]> git.uio.no Git - u/mrichter/AliRoot.git/blame - GEANT321/gtrak/gftrac.F
git://git.uio.no / u / mrichter / AliRoot.git / blame
? search:
summary | shortlog | log | commit | commitdiff | tree
blob | blame (incremental) | history | HEAD
Bugfix in AliPoints2Memory
[u/mrichter/AliRoot.git] / GEANT321 / gtrak / gftrac.F
CommitLineData
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
13C. ******************************************************************
14C. * *
15C. * SUBR. GFTRAC *
16C. * *
17C. * Selects next track segment to be processed and extracts from *
18C. * the stack JTRACK the relevant information to reload commons *
19C. * *
20C. * Called by : GTREVE *
21C. * Authors : S.Banerjee, F.Bruyant *
22C. * *
23C. ******************************************************************
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
42C.
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/
48C. ------------------------------------------------------------------
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
165C***** Code Expanded From Routine: GTRNSF
166C
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
184C***** 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)
280C***** Code Expanded From Routine: GITRAN
281C.
282C. ------------------------------------------------------------------
283C.
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
299C***** 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