/[PAMELA software]/gpamela/gpcalor/gpcalor.F
ViewVC logotype

Annotation of /gpamela/gpcalor/gpcalor.F

Parent Directory Parent Directory | Revision Log Revision Log

Revision 1.1 - (hide annotations) (download)
Wed Dec 14 03:13:55 2005 UTC (19 years, 2 months ago) by cafagna
Branch: MAIN
CVS Tags: v4r4, v4r5, v4r6, v4r7, v4r8, v4r9, v4r14, v4r12, v4r13, v4r10, v4r11, HEAD 
Neutron detector added. Geometry and GPCALOR package
1 cafagna 1.1 *CMZ : 1.05/00 08/07/99 11.14.36 by Christian Zeitnitz
2     *-- Author : Christian Zeitnitz
3     SUBROUTINE GCALOR
4     ********************************************************************
5     * *
6     * PURPOSE: GEANT interface to CALOR *
7     * *
8     * CALLED BY : GUHADR *
9     * *
10     * INPUT : particle, material, and probabilities via GEANT common *
11     * *
12     * OUTPUT : COMMON GCKING, DESTEP *
13     * KCALL = -1 : Nothing done *
14     * = 0 : NMTC has been called *
15     * = 1 : MICAP has been called *
16     * = 2 : HETC/SKALE has been called *
17     * = 3 : FLUKA has been called *
18     * *
19     * AUTHOR : C.Zeitnitz (University of Arizona) *
20     * *
21     ********************************************************************
22     C.
23     C. --- GEANT Commons
24     #include "gcbank.inc"
25     #include "gcjloc.inc"
26     #include "gckine.inc"
27     #include "gcking.inc"
28     #include "gcmate.inc"
29     #include "gcphys.inc"
30     #include "gctrak.inc"
31     #include "gsecti.inc"
32     #include "gconst.inc"
33     #include "gccuts.inc"
34     #include "gcflag.inc"
35     #include "calgea.inc"
36     #include "cerrcm.inc"
37     #include "camass.inc"
38     C
39     C Avogadro number multiplied by 1.E-24
40     PARAMETER(XNAVO = 0.60221367)
41     C
42     DIMENSION NNPART(12)
43     LOGICAL INIT,GOFLUK,DOSKAL,FMICAP,SKALEF,NABSOR,FSTOP
44     DOUBLE PRECISION DECIN,DMASS
45     C
46     DATA INIT /.TRUE./
47     SAVE INIT
48     C
49     IF ( INIT ) THEN
50     C
51     C initialize CALOR
52     CALL CALINI
53     C
54     INIT = .FALSE.
55     C
56     ENDIF
57     KCALL = -1
58     C
59     C get CALOR particle type
60     IPINC = -1
61     IF(IPART .LE. 48 ) IPINC = IGECAL(IPART)
62     C
63     C energy in MeV
64    
65     EINC =GEKIN * 1000.0
66     UINC(1)=VECT(4)
67     UINC(2)=VECT(5)
68     UINC(3)=VECT(6)
69     KCASE=NAMEC(12)
70     NGKINE = 0
71     NABSOR = .FALSE.
72     FSTOP = .FALSE.
73     C ----- particle has to be stopped ? -------
74     IF(GEKIN.LT.CUTHAD.AND.ITRTYP.EQ.4) THEN
75     FSTOP = .TRUE.
76     ISTOP = 2
77     IF(IPART .EQ. 9) THEN
78     NABSOR = .TRUE.
79     ISTOP = 1
80     EINC = 1.0
81     IF(GEKIN.GT.EINC/1000.) DESTEP = DESTEP + GEKIN - EINC/
82     + 1000.0
83     GEKIN = 0.0
84     VECT(7) = 0.0
85     KCASE = NAMEC(18)
86     NMEC = NMEC + 1
87     LMEC(NMEC) = 18
88     ELSE
89     DESTEP = DESTEP + GEKIN
90     GEKIN = 0.0
91     VECT(7) = 0.0
92     IF(IPART.EQ.8.OR.IPART.EQ.11.OR.IPART.EQ.12) THEN
93     CALL GDECAY
94     KCASE = NAMEC(5)
95     NMEC = NMEC + 1
96     LMEC(NMEC) = 5
97     ENDIF
98     RETURN
99     ENDIF
100     ELSE IF(GEKIN.LT.CUTNEU.AND.IPART.EQ.13) THEN
101     IF(GEKIN.LT.1.E-14) EINC=1.E-11
102     ISTOP = 1
103     NABSOR = .TRUE.
104     ENDIF
105     CZZZ IF(ISTOP.EQ.2.OR.GEKIN.EQ.0.0) RETURN
106     C
107     C ------------- check if FLUKA has to be called ---------
108     C ------------------------------------------------- Goto FLUKA ?
109     C
110     DOSKAL = (IPINC.EQ.0 .OR. IPINC.EQ.1) .AND. GEKIN.GT.EMAXP
111     DOSKAL = DOSKAL .OR. (GEKIN .GT. EMAXPI .AND. (IPINC .GT. 1))
112     IF(ICPROC.GE.0) THEN
113     GOFLUK = ICPROC.EQ.3 .OR. IPINC.EQ.-1
114     DOSKAL = DOSKAL .AND. ICPROC.EQ.2
115     ELSE
116     GOFLUK = IPINC .EQ. -1 .OR. GEKIN .GE. ESKALE
117     DOSKAL = DOSKAL .AND. .NOT.GOFLUK
118     GOFLUK = GOFLUK .OR. (DOSKAL.AND.SKALEF(IPINC,GEKIN,ESKALE))
119     GOFLUK = GOFLUK .AND. .NOT.FSTOP .AND. .NOT.NABSOR
120     ENDIF
121     ICPROC = -1
122     C ------------------------------------------- call FLUKA
123     IF(GOFLUK) THEN
124     CALL FLUFIN
125     KCALL = 3
126     RETURN
127     ENDIF
128     CERRF = .FALSE.
129     IF(IPINC .EQ. 1 .AND. EINC .LE. 20.0) THEN
130     C MICAP needs only GEANT material number
131     NCEL = NMAT
132     C --- low energetic neutron -> call micap
133     CALL MICAP
134     KCALL = 1
135     ELSE
136     NCEL = 1
137     AMED(1) = A
138     ZMED(1) = Z
139     DMED(1) = DENS/A*XNAVO
140     IF(INT(A) .EQ. 1) THEN
141     HDEN = DMED(1)
142     ELSE
143     HDEN = 0.0
144     ENDIF
145     C ------- get material parameter for a mixture---------------------
146     KK=MIN1(ABS(Q(JMA+11)),100.)
147     NCEL = 1
148     IF(KK.GT.1) THEN
149     HDEN = 0.0
150     NCEL = 0
151     AMOL = Q(LQ(JMIXT-1) + 2)
152     DO 10 K=1,KK
153     IF(NINT(Q(JMIXT+K)).EQ.1) THEN
154     C hydrogen density
155     XMOLCM = DENS/AMOL*XNAVO
156     WI = Q(JMIXT+K+2*KK)*AMOL/Q(JMIXT+K)
157     HDEN = HDEN + XMOLCM * WI
158     ELSE
159     NCEL = NCEL + 1
160     AMED(NCEL) = Q(JMIXT+K)
161     ZMED(NCEL) = Q(JMIXT+K+KK)
162     C molekuls/cm^3
163     XMOLCM = DENS/AMOL*XNAVO
164     C number of atoms per molecule
165     WI = Q(JMIXT+K+2*KK)*AMOL/AMED(NCEL)
166     C atoms/cm^3
167     DMED(NCEL) = XMOLCM * WI
168     ENDIF
169     10 CONTINUE
170     ENDIF
171     CALL CHETC(DOSKAL)
172     KCALL = 0
173     IF(DOSKAL) KCALL = 2
174     ENDIF
175     C error ocurred in CALOR ?
176     IF(CERRF) THEN
177     WRITE(IERRU,'('' NEVT,IPART,Ek,NMED,ISTOP,NABSOR,FSTOP :'', '
178     + //' I10,I5,G15.6,2I6,2L6)') IEVENT,IPART,GEKIN,NMAT,
179     + ISTOP,NABSOR,FSTOP
180     ENDIF
181     ESUM =0.
182     EKSUM = 0.
183     PX = 0.
184     PY = 0.
185     PZ = 0.
186     NGKINE = 0
187     PSUM = 0.
188     C
189     ZINTHA=GARNDM(6)
190     SLHADR=SLENG
191     STEPHA=BIG
192     C
193     IF(NPHETC.EQ.0.AND.NABSOR) ISTOP = 2
194     C neutron has been absorbed -> INTCAL=18
195     IF(INTCAL.EQ.18) ISTOP = 1
196     IF(NPHETC.LE.0) GOTO 160
197     C
198     C too many particles in the CALOR array for GEANT
199     C happens sometimes with deexcitation gammas and evaporation neutrons
200     C simple approach to combine particles and sum up their energies, but
201     C forget about momentum conservation
202     C
203     IF(NPHETC.GT.MXGKIN) THEN
204     20 CONTINUE
205     DO 30 I=1,12
206     NNPART(I)=0
207     30 CONTINUE
208     NNTOT = 0
209     DO 40 I=1,NPHETC
210     IF(IPCAL(I).NE.-1) THEN
211     NNPART(IPCAL(I)+1)=NNPART(IPCAL(I)+1)+1
212     NNTOT = NNTOT + 1
213     ENDIF
214     40 CONTINUE
215     IF(NNTOT.LE.MXGKIN) GOTO 100
216     JMAX=0
217     IMAX=0
218     DO 50 I=1,12
219     IF(JMAX.LT.NNPART(I)) THEN
220     JMAX=NNPART(I)
221     IPI=I-1
222     ENDIF
223     50 CONTINUE
224     DO 60 I=1,NPHETC
225     IF(IPCAL(I).EQ.IPI) GOTO 70
226     60 CONTINUE
227     70 I1=I
228     DO 80 I=I1+1,NPHETC
229     IF(IPCAL(I).EQ.IPI) GOTO 90
230     80 CONTINUE
231     90 I2=I
232     ECINI = EKINET(I1)
233     DMASS = DBLE(XMASS(IPI))*1.D3
234     DECIN = DBLE(ECINI)
235     PPI = SNGL(DSQRT(DECIN*DECIN + 2.D0*DECIN*DMASS))
236     IPJ = IPCAL(I2)
237     ECINJ = EKINET(I2)
238     DECIN = DBLE(ECINJ)
239     PPJ = SNGL(DSQRT(DECIN*DECIN + 2.D0*DECIN*DMASS))
240     ECIN = SNGL(DBLE(ECINI)+DBLE(ECINJ)+DMASS)
241     EKINET(I1) = ECIN
242     PP = SNGL(DSQRT(DBLE(ECIN*ECIN) + 2.D0*DBLE(ECIN)*DMASS))
243     C determine new direction cosines
244     UCAL(I1,1) = (PPI*UCAL(I1,1)+PPJ*UCAL(I2,1))/PP
245     UCAL(I1,2) = (PPI*UCAL(I1,2)+PPJ*UCAL(I2,2))/PP
246     UCAL(I1,3) = (PPI*UCAL(I1,3)+PPJ*UCAL(I2,3))/PP
247     USUM = SQRT(UCAL(I1,1)**2+UCAL(I1,2)**2+UCAL(I1,3)**2)
248     C normalize direction cosines
249     IF(USUM.LT.0.0001) THEN
250     C direction is isotropic distributed
251     CALL AZIRN(SINA,COSA)
252     COSP = SFLRAF(DUM)
253     SINP = SQRT(1.0-COSP*COSP)
254     UCAL(I1,1) = SINP * COSA
255     UCAL(I1,2) = SINP * SINA
256     UCAL(I1,3) = COSP
257     ELSE
258     UCAL(I1,1) = UCAL(I1,1)/USUM
259     UCAL(I1,2) = UCAL(I1,2)/USUM
260     UCAL(I1,3) = UCAL(I1,3)/USUM
261     ENDIF
262     C particle I2 vanished
263     IPCAL(I2)=-1
264     GOTO 20
265     C end of particle combination
266     100 CONTINUE
267     C sort particles
268     I2=NPHETC
269     DO 120 I = 1,NPHETC
270     IF(I.GE.I2) GOTO 130
271     IF(IPCAL(I).EQ.-1) THEN
272     DO 110 J = I2,I,-1
273     IF(IPCAL(J).NE.-1) THEN
274     IPCAL(I) = IPCAL(J)
275     EKINET(I) = EKINET(J)
276     UCAL(I,1) = UCAL(J,1)
277     UCAL(I,2) = UCAL(J,2)
278     UCAL(I,3) = UCAL(J,3)
279     I2 = J-1
280     GOTO 120
281     ENDIF
282     110 CONTINUE
283     ENDIF
284     120 CONTINUE
285     130 CONTINUE
286     NPHETC=MXGKIN
287     ENDIF
288     C
289     IF(INTCAL.LT.1.OR.INTCAL.GT.30) INTCAL=12
290     KCASE = NAMEC(INTCAL)
291     IF(INTCAL.NE.12) THEN
292     NMEC = NMEC + 1
293     LMEC(NMEC) = INTCAL
294     ENDIF
295     DO 140 I=1,NPHETC
296     IP=IPCAL(I)
297     IGPART=ICALGE(IP)
298     IF ( IGPART.EQ.0 ) THEN
299     PRINT*,'>>> ERROR GCALOR: Particle type ',IP, ' not '
300     + //'implemented in GEANT'
301     GOTO 140
302     ENDIF
303     C
304     C store particle
305     ECIN = EKINET(I)/1000.0
306     IF(ECIN.LT.1.E-15) GOTO 140
307     DECIN = DBLE(ECIN)
308     DMASS = DBLE(XMASS(IP))
309     PP = SNGL(DSQRT(DECIN*DECIN + 2.0D0*DECIN*DMASS))
310     PX = PX + PP*UCAL(I,1)
311     PY = PY + PP*UCAL(I,2)
312     PZ = PZ + PP*UCAL(I,3)
313     C generated particle eq incoming
314     IF(NPHETC.EQ.1 .AND. IGPART.EQ.IPART) THEN
315     VECT(4) = UCAL(I,1)
316     VECT(5) = UCAL(I,2)
317     VECT(6) = UCAL(I,3)
318     VECT(7) = PP
319     GEKIN = ECIN
320     GETOT = SNGL(DECIN + DMASS)
321     TOFG = TOFG + CALTIM(I)
322     ISTOP = 0
323     IF(NABSOR) ISTOP = 2
324     GOTO 160
325     ENDIF
326     C
327     NGKINE=NGKINE+1
328     GKIN(1,NGKINE) = PP*UCAL(I,1)
329     GKIN(2,NGKINE) = PP*UCAL(I,2)
330     GKIN(3,NGKINE) = PP*UCAL(I,3)
331     C the total energy is critical for ECIN below 1.E-8 GeV because of
332     C single precision of GKIN (normalization when mass is added)!!
333     C luckely GEANT does use only the momentum components when storing the
334     C particle on the stack.
335     GKIN(4,NGKINE) = SNGL(DECIN+DMASS)
336     GKIN(5,NGKINE) = FLOAT(IGPART)
337     TOFD(NGKINE) = CALTIM(I)
338     GPOS(1,NGKINE) = VECT(1)
339     GPOS(2,NGKINE) = VECT(2)
340     GPOS(3,NGKINE) = VECT(3)
341     IF(NGKINE.GE.MXGKIN) GOTO 150
342     C
343     140 CONTINUE
344     150 CONTINUE
345     C particle lost its identity
346     ISTOP=1
347     160 CONTINUE
348     C
349     C
350     NGKINE = MIN(NGKINE,MXGKIN)
351     C
352     C score kinetic energy of recoil nucleus (given in MeV)
353     CZ DESTEP = DESTEP + ERMED * 1.E-3
354     170 RETURN
355     END
356     *CMZ : 1.05/02 16/05/2000 17.18.13 by Christian Zeitnitz
357     *-- Author : Christian Zeitnitz 27/05/92
358     SUBROUTINE CALINI
359     C**************************************************************
360     C
361     C INITIALIZATION of CALOR
362     C =======================
363     C
364     C Called by : CALSIG , GCALOR
365     C
366     C Author: Christian Zeitnitz 27.5.92
367     C
368     C**************************************************************
369     C
370     C GEANT COMMON
371     #include "gccuts.inc"
372     #include "gctime.inc"
373     #include "gcbank.inc"
374     C CALOR COMMONS
375     #include "calgea.inc"
376     #include "ccomon.inc"
377     #include "cjoint.inc"
378     #include "cinout.inc"
379     #include "cxpd.inc"
380     #include "cmagnt.inc"
381     #include "chie.inc"
382     #include "cgeos.inc"
383     #include "ctncol.inc"
384     #include "minput.inc"
385     #include "cerrcm.inc"
386     #include "camass.inc"
387     C
388     DIMENSION IPID(0:11)
389     LOGICAL INIT,OPENED,EXISTS
390     CHARACTER*100 BERTF
391     CHARACTER*8 VERSQQ
392     CHARACTER*10 DATE
393     CHARACTER*20 NAP
394     CHARACTER*100 CHROOT
395     DATA INIT/.TRUE./
396     C GEANT Particle IDs used to extract masses from GEANT
397     DATA IPID /14 , 13 , 8 , 7 , 9 , 5 , 6 , 45 , 46 , 49 , 47 , 1/
398     C
399     IF(.NOT.INIT) RETURN
400     INIT = .FALSE.
401     *KEEP,VERSQQ.
402     VERSQQ = ' 1.05/04'
403     IVERSQ = 10504
404     *KEND.
405     CALL GCDATE(IDAT,ITIM)
406     IYEAR = IDAT/10000
407     IMONTH= (IDAT-IYEAR*10000)/100
408     IDAY = IDAT-(IDAT/100)*100
409     WRITE(DATE,'(I2,''.'',I2,''.'',I4)') IDAY,IMONTH,IYEAR
410     PRINT*,'******************************************************'
411     PRINT*,'* *'
412     PRINT*,'* GEANT - CALOR Interface Version ',VERSQQ,' *'
413     PRINT*,'* ----------------------------------------- *'
414     PRINT*,'* ',DATE,' C.Zeitnitz, T.A.Gabriel *'
415     PRINT*,'* *'
416     PRINT*,'* NMTC is used for hadronic interactions of *'
417     PRINT*,'* protons,neutrons and charged pions *'
418     PRINT*,'* up to 3.5 GeV (proton,neutron), 2.5 GeV(pion) *'
419     PRINT*,'* *'
420     PRINT*,'* A Scaling Model is used for the energy range *'
421     PRINT*,'* up to 10 GeV. *'
422     PRINT*,'* *'
423     PRINT*,'* MICAP is calculating the interaction of *'
424     PRINT*,'* Neutrons with an energy below 20 MeV *'
425     PRINT*,'* *'
426     PRINT*,'* For interactions of hadrons not implemented in *'
427     PRINT*,'* CALOR or with an energy above 10 GeV *'
428     PRINT*,'* GEANT-FLUKA is called *'
429     PRINT*,'* *'
430     PRINT*,'* The transport of electrons, positrons and gammas *'
431     PRINT*,'* is done by GEANT *'
432     PRINT*,'* *'
433     PRINT*,'* All output is written to file calor.out *'
434     PRINT*,'* *'
435     PRINT*,'******************************************************'
436     PRINT '('' * Neutron cutoff energy='',G10.2, '
437     + //' '' eV *'')',CUTNEU*1.E9
438     PRINT*,'******************************************************'
439     C
440     C fill particle mass array
441     DO 10 I=0,11
442     CALL GFPART(IPID(I),NAP,ITR,AM,CH,TL,UB,NW)
443     XMASS(I)=AM
444     10 CONTINUE
445     INIT = .FALSE.
446     ICPROC = -1
447     IN = 5
448     EHIN = 3495.0
449     EHIPI = 2495.0
450     EMAX = 3500.0
451     NBERTP = 30
452     INQUIRE(UNIT=NBERTP,OPENED=OPENED)
453     IF(OPENED) THEN
454     REWIND NBERTP
455     ELSE
456     BERTF = 'chetc.dat'
457     INQUIRE(FILE=BERTF,EXIST=EXISTS)
458     IF(.NOT.EXISTS) THEN
459     CHROOT = ' '
460     CALL GETENV('CERN_ROOT',CHROOT)
461     LNROOT = LNBLNK(CHROOT)
462     IF(LNROOT.GT.0)BERTF = CHROOT(1:LNROOT)//'/lib/chetc.dat'
463     ENDIF
464     INQUIRE(FILE=BERTF,EXIST=EXISTS)
465     IF(.NOT.EXISTS) THEN
466     PRINT*,'**********************************'
467     PRINT*,'* G C A L O R *'
468     PRINT*,'* ----------- *'
469     PRINT*,'* File CHETC.DAT not found *'
470     PRINT*,'* Program STOP *'
471     PRINT*,'**********************************'
472     STOP
473     ENDIF
474     OPEN(UNIT = NBERTP,FILE=BERTF, FORM = 'FORMATTED',STATUS=
475     + 'OLD')
476     ENDIF
477     C Output unit for Neutron information and error messages
478     IOUT = 32
479     IERRU = IOUT
480     OPEN(UNIT=IOUT,FILE='calor.out',FORM='FORMATTED',
481     + STATUS='UNKNOWN')
482     IO = IOUT
483     WRITE(IOUT,'(/, '
484     + //' 18X,''GEANT-CALOR INTERFACE V'',A8,'' Output File'', '
485     + //'/,18X,''==========================================='',/)')
486     + VERSQQ
487     C read bert cascade and evaporation dataset
488     CALL CRBERT
489     CLOSE(UNIT=NBERTP)
490     ELOP = AMAX1(1.0,CUTHAD * 1000.0)
491     ELON = AMAX1(20.0,CUTNEU * 1000.0)
492     NPOWR2 = 11
493     NGROUP = 2**NPOWR2
494     EMUCUT = AMAX1(1.0,CUTMUO * 1000.0)
495     EPICUT = ELOP
496     NPIDK = -1
497     CTOFE = 0.0
498     CTOFEN = 0.0
499     ANDIT = 0.0
500     NEXITE = 1
501     NBOGUS = NEXITE
502     ELAS = 0.0
503     BODGE = 0.0
504     EMIN(1) = ELOP
505     EMIN(2) = ELON
506     EMIN(3) = EPICUT
507     EMIN(4) = EPICUT
508     EMIN(5) = EPICUT
509     EMIN(6) = EMUCUT
510     EMIN(7) = EMUCUT
511     C now get some cross sections
512     CALL CREADG(GEOSIG)
513     CALL GTHSIG(1)
514     C No decay cross-section needed in GEANT
515     C SGPIMX = 0.001259/SQRT ((EMIN(3)/139.9+1.)**2 -1.)
516     C SGMUMX = 1.587E-5/SQRT ((EMIN(6)/107.+1.)**2 -1.)
517     SGPIMX = 0.0
518     SGMUMX = 0.0
519     NCOL = 1
520     C ------------ initialize MICAP ------------------------
521     CALL MORINI
522     C perform garbage collection in constant division
523     CALL MZGARB(IXCONS,0)
524     RETURN
525     END
526     *CMZ : 1.01/04 10/06/93 14.43.36 by Christian Zeitnitz
527     *-- Author :
528     SUBROUTINE CREADG(GEOSIG)
529     C
530     #include "cjoint.inc"
531     #include "cbert.inc"
532     C
533     DIMENSION GEOSIG(240)
534     C
535     K=1
536     DO 20 J = 1,4
537     CZ data already read by CRBERT called by CALINI 19.june 92 CZ
538     CZ changed 5-28-92 crazy number for A=240 set to GEOSIG(239)
539     DO 10 I = 4,594,10
540     IF(K.LT.240) THEN
541     GEOSIG(K) = SNGL(CRSC(I + (J-1)*600))
542     GEOSIG(K) = 3.1416 * GEOSIG(K)**2 * 1.E+24
543     ELSE
544     GEOSIG(K) = GEOSIG(K-1)
545     ENDIF
546     10 K = K + 1
547     20 CONTINUE
548     RETURN
549     END
550     *CMZ : 1.01/04 10/06/93 14.43.36 by Christian Zeitnitz
551     *-- Author : Christian Zeitnitz 06/06/92
552     FUNCTION ICALGE(IP)
553     C*******************************************
554     C
555     C INPUT : CALOR particle type
556     C OUTPUT: GEANT particle type
557     C
558     C******************************************
559     C
560     C
561     DIMENSION NCALGE(0:11)
562     C convert CALOR particle code to GEANT
563     C p n pi+ pi0 pi- mu+ mu- D T He3 Alpha Gamma
564     DATA NCALGE/ 14, 13, 8, 7, 9, 5, 6, 45, 46, 49, 47, 1/
565     C
566     IF(IP .LE. 11 .AND. IP.GE.0) THEN
567     ICALGE = NCALGE(IP)
568     ELSE
569     ICALGE = 0
570     ENDIF
571     RETURN
572     END
573     *CMZ : 1.01/04 10/06/93 14.43.36 by Christian Zeitnitz
574     *-- Author : Christian Zeitnitz 06/06/92
575     FUNCTION IGECAL(IP)
576     C*******************************************
577     C
578     C INPUT : GEANT particle type
579     C OUTPUT: CALOR particle type or -1
580     C
581     C******************************************
582     C
583     C
584     DIMENSION NGECAL(48)
585     C
586     C convert GEANT particle code to CALOR
587     C -1 indicates a particle not implemented in CALOR
588     DATA NGECAL/ -1, -1, -1, -1, -1, -1, -1, 2, 4, -1,
589     + -1, -1, 1, 0, -1, -1, -1, -1, -1, -1,
590     + 28*-1/
591     C
592     C
593     IF(IP .LE. 48 .AND. IP.GT.0) THEN
594     IGECAL = NGECAL(IP)
595     ELSE
596     IGECAL = -1
597     ENDIF
598     RETURN
599     END
600     *CMZ : 1.01/04 10/06/93 14.43.36 by Christian Zeitnitz
601     *-- Author : Christian Zeitnitz 19/06/92
602     SUBROUTINE CRBERT
603     C*********************************************************
604     C
605     C Read BERT Data into commons used by BERT,PCOL,GTHSIG
606     C DRES
607     C
608     C*********************************************************
609     C
610     #include "cjoint.inc"
611     #include "cbert.inc"
612     #include "cdresc.inc"
613     #include "cevcm.inc"
614     *KEND.
615     C
616     REWIND NBERTP
617     C ---- read cascade data --------------
618     I1 = 1
619     I2 = 600
620     DO 10 J=1,4
621     READ(NBERTP,10000) (CRSC(I),I=I1,I2)
622     I1 = I1 + 600
623     I2 = I2 + 600
624     10 CONTINUE
625     READ(NBERTP,10000) (TAPCRS(I),I=1,29849)
626     C ----- read evaporation data -----------
627     DO 30 K=1,250
628     DO 20 J=1,20
629     WAPS(K,J) = 0.0
630     20 CONTINUE
631     30 CONTINUE
632     READ(NBERTP,10000) (P0(J),P1(J),P22(J),J=1,1001)
633     READ(NBERTP,10100) (IA(J),J=1,6),(IZ(J),J=1,6)
634     READ(NBERTP,10000) (RHO(J),J=1,6),(OMEGA(J),J=1,6)
635     READ(NBERTP,10000) (EXMASS(J),J=1,6)
636     READ(NBERTP,10000) (CAM2(J),J=1,130)
637     READ(NBERTP,10000) (CAM3(J),J=1,200)
638     READ(NBERTP,10000) (CAM4(J),J=1,130)
639     READ(NBERTP,10000) (CAM5(J),J=1,200)
640     READ(NBERTP,10000) ((T(I,J),J=1,7),I=1,3)
641     READ(NBERTP,10000) (RMASS(J),J=1,297)
642     READ(NBERTP,10000) (ALPH(J),J=1,297)
643     READ(NBERTP,10000) (BET(J),J=1,297)
644     READ(NBERTP,10000) ((WAPS(I,J),I=1,250),J=1,20)
645     10000 FORMAT(5E16.8)
646     10100 FORMAT(6I10)
647     RETURN
648     END
649     *CMZ : 1.01/04 10/06/93 14.43.36 by Christian Zeitnitz
650     *-- Author : Christian Zeitnitz 30/10/92
651     LOGICAL FUNCTION SKALEF(IP,EIP,ESKALE)
652     C*************************************************************
653     C
654     C Called by: GCALOR
655     C Purpose : function is true, when scaling applies to FLUKA
656     C linear transition from NMTC to FLUKA
657     C Author : C.Zeitnitz
658     C
659     C*************************************************************
660     #include "crandm.inc"
661     *KEND.
662     C
663     SKALEF = .TRUE.
664     ENMTC = 3.495
665     IF(IP.GT.1) ENMTC = 2.495
666     IF(EIP.LE.ENMTC) SKALEF = .FALSE.
667     IF(EIP.LT.ESKALE.AND.EIP.GT.ENMTC) THEN
668     X1 = (EIP - ENMTC) / (ESKALE - ENMTC)
669     X2 = SNGL(RANDC(ISEED))
670     IF(X2.GT.X1) SKALEF = .FALSE.
671     ENDIF
672     RETURN
673     END
674     *CMZ : 1.02/02 28/01/94 09.09.15 by Christian Zeitnitz
675     *-- Author : Christian Zeitnitz 30/07/93
676     *
677     * simple utility to generate date and time of GCALOR version
678     * When running kumac file vers.kumac this file is written as fortran
679     * and then read again, in order to fix date and time
680     *
681     SUBROUTINE GCDATE(IDATQQ,ITIMQQ)
682     *KEEP,DATEQQ.
683     IDATQQ = 20051130
684     *KEEP,TIMEQQ.
685     ITIMQQ = 1129
686     *KEND.
687     RETURN
688     END
689     *CMZ : 0.92/00 02/12/92 16.02.28 by Christian Zeitnitz
690     *-- Author :
691     SUBROUTINE AZIRN(SIN,COS)
692     #include "crandm.inc"
693     *KEND.
694     C THIS ROUTINE SELECTS THE AZIMUTHAL ANGLE UNIFORMLY IN THETA
695     10 R1 = SFLRAF(DUM)
696     R1SQ = R1 * R1
697     R2 = RANDC(ISEED)
698     R2SQ = R2 * R2
699     RSQ = R1SQ + R2SQ
700     IF(1.0-RSQ) 10 ,20 ,20
701     20 SIN = 2.0 * R1 * R2 / RSQ
702     COS = (R2SQ-R1SQ) / RSQ
703     RETURN
704     END
705     *CMZ : 0.94/00 08/03/93 12.50.48 by Christian Zeitnitz
706     *-- Author :
707     SUBROUTINE DKLOS
708     C
709     #include "ccomon.inc"
710     #include "cmagnt.inc"
711     #include "ctuctw.inc"
712     #include "celstc.inc"
713     *KEND.
714     C
715     MT = MAT
716     GOTO(10,10,20,30,20,40,40),ITYP
717     10 DKWT =1.
718     C*************ADD MAGNET BODGE TO DELSIG********************
719     DELSIG=SIGMX(ITYP,MT)+TOTELS+BODGE
720     C DELSIG = SIGMX(ITYP,MT ) + TOTELS
721     RETURN
722     20 SIGDK= 0.001259/SQRT ((EC(NO)/139.9+1.)**2. -1.)
723     GO TO 50
724     30 CALL CERROR('DKLOS$')
725     40 SIGDK= 1.587E-5/SQRT ((EC(NO)/107.+1.)**2. -1.)
726     C 50 DELSIG = SIGMX(ITYP,MT ) - SIGDK
727     C********ADD MAGNET BODGE TO DELSIG AND ALLOW FOR IT IN DKWT*******
728     50 DELSIG = SIGMX(ITYP,MT ) - SIGDK+BODGE
729     C DKWT = DELSIG/SIGMX(ITYP,MT )
730     DKWT = DELSIG/(SIGMX(ITYP,MT )+BODGE)
731     RETURN
732     END
733     *CMZ : 0.92/00 02/12/92 16.02.28 by Christian Zeitnitz
734     *-- Author :
735     SUBROUTINE CESWH
736     C** ELASTIC SCATTERING WITH HYDROGEN,
737     C* STRUCK PARTICLE AT REST.
738     #include "cbert.inc"
739     *KEND.
740     SAVE
741     C
742     CALL CAAZIO(SOPC,SOPS)
743     PM(4) = DNCMS
744     PT(1) = 0.
745     DO 10 I=3,13
746     10 PT(I) = 0.
747     DO 20 I=15,48
748     20 PT(I) = 0.
749     DO 30 I=1,24
750     30 COL(I) = 0.
751     A=PM(4)*PM(4)
752     COL(1)=E(1)+E(2)
753     C TOTAL ENERGY PARTICLES 1 AND 2
754     DO40 I=1,3
755     40 COL(I+1)=PM(I)*PM(I)
756     C MASS PARTICLE I SQD.
757     COL(5)=COL(3)+COL(2)+2.0*(E(1)*E(2)-(PXYZ(1)*PXYZ(2)+PXYZ(5)*
758     1PXYZ(6)+PXYZ(9)*PXYZ(10)))
759     COL(6)=DSQRT(COL(5))
760     COL(7)=COL(6)/COL(1)
761     C GAM
762     COL(8)=2.0*COL(6)
763     COL(9)=(COL(4)+COL(5)-A)/COL(8)
764     COM2 = COL(9)*COL(9)
765     50 COL(10)=DSQRT(COM2-COL(4))
766     C P3 PRIME
767     COL(18)=PXYZ(9)*PM(2)/COL(6)
768     C P(1),Z *M2/M=P(BAR PRIME)1,Z
769     COL(21)=PXYZ(9)/COL(1)
770     C VZ VELOCITY
771     PXYZ(3)=COL(10)*SNT*SOPC
772     C X COMPONENT P3 BAR =P3 PRIME X SIN THETA X COS PHI
773     PXYZ(7)=COL(10)*SNT*SOPS
774     C Y COMP. P3 BAR =P3 PRIME X SIN THETA X SIN PHI
775     PXYZ(11)=COL(10)*CST
776     Z=PXYZ(9)/COL(6)
777     PXYZ(11)=PXYZ(11)+(Z*PXYZ(9)*PXYZ(11))/(COL(1)+COL(6))+Z*COL(9)
778     C Z COMP. P3 BAR=P3 PRIME COS THETA+(P1Z SQ*P3Z (PRIME)COS
779     C THETA/(E PRIME*(E+E PRIME))+P1Z*E3 PRIME/E PRIME
780     E(3)=DSQRT(PXYZ(3)*PXYZ(3)+PXYZ(7)*PXYZ(7)+PXYZ(11)*PXYZ(11)+
781     1PM(3)*PM(3))
782     DO60 I=1,9,4
783     60 PXYZ(I+3)=PXYZ(I)-PXYZ(I+2)
784     E(4)=DSQRT(PXYZ(4)*PXYZ(4)+PXYZ(8)*PXYZ(8)+PXYZ(12)*PXYZ(12)
785     1+PM(4)*PM(4))
786     C** KINETIC ENERGY OF 3 AND 4
787     PT(3) = (E(3) - PM(3))/RCPMV
788     PT(15) = (E(4) - PM(4))/RCPMV
789     C** MOMENTUM OF 3 AND 4, IN LAB.
790     P3 = DSQRT(PXYZ(3)*PXYZ(3) + PXYZ(7)*PXYZ(7) + PXYZ(11)*PXYZ(11))
791     P4 = DSQRT(PXYZ(4)*PXYZ(4) + PXYZ(8)*PXYZ(8) + PXYZ(12) *PXYZ(12))
792     C** DIRECT COSINES OF 3 AND 4
793     PT(8) = PXYZ(3)/P3
794     PT(9) = PXYZ(7)/P3
795     PT(10) = PXYZ(11)/P3
796     PT(20) = PXYZ(4)/P4
797     PT(21) = PXYZ(8)/P4
798     PT(22) = PXYZ(12) /P4
799     RETURN
800     END
801     *CMZ : 1.01/17 22/11/93 12.22.58 by Christian Zeitnitz
802     *-- Author :
803     FUNCTION EXPRNF(A)
804     C
805     #include "crandm.inc"
806     *KEND.
807     C
808     REAL I
809     C
810     I = 0.0
811     10 X = RANDC(ISEED)
812     Z = X
813     20 Y = RANDC(ISEED)
814     IF(Z-Y) 50 ,50 ,30
815     30 Z = RANDC(ISEED)
816     IF(Z-Y) 20 ,40 ,40
817     40 I = I + 1.0
818     GO TO 10
819     50 EXPRNF = X + I
820     RETURN
821     END
822     *CMZ : 0.92/00 02/12/92 16.02.28 by Christian Zeitnitz
823     *-- Author :
824     FUNCTION GAURN(X)
825     C
826     #include "crandm.inc"
827     *KEND.
828     C
829     10 Y = EXPRNF(X1)
830     Z = EXPRNF(X2)
831     TEST = (Y-1.0)**2/2.
832     IF(TEST-Z) 20,20,10
833     20 R1 = 2.0 * RANDC(ISEED) - 1.0
834     IF(R1) 30,40,40
835     30 Y = -Y
836     40 GAURN = Y
837     RETURN
838     END
839     *CMZ : 1.01/04 10/06/93 14.43.41 by Christian Zeitnitz
840     *-- Author :
841     SUBROUTINE GTHSIG(ISGNL)
842     C
843     #include "cjoint.inc"
844     #include "ccomon.inc"
845     #include "cxpd.inc"
846     #include "chie.inc"
847     #include "cbert2.inc"
848     *KEND.
849     C
850     C
851     C ** DE IS THE CONST. ENERGY SPACING COMMON T0 P-P,N-P,PI+P,PI-P XSECTS
852     DIMENSION ISA(4),EMX(4)
853     SAVE ISA,EMX
854     C
855     GO TO (10,180),ISGNL
856     10 CONTINUE
857     CZ BERT dataset already read by CRBERT called by CALINI 19.june 92
858     CALL CSHXD
859     DO 20 I=1,4
860     20 ISA(I) = LOCX(3,I)
861     C**** COMPUTE TOTAL P-P AND N-P XSECTS (SINGLE PRODUCTION + DOUBLE PRODU
862     C**** + ELASTIC) AND STORE P-P BEGINNING AT CS(3794) ANP N-P BEGINNING
863     C**** CS(3970).
864     ISP=995
865     IDP=1153
866     DO 50 IT=1,2
867     IS= ISA(IT)
868     DO 30 I=1,158
869     TEMP= CS(IS+18+I)
870     30 CS(IS+18+I) = TEMP + CS(ISP+I)
871     ISP = ISP + 288
872     DO 40 I=1,130
873     TEMP = CS(IS+46+I)
874     40 CS(IS+46+I) = TEMP + CS(IDP+I)
875     50 IDP = IDP + 288
876     C**** COMPUTE TOTAL PI+(SNGL PROD.+ELAS) AND PI-(SNGL PROD.+EXCHNG +ELAS
877     C**** AND STORE PI+-P BEGINNING AT CS(3668) AND PI--P BEGINNING AT CS(35
878     ISP =2009
879     DO 70 IT =3,4
880     IS= ISA(IT)
881     DO 60 I=1,117
882     TEMP = CS(IS +9+I)
883     60 CS(IS+9+I) = TEMP + CS(ISP+I)
884     70 ISP = ISP +234
885     IEX =3415
886     IS = ISA(4)
887     DO 80 I=1,126
888     TEMP = CS(IS+I)
889     80 CS(IS+I) = TEMP + CS(IEX+I)
890     DO 100 IT = 1,2
891     IS = ISA(IT)
892     DO 90 I=1,176
893     90 NPSG(IT,I) = SNGL( CS(IS+I) )
894     100 CONTINUE
895     DO 120 IT = 1,2
896     IS = ISA(IT+2)
897     DO 110 I=1,126
898     110 PIPSG(IT,I) = SNGL( CS(IS+I) )
899     120 CONTINUE
900     C *****
901     C **** SELECT MAX. TOT.XSECTS FOR X ON PROT. IN ENERGY RANGE EMIN(X) TO
902     C **** WHERE X = PROT.,NEUT.,PI+,PI-.
903     IF(EMAX.LT.EHIN)GO TO 130
904     EMX(1)=EHIN
905     EMX(2)=EHIN
906     EMX(3)=EHIPI
907     EMX(4)=EHIPI
908     GO TO 140
909     130 CONTINUE
910     EMX(1)= EMAX
911     EMX(2)= EMAX
912     EMX(3)= 2500.
913     EMX(4)= 2500.
914     140 CONTINUE
915     DO 160 ITP =1,4
916     IS= ISA(ITP)
917     IT = ITP + ITP/4
918     CALL CALSGM(1,ITP,IS,DE,EMIN(IT),IL,EL,SL)
919     CALL CALSGM(1,ITP,IS,DE,EMX(ITP),IH,EH,SH)
920     HSIGMX(IT) = AMAX1(SL,SH)
921     IF(IL.GE.IH) GO TO 160
922     IL = IL +1
923     DO 150 I= IL,IH
924     SIG = SNGL(CS(I+IS))
925     IF(SIG. LE. HSIGMX(IT)) GO TO 150
926     HSIGMX(IT) = SIG
927     150 CONTINUE
928     160 CONTINUE
929     HSIGMX(4)=0.0
930     10000 FORMAT(1H0,7HHSIGMX ,5E15.5)
931     170 RETURN
932     180 IT = ITYP - ITYP/5
933     IS = ISA(IT)
934     CALL CALSGM(2,IT,IS,DE,EC(NO),I,EI,HSIG)
935     GO TO 170
936     END
937     *CMZ : 1.01/04 10/06/93 14.43.41 by Christian Zeitnitz
938     *-- Author :
939     SUBROUTINE CISOB
940     IMPLICIT REAL *8 (A-H,O-Z)
941     C
942     #include "crandm.inc"
943     #include "cbert3.inc"
944     #include "cisob2.inc"
945     *KEND.
946     C
947     INTEGER*2 RANDI
948     REAL*8 DCLN(80),DCIN(115),PPAC(19),POAC(19),
949     + FMXSN(161),FMXDN(130),FMXSP(117),PDCI(60),PDCH(55),DCHN(143),
950     + DCHNA(36),DCHNB(60),PSPCL(158),PDPCL(130),SPCLN(158),DPCLN(130),
951     + FSLN(176),FRINN(161),DMIN(101),PPSCL(117),PNSCL(117),PMSCL(117),
952     + PNNSL(117),PCFSL(234),FRIPN(117),PNMI(101),PNFSL(234),PNEC(126),
953     + PNNEC(126),PMXC(126),PMEC(126),PPEC(126),PEC(176),ECN(176),
954     + PPDC(6426),PMDD(6426),PMDX(6426),PNDD(6426)
955     REAL*8 CALCIN(3)
956     EQUIVALENCE (TAPCRS(1),DCLN(1)) ,(TAPCRS(81),DCIN(1)) ,
957     + (TAPCRS(196),PPAC(1)) ,(TAPCRS(215),POAC(1)) ,
958     + (TAPCRS(234),FMXSN(1)) ,(TAPCRS(395),FMXDN(1)) ,
959     + (TAPCRS(525),FMXSP(1)) ,(TAPCRS(642),PDCI(1)) ,
960     + (TAPCRS(702),PDCH(1)) ,(TAPCRS(757),DCHN(1)) ,
961     + (TAPCRS(900),DCHNA(1)) ,(TAPCRS(936),DCHNB(1)) ,
962     + (TAPCRS(996),PSPCL(1)) ,(TAPCRS(1154),PDPCL(1)),
963     + (TAPCRS(1284),SPCLN(1)),(TAPCRS(1442),DPCLN(1)),
964     + (TAPCRS(1572),FSLN(1)) ,(TAPCRS(1748),FRINN(1))
965     C
966     EQUIVALENCE (TAPCRS(1909),DMIN(1)) ,(TAPCRS(2010),PPSCL(1)),
967     + (TAPCRS(2127),PNSCL(1)),(TAPCRS(2244),PMSCL(1)),
968     + (TAPCRS(2361),PNNSL(1)),(TAPCRS(2478),PCFSL(1)),
969     + (TAPCRS(2712),FRIPN(1)),(TAPCRS(2829),PNMI(1)) ,
970     + (TAPCRS(2930),PNFSL(1)),(TAPCRS(3164),PNEC(1)) ,
971     + (TAPCRS(3290),PNNEC(1)),(TAPCRS(3416),PMXC(1)) ,
972     + (TAPCRS(3542),PMEC(1)) ,(TAPCRS(3668),PPEC(1)) ,
973     + (TAPCRS(3794),PEC(1)) ,(TAPCRS(3970),ECN(1)) ,
974     + (TAPCRS(4146),PPDC(1)) ,(TAPCRS(10572),PMDD(1)),
975     + (TAPCRS(16998),PMDX(1)),(TAPCRS(23424),PNDD(1))
976     C
977     SAVE
978     DATA NTER/0/
979     IF(NTER.NE.0) GO TO 10
980     NTER =1
981     JP = 0
982     IK = 0
983     CASESN = 1.D0
984     LN=2
985     PNMS=.708E13
986     SQNM=2.2638564E27
987     DNCMS=4.758E13
988     POMS=.684E13
989     RCPMV=.50613E11
990     10 CONTINUE
991     LOOP=0
992     INPT=0
993     DO20 I=1,48
994     20 PT(I)=0.0
995     NOF = 0
996     30 BEGRU=0.0
997     NOR=0
998     C NOR=NUMBER OF RECORD
999     NOF=NOF+1
1000     C EINC=INC.PART.EN.
1001     C CASESN=NO.OF INC.PART.
1002     C ANDIT=ANG.DIST.
1003     C PRTIN=INC.PART.
1004     C TRSYM=STRUCK PART.
1005     C RANDI=INPUT RAND NO.
1006     C IP=TYPE OF REACTION(-1=S.P.,0=D.P.,1=CHOICE)
1007     C IK=0,STRUCK PART.AT REST--OTHERWISE ASSUME ENERGY
1008     C JP=0, NO PRINT OUT
1009     KASE=0
1010     C SENTINEL FOR GETTING CROSS SECTIONS WHEN STRUCK PARTICLE HAS ENERGY
1011     DO40 I=1,3
1012     40 CALCIN(I)=0.0
1013     STRKP = -1.D0
1014     GOTO(50 ,50 ,60 ,70 ,60 ),NO
1015     50 PM(1)=DNCMS
1016     GOTO110
1017     60 PM(1)=PNMS
1018     GOTO80
1019     70 PM(1)=POMS
1020     80 IF(NO-4)90 ,100,100
1021     90 ISW(11)=1
1022     GOTO110
1023     100 ISW(11)=0
1024     110 PM(2)=DNCMS
1025     KA = 1
1026     E(1)=EINC*RCPMV+PM(1)
1027     PXYZ(1)=0.0
1028     PXYZ(5)=0.0
1029     PXYZ(9) = DSQRT (E(1)*E(1) - PM(1)*PM(1) )
1030     RLKE=EINC
1031     IF(IK)140,120,140
1032     120 P2=0.0
1033     PXYZ(2)=0.0
1034     PXYZ(6)=0.0
1035     PXYZ(10)=0.0
1036     E(2)=DNCMS
1037     GOTO140
1038     130 CONTINUE
1039     140 IF(NO-3)150,160,160
1040     150 IF(RLKE-3500.0)230,230,190
1041     160 IF(RLKE-180.0)190,190,170
1042     170 IF(RLKE-2500.0)180,180,190
1043     180 IF(KASE)970 ,230,970
1044     190 IF(IK)200,210,200
1045     200 IF(KASE)220,210,220
1046     210 NE=3
1047     C RLKE IN CERROR('CISOB1')
1048     GOTO1050
1049     220 LOOP=LOOP+1
1050     IF(LOOP-1000)130,130,210
1051     230 IF(IP)240,460,460
1052     240 IF(NO-3)460,370,370
1053     250 LK=2
1054     I3=1
1055     260 CALL QRDET(1,PSPCL(1),CALCIN(1))
1056     C ARGUMENT=PSPCL, P-P, N-N, S.P.
1057     CALCIN(1)=CRDT(1)
1058     IF(LK-6)270,320,320
1059     270 CALL QRDET(1, PEC(1), RLKE)
1060     C ELASTIC CROSS SECTION
1061     280 CALCIN(3)=CRDT(1)+CALCIN(1)+CALCIN(2)
1062     C TOTAL
1063     C P-P, N-N, ELASTIC
1064     GO TO 630
1065     290 LK=3
1066     I3=2
1067     300 CALL QRDET(1, SPCLN(1),CALCIN(1))
1068     C ARGUMENT=NSPCL, N-P, P-N, S.P.
1069     CALCIN(1)=CRDT(1)
1070     IF(LK-6)310,320,320
1071     310 CALL QRDET(1, ECN(1), RLKE)
1072     GO TO 280
1073     C P-N, N-P, ELASTIC
1074     320 CRATIO=CALCIN(1)/(CALCIN(1)+CALCIN(2))
1075     VALUE1 = RANDC(ISEED)
1076     IF(VALUE1-CRATIO)330 ,330 ,350
1077     330 IF(KA-NO)360 ,340 ,360
1078     340 I3=1
1079     GOTO270
1080     350 IF(KA-NO)310,270,310
1081     360 I3=2
1082     GOTO310
1083     370 ISW(10)=0
1084     ISW(9)=0
1085     C 9 SET FOR PI0,10 SET FOR PI+-N,PI--P,PI0-P, AND PI0-N
1086     CALCIN(1)=RLKE-180.0
1087     LK=1
1088     C PION
1089     I3=0
1090     IF(NO-4)380,420,450
1091     380 GOTO(390,400),KA
1092     390 CALL QRDET(1, PPSCL(1),CALCIN(1))
1093     CALCIN(1)=CRDT(1)
1094     CALL QRDET(1, PPEC(1),RLKE)
1095     GOTO280
1096     C PI(PLUS)-P, S.P. OR PI(MINUS)-N
1097     400 CALL QRDET(1, PMSCL(1),CALCIN(1))
1098     CALCIN(1)=CRDT(1)
1099     CALL QRDET(1, PMEC(1) , RLKE)
1100     410 CALCIN(3)=CRDT(1)
1101     ISW(10)=2
1102     CALL QRDET(1, PMXC(1) , RLKE)
1103     CALCIN(3)=CALCIN(3)+CRDT(1)+CALCIN(1)+CALCIN(2)
1104     C PI(PLUS)-N, S.P) OR PI(MINUS)-P
1105     GOTO630
1106     420 ISW(9)=2
1107     GOTO(430,440),KA
1108     430 CALL QRDET(1, PNSCL(1),CALCIN(1))
1109     CALCIN(1)=CRDT(1)
1110     CALL QRDET(1, PNEC(1) ,RLKE)
1111     GOTO410
1112     C PI(0)-P, S.P.
1113     440 CALL QRDET(1,PNNSL(1) ,CALCIN(1))
1114     CALCIN(1)=CRDT(1)
1115     CALL QRDET(1,PNNEC(1) ,RLKE )
1116     GOTO410
1117     C PI(0)-N, S.P.
1118     450 GOTO(400,390),KA
1119     C PI(-)-P, PI(-)-N, S.P.
1120     460 IF(RLKE-920.0)470,470,530
1121     470 IF(IP)480,190,480
1122     480 IF(RLKE-360.0)190,190,490
1123     490 IF(KASE)970 ,500,970
1124     500 CALCIN(1)=RLKE-360.0
1125     GOTO(510,520 ),NO
1126     510 ISW(4)=1
1127     GOTO(570,600),KA
1128     520 ISW(4)=0
1129     GOTO(600,570),KA
1130     530 IF(KASE)970 ,540,970
1131     540 CALCIN(2)=RLKE-920.0
1132     CALCIN(1)=RLKE-360.0
1133     GOTO(550,620),NO
1134     550 ISW(4)=1
1135     GOTO(560,590),KA
1136     560 CALL QRDET(1,PDPCL(1) ,CALCIN(2))
1137     C ARGUMENT=PDPCL, P-P, N-N, D.P.
1138     CALCIN(2)=CRDT(1)
1139     C N-N, OR P-P, D.P.
1140     570 IF(IP)250,580,580
1141     580 LK=4+2*(IP)
1142     I3=3
1143     GOTO260
1144     590 CALL QRDET(1,DPCLN(1) ,CALCIN(2))
1145     C ARGUMENT=NDPCL, N-P, P-N, D.P.
1146     CALCIN(2)=CRDT(1)
1147     600 IF(IP)290,610,610
1148     610 LK=5+IP
1149     I3=4
1150     GOTO300
1151     C N-P, OR P-N, D.P.
1152     620 ISW(4)=0
1153     GOTO(590,560),KA
1154     630 IF(JP)1050,650,640
1155     C JP=0, NO PRINT OUT
1156     640 WRITE(6,10000)EINC,NO,KA,CASESN,(RANDS(I),I=2,4),(CALCIN(I),I=1,
1157     +3) , IP,NOF,IK
1158     10000 FORMAT(1H1,' EINC NO KA CASESN RANDI CAL
1159     +CIN IP NOF IK'/1H0,D11.3,2I8,D11.3,1X,3Z4,
1160     + 3D11.3,3I8)
1161     650 CONTINUE
1162     KASE=1
1163     IF(IK)130,660,130
1164     660 GOTO(990 ,990 ,680 ,680 ,680 ),NO
1165     670 I3=0
1166     680 CALL QOUT17(FRIPN(1),PNMI(1),FMXSP(1),PCFSL(1),PNFSL(1))
1167     IF(I3)1090,730 ,690
1168     690 IF(COL(15)-1.0)730 ,790 ,700
1169     700 IF(COL(15)-3.0)770 ,760 ,710
1170     710 IF(COL(15)-5.0)780 ,1020,720
1171     720 NE=11
1172     GOTO1050
1173     730 CALL QOLLM
1174     IF(PT(38))750 ,740 ,750
1175     740 I3=1
1176     GOTO800
1177     750 I3=2
1178     GOTO800
1179     760 I3=4
1180     GOTO800
1181     770 I3=5
1182     GOTO800
1183     780 I3=6
1184     GOTO800
1185     790 I3=3
1186     800 CALL QOUT18
1187     I3=I3
1188     GOTO(690 ,810 ,690 ,820 ),I3
1189     810 NE=12
1190     GOTO1050
1191     820 PM(4)=DNCMS
1192     K=IP
1193     J=2
1194     IF(IP)830 ,860 ,840
1195     830 NWRIT=22
1196     MM=26
1197     GO TO 870
1198     840 IF(PT(38))850 ,830 ,850
1199     850 K=K+1
1200     860 NWRIT=29
1201     MM=38
1202     870 OUT(1)=K
1203     DO900 I=2,MM,12
1204     M=I
1205     K=M+3
1206     DO890 N=1,2
1207     DO880 L=M,K
1208     OUT(J)=PT(L)
1209     880 J=J+1
1210     M=I+6
1211     890 K=M+2
1212     900 CONTINUE
1213     NOR=NOR+1
1214     910 IF(JP)1050,930,920
1215     C JP=0, NO PRINT OUT
1216     920 WRITE(6,10100)NOR,(OUT(I),I=1,NWRIT),E(2),(PXYZ(I),I=2,10,4)
1217     10100 FORMAT(1H ,I7/(7D14.5))
1218     930 NWDS=NWRIT+4
1219     C NO.OF WORDS IN RECORD
1220     940 DO950 I=1,48
1221     950 PT(I)=0.0
1222     PGCNT=0.0
1223     PACNT=0.0
1224     LOOP=0
1225     BEGRU=BEGRU+1.0
1226     IF(CASESN-BEGRU)1050,1080,960
1227     960 IF(IK)130,970 ,130
1228     970 GOTO(670 ,980 ,1000,1010,1040,1100),LK
1229     980 I3=1
1230     990 CALL QOUT21(FRINN(1),DMIN(1),FMXSN(1),FMXDN(1),FSLN(1))
1231     GOTO680
1232     1000 I3=2
1233     GOTO990
1234     1010 I3=3
1235     GOTO990
1236     1020 CALL QOUT19
1237     IF(I3)1030,820 ,820
1238     1030 NE=13
1239     GOTO1050
1240     1040 I3=4
1241     GOTO990
1242     1050 CALL CERROR('CISOB$')
1243     IF(NE-3)1080,1060,1060
1244     1060 IF(CALCIN(1))1070,1080,1070
1245     1070 CONTINUE
1246     NOR=NOR+1
1247     1080 CONTINUE
1248     RETURN
1249     1090 NE=10
1250     GOTO1050
1251     1100 VALUE1 = RANDC(ISEED)
1252     IF(VALUE1-CRATIO)1110,1110,1120
1253     1110 IF(KA-NO)1000,980 ,1000
1254     1120 IF(KA-NO)1130,1010,1130
1255     1130 GO TO 1040
1256     END
1257     *CMZ : 1.01/04 10/06/93 14.43.41 by Christian Zeitnitz
1258     *-- Author :
1259     SUBROUTINE CPCOL(IB,ITYP,HSIG,EC,NOPART,KIND,EP,ALF,BET,GAM)
1260     C
1261     #include "cinpu.inc"
1262     #include "cjoint.inc"
1263     #include "cisobr.inc"
1264     #include "cxpd.inc"
1265     #include "crun.inc"
1266     #include "cinout.inc"
1267     #include "crandm.inc"
1268     #include "cbert.inc"
1269     *KEND.
1270     REAL*8 DCLN(80),DCIN(115),PPAC(19),POAC(19),
1271     + FMXSN(161),FMXDN(130),FMXSP(117),PDCI(60),PDCH(55),DCHN(143),
1272     + DCHNA(36),DCHNB(60),PSPCL(158),PDPCL(130),SPCLN(158),DPCLN(130),
1273     + FSLN(176),FRINN(161),DMIN(101),PPSCL(117),PNSCL(117),PMSCL(117),
1274     + PNNSL(117),PCFSL(234),FRIPN(117),PNMI(101),PNFSL(234),PNEC(126),
1275     + PNNEC(126),PMXC(126),PMEC(126),PPEC(126),PEC(176),ECN(176),
1276     + PPDC(6426),PMDD(6426),PMDX(6426),PNDD(6426)
1277     EQUIVALENCE (TAPCRS(1),DCLN(1)) ,(TAPCRS(81),DCIN(1)) , (TAPCRS(1
1278     +96),PPAC(1)) ,(TAPCRS(215),POAC(1)) , (TAPCRS(234),FMXSN(1)) ,
1279     +(TAPCRS(395),FMXDN(1)) , (TAPCRS(525),FMXSP(1)) ,(TAPCRS(642),
1280     +PDCI(1)) , (TAPCRS(702),PDCH(1)) ,(TAPCRS(757),DCHN(1)) , (TAPCRS
1281     +(900),DCHNA(1)) ,(TAPCRS(936),DCHNB(1)) , (TAPCRS(996),PSPCL(1))
1282     +,(TAPCRS(1154),PDPCL(1)), (TAPCRS(1284),SPCLN(1)),(TAPCRS(1442),
1283     +DPCLN(1)), (TAPCRS(1572),FSLN(1)) ,(TAPCRS(1748),FRINN(1))
1284     EQUIVALENCE (TAPCRS(1909),DMIN(1)) ,(TAPCRS(2010),PPSCL(1)),
1285     + (TAPCRS(2127),PNSCL(1)),(TAPCRS(2244),PMSCL(1)),
1286     + (TAPCRS(2361),PNNSL(1)),(TAPCRS(2478),PCFSL(1)),
1287     + (TAPCRS(2712),FRIPN(1)),(TAPCRS(2829),PNMI(1)) ,
1288     + (TAPCRS(2930),PNFSL(1)),(TAPCRS(3164),PNEC(1)) ,
1289     + (TAPCRS(3290),PNNEC(1)),(TAPCRS(3416),PMXC(1)) ,
1290     + (TAPCRS(3542),PMEC(1)) ,(TAPCRS(3668),PPEC(1)) ,
1291     + (TAPCRS(3794),PEC(1)) ,(TAPCRS(3970),ECN(1)) ,
1292     + (TAPCRS(4146),PPDC(1)) ,(TAPCRS(10572),PMDD(1)),
1293     + (TAPCRS(16998),PMDX(1)),(TAPCRS(23424),PNDD(1))
1294     C
1295     DIMENSION KIND(60),EP(60),ALF(60),BET(60),GAM(60)
1296     DIMENSION ICC(12)
1297     SAVE
1298     C
1299     KE =1
1300     IF(IB)30,10,30
1301     10 IB =1
1302     AND1T = DBLE(ANDT)
1303     CZ BERT dataset already read by CRBERT called by CALINI 19.june 92
1304     SF = 1.D0
1305     RANDI(1) = 16896
1306     PNMS = .708D13
1307     C PI+ OR - MASS IN PER CM.
1308     DNCMS = 4.758D13
1309     C NUCLEON MASS IN PER CM.
1310     SQNM=DNCMS*DNCMS
1311     C NUCLEON MASS SQD.
1312     RCPMV = .50613D11
1313     C RECIPROCAL CM PER MEV.
1314     POMS = .684D13
1315     C PIO MASS IN RECIP. CM
1316     DO 20 I = 1,19
1317     POAC(I) = POAC(I) + POAC(I)
1318     20 PPAC(I) = PPAC(I)/SF
1319     C POAC(19),PPAC(19)
1320     30 DO 40 I =1,60
1321     40 IPEC(I) =0
1322     DO 50 I =1,2114
1323     50 ESPS(I) = 0.D0
1324     DO 60 I = 4515,4849
1325     60 ESPS(I) = 0.D0
1326     DO 70 I=1,12
1327     70 ICC(I)= 0
1328     DO 80 I = 1,4
1329     80 RANDS(I) = RANDI(I)
1330     PM(1) = DNCMS
1331     GO TO(110,110,100,90,100,90,90),ITYP
1332     C P N PI+ PI0 PI- MU+ MU-
1333     90 CALL CERROR('CPCOL1$')
1334     WRITE(IO,10000) ITYP
1335     10000 FORMAT(' Wrong particle type = ',I2,' in CPCOL')
1336     100 PM(1) = PNMS
1337     110 INC =1
1338     CLSM = 1.D0
1339     PM(2) = DNCMS
1340     E(2) = DNCMS
1341     E(1) = DBLE(EC)*RCPMV + PM(1)
1342     PXYZ(2) = 0.
1343     PXYZ(6) = 0.
1344     PXYZ(10) = 0.
1345     CALL P1CLI
1346     C CALC'S X,Y,Z MOM COORD'S OF INC. PART.(PXYZ(1-5-9))AND P1OE1 = PZ1
1347     RLKE =(((E(1)*E(2)-PXYZ(1)*PXYZ(2)-PXYZ(5)*PXYZ(6)-PXYZ(9)*PXYZ(10
1348     + )) /DNCMS)-PM(1))/RCPMV
1349     VALUE1 = RANDC(ISEED)
1350     R = SNGL(VALUE1)
1351     VALUE1 = RLKE
1352     ITP = ITYP - ITYP/5
1353     NOPART = 2
1354     GO TO (170,170,200,120),ITP
1355     120 CONTINUE
1356     C TRY (PI-,P) EXCHANGE.
1357     R = R - XSECHE(4,ITP,EC)/HSIG
1358     IF( R.GT.0.) GO TO 200
1359     C A (PI-,P) EXCHANGE EVENT HAS OCCURRED
1360     IT = 5
1361     KIND(1) = 3
1362     C PI 0
1363     KIND(2) = 1
1364     C NEUTRON
1365     PT(2) = 4.D0
1366     PT(14) = 2.D0
1367     IK = IT
1368     PM(3) = POMS
1369     IF(RLKE - 340.D0) 130,130,140
1370     130 CALL CALMUD(SNT,INPT)
1371     CALL CRDET(51,PMDX,RLKE)
1372     C DIF PI--P EXCHG
1373     GO TO 370
1374     140 I3 = 1
1375     IF(RLKE-1000.D0) 150,160,160
1376     150 I3 = 2
1377     VALUE1 = RLKE - 340.D0
1378     160 CALL ROUT16(PMDX)
1379     C DIF PI--P EXCHG 2500-1000, 1000-340, 340- 0
1380     GO TO 440
1381     170 CONTINUE
1382     C TRY NUCLEON - P DBLE PRODUCTION.
1383     IF(EC.LT.ETH(2,ITP)) GO TO 200
1384     R = R - XSECHE(2,ITP,EC)/HSIG
1385     IF( R.GT.0. ) GO TO 200
1386     C DBLE PRODUCTION HAS OCCURRED.
1387     NOPART =4
1388     IPPP = 0
1389     180 NNO = ITYP
1390     E1NC = DBLE(EC)
1391     CALL CISOB
1392     KNO = 2
1393     DO 190 NOO = 1,NOPART
1394     KIND(NOO) = IDINT( DOUT(KNO)) - 1
1395     EP(NOO) = SNGL ( DOUT(KNO+1))
1396     ALF(NOO) = SNGL ( DOUT(KNO+4))
1397     BET(NOO) = SNGL ( DOUT(KNO+5))
1398     GAM(NOO) = SNGL ( DOUT(KNO+6))
1399     190 KNO = KNO + 7
1400     GO TO 310
1401     200 CONTINUE
1402     C TRY SNGL PRODUCTION.
1403     IF(EC .LT. ETH(1,ITP)) GO TO 210
1404     R = R - XSECHE(1,ITP,EC)/HSIG
1405     IF( R.GT.0.) GO TO 210
1406     C NUCLEON - P ,PI+ -P, OR PI- -P SNGL PRODUCTION HAS OCCURRED.
1407     NOPART =3
1408     IPPP = -1
1409     GO TO 180
1410     210 CONTINUE
1411     C AN ELASTIC EVENT HAS OCCURRED.
1412     GO TO (230,240,340,220,390,220,220),ITYP
1413     220 CALL CERROR('CPCOL2$')
1414     WRITE(IO,10100) ITYP
1415     10100 FORMAT(' Wrong particle type = ',I2,' in CPCOL ')
1416     230 I3 =7
1417     IT =18
1418     GO TO 250
1419     240 I3 = 4
1420     IT = 15
1421     250 CALL ROUT20(DCIN(1),DCLN(1),DCHN(1),PDCI(1),PDCH(1))
1422     C ELAS DIF XSECTS-NP 300-740,NP 0-300, NP 660-3500, PP 500-1000,PP 660-3
1423     C SETS PT(2)=1.-PROT,2.-NEUT,PT(14)=1.,PM(3)= DNCMS
1424     C CALC'S CST(SCAT COS) FOR EC GT (500 FOR PROT,740 FOR NEUTS)
1425     I3 = I3
1426     IGO = I3-4
1427     GO TO (330 ,260 ,270 ,280 ),IGO
1428     C I3 = 5 6 7 8
1429     260 SNT = DSQRT(1.D0 - CST*CST)
1430     GO TO 280
1431     270 CALL CAPOL1(CST,SNT)
1432     280 CALL CESWH
1433     290 IF(IT.EQ.5) GO TO 300
1434     KIND(1) = ITYP - 1
1435     KIND(2) = 0
1436     C PROTON
1437     300 CONTINUE
1438     EP(1)= SNGL( PT(3) )
1439     ALF(1)=SNGL( PT(8) )
1440     BET(1)=SNGL( PT(9) )
1441     GAM(1)=SNGL( PT(10))
1442     EP(2)= SNGL( PT(15))
1443     ALF(2)=SNGL( PT(20))
1444     BET(2)=SNGL( PT(21))
1445     GAM(2)=SNGL( PT(22))
1446     310 DO 320 I = 2,4
1447     320 RANDI(I) = RANDS(I)
1448     RETURN
1449     330 I3=4
1450     CALL ROUT15(PPDC(1))
1451     C CALC'S CST(SCAT COS) FOR EC LT 740 MEV
1452     GO TO 260
1453     340 I3 =1
1454     IT =1
1455     C PI+-P ELAS
1456     350 CALL ROUT11(PPDC (1))
1457     C TAPCRS(248) PI+-P LT 340 MEV.
1458     I3 = I3
1459     GO TO (380,360,360,370),I3
1460     360 CALL CERROR('CPCOL3$')
1461     WRITE(IO,10200) I3
1462     10200 FORMAT(' I3 = ',I3,' IN CPCOL')
1463     370 CST = CRDT(2)- DABS(SNT*(CRDT(2)-CRDT(1)))
1464     GO TO 260
1465     380 I3 =1
1466     CALL ROUT15(PPDC(1))
1467     C PI+-P DIF ELAS FOR1.-2.5 GEV AT 3401,FOR .34 -1. AT 3231.
1468     I3 = I3
1469     GO TO 260
1470     390 IT= 3
1471     C PI--P ELAS
1472     I3= 2
1473     PT(2) = 5.D0
1474     PT(14)= 1.D0
1475     IK= IT
1476     PM(3) = PNMS
1477     IF(RLKE - 340.D0) 400,400,410
1478     400 CALL CALMUD(SNT,INPT)
1479     CALL CRDET(51,PMDD(1),RLKE)
1480     GO TO 370
1481     410 I3 =1
1482     IF(RLKE - 1000.D0) 420,430,430
1483     420 I3 = 2
1484     VALUE1 = RLKE - 340.D0
1485     430 CALL ROUT16(PMDD(1))
1486     440 I3 = I3
1487     IF( I3) 260,450,460
1488     450 I3 = 3
1489     CALL ROUT15(PPDC(1))
1490     GO TO 260
1491     460 CONTINUE
1492     GO TO 360
1493     END
1494     *CMZ : 1.01/04 10/06/93 14.43.41 by Christian Zeitnitz
1495     *-- Author :
1496     SUBROUTINE CALQDK
1497     IMPLICIT REAL *8 (A-H,O-Z)
1498     #include "cbert3.inc"
1499     #include "cisob2.inc"
1500     *KEND.
1501     SAVE
1502     C
1503     UNIV=PNIDK(6)*PNIDK(6)
1504     C M(P1) SQUARED DECAY PION MASS SQUARED
1505     PNIDK(7)=(PNIDK(1)*PNIDK(1)+UNIV-SQNM)/(2.0*PNIDK(1))
1506     C E(PI)PRIME DECAY PION ENERGY PRIME
1507     PNIDK(8)=DSQRT(PNIDK(7)*PNIDK(7)-UNIV)
1508     C DECAY PION MOMENTUM PRIME P(D)
1509     CALL CAPOL1(PNIDK(20),PNIDK(21))
1510     C COS THETA, SIN THETA
1511     CALL CAAZIO(PNIDK(22),PNIDK(23))
1512     C COS PHI, SIN PHI
1513     PNIDK(9)=PNIDK(22)*PNIDK(21)*PNIDK(8)
1514     C DECAY PION X MOMENTUM COMPONENT PRIME
1515     PNIDK(10)=PNIDK(21)*PNIDK(23)*PNIDK(8)
1516     C P(P1)PRIME Y
1517     PNIDK(11)=PNIDK(20)*PNIDK(8)
1518     C P(P1)PRIME Z
1519     UNIV=PNIDK(9)*PNIDK(2)+PNIDK(10)*PNIDK(3)+PNIDK(11)*PNIDK(4)
1520     C P P1 PRIME DOT P
1521     PNIDK(12)=(PNIDK(7)*PNIDK(5)+UNIV)/PNIDK(1)
1522     C DECAY PION ENERGY E(PI)
1523     PNIDK(13)=PNIDK(5)-PNIDK(12)
1524     UNIV=(((PNIDK(5)/PNIDK(1))-1.0)*UNIV)/(PNIDK(2)*PNIDK(2)+
1525     +PNIDK(3)*PNIDK(3)+PNIDK(4)*PNIDK(4))
1526     C (E/M-1.0)*P(P1)PRIME DOT P/P SQUARED
1527     UNIVE=PNIDK(7)/PNIDK(1)
1528     C E PI PRIME OVER MASS
1529     DO10 I=2,4
1530     PNIDK(I+12)=PNIDK(I)*(UNIV+UNIVE) +PNIDK(I+7)
1531     10 PNIDK(I+15)=PNIDK(I)-PNIDK(I+12)
1532     RETURN
1533     C PION MOMENTUM COMPONENTS AND NUCLEON MOMENTUM
1534     C COMPONENTS
1535     END
1536     *CMZ : 0.92/00 02/12/92 16.02.29 by Christian Zeitnitz
1537     *-- Author :
1538     SUBROUTINE CQENE(Z)
1539     IMPLICIT REAL *8 (A-H,O-Z)
1540     #include "cbert3.inc"
1541     #include "cisob2.inc"
1542     *KEND.
1543     DIMENSION Z(380)
1544     SAVE
1545     C
1546     CD=COM*1.0D2
1547     I=IDINT(CD+1.00D0)
1548     AZ=Z(I)
1549     IF(I.EQ.1)GOTO150
1550     10 BZ=Z(I+1)
1551     IF(101-(I+1))70,20,30
1552     20 CZ=BZ+5.0D-1*(BZ-AZ)
1553     GOTO40
1554     30 CZ=Z(I+2)
1555     40 XZ=CD-DFLOAT(I-1)
1556     SCA=CZ-AZ
1557     C F(2)-F(0)
1558     50 SBA=BZ-AZ
1559     C F(1)-F(0)
1560     SQA=AZ*AZ
1561     C F(0)**2
1562     SQAC=SQA-CZ*CZ
1563     C F(0)**2-F(2)**2
1564     SQBA=BZ*BZ-SQA
1565     C F(1)**2-F(0)**2
1566     RB=SQAC+SQBA+SQBA
1567     C (ASQ-CSQ)+2(BSQ-ASQ)
1568     CZ
1569     CZ changed in order to keep exponent small 5/21/92
1570     RC=AZ*1.0D-20*CZ*SCA-SBA*1.0D-20*(2.0D0*AZ*BZ+XZ*(BZ-CZ)*SCA)
1571     CZ RC is 1E-20 smaller than it supposed to be !!!!
1572     RA=SCA-SBA-SBA
1573     C (C-A)-2(B-A)
1574     IF(RA.NE.0.0)GOTO60
1575     COM=AZ+XZ*SBA
1576     GOTO80
1577     60 CONTINUE
1578     CZ \/ factor 1E-20 in RC !!
1579     DISC=RB*1.0D-20*RB-4.0D0*RA*RC
1580     IF(DISC)70,90,90
1581     C B**2-4AC
1582     70 CALL CERROR('CQENE1$')
1583     80 RETURN
1584     CZ \/ correct for factor 1E-20
1585     90 DISC=DSQRT(DISC)*1.0D10
1586     CZ end of change
1587     CZ
1588     PLUS=(DISC-RB)/(RA+RA)
1589     AMINUS=(-RB-DISC)/(RA+RA)
1590     IF(I.EQ.1)GOTO160
1591     100 IF(PLUS.GT.BZ)GOTO120
1592     IF(PLUS.LT.AZ)GOTO120
1593     IF(AMINUS.GT.BZ)GOTO110
1594     IF(AMINUS.GE.AZ)GOTO140
1595     110 COM=PLUS
1596     GOTO80
1597     120 IF(AMINUS.GT.BZ)GOTO70
1598     IF(AMINUS.LT.AZ)GOTO70
1599     130 COM=AMINUS
1600     GOTO80
1601     140 RA=XZ*SBA+AZ
1602     RB=DABS(RA-AMINUS)
1603     RC=DABS(RA-PLUS)
1604     IF(RB.GT.RC)GOTO110
1605     GOTO130
1606     150 CZ=Z(I+1)
1607     SCA=CZ-AZ
1608     BZ=AZ+SCA*7.071067812D-1
1609     XZ=CD+CD
1610     GOTO50
1611     C (CZ-AZ)(CZ-AZ)=C,CZ=MASS FOR R=1,AZ=MASS FOR R=0, C=CONST.FOR PARABOLA
1612     C (M-AZ)(M-AZ)=0.5*C,DETERMINES MASS,BZ,FOR R=1/2
1613     160 BZ=CZ
1614     XZ=XZ-CD
1615     SBA=CZ-AZ
1616     GOTO100
1617     END
1618     *CMZ : 0.92/00 02/12/92 16.02.29 by Christian Zeitnitz
1619     *-- Author :
1620     SUBROUTINE CQLP19
1621     IMPLICIT REAL *8 (A-H,O-Z)
1622     C
1623     #include "crandm.inc"
1624     #include "cbert3.inc"
1625     #include "cisob2.inc"
1626     *KEND.
1627     SAVE
1628     C
1629     UNIV = RANDC(ISEED)
1630     PT(2)=1.0
1631     PT(26)=1.0
1632     PT(14)=3.0
1633     PT(16)=POMS
1634     IF(ISW(12))10,10,140
1635     10 IF(UNIV-.25)20,20,110
1636     20 IF(ISW(4))40,30,40
1637     30 PT(2)=2.0
1638     40 UNIV = RANDC(ISEED)
1639     IF(UNIV-.66666667)50,50,90
1640     50 PT(14)=4.0
1641     60 IF(ISW(4))80,70,80
1642     70 PT(26)=2.0
1643     80 RETURN
1644     90 PT(16)=PNMS
1645     IF(ISW(4))70,100,70
1646     100 PT(14)=5.0
1647     GOTO80
1648     110 IF(ISW(4))130,120,130
1649     120 PT(26)=2.0
1650     GOTO90
1651     130 PT(2)=2.0
1652     PT(16)=PNMS
1653     GOTO80
1654     140 IF(UNIV-.5)150,150,190
1655     150 IF(ISW(4))160,170,160
1656     160 PT(2)=2.0
1657     170 UNIV = RANDC(ISEED)
1658     IF(UNIV-.33333333)90,90,180
1659     180 PT(14)=4.0
1660     GOTO60
1661     190 IF(ISW(4))210,200,210
1662     200 PT(2)=2.0
1663     210 UNIV = RANDC(ISEED)
1664     IF(UNIV-.66666667)220,220,230
1665     220 PT(14)=4.0
1666     IF(ISW(4))70,80,70
1667     230 PT(16)=PNMS
1668     IF(ISW(4))240,70,240
1669     240 GO TO 100
1670     END
1671     *CMZ : 0.92/00 02/12/92 16.02.29 by Christian Zeitnitz
1672     *-- Author :
1673     SUBROUTINE CQLP28
1674     IMPLICIT REAL *8 (A-H,O-Z)
1675     C
1676     #include "crandm.inc"
1677     #include "cbert3.inc"
1678     #include "cisob2.inc"
1679     *KEND.
1680     SAVE
1681     C
1682     R = RANDC(ISEED)
1683     IF(ISW(13))230,10,230
1684     10 IF(R-.6)20,20,120
1685     20 PT(4)=PNMS
1686     R = RANDC(ISEED)
1687     IF(ISW(4))30,90,30
1688     30 IF(R-.33333333)40,40,70
1689     40 PT(26)=5.0
1690     50 PT(28)=PNMS
1691     60 RETURN
1692     70 PT(26)=4.0
1693     80 PT(38)=2.0
1694     GOTO60
1695     90 PT(2)=5.0
1696     PT(14)=2.0
1697     IF(R-.33333333)100,100,110
1698     100 PT(28)=PNMS
1699     GOTO80
1700     110 PT(26)=4.0
1701     GOTO60
1702     120 R = RANDC(ISEED)
1703     IF(ISW(4))130,180,130
1704     130 IF(R-.66666667)140,140,160
1705     140 PT(2)=4.0
1706     150 R = RANDC(ISEED)
1707     IF(R-.66666667)110,110,100
1708     160 PT(14)=2.0
1709     170 PT(4)=PNMS
1710     GOTO150
1711     180 IF(R-.66666667)190,190,220
1712     190 PT(2)=4.0
1713     200 PT(14)=2.0
1714     210 R = RANDC(ISEED)
1715     IF(R-.66666667)70,70,40
1716     220 PT(2)=5.0
1717     PT(4)=PNMS
1718     GOTO210
1719     230 IF(R-VALUE1)240,240,270
1720     240 PT(4)=PNMS
1721     IF(ISW(4))260,250,260
1722     250 PT(2)=5.0
1723     PT(14)=2.0
1724     GOTO50
1725     260 PT(38)=2.0
1726     GOTO40
1727     270 R = RANDC(ISEED)
1728     IF(ISW(4))280,310,280
1729     280 IF(R-.33333333)290,290,300
1730     290 PT(4)=PNMS
1731     GOTO200
1732     300 PT(2)=4.0
1733     GOTO210
1734     310 IF(R-.33333333)320,320,330
1735     320 PT(2)=5.0
1736     GOTO170
1737     330 PT(14)=2.0
1738     GOTO140
1739     END
1740     *CMZ : 0.92/00 02/12/92 16.02.29 by Christian Zeitnitz
1741     *-- Author :
1742     SUBROUTINE CQLPHA
1743     IMPLICIT REAL *8 (A-H,O-Z)
1744     C
1745     #include "crandm.inc"
1746     #include "cbert3.inc"
1747     #include "cisob2.inc"
1748     *KEND.
1749     SAVE
1750     C
1751     UNIV = RANDC(ISEED)
1752     IF(VALUE3)300,10,140
1753     10 IF(UNIV-VALUE1)20,20,120
1754     20 IF(ISW(11))40,30,40
1755     30 PT(2)=5.0
1756     PT(26)=2.0
1757     40 PT(4)=PNMS
1758     PM(4)=PNMS
1759     UNIV = RANDC(ISEED)
1760     IF(UNIV-VALUE2)50,50,70
1761     50 PT(14)=4.0
1762     60 RETURN
1763     70 IF(ISW(11))110,80,110
1764     80 PT(26)=1.0
1765     90 PT(14)=5.0
1766     100 PT(16)=PNMS
1767     GOTO60
1768     110 PT(26)=2.0
1769     GOTO100
1770     120 PT(2)=4.0
1771     IF(ISW(11))100,130,100
1772     130 PT(14)=5.0
1773     GOTO110
1774     140 IF(UNIV-VALUE1)150,150,200
1775     150 PM(4)=PNMS
1776     IF(ISW(11))160,190,160
1777     160 PT(2)=5.0
1778     170 PT(16)=PNMS
1779     180 PT(4)=PNMS
1780     GOTO60
1781     190 PT(14)=5.0
1782     PT(26)=2.0
1783     GOTO170
1784     200 IF(UNIV-VALUE2)210,210,250
1785     210 PT(2)=4.0
1786     UNIV = RANDC(ISEED)
1787     IF(UNIV-VALUE3)240,240,220
1788     220 IF(ISW(11))50,230,50
1789     230 PT(26)=2.0
1790     GOTO50
1791     240 IF(ISW(11))110,90,110
1792     250 PM(4)=PNMS
1793     PT(4)=PNMS
1794     UNIV = RANDC(ISEED)
1795     IF(UNIV-.66666667)260,260,280
1796     260 IF(ISW(11))230,270,230
1797     270 PT(2)=5.0
1798     GOTO50
1799     280 IF(ISW(11))90,290,90
1800     290 PT(26)=2.0
1801     GOTO160
1802     300 IF(UNIV-VALUE1)310,310,340
1803     310 PM(4)=PNMS
1804     PT(4)=PNMS
1805     UNIV = RANDC(ISEED)
1806     IF(VALUE3+1.0)330,320,330
1807     320 IF(UNIV-.33333333)90,90,230
1808     330 PT(2)=5.0
1809     IF(UNIV-.33333333)110,110,50
1810     340 IF(UNIV-VALUE2)350,350,380
1811     350 PT(2)=4.0
1812     UNIV = RANDC(ISEED)
1813     IF(VALUE3+1.0)370,360,370
1814     360 IF(UNIV-.66666667)50,50,110
1815     370 IF(UNIV-.66666667)230,230,90
1816     380 PM(4)=PNMS
1817     PT(4)=PNMS
1818     IF(VALUE3+1.0)390,160,390
1819     390 PT(14)=5.0
1820     GOTO110
1821     END
1822     *CMZ : 1.01/00 03/06/93 19.40.16 by Christian Zeitnitz
1823     *-- Author :
1824     SUBROUTINE CQNGID
1825     IMPLICIT REAL *8 (A-H,O-Z)
1826     C
1827     #include "crandm.inc"
1828     #include "cbert3.inc"
1829     #include "cisob2.inc"
1830     *KEND.
1831     SAVE
1832     C
1833     C ******************************************************************
1834     C**** CALCULATES COS AND SIN THETA,SIN AND COS PHI **************
1835     C ******************************************************************
1836     ICURR= CURR(1)
1837     IT=0
1838     GO TO(10,10,30,30,30),ICURR
1839     C**** INCIDENT PARTICLE - NUCLEON
1840     10 IF(IT.EQ.21.OR.IT.EQ.22)GO TO 20
1841     C**** SINGLE PRODUCTION
1842     IF(RLKE.GT.3500.0D0) CALL CERROR('CQNGID1$')
1843     IF(RLKE.LT.500.0D0)GO TO 70
1844     TESISO= 0.75D0
1845     IF(RLKE.LT.1000.0D0)GO TO 50
1846     TESISO= 0.5D0
1847     IF(RLKE.LT.1300.0D0)GO TO 50
1848     TESISO= 0.25D0
1849     IF(RLKE.LT.2500.0D0)GO TO 50
1850     GO TO 60
1851     C**** DOUBLE PRODUCTION
1852     20 IF(RLKE.GT.3500.0D0) CALL CERROR('CQNGID2$')
1853     GO TO 60
1854     C**** INCIDENT PARTICLE-PION
1855     30 R = RANDC(ISEED)
1856     IF(RLKE.GT.2500.0D0) CALL CERROR('CQNGID3$')
1857     CST= -0.9999995D0
1858     SNT= 0.003162D0
1859     IF(IT.NE.11)GO TO 40
1860     IF(R.LE.0.75D0)GO TO 70
1861     GO TO 80
1862     C**** (PI+)-(P),(PI-)-(N)
1863     C**** (PI0)-(N),(PI0)-(P)
1864     40 IF(IT.NE.12.AND.IT.NE.28) CALL CERROR('CQNGID4$')
1865     IF(RLKE.LT.500.0D0)CST=-CST
1866     IF(R.LE.0.80D0)GO TO 70
1867     GO TO 80
1868     50 R = RANDC(ISEED)
1869     IF(R.LE.TESISO)GO TO 70
1870     C**** BACKWARD/FORWARD
1871     60 R = RANDC(ISEED)
1872     C**** TEST FOR DIRECTION
1873     CST= 0.9999995D0
1874     SNT= 0.003162D0
1875     IF(R.LE.0.5)GO TO 80
1876     CST= -0.9999995D0
1877     GO TO 80
1878     C**** ISOTROPIC
1879     70 CALL CAPOL1(CST,SNT)
1880     C**** CALCULATES COS,SIN PHI
1881     80 CALL CAAZIO(SOPC,SOPS)
1882     RETURN
1883     END
1884     *CMZ : 0.92/00 02/12/92 16.02.29 by Christian Zeitnitz
1885     *-- Author :
1886     SUBROUTINE CQOLL
1887     IMPLICIT REAL *8 (A-H,O-Z)
1888     #include "cbert3.inc"
1889     #include "cisob2.inc"
1890     *KEND.
1891     SAVE
1892     C
1893     A=PM(4)*PM(4)
1894     COL(15)=0.0
1895     COL(1)=E(1)+E(2)
1896     C TOTAL ENERGY PARTICLES 1 AND 2
1897     DO10 I=1,3
1898     10 COL(I+1)=PM(I)*PM(I)
1899     C MASS PARTICLE I SQD.
1900     COL(5)=COL(3)+COL(2)+2.0*(E(1)*E(2)-(PXYZ(1)*PXYZ(2)+PXYZ(5)*
1901     1PXYZ(6)+PXYZ(9)*PXYZ(10)))
1902     COL(6)=DSQRT(COL(5))
1903     COL(7)=COL(6)/COL(1)
1904     C GAM
1905     COL(8)=2.0*COL(6)
1906     COL(9)=(COL(4)+COL(5)-A)/COL(8)
1907     COM2=COL(9)*COL(9)
1908     20 IF(COL(4)-2.9882156E27)30,30,50
1909     C GT,PM(3)=ISOBAR--LTE,TEST FOR ROUNDOFF RANGE,(MIN)SQD+OR-5E23
1910     30 IF(COL(4)-2.9872156E27)60,40 ,40
1911     C LT,PION OR NUCLEON MASS=PM(3)
1912     40 COL(4)=2.9877156E27
1913     PM(3) = 5.466005D13
1914     50 IF(COM2-COL(4))70,90,90
1915     60 IF(COL(4)-SQNM)50,50,120
1916     C LTE,HAVE NUCLEON OR PION--GT,GO TO ERROR
1917     70 IF(COM2-9.9D-1*COL(4)) 90,80,80
1918     80 COM2 = COL(4)
1919     COL(9) = PM(3)
1920     90 COL(10)=DSQRT(COM2-COL(4))
1921     C P3 PRIME
1922     IF(IK)100,170,100
1923     100 COL(11)=(COL(5)+COL(2)-COL(3))/COL(8)
1924     C E1 PRIME
1925     COL(12)=DSQRT(COL(11)*COL(11)-COL(2))
1926     C P1 PRIME
1927     COL(13)=(COL(7)*E(1)-COL(11))/COL(12)
1928     C BETA
1929     COM=1.0-(COL(13)*COL(13)+COL(7)*COL(7))
1930     IF(COM-5.0E-6)110,150,150
1931     110 IF(COM+5.0E-6)120,140,140
1932     120 COL(15)=1.0
1933     C ERROR
1934     130 RETURN
1935     140 COL(14)=.002236067977
1936     GOTO160
1937     150 COL(14)=DSQRT(COM)
1938     C ALPHA
1939     160 E(3)=(COL(9)+COL(10)*(COL(13)*CST+COL(14)*SOPC*SNT))/COL(7)
1940     E(4)=COL(1)-E(3)
1941     GOTO130
1942     170 DO180 I=11,14
1943     180 COL(I)=0.0
1944     E(3)=0.0
1945     E(4)=0.0
1946     GOTO130
1947     C FOR PART AT REST E1 AND P1 PRIME,ALPHA AND BETA NOT
1948     C CALCULATED. E(3) ANDE(4) DONE LATER
1949     END
1950     *CMZ : 1.01/04 10/06/93 14.43.41 by Christian Zeitnitz
1951     *-- Author :
1952     SUBROUTINE QOLLM
1953     IMPLICIT REAL *8 (A-H,O-Z)
1954     #include "cbert3.inc"
1955     #include "cisob2.inc"
1956     *KEND.
1957     SAVE
1958     C
1959     IF(IK)10,60,10
1960     10 UNIV=E(2)+COL(6)-COL(11)
1961     UNIVE=E(1)+COL(11)
1962     UNIVER=COL(1)+COL(6)
1963     K=16
1964     DO20 I=1,9,4
1965     COL(K)=(PXYZ(I)*UNIV-PXYZ(I+1)*UNIVE)/UNIVER
1966     COL(K+3)=(PXYZ(I)+PXYZ(I+1))/COL(1)
1967     C VX
1968     20 K=K+1
1969     COL(22)=(-PXYZ(9)*PXYZ(6))/COL(1)
1970     C QX
1971     C ABBREVIATED FORM SINCE PXYZ(1)=PXYZ(5)=0.0
1972     COL(23)=(PXYZ(2)*PXYZ(9))/COL(1)
1973     C QY
1974     C ABBREVIATED FORM SINCE PXYZ(1)=PXYZ(5)=0.0
1975     COL(24)=0.0
1976     C ABBREVIATED FORM SINCE PXYZ(1)=PXYZ(5)=0.0
1977     A=SNT/COL(14)
1978     B=A*COL(10)
1979     C (-BETA*COS PHI*SIN THETA/ALPHA + COS THETA)/P1P*P3P
1980     UNIV=COL(10)*(CST-A*SOPC*COL(13))/COL(12)
1981     UNIVE=B*SOPS/COL(12)
1982     C P3P*SIN PHI*SIN THETA/P1P*ALPHA
1983     UNIVER=(SOPC*B)+((E(3)+COL(9))/(COL(7)+1.0))
1984     C COS PHI*SIN THETA*P3P/ALPHA + (E3+E3P)/(1.0+GAMMA)
1985     K=19
1986     DO30 I=3,11,4
1987     PXYZ(I)=COL(K)*UNIVER+COL(K+3)*UNIVE+COL(K-3)*UNIV
1988     30 K=K+1
1989     DO40 I=1,9,4
1990     40 PXYZ(I+3)=PXYZ(I)+PXYZ(I+1)-PXYZ(I+2)
1991     50 RETURN
1992     60 DO70 I=16,17
1993     COL(I)=0.0
1994     70 COL(I+3)=0.0
1995     COL(18)=PXYZ(9)*PM(2)/COL(6)
1996     C P(1),Z *M2/M=P(BAR PRIME)1,Z
1997     COL(21)=PXYZ(9)/COL(1)
1998     C VZ VELOCITY
1999     DO80 I=22,24
2000     80 COL(I)=0.0
2001     C CROSS PRODUCT P1 PRIME X V
2002     PXYZ(3)=COL(10)*SNT*SOPC
2003     C X COMPONENT P3 BAR =P3 PRIME X SIN THETA X COS PHI
2004     PXYZ(7)=COL(10)*SNT*SOPS
2005     C Y COMP. P3 BAR =P3 PRIME X SIN THETA X SIN PHI
2006     PXYZ(11)=COL(10)*CST
2007     Z=PXYZ(9)/COL(6)
2008     PXYZ(11)=PXYZ(11)+(Z*PXYZ(9)*PXYZ(11))/(COL(1)+COL(6))+Z*COL(9)
2009     C Z COMP. P3 BAR=P3 PRIME COS THETA+(P1Z SQ*P3Z (PRIME)COS
2010     C THETA/(E PRIME*(E+E PRIME))+P1Z*E3 PRIME/E PRIME
2011     E(3)=DSQRT(PXYZ(3)*PXYZ(3)+PXYZ(7)*PXYZ(7)+PXYZ(11)*PXYZ(11)+
2012     +PM(3)*PM(3))
2013     DO90 I=1,9,4
2014     90 PXYZ(I+3)=PXYZ(I)-PXYZ(I+2)
2015     E(4)=DSQRT(PXYZ(4)*PXYZ(4)+PXYZ(8)*PXYZ(8)+PXYZ(12)*PXYZ(12)
2016     ++PM(4)*PM(4))
2017     IF(PT(38))50,100,50
2018     100 PT(3)=((E(4)-PM(4))/RCPMV)+PT(3)
2019     GOTO50
2020     END
2021     *CMZ : 0.92/00 02/12/92 16.02.29 by Christian Zeitnitz
2022     *-- Author :
2023     SUBROUTINE QOUT17(T,B,R,W,G)
2024     IMPLICIT REAL *8 (A-H,O-Z)
2025     C
2026     #include "crandm.inc"
2027     #include "cbert3.inc"
2028     #include "cisob2.inc"
2029     *KEND.
2030     C
2031     DIMENSIONT(117),B(101),R(117),W(234),G(234)
2032     SAVE
2033     C
2034     IF(I3)10 ,10 ,160
2035     10 PT(38)=0.0
2036     C 1-ALPHA PART.6+1
2037     VALUE1=RLKE-180.0
2038     CALL QRDET(1,T(1),VALUE1)
2039     20 COM2=CRDT(1)
2040     FTR =DNCMS*RLKE*2.0*RCPMV+2.9877156E27
2041     C E**2=MIN**2+NCNMS*RLKE*2*RCPMV
2042     UNIVER=DSQRT(FTR )
2043     C E
2044     30 VALUE2 = RANDC(ISEED)
2045     COM=VALUE2*COM2
2046     C R-PRIME
2047     CALL CQENE (B(1))
2048     COM1=(COM*COM+FTR -.501264E26)/(2.0*UNIVER)
2049     C M1R PRIME)**2+E**2-2(PNMS)/2E=E ALPHA
2050     A=COM1*COM1-COM*COM
2051     IF(A)40 ,50 ,50
2052     40 PACNT=PACNT+1.0
2053     GOTO30
2054     50 UNIVE=(UNIVER-COM1)*COM1*(DSQRT(A)/UNIVER)
2055     C ((E BETA*E ALPHA*P ALPHA)/E)=F(M,TR)
2056     CALL QRDET(1,R(1),VALUE1)
2057     C (PI-NUC)FMAX(RLKE)ISOBAR SAMPLING S.P.
2058     COM1 = RANDC(ISEED)
2059     IF((UNIVE/CRDT(1))-COM1)30 ,60 ,60
2060     C RANDOM NO. LESS OR EQUAL THAN F(M,TR)/FMAX(TR)
2061     60 CALL CQNGID
2062     PM(4)=POMS
2063     PM(3)=COM
2064     PT(2)=3.0
2065     PT(4)=POMS
2066     PT(14)=3.0
2067     PT(16)=POMS
2068     PT(26)=1.0
2069     PT(28)=DNCMS
2070     IF(ISW(9))80 ,70 ,80
2071     70 IF(ISW(10))120 ,110 ,120
2072     80 IF(ISW(10))130 ,90 ,130
2073     90 I3=-1
2074     100 RETURN
2075     110 VALUE1=.4
2076     VALUE2=.66666667
2077     VALUE3=0.0
2078     GOTO150
2079     120 CALL QRDET(2,W(1),VALUE1)
2080     C (PICH-P)FRACT. FIN.STA.WITH RECL. PI1 PI0 L.E.
2081     VALUE3=.33333333
2082     GOTO140
2083     130 CALL QRDET(2,G(1),VALUE1)
2084     VALUE3=STRKP
2085     C (PIN-P)FRACT.FIN.STA.WITH RECL.PI1 PIO L.E.
2086     140 VALUE1=CRDT(1)
2087     VALUE2=CRDT(2)
2088     150 CALL CQLPHA
2089     160 PT(3)=0.0
2090     PT(15)=0.0
2091     PT(27)=0.0
2092     PT(39)=0.0
2093     170 CALL CQOLL
2094     IF(COL(15))90 ,180 ,90
2095     180 IF(PT(38))190 ,200 ,190
2096     190 I3=0
2097     GOTO100
2098     200 PT(39)=0.0
2099     IF(IK)210 ,220 ,210
2100     210 PT(3)=((E(4)-PM(4))/RCPMV)+PT(3)
2101     220 I3=1
2102     GOTO100
2103     END
2104     *CMZ : 1.01/04 10/06/93 14.43.41 by Christian Zeitnitz
2105     *-- Author :
2106     SUBROUTINE QOUT18
2107     IMPLICIT REAL *8 (A-H,O-Z)
2108     #include "cbert3.inc"
2109     #include "cisob2.inc"
2110     *KEND.
2111     SAVE
2112     GOTO(10 ,20 ,80 ,120 ,80 ,100 ),I3
2113     10 I=3
2114     COL(15)=1.0
2115     K=27
2116     GOTO30
2117     20 I=3
2118     COL(15)=4.0
2119     K=15
2120     30 PNIDK(1)=PM(I)
2121     J=I
2122     DO40 L=2,4
2123     PNIDK(L)=PXYZ(J)
2124     40 J=J+4
2125     PNIDK(5)=E(I)
2126     PNIDK(6)=PT(K-11)
2127     CALL CALQDK
2128     IF(K-27)60 ,50 ,60
2129     50 PT(15)=PT(15)+((PNIDK(12)-PNIDK( 6))/RCPMV)
2130     60 PT(K)=PT(K)+((PNIDK(13)-DNCMS)/RCPMV)
2131     I3=1
2132     70 IV=K
2133     RETURN
2134     80 COL(15)=3.0
2135     K=15
2136     IF(PT(14)-2.0)90 ,90 ,120
2137     90 I3=2
2138     GOTO70
2139     100 L=14
2140     DO110 M=5,7
2141     PT(M)=PNIDK(L)
2142     PT(M+12)=PNIDK(L+3)
2143     110 L=L+1
2144     PT(11)=PNIDK(12)
2145     PT(12)=PNIDK(6)
2146     I=4
2147     K=39
2148     COL(15)=5.0
2149     GOTO30
2150     120 I1=3
2151     130 K=12*I1-33
2152     140 IF(I1-4)150 ,160 ,170
2153     150 I2=-1
2154     GOTO200
2155     160 I2=0
2156     GOTO200
2157     170 IF(I1-5)160 ,190 ,180
2158     180 I3=4
2159     GOTO70
2160     190 I2=1
2161     200 IF(PT(K))210 ,220 ,210
2162     210 CALL CQSTOR
2163     220 I1=I1+1
2164     GOTO130
2165     END
2166     *CMZ : 0.92/00 02/12/92 16.02.29 by Christian Zeitnitz
2167     *-- Author :
2168     SUBROUTINE QOUT19
2169     IMPLICIT REAL *8 (A-H,O-Z)
2170     #include "cbert3.inc"
2171     #include "cisob2.inc"
2172     *KEND.
2173     SAVE
2174     C
2175     10 PT(3)=PT(3)+((PT(11)-PT(12))/RCPMV)
2176     C COLLISION ALLOWED
2177     K=3
2178     GOTO100
2179     20 I3=-1
2180     30 RETURN
2181     40 I2=2
2182     50 I1=(K/12)+3
2183     60 CALL CQSTOR
2184     70 IF(K-15)80 ,90 ,120
2185     80 K=15
2186     GOTO40
2187     90 K=27
2188     PT(27)=PT(27)+((PNIDK(12)-PT(K+1))/RCPMV)
2189     100 IF(K-15)40 ,110 ,110
2190     110 I2=0
2191     GOTO50
2192     120 IF(K-27)20 ,130 ,140
2193     130 IF(PT(39))140 ,140 ,150
2194     140 I3=0
2195     GOTO30
2196     150 I2=1
2197     K=39
2198     GOTO50
2199     END
2200     *CMZ : 0.92/00 02/12/92 16.02.29 by Christian Zeitnitz
2201     *-- Author :
2202     SUBROUTINE QOUT21(V,W,X,Y,Z)
2203     IMPLICIT REAL *8 (A-H,O-Z)
2204     C
2205     #include "crandm.inc"
2206     #include "cbert3.inc"
2207     #include "cisob2.inc"
2208     *KEND.
2209     C
2210     REAL*8 V(161),W(101),X(161),Y(130),Z(176)
2211     SAVE
2212     C
2213     VALUE2=RLKE*4.81633308E24+9.0554256E27
2214     C E(TR)**2=RLKE*RCPMV*2*NCMS+4*NCMS**2
2215     VALUE3=DSQRT(VALUE2)
2216     GOTO(10 ,130 ,140 ,270 ),I3
2217     10 ISW(12)=0
2218     20 PT(38)=0.0
2219     I1=0
2220     30 ANS=RLKE
2221     40 VALUE1=ANS-300.0
2222     CALL QRDET(1,V(1),VALUE1)
2223     C (NUC-NUC) F(TR) ISOBAR SAMPLING
2224     FTR=CRDT(1)
2225     50 SN = RANDC(ISEED)
2226     COM=SN*FTR
2227     C R PRIME=F(TR)*RANDOM
2228     CALL CQENE (W(1))
2229     C (NUC-NUC)MASS OF ISOBAR S.P. M(R PRIME)
2230     IF(I1)160 ,60 ,170
2231     60 COM1=(COM*COM-SQNM+VALUE2)/(2.0*VALUE3)
2232     C E GAMMA
2233     A=COM1*COM1-COM*COM
2234     IF(A)70 ,80 ,80
2235     70 PGCNT=PGCNT+1.0
2236     GOTO50
2237     80 UNIVER=DSQRT(A)*COM1*((VALUE3-COM1)/VALUE3)
2238     C F(M,TR)=P GAMMA*E GAMMA*E DELTA/E
2239     CALL QRDET(1,X(1),VALUE1)
2240     C (NUC-NUC)FMAX(TR) ISOBAR SAMPLING S.P.
2241     COM1 = RANDC(ISEED)
2242     IF(COM1-(UNIVER/CRDT(1)))90 ,90 ,50
2243     90 PM(4)=DNCMS
2244     PM(3)=COM
2245     100 CALL CQNGID
2246     PT(4)=DNCMS
2247     PT(28)=DNCMS
2248     110 CALL CQLP19
2249     120 RETURN
2250     130 ISW(12)=2
2251     GOTO20
2252     140 ISW(13)=0
2253     150 I1=-1
2254     ANS=((VALUE3-.708E13)**2-9.0554256E27)/4.81633308E24
2255     GOTO40
2256     C TR PRIME COM1=RLKE PRIME
2257     160 COM1=((VALUE3+DNCMS-COM)**2-9.0554256E27)/4.81633308E24
2258     COM2=COM
2259     ANS=COM1
2260     COM4=FTR
2261     I1=1
2262     GOTO40
2263     170 COM1=(COM2*COM2-COM*COM+VALUE2)/(2.0*VALUE3)
2264     C E EPSILON
2265     A=COM1*COM1-COM2*COM2
2266     IF(A)180 ,190 ,190
2267     180 PECNT=PECNT+1.0
2268     GOTO200
2269     C F(M1,M2,TR)=P EPSILON*E EPSILON*E ZETA/E
2270     190 UNIVER=DSQRT(A)*COM1*((VALUE3-COM1)/VALUE3)
2271     VALUE1=RLKE-920.0
2272     CALL QRDET(1,Y(1),VALUE1)
2273     C (NUC-NUC)FMAX(TR) ISOBAR SAMPLING D.P. FMAX(M1,M2,TR)
2274     SN = RANDC(ISEED)
2275     IF(SN-(UNIVER*FTR/(CRDT(1)*COM4)))210 ,210 ,200
2276     200 FTR=COM4
2277     I1=-1
2278     GOTO50
2279     210 VALUE1 = RANDC(ISEED)
2280     IF(VALUE1-.5)220 ,220 ,230
2281     220 PM(3)=COM2
2282     PM(4)=COM
2283     GOTO240
2284     230 PM(3)=COM
2285     PM(4)=COM2
2286     240 CALL CQNGID
2287     PT(16)=DNCMS
2288     PT(40)=DNCMS
2289     IF(ISW(13))250 ,260 ,250
2290     250 CALL QRDET(1,Z(1),RLKE)
2291     VALUE1=CRDT(1)
2292     C (N-P)FRACT.FIN.STA.3/2 L.E.
2293     260 PT(2)=3.0
2294     PT(4)=POMS
2295     PT(14)=1.0
2296     PT(26)=3.0
2297     PT(28)=POMS
2298     PT(38)=1.0
2299     CALL CQLP28
2300     GOTO120
2301     270 ISW(13)=2.0
2302     GOTO150
2303     END
2304     *CMZ : 1.01/04 10/06/93 14.43.41 by Christian Zeitnitz
2305     *-- Author :
2306     SUBROUTINE QRDET(NODATA,DATA,ENER)
2307     IMPLICIT REAL *8 (A-H,O-Z)
2308     #include "cbert3.inc"
2309     #include "cisob2.inc"
2310     *KEND.
2311     DIMENSION DATA(380)
2312     SAVE
2313     C
2314     IE=DABS(ENER/20.0)
2315     UNIV=(ENER-DFLOAT(IE)*20.0)/20.0
2316     DO10 I=1,25
2317     10 CRDT(I)=0.0
2318     K=(NODATA*IE)+1
2319     IF(INPT)50 ,20 ,50
2320     20 N=NODATA
2321     30 L=K+NODATA
2322     DO40 I=1,N
2323     CRDT(I)=(DATA(L)-DATA(K))*UNIV+DATA(K)
2324     K=K+1
2325     40 L=L+1
2326     INPT=0
2327     RETURN
2328     50 K=INPT-1+K
2329     N=2
2330     GOTO30
2331     END
2332     *CMZ : 1.01/04 10/06/93 14.43.41 by Christian Zeitnitz
2333     *-- Author :
2334     SUBROUTINE CQSTOR
2335     IMPLICIT REAL *8 (A-H,O-Z)
2336     #include "cbert3.inc"
2337     #include "cisob2.inc"
2338     *KEND.
2339     SAVE
2340     C
2341     L=(I1*12)-28
2342     IF(I2)10,60,70
2343     10 JJ=0
2344     IF(PM(3)-DNCMS)30,30,20
2345     20 I1=I1+1
2346     JJ=1
2347     C X-Y-Z-COORDINATES OF COLLISION POINT
2348     30 UNIV=DSQRT(PXYZ(I1)*PXYZ(I1)+PXYZ(I1+4)*PXYZ(I1+4)+PXYZ(I1+8)*
2349     +PXYZ(I1+8))
2350     K=I1+8
2351     DO40 I=I1,K,4
2352     PT(L)=PXYZ(I)/UNIV
2353     40 L=L+1
2354     I1=I1-JJ
2355     50 RETURN
2356     60 K=14
2357     GOTO90
2358     70 IF(I2-2)80,110,110
2359     80 K=17
2360     90 UNIV=DSQRT(PNIDK(K)*PNIDK(K)+PNIDK(K+1)*PNIDK(K+1)+PNIDK
2361     +(K+2)*PNIDK(K+2))
2362     PT(L-3)=1.0
2363     J=K+2
2364     DO100 I=K,J
2365     PT(L)=PNIDK(I)/UNIV
2366     100 L=L+1
2367     GOTO50
2368     110 UNIV=DSQRT(PT(L-3)*PT(L-3)+PT(L-2)*PT(L-2)+PT(L-1)*PT(L-1))
2369     K=L-1
2370     M=L-3
2371     DO120 I=M,K
2372     PT(L)=PT(I)/UNIV
2373     120 L=L+1
2374     PT(M)=1.0
2375     GOTO50
2376     END
2377     *CMZ : 0.92/00 02/12/92 16.02.29 by Christian Zeitnitz
2378     *-- Author :
2379     FUNCTION SFLRAF(X)
2380     C
2381     #include "crandm.inc"
2382     *KEND.
2383     C
2384     SFLRAF = 2.0 * RANDC(ISEED)
2385     TEMP = 1.0 - SFLRAF
2386     IF(TEMP) 10 ,20 ,20
2387     10 SFLRAF = TEMP
2388     20 RETURN
2389     END
2390     *CMZ : 1.01/04 10/06/93 14.43.41 by Christian Zeitnitz
2391     *-- Author :
2392     SUBROUTINE CALSGM(NSGNL,IT,IS,DDE,EM,I,E,S)
2393     C
2394     #include "cinout.inc"
2395     #include "cxpd.inc"
2396     #include "cbert2.inc"
2397     *KEND.
2398     C
2399     DIMENSION PPNP(9,2),ENRGY(9)
2400     DATA ENRGY/1., 3., 5., 8., 10., 12.5,15., 17.5,20./
2401     DATA PPNP /1.20,.890,.620,.392,.310,.250,.208,.178,.155,
2402     + 4.25,2.28,1.62,1.14,.940,.765,.645,.555,.480/
2403     DATA IEMX /9/
2404     SAVE
2405     C
2406     I= IFIX(EM/DDE + 1.)
2407     E= FLOAT(I-1)*DDE
2408     IF(EM.LT.20.0.AND.IT.LE.2) GO TO 70
2409     GO TO (10,30),NSGNL
2410     10 TEMP = SNGL(CS(I+IS))
2411     S = TEMP + (EM-E)/DDE*(SNGL(CS(I+1+IS))- TEMP)
2412     20 RETURN
2413     30 IF(IT.GT.2) GO TO 60
2414     IF(I.LT.176) GO TO 50
2415     40 CALL CERROR('CALSGM1$')
2416     50 S= NPSG(IT,I) +(EM-E)/DDE*(NPSG(IT,I+1) - NPSG(IT,I) )
2417     GO TO 20
2418     60 IF(I.GT.125) GO TO 40
2419     IT = IT - 2
2420     S= PIPSG(IT,I) + (EM-E)/DDE *(PIPSG(IT,I+1) - PIPSG(IT,I) )
2421     GO TO 20
2422     C** LOW ENERGY (.LT. 20 MEV) P-P OF N-P XSECTS FOR ELAST. SCATT. WITH H.
2423     70 CONTINUE
2424     IF(EM.LT.ENRGY(1)) CALL CERROR('CALSGM2$')
2425     DO 80 IE = 2,IEMX
2426     IF(EM.LE.ENRGY(IE)) GO TO 90
2427     80 CONTINUE
2428     CALL CERROR('CALSGM3$')
2429     90 S = ALOG(PPNP(IE-1,IT)) + (EM - ENRGY(IE-1)) /
2430     + (ENRGY(IE) - ENRGY(IE-1)) *
2431     + (ALOG(PPNP(IE,IT)) - ALOG(PPNP(IE-1,IT)))
2432     S = EXP(S) * 1.0E-24
2433     GO TO 20
2434     END
2435     *CMZ : 1.01/04 10/06/93 14.43.41 by Christian Zeitnitz
2436     *-- Author :
2437     SUBROUTINE CSHXD
2438     C
2439     #include "cxpd.inc"
2440     *KEND.
2441     C
2442     DE = 20.
2443     LOCX(1,1) = 995
2444     LOCX(2,1) = 1153
2445     LOCX(3,1) = 3793
2446     LOCX(4,1)= 0
2447     LOCX(1,2) = 1283
2448     LOCX(2,2) = 1441
2449     LOCX(3,2) = 3969
2450     LOCX(4,2)= 0
2451     LOCX(1,3) = 2009
2452     LOCX(2,3)= 0
2453     LOCX(3,3) = 3667
2454     LOCX(4,3)= 0
2455     LOCX(1,4) = 2243
2456     LOCX(2,4)= 0
2457     LOCX(3,4) = 3541
2458     LOCX(4,4) = 3415
2459     DO 10 IT =1,4
2460     DO 10 ID =1,4
2461     10 ETH(ID,IT) = 0.
2462     DO 20 IT=1,2
2463     ETH(1,IT)= 360.
2464     20 ETH(2,IT)= 920.
2465     DO 30 IT =3,4
2466     30 ETH(1,IT)= 180.
2467     RETURN
2468     END
2469     *CMZ : 0.90/04 11/09/92 05.11.48 by Christian Zeitnitz
2470     *-- Author :
2471     FUNCTION XSECHE(ID,ITP,EC)
2472     #include "cbert2.inc"
2473     #include "cxpd.inc"
2474     *KEND.
2475     C
2476     C ID = 1 2 3 4
2477     C SNGL PROD DBLE PROD ELASTIC EXCHANGE
2478     C ITP = 1 2 3 4
2479     C PROT NEUT PI+ PI-
2480     ET = ETH(ID,ITP)
2481     LC =LOCX(ID,ITP)
2482     I= IFIX( (EC-ET)/DE + 1.)
2483     E = FLOAT(I-1)*DE + ET
2484     TEMP = SNGL( CS(I+LC) )
2485     XSECHE=TEMP + (EC-E)/DE * ( SNGL( CS(I+1+LC) ) - TEMP )
2486     RETURN
2487     END
2488     *CMZ : 0.90/00 27/05/92 16.43.05 by Christian Zeitnitz
2489     *-- Author :
2490     FUNCTION CZFOI(Z)
2491     C** USING REVISED DATA (1-70,TWA)
2492     DIMENSION FLI(13)
2493     DATA FLI/18.7,42.0,39.0,60.0,68.0,78.0,99.5,98.5,117.0,140.0,
2494     1150.0,157.0,163.0/,A1/9.76/,A2/58.8/,XP/-0.19/
2495     IF(Z.GT.13.) GO TO 10
2496     IZ=IFIX(Z)
2497     CZFOI=FLI(IZ)
2498     RETURN
2499     10 CZFOI=A1*Z + A2 *(Z**XP)
2500     RETURN
2501     END
2502     *CMZ : 1.04/03 17/02/95 12.38.47 by Christian Zeitnitz
2503     *-- Author : Christian Zeitnitz 21/05/92
2504     SUBROUTINE CHETC(DOSKAL)
2505     C*************************************************************
2506     C
2507     C process intranuclear-cascade and evaporation
2508     C call scaling for smooth transition to FLUKA
2509     C If H-Atoms present -> special particle-H collision
2510     C generate de-exitation gammas
2511     C
2512     C*************************************************************
2513     C
2514     C Interface common
2515     #include "calgea.inc"
2516     *KEND.
2517     C
2518     C CALOR commons
2519     #include "ccomon.inc"
2520     #include "ccomn2.inc"
2521     #include "ccomn3.inc"
2522     #include "cjoint.inc"
2523     #include "cxpd.inc"
2524     #include "cgeos.inc"
2525     #include "chevap.inc"
2526     #include "ctncol.inc"
2527     #include "crandm.inc"
2528     #include "cmass.inc"
2529     *KEND.
2530     C
2531     DIMENSION F(8),PCAP(100,2),NPCOL(12),AP(12),ZP(12)
2532     C
2533     LOGICAL DOSKAL,INIT
2534     INTEGER IBERT
2535     SAVE
2536     C
2537     DATA AP/ 1., 1., 0., 0., 0., 0., 0., 2., 3., 3., 4., 0./
2538     DATA ZP/ 1., 0., 0., 0., 0., 0., 0., 1., 1., 2., 2., 0./
2539     C
2540     DATA INIT/.TRUE./
2541     C
2542     IF(INIT) THEN
2543     IBERT = 0
2544     INIT = .FALSE.
2545     ENDIF
2546     INTCAL = 12
2547     NO = 1
2548     ATARGT = 0.0
2549     ZTARGT = 0.0
2550     ITYP = IPINC + 1
2551     TIP(1) = FLOAT(IPINC)
2552     WT(NO) = 1.0
2553     EC(1) = EINC
2554     MAT = 1
2555     MXMAT = 1
2556     NEL(1) = NCEL
2557     C copy material data to CALOR
2558     DO 10 I=1,NCEL
2559     DEN(I,1) = DMED(I)
2560     ZZ(I,1) = ZMED(I)
2561     A(I,1) = AMED(I)
2562     DENH(1) = HDEN
2563     10 CONTINUE
2564     C calculate x-section for given material
2565     CALL CALCXS
2566     20 CONTINUE
2567     C
2568     C --------- start of intranuclear cascade ----------------------
2569     C
2570     C
2571     R = RANDC(ISEED)
2572     IF(E(NO) - 1.0)100,30 ,100
2573     C* PI- CAPTURE ?
2574     30 IF(TIP(NO).NE.4) GOTO 100
2575     INTCAL = 18
2576     M=1
2577     LMX=NEL(M)
2578     DO 40 L=1,LMX
2579     40 PCAP(L,M)=DEN(L,M)*ZZ(L,M)
2580     PCAPS=0.
2581     DO 50 L=1,LMX
2582     50 PCAPS=PCAPS+PCAP(L,M)
2583     DO 60 L=1,LMX
2584     60 PCAP(L,M)=PCAP(L,M)/PCAPS
2585     LMX=NEL(MAT)
2586     DO 80 L=1,LMX
2587     R0=R
2588     R=R-PCAP(L,MAT)
2589     IF(R.LE.0.) GO TO 70
2590     GO TO 80
2591     70 LELEM=L
2592     GO TO 90
2593     80 CONTINUE
2594     CALL CERROR('NMTC$')
2595     90 DKWT=1.
2596     GO TO 250
2597     100 CONTINUE
2598     C
2599     IF(ITYP.GE.6) GO TO 220
2600     R = R-HSIGG(ITYP,MAT)/SIGMX(ITYP,MAT)
2601     IF(R) 110,110 ,230
2602     110 CONTINUE
2603     CZ 10/11/92 SCALING added
2604     C scaling selected ?
2605     IF(DOSKAL) THEN
2606     INC = ITYP - 1
2607     C get H cross-section
2608     CALL SHXSEC(EC(1),INC,HEHT,HEHEL,HELNEL)
2609     R = RANDC(ISEED)
2610     IF(HEHT*DENH(MAT)*1.E 24/HSIGG(ITYP,MAT)-R) 210,120,120
2611     120 CONTINUE
2612     ATARGT = 1.
2613     ZTARGT = 1.
2614     R = RANDC(ISEED)
2615     IF(HEHEL/HEHT.GT.R) THEN
2616     C ---- elastic
2617     CALL CSCATT(INC,EC(NO),KIND,EP,ALPHA,BETA,GAM)
2618     NOPART = 2
2619     GOTO 160
2620     ELSE
2621     C ---- nonelastic
2622     EHICUT = EMAXPI*1000.
2623     IF(TIP(NO).LE.1.) EHICUT = EMAXP*1000.
2624     CALL SKALEH(IBERT,INC,HEHT,EC(NO),NOPART,KIND,EP,ALPHA,
2625     + BETA,GAM,EHICUT)
2626     GOTO 160
2627     ENDIF
2628     ELSE
2629     CALL GTHSIG(2)
2630     R = RANDC(ISEED)
2631     IF(HSIG*DENH(MAT)*1.E 24/HSIGG(ITYP,MAT)-R) 210,130,130
2632     130 CONTINUE
2633     140 CONTINUE
2634     ATARGT = 1.0
2635     ZTARGT = 1.0
2636     UU = 0.0
2637     CALL CPCOL(IBERT,ITYP,HSIG,EC(NO),NOPART,KIND,EP,ALPHA,BETA,
2638     + GAM)
2639     C CHANGED NOV.1,1986
2640     IBERT = 1
2641     ENDIF
2642     IF(NOPART.LE.0) GO TO 170
2643     DO 150 I=1,NOPART
2644     KINDI(I)=KIND(I)+1
2645     IBB=1
2646     IF(KINDI(I).GT.2)IBB=0
2647     IBBARR(I)=IBB
2648     150 CONTINUE
2649     160 APR = 0.0
2650     ZPR = 0.0
2651     GOTO 190
2652     170 CONTINUE
2653     C END OF CHANGE
2654     C
2655     180 CONTINUE
2656     LELEM = 1
2657     APR=A(LELEM,MAT)
2658     ZPR =ZZ(LELEM,MAT)
2659     190 EX= 0.
2660     EREC =0.
2661     DO 200 I = 1,6
2662     200 NPART(I) = 0
2663     UU = 0.
2664     GOTO 430
2665     210 CONTINUE
2666     220 CONTINUE
2667     NOPART = -1
2668     GO TO 180
2669     230 NNN = NEL(MAT)
2670     DO 240 LEM = 1,NNN
2671     LELEM = LEM
2672     CZ no hydrogen accepted in BERT ; CZ 2 JUN 92
2673     IF(A(LELEM,MAT) .LT. 2.0) GOTO 240
2674     R = R - SIGG(LEM,MAT)/SIGMX(ITYP,MAT)
2675     IF(R) 250,250,240
2676     240 CONTINUE
2677     GOTO 220
2678     C------------- elastic neutron-nucleus scattering not implemented -----
2679     C
2680     250 ETOT = EINC + PMASS(IPINC+1)*1.E3
2681     CZ
2682     CZ check if mass number to low for BERT (A>=4)
2683     IF(A(LELEM,MAT).LT.4.0) THEN
2684     C
2685     CZ 2.95 CALL CERROR('NMTC: A < 4$')
2686     CZ set A=4 (brute force, but will work )
2687     A(LELEM,MAT) = 4.0
2688     ENDIF
2689     F(1) = A(LELEM,MAT)
2690     F(2) = ZZ(LELEM,MAT)
2691     F(3) = EC(NO)
2692     F(4) = 0.0
2693     F(5) = 1.0
2694     F(6) = 0.0
2695     F(7) = TIP(NO)
2696     F(8) = 0.0
2697     C
2698     CZ 10/11/92 SCALING added
2699     IF(DOSKAL) THEN
2700     EHICUT = EMAXPI*1000.
2701     IF(TIP(NO).LE.1.) EHICUT = EMAXP*1000.
2702     CALL CSKALE(IBERT,F,NOPART,KIND,EP,ALPHA,BETA,GAM,EHICUT,
2703     + RMFAS,EX,EREC)
2704     ELSE
2705     CALL CABERT(IBERT,F,NOPART,KIND,EP,ALPHA,BETA,GAM)
2706     ENDIF
2707     IBERT = 1
2708     C
2709     IF(NOPART.GT.0) THEN
2710     DO 260 I=1,NOPART
2711     KINDI(I)=KIND(I)+1
2712     IBB=1
2713     IF(KINDI(I).GT.2) IBB=0
2714     IBBARR(I)=IBB
2715     260 CONTINUE
2716     ENDIF
2717     IF(NOPART.LT.0) THEN
2718     C ----------- Pseudo collision -------------------------
2719     C if incident particle pi- with 1 MeV -> repeat BERT,
2720     C reason : pi- capture (below cutoff)
2721     IF(IPINC.EQ.4 .AND. EINC.EQ.1.0) GO TO 250
2722     C pi- capture ? -> retry
2723     IF(EINC.EQ.1.0) GOTO 20
2724     GOTO 420
2725     ELSE IF(NOPART.EQ.0) THEN
2726     C ------------------- no particle escaped nucleus ------
2727     GO TO(270,270,280,290,280,290,290),ITYP
2728     270 APR = A(LELEM,MAT) + 1.
2729     ZPR = ZZ(LELEM,MAT) + 1. - TIP(1)
2730     EX = EC(NO) + 7.
2731     GO TO 400
2732     280 APR = A(LELEM,MAT)
2733     ZPR = ZZ(LELEM,MAT) + 3.- TIP(1)
2734     EX= EC(NO) + PMASS(ITYP)*1.E3
2735     GO TO 400
2736     290 CALL CERROR('NMTC: PI0,MU+-$')
2737     C ---------------NOPART GT 0 --------------------------
2738     ELSE
2739     300 PI0 =0.
2740     SUME = 0.
2741     PRONO = 0.
2742     PIPOS = 0.
2743     PINEG = 0.
2744     DO 360 N=1,NOPART
2745     LK= KIND(N)+1
2746     GO TO(310,350,320,330,340,370,370),LK
2747     310 PRONO =PRONO +1.
2748     GO TO 350
2749     320 PIPOS = PIPOS +1.
2750     GO TO 350
2751     330 PI0 = PI0+1.
2752     GO TO 350
2753     340 PINEG= PINEG +1.
2754     350 SUME = SUME + EP(N)
2755     360 CONTINUE
2756     CHGPIS =PIPOS +PINEG
2757     FPT = NOPART
2758     FPT = FPT -CHGPIS-PI0
2759     IF(TIP(1)-1.) 380,380,390
2760     370 CALL CERROR('NMTC: MU+-$')
2761     380 APR=A(LELEM,MAT) + 1. - FPT
2762     ZPR= ZZ(LELEM,MAT) + 1. - TIP(1) - PRONO - PIPOS + PINEG
2763     IF(ZPR.LT.0.) THEN
2764     CALL CERROR(' NMTC: Zpr < 0$')
2765     EREC = 0.0
2766     EX = 0.0
2767     ZPR = 0
2768     GOTO 410
2769     ENDIF
2770     IF(.NOT.DOSKAL) EX= EINC + (1.-FPT)*7.0-SUME- CHGPIS*PMASS(3)*
2771     + 1.E3-PI0*PMASS(4)*1.E3
2772     GO TO 400
2773     390 APR = A(LELEM,MAT) - FPT
2774     ZPR = ZZ(LELEM,MAT)+ 3.-TIP(1)-PRONO-PIPOS + PINEG
2775     IF(ZPR.LT.0.) THEN
2776     CALL CERROR(' NMTC: Zpr < 0$')
2777     EREC = 0.0
2778     ZPR = 0
2779     GOTO 410
2780     ENDIF
2781     IF(.NOT.DOSKAL) EX= EINC+(1.-CHGPIS)*PMASS(3)*1.E3-SUME
2782     + -FPT*7.-PI0*PMASS(4)*1.E3
2783     ENDIF
2784     C calculate recoil energy of nucleus
2785     400 CONTINUE
2786     IF(.NOT.DOSKAL) CALL RECOIL
2787     410 EX=EX-EREC
2788     IF(EX.LT.0.0) EX = 0.0
2789     C
2790     C -------- evaporation ------------------------------
2791     C
2792     CALL CERUP
2793     C ------------------ fill return variables -------------
2794     420 CONTINUE
2795     IBERT = 1
2796     430 CONTINUE
2797     CZ set target nucleus
2798     IF(ATARGT.EQ.0.0) THEN
2799     ATARGT = A(LELEM,MAT)
2800     ZTARGT = ZZ(LELEM,MAT)
2801     ENDIF
2802     EXMED = EX
2803     IF(APR.GE.0 .AND. ZPR.GE.0) THEN
2804     ERMED(1) = EREC
2805     AMED(1) = APR
2806     ZMED(1) = ZPR
2807     NRECOL = 1
2808     ELSE
2809     AMED(1) = 0.0
2810     ZMED(1) = 0.0
2811     ERMED(1) = 0.0
2812     NRECOL = 0
2813     ENDIF
2814     IF(NOPART.LT.0) THEN
2815     C Pseudo collision
2816     NCOL = 5
2817     NPHETC = 0
2818     EKINET(1) = EINC
2819     IPCAL(1) = IPINC
2820     CALTIM(1) = 0.0
2821     UCAL(1,1) = UINC(1)
2822     UCAL(1,2) = UINC(2)
2823     UCAL(1,3) = UINC(3)
2824     EXMED = 0.0
2825     NRECOL = 1
2826     ERMED(1) = 0.0
2827     INTCAL = 24
2828     AMED(1) = A(LELEM,MAT)
2829     ZMED(1) = ZZ(LELEM,MAT)
2830     ELSE
2831     C get particles from intranuclear cascade
2832     NCOL = 2
2833     NPHETC = 0
2834     AMED(1) = APR
2835     ZMED(1) = ZPR
2836     IF(NOPART.GT.0) THEN
2837     DO 440 I=1,NOPART
2838     NPHETC = NPHETC + 1
2839     IF(NPHETC.GT.MXCP) NPHETC=MXCP
2840     EKINET(NPHETC) = EP(I)
2841     IPCAL(NPHETC) = KIND(I)
2842     CALTIM(NPHETC) = 0.0
2843     C transformation into Lab ssystem
2844     CALL CB2LAB(ALPHA(I),BETA(I),GAM(I), UINC(1),UINC(2),
2845     + UINC(3),UCAL(NPHETC,1),UCAL(NPHETC,2),UCAL(NPHETC,3))
2846     440 CONTINUE
2847     ENDIF
2848     C get evaporated neutrons
2849     IF(NPART(1).GT.0) THEN
2850     DO 450 I=1,NPART(1)
2851     NPHETC = NPHETC + 1
2852     IF(NPHETC.GT.MXCP) NPHETC=MXCP
2853     EKINET(NPHETC) = EPART(I,1)
2854     IPCAL(NPHETC) = 1
2855     CALTIM(NPHETC) = 0.0
2856     CALL GTISO(ALP,BET,CAM)
2857     UCAL(NPHETC,1) = ALP
2858     UCAL(NPHETC,2) = BET
2859     UCAL(NPHETC,3) = CAM
2860     450 CONTINUE
2861     ENDIF
2862     C get evaporated protons
2863     IF(NPART(2).GT.0) THEN
2864     DO 460 I=1,NPART(2)
2865     NPHETC = NPHETC + 1
2866     IF(NPHETC.GT.MXCP) NPHETC=MXCP
2867     EKINET(NPHETC) = EPART(I,2)
2868     IPCAL(NPHETC) = 0
2869     CALTIM(NPHETC) = 0.0
2870     CALL GTISO(ALP,BET,CAM)
2871     UCAL(NPHETC,1) = ALP
2872     UCAL(NPHETC,2) = BET
2873     UCAL(NPHETC,3) = CAM
2874     460 CONTINUE
2875     ENDIF
2876     C get evaporated heavy particles (alpha,deuteron, triton, He3)
2877     C particle type 10 7 8 9
2878     DO 480 I=3,6
2879     IF(NPART(I).GT.0) THEN
2880     DO 470 K=1,NPART(I)
2881     NPHETC = NPHETC + 1
2882     IF(NPHETC.GT.MXCP) NPHETC=MXCP
2883     EKINET(NPHETC) = HEPART(K,I-2)
2884     IPCAL(NPHETC) = I + 4
2885     CALTIM(NPHETC) = 0.0
2886     CALL GTISO(ALP,BET,CAM)
2887     UCAL(NPHETC,1) = ALP
2888     UCAL(NPHETC,2) = BET
2889     UCAL(NPHETC,3) = CAM
2890     470 CONTINUE
2891     ENDIF
2892     480 CONTINUE
2893     C generate de-exitation gammas
2894     C
2895     IF(UU.GT.0.0) THEN
2896     EEX = UU
2897     EGTOT = 0.0
2898     490 CONTINUE
2899     EGAM = EEX * RANDC(ISEED)
2900     IF((EGTOT+EGAM) .GT. EEX) THEN
2901     EGAM = EEX - EGTOT
2902     EEX = 0.0
2903     ENDIF
2904     EGTOT = EGTOT + EGAM
2905     CALL AZIRN(SINA,COSA)
2906     COSP = SFLRAF(DUM)
2907     SINP = SQRT(1.0-COSP*COSP)
2908     NPHETC = NPHETC + 1
2909     IF(NPHETC.GT.MXCP) NPHETC=MXCP
2910     EKINET(NPHETC) = EGAM
2911     UCAL(NPHETC,1) = SINP * COSA
2912     UCAL(NPHETC,2) = SINP * SINA
2913     UCAL(NPHETC,3) = COSP
2914     IPCAL(NPHETC) = 11
2915     CALTIM(NPHETC) = 0.0
2916     IF(EEX.GT.0.0) GOTO 490
2917     ENDIF
2918     ENDIF
2919     RETURN
2920     END
2921     *CMZ : 1.01/04 10/06/93 14.43.37 by Christian Zeitnitz
2922     *-- Author :
2923     SUBROUTINE CABRAN(K1)
2924     C
2925     #include "crandm.inc"
2926     *KEND.
2927     C
2928     #include "cbert.inc"
2929     *KEND.
2930     C
2931     VALUE1 = RANDC(ISEED)
2932     VALUE1=VALUE1*SIGN
2933     VALUE2=0.0
2934     NOT=1
2935     DO10 I=2,K1
2936     VALUE2=CE(I)+VALUE2
2937     IF(VALUE2-VALUE1)10,20,20
2938     10 NOT=NOT+1
2939     20 RETURN
2940     C VALUE2=SUM OF CE FOR A PARTICULAR REGION--SUM F(I1)MASS
2941     END
2942     *CMZ : 0.92/00 02/12/92 16.02.23 by Christian Zeitnitz
2943     *-- Author :
2944     SUBROUTINE CALP19
2945     #include "crandm.inc"
2946     #include "cbert.inc"
2947     *KEND.
2948     SAVE
2949     C
2950     C
2951     UNIV = RANDC(ISEED)
2952     PT(2)=1.0
2953     PT(26)=1.0
2954     PT(14)=3.0
2955     PT(16)=POMS
2956     IF(ISW(12))10,10,140
2957     10 IF(UNIV-.25)20,20,110
2958     20 IF(ISW(4))40,30,40
2959     30 PT(2)=2.0
2960     40 UNIV = RANDC(ISEED)
2961     IF(UNIV-6.6666667D-1)50,50,90
2962     50 PT(14)=4.0
2963     60 IF(ISW(4))80,70,80
2964     70 PT(26)=2.0
2965     80 GO TO 240
2966     90 PT(16)=PNMS
2967     IF(ISW(4))70,100,70
2968     100 PT(14)=5.0
2969     GOTO80
2970     110 IF(ISW(4))130,120,130
2971     120 PT(26)=2.0
2972     GOTO90
2973     130 PT(2)=2.0
2974     PT(16)=PNMS
2975     GOTO80
2976     140 IF(UNIV-.5)150,150,190
2977     150 IF(ISW(4))160,170,160
2978     160 PT(2)=2.0
2979     170 UNIV = RANDC(ISEED)
2980     IF(UNIV-3.3333333D-1)90,90,180
2981     180 PT(14)=4.0
2982     GOTO60
2983     190 IF(ISW(4))210,200,210
2984     200 PT(2)=2.0
2985     210 UNIV = RANDC(ISEED)
2986     IF(UNIV-6.6666667D-1)220,220,230
2987     220 PT(14)=4.0
2988     IF(ISW(4))70,80,70
2989     230 PT(16)=PNMS
2990     IF(ISW(4))100,70,100
2991     240 RETURN
2992     END
2993     *CMZ : 0.92/00 02/12/92 16.02.24 by Christian Zeitnitz
2994     *-- Author :
2995     SUBROUTINE CALP28
2996     #include "cbert.inc"
2997     #include "crandm.inc"
2998     *KEND.
2999     REAL *8 R
3000     C
3001     SAVE
3002     C
3003     R = RANDC(ISEED)
3004     IF(ISW(13))230,10,230
3005     10 IF(R-6.0D-1)20,20,120
3006     20 PT(4)=PNMS
3007     R = RANDC(ISEED)
3008     IF(ISW(4))30,90,30
3009     30 IF(R-3.3333333D-1)40,40,70
3010     40 PT(26)=5.0
3011     50 PT(28)=PNMS
3012     60 RETURN
3013     70 PT(26)=4.0
3014     80 PT(38)=2.0
3015     GO TO 60
3016     90 PT(2)=5.0
3017     PT(14)=2.0
3018     IF(R-3.3333333D-1)100,100,110
3019     100 PT(28)=PNMS
3020     GO TO 80
3021     110 PT(26)=4.0
3022     GO TO 60
3023     120 R = RANDC(ISEED)
3024     IF(ISW(4))130,180,130
3025     130 IF(R-6.6666667D-1)140,140,160
3026     140 PT(2)=4.0
3027     150 R = RANDC(ISEED)
3028     IF(R-6.6666667D-1)110,110,100
3029     160 PT(14)=2.0
3030     170 PT(4)=PNMS
3031     GO TO 150
3032     180 IF(R-6.6666667D-1)190,190,220
3033     190 PT(2)=4.0
3034     200 PT(14)=2.0
3035     210 R = RANDC(ISEED)
3036     IF(R-6.6666667D-1)70,70,40
3037     220 PT(2)=5.0
3038     PT(4)=PNMS
3039     GO TO 210
3040     230 IF(R-VALUE1)240,240,270
3041     240 PT(4)=PNMS
3042     IF(ISW(4))260,250,260
3043     250 PT(2)=5.0
3044     PT(14)=2.0
3045     GO TO 50
3046     260 PT(38)=2.0
3047     GO TO 40
3048     270 R = RANDC(ISEED)
3049     IF(ISW(4))280,310,280
3050     280 IF(R-3.3333333D-1)290,290,300
3051     290 PT(4)=PNMS
3052     GO TO 200
3053     300 PT(2)=4.0
3054     GOTO210
3055     310 IF(R-3.3333333D-1)320,320,330
3056     320 PT(2)=5.0
3057     GOTO170
3058     330 PT(14)=2.0
3059     GOTO140
3060     END
3061     *CMZ : 0.92/00 02/12/92 16.02.24 by Christian Zeitnitz
3062     *-- Author :
3063     SUBROUTINE CALPHA
3064     #include "cbert.inc"
3065     #include "crandm.inc"
3066     *KEND.
3067     SAVE
3068     C
3069     UNIV = RANDC(ISEED)
3070     IF(VALUE3)300,10,140
3071     10 IF(UNIV-VALUE1)20,20,120
3072     20 IF(ISW(11))40,30,40
3073     30 PT(2)=5.0
3074     PT(26)=2.0
3075     40 PT(4)=PNMS
3076     PM(4)=PNMS
3077     UNIV = RANDC(ISEED)
3078     IF(UNIV-VALUE2)50,50,70
3079     50 PT(14)=4.0
3080     60 RETURN
3081     70 IF(ISW(11))110,80,110
3082     80 PT(26)=1.0
3083     90 PT(14)=5.0
3084     100 PT(16)=PNMS
3085     GO TO 60
3086     110 PT(26)=2.0
3087     GO TO 100
3088     120 PT(2)=4.0
3089     IF(ISW(11))100,130,100
3090     130 PT(14)=5.0
3091     GO TO 110
3092     140 IF(UNIV-VALUE1)150,150,200
3093     150 PM(4)=PNMS
3094     IF(ISW(11))160,190,160
3095     160 PT(2)=5.0
3096     170 PT(16)=PNMS
3097     180 PT(4)=PNMS
3098     GO TO 60
3099     190 PT(14)=5.0
3100     PT(26)=2.0
3101     GO TO 170
3102     200 IF(UNIV-VALUE2)210,210,250
3103     210 PT(2)=4.0
3104     UNIV = RANDC(ISEED)
3105     IF(UNIV-VALUE3)240,240,220
3106     220 IF(ISW(11))50,230,50
3107     230 PT(26)=2.0
3108     GO TO 50
3109     240 IF(ISW(11))110,90,110
3110     250 PM(4)=PNMS
3111     PT(4)=PNMS
3112     UNIV = RANDC(ISEED)
3113     IF(UNIV-6.6666667D-1)260,260,280
3114     260 IF(ISW(11))230,270,230
3115     270 PT(2)=5.0
3116     GO TO 50
3117     280 IF(ISW(11))90,290,90
3118     290 PT(26)=2.0
3119     GO TO 160
3120     300 IF(UNIV-VALUE1)310,310,340
3121     310 PM(4)=PNMS
3122     PT(4)=PNMS
3123     UNIV = RANDC(ISEED)
3124     IF(VALUE3+1.0)330,320,330
3125     320 IF(UNIV-3.3333333D-1)90,90,230
3126     330 PT(2)=5.0
3127     IF(UNIV-3.3333333D-1)110,110,50
3128     340 IF(UNIV-VALUE2)350,350,380
3129     350 PT(2)=4.0
3130     UNIV = RANDC(ISEED)
3131     IF(VALUE3+1.0)370,360,370
3132     360 IF(UNIV-6.6666667D-1)50,50,110
3133     370 IF(UNIV-6.6666667D-1)230,230,90
3134     380 PM(4)=PNMS
3135     PT(4)=PNMS
3136     IF(VALUE3+1.0)390,160,390
3137     390 PT(14)=5.0
3138     GOTO110
3139     END
3140     *CMZ : 0.92/00 02/12/92 16.02.24 by Christian Zeitnitz
3141     *-- Author :
3142     SUBROUTINE CANGID
3143     #include "cbert.inc"
3144     #include "crandm.inc"
3145     *KEND.
3146     REAL*8 R,TESISO
3147     SAVE
3148     C
3149     C ******************************************************************
3150     C**** CALCULATES COS AND SIN THETA,SIN AND COS PHI **************
3151     C ******************************************************************
3152     ICURR = CURR(1)
3153     GO TO(10,10,30,30,30),ICURR
3154     C**** INCIDENT PARTICLE - NUCLEON
3155     10 IF(IT.EQ.21.OR.IT.EQ.22)GO TO 20
3156     C**** SINGLE PRODUCTION
3157     IF(RLKE.GT.3500.0D0) CALL CERROR('CANGID1$')
3158     IF(RLKE.LT.500.0D0)GO TO 70
3159     TESISO= 0.75D0
3160     IF(RLKE.LT.1000.0D0)GO TO 50
3161     TESISO= 0.5D0
3162     IF(RLKE.LT.1300.0D0)GO TO 50
3163     TESISO= 0.25D0
3164     IF(RLKE.LT.2500.0D0)GO TO 50
3165     GO TO 60
3166     C**** DOUBLE PRODUCTION
3167     20 IF(RLKE.GT.3500.0D0) CALL CERROR('CANGID2$')
3168     GO TO 60
3169     C**** INCIDENT PARTICLE-PION
3170     30 R = RANDC(ISEED)
3171     IF(RLKE.GT.2500.0D0) CALL CERROR('CANGID3$')
3172     CST= -0.9999995D0
3173     SNT= 0.003162D0
3174     IF(IT.NE.11)GO TO 40
3175     IF(R.LE.0.75D0)GO TO 70
3176     GO TO 80
3177     C**** (PI+)-(P),(PI-)-(N)
3178     C**** (PI0)-(N),(PI0)-(P)
3179     40 IF(IT.NE.12.AND.IT.NE.28) CALL CERROR('CANGID4$')
3180     IF(RLKE.LT.500.0D0)CST=-CST
3181     IF(R.LE.0.80D0)GO TO 70
3182     GO TO 80
3183     50 R = RANDC(ISEED)
3184     IF(R.LE.TESISO)GO TO 70
3185     C**** BACKWARD/FORWARD
3186     60 R = RANDC(ISEED)
3187     C**** TEST FOR DIRECTION
3188     CST= 0.9999995D0
3189     SNT= 0.003162D0
3190     IF(R.LE.0.5)GO TO 80
3191     CST= -0.9999995D0
3192     GO TO 80
3193     C**** ISOTROPIC
3194     70 CALL CAPOL1(CST,SNT)
3195     C**** CALCULATES COS,SIN PHI
3196     80 CALL CAAZIO(SOPC,SOPS)
3197     RETURN
3198     END
3199     *CMZ : 0.92/00 02/12/92 16.02.24 by Christian Zeitnitz
3200     *-- Author :
3201     SUBROUTINE CAAZIO(SINE,COSINE)
3202     C
3203     #include "crandm.inc"
3204     *KEND.
3205     REAL * 8 SINE,COSINE,R1,R2,R1SQ,R2SQ,SUM
3206     C
3207     10 R1 = RANDC(ISEED)
3208     R1SQ = R1 * R1
3209     C XSQ
3210     R2 = RANDC(ISEED)
3211     R2SQ = R2 * R2
3212     C YSQ
3213     SUM = R1SQ + R2SQ
3214     IF(SUM.GT.1.0) GO TO 10
3215     SUM = SUM * 0.5
3216     C (XSQ+YSQ)/2
3217     COSINE = (SUM-R1SQ) / SUM
3218     C (YSQ-XSQ)/(XSQ+YSQ)
3219     SINE = (R1*R2) / SUM
3220     C (2*X*Y)/(XSQ+YSQ)
3221     R1 = RANDC(ISEED)
3222     IF(R1.LT.0.5) GO TO 20
3223     SINE = -SINE
3224     20 RETURN
3225     END
3226     *CMZ : 1.01/04 10/06/93 14.43.37 by Christian Zeitnitz
3227     *-- Author : Christian Zeitnitz 21/05/92
3228     SUBROUTINE CB2LAB(ALPHA,BETA,GAM,U,V,W,ULAB,VLAB,WLAB)
3229     C***************************************************************
3230     C
3231     C convert direction cosines of paticles produced in BERT
3232     C into Lab system
3233     C
3234     C input: ALPHA,BETA,GAM : direction consine in BERT
3235     C u,v,w : direction cosines in Lab system of
3236     C the projectile
3237     C output:ulab,vlab,wlab : direction cosine in Lab system
3238     C
3239     C
3240     C**************************************************************
3241     C
3242     RT = SQRT(U*U + V*V)
3243     if(RT.EQ.0.0) THEN
3244     SINTH = 0.0
3245     COSTH = 1.0
3246     COSPHI = 1.0
3247     SINPHI = 0.0
3248     ELSE
3249     SINTH = RT
3250     COSTH = W
3251     COSPHI = U/RT
3252     SINPHI = V/RT
3253     ENDIF
3254     T1 = COSTH * ALPHA + SINTH * GAM
3255     ULAB = COSPHI * T1 - SINPHI * BETA
3256     VLAB = SINPHI * T1 + COSPHI * BETA
3257     WLAB = COSTH * GAM - SINTH * ALPHA
3258     C
3259     C U = COSPHI*COSTH* ALPHA -SINPHI* BETA +COSPHI*SINTH* GAMA
3260     C
3261     C V = SINPHI*COSTH* ALPHA +COSPHI* BETA +SINPHI*SINTH* GAMA
3262     C
3263     C W = -SINTH* ALPHA + 0. * BETA +COSTH* GAMA
3264     C ROTATION MATRIX
3265     RETURN
3266     END
3267     *CMZ : 0.92/04 11/12/92 12.04.27 by Christian Zeitnitz
3268     *-- Author :
3269     SUBROUTINE CBBBBB
3270     #include "cbert.inc"
3271     *KEND.
3272     SAVE
3273     C
3274     I=I2
3275     C COLLISION CUT-OFF ENERGY (PROTON)
3276     IF(I1)10,20,10
3277     10 I=I+3
3278     C COLLISION CUT-OFF ENERGY (NEUTRON)
3279     20 IF(KNOT-6)40,40,30
3280     30 IF(KNOT-12)50,50,40
3281     40 CLCFE=CFEPN(I)
3282     50 E(1)=WKRPN(I)*RCPMV+PM(1)
3283     C TOTAL ENERGY PARTICLE 1
3284     60 IF(IN)80,70,80
3285     70 CALLP1CLI
3286     GOTO90
3287     80 CALL P1CLC
3288     C P1OE1=CURRENT=MOMENT/TOTAL
3289     90 RETURN
3290     END
3291     *CMZ : 1.01/04 10/06/93 14.43.37 by Christian Zeitnitz
3292     *-- Author :
3293     SUBROUTINE CABERT(IBERT,FINPUT,NOPART,KIND,ERAY,ARAY,BRAY,GRAY)
3294     C*************************************************************************
3295     C
3296     C calculate collision of particle with nucleus
3297     C
3298     C input: Finput(1) = A of nucleus
3299     C Finput(2) = Z of nucleus
3300     C Finput(3) = Ekin of incident particle
3301     C Finput(4) = energy cut off used in intranuclear cascade default = 0
3302     C Finput(5) = No. of incident particles = 1.0
3303     C Finput(6) = Angular distance
3304     C Finput(7) = particle type a la CALOR + 1
3305     C Finput(8) = same as Finput(4)
3306     C
3307     C output:NOPART > 0 -> no. of particles generated
3308     C = 0 -> collision with no escaping particle
3309     C = -1 -> pseudo collision
3310     C KIND(1-NOPART) -> particle type
3311     C ERAY(1-NOPART) -> kinetic energy
3312     C A,B,GRAY(1-NOPART) -> direction cosine (x,y,z-axis)
3313     C incident particle with GRAY = 1 !!!
3314     C
3315     C*************************************************************************
3316     C
3317     DIMENSION FINPUT(*),KIND(*),ERAY(*),ARAY(*),BRAY(*),GRAY(*)
3318     C
3319     C A.C.3526(3410-44) CASCADE CALCULATION
3320     C
3321     #include "crandm.inc"
3322     #include "cjoint.inc"
3323     #include "cinout.inc"
3324     #include "cbert.inc"
3325     #include "crn.inc"
3326     #include "cmunpu.inc"
3327     #include "crun.inc"
3328     *KEND.
3329     REAL*8 DCLN(80) , DCIN(115) , PPAC(19) , POAC(19) , FMXSN(161),
3330     + FMXDN(130), FMXSP(117), PDCI(60) , PDCH(55) , DCHN(143) ,
3331     + DCHNA(36) , DCHNB(60) , PSPCL(158), PDPCL(130), SPCLN(158),
3332     + DPCLN(130), FSLN(176) , FRINN(161), DMIN(101) , PPSCL(117),
3333     + PNSCL(117), PMSCL(117), PNNSL(117), PCFSL(234), FRIPN(117),
3334     + PNMI(101) , PNFSL(234), PNEC(126) , PNNEC(126), PMXC(126) ,
3335     + PMEC(126) , PPEC(126) , PEC(176) , ECN(176) , PPDC(6426),
3336     + PMDD(6426), PMDX(6426), PNDD(6426)
3337     DIMENSION ICC(12)
3338     REAL * 8 ZERO,XINC
3339     EQUIVALENCE (TAPCRS(1),DCLN(1)) , (TAPCRS(81),DCIN(1)) ,
3340     + (TAPCRS(196),PPAC(1)) , (TAPCRS(215),POAC(1)) ,
3341     + (TAPCRS(234),FMXSN(1)) , (TAPCRS(395),FMXDN(1)) ,
3342     + (TAPCRS(525),FMXSP(1)) , (TAPCRS(642),PDCI(1)) ,
3343     + (TAPCRS(702),PDCH(1)) , (TAPCRS(757),DCHN(1)) ,
3344     + (TAPCRS(900),DCHNA(1)) , (TAPCRS(936),DCHNB(1)) ,
3345     + (TAPCRS(996),PSPCL(1)) , (TAPCRS(1154),PDPCL(1)),
3346     + (TAPCRS(1284),SPCLN(1)), (TAPCRS(1442),DPCLN(1)),
3347     + (TAPCRS(1572),FSLN(1)) , (TAPCRS(1748),FRINN(1)),
3348     + (TAPCRS(1909),DMIN(1)) , (TAPCRS(2010),PPSCL(1))
3349     EQUIVALENCE (TAPCRS(2127),PNSCL(1)), (TAPCRS(2244),PMSCL(1)),
3350     + (TAPCRS(2361),PNNSL(1)), (TAPCRS(2478),PCFSL(1)),
3351     + (TAPCRS(2712),FRIPN(1)), (TAPCRS(2829),PNMI(1)) ,
3352     + (TAPCRS(2930),PNFSL(1)), (TAPCRS(3164),PNEC(1)) ,
3353     + (TAPCRS(3290),PNNEC(1)), (TAPCRS(3416),PMXC(1)) ,
3354     + (TAPCRS(3542),PMEC(1)) , (TAPCRS(3668),PPEC(1)) ,
3355     + (TAPCRS(3794),PEC(1)) , (TAPCRS(3970),ECN(1)) ,
3356     + (TAPCRS(4146),PPDC(1)) , (TAPCRS(10572),PMDD(1)),
3357     + (TAPCRS(16998),PMDX(1)), (TAPCRS(23424),PNDD(1))
3358     C
3359     SAVE
3360     AMASNO =DBLE(FINPUT(1))
3361     ZEE = DBLE(FINPUT(2))
3362     EINC = DBLE(FINPUT(3))
3363     CTOFE = DBLE(FINPUT(4))
3364     CASESN = DBLE(FINPUT(5))
3365     ANDIT = DBLE(FINPUT(6))
3366     CTOFEN = DBLE(FINPUT(8))
3367     PRTIN = FINPUT(7)
3368     KE = 0
3369     IF(IBERT)40,10,40
3370     C CHANGED SEPT.1,1987
3371     10 CONTINUE
3372     CZ BERT dataset already read by CRBERT called by CALINI 19. june 92
3373     NRT = 0
3374     SF =1.
3375     C SF=1.0 AT PRESENT
3376     LN=2
3377     C NOR=RECORD NUMBER
3378     C NRT=NUMBER OF FILES
3379     RANDI(1)=16896
3380     PNMS=.708D13
3381     C PI+ OR - MASS IN RECIP. CM
3382     DNCMS=4.758D13
3383     SQNM=DNCMS*DNCMS
3384     C NUCLEON MASS SQUARED
3385     C NUCLEON MASS IN RECIP. CM
3386     RCPMV=.50613D11
3387     C RECIPROCAL CM PER MV
3388     POMS=.684D13
3389     C PI0 MASS IN RECIP. CM
3390     IFIVE=5
3391     ISIX=6
3392     ZERO=0.0
3393     NE=0
3394     BEGRU = 0.0
3395     DO 20 I=1,3
3396     20 XI(I)=0.0
3397     DO 30 I=1,19
3398     POAC(I)=POAC(I)+POAC(I)
3399     30 PPAC(I)=PPAC(I)/SF
3400     C P0AC(19),PPAC(19)
3401     C SF IS A SCALE FACTOR SUBJECT TO CHANGE
3402     C ANDIT
3403     C ISOBAR ANGULAR DISTRIBUTION 0,50 PERCENT ISOTROPIC 50
3404     C PERCENT FORWARD-BACKWARD-1,ALL ISOTROPIC-2,ALL FORWARD-BACKWARD
3405     C =0,ALL OF WORD IN CRDET TO BE CONSIDERED. NOT 0, ONLY PART. INPT
3406     C ESCAPING PARTICLE STORAGE ESPS
3407     C NUMBER OF FORBIDDEN COLLISIONS FOR NEUTRONS FCN
3408     C NUMBER OF FORBIDDEN COLLISIONS FOR PROTONS FCP
3409     C PARTICLE WITH VELOCITY LESS THAN CRITERION PLVC
3410     C PARTICLE WITH VELOCITY GREATER THAN CRITERION PGVC
3411     40 DO 50 I=1,60
3412     IPEC(I)=0
3413     50 CONTINUE
3414     I18=0
3415     I19=0
3416     DO 60 I=1,2114
3417     ESPS(I)=0.0
3418     60 CONTINUE
3419     DO 70 I= 4515,4849
3420     ESPS(I)=0.D0
3421     70 CONTINUE
3422     DO 80 I=1,10
3423     COUNT(I)=0.0D0
3424     80 CONTINUE
3425     DO 90 I=1,12
3426     ICC(I)=0
3427     90 CONTINUE
3428     SPACE(13)=EINC
3429     NO=AMASNO
3430     NMAS=1+(NO-1)*10
3431     DO 100 I=1,10
3432     OUT(I)=CRSC(NMAS)
3433     NMAS=NMAS+1
3434     100 CONTINUE
3435     CALL ROUT1
3436     IF(PRTIN.GT.4) THEN
3437     CALL CERROR(' BERT called for muon$')
3438     NOPART=-1
3439     RETURN
3440     ENDIF
3441     NO= PRTIN + 1.
3442     IF(SPACE(4).GT.100.0) SPACE(4)=100.0
3443     VALUE1=EINC+SPACE(4)
3444     IF(NO.LT.3) GOTO 2540
3445     IF(NO.EQ.4) THEN
3446     CALL CERROR(' BERT called for pi0$')
3447     NOPART = -1
3448     RETURN
3449     ENDIF
3450     C ----- Charged pions ------
3451     CALL ROUT2(PPAC(1))
3452     IF(I1.EQ.0) THEN
3453     CALL CERROR(' BERT Epion > 2.5 GeV$')
3454     RETURN
3455     ENDIF
3456     IV=2
3457     IF(NO.EQ.5) IV=0
3458     CALL CALXYI(1,14,30)
3459     IP=1
3460     110 CALL ROUT3
3461     IF(BEGRU.EQ.0.0) GOTO 2460
3462     C IF BEGRU=0, LAST RUN COMPLETED--BG6A
3463     KK=I1
3464     XINC=XI(1)
3465     C XINC=X-COORDINATE INC.PART.
3466     CALL ROUT4
3467     IF(I1.LT.0.0) GOTO 2820
3468     I1=KK
3469     120 IF(IN.NE.0) GOTO 2200
3470     IF(EX.GT.D(2)) GOTO 650
3471     130 CURR(2)=OUT(13)
3472     WKRPN(3)=CURR(2)
3473     C K.E. WITH RESPECT TOPROTONS RG.3
3474     WKRPN(6)=OUT(16)
3475     C K.E. WITH RESPECT TONEUTRONS RG.3
3476     IFCA=0
3477     140 CALL CBG6CA(3,3)
3478     150 IFCC=0
3479     CALL CABRAN(6)
3480     KNOT=NOT
3481     IF(NOT.EQ.4) GOTO 380
3482     CALL CABG6C(ISW(11))
3483     VALUE1=RLKE
3484     IF(IN.NE.0) GOTO 1980
3485     IF(NOT.EQ.4) GOTO 380
3486     IF(NOT.LT.4) THEN
3487     ANY=SPACE(NOT+13)
3488     GOTO 170
3489     ELSE
3490     ANY=S(NOT-4)
3491     ENDIF
3492     160 IF(NOT-5)170,600,630
3493     C IT=1-6 PIPPS(20051),BG129(21011),PIMPD(21004),PIPND(20644)
3494     170 CALL ROUT5(PPEC(1),PMEC(1),PMXC(1))
3495     C PPEC(126),PMEC(126),PMXC(126)
3496     180 IF(CLSM-2.0)880 ,740,190
3497     C (PIM-P)EXCHANGE SCATTERING CRS.
3498     190 IF(VALUE1.GT.VALUE2) GOTO 300
3499     200 IF(ISW(1).NE.0) GOTO 240
3500     IFC=IFCC+1
3501     IF(IN.NE.0) GOTO 1990
3502     210 C(3)=0.0
3503     220 C(1)=CURR(4)
3504     C(2)=CURR(5)
3505     C(3)=C(3)+CURR(6)+EX+D(1)
3506     230 CONTINUE
3507     GOTO(960 ,1230,1240,1300,1310,1410,1420,1450,1460,1420,1470,1830,1
3508     +840 ,1460,1850,1860,1870,1880,1960,1930,1940,1950,2360,2420,2430,2
3509     +440 ,1420,2450),IT
3510     240 IF(ISW(2))280,250,280
3511     250 IFC=2+IFCC
3512     260 IF(IN)2000,270,2000
3513     270 C(3)=D(2)+D(3)
3514     GOTO 220
3515     280 IFC=3+IFCC
3516     IF(IN)480,290,480
3517     290 C(3)=D(2)+D(3)+D(4)+D(5)
3518     GOTO 220
3519     C IFC(1-3),BG6C(1502),BG6F(3243),BG6K(4055) COLLISION
3520     300 CALL SIGNEX
3521     310 IF(ISW(1))320,120,320
3522     320 IF(IN)2010,330,2010
3523     330 IF(EX-D(6))130,130,340
3524     340 IF(ISW(2))360,350,360
3525     350 IPEC(7)=IPEC(7)+1
3526     C NO. OF ESCAPED PARTICLES ON REGION 2
3527     GOTO 110
3528     360 IPEC(11)=IPEC(11)+1
3529     C NO. OF ESCAPED PARTICES ON REGION 1
3530     GOTO 110
3531     370 I3=1
3532     GOTO 390
3533     380 I3=-1
3534     390 CALL ROUT6
3535     IF(I3)400 ,410,450
3536     400 CALL CERROR(' BERT CURR(1) < 3 or > 5$')
3537     NOPART=-1
3538     RETURN
3539     410 CALL ROUT6A
3540     IF(CLSM-2.0)910 ,940 ,2180
3541     420 IFCA=1
3542     430 IF(ISW(1))440,210,440
3543     440 IF(ISW(2))290,270,290
3544     C NON-DEUTERON ABSORPTION
3545     450 CALL ROUT7
3546     IF(I3)400 ,460,460
3547     460 CALL ROUT7A
3548     I3=I3
3549     GOTO(480,470 ,590,540,210,290,500,510,270),I3
3550     470 CALL CERROR(' BERT PWD or NWD < 7$')
3551     NOPART = -1
3552     RETURN
3553     480 VALUE1=EX+D(4)+D(5)
3554     490 IF(CURR(10)-2.0)500,510,510
3555     500 C(1)=VALUE1*CURR(7)+CURR(4)
3556     C(2)=VALUE1*CURR(8)+CURR(5)
3557     C(3)=VALUE1*CURR(9)+CURR(6)
3558     GO TO 230
3559     510 VALUE1=VALUE1+D(3)
3560     GO TO 520
3561     520 IF(CURR(10)-2.0)500,500,530
3562     530 VALUE1=VALUE1+D(2)
3563     GO TO 500
3564     540 IF(INC)550,570,550
3565     550 C(3)=D(2)
3566     IF(ISW(3))560,220,560
3567     560 C(3)=C(3)+D(3)+D(4)
3568     GO TO 220
3569     570 IF(ISW(3))580,520,580
3570     580 VALUE1=EX+D(4)
3571     GO TO 490
3572     590 VALUE1=EX
3573     IF(INC)270,490,270
3574     600 IF(RLKE.GT.2500.0) THEN
3575     CALL CERROR(' BERT RLKE > 2.5 GeV$')
3576     RLKE = 2500.0
3577     ENDIF
3578     IF(RLKE-180.0)610,610,620
3579     610 CALL SIGNEX
3580     IF(CLSM-2.0)850 ,760,310
3581     620 VALUE1=VALUE1-180.0
3582     CALL CRJAB(1,PPSCL(1))
3583     C PPSCL(117)
3584     C (PIP-P)SINGLE PROD. CRS. LOW ENERGY
3585     GO TO 180
3586     630 IF(RLKE.GT.2500.0) THEN
3587     CALL CERROR(' BERT RLKE > 2.5 GeV (2)$')
3588     RLKE = 2500.0
3589     ENDIF
3590     IF(RLKE-180.0)610,610,640
3591     640 VALUE1=VALUE1-180.0
3592     CALL CRJAB(1,PMSCL(1))
3593     C PMSCL(117)
3594     C (PIM-P)SINGLE PROD. CRS. LOW ENERGY
3595     GO TO 180
3596     650 IF(D(3))670,660,670
3597     660 IPEC(2)=IPEC(2)+1
3598     C NO. OF PARTICLES INCIDENT ON REGION 3 ESCAPING
3599     GO TO 110
3600     670 ISW(1)=1
3601     CALL SPAC32(31)
3602     680 IF(IN)2020,690 ,2020
3603     690 IF(EX-D(3))710,710,810
3604     700 IF(IN)720,710,720
3605     710 CURR(2)=OUT(14)
3606     WKRPN(2)=CURR(2)
3607     WKRPN(5)=OUT(17)
3608     C K.E. FOR PROTONS AND NEUTRONS REGION 2
3609     720 CALL CBG6CA(2,2)
3610     GO TO 150
3611     730 IV=-1
3612     GO TO 750
3613     740 IV=0
3614     750 CALL ROUT8
3615     I3=I3
3616     GOTO(760,2030,220,580),I3
3617     760 IF(ISW(3))770,680,770
3618     770 IF(EX-D(5))700 ,700 ,780
3619     780 IF(IN)2040,790 ,2040
3620     790 CALL SPAC32(32)
3621     800 IF(EX-D(6))130,130,360
3622     810 IF(D(4))840 ,820 ,840
3623     820 CALL SPAC32(32)
3624     830 IF(EX-D(6))130,130,350
3625     840 ISW(2)=1
3626     ISW(3)=1
3627     CALL SPAC32(30)
3628     850 IF(IN)2050,860 ,2050
3629     860 CALL ROUT10
3630     IF(I3)770,870 ,870
3631     870 CALL CBG6CA(1,1)
3632     GO TO 150
3633     880 IF(VALUE1-VALUE2)890 ,890 ,900
3634     890 IFC=9+IFCC
3635     IF(IN)2060,270,2060
3636     900 CALL SIGNEX
3637     IF(IN)2050,860 ,2050
3638     910 IF(IN)930 ,920 ,930
3639     920 IFCA=6
3640     GO TO 270
3641     930 IFCA=9*IABS(I6-2)+13*(I6-1)*(3-I6)
3642     GOTO2060
3643     940 IF(IN)2070,950 ,2070
3644     950 IFCA=7
3645     GOTO550
3646     960 I3=1
3647     GOTO1000
3648     970 I3=4
3649     GOTO1000
3650     980 I3=2
3651     GOTO1000
3652     990 I3=3
3653     1000 CALLROUT11(PPDC(1))
3654     C PPDCL(378)
3655     I3=I3
3656     GOTO(1180,1270,1400,1010),I3
3657     1010 CST=CRDT(2)-DABS(SNT*(CRDT(2)-CRDT(1)))
3658     1020 SNT=DSQRT(1.0-CST*CST)
3659     1030 CALL ROUT12
3660     IF(I3)1040,1050,1110
3661     1040 CALL CERROR(' BERT COM < -5E-6$')
3662     NOPART=-1
3663     RETURN
3664     1050 IF(EFRN-VALUE1)1150,1060,1060
3665     1060 FCN=FCN+1.0
3666     1070 IV=-1
3667     GOTO1090
3668     1080 IV=0
3669     1090 I1=0
3670     CALLROUT13
3671     IF(I3)460,1100,410
3672     1100 IFC=IFC
3673     GOTO(120,830 ,800 ,2840,3210,3270,680,770,850 ,3150,3250,3230,2200
3674     + ,2010,2010,2080,2090,2100,2020,770,2200,2010,2010,2050,2200,20
3675     +10 ,2010,2020,2110,2050),IFC
3676     1110 IF(EFRP-VALUE1)1150,1120,1120
3677     1120 FCP=FCP+1.0
3678     GOTO1070
3679     1130 I3=0
3680     GOTO1160
3681     1140 I3=-1
3682     GOTO1160
3683     1150 I3=1
3684     1160 CALLROUT14
3685     I3=I3
3686     GOTO(1110,1050,1170,3560,2120),I3
3687     1170 CALL CERROR(' BERT I3=3$')
3688     NOPART=-1
3689     RETURN
3690     1180 I3=1
3691     GOTO1210
3692     1190 I3=3
3693     GOTO1210
3694     1200 I3=4
3695     1210 CALLROUT15(PPDC(1))
3696     C HPPDCI(45),PPDCI(170)
3697     I3=I3
3698     GOTO(1250,1340,1020,1220,1260,1390),I3
3699     1220 CALL CERROR(' BERT I3=4$')
3700     C SNN(RLKE GTE 1000) DCINTP(RLKE GTE CRS.SECT.VALUES)
3701     NOPART=-1
3702     RETURN
3703     1230 PT(2)=5.0
3704     IK=IT
3705     C BG129 (PIM-N)
3706     PT(14)=2.0
3707     GOTO980
3708     1240 PT(2)=5.0
3709     C PIPNX DIR. SCAT.
3710     PT(14)=1.0
3711     IK=IT
3712     GOTO 980
3713     1250 I3=1
3714     GOTO1280
3715     1260 I3=2
3716     GOTO1280
3717     1270 I3=3
3718     1280 CALLROUT16(PMDD(1))
3719     C HPMDDI(45),PMDDI(170),PMDDL(378)
3720     1290 IF(I3)1020,1190,1020
3721     1300 PT(2)=3.0
3722     PT(14)=2.0
3723     IK=3
3724     GO TO 980
3725     1310 PT(14)=2.0
3726     1320 IK=IT
3727     1330 PT(2)=4.0
3728     PM(3)=POMS
3729     C PI 0 MASS/CM
3730     GO TO 990
3731     1340 IF(IK-23)1350,2390,1350
3732     1350 I3=1
3733     GO TO 1380
3734     1360 I3=2
3735     GO TO 1380
3736     1370 I3=3
3737     1380 CALL ROUT16(PMDX(1))
3738     C HPMDXI(45),PMDXI(170),PMDXL(378)
3739     GO TO 1290
3740     1390 IF(IK-23)1360,2370,1360
3741     1400 IF(IK-23)1370,2380,1370
3742     C (PIM-P)XCH.
3743     1410 PT(14)=1.0
3744     GO TO 1320
3745     1420 PT(2)=1.0
3746     C PIM+(PP) ABS
3747     C IT=10,PIP+(NN) ABS
3748     1430 PT(14)=2.0
3749     1440 CALL CAPOL1(CST,SNT)
3750     GO TO 1030
3751     1450 PT(2)=2.0
3752     C PIN+(NN) ABS
3753     GO TO 1430
3754     1460 PT(2)=1.0
3755     C PIN+(PP) ABS ALS0 PI+ ABS
3756     PT(14)=1.0
3757     GO TO 1440
3758     1470 ISW(9)=0
3759     ISW(10)=0
3760     1480 I3=0
3761     GO TO 1500
3762     1490 I3=-1
3763     1500 CALL ROUT17(FRIPN(1),PNMI(1),FMXSP(1),PCFSL(1),PNFSL(1))
3764     C FRIPN(117),PNMI(101),FMXSP(117),PCFSL(234),PNFSL(234)
3765     IF(I3) 1510,1640,1520
3766     1510 CALL CERROR(' BERT I3 < 0$')
3767     C COLL(COM LT -5.0E-6) ECPL(ERROR IN CURR ,STRKP,PT(26),
3768     C PT(2),PT(14) OR PT(37)) ISW10=0
3769     NOPART=-1
3770     RETURN
3771     1520 K=3
3772     1530 IF(PT(K-1)-1.0)1650,1540,1650
3773     1540 IF(PT(K))1560,1560,1550
3774     1550 IF(PT(K)-EFRP)1560,1560,1580
3775     1560 FCP=FCP+1.0
3776     C NO. FORBIDDEN COLLISIONS INVOLVING PROTONS
3777     1570 PM(4)=DNCMS
3778     GO TO 1080
3779     1580 M=PT(K-1)
3780     IF(PT(K)-ECO (M)) 1590,1590,1600
3781     1590 PT(K)=0.0
3782     PNBC(M)=PNBC(M)+1.0
3783     1600 IF(COL(15)-1.0)1640,1740,1610
3784     1610 IF(COL(15)-3.0)1720,1710,1620
3785     1620 IF(COL(15)-5.0)1730,1780,1630
3786     1630 CALL CERROR(' BERT COL(15)>5$')
3787     NOPART=-1
3788     RETURN
3789     1640 CALL COLLM(0)
3790     IF(PT(38)) 1700,1690,1700
3791     1650 IF(PT(K-1)-2.0) 1810,1660,1810
3792     1660 IF(PT(K)) 1680,1680,1670
3793     1670 IF(PT(K)-EFRN) 1680,1680,1580
3794     1680 FCN = FCN+1.0
3795     GO TO 1570
3796     1690 I3=1
3797     GO TO 1750
3798     1700 I3=2
3799     GO TO 1750
3800     1710 I3=4
3801     GO TO 1750
3802     1720 I3=5
3803     GO TO 1750
3804     1730 I3=6
3805     GO TO 1750
3806     1740 I3=3
3807     1750 CALL ROUT18
3808     I3=I3
3809     K=IV
3810     GO TO (1530,1760,1600,1900,1770),I3
3811     1760 CALL CERROR(' BERT PT(K-1) < 3$')
3812     NOPART=-1
3813     RETURN
3814     1770 I18=I18+1
3815     GO TO 1570
3816     1780 CALL ROUT19
3817     IF(I3)1790,1900,1800
3818     1790 CALL CERROR(' BERT PT(K-1)<3, >6 K<27$')
3819     NOPART=-1
3820     RETURN
3821     1800 I19=I19+1
3822     GO TO 1570
3823     1810 IF(COL(15)-1.0)1640,1820,1820
3824     1820 CALL CERROR(' BERT COL(15) >=1$')
3825     NOPART=-1
3826     RETURN
3827     1830 I3=2
3828     GO TO 1910
3829     1840 I3=3
3830     GO TO 1910
3831     1850 I3=4
3832     GOTO1910
3833     1860 I3=5
3834     GOTO1910
3835     1870 I3=6
3836     GOTO1910
3837     1880 I3=7
3838     GOTO1910
3839     1890 I3=8
3840     GOTO1910
3841     1900 I3=1
3842     1910 CALL ROUT20(DCIN(1),DCLN(1),DCHN(1),PDCI(1),PDCH(1))
3843     C DCIN(115),DCLN(80),DCHN(64),PDCI(52),PDCH(64)
3844     I3=I3
3845     GOTO(1920,1140,1490,1430,1200,1020,1440,1030),I3
3846     1920 CALL CERROR(' BERT RLKE>3.5GeV$')
3847     NOPART=-1
3848     RETURN
3849     1930 I3=2
3850     GOTO1970
3851     1940 I3=3
3852     GOTO1970
3853     1950 I3=4
3854     GOTO1970
3855     1960 I3=1
3856     1970 CALL ROUT21(FRINN(1),DMIN(1), FMXSN(1),FMXDN(1),FSLN(1))
3857     C FRINN(161),DMIN(101),FMXSN(161),FMXDN(130),FSLN(176)
3858     GOTO1500
3859     1980 IV=2
3860     GOTO2210
3861     1990 IV=3
3862     GOTO2210
3863     2000 IV=4
3864     GOTO2210
3865     2010 IV=5
3866     GOTO2210
3867     2020 IV=6
3868     GOTO2210
3869     2030 IV=7
3870     GOTO2210
3871     2040 IV=8
3872     GOTO2210
3873     2050 IV=9
3874     GOTO2210
3875     2060 IV=10
3876     GOTO2210
3877     2070 IV=11
3878     GOTO2210
3879     2080 IV=12
3880     GOTO2210
3881     2090 IV=13
3882     GOTO2210
3883     2100 IV=14
3884     GOTO2210
3885     2110 IV=15
3886     GOTO2210
3887     2120 IV=16
3888     GOTO2210
3889     2130 IV=17
3890     GOTO2210
3891     2140 IV=18
3892     GOTO2210
3893     2150 IV=19
3894     GOTO2210
3895     2160 IV=20
3896     GOTO2210
3897     2170 IV=21
3898     GOTO2210
3899     2180 IV=22
3900     GOTO2210
3901     2190 IV=23
3902     GOTO2210
3903     2200 IV=1
3904     2210 CALLROUT22(PPAC(1),POAC(1),PNEC(1),PMXC(1),PNNEC(1))
3905     C PPAC(19),POAC(19),PNEC(126),PMXC(126),PNNEC(126)
3906     IV=IV
3907     IF(I1)2820,2220,2220
3908     2220 GOTO(2350,2230,770,1130,2890,500,520,490,3400,3010,2990,3310,720,1
3909     +60 ,870 ,420,480,580,2900,140,2330,3020,2240),IV
3910     2230 CALL CERROR(' BERT COM>3500,ESPS(1)>=30. COM>2500$')
3911     NOPART=-1
3912     RETURN
3913     2240 CALL CERROR(' BERT IV > 22$')
3914     NOPART=-1
3915     RETURN
3916     2250 XABS=1.0
3917     VALUE1 = RANDC(ISEED)
3918     IF(VALUE1-PPNDA)2260,450,450
3919     C PROB. PIN-DEUT ABS
3920     2260 IT=27
3921     C BG117(20040) PI0 ABS
3922     MED=MED
3923     ABSEC=-HVP(MED)
3924     GO TO 370
3925     2270 IF(RLKE-2500.0)2290,2290,2280
3926     2280 CALL CERROR(' BERT RLKE > 2.5GeV$')
3927     RLKE=2500.0
3928     2290 IF(RLKE-180.0) 2320,2320,2300
3929     2300 IF(NOT-6) 2310,2310,2340
3930     2310 VALUE1=RLKE-180.0
3931     CALL CRJAB(1,PNSCL(1))
3932     C PNSCL(117)
3933     C (PIN-P)SINGLE PRODUCTION CRS. LOW EN.
3934     GO TO 3020
3935     2320 IF(CLSM-2.0)3550,3510,3040
3936     2330 IF(NOT-6)2190,2270,2270
3937     2340 VALUE1=RLKE-180.0
3938     CALL CRJAB(1,PNNSL(1))
3939     C PNNSL(117)
3940     C (PIN-N)SINGLE PROD. CRS. LOW EN.
3941     GOTO3020
3942     2350 ISW(11)=0
3943     GOTO2130
3944     2360 PT(14)=1.0
3945     GO TO 1320
3946     2370 I3=2
3947     GO TO 2400
3948     2380 I3=3
3949     GO TO 2400
3950     2390 I3=1
3951     2400 CALL ROUT16(PNDD(1))
3952     C HPNDDI(45),PNDDI(170),PNDDL(378)
3953     C (PIN-P)DRCT. CROSS SECTION INT. EN.
3954     C (PIN-P)DRCT DIFF. CRS. SEC. LOW ENERGY
3955     2410 GO TO 1290
3956     2420 PT(2)=3.0
3957     PT(14)=2.0
3958     IK=IT
3959     GO TO 980
3960     2430 PT(14)=2.0
3961     IK=23
3962     GO TO 1330
3963     2440 PT(2)=5.0
3964     GO TO 970
3965     2450 ISW(9)=2
3966     GO TO 1890
3967     2460 ITOTE =IPEC(2)+IPEC(7)+IPEC(11)
3968     IF(ITOTE-1)2500,2480,2470
3969     2470 CALL CERROR('BERT1$')
3970     2480 NOPART = -1
3971     2490 CONTINUE
3972     RETURN
3973     2500 NOPART = ESPS(1)
3974     IF(NOPART-60)2520,2520,2510
3975     2510 WRITE(IO ,10000) NOPART
3976     10000 FORMAT(' BERT : NOPART HAS EXCEEDED THE MAXIMUM = ',I6)
3977     NOPART = 60
3978     2520 CONTINUE
3979     DO 2530 NDEX = 1,NOPART
3980     KLMN = 8*(NDEX-1) + 1
3981     KIND(NDEX) = ESPS(KLMN+1)-1.
3982     ERAY(NDEX) = ESPS(KLMN+2)
3983     ARAY(NDEX) = ESPS(KLMN+3)
3984     BRAY(NDEX) = ESPS(KLMN+4)
3985     2530 GRAY(NDEX) = ESPS(KLMN+5)
3986     GO TO 2490
3987     2540 VALUE2=EINC+SPACE(12)
3988     IF(VALUE1-160.0)2550,2550,2570
3989     2550 SPACE(33)=1.4D-24
3990     C NO PRODUCTION POSSIBLE
3991     FMAX(2)=1.4D-24
3992     SPACE(34)=0.46D-24
3993     FMAX(1)=0.46D-24
3994     DO2560 I=9,12
3995     2560 S(I)=0.0
3996     C EINC+50.0 IS LESS THAN 160.0
3997     GOTO2740
3998     2570 CALLCBOVER(VALUE2,DNCMS,ANS)
3999     C NUCLEON MASS=CONSTANT ANS=P1/E1
4000     IF(VALUE1-560.0)2580,2580,2660
4001     2580 S(11)=0.0
4002     S(12)=0.0
4003     C SINGLE PRODUCTION POSSIBLE--S(11),S(12) DOUBLE PROD.
4004     IF(VALUE1-400.0)2600,2590,2590
4005     2590 S(9)=22.6D-27*ANS
4006     S(10)=14.0D-27*ANS
4007     SPACE(44)=56.0D-27
4008     SPACE(45)=27.0D-27*ANS
4009     GOTO2650
4010     2600 IF(VALUE1-300.0)2620,2610,2610
4011     2610 S(9)=20.0D-27*ANS
4012     S(10)=14.0D-27*ANS
4013     SPACE(44)=0.106D-24
4014     SPACE(45)=36.0D-27*ANS
4015     GOTO2650
4016     2620 IF(VALUE1-200.0)2640,2630,2630
4017     2630 S(9)=11.4D-27*ANS
4018     S(10)=11.2D-27*ANS
4019     SPACE(44)=0.313D-24
4020     SPACE(45)=0.103D-24
4021     GOTO2650
4022     2640 S(9)=1.95D-27*ANS
4023     S(10)=1.7D-27*ANS
4024     SPACE(44)=0.52D-24
4025     SPACE(45)=0.176D-24
4026     2650 SPACE(33)=SPACE(44)
4027     SPACE(34)=SPACE(45)
4028     GOTO2740
4029     2660 IF(VALUE1-3600.0)2680,2680,2670
4030     2670 CALL CERROR(' BERT VALUE1 > 3.6GeV$')
4031     NOPART=-1
4032     RETURN
4033     2680 S(9)=22.6D-27*ANS
4034     C DOUBLE PRODUCTION POSSIBLE
4035     S(10)=14.0D-27*ANS
4036     IF(VALUE1-800.0)2690,2700,2700
4037     2690 S(11)=1.9D-27*ANS
4038     S(12)=9.0D-27*ANS
4039     SPACE(46)=38.4D-27*ANS
4040     SPACE(47)=27.2D-27*ANS
4041     GOTO2730
4042     2700 IF(VALUE1-1680.0)2710,2720,2720
4043     2710 S(11)=10.8D-27*ANS
4044     S(12)=17.4D-27*ANS
4045     SPACE(46)=33.0D-27*ANS
4046     SPACE(47)=27.2D-27*ANS
4047     GOTO2730
4048     2720 SPACE(46)=25.0D-27*ANS
4049     SPACE(47)=26.5D-27*ANS
4050     S(10)=13.6D-27*ANS
4051     S(11)=18.0D-27*ANS
4052     S(12)=23.6D-27*ANS
4053     2730 SPACE(33)=SPACE(46)
4054     SPACE(34)=SPACE(47)
4055     2740 GO TO (2750,3630), NO
4056     2750 IV=1
4057     2760 CALL CALXYI(9,33,41)
4058     IP=2
4059     2770 IF(NO-2)2790,2780,2780
4060     2780 ISW(4)=0
4061     GO TO 2800
4062     2790 ISW(4)=1
4063     2800 CALL UNDIS
4064     IF(BEGRU) 2810,2460,2810
4065     2810 XABS=0.0
4066     XINC=XI(1)
4067     C XINC=X-COORDINATE INC.PART.
4068     INC=1
4069     C 0 IF PARTICLE CASCADE
4070     CURR(1)=NO
4071     CURR(3)=DNCMS
4072     C NUCLEON MASS/CM
4073     CALL CALGEO
4074     IF(I1) 2820,2830,2830
4075     2820 CALL CERROR(' BERT error in GEOM$')
4076     NOPART=-1
4077     RETURN
4078     2830 CALL PARTIN
4079     CALL SPAC32(43)
4080     2840 IF(EX-D(2))2850,2850,3120
4081     2850 WKRPN(3)=OUT(13)
4082     WKRPN(6)=OUT(16)
4083     CURR(2)=WKRPN(6)
4084     IF(ISW(4))2860,2870,2860
4085     2860 CURR(2)=WKRPN(3)
4086     C K.E.WITH RESPECT TO NEUTRONS(PROTONS), RG.3
4087     2870 CALL CBG6CA(3,0)
4088     IFCA=3
4089     2880 IFCC=3
4090     2890 KA=6
4091     2900 CALL CABRAN(KA)
4092     KNOT=NOT+6
4093     IF(IN)2920,2920,2910
4094     2910 KNOT=KNOT+6
4095     2920 IF(KNOT-17)2930,2250,2930
4096     2930 CALL CABG6C(ISW(4))
4097     IF(RLKE)2940,2940,2950
4098     2940 CALL CERROR(' BERT RLKE <= 0.0$')
4099     NOPART=-1
4100     RETURN
4101     2950 VALUE1=RLKE
4102     IF(IN) 2140,2960,2140
4103     2960 IF(NOT-5) 2970,3400,3400
4104     2970 IF(NOT-2)2980,3000,3310
4105     2980 ANY=SPACE(33)
4106     2990 CALL CRJAB(1,ECN(1))
4107     C ECN(176)
4108     C (N-P)ELASTIC CRS. SCATTERING
4109     GOTO3020
4110     3000 ANY=SPACE(34)
4111     3010 CALL CRJAB(1,PEC(1))
4112     C PEC(176)
4113     C (P-P)ELASTIC SCAT. CRS.
4114     3020 IF(CLSM-2.0)3540,3500,3030
4115     3030 IF(VALUE1-VALUE2)200,200,3040
4116     3040 CALLSIGNEX
4117     IF(ISW(1))3070,3050,3070
4118     3050 IF(IN)3060 ,2840,3060
4119     3060 IF(CURR(1)-2.0)2200,2200,2150
4120     3070 IF(IN)2010,3080,2010
4121     3080 IF(EX-D(6))2850,2850,3090
4122     3090 IF(ISW(2))3110,3100,3110
4123     3100 IPEC(7)=IPEC(7)+1
4124     C NO. OF ESCAPED PARTICLES ON RG.2
4125     GOTO 2770
4126     3110 IPEC(11)=IPEC(11)+1
4127     GOTO 2770
4128     C NO. OF PARTICLES ESCAPED ON RG.1
4129     3120 IF(D(3))3140,3130,3140
4130     3130 IPEC(2)=IPEC(2)+1
4131     GOTO 2770
4132     C NO. OF PARTICLES INCIDENT ON RG.3 ESCAPING
4133     3140 ISW(1)=1
4134     CALL SPAC32(42)
4135     3150 IF(EX-D(3))3160,3160,3190
4136     3160 WKRPN(2)=OUT(14)
4137     WKRPN(5)=OUT(17)
4138     CURR(2)=WKRPN(5)
4139     IF(ISW(4))3170,3180,3170
4140     3170 CURR(2)=WKRPN(2)
4141     C K.E.WITH RESPECT TO NEUTRONS(PROTONS) RG.2
4142     3180 CALL CBG6CA(2,0)
4143     GOTO2880
4144     3190 IF(D(4))3220,3200,3220
4145     3200 CALL SPAC32(43)
4146     3210 IF(EX-D(6))2850,2850,3100
4147     3220 ISW(2)=1
4148     ISW(3)=1
4149     CALL SPAC32(41)
4150     3230 IF(EX-D(4))3280,3280,3240
4151     3240 CALL SPAC32(42)
4152     3250 IF(EX-D(5))3160,3160,3260
4153     3260 CALL SPAC32(43)
4154     3270 IF(EX-D(6))2850,2850,3110
4155     3280 WKRPN(1)=OUT(15)
4156     WKRPN(4)=OUT(18)
4157     CURR(2)=WKRPN(4)
4158     IF(ISW(4))3290,3300,3290
4159     3290 CURR(2)=WKRPN(1)
4160     C K.E. WITH RESPECT TO NEUTRONS(PROTONS) RG.1
4161     3300 CALL CBG6CA(1,0)
4162     GOTO 2880
4163     3310 IF(RLKE-3500.0)3330,3330,3320
4164     3320 CALL CERROR(' BERT RLKE>3.5GeV (2)$')
4165     RLKE=3500.0
4166     3330 IF(RLKE-360.0)3530,3530,3340
4167     3340 VALUE1=RLKE-360.0
4168     IF(IN)3360,3350,3360
4169     3350 ANY=S(KNOT)
4170     3360 IF(NOT-4)3380,3390,3370
4171     3370 CALL CERROR(' BERT NOT=5$')
4172     NOPART=-1
4173     RETURN
4174     3380 CALL CRJAB(1,PSPCL(1))
4175     C PSPCL(158)
4176     C (P-P) SING. PROD. CRS. LOW ENERGY
4177     GOTO 3020
4178     3390 CALL CRJAB(1,SPCLN(1))
4179     C SPCLN(158)
4180     C (N-P) SINGLE PROD. CRS. LOW ENERGY
4181     GOTO 3020
4182     3400 IF(RLKE-3500.0)3410,3410,3320
4183     3410 IF(RLKE-920.0)3530,3530,3420
4184     3420 VALUE1=RLKE-920.0
4185     IF(NOT-6)3440,3470,3430
4186     3430 CALL CERROR(' BERT NOT > 6$')
4187     NOPART=-1
4188     RETURN
4189     3440 IF(IN)3460,3450,3460
4190     3450 ANY=S(11)
4191     3460 CALL CRJAB(1,PDPCL(1))
4192     C PDPCL(130)
4193     C (P-P) DOUBLE PRODUCTION CRS. LOW ENERGY
4194     GOTO 3020
4195     3470 IF(IN)3490,3480,3490
4196     3480 ANY=S(12)
4197     3490 CALL CRJAB(1,DPCLN(1))
4198     C DPCLN(130)
4199     C (N-P) DOUBLE PRODUCTION CRS. LOW ENERGY
4200     GOTO 3020
4201     3500 IF(VALUE1-VALUE2)730,730,3510
4202     3510 CALL SIGNEX
4203     IF(IN)2160,3520,2160
4204     3520 IF(ISW(3))3250,3150,3250
4205     3530 IF(CLSM-2.0)3550,3510,3040
4206     3540 IF(VALUE1-VALUE2)890 ,890 ,3550
4207     3550 CALL SIGNEX
4208     IF(IN)2170,3230,2170
4209     3560 IF(ESPS(1))3580,3570,3580
4210     3570 NWDS=1
4211     GOTO 3610
4212     3580 NWDS=ESPS(1)*8.0+1.5
4213     C TOTAL NO. OF WORDS(ESCAPING PARTICLES)
4214     IF(COUNT(6).GE.0.0) GO TO 3610
4215     C MINUS,RECORD NOT REPRESENTATIVE,SKIP
4216     DO 3590 I=1,NWDS
4217     3590 ESPS(I) = 0.0
4218     DO 3600 I=1,5
4219     3600 COUNT(I) = 0.0D0
4220     3610 NOR=NOR+1
4221     3620 IN=0
4222     GOTO(110,2770),IP
4223     3630 IV=-1
4224     GOTO 2760
4225     C1370 RETURN
4226     END
4227     *CMZ : 1.01/04 10/06/93 14.43.37 by Christian Zeitnitz
4228     *-- Author :
4229     SUBROUTINE CABG6B
4230     #include "cbert.inc"
4231     *KEND.
4232     C
4233     SAVE
4234     CALL CZERO
4235     J=I2
4236     DO10 I=2,I4
4237     CE(I)=SPACE(J)
4238     10 J=J+1
4239     J=I4+1
4240     DO20 I=J,6
4241     CE(I)=S(I3)
4242     20 I3=I3+1
4243     RETURN
4244     END
4245     *CMZ : 0.92/03 10/12/92 10.53.07 by Christian Zeitnitz
4246     *-- Author :
4247     SUBROUTINE CABG6C(INT1)
4248     SAVE
4249     C
4250     #include "cbert.inc"
4251     *KEND.
4252     C
4253     IF(KNOT-7)10,190,190
4254     10 XABS=0.0
4255     IF(KNOT-2)20,30,30
4256     20 IF(INT1)70,100,70
4257     30 IF(KNOT-5)40,50,60
4258     40 IF(INT1)100,70,100
4259     50 IT=11
4260     IF(INT1)80,110,80
4261     60 IT=12
4262     IF(INT1)110,80,110
4263     70 IT=2*KNOT-1
4264     80 STRKP=-1.0
4265     90 I1=0
4266     GOTO130
4267     100 IT=2*KNOT
4268     110 STRKP=-2.0
4269     120 I1=1
4270     130 I2=CLSM
4271     CALLCBBBBB
4272     140 CALLCAISOM
4273     GOTO(150,150,150,160,150,150,180,180,180,180,180,180,150,150,150,
4274     +150,160,150,150), KNOT
4275     150 IF(RLKE-2500.0)170,170,140
4276     160 RLKE=0.0
4277     170 RETURN
4278     180 IF(RLKE-3500.0)170,170,140
4279     190 IF(KNOT-12)200,200,310
4280     200 IF(IN)370,210,370
4281     210 IF(KNOT-8)220,270,320
4282     220 IF(INT1)230,250,230
4283     230 IT=2*(KNOT+1)
4284     240 STRKP=-2.0
4285     GOTO90
4286     250 IT=2*KNOT+1
4287     260 STRKP=-1.0
4288     GOTO120
4289     270 IF(INT1)280,300,280
4290     280 IT=2*(KNOT+1)
4291     290 GOTO80
4292     300 IT=2*KNOT+1
4293     GOTO110
4294     310 IF(KNOT-18)320,450,450
4295     320 IT=KNOT+10
4296     330 IF(KNOT-10)340,350,360
4297     340 IF(INT1)80,110,80
4298     350 IF(INT1)240,260,240
4299     360 IF(KNOT-12)340,350,430
4300     370 IF(KNOT-8)380,400,320
4301     380 IF(INT1)390,320,390
4302     390 IT=KNOT+11
4303     GOTO80
4304     400 IF(INT1)420,410,420
4305     410 IT=2*KNOT-1
4306     GOTO260
4307     420 IT=KNOT+KNOT
4308     GOTO240
4309     430 XABS=0.0
4310     IF(KNOT-15)80,110,440
4311     440 IF(KNOT-18)110,80,110
4312     450 IT=28
4313     GOTO430
4314     END
4315     *CMZ : 0.92/00 02/12/92 16.02.24 by Christian Zeitnitz
4316     *-- Author :
4317     SUBROUTINE CBG6CA(K,L)
4318     C
4319     #include "cbert.inc"
4320     *KEND.
4321     SAVE
4322     C
4323     CLSM=K
4324     IF(IN)20,10,20
4325     10 CURR(10)=CLSM
4326     CURR(11)=CLSM
4327     C COLLISION MED. STORED IN REGION OF INITIAL COLL. AND
4328     C MEDIUM WHERE PARTICLE WAS BORN
4329     20 EFRP=SPACE(K+9)-7.0
4330     C PROTON WELL DEPTH + BINDING ENERGY=FERMI ENERGY PROTONS--MEV
4331     EFRN=SPACE(K+3)-7.0
4332     PM(2)=DNCMS
4333     C NUCLEON MASS PER CM
4334     PM(1)=DNCMS
4335     IF(K-L)30,40,50
4336     30 PM(1)=POMS
4337     C PI0 MASS PER CM
4338     GOTO50
4339     40 PM(1)=PNMS
4340     C PI(+OR-) MASS PER CM
4341     50 RETURN
4342     END
4343     *CMZ : 1.01/04 10/06/93 14.43.37 by Christian Zeitnitz
4344     *-- Author :
4345     SUBROUTINE CABIG7(C,GREAT,IX)
4346     C
4347     #include "crandm.inc"
4348     *KEND.
4349     C
4350     REAL*8 C, GREAT
4351     C
4352     GREAT = C
4353     I = IX + 1
4354     DO 10 K = 1,I
4355     C = RANDC(ISEED)
4356     IF(C.LT.GREAT) GO TO 10
4357     GREAT = C
4358     10 CONTINUE
4359     C GREAT IS THE LARGEST OF I RANDOM NOS.
4360     RETURN
4361     END
4362     *CMZ : 0.90/00 05/06/92 10.53.27 by Christian Zeitnitz
4363     *-- Author :
4364     SUBROUTINE CBOVER(V,VE,VER)
4365     SAVE
4366     C
4367     #include "cbert.inc"
4368     *KEND.
4369     REAL *8 V,VE,VER
4370     C
4371     VER=DSQRT(1.0-((VE*VE)/((V*RCPMV+VE)**2)))
4372     VER=(DSQRT(VER*(6.91D-1+(VER*11.09D-1))+1.08D-1))/VER
4373     RETURN
4374     END
4375     *CMZ : 1.01/04 10/06/93 14.43.38 by Christian Zeitnitz
4376     *-- Author :
4377     SUBROUTINE CCPES
4378     SAVE
4379     #include "cbert.inc"
4380     *KEND.
4381     C
4382     #include "crn.inc"
4383     *KEND.
4384     C
4385     I1=0
4386     I = IDINT(CURR(1) + 5.0D-2)
4387     COUNT(I) = COUNT(I) + 1.0D0
4388     C*** COUNT NO. OF TIMES EACH TYPE OF PARTICLE ESCAPES
4389     IF(CURR(1)-2.0)10,20,10
4390     10 K=CURR(10)+9.05
4391     GOTO30
4392     20 K=CURR(10)+3.05
4393     30 IF(ESPS(1)-60.0)60,40,40
4394     40 I1=1
4395     C STORAGE ALREADY FILLED
4396     50 RETURN
4397     60 L=ESPS(1)*8.D0 + 2.05D0
4398     ESPS(L)=CURR(1)
4399     ESPS(L+1)=CURR(2)-SPACE(K)
4400     M=13.05-CURR(11)
4401     CC(M)=CC(M)+1.0
4402     M=4
4403     L=L+2
4404     N=L+2
4405     DO70 I=L,N
4406     ESPS(I)=CURR(M+3)
4407     ESPS(I+3)=CURR(M)
4408     70 M=M+1
4409     ESPS(1)=ESPS(1)+1.0
4410     GOTO50
4411     END
4412     *CMZ : 0.92/03 10/12/92 10.53.26 by Christian Zeitnitz
4413     *-- Author :
4414     SUBROUTINE COLE4
4415     SAVE
4416     C
4417     #include "cbert.inc"
4418     *KEND.
4419     C
4420     K=CLSM
4421     COM=(E(4)-DNCMS)/RCPMV
4422     C K.E. OF PARTICLE 4 IN MEV
4423     C TYPE OF PARTIL. 1-5 CURRENT NUCLEON
4424     IF(CURR(1)-3.0)120,10,10
4425     10 IF(XABS)20,30,20
4426     20 COM=COM+ABSEC
4427     GOTO120
4428     30 IF(IT-5)40,70,40
4429     40 IF(IT-24)50,70,50
4430     50 IF(IT-6)60,80,60
4431     60 IF(IT-26)120,80,120
4432     70 UNIV=0.0
4433     C NEUT WITH WRONG ENERGY
4434     GOTO90
4435     80 UNIV=1.0
4436     90 UNIVE=SPACE(K+3)-SPACE(K+9)
4437     C REGION I N-P WELL DEPTH DIFFERENCE
4438     IF(UNIV)110,100,110
4439     100 COM=COM+UNIVE
4440     GOTO120
4441     110 COM=COM-UNIVE
4442     120 RETURN
4443     END
4444     *CMZ : 0.92/00 02/12/92 16.02.25 by Christian Zeitnitz
4445     *-- Author :
4446     SUBROUTINE CACOLL(M)
4447     SAVE
4448     #include "cbert.inc"
4449     *KEND.
4450     IF(M)10,20,20
4451     10 A=PM(4)*PM(4)
4452     GOTO30
4453     20 A=SQNM
4454     30 COL(15)=0.0
4455     MED=CLSM
4456     ECO (1)=CFEPN(MED)
4457     ECO (2)=CFEPN(MED+3)
4458     C PROTON(NEUTRON) ENERGY CUT-OFF
4459     COL(1)=E(1)+E(2)
4460     C TOTAL ENERGY PARTICLES 1 AND 2
4461     DO40 I=1,3
4462     40 COL(I+1)=PM(I)*PM(I)
4463     C MASS PARTICLE I SQD.
4464     COL(5)=COL(3)+COL(2)+2.0*(E(1)*E(2)-(PXYZ(1)*PXYZ(2)+PXYZ(5)*
4465     1PXYZ(6)+PXYZ(9)*PXYZ(10)))
4466     COL(6)=DSQRT(COL(5))
4467     COL(7)=COL(6)/COL(1)
4468     C GAM
4469     COL(8)=2.0*COL(6)
4470     COL(9)=(COL(4)+COL(5)-A)/COL(8)
4471     COM2=COL(9)*COL(9)
4472     50 IF(COL(4)-2.9882156D27)60,60,80
4473     C GT,PM(3)=ISOBAR--LTE,TEST FOR ROUNDOFF RANGE,(MIN)SQD+OR-5D23
4474     60 IF(COL(4)-2.9872156D27)90,70 ,70
4475     C LT,PION OR NUCLEON MASS=PM(3)
4476     70 COL(4)=2.9877156D27
4477     PM(3) = 5.466005D13
4478     80 IF(COM2-COL(4))100,120,120
4479     90 IF(COL(4) - SQNM) 80,80,140
4480     C LTE,HAVE NUCLEON OR PION--GT,GO TO ERROR
4481     100 IF(COM2 - 9.9D-1 * COL(4)) 120,110,110
4482     110 COM2 = COL(4)
4483     COL(9) = PM(3)
4484     120 COL(10)=DSQRT(COM2-COL(4))
4485     C P3 PRIME
4486     COL(11)=(COL(5)+COL(2)-COL(3))/COL(8)
4487     C E1 PRIME
4488     COL(12)=DSQRT(COL(11)*COL(11)-COL(2))
4489     C P1 PRIME
4490     COL(13)=(COL(7)*E(1)-COL(11))/COL(12)
4491     C BETA
4492     COM=1.0-(COL(13)*COL(13)+COL(7)*COL(7))
4493     IF(COM-5.0D-6)130,170,170
4494     130 IF(COM+5.0D-6)140,160,160
4495     140 COL(15)=1.0
4496     C ERROR
4497     150 RETURN
4498     160 COL(14)=2.236067977D-3
4499     GOTO180
4500     170 COL(14)=DSQRT(COM)
4501     C ALPHA
4502     180 E(3)=(COL(9)+COL(10)*(COL(13)*CST+COL(14)*SOPC*SNT))/COL(7)
4503     E(4)=COL(1)-E(3)
4504     GOTO150
4505     END
4506     *CMZ : 1.01/04 10/06/93 14.43.38 by Christian Zeitnitz
4507     *-- Author :
4508     SUBROUTINE COLLM(M)
4509     SAVE
4510     #include "cbert.inc"
4511     *KEND.
4512     C
4513     REAL *8 B
4514     UNIV=E(2)+COL(6)-COL(11)
4515     UNIVE=E(1)+COL(11)
4516     UNIVER=COL(1)+COL(6)
4517     K=16
4518     DO10 I=1,9,4
4519     COL(K)=(PXYZ(I)*UNIV-PXYZ(I+1)*UNIVE)/UNIVER
4520     COL(K+3)=(PXYZ(I)+PXYZ(I+1))/COL(1)
4521     C VX
4522     10 K=K+1
4523     COL(22)=(PXYZ(10)*PXYZ(5)-PXYZ(9)*PXYZ(6))/COL(1)
4524     C QX
4525     COL(23)=(PXYZ(2)*PXYZ(9)-PXYZ(10)*PXYZ(1))/COL(1)
4526     C QY
4527     COL(24)=(PXYZ(6)*PXYZ(1)-PXYZ(5)*PXYZ(2))/COL(1)
4528     A=SNT/COL(14)
4529     B=A*COL(10)
4530     C (-BETA*COS PHI*SIN THETA/ALPHA + COS THETA)/P1P*P3P
4531     UNIV=COL(10)*(CST-A*SOPC*COL(13))/COL(12)
4532     UNIVE=B*SOPS/COL(12)
4533     C P3P*SIN PHI*SIN THETA/P1P*ALPHA
4534     UNIVER=(SOPC*B)+((E(3)+COL(9))/(COL(7)+1.0))
4535     C COS PHI*SIN THETA*P3P/ALPHA + (E3+E3P)/(1.0+GAMMA)
4536     K=19
4537     DO20 I=3,11,4
4538     PXYZ(I)=COL(K)*UNIVER+COL(K+3)*UNIVE+COL(K-3)*UNIV
4539     20 K=K+1
4540     IF(M)30,40,30
4541     30 IF(PT(15))40,60,40
4542     40 DO50 I=1,9,4
4543     50 PXYZ(I+3)=PXYZ(I)+PXYZ(I+1)-PXYZ(I+2)
4544     IF(M)60,130,60
4545     60 IF(PT(3))70,100,70
4546     70 PT(4)=PM(3)
4547     I1=3
4548     80 I2=-1
4549     CALLPSTOR
4550     90 IF(I1-3)100,100,120
4551     100 IF(PT(15))110,120,110
4552     110 PT(16)=DNCMS
4553     C NUCLEON MASS PER CM
4554     I1=4
4555     GOTO80
4556     120 PT(27)=0.0
4557     PT(39)=0.0
4558     130 RETURN
4559     END
4560     *CMZ : 1.01/04 10/06/93 14.43.38 by Christian Zeitnitz
4561     *-- Author :
4562     SUBROUTINE CRDET(NODATA,DATA,ENER)
4563     REAL*8 DATA(6426),ENER
4564     #include "cbert.inc"
4565     *KEND.
4566     SAVE
4567     C
4568     IE=DABS(ENER/20.0)
4569     C ENERGY INTERVAL
4570     UNIV=(ENER-DFLOAT(IE)*20.0)/20.0
4571     C INPT=0 IF WHOLE INTERVAL CONSIDERED
4572     C NODATA=DATA PER ENERGY INTERVAL
4573     DO10 I=1,25
4574     10 CRDT(I)=0.0
4575     C ANSWERS STORED IN CRDT
4576     20 K=(NODATA*IE)+1
4577     30 IF(INPT)40,50 ,80
4578     40 WRITE(6,*) ' CALOR: ERROR in CRDET ====> STOP'
4579     STOP
4580     50 N=NODATA
4581     60 L=K+NODATA
4582     DO70 I=1,N
4583     CRDT(I)=(DATA(L)-DATA(K))*UNIV+DATA(K)
4584     K=K+1
4585     70 L=L+1
4586     INPT=0
4587     RETURN
4588     80 K=INPT-1+K
4589     N=2
4590     GOTO60
4591     C NOT ALL PARTS EVALUATED
4592     END
4593     *CMZ : 0.90/00 29/07/92 13.00.25 by Christian Zeitnitz
4594     *-- Author :
4595     SUBROUTINE CRJAB(K1,PP)
4596     #include "cbert.inc"
4597     #include "crandm.inc"
4598     *KEND.
4599     REAL*8 PP(380)
4600     C
4601     CALL CRDET(K1,PP(1),VALUE1)
4602     VALUE1=(PXYZ(1)*PXYZ(2)+PXYZ(5)*PXYZ(6)+PXYZ(9)*PXYZ(10))
4603     1/E(1)
4604     C P1.P2/E(1)
4605     VALUE2=(VALUE1/(P2*P2))*((E(2)/DNCMS)-1.0)-(1.0/DNCMS)
4606     C S=((P1.P2)/(E1*P2*P2))*((E2/M)-1.0)-1.0/M
4607     VALUE2=DNCMS*CRDT(1)*DSQRT(P1OE1*P1OE1+2.0*VALUE1
4608     1*VALUE2+P2*P2*VALUE2*VALUE2)/(E(2)*P1OE1*ANY)
4609     C (M)(C.S)(J**2+2S(P1.P2)/E1+(P2)(P2)(S)(S)
4610     CZ changed 20.june 92 CZ
4611     IF(VALUE2.GT.1.0) VALUE2 = 1.0
4612     C THIS TESTS SAMPLING TECH.TO ENSURE FMAXS WERE SELECTED SO THAT
4613     C VALUE2 LTE ONE.
4614     VALUE1 = RANDC(ISEED)
4615     RETURN
4616     END
4617     *CMZ : 1.01/04 10/06/93 14.43.38 by Christian Zeitnitz
4618     *-- Author :
4619     SUBROUTINE DCINTP(W)
4620     #include "cbert.inc"
4621     *KEND.
4622     C
4623     #include "crandm.inc"
4624     *KEND.
4625     REAL*8 W(250),Z(24),FLTI
4626     SAVE
4627     C
4628     Z(1)=RLKE-6.6D2
4629     IE=IDINT(Z(1)/2.0D1+5.0D-6)
4630     UNIV=(Z(1)-DFLOAT(IE)*2.0D1)/2.0D1
4631     IE=IE+1
4632     UNIVE=(W(IE+1)-W(IE))*UNIV+W(IE)
4633     C RATIO
4634     I2=0
4635     K=1
4636     UNIV = RANDC(ISEED)
4637     IF(UNIV.GE.UNIVE)GOTO190
4638     C LT=BACKWARD
4639     C N-P ELASTIC SCAT.,RLKE GT 660
4640     LLL=179
4641     IF(W(180).GT.RLKE) GO TO 20
4642     DO 10 I = 1,5
4643     IF(W(179+K).GT.RLKE)GO TO 40
4644     10 K=K+12
4645     20 I1=-1
4646     C ERROR
4647     30 RETURN
4648     40 M=12
4649     50 DO60 L=1,M
4650     Z(L+M)=W(LLL+K)
4651     Z(L)=W(LLL+K-M)
4652     60 K=K+1
4653     UNIV = RANDC(ISEED)
4654     UNIVE=(RLKE-Z(1))/(Z(M+1)-Z(1))
4655     DO70 I=2,M
4656     P=(Z(I+M)-Z(I))*UNIVE+Z(I)
4657     IF(P.GE.UNIV) GO TO 80
4658     70 CONTINUE
4659     GO TO 20
4660     80 I1=I
4661     UNIV = RANDC(ISEED)
4662     FLTI=UNIV+DFLOAT(I1-2)
4663     IF(M.LE.9) GO TO 230
4664     90 GOTO(20,100,100,110,120,130,130,140,150,160,170,180),I1
4665     100 CST=1.0D-2*FLTI-0.1D1
4666     GO TO 30
4667     110 CST=2.0D-2*UNIV-9.8D-1
4668     GO TO 30
4669     120 CST=4.0D-2*UNIV-9.6D-1
4670     GO TO 30
4671     130 CST=6.0D-2*FLTI-0.116D1
4672     GO TO 30
4673     140 CST=8.0D-2*UNIV-8.0D-1
4674     GO TO 30
4675     150 CST=1.0D-1*UNIV-7.2D-1
4676     GO TO 30
4677     160 CST=1.2D-1*UNIV-6.2D-1
4678     GO TO 30
4679     170 CST=2.0D-1*UNIV-5.0D-1
4680     GO TO 30
4681     180 CST=3.0D-1*(UNIV-1.0D0)
4682     GO TO 30
4683     C FORWARD
4684     190 LLL=143
4685     IF(W(144).GT.RLKE) GO TO 20
4686     200 DO 210 I = 1,4
4687     IF(W(143+K).GT.RLKE) GO TO 220
4688     210 K=K+9
4689     GOTO20
4690     220 M=9
4691     GOTO50
4692     230 GOTO(20,240,240,240,240,250,260,270,280),I1
4693     240 CST=1.0D0-2.5D-2*FLTI
4694     GOTO30
4695     250 CST=8.5D-1+0.5D-1*UNIV
4696     GOTO30
4697     260 CST=7.0D-1+1.5D-1*UNIV
4698     GOTO30
4699     270 CST=5.0D-1+2.0D-1*UNIV
4700     GOTO30
4701     280 CST=5.0D-1*UNIV
4702     GOTO30
4703     END
4704     *CMZ : 1.01/04 10/06/93 14.43.38 by Christian Zeitnitz
4705     *-- Author :
4706     SUBROUTINE CADCPR(W,LK)
4707     #include "cbert.inc"
4708     *KEND.
4709     C
4710     #include "crandm.inc"
4711     *KEND.
4712     REAL*8 W(60),Z(24)
4713     REAL*8 FRACT,R,SUM,FLTI
4714     SAVE
4715     C
4716     C PDCI HAS KK=12, PDCH HAS KK=11
4717     I2=0
4718     KK=LK
4719     K=1
4720     DO10 I=1,5
4721     IF(W(K).GE.RLKE)GOTO40
4722     10 K=K+KK
4723     20 I2=1
4724     C ERROR RETURN
4725     30 RETURN
4726     40 DO 50 L = 1,KK
4727     Z(L+KK)=W(K)
4728     Z(L)=W(K-KK)
4729     50 K=K+1
4730     SUM=0.0D0
4731     R = RANDC(ISEED)
4732     FRACT=(RLKE-Z(1))/(Z(KK+1)-Z(1))
4733     DO 60 I = 2,KK
4734     SUM=SUM+Z(I)+((Z(I+KK)-Z(I))*FRACT)
4735     IF(R.LT.SUM) GO TO 70
4736     60 CONTINUE
4737     GO TO 20
4738     C ERROR
4739     70 R = RANDC(ISEED)
4740     I1=I
4741     IF(KK.GT.11) GO TO 90
4742     IF(I1.GT.2) GO TO 80
4743     CST=4.0D-1*R
4744     GO TO 150
4745     80 I1=I1+1
4746     90 FLTI=DFLOAT(I1-2)+R
4747     100 GO TO (20,110,110,110,120,120,130,130,130,130,140,140),I1
4748     110 CST=2.0D-1*(FLTI)
4749     GO TO 150
4750     120 CST=3.0D-1+1.0D-1*(FLTI)
4751     GO TO 150
4752     130 CST=6.0D-1+4.0D-2*(FLTI)
4753     GO TO 150
4754     140 CST=7.8D-1+2.0D-2*(FLTI)
4755     150 R = RANDC(ISEED)
4756     IF(R.GT.5.0D-1) GO TO 30
4757     CST=-(CST)
4758     GO TO 30
4759     END
4760     *CMZ : 0.92/00 02/12/92 16.02.25 by Christian Zeitnitz
4761     *-- Author :
4762     SUBROUTINE DFMAX
4763     SAVE
4764     #include "cbert.inc"
4765     *KEND.
4766     REAL*8 WK
4767     C
4768     I=I2
4769     IF(CURR(1)-2.0)20,10,10
4770     10 I=I+3
4771     20 WK=WKRPN(I)
4772     30 CALL CBOVER(WK,DNCMS,UNIV)
4773     IF(WK-560.0)40,40,60
4774     40 FMAX(1)=27.2D-27*UNIV
4775     C 820 MEV
4776     C (P-P)S
4777     FMAX(2)=38.0D-27*UNIV
4778     C 230 MEV
4779     C (P-N)S
4780     FMAX(3)=22.6D-27*UNIV
4781     C 1020 MEV
4782     C (P-P)S.P.
4783     FMAX(4)=14.0D-27*UNIV
4784     C 750 MEV
4785     C (P-N)S.P.
4786     FMAX(5)=0.0
4787     C (P-P)D.P.
4788     FMAX(6)=0.0
4789     C (P-N)D.P.)
4790     50 RETURN
4791     60 IF(WK-800.0)70,90,90
4792     70 FMAX(2)=37.0D-27*UNIV
4793     C 250 MEV
4794     FMAX(5)=1.9D-27*UNIV
4795     C 5 AN6 AT 1380 MEV
4796     FMAX(6)=9.0D-27*UNIV
4797     80 FMAX(1)=27.2D-27*UNIV
4798     C 820 MEV
4799     FMAX(3)=22.6D-27*UNIV
4800     C 1020
4801     FMAX(4)=14.0D-27*UNIV
4802     C 750
4803     GO TO 50
4804     90 IF(WK-1680.0)100,110,110
4805     100 FMAX(2)=33.0D-27*UNIV
4806     C 400
4807     FMAX(5)=10.8D-27*UNIV
4808     C 5 AND 6 AT 2600
4809     FMAX(6)=17.4D-27*UNIV
4810     GO TO 80
4811     110 FMAX(1)=26.3D-27*UNIV
4812     C 1000
4813     FMAX(2)=24.7D-27*UNIV
4814     C 1000
4815     FMAX(3)=22.6D-27*UNIV
4816     C 1020
4817     FMAX(4)=13.5D-27*UNIV
4818     C 1000
4819     FMAX(5)=18.0D-27*UNIV
4820     FMAX(6)=23.6D-27*UNIV
4821     C 3500
4822     GO TO 50
4823     END
4824     *CMZ : 0.92/00 02/12/92 16.02.25 by Christian Zeitnitz
4825     *-- Author :
4826     SUBROUTINE CAECPL
4827     #include "cbert.inc"
4828     *KEND.
4829     C
4830     SAVE
4831     I1=0
4832     MED=CLSM
4833     IF(PT(38))590,10,590
4834     10 IF(CURR(1)-1.0)380,540,20
4835     20 IF(CURR(1)-3.0)450,420,30
4836     30 IF(CURR(1)-5.0)320,40,380
4837     40 IF(STRKP+1.0)50,60,380
4838     50 IF(STRKP+2.0)380,230,380
4839     60 IF(PT(2)-2.0)80,70,80
4840     70 PT(3)=VNVP(MED)
4841     GOTO90
4842     C PI-,CURR(1)=5.0,PT6+1=0,STRKP=1.0
4843     80 PT(3)=0.0
4844     90 PT(15)=HVP(MED)
4845     IF(PT(26)-1.0)380,190,100
4846     100 IF(PT(26)-2.0)380,110,380
4847     110 PT(27)=-PPAN(MED)
4848     IF(CURR(1)-2.0)580,120,120
4849     C PPAN=-VNHP(NEUT.WELL DEPTH-1/2PROTON WELL DEPTH)
4850     120 IF(CURR(1)-4.0)440,380,130
4851     130 IF(PT(2)-3.0)380,150,140
4852     140 IF(PT(2)-5.0)170,180,380
4853     150 IF(PT(14)-5.0)380,160,380
4854     160 RETURN
4855     170 IF(PT(14)-4.0)380,160,380
4856     180 IF(PT(14)-3.0)380,160,380
4857     C 1/2PROT.WELL DEPTH
4858     190 PT(27)=HVP(MED)
4859     IF(CURR(1)-2.0)560,200,200
4860     200 IF(CURR(1)-4.0)400,380,210
4861     210 IF(PT(2)-4.0)380,150,220
4862     220 IF(PT(2)-5.0)380,170,380
4863     230 PT(3)=-VNVP(MED)
4864     240 PT(15)=-PMAC(MED)
4865     250 IF(PT(26)-1.0)380,270,260
4866     260 IF(PT(26)-2.0)380,300,380
4867     270 PT(27)=-PMAC(MED)
4868     IF(CURR(1)-2.0)150,150,280
4869     280 IF(CURR(1)-4.0)130,210,290
4870     290 IF(PT(2)-5.0)380,150,380
4871     300 PT(27)=HVN(MED)
4872     IF(CURR(1)-2.0)170,170,310
4873     310 IF(CURR(1)-4.0)400,130,210
4874     320 IF(STRKP+1.0)330,340,380
4875     330 IF(STRKP+2.0)380,230,380
4876     C PI0
4877     340 PT(3)=0.0
4878     350 PT(15)=HVP(MED)
4879     IF(PT(26)-1.0)380,370,360
4880     360 IF(PT(26)-2.0)380,390,380
4881     370 PT(27)=HVP(MED)
4882     IF(CURR(1)-4.0)170,130,380
4883     380 I1=1
4884     GOTO160
4885     390 PT(27)=-PPAN(MED)
4886     IF(CURR(1)-4.0)180,400,380
4887     400 IF(PT(2)-3.0)380,170,410
4888     410 IF(PT(2)-4.0)380,180,380
4889     420 IF(STRKP+1.0)430,60,380
4890     C PI+
4891     430 IF(STRKP+2.0)380,230,380
4892     440 IF(PT(2)-3.0)380,180,380
4893     450 IF(STRKP+1.0)460,470,380
4894     C NEUTRON
4895     460 IF(STRKP+2.0)380,490,380
4896     470 PT(3)=0.0
4897     IF(PT(2)-1.0)380,240,480
4898     480 IF(PT(2)-2.0)380,350,380
4899     490 PT(15)=-PMAC(MED)
4900     IF(PT(2)-1.0)380,510,500
4901     500 IF(PT(2)-2.0)380,530,380
4902     510 IF(PT(26)-2.0)380,520,380
4903     520 PT(3)=-VNVP(MED)
4904     PT(27)=HVN(MED)
4905     GOTO150
4906     530 PT(3)=0.0
4907     GOTO250
4908     540 IF(STRKP+1.0)550,60,380
4909     550 IF(STRKP+2.0)380,470,380
4910     C PROTON
4911     560 IF(PT(2)-1.0)380,170,570
4912     570 IF(PT(2)-2.0)380,180,380
4913     580 IF(PT(2)-1.0)380,180,380
4914     590 IF(CURR(1)-1.0)380,610,600
4915     600 IF(CURR(1)-2.0)380,630,380
4916     610 IF(STRKP+1.0)620,840,380
4917     620 IF(STRKP+2.0)380,650,380
4918     630 IF(STRKP+1.0)640,650,380
4919     640 IF(STRKP+2.0)380,960,380
4920     650 IF(PT(14))380,380,660
4921     660 IF(PT(38))380,380,670
4922     670 IF(PT(38)-2.0)680,740,380
4923     680 IF(PT(14)-2.0)690,800,380
4924     690 PT(3)=TFFN(MED)
4925     PT(15)=TFFN(MED)
4926     PT(27)=TFFN(MED)
4927     PT(39)=TFFN(MED)
4928     700 IF(PT(2)-3.0)380,380,710
4929     710 IF(PT(2)-5.0)730,720,380
4930     720 IF(PT(26)-4.0)380,160,380
4931     730 IF(PT(26)-5.0)380,160,380
4932     740 IF(PT(14)-2.0)750,810,380
4933     750 PT(27)=FFPTFN(MED)
4934     PT(3)=FVNP(MED)
4935     760 PT(39)=FVNP(MED)
4936     PT(15)=FVNP(MED)
4937     770 IF(PT(2)-3.0)380,730,780
4938     780 IF(PT(2)-5.0)720,790,380
4939     790 IF(PT(26)-3.0)380,160,380
4940     800 PT(3)=FFPTFN(MED)
4941     PT(27)=FVNP(MED)
4942     GOTO760
4943     810 PT(3)=TFFN(MED)
4944     PT(27)=TFFN(MED)
4945     PT(15)=TFFP(MED)
4946     PT(39)=TFFP(MED)
4947     820 IF(PT(2)-3.0)380,720,830
4948     830 IF(PT(2)-4.0)380,790,380
4949     840 IF(PT(14))380,380,850
4950     850 IF(PT(38)-1.0)380,870,860
4951     860 IF(PT(38)-2.0)380,930,380
4952     870 IF(PT(14)-2.0)880,900,380
4953     880 PT(3)=HVP(MED)
4954     890 PT(15)=HVP(MED)
4955     PT(27)=HVP(MED)
4956     PT(39)=HVP(MED)
4957     IF(PT(14)-2.0)770,700,380
4958     900 PT(27)=HVN(MED)
4959     910 PT(3)=-PMAC(MED)
4960     920 PT(39)=HVN(MED)
4961     PT(15)=HVN(MED)
4962     IF(PT(38)-2.0)820,770,380
4963     930 IF(PT(14)-2.0)940,950,380
4964     940 PT(3)=HVN(MED)
4965     PT(15)=HVN(MED)
4966     PT(27)=-PMAC(MED)
4967     PT(39)=HVN(MED)
4968     GOTO820
4969     950 PT(15)=-PPAN(MED)
4970     PT(39)=-PPAN(MED)
4971     PT(3)=HVP(MED)
4972     PT(27)=HVP(MED)
4973     IF(PT(2)-3.0)380,790,380
4974     960 IF(PT(14))380,380,970
4975     970 IF(PT(38)-1.0)380,990,980
4976     980 IF(PT(38)-2.0)380,1020,380
4977     990 IF(PT(14)-2.0)1000,1010,380
4978     1000 PT(39)=-PMAC(MED)
4979     PT(15)=-PMAC(MED)
4980     PT(27)=-PMAC(MED)
4981     PT(3)=-PMAC(MED)
4982     IF(PT(2)-5.0)380,730,380
4983     1010 PT(3)=THPN(MED)
4984     GOTO890
4985     1020 IF(PT(14)-2.0)1030,1040,380
4986     1030 PT(3)=HVP(MED)
4987     PT(15)=HVP(MED)
4988     PT(39)=HVP(MED)
4989     PT(27)=THPN(MED)
4990     GOTO700
4991     1040 PT(27)=-PMAC(MED)
4992     GOTO910
4993     END
4994     *CMZ : 1.01/04 10/06/93 14.43.38 by Christian Zeitnitz
4995     *-- Author :
4996     SUBROUTINE CERROR(CARG)
4997     C
4998     #include "minput.inc"
4999     #include "cerrcm.inc"
5000     *KEND.
5001     C
5002     CHARACTER*1 CARG(50),CPRT(50)
5003     CHARACTER*1 ZEI,CEND
5004     DATA CEND/'$'/
5005     C
5006     DO 10 I=1,50
5007     ZEI=CARG(I)
5008     IF(ZEI.EQ.CEND) GOTO 20
5009     CPRT(I)=CARG(I)
5010     10 CONTINUE
5011     20 DO 30 J=I,50
5012     CPRT(J)=' '
5013     30 CONTINUE
5014     WRITE(IOUT,*) ' HETC : ERROR in ',CPRT
5015     C
5016     CERRF = .TRUE.
5017     RETURN
5018     END
5019     *CMZ : 0.92/00 02/12/92 16.02.25 by Christian Zeitnitz
5020     *-- Author :
5021     SUBROUTINE EXPRN(EXPA)
5022     C
5023     #include "crandm.inc"
5024     *KEND.
5025     C
5026     REAL * 8 EXPA,EXPB,WHOLE,EXPAO
5027     C
5028     WHOLE=0.0
5029     10 EXPA = RANDC(ISEED)
5030     EXPAO=EXPA
5031     20 EXPB = RANDC(ISEED)
5032     IF(EXPB.LT.EXPA) GO TO 40
5033     C RANDOM2 IS.GTE.TO RANDOM1
5034     30 EXPA=EXPAO+WHOLE
5035     RETURN
5036     40 EXPA = RANDC(ISEED)
5037     IF(EXPA.LT.EXPB) GO TO 20
5038     WHOLE=WHOLE+1.0
5039     GO TO 10
5040     END
5041     *CMZ : 0.92/00 02/12/92 16.02.25 by Christian Zeitnitz
5042     *-- Author :
5043     SUBROUTINE FRMICC(GPART)
5044     #include "crandm.inc"
5045     *KEND.
5046     DIMENSION G(3)
5047     REAL * 8 GPART,G
5048     SAVE
5049     C
5050     DO 10 I = 1,3
5051     10 G(I) = RANDC(ISEED)
5052     C FIND LARGEST OF 3 RANDOM NOS.
5053     IF(G(3).LT.G(2)) GO TO 40
5054     C 3.GTE.2
5055     IF(G(3).LT.G(1))GO TO 30
5056     C 3.GTE.2,AND 3.GTE.1
5057     GPART=G(3)
5058     20 RETURN
5059     30 GPART=G(1)
5060     C 3.GTE.2 AND 3.LT.1 OR 3.LT.2 AND 2.LT.1
5061     GO TO 20
5062     40 IF(G(2).LT.G(1))GO TO 30
5063     GPART=G(2)
5064     C 3.LT.2,AND 2.GTE.1
5065     GO TO 20
5066     END
5067     *CMZ : 0.92/00 02/12/92 16.02.25 by Christian Zeitnitz
5068     *-- Author :
5069     SUBROUTINE CAGENE(Z)
5070     IMPLICIT REAL*8 (A-H,O-Z)
5071     REAL*8 Z(101)
5072     #include "cbert.inc"
5073     *KEND.
5074     SAVE
5075     C
5076     CD=COM*1.0D2
5077     I=IDINT(CD+1.00D0)
5078     AZ=Z(I)
5079     IF(I.EQ.1)GOTO150
5080     10 BZ=Z(I+1)
5081     IF(101-(I+1))70,20,30
5082     20 CZ=BZ+5.0D-1*(BZ-AZ)
5083     GOTO40
5084     30 CZ=Z(I+2)
5085     40 XZ=CD-DFLOAT(I-1)
5086     SCA=CZ-AZ
5087     C F(2)-F(0)
5088     50 SBA=BZ-AZ
5089     C F(1)-F(0)
5090     SQA=AZ*AZ
5091     C F(0)**2
5092     SQAC=SQA-CZ*CZ
5093     C F(0)**2-F(2)**2
5094     SQBA=BZ*BZ-SQA
5095     C F(1)**2-F(0)**2
5096     RB=SQAC+SQBA+SQBA
5097     C (ASQ-CSQ)+2(BSQ-ASQ)
5098     CZ
5099     CZ changed in order to keep exponent small 5/21/92
5100     RC=AZ*1.0D-20*CZ*SCA-SBA*1.0D-20*(2.0D0*AZ*BZ+XZ*(BZ-CZ)*SCA)
5101     CZ RC is 1E-20 smaller than it supposed to be !!!!
5102     RA=SCA-SBA-SBA
5103     C (C-A)-2(B-A)
5104     IF(RA.NE.0.0)GOTO60
5105     COM=AZ+XZ*SBA
5106     GOTO80
5107     60 CONTINUE
5108     CZ \/ factor 1E-20 in RC !!
5109     DISC=RB*1.0D-20*RB-4.0D0*RA*RC
5110     IF(DISC)70,90,90
5111     C B**2-4AC
5112     70 CALL CERROR('CAGENE1$')
5113     80 RETURN
5114     CZ \/ correct for factor 1E-20
5115     90 DISC=DSQRT(DISC)*1.0D10
5116     CZ end of change
5117     CZ
5118     PLUS=(DISC-RB)/(RA+RA)
5119     AMINUS=(-RB-DISC)/(RA+RA)
5120     IF(I.EQ.1)GOTO160
5121     100 IF(PLUS.GT.BZ)GOTO120
5122     IF(PLUS.LT.AZ)GOTO120
5123     IF(AMINUS.GT.BZ)GOTO110
5124     IF(AMINUS.GE.AZ)GOTO140
5125     110 COM=PLUS
5126     GOTO80
5127     120 IF(AMINUS.GT.BZ)GOTO70
5128     IF(AMINUS.LT.AZ)GOTO70
5129     130 COM=AMINUS
5130     GOTO80
5131     140 RA=XZ*SBA+AZ
5132     RB=DABS(RA-AMINUS)
5133     RC=DABS(RA-PLUS)
5134     IF(RB.GT.RC)GOTO110
5135     GOTO130
5136     150 CZ=Z(I+1)
5137     SCA=CZ-AZ
5138     BZ=AZ+SCA*7.071067812D-1
5139     XZ=CD+CD
5140     GOTO50
5141     C (CZ-AZ)(CZ-AZ)=C,CZ=MASS FOR R=1,AZ=MASS FOR R=0, C=CONST.FOR PARABOLA
5142     C (M-AZ)(M-AZ)=0.5*C,DETERMINES MASS,BZ,FOR R=1/2
5143     160 BZ=CZ
5144     XZ=XZ-CD
5145     SBA=CZ-AZ
5146     GOTO100
5147     END
5148     *CMZ : 1.01/04 10/06/93 14.43.38 by Christian Zeitnitz
5149     *-- Author :
5150     SUBROUTINE CALGEO
5151     #include "cbert.inc"
5152     *KEND.
5153     REAL * 8 T1,T2,T3,T4,T5,T6,TEMP,TEMPO
5154     SAVE
5155     C
5156     I1=0
5157     T1=OUT(2)*OUT(2)
5158     C R1SQ
5159     T2=OUT(3)*OUT(3)
5160     C (R1+1)SQ
5161     T3=OUT(4)*OUT(4)
5162     C (R1+2)SQ
5163     T4=2.0*T3
5164     C 2(R1+2)SQ
5165     10 T5=XI(1)*XI(1)+XI(2)*XI(2)+XI(3)*XI(3)
5166     C T5=R SQ
5167     GO TO(20 ,70 ,130,190),MED
5168     20 T6=T5-T1
5169     IF(T6)240,240,30
5170     C MED=1
5171     30 TEMP=T1
5172     40 IF((T6/TEMP)-5.0D-6)50 ,50 ,230
5173     50 DO60 I=1,3
5174     XI(I)=XI(I)*9.99995D-1
5175     60 CURR(I+3)=XI(I)
5176     GOTO10
5177     70 T6=T5-T1
5178     C MED=2
5179     IF(T6)80 ,80 ,120
5180     80 TEMP=T1
5181     90 IF(5.0D-6+(T6/TEMP))230,100,100
5182     100 DO110 I=1,3
5183     XI(I)=XI(I)*10.00005D-1
5184     110 CURR(I+3)=XI(I)
5185     GOTO10
5186     120 T6=T5-T2
5187     TEMP=T2
5188     IF(T6)240,240,40
5189     130 T6=T5-T2
5190     C MED=3
5191     IF(T6)140,140,150
5192     140 TEMP=T2
5193     GOTO90
5194     150 T6=T5-T3
5195     IF(T6)240,240,160
5196     160 TEMP=T3
5197     C****DUMMY IF ST. FOLLOWS TO KEEP ST. 175
5198     IF (TEMP.NE.T3) GO TO 170
5199     GOTO40
5200     170 IF(XI(2))230,180,230
5201     C MED=4
5202     180 IF(CURR(5))230,190,230
5203     190 T6=T5-T3
5204     IF(T6)200,200,210
5205     200 TEMP=T3
5206     GOTO90
5207     210 T6=T5-T4
5208     IF(T6)240,240,220
5209     220 TEMP=T4
5210     GOTO40
5211     230 I1=-1
5212     GOTO290
5213     240 T4=XI(1)*DCOS(1)+XI(2)*DCOS(2)+XI(3)*DCOS(3)
5214     C T4=-B=-RCOS(THETA)=SUM OF XI(I)*DCOS(I)
5215     T6=T4*T4
5216     C T5=R SQ.
5217     T6=T5-T6
5218     C T6=R SQ.-B SQ.
5219     IF(T3-T6)230,250 ,250
5220     250 T3=DSQRT(T3-T6)
5221     C T3=A3=SQ.ROOT OF B SQ.-R SQ.+RADIUS3 SQ. SIMILAR
5222     C FOR T2=A2 ANDT1=A1
5223     TEMP=T2-T6
5224     T2=DSQRT(DABS(TEMP))
5225     TEMPO=T1-T6
5226     T1=DSQRT(DABS(TEMPO))
5227     DO260 I=1,6
5228     260 D(I)=0.0
5229     GOTO(270,300,360,420),MED
5230     270 IF(TEMP)230,280,280
5231     280 D(4)=T1-T4
5232     C B+A1
5233     D(5)=T2-T1
5234     C A2-A1
5235     D(6)=T3-T2
5236     C A3-A2
5237     290 RETURN
5238     300 IF(TEMP)230,310,310
5239     310 D(6)=T3-T2
5240     320 IF(T4)340,330,330
5241     330 D(3)=T2-T4
5242     C B+A2
5243     GOTO290
5244     340 IF(TEMPO)330,350,350
5245     350 D(3)=-(T4+T1)
5246     C B-A1
5247     D(4)=T1+T1
5248     C 2A1
5249     D(5)=T2-T1
5250     C A2-A1
5251     GOTO290
5252     360 IF(T4)380,370,370
5253     370 D(2)=T3-T4
5254     C B+A3
5255     GOTO290
5256     380 IF(TEMP)370,390,390
5257     390 D(2)=-(T4+T2)
5258     C B-A2
5259     D(6)=T3-T2
5260     C A3-A2
5261     IF(TEMPO)400,410,410
5262     400 D(3)=T2+T2
5263     C 2A2
5264     GOTO290
5265     410 D(3)=T2-T1
5266     C A2-A1
5267     D(5)=D(3)
5268     D(4)=T1+T1
5269     C 2A1
5270     GOTO290
5271     420 D(1)=-(T4+T3)
5272     430 IF(TEMP)440,450,450
5273     440 D(2)=T3+T3
5274     GOTO290
5275     450 D(2)=T3-T2
5276     D(6)=D(2)
5277     C B-A3, A3-A2,REGION 4
5278     IF(TEMPO)470,460,460
5279     460 D(3)=T2-T1
5280     C A2-A1
5281     D(5)=D(3)
5282     D(4)=T1+T1
5283     GOTO290
5284     470 D(3)=T2+T2
5285     C 2A2
5286     GOTO290
5287     END
5288     *CMZ : 1.01/04 10/06/93 14.43.38 by Christian Zeitnitz
5289     *-- Author :
5290     SUBROUTINE CALIDK
5291     #include "cbert.inc"
5292     *KEND.
5293     SAVE
5294     C
5295     UNIV=PNIDK(6)*PNIDK(6)
5296     C M(P1) SQUARED DECAY PION MASS SQUARED
5297     PNIDK(7)=(PNIDK(1)*PNIDK(1)+UNIV-SQNM)/(2.0*PNIDK(1))
5298     C E(PI)PRIME DECAY PION ENERGY PRIME
5299     PNIDK(8)=DSQRT(PNIDK(7)*PNIDK(7)-UNIV)
5300     C DECAY PION MOMENTUM PRIME P(D)
5301     CALL CAPOL1(PNIDK(20),PNIDK(21))
5302     C COS THETA, SIN THETA
5303     CALL CAAZIO(PNIDK(22),PNIDK(23))
5304     C COS PHI, SIN PHI
5305     PNIDK(9)=PNIDK(22)*PNIDK(21)*PNIDK(8)
5306     C DECAY PION X MOMENTUM COMPONENT PRIME
5307     PNIDK(10)=PNIDK(21)*PNIDK(23)*PNIDK(8)
5308     C P(P1)PRIME Y
5309     PNIDK(11)=PNIDK(20)*PNIDK(8)
5310     C P(P1)PRIME Z
5311     UNIV=PNIDK(9)*PNIDK(2)+PNIDK(10)*PNIDK(3)+PNIDK(11)*PNIDK(4)
5312     C P P1 PRIME DOT P
5313     PNIDK(12)=(PNIDK(7)*PNIDK(5)+UNIV)/PNIDK(1)
5314     C DECAY PION ENERGY E(PI)
5315     PNIDK(13)=PNIDK(5)-PNIDK(12)
5316     UNIV=(((PNIDK(5)/PNIDK(1))-1.0)*UNIV)/(PNIDK(2)*PNIDK(2)+
5317     +PNIDK(3)*PNIDK(3)+PNIDK(4)*PNIDK(4))
5318     C (E/M-1.0)*P(P1)PRIME DOT P/P SQUARED
5319     UNIVE=PNIDK(7)/PNIDK(1)
5320     C E PI PRIME OVER MASS
5321     DO10 I=2,4
5322     PNIDK(I+12)=PNIDK(I)*(UNIV+UNIVE) +PNIDK(I+7)
5323     10 PNIDK(I+15)=PNIDK(I)-PNIDK(I+12)
5324     RETURN
5325     C PION MOMENTUM COMPONENTS AND NUCLEON MOMENTUM
5326     C COMPONENTS
5327     END
5328     *CMZ : 0.92/00 02/12/92 16.02.26 by Christian Zeitnitz
5329     *-- Author :
5330     SUBROUTINE CAISOM
5331     #include "cbert.inc"
5332     *KEND.
5333     REAL * 8 FERMN
5334     SAVE
5335     C
5336     CALL CAPOL1(POLC,POLS)
5337     CALL CAAZIO(SOPC,SOPS)
5338     M = SNGL(CLSM) + .05
5339     IF(STRKP+2.0)20,20,10
5340     10 FERMN=FMPN(M)
5341     C STRUCK PROTON
5342     GOTO30
5343     20 FERMN=FMPN(M+3)
5344     C STRUCK NEUTRON
5345     30 CALL FRMICC(P2)
5346     P2=FERMN*P2
5347     C FRMIC SELECTS LARGEST OF 3 RANDOM NUMBERS
5348     C P2=MOMENTUM OF PARTICLE SELECTED FROM PROPER
5349     C FERMI DISTRIBUTION
5350     A=P2*POLS
5351     C P2 SIN THETA
5352     PXYZ(2)=A*SOPC
5353     C P2 SIN THETA COS PHI
5354     PXYZ(6)=A*SOPS
5355     C P2 SIN PHI
5356     PXYZ(10)=P2*POLC
5357     C P2 COS THETA
5358     E(2)=DSQRT(P2*P2+SQNM)
5359     C SQ. RT. MOMENTUM STRUCK PART. SQD. +NUCLEON MASS SQD.
5360     RLKE=(((E(1)*E(2)-PXYZ(1)*PXYZ(2)-PXYZ(5)*PXYZ(6)-PXYZ(9)*
5361     1PXYZ(10))/DNCMS )-PM(1))/RCPMV
5362     C RELATIVE K.E.(MEV)--CONSTANT=NUCLEON MASS /CM,
5363     C SECOND=MEV/CM.
5364     RETURN
5365     END
5366     *CMZ : 0.90/00 29/07/92 11.28.17 by Christian Zeitnitz
5367     *-- Author :
5368     SUBROUTINE CALMUD(SINE,INP)
5369     C
5370     #include "crandm.inc"
5371     *KEND.
5372     C
5373     REAL * 8 SINE
5374     C
5375     SINE= RANDC(ISEED)
5376     SINE = 5.0 D1 * SINE
5377     INP = IDINT(SINE + 0.1D1)
5378     SINE=DFLOAT(INP)-SINE
5379     C SINE=(.02N-R)/.02=N-R/.02 N=INPT R/.02=(N-1)+X
5380     RETURN
5381     END
5382     *CMZ : 0.92/00 02/12/92 16.02.26 by Christian Zeitnitz
5383     *-- Author :
5384     SUBROUTINE CALNNN
5385     #include "cbert.inc"
5386     *KEND.
5387     C
5388     FMAX(1) = 0.46 D-24
5389     FMAX(2) = 1.4 D-24
5390     DO10 I=3,6
5391     10 FMAX(I)=0.0
5392     RETURN
5393     END
5394     *CMZ : 0.90/00 19/05/92 17.08.07 by Christian Zeitnitz
5395     *-- Author :
5396     SUBROUTINE P1CLC
5397     #include "cbert.inc"
5398     *KEND.
5399     C
5400     P1OE1=DSQRT(E(1)*E(1)-PM(1)*PM(1))
5401     PXYZ(1)=P1OE1*CURR(7)
5402     PXYZ(5)=P1OE1*CURR(8)
5403     PXYZ(9)=P1OE1*CURR(9)
5404     P1OE1=P1OE1/E(1)
5405     RETURN
5406     END
5407     *CMZ : 0.90/00 06/06/92 14.08.24 by Christian Zeitnitz
5408     *-- Author :
5409     SUBROUTINE P1CLI
5410     #include "cbert.inc"
5411     *KEND.
5412     C
5413     PXYZ(1)=0.0
5414     PXYZ(5)=0.0
5415     PXYZ(9)=DSQRT(E(1)*E(1)-PM(1)*PM(1))
5416     P1OE1=PXYZ(9)/E(1)
5417     RETURN
5418     C MOMENTUM X AND Y COORDINATES,PARTICLE 1 =0.0
5419     C Z COORD. =TOTAL ENERGY SQUARED-MASS SQ. TO THE 1/2
5420     C FOR PARTICLE ONE. P1OE1=CURRENT(MOMENT/TOTAL)
5421     END
5422     *CMZ : 0.92/00 02/12/92 16.02.26 by Christian Zeitnitz
5423     *-- Author :
5424     SUBROUTINE PARTIN
5425     #include "cbert.inc"
5426     *KEND.
5427     C
5428     SAVE
5429     IF(D(4))10 ,20 ,10
5430     10 IPEC(10)=IPEC(10)+1
5431     C NO. OF INC. PARTICLES ON REG.1 ONLY
5432     GOTO50
5433     20 IF(D(3))30 ,40 ,30
5434     30 IPEC(6)=IPEC(6)+1
5435     C NO. OF INC. PARTICLES ON REG.2 ONLY
5436     GOTO50
5437     40 IPEC(1)=IPEC(1)+1
5438     C NO. OF INC. PARTICLES ON REG.3 ONLY
5439     50 DO60 I=1,3
5440     60 ISW(I)=0
5441     C 1=0 WHEN START IN RG.3 OR RG.4
5442     C 2=0 WHEN IN RG.3 NOT PASSING THROUGH RG.1
5443     C 3=0 WHEN IN RG.2 NOT PASSING THROUGH RG.1
5444     RETURN
5445     END
5446     *CMZ : 0.92/00 02/12/92 16.02.26 by Christian Zeitnitz
5447     *-- Author :
5448     SUBROUTINE PFMAX
5449     #include "cbert.inc"
5450     *KEND.
5451     REAL * 8 WK
5452     SAVE
5453     C
5454     I=I2
5455     IF(CURR(1)-2.0)20,10,10
5456     10 I=I+3
5457     20 WK=WKRPN(I)
5458     IF(WK-160.0)30,30,50
5459     30 FMAX(1)=0.176D-24
5460     FMAX(2)=0.52D-24
5461     FMAX(3)=0.0
5462     FMAX(4)=0.0
5463     40 RETURN
5464     50 CALL CBOVER(WK,DNCMS,UNIV)
5465     IF(WK-400.0)60,110,110
5466     60 IF(WK-300.0)70,100,100
5467     70 IF(WK-200.0)80,90,90
5468     80 FMAX(3)=1.95D-27*UNIV
5469     C 3 AND 4 AT 465 MEV
5470     FMAX(4)=1.7D-27*UNIV
5471     FMAX(1)=0.103D-24
5472     FMAX(2)=0.313D-24
5473     GOTO40
5474     90 FMAX(1)=0.09D-24
5475     C 1 AND 2 AT 35 MEV
5476     FMAX(2)=0.26D-24
5477     FMAX(3)=11.4D-27*UNIV
5478     C 3 AND 4 AT 630 MEV
5479     FMAX(4)=11.2D-27*UNIV
5480     GOTO40
5481     100 FMAX(1)=28.0D-27*UNIV
5482     C 1 AND 2 AT 100 MEV
5483     FMAX(2)=0.073D-24
5484     FMAX(3)=20.0D-27*UNIV
5485     C 3 AND 4 AT 780 MEV
5486     FMAX(4)=14.0D-27*UNIV
5487     GOTO40
5488     110 FMAX(1)=27.2D-27*UNIV
5489     C 1 AND 2 AT 155 MEV
5490     FMAX(2)=48.0D-27*UNIV
5491     FMAX(3)=22.6D-27*UNIV
5492     C 3 AND 4 AT 1020 MEV
5493     FMAX(4)=14.0D-27*UNIV
5494     GOTO40
5495     C FMAX(1)=(P-P)S---(2)=(P-N)S---(3)=(P-P)S.P.---(4)=(P-N)S.P.
5496     END
5497     *CMZ : 0.92/00 02/12/92 16.02.26 by Christian Zeitnitz
5498     *-- Author :
5499     SUBROUTINE PINST
5500     #include "cbert.inc"
5501     *KEND.
5502     SAVE
5503     C
5504     I1=0
5505     MED=CLSM
5506     IF(INC)10,140,10
5507     10 INC=0
5508     IF(MED-1)20,50,40
5509     20 I1=1
5510     30 RETURN
5511     40 IF(MED-3)60,90,20
5512     50 IPEC(12)=IPEC(12)+1
5513     C INCIDENT PARTICLE ON REG.1 COLLISION IN REG.1
5514     GOTO30
5515     60 IF(D(4))80,70,80
5516     70 IPEC(8)=IPEC(8)+1
5517     GOTO30
5518     C INC. PARTICLE ON REG.2 COLLISION IN REG.2
5519     80 IPEC(9)=IPEC(9)+1
5520     C INC. PARTICLE ON REG.1 COLLISION IN REG.2
5521     GOTO30
5522     90 IF(D(3))100,120,100
5523     100 IF(D(4))110,130,110
5524     110 IPEC(5)=IPEC(5)+1
5525     C INC. PARTICLE ON REG.1 COLLISION IN REG.3
5526     GOTO30
5527     120 IPEC(3)=IPEC(3)+1
5528     C INC. PARTICLE ON REG.3 COLLISION IN REG.3
5529     GOTO30
5530     130 IPEC(4)=IPEC(4)+1
5531     C INC. PARTICLE ON REG.2 COLLISION IN REG.3
5532     GOTO30
5533     140 K=CURR(11)
5534     K=3*(MED-1)+K
5535     CC(K)=CC(K)+1.0
5536     GOTO30
5537     C COLLISION REG.1 PARTICLE ORIGIN K
5538     END
5539     *CMZ : 0.90/00 29/07/92 11.28.53 by Christian Zeitnitz
5540     *-- Author :
5541     SUBROUTINE CAPOL1(CS,SI)
5542     C
5543     #include "crandm.inc"
5544     *KEND.
5545     C
5546     REAL*8 CS, SI
5547     C
5548     CS = RANDC(ISEED)
5549     S = 2.0 * RANDC(ISEED) - 1.0
5550     IF(S.LT.0) CS = -CS
5551     SI = DSQRT(1.0-(CS*CS))
5552     RETURN
5553     END
5554     *CMZ : 1.01/04 10/06/93 14.43.38 by Christian Zeitnitz
5555     *-- Author :
5556     SUBROUTINE PSTOR
5557     #include "cbert.inc"
5558     *KEND.
5559     SAVE
5560     C
5561     L=(I1*12)-28
5562     IF(I2)10,60,70
5563     10 JJ=0
5564     IF(PM(3)-DNCMS)30,30,20
5565     20 I1=I1+1
5566     JJ=1
5567     C X-Y-Z-COORDINATES OF COLLISION POINT
5568     30 UNIV=DSQRT(PXYZ(I1)*PXYZ(I1)+PXYZ(I1+4)*PXYZ(I1+4)+PXYZ(I1+8)
5569     +*PXYZ(I1+8))
5570     K=I1+8
5571     DO40 I=I1,K,4
5572     PT(L)=PXYZ(I)/UNIV
5573     40 L=L+1
5574     I1=I1-JJ
5575     50 PT(L)=CLSM
5576     PT(L+1)=CURR(11)
5577     PT(L-6)=C(1)
5578     PT(L-5)=C(2)
5579     PT(L-4)=C(3)
5580     RETURN
5581     60 K=14
5582     GOTO90
5583     70 IF(I2-2)80,110,110
5584     80 K=17
5585     90 UNIV=DSQRT(PNIDK(K)*PNIDK(K)+PNIDK(K+1)*PNIDK(K+1)+PNIDK
5586     +(K+2)*PNIDK(K+2))
5587     J=K+2
5588     DO100 I=K,J
5589     PT(L)=PNIDK(I)/UNIV
5590     100 L=L+1
5591     GOTO50
5592     110 UNIV=DSQRT(PT(L-3)*PT(L-3)+PT(L-2)*PT(L-2)+PT(L-1)*PT(L-1))
5593     K=L-1
5594     M=L-3
5595     DO120 I=M,K
5596     PT(L)=PT(I)/UNIV
5597     120 L=L+1
5598     GOTO50
5599     END
5600     *CMZ : 1.01/04 10/06/93 14.43.38 by Christian Zeitnitz
5601     *-- Author :
5602     SUBROUTINE CAPUNP
5603     #include "cbert.inc"
5604     #include "crn.inc"
5605     #include "cmunpu.inc"
5606     *KEND.
5607     REAL*8 AC,ZC,AR,ZE
5608     SAVE
5609     C
5610     IF(PGVC(1))10,60,30
5611     10 I1=-1
5612     20 RETURN
5613     30 PGVC(1)=PGVC(1)-11.0
5614     K=PGVC(1)+2.005
5615     DO40 I=1,11
5616     CURR(I)=PGVC(K)
5617     PGVC(K)=0.0
5618     40 K=K+1
5619     50 I1=1
5620     GOTO20
5621     60 IF(PLVC(1))10,130,70
5622     70 UNIV=0.0
5623     L=PLVC(1)
5624     K=-10
5625     DO110 I=1,L
5626     80 K=K+12
5627     IF(PLVC(K))10,80,90
5628     90 IF(PLVC(K)-UNIV)110,100,100
5629     100 UNIV=PLVC(K)
5630     M=K
5631     110 CONTINUE
5632     PLVC(M)=0.0
5633     DO120 I=1,11
5634     M=M+1
5635     CURR(I)=PLVC(M)
5636     120 PLVC(M)=0.0
5637     PLVC(1)=PLVC(1)-1.0
5638     GOTO50
5639     130 I1=0
5640     AC=AMASNO
5641     IF(NO.GT.2)GOTO140
5642     ZC=ZEE
5643     AC=AMASNO+1.0D0
5644     C AC-COMPOUND NUC,ZC=CHG.COMPOUND,AR=MASS CASCADE RESID.NUCLEUS
5645     IF(NO.EQ.1)GOTO150
5646     GOTO160
5647     140 IF(NO.LT.5)GOTO150
5648     ZC=ZEE-1.0D0
5649     GOTO160
5650     150 ZC=ZEE+1.0D0
5651     160 AR=AC-COUNT(1)-COUNT(2)
5652     ZE=COUNT(1)+COUNT(3)-COUNT(5)
5653     IF(AR)170,180,190
5654     170 COUNT(7)=COUNT(7)+1.0D0
5655     GOTO210
5656     180 IF(ZC.EQ.ZE)GOTO20
5657     COUNT(8)=COUNT(8)+1.0D0
5658     GOTO210
5659     190 IF(AR.GE.(ZC-ZE))GOTO200
5660     COUNT(9)=COUNT(9)+1.0D0
5661     GOTO210
5662     200 IF(ZC.GE.ZE)GOTO20
5663     COUNT(10)=COUNT(10)+1.0D0
5664     210 IF(BEGRU.EQ.1.0D0)GOTO260
5665     BEGRU=BEGRU-1.0D0
5666     220 DO230 I=1,12
5667     CC(I)=PCC(I)
5668     230 IPEC(I)=NIP(I)
5669     DO 240 I = 1,5
5670     240 PNBC(I)=PPNB(I)
5671     250 NOR=NOR-1
5672     COUNT(6)=-1.0D0
5673     GO TO 20
5674     260 BEGRU=-1.0D0
5675     GO TO 220
5676     C 1. PICKS UP LAST 11 ITEMS IN PGVC AND STORES
5677     C THEM IN CURR. STORES ZERO IN THOSE 11 PGVC CELLS.
5678     C GROUP IS GREATER THAN 1ST IN ALL OTHER GROUPS. STORES
5679     C 2-12TH ITEMS IN CURR--ZEROES ITEMS 1-12 IN PLVC GROUP.
5680     END
5681     *CMZ : 1.05/03 27/06/2001 17.24.29 by Christian Zeitnitz
5682     *-- Author : Christian Zeitnitz 20/05/92
5683     DOUBLE PRECISION FUNCTION RANDC(DUMMY)
5684     C
5685     integer DUMMY
5686     DIMENSION RND1(1)
5687     C
5688     CALL GRNDM(RND1,1)
5689     RANDC = RND1(1)
5690     RETURN
5691     END
5692     *CMZ : 0.92/00 02/12/92 16.02.26 by Christian Zeitnitz
5693     *-- Author :
5694     SUBROUTINE ROUT10
5695     C
5696     #include "cbert.inc"
5697     *KEND.
5698     C
5699     I3=0
5700     IF(EX-D(4))40 ,40 ,10
5701     10 CALL SPAC32(31)
5702     GO TO 20
5703     20 I3=-1
5704     30 RETURN
5705     40 CURR(2)=OUT(15)
5706     WKRPN(1)=OUT(15)
5707     WKRPN(4)=OUT(18)
5708     C K.E. FOR PROTONS AND NEUTRONS REGION 1
5709     GO TO 30
5710     END
5711     *CMZ : 0.92/00 02/12/92 16.02.26 by Christian Zeitnitz
5712     *-- Author :
5713     SUBROUTINE ROUT11(T)
5714     SAVE
5715     C
5716     #include "cbert.inc"
5717     *KEND.
5718     C
5719     REAL *8 T(6426)
5720     GO TO (10 ,30 ,40 ,20 ),I3
5721     10 PT(2)=3.0
5722     20 IK=IT
5723     PT(14)=1.0
5724     30 PM(3)=PNMS
5725     40 IF(340.0-RLKE)50 ,70 ,70
5726     50 I3=1
5727     60 RETURN
5728     70 CALL CALMUD(SNT,INPT)
5729     IF(IK-3)100,80 ,90
5730     80 I3=2
5731     GO TO 60
5732     90 I3=3
5733     GO TO 60
5734     100 CALL CRDET(51,T(1),RLKE)
5735     I3=4
5736     GOTO60
5737     END
5738     *CMZ : 0.92/00 02/12/92 16.02.26 by Christian Zeitnitz
5739     *-- Author :
5740     SUBROUTINE ROUT12
5741     C
5742     #include "cbert.inc"
5743     #include "crun.inc"
5744     *KEND.
5745     C
5746     I3=0
5747     CALL CAAZIO(SOPC,SOPS)
5748     CALL CACOLL(0)
5749     IF(COL(15))10 ,30 ,10
5750     10 I3=-1
5751     20 RETURN
5752     30 IF(KE)10 ,50 ,40
5753     40 COM = (E(4)-DNCMS)/RCPMV
5754     GO TO 60
5755     50 CALL COLE4
5756     60 I1= -1
5757     VALUE1=COM
5758     IF(PT(14)-2.0)70 ,20 ,20
5759     70 I3=1
5760     GOTO20
5761     END
5762     *CMZ : 0.92/03 10/12/92 10.53.45 by Christian Zeitnitz
5763     *-- Author :
5764     SUBROUTINE ROUT13
5765     SAVE
5766     #include "cbert.inc"
5767     *KEND.
5768     C
5769     I3=0
5770     IF(IV)10 ,50 ,50
5771     10 IF(XABS)20 ,50 ,20
5772     20 IF(IFCA-2)30 ,70 ,60
5773     30 IN=0
5774     40 I3=1
5775     GOTO90
5776     50 CALLSIGNEX
5777     IF(IFC-12)120,120,130
5778     60 IF(IFCA-6)70 ,30 ,100
5779     70 IN=0
5780     80 I3=-1
5781     90 RETURN
5782     100 IF(IFCA-8)30 ,110,110
5783     110 IN=1
5784     GOTO40
5785     120 IN=0
5786     GOTO90
5787     130 IF(IFC-18)140,140,150
5788     140 IN=-1
5789     GOTO90
5790     150 IN=1
5791     GOTO90
5792     END
5793     *CMZ : 0.92/03 10/12/92 10.54.08 by Christian Zeitnitz
5794     *-- Author :
5795     SUBROUTINE ROUT14
5796     SAVE
5797     C
5798     #include "cbert.inc"
5799     #include "crun.inc"
5800     *KEND.
5801     C
5802     IF(I3)310,270,10
5803     10 IF(I1)20 ,80 ,80
5804     20 I1=0
5805     VALUE1=(E(3)-PM(3))/RCPMV
5806     IF(XABS)30 ,40 ,30
5807     30 VALUE1=VALUE1+ABSEC
5808     40 IF(PT(2)-2.0)70 ,50 ,80
5809     C PT(2)=1=PROTON PT(2)=2=NEUTRON PT(2)=3,4,5=PION
5810     50 I3=2
5811     60 GO TO 320
5812     70 I3=1
5813     GOTO60
5814     80 CALLPINST
5815     IF(I1)90 ,100,90
5816     90 I3=3
5817     GOTO60
5818     100 I1=0
5819     M=PT(2)
5820     VALUE2=VALUE1
5821     IF(M-3)110,150,150
5822     110 IF(ECO(M)-VALUE2)140,120,130
5823     120 IF(ECO(M))90 ,90 ,130
5824     130 PT(I1+3)=0.0
5825     PNBC(M)=PNBC(M)+1.0
5826     GOTO230
5827     140 PT(I1+3)=VALUE2
5828     IF(I1)300,240,300
5829     150 CCOFE=CLCFE
5830     IF(M-4)160,170,170
5831     160 IF(STRKP+2.0)200,190,200
5832     170 IF(STRKP+2.0)200,200,180
5833     180 CCOFE=CLCFE-CTOFE+CTOFEN
5834     GOTO200
5835     190 CCOFE=CLCFE+CTOFE-CTOFEN
5836     200 IF(VALUE2-CCOFE)130,130,210
5837     210 IF(STRKP+2.0)220,220,140
5838     220 PT(3)=VALUE1-SPACE(MED+3)+SPACE(MED+9)
5839     230 IF(I1)260,240,260
5840     240 M=PT(14)
5841     IF(M-3)250,90 ,90
5842     250 VALUE2=COM
5843     I1=12
5844     GOTO110
5845     260 IF(PT(3))300,270,300
5846     270 CALLCAPUNP
5847     IF(I1)90 ,280 ,290
5848     C -, =ERROR 0=END OF RECORD +=PISCC(6607)
5849     280 I3=4
5850     GOTO60
5851     290 I3=5
5852     GOTO60
5853     300 CALL COLLM(-1)
5854     310 IF(KE.GT.0)GO TO 320
5855     CALL CASTPR
5856     IF(I1)90 ,270,90
5857     320 RETURN
5858     END
5859     *CMZ : 0.92/00 02/12/92 16.02.26 by Christian Zeitnitz
5860     *-- Author :
5861     SUBROUTINE ROUT15(T)
5862     SAVE
5863     REAL*8 T(6426)
5864     #include "cbert.inc"
5865     #include "crandm.inc"
5866     *KEND.
5867     C
5868     GOTO(10 ,80 ,20 ,100),I3
5869     10 IF(RLKE.LE.2.5D3) GO TO 40
5870     20 I3=4
5871     30 GO TO 160
5872     40 IF(IK-3)70 ,50 ,60
5873     50 I3=1
5874     GOTO30
5875     60 I3=2
5876     GOTO30
5877     70 CALL CALMUD(SNT,INPT)
5878     CALL CRDET(51,T(1),RLKE)
5879     I2 = 0
5880     CST = CRDT(2) - DABS(SNT*(CRDT(2) - CRDT(1)))
5881     80 IF(I2)90 ,90 ,20
5882     90 I3=3
5883     GOTO30
5884     100 VALUE1 = RANDC(ISEED)
5885     IF(VALUE1-CRDT(1))150,110,110
5886     110 VALUE2=1.0
5887     C SCATT. FORWARD
5888     VALUE1= RANDC(ISEED)
5889     IF(VALUE1-CRDT(4))120,140,140
5890     120 VALUE1 = RANDC(ISEED)
5891     C TO SAMPLE FROM UNIFORM DIST.
5892     130 CST=VALUE1*VALUE2
5893     GOTO90
5894     140 COM=0.0
5895     CALL CABIG7(COM,VALUE1,I1)
5896     GOTO130
5897     150 VALUE2=-1.0
5898     VALUE1 = RANDC(ISEED)
5899     I1=I1+I2
5900     IF(VALUE1-CRDT(2))120,140,140
5901     160 RETURN
5902     END
5903     *CMZ : 0.92/00 02/12/92 16.02.26 by Christian Zeitnitz
5904     *-- Author :
5905     SUBROUTINE ROUT16(T)
5906     REAL*8 T(6426)
5907     C
5908     #include "cbert.inc"
5909     *KEND.
5910     C
5911     CALL CALMUD(SNT,INPT)
5912     CALL CRDET(51,T(1),RLKE)
5913     I2 = 0
5914     CST = CRDT(2) - DABS(SNT*(CRDT(2) - CRDT(1)))
5915     GO TO (10 ,30 ,40 ), I3
5916     10 I3=-1
5917     20 RETURN
5918     30 I3=0
5919     GOTO20
5920     40 I3=1
5921     GOTO20
5922     END
5923     *CMZ : 0.92/00 02/12/92 16.02.26 by Christian Zeitnitz
5924     *-- Author :
5925     SUBROUTINE ROUT17(T,B,R,W,G)
5926     C
5927     #include "crandm.inc"
5928     #include "cbert.inc"
5929     *KEND.
5930     C
5931     REAL*8 T(117),B(101),R(117),W(234),G(234)
5932     SAVE
5933     C
5934     IF(I3)10 ,10 ,150
5935     10 PT(38)=0.0
5936     C 1-ALPHA PART.6+1
5937     VALUE1=RLKE-180.0
5938     CALL CRDET(1,T(1),VALUE1)
5939     COM2=CRDT(1)
5940     FTR=DNCMS*RLKE*2.0*RCPMV+2.9877156D27
5941     C E**2=MIN**2+NCNMS*RLKE*2*RCPMV
5942     UNIVER=DSQRT(FTR)
5943     C E
5944     20 VALUE2 = RANDC(ISEED)
5945     COM=VALUE2*COM2
5946     C R-PRIME
5947     CALL CAGENE(B(1))
5948     COM1=(COM*COM+FTR-.501264D26)/(2.0*UNIVER)
5949     C M1R PRIME)**2+E**2-2(PNMS)/2E=E ALPHA
5950     A=COM1*COM1-COM*COM
5951     IF(A)30 ,40 ,40
5952     30 PACNT=PACNT+1.0
5953     GO TO 20
5954     40 UNIVE=((UNIVER-COM1)*COM1/UNIVER)*DSQRT(A)
5955     C ((E BETA*E ALPHA*P ALPHA)/E)=F(M,TR)
5956     CALL CRDET(1,R(1),VALUE1)
5957     C (PI-NUC)FMAX(RLKE)ISOBAR SAMPLING S.P.
5958     COM1 = RANDC(ISEED)
5959     IF((UNIVE/CRDT(1))-COM1)20 ,50 ,50
5960     C RANDOM NO. LESS OR EQUAL THAN F(M,TR)/FMAX(TR)
5961     50 CALLCANGID
5962     PM(3)=COM
5963     PM(4)=POMS
5964     PT(2)=3.0
5965     PT(4)=POMS
5966     PT(14)=3.0
5967     PT(16)=POMS
5968     PT(26)=1.0
5969     PT(28)=DNCMS
5970     IF(ISW(9))70 ,60 ,70
5971     60 IF(ISW(10))110 ,100 ,110
5972     70 IF(ISW(10))120 ,80 ,120
5973     80 I3=-1
5974     90 RETURN
5975     100 VALUE1=.4
5976     VALUE2=6.6666667D-1
5977     VALUE3=0.0
5978     GO TO 140
5979     110 CALL CRDET(2,W(1),VALUE1)
5980     C (PICH-P)FRACT. FIN.STA.WITH RECL. PI1 PI0 L.E.
5981     VALUE3=3.3333333D-1
5982     GO TO 130
5983     120 CALL CRDET(2,G(1),VALUE1)
5984     VALUE3=STRKP
5985     C (PIN-P)FRACT.FIN.STA.WITH RECL.PI1 PIO L.E.
5986     130 VALUE1=CRDT(1)
5987     VALUE2=CRDT(2)
5988     140 CALL CALPHA
5989     150 CALL CAECPL
5990     IF(I1)160 ,160 ,80
5991     160 CALL CACOLL(-1)
5992     IF(COL(15))80 ,170 ,80
5993     170 IF(PT(38))180 ,190 ,180
5994     180 I3=0
5995     GO TO 90
5996     190 PT(39)=0.0
5997     PT(3)=((E(4)-PM(4))/RCPMV)+PT(3)
5998     I3=1
5999     GO TO 90
6000     END
6001     *CMZ : 1.01/04 10/06/93 14.43.38 by Christian Zeitnitz
6002     *-- Author :
6003     SUBROUTINE ROUT18
6004     SAVE
6005     C
6006     #include "cbert.inc"
6007     *KEND.
6008     C
6009     GOTO(10 ,20 ,80 ,210 ,170 ,190 ),I3
6010     10 I=3
6011     COL(15)=1.0
6012     K=27
6013     GO TO 30
6014     20 I=3
6015     COL(15)=4.0
6016     K=15
6017     30 PNIDK(1)=PM(I)
6018     J=I
6019     DO40 L=2,4
6020     PNIDK(L)=PXYZ(J)
6021     40 J=J+4
6022     PNIDK(5)=E(I)
6023     PNIDK(6)=PT(K-11)
6024     CALLCALIDK
6025     IF(K-27)60 ,50 ,60
6026     50 PT(15)=PT(15)+((PNIDK(12)-PNIDK( 6))/RCPMV)
6027     60 PT(K)=PT(K)+((PNIDK(13)-DNCMS)/RCPMV)
6028     I3=1
6029     70 IV=K
6030     RETURN
6031     80 K=3
6032     COL(15)=2.0
6033     IF(PT(2)-3.0)170 ,90 ,90
6034     90 IF(PT(K)-2500.0)110 ,110 ,100
6035     100 I3=5
6036     GOTO70
6037     110 IF(PT(K))150 ,150 ,120
6038     120 CCOFE = ECO(1)
6039     IF(PT(K-1)-4.0) 140 ,130 ,130
6040     130 CCOFE = CCOFE - CTOFE + CTOFEN
6041     140 IF(PT(K) - CCOFE ) 150 ,150 ,160
6042     150 M=PT(K-1)
6043     PNBC(M)=PNBC(M)+1.0
6044     PT(K)=0.0
6045     I3=3
6046     GOTO70
6047     160 IF(K-3)170 ,170 ,210
6048     170 COL(15)=3.0
6049     K=15
6050     IF(PT(14)-2.0)180,180,90
6051     180 I3=2
6052     GOTO70
6053     190 L=14
6054     DO200 M=5,7
6055     PT(M)=PNIDK(L)
6056     PT(M+12)=PNIDK(L+3)
6057     200 L=L+1
6058     PT(11)=PNIDK(12)
6059     PT(12)=PNIDK(6)
6060     I=4
6061     K=39
6062     COL(15)=5.0
6063     GO TO 30
6064     210 I1=3
6065     220 K=12*I1-33
6066     IF(I1-4)230 ,240 ,250
6067     230 I2=-1
6068     GO TO 280
6069     240 I2=0
6070     GO TO 280
6071     250 IF(I1-5)240 ,270 ,260
6072     260 I3=4
6073     GO TO 70
6074     270 I2=1
6075     280 IF(PT(K))290 ,300 ,290
6076     290 CALL PSTOR
6077     300 I1=I1+1
6078     GO TO 220
6079     END
6080     *CMZ : 0.92/00 02/12/92 16.02.26 by Christian Zeitnitz
6081     *-- Author :
6082     SUBROUTINE ROUT19
6083     SAVE
6084     C
6085     #include "cbert.inc"
6086     *KEND.
6087     C
6088     PT(3)=PT(3)+((PT(11)-PT(12))/RCPMV)
6089     C COLLISION ALLOWED
6090     K=3
6091     10 IF(PT(K)-2500.0)30 ,30 ,20
6092     20 I3=1
6093     GO TO 90
6094     30 IF(PT(K))70 ,70 ,40
6095     40 CCOFE = ECO(1)
6096     IF(PT(K-1)-4.0) 60 ,50 ,50
6097     50 CCOFE = CCOFE - CTOFE + CTOFEN
6098     60 IF(PT(K) - CCOFE) 70 ,70 ,170
6099     70 PT(K)=0.0
6100     IF(PT(K-1)-3.0)80 ,110 ,100
6101     80 I3=-1
6102     90 RETURN
6103     100 IF(PT(K-1)-5.0)110 ,110 ,80
6104     110 M=PT(K-1)
6105     PNBC(M)=PNBC(M)+1.0
6106     GOTO140
6107     120 I2=2
6108     130 I1=(K/12)+3
6109     CALLPSTOR
6110     140 IF(K-15)150 ,160 ,190
6111     150 K=15
6112     IF(PT(15))160 ,160 ,120
6113     160 K=27
6114     PT(27)=PT(27)+((PNIDK(12)-PT(K+1))/RCPMV)
6115     GOTO10
6116     170 IF(K-15)120 ,180 ,180
6117     180 I2=0
6118     GOTO130
6119     190 IF(K-27)80 ,200 ,210
6120     200 IF(PT(39))210 ,210 ,220
6121     210 I3=0
6122     GOTO90
6123     220 I2=1
6124     K=39
6125     GOTO130
6126     END
6127     *CMZ : 1.01/04 10/06/93 14.43.38 by Christian Zeitnitz
6128     *-- Author :
6129     SUBROUTINE ROUT20(T,B,R,W,G)
6130     REAL*8 T(115),B(80),R(239),W(60),G(55)
6131     #include "cbert.inc"
6132     *KEND.
6133     SAVE
6134     C
6135     GO TO (10 ,50 ,70 ,80 ,190 ,200 ,290 ,60 ),I3
6136     10 PM(4)=DNCMS
6137     CALL PINST
6138     IF(I1)20 ,40 ,20
6139     20 I3=1
6140     30 RETURN
6141     40 I3=2
6142     GOTO30
6143     50 ISW(9)=0
6144     60 ISW(10)=2
6145     I3=3
6146     GOTO30
6147     C PI MESON - SINGLE PRODUCTION
6148     70 PT(2)=2.0
6149     I3=4
6150     GOTO30
6151     C COLLISION PARTICLE PI-
6152     80 PT(2)=2.0
6153     PT(14)=1.0
6154     90 PM(3)=DNCMS
6155     IF(740.0-RLKE)140 ,100 ,100
6156     100 IF(300.0-RLKE)110 ,130 ,130
6157     110 VALUE1=RLKE-300.0
6158     CALLCRDET(5,T(1),VALUE1)
6159     C (N-P)DIFF.CRS.INT.EN.
6160     I1=3
6161     I2=3
6162     120 I3=5
6163     GOTO30
6164     130 CALLCRDET(5,B(1),RLKE)
6165     C (N-P)DIFF.CRS.LOW EN.
6166     I1=3
6167     I2=1
6168     GOTO120
6169     140 IF(3500.0-RLKE)20 ,150 ,150
6170     150 IF(IT-17)160 ,20 ,20
6171     160 CALL DCINTP(R(1))
6172     C (N-P)DIFF.CRS.HIGH EN.
6173     170 IF(I1)20 ,180,180
6174     180 I3=6
6175     GOTO30
6176     190 PT(2)=1.0
6177     PT(14)=2.0
6178     GOTO90
6179     200 PT(2)=2.0
6180     PT(14)=2.0
6181     210 PM(3)=DNCMS
6182     IF(500.0-RLKE)230 ,220,220
6183     220 I3=7
6184     GOTO30
6185     230 IF(1000.0-RLKE)270 ,240 ,240
6186     240 CALL CADCPR(W(1),12)
6187     IF(I2.EQ.1) GO TO 20
6188     C SAMPLE + MU IN CST
6189     250 SNT=DSQRT(1.0-CST*CST)
6190     C P-P SCATTERING
6191     260 I3=8
6192     GOTO30
6193     C -, SCATTERING BACKWARD, MU LESS THAN 0
6194     270 IF(3500.0-RLKE)20 ,280 ,280
6195     280 CALL CADCPR(G(1),11)
6196     IF(I2.EQ.1) GO TO 20
6197     C (P-P)DIFF.CRS.SEC.HIGH EN.
6198     GOTO170
6199     290 PT(2)=1.0
6200     PT(14)=1.0
6201     GOTO210
6202     C NO PION PRODUCTION POSSIBLE
6203     END
6204     *CMZ : 0.92/00 02/12/92 16.02.26 by Christian Zeitnitz
6205     *-- Author :
6206     SUBROUTINE ROUT21(V,W,X,Y,Z)
6207     C
6208     #include "crandm.inc"
6209     #include "cbert.inc"
6210     *KEND.
6211     C
6212     REAL*8 V(161),W(101),X(161),Y(130),Z(176)
6213     SAVE
6214     C
6215     VALUE2=RLKE*4.81633308D24+9.0554256D27
6216     C E(TR)**2=RLKE*RCPMV*2*NCMS+4*NCMS**2
6217     VALUE3=DSQRT(VALUE2)
6218     GO TO (10 ,100 ,110 ,240 ),I3
6219     10 ISW(12)=0
6220     20 PT(38)=0.0
6221     I1=0
6222     ANS=RLKE
6223     30 VALUE1=ANS-300.0
6224     CALL CRDET(1,V(1),VALUE1)
6225     C (NUC-NUC) F(TR) ISOBAR SAMPLING
6226     FTR=CRDT(1)
6227     40 SN = RANDC(ISEED)
6228     COM=SN*FTR
6229     C R PRIME=F(TR)*RANDOM
6230     CALL CAGENE(W(1))
6231     C (NUC-NUC)MASS OF ISOBAR S.P. M(R PRIME)
6232     IF(I1)130 ,50 ,140
6233     50 COM1=(COM*COM-SQNM+VALUE2)/(2.0*VALUE3)
6234     C E GAMMA
6235     A=COM1*COM1-COM*COM
6236     IF(A)60 ,70 ,70
6237     60 PGCNT=PGCNT+1.0
6238     GOTO40
6239     C
6240     CZ changed in order to keep exponent small 5/21/92
6241     70 UNIVER=DSQRT(A)*COM1*(1.0D0-COM1/VALUE3)
6242     CZ end of change
6243     CZ
6244     C F(M,TR)=P GAMMA*E GAMMA*E DELTA/E
6245     CALL CRDET(1,X(1),VALUE1)
6246     C (NUC-NUC)FMAX(TR) ISOBAR SAMPLING S.P.
6247     COM1 = RANDC(ISEED)
6248     IF(COM1-(UNIVER/CRDT(1)))80 ,80 ,40
6249     80 PM(4)=DNCMS
6250     PM(3)=COM
6251     CALL CANGID
6252     PT(4)=DNCMS
6253     PT(28)=DNCMS
6254     CALL CALP19
6255     90 RETURN
6256     100 ISW(12)=2
6257     GOTO20
6258     110 ISW(13)=0
6259     120 I1=-1
6260     ANS=((VALUE3-PNMS)**2-9.0554256D27)/4.81633308D24
6261     GO TO 30
6262     C TR PRIME COM1=RLKE PRIME
6263     130 COM1=((VALUE3+DNCMS-COM)**2-9.0554256D27)/4.81633308D24
6264     COM2=COM
6265     ANS=COM1
6266     COM4=FTR
6267     I1=1
6268     GO TO 30
6269     140 COM1=(COM2*COM2-COM*COM+VALUE2)/(2.0*VALUE3)
6270     C E EPSILON
6271     A=COM1*COM1-COM2*COM2
6272     IF(A)150 ,160 ,160
6273     150 PECNT=PECNT+1.0
6274     GOTO170
6275     C F(M1,M2,TR)=P EPSILON*E EPSILON*E ZETA/E
6276     C
6277     CZ changed in order to keep exponent small 5/21/92
6278     160 UNIVER=DSQRT(A)*COM1*(1.0D0-COM1/VALUE3)
6279     CZ end of change
6280     CZ
6281     VALUE1=RLKE-920.0
6282     CALLCRDET(1,Y(1),VALUE1)
6283     C (NUC-NUC)FMAX(TR) ISOBAR SAMPLING D.P. FMAX(M1,M2,TR)
6284     SN = RANDC(ISEED)
6285     IF(SN-(UNIVER*FTR/(CRDT(1)*COM4)))180 ,180 ,170
6286     170 FTR=COM4
6287     I1=-1
6288     GOTO40
6289     180 VALUE1 = RANDC(ISEED)
6290     IF(VALUE1-.5)190 ,190 ,200
6291     190 PM(3)=COM2
6292     PM(4)=COM
6293     GOTO210
6294     200 PM(3)=COM
6295     PM(4)=COM2
6296     210 CALLCANGID
6297     PT(16)=DNCMS
6298     PT(40)=DNCMS
6299     IF(ISW(13))220 ,230 ,220
6300     220 CALL CRDET(1,Z(1),RLKE)
6301     VALUE1=CRDT(1)
6302     C (N-P)FRACT.FIN.STA.3/2 L.E.
6303     230 PT(2)=3.0
6304     PT(4)=POMS
6305     PT(14)=1.0
6306     PT(26)=3.0
6307     PT(28)=POMS
6308     PT(38)=1.0
6309     CALL CALP28
6310     GO TO 90
6311     240 ISW(13)=2
6312     GO TO 120
6313     END
6314     *CMZ : 1.01/04 10/06/93 14.43.38 by Christian Zeitnitz
6315     *-- Author :
6316     SUBROUTINE ROUT22(V,W,X,Y,Z)
6317     REAL*8 V(19),W(19),X(126),Y(126),Z(126)
6318     #include "cbert.inc"
6319     *KEND.
6320     SAVE
6321     C
6322     I5=CURR(1)
6323     GOTO(270 ,1070,340 ,350 ,370 ,1040,520 ,1110,1170,460 ,1270,440 ,4
6324     +00 ,500 ,1440,10 ,700 ,590 ,260 ,530 ,430 ,1220,1570),IV
6325     10 DO20 I=1,3
6326     XI(I)=CURR(I+3)
6327     20 DCOS(I)=CURR(I+6)
6328     IN=-1
6329     MED=CURR(10)
6330     I5=CURR(1)
6331     CALL CALGEO
6332     IF(I1)60 ,30 ,30
6333     30 IF(CURR(1)-2.0)70 ,680 ,40
6334     40 IF(CURR(1)-4.0)690 ,700 ,50
6335     50 IV=1
6336     60 RETURN
6337     70 ISW(4)=1
6338     C PROTON
6339     80 XABS=0.0
6340     I4=1
6341     I2=MED
6342     IF(I2-1)110,90 ,210
6343     90 I4=6
6344     GOTO210
6345     100 ISW(6)=1
6346     ISW(5)=1
6347     I3=0
6348     IF(COM-3600.0)120 ,120 ,110
6349     110 IV=2
6350     GOTO60
6351     C COM=GREATEST ENERGY INSIDE NUCLEUS FOR NUCLEONS ONLY
6352     120 IF(COM-560.0)130 ,130 ,140
6353     130 IF(COM-160.0)200 ,200 ,190
6354     140 CALLDFMAX
6355     C DFMAX FILLS OUT FMAX(1-6)
6356     I1=6
6357     150 IF(CURR(1)-2.0)170 ,160 ,160
6358     160 I3=1
6359     170 CALLCSTORE
6360     EX=0.0
6361     CALLSIGNEX
6362     GOTO(260 ,370 ,430 ,480 ,400 ,580 ,920 ,1040,1170,180,1440),I4
6363     180 IV=3
6364     GOTO60
6365     190 ISW(6)=0
6366     CALLPFMAX
6367     C PFMAX FILLS OUT FMAX(1-4)
6368     I1=4
6369     GOTO150
6370     200 ISW(5)=0
6371     ISW(6)=0
6372     CALLCALNNN
6373     C NN FILLS OUT FMAX(1-2),FMAX(3-6)=0
6374     I1=2
6375     GOTO150
6376     210 ISW(1)=0
6377     ISW(2)=0
6378     ISW(3)=0
6379     220 M=MED+ INT(15.0-6.0*SNGL(CURR(1)))
6380     A=CURR(2)-SPACE(M)
6381     230 DO240 I=1,3
6382     WKRPN(I)=A+SPACE(I+9)
6383     240 WKRPN(I+3)=A+SPACE(I+3)
6384     250 M=4-3*ISW(4)
6385     COM=WKRPN(M)
6386     GOTO100
6387     260 GOTO(1290,1290,270 ),I2
6388     270 IF(EX-D(2))310 ,310 ,280
6389     C ENTRY POINT FOR CASCADE CHARGED AND NEUTRAL PIONS AFTER CRJAB
6390     C REJECTION,PROD.REACTION LT 180 FERMI REJECTION FOR NON-ABSORPTION
6391     C REACTION ALSO ALL CASCADE NUCLEAR REJECTIONS INCLUDING CRJAB OR
6392     C RLKE LT PROD.THRESHOLD
6393     280 IF(D(3))560 ,290 ,560
6394     290 CALLCCPES
6395     IF(I1)300,300,110
6396     C GO TO CAPUNP
6397     300 IV=4
6398     GOTO60
6399     310 IF(IN) 320 ,320 ,1460
6400     320 CALLCBG6CA(3,0)
6401     IFCC=12
6402     330 MED=CLSM
6403     IV=5
6404     GOTO60
6405     340 VALUE1=EX
6406     IV=6
6407     GOTO60
6408     350 VALUE1=EX+D(3)
6409     360 IV=7
6410     GOTO60
6411     C E.P.FOR REJECTION FOLLOWING CRJAB OR RLKE LT 180 IN PROD.REACTIONS
6412     C AND FOR FERMI REJECTION IN SCATTERING AND PRODUCTION REACTIONS
6413     C FOR CASCADE CHARGED AND NEUTRAL PIONS
6414     370 IF(EX-D(6))310 ,310 ,290
6415     380 ISW(1)=1
6416     390 GOTO(400 ,400 ,400 ,1040),I5
6417     C E.P.FOR ALL REJECTIONS,CRJAB,PRODUCTION,AND FERMI FOR CASCADE
6418     C NUCLEONS
6419     400 IF(EX-D(3))510 ,510 ,410
6420     410 I2=3
6421     I4=2
6422     I3=1
6423     I1=2
6424     IF(D(4))420 ,250 ,420
6425     420 ISW(2)=1
6426     ISW(3)=1
6427     I4=3
6428     I2=1
6429     GOTO250
6430     430 GOTO(440 ,440 ,440 ,1170),I5
6431     440 IF(EX-D(4))450 ,450 ,470
6432     450 CALLCBG6CA(1,0)
6433     IFCC=7
6434     GOTO330
6435     460 VALUE1=EX
6436     IV=8
6437     GOTO60
6438     470 I4=4
6439     I1=2
6440     I2=2
6441     I3=1
6442     GOTO250
6443     C E.P.FOR CASCADE NUCLEONS AND PI0,AFTER CRJAB AND PROD.THRESHOLD
6444     C REJECTIONS
6445     480 IF(I5-2)500 ,500 ,490
6446     490 IF(I5-4)110,1440,110
6447     C E.P.FOR CASCADE NUCLEONS AFTER ALL FERMI REJECTIONS
6448     500 IF(EX-D(5))510 ,510 ,540
6449     510 CALLCBG6CA(2,0)
6450     IFCC=10
6451     GOTO330
6452     520 VALUE1=EX
6453     GOTO360
6454     530 IF(ISW(3))480 ,390 ,480
6455     540 I4=2
6456     I2=3
6457     550 I3=1
6458     I1=2
6459     GOTO250
6460     560 ISW(1)=1
6461     IF(CURR(1)-3.0)570 ,940 ,1390
6462     570 I4=5
6463     I2=2
6464     GOTO550
6465     C D.P.
6466     580 ISW(1)=1
6467     ISW(2)=1
6468     ISW(3)=1
6469     GOTO260
6470     590 ANY=FMAX(NOT)
6471     IF(NOT-5)620 ,600 ,610
6472     600 IV=9
6473     GOTO60
6474     610 IF(I5-4)600 ,630 ,600
6475     620 IF(KNOT-15)630 ,1560,1560
6476     630 GOTO(640 ,640 ,640 ,1510),I5
6477     640 IF(NOT-2)650 ,660 ,670
6478     650 IV=10
6479     GOTO60
6480     660 IV=11
6481     GOTO60
6482     670 IV=12
6483     GOTO60
6484     680 ISW(4)=0
6485     C NEUTRON
6486     GOTO80
6487     690 ISW(11)=1
6488     C CURR(1)=3=PI+ MESON(11575)--PI 0=4(15100)--PI -(14646)
6489     700 IN=1
6490     ISW(1)=0
6491     ISW(2)=0
6492     ISW(3)=0
6493     ISW(5)=1
6494     ISW(6)=0
6495     ISW(7)=0
6496     ISW(8)=1
6497     I6=I5-2
6498     I2=MED
6499     COM=CURR(2)-SPACE(MED+9)
6500     GOTO(720 ,710 ,730 ),MED
6501     C E.P.FOR PI0 AFTER FERMI REJECTION
6502     710 ISW(8)=0
6503     720 ISW(7)=1
6504     730 DO740 I=1,3
6505     WKRPN(I)=COM+SPACE(I+9)
6506     740 WKRPN(I+3)=COM+SPACE(I+3)
6507     COM=COM+SPACE(4)
6508     750 IF(COM-2600.0)760 ,760 ,110
6509     760 IF(COM-100.0)770 ,770 ,780
6510     770 LG=4
6511     GOTO1330
6512     780 LG=6
6513     790 CALLCASPCN
6514     IF(VALUE1)800 ,800 ,830
6515     800 COM=CURR(2)-SPACE(MED+9)
6516     IF(COM-360.0)810 ,830 ,830
6517     810 GOTO(820 ,1350,820 ),I6
6518     820 CALLCRDET(1,V(1),COM)
6519     FMAX(4)=CRDT(1)
6520     830 GOTO(840 ,1360,840 ),I6
6521     840 I1=6
6522     850 I4=7
6523     I2=1
6524     I3=0
6525     GOTO(860 ,870 ,860 ),I6
6526     860 IF(ISW(11))870 ,910 ,870
6527     C PI+
6528     870 IF(ISW(7))880 ,900 ,880
6529     C PI-
6530     880 IF(ISW(8))170 ,890 ,170
6531     890 I2=2
6532     GOTO170
6533     900 I2=3
6534     GOTO170
6535     910 I3=1
6536     GOTO870
6537     920 IF(CURR(1)-2.0)930 ,930 ,260
6538     930 A=CURR(2)-SPACE(MED+9)
6539     GOTO230
6540     940 I4=8
6541     950 I2=2
6542     960 I3=0
6543     I1=LG
6544     IF(CURR(1)-4.0)970 ,1030,970
6545     970 IF(ISW(11))990 ,980 ,990
6546     980 I3=1
6547     990 IF(CURR(1)-3.0)1000,1010,1010
6548     1000 IV=23
6549     GOTO60
6550     1010 IF(LG-4)1000,170 ,1020
6551     1020 M=5-IABS(I5-4)
6552     UNIVER=FMAX(M)
6553     CALLCASPCN
6554     FMAX(M)=UNIVER
6555     GOTO170
6556     1030 I1=I1+1
6557     GOTO1010
6558     C E.P.FOR CHARGED AND NEUTRAL PIONS AFTER CRJAB REJECTION ALSO,AFTER
6559     C RLKE.LE.180 IN PROD.REACTIONS AND AFTER FERMI REJECTION IN SCATTER
6560     C ING AND PROD.REACTIONS
6561     1040 IF(EX-D(3))1050,1050,1140
6562     1050 GOTO(1060,1410,1060),I6
6563     1060 IV=13
6564     GOTO60
6565     1070 ANY=FMAX(NOT)
6566     IF(CURR(1)-3.0)1080,1100,1100
6567     1080 IFC=12
6568     1090 IV=14
6569     GOTO60
6570     1100 IFCC=(CLSM-2.0)*((CLSM*5.5)-8.5)+12.05
6571     GOTO1090
6572     1110 IF(I4-10)1120,1210,1120
6573     C E.P.FOR ESCAPE PRIOR TO CHOOSING REACTIONS--CASCADE CHARGED PION
6574     1120 IF(CLSM-2.0)1130,1210,1130
6575     1130 I4=2
6576     GOTO950
6577     1140 I4=2
6578     C E.P.WHEN CASCADE PARTICLE ESCAPES FROM REGION 2
6579     I2=3
6580     IF(D(4))1160,1150,1160
6581     1150 GOTO(960 ,1450,960 ),I6
6582     1160 ISW(2)=1
6583     ISW(3)=1
6584     I4=9
6585     I2=1
6586     GOTO1150
6587     C E.P.AFTER ALL REJECTIONS EXCEPT FERMI IN ABS.REACTIONS FOR
6588     C CHARGED AND NEUTRAL CC PIONS--ESCAPE FROM REGION 1 PRIOR TO
6589     C CHOOSING REACTION FOR CC CHARGED PION
6590     1170 IF(EX-D(4))1180,1180,1200
6591     1180 GOTO(1190,1480,1190),I6
6592     1190 IV=15
6593     GOTO60
6594     1200 I4=10
6595     GOTO(950 ,1430,950 ),I6
6596     1210 I4=2
6597     I2=3
6598     GOTO960
6599     1220 IF(IN)1240,1230,1240
6600     1230 IV=16
6601     GOTO60
6602     1240 IFCA=8*IABS(I6-2)-11*(I6-1)*(I6-3)
6603     IF(ISW(1))1250,340 ,1250
6604     1250 IF(ISW(2))1260,350,1260
6605     1260 IV=17
6606     GOTO60
6607     1270 IFCA=10*IABS(I6-2)+12*(I6-1)*(3-I6)
6608     IF(ISW(3))1280,520,1280
6609     1280 IV=18
6610     GOTO60
6611     1290 IF(CURR(1)-3.0)1300,1310,1310
6612     1300 GOTO(430 ,380 ),MED
6613     1310 ISW(1)=1
6614     GOTO(1320,1040),MED
6615     1320 ISW(2)=1
6616     ISW(3)=1
6617     GOTO1170
6618     1330 ISW(5)=0
6619     GOTO(1340,1500,1340),I6
6620     1340 CALLCBOVER(CURR(2),PNMS,ANS)
6621     FMAX(1)=.20 D-24*ANS
6622     C (PI+P)SCATTERING
6623     FMAX(2) = 23.0D-27*ANS
6624     C (PIM+P)SCATTERING
6625     FMAX(3)=45.1D-27*ANS
6626     C (PIM+P)EXCHANGE
6627     COM=CURR(2)-SPACE(MED+9)
6628     C (K.E.OF PIONS OUTSIDE NUCLEUS
6629     CALLCRDET(1,V(1),COM)
6630     FMAX(4)=CRDT(1)
6631     C C(PIP+P)ABS.
6632     I1=4
6633     GOTO850
6634     1350 CALLCRDET(1,W(1),COM)
6635     FMAX(5)=CRDT(1)
6636     1360 I1=7
6637     GOTO850
6638     1370 CALLCBG6CA(3,4)
6639     IFCC=24
6640     1380 KA=7
6641     MED=CLSM
6642     IV=19
6643     GOTO60
6644     1390 I4=8
6645     1400 I2=2
6646     GOTO960
6647     1410 CALLCBG6CA(2,3)
6648     1420 IFCC=21
6649     GOTO1380
6650     1430 I4=11
6651     GOTO1400
6652     1440 IF(EX-D(5))1410,1410,1490
6653     1450 I1=9-I5
6654     GOTO960
6655     1460 GOTO(1470,1370,1470),I6
6656     1470 IV=20
6657     GOTO60
6658     1480 CALLCBG6CA(1,2)
6659     GOTO1420
6660     1490 I1=5
6661     GOTO1210
6662     1500 CALLCBOVER(CURR(2),POMS,ANS)
6663     FMAX(1) = 89.2D-27*ANS
6664     C (PI0+P)ELAST.SCAT.
6665     FMAX(2)=45.1D-27*ANS
6666     C (PI0+P)EX.SCAT.
6667     FMAX(3)=FMAX(1)
6668     SPACE(48)=FMAX(1)
6669     FMAX(4)=FMAX(2)
6670     SPACE(49)=FMAX(2)
6671     COM=CURR(2)-SPACE(MED+9)
6672     CALLCRDET(1,W(1),COM)
6673     C (PIN-P)ABS. CRS.SEC.
6674     FMAX(5)=CRDT(1)
6675     C (PI0+P)ABS.
6676     SPACE(50)=FMAX(5)
6677     I1=5
6678     GOTO850
6679     1510 IF(NOT-2)1530,1550,1520
6680     1520 IV=21
6681     GOTO60
6682     1530 CALLCRJAB(1,X(1))
6683     C (PIN-P)DIRECT SCAT.CRS.
6684     1540 IV=22
6685     GOTO60
6686     1550 CALLCRJAB(1,Y(1))
6687     C (PIM-P)XCH.SCAT.CRS.
6688     GOTO1540
6689     1560 IF(KNOT-16)1570,1550,1550
6690     1570 CALLCRJAB(1,Z(1))
6691     C (PIN-N)DRCT.SCAT.CRS.
6692     GOTO1540
6693     END
6694     *CMZ : 1.01/04 10/06/93 14.43.38 by Christian Zeitnitz
6695     *-- Author :
6696     SUBROUTINE ROUT1
6697     SAVE
6698     C
6699     #include "cbert.inc"
6700     *KEND.
6701     C
6702     OUT(11)=ZEE
6703     VALUE2=ZEE**6.6666667D-1
6704     DO10 I=5,7
6705     SPACE(I+2)=OUT(I)*OUT(11)
6706     10 SPACE(I+5)=(OUT(I+3)*VALUE2)+7.0
6707     C SCALED PROTONS PER CC AND POTENTIAL PROTON WELL DEPTH
6708     C (MEV) IN EACH REGION
6709     OUT(12)=AMASNO-OUT(11)
6710     C NO. OF NEUTRONS N, STORED
6711     VALUE2=OUT(12)**6.6666667D-1
6712     C N 2/3
6713     DO20 I=5,7
6714     SPACE(I-4)=OUT(I)*OUT(12)
6715     20 SPACE(I-1)=(OUT(I+3)*VALUE2)+7.0
6716     C SCALED NEUTS. PER CC AND POT. NEUT. WELL DEPTH (MEV)
6717     C IN EACH REGION
6718     DO30 I=1,3
6719     HVN(I)=0.5*SPACE(I+3)
6720     HVP(I)=0.5*SPACE(I+9)
6721     AWD(I)=HVN(I)+HVP(I)
6722     FVNP(I)=0.5*AWD(I)
6723     VNVP(I)=SPACE(I+3)-SPACE(I+9)
6724     PMAC(I)=VNVP(I)-HVN(I)
6725     PPAN(I)=-VNVP(I)-HVP(I)
6726     THPN(I)=HVP(I)-VNVP(I)
6727     FFPTFN(I)=-VNVP(I)+FVNP(I)
6728     TFFN(I)=SPACE(I+9)-FVNP(I)
6729     30 TFFP(I)=VNVP(I)+TFFN(I)
6730     PPPDA=(2.0*ZEE)/(ZEE+AMASNO-1.0)
6731     PPMDA=(2.0*OUT(12))/(AMASNO+OUT(12)-1.0)
6732     PPNDA=(2.0*ZEE*OUT(12))/(AMASNO*AMASNO-AMASNO)
6733     PPNNA=(OUT(12)*OUT(12)-OUT(12))/(OUT(12)*OUT(12)+ZEE*ZEE-AMASNO)
6734     C PION ABSORPTION CALC. FOR EACH REG. 1/2 NWD, (-PNAN, -PPAC)
6735     C 1/2 PWD, (-PNAP, -PNAC) AV. WELL DEPTH, 1/4 AV. WELL DEPTH,
6736     C (N-P)WELL DEPTH, (-VPVN), 1/2NWD -PWD, (PMAP, -VPHN), 1/2PWD -NWD,
6737     C (-VNHP), 3/2PWD -NWD, 5/4PWD -3/4NWD, 3/4PWD -1/4NWD,
6738     C 3/4NWD -1/4PWD, PROB. PIP DEUT ABS, PROB PIM DEUT ABS
6739     C PROB PIN DEUT ABS, PROB PIN NN ABS RATHER THAN PP
6740     K=15
6741     DO40 I=4,6
6742     OUT(K)=SPACE(I+6)+EINC
6743     OUT(K+3)=SPACE(I)+EINC
6744     40 K=K-1
6745     C TOTAL K.E. IN MEV INCIDENT PROTON(NEUTRON)PARTICLE IN EACH REGION
6746     OUT(30)=(ZEE/OUT(4))*1.4412D-13
6747     C COULOMB POTENTIAL AT SURFACE IN MEV. CONVERSION
6748     C FACTOR=MEV-CM PER PROTON (BG33)
6749     IF(CTOFE)60,50,60
6750     50 CTOFE=OUT(30)
6751     C IF CTOFE=0,THEN EQUATE IT TO1/2 POTENTIAL ENERGY AT SURFACE
6752     60 DO70 I=1,3
6753     CFEPN(I+3)=SPACE(I+3)+CTOFEN
6754     70 CFEPN(I)=SPACE(I+9)+CTOFE
6755     C BG33P--CUTOFF ENERGIES IN EACH REGION FOR NEUTRONS(PROTONS)
6756     IN=0
6757     VALUE1=6.28318531D10*(1.19366207D-1)**3.3333333D-1
6758     C CALC. OF FERMI MOMENTA PER CM. PF EQU. 2PI*((3/8PI)TO 1/3)*E10
6759     DO80 I=1,3
6760     FMPN(I)=VALUE1* (SPACE(I+6))**3.3333333D-1
6761     80 FMPN(I+3)=VALUE1* (SPACE(I))**3.3333333D-1
6762     C FERMI MOMENTA PER CM. OF PROTONS(NEUTRONS)
6763     DO 90 I = 1,4
6764     90 RANDS(I)=RANDI(I)
6765     RETURN
6766     END
6767     *CMZ : 0.92/05 19/12/92 15.36.43 by Christian Zeitnitz
6768     *-- Author :
6769     SUBROUTINE ROUT2(T)
6770     REAL*8 T(19)
6771     C
6772     #include "cbert.inc"
6773     *KEND.
6774     SAVE
6775     C
6776     I1=1
6777     VALUE2=EINC+SPACE(12)
6778     CALL CBOVER(VALUE2,PNMS,ANS)
6779     SPACE(14)=0.20D-24*ANS
6780     C PIP+P
6781     SPACE(15)=0.023D-24*ANS
6782     C (PIM+P)EL
6783     SPACE(16)=.0451D-24*ANS
6784     C (PIM+P)EX
6785     C 180
6786     IF(VALUE1-100.0)10 ,10 ,50
6787     10 FMAX(1)=SPACE(14)
6788     FMAX(2)=SPACE(15)
6789     FMAX(3)=SPACE(16)
6790     S(1)=0.0
6791     S(2)=0.0
6792     20 CALLCRDET(1,T(1),EINC)
6793     C (PIP-P) ABSORPTION CROSS SECTION
6794     SPACE(17)=CRDT(1)
6795     IF(I1)40 ,40 ,30
6796     30 FMAX(4)=SPACE(17)
6797     40 RETURN
6798     50 IF(VALUE2-2600.0)70 ,70 ,60
6799     C VALUE2 IS GREATER THAN 2600
6800     60 I1=0
6801     GOTO40
6802     70 SPACE(17)=0.0
6803     IF(VALUE2-220.0)80 ,80 ,90
6804     80 S(1)=0.75D-27*ANS
6805     C (PIP-P)S.P. 400MEV
6806     S(2)=4.7D-27*ANS
6807     C (PIM-P)S.P. 400MEV
6808     GOTO110
6809     90 IF(VALUE2-400.0)100,100,120
6810     100 SPACE(14)=0.20D-24
6811     SPACE(16)=.0451D-24
6812     S(1)=7.8D-27*ANS
6813     S(2)=21.8D-27*ANS
6814     C 660 MEV
6815     110 IF(EINC-360.0)20 ,40 ,40
6816     120 IF(VALUE2-500.0)130,130,140
6817     130 SPACE(14)=.113D-24
6818     C 250 MEV
6819     SPACE(15)=20.5D-27*ANS
6820     C 620 MEV
6821     SPACE(16)=27.7D-27
6822     C 250 MEV
6823     S(1)=13.8D-27*ANS
6824     S(2)=24.4D-27*ANS
6825     C 800 MEV
6826     I1=-1
6827     GOTO110
6828     140 S(2)=30.4D-27*ANS
6829     SPACE(15)=26.3D-27*ANS
6830     C 900
6831     IF(VALUE2-600.0)150,150,160
6832     C 940,325
6833     150 SPACE(14)=53.0D-27
6834     C 325
6835     C VALUE2 LTE 600
6836     C 325
6837     SPACE(16)=16.2D-27
6838     S(1)=15.2D-27*ANS
6839     C 940
6840     GOTO40
6841     160 IF(VALUE2-800.0)170,170,180
6842     C 1200,400
6843     170 SPACE(14)=33.0D-27
6844     C 400
6845     SPACE(16)=12.0D-27*ANS
6846     C 400
6847     S(1)=20.9D-27*ANS
6848     C 1200
6849     GOTO40
6850     180 SPACE(14)=19.3D-27*ANS
6851     C 1300
6852     SPACE(16)=8.2D-27*ANS
6853     C 540
6854     S(1)=23.3D-27*ANS
6855     C 1400
6856     S(2)=30.4D-27*ANS
6857     C SIGMA(A) 900+2MB FOR FUTURE CORRECTION
6858     GOTO40
6859     C VALUES OF FI FOR BOTH INCIDENT AND CASCADE PARTICLES FOR
6860     C CHARGED PIONS(PI +OR-) ,SINGLE PRODUCTION. S(1)=N)S.P., S(2)=P)
6861     C S.P., SPACE(14)=N)S, SPACE(15)=P)D.S., SPACE(16)=P)ABS, SPACE(17)
6862     C =P)ABS (PPAC)
6863     END
6864     *CMZ : 0.92/00 02/12/92 16.02.27 by Christian Zeitnitz
6865     *-- Author :
6866     SUBROUTINE ROUT3
6867     C
6868     #include "cbert.inc"
6869     *KEND.
6870     C
6871     IF(NO-4)10 ,20 ,20
6872     C BG6A IN ORIGINAL
6873     10 ISW(11)=1
6874     GOTO30
6875     20 ISW(11)=0
6876     30 CALL UNDIS
6877     INC=1
6878     RETURN
6879     END
6880     *CMZ : 0.92/00 02/12/92 16.02.27 by Christian Zeitnitz
6881     *-- Author :
6882     SUBROUTINE ROUT4
6883     C
6884     #include "cbert.inc"
6885     *KEND.
6886     C
6887     CALL CALGEO
6888     IF(I1) 20,10,10
6889     10 CURR(3)=PNMS
6890     C PI+ OR -MASS/CM
6891     CURR(1)=NO
6892     CALL PARTIN
6893     CALL SPAC32(32)
6894     20 RETURN
6895     END
6896     *CMZ : 0.92/00 02/12/92 16.02.27 by Christian Zeitnitz
6897     *-- Author :
6898     SUBROUTINE ROUT5(T,B,R)
6899     REAL*8 T(126),B(126),R(126)
6900     C
6901     #include "cbert.inc"
6902     *KEND.
6903     C
6904     IF(NOT-2) 10 ,20 ,30
6905     10 CALL CRJAB(1,T(1))
6906     GO TO 40
6907     C (PIP-P)ELASTIC SCATTERING CRS.
6908     20 CALL CRJAB(1,B(1))
6909     GO TO 40
6910     C (PIM-P)DIRECT SCATTERING CRS.
6911     30 CALLCRJAB(1,R(1))
6912     40 RETURN
6913     END
6914     *CMZ : 0.92/03 10/12/92 10.54.57 by Christian Zeitnitz
6915     *-- Author :
6916     SUBROUTINE ROUT6
6917     C
6918     #include "crandm.inc"
6919     *KEND.
6920     C
6921     #include "cbert.inc"
6922     *KEND.
6923     C
6924     IF(I3)10 ,90 ,90
6925     10 XABS=1.0
6926     MED=CLSM
6927     KNOT=NOT
6928     VALUE1 = RANDC(ISEED)
6929     IF(ISW(11))50 ,20 ,50
6930     20 IF(VALUE1-PPMDA)60 ,40 ,40
6931     C PROB. PIM-DEUT ABS.
6932     30 RETURN
6933     40 I3=1
6934     GO TO 30
6935     50 IF(VALUE1-PPPDA)60 ,40 ,40
6936     C PROB. PIP-DEUT ABS.
6937     60 IF(ISW(11))80 ,70 ,80
6938     70 IT=13
6939     ABSEC=PMAC(MED)
6940     GO TO 90
6941     80 IT=14
6942     ABSEC=-HVN(MED)
6943     90 STRKP=-1.0
6944     I1=0
6945     I2=MED
6946     CALL CBBBBB
6947     I3=0
6948     GO TO 30
6949     END
6950     *CMZ : 0.92/00 02/12/92 16.02.27 by Christian Zeitnitz
6951     *-- Author :
6952     SUBROUTINE ROUT6A
6953     SAVE
6954     C
6955     #include "cbert.inc"
6956     *KEND.
6957     C
6958     10 I1=0
6959     CALL SPISOM
6960     STRKP=-2.0
6961     I1=1
6962     CALL SPISOM
6963     STRKP=-1.0
6964     COM=(AWD(MED)-7.0)*2.0*RCPMV
6965     IF(COM-E(2))10 ,10 ,20
6966     20 PM(2)=2.0*DNCMS
6967     PM(3)=DNCMS
6968     E(2)=PM(2)+E(2)
6969     RETURN
6970     END
6971     *CMZ : 0.92/00 02/12/92 16.02.27 by Christian Zeitnitz
6972     *-- Author :
6973     SUBROUTINE ROUT7
6974     C
6975     #include "crandm.inc"
6976     *KEND.
6977     C
6978     #include "cbert.inc"
6979     *KEND.
6980     SAVE
6981     I3=0
6982     IF(CURR(1)-3.0)20 ,50 ,10
6983     10 IF(CURR(1)-5.0)60 ,40 ,20
6984     C PROTON, NEUTRON NOT PERMITTED
6985     20 I3=-1
6986     30 RETURN
6987     40 IT=7
6988     IFCA=5
6989     C PI MESON - (5)
6990     ABSEC=PMAC(MED)
6991     C PIM +PP ABS. TYOR=PMAPP(20021)
6992     GOTO90
6993     50 IT=10
6994     IFCA=3
6995     C TYOR=PPAN(20004) PIP-NN ABS. ENERGY CORRECTION PIMESON +
6996     ABSEC=PPAN(MED)
6997     GOTO100
6998     60 VALUE1 = RANDC(ISEED)
6999     IF(VALUE1-PPNNA)70 ,80 ,80
7000     70 IT=8
7001     IFCA=4
7002     C PNANN(20015)=TYOR PIN-NN ABS PIMESON 0
7003     ABSEC=-HVN(MED)
7004     GOTO100
7005     80 IT=9
7006     IFCA=2
7007     C PNAPP(20011)=TYOR PIN+PP ABS. PIMESON 0
7008     ABSEC=-HVP(MED)
7009     90 STRKP=-1.0
7010     E(1)=WKRPN(MED)*RCPMV+PM(1)
7011     GOTO110
7012     100 STRKP=-2.0
7013     E(1)=WKRPN(MED+3)*RCPMV+PM(1)
7014     110 IF(INC)130,120,130
7015     120 CALLP1CLC
7016     GOTO30
7017     130 CALLP1CLI
7018     GOTO30
7019     END
7020     *CMZ : 0.92/00 02/12/92 16.02.27 by Christian Zeitnitz
7021     *-- Author :
7022     SUBROUTINE ROUT7A
7023     #include "cbert.inc"
7024     *KEND.
7025     C
7026     SAVE
7027     10 I1=-1
7028     CALLSPISOM
7029     GOTO(20 ,30 ,20 ,20 ,30 ),IFCA
7030     20 VALUE1=SPACE(MED+3)-7.0
7031     GOTO40
7032     30 VALUE1=SPACE(MED+9)-7.0
7033     40 IF(VALUE1)50 ,70 ,70
7034     50 I3=2
7035     60 RETURN
7036     70 IF((VALUE1*2.0*RCPMV)-E(2))10 ,10 ,80
7037     80 PM(3)=DNCMS
7038     PM(2)=2.0*DNCMS
7039     E(2)=PM(2)+E(2)
7040     VALUE1=EX
7041     IF(MED-2)90 ,100,110
7042     90 I3=3
7043     GOTO60
7044     100 I3=4
7045     GOTO60
7046     110 IF(INC)120,170,120
7047     120 IF(ISW(1))140,130,140
7048     130 I3=5
7049     GOTO60
7050     140 IF(ISW(2))150,160,150
7051     150 I3=6
7052     GOTO60
7053     160 I3=9
7054     GOTO60
7055     170 IF(ISW(1))190,180,190
7056     180 I3=7
7057     GOTO60
7058     190 IF(ISW(2))200,210,200
7059     200 I3=1
7060     GOTO60
7061     210 I3=8
7062     GOTO60
7063     END
7064     *CMZ : 0.92/00 02/12/92 16.02.27 by Christian Zeitnitz
7065     *-- Author :
7066     SUBROUTINE ROUT8
7067     C
7068     #include "cbert.inc"
7069     *KEND.
7070     C
7071     SAVE
7072     I3=1
7073     IF(IV) 20 ,10 ,10
7074     10 IF(VALUE1-VALUE2) 20 ,20 ,110
7075     20 IF(ISW(3)) 80 ,30 ,80
7076     30 IFC=7+IFCC
7077     C 7=BG6E(2461) 8=BG6IA(4026) NTNT(21626) BG48X(12762)=19
7078     IF(IN) 40 ,60 ,40
7079     40 I3=2
7080     50 RETURN
7081     60 C(3)=D(2)
7082     GO TO 70
7083     70 I3=3
7084     GO TO 50
7085     80 IFC=8+IFCC
7086     IF(IN)90 ,100,90
7087     90 I3=4
7088     GO TO 50
7089     100 C(3)=D(2)+D(3)+D(4)
7090     GO TO 70
7091     110 CALL SIGNEX
7092     GOTO 50
7093     END
7094     *CMZ : 0.90/00 05/06/92 10.57.24 by Christian Zeitnitz
7095     *-- Author :
7096     SUBROUTINE SIGNEX
7097     #include "cbert.inc"
7098     *KEND.
7099     SAVE
7100     C
7101     CALL EXPRN(UNIV)
7102     EX=EX+UNIV/SIGN
7103     RETURN
7104     C EX=DISTANCE IN SAMPLING ROUTINE
7105     C EXPONENTIAL RANDOM DIVIDED BY SIGMA CI REGION I
7106     END
7107     *CMZ : 0.92/00 02/12/92 16.02.27 by Christian Zeitnitz
7108     *-- Author :
7109     SUBROUTINE SPAC32(I)
7110     #include "cbert.inc"
7111     *KEND.
7112     SAVE
7113     C
7114     EX=0.0
7115     I4=5
7116     SIGN=9.99999D-1*SPACE(I)
7117     IF(I-31)10,20,30
7118     10 I2=18
7119     I3=3
7120     GOTO90
7121     20 I2=22
7122     I3=5
7123     GOTO90
7124     30 IF(I-41)40,50,50
7125     40 I2=26
7126     I3=7
7127     GOTO90
7128     50 I4=3
7129     IF(I-42)60,70,80
7130     60 I2=35
7131     I3=13
7132     GOTO90
7133     70 I2=37
7134     I3=17
7135     GOTO90
7136     80 I2=39
7137     I3=21
7138     90 CALLCABG6B
7139     CALLSIGNEX
7140     RETURN
7141     END
7142     *CMZ : 0.92/00 02/12/92 16.02.27 by Christian Zeitnitz
7143     *-- Author :
7144     SUBROUTINE CASPCN
7145     #include "cbert.inc"
7146     *KEND.
7147     REAL*8 WK
7148     SAVE
7149     C
7150     FMAX(4)=0.0
7151     FMAX(5)=0.0
7152     I6=CURR(1)-1.95
7153     WK=WKRPN(I2)
7154     GOTO(10,20,10),I6
7155     10 UNIV=PNMS
7156     GOTO30
7157     20 UNIV=POMS
7158     30 CALLCBOVER(WK,UNIV,UNIVE)
7159     VALUE1=0.0
7160     IF(WK-220.0)40,40,100
7161     40 GOTO(50,80,50),I6
7162     50 FMAX(5)=0.35D-27*UNIVE
7163     C (PIP+P)S.P.
7164     FMAX(6)=2.3D-27*UNIVE
7165     C (PIM+P)S.P.
7166     FMAX(1)=0.20D-24*UNIVE
7167     C (PIP+P)SC
7168     FMAX(3)=.0451D-24*UNIVE
7169     C (PIM+P)EX
7170     60 FMAX(2)=0.023D-24*UNIVE
7171     C (PIM-P)SC
7172     70 RETURN
7173     80 FMAX(6)=1.35D-27*UNIVE
7174     C (PI0+P)S.P.
7175     FMAX(1)=89.2D-27*UNIVE
7176     C (PI0+P)SC
7177     FMAX(2)=.0451D-24*UNIVE
7178     C (PI0+P)EX
7179     90 FMAX(3)=FMAX(1)
7180     C (PI0+N)SC
7181     FMAX(4)=FMAX(2)
7182     C (PI0+N)EX
7183     FMAX(7)=FMAX(6)
7184     C (PI0+N)S.P.
7185     GOTO70
7186     100 IF(WK-400.0)110,110,140
7187     110 GOTO(120,130,120),I6
7188     120 FMAX(5)=4.5D-27*UNIVE
7189     FMAX(6)=20.6D-27*UNIVE
7190     FMAX(1)=0.20D-24
7191     FMAX(3)=.0451D-24
7192     GOTO60
7193     130 FMAX(6)=12.5D-27*UNIVE
7194     FMAX(1)=89.2D-27
7195     FMAX(2)=.0451D-24
7196     GOTO90
7197     140 IF(WK-500.0)150,150,180
7198     150 GOTO(160,170,160),I6
7199     160 FMAX(1)=.113D-24
7200     FMAX(2)=20.5D-27*UNIVE
7201     FMAX(3)=27.7D-27
7202     FMAX(5)=11.7D-27*UNIVE
7203     FMAX(6)=21.7D-27*UNIVE
7204     GOTO70
7205     170 FMAX(1)=50.8D-27
7206     FMAX(2)=27.7D-27
7207     FMAX(6)=14.6D-27*UNIVE
7208     GOTO90
7209     180 VALUE1=1.0
7210     IF(WK-600.0)190,190,220
7211     190 GOTO(200,210,200),I6
7212     200 FMAX(1)=51.0D-27
7213     FMAX(2)=24.7D-27*UNIVE
7214     FMAX(3)=15.5D-27*UNIVE
7215     FMAX(5)=15.1D-27*UNIVE
7216     FMAX(6)=30.4D-27*UNIVE
7217     GOTO70
7218     210 FMAX(1)=23.0D-27*UNIVE
7219     FMAX(2)=15.5D-27*UNIVE
7220     FMAX(6)=22.6D-27*UNIVE
7221     GOTO90
7222     220 IF(WK-800.0)230,230,260
7223     230 GOTO(240,250,240),I6
7224     240 FMAX(1)=33.0D-27
7225     FMAX(2)=26.3D-27*UNIVE
7226     FMAX(3)=12.0D-27*UNIVE
7227     FMAX(5)=20.1D-27*UNIVE
7228     FMAX(6)=30.4D-27*UNIVE
7229     GOTO70
7230     250 FMAX(1)=16.0D-27*UNIVE
7231     FMAX(2)=12.0D-27*UNIVE
7232     FMAX(6)=22.6D-27*UNIVE
7233     GOTO90
7234     260 GOTO(270,280,270),I6
7235     270 FMAX(1)=19.3D-27*UNIVE
7236     FMAX(2)=26.3D-27*UNIVE
7237     FMAX(3)=8.2D-27*UNIVE
7238     FMAX(5)=23.3D-27*UNIVE
7239     FMAX(6)=30.4D-27*UNIVE
7240     GOTO70
7241     280 FMAX(1)=16.0D-27*UNIVE
7242     FMAX(2)=8.2D-27*UNIVE
7243     FMAX(6)=24.9D-27*UNIVE
7244     GOTO90
7245     END
7246     *CMZ : 0.92/00 02/12/92 16.02.27 by Christian Zeitnitz
7247     *-- Author :
7248     SUBROUTINE SPISOM
7249     #include "cbert.inc"
7250     *KEND.
7251     SAVE
7252     C
7253     10 CALL CAISOM
7254     IF(I1)20,20,30
7255     20 SPACE(176)=PXYZ(2)
7256     SPACE(177)=PXYZ(6)
7257     SPACE(178)=PXYZ(10)
7258     IF(I1)50,40,40
7259     30 PXYZ(2)=PXYZ(2)+SPACE(176)
7260     PXYZ(6)=PXYZ(6)+SPACE(177)
7261     PXYZ(10)=PXYZ(10)+SPACE(178)
7262     E(2)=(PXYZ(10)*PXYZ(10)+PXYZ(6)*PXYZ(6)+PXYZ(2)*PXYZ(2))/
7263     11.9032D14
7264     40 RETURN
7265     50 I1=1
7266     GOTO10
7267     END
7268     *CMZ : 1.01/04 10/06/93 14.43.38 by Christian Zeitnitz
7269     *-- Author :
7270     SUBROUTINE CSTORE
7271     #include "cbert.inc"
7272     *KEND.
7273     REAL * 8 SUB1,SUB2
7274     SAVE
7275     C
7276     CALL CZERO
7277     N=I1
7278     IF(I3)200,10,200
7279     10 K=I2+6
7280     L=I2
7281     GOTO(50,50,50,20,50),I5
7282     20 IF(I1-5)30,230,30
7283     30 MM=-6
7284     40 L=K
7285     N=N-1
7286     50 DO110 I=1,N,2
7287     ID=I
7288     CE(I+1)=FMAX(I)*1.0D30*SPACE(K)
7289     CE(I+2)=FMAX(I+1)*1.0D30*SPACE(L)
7290     GOTO(110,110,60,60,60),I5
7291     60 M=K
7292     K=L
7293     GOTO(110,110,100,80,70),I5
7294     70 IF(ID-2)110,110,90
7295     80 K=M+MM
7296     MM=-MM
7297     L=K
7298     GOTO110
7299     90 K=I2
7300     100 L=M
7301     110 CONTINUE
7302     GOTO(120,120,120,220,120),I5
7303     120 SIGN=0.0
7304     DO130 I=2,8
7305     130 SIGN=SIGN+CE(I)
7306     GOTO(140,140,150,250,150),I5
7307     140 SIGN=SIGN*9.99999D-1
7308     RETURN
7309     150 IF(I1-4)160,160,140
7310     160 IF(I3)170,170,180
7311     170 SPACE(I2+87)=SIGN
7312     GOTO190
7313     180 SPACE(I2+106)=SIGN
7314     190 FMAX(5)=0.0
7315     FMAX(6)=0.0
7316     GOTO140
7317     200 K=I2
7318     L=I2+6
7319     GOTO(50,50,50,210,50),I5
7320     210 MM=6
7321     GOTO40
7322     220 CE(8)=FMAX(7)*1.0D30*SPACE(L)
7323     GOTO120
7324     230 SUB1=FMAX(1)*1.0D30
7325     SUB2=FMAX(2)*1.0D30
7326     DO240 I=2,N,2
7327     CE(I)=SUB1*SPACE(K)
7328     CE(I+1)=SUB2*SPACE(K)
7329     K=L
7330     240 L=K+6
7331     CE(N+1)=SPACE(K)*1.0D30*FMAX(N)
7332     GOTO120
7333     250 IF(I1-5)140,260,140
7334     260 SPACE(I2+68)=SIGN
7335     FMAX(6)=0.0
7336     FMAX(7)=0.0
7337     GOTO140
7338     END
7339     *CMZ : 1.01/04 10/06/93 14.43.38 by Christian Zeitnitz
7340     *-- Author :
7341     SUBROUTINE CASTPH(W)
7342     REAL*8 W(11)
7343     #include "cbert.inc"
7344     *KEND.
7345     SAVE
7346     C
7347     IF(PGVC(1)-440.0)10,40,40
7348     10 I=PGVC(1)+2.005
7349     J=I+10
7350     C PGVC(1)=NO.OF TIMES VELOCITY GREATER THAN CRITERION ENTERED
7351     L=1
7352     DO20 K=I,J
7353     PGVC(K)=W(L)
7354     20 L=L+1
7355     PGVC(1)=PGVC(1)+11.0
7356     30 RETURN
7357     40 I1=1
7358     GOTO30
7359     END
7360     *CMZ : 1.01/04 10/06/93 14.43.38 by Christian Zeitnitz
7361     *-- Author :
7362     SUBROUTINE CASTPL(W)
7363     REAL*8 W(12)
7364     #include "cbert.inc"
7365     *KEND.
7366     SAVE
7367     C
7368     DO10 K=2,950,12
7369     IF(PLVC(K))10,40,10
7370     10 CONTINUE
7371     20 I1=1
7372     30 RETURN
7373     40 I=K
7374     J=I+11
7375     C PLVC(1)=NO. OF TIMES ENTERED FOR STORAGE OF VELOCITY
7376     C LESS THAN CRITERION
7377     L=1
7378     DO50 K=I,J
7379     PLVC(K)=W(L)
7380     50 L=L+1
7381     PLVC(1)=PLVC(1)+1.0
7382     GOTO30
7383     END
7384     *CMZ : 1.01/04 10/06/93 14.43.39 by Christian Zeitnitz
7385     *-- Author :
7386     SUBROUTINE CASTPR
7387     #include "cbert.inc"
7388     *KEND.
7389     C
7390     SAVE
7391     I1=0
7392     MED=CLSM
7393     DO90 I=3,39,12
7394     K=I
7395     IF(PT(I))10,90,10
7396     10 IF(PT(K-1)-2.0)20,30,20
7397     20 PT(K-2)=PT(K)-SPACE(MED+9)
7398     GOTO60
7399     30 PT(K-2)=PT(K)-SPACE(MED+3)
7400     40 IF(PT(K-2)-500.0)50,50,80
7401     50 CALLCASTPL(PT(K-2))
7402     C VELOCITY LESS THAN CRITERION
7403     IF(I1)100,90,100
7404     60 IF(PT(K-1)-1.0)70,40,70
7405     70 PT(K-2)=(DNCMS*PT(K-2))/PT(K+1)
7406     GOTO40
7407     80 CALLCASTPH(PT(K-1))
7408     C VELOCITY GREATER THAN CRITERION
7409     IF(I1)100,90,100
7410     90 CONTINUE
7411     100 RETURN
7412     END
7413     *CMZ : 1.01/04 10/06/93 14.43.39 by Christian Zeitnitz
7414     *-- Author :
7415     SUBROUTINE UNDIS
7416     #include "cbert.inc"
7417     #include "crandm.inc"
7418     #include "cmunpu.inc"
7419     #include "crn.inc"
7420     #include "cxyinc.inc"
7421     *KEND.
7422     REAL*8 RAN1,RAN2
7423     SAVE
7424     C
7425     IF(BEGRU) 110,130,100
7426     10 BEGRU=1.0
7427     DO 20 I = 1,4
7428     20 RANDS(I)=RANDI(I)
7429     30 RAN1 = RANDC(ISEED)
7430     RAN2 = RANDC(ISEED)
7431     RAN1 = 2.D0*RAN1-1.D0
7432     RAN2 = 2.D0*RAN2-1.D0
7433     IF(RAN1**2 + RAN2**2 .GE. 1.D0) GO TO 30
7434     XI(1) = RAN1*OUT(4)
7435     XI(2) = RAN2*OUT(4)
7436     X = XI(1)
7437     Y = XI(2)
7438     CURR(4)=XI(1)
7439     CURR(5) = XI(2)
7440     XI(3)=-OUT(4)
7441     DCOS(1)=0.0
7442     DCOS(2)=0.0
7443     DCOS(3)=1.0
7444     MED=4
7445     CURR(6)=XI(3)
7446     CURR(7)=0.0
7447     CURR(8)=0.0
7448     CURR(9)=1.0
7449     CURR(10)=MED
7450     C X, Y AND Z COORDINATES, ALSO ALPHA, BETA AND GAMMA
7451     C DIRECTION COSINES. MED=4, (NO. OF GEOM)
7452     40 RETURN
7453     50 BEGRU = BEGRU + 1.0 D0
7454     60 BEGRU=BEGRU+1.0
7455     IF(CASESN -BEGRU)80,70,70
7456     70 FRAND = RANDC(ISEED)
7457     GO TO 30
7458     80 BEGRU=0.0
7459     DO90 I=1,4
7460     RANDI(I)=RANDS(I)
7461     90 ERAND(I)=RANDS(I)
7462     GOTO40
7463     C FINAL RANDOM IN ERAND. RUN COMPLETED
7464     100 IF(COUNT(6).EQ.0.0) GO TO 130
7465     110 COUNT(6) = 0.0
7466     120 IF(BEGRU) 50,10,60
7467     130 DO 140 I=1,12
7468     PCC(I) = CC(I)
7469     140 NIP(I) = IPEC(I)
7470     DO 150 I=1,5
7471     150 PPNB(I) = PNBC(I)
7472     GO TO 120
7473     C*** WHEN BEGRU = 0, MUNPU COMMON IS ZEROED
7474     END
7475     *CMZ : 1.01/04 10/06/93 14.43.39 by Christian Zeitnitz
7476     *-- Author :
7477     SUBROUTINE CALXYI(II,JJ,KK)
7478     C
7479     #include "cbert.inc"
7480     *KEND.
7481     C
7482     REAL * 8 W1,W2,W3,W4,W5,W6
7483     SAVE
7484     C
7485     W1=S(II)*1.0D30
7486     W2=S(II+1)*1.0D30
7487     IF(IABS(IV)-1)10,20,10
7488     10 W3=SPACE(JJ)*1.0D30
7489     W4=SPACE(JJ+1)*1.0D30
7490     W5=SPACE(JJ+2)*1.0D30
7491     W6=SPACE(JJ+3)*1.0D30
7492     LL=II+2
7493     IF(IV)40,60,40
7494     20 W3=S(II+2)*1.0D30
7495     W4=S(II+3)*1.0D30
7496     W5=SPACE(JJ)*1.0D30
7497     W6=SPACE(JJ+1)*1.0D30
7498     LL=II+4
7499     IF(IV)50,30,30
7500     30 NM=7
7501     I7=1
7502     40 MM=7
7503     NN=1
7504     GO TO 70
7505     50 NM=1
7506     I7=7
7507     60 MM=1
7508     NN=7
7509     70 DO100 I=1,3
7510     S(LL)=W1*SPACE(MM)
7511     S(LL+1)=W2*SPACE(NN)
7512     IF(IABS(IV)-1)90,80,90
7513     80 S(LL+2)=W3*SPACE(NM)
7514     S(LL+3)=W4*SPACE(I7)
7515     LL=LL+2
7516     NM=NM+1
7517     I7=I7+1
7518     90 MM=MM+1
7519     NN=NN+1
7520     100 LL=LL+2
7521     IF(IV)110,120,130
7522     110 NM=7
7523     I7=1
7524     GOTO170
7525     120 MM=1
7526     NN=7
7527     NM=7
7528     I7=7
7529     GOTO 150
7530     130 IF(IV-1)160,160,140
7531     140 MM=7
7532     NN=1
7533     NM=1
7534     I7=7
7535     150 LL=JJ+4
7536     GOTO180
7537     160 NM=1
7538     I7=7
7539     170 LL=JJ
7540     180 DO210 I=1,3
7541     SPACE(LL+2)=W5*SPACE(NM)
7542     SPACE(LL+3)=W6*SPACE(I7)
7543     IF(IABS(IV)-1)190,200,190
7544     190 SPACE(LL)=W3*SPACE(MM)
7545     SPACE(LL+1)=W4*SPACE(NN)
7546     LL=LL+2
7547     MM=MM+1
7548     NN=NN+1
7549     200 NM=NM+1
7550     I7=I7+1
7551     210 LL=LL+2
7552     LL=KK+2
7553     IF(IABS(IV)-1)220,250,220
7554     220 MM=JJ+4
7555     NN=II+2
7556     DO230 I=KK,LL
7557     SPACE(I)=SPACE(MM)+SPACE(MM+1)+SPACE(MM+2)+SPACE(MM+3) +S(NN)+
7558     + S(NN+1)
7559     MM=MM+4
7560     230 NN=NN+2
7561     240 RETURN
7562     250 MM=II+4
7563     NN=JJ+2
7564     DO260 I=KK,LL
7565     SPACE(I)=SPACE(NN)+SPACE(NN+1)+S(MM)+S(MM+1)+S(MM+2)+S(MM+3)
7566     MM=MM+4
7567     260 NN=NN+2
7568     GOTO240
7569     END
7570     *CMZ : 0.92/00 02/12/92 16.02.27 by Christian Zeitnitz
7571     *-- Author :
7572     SUBROUTINE CZERO
7573     #include "cbert.inc"
7574     *KEND.
7575     C
7576     DO 10 I = 1,21
7577     10 CE(I) = 0.0
7578     RETURN
7579     END
7580     *CMZ : 0.92/00 02/12/92 16.02.30 by Christian Zeitnitz
7581     *-- Author :
7582     FUNCTION CDOST(I,Z)
7583     C
7584     #include "cevcm.inc"
7585     *KEND.
7586     C
7587     IF(Z-70.0) 30,10,10
7588     10 CDOST = T(I,7)
7589     20 RETURN
7590     30 IF(Z-10.0) 40,40,50
7591     40 CDOST = T(I,1)
7592     GO TO 20
7593     50 N = 0.1 * Z + 1.0
7594     X = 10 * N
7595     X = (X-Z) * 0.1
7596     CDOST = X * T(I,N-1) + (1.0-X) * T(I,N)
7597     GO TO 20
7598     END
7599     *CMZ : 1.05/01 21/02/2000 16.44.49 by Christian Zeitnitz
7600     *-- Author :
7601     SUBROUTINE CDRES(M2,M3,T1,NPART,EPART,SOCHPE,U,EREC,HEPART)
7602     C*****A LA EVAP III(TWA,8-68)
7603     C*****COMPATIBLE WITH O5R DRES EXCEPT FOR COMMON/COMON/
7604     C
7605     #include "cjoint.inc"
7606     #include "crandm.inc"
7607     #include "cforcn.inc"
7608     #include "cdresc.inc"
7609     #include "cevcm.inc"
7610     #include "camass.inc"
7611     *KEND.
7612     LOGICAL INIT
7613     C
7614     C
7615     DIMENSION ZMASS(6),Q(6) ,
7616     + FLKCOU(6) ,CCOUL(6) ,THRESH(6) , NPART(6),
7617     + EPART(200,2) ,HEPART(200,4) ,SMALLA(6) ,
7618     + R(6) ,S(6) ,SOS(6) ,STRUN(6) ,EYE1(6) ,EYE0(6) ,
7619     + SMOM1(6) ,IAI(5) ,IZI(5) ,XX(5)
7620     C
7621     SAVE
7622     DATA INIT/.TRUE./
7623     C
7624     CZ DELTAS (A)=(A-1.0)/(1.0+(124.0/A**0.6666667))
7625     IF(.NOT.INIT) GO TO 20
7626     INIT = .FALSE.
7627     FKEY=0.
7628     C evaporation data read in by CRBERT called by CALINI CZ 19.JUNE 92
7629     DO10 K=1,7
7630     10 T(4,K)=0.0
7631     Y0=1.5
7632     B0=8.0
7633     NBE8 = 0
7634     NRNEEP = 0
7635     ZMASS(1) = XMASS(1)*1.E3
7636     ZMASS(2) = XMASS(0)*1.E3
7637     ZMASS(3) = XMASS(7)*1.E3
7638     ZMASS(4) = XMASS(8)*1.E3
7639     ZMASS(5) = XMASS(9)*1.E3
7640     ZMASS(6) = XMASS(10)*1.E3
7641     EMH = ZMASS(2)
7642     EMN = ZMASS(1)
7643     C QUESTION:WHAT IS UM?
7644     C END OF CHANGE
7645     UM = 931.20793
7646     EMHN=EMH-EMN
7647     EMNUM=EMN-UM
7648     20 CONTINUE
7649     DO30 I=1,6
7650     NPART(I)=0
7651     30 SMOM1(I)=0.0
7652     DO40 K=1,6
7653     FLA(K)=IA(K)
7654     40 FLZ(K)=IZ(K)
7655     50 JA=M2
7656     JZ=M3
7657     U=T1
7658     IF(JA-JZ)60 ,60 ,70
7659     60 CONTINUE
7660     RETURN
7661     70 A=JA
7662     Z=JZ
7663     BE=Z*EMHN+A*EMNUM-CENERG(A,Z)
7664     RNMASS=Z*EMH+(A-Z)*EMN-BE
7665     IF(EREC)80 ,80 ,90
7666     80 VRNSQ=0.
7667     VCM=0.
7668     GO TO 100
7669     90 VRNSQ=2.0*EREC/RNMASS
7670     VCM=SQRT(VRNSQ)
7671     100 IF(JA-8)120 ,110 ,120
7672     110 IF(JZ-4)120 ,710 ,120
7673     120 CONTINUE
7674     DO150 K=1,6
7675     IF((A-FLA(K)).LE.(Z-FLZ(K)))GO TO 150
7676     IF(A-2.0*FLA(K))150,130,130
7677     130 IF(Z-2.0*FLZ(K))150,140,140
7678     140 Q(K) = CQNRG(A-FLA(K),Z-FLZ(K),A,Z) + EXMASS(K)
7679     C 728 Q(K)=CENERG(A-FLA(K),Z-FLZ(K))-CENERG(A,Z)+EXMASS(K)
7680     150 CONTINUE
7681     FLKCOU(1)=0.0
7682     FLKCOU(2)=CDOST(1,Z-FLZ(2))
7683     FLKCOU(3)=FLKCOU(2)+.06
7684     FLKCOU(4)=FLKCOU(2)+.12
7685     FLKCOU(6)=CDOST(2,Z-FLZ(6))
7686     FLKCOU(5)=FLKCOU(6)-.06
7687     CCOUL(1)=1.0
7688     CCOU2=CDOST(3,Z-FLZ(2))
7689     CCOUL(2)=CCOU2+1.0
7690     CCOUL(3)=CCOU2*1.5+3.0
7691     CCOUL(4)=CCOU2+3.0
7692     CCOUL(6)=CDOST(4,Z-FLZ(6))*2.0+2.0
7693     CCOUL(5)=2.0*CCOUL(6)-1.0
7694     SIGMA=0.0
7695     DO 200 J=1,6
7696     IF(A-2.0*FLA(J))180,160,160
7697     160 IF(Z-2.0*FLZ(J))180,170,170
7698     170 MM=JA-IA(J)
7699     ZZ=Z-FLZ(J)
7700     AA=A-FLA(J)
7701     IF(AA.LE.ZZ)GO TO 180
7702     SMALLA(J)=AA*(1.0+Y0*(AA-2.0*ZZ)**2/AA**2)/B0
7703     THRESH(J)=Q(J)+.88235*FLKCOU(J)*FLZ(J)* ZZ/(RMASS(MM)+RHO(J))
7704     NN=AA-ZZ
7705     IZZ=ZZ
7706     CORR=CAM4(IZZ)+CAM5(NN)
7707     IF(FKEY.EQ.1.) CORR=0.
7708     ARG=U-THRESH(J)-CORR
7709     IF(ARG)180,190,190
7710     180 R(J)=0.0
7711     S(J)=0.0
7712     SOS(J)=0.
7713     GOTO200
7714     190 S(J)=SQRT (SMALLA(J)*ARG)*2.0
7715     SOS(J)=10.0*S(J)
7716     200 CONTINUE
7717     N1=1
7718     DO210 J=1,6
7719     IF(SOS(J)-1250.0)210 ,220 ,220
7720     210 CONTINUE
7721     N1=2
7722     GO TO 230
7723     220 SES=AMAX1(S(1),S(2),S(3),S(4),S(5),S(6))
7724     230 DO390 J=1,6
7725     IF(S(J))240 ,390 ,240
7726     240 JS=SOS(J)+1.0
7727     MM=JA-IA(J)
7728     IF(N1-1)250 ,260 ,250
7729     250 IF(JS-1000)290 ,270 ,270
7730     260 SAS=EXP (S(J)-SES)
7731     GO TO 280
7732     270 SAS=EXP (S(J)-50.0)
7733     280 EYE1(J)=(S(J)**2-3.0*S(J)+3.0)*SAS/(4.0*SMALLA(J)**2)
7734     FJS=JS
7735     STRUN(J)=FJS-1.0
7736     GO TO 300
7737     290 FJS=JS
7738     STRUN(J)=FJS-1.0
7739     EYE1(J)=(P1(JS)+(P1(JS+1)-P1(JS))*(SOS(J)-STRUN(J)))/ SMALLA(J
7740     + )**2
7741     300 IF(J-1)320,320,310
7742     310 R(J)=CCOUL(J)*RMASS(MM)**2*EYE1(J)
7743     GOTO380
7744     320 IF(N1-1)330 ,340 ,330
7745     330 IF(JS-1000)350 ,340 ,340
7746     340 EYE0(J)=(S(J)-1.0)*0.5*SAS/SMALLA(J)
7747     GO TO 360
7748     350 EYE0(J)=(P0(JS)+(P0(JS+1)-P0(JS))*(SOS(J)-STRUN(J))) /
7749     + SMALLA(J)
7750     360 R(J)=RMASS(MM)**2*ALPH(MM)*(EYE1(J)+BET(MM)* EYE0(J))
7751     IF(R(J))370 ,380,380
7752     370 R(J)=0.0
7753     380 SIGMA=SIGMA+R(J)
7754     390 CONTINUE
7755     NCOUNT = 0
7756     400 IF(SIGMA)410,410,500
7757     410 CONTINUE
7758     DO 430 J = 1,6
7759     IF(JA-IA(J))430 ,420 ,430
7760     420 IF(JZ-IZ(J))430 ,440 ,430
7761     430 CONTINUE
7762     GO TO 480
7763     440 JEMISS = J
7764     C*****STORE,RESIDUAL NUC IS OF EMITTED PARTICLE TYPE
7765     EPS = U + EREC
7766     NPART(JEMISS) = NPART(JEMISS)+1
7767     NRNEEP = NRNEEP + 1
7768     450 SMOM1(JEMISS) = SMOM1(JEMISS) + EPS
7769     IF(JEMISS-2)460 ,460 ,470
7770     460 EPART(NPART(JEMISS),JEMISS)=EPS
7771     GO TO 780
7772     470 KEMISS=JEMISS-2
7773     HEPART(NPART(JEMISS),KEMISS)=EPS
7774     GO TO 780
7775     480 IF(JA-8)790,490,790
7776     490 IF(JZ-4)790,710,790
7777     500 URAN = RANDC(ISEED) * SIGMA
7778     SUM=0.0
7779     DO510 J=1,6
7780     K=J
7781     SUM=R(J)+SUM
7782     IF(SUM -URAN)510,510,520
7783     510 CONTINUE
7784     520 JEMISS=K
7785     JS=SOS(JEMISS)+1.0
7786     IF(JS-1000)540 ,530 ,530
7787     530 RATIO2=(S(JEMISS)**3-6.0*S(JEMISS)**2+15.0*
7788     +S(JEMISS)-15.0)/((2.0*S(JEMISS)**2-6.0*S(JEMISS)+6.0)*SMALLA
7789     +(JEMISS))
7790     GO TO 550
7791     540 RATIO2=(P22(JS)+(P22(JS+1)-P22(JS))*
7792     +(SOS(JEMISS)-STRUN(JEMISS)))/SMALLA(JEMISS)
7793     550 EPSAV=RATIO2*2.0
7794     IF(JEMISS-1)560,560,580
7795     560 MM=JA-IA(J)
7796     570 EPSAV=(EPSAV+BET(MM))/(1.0+BET(MM)*EYE0(JEMISS)
7797     +/EYE1(JEMISS))
7798     580 E1=EXPRNF(V)/2.0
7799     E2=EXPRNF(V)/2.0
7800     EPS=(E1+E2)*EPSAV+THRESH(JEMISS)-Q(JEMISS)
7801     COSCM = RANDC(ISEED)
7802     PLORMI = RANDC(ISEED)
7803     IF(PLORMI-0.5)590,590,600
7804     590 COSCM=-COSCM
7805     600 AR=A-FLOAT (IA(JEMISS))
7806     ZR=Z-FLOAT (IZ(JEMISS))
7807     BE=ZR*EMHN+AR*EMNUM-CENERG(AR,ZR)
7808     RNMASS=ZR*EMH+(AR-ZR)*EMN-BE
7809     VCMEPS = 2.0*EPS/(ZMASS(JEMISS)*(1.+ZMASS(JEMISS)/RNMASS))
7810     VCMEVP=SQRT(VCMEPS)
7811     VRNSQ=VCMEPS*ZMASS(JEMISS)*ZMASS(JEMISS)/(RNMASS*RNMASS)
7812     ++VCM*VCM+2.0*ZMASS(JEMISS)/RNMASS*VCMEVP*VCM*COSCM
7813     VLBEPS=VCMEPS+VCM*VCM-2.*VCMEVP*VCM*COSCM
7814     EPS=0.5*ZMASS(JEMISS)*VLBEPS
7815     610 UNEW=U-0.5*VCMEPS*(ZMASS(JEMISS)*ZMASS(JEMISS)/RNMASS+ZMASS(JEMISS
7816     +))-Q(JEMISS)
7817     IF(UNEW)630 ,620 ,620
7818     620 U = UNEW
7819     VCM=SQRT(VRNSQ)
7820     EREC=0.5*RNMASS*VRNSQ
7821     NPART(JEMISS)=NPART(JEMISS)+1
7822     GO TO 650
7823     630 NCOUNT = NCOUNT + 1
7824     IF(NCOUNT-10) 580,580,640
7825     640 SIGMA = SIGMA - R(JEMISS)
7826     R(JEMISS) = 0.0
7827     NCOUNT = 0
7828     GO TO 400
7829     650 JAT=JA-IA(JEMISS)
7830     JZT=JZ-IZ(JEMISS)
7831     IF(JAT-JZT)410,410,660
7832     660 JA=JAT
7833     JZ=JZT
7834     C*****STORE,END OF NORMAL CYCLE
7835     SMOM1(JEMISS)=SMOM1(JEMISS)+EPS
7836     IF(NPART(JEMISS).LE.0)CALL CERROR('CDRES1$')
7837     IF(JEMISS-2)670 ,670 ,680
7838     670 EPART(NPART(JEMISS),JEMISS)=EPS
7839     GO TO 690
7840     680 KEMISS=JEMISS-2
7841     HEPART(NPART(JEMISS),KEMISS)=EPS
7842     690 IF(JA-8)70,700 ,70
7843     700 IF(JZ-4)70,710 ,70
7844     710 IF(U)720 ,720 ,730
7845     720 EPS=0.
7846     GO TO 740
7847     730 EPS=0.5*(U+.093)
7848     740 NBE8=NBE8+1
7849     COSCM = RANDC(ISEED)
7850     VCMEPS=2.0*EPS/ZMASS(6)
7851     VCMEVP=SQRT(VCMEPS)
7852     VLBEPS=VCMEPS+VRNSQ+2.0*VCMEVP*VCM*COSCM
7853     NOP=0
7854     750 EPS=0.5*ZMASS(6)*VLBEPS
7855     C*****STORE,BE 8 BREAKUP
7856     SMOM1(6)=SMOM1(6)+EPS
7857     NPART(6)=NPART(6)+1
7858     HEPART(NPART(6),4)=EPS
7859     IF(NOP)760,760,770
7860     760 VLBEPS=VCMEPS+VRNSQ-2.0*VCMEVP*VCM*COSCM
7861     NOP=1
7862     GO TO 750
7863     770 CONTINUE
7864     780 EREC=0.
7865     U = 0.0
7866     790 SOCHPE=SMOM1(3)+SMOM1(5)+SMOM1(6)+SMOM1(4)
7867     800 CONTINUE
7868     RETURN
7869     END
7870     *CMZ : 1.01/04 10/06/93 14.43.43 by Christian Zeitnitz
7871     *-- Author :
7872     FUNCTION CENERG(A,Z)
7873     C
7874     #include "cevcm.inc"
7875     *KEND.
7876     C
7877     DELTAS (A)=(A-1.0)/(1.0+(124.0/A**0.6666667))
7878     CAM (A,Z)=8.367*A-0.783*Z
7879     + -17.0354*A*(1.0-1.84619*(A-2.0*Z)**2/A**2)
7880     + +25.8357*A**0.6666667*(1.0-1.71219*(A-2.0*Z)**2/A**2)
7881     + *(1.0-0.62025/A**0.6666667)**2
7882     + +0.779*Z*(Z-1.0)*(1.0-1.5849/A**0.6666667+1.2273/A
7883     + +1.5772/A**1.3333333)/A**0.3333333
7884     + -0.4323*Z**1.3333333*(1.0-0.57811/A**0.3333333
7885     + -0.14518/A**0.6666667+0.49597/A)/A**0.3333333
7886     I=A
7887     KZ=Z
7888     N=A-Z
7889     IF(I.EQ.0) THEN
7890     CENERG=0.0
7891     RETURN
7892     ENDIF
7893     IF(N.LT.0)CALL CERROR('CENERG A<Z $')
7894     JPRIME=DELTAS (A)
7895     J=I-2*KZ-JPRIME+10
7896     IF(J-20)10,10,40
7897     10 IF(J)40,40,20
7898     20 IF(WAPS(I,J))30,40,30
7899     30 CENERG=WAPS(I,J)
7900     RETURN
7901     40 CENERG=CAM (A,Z)+CAM2(KZ)+CAM3(N)
7902     RETURN
7903     END
7904     *CMZ : 1.01/09 29/06/93 19.03.31 by Christian Zeitnitz
7905     *-- Author :
7906     SUBROUTINE CERUP
7907     C*****MODIFIED TO OBTAIN APR,ZPR AFTER CAS + EVAP (8-68,T.W.A.)
7908     #include "chevap.inc"
7909     #include "ccomon.inc"
7910     #include "ccomn3.inc"
7911     #include "ccomn2.inc"
7912     #include "cforcn.inc"
7913     #include "cinout.inc"
7914     #include "caz.inc"
7915     *KEND.
7916     DIMENSION FPART(6)
7917     SAVE
7918     C
7919     IF(EX) 10 ,20 ,50
7920     10 NEGEX =NEGEX +1
7921     20 DO 30 I=1,6
7922     30 NPART(I)=0
7923     HEVSUM = 0.0
7924     UU = 0.0
7925     RETURN
7926     40 LOWAZ=LOWAZ+1
7927     GO TO 20
7928     50 IF(APR.LE.4.)GO TO 40
7929     IF(ZPR.LE.2.)GO TO 40
7930     IF(APR.LE.ZPR)GO TO 40
7931     M2= APR
7932     M3= ZPR
7933     CALL CDRES(M2,M3,EX,NPART,EPART,HEVSUM,UU,EREC,HEPART)
7934     DO 60 I=1,6
7935     60 IF(NPART(I).GT.0) GOTO 70
7936     FKEY =1.
7937     CALL CDRES(M2,M3,EX,NPART,EPART,HEVSUM,UU,EREC,HEPART)
7938     FKEY=0.
7939     70 CONTINUE
7940     80 DO 90 I=1,6
7941     IF(NPART(I).GT.200) THEN
7942     CALL CERROR(' CERUP : N_EVAP > 200 $')
7943     WRITE(IO,10000) I,NPART(I)
7944     10000 FORMAT(' CERUP: I=',I5,' NPART=',I5)
7945     NPART(I)=200
7946     ENDIF
7947     FPART(I)=NPART(I)
7948     90 CONTINUE
7949     ZPR=ZPR-FPART(2)-FPART(3)-2.*(FPART(5)+FPART(6)) -FPART(4)
7950     APR=APR-FPART(1)-FPART(2)-2.*FPART(3)-3.*(FPART(4)+FPART(5))
7951     + -4.*FPART(6)
7952     C CHANGED JAN.1,1986
7953     NPART1=NPART(1)
7954     NPART2=NPART(2)
7955     IF(NPART1.LE.0)GO TO 110
7956     DO 100 I=1,NPART1
7957     KINDI(I)=2
7958     IBBARR(I)=1
7959     100 CONTINUE
7960     110 IF(NPART2.LE.0) RETURN
7961     DO 120 I=1,NPART2
7962     KINDI(I)=1
7963     IBBARR(I)=1
7964     120 CONTINUE
7965     C END OF CHANGE
7966     RETURN
7967     END
7968     *CMZ : 0.92/00 02/12/92 16.02.30 by Christian Zeitnitz
7969     *-- Author :
7970     SUBROUTINE GTISO(U,V,W)
7971     C
7972     #include "crandm.inc"
7973     *KEND.
7974     C
7975     10 Z = RANDC(ISEED)
7976     X = 0.687368 * SFLRAF(X)
7977     Y = 0.687368 * SFLRAF(X)
7978     XSQ = X * X
7979     YSQ = Y * Y
7980     ZSQ = Z * Z
7981     D = XSQ + YSQ + ZSQ
7982     IF(D*D-Z) 20 ,20 ,10
7983     20 U = 2.0*X*Z/D
7984     V = 2.0*Y*Z/D
7985     W = (ZSQ-XSQ-YSQ)/D
7986     RETURN
7987     END
7988     *CMZ : 1.01/09 29/06/93 16.14.56 by Christian Zeitnitz
7989     *-- Author :
7990     SUBROUTINE RECOIL
7991     C
7992     #include "cinout.inc"
7993     #include "ccomon.inc"
7994     #include "camass.inc"
7995     *KEND.
7996     SAVE
7997     C
7998     IF(APR.LE.4.) THEN
7999     EREC = 0.0
8000     ELSE
8001     PX=0.
8002     PY=0.
8003     PZ=0.
8004     IF(NOPART.NE.0) THEN
8005     DO 10 I=1,NOPART
8006     TM = XMASS(KIND(I))*1000.
8007     PI = EP(I)*SQRT (1.+2.*TM/EP(I))
8008     PX = PI*ALPHA(I) +PX
8009     PY = PI*BETA(I) +PY
8010     PZ = PI*GAM(I) +PZ
8011     10 CONTINUE
8012     ENDIF
8013     KT= TIP(NO)
8014     TM = XMASS(KT)*1000.
8015     PZ = EC(NO)*SQRT (1.+2.*TM/EC(NO)) - PZ
8016     AA = APR * 931.49432
8017     EREC = SQRT (AA**2 +PX**2 +PY**2 +PZ**2)-AA
8018     ENDIF
8019     RETURN
8020     END
8021     *CMZ : 0.92/00 02/12/92 16.02.30 by Christian Zeitnitz
8022     *-- Author :
8023     FUNCTION CQNRG(A1,Z1,A2,Z2)
8024     C
8025     #include "cevcm.inc"
8026     *KEND.
8027     C
8028     DELTAS (A)=(A-1.0)/(1.0+(124.0/A**0.6666667))
8029     CAM (A,Z)=8.367*A-0.783*Z
8030     1-17.0354*A*(1.0-1.84619*(A-2.0*Z)**2/A**2)
8031     2+25.8357*A**0.6666667*(1.0-1.71219*(A-2.0*Z)**2/A**2)
8032     3*(1.0-0.62025/A**0.6666667)**2
8033     4+0.779*Z*(Z-1.0)*(1.0-1.5849/A**0.6666667+1.2273/A
8034     5+1.5772/A**1.3333333)/A**0.3333333
8035     6-0.4323*Z**1.3333333*(1.0-0.57811/A**0.3333333
8036     7-0.14518/A**0.6666667+0.49597/A)/A**0.3333333
8037     I1 = A1
8038     I2 = A2
8039     KZ1 = Z1
8040     KZ2 = Z2
8041     N1 = A1 - Z1
8042     N2 = A2 - Z2
8043     IF(N1.LE.0) CALL CERROR('CQNRG1$')
8044     IF(N2.LE.0) CALL CERROR('CQNRG2$')
8045     JP1 = DELTAS(A1)
8046     JP2 = DELTAS(A2)
8047     J1 = I1 - 2*KZ1 - JP1 + 10
8048     J2 = I2 - 2*KZ2 - JP2 + 10
8049     IF(J1.LT.1.OR.J1.GT.20) GO TO 10
8050     IF(J2.LT.1.OR.J2.GT.20) GO TO 10
8051     ENRG1 = WAPS(I1,J1)
8052     ENRG2 = WAPS(I2,J2)
8053     IF(ENRG1.EQ.0.) GO TO 10
8054     IF(ENRG2.EQ.0.) GO TO 10
8055     GO TO 20
8056     10 ENRG1 = CAM(A1,Z1) + CAM2(KZ1) + CAM3(N1)
8057     ENRG2 = CAM(A2,Z2) + CAM2(KZ2) + CAM3(N2)
8058     20 CQNRG = ENRG1 - ENRG2
8059     RETURN
8060     END
8061     *CMZ : 1.04/10 07/10/97 09.28.00 by Christian Zeitnitz
8062     *-- Author : Christian Zeitnitz 06/06/92
8063     SUBROUTINE CALSIG
8064     C************************************************************
8065     C CALOR-Cross-Section
8066     C
8067     C INPUT : material constants and particle type
8068     C OUTPUT : distance to next hadronic interaction
8069     C
8070     C Author : Christian Zeitnitz (U of Arizona)
8071     C Date : 6-6-92
8072     C************************************************************
8073     C
8074     C GEANT Commons
8075     #include "gckine.inc"
8076     #include "gctrak.inc"
8077     #include "gcmate.inc"
8078     #include "gcjloc.inc"
8079     #include "gcbank.inc"
8080     #include "gconsp.inc"
8081     #include "gcphys.inc"
8082     *KEND.
8083     C
8084     C CALOR common
8085     #include "calgea.inc"
8086     *KEND.
8087     C
8088     C Avogadro number multiplied by 1.E-24
8089     PARAMETER(XNAVO = 0.60221367)
8090     CC
8091     LOGICAL INIT,GOFLUK,DOSKAL,SKALEF
8092     C
8093     DATA INIT/.TRUE./
8094     C
8095     IF(INIT) THEN
8096     C
8097     C Initialize CALOR at first call
8098     INIT = .FALSE.
8099     CALL CALINI
8100     ENDIF
8101     C
8102     DOSKAL = .FALSE.
8103     IF(Z+0.5.GE.1.0 ) THEN
8104     IPINC = -1
8105     IF(IPART .LE. 48) IPINC = IGECAL(IPART)
8106     C
8107     C ------------- check if FLUKA have to be called ---------
8108     C ------------------------------------------------- Goto FLUKA ?
8109     C
8110     C particle type not implemented in CALOR
8111     GOFLUK = IPINC .EQ. -1 .OR. GEKIN .GE. ESKALE
8112     DOSKAL = (IPINC.EQ.0 .OR. IPINC.EQ.1) .AND. GEKIN.GT.EMAXP
8113     DOSKAL = DOSKAL .OR. (GEKIN .GT. EMAXPI .AND. (IPINC .GT. 1))
8114     DOSKAL = DOSKAL .AND. .NOT.GOFLUK
8115     GOFLUK = GOFLUK .OR. (DOSKAL.AND.SKALEF(IPINC,GEKIN,ESKALE))
8116     C
8117     IF(GOFLUK) THEN
8118     ICPROC = 3
8119     CALL FLDIST
8120     RETURN
8121     ENDIF
8122     C
8123     C --------- material information for CALOR --------------------------
8124     C
8125     EINC = GEKIN * 1000.0
8126     IF(IPINC .EQ. 1 .AND. EINC .LT. 20.0 ) THEN
8127     C MICAP needs only the GEANT material number !
8128     NCEL = NMAT
8129     ELSE
8130     NCEL = 1
8131     AMED(1) = A
8132     ZMED(1) = Z
8133     DMED(1) = DENS/A*XNAVO
8134     IF(A.GT.1.0 .AND. A.LT.1.1) THEN
8135     HDEN = DMED(1)
8136     ELSE
8137     HDEN = 0.0
8138     ENDIF
8139     C ------- get material parameter for a mixture---------------------
8140     KK=MIN(Q(JMA+11),100.)
8141     NCEL = 1
8142     IF(KK.GT.1) THEN
8143     NCEL = 0
8144     HDEN = 0.0
8145     AMOL = Q(LQ(JMIXT-1)+2)
8146     DO 10 K=1,KK
8147     IF(NINT(Q(JMIXT+K)).EQ.1) THEN
8148     XMOLCM = DENS/AMOL*XNAVO
8149     WI = Q(JMIXT+K+2*KK)*AMOL/Q(JMIXT+K)
8150     HDEN = HDEN + XMOLCM*WI
8151     ELSE
8152     NCEL = NCEL + 1
8153     AMED(NCEL)= Q(JMIXT+K)
8154     ZMED(NCEL) = Q(JMIXT+K+KK)
8155     XMOLCM = DENS/AMOL*XNAVO
8156     WI = Q(JMIXT+K+2*KK)*AMOL/AMED(NCEL)
8157     DMED(NCEL) = XMOLCM*WI
8158     ENDIF
8159     10 CONTINUE
8160     ENDIF
8161     ENDIF
8162     C
8163     CALL GETXSC
8164     IF( SIG .GT. 0.0) THEN
8165     SHADR = ZINTHA/SIG
8166     ELSE
8167     SHADR = BIG
8168     ENDIF
8169     ELSE
8170     SHADR = BIG
8171     ENDIF
8172     IF(DOSKAL) ICPROC = 2
8173     RETURN
8174     END
8175     *CMZ : 1.01/04 10/06/93 14.43.44 by Christian Zeitnitz
8176     *-- Author : Christian Zeitnitz 06/06/92
8177     SUBROUTINE GETXSC
8178     C***************************************************
8179     C Get x-section for hadronic interaction
8180     C
8181     C INPUT: material and particle parameters
8182     C OUTPUT: SIG = x-section
8183     C Author: C.Zeitnitz
8184     C
8185     C**************************************************
8186     C GEANT-CALOR interface common
8187     #include "calgea.inc"
8188     *KEND.
8189     C HETC-COMMON
8190     #include "ccomon.inc"
8191     *KEND.
8192     C
8193     C MICAP or HETC ?
8194     IF(IPINC.EQ.1.AND.EINC.LT.20.0) THEN
8195     C set MICAP parameter
8196     EK = EINC * 1.0E6
8197     SIG = SIGMOR(EK,NCEL)
8198     ICPROC = 1
8199     ELSE
8200     C copy parameter to HETC common
8201     NO = 1
8202     ITYP = IPINC + 1
8203     TIP(1) = FLOAT(IPINC)
8204     EC(1) = EINC
8205     IF(IPINC.LE.1.AND.EINC.GT.EMAXP) EC(1) = EMAXP*1000.
8206     IF(IPINC.GT.1.AND.EINC.GT.EMAXPI) EC(1) = EMAXPI*1000.
8207     MAT = 1
8208     MXMAT = 1
8209     NEL(1) = NCEL
8210     C copy material data to HETC
8211     DO 10 I=1,NCEL
8212     DEN(I,1) = DMED(I)
8213     ZZ(I,1) = ZMED(I)
8214     A(I,1) = AMED(I)
8215     DENH(1) = HDEN
8216     10 CONTINUE
8217     C calcutlate x-section for particle type IPINC and material
8218     CALL CALCXS
8219     SIG = SIGMX(ITYP,MAT)
8220     ICPROC = 0
8221     ENDIF
8222     RETURN
8223     END
8224     *CMZ : 1.01/04 10/06/93 14.43.44 by Christian Zeitnitz
8225     *-- Author : Christian Zeitnitz 06/06/92
8226     SUBROUTINE CALCXS
8227     C***********************************************
8228     C
8229     C calculate cross section for given material
8230     C
8231     C***********************************************
8232     #include "ccomon.inc"
8233     #include "cgeos.inc"
8234     #include "cxpd.inc"
8235     *KEND.
8236     C
8237     M=1
8238     DO 10 I=1,7
8239     SIGMX(I,M) = 0.0
8240     10 CONTINUE
8241     TOT = 0.0
8242     DO 20 L=1,NEL(MAT)
8243     EION(L,M) = CZFOI(ZZ(L,M))*1.0E-6
8244     NA = INT(A(L,M)+0.5)
8245     SIGG(L,M) = DEN(L,M)*GEOSIG(NA)
8246     TOT = TOT + SIGG(L,M)
8247     20 CONTINUE
8248     DO 30 IT=1,5
8249     HSIGG(IT,M) = DENH(M) * HSIGMX(IT) * 1.E24
8250     30 CONTINUE
8251     SIGMX(1,M) = TOT + HSIGG(1,M)
8252     SIGMX(2,M) = TOT + HSIGG(2,M)
8253     SIGMX(3,M) = TOT + SGPIMX + HSIGG(3,M)
8254     SIGMX(4,M) = 0.
8255     SIGMX(5,M) = TOT + SGPIMX + HSIGG(5,M)
8256     SIGMX(6,M) = SGMUMX
8257     SIGMX(7,M) = SGMUMX
8258     C
8259     MT =MXMAT +1
8260     SIGMX(1,MT)= SGPIMX
8261     SIGMX(2,MT)= SGPIMX
8262     SIGMX(3,MT)= SGPIMX
8263     SIGMX(4,MT)= 0.
8264     SIGMX(5,MT)= SGPIMX
8265     SIGMX(6,MT)= SGMUMX
8266     SIGMX(7,MT)= SGMUMX
8267     CZ CALL RANGE
8268     K =1
8269     SUMARG = DENH(K)* 21.132
8270     III = NEL(K)
8271     DO 40 I=1,III
8272     SUMARG = DEN(I,K)*ZZ(I,K)*(ZZ(I,K)+1.)* (10.566-.333*
8273     + ALOG(ZZ(I,K)* A(I,K))) +SUMARG
8274     40 CONTINUE
8275     ARG(K) = SQRT (.498*SUMARG)
8276     RETURN
8277     END
8278     *CMZ : 1.05/03 27/06/2001 18.17.08 by Christian Zeitnitz
8279     *-- Author : Christian Zeitnitz 30/07/92
8280     FUNCTION SIGMOR(EK,NMED)
8281     C***************************************************
8282     C Get x-section for low energetic neutrons
8283     C Ek < 20 MeV (Ek is given in eV)
8284     C INPUT: material and neutron energy
8285     C OUTPUT: SIG = x-section
8286     C
8287     C**************************************************
8288     C MICAP common
8289     #include "mmicap.inc"
8290     #include "mpoint.inc"
8291     *KEND.
8292     C
8293     CALL NSIGTA(EK,NMED,TSIG,D,LD(LFP32),LD(LFP33))
8294     SIGMOR = TSIG
8295     RETURN
8296     END
8297     *CMZ : 1.01/04 10/06/93 14.43.45 by Christian Zeitnitz
8298     *-- Author :
8299     SUBROUTINE ANGCDF(D,LD,LZ)
8300     C THIS ROUTINE READS THE INPUT ANGULAR DISTRIBUTION FILES
8301     C AND CONVERTS THEM TO A NORMALIZED CDF
8302     DIMENSION D(*),LD(*)
8303     IPP=1
8304     NR=LD(IPP)
8305     NE=LD(IPP+1)
8306     NR2=2*NR
8307     II=2+NR2
8308     10 CONTINUE
8309     E=D(II+1)
8310     NP=LD(II+2)
8311     A1=-1.0
8312     PL=D(II+4)
8313     D(II+4)=0.0
8314     PROB=0.0
8315     DO 20 I=2,NP
8316     N=II+2*I+2
8317     A2=D(N-1)
8318     PH=D(N)
8319     PROB=PROB+(PH+PL)*(A2-A1)/2.0
8320     PL=PH
8321     D(N)=PROB
8322     A1=A2
8323     20 CONTINUE
8324     DO 30 I=1,NP
8325     N=II+2*I+2
8326     D(N)=D(N)/PROB
8327     30 CONTINUE
8328     II=II+2*NP+2
8329     IF(II.GE.LZ)GO TO 40
8330     GO TO 10
8331     40 RETURN
8332     END
8333     *CMZ : 0.92/00 02/12/92 16.02.31 by Christian Zeitnitz
8334     *-- Author :
8335     SUBROUTINE BANKR(D,LD,NBNKID)
8336     C THIS IS A DUMMY ROUTINE USUALLY SUPPLIED BY THE USER TO
8337     C OBTAIN FURTHER ANALYSIS OF THE PROBLEM DEPENDING ON THE
8338     C VALUE ASSIGNED TO NBNKID.
8339     #include "minput.inc"
8340     #include "mconst.inc"
8341     #include "mpoint.inc"
8342     #include "mapoll.inc"
8343     #include "mrecoi.inc"
8344     #include "mgamma.inc"
8345     #include "mmass.inc"
8346     *KEND.
8347     DIMENSION D(*),LD(*)
8348     NBNK=NBNKID
8349     10 GO TO (20,30,40,50,60,70,80,90,100,110,120,130,140),NBNKID
8350     C SOURCES GENERATED
8351     20 RETURN
8352     C SPLITTINGS OCCURRING
8353     30 RETURN
8354     C FISSIONS OCCURRING
8355     40 RETURN
8356     C GAMMA RAYS GENERATED
8357     50 RETURN
8358     C REAL COLLISIONS
8359     60 RETURN
8360     C ALBEDO SCATTERINGS
8361     70 RETURN
8362     80 RETURN
8363     90 RETURN
8364     C ENERGY CUTOFFS
8365     100 RETURN
8366     C TIME CUTOFFS
8367     110 RETURN
8368     C RUSSIAN ROULETTE KILLS
8369     120 RETURN
8370     C RUSSIAN ROULETTE SURVIVORS
8371     130 RETURN
8372     C GAMMA RAYS NOT STORED BECAUSE BANK WAS FULL
8373     140 RETURN
8374     END
8375     *CMZ : 1.01/16 26/10/93 09.45.57 by Christian Zeitnitz
8376     *-- Author :
8377     SUBROUTINE BARIER(KZ1,KZ2,A1,A2,CB)
8378     C THIS ROUTINE CALCULATES THE COULOMB BARRIER FOR A
8379     C COLLISION INVOLVING CHARGED PARTICLE EMISSION
8380     IFLG=0
8381     C CALCULATE THE RADIUS OF THE NUCLEUS AND CHARGED PARTICLE
8382     A=A1
8383     10 IF(A.LT.5.5)R=1.20E-13
8384     IF((A.GE.5.5).AND.(A.LT.6.5))R=2.02E-13
8385     IF((A.GE.6.5).AND.(A.LT.7.5))R=2.43E-13
8386     IF((A.GE.7.5).AND.(A.LT.8.5))R=2.84E-13
8387     IF((A.GE.8.5).AND.(A.LT.9.5))R=3.25E-13
8388     IF(A.GE.9.5)R=(A**(1.0/3.0))*1.70E-13
8389     IF(IFLG.EQ.0)R1=R
8390     IF(IFLG.EQ.1)GO TO 20
8391     IFLG=1
8392     A=A2
8393     GO TO 10
8394     20 R2=R
8395     C CALCULATE THE COULOMB BARRIER (UNITS=MEV)
8396     C THE FACTOR 0.75 IS ARBITRARYLY SET TO ACCOUNT FOR CHARGED
8397     C PARTICLE EMISSION BELOW THE COULOMB BARRIER
8398     CB=((KZ1*KZ2*1.44E-13)/(R1+R2))*0.75
8399     IF(CB.LT.0.0) CB = 0.0
8400     RETURN
8401     END
8402     *CMZ : 0.90/00 20/07/92 14.28.01 by Christian Zeitnitz
8403     *-- Author :
8404     FUNCTION CADIG(E)
8405     C THIS FUNCTION ADDS A TOLERANCE TO THE ARGUMENT
8406     ARG=ALOG10(E)
8407     ITR=5-IFIX(ARG)
8408     EPS=10.**ITR
8409     CADIG=1./EPS
8410     RETURN
8411     END
8412     *CMZ : 1.01/04 10/06/93 14.43.45 by Christian Zeitnitz
8413     *-- Author :
8414     SUBROUTINE CANGLE(D,LD,E,FM,LEN)
8415     C THIS ROUTINE SELECTS THE SCATTERING ANGLE AT A COLLISION
8416     DIMENSION D(*),LD(*)
8417     SAVE
8418     I=0
8419     IPP=1
8420     NR=LD(IPP)
8421     NE=LD(IPP+1)
8422     NR2=2*NR
8423     IP=2+NR2
8424     INT=LD(IP)
8425     10 IP=IP+1
8426     I=I+1
8427     EINCD=D(IP)
8428     IF(E.LE.EINCD)GO TO 30
8429     IP1=IP
8430     IP=IP+1
8431     NP=LD(IP)
8432     IP=IP+2*NP
8433     IF(IP.GE.LEN)GO TO 20
8434     GO TO 10
8435     C E IS GREATER THAN THE LAST INCIDENT ENERGY
8436     C USE THE LAST DISTRIBUTION
8437     20 IP=IP-2*NP-1
8438     GO TO 70
8439     30 IF(I.EQ.1)GO TO 60
8440     C CHOOSE WHICH DISTRIBUTION TO SAMPLE FROM
8441     C THE INTERPOLATION SCHEME IS ASSUMED LINEAR-LINEAR IF IT
8442     C IS NOT EQUAL TO THREE (LINEAR-LOG). THIS IS GENERALLY TRUE
8443     IF(INT.NE.3)GO TO 40
8444     PROB=ALOG(EINCD/E)/ALOG(EINCD/D(IP1))
8445     40 PROB=(EINCD-E)/(EINCD-D(IP1))
8446     R=FLTRNF(0)
8447     IF(R.LE.PROB)GO TO 50
8448     C SELECT FROM THE SECOND DISTRIBUTION
8449     NP=LD(IP+1)
8450     GO TO 70
8451     C SELECT FROM THE FIRST DISTRIBUTION
8452     50 IP=IP1
8453     GO TO 70
8454     C E IS LESS THAN THE FIRST INCIDENT ENERGY
8455     C USE THE FIRST DISTRIBUTION
8456     60 NP=LD(IP+1)
8457     70 CONTINUE
8458     PROB1=0.0
8459     R=FLTRNF(0)
8460     DO 80 I=2,NP
8461     N=IP+2*I+1
8462     A1=D(N-3)
8463     IF(R.LE.D(N))GO TO 90
8464     PROB1=D(N)
8465     80 CONTINUE
8466     FM=1.0
8467     RETURN
8468     90 FM=A1+(R-PROB1)*(D(N-1)-A1)/(D(N)-PROB1)
8469     IF(ABS(FM).GT.1.) FM = 1.0
8470     RETURN
8471     END
8472     *CMZ : 1.04/00 02/02/95 09.20.58 by Christian Zeitnitz
8473     *-- Author :
8474     SUBROUTINE CEVAP(E,Q,ATAR,CB,EX)
8475     C THIS ROUTINE SAMPLES AN EXIT ENERGY FROM AN
8476     C EVAPORATION SPECTRUM
8477     #include "minput.inc"
8478     *KEND.
8479     SAVE
8480     C CONVERT THE COULOMB BARRIER (CB) TO UNITS OF EV
8481     CB=CB*1.00E+06
8482     C CALCULATE THE MAXIMUM ENERGY AVAILABLE
8483     CBI=CB
8484     EMAX=E+Q-CB
8485     IF(EMAX.GT.0.0)GO TO 10
8486     CB=0.5*CB
8487     EMAX=E+Q-CB
8488     IF(EMAX.GT.0.0)GO TO 10
8489     CB=0.0
8490     EMAX=E+Q-CB
8491     IF(EMAX.GT.0.0)GO TO 10
8492     WRITE(IOUT,10000)E,EMAX,Q,CBI
8493     10000 FORMAT(' MICAP: NEGATIVE MAXIMUM ENERGY CALCULATED IN ROUTINE ',
8494     1'EVAP --- INDICATING PROBABLE CROSS SECTION ERROR ALLOWING ',
8495     2'THE REACTION TO OCCUR',/,10X,'E,EMAX,Q,CB=',4E13.5)
8496     WRITE(6,*) ' CALOR: Fatal ERROR in EVAP ====> STOP '
8497     STOP
8498     C CALCULATE THE NUCLEAR TEMPERATURE (THETA)
8499     10 THETA=4.0161E+03*(SQRT(E+Q-CB)/(ATAR**0.8333333))
8500     C SELECT THE EXIT ENERGY FROM AN EVAPORATION SPECTRUM
8501     20 R1=FLTRNF(0)
8502     R2=FLTRNF(0)
8503     W=-ALOG(R1*R2)
8504     EX=THETA*W
8505     IF(EX.LT.0.0) EX = 0.0
8506     IF(EX.LE.EMAX)RETURN
8507     C RESAMPLE 75% OF THE TIME IF EX IS GREATER THAN EMAX
8508     R=FLTRNF(0)
8509     IF(R.LE.0.75)GO TO 20
8510     EX=EMAX
8511     RETURN
8512     END
8513     *CMZ : 0.92/00 02/12/92 16.02.32 by Christian Zeitnitz
8514     *-- Author :
8515     SUBROUTINE CEVAP1(EOLD,E,Q,ATAR,CB,EX)
8516     C THIS ROUTINE SAMPLES AN EXIT ENERGY FROM AN
8517     C EVAPORATION SPECTRUM FOR AN (N,N-PRIME X) REACTION
8518     #include "minput.inc"
8519     *KEND.
8520     SAVE
8521     C CONVERT THE COULOMB BARRIER (CB) TO UNITS OF EV
8522     CB=CB*1.00E+06
8523     C CALCULATE THE MAXIMUM ENERGY AVAILABLE
8524     CBI=CB
8525     EMAX=EOLD+Q-CB-E
8526     IF(EMAX.GT.0.0)GO TO 10
8527     CB=0.5*CB
8528     EMAX=EOLD+Q-CB-E
8529     IF(EMAX.GT.0.0)GO TO 10
8530     CB=0.0
8531     EMAX=EOLD+Q-CB-E
8532     IF(EMAX.LE.0.0)EMAX=1.0E+00
8533     C CALCULATE THE NUCLEAR TEMPERATURE (THETA)
8534     10 THETA=4.0161E+03*(SQRT(EMAX)/(ATAR**0.8333333))
8535     C SELECT THE EXIT ENERGY FROM AN EVAPORATION SPECTRUM
8536     ITRY = 0
8537     20 R1=FLTRNF(0)
8538     R2=FLTRNF(0)
8539     W=-ALOG(R1*R2)
8540     EX=THETA*W
8541     IF(EX.LE.EMAX)RETURN
8542     C RESAMPLE 75% OF THE TIME IF EX IS GREATER THAN EMAX
8543     R=FLTRNF(0)
8544     ITRY = ITRY + 1
8545     IF(R.LE.0.75.AND.ITRY.LT.5)GO TO 20
8546     EX=EMAX
8547     RETURN
8548     END
8549     *CMZ : 1.01/04 10/06/93 14.43.45 by Christian Zeitnitz
8550     *-- Author : Christian Zeitnitz 27/04/93
8551     SUBROUTINE CHKZEB(NW,IX)
8552     C
8553     C Check if NW words are available in ZEBRA division IX
8554     C
8555     C ZEBRA user communication common
8556     COMMON/ QUEST / IQUEST(100)
8557     C
8558     CALL MZNEED(IX,NW,'G')
8559     IF(IQUEST(11).LT.0) THEN
8560     PRINT *,'******************************************'
8561     PRINT *,'* G C A L O R *'
8562     PRINT *,'* NOT enough space available in ZEBRA *'
8563     PRINT '('' * division '',I3,'' to store '',I8, '
8564     + //' '' words *'')',IX,NW
8565     PRINT *,'* *'
8566     PRINT *,'* INCREASE ZEBRA COMMON SIZE AND RERUN *'
8567     PRINT *,'* *'
8568     PRINT *,'* RUN TERMINATED *'
8569     PRINT *,'******************************************'
8570     STOP
8571     ENDIF
8572     RETURN
8573     END
8574     *CMZ : 0.93/05 12/02/93 19.04.36 by Christian Zeitnitz
8575     *-- Author :
8576     SUBROUTINE CLEAR(L,L1,L2)
8577     C THIS ROUTINE ZEROS ARRAY L FROM
8578     C STARTING POINT L1 TO ENDING POINT L2
8579     DIMENSION L(*)
8580     IF(L2-L1.LT.0)GO TO 20
8581     DO 10 I=L1,L2
8582     10 L(I)=0
8583     20 RETURN
8584     END
8585     *CMZ : 1.01/04 10/06/93 14.43.45 by Christian Zeitnitz
8586     *-- Author :
8587     SUBROUTINE CMLABE(D,LD,AWR,KZ,ID,FM,Q,IFLG)
8588     C THIS ROUTINE CONVERTS THE EXIT NEUTRON SCATTERING ANGLE
8589     C FROM THE CENTER OF MASS COORDINATE SYSTEM TO THE LABORATORY
8590     C COORDINATE SYSTEM FOR AN ELASTIC SCATTERING REACTION. IT
8591     C ALSO CALCULATES THE EXIT ENERGIES AND DIRECTIONAL COSINES
8592     C FOR THE NEUTRON AND RECOIL NUCLEUS AS WELL AS SETTING ALL
8593     C EXIT PARAMETERS FOR THE RECOIL NUCLEUS.
8594     #include "minput.inc"
8595     #include "mconst.inc"
8596     #include "mnutrn.inc"
8597     #include "mrecoi.inc"
8598     #include "mapoll.inc"
8599     #include "mmass.inc"
8600     #include "mupsca.inc"
8601     #include "mpstor.inc"
8602     *KEND.
8603     DIMENSION D(*),LD(*)
8604     SAVE
8605     MT=0
8606     IF(ID.EQ.2)MT=2
8607     C IFLG EQUAL TO ONE IMPLIES LABORATORY COORDINATE SYSTEM
8608     IF(IFLG.EQ.1)GO TO 10
8609     IF(IFLG.EQ.2)GO TO 50
8610     ALPHA=((AWR-1.0)/(AWR+1.0))**2
8611     C E EQUALS THE EXIT ENERGY IN THE LAB SYSTEM
8612     E=0.5*EOLD*((1.0-ALPHA)*FM+1.0+ALPHA)
8613     C CALCULATE COSINE OF SCATTERING ANGLE (FM) IN LAB SYSTEM
8614     FM=(1.0+AWR*FM)/SQRT(1.0+AWR**2+2.0*AWR*FM)
8615     C CALCULATE THE NEUTRON EXIT DIRECTIONAL COSINES
8616     10 SINPSI=SQRT(1.0-FM**2)
8617     CALL AZIRN(SINETA,COSETA)
8618     STHETA=1.0-UOLD**2
8619     IF(STHETA)30,30,20
8620     20 STHETA=SQRT(STHETA)
8621     COSPHI=VOLD/STHETA
8622     SINPHI=WOLD/STHETA
8623     GO TO 40
8624     30 COSPHI=1.0
8625     SINPHI=0.0
8626     STHETA=0.0
8627     40 U=UOLD*FM-COSETA*SINPSI*STHETA
8628     V=VOLD*FM+UOLD*COSPHI*COSETA*SINPSI-SINPHI*SINPSI*SINETA
8629     W=WOLD*FM+UOLD*SINPHI*COSETA*SINPSI+COSPHI*SINPSI*SINETA
8630     S=1.0/SQRT(U**2+V**2+W**2)
8631     U=U*S
8632     V=V*S
8633     W=W*S
8634     C CALCULATE AND SET THE RECOIL NUCLEUS EXIT PARAMETERS
8635     50 ER=EOLD-E
8636     C PERFORM ENERGY BALANCE CONSIDERING TARGET NUCLEUS ENERGY
8637     IF(IFLG.EQ.2)ER=ERFGM+EOLD-E
8638     XR=X
8639     YR=Y
8640     ZR=Z
8641     WATER=WTBC
8642     NZR=KZ
8643     AGER=AGE
8644     NCOLR=NCOL
8645     MTNR=MT
8646     AR=AWR*AN
8647     ENIR=EOLD
8648     UNIR=UOLD
8649     VNIR=VOLD
8650     WNIR=WOLD
8651     ENOR=E
8652     UNOR=U
8653     VNOR=V
8654     WNOR=W
8655     WTNR=WATE
8656     QR=Q
8657     C CALCULATE THE NEUTRON MOMENTUM BEFORE AND AFTER COLLISION
8658     C NEUTRON MOMENTUM BEFORE COLLISION (PI) EQUALS TOTAL MOMENTUM
8659     PI=SQRT(2.0*ZN*EOLD)
8660     PO=SQRT(2.0*ZN*E)
8661     C CALCULATE THE DIRECTIONAL MOMENTUM OF THE RECOIL NUCLEUS
8662     PRX=PI*UOLD-PO*U
8663     PRY=PI*VOLD-PO*V
8664     PRZ=PI*WOLD-PO*W
8665     C CALCULATE THE TOTAL MOMENTUM OF THE RECOIL NUCLEUS
8666     PR=SQRT(PRX**2+PRY**2+PRZ**2)
8667     C CALCULATE THE RECOIL NUCLEUS DIRECTIONAL COSINES
8668     IF(PR.GT.0.0) THEN
8669     UR=PRX/PR
8670     VR=PRY/PR
8671     WR=PRZ/PR
8672     ELSE
8673     UR=0.0
8674     VR=0.0
8675     WR=0.0
8676     ENDIF
8677     C STORE THE RECOIL HEAVY ION IN THE RECOIL BANK
8678     EP = ER
8679     UP = UR
8680     VP = VR
8681     WP = WR
8682     AGEP = AGE
8683     MTP = MT
8684     AMP = AR
8685     ZMP = FLOAT(NZR)
8686     CALL STOPAR(IDHEVY,NHEVY)
8687     RETURN
8688     END
8689     *CMZ : 1.01/04 10/06/93 14.43.45 by Christian Zeitnitz
8690     *-- Author :
8691     SUBROUTINE CMLABI(D,LD,AWR,KZ,ID,FM,Q,IFLG,LIFLAG,LRI)
8692     C THIS ROUTINE CONVERTS THE EXIT NEUTRON SCATTERING ANGLE
8693     C FROM THE CENTER OF MASS COORDINATE SYSTEM TO THE LABORATORY
8694     C COORDINATE SYSTEM FOR AN INELASTIC SCATTERING REACTION. IT
8695     C ALSO CALCULATES THE EXIT ENERGIES AND DIRECTIONAL COSINES
8696     C FOR THE NEUTRON AND RECOIL NUCLEUS AS WELL AS SETTING ALL
8697     C EXIT PARAMETERS FOR THE RECOIL NUCLEUS.
8698     #include "minput.inc"
8699     #include "mconst.inc"
8700     #include "mnutrn.inc"
8701     #include "mrecoi.inc"
8702     #include "mapoll.inc"
8703     #include "mmass.inc"
8704     #include "mpstor.inc"
8705     *KEND.
8706     DIMENSION D(*),LD(*)
8707     SAVE
8708     MT=0
8709     IF((ID.GE.14).AND.(ID.LE.54))MT=51
8710     IF(MT.NE.51)GO TO 10
8711     IMT=ID-14
8712     MT=MT+IMT
8713     10 IF(ID.EQ.11)MT=22
8714     IF(ID.EQ.13)MT=28
8715     C IFLG EQUAL TO ONE IMPLIES LABORATORY COORDINATE SYSTEM
8716     IF(LIFLAG.EQ.1)GO TO 60
8717     IF(IFLG.EQ.1)GO TO 20
8718     C E1 EQUALS THE EXIT ENERGY IN THE COM SYSTEM
8719     E1=((AWR/(AWR+1.0))**2)*EOLD+Q*(AWR/(AWR+1.0))
8720     C re-sample in COLISN E1<0.0 (Q-value = -EOLD) !!!
8721     IF(E1.LT.0.0) THEN
8722     IFLG = -1
8723     RETURN
8724     ENDIF
8725     C E2 EQUALS THE EXIT ENERGY IN THE LAB SYSTEM
8726     E2=E1+(EOLD+2.0*FM*(AWR+1.0)*SQRT(EOLD*E1))/((AWR+1.0)**2)
8727     C CALCULATE COSINE OF SCATTERING ANGLE FM IN LAB SYSTEM
8728     FM=(SQRT(E1/E2))*FM+(SQRT(EOLD/E2))*(1.0/(AWR+1.0))
8729     E=E2
8730     C CALCULATE THE NEUTRON EXIT DIRECTIONAL COSINES
8731     20 SINPSI=SQRT(1.0-FM**2)
8732     CALL AZIRN(SINETA,COSETA)
8733     STHETA=1.0-UOLD**2
8734     IF(STHETA)40,40,30
8735     30 STHETA=SQRT(STHETA)
8736     COSPHI=VOLD/STHETA
8737     SINPHI=WOLD/STHETA
8738     GO TO 50
8739     40 COSPHI=1.0
8740     SINPHI=0.0
8741     STHETA=0.0
8742     50 U=UOLD*FM-COSETA*SINPSI*STHETA
8743     V=VOLD*FM+UOLD*COSPHI*COSETA*SINPSI-SINPHI*SINPSI*SINETA
8744     W=WOLD*FM+UOLD*SINPHI*COSETA*SINPSI+COSPHI*SINPSI*SINETA
8745     S=1.0/SQRT(U**2+V**2+W**2)
8746     U=U*S
8747     V=V*S
8748     W=W*S
8749     IF(MT.EQ.91)LIFLAG=1
8750     IF(MT.EQ.22)LIFLAG=1
8751     IF(MT.EQ.28)LIFLAG=1
8752     IF(LIFLAG.EQ.1)GO TO 60
8753     C CALCULATE AND SET THE RECOIL NUCLEUS EXIT PARAMETERS
8754     ER=EOLD-E+Q
8755     60 XR=X
8756     YR=Y
8757     ZR=Z
8758     WATER=WTBC
8759     NZR=KZ
8760     AGER=AGE
8761     NCOLR=NCOL
8762     MTNR=MT
8763     AR=AWR*AN
8764     ENIR=EOLD
8765     UNIR=UOLD
8766     VNIR=VOLD
8767     WNIR=WOLD
8768     ENOR=E
8769     UNOR=U
8770     VNOR=V
8771     WNOR=W
8772     WTNR=WATE
8773     QR=Q
8774     C CALCULATE THE NEUTRON MOMENTUM BEFORE AND AFTER COLLISION
8775     C NEUTRON MOMENTUM BEFORE COLLISION (PI) EQUALS TOTAL MOMENTUM
8776     PI=SQRT(2.0*ZN*EOLD)
8777     PO=SQRT(2.0*ZN*E)
8778     C CALCULATE THE DIRECTIONAL MOMENTUM OF THE RECOIL NUCLEUS
8779     PRX=PI*UOLD-PO*U
8780     PRY=PI*VOLD-PO*V
8781     PRZ=PI*WOLD-PO*W
8782     C CALCULATE THE TOTAL MOMENTUM OF THE RECOIL NUCLEUS
8783     PR=SQRT(PRX**2+PRY**2+PRZ**2)
8784     C CALCULATE THE RECOIL NUCLEUS DIRECTIONAL COSINES
8785     UR=PRX/PR
8786     VR=PRY/PR
8787     WR=PRZ/PR
8788     C CALCULATE THE RECOIL HEAVY ION ENERGY FOR MT-91
8789     IF(LIFLAG.EQ.0)GO TO 70
8790     XM = AR*931.075E6
8791     ER= SQRT(PR**2 + XM**2) - XM
8792     70 CONTINUE
8793     C IF LR-FLAG IS USED, DO NOT STORE RECOIL ION AT THIS TIME
8794     IF(LRI.EQ.22)RETURN
8795     IF(LRI.EQ.23)RETURN
8796     IF(LRI.EQ.28)RETURN
8797     C STORE THE RECOIL HEAVY ION IN THE RECOIL BANK
8798     EP = ER
8799     UP = UR
8800     VP = VR
8801     WP = WR
8802     AGEP = AGE
8803     MTP = MT
8804     AMP = AR
8805     ZMP = FLOAT(NZR)
8806     CALL STOPAR(IDHEVY,NHEVY)
8807     RETURN
8808     END
8809     *CMZ : 1.05/03 27/06/2001 18.32.27 by Christian Zeitnitz
8810     *-- Author :
8811     SUBROUTINE COLISN(D,LD,IGAMS,LGAM,INABS,LNAB,XTHRMS,ITHRMS,LTHRM,
8812     + IDICTS,LDICT,NTX,NTS,IGCBS,LGCB,AWR,Q,NSEI,NAEI,NMT2,NMT4,
8813     + NMT16,NMT17,NMT18,NMT22,NMT23,NMT24,NMT28,NMT51,NMT91,
8814     + NMT102,NMT103,NMT104,NMT105,NMT106,NMT107,NMT108,NMT109,
8815     + NMT111,NMT112,NMT113,NMT114,IGCBS2,LGCB2,KZ,LR,QLR,
8816     + IIN,IIM)
8817     C THIS ROUTINE IS CALLED AT EACH COLLISION TO
8818     C DETERMINE THE POST COLLISION PARAMETERS
8819     #include "minput.inc"
8820     #include "mconst.inc"
8821     #include "mnutrn.inc"
8822     #include "mapoll.inc"
8823     #include "mcross.inc"
8824     #include "mmass.inc"
8825     #include "mupsca.inc"
8826     #include "mpstor.inc"
8827     #include "mmicab.inc"
8828     *KEND.
8829     DIMENSION D(*),LD(*),IGAMS(*),LGAM(*),INABS(*),LNAB(*),
8830     + XTHRMS(*),ITHRMS(*),LTHRM(*),IDICTS(NNR,NNUC),LDICT(NNR,NNUC),
8831     + NTX(*),
8832     + NTS(*),IGCBS(NGR,NNUC),LGCB(NGR,NNUC),AWR(*),Q(NQ,NNUC),
8833     + NSEI(*),NAEI(*),NMT2(*),NMT4(*),NMT16(1),NMT17(*),NMT18(*),
8834     + NMT22(*),NMT23(*),NMT24(*),NMT28(*),NMT51(*),NMT91(*),
8835     + NMT102(*),NMT103(*),NMT104(*),NMT105(*),NMT106(*),NMT107(*),
8836     + NMT108(*),NMT109(*),NMT111(*),NMT112(*),NMT113(*),NMT114(*),
8837     + IGCBS2(NGR,NNUC),LGCB2(NGR,NNUC),KZ(*),LR(NQ,NNUC),QLR(NQ,NNUC),
8838     + FM(MAXNEU)
8839     C
8840     CHARACTER*80 COMM
8841     C
8842     DATA QBE8/-7.3686E+06/
8843     SAVE
8844     CALL GTMED(NMED,MED)
8845     C INITIALIZE THE COUNTERS AND FLAGS
8846     C ITRY ALLOWS FOR MULTIPLE ATTEMPTS IF THE ENDF/B PARTIAL
8847     C CROSS SECTIONS DO NOT EXACTLY SUM TO THE TOTAL
8848     10 ISTOP=0
8849     ITRY=0
8850     NCOL=NCOL+1
8851     SIGREC=0.0
8852     SUMREC=0.0
8853     FSUMS = 1.0
8854     FSUMIS = 1.0
8855     FSUMA = 1.0
8856     20 ID=0
8857     MT=0
8858     QI=0.0
8859     LRI=0
8860     QLRI=0.0
8861     DO 30 I=1,MAXNEU
8862     FM(I)=1.0
8863     30 CONTINUE
8864     DO 40 I=1,MAXNEU
8865     ENE(I)=0.0
8866     40 CONTINUE
8867     INEU = 0
8868     U1=0.0
8869     V1=0.0
8870     W1=0.0
8871     ERFGM=0.0
8872     IFLG=0
8873     LIFLAG=0
8874     AWRI=AWR(IIN)
8875     KZI=KZ(IIM)
8876     C INITIALIZE THE CROSS SECTION VARIABLES
8877     SIGT=0.0
8878     SIGTNS=0.0
8879     SIGTNA=0.0
8880     SIGNES=0.0
8881     SIGNIS=0.0
8882     SGNISD=0.0
8883     SGNISC=0.0
8884     SIGN2N=0.0
8885     SIGN3N=0.0
8886     SIGNNA=0.0
8887     SGNN3A=0.0
8888     SGN2NA=0.0
8889     SIGNNP=0.0
8890     SIGNF=0.0
8891     SIGNG=0.0
8892     SIGNP=0.0
8893     SIGND=0.0
8894     SIGNT=0.0
8895     SGN3HE=0.0
8896     SIGNA=0.0
8897     SIGN2A=0.0
8898     SIGN3A=0.0
8899     SIGN2P=0.0
8900     SIGNPA=0.0
8901     SGNT2A=0.0
8902     SGND2A=0.0
8903     SUMIS=0.0
8904     SUMS=0.0
8905     SUMA=0.0
8906     C DETERMINE THE TOTAL CROSS SECTION (MT-1)
8907     L1=LDICT(1,IIN)
8908     IF(L1.EQ.0)GO TO 50
8909     LS1=IDICTS(1,IIN) + LMOX2
8910     LEN=L1/2
8911     CALL TBSPLT(D(LS1),E,LEN,SIGT)
8912     GO TO 60
8913     50 CONTINUE
8914     COMM=' COLISN: TOTAL CROSS SECTION LENGTH IS ZERO'
8915     SIGREC = 0.0
8916     SUMREC = 0.0
8917     GOTO 980
8918     60 CONTINUE
8919     C DETERMINE THE TOTAL NEUTRON DISAPPEARANCE (MT-102 TO MT-114
8920     C AND MT-18)
8921     L1=LNAB(IIN)
8922     IF(L1.EQ.0)GO TO 70
8923     LS1=INABS(IIN)+LMOX2
8924     LEN=L1/2
8925     CALL TBSPLT(D(LS1),E,LEN,SIGTNA)
8926     GO TO 80
8927     70 SIGTNA=0.0
8928     80 CONTINUE
8929     C DETERMINE THE NON-ABSORPTION PROBABILITY
8930     PNAB=1.0-SIGTNA/SIGT
8931     C DETERMINE THE COLLISION TYPE (ABSORPTION OR SCATTERING)
8932     R=FLTRNF(0)
8933     IF(R.GT.PNAB)GO TO 570
8934     C THE REACTION TYPE IS A SCATTER
8935     NSEI(IIN)=NSEI(IIN)+1
8936     SIGTNS=SIGT-SIGTNA
8937     R=FLTRNF(0)
8938     C DETERMINE (N,N) CROSS SECTION (MT-2)
8939     ID=2
8940     L1=LDICT(ID,IIN)
8941     IF(L1.EQ.0)GO TO 110
8942     LS1=IDICTS(ID,IIN)+LMOX2
8943     LEN=L1/2
8944     CALL TBSPLT(D(LS1),E,LEN,SIGNES)
8945     SUMS=SIGNES/SIGTNS*FSUMS
8946     IF(R.GT.SUMS)GO TO 120
8947     C REACTION TYPE IS (N,N)
8948     NMT2(MED)=NMT2(MED)+1
8949     C DETERMINE IF SCATTERING OCCURS IN THE THERMAL ENERGY RANGE
8950     ETHERM = 500.*8.617E-5*TEMP/AWRI
8951     IF(E.LE.ETHERM) THEN
8952     C Reaction is a thermal scatter
8953     CALL THRMSC(D,LD,XTHRMS,ITHRMS,LTHRM,E,U,V,W,TEMP,FM,AWR,IIN,
8954     + IFLG,IOUT)
8955     QI=Q(ID,IIN)
8956     CALL CMLABE(D,LD,AWRI,KZI,ID,FM,QI,IFLG)
8957     EP = E
8958     VP = V
8959     UP = U
8960     WP = W
8961     AGEP = AGE
8962     MTP = 2
8963     CALL STOPAR(IDNEU,NNEU)
8964     RETURN
8965     ENDIF
8966     C DETERMINE THE COSINE OF THE NEUTRON SCATTERING ANGLE IN THE
8967     C CENTER OF MASS COORDINATE SYSTEM
8968     L1=LDICT(67,IIN)
8969     IF(L1.EQ.0)GO TO 90
8970     LS1=IDICTS(67,IIN)+LMOX2
8971     LEN=L1
8972     CALL CANGLE(D(LS1),LD(LS1),E,FM(1),LEN)
8973     GO TO 100
8974     C ASSUME ISOTROPIC IN THE CENTER OF MASS COORDINATE SYSTEM
8975     90 R=FLTRNF(0)
8976     FM(1)=2.0*R-1.0
8977     C DETERMINE THE EXIT COLLISION PARAMETERS IN THE LABORATORY
8978     C COORDINATE SYSTEM
8979     100 CONTINUE
8980     QI=Q(ID,IIN)
8981     CALL CMLABE(D,LD,AWRI,KZI,ID,FM(1),QI,IFLG)
8982     EP = E
8983     VP = V
8984     UP = U
8985     WP = W
8986     AGEP = AGE
8987     MTP = 2
8988     CALL STOPAR(IDNEU,NNEU)
8989     RETURN
8990     110 SIGNES=0.0
8991     120 CONTINUE
8992     C DETERMINE (N,N") CROSS SECTION (MT-4)
8993     ID=3
8994     L1=LDICT(ID,IIN)
8995     IF(L1.EQ.0)GO TO 240
8996     LS1=IDICTS(ID,IIN)+LMOX2
8997     LEN=L1/2
8998     CALL TBSPLT(D(LS1),E,LEN,SIGNIS)
8999     SUMS=SUMS+SIGNIS/SIGTNS*FSUMS
9000     IF(R.GT.SUMS)GO TO 250
9001     C REACTION TYPE IS (N,N")
9002     NMT4(MED)=NMT4(MED)+1
9003     C DETERMINE (N,N"-DISCRETE) CROSS SECTION (MT-51 TO MT-90)
9004     R=FLTRNF(0)
9005     DO 130 I=14,53
9006     L1=LDICT(I,IIN)
9007     IF(L1.EQ.0)GO TO 170
9008     LS1=IDICTS(I,IIN)+LMOX2
9009     LEN=L1/2
9010     CALL XSECNU(D,LEN,E,SGNISD,LS1,L1)
9011     SUMIS=SUMIS+SGNISD/SIGNIS*FSUMIS
9012     IF(R.LE.SUMIS)GO TO 140
9013     130 CONTINUE
9014     GO TO 180
9015     140 CONTINUE
9016     C REACTION TYPE IS (N,N") DISCRETE
9017     NMT51(MED)=NMT51(MED)+1
9018     I=I+68
9019     C DETERMINE THE COSINE OF THE NEUTRON SCATTERING ANGLE IN THE
9020     C CENTER OF MASS COORDINATE SYSTEM
9021     L1=LDICT(I,IIN)
9022     IF(L1.EQ.0)GO TO 150
9023     LS1=IDICTS(I,IIN)+LMOX2
9024     LEN=L1
9025     CALL CANGLE(D(LS1),LD(LS1),E,FM(1),LEN)
9026     GO TO 160
9027     C ASSUME ISOTROPIC IN THE CENTER OF MASS COORDINATE SYSTEM
9028     150 R=FLTRNF(0)
9029     FM(1)=2.0*R-1.0
9030     C DETERMINE THE EXIT COLLISION PARAMETERS IN THE LABORATORY
9031     C COORDINATE SYSTEM
9032     160 ID=I-68
9033     QI=Q(ID,IIN)
9034     LRI=LR(ID,IIN)
9035     QLRI=QLR(ID,IIN)
9036     CALL CMLABI(D,LD,AWRI,KZI,ID,FM(1),QI,IFLG,LIFLAG,LRI)
9037     C Re-sample if no energy determined in CMLABI
9038     IF(IFLG.EQ.-1) GOTO 10
9039     EP = E
9040     VP = V
9041     UP = U
9042     WP = W
9043     AGEP = AGE
9044     MTP = 51
9045     CALL STOPAR(IDNEU,NNEU)
9046     IF(LRI.EQ.22)GO TO 520
9047     IF(LRI.EQ.23)GO TO 530
9048     IF(LRI.EQ.28)GO TO 540
9049     CALL PHOTON(D,LD,IDICTS,LDICT,NTX,NTS,IGCBS,LGCB,AWR,
9050     +IGCBS2,LGCB2,LR,IGAMS,LGAM,QI,ID,IIN,LRI,SGNISD)
9051     RETURN
9052     170 SGNISD=0.0
9053     180 CONTINUE
9054     C DISCRETE INELASTIC SCATTERING LEVEL WAS NOT CHOSEN
9055     C DETERMINE (N,N"-CONTINUUM) CROSS SECTION (MT-91)
9056     ID=54
9057     L1=LDICT(ID,IIN)
9058     IF(L1.EQ.0)GO TO 210
9059     LS1=IDICTS(ID,IIN)+LMOX2
9060     LEN=L1/2
9061     CALL TBSPLT(D(LS1),E,LEN,SGNISC)
9062     SUMIS=SUMIS+SGNISC/SIGNIS*FSUMIS
9063     IF(R.GT.SUMIS)GO TO 220
9064     C REACTION TYPE IS (N,N") CONTINUUM
9065     NMT91(MED)=NMT91(MED)+1
9066     C DETERMINE THE COSINE OF THE NEUTRON SCATTERING ANGLE IN THE
9067     C LABORATORY COORDINATE SYSTEM
9068     L1=LDICT(122,IIN)
9069     IF(L1.EQ.0)GO TO 190
9070     LS1=IDICTS(122,IIN)+LMOX2
9071     LEN=L1
9072     CALL CANGLE(D(LS1),LD(LS1),E,FM(1),LEN)
9073     GO TO 200
9074     C ASSUME ISOTROPIC IN THE LABORATORY COORDINATE SYSTEM
9075     190 CALL GTISO(U1,V1,W1)
9076     U=U1
9077     V=V1
9078     W=W1
9079     LIFLAG=1
9080     C DETERMINE THE EXIT NEUTRON ENERGY IN THE LABORATORY
9081     C COORDINATE SYSTEM
9082     200 L1=LDICT(133,IIN)
9083     IF(L1.EQ.0)GO TO 230
9084     LS1=IDICTS(133,IIN)+LMOX2
9085     CALL SECEGY(EX,D(LS1),E,LD(LS1))
9086     E=EX
9087     IFLG=1
9088     C DETERMINE THE EXIT COLLISION PARAMETERS IN THE LABORATORY
9089     C COORDINATE SYSTEM
9090     QI=Q(ID,IIN)
9091     LRI=LR(ID,IIN)
9092     QLRI=QLR(ID,IIN)
9093     CALL CMLABI(D,LD,AWRI,KZI,ID,FM(1),QI,IFLG,LIFLAG,LRI)
9094     C Re-sample if no energy determined in CMLABI
9095     IF(IFLG.EQ.-1) GOTO 10
9096     EP = E
9097     VP = V
9098     UP = U
9099     WP = W
9100     AGEP = AGE
9101     MTP = 91
9102     CALL STOPAR(IDNEU,NNEU)
9103     IF(LRI.EQ.22)GO TO 520
9104     IF(LRI.EQ.23)GO TO 530
9105     IF(LRI.EQ.28)GO TO 540
9106     CALL PHOTON(D,LD,IDICTS,LDICT,NTX,NTS,IGCBS,LGCB,AWR,
9107     +IGCBS2,LGCB2,LR,IGAMS,LGAM,QI,ID,IIN,LRI,SGNISC)
9108     RETURN
9109     210 SGNISC=0.0
9110     220 CONTINUE
9111     COMM= ' COLISN: INELASTIC SCATTERING CROSS SECTION WAS NOT CHOSEN'
9112     NMT4(MED)=NMT4(MED)-1
9113     FSUMIS = 1./SUMIS
9114     GO TO 550
9115     230 CONTINUE
9116     COMM=' COLISN: NO SECONDARY ENERGY DISTRIBUTION WAS FOUND MT-91'
9117     ISTOP=1
9118     GO TO 560
9119     240 SIGNIS=0.0
9120     250 CONTINUE
9121     C DETERMINE (N,2N) CROSS SECTION (MT-16)
9122     ID=8
9123     L1=LDICT(ID,IIN)
9124     IF(L1.EQ.0)GO TO 290
9125     LS1=IDICTS(ID,IIN)+LMOX2
9126     LEN=L1/2
9127     CALL TBSPLT(D(LS1),E,LEN,SIGN2N)
9128     SUMS=SUMS+SIGN2N/SIGTNS*FSUMS
9129     IF(R.GT.SUMS)GO TO 300
9130     C REACTION TYPE IS (N,2N)
9131     NMT16(MED)=NMT16(MED)+1
9132     C USE THE ONE NEUTRON EMISSION MODEL AND MULTIPLY THE
9133     C WEIGHT BY TWO
9134     C changed to 2 neutron production CZ July 30, 1992
9135     CZ WATE=2.0*WATE
9136     C DETERMINE THE COSINE OF THE NEUTRON SCATTERING ANGLE IN THE
9137     C LABORATORY COORDINATE SYSTEM
9138     L1=LDICT(72,IIN)
9139     IF(L1.EQ.0)GO TO 260
9140     LS1=IDICTS(72,IIN)+LMOX2
9141     LEN=L1
9142     C get scattering angle for 1. neutron
9143     CALL CANGLE(D(LS1),LD(LS1),E,FM(1),LEN)
9144     C get scattering angle for 2. neutron
9145     CALL CANGLE(D(LS1),LD(LS1),E,FM(2),LEN)
9146     GO TO 270
9147     C ASSUME ISOTROPIC IN THE LABORATORY COORDINATE SYSTEM
9148     260 CONTINUE
9149     IFLG=1
9150     C DETERMINE THE EXIT NEUTRON ENERGY IN THE LABORATORY
9151     C COORDINATE SYSTEM
9152     270 INEU = 2
9153     L1=LDICT(123,IIN)
9154     IF(L1.EQ.0)GO TO 280
9155     LS1=IDICTS(123,IIN)+LMOX2
9156     CALL GETENE(E,D(LS1),LD(LS1),INEU)
9157     C DETERMINE THE EXIT COLLISION PARAMETERS IN THE LABORATORY
9158     C COORDINATE SYSTEM
9159     QI=Q(ID,IIN)
9160     CALL N2NN3N(D,LD,AWRI,KZI,ID,FM,QI,IFLG)
9161     CALL PHOTON(D,LD,IDICTS,LDICT,NTX,NTS,IGCBS,LGCB,AWR,
9162     +IGCBS2,LGCB2,LR,IGAMS,LGAM,QI,ID,IIN,LRI,SIGN2N)
9163     RETURN
9164     280 CONTINUE
9165     COMM=' COLISN: NO SECONDARY ENERGY DISTRIBUTION WAS FOUND MT-16'
9166     ISTOP=1
9167     GO TO 560
9168     290 SIGN2N=0.0
9169     300 CONTINUE
9170     C DETERMINE (N,3N) CROSS SECTION (MT-17)
9171     ID=9
9172     L1=LDICT(ID,IIN)
9173     IF(L1.EQ.0)GO TO 350
9174     LS1=IDICTS(ID,IIN)+LMOX2
9175     LEN=L1/2
9176     CALL TBSPLT(D(LS1),E,LEN,SIGN3N)
9177     SUMS=SUMS+SIGN3N/SIGTNS*FSUMS
9178     IF(R.GT.SUMS)GO TO 360
9179     C REACTION TYPE IS (N,3N)
9180     NMT17(MED)=NMT17(MED)+1
9181     C USE THE ONE NEUTRON EMISSION MODEL AND MULTIPLY THE
9182     C WEIGHT BY THREE
9183     C changed to 3 neutron production CZ July 30,1992
9184     CZ WATE=3.0*WATE
9185     C DETERMINE THE COSINE OF THE NEUTRON SCATTERING ANGLE IN THE
9186     C LABORATORY COORDINATE SYSTEM
9187     L1=LDICT(73,IIN)
9188     IF(L1.EQ.0)GO TO 320
9189     LS1=IDICTS(73,IIN)+LMOX2
9190     LEN=L1
9191     DO 310 KN=1,3
9192     CALL CANGLE(D(LS1),LD(LS1),E,FM(KN),LEN)
9193     310 CONTINUE
9194     GO TO 330
9195     C ASSUME ISOTROPIC IN THE LABORATORY COORDINATE SYSTEM
9196     320 CONTINUE
9197     IFLG=1
9198     C DETERMINE THE EXIT NEUTRON ENERGY IN THE LABORATORY
9199     C COORDINATE SYSTEM
9200     330 L1=LDICT(124,IIN)
9201     IF(L1.EQ.0)GO TO 340
9202     LS1=IDICTS(124,IIN)+LMOX2
9203     INEU = 3
9204     CALL GETENE(E,D(LS1),LD(LS1),INEU)
9205     C DETERMINE THE EXIT COLLISION PARAMETERS IN THE LABORATORY
9206     C COORDINATE SYSTEM
9207     QI=Q(ID,IIN)
9208     CALL N2NN3N(D,LD,AWRI,KZI,ID,FM,QI,IFLG)
9209     CALL PHOTON(D,LD,IDICTS,LDICT,NTX,NTS,IGCBS,LGCB,AWR,
9210     +IGCBS2,LGCB2,LR,IGAMS,LGAM,QI,ID,IIN,LRI,SIGN3N)
9211     RETURN
9212     340 CONTINUE
9213     COMM= ' COLISN; NO SECONDARY ENERGY DISTRIBUTION WAS FOUND MT-17'
9214     ISTOP=1
9215     GO TO 560
9216     350 SIGN3N=0.0
9217     360 CONTINUE
9218     C DETERMINE (N,N"A) CROSS SECTION (MT-22)
9219     ID=11
9220     L1=LDICT(ID,IIN)
9221     IF(L1.EQ.0)GO TO 400
9222     LS1=IDICTS(ID,IIN)+LMOX2
9223     LEN=L1/2
9224     CALL TBSPLT(D(LS1),E,LEN,SIGNNA)
9225     SUMS=SUMS+SIGNNA/SIGTNS*FSUMS
9226     IF(R.GT.SUMS)GO TO 410
9227     C REACTION TYPE IS (N,N"A)
9228     NMT22(MED)=NMT22(MED)+1
9229     C DETERMINE THE COSINE OF THE NEUTRON SCATTERING ANGLE IN THE
9230     C LABORATORY COORDINATE SYSTEM
9231     L1=LDICT(75,IIN)
9232     IF(L1.EQ.0)GO TO 370
9233     LS1=IDICTS(75,IIN)+LMOX2
9234     LEN=L1
9235     CALL CANGLE(D(LS1),LD(LS1),E,FM(1),LEN)
9236     GO TO 380
9237     C ASSUME ISOTROPIC IN THE LABORATORY COORDINATE SYSTEM
9238     370 CALL GTISO(U1,V1,W1)
9239     U=U1
9240     V=V1
9241     W=W1
9242     LIFLAG=1
9243     C DETERMINE THE EXIT NEUTRON ENERGY IN THE LABORATORY
9244     C COORDINATE SYSTEM
9245     380 L1=LDICT(126,IIN)
9246     IF(L1.EQ.0)GO TO 390
9247     LS1=IDICTS(126,IIN)+LMOX2
9248     CALL SECEGY(EX,D(LS1),E,LD(LS1))
9249     E=EX
9250     IFLG=1
9251     C DETERMINE THE EXIT COLLISION PARAMETERS IN THE LABORATORY
9252     C COORDINATE SYSTEM
9253     QI=Q(ID,IIN)
9254     LRI=22
9255     CALL CMLABI(D,LD,AWRI,KZI,ID,FM(1),QI,IFLG,LIFLAG,LRI)
9256     C Re-sample if no energy determined in CMLABI
9257     IF(IFLG.EQ.-1) GOTO 10
9258     UP = U
9259     VP = V
9260     WP = W
9261     EP = E
9262     AGEP = AGE
9263     MTP = 22
9264     CALL STOPAR(IDNEU,NNEU)
9265     KZ1=2
9266     KZ2=KZI-KZ1
9267     ATAR=AWRI*AN
9268     A1=AA
9269     A2=ATAR-AA
9270     Z1=ZA
9271     Z2=A2*9.31075E+08
9272     MT=22
9273     CALL NN2BOD(D,LD,KZ1,KZ2,A1,A2,Z1,Z2,ATAR,QI,MT)
9274     CALL PHOTON(D,LD,IDICTS,LDICT,NTX,NTS,IGCBS,LGCB,AWR,
9275     +IGCBS2,LGCB2,LR,IGAMS,LGAM,QI,ID,IIN,LRI,SIGNNA)
9276     RETURN
9277     390 CONTINUE
9278     COMM=' COLISN; NO SECONDARY ENERGY DISTRIBUTION WAS FOUND MT-22'
9279     ISTOP=1
9280     GO TO 560
9281     400 SIGNNA=0.0
9282     410 CONTINUE
9283     C DETERMINE (N,2NA) CROSS SECTION (MT-24)
9284     ID=12
9285     L1=LDICT(ID,IIN)
9286     IF(L1.EQ.0)GO TO 450
9287     LS1=IDICTS(ID,IIN)+LMOX2
9288     LEN=L1/2
9289     CALL TBSPLT(D(LS1),E,LEN,SGN2NA)
9290     SUMS=SUMS+SGN2NA/SIGTNS*FSUMS
9291     IF(R.GT.SUMS)GO TO 460
9292     C REACTION TYPE IS (N,2NA)
9293     NMT24(MED)=NMT24(MED)+1
9294     C USE THE ONE NEUTRON EMISSION MODEL AND MULTIPLY THE
9295     C WEIGHT BY TWO
9296     C changed to 2 neutron production CZ July 30,1992
9297     CZ WATE=2.0*WATE
9298     C DETERMINE THE COSINE OF THE NEUTRON SCATTERING ANGLE IN THE
9299     C LABORATORY COORDINATE SYSTEM
9300     L1=LDICT(76,IIN)
9301     IF(L1.EQ.0)GO TO 420
9302     LS1=IDICTS(76,IIN)+LMOX2
9303     LEN=L1
9304     CALL CANGLE(D(LS1),LD(LS1),E,FM(1),LEN)
9305     CALL CANGLE(D(LS1),LD(LS1),E,FM(2),LEN)
9306     GO TO 430
9307     C ASSUME ISOTROPIC IN THE LABORATORY COORDINATE SYSTEM
9308     420 CONTINUE
9309     IFLG=1
9310     C DETERMINE THE EXIT NEUTRON ENERGY IN THE LABORATORY
9311     C COORDINATE SYSTEM
9312     430 L1=LDICT(127,IIN)
9313     IF(L1.EQ.0)GO TO 440
9314     LS1=IDICTS(127,IIN)+LMOX2
9315     INEU=2
9316     CALL GETENE(E,D(LS1),LD(LS1),INEU)
9317     C DETERMINE THE EXIT COLLISION PARAMETERS IN THE LABORATORY
9318     C COORDINATE SYSTEM
9319     QI=Q(ID,IIN)
9320     CALL N2NN3N(D,LD,AWRI,KZI,ID,FM,QI,IFLG)
9321     KZ1=2
9322     KZ2=KZI-KZ1
9323     ATAR=AWRI*AN
9324     A1=AA
9325     A2=ATAR-AN-AA
9326     Z1=ZA
9327     Z2=A2*9.31075E+08
9328     MT=24
9329     CALL NN2BOD(D,LD,KZ1,KZ2,A1,A2,Z1,Z2,ATAR,QI,MT)
9330     CALL PHOTON(D,LD,IDICTS,LDICT,NTX,NTS,IGCBS,LGCB,AWR,
9331     +IGCBS2,LGCB2,LR,IGAMS,LGAM,QI,ID,IIN,LRI,SGN2NA)
9332     RETURN
9333     440 CONTINUE
9334     COMM=' COLISN; NO SECONDARY ENERGY DISTRIBUTION WAS FOUND MT-24'
9335     ISTOP=1
9336     GO TO 560
9337     450 SGN2NA=0.0
9338     460 CONTINUE
9339     C DETERMINE (N,N"P) CROSS SECTION (MT-28)
9340     ID=13
9341     L1=LDICT(ID,IIN)
9342     IF(L1.EQ.0)GO TO 500
9343     LS1=IDICTS(ID,IIN)+LMOX2
9344     LEN=L1/2
9345     CALL TBSPLT(D(LS1),E,LEN,SIGNNP)
9346     SUMS=SUMS+SIGNNP/SIGTNS*FSUMS
9347     IF(R.GT.SUMS)GO TO 510
9348     C REACTION TYPE IS (N,N"P)
9349     NMT28(MED)=NMT28(MED)+1
9350     C DETERMINE THE COSINE OF THE NEUTRON SCATTERING ANGLE IN THE
9351     C LABORATORY COORDINATE SYSTEM
9352     L1=LDICT(77,IIN)
9353     IF(L1.EQ.0)GO TO 470
9354     LS1=IDICTS(77,IIN)+LMOX2
9355     LEN=L1
9356     CALL CANGLE(D(LS1),LD(LS1),E,FM(1),LEN)
9357     GO TO 480
9358     C ASSUME ISOTROPIC IN THE LABORATORY COORDINATE SYSTEM
9359     470 CALL GTISO(U1,V1,W1)
9360     U=U1
9361     V=V1
9362     W=W1
9363     LIFLAG=1
9364     C DETERMINE THE EXIT NEUTRON ENERGY IN THE LABORATORY
9365     C COORDINATE SYSTEM
9366     480 L1=LDICT(128,IIN)
9367     IF(L1.EQ.0)GO TO 490
9368     LS1=IDICTS(128,IIN)+LMOX2
9369     CALL SECEGY(EX,D(LS1),E,LD(LS1))
9370     E=EX
9371     IFLG=1
9372     C DETERMINE THE EXIT COLLISION PARAMETERS IN THE LABORATORY
9373     C COORDINATE SYSTEM
9374     QI=Q(ID,IIN)
9375     LRI=28
9376     CALL CMLABI(D,LD,AWRI,KZI,ID,FM(1),QI,IFLG,LIFLAG,LRI)
9377     C Re-sample if no energy determined in CMLABI
9378     IF(IFLG.EQ.-1) GOTO 10
9379     EP = E
9380     UP = U
9381     VP = V
9382     WP = W
9383     AGEP = AGE
9384     MTP = 28
9385     CALL STOPAR(IDNEU,NNEU)
9386     KZ1=1
9387     KZ2=KZI-KZ1
9388     ATAR=AWRI*AN
9389     A1=AP
9390     A2=ATAR-AP
9391     Z1=ZP
9392     Z2=A2*9.31075E+08
9393     MT=28
9394     CALL NN2BOD(D,LD,KZ1,KZ2,A1,A2,Z1,Z2,ATAR,QI,MT)
9395     CALL PHOTON(D,LD,IDICTS,LDICT,NTX,NTS,IGCBS,LGCB,AWR,
9396     +IGCBS2,LGCB2,LR,IGAMS,LGAM,QI,ID,IIN,LRI,SIGNNP)
9397     RETURN
9398     490 CONTINUE
9399     COMM=' COLISN; NO SECONDARY ENERGY DISTRIBUTION FOUND FOR MT-28'
9400     SIGREC=SIGTNS
9401     SUMREC=SUMS
9402     ISTOP=1
9403     GO TO 560
9404     500 SIGNNP=0.0
9405     510 CONTINUE
9406     FSUMS = 1./SUMS
9407     GO TO 550
9408     520 CONTINUE
9409     C REACTION TYPE IS (N,N"A) USING LR FLAG
9410     NMT22(MED)=NMT22(MED)+1
9411     SIGNNA=SGNISD
9412     IF(ID.EQ.54)SIGNNA=SGNISC
9413     KZ1=2
9414     KZ2=KZI-KZ1
9415     ATAR=AWRI*AN
9416     A1=AA
9417     A2=ATAR-AA
9418     Z1=ZA
9419     Z2=A2*9.31075E+08
9420     MT=22
9421     CALL LR2BOD(D,LD,KZ1,KZ2,A1,A2,Z1,Z2,ATAR,QI,QLRI,ID,MT)
9422     CALL PHOTON(D,LD,IDICTS,LDICT,NTX,NTS,IGCBS,LGCB,AWR,
9423     +IGCBS2,LGCB2,LR,IGAMS,LGAM,QI,ID,IIN,LRI,SIGNNA)
9424     RETURN
9425     530 CONTINUE
9426     C REACTION TYPE IS (N,N"3A) USING LR FLAG
9427     C CARBON-12 IS CURRENTLY THE ONLY ELEMENT CONTAINING MT-23
9428     NMT23(MED)=NMT23(MED)+1
9429     SGNN3A=SGNISD
9430     IF(ID.EQ.54)SGNN3A=SGNISC
9431     KZ1=2
9432     KZ2=KZI-KZ1
9433     ATAR=AWRI*AN
9434     A1=AA
9435     A2=ATAR-AA
9436     Z1=ZA
9437     Z2=A2*9.31075E+08
9438     C QBE8 IS THE MASS DIFFERENCE FOR A CARBON-ALPHA EMISSION
9439     MT=23
9440     CALL LR2BOD(D,LD,KZ1,KZ2,A1,A2,Z1,Z2,ATAR,QI,QBE8,ID,MT)
9441     KZ1=2
9442     KZ2=KZ2-KZ1
9443     ATAR=AWRI*AN
9444     A1=AA
9445     A2=A2-AA
9446     Z1=ZA
9447     Z2=A2*9.31075E+08
9448     MT=23
9449     CALL LR2BOD(D,LD,KZ1,KZ2,A1,A2,Z1,Z2,ATAR,QBE8,QLRI,ID,MT)
9450     CALL PHOTON(D,LD,IDICTS,LDICT,NTX,NTS,IGCBS,LGCB,AWR,
9451     +IGCBS2,LGCB2,LR,IGAMS,LGAM,QI,ID,IIN,LRI,SGNN3A)
9452     RETURN
9453     540 CONTINUE
9454     C REACTION TYPE IS (N,N"P) USING LR FLAG
9455     NMT28(MED)=NMT28(MED)+1
9456     SIGNNP=SGNISD
9457     IF(ID.EQ.54)SIGNNP=SGNISC
9458     KZ1=1
9459     KZ2=KZI-KZ1
9460     ATAR=AWRI*AN
9461     A1=AP
9462     A2=ATAR-AP
9463     Z1=ZP
9464     Z2=A2*9.31075E+08
9465     MT=28
9466     CALL LR2BOD(D,LD,KZ1,KZ2,A1,A2,Z1,Z2,ATAR,QI,QLRI,ID,MT)
9467     CALL PHOTON(D,LD,IDICTS,LDICT,NTX,NTS,IGCBS,LGCB,AWR,
9468     +IGCBS2,LGCB2,LR,IGAMS,LGAM,QI,ID,IIN,LRI,SIGNNP)
9469     RETURN
9470     550 ITRY=ITRY+1
9471     NSEI(IIN)=NSEI(IIN)-1
9472     ISTOP = 1
9473     IF((FSUMS.GT.0.1.AND.FSUMS.LE.10.0).AND.
9474     + (FSUMIS.GT.0.1.AND.FSUMIS.LE.10.0)) ISTOP = 0
9475     IF(ISTOP.EQ.0.AND.ITRY.LE.5) GOTO 20
9476     C A SCATTERING REACTION WAS NOT CHOSEN
9477     COMM=' COLISN: A SCATTERING REACTION TYPE WAS NOT CHOSEN '
9478     SIGREC=SIGTNS
9479     SUMREC=SUMS
9480     GOTO 980
9481     560 CONTINUE
9482     IF(ISTOP.EQ.1)GO TO 980
9483     ITRY=0
9484     GO TO 20
9485     C THE REACTION TYPE IS AN ABSORPTION
9486     570 NAEI(IIN)=NAEI(IIN)+1
9487     R=FLTRNF(0)
9488     C DETERMINE THE FISSION CROSS SECTION (MT-18)
9489     C THE TREATMENT OF THE FISSION REACTION ASSUMES THE FISSION
9490     C CROSS SECTION IS STORED AS NUBAR*SIGF
9491     ID=10
9492     L1=LDICT(ID,IIN)
9493     IF(L1.EQ.0)GO TO 640
9494     LS1=IDICTS(ID,IIN)+LMOX2
9495     LEN=L1/2
9496     CALL TBSPLT(D(LS1),E,LEN,SIGNF)
9497     C DETERMINE THE AVERAGE NUMBER OF NEUTRONS EMITTED PER FISSION
9498     C EVENT (NUBAR)
9499     L1=LDICT(134,IIN)
9500     IF(L1.EQ.0)GO TO 630
9501     LS1=IDICTS(134,IIN)+LMOX2
9502     LEN=L1
9503     CALL GETNU(D(LS1),LD(LS1),EOLD,LEN,XNU)
9504     C EXTRACT THE FISSION CROSS SECTION FROM THE NUBAR*SIGF CROSS
9505     C SECTION STORED IN POSITION 10 OF THE DICTIONARY
9506     SIGNF=SIGNF/XNU
9507     SUMA=SIGNF/SIGTNA*FSUMA
9508     IF(R.GT.SUMA)GO TO 650
9509     C THE REACTION TYPE IS (N,F)
9510     NMT18(MED)=NMT18(MED)+1
9511     WATE = 0.0
9512     C DETERMINE THE COSINE OF THE NEUTRON SCATTERING ANGLE IN THE
9513     C LABORATORY COORDINATE SYSTEM
9514     C changed in order to get N fission neutron CZ July 30,1992
9515     C INEU is poisson distributed with mean XNU
9516     580 CALL GPOISS(XNU,INEU,1)
9517     IF(INEU.GT.INT(4.*XNU)) GOTO 580
9518     C check for maximum number of neutrons emitted
9519     IF(INEU.GT.INT(AWRI)-KZ(MED)) INEU = INT(AWRI) - KZ(MED)
9520     IF(INEU.GT.MAXNEU) INEU = MAXNEU
9521     L1=LDICT(74,IIN)
9522     IF(L1.EQ.0)GO TO 600
9523     LS1=IDICTS(74,IIN)+LMOX2
9524     LEN=L1
9525     DO 590 KN=1,INEU
9526     CALL CANGLE(D(LS1),LD(LS1),E,FM(KN),LEN)
9527     590 CONTINUE
9528     GO TO 610
9529     C ASSUME ISOTROPIC IN THE LABORATORY COORDINATE SYSTEM
9530     600 CONTINUE
9531     LIFLAG=1
9532     C DETERMINE THE EXIT NEUTRON ENERGY IN THE LABORATORY
9533     C COORDINATE SYSTEM
9534     610 L1=LDICT(125,IIN)
9535     IF(L1.EQ.0)GO TO 620
9536     LS1=IDICTS(125,IIN)+LMOX2
9537     IF(INEU.GT.0) CALL GETENE(E,D(LS1),LD(LS1),INEU)
9538     C DETERMINE THE EXIT NEUTRON WEIGHT FROM THE AVERAGE NUMBER
9539     C OF NEUTRONS EMITTED PER FISSION REACTION (NU)
9540     C changed CZ July 30,1992
9541     CZ WATE=WATE*XNU
9542     C DETERMINE THE EXIT COLLISION PARAMETERS IN THE LABORATORY
9543     C COORDINATE SYSTEM
9544     QI=Q(ID,IIN)
9545     IF(INEU.GT.0) CALL LABNF(D,LD,FM,AWRI,KZI,QI,LIFLAG)
9546     CALL PHOTON(D,LD,IDICTS,LDICT,NTX,NTS,IGCBS,LGCB,AWR,
9547     +IGCBS2,LGCB2,LR,IGAMS,LGAM,QI,ID,IIN,LRI,SIGNF)
9548     NPSCL(3)=NPSCL(3)+1
9549     CALL BANKR(D,LD,3)
9550     RETURN
9551     620 CONTINUE
9552     COMM=' COLISN: NO SECONDARY ENERGY DISTRIBUTION FOUND FOR MT-18'
9553     SIGREC=SIGNF
9554     SUMREC=SUMA
9555     ISTOP=1
9556     GO TO 970
9557     630 CONTINUE
9558     COMM=' COLISN: NO NUMBER OF FISSION NEUTRON FOUND FOR MT-18'
9559     SIGREC=SIGNF
9560     SUMREC=SUMA
9561     ISTOP=1
9562     GO TO 970
9563     640 SIGNF=0.0
9564     650 CONTINUE
9565     C DETERMINE (N,G) CROSS SECTION (MT-102)
9566     ID=55
9567     L1=LDICT(ID,IIN)
9568     IF(L1.EQ.0)GO TO 660
9569     LS1=IDICTS(ID,IIN)+LMOX2
9570     LEN=L1/2
9571     CALL TBSPLT(D(LS1),E,LEN,SIGNG)
9572     SUMA=SUMA+SIGNG/SIGTNA*FSUMA
9573     IF(R.GT.SUMA)GO TO 670
9574     C THE REACTION TYPE IS (N,G)
9575     NMT102(MED)=NMT102(MED)+1
9576     QI=Q(ID,IIN)
9577     CALL PHOTON(D,LD,IDICTS,LDICT,NTX,NTS,IGCBS,LGCB,AWR,
9578     +IGCBS2,LGCB2,LR,IGAMS,LGAM,QI,ID,IIN,LRI,SIGNG)
9579     MT=102
9580     CALL NGHEVY(D,LD,KZI,AWRI,QI,MT)
9581     WATE=0.0
9582     RETURN
9583     660 SIGNG=0.0
9584     670 CONTINUE
9585     C DETERMINE (N,P) CROSS SECTION (MT-103)
9586     ID=56
9587     L1=LDICT(ID,IIN)
9588     IF(L1.EQ.0)GO TO 690
9589     LS1=IDICTS(ID,IIN)+LMOX2
9590     LEN=L1/2
9591     CALL TBSPLT(D(LS1),E,LEN,SIGNP)
9592     SUMA=SUMA+SIGNP/SIGTNA*FSUMA
9593     IF(R.GT.SUMA)GO TO 700
9594     C THE REACTION TYPE IS (N,P)
9595     NMT103(MED)=NMT103(MED)+1
9596     QI=Q(ID,IIN)
9597     KZ1=1
9598     KZ2=KZI-KZ1
9599     ATAR=AWRI*AN
9600     A1=AP
9601     A2=ATAR+AN-AP
9602     Z1=ZP
9603     Z2=A2*9.31075E+08
9604     MT=103
9605     IF(KZI.EQ.6)GO TO 680
9606     CALL TWOBOD(D,LD,KZ1,KZ2,A1,A2,Z1,Z2,ATAR,QI,MT)
9607     CALL PHOTON(D,LD,IDICTS,LDICT,NTX,NTS,IGCBS,LGCB,AWR,
9608     +IGCBS2,LGCB2,LR,IGAMS,LGAM,QI,ID,IIN,LRI,SIGNP)
9609     WATE=0.0
9610     RETURN
9611     680 CALL GRNDST(D,LD,KZ1,KZ2,A1,A2,Z1,Z2,ATAR,QI,MT)
9612     WATE=0.0
9613     RETURN
9614     690 SIGNP=0.0
9615     700 CONTINUE
9616     C DETERMINE (N,D) CROSS SECTION (MT-104)
9617     ID=57
9618     L1=LDICT(ID,IIN)
9619     IF(L1.EQ.0)GO TO 720
9620     LS1=IDICTS(ID,IIN)+LMOX2
9621     LEN=L1/2
9622     CALL TBSPLT(D(LS1),E,LEN,SIGND)
9623     SUMA=SUMA+SIGND/SIGTNA*FSUMA
9624     IF(R.GT.SUMA)GO TO 730
9625     C THE REACTION TYPE IS (N,D)
9626     NMT104(MED)=NMT104(MED)+1
9627     QI=Q(ID,IIN)
9628     KZ1=1
9629     KZ2=KZI-KZ1
9630     ATAR=AWRI*AN
9631     A1=AD
9632     A2=ATAR+AN-AD
9633     Z1=ZD
9634     Z2=A2*9.31075E+08
9635     MT=104
9636     IF((KZI.EQ.5).OR.(KZI.EQ.6))GO TO 710
9637     IF((KZI.EQ.8).OR.(KZI.EQ.13))GO TO 710
9638     IF((KZI.EQ.14).OR.(KZI.EQ.20))GO TO 710
9639     CALL TWOBOD(D,LD,KZ1,KZ2,A1,A2,Z1,Z2,ATAR,QI,MT)
9640     CALL PHOTON(D,LD,IDICTS,LDICT,NTX,NTS,IGCBS,LGCB,AWR,
9641     +IGCBS2,LGCB2,LR,IGAMS,LGAM,QI,ID,IIN,LRI,SIGND)
9642     WATE=0.0
9643     RETURN
9644     710 CALL GRNDST(D,LD,KZ1,KZ2,A1,A2,Z1,Z2,ATAR,QI,MT)
9645     WATE=0.0
9646     RETURN
9647     720 SIGND=0.0
9648     730 CONTINUE
9649     C DETERMINE (N,T) CROSS SECTION (MT-105)
9650     ID=58
9651     L1=LDICT(ID,IIN)
9652     IF(L1.EQ.0)GO TO 750
9653     LS1=IDICTS(ID,IIN)+LMOX2
9654     LEN=L1/2
9655     CALL TBSPLT(D(LS1),E,LEN,SIGNT)
9656     SUMA=SUMA+SIGNT/SIGTNA*FSUMA
9657     IF(R.GT.SUMA)GO TO 760
9658     C THE REACTION TYPE IS (N,T)
9659     NMT105(MED)=NMT105(MED)+1
9660     QI=Q(ID,IIN)
9661     KZ1=1
9662     KZ2=KZI-KZ1
9663     ATAR=AWRI*AN
9664     A1=AT
9665     A2=ATAR+AN-AT
9666     Z1=ZT
9667     Z2=A2*9.31075E+08
9668     MT=105
9669     IF((KZI.EQ.5).OR.(KZI.EQ.13))GO TO 740
9670     IF(KZI.EQ.20)GO TO 740
9671     CALL TWOBOD(D,LD,KZ1,KZ2,A1,A2,Z1,Z2,ATAR,QI,MT)
9672     CALL PHOTON(D,LD,IDICTS,LDICT,NTX,NTS,IGCBS,LGCB,AWR,
9673     +IGCBS2,LGCB2,LR,IGAMS,LGAM,QI,ID,IIN,LRI,SIGNT)
9674     WATE=0.0
9675     RETURN
9676     740 CALL GRNDST(D,LD,KZ1,KZ2,A1,A2,Z1,Z2,ATAR,QI,MT)
9677     WATE=0.0
9678     RETURN
9679     750 SIGNT=0.0
9680     760 CONTINUE
9681     C DETERMINE (N,3HE) CROSS SECTION (MT-106)
9682     ID=59
9683     L1=LDICT(ID,IIN)
9684     IF(L1.EQ.0)GO TO 780
9685     LS1=IDICTS(ID,IIN)+LMOX2
9686     LEN=L1/2
9687     CALL TBSPLT(D(LS1),E,LEN,SGN3HE)
9688     SUMA=SUMA+SGN3HE/SIGTNA*FSUMA
9689     IF(R.GT.SUMA)GO TO 790
9690     C THE REACTION TYPE IS (N,3HE)
9691     NMT106(MED)=NMT106(MED)+1
9692     QI=Q(ID,IIN)
9693     KZ1=2
9694     KZ2=KZI-KZ1
9695     ATAR=AWRI*AN
9696     A1=AHE3
9697     A2=ATAR+AN-AHE3
9698     Z1=ZHE3
9699     Z2=A2*9.31075E+08
9700     MT=106
9701     IF(KZI.EQ.20)GO TO 770
9702     CALL TWOBOD(D,LD,KZ1,KZ2,A1,A2,Z1,Z2,ATAR,QI,MT)
9703     CALL PHOTON(D,LD,IDICTS,LDICT,NTX,NTS,IGCBS,LGCB,AWR,
9704     +IGCBS2,LGCB2,LR,IGAMS,LGAM,QI,ID,IIN,LRI,SGN3HE)
9705     WATE=0.0
9706     RETURN
9707     770 CALL GRNDST(D,LD,KZ1,KZ2,A1,A2,Z1,Z2,ATAR,QI,MT)
9708     WATE=0.0
9709     RETURN
9710     780 SGN3HE=0.0
9711     790 CONTINUE
9712     C DETERMINE (N,A) CROSS SECTION (MT-107)
9713     ID=60
9714     L1=LDICT(ID,IIN)
9715     IF(L1.EQ.0)GO TO 810
9716     LS1=IDICTS(ID,IIN)+LMOX2
9717     LEN=L1/2
9718     CALL TBSPLT(D(LS1),E,LEN,SIGNA)
9719     SUMA=SUMA+SIGNA/SIGTNA*FSUMA
9720     IF(R.GT.SUMA)GO TO 820
9721     C THE REACTION TYPE IS (N,A)
9722     NMT107(MED)=NMT107(MED)+1
9723     QI=Q(ID,IIN)
9724     KZ1=2
9725     KZ2=KZI-KZ1
9726     ATAR=AWRI*AN
9727     A1=AA
9728     A2=ATAR+AN-AA
9729     Z1=ZA
9730     Z2=A2*9.31075E+08
9731     MT=107
9732     IF((KZI.EQ.6).OR.(KZI.EQ.13))GO TO 800
9733     CALL TWOBOD(D,LD,KZ1,KZ2,A1,A2,Z1,Z2,ATAR,QI,MT)
9734     CALL PHOTON(D,LD,IDICTS,LDICT,NTX,NTS,IGCBS,LGCB,AWR,
9735     +IGCBS2,LGCB2,LR,IGAMS,LGAM,QI,ID,IIN,LRI,SIGNA)
9736     WATE=0.0
9737     RETURN
9738     800 CALL GRNDST(D,LD,KZ1,KZ2,A1,A2,Z1,Z2,ATAR,QI,MT)
9739     WATE=0.0
9740     RETURN
9741     810 SIGNA=0.0
9742     820 CONTINUE
9743     C DETERMINE (N,2A) CROSS SECTION (MT-108)
9744     ID=61
9745     L1=LDICT(ID,IIN)
9746     IF(L1.EQ.0)GO TO 840
9747     LS1=IDICTS(ID,IIN)+LMOX2
9748     LEN=L1/2
9749     CALL TBSPLT(D(LS1),E,LEN,SIGN2A)
9750     SUMA=SUMA+SIGN2A/SIGTNA*FSUMA
9751     IF(R.GT.SUMA)GO TO 850
9752     C THE REACTION TYPE IS (N,2A)
9753     NMT108(MED)=NMT108(MED)+1
9754     QI=Q(ID,IIN)
9755     KZ1=2
9756     KZ2=KZI-2*KZ1
9757     ATAR=AWRI*AN
9758     A1=AA
9759     A2=ATAR+AN-AA
9760     Z1=ZA
9761     Z2=A2*9.31075E+08
9762     MT=108
9763     C USE THE ONE PARTICLE EMISSION MODEL AND MULTIPLY THE
9764     C WEIGHT BY TWO
9765     IF((KZI.EQ.7).OR.(KZI.EQ.20))GO TO 830
9766     CALL TWOBOD(D,LD,KZ1,KZ2,A1,A2,Z1,Z2,ATAR,QI,MT)
9767     CALL PHOTON(D,LD,IDICTS,LDICT,NTX,NTS,IGCBS,LGCB,AWR,
9768     +IGCBS2,LGCB2,LR,IGAMS,LGAM,QI,ID,IIN,LRI,SIGN2A)
9769     WATE=0.0
9770     RETURN
9771     830 CALL GRNDST(D,LD,KZ1,KZ2,A1,A2,Z1,Z2,ATAR,QI,MT)
9772     WATE=0.0
9773     RETURN
9774     840 SIGN2A=0.0
9775     850 CONTINUE
9776     C DETERMINE (N,3A) CROSS SECTION (MT-109)
9777     ID=62
9778     L1=LDICT(ID,IIN)
9779     IF(L1.EQ.0)GO TO 860
9780     LS1=IDICTS(ID,IIN)+LMOX2
9781     LEN=L1/2
9782     CALL TBSPLT(D(LS1),E,LEN,SIGN3A)
9783     SUMA=SUMA+SIGN3A/SIGTNA*FSUMA
9784     IF(R.GT.SUMA)GO TO 870
9785     C THE REACTION TYPE IS (N,3A)
9786     NMT109(MED)=NMT109(MED)+1
9787     QI=Q(ID,IIN)
9788     KZ1=2
9789     KZ2=KZI-3*KZ1
9790     ATAR=AWRI*AN
9791     A1=AA
9792     A2=ATAR+AN-AA
9793     Z1=ZA
9794     Z2=A2*9.31075E+08
9795     MT=109
9796     C USE THE ONE PARTICLE EMISSION MODEL AND MULTIPLY THE
9797     C WEIGHT BY THREE
9798     CALL TWOBOD(D,LD,KZ1,KZ2,A1,A2,Z1,Z2,ATAR,QI,MT)
9799     CALL PHOTON(D,LD,IDICTS,LDICT,NTX,NTS,IGCBS,LGCB,AWR,
9800     +IGCBS2,LGCB2,LR,IGAMS,LGAM,QI,ID,IIN,LRI,SIGN3A)
9801     WATE=0.0
9802     RETURN
9803     860 SIGN3A=0.0
9804     870 CONTINUE
9805     C DETERMINE (N,2P) CROSS SECTION (MT-111)
9806     ID=63
9807     L1=LDICT(ID,IIN)
9808     IF(L1.EQ.0)GO TO 890
9809     LS1=IDICTS(ID,IIN)+LMOX2
9810     LEN=L1/2
9811     CALL TBSPLT(D(LS1),E,LEN,SIGN2P)
9812     SUMA=SUMA+SIGN2P/SIGTNA*FSUMA
9813     IF(R.GT.SUMA)GO TO 900
9814     C THE REACTION TYPE IS (N,2P)
9815     NMT111(MED)=NMT111(MED)+1
9816     QI=Q(ID,IIN)
9817     KZ1=1
9818     KZ2=KZI-2*KZ1
9819     ATAR=AWRI*AN
9820     A1=AP
9821     A2=ATAR+AN-AP
9822     Z1=ZP
9823     Z2=A2*9.31075E+08
9824     MT=111
9825     C USE THE ONE PARTICLE EMISSION MODEL AND MULTIPLY THE
9826     C WEIGHT BY TWO
9827     IF(KZI.EQ.20)GO TO 880
9828     CALL TWOBOD(D,LD,KZ1,KZ2,A1,A2,Z1,Z2,ATAR,QI,MT)
9829     CALL PHOTON(D,LD,IDICTS,LDICT,NTX,NTS,IGCBS,LGCB,AWR,
9830     +IGCBS2,LGCB2,LR,IGAMS,LGAM,QI,ID,IIN,LRI,SIGN2P)
9831     WATE=0.0
9832     RETURN
9833     880 CALL GRNDST(D,LD,KZ1,KZ2,A1,A2,Z1,Z2,ATAR,QI,MT)
9834     WATE=0.0
9835     RETURN
9836     890 SIGN2P=0.0
9837     900 CONTINUE
9838     C DETERMINE (N,PA) CROSS SECTION (MT-112)
9839     ID=64
9840     L1=LDICT(ID,IIN)
9841     IF(L1.EQ.0)GO TO 910
9842     LS1=IDICTS(ID,IIN)+LMOX2
9843     LEN=L1/2
9844     CALL TBSPLT(D(LS1),E,LEN,SIGNPA)
9845     SUMA=SUMA+SIGNPA/SIGTNA*FSUMA
9846     IF(R.GT.SUMA)GO TO 920
9847     C THE REACTION TYPE IS (N,PA)
9848     NMT112(MED)=NMT112(MED)+1
9849     QI=Q(ID,IIN)
9850     KZ1=1
9851     KZ2=2
9852     KZ3=KZI-KZ1-KZ2
9853     ATAR=AWRI*AN
9854     A1=AP
9855     A2=AA
9856     A3=ATAR+AN-A1
9857     Z1=ZP
9858     Z2=ZA
9859     Z3=A3*9.31075E+08
9860     MT=112
9861     CZ July 30,1992 Three-Body process added ----
9862     CALL TREBOD(D,LD,KZ1,KZ2,KZ3,A1,A2,A3,Z1,Z2,Z3,ATAR,QI,MT)
9863     CALL PHOTON(D,LD,IDICTS,LDICT,NTX,NTS,IGCBS,LGCB,AWR,
9864     +IGCBS2,LGCB2,LR,IGAMS,LGAM,QI,ID,IIN,LRI,SIGNPA)
9865     WATE=0.0
9866     RETURN
9867     910 SIGNPA=0.0
9868     920 CONTINUE
9869     C DETERMINE (N,T2A) CROSS SECTION (MT-113)
9870     ID=65
9871     L1=LDICT(ID,IIN)
9872     IF(L1.EQ.0)GO TO 930
9873     LS1=IDICTS(ID,IIN)+LMOX2
9874     LEN=L1/2
9875     CALL TBSPLT(D(LS1),E,LEN,SGNT2A)
9876     SUMA=SUMA+SGNT2A/SIGTNA*FSUMA
9877     IF(R.GT.SUMA)GO TO 940
9878     C THE REACTION TYPE IS (N,T2A)
9879     NMT113(MED)=NMT113(MED)+1
9880     QI=Q(ID,IIN)
9881     KZ1=1
9882     KZ2=2
9883     KZ3=KZI-KZ1-2*KZ2
9884     ATAR=AWRI*AN
9885     A1=AT
9886     A2=AA
9887     A3=ATAR+AN-A1
9888     Z1=ZT
9889     Z2=ZA
9890     Z3=A3*9.31075E+08
9891     MT=113
9892     CZ July 30,1992 Three-Body process added ----
9893     CALL TREBOD(D,LD,KZ1,KZ2,KZ3,A1,A2,A3,Z1,Z2,Z3,ATAR,QI,MT)
9894     CALL PHOTON(D,LD,IDICTS,LDICT,NTX,NTS,IGCBS,LGCB,AWR,
9895     +IGCBS2,LGCB2,LR,IGAMS,LGAM,QI,ID,IIN,LRI,SGNT2A)
9896     WATE=0.0
9897     RETURN
9898     930 SGNT2A=0.0
9899     940 CONTINUE
9900     C DETERMINE (N,D2A) CROSS SECTION (MT-114)
9901     ID=66
9902     L1=LDICT(ID,IIN)
9903     IF(L1.EQ.0)GO TO 950
9904     LS1=IDICTS(ID,IIN)+LMOX2
9905     LEN=L1/2
9906     CALL TBSPLT(D(LS1),E,LEN,SGND2A)
9907     SUMA=SUMA+SGND2A/SIGTNA*FSUMA
9908     IF(R.GT.SUMA)GO TO 960
9909     C THE REACTION TYPE IS (N,D2A)
9910     NMT114(MED)=NMT114(MED)+1
9911     QI=Q(ID,IIN)
9912     KZ1=1
9913     KZ2=2
9914     KZ3=KZI-KZ1-2*KZ2
9915     ATAR=AWRI*AN
9916     A1=AD
9917     A2=AA
9918     A3=ATAR+AN-A1
9919     Z1=ZD
9920     Z2=ZA
9921     Z3=A3*9.31075E+08
9922     MT=114
9923     CZ July 30,1992 Three-Body process added ----
9924     CALL TREBOD(D,LD,KZ1,KZ2,KZ3,A1,A2,A3,Z1,Z2,Z3,ATAR,QI,MT)
9925     CALL PHOTON(D,LD,IDICTS,LDICT,NTX,NTS,IGCBS,LGCB,AWR,
9926     +IGCBS2,LGCB2,LR,IGAMS,LGAM,QI,ID,IIN,LRI,SGND2A)
9927     WATE=0.0
9928     RETURN
9929     950 SGND2A=0.0
9930     960 CONTINUE
9931     FSUMA = 1./SUMA
9932     ITRY=ITRY+1
9933     ISTOP=1
9934     IF(FSUMA.GT.0.1.AND.FSUMA.LE.10.0) ISTOP=0
9935     NAEI(IIN)=NAEI(IIN)-1
9936     IF(ISTOP.EQ.0.AND.ITRY.LE.5)GO TO 20
9937     C AN ABSORPTION REACTION WAS NOT CHOSEN
9938     COMM=' COLISN:AN ABSORPTION REACTION TYPE WAS NOT CHOSEN '
9939     SIGREC = SIGTNA
9940     SUMREC = SUMA
9941     GOTO 980
9942     970 CONTINUE
9943     IF(ISTOP.EQ.1)GO TO 980
9944     ITRY=0
9945     GO TO 20
9946     980 CONTINUE
9947     WRITE(IOUT,'(A80,/,I5,F7.1,I4,/,G18.7,I5,3G10.4)') COMM,
9948     + NMED,AWR(IIN),KZ(IIM),
9949     + E,MT,
9950     + SIGT,SIGREC,SUMREC
9951     RETURN
9952     END
9953     *CMZ : 0.90/00 20/07/92 14.28.14 by Christian Zeitnitz
9954     *-- Author :
9955     SUBROUTINE CTERP(X1,X2,X,Y1,Y2,Y)
9956     C THIS ROUTINE PERFORMS LINEAR INTERPOLATION
9957     Y=Y2-(X2-X)*(Y2-Y1)/(X2-X1)
9958     RETURN
9959     END
9960     *CMZ : 1.04/00 02/02/95 09.21.40 by Christian Zeitnitz
9961     *-- Author :
9962     SUBROUTINE EVAPLR(E,Q,SQ,ATAR,CB,EX)
9963     C THIS ROUTINE SAMPLES AN EXIT ENERGY FROM AN
9964     C EVAPORATION SPECTRUM FOR AN LR-FLAG (N,N-PRIME X) REACTION
9965     #include "minput.inc"
9966     *KEND.
9967     SAVE
9968     C CONVERT THE COULOMB BARRIER (CB) TO UNITS OF EV
9969     CB=CB*1.00E+06
9970     C SET THE EXCITATION ENERGY (Q) TO ITS ABSOLUTE VALUE
9971     QA=ABS(Q)
9972     C CALCULATE THE MAXIMUM ENERGY AVAILABLE
9973     CBI=CB
9974     EMAX=QA+SQ-CB
9975     IF(EMAX.GT.0.0)GO TO 10
9976     CB=0.5*CB
9977     EMAX=QA+SQ-CB
9978     IF(EMAX.GT.0.0)GO TO 10
9979     CB=0.0
9980     EMAX=QA+SQ-CB
9981     IF(EMAX.GT.0.0)GO TO 10
9982     WRITE(IOUT,10000)E,EMAX,QA,SQ,CBI
9983     10000 FORMAT(' MICAP: NEGATIVE MAXIMUM ENERGY CALCULATED IN ROUTINE ',
9984     1'EVAPLR --- INDICATING PROBABLE CROSS SECTION ERROR ALLOWING ',
9985     2'THE REACTION TO OCCUR',/,10X,'E,EMAX,QA,SQ,CB=',1P5E13.5)
9986     WRITE(6,*) ' CALOR: ERROR in EVAPLR ====> STOP '
9987     STOP
9988     C CALCULATE THE NUCLEAR TEMPERATURE (THETA)
9989     10 THETA=4.0161E+03*(SQRT(QA+SQ-CB)/(ATAR**0.8333333))
9990     C SELECT THE EXIT ENERGY FROM AN EVAPORATION SPECTRUM
9991     20 R1=FLTRNF(0)
9992     R2=FLTRNF(0)
9993     W=-ALOG(R1*R2)
9994     EX=THETA*W
9995     IF(EX.LE.EMAX)RETURN
9996     C RESAMPLE 75% OF THE TIME IF EX IS GREATER THAN EMAX
9997     R=FLTRNF(0)
9998     IF(R.LE.0.75)GO TO 20
9999     EX=EMAX
10000     RETURN
10001     END
10002     *CMZ : 0.90/09 03/11/92 15.18.49 by Christian Zeitnitz
10003     *-- Author :
10004     C*********************************************************************
10005     FUNCTION FISRNF(A,B)
10006     C*********************************************************************
10007     C Sample secondary fission neutron energy from Watt spectrum
10008     C taken from ORNL/TM-7631
10009     C CZ 3/11/92
10010     DIMENSION RNDM(3)
10011     C
10012     CALL GRNDM(RNDM,3)
10013     Z=SQRT(-ALOG(RNDM(1)))
10014     S=6.28319*RNDM(2)
10015     ALOGR3=ALOG(RNDM(3))
10016     X=SQRT(A*B)/2.
10017     E1=A*((Z*COS(S)+X)**2-ALOGR3)
10018     C-- E2=A*((Z*SIN(S)+X)**2-ALOGR3)
10019     C distribution of E1 and E2 are identical
10020     FISRNF = E1
10021     RETURN
10022     END
10023     *CMZ : 1.05/03 27/06/2001 17.54.33 by Christian Zeitnitz
10024     *-- Author :
10025     C*********************************************************************
10026     FUNCTION FLTRNF(IX)
10027     C*********************************************************************
10028     #include "crandm.inc"
10029     *KEND.
10030     FLTRNF = RANDC(ISEED)
10031     RETURN
10032     END
10033     *CMZ : 1.05/03 27/06/2001 17.56.54 by Christian Zeitnitz
10034     *-- Author : Christian Zeitnitz 23/10/92
10035     SUBROUTINE GETENE(EN,D1,LD2,N)
10036     C sample N times secondary energy distribution and
10037     C store in ENE(*)
10038     #include "mconst.inc"
10039     #include "mnutrn.inc"
10040     *KEND.
10041     C
10042     DIMENSION D1(*),LD2(*)
10043     C
10044     DO 10 I=1,N
10045     CALL SECEGY(EX,D1,EN,LD2)
10046     ENE(I) = EX
10047     10 CONTINUE
10048     RETURN
10049     END
10050    
10051     *CMZ : 1.01/04 10/06/93 14.43.47 by Christian Zeitnitz
10052     *-- Author :
10053     SUBROUTINE GETNU(D,LD,E,LEN,XNU)
10054     C THIS ROUTINE SELECTS THE AVERAGE NUMBER OF NEUTRONS
10055     C BORN FROM A FISSION REACTION (I.E. NU-BAR)
10056     #include "minput.inc"
10057     *KEND.
10058     DIMENSION D(*),LD(*),C(4)
10059     SAVE
10060     IP=1
10061     XNU=0.0
10062     LNU=LD(IP)
10063     IP=IP+1
10064     IF(LNU.NE.1)GO TO 30
10065     C POLYNOMIAL REPRESENTATION USED TO SPECIFY NU-BAR
10066     C INITIALIZE THE POLYNOMIAL COEFFICIENTS TO ZERO
10067     DO 10 I=1,4
10068     C(I)=0.0
10069     10 CONTINUE
10070     NC=LD(IP)
10071     DO 20 I=1,NC
10072     C(I)=D(IP+I)
10073     20 CONTINUE
10074     C CALCULATE NU-BAR USING POLYNOMIAL COEFFICIENTS
10075     XNU=C(1)+C(2)*E+C(3)*(E**2)+C(4)*(E**3)
10076     RETURN
10077     C TABULATED DATA USED TO SPECIFY NU-BAR
10078     C CURRENT ENDF/B DATA (VERSION V) ALLOWS ONLY ONE
10079     C INTERPOLATION RANGE (NR) AND ONLY LINEAR-LINEAR
10080     C INTERPOLABLE DATA (INT=2)
10081     30 IF(LNU.NE.2)GO TO 40
10082     NR=LD(IP)
10083     NP=LD(IP+1)
10084     IP=IP+2*NR+2
10085     C SELECT NU-BAR FROM THE TABULATED DATA
10086     C LINEAR-LINEAR INTERPOLATION IS ASSUMED AT THIS POINT
10087     CALL TBSPLT(D(IP),E,NP,XNU)
10088     RETURN
10089     40 WRITE(IOUT,10000)LNU
10090     10000 FORMAT(' MICAP: ERROR IN ROUTINE GETNU; LNU=',I3)
10091     WRITE(6,*) ' CALOR: ERROR in GETNU ====> STOP'
10092     STOP
10093     END
10094     *CMZ : 1.01/04 10/06/93 14.43.48 by Christian Zeitnitz
10095     *-- Author : Christian Zeitnitz 03/08/92
10096     SUBROUTINE GETPAR(ID,N,IERR)
10097     C retrieve particle from MPSTOR common
10098     #include "mconst.inc"
10099     #include "mpstor.inc"
10100     #include "minput.inc"
10101     *KEND.
10102     IERR = 0
10103     NN = 0
10104     NS = 1
10105     10 CONTINUE
10106     IF(IDN(NS).EQ.ID) NN = NN + 1
10107     IF(N.EQ.NN) GOTO 20
10108     NS = NS + 1
10109     IF(NS.GT.NPSTOR) THEN
10110     WRITE(IOUT,'('' MICAP: Cant retrieve particle no. '',I3, '
10111     + //' '' of type '',I3,''; End of data '')') N,ID
10112     IERR = 1
10113     RETURN
10114     ENDIF
10115     GOTO 10
10116     20 CONTINUE
10117     EP = EN(NS)
10118     UP = UN(NS)
10119     VP = VN(NS)
10120     WP = WN(NS)
10121     AMP = AMN(NS)
10122     ZMP = ZMN(NS)
10123     AGEP = AGEN(NS)
10124     MTP = MTN(NS)
10125     RETURN
10126     END
10127     *CMZ : 1.01/16 18/11/93 09.19.55 by Christian Zeitnitz
10128     *-- Author :
10129     SUBROUTINE GRNDST(D,LD,KZ1,KZ2,A1,A2,Z1,Z2,ATAR,Q,MT)
10130     C THIS ROUTINE CALCULATES THE EXIT ENERGIES AND DIRECTIONAL
10131     C COSINES FOR THE CHARGED PARTICLE AND RECOIL NUCLEUS FOR
10132     C A GROUND STATE TWO-BODY REACTION USING CLASSICAL KINEMATICS
10133     C AND A MOMEMTUM BALANCE. IT ALSO SETS ALL EXIT PARAMETERS FOR
10134     C THE COLLISION PRODUCTS AND STORES THEM IN THE RECOIL BANK.
10135     #include "minput.inc"
10136     #include "mconst.inc"
10137     #include "mnutrn.inc"
10138     #include "mrecoi.inc"
10139     #include "mapoll.inc"
10140     #include "mmass.inc"
10141     #include "mpstor.inc"
10142     *KEND.
10143     DIMENSION D(*),LD(*)
10144     SAVE
10145     NPN = 1
10146     IF(MT.EQ.108) NPN = 2
10147     IF(MT.EQ.109) NPN = 3
10148     IF(MT.EQ.111) NPN = 2
10149     C CALCULATE THE CONSTANTS USED IN THE KINEMATIIC EQUATIONS
10150     ZATAR=ATAR*9.31075E+08
10151     PXO = 0.0
10152     PYO = 0.0
10153     PZO = 0.0
10154     C loop over emmited particles
10155     DO 40 NP=1,NPN
10156     C ASSUME ISOTROPIC CHARGED PARTICLE EMISSION IN THE CENTER
10157     C OF MASS COORDINATE SYSTEM
10158     R=FLTRNF(0)
10159     FM=2.0*R-1.0
10160     C FOR A GROUND STATE REACTION THE RECOIL MASS IS KNOWN EXACTLY
10161     Z2=ZN+ZATAR-FLOAT(NP)*Z1-Q
10162     A2=Z2/9.31075E+08
10163     DENOM=(AN+ATAR)*(A1*FLOAT(NP)+A2)
10164     ERATIO=EOLD/(EOLD+Q)
10165     AC=((AN*A2)/DENOM)*ERATIO
10166     BC=((AN*A1)/DENOM)*ERATIO
10167     CC=((ATAR*A1)/DENOM)*(1.0+(AN*Q)/(ATAR*(EOLD+Q)))
10168     DC=((ATAR*A2)/DENOM)*(1.0+(AN*Q)/(ATAR*(EOLD+Q)))
10169     C CALCULATE THE CHARGED PARTICLE AND RECOIL NUCLEUS IN THE
10170     C LABORATORY COORDINATE SYSTEM
10171     E1=(EOLD+Q)*(BC+DC+(2.0*SQRT(AC*CC))*FM)
10172     E2=(EOLD+Q)*(AC+CC-(2.0*SQRT(AC*CC))*FM)
10173     C CALCULATE THE CHARGED PARTICLE ENERGY AND VELOCITY IN THE
10174     C CENTER OF MASS COORDINATE SYSTEM
10175     E1CM=(Z2/(Z1+Z2))*((ZATAR/(ZN+ZATAR))*EOLD+Q)
10176     V1CM=SQRT((2.0*E1CM)/Z1)
10177     C CALCULATE THE VELOCITY OF THE CENTER OF MASS
10178     VCM=SQRT(2.0*ZN*EOLD)/(ZN+ZATAR)
10179     C CONVERT THE COSINE OF THE SCATTERING ANGLE IN THE CENTER OF
10180     C MASS COORDINATE SYSTEM TO THE LABORATORY COORDINATE SYSTEM
10181     FM=(V1CM*FM+VCM)/(SQRT(((V1CM*FM+VCM)**2)+ ((V1CM*(1.0-FM**2))
10182     + **2)))
10183     C CALCULATE THE CHARGED PARTICLE EXIT DIRECTIONAL COSINES
10184     SINPSI=SQRT(1.0-FM**2)
10185     CALL AZIRN(SINETA,COSETA)
10186     STHETA=1.0-UOLD**2
10187     IF(STHETA)20,20,10
10188     10 STHETA=SQRT(STHETA)
10189     COSPHI=VOLD/STHETA
10190     SINPHI=WOLD/STHETA
10191     GO TO 30
10192     20 COSPHI=1.0
10193     SINPHI=0.0
10194     STHETA=0.0
10195     30 U1=UOLD*FM-COSETA*SINPSI*STHETA
10196     V1=VOLD*FM+UOLD*COSPHI*COSETA*SINPSI-SINPHI*SINPSI*SINETA
10197     W1=WOLD*FM+UOLD*SINPHI*COSETA*SINPSI+COSPHI*SINPSI*SINETA
10198     S=1.0/SQRT(U1**2+V1**2+W1**2)
10199     U1=U1*S
10200     V1=V1*S
10201     W1=W1*S
10202     PPO = SQRT(2.0*Z1*E1)
10203     PXO = PXO + U1*PPO
10204     PYO = PYO + V1*PPO
10205     PZO = PZO + W1*PPO
10206     C CALCULATE AND SET THE CHARGED PARTICLE EXIT PARAMETERS
10207     XR=X
10208     YR=Y
10209     ZR=Z
10210     WATER=WTBC
10211     NZR=KZ1
10212     AGER=AGE
10213     NCOLR=NCOL
10214     MTNR=MT
10215     AR=A1
10216     ENIR=EOLD
10217     UNIR=UOLD
10218     VNIR=VOLD
10219     WNIR=WOLD
10220     ENOR=0.0
10221     UNOR=0.0
10222     VNOR=0.0
10223     WNOR=0.0
10224     WTNR=0.0
10225     QR=Q
10226     UR=U1
10227     VR=V1
10228     WR=W1
10229     ER=E1
10230     C STORE THE CHARGED PARTICLE IN THE RECOIL BANK
10231     EP = ER
10232     UP = UR
10233     VP = VR
10234     WP = WR
10235     AMP = AR
10236     ZMP = FLOAT(NZR)
10237     AGEP = AGE
10238     MTP = MT
10239     CALL STOPAR(IDHEVY,NHEVY)
10240     40 CONTINUE
10241     C CALCULATE THE TOTAL MOMENTUM BEFORE THE COLLISION
10242     C NEUTRON MOMENTUM BEFORE COLLISION (PI) EQUALS TOTAL MOMENTUM
10243     PI=SQRT(2.0*ZN*EOLD)
10244     C CALCULATE THE DIRECTIONAL MOMENTUM OF THE RECOIL NUCLEUS
10245     PRX=PI*UOLD-PXO
10246     PRY=PI*VOLD-PYO
10247     PRZ=PI*WOLD-PZO
10248     C CALCULATE THE TOTAL MOMENTUM OF THE RECOIL NUCLEUS
10249     PR=SQRT(PRX**2+PRY**2+PRZ**2)
10250     C CALCULATE THE RECOIL NUCLEUS DIRECTIONAL COSINES
10251     U2=PRX/PR
10252     V2=PRY/PR
10253     W2=PRZ/PR
10254     C CALCULATE THE RECOIL NUCLEUS EXIT ENERGY
10255     XM = A2 * 931.075E6
10256     E2 = SQRT(PR**2+XM**2) - XM
10257     C CALCULATE AND SET THE CHARGED PARTICLE EXIT PARAMETERS
10258     XR=X
10259     YR=Y
10260     ZR=Z
10261     WATER=WTBC
10262     NZR=KZ2
10263     AGER=AGE
10264     NCOLR=NCOL
10265     MTNR=MT
10266     AR=A2
10267     ENIR=EOLD
10268     UNIR=UOLD
10269     VNIR=VOLD
10270     WNIR=WOLD
10271     ENOR=0.0
10272     UNOR=0.0
10273     VNOR=0.0
10274     WNOR=0.0
10275     WTNR=0.0
10276     QR=Q
10277     UR=U2
10278     VR=V2
10279     WR=W2
10280     ER=E2
10281     C STORE THE RECOIL HEAVY ION IN THE RECOIL BANK
10282     EP = ER
10283     UP = UR
10284     VP = VR
10285     WP = WR
10286     AMP = AR
10287     ZMP = FLOAT(NZR)
10288     AGEP = AGE
10289     MTP = MT
10290     CALL STOPAR(IDHEVY,NHEVY)
10291     RETURN
10292     END
10293     *CMZ : 1.04/05 16/08/95 15.27.07 by Christian Zeitnitz
10294     *-- Author : Christian Zeitnitz 28/07/92
10295     SUBROUTINE GTMED(MEDGEA,MEDMOR)
10296     #include "mmicap.inc"
10297     #include "minput.inc"
10298     *KEND.
10299     C get MICAP material number
10300     DO 10 I=1,MEDIA
10301     IF(LD(LGE2MO+I).EQ.MEDGEA) THEN
10302     MEDMOR = I
10303     GOTO 20
10304     ENDIF
10305     10 CONTINUE
10306     WRITE(IOUT,'('' MICAP GTMED: GEANT Medium '',I5, '
10307     + //' '' not found ==> STOP'')') MEDGEA
10308     STOP
10309     20 RETURN
10310     END
10311     *CMZ : 0.92/00 02/12/92 16.02.32 by Christian Zeitnitz
10312     *-- Author :
10313     SUBROUTINE INTERP(X,Y,X1,Y1,X2,Y2,INT)
10314     C THIS ROUTINE PERFORMS THE INTERPOLATION ACCORDING
10315     C TO THE ENDF/B INTERPOLATION SCHEME INT
10316     #include "minput.inc"
10317     *KEND.
10318     SAVE
10319     IF(INT.LT.1.OR.INT.GT.5)GO TO 60
10320     IF(X2.EQ.X1)GO TO 10
10321     GO TO (10,20,30,40,50),INT
10322     10 Y=Y1
10323     RETURN
10324     20 Y=Y1+(X-X1)*(Y2-Y1)/(X2-X1)
10325     RETURN
10326     30 IF(X1.EQ.0.0.OR.X2.EQ.0.0)GO TO 20
10327     Y=Y1+ALOG(X/X1)*(Y2-Y1)/ALOG(X2/X1)
10328     RETURN
10329     40 IF(Y1.EQ.0.0.OR.Y2.EQ.0.0)GO TO 20
10330     Y=Y1*EXP((X-X1)*ALOG(Y2/Y1)/(X2-X1))
10331     RETURN
10332     50 IF(Y1.EQ.0.0.OR.Y2.EQ.0.0)GO TO 30
10333     IF(X1.EQ.0.0.OR.X2.EQ.0.0)GO TO 40
10334     Y=Y1*EXP(ALOG(X/X1)*ALOG(Y2/Y1)/ALOG(X2/X1))
10335     RETURN
10336     60 WRITE(IOUT,10000)INT
10337     10000 FORMAT(' MICAP: INTERP-INVALID INTERPOLATION SCHEME',I11)
10338     WRITE(6,*) ' CALOR: ERROR in INTERP ====> STOP '
10339     STOP
10340     END
10341     *CMZ : 1.01/04 10/06/93 14.43.48 by Christian Zeitnitz
10342     *-- Author :
10343     SUBROUTINE INTSCH(IFSE,I,IS,NR)
10344     C THIS ROUTINE DETERMINES THE INTERPOLATION SCHEME
10345     C ACCORDING TO ENDF/B-V FORMATTED DATA FILES
10346     DIMENSION IFSE(*)
10347     DO 10 J=1,NR
10348     J1=3+2*(J-1)
10349     NPTS=IFSE(J1)
10350     IF(I.LE.NPTS)GO TO 20
10351     10 CONTINUE
10352     20 IS=IFSE(J1+1)
10353     RETURN
10354     END
10355     *CMZ : 1.04/00 02/02/95 09.26.26 by Christian Zeitnitz
10356     *-- Author :
10357     SUBROUTINE ISOTPE(D,LD,KM,RHO,IN,IDICTS,LDICT,E,TSIG,NMED,
10358     + IIN,IIM)
10359     C THIS ROUTINE DETERMINES WHICH ISOTOPE HAS BEEN STRUCK
10360     C IN MEDIA NMED
10361     #include "minput.inc"
10362     #include "mconst.inc"
10363     #include "mmicab.inc"
10364     *KEND.
10365     C
10366     DIMENSION D(*),LD(*),KM(*),RHO(*),IN(*),IDICTS(NNR,NNUC),
10367     + LDICT(NNR,NNUC)
10368     SAVE
10369     C
10370     R=FLTRNF(0)
10371     NOA=0
10372     SUM=0.
10373     20 DO 30 K=1,NMIX
10374     IF(KM(K).NE.NMED)GO TO 30
10375     C DETERMINE ISOTOPE NUMBER
10376     K1=IN(K)
10377     K2=K
10378     C DETERMINE TOTAL CROSS SECTION FOR THIS ISOTOPE
10379     LS1=IDICTS(1,K1)+LMOX2
10380     L1=LDICT(1,K1)
10381     LEN=L1/2
10382     CALL TBSPLT(D(LS1),E,LEN,X)
10383     SUM=SUM+X*RHO(K)
10384     C CHECK TO SEE IF THIS ISOTOPE WAS HIT
10385     IF(R.LE.SUM/TSIG)GO TO 40
10386     30 CONTINUE
10387     C AN ISOTOPE WAS NOT CHOSEN, TRY AGAIN
10388     NOA=NOA+1
10389     IF(NOA.GT.5)GO TO 50
10390     SUM=0.0
10391     R=FLTRNF(0)
10392     GO TO 20
10393     40 IIN=K1
10394     IIM=K2
10395     RETURN
10396     50 WRITE(IOUT,10000)NMED,TSIG
10397     10000 FORMAT(' MICAP: AN ISOTOPE WAS NOT CHOSEN IN 5 ATTEMPTS IN ',
10398     +'ROUTINE ISOTPE',/,3X,'MEDIUM=',I5,5X,'MACROSCOPIC XSEC=',
10399     +1PE12.4)
10400     WRITE(IOUT,10100)R,SUM,TSIG,X,E,RHO(K2),NMED,K1,K2
10401     10100 FORMAT('0',1X,1P6E12.4,3I10)
10402     WRITE(6,*) ' CALOR: ERROR in ISOTPE =====> STOP '
10403     STOP
10404     END
10405     *CMZ : 1.01/04 10/06/93 14.43.48 by Christian Zeitnitz
10406     *-- Author :
10407     SUBROUTINE LABNF(D,LD,FM,AWR,KZ,Q,LIFLAG)
10408     C THIS ROUTINE CALCULATES THE DIRECTIONAL COSINES FOR THE
10409     C NEUTRON BORN FROM THE FISSION REACTION. THIS VERSION OF
10410     C THE PROGRAM WILL TREAT A FISSION REACTION AS A SCATTERING
10411     C EVENT WITH THE NEUTRON EMERGING WITH A MODIFIED WEIGHT OF
10412     C WATE*NU-BAR. NO PROVISIONS ARE MADE AT THIS TIME TO
10413     C CALCULATE THE FISSION FRAGMENTS PARAMETERS, HOWEVER A HEAVY
10414     C RECOIL ION WILL BE STORED (FOR ANALYSIS PURPOSES) WITH
10415     C ENERGY AND DIRECTION COSINES EQUAL TO ZERO.
10416     #include "minput.inc"
10417     #include "mconst.inc"
10418     #include "mnutrn.inc"
10419     #include "mrecoi.inc"
10420     #include "mapoll.inc"
10421     #include "mmass.inc"
10422     #include "mpstor.inc"
10423     *KEND.
10424     DIMENSION D(*),LD(*),FM(*)
10425     SAVE
10426     MT=18
10427     C CALCULATE THE NEUTRON EXIT DIRECTIONAL COSINES
10428     POX = 0.0
10429     POY = 0.0
10430     POZ = 0.0
10431     DO 40 KN=1,INEU
10432     IF(LIFLAG.EQ.1) THEN
10433     CALL GTISO(UP,VP,WP)
10434     ELSE
10435     SINPSI=SQRT(1.0-FM(KN)**2)
10436     CALL AZIRN(SINETA,COSETA)
10437     STHETA=1.0-UOLD**2
10438     IF(STHETA)20,20,10
10439     10 STHETA=SQRT(STHETA)
10440     COSPHI=VOLD/STHETA
10441     SINPHI=WOLD/STHETA
10442     GO TO 30
10443     20 COSPHI=1.0
10444     SINPHI=0.0
10445     STHETA=0.0
10446     30 UP=UOLD*FM(KN)-COSETA*SINPSI*STHETA
10447     VP=VOLD*FM(KN)+UOLD*COSPHI*COSETA*SINPSI-SINPHI* SINPSI*
10448     + SINETA
10449     WP=WOLD*FM(KN)+UOLD*SINPHI*COSETA*SINPSI+COSPHI* SINPSI*
10450     + SINETA
10451     S=1.0/SQRT(UP**2+VP**2+WP**2)
10452     UP=UP*S
10453     VP=VP*S
10454     WP=WP*S
10455     ENDIF
10456     AGEP = AGE
10457     EP = ENE(KN)
10458     C use only first neutron for recoil calculation in order to ensure
10459     C correct recoil nucleus energy spectrum
10460     IF(KN.EQ.1) THEN
10461     PP = SQRT(EP**2 + 2.0*EP*ZN)
10462     POX = POX + PP*UP
10463     POY = POY + PP*VP
10464     POZ = POZ + PP*WP
10465     ENDIF
10466     MTP = MT
10467     CALL STOPAR(IDNEU,NNEU)
10468     40 CONTINUE
10469     C SET THE HEAVY RECOIL ION PARAMETERS FOR ANALYSIS TAPE
10470     50 PI=SQRT(2.0*ZN*EOLD)
10471     PIX=PI*UOLD
10472     PIY=PI*VOLD
10473     PIZ=PI*WOLD
10474     PRX=PIX-POX
10475     PRY=PIY-POY
10476     PRZ=PIZ-POZ
10477     PR=SQRT(PRX**2+PRY**2+PRZ**2)
10478     UR=PRX/PR
10479     VR=PRY/PR
10480     WR=PRZ/PR
10481     AR=AWR*AN+AN-INEU*AN
10482     XM=AR*931.075E6
10483     ER=SQRT(PR**2+XM**2)-XM
10484     EP = ER
10485     UP = UR
10486     VP = VR
10487     WP = WR
10488     AGEP = AGE
10489     MTP = MT
10490     XR=X
10491     YR=Y
10492     ZR=Z
10493     WATER=WTBC
10494     NZR=KZ
10495     AGER=AGE
10496     NCOLR=NCOL
10497     MTNR=MT
10498     AMP = AR
10499     ZMP = FLOAT(KZ)
10500     ENIR=EOLD
10501     UNIR=UOLD
10502     VNIR=VOLD
10503     WNIR=WOLD
10504     ENOR=E
10505     UNOR=U
10506     VNOR=V
10507     WNOR=W
10508     WTNR=WATE
10509     QR=Q
10510     C STORE THE RECOIL HEAVY ION IN THE RECOIL BANK
10511     CALL STOPAR(IDHEVY,NHEVY)
10512     RETURN
10513     END
10514     *CMZ : 0.92/00 02/12/92 16.02.32 by Christian Zeitnitz
10515     *-- Author :
10516     SUBROUTINE LR2BOD(D,LD,KZ1,KZ2,A1,A2,Z1,Z2,ATAR,Q,SQ,ID,MT)
10517     C THIS ROUTINE CALCULATES THE EXIT ENERGIES AND DIRECTIONAL
10518     C COSINES FOR THE CHARGED PARTICLE AND RECOIL NUCLEUS FOR
10519     C A TWO-BODY REACTION USING AN EVAPORATION SPECTRUM AND
10520     C MOMEMTUM BALANCE. IT ALSO SETS ALL EXIT PARAMETERS FOR
10521     C THE COLLISION PRODUCTS AND STORES THEM IN THE RECOIL BANK.
10522     C THE TWO BODY REACTION RESULTS FROM THE BREAK-UP OF A NUCLEUS
10523     C LEFT IN AN EXCITED STATE BY AN INELASTIC COLLISION
10524     C DESIGNATED BY A LR-FLAG IN THE INELASTIC RESOLVED DATA
10525     #include "minput.inc"
10526     #include "mconst.inc"
10527     #include "mnutrn.inc"
10528     #include "mrecoi.inc"
10529     #include "mapoll.inc"
10530     #include "mmass.inc"
10531     #include "mpstor.inc"
10532     *KEND.
10533     DIMENSION D(*),LD(*)
10534     SAVE
10535     C CALCULATE THE CONSTANTS USED IN THE KINEMATIIC EQUATIONS
10536     ZATAR=ATAR*9.31075E+08
10537     C FOR A CARBON-ALPHA EMISSION THE RECOIL MASS IS KNOWN EXACTLY
10538     IF(KZ1+KZ2.EQ.6)Z2=ZATAR-Z1-SQ
10539     IF(KZ1+KZ2.EQ.6)A2=Z2/9.31075E+08
10540     C TRANSFER THE RECOILING COMPOUND NUCLEUS PARAMETERS OUT OF
10541     C COMMON RECOIL FOR USE IN THE MOMENTUM BALANCE EQUATIONS
10542     ERCN=ER
10543     URCN=UR
10544     VRCN=VR
10545     WRCN=WR
10546     ARCN=AR
10547     NZRCN=NZR
10548     ZARCN=ARCN*9.31075E+08
10549     IF(MT.EQ.23)GO TO 10
10550     C CALCULATE THE COULOMB BARRIER (CB)
10551     CALL BARIER(KZ1,KZ2,A1,A2,CB)
10552     C CALCULATE THE ENERGY AVAILABLE IN THE CENTER OF MASS (EAV)
10553     CALL EVAPLR(E,Q,SQ,ATAR,CB,EX)
10554     EAV=EX+CB
10555     GO TO 30
10556     10 IF((ID.EQ.54).AND.(KZ1+KZ2.EQ.6))GO TO 20
10557     EAV=ABS(Q)+SQ
10558     GO TO 30
10559     20 Q=EOLD-E-ERCN
10560     IF(Q.LE.ABS(SQ))Q=7.65300E+06
10561     EAV=Q+SQ
10562     30 CONTINUE
10563     C CALCULATE THE CHARGED PARTICLE ENERGY USING CONSERVATION
10564     C OF MOMENTUM (CENTER OF MASS SYSTEM)
10565     E1CM=(A2/(A1+A2))*EAV
10566     C ASSUME ISOTROPIC CHARGED PARTICLE EMISSION IN THE CENTER
10567     C OF MASS COORDINATE SYSTEM
10568     R=FLTRNF(0)
10569     FM=2.0*R-1.0
10570     C CALCULATE THE VELOCITY OF THE CENTER OF MASS AND THE
10571     C CHARGED PARTICLE IN THE CENTER OF MASS SYSTEM
10572     VCM=SQRT((2.0*ERCN)/ZARCN)
10573     V1CM=SQRT((2.0*E1CM)/Z1)
10574     C CALCULATE THE CHARGED PARTICLE ENERGY IN THE LABORATORY
10575     C COORDINATE SYSTEM
10576     E1=0.5*Z1*(VCM**2+V1CM**2+VCM*V1CM*FM)
10577     C CONVERT THE COSINE OF THE SCATTERING ANGLE IN THE CENTER OF
10578     C MASS COORDINATE SYSTEM TO THE LABORATORY COORDINATE SYSTEM
10579     FM=(V1CM*FM+VCM)/(SQRT(((V1CM*FM+VCM)**2)+((V1CM*(1.0-FM**2))
10580     1**2)))
10581     C CALCULATE THE CHARGED PARTICLE EXIT DIRECTIONAL COSINES
10582     SINPSI=SQRT(1.0-FM**2)
10583     CALL AZIRN(SINETA,COSETA)
10584     STHETA=1.0-URCN**2
10585     IF(STHETA)50,50,40
10586     40 STHETA=SQRT(STHETA)
10587     COSPHI=VRCN/STHETA
10588     SINPHI=WRCN/STHETA
10589     GO TO 60
10590     50 COSPHI=1.0
10591     SINPHI=0.0
10592     STHETA=0.0
10593     60 U1=URCN*FM-COSETA*SINPSI*STHETA
10594     V1=VRCN*FM+URCN*COSPHI*COSETA*SINPSI-SINPHI*SINPSI*SINETA
10595     W1=WRCN*FM+URCN*SINPHI*COSETA*SINPSI+COSPHI*SINPSI*SINETA
10596     S=1.0/SQRT(U1**2+V1**2+W1**2)
10597     U1=U1*S
10598     V1=V1*S
10599     W1=W1*S
10600     C CALCULATE AND SET THE CHARGED PARTICLE EXIT PARAMETERS
10601     XR=X
10602     YR=Y
10603     ZR=Z
10604     WATER=WTBC
10605     NZR=KZ1
10606     AGER=AGE
10607     NCOLR=NCOL
10608     MTNR=MT
10609     AR=A1
10610     ENIR=EOLD
10611     UNIR=UOLD
10612     VNIR=VOLD
10613     WNIR=WOLD
10614     ENOR=E
10615     UNOR=U
10616     VNOR=V
10617     WNOR=W
10618     WTNR=WATE
10619     QR=Q
10620     UR=U1
10621     VR=V1
10622     WR=W1
10623     ER=E1
10624     C STORE THE CHARGED PARTICLE IN THE RECOIL BANK
10625     EP = ER
10626     UP = UR
10627     VP = VR
10628     WP = WR
10629     AGEP = AGE
10630     MTP = MT
10631     AMP = AR
10632     ZMP = FLOAT(NZR)
10633     CALL STOPAR(IDHEVY,NHEVY)
10634     C CALCULATE THE TOTAL MOMENTUM BEFORE THE COLLISION
10635     C COMPOUND NUCLEUS MOMENTUM BEFORE THE COLLISION (PI) EQUALS
10636     C THE TOTAL MOMENTUM
10637     PI=SQRT(2.0*ZARCN*ERCN)
10638     C CALCULATE THE TOTAL MOMEMTUM OF THE EXIT CHARGED PARTICLE
10639     PO=SQRT(2.0*Z1*E1)
10640     C CALCULATE THE DIRECTIONAL MOMENTUM OF THE RECOIL NUCLEUS
10641     PRX=PI*URCN-PO*U1
10642     PRY=PI*VRCN-PO*V1
10643     PRZ=PI*WRCN-PO*W1
10644     C CALCULATE THE TOTAL MOMENTUM OF THE RECOIL NUCLEUS
10645     PR=SQRT(PRX**2+PRY**2+PRZ**2)
10646     C CALCULATE THE RECOIL NUCLEUS DIRECTIONAL COSINES
10647     U2=PRX/PR
10648     V2=PRY/PR
10649     W2=PRZ/PR
10650     C CALCULATE THE RECOIL NUCLEUS EXIT ENERGY
10651     XM = A2*931.075E6
10652     E2 = SQRT(PR**2+XM**2) - XM
10653     C CALCULATE AND SET THE CHARGED PARTICLE EXIT PARAMETERS
10654     XR=X
10655     YR=Y
10656     ZR=Z
10657     WATER=WTBC
10658     NZR=KZ2
10659     AGER=AGE
10660     NCOLR=NCOL
10661     MTNR=MT
10662     AR=A2
10663     ENIR=EOLD
10664     UNIR=UOLD
10665     VNIR=VOLD
10666     WNIR=WOLD
10667     ENOR=E
10668     UNOR=U
10669     VNOR=V
10670     WNOR=W
10671     WTNR=WATE
10672     QR=Q
10673     UR=U2
10674     VR=V2
10675     WR=W2
10676     ER=E2
10677     IF((KZ2.EQ.4).AND.(MT.EQ.23))RETURN
10678     C STORE THE RECOIL HEAVY ION IN THE RECOIL BANK
10679     EP = ER
10680     UP = UR
10681     VP = VR
10682     WP = WR
10683     AGEP = AGE
10684     MTP = MT
10685     AMP = AR
10686     ZMP = FLOAT(NZR)
10687     CALL STOPAR(IDHEVY,NHEVY)
10688     RETURN
10689     END
10690     *CMZ : 1.01/04 10/06/93 14.43.48 by Christian Zeitnitz
10691     *-- Author :
10692     SUBROUTINE LRNORM(D,LD,IDICTS,LDICT,LR,EOLD,MT,IIN,XSLR)
10693     C THIS ROUTINE IS DESIGNED TO ADJUST THE NEUTRON CROSS SECTION
10694     C USED TO CALCULATE THE PHOTON MULTIPLICITY WHEN THE
10695     C INELASTIC RESOLVED DATA CONTAINS LR-FLAGS DESIGNATING
10696     C CHARGED PARTICLE EMISSION
10697     #include "minput.inc"
10698     #include "mconst.inc"
10699     #include "mcross.inc"
10700     #include "mmicab.inc"
10701     *KEND.
10702     DIMENSION D(*),LD(*),IDICTS(NNR,NNUC),LDICT(NNR,NNUC),
10703     +LR(NQ,NNUC)
10704     SAVE
10705     C INITIALIZE VARIABLES USED IN THE CALCULATION
10706     SUM=0.0
10707     SUM4=SIGNIS
10708     C DETERMINE (N,N") CROSS SECTION AND LR-FLAG
10709     DO 10 I=14,54
10710     L1=LDICT(I,IIN)
10711     IF(L1.EQ.0)GO TO 10
10712     LS1=IDICTS(I,IIN)+LMOX2
10713     LEN=L1/2
10714     CALL XSECNU(D,LEN,EOLD,SIG,LS1,L1)
10715     LRI=LR(I,IIN)
10716     IF(LRI.EQ.MT)SUM=SUM+SIG
10717     IF(LRI.EQ.22)SUM4=SUM4-SIG
10718     IF(LRI.EQ.23)SUM4=SUM4-SIG
10719     IF(LRI.EQ.28)SUM4=SUM4-SIG
10720     10 CONTINUE
10721     XSLR=SUM
10722     IF(MT.EQ.4)XSLR=SUM4
10723     RETURN
10724     END
10725     *CMZ : 1.04/05 16/08/95 14.52.27 by Christian Zeitnitz
10726     *-- Author : Christian Zeitnitz 25/05/94
10727     SUBROUTINE MATISO(IZ,IA,NI,IDISO,FSINGL,NUNIT)
10728     C
10729     C Search array MATIDS for the isotopes which have to be taken
10730     C into account for the element described by IZ and IA
10731     C
10732     #include "mmicap.inc"
10733     #include "minput.inc"
10734     *KEND.
10735     C
10736     DIMENSION IDISO(20,2)
10737     LOGICAL FSINGL
10738     C
10739     IF(IZ.GT.0.AND.IZ.LE.100.and.MATIDS(IZ,1,1).GT.0) THEN
10740     ID = IZ*1000+IA
10741     IF = 0
10742     IC = 0
10743     IDIFF = 1000000
10744     C
10745     C check first if selected isotope available
10746     DO 10 I=2,MATIDS(IZ,1,1)+1
10747     IF( MATIDS(IZ,I,1).EQ.ID .AND.
10748     + (MATIDS(IZ,I,2).EQ.100 .OR. FSINGL)) IF = I
10749     IF( IABS(MATIDS(IZ,I,1)-ID).LT.IDIFF) THEN
10750     IDIFF = IABS(MATIDS(IZ,I,1)-ID)
10751     IC = I
10752     ENDIF
10753     IDISO(I-1,1) = MATIDS(IZ,I,1)
10754     IDISO(I-1,2) = MATIDS(IZ,I,2)
10755     10 CONTINUE
10756     NI = 1
10757     C the unit number on which the x-section is stored
10758     NUNIT = MATIDS(IZ,1,2)
10759     IF(.NOT. FSINGL) THEN
10760     IF(IF .EQ. 0) THEN
10761     C no matching isotope found. Look for closest one
10762     IF(MATIDS(IZ,2,2).NE.100) NI = MATIDS(IZ,1,1)
10763     ELSE
10764     C matching isotope found
10765     IDISO(1,1) = MATIDS(IZ,IF,1)
10766     IDISO(1,2) = 100
10767     ENDIF
10768     ELSE
10769     IDISO(1,1) = MATIDS(IZ,IC,1)
10770     IDISO(1,2) = 100
10771     ENDIF
10772     ELSE
10773     WRITE(IOUT,'('' MATISO: Error in neutron x-section '', '
10774     + //' ''file detected - Z = '',I4)') IZ
10775     WRITE(6,'('' MICAP : Error in x-section file '', '
10776     + //' '' detected -> STOP '')')
10777     STOP
10778     ENDIF
10779     RETURN
10780     END
10781     *CMZ : 1.05/03 27/06/2001 18.31.28 by Christian Zeitnitz
10782     *-- Author :
10783     SUBROUTINE MICAP
10784     C
10785     C CALOR-GEANT interface COMMON
10786     #include "calgea.inc"
10787     *KEND.
10788     C MICAP commons
10789     #include "mmicap.inc"
10790     #include "minput.inc"
10791     #include "mconst.inc"
10792     #include "mnutrn.inc"
10793     #include "mapoll.inc"
10794     #include "mpoint.inc"
10795     #include "mrecoi.inc"
10796     #include "mmass.inc"
10797     #include "mpstor.inc"
10798     #include "cmagic.inc"
10799     *KEND.
10800     C
10801     C convert Z,A of recoil to CALOR particle code
10802     C only p = 0, D = 7, T = 8, He3 = 9, alpha=10
10803     DIMENSION NPART(4,0:2)
10804     DATA ((NPART(I,J),I=1,4),J=0,2)/1 ,-1 ,-1 , -1,
10805     + 0 , 7 , 8 , -1,
10806     + -1 ,-1 , 9 , 10/
10807     LOGICAL NOP
10808     SAVE
10809     C first check, if ZEBRA still in order
10810     IF(LD(LMAG1).NE.NMAGIC.OR.LD(LMAG2).NE.NMAGIC) THEN
10811     WRITE(6,*) ' CALOR: ZEBRA banks screwed up --> STOP'
10812     WRITE(IOUT,'('' MICAP: Magic number '',I12,'' not found: '', '
10813     + //' 2I12)') NMAGIC,LD(LMAG1),LD(LMAG2)
10814     STOP
10815     ENDIF
10816     C THIS ROUTINE PERFORMS THE RANDOM WALK FOR ALL PARTICLES
10817     10 CONTINUE
10818     C get material and particle information
10819     U = UINC(1)
10820     V = UINC(2)
10821     W = UINC(3)
10822     X = 0.0
10823     Y = 0.0
10824     Z = 0.0
10825     BLZNT = 1
10826     WATE = 1.0
10827     AGE = 0.0
10828     NREG = 1
10829     WTBC = 1.0
10830     C Energy MeV -> eV
10831     E = EINC * 1.E6
10832     C Material number a la GEANT
10833     NMED = NCEL
10834     NMEM=1
10835     C reset counter of heavy/charged and gamma bank
10836     NMEMR = 0
10837     NMEMG = 0
10838     INALB=0
10839     EOLD=E
10840     UOLD=U
10841     VOLD=V
10842     WOLD=W
10843     OLDWT=WATE
10844     XOLD=X
10845     YOLD=Y
10846     ZOLD=Z
10847     BLZON=BLZNT
10848     MEDOLD=NMED
10849     OLDAGE=AGE
10850     I=1
10851     CALL GTMED(NMED,IMED)
10852     C get total cross-section
10853     CALL NSIGTA(E,NMED,TSIG,D,LD(LFP32),LD(LFP33))
10854     C DETERMINE WHICH ISOTOPE HAS BEEN HIT
10855     CALL ISOTPE(D,LD,LD(LFP10),D(LFP12),LD(LFP16),LD(LFP26),LD(LFP27),
10856     + E,TSIG,IMED,IIN,IIM)
10857     C THE PARAMETER (IIN) IS THE POINTER FOR ARRAYS DIMENSIONED BY
10858     C (NNUC) AND THE PARAMETER (IIM) IS THE POINTER FOR ARRAYS
10859     C DIMENSIONED BY (NMIX)
10860     LD(LFP42+IMED-1)=LD(LFP42+IMED-1)+1
10861     INEU = 0
10862     NNEU = 0
10863     NHEVY = 0
10864     NGAMA = 0
10865     NPSTOR = 0
10866     ATARGT = D(LFP34+IIN-1)*1.008665
10867     ZTARGT = FLOAT(LD(LFP13+IIM-1))
10868     CALL COLISN(D,LD,LD(LFP20),LD(LFP21),LD(LFP22),LD(LFP23),
10869     + D(LFP24),LD(LFP24),
10870     + LD(LFP25),LD(LFP26),LD(LFP27),LD(LFP28),LD(LFP29),LD(LFP30),
10871     + LD(LFP31),D(LFP34),D(LFP35),LD(LFP41),LD(LFP41+NNUC),
10872     + LD(LFP42),LD(LFP42+MEDIA),LD(LFP42+2*MEDIA),LD(LFP42+3*MEDIA),
10873     + LD(LFP42+4*MEDIA),LD(LFP42+5*MEDIA),LD(LFP42+6*MEDIA),
10874     + LD(LFP42+7*MEDIA),LD(LFP42+8*MEDIA),LD(LFP42+9*MEDIA),
10875     + LD(LFP42+10*MEDIA),LD(LFP42+11*MEDIA),LD(LFP42+12*MEDIA),
10876     + LD(LFP42+13*MEDIA),LD(LFP42+14*MEDIA),LD(LFP42+15*MEDIA),
10877     + LD(LFP42+16*MEDIA),LD(LFP42+17*MEDIA),LD(LFP42+18*MEDIA),
10878     + LD(LFP42+19*MEDIA),LD(LFP42+20*MEDIA),LD(LFP42+21*MEDIA),
10879     + LD(LFP42+22*MEDIA),LD(LFP45),LD(LFP46),LD(LFP13),
10880     + LD(LFP35+NQ*NNUC),D(LFP35+2*NQ*NNUC),IIN,IIM)
10881     CALL BANKR(D,LD,5)
10882     C -------- fill return arrays with generated particles ---------------
10883     C first heavy/charged particles
10884     20 NPHETC = 0
10885     NRECOL = 0
10886     ERMED(1) = 0.0
10887     EETOT = 0.0
10888     C -------- store neutrons -------------------------------------
10889     INTCAL = 0
10890     C
10891     DO 30 N=1,NNEU
10892     CALL GETPAR(IDNEU,N,IERR)
10893     IF(IERR.EQ.0) THEN
10894     NPHETC = NPHETC + 1
10895     IF(NPHETC.GT.MXCP) NPHETC=MXCP
10896     IPCAL(NPHETC) = 1
10897     C kinetic energy in MeV
10898     EKINET(NPHETC) = EP * 1.E-6
10899     UCAL(NPHETC,1) = UP
10900     UCAL(NPHETC,2) = VP
10901     UCAL(NPHETC,3) = WP
10902     CALTIM(NPHETC) = AGEP
10903     ENDIF
10904     30 CONTINUE
10905     C -------- store heavy recoil products ------------------------
10906     DO 40 N=1,NHEVY
10907     CALL GETPAR(IDHEVY,N,IERR)
10908     IF(IERR.EQ.0) THEN
10909     C check particle type
10910     MA = NINT(AMP)
10911     MZ = NINT(ZMP)
10912     NOP = .TRUE.
10913     IF(MA.LE.4.AND.MZ.LE.2) THEN
10914     IF(NPART(MA,MZ).GT.-1) NOP = .FALSE.
10915     ENDIF
10916     IF(NOP) THEN
10917     C get heavy recoil nucleus
10918     NRECOL = NRECOL + 1
10919     AMED(NRECOL) = AMP
10920     ZMED(NRECOL) = ZMP
10921     ERMED(NRECOL)= EP * 1.E-6
10922     GOTO 40
10923     ENDIF
10924     C store particle type
10925     NPHETC = NPHETC + 1
10926     IF(NPHETC.GT.MXCP) NPHETC=MXCP
10927     IPCAL(NPHETC) = NPART(MA,MZ)
10928     C kinetic energy in MeV
10929     EKINET(NPHETC) = EP * 1.E-6
10930     UCAL(NPHETC,1) = UP
10931     UCAL(NPHETC,2) = VP
10932     UCAL(NPHETC,3) = WP
10933     CALTIM(NPHETC) = AGEP
10934     ENDIF
10935     40 CONTINUE
10936     C
10937     C----------- get generated gammas --------------------
10938     DO 50 N=1,NGAMA
10939     CALL GETPAR(IDGAMA,N,IERR)
10940     IF(IERR.EQ.0) THEN
10941     NG = NG + 1
10942     NPHETC = NPHETC + 1
10943     IF(NPHETC.GT.MXCP) NPHETC=MXCP
10944     IPCAL(NPHETC) = 11
10945     EKINET(NPHETC) = EP*1.E-6
10946     UCAL(NPHETC,1) = UP
10947     UCAL(NPHETC,2) = VP
10948     UCAL(NPHETC,3) = WP
10949     CALTIM(NPHETC) = AGEP
10950     C nucleus is in ground state !
10951     EXMED = 0.0
10952     ENDIF
10953     50 CONTINUE
10954     IF (MTP .EQ. 2) THEN
10955     INTCAL = 13
10956     ELSEIF (MTP .EQ. 18) THEN
10957     IF (NHEVY.GT.0) INTCAL = 15
10958     ELSEIF (MTP .LT. 100) THEN
10959     IF (NNEU .GT.0) INTCAL = 20
10960     ELSEIF (MTP .EQ. 102) THEN
10961     INTCAL = 18
10962     ELSEIF (MTP .GE. 100) THEN
10963     IF (NHEVY+NGAMA.GT.0) INTCAL = 16
10964     ENDIF
10965     IF(NNEU+NHEVY+NGAMA.GT.0.AND.INTCAL.EQ.0) INTCAL=12
10966     RETURN
10967     END
10968     *CMZ : 1.05/03 29/08/2001 14.35.16 by Christian Zeitnitz
10969     *-- Author : Christian Zeitnitz 21/07/92
10970     SUBROUTINE MORINI
10971     C**************************************************************
10972     C Initialize MICAP
10973     C ================
10974     C Called by : CALINI
10975     C
10976     C Purpose : setup cross-section tables and initialize pointer
10977     C print flags etc.
10978     C
10979     C Author : C.Zeitnitz
10980     C
10981     C last modification: Changed in order to read new x-section file
10982     C
10983     C
10984     C for details see MICAP manual ORNL/TM-10340
10985     C*************************************************************
10986     C MICAP commons
10987     #include "mmicap.inc"
10988     #include "mpoint.inc"
10989     #include "minput.inc"
10990     #include "mmass.inc"
10991     #include "mconst.inc"
10992     #include "cmagic.inc"
10993     #include "cerrcm.inc"
10994     #include "camass.inc"
10995     *KEND.
10996     C GEANT common
10997     #include "gccuts.inc"
10998     #include "gcflag.inc"
10999     *KEND.
11000     C pointer to material/mixture bank (NMATE,JMATE)
11001     #include "gcnum.inc"
11002     *KEND.
11003     C
11004     COMMON / QUEST / IQUEST(100)
11005     C
11006     C Avogadro number multiplied by 1.E-24
11007     PARAMETER(XNAVO = 0.60221367)
11008     C
11009     DIMENSION A(100),AGEA(100),Z(100),DEN(100),MID(100,2),IDI(20,2)
11010     CHARACTER*100 XSFILE
11011     CHARACTER*4 CNAME
11012     CHARACTER*70 CCOMM
11013     CHARACTER*100 CHROOT
11014     LOGICAL OPENED,EXISTS,IFOUND,FMIST,FSINGL,FMIFL
11015     C
11016     C set GEANT initialization flag
11017     IFINIT(7) = 1
11018     C
11019     C neutron energy cut (eV)
11020     ECUT = CUTNEU * 1.E9
11021     C get time cut off from GEANT
11022     TCUT = TOFMAX
11023     C temperature for thermal neutron xsection (Kelvin)
11024     C only temporary constant !!!
11025     TEMP = 300.0
11026     C xsection file unit
11027     MICROS = 31
11028     C open MICAP I/O units
11029     INQUIRE(UNIT=MICROS,OPENED=OPENED)
11030     IF(OPENED) THEN
11031     REWIND MICROS
11032     ELSE
11033     XSFILE = 'xsneut.dat'
11034     INQUIRE(FILE=XSFILE,EXIST=EXISTS)
11035     IF(.NOT.EXISTS) THEN
11036     CHROOT=' '
11037     CALL GETENV('CERN_ROOT',CHROOT)
11038     LNROOT = LNBLNK(CHROOT)
11039     IF(LNROOT.GT.0)XSFILE = CHROOT(1:LNROOT)//'/lib/xsneut.dat'
11040     ENDIF
11041     INQUIRE(FILE=XSFILE,EXIST=EXISTS)
11042     IF(.NOT.EXISTS) THEN
11043     PRINT*,'**********************************'
11044     PRINT*,'* G C A L O R *'
11045     PRINT*,'* ----------- *'
11046     PRINT*,'* File XSNEUT.DAT not found *'
11047     PRINT*,'* Program STOP *'
11048     PRINT*,'**********************************'
11049     STOP
11050     ENDIF
11051     OPEN(UNIT=MICROS,FILE=XSFILE,STATUS='OLD')
11052     ENDIF
11053     C setup the link areas needed for x-section banks
11054     CALL MZLINK(IXCONS,'MICTMP',LTEMP,LTEMP,LTEMP)
11055     CALL MZLINK(IXCONS,'MMICAP',LMAG2,LMOX4,LMAG2)
11056     CALL MZLINK(IXCONS,'MPOINT',LMAG1,LFP210,LMAG1)
11057     C
11058     LSUP = 0
11059     LCSUP = 0
11060     NUNIT = MICROS
11061     C pointers into TEMP bank
11062     NTUNIT = 1
11063     NTNAME = NTUNIT + 1
11064     NTMPNI = NTNAME + 1 + 80/4
11065     NTCOMM = NTMPNI + 1
11066     NTDATS = NTCOMM + 1 + 80/4
11067     NTLIST = NTDATS + 1 + 24/4
11068     10 CONTINUE
11069     C read comment and date of xsection file
11070     READ(NUNIT,'(A80,/,A24)') COMMEN,DATSTR
11071     C read in material definition array
11072     READ(NUNIT,'(I10)') NISO
11073     NWW = NISO * 3 + 12 + NTLIST
11074     C get temporary buffer
11075     CALL CHKZEB(NWW,IXCONS)
11076     IF(LSUP.EQ.0) Then
11077     C create a top level bank for the list of isotopes
11078     CALL MZBOOK(IXCONS,LTEMP,LSUP,1,'TEMP',3,0,NWW,0,-1)
11079     LT = LTEMP
11080     ELSE
11081     C create an additional bank in the linear structure TEMP
11082     CALL MZBOOK(IXCONS,LT,LSUP,0,'TEMP',3,0,NWW,0,-1)
11083     LSUP = LT
11084     ENDIF
11085     NREC = NISO * 3 / 12
11086     NN = 0
11087     C store the unit number of the file in bank TEMP
11088     IQ(LT + NTUNIT) = NUNIT
11089     C store the file name in bank TEMP
11090     CALL UCTOH(XSFILE,IQ(LT+NTNAME+1),4,LNBLNK(XSFILE))
11091     IQ(LT + NTNAME) = LNBLNK(XSFILE)
11092     C store the comment and date string in bank TEMP
11093     IQ(LT + NTCOMM) = LNBLNK(COMMEN)
11094     CALL UCTOH(COMMEN,IQ(LT+NTCOMM+1),4,LNBLNK(COMMEN))
11095     IQ(LT + NTDATS) = LNBLNK(DATSTR)
11096     CALL UCTOH(DATSTR,IQ(LT+NTDATS+1),4,LNBLNK(DATSTR))
11097     DO 20 I=1,NREC
11098     LL = (I-1)*12 + LT + NTLIST
11099     READ(NUNIT,'(12I6)') (IQ(L),L=LL,LL+11)
11100     20 CONTINUE
11101     C
11102     C get number of comment lines for different isotopes
11103     READ(NUNIT,'(I10)') NCOM
11104     NWW = NCOM * 80 + 2
11105     C get CISO bank
11106     CALL CHKZEB(NWW,IXCONS)
11107     IF(LCSUP.EQ.0) Then
11108     C create a top level bank for the isotope comments
11109     CALL MZBOOK(IXCONS,LCISO,LCSUP,1,'CISO',3,0,NWW,0,-1)
11110     LC = LCISO
11111     ELSE
11112     C create an additional bank in the linear structure CISO
11113     CALL MZBOOK(IXCONS,LC,LCSUP,0,'CISO',3,0,NWW,0,-1)
11114     LCSUP = LC
11115     ENDIF
11116     IQ(LC+1) = NCOM
11117     DO 30 I=1,NCOM
11118     J = (I-1)*81 + 2
11119     READ(NUNIT,'(I4,I4,A70)') IQ(LC+J),IQ(LC+J+1),
11120     + CCOMM
11121     CALL UCTOH(CCOMM,IQ(LC+J+2),4,70)
11122     30 CONTINUE
11123     C
11124     C---------------------------------------------------------------------
11125     C check the existence of secondary x-section files stored in bank MIFL
11126     C real messy code !!! But its fortran after all !!! CZ Jan 95
11127     XSFILE = ' '
11128     IF(NUNIT.EQ.MICROS) THEN
11129     FMIFL = .FALSE.
11130     CALL MZINQD(IXCONS)
11131     IF(LMIFIL.GE.IQUEST(3) .AND. LMIFIL.LE.IQUEST(4)) THEN
11132     CALL UHTOC(IQ(LMIFIL-4),4,CNAME,4)
11133     IF(CNAME.EQ.'MIFL') FMIFL = .TRUE.
11134     ENDIF
11135     IXSF=LMIFIL
11136     ENDIF
11137     IF(FMIFL) THEN
11138     40 CONTINUE
11139     C get the file name
11140     CALL UHTOC(IQ(IXSF+2),4,XSFILE,IQ(IXSF+1))
11141     IXSF = IXSF + 101
11142     C last name in the list ?
11143     IF(IXSF-LMIFIL .GE. IQ(LMIFIL-1) ) FMIFL = .FALSE.
11144     C
11145     INQUIRE(FILE=XSFILE,EXIST=EXISTS)
11146     IF(.NOT.EXISTS) THEN
11147     PRINT '(70(''*''))'
11148     PRINT '('' * MICAP : x-section file not found '')'
11149     PRINT '('' * '',A77)', XSFILE
11150     PRINT '(70(''*''))'
11151     IF(FMIFL) GOTO 40
11152     ELSE
11153     C find a free unit number (greater 31), and use it
11154     DO 50 I=NUNIT+1,99
11155     INQUIRE(UNIT=I,OPENED=OPENED)
11156     IF(.NOT.OPENED) THEN
11157     NUNIT = I
11158     OPEN(UNIT=I,FILE=XSFILE,STATUS='OLD')
11159     GOTO 10
11160     ENDIF
11161     50 CONTINUE
11162     PRINT '(70(''*''))'
11163     PRINT *,'* MICAP : No more free units available !'
11164     PRINT '(70(''*''))'
11165     ENDIF
11166     ENDIF
11167     C---------------------------------------------------------------------
11168     CALL VZERO(MATIDS,4000)
11169     LT = LTEMP
11170     60 CONTINUE
11171     NUNIT = IQ(LT + NTUNIT)
11172     KK = LT + NTLIST
11173     DO 90 I=1,100
11174     NIS = IQ(KK)
11175     KK = KK + 1
11176     IF(NIS.EQ.0) GOTO 100
11177     IF(MATIDS(I,1,1).EQ.0) THEN
11178     MATIDS(I,1,1) = NIS
11179     MATIDS(I,1,2) = NUNIT
11180     C is the Z of the element correct?
11181     ELSE IF(IQ(KK)/1000.EQ.I) THEN
11182     C overwrite existing element with the one stored in new file
11183     DO 70 J=2,MATIDS(I,1,1)+1
11184     MATIDS(I,J,1) = 0
11185     MATIDS(I,J,2) = 0
11186     70 CONTINUE
11187     MATIDS(I,1,1) = NIS
11188     MATIDS(I,1,2) = NUNIT
11189     ELSE
11190     C no action
11191     KK = KK + 2 * NIS
11192     GOTO 90
11193     ENDIF
11194     C maximal 20 isotopes per element
11195     NIS = MIN(NIS,19)
11196     DO 80 J=2,NIS+1
11197     MATIDS(I,J,1) = IQ(KK)
11198     MATIDS(I,J,2) = IQ(KK+1)
11199     KK = KK + 2
11200     80 CONTINUE
11201     90 CONTINUE
11202     100 CONTINUE
11203     LT = LQ(LT)
11204     IF(LT.GT.0) GOTO 60
11205     C
11206     C DEFINE CROSS SECTION DIMENSIONING VARIABLES
11207     C NNR EQUALS THE NUMBER OF NEUTRON RECORDS
11208     C NQ EQUALS THE NUMBER OF Q VALUES
11209     C NGR EQUALS THE NUMBER OF GAMMA RECORDS
11210     C SET THE DEFAULT VALUES FOR THE CURRENT CROSS SECTION DATA
11211     NNR=134
11212     NQ=66
11213     NGR=60
11214     C
11215     C SET THE DEFAULT VALUES FOR THE NEUTRON, PROTON, DEUTERON,
11216     C TRITON, HELIUM-3, AND ALPHA PARTICLE MASSES (IN EV)
11217     ZN=XMASS(1)*1.E9
11218     ZP=XMASS(0)*1.E9
11219     ZD=XMASS(7)*1.E9
11220     ZT=XMASS(8)*1.E9
11221     ZHE3=XMASS(9)*1.E9
11222     ZA=XMASS(10)*1.E9
11223     C SET THE DEFAULT VALUES FOR THE NEUTRON, PROTON, DEUTERON,
11224     C TRITON, HELIUM-3, AND ALPHA PARTICLE MASSES (IN AMU)
11225     XAMU=0.93149432*1.E9
11226     AN=ZN/XAMU
11227     AP=ZP/XAMU
11228     AD=ZD/XAMU
11229     AT=ZT/XAMU
11230     AHE3=ZHE3/XAMU
11231     AA=ZA/XAMU
11232     C now preprocess all materials xs
11233     MEDIA = 0
11234     NMIX = 0
11235     NMAT = 0
11236     C Check if material option bank MIST exists
11237     FMIST = .FALSE.
11238     CALL MZINQD(IXCONS)
11239     IF(LMIST.GE.IQUEST(3) .AND. LMIST.LE.IQUEST(4)) THEN
11240     CALL UHTOC(IQ(LMIST-4),4,CNAME,4)
11241     IF(CNAME.EQ.'MIST') FMIST = .TRUE.
11242     ENDIF
11243     C 1. loop over tracking media -> get NMIX,MEDIA
11244     DO 140 I=1,NTMED
11245     JTM = LQ(JTMED - I)
11246     IF(JTM.LE.0) GOTO 140
11247     C valid tracking medium found get material number
11248     C and get corresponding material parameters from JMATE structure
11249     IMA = INT(Q(JTM+6))
11250     IF(IMA.LE.0 .OR. IMA.GT.NMATE) GOTO 140
11251     C count number of elements and number of mixing operations
11252     JMA = LQ(JMATE-IMA)
11253     IF(JMA.LE.0) GOTO 140
11254     IF(Q(JMA+6) .LE. 1.0 .OR. Q(JMA+6) .GE. 240.) GOTO 140
11255     C Check if for material IMA single isotopes are selected
11256     FSINGL = .FALSE.
11257     IF(FMIST) THEN
11258     DO 110 KIM=1,IQ(LMIST-1),2
11259     IF(IMA.EQ.IQ(LMIST+KIM).AND.IQ(LMIST+KIM+1).EQ.0) THEN
11260     FSINGL = .TRUE.
11261     GOTO 120
11262     ENDIF
11263     110 CONTINUE
11264     120 CONTINUE
11265     ENDIF
11266     C get number of elements in material max = 100
11267     KK = MIN(ABS(Q(JMA+11)),100.)
11268     C relation between MICAP and GEANT material number
11269     MEDIA = MEDIA + 1
11270     C mixture ?
11271     KK1 = KK
11272     IF(KK.GT.1) THEN
11273     JMIXT = LQ(JMA - 5)
11274     C
11275     C check if more than one isotope has to taken into account for all
11276     C elements in the mixture
11277     DO 130 K=1,KK
11278     IA = NINT(Q(JMIXT+K))
11279     IZ = NINT(Q(JMIXT+K+KK))
11280     CALL MATISO(IZ,IA,NNI,IDI,FSINGL,NUNIT)
11281     KK1 = KK1 + NNI - 1
11282     130 CONTINUE
11283     ELSE
11284     IA = NINT(Q(JMA+6))
11285     IZ = NINT(Q(JMA+7))
11286     CALL MATISO(IZ,IA,NNI,IDI,FSINGL,NUNIT)
11287     KK1 = KK1 + NNI - 1
11288     ENDIF
11289     NMIX = NMIX + KK1
11290     140 CONTINUE
11291     C allocate ZEBRA bank for material information
11292     NW = 9 * NMIX + MEDIA + 10
11293     C define link area for MICAP banks in GCBANK
11294     CALL CHKZEB(NW,IXCONS)
11295     CALL MZBOOK(IXCONS,LMOMA,0,2,'MOME',0,0,NW,0,-1)
11296     LMAG1 = LMOMA + 1
11297     IQ(LMAG1) = NMAGIC
11298     LGE2MO = LMAG1 + 1
11299     LFP10 = LGE2MO + MEDIA + 1
11300     LFP11 = LFP10 + NMIX
11301     LFP12 = LFP11 + NMIX
11302     LFP13 = LFP12 + NMIX
11303     LFP14 = LFP13 + NMIX
11304     LFP140 = LFP14 + NMIX
11305     LFP16 = LFP140 + NMIX
11306     LFP17 = LFP16 + NMIX
11307     C 2. loop over tracking media
11308     MEDIA1 = 0
11309     NMIX1 = 0
11310     DO 230 I=1,NTMED
11311     JTM = LQ(JTMED - I)
11312     IF(JTM.LE.0) GOTO 230
11313     C valid tracking medium found get material number
11314     C and get corresponding material parameters from JMATE structure
11315     IMA = INT(Q(JTM+6))
11316     IF(IMA.LE.0 .OR. IMA.GT.NMATE) GOTO 230
11317     C count number of elements and number of mixing operations
11318     JMA = LQ(JMATE-IMA)
11319     IF(JMA.LE.0) GOTO 230
11320     IF(Q(JMA+6) .LE. 1.0 .OR. Q(JMA+6) .GE. 240.) GOTO 230
11321     C Check if for material IMA single isotopes are selected
11322     FSINGL = .FALSE.
11323     IF(FMIST) THEN
11324     DO 150 KIM=1,IQ(LMIST-1),2
11325     IF(IMA.EQ.IQ(LMIST+KIM).AND.IQ(LMIST+KIM+1).EQ.0) THEN
11326     FSINGL = .TRUE.
11327     GOTO 160
11328     ENDIF
11329     150 CONTINUE
11330     160 CONTINUE
11331     ENDIF
11332     NMAT = NMAT + 1
11333     C get number of elements in material max = 100
11334     RHO1 = Q(JMA+8)
11335     KK = MIN1(ABS(Q(JMA+11)),100.)
11336     C relation between MICAP and GEANT material number
11337     C check if medium IMA already stored (multiple tracking media)
11338     DO K=1,100
11339     AGEA(K) = 0.0
11340     ENDDO
11341     DO 180 KMI=1,MEDIA1
11342     IF(IQ(LGE2MO+KMI).EQ.IMA) THEN
11343     IF(KK.EQ.1) THEN
11344     IA = NINT(Q(JMA+6))
11345     IZ = NINT(Q(JMA+7))
11346     CALL MATISO(IZ,IA,NNI,IDI,FSINGL,NUNIT)
11347     NMIX = NMIX - NNI
11348     ELSE
11349     JMIXT = LQ(JMA - 5)
11350     DO 170 K=1,KK
11351     IA = NINT(Q(JMIXT+K))
11352     IZ = NINT(Q(JMIXT+K+KK))
11353     CALL MATISO(IZ,IA,NNI,IDI,FSINGL,NUNIT)
11354     NMIX = NMIX - NNI
11355     170 CONTINUE
11356     ENDIF
11357     MEDIA = MEDIA - 1
11358     GOTO 230
11359     ENDIF
11360     180 CONTINUE
11361     MEDIA1 = MEDIA1 + 1
11362     IQ(LGE2MO+MEDIA1) = IMA
11363     C mixture ?
11364     KK2 = KK
11365     IF(KK.GT.1) THEN
11366     JMIXT = LQ(JMA - 5)
11367     KPOS = 1
11368     DO 200 K=1,KK
11369     AMOL = Q(LQ(JMIXT-1) + 2)
11370     XMOLCM = RHO1/AMOL*XNAVO
11371     IA = NINT(Q(JMIXT+K))
11372     IZ = NINT(Q(JMIXT+K+KK))
11373     CALL MATISO(IZ,IA,NNI,IDI,FSINGL,NUNIT)
11374     KK2 = KK2 + NNI - 1
11375     DO 190 KJ=1,NNI
11376     KKPOS = KPOS + KJ - 1
11377     IF(KJ.EQ.1) THEN
11378     AGEA(KKPOS) = Q(JMIXT+K)
11379     ELSE
11380     AGEA(KKPOS) = 0.
11381     ENDIF
11382     MID(KKPOS,1) = IDI(KJ,1)
11383     MID(KKPOS,2) = NUNIT
11384     IIZ = IDI(KJ,1)/1000
11385     IIA = IDI(KJ,1) - IIZ * 1000
11386     IF(IIA.NE.0 .AND. NNI.GT.1.) THEN
11387     A(KKPOS) = FLOAT(IIA)
11388     ELSE
11389     A(KKPOS) = Q(JMIXT+K)
11390     ENDIF
11391     Z(KKPOS) = Q(JMIXT+K+KK)
11392     WISO = FLOAT(IDI(KJ,2))/100.
11393     WI = Q(JMIXT+K+2*KK)*AMOL/A(KKPOS)*WISO
11394     DEN(KKPOS) = XMOLCM * WI
11395     190 CONTINUE
11396     KPOS = KPOS + NNI
11397     200 CONTINUE
11398     C element or compound
11399     ELSE
11400     IA = NINT(Q(JMA+6))
11401     IZ = NINT(Q(JMA+7))
11402     CALL MATISO(IZ,IA,NNI,IDI,FSINGL,NUNIT)
11403     KK2 = KK2 + NNI - 1
11404     DO 210 KJ=1,NNI
11405     IF(KJ.EQ.1) THEN
11406     AGEA(KJ) = Q(JMA+6)
11407     ELSE
11408     AGEA(KJ) = 0.
11409     ENDIF
11410     MID(KJ,1) = IDI(KJ,1)
11411     MID(KJ,2) = NUNIT
11412     IIZ = IDI(KJ,1)/1000
11413     IIA = IDI(KJ,1) - IIZ * 1000
11414     IF(IIA.NE.0 .AND. NNI.GT.1.) THEN
11415     A(KJ) = FLOAT(IIA)
11416     ELSE
11417     A(KJ) = Q(JMA+6)
11418     ENDIF
11419     Z(KJ) = Q(JMA+7)
11420     WISO = FLOAT(IDI(KJ,2))/100.
11421     DEN(KJ) = RHO1/A(KJ) * WISO *XNAVO
11422     210 CONTINUE
11423     ENDIF
11424     C
11425     C fill MICAP material arrays
11426     C actual number of isotopes given by KK2
11427     C
11428     DO 220 J = NMIX1 + 1, NMIX1 + KK2
11429     IQ(LFP10+J-1) = MEDIA1
11430     IQ(LFP11+J-1) = MID(J-NMIX1,1)
11431     C check if bound hydrogen has been selected
11432     IF(MID(J-NMIX1,1).eq.1001.AND.KK.GT.1) IQ(LFP11+J-1) = 1000
11433     Q(LFP12+J-1) = DEN(J-NMIX1)
11434     IQ(LFP13+J-1) = NINT(Z(J-NMIX1))
11435     Q(LFP14+J-1) = A(J-NMIX1)
11436     Q(LFP140+J-1) = AGEA(J-NMIX1)
11437     220 CONTINUE
11438     NMIX1 = NMIX1 + KK2
11439     230 CONTINUE
11440     IF(NMIX.LE.0) THEN
11441     PRINT *,' GCALOR: NO tracking media found ===> STOP '
11442     STOP
11443     ENDIF
11444     C read cross-sections and perform mixing and thinning
11445     CALL MOXSEC
11446     C close MICAP cross-section file(s)
11447     LT = LTEMP
11448     240 CONTINUE
11449     CLOSE(UNIT=IQ(LT+NTUNIT))
11450     LT = LQ(LT)
11451     IF(LT.GT.0) GOTO 240
11452     C Drop temporary linear structures
11453     CALL MZDROP(IXCONS,LTEMP,'L')
11454     CALL MZDROP(IXCONS,LCISO,'L')
11455     RETURN
11456     END
11457     *CMZ : 1.05/04 25/02/2005 14.27.38 by Christian Zeitnitz
11458     *-- Author : Christian Zeitnitz 22/07/92
11459     SUBROUTINE MOXSEC
11460     C************************************************************
11461     C
11462     C setup cross-section tables for MICAP
11463     C
11464     C Called by: MORINI
11465     C
11466     C INPUT: MICAP element IDs in KE = LD(LFP11)
11467     C element densities in RHO = D (LFP12)
11468     C
11469     C Author : C.Zeitnitz
11470     C
11471     C See USER's GUIDE TO MICAP ORNL/TM-10340
11472     C for details and pointer description (MPOINT)
11473     C
11474     C************************************************************
11475     #include "mmicap.inc"
11476     #include "minput.inc"
11477     #include "mpoint.inc"
11478     #include "mconst.inc"
11479     #include "cmagic.inc"
11480     *KEND.
11481     C
11482     CHARACTER*80 XSFILE
11483     CHARACTER*70 CCOMM
11484     CHARACTER*11 CGEANT
11485     CHARACTER*4 MARK
11486     CHARACTER*20 MATNAM
11487     INTEGER INEL(134)
11488     LOGICAL NOHED,XSTOP
11489     C
11490     C CALCULATE THE NUMBER OF ELEMENTS (NNUC)
11491     C AND GENERATE THE ISOTOPE NUMBER ARRAY (IN(NMIX))
11492     NWTOT = 0
11493     DO 10 I=1,NMIX
11494     LD(LFP17+I-1)=0
11495     LD(LFP16+I-1)=0
11496     10 CONTINUE
11497     C INITIALIZE THE NUMBER OF ELEMENTS (NNUC)
11498     NNUC=0
11499     DO 30 I=1,NMIX
11500     IF(LD(LFP16+I-1).GT.0)GO TO 30
11501     NNUC=NNUC+1
11502     LD(LFP16+I-1)=NNUC
11503     DO 20 J=I+1,NMIX
11504     IF(LD(LFP11+I-1).NE.LD(LFP11+J-1))GO TO 20
11505     LD(LFP16+J-1)=NNUC
11506     20 CONTINUE
11507     30 CONTINUE
11508     C get number of isoptopes from xsection file(s)
11509     LT = LTEMP
11510     NII = 0
11511     40 CONTINUE
11512     NUNIT = IQ(LT+NTUNIT)
11513     READ(NUNIT,'(I10)') NIS
11514     NII = NII + NIS
11515     IQ(LT+NTMPNI) = NIS
11516     LT = LQ(LT)
11517     IF(LT.GT.0) GOTO 40
11518     C allocate needed memory for x-section
11519     NW = 2*NII+13*NNUC+2*NNR*NNUC+4*NGR*NNUC+3*NQ*NNUC+26*MEDIA + 2
11520     NI = NII
11521     NWTOT = NWTOT + NW
11522     CALL CHKZEB(NW,IXCONS)
11523     CALL MZBOOK(IXCONS,LMOX1,0,2,'MOX1',0,0,NW,0,-1)
11524     C SET UP THE B CONTROL BLOCK LOCATION NUMBER ARRAY ICOM(NNUC)
11525     C LFP170 points to length of x-section data
11526     LFP170 = LMOX1 + 2
11527     LFP18=LFP170+NNUC
11528     LFP18A=LFP18+NII
11529     LFP19=LFP18A+NII
11530     LFP20=LFP19+NMIX
11531     C SET UP THE ARRAY (IREC(NII))
11532     CALL XSECN1(NII,LD(LFP11),LD(LFP16),LD(LFP17),
11533     + LD(LFP18),LD(LFP18A),LD(LFP170),LD(LFP19),
11534     + D(LFP20),LD(LFP20),INEL)
11535     C check if all isotopes have been found in the x-section file(s)
11536     XSTOP = .FALSE.
11537     DO 50 I=1,NMIX
11538     IF(LD(LFP19+I-1).EQ.0) THEN
11539     WRITE(IOUT,10100)LD(LFP19+I-1)
11540     10000 FORMAT(' MICAP: Could not find x-section of element ',I8)
11541     XSTOP = .TRUE.
11542     ENDIF
11543     50 CONTINUE
11544     IF(XSTOP) THEN
11545     PRINT '('' CALOR : Neutron x-section not found ===> STOP '')'
11546     STOP
11547     ENDIF
11548     LFP21=LFP20+NNUC
11549     C store xs accuracy at LFP210 (used for thinning in XSECN3)
11550     LFP210 = LFP21 + NNUC
11551     LFP22=LFP210+NNUC
11552     LFP23=LFP22+NNUC
11553     LFP24=LFP23+NNUC
11554     LFP25=LFP24+NNUC
11555     LFP26=LFP25+NNUC
11556     LFP27=LFP26+NNR*NNUC
11557     LFP28=LFP27+NNR*NNUC
11558     LFP29=LFP28+NNUC
11559     LFP30=LFP29+NNUC
11560     LFP31=LFP30+NGR*NNUC
11561     LFP32=LFP31+NGR*NNUC
11562     LFP33=LFP32+MEDIA
11563     LFP34=LFP33+MEDIA
11564     LFP35=LFP34+NNUC
11565     LFP36=LFP35+3*NQ*NNUC
11566     C CLEAR THE STORAGE LOCATIONS FOR THE DICTIONARIES, ETC.
11567     CALL CLEAR(LD,LFP20,LFP36-1)
11568     C ESTABLISH THE RANDOM WALK STORAGE LOCATIONS
11569     LFP41=LFP36
11570     LFP42=LFP41+2*NNUC
11571     LFP45=LFP42+24*MEDIA
11572     LFP46=LFP45+NGR*NNUC
11573     NW = 0
11574     DO 60 INUC=1,NNUC
11575     NW = NW + LD(LFP170+INUC-1)
11576     60 CONTINUE
11577     NW = NW + 2
11578     NWTOT = NWTOT + NW
11579     CALL CHKZEB(NW,IXCONS)
11580     CALL MZBOOK(IXCONS,LMOX2,0,2,'MOX2',0,0,NW,0,-1)
11581     LFP43 = LMOX2 + 2
11582     LAST = LFP43 - 1
11583     MAXD = LMOX2 + NW
11584     C PLACE THE MICROSCOPIC CROSS SECTION DATA INTO THE CORE
11585     CALL XSECN2(LD(LFP17),LD(LFP18),LD(LFP18A),
11586     + LD(LFP20),LD(LFP21),D(LFP210),LD(LFP22),LD(LFP23),
11587     + LD(LFP24),LD(LFP25),LD(LFP26),LD(LFP27),LD(LFP28),
11588     + LD(LFP29),LD(LFP30),LD(LFP31),D(LFP34),D(LFP35),
11589     + LD(LFP35+NQ*NNUC),D(LFP35+2*NQ*NNUC),
11590     + D(LFP43),LD(LFP43),MAXD,LAST,INEL)
11591     C determine length needed for macroscopic xs and mixing
11592     C the bank has to store:
11593     C - the xs of each isotope in the mixture
11594     C - the mixed xs (defined by sum of diff. energy points)
11595     NW = 0
11596     DO 90 IM=1,MEDIA
11597     NM = 0
11598     LZ = 0
11599     DO 70 IN=1,NMIX
11600     IF(LD(LFP10+IN-1).NE.IM) GOTO 70
11601     NM = NM+1
11602     II = LD(LFP16+IN-1)
11603     LZ = LD(LFP27+NNR*(II-1))+LZ
11604     C LZ = MAX0(LD(LFP27+NNR*(II-1)),LZ)
11605     C LZ = MAX0(LDICT(1,II),LZ)
11606     70 CONTINUE
11607     C IF(NM.GT.1) LZ = 6*LZ
11608     NW = NW + 2.*LZ
11609     90 CONTINUE
11610     NW = NW + 2
11611     NWTOT = NWTOT + NW
11612     CALL CHKZEB(NW,IXCONS)
11613     CALL MZBOOK(IXCONS,LMOX3,0,2,'MOX3',0,0,NW,0,-1)
11614     LAST = LMOX3 + 1
11615     LFP44=LAST+1
11616     MAXD = LMOX3+NW
11617     C SET, MIX AND THIN THE TOTAL CROSS SECTIONS
11618     C ACCORDING TO THE MIXING TABLE
11619     CALL XSECN3(LD(LFP10),LD(LFP11),D(LFP12),LD(LFP16),LD(LFP26),
11620     + LD(LFP27),LD(LFP32),LD(LFP33),D(LFP44),LD(LFP44),
11621     + D,MAXD,LAST)
11622     C ESTABLISH THE PHOTON TOTAL CROSS SECTION DATA DICTIONARY
11623     C STORAGE LOCATIONS
11624     C determine number of words needed for photon production xs
11625     NW = 0
11626     DO 110 I=1,NNUC
11627     DO 100 J=1,LD(LFP28+I-1)
11628     LZ = LD(LFP31 + 2*J - 1 + NGR*(I-1))
11629     C LZ = LGCB(2*J,I)
11630     NW = NW + LZ
11631     100 CONTINUE
11632     110 CONTINUE
11633     NW = NW + 2*NGR*NNUC+2
11634     NWTOT = NWTOT + NW + 1
11635     CALL CHKZEB(NW,IXCONS)
11636     CALL MZBOOK(IXCONS,LMOX4,0,2,'MOX4',0,0,NW,0,-1)
11637     LMAG2 = LMOX4 + 1
11638     LD(LMAG2) = NMAGIC
11639     LFP45 = LMAG2 + 1
11640     LFP46 = LFP45 + NGR*NNUC
11641     LFP47 = LFP46 + NGR*NNUC
11642     LAST = LFP47 - 1
11643     MAXD = LMOX4 + NW
11644     C CLEAR THE STORAGE LOCATIONS FOR THE PHOTON DICTIONARIES
11645     C OF THE TOTAL PHOTON PRODUCTION CROSS SECTIONS
11646     CALL CLEAR(LD,LFP45,LFP47-1)
11647     C SUM THE PHOTON PARTIAL DISTRIBUTIONS OF THE ENDF/B-V
11648     C FILE 12 AND FILE 13 DATA (BY MT NUMBER) AND PLACE THESE
11649     C MICROSCOPIC MULTIPLICITIES TIMES CROSS SECTIONS IN CORE
11650     CALL XSECN5(LD(LFP28),LD(LFP30),LD(LFP31),LD(LFP45),LD(LFP46),
11651     + D(LFP47),LD(LFP47),D,LD,MAXD,LAST)
11652     C
11653     C print out media to print unit IOUT
11654     C WRITE(IOUT,10000)
11655     10100 FORMAT(23X,'MICAP Material Parameters',/,
11656     + 23X,'-------------------------',/)
11657     WRITE(IOUT,10200)
11658     10200 FORMAT(8X,'GEANT Material Parameters',10X,
11659     + 6X,'MICAP Material Parameters',/,
11660     + 8X,25('-'),10X,6X,25('-'))
11661     WRITE(IOUT,10300)
11662     10300 FORMAT(1X,'Material',16X,'No/Iso',4X,'A',5X,'Z',2X,'|',
11663     + 4X,'A',5X,'Z',3X,'Density',
11664     + 3X,'Coll.Len',/,44('-'),'+',33('-'))
11665     MFLAG = 0
11666     KMED = 0
11667     NISO = 1
11668     DO 130 I=0,NMIX-1
11669     C get GEANT name of material
11670     MARK = '/ '
11671     IF(LD(LFP11+I)/1000.NE.LD(LFP13+I).OR.
11672     + (I.LT.NMIX-1.AND.D(LFP140+I).NE.0..AND.D(LFP140+I+1).NE.0.
11673     + .AND.NINT(D(LFP34+LD(LFP16+I)-1)*1.008665)
11674     + .NE.NINT(D(LFP140+I)))) THEN
11675     MARK = '/ *'
11676     MFLAG=1
11677     ENDIF
11678     K1 = LD(LFP16+I)-1
11679     LS1 = LD(LFP26+NNR*K1)+LMOX2
11680     LEN = LD(LFP27+NNR*K1)/2
11681     EN = 1.E6
11682     CALL TBSPLT(D(LS1),EN,LEN,XSEC)
11683     XSEC = 1./XSEC/D(LFP12+I)
11684     IF(D(LFP140+I).NE.0.) THEN
11685     WRITE(CGEANT,'(F6.1,I5)') D(LFP140+I),LD(LFP13+I)
11686     ELSE
11687     WRITE(CGEANT,'(A11)') ' - -'
11688     ENDIF
11689     IF(KMED.NE.LD(LFP10+I)) THEN
11690     NISO = 1
11691     CALL GFMATE(LD(LGE2MO+LD(LFP10+I)),MATNAM,AA,ZZ,DENS,
11692     + RADL,ABSL,UB,NW)
11693     NBLK = LNBLNK(MATNAM)
11694     DO 120 JC=NBLK+1,20
11695     WRITE(MATNAM(JC:JC),'(A1)') '.'
11696     120 CONTINUE
11697     WRITE(MARK(2:3),'(I2)') NISO
11698     WRITE(IOUT,10400) MATNAM,LD(LGE2MO+LD(LFP10+I)),MARK,
11699     + CGEANT,
11700     + D(LFP34+LD(LFP16+I)-1)*1.008665,
11701     + LD(LFP11+I)/1000,D(LFP12+I),XSEC
11702     KMED = LD(LFP10+I)
11703     ELSE
11704     WRITE(MARK(2:3),'(I2)') NISO
11705     WRITE(IOUT,10500) LD(LGE2MO+LD(LFP10+I)),MARK,CGEANT,
11706     + D(LFP34+LD(LFP16+I)-1)*1.008665,
11707     + LD(LFP11+I)/1000,D(LFP12+I),XSEC
11708     ENDIF
11709     10400 FORMAT(1X,A20,I6,A4,A11,' |',F6.1,I5,1X,E11.4,1X,E9.3)
11710     10500 FORMAT(1X,20X,I6,A4,A11,' |',F6.1,I5,1X,E11.4,1X,E9.3)
11711     LD(LFP13+I) = LD(LFP11+I)/1000
11712     NISO = NISO + 1
11713     130 CONTINUE
11714     WRITE(IOUT,'(78(''-''),/,48X,''Density in (Atoms/barn/cm)'')')
11715     WRITE(IOUT,'(36X, '
11716     + //' ''Collision Length for 1 MeV neutron in (cm)'',/)')
11717     IF(MFLAG.EQ.1) WRITE(IOUT,'(/, '
11718     + //'15X,''*******************************************'',/, '
11719     + //'15X,''* W A R N I N G *'',/, '
11720     + //'15X,''* Marked isotopes (*) not found in the *'',/, '
11721     + //'15X,''* cross-section file(s) *'',/, '
11722     + //'15X,''* Cross-sections of the isotope with *'',/, '
11723     + //'15X,''* the closest Z will be used instead *'',/, '
11724     + //'15X,''*******************************************'',/)')
11725     C which x-section files have been used?
11726     LT = LTEMP
11727     LCI = LCISO
11728     LC = 0
11729     NOHED=.TRUE.
11730     140 CONTINUE
11731     C first check if x-section file has been used!
11732     NUNIT = IQ(LT+NTUNIT)
11733     DO 150 I=0,NMIX-1
11734     KISO = LD(LFP16+I)
11735     MISO = LD(LFP17+KISO-1)
11736     IF(NUNIT.EQ.LD(LFP18A+MISO-1)) GOTO 160
11737     150 CONTINUE
11738     C unit never used !
11739     GOTO 190
11740     160 CONTINUE
11741     C search for comments for selected isotopes
11742     NCOM = IQ(LCI+1)
11743     DO 180 J=1,NCOM
11744     K = (J-1)*81 + 2
11745     JZ = IQ(LCI+K)
11746     JA = IQ(LCI+K+1)
11747     CCOMM = ' '
11748     CALL UHTOC(IQ(LCI+K+2),4,CCOMM,70)
11749     DO 170 I=0,NMIX-1
11750     KISO = LD(LFP16+I)
11751     IA = NINT(D(LFP34+KISO-1)*1.008665)
11752     IZ = LD(LFP11+I)/1000
11753     MISO = LD(LFP17+KISO-1)
11754     C print the comment, if the isotope is correct and has been read from
11755     C the current x-section file
11756     IF(IA.EQ.JA .AND. IZ.EQ.JZ .AND.
11757     + NUNIT.EQ.LD(LFP18A+MISO-1)) THEN
11758     IF(NOHED) THEN
11759     WRITE(IOUT,'(/,23X,''COMMENTS ABOUT ISOTOPE DATA'')')
11760     WRITE(IOUT,'( 23X,''---------------------------'',/)')
11761     NOHED = .FALSE.
11762     ENDIF
11763     LC = LC + 1
11764     WRITE(IOUT,'(I4,'') '',A70)') LC,CCOMM
11765     GOTO 180
11766     ENDIF
11767     170 CONTINUE
11768     180 CONTINUE
11769     190 LT = LQ(LT)
11770     LCI = LQ(LCI)
11771     IF(LT.GT.0.AND.LCI.GT.0) GOTO 140
11772     C print the x-section file names and comments
11773     WRITE(IOUT,'(/,20X,''USED NEUTRON CROSS-SECTION FILES'')')
11774     WRITE(IOUT,'( 20X,''--------------------------------'',/)')
11775     LT = LTEMP
11776     200 CONTINUE
11777     C first check if x-section file has been used!
11778     NUNIT = IQ(LT+NTUNIT)
11779     DO 210 I=0,NMIX-1
11780     KISO = LD(LFP16+I)
11781     MISO = LD(LFP17+KISO-1)
11782     IF(NUNIT.EQ.LD(LFP18A+MISO-1)) GOTO 220
11783     210 CONTINUE
11784     C unit never used !
11785     GOTO 230
11786     220 CONTINUE
11787     C get file name of x-section file
11788     XSFILE = ' '
11789     COMMEN = ' '
11790     DATSTR = ' '
11791     CALL UHTOC(IQ(LT+NTNAME+1),4,XSFILE,IQ(LT+NTNAME))
11792     CALL UHTOC(IQ(LT+NTCOMM+1),4,COMMEN,IQ(LT+NTCOMM))
11793     CALL UHTOC(IQ(LT+NTDATS+1),4,DATSTR,IQ(LT+NTDATS))
11794     WRITE(IOUT,'('' File : '',A66)') XSFILE
11795     WRITE(IOUT,'('' Generated : '',A24,/, '
11796     + //' '' Comment : '',A66,/)') DATSTR,COMMEN
11797     230 LT = LQ(LT)
11798     IF(LT.GT.0) GOTO 200
11799     WRITE(IOUT,'(/,'' MICAP :'',I10, '
11800     + //' '' words used in GCBANK for neutron x-section tables''/)')
11801     + NWTOT
11802     RETURN
11803     END
11804     *CMZ : 1.01/04 10/06/93 14.43.48 by Christian Zeitnitz
11805     *-- Author :
11806     SUBROUTINE N2NN3N(D,LD,AWR,KZ,ID,FM,Q,IFLG)
11807     C THIS ROUTINE CALCULATES THE DIRECTIONAL COSINES FOR THE
11808     C NEUTRON AND RECOIL NUCLEUS FOR AN N2N OR N3N REACTION
11809     C USING THE ONE NEUTRON EMMISION MODEL. IT ALSO SETS ALL
11810     C EXIT PARAMETRS FOR THE RECOIL NUCLEUS.
11811     #include "minput.inc"
11812     #include "mconst.inc"
11813     #include "mnutrn.inc"
11814     #include "mrecoi.inc"
11815     #include "mapoll.inc"
11816     #include "mmass.inc"
11817     #include "mpstor.inc"
11818     *KEND.
11819     DIMENSION D(*),LD(*),FM(*)
11820     SAVE
11821     MT=0
11822     IF(ID.EQ.8)MT=16
11823     IF(ID.EQ.9)MT=17
11824     IF(ID.EQ.12)MT=24
11825     C IFLG EQUAL TO ONE IMPLIES THE DIRECTION COSINES WERE
11826     C SELECTED ISOTROPICALLY IN THE LABORATORY COORDINATE SYSTEM
11827     C CALCULATE THE NEUTRON EXIT DIRECTIONAL COSINES
11828     POX = 0.0
11829     POY = 0.0
11830     POZ = 0.0
11831     DO 40 KN=1,INEU
11832     IF(IFLG.EQ.1) THEN
11833     CALL GTISO(UP,VP,WP)
11834     ELSE
11835     SINPSI=SQRT(1.0-FM(KN)**2)
11836     CALL AZIRN(SINETA,COSETA)
11837     STHETA=1.0-UOLD**2
11838     IF(STHETA)20,20,10
11839     10 STHETA=SQRT(STHETA)
11840     COSPHI=VOLD/STHETA
11841     SINPHI=WOLD/STHETA
11842     GO TO 30
11843     20 COSPHI=1.0
11844     SINPHI=0.0
11845     STHETA=0.0
11846     30 UP = UOLD*FM(KN)-COSETA*SINPSI*STHETA
11847     VP = VOLD*FM(KN)+UOLD*COSPHI*COSETA*SINPSI-SINPHI* SINPSI*
11848     + SINETA
11849     WP = WOLD*FM(KN)+UOLD*SINPHI*COSETA*SINPSI+COSPHI* SINPSI*
11850     + SINETA
11851     S=1.0/SQRT(UP*UP+VP*VP+WP*WP)
11852     UP=UP*S
11853     VP=VP*S
11854     WP=WP*S
11855     ENDIF
11856     EP = ENE(KN)
11857     C use ONLY first neutron for recoil calculation in order the ensure
11858     C correct energy spectrum of recoil nucleus
11859     IF(KN.EQ.1) THEN
11860     PP = SQRT(EP**2 + 2.0*EP*ZN)
11861     POX = POX + PP*UP
11862     POY = POY + PP*VP
11863     POZ = POZ + PP*WP
11864     ENDIF
11865     AGEP = AGE
11866     MTP = MT
11867     CALL STOPAR(IDNEU,NNEU)
11868     40 CONTINUE
11869     C CALCULATE AND SET THE RECOIL NUCLEUS EXIT PARAMETERS
11870     50 XR=X
11871     YR=Y
11872     ZR=Z
11873     WATER=WTBC
11874     NZR=KZ
11875     ZMP = FLOAT(KZ)
11876     AGER=AGE
11877     AGEP = AGE
11878     NCOLR=NCOL
11879     MTNR=MT
11880     MTP = MT
11881     AR = (AWR*AN) - FLOAT(INEU-1)*AN
11882     AMP = AR
11883     ENIR=EOLD
11884     UNIR=UOLD
11885     VNIR=VOLD
11886     WNIR=WOLD
11887     ENOR=E
11888     UNOR=U
11889     VNOR=V
11890     WNOR=W
11891     WTNR=WATE
11892     QR=Q
11893     C CALCULATE THE NEUTRON MOMENTUM BEFORE AND AFTER COLLISION
11894     C NEUTRON MOMENTUM BEFORE COLLISION (PI) EQUALS TOTAL MOMENTUM
11895     PI=SQRT(2.0*ZN*EOLD)
11896     C CALCULATE THE DIRECTIONAL MOMENTUM OF THE RECOIL NUCLEUS
11897     PIX=PI*UOLD
11898     PIY=PI*VOLD
11899     PIZ=PI*WOLD
11900     PRX = PIX - POX
11901     PRY = PIY - POY
11902     PRZ = PIZ - POZ
11903     C CALCULATE THE TOTAL MOMENTUM OF THE RECOIL NUCLEUS
11904     PR=SQRT(PRX**2+PRY**2+PRZ**2)
11905     C CALCULATE THE RECOIL NUCLEUS DIRECTIONAL COSINES
11906     UR=PRX/PR
11907     VR=PRY/PR
11908     WR=PRZ/PR
11909     UP = UR
11910     VP = VR
11911     WP = WR
11912     C CALCULATE THE RECOIL NUCLEUS EXIT ENERGY
11913     XM = AR*931.075E6
11914     ER= SQRT(PR**2 + XM**2) - XM
11915     EP = ER
11916     MTP = MT
11917     C IF MT=24, DO NOT STORE THE RECOIL HEAVY ION IN THE BANK
11918     IF(MT.EQ.24)RETURN
11919     C STORE THE RECOIL HEAVY ION IN THE RECOIL BANK
11920     CALL STOPAR(IDHEVY,NHEVY)
11921     RETURN
11922     END
11923     *CMZ : 1.01/00 01/06/93 09.05.16 by Christian Zeitnitz
11924     *-- Author :
11925     SUBROUTINE NGHEVY(D,LD,KZ,AWR,Q,MT)
11926     C THIS ROUTINE CALCULATES THE EXIT ENERGY AND DIRECTIONAL
11927     C COSINES FOR THE RECOIL NUCLEUS RESULTING FROM THE (N,G)
11928     C REACTION MT-102, AND STORES THE RECOIL NUCLEUS IN THE
11929     C HEAVY ION BANK. THE ENERGY AND DIRECTIONAL COSINES ARE
11930     C DETERMINED BY A MOMENTUM BALANCE IN THE LABORATORY SYSTEM
11931     C WITH THE PHOTONS MOMENTUM EQUAL TO ITS ENERGY.
11932     #include "minput.inc"
11933     #include "mconst.inc"
11934     #include "mnutrn.inc"
11935     #include "mrecoi.inc"
11936     #include "mapoll.inc"
11937     #include "mmass.inc"
11938     #include "mpstor.inc"
11939     #include "mgamma.inc"
11940     *KEND.
11941     DIMENSION D(*),LD(*)
11942     SAVE
11943     AR=AWR*AN+AN
11944     C CALCULATE THE TOTAL MOMENTUM BEFORE THE COLLISION
11945     C NEUTRON MOMENTUM BEFORE COLLISION (PI) EQUALS TOTAL MOMENTUM
11946     PI=SQRT(2.0*ZN*EOLD)
11947     C CALCULATE THE TOTAL MOMEMTUM OF THE EXIT PHOTON
11948     PO=EG*1.00E+06
11949     C CALCULATE THE DIRECTIONAL MOMENTUM OF THE RECOIL NUCLEUS
11950     PRX=PI*UOLD-PO*UG
11951     PRY=PI*VOLD-PO*VG
11952     PRZ=PI*WOLD-PO*WG
11953     C CALCULATE THE TOTAL MOMENTUM OF THE RECOIL NUCLEUS
11954     PR=SQRT(PRX**2+PRY**2+PRZ**2)
11955     C CALCULATE THE RECOIL NUCLEUS DIRECTIONAL COSINES
11956     UR=PRX/PR
11957     VR=PRY/PR
11958     WR=PRZ/PR
11959     C CALCULATE THE RECOIL NUCLEUS EXIT ENERGY
11960     ER=PR**2/(2*AR*9.31075E+08)
11961     C CALCULATE AND SET THE CHARGED PARTICLE EXIT PARAMETERS
11962     XR=X
11963     YR=Y
11964     ZR=Z
11965     WATER=WTBC
11966     NZR=KZ
11967     AGER=AGE
11968     NCOLR=NCOL
11969     MTNR=MT
11970     ENIR=EOLD
11971     UNIR=UOLD
11972     VNIR=VOLD
11973     WNIR=WOLD
11974     ENOR=0.0
11975     UNOR=0.0
11976     VNOR=0.0
11977     WNOR=0.0
11978     WTNR=0.0
11979     QR=Q
11980     C STORE THE RECOIL HEAVY ION IN THE RECOIL BANK
11981     EP = ER
11982     UP = UR
11983     VP = VR
11984     WP = WR
11985     AMP = AR
11986     ZMP = FLOAT(NZR)
11987     AGEP = AGE
11988     MTP = MT
11989     CALL STOPAR(IDHEVY,NHEVY)
11990     RETURN
11991     END
11992     *CMZ : 0.90/00 03/08/92 17.58.51 by Christian Zeitnitz
11993     *-- Author :
11994     SUBROUTINE NN2BOD(D,LD,KZ1,KZ2,A1,A2,Z1,Z2,ATAR,Q,MT)
11995     C THIS ROUTINE CALCULATES THE EXIT ENERGIES AND DIRECTIONAL
11996     C COSINES FOR THE CHARGED PARTICLE AND RECOIL NUCLEUS FOR
11997     C A TWO-BODY REACTION USING AN EVAPORATION SPECTRUM AND
11998     C MOMEMTUM BALANCE. IT ALSO SETS ALL EXIT PARAMETERS FOR
11999     C THE COLLISION PRODUCTS AND STORES THEM IN THE RECOIL BANK.
12000     C THE TWO BODY REACTION RESULTS FROM THE BREAK-UP OF A NUCLEUS
12001     C LEFT IN AN EXCITED STATE BY AN INELASTIC COLLISION OR A
12002     C N,2N REACTION (I.E. MT-24).
12003     #include "minput.inc"
12004     #include "mconst.inc"
12005     #include "mrecoi.inc"
12006     #include "mapoll.inc"
12007     #include "mmass.inc"
12008     #include "mpstor.inc"
12009     #include "mnutrn.inc"
12010     *KEND.
12011     DIMENSION D(*),LD(*)
12012     SAVE
12013     C TRANSFER THE RECOILING COMPOUND NUCLEUS PARAMETERS OUT OF
12014     C COMMON RECOIL FOR USE IN THE MOMENTUM BALANCE EQUATIONS
12015     ERCN=ER
12016     URCN=UR
12017     VRCN=VR
12018     WRCN=WR
12019     ARCN=AR
12020     NZRCN=NZR
12021     ZARCN=ARCN*9.31075E+08
12022     C CALCULATE THE COULOMB BARRIER (CB)
12023     CALL BARIER(KZ1,KZ2,A1,A2,CB)
12024     C CALCULATE THE CHARGED PARTICLE EXIT ENERGY (EX)
12025     CALL CEVAP1(EOLD,E,Q,ATAR,CB,EX)
12026     E1=EX+CB
12027     C ASSUME ISOTROPIC CHARGED PARTICLE EMISSION IN THE LABORATORY
12028     CALL GTISO(U1,V1,W1)
12029     C CALCULATE AND SET THE CHARGED PARTICLE EXIT PARAMETERS
12030     XR=X
12031     YR=Y
12032     ZR=Z
12033     WATER=WTBC
12034     NZR=KZ1
12035     AGER=AGE
12036     NCOLR=NCOL
12037     MTNR=MT
12038     AR=A1
12039     ENIR=EOLD
12040     UNIR=UOLD
12041     VNIR=VOLD
12042     WNIR=WOLD
12043     ENOR=E
12044     UNOR=U
12045     VNOR=V
12046     WNOR=W
12047     WTNR=WATE
12048     QR=Q
12049     UR=U1
12050     VR=V1
12051     WR=W1
12052     ER=E1
12053     C STORE THE CHARGED PARTICLE IN THE RECOIL BANK
12054     EP = ER
12055     UP = UR
12056     VP = VR
12057     WP = WR
12058     AGEP = AGE
12059     MTP = MT
12060     AMP = AR
12061     ZMP = FLOAT(NZR)
12062     CALL STOPAR(IDHEVY,NHEVY)
12063     C CALCULATE THE TOTAL MOMENTUM BEFORE THE COLLISION
12064     C COMPOUND NUCLEUS MOMENTUM BEFORE THE COLLISION (PI) EQUALS
12065     C THE TOTAL MOMENTUM
12066     PI=SQRT(2.0*ZARCN*ERCN)
12067     C CALCULATE THE TOTAL MOMEMTUM OF THE EXIT CHARGED PARTICLE
12068     PO=SQRT(2.0*Z1*E1)
12069     C CALCULATE THE DIRECTIONAL MOMENTUM OF THE RECOIL NUCLEUS
12070     PRX=PI*URCN-PO*U1
12071     PRY=PI*VRCN-PO*V1
12072     PRZ=PI*WRCN-PO*W1
12073     C CALCULATE THE TOTAL MOMENTUM OF THE RECOIL NUCLEUS
12074     PR=SQRT(PRX**2+PRY**2+PRZ**2)
12075     C CALCULATE THE RECOIL NUCLEUS DIRECTIONAL COSINES
12076     U2=PRX/PR
12077     V2=PRY/PR
12078     W2=PRZ/PR
12079     C CALCULATE THE RECOIL NUCLEUS EXIT ENERGY
12080     XM = A2 * 931.075E6
12081     E2 = SQRT(PR**2 + XM**2) - XM
12082     C CALCULATE AND SET THE CHARGED PARTICLE EXIT PARAMETERS
12083     XR=X
12084     YR=Y
12085     ZR=Z
12086     WATER=WTBC
12087     NZR=KZ2
12088     AGER=AGE
12089     NCOLR=NCOL
12090     MTNR=MT
12091     AR=A2
12092     ENIR=EOLD
12093     UNIR=UOLD
12094     VNIR=VOLD
12095     WNIR=WOLD
12096     ENOR=E
12097     UNOR=U
12098     VNOR=V
12099     WNOR=W
12100     WTNR=WATE
12101     QR=Q
12102     UR=U2
12103     VR=V2
12104     WR=W2
12105     ER=E2
12106     C STORE THE RECOIL HEAVY ION IN THE RECOIL BANK
12107     EP = ER
12108     UP = UR
12109     VP = VR
12110     WP = WR
12111     AGEP = AGE
12112     MTP = MT
12113     AMP = AR
12114     ZMP = FLOAT(NZR)
12115     CALL STOPAR(IDHEVY,NHEVY)
12116     RETURN
12117     END
12118     *CMZ : 0.94/04 18/03/93 22.56.07 by Christian Zeitnitz
12119     *-- Author :
12120     SUBROUTINE NSIGTA(E,JMED,TSIG,D,ISIGTS,LSIGT)
12121     C THIS ROUTINE DETERMINES THE MACROSCOPIC TOTAL
12122     C CROSS SECTION FOR MEDIA MED
12123     #include "mmicab.inc"
12124     *KEND.
12125     DIMENSION D(*),ISIGTS(*),LSIGT(*)
12126     CALL GTMED(JMED,MED)
12127     TSIG=0.0
12128     L1=LSIGT(MED)
12129     LS1=ISIGTS(MED)+LMOX3
12130     LEN=L1/2
12131     CALL TBSPLT(D(LS1),E,LEN,TSIG)
12132     RETURN
12133     END
12134     *CMZ : 1.01/04 10/06/93 14.43.48 by Christian Zeitnitz
12135     *-- Author :
12136     SUBROUTINE PARTXS(D,LD,E,SIGTOT,EP)
12137     C THIS ROUTINE SAMPLES FROM THE FILE 12 OR 13 PHOTON
12138     C PRODUCTION PARTIAL DISTRIBUTIONS TO OBTAIN THE EXIT
12139     C PHOTON ENERGY FROM A NEUTRON REACTION
12140     #include "minput.inc"
12141     *KEND.
12142     DIMENSION D(*),LD(*)
12143     SAVE
12144     C INITIALIZE THE VALUES USED IN THE SELECTION PROCESS
12145     C THE VALUE (II) IS A POINTER
12146     ITRY1=0
12147     10 R=FLTRNF(0)
12148     SUM=0.0
12149     NH=0
12150     NL=0
12151     II=0
12152     C SET THE NUMBER OF PARTIAL DISTRIBUTIONS (NK) AND THE NUMBER
12153     C OF POINTS PER PARTIAL DISTRIBUTION (NP)
12154     NK=LD(II+1)
12155     NP=LD(II+2)
12156     II=II+2
12157     C DETERMINE WHICH POINTS (NL) AND (NH) BOUND THE INCIDENT
12158     C NEUTRON ENERGY
12159     DO 20 N=1,NP
12160     IF(E.LE.D(II+N))GO TO 40
12161     20 CONTINUE
12162     C THE INCIDENT NEUTRON ENERGY IS GREATER THAN THE LAST ENERGY
12163     C POINT OF THE PARTIAL DISTRIBUTIONS, THEREFORE USE THE LAST
12164     C ENERGY POINT OF THE PARTIAL DISTRIBUTION TO SAMPLE FROM
12165     NH=NP
12166     II=II+NP
12167     DO 30 K=1,NK
12168     EP=D(II+1)
12169     LP=LD(II+2)
12170     A=D(II+3)
12171     LF=LD(II+4)
12172     IF(LP.EQ.2)EP=EP+(A/(A+1))*E
12173     II=II+4
12174     SIG=D(II+NH)
12175     SUM=SUM+SIG/SIGTOT
12176     IF(EP.EQ.0.0)GO TO 100
12177     IF(R.LE.SUM)GO TO 100
12178     II=II+NP
12179     30 CONTINUE
12180     GO TO 80
12181     40 IF(N.EQ.1)GO TO 60
12182     C THE INCIDENT NEUTRON ENERGY IS BOUNDED BY THE ENEGY POINTS
12183     C (NL) AND (NH) OF THE PARTIAL DISTRIBUTIONS, THEREFORE USE
12184     C LINEAR INTERPOLATION
12185     NH=N
12186     NL=N-1
12187     EH=D(II+NH)
12188     EL=D(II+NL)
12189     II=II+NP
12190     DO 50 K=1,NK
12191     EP=D(II+1)
12192     LP=LD(II+2)
12193     A=D(II+3)
12194     LF=LD(II+4)
12195     IF(LP.EQ.2)EP=EP+(A/(A+1))*E
12196     II=II+4
12197     SIG=D(II+NL)+(E-EL)*(D(II+NH)-D(II+NL))/(EH-EL)
12198     SUM=SUM+SIG/SIGTOT
12199     IF(EP.EQ.0.0)GO TO 100
12200     IF(R.LE.SUM)GO TO 100
12201     II=II+NP
12202     50 CONTINUE
12203     GO TO 80
12204     C THE INCIDENT NEUTRON ENERGY IS LESS THAN THE FIRST ENERGY
12205     C POINT OF THE PARTIAL DISTRIBUTIONS, THEREFORE USE THE FIRST
12206     C ENERGY POINT OF THE PARTIAL DISTRIBUTION TO SAMPLE FROM
12207     60 NL=N
12208     II=II+NP
12209     DO 70 K=1,NK
12210     EP=D(II+1)
12211     LP=LD(II+2)
12212     A=D(II+3)
12213     LF=LD(II+4)
12214     IF(LP.EQ.2)EP=EP+(A/(A+1))*E
12215     II=II+4
12216     SIG=D(II+NL)
12217     SUM=SUM+SIG/SIGTOT
12218     IF(EP.EQ.0.0)GO TO 100
12219     IF(R.LE.SUM)GO TO 100
12220     II=II+NP
12221     70 CONTINUE
12222     C retry with new R if SUM != 0
12223     80 IF(SUM.EQ.0.0) GOTO 90
12224     ITRY1 = ITRY1 + 1
12225     IF(ITRY1.LE.2) GOTO 10
12226     C no success set EP = 0
12227     90 EP = 0.0
12228     100 RETURN
12229     END
12230     *CMZ : 1.05/03 27/06/2001 18.21.00 by Christian Zeitnitz
12231     *-- Author :
12232     SUBROUTINE PHOTON(D,LD,IDICTS,LDICT,NTX,NTS,IGCBS,LGCB,
12233     + AWR,IGCBS2,LGCB2,LR,IGAMS,LGAM,QI,ID,IIN,LRI,SIGN)
12234     C THIS ROUTINE CONTROLS THE GENERATION AND STORAGE OF ALL
12235     C PHOTONS PRODUCED BY THE NEUTRON INTERACTIONS. WHERE DATA
12236     C PERMITS, THE PHOTON PRODUCED IS DIRECTLY COUPLED TO THE
12237     C NEUTRON REACTION OCCURING.
12238     #include "minput.inc"
12239     #include "mconst.inc"
12240     #include "mnutrn.inc"
12241     #include "mapoll.inc"
12242     #include "mcross.inc"
12243     #include "mpstor.inc"
12244     #include "mmicab.inc"
12245     *KEND.
12246     DIMENSION IDICTS(NNR,NNUC),LDICT(NNR,NNUC),NTX(*),NTS(*),
12247     + IGCBS(NGR,NNUC),LGCB(NGR,NNUC),AWR(*),IGCBS2(NGR,NNUC),
12248     + LGCB2(NGR,NNUC),LR(NQ,NNUC),IGAMS(*),LGAM(*),D(*),LD(*)
12249     SAVE
12250     C flag to mark call to SECEGY = 1 or PARTXS = 2 for EP CZ 13/8/92
12251     IEP = 0
12252     C INITIALIZE THE PHOTON ENERGY TO ZERO IN CASE NO PHOTON IS
12253     C CHOSEN (THIS IS NECESSARY BECAUSE OF ENDF INCONSISTENCY)
12254     EG=0.0
12255     C INITIALIZE THE PARAMETERS USED IN THE SELECTION PROCESS
12256     MT=0
12257     IMT=0
12258     NUMBG=0
12259     XSIG2=0.0
12260     XSIG=0.0
12261     SIGMT3=0.0
12262     SIGP=0.0
12263     AWRI=AWR(IIN)
12264     NNTX=NTX(IIN)
12265     NNTS=NTS(IIN)
12266     L=2*NNTX+2*NNTS
12267     C NO PHOTON DATA PRESENT (IF L=0)
12268     IF(L.EQ.0)GO TO 360
12269     LX=2*NNTX
12270     LS=LX+1
12271     C DETERMINE THE NEUTRON REACTION MT NUMBER
12272     IF(ID.EQ.8)MT=16
12273     IF(ID.EQ.9)MT=17
12274     IF(ID.EQ.10)MT=18
12275     IF(ID.EQ.11)MT=22
12276     IF(ID.EQ.12)MT=24
12277     IF(ID.EQ.13)MT=28
12278     IF((ID.GE.14).AND.(ID.LE.54))MT=51
12279     IF(ID.EQ.55)MT=102
12280     IF(ID.EQ.56)MT=103
12281     IF(ID.EQ.57)MT=104
12282     IF(ID.EQ.58)MT=105
12283     IF(ID.EQ.59)MT=106
12284     IF(ID.EQ.60)MT=107
12285     IF(ID.EQ.61)MT=108
12286     IF(ID.EQ.62)MT=109
12287     IF(ID.EQ.63)MT=111
12288     IF(ID.EQ.64)MT=112
12289     IF(ID.EQ.65)MT=113
12290     IF(ID.EQ.66)MT=114
12291     C DETERMINE WHICH DISCRETE INELASTIC SCATTERING LEVEL OCCURRED
12292     IF(MT.NE.51)GO TO 130
12293     IMT=ID-14
12294     MT=MT+IMT
12295     C RESET THE MT NUMBER IF AN LR-FLAG IS INVOLKED
12296     IF(LRI.EQ.22)MT=22
12297     IF(LRI.EQ.23)MT=23
12298     IF(LRI.EQ.28)MT=28
12299     C CHECK PHOTON PRODUCTION DICTIONARY TO SEE IF THERE IS PHOTON
12300     C DATA CORRESPONDING TO THE NEUTRON MT REACTION THAT OCCURRED
12301     DO 10 IX=1,NNTX
12302     MTG=LGCB(2*IX-1,IIN)
12303     IF(MTG.EQ.MT)GO TO 30
12304     10 CONTINUE
12305     20 IF(LRI.EQ.22)GO TO 190
12306     IF(LRI.EQ.23)GO TO 190
12307     IF(LRI.EQ.28)GO TO 190
12308     GO TO 70
12309     C PHOTON DATA FOUND CORRESPONDING TO NEUTRON MT REACTION
12310     30 L1=LGCB2(2*IX,IIN)
12311     IF(L1.EQ.0)GO TO 370
12312     LS1=IGCBS2(2*IX,IIN)+LMOX4
12313     LEN=L1/2
12314     CALL TBSPLT(D(LS1),EOLD,LEN,SIGP)
12315     IF(SIGP.EQ.0.0)GO TO 190
12316     LS2=IGCBS(2*IX,IIN)+LMOX2
12317     C DETERMINE EXIT PHOTON ENERGY (EP)
12318     CALL PARTXS(D(LS2),LD(LS2),EOLD,SIGP,EP)
12319     IEP = 2
12320     IF(EP.GT.0.0)GO TO 60
12321     C DISCRETE PHOTON ENERGY WAS NOT SELECTED (EP=0.0)
12322     C CHECK SECONDARY PHOTON DISTRIBUTION (FILE 15) FOR EP
12323     DO 40 IS=1,NNTS
12324     MTGS=LGCB(LX+2*IS-1,IIN)
12325     IF(MTGS.EQ.MT)GO TO 50
12326     40 CONTINUE
12327     C no file 15 found and EP=0 in PARTXS -> try MT=4 etc
12328     GO TO 20
12329     50 L1=LGCB(LX+2*IS,IIN)
12330     IF(L1.EQ.0)GO TO 380
12331     LS3=IGCBS(LX+2*IS,IIN)+LMOX2
12332     C DETERMINE EXIT PHOTON ENERGY (EP)
12333     CALL SECEGY(EP,D(LS3),EOLD,LD(LS3))
12334     IEP = 1
12335     C DETERMINE THE PHOTON MULTIPLICITY (YP)
12336     C RECALCULATE THE DENOMINATOR USED IN CALCULATING THE
12337     C PHOTON MULTIPLICITY TO ACCOUNT FOR THE LR-FLAGS
12338     60 IF(LRI.EQ.22)CALL LRNORM(D,LD,IDICTS,LDICT,LR,EOLD,MT,IIN,SIGN)
12339     IF(LRI.EQ.23)CALL LRNORM(D,LD,IDICTS,LDICT,LR,EOLD,MT,IIN,SIGN)
12340     IF(LRI.EQ.28)CALL LRNORM(D,LD,IDICTS,LDICT,LR,EOLD,MT,IIN,SIGN)
12341     YP=SIGP/SIGN
12342     GO TO 330
12343     C THE DISCRETE INELASTIC LEVEL PHOTON DATA WAS NOT FOUND
12344     C CHECK THE PHOTON PRODUCTION DICTIONARY TO SEE IF THERE IS
12345     C PHOTON DATA CORRESPONDING TO MT=4
12346     70 DO 80 IX=1,NNTX
12347     MTG=LGCB(2*IX-1,IIN)
12348     IF(MTG.EQ.4)GO TO 90
12349     80 CONTINUE
12350     GO TO 190
12351     C PHOTON DATA FOUND CORRESPONDING TO MT=4
12352     90 L1=LGCB2(2*IX,IIN)
12353     IF(L1.EQ.0)GO TO 370
12354     LS1=IGCBS2(2*IX,IIN)+LMOX4
12355     LEN=L1/2
12356     CALL TBSPLT(D(LS1),EOLD,LEN,SIGP)
12357     IF(SIGP.EQ.0.0)GO TO 190
12358     LS2=IGCBS(2*IX,IIN)+LMOX2
12359     C DETERMINE EXIT PHOTON ENERGY (EP)
12360     CALL PARTXS(D(LS2),LD(LS2),EOLD,SIGP,EP)
12361     IEP = 2
12362     IF(EP.GT.0.0)GO TO 120
12363     C DISCRETE PHOTON ENERGY WAS NOT SELECTED (EP=0.0)
12364     C CHECK SECONDARY PHOTON DISTRIBUTION (FILE 15) FOR EP
12365     DO 100 IS=1,NNTS
12366     MTGS=LGCB(LX+2*IS-1,IIN)
12367     IF(MTGS.EQ.4)GO TO 110
12368     100 CONTINUE
12369     GO TO 380
12370     110 L1=LGCB(LX+2*IS,IIN)
12371     IF(L1.EQ.0)GO TO 380
12372     LS3=IGCBS(LX+2*IS,IIN)+LMOX2
12373     C DETERMINE EXIT PHOTON ENERGY (EP)
12374     CALL SECEGY(EP,D(LS3),EOLD,LD(LS3))
12375     IEP = 1
12376     C DETERMINE THE PHOTON MULTIPLICITY (YP)
12377     C RECALCULATE THE DENOMINATOR USED IN CALCULATING THE
12378     C PHOTON MULTIPLICITY TO ACCOUNT FOR THE LR-FLAGS
12379     120 MT=4
12380     CALL LRNORM(D,LD,IDICTS,LDICT,LR,EOLD,MT,IIN,SIGNIS)
12381     YP=SIGP/SIGNIS
12382     GO TO 330
12383     C CHECK PHOTON PRODUCTION DICTIONARY TO SEE IF THERE IS PHOTON
12384     C DATA CORRESPONDING TO THE NEUTRON MT REACTION THAT OCCURRED
12385     130 DO 140 IX=1,NNTX
12386     MTG=LGCB(2*IX-1,IIN)
12387     IF(MTG.EQ.MT)GO TO 150
12388     140 CONTINUE
12389     GO TO 190
12390     C PHOTON DATA FOUND CORRESPONDING TO NEUTRON MT REACTION
12391     150 L1=LGCB2(2*IX,IIN)
12392     IF(L1.EQ.0)GO TO 370
12393     LS1=IGCBS2(2*IX,IIN)+LMOX4
12394     LEN=L1/2
12395     CALL TBSPLT(D(LS1),EOLD,LEN,SIGP)
12396     IF(SIGP.EQ.0.0)GO TO 190
12397     LS2=IGCBS(2*IX,IIN)+LMOX2
12398     C DETERMINE EXIT PHOTON ENERGY (EP)
12399     CALL PARTXS(D(LS2),LD(LS2),EOLD,SIGP,EP)
12400     IEP = 2
12401     IF(EP.GT.0.0)GO TO 180
12402     C DISCRETE PHOTON ENERGY WAS NOT SELECTED (EP=0.0)
12403     C CHECK SECONDARY PHOTON DISTRIBUTION (FILE 15) FOR EP
12404     DO 160 IS=1,NNTS
12405     MTGS=LGCB(LX+2*IS-1,IIN)
12406     IF(MTGS.EQ.MT)GO TO 170
12407     160 CONTINUE
12408     GO TO 380
12409     170 L1=LGCB(LX+2*IS,IIN)
12410     IF(L1.EQ.0)GO TO 380
12411     LS3=IGCBS(LX+2*IS,IIN)+LMOX2
12412     C DETERMINE EXIT PHOTON ENERGY (EP)
12413     CALL SECEGY(EP,D(LS3),EOLD,LD(LS3))
12414     IEP = 1
12415     C DETERMINE THE PHOTON MULTIPLICITY (YP)
12416     180 YP=SIGP/SIGN
12417     GO TO 330
12418     C NO PHOTON DATA WAS FOUND FOR THE PARTICULAR NEUTRON MT
12419     C REACTION OR FOR NEUTRON MT=4, THEREFORE CHECK THE PHOTON
12420     C PRODUCTION DICTIONARY TO SEE IF THERE IS PHOTON DATA
12421     C CORRESPONDING TO MT=3 (THE CATCH-ALL MT)
12422     190 DO 200 IX=1,NNTX
12423     MTG=LGCB(2*IX-1,IIN)
12424     IF(MTG.EQ.3)GO TO 210
12425     200 CONTINUE
12426     GO TO 360
12427     C PHOTON DATA FOUND CORRESPONDING TO MT=3
12428     210 L1=LGCB2(2*IX,IIN)
12429     IF(L1.EQ.0)GO TO 370
12430     LS1=IGCBS2(2*IX,IIN)+LMOX4
12431     LEN=L1/2
12432     CALL TBSPLT(D(LS1),EOLD,LEN,SIGP)
12433     IF(SIGP.EQ.0.0)GO TO 360
12434     LS2=IGCBS(2*IX,IIN)+LMOX2
12435     C DETERMINE EXIT PHOTON ENERGY (EP)
12436     CALL PARTXS(D(LS2),LD(LS2),EOLD,SIGP,EP)
12437     IEP = 2
12438     IF(EP.GT.0.0)GO TO 240
12439     C DISCRETE PHOTON ENERGY WAS NOT SELECTED (EP=0.0)
12440     C CHECK SECONDARY PHOTON DISTRIBUTION (FILE 15) FOR EP
12441     DO 220 IS=1,NNTS
12442     MTGS=LGCB(LX+2*IS-1,IIN)
12443     IF(MTGS.EQ.3)GO TO 230
12444     220 CONTINUE
12445     GO TO 380
12446     230 L1=LGCB(LX+2*IS,IIN)
12447     IF(L1.EQ.0)GO TO 380
12448     LS3=IGCBS(LX+2*IS,IIN)+LMOX2
12449     C DETERMINE EXIT PHOTON ENERGY (EP)
12450     CALL SECEGY(EP,D(LS3),EOLD,LD(LS3))
12451     IEP = 1
12452     C THE PHOTON WAS SELECTED FROM PHOTON DATA FOR MT=3
12453     C TO OBTAIN THE CORRECT MULTIPLICITY, THE NEUTRON CROSS
12454     C SECTION FOR MT=3 MUST BE ADJUSTED TO REPRESENT THE SAME
12455     C DATA AS MT=3 DOES IN THE PHOTON DATA
12456     240 ID=2
12457     C OBTAIN NEUTRON ELASTIC SCATTERING CROSS SECTION
12458     L1=LDICT(ID,IIN)
12459     IF(L1.EQ.0)GO TO 250
12460     LS1=IDICTS(ID,IIN)+LMOX2
12461     LEN=L1/2
12462     CALL TBSPLT(D(LS1),EOLD,LEN,XSIG2)
12463     C SUBTRACT THE ELASTIC SCATTERING CROSS SECTION FROM THE TOTAL
12464     C CROSS SECTION TO OBTAIN BASE NEUTRON MT=3 REACTION
12465     SIGMT3=SIGT-XSIG2
12466     GO TO 260
12467     250 SIGMT3=SIGT
12468     260 CONTINUE
12469     C SCAN THE PHOTON PRODUCTION DICTIONARY FOR ALL MT NUMBERS
12470     C NOT EQUAL TO MT=3
12471     DO 300 IX=1,NNTX
12472     MTG=LGCB(2*IX-1,IIN)
12473     IF(MTG.EQ.3)GO TO 300
12474     L1=LGCB2(2*IX,IIN)
12475     IF(L1.EQ.0)GO TO 370
12476     LS1=IGCBS2(2*IX,IIN)+LMOX4
12477     LEN=L1/2
12478     CALL TBSPLT(D(LS1),EOLD,LEN,SIGEX)
12479     C IF THE TOTAL PHOTON PRODUCTION CROSS SECTION IS ZERO AT
12480     C THE NEUTRON ENERGY, THEN THE NEUTRON CROSS SECTION SHOULD
12481     C NOT BE SUBTRACTED FROM MT3 TO MAINTAIN PROPER NORMALIZATION
12482     IF(SIGEX.EQ.0.0)GO TO 300
12483     C SET THE NEUTRON DICTIONARY ID NUMBER CORRESPONDING TO MTG
12484     IF((MTG.LT.51).OR.(MTG.GT.91))GO TO 270
12485     ID=14
12486     IMT3=MTG-51
12487     ID=ID+IMT3
12488     270 IF(MTG.EQ.4)ID=3
12489     IF(MTG.EQ.16)ID=8
12490     IF(MTG.EQ.17)ID=9
12491     IF(MTG.EQ.18)ID=10
12492     IF(MTG.EQ.22)ID=11
12493     IF(MTG.EQ.24)ID=12
12494     IF(MTG.EQ.28)ID=13
12495     IF(MTG.EQ.102)ID=55
12496     IF(MTG.EQ.103)ID=56
12497     IF(MTG.EQ.104)ID=57
12498     IF(MTG.EQ.105)ID=58
12499     IF(MTG.EQ.106)ID=59
12500     IF(MTG.EQ.107)ID=60
12501     IF(MTG.EQ.108)ID=61
12502     IF(MTG.EQ.109)ID=62
12503     IF(MTG.EQ.111)ID=63
12504     IF(MTG.EQ.112)ID=64
12505     IF(MTG.EQ.113)ID=65
12506     IF(MTG.EQ.114)ID=66
12507     C OBTAIN THE NEUTRON CROSS SECTION CORRESPONDING TO MTG AND
12508     C SUBTRACT IT OFF OF THE BASE NEUTRON MT=3 CROSS SECTION
12509     L1=LDICT(ID,IIN)
12510     IF(L1.EQ.0)GO TO 280
12511     LS1=IDICTS(ID,IIN)+LMOX2
12512     LEN=L1/2
12513     CALL TBSPLT(D(LS1),EOLD,LEN,XSIG)
12514     GO TO 290
12515     280 XSIG=0.0
12516     290 SIGMT3=SIGMT3-XSIG
12517     IF(SIGMT3.LE.0.0)GO TO 310
12518     300 CONTINUE
12519     C DETERMINE THE PHOTON MULTIPLICITY (YP)
12520     YP=SIGP/SIGMT3
12521     IF(YP.GE.100.0)GO TO 310
12522     GO TO 330
12523     310 CONTINUE
12524     C THIS SECTION OF CODING IS INCLUDED TO ACCOUNT FOR ANY
12525     C ENDF/B DATA INCONSISTENCY WHICH COULD YIELD A PHOTON OF
12526     C CONSIDERABLE WEIGHT. THE FOLLOWING CODING WILL SAMPLE THE
12527     C PHOTON WEIGHT FROM THE GENERAL PHOTON YIELD ARRAY AND
12528     C ADJUST THE WEIGHT TO PHOTONS PER NON-ELASTIC COLLISION.
12529     L1=LGAM(IIN)
12530     IF(L1.EQ.0)GO TO 320
12531     LS1=IGAMS(IIN)+LMOX2
12532     LEN=L1/2
12533     CALL TBSPLT(D(LS1),EOLD,LEN,YP)
12534     YP=(YP*SIGT)/(SIGT-XSIG2)
12535     GO TO 330
12536     320 YP=1.00
12537     C THE FOLLOWING SECTION OF CODING IS INCLUDED TO DISTRIBUTE
12538     C THE WEIGHT ENDF/B-V DATA MAY GIVE A PARTICULAR PHOTON.
12539     C FOR EXAMPLE, ENDF/B-V DATA MAY ASSIGN A MULITPLICITY OF
12540     C 75 TO A PARTICULAR PHOTON. BECAUSE SUCH A PHOTON COULD
12541     C CONSIDERABLY MODIFY THE RESULTS OF A DETECTOR RESPONSE, THE
12542     C MULTIPLICITY (PHOTON WEIGHT) IS DISTRIBUTED TO SEVERAL
12543     C PHOTONS (SPLITTING OF SORTS) WITH BOTH WEIGHT AND ENERGY
12544     C BEING CONSERVED. THIS RARELY OCCURS BUT IS NECESSARY.
12545     330 CONTINUE
12546     MGPAR = INT(FLOAT(MAXPAR)*0.7)
12547     C
12548     C for a photon multiplicity > 1.01 a poisson distribution is sampled
12549     C for the actually generated multiplicity (with mean YP)
12550     C
12551     IF(YP.GT.1.01) THEN
12552     C
12553     C use poisson distribution
12554     C
12555     340 CALL GPOISS(YP,NUMBG,1)
12556     IGTRY=IGTRY+1
12557     IF(NUMBG.GT.INT(4.*YP).OR.
12558     + NUMBG.GT.MGPAR.AND.IGTRY.LT.5) GOTO 340
12559     ELSE
12560     C YP <= 1.01
12561     C number of photons generated = INT(YP)
12562     C plus an additional photon if YP-INT(YP) > random number
12563     C CZ 21.8.95
12564     NUMBG = INT(YP)
12565     IF((YP-FLOAT(NUMBG)).GT.FLTRNF(0)) NUMBG = NUMBG + 1
12566     ENDIF
12567     NUMBG=MIN(NUMBG,MGPAR)
12568     C Allow 0 Photons to be generated
12569     IF(NUMBG.EQ.0) RETURN
12570     EPTOT = YP*EP
12571     EPSUM = 0.0
12572     DO 350 I=1,NUMBG
12573     C ASSUME ISOTROPIC PHOTON EMISSION IN THE LABORATORY SYSTEM
12574     CALL GTISO(U1,V1,W1)
12575     C SET THE PHOTON EXIT PARAMETERS
12576     UP=U1
12577     VP=V1
12578     WP=W1
12579     AGEP=AGE
12580     MTP=MT
12581     C re-sample photon energy depending on model used CZ 13.8.92
12582     IF(IEP.EQ.2) THEN
12583     CALL PARTXS(D(LS2),LD(LS2),EOLD,SIGP,EP1)
12584     IF(EP1.GT.0.0) EP=EP1
12585     ENDIF
12586     IF(IEP.EQ.1) THEN
12587     CALL SECEGY(EP1,D(LS3),EOLD,LD(LS3))
12588     IF(EP1.GT.0.0) EP=EP1
12589     ENDIF
12590     EPSUM = EPSUM+EP
12591     C check for energy conservation
12592     IF(EPSUM.GT.EPTOT.OR.I.EQ.NUMBG) EP = EPTOT-EPSUM+EP
12593     C STORE THE PHOTON
12594     CALL STOPAR(IDGAMA,NGAMA)
12595     C end photon production when energy is used up CZ 13.8.92
12596     IF(EPSUM.GT.EPTOT) GOTO 360
12597     350 CONTINUE
12598     360 RETURN
12599     370 WRITE(IOUT,10000)
12600     10000 FORMAT(' PHOTON: THE PHOTON PRODUCTION ',
12601     + 'CROSS SECTION DATA WAS NOT FOUND (L1=0)')
12602     GOTO 390
12603     380 WRITE(IOUT,10100)
12604     10100 FORMAT(' PHOTON: NO SECONDARY ENERGY ',
12605     + 'DISTRIBUTION WAS FOUND FOR THE CONTINUUM REACTION CHOSEN')
12606     390 WRITE(6,*) ' CALOR: ERROR in PHOTON ===> STOP '
12607     STOP
12608     END
12609     *CMZ : 1.05/03 27/06/2001 17.54.25 by Christian Zeitnitz
12610     *-- Author :
12611     C*********************************************************************
12612     FUNCTION RNMAXF(T)
12613     C T := most probable value of distribution
12614     C*********************************************************************
12615     DATA FF/0./
12616     SAVE FF,R1SQ,W,U
12617     U=EXPRNF(U)
12618     IF(FF) 30 ,10 ,30
12619     10 R1=FLTRNF(0)
12620     R2=FLTRNF(0)
12621     R1SQ=R1*R1
12622     R2SQ=R2*R2
12623     RSQ=R1SQ+R2SQ
12624     IF(RSQ-1.) 20 ,20 ,10
12625     20 W=EXPRNF(W)/RSQ
12626     FF=1.
12627     RNMAXF=(R2SQ*W+U)*T
12628     GO TO 40
12629     30 FF=0.
12630     RNMAXF=(R1SQ*W+U)*T
12631     40 RETURN
12632     END
12633     *CMZ : 1.04/00 02/02/95 09.26.27 by Christian Zeitnitz
12634     *-- Author :
12635     SUBROUTINE SECEGY(EX,FSE,E,IFSE)
12636     C THIS ROUTINE SELECTS A PARTIAL ENERGY DISTRIBUTION
12637     C TO SAMPLE THE EXIT ENERGY FROM
12638     #include "minput.inc"
12639     *KEND.
12640     DIMENSION FSE(*),IFSE(*)
12641     SAVE
12642     EX = 0.0
12643     IPP=1
12644     N=1
12645     IP=1
12646     R=FLTRNF(0)
12647     NK=IFSE(IP)
12648     PROB=0.
12649     10 IP=IP+1
12650     LF=IFSE(IP)
12651     IP=IP+1
12652     C TEMP FIX UP
12653     U=FSE(IP)
12654     IF(LF.EQ.11)U=FLOAT(IFSE(IP))
12655     IP=IP+1
12656     NR=IFSE(IP)
12657     IPR=IP
12658     IP=IP+1
12659     NP=IFSE(IP)
12660     IP=IP+2*NR
12661     20 CONTINUE
12662     DO 30 I=1,NP
12663     IP=IP+2
12664     C IF E IS LESS THAN THE LOWEST ENERGY OF THE MESH, THEN THE
12665     C PROBABILITY WILL EQUAL ZERO FOR SELECTING THAT DISTRIBUTION
12666     IF(E.LT.FSE(IP-1))GO TO 50
12667     30 CONTINUE
12668     C TRY THE NEXT PARTIAL DISTRIBUTION
12669     40 N=N+1
12670     IF(N.GT.NK)GO TO 170
12671     IF(LF.EQ.1)GO TO 100
12672     IF(LF.EQ.5)GO TO 120
12673     IF((LF.EQ.7).OR.(LF.EQ.9))GO TO 130
12674     GO TO 140
12675     50 IF(I.NE.1)GO TO 70
12676     IF(E+CADIG(E).LT.FSE(IP-1))GO TO 60
12677     E=E+CADIG(E)
12678     IP=IP-2
12679     GO TO 20
12680     60 CONTINUE
12681     IP=IP+(NP-1)*2
12682     GO TO 40
12683     C DETERMINE THE INTERPOLATING SCHEME
12684     70 CONTINUE
12685     DO 80 J=1,NR
12686     J1=IPR+2*J
12687     IF(I.LE.IFSE(J1))GO TO 90
12688     80 CONTINUE
12689     90 IS=IFSE(J1+1)
12690     CALL INTERP(E,P,FSE(IP-3),FSE(IP-2),FSE(IP-1),FSE(IP),IS)
12691     PROB=PROB+P
12692     IF(R.LE.PROB)GO TO 150
12693     IP=IP+2*(NP-I)
12694     GO TO 40
12695     C SKIP THE DATA FOR LF EQUAL ONE
12696     100 IP=IP+1
12697     NR=IFSE(IP)
12698     NE=IFSE(IP+1)
12699     IP=IP+2*NR+1
12700     DO 110 I=1,NE
12701     IP=IP+2
12702     NR=IFSE(IP)
12703     IP=IP+1
12704     NP=IFSE(IP)
12705     IP=IP+2*NR+2*NP
12706     110 CONTINUE
12707     GO TO 10
12708     C SKIP THE DATA FOR LF EQUAL FIVE
12709     120 IP=IP+1
12710     NR=IFSE(IP)
12711     NE=IFSE(IP+1)
12712     IP=IP+2*NR+1
12713     IP=IP+2*NE
12714     IP=IP+1
12715     NR=IFSE(IP)
12716     NF=IFSE(IP+1)
12717     IP=IP+2*NF+2*NR+1
12718     GO TO 10
12719     C SKIP THE DATA FOR LF EQUAL SEVEN, AND LF EQUAL NINE
12720     130 IP=IP+1
12721     NR=IFSE(IP)
12722     NE=IFSE(IP+1)
12723     IP=IP+2*NR+1
12724     IP=IP+2*NE
12725     GO TO 10
12726     C SKIP THE DATA FOR LF EQUAL ELEVEN
12727     140 IP=IP+1
12728     NR=IFSE(IP)
12729     NE=IFSE(IP+1)
12730     IP=IP+2*NR+1
12731     IP=IP+2*NE
12732     IP=IP+1
12733     NR=IFSE(IP)
12734     NE=IFSE(IP+1)
12735     IP=IP+2*NR+1
12736     IP=IP+2*NE
12737     GO TO 10
12738     C NOW SELECT THE SECONDARY ENERGY FROM THE CHOSEN DISTRIBUTION
12739     150 IP=IP+2*(NP-I)
12740     160 CONTINUE
12741     IF(LF.EQ.1)CALL SECLF1(FSE(IP+1),IFSE(IP+1),EX,U,E)
12742     IF(LF.EQ.5)CALL SECLF5(FSE(IP+1),IFSE(IP+1),EX,U,E)
12743     IF(LF.EQ.7)CALL SECLF7(FSE(IP+1),IFSE(IP+1),EX,U,E)
12744     IF(LF.EQ.9)CALL SECLF9(FSE(IP+1),IFSE(IP+1),EX,U,E)
12745     IF(LF.EQ.11)CALL SECL11(FSE(IP+1),IFSE(IP+1),EX,U,E)
12746     RETURN
12747     170 CONTINUE
12748     C TEMP CARD
12749     LF=IFSE(IPP+1)
12750     U=FSE(IPP+2)
12751     IF(LF.EQ.11)U=FLOAT(IFSE(IPP+2))
12752     NR=IFSE(IPP+3)
12753     NP=IFSE(IPP+4)
12754     IP=2*NR+2*NP+5
12755     GO TO 160
12756     END
12757     *CMZ : 1.04/00 02/02/95 09.23.46 by Christian Zeitnitz
12758     *-- Author :
12759     SUBROUTINE SECL11(FSE,IFSE,EX,U,E)
12760     C THIS ROUTINE SAMPLES AN EXIT ENERGY FROM
12761     C AN ENERGY DEPENDENT WATT SPECTRUM
12762     #include "minput.inc"
12763     *KEND.
12764     DIMENSION FSE(*),IFSE(*)
12765     SAVE
12766     IP=1
12767     NR=IFSE(IP)
12768     NE=IFSE(IP+1)
12769     IP=2*NR+1
12770     EMAX=E-U
12771     C DETERMINE A
12772     DO 10 I=1,NE
12773     IP=IP+2
12774     IF(E.LE.FSE(IP))GO TO 20
12775     10 CONTINUE
12776     GO TO 30
12777     20 IF(I.EQ.1)GO TO 40
12778     C DETERMINE THE INTERPOLATING SCHEME
12779     CALL INTSCH(IFSE,I,IS,NR)
12780     E1=FSE(IP-2)
12781     E2=FSE(IP)
12782     T1=FSE(IP-1)
12783     T2=FSE(IP+1)
12784     CALL INTERP(E,A,E1,T1,E2,T2,IS)
12785     GO TO 50
12786     C INCIDENT ENERGY IS ABOVE THE LAST INCIDENT ENERGY GIVEN
12787     C USE THE LAST DISTRIBUTION
12788     30 IP=2+2*NR+2*NE
12789     A=FSE(IP)
12790     GO TO 50
12791     C INCIDENT ENERGY IS BELOW THE FIRST INCIDENT ENERGY GIVEN
12792     C USE THE FIRST DISTRIBUTION
12793     40 A=FSE(4+2*NR)
12794     C DETERMINE B
12795     50 IP=3+2*NR+2*NE
12796     NR1=IFSE(IP)
12797     NF=IFSE(IP+1)
12798     IP=2*NR+2*NE+2*NR1+3
12799     DO 60 I=1,NF
12800     IP=IP+2
12801     IF(E.LE.FSE(IP))GO TO 70
12802     60 CONTINUE
12803     GO TO 80
12804     70 IF(I.EQ.1)GO TO 90
12805     CALL INTSCH(IFSE(2*NR+2*NE+3),I,IS,NR1)
12806     E1=FSE(IP-2)
12807     E2=FSE(IP)
12808     T1=FSE(IP-1)
12809     T2=FSE(IP+1)
12810     CALL INTERP(E,B,E1,T1,E2,T2,IS)
12811     GO TO 100
12812     80 IP=2*NR+2*NF+2*NE+2*NR1+4
12813     B=FSE(IP)
12814     GO TO 100
12815     90 B=FSE(IP+1)
12816     C SELECT THE EXIT ENERGY FROM THE WATT SPECTRUM
12817     100 EX=FISRNF(A,B)
12818     IF(EX.LE.EMAX)RETURN
12819     EX=EMAX
12820     RETURN
12821     END
12822     *CMZ : 1.01/07 24/06/93 21.32.11 by Christian Zeitnitz
12823     *-- Author :
12824     SUBROUTINE SECLF1(FSE,IFSE,EX,U,E)
12825     C THIS ROUTINE SAMPLES AN EXIT ENERGY FROM
12826     C A TABULATED DISTRIBUTION
12827     #include "minput.inc"
12828     *KEND.
12829     DIMENSION FSE(*),IFSE(*)
12830     SAVE
12831     C=0.
12832     IP=1
12833     NRE=IFSE(IP)
12834     NE=IFSE(IP+1)
12835     IP=IP+2*NRE+1
12836     C FIND THE TWO INCIDENT ENERGY DISTRIBUTIONS THAT BOUND E
12837     C INCIDENT ENERGY IS BELOW THE FIRST INCIDENT ENERGY GIVEN
12838     C USE THE FIRST DISTRIBUTION
12839     IP=IP+1
12840     IE=1
12841     E1=FSE(IP)
12842     IP1=IP
12843     IF(E.GT.E1)GO TO 10
12844     IPR=IP+1
12845     NR=IFSE(IPR)
12846     NP=IFSE(IPR+1)
12847     GO TO 50
12848     10 IP=IP+1
12849     IPR1=IP
12850     NP1=IFSE(IP+1)
12851     IP=IP+2*IFSE(IPR1)+1
12852     IP=IP+2*NP1
12853     20 IE=IE+1
12854     IP=IP+1
12855     C INCIDENT ENERGY IS ABOVE THE LAST INCIDENT ENERGY GIVEN
12856     C USE THE LAST DISTRIBUTION
12857     IF(IE.GT.NE)GO TO 40
12858     E2=FSE(IP)
12859     IF(E.LE.E2)GO TO 30
12860     E1=E2
12861     IP1=IP
12862     IP=IP+1
12863     IPR1=IP
12864     NP1=IFSE(IP+1)
12865     IP=IP+2*IFSE(IPR1)+1
12866     IP=IP+2*NP1
12867     GO TO 20
12868     30 IP2=IP
12869     IP=IP+1
12870     IPR2=IP
12871     NP2=IFSE(IP+1)
12872     IP=IP+2*IFSE(IPR2)+1
12873     C DETERMINE THE INTERPOLATING SCHEME
12874     CALL INTSCH(IFSE,IE,IS,NRE)
12875     C SELECT THE DISTRIBUTION TO SAMPLE FROM
12876     R=FLTRNF(0)
12877     C INTERPOLATION SCHEMES OF 1 (CONSTANT) OR 2 (LINEAR) ALLOWED
12878     IF(IS.GT.2)GO TO 110
12879     PROB=(E2-E)/(E2-E1)
12880     IF(IS.EQ.1)PROB=1.0
12881     IF(R.LE.PROB)GO TO 40
12882     C SELECT FROM THE SECOND DISTRIBUTION
12883     NP=NP2
12884     IP=IP2
12885     IPR=IPR2
12886     GO TO 50
12887     C SELECT FROM THE FIRST DISTRIBUTION
12888     C OR FROM THE LAST INCIDENT ENERGY
12889     40 NP=NP1
12890     IP=IP1
12891     IPR=IPR1
12892     C SELECT THE EXIT ENERGY FROM THE TABULATED DISTRIBUTION
12893     50 CONTINUE
12894     ITRY = 0
12895     60 CONTINUE
12896     PROB=0.
12897     R=FLTRNF(0)
12898     NR=2*IFSE(IPR)+1
12899     DO 90 I=1,NP
12900     CALL INTSCH(IFSE(IPR),NP,IS,IFSE(IPR))
12901     N=IP+NR+1+2*I
12902     PROB1=PROB
12903     IF(I.EQ.1)GO TO 90
12904     IF(IS.EQ.1)GO TO 70
12905     IF(IS.GT.2)GO TO 110
12906     PROB=PROB+(FSE(N)+FSE(N-2))*(FSE(N-1)-FSE(N-3))/2.
12907     GO TO 80
12908     70 PROB=PROB+FSE(N-2)*(FSE(N-1)-FSE(N-3))
12909     80 IF(R.LE.PROB)GO TO 100
12910     90 CONTINUE
12911     ITRY = ITRY + 1
12912     IF(ITRY.LT.5) GOTO 60
12913     IF(R.LT..998)GO TO 120
12914     100 EX=FSE(N-3)+(R-PROB1)*(FSE(N-1)-FSE(N-3))/(PROB-PROB1)
12915     RETURN
12916     110 WRITE(IOUT,10000)IS
12917     10000 FORMAT(' MICAP: INTERPOLATION SCHEME=',I3,' IN SECLF1')
12918     GOTO 130
12919     120 WRITE(IOUT,10100)R,PROB
12920     10100 FORMAT(' MICAP: EXIT ENERGY NOT SELECTED IN SECLF1',1P2E13.5)
12921     130 WRITE(6,*) ' CALOR: ERROR in SECLF1 =====> STOP '
12922     STOP
12923     END
12924     *CMZ : 1.04/00 02/02/95 09.24.15 by Christian Zeitnitz
12925     *-- Author :
12926     SUBROUTINE SECLF5(FSE,IFSE,EX,U,E)
12927     C THIS ROUTINE SAMPLES AN EXIT ENERGY FROM
12928     C A GENERAL EVAPORATION SPECTRUM
12929     #include "minput.inc"
12930     *KEND.
12931     DIMENSION FSE(*),IFSE(*)
12932     SAVE
12933     C DETERMINE THETA
12934     IP=1
12935     NR=IFSE(IP)
12936     NE=IFSE(IP+1)
12937     IP=2*NR+IP
12938     EMAX=E-U
12939     R=FLTRNF(0)
12940     DO 10 I=1,NE
12941     IP=IP+2
12942     IF(E.LE.FSE(IP))GO TO 20
12943     10 CONTINUE
12944     GO TO 80
12945     20 IF(I.EQ.1)GO TO 90
12946     C DETERMINE THE INTERPOLATING SCHEME
12947     CALL INTSCH(IFSE,I,IS,NR)
12948     E2=FSE(IP)
12949     E1=FSE(IP-2)
12950     CALL INTERP(E,THETA,E1,FSE(IP-1),E2,FSE(IP+1),IS)
12951     IP=IP+2+(NE-I)*2
12952     C DETERMINE X
12953     30 NF=IFSE(IP+1)
12954     NR=IFSE(IP)
12955     IPR=IP
12956     IP=IP+1+2*NR
12957     PROB=0.
12958     DO 60 I=1,NF
12959     N=IP+2*I
12960     PROB1=PROB
12961     CALL INTSCH(IFSE(IPR),I,IS,NR)
12962     IF(I.EQ.1)GO TO 60
12963     IF(IS.EQ.1)GO TO 40
12964     IF(IS.GT.2)GO TO 100
12965     PROB=PROB+(FSE(N)+FSE(N-2))*(FSE(N-1)-FSE(N-3))/2.
12966     GO TO 50
12967     40 PROB=PROB+FSE(N-2)*(FSE(N-1)-FSE(N-3))
12968     50 CONTINUE
12969     IF(R.LE.PROB)GO TO 70
12970     60 CONTINUE
12971     70 X=FSE(N-3)+(R-PROB1)*(FSE(N-1)-FSE(N-3))/(PROB-PROB1)
12972     C SELECT THE EXIT ENERGY FROM THE GENERAL EVAPORATION SPECTRUM
12973     EX=THETA*X
12974     IF(EX.LE.EMAX)RETURN
12975     EX=EMAX
12976     RETURN
12977     C INCIDENT ENERGY IS ABOVE THE LAST INCIDENT ENERGY GIVEN
12978     C USE THE LAST DISTRIBUTION
12979     80 THETA=FSE(IP+1)
12980     IP=IP+2
12981     GO TO 30
12982     C INCIDENT ENERGY IS BELOW THE FIRST INCIDENT ENERGY GIVEN
12983     C USE THE FIRST DISTRIBUTION
12984     90 THETA=FSE(IP+1)
12985     IP=IP+2*(NE-I)+2
12986     GO TO 30
12987     100 WRITE(IOUT,10100)IS
12988     10100 FORMAT(' MICAP: INTERPOLATION SCHEME=',I3,' IN SECLF5')
12989     WRITE(6,*) ' CALOR: ERROR in SECLF5 =====> STOP '
12990     STOP
12991     END
12992     *CMZ : 1.04/00 02/02/95 09.24.44 by Christian Zeitnitz
12993     *-- Author :
12994     SUBROUTINE SECLF7(FSE,IFSE,EX,U,E)
12995     C THIS ROUTINE SAMPLES AN EXIT ENERGY FROM
12996     C A SIMPLE FISSION SPECTRUM
12997     #include "minput.inc"
12998     *KEND.
12999     DIMENSION FSE(*),IFSE(*)
13000     SAVE
13001     C DETERMINE THETA
13002     IP=1
13003     EMAX=E-U
13004     NR=IFSE(IP)
13005     NE=IFSE(IP+1)
13006     IP=2*NR+1
13007     DO 10 I=1,NE
13008     IP=IP+2
13009     IF(E.LE.FSE(IP))GO TO 20
13010     10 CONTINUE
13011     GO TO 30
13012     20 IF(I.EQ.1)GO TO 40
13013     C DETERMINE THE INTERPOLATING SCHEME
13014     CALL INTSCH(IFSE,I,IS,NR)
13015     E1=FSE(IP-2)
13016     E2=FSE(IP)
13017     CALL INTERP(E,THETA,E1,FSE(IP-1),E2,FSE(IP+1),IS)
13018     GO TO 50
13019     C INCIDENT ENERGY IS ABOVE THE LAST INCIDENT ENERGY GIVEN
13020     C USE THE LAST DISTRIBUTION
13021     30 THETA=FSE(IP+1)
13022     GO TO 50
13023     C INCIDENT ENERGY IS BELOW THE FIRST INCIDENT ENERGY GIVEN
13024     C USE THE FIRST DISTRIBUTION
13025     40 THETA=FSE(IP+1)
13026     C SELECT THE EXIT ENERGY FROM THE FISSION SPECTRUM
13027     50 R1=FLTRNF(0)
13028     R2=FLTRNF(0)
13029     S=R1**2+R2**2
13030     IF(S.GT.1.)GO TO 50
13031     TAU=(-ALOG(S)/S)*(R1**2)
13032     R=FLTRNF(0)
13033     W=-ALOG(R)+TAU
13034     EX=THETA*W
13035     IF(EX.LE.EMAX)RETURN
13036     EX=EMAX
13037     RETURN
13038     END
13039     *CMZ : 1.04/00 02/02/95 09.25.31 by Christian Zeitnitz
13040     *-- Author :
13041     SUBROUTINE SECLF9(FSE,IFSE,EX,U,E)
13042     C THIS ROUTINE SAMPLES AN EXIT ENERGY FROM
13043     C AN EVAPORATION SPECTRUM
13044     #include "minput.inc"
13045     *KEND.
13046     DIMENSION FSE(*),IFSE(*)
13047     SAVE
13048     C DETERMINE THETA
13049     IP=1
13050     EMAX=E-U
13051     NR=IFSE(IP)
13052     NE=IFSE(IP+1)
13053     IP=2*NR+1
13054     DO 10 I=1,NE
13055     IP=IP+2
13056     IF(E.LE.FSE(IP))GO TO 20
13057     10 CONTINUE
13058     GO TO 30
13059     20 IF(I.EQ.1)GO TO 40
13060     C DETERMINE THE INTERPOLATING SCHEME
13061     CALL INTSCH(IFSE,I,IS,NR)
13062     E1=FSE(IP-2)
13063     E2=FSE(IP)
13064     CALL INTERP(E,THETA,E1,FSE(IP-1),E2,FSE(IP+1),IS)
13065     GO TO 50
13066     C INCIDENT ENERGY IS ABOVE THE LAST INCIDENT ENERGY GIVEN
13067     C USE THE LAST DISTRIBUTION
13068     30 THETA=FSE(IP+1)
13069     GO TO 50
13070     C INCIDENT ENERGY IS BELOW THE FIRST INCIDENT ENERGY GIVEN
13071     C USE THE FIRST DISTRIBUTION
13072     40 THETA=FSE(IP+1)
13073     C SELECT THE EXIT ENERGY FROM THE EVAPORATION SPECTRUM
13074     50 R1=FLTRNF(0)
13075     R2=FLTRNF(0)
13076     W=-ALOG(R1*R2)
13077     EX=THETA*W
13078     IF(EX.LE.EMAX)RETURN
13079     EX=EMAX
13080     RETURN
13081     END
13082     *CMZ : 1.01/04 10/06/93 14.43.49 by Christian Zeitnitz
13083     *-- Author : Christian Zeitnitz 03/08/92
13084     SUBROUTINE STOPAR(ID,NP)
13085     C store particle in MPSTOR common
13086     #include "mconst.inc"
13087     #include "mpstor.inc"
13088     #include "minput.inc"
13089     *KEND.
13090     C
13091     NPSTOR = NPSTOR + 1
13092     IF(NPSTOR.GT.MAXPAR) THEN
13093     WRITE(IOUT,'('' MICAP : Cant store particle; bank full'', '
13094     + //' '' ID='',I3,'' NPSTOR='',I5)') ID,NPSTOR
13095     NPSTOR = NPSTOR - 1
13096     ELSE
13097     EN(NPSTOR) = EP
13098     UN(NPSTOR) = UP
13099     VN(NPSTOR) = VP
13100     WN(NPSTOR) = WP
13101     AMN(NPSTOR) = AMP
13102     ZMN(NPSTOR) = ZMP
13103     AGEN(NPSTOR) = AGEP
13104     MTN(NPSTOR) = MTP
13105     IDN(NPSTOR) = ID
13106     NP = NP + 1
13107     ENDIF
13108     RETURN
13109     END
13110     *CMZ : 0.92/00 02/12/92 16.02.33 by Christian Zeitnitz
13111     *-- Author :
13112     SUBROUTINE TBSPLT(A,E,NP,Y)
13113     C THIS ROUTINE DETERMINES A CROSS SECTION AT A GIVEN
13114     C ENERGY FROM A CROSS SECTION VERSUS ENERGY TABLE USING
13115     C A TABLE SPLITTING METHOD
13116     DIMENSION A(1)
13117     SAVE
13118     IPP=1
13119     IF(E.LE.A(1))GO TO 40
13120     IF(E.GE.A(2*NP-1))GO TO 50
13121     INDXH=NP
13122     INDXL=0
13123     10 IF(INDXL+1.EQ.INDXH)GO TO 30
13124     J=(INDXH+INDXL)/2
13125     N=2*J-1
13126     IF(E.LE.A(N))GO TO 20
13127     INDXL=J
13128     GO TO 10
13129     20 INDXH=J
13130     GO TO 10
13131     30 N=2*INDXH-1
13132     Y=A(N-1)+(E-A(N-2))*(A(N+1)-A(N-1))/(A(N)-A(N-2))
13133     RETURN
13134     40 Y=A(IPP+1)
13135     RETURN
13136     50 Y=A(2*NP)
13137     RETURN
13138     END
13139     *CMZ : 1.05/03 27/06/2001 18.34.49 by Christian Zeitnitz
13140     *-- Author :
13141     SUBROUTINE THRMSC(D,LD,XTHRMS,ITHRMS,LTHRM,E,U,V,W,TEMP,FM,AWR,
13142     + IIN,IFLG,IOUT)
13143     C THIS ROUTINE CONTROLS SELECTION OF THE NEUTRON EXIT ENERGY
13144     C IN THE THERMAL DATA RANGE
13145     #include "mupsca.inc"
13146     *KEND.
13147     DIMENSION D(*),LD(*),XTHRMS(*),ITHRMS(*),LTHRM(*),AWR(*)
13148     REAL HMASSN/0.5044905/,SPI/1.1283792/
13149     C HMASSN EQUALS ONE-HALF THE NEUTRON MASS
13150     C SPI EQUALS TWO DIVIDED BY THE SQUARE ROOT OF PI
13151     C CONVERT TEMPERATURE FROM DEGREES KELVIN TO EV
13152     DATA BK/8.6167E-5/
13153     SAVE
13154     C
13155     TDK=BK*TEMP
13156     AAWR=AWR(IIN)
13157     IFLG=0
13158     NE=ITHRMS(IIN)
13159     IF(NE.LE.0)GO TO 10
13160     EO=E
13161     NP7=ITHRMS(IIN+1)
13162     NB7=ITHRMS(IIN+2)
13163     CT=ITHRMS(IIN+3)
13164     LENMD=ITHRMS(IIN+4)
13165     N=NB7*NE
13166     CALL THRSEL(NE,NP7,NB7,E,EOUT,FM,CT,XTHRMS(IIN+5),
13167     + XTHRMS(IIN+5+NE),XTHRMS(IIN+5+NE+NP7),
13168     + XTHRMS(IIN+5+NE+NP7+NB7),
13169     + XTHRMS(IIN+5+2*NE+NP7+NB7),XTHRMS(IIN+5+2*NE+NP7+NB7+N),
13170     + XTHRMS(IIN+5+2*NE+NP7+NB7+N+LENMD),AWR,IIN,
13171     + ITHRMS(IIN+5+2*NE+NP7+NB7+N+LENMD+NP7*NB7),
13172     + ITHRMS(IIN+5+2*NE+NP7+NB7+N),IOUT)
13173     E=EOUT
13174     C IFLG EQUAL TO ONE IMPLIES (FM) IN LABORATORY SYSTEM
13175     IFLG=1
13176     RETURN
13177     C FREE GAS MODEL
13178     10 CONTINUE
13179     C SPD IS THE SPEED OF THE INCIDENT NEUTRON
13180     SPD=SQRT(E/HMASSN)
13181     TAUN=SPI*SQRT(2.0*TDK/AAWR)
13182     PTEST=SPD/(SPD+TAUN)
13183     C UO, VO, AND WO ARE THE VELOCITY COMPONENTS OF THE INCIDENT
13184     C NEUTRON IN TERMS OF THE NEUTRON SPEED
13185     UO=SPD*U
13186     VO=SPD*V
13187     WO=SPD*W
13188     20 CONTINUE
13189     IF(PTEST.GT.FLTRNF(0))GO TO 30
13190     ETA=-ALOG(FLTRNF(0)*FLTRNF(0))*TDK
13191     GO TO 40
13192     30 CONTINUE
13193     ETA=RNMAXF(TDK)
13194     40 CONTINUE
13195     C ERFGM IS THE INITIAL ENERGY OF THE TARGET NUCLEUS
13196     ERFGM=ETA
13197     C ETA IS THE SPEED OF THE TARGET NUCLEUS
13198     ETA=SQRT(2.0*ETA/AAWR)
13199     C UN, VN, AND WN ARE THE VELOCITY COMPONENTS OF THE TARGET
13200     C NUCLEUS IN TERMS OF THE TARGET NUCLEUS SPEED
13201     CALL GTISO(UN,VN,WN)
13202     UN=UN*ETA
13203     VN=VN*ETA
13204     WN=WN*ETA
13205     VRELSQ=(UO-UN)**2+(VO-VN)**2+(WO-WN)**2
13206     F2=FLTRNF(0)**2
13207     V2=VRELSQ/(SPD+ETA)**2
13208     IF(F2.GT.V2)GO TO 20
13209     VREL=SQRT(VRELSQ)
13210     ALPHA=1.0/(AAWR+1.0)
13211     BETA=1.0-ALPHA
13212     CALL GTISO(UA,VA,WA)
13213     UO=UO*ALPHA+BETA*(UN+VREL*UA)
13214     VO=VO*ALPHA+BETA*(VN+VREL*VA)
13215     WO=WO*ALPHA+BETA*(WN+VREL*WA)
13216     SPDSQ=UO*UO+VO*VO+WO*WO
13217     C E IS THE EXIT ENERGY OF THE NEUTRON
13218     E=HMASSN*SPDSQ
13219     SPD=1.0/SQRT(SPDSQ)
13220     FM=(U*UO+V*VO+W*WO)*SPD
13221     C U, V, AND W ARE THE EXIT NEUTRON DIRECTION COSINES
13222     U=UO*SPD
13223     V=VO*SPD
13224     W=WO*SPD
13225     C IFLG EQUAL TO TWO IMPLIES (U,V,W) IN LABORATORY SYSTEM
13226     IFLG=2
13227     RETURN
13228     END
13229     *CMZ : 1.01/04 10/06/93 14.43.49 by Christian Zeitnitz
13230     *-- Author :
13231     SUBROUTINE THRSEL(NE,NP7,NB7,E,EOUT,FM,TDK,ETH,ALPHA,BETA,W,
13232     + PMUPS,PMDS,F,AWR,IIN,IPTMD,IPMDS,IOUT)
13233     C THIS ROUTINE SELECTS THE EXIT ENERGY AND SCATTERING ANGLE
13234     C FROM S(ALPHA,BETA) DATA TABLES
13235     DIMENSION ETH(*),ALPHA(*),BETA(*),ABETA2(2),PMDS(*),
13236     + IPTMD(NE),W(NE),IPMDS(*),PMUPS(NB7,NE),F(NP7,NB7),AWR(*)
13237     SAVE
13238     C
13239     AAWR=AWR(IIN)
13240     DO 10 IE=1,NE
13241     IF(E.LT.ETH(IE))GO TO 20
13242     10 CONTINUE
13243     INDX=NE
13244     GO TO 30
13245     20 INDX=IE
13246     IF(INDX.EQ.1)GO TO 30
13247     R=FLTRNF(0)
13248     DELE=(ETH(INDX)-E)/(ETH(INDX)-ETH(INDX-1))
13249     DELEN=DELE
13250     GO TO 40
13251     30 DELEN=1.0
13252     INDX=2
13253     40 PROB=DELEN*W(INDX-1)+(1.0-DELEN)*W(INDX)
13254     IF(R.LE.PROB)GO TO 120
13255     C NEUTRON DOWNSCATTERS
13256     R=FLTRNF(0)
13257     DO 90 I=1,2
13258     IP=IPTMD(INDX)
13259     NB=IPMDS(IP)
13260     DO 50 IB=1,NB
13261     IF(R.LE.PMDS(IP+NB+IB))GO TO 60
13262     50 CONTINUE
13263     WRITE(IOUT,10000)PMDS(IP+2*NB)
13264     10000 FORMAT(' MICAP: CUMULATIVE DOWNSCATTER DIST. DOES NOT END ',
13265     + 'IN 1.0 IN THRSEL',E12.4)
13266     PRINT *,' CALOR: ERROR in MICAP ====> STOP '
13267     STOP
13268     60 IF(IB.EQ.1)GO TO 70
13269     DELE=(PMDS(IP+NB+IB)-R)/(PMDS(IP+NB+IB)-PMDS(IP+NB+IB-1))
13270     ABETA=DELE*(PMDS(IP+IB-1)-PMDS(IP+IB))+PMDS(IP+IB)
13271     GO TO 80
13272     70 ABETA=BETA(IB)
13273     80 ABETA2(I)=ABETA
13274     INDX=INDX-1
13275     90 CONTINUE
13276     ABETA=DELEN*ABETA2(2)+(1.0-DELEN)*ABETA2(1)
13277     EOUT=E-TDK*ABETA
13278     IF(EOUT.LT.1.0E-05)EOUT=1.0E-05
13279     DO 100 IB=1,NB7
13280     IF(ABETA.LE.BETA(IB))GO TO 110
13281     100 CONTINUE
13282     IB=NB7
13283     110 DELE=(ABETA-BETA(IB))/(BETA(IB-1)-BETA(IB))
13284     GO TO 180
13285     C NEUTRON UPSCATTERS
13286     120 R=FLTRNF(0)
13287     DO 170 I=1,2
13288     DO 130 IB=1,NB7
13289     IF(R.LE.PMUPS(IB,INDX))GO TO 140
13290     130 CONTINUE
13291     WRITE(IOUT,10100)PMUPS(NB7,INDX)
13292     10100 FORMAT(' MICAP: CUMULATIVE UPSCATTER DIST. DOES NOT END ',
13293     + 'IN 1.0 IN THRSEL',E12.4)
13294     PRINT *,' CALOR: ERROR in MICAP ====> STOP '
13295     STOP
13296     140 IF(IB.EQ.1)GO TO 150
13297     DELE=(PMUPS(IB,INDX)-R)/(PMUPS(IB,INDX)-PMUPS(IB-1,INDX))
13298     ABETA=DELE*(BETA(IB-1)-BETA(IB))+BETA(IB)
13299     GO TO 160
13300     150 WRITE(IOUT,10200)PMUPS(1,INDX)
13301     10200 FORMAT(' MICAP: CUMULATIVE UPSCATTER DIST. DOES NOT BEGIN ',
13302     + 'AT 0.0 IN THRSEL',E12.4)
13303     PRINT *,' CALOR: ERROR in MICAP ====> STOP '
13304     STOP
13305     160 ABETA2(I)=ABETA
13306     INDX=INDX-1
13307     170 CONTINUE
13308     ABETA=DELEN*ABETA2(2)+(1.0-DELEN)*ABETA2(1)
13309     EOUT=E+TDK*ABETA
13310     C SELECT ANGLE
13311     180 AMAX=(EOUT+E+2.0*SQRT(E*EOUT))/(AAWR*TDK)
13312     AMIN=(EOUT+E-2.0*SQRT(E*EOUT))/(AAWR*TDK)
13313     DO 190 IA=1,NP7
13314     IF(AMAX.LT.ALPHA(IA))GO TO 200
13315     190 CONTINUE
13316     IA=NP7
13317     DELA=0.0
13318     GO TO 210
13319     200 DELA=(ALPHA(IA)-AMAX)/(ALPHA(IA)-ALPHA(IA-1))
13320     210 F4=DELE*(F(IA,IB-1)-F(IA,IB))+F(IA,IB)
13321     F3=DELE*(F(IA-1,IB-1)-F(IA-1,IB))+F(IA-1,IB)
13322     F2=DELA*(F3-F4)+F4
13323     DO 220 IA=1,NP7
13324     IF(AMIN.LT.ALPHA(IA))GO TO 230
13325     220 CONTINUE
13326     IA=NP7
13327     DELA=0.0
13328     GO TO 240
13329     230 DELA=(ALPHA(IA)-AMIN)/(ALPHA(IA)-ALPHA(IA-1))
13330     240 F4=DELE*(F(IA,IB-1)-F(IA,IB))+F(IA,IB)
13331     F3=DELE*(F(IA-1,IB-1)-F(IA-1,IB))+F(IA-1,IB)
13332     F1=DELA*(F3-F4)+F4
13333     R=FLTRNF(0)
13334     F0=R*F2+(1.0-R)*F1
13335     F1=0.0
13336     DO 250 IA=1,NP7
13337     F2=DELE*(F(IA,IB-1)-F(IA,IB))+F(IA,IB)
13338     IF(F0.LE.F2)GO TO 260
13339     F1=F2
13340     250 CONTINUE
13341     260 IF(F1.EQ.F2)GO TO 270
13342     DELA=(F2-F0)/(F2-F1)
13343     GO TO 280
13344     270 ALP=ALPHA(IA)
13345     GO TO 290
13346     280 ALP=DELA*ALPHA(IA-1)+(1.0-DELA)*ALPHA(IA)
13347     290 FM=(E+EOUT-ALP*AAWR*TDK)/(2.0*SQRT(E*EOUT))
13348     IF(ABS(FM).LE.1.0)RETURN
13349     WRITE(IOUT,10300)FM,E,EOUT,R,IA,IB
13350     10300 FORMAT(' MICAP: ERROR IN THRSEL, COSINE OF ANGLE >1'/,
13351     +' ',1P4E12.4,2I11)
13352     FM=2.0*FLTRNF(0)-1.0
13353     RETURN
13354     END
13355     *CMZ : 1.01/04 10/06/93 14.43.49 by Christian Zeitnitz
13356     *-- Author :
13357     SUBROUTINE TREBOD(D,LD,KZ1,KZ2,KZ3,A1,A2,A3,Z1,Z2,Z3,
13358     + ATAR,Q,MT)
13359     C CZ July 30,1992 Simple aproach to get (N,PA), (N,T2A),(N,D2A)
13360     C processes. This is TWOBOD extended to a third particle
13361     C THIS ROUTINE CALCULATES THE EXIT ENERGIES AND DIRECTIONAL
13362     C COSINES FOR THE CHARGED PARTICLE AND RECOIL NUCLEUS FOR
13363     C A THREE-BODY REACTION USING AN EVAPORATION SPECTRUM AND
13364     C MOMEMTUM BALANCE. IT ALSO SETS ALL EXIT PARAMETERS FOR
13365     C THE COLLISION PRODUCTS AND STORES THEM IN THE RECOIL BANK.
13366     #include "minput.inc"
13367     #include "mconst.inc"
13368     #include "mnutrn.inc"
13369     #include "mrecoi.inc"
13370     #include "mapoll.inc"
13371     #include "mmass.inc"
13372     #include "mpstor.inc"
13373     *KEND.
13374     DIMENSION D(*),LD(*),ER1(3)
13375     SAVE
13376     C loop over no. of emmitted particles CZ July 30,1992
13377     NPN = 1
13378     IF(MT.EQ.112) NPN = 2
13379     IF(MT.EQ.113) NPN = 3
13380     IF(MT.EQ.114) NPN = 3
13381     PRXO = 0.0
13382     PRYO = 0.0
13383     PRZO = 0.0
13384     DO 10 NP=1,NPN
13385     C CALCULATE THE COULOMB BARRIER (CB)
13386     CALL BARIER(KZ1,KZ2,A1,A3,CB)
13387     C CALCULATE THE CHARGED PARTICLE EXIT ENERGY (EX)
13388     CALL CEVAP(EOLD,Q,ATAR,CB,EX)
13389     E1=EX+CB
13390     ZMSS = Z2
13391     AMSS = A2
13392     KZZ = KZ2
13393     IF(NP.EQ.1) THEN
13394     ZMSS = Z1
13395     AMSS = A1
13396     KZZ = KZ1
13397     ENDIF
13398     C ASSUME ISOTROPIC CHARGED PARTICLE EMISSION IN THE LABORATORY
13399     CALL GTISO(U1,V1,W1)
13400     PPN = SQRT(2.0*ZMSS*E1)
13401     PRXO = PRXO + U1*PPN
13402     PRYO = PRYO + V1*PPN
13403     PRZO = PRZO + W1*PPN
13404     C CALCULATE AND SET THE CHARGED PARTICLE EXIT PARAMETERS
13405     XR=X
13406     YR=Y
13407     ZR=Z
13408     WATER=WTBC
13409     NZR=KZZ
13410     AGER=AGE
13411     NCOLR=NCOL
13412     MTNR=MT
13413     AR=AMSS
13414     ENIR=EOLD
13415     UNIR=UOLD
13416     VNIR=VOLD
13417     WNIR=WOLD
13418     ENOR=0.0
13419     UNOR=0.0
13420     VNOR=0.0
13421     WNOR=0.0
13422     WTNR=0.0
13423     QR=Q
13424     UR=U1
13425     VR=V1
13426     WR=W1
13427     ER=E1
13428     C STORE THE CHARGED PARTICLE IN THE RECOIL BANK
13429     EP = ER
13430     UP = UR
13431     VP = VR
13432     WP = WR
13433     AMP = AR
13434     ZMP = FLOAT(NZR)
13435     AGEP = AGE
13436     MTP = MT
13437     CALL STOPAR(IDHEVY,NHEVY)
13438     A3 = A3 - A2
13439     Z3 = Z3 - Z2
13440     KZ3 = KZ3 - KZ2
13441     10 CONTINUE
13442     A3 = A3 + A2
13443     Z3 = Z3 + Z2
13444     KZ3 = KZ3 + KZ2
13445     C CALCULATE THE TOTAL MOMENTUM BEFORE THE COLLISION
13446     C NEUTRON MOMENTUM BEFORE COLLISION (PI) EQUALS TOTAL MOMENTUM
13447     PI=SQRT(2.0*ZN*EOLD)
13448     C CALCULATE THE DIRECTIONAL MOMENTUM OF THE RECOIL NUCLEUS
13449     PRX=PI*UOLD - PRXO
13450     PRY=PI*VOLD - PRYO
13451     PRZ=PI*WOLD - PRZO
13452     C CALCULATE THE TOTAL MOMENTUM OF THE RECOIL NUCLEUS
13453     PR=SQRT(PRX**2+PRY**2+PRZ**2)
13454     C CALCULATE THE RECOIL NUCLEUS DIRECTIONAL COSINES
13455     U2=PRX/PR
13456     V2=PRY/PR
13457     W2=PRZ/PR
13458     C CALCULATE THE RECOIL NUCLEUS EXIT ENERGY
13459     XM = A2 * 931.075E6
13460     E2 = SQRT(PR**2+XM**2) - XM
13461     C CALCULATE AND SET THE CHARGED PARTICLE EXIT PARAMETERS
13462     XR=X
13463     YR=Y
13464     ZR=Z
13465     WATER=WTBC
13466     NZR=KZ3
13467     AGER=AGE
13468     NCOLR=NCOL
13469     MTNR=MT
13470     AR=A3
13471     ENIR=EOLD
13472     UNIR=UOLD
13473     VNIR=VOLD
13474     WNIR=WOLD
13475     ENOR=0.0
13476     UNOR=0.0
13477     VNOR=0.0
13478     WNOR=0.0
13479     WTNR=0.0
13480     QR=Q
13481     UR=U2
13482     VR=V2
13483     WR=W2
13484     ER=E2
13485     C STORE THE RECOIL HEAVY ION IN THE RECOIL BANK
13486     EP = ER
13487     UP = UR
13488     VP = VR
13489     WP = WR
13490     AMP = AR
13491     ZMP = FLOAT(NZR)
13492     AGEP = AGE
13493     MTP = MT
13494     CALL STOPAR(IDHEVY,NHEVY)
13495     RETURN
13496     END
13497     *CMZ : 1.04/03 15/02/95 14.00.42 by Christian Zeitnitz
13498     *-- Author :
13499     SUBROUTINE TWOBOD(D,LD,KZ1,KZ2,A1,A2,Z1,Z2,ATAR,Q,MT)
13500     C THIS ROUTINE CALCULATES THE EXIT ENERGIES AND DIRECTIONAL
13501     C COSINES FOR THE CHARGED PARTICLE AND RECOIL NUCLEUS FOR
13502     C A TWO-BODY REACTION USING AN EVAPORATION SPECTRUM AND
13503     C MOMEMTUM BALANCE. IT ALSO SETS ALL EXIT PARAMETERS FOR
13504     C THE COLLISION PRODUCTS AND STORES THEM IN THE RECOIL BANK.
13505     #include "minput.inc"
13506     #include "mconst.inc"
13507     #include "mnutrn.inc"
13508     #include "mrecoi.inc"
13509     #include "mapoll.inc"
13510     #include "mmass.inc"
13511     #include "mpstor.inc"
13512     *KEND.
13513     DIMENSION D(*),LD(*)
13514     SAVE
13515     PRXO = 0.0
13516     PRYO = 0.0
13517     PRZO = 0.0
13518     C loop over no. of emmitted particles CZ July 30,1992
13519     NPN = 1
13520     IF(MT.EQ.108) NPN = 2
13521     IF(MT.EQ.109) NPN = 3
13522     IF(MT.EQ.111) NPN = 2
13523     C CALCULATE THE COULOMB BARRIER (CB)
13524     CALL BARIER(KZ1,KZ2,A1,A2,CB)
13525     C CALCULATE THE CHARGED PARTICLE EXIT ENERGY (EX)
13526     CALL CEVAP(EOLD,Q,ATAR,CB,EX)
13527     E1=EX+CB
13528     C calculate the massnumber and mass of the residual nucleus
13529     A2 = A2 - (NPN-1)*A1
13530     Z2 = Z2 - (NPN-1)*Z1
13531     IF(A2.LT.0.) A2 = 0.
13532     IF(Z2.LT.0.) Z2 = 0.
13533     IF(NPN.EQ.1) THEN
13534     C for 1 final state particle the available kinetic energy is given
13535     C by momentum and energy conservation
13536     E1 = E1*Z2/(Z1+Z2)
13537     ENDIF
13538     DO 10 NP=1,NPN
13539     C ASSUME ISOTROPIC CHARGED PARTICLE EMISSION IN THE LABORATORY
13540     CALL GTISO(U1,V1,W1)
13541     IF(NPN.EQ.1) THEN
13542     C only one final state particle -> use all the energy available
13543     PPN = SQRT(2.0*Z1*E1)
13544     EKN = E1
13545     ELSE
13546     IF(NP.LT.NPN) THEN
13547     EKN = E1*FLTRNF(0)
13548     ELSE
13549     EKN = E1
13550     ENDIF
13551     E1 = E1 - EKN
13552     PPN = SQRT(2.0*Z1*EKN)
13553     ENDIF
13554     PRXO = PRXO + U1*PPN
13555     PRYO = PRYO + V1*PPN
13556     PRZO = PRZO + W1*PPN
13557     C CALCULATE AND SET THE CHARGED PARTICLE EXIT PARAMETERS
13558     XR=X
13559     YR=Y
13560     ZR=Z
13561     WATER=WTBC
13562     NZR=KZ1
13563     AGER=AGE
13564     NCOLR=NCOL
13565     MTNR=MT
13566     AR=A1
13567     ENIR=EOLD
13568     UNIR=UOLD
13569     VNIR=VOLD
13570     WNIR=WOLD
13571     ENOR=0.0
13572     UNOR=0.0
13573     VNOR=0.0
13574     WNOR=0.0
13575     WTNR=0.0
13576     QR=Q
13577     UR=U1
13578     VR=V1
13579     WR=W1
13580     ER=EKN
13581     C STORE THE CHARGED PARTICLE IN THE RECOIL BANK
13582     EP = ER
13583     UP = UR
13584     VP = VR
13585     WP = WR
13586     AMP = AR
13587     ZMP = FLOAT(NZR)
13588     AGEP = AGE
13589     MTP = MT
13590     CALL STOPAR(IDHEVY,NHEVY)
13591     10 CONTINUE
13592     C CALCULATE THE TOTAL MOMENTUM BEFORE THE COLLISION
13593     C NEUTRON MOMENTUM BEFORE COLLISION (PI) EQUALS TOTAL MOMENTUM
13594     PI=SQRT(2.0*ZN*EOLD)
13595     C CALCULATE THE DIRECTIONAL MOMENTUM OF THE RECOIL NUCLEUS
13596     PRX=PI*UOLD - PRXO
13597     PRY=PI*VOLD - PRYO
13598     PRZ=PI*WOLD - PRZO
13599     C CALCULATE THE TOTAL MOMENTUM OF THE RECOIL NUCLEUS
13600     PR=SQRT(PRX**2+PRY**2+PRZ**2)
13601     C CALCULATE THE RECOIL NUCLEUS DIRECTIONAL COSINES
13602     U2=PRX/PR
13603     V2=PRY/PR
13604     W2=PRZ/PR
13605     C CALCULATE THE RECOIL NUCLEUS EXIT ENERGY
13606     XM = A2*931.075E6
13607     E2 = SQRT(PR**2+XM**2) - XM
13608     C CALCULATE AND SET THE CHARGED PARTICLE EXIT PARAMETERS
13609     XR=X
13610     YR=Y
13611     ZR=Z
13612     WATER=WTBC
13613     NZR=KZ2
13614     AGER=AGE
13615     NCOLR=NCOL
13616     MTNR=MT
13617     AR=A2
13618     ENIR=EOLD
13619     UNIR=UOLD
13620     VNIR=VOLD
13621     WNIR=WOLD
13622     ENOR=0.0
13623     UNOR=0.0
13624     VNOR=0.0
13625     WNOR=0.0
13626     WTNR=0.0
13627     QR=Q
13628     UR=U2
13629     VR=V2
13630     WR=W2
13631     ER=E2
13632     C STORE THE RECOIL HEAVY ION IN THE RECOIL BANK
13633     EP = ER
13634     UP = UR
13635     VP = VR
13636     WP = WR
13637     AMP = AR
13638     ZMP = FLOAT(NZR)
13639     AGEP = AGE
13640     MTP = MT
13641     CALL STOPAR(IDHEVY,NHEVY)
13642     RETURN
13643     END
13644     *CMZ : 1.05/04 30/11/2005 11.04.02 by Christian Zeitnitz
13645     *-- Author :
13646     SUBROUTINE XSECN1(NII,KE,IN,ICOM,IREC,IUNIT,LNUMB,IND,
13647     + BUF,IBUF,INEL)
13648     C THIS ROUTINE READS THE SECOND RECORD ON INPUT
13649     C I/O UNIT (MICROS) (I.E. THE B CONTROL BLOCK)
13650     #include "minput.inc"
13651     #include "mmicap.inc"
13652     #include "mconst.inc"
13653     *KEND.
13654     DIMENSION BUF(*),IBUF(*),ICOM(*),KE(*),IREC(*),IND(*),IN(*)
13655     DIMENSION INEL(*),LNUMB(*),IUNIT(*)
13656     INTEGER NII
13657     C READ THE B CONTROL BLOCK OFF INPUT I/O UNIT
13658     LT = LTEMP
13659     LZ = 1
13660     IU = 1
13661     10 CONTINUE
13662     NU = IQ(LT+NTUNIT)
13663     NIJ = IQ(LT+NTMPNI)
13664     LZZ=3*NIJ
13665     READ(NU,'((8I10))')(IBUF(I),I=LZ,LZZ+LZ-1)
13666     C INITIALIZE IND ARRAY AND IREC ARRAY TO ZERO
13667     DO 20 I=IU,IU+NIJ-1
13668     IUNIT(I) = NU
13669     20 CONTINUE
13670     IU = IU+NIJ
13671     LZ = LZ + LZZ
13672     LT = LQ(LT)
13673     IF(LT.GT.0) GOTO 10
13674     DO 30 I=1,NII
13675     INEL(I)=0
13676     IREC(I)=0
13677     30 CONTINUE
13678     DO 40 I=1,NMIX
13679     40 IND(I)=0
13680     II=0
13681     JI=0
13682     50 II=II+1
13683     CZ IF(II.GT.NII)GO TO 90
13684     IF(3*II.GT.LZ)GO TO 90
13685     NEL=IBUF(3*II-2)
13686     INEL(II)=NEL
13687     DO 60 IJ=1,NMIX
13688     C correct element AND the correct unit ?
13689     IF(NEL.EQ.KE(IJ)) GO TO 70
13690     60 CONTINUE
13691     IREC(II)=0
13692     GO TO 50
13693     70 I=IN(IJ)
13694     C ICOM RELATES THE ISOTOPE NUMBER TO THE DICTIONARY NUMBER
13695     IF(ICOM(I).GT.0) IREC(ICOM(I)) = 0
13696     ICOM(I)=II
13697     C total length of x-section data in words
13698     LNUMB(I) = IBUF(3*II)
13699     IREC(II) = IBUF(3*II-1)
13700     C SET INDICATORS
13701     DO 80 I=IJ,NMIX
13702     IF(NEL.NE.KE(I))GO TO 80
13703     IND(I)=1
13704     JI=JI+1
13705     80 CONTINUE
13706     GO TO 50
13707     90 RETURN
13708     END
13709     *CMZ : 1.05/03 27/06/2001 18.41.30 by Christian Zeitnitz
13710     *-- Author :
13711     SUBROUTINE XSECN2(ICOM,IREC,IUNIT,IGAMS,LGAM,ELTOL,INABS,LNAB,
13712     + ITHRMS,LTHRM,IDICTS,LDICT,NTX,NTS,IGCBS,LGCB,AWR,Q,LR,QLR,
13713     + BUF,IBUF,LIM,LAST,INEL)
13714     C THIS ROUTINE READS THE REMAINDER OF INPUT I/O UNIT(s),
13715     C SELECTS THE ELEMENTS NEEDED FOR THE CALCULATIONS,
13716     C AND STORES THE CROSS SECTION DATA IN CORE
13717     #include "minput.inc"
13718     #include "mconst.inc"
13719     #include "mmicab.inc"
13720     *KEND.
13721     CHARACTER*4 MARK
13722     DIMENSION BUF(*),IBUF(*),ICOM(*),IGAMS(*),LGAM(*),INABS(*),
13723     +LNAB(*),ITHRMS(*),LTHRM(*),AWR(*),IDICTS(NNR,NNUC),ELTOL(*),
13724     +LDICT(NNR,NNUC),Q(NQ,NNUC),NTX(*),NTS(*),IGCBS(NGR,NNUC),
13725     +LGCB(NGR,NNUC),IREC(*),LR(NQ,NNUC),QLR(NQ,NNUC)
13726     DIMENSION INEL(*),IUNIT(*)
13727     C ASSIGN THE DEFAULT VALUES
13728     LEN=0
13729     C INITIALIZE THE COUNTERS FOR THE LOOP
13730     C NISR EQUALS THE NUMBER OF ISOTOPES READ
13731     C IRECNO EQUALS THE NEXT RECORD NUMBER TO BE READ ON INPUT
13732     C I/O UNIT (NUNIT)
13733     C LAST EQUALS THE LAST CORE POSITION USED IN THE CALLING
13734     CROUTINE (INPUT1)
13735     C LST EQUALS THE LAST POSITION USED IN THE BUF ARRAY
13736     C (I.E. (BUF(LST) = D(LAST)))
13737     NISR=0
13738     IRECNO=1
13739     LST=0
13740     C PRINT OUT THE CROSS SECTION DIRECTORY IF CALLED FOR
13741     10 CONTINUE
13742     C START LOOP TO READ IN THE DATA ON INPUT I/O UNIT
13743     DO 370 II=1,NI
13744     IR = IREC(II)
13745     IF(NUNIT.NE.IUNIT(II)) IRECNO = 1
13746     NUNIT= IUNIT(II)
13747     IF(NUNIT.LE.0) THEN
13748     WRITE(IOUT,'(/,'' XSECN2 : Wrong unit number '',I10)') NUNIT
13749     GOTO 370
13750     ENDIF
13751     IF(NISR.GE.NNUC)GO TO 370
13752     IF(IR.EQ.0)GO TO 370
13753     C LOOP TO LOCATE THE I CONTROL BLOCK RECORD (IR=IREC(II))
13754     CZ x-section endmark = 'ENDE'
13755     CZ file endmark ='ENDF'
13756     MARK = ' '
13757     20 IF(MARK.EQ.'ENDE') IRECNO = IRECNO + 1
13758     IF(MARK.EQ.'ENDF') GOTO 50
13759     IF(IR.EQ.IRECNO) GOTO 30
13760     READ(NUNIT,'(A)') MARK
13761     GO TO 20
13762     C CHECK TO DETERMINE THE ISOTOPE NUMBER FOR THE RANDOM WALK
13763     30 DO 40 I=1,NNUC
13764     IF(ICOM(I).EQ.II)GO TO 60
13765     40 CONTINUE
13766     50 WRITE(IOUT,10000)II
13767     10000 FORMAT('0',10X,'ERROR IN ROUTINE XSECN2, II=',I6,/)
13768     GO TO 390
13769     C READ I CONTROL BLOCK RECORD OFF INPUT I/O UNIT (NUNIT) FOR
13770     C THE ELEMENT CORRESPONDING TO IREC(II) AND ICOM(I)
13771     60 IJK=I
13772     READ(NUNIT,'(I10,4G13.7,1I10,/,6I10)') IBUF(LST+1),(BUF(LST+
13773     + IK),IK=2,5),(IBUF(LST+IJ),IJ=6,12)
13774     NISR=NISR+1
13775     C ASSIGN VALUES TO ARRAYS NEEDED FOR THE RANDOM WALK
13776     ISO=IJK
13777     NEL=INEL(II)
13778     AWR(ISO)=BUF(LST+2)
13779     CZ store accuracy of xs
13780     ELTOL(ISO) = BUF(LST+4)
13781     IFLAGU=IBUF(LST+6)
13782     LGAM(ISO)=IBUF(LST+7)
13783     NTX(ISO)=IBUF(LST+8)
13784     NTS(ISO)=IBUF(LST+9)
13785     LTHRM(ISO)=IBUF(LST+11)
13786     LNAB(ISO)=IBUF(LST+12)
13787     C READ IN THE ISOTOPE DICTIONARY (IDICT ARRAY)
13788     C FROM INPUT I/O UNIT (NUNIT)
13789     READ(NUNIT,'((8I10))')(LDICT(J,ISO),J=1,NNR)
13790     70 CONTINUE
13791     C READ IN ENDF/B FILE3 CROSS SECTION DATA
13792     C READ IN ENDF/B FILE4 ANGULAR DISTRIBUTION DATA
13793     C READ IN ENDF/B FILE5 SECONDARY ENERGY DISTRIBUTION DATA
13794     DO 190 I2=1,NNR
13795     LZ=LDICT(I2,ISO)
13796     IF(LZ.EQ.0)GO TO 190
13797     LEN=LIM-LAST
13798     IF(LEN.LT.LZ)GO TO 380
13799     IDICTS(I2,ISO)=LAST+1-LMOX2
13800     CZ changed in order to read ASCII input file
13801     C I2 < 67 -> x-section data
13802     C I2 < 123 -> angular distribution
13803     C I2 < 134 -> secondary energy distribution
13804     C I2 = 134 ->
13805     IF(I2.LT.67) THEN
13806     READ(NUNIT,'((6G13.7))')(BUF(LST+I),I=1,LZ)
13807     ELSE IF(I2.LT.123) THEN
13808     C ------------------- I2 = 67 -----------------------------
13809     READ(NUNIT,'((8I10))') (IBUF(LST+I),I=1,2), (IBUF(LST+
13810     + J+2),J=1,2*IBUF(LST+1))
13811     K = 2*IBUF(LST+1) + 2 + 1
13812     DO 80 J=1,IBUF(LST+2)
13813     READ(NUNIT,'(G13.7,I10,/,(6G13.7))') BUF(LST+K), IBUF(LST
13814     + +K+1), (BUF(LST+IK+K+1),IK=1,IBUF(LST+K+1)*2)
13815     K = K + 2 + IBUF(LST+K+1)*2
13816     80 CONTINUE
13817     ELSE IF(I2.LT.134) THEN
13818     C-------------------- I2 = 123 ----------------------------
13819     C first header is different, because of nk in first position
13820     read(nunit,'(2I10,G13.7,2I10,/,(8I10))') (IBUF(LST+I),
13821     + I=1,2),BUF(LST+3),(IBUF(LST+J),J=4,5), (IBUF(LST+K+5),
13822     + K=1,2*IBUF(LST+4))
13823     C define buffer position to start at LF type
13824     IP = 2
13825     do nk=1,IBUF(LST+1)
13826     if(nk.gt.1) then
13827     read(nunit,'(I10,G13.7,2I10,/,(8I10))') IBUF(LST+IP),
13828     + BUF(LST+IP+1),(IBUF(LST+IP+J),J=2,3), (IBUF(LST+IP+K+3)
13829     + ,K=1,2*IBUF(LST+IP+2))
13830     endif
13831     ID = IP - 2 + 2*IBUF(LST+IP+2) + 5
13832     LF = IBUF(LST+IP)
13833     NP2 = 2*IBUF(LST+IP+3)
13834     READ(NUNIT,'((6G13.7))') (BUF(LST+ID+I),I=1,NP2)
13835     ID = ID + NP2
13836     KEND = 1
13837     IF(LF.EQ.5.OR.LF.EQ.11) KEND = 2
13838     DO 100 K=1,KEND
13839     READ(NUNIT,'((8I10))') (IBUF(LST+ID+I),I=1,2)
13840     NR2 = 2*IBUF(LST+ID+1)
13841     NE = IBUF(LST+ID+2)
13842     ID = ID + 2
13843     READ(NUNIT,'((8I10))') (IBUF(LST+ID+I),I=1,NR2)
13844     ID = ID + NR2
13845     IEND = NE
13846     IF(LF.EQ.5.OR.LF.EQ.11) IEND = 1
13847     IF(LF.EQ.7.OR.LF.EQ.9) IEND = 1
13848     DO 90 I=1,IEND
13849     IF(LF.EQ.1) THEN
13850     READ(NUNIT,'(G13.7,2I10)') BUF(LST+ID+1), (IBUF(LST
13851     + +ID+J),J=2,3)
13852     NR2 = 2*IBUF(LST+ID+2)
13853     NP2 = 2*IBUF(LST+ID+3)
13854     ID = ID + 3
13855     READ(NUNIT,'((8I10))') (IBUF(LST+ID+J),J=1, NR2)
13856     ID = ID + NR2
13857     ELSE
13858     NP2 = 2*NE
13859     ENDIF
13860     READ(NUNIT,'((6G13.7))') (BUF(LST+ID+J),J=1,NP2)
13861     ID = ID + NP2
13862     90 Continue
13863     100 CONTINUE
13864     IP = ID + 1
13865     enddo
13866     ELSE
13867     C ------------------ I2 = 134 --------------------------------------
13868     READ(NUNIT,'(I10)') IBUF(LST+1)
13869     LNU = IBUF(LST+1)
13870     IF(LNU.NE.2) THEN
13871     READ(NUNIT,'(I10,/,(6G13.7))') IBUF(LST+2), (BUF(LST
13872     + +I+2),I=1,IBUF(LST+2))
13873     ELSE
13874     READ(NUNIT,'((8I10))') (IBUF(LST+I),I=2,3)
13875     NR2 = IBUF(LST+2)*2
13876     READ(NUNIT,'((8I10))') (IBUF(LST+3+J),J=1,NR2)
13877     NP2 = IBUF(LST+3)*2
13878     READ(NUNIT,'((6G13.7))') (BUF(LST+3+NR2+J),J=1,NP2)
13879     ENDIF
13880     ENDIF
13881     CZ end of change
13882     IF(I2.GT.66)GO TO 120
13883     110 CONTINUE
13884     GO TO 180
13885     120 IF(I2.GT.122)GO TO 150
13886     130 CONTINUE
13887     CALL ANGCDF(BUF(LST+1),IBUF(LST+1),LZ)
13888     140 CONTINUE
13889     GO TO 180
13890     150 IF(I2.GT.133)GO TO 170
13891     160 CONTINUE
13892     GO TO 180
13893     170 CONTINUE
13894     180 CONTINUE
13895     LAST=LAST+LZ
13896     LST=LST+LZ
13897     190 CONTINUE
13898     C READ IN THE AVERAGE PHOTON PRODUCTION ARRAY
13899     LZ=LGAM(ISO)
13900     IF(LZ.EQ.0)GO TO 210
13901     LEN=LIM-LAST
13902     IF(LEN.LT.LZ)GO TO 380
13903     IGAMS(ISO)=LAST+1-LMOX2
13904     READ(NUNIT,'((6G13.7))')(BUF(LST+I),I=1,LZ)
13905     200 CONTINUE
13906     LAST=LAST+LZ
13907     LST=LST+LZ
13908     210 CONTINUE
13909     C READ IN THE TOTAL NEUTRON DISAPPERANCE ARRAY
13910     LZ=LNAB(ISO)
13911     IF(LZ.EQ.0)GO TO 230
13912     LEN=LIM-LAST
13913     IF(LEN.LT.LZ)GO TO 380
13914     INABS(ISO)=LAST+1-LMOX2
13915     READ(NUNIT,'((6G13.7))')(BUF(LST+I),I=1,LZ)
13916     220 CONTINUE
13917     LAST=LAST+LZ
13918     LST=LST+LZ
13919     230 CONTINUE
13920     C READ IN THE Q VALUE ARRAY
13921     READ(NUNIT,'((6G13.7))')(Q(I,ISO),I=1,NQ)
13922     240 CONTINUE
13923     C READ IN THE LR VALUE ARRAY
13924     READ(NUNIT,'((8I10))')(LR(I,ISO),I=1,NQ)
13925     250 CONTINUE
13926     C READ IN THE QLR VALUE ARRAY
13927     READ(NUNIT,'((6G13.7))')(QLR(I,ISO),I=1,NQ)
13928     260 CONTINUE
13929     C READ IN THE PHOTON DATA DICTIONARY (GCB ARRAY)
13930     C FROM INPUT I/O UNIT (NUNIT)
13931     C CURRENT STORAGE IS SET TO ACCOMODATE UP TO 30 INTERACTIONS
13932     C (I.E. (2*NTX(ISO)+2*NTS(ISO)).LE.NGR)
13933     L=2*NTX(ISO)+2*NTS(ISO)
13934     IF(L.EQ.0)GO TO 350
13935     L1=2*NTX(ISO)
13936     L2=L1+1
13937     READ(NUNIT,'((8I10))')(LGCB(J,ISO),J=1,L)
13938     270 CONTINUE
13939     C READ IN ENDF/B FILE12 PHOTON MULTIPLICATION DATA
13940     C READ IN ENDF/B FILE13 PHOTON CROSS SECTION DATA
13941     NNTX=NTX(ISO)
13942     DO 300 I2=1,NNTX
13943     LZ=LGCB(2*I2,ISO)
13944     IF(LZ.EQ.0)GO TO 300
13945     LEN=LIM-LAST
13946     IF(LEN.LT.LZ)GO TO 380
13947     IGCBS(2*I2-1,ISO)=LGCB(2*I2-1,ISO)
13948     IGCBS(2*I2,ISO)=LAST+1-LMOX2
13949     CZ changed in order to read ASCII xsection file
13950     READ(NUNIT,'((8I10))') (IBUF(LST+I),I=1,2)
13951     READ(NUNIT,'((6G13.7))') (BUF(LST+J+2),J=1,IBUF(LST+2))
13952     ID = IBUF(LST+2) + 2 + LST
13953     DO 280 K = 1, IBUF(LST+1)
13954     READ(NUNIT,'(2(G13.7,I10))') BUF(ID+1),IBUF(ID+2), BUF(ID+3
13955     + ),IBUF(ID+4)
13956     ID = ID + 4
13957     READ(NUNIT,'((6G13.7))') (BUF(ID + J),J=1,IBUF(LST+2))
13958     ID = ID + IBUF(LST+2)
13959     280 CONTINUE
13960     CZ end of change
13961     290 CONTINUE
13962     LAST=LAST+LZ
13963     LST=LST+LZ
13964     300 CONTINUE
13965     C READ IN ENDF/B FILE15 PHOTON SECONDARY ENERGY DISTRIBUTIONS
13966     NNTS=NTS(ISO)
13967     IF(NNTS.EQ.0)GO TO 350
13968     DO 340 I2=1,NNTS
13969     LZ=LGCB(L1+2*I2,ISO)
13970     IF(LZ.EQ.0)GO TO 340
13971     LEN=LIM-LAST
13972     IF(LEN.LT.LZ)GO TO 380
13973     IGCBS(L1+2*I2-1,ISO)=LGCB(L1+2*I2-1,ISO)
13974     IGCBS(L1+2*I2,ISO)=LAST+1-LMOX2
13975     CZ changed in order to read ASCII xsection file
13976     READ(NUNIT,'(2I10,G13.7,2I10,/,(8I10))') (IBUF(LST+I),I=1,
13977     + 2),BUF(LST+3), (IBUF(LST+J),J=4,5), (IBUF(LST+K+5),K=1,2*
13978     + IBUF(LST+4))
13979     ID = 2*IBUF(LST+4) + 5
13980     LF = IBUF(LST+2)
13981     NP2 = 2*IBUF(LST+5)
13982     READ(NUNIT,'((6G13.7))') (BUF(LST+ID+I),I=1,NP2)
13983     ID = ID + NP2
13984     KEND = 1
13985     IF(LF.EQ.5.OR.LF.EQ.11) KEND = 2
13986     DO 320 K=1,KEND
13987     READ(NUNIT,'((8I10))') (IBUF(LST+ID+I),I=1,2)
13988     NR2 = 2*IBUF(LST+ID+1)
13989     NE = IBUF(LST+ID+2)
13990     ID = ID + 2
13991     READ(NUNIT,'((8I10))') (IBUF(LST+ID+I),I=1,NR2)
13992     ID = ID + NR2
13993     IEND = NE
13994     IF(LF.EQ.5.OR.LF.EQ.11) IEND = 1
13995     IF(LF.EQ.7.OR.LF.EQ.9) IEND = 1
13996     DO 310 I=1,IEND
13997     IF(LF.EQ.1) THEN
13998     READ(NUNIT,'(G13.7,2I10)') BUF(LST+ID+1), (IBUF(L
13999     + ST+ID+J),J=2,3)
14000     NR2 = 2*IBUF(LST+ID+2)
14001     NP2 = 2*IBUF(LST+ID+3)
14002     ID = ID + 3
14003     READ(NUNIT,'((8I10))') (IBUF(LST+ID+J),J=1,NR2)
14004     ID = ID + NR2
14005     ELSE
14006     NP2 = 2*NE
14007     ENDIF
14008     READ(NUNIT,'((6G13.7))') (BUF(LST+ID+J),J=1,NP2)
14009     ID = ID + NP2
14010     310 CONTINUE
14011     320 CONTINUE
14012     CZ end of change
14013     330 CONTINUE
14014     LAST=LAST+LZ
14015     LST=LST+LZ
14016     340 CONTINUE
14017     350 CONTINUE
14018     C READ IN THE THERMAL CROSS SECTION DATA ARRAY
14019     LZ=LTHRM(ISO)
14020     IF(LZ.EQ.0)GO TO 360
14021     LEN=LIM-LAST
14022     IF(LEN.LT.LZ)GO TO 380
14023     ITHRMS(ISO)=LAST+1
14024     READ(NUNIT,'((6G13.7))')(BUF(LST+I),I=1,LZ)
14025     LAST=LAST+LZ
14026     LST=LST+LZ
14027     360 CONTINUE
14028     370 CONTINUE
14029     GO TO 400
14030     380 WRITE(IOUT,10100)LZ,LEN
14031     10100 FORMAT('0','NOT ENOUGH SPACE TO READ IN RECORD',/,5X,
14032     +'LENGTH OF RECORD=',I10,/,5X,'SPACE AVAILABLE=',I10)
14033     390 PRINT '('' CALOR: ERROR in XSECN2 ====> STOP '')'
14034     STOP
14035     400 RETURN
14036     END
14037     *CMZ : 0.94/04 18/03/93 22.51.31 by Christian Zeitnitz
14038     *-- Author :
14039     SUBROUTINE XSECN3(KM,KE,RHO,IN,IDICTS,LDICT,ISIGTS,LSIGT,BUF,
14040     +IBUF,TCS,LIM,LAST)
14041     C THIS ROUTINE CREATES MACROSCOPIC TOTAL CROSS SECTIONS
14042     C AND THEN MIXES AND THINS THESE CROSS SECTIONS ACCORDING
14043     C TO THE MIXING TABLE
14044     #include "minput.inc"
14045     #include "mconst.inc"
14046     #include "mpoint.inc"
14047     #include "mmicab.inc"
14048     *KEND.
14049     DIMENSION BUF(*),IBUF(*),KM(*),KE(*),RHO(*),IN(*),
14050     +IDICTS(NNR,NNUC),LDICT(NNR,NNUC),ISIGTS(*),LSIGT(*),TCS(*)
14051     C ASSIGN THE INITIAL VALUES
14052     C LST EQUALS THE LAST POSITION USED IN THE BUF ARRAY
14053     C (I.E. (BUF(LST) = D(LAST)))
14054     C LEN EQUALS THE CORE SPACE AVAILABLE
14055     LST=0
14056     LEN=LIM-LAST
14057     TOL = 1.0
14058     C READ IN TWO CROSS SECTION ARRAYS AND CREATE
14059     C MACROSCOPIC CROSS SECTIONS
14060     DO 160 J=1,MEDIA
14061     JI=0
14062     K=0
14063     C READ IN THE FIRST ARRAY
14064     DO 140 IJ=1,NMIX
14065     IF(KM(IJ).NE.J)GO TO 140
14066     JI=JI+1
14067     K=K+1
14068     II=IN(IJ)
14069     TOL = AMIN1(TCS(LFP210+II-1)/5.,TOL)
14070     IF(JI.EQ.2)GO TO 20
14071     LZ=LDICT(1,II)
14072     ISLZ=IDICTS(1,II)+LMOX2
14073     N=LZ
14074     IF(LEN.LT.N)GO TO 180
14075     NP=LZ/2
14076     DO 10 M=1,NP
14077     BUF(LST+2*M-1)=TCS(ISLZ+2*(M-1))
14078     BUF(LST+2*M)=TCS(ISLZ+2*M-1)*RHO(IJ)
14079     10 CONTINUE
14080     GO TO 140
14081     20 CONTINUE
14082     C READ IN THE SECOND ARRAY
14083     LZ2=LZ+1
14084     LZ1=LZ
14085     LZ=LDICT(1,II)
14086     ISLZ=IDICTS(1,II)+LMOX2
14087     N=2*(LZ+LZ1)
14088     IF(N.GE.LEN)GO TO 180
14089     NP=LZ/2
14090     DO 30 M=1,NP
14091     BUF(LST+LZ1+2*M-1)=TCS(ISLZ+2*(M-1))
14092     BUF(LST+LZ1+2*M)=TCS(ISLZ+2*M-1)*RHO(IJ)
14093     30 CONTINUE
14094     GO TO 40
14095     C MIX THE TWO ARRAYS
14096     40 K=2
14097     L=2
14098     IF(BUF(LST+1).NE.1.E-5)GO TO 170
14099     IF(BUF(LST+LZ2).NE.1.E-5)GO TO 170
14100     NXSEC=1
14101     BUF(LST+LZ1+LZ+1)=1.E-5
14102     BUF(LST+LZ1+LZ+2)=BUF(LST+2)+BUF(LST+LZ2+1)
14103     C DETERMINE THE NEXT ENERGY POINT
14104     50 IF(BUF(LST+1+K).EQ.BUF(LST+LZ2+L))GO TO 90
14105     IF(BUF(LST+1+K).LT.BUF(LST+LZ2+L))GO TO 70
14106     C DETERMINE THE CROSS SECTION AT ENERGY POINT BUF(LST+LZ2+L)
14107     CALL CTERP(BUF(LST+K-1),BUF(LST+K+1),BUF(LST+LZ2+L),
14108     + BUF(LST+K), BUF(LST+K+2),SIGMA)
14109     NXSEC=NXSEC+1
14110     LP=LZ1+LZ+1+2*(NXSEC-1)
14111     BUF(LST+LP)=BUF(LST+LZ2+L)
14112     BUF(LST+LP+1)=BUF(LST+LZ2+L+1)+SIGMA
14113     L=L+2
14114     IF(L.LT.LZ)GO TO 50
14115     C ALL THE POINTS IN THE SECOND ARRAY HAVE NOW BEEN USED
14116     60 NXSEC=NXSEC+1
14117     LP=LZ1+LZ+1+2*(NXSEC-1)
14118     BUF(LST+LP)=BUF(LST+1+K)
14119     BUF(LST+LP+1)=BUF(LST+2+K)
14120     K=K+2
14121     IF(K.LT.LZ1)GO TO 60
14122     GO TO 100
14123     C DETERMINE THE CROSS SECTION AT ENERGY POINT BUF(LST+1+K)
14124     70 CALL CTERP(BUF(LST+LZ2+L-2),BUF(LST+LZ2+L),BUF(LST+1+K),
14125     + BUF(LST+LZ2+L-1),BUF(LST+LZ2+L+1),SIGMA)
14126     NXSEC=NXSEC+1
14127     LP=LZ1+LZ+1+2*(NXSEC-1)
14128     BUF(LST+LP)=BUF(LST+1+K)
14129     BUF(LST+LP+1)=BUF(LST+K+2)+SIGMA
14130     K=K+2
14131     IF(K.LT.LZ1)GO TO 50
14132     C ALL THE POINTS IN THE FIRST ARRAY HAVE NOW BEEN USED
14133     80 NXSEC=NXSEC+1
14134     LP=LZ1+LZ+2*NXSEC-1
14135     BUF(LST+LP)=BUF(LST+LZ2+L)
14136     BUF(LST+LP+1)=BUF(LST+LZ2+L+1)
14137     L=L+2
14138     IF(L.LT.LZ)GO TO 80
14139     GO TO 100
14140     C THE ENERGY POINTS COINCIDE
14141     90 NXSEC=NXSEC+1
14142     LP=LZ1+LZ+1+2*(NXSEC-1)
14143     BUF(LST+LP)=BUF(LST+LZ2+L)
14144     BUF(LST+LP+1)=BUF(LST+2+K)+BUF(LST+LZ2+L+1)
14145     L=L+2
14146     K=K+2
14147     IF((L.LT.LZ).AND.(K.LT.LZ1))GO TO 50
14148     IF((L.GT.LZ).AND.(K.LT.LZ1))GO TO 60
14149     IF((L.LT.LZ).AND.(K.GT.LZ1))GO TO 80
14150     C FINISHED MIXING NOW THIN
14151     100 L=1
14152     NXSEC2=1
14153     LP=LZ1+LZ
14154     BUF(LST+NXSEC2)=BUF(LST+LP+L)
14155     BUF(LST+NXSEC2+1)=BUF(LST+LP+L+1)
14156     KI=0
14157     110 L=L+2
14158     KI=KI+1
14159     C CHECK TO SEE IF AT END OF CROSS SECTION ARRAY
14160     L2=L+2
14161     N=2*NXSEC
14162     IF(L2.LT.N)GO TO 120
14163     C FINISHED THINING
14164     NXSEC2=NXSEC2+1
14165     N=2*(NXSEC2-1)
14166     BUF(LST+1+N)=BUF(LST+LP+L)
14167     BUF(LST+2+N)=BUF(LST+LP+L+1)
14168     LZ=2*NXSEC2
14169     JI=1
14170     GO TO 140
14171     120 DO 130 I=1,KI
14172     C ESTIMATE THE CROSS SECTION AT KI NODES
14173     CALL CTERP(BUF(LST+LP+L-2*KI),BUF(LST+LP+L2),
14174     + BUF(LST+LP+L-2*I+2),BUF(LST+LP+L-2*KI+1),
14175     + BUF(LST+LP+L2+1),SIGMA)
14176     ER=ABS(SIGMA-BUF(LST+LP+L-2*I+3))
14177     C IF ERROR IS WITHIN ALLOWABLE TOLERANCE, CHECK NEXT POINT
14178     ERMAX=BUF(LST+LP+L-2*I+3)*TOL
14179     IF(ER.LE.ERMAX)GO TO 130
14180     C NOT WITHIN ALLOWABLE TOLERANCE, MUST ADD NODE L-2 TO MESH
14181     IF(L.GT.3.AND.KI.GT.1) L = L - 2
14182     NXSEC2=NXSEC2+1
14183     N=2*(NXSEC2-1)
14184     BUF(LST+1+N)=BUF(LST+LP+L)
14185     BUF(LST+2+N)=BUF(LST+LP+L+1)
14186     KI = 0
14187     GO TO 110
14188     130 CONTINUE
14189     C ALL KI POINTS ARE WITHIN ALLOWABLE TOLERANCE
14190     C CHECK THE NEXT POINT
14191     GO TO 110
14192     140 CONTINUE
14193     C FINISHED WITH MEDIUM J, NOW STORE IN CORE
14194     N=2*NXSEC2
14195     IF(K.EQ.1)N=LZ
14196     LSIGT(J)=N
14197     ISIGTS(J)=LAST+1-LMOX3
14198     150 CONTINUE
14199     LAST=LAST+N
14200     LST=LST+N
14201     C FINISHED MIXING AND THINING
14202     160 CONTINUE
14203     GO TO 200
14204     170 WRITE(IOUT,10000)BUF(LST+1),BUF(LST+LZ2)
14205     10000 FORMAT(' MICAP: ERROR-BEGINNING ENERGY DOES NOT START AT 1.-5',
14206     +1P2E12.4)
14207     GOTO 190
14208     180 CONTINUE
14209     L=LEN
14210     WRITE(IOUT,10100)L,N
14211     10100 FORMAT(' MICAP: NOT ENOUGH ROOM TO MIX CROSS SECTIONS',/,5X,
14212     +'SPACE AVAILABLE=',I10,/,5X,'SPACE NEEDED=',I10)
14213     190 PRINT '('' CALOR: ERROR in XSECN3 ====> STOP'')'
14214     STOP
14215     200 RETURN
14216     END
14217     *CMZ : 1.01/04 10/06/93 14.43.49 by Christian Zeitnitz
14218     *-- Author :
14219     SUBROUTINE XSECN5(NTX,IGCBS,LGCB,IGCBS2,LGCB2,BUF,IBUF,D,LD,
14220     +LIM,LAST)
14221     C THIS ROUTINE READS THE PHOTON PARTIAL DISTRIBUTIONS FOR EACH
14222     C REACTION LISTED IN THE GCB ARRAYS AND SUMS THEM UP TO
14223     C CREATE A TOTAL MULTIPLICITY * CROSS SECTION ARRAY FOR
14224     C EACH REACTION AND STORES THIS CROSS SECTION DATA IN CORE
14225     #include "minput.inc"
14226     #include "mconst.inc"
14227     #include "mmicab.inc"
14228     *KEND.
14229     DIMENSION NTX(NNUC),IGCBS(NGR,NNUC),LGCB(NGR,NNUC),
14230     +IGCBS2(NGR,NNUC),LGCB2(NGR,NNUC),BUF(*),IBUF(*),D(*),LD(*)
14231     C ASSIGN THE DEFAULT VALUES
14232     LEN=0
14233     C INITIALIZE THE COUNTERS FOR THE LOOP
14234     C LAST EQUALS THE LAST CORE POSITION USED IN THE CALLING
14235     CROUTINE (INPUT1)
14236     C LST EQUALS THE LAST POSITION USED IN THE BUF ARRAY
14237     C (I.E. (BUF(LST) = D(LAST)))
14238     LST=0
14239     DO 70 I=1,NNUC
14240     NNTX=NTX(I)
14241     L=2*NNTX
14242     IF(L.EQ.0)GO TO 70
14243     DO 60 I2=1,NNTX
14244     LZ=LGCB(2*I2,I)
14245     IF(LZ.EQ.0)GO TO 60
14246     LEN=LIM-LAST
14247     IF(LEN.LT.LZ)GO TO 80
14248     C EQUATE THE MT NUMBERS IN THE GCB AND GCB2 DICTIONARIES
14249     IGCBS2(2*I2-1,I)=IGCBS(2*I2-1,I)
14250     LGCB2(2*I2-1,I)=LGCB(2*I2-1,I)
14251     C SET THE STARTING LOCATION FOR THE PHOTON TOTAL CROSS SECTION
14252     IGCBS2(2*I2,I)=LAST+1-LMOX4
14253     C OBTAIN THE STARTING LOCATION OF THE PARTIAL DISTRIBUTIONS
14254     IST=IGCBS(2*I2,I)+LMOX2
14255     NK=LD(IST)
14256     NP=LD(IST+1)
14257     NP2=2*NP
14258     LGCB2(2*I2,I)=NP2
14259     C ZERO OUT THE CORE AREA TO STORE THE TOTAL PHOTON
14260     C MULTIPLICITY * CROSS SECTION ARRAYS
14261     DO 10 IP=1,NP2
14262     BUF(LST+IP)=0.0
14263     10 CONTINUE
14264     C SET UP THE ENERGY BOUNDARIES FOR THE (E,XS) TABLE
14265     DO 20 J=1,NP
14266     BUF(LST+2*J-1)=D(IST+J+2-1)
14267     20 CONTINUE
14268     II=NP+2
14269     AWRI=D(IST+II+3-1)
14270     C SUM THE PARTIAL DISTRIBUTIONS TO OBTAIN THE TOTAL
14271     C MULTIPLICITY * CROSS SECTION ARRAY AND STORE IN THE
14272     C ENERGY,CROSS SECTION TABLE
14273     DO 40 J=1,NK
14274     II=II+4
14275     DO 30 K=1,NP
14276     BUF(LST+2*K)=BUF(LST+2*K)+D(IST+II+K-1)
14277     30 CONTINUE
14278     II=II+NP
14279     40 CONTINUE
14280     50 CONTINUE
14281     C UPDATE CORE LOCATION POINTERS
14282     LAST=LAST+NP2
14283     LST=LST+NP2
14284     60 CONTINUE
14285     70 CONTINUE
14286     RETURN
14287     80 WRITE(IOUT,10000)LZ,LEN
14288     10000 FORMAT(' MICAP: NOT ENOUGH SPACE TO READ IN RECORD',/,5X,
14289     +'LENGTH OF RECORD=',I10,/,5X,'SPACE AVAILABLE=',I10)
14290     PRINT '('' CALOR: ERROR in XSECN5 ====> STOP '')'
14291     STOP
14292     END
14293     *CMZ : 1.01/04 10/06/93 14.43.49 by Christian Zeitnitz
14294     *-- Author :
14295     SUBROUTINE XSECNU(BUF,LEN,E,XSC,L1,L2)
14296     C THIS ROUTINE DETERMINES A CROSS SECTION AT A GIVEN ENERGY
14297     C FROM A CROSS SECTION VERSUS ENERGY TABLE
14298     DIMENSION BUF(*)
14299     SAVE
14300     IF(E.LT.BUF(L1))GO TO 40
14301     DO 10 J=1,LEN
14302     N=L1+2*(J-1)
14303     IF(E.LE.BUF(N))GO TO 20
14304     10 CONTINUE
14305     XSC=BUF(L2)
14306     RETURN
14307     20 IF(J.EQ.1)GO TO 30
14308     XSC=BUF(N-1)+(E-BUF(N-2))*(BUF(N+1)-BUF(N-1))/
14309     +(BUF(N)-BUF(N-2))
14310     RETURN
14311     30 XSC=BUF(N+1)
14312     RETURN
14313     40 XSC=0.0
14314     RETURN
14315     END
14316     *CMZ : 1.03/00 27/05/94 16.22.23 by Christian Zeitnitz
14317     *-- Author : Christian Zeitnitz 27/05/94
14318     SUBROUTINE MICSET(MATNO,NKEY)
14319     C***********************************************************************
14320     C set a option in MICAP
14321     C
14322     C INPUT: MATNO - GEANT material number
14323     C NKEY - 0 -> use single isotopes instead of the
14324     C natural composition in material MATNO
14325     C 1 -> use natural composition
14326     C
14327     C************************************************************************
14328     C
14329     #include "mmicap.inc"
14330     *KEND.
14331     C
14332     LOGICAL FIRST
14333     DATA FIRST/.TRUE./
14334     C
14335     IF(FIRST) THEN
14336     FIRST = .FALSE.
14337     NWW = 100
14338     CALL CHKZEB(NWW,IXCONS)
14339     CALL MZLINK(IXCONS,'MICPAR',LMIST,LMIST,LMIST)
14340     CALL MZBOOK(IXCONS,LMIST,0,2,'MIST',0,0,NWW,0,0)
14341     ENDIF
14342     10 CONTINUE
14343     DO 20 I=1,IQ(LMIST-1),2
14344     IF(IQ(LMIST+I).EQ.MATNO) THEN
14345     IQ(LMIST+I+1) = NKEY
14346     GOTO 999
14347     ENDIF
14348     IF(IQ(LMIST+I).EQ.0) THEN
14349     IQ(LMIST+I) = MATNO
14350     IQ(LMIST+I+1) = NKEY
14351     GOTO 999
14352     ENDIF
14353     20 CONTINUE
14354     C
14355     C Bank got to small, increase the size
14356     NWW = 100 + IQ(LMIST-1)
14357     CALL CHKZEB(NWW,IXCONS)
14358     CALL MZPUSH(IXCONS,LMIST,0,100,'I')
14359     GOTO 10
14360     999 RETURN
14361     END
14362     *CMZ : 1.04/01 09/02/95 17.09.56 by Christian Zeitnitz
14363     *-- Author : Christian Zeitnitz 9/02/95
14364     SUBROUTINE MICFIL(CNAME)
14365     C***********************************************************************
14366     C set a option in MICAP
14367     C
14368     C INPUT:
14369     C CNAME - in case NKEY=10 the file name
14370     C
14371     C************************************************************************
14372     C
14373     #include "mmicap.inc"
14374     *KEND.
14375     C
14376     CHARACTER*(*) CNAME
14377     C
14378     LOGICAL FIRST
14379     DATA FIRST/.TRUE./
14380     C
14381     IF(FIRST) THEN
14382     FIRST = .FALSE.
14383     NFIL = 101
14384     CALL CHKZEB(NFIL,IXCONS)
14385     CALL MZLINK(IXCONS,'MICFIL',LMIFIL,LMIFIL,LMIFIL)
14386     CALL MZBOOK(IXCONS,LMIFIL,0,2,'MIFL',0,0,NFIL,0,0)
14387     ELSE
14388     C increase the bank for the x-section file name
14389     NFIL = 101 + IQ(LMIFIL-1)
14390     CALL CHKZEB(NFIL,IXCONS)
14391     CALL MZPUSH(IXCONS,LMIFIL,0,101,'I')
14392     ENDIF
14393     C store x-section file name in bank 'MIFL'
14394     C find the last free index in the bank
14395     IF(LNBLNK(CNAME).GT.0) THEN
14396     I = LMIFIL+IQ(LMIFIL-1)-100+1
14397     CALL UCTOH(CNAME,IQ(I),4,LNBLNK(CNAME))
14398     IQ(I-1) = LNBLNK(CNAME)
14399     ELSE
14400     PRINT*,' MICSET : invalid file name '
14401     ENDIF
14402     30 RETURN
14403     END
14404     *CMZ : 1.01/10 30/06/93 13.51.55 by Christian Zeitnitz
14405     *-- Author :
14406     SUBROUTINE CSKALE(IBERT,F,NOFAS,ITSLO,EFAS,ALPFAS,BETFAS,GAMFAS,
14407     + EHICUT,RMFAS,EXFAS,REFAS)
14408     C
14409     CZ modified SKALE -- generate WT particles
14410     C
14411     DIMENSION F(*) , ITSLO(*) , EFAS(*) , ALPFAS(*) , BETFAS(*) ,
14412     + GAMFAS(*), WTFAS(200), ESLO(200), ALPSLO(200),
14413     + BETSLO(200), GAMSLO(200), NPI(200)
14414     C
14415     LOGICAL FTROBL
14416     C
14417     DATA IELAS/1/
14418     SAVE
14419     C
14420     NKEY=2
14421     NCT=1
14422     10 ESTOR=F(3)
14423     F(3)=EHICUT
14424     C
14425     CALL CABERT(IBERT,F,NOSLO,ITSLO,ESLO,ALPSLO,BETSLO,GAMSLO)
14426     IBERT=1
14427     F(3)=ESTOR
14428     C
14429     IF(NOSLO.GT.0) GO TO 70
14430     NOFAS=NOSLO
14431     20 CONTINUE
14432     C
14433     C scaling within geant
14434     C generate N particles with RND*WT*Ei energy
14435     C check for depletion of nucleus
14436     C
14437     IF(NOFAS.LE.0) RETURN
14438     C first determine recoil nucleus parameters
14439     FTROBL = .FALSE.
14440     30 CONTINUE
14441     AR=F(1)
14442     ZR=F(2)
14443     PI0NO = 0.0
14444     PIPNO = 0.0
14445     PIMNO = 0.0
14446     PRONO = 0.0
14447     XNEUT = 0.0
14448     DO 40 I=1,NOFAS
14449     IF(ITSLO(I).LE.0) PRONO = PRONO + 1.0
14450     IF(ITSLO(I).LE.1) XNEUT = XNEUT + 1.0
14451     IF(ITSLO(I).EQ.2) THEN
14452     CALL GRNDM(R,1)
14453     NPI(I) = INT(WTFAS(I))
14454     XN = WTFAS(I) - FLOAT(NPI(I)) - R
14455     IF(XN.GT.0.0) NPI(I) = NPI(I) + 1
14456     IF(NPI(I).LE.0.OR.FTROBL) NPI(I) = 1
14457     PIPNO = PIPNO + FLOAT(NPI(I))
14458     ELSE IF(ITSLO(I).EQ.4) THEN
14459     CALL GRNDM(R,1)
14460     NPI(I) = INT(WTFAS(I))
14461     XN = WTFAS(I) - FLOAT(NPI(I)) - R
14462     IF(XN.GT.0.0) NPI(I) = NPI(I) + 1
14463     IF(NPI(I).LE.0.OR.FTROBL) NPI(I) = 1
14464     PIMNO = PIMNO + FLOAT(NPI(I))
14465     ELSE IF(ITSLO(I).EQ.3) THEN
14466     CALL GRNDM(R,1)
14467     NPI(I) = INT(WTFAS(I))
14468     XN = WTFAS(I) - FLOAT(NPI(I)) - R
14469     IF(XN.GT.0.0) NPI(I) = NPI(I) + 1
14470     IF(NPI(I).LE.0.OR.FTROBL) NPI(I) = 1
14471     ENDIF
14472     40 CONTINUE
14473     AADD = 1.
14474     IF(F(7).GT.1) AADD = 0.0
14475     ZADD = 1. - F(7)
14476     IF(F(7).GT.1) ZADD = 3.-F(7)
14477     AR = AR + AADD - PRONO - XNEUT
14478     ZR = ZR + ZADD - PRONO - PIPNO + PIMNO
14479     IF((ZR.LT.0.OR.AR.LT.ZR).AND..NOT.FTROBL) THEN
14480     FTROBL = .TRUE.
14481     GOTO 30
14482     ENDIF
14483     C start generating more particles
14484     K = NOFAS + 1
14485     C loop over particles
14486     DO 60 I=1,NOFAS
14487     C don't scale nucleons
14488     IF(ITSLO(I).LE.1) THEN
14489     EFAS(I) = EFAS(I)*WTFAS(I)
14490     ELSE
14491     DO 50 J=1,NPI(I)
14492     IF(J.EQ.NPI(I)) THEN
14493     IF(WTFAS(I).GT.0.0) EFAS(I) = EFAS(I)*WTFAS(I)
14494     ELSE
14495     WTFAS(I) = WTFAS(I) - 1.
14496     EFAS(K) = EFAS(I)
14497     ITSLO(K) = ITSLO(I)
14498     ALPFAS(K) = ALPFAS(I)
14499     BETFAS(K) = BETFAS(I)
14500     GAMFAS(K) = GAMFAS(I)
14501     K = K + 1
14502     ENDIF
14503     50 CONTINUE
14504     ENDIF
14505     60 CONTINUE
14506     NOFAS=K-1
14507     RETURN
14508     70 IF(IELAS.EQ.0) GO TO 80
14509     CALL ESKALE(IE,EHICUT,F,NOFAS,ITSLO,EFAS,ALPFAS,BETFAS,GAMFAS,
14510     + WTFAS,RMFAS,EXFAS,REFAS,NOSLO,ESLO,ALPSLO,BETSLO,GAMSLO)
14511     GO TO (80,10,20),IE
14512     80 ATAR=F(1)
14513     EINC=F(3)
14514     ITINC=F(7)
14515     CALL MCMOSC(NKEY,ATAR,ITINC,EINC,EHICUT,NOSLO,ITSLO,ESLO,ALPSLO,
14516     + BETSLO,GAMSLO,EFAS,WTFAS,ALPFAS,BETFAS,GAMFAS,RMFAS,NOFAS,EXFAS,
14517     + REFAS,WHY)
14518     IF(NOFAS.EQ.0) GO TO 10
14519     GOTO 20
14520     END
14521     *CMZ : 1.01/09 29/06/93 12.26.35 by Christian Zeitnitz
14522     *-- Author :
14523     SUBROUTINE ESKALE(IE,EHICUT,FIN,NOFAS,ITSLO,EFAS,ALPFAS,BETFAS,
14524     + GAMFAS,WTFAS,RMFAS,EXFAS,REFAS,NOSLO,ESLO,ALPSLO,BETSLO,GAMSLO)
14525     C
14526     C changed 10 Nov. 1992 C.Zeitnitz
14527     C
14528     DIMENSION FIN(*) , ITSLO(*) , EFAS(*) , ALPFAS(*) ,
14529     + BETFAS(*) , GAMFAS(*) , WTFAS(*) , ESLO(*) ,
14530     + ALPSLO(*) , BETSLO(*) , GAMSLO(*) , ITSLO2(200),
14531     + EFAS2(200), WTFAS2(200), ALPFA2(200), BETFA2(200),
14532     + GAMFA2(200)
14533     C
14534     #include "cinout.inc"
14535     #include "cbert.inc"
14536     *KEND.
14537     C
14538     REAL*8 F,PRTIN2,FEINC
14539     REAL*4 W
14540     C
14541     DATA F /0.95D0/
14542     DATA W /0.2/
14543     SAVE
14544     C
14545     IND = 1
14546     EINC = DBLE(FIN(3))
14547     EPART= FIN(3)
14548     FIN(3) = EHICUT
14549     FEINC = DBLE(EHICUT) * F
14550     PRTIN2 = DBLE(FIN(7)) + 1.D0
14551     C**
14552     C** NEP = NO. OF ESCAPING PARTICLES
14553     C**
14554     10 NEP = IDINT(ESPS(1) + 1.0D-2)
14555     C
14556     C** CHECK FOR PIONS
14557     C
14558     J = 2
14559     DO 20 I = 1,NEP
14560     IF(ESPS(J).GE.3.D0) GO TO 50
14561     J = J + 8
14562     20 CONTINUE
14563     ITEST1 = ITEST1 + 1
14564     J = 2
14565     DO 40 I=1,NEP
14566     C
14567     C** CHECK FOR ESCAPING PARTICLE SAME AS INCIDENT PARTICLE
14568     C
14569     IF(ESPS(J).NE.PRTIN2) GO TO 30
14570     C
14571     C** CHECK FOR ENERGY OF ESCAPING PARTICLE GREATER THAN F * ENERGY
14572     C** OF INCIDENT PARTICLE
14573     C
14574     IF(ESPS(J+1).GT.FEINC) GO TO 60
14575     30 J = J + 8
14576     40 CONTINUE
14577     C
14578     C** A 'NON-ELASTIC' COLLISION HAS OCCURRED
14579     C
14580     50 GO TO (160 ,120),IND
14581     C
14582     C** AN 'ELASTIC' COLLISION HAS OCCURRED
14583     C
14584     60 CONTINUE
14585     70 GO TO (80,110),IND
14586     80 ATAR = FIN(1)
14587     NKEY = 2
14588     NELAST = NELAST + 1
14589     ITINC = FIN(7)
14590     CALL MCMOSC(NKEY,ATAR,ITINC,EPART,EHICUT,NOSLO,ITSLO,ESLO,
14591     + ALPSLO,BETSLO,GAMSLO,EFAS,WTFAS,ALPFAS,BETFAS,GAMFAS,RMFAS,
14592     + NOFAS,EXFAS,REFAS,WHY)
14593     NOFAS1 = NOFAS
14594     IF(NOFAS1.GT.0) GO TO 90
14595     IE = 2
14596     GO TO 170
14597     C
14598     C** MULTIPLY ALL PARTICLE WEIGHTS FOR THIS COLLISION BY W
14599     C
14600     90 DO 100 I=1,NOFAS1
14601     WTFAS(I) = WTFAS(I) * W
14602     100 CONTINUE
14603     110 IBERT = 1
14604     CALL CABERT(IBERT,FIN,NOSLO,ITSLO2,ESLO,ALPSLO,BETSLO,GAMSLO)
14605     IF(NOSLO.LE.0) GO TO 110
14606     IND = 2
14607     GO TO 10
14608     120 CALL MCMOSC(NKEY,ATAR,ITINC,EPART,EHICUT,NOSLO,ITSLO2,ESLO,
14609     + ALPSLO,BETSLO,GAMSLO,EFAS2,WTFAS2,ALPFA2,BETFA2,GAMFA2,RMFAS2,
14610     + NOFAS2,EXFAS2,REFAS2,WHY)
14611     IF(NOFAS2.LE.0) GO TO 110
14612     C
14613     C** MULTIPLY ALL PARTICLE WEIGHTS BY 1.-W
14614     W2 = 1.0 - W
14615     DO 130 I=1,NOFAS2
14616     WTFAS2(I) = WTFAS2(I) * W2
14617     130 CONTINUE
14618     C
14619     C** COMBINE TWO COLLISIONS
14620     C
14621     IF(NOFAS1 + NOFAS2.LE.60) GO TO 140
14622     WRITE(IO,10000) NOFAS1,NOFAS2
14623     10000 FORMAT(' HETC: Too many particles in ESKALE -- NOFAS1 = ',I2,
14624     + ' NOFAS2 = ',I2)
14625     IF(NOFAS1.EQ.60) NOFAS1 = 59
14626     NOFAS2 = 60 - NOFAS1
14627     140 NOFAS = NOFAS1 + NOFAS2
14628     DO 150 I = 1,NOFAS2
14629     J = NOFAS1 + I
14630     ITSLO(J) = ITSLO2(I)
14631     EFAS(J) = EFAS2(I)
14632     WTFAS(J) = WTFAS2(I)
14633     ALPFAS(J) = ALPFA2(I)
14634     BETFAS(J) = BETFA2(I)
14635     GAMFAS(J) = GAMFA2(I)
14636     150 CONTINUE
14637     EXFAS = EXFAS * W + EXFAS2 * (1.-W)
14638     RMFAS = RMFAS * W + RMFAS2 * (1.-W)
14639     REFAS = REFAS * W + REFAS2 * (1.-W)
14640     IE = 3
14641     GO TO 170
14642     160 IE = 1
14643     170 FIN(3) = SNGL(EINC)
14644     RETURN
14645     END
14646     *CMZ : 1.01/09 29/06/93 12.23.58 by Christian Zeitnitz
14647     *-- Author :
14648     SUBROUTINE MCMOSC(NKEY,ATAR,ITINC,EOPRS,EINCS,NOSLO,ITSLO,ESLO,
14649     + ALPSLO,BETSLO,GAMSLO,EFAS,WTFAS,ALPFAS,BETFAS,GAMFAS,RMFAS,NOFAS,
14650     + EXFAS,REFAS,WHY)
14651     C
14652     C CALCULATION OF MOMENTUM SPECTRA
14653     C FOR SCALED-UP INCIDENT PARTICLE ENERGIES
14654     C
14655     REAL*8 AMASNO, EINC, ARRAY, BRRAY, BARB, EINCT, NUMBEA, TARMAT
14656     REAL*8 EOPR,TARMAS,FUG,AMORNT,AMRNST,ESTART, ERNPRT,ERNT,AMASIN,
14657     +EMASS,PMAX,AMOINC,CHEINC,RESMAS,ETOT,ETOTPR, AMOIPR,BETA,BETAPR,
14658     +GAMMA,GAMPR,ECM,RECAL1,RECAL2,RECAL3,ECMPR, CUTL,CUTCM,ECMOKE,
14659     +PCMO,YIELD,AVERE,BTOT,BTOTPR,ZKZ,BPRLAB,ECMKE, PLICIT,EXCIT,PX,
14660     +PY,PZ,PXS,PYS,PZS,P,CHECK,WEIGHT,PCM,EPRCM, PTEMP,WCM,W,PPR,
14661     +PSTOR1,PSTOR2,B,ESUM,BLANK,BLANK1,AMORN, ERN,ERNPR,AESUM,ESTAR,
14662     +ESTARP,TOTAL,ANSWER,A1,A2,A3,A4,A5,A11,B11 ,C11,ANSPLU,ANSMIN,A6,
14663     +A7,D1,STO,STOO,A8,ESUMPR,BTOLAB,ARRMON
14664     C
14665     #include "camass.inc"
14666     *KEND.
14667     DIMENSION PART(5),EMASS(5),CTOFM(5),ARRAY(500)
14668     DIMENSION BRRAY(500),WEIGHT(65),CUTL(5),CUTCM(5),RESMAS(5),
14669     + AVERE(10),YIELD(10),ECMKE(5),PLICIT(5),EPRCM(65),FUG(5)
14670     C
14671     DIMENSION ITSLO(*),ESLO(*),ALPSLO(*),BETSLO(*),GAMSLO(*),
14672     + EFAS(*),WTFAS(*),ALPFAS(*),BETFAS(*),GAMFAS(*)
14673     C
14674     DIMENSION EINCT(10), NUMBEA(10)
14675     LOGICAL INIT
14676     C
14677     EQUIVALENCE(CUTCM(1),RESMAS(1),CUTL(1),EMASS(1))
14678     C
14679     DATA INIT/.TRUE./
14680     SAVE
14681     C
14682     10 IF(INIT) THEN
14683     20 COUNT = 0.
14684     TARMAT=0.
14685     COUNT1 = 0.
14686     COUNT2=0.
14687     COUNT3=0.
14688     COUNT4 = 0.
14689     COUNT5 = 0.
14690     NTTME=0
14691     AMORNT = 0.0
14692     AMRNST = 0.0
14693     ESTART=0.
14694     ZKZ=0.
14695     NMLTEO = 0
14696     ERNPRT = 0.0
14697     ERNT = 0.0
14698     CHECK7=0.
14699     CHECK8=0.
14700     DO 30 III=1,500
14701     BRRAY(III)=0.
14702     ARRAY(III)=0.
14703     30 CONTINUE
14704     DO 40 IHK = 1,10
14705     EINCT(IHK)=0.
14706     NUMBEA(IHK)=0.
14707     YIELD(IHK) = 0.0
14708     C WILL CONTAIN AVERAGE MULTIPLICITIES WHEN DIVIDED BY # OF COLLISION
14709     AVERE(IHK) = 0.0
14710     40 CONTINUE
14711     C WILL CONTAIN AVERAGE ENERGY WHEN DIVIDED BY # OF COLLISIONS
14712     BTOT = 0.0
14713     BTOTPR=0.0
14714     C SETTING MASSES FOR THE 5 POSSIBLE EMERGENT PARTICLES
14715     RESMAS(1) = XMASS(0)*1000.
14716     RESMAS(2) = XMASS(1)*1000.
14717     RESMAS(3)= XMASS(2)*1000.
14718     RESMAS(4)= XMASS(2)*1000.
14719     RESMAS(5) = XMASS(3)*1000.
14720     FUG(3)=1.0D0
14721     FUG(4)=1.0D0
14722     FUG(5)=1.0D0
14723     INIT = .FALSE.
14724     ENDIF
14725     GO TO (50 ,70 ,50 ,440),NKEY
14726     50 RETURN
14727     C DEFINES INCIDENT PARTICLE
14728     60 EINCT(IPIN)=EINCT(IPIN)-EINC
14729     EINCT(IPIN+5)=EINCT(IPIN+5)-EOPR
14730     NUMBEA(IPIN)=NUMBEA(IPIN)-1.D0
14731     NUMBEA(IPIN+5)=NUMBEA(IPIN+5)-1.D0
14732     TARMAT = TARMAT-TARMAS
14733     RETURN
14734     70 PIN = ITINC +1
14735     ZKZ=ZKZ+1.D0
14736     IPIN= PIN
14737     NOFAS=0
14738     WHY=0.
14739     INTYPE=ITINC+1
14740     GOTO(80 ,90 ,100 ,100 ,100 ),INTYPE
14741     80 FUG(1)=1.00D0
14742     FUG(2)=1.00D0
14743     GOTO 110
14744     90 FUG(1)=1.00D0
14745     FUG(2)=1.00D0
14746     GOTO 110
14747     100 FUG(1)=1.0
14748     FUG(2)=1.0
14749     110 CONTINUE
14750     AMASNO= ATAR
14751     TARMAS= 931.49432D0*AMASNO
14752     TARMAT=TARMAT+TARMAS
14753     AMASIN=RESMAS(IPIN)
14754     EOPR=EOPRS
14755     EINC=EINCS
14756     CHEINC = 1.D0
14757     IF(IPIN.GT.2) CHEINC = 0.0
14758     EINCT(IPIN)=EINCT(IPIN)+EINC
14759     NUMBEA(IPIN)=NUMBEA(IPIN)+1.D0
14760     EINCT(IPIN+5)=EINCT(IPIN+5)+EOPR
14761     NUMBEA(IPIN+5)=NUMBEA(IPIN+5)+1.D0
14762     DO 120 I = 1,5
14763     ECMKE(I) = 0.0
14764     C TEMPORARY STORAGE FOR UNSCALED K.E. IN C.M. USED IN WEIGHT CALCULA
14765     PLICIT(I) = 0.0
14766     120 CONTINUE
14767     C TEMPORARY STORAGE FOR UNSCALED MULTIPLICITIES USED IN WEIGHT CALCU
14768     NWDS = NOSLO*8+1
14769     DO 130 III=2,NWDS,8
14770     M8=(III+6)/8
14771     ARRAY(III)=ITSLO(M8)+1
14772     ARRAY(III+1)=ESLO(M8)
14773     ARRAY(III+2)=ALPSLO(M8)
14774     ARRAY(III+3)=BETSLO(M8)
14775     ARRAY(III+4)=GAMSLO(M8)
14776     130 CONTINUE
14777     C TOTAL ENERGY OF INCIDENT PARTICLE LAB
14778     ETOT=EINC+AMASIN
14779     C TOTAL ENERGY OF SCALED INCIDENT PARTICLE LAB
14780     ETOTPR=EOPR+AMASIN
14781     C MOMENTUM OF INCIDENT PARTICLE LAB
14782     AMOINC =DSQRT (EINC*(EINC + 2.0D0*AMASIN))
14783     C MOMENTUM OF SCALED INCIDENT PARTICLE LAB
14784     AMOIPR=DSQRT(ETOTPR*ETOTPR-AMASIN*AMASIN)
14785     C BETA FOR INCIDENT PARTICLE AND TARGET
14786     BETA=AMOINC/(ETOT+TARMAS)
14787     C BETA FOR SCALED INCIDENT PARTICLE AND TARGET
14788     BETAPR=AMOIPR/(ETOTPR+TARMAS)
14789     C GAMMA FOR INCIDENT PARTICLE
14790     GAMMA=1.D0/DSQRT(1.D0-BETA*BETA)
14791     C GAMMA FOR SCALED INCIDENT PARTICLE
14792     GAMPR=1.D0/DSQRT(1.D0-BETAPR*BETAPR)
14793     C TOTAL ENERGY OF INCIDENT PARTICLE IN C.M.
14794     ECM=GAMMA*(ETOT-BETA*AMOINC)
14795     RECAL1=ECM
14796     C TOTAL ENERGY OF SCALED INCIDENT PARTICLE IN C.M.
14797     ECMPR=GAMPR*(ETOTPR-BETAPR*AMOIPR)
14798     C TOTAL CUTOFF ENERGY IN LAB SYSTEM FOR THE FIVE PARTICLES
14799     C KINETIC ENERGY OF INCIDENT PARTICLE IN C.M. SYSTEM
14800     ECMOKE=ECM-RESMAS(IPIN)
14801     RECAL2=ECMOKE
14802     C MOMENTUM OF INCIDENT PARTICLE IN C.M. SYSTEM
14803     PCMO=DSQRT(ECM*ECM-RESMAS(IPIN)*RESMAS(IPIN))
14804     RECAL3=PCMO
14805     C COUNTER FOR NUMBER OF COLLISIONS
14806     140 ECM=RECAL1
14807     ECMOKE=RECAL2
14808     PCMO=RECAL3
14809     DO 150 III = 2,NWDS
14810     150 BRRAY(III) = ARRAY(III)
14811     160 EXCIT = EINC + RESMAS(IPIN)*(1.D0-CHEINC)
14812     PX = 0.
14813     PY = 0.
14814     PZ = AMOINC
14815     PXS = 0.
14816     PYS = 0.
14817     PZS = AMOIPR
14818     C SETUP OF INITIAL LAB MOMENTUM
14819     DO 190 III = 2,NWDS,8
14820     KTYPE=ARRAY(III)
14821     C DEFINES TYPE OF ESCAPING PARTICLE
14822     M8 = (III+6)/8
14823     ARRAY(III+1) = ARRAY(III+1)+RESMAS(KTYPE)
14824     C TOTAL ENERGY OF ESCAPING PARTICLE
14825     AVERE(KTYPE) = ARRAY(III+1)+AVERE(KTYPE)-CUTL(KTYPE)
14826     C ENERGY CONSERVATION CHECK OF UNSCALED SYSTEM IN LAB
14827     YIELD(KTYPE)=YIELD(KTYPE)+1.D0
14828     C SUMMING UP PARTICLES FOR MULTIPLICITY
14829     PLICIT(KTYPE) = PLICIT(KTYPE) + 1.0D0
14830     C MULTIPLICITY OF ESCAPING PARTICLES FOR THIS COLLISION
14831     P=(ARRAY(III+1)*ARRAY(III+1)-RESMAS(KTYPE)*RESMAS(KTYPE))**.5
14832     C MOMENTUM IN LAB OF ESCAPING UNSCALED PARTICLE
14833     PX=PX+P*ARRAY(III+2)
14834     PY=PY+P*ARRAY(III+3)
14835     PZ=PZ-P*ARRAY(III+4)
14836     C THREE MOMENTUM COMPONENTS IN LAB OF ESCAPING UNSCALED PARTICLE
14837     CHECK = 0.
14838     IF(KTYPE.LT.3) CHECK=1.D0
14839     EXCIT=EXCIT-ARRAY(III+1)+RESMAS(KTYPE)*CHECK
14840     C PRELIMINARY CALCULATION TO OBTAIN EXCITATION ENERGY
14841     170 WEIGHT(M8)=GAMMA*(ARRAY(III+1)-ARRAY(III+4)*P*BETA)
14842     IF(WEIGHT(M8).GT.ECM) COUNT = COUNT + 1.
14843     C WILL BE USED IN WEIGHT CALCULATION.
14844     C NOW CONTAINS T.E. IN CM OF UNSCALED ESCAPING PARTICLE
14845     IF(WEIGHT(M8).GT.ECM) ECMOKE=WEIGHT(M8)-RESMAS(IPIN)
14846     IF(WEIGHT(M8).GT.ECM) PCMO=DSQRT(WEIGHT(M8)**2-RESMAS(IPIN)**
14847     + 2)
14848     IF(WEIGHT(M8).GT.ECM) ECM=WEIGHT(M8)
14849     ECMKE(KTYPE)=ECMKE(KTYPE)+WEIGHT(M8)-RESMAS(KTYPE)
14850     C CM KE OF UNSCALED PARTICLES....USED IN CALCULATING B
14851     PCM=(WEIGHT(M8)*WEIGHT(M8)-RESMAS(KTYPE)*RESMAS(KTYPE))**.5
14852     C MOMENTUM IN CM OF UNSCALED ESCAPING PARTICLE
14853     EPRCM(M8)=((WEIGHT(M8)-CUTCM(KTYPE))/(ECM-CUTCM(IPIN )))**
14854     + (1.D0/FUG(KTYPE))*(ECMPR-CUTCM(IPIN ))+CUTCM(KTYPE)
14855     C SCALED UP TOTAL ENERGY OF ESCAPING PARTICLE IN CM
14856     PTEMP=DSQRT(EPRCM(M8)*EPRCM(M8)-RESMAS(KTYPE)*RESMAS(KTYPE))
14857     C MOMENTUM OF SCALED UP PARTICLE IN CM
14858     W=1.D0-(P/PTEMP)**2+((P/PTEMP)**2)*ARRAY(III+4)*ARRAY(III+4)
14859     IF(W.LE.0.) CHECK8=CHECK8+1.
14860     IF(W.LE.0.) W=0.
14861     IF(W.LE.0.) GO TO 180
14862     W=DSQRT(W)
14863     C POLAR ANGLE IN CM...COMES FROM CONSERVATION OF TRANSVERSE MOMENTUM
14864     WCM=GAMMA*(P*ARRAY(III+4)-BETA*ARRAY(III+1))/PCM
14865     C THE SIGN OF W IS CHECKED NEXT
14866     C UNSCALED CM POLAR ANGLE
14867     IF(WCM.LT.0.) W=-W
14868     180 CONTINUE
14869     ARRAY(III+1)=GAMPR*(EPRCM(M8)+BETAPR*PTEMP*W)
14870     C CONTAINS TOTAL SCALED ENERGY IN LAB
14871     PPR=(ARRAY(III+1)*ARRAY(III+1)-RESMAS(KTYPE)*RESMAS(KTYPE))**
14872     + .5
14873     C MOMENTUM OF SCALED PARTICLE IN LAB
14874     ARRAY(III+4)=GAMPR*(PTEMP*W+BETAPR*EPRCM(M8))/PPR
14875     C CORRECTED POLAR ANGLE IN LAB TO CONSERVE TRANSVERSE MOMENTUM
14876     ARRAY(III+1)=ARRAY(III+1)-RESMAS(KTYPE)
14877     C K.E. IN LAB OF SCALED PARTICLE
14878     PSTOR1=DSQRT(1.D0-ARRAY(III+4)*ARRAY(III+4))* DCOS(DATAN(ARRAY
14879     + (III+3)/ARRAY(III+2)))
14880     PSTOR1=DABS(PSTOR1)
14881     PSTOR2=DSQRT(1.D0-ARRAY(III+4)*ARRAY(III+4))* DSIN(DATAN(ARRAY
14882     + (III+3)/ARRAY(III+2)))
14883     PSTOR2=DABS(PSTOR2)
14884     IF(ARRAY(III+2).LT.0.) PSTOR1=-PSTOR1
14885     IF(ARRAY(III+3).LT.0.) PSTOR2=-PSTOR2
14886     C SETTING UP MODIFIED PX,PY TO PRESERVE THE AZIMUTHAL ANGLE
14887     ARRAY(III+2)=PSTOR1
14888     ARRAY(III+3)=PSTOR2
14889     C RESTORING CORRECTED X AND Y COSINES
14890     190 CONTINUE
14891     B = ECMOKE + AMASIN*(1.D0-CHEINC)
14892     DO 200 IIV = 1,5
14893     200 B=B-ECMKE(IIV)+PLICIT(IIV)*(CUTCM(IIV)-RESMAS(IIV))
14894     BTOT = BTOT + B
14895     BLANK = 1.D0
14896     BLANK1 = 1.D0/(ECM-CHEINC*AMASIN-B)
14897     DO 210 J = 2,NWDS,8
14898     KTYPE = ARRAY(J)
14899     M9 = (J+6)/8
14900     IF(KTYPE.LE.2)WEIGHT(M9)=(WEIGHT(M9)-CUTCM(KTYPE))/ (EPRCM(M9)
14901     + -CUTCM(KTYPE))
14902     IF(KTYPE.GT.2)WEIGHT(M9)=WEIGHT(M9)/EPRCM(M9)
14903     210 CONTINUE
14904     AMORN=TARMAS+CHEINC*AMASIN - PLICIT(1)*RESMAS(1)-PLICIT(2)*
14905     + RESMAS(2) +(PLICIT(1)+PLICIT(2))*7.0D0-CHEINC*7.D0
14906     C MASS OF RESIDUAL NUCLEUS
14907     IF(AMORN.LE.0.)WHY=1.
14908     C WHY=1 UNSCALED RESIDUAL MASS.LE.0
14909     IF(AMORN.LE.0.) GO TO 220
14910     AMORNT = AMORNT + AMORN
14911     ERN=DSQRT(PX*PX+PY*PY+PZ*PZ+AMORN*AMORN)-AMORN
14912     C ENERGY OF RECOILING NUCLEUS (UNSCALED)
14913     ERNT=ERNT+ERN
14914     C SUMMING TOTAL RECOIL ENERGIES FOR ALL COLLISIONS UNSCALED
14915     ESTAR=EXCIT-ERN-(PLICIT(1)+PLICIT(2)-1.D0*CHEINC)*7.D0
14916     ESTART=ESTART+ESTAR
14917     IF(ESTAR.LT.0.) CHECK7=CHECK7+1.
14918     IF(ESTAR.LT.0.) GO TO 270
14919     GO TO 290
14920     220 NMLTEO=NMLTEO+1
14921     ZKZ = ZKZ - 1.D0
14922     230 BTOT = BTOT - B
14923     DO 240 III = 2,NWDS,8
14924     KTYPE = ARRAY(III)
14925     YIELD(KTYPE)=YIELD(KTYPE)-1.D0
14926     AVERE(KTYPE)=AVERE(KTYPE)-BRRAY(III+1)+(CUTL(KTYPE)- RESMAS(KT
14927     + YPE))
14928     240 CONTINUE
14929     GO TO 60
14930     250 DO 260 III = 2,NWDS,8
14931     KTYPE = ARRAY(III)
14932     M8 = (III+6)/8
14933     YIELD(KTYPE)=YIELD(KTYPE)-1.D0
14934     AVERE(KTYPE)=AVERE(KTYPE)-BRRAY(III+1)+(CUTL(KTYPE)- RESMAS(KT
14935     + YPE))
14936     YIELD(KTYPE+5) = YIELD(KTYPE+5) - WEIGHT(M8)
14937     AVERE(KTYPE+5)=AVERE(KTYPE+5)-ARRAY(III+1)*WEIGHT(M8)+ (CUTL(K
14938     + TYPE)-RESMAS(KTYPE))*WEIGHT(M8)
14939     260 CONTINUE
14940     BTOT = BTOT-B
14941     ZKZ = ZKZ - 1.D0
14942     ERNT=ERNT-ERN
14943     ESTART=ESTART-ESTAR
14944     AMORNT=AMORNT-AMORN
14945     GO TO 60
14946     270 ERNT = ERNT - ERN
14947     ERN = ERN+ESTAR
14948     ESTART = ESTART-ESTAR
14949     ERNT=ERNT+ERN
14950     ESTAR=0.
14951     IF(ERN.LT.0.) COUNT5 = COUNT5 + 1.
14952     IF(ERN.LT.0.)WHY=2
14953     C WHY=2 ENERGY OF UNSCALED RECOILING NUCLEUS.LT.0 WHEN ESTAR.LT.0.
14954     C ERN=ERN+ESTAR.......ERN.LT.0
14955     IF(ERN.GE.0.) GO TO 290
14956     ZKZ=ZKZ-1.D0
14957     AMORNT=AMORNT-AMORN
14958     BTOT=BTOT-B
14959     ERNT=ERNT-ERN
14960     DO 280 III=2,NWDS,8
14961     KTYPE=ARRAY(III)
14962     YIELD(KTYPE)=YIELD(KTYPE)-1.D0
14963     AVERE(KTYPE)=AVERE(KTYPE)-BRRAY(III+1)+(CUTL(KTYPE)- RESMAS(KT
14964     + YPE))
14965     280 CONTINUE
14966     GO TO 60
14967     290 CONTINUE
14968     C*****CALCULATIONS DEALING WITH SCALED UP NUCLEAR RECOIL AND BPR********
14969     A1=0.
14970     A2=0.
14971     A3=0.
14972     A4=0.
14973     A5=0.
14974     DO 300 III=2,NWDS,8
14975     M8=(III+6)/8
14976     KTYPE=ARRAY(III)
14977     P=((ARRAY(III+1)+RESMAS(KTYPE))**2-RESMAS(KTYPE)**2)**.5
14978     A1=P*ARRAY(III+2)*WEIGHT(M8)+A1
14979     A2=P*ARRAY(III+3)*WEIGHT(M8)+A2
14980     A3=P*ARRAY(III+4)*WEIGHT(M8)+A3
14981     A4=(ARRAY(III+1)+RESMAS(KTYPE))*WEIGHT(M8)+A4
14982     IF(KTYPE.GT.2.) GO TO 300
14983     A5=(7.D0-RESMAS(KTYPE))*WEIGHT(M8)+A5
14984     300 CONTINUE
14985     A11=A1*A1+A2*A2+A3*A3+A5*A5-A4*A4
14986     B11=2.D0*((TARMAS+(AMASIN-7.D0)*CHEINC)*A5-AMOIPR*A3+A4*(ETOTPR
14987     + +TARMAS-ESTAR))
14988     C11=AMOIPR*AMOIPR+(TARMAS+(AMASIN-7.D0)*CHEINC)**2
14989     + -(ETOTPR+TARMAS-ESTAR)**2
14990     IF(A11.EQ.0.) COUNT1=COUNT1 + 1.
14991     IF(A11.EQ.0.) GO TO 310
14992     ANSPLU=(-B11+DSQRT(B11**2-4.D0*A11*C11))/(2.D0*A11)
14993     ANSMIN=(-B11-DSQRT(B11**2-4.D0*A11*C11))/(2.D0*A11)
14994     GO TO 320
14995     310 ANSWER=-C11/B11
14996     IF(ANSWER.LE.0.) COUNT2=COUNT2+1.
14997     IF(ANSWER.LE.0.) WHY=3
14998     C SOLUTION TO ENERGY BALANCE EQUATION IS .LE. 0.
14999     IF(ANSWER.LE.0.) GO TO 350
15000     ANSMIN=ANSWER
15001     ANSPLU=ANSWER
15002     C$$$$$PUT IN CHECK
15003     320 SCORE=0.
15004     CHECK=0.
15005     DO 340 I=1,2
15006     A1=0.
15007     A2=0.
15008     A3=0.
15009     A4=0.
15010     A5=0.
15011     ANSWER=ANSPLU
15012     IF(I.EQ.2) ANSWER=ANSMIN
15013     DO 330 III=2,NWDS,8
15014     M8=(III+6)/8
15015     KTYPE=ARRAY(III)
15016     P=((ARRAY(III+1)+RESMAS(KTYPE))**2-RESMAS(KTYPE)**2)**.5
15017     A6=ANSWER*WEIGHT(M8)
15018     A1=A1+P*ARRAY(III+2)*A6
15019     A2=A2+P*ARRAY(III+3)*A6
15020     A3=A3+P*ARRAY(III+4)*A6
15021     IF(KTYPE.LT.3) A4=A4+(7.D0-RESMAS(KTYPE))*A6
15022     A5 = A5 + (ARRAY(III+1)+RESMAS(KTYPE))*WEIGHT(M8)
15023     330 CONTINUE
15024     A7=A1*A1+A2*A2+(AMOIPR-A3)**2+(TARMAS+(AMASIN-7.D0)*CHEINC
15025     + +A4)**2
15026     A7=DSQRT(A7)
15027     D1 = (ETOTPR + TARMAS - ESTAR - A7)/A5
15028     STO =DABS((ANSWER-D1)/ANSWER)
15029     IF(I.EQ.1) A8=A7
15030     IF(I.EQ.1) STOO = STO
15031     IF(STO.LE..00001) COUNT3 = COUNT3 + 1.
15032     IF(STO.LE..00001) CHECK=I
15033     IF(STO.LE..00001) SCORE=SCORE+1.
15034     340 CONTINUE
15035     IF(SCORE.EQ.0.) WHY=5
15036     C WHY=5 ENERGY EQUATION NOT SATISFIED
15037     IF(SCORE.NE.0.) GO TO 360
15038     350 ZKZ = ZKZ-1.D0
15039     NTTME=NTTME+1
15040     ERNT=ERNT-ERN
15041     ESTART=ESTART-ESTAR
15042     AMORNT=AMORNT-AMORN
15043     GO TO 230
15044     360 CONTINUE
15045     IF(SCORE.EQ.2.) GO TO 370
15046     IF(CHECK.EQ.1.D0) ANSWER = ANSPLU
15047     IF(ANSWER.LE.0.) COUNT2=COUNT2+1.
15048     IF(ANSWER.LE.0.) WHY=3
15049     IF(ANSWER.LT.0.) GO TO 350
15050     GO TO 390
15051     370 IF(ANSPLU.GT.0.AND.ANSMIN.GT.0.) GO TO 380
15052     IF(ANSPLU.GT.0.) ANSWER=ANSPLU
15053     IF(ANSMIN.GT.0.) ANSWER=ANSMIN
15054     GO TO 390
15055     380 IF(A8.LT.A7) ANSWER=ANSPLU
15056     IF(ANSWER.LE.0.) COUNT2=COUNT2+1.
15057     IF(ANSWER.LE.0.) WHY=3
15058     IF(ANSWER.LE.0.) GO TO 350
15059     390 D1=0.
15060     DO 410 III=2,NWDS,8
15061     KTYPE=ARRAY(III)
15062     M8=(III+6)/8
15063     WEIGHT(M8)=ANSWER*WEIGHT(M8)
15064     IF(KTYPE.GT.2) GO TO 400
15065     D1=D1+WEIGHT(M8)*RESMAS(KTYPE)-7.D0*WEIGHT(M8)
15066     P=((ARRAY(III+1)+RESMAS(KTYPE))**2-RESMAS(KTYPE)**2)**.5
15067     400 CONTINUE
15068     AVERE(KTYPE+5)=AVERE(KTYPE+5)+ARRAY(III+1)*WEIGHT(M8)- (CUTL(K
15069     + TYPE)-RESMAS(KTYPE))*WEIGHT(M8)
15070     C CALCULATION FOR SCALED-UP ENERGY
15071     YIELD(KTYPE+5)=YIELD(KTYPE+5)+WEIGHT(M8)
15072     C CALCULATION FOR MULTIPLICITY OF SCALED-UP PARTICLES
15073     PXS=PXS+WEIGHT(M8)*P*ARRAY(III+2)
15074     PYS=PYS+WEIGHT(M8)*P*ARRAY(III+3)
15075     PZS=PZS-WEIGHT(M8)*P*ARRAY(III+4)
15076     410 CONTINUE
15077     BARB=TARMAS+(AMASIN-7.D0)*CHEINC-D1
15078     IF(BARB.LE.0.) COUNT4=COUNT4+1.
15079     IF(BARB.LE.0.)WHY=4.
15080     C WHY=4 SCALED UP RESIDUAL MASS LE.0
15081     IF(BARB.LE.0.) GO TO 250
15082     ERNPR=(PXS*PXS+PYS*PYS+PZS*PZS+(TARMAS+(AMASIN-7.D0)*CHEINC-D1)**2
15083     +)**.5-TARMAS-(AMASIN-7.D0)*CHEINC+D1
15084     ERNPRT=ERNPR+ERNPRT
15085     BTOTPR=BTOTPR+ECMPR-ANSWER/BLANK1-RESMAS(IPIN)*CHEINC
15086     AMRNST = AMRNST + (TARMAS+(AMASIN-7.D0)*CHEINC-D1)
15087     RMFAS=BARB
15088     REFAS=ERNPR
15089     EXFAS=ESTAR
15090     NOFAS=NOSLO
15091     C*****END CALCULATIONS DEALING WITH SCALED UP NUCLEAR RECOIL AND BPR****
15092     420 CONTINUE
15093     DO 430 III=2,NWDS,8
15094     M8=(III+6)/8
15095     EFAS(M8)=ARRAY(III+1)
15096     ALPFAS(M8)=ARRAY(III+2)
15097     BETFAS(M8)=ARRAY(III+3)
15098     GAMFAS(M8)=ARRAY(III+4)
15099     WTFAS(M8)=WEIGHT(M8)
15100     430 CONTINUE
15101     RETURN
15102     440 DO 450 IHK=1,10
15103     NUMBEA(IHK)=NUMBEA(IHK)/ZKZ
15104     EINCT(IHK)=EINCT(IHK)/ZKZ
15105     YIELD(IHK)=YIELD(IHK)/ZKZ
15106     AVERE(IHK)=AVERE(IHK)/ZKZ
15107     450 CONTINUE
15108     ESTART = ESTART/ZKZ
15109     TARMAT=TARMAT/ZKZ
15110     BTOTPR=BTOTPR/ZKZ
15111     AMORNT = AMORNT/ZKZ
15112     AMRNST = AMRNST/ZKZ
15113     ERNT=ERNT/ZKZ
15114     ERNPRT=ERNPRT/ZKZ
15115     BTOT = BTOT/ZKZ
15116     ETOT=0.
15117     ETOTPR=0.
15118     DO 460 I=1,5
15119     ETOT=ETOT+EINCT(I)+RESMAS(I)*NUMBEA(I)
15120     ETOTPR=ETOTPR+EINCT(I+5)+RESMAS(I)*NUMBEA(I+5)
15121     460 CONTINUE
15122     ESUM = 0.0
15123     ESUMPR = 0.0
15124     DO 470 I = 1,5
15125     ESUM = ESUM + AVERE(I)
15126     ESUMPR = ESUMPR + AVERE(I+5)
15127     470 CONTINUE
15128     RETURN
15129     END
15130     *CMZ : 0.93/08 02/03/93 09.35.17 by Christian Zeitnitz
15131     *-- Author :
15132     SUBROUTINE SHXSEC(E,INC,SIGT,SIGEL,SIGNEL)
15133     C
15134     #include "cinout.inc"
15135     *KEND.
15136     C
15137     C CALCULATES PROTON AND NEUTRON CROSS SECTIONS FOR E > 3.5 GeV
15138     C CALCULATES PI+ AND PI- CROSS SECTIONS FOR E > 2.5 GeV
15139     C THE TARGET PARTICLE IS A PROTON
15140     C E ------- KINETIC ENERGY OF INCIDENT PARTICLE(MEV)
15141     C INC ----- TYPE OF INCIDENT PARTICLE
15142     C 0 -- PROTON
15143     C 1 NEUTRON
15144     C 2 PI+
15145     C 3 NOT USED
15146     C 4 PI-
15147     C SIGT ---- TOTAL CROSS SECTION(CM**2)
15148     C SIGEL --- ELASTIC CROSS SECTION(CM**2)
15149     C SIGNEL -- NONELASTIC CROSS SECTION(CM**2)
15150     C
15151     REAL*8 E1
15152     IN = INC + 1
15153     E1 = E*1.D-3
15154     GO TO (20,30,50,10,80),IN
15155     10 CALL CERROR('CRSEC1')
15156     C
15157     20 SIGT = 37.5D0 + 7.D0/(DSQRT(E1))
15158     SIGEL = 7.D0 + 21.03D0/(E1**0.873D0)
15159     GO TO 110
15160     C
15161     C
15162     30 IF(E1.GT.8.D0) GO TO 40
15163     SIGT = 42.D0
15164     SIGEL = -0.222D0*E1+12.48D0
15165     GO TO 110
15166     40 SIGT = 37.5D0 + 26.45D0/(E1**0.852D0)
15167     SIGEL = 6.0D0 + 73.144D0/(E1**1.32D0)
15168     GO TO 110
15169     C
15170     C
15171     50 IF(E1.GT.3.D0) GO TO 60
15172     SIGT = -4.66D0*E1 + 42.95D0
15173     SIGEL = -1.40D0*E1 + 10.0D0
15174     GO TO 110
15175     60 IF(E1.GT.6.D0) GO TO 70
15176     SIGT = -0.7567D0*E1 + 31.24D0
15177     SIGEL = -0.166D0*E1 + 6.298D0
15178     GO TO 110
15179     70 SIGT = 21.50D0 + 18.914D0/(E1**.7155D0)
15180     SIGEL = 3.5D0 + 9.93D0/(E1**.953D0)
15181     GO TO 110
15182     C
15183     C
15184     80 IF(E1.GT.5.D0) GO TO 90
15185     SIGT = -1.66D0*E1 + 37.34D0
15186     GO TO 100
15187     90 SIGT = 23.60D0 + 25.51D0/(E1**0.959D0)
15188     100 SIGEL = 3.8D0 + 7.273D0/(E1**0.896D0)
15189     C
15190     C
15191     110 SIGT = SIGT*1.E-27
15192     SIGEL = SIGEL*1.E-27
15193     SIGNEL = SIGT - SIGEL
15194     C
15195     IF((IN.LE.2).AND.(E1.LT.3.4949D0)) WRITE(IO,10000) E1
15196     IF((IN.GT.2).AND.(E1.LT.2.4949D0)) WRITE(IO,10100) E1
15197     10000 FORMAT(' HETC: PROTON OR NEUTRON CROSS-SECTIONS ARE BEING
15198     + REQUESTED FOR AN ENERGY LESS THAN 3.5-GEV in SHXSEC E=',G18.7)
15199     10100 FORMAT(' HETC: PI+ OR PI- CROSS-SECTIONS ARE BEING REQUESTED
15200     + FOR AN ENERGY LESS THAN 2.5-GEV in SHXSEC E=',G18.7)
15201     RETURN
15202     END
15203     *CMZ : 1.01/04 10/06/93 14.43.50 by Christian Zeitnitz
15204     *-- Author : Christian Zeitnitz 19/11/92
15205     SUBROUTINE SKALEH(IBERT,ITINC,HSIG,EINC,NOFAS,ITFAS,EFAS,ALPHAS,
15206     + BETFAS,GAMFAS,EHICUT)
15207     C
15208     #include "cmass.inc"
15209     *KEND.
15210     DIMENSION ITFAS(*), EFAS(*) , ALPHAS(*) , BETFAS(*) , GAMFAS(*)
15211     DIMENSION R(60)
15212     SAVE
15213     C
15214     ITYPE = ITINC + 1
15215     CALL CPCOL(IBERT,ITYPE,HSIG,EHICUT,NOFAS,ITFAS,EFAS,ALPFAS,BETFAS,
15216     + GAMFAS)
15217     IF(NOFAS.LE.0) RETURN
15218     CZ simple scaling for H-collision, conserve energy 19 Nov. 1992
15219     EI=EINC+PMASS(ITINC+1)
15220     ESUMF = 0.0
15221     DO 10 I=1,NOFAS
15222     ESUMF=ESUMF+PMASS(ITFAS(I)+1)+EFAS(I)
15223     10 CONTINUE
15224     EDIV = EI-ESUMF
15225     IF(EDIV.LE.0.0) RETURN
15226     CALL GRNDM(R,NOFAS)
15227     RS=0.0
15228     DO 20 I=1,NOFAS
15229     RS=RS+R(I)
15230     20 CONTINUE
15231     DO 30 I=1,NOFAS
15232     EFAS(I) = EFAS(I)+R(I)/RS*EDIV
15233     30 CONTINUE
15234     RETURN
15235     END
15236     *CMZ : 0.93/01 08/02/93 14.21.45 by Christian Zeitnitz
15237     *-- Author :
15238     SUBROUTINE CSCATT(INC,EKE1,ITFAS,EFAS,ALPFAS,BETFAS,GAMFAS)
15239     C
15240     C
15241     C INC = TYPE OF INCIDENT PARTICLE
15242     C = 0 PROTON
15243     C = 1 NEUTRON
15244     C = 2 PI +
15245     C = 3 NOT USED
15246     C = 4 PI -
15247     C EKE1 = KINETIC ENERGY OF INCIDENT PARTICLE(MEV)
15248     C ITFAS = TYPE OF PARTICLE (SAME AS ABOVE)
15249     C EFAS = KINETIC ENERGY OF PARTICLES (MEV)
15250     C ALPFAS = X-DIRECTION COSINE
15251     C BETFAS = Y-DIRECTION COSINE
15252     C GAMFAS = Z-DIRECTION COSINE
15253     C RANDS = LOCATION OF RANDOM NUMBER SEQUENCE
15254     C
15255     C SUBROUTINES CALLED CAAZIO.
15256     C
15257     DIMENSION ITFAS(2),EFAS(2),ALPFAS(2),BETFAS(2),GAMFAS(2),RANDS(4)
15258     REAL*8 B,M1,M2,E1,P1,ECM1,PCM1,ETLAB,ETCM,BETA,GAMMA,T1,T2,T3,T4,
15259     1 T5,T6,T7,T8,T9,T10,T11,T12,PLAB1,PLAB2,CST,SNT,TB
15260     #include "crandm.inc"
15261     *KEND.
15262     C
15263     DATA M2/940.075D0/
15264     SAVE
15265     C
15266     T2 = M2*M2
15267     IN=INC+1
15268     GO TO (10,10,20,30,40),IN
15269     10 M1=940.075D0
15270     GO TO 60
15271     20 B=7.040D-6
15272     GO TO 50
15273     30 CALL CERROR('SCATT1')
15274     40 B=7.575D-6
15275     50 M1=139.89D0
15276     60 E1=EKE1+M1
15277     T1=M1*M1
15278     P1=DSQRT(E1*E1-T1)
15279     IF(IN.GT.2) GO TO 70
15280     B=7.26D-6+ (3.13D-11)*P1
15281     70 ETLAB=E1+M2
15282     BETA=P1/ETLAB
15283     GAMMA=1.D0/DSQRT(1.D0-BETA*BETA)
15284     ETCM=ETLAB/GAMMA
15285     T3=T1+T2
15286     T4=T1-T2
15287     T4=T4*T4
15288     T5=ETCM*ETCM
15289     T6=T5*T5
15290     T7=B*(T6-2.D0*T5*T3+T4)/(2.D0*T5)
15291     T8 = RANDC(ISEED)
15292     TB=T7
15293     IF(T7.GT.50.D0) TB=50.D0
15294     CST=1.D0+(DLOG(1.D0-T8*(1.D0-DEXP(-TB))))/T7
15295     SNT=DSQRT(1.D0-CST*CST)
15296     CALL CAAZIO(T9,T10)
15297     ECM1=(T5+T1-T2)/(2.D0*ETCM )
15298     PCM1=DSQRT(ECM1*ECM1-T1)
15299     ITFAS(1)=INC
15300     ITFAS(2)=0.
15301     T11 = GAMMA*(ECM1+PCM1*CST*BETA) - M1
15302     T12 = ETLAB - T11 -M1 - M2
15303     PLAB1 = DSQRT(2.D0*M1*T11 + T11*T11)
15304     PLAB2 = DSQRT(2.D0*M2*T12 + T12*T12)
15305     EFAS(1) = T11
15306     EFAS(2) = T12
15307     ALPFAS(1)=PCM1*SNT*T9
15308     ALPFAS(2)= -ALPFAS(1)
15309     ALPFAS(1)=ALPFAS(1)/PLAB1
15310     ALPFAS(2)=ALPFAS(2)/PLAB2
15311     BETFAS(1)=PCM1*SNT*T10
15312     BETFAS(2)=-BETFAS(1)
15313     BETFAS(1)=BETFAS(1)/PLAB1
15314     BETFAS(2)=BETFAS(2)/PLAB2
15315     GAMFAS(1)= GAMMA*(PCM1*CST+BETA*ECM1)
15316     GAMFAS(2)= -GAMFAS(1)+P1
15317     GAMFAS(1)= GAMFAS(1)/PLAB1
15318     GAMFAS(2)= GAMFAS(2)/PLAB2
15319     RETURN
15320     END
  ViewVC Help
Powered by ViewVC 1.1.23