]>
Commit | Line | Data |
---|---|---|
fe4da5cc | 1 | * |
2 | * $Id$ | |
3 | * | |
4 | * $Log$ | |
5 | * Revision 1.1.1.1 1995/10/24 10:21:41 cernlib | |
6 | * Geant | |
7 | * | |
8 | * | |
9 | #include "geant321/pilot.h" | |
10 | *CMZ : 3.21/02 29/03/94 15.41.23 by S.Giani | |
11 | *-- Author : | |
12 | SUBROUTINE GFTRAC | |
13 | C. ****************************************************************** | |
14 | C. * * | |
15 | C. * SUBR. GFTRAC * | |
16 | C. * * | |
17 | C. * Selects next track segment to be processed and extracts from * | |
18 | C. * the stack JTRACK the relevant information to reload commons * | |
19 | C. * * | |
20 | C. * Called by : GTREVE * | |
21 | C. * Authors : S.Banerjee, F.Bruyant * | |
22 | C. * * | |
23 | C. ****************************************************************** | |
24 | * | |
25 | #include "geant321/gcbank.inc" | |
26 | #include "geant321/gckine.inc" | |
27 | #include "geant321/gcnum.inc" | |
28 | #include "geant321/gconsp.inc" | |
29 | #include "geant321/gcphys.inc" | |
30 | #include "geant321/gcstak.inc" | |
31 | #include "geant321/gctmed.inc" | |
32 | #include "geant321/gctrak.inc" | |
33 | #include "geant321/gcunit.inc" | |
34 | #include "geant321/gcvolu.inc" | |
35 | #include "geant321/gcpoly.inc" | |
36 | #if defined(CERNLIB_USRJMP) | |
37 | #include "geant321/gcjump.inc" | |
38 | #endif | |
39 | REAL XC(3), XT(3), X0(3) | |
40 | INTEGER IDTYP(3,12) | |
41 | LOGICAL BTEST | |
42 | C. | |
43 | SAVE MANY | |
44 | DATA MANY / 0/ | |
45 | DATA IDTYP / 1, 1, 1, 0, 1, 1, 0, 0, 1, 0, 0, 1, 2, 3, 1, | |
46 | + 2, 3, 1, 2, 3, 1, 2, 3, 1, 2, 4, 3, 1, 1, 1, | |
47 | + 2, 3, 1, 2, 3, 1/ | |
48 | C. ------------------------------------------------------------------ | |
49 | * | |
50 | * *** Process next track in 'IN current VOlume' chain, if any | |
51 | * | |
52 | IF (NJTMAX.LT.0) THEN | |
53 | * | |
54 | * ** Reactivate parallel tracking if enough space available | |
55 | * | |
56 | IF (NALIVE.LE.NJTMIN) NJTMAX = -NJTMAX | |
57 | * | |
58 | * ** Update common /GCVOLU/ and structure JGPAR if necessary | |
59 | * | |
60 | NLEVEL = NLVSAV | |
61 | ISKP = 1 | |
62 | DO 9 ILEV = 2,NLDOWN | |
63 | IF (ISKP.NE.0) THEN | |
64 | IF (LINDEX(ILEV).EQ.LINSAV(ILEV)) GO TO 9 | |
65 | ISKP = 0 | |
66 | ENDIF | |
67 | JSKLD = LQ(JSKLT-ILEV) | |
68 | JSKD = LQ(JSKLD-LINSAV(ILEV)) | |
69 | IVO = IQ(JSKD+2) | |
70 | LQ(JGPAR-ILEV) = LQ(JSKD-1) | |
71 | IQ(JGPAR+ILEV) = IQ(JSKD+1) | |
72 | LVOLUM(ILEV) = IVO | |
73 | NAMES(ILEV) = IQ(JVOLUM+IVO) | |
74 | LINDEX(ILEV) = LINSAV(ILEV) | |
75 | LINMX(ILEV) = LMXSAV(ILEV) | |
76 | JVOM = LQ(JVOLUM-LVOLUM(ILEV-1)) | |
77 | IF (Q(JVOM+3).GT.0.) THEN | |
78 | JIN = LQ(JVOM-LINDEX(ILEV)) | |
79 | NUMBER(ILEV) = Q(JIN+3) | |
80 | GONLY(ILEV) = Q(JIN+8) | |
81 | ELSE | |
82 | NUMBER(ILEV) = LINDEX(ILEV) | |
83 | GONLY(ILEV) = GONLY(ILEV-1) | |
84 | ENDIF | |
85 | IF (LQ(LQ(JVOLUM-IVO)).EQ.0) THEN | |
86 | NLDEV(ILEV) = NLDEV(ILEV-1) | |
87 | ELSE | |
88 | NLDEV(ILEV) = ILEV | |
89 | ENDIF | |
90 | GTRAN(1,ILEV) = Q(JSKD+3) | |
91 | GTRAN(2,ILEV) = Q(JSKD+4) | |
92 | GTRAN(3,ILEV) = Q(JSKD+5) | |
93 | DO 8 I = 1, 10, 2 | |
94 | GRMAT(I,ILEV) = Q(JSKD+5+I) | |
95 | GRMAT(I+1,ILEV) = Q(JSKD+6+I) | |
96 | 8 CONTINUE | |
97 | 9 CONTINUE | |
98 | * ** | |
99 | IF (NJINVO.NE.0) GO TO 800 | |
100 | IFUPD = 0 | |
101 | ELSE | |
102 | IF (NJINVO.NE.0) GO TO 800 | |
103 | IFUPD = 1 | |
104 | ENDIF | |
105 | * | |
106 | * *** 'IN current VOlume' chain is empty, refill from JSKLT structure | |
107 | * Scan brother chains, starting from current one when going up in | |
108 | * the skeleton structure | |
109 | * | |
110 | 10 INSK = 1 | |
111 | * | |
112 | 11 NLEVEL = NLDOWN | |
113 | JSKLD = LQ(JSKLT-NLEVEL) | |
114 | NINSK = LINMX(NLEVEL) | |
115 | IDO = 1 | |
116 | * | |
117 | 20 IF (IQ(JSKLD+INSK).EQ.0) GO TO 589 | |
118 | JSKD = LQ(JSKLD-INSK) | |
119 | IVO = IQ(JSKD+2) | |
120 | IF (IFUPD.NE.0.AND.NLEVEL.GT.1) THEN | |
121 | * | |
122 | * ** Update common /GCVOLU/ for level NLEVEL | |
123 | * | |
124 | LQ(JGPAR-NLEVEL) = LQ(JSKD-1) | |
125 | IQ(JGPAR+NLEVEL) = IQ(JSKD+1) | |
126 | LVOLUM(NLEVEL) = IVO | |
127 | NAMES(NLEVEL) = IQ(JVOLUM+IVO) | |
128 | LINDEX(NLEVEL) = INSK | |
129 | JVOM = LQ(JVOLUM-LVOLUM(NLEVEL-1)) | |
130 | IF (Q(JVOM+3).GT.0.) THEN | |
131 | JIN = LQ(JVOM-INSK) | |
132 | NUMBER(NLEVEL) = Q(JIN+3) | |
133 | GONLY(NLEVEL) = Q(JIN+8) | |
134 | ELSE | |
135 | NUMBER(NLEVEL) = INSK | |
136 | GONLY(NLEVEL) = GONLY(NLEVEL-1) | |
137 | ENDIF | |
138 | IF (LQ(LQ(JVOLUM-IVO)).EQ.0) THEN | |
139 | NLDEV(NLEVEL) = NLDEV(NLEVEL-1) | |
140 | ELSE | |
141 | NLDEV(NLEVEL) = NLEVEL | |
142 | ENDIF | |
143 | GTRAN(1,NLEVEL) = Q(JSKD+3) | |
144 | GTRAN(2,NLEVEL) = Q(JSKD+4) | |
145 | GTRAN(3,NLEVEL) = Q(JSKD+5) | |
146 | DO 29 I = 1, 10, 2 | |
147 | GRMAT(I,NLEVEL) = Q(JSKD+5+I) | |
148 | GRMAT(I+1,NLEVEL) = Q(JSKD+6+I) | |
149 | 29 CONTINUE | |
150 | ENDIF | |
151 | * | |
152 | JVO = LQ(JVOLUM-IVO) | |
153 | IF (Q(JVO+3).EQ.0.) GO TO 600 | |
154 | NIN = Q(JVO+3) | |
155 | * | |
156 | * ** Sort-out unsorted-out elements in first non-empty brother chain | |
157 | * | |
158 | LPREV = JSKLD +INSK | |
159 | NCUR = IQ(LPREV) | |
160 | 50 LCUR = JTRACK +(NCUR-1)*NWTRAC | |
161 | IF (IQ(LCUR+2).NE.0) GO TO 600 | |
162 | NSTO = IQ(LCUR+1) | |
163 | * | |
164 | IPCUR = LCUR +NWINT | |
165 | C***** Code Expanded From Routine: GTRNSF | |
166 | C | |
167 | IF (GRMAT(10,NLEVEL) .EQ. 0.) THEN | |
168 | XC(1) = Q(1+IPCUR) - GTRAN(1,NLEVEL) | |
169 | XC(2) = Q(2+IPCUR) - GTRAN(2,NLEVEL) | |
170 | XC(3) = Q(3+IPCUR) - GTRAN(3,NLEVEL) | |
171 | * | |
172 | ELSE | |
173 | XL11X = Q(1+IPCUR) - GTRAN(1,NLEVEL) | |
174 | XL21X = Q(2+IPCUR) - GTRAN(2,NLEVEL) | |
175 | XL31X = Q(3+IPCUR) - GTRAN(3,NLEVEL) | |
176 | XC(1) = XL11X*GRMAT(1,NLEVEL) + XL21X*GRMAT(2,NLEVEL) + XL31X* | |
177 | 1 GRMAT(3,NLEVEL) | |
178 | XC(2) = XL11X*GRMAT(4,NLEVEL) + XL21X*GRMAT(5,NLEVEL) + XL31X* | |
179 | 1 GRMAT(6,NLEVEL) | |
180 | XC(3) = XL11X*GRMAT(7,NLEVEL) + XL21X*GRMAT(8,NLEVEL) + XL31X* | |
181 | 1 GRMAT(9,NLEVEL) | |
182 | ||
183 | ENDIF | |
184 | C***** End of Code Expanded From Routine: GTRNSF | |
185 | * | |
186 | IF (NIN.LT.0) GO TO 200 | |
187 | * | |
188 | * * Case with contents defined by Position | |
189 | * | |
190 | JNEAR = LQ(JVO-NIN-1) | |
191 | INFROM = IQ(LCUR+11) | |
192 | IF (INFROM.GT.0) THEN | |
193 | JIN = LQ(JVO-INFROM) | |
194 | IF (LQ(JIN-1).NE.0) JNEAR = LQ(JIN-1) | |
195 | ENDIF | |
196 | IF (IQ(JNEAR+2).EQ.0) GO TO 300 | |
197 | ISEARC = Q(JVO+1) | |
198 | IF (ISEARC.LT.0) THEN | |
199 | * | |
200 | * Prepare access list when contents have been ordered by GSORD | |
201 | * | |
202 | JSB = LQ(LQ(JVO-NIN-1)) | |
203 | IAX = Q(JSB+1) | |
204 | NSB = Q(JSB+2) | |
205 | IF (IAX.LE.3) THEN | |
206 | IDIV = LOCATF (Q(JSB+3), NSB, XC(IAX)) | |
207 | ELSE | |
208 | CALL GFCOOR (XC, IAX, CX) | |
209 | IDIV = LOCATF (Q(JSB+3), NSB, CX) | |
210 | ENDIF | |
211 | IF (IDIV.LT.0) IDIV = -IDIV | |
212 | IF (IDIV.EQ.0) THEN | |
213 | IF (IAX.NE.6) GO TO 300 | |
214 | IDIV = NSB | |
215 | ELSE IF (IDIV.EQ.NSB) THEN | |
216 | IF (IAX.NE.6) GO TO 300 | |
217 | ENDIF | |
218 | JSC0 = LQ(JVO-NIN-2) | |
219 | NCONT = IQ(JSC0+IDIV) | |
220 | IF (NCONT.LE.0) GO TO 300 | |
221 | JSCV = LQ(JSC0-IDIV) | |
222 | ICONT = 1 | |
223 | GO TO 120 | |
224 | ELSE | |
225 | IF (ISEARC.GT.0) THEN | |
226 | #if !defined(CERNLIB_USRJMP) | |
227 | CALL GUNEAR (ISEARC, 1, XC, JNEAR) | |
228 | #endif | |
229 | #if defined(CERNLIB_USRJMP) | |
230 | CALL JUMPT4(JUNEAR, ISEARC, 1, XC, JNEAR) | |
231 | #endif | |
232 | IF (IQ(JNEAR+1).EQ.0) GO TO 300 | |
233 | ENDIF | |
234 | JNEAR = JNEAR +1 | |
235 | NNEAR = IQ(JNEAR) | |
236 | INEAR = 1 | |
237 | ENDIF | |
238 | * | |
239 | 110 IN = IQ(JNEAR+INEAR) | |
240 | IF (IN.GT.0) GO TO 150 | |
241 | GO TO 190 | |
242 | * | |
243 | 120 IN = IQ(JSCV+ICONT) | |
244 | * | |
245 | * For each selected content in turn, check if point is in | |
246 | * | |
247 | 150 JIN = LQ(JVO-IN) | |
248 | IVOT = Q(JIN+2) | |
249 | JVOT = LQ(JVOLUM-IVOT) | |
250 | IF (BTEST(IQ(JVOT),1)) THEN | |
251 | * (case with JVOLUM structure locally developed) | |
252 | JPAR = LQ(LQ(JVOLUM-LVOLUM(NLDEV(NLEVEL)))) | |
253 | DO 169 ILEV = NLDEV(NLEVEL), NLEVEL | |
254 | IF (IQ(JPAR+1).EQ.0) THEN | |
255 | IF (ILEV.EQ.NLEVEL) THEN | |
256 | JPAR = LQ(JPAR-IN) | |
257 | ELSE | |
258 | JPAR = LQ(JPAR-LINDEX(ILEV+1)) | |
259 | ENDIF | |
260 | ELSE IF (IQ(JPAR-3).GT.1) THEN | |
261 | JPAR = LQ(JPAR-LINDEX(ILEV+1)) | |
262 | ELSE | |
263 | JPAR = LQ(JPAR-1) | |
264 | ENDIF | |
265 | 169 CONTINUE | |
266 | JPAR = JPAR +5 | |
267 | NPAR = IQ(JPAR) | |
268 | GO TO 175 | |
269 | ENDIF | |
270 | * (normal case) | |
271 | NPAR = Q(JVOT+5) | |
272 | IF (NPAR.EQ.0) THEN | |
273 | JPAR = JIN +9 | |
274 | NPAR = Q(JPAR) | |
275 | ELSE | |
276 | JPAR = JVOT +6 | |
277 | ENDIF | |
278 | * | |
279 | 175 IROTT = Q(JIN+4) | |
280 | C***** Code Expanded From Routine: GITRAN | |
281 | C. | |
282 | C. ------------------------------------------------------------------ | |
283 | C. | |
284 | IF (IROTT.EQ.0) THEN | |
285 | XT(1) = XC(1) - Q(JIN+5) | |
286 | XT(2) = XC(2) - Q(JIN+6) | |
287 | XT(3) = XC(3) - Q(JIN+7) | |
288 | * | |
289 | ELSE | |
290 | XL1 = XC(1) - Q(5+JIN) | |
291 | XL2 = XC(2) - Q(6+JIN) | |
292 | XL3 = XC(3) - Q(7+JIN) | |
293 | JR = LQ(JROTM-IROTT) | |
294 | XT(1) = XL1*Q(JR+1) + XL2*Q(JR+2) + XL3*Q(JR+3) | |
295 | XT(2) = XL1*Q(JR+4) + XL2*Q(JR+5) + XL3*Q(JR+6) | |
296 | XT(3) = XL1*Q(JR+7) + XL2*Q(JR+8) + XL3*Q(JR+9) | |
297 | * | |
298 | ENDIF | |
299 | C***** Code Expanded From Routine: GITRAN | |
300 | CALL GINME (XT, Q(JVOT+2), Q(JPAR+1), IYES) | |
301 | IF (IYES.NE.0) THEN | |
302 | * | |
303 | * Volume found at deeper level | |
304 | * | |
305 | NLDOWN = NLEVEL +1 | |
306 | LINMX(NLDOWN) = NIN | |
307 | JSKL = LQ(JSKLT-NLDOWN) | |
308 | * | |
309 | * Clear skeleton at lowest level if necessary | |
310 | * | |
311 | JOFF = JSKL +IQ(JSKL-3) | |
312 | DO 184 ILEV = 1,NLEVEL | |
313 | IF (IQ(JOFF+ILEV).EQ.LINDEX(ILEV)) GO TO 184 | |
314 | DO 182 I = ILEV,NLEVEL | |
315 | IQ(JOFF+I) = LINDEX(I) | |
316 | 182 CONTINUE | |
317 | DO 183 I = 1,NIN | |
318 | JSK = LQ(JSKL-I) | |
319 | IQ(JSK+1) = 0 | |
320 | 183 CONTINUE | |
321 | GO TO 185 | |
322 | 184 CONTINUE | |
323 | * | |
324 | * Prepare skeleton for level down if not yet done | |
325 | * | |
326 | 185 JSK = LQ(JSKL-IN) | |
327 | IF (IQ(JSK+1).EQ.0) THEN | |
328 | LQ(JSK-1) = JPAR | |
329 | IQ(JSK+1) = NPAR | |
330 | IQ(JSK+2) = IVOT | |
331 | CALL GTRMUL (GTRAN(1,NLEVEL), GRMAT(1,NLEVEL), | |
332 | + Q(JIN+5), IROTT, Q(JSK+3), Q(JSK+6)) | |
333 | ENDIF | |
334 | GO TO 500 | |
335 | * | |
336 | ENDIF | |
337 | * | |
338 | 190 IF (ISEARC.LT.0) THEN | |
339 | IF (ICONT.EQ.NCONT) GO TO 300 | |
340 | ICONT = ICONT +1 | |
341 | GO TO 120 | |
342 | ELSE | |
343 | IF (INEAR.EQ.NNEAR) GO TO 300 | |
344 | INEAR = INEAR +1 | |
345 | GO TO 110 | |
346 | ENDIF | |
347 | * | |
348 | * * Case with contents defined by division | |
349 | * | |
350 | 200 JDIV = LQ(JVO-1) | |
351 | ISH = Q(JVO+2) | |
352 | IAXIS = Q(JDIV+1) | |
353 | IVOT = Q(JDIV+2) | |
354 | JVOT = LQ(JVOLUM-IVOT) | |
355 | IF (NLEVEL.LT.NLDEV(NLEVEL)) THEN | |
356 | JPAR = 0 | |
357 | ELSE | |
358 | * (case with structure JVOLUM locally developped) | |
359 | JPAR = LQ(LQ(JVOLUM-LVOLUM(NLDEV(NLEVEL)))) | |
360 | IF (NLEVEL.EQ.NLDEV(NLEVEL)) GO TO 250 | |
361 | DO 249 ILEV = NLDEV(NLEVEL), NLEVEL-1 | |
362 | IF (IQ(JPAR+1).EQ.0) THEN | |
363 | JPAR = LQ(JPAR-LINDEX(ILEV+1)) | |
364 | IF (JPAR.EQ.0) GO TO 250 | |
365 | ELSE IF (IQ(JPAR-3).GT.1) THEN | |
366 | JPAR = LQ(JPAR-LINDEX(ILEV+1)) | |
367 | ELSE | |
368 | JPAR = LQ(JPAR-1) | |
369 | ENDIF | |
370 | IF (ILEV.EQ.NLEVEL-1) THEN | |
371 | NDIV = IQ(JPAR+1) | |
372 | ORIG = Q(JPAR+2) | |
373 | SDIV = Q(JPAR+3) | |
374 | ENDIF | |
375 | 249 CONTINUE | |
376 | GO TO 260 | |
377 | ENDIF | |
378 | * (normal case) | |
379 | 250 NDIV = Q(JDIV+3) | |
380 | ORIG = Q(JDIV+4) | |
381 | SDIV = Q(JDIV+5) | |
382 | * | |
383 | 260 IDT = IDTYP(IAXIS,ISH) | |
384 | IF (IDT.EQ.1) THEN | |
385 | * | |
386 | * Division along X, Y or Z axis | |
387 | * | |
388 | XTT = XC(IAXIS) | |
389 | IF (ISH.EQ.10) THEN | |
390 | IF (IAXIS.NE.3) THEN | |
391 | XTT = XTT - Q(LQ(JGPAR-NLEVEL)+IAXIS+4) * XC(3) | |
392 | IF (IAXIS.EQ.1) THEN | |
393 | YT = XC(2) - Q(LQ(JGPAR-NLEVEL)+6) * XC(3) | |
394 | XTT = XTT - Q(LQ(JGPAR-NLEVEL)+4) * YT | |
395 | ENDIF | |
396 | ENDIF | |
397 | ENDIF | |
398 | IN = (XTT -ORIG)/SDIV +1 | |
399 | ELSE IF (IDT.EQ.2) THEN | |
400 | * | |
401 | * Division along R axis | |
402 | * | |
403 | R = XC(1)**2 + XC(2)**2 | |
404 | IF (ISH.EQ.9) R = R + XC(3)**2 | |
405 | R = SQRT (R) | |
406 | IF (ISH.EQ.5.OR.ISH.EQ.6.OR.ISH.EQ.9) THEN | |
407 | IN = (R - ORIG) / SDIV + 1 | |
408 | ELSE IF (ISH.EQ.7.OR.ISH.EQ.8) THEN | |
409 | IPAR = LQ(JGPAR-NLEVEL) | |
410 | DR = 0.5 * (Q(IPAR+4) - Q(IPAR+2)) / Q(IPAR+1) | |
411 | RMN = 0.5 * (Q(IPAR+4) + Q(IPAR+2)) + DR * XC(3) | |
412 | DR = 0.5 * (Q(IPAR+5) - Q(IPAR+3)) / Q(IPAR+1) | |
413 | RMX = 0.5 * (Q(IPAR+5) + Q(IPAR+3)) + DR * XC(3) | |
414 | STP = (RMX - RMN) / NDIV | |
415 | IN = (R - RMN) / STP + 1 | |
416 | ELSE | |
417 | IPAR = LQ(JGPAR-NLEVEL) | |
418 | IF (ISH.EQ.12) THEN | |
419 | IPT = IPAR + 1 | |
420 | ELSE | |
421 | IPT = IPAR + 2 | |
422 | ENDIF | |
423 | IF (IZSEC.GT.0) THEN | |
424 | IPT = IPT + 3 * IZSEC | |
425 | ELSE | |
426 | NZ = Q(IPT+2) | |
427 | DO 261 IZ = 1, NZ-1 | |
428 | IF((XC(3)-Q(IPT+3*IZ))*(XC(3)-Q(IPT+3*IZ+3)).LE.0.) | |
429 | + THEN | |
430 | IZSEC = IZ | |
431 | IPT = IPT + 3 * IZSEC | |
432 | GO TO 262 | |
433 | ENDIF | |
434 | 261 CONTINUE | |
435 | IN = 0 | |
436 | GO TO 265 | |
437 | ENDIF | |
438 | 262 POR1 = (Q(IPT+3) - XC(3)) / (Q(IPT+3) - Q(IPT)) | |
439 | POR2 = (XC(3) - Q(IPT)) / (Q(IPT+3) - Q(IPT)) | |
440 | RMN = Q(IPT+1) * POR1 + Q(IPT+4) * POR2 | |
441 | RMX = Q(IPT+2) * POR1 + Q(IPT+5) * POR2 | |
442 | IF (ISH.EQ.11) THEN | |
443 | NPDV = Q(IPAR+3) | |
444 | DPH = Q(IPAR+2) / NPDV | |
445 | IF (IPSEC.LE.0) THEN | |
446 | IF (XC(1).NE.0..OR.XC(2).NE.0.) THEN | |
447 | PHI = RADDEG * ATAN2 (XC(2), XC(1)) | |
448 | ELSE | |
449 | PHI = 0.0 | |
450 | ENDIF | |
451 | PH0 = MOD (PHI-Q(IPAR+1)+360., 360.) | |
452 | IPSEC= PH0/DPH + 1 | |
453 | ENDIF | |
454 | PH = DEGRAD * (Q(IPAR+1) + (IPSEC - 0.5) * DPH) | |
455 | R = XC(1) * COS(PH) + XC(2) * SIN(PH) | |
456 | ENDIF | |
457 | STP = (RMX - RMN) / NDIV | |
458 | IN = (R - RMN) / STP + 1 | |
459 | ENDIF | |
460 | ELSE IF (IDT.EQ.3) THEN | |
461 | * | |
462 | * Division along Phi axis | |
463 | * | |
464 | IF (XC(1).NE.0..OR.XC(2).NE.0.) THEN | |
465 | PHI = RADDEG * ATAN2 (XC(2), XC(1)) | |
466 | ELSE | |
467 | PHI = 0. | |
468 | ENDIF | |
469 | IN = MOD (PHI-ORIG+360., 360.) / SDIV + 1 | |
470 | ELSE IF (IDT.EQ.4) THEN | |
471 | * | |
472 | * Division along Theta axis | |
473 | * | |
474 | IF (XC(3).NE.0.0) THEN | |
475 | RXY = SQRT (XC(1)**2 + XC(2)**2) | |
476 | THET = RADDEG * ATAN (RXY/XC(3)) | |
477 | IF (THET.LT.0.0) THET = THET + 180.0 | |
478 | ELSE | |
479 | THET = 90.0 | |
480 | ENDIF | |
481 | IN = (THET - ORIG) / SDIV + 1 | |
482 | ENDIF | |
483 | * | |
484 | 265 IF (IN.GT.NDIV) IN = 0 | |
485 | IF (IN.LE.0) GO TO 300 | |
486 | * | |
487 | IF (JPAR.NE.0) THEN | |
488 | IF (IQ(JPAR-3).GT.1) THEN | |
489 | JPAR = LQ(JPAR-IN) | |
490 | ELSE | |
491 | JPAR = LQ(JPAR-1) | |
492 | ENDIF | |
493 | JPAR = JPAR + 5 | |
494 | NPAR = IQ(JPAR) | |
495 | ELSE | |
496 | NPAR = Q(JVOT+5) | |
497 | JPAR = JVOT + 6 | |
498 | ENDIF | |
499 | * | |
500 | * Volume found at deeper level | |
501 | * | |
502 | NLDOWN = NLEVEL +1 | |
503 | LINMX(NLDOWN) = NDIV | |
504 | JSKL = LQ(JSKLT-NLDOWN) | |
505 | * | |
506 | * Clear skeleton at lowest level if necessary | |
507 | * | |
508 | JOFF = JSKL +IQ(JSKL-3) | |
509 | DO 269 ILEV = 1,NLEVEL | |
510 | IF (IQ(JOFF+ILEV).EQ.LINDEX(ILEV)) GO TO 269 | |
511 | DO 267 I = ILEV,NLEVEL | |
512 | IQ(JOFF+I) = LINDEX(I) | |
513 | 267 CONTINUE | |
514 | DO 268 I = 1,NDIV | |
515 | JSK = LQ(JSKL-I) | |
516 | IQ(JSK+1) = 0 | |
517 | 268 CONTINUE | |
518 | GO TO 270 | |
519 | 269 CONTINUE | |
520 | * | |
521 | * Prepare skeleton at level down if not yet done | |
522 | * | |
523 | 270 JSK = LQ(JSKL-IN) | |
524 | IF (IQ(JSK+1).EQ.0) THEN | |
525 | LQ(JSK-1) = JPAR | |
526 | IQ(JSK+1) = NPAR | |
527 | IQ(JSK+2) = IVOT | |
528 | * | |
529 | IF (IDT.EQ.1) THEN | |
530 | X0(1) = 0.0 | |
531 | X0(2) = 0.0 | |
532 | X0(3) = 0.0 | |
533 | X0(IAXIS) = ORIG + (IN - 0.5) * SDIV | |
534 | IF (ISH.EQ.4.OR.(ISH.EQ.10.AND.IAXIS.NE.1)) THEN | |
535 | CALL GCENT (IAXIS, X0) | |
536 | ENDIF | |
537 | IF (GRMAT(10,NLEVEL).EQ.0.0) THEN | |
538 | Q(JSK+3) = GTRAN(1,NLEVEL) + X0(1) | |
539 | Q(JSK+4) = GTRAN(2,NLEVEL) + X0(2) | |
540 | Q(JSK+5) = GTRAN(3,NLEVEL) + X0(3) | |
541 | DO 278 I = 1, 10, 2 | |
542 | Q(JSK+5+I) = GRMAT(I,NLEVEL) | |
543 | Q(JSK+6+I) = GRMAT(I+1,NLEVEL) | |
544 | 278 CONTINUE | |
545 | ELSE | |
546 | CALL GTRMUL (GTRAN(1,NLEVEL), GRMAT(1,NLEVEL), X0, 0, | |
547 | + Q(JSK+3), Q(JSK+6)) | |
548 | ENDIF | |
549 | * | |
550 | ELSE IF (IDT.EQ.3.OR.IDT.EQ.4) THEN | |
551 | IF (IDT.EQ.3) THEN | |
552 | PH0 = DEGRAD * (ORIG + (IN - 0.5) * SDIV) | |
553 | CPHR = COS (PH0) | |
554 | SPHR = SIN (PH0) | |
555 | ELSE | |
556 | PH0 = 0.0 | |
557 | CPHR = 1.0 | |
558 | SPHR = 0.0 | |
559 | ENDIF | |
560 | DO 279 I = 1, 3 | |
561 | Q(JSK+2+I) = GTRAN(I,NLEVEL) | |
562 | Q(JSK+5+I) = GRMAT(I,NLEVEL)*CPHR +GRMAT(I+3,NLEVEL)*SPHR | |
563 | Q(JSK+8+I) = GRMAT(I+3,NLEVEL)*CPHR -GRMAT(I,NLEVEL)*SPHR | |
564 | Q(JSK+11+I)= GRMAT(I+6,NLEVEL) | |
565 | 279 CONTINUE | |
566 | IF (PH0.EQ.0.0.AND.GRMAT(10,NLEVEL).EQ.0.0) THEN | |
567 | Q(JSK+15) = 0.0 | |
568 | ELSE | |
569 | Q(JSK+15) = 1.0 | |
570 | ENDIF | |
571 | IF (ISH.EQ.11) IPSEC = 1 | |
572 | * | |
573 | ELSE | |
574 | Q(JSK+3) = GTRAN(1,NLEVEL) | |
575 | Q(JSK+4) = GTRAN(2,NLEVEL) | |
576 | Q(JSK+5) = GTRAN(3,NLEVEL) | |
577 | DO 281 I = 1, 10, 2 | |
578 | Q(JSK+5+I) = GRMAT(I,NLEVEL) | |
579 | Q(JSK+6+I) = GRMAT(I+1,NLEVEL) | |
580 | 281 CONTINUE | |
581 | ENDIF | |
582 | * | |
583 | ENDIF | |
584 | GO TO 500 | |
585 | * | |
586 | 300 IF (GONLY(NLEVEL).EQ.0.) THEN | |
587 | IF (MANY.EQ.0) THEN | |
588 | WRITE (CHMAIL, 1001) | |
589 | CALL GMAIL (0 ,0) | |
590 | MANY = 1 | |
591 | ENDIF | |
592 | ENDIF | |
593 | * | |
594 | IQ(LCUR+2) = 1 | |
595 | LPREV = LCUR +1 | |
596 | GO TO 510 | |
597 | * | |
598 | * Move track down in skeleton | |
599 | * | |
600 | 500 IQ(LPREV) = NSTO | |
601 | IQ(LCUR+1) = IQ(JSKL+IN) | |
602 | * (reset INFROM to 0) | |
603 | IQ(LCUR+11) = 0 | |
604 | IQ(JSKL+IN) = NCUR | |
605 | * | |
606 | 510 IF (NSTO.EQ.0) THEN | |
607 | GO TO 600 | |
608 | ELSE | |
609 | NCUR = NSTO | |
610 | GO TO 50 | |
611 | ENDIF | |
612 | * | |
613 | 589 IF (IDO.LT.NINSK) THEN | |
614 | IDO = IDO +1 | |
615 | INSK = INSK +1 | |
616 | IF (INSK.GT.NINSK) INSK = 1 | |
617 | IFUPD = 1 | |
618 | GO TO 20 | |
619 | ENDIF | |
620 | * | |
621 | * ** No more elements at lowest level, go one level up in skeleton | |
622 | * | |
623 | NLDOWN = NLDOWN -1 | |
624 | INSK = LINDEX(NLDOWN) | |
625 | IFUPD = 0 | |
626 | GO TO 11 | |
627 | * | |
628 | 600 IF (NLDOWN.GT.NLEVEL) THEN | |
629 | IFUPD = 1 | |
630 | GO TO 10 | |
631 | ENDIF | |
632 | * | |
633 | * ** Prepare 'IN current VOlume' chain | |
634 | * | |
635 | NJINVO = IQ(JSKLD+INSK) | |
636 | IQ(JSKLD+INSK) = 0 | |
637 | * | |
638 | IF (NJTMAX.LT.0) THEN | |
639 | * (save status of skeleton for later reactivation of // tracking) | |
640 | DO 609 I = 2,NLEVEL | |
641 | LINSAV(I) = LINDEX(I) | |
642 | LMXSAV(I) = LINMX(I) | |
643 | 609 CONTINUE | |
644 | ENDIF | |
645 | * | |
646 | * *** Fetch information for next track segment to be processed | |
647 | * | |
648 | 800 NCUR = NJINVO | |
649 | LCUR = JTRACK +(NCUR-1)*NWTRAC | |
650 | NJINVO = IQ(LCUR+1) | |
651 | NTMULT = IQ(LCUR+3) | |
652 | ITRA = IQ(LCUR+4) | |
653 | ISTAK = IQ(LCUR+5) | |
654 | IPART = IQ(LCUR+6) | |
655 | NSTEP = IQ(LCUR+7) | |
656 | *free IDECAD = IQ(LCUR+8) | |
657 | IEKBIN = IQ(LCUR+9) | |
658 | ISTORY = IQ(LCUR+10) | |
659 | INFROM = IQ(LCUR+11) | |
660 | * | |
661 | IF (IPART.NE.IPAOLD) THEN | |
662 | JPA = LQ(JPART-IPART) | |
663 | DO 819 I = 1,5 | |
664 | NAPART(I) = IQ(JPA+I) | |
665 | 819 CONTINUE | |
666 | ITRTYP = Q(JPA+6) | |
667 | AMASS = Q(JPA+7) | |
668 | CHARGE = Q(JPA+8) | |
669 | TLIFE = Q(JPA+9) | |
670 | IPAOLD = IPART | |
671 | IUPD = 0 | |
672 | ENDIF | |
673 | * | |
674 | IPCUR = LCUR +NWINT | |
675 | DO 829 I = 1,7 | |
676 | VECT(I) = Q(IPCUR+I) | |
677 | 829 CONTINUE | |
678 | GEKIN = Q(IPCUR+8) | |
679 | SLENG = Q(IPCUR+9) | |
680 | GEKRAT = Q(IPCUR+10) | |
681 | TOFG = Q(IPCUR+11) | |
682 | UPWGHT = Q(IPCUR+12) | |
683 | * | |
684 | GETOT = GEKIN +AMASS | |
685 | SAFETY = 0. | |
686 | * | |
687 | IPCUR = IPCUR +NWREAL | |
688 | IF (ITRTYP.EQ.1) THEN | |
689 | * Photons | |
690 | ZINTPA = Q(IPCUR+1) | |
691 | ZINTCO = Q(IPCUR+2) | |
692 | ZINTPH = Q(IPCUR+3) | |
693 | ZINTPF = Q(IPCUR+4) | |
694 | ZINTRA = Q(IPCUR+5) | |
695 | ELSE IF (ITRTYP.EQ.2) THEN | |
696 | * Electrons | |
697 | ZINTBR = Q(IPCUR+1) | |
698 | ZINTDR = Q(IPCUR+2) | |
699 | ZINTAN = Q(IPCUR+3) | |
700 | ELSE IF (ITRTYP.EQ.3) THEN | |
701 | * Neutral hadrons | |
702 | SUMLIF = Q(IPCUR+1) | |
703 | ZINTHA = Q(IPCUR+2) | |
704 | ELSE IF (ITRTYP.EQ.4) THEN | |
705 | * Charged hadrons | |
706 | SUMLIF = Q(IPCUR+1) | |
707 | ZINTHA = Q(IPCUR+2) | |
708 | ZINTDR = Q(IPCUR+3) | |
709 | ELSE IF (ITRTYP.EQ.5) THEN | |
710 | * Muons | |
711 | SUMLIF = Q(IPCUR+1) | |
712 | ZINTBR = Q(IPCUR+2) | |
713 | ZINTPA = Q(IPCUR+3) | |
714 | ZINTDR = Q(IPCUR+4) | |
715 | ZINTMU = Q(IPCUR+5) | |
716 | ELSE IF (ITRTYP.EQ.7) THEN | |
717 | * Cerenkov photons | |
718 | ZINTLA = Q(IPCUR+1) | |
719 | ELSE IF (ITRTYP.EQ.8) THEN | |
720 | * Ions | |
721 | ZINTHA = Q(IPCUR+1) | |
722 | ZINTDR = Q(IPCUR+2) | |
723 | ENDIF | |
724 | * | |
725 | * * Reset NUMED | |
726 | * | |
727 | JVO = LQ(JVOLUM-LVOLUM(NLEVEL)) | |
728 | NUMED = Q(JVO+4) | |
729 | * | |
730 | * Link selected track segment area to 'garbaged' chain | |
731 | * | |
732 | IQ(LCUR+1) = NJGARB | |
733 | NJGARB = NCUR | |
734 | * | |
735 | * Save skeleton status when parallel tracking is frozen | |
736 | * | |
737 | IF (NJTMAX.LT.0) THEN | |
738 | NLVSAV = NLEVEL | |
739 | DO 889 ILEV = 2,NLDOWN | |
740 | LINSAV(ILEV) = LINDEX(ILEV) | |
741 | LMXSAV(ILEV) = LINMX(ILEV) | |
742 | 889 CONTINUE | |
743 | ENDIF | |
744 | * | |
745 | 1001 FORMAT (' GFTRAC : Simple NOT-ONLY configuration assumed. OK?') | |
746 | * END GFTRAC | |
747 | END |