GEANT321/gtrak/gftrac.F

   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