GEANT321/gphys/gphysi.F

   1 *
   2 * $Id$
   3 *
   4 * $Log$
   5 * Revision 1.2  1996/09/30 13:28:58  ravndal
   6 * Medium name length checked
   7 *
   8 * Revision 1.1.1.1  1995/10/24 10:21:31  cernlib
   9 * Geant
  10 *
  11 *
  12 #include "geant321/pilot.h"
  13 *CMZ :  3.21/03 06/10/94  16.31.40  by  S.Ravndal
  14 *-- Author :
  15       SUBROUTINE GPHYSI
  16 C.
  17 C.    ******************************************************************
  18 C.    *                                                                *
  19 C     *       Initialise material constants for all the physics        *
  20 C.    *       mechanisms used by GEANT                                 *
  21 C.    *                                                                *
  22 C.    *    ==>Called by : <USER>, UGINIT                               *
  23 C.    *       Author    R.Brun  *********                              *
  24 C.    *                                                                *
  25 C.    ******************************************************************
  26 C.
  27 #include "geant321/gcbank.inc"
  28 #include "geant321/gcphys.inc"
  29 #include "geant321/gccuts.inc"
  30 #include "geant321/gcflag.inc"
  31 #include "geant321/gcjloc.inc"
  32 #include "geant321/gclist.inc"
  33 #include "geant321/gcmulo.inc"
  34 #include "geant321/gctmed.inc"
  35 #include "geant321/gcmate.inc"
  36 #include "geant321/gcnum.inc"
  37 #include "geant321/gconsp.inc"
  38 #include "geant321/gctime.inc"
  39 #include "geant321/gctrak.inc"
  40 #include "geant321/gcunit.inc"
  41       DIMENSION CUTS(10),UCUT(10),MECA(5,13)
  42       EQUIVALENCE (CUTS(1),CUTGAM),(MECA(1,1),IPAIR)
  43       CHARACTER*4 DNAME,KCUT(10)
  44       CHARACTER*20 CHTITL
  45       LOGICAL NUCRIN
  46 C.
  47 C.    ------------------------------------------------------------------
  48 C.
  49 C              Write RUN parameters, version numbers and CUTS
  50 C
  51       WRITE(CHMAIL,10000)
  52       CALL GMAIL(0,0)
  53       WRITE(CHMAIL,10100)
  54       CALL GMAIL(0,0)
  55       WRITE(CHMAIL,10200)GVERSN,IGDATE,IGTIME
  56       CALL GMAIL(0,0)
  57       WRITE(CHMAIL,10100)
  58       CALL GMAIL(0,0)
  59       WRITE(CHMAIL,10300)IDRUN
  60       CALL GMAIL(0,0)
  61       WRITE(CHMAIL,10100)
  62       CALL GMAIL(0,0)
  63       WRITE(CHMAIL,10400)
  64       CALL GMAIL(0,0)
  65       WRITE(CHMAIL,10100)
  66       CALL GMAIL(0,0)
  67       WRITE(CHMAIL,10500)
  68       CALL GMAIL(0,0)
  69       WRITE(CHMAIL,10600)
  70       CALL GMAIL(0,0)
  71       WRITE(CHMAIL,10100)
  72       CALL GMAIL(0,0)
  73 C
  74 C              Get the version number of the original INIT structure
  75 C
  76       OLDGVE=BIG
  77 *
  78 *        Set NUMOLD to 0 to force recalculation of
  79 *        pointers in the tracking routines
  80       NUMOLD=0
  81       IF(JRUNG.NE.0)THEN
  82          OLDGVE =  Q(JRUNG+21)
  83          IQ(JRUNG+11)=IGDATE
  84          IQ(JRUNG+12)=IGTIME
  85          Q(JRUNG+21)=GVERSN
  86          Q(JRUNG+22)=ZVERSN
  87 C
  88          DNAME='INIT'
  89          WRITE(CHMAIL,10700) DNAME,IQ(JRUNG+11),IQ(JRUNG+12), Q(JRUNG+
  90      +   21), Q(JRUNG+22)
  91          CALL GMAIL(0,0)
  92          WRITE(CHMAIL,10100)
  93          CALL GMAIL(0,0)
  94          DNAME='KINE'
  95          WRITE(CHMAIL,10700) DNAME,IQ(JRUNG+13),IQ(JRUNG+14), Q(JRUNG+
  96      +   23), Q(JRUNG+24)
  97          CALL GMAIL(0,0)
  98          WRITE(CHMAIL,10100)
  99          CALL GMAIL(0,0)
 100          DNAME='HITS'
 101          WRITE(CHMAIL,10700) DNAME,IQ(JRUNG+15),IQ(JRUNG+16), Q(JRUNG+
 102      +   25), Q(JRUNG+26)
 103          CALL GMAIL(0,0)
 104          WRITE(CHMAIL,10100)
 105          CALL GMAIL(0,0)
 106          DNAME='DIGI'
 107          WRITE(CHMAIL,10700) DNAME,IQ(JRUNG+17),IQ(JRUNG+18), Q(JRUNG+
 108      +   27), Q(JRUNG+28)
 109          CALL GMAIL(0,0)
 110          WRITE(CHMAIL,10100)
 111          CALL GMAIL(0,0)
 112          IF(NRNDM(1).EQ.0.AND.NRNDM(2).EQ.0) THEN
 113 *
 114 *             The random number sequence has not been explicitely
 115 *             initialised via a data card. See whether we can initialise
 116 *             it with the words 19/20 of the JRUNG data structure.
 117             IF(IQ(JRUNG+19).NE.0.OR.IQ(JRUNG+20).NE.0) THEN
 118                NRNDM(1) = IQ(JRUNG+19)
 119                NRNDM(2) = IQ(JRUNG+20)
 120                CALL GRNDMQ(NRNDM(1), NRNDM(2), 0, 'S')
 121             ENDIF
 122          ENDIF
 123          CALL GRNDMQ(IQ(JRUNG+19), IQ(JRUNG+20), 0, 'G')
 124          WRITE(CHMAIL,10900) IQ(JRUNG+19), IQ(JRUNG+20)
 125          CALL GMAIL(0,0)
 126          WRITE(CHMAIL,11000)
 127          CALL GMAIL(0,0)
 128          WRITE(CHMAIL,10100)
 129          CALL GMAIL(0,0)
 130       ENDIF
 131 C
 132 C             Create energy loss and cross-section banks
 133 C
 134       IF(NEKBIN.LE.0.OR.NEKBIN.GT.199)NEKBIN=90
 135       IF(EKMIN.GE.EKMAX.OR.EKMIN.LE.0.)THEN
 136          EKMIN=1.E-5
 137          EKMAX=1.E+4
 138       ENDIF
 139       NEK1=NEKBIN+1
 140       EKINV=1./LOG10(EKMAX/EKMIN)
 141       EKBIN(1)=LOG10(EKMIN)
 142       ELOW(1)=EKMIN
 143       GEKA=NEKBIN*EKINV
 144       GEKB=1.-GEKA*EKBIN(1)
 145       DO 10 I=2,NEK1
 146          EL=EKBIN(1)+(I-1)/GEKA
 147          EKBIN(I)=EL
 148          ELOW(I)=10.**EL
 149    10 CONTINUE
 150       ILOW=0
 151       IF(NMATE.LE.0)GO TO 999
 152       IF(JMATE.LE.0)GO TO 999
 153       IF(JTMED.LE.0)GO TO 999
 154 C
 155       IF(IQ(JTMED-1).LT.40) THEN
 156          NPUSH=40-IQ(JTMED-1)
 157          CALL MZPUSH(IXCONS,JTMED,0,NPUSH,'I')
 158       END IF
 159       Q(JTMED+31)=ILABS
 160       Q(JTMED+32)=ISYNC
 161       Q(JTMED+33)=ISTRA
 162 *
 163 *             If Landau fluctuations activated, cancel delta rays
 164       KLOS=Q(JTMED+21)
 165       IF (KLOS .EQ. 0) Q(JTMED+15) = 0.
 166       IF (KLOS .EQ. 2) THEN
 167          Q(JTMED+ 8)=9999.
 168          Q(JTMED+ 9)=9999.
 169          Q(JTMED+15)=0.
 170       ENDIF
 171 *
 172 * If Cerenkov generation is on, activate Light absorbtion unless
 173 * explicitely switched off by the user
 174 *
 175       KLABS=Q(JTMED+31)
 176       IF(ITCKOV.NE.0) THEN
 177          IF(KLABS.EQ.-1) THEN
 178             Q(JTMED+31)=1
 179          ENDIF
 180       ENDIF
 181       Q(JTMED+31)=MAX(Q(JTMED+31),0.)
 182 *
 183 *             If BCUTE,BCUTM,DCUTE,DCUTM,PPCUTM not initialized (=BIG)
 184 *             Set them to CUTGAM,CUTGAM,CUTELE,CUTELE respectively
 185 *
 186       IF(Q(JTMED+ 6).GT.0.9*BIG)Q(JTMED+ 6)=Q(JTMED+1)
 187       IF(Q(JTMED+ 7).GT.0.9*BIG)Q(JTMED+ 7)=Q(JTMED+1)
 188       IF(Q(JTMED+ 8).GT.0.9*BIG)Q(JTMED+ 8)=Q(JTMED+2)
 189       IF(Q(JTMED+ 9).GT.0.9*BIG)Q(JTMED+ 9)=Q(JTMED+2)
 190       IF(Q(JTMED+10).GT.0.9*BIG)Q(JTMED+10)=0.010
 191       IF(Q(JTMED+10).LT.4.*EMASS)Q(JTMED+10)=4.*EMASS
 192 C
 193       DO 20 K=1,10
 194    20 CALL GEVKEV(Q(JTMED+K),UCUT(K),KCUT(K))
 195       WRITE(CHMAIL,10800)
 196       CALL GMAIL(0,0)
 197       WRITE(CHMAIL,10100)
 198       CALL GMAIL(0,0)
 199       WRITE(CHMAIL,11100)
 200       CALL GMAIL(0,0)
 201       WRITE(CHMAIL,11200)
 202       CALL GMAIL(0,0)
 203       WRITE(CHMAIL,10100)
 204       CALL GMAIL(0,0)
 205       WRITE(CHMAIL,11300) (UCUT(K),KCUT(K),K=1,3)
 206       CALL GMAIL(0,0)
 207       WRITE(CHMAIL,11400) (UCUT(K),KCUT(K),K=4,5)
 208       CALL GMAIL(0,0)
 209       WRITE(CHMAIL,11500) (UCUT(K),KCUT(K),K=6,7)
 210       CALL GMAIL(0,0)
 211       WRITE(CHMAIL,11600) (UCUT(K),KCUT(K),K=8,10)
 212       CALL GMAIL(0,0)
 213       WRITE(CHMAIL,11700) (Q(JTMED+K),K=11,13)
 214       CALL GMAIL(0,0)
 215       WRITE(CHMAIL,11800) (Q(JTMED+K),K=14,16)
 216       CALL GMAIL(0,0)
 217       IF(Q(JTMED+18).EQ.3.) THEN
 218          NUCRIN = .TRUE.
 219          Q(JTMED+18)=1.
 220       ELSE
 221          NUCRIN = .FALSE.
 222       ENDIF
 223       WRITE(CHMAIL,11900) (Q(JTMED+K),K=17,19)
 224       CALL GMAIL(0,0)
 225       WRITE(CHMAIL,12000) (Q(JTMED+K),K=20,22)
 226       CALL GMAIL(0,0)
 227       WRITE(CHMAIL,12100) Q(JTMED+23),Q(JTMED+31),Q(JTMED+32)
 228       CALL GMAIL(0,0)
 229       WRITE(CHMAIL,12110) Q(JTMED+33)
 230       CALL GMAIL(0,0)
 231       WRITE(CHMAIL,10100)
 232       CALL GMAIL(0,0)
 233       IF(NUCRIN) THEN
 234          WRITE(CHMAIL,10100)
 235          CALL GMAIL(0,0)
 236          WRITE(CHMAIL,12800)
 237          CALL GMAIL(0,0)
 238          WRITE(CHMAIL,12900)
 239          CALL GMAIL(0,0)
 240          WRITE(CHMAIL,10100)
 241          CALL GMAIL(0,0)
 242       ENDIF
 243 *
 244 * ***    Here we clean up the old cross section tables if any
 245       DO 40  IMA=1,NMATE
 246          JMA=LQ(JMATE-IMA)
 247          IF(JMA.NE.0) THEN
 248             DO 30  J=1,20
 249                IF(LQ(JMA-J).NE.0.AND.J.NE.5) THEN
 250                   CALL MZDROP(IXCONS,LQ(JMA-J),'L')
 251                ENDIF
 252    30       CONTINUE
 253          ENDIF
 254    40 CONTINUE
 255 *
 256 * *** Call initialisation of the phtotelectric effect constants
 257       CALL GPHINI
 258       DO 180 ITM=1,NTMED
 259          JTM=LQ(JTMED-ITM)
 260          IF(JTM.LE.0) GO TO 180
 261          NL=10-IQ(JTM-2)
 262          IF(NL.GT.0)THEN
 263             CALL MZPUSH(IXCONS,JTM,NL,0,'I')
 264             JTM=LQ(JTMED-ITM)
 265          ENDIF
 266 *         IF(IQ(JTM-1).LT.40) THEN
 267 *           NPUSH=40-IQ(JTM-1)
 268 *           CALL MZPUSH(IXCONS,JTM,0,NPUSH,'I')
 269 *           JTM=LQ(JTMED-ITM)
 270 *         ENDIF
 271          ISVOL = Q(JTM + 7)
 272          IFIELD = Q(JTM + 8)
 273          FIELDM = Q(JTM + 9)
 274          TMAXFD = Q(JTM + 10)
 275          STEMAX = Q(JTM + 11)
 276          DEEMAX = Q(JTM + 12)
 277          EPSIL = Q(JTM + 13)
 278          STMIN = Q(JTM + 14)
 279          IF (TMAXFD.LE.0..OR. (IGAUTO.NE.0.AND.TMAXFD.GT.20.)) THEN
 280             TMAXFD=20.
 281             Q(JTM+10) = TMAXFD
 282          ENDIF
 283          NMAT = Q(JTM+6)
 284          JMA = LQ(JMATE-NMAT)
 285          IF(JMA.LE.0)THEN
 286             WRITE(CHMAIL,12200)NMAT,ITM
 287             CALL GMAIL(1,1)
 288             GO TO 180
 289          ENDIF
 290 C
 291 C=====>       Get material parameters
 292 C
 293          A=Q(JMA+6)
 294          Z=Q(JMA+7)
 295          DENS=Q(JMA+8)
 296          RADL=Q(JMA+9)
 297          IF (Z.LT.1.) THEN
 298             DEEMAX=0.
 299             STMIN =0.
 300             JTP=LQ(JTM)
 301             IF(JTP.EQ.0) THEN
 302                CALL MZBOOK(IXCONS,JTP,JTM,0,'TCUT',0,0,40,3,0)
 303                IQ(JTP-5)=ITM
 304                DO 50 I=1,23
 305                   Q(JTP+I)=Q(JTMED+I)
 306    50          CONTINUE
 307                Q(JTP+31)=Q(JTMED+31)
 308                Q(JTP+32)=Q(JTMED+32)
 309                Q(JTP+33)=Q(JTMED+33)
 310             ELSEIF(IQ(JTP-1).LT.40) THEN
 311                NPUSH=40-IQ(JTP-1)
 312                CALL MZPUSH(IXCONS,JTP,0,NPUSH,'I')
 313                JTP=LQ(JTM)
 314                Q(JTP+31)=Q(JTMED+31)
 315                Q(JTP+32)=Q(JTMED+32)
 316                Q(JTP+33)=Q(JTMED+33)
 317             ENDIF
 318 C
 319 C=====>     decay and synch. rad. in vacuum
 320 C
 321             DO 60 I=11,23
 322                Q(JTP+I)=0.
 323    60       CONTINUE
 324             Q(JTP+20) = Q(JTMED+20)
 325             Q(JTP+31) = 0.
 326             Q(JTP+32) = Q(JTMED+32)
 327             Q(JTP+33) =0.
 328          ENDIF
 329 C
 330 C=====>       Get tracking medium parameters
 331 C
 332          JTP=JTMED
 333          IF(LQ(JTM).NE.0)JTP=LQ(JTM)
 334          IF(JTP.NE.JTMED)THEN
 335             IF(IQ(JTP-1).LT.40) THEN
 336                NPUSH=40-IQ(JTP-1)
 337                CALL MZPUSH(IXCONS,JTP,0,NPUSH,'I')
 338                JTP=LQ(JTM)
 339                Q(JTP+31)=Q(JTMED+31)
 340                Q(JTP+32)=Q(JTMED+32)
 341                Q(JTP+33)=Q(JTMED+33)
 342             ENDIF
 343             KLOS=Q(JTP+21)
 344             IF (KLOS .EQ. 2) THEN
 345                Q(JTP+ 8)=9999.
 346                Q(JTP+ 9)=9999.
 347                Q(JTP+15)=0.
 348             ENDIF
 349 *
 350 * If Cerenkov generation is on, activate Light absorbtion unless
 351 * explicitely switched off by the user
 352 *
 353             KLABS=Q(JTP+31)
 354             IF(ITCKOV.NE.0) THEN
 355                IF(KLABS.EQ.-1) THEN
 356                   Q(JTP+31)=1
 357                ENDIF
 358             ENDIF
 359             Q(JTP+31)=MAX(Q(JTP+31),0.)
 360             IF(Q(JTP+ 6).GT.0.9*BIG)Q(JTP+ 6)=Q(JTP+1)
 361             IF(Q(JTP+ 7).GT.0.9*BIG)Q(JTP+ 7)=Q(JTP+1)
 362             IF(Q(JTP+ 8).GT.0.9*BIG)Q(JTP+ 8)=Q(JTP+2)
 363             IF(Q(JTP+ 9).GT.0.9*BIG)Q(JTP+ 9)=Q(JTP+2)
 364             IF(Q(JTP+10).GT.0.9*BIG)Q(JTP+10)=0.010
 365             IF(Q(JTP+10).LT.4.*EMASS)Q(JTP+10)=4.*EMASS
 366 *
 367             CALL UHTOC(IQ(JTM+1),4,CHTITL,20)
 368             LAST=LNBLNK(CHTITL)
 369             IF(LAST.GT.0) THEN
 370                IF(CHTITL(LAST:LAST).EQ.'$') LAST=LAST-1
 371                IF(LAST.LT.20) CHTITL(LAST+1:20)=' '
 372             ENDIF
 373 *
 374             DO 70 K=1,10
 375    70       CALL GEVKEV(Q(JTP+K),UCUT(K),KCUT(K))
 376             WRITE(CHMAIL,10100)
 377             CALL GMAIL(0,0)
 378             WRITE(CHMAIL,12300)ITM,CHTITL
 379             CALL GMAIL(0,0)
 380             WRITE(CHMAIL,12400)
 381             CALL GMAIL(0,0)
 382             WRITE(CHMAIL,11300) (UCUT(K),KCUT(K),K=1,3)
 383             CALL GMAIL(0,0)
 384             WRITE(CHMAIL,11400) (UCUT(K),KCUT(K),K=4,5)
 385             CALL GMAIL(0,0)
 386             WRITE(CHMAIL,11500) (UCUT(K),KCUT(K),K=6,7)
 387             CALL GMAIL(0,0)
 388             WRITE(CHMAIL,11600) (UCUT(K),KCUT(K),K=8,10)
 389             CALL GMAIL(0,0)
 390             WRITE(CHMAIL,11700) (Q(JTP+K),K=11,13)
 391             CALL GMAIL(0,0)
 392             WRITE(CHMAIL,11800) (Q(JTP+K),K=14,16)
 393             CALL GMAIL(0,0)
 394             IF(Q(JTP+18).EQ.3.) THEN
 395                NUCRIN = .TRUE.
 396                Q(JTP+18)=1.
 397             ELSE
 398                NUCRIN = .FALSE.
 399             ENDIF
 400             WRITE(CHMAIL,11900) (Q(JTP+K),K=17,19)
 401             CALL GMAIL(0,0)
 402             WRITE(CHMAIL,12000) (Q(JTP+K),K=20,22)
 403             CALL GMAIL(0,0)
 404             WRITE(CHMAIL,12100) Q(JTP+23),Q(JTP+31),Q(JTP+32)
 405             CALL GMAIL(0,0)
 406             WRITE(CHMAIL,12110) Q(JTP+33)
 407             CALL GMAIL(0,0)
 408             WRITE(CHMAIL,10100)
 409             CALL GMAIL(0,0)
 410             IF(NUCRIN) THEN
 411                WRITE(CHMAIL,10100)
 412                CALL GMAIL(0,0)
 413                WRITE(CHMAIL,12800)
 414                CALL GMAIL(0,0)
 415                WRITE(CHMAIL,12900)
 416                CALL GMAIL(0,0)
 417                WRITE(CHMAIL,10100)
 418                CALL GMAIL(0,0)
 419             ENDIF
 420          ENDIF
 421 C
 422          DO 80 I=1,10
 423             CUTS(I)=Q(JTP+I)
 424    80    CONTINUE
 425          DO 90 I=1,13
 426             MECA(1,I)=Q(JTP+10+I)
 427    90    CONTINUE
 428          ILABS=Q(JTP+10+21)
 429          ISYNC=Q(JTP+10+22)
 430          ISTRA=Q(JTP+10+23)
 431 C
 432          IF(ILOW.EQ.0)THEN
 433             DO 100 I=1,10
 434                IF(Q(JTP+I).LT.0.0000099)THEN
 435                   WRITE(CHMAIL,12500)
 436                   CALL GMAIL(1,1)
 437                   ILOW=1
 438                ENDIF
 439   100       CONTINUE
 440          ENDIF
 441 C
 442 C             Check consistency of different tracking media
 443 C             referencing the same material
 444 C
 445          DO 120 ITM2=ITM+1,NTMED
 446             JTM2=LQ(JTMED-ITM2)
 447             IF(JTM2.NE.0)THEN
 448                NMAT2=Q(JTM2+6)
 449                IF(NMAT2.EQ.NMAT)THEN
 450                   JTP2=JTMED
 451                   IF(LQ(JTM2).NE.0)JTP2=LQ(JTM2)
 452                   IF(JTP.NE.JTP2)THEN
 453                      IF(JTP2.NE.JTMED)THEN
 454                         KLOS=Q(JTP2+21)
 455                         IF (KLOS .EQ. 2) THEN
 456                            Q(JTP2+ 8)=9999.
 457                            Q(JTP2+ 9)=9999.
 458                            Q(JTP2+15)=0.
 459                         ENDIF
 460                         IF(Q(JTP2+ 6).GT.0.9*BIG)Q(JTP2+ 6)=Q(JTP2+1)
 461                         IF(Q(JTP2+ 7).GT.0.9*BIG)Q(JTP2+ 7)=Q(JTP2+1)
 462                         IF(Q(JTP2+ 8).GT.0.9*BIG)Q(JTP2+ 8)=Q(JTP2+2)
 463                         IF(Q(JTP2+ 9).GT.0.9*BIG)Q(JTP2+ 9)=Q(JTP2+2)
 464                         IF(Q(JTP2+10).GT.0.9*BIG)Q(JTP2+10)=0.010
 465                         IF(Q(JTP2+10).LT.4.*EMASS)Q(JTP2+10)=4.*EMASS
 466                      ENDIF
 467                      DO 110 I=6,10
 468                         IF(Q(JTP+I).NE.Q(JTP2+I))THEN
 469                            WRITE(CHMAIL,12600)NMAT
 470                            CALL GMAIL(1,0)
 471                            WRITE(CHMAIL,12700)ITM,ITM2
 472                            CALL GMAIL(0,1)
 473                            GO TO 120
 474                         ENDIF
 475   110                CONTINUE
 476                   ENDIF
 477                ENDIF
 478             ENDIF
 479   120    CONTINUE
 480          IF (DEEMAX.LT.0.) THEN
 481             IF(ISVOL.EQ.0)THEN
 482                DEEMAX=0.25
 483                IF(RADL.GT.2.)DEEMAX=0.25-0.2/SQRT(RADL)
 484             ELSE
 485                DEEMAX = 0.2/SQRT(RADL)
 486             ENDIF
 487          ENDIF
 488          IF(OLDGVE.LT.3.15.OR.STEMAX.LE.0.) THEN
 489 *
 490 *       Before version 3.15 there was no STEMAX, so we put it to BIG
 491             STEMAX=BIG
 492          ENDIF
 493          Q(JTM+11) = STEMAX
 494          Q(JTM+12) = DEEMAX
 495 C
 496 *
 497 *       It can happen that several tracking media refer to the
 498 *       same material. In this case we do not fill the cross section
 499 *       tables more than once. But we still fill the banks of the
 500 *       tracking medium.
 501          IF(LQ(JMA-1).NE.0) GOTO 160
 502          NPUSH=20-IQ(JMA-2)
 503          IF(NPUSH.GT.0)THEN
 504             CALL MZPUSH(IXCONS,JMA,NPUSH,0,'I')
 505             JTM=LQ(JTMED-ITM)
 506             JMA=LQ(JMATE-NMAT)
 507          ENDIF
 508 *
 509 *     Energy loss and cross-section tables
 510          IF(ISTRA.EQ.0) THEN
 511          CALL MZBOOK(IXCONS,LBANK,JMA, -1,'MAEL',0,0,2*NEK1,3,0)
 512          CALL MZBOOK(IXCONS,LBANK,JMA, -2,'MAMU',0,0, NEK1,3,0)
 513          ELSE
 514          CALL MZBOOK(IXCONS,LBANK,JMA, -1,'MAEL',0,0,3*NEK1,3,0)
 515          CALL MZBOOK(IXCONS,LBANK,JMA, -2,'MAMU',0,0,2*NEK1,3,0)
 516          ENDIF
 517          CALL MZBOOK(IXCONS,LBANK,JMA, -3,'MAAL',0,0, NEK1,3,0)
 518          CALL MZBOOK(IXCONS,JPROB,JMA, -4,'MAPR',0,0, 40,3,0)
 519          CALL MZBOOK(IXCONS,JPHOT,JMA, -6,'MAPH',2,2, NEK1,3,0)
 520          CALL MZBOOK(IXCONS,JANNI,JMA, -7,'MAAN',0,0, NEK1,3,0)
 521          CALL MZBOOK(IXCONS,JCOMP,JMA, -8,'MACO',0,0, NEK1,3,0)
 522          CALL MZBOOK(IXCONS,JBREM,JMA, -9,'MABR',0,0,3*NEK1,3,0)
 523          CALL MZBOOK(IXCONS,JPAIR,JMA,-10,'MAPA',0,0,2*NEK1,3,0)
 524          CALL MZBOOK(IXCONS,JDRAY,JMA,-11,'MADR',0,0,3*NEK1,3,0)
 525 *
 526 * *** Special case for heavy materials, photo-fission
 527          IF(A.GE.230..AND.A.LE.240..AND.IPFIS.NE.0)THEN
 528             CALL MZBOOK(IXCONS,JPFIS,JMA,-12,'MAPF',0,0,2*NEK1,3,0)
 529          ENDIF
 530 *
 531 * *** Rayleigh effect
 532          CALL MZBOOK(IXCONS,JRAYL,JMA,-13,'MARA',0,0,2*NEK1,3,0)
 533 *
 534 * *** Muon nuclear interactions
 535          IF(IMUNU.EQ.0)THEN
 536             JMUNU=0
 537          ELSE
 538             CALL MZBOOK(IXCONS,JMUNU,JMA,-14,'MAMN',0,0,NEK1,3,0)
 539          ENDIF
 540 *
 541 * *** stopping range
 542          CALL MZBOOK(IXCONS,LBANK,JMA,-15,'MASE',0,0,2*NEK1,3,0)
 543          CALL MZBOOK(IXCONS,LBANK,JMA,-16,'MASM',0,0,2*NEK1,3,0)
 544 *
 545 * *** Special for photeffect
 546          CALL GPHXSI
 547 *
 548 * *** coefficients for energy loss
 549          CALL MZBOOK(IXCONS,LBANK,JMA,-17,'MACE',0,0,6*NEK1,3,0)
 550          CALL MZBOOK(IXCONS,LBANK,JMA,-18,'MACM',0,0,6*NEK1,3,0)
 551 *
 552 * *** auxiliary tables for integration of dE/dx
 553          CALL GWORK(NEKBIN*4)
 554 *
 555          DO 130 JWORK=1, NEKBIN*4
 556             WS(JWORK) = 0.
 557   130    CONTINUE
 558 *
 559 * *** Straggling for thin layers, if in effect
 560          IF(ISTRA.GT.0) THEN
 561             CALL MZBOOK(IXCONS,JTSTRA,JMA,-19,'MAST',2,2,1,3,0)
 562 #if defined(CERNLIB_ASHO)
 563             IF(ISTRA.EQ.2) THEN
 564                CALL MZBOOK(IXCONS,JTASHO,JMA,-20,'MASH',0,0,106,3,0)
 565             ENDIF
 566 #endif
 567          ENDIF
 568 *
 569          DO 140 J=1,20
 570             JB=LQ(JMA-J)
 571             IF(JB.NE.0)IQ(JB-5)=NMAT
 572   140    CONTINUE
 573 C
 574          JPROB=LQ(JMA-4)
 575          JMIXT=LQ(JMA-5)
 576          JPFIS=LQ(JMA-12)
 577 *
 578 * *** Fill above tables (energy losses,cross-sections,stopping ranges)
 579 *
 580          CALL GPROBI
 581 C
 582          DO 150 IEKBIN=1,NEK1
 583 C
 584             CALL GDRELA
 585             CALL GBRELA
 586             CALL GPRELA
 587 C
 588             CALL GPHOTI
 589             CALL GRAYLI
 590             CALL GANNII
 591             CALL GCOMPI
 592             CALL GBRSGA
 593             CALL GPRSGA
 594             CALL GDRSGA
 595             CALL GMUNUI
 596             CALL GPFISI
 597   150    CONTINUE
 598 *
 599 *           Stopping ranges
 600 *
 601          CALL GRANGI
 602 *
 603 *           Energy loss coefficients
 604 *
 605          CALL GCOEFF
 606 * *** The table for the energy loss in thin gas layers if the tracking
 607 *     media is defined as such
 608 *
 609          IF(ISTRA.GT.0) THEN
 610             CALL GSTINI
 611 #if defined(CERNLIB_ASHO)
 612             IF (ISTRA.EQ.2) THEN
 613                CALL GIASHO
 614             ENDIF
 615 #endif
 616          ENDIF
 617 *
 618 * *** Multiple scattering,energy-loss and mag.field steps
 619   160    DO 170 J=1,2
 620             IF(LQ(JTM-J).NE.0) THEN
 621                CALL MZDROP(IXCONS,LQ(JTM-J),'L')
 622             ENDIF
 623   170    CONTINUE
 624          CALL MZBOOK(IXCONS,LBANK,JTM, -1,'MUEL',0,0,NEK1+2,3,0)
 625          IQ(LBANK-5)=ITM
 626          CALL MZBOOK(IXCONS,LBANK,JTM, -2,'MUMU',0,0,NEK1+2,3,0)
 627          IQ(LBANK-5)=ITM
 628          CALL GMULOF
 629 C
 630   180 CONTINUE
 631 *
 632       WRITE(CHMAIL,10100)
 633       CALL GMAIL(0,0)
 634       WRITE(CHMAIL,10400)
 635       CALL GMAIL(0,2)
 636 C
 637 10000 FORMAT(
 638      +'1************************************************************')
 639 10100 FORMAT(
 640      +' *                                                          *')
 641 10200 FORMAT(
 642      +' *    G E A N T  Version',F7.4,'      DATE/TIME',I7,'/',
 643      +   I4,2X,'*')
 644 10300 FORMAT(
 645      +' *                      R U N  ',I5,10X,'              *')
 646 10400 FORMAT(
 647      +' ************************************************************')
 648 10500 FORMAT(
 649      +' *      Data structure   Date   Time    GVERSN    ZVERSN    *')
 650 10600 FORMAT(
 651      +' *      --------------   ----   ----    ------    ------    *')
 652 10700 FORMAT(' *',11X,A,6X,I7,2X,I4,3X,F7.4,2X,F7.2,5X,'*')
 653 10800 FORMAT(
 654      +' *----------------------------------------------------------*')
 655 10900 FORMAT(' *     Random number seeds: ',3X,I10,3X,I10,6X,'*')
 656 11000 FORMAT(
 657      +' *     --------------------                                 *')
 658 11100 FORMAT(
 659      +' *              Standard TPAR for this run are              *')
 660 11200 FORMAT(
 661      +' *              ------------------------------              *')
 662 11300 FORMAT(
 663      +' *  CUTGAM=',F6.2,A4,'  CUTELE=',F6.2,A4,'  CUTNEU=',F6.2,A4,1X,
 664      + '*')
 665 11400 FORMAT(
 666      +' *  CUTHAD=',F6.2,A4,'  CUTMUO=',F6.2,A4,20X,'*')
 667 11500 FORMAT(
 668      +' *  BCUTE =',F6.2,A4,'  BCUTM =',F6.2,A4,20X,'*')
 669 11600 FORMAT(
 670      +' *  DCUTE =',F6.2,A4,'  DCUTM =',F6.2,A4,'  PPCUTM=',F6.2,A4,1X,
 671      + '*')
 672 11700 FORMAT(
 673      +' *  IPAIR =',F10.0,'  ICOMP =',F10.0,'  IPHOT =',F10.0,1X,'*')
 674 11800 FORMAT(
 675      +' *  IPFIS =',F10.0,'  IDRAY =',F10.0,'  IANNI =',F10.0,1X,'*')
 676 11900 FORMAT(
 677      +' *  IBREM =',F10.0,'  IHADR =',F10.0,'  IMUNU =',F10.0,1X,'*')
 678 12000 FORMAT(
 679      +' *  IDCAY =',F10.0,'  ILOSS =',F10.0,'  IMULS =',F10.0,1X,'*')
 680 12100 FORMAT(
 681      +' *  IRAYL =',F10.0,'  ILABS =',F10.0,'  ISYNC =',F10.0,1X,'*')
 682 12110 FORMAT(
 683      +' *  ISTRA =',F10.0, 39X,                                  '*')
 684
 685 12200 FORMAT(' ***** GPHYSI error, Material Nr=',I3,
 686      + ' referenced by Medium Nr=',I3)
 687 12300 FORMAT(
 688      +' *     Special TPAR for TMED',I4,3X,A,5X,'*')
 689 12400 FORMAT(
 690      +' *     -------------------------                            *')
 691 12500 FORMAT(' ***** GPHYSI error, CUTS must be',
 692      + ' greater than 10 KeV *****')
 693 12600 FORMAT(' ***** GPHYSI error for material nr ',I4)
 694 12700 FORMAT(7X,'Tracking medium NR',I4,' and',I4,
 695      +' have different parameters')
 696 12800 FORMAT(
 697      +' *  IHADR=3 not supported any more. GHEISHA will handle     *')
 698 12900 FORMAT(
 699      +' *  hadronic interactions for the above tracking medium     *')
 700   999 END