[u/mrichter/AliRoot.git] / GEANT321 / gheisha / casn.F

*
* $Id$
*
* $Log$
* Revision 1.1.1.1  1995/10/24 10:21:00  cernlib
* Geant
*
*
#include "geant321/pilot.h"
*CMZ :  3.21/02 29/03/94  15.41.38  by  S.Giani
*-- Author :
      SUBROUTINE CASN(K,INT,NFL)
C
C *** CASCADE OF NEUTRON ***
C *** NVE 04-MAY-1988 CERN GENEVA ***
C
C ORIGIN : H.FESEFELDT (13-SEP-1987)
C
C N  UNDERGOES INTERACTION WITH NUCLEON WITHIN NUCLEUS.
C CHECK IF ENERGETICALLY POSSIBLE TO PRODUCE PIONS/KAONS.
C IF NOT ASSUME NUCLEAR EXCITATION OCCURS AND INPUT PARTICLE
C IS DEGRADED IN ENERGY.    NO OTHER PARTICLES PRODUCED.
C IF REACTION IS POSSIBLE FIND CORRECT NUMBER OF PIONS/PROTONS/
C NEUTRONS PRODUCED USING AN INTERPOLATION TO MULTIPLICITY DATA.
C REPLACE SOME PIONS OR PROTONS/NEUTRONS BY KAONS OR STRANGE BARYONS
C ACCORDING TO AVERAGE MULTIPLICITY PER INELASTIC REACTIONS.
C
#include "geant321/mxgkgh.inc"
#include "geant321/s_consts.inc"
#include "geant321/s_curpar.inc"
#include "geant321/s_result.inc"
#include "geant321/s_prntfl.inc"
#include "geant321/limits.inc"
#include "geant321/s_kginit.inc"
C
      REAL N
      DIMENSION PMUL(2,1200),ANORM(2,60),SUPP(10),CECH(10),B(2)
      DIMENSION RNDM(1)
      SAVE PMUL,ANORM
      DATA SUPP/0.,0.4,0.55,0.65,0.75,0.82,0.86,0.90,0.94,0.98/
      DATA CECH/0.50,0.45,0.40,0.35,0.30,0.25,0.06,0.04,0.005,0./
      DATA B/0.35,0.0/,C/1.25/
C
C --- INITIALIZATION INDICATED BY KGINIT(17) ---
      IF (KGINIT(17) .NE. 0) GO TO 10
      KGINIT(17)=1
C
C --- INITIALIZE PMUL AND ANORM ARRAYS ---
      DO 9000 J=1,1200
      DO 9001 I=1,2
      PMUL(I,J)=0.0
      IF (J .LE. 60) ANORM(I,J)=0.0
 9001 CONTINUE
 9000 CONTINUE
C
C** COMPUTE NORMALIZATION CONSTANTS
C** FOR N AS TARGET
C
      L=0
      DO 1 NP1=1,20
      NP=NP1-1
      NPP1=NP1+2
      DO 1 NM1=NP1,NPP1
      NM=NM1-1
      DO 1 NZ1=1,20
      NZ=NZ1-1
      L=L+1
      IF(L.GT.1200) GOTO 1
      NPROT= -NP+NM
      NNEUT=2-NPROT
      NT=NP+NM+NZ
      IF(NT.LE.0.OR.NT.GT.60) GOTO 1
      PMUL(1,L)=PMLTPC(NP,NM,NZ,NT,B(2),C)
      NPROTF=NFAC(NPROT)
      NNEUTF=NFAC(NNEUT)
      PMUL(1,L)=PMUL(1,L)/(NPROTF*NNEUTF)
      ANORM(1,NT)=ANORM(1,NT)+PMUL(1,L)
    1 CONTINUE
C** FOR P AS TARGET
      L=0
      DO 2 NP1=1,20
      NP=NP1-1
      NMM1=NP1-1
      IF(NMM1.LE.1) NMM1=1
      NPP1=NP1+1
      DO 2 NM1=NMM1,NPP1
      NM=NM1-1
      DO 2 NZ1=1,20
      NZ=NZ1-1
      L=L+1
      IF(L.GT.1200) GOTO 2
      NPROT=1-NP+NM
      NNEUT=2-NPROT
      NT=NP+NM+NZ
      IF(NT.LE.0.OR.NT.GT.60) GOTO 2
      PMUL(2,L)=PMLTPC(NP,NM,NZ,NT,B(1),C)
      NPROTF=NFAC(NPROT)
      NNEUTF=NFAC(NNEUT)
      PMUL(2,L)=PMUL(2,L)/(NPROTF*NNEUTF)
      ANORM(2,NT)=ANORM(2,NT)+PMUL(2,L)
    2 CONTINUE
      DO 3 I=1,60
      IF(ANORM(1,I).GT.0.) ANORM(1,I)=1./ANORM(1,I)
      IF(ANORM(2,I).GT.0.) ANORM(2,I)=1./ANORM(2,I)
    3 CONTINUE
      IF(.NOT.NPRT(10)) GOTO 10
      WRITE(NEWBCD,2001)
      DO 4 NFL=1,2
      WRITE(NEWBCD,2002) NFL
      WRITE(NEWBCD,2003) (ANORM(NFL,I),I=1,60)
      WRITE(NEWBCD,2003) (PMUL(NFL,I),I=1,1200)
    4 CONTINUE
C**  CHOOSE PROTON OR NEUTRON AS TARGET
   10 NFL=2
      CALL GRNDM(RNDM,1)
      IF(RNDM(1).LT.ZNO2/ATNO2) NFL=1
      TARMAS=RMASS(14)
      IF (NFL .EQ. 2) TARMAS=RMASS(16)
      S=AMASQ+TARMAS**2+2.0*TARMAS*EN
      RS=SQRT(S)
      ENP(8)=AMASQ+TARMAS**2+2.0*TARMAS*ENP(6)
      ENP(9)=SQRT(ENP(8))
      EAB=RS-TARMAS-RMASS(16)
C**  ELASTIC SCATTERING
      NP=0
      NM=0
      NZ=0
      N=0.
      NCECH=0
      IF(INT.EQ.2) GOTO 20
C** INTRODUCE CHARGE EXCHANGE REACTION PN --> NP
      IF(NFL.EQ.2) GOTO 100
      IPLAB=IFIX(P*2.5)+1
      IF(IPLAB.GT.10) IPLAB=10
      CALL GRNDM(RNDM,1)
      IF(RNDM(1).GT.CECH(IPLAB)/ATNO2**0.42) GOTO 100
      NCECH=1
      GOTO 100
C**  CHECK IF ENERGETICALLY POSSIBLE TO PRODUCE ONE EXTRA PION IN REACT.
  20  IF (EAB .LE. RMASS(7)) GOTO 55
C**  SUPPRESSION OF HIGH MULTIPLICITY EVENTS AT LOW MOMENTUM
      IEAB=IFIX(EAB*5.)+1
      IF(IEAB.GT.10) GOTO 22
      CALL GRNDM(RNDM,1)
      IF(RNDM(1).LT.SUPP(IEAB)) GOTO 22
      N=1.
      GOTO (24,23),NFL
 23   CONTINUE
      TEST=-(1+B(2))**2/(2.0*C**2)
      IF (TEST .GT. EXPXU) TEST=EXPXU
      IF (TEST .LT. EXPXL) TEST=EXPXL
      W0=EXP(TEST)/2.0
      WM=EXP(TEST)
      CALL GRNDM(RNDM,1)
      RAN=RNDM(1)
      NP=0
      NM=0
      NZ=1
      IF(RAN.LT.W0/(W0+WM)) GOTO 100
      NP=0
      NM=1
      NZ=0
      GOTO 100
 24   CONTINUE
      TEST=-(1+B(1))**2/(2.0*C**2)
      IF (TEST .GT. EXPXU) TEST=EXPXU
      IF (TEST .LT. EXPXL) TEST=EXPXL
      W0=EXP(TEST)
      WP=EXP(TEST)/2.0
      TEST=-(-1+B(1))**2/(2.0*C**2)
      IF (TEST .GT. EXPXU) TEST=EXPXU
      IF (TEST .LT. EXPXL) TEST=EXPXL
      WM=EXP(TEST)/2.0
      WT=W0+WP+WM
      WP=W0+WP
      CALL GRNDM(RNDM,1)
      RAN=RNDM(1)
      NP=0
      NM=0
      NZ=1
      IF(RAN.LT.W0/WT) GOTO 100
      NP=1
      NM=0
      NZ=0
      IF(RAN.LT.WP/WT) GOTO 100
      NP=0
      NM=1
      NZ=0
      GOTO 100
C
   22 ALEAB=LOG(EAB)
C** NO. OF TOTAL PARTICLES VS SQRT(S)-2*MP
      N=3.62567+0.665843*ALEAB+0.336514*ALEAB*ALEAB
     * +0.117712*ALEAB*ALEAB*ALEAB+0.0136912*ALEAB*ALEAB*ALEAB*ALEAB
      N=N-2.
C** NORMALIZATION CONSTANT FOR  KNO-DISTRIBUTION
      ANPN=0.
      DO 21 NT=1,60
      TEST=-(PI/4.0)*(NT/N)**2
      IF (TEST .GT. EXPXU) TEST=EXPXU
      IF (TEST .LT. EXPXL) TEST=EXPXL
      ANPN=ANPN+PI*NT*EXP(TEST)/(2.0*N*N)
   21 CONTINUE
      ANPN=1./ANPN
C** P OR N AS TARGET
      CALL GRNDM(RNDM,1)
      RAN=RNDM(1)
      EXCS=0.
      GOTO (40,30),NFL
C** FOR N AS TARGET
   30 L=0
      DO 31 NP1=1,20
      NP=NP1-1
      NPP1=NP1+2
      DO 31 NM1=NP1,NPP1
      NM=NM1-1
      DO 31 NZ1=1,20
      NZ=NZ1-1
      L=L+1
      IF(L.GT.1200) GOTO 31
      NT=NP+NM+NZ
      IF(NT.LE.0.OR.NT.GT.60) GOTO 31
      TEST=-(PI/4.0)*(NT/N)**2
      IF (TEST .GT. EXPXU) TEST=EXPXU
      IF (TEST .LT. EXPXL) TEST=EXPXL
      DUM1=ANPN*PI*NT*PMUL(1,L)*ANORM(1,NT)/(2.0*N*N)
      DUM2=ABS(DUM1)
      DUM3=EXP(TEST)
      ADDNVE=0.0
      IF (DUM2 .GE. 1.0) ADDNVE=DUM1*DUM3
      IF ((DUM2 .LT. 1.0) .AND. (DUM3 .GE. 1.0E-10)) ADDNVE=DUM1*DUM3
      EXCS=EXCS+ADDNVE
      IF(RAN.LT.EXCS) GOTO 100
   31 CONTINUE
      GOTO 80
C** FOR P AS TARGET
   40 L=0
      DO 41 NP1=1,20
      NP=NP1-1
      NMM1=NP1-1
      IF(NMM1.LE.1) NMM1=1
      NPP1=NP1+1
      DO 41 NM1=NMM1,NPP1
      NM=NM1-1
      DO 41 NZ1=1,20
      NZ=NZ1-1
      L=L+1
      IF(L.GT.1200) GOTO 41
      NT=NP+NM+NZ
      IF(NT.LE.0.OR.NT.GT.60) GOTO 41
      TEST=-(PI/4.0)*(NT/N)**2
      IF (TEST .GT. EXPXU) TEST=EXPXU
      IF (TEST .LT. EXPXL) TEST=EXPXL
      DUM1=ANPN*PI*NT*PMUL(2,L)*ANORM(2,NT)/(2.0*N*N)
      DUM2=ABS(DUM1)
      DUM3=EXP(TEST)
      ADDNVE=0.0
      IF (DUM2 .GE. 1.0) ADDNVE=DUM1*DUM3
      IF ((DUM2 .LT. 1.0) .AND. (DUM3 .GE. 1.0E-10)) ADDNVE=DUM1*DUM3
      EXCS=EXCS+ADDNVE
      IF(RAN.LT.EXCS) GOTO 100
   41 CONTINUE
      GOTO 80
   50 IF(NPRT(4))
     *WRITE(NEWBCD,1003) EAB,N,NFL,NP,NM,NZ
      CALL STPAIR
      IF(INT.EQ.1) CALL TWOB(16,NFL,N)
      IF(INT.EQ.2) CALL GENXPT(16,NFL,N)
      GO TO 9999
   55 IF(NPRT(4))
     *WRITE(NEWBCD,1001)
      GOTO 53
C** EXCLUSIVE REACTION NOT FOUND
   80 IF(NPRT(4))
     *WRITE(NEWBCD,1004) RS,N
   53 INT=1
      NP=0
      NM=0
      NZ=0
  100 DO 101 I=1,60
  101 IPA(I)=0
      IF(INT.LE.0) GOTO 131
      NPROT=1-NP+NM+(1-NFL)
      NNEUT=2-NPROT
      GOTO (112,102),NFL
  102 GOTO (103,104),INT
  103 IPA(1)=16
      IPA(2)=16
      NT=2
      GOTO 130
  104 IF(NNEUT.EQ.1) GOTO 105
      IF(NNEUT.EQ.2) GOTO 106
      IPA(1)=14
      IPA(2)=14
      GOTO 120
  105 IPA(1)=14
      IPA(2)=16
      CALL GRNDM(RNDM,1)
      IF(RNDM(1).LT.0.5) GOTO 120
      IPA(1)=16
      IPA(2)=14
      GOTO 120
  106 IPA(1)=16
      IPA(2)=16
      GOTO 120
  112 GOTO (113,114),INT
  113 IPA(1)=16
      IPA(2)=14
      NT=2
      IF(NCECH.EQ.0) GOTO 130
      IPA(1)=14
      IPA(2)=16
      GOTO 130
  114 IF(NNEUT.EQ.1) GOTO 115
      IF(NNEUT.EQ.2) GOTO 116
      IPA(1)=14
      IPA(2)=14
      GOTO 120
  115 IPA(1)=14
      IPA(2)=16
      CALL GRNDM(RNDM,1)
      IF(RNDM(1).LT.0.33) GOTO 120
      IPA(1)=16
      IPA(2)=14
      GOTO 120
  116 IPA(1)=16
      IPA(2)=16
  120 NT=2
      IF(NP.EQ.0) GOTO 122
      DO 121 I=1,NP
      NT=NT+1
  121 IPA(NT)=7
  122 IF(NM.EQ.0) GOTO 124
      DO 123 I=1,NM
      NT=NT+1
  123 IPA(NT)=9
  124 IF(NZ.EQ.0) GOTO 130
      DO 125 I=1,NZ
      NT=NT+1
  125 IPA(NT)=8
  130 IF(NPRT(4))
     *WRITE(NEWBCD,2004) NT,(IPA(I),I=1,20)
      GOTO 50
  131 IF(NPRT(4))
     *WRITE(NEWBCD,2005)
C
1001  FORMAT('0*CASN* CASCADE ENERGETICALLY NOT POSSIBLE NUCLEAR',
     * ' EXCITATION',2X,F8.4,2X,'INCIDENT ENERGY LOST')
1003  FORMAT(' *CASN* NEUTRON-INDUCED CASCADE,',
     $ ' AVAIL. ENERGY',2X,F8.4,
     $ 2X,'<NTOT>',2X,F8.4,2X,'FROM',4(2X,I3),2X,'PARTICLES')
1004  FORMAT(' *CASN* NEUTRON-INDUCED CASCADE,',
     $ ' EXCLUSIVE REACTION NOT FOUND',
     $ ' TRY ELASTIC SCATTERING  AVAIL. ENERGY',2X,F8.4,2X,
     $ '<NTOT>',2X,F8.4)
2001  FORMAT('0*CASN* TABLES FOR MULT. DATA NEUTRON INDUCED REACTION',
     $ ' FOR DEFINITION OF NUMBERS SEE FORTRAN CODING')
2002  FORMAT(' *CASN* TARGET PARTICLE FLAG',2X,I5)
2003  FORMAT(1H ,10E12.4)
2004  FORMAT(' *CASN* ',I3,2X,'PARTICLES , MASS INDEX ARRAY',2X,20I4)
2005  FORMAT(' *CASN* NO PARTICLES PRODUCED')
C
 9999 CONTINUE
      END
Commit	Line	Data
fe4da5cc	1	*
	2	* $Id$
	3	*
	4	* $Log$
	5	* Revision 1.1.1.1 1995/10/24 10:21:00 cernlib
	6	* Geant
	7	*
	8	*
	9	#include "geant321/pilot.h"
	10	*CMZ : 3.21/02 29/03/94 15.41.38 by S.Giani
	11	*-- Author :
	12	SUBROUTINE CASN(K,INT,NFL)
	13	C
	14	C * CASCADE OF NEUTRON *
	15	C * NVE 04-MAY-1988 CERN GENEVA *
	16	C
	17	C ORIGIN : H.FESEFELDT (13-SEP-1987)
	18	C
	19	C N UNDERGOES INTERACTION WITH NUCLEON WITHIN NUCLEUS.
	20	C CHECK IF ENERGETICALLY POSSIBLE TO PRODUCE PIONS/KAONS.
	21	C IF NOT ASSUME NUCLEAR EXCITATION OCCURS AND INPUT PARTICLE
	22	C IS DEGRADED IN ENERGY. NO OTHER PARTICLES PRODUCED.
	23	C IF REACTION IS POSSIBLE FIND CORRECT NUMBER OF PIONS/PROTONS/
	24	C NEUTRONS PRODUCED USING AN INTERPOLATION TO MULTIPLICITY DATA.
	25	C REPLACE SOME PIONS OR PROTONS/NEUTRONS BY KAONS OR STRANGE BARYONS
	26	C ACCORDING TO AVERAGE MULTIPLICITY PER INELASTIC REACTIONS.
	27	C
	28	#include "geant321/mxgkgh.inc"
	29	#include "geant321/s_consts.inc"
	30	#include "geant321/s_curpar.inc"
	31	#include "geant321/s_result.inc"
	32	#include "geant321/s_prntfl.inc"
	33	#include "geant321/limits.inc"
	34	#include "geant321/s_kginit.inc"
	35	C
	36	REAL N
	37	DIMENSION PMUL(2,1200),ANORM(2,60),SUPP(10),CECH(10),B(2)
	38	DIMENSION RNDM(1)
	39	SAVE PMUL,ANORM
	40	DATA SUPP/0.,0.4,0.55,0.65,0.75,0.82,0.86,0.90,0.94,0.98/
	41	DATA CECH/0.50,0.45,0.40,0.35,0.30,0.25,0.06,0.04,0.005,0./
	42	DATA B/0.35,0.0/,C/1.25/
	43	C
	44	C --- INITIALIZATION INDICATED BY KGINIT(17) ---
	45	IF (KGINIT(17) .NE. 0) GO TO 10
	46	KGINIT(17)=1
	47	C
	48	C --- INITIALIZE PMUL AND ANORM ARRAYS ---
	49	DO 9000 J=1,1200
	50	DO 9001 I=1,2
	51	PMUL(I,J)=0.0
	52	IF (J .LE. 60) ANORM(I,J)=0.0
	53	9001 CONTINUE
	54	9000 CONTINUE
	55	C
	56	C** COMPUTE NORMALIZATION CONSTANTS
	57	C** FOR N AS TARGET
	58	C
	59	L=0
	60	DO 1 NP1=1,20
	61	NP=NP1-1
	62	NPP1=NP1+2
	63	DO 1 NM1=NP1,NPP1
	64	NM=NM1-1
65	DO 1 NZ1=1,20
66	NZ=NZ1-1
67	L=L+1
68	IF(L.GT.1200) GOTO 1
69	NPROT= -NP+NM
70	NNEUT=2-NPROT
71	NT=NP+NM+NZ
72	IF(NT.LE.0.OR.NT.GT.60) GOTO 1
73	PMUL(1,L)=PMLTPC(NP,NM,NZ,NT,B(2),C)
74	NPROTF=NFAC(NPROT)
75	NNEUTF=NFAC(NNEUT)
76	PMUL(1,L)=PMUL(1,L)/(NPROTF*NNEUTF)
77	ANORM(1,NT)=ANORM(1,NT)+PMUL(1,L)
78	1 CONTINUE
79	C** FOR P AS TARGET
80	L=0
81	DO 2 NP1=1,20
82	NP=NP1-1
83	NMM1=NP1-1
84	IF(NMM1.LE.1) NMM1=1
85	NPP1=NP1+1
86	DO 2 NM1=NMM1,NPP1
87	NM=NM1-1
88	DO 2 NZ1=1,20
89	NZ=NZ1-1
90	L=L+1
91	IF(L.GT.1200) GOTO 2
92	NPROT=1-NP+NM
93	NNEUT=2-NPROT
94	NT=NP+NM+NZ
95	IF(NT.LE.0.OR.NT.GT.60) GOTO 2
96	PMUL(2,L)=PMLTPC(NP,NM,NZ,NT,B(1),C)
97	NPROTF=NFAC(NPROT)
98	NNEUTF=NFAC(NNEUT)
99	PMUL(2,L)=PMUL(2,L)/(NPROTF*NNEUTF)
100	ANORM(2,NT)=ANORM(2,NT)+PMUL(2,L)
101	2 CONTINUE
102	DO 3 I=1,60
103	IF(ANORM(1,I).GT.0.) ANORM(1,I)=1./ANORM(1,I)
104	IF(ANORM(2,I).GT.0.) ANORM(2,I)=1./ANORM(2,I)
105	3 CONTINUE
106	IF(.NOT.NPRT(10)) GOTO 10
107	WRITE(NEWBCD,2001)
108	DO 4 NFL=1,2
109	WRITE(NEWBCD,2002) NFL
110	WRITE(NEWBCD,2003) (ANORM(NFL,I),I=1,60)
111	WRITE(NEWBCD,2003) (PMUL(NFL,I),I=1,1200)
112	4 CONTINUE
113	C** CHOOSE PROTON OR NEUTRON AS TARGET
114	10 NFL=2
115	CALL GRNDM(RNDM,1)
116	IF(RNDM(1).LT.ZNO2/ATNO2) NFL=1
117	TARMAS=RMASS(14)
118	IF (NFL .EQ. 2) TARMAS=RMASS(16)
119	S=AMASQ+TARMAS*2+2.0TARMAS*EN
120	RS=SQRT(S)
121	ENP(8)=AMASQ+TARMAS*2+2.0TARMAS*ENP(6)
122	ENP(9)=SQRT(ENP(8))
123	EAB=RS-TARMAS-RMASS(16)
124	C** ELASTIC SCATTERING
125	NP=0
126	NM=0
127	NZ=0
128	N=0.
129	NCECH=0
130	IF(INT.EQ.2) GOTO 20
131	C** INTRODUCE CHARGE EXCHANGE REACTION PN --> NP
132	IF(NFL.EQ.2) GOTO 100
133	IPLAB=IFIX(P*2.5)+1
134	IF(IPLAB.GT.10) IPLAB=10
135	CALL GRNDM(RNDM,1)
136	IF(RNDM(1).GT.CECH(IPLAB)/ATNO2**0.42) GOTO 100
137	NCECH=1
138	GOTO 100
139	C** CHECK IF ENERGETICALLY POSSIBLE TO PRODUCE ONE EXTRA PION IN REACT.
140	20 IF (EAB .LE. RMASS(7)) GOTO 55
141	C** SUPPRESSION OF HIGH MULTIPLICITY EVENTS AT LOW MOMENTUM
142	IEAB=IFIX(EAB*5.)+1
143	IF(IEAB.GT.10) GOTO 22
144	CALL GRNDM(RNDM,1)
145	IF(RNDM(1).LT.SUPP(IEAB)) GOTO 22
146	N=1.
147	GOTO (24,23),NFL
148	23 CONTINUE
149	TEST=-(1+B(2))*2/(2.0C**2)
150	IF (TEST .GT. EXPXU) TEST=EXPXU
151	IF (TEST .LT. EXPXL) TEST=EXPXL
152	W0=EXP(TEST)/2.0
153	WM=EXP(TEST)
154	CALL GRNDM(RNDM,1)
155	RAN=RNDM(1)
156	NP=0
157	NM=0
158	NZ=1
159	IF(RAN.LT.W0/(W0+WM)) GOTO 100
160	NP=0
161	NM=1
162	NZ=0
163	GOTO 100
164	24 CONTINUE
165	TEST=-(1+B(1))*2/(2.0C**2)
166	IF (TEST .GT. EXPXU) TEST=EXPXU
167	IF (TEST .LT. EXPXL) TEST=EXPXL
168	W0=EXP(TEST)
169	WP=EXP(TEST)/2.0
170	TEST=-(-1+B(1))*2/(2.0C**2)
171	IF (TEST .GT. EXPXU) TEST=EXPXU
172	IF (TEST .LT. EXPXL) TEST=EXPXL
173	WM=EXP(TEST)/2.0
174	WT=W0+WP+WM
175	WP=W0+WP
176	CALL GRNDM(RNDM,1)
177	RAN=RNDM(1)
178	NP=0
179	NM=0
180	NZ=1
181	IF(RAN.LT.W0/WT) GOTO 100
182	NP=1
183	NM=0
184	NZ=0
185	IF(RAN.LT.WP/WT) GOTO 100
186	NP=0
187	NM=1
188	NZ=0
189	GOTO 100
190	C
191	22 ALEAB=LOG(EAB)
192	C** NO. OF TOTAL PARTICLES VS SQRT(S)-2*MP
193	N=3.62567+0.665843ALEAB+0.336514ALEAB*ALEAB
194	* +0.117712ALEABALEABALEAB+0.0136912ALEABALEABALEAB*ALEAB
195	N=N-2.
196	C** NORMALIZATION CONSTANT FOR KNO-DISTRIBUTION
197	ANPN=0.
198	DO 21 NT=1,60
199	TEST=-(PI/4.0)(NT/N)*2
200	IF (TEST .GT. EXPXU) TEST=EXPXU
201	IF (TEST .LT. EXPXL) TEST=EXPXL
202	ANPN=ANPN+PINTEXP(TEST)/(2.0NN)
203	21 CONTINUE
204	ANPN=1./ANPN
205	C** P OR N AS TARGET
206	CALL GRNDM(RNDM,1)
207	RAN=RNDM(1)
208	EXCS=0.
209	GOTO (40,30),NFL
210	C** FOR N AS TARGET
211	30 L=0
212	DO 31 NP1=1,20
213	NP=NP1-1
214	NPP1=NP1+2
215	DO 31 NM1=NP1,NPP1
216	NM=NM1-1
217	DO 31 NZ1=1,20
218	NZ=NZ1-1
219	L=L+1
220	IF(L.GT.1200) GOTO 31
221	NT=NP+NM+NZ
222	IF(NT.LE.0.OR.NT.GT.60) GOTO 31
223	TEST=-(PI/4.0)(NT/N)*2
224	IF (TEST .GT. EXPXU) TEST=EXPXU
225	IF (TEST .LT. EXPXL) TEST=EXPXL
226	DUM1=ANPNPINTPMUL(1,L)ANORM(1,NT)/(2.0NN)
227	DUM2=ABS(DUM1)
228	DUM3=EXP(TEST)
229	ADDNVE=0.0
230	IF (DUM2 .GE. 1.0) ADDNVE=DUM1*DUM3
231	IF ((DUM2 .LT. 1.0) .AND. (DUM3 .GE. 1.0E-10)) ADDNVE=DUM1*DUM3
232	EXCS=EXCS+ADDNVE
233	IF(RAN.LT.EXCS) GOTO 100
234	31 CONTINUE
235	GOTO 80
236	C** FOR P AS TARGET
237	40 L=0
238	DO 41 NP1=1,20
239	NP=NP1-1
240	NMM1=NP1-1
241	IF(NMM1.LE.1) NMM1=1
242	NPP1=NP1+1
243	DO 41 NM1=NMM1,NPP1
244	NM=NM1-1
245	DO 41 NZ1=1,20
246	NZ=NZ1-1
247	L=L+1
248	IF(L.GT.1200) GOTO 41
249	NT=NP+NM+NZ
250	IF(NT.LE.0.OR.NT.GT.60) GOTO 41
251	TEST=-(PI/4.0)(NT/N)*2
252	IF (TEST .GT. EXPXU) TEST=EXPXU
253	IF (TEST .LT. EXPXL) TEST=EXPXL
254	DUM1=ANPNPINTPMUL(2,L)ANORM(2,NT)/(2.0NN)
255	DUM2=ABS(DUM1)
256	DUM3=EXP(TEST)
257	ADDNVE=0.0
258	IF (DUM2 .GE. 1.0) ADDNVE=DUM1*DUM3
259	IF ((DUM2 .LT. 1.0) .AND. (DUM3 .GE. 1.0E-10)) ADDNVE=DUM1*DUM3
260	EXCS=EXCS+ADDNVE
261	IF(RAN.LT.EXCS) GOTO 100
262	41 CONTINUE
263	GOTO 80
264	50 IF(NPRT(4))
265	*WRITE(NEWBCD,1003) EAB,N,NFL,NP,NM,NZ
266	CALL STPAIR
267	IF(INT.EQ.1) CALL TWOB(16,NFL,N)
268	IF(INT.EQ.2) CALL GENXPT(16,NFL,N)
269	GO TO 9999
270	55 IF(NPRT(4))
271	*WRITE(NEWBCD,1001)
272	GOTO 53
273	C** EXCLUSIVE REACTION NOT FOUND
274	80 IF(NPRT(4))
275	*WRITE(NEWBCD,1004) RS,N
276	53 INT=1
277	NP=0
278	NM=0
279	NZ=0
280	100 DO 101 I=1,60
281	101 IPA(I)=0
282	IF(INT.LE.0) GOTO 131
283	NPROT=1-NP+NM+(1-NFL)
284	NNEUT=2-NPROT
285	GOTO (112,102),NFL
286	102 GOTO (103,104),INT
287	103 IPA(1)=16
288	IPA(2)=16
289	NT=2
290	GOTO 130
291	104 IF(NNEUT.EQ.1) GOTO 105
292	IF(NNEUT.EQ.2) GOTO 106
293	IPA(1)=14
294	IPA(2)=14
295	GOTO 120
296	105 IPA(1)=14
297	IPA(2)=16
298	CALL GRNDM(RNDM,1)
299	IF(RNDM(1).LT.0.5) GOTO 120
300	IPA(1)=16
301	IPA(2)=14
302	GOTO 120
303	106 IPA(1)=16
304	IPA(2)=16
305	GOTO 120
306	112 GOTO (113,114),INT
307	113 IPA(1)=16
308	IPA(2)=14
309	NT=2
310	IF(NCECH.EQ.0) GOTO 130
311	IPA(1)=14
312	IPA(2)=16
313	GOTO 130
314	114 IF(NNEUT.EQ.1) GOTO 115
315	IF(NNEUT.EQ.2) GOTO 116
316	IPA(1)=14
317	IPA(2)=14
318	GOTO 120
319	115 IPA(1)=14
320	IPA(2)=16
321	CALL GRNDM(RNDM,1)
322	IF(RNDM(1).LT.0.33) GOTO 120
323	IPA(1)=16
324	IPA(2)=14
325	GOTO 120
326	116 IPA(1)=16
327	IPA(2)=16
328	120 NT=2
329	IF(NP.EQ.0) GOTO 122
330	DO 121 I=1,NP
331	NT=NT+1
332	121 IPA(NT)=7
333	122 IF(NM.EQ.0) GOTO 124
334	DO 123 I=1,NM
335	NT=NT+1
336	123 IPA(NT)=9
337	124 IF(NZ.EQ.0) GOTO 130
338	DO 125 I=1,NZ
339	NT=NT+1
340	125 IPA(NT)=8
341	130 IF(NPRT(4))
342	*WRITE(NEWBCD,2004) NT,(IPA(I),I=1,20)
343	GOTO 50
344	131 IF(NPRT(4))
345	*WRITE(NEWBCD,2005)
346	C
347	1001 FORMAT('0CASN CASCADE ENERGETICALLY NOT POSSIBLE NUCLEAR',
348	* ' EXCITATION',2X,F8.4,2X,'INCIDENT ENERGY LOST')
349	1003 FORMAT(' CASN NEUTRON-INDUCED CASCADE,',
350	$ ' AVAIL. ENERGY',2X,F8.4,
351	$ 2X,'<NTOT>',2X,F8.4,2X,'FROM',4(2X,I3),2X,'PARTICLES')
352	1004 FORMAT(' CASN NEUTRON-INDUCED CASCADE,',
353	$ ' EXCLUSIVE REACTION NOT FOUND',
354	$ ' TRY ELASTIC SCATTERING AVAIL. ENERGY',2X,F8.4,2X,
355	$ '<NTOT>',2X,F8.4)
356	2001 FORMAT('0CASN TABLES FOR MULT. DATA NEUTRON INDUCED REACTION',
357	$ ' FOR DEFINITION OF NUMBERS SEE FORTRAN CODING')
358	2002 FORMAT(' CASN TARGET PARTICLE FLAG',2X,I5)
359	2003 FORMAT(1H ,10E12.4)
360	2004 FORMAT(' CASN ',I3,2X,'PARTICLES , MASS INDEX ARRAY',2X,20I4)
361	2005 FORMAT(' CASN NO PARTICLES PRODUCED')
362	C
363	9999 CONTINUE
364	END