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