GEANT321/gtrak/gstrac.F

   1 *
   2 * $Id$
   3 *
   4 * $Log$
   5 * Revision 1.2  1996/02/27 10:30:56  ravndal
   6 * Correct interaction length for heavy ions
   7 *
   8 * Revision 1.1.1.1  1995/10/24 10:21:43  cernlib
   9 * Geant
  10 *
  11 *
  12 #include "geant321/pilot.h"
  13 *CMZ :  3.21/04 13/12/94  15.23.45  by  S.Giani
  14 *-- Author :
  15       SUBROUTINE GSTRAC
  16 C.
  17 C.    ******************************************************************
  18 C.    *                                                                *
  19 C.    *       SUBR. GSTRAC                                             *
  20 C.    *                                                                *
  21 C.    *  Stores in stack JTRACK the information for current track      *
  22 C.    *   segment at exit of current Volume/Medium.                    *
  23 C.    *                                                                *
  24 C.    *   Called by : GTRACK                                           *
  25 C.    *   Authors   : S.Banerjee, F.Bruyant                            *
  26 C.    *                                                                *
  27 C.    ******************************************************************
  28 C.
  29 #include "geant321/gcbank.inc"
  30 #include "geant321/gckine.inc"
  31 #include "geant321/gcnum.inc"
  32 #include "geant321/gcphys.inc"
  33 #include "geant321/gcstak.inc"
  34 #include "geant321/gctrak.inc"
  35 #include "geant321/gcunit.inc"
  36 #include "geant321/gcvolu.inc"
  37       REAL      XC(3)
  38 C.
  39 C.    ------------------------------------------------------------------
  40 *
  41 * *** Find where in the tracking skeleton to enter the current track
  42 *
  43       IF (NLEVIN.EQ.NLEVEL) THEN
  44 *       (case when GINVOL has not been called)
  45          JVO = LQ(JVOLUM-LVOLUM(NLEVIN))
  46          IF (INGOTO.GT.0) THEN
  47 *
  48 *  **      Point is in content predicted by GTNEXT, go one level down
  49 *
  50             NLEVIN = NLEVIN +1
  51             INFROM = 0
  52             JIN    = LQ(JVO-INGOTO)
  53             IVOT   = Q(JIN+2)
  54             LVOLUM(NLEVIN) = IVOT
  55             LINDEX(NLEVIN) = INGOTO
  56             LINMX (NLEVIN) = Q(JVO+3)
  57 *
  58 *  **      Prepare the translation and rotation matrices if necessary
  59 *
  60             JSKL = LQ(JSKLT-NLEVIN)
  61             IF (NLEVIN.GT.2) THEN
  62                IOFF = IQ(JSKL-3)
  63                DO 29 ILEV = 1, NLEVEL
  64                   IF (IQ(JSKL+IOFF+ILEV).NE.LINDEX(ILEV)) GO TO 30
  65    29          CONTINUE
  66             ENDIF
  67             JSK  = LQ(JSKL-INGOTO)
  68             IF (IQ(JSK+1).GT.0) GO TO 100
  69    30       IROTT = Q(JIN+4)
  70             CALL GTRMUL (GTRAN(1,NLEVEL), GRMAT(1,NLEVEL), Q(JIN+5),
  71      +                   IROTT, GTRAN(1,NLEVIN), GRMAT(1,NLEVIN))
  72             GO TO 100
  73          ELSE
  74 *
  75 *  **      otherwise, go one level up
  76 *
  77             NLEVIN = NLEVIN -1
  78 *
  79          ENDIF
  80 *
  81       ELSE IF (NLEVIN.GT.NLEVEL) THEN
  82          INFROM = 0
  83          GO TO 100
  84 *
  85       ELSE IF (NLEVIN.LT.0) THEN
  86 *       (case when entering a dominant overlaping volume)
  87          NLEVIN = -NLEVIN
  88          INFROM = LINDEX(NLEVIN+1)
  89          GO TO 100
  90       ENDIF
  91 *
  92 *  **  Track has left current volume, check levels up
  93 *
  94    80 IF (NLEVIN.EQ.0) GO TO 999
  95 *
  96       IF (GRMAT(10,NLEVIN).EQ.0.) THEN
  97          DO 88 I = 1,3
  98             XC(I) = VECT(I) -GTRAN(I,NLEVIN)
  99    88    CONTINUE
 100       ELSE
 101 C       (later, code in line)
 102          CALL GTRNSF (VECT, GTRAN(1,NLEVIN), GRMAT(1,NLEVIN), XC)
 103       ENDIF
 104 *
 105       JVO  = LQ(JVOLUM-LVOLUM(NLEVIN))
 106       JPAR = LQ(JGPAR-NLEVIN)
 107       CALL GINME (XC, Q(JVO+2), Q(JPAR+1), IYES)
 108       IF (IYES.NE.0) THEN
 109          INFROM = LINDEX(NLEVIN+1)
 110       ELSE
 111          NLEVIN = NLEVIN -1
 112          GO TO 80
 113       ENDIF
 114 *
 115 * *** Allocate last 'garbaged' area if any, otherwise first 'free' one
 116 *
 117   100 IF (NJGARB.NE.0) THEN
 118          NCUR   = NJGARB
 119          LCUR   = JTRACK +(NCUR-1)*NWTRAC
 120          NJGARB = IQ(LCUR+1)
 121       ELSE
 122          NCUR   = NJFREE
 123          LCUR   = JTRACK +(NCUR-1)*NWTRAC
 124          NJFREE = NCUR +1
 125       ENDIF
 126 *
 127 * *** Link allocated area to relevant chain in JSKLT structure
 128 *
 129       JSKL = LQ(JSKLT-NLEVIN)
 130       IQ(LCUR+1) = IQ(JSKL+LINDEX(NLEVIN))
 131       IQ(JSKL+LINDEX(NLEVIN)) = NCUR
 132 *
 133 * *** Store information for current track segment in stack JTRACK
 134 *
 135       IQ(LCUR+2) = 0
 136       IQ(LCUR+3) = NTMULT
 137       IQ(LCUR+4) = ITRA
 138       IQ(LCUR+5) = ISTAK
 139       IQ(LCUR+6) = IPART
 140       IQ(LCUR+7) = NSTEP
 141 *free IQ(LCUR+8) = IDECAD
 142       IQ(LCUR+9) = IEKBIN
 143       IQ(LCUR+10)= ISTORY
 144       IQ(LCUR+11)= INFROM
 145 *
 146       IPCUR = LCUR +NWINT
 147       DO 109 I = 1,7
 148          Q(IPCUR+I)  = VECT(I)
 149   109 CONTINUE
 150       Q(IPCUR+8)  = GEKIN
 151       Q(IPCUR+9)  = SLENG
 152       Q(IPCUR+10) = GEKRAT
 153       Q(IPCUR+11) = TOFG
 154       Q(IPCUR+12) = UPWGHT
 155 *
 156       IPCUR = IPCUR +NWREAL
 157       IF (ITRTYP.EQ.1) THEN
 158 *     Photons
 159          Q(IPCUR+1) = ZINTPA
 160          Q(IPCUR+2) = ZINTCO
 161          Q(IPCUR+3) = ZINTPH
 162          Q(IPCUR+4) = ZINTPF
 163          Q(IPCUR+5) = ZINTRA
 164       ELSE IF (ITRTYP.EQ.2) THEN
 165 *     Electrons
 166          Q(IPCUR+1) = ZINTBR
 167          Q(IPCUR+2) = ZINTDR
 168          Q(IPCUR+3) = ZINTAN
 169       ELSE IF (ITRTYP.EQ.3) THEN
 170 *     Neutral hadrons
 171          Q(IPCUR+1) = SUMLIF
 172          Q(IPCUR+2) = ZINTHA
 173       ELSE IF (ITRTYP.EQ.4) THEN
 174 *     Charged hadrons
 175          Q(IPCUR+1) = SUMLIF
 176          Q(IPCUR+2) = ZINTHA
 177          Q(IPCUR+3) = ZINTDR
 178       ELSE IF (ITRTYP.EQ.5) THEN
 179 *     Muons
 180          Q(IPCUR+1) = SUMLIF
 181          Q(IPCUR+2) = ZINTBR
 182          Q(IPCUR+3) = ZINTPA
 183          Q(IPCUR+4) = ZINTDR
 184          Q(IPCUR+5) = ZINTMU
 185       ELSE IF (ITRTYP.EQ.7) THEN
 186 *     Cerenkov photons
 187          Q(IPCUR+1) = ZINTLA
 188       ELSE IF (ITRTYP.EQ.8) THEN
 189 *     Ions
 190          Q(IPCUR+1) = ZINTHA
 191          Q(IPCUR+2) = ZINTDR
 192       ENDIF
 193 *
 194 * *** Take care of the skeleton
 195 *
 196       IF (NLEVIN.GT.NLDOWN) THEN
 197          NLDOWN = NLEVIN
 198          JSKL   = LQ(JSKLT-NLDOWN)
 199 *
 200 *  **    Clear skeleton at lowest level if necessary
 201 *
 202          JOFF   = JSKL + IQ(JSKL-3)
 203          DO 229 ILEV = 1, NLDOWN-1
 204             IF (IQ(JOFF+ILEV).EQ.LINDEX(ILEV)) GO TO 229
 205             NINSK = LINMX(NLDOWN)
 206             DO 209 IN = 1, NINSK
 207                JSK  = LQ(JSKL-IN)
 208                IQ(JSK+1) = 0
 209   209       CONTINUE
 210             DO 219 I = ILEV, NLDOWN-1
 211                IQ(JOFF+I) = LINDEX(I)
 212   219       CONTINUE
 213             GO TO 230
 214   229    CONTINUE
 215       ENDIF
 216 *
 217 *  ** Fill up the skeleton at NLDOWN
 218 *
 219   230 IF (NLEVIN.GT.NLEVEL) THEN
 220          JSKL = LQ(JSKLT-NLDOWN)
 221          JSK  = LQ(JSKL-LINDEX(NLDOWN))
 222          IF (IQ(JSK+1).LE.0) THEN
 223             LQ(JSK-1) = LQ(JGPAR-NLDOWN)
 224             IQ(JSK+1) = IQ(JGPAR+NLDOWN)
 225             IQ(JSK+2) = LVOLUM(NLDOWN)
 226             DO 239 I = 1, 3
 227                Q(JSK+2+I) = GTRAN(I,NLDOWN)
 228   239       CONTINUE
 229             DO 249 I = 1, 10
 230                Q(JSK+5+I) = GRMAT(I,NLDOWN)
 231   249       CONTINUE
 232          ENDIF
 233 *
 234       ENDIF
 235 *
 236 * *** Update NALIVE and test if tracking stack is full
 237 *
 238       NALIVE = NALIVE + 1
 239       IF (NALIVE-IQ(JSTAK+1).GE.NJTMAX) THEN
 240          WRITE (CHMAIL, 1001)
 241          CALL GMAIL (0, 0)
 242          NJTMAX = -NJTMAX
 243          NLVSAV = NLEVEL
 244          DO 309 I = 2,NLDOWN
 245             LINSAV(I) = LINDEX(I)
 246             LMXSAV(I) = LINMX(I)
 247   309    CONTINUE
 248       ENDIF
 249 *
 250  1001 FORMAT (' GSTRAC : Stack JTRACK full. Inhibit parallel tracking')
 251 *                                                             END GSTRAC
 252   999 END
 253