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