Geant4  9.6.p02
 All Classes Namespaces Files Functions Variables Typedefs Enumerations Enumerator Friends Macros Groups Pages
tog4.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: tog4.F,v 1.5 2006-06-29 18:15:21 gunter Exp $
28 * GEANT4 tag $Name: not supported by cvs2svn $
29 *
30  subroutine tog4
31 ************************************************************************
32 *
33 * tog4
34 *
35 * Perform the translation to G4
36 *
37 ************************************************************************
38  implicit none
39 #include "gcbank.inc"
40  integer maxdivols
41  parameter(maxdivols=20000)
42  integer nvol, nrotm, nmate, ntmed, nset, i, jma, nmixt, k, nin,
43  > jdiv, jd, iaxis, ivo, ndiv, numed, npar, natt, ivol, jin,
44  > nparv, npard, nr, irot, konly, nwbuf, isvol, nmat, ifield,
45  > nbits(5000), idtyp, nwhi, nwdi, iset, idet, j, in, jmx,
46  > jdh, jdd, jdu, ndet, nn, nupar, npos, ndvol, ndivols, ii,
47  > npositioned, iia(10000), imate, smixt
48 
49  real c0, step, x, y, z, a, dens, radl, absl, fact(5000),
50  > fieldm, tmaxfd, stemax, deemax, epsil, stmin, orig(5000),
51  > upar(5000)
52 
53  character shape*4, name*4, dname*4, chonly*4, chmat*20, chtmed*20,
54  > chset*4, chdet*4, chnms(5000)*4, divols(maxdivols)*4
55 *
56  npositioned = 0
57 *
58 *** count materials and convert
59  call bankcnt(jmate,iia, nmate)
60  print *,'Materials: ',nmate
61  do imate=1,nmate
62  ii=iia(imate)
63  jma = lq(jmate-ii)
64  call uhtoc(iq(jma+1),4,chmat,20)
65  a = q(jma+6)
66  z = q(jma+7)
67  dens = q(jma+8)
68  radl = q(jma+9)
69  absl = q(jma+10)
70  nwbuf = iq(jma-1)-11
71  if (jma.gt.0) then
72  smixt=q(jma+11)
73  nmixt=abs(smixt)
74  if (nmixt.le.1) then
75  write(6,101) imate, chmat, a, z, dens, radl, absl
76  call ksmate(ii, chmat, a, z, dens, radl, absl,
77  > q(jma+12), nwbuf)
78  else
79  jmx = lq(jma-5)
80  write(6,102) imate, chmat, a, z, dens, radl, absl,
81  > (j,q(jmx+j),q(jmx+nmixt+j),q(jmx+2*nmixt+j),
82  > j=1,nmixt)
83  call ksmixt(ii, chmat, q(jmx+1), q(jmx+nmixt+1),
84  > dens, smixt, q(jmx+2*nmixt+1))
85  end if
86  end if
87  enddo
88  101 format(1x,i5,1x,a12,f6.2,f5.1,f8.2,2f9.2)
89  102 format(1x,i5,1x,a12,f6.2,f5.1,f8.2,2f9.2,1x,i2, f6.2, f5.1,
90  > f6.2/(57x, i2, f6.2, f5.1, f6.2))
91 *
92 *** count tracking media and convert
93  call bankcnt(jtmed,iia, ntmed)
94  print *,'Media: ',ntmed
95  do i=1,ntmed
96  ii=iia(i)
97  j = lq(jtmed-ii)
98  call uhtoc(iq(j+1),4,chtmed,20)
99  nmat = q(j+6)
100  isvol = q(j+7)
101  ifield = q(j+8)
102  fieldm = q(j+9)
103  tmaxfd = q(j+10)
104  stemax = q(j+11)
105  deemax = q(j+12)
106  epsil = q(j+13)
107  stmin = q(j+14)
108  nwbuf = iq(j-1) -14
109  call kstmed(ii,chtmed,nmat,isvol,ifield,fieldm,tmaxfd,stemax,
110  + deemax,epsil,stmin,q(j+15),nwbuf)
111  enddo
112 *
113 *** count rotation matrices and convert
114  call bankcnt(jrotm,iia, nrotm)
115  print *,'Rotms: ',nrotm
116  do i=1,nrotm
117  ii=iia(i)
118  j = lq(jrotm-ii)
119  call ksrotm(ii,q(j+11),q(j+12),q(j+13),q(j+14),q(j+15),q(j+16))
120  enddo
121 *
122 *** count volumes
123  npos = 0
124  call bankcnt(jvolum,iia, nvol)
125  print *,'Volumes: ',nvol
126 *** pull out the names of the volumes which are subvolumes of
127 *** divided volumes (gsvolu should not be called on these)
128  ndivols = 0
129  do i=1, nvol
130  ii=iia(i)
131  j = lq(jvolum-ii)
132  nin = q(j+3)
133  if (nin.lt.0) then
134  jdiv = lq(j-1)
135  ivo = q(jdiv+2)
136  call uhtoc(iq(jvolum+ivo),4,dname,4)
137  ndivols = ndivols +1
138  if (ndivols.gt.maxdivols) then
139  ndivols = maxdivols
140  print *,
141  + '!!!ERROR!!! ndivols array exhausted. ',
142  + 'Too many divisions.'
143  endif
144  divols(ndivols) = dname
145  endif
146  enddo
147 *** create the logical volumes (gsvolu)
148  ndvol = 0
149  do i=1, nvol
150  ii=iia(i)
151  j = lq(jvolum-ii)
152  call uhtoc(iq(jvolum+ii),4,name,4)
153  call jshape(q(j+2),shape)
154  nin = q(j+3)
155  numed = q(j+4)
156  npar = q(j+5)
157  natt = q(j+6)
158  do k=1, ndivols
159  if (divols(k).eq.name) then
160  ndvol = ndvol +1
161 c print *,'Division volume ',name,'; no gsvolu call.'
162  goto 11
163  endif
164  enddo
165  call ksvolu(name, shape, numed, q(j+7), npar, ivol)
166  11 continue
167  enddo
168  print *,'Divided volumes: ',ndvol
169 
170 *** properties of the mother volume
171  call uhtoc(iq(jvolum+1),4,name,4)
172  j=lq(jvolum-1)
173  call jshape(q(j+2),shape)
174  print *,'mother volume: ',name,' shape: ',shape
175 *** convert physical volumes
176  do i=1, nvol
177  ii=iia(i)
178  j = lq(jvolum-ii)
179  call uhtoc(iq(jvolum+ii),4,name,4)
180  nin = q(j+3)
181  numed = q(j+4)
182  npar = q(j+5)
183  if (nin.lt.0) then
184 * ! divided volume
185  jdiv = lq(j-1)
186  iaxis = q(jdiv+1)
187  ivo = q(jdiv+2)
188  call uhtoc(iq(jvolum+ivo),4,dname,4)
189  jd = lq(jvolum-ivo)
190  numed = q(jd+4)
191  ndiv = q(jdiv+3)
192  c0 = q(jdiv+4)
193  step = q(jdiv+5)
194  call ksdvn2(dname, name, ndiv, iaxis, c0, numed)
195  else if (nin.gt.0) then
196 * ! volume not divided. Handle positioning of daughter vols
197  do in=1, nin
198  jin = lq(j-in)
199  ivo = q(jin+2)
200  call uhtoc(iq(jvolum+ivo),4,dname,4)
201  jd = lq(jvolum-ivo)
202  nparv = q(jd+5) ! NPAR declared in the GSVOLU call
203  nr = q(jin+3)
204  irot = q(jin+4)
205  x = q(jin+5)
206  y = q(jin+6)
207  z = q(jin+7)
208  konly = q(jin+8)
209  if (konly.ne.0) then
210  chonly = 'ONLY'
211  else
212  chonly = 'MANY'
213  endif
214  npard = iq(jin-1) -9
215  npositioned = npositioned +1
216  if (nparv.eq.0) then
217 * ! use GSPOSP
218  call ksposp(dname, nr, name, x, y, z, irot, chonly,
219  + q(jin+10), npard)
220  else
221 * ! GSPOS
222  call kspos(dname, nr, name, x, y, z, irot, chonly)
223  endif
224  enddo
225  endif
226  enddo
227 *
228 *** count sensitive detectors
229  call bankcnt(jset,iia, nset)
230  print *,'Sets: ',nset
231  do i=1,nset
232  ii=iia(i)
233  j = lq(jset-ii)
234  call uhtoc(iq(jset+i),4,chset,4)
235  ndet = iq(j-1)
236  do k=1,ndet
237  jd = lq(j-k)
238  call uhtoc(iq(j+k),4,chdet,4)
239  call gfdet(chset, chdet, nn, chnms, nbits, idtyp,
240  + nwhi, nwdi, iset, idet)
241  call ksdet(chset, chdet, nn, chnms, nbits, idtyp,
242  + nwhi, nwdi, iset, idet)
243  jdh = lq(jd-1)
244  if (jdh.ne.0) then
245  call gfdeth(chset,chdet,nn,chnms,nbits,orig,fact)
246  call ksdeth(chset,chdet,nn,chnms,nbits,orig,fact)
247  endif
248  jdd = lq(jd-2)
249  if (jdd.ne.0) then
250  call gfdetd(chset,chdet,nn,chnms,nbits)
251  call ksdetd(chset,chdet,nn,chnms,nbits)
252  endif
253  jdu = lq(jd-3)
254  if (jdu.ne.0) then
255  call gfdetu(chset,chdet,100,nupar,upar)
256  call ksdetu(chset,chdet,nupar,upar)
257  endif
258  enddo
259  enddo
260  print *,'Positioned volumes (gspos, gsposp):',npositioned
261 *
262  call kgclos
263 *
264  end
265 
266  subroutine bankcnt(link,iia,nbanks)
267 ************************************************************************
268 ************************************************************************
269  implicit none
270 #include "gcbank.inc"
271  integer i, link, nbanks, iia(*)
272 *
273  nbanks=0
274  if (link.eq.0) return
275 C* do i=1,9999999
276  do i=1,iq(link-2)
277 C* if(lq(link-nbanks-1).eq.0.or.iq(link-2).eq.nbanks) goto 10
278  if(lq(link-i).ne.0)then
279  nbanks = nbanks +1
280  iia(nbanks)=i
281  endif
282  enddo
283  10 continue
284  end
Generated on Sat May 25 2013 14:33:09 for Geant4 by   doxygen 1.8.4