This commit was generated by cvs2svn to compensate for changes in r2,
[u/mrichter/AliRoot.git] / 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