Geant4  9.6.p02
 All Classes Namespaces Files Functions Variables Typedefs Enumerations Enumerator Friends Macros Groups Pages
g3routines.F
Go to the documentation of this file.
1 *
2 * ********************************************************************
3 * * License and Disclaimer *
4 * * *
5 * * The Geant4 software is copyright of the Copyright Holders of *
6 * * the Geant4 Collaboration. It is provided under the terms and *
7 * * conditions of the Geant4 Software License, included in the file *
8 * * LICENSE and available at http://cern.ch/geant4/license . These *
9 * * include a list of copyright holders. *
10 * * *
11 * * Neither the authors of this software system, nor their employing *
12 * * institutes,nor the agencies providing financial support for this *
13 * * work make any representation or warranty, express or implied, *
14 * * regarding this software system or assume any liability for its *
15 * * use. Please see the license in the file LICENSE and URL above *
16 * * for the full disclaimer and the limitation of liability. *
17 * * *
18 * * This code implementation is the result of the scientific and *
19 * * technical work of the GEANT4 collaboration. *
20 * * By using, copying, modifying or distributing the software (or *
21 * * any work based on the software) you agree to acknowledge its *
22 * * use in resulting scientific publications, and indicate your *
23 * * acceptance of all terms of the Geant4 Software license. *
24 * ********************************************************************
25 *
26 *
27 * $Id: g3routines.F,v 1.5 2006-06-29 18:15:10 gunter Exp $
28 * GEANT4 tag $Name: not supported by cvs2svn $
29 *
30 #define CALL_GEANT
31 
32 #ifndef CALL_GEANT
33  subroutine gsvolu(name, shape, nmed, par, npar, ivol)
34 #else
35  subroutine ksvolu(name, shape, nmed, par, npar, ivol)
36 #endif
37 ************************************************************************
38 ************************************************************************
39  implicit none
40  character name*4, shape*4, fmt*150
41  integer nmed, npar, ivol, k
42  real par(npar)
43  character rname*6
44 #include "G3toG4.inc"
45  data rname /'GSVOLU'/
46 *
47  call check_lines
48 #ifdef CALL_GEANT
49  if (dogeom) call gsvolu(name, shape, nmed, par, npar, ivol)
50 #endif
51  if (npar.ne.0) call checkshape(name, shape, par, npar)
52 *
53  if (lunlist.ne.0) then
54 * write(lunlist,
55 * + '(a4,1x,a6,1x,a4,1x,a4,2i5,<npar>e15.8)')
56 * + context, rname, name, shape, nmed, npar,
57 * + (par(k),k=1,npar)
58  write(fmt,'(A,I2,A)')'(a4,1x,a6,1x,a4,1x,a4,2i5,',max(npar,1),
59  > '(1x,e16.8))'
60  write(lunlist,fmt) context, rname, name, shape, nmed, npar,
61  + (par(k),k=1,npar)
62  endif
63  if (luncode.ne.0) then
64  write(luncode,'(''{'')')
65  call g3ldpar(par,npar)
66  write(luncode,1000) name, shape, nmed, npar
67  1000 format('G4gsvolu(name="',a,'",shape="',a,'",nmed=',i5,
68  + ',par,npar=',i4,');')
69  write(luncode,'(''}'')')
70  endif
71 *
72  end
73 *
74 #ifndef CALL_GEANT
75  subroutine gspos(name, num, moth, x, y, z, irot, only)
76 #else
77  subroutine kspos(name, num, moth, x, y, z, irot, only)
78 #endif
79 ************************************************************************
80 ************************************************************************
81  implicit none
82  character name*4, moth*4, only*4
83  integer num, irot
84  real x, y, z
85  character rname*6
86 #include "G3toG4.inc"
87  data rname /'GSPOS '/
88 *
89  call check_lines
90 #ifdef CALL_GEANT
91  if (dogeom) call gspos(name, num, moth, x, y, z, irot, only)
92 #endif
93  if (lunlist.ne.0) then
94  write(lunlist,
95  + '(a4,1x,a6,1x,a4,i5,1x,a4,3(1x,e16.8),i5,1x,a4)')
96  + context, rname, name, num, moth, x, y, z, irot, only
97  endif
98  if (luncode.ne.0) then
99  write(luncode,'(''{'')')
100  call rtocp('x',x)
101  call rtocp('y',y)
102  call rtocp('z',z)
103  write(luncode,1000) name,num,moth,irot,only
104  1000 format('G4gspos(name="',a,'",num=',i5,',moth="',a,
105  + '",x,y,z,irot=',i5,',only="',a,'");')
106  write(luncode,'(''}'')')
107  endif
108 *
109  end
110 *
111 #ifndef CALL_GEANT
112  subroutine gsposp(name, num, moth, x, y, z, irot, only, par, npar)
113 #else
114  subroutine ksposp(name, num, moth, x, y, z, irot, only, par, npar)
115 #endif
116 ************************************************************************
117 ************************************************************************
118  implicit none
119  character name*4, moth*4, only*4
120  integer num, irot, npar, k
121  real x, y, z, par(npar)
122  character rname*6, fmt*150
123 #include "G3toG4.inc"
124  data rname /'GSPOSP'/
125 *
126  call check_lines
127 #ifdef CALL_GEANT
128  if (dogeom) call gsposp(name, num, moth, x, y, z, irot, only,
129  + par, npar)
130 #endif
131  if (lunlist.ne.0) then
132  do k=1,npar
133  if (abs(par(k)).gt.1.e10) then
134  print *,'Warning: huge junk value in PAR for GSPOS'
135  print *,' zeroed out. Volume ',name
136  par(k) = 0.
137  endif
138  enddo
139 * write(lunlist,
140 * + '(a4,1x,a6,1x,a4,i5,1x,a4,3e15.8,i5,1x,a4,
141 * + i5,<npar>e15.8)')
142 * + context, rname, name, num, moth, x, y, z, irot, only,
143 * + npar,
144 * + (par(k),k=1,npar)
145  write(fmt,'(A,A,I2,A)')
146  > '(a4,1x,a6,1x,a4,i5,1x,a4,3(1x,e16.8),',
147  + 'i5,1x,a4,i5,',max(npar,1),'(1x,e16.8))'
148  write(lunlist,fmt)
149  + context, rname, name, num, moth, x, y, z, irot, only,
150  + npar,
151  + (par(k),k=1,npar)
152  endif
153  if (luncode.ne.0) then
154  write(luncode,'(''{'')')
155  call rtocp('x',x)
156  call rtocp('y',y)
157  call rtocp('z',z)
158  call g3ldpar(par,npar)
159  write(luncode,1000) name,num,moth,irot,only,npar
160  1000 format('G4gsposp(name="',a,'",num=',i5,',moth="',a,
161  + '",x,y,z,irot=',i5,',only="',a,'",par,npar=',i4,');')
162  write(luncode,'(''}'')')
163  endif
164 *
165  end
166 *
167 #ifndef CALL_GEANT
168  subroutine gsatt(name, attr, ival)
169 #else
170  subroutine ksatt(name, attr, ival)
171 #endif
172 ************************************************************************
173 ************************************************************************
174  implicit none
175  character name*4, attr*4
176  integer ival
177  character rname*6
178 #include "G3toG4.inc"
179  data rname /'GSATT '/
180 *
181  call check_lines
182 #ifdef CALL_GEANT
183  if (dogeom) call gsatt(name, attr, ival)
184 #endif
185  if (lunlist.ne.0) then
186  write(lunlist,
187  + '(a4,1x,a6,1x,a4,1x,a4,i12)')
188  + context, rname, name, attr, ival
189  endif
190  if (luncode.ne.0) then
191  write(luncode,'(''{'')')
192  write(luncode,1000) name,attr,ival
193  1000 format('G4gsatt(name="',a,'",attr="',a,'",ival=',i10,');')
194  write(luncode,'(''}'')')
195  endif
196 *
197  end
198 *
199 #ifndef CALL_GEANT
200  subroutine gsrotm(irot, theta1, phi1, theta2, phi2,
201  + theta3, phi3)
202 #else
203  subroutine ksrotm(irot, theta1, phi1, theta2, phi2,
204  + theta3, phi3)
205 #endif
206 ************************************************************************
207 ************************************************************************
208  implicit none
209  integer irot
210  real theta1, phi1, theta2, phi2, theta3, phi3
211  character rname*6
212 #include "G3toG4.inc"
213  data rname /'GSROTM'/
214 *
215  call check_lines
216 #ifdef CALL_GEANT
217  if (dogeom) call gsrotm(irot, theta1, phi1, theta2, phi2,
218  + theta3, phi3)
219 #endif
220  if (lunlist.ne.0) then
221  write(lunlist,
222  + '(a4,1x,a6,i5,6f11.5)')
223  + context, rname, irot, theta1, phi1, theta2, phi2,
224  + theta3, phi3
225  endif
226  if (luncode.ne.0) then
227  write(luncode,'(''{'')')
228  call rtocp('theta1',theta1)
229  call rtocp('phi1',phi1)
230  call rtocp('theta2',theta2)
231  call rtocp('phi2',phi2)
232  call rtocp('theta3',theta3)
233  call rtocp('phi3',phi3)
234  write(luncode,1000) irot
235  1000 format('G4gsrotm(irot=',i5,
236  + ',theta1,phi1,theta2,phi2,theta3,phi3);')
237  write(luncode,'(''}'')')
238  endif
239 *
240  end
241 *
242 #ifndef CALL_GEANT
243  subroutine gsdvn(name, moth, ndiv, iaxis)
244 #else
245  subroutine ksdvn(name, moth, ndiv, iaxis)
246 #endif
247 ************************************************************************
248 ************************************************************************
249  implicit none
250  character name*4, moth*4
251  integer ndiv, iaxis
252  character rname*6
253 #include "G3toG4.inc"
254  data rname /'GSDVN '/
255 *
256  call check_lines
257 #ifdef CALL_GEANT
258  if (dogeom) call gsdvn(name, moth, ndiv, iaxis)
259 #endif
260  if (lunlist.ne.0) then
261  write(lunlist,
262  + '(a4,1x,a6,1x,a4,1x,a4,i5,i3)')
263  + context, rname, name, moth, ndiv, iaxis
264  endif
265  if (luncode.ne.0) then
266  write(luncode,'(''{'')')
267  write(luncode,1000) name, moth, ndiv, iaxis
268  1000 format('G4gsdvn(name="',a,'",moth="',a,'",ndiv=',i3,
269  + ',iaxis=',i1,');')
270  write(luncode,'(''}'')')
271  endif
272 *
273  end
274 *
275 #ifndef CALL_GEANT
276  subroutine gsdvt(name, moth, step, iaxis, numed, ndvmx)
277 #else
278  subroutine ksdvt(name, moth, step, iaxis, numed, ndvmx)
279 #endif
280 ************************************************************************
281 ************************************************************************
282  implicit none
283  character name*4, moth*4
284  real step
285  integer iaxis, numed, ndvmx
286  character rname*6
287 #include "G3toG4.inc"
288  data rname /'GSDVT '/
289 *
290  call check_lines
291 #ifdef CALL_GEANT
292  if (dogeom) call gsdvt(name, moth, step, iaxis, numed, ndvmx)
293 #endif
294  if (lunlist.ne.0) then
295  write(lunlist,
296  + '(a4,1x,a6,1x,a4,1x,a4,(1x,e16.8),3i5)')
297  + context, rname, name, moth, step, iaxis, numed, ndvmx
298  endif
299  if (luncode.ne.0) then
300  write(luncode,'(''{'')')
301  call rtocp('step',step)
302  write(luncode,1000) name,moth,iaxis,numed,ndvmx
303  1000 format('G4gsdvt(name="',a,'",moth="',a,'",step,iaxis=',
304  + i1,',numed=',i4,',ndvmx=',i4,');')
305  write(luncode,'(''}'')')
306  endif
307 *
308  end
309 *
310 #ifndef CALL_GEANT
311  subroutine gsdvx(name, moth, ndiv, iaxis, step, c0, numed, ndvmx)
312 #else
313  subroutine ksdvx(name, moth, ndiv, iaxis, step, c0, numed, ndvmx)
314 #endif
315 ************************************************************************
316 ************************************************************************
317  implicit none
318  character name*4, moth*4
319  integer ndiv, iaxis, numed, ndvmx
320  real step, c0
321  character rname*6
322 #include "G3toG4.inc"
323  data rname /'GSDVX '/
324 *
325  call check_lines
326 #ifdef CALL_GEANT
327  if (dogeom) call gsdvx(name, moth, ndiv, iaxis, step, c0, numed,
328  + ndvmx)
329 #endif
330  if (lunlist.ne.0) then
331  write(lunlist,
332  + '(a4,1x,a6,1x,a4,1x,a4,i5,i3,2(1x,e16.8),2i5)')
333  + context, rname, name, moth, ndiv, iaxis,step, c0,
334  + numed, ndvmx
335  endif
336  if (luncode.ne.0) then
337  write(luncode,'(''{'')')
338  call rtocp('step',step)
339  call rtocp('c0',c0)
340  write(luncode,1000) name,moth,ndiv,iaxis,numed,ndvmx
341  1000 format('G4gsdvx(name="',a,'",moth="',a,'",ndiv=',i3,',iaxis=',
342  + i1,',step,c0,numed=',i4,',ndvmx=',i4,');')
343  write(luncode,'(''}'')')
344  endif
345 *
346  end
347 *
348 #ifndef CALL_GEANT
349  subroutine gsdvn2(name, moth, ndiv, iaxis, c0, numed)
350 #else
351  subroutine ksdvn2(name, moth, ndiv, iaxis, c0, numed)
352 #endif
353 ************************************************************************
354 ************************************************************************
355  implicit none
356  character name*4, moth*4
357  integer ndiv, iaxis, numed
358  real c0
359  character rname*6
360 #include "G3toG4.inc"
361  data rname /'GSDVN2'/
362 *
363  call check_lines
364 #ifdef CALL_GEANT
365  if (dogeom) call gsdvn2(name, moth, ndiv, iaxis, c0, numed)
366 #endif
367  if (lunlist.ne.0) then
368  write(lunlist,
369  + '(a4,1x,a6,1x,a4,1x,a4,i5,i3,(1x,e16.8),i5)')
370  + context, rname, name, moth, ndiv, iaxis, c0, numed
371  endif
372  if (luncode.ne.0) then
373  write(luncode,'(''{'')')
374  call rtocp('c0',c0)
375  write(luncode, 1000) name,moth,ndiv,iaxis,numed
376  1000 format('G4gsdvn2(name="',a,'",moth="',a,'",ndiv=',i3,',iaxis=',
377  + i1,',c0,numed=',i4,');')
378  write(luncode,'(''}'')')
379  endif
380 *
381  end
382 *
383 #ifndef CALL_GEANT
384  subroutine gsdvt2(name, moth, step, iaxis, c0, numed, ndvmx)
385 #else
386  subroutine ksdvt2(name, moth, step, iaxis, c0, numed, ndvmx)
387 #endif
388 ************************************************************************
389 ************************************************************************
390  implicit none
391  character name*4, moth*4
392  integer iaxis, numed, ndvmx
393  real step, c0
394  character rname*6
395 #include "G3toG4.inc"
396  data rname /'GSDVT2'/
397 *
398  call check_lines
399 #ifdef CALL_GEANT
400  if (dogeom) call gsdvt2(name, moth, step, iaxis, c0, numed, ndvmx)
401 #endif
402  if (lunlist.ne.0) then
403  write(lunlist,
404  + '(a4,1x,a6,1x,a4,1x,a4,(1x,e16.8),i3,(1x,e16.8),2i5)')
405  + context, rname, name, moth, step, iaxis, c0, numed, ndvmx
406  endif
407  if (luncode.ne.0) then
408  write(luncode,'(''{'')')
409  call rtocp('step',step)
410  call rtocp('c0',c0)
411  write(luncode,1000) name,moth,iaxis,numed,ndvmx
412  1000 format('G4gsdvt2(name="',a,'",moth="',a,'",step,iaxis=',
413  + i1,',c0,numed=',i4,',ndvmx=',i4,');')
414  write(luncode,'(''}'')')
415  endif
416 *
417  end
418 *
419 #ifndef CALL_GEANT
420  subroutine gsmate(imate, name, a, z, dens, radl, absl, ubf, nwbf)
421 #else
422  subroutine ksmate(imate, name, a, z, dens, radl, absl, ubf, nwbf)
423 #endif
424 ************************************************************************
425 ************************************************************************
426  implicit none
427  character name*(*)
428  integer imate, nwbf, k
429  real a, z, dens, radl, absl, ubf(nwbf)
430  character rname*6, fmt*150
431 #include "G3toG4.inc"
432  data rname /'GSMATE'/
433 *
434  call check_lines
435 #ifdef CALL_GEANT
436  if (dogeom) call gsmate
437  + (imate, name, a, z, dens, radl, absl, ubf, nwbf)
438 #endif
439  if (lunlist.ne.0) then
440  write(fmt,'(A,I3,A)')
441  > '(a4,1x,a6,i5,1x,''"'',a,''"'',4(1x,e16.8),i3,',
442  > max(nwbf,1),'(1x,e16.8))'
443  write(lunlist,fmt)
444  + context, rname, imate, name, a, z, dens, radl,
445  + nwbf, (ubf(k), k=1,nwbf)
446  endif
447  if (luncode.ne.0) then
448  write(luncode,'(''{'')')
449  call rtocp('a',a)
450  call rtocp('z',z)
451  call rtocp('dens',dens)
452  call rtocp('radl',radl)
453  call g3ldpar(ubf,nwbf)
454  write(luncode,1000) imate, name, nwbf
455  1000 format('G4gsmate(imate=',i4,',name="',a,
456  + '",a,z,dens,radl,npar=',i4,',par);')
457  write(luncode,'(''}'')')
458  endif
459 *
460  end
461 *
462 #ifndef CALL_GEANT
463  subroutine gsmixt(imate, name, a, z, dens, nlmat, wmat)
464 #else
465  subroutine ksmixt(imate, name, a, z, dens, nlmat, wmat)
466 #endif
467 ************************************************************************
468 ************************************************************************
469  implicit none
470  character name*(*)
471  integer imate, nlmat, k, nlmata
472  real a(*), z(*), dens, wmat(*)
473  character rname*6, fmt*150
474 #include "G3toG4.inc"
475  data rname /'GSMIXT'/
476 *
477  call check_lines
478 #ifdef CALL_GEANT
479  if (dogeom) call gsmixt
480  + (imate, name, a, z, dens, nlmat, wmat)
481 #endif
482  if (lunlist.ne.0) then
483  nlmata = abs(nlmat)
484  write(fmt,'(A,I3,A,I3,A,I3,A)')
485  + '(a4,1x,a6,i5,1x,''"'',a,''"'',1x,e16.8,1x,i3,',
486  > max(nlmata,1),
487  > '(1x,e16.8),',max(nlmata,1),'(1x,e16.8),',
488  > max(nlmata,1),'(1x,e16.8))'
489  write(lunlist,fmt)
490  + context, rname, imate, name, dens,
491  + nlmat,
492  + (a(k), k=1,abs(nlmat)),
493  + (z(k), k=1,abs(nlmat)),
494  + (wmat(k), k=1,abs(nlmat))
495  endif
496  if (luncode.ne.0) then
497  write(luncode,'(''{'')')
498  call rtocp('dens',dens)
499  call artocp('aa',a,abs(nlmat))
500  call artocp('zz',z,abs(nlmat))
501  call artocp('wmat',wmat,abs(nlmat))
502  write(luncode,1000) imate,name,nlmat
503  1000 format('G4gsmixt(imate=',i5,',name="',a,
504  + '",aa,zz,dens,nlmat=',i3,',wmat);')
505  write(luncode,'(''}'')')
506  endif
507 *
508  end
509 *
510 #ifndef CALL_GEANT
511  subroutine gstmed(
512  + itmed, name, nmat, isvol, ifield, fieldm,
513  + tmaxfd, stemax, deemax, epsil, stmin, ubuf, nwbuf)
514 #else
515  subroutine kstmed(
516  + itmed, name, nmat, isvol, ifield, fieldm,
517  + tmaxfd, stemax, deemax, epsil, stmin, ubuf, nwbuf)
518 #endif
519 ************************************************************************
520 ************************************************************************
521  implicit none
522  character name*(*)
523  integer itmed, nmat, isvol, ifield, nwbuf, k
524  real fieldm, tmaxfd, stemax, deemax, epsil, stmin, ubuf(nwbuf)
525  character rname*6, fmt*150
526 #include "G3toG4.inc"
527  data rname /'GSTMED'/
528 *
529  call check_lines
530 #ifdef CALL_GEANT
531  if (dogeom) call gstmed(
532  + itmed, name, nmat, isvol, ifield, fieldm,
533  + tmaxfd, stemax, deemax, epsil, stmin, ubuf, nwbuf)
534 #endif
535  if (lunlist.ne.0) then
536 * write(lunlist,
537 * + '(a4,1x,a6,i5,1x,''"'',a,''"'',3i3,6e15.8,i3,<nwbuf>e15.8)')
538 * + context, rname, itmed, name, nmat, isvol, ifield, fieldm,
539 * + tmaxfd, stemax, deemax, epsil, stmin,
540 * + nwbuf, (ubuf(k),k=1,nwbuf)
541  write(fmt,'(A,I3,A)')
542  > '(a4,1x,a6,i5,1x,''"'',a,''"'',3i3,6(1x,e16.8),i3,',
543  > max(nwbuf,1),'(1x,e16.8))'
544  write(lunlist,fmt)
545  + context, rname, itmed, name, nmat, isvol, ifield, fieldm,
546  + tmaxfd, stemax, deemax, epsil, stmin,
547  + nwbuf, (ubuf(k),k=1,nwbuf)
548  endif
549  if (luncode.ne.0) then
550  write(luncode,'(''{'')')
551  call rtocp('fieldm',fieldm)
552  call rtocp('tmaxfd',tmaxfd)
553  call rtocp('stemax',stemax)
554  call rtocp('deemax',deemax)
555  call rtocp('epsil',epsil)
556  call rtocp('stmin',stmin)
557  call g3ldpar(ubuf,nwbuf)
558  write(luncode,1000) itmed,name,nmat,isvol,ifield,nwbuf
559  1000 format('G4gstmed(itmed=',i4,',name="',a,'",nmat=',i4,
560  + ',isvol=',i2,',ifield=',i2,',',/
561  + ' fieldm,tmaxfd,stemax,deemax,epsil,stmin,par,npar=',
562  + i4,');')
563  write(luncode,'(''}'')')
564  endif
565 *
566  end
567 *
568 #ifndef CALL_GEANT
569  subroutine gstpar(itmed, chpar, parval)
570 #else
571  subroutine kstpar(itmed, chpar, parval)
572 #endif
573 ************************************************************************
574 ************************************************************************
575  implicit none
576  character chpar*(*)
577  integer itmed
578  real parval
579  character rname*6
580 #include "G3toG4.inc"
581  data rname /'GSTPAR'/
582 *
583  call check_lines
584 #ifdef CALL_GEANT
585  if (dogeom) call gstpar(itmed, chpar, parval)
586 #endif
587  if (lunlist.ne.0) then
588  write(lunlist,
589  + '(a4,1x,a6,i5,1x,a4,(1x,e16.8))')
590  + context, rname, itmed, chpar, parval
591  endif
592  if (luncode.ne.0) then
593  write(luncode,'(''{'')')
594  write(luncode,1000) itmed, chpar, parval
595  1000 format('G4gstpar(itmed=',i4,',chpar="',a,'",parval=',
596  + (1x,e16.8),');')
597  write(luncode,'(''}'')')
598  endif
599 *
600  end
601 *
602 #ifndef CALL_GEANT
603  subroutine gspart(
604  + ipart, chpar, itrtyp, amass, charge, tlife, ub, nwb)
605 #else
606  subroutine kspart(
607  + ipart, chpar, itrtyp, amass, charge, tlife, ub, nwb)
608 #endif
609 ************************************************************************
610 ************************************************************************
611  implicit none
612  character chpar*(*)
613  integer ipart, itrtyp, nwb, k
614  real amass, charge, tlife, ub(nwb)
615  character rname*6, fmt*150
616 #include "G3toG4.inc"
617  data rname /'GSPART'/
618 *
619  call check_lines
620 #ifdef CALL_GEANT
621  if (dogeom) call gspart(
622  + ipart, chpar, itrtyp, amass, charge, tlife, ub, nwb)
623 #endif
624  if (lunlist.ne.0) then
625 * write(lunlist,
626 * + '(a4,1x,a6,i5,1x,''"'',a,''"'',i3,3e15.8,i3,<nwb>e15.8)')
627 * + context, rname, ipart, chpar, itrtyp, amass, charge, tlife,
628 * + nwb, (ub(k), k=1,nwb)
629  write(fmt,'(A,I3,A)')
630  > '(a4,1x,a6,i5,1x,''"'',a,''"'',i3,3(1x,e16.8),i3,',
631  > max(nwb,1),'(1x,e16.8))'
632  write(lunlist,fmt)
633  + context, rname, ipart, chpar, itrtyp, amass, charge,
634  > tlife,
635  + nwb, (ub(k), k=1,nwb)
636  endif
637  if (luncode.ne.0) then
638  write(luncode,'(''{'')')
639  call rtocp('amass',amass)
640  call rtocp('charge',charge)
641  call rtocp('tlife',tlife)
642  call g3ldpar(ub,nwb)
643  write(luncode,1000) ipart,chpar,itrtyp,nwb
644  1000 format('G4gspart(ipart=',i8,',chpar="',a,'",itrtyp=',i8,
645  + ',amass,charge,'/' tlife,par,npar=',i4,');')
646  write(luncode,'(''}'')')
647  endif
648 *
649  end
650 *
651 #ifndef CALL_GEANT
652  subroutine gsdk(ipart, bratio, mode)
653 #else
654  subroutine ksdk(ipart, bratio, mode)
655 #endif
656 ************************************************************************
657 ************************************************************************
658  implicit none
659  integer ipart, mode(6)
660  real bratio(6)
661  character rname*6
662 #include "G3toG4.inc"
663  data rname /'GSDK '/
664 *
665  call check_lines
666 #ifdef CALL_GEANT
667  if (dogeom) call gsdk(ipart, bratio, mode)
668 #endif
669  if (lunlist.ne.0) then
670 *** 6 is prefixed to the arrays for consistency with other
671 *** array treatments (count precedes the array)
672  write(lunlist,
673  + '(a4,1x,a6,i5,i3,6(1x,e16.8),6i8)')
674  + context, rname, ipart, 6, bratio, mode
675  endif
676  if (luncode.ne.0) then
677  write(luncode,'(''{'')')
678  call artocp('bratio',bratio,6)
679  call aitocp('mode',mode,6)
680  write(luncode,1000) ipart
681  1000 format('G4gsdk(ipart=',i8,',bratio,mode);')
682  write(luncode,'(''}'')')
683  endif
684 *
685  end
686 *
687 #ifndef CALL_GEANT
688  subroutine gsdet(chset, chdet, nv, chnam, nbits, idtyp, nwhi,
689  + nwdi, iset, idet)
690 #else
691  subroutine ksdet(chset, chdet, nv, chnam, nbits, idtyp, nwhi,
692  + nwdi, iset, idet)
693 #endif
694 ************************************************************************
695 ************************************************************************
696  implicit none
697  integer nv, nbits(nv), idtyp, nwhi, nwdi, iset, idet, k
698  character rname*6, chset*4, chdet*4, chnam(nv)*4, fmt*150
699 #include "G3toG4.inc"
700  data rname /'GSDET '/
701 *
702  call check_lines
703 #ifdef CALL_GEANT
704  if (dogeom) call gsdet(chset, chdet, nv, chnam, nbits, idtyp,
705  + nwhi, nwdi, iset, idet)
706 #endif
707  if (lunlist.ne.0) then
708 * write(lunlist,
709 * + '(a4,1x,a6,1x,a4,1x,a4,i5,<nv>(1x,a4),<nv>i10,i10,2i5)')
710 * + context, rname, chset, chdet, nv, (chnam(k), k=1,nv),
711 * + (nbits(k), k=1,nv), idtyp, nwhi, nwdi
712  write(fmt,'(A,I3,A,I3,A)')'(a4,1x,a6,1x,a4,1x,a4,i5,',
713  > max(nv,1),'(1x,a4),',max(nv,1),'i10,i10,2i5)'
714  write(lunlist,fmt)
715  + context, rname, chset, chdet, nv, (chnam(k), k=1,nv),
716  + (nbits(k), k=1,nv), idtyp, nwhi, nwdi
717  endif
718  if (luncode.ne.0) then
719  write(luncode,'(''{'')')
720  call astocp('chnam',chnam,nv)
721  call aitocp('nbits',nbits,nv)
722  write(luncode,1000) chset, chdet, nv, idtyp, nwhi, nwdi
723  1000 format('G4gsdet(chset="',a,'",chdet="',a,'",nv=',i3,
724  + ',chnam,nbits,idtyp=',i8,','/
725  + ' nwhi=',i8,',nwdi=',i8,');')
726  write(luncode,'(''}'')')
727  endif
728 *
729  end
730 *
731 #ifndef CALL_GEANT
732  subroutine gsdetv(chset, chdet, idtyp, nwhi, nwdi, iset, idet)
733 #else
734  subroutine ksdetv(chset, chdet, idtyp, nwhi, nwdi, iset, idet)
735 #endif
736 ************************************************************************
737 ************************************************************************
738  implicit none
739  integer idtyp, nwhi, nwdi, iset, idet
740  character rname*6, chset*4, chdet*4
741 #include "G3toG4.inc"
742  data rname /'GSDETV'/
743 *
744  call check_lines
745 #ifdef CALL_GEANT
746  if (dogeom) call gsdetv(chset, chdet, idtyp,
747  + nwhi, nwdi, iset, idet)
748 #endif
749  if (lunlist.ne.0) then
750  write(lunlist,
751  + '(a4,1x,a6,1x,a4,1x,a4,i10,2i5)')
752  + context, rname, chset, chdet, idtyp, nwhi, nwdi
753  endif
754  if (luncode.ne.0) then
755  write(luncode,'(''{'')')
756  write(luncode,1000) chset, chdet, idtyp, nwhi, nwdi
757  1000 format('G4gsdetv(chset="',a,'",chdet="',a,'",idtyp=',i8,
758  + ',nwhi=',i8,',nwdi=',i8,');')
759  write(luncode,'(''}'')')
760  endif
761 *
762  end
763 *
764 #ifndef CALL_GEANT
765  subroutine gsdeta(chset, chdet, chali, nwhi, nwdi, iali)
766 #else
767  subroutine ksdeta(chset, chdet, chali, nwhi, nwdi, iali)
768 #endif
769 ************************************************************************
770 ************************************************************************
771  implicit none
772  integer nwhi, nwdi, iali
773  character rname*6, chset*4, chdet*4, chali*4
774 #include "G3toG4.inc"
775  data rname /'GSDETA'/
776 *
777  call check_lines
778 #ifdef CALL_GEANT
779  if (dogeom) call gsdeta(chset, chdet, chali, nwhi, nwdi, iali)
780 #endif
781  if (lunlist.ne.0) then
782  write(lunlist,
783  + '(a4,1x,a6,1x,a4,1x,a4,1x,a4,2i5)')
784  + context, rname, chset, chdet, chali, nwhi, nwdi
785  endif
786  if (luncode.ne.0) then
787  write(luncode,'(''{'')')
788  write(luncode,1000) chset, chdet, chali, nwhi, nwdi
789  1000 format('G4gsdeta(chset="',a,'",chdet="',a,'",chali="',a,
790  + '",nwhi=',i8,',nwdi=',i8,');')
791  write(luncode,'(''}'')')
792  endif
793 *
794  end
795 *
796 #ifndef CALL_GEANT
797  subroutine gsdeth(chset, chdet, nh, chnam, nbits, orig, fact)
798 #else
799  subroutine ksdeth(chset, chdet, nh, chnam, nbits, orig, fact)
800 #endif
801 ************************************************************************
802 ************************************************************************
803  implicit none
804  integer nh, nbits(nh), k
805  real orig(nh), fact(nh)
806  character rname*6, chset*4, chdet*4, chnam(nh)*4, fmt*150
807 #include "G3toG4.inc"
808  data rname /'GSDETH'/
809 *
810  call check_lines
811 #ifdef CALL_GEANT
812  if (dogeom) call gsdeth(chset, chdet, nh, chnam, nbits,
813  + orig, fact)
814 #endif
815  if (lunlist.ne.0) then
816 * write(lunlist,
817 * + '(a4,1x,a6,1x,a4,1x,a4,i5,<nh>(1x,a4),<nh>i5,<nh>e15.8,
818 * + <nh>e15.8)')
819 * + context, rname, chset, chdet, nh, (chnam(k), k=1,nh),
820 * + (nbits(k), k=1,nh), (orig(k), k=1,nh), (fact(k), k=1,nh)
821  write(fmt,'(A,I3,A,I3,A,I3,A,I3,A)')
822  > '(a4,1x,a6,1x,a4,1x,a4,i5,',max(nh,1),'(1x,a4),',
823  > max(nh,1),'i5,',max(nh,1),'(1x,e16.8),',max(nh,1),
824  > '(1x,e16.8))'
825  write(lunlist, fmt)
826  + context, rname, chset, chdet, nh, (chnam(k), k=1,nh),
827  + (nbits(k), k=1,nh), (orig(k), k=1,nh), (fact(k), k=1,nh)
828  endif
829  if (luncode.ne.0) then
830  write(luncode,'(''{'')')
831  call astocp('chnam',chnam,nh)
832  call aitocp('nbits',nbits,nh)
833  call artocp('orig',orig,nh)
834  call artocp('fact',fact,nh)
835  write(luncode,1000) chset,chdet,nh
836  1000 format('G4gsdeth(chset="',a,'",chdet="',a,'",nh=',i4,
837  + ',chnam,nbits,orig,fact);')
838  write(luncode,'(''}'')')
839  endif
840 *
841  end
842 *
843 #ifndef CALL_GEANT
844  subroutine gsdetd(chset, chdet, nd, chnam, nbits)
845 #else
846  subroutine ksdetd(chset, chdet, nd, chnam, nbits)
847 #endif
848 ************************************************************************
849 ************************************************************************
850  implicit none
851  integer nd, nbits(nd), k
852  character rname*6, chset*4, chdet*4, chnam(nd)*4, fmt*150
853 #include "G3toG4.inc"
854  data rname /'GSDETD'/
855 *
856  call check_lines
857 #ifdef CALL_GEANT
858  if (dogeom) call gsdetd(chset, chdet, nd, chnam, nbits)
859 #endif
860  if (lunlist.ne.0) then
861 * write(lunlist,
862 * + '(a4,1x,a6,1x,a4,1x,a4,i5,<nd>(1x,a4),<nd>i5)')
863 * + context, rname, chset, chdet, nd, (chnam(k), k=1,nd),
864 * + (nbits(k), k=1,nd)
865  write(fmt,'(A,I3,A,I3,A)')
866  + '(a4,1x,a6,1x,a4,1x,a4,i5,',max(nd,1),'(1x,a4),',
867  > max(nd,1),'i5)'
868  write(lunlist,fmt)
869  + context, rname, chset, chdet, nd, (chnam(k), k=1,nd),
870  + (nbits(k), k=1,nd)
871  endif
872  if (luncode.ne.0) then
873  write(luncode,'(''{'')')
874  call astocp('chnam',chnam,nd)
875  call aitocp('nbits',nbits,nd)
876  write(luncode,1000) chset, chdet, nd
877  1000 format('G4gsdetd(chset="',a,'",chdet="',a,'",nd=',i4,
878  + ',chnam,nbits);')
879  write(luncode,'(''}'')')
880  endif
881 *
882  end
883 *
884 #ifndef CALL_GEANT
885  subroutine gsdetu(chset, chdet, nupar, upar)
886 #else
887  subroutine ksdetu(chset, chdet, nupar, upar)
888 #endif
889 ************************************************************************
890 ************************************************************************
891  implicit none
892  integer nupar, k
893  real upar(nupar)
894  character rname*6, chset*4, chdet*4, fmt*150
895 #include "G3toG4.inc"
896  data rname /'GSDETU'/
897 *
898  call check_lines
899 #ifdef CALL_GEANT
900  if (dogeom) call gsdetu(chset, chdet, nupar, upar)
901 #endif
902  if (lunlist.ne.0) then
903 * write(lunlist,
904 * + '(a4,1x,a6,1x,a4,1x,a4,i5,<nupar>e15.8)')
905 * + context, rname, chset, chdet, nupar, (upar(k), k=1,nupar)
906  write(fmt,'(A,I3,A)')
907  + '(a4,1x,a6,1x,a4,1x,a4,i5,',max(nupar,1),'(1x,e16.8))'
908  write(lunlist,fmt)
909  + context, rname, chset, chdet, nupar, (upar(k), k=1,nupar)
910  endif
911  if (luncode.ne.0) then
912  write(luncode,'(''{'')')
913  call g3ldpar(upar,nupar)
914  write(luncode,1000) chset, chdet, nupar
915  1000 format('G4gsdetu(chset="',a,'",chdet="',a,'",npar=',
916  + i4,',par);')
917  write(luncode,'(''}'')')
918  endif
919 *
920  end
921 *
922 #ifndef CALL_GEANT
923  subroutine ggclos
924 #else
925  subroutine kgclos
926 #endif
927 ************************************************************************
928 ************************************************************************
929  implicit none
930  character rname*6
931 #include "G3toG4.inc"
932  data rname /'GGCLOS'/
933 *
934  call check_lines
935 #ifdef CALL_GEANT
936  if (dogeom) call ggclos
937 #endif
938  if (lunlist.ne.0) then
939  write(lunlist,'(a4,1x,a6)') context, rname
940  close(lunlist)
941  endif
942  if (luncode.ne.0) then
943  write(luncode,'(''//GeoMgr->CloseGeometry();'')')
944  write(luncode,'(''}'')')
945  call g3main
946  close(luncode)
947  endif
948 *
949  end
950 
951  subroutine checkshape(name, shape, par, npar)
952  implicit none
953 ************************************************************************
954 * convert TRAP, PARA and GTRA to external form
955 ************************************************************************
956  character name*4, shape*4
957  real ph, par(*), tt, raddeg
958  integer npar
959 
960  raddeg = 180./3.1415926
961 
962  if (shape(1:3).eq.'BOX'.and.npar.ne.3) then
963  print *,'!! error, BOX with ',npar,' parameters, vol ',name
964  endif
965  if (shape.eq.'TRD1'.and.npar.ne.4) then
966  print *,'!! error, TRD1 with ',npar,' parameters, vol ',name
967  endif
968  if (shape.eq.'TRD2'.and.npar.ne.5) then
969  print *,'!! error, TRD2 with ',npar,' parameters, vol ',name
970  endif
971  if (shape.eq.'TRAP'.and.npar.ne.35.and.npar.ne.11) then
972 *** G3 sets 11 to 35. Why?
973  print *,'!! error, TRAP with ',npar,' parameters, vol ',name
974  endif
975  if (shape.eq.'TUBE'.and.npar.ne.3) then
976  print *,'!! error, TUBE with ',npar,' parameters, vol ',name
977  endif
978  if (shape.eq.'TUBS'.and.npar.ne.5) then
979  print *,'!! error, TUBS with ',npar,' parameters, vol ',name
980  endif
981  if (shape.eq.'CONE'.and.npar.ne.5) then
982  print *,'!! error, CONE with ',npar,' parameters, vol ',name
983  endif
984  if (shape.eq.'CONS'.and.npar.ne.7) then
985  print *,'!! error, CONS with ',npar,' parameters, vol ',name
986  endif
987  if (shape.eq.'SPHE'.and.npar.ne.6) then
988  print *,'!! error, SPHE with ',npar,' parameters, vol ',name
989  endif
990  if (shape.eq.'PARA'.and.npar.ne.6) then
991  print *,'!! error, PARA with ',npar,' parameters, vol ',name
992  endif
993  if (shape.eq.'PARA') then
994 *
995 * ** PARA
996 *
997  ph = 0.
998  if (par(5).ne.0.) ph = atan2(par(6),par(5))*raddeg
999  tt = sqrt(par(5)**2+par(6)**2)
1000  par(4) = atan(par(4))*raddeg
1001  if (par(4).gt.90.0) par(4) = par(4)-180.0
1002  par(5) = atan(tt)*raddeg
1003  if (ph.lt.0.0) ph = ph + 360.0
1004  par(6) = ph
1005  end if
1006  if (shape.eq.'TRAP') then
1007 *
1008 * ** TRAP
1009 *
1010  npar=11
1011  ph = 0.
1012  if (par(2).ne.0.) ph = atan2(par(3),par(2))*raddeg
1013  tt = sqrt(par(2)**2+par(3)**2)
1014  par(2) = atan(tt)*raddeg
1015  if (ph.lt.0.0) ph = ph+360.0
1016  par(3) = ph
1017  par(7) = atan(par(7))*raddeg
1018  if (par(7).gt.90.0) par(7) = par(7)-180.0
1019  par(11)= atan(par(11))*raddeg
1020  if (par(11).gt.90.0) par(11) = par(11)-180.0
1021 
1022  end if
1023  end
Generated on Sat May 25 2013 14:33:09 for Geant4 by   doxygen 1.8.4