*CMZU: 3.16/00 05/11/93 17.20.00 BY FEDERICO CARMINATI *-- AUTHOR : C--------------------------------------------------------------------- SUBROUTINE ADD(K,L,M) C C *** VARIOUS VECTOR OPERATIONS *** C C COPIED FROM F14BLO.PAMLIB 23.4.82 C AUTHOR: V.BLOBEL (UNIVERSITY OF HAMBURG) C DESYLIB C C *** BLANK COMMON REPLACED BY /VECUTY/ TO MATCH GEANT/GHEISHA CODE *** C *** NOTE THAT P(10,100) HAS BECOME PV(10,200) DUE TO THIS *** C C UN-USED ENTRIES REMOVED : C "PCOP" "PEXC" "PZER" "PWRT" "DOT4" "IMPU" "IMPULI" "ADD3" C "SUB3" "CROSS" "DOT" "SMUL" "NORZ" "PARPER" "PUNIT" "TRAP" C C *** ALL ENTRIES RE-WRITTEN AS SUBROUTINES USING ONLY NECESSARY *** C *** "DOUBLE PRECISION" STMTS. AND ALL SPECIFIC FUNCTIONS HAVE *** C *** BEEN CHANGED TO THEIR GENERIC EQUIVALENCES *** C *** NVE 29-MAR-1988 CERN GENEVA *** C C ORIGIN : H.FESEFELDT (22-JUNE-1984) C C C --- PV-ARRAY --- PARAMETER (MXGKGH=100) PARAMETER (MXGKPV=MXGKGH) COMMON /VECUTY/ PV(10,MXGKPV) C C DOUBLE PRECISION A,B SAVE C A=PV(4,K)+PV(4,L) PV(4,M)=A B=A*A DO 2 I=1,3 A=PV(I,K)+PV(I,L) B=B-A*A PV(I,M)=A 2 CONTINUE PV(5,M)=SIGN(SQRT(ABS(B)),B) RETURN END C--------------------------------------------------------------------- SUBROUTINE ADD3(K,L,M) C C --- PV-ARRAY --- PARAMETER (MXGKGH=100) PARAMETER (MXGKPV=MXGKGH) COMMON /VECUTY/ PV(10,MXGKPV) C C DOUBLE PRECISION A SAVE C DO 2 I=1,3 A=PV(I,K)+PV(I,L) PV(I,M)=A 2 CONTINUE RETURN END C--------------------------------------------------------------------- SUBROUTINE SUB3(K,L,M) C C --- PV-ARRAY --- PARAMETER (MXGKGH=100) PARAMETER (MXGKPV=MXGKGH) COMMON /VECUTY/ PV(10,MXGKPV) C C DOUBLE PRECISION A SAVE C DO 2 I=1,3 A=PV(I,K)-PV(I,L) PV(I,M)=A 2 CONTINUE RETURN END C--------------------------------------------------------------------- SUBROUTINE CROSS3(K,L,M) C PARAMETER (MXGKGH=100) PARAMETER (MXGKPV=MXGKGH) COMMON /VECUTY/ PV(10,MXGKPV) C DIMENSION G(3) DOUBLE PRECISION A,B,G SAVE C A=PV(2,K)*PV(3,L) B=PV(3,K)*PV(2,L) G(1)=A-B A=PV(3,K)*PV(1,L) B=PV(1,K)*PV(3,L) G(2)=A-B A=PV(1,K)*PV(2,L) B=PV(2,K)*PV(1,L) G(3)=A-B DO 26 I=1,3 26 PV(I,M)=G(I) RETURN END C--------------------------------------------------------------------- SUBROUTINE SUB(K,L,M) C C --- PV-ARRAY --- PARAMETER (MXGKGH=100) PARAMETER (MXGKPV=MXGKGH) COMMON /VECUTY/ PV(10,MXGKPV) C C DOUBLE PRECISION A,B SAVE C A=PV(4,K)-PV(4,L) PV(4,M)=A B=A*A DO 4 I=1,3 A=PV(I,K)-PV(I,L) B=B-A*A PV(I,M)=A 4 CONTINUE PV(5,M)=SIGN(SQRT(ABS(B)),B) RETURN END C--------------------------------------------------------------------- SUBROUTINE LOR(K,L,M) C C --- PV-ARRAY --- PARAMETER (MXGKGH=100) PARAMETER (MXGKPV=MXGKGH) COMMON /VECUTY/ PV(10,MXGKPV) C C DOUBLE PRECISION A,B,C SAVE C A=0.0 DO 6 I=1,3 A=A+PV(I,K)*PV(I,L) 6 CONTINUE A=(A/(PV(4,L)+PV(5,L))-PV(4,K))/PV(5,L) B=PV(5,K)*PV(5,K) DO 8 I=1,3 C=PV(I,K)+A*PV(I,L) B=B+C*C PV(I,M)=C 8 CONTINUE PV(4,M)=SQRT(B) PV(5,M)=PV(5,K) RETURN END C--------------------------------------------------------------------- SUBROUTINE LENGTX(K,U) C C --- PV-ARRAY --- PARAMETER (MXGKGH=100) PARAMETER (MXGKPV=MXGKGH) COMMON /VECUTY/ PV(10,MXGKPV) C C DOUBLE PRECISION A,B SAVE C A=0.0 DO 36 I=1,3 A=A+PV(I,K)*PV(I,K) 36 CONTINUE B=SQRT(A) U=B RETURN END C--------------------------------------------------------------------- SUBROUTINE ANG(K,L,U,V) C C --- PV-ARRAY --- PARAMETER (MXGKGH=100) PARAMETER (MXGKPV=MXGKGH) COMMON /VECUTY/ PV(10,MXGKPV) C C DOUBLE PRECISION A,B,C,D SAVE C A=0.0 B=0.0 C=0.0 DO 38 I=1,3 A=A+PV(I,K)*PV(I,K) B=B+PV(I,L)*PV(I,L) C=C+PV(I,K)*PV(I,L) 38 CONTINUE D=SQRT(A*B) IF (D .NE. 0.0) D=C/D IF (ABS(D) .GT. 1.D0) D=SIGN(1.D0,D) U=D V=ACOS(D) RETURN END C--------------------------------------------------------------------- SUBROUTINE DEFS(K,L,M) C C --- PV-ARRAY --- PARAMETER (MXGKGH=100) PARAMETER (MXGKPV=MXGKGH) COMMON /VECUTY/ PV(10,MXGKPV) C C DOUBLE PRECISION A,B SAVE C MX=M MY=M+1 MZ=M+2 DO 52 I=1,3 F=PV(I,K) H=PV(I,L) PV(I,MY)=F PV(I,MZ)=H 52 CONTINUE A=PV(2,MY)*PV(3,MZ) B=PV(3,MY)*PV(2,MZ) PV(1,MX)=A-B A=PV(3,MY)*PV(1,MZ) B=PV(1,MY)*PV(3,MZ) PV(2,MX)=A-B A=PV(1,MY)*PV(2,MZ) B=PV(2,MY)*PV(1,MZ) PV(3,MX)=A-B A=PV(2,MZ)*PV(3,MX) B=PV(3,MZ)*PV(2,MX) PV(1,MY)=A-B A=PV(3,MZ)*PV(1,MX) B=PV(1,MZ)*PV(3,MX) PV(2,MY)=A-B A=PV(1,MZ)*PV(2,MX) B=PV(2,MZ)*PV(1,MX) PV(3,MY)=A-B DO 58 J=MX,MZ A=0.0 DO 54 I=1,3 A=A+PV(I,J)*PV(I,J) 54 CONTINUE B=SQRT(A) IF (B .NE. 0.0) B=1.0/B DO 56 I=1,3 PV(I,J)=B*PV(I,J) 56 CONTINUE 58 CONTINUE RETURN END C--------------------------------------------------------------------- SUBROUTINE TRAC(K,L,M) C C --- PV-ARRAY --- PARAMETER (MXGKGH=100) PARAMETER (MXGKPV=MXGKGH) COMMON /VECUTY/ PV(10,MXGKPV) C C DOUBLE PRECISION B,G(3) SAVE C N=L DO 62 J=1,3 B=0.0 DO 60 I=1,3 B=B+PV(I,N)*PV(I,K) 60 CONTINUE G(J)=B N=N+1 62 CONTINUE DO 64 I=1,3 PV(I,M)=G(I) 64 CONTINUE RETURN END *CMZ : 3.16/00 05/11/93 18.56.07 BY FEDERICO CARMINATI *-- AUTHOR : C--------------------------------------------------------------------- REAL FUNCTION ATOMAS(A,Z) C C *** DETERMINATION OF THE ATOMIC MASS *** C *** NVE 19-MAY-1988 CERN GENEVA *** C C ORIGIN : H.FESEFELDT (02-DEC-1986) C COMMON/CONSTS/ PI,TWPI,PIBTW,MP,MPI,MMU,MEL,MKCH,MK0,SMP,SMPI, $ SMU,CT,CTKCH,CTK0, $ ML0,MSP,MS0,MSM,MX0,MXM,CTL0,CTSP,CTSM,CTX0,CTXM, $ RMASS(35),RCHARG(35) C REAL MP,MPI,MMU,MEL,MKCH,MK0, * ML0,MSP,MS0,MSM,MX0,MXM C C DOUBLE PRECISION AA,ZZ,MASS SAVE C C --- GET ATOMIC (= ELECTRONS INCL.) MASSES (IN MEV) FROM RMASS ARRAY --- C --- ELECTRON --- RMEL=RMASS(4)*1000. C --- PROTON --- RMP=RMASS(14)*1000. C --- NEUTRON --- RMN=RMASS(16)*1000. C --- DEUTERON --- RMD=RMASS(30)*1000.+RMEL C --- ALPHA --- RMA=RMASS(32)*1000.+2.*RMEL C ATOMAS = 0. AA = A * 1.D0 ZZ = Z * 1.D0 IA = IFIX(A + 0.5) IF(IA.LT.1) RETURN IZ = IFIX(Z + 0.5) IF(IZ.LT.0) RETURN IF(IZ.GT.IA) RETURN IF(IA.GT.4) GOTO 50 MASS=0.D0 GOTO (10,20,50,40),IA 10 IF(IZ.EQ.0) MASS=RMN IF(IZ.EQ.1) MASS=RMP+RMEL GOTO 60 20 IF(IZ.NE.1) GOTO 50 MASS=RMD GOTO 60 40 IF(IZ.NE.2) GOTO 50 MASS=RMA GOTO 60 50 MASS=(AA-ZZ)*RMN + ZZ*RMP +ZZ*RMEL - 15.67*AA * + 17.23*(AA**0.6666667) + 93.15*((AA/2.-ZZ)**2)/AA * +0.6984523*ZZ**2/(AA**0.3333333) IPP=MOD(IA-IZ,2) IZZ=MOD(IZ,2) IF(IPP.NE.IZZ) GOTO 60 MASS = MASS + (IPP+IZZ- 1)*12.00*(AA**(-0.5)) 60 ATOMAS = MASS*0.001 RETURN END *CMZU: 3.16/00 05/11/93 17.20.00 BY FEDERICO CARMINATI *-- AUTHOR : C--------------------------------------------------------------------- SUBROUTINE CAPTUR(NOPT) C C *** ROUTINE FOR CAPTURE OF NEUTRAL BARYONS *** C *** NVE 04-MAR-1988 CERN GENEVA *** C C ORIGIN : H.FESEFELDT (02-DEC-1986) C PARAMETER (MXGKGH=100) COMMON/CONSTS/ PI,TWPI,PIBTW,MP,MPI,MMU,MEL,MKCH,MK0,SMP,SMPI, $ SMU,CT,CTKCH,CTK0, $ ML0,MSP,MS0,MSM,MX0,MXM,CTL0,CTSP,CTSM,CTX0,CTXM, $ RMASS(35),RCHARG(35) C REAL MP,MPI,MMU,MEL,MKCH,MK0, * ML0,MSP,MS0,MSM,MX0,MXM C PARAMETER (MXGKCU=MXGKGH) COMMON/CURPAR/WEIGHT(10),DDELTN,IFILE,IRUN,NEVT,NEVENT,SHFLAG, * ITHST,ITTOT,ITLST,IFRND,TOFCUT,CMOM(5),CENG(5), * RS,S,ENP(10),NP,NM,NN,NR,NO,NZ,IPA(MXGKCU), * ATNO2,ZNO2 C COMMON/RESULT/XEND,YEND,ZEND,RCA,RCE,AMAS,NCH,TOF,PX,PY,PZ, * USERW,INTCT,P,EN,EK,AMASQ,DELTN,ITK,NTK,IPART,IND, * LCALO,ICEL,SINL,COSL,SINP,COSP, * XOLD,YOLD,ZOLD,POLD,PXOLD,PYOLD,PZOLD, * XSCAT,YSCAT,ZSCAT,PSCAT,PXSCAT,PYSCAT,PZSCAT REAL NCH,INTCT C COMMON/MAT / LMAT, * DEN(21),RADLTH(21),ATNO(21),ZNO(21),ABSL(21), * CDEN(21),MDEN(21),X0DEN(21),X1DEN(21),RION(21), * MATID(21),MATID1(21,24),PARMAT(21,10), * IFRAT,IFRAC(21),FRAC1(21,10),DEN1(21,10), * ATNO1(21,10),ZNO1(21,10) C PARAMETER (MXEVEN=12*MXGKGH) COMMON/EVENT / NSIZE,NCUR,NEXT,NTOT,EVE(MXEVEN) C COMMON/PRNTFL/INBCD,NEWBCD,INBIN,NEWBIN,NPEVT,NEVTP,LPRT,NPRT(10) LOGICAL LPRT,NPRT C COMMON/ERRCOM/ IER(100) C PARAMETER (MXGKPV=MXGKGH) COMMON /VECUTY/ PV(10,MXGKPV) C C DIMENSION RNDM(3) SAVE C NOPT=1 IER(81)=IER(81)+1 PV(1,1)=PX*P PV(2,1)=PY*P PV(3,1)=PZ*P PV(4,1)=EN PV(5,1)=ABS(AMAS) PV(6,1)=NCH PV(7,1)=TOF PV(8,1)=IPART PV(9,1)=0. PV(10,1)=USERW ND=IND+1 PV(1,2)=0. PV(2,2)=0. PV(3,2)=0. PV(4,2)=ATOMAS(ATNO(ND),ZNO(ND)) PV(5,2)=PV(4,2) PV(6,2)=ZNO(ND) PV(7,2)=TOF PV(8,2)=0. PV(9,2)=0. PV(10,2)=0. CALL ADD(1,2,MXGKPV) PV(1,MXGKPV)=-PV(1,MXGKPV) PV(2,MXGKPV)=-PV(2,MXGKPV) PV(3,MXGKPV)=-PV(3,MXGKPV) CALL NORMAL(RAN) P=0.0065+RAN*0.0010 CALL GRNDM(RNDM,3) COST=-1.+RNDM(1)*2. SINT=SQRT(ABS(1.-COST*COST)) PHI=TWPI*RNDM(2) PV(1,3)=P*SINT*SIN(PHI) PV(2,3)=P*SINT*COS(PHI) PV(3,3)=P*COST PV(4,3)=P PV(5,3)=0. PV(6,3)=0. PV(8,3)=1. PV(9,3)=0. PV(10,3)=0. RAN=RNDM(3) TOF=TOF-480.*LOG(RAN) PV(7,3)=TOF CALL LOR(3,MXGKPV,3) NT=3 XP=0.008-P IF(XP.LT.0.) GOTO 9 NT=4 CALL GRNDM(RNDM,2) COST=-1.+RNDM(1)*2. SINT=SQRT(ABS(1.-COST*COST)) PHI=TWPI*RNDM(2) PV(1,4)=XP*SINT*SIN(PHI) PV(2,4)=XP*SINT*COS(PHI) PV(3,4)=XP*COST PV(4,4)=XP PV(5,4)=0. PV(6,4)=0. PV(7,4)=TOF PV(8,4)=1. PV(9,4)=0. PV(10,4)=0. CALL LOR(4,MXGKPV,4) 9 INTCT=INTCT+1. CALL SETCUR(3) NTK=NTK+1 IF(NT.EQ.4) CALL SETTRK(4) IF(NPRT(4)) *WRITE(NEWBCD,1002) XEND,YEND,ZEND,EN,XP 1002 FORMAT(' *CAPTUR* NEUTRON CAPTURE POSITION',3(2X,F8.2),2X, * 'PHOTON ENERGIES',2X,2F8.4) C RETURN END *CMZ : 3.16/00 05/11/93 19.18.52 BY FEDERICO CARMINATI *-- AUTHOR : C--------------------------------------------------------------------- SUBROUTINE CASAL0(K,INT,NFL) C C *** CASCADE OF ANTI-LAMBDA *** C *** NVE 04-MAY-1988 CERN GENEVA *** C C ORIGIN : H.FESEFELDT (13-SEP-1987) C C L0B 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 PARAMETER (MXGKGH=100) COMMON/CONSTS/ PI,TWPI,PIBTW,MP,MPI,MMU,MEL,MKCH,MK0,SMP,SMPI, $ SMU,CT,CTKCH,CTK0, $ ML0,MSP,MS0,MSM,MX0,MXM,CTL0,CTSP,CTSM,CTX0,CTXM, $ RMASS(35),RCHARG(35) C REAL MP,MPI,MMU,MEL,MKCH,MK0, * ML0,MSP,MS0,MSM,MX0,MXM C PARAMETER (MXGKCU=MXGKGH) COMMON/CURPAR/WEIGHT(10),DDELTN,IFILE,IRUN,NEVT,NEVENT,SHFLAG, * ITHST,ITTOT,ITLST,IFRND,TOFCUT,CMOM(5),CENG(5), * RS,S,ENP(10),NP,NM,NN,NR,NO,NZ,IPA(MXGKCU), * ATNO2,ZNO2 C COMMON/RESULT/XEND,YEND,ZEND,RCA,RCE,AMAS,NCH,TOF,PX,PY,PZ, * USERW,INTCT,P,EN,EK,AMASQ,DELTN,ITK,NTK,IPART,IND, * LCALO,ICEL,SINL,COSL,SINP,COSP, * XOLD,YOLD,ZOLD,POLD,PXOLD,PYOLD,PZOLD, * XSCAT,YSCAT,ZSCAT,PSCAT,PXSCAT,PYSCAT,PZSCAT REAL NCH,INTCT C COMMON/PRNTFL/INBCD,NEWBCD,INBIN,NEWBIN,NPEVT,NEVTP,LPRT,NPRT(10) LOGICAL LPRT,NPRT C C --- INITIALIZATION FLAGS FOR VARIOUS GHEISHA ROUTINES --- COMMON /KGINIT/ KGINIT(50) C C --- BOUNDARY LIMITS FOR ARGUMENTS OF INTRINSIC FUNCTIONS --- C --- XL DENOTES LOWER BOUND WHEREAS XU DENOTES UPPER BOUND --- COMMON /LIMITS/ EXPXL,EXPXU C C REAL N DIMENSION PMUL1(2,1200),PMUL2(2,400),ANORM1(2,60),ANORM2(2,60), $ CECH(10),ANHL(25),IIPA(10,2),B(2) DIMENSION RNDM(2) SAVE PMUL1,ANORM1,PMUL2,ANORM2 SAVE DATA CECH/0.50,0.45,0.40,0.35,0.30,0.25,0.06,0.04,0.005,0./ DATA ANHL/1.00,1.00,1.00,1.00,1.00,1.00,1.00,1.00,0.97,0.88 $ ,0.85,0.81,0.75,0.64,0.64,0.55,0.55,0.45,0.47,0.40 $ ,0.39,0.36,0.33,0.10,0.01/ DATA IIPA/24,25,14,14,16,23,24,16,16,14, $ 14,16,19,24,25,14,16,19,24,23/ DATA B/0.7,0.7/,C/1.25/ C C --- INITIALIZATION INDICATED BY KGINIT(1) --- IF (KGINIT(1) .NE. 0) GO TO 10 KGINIT(1)=1 C C --- INITIALIZE PMUL AND ANORM ARRAYS --- DO 9000 J=1,1200 DO 9001 I=1,2 PMUL1(I,J)=0.0 IF (J .LE. 400) PMUL2(I,J)=0.0 IF (J .LE. 60) ANORM1(I,J)=0.0 IF (J .LE. 60) ANORM2(I,J)=0.0 9001 CONTINUE 9000 CONTINUE C C** COMPUTE NORMALIZATION CONSTANTS C** FOR P AS TARGET C L=0 DO 1 NP1=1,20 NP=NP1-1 NMM1=NP1-2 IF(NMM1.LE.1) NMM1=1 NPP1=NP1+1 DO 1 NM1=NMM1,NPP1 NM=NM1-1 DO 1 NZ1=1,20 NZ=NZ1-1 L=L+1 IF(L.GT.1200) GOTO 1 NT=NP+NM+NZ IF(NT.LE.0.OR.NT.GT.60) GOTO 1 PMUL1(1,L)=PMLTPC(NP,NM,NZ,NT,B(1),C) ANORM1(1,NT)=ANORM1(1,NT)+PMUL1(1,L) 1 CONTINUE C** FOR N AS TARGET L=0 DO 2 NP1=1,20 NP=NP1-1 NMM1=NP1-1 IF(NMM1.LT.1) NMM1=1 NPP1=NP1+2 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 NT=NP+NM+NZ IF(NT.LE.0.OR.NT.GT.60) GOTO 2 PMUL1(2,L)=PMLTPC(NP,NM,NZ,NT,B(2),C) ANORM1(2,NT)=ANORM1(2,NT)+PMUL1(2,L) 2 CONTINUE DO 3 I=1,60 IF(ANORM1(1,I).GT.0.) ANORM1(1,I)=1./ANORM1(1,I) IF(ANORM1(2,I).GT.0.) ANORM1(2,I)=1./ANORM1(2,I) 3 CONTINUE IF(.NOT.NPRT(10)) GOTO 9 WRITE(NEWBCD,2001) DO 4 NFL=1,2 WRITE(NEWBCD,2002) NFL WRITE(NEWBCD,2003) (ANORM1(NFL,I),I=1,60) WRITE(NEWBCD,2003) (PMUL1(NFL,I),I=1,1200) 4 CONTINUE C** DO THE SAME FOR ANNIHILATION CHANNELS C** FOR P AS TARGET C 9 L=0 DO 5 NP1=2,20 NP=NP1-1 NM=NP-1 DO 5 NZ1=1,20 NZ=NZ1-1 L=L+1 IF(L.GT.400) GOTO 5 NT=NP+NM+NZ IF(NT.LE.1.OR.NT.GT.60) GOTO 5 PMUL2(1,L)=PMLTPC(NP,NM,NZ,NT,B(1),C) ANORM2(1,NT)=ANORM2(1,NT)+PMUL2(1,L) 5 CONTINUE C** FOR N AS TARGET L=0 DO 6 NP1=1,20 NP=NP1-1 NM=NP DO 6 NZ1=1,20 NZ=NZ1-1 L=L+1 IF(L.GT.400) GOTO 6 NT=NP+NM+NZ IF(NT.LE.1.OR.NT.GT.60) GOTO 6 PMUL2(2,L)=PMLTPC(NP,NM,NZ,NT,B(2),C) ANORM2(2,NT)=ANORM2(2,NT)+PMUL2(2,L) 6 CONTINUE DO 7 I=1,60 IF(ANORM2(1,I).GT.0.) ANORM2(1,I)=1./ANORM2(1,I) IF(ANORM2(2,I).GT.0.) ANORM2(2,I)=1./ANORM2(2,I) 7 CONTINUE IF(.NOT.NPRT(10)) GOTO 10 WRITE(NEWBCD,3001) DO 8 NFL=1,2 WRITE(NEWBCD,3002) NFL WRITE(NEWBCD,3003) (ANORM2(NFL,I),I=1,60) WRITE(NEWBCD,3003) (PMUL2(NFL,I),I=1,400) 8 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-ABS(RMASS(19)) C** ELASTIC SCATTERING NP=0 NM=0 NZ=0 IPA(1)=19 IPA(2)=14 IF(NFL.EQ.2) IPA(2)=16 N=0. IF(INT.EQ.2) GOTO 20 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 120 C** INTRODUCE CHARGE AND STRANGENESS EXCHANGE REACTION C** LB P --> S0B P, LB P --> S-B N, LB N --> S+B P, LB N --> S0B N C** LB P --> P LB, LB P --> P S0B, LB P --> N S-B C** LB N --> N LB, LB N --> N S0B, LB N --> P S+B CALL GRNDM(RNDM,1) RAN=RNDM(1) IRN=IFIX(RAN/0.2)+1 IF(IRN.GT.5) IRN=5 IRN=IRN+(NFL-1)*5 IPA(1)=IIPA(IRN,1) IPA(2)=IIPA(IRN,2) GOTO 120 C** ANNIHILATION CHANNELS 20 IPLAB=IFIX(P*10.)+1 IF(IPLAB.GT.10) IPLAB=IFIX((P-1.)*5.)+11 IF(IPLAB.GT.15) IPLAB=IFIX( P-2. )+16 IF(IPLAB.GT.23) IPLAB=IFIX((P-10.)/10.)+24 IF(IPLAB.GT.25) IPLAB=25 CALL GRNDM(RNDM,1) IF(RNDM(1).GT.ANHL(IPLAB)) GOTO 19 EAB=RS IF (EAB .LE. RMASS(7)+RMASS(10)) GOTO 55 GOTO 222 C** CHECK IF ENERGETICALLY POSSIBLE TO PRODUCE ONE EXTRA PION IN REACT. 19 IF (EAB .LE. RMASS(7)) GOTO 55 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 .LT. EXPXL) TEST=EXPXL IF (TEST .GT. EXPXU) TEST=EXPXU DUM1=PI*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 ANPN=ANPN+ADDNVE 21 CONTINUE ANPN=1./ANPN C** P OR N AS TARGET CALL GRNDM(RNDM,1) RAN=RNDM(1) EXCS=0. GOTO (30,40),NFL C** FOR P AS TARGET 30 L=0 DO 31 NP1=1,20 NP=NP1-1 NMM1=NP1-2 IF(NMM1.LE.1) NMM1=1 NPP1=NP1+1 DO 31 NM1=NMM1,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 .LT. EXPXL) TEST=EXPXL IF (TEST .GT. EXPXU) TEST=EXPXU DUM1=ANPN*PI*NT*PMUL1(1,L)*ANORM1(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 N AS TARGET 40 L=0 DO 41 NP1=1,20 NP=NP1-1 NMM1=NP1-1 IF(NMM1.LT.1) NMM1=1 NPP1=NP1+2 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 .LT. EXPXL) TEST=EXPXL IF (TEST .GT. EXPXU) TEST=EXPXU DUM1=ANPN*PI*NT*PMUL1(2,L)*ANORM1(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 C** ANNIHILATION CHANNELS 222 IPA(1)=0 IPA(2)=0 ALEAB=LOG(EAB) C** NO. OF TOTAL PARTICLES VS SQRT(S) 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 221 NT=2,60 TEST=-(PI/4.0)*(NT/N)**2 IF (TEST .LT. EXPXL) TEST=EXPXL IF (TEST .GT. EXPXU) TEST=EXPXU DUM1=PI*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 ANPN=ANPN+ADDNVE 221 CONTINUE ANPN=1./ANPN C** P OR N AS TARGET CALL GRNDM(RNDM,1) RAN=RNDM(1) EXCS=0. GOTO (230,240),NFL C** FOR P AS TARGET 230 L=0 DO 231 NP1=2,20 NP=NP1-1 NM=NP-1 DO 231 NZ1=1,20 NZ=NZ1-1 L=L+1 IF(L.GT.400) GOTO 231 NT=NP+NM+NZ IF(NT.LE.1.OR.NT.GT.60) GOTO 231 TEST=-(PI/4.0)*(NT/N)**2 IF (TEST .LT. EXPXL) TEST=EXPXL IF (TEST .GT. EXPXU) TEST=EXPXU DUM1=ANPN*PI*NT*PMUL2(1,L)*ANORM2(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 120 231 CONTINUE GOTO 80 C** FOR N AS TARGET 240 L=0 DO 241 NP1=1,20 NP=NP1-1 NM=NP DO 241 NZ1=1,20 NZ=NZ1-1 L=L+1 IF(L.GT.400) GOTO 241 NT=NP+NM+NZ IF(NT.LE.1.OR.NT.GT.60) GOTO 241 TEST=-(PI/4.0)*(NT/N)**2 IF (TEST .LT. EXPXL) TEST=EXPXL IF (TEST .GT. EXPXU) TEST=EXPXU DUM1=ANPN*PI*NT*PMUL2(2,L)*ANORM2(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 120 241 CONTINUE GOTO 80 50 IF(NPRT(4)) *WRITE(NEWBCD,1003) EAB,N,NFL,NP,NM,NZ IF(INT.EQ.1) CALL TWOB(19,NFL,N) IF(INT.EQ.2) CALL GENXPT(19,NFL,N) GO TO 9999 55 IF(NPRT(4)) *WRITE(NEWBCD,1001) GOTO 53 C** EXCLUSIVE REACTION NOT FOUND,ASSUME ELASTIC SCATTERING 80 IF(NPRT(4)) *WRITE(NEWBCD,1004) RS,N 53 INT=1 NP=0 NM=0 NZ=0 IPA(1)=19 IPA(2)=14 IF(NFL.EQ.2) IPA(2)=16 GOTO 120 100 DO 101 I=1,60 101 IPA(I)=0 IF(INT.LE.0) GOTO 131 GOTO (102,112),NFL 102 NCHT=NP-NM NCHT=NCHT+2 IF(NCHT.LE.0) NCHT=1 IF(NCHT.GT.4) NCHT=4 GOTO(103,104,105,106),NCHT 103 IPA(1)=25 IPA(2)=14 GOTO 120 104 IPA(1)=19 IPA(2)=14 CALL GRNDM(RNDM,2) IF(RNDM(1).LT.0.5) IPA(1)=24 IF(RNDM(2).LT.0.5) GOTO 120 IPA(1)=25 IPA(2)=16 GOTO 120 105 IPA(1)=19 CALL GRNDM(RNDM,2) IF(RNDM(1).LT.0.5) IPA(1)=24 IPA(2)=16 IF(RNDM(2).LT.0.5) GOTO 120 IPA(1)=23 IPA(2)=14 GOTO 120 106 IPA(1)=23 IPA(2)=16 GOTO 120 112 NCHT=NP-NM NCHT=NCHT+3 IF(NCHT.LE.0) NCHT=1 IF(NCHT.GT.4) NCHT=4 GOTO(113,114,115,116),NCHT 113 IPA(1)=25 IPA(2)=14 GOTO 120 114 IPA(1)=19 CALL GRNDM(RNDM,2) IF(RNDM(1).LT.0.5) IPA(1)=24 IPA(2)=14 IF(RNDM(2).LT.0.5) GOTO 120 IPA(1)=25 IPA(2)=16 GOTO 120 115 IPA(1)=19 CALL GRNDM(RNDM,2) IF(RNDM(1).LT.0.5) IPA(1)=24 IPA(2)=16 IF(RNDM(2).LT.0.5) GOTO 120 IPA(1)=23 IPA(2)=14 GOTO 120 116 IPA(1)=23 IPA(2)=16 120 NT=2 IF(IPA(1).NE.0) GOTO 119 IF(NZ.EQ.0) GOTO 118 IF(NM.EQ.0) GOTO 117 CALL GRNDM(RNDM,1) IF(RNDM(1).LT.0.5) GOTO 118 117 IPA(3)=12 NZ=NZ-1 NT=3 GOTO 119 118 IF(NM.EQ.0) GOTO 119 IPA(3)=13 NM=NM-1 NT=3 119 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(' *CASAL0* CASCADE ENERGETICALLY NOT POSSIBLE', $ ' CONTINUE WITH QUASI-ELASTIC SCATTERING') 1003 FORMAT(' *CASAL0* ANTILAMBDA-INDUCED CASCADE,', $ 'AVAIL. ENERGY',2X,F8.4,/, $ 2X,' ',2X,F8.4,2X,'FROM',4(2X,I3),2X,'PARTICLES') 1004 FORMAT(' *CASAL0* ANTILAMBDA-INDUCED CASCADE,', $ ' EXCLUSIVE REACTION', $' NOT FOUND TRY ELASTIC SCATTERING AVAIL. ENERGY',2X,F8.4,/,2X, $ ' ',2X,F8.4) 2001 FORMAT(' *CASAL0* TABLES FOR MULT. DATA ANTILAMBDA INDUCED ', $ 'REACTION FOR DEFINITION OF NUMBERS SEE FORTRAN CODING') 2002 FORMAT(' *CASAL0* TARGET PARTICLE FLAG',2X,I5) 2003 FORMAT(1H ,10E12.4) 2004 FORMAT(' *CASAL0* ',I3,2X,'PARTICLES, MASS INDEX ARRAY',2X,20I4) 2005 FORMAT(' *CASAL0* NO PARTICLES PRODUCED') 3001 FORMAT(' *CASAL0* TABLES FOR MULT. DATA ANTIPROTON INDUCED ', $ 'ANNIHILATION REACTION FOR DEFINITION OF NUMBERS SEE FORTRAN', $ ' CODING') 3002 FORMAT(' *CASAL0* TARGET PARTICLE FLAG',2X,I5) 3003 FORMAT(1H ,10E12.4) C 9999 CONTINUE RETURN END *CMZ : 3.14/16 06/05/91 22.27.53 by Federico Carminati *-- Author : Nick van Eijndhoven (CERN) 02/02/89 C--------------------------------------------------------------------- SUBROUTINE CASAOM(K,INT,NFL) C C *** CASCADE OF OMEGA- BAR *** C *** NVE 17-JAN-1989 CERN GENEVA *** C C OMEGA- BAR UNDERGOES INTERACTION WITH NUCLEON WITHIN NUCLEUS. C CHECK IF ENERGETICALLY POSSIBLE TO PRODUCE PIONS/KAONS. C IF NOT, ASSUME NUCLEAR EXCITATION OCCURS, DEGRADE INPUT PARTICLE C IN ENERGY AND NO OTHER PARTICLES ARE 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 COMMON/PRNTFL/INBCD,NEWBCD,INBIN,NEWBIN,NPEVT,NEVTP,LPRT,NPRT(10) LOGICAL LPRT,NPRT C C --- INITIALIZATION FLAGS FOR VARIOUS GHEISHA ROUTINES --- COMMON /KGINIT/ KGINIT(50) C SAVE C C *** NOT YET FINISHED ==> TAKE OMEGA- CASCADE INSTEAD *** C C --- INITIALIZATION INDICATED BY KGINIT(24) --- KGINIT(24)=1 C IF (NPRT(4)) PRINT 1000 1000 FORMAT(' *CASAOM* NOT WRITTEN YET ==> CASOM CALLED INSTEAD') C CALL CASOM(K,INT,NFL) C 9999 CONTINUE RETURN END *CMZ : 3.16/00 05/11/93 19.19.11 BY FEDERICO CARMINATI *-- AUTHOR : C--------------------------------------------------------------------- SUBROUTINE CASASM(K,INT,NFL) C C *** CASCADE OF ANTI SIGMA- *** C *** NVE 04-MAY-1988 CERN GENEVA *** C C ORIGIN : H.FESEFELDT (13-SEP-1987) C C S-B 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 PARAMETER (MXGKGH=100) COMMON/CONSTS/ PI,TWPI,PIBTW,MP,MPI,MMU,MEL,MKCH,MK0,SMP,SMPI, $ SMU,CT,CTKCH,CTK0, $ ML0,MSP,MS0,MSM,MX0,MXM,CTL0,CTSP,CTSM,CTX0,CTXM, $ RMASS(35),RCHARG(35) C REAL MP,MPI,MMU,MEL,MKCH,MK0, * ML0,MSP,MS0,MSM,MX0,MXM C PARAMETER (MXGKCU=MXGKGH) COMMON/CURPAR/WEIGHT(10),DDELTN,IFILE,IRUN,NEVT,NEVENT,SHFLAG, * ITHST,ITTOT,ITLST,IFRND,TOFCUT,CMOM(5),CENG(5), * RS,S,ENP(10),NP,NM,NN,NR,NO,NZ,IPA(MXGKCU), * ATNO2,ZNO2 C COMMON/RESULT/XEND,YEND,ZEND,RCA,RCE,AMAS,NCH,TOF,PX,PY,PZ, * USERW,INTCT,P,EN,EK,AMASQ,DELTN,ITK,NTK,IPART,IND, * LCALO,ICEL,SINL,COSL,SINP,COSP, * XOLD,YOLD,ZOLD,POLD,PXOLD,PYOLD,PZOLD, * XSCAT,YSCAT,ZSCAT,PSCAT,PXSCAT,PYSCAT,PZSCAT REAL NCH,INTCT C COMMON/PRNTFL/INBCD,NEWBCD,INBIN,NEWBIN,NPEVT,NEVTP,LPRT,NPRT(10) LOGICAL LPRT,NPRT C C --- INITIALIZATION FLAGS FOR VARIOUS GHEISHA ROUTINES --- COMMON /KGINIT/ KGINIT(50) C C --- BOUNDARY LIMITS FOR ARGUMENTS OF INTRINSIC FUNCTIONS --- C --- XL DENOTES LOWER BOUND WHEREAS XU DENOTES UPPER BOUND --- COMMON /LIMITS/ EXPXL,EXPXU C C REAL N DIMENSION PMUL1(2,1200),PMUL2(2,400),ANORM1(2,60),ANORM2(2,60), $ CECH(10),ANHL(25),IIPA(10,2),B(2) DIMENSION RNDM(2) SAVE PMUL1,ANORM1,PMUL2,ANORM2 SAVE DATA CECH/0.50,0.45,0.40,0.35,0.30,0.25,0.06,0.04,0.005,0./ DATA ANHL/1.00,1.00,1.00,1.00,1.00,1.00,1.00,1.00,0.97,0.88 $ ,0.85,0.81,0.75,0.64,0.64,0.55,0.55,0.45,0.47,0.40 $ ,0.39,0.36,0.33,0.10,0.01/ DATA IIPA/14,14,14,14,14,19,24,16,14,14, $ 25,25,25,25,25,14,14,25,19,24/ DATA B/0.7,0.7/,C/1.25/ C C --- INITIALIZATION INDICATED BY KGINIT(2) --- IF (KGINIT(2) .NE. 0) GO TO 10 KGINIT(2)=1 C C --- INITIALIZE PMUL AND ANORM ARRAYS --- DO 9000 J=1,1200 DO 9001 I=1,2 PMUL1(I,J)=0.0 IF (J .LE. 400) PMUL2(I,J)=0.0 IF (J .LE. 60) ANORM1(I,J)=0.0 IF (J .LE. 60) ANORM2(I,J)=0.0 9001 CONTINUE 9000 CONTINUE C C** COMPUTE NORMALIZATION CONSTANTS C** FOR P AS TARGET C L=0 DO 1 NP1=1,20 NP=NP1-1 NMM1=NP1-2 IF(NMM1.LE.1) NMM1=1 NPP1=NP1 DO 1 NM1=NMM1,NPP1 NM=NM1-1 DO 1 NZ1=1,20 NZ=NZ1-1 L=L+1 IF(L.GT.1200) GOTO 1 NT=NP+NM+NZ IF(NT.LE.0.OR.NT.GT.60) GOTO 1 PMUL1(1,L)=PMLTPC(NP,NM,NZ,NT,B(1),C) ANORM1(1,NT)=ANORM1(1,NT)+PMUL1(1,L) 1 CONTINUE C** FOR N AS TARGET L=0 DO 2 NP1=1,20 NP=NP1-1 NMM1=NP1-1 IF(NMM1.LT.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 NT=NP+NM+NZ IF(NT.LE.0.OR.NT.GT.60) GOTO 2 PMUL1(2,L)=PMLTPC(NP,NM,NZ,NT,B(2),C) ANORM1(2,NT)=ANORM1(2,NT)+PMUL1(2,L) 2 CONTINUE DO 3 I=1,60 IF(ANORM1(1,I).GT.0.) ANORM1(1,I)=1./ANORM1(1,I) IF(ANORM1(2,I).GT.0.) ANORM1(2,I)=1./ANORM1(2,I) 3 CONTINUE IF(.NOT.NPRT(10)) GOTO 9 WRITE(NEWBCD,2001) DO 4 NFL=1,2 WRITE(NEWBCD,2002) NFL WRITE(NEWBCD,2003) (ANORM1(NFL,I),I=1,60) WRITE(NEWBCD,2003) (PMUL1(NFL,I),I=1,1200) 4 CONTINUE C** DO THE SAME FOR ANNIHILATION CHANNELS C** FOR P AS TARGET C 9 L=0 DO 5 NP1=3,20 NP=NP1-1 NM=NP-2 DO 5 NZ1=1,20 NZ=NZ1-1 IF(NM+NZ.EQ.0) GOTO 5 L=L+1 IF(L.GT.400) GOTO 5 NT=NP+NM+NZ IF(NT.LE.2.OR.NT.GT.60) GOTO 5 PMUL2(1,L)=PMLTPC(NP,NM,NZ,NT,B(1),C) ANORM2(1,NT)=ANORM2(1,NT)+PMUL2(1,L) 5 CONTINUE C** FOR N AS TARGET L=0 DO 6 NP1=2,20 NP=NP1-1 NM=NP-1 DO 6 NZ1=1,20 NZ=NZ1-1 IF(NM+NZ.EQ.0) GOTO 6 L=L+1 IF(L.GT.400) GOTO 6 NT=NP+NM+NZ IF(NT.LE.1.OR.NT.GT.60) GOTO 6 PMUL2(2,L)=PMLTPC(NP,NM,NZ,NT,B(2),C) ANORM2(2,NT)=ANORM2(2,NT)+PMUL2(2,L) 6 CONTINUE DO 7 I=1,60 IF(ANORM2(1,I).GT.0.) ANORM2(1,I)=1./ANORM2(1,I) IF(ANORM2(2,I).GT.0.) ANORM2(2,I)=1./ANORM2(2,I) 7 CONTINUE IF(.NOT.NPRT(10)) GOTO 10 WRITE(NEWBCD,3001) DO 8 NFL=1,2 WRITE(NEWBCD,3002) NFL WRITE(NEWBCD,3003) (ANORM2(NFL,I),I=1,60) WRITE(NEWBCD,3003) (PMUL2(NFL,I),I=1,400) 8 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-ABS(RMASS(25)) C** ELASTIC SCATTERING NP=0 NM=0 NZ=0 IPA(1)=25 IPA(2)=14 IF(NFL.EQ.2) IPA(2)=16 N=0. IF(INT.EQ.2) GOTO 20 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 120 C** INTRODUCE CHARGE AND STRANGENESS EXCHANGE REACTION C** S-B N --> LB P, S-B N --> S0B P, C** S-B P --> P S-B C** S-B N --> N S-B, S-B N --> P LB, S-B N --> P S0B CALL GRNDM(RNDM,1) RAN=RNDM(1) IRN=IFIX(RAN/0.2)+1 IF(IRN.GT.5) IRN=5 IRN=IRN+(NFL-1)*5 IPA(1)=IIPA(IRN,1) IPA(2)=IIPA(IRN,2) GOTO 120 C** ANNIHILATION CHANNELS 20 IPLAB=IFIX(P*10.)+1 IF(IPLAB.GT.10) IPLAB=IFIX((P-1.)*5.)+11 IF(IPLAB.GT.15) IPLAB=IFIX( P-2. )+16 IF(IPLAB.GT.23) IPLAB=IFIX((P-10.)/10.)+24 IF(IPLAB.GT.25) IPLAB=25 CALL GRNDM(RNDM,1) IF(RNDM(1).GT.ANHL(IPLAB)) GOTO 19 EAB=RS IF (EAB .LE. RMASS(7)+RMASS(10)) GOTO 55 GOTO 222 C** CHECK IF ENERGETICALLY POSSIBLE TO PRODUCE ONE EXTRA PION IN REACT. 19 IF (EAB .LE. RMASS(7)) GOTO 55 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 .LT. EXPXL) TEST=EXPXL IF (TEST .GT. EXPXU) TEST=EXPXU DUM1=PI*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 ANPN=ANPN+ADDNVE 21 CONTINUE ANPN=1./ANPN C** P OR N AS TARGET CALL GRNDM(RNDM,1) RAN=RNDM(1) EXCS=0. GOTO (30,40),NFL C** FOR P AS TARGET 30 L=0 DO 31 NP1=1,20 NP=NP1-1 NMM1=NP1-2 IF(NMM1.LE.1) NMM1=1 NPP1=NP1 DO 31 NM1=NMM1,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 .LT. EXPXL) TEST=EXPXL IF (TEST .GT. EXPXU) TEST=EXPXU DUM1=ANPN*PI*NT*PMUL1(1,L)*ANORM1(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 N AS TARGET 40 L=0 DO 41 NP1=1,20 NP=NP1-1 NMM1=NP1-1 IF(NMM1.LT.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 .LT. EXPXL) TEST=EXPXL IF (TEST .GT. EXPXU) TEST=EXPXU DUM1=ANPN*PI*NT*PMUL1(2,L)*ANORM1(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 C** ANNIHILATION CHANNELS 222 IPA(1)=0 IPA(2)=0 ALEAB=LOG(EAB) C** NO. OF TOTAL PARTICLES VS SQRT(S) 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 221 NT=2,60 TEST=-(PI/4.0)*(NT/N)**2 IF (TEST .LT. EXPXL) TEST=EXPXL IF (TEST .GT. EXPXU) TEST=EXPXU DUM1=PI*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 ANPN=ANPN+ADDNVE 221 CONTINUE ANPN=1./ANPN C** P OR N AS TARGET CALL GRNDM(RNDM,1) RAN=RNDM(1) EXCS=0. GOTO (230,240),NFL C** FOR P AS TARGET 230 L=0 DO 231 NP1=3,20 NP=NP1-1 NM=NP-2 DO 231 NZ1=1,20 NZ=NZ1-1 IF(NM+NZ.EQ.0) GOTO 231 L=L+1 IF(L.GT.400) GOTO 231 NT=NP+NM+NZ IF(NT.LE.2.OR.NT.GT.60) GOTO 231 TEST=-(PI/4.0)*(NT/N)**2 IF (TEST .LT. EXPXL) TEST=EXPXL IF (TEST .GT. EXPXU) TEST=EXPXU DUM1=ANPN*PI*NT*PMUL2(1,L)*ANORM2(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 120 231 CONTINUE GOTO 80 C** FOR N AS TARGET 240 L=0 DO 241 NP1=2,20 NP=NP1-1 NM=NP-1 DO 241 NZ1=1,20 NZ=NZ1-1 IF(NM+NZ.EQ.0) GOTO 241 L=L+1 IF(L.GT.400) GOTO 241 NT=NP+NM+NZ IF(NT.LE.1.OR.NT.GT.60) GOTO 241 TEST=-(PI/4.0)*(NT/N)**2 IF (TEST .LT. EXPXL) TEST=EXPXL IF (TEST .GT. EXPXU) TEST=EXPXU DUM1=ANPN*PI*NT*PMUL2(2,L)*ANORM2(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 120 241 CONTINUE GOTO 80 50 IF(NPRT(4)) *WRITE(NEWBCD,1003) EAB,N,NFL,NP,NM,NZ IF(INT.EQ.1) CALL TWOB(25,NFL,N) IF(INT.EQ.2) CALL GENXPT(25,NFL,N) GO TO 9999 55 IF(NPRT(4)) *WRITE(NEWBCD,1001) GOTO 53 C** EXCLUSIVE REACTION NOT FOUND,ASSUME ELASTIC SCATTERING 80 IF(NPRT(4)) *WRITE(NEWBCD,1004) RS,N 53 INT=1 NP=0 NM=0 NZ=0 IPA(1)=25 IPA(2)=14 IF(NFL.EQ.2) IPA(2)=16 GOTO 120 100 DO 101 I=1,60 101 IPA(I)=0 IF(INT.LE.0) GOTO 131 GOTO (102,112),NFL 102 NCHT=NP-NM NCHT=NCHT+1 IF(NCHT.LE.0) NCHT=1 IF(NCHT.GT.3) NCHT=3 GOTO(103,104,105),NCHT 103 IPA(1)=25 IPA(2)=14 GOTO 120 104 IPA(1)=25 IPA(2)=16 CALL GRNDM(RNDM,2) IF(RNDM(1).LT.0.5) GOTO 120 IPA(1)=24 IF(RNDM(2).LT.0.5) IPA(1)=19 IPA(2)=14 GOTO 120 105 IPA(1)=24 CALL GRNDM(RNDM,1) IF(RNDM(1).LT.0.5) IPA(1)=19 IPA(2)=16 GOTO 120 112 NCHT=NP-NM NCHT=NCHT+2 IF(NCHT.LE.0) NCHT=1 IF(NCHT.GT.3) NCHT=3 GOTO(113,114,115),NCHT 113 IPA(1)=25 IPA(2)=14 GOTO 120 114 IPA(1)=24 CALL GRNDM(RNDM,2) IF(RNDM(1).LT.0.5) IPA(1)=19 IPA(2)=14 IF(RNDM(2).LT.0.5) GOTO 120 IPA(1)=25 IPA(2)=16 GOTO 120 115 IPA(1)=24 CALL GRNDM(RNDM,1) IF(RNDM(1).LT.0.5) IPA(1)=19 IPA(2)=16 120 NT=2 IF(IPA(1).NE.0) GOTO 119 IF(NZ.EQ.0) GOTO 118 IF(NM.EQ.0) GOTO 117 CALL GRNDM(RNDM,1) IF(RNDM(1).LT.0.5) GOTO 118 117 IPA(3)=12 NZ=NZ-1 NT=3 GOTO 119 118 IF(NM.EQ.0) GOTO 119 IPA(3)=13 NM=NM-1 NT=3 119 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(' *CASASM* CASCADE ENERGETICALLY NOT POSSIBLE', $ ' CONTINUE WITH QUASI-ELASTIC SCATTERING') 1003 FORMAT(' *CASASM* ANTISIGMA- -INDUCED CASCADE', $ ' AVAIL. ENERGY',2X,F8.4,/, $ 2X,' ',2X,F8.4,2X,'FROM',4(2X,I3),2X,'PARTICLES') 1004 FORMAT(' *CASASM* ANTISIGMA- -INDUCED CASCADE,', $ ' EXCLUSIVE REACTION', $' NOT FOUND TRY ELASTIC SCATTERING AVAIL. ENERGY',2X,F8.4,/,2X, $ ' ',2X,F8.4) 2001 FORMAT(' *CASASM* TABLES FOR MULT. DATA ANTISIGMA- INDUCED ', $ 'REACTION FOR DEFINITION OF NUMBERS SEE FORTRAN CODING') 2002 FORMAT(' *CASASM* TARGET PARTICLE FLAG',2X,I5) 2003 FORMAT(1H ,10E12.4) 2004 FORMAT(' *CASASM* ',I3,2X,'PARTICLES , MASS INDEX ARRAY',2X,20I4) 2005 FORMAT(' *CASASM* NO PARTICLES PRODUCED') 3001 FORMAT(' *CASASM* TABLES FOR MULT. DATA ANTISIGMA- INDUCED ', * 'ANNIHILATION REACTION FOR DEFINITION OF NUMBERS SEE FORTRAN', * ' CODING') 3002 FORMAT(' *CASASM* TARGET PARTICLE FLAG',2X,I5) 3003 FORMAT(1H ,10E12.4) C 9999 CONTINUE RETURN END *CMZ : 3.16/00 05/11/93 19.19.31 BY FEDERICO CARMINATI *-- AUTHOR : C--------------------------------------------------------------------- SUBROUTINE CASASP(K,INT,NFL) C C *** CASCADE OF ANTI SIGMA+ *** C *** NVE 04-MAY-1988 CERN GENEVA *** C C ORIGIN : H.FESEFELDT (13-SEP-1987) C C S+B 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 PARAMETER (MXGKGH=100) COMMON/CONSTS/ PI,TWPI,PIBTW,MP,MPI,MMU,MEL,MKCH,MK0,SMP,SMPI, $ SMU,CT,CTKCH,CTK0, $ ML0,MSP,MS0,MSM,MX0,MXM,CTL0,CTSP,CTSM,CTX0,CTXM, $ RMASS(35),RCHARG(35) C REAL MP,MPI,MMU,MEL,MKCH,MK0, * ML0,MSP,MS0,MSM,MX0,MXM C PARAMETER (MXGKCU=MXGKGH) COMMON/CURPAR/WEIGHT(10),DDELTN,IFILE,IRUN,NEVT,NEVENT,SHFLAG, * ITHST,ITTOT,ITLST,IFRND,TOFCUT,CMOM(5),CENG(5), * RS,S,ENP(10),NP,NM,NN,NR,NO,NZ,IPA(MXGKCU), * ATNO2,ZNO2 C COMMON/RESULT/XEND,YEND,ZEND,RCA,RCE,AMAS,NCH,TOF,PX,PY,PZ, * USERW,INTCT,P,EN,EK,AMASQ,DELTN,ITK,NTK,IPART,IND, * LCALO,ICEL,SINL,COSL,SINP,COSP, * XOLD,YOLD,ZOLD,POLD,PXOLD,PYOLD,PZOLD, * XSCAT,YSCAT,ZSCAT,PSCAT,PXSCAT,PYSCAT,PZSCAT REAL NCH,INTCT C COMMON/PRNTFL/INBCD,NEWBCD,INBIN,NEWBIN,NPEVT,NEVTP,LPRT,NPRT(10) LOGICAL LPRT,NPRT C C --- INITIALIZATION FLAGS FOR VARIOUS GHEISHA ROUTINES --- COMMON /KGINIT/ KGINIT(50) C C --- BOUNDARY LIMITS FOR ARGUMENTS OF INTRINSIC FUNCTIONS --- C --- XL DENOTES LOWER BOUND WHEREAS XU DENOTES UPPER BOUND --- COMMON /LIMITS/ EXPXL,EXPXU C C REAL N DIMENSION PMUL1(2,1200),PMUL2(2,400),ANORM1(2,60),ANORM2(2,60), $ CECH(10),ANHL(25),IIPA(10,2),B(2) DIMENSION RNDM(2) SAVE PMUL1,ANORM1,PMUL2,ANORM2 SAVE DATA CECH/0.50,0.45,0.40,0.35,0.30,0.25,0.06,0.04,0.005,0./ DATA ANHL/1.00,1.00,1.00,1.00,1.00,1.00,1.00,1.00,0.97,0.88 $ ,0.85,0.81,0.75,0.64,0.64,0.55,0.55,0.45,0.47,0.40 $ ,0.39,0.36,0.33,0.10,0.01/ DATA IIPA/19,24,16,16,14,16,16,16,16,16, $ 16,16,19,24,23,23,23,23,23,23/ DATA B/0.7,0.7/,C/1.25/ C C --- INITIALIZATION INDICATED BY KGINIT(3) --- IF (KGINIT(3) .NE. 0) GO TO 10 KGINIT(3)=1 C C --- INITIALIZE PMUL AND ANORM ARRAYS --- DO 9000 J=1,1200 DO 9001 I=1,2 PMUL1(I,J)=0.0 IF (J .LE. 400) PMUL2(I,J)=0.0 IF (J .LE. 60) ANORM1(I,J)=0.0 IF (J .LE. 60) ANORM2(I,J)=0.0 9001 CONTINUE 9000 CONTINUE C C** COMPUTE NORMALIZATION CONSTANTS C** FOR P AS TARGET C L=0 DO 1 NP1=1,20 NP=NP1-1 NMM1=NP1-1 IF(NMM1.LE.1) NMM1=1 NPP1=NP1+1 DO 1 NM1=NMM1,NPP1 NM=NM1-1 DO 1 NZ1=1,20 NZ=NZ1-1 L=L+1 IF(L.GT.1200) GOTO 1 NT=NP+NM+NZ IF(NT.LE.0.OR.NT.GT.60) GOTO 1 PMUL1(1,L)=PMLTPC(NP,NM,NZ,NT,B(1),C) ANORM1(1,NT)=ANORM1(1,NT)+PMUL1(1,L) 1 CONTINUE C** FOR N AS TARGET L=0 DO 2 NP1=1,20 NP=NP1-1 NMM1=NP1 IF(NMM1.LT.1) NMM1=1 NPP1=NP1+2 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 NT=NP+NM+NZ IF(NT.LE.0.OR.NT.GT.60) GOTO 2 PMUL1(2,L)=PMLTPC(NP,NM,NZ,NT,B(2),C) ANORM1(2,NT)=ANORM1(2,NT)+PMUL1(2,L) 2 CONTINUE DO 3 I=1,60 IF(ANORM1(1,I).GT.0.) ANORM1(1,I)=1./ANORM1(1,I) IF(ANORM1(2,I).GT.0.) ANORM1(2,I)=1./ANORM1(2,I) 3 CONTINUE IF(.NOT.NPRT(10)) GOTO 9 WRITE(NEWBCD,2001) DO 4 NFL=1,2 WRITE(NEWBCD,2002) NFL WRITE(NEWBCD,2003) (ANORM1(NFL,I),I=1,60) WRITE(NEWBCD,2003) (PMUL1(NFL,I),I=1,1200) 4 CONTINUE C** DO THE SAME FOR ANNIHILATION CHANNELS C** FOR P AS TARGET C 9 L=0 DO 5 NP1=2,20 NP=NP1-1 NM=NP DO 5 NZ1=1,20 NZ=NZ1-1 L=L+1 IF(L.GT.400) GOTO 5 NT=NP+NM+NZ IF(NT.LE.1.OR.NT.GT.60) GOTO 5 PMUL2(1,L)=PMLTPC(NP,NM,NZ,NT,B(1),C) ANORM2(1,NT)=ANORM2(1,NT)+PMUL2(1,L) 5 CONTINUE C** FOR N AS TARGET L=0 DO 6 NP1=1,20 NP=NP1-1 NM=NP+1 DO 6 NZ1=1,20 NZ=NZ1-1 L=L+1 IF(L.GT.400) GOTO 6 NT=NP+NM+NZ IF(NT.LE.1.OR.NT.GT.60) GOTO 6 PMUL2(2,L)=PMLTPC(NP,NM,NZ,NT,B(2),C) ANORM2(2,NT)=ANORM2(2,NT)+PMUL2(2,L) 6 CONTINUE DO 7 I=1,60 IF(ANORM2(1,I).GT.0.) ANORM2(1,I)=1./ANORM2(1,I) IF(ANORM2(2,I).GT.0.) ANORM2(2,I)=1./ANORM2(2,I) 7 CONTINUE IF(.NOT.NPRT(10)) GOTO 10 WRITE(NEWBCD,3001) DO 8 NFL=1,2 WRITE(NEWBCD,3002) NFL WRITE(NEWBCD,3003) (ANORM2(NFL,I),I=1,60) WRITE(NEWBCD,3003) (PMUL2(NFL,I),I=1,400) 8 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-ABS(RMASS(23)) C** ELASTIC SCATTERING NP=0 NM=0 NZ=0 IPA(1)=23 IPA(2)=14 IF(NFL.EQ.2) IPA(2)=16 N=0. IF(INT.EQ.2) GOTO 20 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 120 C** INTRODUCE CHARGE AND STRANGENESS EXCHANGE REACTION C** S+B P --> LB N, S+B P --> S0B N, C** S+B P --> N LB, S+B P --> N S0B, S+B P --> P S+B C** S+B N --> N S+B CALL GRNDM(RNDM,1) RAN=RNDM(1) IRN=IFIX(RAN/0.2)+1 IF(IRN.GT.5) IRN=5 IRN=IRN+(NFL-1)*5 IPA(1)=IIPA(IRN,1) IPA(2)=IIPA(IRN,2) GOTO 120 C** ANNIHILATION CHANNELS 20 IPLAB=IFIX(P*10.)+1 IF(IPLAB.GT.10) IPLAB=IFIX((P-1.)*5.)+11 IF(IPLAB.GT.15) IPLAB=IFIX( P-2. )+16 IF(IPLAB.GT.23) IPLAB=IFIX((P-10.)/10.)+24 IF(IPLAB.GT.25) IPLAB=25 CALL GRNDM(RNDM,1) IF(RNDM(1).GT.ANHL(IPLAB)) GOTO 19 EAB=RS IF (EAB .LE. RMASS(7)+RMASS(10)) GOTO 55 GOTO 222 C** CHECK IF ENERGETICALLY POSSIBLE TO PRODUCE ONE EXTRA PION IN REACT. 19 IF (EAB .LE. RMASS(7)) GOTO 55 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 .LT. EXPXL) TEST=EXPXL IF (TEST .GT. EXPXU) TEST=EXPXU DUM1=PI*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 ANPN=ANPN+ADDNVE 21 CONTINUE ANPN=1./ANPN C** P OR N AS TARGET CALL GRNDM(RNDM,1) RAN=RNDM(1) EXCS=0. GOTO (30,40),NFL C** FOR P AS TARGET 30 L=0 DO 31 NP1=1,20 NP=NP1-1 NMM1=NP1-1 IF(NMM1.LE.1) NMM1=1 NPP1=NP1+1 DO 31 NM1=NMM1,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 .LT. EXPXL) TEST=EXPXL IF (TEST .GT. EXPXU) TEST=EXPXU DUM1=ANPN*PI*NT*PMUL1(1,L)*ANORM1(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 N AS TARGET 40 L=0 DO 41 NP1=1,20 NP=NP1-1 NMM1=NP1 IF(NMM1.LT.1) NMM1=1 NPP1=NP1+2 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 .LT. EXPXL) TEST=EXPXL IF (TEST .GT. EXPXU) TEST=EXPXU DUM1=ANPN*PI*NT*PMUL1(2,L)*ANORM1(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 C** ANNIHILATION CHANNELS 222 IPA(1)=0 IPA(2)=0 ALEAB=LOG(EAB) C** NO. OF TOTAL PARTICLES VS SQRT(S) 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 221 NT=2,60 TEST=-(PI/4.0)*(NT/N)**2 IF (TEST .LT. EXPXL) TEST=EXPXL IF (TEST .GT. EXPXU) TEST=EXPXU DUM1=PI*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 ANPN=ANPN+ADDNVE 221 CONTINUE ANPN=1./ANPN C** P OR N AS TARGET CALL GRNDM(RNDM,1) RAN=RNDM(1) EXCS=0. GOTO (230,240),NFL C** FOR P AS TARGET 230 L=0 DO 231 NP1=2,20 NP=NP1-1 NM=NP DO 231 NZ1=1,20 NZ=NZ1-1 L=L+1 IF(L.GT.400) GOTO 231 NT=NP+NM+NZ IF(NT.LE.1.OR.NT.GT.60) GOTO 231 TEST=-(PI/4.0)*(NT/N)**2 IF (TEST .LT. EXPXL) TEST=EXPXL IF (TEST .GT. EXPXU) TEST=EXPXU DUM1=ANPN*PI*NT*PMUL2(1,L)*ANORM2(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 120 231 CONTINUE GOTO 80 C** FOR N AS TARGET 240 L=0 DO 241 NP1=1,20 NP=NP1-1 NM=NP+1 DO 241 NZ1=1,20 NZ=NZ1-1 L=L+1 IF(L.GT.400) GOTO 241 NT=NP+NM+NZ IF(NT.LE.1.OR.NT.GT.60) GOTO 241 TEST=-(PI/4.0)*(NT/N)**2 IF (TEST .LT. EXPXL) TEST=EXPXL IF (TEST .GT. EXPXU) TEST=EXPXU DUM1=ANPN*PI*NT*PMUL2(2,L)*ANORM2(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 120 241 CONTINUE GOTO 80 50 IF(NPRT(4)) *WRITE(NEWBCD,1003) EAB,N,NFL,NP,NM,NZ IF(INT.EQ.1) CALL TWOB(23,NFL,N) IF(INT.EQ.2) CALL GENXPT(23,NFL,N) GO TO 9999 55 IF(NPRT(4)) *WRITE(NEWBCD,1001) GOTO 53 C** EXCLUSIVE REACTION NOT FOUND,ASSUME ELASTIC SCATTERING 80 IF(NPRT(4)) *WRITE(NEWBCD,1004) RS,N 53 INT=1 NP=0 NM=0 NZ=0 IPA(1)=23 IPA(2)=14 IF(NFL.EQ.2) IPA(2)=16 GOTO 120 100 DO 101 I=1,60 101 IPA(I)=0 IF(INT.LE.0) GOTO 131 GOTO (102,112),NFL 102 NCHT=NP-NM NCHT=NCHT+2 IF(NCHT.LE.0) NCHT=1 IF(NCHT.GT.3) NCHT=3 GOTO(103,104,105),NCHT 103 IPA(1)=24 CALL GRNDM(RNDM,1) IF(RNDM(1).LT.0.5) IPA(1)=19 IPA(2)=14 GOTO 120 104 IPA(1)=23 IPA(2)=14 CALL GRNDM(RNDM,2) IF(RNDM(1).LT.0.5) GOTO 120 IPA(1)=24 IF(RNDM(2).LT.0.5) IPA(1)=19 IPA(2)=16 GOTO 120 105 IPA(1)=23 IPA(2)=16 GOTO 120 112 NCHT=NP-NM NCHT=NCHT+3 IF(NCHT.LE.0) NCHT=1 IF(NCHT.GT.3) NCHT=3 GOTO(113,114,115),NCHT 113 IPA(1)=24 CALL GRNDM(RNDM,1) IF(RNDM(1).LT.0.5) IPA(1)=19 IPA(2)=14 GOTO 120 114 IPA(1)=24 CALL GRNDM(RNDM,2) IF(RNDM(1).LT.0.5) IPA(1)=19 IPA(2)=16 IF(RNDM(2).LT.0.5) GOTO 120 IPA(1)=23 IPA(2)=14 GOTO 120 115 IPA(1)=23 IPA(2)=16 120 NT=2 IF(IPA(1).NE.0) GOTO 119 IF(NZ.EQ.0) GOTO 118 IF(NM.EQ.0) GOTO 117 CALL GRNDM(RNDM,1) IF(RNDM(1).LT.0.5) GOTO 118 117 IPA(3)=12 NZ=NZ-1 NT=3 GOTO 119 118 IF(NM.EQ.0) GOTO 119 IPA(3)=13 NM=NM-1 NT=3 119 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(' *CASASP* CASCADE ENERGETICALLY NOT POSSIBLE', $ ' CONTINUE WITH QUASI-ELASTIC SCATTERING') 1003 FORMAT(' *CASASP* ANTISIGMA+ -INDUCED CASCADE,', $ ' AVAIL. ENERGY',2X,F8.4,/, $ 2X,' ',2X,F8.4,2X,'FROM',4(2X,I3),2X,'PARTICLES') 1004 FORMAT(' *CASASP* ANTISIGMA+ -INDUCED CASCADE,', $ ' EXCLUSIVE REACTION', $' NOT FOUND TRY ELASTIC SCATTERING AVAIL. ENERGY',2X,F8.4,/,2X, $ ' ',2X,F8.4) 2001 FORMAT(' *CASASP* TABLES FOR MULT. DATA ANTISIGMA+ INDUCED ', $ 'REACTION FOR DEFINITION OF NUMBERS SEE FORTRAN CODING') 2002 FORMAT(' *CASASP* TARGET PARTICLE FLAG',2X,I5) 2003 FORMAT(1H ,10E12.4) 2004 FORMAT(' *CASASP* ',I3,2X,'PARTICLES , MASS INDEX ARRAY',2X,20I4) 2005 FORMAT(' *CASASP* NO PARTICLES PRODUCED') 3001 FORMAT(' *CASASP* TABLES FOR MULT. DATA ANTIPROTON INDUCED ', $ 'ANNIHILATION REACTION FOR DEFINITION OF NUMBERS SEE FORTRAN', $ ' CODING') 3002 FORMAT(' *CASASP* TARGET PARTICLE FLAG',2X,I5) 3003 FORMAT(1H ,10E12.4) C 9999 CONTINUE RETURN END *CMZ : 3.14/16 06/05/91 22.27.53 by Federico Carminati *-- Author : Nick van Eijndhoven (CERN) 02/02/89 C--------------------------------------------------------------------- SUBROUTINE CASAXM(K,INT,NFL) C C *** CASCADE OF XI- BAR *** C *** NVE 17-JAN-1989 CERN GENEVA *** C C XI- BAR UNDERGOES INTERACTION WITH NUCLEON WITHIN NUCLEUS. C CHECK IF ENERGETICALLY POSSIBLE TO PRODUCE PIONS/KAONS. C IF NOT, ASSUME NUCLEAR EXCITATION OCCURS, DEGRADE INPUT PARTICLE C IN ENERGY AND NO OTHER PARTICLES ARE 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 COMMON/PRNTFL/INBCD,NEWBCD,INBIN,NEWBIN,NPEVT,NEVTP,LPRT,NPRT(10) LOGICAL LPRT,NPRT C C --- INITIALIZATION FLAGS FOR VARIOUS GHEISHA ROUTINES --- COMMON /KGINIT/ KGINIT(50) C SAVE C C *** NOT YET FINISHED ==> TAKE XI- CASCADE INSTEAD *** C C --- INITIALIZATION INDICATED BY KGINIT(22) --- KGINIT(22)=1 C IF (NPRT(4)) PRINT 1000 1000 FORMAT(' *CASAXM* NOT WRITTEN YET ==> CASXM CALLED INSTEAD') C CALL CASXM(K,INT,NFL) C 9999 CONTINUE RETURN END *CMZ : 3.14/16 06/05/91 22.27.53 by Federico Carminati *-- Author : Nick van Eijndhoven (CERN) 02/02/89 C--------------------------------------------------------------------- SUBROUTINE CASAX0(K,INT,NFL) C C *** CASCADE OF XI0 BAR *** C *** NVE 17-JAN-1989 CERN GENEVA *** C C XI0 BAR UNDERGOES INTERACTION WITH NUCLEON WITHIN NUCLEUS. C CHECK IF ENERGETICALLY POSSIBLE TO PRODUCE PIONS/KAONS. C IF NOT, ASSUME NUCLEAR EXCITATION OCCURS, DEGRADE INPUT PARTICLE C IN ENERGY AND NO OTHER PARTICLES ARE 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 COMMON/PRNTFL/INBCD,NEWBCD,INBIN,NEWBIN,NPEVT,NEVTP,LPRT,NPRT(10) LOGICAL LPRT,NPRT C C --- INITIALIZATION FLAGS FOR VARIOUS GHEISHA ROUTINES --- COMMON /KGINIT/ KGINIT(50) C SAVE C C *** NOT YET FINISHED ==> TAKE XI0 CASCADE INSTEAD *** C C --- INITIALIZATION INDICATED BY KGINIT(23) --- KGINIT(23)=1 C IF (NPRT(4)) PRINT 1000 1000 FORMAT(' *CASAX0* NOT WRITTEN YET ==> CASX0 CALLED INSTEAD') C CALL CASX0(K,INT,NFL) C 9999 CONTINUE RETURN END *CMZ : 3.14/16 06/05/91 22.27.50 BY FEDERICO CARMINATI *-- AUTHOR : C--------------------------------------------------------------------- SUBROUTINE CASFRG(NUCFLG,INT,NFL) C C *** CASCADE OF HEAVY FRAGMENTS *** C *** NVE 11-MAY-1988 CERN GENEVA *** C C ORIGIN : H.FESEFELDT (02-DEC-1986) C SAVE C --- NUCFLG IS A FLAG TO DENOTE THE NUCREC ACTION --- C NUCFLG = 0 ==> NO ACTION TAKEN BY NUCREC C 1 ==> ACTION TAKEN BY NUCREC NUCFLG=1 CALL NUCREC(NOPT,2) IF (NOPT .NE. 0) GO TO 9999 C NUCFLG=0 CALL COSCAT C 9999 CONTINUE RETURN END *CMZ : 3.16/00 05/11/93 19.16.15 BY FEDERICO CARMINATI *-- AUTHOR : C--------------------------------------------------------------------- SUBROUTINE CASKM(K,INT,NFL) C C *** CASCADE OF K- *** C *** NVE 04-MAY-1988 CERN GENEVA *** C C ORIGIN : H.FESEFELDT (13-SEP-1987) C C K- 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 PARAMETER (MXGKGH=100) COMMON/CONSTS/ PI,TWPI,PIBTW,MP,MPI,MMU,MEL,MKCH,MK0,SMP,SMPI, $ SMU,CT,CTKCH,CTK0, $ ML0,MSP,MS0,MSM,MX0,MXM,CTL0,CTSP,CTSM,CTX0,CTXM, $ RMASS(35),RCHARG(35) C REAL MP,MPI,MMU,MEL,MKCH,MK0, * ML0,MSP,MS0,MSM,MX0,MXM C PARAMETER (MXGKCU=MXGKGH) COMMON/CURPAR/WEIGHT(10),DDELTN,IFILE,IRUN,NEVT,NEVENT,SHFLAG, * ITHST,ITTOT,ITLST,IFRND,TOFCUT,CMOM(5),CENG(5), * RS,S,ENP(10),NP,NM,NN,NR,NO,NZ,IPA(MXGKCU), * ATNO2,ZNO2 C COMMON/RESULT/XEND,YEND,ZEND,RCA,RCE,AMAS,NCH,TOF,PX,PY,PZ, * USERW,INTCT,P,EN,EK,AMASQ,DELTN,ITK,NTK,IPART,IND, * LCALO,ICEL,SINL,COSL,SINP,COSP, * XOLD,YOLD,ZOLD,POLD,PXOLD,PYOLD,PZOLD, * XSCAT,YSCAT,ZSCAT,PSCAT,PXSCAT,PYSCAT,PZSCAT REAL NCH,INTCT C COMMON/PRNTFL/INBCD,NEWBCD,INBIN,NEWBIN,NPEVT,NEVTP,LPRT,NPRT(10) LOGICAL LPRT,NPRT C C --- INITIALIZATION FLAGS FOR VARIOUS GHEISHA ROUTINES --- COMMON /KGINIT/ KGINIT(50) C C --- BOUNDARY LIMITS FOR ARGUMENTS OF INTRINSIC FUNCTIONS --- C --- XL DENOTES LOWER BOUND WHEREAS XU DENOTES UPPER BOUND --- COMMON /LIMITS/ EXPXL,EXPXU C C REAL N DIMENSION PMUL(2,1200),ANORM(2,60),CECH(10),CNK0(20),PIY1(4), $ PIY2(3),IPIY1(2,4),IPIY2(2,3),IPIY3(2,3),B(2) DIMENSION RNDM(1) SAVE PMUL,ANORM SAVE DATA CECH/1.,1.,1.,0.70,0.60,0.55,0.35,0.25,0.18,0.15/ DATA CNK0/0.17,0.18,0.17,0.24,0.26,0.20,0.22,0.21,0.34,0.45 $ ,0.58,0.55,0.36,0.29,0.29,0.32,0.32,0.33,0.33,0.33/ DATA PIY1/0.67,0.78,0.89,1.00/,PIY2/0.68,0.84,1.00/ DATA IPIY1/8,18,9,20,8,21,7,22/ DATA IPIY2/9,18,9,21,8,22/,IPIY3/7,18,8,20,7,21/ DATA B/0.7,0.7/,C/1.25/ C C --- INITIALIZATION INDICATED BY KGINIT(4) --- IF (KGINIT(4) .NE. 0) GO TO 10 KGINIT(4)=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 P AS TARGET C L=0 DO 1 NP1=1,20 NP=NP1-1 NMM1=NP1-1 IF(NMM1.LE.1) NMM1=1 NPP1=NP1+1 DO 1 NM1=NMM1,NPP1 NM=NM1-1 DO 1 NZ1=1,20 NZ=NZ1-1 L=L+1 IF(L.GT.1200) GOTO 1 NT=NP+NM+NZ IF(NT.LE.0.OR.NT.GT.60) GOTO 1 PMUL(1,L)=PMLTPC(NP,NM,NZ,NT,B(1),C) ANORM(1,NT)=ANORM(1,NT)+PMUL(1,L) 1 CONTINUE C** FOR N AS TARGET L=0 DO 2 NP1=1,20 NP=NP1-1 NPP1=NP1+2 DO 2 NM1=NP1,NPP1 NM=NM1-1 DO 2 NZ1=1,20 NZ=NZ1-1 L=L+1 IF(L.GT.1200) GOTO 2 NT=NP+NM+NZ IF(NT.LE.0.OR.NT.GT.60) GOTO 2 PMUL(2,L)=PMLTPC(NP,NM,NZ,NT,B(2),C) 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(13) C C** ELASTIC SCATTERING NP=0 NM=0 NZ=0 N=0. IPA(1)=13 IPA(2)=14 IF(NFL.EQ.2) IPA(2)=16 IF(INT.EQ.2) GOTO 20 GOTO 100 C** CHECK IF ENERGETICALLY POSSIBLE TO PRODUCE ONE EXTRA PION IN REACT. 20 IPLAB=IFIX(P*5.)+1 IF(IPLAB.GT.10) GOTO 22 CALL GRNDM(RNDM,1) IF(RNDM(1).LT.CECH(IPLAB)) GOTO 19 IF (EAB .LT. RMASS(7)) GOTO 55 GOTO 22 C** CHARGE EXCHANGE REACTION (IS INCLUDED IN INELASTIC CROSS SECTION) 19 IPLAB=IFIX(P*10.)+1 IF(IPLAB.GT.20) IPLAB=20 CALL GRNDM(RNDM,1) IF(RNDM(1).GT.CNK0(IPLAB)) GOTO 24 IF(NFL.EQ.1) GOTO 23 C** FOR K- N REACTION NO K N STRANGENESS EXCHANGE POSSIBLE INT=1 IPA(1)=13 IPA(2)=16 GOTO 100 23 INT=1 IPA(1)=12 IPA(2)=16 GOTO 100 C** P L, P S REACTIONS 24 CALL GRNDM(RNDM,1) RAN=RNDM(1) IF(RAN.LT.0.25) GOTO 25 IF(RAN.LT.0.50) GOTO 26 IF(RAN.LT.0.75) GOTO 27 C** K- P --> PI0 L OR K- N --> PI- L IPA(1)=8 IF(NFL.EQ.2) IPA(1)=9 IPA(2)=18 GOTO 100 C** K- P --> PI- S+ 25 IPA(1)=9 IPA(2)=20 IF(NFL.EQ.1) GOTO 100 IPA(1)=13 IPA(2)=16 GOTO 100 C** K- P --> PI0 S0 OR K- N --> PI- S0 26 IPA(1)=8 IF(NFL.EQ.2) IPA(1)=9 IPA(2)=21 GOTO 100 C** K- P --> PI+ S- OR K- N --> PI0 S- 27 IPA(1)=7 IF(NFL.EQ.2) IPA(1)=8 IPA(2)=22 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 .LT. EXPXL) TEST=EXPXL IF (TEST .GT. EXPXU) TEST=EXPXU DUM1=PI*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 ANPN=ANPN+ADDNVE 21 CONTINUE ANPN=1./ANPN C** P OR N AS TARGET CALL GRNDM(RNDM,1) RAN=RNDM(1) EXCS=0. GOTO (30,40),NFL C** FOR P AS TARGET 30 L=0 DO 31 NP1=1,20 NP=NP1-1 NMM1=NP1-1 IF(NMM1.LE.1) NMM1=1 NPP1=NP1+1 DO 31 NM1=NMM1,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 .LT. EXPXL) TEST=EXPXL IF (TEST .GT. EXPXU) TEST=EXPXU 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 50 31 CONTINUE GOTO 80 C** FOR N AS TARGET 40 L=0 DO 41 NP1=1,20 NP=NP1-1 NPP1=NP1+2 DO 41 NM1=NP1,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 .LT. EXPXL) TEST=EXPXL IF (TEST .GT. EXPXU) TEST=EXPXU 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 50 41 CONTINUE GOTO 80 50 GOTO (60,65),NFL 60 IF(NP.EQ.NM) GOTO 61 IF(NP.EQ.1+NM) GOTO 63 IPA(1)=12 IPA(2)=14 GOTO 90 61 CALL GRNDM(RNDM,1) IF(RNDM(1).LT.0.75) GOTO 62 IPA(1)=12 IPA(2)=16 GOTO 90 62 IPA(1)=13 IPA(2)=14 GOTO 90 63 IPA(1)=13 IPA(2)=16 GOTO 90 65 IF(NP.EQ.-1+NM) GOTO 66 IF(NP.EQ.NM) GOTO 68 IPA(1)=12 IPA(2)=16 GOTO 90 66 CALL GRNDM(RNDM,1) IF(RNDM(1).LT.0.50) GOTO 67 IPA(1)=12 IPA(2)=16 GOTO 90 67 IPA(1)=13 IPA(2)=14 GOTO 90 68 IPA(1)=13 IPA(2)=16 C** PI Y PRODUCTION INSTEAD OF K N 90 CALL GRNDM(RNDM,1) IF(RNDM(1).LT.0.5) GOTO 100 IF(IPA(1).EQ.13.AND.IPA(2).EQ.16) GOTO 95 IF(IPA(1).EQ.11.AND.IPA(2).EQ.14) GOTO 95 IF(IPA(1).EQ.12.AND.IPA(2).EQ.14) GOTO 95 CALL GRNDM(RNDM,1) RAN=RNDM(1) DO 91 I=1,4 IF(RAN.LT.PIY1(I)) GOTO 92 91 CONTINUE GOTO 100 92 IPA(1)=IPIY1(1,I) IPA(2)=IPIY1(2,I) GOTO 100 95 CALL GRNDM(RNDM,1) RAN=RNDM(1) DO 96 I=1,3 IF(RAN.LT.PIY2(I)) GOTO 97 96 CONTINUE GOTO 100 97 IF(IPA(2).EQ.14) GOTO 98 IPA(1)=IPIY2(1,I) IPA(2)=IPIY2(2,I) GOTO 100 98 IPA(1)=IPIY3(1,I) IPA(2)=IPIY3(2,I) GOTO 100 70 IF(NPRT(4)) *WRITE(NEWBCD,1003) EAB,N,NFL,NP,NM,NZ CALL STPAIR IF(INT.EQ.1) CALL TWOB(13,NFL,N) IF(INT.EQ.2) CALL GENXPT(13,NFL,N) GO TO 9999 C** NUCLEAR EXCITATION 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 N=0. IPA(1)=13 IPA(2)=14 IF(NFL.EQ.2) IPA(2)=16 100 DO 101 I=3,60 101 IPA(I)=0 IF(INT.LE.0) GOTO 131 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) DO 132 I=1,NT IF(IPA(I).NE.12) GOTO 132 CALL GRNDM(RNDM,1) IF(RNDM(1).LT.0.5) GOTO 132 IPA(I)=11 132 CONTINUE GOTO 70 131 IF(NPRT(4)) *WRITE(NEWBCD,2005) C 1001 FORMAT(' *CASKM* CASCADE ENERGETICALLY NOT POSSIBLE', $ ' CONTINUE WITH QUASI-ELASTIC SCATTERING') 1003 FORMAT(' *CASKM* KAON- -INDUCED CASCADE,', $ ' AVAIL. ENERGY',2X,F8.4,/, $ 2X,' ',2X,F8.4,2X,'FROM',4(2X,I3),2X,'PARTICLES') 1004 FORMAT(' *CASKM* KAON- -INDUCED CASCADE,', $ ' EXCLUSIVE REACTION NOT FOUND', $ ' TRY ELASTIC SCATTERING AVAIL. ENERGY',2X,F8.4,/,2X, $ ' ',2X,F8.4) 2001 FORMAT(' *CASKM* TABLES FOR MULT. DATA KAON- INDUCED REACTION', $ ' FOR DEFINITION OF NUMBERS SEE FORTRAN CODING') 2002 FORMAT(' *CASKM* TARGET PARTICLE FLAG',2X,I5) 2003 FORMAT(1H ,10E12.4) 2004 FORMAT(' *CASKM* ',I3,2X,'PARTICLES , MASS INDEX ARRAY',2X,20I4) 2005 FORMAT(' *CASKM* NO PARTICLES PRODUCED') C 9999 CONTINUE RETURN END *CMZ : 3.16/00 05/11/93 19.17.03 BY FEDERICO CARMINATI *-- AUTHOR : C--------------------------------------------------------------------- SUBROUTINE CASKP(K,INT,NFL) C C *** CASCADE OF K+ *** C *** NVE 04-MAY-1988 CERN GENEVA *** C C ORIGIN : H.FESEFELDT (13-SEP-1987) C C K+ 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 PARAMETER (MXGKGH=100) PARAMETER (MXGKCU=MXGKGH) COMMON/CURPAR/WEIGHT(10),DDELTN,IFILE,IRUN,NEVT,NEVENT,SHFLAG, * ITHST,ITTOT,ITLST,IFRND,TOFCUT,CMOM(5),CENG(5), * RS,S,ENP(10),NP,NM,NN,NR,NO,NZ,IPA(MXGKCU), * ATNO2,ZNO2 C COMMON/CONSTS/ PI,TWPI,PIBTW,MP,MPI,MMU,MEL,MKCH,MK0,SMP,SMPI, $ SMU,CT,CTKCH,CTK0, $ ML0,MSP,MS0,MSM,MX0,MXM,CTL0,CTSP,CTSM,CTX0,CTXM, $ RMASS(35),RCHARG(35) C REAL MP,MPI,MMU,MEL,MKCH,MK0, * ML0,MSP,MS0,MSM,MX0,MXM C COMMON/RESULT/XEND,YEND,ZEND,RCA,RCE,AMAS,NCH,TOF,PX,PY,PZ, * USERW,INTCT,P,EN,EK,AMASQ,DELTN,ITK,NTK,IPART,IND, * LCALO,ICEL,SINL,COSL,SINP,COSP, * XOLD,YOLD,ZOLD,POLD,PXOLD,PYOLD,PZOLD, * XSCAT,YSCAT,ZSCAT,PSCAT,PXSCAT,PYSCAT,PZSCAT REAL NCH,INTCT C COMMON/PRNTFL/INBCD,NEWBCD,INBIN,NEWBIN,NPEVT,NEVTP,LPRT,NPRT(10) LOGICAL LPRT,NPRT C C --- INITIALIZATION FLAGS FOR VARIOUS GHEISHA ROUTINES --- COMMON /KGINIT/ KGINIT(50) C C --- BOUNDARY LIMITS FOR ARGUMENTS OF INTRINSIC FUNCTIONS --- C --- XL DENOTES LOWER BOUND WHEREAS XU DENOTES UPPER BOUND --- COMMON /LIMITS/ EXPXL,EXPXU C C REAL N DIMENSION PMUL(2,1200),ANORM(2,60),SUPP(10),CECH(10),B(2) DIMENSION RNDM(1) SAVE PMUL,ANORM SAVE DATA SUPP/0.,0.4,0.55,0.65,0.75,0.82,0.86,0.90,0.94,0.98/ DATA CECH/0.33,0.27,0.29,0.31,0.27,0.18,0.13,0.10,0.09,0.07/ DATA B/0.7,0.7/,C/1.25/ C C --- INITIALIZATION INDICATED BY KGINIT(5) --- IF (KGINIT(5) .NE. 0) GO TO 10 KGINIT(5)=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 P AS TARGET C L=0 DO 1 NP1=1,20 NP=NP1-1 NMM1=NP1-2 IF(NMM1.LE.1) NMM1=1 DO 1 NM1=NMM1,NP1 NM=NM1-1 DO 1 NZ1=1,20 NZ=NZ1-1 L=L+1 IF(L.GT.1200) GOTO 1 NT=NP+NM+NZ IF(NT.LE.0.OR.NT.GT.60) GOTO 1 PMUL(1,L)=PMLTPC(NP,NM,NZ,NT,B(1),C) ANORM(1,NT)=ANORM(1,NT)+PMUL(1,L) 1 CONTINUE C** FOR N 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 NT=NP+NM+NZ IF(NT.LE.0.OR.NT.GT.60) GOTO 2 PMUL(2,L)=PMLTPC(NP,NM,NZ,NT,B(2),C) 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(10) C C** ELASTIC SCATTERING NP=0 NM=0 NZ=0 N=0. IPA(1)=10 IPA(2)=14 IF(NFL.EQ.2) IPA(2)=16 IF(INT.EQ.2) GOTO 20 C** FOR K+ N REACTIONS CHANGE SOME OF THE ELASTIC CROSS SECTION C** TO K+ N --> K0 P IF(NFL.EQ.1) GOTO 100 IPLAB=IFIX(P *5.)+1 IF(IPLAB.GT.10) IPLAB=10 CALL GRNDM(RNDM,1) IF(RNDM(1).GT.CECH(IPLAB)/ATNO2**0.42) GOTO 100 IPA(1)=11 IPA(2)=14 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 (23,24),NFL 23 CONTINUE TEST=-(1+B(1))**2/(2.0*C**2) IF (TEST .LT. EXPXL) TEST=EXPXL IF (TEST .GT. EXPXU) TEST=EXPXU W0=EXP(TEST) WP=EXP(TEST) WP=WP*2.0 CALL GRNDM(RNDM,1) RAN=RNDM(1) NP=0 NM=0 NZ=1 IF(RAN.LT.W0/(W0+WP)) GOTO 50 NP=1 NM=0 NZ=0 GOTO 50 24 CONTINUE TEST=-(1+B(2))**2/(2.0*C**2) IF (TEST .LT. EXPXL) TEST=EXPXL IF (TEST .GT. EXPXU) TEST=EXPXU W0=EXP(TEST) WP=EXP(TEST) TEST=-(-1+B(2))**2/(2.0*C**2) IF (TEST .LT. EXPXL) TEST=EXPXL IF (TEST .GT. EXPXU) TEST=EXPXU WM=EXP(TEST) 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 50 NP=1 NM=0 NZ=0 IF(RAN.LT.WP/WT) GOTO 50 NP=0 NM=1 NZ=0 GOTO 50 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 .LT. EXPXL) TEST=EXPXL IF (TEST .GT. EXPXU) TEST=EXPXU DUM1=PI*NT/(2.0*N*N) DUM2=ABS(DUM1) DUM3=EXP(TEST) ADDNVE=0.0 IF (DUM2 .GE. 1) ADDNVE=DUM1*DUM3 IF ((DUM2 .LT. 1) .AND. (DUM3 .GE. 1.0E-10)) ADDNVE=DUM1*DUM3 ANPN=ANPN+ADDNVE 21 CONTINUE ANPN=1./ANPN C** P OR N AS TARGET CALL GRNDM(RNDM,1) RAN=RNDM(1) EXCS=0. GOTO (30,40),NFL C** FOR P AS TARGET 30 L=0 DO 31 NP1=1,20 NP=NP1-1 NMM1=NP1-2 IF(NMM1.LE.1) NMM1=1 DO 31 NM1=NMM1,NP1 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 .LT. EXPXL) TEST=EXPXL IF (TEST .GT. EXPXU) TEST=EXPXU 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) ADDNVE=DUM1*DUM3 IF ((DUM2 .LT. 1) .AND. (DUM3 .GE. 1.0E-10)) ADDNVE=DUM1*DUM3 EXCS=EXCS+ADDNVE IF(RAN.LT.EXCS) GOTO 50 31 CONTINUE GOTO 80 C** FOR N 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 .LT. EXPXL) TEST=EXPXL IF (TEST .GT. EXPXU) TEST=EXPXU 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) ADDNVE=DUM1*DUM3 IF ((DUM2 .LT. 1) .AND. (DUM3 .GE. 1.0E-10)) ADDNVE=DUM1*DUM3 EXCS=EXCS+ADDNVE IF(RAN.LT.EXCS) GOTO 50 41 CONTINUE GOTO 80 50 GOTO (60,65),NFL 60 IF(NP.EQ.1+NM) GOTO 61 IF(NP.EQ.2+NM) GOTO 63 IPA(1)=10 IPA(2)=14 GOTO 100 61 CALL GRNDM(RNDM,1) IF(RNDM(1).LT.0.5) GOTO 62 IPA(1)=10 IPA(2)=16 GOTO 100 62 IPA(1)=11 IPA(2)=14 GOTO 100 63 IPA(1)=11 IPA(2)=16 GOTO 100 65 IF(NP.EQ.NM) GOTO 66 IF(NP.EQ.1+NM) GOTO 68 IPA(1)=10 IPA(2)=14 GOTO 100 66 CALL GRNDM(RNDM,1) IF(RNDM(1).LT.0.25) GOTO 67 IPA(1)=10 IPA(2)=16 GOTO 100 67 IPA(1)=11 IPA(2)=14 GOTO 100 68 IPA(1)=11 IPA(2)=16 GOTO 100 70 IF(NPRT(4)) *WRITE(NEWBCD,1003) EAB,N,NFL,NP,NM,NZ CALL STPAIR IF(INT.EQ.1) CALL TWOB(10,NFL,N) IF(INT.EQ.2) CALL GENXPT(10,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 N=0. IPA(1)=10 IPA(2)=14 IF(NFL.EQ.2) IPA(2)=16 100 DO 101 I=3,60 101 IPA(I)=0 IF(INT.LE.0) GOTO 131 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) DO 132 I=1,NT IF(IPA(I).NE.11) GOTO 132 CALL GRNDM(RNDM,1) IF(RNDM(1).LT.0.5) GOTO 132 IPA(I)=12 132 CONTINUE GOTO 70 131 IF(NPRT(4)) *WRITE(NEWBCD,2005) C 1001 FORMAT(' *CASKP* CASCADE ENERGETICALLY NOT POSSIBLE', $ ' CONTINUE WITH QUASI-ELASTIC SCATTERING') 1003 FORMAT(' *CASKP* KAON+ -INDUCED CASCADE,', $ ' AVAIL. ENERGY',2X,F8.4,/, $ 2X,' ',2X,F8.4,2X,'FROM',4(2X,I3),2X,'PARTICLES') 1004 FORMAT(' *CASKP* KAON+ -INDUCED CASCADE,', $ ' EXCLUSIVE REACTION NOT FOUND', $ 'TRY ELASTIC SCATTERING AVAIL. ENERGY',2X,F8.4,/,2X, $ ' ',2X,F8.4) 2001 FORMAT(' *CASKP* TABLES FOR MULT. DATA KAON+ INDUCED REACTION', $ ' FOR DEFINITION OF NUMBERS SEE FORTRAN CODING') 2002 FORMAT(' *CASKP* TARGET PARTICLE FLAG',2X,I5) 2003 FORMAT(1H ,10E12.4) 2004 FORMAT(' *CASKP* ',I3,2X,'PARTICLES , MASS INDEX ARRAY',2X,20I4) 2005 FORMAT(' *CASKP* NO PARTICLES PRODUCED') C 9999 CONTINUE RETURN END *CMZ : 3.16/00 05/11/93 19.17.27 BY FEDERICO CARMINATI *-- AUTHOR : C--------------------------------------------------------------------- SUBROUTINE CASK0(K,INT,NFL) C C *** CASCADE OF K0 *** C *** NVE 04-MAY-1988 CERN GENEVA *** C C ORIGIN : H.FESEFELDT (13-SEP-1987) C C K0 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 PARAMETER (MXGKGH=100) COMMON/CONSTS/ PI,TWPI,PIBTW,MP,MPI,MMU,MEL,MKCH,MK0,SMP,SMPI, $ SMU,CT,CTKCH,CTK0, $ ML0,MSP,MS0,MSM,MX0,MXM,CTL0,CTSP,CTSM,CTX0,CTXM, $ RMASS(35),RCHARG(35) C REAL MP,MPI,MMU,MEL,MKCH,MK0, * ML0,MSP,MS0,MSM,MX0,MXM C PARAMETER (MXGKCU=MXGKGH) COMMON/CURPAR/WEIGHT(10),DDELTN,IFILE,IRUN,NEVT,NEVENT,SHFLAG, * ITHST,ITTOT,ITLST,IFRND,TOFCUT,CMOM(5),CENG(5), * RS,S,ENP(10),NP,NM,NN,NR,NO,NZ,IPA(MXGKCU), * ATNO2,ZNO2 C COMMON/RESULT/XEND,YEND,ZEND,RCA,RCE,AMAS,NCH,TOF,PX,PY,PZ, * USERW,INTCT,P,EN,EK,AMASQ,DELTN,ITK,NTK,IPART,IND, * LCALO,ICEL,SINL,COSL,SINP,COSP, * XOLD,YOLD,ZOLD,POLD,PXOLD,PYOLD,PZOLD, * XSCAT,YSCAT,ZSCAT,PSCAT,PXSCAT,PYSCAT,PZSCAT REAL NCH,INTCT C COMMON/PRNTFL/INBCD,NEWBCD,INBIN,NEWBIN,NPEVT,NEVTP,LPRT,NPRT(10) LOGICAL LPRT,NPRT C C --- INITIALIZATION FLAGS FOR VARIOUS GHEISHA ROUTINES --- COMMON /KGINIT/ KGINIT(50) C C --- BOUNDARY LIMITS FOR ARGUMENTS OF INTRINSIC FUNCTIONS --- C --- XL DENOTES LOWER BOUND WHEREAS XU DENOTES UPPER BOUND --- COMMON /LIMITS/ EXPXL,EXPXU C C REAL N DIMENSION PMUL(2,1200),ANORM(2,60),SUPP(10),CECH(10),B(2) DIMENSION RNDM(1) SAVE PMUL,ANORM SAVE DATA SUPP/0.,0.4,0.55,0.65,0.75,0.82,0.86,0.90,0.94,0.98/ DATA CECH/0.33,0.27,0.29,0.31,0.27,0.18,0.13,0.10,0.09,0.07/ DATA B/0.7,0.7/,C/1.25/ C C --- INITIALIZATION INDICATED BY KGINIT(6) --- IF (KGINIT(6) .NE. 0) GO TO 10 KGINIT(6)=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 P AS TARGET C L=0 DO 1 NP1=1,20 NP=NP1-1 NMM1=NP1-1 IF(NMM1.LE.1) NMM1=1 NPP1=NP1+1 DO 1 NM1=NMM1,NPP1 NM=NM1-1 DO 1 NZ1=1,20 NZ=NZ1-1 L=L+1 IF(L.GT.1200) GOTO 1 NT=NP+NM+NZ IF(NT.LE.0.OR.NT.GT.60) GOTO 1 PMUL(1,L)=PMLTPC(NP,NM,NZ,NT,B(1),C) ANORM(1,NT)=ANORM(1,NT)+PMUL(1,L) 1 CONTINUE C** FOR N AS TARGET L=0 DO 2 NP1=1,20 NP=NP1-1 NMM1=NP1-2 IF(NMM1.LE.1) NMM1=1 DO 2 NM1=NMM1,NP1 NM=NM1-1 DO 2 NZ1=1,20 NZ=NZ1-1 L=L+1 IF(L.GT.1200) GOTO 2 NT=NP+NM+NZ IF(NT.LE.0.OR.NT.GT.60) GOTO 2 PMUL(2,L)=PMLTPC(NP,NM,NZ,NT,B(2),C) 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(11) C C** ELASTIC SCATTERING NP=0 NM=0 NZ=0 N=0. IPA(1)=11 IPA(2)=14 IF(NFL.EQ.2) IPA(2)=16 IF(INT.EQ.2) GOTO 20 C** FOR K0 P REACTIONS CHANGE SOME OF THE ELASTIC CROSS SECTION C** TO K0 P --> K+ N IF(NFL.EQ.2) GOTO 100 IPLAB=IFIX(P *5.)+1 IF(IPLAB.GT.10) IPLAB=10 CALL GRNDM(RNDM,1) IF(RNDM(1).GT.CECH(IPLAB)/ATNO2**0.42) GOTO 100 IPA(1)=10 IPA(2)=16 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(1))**2/(2.0*C**2) IF (TEST .LT. EXPXL) TEST=EXPXL IF (TEST .GT. EXPXU) TEST=EXPXU W0=EXP(TEST) TEST=-(-1+B(1))**2/(2.0*C**2) IF (TEST .LT. EXPXL) TEST=EXPXL IF (TEST .GT. EXPXU) TEST=EXPXU WM=EXP(TEST) W0=W0/2.0 WM=WM*1.5 CALL GRNDM(RNDM,1) RAN=RNDM(1) NP=0 NM=0 NZ=1 IF(RAN.LT.W0/(W0+WM)) GOTO 50 NP=0 NM=1 NZ=0 GOTO 50 24 CONTINUE TEST=-(1+B(2))**2/(2.0*C**2) IF (TEST .LT. EXPXL) TEST=EXPXL IF (TEST .GT. EXPXU) TEST=EXPXU W0=EXP(TEST) WP=EXP(TEST) TEST=-(-1+B(2))**2/(2.0*C**2) IF (TEST .LT. EXPXL) TEST=EXPXL IF (TEST .GT. EXPXU) TEST=EXPXU WM=EXP(TEST) 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 50 NP=1 NM=0 NZ=0 IF(RAN.LT.WP/WT) GOTO 50 NP=0 NM=1 NZ=0 GOTO 50 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 .LT. EXPXL) TEST=EXPXL IF (TEST .GT. EXPXU) TEST=EXPXU DUM1=PI*NT/(2.0*N*N) DUM2=ABS(DUM1) DUM3=EXP(TEST) ADDNVE=0.0 IF (DUM2 .GE. 1) ADDNVE=DUM1*DUM3 IF ((DUM2 .LT. 1) .AND. (DUM3 .GE. 1.0E-10)) ADDNVE=DUM1*DUM3 ANPN=ANPN+ADDNVE 21 CONTINUE ANPN=1./ANPN C** P OR N AS TARGET CALL GRNDM(RNDM,1) RAN=RNDM(1) EXCS=0. GOTO (30,40),NFL C** FOR P AS TARGET 30 L=0 DO 31 NP1=1,20 NP=NP1-1 NMM1=NP1-1 IF(NMM1.LE.1) NMM1=1 NPP1=NP1+1 DO 31 NM1=NMM1,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 .LT. EXPXL) TEST=EXPXL IF (TEST .GT. EXPXU) TEST=EXPXU 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) ADDNVE=DUM1*DUM3 IF ((DUM2 .LT. 1) .AND. (DUM3 .GE. 1.0E-10)) ADDNVE=DUM1*DUM3 EXCS=EXCS+ADDNVE IF(RAN.LT.EXCS) GOTO 50 31 CONTINUE GOTO 80 C** FOR N AS TARGET 40 L=0 DO 41 NP1=1,20 NP=NP1-1 NMM1=NP1-2 IF(NMM1.LE.1) NMM1=1 DO 41 NM1=NMM1,NP1 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 .LT. EXPXL) TEST=EXPXL IF (TEST .GT. EXPXU) TEST=EXPXU 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) ADDNVE=DUM1*DUM3 IF ((DUM2 .LT. 1) .AND. (DUM3 .GE. 1.0E-10)) ADDNVE=DUM1*DUM3 EXCS=EXCS+ADDNVE IF(RAN.LT.EXCS) GOTO 50 41 CONTINUE GOTO 80 50 GOTO (65,60),NFL 60 IF(NP.EQ.1+NM) GOTO 61 IF(NP.EQ.2+NM) GOTO 63 IPA(1)=11 IPA(2)=16 GOTO 100 61 CALL GRNDM(RNDM,1) IF(RNDM(1).LT.0.5) GOTO 62 IPA(1)=11 IPA(2)=14 GOTO 100 62 IPA(1)=10 IPA(2)=16 GOTO 100 63 IPA(1)=10 IPA(2)=14 GOTO 100 65 IF(NP.EQ.NM) GOTO 66 IF(NP.EQ.1+NM) GOTO 68 IPA(1)=11 IPA(2)=16 GOTO 100 66 CALL GRNDM(RNDM,1) IF(RNDM(1).LT.0.25) GOTO 67 IPA(1)=11 IPA(2)=14 GOTO 100 67 IPA(1)=10 IPA(2)=16 GOTO 100 68 IPA(1)=11 IPA(2)=16 GOTO 100 70 IF(NPRT(4)) *WRITE(NEWBCD,1003) EAB,N,NFL,NP,NM,NZ CALL STPAIR IF(INT.EQ.1) CALL TWOB(11,NFL,N) IF(INT.EQ.2) CALL GENXPT(11,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 N=0. IPA(1)=11 IPA(2)=14 IF(NFL.EQ.2) IPA(2)=16 100 DO 101 I=3,60 101 IPA(I)=0 IF(INT.LE.0) GOTO 131 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) DO 132 I=1,NT IF(IPA(I).NE.11) GOTO 132 CALL GRNDM(RNDM,1) IF(RNDM(1).LT.0.5) GOTO 132 IPA(I)=12 132 CONTINUE GOTO 70 131 IF(NPRT(4)) *WRITE(NEWBCD,2005) C 1001 FORMAT(' *CASK0* CASCADE ENERGETICALLY NOT POSSIBLE', $ ' CONTINUE WITH QUASI-ELASTIC SCATTERING') 1003 FORMAT(' *CASK0* K0 -INDUCED CASCADE,', $ ' AVAIL. ENERGY',2X,F8.4,/, $ 2X,' ',2X,F8.4,2X,'FROM',4(2X,I3),2X,'PARTICLES') 1004 FORMAT(' *CASK0* K0 -INDUCED CASCADE,', $ ' EXCLUSIVE REACTION NOT FOUND', $ ' TRY ELASTIC SCATTERING AVAIL. ENERGY',2X,F8.4,/,2X, $ ' ',2X,F8.4) 2001 FORMAT(' *CASK0* TABLES FOR MULT. DATA K0 INDUCED REACTION', $ ' FOR DEFINITION OF NUMBERS SEE FORTRAN CODING') 2002 FORMAT(' *CASK0* TARGET PARTICLE FLAG',2X,I5) 2003 FORMAT(1H ,10E12.4) 2004 FORMAT(' *CASK0* ',I3,2X,'PARTICLES , MASS INDEX ARRAY',2X,20I4) 2005 FORMAT(' *CASK0* NO PARTICLES PRODUCED') C 9999 CONTINUE RETURN END *CMZ : 3.16/00 05/11/93 19.17.46 BY FEDERICO CARMINATI *-- AUTHOR : C--------------------------------------------------------------------- SUBROUTINE CASK0B(K,INT,NFL) C C *** CASCADE OF ANTI K0 *** C *** NVE 04-MAY-1988 CERN GENEVA *** C C ORIGIN : H.FESEFELDT (13-SEP-1987) C C K0B 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 PARAMETER (MXGKGH=100) COMMON/CONSTS/ PI,TWPI,PIBTW,MP,MPI,MMU,MEL,MKCH,MK0,SMP,SMPI, $ SMU,CT,CTKCH,CTK0, $ ML0,MSP,MS0,MSM,MX0,MXM,CTL0,CTSP,CTSM,CTX0,CTXM, $ RMASS(35),RCHARG(35) C REAL MP,MPI,MMU,MEL,MKCH,MK0, * ML0,MSP,MS0,MSM,MX0,MXM C PARAMETER (MXGKCU=MXGKGH) COMMON/CURPAR/WEIGHT(10),DDELTN,IFILE,IRUN,NEVT,NEVENT,SHFLAG, * ITHST,ITTOT,ITLST,IFRND,TOFCUT,CMOM(5),CENG(5), * RS,S,ENP(10),NP,NM,NN,NR,NO,NZ,IPA(MXGKCU), * ATNO2,ZNO2 C COMMON/RESULT/XEND,YEND,ZEND,RCA,RCE,AMAS,NCH,TOF,PX,PY,PZ, * USERW,INTCT,P,EN,EK,AMASQ,DELTN,ITK,NTK,IPART,IND, * LCALO,ICEL,SINL,COSL,SINP,COSP, * XOLD,YOLD,ZOLD,POLD,PXOLD,PYOLD,PZOLD, * XSCAT,YSCAT,ZSCAT,PSCAT,PXSCAT,PYSCAT,PZSCAT REAL NCH,INTCT C COMMON/PRNTFL/INBCD,NEWBCD,INBIN,NEWBIN,NPEVT,NEVTP,LPRT,NPRT(10) LOGICAL LPRT,NPRT C C --- INITIALIZATION FLAGS FOR VARIOUS GHEISHA ROUTINES --- COMMON /KGINIT/ KGINIT(50) C C --- BOUNDARY LIMITS FOR ARGUMENTS OF INTRINSIC FUNCTIONS --- C --- XL DENOTES LOWER BOUND WHEREAS XU DENOTES UPPER BOUND --- COMMON /LIMITS/ EXPXL,EXPXU C C REAL N DIMENSION PMUL(2,1200),ANORM(2,60),CECH(10),CNK0(20),PIY1(4), $ PIY2(3),IPIY1(2,4),IPIY2(2,3),IPIY3(2,3),B(2) DIMENSION RNDM(1) SAVE PMUL,ANORM SAVE DATA CECH/1.,1.,1.,0.70,0.60,0.55,0.35,0.25,0.18,0.15/ DATA CNK0/0.17,0.18,0.17,0.24,0.26,0.20,0.22,0.21,0.34,0.45 $ ,0.58,0.55,0.36,0.29,0.29,0.32,0.32,0.33,0.33,0.33/ DATA PIY1/0.67,0.78,0.89,1.00/,PIY2/0.68,0.84,1.00/ DATA IPIY1/8,18,9,20,8,21,7,22/ DATA IPIY2/9,18,9,21,8,22/,IPIY3/7,18,8,20,7,21/ DATA B/0.7,0.7/,C/1.25/ C C --- INITIALIZATION INDICATED BY KGINIT(7) --- IF (KGINIT(7) .NE. 0) GO TO 10 KGINIT(7)=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 P AS TARGET C L=0 DO 1 NP1=1,20 NP=NP1-1 NMM1=NP1-2 IF(NMM1.LE.1) NMM1=1 DO 1 NM1=NMM1,NP1 NM=NM1-1 DO 1 NZ1=1,20 NZ=NZ1-1 L=L+1 IF(L.GT.1200) GOTO 1 NT=NP+NM+NZ IF(NT.LE.0.OR.NT.GT.60) GOTO 1 PMUL(1,L)=PMLTPC(NP,NM,NZ,NT,B(1),C) ANORM(1,NT)=ANORM(1,NT)+PMUL(1,L) 1 CONTINUE C** FOR N AS TARGET L=0 DO 2 NP1=1,20 NP=NP1-1 NMM1=NP1-1 IF(NMM1.LT.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 NT=NP+NM+NZ IF(NT.LE.0.OR.NT.GT.60) GOTO 2 PMUL(2,L)=PMLTPC(NP,NM,NZ,NT,B(2),C) 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-ABS(RMASS(12)) C C** ELASTIC SCATTERING NP=0 NM=0 NZ=0 N=0. IPA(1)=12 IPA(2)=14 IF(NFL.EQ.2) IPA(2)=16 IF(INT.EQ.2) GOTO 20 GOTO 100 C** CHECK IF ENERGETICALLY POSSIBLE TO PRODUCE ONE EXTRA PION IN REACT. 20 IPLAB=IFIX(P*5.)+1 IF(IPLAB.GT.10) GOTO 22 CALL GRNDM(RNDM,1) IF(RNDM(1).LT.CECH(IPLAB)) GOTO 19 IF (EAB .LT. RMASS(7)) GOTO 55 GOTO 22 C** CHARGE EXCHANGE REACTION (IS INCLUDED IN INELASTIC CROSS SECTION) 19 IPLAB=IFIX(P*10.)+1 IF(IPLAB.GT.20) IPLAB=20 CALL GRNDM(RNDM,1) IF(RNDM(1).GT.CNK0(IPLAB)) GOTO 24 IF(NFL.EQ.2) GOTO 23 C** FOR K0B P REACTION NO K N STRANGENESS EXCHANGE POSSIBLE INT=1 IPA(1)=12 IPA(2)=14 GOTO 100 23 INT=1 IPA(1)=13 IPA(2)=14 GOTO 100 C** P L, P S REACTIONS 24 CALL GRNDM(RNDM,1) RAN=RNDM(1) IF(RAN.LT.0.25) GOTO 25 IF(RAN.LT.0.50) GOTO 26 IF(RAN.LT.0.75) GOTO 27 C** K0B P --> PI+ L OR K0B N --> PI0 L IPA(1)=7 IF(NFL.EQ.2) IPA(1)=8 IPA(2)=18 GOTO 100 C** K0B N --> PI- S+ 25 IPA(1)=9 IPA(2)=20 IF(NFL.EQ.2) GOTO 100 IPA(1)=12 IPA(2)=14 GOTO 100 C** K0B P --> PI+ S0 OR K0B N --> PI0 S0 26 IPA(1)=7 IF(NFL.EQ.2) IPA(1)=8 IPA(2)=21 GOTO 100 C** K0B N --> PI+ S- 27 IPA(1)=7 IPA(2)=22 IF(NFL.EQ.2) GOTO 100 IPA(1)=12 IPA(2)=14 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 .LT. EXPXL) TEST=EXPXL IF (TEST .GT. EXPXU) TEST=EXPXU DUM1=PI*NT/(2.0*N*N) DUM2=ABS(DUM1) DUM3=EXP(TEST) ADDNVE=0.0 IF (DUM2 .GE. 1) ADDNVE=DUM1*DUM3 IF ((DUM2 .LT. 1) .AND. (DUM3 .GE. 1.0E-10)) ADDNVE=DUM1*DUM3 ANPN=ANPN+ADDNVE 21 CONTINUE ANPN=1./ANPN C** P OR N AS TARGET CALL GRNDM(RNDM,1) RAN=RNDM(1) EXCS=0. GOTO (30,40),NFL C** FOR P AS TARGET 30 L=0 DO 31 NP1=1,20 NP=NP1-1 NMM1=NP1-2 IF(NMM1.LE.1) NMM1=1 DO 31 NM1=NMM1,NP1 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 .LT. EXPXL) TEST=EXPXL IF (TEST .GT. EXPXU) TEST=EXPXU 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) ADDNVE=DUM1*DUM3 IF ((DUM2 .LT. 1) .AND. (DUM3 .GE. 1.0E-10)) ADDNVE=DUM1*DUM3 EXCS=EXCS+ADDNVE IF(RAN.LT.EXCS) GOTO 50 31 CONTINUE GOTO 80 C** FOR N AS TARGET 40 L=0 DO 41 NP1=1,20 NP=NP1-1 NMM1=NP1-1 IF(NMM1.LT.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 .LT. EXPXL) TEST=EXPXL IF (TEST .GT. EXPXU) TEST=EXPXU 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) ADDNVE=DUM1*DUM3 IF ((DUM2 .LT. 1) .AND. (DUM3 .GE. 1.0E-10)) ADDNVE=DUM1*DUM3 EXCS=EXCS+ADDNVE IF(RAN.LT.EXCS) GOTO 50 41 CONTINUE GOTO 80 50 GOTO (65,60),NFL 60 IF(NP.EQ.NM) GOTO 61 IF(NP.EQ.1+NM) GOTO 63 IPA(1)=12 IPA(2)=14 GOTO 90 61 CALL GRNDM(RNDM,1) IF(RNDM(1).LT.0.75) GOTO 62 IPA(1)=13 IPA(2)=14 GOTO 90 62 IPA(1)=13 IPA(2)=14 GOTO 90 63 IPA(1)=13 IPA(2)=16 GOTO 90 65 IF(NP.EQ.1+NM) GOTO 66 IF(NP.EQ.NM) GOTO 68 IPA(1)=13 IPA(2)=16 GOTO 90 66 CALL GRNDM(RNDM,1) IF(RNDM(1).LT.0.50) GOTO 67 IPA(1)=12 IPA(2)=16 GOTO 90 67 IPA(1)=13 IPA(2)=14 GOTO 90 68 IPA(1)=12 IPA(2)=14 C** PI Y PRODUCTION INSTEAD OF K N 90 CALL GRNDM(RNDM,1) IF(RNDM(1).LT.0.5) GOTO 100 IF(IPA(1).EQ.13.AND.IPA(2).EQ.16) GOTO 95 IF(IPA(1).EQ.11.AND.IPA(2).EQ.14) GOTO 95 IF(IPA(1).EQ.12.AND.IPA(2).EQ.14) GOTO 95 CALL GRNDM(RNDM,1) RAN=RNDM(1) DO 91 I=1,4 IF(RAN.LT.PIY1(I)) GOTO 92 91 CONTINUE GOTO 100 92 IPA(1)=IPIY1(1,I) IPA(2)=IPIY1(2,I) GOTO 100 95 CALL GRNDM(RNDM,1) RAN=RNDM(1) DO 96 I=1,3 IF(RAN.LT.PIY2(I)) GOTO 97 96 CONTINUE GOTO 100 97 IF(IPA(2).EQ.14) GOTO 98 IPA(1)=IPIY2(1,I) IPA(2)=IPIY2(2,I) GOTO 100 98 IPA(1)=IPIY3(1,I) IPA(2)=IPIY3(2,I) GOTO 100 70 IF(NPRT(4)) *WRITE(NEWBCD,1003) EAB,N,NFL,NP,NM,NZ CALL STPAIR IF(INT.EQ.1) CALL TWOB(12,NFL,N) IF(INT.EQ.2) CALL GENXPT(12,NFL,N) GO TO 9999 C** NUCLEAR EXCITATION 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 N=0. IPA(1)=12 IPA(2)=14 IF(NFL.EQ.2) IPA(2)=16 100 DO 101 I=3,60 101 IPA(I)=0 IF(INT.LE.0) GOTO 131 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) DO 132 I=1,NT IF(IPA(I).NE.12) GOTO 132 CALL GRNDM(RNDM,1) IF(RNDM(1).LT.0.5) GOTO 132 IPA(I)=11 132 CONTINUE GOTO 70 131 IF(NPRT(4)) *WRITE(NEWBCD,2005) C 1001 FORMAT(' *CASK0B* CASCADE ENERGETICALLY NOT POSSIBLE', $ ' CONTINUE WITH QUASI-ELASTIC SCATTERING') 1003 FORMAT(' *CASK0B* K0B -INDUCED CASCADE,', $ ' AVAIL. ENERGY',2X,F8.4,/, $ 2X,' ',2X,F8.4,2X,'FROM',4(2X,I3),2X,'PARTICLES') 1004 FORMAT(' *CASK0B* K0B -INDUCED CASCADE,', $ ' EXCLUSIVE REACTION NOT FOUND', $ ' TRY ELASTIC SCATTERING AVAIL. ENERGY',2X,F8.4,/,2X, $ ' ',2X,F8.4) 2001 FORMAT(' *CASK0B* TABLES FOR MULT. DATA K0B INDUCED REACTION', $ ' FOR DEFINITION OF NUMBERS SEE FORTRAN CODING') 2002 FORMAT(' *CASK0B* TARGET PARTICLE FLAG',2X,I5) 2003 FORMAT(1H ,10E12.4) 2004 FORMAT(' *CASK0B* ',I3,2X,'PARTICLES , MASS INDEX ARRAY',2X,20I4) 2005 FORMAT(' *CASK0B* NO PARTICLES PRODUCED') C 9999 CONTINUE RETURN END *CMZ : 3.16/00 05/11/93 19.19.55 BY FEDERICO CARMINATI *-- AUTHOR : C--------------------------------------------------------------------- SUBROUTINE CASL0(K,INT,NFL) C C *** CASCADE OF LAMBDA *** C *** NVE 04-MAY-1988 CERN GENEVA *** C C ORIGIN : H.FESEFELDT (13-SEP-1987) C C L0 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 PARAMETER (MXGKGH=100) COMMON/CONSTS/ PI,TWPI,PIBTW,MP,MPI,MMU,MEL,MKCH,MK0,SMP,SMPI, $ SMU,CT,CTKCH,CTK0, $ ML0,MSP,MS0,MSM,MX0,MXM,CTL0,CTSP,CTSM,CTX0,CTXM, $ RMASS(35),RCHARG(35) C REAL MP,MPI,MMU,MEL,MKCH,MK0, * ML0,MSP,MS0,MSM,MX0,MXM C PARAMETER (MXGKCU=MXGKGH) COMMON/CURPAR/WEIGHT(10),DDELTN,IFILE,IRUN,NEVT,NEVENT,SHFLAG, * ITHST,ITTOT,ITLST,IFRND,TOFCUT,CMOM(5),CENG(5), * RS,S,ENP(10),NP,NM,NN,NR,NO,NZ,IPA(MXGKCU), * ATNO2,ZNO2 C COMMON/RESULT/XEND,YEND,ZEND,RCA,RCE,AMAS,NCH,TOF,PX,PY,PZ, * USERW,INTCT,P,EN,EK,AMASQ,DELTN,ITK,NTK,IPART,IND, * LCALO,ICEL,SINL,COSL,SINP,COSP, * XOLD,YOLD,ZOLD,POLD,PXOLD,PYOLD,PZOLD, * XSCAT,YSCAT,ZSCAT,PSCAT,PXSCAT,PYSCAT,PZSCAT REAL NCH,INTCT C COMMON/PRNTFL/INBCD,NEWBCD,INBIN,NEWBIN,NPEVT,NEVTP,LPRT,NPRT(10) LOGICAL LPRT,NPRT C C --- INITIALIZATION FLAGS FOR VARIOUS GHEISHA ROUTINES --- COMMON /KGINIT/ KGINIT(50) C C --- BOUNDARY LIMITS FOR ARGUMENTS OF INTRINSIC FUNCTIONS --- C --- XL DENOTES LOWER BOUND WHEREAS XU DENOTES UPPER BOUND --- COMMON /LIMITS/ EXPXL,EXPXU C C REAL N DIMENSION PMUL(2,1200),ANORM(2,60),CECH(10),IIPA(10,2),B(2) DIMENSION RNDM(2) SAVE PMUL,ANORM SAVE DATA CECH/0.50,0.45,0.40,0.35,0.30,0.25,0.06,0.04,0.005,0./ DATA IIPA/20,21,14,14,16,21,22,16,16,14, * 16,14,18,21,20,16,14,18,21,22/ DATA B/0.7,0.7/,C/1.25/ C C --- INITIALIZATION INDICATED BY KGINIT(8) --- IF (KGINIT(8) .NE. 0) GO TO 10 KGINIT(8)=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 NMM1=NP1-1 IF(NMM1.LE.0) NMM1=1 NPP1=NP1+2 DO 1 NM1=NMM1,NPP1 NM=NM1-1 DO 1 NZ1=1,20 NZ=NZ1-1 L=L+1 IF(L.GT.1200) GOTO 1 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) 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-2 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 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) 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(18) C** ELASTIC SCATTERING NP=0 NM=0 NZ=0 N=0. IPA(1)=18 IPA(2)=14 IF(NFL.EQ.2) IPA(2)=16 IF(INT.EQ.2) GOTO 20 C** INTRODUCE CHARGE AND STRANGENESS EXCHANGE REACTIONS C** LP --> S+N, LP --> S0 P , LN --> S0 N , LN --> S- P C** LP --> P L, LP --> P S0 , LP --> N S+ C** LN --> N L, LN --> N S0 , LN --> P S- 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 120 CALL GRNDM(RNDM,1) RAN=RNDM(1) IRN=IFIX(RAN/0.2)+1 IF(IRN.GT.5) IRN=5 IRN=IRN+(NFL-1)*5 IPA(1)=IIPA(IRN,1) IPA(2)=IIPA(IRN,2) GOTO 120 C** CHECK IF ENERGETICALLY POSSIBLE TO PRODUCE ONE EXTRA PION IN REACT. 20 IF (EAB .LE. RMASS(7)) GOTO 55 ALEAB=LOG(EAB) C** NO. OF TOTAL PARTICLES VS SQRT(S)-MP-MSM 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 .LT. EXPXL) TEST=EXPXL IF (TEST .GT. EXPXU) TEST=EXPXU DUM1=PI*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 ANPN=ANPN+ADDNVE 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 NMM1=NP1-1 IF(NMM1.LE.0) NMM1=1 NPP1=NP1+2 DO 31 NM1=NMM1,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 .LT. EXPXL) TEST=EXPXL IF (TEST .GT. EXPXU) TEST=EXPXU 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-2 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 .LT. EXPXL) TEST=EXPXL IF (TEST .GT. EXPXU) TEST=EXPXU 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 IF(INT.EQ.1) CALL TWOB(18,NFL,N) IF(INT.EQ.2) CALL GENXPT(18,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 IPA(1)=18 IPA(2)=14 IF(NFL.EQ.2) IPA(2)=16 GOTO 120 100 DO 101 I=1,60 101 IPA(I)=0 IF(INT.LE.0) GOTO 131 GOTO (112,102),NFL 102 NCHT=NP-NM NCHT=NCHT+3 IF(NCHT.LE.0) NCHT=1 IF(NCHT.GT.4) NCHT=4 GOTO (103,104,105,106),NCHT 103 IPA(1)=20 IPA(2)=14 GOTO 120 104 IPA(1)=18 CALL GRNDM(RNDM,2) IF(RNDM(1).LT.0.5) IPA(1)=21 IPA(2)=14 IF(RNDM(2).LT.0.5) GOTO 120 IPA(1)=20 IPA(2)=16 GOTO 120 105 IPA(1)=18 CALL GRNDM(RNDM,2) IF(RNDM(1).LT.0.5) IPA(1)=21 IPA(2)=16 IF(RNDM(2).LT.0.5) GOTO 120 IPA(1)=22 IPA(2)=14 GOTO 120 106 IPA(1)=22 IPA(2)=16 GOTO 120 112 NCHT=NP-NM NCHT=NCHT+2 IF(NCHT.LE.0) NCHT=1 IF(NCHT.GT.4) NCHT=4 GOTO (113,114,115,116),NCHT 113 IPA(1)=20 IPA(2)=14 GOTO 120 114 IPA(1)=18 CALL GRNDM(RNDM,2) IF(RNDM(1).LT.0.5) IPA(1)=21 IPA(2)=14 IF(RNDM(2).LT.0.5) GOTO 120 IPA(1)=20 IPA(2)=16 GOTO 120 115 IPA(1)=18 CALL GRNDM(RNDM,2) IF(RNDM(1).LT.0.5) IPA(1)=21 IPA(2)=16 IF(RNDM(2).LT.0.5) GOTO 120 IPA(1)=22 IPA(2)=14 GOTO 120 116 IPA(1)=22 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(' *CASL0* CASCADE ENERGETICALLY NOT POSSIBLE', $ ' CONTINUE WITH QUASI-ELASTIC SCATTERING') 1003 FORMAT(' *CASL0* LAMBDA-INDUCED CASCADE,', $ ' AVAIL. ENERGY',2X,F8.4,/, $ 2X,' ',2X,F8.4,2X,'FROM',4(2X,I3),2X,'PARTICLES') 1004 FORMAT(' *CASL0* LAMBDA-INDUCED CASCADE,', $ ' EXCLUSIVE REACTION NOT FOUND', $ ' TRY ELASTIC SCATTERING AVAIL. ENERGY',2X,F8.4,/,2X, $ ' ',2X,F8.4) 2001 FORMAT(' *CASL0* TABLES FOR MULT. DATA LAMBDA INDUCED REACTION', $ ' FOR DEFINITION OF NUMBERS SEE FORTRAN CODING') 2002 FORMAT(' *CASL0* TARGET PARTICLE FLAG',2X,I5) 2003 FORMAT(1H ,10E12.4) 2004 FORMAT(' *CASL0* ',I3,2X,'PARTICLES , MASS INDEX ARRAY',2X,20I4) 2005 FORMAT(' *CASL0* NO PARTICLES PRODUCED') C 9999 CONTINUE RETURN END *CMZU: 3.16/00 05/11/93 17.20.00 BY FEDERICO CARMINATI *-- AUTHOR : C--------------------------------------------------------------------- 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 PARAMETER (MXGKGH=100) COMMON/CONSTS/ PI,TWPI,PIBTW,MP,MPI,MMU,MEL,MKCH,MK0,SMP,SMPI, $ SMU,CT,CTKCH,CTK0, $ ML0,MSP,MS0,MSM,MX0,MXM,CTL0,CTSP,CTSM,CTX0,CTXM, $ RMASS(35),RCHARG(35) C REAL MP,MPI,MMU,MEL,MKCH,MK0, * ML0,MSP,MS0,MSM,MX0,MXM C PARAMETER (MXGKCU=MXGKGH) COMMON/CURPAR/WEIGHT(10),DDELTN,IFILE,IRUN,NEVT,NEVENT,SHFLAG, * ITHST,ITTOT,ITLST,IFRND,TOFCUT,CMOM(5),CENG(5), * RS,S,ENP(10),NP,NM,NN,NR,NO,NZ,IPA(MXGKCU), * ATNO2,ZNO2 C COMMON/RESULT/XEND,YEND,ZEND,RCA,RCE,AMAS,NCH,TOF,PX,PY,PZ, * USERW,INTCT,P,EN,EK,AMASQ,DELTN,ITK,NTK,IPART,IND, * LCALO,ICEL,SINL,COSL,SINP,COSP, * XOLD,YOLD,ZOLD,POLD,PXOLD,PYOLD,PZOLD, * XSCAT,YSCAT,ZSCAT,PSCAT,PXSCAT,PYSCAT,PZSCAT REAL NCH,INTCT C COMMON/PRNTFL/INBCD,NEWBCD,INBIN,NEWBIN,NPEVT,NEVTP,LPRT,NPRT(10) LOGICAL LPRT,NPRT C C --- BOUNDARY LIMITS FOR ARGUMENTS OF INTRINSIC FUNCTIONS --- C --- XL DENOTES LOWER BOUND WHEREAS XU DENOTES UPPER BOUND --- COMMON /LIMITS/ EXPXL,EXPXU C C --- INITIALIZATION FLAGS FOR VARIOUS GHEISHA ROUTINES --- COMMON /KGINIT/ KGINIT(50) C C REAL N DIMENSION PMUL(2,1200),ANORM(2,60),SUPP(10),CECH(10),B(2) DIMENSION RNDM(1) SAVE PMUL,ANORM SAVE 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(' *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,' ',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, $ ' ',2X,F8.4) 2001 FORMAT(' *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 RETURN END *CMZU: 3.16/00 05/11/93 17.20.00 BY FEDERICO CARMINATI *-- AUTHOR : C--------------------------------------------------------------------- SUBROUTINE CASNB(K,INT,NFL) C C *** CASCADE OF ANTI NEUTRON *** C *** NVE 04-MAY-1988 CERN GENEVA *** C C ORIGIN : H.FESEFELDT (13-SEP-1987) C C NB 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 PARAMETER (MXGKGH=100) COMMON/CONSTS/ PI,TWPI,PIBTW,MP,MPI,MMU,MEL,MKCH,MK0,SMP,SMPI, $ SMU,CT,CTKCH,CTK0, $ ML0,MSP,MS0,MSM,MX0,MXM,CTL0,CTSP,CTSM,CTX0,CTXM, $ RMASS(35),RCHARG(35) C REAL MP,MPI,MMU,MEL,MKCH,MK0, * ML0,MSP,MS0,MSM,MX0,MXM C PARAMETER (MXGKCU=MXGKGH) COMMON/CURPAR/WEIGHT(10),DDELTN,IFILE,IRUN,NEVT,NEVENT,SHFLAG, * ITHST,ITTOT,ITLST,IFRND,TOFCUT,CMOM(5),CENG(5), * RS,S,ENP(10),NP,NM,NN,NR,NO,NZ,IPA(MXGKCU), * ATNO2,ZNO2 C COMMON/RESULT/XEND,YEND,ZEND,RCA,RCE,AMAS,NCH,TOF,PX,PY,PZ, * USERW,INTCT,P,EN,EK,AMASQ,DELTN,ITK,NTK,IPART,IND, * LCALO,ICEL,SINL,COSL,SINP,COSP, * XOLD,YOLD,ZOLD,POLD,PXOLD,PYOLD,PZOLD, * XSCAT,YSCAT,ZSCAT,PSCAT,PXSCAT,PYSCAT,PZSCAT REAL NCH,INTCT C COMMON/PRNTFL/INBCD,NEWBCD,INBIN,NEWBIN,NPEVT,NEVTP,LPRT,NPRT(10) LOGICAL LPRT,NPRT C C --- INITIALIZATION FLAGS FOR VARIOUS GHEISHA ROUTINES --- COMMON /KGINIT/ KGINIT(50) C C --- BOUNDARY LIMITS FOR ARGUMENTS OF INTRINSIC FUNCTIONS --- C --- XL DENOTES LOWER BOUND WHEREAS XU DENOTES UPPER BOUND --- COMMON /LIMITS/ EXPXL,EXPXU C C REAL N DIMENSION PMUL1(2,1200),PMUL2(2,400),ANORM1(2,60),ANORM2(2,60), * SUPP(10),CECH(10),ANHL(25),B(2) DIMENSION RNDM(1) SAVE PMUL1,ANORM1,PMUL2,ANORM2 SAVE 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 ANHL/1.00,1.00,1.00,1.00,1.00,1.00,1.00,1.00,0.97,0.88 * ,0.85,0.81,0.75,0.64,0.64,0.55,0.55,0.45,0.47,0.40 * ,0.39,0.36,0.33,0.10,0.01/ DATA B/0.7,0.7/,C/1.25/ C C --- INITIALIZATION INDICATED BY KGINIT(9) --- IF (KGINIT(9) .NE. 0) GO TO 10 KGINIT(9)=1 C C --- INITIALIZE PMUL AND ANORM ARRAYS --- DO 9000 J=1,1200 DO 9001 I=1,2 PMUL1(I,J)=0.0 IF (J .LE. 400) PMUL2(I,J)=0.0 IF (J .LE. 60) ANORM1(I,J)=0.0 IF (J .LE. 60) ANORM2(I,J)=0.0 9001 CONTINUE 9000 CONTINUE C C** COMPUTE NORMALIZATION CONSTANTS C** FOR P AS TARGET C L=0 DO 1 NP1=1,20 NP=NP1-1 NMM1=NP1-2 IF(NMM1.LE.1) NMM1=1 DO 1 NM1=NMM1,NP1 NM=NM1-1 DO 1 NZ1=1,20 NZ=NZ1-1 L=L+1 IF(L.GT.1200) GOTO 1 NT=NP+NM+NZ IF(NT.LE.0.OR.NT.GT.60) GOTO 1 PMUL1(1,L)=PMLTPC(NP,NM,NZ,NT,B(1),C) ANORM1(1,NT)=ANORM1(1,NT)+PMUL1(1,L) 1 CONTINUE C** FOR N AS TARGET L=0 DO 2 NP1=1,20 NP=NP1-1 NMM1=NP1-1 IF(NMM1.LT.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 NT=NP+NM+NZ IF(NT.LE.0.OR.NT.GT.60) GOTO 2 PMUL1(2,L)=PMLTPC(NP,NM,NZ,NT,B(2),C) ANORM1(2,NT)=ANORM1(2,NT)+PMUL1(2,L) 2 CONTINUE DO 3 I=1,60 IF(ANORM1(1,I).GT.0.) ANORM1(1,I)=1./ANORM1(1,I) IF(ANORM1(2,I).GT.0.) ANORM1(2,I)=1./ANORM1(2,I) 3 CONTINUE IF(.NOT.NPRT(10)) GOTO 9 WRITE(NEWBCD,2001) DO 4 NFL=1,2 WRITE(NEWBCD,2002) NFL WRITE(NEWBCD,2003) (ANORM1(NFL,I),I=1,60) WRITE(NEWBCD,2003) (PMUL1(NFL,I),I=1,1200) 4 CONTINUE C** DO THE SAME FOR ANNIHILATION CHANNELS C** FOR P AS TARGET C 9 L=0 DO 5 NP1=2,20 NP=NP1-1 NM=NP-1 DO 5 NZ1=1,20 NZ=NZ1-1 L=L+1 IF(L.GT.400) GOTO 5 NT=NP+NM+NZ IF(NT.LE.1.OR.NT.GT.60) GOTO 5 PMUL2(1,L)=PMLTPC(NP,NM,NZ,NT,B(1),C) ANORM2(1,NT)=ANORM2(1,NT)+PMUL2(1,L) 5 CONTINUE C** FOR N AS TARGET L=0 DO 6 NP1=1,20 NP=NP1-1 NM=NP DO 6 NZ1=1,20 NZ=NZ1-1 L=L+1 IF(L.GT.400) GOTO 6 NT=NP+NM+NZ IF(NT.LE.1.OR.NT.GT.60) GOTO 6 PMUL2(2,L)=PMLTPC(NP,NM,NZ,NT,B(2),C) ANORM2(2,NT)=ANORM2(2,NT)+PMUL2(2,L) 6 CONTINUE DO 7 I=1,60 IF(ANORM2(1,I).GT.0.) ANORM2(1,I)=1./ANORM2(1,I) IF(ANORM2(2,I).GT.0.) ANORM2(2,I)=1./ANORM2(2,I) 7 CONTINUE IF(.NOT.NPRT(10)) GOTO 10 WRITE(NEWBCD,3001) DO 8 NFL=1,2 WRITE(NEWBCD,3002) NFL WRITE(NEWBCD,3003) (ANORM2(NFL,I),I=1,60) WRITE(NEWBCD,3003) (PMUL2(NFL,I),I=1,400) 8 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-ABS(RMASS(17)) C** ELASTIC SCATTERING NCECH=0 NP=0 NM=0 NZ=0 N=0. IF(INT.EQ.2) GOTO 20 C** INTRODUCE CHARGE EXCHANGE REACTION NB N --> PB P IF(NFL.EQ.1) 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.75) GOTO 100 NCECH=1 GOTO 100 C** ANNIHILATION CHANNELS 20 IPLAB=IFIX(P*10.)+1 IF(IPLAB.GT.10) IPLAB=IFIX((P-1.)*5.)+11 IF(IPLAB.GT.15) IPLAB=IFIX( P-2. )+16 IF(IPLAB.GT.23) IPLAB=IFIX((P-10.)/10.)+24 IF(IPLAB.GT.25) IPLAB=25 CALL GRNDM(RNDM,1) IF(RNDM(1).GT.ANHL(IPLAB)) GOTO 19 EAB=RS IF (EAB .LE. 2.0*RMASS(7)) GOTO 55 GOTO 222 C** CHECK IF ENERGETICALLY POSSIBLE TO PRODUCE ONE EXTRA PION IN REACT. 19 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 (23,24),NFL 23 CONTINUE TEST=-(1+B(1))**2/(2.0*C**2) IF (TEST .LT. EXPXL) TEST=EXPXL IF (TEST .GT. EXPXU) TEST=EXPXU W0=EXP(TEST) WP=EXP(TEST) CALL GRNDM(RNDM,1) RAN=RNDM(1) NP=0 NM=0 NZ=1 IF(RAN.LT.W0/(W0+WP)) GOTO 100 NP=1 NM=0 NZ=0 GOTO 100 24 CONTINUE TEST=-(1+B(2))**2/(2.0*C**2) IF (TEST .LT. EXPXL) TEST=EXPXL IF (TEST .GT. EXPXU) TEST=EXPXU W0=EXP(TEST) WP=EXP(TEST) TEST=-(-1+B(2))**2/(2.0*C**2) IF (TEST .LT. EXPXL) TEST=EXPXL IF (TEST .GT. EXPXU) TEST=EXPXU WM=EXP(TEST) 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 .LT. EXPXL) TEST=EXPXL IF (TEST .GT. EXPXU) TEST=EXPXU DUM1=PI*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 .GT. 1.0E-10)) ADDNVE=DUM1*DUM3 ANPN=ANPN+ADDNVE 21 CONTINUE ANPN=1./ANPN C** P OR N AS TARGET CALL GRNDM(RNDM,1) RAN=RNDM(1) EXCS=0. GOTO (30,40),NFL C** FOR P AS TARGET 30 L=0 DO 31 NP1=1,20 NP=NP1-1 NMM1=NP1-2 IF(NMM1.LE.1) NMM1=1 DO 31 NM1=NMM1,NP1 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 .LT. EXPXL) TEST=EXPXL IF (TEST .GT. EXPXU) TEST=EXPXU DUM1=ANPN*PI*NT*PMUL1(1,L)*ANORM1(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 .GT. 1.0E-10)) ADDNVE=DUM1*DUM3 EXCS=EXCS+ADDNVE IF(RAN.LT.EXCS) GOTO 100 31 CONTINUE GOTO 80 C** FOR N AS TARGET 40 L=0 DO 41 NP1=1,20 NP=NP1-1 NMM1=NP1-1 IF(NMM1.LT.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 .LT. EXPXL) TEST=EXPXL IF (TEST .GT. EXPXU) TEST=EXPXU DUM1=ANPN*PI*NT*PMUL1(2,L)*ANORM1(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 .GT. 1.0E-10)) ADDNVE=DUM1*DUM3 EXCS=EXCS+ADDNVE IF(RAN.LT.EXCS) GOTO 100 41 CONTINUE GOTO 80 C** ANNIHILATION CHANNELS 222 IPA(1)=0 IPA(2)=0 ALEAB=LOG(EAB) C** NO. OF TOTAL PARTICLES VS SQRT(S) 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 221 NT=2,60 TEST=-(PI/4.0)*(NT/N)**2 IF (TEST .LT. EXPXL) TEST=EXPXL IF (TEST .GT. EXPXU) TEST=EXPXU DUM1=PI*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 .GT. 1.0E-10)) ADDNVE=DUM1*DUM3 ANPN=ANPN+ADDNVE 221 CONTINUE ANPN=1./ANPN C** P OR N AS TARGET CALL GRNDM(RNDM,1) RAN=RNDM(1) EXCS=0. GOTO (230,240),NFL C** FOR P AS TARGET 230 L=0 DO 231 NP1=2,20 NP=NP1-1 NM=NP-1 DO 231 NZ1=1,20 NZ=NZ1-1 L=L+1 IF(L.GT.400) GOTO 231 NT=NP+NM+NZ IF(NT.LE.1.OR.NT.GT.60) GOTO 231 TEST=-(PI/4.0)*(NT/N)**2 IF (TEST .LT. EXPXL) TEST=EXPXL IF (TEST .GT. EXPXU) TEST=EXPXU DUM1=ANPN*PI*NT*PMUL2(1,L)*ANORM2(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 .GT. 1.0E-10)) ADDNVE=DUM1*DUM3 EXCS=EXCS+ADDNVE IF(RAN.LT.EXCS) GOTO 120 231 CONTINUE GOTO 80 C** FOR N AS TARGET 240 L=0 DO 241 NP1=1,20 NP=NP1-1 NM=NP DO 241 NZ1=1,20 NZ=NZ1-1 L=L+1 IF(L.GT.400) GOTO 241 NT=NP+NM+NZ IF(NT.LE.1.OR.NT.GT.60) GOTO 241 TEST=-(PI/4.0)*(NT/N)**2 IF (TEST .LT. EXPXL) TEST=EXPXL IF (TEST .GT. EXPXU) TEST=EXPXU DUM1=ANPN*PI*NT*PMUL2(2,L)*ANORM2(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 .GT. 1.0E-10)) ADDNVE=DUM1*DUM3 EXCS=EXCS+ADDNVE IF(RAN.LT.EXCS) GOTO 120 241 CONTINUE GOTO 80 50 IF(NPRT(4)) *WRITE(NEWBCD,1003) EAB,N,NFL,NP,NM,NZ CALL STPAIR IF(INT.EQ.1) CALL TWOB(17,NFL,N) IF(INT.EQ.2) CALL GENXPT(17,NFL,N) GO TO 9999 55 IF(NPRT(4)) *WRITE(NEWBCD,1001) GOTO 53 C** EXCLUSIVE REACTION NOT FOUND,ASSUME ELASTIC SCATTERING 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 GOTO (102,112),NFL 102 GOTO (103,104),INT 103 IPA(1)=17 IPA(2)=14 NT=2 GOTO 130 104 IF(NP.EQ.1+NM) GOTO 105 IF(NP.EQ.2+NM) GOTO 106 IPA(1)=17 IPA(2)=14 GOTO 120 105 IPA(1)=15 IPA(2)=14 CALL GRNDM(RNDM,1) IF(RNDM(1).LT.0.5) GOTO 120 IPA(1)=17 IPA(2)=16 GOTO 120 106 IPA(1)=15 IPA(2)=16 GOTO 120 112 GOTO (113,114),INT 113 IPA(1)=17 IPA(2)=16 NT=2 IF(NCECH.EQ.0) GOTO 130 IPA(1)=15 IPA(2)=14 GOTO 130 114 IF(NP.EQ. NM) GOTO 115 IF(NP.EQ.1+NM) GOTO 116 IPA(1)=17 IPA(2)=14 GOTO 120 115 IPA(1)=15 IPA(2)=14 CALL GRNDM(RNDM,1) IF(RNDM(1).LT.0.33) GOTO 120 IPA(1)=17 IPA(2)=16 GOTO 120 116 IPA(1)=15 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(' *CASNB* CASCADE ENERGETICALLY NOT POSSIBLE', $ ' CONTINUE WITH QUASI- ELASTIC SCATTERING') 1003 FORMAT(' *CASNB* ANTINEUTRON-INDUCED CASCADE,', $ ' AVAIL. ENERGY',2X,F8.4,/, $ 2X,' ',2X,F8.4,2X,'FROM',4(2X,I3),2X,'PARTICLES') 1004 FORMAT(' *CASNB* ANTINEUTRON-INDUCED CASCADE,', $ ' EXCLUSIVE REACTION', $ ' NOT FOUND TRY ELASTIC SCATTERING AVAIL. ENERGY',2X,F8.4,/,2X, $ ' ',2X,F8.4) 2001 FORMAT(' *CASNB* TABLES FOR MULT. DATA ANTINEUTRON INDUCED ', * 'REACTION FOR DEFINITION OF NUMBERS SEE FORTRAN CODING') 2002 FORMAT(' *CASNB* TARGET PARTICLE FLAG',2X,I5) 2003 FORMAT(1H ,10E12.4) 2004 FORMAT(' *CASNB* ',I3,2X,'PARTICLES , MASS INDEX ARRAY',2X,20I4) 2005 FORMAT(' *CASNB* NO PARTICLES PRODUCED') 3001 FORMAT(' *CASNB* TABLES FOR MULT. DATA ANTIPROTON INDUCED ', $ 'ANNIHILATION REACTION FOR DEFINITION OF NUMBERS SEE FORTRAN', $ ' CODING') 3002 FORMAT(' *CASNB* TARGET PARTICLE FLAG',2X,I5) 3003 FORMAT(1H ,10E12.4) C 9999 CONTINUE RETURN END *CMZ : 19/07/94 16.36.34 by D. HECK IK3 KFK KARLSRUHE *-- Author : Nick van Eijndhoven (CERN) 02/02/89 C--------------------------------------------------------------------- SUBROUTINE CASOM(K,INT,NFL) C C *** CASCADE OF OMEGA- *** C *** NVE 31-JAN-1989 CERN GENEVA *** C C OMEGA- UNDERGOES INTERACTION WITH NUCLEON WITHIN NUCLEUS. C CHECK IF ENERGETICALLY POSSIBLE TO PRODUCE PIONS/KAONS. C IF NOT, ASSUME NUCLEAR EXCITATION OCCURS, DEGRADE INPUT PARTICLE C IN ENERGY AND NO OTHER PARTICLES ARE 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 PARAMETER (MXGKGH=100) COMMON/CONSTS/ PI,TWPI,PIBTW,MP,MPI,MMU,MEL,MKCH,MK0,SMP,SMPI, $ SMU,CT,CTKCH,CTK0, $ ML0,MSP,MS0,MSM,MX0,MXM,CTL0,CTSP,CTSM,CTX0,CTXM, $ RMASS(35),RCHARG(35) C REAL MP,MPI,MMU,MEL,MKCH,MK0, * ML0,MSP,MS0,MSM,MX0,MXM C PARAMETER (MXGKCU=MXGKGH) COMMON/CURPAR/WEIGHT(10),DDELTN,IFILE,IRUN,NEVT,NEVENT,SHFLAG, * ITHST,ITTOT,ITLST,IFRND,TOFCUT,CMOM(5),CENG(5), * RS,S,ENP(10),NP,NM,NN,NR,NO,NZ,IPA(MXGKCU), * ATNO2,ZNO2 C COMMON/RESULT/XEND,YEND,ZEND,RCA,RCE,AMAS,NCH,TOF,PX,PY,PZ, * USERW,INTCT,P,EN,EK,AMASQ,DELTN,ITK,NTK,IPART,IND, * LCALO,ICEL,SINL,COSL,SINP,COSP, * XOLD,YOLD,ZOLD,POLD,PXOLD,PYOLD,PZOLD, * XSCAT,YSCAT,ZSCAT,PSCAT,PXSCAT,PYSCAT,PZSCAT REAL NCH,INTCT C COMMON/PRNTFL/INBCD,NEWBCD,INBIN,NEWBIN,NPEVT,NEVTP,LPRT,NPRT(10) LOGICAL LPRT,NPRT C C --- INITIALIZATION FLAGS FOR VARIOUS GHEISHA ROUTINES --- COMMON /KGINIT/ KGINIT(50) C C --- BOUNDARY LIMITS FOR ARGUMENTS OF INTRINSIC FUNCTIONS --- C --- XL DENOTES LOWER BOUND WHEREAS XU DENOTES UPPER BOUND --- COMMON /LIMITS/ EXPXL,EXPXU C C REAL N DIMENSION PMUL(2,1200),ANORM(2,60),CECH(10),IIPA(14,2),B(2) DIMENSION RNDM(1) SAVE PMUL,ANORM SAVE DATA CECH/0.50,0.45,0.40,0.35,0.30,0.25,0.06,0.04,0.005,0./ C --- ARRAY IIPA DENOTES THE STRANGENESS AND CHARGE EXCHAGE REACTIONS --- C OM- P --> XI0 S0, OM- P --> S0 XI0 C OM- P --> XI0 L0, OM- P --> L0 XI0 C OM- P --> XI- S+, OM- P --> S+ XI- C XI- P --> P OM- C OM- N --> XI0 S-, OM- N --> S- XI0 C OM- N --> XI- L0, OM- N --> L0 XI- C OM- N --> XI- S0, OM- N --> S0 XI- C OM- N --> N OM- DATA IIPA/26,21,26,18,27,20,14, 26,22,27,18,27,21,16, $ 21,26,18,26,20,27,33, 22,26,18,27,21,27,33/ DATA B/0.7,0.7/,C/1.25/ C C --- INITIALIZATION INDICATED BY KGINIT(21) --- IF (KGINIT(21) .NE. 0) GO TO 10 KGINIT(21)=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 C --- FOR P TARGET --- L=0 DO 1 NP1=1,20 NP=NP1-1 NMM1=NP1-1 IF (NMM1 .LE. 0) NMM1=1 NPP1=NP1+1 DO 1 NM1=NMM1,NPP1 NM=NM1-1 DO 1 NZ1=1,20 NZ=NZ1-1 L=L+1 IF (L .GT. 1200) GO TO 1 NT=NP+NM+NZ IF ((NT .LE. 0) .OR. (NT .GT. 60)) GO TO 1 PMUL(1,L)=PMLTPC(NP,NM,NZ,NT,B(2),C) ANORM(1,NT)=ANORM(1,NT)+PMUL(1,L) 1 CONTINUE C --- FOR N TARGET --- L=0 DO 2 NP1=1,20 NP=NP1-1 NMM1=NP1 NPP1=NP1+2 DO 2 NM1=NMM1,NPP1 NM=NM1-1 DO 2 NZ1=1,20 NZ=NZ1-1 L=L+1 IF (L .GT. 1200) GO TO 2 NT=NP+NM+NZ IF ((NT .LE. 0) .OR. (NT .GT. 60)) GO TO 2 PMUL(2,L)=PMLTPC(NP,NM,NZ,NT,B(1),C) ANORM(2,NT)=ANORM(2,NT)+PMUL(2,L) 2 CONTINUE C 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 C IF (.NOT. NPRT(10)) GO TO 10 C WRITE(NEWBCD,2001) 2001 FORMAT(' *CASOM* TABLES FOR MULT. DATA OM- INDUCED REACTION', $ ' FOR DEFINITION OF NUMBERS SEE FORTRAN CODING') DO 4 NFL=1,2 WRITE(NEWBCD,2002) NFL 2002 FORMAT(' *CASOM* TARGET PARTICLE FLAG',2X,I5) WRITE(NEWBCD,2003) (ANORM(NFL,I),I=1,60) WRITE(NEWBCD,2003) (PMUL(NFL,I),I=1,1200) 2003 FORMAT(1H ,10E12.4) 4 CONTINUE C C --- SELECT TARGET NUCLEON --- 10 CONTINUE 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(33) C C --- RESET STRANGENESS FIXING FLAG --- NVEFIX=0 C C *** ELASTIC SCATTERING *** NP=0 NM=0 NZ=0 N=0. IPA(1)=33 IPA(2)=14 IF (NFL .EQ. 2) IPA(2)=16 C IF (INT .EQ. 2) GO TO 20 C C *** INTRODUCE CHARGE AND STRANGENESS EXCHANGE REACTIONS *** 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)) GO TO 120 CALL GRNDM(RNDM,1) RAN=RNDM(1) IRN=IFIX(RAN*7.)+1 IF (NFL .EQ. 2) IRN=7+IFIX(RAN*7.)+1 IF (NFL .EQ. 1) IRN=MAX(IRN,7) IF (NFL .EQ. 2) IRN=MAX(IRN,14) IPA(1)=IIPA(IRN,1) IPA(2)=IIPA(IRN,2) GO TO 120 C C --- CHECK IF ENERGETICALLY POSSIBLE TO PRODUCE ONE EXTRA PION --- 20 CONTINUE IF (EAB .LE. RMASS(7)) GO TO 55 C C --- NO. OF TOTAL PARTICLES VS SQRT(S)-MP-MSM --- ALEAB=LOG(EAB) 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 C --- NORMALIZATION CONSTANT FOR KNO-DISTRIBUTION --- ANPN=0. DO 21 NT=1,60 TEST=-(PI/4.0)*(NT/N)**2 IF (TEST .LT. EXPXL) TEST=EXPXL IF (TEST .GT. EXPXU) TEST=EXPXU DUM1=PI*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 ANPN=ANPN+ADDNVE 21 CONTINUE ANPN=1./ANPN C C --- CHECK FOR TARGET NUCLEON TYPE --- CALL GRNDM(RNDM,1) RAN=RNDM(1) EXCS=0. GO TO (30,40),NFL C C --- PROTON TARGET --- 30 CONTINUE L=0 DO 31 NP1=1,20 NP=NP1-1 NMM1=NP1-1 IF (NMM1 .LE. 0) NMM1=1 NPP1=NP1+1 DO 31 NM1=NMM1,NPP1 NM=NM1-1 DO 31 NZ1=1,20 NZ=NZ1-1 L=L+1 IF (L .GT. 1200) GO TO 31 NT=NP+NM+NZ IF ((NT .LE. 0) .OR. (NT .GT. 60)) GO TO 31 TEST=-(PI/4.0)*(NT/N)**2 IF (TEST .LT. EXPXL) TEST=EXPXL IF (TEST .GT. EXPXU) TEST=EXPXU 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) GO TO 100 31 CONTINUE GO TO 80 C C --- NEUTRON TARGET --- 40 CONTINUE L=0 DO 41 NP1=1,20 NP=NP1-1 NMM1=NP1 NPP1=NP1+2 DO 41 NM1=NMM1,NPP1 NM=NM1-1 DO 41 NZ1=1,20 NZ=NZ1-1 L=L+1 IF (L .GT. 1200) GO TO 41 NT=NP+NM+NZ IF ((NT .LE. 0) .OR. (NT .GT. 60)) GO TO 41 TEST=-(PI/4.0)*(NT/N)**2 IF (TEST .LT. EXPXL) TEST=EXPXL IF (TEST .GT. EXPXU) TEST=EXPXU 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) GO TO 100 41 CONTINUE GO TO 80 C 50 CONTINUE IF (NPRT(4)) WRITE(NEWBCD,1003) EAB,N,NFL,NP,NM,NZ 1003 FORMAT(' *CASOM* OM- -INDUCED CASCADE,', $ ' AVAIL. ENERGY',2X,F8.4, $ 2X,'',2X,F8.4,2X,'FROM',4(2X,I3),2X,'PARTICLES') IF (INT .EQ. 1) CALL TWOB(33,NFL,N) IF (INT .EQ. 2) CALL GENXPT(33,NFL,N) GO TO 9999 C C *** ENERGETICALLY NOT POSSIBLE TO PRODUCE ONE EXTRA PION *** 55 CONTINUE IF (NPRT(4)) WRITE(NEWBCD,1001) 1001 FORMAT(' *CASOM* CASCADE ENERGETICALLY NOT POSSIBLE', $ ' CONTINUE WITH QUASI-ELASTIC SCATTERING') GO TO 53 C C *** EXCLUSIVE REACTION NOT FOUND *** 80 CONTINUE IF (NPRT(4)) WRITE(NEWBCD,1004) RS,N 1004 FORMAT(' *CASOM* OM- -INDUCED CASCADE,', $ ' EXCLUSIVE REACTION NOT FOUND', $ ' TRY ELASTIC SCATTERING AVAIL. ENERGY',2X,F8.4,2X, $ '',2X,F8.4) C 53 CONTINUE INT=1 NP=0 NM=0 NZ=0 IPA(1)=33 IPA(2)=14 IF (NFL .EQ. 2) IPA(2)=16 GO TO 120 C C *** INELASTIC INTERACTION HAS OCCURRED *** C *** NUMBER OF SECONDARY MESONS DETERMINED BY KNO DISTRIBUTION *** 100 CONTINUE DO 101 I=1,60 IPA(I)=0 101 CONTINUE C IF (INT .LE. 0) GO TO 131 C C --- TAKE TARGET NUCLEON TYPE INTO ACCOUNT --- GO TO (102,112),NFL C C --- PROTON TARGET --- 102 CONTINUE C --- CHECK FOR TOTAL CHARGE OF FINAL STATE MESONS TO DETERMINE --- C --- THE KIND OF BARYONS TO BE PRODUCED TAKING INTO ACCOUNT --- C --- CHARGE AND STRANGENESS CONSERVATION --- NCHT=NP-NM IF (NCHT .LT. 0) GO TO 103 IF (NCHT .EQ. 0) GO TO 104 IF (NCHT .GT. 0) GO TO 105 C 103 CONTINUE C --- STRANGENESS MISMATCH ==> TAKE A XI0 AND CORRECT THE STRANGENESS --- C --- BY REPLACING A PI- BY K- --- C --- XI0 P --- IPA(1)=26 IPA(2)=14 NVEFIX=1 IF (NCHT .EQ. -1) GO TO 120 C --- CHARGE MISMATCH ==> TAKE A S+ AND CORRECT THE STRANGENESS --- C --- BY REPLACING 2 PI- BY K- --- C --- S+ P --- IPA(1)=20 IPA(2)=14 NVEFIX=2 GO TO 120 C 104 CONTINUE C --- OM- P --- IPA(1)=33 IPA(2)=14 C 105 CONTINUE C --- OM- N --- IPA(1)=33 IPA(2)=16 GO TO 120 C C --- NEUTRON TARGET --- 112 CONTINUE C --- CHECK FOR TOTAL CHARGE OF FINAL STATE MESONS TO DETERMINE --- C --- THE KIND OF BARYONS TO BE PRODUCED TAKING INTO ACCOUNT --- C --- CHARGE AND STRANGENESS CONSERVATION --- NCHT=NP-NM IF (NCHT .LT. -1) GO TO 113 IF (NCHT .EQ. -1) GO TO 114 IF (NCHT .GT. -1) GO TO 115 C 113 CONTINUE C --- STRANGENESS MISMATCH ==> TAKE A XI0 AND CORRECT THE STRANGENESS --- C --- BY REPLACING A PI- BY K- --- C --- XI0 P --- IPA(1)=26 IPA(2)=14 NVEFIX=1 IF (NCHT .EQ. -2) GO TO 120 C --- CHARGE MISMATCH ==> TAKE A S+ AND CORRECT THE STRANGENESS --- C --- BY REPLACING 2 PI- BY K- --- C --- S+ P --- IPA(1)=20 IPA(2)=14 NVEFIX=2 GO TO 120 C 114 CONTINUE C --- OM- P --- IPA(1)=33 IPA(2)=14 GO TO 120 C 115 CONTINUE C --- OM- N --- IPA(1)=33 IPA(2)=16 C C --- TAKE PIONS FOR ALL SECONDARY MESONS --- 120 CONTINUE NT=2 C IF (NP .EQ. 0) GO TO 122 C C --- PI+ --- DO 121 I=1,NP NT=NT+1 IPA(NT)=7 121 CONTINUE C 122 CONTINUE IF (NM .EQ. 0) GO TO 124 C C --- PI- --- DO 123 I=1,NM NT=NT+1 IPA(NT)=9 IF (NVEFIX .GE. 1) IPA(NT)=13 IF (NPRT(4) .AND. (NVEFIX .GE. 1)) PRINT 3000 3000 FORMAT(' *CASOM* K- INTRODUCED') NVEFIX=NVEFIX-1 123 CONTINUE C 124 CONTINUE IF (NZ .EQ. 0) GO TO 130 C C --- PI0 --- DO 125 I=1,NZ NT=NT+1 IPA(NT)=8 125 CONTINUE C C --- ALL SECONDARY PARTICLES HAVE BEEN DEFINED --- C --- NOW GO FOR MOMENTA AND X VALUES --- 130 CONTINUE IF (NPRT(4)) WRITE(NEWBCD,2004) NT,(IPA(I),I=1,60) 2004 FORMAT(' *CASOM* ',I3,' PARTICLES PRODUCED. MASS INDEX ARRAY : '/ $ 3(1H ,20(I3,1X)/)) GO TO 50 C 131 CONTINUE IF (NPRT(4)) WRITE(NEWBCD,2005) 2005 FORMAT(' *CASOM* NO PARTICLES PRODUCED') C 9999 CONTINUE RETURN END *CMZ : 3.16/00 05/11/93 19.20.14 BY FEDERICO CARMINATI *-- AUTHOR : C--------------------------------------------------------------------- SUBROUTINE CASSM(K,INT,NFL) C C *** CASCADE OF SIGMA- *** C *** NVE 04-MAY-1988 CERN GENEVA *** C C ORIGIN : H.FESEFELDT (13-SEP-1987) C C S- 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 PARAMETER (MXGKGH=100) COMMON/CONSTS/ PI,TWPI,PIBTW,MP,MPI,MMU,MEL,MKCH,MK0,SMP,SMPI, $ SMU,CT,CTKCH,CTK0, $ ML0,MSP,MS0,MSM,MX0,MXM,CTL0,CTSP,CTSM,CTX0,CTXM, $ RMASS(35),RCHARG(35) C REAL MP,MPI,MMU,MEL,MKCH,MK0, * ML0,MSP,MS0,MSM,MX0,MXM C PARAMETER (MXGKCU=MXGKGH) COMMON/CURPAR/WEIGHT(10),DDELTN,IFILE,IRUN,NEVT,NEVENT,SHFLAG, * ITHST,ITTOT,ITLST,IFRND,TOFCUT,CMOM(5),CENG(5), * RS,S,ENP(10),NP,NM,NN,NR,NO,NZ,IPA(MXGKCU), * ATNO2,ZNO2 C COMMON/RESULT/XEND,YEND,ZEND,RCA,RCE,AMAS,NCH,TOF,PX,PY,PZ, * USERW,INTCT,P,EN,EK,AMASQ,DELTN,ITK,NTK,IPART,IND, * LCALO,ICEL,SINL,COSL,SINP,COSP, * XOLD,YOLD,ZOLD,POLD,PXOLD,PYOLD,PZOLD, * XSCAT,YSCAT,ZSCAT,PSCAT,PXSCAT,PYSCAT,PZSCAT REAL NCH,INTCT C COMMON/PRNTFL/INBCD,NEWBCD,INBIN,NEWBIN,NPEVT,NEVTP,LPRT,NPRT(10) LOGICAL LPRT,NPRT C C --- INITIALIZATION FLAGS FOR VARIOUS GHEISHA ROUTINES --- COMMON /KGINIT/ KGINIT(50) C C --- BOUNDARY LIMITS FOR ARGUMENTS OF INTRINSIC FUNCTIONS --- C --- XL DENOTES LOWER BOUND WHEREAS XU DENOTES UPPER BOUND --- COMMON /LIMITS/ EXPXL,EXPXU C C REAL N DIMENSION PMUL(2,1200),ANORM(2,60),CECH(10),IIPA(10,2),B(2) DIMENSION RNDM(2) SAVE PMUL,ANORM SAVE DATA CECH/0.50,0.45,0.40,0.35,0.30,0.25,0.06,0.04,0.005,0./ DATA IIPA/21,18,14,16,16,16,16,16,16,16, * 16,16,22,21,18,22,22,22,22,22/ DATA B/0.7,0.7/,C/1.25/ C C --- INITIALIZATION INDICATED BY KGINIT(12) --- IF (KGINIT(12) .NE. 0) GO TO 10 KGINIT(12)=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 P AS TARGET C L=0 DO 1 NP1=1,20 NP=NP1-1 NMM1=NP1-1 IF(NMM1.LE.0) NMM1=1 NPP1=NP1+1 DO 1 NM1=NMM1,NPP1 NM=NM1-1 DO 1 NZ1=1,20 NZ=NZ1-1 L=L+1 IF(L.GT.1200) GOTO 1 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) ANORM(1,NT)=ANORM(1,NT)+PMUL(1,L) 1 CONTINUE C** FOR N AS TARGET L=0 DO 2 NP1=1,20 NP=NP1-1 NMM1=NP1 NPP1=NP1+2 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 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) 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(22) C** ELASTIC SCATTERING NP=0 NM=0 NZ=0 N=0. IPA(1)=22 IPA(2)=14 IF(NFL.EQ.2) IPA(2)=16 IF(INT.EQ.2) GOTO 20 C** INTRODUCE CHARGE AND STRANGENESS EXCHANGE REACTIONS C** S-P --> S0N, S-P --> L N , C** S-P --> PS-, S-P --> N S0 , S-P --> N L C** S-N --> NS-, 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 120 CALL GRNDM(RNDM,1) RAN=RNDM(1) IRN=IFIX(RAN/0.2)+1 IF(IRN.GT.5) IRN=5 IRN=IRN+(NFL-1)*5 IPA(1)=IIPA(IRN,1) IPA(2)=IIPA(IRN,2) GOTO 120 C** CHECK IF ENERGETICALLY POSSIBLE TO PRODUCE ONE EXTRA PION IN REACT. 20 IF (EAB .LE. RMASS(7)) GOTO 55 ALEAB=LOG(EAB) C** NO. OF TOTAL PARTICLES VS SQRT(S)-MP-MSM 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 .LT. EXPXL) TEST=EXPXL IF (TEST .GT. EXPXU) TEST=EXPXU DUM1=PI*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 ANPN=ANPN+ADDNVE 21 CONTINUE ANPN=1./ANPN C** P OR N AS TARGET CALL GRNDM(RNDM,1) RAN=RNDM(1) EXCS=0. GOTO (30,40),NFL C** FOR P AS TARGET 30 L=0 DO 31 NP1=1,20 NP=NP1-1 NMM1=NP1-1 IF(NMM1.LE.0) NMM1=1 NPP1=NP1+1 DO 31 NM1=NMM1,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 .LT. EXPXL) TEST=EXPXL IF (TEST .GT. EXPXU) TEST=EXPXU 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 N AS TARGET 40 L=0 DO 41 NP1=1,20 NP=NP1-1 NMM1=NP1 NPP1=NP1+2 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 .LT. EXPXL) TEST=EXPXL IF (TEST .GT. EXPXU) TEST=EXPXU 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 IF(INT.EQ.1) CALL TWOB(22,NFL,N) IF(INT.EQ.2) CALL GENXPT(22,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 IPA(1)=22 IPA(2)=14 IF(NFL.EQ.2) IPA(2)=16 GOTO 120 100 DO 101 I=1,60 101 IPA(I)=0 IF(INT.LE.0) GOTO 131 GOTO (102,112),NFL 102 NCHT=NP-NM NCHT=NCHT+2 IF(NCHT.LE.0) NCHT=1 IF(NCHT.GT.3) NCHT=3 GOTO (103,104,105),NCHT 103 IPA(1)=21 CALL GRNDM(RNDM,1) IF(RNDM(1).LT.0.5) IPA(1)=18 IPA(2)=14 GOTO 120 104 IPA(1)=22 IPA(2)=14 CALL GRNDM(RNDM,2) IF(RNDM(1).LT.0.5) GOTO 120 IPA(1)=21 IF(RNDM(2).LT.0.5) IPA(1)=18 IPA(2)=16 GOTO 120 105 IPA(1)=22 IPA(2)=16 GOTO 120 112 NCHT=NP-NM NCHT=NCHT+3 IF(NCHT.LE.0) NCHT=1 IF(NCHT.GT.3) NCHT=3 GOTO (113,114,115),NCHT 113 IPA(1)=21 CALL GRNDM(RNDM,1) IF(RNDM(1).LT.0.5) IPA(1)=18 IPA(2)=14 GOTO 120 114 IPA(1)=21 CALL GRNDM(RNDM,2) IF(RNDM(1).LT.0.5) IPA(1)=18 IPA(2)=16 IF(RNDM(2).LT.0.5) GOTO 120 IPA(1)=22 IPA(2)=14 GOTO 120 115 IPA(1)=22 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(' *CASSM* CASCADE ENERGETICALLY NOT POSSIBLE', $ ' CONTINUE WITH QUASI-ELASTIC SCATTERING') 1003 FORMAT(' *CASSM* SIGMA- -INDUCED CASCADE,', $ ' AVAIL. ENERGY',2X,F8.4,/, $ 2X,' ',2X,F8.4,2X,'FROM',4(2X,I3),2X,'PARTICLES') 1004 FORMAT(' *CASSM* SIGMA- -INDUCED CASCADE,', $ ' EXCLUSIVE REACTION NOT FOUND', $ ' TRY ELASTIC SCATTERING AVAIL. ENERGY',2X,F8.4,/,2X, $ ' ',2X,F8.4) 2001 FORMAT(' *CASSM* TABLES FOR MULT. DATA SIGMA- INDUCED REACTION', $ ' FOR DEFINITION OF NUMBERS SEE FORTRAN CODING') 2002 FORMAT(' *CASSM* TARGET PARTICLE FLAG',2X,I5) 2003 FORMAT(1H ,10E12.4) 2004 FORMAT(' *CASSM* ',I3,2X,'PARTICLES , MASS INDEX ARRAY',2X,20I4) 2005 FORMAT(' *CASSM* NO PARTICLES PRODUCED') C 9999 CONTINUE RETURN END *CMZ : 3.16/00 05/11/93 19.20.36 BY FEDERICO CARMINATI *-- AUTHOR : C--------------------------------------------------------------------- SUBROUTINE CASSP(K,INT,NFL) C C *** CASCADE OF SIGMA+ *** C *** NVE 04-MAY-1988 CERN GENEVA *** C C ORIGIN : H.FESEFELDT (30-NOV-1987) C C S+ 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 PARAMETER (MXGKGH=100) COMMON/CONSTS/ PI,TWPI,PIBTW,MP,MPI,MMU,MEL,MKCH,MK0,SMP,SMPI, $ SMU,CT,CTKCH,CTK0, $ ML0,MSP,MS0,MSM,MX0,MXM,CTL0,CTSP,CTSM,CTX0,CTXM, $ RMASS(35),RCHARG(35) C REAL MP,MPI,MMU,MEL,MKCH,MK0, * ML0,MSP,MS0,MSM,MX0,MXM C PARAMETER (MXGKCU=MXGKGH) COMMON/CURPAR/WEIGHT(10),DDELTN,IFILE,IRUN,NEVT,NEVENT,SHFLAG, * ITHST,ITTOT,ITLST,IFRND,TOFCUT,CMOM(5),CENG(5), * RS,S,ENP(10),NP,NM,NN,NR,NO,NZ,IPA(MXGKCU), * ATNO2,ZNO2 C COMMON/RESULT/XEND,YEND,ZEND,RCA,RCE,AMAS,NCH,TOF,PX,PY,PZ, * USERW,INTCT,P,EN,EK,AMASQ,DELTN,ITK,NTK,IPART,IND, * LCALO,ICEL,SINL,COSL,SINP,COSP, * XOLD,YOLD,ZOLD,POLD,PXOLD,PYOLD,PZOLD, * XSCAT,YSCAT,ZSCAT,PSCAT,PXSCAT,PYSCAT,PZSCAT REAL NCH,INTCT C COMMON/PRNTFL/INBCD,NEWBCD,INBIN,NEWBIN,NPEVT,NEVTP,LPRT,NPRT(10) LOGICAL LPRT,NPRT C C --- INITIALIZATION FLAGS FOR VARIOUS GHEISHA ROUTINES --- COMMON /KGINIT/ KGINIT(50) C C --- BOUNDARY LIMITS FOR ARGUMENTS OF INTRINSIC FUNCTIONS --- C --- XL DENOTES LOWER BOUND WHEREAS XU DENOTES UPPER BOUND --- COMMON /LIMITS/ EXPXL,EXPXU C C REAL N DIMENSION PMUL(2,1200),ANORM(2,60),CECH(10),IIPA(10,2),B(2) DIMENSION RNDM(2) SAVE PMUL,ANORM SAVE DATA CECH/0.50,0.45,0.40,0.35,0.30,0.25,0.06,0.04,0.005,0./ DATA IIPA/14,14,14,14,14,21,18,16,14,14, * 20,20,20,20,20,14,14,20,21,18/ DATA B/0.7,0.7/,C/1.25/ C C --- INITIALIZATION INDICATED BY KGINIT(13) --- IF (KGINIT(13) .NE. 0) GO TO 10 KGINIT(13)=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 P AS TARGET C L=0 DO 1 NP1=1,20 NP=NP1-1 NMM1=NP1 IF(NMM1.LE.0) NMM1=1 NPP1=NP1+2 DO 1 NM1=NMM1,NPP1 NM=NM1-1 DO 1 NZ1=1,20 NZ=NZ1-1 L=L+1 IF(L.GT.1200) GOTO 1 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) ANORM(1,NT)=ANORM(1,NT)+PMUL(1,L) 1 CONTINUE C** FOR N 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 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) 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(20) C** ELASTIC SCATTERING NP=0 NM=0 NZ=0 N=0. IPA(1)=20 IPA(2)=14 IF(NFL.EQ.2) IPA(2)=16 IF(INT.EQ.2) GOTO 20 C** INTRODUCE CHARGE AND STRANGENESS EXCHANGE REACTIONS C** S+N --> S0 P ,S+N --> L P, C** S+P --> PS+, C** S+N --> NS+, S+N --> P S0 , S+N --> P L 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 120 CALL GRNDM(RNDM,1) RAN=RNDM(1) IRN=IFIX(RAN/0.2)+1 IF(IRN.GT.5) IRN=5 IRN=IRN+(NFL-1)*5 IPA(1)=IIPA(IRN,1) IPA(2)=IIPA(IRN,2) GOTO 120 C** CHECK IF ENERGETICALLY POSSIBLE TO PRODUCE ONE EXTRA PION IN REACT. 20 IF (EAB .LE. RMASS(7)) GOTO 55 ALEAB=LOG(EAB) C** NO. OF TOTAL PARTICLES VS SQRT(S)-MP-MSM 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 .LT. EXPXL) TEST=EXPXL IF (TEST .GT. EXPXU) TEST=EXPXU DUM1=PI*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 ANPN=ANPN+ADDNVE 21 CONTINUE ANPN=1./ANPN C** P OR N AS TARGET CALL GRNDM(RNDM,1) RAN=RNDM(1) EXCS=0. GOTO (30,40),NFL C** FOR P AS TARGET 30 L=0 DO 31 NP1=1,20 NP=NP1-1 NMM1=NP1 IF(NMM1.LE.0) NMM1=1 NPP1=NP1+2 DO 31 NM1=NMM1,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 .LT. EXPXL) TEST=EXPXL IF (TEST .GT. EXPXU) TEST=EXPXU 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 N 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 .LT. EXPXL) TEST=EXPXL IF (TEST .GT. EXPXU) TEST=EXPXU 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 IF(INT.EQ.1) CALL TWOB(20,NFL,N) IF(INT.EQ.2) CALL GENXPT(20,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 IPA(1)=20 IPA(2)=14 IF(NFL.EQ.2) IPA(2)=16 GOTO 120 100 DO 101 I=1,60 101 IPA(I)=0 IF(INT.LE.0) GOTO 131 GOTO (102,112),NFL 102 NCHT=NP-NM NCHT=NCHT+3 IF(NCHT.LE.0) NCHT=1 IF(NCHT.GT.3) NCHT=3 GOTO (103,104,105),NCHT 103 IPA(1)=21 CALL GRNDM(RNDM,1) IF(RNDM(1).LT.0.5) IPA(1)=18 IPA(2)=16 GOTO 120 104 IPA(1)=20 IPA(2)=16 CALL GRNDM(RNDM,2) IF(RNDM(1).LT.0.5) GOTO 120 IPA(1)=21 IF(RNDM(2).LT.0.5) IPA(1)=18 IPA(2)=14 GOTO 120 105 IPA(1)=20 IPA(2)=14 GOTO 120 112 NCHT=NP-NM NCHT=NCHT+2 IF(NCHT.LE.0) NCHT=1 IF(NCHT.GT.3) NCHT=3 GOTO (113,114,115),NCHT 113 IPA(1)=20 IPA(2)=14 GOTO 120 114 IPA(1)=21 CALL GRNDM(RNDM,2) IF(RNDM(1).LT.0.5) IPA(1)=18 IPA(2)=14 IF(RNDM(2).LT.0.5) GOTO 120 IPA(1)=20 IPA(2)=16 GOTO 120 115 IPA(1)=21 CALL GRNDM(RNDM,1) IF(RNDM(1).LT.0.5) IPA(1)=18 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(' *CASSP* CASCADE ENERGETICALLY NOT POSSIBLE', $ ' CONTINUE WITH QUASI-ELASTIC SCATTERING') 1003 FORMAT(' *CASSP* SIGMA+ -INDUCED CASCADE,', $ ' AVAIL. ENERGY',2X,F8.4,/, $ 2X,' ',2X,F8.4,2X,'FROM',4(2X,I3),2X,'PARTICLES') 1004 FORMAT(' *CASSP* SIGMA+ -INDUCED CASCADE,', $ ' EXCLUSIVE REACTION NOT FOUND', $ ' TRY ELASTIC SCATTERING AVAIL. ENERGY',2X,F8.4,/,2X, $ ' ',2X,F8.4) 2001 FORMAT(' *CASSP* TABLES FOR MULT. DATA SIGMA+ INDUCED REACTION', $ ' FOR DEFINITION OF NUMBERS SEE FORTRAN CODING') 2002 FORMAT(' *CASSP* TARGET PARTICLE FLAG',2X,I5) 2003 FORMAT(1H ,10E12.4) 2004 FORMAT(' *CASSP* ',I3,2X,'PARTICLES , MASS INDEX ARRAY',2X,20I4) 2005 FORMAT(' *CASSP* NO PARTICLES PRODUCED') C 9999 CONTINUE RETURN END *CMZU: 3.16/00 05/11/93 17.20.00 BY FEDERICO CARMINATI *-- AUTHOR : C--------------------------------------------------------------------- SUBROUTINE CASP(K,INT,NFL) C C *** CASCADE OF PROTON *** C *** NVE 04-MAY-1988 CERN GENEVA *** C C ORIGIN : H.FESEFELDT (13-SEP-1987) C C P 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 PARAMETER (MXGKGH=100) COMMON/CONSTS/ PI,TWPI,PIBTW,MP,MPI,MMU,MEL,MKCH,MK0,SMP,SMPI, $ SMU,CT,CTKCH,CTK0, $ ML0,MSP,MS0,MSM,MX0,MXM,CTL0,CTSP,CTSM,CTX0,CTXM, $ RMASS(35),RCHARG(35) C REAL MP,MPI,MMU,MEL,MKCH,MK0, * ML0,MSP,MS0,MSM,MX0,MXM C PARAMETER (MXGKCU=MXGKGH) COMMON/CURPAR/WEIGHT(10),DDELTN,IFILE,IRUN,NEVT,NEVENT,SHFLAG, * ITHST,ITTOT,ITLST,IFRND,TOFCUT,CMOM(5),CENG(5), * RS,S,ENP(10),NP,NM,NN,NR,NO,NZ,IPA(MXGKCU), * ATNO2,ZNO2 C COMMON/RESULT/XEND,YEND,ZEND,RCA,RCE,AMAS,NCH,TOF,PX,PY,PZ, * USERW,INTCT,P,EN,EK,AMASQ,DELTN,ITK,NTK,IPART,IND, * LCALO,ICEL,SINL,COSL,SINP,COSP, * XOLD,YOLD,ZOLD,POLD,PXOLD,PYOLD,PZOLD, * XSCAT,YSCAT,ZSCAT,PSCAT,PXSCAT,PYSCAT,PZSCAT REAL NCH,INTCT C COMMON/PRNTFL/INBCD,NEWBCD,INBIN,NEWBIN,NPEVT,NEVTP,LPRT,NPRT(10) LOGICAL LPRT,NPRT C C --- INITIALIZATION FLAGS FOR VARIOUS GHEISHA ROUTINES --- COMMON /KGINIT/ KGINIT(50) C C --- BOUNDARY LIMITS FOR ARGUMENTS OF INTRINSIC FUNCTIONS --- C --- XL DENOTES LOWER BOUND WHEREAS XU DENOTES UPPER BOUND --- COMMON /LIMITS/ EXPXL,EXPXU C C REAL N DIMENSION PMUL(2,1200),ANORM(2,60),SUPP(10),CECH(10),B(2) DIMENSION RNDM(1) SAVE PMUL,ANORM SAVE 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.70,0.35/,C/1.25/ C C --- INITIALIZATION INDICATED BY KGINIT(10) --- IF (KGINIT(10) .NE. 0) GO TO 10 KGINIT(10)=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 P AS TARGET C L=0 DO 1 NP1=1,20 NP=NP1-1 NMM1=NP1-2 IF(NMM1.LE.1) NMM1=1 DO 1 NM1=NMM1,NP1 NM=NM1-1 DO 1 NZ1=1,20 NZ=NZ1-1 L=L+1 IF(L.GT.1200) GOTO 1 NPROT=2-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(1),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 N 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(2),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(14) C** ELASTIC SCATTERING NCECH=0 NP=0 NM=0 NZ=0 N=0. IF(INT.EQ.2) GOTO 20 C** INTRODUCE CHARGE EXCHANGE REACTION PN --> NP IF(NFL.EQ.1) 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 (23,24),NFL 23 CONTINUE TEST=-(1+B(1))**2/(2.0*C**2) IF (TEST .LT. EXPXL) TEST=EXPXL IF (TEST .GT. EXPXU) TEST=EXPXU W0=EXP(TEST)/2.0 WP=EXP(TEST) CALL GRNDM(RNDM,1) RAN=RNDM(1) NP=0 NM=0 NZ=1 IF(RAN.LT.W0/(W0+WP)) GOTO 100 NP=1 NM=0 NZ=0 GOTO 100 24 CONTINUE TEST=-(1+B(2))**2/(2.0*C**2) IF (TEST .LT. EXPXL) TEST=EXPXL IF (TEST .GT. EXPXU) TEST=EXPXU W0=EXP(TEST) WP=EXP(TEST)/2.0 TEST=-(-1+B(2))**2/(2.0*C**2) IF (TEST .LT. EXPXL) TEST=EXPXL IF (TEST .GT. EXPXU) TEST=EXPXU 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 .LT. EXPXL) TEST=EXPXL IF (TEST .GT. EXPXU) TEST=EXPXU DUM1=PI*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 ANPN=ANPN+ADDNVE 21 CONTINUE ANPN=1./ANPN C** P OR N AS TARGET CALL GRNDM(RNDM,1) RAN=RNDM(1) EXCS=0. GOTO (30,40),NFL C** FOR P AS TARGET 30 L=0 DO 31 NP1=1,20 NP=NP1-1 NMM1=NP1-2 IF(NMM1.LE.1) NMM1=1 DO 31 NM1=NMM1,NP1 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 .LT. EXPXL) TEST=EXPXL IF (TEST .GT. EXPXU) TEST=EXPXU 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 N 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 .LT. EXPXL) TEST=EXPXL IF (TEST .GT. EXPXU) TEST=EXPXU 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(14,NFL,N) IF(INT.EQ.2) CALL GENXPT(14,NFL,N) GO TO 9999 55 IF(NPRT(4)) *WRITE(NEWBCD,1001) GOTO 53 C** EXCLUSIVE REACTION NOT FOUND,ASSUME ELASTIC SCATTERING 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=2-NP+NM+(1-NFL) NNEUT=2-NPROT GOTO (102,112),NFL 102 GOTO (103,104),INT 103 IPA(1)=14 IPA(2)=14 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)=14 IPA(2)=16 NT=2 IF(NCECH.EQ.0) GOTO 130 IPA(1)=16 IPA(2)=14 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)=16 IPA(2)=14 CALL GRNDM(RNDM,1) IF(RNDM(1).LT.0.33) GOTO 120 IPA(1)=14 IPA(2)=16 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(' *CASP* CASCADE ENERGETICALLY NOT POSSIBLE', $ ' CONTINUE WITH QUASI-ELASTIC SCATTERING') 1003 FORMAT(' *CASP* PROTON-INDUCED CASCADE,', $ ' AVAIL. ENERGY',2X,F8.4,/, $ 2X,' ',2X,F8.4,2X,'FROM',4(2X,I3),2X,'PARTICLES') 1004 FORMAT(' *CASP* PROTON-INDUCED CASCADE,', $ ' EXCLUSIVE REACTION NOT FOUND', $ ' TRY ELASTIC SCATTERING AVAIL. ENERGY',2X,F8.4,/,2X, $ ' ',2X,F8.4) 2001 FORMAT(' *CASP* TABLES FOR MULT. DATA PROTON INDUCED REACTION', $ ' FOR DEFINITION OF NUMBERS SEE FORTRAN CODING') 2002 FORMAT(' *CASP* TARGET PARTICLE FLAG',2X,I5) 2003 FORMAT(1H ,10E12.4) 2004 FORMAT(' *CASP* ',I3,2X,'PARTICLES , MASS INDEX ARRAY',2X,20I4) 2005 FORMAT(' *CASP* NO PARTICLES PRODUCED') C 9999 CONTINUE RETURN END *CMZU: 3.16/00 05/11/93 17.20.00 BY FEDERICO CARMINATI *-- AUTHOR : C--------------------------------------------------------------------- SUBROUTINE CASPB(K,INT,NFL) C C *** CASCADE OF ANTI PROTON *** C *** NVE 04-MAY-1988 CERN GENEVA *** C C ORIGIN : H.FESEFELDT (13-SEP-1987) C C PB 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 PARAMETER (MXGKGH=100) COMMON/CONSTS/ PI,TWPI,PIBTW,MP,MPI,MMU,MEL,MKCH,MK0,SMP,SMPI, $ SMU,CT,CTKCH,CTK0, $ ML0,MSP,MS0,MSM,MX0,MXM,CTL0,CTSP,CTSM,CTX0,CTXM, $ RMASS(35),RCHARG(35) C REAL MP,MPI,MMU,MEL,MKCH,MK0, * ML0,MSP,MS0,MSM,MX0,MXM C PARAMETER (MXGKCU=MXGKGH) COMMON/CURPAR/WEIGHT(10),DDELTN,IFILE,IRUN,NEVT,NEVENT,SHFLAG, * ITHST,ITTOT,ITLST,IFRND,TOFCUT,CMOM(5),CENG(5), * RS,S,ENP(10),NP,NM,NN,NR,NO,NZ,IPA(MXGKCU), * ATNO2,ZNO2 C COMMON/RESULT/XEND,YEND,ZEND,RCA,RCE,AMAS,NCH,TOF,PX,PY,PZ, * USERW,INTCT,P,EN,EK,AMASQ,DELTN,ITK,NTK,IPART,IND, * LCALO,ICEL,SINL,COSL,SINP,COSP, * XOLD,YOLD,ZOLD,POLD,PXOLD,PYOLD,PZOLD, * XSCAT,YSCAT,ZSCAT,PSCAT,PXSCAT,PYSCAT,PZSCAT REAL NCH,INTCT C COMMON/PRNTFL/INBCD,NEWBCD,INBIN,NEWBIN,NPEVT,NEVTP,LPRT,NPRT(10) LOGICAL LPRT,NPRT C C --- INITIALIZATION FLAGS FOR VARIOUS GHEISHA ROUTINES --- COMMON /KGINIT/ KGINIT(50) C C --- BOUNDARY LIMITS FOR ARGUMENTS OF INTRINSIC FUNCTIONS --- C --- XL DENOTES LOWER BOUND WHEREAS XU DENOTES UPPER BOUND --- COMMON /LIMITS/ EXPXL,EXPXU C C REAL N DIMENSION PMUL1(2,1200),PMUL2(2,400),ANORM1(2,60),ANORM2(2,60), $ SUPP(10),CECH(20),ANHL(29),B(2) DIMENSION RNDM(1) SAVE PMUL1,ANORM1,PMUL2,ANORM2 SAVE DATA SUPP/0.,0.4,0.55,0.65,0.75,0.82,0.86,0.90,0.94,0.98/ DATA CECH/0.14,0.17,0.18,0.18,0.18,0.17,0.17,0.16,0.155,0.145, * 0.11,0.082,0.065,0.050,0.041,0.035,0.028,0.024,0.010 * ,0.0/ DATA ANHL/1.00,1.00,1.00,1.00,1.0,1.00,1.0,1.00,1.00,0.90 * ,0.6,0.52,0.47,0.44,0.41,0.39,0.37,0.35,0.34,0.24 * ,0.19,0.15,0.12,0.10,0.09,0.07,0.06,0.05,0./ DATA B/0.7,0.7/,C/1.25/ C C --- INITIALIZATION INDICATED BY KGINIT(11) --- IF (KGINIT(11) .NE. 0) GO TO 10 KGINIT(11)=1 C C --- INITIALIZE PMUL AND ANORM ARRAYS --- DO 9000 J=1,1200 DO 9001 I=1,2 PMUL1(I,J)=0.0 IF (J .LE. 400) PMUL2(I,J)=0.0 IF (J .LE. 60) ANORM1(I,J)=0.0 IF (J .LE. 60) ANORM2(I,J)=0.0 9001 CONTINUE 9000 CONTINUE C C** COMPUTE NORMALIZATION CONSTANTS C** FOR P AS TARGET C L=0 DO 1 NP1=1,20 NP=NP1-1 NMM1=NP1-1 IF(NMM1.LE.1) NMM1=1 NPP1=NP1+1 DO 1 NM1=NMM1,NPP1 NM=NM1-1 DO 1 NZ1=1,20 NZ=NZ1-1 L=L+1 IF(L.GT.1200) GOTO 1 NT=NP+NM+NZ IF(NT.LE.0.OR.NT.GT.60) GOTO 1 PMUL1(1,L)=PMLTPC(NP,NM,NZ,NT,B(1),C) ANORM1(1,NT)=ANORM1(1,NT)+PMUL1(1,L) 1 CONTINUE C** FOR N AS TARGET L=0 DO 2 NP1=1,20 NP=NP1-1 NPP1=NP1+2 DO 2 NM1=NP1,NPP1 NM=NM1-1 DO 2 NZ1=1,20 NZ=NZ1-1 L=L+1 IF(L.GT.1200) GOTO 2 NT=NP+NM+NZ IF(NT.LE.0.OR.NT.GT.60) GOTO 2 PMUL1(2,L)=PMLTPC(NP,NM,NZ,NT,B(2),C) ANORM1(2,NT)=ANORM1(2,NT)+PMUL1(2,L) 2 CONTINUE DO 3 I=1,60 IF(ANORM1(1,I).GT.0.) ANORM1(1,I)=1./ANORM1(1,I) IF(ANORM1(2,I).GT.0.) ANORM1(2,I)=1./ANORM1(2,I) 3 CONTINUE IF(.NOT.NPRT(10)) GOTO 9 WRITE(NEWBCD,2001) DO 4 NFL=1,2 WRITE(NEWBCD,2002) NFL WRITE(NEWBCD,2003) (ANORM1(NFL,I),I=1,60) WRITE(NEWBCD,2003) (PMUL1(NFL,I),I=1,1200) 4 CONTINUE C** DO THE SAME FOR ANNIHILATION CHANNELS C** FOR P AS TARGET C 9 L=0 DO 5 NP1=1,20 NP=NP1-1 NM=NP DO 5 NZ1=1,20 NZ=NZ1-1 L=L+1 IF(L.GT.400) GOTO 5 NT=NP+NM+NZ IF(NT.LE.1.OR.NT.GT.60) GOTO 5 PMUL2(1,L)=PMLTPC(NP,NM,NZ,NT,B(1),C) ANORM2(1,NT)=ANORM2(1,NT)+PMUL2(1,L) 5 CONTINUE C** FOR N AS TARGET L=0 DO 6 NP1=1,20 NP=NP1-1 NM=NP+1 DO 6 NZ1=1,20 NZ=NZ1-1 L=L+1 IF(L.GT.400) GOTO 6 NT=NP+NM+NZ IF(NT.LE.1.OR.NT.GT.60) GOTO 6 PMUL2(2,L)=PMLTPC(NP,NM,NZ,NT,B(2),C) ANORM2(2,NT)=ANORM2(2,NT)+PMUL2(2,L) 6 CONTINUE DO 7 I=1,60 IF(ANORM2(1,I).GT.0.) ANORM2(1,I)=1./ANORM2(1,I) IF(ANORM2(2,I).GT.0.) ANORM2(2,I)=1./ANORM2(2,I) 7 CONTINUE IF(.NOT.NPRT(10)) GOTO 10 WRITE(NEWBCD,3001) DO 8 NFL=1,2 WRITE(NEWBCD,3002) NFL WRITE(NEWBCD,3003) (ANORM2(NFL,I),I=1,60) WRITE(NEWBCD,3003) (PMUL2(NFL,I),I=1,400) 8 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-ABS(RMASS(15)) C** ELASTIC SCATTERING NCECH=0 NP=0 NM=0 NZ=0 N=0. IF(INT.EQ.2) GOTO 20 C** INTRODUCE CHARGE EXCHANGE REACTION PB P --> NB N IF(NFL.EQ.2) GOTO 100 IPLAB=IFIX(P*10.)+1 IF(IPLAB.GT.10) IPLAB=IFIX(P)+10 IF(IPLAB.GT.20) IPLAB=20 CALL GRNDM(RNDM,1) IF(RNDM(1).GT.CECH(IPLAB)/ATNO2**0.75) GOTO 100 NCECH=1 GOTO 100 C** ANNIHILATION CHANNELS 20 IPLAB=IFIX(P*10.)+1 IF(IPLAB.GT.10) IPLAB=IFIX(P)+10 IF(IPLAB.GT.19) IPLAB=IFIX(P/10.)+19 IF(IPLAB.GT.28) IPLAB=29 CALL GRNDM(RNDM,1) IF(RNDM(1).GT.ANHL(IPLAB)) GOTO 19 EAB=RS IF (EAB .LE. 2.0*RMASS(7)) GOTO 55 GOTO 222 C** CHECK IF ENERGETICALLY POSSIBLE TO PRODUCE ONE EXTRA PION IN REACT. 19 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(1))**2/(2.0*C**2) IF (TEST .LT. EXPXL) TEST=EXPXL IF (TEST .GT. EXPXU) TEST=EXPXU W0=EXP(TEST) TEST=-(-1+B(1))**2/(2.0*C**2) IF (TEST .LT. EXPXL) TEST=EXPXL IF (TEST .GT. EXPXU) TEST=EXPXU 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(2))**2/(2.0*C**2) IF (TEST .LT. EXPXL) TEST=EXPXL IF (TEST .GT. EXPXU) TEST=EXPXU W0=EXP(TEST) WP=EXP(TEST) TEST=-(-1+B(2))**2/(2.0*C**2) IF (TEST .LT. EXPXL) TEST=EXPXL IF (TEST .GT. EXPXU) TEST=EXPXU WM=EXP(TEST) 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 .LT. EXPXL) TEST=EXPXL IF (TEST .GT. EXPXU) TEST=EXPXU DUM1=PI*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 .GT. 1.0E-10)) ADDNVE=DUM1*DUM3 ANPN=ANPN+ADDNVE 21 CONTINUE ANPN=1./ANPN C** P OR N AS TARGET CALL GRNDM(RNDM,1) RAN=RNDM(1) EXCS=0. GOTO (30,40),NFL C** FOR P AS TARGET 30 L=0 DO 31 NP1=1,20 NP=NP1-1 NMM1=NP1-1 IF(NMM1.LE.1) NMM1=1 NPP1=NP1+1 DO 31 NM1=NMM1,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 .LT. EXPXL) TEST=EXPXL IF (TEST .GT. EXPXU) TEST=EXPXU DUM1=ANPN*PI*NT*PMUL1(1,L)*ANORM1(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 .GT. 1.0E-10)) ADDNVE=DUM1*DUM3 EXCS=EXCS+ADDNVE IF(RAN.LT.EXCS) GOTO 100 31 CONTINUE GOTO 80 C** FOR N AS TARGET 40 L=0 DO 41 NP1=1,20 NP=NP1-1 NPP1=NP1+2 DO 41 NM1=NP1,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 .LT. EXPXL) TEST=EXPXL IF (TEST .GT. EXPXU) TEST=EXPXU DUM1=ANPN*PI*NT*PMUL1(2,L)*ANORM1(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 .GT. 1.0E-10)) ADDNVE=DUM1*DUM3 EXCS=EXCS+ADDNVE IF(RAN.LT.EXCS) GOTO 100 41 CONTINUE GOTO 80 C** ANNIHILATION CHANNELS 222 IPA(1)=0 IPA(2)=0 ALEAB=LOG(EAB) C** NO. OF TOTAL PARTICLES VS SQRT(S) 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 221 NT=2,60 TEST=-(PI/4.0)*(NT/N)**2 IF (TEST .LT. EXPXL) TEST=EXPXL IF (TEST .GT. EXPXU) TEST=EXPXU DUM1=PI*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 .GT. 1.0E-10)) ADDNVE=DUM1*DUM3 ANPN=ANPN+ADDNVE 221 CONTINUE ANPN=1./ANPN C** P OR N AS TARGET CALL GRNDM(RNDM,1) RAN=RNDM(1) EXCS=0. GOTO (230,240),NFL C** FOR P AS TARGET 230 L=0 DO 231 NP1=1,20 NP=NP1-1 NM=NP DO 231 NZ1=1,20 NZ=NZ1-1 L=L+1 IF(L.GT.400) GOTO 231 NT=NP+NM+NZ IF(NT.LE.1.OR.NT.GT.60) GOTO 231 TEST=-(PI/4.0)*(NT/N)**2 IF (TEST .LT. EXPXL) TEST=EXPXL IF (TEST .GT. EXPXU) TEST=EXPXU DUM1=ANPN*PI*NT*PMUL2(1,L)*ANORM2(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 .GT. 1.0E-10)) ADDNVE=DUM1*DUM3 EXCS=EXCS+ADDNVE IF(RAN.LT.EXCS) GOTO 120 231 CONTINUE GOTO 80 C** FOR N AS TARGET 240 L=0 DO 241 NP1=1,20 NP=NP1-1 NM=NP+1 DO 241 NZ1=1,20 NZ=NZ1-1 L=L+1 IF(L.GT.400) GOTO 241 NT=NP+NM+NZ IF(NT.LE.1.OR.NT.GT.60) GOTO 241 TEST=-(PI/4.0)*(NT/N)**2 IF (TEST .LT. EXPXL) TEST=EXPXL IF (TEST .GT. EXPXU) TEST=EXPXU DUM1=ANPN*PI*NT*PMUL2(2,L)*ANORM2(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 .GT. 1.0E-10)) ADDNVE=DUM1*DUM3 EXCS=EXCS+ADDNVE IF(RAN.LT.EXCS) GOTO 120 241 CONTINUE GOTO 80 50 IF(NPRT(4)) *WRITE(NEWBCD,1003) EAB,N,NFL,NP,NM,NZ CALL STPAIR IF(INT.EQ.1) CALL TWOB(15,NFL,N) IF(INT.EQ.2) CALL GENXPT(15,NFL,N) GO TO 9999 55 IF(NPRT(4)) *WRITE(NEWBCD,1001) GOTO 53 C** EXCLUSIVE REACTION NOT FOUND,ASSUME ELASTIC SCATTERING 80 IF(NPRT(4)) *WRITE(NEWBCD,1004)EAB,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 GOTO (112,102),NFL 102 GOTO (103,104),INT 103 IPA(1)=15 IPA(2)=16 NT=2 GOTO 130 104 IF(NP.EQ.-1+NM) GOTO 105 IF(NP.EQ. NM) GOTO 106 IPA(1)=17 IPA(2)=14 GOTO 120 105 IPA(1)=15 IPA(2)=14 CALL GRNDM(RNDM,1) IF(RNDM(1).LT.0.5) GOTO 120 IPA(1)=17 IPA(2)=16 GOTO 120 106 IPA(1)=15 IPA(2)=16 GOTO 120 112 GOTO (113,114),INT 113 IPA(1)=15 IPA(2)=14 NT=2 IF(NCECH.EQ.0) GOTO 130 IPA(1)=17 IPA(2)=16 GOTO 130 114 IF(NP.EQ. NM) GOTO 115 IF(NP.EQ.1+NM) GOTO 116 IPA(1)=17 IPA(2)=14 GOTO 120 115 IPA(1)=17 IPA(2)=16 CALL GRNDM(RNDM,1) IF(RNDM(1).LT.0.33) GOTO 120 IPA(1)=15 IPA(2)=14 GOTO 120 116 IPA(1)=15 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(' *CASPB* CASCADE ENERGETICALLY NOT POSSIBLE', $ ' CONTINUE WITH QUASI-ELASTIC SCATTERING') 1003 FORMAT(' *CASPB* ANTIPROTON-INDUCED CASCADE,', $ ' AVAIL. ENERGY',2X,F8.4,/, $ 2X,' ',2X,F8.4,2X,'FROM',4(2X,I3),2X,'PARTICLES') 1004 FORMAT(' *CASPB* ANTIPROTON-INDUCED CASCADE,', $ ' EXCLUSIVE REACTION', $ ' NOT FOUND TRY ELASTIC SCATTERING AVAIL. ENERGY',2X,F8.4,/,2X, $ ' ',2X,F8.4) 2001 FORMAT(' *CASPB* TABLES FOR MULT. DATA ANTIPROTON INDUCED ', $ 'REACTION FOR DEFINITION OF NUMBERS SEE FORTRAN CODING') 2002 FORMAT(' *CASPB* TARGET PARTICLE FLAG',2X,I5) 2003 FORMAT(1H ,10E12.4) 2004 FORMAT(' *CASPB* ',I3,2X,'PARTICLES , MASS INDEX ARRAY',2X,20I4) 2005 FORMAT(' *CASPB* NO PARTICLES PRODUCED') 3001 FORMAT(' *CASPB* TABLES FOR MULT. DATA ANTIPROTON INDUCED ', $ ' ANNIHILATION REACTION FOR DEFINITION OF NUMBERS SEE FORTRAN', $ ' CODING') 3002 FORMAT(' *CASPB* TARGET PARTICLE FLAG',2X,I5) 3003 FORMAT(1H ,10E12.4) C 9999 CONTINUE RETURN END *CMZ : 3.16/00 05/11/93 19.15.23 BY FEDERICO CARMINATI *-- AUTHOR : C--------------------------------------------------------------------- SUBROUTINE CASPIM(K,INT,NFL) C C *** CASCADE OF PI- *** C *** NVE 04-MAY-1988 CERN GENEVA *** C C ORIGIN : H.FESEFELDT 13-SEP-1987 C C PI- 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 PARAMETER (MXGKGH=100) COMMON/CONSTS/ PI,TWPI,PIBTW,MP,MPI,MMU,MEL,MKCH,MK0,SMP,SMPI, $ SMU,CT,CTKCH,CTK0, $ ML0,MSP,MS0,MSM,MX0,MXM,CTL0,CTSP,CTSM,CTX0,CTXM, $ RMASS(35),RCHARG(35) C REAL MP,MPI,MMU,MEL,MKCH,MK0, * ML0,MSP,MS0,MSM,MX0,MXM C PARAMETER (MXGKCU=MXGKGH) COMMON/CURPAR/WEIGHT(10),DDELTN,IFILE,IRUN,NEVT,NEVENT,SHFLAG, * ITHST,ITTOT,ITLST,IFRND,TOFCUT,CMOM(5),CENG(5), * RS,S,ENP(10),NP,NM,NN,NR,NO,NZ,IPA(MXGKCU), * ATNO2,ZNO2 C COMMON/RESULT/XEND,YEND,ZEND,RCA,RCE,AMAS,NCH,TOF,PX,PY,PZ, * USERW,INTCT,P,EN,EK,AMASQ,DELTN,ITK,NTK,IPART,IND, * LCALO,ICEL,SINL,COSL,SINP,COSP, * XOLD,YOLD,ZOLD,POLD,PXOLD,PYOLD,PZOLD, * XSCAT,YSCAT,ZSCAT,PSCAT,PXSCAT,PYSCAT,PZSCAT REAL NCH,INTCT C COMMON/PRNTFL/INBCD,NEWBCD,INBIN,NEWBIN,NPEVT,NEVTP,LPRT,NPRT(10) LOGICAL LPRT,NPRT C C --- BOUNDARY LIMITS FOR ARGUMENTS OF INTRINSIC FUNCTIONS --- C --- XL DENOTES LOWER BOUND WHEREAS XU DENOTES UPPER BOUND --- COMMON /LIMITS/ EXPXL,EXPXU C C --- INITIALIZATION FLAGS FOR VARIOUS GHEISHA ROUTINES --- COMMON /KGINIT/ KGINIT(50) C C REAL N DIMENSION PMUL(2,1200),ANORM(2,60),SUPP(10),CECH(10),B(2) DIMENSION RNDM(1) SAVE PMUL,ANORM SAVE DATA SUPP/0.,0.4,0.55,0.65,0.75,0.82,0.86,0.90,0.94,0.98/ DATA CECH/1.,0.95,0.79,0.32,0.19,0.16,0.14,0.12,0.10,0.08/ DATA B/0.7,0.7/,C/1.25/ C C --- INITIALIZATION INDICATED BY KGINIT(16) --- IF (KGINIT(16) .NE. 0) GO TO 10 KGINIT(16)=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 *** COMPUTATION OF NORMALIZATION CONSTANTS *** C C --- P TARGET --- L=0 DO 1100 NP1=1,20 NP=NP1-1 NMM1=NP1-1 IF (NMM1 .LE. 1) NMM1=1 NPP1=NP1+1 C DO 1101 NM1=NMM1,NPP1 NM=NM1-1 C DO 1102 NZ1=1,20 NZ=NZ1-1 L=L+1 IF (L .GT. 1200) GOTO 1199 NT=NP+NM+NZ IF (NT .LE. 0) GO TO 1102 IF (NT .GT. 60) GO TO 1102 PMUL(1,L)=PMLTPC(NP,NM,NZ,NT,B(1),C) ANORM(1,NT)=ANORM(1,NT)+PMUL(1,L) 1102 CONTINUE C 1101 CONTINUE C 1100 CONTINUE C 1199 CONTINUE C C --- N TARGET --- L=0 DO 1200 NP1=1,20 NP=NP1-1 NPP1=NP1+2 C DO 1201 NM1=NP1,NPP1 NM=NM1-1 C DO 1202 NZ1=1,20 NZ=NZ1-1 L=L+1 IF (L .GT. 1200) GO TO 1299 NT=NP+NM+NZ IF (NT .LE. 0) GO TO 1202 IF (NT .GT. 60) GO TO 1202 PMUL(2,L)=PMLTPC(NP,NM,NZ,NT,B(2),C) ANORM(2,NT)=ANORM(2,NT)+PMUL(2,L) 1202 CONTINUE C 1201 CONTINUE C 1200 CONTINUE C 1299 CONTINUE C DO 3 I=1,60 IF (ANORM(1,I) .GT. 0.0) ANORM(1,I)=1.0/ANORM(1,I) IF (ANORM(2,I) .GT. 0.0) ANORM(2,I)=1.0/ANORM(2,I) 3 CONTINUE C IF (.NOT. NPRT(10)) GO TO 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 C --- CHOOSE PROTON OR NEUTRON AS TARGET --- 10 CONTINUE 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(9) C C --- ELASTIC SCATTERING --- NP=0 NM=0 NZ=0 N=0.0 IPA(1)=9 IPA(2)=14 IF (NFL .EQ. 2) IPA(2)=16 IF (INT .EQ. 2) GOTO 20 GOTO 100 C C --- CHECK IF ENERGETICALLY POSSIBLE TO PRODUCE ONE EXTRA PION IN REACT. 20 CONTINUE IF (EAB .LE. RMASS(9)) GO TO 55 C C --- SUPPRESSION OF HIGH MULTIPLICITY EVENTS AT LOW MOMENTUM --- IEAB=IFIX(EAB*5.0)+1 IF (IEAB .GT. 10) GO TO 22 CALL GRNDM(RNDM,1) IF (RNDM(1) .LT. SUPP(IEAB)) GO TO 22 C C --- CHARGE EXCHANGE REACTION (IS INCLUDED IN INELASTIC CROSS SECTION) IPLAB=IFIX(P*5.0)+1 IF (IPLAB .GT. 10) IPLAB=10 CALL GRNDM(RNDM,1) IF (RNDM(1) .GT. CECH(IPLAB)) GO TO 23 C IF (NFL .EQ. 1) GOTO 24 C C --- N TARGET --- INT=1 IPA(1)=9 IPA(2)=16 GO TO 100 C C --- P TARGET --- 24 CONTINUE IPA(1)=8 IPA(2)=16 GO TO 100 C 23 CONTINUE N=1.0 C IF (NFL .EQ. 1) GO TO 26 C C --- N TARGET --- DUM=-(1+B(2))**2/(2.0*C**2) IF (DUM .LT. EXPXL) DUM=EXPXL IF (DUM .GT. EXPXU) DUM=EXPXU W0=EXP(DUM) DUM=-(-1+B(2))**2/(2.0*C**2) IF (DUM .LT. EXPXL) DUM=EXPXL IF (DUM .GT. EXPXU) DUM=EXPXU WM=EXP(DUM) CALL GRNDM(RNDM,1) RAN=RNDM(1) NP=0 NM=0 NZ=1 IF (RAN .LT. W0/(W0+WM)) GO TO 50 NP=0 NM=1 NZ=0 GO TO 50 C C --- P TARGET --- 26 CONTINUE DUM=-(1+B(1))**2/(2.0*C**2) IF (DUM .LT. EXPXL) DUM=EXPXL IF (DUM .GT. EXPXU) DUM=EXPXU W0=EXP(DUM) WP=EXP(DUM) DUM=-(-1+B(1))**2/(2.0*C**2) IF (DUM .LT. EXPXL) DUM=EXPXL IF (DUM .GT. EXPXU) DUM=EXPXU WM=EXP(DUM) WP=WP*10. 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) GO TO 50 NP=1 NM=0 NZ=0 IF (RAN .LT. WP/WT) GO TO 50 NP=0 NM=1 NZ=0 GOTO 50 C 22 CONTINUE ALEAB=LOG(EAB) C 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.0 C C --- NORMALIZATION CONSTANT FOR KNO-DISTRIBUTION --- ANPN=0.0 DO 21 NT=1,60 TEST=-(PI/4.0)*(NT/N)**2 IF (TEST .LT. EXPXL) TEST=EXPXL IF (TEST .GT. EXPXU) TEST=EXPXU DUM1=PI*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 ANPN=ANPN+ADDNVE 21 CONTINUE ANPN=1.0/ANPN C CALL GRNDM(RNDM,1) RAN=RNDM(1) EXCS=0.0 IF (NFL .EQ. 2) GO TO 40 C C --- P TARGET --- L=0 DO 310 NP1=1,20 NP=NP1-1 NMM1=NP1-1 IF (NMM1 .LE. 1) NMM1=1 NPP1=NP1+1 C DO 311 NM1=NMM1,NPP1 NM=NM1-1 C DO 312 NZ1=1,20 NZ=NZ1-1 L=L+1 IF (L .GT. 1200) GO TO 80 NT=NP+NM+NZ IF (NT .LE. 0) GO TO 312 IF (NT .GT. 60) GO TO 312 TEST=-(PI/4.0)*(NT/N)**2 IF (TEST .LT. EXPXL) TEST=EXPXL IF (TEST .GT. EXPXU) TEST=EXPXU 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 50 312 CONTINUE C 311 CONTINUE C 310 CONTINUE GOTO 80 C C --- N TARGET --- 40 CONTINUE L=0 DO 410 NP1=1,20 NP=NP1-1 NPP1=NP1+2 C DO 411 NM1=NP1,NPP1 NM=NM1-1 C DO 412 NZ1=1,20 NZ=NZ1-1 L=L+1 IF (L .GT. 1200) GO TO 80 NT=NP+NM+NZ IF (NT .LE. 0) GO TO 412 IF (NT .GT. 60) GO TO 412 TEST=-(PI/4.0)*(NT/N)**2 IF (TEST .LT. EXPXL) TEST=EXPXL IF (TEST .GT. EXPXU) TEST=EXPXU 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 50 412 CONTINUE C 411 CONTINUE C 410 CONTINUE GO TO 80 C 50 CONTINUE IF (NFL .EQ. 2) GO TO 65 C C --- P TARGET --- IF (NP .EQ. NM) GO TO 61 IF (NP .EQ. 1+NM) GO TO 63 IPA(1)=8 IPA(2)=14 GO TO 100 C 61 CONTINUE CALL GRNDM(RNDM,1) IF (RNDM(1) .LT. 0.75) GO TO 62 IPA(1)=8 IPA(2)=16 GO TO 100 C 62 CONTINUE IPA(1)=9 IPA(2)=14 GO TO 100 C 63 CONTINUE IPA(1)=9 IPA(2)=16 GO TO 100 C C --- N TARGET --- 65 CONTINUE IF (NP .EQ. -1+NM) GO TO 66 IF (NP .EQ. NM) GO TO 68 IPA(1)=8 IPA(2)=16 GO TO 100 C 66 CONTINUE CALL GRNDM(RNDM,1) IF (RNDM(1) .LT. 0.50) GO TO 67 IPA(1)=8 IPA(2)=16 GO TO 100 C 67 CONTINUE IPA(1)=9 IPA(2)=14 GO TO 100 C 68 CONTINUE IPA(1)=9 IPA(2)=16 GO TO 100 C 70 CONTINUE IF (NPRT(4)) WRITE(NEWBCD,1003) EAB,N,NFL,NP,NM,NZ CALL STPAIR IF (INT .EQ. 1) CALL TWOB(9,NFL,N) IF (INT .EQ. 2) CALL GENXPT(9,NFL,N) GO TO 9999 C C --- ENERGETICALLY NOT POSSIBLE TO PRODUCE CASCADE-PARTICLES --- C --- CONTINUE WITH QUASI-ELASTIC SCATTERING --- 55 CONTINUE IF (NPRT(4)) WRITE(NEWBCD,1001) GO TO 53 C C --- EXCLUSIVE REACTION NOT FOUND --- 80 CONTINUE IF (NPRT(4)) WRITE(NEWBCD,1004) RS,N C 53 CONTINUE INT=1 NP=0 NM=0 NZ=0 N=0.0 IPA(1)=9 IPA(2)=14 IF (NFL .EQ. 2) IPA(2)=16 C 100 CONTINUE DO 101 I=3,60 IPA(I)=0 101 CONTINUE IF (INT .LE. 0) GO TO 131 C 120 CONTINUE NT=2 IF (NP .EQ. 0) GO TO 122 DO 121 I=1,NP NT=NT+1 IPA(NT)=7 121 CONTINUE C 122 CONTINUE IF (NM .EQ. 0) GO TO 124 DO 123 I=1,NM NT=NT+1 IPA(NT)=9 123 CONTINUE C 124 CONTINUE IF (NZ .EQ. 0) GO TO 130 DO 125 I=1,NZ NT=NT+1 IPA(NT)=8 125 CONTINUE C 130 CONTINUE IF (NPRT(4)) WRITE(NEWBCD,2004) NT,(IPA(I),I=1,20) IF (IPA(1) .EQ. 7) NP=NP+1 IF (IPA(1) .EQ. 8) NZ=NZ+1 IF (IPA(1) .EQ. 9) NM=NM+1 GO TO 70 C 131 CONTINUE IF (NPRT(4)) WRITE(NEWBCD,2005) C 1001 FORMAT(' *CASPIM* CASCADE ENERGETICALLY NOT POSSIBLE', $ ' CONTINUE WITH QUASI-ELASTIC SCATTERING') 1003 FORMAT(' *CASPIM* PION- -INDUCED CASCADE, AVAIL. ENERGY',2X,F8.4, $ /,2X,' ',2X,F8.4,2X,'FROM',4(2X,I3),2X,'PARTICLES') 1004 FORMAT(' *CASPIM* PION- -INDUCED CASCADE, EXCLUSIVE REACTION', $ ' NOT FOUND TRY ELASTIC SCATTERING AVAIL. ENERGY',2X,F8.4,/,2X, * ' ',2X,F8.4) 2001 FORMAT(' *CASPIM* TABLES FOR MULTIPLICITY DATA PION- INDUCED', $ 'REACTION FOR DEFINITION OF NUMBERS SEE FORTRAN CODING') 2002 FORMAT(' *CASPIM* TARGET PARTICLE FLAG',2X,I5) 2003 FORMAT(1H ,10E12.4) 2004 FORMAT(' *CASPIM* ',I3,' PARTICLES, MASS INDEX ARRAY ',20I4) 2005 FORMAT(' *CASPIM* NO PARTICLES PRODUCED') C 9999 CONTINUE RETURN END *CMZ : 3.16/00 05/11/93 19.15.49 BY FEDERICO CARMINATI *-- AUTHOR : C--------------------------------------------------------------------- SUBROUTINE CASPIP(K,INT,NFL) C C *** CASCADE OF PI+ *** C *** NVE 04-MAY-1988 CERN GENEVA *** C C ORIGIN : H.FESEFELDT (18-SEP-1987) C C PI+ 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 PARAMETER (MXGKGH=100) COMMON/CONSTS/ PI,TWPI,PIBTW,MP,MPI,MMU,MEL,MKCH,MK0,SMP,SMPI, $ SMU,CT,CTKCH,CTK0, $ ML0,MSP,MS0,MSM,MX0,MXM,CTL0,CTSP,CTSM,CTX0,CTXM, $ RMASS(35),RCHARG(35) C REAL MP,MPI,MMU,MEL,MKCH,MK0, * ML0,MSP,MS0,MSM,MX0,MXM C PARAMETER (MXGKCU=MXGKGH) COMMON/CURPAR/WEIGHT(10),DDELTN,IFILE,IRUN,NEVT,NEVENT,SHFLAG, * ITHST,ITTOT,ITLST,IFRND,TOFCUT,CMOM(5),CENG(5), * RS,S,ENP(10),NP,NM,NN,NR,NO,NZ,IPA(MXGKCU), * ATNO2,ZNO2 C COMMON/RESULT/XEND,YEND,ZEND,RCA,RCE,AMAS,NCH,TOF,PX,PY,PZ, * USERW,INTCT,P,EN,EK,AMASQ,DELTN,ITK,NTK,IPART,IND, * LCALO,ICEL,SINL,COSL,SINP,COSP, * XOLD,YOLD,ZOLD,POLD,PXOLD,PYOLD,PZOLD, * XSCAT,YSCAT,ZSCAT,PSCAT,PXSCAT,PYSCAT,PZSCAT REAL NCH,INTCT C COMMON/PRNTFL/INBCD,NEWBCD,INBIN,NEWBIN,NPEVT,NEVTP,LPRT,NPRT(10) LOGICAL LPRT,NPRT C C --- BOUNDARY LIMITS FOR ARGUMENTS OF INTRINSIC FUNCTIONS --- C --- XL DENOTES LOWER BOUND WHEREAS XU DENOTES UPPER BOUND --- COMMON /LIMITS/ EXPXL,EXPXU C C --- INITIALIZATION FLAGS FOR VARIOUS GHEISHA ROUTINES --- COMMON /KGINIT/ KGINIT(50) C C REAL N DIMENSION PMUL(2,1200),ANORM(2,60),SUPP(10),CECH(10),B(2) DIMENSION RNDM(1) SAVE PMUL,ANORM SAVE DATA SUPP/0.,0.2,0.45,0.55,0.65,0.75,0.85,0.90,0.94,0.98/ DATA CECH/0.33,0.27,0.29,0.31,0.27,0.18,0.13,0.10,0.09,0.07/ DATA B/0.7,0.7/,C/1.25/ C C --- INITIALIZATION INDICATED BY KGINIT(18) --- IF (KGINIT(18) .NE. 0) GO TO 10 KGINIT(18)=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 P AS TARGET C L=0 DO 1 NP1=1,20 NP=NP1-1 NMM1=NP1-2 IF(NMM1.LE.1) NMM1=1 DO 1 NM1=NMM1,NP1 NM=NM1-1 DO 1 NZ1=1,20 NZ=NZ1-1 L=L+1 IF(L.GT.1200) GOTO 1 NT=NP+NM+NZ IF(NT.LE.0.OR.NT.GT.60) GOTO 1 PMUL(1,L)=PMLTPC(NP,NM,NZ,NT,B(1),C) ANORM(1,NT)=ANORM(1,NT)+PMUL(1,L) 1 CONTINUE C** FOR N 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 NT=NP+NM+NZ IF(NT.LE.0.OR.NT.GT.60) GOTO 2 PMUL(2,L)=PMLTPC(NP,NM,NZ,NT,B(2),C) 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(7) C C** ELASTIC SCATTERING NP=0 NM=0 NZ=0 N=0. IPA(1)=7 IPA(2)=14 IF(NFL.EQ.2) IPA(2)=16 IF(INT.EQ.2) GOTO 20 C** FOR PI+ N REACTIONS CHANGE SOME OF THE ELASTIC CROSS SECTION C** TO PI+ N --> PI0 P IF(NFL.EQ.1) GOTO 100 IPLAB=IFIX(P *5.)+1 IF(IPLAB.GT.10) IPLAB=10 CALL GRNDM(RNDM,1) IF(RNDM(1).GT.CECH(IPLAB)/ATNO2**0.42) GOTO 100 IPA(1)=8 IPA(2)=14 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 (23,24),NFL 23 CONTINUE TEST=-(1+B(1))**2/(2.0*C**2) IF (TEST .LE. EXPXL) TEST=EXPXL IF (TEST .GE. EXPXU) TEST=EXPXU W0=EXP(TEST) WP=EXP(TEST) CALL GRNDM(RNDM,1) RAN=RNDM(1) NP=0 NM=0 NZ=1 IF(RAN.LT.W0/(W0+WP)) GOTO 50 NP=1 NM=0 NZ=0 GOTO 50 24 CONTINUE TEST=-(1+B(2))**2/(2.0*C**2) IF (TEST .LE. EXPXL) TEST=EXPXL IF (TEST .GE. EXPXU) TEST=EXPXU W0=EXP(TEST) WP=EXP(TEST) TEST=-(-1+B(2))**2/(2.0*C**2) IF (TEST .LE. EXPXL) TEST=EXPXL IF (TEST .GE. EXPXU) TEST=EXPXU WM=EXP(TEST) 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 50 NP=1 NM=0 NZ=0 IF(RAN.LT.WP/WT) GOTO 50 NP=0 NM=1 NZ=0 GOTO 50 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 .LE. EXPXL) TEST=EXPXL IF (TEST .GE. EXPXU) TEST=EXPXU DUM1=PI*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 ANPN=ANPN+ADDNVE 21 CONTINUE ANPN=1./ANPN C** P OR N AS TARGET CALL GRNDM(RNDM,1) RAN=RNDM(1) EXCS=0. GOTO (30,40),NFL C** FOR P AS TARGET 30 L=0 DO 31 NP1=1,20 NP=NP1-1 NMM1=NP1-2 IF(NMM1.LE.1) NMM1=1 DO 31 NM1=NMM1,NP1 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 .LE. EXPXL) TEST=EXPXL IF (TEST .GE. EXPXU) TEST=EXPXU 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 50 31 CONTINUE GOTO 80 C** FOR N 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 .LE. EXPXL) TEST=EXPXL IF (TEST .GE. EXPXU) TEST=EXPXU 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 .GT. 1.0E-10)) ADDNVE=DUM1*DUM3 EXCS=EXCS+ADDNVE IF(RAN.LT.EXCS) GOTO 50 41 CONTINUE GOTO 80 50 GOTO (60,65),NFL 60 IF(NP.EQ.1+NM) GOTO 61 IF(NP.EQ.2+NM) GOTO 63 IPA(1)=7 IPA(2)=14 GOTO 100 61 CALL GRNDM(RNDM,1) IF(RNDM(1).LT.0.5) GOTO 62 IPA(1)=7 IPA(2)=16 GOTO 100 62 IPA(1)=8 IPA(2)=14 GOTO 100 63 IPA(1)=8 IPA(2)=16 GOTO 100 65 IF(NP.EQ.NM) GOTO 66 IF(NP.EQ.1+NM) GOTO 68 IPA(1)=7 IPA(2)=14 GOTO 100 66 CALL GRNDM(RNDM,1) IF(RNDM(1).LT.0.25) GOTO 67 IPA(1)=7 IPA(2)=16 GOTO 100 67 IPA(1)=8 IPA(2)=14 GOTO 100 68 IPA(1)=8 IPA(2)=16 GOTO 100 70 IF(NPRT(4)) *WRITE(NEWBCD,1003) EAB,N,NFL,NP,NM,NZ CALL STPAIR IF(INT.EQ.1) CALL TWOB(7,NFL,N) IF(INT.EQ.2) CALL GENXPT(7,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 N=0. IPA(1)=7 IPA(2)=14 IF(NFL.EQ.2) IPA(2)=16 100 DO 101 I=3,60 101 IPA(I)=0 IF(INT.LE.0) GOTO 131 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) IF(IPA(1).EQ.7) NP=NP+1 IF(IPA(1).EQ.8) NZ=NZ+1 IF(IPA(1).EQ.9) NM=NM+1 GOTO 70 131 IF(NPRT(4)) *WRITE(NEWBCD,2005) C 1001 FORMAT(' *CASPIP* CASCADE ENERGETICALLY NOT POSSIBLE', $ ' CONTINUE WITH QUASI-ELASTIC SCATTERING') 1003 FORMAT(' *CASPIP* PION+ -INDUCED CASCADE,', $ ' AVAIL. ENERGY',2X,F8.4,/, $ 2X,' ',2X,F8.4,2X,'FROM',4(2X,I3),2X,'PARTICLES') 1004 FORMAT(' *CASPIP* PION+ -INDUCED CASCADE,', $ ' EXCLUSIVE REACTION NOT FOUND', $ ' TRY ELASTIC SCATTERING AVAIL. ENERGY',2X,F8.4,/,2X, $ ' ',2X,F8.4) 2001 FORMAT(' *CASPIP* TABLES FOR MULT. DATA PION+ INDUCED REACTION', $ ' FOR DEFINITION OF NUMBERS SEE FORTRAN CODING') 2002 FORMAT(' *CASPIP* TARGET PARTICLE FLAG',2X,I5) 2003 FORMAT(1H ,10E12.4) 2004 FORMAT(' *CASPIP* ',I3,2X,'PARTICLES , MASS INDEX ARRAY',2X,20I4) 2005 FORMAT(' *CASPIP* NO PARTICLES PRODUCED') C 9999 CONTINUE RETURN END *CMZ : 19/07/94 16.37.18 by D. HECK IK3 KFK KARLSRUHE *-- Author : Nick van Eijndhoven (CERN) 02/02/89 C--------------------------------------------------------------------- SUBROUTINE CASXM(K,INT,NFL) C C *** CASCADE OF XI- *** C *** NVE 17-JAN-1989 CERN GENEVA *** C C XI- UNDERGOES INTERACTION WITH NUCLEON WITHIN NUCLEUS. C CHECK IF ENERGETICALLY POSSIBLE TO PRODUCE PIONS/KAONS. C IF NOT, ASSUME NUCLEAR EXCITATION OCCURS, DEGRADE INPUT PARTICLE C IN ENERGY AND NO OTHER PARTICLES ARE 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 PARAMETER (MXGKGH=100) COMMON/CONSTS/ PI,TWPI,PIBTW,MP,MPI,MMU,MEL,MKCH,MK0,SMP,SMPI, $ SMU,CT,CTKCH,CTK0, $ ML0,MSP,MS0,MSM,MX0,MXM,CTL0,CTSP,CTSM,CTX0,CTXM, $ RMASS(35),RCHARG(35) C REAL MP,MPI,MMU,MEL,MKCH,MK0, * ML0,MSP,MS0,MSM,MX0,MXM C PARAMETER (MXGKCU=MXGKGH) COMMON/CURPAR/WEIGHT(10),DDELTN,IFILE,IRUN,NEVT,NEVENT,SHFLAG, * ITHST,ITTOT,ITLST,IFRND,TOFCUT,CMOM(5),CENG(5), * RS,S,ENP(10),NP,NM,NN,NR,NO,NZ,IPA(MXGKCU), * ATNO2,ZNO2 C COMMON/RESULT/XEND,YEND,ZEND,RCA,RCE,AMAS,NCH,TOF,PX,PY,PZ, * USERW,INTCT,P,EN,EK,AMASQ,DELTN,ITK,NTK,IPART,IND, * LCALO,ICEL,SINL,COSL,SINP,COSP, * XOLD,YOLD,ZOLD,POLD,PXOLD,PYOLD,PZOLD, * XSCAT,YSCAT,ZSCAT,PSCAT,PXSCAT,PYSCAT,PZSCAT REAL NCH,INTCT C COMMON/PRNTFL/INBCD,NEWBCD,INBIN,NEWBIN,NPEVT,NEVTP,LPRT,NPRT(10) LOGICAL LPRT,NPRT C C --- INITIALIZATION FLAGS FOR VARIOUS GHEISHA ROUTINES --- COMMON /KGINIT/ KGINIT(50) C C --- BOUNDARY LIMITS FOR ARGUMENTS OF INTRINSIC FUNCTIONS --- C --- XL DENOTES LOWER BOUND WHEREAS XU DENOTES UPPER BOUND --- COMMON /LIMITS/ EXPXL,EXPXU C C REAL N DIMENSION PMUL(2,1200),ANORM(2,60),CECH(10),IIPA(12,2),B(2) DIMENSION RNDM(1) SAVE PMUL,ANORM SAVE DATA CECH/0.50,0.45,0.40,0.35,0.30,0.25,0.06,0.04,0.005,0./ C --- ARRAY IIPA DENOTES THE STRANGENESS AND CHARGE EXCHAGE REACTIONS --- C XI- P --> XI0 N, XI- P --> N XI0 C XI- P --> S0 S0, XI- P --> L0 L0 C XI- P --> S0 L0, XI- P --> L0 S0 C XI- P --> P XI- C XI- N --> N XI- C XI- N --> S0 S-, XI- N --> S- S0 C XI- N --> L0 S-, XI- N --> S- L0 DATA IIPA/26,16,21,18,21,18,14, 16,21,22,18,22, * 16,26,21,18,18,21,27, 27,22,21,22,18/ DATA B/0.7,0.7/,C/1.25/ C C --- INITIALIZATION INDICATED BY KGINIT(19) --- IF (KGINIT(19) .NE. 0) GO TO 10 KGINIT(19)=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 C --- FOR P TARGET --- L=0 DO 1 NP1=1,20 NP=NP1-1 NMM1=NP1-1 IF (NMM1 .LE. 0) NMM1=1 NPP1=NP1+1 DO 1 NM1=NMM1,NPP1 NM=NM1-1 DO 1 NZ1=1,20 NZ=NZ1-1 L=L+1 IF (L .GT. 1200) GO TO 1 NT=NP+NM+NZ IF ((NT .LE. 0) .OR. (NT .GT. 60)) GO TO 1 PMUL(1,L)=PMLTPC(NP,NM,NZ,NT,B(2),C) ANORM(1,NT)=ANORM(1,NT)+PMUL(1,L) 1 CONTINUE C --- FOR N TARGET --- L=0 DO 2 NP1=1,20 NP=NP1-1 NMM1=NP1 NPP1=NP1+2 DO 2 NM1=NMM1,NPP1 NM=NM1-1 DO 2 NZ1=1,20 NZ=NZ1-1 L=L+1 IF (L .GT. 1200) GO TO 2 NT=NP+NM+NZ IF ((NT .LE. 0) .OR. (NT .GT. 60)) GO TO 2 PMUL(2,L)=PMLTPC(NP,NM,NZ,NT,B(1),C) ANORM(2,NT)=ANORM(2,NT)+PMUL(2,L) 2 CONTINUE C 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 C IF (.NOT. NPRT(10)) GO TO 10 C WRITE(NEWBCD,2001) 2001 FORMAT(' *CASXM* TABLES FOR MULT. DATA XI- INDUCED REACTION', $ ' FOR DEFINITION OF NUMBERS SEE FORTRAN CODING') DO 4 NFL=1,2 WRITE(NEWBCD,2002) NFL 2002 FORMAT(' *CASXM* TARGET PARTICLE FLAG',2X,I5) WRITE(NEWBCD,2003) (ANORM(NFL,I),I=1,60) WRITE(NEWBCD,2003) (PMUL(NFL,I),I=1,1200) 2003 FORMAT(1H ,10E12.4) 4 CONTINUE C C --- SELECT TARGET NUCLEON --- 10 CONTINUE 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(27) C C --- RESET STRANGENESS FIXING FLAG --- NVEFIX=0 C C *** ELASTIC SCATTERING *** NP=0 NM=0 NZ=0 N=0. IPA(1)=27 IPA(2)=14 IF (NFL .EQ. 2) IPA(2)=16 C IF (INT .EQ. 2) GO TO 20 C C *** INTRODUCE CHARGE AND STRANGENESS EXCHANGE REACTIONS *** 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)) GO TO 120 CALL GRNDM(RNDM,1) RAN=RNDM(1) IRN=IFIX(RAN*7.)+1 IF (NFL .EQ. 2) IRN=7+IFIX(RAN*5.)+1 IF (NFL .EQ. 1) IRN=MAX(IRN,7) IF (NFL .EQ. 2) IRN=MAX(IRN,12) IPA(1)=IIPA(IRN,1) IPA(2)=IIPA(IRN,2) GO TO 120 C C --- CHECK IF ENERGETICALLY POSSIBLE TO PRODUCE ONE EXTRA PION --- 20 CONTINUE IF (EAB .LE. RMASS(7)) GO TO 55 C C --- NO. OF TOTAL PARTICLES VS SQRT(S)-MP-MSM --- ALEAB=LOG(EAB) 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 C --- NORMALIZATION CONSTANT FOR KNO-DISTRIBUTION --- ANPN=0. DO 21 NT=1,60 TEST=-(PI/4.0)*(NT/N)**2 IF (TEST .LT. EXPXL) TEST=EXPXL IF (TEST .GT. EXPXU) TEST=EXPXU DUM1=PI*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 ANPN=ANPN+ADDNVE 21 CONTINUE ANPN=1./ANPN C C --- CHECK FOR TARGET NUCLEON TYPE --- CALL GRNDM(RNDM,1) RAN=RNDM(1) EXCS=0. GO TO (30,40),NFL C C --- PROTON TARGET --- 30 CONTINUE L=0 DO 31 NP1=1,20 NP=NP1-1 NMM1=NP1-1 IF (NMM1 .LE. 0) NMM1=1 NPP1=NP1+1 DO 31 NM1=NMM1,NPP1 NM=NM1-1 DO 31 NZ1=1,20 NZ=NZ1-1 L=L+1 IF (L .GT. 1200) GO TO 31 NT=NP+NM+NZ IF ((NT .LE. 0) .OR. (NT .GT. 60)) GO TO 31 TEST=-(PI/4.0)*(NT/N)**2 IF (TEST .LT. EXPXL) TEST=EXPXL IF (TEST .GT. EXPXU) TEST=EXPXU 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) GO TO 100 31 CONTINUE GO TO 80 C C --- NEUTRON TARGET --- 40 CONTINUE L=0 DO 41 NP1=1,20 NP=NP1-1 NMM1=NP1 NPP1=NP1+2 DO 41 NM1=NMM1,NPP1 NM=NM1-1 DO 41 NZ1=1,20 NZ=NZ1-1 L=L+1 IF (L .GT. 1200) GO TO 41 NT=NP+NM+NZ IF ((NT .LE. 0) .OR. (NT .GT. 60)) GO TO 41 TEST=-(PI/4.0)*(NT/N)**2 IF (TEST .LT. EXPXL) TEST=EXPXL IF (TEST .GT. EXPXU) TEST=EXPXU 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) GO TO 100 41 CONTINUE GO TO 80 C 50 CONTINUE IF (NPRT(4)) WRITE(NEWBCD,1003) EAB,N,NFL,NP,NM,NZ 1003 FORMAT(' *CASXM* XI- -INDUCED CASCADE,', $ ' AVAIL. ENERGY',2X,F8.4, $ 2X,'',2X,F8.4,2X,'FROM',4(2X,I3),2X,'PARTICLES') IF (INT .EQ. 1) CALL TWOB(27,NFL,N) IF (INT .EQ. 2) CALL GENXPT(27,NFL,N) GO TO 9999 C C *** ENERGETICALLY NOT POSSIBLE TO PRODUCE ONE EXTRA PION *** 55 CONTINUE IF (NPRT(4)) WRITE(NEWBCD,1001) 1001 FORMAT(' *CASXM* CASCADE ENERGETICALLY NOT POSSIBLE', $ ' CONTINUE WITH QUASI-ELASTIC SCATTERING') GO TO 53 C C *** EXCLUSIVE REACTION NOT FOUND *** 80 CONTINUE IF (NPRT(4)) WRITE(NEWBCD,1004) RS,N 1004 FORMAT(' *CASXM* XI- -INDUCED CASCADE,', $ ' EXCLUSIVE REACTION NOT FOUND', $ ' TRY ELASTIC SCATTERING AVAIL. ENERGY',2X,F8.4,2X, $ '',2X,F8.4) C 53 CONTINUE INT=1 NP=0 NM=0 NZ=0 IPA(1)=27 IPA(2)=14 IF (NFL .EQ. 2) IPA(2)=16 GO TO 120 C C *** INELASTIC INTERACTION HAS OCCURRED *** C *** NUMBER OF SECONDARY MESONS DETERMINED BY KNO DISTRIBUTION *** 100 CONTINUE DO 101 I=1,60 IPA(I)=0 101 CONTINUE C IF (INT .LE. 0) GO TO 131 C C --- TAKE TARGET NUCLEON TYPE INTO ACCOUNT --- GO TO (102,112),NFL C C --- PROTON TARGET --- 102 CONTINUE C --- CHECK FOR TOTAL CHARGE OF FINAL STATE MESONS TO DETERMINE --- C --- THE KIND OF BARYONS TO BE PRODUCED TAKING INTO ACCOUNT --- C --- CHARGE AND STRANGENESS CONSERVATION --- NCHT=NP-NM IF (NCHT .LT. 0) GO TO 103 IF (NCHT .EQ. 0) GO TO 104 IF (NCHT .GT. 0) GO TO 105 C 103 CONTINUE C --- XI0 P --- IPA(1)=26 IPA(2)=14 IF (NCHT .EQ. -1) GO TO 120 C --- CHARGE MISMATCH ==> TAKE A S+ AND CORRECT THE STRANGENESS --- C --- BY REPLACING A PI- BY K- --- C --- S+ P --- IPA(1)=20 IPA(2)=14 NVEFIX=1 GO TO 120 C 104 CONTINUE C --- XI- P --- IPA(1)=27 IPA(2)=14 CALL GRNDM(RNDM,1) IF (RNDM(1) .LT. 0.5) GO TO 120 C --- XI0 N --- IPA(1)=26 IPA(2)=16 GO TO 120 C 105 CONTINUE C --- XI- N --- IPA(1)=27 IPA(2)=16 GO TO 120 C C --- NEUTRON TARGET --- 112 CONTINUE C --- CHECK FOR TOTAL CHARGE OF FINAL STATE MESONS TO DETERMINE --- C --- THE KIND OF BARYONS TO BE PRODUCED TAKING INTO ACCOUNT --- C --- CHARGE AND STRANGENESS CONSERVATION --- NCHT=NP-NM IF (NCHT .LT. -1) GO TO 113 IF (NCHT .EQ. -1) GO TO 114 IF (NCHT .GT. -1) GO TO 115 C 113 CONTINUE C --- XI0 P --- IPA(1)=26 IPA(2)=14 IF (NCHT .EQ. -2) GO TO 120 C --- CHARGE MISMATCH ==> TAKE A S+ AND CORRECT THE STRANGENESS --- C --- BY REPLACING A PI- BY K- --- C --- S+ P --- IPA(1)=20 IPA(2)=14 NVEFIX=1 GO TO 120 C 114 CONTINUE C --- XI0 N --- IPA(1)=26 IPA(2)=16 CALL GRNDM(RNDM,1) IF (RNDM(1) .LT. 0.5) GO TO 120 C --- XI- P --- IPA(1)=27 IPA(2)=14 GO TO 120 C 115 CONTINUE C --- XI- N --- IPA(1)=27 IPA(2)=16 C C --- TAKE PIONS FOR ALL SECONDARY MESONS --- 120 CONTINUE NT=2 C IF (NP .EQ. 0) GO TO 122 C C --- PI+ --- DO 121 I=1,NP NT=NT+1 IPA(NT)=7 121 CONTINUE C 122 CONTINUE IF (NM .EQ. 0) GO TO 124 C C --- PI- --- DO 123 I=1,NM NT=NT+1 IPA(NT)=9 IF (NVEFIX .GE. 1) IPA(NT)=13 IF (NPRT(4) .AND. (NVEFIX .GE. 1)) PRINT 3000 3000 FORMAT(' *CASXM* K- INTRODUCED') NVEFIX=NVEFIX-1 123 CONTINUE C 124 CONTINUE IF (NZ .EQ. 0) GO TO 130 C C --- PI0 --- DO 125 I=1,NZ NT=NT+1 IPA(NT)=8 125 CONTINUE C C --- ALL SECONDARY PARTICLES HAVE BEEN DEFINED --- C --- NOW GO FOR MOMENTA AND X VALUES --- 130 CONTINUE IF (NPRT(4)) WRITE(NEWBCD,2004) NT,(IPA(I),I=1,60) 2004 FORMAT(' *CASXM* ',I3,' PARTICLES PRODUCED. MASS INDEX ARRAY : '/ $ 3(1H ,20(I3,1X)/)) GO TO 50 C 131 CONTINUE IF (NPRT(4)) WRITE(NEWBCD,2005) 2005 FORMAT(' *CASXM* NO PARTICLES PRODUCED') C 9999 CONTINUE RETURN END *CMZ : 19/07/94 16.37.49 by D. HECK IK3 KFK KARLSRUHE *-- Author : Nick van Eijndhoven (CERN) 02/02/89 C--------------------------------------------------------------------- SUBROUTINE CASX0(K,INT,NFL) C C *** CASCADE OF XI0 *** C *** NVE 20-JAN-1989 CERN GENEVA *** C C XI0 UNDERGOES INTERACTION WITH NUCLEON WITHIN NUCLEUS. C CHECK IF ENERGETICALLY POSSIBLE TO PRODUCE PIONS/KAONS. C IF NOT, ASSUME NUCLEAR EXCITATION OCCURS, DEGRADE INPUT PARTICLE C IN ENERGY AND NO OTHER PARTICLES ARE 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 PARAMETER (MXGKGH=100) COMMON/CONSTS/ PI,TWPI,PIBTW,MP,MPI,MMU,MEL,MKCH,MK0,SMP,SMPI, $ SMU,CT,CTKCH,CTK0, $ ML0,MSP,MS0,MSM,MX0,MXM,CTL0,CTSP,CTSM,CTX0,CTXM, $ RMASS(35),RCHARG(35) C REAL MP,MPI,MMU,MEL,MKCH,MK0, * ML0,MSP,MS0,MSM,MX0,MXM C PARAMETER (MXGKCU=MXGKGH) COMMON/CURPAR/WEIGHT(10),DDELTN,IFILE,IRUN,NEVT,NEVENT,SHFLAG, * ITHST,ITTOT,ITLST,IFRND,TOFCUT,CMOM(5),CENG(5), * RS,S,ENP(10),NP,NM,NN,NR,NO,NZ,IPA(MXGKCU), * ATNO2,ZNO2 C COMMON/RESULT/XEND,YEND,ZEND,RCA,RCE,AMAS,NCH,TOF,PX,PY,PZ, * USERW,INTCT,P,EN,EK,AMASQ,DELTN,ITK,NTK,IPART,IND, * LCALO,ICEL,SINL,COSL,SINP,COSP, * XOLD,YOLD,ZOLD,POLD,PXOLD,PYOLD,PZOLD, * XSCAT,YSCAT,ZSCAT,PSCAT,PXSCAT,PYSCAT,PZSCAT REAL NCH,INTCT C COMMON/PRNTFL/INBCD,NEWBCD,INBIN,NEWBIN,NPEVT,NEVTP,LPRT,NPRT(10) LOGICAL LPRT,NPRT C C --- INITIALIZATION FLAGS FOR VARIOUS GHEISHA ROUTINES --- COMMON /KGINIT/ KGINIT(50) C C --- BOUNDARY LIMITS FOR ARGUMENTS OF INTRINSIC FUNCTIONS --- C --- XL DENOTES LOWER BOUND WHEREAS XU DENOTES UPPER BOUND --- COMMON /LIMITS/ EXPXL,EXPXU C C REAL N DIMENSION PMUL(2,1200),ANORM(2,60),CECH(10),IIPA(12,2),B(2) DIMENSION RNDM(1) SAVE PMUL,ANORM SAVE DATA CECH/0.50,0.45,0.40,0.35,0.30,0.25,0.06,0.04,0.005,0./ C --- ARRAY IIPA DENOTES THE STRANGENESS AND CHARGE EXCHAGE REACTIONS --- C XI0 P --> S+ S0, XI0 P --> S0 S+ C XI0 P --> S+ L0, XI0 P --> L0 S+ C XI0 P --> P XI0 C XI0 N --> S0 S0 C XI0 N --> L0 L0 C XI0 N --> XI- P, XI0 N --> P XI- C XI0 N --> S+ S-, XI0 N --> S- S+ C XI0 N --> N XI0 DATA IIPA/20,21,20,18,14, 21,18,27,14,20,22,16, * 21,20,18,20,26, 21,18,14,27,22,20,26/ DATA B/0.7,0.7/,C/1.25/ C C --- INITIALIZATION INDICATED BY KGINIT(20) --- IF (KGINIT(20) .NE. 0) GO TO 10 KGINIT(20)=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 C --- FOR P TARGET --- L=0 DO 1 NP1=1,20 NP=NP1-1 NMM1=NP1-2 IF (NMM1 .LE. 0) NMM1=1 NPP1=NP1+1 DO 1 NM1=NMM1,NPP1 NM=NM1-1 DO 1 NZ1=1,20 NZ=NZ1-1 L=L+1 IF (L .GT. 1200) GO TO 1 NT=NP+NM+NZ IF ((NT .LE. 0) .OR. (NT .GT. 60)) GO TO 1 PMUL(1,L)=PMLTPC(NP,NM,NZ,NT,B(1),C) ANORM(1,NT)=ANORM(1,NT)+PMUL(1,L) 1 CONTINUE C --- FOR N TARGET --- L=0 DO 2 NP1=1,20 NP=NP1-1 NMM1=NP1-1 IF (NMM1 .LE. 0) NMM1=1 NPP1=NP1+2 DO 2 NM1=NMM1,NPP1 NM=NM1-1 DO 2 NZ1=1,20 NZ=NZ1-1 L=L+1 IF (L .GT. 1200) GO TO 2 NT=NP+NM+NZ IF ((NT .LE. 0) .OR. (NT .GT. 60)) GO TO 2 PMUL(2,L)=PMLTPC(NP,NM,NZ,NT,B(2),C) ANORM(2,NT)=ANORM(2,NT)+PMUL(2,L) 2 CONTINUE C 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 C IF (.NOT. NPRT(10)) GO TO 10 C WRITE(NEWBCD,2001) 2001 FORMAT(' *CASX0* TABLES FOR MULT. DATA XI0 INDUCED REACTION', $ ' FOR DEFINITION OF NUMBERS SEE FORTRAN CODING') DO 4 NFL=1,2 WRITE(NEWBCD,2002) NFL 2002 FORMAT(' *CASX0* TARGET PARTICLE FLAG',2X,I5) WRITE(NEWBCD,2003) (ANORM(NFL,I),I=1,60) WRITE(NEWBCD,2003) (PMUL(NFL,I),I=1,1200) 2003 FORMAT(1H ,10E12.4) 4 CONTINUE C C --- SELECT TARGET NUCLEON --- 10 CONTINUE 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(26) C C --- RESET STRANGENESS FIXING FLAG --- NVEFIX=0 C C *** ELASTIC SCATTERING *** NP=0 NM=0 NZ=0 N=0. IPA(1)=26 IPA(2)=14 IF (NFL .EQ. 2) IPA(2)=16 C IF (INT .EQ. 2) GO TO 20 C C *** INTRODUCE CHARGE AND STRANGENESS EXCHANGE REACTIONS *** 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)) GO TO 120 CALL GRNDM(RNDM,1) RAN=RNDM(1) IRN=IFIX(RAN*5.)+1 IF (NFL .EQ. 2) IRN=5+IFIX(RAN*7.)+1 IF (NFL .EQ. 1) IRN=MAX(IRN,5) IF (NFL .EQ. 2) IRN=MAX(IRN,12) IPA(1)=IIPA(IRN,1) IPA(2)=IIPA(IRN,2) GO TO 120 C C --- CHECK IF ENERGETICALLY POSSIBLE TO PRODUCE ONE EXTRA PION --- 20 CONTINUE IF (EAB .LE. RMASS(7)) GO TO 55 C C --- NO. OF TOTAL PARTICLES VS SQRT(S)-MP-MSM --- ALEAB=LOG(EAB) 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 C --- NORMALIZATION CONSTANT FOR KNO-DISTRIBUTION --- ANPN=0. DO 21 NT=1,60 TEST=-(PI/4.0)*(NT/N)**2 IF (TEST .LT. EXPXL) TEST=EXPXL IF (TEST .GT. EXPXU) TEST=EXPXU DUM1=PI*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 ANPN=ANPN+ADDNVE 21 CONTINUE ANPN=1./ANPN C C --- CHECK FOR TARGET NUCLEON TYPE --- CALL GRNDM(RNDM,1) RAN=RNDM(1) EXCS=0. GO TO (30,40),NFL C C --- PROTON TARGET --- 30 CONTINUE L=0 DO 31 NP1=1,20 NP=NP1-1 NMM1=NP1-2 IF (NMM1 .LE. 0) NMM1=1 NPP1=NP1+1 DO 31 NM1=NMM1,NPP1 NM=NM1-1 DO 31 NZ1=1,20 NZ=NZ1-1 L=L+1 IF (L .GT. 1200) GO TO 31 NT=NP+NM+NZ IF ((NT .LE. 0) .OR. (NT .GT. 60)) GO TO 31 TEST=-(PI/4.0)*(NT/N)**2 IF (TEST .LT. EXPXL) TEST=EXPXL IF (TEST .GT. EXPXU) TEST=EXPXU 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) GO TO 100 31 CONTINUE GO TO 80 C C --- NEUTRON TARGET --- 40 CONTINUE L=0 DO 41 NP1=1,20 NP=NP1-1 NMM1=NP1-1 IF (NMM1 .LE. 0) NMM1=1 NPP1=NP1+2 DO 41 NM1=NMM1,NPP1 NM=NM1-1 DO 41 NZ1=1,20 NZ=NZ1-1 L=L+1 IF (L .GT. 1200) GO TO 41 NT=NP+NM+NZ IF ((NT .LE. 0) .OR. (NT .GT. 60)) GO TO 41 TEST=-(PI/4.0)*(NT/N)**2 IF (TEST .LT. EXPXL) TEST=EXPXL IF (TEST .GT. EXPXU) TEST=EXPXU 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) GO TO 100 41 CONTINUE GO TO 80 C 50 CONTINUE IF (NPRT(4)) WRITE(NEWBCD,1003) EAB,N,NFL,NP,NM,NZ 1003 FORMAT(' *CASX0* XI0 -INDUCED CASCADE,', $ ' AVAIL. ENERGY',2X,F8.4, $ 2X,'',2X,F8.4,2X,'FROM',4(2X,I3),2X,'PARTICLES') IF (INT .EQ. 1) CALL TWOB(27,NFL,N) IF (INT .EQ. 2) CALL GENXPT(27,NFL,N) GO TO 9999 C C *** ENERGETICALLY NOT POSSIBLE TO PRODUCE ONE EXTRA PION *** 55 CONTINUE IF (NPRT(4)) WRITE(NEWBCD,1001) 1001 FORMAT(' *CASX0* CASCADE ENERGETICALLY NOT POSSIBLE', $ ' CONTINUE WITH QUASI-ELASTIC SCATTERING') GO TO 53 C C *** EXCLUSIVE REACTION NOT FOUND *** 80 CONTINUE IF (NPRT(4)) WRITE(NEWBCD,1004) RS,N 1004 FORMAT(' *CASX0* XI0 -INDUCED CASCADE,', $ ' EXCLUSIVE REACTION NOT FOUND', $ ' TRY ELASTIC SCATTERING AVAIL. ENERGY',2X,F8.4,2X, $ '',2X,F8.4) C 53 CONTINUE INT=1 NP=0 NM=0 NZ=0 IPA(1)=26 IPA(2)=14 IF (NFL .EQ. 2) IPA(2)=16 GO TO 120 C C *** INELASTIC INTERACTION HAS OCCURRED *** C *** NUMBER OF SECONDARY MESONS DETERMINED BY KNO DISTRIBUTION *** 100 CONTINUE DO 101 I=1,60 IPA(I)=0 101 CONTINUE C IF (INT .LE. 0) GO TO 131 C C --- TAKE TARGET NUCLEON TYPE INTO ACCOUNT --- GO TO (102,112),NFL C C --- PROTON TARGET --- 102 CONTINUE C --- CHECK FOR TOTAL CHARGE OF FINAL STATE MESONS TO DETERMINE --- C --- THE KIND OF BARYONS TO BE PRODUCED TAKING INTO ACCOUNT --- C --- CHARGE AND STRANGENESS CONSERVATION --- NCHT=NP-NM IF (NCHT .LT. 1) GO TO 103 IF (NCHT .EQ. 1) GO TO 104 IF (NCHT .GT. 1) GO TO 105 C 103 CONTINUE C --- XI0 P --- IPA(1)=26 IPA(2)=14 IF (NCHT .EQ. 0) GO TO 120 C --- CHARGE MISMATCH ==> TAKE A S+ AND CORRECT THE STRANGENESS --- C --- BY REPLACING A PI- BY K- --- C --- S+ P --- IPA(1)=20 IPA(2)=14 NVEFIX=1 GO TO 120 C 104 CONTINUE C --- XI0 N --- IPA(1)=26 IPA(2)=16 CALL GRNDM(RNDM,1) IF (RNDM(1) .LT. 0.5) GO TO 120 C --- XI- P --- IPA(1)=27 IPA(2)=14 GO TO 120 C 105 CONTINUE C --- XI- N --- IPA(1)=27 IPA(2)=16 GO TO 120 C C --- NEUTRON TARGET --- 112 CONTINUE C --- CHECK FOR TOTAL CHARGE OF FINAL STATE MESONS TO DETERMINE --- C --- THE KIND OF BARYONS TO BE PRODUCED TAKING INTO ACCOUNT --- C --- CHARGE AND STRANGENESS CONSERVATION --- NCHT=NP-NM IF (NCHT .LT. 0) GO TO 113 IF (NCHT .EQ. 0) GO TO 114 IF (NCHT .GT. 0) GO TO 115 C 113 CONTINUE C --- XI0 P --- IPA(1)=26 IPA(2)=14 IF (NCHT .EQ. -1) GO TO 120 C --- CHARGE MISMATCH ==> TAKE A S+ AND CORRECT THE STRANGENESS --- C --- BY REPLACING A PI- BY K- --- C --- S+ P --- IPA(1)=20 IPA(2)=14 NVEFIX=1 GO TO 120 C 114 CONTINUE C --- XI0 N --- IPA(1)=26 IPA(2)=16 CALL GRNDM(RNDM,1) IF (RNDM(1) .LT. 0.5) GO TO 120 C --- XI- P --- IPA(1)=27 IPA(2)=14 GO TO 120 C 115 CONTINUE C --- XI- N --- IPA(1)=27 IPA(2)=16 C C --- TAKE PIONS FOR ALL SECONDARY MESONS --- C --- REPLACE PI BY K IN CASE OF STRANGENESS TO BE FIXED --- 120 CONTINUE NT=2 C IF (NP .EQ. 0) GO TO 122 C C --- PI+ --- DO 121 I=1,NP NT=NT+1 IPA(NT)=7 121 CONTINUE C 122 CONTINUE IF (NM .EQ. 0) GO TO 124 C C --- PI- --- DO 123 I=1,NM NT=NT+1 IPA(NT)=9 IF (NVEFIX .GE. 1) IPA(NT)=13 IF (NPRT(4) .AND. (NVEFIX .GE. 1)) PRINT 3000 3000 FORMAT(' *CASX0* K- INTRODUCED') NVEFIX=NVEFIX-1 123 CONTINUE C 124 CONTINUE IF (NZ .EQ. 0) GO TO 130 C C --- PI0 --- DO 125 I=1,NZ NT=NT+1 IPA(NT)=8 125 CONTINUE C C --- ALL SECONDARY PARTICLES HAVE BEEN DEFINED --- C --- NOW GO FOR MOMENTA AND X VALUES --- 130 CONTINUE IF (NPRT(4)) WRITE(NEWBCD,2004) NT,(IPA(I),I=1,60) 2004 FORMAT(' *CASX0* ',I3,' PARTICLES PRODUCED. MASS INDEX ARRAY : '/ $ 3(1H ,20(I3,1X)/)) GO TO 50 C 131 CONTINUE IF (NPRT(4)) WRITE(NEWBCD,2005) 2005 FORMAT(' *CASX0* NO PARTICLES PRODUCED') C 9999 CONTINUE RETURN END *CMZU: 3.16/00 05/11/93 17.20.00 BY FEDERICO CARMINATI *-- AUTHOR : C--------------------------------------------------------------------- FUNCTION CINEMA(EK1) C C *** INELASTICITY IN NUCLEAR INTERACTIONS AS A FUNCTION *** C *** OF ATOMIC NUMBER ATNO2 AND KINETIC ENERGY EK1 *** C *** NVE 12-JUL-1988 CERN GENEVA *** C C ORIGIN : H.FESEFELDT (14-OCT-1987) C C THE FUNCTIONAL DEPENDENCE AND THE PARAMETERS HAVE BEEN OBTAINED C BY STUDY OF VARIOUS NUCLEAR STRUCTURE MODELS. C BUT: IT IS OF COURSE AN INTERPOLATION AS FUNCTION OF ATOMIC C NUMBER, FOR CERTAIN NUCLEI A DIFFERENT DESCRIPTION MAY BE C MORE ADEQUATE. DETAILED TESTS HAVE BEEN PERFORMED FOR C FE, CU, PB ,U AND SOME MIXTURES LIKE NAI, BGO, CONCRETE. C PARAMETER (MXGKGH=100) PARAMETER (MXGKCU=MXGKGH) COMMON/CURPAR/WEIGHT(10),DDELTN,IFILE,IRUN,NEVT,NEVENT,SHFLAG, * ITHST,ITTOT,ITLST,IFRND,TOFCUT,CMOM(5),CENG(5), * RS,S,ENP(10),NP,NM,NN,NR,NO,NZ,IPA(MXGKCU), * ATNO2,ZNO2 C COMMON/RESULT/XEND,YEND,ZEND,RCA,RCE,AMAS,NCH,TOF,PX,PY,PZ, * USERW,INTCT,P,EN,EK,AMASQ,DELTN,ITK,NTK,IPART,IND, * LCALO,ICEL,SINL,COSL,SINP,COSP, * XOLD,YOLD,ZOLD,POLD,PXOLD,PYOLD,PZOLD, * XSCAT,YSCAT,ZSCAT,PSCAT,PXSCAT,PYSCAT,PZSCAT REAL NCH,INTCT C COMMON/MAT / LMAT, * DEN(21),RADLTH(21),ATNO(21),ZNO(21),ABSL(21), * CDEN(21),MDEN(21),X0DEN(21),X1DEN(21),RION(21), * MATID(21),MATID1(21,24),PARMAT(21,10), * IFRAT,IFRAC(21),FRAC1(21,10),DEN1(21,10), * ATNO1(21,10),ZNO1(21,10) C C --- BOUNDARY LIMITS FOR ARGUMENTS OF INTRINSIC FUNCTIONS --- C --- XL DENOTES LOWER BOUND WHEREAS XU DENOTES UPPER BOUND --- COMMON /LIMITS/ EXPXL,EXPXU C SAVE C CINEMA=0.0 ND=IND+1 ALA=LOG(ATNO2) ALEK1=LOG(EK1) SIG1=0.50 SIG2=0.50 EM=0.2390+0.0408*ALA**2 IF (EM. GT. 1.0) EM=1.0 CINEM=0.0019*ALA**3 IF(CINEM.GT.0.15) CINEM=0.15 IF (PARMAT(ND,10) .GE. 0.01) CINEM=CINEM*PARMAT(ND,10) C IF (ALEK1 .GT. EM) GO TO 1 C CORR=-(ALEK1-EM)**2/(2.0*SIG1**2) IF (CORR .LT. EXPXL) CORR=EXPXL IF (CORR .GT. EXPXU) CORR=EXPXU DUM1=-EK1*CINEM DUM2=ABS(DUM1) DUM3=EXP(CORR) CINEMA=0.0 IF (DUM2 .GE. 1.0) CINEMA=DUM1*DUM3 IF ((DUM2 .LT. 1.0) .AND. (DUM3 .GT. 1.0E-10)) CINEMA=DUM1*DUM3 GO TO 2 C 1 CONTINUE CORR=-(ALEK1-EM)**2/(2.0*SIG2**2) IF (CORR .LT. EXPXL) CORR=EXPXL IF (CORR .GT. EXPXU) CORR=EXPXU DUM1=-EK1*CINEM DUM2=ABS(DUM1) DUM3=EXP(CORR) CINEMA=0.0 IF (DUM2 .GE. 1.0) CINEMA=DUM1*DUM3 IF ((DUM2 .LT. 1.0) .AND. (DUM3 .GT. 1.0E-10)) CINEMA=DUM1*DUM3 C 2 CONTINUE IF (CINEMA .LT. -EK1) CINEMA=-EK1 C RETURN END *CMZ : 3.16/00 05/11/93 18.12.42 BY FEDERICO CARMINATI *-- AUTHOR : C--------------------------------------------------------------------- SUBROUTINE COHERT(IPPP,NFL,AVERN) C C *** GENERATION OF X- AND PT- VALUES FOR ALL PRODUCED PARTICLES *** C C C GENERATION OF DIFFRACTION DISSOCIATION AT HIGH ENERGIES C (NOT USED IN STANDARD VERSION) C PARAMETER (MXGKGH=100) COMMON/CONSTS/ PI,TWPI,PIBTW,MP,MPI,MMU,MEL,MKCH,MK0,SMP,SMPI, $ SMU,CT,CTKCH,CTK0, $ ML0,MSP,MS0,MSM,MX0,MXM,CTL0,CTSP,CTSM,CTX0,CTXM, $ RMASS(35),RCHARG(35) C REAL MP,MPI,MMU,MEL,MKCH,MK0, * ML0,MSP,MS0,MSM,MX0,MXM C PARAMETER (MXGKCU=MXGKGH) COMMON/CURPAR/WEIGHT(10),DDELTN,IFILE,IRUN,NEVT,NEVENT,SHFLAG, * ITHST,ITTOT,ITLST,IFRND,TOFCUT,CMOM(5),CENG(5), * RS,S,ENP(10),NP,NM,NN,NR,NO,NZ,IPA(MXGKCU), * ATNO2,ZNO2 C COMMON/RESULT/XEND,YEND,ZEND,RCA,RCE,AMAS,NCH,TOF,PX,PY,PZ, * USERW,INTCT,P,EN,EK,AMASQ,DELTN,ITK,NTK,IPART,IND, * LCALO,ICEL,SINL,COSL,SINP,COSP, * XOLD,YOLD,ZOLD,POLD,PXOLD,PYOLD,PZOLD, * XSCAT,YSCAT,ZSCAT,PSCAT,PXSCAT,PYSCAT,PZSCAT REAL NCH,INTCT C COMMON/MAT / LMAT, * DEN(21),RADLTH(21),ATNO(21),ZNO(21),ABSL(21), * CDEN(21),MDEN(21),X0DEN(21),X1DEN(21),RION(21), * MATID(21),MATID1(21,24),PARMAT(21,10), * IFRAT,IFRAC(21),FRAC1(21,10),DEN1(21,10), * ATNO1(21,10),ZNO1(21,10) C PARAMETER (MXEVEN=12*MXGKGH) COMMON/EVENT / NSIZE,NCUR,NEXT,NTOT,EVE(MXEVEN) C COMMON/PRNTFL/INBCD,NEWBCD,INBIN,NEWBIN,NPEVT,NEVTP,LPRT,NPRT(10) LOGICAL LPRT,NPRT C COMMON/ERRCOM/ IER(100) C PARAMETER (MXGKPV=MXGKGH) COMMON /VECUTY/ PV(10,MXGKPV) C C COMMON/GENIN /TECM,AMASS(18),NPG,KGENEV COMMON/GENOUT/PCM(5,18),WGT C C REAL NUCSUP DIMENSION SIDE(200),C1PAR(5),G1PAR(5),NUCSUP(5) DIMENSION RNDM(3) SAVE DATA C1PAR/0.6,0.6,0.35,0.15,0.10/ DATA G1PAR/2.6,2.6,1.8,1.30,1.20/ DATA NUCSUP/1.0,0.8,0.6,0.5,0.4/ C DATA CB/3.0/ DATA CB/0.01/ C BPP(X)=5.000+0.300*LOG(X) C MX =MXGKPV-20 MX1=MX+1 MX2=MX+2 MX3=MX+3 MX4=MX+4 MX5=MX+5 MX6=MX+6 MX7=MX+7 MX8=MX+8 EK=ENP(5) EN=ENP(6) P=ENP(7) S=ENP(8) RS=ENP(9) CFA=0.025*((ATNO2-1.)/120.)*EXP(-(ATNO2-1.)/120.) IF(P.LT.0.001) GOTO 60 NT=0 C** IREHMF=4 IF(IABS(IPA(1)).NE.IPART) IREHMF=5 C** CHECK MASS-INDICES FOR ALL PARTICLES C** DO 1 I=1,100 IF(IPA(I).EQ.0) GOTO 1 NT=NT+1 IPA(NT)=IPA(I) 1 CONTINUE * CALL VZERO(IPA(NT+1),MXGKCU-NT) CDH DO III = NT+1, MXGKCU IPA(III) = 0 ENDDO C** C** SET THE EFFECTICE 4-MOMENTUM-VECTOR FOR INTERACTION C** PV( 1,MXGKPV-1)=P*PX PV( 2,MXGKPV-1)=P*PY PV( 3,MXGKPV-1)=P*PZ PV( 4,MXGKPV-1)=EN PV( 5,MXGKPV-1)=AMAS PV( 6,MXGKPV-1)=NCH PV( 7,MXGKPV-1)=TOF PV( 8,MXGKPV-1)=IPART PV( 9,MXGKPV-1)=0. PV(10,MXGKPV-1)=USERW IER(48)=IER(48)+1 C** C** DISTRIBUTE PARTICLES IN FORWARD AND BACKWARD HEMISPHERE OF CMS C** OF THE HADRON NUCLEON INTERACTION C** SIDE(1)= 1. SIDE(2)=-1. TARG=0. IFOR=1 IBACK=1 DO 3 I=1,NT IF (I .LE. 2) GO TO 78 SIDE(I)= -1. IF (SIDE(I) .LT. 0.) GO TO 76 C C --- PARTICLE IN FORWARD HEMISPHERE --- 77 CONTINUE IFOR=IFOR+1 IF (IFOR .LE. 18) GO TO 78 C C --- CHANGE IT TO BACKWARD --- SIDE(I)=-1. IFOR=IFOR-1 IBACK=IBACK+1 GO TO 78 C C --- PARTICLE IN BACKWARD HEMISPHERE --- 76 CONTINUE IBACK=IBACK+1 IF (IBACK .LE. 18) GO TO 78 C C --- CHANGE IT TO FORWARD --- SIDE(I)=1. IBACK=IBACK-1 IFOR=IFOR+1 C** C** SUPPRESSION OF CHARGED PIONS FOR VARIOUS REASONS C** 78 IF(IPART.EQ.15.OR.IPART.GE.17) GOTO 3 IF(ABS(IPA(I)).GE.10) GOTO 3 IF(ABS(IPA(I)).EQ. 8) GOTO 3 CALL GRNDM(RNDM,1) IF(RNDM(1).GT.(10.-P)/6.) GOTO 3 CALL GRNDM(RNDM,1) IF(RNDM(1).GT.ATNO2/300.) GOTO 3 IPA(I)=14 CALL GRNDM(RNDM,1) IF(RNDM(1).GT.ZNO2/ATNO2) IPA(I)=16 TARG=TARG+1. 3 CONTINUE TB=2.*IBACK CALL GRNDM(RNDM,1) IF(RS.LT.(2.0+RNDM(1))) TB=(2.*IBACK+NT)/2. C** C** NUCLEONS + SOME PIONS FROM INTRANUCLEAR CASCADE C** AFC=0.312+0.200*LOG(LOG(S)) XTARG=AFC*(ATNO2**0.33-1.0)*TB IF(XTARG.LE.0.) XTARG=0.01 CALL POISSO(XTARG,NTARG) NT2=NT+NTARG IF(NT2.LE.MXGKPV-30) GOTO 2 NT2=MXGKPV-30 NTARG=NT2-NT 2 CONTINUE IF(NPRT(4)) *WRITE(NEWBCD,3001) NTARG,NT NT1=NT+1 IF(NTARG.EQ.0) GOTO 51 IPX=IFIX(P/3.)+1 IF(IPX.GT.5) IPX=5 DO 4 I=NT1,NT2 CALL GRNDM(RNDM,1) RAN=RNDM(1) IF(RAN.LT.NUCSUP(IPX)) GOTO 52 CALL GRNDM(RNDM,1) IPA(I)=-(7+IFIX(RNDM(1)*3.0)) GOTO 4 52 IPA(I)=-16 PNRAT=1.-ZNO2/ATNO2 CALL GRNDM(RNDM,1) IF(RNDM(1).GT.PNRAT) IPA(I)=-14 TARG=TARG+1. 4 SIDE(I)=-2. NT=NT2 C** C** CHOOSE MASSES AND CHARGES FOR ALL PARTICLES C** 51 DO 5 I=1,NT IPA1=ABS(IPA(I)) PV(5,I)=RMASS(IPA1) PV(6,I)=RCHARG(IPA1) PV(7,I)=1. IF(PV(5,I).LT.0.) PV(7,I)=-1. PV(5,I)=ABS(PV(5,I)) 5 CONTINUE C** C** MARK LEADING STRANGE PARTICLES C** LEAD=0 IF(IPART.LT.10.OR.IPART.EQ.14.OR.IPART.EQ.16) GOTO 6 IPA1=ABS(IPA(1)) IF(IPA1.LT.10.OR.IPA1.EQ.14.OR.IPA1.EQ.16) GOTO 531 LEAD=IPA1 GOTO 6 531 IPA1=ABS(IPA(2)) IF(IPA1.LT.10.OR.IPA1.EQ.14.OR.IPA1.EQ.16) GOTO 6 LEAD=IPA1 C** C** CHECK AVAILABLE KINETIC ENERGY , CHANGE HEMISPHERE FOR PARTICLES C** UNTIL IT FITS C** 6 IF(NT.LE.1) GOTO 60 TAVAI=0. DO 7 I=1,NT IF(SIDE(I).LT.-1.5) GOTO 7 TAVAI=TAVAI+ABS(PV(5,I)) 7 CONTINUE CJOK MODIFIED ACCORDING TO D.HECK IF(TAVAI.LT.RS-0.00001) GOTO 12 IF(NPRT(4)) $ WRITE(NEWBCD,3002) (IPA(I),I=1,20),(SIDE(I),I=1,20),TAVAI,RS 3002 FORMAT(' *COHERT* CHECK AVAILABLE ENERGIES'/ $ 1H ,20I5/1H ,20F5.0/1H ,'TAVAI,RS ',2F10.3) DO 10 I=1,NT II=NT-I+1 IF(SIDE(II).LT.-1.5) GOTO 10 IF(II.EQ.NT) GOTO 11 NT1=II+1 NT2=NT DO 8 J=NT1,NT2 IPA(J-1)=IPA(J) SIDE(J-1)=SIDE(J) DO 8 K=1,10 8 PV(K,J-1)=PV(K,J) GOTO 11 10 CONTINUE 11 SIDE(NT)=0. IPA(NT)=0 NT=NT-1 GOTO 6 12 IF(NT.LE.1) GOTO 60 B=BPP(ATNO2) IF(B.LT.CB) B=CB C** C** CHOOSE MASSES FOR THE 3 CLUSTER: 1. FORWARD CLUSTER C** 2. BACKWARD MESON CLUSTER 3. BACKWARD NUCLEON CLUSTER C** RMC0=0. RMD0=0. RME0=0. NTC=0 NTD=0 NTE=0 DO 31 I=1,NT IF(SIDE(I).GT.0.) RMC0=RMC0+ABS(PV(5,I)) IF(SIDE(I).GT.0.) NTC =NTC +1 IF(SIDE(I).LT.0..AND.SIDE(I).GT.-1.5) RMD0=RMD0+ABS(PV(5,I)) IF( SIDE(I).LT.-1.5) RME0=RME0+ABS(PV(5,I)) IF(SIDE(I).LT.0..AND.SIDE(I).GT.-1.5) NTD =NTD +1 IF( SIDE(I).LT.-1.5) NTE =NTE +1 31 CONTINUE 32 CALL GRNDM(RNDM,1) RAN=RNDM(1) RMC=RMC0 IF(NTC.LE.1) GOTO 33 NTC1=NTC IF(NTC1.GT.5) NTC1=5 RMC=-LOG(1.-RAN) GPAR=G1PAR(NTC1) CPAR=C1PAR(NTC1) DUMNVE=GPAR IF (DUMNVE .EQ. 0.0) DUMNVE=1.0E-10 RMC=RMC0+RMC**CPAR/DUMNVE 33 RMD=RMD0 IF(NTD.LE.1) GOTO 34 NTD1=NTD IF(NTD1.GT.5) NTD1=5 CALL GRNDM(RNDM,1) RAN=RNDM(1) RMD=-LOG(1.-RAN) GPAR=G1PAR(NTD1) CPAR=C1PAR(NTD1) DUMNVE=GPAR IF (DUMNVE .EQ. 0.0) DUMNVE=1.0E-10 RMD=RMD0+RMD**CPAR/DUMNVE 34 IF(RMC+RMD.LT.RS) GOTO 35 IF (RMC.LE.RMC0.AND.RMD.LE.RMD0) THEN HNRMDC = 0.999*RS/(RMC+RMD) RMD = RMD*HNRMDC RMC = RMC*HNRMDC ELSE RMC=0.1*RMC0+0.9*RMC RMD=0.1*RMD0+0.9*RMD ENDIF GOTO 34 35 IF(NTE.LE.0) GOTO 38 RME=RME0 IF(NTE.EQ.1) GOTO 38 NTE1=NTE IF(NTE1.GT.5) NTE1=5 CALL GRNDM(RNDM,1) RAN=RNDM(1) RME=-LOG(1.-RAN) GPAR=G1PAR(NTE1) CPAR=C1PAR(NTE1) DUMNVE=GPAR IF (DUMNVE .EQ. 0.0) DUMNVE=1.0E-10 RME=RME0+RME**CPAR/DUMNVE C** C** SET BEAM , TARGET OF FIRST INTERACTION IN CMS C** 38 PV(1,MX1)=0. PV(2,MX1)=0. PV(3,MX1)=P PV(5,MX1)=ABS(AMAS) PV(4,MX1)=SQRT(P*P+AMAS*AMAS) PV(1,MX2)=0. PV(2,MX2)=0. PV(3,MX2)=0. PV(4,MX2)=MP PV(5,MX2)=MP C** TRANSFORM INTO CMS. CALL ADD(MX1,MX2,MX ) CALL LOR(MX1,MX ,MX1) CALL LOR(MX2,MX ,MX2) PF=(S+RMD*RMD-RMC*RMC)**2 - 4*S*RMD*RMD IF(PF.LT.0.0001) PF=0.0001 DUMNVE=2.0*RS IF (DUMNVE .EQ. 0.0) DUMNVE=1.0E-10 PF=SQRT(PF)/DUMNVE IF(NPRT(4)) WRITE(6,2002) PF,RMC,RMD,RS C** C** SET FINAL STATE MASSES AND ENERGIES IN CMS C** PV(5,MX3)=RMC PV(5,MX4)=RMD PV(4,MX3)=SQRT(PF*PF+PV(5,MX3)*PV(5,MX3)) PV(4,MX4)=SQRT(PF*PF+PV(5,MX4)*PV(5,MX4)) C** C** SET |T| AND |TMIN| C** T=-1.0E10 CALL GRNDM(RNDM,1) IF (B .NE. 0.0) T=LOG(1.-RNDM(1))/B CALL LENGTX(MX1,PIN) TACMIN=(PV(4,MX1)-PV(4,MX3))**2-(PIN-PF)**2 C** C** CACULATE (SIN(TETA/2.)**2 AND COS(TETA), SET AZIMUTH ANGLE PHI C** DUMNVE=4.0*PIN*PF IF (DUMNVE .EQ. 0.0) DUMNVE=1.0E-10 CTET=-(T-TACMIN)/DUMNVE CTET=1.0-2.0*CTET IF (CTET .GT. 1.0) CTET=1.0 IF (CTET .LT. -1.0) CTET=-1.0 DUMNVE=1.0-CTET*CTET IF (DUMNVE .LT. 0.0) DUMNVE=0.0 STET=SQRT(DUMNVE) CALL GRNDM(RNDM,1) PHI=RNDM(1)*TWPI C** C** CALCULATE FINAL STATE MOMENTA IN CMS C** PV(1,MX3)=PF*STET*SIN(PHI) PV(2,MX3)=PF*STET*COS(PHI) PV(3,MX3)=PF*CTET PV(1,MX4)=-PV(1,MX3) PV(2,MX4)=-PV(2,MX3) PV(3,MX4)=-PV(3,MX3) C** C** SIMULATE BACKWARD NUCLEON CLUSTER IN LAB. SYSTEM AND TRANSFORM IN C** CMS. C** IF(NTE.EQ.0) GOTO 28 GA=1.2 EKIT1=0.04 EKIT2=0.6 IF(EK.GT.5.) GOTO 666 EKIT1=EKIT1*EK**2/25. EKIT2=EKIT2*EK**2/25. 666 A=(1.-GA)/(EKIT2**(1.-GA)-EKIT1**(1.-GA)) DO 29 I=1,NT IF(SIDE(I).GT.-1.5) GOTO 29 CALL GRNDM(RNDM,3) RAN=RNDM(1) EKIT=(RAN*(1.-GA)/A+EKIT1**(1.-GA))**(1./(1.-GA)) PV(4,I)=EKIT+PV(5,I) DUMNVE=ABS(PV(4,I)**2-PV(5,I)**2) PP=SQRT(DUMNVE) RAN=RNDM(2) COST=LOG(2.23*RAN+0.383)/0.96 IF (COST .LT. -1.0) COST=-1.0 IF (COST .GT. 1.0) COST=1.0 DUMNVE=1.0-COST*COST IF (DUMNVE .LT. 0.0) DUMNVE=0.0 SINT=SQRT(DUMNVE) PHI=TWPI*RNDM(3) PV(1,I)=PP*SINT*SIN(PHI) PV(2,I)=PP*SINT*COS(PHI) PV(3,I)=PP*COST CALL LOR(I,MX ,I) 29 CONTINUE C** C** FRAGMENTATION OF FORWARD CLUSTER AND BACKWARD MESON CLUSTER C** 28 PV(1,1)=PV(1,MX3) PV(2,1)=PV(2,MX3) PV(3,1)=PV(3,MX3) PV(4,1)=PV(4,MX3) PV(1,2)=PV(1,MX4) PV(2,2)=PV(2,MX4) PV(3,2)=PV(3,MX4) PV(4,2)=PV(4,MX4) DO 17 I=MX5,MX6 DO 16 J=1,3 16 PV(J,I)=-PV(J,I-2) DO 17 J=4,5 17 PV(J,I)= PV(J,I-2) KGENEV=1 IF(NTC.LE.1) GOTO 26 TECM= PV(5,MX3) NPG=0 DO 18 I=1,NT IF(SIDE(I).LT.0.) GOTO 18 NPG=NPG+1 AMASS(NPG)=ABS(PV(5,I)) 18 CONTINUE IF(NPRT(4)) WRITE(NEWBCD,2004) TECM,NPG,(AMASS(I),I=1,NPG) CALL PHASP NPG=0 DO 19 I=1,NT IF(SIDE(I).LT.0.) GOTO 19 NPG=NPG+1 PV(1,I)=PCM(1,NPG) PV(2,I)=PCM(2,NPG) PV(3,I)=PCM(3,NPG) PV(4,I)=PCM(4,NPG) IF(NPRT(4)) WRITE(NEWBCD,2001) I,(PV(J,I),J=1,5) CALL LOR(I,MX5,I) IF(NPRT(4)) WRITE(NEWBCD,2001) I,(PV(J,I),J=1,10),IPA(I),SIDE(I) 19 CONTINUE 26 IF(NTD.LE.1) GOTO 27 TECM= PV(5,MX4) NPG=0 DO 20 I=1,NT IF(SIDE(I).GT.0..OR.SIDE(I).LT.-1.5) GOTO 20 NPG=NPG+1 AMASS(NPG)=ABS(PV(5,I)) 20 CONTINUE IF(NPRT(4)) WRITE(NEWBCD,2004) TECM,NPG,(AMASS(I),I=1,NPG) CALL PHASP NPG=0 DO 21 I=1,NT IF(SIDE(I).GT.0..OR.SIDE(I).LT.-1.5) GOTO 21 NPG=NPG+1 PV(1,I)=PCM(1,NPG) PV(2,I)=PCM(2,NPG) PV(3,I)=PCM(3,NPG) PV(4,I)=PCM(4,NPG) IF(NPRT(4)) WRITE(NEWBCD,2001) I,(PV(J,I),J=1,5) CALL LOR(I,MX6,I) IF(NPRT(4)) WRITE(NEWBCD,2001) I,(PV(J,I),J=1,10),IPA(I),SIDE(I) 21 CONTINUE C** C** LORENTZ TRANSFORMATION IN LAB SYSTEM C** 27 TARG=0. DO 36 I=1,NT IF(PV(5,I).GT.0.5) TARG=TARG+1. CALL LOR(I,MX2,I) 36 CONTINUE IF(TARG.LT.0.5) TARG=1. C** C** SOMETIMES THE LEADING STRANGE PARTICLES ARE LOST , SET THEM BACK C** IF(LEAD.EQ.0) GOTO 6085 DO 6081 I=1,NT IF(ABS(IPA(I)).EQ.LEAD) GOTO 6085 6081 CONTINUE I=1 IF(LEAD.GE.14.AND.ABS(IPA(2)).GE.14) I=2 IF(LEAD.LT.14.AND.ABS(IPA(2)).LT.14) I=2 IPA(I)=LEAD EKIN=PV(4,I)-ABS(PV(5,I)) PV(5,I)=RMASS(LEAD) PV(7,I)=1. IF(PV(5,I).LT.0.) PV(7,I)=-1. PV(5,I)=ABS(PV(5,I)) PV(6,I)=RCHARG(LEAD) PV(4,I)=PV(5,I)+EKIN CALL LENGTX(I,PP) DUMNVE=ABS(PV(4,I)**2-PV(5,I)**2) PP1=SQRT(DUMNVE) C IF (PP .GE. 1.0E-6) GO TO 8000 CALL GRNDM(RNDM,2) RTHNVE=PI*RNDM(1) PHINVE=TWPI*RNDM(2) PV(1,I)=PP1*SIN(RTHNVE)*COS(PHINVE) PV(2,I)=PP1*SIN(RTHNVE)*SIN(PHINVE) PV(3,I)=PP1*COS(RTHNVE) GO TO 8001 8000 CONTINUE PV(1,I)=PV(1,I)*PP1/PP PV(2,I)=PV(2,I)*PP1/PP PV(3,I)=PV(3,I)*PP1/PP 8001 CONTINUE C C** FOR VARIOUS REASONS, THE ENERGY BALANCE IS NOT SUFFICIENT, C** CHECK THAT, ENERGY BALANCE, ANGLE OF FINAL SYSTEM E.T.C. 6085 KGENEV=1 PV(1,MX4)=0. PV(2,MX4)=0. PV(3,MX4)=P PV(4,MX4)=SQRT(P*P+AMAS*AMAS) PV(5,MX4)=ABS(AMAS) EKIN0=PV(4,MX4)-PV(5,MX4) PV(1,MX5)=0. PV(2,MX5)=0. PV(3,MX5)=0. PV(4,MX5)=MP*TARG PV(5,MX5)=PV(4,MX5) EKIN=PV(4,MX4)+PV(4,MX5) I=MX4 IF(NPRT(4)) WRITE(NEWBCD,2001) I,(PV(J,I),J=1,5) I=MX5 IF(NPRT(4)) WRITE(NEWBCD,2001) I,(PV(J,I),J=1,5) CALL ADD(MX4,MX5,MX6) CALL LOR(MX4,MX6,MX4) CALL LOR(MX5,MX6,MX5) TECM=PV(4,MX4)+PV(4,MX5) NPG=NT PV(1,MX8)=0. PV(2,MX8)=0. PV(3,MX8)=0. PV(4,MX8)=0. PV(5,MX8)=0. EKIN1=0. DO 598 I=1,NPG IF(NPRT(4)) WRITE(NEWBCD,2001) I,(PV(J,I),J=1,10),IPA(I),SIDE(I) CALL ADD(MX8,I,MX8) EKIN1=EKIN1+PV(4,I)-PV(5,I) EKIN=EKIN-PV(5,I) IF(I.GT.18) GOTO 598 AMASS(I)=PV(5,I) 598 CONTINUE IF(NPG.GT.18) GOTO 597 CALL PHASP EKIN=0. DO 599 I=1,NPG PV(1,MX7)=PCM(1,I) PV(2,MX7)=PCM(2,I) PV(3,MX7)=PCM(3,I) PV(4,MX7)=PCM(4,I) PV(5,MX7)=AMASS(I) CALL LOR(MX7,MX5,MX7) 599 EKIN=EKIN+PV(4,MX7)-PV(5,MX7) CALL ANG(MX8,MX4,COST,TETA) IF(NPRT(4)) WRITE(NEWBCD,2003) TETA,EKIN0,EKIN1,EKIN C** C** MAKE SHURE, THAT KINETIC ENERGIES ARE CORRECT C** THE 3. CLUSTER IS NOT PRODUCED WITHIN PROPER KINEMATICS!!! C** EKIN= KINETIC ENERGY THEORETICALLY C** EKIN1= KINETIC ENERGY SIMULATED C** 597 EKIN1=0. IF(EKIN1.EQ.0.) GOTO 600 PV(1,MX7)=0. PV(2,MX7)=0. PV(3,MX7)=0. PV(4,MX7)=0. PV(5,MX7)=0. WGT=EKIN/EKIN1 EKIN1=0. DO 602 I=1,NT EKIN=PV(4,I)-PV(5,I) EKIN=EKIN*WGT PV(4,I)=EKIN+PV(5,I) DUMNVE=ABS(PV(4,I)**2-PV(5,I)**2) PP=SQRT(DUMNVE) CALL LENGTX(I,PP1) C IF (PP1 .GE. 1.0E-6) GO TO 8002 CALL GRNDM(RNDM,2) RTHNVE=PI*RNDM(1) PHINVE=TWPI*RNDM(2) PV(1,I)=PP*SIN(RTHNVE)*COS(PHINVE) PV(2,I)=PP*SIN(RTHNVE)*SIN(PHINVE) PV(3,I)=PP*COS(RTHNVE) GO TO 8003 8002 CONTINUE PV(1,I)=PV(1,I)*PP/PP1 PV(2,I)=PV(2,I)*PP/PP1 PV(3,I)=PV(3,I)*PP/PP1 8003 CONTINUE C EKIN1=EKIN1+EKIN CALL ADD(MX7,I,MX7) 602 CONTINUE CALL ANG(MX7,MX4,COST,TETA) IF(NPRT(4)) WRITE(NEWBCD,2003) TETA,EKIN0,EKIN1 C** C** ROTATE IN DIRECTION OF Z-AXIS, SEE COMMENTS IN 'GENXPT' C** 600 PV(1,MX7)=0. PV(2,MX7)=0. PV(3,MX7)=0. PV(4,MX7)=0. PV(5,MX7)=0. DO 596 I=1,NT CALL ADD(MX7,I,MX7) 596 CONTINUE * CALL RANNOR(RAN1,RAN2) CALL GRNDM(RNDM,2) RY=RNDM(1) RZ=RNDM(2) RX=6.283185*RZ A1=SQRT(-2.*LOG(RY)) RAN1=A1*SIN(RX) RAN2=A1*COS(RX) PV(1,MX7)=PV(1,MX7)+RAN1*0.020*TARG PV(2,MX7)=PV(2,MX7)+RAN2*0.020*TARG CALL DEFS(MX4,MX7,MX8) PV(1,MX7)=0. PV(2,MX7)=0. PV(3,MX7)=0. PV(4,MX7)=0. PV(5,MX7)=0. C DO 595 I=1,NT C CALL TRAC(I,MX8,I) C 595 CALL ADD(MX7,I,MX7) C CALL ANG(MX7,MX4,COST,TETA) IF(NPRT(4)) WRITE(NEWBCD,2003) TETA C** C** ROTATE IN DIRECTION OF PRIMARY PARTICLE C** DEKIN=0. NPIONS=0 EK1=0. DO 25 I=1,NT CALL DEFS1(I,MXGKPV-1,I) IF(NPRT(4)) WRITE(NEWBCD,2001) I,(PV(J,I),J=1,10),IPA(I),SIDE(I) IF(ATNO2.LT.1.5) GOTO 25 CALL LENGTX(I,PP) EKIN=PV(4,I)-ABS(PV(5,I)) CALL NORMAL(RAN) EKIN=EKIN-CFA*(1.+0.5*RAN) IF (EKIN .LT. 1.0E-6) EKIN=1.0E-6 CALL STEEQ(XXH,I) DEKIN=DEKIN+EKIN*(1.-XXH) EKIN=EKIN*XXH IF(ABS(IPA(I)).GE.7.AND.ABS(IPA(I)).LE.9) NPIONS=NPIONS+1 IF(ABS(IPA(I)).GE.7.AND.ABS(IPA(I)).LE.9) EK1=EK1+EKIN PP1=SQRT(EKIN*(EKIN+2.*ABS(PV(5,I)))) PV(4,I)=EKIN+ABS(PV(5,I)) C IF (PP .GE. 1.0E-6) GO TO 8004 CALL GRNDM(RNDM,2) RTHNVE=PI*RNDM(1) PHINVE=TWPI*RNDM(2) PV(1,I)=PP1*SIN(RTHNVE)*COS(PHINVE) PV(2,I)=PP1*SIN(RTHNVE)*SIN(PHINVE) PV(3,I)=PP1*COS(RTHNVE) GO TO 8005 8004 CONTINUE PV(1,I)=PV(1,I)*PP1/PP PV(2,I)=PV(2,I)*PP1/PP PV(3,I)=PV(3,I)*PP1/PP 8005 CONTINUE C 25 CONTINUE EK1=0. IF(EK1.EQ.0.) GOTO 23 IF(NPIONS.LE.0) GOTO 23 DEKIN=1.+DEKIN/EK1 DO 22 I=1,NT IF(ABS(IPA(I)).LT.7.OR.ABS(IPA(I)).GT.9) GOTO 22 CALL LENGTX(I,PP) EKIN=PV(4,I)-ABS(PV(5,I)) EKIN=EKIN*DEKIN IF (EKIN .LT. 1.0E-6) EKIN=1.0E-6 PP1=SQRT(EKIN*(EKIN+2.*ABS(PV(5,I)))) PV(4,I)=EKIN+ABS(PV(5,I)) C IF (PP .GE. 1.0E-6) GO TO 8006 CALL GRNDM(RNDM,2) RTHNVE=PI*RNDM(1) PHINVE=TWPI*RNDM(2) PV(1,I)=PP1*SIN(RTHNVE)*COS(PHINVE) PV(2,I)=PP1*SIN(RTHNVE)*SIN(PHINVE) PV(3,I)=PP1*COS(RTHNVE) GO TO 8007 8006 CONTINUE PV(1,I)=PV(1,I)*PP1/PP PV(2,I)=PV(2,I)*PP1/PP PV(3,I)=PV(3,I)*PP1/PP 8007 CONTINUE C 22 CONTINUE 23 IGEN=0 IF(ATNO2.LT.1.5) GOTO 40 C** C** ADD BLACK TRACK PARTICLES C** CALL HIGHAB(SPROB) TEX=ENP(1) SPALL=TARG IF(TEX.LT.0.001) GOTO 445 BLACK=(1.5+1.25*TARG)*ENP(1)/(ENP(1)+ENP(3)) CALL POISSO(BLACK,NBL) IF(NPRT(4)) *WRITE(NEWBCD,3003) NBL,TEX IF(IFIX(TARG)+NBL.GT.ATNO2) NBL=ATNO2-TARG IF(NT+NBL.GT.MXGKPV-2) NBL=MXGKPV-2-NT IF(NBL.LE.0) GOTO 445 EKIN=TEX/NBL EKIN2=0. CALL STEEP(XX) DO 441 I=1,NBL CALL GRNDM(RNDM,1) IF(RNDM(1).LT.SPROB) GOTO 441 IF(NT.EQ.MXGKPV-2) GOTO 441 IF(EKIN2.GT.TEX) GOTO 443 CALL GRNDM(RNDM,1) RAN1=RNDM(1) CALL NORMAL(RAN2) EKIN1=-EKIN*LOG(RAN1)-CFA*(1.+0.5*RAN2) IF(EKIN1.LT.0.0) EKIN1=-0.010*LOG(RAN1) EKIN1=EKIN1*XX EKIN2=EKIN2+EKIN1 IF(EKIN2.GT.TEX) EKIN1=TEX-(EKIN2-EKIN1) IF (EKIN1 .LT. 0.0) EKIN1=1.0E-6 IPA1=16 PNRAT=1.-ZNO2/ATNO2 CALL GRNDM(RNDM,3) IF(RNDM(1).GT.PNRAT) IPA1=14 NT=NT+1 SPALL=SPALL+1. COST=-1.0+RNDM(2)*2.0 DUMNVE=1.0-COST*COST IF (DUMNVE .LT. 0.0) DUMNVE=0.0 SINT=SQRT(DUMNVE) PHI=TWPI*RNDM(3) IPA(NT)=-IPA1 SIDE(NT)=-4. PV(5,NT)=ABS(RMASS(IPA1)) PV(6,NT)=RCHARG(IPA1) PV(7,NT)=1. PV(4,NT)=EKIN1+PV(5,NT) DUMNVE=ABS(PV(4,NT)**2-PV(5,NT)**2) PP=SQRT(DUMNVE) PV(1,NT)=PP*SINT*SIN(PHI) PV(2,NT)=PP*SINT*COS(PHI) PV(3,NT)=PP*COST 441 CONTINUE 443 IF(ATNO2.LT.10.) GOTO 445 IF(EK.GT.2.0) GOTO 445 II=NT+1 KK=0 EKA=EK IF(EKA.GT.1.) EKA=EKA*EKA IF(EKA.LT.0.1) EKA=0.1 IKA=3.6*EXP((ZNO2**2/ATNO2-35.56)/6.45)/EKA IF(IKA.LE.0) GO TO 445 DO 444 I=1,NT II=II-1 IF(IPA(II).NE.-14) GOTO 444 IPA(II)=-16 IPA1 = 16 PV(5,II)=ABS(RMASS(IPA1)) PV(6,II)=RCHARG(IPA1) KK=KK+1 IF(KK.GT.IKA) GOTO 445 444 CONTINUE 445 TEX=ENP(3) IF(TEX.LT.0.001) GOTO 40 BLACK=(1.5+1.25*TARG)*ENP(3)/(ENP(1)+ENP(3)) CALL POISSO(BLACK,NBL) IF(NT+NBL.GT.MXGKPV-2) NBL=MXGKPV-2-NT IF(NBL.LE.0) GOTO 40 EKIN=TEX/NBL EKIN2=0. CALL STEEP(XX) IF(NPRT(4)) *WRITE(NEWBCD,3004) NBL,TEX DO 442 I=1,NBL CALL GRNDM(RNDM,1) IF(RNDM(1).LT.SPROB) GOTO 442 IF(NT.EQ.MXGKPV-2) GOTO 442 IF(EKIN2.GT.TEX) GOTO 40 CALL GRNDM(RNDM,1) RAN1=RNDM(1) CALL NORMAL(RAN2) EKIN1=-EKIN*LOG(RAN1)-CFA*(1.+0.5*RAN2) IF(EKIN1.LT.0.0) EKIN1=-0.005*LOG(RAN1) EKIN1=EKIN1*XX EKIN2=EKIN2+EKIN1 IF(EKIN2.GT.TEX) EKIN1=TEX-(EKIN2-EKIN1) IF (EKIN1 .LT. 0.0) EKIN1=1.0E-6 CALL GRNDM(RNDM,3) COST=-1.0+RNDM(1)*2.0 DUMNVE=1.0-COST*COST IF (DUMNVE .LT. 0.0) DUMNVE=0.0 SINT=SQRT(DUMNVE) PHI=TWPI*RNDM(2) RAN=RNDM(3) IPA(NT+1)=-30 IF(RAN.GT.0.60) IPA(NT+1)=-31 IF(RAN.GT.0.90) IPA(NT+1)=-32 SIDE(NT+1)=-4. PV(5,NT+1)=(ABS(IPA(NT+1))-28)*MP SPALL=SPALL+PV(5,NT+1)*1.066 IF(SPALL.GT.ATNO2) GOTO 40 NT=NT+1 PV(6,NT)=1. IF(IPA(NT).EQ.-32) PV(6,NT)=2. PV(7,NT)=1. PV(4,NT)=PV(5,NT)+EKIN1 DUMNVE=ABS(PV(4,NT)**2-PV(5,NT)**2) PP=SQRT(DUMNVE) PV(1,NT)=PP*SINT*SIN(PHI) PV(2,NT)=PP*SINT*COS(PHI) PV(3,NT)=PP*COST 442 CONTINUE C** C** STORE ON EVENT COMMON C** 40 CALL GRNDM(RNDM,1) IF(RS.GT.(4.+RNDM(1)*1.)) GOTO 42 DO 41 I=1,NT CALL LENGTX(I,ETB) IF(ETB.LT.P) GOTO 41 ETF=P PV(4,I)=SQRT(PV(5,I)**2+ETF**2) DUMNVE=ETB IF (DUMNVE .EQ. 0.0) DUMNVE=1.0E-10 ETF=ETF/DUMNVE PV(1,I)=PV(1,I)*ETF PV(2,I)=PV(2,I)*ETF PV(3,I)=PV(3,I)*ETF 41 CONTINUE 42 EKIN=PV(4,MXGKPV)-ABS(PV(5,MXGKPV)) EKIN1=PV(4,MXGKPV-1)-ABS(PV(5,MXGKPV-1)) EKIN2=0. CALL TDELAY(TOF1) CALL GRNDM(RNDM,1) RAN=RNDM(1) TOF=TOF-TOF1*LOG(RAN) DO 44 I=1,NT EKIN2=EKIN2+PV(4,I)-ABS(PV(5,I)) IF(PV(7,I).LT.0.) PV(5,I)=-PV(5,I) PV(7,I)=TOF PV(8,I)=ABS(IPA(I)) PV(9,I)=0. 44 PV(10,I)=0. IF(NPRT(4)) WRITE(NEWBCD,2006) NT,EKIN,ENP(1),ENP(3),EKIN1,EKIN2 INTCT=INTCT+1. NMODE=3 IF(SPALL.LT.0.5.AND.ATNO2.GT.1.5) NMODE=14 CALL SETCUR(NT) NTK=NTK+1 IF(NT.EQ.1) GOTO 300 DO 50 II=2,NT I=II-1 IF(NTOT.LT.NSIZE/12) GOTO 43 GO TO 9999 43 CALL SETTRK(I) 50 CONTINUE 300 CONTINUE GO TO 9999 C** C** IT IS NOT POSSIBLE TO PRODUCE A PROPER TWO CLUSTER FINAL STATE. C** CONTINUE WITH QUASI ELASTIC SCATTERING C** 60 IF(NPRT(4)) WRITE(NEWBCD,2005) DO 61 I=3,MXGKCU 61 IPA(I)=0 IPA(1)=IPART IPA(2)=14 IF(NFL.EQ.2) IPA(2)=16 CALL TWOB(IPPP,NFL,AVERN) GO TO 9999 C 2000 FORMAT(' *COHERT* CMS PARAMETERS OF FINAL STATE PARTICLES', $ ' AFTER ',I3,' TRIALS') 2001 FORMAT(' *COHERT* TRACK',2X,I3,2X,10F8.2,2X,I3,2X,F3.0) 2002 FORMAT(' *COHERT* MOMENTUM ',F8.3,' MASSES ',2F8.4,' RS ',F8.4) 2003 FORMAT(' *COHERT* TETA,EKIN0,EKIN1,EKIN ',4F10.4) 2004 FORMAT(' *COHERT* TECM,NPB,MASSES: ',F10.4,1X,I3,1X,8F10.4/ $ 1H ,26X,15X,8F10.4) 2005 FORMAT(' *COHERT* NUMBER OF FINAL STATE PARTICLES', $ ' LESS THAN 2 ==> CONTINUE WITH 2-BODY SCATTERING') 2006 FORMAT(' *COHERT* COMP.',1X,I5,1X,5F7.2) 3001 FORMAT(' *COHERT* NUCLEAR EXCITATION ',I5,' PARTICLES PRODUCED', $ ' IN ADDITION TO',I5,' NORMAL PARTICLES') 3003 FORMAT(' *COHERT* ',I3,' BLACK TRACK PARTICLES PRODUCED', $ ' WITH TOTAL KINETIC ENERGY OF ',F8.3,' GEV') 3004 FORMAT(' *COHERT* ',I5,' HEAVY FRAGMENTS WITH TOTAL ENERGY OF ', $ F8.4,' GEV') C 9999 CONTINUE RETURN END *CMZ : 3.14/16 06/05/91 22.27.48 BY FEDERICO CARMINATI *-- AUTHOR : C--------------------------------------------------------------------- SUBROUTINE CORANH(NIHIL,NFL) C C *** NUCLEAR INTERACTIONS FOR HEAVY FRAGMENTS *** C *** NVE 06-MAY-1988 CERN GENEVA *** C C ORIGIN : H.FESEFELDT (09-JULY-1987) C PARAMETER (MXGKGH=100) COMMON/CONSTS/ PI,TWPI,PIBTW,MP,MPI,MMU,MEL,MKCH,MK0,SMP,SMPI, $ SMU,CT,CTKCH,CTK0, $ ML0,MSP,MS0,MSM,MX0,MXM,CTL0,CTSP,CTSM,CTX0,CTXM, $ RMASS(35),RCHARG(35) C REAL MP,MPI,MMU,MEL,MKCH,MK0, * ML0,MSP,MS0,MSM,MX0,MXM C PARAMETER (MXGKCU=MXGKGH) COMMON/CURPAR/WEIGHT(10),DDELTN,IFILE,IRUN,NEVT,NEVENT,SHFLAG, * ITHST,ITTOT,ITLST,IFRND,TOFCUT,CMOM(5),CENG(5), * RS,S,ENP(10),NP,NM,NN,NR,NO,NZ,IPA(MXGKCU), * ATNO2,ZNO2 C COMMON/RESULT/XEND,YEND,ZEND,RCA,RCE,AMAS,NCH,TOF,PX,PY,PZ, * USERW,INTCT,P,EN,EK,AMASQ,DELTN,ITK,NTK,IPART,IND, * LCALO,ICEL,SINL,COSL,SINP,COSP, * XOLD,YOLD,ZOLD,POLD,PXOLD,PYOLD,PZOLD, * XSCAT,YSCAT,ZSCAT,PSCAT,PXSCAT,PYSCAT,PZSCAT REAL NCH,INTCT C COMMON/MAT / LMAT, * DEN(21),RADLTH(21),ATNO(21),ZNO(21),ABSL(21), * CDEN(21),MDEN(21),X0DEN(21),X1DEN(21),RION(21), * MATID(21),MATID1(21,24),PARMAT(21,10), * IFRAT,IFRAC(21),FRAC1(21,10),DEN1(21,10), * ATNO1(21,10),ZNO1(21,10) C PARAMETER (MXEVEN=12*MXGKGH) COMMON/EVENT / NSIZE,NCUR,NEXT,NTOT,EVE(MXEVEN) C COMMON/PRNTFL/INBCD,NEWBCD,INBIN,NEWBIN,NPEVT,NEVTP,LPRT,NPRT(10) LOGICAL LPRT,NPRT C COMMON/ERRCOM/ IER(100) C PARAMETER (MXGKPV=MXGKGH) COMMON /VECUTY/ PV(10,MXGKPV) C SAVE C C NIHIL=0 IF(AMAS.GT.0.) GO TO 9999 IF(IPART.LT.14) GO TO 9999 IF(IPA(1).GE.14) GO TO 9999 IF(IPA(2).GE.14) GO TO 9999 NIHIL=1 C** C** DO NOT BE CONFUSED, THIS HAS NOTHING TO DO WITH RELATIVISTIC C** KINEMATIC C TARMAS=RMASS(14) IF (NFL .EQ. 2) TARMAS=RMASS(16) EKCOR=1. IF(EK.GT.1.) EKCOR=1./EK EK=2.*TARMAS+EK*(1.+EKCOR/ATNO2) EN=EK+ABS(AMAS) P =SQRT(ABS(EN*EN-AMAS*AMAS)) S =AMAS*AMAS+TARMAS**2+2.0*TARMAS*EN RS=SQRT(S) ENP(5)=EK ENP(6)=EN ENP(7)=P ENP(8)=S ENP(9)=RS C** C** EVAPORATION C** TKIN=EXNU(EK) ENP(5)=EK-TKIN IF(ENP(5).LT.0.0001) ENP(5)=0.0001 ENP(6)=ENP(5)+ABS(AMAS) ENP(7)=ENP(6)*ENP(6)-AMASQ ENP(7)=SQRT(ABS(ENP(7))) ENP(8)=AMASQ+RMASS(14)**2+2.*RMASS(14)*ENP(6) ENP(9)=SQRT(ENP(8)) C** CHECK AVAILABLE ENERGY FOR FIRST INTERACTION IF(ENP(5).GT.CENG(3)) GO TO 9999 ENP(5)=0. ENP(6)=ABS(AMAS) ENP(7)=0. ENP(8)=4.*RMASS(14)**2 ENP(9)=2.*RMASS(14) C 9999 CONTINUE RETURN END *CMZU: 3.16/00 05/11/93 17.20.00 BY FEDERICO CARMINATI *-- AUTHOR : C--------------------------------------------------------------------- SUBROUTINE COSCAT C C *** MOMENTUM GENERATION FOR COHERENT ELASTIC SCATTERING *** C *** NVE 13-JUL-1988 CERN GENEVA *** C C ORIGIN : H.FESEFELDT (03-DEC-1986) C C APPROXIMATION OF BESSEL FUNCTION FOR TETA(LAB)<=20 DEG. C IS USED . THE NUCLEAR RADIUS IS TAKEN AS R=1.25*E-13*(A)**1/3FM C PARAMETER (MXGKGH=100) COMMON/CONSTS/ PI,TWPI,PIBTW,MP,MPI,MMU,MEL,MKCH,MK0,SMP,SMPI, $ SMU,CT,CTKCH,CTK0, $ ML0,MSP,MS0,MSM,MX0,MXM,CTL0,CTSP,CTSM,CTX0,CTXM, $ RMASS(35),RCHARG(35) C REAL MP,MPI,MMU,MEL,MKCH,MK0, * ML0,MSP,MS0,MSM,MX0,MXM C PARAMETER (MXGKCU=MXGKGH) COMMON/CURPAR/WEIGHT(10),DDELTN,IFILE,IRUN,NEVT,NEVENT,SHFLAG, * ITHST,ITTOT,ITLST,IFRND,TOFCUT,CMOM(5),CENG(5), * RS,S,ENP(10),NP,NM,NN,NR,NO,NZ,IPA(MXGKCU), * ATNO2,ZNO2 C COMMON/RESULT/XEND,YEND,ZEND,RCA,RCE,AMAS,NCH,TOF,PX,PY,PZ, * USERW,INTCT,P,EN,EK,AMASQ,DELTN,ITK,NTK,IPART,IND, * LCALO,ICEL,SINL,COSL,SINP,COSP, * XOLD,YOLD,ZOLD,POLD,PXOLD,PYOLD,PZOLD, * XSCAT,YSCAT,ZSCAT,PSCAT,PXSCAT,PYSCAT,PZSCAT REAL NCH,INTCT C COMMON/MAT / LMAT, * DEN(21),RADLTH(21),ATNO(21),ZNO(21),ABSL(21), * CDEN(21),MDEN(21),X0DEN(21),X1DEN(21),RION(21), * MATID(21),MATID1(21,24),PARMAT(21,10), * IFRAT,IFRAC(21),FRAC1(21,10),DEN1(21,10), * ATNO1(21,10),ZNO1(21,10) C PARAMETER (MXEVEN=12*MXGKGH) COMMON/EVENT / NSIZE,NCUR,NEXT,NTOT,EVE(MXEVEN) C COMMON/PRNTFL/INBCD,NEWBCD,INBIN,NEWBIN,NPEVT,NEVTP,LPRT,NPRT(10) LOGICAL LPRT,NPRT C COMMON/ERRCOM/ IER(100) C PARAMETER (MXGKPV=MXGKGH) COMMON /VECUTY/ PV(10,MXGKPV) C C COMMON/COSCOM/AA,BB,CC,DD,RR C C --- INITIALIZATION FLAGS FOR VARIOUS GHEISHA ROUTINES --- COMMON /KGINIT/ KGINIT(50) C C EXTERNAL FCTCOS DIMENSION FF(20),ATNOX(3) DIMENSION RNDM(1) SAVE C DATA ATNOX/9.,56.,207./ C C --- INITIALIZATION INDICATED BY KGINIT(14) --- IF (KGINIT(14) .NE. 0) GO TO 10 KGINIT(14)=1 C IF(.NOT.NPRT(10)) GOTO 10 WRITE(NEWBCD,2001) 2001 FORMAT(1H ,'*COSCAT* DS/DT FOR COHERENT ELASTIC SCATTERING') DO 3 L=1,3 WRITE(NEWBCD,2003) ATNOX(L),P 2003 FORMAT(1H ,'*COSCAT* CALCULATED CROSS SECTIONS FOR A=', * F5.1,' AND P=',F8.2) DO 2 I=1,20 TETA=(I-1)*PI/360. T=2.*P**2*(1.-COS(TETA*1.D0)) IF(ATNOX(L).GT.62.) GOTO 4 FF(I)=TWPI*ATNOX(L)**1.63*EXP(-14.5D0*ATNOX(L)**0.65*T) * +TWPI*1.4*ATNOX(L)**0.33*EXP(-10.D0*T) GOTO 2 4 FF(I)=TWPI*ATNOX(L)**1.33*EXP(-60.0D0*ATNOX(L)**0.33*T) * +TWPI*0.4*ATNOX(L)**0.40*EXP(-10.D0*T) 2 CONTINUE WRITE(NEWBCD,2004) FF 2004 FORMAT(1H ,10E12.3) 3 CONTINUE 10 IF(P.LT.0.01) GO TO 9999 IF(ATNO2.LT.0.5) GO TO 9999 IER(46)=IER(46)+1 RAN=RANRES(DUM) * CALL VZERO(IPA(1),MXGKCU) CDH DO III = 1, MXGKCU IPA(III) = 0 ENDDO IPA(1)=IPART IF(ATNO2.GT.62.) GOTO 11 AA=ATNO2**1.63 BB=14.5*ATNO2**0.66 CC=1.4*ATNO2**0.33 DD=10. AA=AA/BB CC=CC/DD RR=(AA+CC)*RAN GOTO 12 11 AA=ATNO2**1.33 BB=60.*ATNO2**0.33 CC=0.4*ATNO2**0.40 DD=10. AA=AA/BB CC=CC/DD RR=(AA+CC)*RAN 12 T1=-LOG(RAN)/BB T2=-LOG(RAN)/DD EPS=0.001 IND1=10 CALL RTMI(T,VAL,FCTCOS,T1,T2,EPS,IND1,IER1) IF(IER1.EQ.0) GOTO 14 T=0.25*(3.*T1+T2) IER(68)=IER(68)+1 14 CALL GRNDM(RNDM,1) PHI=RNDM(1)*TWPI RR=0.5*T/P**2 IF(RR.GT.1.) RR=0. COST=1.-RR * SINT=SQRT(MAX((1.-COST)*(1.+COST),0.)) SINT=SQRT(MAX(RR*(2.-RR),0.)) IF(SINT.NE.0.) THEN PV( 1,MXGKPV-1)=P*PX PV( 2,MXGKPV-1)=P*PY PV( 3,MXGKPV-1)=P*PZ PV( 4,MXGKPV-1)=EN PV( 5,MXGKPV-1)=AMAS PV( 6,MXGKPV-1)=NCH PV( 7,MXGKPV-1)=TOF PV( 8,MXGKPV-1)=IPART PV( 9,MXGKPV-1)=0. PV(10,MXGKPV-1)=USERW PV(1,1)=P*SINT*SIN(PHI) PV(2,1)=P*SINT*COS(PHI) PV(3,1)=P*COST PV(4,1)=EN PV(5,1)=AMAS PV(6,1)=NCH PV(7,1)=TOF PV(8,1)=IPART PV(9,1)=0. PV(10,1)=0. CALL DEFS1(1,MXGKPV-1,1) SINL1=SINL COSL1=COSL SINP1=SINP COSP1=COSP CALL SETCUR(1) ELSE SINL1=SINL COSL1=COSL SINP1=SINP COSP1=COSP ENDIF IF(NPRT(4)) *WRITE(NEWBCD,1004) AMAS,P,SINL1,COSL1,SINP1,COSP1,SINL,COSL, * SINP,COSP,T1,T,T2,IER1 C 1004 FORMAT(1H ,'*COSCAT* COHERENT ELASTIC SCATTERING MASS ' * ,F8.3,' MOMENTUM ' * ,F8.3/,' DIRECTION ',4F10.4,' CHANGED TO ',4F10.4/ *1H ,'T1,T,T2 ',3E10.3,' IER1 ',I2) C 9999 CONTINUE RETURN END *CMZU: 3.16/00 05/11/93 17.20.00 BY FEDERICO CARMINATI *-- AUTHOR : C--------------------------------------------------------------------- SUBROUTINE DEFS1(I,J,K) C C *** NVE 16-MAR-1988 CERN GENEVA *** C C ORIGIN : H.FESEFELDT (15-JAN-1984) C PARAMETER (MXGKGH=100) PARAMETER (MXGKPV=MXGKGH) COMMON /VECUTY/ PV(10,MXGKPV) C SAVE C DATA PI/3.141592653589793/ C PX=PV(1,I) PY=PV(2,I) PZ=PV(3,I) PT2 = PV(1,J)**2+PV(2,J)**2 IF(PT2.GT.0.) THEN CALL LENGTX(J,P) COST=PV(3,J)/P SINT1=SQRT(ABS((1.-COST)*(1.+COST))) SINT2=SQRT(PT2)/P SINT=0.5*(SINT1+SINT2) PH=PI*0.5 IF(PV(2,J).LT.0.) PH=PI*1.5 IF(ABS(PV(1,J)).GT.1.E-6) PH=ATAN2(PV(2,J),PV(1,J)) COSP=COS(PH) SINP=SIN(PH) PV(1,K)= COST*COSP*PX- SINP*PY+SINT*COSP*PZ PV(2,K)= COST*SINP*PX+ COSP*PY+SINT*SINP*PZ PV(3,K)=-SINT *PX +COST *PZ ELSE PV(1,K)=PX PV(2,K)=PY PV(3,K)=PZ C --- TAKE THE CASE OF THETA=PI INTO ACCOUNT (MR/NVE 27-SEP-1990) --- IF (PV(3,J) .LT. 0.) PV(3,K)=-PZ ENDIF RETURN END *CMZ : 3.14/16 10/05/90 17.25.40 BY NICK VAN EIJNDHOVEN (CERN) *-- AUTHOR : C--------------------------------------------------------------------- SUBROUTINE DLPNUC(A,N) C C CALLED BY : PHPNUC C ORIGIN : H.FESEFELDT C IMPLICIT DOUBLE PRECISION (A-H,O-Z) C DIMENSION A(N) DIMENSION LT(20),RT(20) INTEGER R,RT SAVE C LEVEL=1 LT(1)=1 RT(1)=N 10 L=LT(LEVEL) R=RT(LEVEL) LEVEL=LEVEL-1 20 IF(R.LE.L) IF(LEVEL) 50,50,10 C C SUBDIVIDE THE INTERVAL L,R C L : LOWER LIMIT OF THE INTERVAL (INPUT) C R : UPPER LIMIT OF THE INTERVAL (INPUT) C J : UPPER LIMIT OF LOWER SUB-INTERVAL (OUTPUT) C I : LOWER LIMIT OF UPPER SUB-INTERVAL (OUTPUT) C I=L J=R M=(L+R)/2 X=A(M) 220 IF(A(I).GE.X) GO TO 230 I=I+1 GO TO 220 230 IF(A(J).LE.X) GO TO 231 J=J-1 GO TO 230 C 231 IF(I.GT.J) GO TO 232 W=A(I) A(I)=A(J) A(J)=W I=I+1 J=J-1 IF(I.LE.J) GO TO 220 C 232 LEVEL=LEVEL+1 IF((R-I).GE.(J-L)) GO TO 30 LT(LEVEL)=L RT(LEVEL)=J L=I GO TO 20 30 LT(LEVEL)=I RT(LEVEL)=R R=J GO TO 20 50 RETURN END *CMZ : 3.14/16 10/05/90 17.25.40 BY NICK VAN EIJNDHOVEN (CERN) *-- AUTHOR : C--------------------------------------------------------------------- SUBROUTINE DOTNUC(C,S,C2,S2,PR,I) C IMPLICIT DOUBLE PRECISION (A-H,O-Z) DIMENSION PR(50) SAVE C K1 = 5*I - 4 K2 = K1 + 1 SA = PR(K1) SB = PR(K2) A = SA*C - SB*S PR(K2) = SA*S + SB*C K2 = K2 + 1 B = PR(K2) PR(K1) = A*C2 - B*S2 PR(K2) = A*S2 + B*C2 RETURN END *CMZ : 3.14/16 10/05/90 17.25.40 BY NICK VAN EIJNDHOVEN (CERN) *-- AUTHOR : C--------------------------------------------------------------------- FUNCTION DPDNUC(A,B,C) C C CALLED BY : PHPNUC C ORIGIN : H.FESEFELDT C IMPLICIT DOUBLE PRECISION (A-H,O-Z) SAVE C C DPDK = SQRT(A*A+(B*B-C*C)**2/(A*A) - 2.0*(B*B+C*C))/2.0 A2 = A*A B2 = B*B C2 = C*C IF(A2) 21,21,61 61 CONTINUE ARG=A2+(B2-C2)**2/A2-2.0*(B2+C2) IF (ARG) 21,21,31 21 DPDNUC=0.0 GOTO 41 31 CONTINUE DPDNUC = 0.5*SQRT(A2 + (B2-C2)**2/A2 - 2.0*(B2+C2)) 41 CONTINUE RETURN END *CMZ : 3.15/01 06/05/91 22.27.46 BY FEDERICO CARMINATI *-- AUTHOR : C--------------------------------------------------------------------- FUNCTION EXNU(EK1) C C *** NUCLEAR EVAPORATION AS FUNCTION OF ATOMIC NUMBER ATNO *** C *** AND KINETIC ENERGY EKIN OF PRIMARY PARTICLE *** C *** NVE 04-MAR-1988 CERN GENEVA *** C C ORIGIN : H.FESEFELDT (10-DEC-1986) C C PARAMETER (MXGKGH=100) COMMON/CONSTS/ PI,TWPI,PIBTW,MP,MPI,MMU,MEL,MKCH,MK0,SMP,SMPI, $ SMU,CT,CTKCH,CTK0, $ ML0,MSP,MS0,MSM,MX0,MXM,CTL0,CTSP,CTSM,CTX0,CTXM, $ RMASS(35),RCHARG(35) C REAL MP,MPI,MMU,MEL,MKCH,MK0, * ML0,MSP,MS0,MSM,MX0,MXM C PARAMETER (MXGKCU=MXGKGH) COMMON/CURPAR/WEIGHT(10),DDELTN,IFILE,IRUN,NEVT,NEVENT,SHFLAG, * ITHST,ITTOT,ITLST,IFRND,TOFCUT,CMOM(5),CENG(5), * RS,S,ENP(10),NP,NM,NN,NR,NO,NZ,IPA(MXGKCU), * ATNO2,ZNO2 C COMMON/RESULT/XEND,YEND,ZEND,RCA,RCE,AMAS,NCH,TOF,PX,PY,PZ, * USERW,INTCT,P,EN,EK,AMASQ,DELTN,ITK,NTK,IPART,IND, * LCALO,ICEL,SINL,COSL,SINP,COSP, * XOLD,YOLD,ZOLD,POLD,PXOLD,PYOLD,PZOLD, * XSCAT,YSCAT,ZSCAT,PSCAT,PXSCAT,PYSCAT,PZSCAT REAL NCH,INTCT C COMMON/MAT / LMAT, * DEN(21),RADLTH(21),ATNO(21),ZNO(21),ABSL(21), * CDEN(21),MDEN(21),X0DEN(21),X1DEN(21),RION(21), * MATID(21),MATID1(21,24),PARMAT(21,10), * IFRAT,IFRAC(21),FRAC1(21,10),DEN1(21,10), * ATNO1(21,10),ZNO1(21,10) C PARAMETER (MXEVEN=12*MXGKGH) COMMON/EVENT / NSIZE,NCUR,NEXT,NTOT,EVE(MXEVEN) C COMMON/PRNTFL/INBCD,NEWBCD,INBIN,NEWBIN,NPEVT,NEVTP,LPRT,NPRT(10) LOGICAL LPRT,NPRT C COMMON/ERRCOM/ IER(100) C PARAMETER (MXGKPV=MXGKGH) COMMON /VECUTY/ PV(10,MXGKPV) C C DIMENSION RNDM(2) SAVE C EXNU=0. IF(ATNO2.LT.1.5) GO TO 9999 MAGIC=0 IF(INT(ZNO2+0.1).EQ.82) MAGIC=1 EKIN1=EK1 IF(EKIN1.LT.0.1) EKIN1=0.1 IF(EKIN1.GT.4.) EKIN1=4. C** 0.35 VALUE AT 1 GEV C** 0.05 VALUE AT 0.1 GEV CFA=(0.35-0.05)/2.3 CFA= 0.35+CFA*LOG(EKIN1) IF(CFA.LT.0.15) CFA=0.15 EXNU=7.716*CFA*EXP(-CFA) ATNO3=ATNO2 IF(ATNO3.GT.120.) ATNO3=120. CFA=((ATNO3-1.)/120.)*EXP(-(ATNO3-1.)/120.) EXNU=EXNU*CFA FPDIV=1.-0.25*EKIN1**2 IF(FPDIV.LT.0.50) FPDIV=0.50 GFA=2.0*((ATNO2-1.)/70.)*EXP(-(ATNO2-1.)/70.) ENP(1)=EXNU*FPDIV ENP(3)=EXNU-ENP(1) 4 CALL NORMAL(RAN1) CALL NORMAL(RAN2) IF(MAGIC.EQ.1) THEN RAN1=0. RAN2=0. ENDIF ENP(1)=ENP(1)*(1.+RAN1*GFA) IF(ENP(1).LT.0.) ENP(1)=0. ENP(3)=ENP(3)*(1.+RAN2*GFA) IF(ENP(3).LT.0.) ENP(3)=0. 5 EXNU=ENP(1)+ENP(3) IF(EXNU.LT.EK1) GOTO 10 CALL GRNDM(RNDM,2) ENP(1)=ENP(1)*(1.-0.5*RNDM(1)) ENP(3)=ENP(3)*(1.-0.5*RNDM(2)) GOTO 5 10 CONTINUE IF (NPRT(4)) $ WRITE(NEWBCD,1001) XEND,YEND,ZEND,EXNU,ENP(1),ENP(3) 1001 FORMAT(' *EXNU* NUCLEAR EXCITATION AT X,Y,Z = ',3(G12.5,1X)/ $ 1H ,7X,'EXNU,ENP(1),ENP(3) = ',3(G12.5,1X)) C 9999 CONTINUE RETURN END *CMZ : 3.14/16 13/03/89 14.48.42 BY NICK VAN EIJNDHOVEN (CERN) *-- AUTHOR : C--------------------------------------------------------------------- REAL FUNCTION FCTCOS(T) C C *** NVE 01-MAR-1988 CERN GENEVA *** C C ORIGIN : H.FESEFELDT (27-OCT-1983) C COMMON/COSCOM/AA,BB,CC,DD,RR C C --- BOUNDARY LIMITS FOR ARGUMENTS OF INTRINSIC FUNCTIONS --- C --- XL DENOTES LOWER BOUND WHEREAS XU DENOTES UPPER BOUND --- COMMON /LIMITS/ EXPXL,EXPXU C C DOUBLE PRECISION TEST1,TEST2 SAVE C TEST1=-BB*T*1.0D0 IF (TEST1 .GT. EXPXU) TEST1=EXPXU IF (TEST1 .LT. EXPXL) TEST1=EXPXL TEST2=-DD*T*1.0D0 IF (TEST2 .GT. EXPXU) TEST2=EXPXU IF (TEST2 .LT. EXPXL) TEST2=EXPXL C FCTCOS=AA*EXP(TEST1)+CC*EXP(TEST2)-RR C RETURN END *CMZ : 3.14/16 13/03/89 14.48.39 BY NICK VAN EIJNDHOVEN (CERN) *-- AUTHOR : C--------------------------------------------------------------------- FUNCTION FERMIG(EK1) C C *** NVE 16-MAR-1988 CERN GENEVA *** C C ORIGIN : H.FESEFELDT (23-AUG-1985) C FERMIG=0. RETURN END *CMZ : 3.16/00 05/11/93 19.05.29 BY FEDERICO CARMINATI *-- AUTHOR : C--------------------------------------------------------------------- FUNCTION FISSIO(EK1) C C *** GENERATION OF PHOTONS AND NEUTRONS BY FISSION *** C *** NVE 04-MAR-1988 CERN GENEVA *** C C ORIGIN : H.FESEFELDT (21-MAR-1987) C C THE PHYSICS IS BASED ON U(238) C FOR OTHER MATERIALS EXTRAPOLATIONS ARE USED C PARAMETER (MXGKGH=100) COMMON/CONSTS/ PI,TWPI,PIBTW,MP,MPI,MMU,MEL,MKCH,MK0,SMP,SMPI, $ SMU,CT,CTKCH,CTK0, $ ML0,MSP,MS0,MSM,MX0,MXM,CTL0,CTSP,CTSM,CTX0,CTXM, $ RMASS(35),RCHARG(35) C REAL MP,MPI,MMU,MEL,MKCH,MK0, * ML0,MSP,MS0,MSM,MX0,MXM C PARAMETER (MXGKCU=MXGKGH) COMMON/CURPAR/WEIGHT(10),DDELTN,IFILE,IRUN,NEVT,NEVENT,SHFLAG, * ITHST,ITTOT,ITLST,IFRND,TOFCUT,CMOM(5),CENG(5), * RS,S,ENP(10),NP,NM,NN,NR,NO,NZ,IPA(MXGKCU), * ATNO2,ZNO2 C COMMON/RESULT/XEND,YEND,ZEND,RCA,RCE,AMAS,NCH,TOF,PX,PY,PZ, * USERW,INTCT,P,EN,EK,AMASQ,DELTN,ITK,NTK,IPART,IND, * LCALO,ICEL,SINL,COSL,SINP,COSP, * XOLD,YOLD,ZOLD,POLD,PXOLD,PYOLD,PZOLD, * XSCAT,YSCAT,ZSCAT,PSCAT,PXSCAT,PYSCAT,PZSCAT REAL NCH,INTCT C COMMON/MAT / LMAT, * DEN(21),RADLTH(21),ATNO(21),ZNO(21),ABSL(21), * CDEN(21),MDEN(21),X0DEN(21),X1DEN(21),RION(21), * MATID(21),MATID1(21,24),PARMAT(21,10), * IFRAT,IFRAC(21),FRAC1(21,10),DEN1(21,10), * ATNO1(21,10),ZNO1(21,10) C PARAMETER (MXEVEN=12*MXGKGH) COMMON/EVENT / NSIZE,NCUR,NEXT,NTOT,EVE(MXEVEN) C COMMON/PRNTFL/INBCD,NEWBCD,INBIN,NEWBIN,NPEVT,NEVTP,LPRT,NPRT(10) LOGICAL LPRT,NPRT C COMMON/ERRCOM/ IER(100) C PARAMETER (MXGKPV=MXGKGH) COMMON /VECUTY/ PV(10,MXGKPV) C C C --- INITIALIZATION FLAGS FOR VARIOUS GHEISHA ROUTINES --- COMMON /KGINIT/ KGINIT(50) C C DIMENSION SPNEUT(10) DIMENSION RNDM(2) SAVE SPNEUT SAVE DATA SPNEUT/10*0./ C C --- INITIALIZATION INDICATED BY KGINIT(15) --- IF (KGINIT(15) .NE. 0) GO TO 10 KGINIT(15)=1 C XX=1.-0.5 XXX=SQRT(2.29*XX) SPNEUT(1)=EXP(-XX/0.965)*(EXP(XXX)-EXP(-XXX))/2. DO 1 I=2,10 XX=I*1.-0.5 XXX=SQRT(2.29*XX) 1 SPNEUT(I)=SPNEUT(I-1)+EXP(-XX/0.965)*(EXP(XXX)-EXP(-XXX))/2. DO 2 I=1,10 2 SPNEUT(I)=SPNEUT(I)/SPNEUT(10) C** IN THIS ROUTINE WE USE MEV AS UNIT FOR ENERGY AND MOMENTUM 10 NT=0 IER(82)=IER(82)+1 ND=IND+1 PV( 1,MXGKPV)=PX*P PV( 2,MXGKPV)=PY*P PV( 3,MXGKPV)=PZ*P PV( 4,MXGKPV)=EN PV( 5,MXGKPV)=ABS(AMAS) PV( 6,MXGKPV)=NCH PV( 7,MXGKPV)=TOF PV( 8,MXGKPV)=IPART PV( 9,MXGKPV)=0. PV(10,MXGKPV)=USERW PV( 1,MXGKPV-1)=0. PV( 2,MXGKPV-1)=0. PV( 3,MXGKPV-1)=0. PV( 4,MXGKPV-1)=ATOMAS(ATNO(ND),ZNO(ND)) PV( 5,MXGKPV-1)=PV(4,MXGKPV-1) PV( 6,MXGKPV-1)=ZNO(ND) PV( 7,MXGKPV-1)=TOF PV( 8,MXGKPV-1)=0. PV( 9,MXGKPV-1)=0. PV(10,MXGKPV-1)=0. CALL ADD(MXGKPV,MXGKPV-1,MXGKPV-2) PV(1,MXGKPV-2)=-PV(1,MXGKPV-2) PV(2,MXGKPV-2)=-PV(2,MXGKPV-2) PV(3,MXGKPV-2)=-PV(3,MXGKPV-2) C** NUMBER OF NEUTRONS AND PHOTONS FISSIO=0. E1=EK1*1000. IF(E1.LT.1.0) E1=1.0 AVERN=2.569+0.559*LOG(E1) C** TAKE THE FOLLOWING VALUE IF PHOTOFISSION IS NOT INCLUDED IF(IFIX(PARMAT(IND+1,8)).EQ.0) *AVERN=2.569+0.900*LOG(E1) AVERG=9.500+0.600*LOG(E1) CALL NORMAL(RAN) NN=IFIX(AVERN+RAN*1.23+0.5) CALL NORMAL(RAN) NG=IFIX(AVERG+RAN*3.+0.5) IF(NN.LT.1) NN=1 IF(NG.LT.1) NG=1 EXN=0. EXG=0. C** DISTRIBUTE KINETIC ENERGY DO 15 I=1,NN CALL GRNDM(RNDM,1) RAN=RNDM(1) DO 11 J=1,10 IF(RAN.LT.SPNEUT(J)) GOTO 12 11 CONTINUE J=10 12 CALL GRNDM(RNDM,1) EKIN=(J-1)*1.+RNDM(1) EXN=EXN+EKIN PV(4,I)=EKIN+RMASS(16)*1000. PV(5,I)=RMASS(16)*1000. PV(6,I)=0. C** EMISSION TIME FOR NEUTRONS =0. PV(7,I)=TOF PV(8,I)=16. PV(9,I)=0. PV(10,I)=0. 15 CONTINUE NT=NN DO 20 I=1,NG CALL GRNDM(RNDM,1) RAN=RNDM(1) NT=NT+1 PV(4,NT)=-0.87*LOG(RAN) EXG=EXG+PV(4,NT) PV(5,NT)=0. PV(6,NT)=0. C RAN=RNDM(1) C** EMISSION TIME FOR PHOTONS= 2.5 E-8 SEC C PV(7,NT)=TOF-500.*LOG(RAN) C** CHANGED 30.7.85 PV(7,NT)=TOF PV(8,NT)=1. PV(9,NT)=0. PV(10,NT)=0. 20 CONTINUE IF(NT.EQ.0) GO TO 9999 EX=EXN+EXG IF(NPRT(4)) *WRITE(NEWBCD,2000) ATNO(IND+1),NN,NG,EX FISSIO=EX/1000. DO 49 I=1,NT PV(5,I)=PV(5,I)/1000. PV(4,I)=PV(4,I)/1000. CALL GRNDM(RNDM,2) COST=-1.+2.*RNDM(1) SINT=SQRT(ABS(1.-COST*COST)) PHI=RNDM(2)*TWPI PP=SQRT(ABS(PV(4,I)**2-PV(5,I)**2)) PV(1,I)=PP*SINT*SIN(PHI) PV(2,I)=PP*SINT*COS(PHI) PV(3,I)=PP*COST CALL LOR(I,MXGKPV-2,I) 49 CONTINUE INTCT=INTCT+1. DO 50 I=1,NT IF(NTOT.LT.NSIZE/12) GOTO 43 IER(39)=IER(39)+1 GO TO 9999 43 CALL SETTRK(I) 50 CONTINUE C 2000 FORMAT(1H ,'*FISSIO* NUCLEAR FISSION ON MATERIAL ',F6.1,/, *' NEUTRONS, PHOTONS PRODUCED= ',2I3,' WITH ',F8.4, *' MEV TOTAL ENERGY') C 9999 CONTINUE RETURN END *CMZ : 3.16/00 05/11/93 19.22.38 BY FEDERICO CARMINATI *-- AUTHOR : C--------------------------------------------------------------------- SUBROUTINE GENXPT(IPPP,NFL,AVERN) C C *** GENERATION OF X- AND PT- VALUES FOR ALL PRODUCED PARTICLES *** C *** NVE 02-MAY-1988 CERN GENEVA *** C C ORIGIN : H.FESEFELDT 11-OCT-1987 C C A SIMPLE SINGLE VARIABLE DESCRIPTION E D3S/DP3= F(Q) WITH C Q**2 = (M*X)**2 + PT**2 IS USED. FINAL STATE KINEMATIC IS PRODUCED C BY AN FF-TYPE ITERATIVE CASCADE METHOD C PARAMETER (MXGKGH=100) COMMON/CONSTS/ PI,TWPI,PIBTW,MP,MPI,MMU,MEL,MKCH,MK0,SMP,SMPI, $ SMU,CT,CTKCH,CTK0, $ ML0,MSP,MS0,MSM,MX0,MXM,CTL0,CTSP,CTSM,CTX0,CTXM, $ RMASS(35),RCHARG(35) C REAL MP,MPI,MMU,MEL,MKCH,MK0, * ML0,MSP,MS0,MSM,MX0,MXM C PARAMETER (MXGKCU=MXGKGH) COMMON/CURPAR/WEIGHT(10),DDELTN,IFILE,IRUN,NEVT,NEVENT,SHFLAG, * ITHST,ITTOT,ITLST,IFRND,TOFCUT,CMOM(5),CENG(5), * RS,S,ENP(10),NP,NM,NN,NR,NO,NZ,IPA(MXGKCU), * ATNO2,ZNO2 C COMMON/RESULT/XEND,YEND,ZEND,RCA,RCE,AMAS,NCH,TOF,PX,PY,PZ, * USERW,INTCT,P,EN,EK,AMASQ,DELTN,ITK,NTK,IPART,IND, * LCALO,ICEL,SINL,COSL,SINP,COSP, * XOLD,YOLD,ZOLD,POLD,PXOLD,PYOLD,PZOLD, * XSCAT,YSCAT,ZSCAT,PSCAT,PXSCAT,PYSCAT,PZSCAT REAL NCH,INTCT C COMMON/MAT / LMAT, * DEN(21),RADLTH(21),ATNO(21),ZNO(21),ABSL(21), * CDEN(21),MDEN(21),X0DEN(21),X1DEN(21),RION(21), * MATID(21),MATID1(21,24),PARMAT(21,10), * IFRAT,IFRAC(21),FRAC1(21,10),DEN1(21,10), * ATNO1(21,10),ZNO1(21,10) C PARAMETER (MXEVEN=12*MXGKGH) COMMON/EVENT / NSIZE,NCUR,NEXT,NTOT,EVE(MXEVEN) C COMMON/PRNTFL/INBCD,NEWBCD,INBIN,NEWBIN,NPEVT,NEVTP,LPRT,NPRT(10) LOGICAL LPRT,NPRT C COMMON/ERRCOM/ IER(100) C PARAMETER (MXGKPV=MXGKGH) COMMON /VECUTY/ PV(10,MXGKPV) C C COMMON/GENIN /TECM,AMASS(18),NPG,KGENEV COMMON/GENOUT/PCM(5,18),WGT C C REAL MASPAR,LAMB,NUCSUP DIMENSION MASPAR(8),BP(8),PTEX(8),C1PAR(5),G1PAR(5),TAVAI(2), $ SIDE(MXGKCU),IAVAI(2),BINL(20),DNDL(20),TWSUP(8), $ NUCSUP(6),PSUP(6),IPAX(100) DIMENSION RNDM(3) SAVE DATA MASPAR/0.75,0.70,0.65,0.60,0.50,0.40,0.75,0.20/ DATA BP/3.50,3.50,3.50,6.00,5.00,4.00,3.50,3.50/ DATA PTEX/1.70,1.70,1.50,1.70,1.40,1.20,1.70,1.20/ DATA C1PAR/0.6,0.6,0.35,0.15,0.10/ DATA G1PAR/2.6,2.6,1.80,1.30,1.20/ DATA BINL/0.,0.1,0.2,0.3,0.4,0.5,0.6,0.7,0.8,0.9,1.0,1.11,1.25 $ ,1.43,1.67,2.0,2.5,3.33,5.00,10.00/ DATA TWSUP/1.,1.,0.7,0.5,0.3,0.2,0.1,0.0/ DATA NUCSUP/1.00,0.7,0.5,0.4,0.35,0.3/ DATA PSUP/3.,6.,20.,50.,100.,1000./ C C** CALL HIGSEL(ISEL) IF(ISEL.EQ.1) THEN CALL HIGXPT(IPPP,NFL,AVERN) RETURN ENDIF C** C** FOR ANNIHILATION INTERACTIONS INTRODUCE PROPER KINEMATICS C** CALL CORANH(NIHIL,NFL) C** C** C** CHECK FIRST MASS-INDICES C** EK=ENP(5) EN=ENP(6) P=ENP(7) S=ENP(8) RS=ENP(9) NT=0 DO 1 I=1,100 IF(IPA(I).EQ.0) GOTO 1 NT=NT+1 IPA(NT)=IPA(I) 1 CONTINUE * CALL VZERO(IPA(NT+1),MXGKCU-NT) * CALL UCOPY(IPA(1),IPAX(1),100) CDH DO III = NT+1, MXGKCU IPA(III) = 0 ENDDO DO III = 1, 100 IPAX(III) = IPA(III) ENDDO C** C** FOR LOW MULTIPLICITY USE TWO-BODY RESONANCE MODEL OR SINGLE/DOUBLE C** DIFFRACTION MODEL (--> TWOCLU (--> TWOB (--> COSCAT))) C** CFA=0.025*((ATNO2-1.)/120.)*EXP(-(ATNO2-1.)/120.) IF(NIHIL.GT.0) GOTO 200 IF(NT.GE.8) GOTO 200 IF(EK.LT.1.) GOTO 60 CALL GRNDM(RNDM,1) RAN=RNDM(1) IF(IPART.GE.10.AND.IPART.LE.13.AND.RAN.LT.0.5) GOTO 200 CALL GRNDM(RNDM,1) RAN=RNDM(1) WSUP=TWSUP(NT) IF(RAN.GT.WSUP) GOTO 200 60 CONTINUE * CALL UCOPY(IPAX,IPA,100) CDH DO III = 1, 100 IPA(III) = IPAX(III) ENDDO CALL TWOCLU(IPPP,NFL,AVERN) GO TO 9999 C** C** SET EFFECTIVE 4-MOMENTUM OF PRIMARY PARTICLE C** 200 MX =MXGKPV-20 MX1=MX+1 MX2=MX+2 MX3=MX+3 MX4=MX+4 MX5=MX+5 MX6=MX+6 MX7=MX+7 MX8=MX+8 MX9=MX+9 PV( 1,MXGKPV-1)=P*PX PV( 2,MXGKPV-1)=P*PY PV( 3,MXGKPV-1)=P*PZ PV( 4,MXGKPV-1)=EN PV( 5,MXGKPV-1)=AMAS PV( 6,MXGKPV-1)=NCH PV( 7,MXGKPV-1)=TOF PV( 8,MXGKPV-1)=IPART PV( 9,MXGKPV-1)=0. PV(10,MXGKPV-1)=USERW IER(49)=IER(49)+1 C** C** SOME RANDOMISATION OF ORDER OF FINAL STATE PARTICLES C** DO 201 I=3,NT CALL GRNDM(RNDM,1) IPX=IFIX(3.+RNDM(1)*(NT-2.)) IF(IPX.GT.NT) IPX=NT IPA1=IPA(IPX) IPA(IPX)=IPA(I) 201 IPA(I) =IPA1 C** C** DISTRIBUTE IN FORWARD AND BACKWARD HEMISPHERE IN CMS C** SIDE(1)= 1. SIDE(2)=-1. NTB=1 TARG=0. IF(IPART.LT.10.OR.IPART.GT.13) GOTO 53 CALL GRNDM(RNDM,1) IF(RNDM(1).LT.0.7) GOTO 53 IPA1=IPA(1) IPA(1)=IPA(2) IPA(2)=IPA1 53 LEAD=0 IF(IPART.LT.10.OR.IPART.EQ.14.OR.IPART.EQ.16) GOTO 532 IPA1=ABS(IPA(1)) IF(IPA1.LT.10.OR.IPA1.EQ.14.OR.IPA1.EQ.16) GOTO 531 LEAD=IPA1 GOTO 532 531 IPA1=ABS(IPA(2)) IF(IPA1.LT.10.OR.IPA1.EQ.14.OR.IPA1.EQ.16) GOTO 532 LEAD=IPA1 532 DO 3 I=1,NT IF(I.LE.2) GOTO 54 SIDE(I)= 1. CALL GRNDM(RNDM,1) IF(RNDM(1).LT.0.5) SIDE(I)=-1. IF(SIDE(I).LT.-0.5) NTB=NTB+1 54 CONTINUE 3 CONTINUE TB=2.*NTB CALL GRNDM(RNDM,1) IF(RS.LT.(2.0+RNDM(1))) TB=(2.*NTB+NT)/2. C** C** ADD PARTICLES FROM INTRANUCLEAR CASCADE C** AFC=0.312+0.200*LOG(LOG(S))+S**1.5/6000. IF(AFC.GT.0.75) AFC=0.75 XTARG=AFC*(ATNO2**0.33 -1.0)*TB IF(XTARG.LE.0.) XTARG=0.01 CALL POISSO(XTARG,NTARG) NT2=NT+NTARG IF(NT2.LE.MX) GOTO 2 NT2=MX NTARG=NT2-NT 2 CONTINUE IF (NPRT(4)) WRITE(NEWBCD,3001) NTARG,NT NT1=NT+1 IF(NTARG.EQ.0) GOTO 51 C** C** CHECK NUMBER OF EXTRA NUCLEONS AND PIONS C** DO 881 IPX=1,6 IF(P.LE.PSUP(IPX)) GOTO 882 881 CONTINUE IPX=6 882 DO 4 I=NT1,NT2 CALL GRNDM(RNDM,1) RAN=RNDM(1) IF(RAN.LT.NUCSUP(IPX)) GOTO 52 CALL GRNDM(RNDM,1) IPA(I)=-(7+IFIX(RNDM(1)*3.0)) GOTO 4 52 IPA(I)=-16 PNRAT=1.-ZNO2/ATNO2 CALL GRNDM(RNDM,1) IF(RNDM(1).GT.PNRAT) IPA(I)=-14 TARG=TARG+1. 4 SIDE(I)=-2. NT=NT2 C** C** CHOOSE MASSES AND CHARGES FOR ALL PARTICLES C** 51 DO 5 I=1,NT IPA1=ABS(IPA(I)) PV(5,I)=RMASS(IPA1) PV(6,I)=RCHARG(IPA1) PV(7,I)=1. IF(PV(5,I).LT.0.) PV(7,I)=-1. PV(5,I)=ABS(PV(5,I)) 5 CONTINUE C** C** CHECK AVAILABLE KINETIC ENERGY, IN THIS MODEL CONSERVATION OF C** KINETIC ENERGY IN FORWARD AND BACKWARD HEMISPHERE IS ASSUMED C** 6 IF(NT.LE.1) GOTO 60 TAVAI(1)=RS/2. TAVAI(2)=(TARG+1.)*RS/2. IAVAI(1)=0 IAVAI(2)=0 DO 7 I=1,NT L=1 IF(SIDE(I).LT.0.) L=2 IAVAI(L)=IAVAI(L)+1 TAVAI(L)=TAVAI(L)-ABS(PV(5,I)) 7 CONTINUE NTH=NT IF(NTH.GT.10) NTH=10 IF (NPRT(4)) $ WRITE(NEWBCD,3002) TAVAI,IAVAI,(IPA(I),SIDE(I),I=1,NTH) IF(IAVAI(1).LE.0) GOTO 60 IF(IAVAI(2).LE.0) GOTO 60 IF(TAVAI(1).GT.0.) GOTO 11 CALL GRNDM(RNDM,1) ISKIP=IFIX(RNDM(1)*(IAVAI(1)-1))+1 IS=0 DO 10 I=1,NT II=NT-I+1 IF(SIDE(II).LT.0.) GOTO 10 IS=IS+1 IF(IS.NE.ISKIP) GOTO 10 IF(II.EQ.NT) GOTO 9 NT1=II+1 NT2=NT DO 8 J=NT1,NT2 IPA(J-1)=IPA(J) SIDE(J-1)=SIDE(J) DO 71 K=1,10 71 PV(K,J-1)=PV(K,J) 8 CONTINUE GOTO 9 10 CONTINUE 9 IPA(NT)=0 SIDE(NT)=0. NT=NT-1 GOTO 6 11 IF(TAVAI(2).GT.0.) GOTO 15 CALL GRNDM(RNDM,1) ISKIP=IFIX(RNDM(1)*(IAVAI(2)-1))+1 IS=0 DO 14 I=1,NT II=NT-I+1 IF(SIDE(II).GT.0.) GOTO 14 IS=IS+1 IF(IS.NE.ISKIP) GOTO 14 IF(SIDE(II).LT.-1.5) NTARG=NTARG-1 IF(NTARG.LT.0) NTARG=0 IF(II.EQ.NT) GOTO 13 NT1=II+1 NT2=NT DO 12 J=NT1,NT2 IPA(J-1)=IPA(J) SIDE(J-1)=SIDE(J) DO 74 K=1,10 74 PV(K,J-1)=PV(K,J) 12 CONTINUE GOTO 13 14 CONTINUE 13 IPA(NT)=0 SIDE(NT)=0. NT=NT-1 GOTO 6 15 IF(NT.LE.1) GOTO 60 IF(NT.EQ.MX) GOTO 29 NT1=NT+1 NT2=MX DO 28 I=NT1,NT2 28 IPA(I)=0 29 CONTINUE C** C** NOW THE PREPARATION IS FINISHED. C** DEFINE INITIAL STATE VECTORS FOR LORENTZ TRANSFORMATIONS. C** PV( 1,MX1)=0. PV( 2,MX1)=0. PV( 3,MX1)=P PV( 4,MX1)=SQRT(P*P+AMAS*AMAS) PV( 5,MX1)=ABS(AMAS) PV( 1,MX2)=0. PV( 2,MX2)=0. PV( 3,MX2)=0. PV( 4,MX2)=MP PV( 5,MX2)=MP PV( 1,MX4)=0. PV( 2,MX4)=0. PV( 3,MX4)=0. PV( 4,MX4)=MP*(1.+TARG) PV( 5,MX4)=PV(4,MX4) PV( 1,MX8)=0. PV( 2,MX8)=0. PV( 3,MX8)=0. PV( 1,MX9)=1. PV( 2,MX9)=0. PV( 3,MX9)=0. CALL ADD(MX1,MX2,MX3) CALL ADD(MX4,MX1,MX4) CALL LOR(MX1,MX3,MX1) CALL LOR(MX2,MX3,MX2) C** C** MAIN LOOP FOR 4-MOMENTUM GENERATION , SEE PITHA-REPORT (AACHEN) C** FOR A DETAILED DESCRIPTION OF THE METHOD. C** CALL GRNDM(RNDM,1) PHI=RNDM(1)*TWPI EKIN1=0. EKIN2=0. DO 39 J=1,10 PV(J,MX5)=0. 39 PV(J,MX6)=0. NPG=0 TARG1=0. DO 16 III=1,NT I=NT-III+1 IPA1=ABS(IPA(I)) C** C** COUNT NUMBER OF BACKWARD NUCLEONS C** IF(I.EQ.2) GOTO 301 IF(SIDE(I).LT.-1.5.AND.IPA1.GE.14) GOTO 301 GOTO 38 301 NPG=NPG+1 IF(NPG.GT.18) GOTO 38 SIDE(I)=-3. TARG1=TARG1+1. GOTO 16 38 J=3 IF(IPA1.LT.14) J=2 IF(IPA1.LT.10) J=1 IF(I.LE.2) J=J+3 IF(SIDE(I).LT.-1.5) J=7 IF(J.EQ.7.AND.IPA1.GE.14) J=8 C** C** SET PT - AND PHI VALUES, THEY ARE CHANGED SOMEWHAT IN THE ITERATION C** LOOP, SET MASS PARAMETER FOR LAMBDA FRAGMENTATION MODEL C** CALL GRNDM(RNDM,1) RAN=RNDM(1) BPP=BP(J) BPE=PTEX(J) PT2=-LOG(1.-RAN)/BPP ASPAR=MASPAR(J) PT2=PT2**BPE PT =SQRT(PT2) IF(PT.LT.0.001) PT=0.001 PV(1,I)=PT*COS(PHI) PV(2,I)=PT*SIN(PHI) PV(10,I)=PT BINL(1)=0. RLMAX=1./PV(10,I) DO 73 J=2,20 73 BINL(J)=RLMAX*(J-1)/19. ET=PV(4,MX1) IF(SIDE(I).LT.0.) THEN ET=PV(4,MX2) ENDIF DNDL(1)=0. NTRIAL=0 C** C** START OF BIG ITERATION LOOP C** 30 NTRIAL=NTRIAL+1 IF(NTRIAL.GT. 2) GOTO 169 DO 17 L=2,20 DNDL(L)=0. X=(BINL(L)+BINL(L-1))/2. IF(PV(10,I).LT.0.001) PV(10,I)=0.001 IF(X.GT.1./PV(10,I)) GOTO 17 DX=BINL(L)-BINL(L-1) DNDL(L)=ASPAR/SQRT((1.+(ASPAR*X)**2)**3) DNDL(L)=ET*DNDL(L)/SQRT((X*PV(10,I)*ET)**2+PV(10,I)**2 * +PV(5,I)**2) DNDL(L)=DNDL(L)*DX 17 DNDL(L)=DNDL(L-1)+DNDL(L) NTRI=0 31 CALL GRNDM(RNDM,1) RAN=RNDM(1)*DNDL(20) DO 18 L=2,20 IF(RAN.LT.DNDL(L)) GOTO 19 18 CONTINUE C** C** START OF SMALL ITERATION LOOP C** 19 NTRI=NTRI+1 CALL GRNDM(RNDM,1) RAN=RNDM(1) DX=BINL(L)-BINL(L-1) LAMB=BINL(L-1)+RAN*DX/2. X=PV(10,I)*LAMB IF(X.GT.1.) X=1. X=X*SIDE(I)/ABS(SIDE(I)) PV(3,I)=X*ET PV(4,I)=PV(3,I)**2+PV(10,I)**2+PV(5,I)**2 PV(4,I)=SQRT(PV(4,I)) IF(SIDE(I).LT.0.) GOTO 165 IF(I.GT.2) GOTO 20 EKIN=TAVAI(1)-EKIN1 CALL NORMAL(RAN) IF(EKIN.LT.0.) EKIN=0.04*ABS(RAN) PV(4,I)=ABS(PV(5,I))+EKIN RNVE=ABS(PV(4,I)**2-PV(5,I)**2) PP=SQRT(RNVE) CALL LENGTX(I,PP1) C IF (PP1 .GE. 1.0E-6) GO TO 8000 CALL GRNDM(RNDM,2) RTHNVE=PI*RNDM(1) PHINVE=TWPI*RNDM(2) PV(1,I)=PP*SIN(RTHNVE)*COS(PHINVE) PV(2,I)=PP*SIN(RTHNVE)*SIN(PHINVE) PV(3,I)=PP*COS(RTHNVE) GO TO 8001 8000 CONTINUE PV(1,I)=PV(1,I)*PP/PP1 PV(2,I)=PV(2,I)*PP/PP1 PV(3,I)=PV(3,I)*PP/PP1 8001 CONTINUE C CALL ADD(MX5,I,MX5) GOTO 16 20 EKIN=EKIN1+PV(4,I)-ABS(PV(5,I)) IF(EKIN.LT.0.95*TAVAI(1)) GOTO 161 IF(NTRI.GT. 5) GOTO 167 PV(10,I)=PV(10,I)*0.9 PV( 1,I)=PV( 1,I)*0.9 PV( 2,I)=PV( 2,I)*0.9 DNDL(20)=DNDL(20)*0.9 IF((TAVAI(2)-ABS(PV(5,I))).LT.0.) GOTO 31 SIDE(I)=-1. TAVAI(1)=TAVAI(1)+ABS(PV(5,I)) TAVAI(2)=TAVAI(2)-ABS(PV(5,I)) GOTO 31 161 CALL ADD(MX5,I,MX5) EKIN1=EKIN1+PV(4,I)-ABS(PV(5,I)) GOTO 163 165 EKIN=EKIN2+PV(4,I)-ABS(PV(5,I)) XXX=0.95+0.05*TARG/20. IF(XXX.GT.0.999) X=0.999 IF(EKIN.LT.XXX*TAVAI(2)) GOTO 166 IF(NTRI.GT. 5) GOTO 167 PV(10,I)=PV(10,I)*0.9 PV( 1,I)=PV( 1,I)*0.9 PV( 2,I)=PV( 2,I)*0.9 DNDL(20)=DNDL(20)*0.9 IF((TAVAI(1)-ABS(PV(5,I))).LT.0.) GOTO 31 SIDE(I)=+1. TAVAI(1)=TAVAI(1)-ABS(PV(5,I)) TAVAI(2)=TAVAI(2)+ABS(PV(5,I)) GOTO 31 166 CALL ADD(MX6,I,MX6) EKIN2=EKIN2+PV(4,I)-ABS(PV(5,I)) 163 CALL ADD(MX5,MX6,MX7) PV(3,MX7)=0. CALL ANG(MX7,MX9,COST,PHIS) IF(PV(2,MX7).LT.0.) PHIS=TWPI-PHIS CALL NORMAL(RAN) RAN=RAN*PI/12. PHI=PHIS+PI+RAN IF(PHI.GT.TWPI) PHI=PHI-TWPI IF(PHI.LT.0.) PHI=TWPI-PHI GOTO 16 C** C** PARTICLE MOMENTUM ZERO, REDUCE KINETIC ENERGY OF ALL OTHER C** 167 EKIN1=0. EKIN2=0. DO 162 J=1,10 PV(J,MX5)=0. 162 PV(J,MX6)=0. II=I+1 DO 168 L=II,NT IF(ABS(IPA(L)).GE.14.AND.SIDE(L).LT.0.) GOTO 168 PV(4,L)=PV(4,L)*0.95+0.05*ABS(PV(5,L)) IF(PV(4,L).LT.ABS(PV(5,L))) PV(4,L)=ABS(PV(5,L)) RNVE=ABS(PV(4,L)**2-PV(5,L)**2) PP=SQRT(RNVE) CALL LENGTX(L,PP1) C IF (PP1 .GE. 1.0E-6) GO TO 8002 CALL GRNDM(RNDM,2) RTHNVE=PI*RNDM(1) PHINVE=TWPI*RNDM(2) PV(1,L)=PP*SIN(RTHNVE)*COS(PHINVE) PV(2,L)=PP*SIN(RTHNVE)*SIN(PHINVE) PV(3,L)=PP*COS(RTHNVE) GO TO 8003 8002 CONTINUE PV(1,L)=PV(1,L)*PP/PP1 PV(2,L)=PV(2,L)*PP/PP1 PV(3,L)=PV(3,L)*PP/PP1 8003 CONTINUE C PV(10,L)=SQRT(PV(1,L)**2+PV(2,L)**2) IF(SIDE(L).LT.0.) GOTO 164 EKIN1=EKIN1+PV(4,L)-ABS(PV(5,L)) CALL ADD(MX5,L,MX5) GOTO 168 164 EKIN2=EKIN2+PV(4,L)-ABS(PV(5,L)) CALL ADD(MX6,L,MX6) 168 CONTINUE C *** NEXT STMT. CHANGED TO PREVENT FROM INFINITE LOOPING *** C************* GOTO 38 GO TO 30 C** C** SKIP PARTICLE, IF NOT ENOUGH ENERGY C** 169 IPA(I)=0 DO 170 J=1,10 170 PV(J,I)=0. GOTO 163 16 CONTINUE NTRI=0 II=0 DO 320 I=1,NT IF(IPA(I).EQ.0) GOTO 320 II=II+1 IPA(II)=IPA(I) SIDE(II)=SIDE(I) DO 321 J=1,10 321 PV(J,II)=PV(J,I) 320 CONTINUE NT=II C** C** BACKWARD NUCLEONS PRODUCED WITH A CLUSTER MODEL C** CALL LOR(MX4,MX3,MX7) CALL SUB(MX7,MX5,MX7) CALL SUB(MX7,MX6,MX7) IF(TARG1.GT.1.5) GOTO 310 322 I=2 CALL NORMAL(RAN) EKIN=TAVAI(2)-EKIN2 EKINM=RS/2.-MP IF(EKIN.GT.EKINM) EKIN=EKINM CALL NORMAL(RAN) IF(EKIN.LT.0.04) EKIN=0.04*ABS(RAN) PV(4,I)=ABS(PV(5,I))+EKIN RNVE=ABS(PV(4,I)**2-PV(5,I)**2) PP=SQRT(RNVE) CALL LENGTX(MX7,PP1) C IF (PP1 .GE. 1.0E-6) GO TO 8004 CALL GRNDM(RNDM,2) RTHNVE=PI*RNDM(1) PHINVE=TWPI*RNDM(2) PV(1,I)=PP*SIN(RTHNVE)*COS(PHINVE) PV(2,I)=PP*SIN(RTHNVE)*SIN(PHINVE) PV(3,I)=PP*COS(RTHNVE) GO TO 8005 8004 CONTINUE PV(1,I)=PV(1,MX7)*PP/PP1 PV(2,I)=PV(2,MX7)*PP/PP1 PV(3,I)=PV(3,MX7)*PP/PP1 8005 CONTINUE C CALL ADD(MX6,I,MX6) GOTO 330 310 ITARG1=IFIX(TARG1+0.1) IF(ITARG1.GT.5) ITARG1=5 RMB0=0. NPG=0 DO 311 I=1,NT IF(SIDE(I).GT.-2.5) GOTO 311 NPG=NPG+1 RMB0=RMB0+ABS(PV(5,I)) 311 CONTINUE IF(NPG.LT.2) GOTO 322 CALL GRNDM(RNDM,1) RAN=RNDM(1) RMB=-LOG(1.-RAN) GPAR=G1PAR(ITARG1) CPAR=C1PAR(ITARG1) RMB=RMB0+RMB**CPAR/GPAR PV(5,MX7)=RMB IF(PV(5,MX7).GT.PV(4,MX7)) PV(5,MX7)=PV(4,MX7) RNVE=ABS(PV(4,MX7)**2-PV(5,MX7)**2) PP=SQRT(RNVE) CALL LENGTX(MX7,PP1) C IF (PP1 .GE. 1.0E-6) GO TO 8006 CALL GRNDM(RNDM,2) RTHNVE=PI*RNDM(1) PHINVE=TWPI*RNDM(2) PV(1,MX7)=PP*SIN(RTHNVE)*COS(PHINVE) PV(2,MX7)=PP*SIN(RTHNVE)*SIN(PHINVE) PV(3,MX7)=PP*COS(RTHNVE) GO TO 8007 8006 CONTINUE PV(1,MX7)=PV(1,MX7)*PP/PP1 PV(2,MX7)=PV(2,MX7)*PP/PP1 PV(3,MX7)=PV(3,MX7)*PP/PP1 8007 CONTINUE C I=MX7 IF (NPRT(4)) WRITE(NEWBCD,2001) I,(PV(J,I),J=1,5) PV(1,MX7)=-PV(1,MX7) PV(2,MX7)=-PV(2,MX7) PV(3,MX7)=-PV(3,MX7) KGENEV=1 TECM=PV(5,MX7) NPG=0 DO 312 I=1,NT IF(SIDE(I).GT.-2.5)GOTO 312 NPG=NPG+1 AMASS(NPG)=ABS(PV(5,I)) 312 CONTINUE CALL PHASP NPG=0 DO 314 I=1,NT IF(SIDE(I).GT.-2.5) GOTO 314 NPG=NPG+1 PV(1,I)=PCM(1,NPG) PV(2,I)=PCM(2,NPG) PV(3,I)=PCM(3,NPG) PV(4,I)=PCM(4,NPG) CALL LOR(I,MX7,I) CALL ADD(MX6,I,MX6) 314 CONTINUE 330 IF (NPRT(4)) $ WRITE(NEWBCD,2002) NTRIAL,EKIN1,EKIN2,TAVAI(1),TAVAI(2) 175 IF (.NOT.NPRT(4)) GOTO 36 CALL ADD(MX5,MX6,MX7) EKIN1=PV(4,MX1)+PV(4,MX2) EKIN2=PV(4,MX5)+PV(4,MX6) WRITE(NEWBCD,2000) EKIN1,EKIN2 I=MX1 WRITE(NEWBCD,2001) I,(PV(J,I),J=1,4) I=MX2 WRITE(NEWBCD,2001) I,(PV(J,I),J=1,4) I=MX5 WRITE(NEWBCD,2001) I,(PV(J,I),J=1,5) I=MX6 WRITE(NEWBCD,2001) I,(PV(J,I),J=1,5) DO 37 I=1,NT 37 WRITE(NEWBCD,2001) I,(PV(J,I),J=1,10),IPA(I),SIDE(I) C** C** LORENTZ TRANSFORMATION IN LAB SYSTEM C** 36 IF(NT.LE.2) GOTO 60 TARG=0. DO 601 I=1,NT IF(PV(5,I).GT.0.5) TARG=TARG+1. CALL LOR(I,MX2,I) 601 CONTINUE IF(TARG.LT.0.5) TARG=1. IF(LEAD.EQ.0) GOTO 6085 DO 6081 I=1,NT IF(ABS(IPA(I)).EQ.LEAD) GOTO 6085 6081 CONTINUE I=1 IF(LEAD.GE.14.AND.ABS(IPA(2)).GE.14) I=2 IF(LEAD.LT.14.AND.ABS(IPA(2)).LT.14) I=2 IPA(I)=LEAD EKIN=PV(4,I)-ABS(PV(5,I)) PV(5,I)=RMASS(LEAD) PV(7,I)=1. IF(PV(5,I).LT.0.) PV(7,I)=-1. PV(5,I)=ABS(PV(5,I)) PV(6,I)=RCHARG(LEAD) PV(4,I)=PV(5,I)+EKIN CALL LENGTX(I,PP) RNVE=ABS(PV(4,I)**2-PV(5,I)**2) PP1=SQRT(RNVE) PV(1,I)=PP1*PV(1,I)/PP PV(2,I)=PP1*PV(2,I)/PP PV(3,I)=PP1*PV(3,I)/PP 6085 KGENEV=1 PV(1,MX4)=0. PV(2,MX4)=0. PV(3,MX4)=P PV(4,MX4)=SQRT(P*P+AMAS*AMAS) PV(5,MX4)=ABS(AMAS) EKIN0=PV(4,MX4)-PV(5,MX4) PV(1,MX5)=0. PV(2,MX5)=0. PV(3,MX5)=0. PV(4,MX5)=MP*TARG PV(5,MX5)=PV(4,MX5) EKIN=PV(4,MX4)+PV(4,MX5) I=MX4 IF (NPRT(4)) WRITE(NEWBCD,2001) I,(PV(J,I),J=1,5) I=MX5 IF (NPRT(4)) WRITE(NEWBCD,2001) I,(PV(J,I),J=1,5) CALL ADD(MX4,MX5,MX6) CALL LOR(MX4,MX6,MX4) CALL LOR(MX5,MX6,MX5) TECM=PV(4,MX4)+PV(4,MX5) NPG=NT PV(1,MX8)=0. PV(2,MX8)=0. PV(3,MX8)=0. PV(4,MX8)=0. PV(5,MX8)=0. EKIN1=0. DO 598 I=1,NPG IF (NPRT(4)) WRITE(NEWBCD,2001) I,(PV(J,I),J=1,10),IPA(I),SIDE(I) CALL ADD(MX8,I,MX8) EKIN1=EKIN1+PV(4,I)-PV(5,I) EKIN=EKIN-PV(5,I) IF(I.GT.18) GOTO 598 AMASS(I)=PV(5,I) 598 CONTINUE IF(NPG.GT.18) GOTO 597 CALL PHASP EKIN=0. DO 599 I=1,NPG PV(1,MX7)=PCM(1,I) PV(2,MX7)=PCM(2,I) PV(3,MX7)=PCM(3,I) PV(4,MX7)=PCM(4,I) PV(5,MX7)=AMASS(I) CALL LOR(MX7,MX5,MX7) 599 EKIN=EKIN+PV(4,MX7)-PV(5,MX7) CALL ANG(MX8,MX4,COST,TETA) IF (NPRT(4)) WRITE(NEWBCD,2003) TETA,EKIN0,EKIN1,EKIN C** C** MAKE SHURE, THAT KINETIC ENERGIES ARE CORRECT. C** EKIN= KINETIC ENERGY THEORETICALLY C** EKIN1= KINETIC ENERGY SIMULATED C** 597 IF(EKIN1.EQ.0.) GOTO 600 PV(1,MX7)=0. PV(2,MX7)=0. PV(3,MX7)=0. PV(4,MX7)=0. PV(5,MX7)=0. WGT=EKIN/EKIN1 EKIN1=0. DO 602 I=1,NT EKIN=PV(4,I)-PV(5,I) EKIN=EKIN*WGT PV(4,I)=EKIN+PV(5,I) RNVE=ABS(PV(4,I)**2-PV(5,I)**2) PP=SQRT(RNVE) CALL LENGTX(I,PP1) C IF (PP1 .GE. 1.0E-6) GO TO 8008 CALL GRNDM(RNDM,2) RTHNVE=PI*RNDM(1) PHINVE=TWPI*RNDM(2) PV(1,I)=PP*SIN(RTHNVE)*COS(PHINVE) PV(2,I)=PP*SIN(RTHNVE)*SIN(PHINVE) PV(3,I)=PP*COS(RTHNVE) GO TO 8009 8008 CONTINUE PV(1,I)=PV(1,I)*PP/PP1 PV(2,I)=PV(2,I)*PP/PP1 PV(3,I)=PV(3,I)*PP/PP1 8009 CONTINUE C EKIN1=EKIN1+EKIN CALL ADD(MX7,I,MX7) 602 CONTINUE CALL ANG(MX7,MX4,COST,TETA) IF (NPRT(4)) WRITE(NEWBCD,2003) TETA,EKIN0,EKIN1 C** C** ROTATE IN DIRECTION OF Z-AXIS, THIS DOES DISTURB IN SOME WAY OUR C** INCLUSIVE DISTRIBUTIONS, BUT IT IS NESSACARY FOR MOMENTUM CONSER- C** VATION. C** 600 PV(1,MX7)=0. PV(2,MX7)=0. PV(3,MX7)=0. PV(4,MX7)=0. PV(5,MX7)=0. DO 596 I=1,NT CALL ADD(MX7,I,MX7) 596 CONTINUE C** C** SOME SMEARING IN TRANSVERSE DIRECTION FROM FERMI MOTION C** * CALL RANNOR(RAN1,RAN2) CALL GRNDM(RNDM,2) RY=RNDM(1) RZ=RNDM(2) RX=6.283185*RZ A1=SQRT(-2.*LOG(RY)) RAN1=A1*SIN(RX) RAN2=A1*COS(RX) PV(1,MX7)=PV(1,MX7)+RAN1*0.020*TARG PV(2,MX7)=PV(2,MX7)+RAN2*0.020*TARG CALL DEFS(MX4,MX7,MX8) PV(1,MX7)=0. PV(2,MX7)=0. PV(3,MX7)=0. PV(4,MX7)=0. PV(5,MX7)=0. DO 595 I=1,NT CALL TRAC(I,MX8,I) CALL ADD(MX7,I,MX7) 595 CONTINUE CALL ANG(MX7,MX4,COST,TETA) IF (NPRT(4)) WRITE(NEWBCD,2003) TETA C** C** ROTATE IN DIRECTION OF PRIMARY PARTICLE, SUBTRACT BINDING ENERGIES C** AND MAKE SOME FURTHER CORRECTIONS IF REQUIRED (STEEP, STEEQ) C** DEKIN=0. NPIONS=0 EK1=0. DO 21 I=1,NT CALL DEFS1(I,MXGKPV-1,I) IF (NPRT(4)) WRITE(NEWBCD,2001) I,(PV(J,I),J=1,10),IPA(I),SIDE(I) IF(ATNO2.LT.1.5) GOTO 21 CALL LENGTX(I,PP) EKIN=PV(4,I)-ABS(PV(5,I)) CALL NORMAL(RAN) EKIN=EKIN-CFA*(1.+0.5*RAN) IF (EKIN .LT. 1.0E-6) EKIN=1.0E-6 CALL STEEQ(XXH,I) DEKIN=DEKIN+EKIN*(1.-XXH) EKIN=EKIN*XXH IF(ABS(IPA(I)).GE.7.AND.ABS(IPA(I)).LE.9) NPIONS=NPIONS+1 IF(ABS(IPA(I)).GE.7.AND.ABS(IPA(I)).LE.9) EK1=EK1+EKIN PP1=SQRT(EKIN*(EKIN+2.*ABS(PV(5,I)))) PV(4,I)=EKIN+ABS(PV(5,I)) C IF (PP .GE. 1.0E-6) GO TO 8010 CALL GRNDM(RNDM,2) RTHNVE=PI*RNDM(1) PHINVE=TWPI*RNDM(2) PV(1,I)=PP1*SIN(RTHNVE)*COS(PHINVE) PV(2,I)=PP1*SIN(RTHNVE)*SIN(PHINVE) PV(3,I)=PP1*COS(RTHNVE) GO TO 8011 8010 CONTINUE PV(1,I)=PV(1,I)*PP1/PP PV(2,I)=PV(2,I)*PP1/PP PV(3,I)=PV(3,I)*PP1/PP 8011 CONTINUE C 21 CONTINUE IF(EK1.EQ.0.) GOTO 23 IF(NPIONS.EQ.0) GOTO 23 DEKIN=1.+DEKIN/EK1 DO 22 I=1,NT IF(ABS(IPA(I)).LT.7.OR.ABS(IPA(I)).GT.9) GOTO 22 CALL LENGTX(I,PP) EKIN=PV(4,I)-ABS(PV(5,I)) EKIN=EKIN*DEKIN IF (EKIN .LT. 1.0E-6) EKIN=1.0E-6 PP1=SQRT(EKIN*(EKIN+2.*ABS(PV(5,I)))) PV(4,I)=EKIN+ABS(PV(5,I)) C IF (PP .GE. 1.0E-6) GO TO 8012 CALL GRNDM(RNDM,2) RTHNVE=PI*RNDM(1) PHINVE=TWPI*RNDM(2) PV(1,I)=PP1*SIN(RTHNVE)*COS(PHINVE) PV(2,I)=PP1*SIN(RTHNVE)*SIN(PHINVE) PV(3,I)=PP1*COS(RTHNVE) GO TO 8013 8012 CONTINUE PV(1,I)=PV(1,I)*PP1/PP PV(2,I)=PV(2,I)*PP1/PP PV(3,I)=PV(3,I)*PP1/PP 8013 CONTINUE C 22 CONTINUE C** C** ADD BLACK TRACK PARTICLES, THE TOTAL NUMBER OF PARTICLES PRODUCED C** IS RESTRICTED TO 198, THIS MAY HAVE INFLUENCE ON VERY HIGH ENERGY C** FIRST PROTONS AND NEUTRONS C** 23 IF(ATNO2.LT.1.5) GOTO 40 CALL SELFAB(SPROB) TEX=ENP(1) SPALL=TARG IF(TEX.LT.0.001) GOTO 445 BLACK=(1.5+1.25*TARG)*ENP(1)/(ENP(1)+ENP(3)) CALL POISSO(BLACK,NBL) IF (NPRT(4)) WRITE(NEWBCD,3003) NBL,TEX IF(IFIX(TARG)+NBL.GT.ATNO2) NBL=ATNO2-TARG IF(NT+NBL.GT.MXGKPV-10) NBL=MXGKPV-10-NT IF(NBL.LE.0) GOTO 445 EKIN=TEX/NBL EKIN2=0. CALL STEEP(XX) DO 441 I=1,NBL CALL GRNDM(RNDM,1) IF(RNDM(1).LT.SPROB) GOTO 441 IF(NT.EQ.MXGKPV-10) GOTO 441 IF(EKIN2.GT.TEX) GOTO 443 CALL GRNDM(RNDM,1) RAN1=RNDM(1) CALL NORMAL(RAN2) EKIN1=-EKIN*LOG(RAN1)-CFA*(1.+0.5*RAN2) IF(EKIN1.LT.0.0) EKIN1=-0.010*LOG(RAN1) EKIN1=EKIN1*XX EKIN2=EKIN2+EKIN1 IF(EKIN2.GT.TEX) EKIN1=TEX-(EKIN2-EKIN1) IF (EKIN1 .LT. 0.0) EKIN1=1.0E-6 IPA1=16 PNRAT=1.-ZNO2/ATNO2 CALL GRNDM(RNDM,3) IF(RNDM(1).GT.PNRAT) IPA1=14 NT=NT+1 SPALL=SPALL+1. COST=-1.+RNDM(2)*2. SINT=SQRT(ABS(1.-COST*COST)) PHI=TWPI*RNDM(3) IPA(NT)=-IPA1 SIDE(NT)=-4. PV(5,NT)=ABS(RMASS(IPA1)) PV(6,NT)=RCHARG(IPA1) PV(7,NT)=1. PV(4,NT)=EKIN1+PV(5,NT) RNVE=ABS(PV(4,NT)**2-PV(5,NT)**2) PP=SQRT(RNVE) PV(1,NT)=PP*SINT*SIN(PHI) PV(2,NT)=PP*SINT*COS(PHI) PV(3,NT)=PP*COST 441 CONTINUE 443 IF(ATNO2.LT.10.) GOTO 445 IF(EK.GT.2.0) GOTO 445 II=NT+1 KK=0 EKA=EK IF(EKA.GT.1.) EKA=EKA*EKA IF(EKA.LT.0.1) EKA=0.1 IKA=3.6*EXP((ZNO2**2/ATNO2-35.56)/6.45)/EKA IF(IKA.LE.0) GO TO 445 DO 444 I=1,NT II=II-1 IF(IPA(II).NE.-14) GOTO 444 IPA(II)=-16 IPA1 = 16 PV(5,II)=ABS(RMASS(IPA1)) PV(6,II)=RCHARG(IPA1) KK=KK+1 IF(KK.GT.IKA) GOTO 445 444 CONTINUE C** C** THEN ALSO DEUTERONS, TRITONS AND ALPHAS C** 445 TEX=ENP(3) IF(TEX.LT.0.001) GOTO 40 BLACK=(1.5+1.25*TARG)*ENP(3)/(ENP(1)+ENP(3)) CALL POISSO(BLACK,NBL) IF(NT+NBL.GT.MXGKPV-10) NBL=MXGKPV-10-NT IF(NBL.LE.0) GOTO 40 EKIN=TEX/NBL EKIN2=0. CALL STEEP(XX) IF (NPRT(4)) WRITE(NEWBCD,3004) NBL,TEX DO 442 I=1,NBL CALL GRNDM(RNDM,1) IF(RNDM(1).LT.SPROB) GOTO 442 IF(NT.EQ.MXGKPV-10) GOTO 442 IF(EKIN2.GT.TEX) GOTO 40 CALL GRNDM(RNDM,1) RAN1=RNDM(1) CALL NORMAL(RAN2) EKIN1=-EKIN*LOG(RAN1)-CFA*(1.+0.5*RAN2) IF(EKIN1.LT.0.0) EKIN1=-0.010*LOG(RAN1) EKIN1=EKIN1*XX EKIN2=EKIN2+EKIN1 IF(EKIN2.GT.TEX) EKIN1=TEX-(EKIN2-EKIN1) IF (EKIN1 .LT. 0.0) EKIN1=1.0E-6 CALL GRNDM(RNDM,3) COST=-1.+RNDM(1)*2. SINT=SQRT(ABS(1.-COST*COST)) PHI=TWPI*RNDM(2) RAN=RNDM(3) IPA(NT+1)=-30 IF(RAN.GT.0.60) IPA(NT+1)=-31 IF(RAN.GT.0.90) IPA(NT+1)=-32 SIDE(NT+1)=-4. PV(5,NT+1)=(ABS(IPA(NT+1))-28)*MP SPALL=SPALL+PV(5,NT+1)*1.066 IF(SPALL.GT.ATNO2) GOTO 40 NT=NT+1 PV(6,NT)=1. IF(IPA(NT).EQ.-32) PV(6,NT)=2. PV(7,NT)=1. PV(4,NT)=PV(5,NT)+EKIN1 RNVE=ABS(PV(4,NT)**2-PV(5,NT)**2) PP=SQRT(RNVE) PV(1,NT)=PP*SINT*SIN(PHI) PV(2,NT)=PP*SINT*COS(PHI) PV(3,NT)=PP*COST 442 CONTINUE C** C** STORE ON EVENT COMMON C** 40 CALL GRNDM(RNDM,1) IF(RS.GT.(4.+RNDM(1))) GOTO 42 DO 41 I=1,NT CALL LENGTX(I,ETB) IF(ETB.LT.P) GOTO 41 ETF=P PV(4,I)=SQRT(PV(5,I)**2+ETF**2) ETF=ETF/ETB PV(1,I)=PV(1,I)*ETF PV(2,I)=PV(2,I)*ETF PV(3,I)=PV(3,I)*ETF 41 CONTINUE 42 EKIN=PV(4,MXGKPV)-ABS(PV(5,MXGKPV)) EKIN1=PV(4,MXGKPV-1)-ABS(PV(5,MXGKPV-1)) EKIN2=0. CALL TDELAY(TOF1) CALL GRNDM(RNDM,1) RAN=RNDM(1) TOF=TOF-TOF1*LOG(RAN) DO 44 I=1,NT EKIN2=EKIN2+PV(4,I)-ABS(PV(5,I)) IF(PV(7,I).LT.0.) PV(5,I)=-PV(5,I) PV(7,I)=TOF PV(8,I)=ABS(IPA(I)) PV(9,I)=0. 44 PV(10,I)=0. IF (NPRT(4)) WRITE(NEWBCD,2006) NT,EKIN,ENP(1),ENP(3),EKIN1,EKIN2 INTCT=INTCT+1. CALL SETCUR(NT) NTK=NTK+1 IF(NT.EQ.1) GO TO 9999 DO 50 II=2,NT I=II-1 IF(NTOT.LT.NSIZE/12) GOTO 43 GO TO 9999 43 CALL SETTRK(I) 50 CONTINUE C 2002 FORMAT(' *GENXPT* PRODUCTION OF FINAL STATE KINEMATIC AFTER ',I3, $ ' TRIALS.',/,' KINETIC ENERGIES ',2F6.2,' OUT OF ',2F6.2) 2000 FORMAT(' *GENXPT* CMS PARAMETERS OF FINAL STATE PARTICLES,',/, $ ' ENERGIES IN INITIAL AND FINAL STATE ',2F6.2) 2001 FORMAT(' *GENXPT* TRACK',2X,I3,2X,10F8.3,2X,I3,2X,F4.0) 2003 FORMAT(' *GENXPT* TETA,EKIN0,EKIN1,EKIN ',4F10.4) 2006 FORMAT(' *GENXPT* COMP.',1X,I5,1X,5F7.2) 3001 FORMAT(' *GENXPT* NUCLEAR EXCITATION',I5, $ ' PARTICLES PRODUCED IN ADDITION TO ',I5,' NORMAL PARTICLES') 3002 FORMAT(' *GENXPT* AVAILABLE ENERGIES ',2F10.4, $ ' FOR ',2I3,' PARTICLES IN BEAM/TARGET FRAGM. REGION', $ ' WITH IPA/SIDE ARRAY '/ $ 1H ,5X,10(I3,2X,F3.0,4X)) 3003 FORMAT(' *GENXPT* ',I3,' BLACK TRACK PARTICLES PRODUCED', $ ' WITH TOTAL KINETIC ENERGY OF ',F8.3,' GEV') 3004 FORMAT(' *GENXPT* ',I5,' HEAVY FRAGMENTS PRODUCED', $ ' WITH TOTAL ENERGY OF',F8.4,' GEV') C 9999 CONTINUE C RETURN END *CMZ : 3.16/00 05/11/93 19.31.20 BY FEDERICO CARMINATI *-- AUTHOR : C--------------------------------------------------------------------- SUBROUTINE GHEPEC(LEDPAR) C** C** MOMENTUM CONSERVATION AT HIGH ENERGIES C** PARAMETER (MXGKGH=100) COMMON/PRNTFL/INBCD,NEWBCD,INBIN,NEWBIN,NPEVT,NEVTP,LPRT,NPRT(10) LOGICAL LPRT,NPRT C PARAMETER (MXGKPV=MXGKGH) COMMON /VECUTY/ PV(10,MXGKPV) C C DOUBLE PRECISION AHMF,BHMF SAVE C** IF(LEDPAR.LE.0) RETURN C** MX=MXGKPV-10 MX5=MX+5 MX6=MX+6 MX7=MX+7 MX9=MX+9 C** C** APPLY CORRECTION ON LEADING PARTICLE C** IF(NPRT(4)) $ WRITE(NEWBCD,1002) LEDPAR,(PV(J,LEDPAR),J=1,10) C** CALL SUB3(MX9,MXGKPV,MX5) CALL ANG(MXGKPV,LEDPAR,COST,TETA) CALL LENGTX(LEDPAR,PPP) PTLED=PPP*SQRT(1.-COST**2) CALL SUB3(LEDPAR,MX5,LEDPAR) CALL ANG(MXGKPV,LEDPAR,COST,TETA) CALL LENGTX(LEDPAR,PPP) PPP=PPP*COST CALL LENGTX(MXGKPV,PBEAM) PV(1,MX6)=PV(1,MXGKPV)*PPP/PBEAM PV(2,MX6)=PV(2,MXGKPV)*PPP/PBEAM PV(3,MX6)=PV(3,MXGKPV)*PPP/PBEAM CALL CROSS3(MXGKPV,LEDPAR,MX7) CALL CROSS3(MX7,MXGKPV,MX7) CALL LENGTX(MX7,PPP) CDH TO AVOID DIVISION BY 0, SET PPP TO A SMALL POSITIVE VALUE IF ( PPP .LE. 0. ) PPP = 1.E-20 PV(1,MX7)=PV(1,MX7)*PTLED/PPP PV(2,MX7)=PV(2,MX7)*PTLED/PPP PV(3,MX7)=PV(3,MX7)*PTLED/PPP CALL ADD3(MX6,MX7,LEDPAR) CALL LENGTX(LEDPAR,PPP) AHMF=PPP BHMF=PV(5,LEDPAR) PV(4,LEDPAR)=DSQRT(AHMF**2+BHMF**2) C** IF(NPRT(4)) THEN WRITE(NEWBCD,1003) LEDPAR,(PV(J,LEDPAR),J=1,10) ENDIF C** RETURN 1002 FORMAT(1H ,'*GHEPEC* LEADING PARTICLE ',I3,2X,10F8.3) 1003 FORMAT(1H ,'*GHEPEC* CORRECTED 4-VECT ',I3,2X,10F8.3) END *CMZ : 3.16/00 05/11/93 19.46.20 BY FEDERICO CARMINATI *-- AUTHOR : C--------------------------------------------------------------------- SUBROUTINE GHETUN(NT) C** C** TUNING OF THE HIGH ENERGY COLLISION MODEL: C** C** 1. AVOID THAT PI0 IS LEADING PARTICLE. C** 2. SOME FINE-TUNING FOR THE NUMBER OF PRODUCED PROTONS AND C** NEUTRONS. C** 3. INTRODUCE A FLAVOUR DEPENDENT CORRECTION FOR SINGLE PARTICLE C** SPECTRA. C** 4. FINE-TUNING OF LEADING PARTICLE SPECTRA AND MOMENTUM C** CONSERVATION. C** PARAMETER (MXGKGH=100) COMMON/CONSTS/ PI,TWPI,PIBTW,MP,MPI,MMU,MEL,MKCH,MK0,SMP,SMPI, $ SMU,CT,CTKCH,CTK0, $ ML0,MSP,MS0,MSM,MX0,MXM,CTL0,CTSP,CTSM,CTX0,CTXM, $ RMASS(35),RCHARG(35) C REAL MP,MPI,MMU,MEL,MKCH,MK0, * ML0,MSP,MS0,MSM,MX0,MXM C PARAMETER (MXGKCU=MXGKGH) COMMON/CURPAR/WEIGHT(10),DDELTN,IFILE,IRUN,NEVT,NEVENT,SHFLAG, * ITHST,ITTOT,ITLST,IFRND,TOFCUT,CMOM(5),CENG(5), * RS,S,ENP(10),NP,NM,NN,NR,NO,NZ,IPA(MXGKCU), * ATNO2,ZNO2 C COMMON/RESULT/XEND,YEND,ZEND,RCA,RCE,AMAS,NCH,TOF,PX,PY,PZ, * USERW,INTCT,P,EN,EK,AMASQ,DELTN,ITK,NTK,IPART,IND, * LCALO,ICEL,SINL,COSL,SINP,COSP, * XOLD,YOLD,ZOLD,POLD,PXOLD,PYOLD,PZOLD, * XSCAT,YSCAT,ZSCAT,PSCAT,PXSCAT,PYSCAT,PZSCAT REAL NCH,INTCT C COMMON/PRNTFL/INBCD,NEWBCD,INBIN,NEWBIN,NPEVT,NEVTP,LPRT,NPRT(10) LOGICAL LPRT,NPRT C PARAMETER (MXGKPV=MXGKGH) COMMON /VECUTY/ PV(10,MXGKPV) C C C DOUBLE PRECISION AHMF,BHMF DIMENSION RNDM(4),SNUM(34),BNUM(34),REDDEC(7) SAVE DATA SNUM/9*0.,1.,0.,0.,-1.,4*0.,-1.,1.,-1.,-1.,-1.,1.,1.,1., $ -2.,-2.,2.,2.,3*0.,-3.,3./ DATA BNUM/13*0.,1.,-1.,1.,-1.,1.,-1.,1.,1.,1.,-1.,-1.,-1., $ 1.,1.,-1.,-1.,2.,3.,4.,1.,-1./ C** MX=MXGKPV-10 MX1=MX+1 MX2=MX+2 MX3=MX+3 MX4=MX+4 MX5=MX+5 MX6=MX+6 MX7=MX+7 MX8=MX+8 MX9=MX+9 NT1=NT IF(NT1.GT.MXGKPV-10) NT1=MXGKPV-10 NT=NT1 C CALL GRNDM(RNDM,1) IF(EK.LT.(25.+RNDM(1)*75.)) GOTO 15 C C** IF PI0 IS THE HIGHEST MOMENTUM PARTICLE, INTERCHANGE IT WITH A C** CHARGED PION. C CALL GRNDM(RNDM,4) REDEN = -0.7 + 0.29*LOG10(EK) REDAT = 1. - 0.4000*LOG10(ATNO2) PMAX = -200. PMAPIP= -200. PMAPI0= -200. PMAPIM= -200. IPMAX = 0 MAXPIP= 0 MAXPI0= 0 MAXPIM= 0 IF(RNDM(1).GT.(ATNO2/100.-0.28).AND.ABS(NCH).GT.0.5) THEN DO 46 I=1,NT1 IPHMF=IFIX(PV(8,I)+0.1) CALL LENGTX(I,PPP) IF(PPP.GT.PMAX) THEN PMAX=PPP IPMAX=I ENDIF IF(IPHMF.EQ.7) THEN IF(PPP.GT.PMAPIP) THEN PMAPIP=PPP MAXPIP=I ENDIF ENDIF IF(IPHMF.EQ.8) THEN IF(PPP.GT.PMAPI0) THEN PMAPI0=PPP MAXPI0=I ENDIF ENDIF IF(IPHMF.EQ.9) THEN IF(PPP.GT.PMAPIM) THEN PMAPIM=PPP MAXPIM=I ENDIF ENDIF 46 CONTINUE ENDIF C** C** SOME ADDITIONAL TUNING OF THE NUMBER OF GREY TRACK PARTICLES C** IF(NT1.GT.2) THEN DO 47 I=3,NT1 IPHMF=IFIX(PV(8,I)+0.1) IF(IPHMF.EQ.14.OR.IPHMF.EQ.16.OR.IPHMF.GE.30) THEN CALL LENGTX(I,PPP) IF(PPP.LT.1.5) THEN IF(RNDM(2).LT.REDEN.OR.RNDM(3).LT.REDAT) THEN PV(1,I) = 0. PV(2,I) = 0. PV(3,I) = 0. PV(4,I) = ABS(PV(5,I)) ENDIF ENDIF ENDIF 47 CONTINUE ENDIF C** IF(MAXPI0.EQ.0) GOTO 10 IF(PMAPI0.LT.PMAX) GOTO 10 IF(RNDM(4).LT.PMAPI0/P) THEN IF(NCH.GT.0.5.AND.MAXPIP.NE.0) THEN DO 49 J=5,10 PV(J,MX1)=PV(J,MAXPI0) PV(J,MAXPI0)=PV(J,MAXPIP) PV(J,MAXPIP)=PV(J,MX1) 49 CONTINUE ENDIF IF(NCH.LT.-0.5.AND.MAXPIM.NE.0) THEN DO 56 J=5,10 PV(J,MX1)=PV(J,MAXPI0) PV(J,MAXPI0)=PV(J,MAXPIM) PV(J,MAXPIM)=PV(J,MX1) 56 CONTINUE ENDIF ENDIF C 10 CONTINUE C** C** CHECK TOTAL BARYON- NUMBER AND C** SKIP ZERO MOMENTUM PARTICLES C** BNTOT=-BNUM(IPART)-ATNO2 DO 57 I=1,NT1 IPHMF=IFIX(PV(8,I)+0.1) BNTOT=BNTOT+BNUM(IPHMF) 57 CONTINUE BNTOT=1.+BNTOT/ATNO2 IF(ATNO2.LT.1.5) BNTOT=0. CALL GRNDM(RNDM,1) IF(ATNO2.GT.(75.+RNDM(1)*25.)) BNTOT=0. C** II=0 DO 12 I=1,NT1 CALL LENGTX(I,PPP) IF(PPP.GT.1.E-6) THEN IPHMF=IFIX(PV(8,I)+0.1) IF(BNTOT.GT.0.3) THEN IF(IPHMF.EQ.14.OR.IPHMF.EQ.16.OR.IPHMF.GE.30) THEN CALL GRNDM(RNDM,1) IF(RNDM(1).LT.0.5.AND.PPP.LT.1.2) GOTO 12 ENDIF ENDIF II=II+1 DO 11 J=1,10 PV(J,II)=PV(J,I) 11 CONTINUE ENDIF 12 CONTINUE NT1=II NT=NT1 C** C** EXACT MOMENTUM CONSERVATION AND SOME CORRECTIONS FOR SINGLE C** PARTICLE SPECTRA AT HIGH ENERGIES ONLY C 15 PV(1,MX1) = P*PX PV(2,MX1) = P*PY PV(3,MX1) = P*PZ PV(4,MX1) = EN PV(5,MX1) = ABS(AMAS) PV(6,MX1) = NCH PV(1,MX2) = 0. PV(2,MX2) = 0. PV(3,MX2) = 0. PV(4,MX2) = MP PV(5,MX2) = MP PV(6,MX2) = 0. C IF(NPRT(4)) THEN WRITE(NEWBCD,2000) WRITE(NEWBCD,2001) MX1,(PV(J,MX1),J=1,6) WRITE(NEWBCD,2001) MX2,(PV(J,MX2),J=1,6) ENDIF C DO 58 J=1,10 PV(J,MX9) = 0. 58 CONTINUE CALL ADD(MX1,MX2,MX3) CALL LOR(MX1,MX3,MX4) CALL LOR(MX2,MX3,MX5) LEDPAR=0 REDPAR=0. GESPAR=0. SNUM1=SNUM(IPART) IF(IPART.EQ.11.OR.IPART.EQ.12) THEN CALL GRNDM(RNDM,1) SNUM1=1. IF(RNDM(1).LT.0.5) SNUM1=-1. ENDIF DO 20 I=1,NT1 IPHMF=IFIX(PV(8,I)+0.1) IF(IPHMF.LE.6.OR.IPHMF.GT.32) GOTO 19 CALL LENGTX(I,PPP) IF(PPP.LT.1.E-3) GOTO 19 CALL LOR(I,MX3,MX6) CALL ANG(MX4,MX6,COST,TETA) SNUM2=SNUM(IPHMF) IF(IPHMF.EQ.11.OR.IPHMF.EQ.12) THEN CALL GRNDM(RNDM,1) SNUM2=1. IF(RNDM(1).LT.0.5) SNUM2=-1. ENDIF IF(COST.GT.0.) THEN HFMAS=ABS(AMAS) REDDEC(1)=ABS(HFMAS -ABS(PV(5,I))) REDDEC(2)=ABS(NCH-PV(6,I)) REDDEC(3)=ABS(SNUM1 -SNUM2) REDDEC(4)=ABS(BNUM(IPART)-BNUM(IPHMF)) ELSE HFMAS=MP REDDEC(1)=ABS(HFMAS -ABS(PV(5,I))) REDDEC(2)=ABS(ZNO2/ATNO2-PV(6,I)) REDDEC(3)=ABS(SNUM2) REDDEC(4)=ABS(1.-BNUM(IPHMF)) ENDIF REDDEC(6)=REDDEC(1)+REDDEC(2)+REDDEC(3)+REDDEC(4) SBQWGT=REDDEC(6) IF(HFMAS.LT.0.2) THEN SBQWGT=(SBQWGT-2.5)*0.10 IF(IPHMF.EQ.8) SBQWGT=0.15 ELSE IF (HFMAS.LT.0.6) THEN SBQWGT=(SBQWGT-3.0)*0.10 ELSE SBQWGT=(SBQWGT-2.0)*0.10 IF(IPHMF.EQ.8) SBQWGT=0.15 ENDIF CALL LENGTX(MX6,PPP) IF(SBQWGT.GT.0. .AND. PPP.GT.1.E-6) THEN PLHMF=PPP*COST PTHMF=PPP*SQRT(1.-COST*COST) PLHMF=PLHMF*(1.-SBQWGT) CALL CROSS3(MX4,MX6,MX8) CALL CROSS3(MX8,MX4,MX8) CALL LENGTX(MX4,PPP) PV(1,MX7)=PV(1,MX4)*PLHMF/PPP PV(2,MX7)=PV(2,MX4)*PLHMF/PPP PV(3,MX7)=PV(3,MX4)*PLHMF/PPP CALL LENGTX(MX8,PPP) PV(1,MX8)=PV(1,MX8)*PTHMF/PPP PV(2,MX8)=PV(2,MX8)*PTHMF/PPP PV(3,MX8)=PV(3,MX8)*PTHMF/PPP CALL ADD3(MX7,MX8,MX6) CALL LENGTX(MX6,PPP) AHMF=PPP BHMF=PV(5,I) PV(4,MX6)=DSQRT(AHMF**2+BHMF**2) C IF(NPRT(4)) $ WRITE(NEWBCD,3001) I,(PV(J,I),J=1,8),SBQWGT C CALL LOR(MX6,MX5,I) C IF(NPRT(4)) $ WRITE(NEWBCD,3001) I,(PV(J,I),J=1,8),SBQWGT ENDIF C IF(IPHMF.EQ.8) GOTO 19 CALL SUB3(MXGKPV,I,MX8) CALL LENGTX(MX8,PPP) REDDEC(5) = PPP/P REDDEC(7)=REDDEC(5)*2./3. + REDDEC(6)/12. REDDEC(7) = 1.-REDDEC(7) IF(REDDEC(7) .LT. 0.) REDDEC(7) = 0. GESPAR=GESPAR+REDDEC(7) IF(REDDEC(6).LE.3.75) THEN IF(REDDEC(7) .GT. REDPAR) THEN LEDPAR=I REDPAR=REDDEC(7) ENDIF ENDIF IF(NPRT(4)) $ WRITE(NEWBCD,2001) I,(PV(J,I),J=1,6),PV(8,I),REDDEC C 19 CALL ADD3(MX9,I,MX9) C 20 CONTINUE IF(NPRT(4)) $ WRITE(NEWBCD,1001) LEDPAR,REDPAR,GESPAR C** C** APPLY CORRECTION ON LEADING PARTICLE C** CALL GHEPEC(LEDPAR) C** RETURN 1001 FORMAT(1H ,'*GHETUN* ', $ 'SEARCH FOR LEADING PARTICLE, WEIGHT, TOTAL WEIGHT ', $ I5,3X,2F10.4) 2000 FORMAT(1H ,'*GHETUN* MOMENTUM CONSERVATION AT HIGH ENERGIES: ') 2001 FORMAT(1H ,I3,2X,7F8.3/1H ,5X,7F8.3) 3001 FORMAT(1H ,I3,2X,5F8.3,F5.1,F8.3,F5.1,F8.3) END *CMZU: 3.16/00 01/10/93 08.40.24 BY FEDERICO CARMINATI *-- AUTHOR : C--------------------------------------------------------------------- SUBROUTINE GNSLWD(NUCFLG,INT,NFL,TEKLOW) C C *** NEUTRON TRACKING ROUTINE FOR ENERGIES BELOW THE CUT-OFF. *** C *** TAKE ONLY ELASTIC SCATTERING, NEUTRON CAPTURE *** C *** AND NUCLEAR FISSION. *** C *** NVE 11-MAY-1988 CERN GENEVA *** C C CALLED BY : GHEISH C ORIGIN : H.FESEFELDT (ROUTINE NSLDOW 20-OCT-1987) C PARAMETER (MAXMEC=30) COMMON/GCTRAK/VECT(7),GETOT,GEKIN,VOUT(7),NMEC,LMEC(MAXMEC) + ,NAMEC(MAXMEC),NSTEP ,MAXNST,DESTEP,DESTEL,SAFETY,SLENG + ,STEP ,SNEXT ,SFIELD,TOFG ,GEKRAT,UPWGHT,IGNEXT,INWVOL + ,ISTOP ,IGAUTO,IEKBIN, ILOSL, IMULL,INGOTO,NLDOWN,NLEVIN + ,NLVSAV,ISTORY PARAMETER (MAXME1=30) COMMON/GCTPOL/POLAR(3), NAMEC1(MAXME1) C C --- GHEISHA COMMONS --- PARAMETER (MXGKGH=100) COMMON/CONSTS/ PI,TWPI,PIBTW,MP,MPI,MMU,MEL,MKCH,MK0,SMP,SMPI, $ SMU,CT,CTKCH,CTK0, $ ML0,MSP,MS0,MSM,MX0,MXM,CTL0,CTSP,CTSM,CTX0,CTXM, $ RMASS(35),RCHARG(35) C REAL MP,MPI,MMU,MEL,MKCH,MK0, * ML0,MSP,MS0,MSM,MX0,MXM C PARAMETER (MXGKCU=MXGKGH) COMMON/CURPAR/WEIGHT(10),DDELTN,IFILE,IRUN,NEVT,NEVENT,SHFLAG, * ITHST,ITTOT,ITLST,IFRND,TOFCUT,CMOM(5),CENG(5), * RS,S,ENP(10),NP,NM,NN,NR,NO,NZ,IPA(MXGKCU), * ATNO2,ZNO2 C COMMON/RESULT/XEND,YEND,ZEND,RCA,RCE,AMAS,NCH,TOF,PX,PY,PZ, * USERW,INTCT,P,EN,EK,AMASQ,DELTN,ITK,NTK,IPART,IND, * LCALO,ICEL,SINL,COSL,SINP,COSP, * XOLD,YOLD,ZOLD,POLD,PXOLD,PYOLD,PZOLD, * XSCAT,YSCAT,ZSCAT,PSCAT,PXSCAT,PYSCAT,PZSCAT REAL NCH,INTCT C PARAMETER (MXGKPV=MXGKGH) COMMON /VECUTY/ PV(10,MXGKPV) C COMMON/PRNTFL/INBCD,NEWBCD,INBIN,NEWBIN,NPEVT,NEVTP,LPRT,NPRT(10) LOGICAL LPRT,NPRT C DIMENSION RNDM(2) SAVE C C --- FLAGS TO INDICATE THE NUCREC ACTION --- C NUCFLG = 0 ==> NO ACTION BY NUCREC C 1 ==> ACTION BY NUCREC ==> SPECIAL TREATMENT IN GHEISH NOPT=0 NUCFLG=0 C C --- IN ORDER TO AVOID TROUBLES CAUSED BY ARITHMETIC INCERTAINTIES, --- C --- RECALCULATE SOME QUANTITIES. TAKE KINETIC ENERGY EK AS MOST --- C --- RELEVANT QUANTITY. --- C C --- VERY LOW KINETIC ENERGY ==> NEUTRON CAPTURE --- IF (EK .LT. 1.E-9) GO TO 22 C EN=EK+ABS(AMAS) P=SQRT(ABS(EN*EN-AMAS*AMAS)) PU=SQRT(PX**2+PY**2+PZ**2) IF (PU .GE. 1.E-9) GO TO 7 C PX=0.0 PY=0.0 PZ=0.0 GO TO 22 C 7 CONTINUE PX=PX/PU PY=PY/PU PZ=PZ/PU C C --- SELECT PROCESS ACCORDING TO "INT" --- GO TO (23,23,21,22), INT C C *** NUCLEAR FISSION *** 21 CONTINUE ISTOP=1 TKIN=FISSIO(EK) GO TO 9999 C C *** NEUTRON CAPTURE *** 22 CONTINUE ISTOP=1 CALL CAPTUR(NOPT) GO TO 9999 C C *** ELASTIC AND INELASTIC SCATTERING *** 23 CONTINUE PV( 1,MXGKPV)=P*PX PV( 2,MXGKPV)=P*PY PV( 3,MXGKPV)=P*PZ PV( 4,MXGKPV)=EN PV( 5,MXGKPV)=AMAS PV( 6,MXGKPV)=NCH PV( 7,MXGKPV)=TOF PV( 8,MXGKPV)=IPART PV( 9,MXGKPV)=0.0 PV(10,MXGKPV)=USERW C C --- SPECIAL TREATMENT FOR INELASTIC SCATTERING IN HEAVY MEDIA --- IF ((INT .EQ. 2) .AND. (ATNO2 .GE. 1.5)) GO TO 29 C C *** ELASTIC SCATTERING *** 30 CONTINUE C IF (NPRT(9)) PRINT 1000 1000 FORMAT(' *GNSLWD* ELASTIC SCATTERING') C DO 24 J=4,9 PV(J,1)=PV(J,MXGKPV) 24 CONTINUE PV(10,1)=0.0 C C --- VERY SIMPLE SIMULATION OF SCATTERING ANGLE AND ENERGY --- C --- NONRELATIVISTIC APPROXIMATION WITH ISOTROPIC ANGULAR --- C --- DISTRIBUTION IN THE CMS SYSTEM --- 25 CALL GRNDM(RNDM,2) RAN=RNDM(1) COST1=-1.0+2.0*RAN EKA=1.0+2.0*COST1*ATNO2+ATNO2**2 IF(EKA.LE.0.) GOTO 25 COST=(ATNO2*COST1+1.0)/SQRT(EKA) IF (COST .LT. -1.0) COST=-1.0 IF (COST .GT. 1.0) COST=1.0 EKA=EKA/(1.0+ATNO2)**2 EK=EK*EKA EN=EK+ABS(AMAS) P=SQRT(ABS(EN*EN-AMAS*AMAS)) SINT=SQRT(ABS(1.0-COST*COST)) PHI=RNDM(2)*TWPI PV(1,2)=SINT*SIN(PHI) PV(2,2)=SINT*COS(PHI) PV(3,2)=COST CALL DEFS1(2,MXGKPV,2) PU=SQRT(PV(1,2)**2+PV(2,2)**2+PV(3,2)**2) PX=PV(1,2)/PU PY=PV(2,2)/PU PZ=PV(3,2)/PU PV(1,1)=PX*P PV(2,1)=PY*P PV(3,1)=PZ*P PV(4,1)=EN C C --- STORE BACKSCATTERED PARTICLE FOR ATNO < 4.5 --- IF (ATNO2 .GT. 4.5) GO TO 27 C IF (NPRT(9)) PRINT 1001,ATNO2 1001 FORMAT(' *GNSLWD* BACKSCATTERED PARTICLE STORED FOR ATNO ',G12.5) C PV(1,2)=PV(1,MXGKPV)-PV(1,1) PV(2,2)=PV(2,MXGKPV)-PV(2,1) PV(3,2)=PV(3,MXGKPV)-PV(3,1) CALL LENGTX(2,PP) PV(9,2)=0.0 PV(10,2)=0.0 PV(7,2)=TOF C IF (ATNO2 .GT. 3.5) GO TO 274 IF (ATNO2 .GT. 2.5) GO TO 273 IF (ATNO2 .GT. 1.5) GO TO 272 C 271 CONTINUE PV(5,2)=RMASS(14) PV(4,2)=SQRT(PP*PP+PV(5,2)*PV(5,2)) PV(6,2)=RCHARG(14) PV(8,2)=14.0 GO TO 275 C 272 CONTINUE PV(5,2)=RMASS(30) PV(4,2)=SQRT(PP*PP+PV(5,2)*PV(5,2)) PV(6,2)=RCHARG(30) PV(8,2)=30.0 GO TO 275 C 273 CONTINUE PV(5,2)=RMASS(31) PV(4,2)=SQRT(PP*PP+PV(5,2)*PV(5,2)) PV(6,2)=RCHARG(31) PV(8,2)=31.0 GO TO 275 C 274 CONTINUE PV(5,2)=RMASS(32) PV(4,2)=SQRT(PP*PP+PV(5,2)*PV(5,2)) PV(6,2)=RCHARG(32) PV(8,2)=32.0 C 275 CONTINUE INTCT=INTCT+1.0 CALL SETCUR(1) NTK=NTK+1 CALL SETTRK(2) GO TO 9999 C C --- PUT QUANTITIES IN COMMON /RESULT/ --- 27 CONTINUE IF (PV(10,1) .NE. 0.0) USERW=PV(10,1) SINL=PZ COSL=SQRT(ABS(1.0-SINL*SINL)) IF (ABS(COSL) .LT. 1.E-10) GO TO 28 C SINP=PY/COSL COSP=PX/COSL GO TO 9999 C 28 CONTINUE CALL GRNDM(RNDM,1) PHI=RNDM(1)*TWPI SINP=SIN(PHI) COSP=COS(PHI) GO TO 9999 C C *** INELASTIC SCATTERING ON HEAVY NUCLEI *** 29 CONTINUE C IF (NPRT(9)) PRINT 1002 1002 FORMAT(' *GNSLWD* INELASTIC SCATTERING ON HEAVY NUCLEUS') C C --- DECIDE BETWEEN SPALLATION OR SIMPLE NUCLEAR REACTION --- CALL GRNDM(RNDM,1) TEST1=RNDM(1) TEST2=4.5*(EK-0.01) IF (TEST1 .GT. TEST2) GO TO 40 C C *** SPALLATION *** C IF (NPRT(9)) PRINT 1003 1003 FORMAT(' *GNSLWD* SPALLATION') C PV( 1,MXGKPV)=P*PX PV( 2,MXGKPV)=P*PY PV( 3,MXGKPV)=P*PZ PV( 4,MXGKPV)=EN PV( 5,MXGKPV)=AMAS PV( 6,MXGKPV)=NCH PV( 7,MXGKPV)=TOF PV( 8,MXGKPV)=IPART PV( 9,MXGKPV)=0.0 PV(10,MXGKPV)=USERW C C --- FERMI-MOTION AND EVAPORATION --- TKIN=CINEMA(EK) ENP(5)=EK+TKIN C --- CHECK FOR LOWERBOUND OF EKIN IN CROSS-SECTION TABLES --- IF (ENP(5) .LE. TEKLOW) ENP(5)=TEKLOW ENP(6)=ENP(5)+ABS(AMAS) ENP(7)=ENP(6)*ENP(6)-AMASQ ENP(7)=SQRT(ENP(7)) TKIN=FERMIG(ENP(5)) ENP(5)=ENP(5)+TKIN C --- CHECK FOR LOWERBOUND OF EKIN IN CROSS-SECTION TABLES --- IF (ENP(5) .LE. TEKLOW) ENP(5)=TEKLOW ENP(6)=ENP(5)+ABS(AMAS) ENP(7)=ENP(6)*ENP(6)-AMASQ ENP(7)=SQRT(ENP(7)) TKIN=EXNU(ENP(5)) ENP(5)=ENP(5)-TKIN C --- CHECK FOR LOWERBOUND OF EKIN IN CROSS-SECTION TABLES --- IF (ENP(5) .LE. TEKLOW) ENP(5)=TEKLOW ENP(6)=ENP(5)+ABS(AMAS) ENP(7)=ENP(6)*ENP(6)-AMASQ ENP(7)=SQRT(ENP(7)) C C --- NEUTRON CASCADE --- K=2 * CALL VZERO(IPA(1),MXGKCU) CDH DO III = 1, MXGKCU IPA(III) = 0 ENDDO CALL CASN(K,INT,NFL) GO TO 9999 C 40 CONTINUE IF (NPRT(9)) PRINT 1004 1004 FORMAT(' *GNSLWD* NUCLEAR REACTION') CALL NUCREC(NOPT,1) IF (NOPT .NE. 0) NUCFLG=1 IF (NOPT .EQ. 0) GO TO 30 C 9999 CONTINUE RETURN END *CMZ : 3.14/16 29/06/89 11.35.32 BY NICK VAN EIJNDHOVEN (CERN) *-- AUTHOR : C--------------------------------------------------------------------- FUNCTION GPDK(A,B,C) C C *** NVE 16-MAR-1988 CERN GENEVA *** C C CALLED BY : PHASP C ORIGIN : H.FESEFELDT (27-OCT-1983) C C GPDK = SQRT(A*A+(B*B-C*C)**2/(A*A) - 2.0*(B*B+C*C))/2.0 C SAVE C A2 = A*A B2 = B*B C2 = C*C IF(A2) 21,21,61 61 CONTINUE ARG=A2+(B2-C2)**2/A2-2.0*(B2+C2) IF (ARG) 21,21,31 21 GPDK=0.0 GOTO 41 31 CONTINUE GPDK = 0.5*SQRT(ABS(A2 + (B2-C2)**2/A2 - 2.0*(B2+C2))) 41 CONTINUE RETURN END *CMZ : 3.16/00 05/11/93 19.46.20 BY FEDERICO CARMINATI *-- AUTHOR : C--------------------------------------------------------------------- SUBROUTINE HIGCLU(IPPP,NFL,AVERN) C C *** GENERATION OF X- AND PT- VALUES FOR ALL PRODUCED PARTICLES *** C *** NVE 01-AUG-1988 CERN GENEVA *** C C ORIGIN : H.FESEFELDT (11-OCT-1987) C C A SIMPLE TWO CLUSTER MODEL IS USED C THIS SHOULD BE SUFFICIENT FOR LOW ENERGY INTERACTIONS C C PARAMETER (MXGKGH=100) COMMON/CONSTS/ PI,TWPI,PIBTW,MP,MPI,MMU,MEL,MKCH,MK0,SMP,SMPI, $ SMU,CT,CTKCH,CTK0, $ ML0,MSP,MS0,MSM,MX0,MXM,CTL0,CTSP,CTSM,CTX0,CTXM, $ RMASS(35),RCHARG(35) C REAL MP,MPI,MMU,MEL,MKCH,MK0, * ML0,MSP,MS0,MSM,MX0,MXM C PARAMETER (MXGKCU=MXGKGH) COMMON/CURPAR/WEIGHT(10),DDELTN,IFILE,IRUN,NEVT,NEVENT,SHFLAG, * ITHST,ITTOT,ITLST,IFRND,TOFCUT,CMOM(5),CENG(5), * RS,S,ENP(10),NP,NM,NN,NR,NO,NZ,IPA(MXGKCU), * ATNO2,ZNO2 C COMMON/RESULT/XEND,YEND,ZEND,RCA,RCE,AMAS,NCH,TOF,PX,PY,PZ, * USERW,INTCT,P,EN,EK,AMASQ,DELTN,ITK,NTK,IPART,IND, * LCALO,ICEL,SINL,COSL,SINP,COSP, * XOLD,YOLD,ZOLD,POLD,PXOLD,PYOLD,PZOLD, * XSCAT,YSCAT,ZSCAT,PSCAT,PXSCAT,PYSCAT,PZSCAT REAL NCH,INTCT C COMMON/MAT / LMAT, * DEN(21),RADLTH(21),ATNO(21),ZNO(21),ABSL(21), * CDEN(21),MDEN(21),X0DEN(21),X1DEN(21),RION(21), * MATID(21),MATID1(21,24),PARMAT(21,10), * IFRAT,IFRAC(21),FRAC1(21,10),DEN1(21,10), * ATNO1(21,10),ZNO1(21,10) C PARAMETER (MXEVEN=12*MXGKGH) COMMON/EVENT / NSIZE,NCUR,NEXT,NTOT,EVE(MXEVEN) C COMMON/PRNTFL/INBCD,NEWBCD,INBIN,NEWBIN,NPEVT,NEVTP,LPRT,NPRT(10) LOGICAL LPRT,NPRT C COMMON/ERRCOM/ IER(100) C PARAMETER (MXGKPV=MXGKGH) COMMON /VECUTY/ PV(10,MXGKPV) C C COMMON/GENIN /TECM,AMASS(18),NPG,KGENEV COMMON/GENOUT/PCM(5,18),WGT C C REAL NUCSUP DIMENSION SIDE(MXGKCU),C1PAR(5),G1PAR(5),NUCSUP(6) DIMENSION RNDM(3) DIMENSION PSUP(6) SAVE DATA C1PAR/0.6,0.6,0.35,0.15,0.10/ DATA G1PAR/2.6,2.6,1.8,1.30,1.20/ DATA NUCSUP/1.0,0.7,0.5,0.4,0.35,0.3/ DATA PSUP/3.,6.,20.,50.,100.,1000./ C DATA CB/3.0/ DATA CB/0.01/ C BPP(X)=4.000+1.600*LOG(X) C MX =MXGKPV-20 MX1=MX+1 MX2=MX+2 MX3=MX+3 MX4=MX+4 MX5=MX+5 MX6=MX+6 MX7=MX+7 MX8=MX+8 EK=ENP(5) EN=ENP(6) P=ENP(7) S=ENP(8) RS=ENP(9) CFA=0.025*((ATNO2-1.)/120.)*EXP(-(ATNO2-1.)/120.) IF(P.LT.0.001) GOTO 60 NT=0 C** C** CHECK MASS-INDICES FOR ALL PARTICLES C** DO 1 I=1,100 IF(IPA(I).EQ.0) GOTO 1 NT=NT+1 IPA(NT)=IPA(I) 1 CONTINUE * CALL VZERO(IPA(NT+1),MXGKCU-NT) CDH DO III = NT+1, MXGKCU IPA(III) = 0 ENDDO C** C** SET THE EFFECTICE 4-MOMENTUM-VECTOR FOR INTERACTION C** PV( 1,MXGKPV-1)=P*PX PV( 2,MXGKPV-1)=P*PY PV( 3,MXGKPV-1)=P*PZ PV( 4,MXGKPV-1)=EN PV( 5,MXGKPV-1)=AMAS PV( 6,MXGKPV-1)=NCH PV( 7,MXGKPV-1)=TOF PV( 8,MXGKPV-1)=IPART PV( 9,MXGKPV-1)=0. PV(10,MXGKPV-1)=USERW IER(48)=IER(48)+1 C** C** DISTRIBUTE PARTICLES IN FORWARD AND BACKWARD HEMISPHERE OF CMS C** OF THE HADRON NUCLEON INTERACTION C** SIDE(1)= 1. SIDE(2)=-1. TARG=0. IFOR=1 IBACK=1 DO 3 I=1,NT IF (I .LE. 2) GO TO 78 SIDE(I)=1. CALL GRNDM(RNDM,1) IF (RNDM(1) .LT. 0.5) SIDE(I)=-1. IF (SIDE(I) .LT. 0.) GO TO 76 C C --- PARTICLE IN FORWARD HEMISPHERE --- 77 CONTINUE IFOR=IFOR+1 IF (IFOR .LE. 18) GO TO 78 C C --- CHANGE IT TO BACKWARD --- SIDE(I)=-1. IFOR=IFOR-1 IBACK=IBACK+1 GO TO 78 C C --- PARTICLE IN BACKWARD HEMISPHERE --- 76 CONTINUE IBACK=IBACK+1 IF (IBACK .LE. 18) GO TO 78 C C --- CHANGE IT TO FORWARD --- SIDE(I)=1. IBACK=IBACK-1 IFOR=IFOR+1 C** C** SUPPRESSION OF CHARGED PIONS FOR VARIOUS REASONS C** 78 IF(IPART.EQ.15.OR.IPART.GE.17) GOTO 3 IF(ABS(IPA(I)).GE.10) GOTO 3 IF(ABS(IPA(I)).EQ. 8) GOTO 3 CALL GRNDM(RNDM,1) IF(RNDM(1).GT.(10.-P)/6.) GOTO 3 CALL GRNDM(RNDM,1) IF(RNDM(1).GT.ATNO2/300.) GOTO 3 IPA(I)=14 CALL GRNDM(RNDM,1) IF(RNDM(1).GT.ZNO2/ATNO2) IPA(I)=16 TARG=TARG+1. 3 CONTINUE TB=2.*IBACK CALL GRNDM(RNDM,1) IF(RS.LT.(2.0+RNDM(1))) TB=(2.*IBACK+NT)/2. C** C** NUCLEONS + SOME PIONS FROM INTRANUCLEAR CASCADE C** AFC=0.312+0.200*LOG(LOG(S))+S**1.5/6000. IF(AFC.GT.0.50) AFC= 0.50 XTARG=AFC*(ATNO2**0.33-1.0)*TB IF(XTARG.LE.0.) XTARG=0.01 DO 881 IPX=1,6 IF(P.LE.PSUP(IPX)) GOTO 882 881 CONTINUE IPX=6 882 XPNHMF = XTARG*NUCSUP(IPX) XSHHMF = XTARG - XPNHMF IF(XSHHMF.LT.0.01) XSHHMF=0.01 IF(XPNHMF.LT.0.01) XPNHMF=0.01 SSHHMF=0.5*XSHHMF SPNHMF=0.9*XPNHMF RSHHMF=SSHHMF**2/XSHHMF RPNHMF=SPNHMF**2/XPNHMF IF(RSHHMF.LT.1.1) THEN CALL POISSO(XSHHMF,NSHHMF) GOTO 541 ELSE RSHHMF=XSHHMF/(RSHHMF-1.) IF(RSHHMF.LE.20.) THEN CALL SVGAM7(RSHHMF,XHMF) ELSE KRSHMF=IFIX(RSHHMF+0.5) CALL SVERL2(KRSHMF,XHMF) ENDIF XSHHMF=XHMF*XSHHMF/RSHHMF CALL POISSO(XSHHMF,NSHHMF) ENDIF 541 IF(RPNHMF.LE.1.1) THEN CALL POISSO(XPNHMF,NPNHMF) GOTO 542 ELSE RPNHMF=XPNHMF/(RPNHMF-1.) IF(RPNHMF.LE.20.) THEN CALL SVGAM7(RPNHMF,XHMF) ELSE KRPHMF=IFIX(RPNHMF+0.5) CALL SVERL2(KRPHMF,XHMF) ENDIF XPNHMF=XHMF*XPNHMF/RPNHMF CALL POISSO(XPNHMF,NPNHMF) ENDIF 542 NTARG=NSHHMF+NPNHMF NT2=NT+NTARG IF(NT2.LE.MXGKPV-30) GOTO 2 NT2=MXGKPV-30 NTARG=NT2-NT 2 CONTINUE IF(NPRT(4)) *WRITE(NEWBCD,3001) NTARG,NT NT1=NT+1 IF(NTARG.EQ.0) GOTO 51 DO 4 I=NT1,NT2 IF(NPNHMF.GT.0) GOTO 52 CALL GRNDM(RNDM,1) IPA(I)=-(7+IFIX(RNDM(1)*3.0)) CJOK SIDE(I)=-2. CJOK GOTO 4 52 IPA(I)=-16 PNRAT=1.-ZNO2/ATNO2 CALL GRNDM(RNDM,1) IF(RNDM(1).GT.PNRAT) IPA(I)=-14 TARG=TARG+1. SIDE(I)=-2. NPNHMF=NPNHMF-1 4 CONTINUE NT=NT2 C** C** CHOOSE MASSES AND CHARGES FOR ALL PARTICLES C** 51 DO 5 I=1,NT IPA1=ABS(IPA(I)) PV(5,I)=RMASS(IPA1) PV(6,I)=RCHARG(IPA1) PV(7,I)=1. IF(PV(5,I).LT.0.) PV(7,I)=-1. PV(5,I)=ABS(PV(5,I)) 5 CONTINUE C** C** MARK LEADING STRANGE PARTICLES C** LEAD=0 IF(IPART.LT.10.OR.IPART.EQ.14.OR.IPART.EQ.16) GOTO 6 IPA1=ABS(IPA(1)) IF(IPA1.LT.10.OR.IPA1.EQ.14.OR.IPA1.EQ.16) GOTO 531 LEAD=IPA1 GOTO 6 531 IPA1=ABS(IPA(2)) IF(IPA1.LT.10.OR.IPA1.EQ.14.OR.IPA1.EQ.16) GOTO 6 LEAD=IPA1 C** C** CHECK AVAILABLE KINETIC ENERGY , CHANGE HEMISPHERE FOR PARTICLES C** UNTIL IT FITS C** 6 IF(NT.LE.1) GOTO 60 TAVAI=0. DO 7 I=1,NT IF(SIDE(I).LT.-1.5) GOTO 7 TAVAI=TAVAI+ABS(PV(5,I)) 7 CONTINUE CJOK MODIFIED ACCORDING TO D.HECK IF(TAVAI.LT.RS-0.00001) GOTO 12 IF(NPRT(4)) $ WRITE(NEWBCD,3002) (IPA(I),I=1,20),(SIDE(I),I=1,20),TAVAI,RS 3002 FORMAT(' *HIGCLU* CHECK AVAILABLE ENERGIES'/ $ 1H ,20I5/1H ,20F5.0/1H ,'TAVAI,RS ',2F10.3) DO 10 I=1,NT II=NT-I+1 IF(SIDE(II).LT.-1.5) GOTO 10 IF(II.EQ.NT) GOTO 11 NT1=II+1 NT2=NT DO 8 J=NT1,NT2 IPA(J-1)=IPA(J) SIDE(J-1)=SIDE(J) DO 8 K=1,10 8 PV(K,J-1)=PV(K,J) GOTO 11 10 CONTINUE 11 SIDE(NT)=0. IPA(NT)=0 NT=NT-1 GOTO 6 12 IF(NT.LE.1) GOTO 60 B=BPP(P) IF(B.LT.CB) B=CB C** C** CHOOSE MASSES FOR THE 3 CLUSTER: 1. FORWARD CLUSTER C** 2. BACKWARD MESON CLUSTER 3. BACKWARD NUCLEON CLUSTER C** RMC0=0. RMD0=0. RME0=0. NTC=0 NTD=0 NTE=0 DO 31 I=1,NT IF(SIDE(I).GT.0.) RMC0=RMC0+ABS(PV(5,I)) IF(SIDE(I).GT.0.) NTC =NTC +1 IF(SIDE(I).LT.0..AND.SIDE(I).GT.-1.5) RMD0=RMD0+ABS(PV(5,I)) IF( SIDE(I).LT.-1.5) RME0=RME0+ABS(PV(5,I)) IF(SIDE(I).LT.0..AND.SIDE(I).GT.-1.5) NTD =NTD +1 IF( SIDE(I).LT.-1.5) NTE =NTE +1 31 CONTINUE 32 CALL GRNDM(RNDM,1) RAN=RNDM(1) RMC=RMC0 IF(NTC.LE.1) GOTO 33 NTC1=NTC IF(NTC1.GT.5) NTC1=5 RMC=-LOG(1.-RAN) GPAR=G1PAR(NTC1) CPAR=C1PAR(NTC1) DUMNVE=GPAR IF (DUMNVE .EQ. 0.0) DUMNVE=1.0E-10 RMC=RMC0+RMC**CPAR/DUMNVE 33 RMD=RMD0 IF(NTD.LE.1) GOTO 34 NTD1=NTD IF(NTD1.GT.5) NTD1=5 CALL GRNDM(RNDM,1) RAN=RNDM(1) RMD=-LOG(1.-RAN) GPAR=G1PAR(NTD1) CPAR=C1PAR(NTD1) DUMNVE=GPAR IF (DUMNVE .EQ. 0.0) DUMNVE=1.0E-10 RMD=RMD0+RMD**CPAR/DUMNVE 34 IF(RMC+RMD.LE.RS) GOTO 35 IF (RMC.LE.RMC0.AND.RMD.LE.RMD0) THEN HNRMDC = 0.999*RS/(RMC+RMD) RMD = RMD*HNRMDC RMC = RMC*HNRMDC ELSE RMC=0.1*RMC0+0.9*RMC RMD=0.1*RMD0+0.9*RMD ENDIF GOTO 34 35 IF(NTE.LE.0) GOTO 38 RME=RME0 IF(NTE.EQ.1) GOTO 38 NTE1=NTE IF(NTE1.GT.5) NTE1=5 CALL GRNDM(RNDM,1) RAN=RNDM(1) RME=-LOG(1.-RAN) GPAR=G1PAR(NTE1) CPAR=C1PAR(NTE1) DUMNVE=GPAR IF (DUMNVE .EQ. 0.0) DUMNVE=1.0E-10 RME=RME0+RME**CPAR/DUMNVE C** C** SET BEAM , TARGET OF FIRST INTERACTION IN CMS C** 38 PV( 1,MX1) =0. PV( 2,MX1) =0. PV( 3,MX1) =P PV( 5,MX1) =ABS(AMAS) PV( 4,MX1) =SQRT(P*P+AMAS*AMAS) PV( 1,MX2) =0. PV( 2,MX2) =0. PV( 3,MX2) =0. PV( 4,MX2) =MP PV( 5,MX2) =MP C** TRANSFORM INTO CMS. CALL ADD(MX1,MX2,MX) CALL LOR(MX1,MX,MX1) CALL LOR(MX2,MX,MX2) PF=(S+RMD*RMD-RMC*RMC)**2 - 4*S*RMD*RMD IF(PF.LT.0.0001) PF=0.0001 DUMNVE=2.0*RS IF (DUMNVE .EQ. 0.0) DUMNVE=1.0E-10 PF=SQRT(PF)/DUMNVE IF(NPRT(4)) WRITE(6,2002) PF,RMC,RMD,RS C** C** SET FINAL STATE MASSES AND ENERGIES IN CMS C** PV(5,MX3) =RMC PV(5,MX4) =RMD PV(4,MX3) =SQRT(PF*PF+RMC*RMC) PV(4,MX4) =SQRT(PF*PF+RMD*RMD) C** C** SET |T| AND |TMIN| C** T=-1.0E10 CALL GRNDM(RNDM,1) IF (B .NE. 0.0) T=LOG(1.-RNDM(1))/B CALL LENGTX(MX1,PIN) TACMIN=(PV(4,MX1) -PV(4,MX3))**2 -(PIN-PF)**2 C** C** CACULATE (SIN(TETA/2.)**2 AND COS(TETA), SET AZIMUTH ANGLE PHI C** DUMNVE=4.0*PIN*PF IF (DUMNVE .EQ. 0.0) DUMNVE=1.0E-10 CTET=-(T-TACMIN)/DUMNVE CTET=1.0-2.0*CTET IF (CTET .GT. 1.0) CTET=1.0 IF (CTET .LT. -1.0) CTET=-1.0 DUMNVE=1.0-CTET*CTET IF (DUMNVE .LT. 0.0) DUMNVE=0.0 STET=SQRT(DUMNVE) CALL GRNDM(RNDM,1) PHI=RNDM(1)*TWPI C** C** CALCULATE FINAL STATE MOMENTA IN CMS C** PV(1,MX3) =PF*STET*SIN(PHI) PV(2,MX3) =PF*STET*COS(PHI) PV(3,MX3) =PF*CTET PV(1,MX4) =-PV(1,MX3) PV(2,MX4) =-PV(2,MX3) PV(3,MX4) =-PV(3,MX3) C** C** SIMULATE BACKWARD NUCLEON CLUSTER IN LAB. SYSTEM AND TRANSFORM IN C** CMS. C** IF(NTE.EQ.0) GOTO 28 GA=1.2 EKIT1=0.04 EKIT2=0.6 IF(EK.GT.5.) GOTO 666 EKIT1=EKIT1*EK**2/25. EKIT2=EKIT2*EK**2/25. 666 A=(1.-GA)/(EKIT2**(1.-GA)-EKIT1**(1.-GA)) DO 29 I=1,NT IF(SIDE(I).GT.-1.5) GOTO 29 CALL GRNDM(RNDM,3) RAN=RNDM(1) EKIT=(RAN*(1.-GA)/A+EKIT1**(1.-GA))**(1./(1.-GA)) PV(4,I)=EKIT+PV(5,I) DUMNVE=ABS(PV(4,I)**2-PV(5,I)**2) PP=SQRT(DUMNVE) RAN=RNDM(2) COST=LOG(2.23*RAN+0.383)/0.96 IF (COST .LT. -1.0) COST=-1.0 IF (COST .GT. 1.0) COST=1.0 DUMNVE=1.0-COST*COST IF (DUMNVE .LT. 0.0) DUMNVE=0.0 SINT=SQRT(DUMNVE) PHI=TWPI*RNDM(3) PV(1,I)=PP*SINT*SIN(PHI) PV(2,I)=PP*SINT*COS(PHI) PV(3,I)=PP*COST CALL LOR(I,MX,I) 29 CONTINUE C** C** FRAGMENTATION OF FORWARD CLUSTER AND BACKWARD MESON CLUSTER C** 28 PV(1,1)=PV(1,MX3) PV(2,1)=PV(2,MX3) PV(3,1)=PV(3,MX3) PV(4,1)=PV(4,MX3) PV(1,2)=PV(1,MX4) PV(2,2)=PV(2,MX4) PV(3,2)=PV(3,MX4) PV(4,2)=PV(4,MX4) DO 17 I=MX5,MX6 DO 16 J=1,3 16 PV(J,I)=-PV(J,I-2) DO 17 J=4,5 17 PV(J,I)= PV(J,I-2) KGENEV=1 IF(NTC.LE.1) GOTO 26 TECM=PV(5,MX3) NPG=0 DO 18 I=1,NT IF(SIDE(I).LT.0.) GOTO 18 IF(NPG.EQ.18) THEN SIDE(I)=-SIDE(I) GOTO 18 ENDIF NPG=NPG+1 AMASS(NPG)=ABS(PV(5,I)) 18 CONTINUE IF(NPRT(4)) WRITE(NEWBCD,2004) TECM,NPG,(AMASS(I),I=1,NPG) CALL PHASP NPG=0 DO 19 I=1,NT IF(SIDE(I).LT.0.) GOTO 19 NPG=NPG+1 PV(1,I)=PCM(1,NPG) PV(2,I)=PCM(2,NPG) PV(3,I)=PCM(3,NPG) PV(4,I)=PCM(4,NPG) IF(NPRT(4)) WRITE(NEWBCD,2001) I,(PV(J,I),J=1,5) CALL LOR(I,MX5,I) IF(NPRT(4)) WRITE(NEWBCD,2001) I,(PV(J,I),J=1,10),IPA(I),SIDE(I) 19 CONTINUE 26 IF(NTD.LE.1) GOTO 27 TECM=PV(5,MX4) NPG=0 DO 20 I=1,NT IF(SIDE(I).GT.0..OR.SIDE(I).LT.-1.5) GOTO 20 IF(NPG.EQ.18) THEN SIDE(I)=-2. PV(4,I)=ABS(PV(5,I)) DO 48 J=1,3 PV(J,I)=0. 48 CONTINUE GOTO 20 ENDIF NPG=NPG+1 AMASS(NPG)=ABS(PV(5,I)) 20 CONTINUE IF(NPRT(4)) WRITE(NEWBCD,2004) TECM,NPG,(AMASS(I),I=1,NPG) CALL PHASP NPG=0 DO 21 I=1,NT IF(SIDE(I).GT.0..OR.SIDE(I).LT.-1.5) GOTO 21 NPG=NPG+1 PV(1,I)=PCM(1,NPG) PV(2,I)=PCM(2,NPG) PV(3,I)=PCM(3,NPG) PV(4,I)=PCM(4,NPG) IF(NPRT(4)) WRITE(NEWBCD,2001) I,(PV(J,I),J=1,5) CALL LOR(I,MX6,I) IF(NPRT(4)) WRITE(NEWBCD,2001) I,(PV(J,I),J=1,10),IPA(I),SIDE(I) 21 CONTINUE C** C** LORENTZ TRANSFORMATION IN LAB SYSTEM C** 27 TARG=0. DO 36 I=1,NT IF(PV(5,I).GT.0.5) TARG=TARG+1. CALL LOR(I,MX2,I) 36 CONTINUE IF(TARG.LT.0.5) TARG=1. C** C** SOMETIMES THE LEADING STRANGE PARTICLES ARE LOST , SET THEM BACK C** IF(LEAD.EQ.0) GOTO 6085 DO 6081 I=1,NT IF(ABS(IPA(I)).EQ.LEAD) GOTO 6085 6081 CONTINUE I=1 IF(LEAD.GE.14.AND.ABS(IPA(2)).GE.14) I=2 IF(LEAD.LT.14.AND.ABS(IPA(2)).LT.14) I=2 IPA(I)=LEAD EKIN=PV(4,I)-ABS(PV(5,I)) PV(5,I)=RMASS(LEAD) PV(7,I)=1. IF(PV(5,I).LT.0.) PV(7,I)=-1. PV(5,I)=ABS(PV(5,I)) PV(6,I)=RCHARG(LEAD) PV(4,I)=PV(5,I)+EKIN CALL LENGTX(I,PP) DUMNVE=ABS(PV(4,I)**2-PV(5,I)**2) PP1=SQRT(DUMNVE) C IF (PP .GE. 1.0E-6) GO TO 8000 CALL GRNDM(RNDM,2) RTHNVE=PI*RNDM(1) PHINVE=TWPI*RNDM(2) PV(1,I)=PP1*SIN(RTHNVE)*COS(PHINVE) PV(2,I)=PP1*SIN(RTHNVE)*SIN(PHINVE) PV(3,I)=PP1*COS(RTHNVE) GO TO 8001 8000 CONTINUE PV(1,I)=PV(1,I)*PP1/PP PV(2,I)=PV(2,I)*PP1/PP PV(3,I)=PV(3,I)*PP1/PP 8001 CONTINUE C C** FOR VARIOUS REASONS, THE ENERGY BALANCE IS NOT SUFFICIENT, C** CHECK THAT, ENERGY BALANCE, ANGLE OF FINAL SYSTEM E.T.C. 6085 KGENEV=1 PV(1,MX4) =0. PV(2,MX4) =0. PV(3,MX4) =P PV(4,MX4) =SQRT(P*P+AMAS*AMAS) PV(5,MX4) =ABS(AMAS) EKIN0=PV(4,MX4) -PV(5,MX4) PV(1,MX5) =0. PV(2,MX5) =0. PV(3,MX5) =0. PV(4,MX5) =MP*TARG PV(5,MX5) =PV(4,MX5) EKIN=PV(4,MX4) +PV(4,MX5) I=MX4 IF(NPRT(4)) WRITE(NEWBCD,2001) I,(PV(J,I),J=1,5) I=MX5 IF(NPRT(4)) WRITE(NEWBCD,2001) I,(PV(J,I),J=1,5) CALL ADD(MX4,MX5,MX6) CALL LOR(MX4,MX6,MX4) CALL LOR(MX5,MX6,MX5) TECM=PV(4,MX4) +PV(4,MX5) NPG=NT PV(1,MX8) =0. PV(2,MX8) =0. PV(3,MX8) =0. PV(4,MX8) =0. PV(5,MX8) =0. EKIN1=0. DO 598 I=1,NPG IF(NPRT(4)) WRITE(NEWBCD,2001) I,(PV(J,I),J=1,10),IPA(I),SIDE(I) CALL ADD(MX8,I,MX8) EKIN1=EKIN1+PV(4,I)-PV(5,I) EKIN=EKIN-PV(5,I) IF(I.GT.18) GOTO 598 AMASS(I)=PV(5,I) 598 CONTINUE IF(NPG.GT.18) GOTO 597 CALL PHASP EKIN=0. DO 599 I=1,NPG PV(1,MX7)=PCM(1,I) PV(2,MX7)=PCM(2,I) PV(3,MX7)=PCM(3,I) PV(4,MX7)=PCM(4,I) PV(5,MX7)=AMASS(I) CALL LOR(MX7,MX5,MX7) 599 EKIN=EKIN+PV(4,MX7)-PV(5,MX7) CALL ANG(MX8,MX4,COST,TETA) IF(NPRT(4)) WRITE(NEWBCD,2003) TETA,EKIN0,EKIN1,EKIN C** C** MAKE SHURE, THAT KINETIC ENERGIES ARE CORRECT C** THE 3. CLUSTER IS NOT PRODUCED WITHIN PROPER KINEMATICS!!! C** EKIN= KINETIC ENERGY THEORETICALLY C** EKIN1= KINETIC ENERGY SIMULATED C** 597 IF(EKIN1.EQ.0.) GOTO 600 PV(1,MX7) =0. PV(2,MX7) =0. PV(3,MX7) =0. PV(4,MX7) =0. PV(5,MX7) =0. WGT=EKIN/EKIN1 EKIN1=0. DO 602 I=1,NT EKIN=PV(4,I)-PV(5,I) EKIN=EKIN*WGT PV(4,I)=EKIN+PV(5,I) DUMNVE=ABS(PV(4,I)**2-PV(5,I)**2) PP=SQRT(DUMNVE) CALL LENGTX(I,PP1) C IF (PP1 .GE. 1.0E-6) GO TO 8002 CALL GRNDM(RNDM,2) RTHNVE=PI*RNDM(1) PHINVE=TWPI*RNDM(2) PV(1,I)=PP*SIN(RTHNVE)*COS(PHINVE) PV(2,I)=PP*SIN(RTHNVE)*SIN(PHINVE) PV(3,I)=PP*COS(RTHNVE) GO TO 8003 8002 CONTINUE PV(1,I)=PV(1,I)*PP/PP1 PV(2,I)=PV(2,I)*PP/PP1 PV(3,I)=PV(3,I)*PP/PP1 8003 CONTINUE C EKIN1=EKIN1+EKIN CALL ADD(MX7,I,MX7) 602 CONTINUE CALL ANG(MX7,MX4,COST,TETA) IF(NPRT(4)) WRITE(NEWBCD,2003) TETA,EKIN0,EKIN1 C** C** ROTATE IN DIRECTION OF Z-AXIS, SEE COMMENTS IN 'GENXPT' C** 600 PV(1,MX7)=0. PV(2,MX7)=0. PV(3,MX7)=0. PV(4,MX7)=0. PV(5,MX7)=0. DO 596 I=1,NT CALL ADD(MX7,I,MX7) 596 CONTINUE * CALL RANNOR(RAN1,RAN2) CALL GRNDM(RNDM,2) RY=RNDM(1) RZ=RNDM(2) RX=6.283185*RZ A1=SQRT(-2.*LOG(RY)) RAN1=A1*SIN(RX) RAN2=A1*COS(RX) PV(1,MX7)=PV(1,MX7)+RAN1*0.020*TARG PV(2,MX7)=PV(2,MX7)+RAN2*0.020*TARG CALL DEFS(MX4,MX7,MX8) PV(1,MX7)=0. PV(2,MX7)=0. PV(3,MX7)=0. PV(4,MX7)=0. PV(5,MX7)=0. DO 595 I=1,NT CALL TRAC(I,MX8,I) CALL ADD(MX7,I,MX7) 595 CONTINUE CALL ANG(MX7,MX4,COST,TETA) IF(NPRT(4)) WRITE(NEWBCD,2003) TETA C** C** ROTATE IN DIRECTION OF PRIMARY PARTICLE C** DEKIN=0. NPIONS=0 EK1=0. DO 25 I=1,NT CALL DEFS1(I,MXGKPV-1,I) IF(NPRT(4)) WRITE(NEWBCD,2001) I,(PV(J,I),J=1,10),IPA(I),SIDE(I) IF(ATNO2.LT.1.5) GOTO 25 CALL LENGTX(I,PP) EKIN=PV(4,I)-ABS(PV(5,I)) CALL NORMAL(RAN) EKIN=EKIN-CFA*(1.+0.5*RAN) IF (EKIN .LT. 1.0E-6) EKIN=1.0E-6 CALL STEEQ(XXH,I) DEKIN=DEKIN+EKIN*(1.-XXH) EKIN=EKIN*XXH IF(ABS(IPA(I)).GE.7.AND.ABS(IPA(I)).LE.9) NPIONS=NPIONS+1 IF(ABS(IPA(I)).GE.7.AND.ABS(IPA(I)).LE.9) EK1=EK1+EKIN PP1=SQRT(EKIN*(EKIN+2.*ABS(PV(5,I)))) PV(4,I)=EKIN+ABS(PV(5,I)) C IF (PP .GE. 1.0E-6) GO TO 8004 CALL GRNDM(RNDM,2) RTHNVE=PI*RNDM(1) PHINVE=TWPI*RNDM(2) PV(1,I)=PP1*SIN(RTHNVE)*COS(PHINVE) PV(2,I)=PP1*SIN(RTHNVE)*SIN(PHINVE) PV(3,I)=PP1*COS(RTHNVE) GO TO 8005 8004 CONTINUE PV(1,I)=PV(1,I)*PP1/PP PV(2,I)=PV(2,I)*PP1/PP PV(3,I)=PV(3,I)*PP1/PP 8005 CONTINUE C 25 CONTINUE IF(EK1.EQ.0.) GOTO 23 IF(NPIONS.LE.0) GOTO 23 DEKIN=1.+DEKIN/EK1 DO 22 I=1,NT IF(ABS(IPA(I)).LT.7.OR.ABS(IPA(I)).GT.9) GOTO 22 CALL LENGTX(I,PP) EKIN=PV(4,I)-ABS(PV(5,I)) EKIN=EKIN*DEKIN IF (EKIN .LT. 1.0E-6) EKIN=1.0E-6 PP1=SQRT(EKIN*(EKIN+2.*ABS(PV(5,I)))) PV(4,I)=EKIN+ABS(PV(5,I)) C IF (PP .GE. 1.0E-6) GO TO 8006 CALL GRNDM(RNDM,2) RTHNVE=PI*RNDM(1) PHINVE=TWPI*RNDM(2) PV(1,I)=PP1*SIN(RTHNVE)*COS(PHINVE) PV(2,I)=PP1*SIN(RTHNVE)*SIN(PHINVE) PV(3,I)=PP1*COS(RTHNVE) GO TO 8007 8006 CONTINUE PV(1,I)=PV(1,I)*PP1/PP PV(2,I)=PV(2,I)*PP1/PP PV(3,I)=PV(3,I)*PP1/PP 8007 CONTINUE C 22 CONTINUE 23 IF(ATNO2.LT.1.5) GOTO 40 C** C** ADD BLACK TRACK PARTICLES C** CALL HIGHAB(SPROB) CALL GRNDM(RNDM,1) IF(RNDM(1).LT.SPROB) GOTO 40 TEX=ENP(1) SPALL=TARG IF(TEX.LT.0.001) GOTO 445 BLACK=(1.5+1.25*TARG)*ENP(1)/(ENP(1)+ENP(3)) CALL POISSO(BLACK,NBL) IF(NPRT(4)) *WRITE(NEWBCD,3003) NBL,TEX IF(IFIX(TARG)+NBL.GT.ATNO2) NBL=ATNO2-TARG IF(NT+NBL.GT.MXGKPV-2) NBL=MXGKPV-2-NT IF(NBL.LE.0) GOTO 445 EKIN=TEX/NBL EKIN2=0. CALL STEEP(XX) DO 441 I=1,NBL CALL GRNDM(RNDM,1) IF(RNDM(1).LT.SPROB) GOTO 441 IF(NT.EQ.MXGKPV-2) GOTO 441 IF(EKIN2.GT.TEX) GOTO 443 CALL GRNDM(RNDM,1) RAN1=RNDM(1) CALL NORMAL(RAN2) EKIN1=-EKIN*LOG(RAN1)-CFA*(1.+0.5*RAN2) IF(EKIN1.LT.0.0) EKIN1=-0.010*LOG(RAN1) EKIN1=EKIN1*XX EKIN2=EKIN2+EKIN1 IF(EKIN2.GT.TEX) EKIN1=TEX-(EKIN2-EKIN1) IF (EKIN1 .LT. 0.0) EKIN1=1.0E-6 IPA1=16 PNRAT=1.-ZNO2/ATNO2 CALL GRNDM(RNDM,3) IF(RNDM(1).GT.PNRAT) IPA1=14 NT=NT+1 SPALL=SPALL+1. COST=-1.0+RNDM(2)*2.0 DUMNVE=1.0-COST*COST IF (DUMNVE .LT. 0.0) DUMNVE=0.0 SINT=SQRT(DUMNVE) PHI=TWPI*RNDM(3) IPA(NT)=-IPA1 SIDE(NT)=-4. PV(5,NT)=ABS(RMASS(IPA1)) PV(6,NT)=RCHARG(IPA1) PV(7,NT)=1. PV(4,NT)=EKIN1+PV(5,NT) DUMNVE=ABS(PV(4,NT)**2-PV(5,NT)**2) PP=SQRT(DUMNVE) PV(1,NT)=PP*SINT*SIN(PHI) PV(2,NT)=PP*SINT*COS(PHI) PV(3,NT)=PP*COST 441 CONTINUE 443 IF(ATNO2.LT.10.) GOTO 445 IF(EK.GT.2.0) GOTO 445 II=NT+1 KK=0 EKA=EK IF(EKA.GT.1.) EKA=EKA*EKA IF(EKA.LT.0.1) EKA=0.1 IKA=3.6*EXP((ZNO2**2/ATNO2-35.56)/6.45)/EKA IF(IKA.LE.0) GO TO 445 DO 444 I=1,NT II=II-1 IF(IPA(II).NE.-14) GOTO 444 IPA(II)=-16 IPA1 = 16 PV(5,II)=ABS(RMASS(IPA1)) PV(6,II)=RCHARG(IPA1) KK=KK+1 IF(KK.GT.IKA) GOTO 445 444 CONTINUE 445 TEX=ENP(3) IF(TEX.LT.0.001) GOTO 40 BLACK=(1.5+1.25*TARG)*ENP(3)/(ENP(1)+ENP(3)) CALL POISSO(BLACK,NBL) IF(NT+NBL.GT.MXGKPV-2) NBL=MXGKPV-2-NT IF(NBL.LE.0) GOTO 40 EKIN=TEX/NBL EKIN2=0. CALL STEEP(XX) IF(NPRT(4)) *WRITE(NEWBCD,3004) NBL,TEX DO 442 I=1,NBL CALL GRNDM(RNDM,1) IF(RNDM(1).LT.SPROB) GOTO 442 IF(NT.EQ.MXGKPV-2) GOTO 442 IF(EKIN2.GT.TEX) GOTO 40 CALL GRNDM(RNDM,1) RAN1=RNDM(1) CALL NORMAL(RAN2) EKIN1=-EKIN*LOG(RAN1)-CFA*(1.+0.5*RAN2) IF(EKIN1.LT.0.0) EKIN1=-0.005*LOG(RAN1) EKIN1=EKIN1*XX EKIN2=EKIN2+EKIN1 IF(EKIN2.GT.TEX) EKIN1=TEX-(EKIN2-EKIN1) IF (EKIN1 .LT. 0.0) EKIN1=1.0E-6 CALL GRNDM(RNDM,3) COST=-1.0+RNDM(1)*2.0 DUMNVE=1.0-COST*COST IF (DUMNVE .LT. 0.0) DUMNVE=0.0 SINT=SQRT(DUMNVE) PHI=TWPI*RNDM(2) RAN=RNDM(3) IPA(NT+1)=-30 IF(RAN.GT.0.60) IPA(NT+1)=-31 IF(RAN.GT.0.90) IPA(NT+1)=-32 SIDE(NT+1)=-4. PV(5,NT+1)=(ABS(IPA(NT+1))-28)*MP SPALL=SPALL+PV(5,NT+1)*1.066 IF(SPALL.GT.ATNO2) GOTO 40 NT=NT+1 PV(6,NT)=1. IF(IPA(NT).EQ.-32) PV(6,NT)=2. PV(7,NT)=1. PV(4,NT)=PV(5,NT)+EKIN1 DUMNVE=ABS(PV(4,NT)**2-PV(5,NT)**2) PP=SQRT(DUMNVE) PV(1,NT)=PP*SINT*SIN(PHI) PV(2,NT)=PP*SINT*COS(PHI) PV(3,NT)=PP*COST 442 CONTINUE C** C** STORE ON EVENT COMMON C** 40 CALL GRNDM(RNDM,1) IF(RS.GT.(4.+RNDM(1)*1.)) GOTO 42 DO 41 I=1,NT CALL LENGTX(I,ETB) IF(ETB.LT.P) GOTO 41 ETF=P PV(4,I)=SQRT(PV(5,I)**2+ETF**2) DUMNVE=ETB IF (DUMNVE .EQ. 0.0) DUMNVE=1.0E-10 ETF=ETF/DUMNVE PV(1,I)=PV(1,I)*ETF PV(2,I)=PV(2,I)*ETF PV(3,I)=PV(3,I)*ETF 41 CONTINUE 42 EKIN=PV(4,MXGKPV)-ABS(PV(5,MXGKPV)) EKIN1=PV(4,MXGKPV-1)-ABS(PV(5,MXGKPV-1)) EKIN2=0. CALL TDELAY(TOF1) CALL GRNDM(RNDM,1) RAN=RNDM(1) TOF=TOF-TOF1*LOG(RAN) DO 44 I=1,NT IF(PV(7,I).LT.0.) PV(5,I)=-PV(5,I) PV(7,I)=TOF PV(8,I)=ABS(IPA(I)) PV(9,I)=0. 44 PV(10,I)=0. CALL GHETUN(NT) DO 45 I=1,NT EKIN2=EKIN2+PV(4,I)-ABS(PV(5,I)) 45 CONTINUE EKIN2=(EKIN2-EKIN)/EKIN IF(NPRT(4)) $ WRITE(NEWBCD,2006) NT,EKIN,ENP(1),ENP(3),EKIN1,EKIN2 IF(EKIN2.GT.0.2) GOTO 60 INTCT=INTCT+1. NMODE=3 IF(SPALL.LT.0.5.AND.ATNO2.GT.1.5) NMODE=14 CALL SETCUR(NT) NTK=NTK+1 IF(NT.EQ.1) GOTO 300 DO 50 II=2,NT I=II-1 IF(NTOT.LT.NSIZE/12) GOTO 43 GO TO 9999 43 CALL SETTRK(I) 50 CONTINUE 300 CONTINUE GO TO 9999 C** C** IT IS NOT POSSIBLE TO PRODUCE A PROPER TWO CLUSTER FINAL STATE. C** CONTINUE WITH QUASI ELASTIC SCATTERING C** 60 IF(NPRT(4)) WRITE(NEWBCD,2005) DO 61 I=3,MXGKCU 61 IPA(I)=0 IPA(1)=IPART IPA(2)=14 IF(NFL.EQ.2) IPA(2)=16 CALL TWOB(IPPP,NFL,AVERN) GO TO 9999 C 2000 FORMAT(' *HIGCLU* CMS PARAMETERS OF FINAL STATE PARTICLES', $ ' AFTER ',I3,' TRIALS') 2001 FORMAT(' *HIGCLU* TRACK',2X,I3,2X,10F8.2,2X,I3,2X,F3.0) 2002 FORMAT(' *HIGCLU* MOMENTUM ',F8.3,' MASSES ',2F8.4,' RS ',F8.4) 2003 FORMAT(' *HIGCLU* TETA,EKIN0,EKIN1,EKIN ',4F10.4) 2004 FORMAT(' *HIGCLU* TECM,NPB,MASSES: ',F10.4,1X,I3,1X,8F10.4/ $ 1H ,26X,15X,8F10.4) 2005 FORMAT(' *HIGCLU* NUMBER OF FINAL STATE PARTICLES', $ ' LESS THAN 2 ==> CONTINUE WITH 2-BODY SCATTERING') 2006 FORMAT(' *HIGCLU* COMP.',1X,I5,1X,5F7.2) 3001 FORMAT(' *HIGCLU* NUCLEAR EXCITATION ',I5,' PARTICLES PRODUCED', $ ' IN ADDITION TO',I5,' NORMAL PARTICLES') 3003 FORMAT(' *HIGCLU* ',I3,' BLACK TRACK PARTICLES PRODUCED', $ ' WITH TOTAL KINETIC ENERGY OF ',F8.3,' GEV') 3004 FORMAT(' *HIGCLU* ',I5,' HEAVY FRAGMENTS WITH TOTAL ENERGY OF ', $ F8.4,' GEV') C 9999 CONTINUE RETURN END *CMZ : 3.16/00 05/11/93 18.12.42 BY FEDERICO CARMINATI *-- AUTHOR : C--------------------------------------------------------------------- SUBROUTINE HIGHAB(SPROB) C C *** SELF-ABSORBTION IN HEAVY MOLECULES *** C *** NVE 16-MAR-1988 CERN GENEVA *** C C ORIGIN : H.FESEFELDT (11-OCT-1987) C C PARAMETER (MXGKGH=100) PARAMETER (MXGKCU=MXGKGH) COMMON/CURPAR/WEIGHT(10),DDELTN,IFILE,IRUN,NEVT,NEVENT,SHFLAG, * ITHST,ITTOT,ITLST,IFRND,TOFCUT,CMOM(5),CENG(5), * RS,S,ENP(10),NP,NM,NN,NR,NO,NZ,IPA(MXGKCU), * ATNO2,ZNO2 C PARAMETER (MXGKPV=MXGKGH) COMMON /VECUTY/ PV(10,MXGKPV) C SAVE C SPROB=0. EKW=PV(4,MXGKPV)-ABS(PV(5,MXGKPV)) IF(EKW.LT.5.) RETURN ALEKW=LOG(EKW-4.) BLEKW=0.25-0.02*LOG(ATNO2) SPROB=BLEKW*ALEKW IF(SPROB.GT.1.) SPROB=1. RETURN END *CMZ : 3.16/00 05/11/93 18.12.42 BY FEDERICO CARMINATI *-- AUTHOR : C--------------------------------------------------------------------- SUBROUTINE HIGSEL(ISEL) C COMMON/RESULT/XEND,YEND,ZEND,RCA,RCE,AMAS,NCH,TOF,PX,PY,PZ, * USERW,INTCT,P,EN,EK,AMASQ,DELTN,ITK,NTK,IPART,IND, * LCALO,ICEL,SINL,COSL,SINP,COSP, * XOLD,YOLD,ZOLD,POLD,PXOLD,PYOLD,PZOLD, * XSCAT,YSCAT,ZSCAT,PSCAT,PXSCAT,PYSCAT,PZSCAT REAL NCH,INTCT C C DIMENSION RNDM(1) SAVE C CALL GRNDM(RNDM,1) ISEL=1 IF(P.LT.25.+RNDM(1)*25.) ISEL=0 RETURN END *CMZ : 3.16/00 05/11/93 19.46.20 BY FEDERICO CARMINATI *-- AUTHOR : C--------------------------------------------------------------------- SUBROUTINE HIGXPT(IPPP,NFL,AVERN) C C *** GENERATION OF X- AND PT- VALUES FOR ALL PRODUCED PARTICLES *** C *** NVE 02-MAY-1988 CERN GENEVA *** C C ORIGIN : H.FESEFELDT 11-OCT-1987 C C A SIMPLE SINGLE VARIABLE DESCRIPTION E D3S/DP3= F(Q) WITH C Q**2 = (M*X)**2 + PT**2 IS USED. FINAL STATE KINEMATIC IS PRODUCED C BY AN FF-TYPE ITERATIVE CASCADE METHOD C PARAMETER (MXGKGH=100) COMMON/CONSTS/ PI,TWPI,PIBTW,MP,MPI,MMU,MEL,MKCH,MK0,SMP,SMPI, $ SMU,CT,CTKCH,CTK0, $ ML0,MSP,MS0,MSM,MX0,MXM,CTL0,CTSP,CTSM,CTX0,CTXM, $ RMASS(35),RCHARG(35) C REAL MP,MPI,MMU,MEL,MKCH,MK0, * ML0,MSP,MS0,MSM,MX0,MXM C PARAMETER (MXGKCU=MXGKGH) COMMON/CURPAR/WEIGHT(10),DDELTN,IFILE,IRUN,NEVT,NEVENT,SHFLAG, * ITHST,ITTOT,ITLST,IFRND,TOFCUT,CMOM(5),CENG(5), * RS,S,ENP(10),NP,NM,NN,NR,NO,NZ,IPA(MXGKCU), * ATNO2,ZNO2 C COMMON/RESULT/XEND,YEND,ZEND,RCA,RCE,AMAS,NCH,TOF,PX,PY,PZ, * USERW,INTCT,P,EN,EK,AMASQ,DELTN,ITK,NTK,IPART,IND, * LCALO,ICEL,SINL,COSL,SINP,COSP, * XOLD,YOLD,ZOLD,POLD,PXOLD,PYOLD,PZOLD, * XSCAT,YSCAT,ZSCAT,PSCAT,PXSCAT,PYSCAT,PZSCAT REAL NCH,INTCT C COMMON/MAT / LMAT, * DEN(21),RADLTH(21),ATNO(21),ZNO(21),ABSL(21), * CDEN(21),MDEN(21),X0DEN(21),X1DEN(21),RION(21), * MATID(21),MATID1(21,24),PARMAT(21,10), * IFRAT,IFRAC(21),FRAC1(21,10),DEN1(21,10), * ATNO1(21,10),ZNO1(21,10) C PARAMETER (MXEVEN=12*MXGKGH) COMMON/EVENT / NSIZE,NCUR,NEXT,NTOT,EVE(MXEVEN) C COMMON/PRNTFL/INBCD,NEWBCD,INBIN,NEWBIN,NPEVT,NEVTP,LPRT,NPRT(10) LOGICAL LPRT,NPRT C COMMON/ERRCOM/ IER(100) C PARAMETER (MXGKPV=MXGKGH) COMMON /VECUTY/ PV(10,MXGKPV) C C COMMON/GENIN /TECM,AMASS(18),NPG,KGENEV COMMON/GENOUT/PCM(5,18),WGT C C C REAL MASPAR,LAMB,NUCSUP DIMENSION MASPAR(8),BP(8),PTEX(8),C1PAR(5),G1PAR(5),TAVAI(2), $ SIDE(MXGKCU),IAVAI(2),BINL(20),DNDL(20),TWSUP(8), $ NUCSUP(6),PSUP(6),IPAX(100) DIMENSION RNDM(3) SAVE DATA MASPAR/0.75,0.70,0.65,0.60,0.50,0.40,0.20,0.10/ DATA BP/4.00,2.50,2.20,3.00,3.00,1.70,3.50,3.50/ DATA PTEX/1.70,1.70,1.50,1.70,1.40,1.20,1.70,1.20/ DATA C1PAR/0.6,0.6,0.35,0.15,0.10/ DATA G1PAR/2.6,2.6,1.80,1.30,1.20/ DATA BINL/0.,0.1,0.2,0.3,0.4,0.5,0.6,0.7,0.8,0.9,1.0,1.11,1.25 $ ,1.43,1.67,2.0,2.5,3.33,5.00,10.00/ DATA TWSUP/1.,1.,0.7,0.5,0.3,0.2,0.1,0.0/ DATA NUCSUP/1.00,0.7,0.5,0.4,0.5,0.5/ DATA PSUP/3.,6.,20.,50.,100.,1000./ C C** C** FOR ANNIHILATION INTERACTIONS INTRODUCE PROPER KINEMATICS C** CALL CORANH(NIHIL,NFL) C** C** C** CHECK FIRST MASS-INDICES C** EK=ENP(5) EN=ENP(6) P=ENP(7) S=ENP(8) RS=ENP(9) NT=0 DO 1 I=1,100 IF(IPA(I).EQ.0) GOTO 1 NT=NT+1 IPA(NT)=IPA(I) 1 CONTINUE * CALL VZERO(IPA(NT+1),MXGKCU-NT) * CALL UCOPY(IPA(1),IPAX(1),100) CDH DO III = NT+1, MXGKCU IPA(III) = 0 ENDDO DO III = 1, 100 IPAX(III) = IPA(III) ENDDO C** C** FOR LOW MULTIPLICITY USE TWO-BODY RESONANCE MODEL OR SINGLE/DOUBLE C** DIFFRACTION MODEL (--> HIGCLU (--> TWOB (--> COSCAT))) C** CFA=0.025*((ATNO2-1.)/120.)*EXP(-(ATNO2-1.)/120.) IF(NIHIL.GT.0) GOTO 200 IF(NT.GE.8) GOTO 200 IF(EK.LT.1.) GOTO 60 CALL GRNDM(RNDM,1) RAN=RNDM(1) IF(IPART.GE.10.AND.IPART.LE.13.AND.RAN.LT.0.5) GOTO 200 CALL GRNDM(RNDM,1) RAN=RNDM(1) WSUP=TWSUP(NT) IF(RAN.GT.WSUP) GOTO 200 CALL GRNDM(RNDM,1) RAN=RNDM(1)*200.+50. IF(EK.GT.RAN) GOTO 200 60 CONTINUE * CALL UCOPY(IPAX,IPA,100) CDH DO III = 1, 100 IPA(III) = IPAX(III) ENDDO CALL HIGCLU(IPPP,NFL,AVERN) GO TO 9999 C** C** SET EFFECTIVE 4-MOMENTUM OF PRIMARY PARTICLE C** 200 MX =MXGKPV-20 MX1=MX+1 MX2=MX+2 MX3=MX+3 MX4=MX+4 MX5=MX+5 MX6=MX+6 MX7=MX+7 MX8=MX+8 MX9=MX+9 PV( 1,MXGKPV-1)=P*PX PV( 2,MXGKPV-1)=P*PY PV( 3,MXGKPV-1)=P*PZ PV( 4,MXGKPV-1)=EN PV( 5,MXGKPV-1)=AMAS PV( 6,MXGKPV-1)=NCH PV( 7,MXGKPV-1)=TOF PV( 8,MXGKPV-1)=IPART PV( 9,MXGKPV-1)=0. PV(10,MXGKPV-1)=USERW IER(49)=IER(49)+1 C** C** SOME RANDOMISATION OF ORDER OF FINAL STATE PARTICLES C** DO 201 I=3,NT CALL GRNDM(RNDM,1) IPX=IFIX(3.+RNDM(1)*(NT-2.)) IF(IPX.GT.NT) IPX=NT IPA1=IPA(IPX) IPA(IPX)=IPA(I) 201 IPA(I) =IPA1 C** C** DISTRIBUTE IN FORWARD AND BACKWARD HEMISPHERE IN CMS C** SIDE(1)= 1. SIDE(2)=-1. NTB=1 TARG=0. IF(IPART.LT.10.OR.IPART.GT.13) GOTO 53 CALL GRNDM(RNDM,1) IF(RNDM(1).LT.0.9) GOTO 53 IPA1=IPA(1) IPA(1)=IPA(2) IPA(2)=IPA1 53 LEAD=0 IF(IPART.LT.10.OR.IPART.EQ.14.OR.IPART.EQ.16) GOTO 532 IPA1=ABS(IPA(1)) IF(IPA1.LT.10.OR.IPA1.EQ.14.OR.IPA1.EQ.16) GOTO 531 LEAD=IPA1 GOTO 532 531 IPA1=ABS(IPA(2)) IF(IPA1.LT.10.OR.IPA1.EQ.14.OR.IPA1.EQ.16) GOTO 532 LEAD=IPA1 532 DO 3 I=1,NT IF(I.LE.2) GOTO 54 SIDE(I)= 1. CALL GRNDM(RNDM,1) IF(RNDM(1).LT.0.5) SIDE(I)=-1. IF(SIDE(I).LT.-0.5) NTB=NTB+1 54 CONTINUE 3 CONTINUE TB=2.*NTB CALL GRNDM(RNDM,1) IF(RS.LT.(2.0+RNDM(1))) TB=(2.*NTB+NT)/2. C** C** ADD PARTICLES FROM INTRANUCLEAR CASCADE C** AFC=0.312+0.200*LOG(LOG(S))+S**1.5/6000. IF(AFC.GT.0.5) AFC=0.5 XTARG=AFC*(ATNO2**0.33 -1.0)*TB IF(XTARG.LE.0.) XTARG=0.01 C** SOME EXTRA STRANGE PARTICLES XSTRAN=0.030*XTARG CALL POISSO(XSTRAN,NSTRAN) C** NUCLEONS AND PIONS DO 881 IPX=1,6 IF(P.LE.PSUP(IPX)) GOTO 882 881 CONTINUE IPX = 6 882 XPNHMF = XTARG*NUCSUP(IPX) XSHHMF = XTARG - XPNHMF IF(XSHHMF.LT.0.01) XSHHMF=0.01 IF(XPNHMF.LT.0.01) XPNHMF=0.01 SSHHMF=0.5*XSHHMF SPNHMF=0.9*XPNHMF RSHHMF=SSHHMF**2/XSHHMF RPNHMF=SPNHMF**2/XPNHMF IF(RSHHMF.LT.1.1) THEN CALL POISSO(XSHHMF,NSHHMF) GOTO 541 ELSE RSHHMF=XSHHMF/(RSHHMF-1.) IF(RSHHMF.LE.20.) THEN CALL SVGAM7(RSHHMF,XHMF) ELSE KRSHMF=IFIX(RSHHMF+0.5) CALL SVERL2(KRSHMF,XHMF) ENDIF XSHHMF=XHMF*XSHHMF/RSHHMF CALL POISSO(XSHHMF,NSHHMF) ENDIF 541 IF(RPNHMF.LE.1.1) THEN CALL POISSO(XPNHMF,NPNHMF) GOTO 542 ELSE RPNHMF=XPNHMF/(RPNHMF-1.) IF(RPNHMF.LE.20.) THEN CALL SVGAM7(RPNHMF,XHMF) ELSE KRPHMF=IFIX(RPNHMF+0.5) CALL SVERL2(KRPHMF,XHMF) ENDIF XPNHMF=XHMF*XPNHMF/RPNHMF CALL POISSO(XPNHMF,NPNHMF) ENDIF 542 NTARG=NSHHMF+NPNHMF+NSTRAN NT2=NT+NTARG IF(NT2.LE.MX) GOTO 2 NT2=MX NTARG=NT2-NT 2 CONTINUE IF (NPRT(4)) WRITE(NEWBCD,3001) NTARG,NT NT1=NT+1 IF(NTARG.EQ.0) GOTO 51 C** C** CHECK NUMBER OF EXTRA NUCLEONS AND PIONS C** DO 4 I=NT1,NT2 IF(NPNHMF.GT.0) GOTO 52 IF(NSTRAN.GT.0) GOTO 59 CALL GRNDM(RNDM,2) IPA(I)=-(7+IFIX(RNDM(1)*3.0)) SIDE(I)=-2. IF(RNDM(2).LT.0.2) THEN IPA(I)=IABS(IPA(I)) SIDE(I)=1. NTARG=NTARG-1 ENDIF GOTO 4 52 IPA(I)=-16 PNRAT=1.-ZNO2/ATNO2 CALL GRNDM(RNDM,1) IF(RNDM(1).GT.PNRAT) IPA(I)=-14 TARG=TARG+1. SIDE(I)=-2. NPNHMF=NPNHMF-1 GOTO 4 59 CALL GRNDM(RNDM,2) IPA(I)=-18 IF(RNDM(1).GT.0.14) IPA(I)=-21 IF(RNDM(1).GT.0.20) IPA(I)=-10 IF(RNDM(1).GT.0.43) IPA(I)=-11 IF(RNDM(1).GT.0.66) IPA(I)=-12 IF(RNDM(1).GT.0.89) IPA(I)=-13 SIDE(I)=-2. IF(RNDM(2).LT.0.2) THEN IPA(I)=IABS(IPA(I)) SIDE(I)=1. NTARG=NTARG-1 ENDIF NSTRAN=NSTRAN-1 4 CONTINUE NT=NT2 C** C** CHOOSE MASSES AND CHARGES FOR ALL PARTICLES C** 51 DO 5 I=1,NT IPA1=ABS(IPA(I)) PV(5,I)=RMASS(IPA1) PV(6,I)=RCHARG(IPA1) PV(7,I)=1. IF(PV(5,I).LT.0.) PV(7,I)=-1. PV(5,I)=ABS(PV(5,I)) 5 CONTINUE C** C** CHECK AVAILABLE KINETIC ENERGY, IN THIS MODEL CONSERVATION OF C** KINETIC ENERGY IN FORWARD AND BACKWARD HEMISPHERE IS ASSUMED C** 6 IF(NT.LE.1) GOTO 60 TAVAI(1)=RS/2. TAVAI(2)=(TARG+1.)*RS/2. IAVAI(1)=0 IAVAI(2)=0 DO 7 I=1,NT L=1 IF(SIDE(I).LT.0.) L=2 IAVAI(L)=IAVAI(L)+1 TAVAI(L)=TAVAI(L)-ABS(PV(5,I)) 7 CONTINUE NTH=NT IF(NTH.GT.10) NTH=10 IF (NPRT(4)) $ WRITE(NEWBCD,3002) TAVAI,IAVAI,(IPA(I),SIDE(I),I=1,NTH) IF(IAVAI(1).LE.0) GOTO 60 IF(IAVAI(2).LE.0) GOTO 60 IF(TAVAI(1).GT.0.) GOTO 11 CALL GRNDM(RNDM,1) ISKIP=IFIX(RNDM(1)*(IAVAI(1)-1))+1 IS=0 DO 10 I=1,NT II=NT-I+1 IF(SIDE(II).LT.0.) GOTO 10 IS=IS+1 IF(IS.NE.ISKIP) GOTO 10 IF(II.EQ.NT) GOTO 9 NT1=II+1 NT2=NT DO 8 J=NT1,NT2 IPA(J-1)=IPA(J) SIDE(J-1)=SIDE(J) DO 71 K=1,10 71 PV(K,J-1)=PV(K,J) 8 CONTINUE GOTO 9 10 CONTINUE 9 IPA(NT)=0 SIDE(NT)=0. NT=NT-1 GOTO 6 11 IF(TAVAI(2).GT.0.) GOTO 15 CALL GRNDM(RNDM,1) ISKIP=IFIX(RNDM(1)*(IAVAI(2)-1))+1 IS=0 DO 14 I=1,NT II=NT-I+1 IF(SIDE(II).GT.0.) GOTO 14 IS=IS+1 IF(IS.NE.ISKIP) GOTO 14 IF(SIDE(II).LT.-1.5) NTARG=NTARG-1 IF(NTARG.LT.0) NTARG=0 IF(II.EQ.NT) GOTO 13 NT1=II+1 NT2=NT DO 12 J=NT1,NT2 IPA(J-1)=IPA(J) SIDE(J-1)=SIDE(J) DO 74 K=1,10 74 PV(K,J-1)=PV(K,J) 12 CONTINUE GOTO 13 14 CONTINUE 13 IPA(NT)=0 SIDE(NT)=0. NT=NT-1 GOTO 6 15 IF(NT.LE.1) GOTO 60 IF(NT.EQ.MX) GOTO 29 NT1=NT+1 NT2=MX DO 28 I=NT1,NT2 28 IPA(I)=0 29 CONTINUE C** C** NOW THE PREPARATION IS FINISHED. C** DEFINE INITIAL STATE VECTORS FOR LORENTZ TRANSFORMATIONS. C** PV( 1,MX1)=0. PV( 2,MX1)=0. PV( 3,MX1)=P PV( 4,MX1)=SQRT(P*P+AMAS*AMAS) PV( 5,MX1)=ABS(AMAS) PV( 1,MX2)=0. PV( 2,MX2)=0. PV( 3,MX2)=0. PV( 4,MX2)=MP PV( 5,MX2)=MP PV( 1,MX4)=0. PV( 2,MX4)=0. PV( 3,MX4)=0. PV( 4,MX4)=MP*(1.+TARG) PV( 5,MX4)=PV(4,MX4) PV( 1,MX8)=0. PV( 2,MX8)=0. PV( 3,MX8)=0. PV( 1,MX9)=1. PV( 2,MX9)=0. PV( 3,MX9)=0. CALL ADD(MX1,MX2,MX3) CALL ADD(MX4,MX1,MX4) CALL LOR(MX1,MX3,MX1) CALL LOR(MX2,MX3,MX2) C** C** MAIN LOOP FOR 4-MOMENTUM GENERATION , SEE PITHA-REPORT (AACHEN) C** FOR A DETAILED DESCRIPTION OF THE METHOD. C** CALL GRNDM(RNDM,1) PHI=RNDM(1)*TWPI EKIN1=0. EKIN2=0. DO 39 J=1,10 PV(J,MX5)=0. 39 PV(J,MX6)=0. NPG=0 RMG0=0. TARG1=0. DO 16 III=1,NT I=NT-III+1 IPA1=ABS(IPA(I)) C** C** COUNT NUMBER OF BACKWARD NUCLEONS C** IF(I.EQ.2) THEN IF(IPA1.GT.16) THEN CALL GRNDM(RNDM,1) IF(RNDM(1).LT.0.2) GOTO 301 ELSE IF(IPA1.GE.14) THEN GOTO 301 ENDIF ENDIF IF(SIDE(I).GT.-1.5) GOTO 38 IF(IPA1.EQ.14.OR.IPA1.EQ.16) GOTO 301 GOTO 38 301 NPG=NPG+1 IF(NPG.GT.18) GOTO 38 RMG0=RMG0+ABS(PV(5,I)) SIDE(I)=-3. TARG1=TARG1+1. GOTO 16 38 J=3 IF(IPA1.LT.14) J=2 IF(IPA1.LT.10) J=1 IF(I.LE.2) J=J+3 IF(SIDE(I).LT.-1.5) J=7 IF(J.EQ.7.AND.IPA1.GE.14) J=8 C** C** SET PT - AND PHI VALUES, THEY ARE CHANGED SOMEWHAT IN THE ITERATION C** LOOP, SET MASS PARAMETER FOR LAMBDA FRAGMENTATION MODEL C** CALL GRNDM(RNDM,1) RAN=RNDM(1) BPP=BP(J) BPE=PTEX(J) PT2=-LOG(1.-RAN)/BPP ASPAR=MASPAR(J) PT2=PT2**BPE PT =SQRT(PT2) IF(PT.LT.0.05) THEN CALL GRNDM(RNDM,1) PT=0.3*RNDM(1) ENDIF IF(PT.LT.0.001) PT=0.001 PV(1,I)=PT*COS(PHI) PV(2,I)=PT*SIN(PHI) PV(10,I)=PT BINL(1)=0. RLMAX=1./PV(10,I) DO 73 J=2,20 73 BINL(J)=RLMAX*(J-1)/19. ET=PV(4,MX1) IF(SIDE(I).LT.0.) THEN ET=PV(4,MX2) ENDIF DNDL(1)=0. NTRIAL=0 C** C** START OF BIG ITERATION LOOP C** 30 NTRIAL=NTRIAL+1 IF(NTRIAL.GT. 2) GOTO 169 DO 17 L=2,20 DNDL(L)=0. X=(BINL(L)+BINL(L-1))/2. IF(PV(10,I).LT.0.001) PV(10,I)=0.001 IF(X.GT.1./PV(10,I)) GOTO 17 DX=BINL(L)-BINL(L-1) DNDL(L)=ASPAR/SQRT((1.+(ASPAR*X)**2)**3) DNDL(L)=ET*DNDL(L)/SQRT((X*PV(10,I)*ET)**2+PV(10,I)**2 * +PV(5,I)**2) DNDL(L)=DNDL(L)*DX 17 DNDL(L)=DNDL(L-1)+DNDL(L) NTRI=0 31 CALL GRNDM(RNDM,1) RAN=RNDM(1)*DNDL(20) DO 18 L=2,20 IF(RAN.LT.DNDL(L)) GOTO 19 18 CONTINUE C** C** START OF SMALL ITERATION LOOP C** 19 NTRI=NTRI+1 CALL GRNDM(RNDM,1) RAN=RNDM(1) DX=BINL(L)-BINL(L-1) LAMB=BINL(L-1)+RAN*DX/2. X=PV(10,I)*LAMB IF(X.GT.1.) X=1. X=X*SIDE(I)/ABS(SIDE(I)) PV(3,I)=X*ET PV(4,I)=PV(3,I)**2+PV(10,I)**2+PV(5,I)**2 PV(4,I)=SQRT(PV(4,I)) IF(SIDE(I).LT.0.) GOTO 165 IF(I.GT.2) GOTO 20 EKIN=TAVAI(1)-EKIN1 CALL NORMAL(RAN) IF(EKIN.LT.0.) EKIN=0.04*ABS(RAN) PV(4,I)=ABS(PV(5,I))+EKIN RNVE=ABS(PV(4,I)**2-PV(5,I)**2) PP=SQRT(RNVE) CALL LENGTX(I,PP1) C IF (PP1 .GE. 1.0E-6) GO TO 8000 CALL GRNDM(RNDM,2) RTHNVE=PI*RNDM(1) PHINVE=TWPI*RNDM(2) PV(1,I)=PP*SIN(RTHNVE)*COS(PHINVE) PV(2,I)=PP*SIN(RTHNVE)*SIN(PHINVE) PV(3,I)=PP*COS(RTHNVE) GO TO 8001 8000 CONTINUE PV(3,I) = PP**2 - PV(10,I)**2 IF(PV(3,I).LT.0.) PV(3,I)=0. PV(3,I) = SQRT(PV(3,I))*SIDE(I)/ABS(SIDE(I)) 8001 CONTINUE C CALL ADD(MX5,I,MX5) GOTO 16 20 EKIN=EKIN1+PV(4,I)-ABS(PV(5,I)) IF(EKIN.LT.0.95*TAVAI(1)) GOTO 161 IF(NTRI.GT. 5) GOTO 167 PV(10,I)=PV(10,I)*0.9 PV( 1,I)=PV( 1,I)*0.9 PV( 2,I)=PV( 2,I)*0.9 DNDL(20)=DNDL(20)*0.9 IF((TAVAI(2)-ABS(PV(5,I))).LT.0.) GOTO 31 SIDE(I)=-1. TAVAI(1)=TAVAI(1)+ABS(PV(5,I)) TAVAI(2)=TAVAI(2)-ABS(PV(5,I)) GOTO 31 161 CALL ADD(MX5,I,MX5) EKIN1=EKIN1+PV(4,I)-ABS(PV(5,I)) GOTO 163 165 EKIN=EKIN2+PV(4,I)-ABS(PV(5,I)) XXX=0.95+0.05*TARG/20. IF(XXX.GT.0.999) X=0.999 IF(EKIN.LT.XXX*TAVAI(2)) GOTO 166 IF(NTRI.GT. 5) GOTO 167 PV(10,I)=PV(10,I)*0.9 PV( 1,I)=PV( 1,I)*0.9 PV( 2,I)=PV( 2,I)*0.9 DNDL(20)=DNDL(20)*0.9 IF((TAVAI(1)-ABS(PV(5,I))).LT.0.) GOTO 31 SIDE(I)=+1. TAVAI(1)=TAVAI(1)-ABS(PV(5,I)) TAVAI(2)=TAVAI(2)+ABS(PV(5,I)) GOTO 31 166 CALL ADD(MX6,I,MX6) EKIN2=EKIN2+PV(4,I)-ABS(PV(5,I)) 163 CALL ADD(MX5,MX6,MX7) PV(3,MX7)=0. CALL ANG(MX7,MX9,COST,PHIS) IF(PV(2,MX7).LT.0.) PHIS=TWPI-PHIS CALL NORMAL(RAN) RAN=RAN*PI/12. PHI=PHIS+PI+RAN IF(PHI.GT.TWPI) PHI=PHI-TWPI IF(PHI.LT.0.) PHI=TWPI-PHI GOTO 16 C** C** PARTICLE MOMENTUM ZERO, REDUCE KINETIC ENERGY OF ALL OTHER C** 167 EKIN1=0. EKIN2=0. DO 162 J=1,10 PV(J,MX5)=0. 162 PV(J,MX6)=0. II=I+1 DO 168 L=II,NT IF(ABS(IPA(L)).GE.14.AND.SIDE(L).LT.0.) GOTO 168 PV(4,L)=PV(4,L)*0.95+0.05*ABS(PV(5,L)) IF(PV(4,L).LT.ABS(PV(5,L))) PV(4,L)=ABS(PV(5,L)) RNVE=ABS(PV(4,L)**2-PV(5,L)**2) PP=SQRT(RNVE) CALL LENGTX(L,PP1) C IF (PP1 .GE. 1.0E-6) GO TO 8002 CALL GRNDM(RNDM,2) RTHNVE=PI*RNDM(1) PHINVE=TWPI*RNDM(2) PV(1,L)=PP*SIN(RTHNVE)*COS(PHINVE) PV(2,L)=PP*SIN(RTHNVE)*SIN(PHINVE) PV(3,L)=PP*COS(RTHNVE) GO TO 8003 8002 CONTINUE PV(1,L)=PV(1,L)*PP/PP1 PV(2,L)=PV(2,L)*PP/PP1 PV(3,L)=PV(3,L)*PP/PP1 8003 CONTINUE C PV(10,L)=SQRT(PV(1,L)**2+PV(2,L)**2) IF(SIDE(L).LT.0.) GOTO 164 EKIN1=EKIN1+PV(4,L)-ABS(PV(5,L)) CALL ADD(MX5,L,MX5) GOTO 168 164 EKIN2=EKIN2+PV(4,L)-ABS(PV(5,L)) CALL ADD(MX6,L,MX6) 168 CONTINUE C *** NEXT STMT. CHANGED TO PREVENT FROM INFINITE LOOPING *** C************* GOTO 38 GO TO 30 C** C** SKIP PARTICLE, IF NOT ENOUGH ENERGY C** 169 IPA(I)=0 DO 170 J=1,10 170 PV(J,I)=0. GOTO 163 16 CONTINUE NTRI=0 II=0 DO 320 I=1,NT IF(IPA(I).EQ.0) GOTO 320 II=II+1 IPA(II)=IPA(I) SIDE(II)=SIDE(I) DO 321 J=1,10 321 PV(J,II)=PV(J,I) 320 CONTINUE NT=II C** C** BACKWARD NUCLEONS PRODUCED WITH A CLUSTER MODEL C** IF(NPG.EQ.0) GOTO 330 RMG=RMG0 IF(NPG.EQ.1) GOTO 310 NPG1=NPG IF(NPG1.GT.5) NPG1=5 CALL GRNDM(RNDM,1) RMG=-LOG(1.-RNDM(1)) GPAR=G1PAR(NPG1) CPAR=C1PAR(NPG1) DUMNVE=GPAR IF(DUMNVE.EQ.0.) DUMNVE=1.0E-10 RMG=RMG0+RMG**CPAR/DUMNVE 310 GA=1.2 EKIT1=0.04 EKIT2=0.6 IF(EK.GT.5.) GOTO 311 EKIT1=EKIT1*EK**2/25. EKIT2=EKIT2*EK**2/25. 311 A=(1.-GA)/(EKIT2**(1.-GA)-EKIT1**(1.-GA)) DO 312 I=1,NT IF(SIDE(I).GT.-2.5) GOTO 312 CALL GRNDM(RNDM,3) EKIT=(RNDM(1)*(1.-GA)/A+EKIT1**(1.-GA))**(1./(1.-GA)) PV(4,I)=EKIT+PV(5,I) DUMNVE=ABS(PV(4,I)**2-PV(5,I)**2) PP=SQRT(DUMNVE) COST=LOG(2.23*RNDM(2)+0.383)/0.96 IF(COST.LT.-1.) COST=-1. IF(COST.GT. 1.) COST= 1. DUMNVE=1.0-COST*COST IF(DUMNVE.LT.0.0) DUMNVE=0.0 SINT=SQRT(DUMNVE) PHI=TWPI*RNDM(3) PV(1,I)=PP*SINT*SIN(PHI) PV(2,I)=PP*SINT*COS(PHI) PV(3,I)=PP*COST CALL LOR(I,MX3,I) CALL ADD(MX6,I,MX6) 312 CONTINUE 330 IF (NPRT(4)) $ WRITE(NEWBCD,2002) NTRIAL,EKIN1,EKIN2,TAVAI(1),TAVAI(2) 175 IF (.NOT.NPRT(4)) GOTO 36 CALL ADD(MX5,MX6,MX7) EKIN1=PV(4,MX1)+PV(4,MX2) EKIN2=PV(4,MX5)+PV(4,MX6) WRITE(NEWBCD,2000) EKIN1,EKIN2 I=MX1 WRITE(NEWBCD,2001) I,(PV(J,I),J=1,4) I=MX2 WRITE(NEWBCD,2001) I,(PV(J,I),J=1,4) I=MX5 WRITE(NEWBCD,2001) I,(PV(J,I),J=1,5) I=MX6 WRITE(NEWBCD,2001) I,(PV(J,I),J=1,5) DO 37 I=1,NT 37 WRITE(NEWBCD,2001) I,(PV(J,I),J=1,10),IPA(I),SIDE(I) C** C** LORENTZ TRANSFORMATION IN LAB SYSTEM C** 36 IF(NT.LE.2) GOTO 60 TARG=0. DO 601 I=1,NT IF(PV(5,I).GT.0.5) TARG=TARG+1. CALL LOR(I,MX2,I) 601 CONTINUE IF(TARG.LT.0.5) TARG=1. IF(LEAD.EQ.0) GOTO 6085 DO 6081 I=1,NT IF(ABS(IPA(I)).EQ.LEAD) GOTO 6085 6081 CONTINUE I=1 IF(LEAD.GE.14.AND.ABS(IPA(2)).GE.14) I=2 IF(LEAD.LT.14.AND.ABS(IPA(2)).LT.14) I=2 IPA(I)=LEAD EKIN=PV(4,I)-ABS(PV(5,I)) PV(5,I)=RMASS(LEAD) PV(7,I)=1. IF(PV(5,I).LT.0.) PV(7,I)=-1. PV(5,I)=ABS(PV(5,I)) PV(6,I)=RCHARG(LEAD) PV(4,I)=PV(5,I)+EKIN CALL LENGTX(I,PP) RNVE=ABS(PV(4,I)**2-PV(5,I)**2) PP1=SQRT(RNVE) PV(1,I)=PP1*PV(1,I)/PP PV(2,I)=PP1*PV(2,I)/PP PV(3,I)=PP1*PV(3,I)/PP 6085 KGENEV=1 PV(1,MX4)=0. PV(2,MX4)=0. PV(3,MX4)=P PV(4,MX4)=SQRT(P*P+AMAS*AMAS) PV(5,MX4)=ABS(AMAS) EKIN0=PV(4,MX4)-PV(5,MX4) PV(1,MX5)=0. PV(2,MX5)=0. PV(3,MX5)=0. PV(4,MX5)=MP*TARG PV(5,MX5)=PV(4,MX5) EKIN=PV(4,MX4)+PV(4,MX5) I=MX4 IF (NPRT(4)) WRITE(NEWBCD,2001) I,(PV(J,I),J=1,5) I=MX5 IF (NPRT(4)) WRITE(NEWBCD,2001) I,(PV(J,I),J=1,5) CALL ADD(MX4,MX5,MX6) CALL LOR(MX4,MX6,MX4) CALL LOR(MX5,MX6,MX5) TECM=PV(4,MX4)+PV(4,MX5) NPG=NT PV(1,MX8)=0. PV(2,MX8)=0. PV(3,MX8)=0. PV(4,MX8)=0. PV(5,MX8)=0. EKIN1=0. DO 598 I=1,NPG IF (NPRT(4)) WRITE(NEWBCD,2001) I,(PV(J,I),J=1,10),IPA(I),SIDE(I) CALL ADD(MX8,I,MX8) EKIN1=EKIN1+PV(4,I)-PV(5,I) EKIN=EKIN-PV(5,I) IF(I.GT.18) GOTO 598 AMASS(I)=PV(5,I) 598 CONTINUE IF(NPG.GT.18) GOTO 597 CALL PHASP EKIN=0. DO 599 I=1,NPG PV(1,MX7)=PCM(1,I) PV(2,MX7)=PCM(2,I) PV(3,MX7)=PCM(3,I) PV(4,MX7)=PCM(4,I) PV(5,MX7)=AMASS(I) CALL LOR(MX7,MX5,MX7) 599 EKIN=EKIN+PV(4,MX7)-PV(5,MX7) CALL ANG(MX8,MX4,COST,TETA) IF (NPRT(4)) WRITE(NEWBCD,2003) TETA,EKIN0,EKIN1,EKIN C** C** MAKE SHURE, THAT KINETIC ENERGIES ARE CORRECT. C** EKIN= KINETIC ENERGY THEORETICALLY C** EKIN1= KINETIC ENERGY SIMULATED C** 597 IF(EKIN1.EQ.0.) GOTO 600 PV(1,MX7)=0. PV(2,MX7)=0. PV(3,MX7)=0. PV(4,MX7)=0. PV(5,MX7)=0. WGT=EKIN/EKIN1 EKIN1=0. DO 602 I=1,NT EKIN=PV(4,I)-PV(5,I) EKIN=EKIN*WGT PV(4,I)=EKIN+PV(5,I) RNVE=ABS(PV(4,I)**2-PV(5,I)**2) PP=SQRT(RNVE) CALL LENGTX(I,PP1) C IF (PP1 .GE. 1.0E-6) GO TO 8008 CALL GRNDM(RNDM,2) RTHNVE=PI*RNDM(1) PHINVE=TWPI*RNDM(2) PV(1,I)=PP*SIN(RTHNVE)*COS(PHINVE) PV(2,I)=PP*SIN(RTHNVE)*SIN(PHINVE) PV(3,I)=PP*COS(RTHNVE) GO TO 8009 8008 CONTINUE PV(1,I)=PV(1,I)*PP/PP1 PV(2,I)=PV(2,I)*PP/PP1 PV(3,I)=PV(3,I)*PP/PP1 8009 CONTINUE C EKIN1=EKIN1+EKIN CALL ADD(MX7,I,MX7) 602 CONTINUE CALL ANG(MX7,MX4,COST,TETA) IF (NPRT(4)) WRITE(NEWBCD,2003) TETA,EKIN0,EKIN1 C** C** ROTATE IN DIRECTION OF Z-AXIS, THIS DOES DISTURB IN SOME WAY OUR C** INCLUSIVE DISTRIBUTIONS, BUT IT IS NESSACARY FOR MOMENTUM CONSER- C** VATION. C** 600 PV(1,MX7)=0. PV(2,MX7)=0. PV(3,MX7)=0. PV(4,MX7)=0. PV(5,MX7)=0. DO 596 I=1,NT CALL ADD(MX7,I,MX7) 596 CONTINUE C** C** SOME SMEARING IN TRANSVERSE DIRECTION FROM FERMI MOTION C** * CALL RANNOR(RAN1,RAN2) CALL GRNDM(RNDM,2) RY=RNDM(1) RZ=RNDM(2) RX=6.283185*RZ A1=SQRT(-2.*LOG(RY)) RAN1=A1*SIN(RX) RAN2=A1*COS(RX) PV(1,MX7)=PV(1,MX7)+RAN1*0.020*TARG PV(2,MX7)=PV(2,MX7)+RAN2*0.020*TARG CALL DEFS(MX4,MX7,MX8) PV(1,MX7)=0. PV(2,MX7)=0. PV(3,MX7)=0. PV(4,MX7)=0. PV(5,MX7)=0. DO 595 I=1,NT CALL TRAC(I,MX8,I) CALL ADD(MX7,I,MX7) 595 CONTINUE CALL ANG(MX7,MX4,COST,TETA) IF (NPRT(4)) WRITE(NEWBCD,2003) TETA C** C** ROTATE IN DIRECTION OF PRIMARY PARTICLE, SUBTRACT BINDING ENERGIES C** AND MAKE SOME FURTHER CORRECTIONS IF REQUIRED (STEEP, STEEQ) C** DEKIN=0. NPIONS=0 EK1=0. EK2=0. DO 21 I=1,NT CALL DEFS1(I,MXGKPV-1,I) IF (NPRT(4)) WRITE(NEWBCD,2001) I,(PV(J,I),J=1,10),IPA(I),SIDE(I) IF(ATNO2.LT.1.5) GOTO 21 CALL LENGTX(I,PP) EKIN=PV(4,I)-ABS(PV(5,I)) CALL NORMAL(RAN) EKIN=EKIN-CFA*(1.+0.5*RAN) IF (EKIN .LT. 1.0E-6) EKIN=1.0E-6 CALL STEEQ(XXH,I) DEKIN=DEKIN+EKIN*(1.-XXH) EKIN=EKIN*XXH IF(ABS(IPA(I)).GE.7.AND.ABS(IPA(I)).LE.9) NPIONS=NPIONS+1 IF(ABS(IPA(I)).GE.7.AND.ABS(IPA(I)).LE.9) EK1=EK1+EKIN PP1=SQRT(EKIN*(EKIN+2.*ABS(PV(5,I)))) PV(4,I)=EKIN+ABS(PV(5,I)) C IF (PP .GE. 1.0E-6) GO TO 8010 CALL GRNDM(RNDM,2) RTHNVE=PI*RNDM(1) PHINVE=TWPI*RNDM(2) PV(1,I)=PP1*SIN(RTHNVE)*COS(PHINVE) PV(2,I)=PP1*SIN(RTHNVE)*SIN(PHINVE) PV(3,I)=PP1*COS(RTHNVE) GO TO 8011 8010 CONTINUE PV(1,I)=PV(1,I)*PP1/PP PV(2,I)=PV(2,I)*PP1/PP PV(3,I)=PV(3,I)*PP1/PP 8011 CONTINUE C 21 CONTINUE IF(EK1.EQ.0.) GOTO 23 IF(NPIONS.EQ.0) GOTO 23 DEKIN=1.+DEKIN/EK1 DO 22 I=1,NT IF(ABS(IPA(I)).LT.7.OR.ABS(IPA(I)).GT.9) GOTO 22 CALL LENGTX(I,PP) EKIN=PV(4,I)-ABS(PV(5,I)) EKIN=EKIN*DEKIN IF (EKIN .LT. 1.0E-6) EKIN=1.0E-6 PP1=SQRT(EKIN*(EKIN+2.*ABS(PV(5,I)))) PV(4,I)=EKIN+ABS(PV(5,I)) C IF (PP .GE. 1.0E-6) GO TO 8012 CALL GRNDM(RNDM,2) RTHNVE=PI*RNDM(1) PHINVE=TWPI*RNDM(2) PV(1,I)=PP1*SIN(RTHNVE)*COS(PHINVE) PV(2,I)=PP1*SIN(RTHNVE)*SIN(PHINVE) PV(3,I)=PP1*COS(RTHNVE) GO TO 8013 8012 CONTINUE PV(1,I)=PV(1,I)*PP1/PP PV(2,I)=PV(2,I)*PP1/PP PV(3,I)=PV(3,I)*PP1/PP 8013 CONTINUE C 22 CONTINUE C** C** ADD BLACK TRACK PARTICLES, THE TOTAL NUMBER OF PARTICLES PRODUCED C** IS RESTRICTED TO 198, THIS MAY HAVE INFLUENCE ON VERY HIGH ENERGY C** FIRST PROTONS AND NEUTRONS C** 23 IF(ATNO2.LT.1.5) GOTO 40 CALL HIGHAB(SPROB) CALL GRNDM(RNDM,1) IF(RNDM(1).LT.SPROB) GOTO 40 TEX=ENP(1) SPALL=TARG IF(TEX.LT.0.001) GOTO 445 BLACK=(1.5+1.25*TARG)*ENP(1)/(ENP(1)+ENP(3)) CALL POISSO(BLACK,NBL) IF (NPRT(4)) WRITE(NEWBCD,3003) NBL,TEX IF(IFIX(TARG)+NBL.GT.ATNO2) NBL=ATNO2-TARG IF(NT+NBL.GT.MXGKPV-10) NBL=MXGKPV-10-NT IF(NBL.LE.0) GOTO 445 EKIN=TEX/NBL EKIN2=0. CALL STEEP(XX) DO 441 I=1,NBL CALL GRNDM(RNDM,1) IF(RNDM(1).LT.SPROB) GOTO 441 IF(NT.EQ.MXGKPV-10) GOTO 441 IF(EKIN2.GT.TEX) GOTO 443 CALL GRNDM(RNDM,1) RAN1=RNDM(1) CALL NORMAL(RAN2) EKIN1=-EKIN*LOG(RAN1)-CFA*(1.+0.5*RAN2) IF(EKIN1.LT.0.0) EKIN1=-0.010*LOG(RAN1) EKIN1=EKIN1*XX EKIN2=EKIN2+EKIN1 IF(EKIN2.GT.TEX) EKIN1=TEX-(EKIN2-EKIN1) IF (EKIN1 .LT. 0.0) EKIN1=1.0E-6 IPA1=16 PNRAT=1.-ZNO2/ATNO2 CALL GRNDM(RNDM,3) IF(RNDM(1).GT.PNRAT) IPA1=14 NT=NT+1 SPALL=SPALL+1. COST=-1.+RNDM(2)*2. SINT=SQRT(ABS(1.-COST*COST)) PHI=TWPI*RNDM(3) IPA(NT)=-IPA1 SIDE(NT)=-4. PV(5,NT)=ABS(RMASS(IPA1)) PV(6,NT)=RCHARG(IPA1) PV(7,NT)=1. PV(4,NT)=EKIN1+PV(5,NT) RNVE=ABS(PV(4,NT)**2-PV(5,NT)**2) PP=SQRT(RNVE) PV(1,NT)=PP*SINT*SIN(PHI) PV(2,NT)=PP*SINT*COS(PHI) PV(3,NT)=PP*COST 441 CONTINUE 443 IF(ATNO2.LT.10.) GOTO 445 IF(EK.GT.2.0) GOTO 445 II=NT+1 KK=0 EKA=EK IF(EKA.GT.1.) EKA=EKA*EKA IF(EKA.LT.0.1) EKA=0.1 IKA=3.6*EXP((ZNO2**2/ATNO2-35.56)/6.45)/EKA IF(IKA.LE.0) GO TO 445 DO 444 I=1,NT II=II-1 IF(IPA(II).NE.-14) GOTO 444 IPA(II)=-16 IPA1 = 16 PV(5,II)=ABS(RMASS(IPA1)) PV(6,II)=RCHARG(IPA1) KK=KK+1 IF(KK.GT.IKA) GOTO 445 444 CONTINUE C** C** THEN ALSO DEUTERONS, TRITONS AND ALPHAS C** 445 TEX=ENP(3) IF(TEX.LT.0.001) GOTO 40 BLACK=(1.5+1.25*TARG)*ENP(3)/(ENP(1)+ENP(3)) CALL POISSO(BLACK,NBL) IF(NT+NBL.GT.MXGKPV-10) NBL=MXGKPV-10-NT IF(NBL.LE.0) GOTO 40 EKIN=TEX/NBL EKIN2=0. CALL STEEP(XX) IF (NPRT(4)) WRITE(NEWBCD,3004) NBL,TEX DO 442 I=1,NBL CALL GRNDM(RNDM,1) IF(RNDM(1).LT.SPROB) GOTO 442 IF(NT.EQ.MXGKPV-10) GOTO 442 IF(EKIN2.GT.TEX) GOTO 40 CALL GRNDM(RNDM,1) RAN1=RNDM(1) CALL NORMAL(RAN2) EKIN1=-EKIN*LOG(RAN1)-CFA*(1.+0.5*RAN2) IF(EKIN1.LT.0.0) EKIN1=-0.010*LOG(RAN1) EKIN1=EKIN1*XX EKIN2=EKIN2+EKIN1 IF(EKIN2.GT.TEX) EKIN1=TEX-(EKIN2-EKIN1) IF (EKIN1 .LT. 0.0) EKIN1=1.0E-6 CALL GRNDM(RNDM,3) COST=-1.+RNDM(1)*2. SINT=SQRT(ABS(1.-COST*COST)) PHI=TWPI*RNDM(2) RAN=RNDM(3) IPA(NT+1)=-30 IF(RAN.GT.0.60) IPA(NT+1)=-31 IF(RAN.GT.0.90) IPA(NT+1)=-32 SIDE(NT+1)=-4. PV(5,NT+1)=(ABS(IPA(NT+1))-28)*MP SPALL=SPALL+PV(5,NT+1)*1.066 IF(SPALL.GT.ATNO2) GOTO 40 NT=NT+1 PV(6,NT)=1. IF(IPA(NT).EQ.-32) PV(6,NT)=2. PV(7,NT)=1. PV(4,NT)=PV(5,NT)+EKIN1 RNVE=ABS(PV(4,NT)**2-PV(5,NT)**2) PP=SQRT(RNVE) PV(1,NT)=PP*SINT*SIN(PHI) PV(2,NT)=PP*SINT*COS(PHI) PV(3,NT)=PP*COST 442 CONTINUE C** C** STORE ON EVENT COMMON C** 40 CALL GRNDM(RNDM,1) IF(RS.GT.(4.+RNDM(1))) GOTO 42 DO 41 I=1,NT CALL LENGTX(I,ETB) IF(ETB.LT.P) GOTO 41 ETF=P PV(4,I)=SQRT(PV(5,I)**2+ETF**2) ETF=ETF/ETB PV(1,I)=PV(1,I)*ETF PV(2,I)=PV(2,I)*ETF PV(3,I)=PV(3,I)*ETF 41 CONTINUE 42 EKIN=PV(4,MXGKPV)-ABS(PV(5,MXGKPV)) EKIN1=PV(4,MXGKPV-1)-ABS(PV(5,MXGKPV-1)) EKIN2=0. CALL TDELAY(TOF1) CALL GRNDM(RNDM,1) RAN=RNDM(1) TOF=TOF-TOF1*LOG(RAN) DO 44 I=1,NT IF(PV(7,I).LT.0.) PV(5,I)=-PV(5,I) PV(7,I)=TOF PV(8,I)=ABS(IPA(I)) PV(9,I)=0. 44 PV(10,I)=0. CALL GHETUN(NT) DO 55 I=1,NT EKIN2=EKIN2+PV(4,I)-ABS(PV(5,I)) 55 CONTINUE EKIN2=(EKIN2-EKIN)/EKIN IF(NPRT(4)) $ WRITE(NEWBCD,2006) NT,EKIN,ENP(1),ENP(3),EKIN1,EKIN2 IF(EKIN2.GT.0.2) GOTO 60 C** INTCT=INTCT+1. CALL SETCUR(NT) NTK=NTK+1 IF(NT.EQ.1) GO TO 9999 DO 50 II=2,NT I=II-1 IF(NTOT.LT.NSIZE/12) GOTO 43 GO TO 9999 43 CALL SETTRK(I) 50 CONTINUE C 2002 FORMAT(' *HIGXPT* PRODUCTION OF FINAL STATE KINEMATIC AFTER ',I3, $ ' TRIALS. KINETIC ENERGIES ',2F6.2,' OUT OF ',2F6.2) 2000 FORMAT(' *HIGXPT* CMS PARAMETERS OF FINAL STATE PARTICLES,', $ ' ENERGIES IN INITIAL AND FINAL STATE ',2F6.2) 2001 FORMAT(' *HIGXPT* TRACK',2X,I3,2X,10F8.3,2X,I3,2X,F4.0) 2003 FORMAT(' *HIGXPT* TETA,EKIN0,EKIN1,EKIN ',4F10.4) 2006 FORMAT(' *HIGXPT* COMP.',1X,I5,1X,5F7.2) 3001 FORMAT(' *HIGXPT* NUCLEAR EXCITATION',I5, $ ' PARTICLES PRODUCED IN ADDITION TO ',I5,' NORMAL PARTICLES') 3002 FORMAT(' *HIGXPT* AVAILABLE ENERGIES ',2F10.4, $ ' FOR ',2I3,' PARTICLES IN BEAM/TARGET FRAGM. REGION', $ ' WITH IPA/SIDE ARRAY '/ $ 1H ,5X,10(I3,2X,F3.0,4X)) 3003 FORMAT(' *HIGXPT* ',I3,' BLACK TRACK PARTICLES PRODUCED', $ ' WITH TOTAL KINETIC ENERGY OF ',F8.3,' GEV') 3004 FORMAT(' *HIGXPT* ',I5,' HEAVY FRAGMENTS PRODUCED', $ ' WITH TOTAL ENERGY OF',F8.4,' GEV') C 9999 CONTINUE C RETURN END *CMZ : 3.14/16 13/03/89 14.48.40 BY NICK VAN EIJNDHOVEN (CERN) *-- AUTHOR : C--------------------------------------------------------------------- INTEGER FUNCTION NFAC(N) C C *** NVE 16-MAR-1988 CERN GENEVA *** C C ORIGIN : H.FESEFELDT (27-OCT-1983) C SAVE C NFAC=1. M=N IF(M.LE.1) RETURN IF(M.GT.10) M=10 DO 1 I=2,M 1 NFAC=NFAC*I RETURN END *CMZ : 3.14/16 13/03/89 14.48.40 BY NICK VAN EIJNDHOVEN (CERN) *-- AUTHOR : C--------------------------------------------------------------------- SUBROUTINE NORMAL(RAN) C C *** NVE 14-APR-1988 CERN GENEVA *** C C ORIGIN : H.FESEFELDT (27-OCT-1983) C DIMENSION RNDM(12) SAVE C RAN=-6. CALL GRNDM(RNDM,12) DO 1 I=1,12 RAN=RAN+RNDM(I) 1 CONTINUE RETURN END *CMZ : 3.16/00 05/11/93 20.30.06 BY FEDERICO CARMINATI *-- AUTHOR : C--------------------------------------------------------------------- SUBROUTINE NUCREC(NOPT,IREC) C C *** NUCLEAR REACTION KINEMATICS AT LOW ENERGIES *** C *** NVE 18-MAY-1988 CERN GENEVA *** C C CALLED BY : GHEISH, GNSLWD C ORIGIN : H.FESEFELDT (12-FEB-1987) C C NOPT=1 N M(A,Z) --> G (G) M(A+1,Z ) NEUTRON CAPTURE C NOPT=2 N M(A,Z) --> N (G) M(A ,Z ) INELASTIC NEUTRON SCATT. C NOPT=3 N M(A,Z) --> P (G) M(A ,Z-1) C NOPT=4 N M(A,Z) --> D (G) M(A-1,Z-1) C NOPT=5 N M(A,Z) --> T (G) M(A-2,Z-1) C NOPT=6 N M(A,Z) --> ALP. M(A-3,Z-2) C NOPT=7 N M(A,Z) --> N N M(A-1,Z ) C NOPT=8 N M(A,Z) --> N P M(A-1,Z-1) C NOPT=9 N M(A,Z) --> P P M(A-1,Z-2) C NOPT=11 P M(A,Z) --> G (G) M(A+1,Z+1) PROTON CAPTURE C NOPT=12 P M(A,Z) --> N (G) M(A ,Z ) INELASTIC PROTON SCATT. C NOPT=13 P M(A,Z) --> P (G) M(A ,Z+1) C NOPT=14 P M(A,Z) --> D (G) M(A-1,Z ) C NOPT=15 P M(A,Z) --> T (G) M(A-2,Z ) C NOPT=16 P M(A,Z) --> ALP. M(A-3,Z-1) C NOPT=17 P M(A,Z) --> N N M(A-1,Z+1) C NOPT=18 P M(A,Z) --> N P M(A-1,Z ) C NOPT=19 P M(A,Z) --> P P M(A-1,Z-1) C SIMILAR FOR D,T,ALPHA SCATTERING ON NUCLEI C C NOTE : DOUBLE PRECISION CALCULATIONS ARE VITAL FOR THESE LOW C ENERGY PROCESSES C THEREFORE THE VARS OF /GENIO/ ARE DECLARED DOUBLE PRECISION C ALSO A DOUBLE PRECISION VERSION OF THE PHASE SPACE PACKAGE C "PHPNUC" HAS BEEN INTRODUCED C *** HMF 29-AUG-1989 RWTH AACHEN *** C PARAMETER (MXGKGH=100) COMMON/CONSTS/ PI,TWPI,PIBTW,MP,MPI,MMU,MEL,MKCH,MK0,SMP,SMPI, $ SMU,CT,CTKCH,CTK0, $ ML0,MSP,MS0,MSM,MX0,MXM,CTL0,CTSP,CTSM,CTX0,CTXM, $ RMASS(35),RCHARG(35) C REAL MP,MPI,MMU,MEL,MKCH,MK0, * ML0,MSP,MS0,MSM,MX0,MXM C PARAMETER (MXGKCU=MXGKGH) COMMON/CURPAR/WEIGHT(10),DDELTN,IFILE,IRUN,NEVT,NEVENT,SHFLAG, * ITHST,ITTOT,ITLST,IFRND,TOFCUT,CMOM(5),CENG(5), * RS,S,ENP(10),NP,NM,NN,NR,NO,NZ,IPA(MXGKCU), * ATNO2,ZNO2 C COMMON/RESULT/XEND,YEND,ZEND,RCA,RCE,AMAS,NCH,TOF,PX,PY,PZ, * USERW,INTCT,P,EN,EK,AMASQ,DELTN,ITK,NTK,IPART,IND, * LCALO,ICEL,SINL,COSL,SINP,COSP, * XOLD,YOLD,ZOLD,POLD,PXOLD,PYOLD,PZOLD, * XSCAT,YSCAT,ZSCAT,PSCAT,PXSCAT,PYSCAT,PZSCAT REAL NCH,INTCT C COMMON/MAT / LMAT, * DEN(21),RADLTH(21),ATNO(21),ZNO(21),ABSL(21), * CDEN(21),MDEN(21),X0DEN(21),X1DEN(21),RION(21), * MATID(21),MATID1(21,24),PARMAT(21,10), * IFRAT,IFRAC(21),FRAC1(21,10),DEN1(21,10), * ATNO1(21,10),ZNO1(21,10) C PARAMETER (MXEVEN=12*MXGKGH) COMMON/EVENT / NSIZE,NCUR,NEXT,NTOT,EVE(MXEVEN) C COMMON/PRNTFL/INBCD,NEWBCD,INBIN,NEWBIN,NPEVT,NEVTP,LPRT,NPRT(10) LOGICAL LPRT,NPRT C COMMON/ERRCOM/ IER(100) C PARAMETER (MXGKPV=MXGKGH) COMMON /VECUTY/ PV(10,MXGKPV) C C COMMON/NUCIN /TECM,AMASS(18),NPG,KGENEV COMMON/NUCOUT/PCM(5,18),WGT DOUBLE PRECISION TECM,AMASS,PCM,WGT C C C DIMENSION QVAL(10),TCH(10) DIMENSION RNDM(2) SAVE C C** PROGRAM RETURNS WITH NOPT=0, IF INELASTIC SCATTERING ENERGETICALLY C** NOT POSSIBLE, OR IF WRONG PARTICLES ENTER THIS ROUTINE: ONLY FOR C** PROTONS,NEUTRONS, DEUTERIUM, TRITIUM AND ALPHAS. C** IF EK > 100 MEV, THIS ROUTINE IS CERTAINLY NOT ADEQUATE. C NOPT=0 IF (IREC .EQ. 0) GO TO 9999 C IF (NPRT(9) .AND. (EK .GT. 0.1)) PRINT 9000,EK,IPART 9000 FORMAT(' *NUCREC* ENERGY TOO HIGH EK = ',G12.5,' GEV ', $ ' KPART = ',I3) IF (EK .GT. 0.1) GO TO 9999 C C%%% IF(IPART.EQ.16) GOTO 2 C%%% IF(IPART.EQ.14) GOTO 3 C%%% IF(IPART.EQ.30) GOTO 4 C%%% IF(IPART.EQ.31) GOTO 5 C%%% IF(IPART.EQ.32) GOTO 6 C%%% GO TO 9999 C%%% 2 AMAS = ATOMAS(1.,0.) C%%% GOTO 8 C%%% 3 AMAS = ATOMAS(1.,1.) C%%% GOTO 8 C%%% 4 AMAS = ATOMAS(2.,1.) C%%% GOTO 8 C%%% 5 AMAS = ATOMAS(3.,1.) C%%% GOTO 8 C%%% 6 AMAS = ATOMAS(4.,2.) C IF (IPART .EQ. 16) GO TO 8 IF (IPART .EQ. 14) GO TO 8 IF (IPART .EQ. 30) GO TO 8 IF (IPART .EQ. 31) GO TO 8 IF( IPART .EQ. 32) GO TO 8 GO TO 9999 C** SET BEAM PARTICLE, TAKE EK AS FUNDAMENTAL QUANTITY C** DUE TO THE DIFFICULT KINEMATIC, ALL MASSES HAVE TO BE ASSIGNED C** THE BEST MEASURED VALUES. 8 CONTINUE * CALL VZERO(QVAL,10) * CALL VZERO(TCH ,10) CDH DO III = 1, 10 QVAL(III) = 0. ENDDO DO III = 1, 10 TCH(III) = 0. ENDDO C --- GET MASS WHICH MATCHES GEANT --- AMAS=RMASS(IPART) EN=EK+ABS(AMAS) P =SQRT(ABS(EN*EN-AMAS*AMAS)) PP=SQRT(PX*PX+PY*PY+PZ*PZ) IF (PP .GT. 1.0E-6) GO TO 8000 CALL GRNDM(RNDM,2) PHINVE=TWPI*RNDM(1) COST=-1.+2.*RNDM(2) IF (COST .LE. -1.) COST=-1. IF (COST .GE. 1.) COST= 1. RTHNVE=ACOS(COST) PX=SIN(RTHNVE)*COS(PHINVE) PY=SIN(RTHNVE)*SIN(PHINVE) PZ=COS(RTHNVE) PP=1. 8000 CONTINUE PX=PX/PP PY=PY/PP PZ=PZ/PP * CALL VZERO(PV,10*MXGKPV) CDH DO III = 1, MXGKPV DO IIII = 1, 10 PV(IIII,III) = 0. ENDDO ENDDO PV(1,1) =PX*P PV(2,1) =PY*P PV(3,1) =PZ*P PV(4,1) =EN PV(5,1) =AMAS PV(6,1) =NCH PV(7,1) =TOF PV(8,1) =IPART PV(9,1) =0. PV(10,1)=USERW PV(1,2) =0. PV(2,2) =0. PV(3,2) =0. PV(4,2) =0. PV(5,2) =ATOMAS(ATNO2,ZNO2) PV(6,2) =ZNO2 PV(7,2) =TOF PV(8,2) =0. PV(9,2) =0. PV(10,2)=0. C** CALCULATE Q-VALUE OF REACTIONS IF(IPART.EQ.16) GOTO 20 IF(IPART.EQ.14) GOTO 30 IF(IPART.EQ.30) GOTO 40 IF(IPART.EQ.31) GOTO 50 IF(IPART.EQ.32) GOTO 60 20 PV(5,11)=ATOMAS(ATNO2+1.,ZNO2 ) PV(6,11)=ZNO2 PV(5,21)=0. PV(6,21)=0. PV(8,21)=1. PV(5,31)=0. PV(6,31)=0. PV(8,31)=1. C PV(5,12)=PV(5,2) PV(6,12)=PV(6,2) PV(5,22)=RMASS(16) PV(6,22)=0. PV(8,22)=16. PV(5,32)=0. PV(6,32)=0. PV(8,32)=1. C PV(5,13)=ATOMAS(ATNO2 ,ZNO2-1.) PV(6,13)=ZNO2-1. PV(5,23)=RMASS(14) PV(6,23)=1. PV(8,23)=14. PV(5,33)=0. PV(6,33)=0. PV(8,33)=1. C PV(5,14)=ATOMAS(ATNO2-1.,ZNO2-1.) PV(6,14)=ZNO2-1. PV(5,24)=RMASS(30) PV(6,24)=1. PV(8,24)=30. PV(5,34)=0. PV(6,34)=0. PV(8,34)=1. C PV(5,15)=ATOMAS(ATNO2-2.,ZNO2-1.) PV(6,15)=ZNO2-1. PV(5,25)=RMASS(31) PV(6,25)=1. PV(8,25)=31. PV(5,35)=0. PV(6,35)=0. PV(8,35)=1. C PV(5,16)=ATOMAS(ATNO2-3.,ZNO2-2.) PV(6,16)=ZNO2-2. PV(5,26)=RMASS(32) PV(6,26)=2. PV(8,26)=32. PV(5,36)=0. PV(6,36)=0. PV(8,36)=1. C PV(5,17)=ATOMAS(ATNO2-1.,ZNO2 ) PV(6,17)=ZNO2 PV(5,27)=PV(5,22) PV(6,27)=0. PV(8,27)=16. PV(5,37)=PV(5,22) PV(6,37)=0. PV(8,37)=16. C PV(5,18)=PV(5,14) PV(6,18)=PV(6,14) PV(5,28)=PV(5,22) PV(6,28)=0. PV(8,28)=16. PV(5,38)=PV(5,23) PV(6,38)=1. PV(8,38)=14. C PV(5,19)=ATOMAS(ATNO2-1.,ZNO2-2.) PV(6,19)=ZNO2-2. PV(5,29)=PV(5,23) PV(6,29)=1. PV(8,29)=14. PV(5,39)=PV(5,23) PV(6,39)=1. PV(8,39)=14. C GOTO 70 30 PV(5,11)=ATOMAS(ATNO2+1.,ZNO2+1.) PV(6,11)=ZNO2+1. PV(5,21)=0. PV(6,21)=0. PV(8,21)=1. PV(5,31)=0. PV(6,31)=0. PV(8,31)=1. C PV(5,12)=ATOMAS(ATNO2 ,ZNO2+1.) PV(6,12)=ZNO2+1. PV(5,22)=RMASS(16) PV(6,22)=0. PV(8,22)=16. PV(5,32)=0. PV(6,32)=0. PV(8,32)=1. C PV(5,13)=PV(5,2) PV(6,13)=PV(6,2) PV(5,23)=RMASS(14) PV(6,23)=1. PV(8,23)=14. PV(5,33)=0. PV(6,33)=0. PV(8,33)=1. C PV(5,14)=ATOMAS(ATNO2-1.,ZNO2 ) PV(6,14)=ZNO2 PV(5,24)=RMASS(30) PV(6,24)=1. PV(8,24)=30. PV(5,34)=0. PV(6,34)=0. PV(8,34)=1. C PV(5,15)=ATOMAS(ATNO2-2.,ZNO2 ) PV(6,15)=ZNO2 PV(5,25)=RMASS(31) PV(6,25)=1. PV(8,25)=31. PV(5,35)=0. PV(6,35)=0. PV(8,35)=1. C PV(5,16)=ATOMAS(ATNO2-3.,ZNO2-1.) PV(6,16)=ZNO2-1. PV(5,26)=RMASS(32) PV(6,26)=2. PV(8,26)=32. PV(5,36)=0. PV(6,36)=0. PV(8,36)=1. C PV(5,17)=ATOMAS(ATNO2-1.,ZNO2+1.) PV(6,17)=ZNO2+1. PV(5,27)=PV(5,22) PV(6,27)=0. PV(8,27)=16. PV(5,37)=PV(5,22) PV(6,37)=0. PV(8,37)=16. C PV(5,18)=PV(5,14) PV(6,18)=PV(6,14) PV(5,28)=PV(5,22) PV(6,28)=0. PV(8,28)=16. PV(5,38)=PV(5,23) PV(6,38)=1. PV(8,38)=14. C PV(5,19)=ATOMAS(ATNO2-1.,ZNO2-1.) PV(6,19)=ZNO2-1. PV(5,29)=PV(5,23) PV(6,29)=1. PV(8,29)=14. PV(5,39)=PV(5,23) PV(6,39)=1. PV(8,39)=14. C NOPT=10 GOTO 70 40 PV(5,11)=ATOMAS(ATNO2+2.,ZNO2+1.) PV(6,11)=ZNO2+1. PV(5,21)=0. PV(6,21)=0. PV(8,21)=1. PV(5,31)=0. PV(6,31)=0. PV(8,31)=1. C PV(5,12)=ATOMAS(ATNO2+1.,ZNO2+1.) PV(6,12)=ZNO2+1. PV(5,22)=RMASS(16) PV(6,22)=0. PV(8,22)=16. PV(5,32)=0. PV(6,32)=0. PV(8,32)=1. C PV(5,13)=ATOMAS(ATNO2+1.,ZNO2 ) PV(6,13)=ZNO2 PV(5,23)=RMASS(14) PV(6,23)=1. PV(8,23)=14. PV(5,33)=0. PV(6,33)=0. PV(8,33)=1. C PV(5,14)=PV(5,2) PV(6,14)=PV(6,2) PV(5,24)=RMASS(30) PV(6,24)=1. PV(8,24)=30. PV(5,34)=0. PV(6,34)=0. PV(8,34)=1. C PV(5,15)=ATOMAS(ATNO2-1.,ZNO2 ) PV(6,15)=ZNO2 PV(5,25)=RMASS(31) PV(6,25)=1. PV(8,25)=31. PV(5,35)=0. PV(6,35)=0. PV(8,35)=1. C PV(5,16)=ATOMAS(ATNO2-2.,ZNO2-1.) PV(6,16)=ZNO2-1. PV(5,26)=RMASS(32) PV(6,26)=2. PV(8,26)=32. PV(5,36)=0. PV(6,36)=0. PV(8,36)=1. C PV(5,17)=ATOMAS(ATNO2 ,ZNO2+1.) PV(6,17)=ZNO2+1. PV(5,27)=PV(5,22) PV(6,27)=0. PV(8,27)=16. PV(5,37)=PV(5,22) PV(6,37)=0. PV(8,37)=16. C PV(5,18)=PV(5,14) PV(6,18)=PV(6,14) PV(5,28)=PV(5,22) PV(6,28)=0. PV(8,28)=16. PV(5,38)=PV(5,23) PV(6,38)=1. PV(8,38)=14. C PV(5,19)=ATOMAS(ATNO2 ,ZNO2-1.) PV(6,19)=ZNO2-1. PV(5,29)=PV(5,23) PV(6,29)=1. PV(8,29)=14. PV(5,39)=PV(5,23) PV(6,39)=1. PV(8,39)=14. C NOPT=20 GOTO 70 50 PV(5,11)=ATOMAS(ATNO2+3.,ZNO2+1.) PV(6,11)=ZNO2+1. PV(5,21)=0. PV(6,21)=0. PV(8,21)=1. PV(5,31)=0. PV(6,31)=0. PV(8,31)=1. C PV(5,12)=ATOMAS(ATNO2+2.,ZNO2+1.) PV(6,12)=ZNO2+1. PV(5,22)=RMASS(16) PV(6,22)=0. PV(8,22)=16. PV(5,32)=0. PV(6,32)=0. PV(8,32)=1. C PV(5,13)=ATOMAS(ATNO2+2.,ZNO2 ) PV(6,13)=ZNO2 PV(5,23)=RMASS(14) PV(6,23)=1. PV(8,23)=14. PV(5,33)=0. PV(6,33)=0. PV(8,33)=1. C PV(5,14)=ATOMAS(ATNO2+1.,ZNO2 ) PV(6,14)=ZNO2 PV(5,24)=RMASS(30) PV(6,24)=1. PV(8,24)=30. PV(5,34)=0. PV(6,34)=0. PV(8,34)=1. C PV(5,15)=PV(5,2) PV(6,15)=PV(6,2) PV(5,25)=RMASS(31) PV(6,25)=1. PV(8,25)=31. PV(5,35)=0. PV(6,35)=0. PV(8,35)=1. C PV(5,16)=ATOMAS(ATNO2-1.,ZNO2-1.) PV(6,16)=ZNO2-1. PV(5,26)=RMASS(32) PV(6,26)=2. PV(8,26)=32. PV(5,36)=0. PV(6,36)=0. PV(8,36)=1. C PV(5,17)=ATOMAS(ATNO2+1.,ZNO2+1.) PV(6,17)=ZNO2+1. PV(5,27)=PV(5,22) PV(6,27)=0. PV(8,27)=16. PV(5,37)=PV(5,22) PV(6,37)=0. PV(8,37)=16. C PV(5,18)=PV(5,14) PV(6,18)=PV(6,14) PV(5,28)=PV(5,22) PV(6,28)=0. PV(8,28)=16. PV(5,38)=PV(5,23) PV(6,38)=1. PV(8,38)=14. C PV(5,19)=ATOMAS(ATNO2+1.,ZNO2-1.) PV(6,19)=ZNO2-1. PV(5,29)=PV(5,23) PV(6,29)=1. PV(8,29)=14. PV(5,39)=PV(5,23) PV(6,39)=1. PV(8,39)=14. C NOPT=30 GOTO 70 60 PV(5,11)=ATOMAS(ATNO2+4.,ZNO2+2.) PV(6,11)=ZNO2+2. PV(5,21)=0. PV(6,21)=0. PV(8,21)=1. PV(5,31)=0. PV(6,31)=0. PV(8,31)=1. C PV(5,12)=ATOMAS(ATNO2+3.,ZNO2+2.) PV(6,12)=ZNO2+2. PV(5,22)=RMASS(16) PV(6,22)=0. PV(8,22)=16. PV(5,32)=0. PV(6,32)=0. PV(8,32)=1. C PV(5,13)=ATOMAS(ATNO2+3.,ZNO2+1.) PV(6,13)=ZNO2+1. PV(5,23)=RMASS(14) PV(6,23)=1. PV(8,23)=14. PV(5,33)=0. PV(6,33)=0. PV(8,33)=1. C PV(5,14)=ATOMAS(ATNO2+2.,ZNO2+1.) PV(6,14)=ZNO2+1. PV(5,24)=RMASS(30) PV(6,24)=1. PV(8,24)=30. PV(5,34)=0. PV(6,34)=0. PV(8,34)=1. C PV(5,15)=ATOMAS(ATNO2+1.,ZNO2+1.) PV(6,15)=ZNO2+1. PV(5,25)=RMASS(31) PV(6,25)=1. PV(8,25)=31. PV(5,35)=0. PV(6,35)=0. PV(8,35)=1. C PV(5,16)=PV(5,2) PV(6,16)=PV(6,2) PV(5,26)=RMASS(32) PV(6,26)=2. PV(8,26)=32. PV(5,36)=0. PV(6,36)=0. PV(8,36)=1. C PV(5,17)=ATOMAS(ATNO2+2.,ZNO2+2.) PV(6,17)=ZNO2+2. PV(5,27)=PV(5,22) PV(6,27)=0. PV(8,27)=16. PV(5,37)=PV(5,22) PV(6,37)=0. PV(8,37)=16. C PV(5,18)=PV(5,14) PV(6,18)=PV(6,14) PV(5,28)=PV(5,22) PV(6,28)=0. PV(8,28)=16. PV(5,38)=PV(5,23) PV(6,38)=1. PV(8,38)=14. C PV(5,19)=ATOMAS(ATNO2+2.,ZNO2 ) PV(6,19)=ZNO2 PV(5,29)=PV(5,23) PV(6,29)=1. PV(8,29)=14. PV(5,39)=PV(5,23) PV(6,39)=1. PV(8,39)=14. C NOPT=40 70 QV =EK+PV(5,2)+PV(5,1) TC = PV(6,2)+PV(6,1) QVAL(1)=QV - PV(5,11) TCH (1)=TC - PV(6,11) QVAL(2)=QV - PV(5,12) - PV(5,22) TCH (2)=TC - PV(6,12) - PV(6,22) QVAL(3)=QV - PV(5,13) - PV(5,23) TCH (3)=TC - PV(6,13) - PV(6,23) QVAL(4)=QV - PV(5,14) - PV(5,24) TCH (4)=TC - PV(6,14) - PV(6,24) QVAL(5)=QV - PV(5,15) - PV(5,25) TCH (5)=TC - PV(6,15) - PV(6,25) QVAL(6)=QV - PV(5,16) - PV(5,26) TCH (6)=TC - PV(6,16) - PV(6,26) QVAL(7)=QV - PV(5,17) - PV(5,27) - PV(5,37) TCH (7)=TC - PV(6,17) - PV(6,27) - PV(6,37) QVAL(8)=QV - PV(5,18) - PV(5,28) - PV(5,38) TCH (8)=TC - PV(6,18) - PV(6,28) - PV(6,38) QVAL(9)=QV - PV(5,19) - PV(5,29) - PV(5,39) TCH (9)=TC - PV(6,19) - PV(6,29) - PV(6,39) 74 QV = 0 IF(IREC.EQ.2) QVAL(1)=0. IF(IPART.NE.16) GOTO 75 CALL GRNDM(RNDM,2) IF(RNDM(1).GT.((ATNO2-1.)/230.)**2) QVAL(1)=0. EKA=7.9254/ATNO2 IF(RNDM(2).LT.EK/EKA) GOTO 75 QVAL(3)=0. QVAL(4)=0. QVAL(5)=0. QVAL(6)=0. QVAL(9)=0. 75 DO 71 I=1,9 IF(PV(5,10+I).LT.0.5) QVAL(I)=0. IF(QVAL(I).LT.0. ) QVAL(I)=0. IF(ABS(TCH(I)-0.1).GT.0.5 ) QVAL(I)=0. QV=QV+QVAL(I) 71 CONTINUE CALL GRNDM(RNDM,1) RAN=RNDM(1) QV1=0. DO 72 I=1,9 IF(QVAL(I).EQ.0.) GOTO 72 QV1=QV1+QVAL(I)/QV IF(RAN.LE.QV1) GOTO 73 72 CONTINUE C** REACTION KINEMATICALLY NOT POSSIBLE NOPT=0 GO TO 9999 73 NOPT=NOPT+I PV(5,3)=PV(5,10+I) PV(6,3)=PV(6,10+I) PV(8,3)=0. PV(5,4)=PV(5,20+I) PV(6,4)=PV(6,20+I) PV(8,4)=PV(8,20+I) PV(5,5)=PV(5,30+I) PV(6,5)=PV(6,30+I) PV(8,5)=PV(8,30+I) NT=2 RAN=EK*10. IF(RAN.GT.0.5) RAN=0.5 CALL GRNDM(RNDM,1) IF(RNDM(1).LT.RAN) NT=3 IF(MOD(NOPT,10).GE.7) NT=3 C** CALCULATE CMS ENERGY 80 PV(4,2)=PV(5,2) CALL ADD(1,2,MXGKPV) PV(1,MXGKPV)=-PV(1,MXGKPV) PV(2,MXGKPV)=-PV(2,MXGKPV) PV(3,MXGKPV)=-PV(3,MXGKPV) C** SET QUANTITIES FOR PHASE SPACE ROUTINE IN CMS TECM=PV(5,MXGKPV) NPG=NT KGENEV=1 DO 81 I=1,NPG 81 AMASS(I)=PV(5,2+I) C --- INVOKE DOUBLE PRECISION VERSION OF THE PHASE SPACE PACKAGE --- CALL PHPNUC DO 83 I=1,NPG DO 82 J=1,4 82 PV(J,2+I)=PCM(J,I) C** TRANSFORM INTO LAB.SYSTEM CALL LOR(2+I,MXGKPV,2+I) PV(7,2+I)=TOF 83 CONTINUE C** SET CHARGES AND PARTICLE INDEX FOR LOW MASS FRAGMENTS IF (ABS(PV(5,3)-RMASS(14)) .LT. 0.0001) GO TO 84 IF (ABS(PV(5,3)-RMASS(16)) .LT. 0.0001) GO TO 85 IF (ABS(PV(5,3)-RMASS(30)) .LT. 0.0001) GO TO 86 IF (ABS(PV(5,3)-RMASS(31)) .LT. 0.0001) GO TO 87 IF (ABS(PV(5,3)-RMASS(32)) .LT. 0.0001) GO TO 88 GOTO 89 84 PV(6,3)=1. PV(8,3)=14. GOTO 89 85 PV(6,3)=0. PV(8,3)=16. GOTO 89 86 PV(6,3)=1. PV(8,3)=30. GOTO 89 87 PV(6,3)=1. PV(8,3)=31. GOTO 89 88 PV(6,3)=2. PV(8,3)=32. 89 NTT=2+NT DO 90 I=1,NTT IPP=IFIX(PV(8,I)+0.01) IF(IPP.EQ.0) GOTO 90 EK=PV(4,I)-PV(5,I) IF(I.LT.3) GOTO 92 IF(IPP.LT.30) GOTO 92 CALL GRNDM(RNDM,1) EK=EK*0.5*RNDM(1) 92 IF(EK.LT.1.E-6) EK=1.E-6 PV(5,I)=RMASS(IPP) PV(4,I)=EK+PV(5,I) P=SQRT(ABS(PV(4,I)**2-PV(5,I)**2)) PP=SQRT(PV(1,I)**2+PV(2,I)**2+PV(3,I)**2) IF(PP.GT.1.E-6) GOTO 91 CALL GRNDM(RNDM,2) PHINVE=TWPI*RNDM(1) COST=-1.+2.*RNDM(2) IF (COST .LE. -1.) COST=-1. IF (COST .GE. 1.) COST= 1. RTHNVE=ACOS(COST) PV(1,I)=SIN(RTHNVE)*COS(PHINVE) PV(2,I)=SIN(RTHNVE)*SIN(PHINVE) PV(3,I)=COS(RTHNVE) PP=1. 91 PV(1,I)=PV(1,I)*P/PP PV(2,I)=PV(2,I)*P/PP PV(3,I)=PV(3,I)*P/PP 90 CONTINUE IF(.NOT.NPRT(4)) GOTO 100 WRITE(NEWBCD,1000) XEND,YEND,ZEND,IND,NOPT 1000 FORMAT(' *NUCREC* NUCLEAR REACTION AT (X,Y,Z) ',3(G12.5,1X) $,/,' MATERIAL ',I5,' NOPT ',I5) DO 95 I=1,NTT WRITE(NEWBCD,1001) I,(PV(J,I),J=1,10) 95 CONTINUE 1001 FORMAT(1H ,I3,1X,10(G10.3,1X)) 100 INTCT=INTCT+1. C** SET INTERACTION MODE ACCORDING TO GHEISHA-CONVENTION C** N-CAPTURE IF(PV(8,3).GT.0.) GOTO 110 CALL SETCUR(4) NTK=NTK+1 IF(NT.EQ.3) CALL SETTRK(5) GO TO 9999 110 CONTINUE CALL SETCUR(4) NTK=NTK+1 CALL SETTRK(3) IF(NT.EQ.3) CALL SETTRK(5) CALL SETTRK(3) C 9999 CONTINUE RETURN END *CMZ : 3.16/00 05/11/93 19.18.25 BY FEDERICO CARMINATI *-- AUTHOR : C--------------------------------------------------------------------- SUBROUTINE PHASP C C *** NVE 29-MAR-1988 CERN GENEVA *** C C CALLED BY : NUCREC TWOCLU GENXPT C ORIGIN : H.FESEFELDT (02-DEC-1986) C COMMON/PRNTFL/INBCD,NEWBCD,INBIN,NEWBIN,NPEVT,NEVTP,LPRT,NPRT(10) LOGICAL LPRT,NPRT C COMMON/GENIN /TECM,AMASS(18),NPG,KGENEV COMMON/GENOUT/PCM(5,18),WGT C C --- BOUNDARY LIMITS FOR ARGUMENTS OF INTRINSIC FUNCTIONS --- C --- XL DENOTES LOWER BOUND WHEREAS XU DENOTES UPPER BOUND --- COMMON /LIMITS/ EXPXL,EXPXU C C DOUBLE PRECISION WTMAX,WTMAXQ,WTFC,TWGT,ONE,TEXPXL,TEXPXU PARAMETER (ONE=1.D0) LOGICAL LZERO DIMENSION EMM(18) DIMENSION RNO(50) DIMENSION EM(18),PD(18),EMS(18),SM(18),FFQ(18),PCM1(90) EQUIVALENCE (NT,NPG),(AMASS(1),EM(1)),(PCM1(1),PCM(1,1)) SAVE KNT SAVE C DATA FFQ/0.,3.141592, 19.73921, 62.01255, 129.8788, 204.0131, $ 256.3704, 268.4705, 240.9780, 189.2637, $ 132.1308, 83.0202, 47.4210, 24.8295, $ 12.0006, 5.3858, 2.2560, 0.8859/ DATA KNT , TWOPI / 1 , 6.2831853073 / C C --- INITIALISE LOCAL ARRAYS AND THE RESULT ARRAY PCM --- DO 10 JZERO=1,18 PCM(1,JZERO)=0. PCM(2,JZERO)=0. PCM(3,JZERO)=0. PCM(4,JZERO)=0. PCM(5,JZERO)=0. EMM(JZERO) =0. PD(JZERO) =0. EMS(JZERO) =0. SM(JZERO) =0. 10 CONTINUE C KNT = KNT + 1 IF (.NOT.NPRT(3).AND..NOT.NPRT(4)) GOTO 100 WRITE(NEWBCD,1200) NPG,TECM,(AMASS(JK),JK=1,NPG) 100 CONTINUE 150 IF (NT .LT. 2) GO TO 1001 IF (NT .GT. 18) GO TO 1002 NTM1=NT-1 NTM2=NT-2 NTNM4 = 3*NT - 4 EMM(1)=EM(1) TM=0.0 DO 200 I=1,NT EMS(I)=EM(I)**2 TM=TM+EM(I) 200 SM(I)=TM WGT=1. 210 TECMTM=TECM-TM IF (TECMTM .LE. 0.0) GO TO 1000 EMM(NT)=TECM IF (KGENEV.GT.1) GO TO 400 EMMAX=TECMTM+EM(1) EMMIN=0.0 C C FOR WEIGHT CALCULATION, FORM SUM OF LOG'S OF TERMS C INSTEAD OF PRODUCT OF TERMS. NOTE THAT THEREBY WTMAX C AND WTMAXQ ARE CHANGED IN THEIR CONTENTS; THEY ARE C CURRENTLY NOT USED OUTSIDE THE RANGE FROM HERE TO C LABEL 531. WE ALSO NEED TO CHECK FOR ZERO FACTORS NOW. C NEGATIVE VALUES CANNOT APPEAR AS GPDK ALWAYS RETURNS A C NONNEGATIVE NUMBER. AS CODED, EVEN THE EXOTIC CASES C NT<2 (FIRST LOOP NOT EXECUTED) AND NTM1<1 (SECOND LOOP C NOT EXECUTED) SHOULD BE SAFE AND GIVE THE SAME RESULT C FOR WTG IN THE END AS THE OLD CODE. C WTMAX=0.0 LZERO=.TRUE. DO 350 I=2,NT EMMIN=EMMIN+EM(I-1) EMMAX=EMMAX+EM(I) WTFC=GPDK(EMMAX,EMMIN,EM(I)) IF(WTFC.LE.0.) THEN LZERO=.FALSE. GOTO 351 ENDIF WTMAX=WTMAX+LOG(WTFC) 350 CONTINUE 351 WTMAXQ= EXPXU IF(LZERO) WTMAXQ= -WTMAX GO TO 455 400 WTMAXQ=LOG(ONE*TECMTM**NTM2*FFQ(NT) / TECM) 455 CONTINUE CALL GRNDM(RNO,NTNM4) IF(NTM2) 900,509,460 460 CONTINUE CALL FLPSOR(RNO,NTM2) DO 508 J=2,NTM1 508 EMM(J)=RNO(J-1)*TECMTM+SM(J) 509 TWGT=WTMAXQ IR=NTM2 LZERO=.TRUE. DO 530 I=1,NTM1 PD(I)=GPDK(EMM(I+1),EMM(I),EM(I+1)) IF(PD(I).LE.0.0) THEN LZERO=.FALSE. ELSE TWGT=TWGT+LOG(ONE*PD(I)) ENDIF 530 CONTINUE 531 WGT=0.0 IF(LZERO) THEN TEXPXU=EXPXU TEXPXL=EXPXL WGT=EXP(MAX(MIN(TWGT,TEXPXU),TEXPXL)) ENDIF PCM(1,1)=0.0 PCM(2,1)=PD(1) PCM(3,1)=0.0 DO 570 I=2,NT PCM(1,I)=0.0 PCM(2,I) = -PD(I-1) PCM(3,I)=0.0 IR=IR+1 BANG=TWOPI*RNO(IR) CB=COS(BANG) SB=SIN(BANG) IR=IR+1 C=2.0*RNO(IR)-1.0 S=SQRT(ABS(1.0-C*C)) IF(I.EQ.NT) GO TO 1567 ESYS=SQRT(PD(I)**2+EMM(I)**2) BETA=PD(I)/ESYS GAMA=ESYS/EMM(I) DO 568 J=1,I NDX = 5*J - 5 AA= PCM1(NDX+1)**2 + PCM1(NDX+2)**2 + PCM1(NDX+3)**2 PCM1(NDX+5) = SQRT(AA) PCM1(NDX+4) = SQRT(AA+EMS(J)) CALL ROTES2(C,S,CB,SB,PCM,J) PSAVE = GAMA*(PCM(2,J)+BETA*PCM(4,J)) 568 PCM(2,J)=PSAVE GO TO 570 1567 DO 1568 J=1,I AA=PCM(1,J)**2 + PCM(2,J)**2 + PCM(3,J)**2 PCM(5,J)=SQRT(AA) PCM(4,J)=SQRT(AA+EMS(J)) CALL ROTES2(C,S,CB,SB,PCM,J) 1568 CONTINUE 570 CONTINUE 900 CONTINUE RETURN 1000 DO 212 I=1,NPG PCM(1,I)=0. PCM(2,I)=0. PCM(3,I)=0. PCM(4,I)=AMASS(I) 212 PCM(5,I)=AMASS(I) WGT=0. RETURN 1001 IF(NPRT(3).OR.NPRT(4)) WRITE(NEWBCD,1101) GO TO 1050 1002 WRITE(NEWBCD,1102) 1050 WRITE(NEWBCD,1150) KNT WRITE(NEWBCD,1200) NPG,TECM,(AMASS(JK),JK=1,NPG) RETURN 1100 FORMAT(1H ,'*PHASP* AVAILABLE ENERGY NEGATIVE') 1101 FORMAT(1H ,'*PHASP* LESS THAN 2 OUTGOING PARTICLES') 1102 FORMAT(1H ,'*PHASP* MORE THAN 18 OUTGOING PARTICLES') 1150 FORMAT(1H ,'*PHASP* ABOVE ERROR DETECTED IN PHASP AT CALL NUMBER' $ ,I7) 1200 FORMAT(1H ,'*PHASP* INPUT DATA TO PHASP. NPG= ' ,I6/ $ 2X,9H TECM= ,D15.7,18H PARTICLE MASSES=,5D15.7/(42X,5D15.7) $ ) END *CMZ : 3.15/04 30/03/92 16.43.48 BY FEDERICO CARMINATI *-- AUTHOR : C--------------------------------------------------------------------- SUBROUTINE PHPNUC C C *** DOUBLE PRECISION VERSION OF THE PHASE SPACE ROUTINE "PHASP" C *** THIS ROUTINE MUST BE CALLED BY THE NUCLEAR INTERACTION ROUTINE C *** "NUCREC" (SEE ALSO COMMENTS THEREIN). THE REASON IS SIMPLY THAT C *** ENERGY-MOMENTUM CALCULATIONS ARE NOT POSSIBLE WITHIN ONLY C *** 6 DIGITS OF ACCURACY FOR TOTAL ENERGIES C *** IN THE ORDER OF HUNDREDS OF GEV (URANIUM NUCLEUS), COMPARED WITH C *** KINETIC ENERGIES IN THE ORDER OF MEV (NEUTRONS, PROTONS AND C *** PHOTONS IN THE REACTIONS A(X,Y(GAMMA,GAMMA))A'). IN THE ORIGINAL C *** GHEISHA8 CODE ALL THESE CALCULATIONS ARE DONE IN DOUBLE PRECISION C *** HMF 29-AUG-1989 RWTH AACHEN C C CALLED BY : NUCREC C ORIGIN : H.FESEFELDT C IMPLICIT DOUBLE PRECISION (A-H,O-Z) REAL RNDM(1) C COMMON/PRNTFL/INBCD,NEWBCD,INBIN,NEWBIN,NPEVT,NEVTP,LPRT,NPRT(10) LOGICAL LPRT,NPRT C COMMON/NUCIN /TECM,AMASS(18),NPG,KGENEV COMMON/NUCOUT/PCM(5,18),WGT DOUBLE PRECISION TECM,AMASS,PCM,WGT C C SAVE KNT, TWOPI, FFQ DIMENSION EMM(18) DIMENSION RNO(50) DIMENSION EM(18),PD(18),EMS(18),SM(18),FFQ(18),PCM1(90) EQUIVALENCE (NT,NPG),(AMASS(1),EM(1)),(PCM1(1),PCM(1,1)) SAVE DATA FFQ/0.,3.141592, 19.73921, 62.01255, 129.8788, 204.0131, 2 256.3704, 268.4705, 240.9780, 189.2637, 3 132.1308, 83.0202, 47.4210, 24.8295, 4 12.0006, 5.3858, 2.2560, 0.8859/ DATA KNT , TWOPI / 1 , 6.2831853073 / C C --- INITIALISE LOCAL ARRAYS AND THE RESULT ARRAY PCM --- CJOK CALL VZERO(PCM,90) DO 80 JZERO=1,18 DO 8080 IJK=1,5 PCM(IJK,JZERO) = 0.D0 8080 CONTINUE EMM(JZERO)=0. PD(JZERO) =0. EMS(JZERO)=0. SM(JZERO) =0. 80 CONTINUE C KNT = KNT + 1 IF (.NOT.NPRT(3).AND..NOT.NPRT(4)) GOTO 100 WRITE(NEWBCD,1200) NPG,TECM,(AMASS(JK),JK=1,NPG) 100 CONTINUE 150 IF (NT .LT. 2) GO TO 1001 IF (NT .GT. 18) GO TO 1002 NTM1=NT-1 NTM2=NT-2 NTP1=NT+1 NTNM4 = 3*NT - 4 EMM(1)=EM(1) TM=0.0 DO 200 I=1,NT EMS(I)=EM(I)**2 TM=TM+EM(I) 200 SM(I)=TM WGT=1. 210 TECMTM=TECM-TM IF (TECMTM .LE. 0.0) GO TO 1000 EMM(NT)=TECM IF (KGENEV.GT.1) GO TO 400 EMMAX=TECMTM+EM(1) EMMIN=0.0 WTMAX=1.0 DO 350 I=2,NT EMMIN=EMMIN+EM(I-1) EMMAX=EMMAX+EM(I) 350 WTMAX=WTMAX*DPDNUC(EMMAX,EMMIN,EM(I)) WTMAXQ=1.0/WTMAX GO TO 455 400 WTMAXQ=TECMTM**NTM2*FFQ(NT) / TECM 455 CONTINUE DO 457 I= 1, NTNM4 CALL GRNDM(RNDM,1) 457 RNO(I) = DBLE(RNDM(1)) IF(NTM2) 900,509,460 460 CONTINUE CALL DLPNUC(RNO,NTM2) DO 508 J=2,NTM1 508 EMM(J)=RNO(J-1)*(TECMTM)+SM(J) 509 WGT=WTMAXQ IR=NTM2 DO 530 I=1,NTM1 PD(I)=DPDNUC(EMM(I+1),EMM(I),EM(I+1)) 530 WGT=WGT*PD(I) PCM(1,1)=0.0 PCM(2,1)=PD(1) PCM(3,1)=0.0 DO 570 I=2,NT PCM(1,I)=0.0 PCM(2,I) = -PD(I-1) PCM(3,I)=0.0 IR=IR+1 BANG=TWOPI*RNO(IR) CB=COS(BANG) SB=SIN(BANG) IR=IR+1 C=2.0*RNO(IR)-1.0 S=SQRT(1.0-C*C) IF(I.EQ.NT) GO TO 1567 ESYS=SQRT(PD(I)**2+EMM(I)**2) BETA=PD(I)/ESYS GAMA=ESYS/EMM(I) DO 568 J=1,I NDX = 5*J - 5 AA= PCM1(NDX+1)**2 + PCM1(NDX+2)**2 + PCM1(NDX+3)**2 PCM1(NDX+5) = SQRT(AA) PCM1(NDX+4) = SQRT(AA+EMS(J)) CALL DOTNUC(C,S,CB,SB,PCM,J) PSAVE = GAMA*(PCM(2,J)+BETA*PCM(4,J)) 568 PCM(2,J)=PSAVE GO TO 570 1567 DO 1568 J=1,I AA=PCM(1,J)**2 + PCM(2,J)**2 + PCM(3,J)**2 PCM(5,J)=SQRT(AA) PCM(4,J)=SQRT(AA+EMS(J)) CALL DOTNUC(C,S,CB,SB,PCM,J) 1568 CONTINUE 570 CONTINUE 900 CONTINUE RETURN 1000 DO 212 I=1,NPG PCM(1,I)=0. PCM(2,I)=0. PCM(3,I)=0. PCM(4,I)=AMASS(I) 212 PCM(5,I)=AMASS(I) WGT=0. RETURN 1001 IF(NPRT(3).OR.NPRT(4)) WRITE(NEWBCD,1101) GO TO 1050 1002 WRITE(NEWBCD,1102) 1050 WRITE(NEWBCD,1150) KNT WRITE(NEWBCD,1200) NPG,TECM,(AMASS(JK),JK=1,NPG) STOP 1100 FORMAT(' *PHPNUC* AVAILABLE ENERGY NEGATIVE') 1101 FORMAT(' *PHPNUC* LESS THAN 2 OUTGOING PARTICLES') 1102 FORMAT(' *PHPNUC* MORE THAN 18 OUTGOING PARTICLES') 1150 FORMAT(' *PHPNUC* ABOVE ERROR DETECTED IN PHASP', $ ' AT CALL NUMBER ',I7) 1200 FORMAT(' *PHPNUC* INPUT DATA TO PHPNUC. NPG = ',I6/ $ ' TECM = ',E15.7,' PARTICLE MASSES = ',5E15.7/(42X,5E15.7)) END *CMZU: 3.16/00 05/11/93 17.20.00 BY FEDERICO CARMINATI *-- AUTHOR : C--------------------------------------------------------------------- FUNCTION PMLTPC(NP,NM,NZ,N,B,C) C C *** NVE 03-MAR-1988 CERN GENEVA *** C C ORIGIN : H.FESEFELDT (14-SEP-1987) C C --- BOUNDARY LIMITS FOR ARGUMENTS OF INTRINSIC FUNCTIONS --- C --- XL DENOTES LOWER BOUND WHEREAS XU DENOTES UPPER BOUND --- COMMON /LIMITS/ EXPXL,EXPXU SAVE C RLNNPF=0. IF(NP.LE.1) GOTO 2 DO 1 I=2,NP 1 RLNNPF=RLNNPF+LOG(I*1.) 2 RLNNMF=0. IF(NM.LE.1) GOTO 4 DO 3 I=2,NM 3 RLNNMF=RLNNMF+LOG(I*1.) 4 RLNNZF=0. IF(NZ.LE.1) GOTO 6 DO 5 I=2,NZ 5 RLNNZF=RLNNZF+LOG(I*1.) 6 PMLTPC=-(NP-NM+NZ+B)**2/(2*(C*N)**2)-RLNNPF-RLNNMF-RLNNZF IF(PMLTPC.LT.EXPXL) PMLTPC=EXPXL PMLTPC=EXP(PMLTPC) RETURN END *CMZ : 3.14/16 13/03/89 14.48.41 BY NICK VAN EIJNDHOVEN (CERN) *-- AUTHOR : C--------------------------------------------------------------------- SUBROUTINE POISSO(XAV,IRAN) C C *** GENERATION OF POISSON DISTRIBUTION *** C *** NVE 16-MAR-1988 CERN GENEVA *** C DIMENSION RNDM(1) C ORIGIN : H.FESEFELDT (27-OCT-1983) C SAVE C C --- USE NORMAL DISTRIBUTION FOR > 9.9 --- IF(XAV.GT.9.9) GOTO 2 C MM=IFIX(5.*XAV) IRAN=0 IF(MM.LE.0) GOTO 3 R=EXP(-XAV) CALL GRNDM(RNDM,1) RAN1=RNDM(1) IF(RAN1.LE.R) RETURN RR=R DO 1 I=1,MM IRAN=IRAN+1 IF(I.LE.5) RRR=XAV**I/NFAC(I) C** STIRLING' S FORMULA FOR LARGE NUMBERS IF(I.GT.5) RRR=EXP(I*LOG(XAV)-(I+0.5)*LOG(I*1.)+I-0.9189385) RR=RR+R*RRR IF(RAN1.LE.RR) RETURN 1 CONTINUE RETURN C** NORMAL DISTRIBUTION WITH SIGMA**2 = 2 CALL NORMAL(RAN1) RAN1=XAV+RAN1*SQRT(XAV) IRAN=IFIX(RAN1) IF(IRAN.LT.0) IRAN=0 RETURN C** FOR VERY SMALL XAV TRY IRAN=1,2,3 3 P1=XAV*EXP(-XAV) P2=XAV*P1/2. P3=XAV*P2/3. CALL GRNDM(RNDM,1) RAN=RNDM(1) IRAN=3 IF(RAN.LT.P3) RETURN IRAN=2 IF(RAN.LT.P2) RETURN IRAN=1 IF(RAN.LT.P1) RETURN IRAN=0 RETURN END *CMZ : 3.14/16 13/03/89 14.48.39 BY NICK VAN EIJNDHOVEN (CERN) *-- AUTHOR : C--------------------------------------------------------------------- FUNCTION RANRES(X) C C *** RESTRICTED RANDOM NUMBERS TO BE USED AS ARGUMENT IN LOG ETC... *** C *** NVE 13-JUL-1988 CERN GENEVA *** C C NOTE : 0 < RANRES < 1 DIMENSION RNDM(1) SAVE C 1 CONTINUE CALL GRNDM(RNDM,1) RANRES=RNDM(1) IF ((RANRES .LE. 0.) .OR. (RANRES .GE. 1.)) GO TO 1 RETURN END *CMZ : 3.14/16 23/05/89 10.04.05 BY NICK VAN EIJNDHOVEN (CERN) *-- AUTHOR : C--------------------------------------------------------------------- SUBROUTINE ROTES2(C,S,C2,S2,PR,I) C C *** NVE 16-MAR-1988 CERN GENEVA *** C C ORIGIN : H.FESEFELDT (27-OCT-1983) C DIMENSION PR(*) SAVE C K1 = 5*I - 4 K2 = K1 + 1 SA = PR(K1) SB = PR(K2) A = SA*C - SB*S PR(K2) = SA*S + SB*C K2 = K2 + 1 B = PR(K2) PR(K1) = A*C2 - B*S2 PR(K2) = A*S2 + B*C2 RETURN END *CMZ : 3.14/16 13/03/89 14.48.41 BY NICK VAN EIJNDHOVEN (CERN) *-- AUTHOR : C--------------------------------------------------------------------- SUBROUTINE RTMI(X,F,FCT,XLI,XRI,EPS,IEND,IER) C C *** NVE 16-MAR-1988 CERN GENEVA *** C C ORIGIN : H.FESEFELDT (27-OCT-1983) C COPIED FROM R01UTL.SSP.S 23.4.82 C SAVE EXTERNAL FCT C C --- PREPARE ITERATION --- IER=0 XL=XLI XR=XRI X=XL TOL=X F=FCT(TOL) IF(F)1,16,1 1 FL=F X=XR TOL=X F=FCT(TOL) IF(F)2,16,2 2 FR=F IF(SIGN(1.,FL)+SIGN(1.,FR))25,3,25 C C BASIC ASSUMPTION FL*FR LESS THAN 0 IS SATISFIED. C GENERATE TOLERANCE FOR FUNCTION VALUES. 3 I=0 TOLF=100.*EPS C C C START ITERATION LOOP 4 I=I+1 C C START BISECTION LOOP DO 13 K=1,IEND X=.5*(XL+XR) TOL=X F=FCT(TOL) IF(F)5,16,5 5 IF(SIGN(1.,F)+SIGN(1.,FR))7,6,7 C C INTERCHANGE XL AND XR IN ORDER TO GET THE SAME SIGN IN F AND FR 6 TOL=XL XL=XR XR=TOL TOL=FL FL=FR FR=TOL 7 TOL=F-FL A=F*TOL A=A+A IF(A-FR*(FR-FL))8,9,9 8 IF(I-IEND)17,17,9 9 XR=X FR=F C C TEST ON SATISFACTORY ACCURACY IN BISECTION LOOP TOL=EPS A=ABS(XR) IF(A-1.)11,11,10 10 TOL=TOL*A 11 IF(ABS(XR-XL)-TOL)12,12,13 12 IF(ABS(FR-FL)-TOLF)14,14,13 13 CONTINUE C END OF BISECTION LOOP C C NO CONVERGENCE AFTER IEND ITERATION STEPS FOLLOWED BY IEND C SUCCESSIVE STEPS OF BISECTION OR STEADILY INCREASING FUNCTION C VALUES AT RIGHT BOUNDS. ERROR RETURN. IER=1 14 IF(ABS(FR)-ABS(FL))16,16,15 15 X=XL F=FL 16 RETURN C C COMPUTATION OF ITERATED X-VALUE BY INVERSE PARABOLIC INTERPOLATION 17 A=FR-F DX=(X-XL)*FL*(1.+F*(A-TOL)/(A*(FR-FL)))/TOL XM=X FM=F X=XL-DX TOL=X F=FCT(TOL) IF(F)18,16,18 C C TEST ON SATISFACTORY ACCURACY IN ITERATION LOOP 18 TOL=EPS A=ABS(X) IF(A-1.)20,20,19 19 TOL=TOL*A 20 IF(ABS(DX)-TOL)21,21,22 21 IF(ABS(F)-TOLF)16,16,22 C C PREPARATION OF NEXT BISECTION LOOP 22 IF(SIGN(1.,F)+SIGN(1.,FL))24,23,24 23 XR=X FR=F GO TO 4 24 XL=X FL=F XR=XM FR=FM GO TO 4 C END OF ITERATION LOOP C C C ERROR RETURN IN CASE OF WRONG INPUT DATA 25 IER=2 RETURN END *CMZU: 3.16/00 05/11/93 17.20.00 BY FEDERICO CARMINATI *-- AUTHOR : C--------------------------------------------------------------------- SUBROUTINE SELFAB(SPROB) C C *** SELF-ABSORBTION IN HEAVY MOLECULES *** C *** NVE 16-MAR-1988 CERN GENEVA *** C C ORIGIN : H.FESEFELDT (11-OCT-1987) C PARAMETER (MXGKGH=100) PARAMETER (MXGKCU=MXGKGH) COMMON/CURPAR/WEIGHT(10),DDELTN,IFILE,IRUN,NEVT,NEVENT,SHFLAG, * ITHST,ITTOT,ITLST,IFRND,TOFCUT,CMOM(5),CENG(5), * RS,S,ENP(10),NP,NM,NN,NR,NO,NZ,IPA(MXGKCU), * ATNO2,ZNO2 C PARAMETER (MXGKPV=MXGKGH) COMMON /VECUTY/ PV(10,MXGKPV) C SAVE C SPROB=0. EKW=PV(4,MXGKPV)-ABS(PV(5,MXGKPV)) IF(EKW.LT.5.) RETURN ALEKW=LOG(EKW-4.) SPROB=0.6*ALEKW IF(SPROB.GT.1.) SPROB=1. RETURN END *CMZ : 3.14/16 13/03/89 14.48.41 BY NICK VAN EIJNDHOVEN (CERN) *-- AUTHOR : C--------------------------------------------------------------------- SUBROUTINE SETCUR(NTR) C C *** STORAGE OF CURRENT TRACK PARAMETERS *** C *** NVE 16-MAR-1988 CERN GENEVA *** C C ORIGIN : H.FESEFELDT (26-JAN-1984) C PARAMETER (MXGKGH=100) COMMON/CONSTS/ PI,TWPI,PIBTW,MP,MPI,MMU,MEL,MKCH,MK0,SMP,SMPI, $ SMU,CT,CTKCH,CTK0, $ ML0,MSP,MS0,MSM,MX0,MXM,CTL0,CTSP,CTSM,CTX0,CTXM, $ RMASS(35),RCHARG(35) C REAL MP,MPI,MMU,MEL,MKCH,MK0, * ML0,MSP,MS0,MSM,MX0,MXM C PARAMETER (MXGKCU=MXGKGH) COMMON/CURPAR/WEIGHT(10),DDELTN,IFILE,IRUN,NEVT,NEVENT,SHFLAG, * ITHST,ITTOT,ITLST,IFRND,TOFCUT,CMOM(5),CENG(5), * RS,S,ENP(10),NP,NM,NN,NR,NO,NZ,IPA(MXGKCU), * ATNO2,ZNO2 C COMMON/RESULT/XEND,YEND,ZEND,RCA,RCE,AMAS,NCH,TOF,PX,PY,PZ, * USERW,INTCT,P,EN,EK,AMASQ,DELTN,ITK,NTK,IPART,IND, * LCALO,ICEL,SINL,COSL,SINP,COSP, * XOLD,YOLD,ZOLD,POLD,PXOLD,PYOLD,PZOLD, * XSCAT,YSCAT,ZSCAT,PSCAT,PXSCAT,PYSCAT,PZSCAT REAL NCH,INTCT C COMMON/MAT / LMAT, * DEN(21),RADLTH(21),ATNO(21),ZNO(21),ABSL(21), * CDEN(21),MDEN(21),X0DEN(21),X1DEN(21),RION(21), * MATID(21),MATID1(21,24),PARMAT(21,10), * IFRAT,IFRAC(21),FRAC1(21,10),DEN1(21,10), * ATNO1(21,10),ZNO1(21,10) C PARAMETER (MXEVEN=12*MXGKGH) COMMON/EVENT / NSIZE,NCUR,NEXT,NTOT,EVE(MXEVEN) C COMMON/PRNTFL/INBCD,NEWBCD,INBIN,NEWBIN,NPEVT,NEVTP,LPRT,NPRT(10) LOGICAL LPRT,NPRT C COMMON/ERRCOM/ IER(100) C PARAMETER (MXGKPV=MXGKGH) COMMON /VECUTY/ PV(10,MXGKPV) C C DIMENSION RNDM(1) SAVE C CALL LENGTX(NTR,P) AMAS=PV(5,NTR) AMASQ=AMAS*AMAS NCH=PV(6,NTR) TOF=PV(7,NTR) IPART=IFIX(PV(8,NTR)+0.1) IF(PV(10,NTR).NE.0.) USERW=PV(10,NTR) PX=0. PY=0. PZ=0. IF(P.LT.1.E-10) GOTO 4 PX=PV(1,NTR)/P PY=PV(2,NTR)/P PZ=PV(3,NTR)/P 4 EN=PV(4,NTR) EK=EN-ABS(AMAS) SINL=PZ COSL=SQRT(ABS(1.-SINL*SINL)) IF(ABS(COSL).LT.1.E-10) GOTO 1 SINP=PY/COSL COSP=PX/COSL GOTO 2 1 CALL GRNDM(RNDM,1) PHI=RNDM(1)*TWPI SINP=SIN(PHI) COSP=COS(PHI) 2 IF(NPRT(3).OR.NPRT(4).OR.NPRT(5)) *WRITE(NEWBCD,1001) XEND,YEND,ZEND,RCA,RCE,AMAS,NCH,TOF,PX,PY,PZ, *USERW,INTCT,P,EN,EK,AMASQ,DELTN,ITK,NTK,IPART,IND,LCALO,ICEL, *SINL,COSL,SINP,COSP RETURN 1001 FORMAT(1H ,'*SETCUR* ','TRACK PARAMETER CHANGED: ', $ 3F13.2,1X,2F7.0,1X,F8.3,1X,/,' ', $ F3.0,1X,F6.0,1X,3F6.3,1X,F10.0,1X,F5.0/10X,4F8.3,1X,F8.5,1X,6I5, $ 4F8.3) END *CMZU: 3.16/00 05/11/93 17.20.00 BY FEDERICO CARMINATI *-- AUTHOR : C--------------------------------------------------------------------- SUBROUTINE SETTRK(NTR) C C *** FILL THE STACK VIA COMMON /EVENT/ *** C *** INSTEAD OF THE USERWORD, THE PARTICLE INDEX IS STORED *** C *** NVE 01-MAR-1988 CERN GENEVA *** C C ORIGIN : H.FESEFELDT (10-NOV-1983) C INTEGER MXGKIN PARAMETER (MXGKIN=100) COMMON/GCKING/KCASE,NGKINE,GKIN(5,MXGKIN), + TOFD(MXGKIN),IFLGK(MXGKIN) INTEGER KCASE,NGKINE ,IFLGK,MXPHOT,NGPHOT REAL GKIN,TOFD,XPHOT C PARAMETER (MXPHOT=800) COMMON/GCKIN2/NGPHOT,XPHOT(11,MXPHOT) C COMMON/GCKIN3/GPOS(3,MXGKIN) REAL GPOS C PARAMETER (MXGKGH=100) COMMON/CONSTS/ PI,TWPI,PIBTW,MP,MPI,MMU,MEL,MKCH,MK0,SMP,SMPI, $ SMU,CT,CTKCH,CTK0, $ ML0,MSP,MS0,MSM,MX0,MXM,CTL0,CTSP,CTSM,CTX0,CTXM, $ RMASS(35),RCHARG(35) C REAL MP,MPI,MMU,MEL,MKCH,MK0, * ML0,MSP,MS0,MSM,MX0,MXM C PARAMETER (MXGKCU=MXGKGH) COMMON/CURPAR/WEIGHT(10),DDELTN,IFILE,IRUN,NEVT,NEVENT,SHFLAG, * ITHST,ITTOT,ITLST,IFRND,TOFCUT,CMOM(5),CENG(5), * RS,S,ENP(10),NP,NM,NN,NR,NO,NZ,IPA(MXGKCU), * ATNO2,ZNO2 C COMMON/RESULT/XEND,YEND,ZEND,RCA,RCE,AMAS,NCH,TOF,PX,PY,PZ, * USERW,INTCT,P,EN,EK,AMASQ,DELTN,ITK,NTK,IPART,IND, * LCALO,ICEL,SINL,COSL,SINP,COSP, * XOLD,YOLD,ZOLD,POLD,PXOLD,PYOLD,PZOLD, * XSCAT,YSCAT,ZSCAT,PSCAT,PXSCAT,PYSCAT,PZSCAT REAL NCH,INTCT C COMMON/MAT / LMAT, * DEN(21),RADLTH(21),ATNO(21),ZNO(21),ABSL(21), * CDEN(21),MDEN(21),X0DEN(21),X1DEN(21),RION(21), * MATID(21),MATID1(21,24),PARMAT(21,10), * IFRAT,IFRAC(21),FRAC1(21,10),DEN1(21,10), * ATNO1(21,10),ZNO1(21,10) C PARAMETER (MXEVEN=12*MXGKGH) COMMON/EVENT / NSIZE,NCUR,NEXT,NTOT,EVE(MXEVEN) C COMMON/PRNTFL/INBCD,NEWBCD,INBIN,NEWBIN,NPEVT,NEVTP,LPRT,NPRT(10) LOGICAL LPRT,NPRT C COMMON/ERRCOM/ IER(100) C PARAMETER (MXGKPV=MXGKGH) COMMON /VECUTY/ PV(10,MXGKPV) C SAVE C C C --- CHECK PV ARRAY BOUNDARY --- IF(NTR .LE. MXGKPV) GOTO 10 PRINT 1000,NTR 1000 FORMAT(' *SETTRK* NTR = ',I3,' WOULD ADRESS OUTSIDE PV ARRAY'/ $ ' ===> TRACK WILL NOT BE PUT ON STACK AND WILL BE LOST') GO TO 9999 C C --- CHECK TOTAL NUMBER OF PRODUCED PARTICLES --- 10 CONTINUE NVEDUM=NTOT+1 IF(NVEDUM .LE. MXEVEN) GOTO 20 IF(NVEDUM .EQ. MXEVEN+1) PRINT 1001, NVEDUM,MXEVEN 1001 FORMAT(' *SETTRK* STORAGE OF PARTICLE NO. ',I4, 'NOT ALLOWED'/ $ ' MAXIMUM NUMBER OF GENERATED PARTICLES IS ',I4/ $ ' ===> FROM NOW ON ALL GENERATED PARTICLES WILL BE DISCARDED') GO TO 9999 C C --- STORE GENERATED PARTICLE ON THE STACK --- 20 CONTINUE EVE(NEXT )=XEND EVE(NEXT+ 1)=YEND EVE(NEXT+ 2)=ZEND EVE(NEXT+ 3)=RCA EVE(NEXT+ 4)=RCE EVE(NEXT+ 5)=PV(5,NTR) EVE(NEXT+ 6)=PV(6,NTR) EVE(NEXT+ 7)=PV(7,NTR) EVE(NEXT+ 8)=PV(1,NTR) EVE(NEXT+ 9)=PV(2,NTR) EVE(NEXT+10)=PV(3,NTR) EVE(NEXT+11)=PV(8,NTR) NEXT=NEXT+12 NTOT=NTOT+1 NEXT1=NEXT-12 NEXT2=NEXT-1 NTOT1=NTOT-1 IF(NPRT(3).OR.NPRT(4).OR.NPRT(5)) $ WRITE(NEWBCD,2000) NTOT1,(EVE(I),I=NEXT1,NEXT2) 2000 FORMAT(' *SETTRK* TRACK ON STACK:',I5,/, $ 12X,3F12.2,1X,2F7.0,1X, $ F8.3,1X,F3.0,1X,F6.0,1X,3F8.3,1X,F10.0) C 9999 CONTINUE RETURN END *CMZ : 3.14/16 28/09/90 10.10.17 BY NICK VAN EIJNDHOVEN (CERN) *-- AUTHOR : C--------------------------------------------------------------------- SUBROUTINE STEEP(XX) C C *** NVE 16-MAR-1988 CERN GENEVA *** C C ORIGIN : H.FESEFELDT (22-FEB-1985) C XX=1. RETURN END *CMZU: 3.16/00 05/11/93 17.20.00 BY FEDERICO CARMINATI *-- AUTHOR : C--------------------------------------------------------------------- SUBROUTINE STEEQ(XXH,IPV) C C *** CORRECTIONS FOR SINGLE PARTICLE SPECTRA (SHOWER PARTICLES) *** C *** NVE 16-MAR-1988 CERN GENEVA C C ORIGIN : H.FESEFELDT (06-SEP-1985) C PARAMETER (MXGKGH=100) PARAMETER (MXGKCU=MXGKGH) COMMON/CURPAR/WEIGHT(10),DDELTN,IFILE,IRUN,NEVT,NEVENT,SHFLAG, * ITHST,ITTOT,ITLST,IFRND,TOFCUT,CMOM(5),CENG(5), * RS,S,ENP(10),NP,NM,NN,NR,NO,NZ,IPA(MXGKCU), * ATNO2,ZNO2 C PARAMETER (MXGKPV=MXGKGH) COMMON /VECUTY/ PV(10,MXGKPV) C COMMON/RESULT/XEND,YEND,ZEND,RCA,RCE,AMAS,NCH,TOF,PX,PY,PZ, * USERW,INTCT,P,EN,EK,AMASQ,DELTN,ITK,NTK,IPART,IND, * LCALO,ICEL,SINL,COSL,SINP,COSP, * XOLD,YOLD,ZOLD,POLD,PXOLD,PYOLD,PZOLD, * XSCAT,YSCAT,ZSCAT,PSCAT,PXSCAT,PYSCAT,PZSCAT REAL NCH,INTCT C C DIMENSION ALEM(7),VAL0(7) DIMENSION RNDM(1) SAVE C** DATA EM/ 4.0 , 10. , 15. , 20. , 30. , 100. , 1000./ DATA ALEM/ 1.40, 2.30 , 2.70 , 3.00 , 3.40 , 4.60 , 7.00 / DATA VAL0/ 0.00, 0.40 , 0.48 , 0.51 , 0.54 , 0.60 , 0.65 / C XXH=1. C IF ((IPART .NE. 7) .AND. (IPART .NE. 9)) GO TO 9999 IF (ABS(IPA(IPV)) .NE. 8) GO TO 9999 CALL GRNDM(RNDM,1) IF (RNDM(1) .GT. LOG(ATNO2)) GO TO 9999 EKW=PV(4,MXGKPV)-ABS(PV(5,MXGKPV)) ALEKW=LOG(EKW) IF (ALEKW .LE. ALEM(1)) GO TO 9999 C C --- GET ENERGY BIN --- DO 1 I=2,7 IF (ALEKW .LT. ALEM(I)) GO TO 2 1 CONTINUE XXH=VAL0(7) GO TO 3 C C *** USE LINEAR INTERPOLATION OR EXTRAPOLATION BY Y=RC*X+B *** 2 CONTINUE I1=I-1 I2=I DXNVE=ALEM(I2)-ALEM(I1) DYNVE=VAL0(I2)-VAL0(I1) RCNVE=DYNVE/DXNVE BNVE=VAL0(I1)-RCNVE*ALEM(I1) XXH=RCNVE*ALEKW+BNVE C 3 CONTINUE XXH=1.-XXH C 9999 CONTINUE RETURN END *CMZU: 3.16/00 05/11/93 17.20.00 BY FEDERICO CARMINATI *-- AUTHOR : C--------------------------------------------------------------------- SUBROUTINE STPAIR C C *** STRANGE PARTICLE PAIR PRODUCTION *** C *** NVE 14-MAR-1988 CERN GENEVA *** C C ORIGIN : H.FESEFELDT 16-DEC-1987 C C THE SAME FORMULA FOR VS AVAILABLE ENERGY C AND VS AVAILABLE ENERGY C FOR ALL REACTIONS. C CHOOSE CHARGE COMBINATIONS K+ K- , K+ K0B, K0 K0B OR K0 K- C K+ Y0, K0 Y+, K0 Y- C FOR ANTIBARYON INDUCED REACTIONS HALF OF THE CROSS SECTIONS C KB YB PAIRS ARE PRODUCED C CHARGE IS NOT CONSERVED , NO EXPERIMENTAL DATA AVAILABLE FOR C EXCLUSIVE REACTIONS, THEREFORE SOME AVERAGE BEHAVIOUR ASSUMED. C THE RATIO L/SIGMA IS TAKEN AS 3:1 (FROM EXPERIMENTAL LOW ENERGY) C PARAMETER (MXGKGH=100) COMMON/CONSTS/ PI,TWPI,PIBTW,MP,MPI,MMU,MEL,MKCH,MK0,SMP,SMPI, $ SMU,CT,CTKCH,CTK0, $ ML0,MSP,MS0,MSM,MX0,MXM,CTL0,CTSP,CTSM,CTX0,CTXM, $ RMASS(35),RCHARG(35) C REAL MP,MPI,MMU,MEL,MKCH,MK0, * ML0,MSP,MS0,MSM,MX0,MXM C PARAMETER (MXGKCU=MXGKGH) COMMON/CURPAR/WEIGHT(10),DDELTN,IFILE,IRUN,NEVT,NEVENT,SHFLAG, * ITHST,ITTOT,ITLST,IFRND,TOFCUT,CMOM(5),CENG(5), * RS,S,ENP(10),NP,NM,NN,NR,NO,NZ,IPA(MXGKCU), * ATNO2,ZNO2 C COMMON/RESULT/XEND,YEND,ZEND,RCA,RCE,AMAS,NCH,TOF,PX,PY,PZ, * USERW,INTCT,P,EN,EK,AMASQ,DELTN,ITK,NTK,IPART,IND, * LCALO,ICEL,SINL,COSL,SINP,COSP, * XOLD,YOLD,ZOLD,POLD,PXOLD,PYOLD,PZOLD, * XSCAT,YSCAT,ZSCAT,PSCAT,PXSCAT,PYSCAT,PZSCAT REAL NCH,INTCT C COMMON/MAT / LMAT, * DEN(21),RADLTH(21),ATNO(21),ZNO(21),ABSL(21), * CDEN(21),MDEN(21),X0DEN(21),X1DEN(21),RION(21), * MATID(21),MATID1(21,24),PARMAT(21,10), * IFRAT,IFRAC(21),FRAC1(21,10),DEN1(21,10), * ATNO1(21,10),ZNO1(21,10) C PARAMETER (MXEVEN=12*MXGKGH) COMMON/EVENT / NSIZE,NCUR,NEXT,NTOT,EVE(MXEVEN) C COMMON/PRNTFL/INBCD,NEWBCD,INBIN,NEWBIN,NPEVT,NEVTP,LPRT,NPRT(10) LOGICAL LPRT,NPRT C COMMON/ERRCOM/ IER(100) C PARAMETER (MXGKPV=MXGKGH) COMMON /VECUTY/ PV(10,MXGKPV) C C C REAL KKB,KY DIMENSION KKB(9),KY(12),IPAKKB(2,9),IPAKY(2,12),IPAKYB(2,12) DIMENSION AVKKB(12),AVKY(12),AVNNB(12),AVRS(12) DIMENSION RNDM(1) SAVE DATA KKB/0.2500,0.3750,0.5000,0.5625,0.6250,0.6875,0.7500, * 0.8750,1.000/ DATA KY /0.200,0.300,0.400,0.550,0.625,0.700,0.800,0.850, * 0.900,0.950,0.975,1.000/ DATA IPAKKB/10,13,10,11,10,12,11,11,11,12,12,11,12,12, * 11,13,12,13/ DATA IPAKY /18,10,18,11,18,12,20,10,20,11,20,12,21,10, * 21,11,21,12,22,10,22,11,22,12/ DATA IPAKYB/19,13,19,12,19,11,23,13,23,12,23,11,24,13, * 24,12,24,11,25,13,25,12,25,11/ DATA AVRS/3.,4.,5.,6.,7.,8.,9.,10.,20.,30.,40.,50./ DATA AVKKB/0.0015,0.005,0.012,0.0285,0.0525,0.075,0.0975, * 0.123,0.28,0.398,0.495,0.573/ DATA AVKY /0.005,0.03,0.064,0.095,0.115,0.13,0.145,0.155, * 0.20,0.205,0.210,0.212/ DATA AVNNB/0.00001,0.0001,0.0006,0.0025,0.01,0.02,0.04, $ 0.05,0.12,0.15,0.18,0.20/ C IF(IPA(3).LE.0) GO TO 9999 IER(50)=IER(50)+1 IPA1=ABS(IPA(1)) IPA2=ABS(IPA(2)) C --- PROTECTION AGAINST ANNIHILATION PROCESSES --- IF ((IPA1 .EQ. 0) .OR. (IPA2 .EQ. 0)) GO TO 9999 EAB=RS-ABS(RMASS(IPA1))-ABS(RMASS(IPA2)) IF(EAB.LT.1.) GO TO 9999 C** C** CHOOSE RANDOM REPLACEMENT OF PRODUCED KAONS (16.12.87) DO 111 I=1,60 IF(IPA(I).EQ.0) GOTO 112 111 CONTINUE 112 I=I-3 CALL GRNDM(RNDM,1) I3=3+IFIX(RNDM(1)*I) 114 CALL GRNDM(RNDM,1) I4=3+IFIX(RNDM(1)*I) IF(I.EQ.1) I4=4 IF(I3.EQ.I4) GOTO 114 C C *** CHOOSE RANDOM REPLACEMENT OF PRODUCED KAONS (16.12.87) *** C --- GET RS BIN --- DO 1 I=2,12 IF (RS .LE. AVRS(I)) GO TO 2 1 CONTINUE I1=11 I2=12 GO TO 3 C 2 CONTINUE I1=I-1 I2=I C C *** USE LINEAR INTERPOLATION OR EXTRAPOLATION BY Y=RC*X+B *** 3 CONTINUE DXNVE=AVRS(I2)-AVRS(I1) DYNVE=LOG(AVKKB(I2))-LOG(AVKKB(I1)) RCNVE=DYNVE/DXNVE BNVE=LOG(AVKKB(I1))-RCNVE*AVRS(I1) AVK=RCNVE*RS+BNVE DYNVE=LOG(AVKY(I2))-LOG(AVKY(I1)) RCNVE=DYNVE/DXNVE BNVE=LOG(AVKY(I1))-RCNVE*AVRS(I1) AVY=RCNVE*RS+BNVE DYNVE=LOG(AVNNB(I2))-LOG(AVNNB(I1)) RCNVE=DYNVE/DXNVE BNVE =LOG(AVNNB(I1))-RCNVE*AVRS(I1) AVN =RCNVE*RS+BNVE C AVK=EXP(AVK) AVY=EXP(AVY) AVN=EXP(AVN) IF(AVK+AVY+AVN.LE.0.) GOTO 9999 IF(IPA1.LT.14) AVY=AVY/2. IF(IPA2.LT.14) AVY=0. AVY=AVY+AVK+AVN AVK= AVK+AVN CALL GRNDM(RNDM,1) RAN=RNDM(1) IF(RAN.LT.AVN) GOTO 5 IF(RAN.LT.AVK) GOTO 10 IF(RAN.LT.AVY) GOTO 20 GO TO 9999 5 IF((EAB-2.).LT.0.) GO TO 9999 CALL GRNDM(RNDM,1) IF(RNDM(1).LT.0.5) GO TO 6 IPA(I3)=14 IPA(I4)=15 GOTO 30 6 IPA(I3)=16 IPA(I4)=17 GOTO 30 10 IF((EAB-1.).LT.0.) GO TO 9999 CALL GRNDM(RNDM,1) RAN=RNDM(1) DO 11 I=1,9 IF(RAN.LT.KKB(I)) GOTO 12 11 CONTINUE GO TO 9999 12 IPA(I3)=IPAKKB(1,I) IPA(I4)=IPAKKB(2,I) GOTO 30 20 IF((EAB-1.6).LT.0.) GO TO 9999 CALL GRNDM(RNDM,1) RAN=RNDM(1) DO 21 I=1,12 IF(RAN.LT.KY(I)) GOTO 22 21 CONTINUE GO TO 9999 22 IF(IPA(1).LT.14) GOTO 23 CALL GRNDM(RNDM,1) IF(RNDM(1).LT.0.5) GOTO 23 IPA1=ABS(IPA(1)) IPA(1)=IPAKY(1,I) IF(IPA1.EQ.15) GOTO 25 IF(IPA1.EQ.17) GOTO 25 IF(IPA1.EQ.19) GOTO 25 IF(IPA1.GT.22) GOTO 25 GOTO 24 25 IPA(1)=IPAKYB(1,I) IPA(I3)=IPAKYB(2,I) GOTO 30 23 IPA(2)=IPAKY(1,I) 24 IPA(I3)=IPAKY(2,I) C** CHECK THE AVAILABLE ENERGY 30 EAB=RS IJ=0 DO 31 I=1,60 IF(IPA(I).EQ.0) GOTO 31 IPA1=ABS(IPA(I)) EAB=EAB-ABS(RMASS(IPA1)) IJ=IJ+1 IF(EAB.LT.0.) GOTO 35 31 CONTINUE IF (NPRT(4)) WRITE(NEWBCD,1003) (IPA(J),J=1,IJ) GO TO 9999 35 I=I-1 L=I-1 IF(L.LE.0) GO TO 9999 DO 36 J=I,60 36 IPA(J)=0 IF (NPRT(4)) WRITE(NEWBCD,1002) (IPA(J),J=1,L) C 1002 FORMAT(' *STPAIR* KKB/KY PAIR PRODUCTION NOT ENOUGH ENERGY', $/,' REDUCE NUMBER OF PARTICLES ',2X,20I3) 1003 FORMAT(' *STPAIR* KKB/KY PAIR PRODUCTION ENERGY SUFFICIENT', $/ ' NUMBER OF PARTICLES ',2X,20I3) C 9999 CONTINUE C RETURN END *CMZ : 3.16/00 05/11/93 17.50.33 BY FEDERICO CARMINATI *-- AUTHOR : C--------------------------------------------------------------------- SUBROUTINE SVERL2(M,X) DIMENSION U(2) SAVE C CALL GRNDM(U,2) X=0.62666*LOG((1.+U(1))/(1.-U(1))) IF(U(2).LT.0.5) X=-X X=M+X*SQRT(M*1.) RETURN END *CMZ : 3.16/00 05/11/93 17.50.33 BY FEDERICO CARMINATI *-- AUTHOR : C--------------------------------------------------------------------- SUBROUTINE SVGAM7(A,X) DIMENSION U(2) REAL LA SAVE C GA=A-1. LA=SQRT(2.*A-1.) EP=1.570796327+ATAN(GA/LA) RO=1.570796327-EP 1 CALL GRNDM(U,2) X=GA+LA*TAN(EP*U(1)+RO) CDH IF(X.LE.0.) GOTO 1 C Y=LOG(1.+((X-GA)/LA)**2) +GA*LOG(X/GA)-X+GA IF(LOG(U(2)).GT.Y) GOTO 1 RETURN END *CMZU: 3.16/00 05/11/93 17.20.00 BY FEDERICO CARMINATI *-- AUTHOR : C--------------------------------------------------------------------- SUBROUTINE TDELAY(X) C C *** TIME DELAY FOR NUCLEAR REACTIONS *** C *** NVE 16-MAR-1988 CERN GENEVA *** C C ORIGIN : H.FESEFELDT (01-FEB-1984) C PARAMETER (MXGKGH=100) PARAMETER (MXGKCU=MXGKGH) COMMON/CURPAR/WEIGHT(10),DDELTN,IFILE,IRUN,NEVT,NEVENT,SHFLAG, * ITHST,ITTOT,ITLST,IFRND,TOFCUT,CMOM(5),CENG(5), * RS,S,ENP(10),NP,NM,NN,NR,NO,NZ,IPA(MXGKCU), * ATNO2,ZNO2 C COMMON/RESULT/XEND,YEND,ZEND,RCA,RCE,AMAS,NCH,TOF,PX,PY,PZ, * USERW,INTCT,P,EN,EK,AMASQ,DELTN,ITK,NTK,IPART,IND, * LCALO,ICEL,SINL,COSL,SINP,COSP, * XOLD,YOLD,ZOLD,POLD,PXOLD,PYOLD,PZOLD, * XSCAT,YSCAT,ZSCAT,PSCAT,PXSCAT,PYSCAT,PZSCAT REAL NCH,INTCT C SAVE C X=0. IF(ATNO2.LT.1.5) RETURN IF(ATNO2.GT.230.) RETURN IF(EK.GT.0.2) RETURN X=500.*EXP(-EK/0.04) RETURN END *CMZ : 3.16/00 05/11/93 19.14.52 BY FEDERICO CARMINATI *-- AUTHOR : C--------------------------------------------------------------------- SUBROUTINE TWOB(IPPP,NFL,AVERN) C C *** GENERATION OF MOMENTA FOR ELAST. AND QUASI ELAST. 2 BODY REACT. *** C *** NVE 04-MAY-1988 CERN GENEVA *** C C ORIGIN : H.FESEFELDT 15-SEP-1987 C C THE SIMPLE FORMULA DS/D|T| = S0* EXP(-B*|T|) IS USED. C THE B VALUES ARE PARAMETRIZATIONS FROM EXPERIMENTAL DATA . C NOT AVAILABLE VALUES ARE TAKEN FROM THOSE OF SIMILAR REACTIONS C PARAMETER (MXGKGH=100) COMMON/CONSTS/ PI,TWPI,PIBTW,MP,MPI,MMU,MEL,MKCH,MK0,SMP,SMPI, $ SMU,CT,CTKCH,CTK0, $ ML0,MSP,MS0,MSM,MX0,MXM,CTL0,CTSP,CTSM,CTX0,CTXM, $ RMASS(35),RCHARG(35) C REAL MP,MPI,MMU,MEL,MKCH,MK0, * ML0,MSP,MS0,MSM,MX0,MXM C PARAMETER (MXGKCU=MXGKGH) COMMON/CURPAR/WEIGHT(10),DDELTN,IFILE,IRUN,NEVT,NEVENT,SHFLAG, * ITHST,ITTOT,ITLST,IFRND,TOFCUT,CMOM(5),CENG(5), * RS,S,ENP(10),NP,NM,NN,NR,NO,NZ,IPA(MXGKCU), * ATNO2,ZNO2 C COMMON/RESULT/XEND,YEND,ZEND,RCA,RCE,AMAS,NCH,TOF,PX,PY,PZ, * USERW,INTCT,P,EN,EK,AMASQ,DELTN,ITK,NTK,IPART,IND, * LCALO,ICEL,SINL,COSL,SINP,COSP, * XOLD,YOLD,ZOLD,POLD,PXOLD,PYOLD,PZOLD, * XSCAT,YSCAT,ZSCAT,PSCAT,PXSCAT,PYSCAT,PZSCAT REAL NCH,INTCT C COMMON/MAT / LMAT, * DEN(21),RADLTH(21),ATNO(21),ZNO(21),ABSL(21), * CDEN(21),MDEN(21),X0DEN(21),X1DEN(21),RION(21), * MATID(21),MATID1(21,24),PARMAT(21,10), * IFRAT,IFRAC(21),FRAC1(21,10),DEN1(21,10), * ATNO1(21,10),ZNO1(21,10) C PARAMETER (MXEVEN=12*MXGKGH) COMMON/EVENT / NSIZE,NCUR,NEXT,NTOT,EVE(MXEVEN) C COMMON/PRNTFL/INBCD,NEWBCD,INBIN,NEWBIN,NPEVT,NEVTP,LPRT,NPRT(10) LOGICAL LPRT,NPRT C COMMON/ERRCOM/ IER(100) C PARAMETER (MXGKPV=MXGKGH) COMMON /VECUTY/ PV(10,MXGKPV) C C DIMENSION RNDM(3) C SAVE C DATA CB/3./ DATA CB/0.01/ C C --- STATEMENT FUNCTIONS --- BPP(X)=4.225+1.795*LOG(X) C C** C** FOR DIFFRACTION SCATTERING ON HEAVY NUCLEI USE BETTER ROUTINE C** "COSCAT" C TARMAS=RMASS(14) IF (NFL .EQ. 2) TARMAS=RMASS(16) ENP(8)=RMASS(IPPP)**2+TARMAS**2+2.0*TARMAS*ENP(6) ENP(9)=SQRT(ENP(8)) EK=ENP(5) EN=ENP(6) P=ENP(7) S=ENP(8) RS=ENP(9) CFA=0.025*((ATNO2-1.)/120.)*EXP(-(ATNO2-1.)/120.) IF(ATNO2.LT.1.5) GOTO 500 IPA1=ABS(IPA(1)) IPA2=ABS(IPA(2)) RMC=RMASS(IPA1) RMD=RMASS(IPA2) RCHC=RCHARG(IPA1) RCHD=RCHARG(IPA2) IF(ABS(RMC-AMAS).GT.0.001) GOTO 500 RMNVE=RMASS(14) IF (NFL .EQ. 2) RMNVE=RMASS(16) IF(ABS(RMD-RMNVE).GT.0.001) GOTO 500 IF(ABS(RCHC-NCH).GT.0.5) GOTO 500 IF(NFL.EQ.1.AND.RCHD.LT.0.5) GOTO 500 IF(NFL.EQ.2.AND.ABS(RCHD).GT.0.5) GOTO 500 IF(ENP(1).GT.0.0001.OR.ENP(3).GT.0.0001) GOTO 500 CALL COSCAT GO TO 9999 C** C** SET EFFECTIVE 4-MOMENTUM OF INITIAL PARTICLE C** 500 PV( 1,MXGKPV-1)=P*PX PV( 2,MXGKPV-1)=P*PY PV( 3,MXGKPV-1)=P*PZ PV( 4,MXGKPV-1)=EN PV( 5,MXGKPV-1)=AMAS PV( 6,MXGKPV-1)=NCH PV( 7,MXGKPV-1)=TOF PV( 8,MXGKPV-1)=IPART PV( 9,MXGKPV-1)=0. PV(10,MXGKPV-1)=USERW IER(47)=IER(47)+1 IF(NPRT(4)) $ WRITE(NEWBCD,4001) (PV(J,MXGKPV-1),J=1,10),IPA(1),IPA(2) DO 2 J=1,6 2 PV(J,1)=PV(J,MXGKPV-1) PV(7,1)=1. IF(PV(5,1).LT.0.) PV(7,1)=-1. PV(5,1)=ABS(PV(5,1)) NT=1 C** C** TWO-BODY SCATTERING POSSIBLE?? IF NOT, CONTINUE WITH ORIGINAL C** PARTICLE, BUT SPEND THE NUCLEAR EVAPORATION ENERGY C** IF(P.LT.0.1) GOTO 200 IF(RS.LT.0.01) GOTO 200 C** C** CALCULATE SLOPE B FOR ELASTIC SCATTERING ON PROTON/NEUTRON C** B=BPP(P) IF(B.LT.CB) B=CB IF(ABS(IPA(2)).GT.13) GOTO 9 IPA(2)=14 CALL GRNDM(RNDM,1) IF(RNDM(1).LT.0.5) IPA(2)=16 C** C** SET MASSES AND MOMENTA FOR FINAL STATE PARTICLES C** 9 RMC=RMASS(ABS(IPA(1))) RMD=RMASS(ABS(IPA(2))) PV(6,1)=RCHARG(ABS(IPA(1))) PV(6,2)=RCHARG(ABS(IPA(2))) PF=(S+RMD*RMD-RMC*RMC)**2 - 4*S*RMD*RMD IF(NPRT(4)) WRITE(NEWBCD,4002) RMC,RMD,PV(6,1),PV(6,2),RS,S,PF IF(PF.LT.0.001) GO TO 9999 PF=SQRT(PF)/(2.*RS) C** C** SET BEAM AND TARGET IN CMS C** PV(1,3)=0. PV(2,3)=0. PV(3,3)=P PV(5,3)=ABS(AMAS) PV(4,3)=SQRT(P*P+AMAS*AMAS) PV(1,4)=0. PV(2,4)=0. PV(3,4)=0. RMNVE=RMASS(14) IF (NFL .EQ. 2) RMNVE=RMASS(16) PV(4,4)=RMNVE PV(5,4)=RMNVE C** C** TRANSFORM INTO CMS. C** CALL ADD(3,4,10) CALL LOR(3,10,3) CALL LOR(4,10,4) C** C** SET FINAL STATE MASSES AND ENERGIES IN CMS C** PV(5,1)=ABS(RMC) PV(5,2)=ABS(RMD) PV(7,1)=1. PV(7,2)=1. IF(RMC.LT.0.) PV(7,1)=-1. IF(RMD.LT.0.) PV(7,2)=-1. PV(4,1)=SQRT(PF*PF+PV(5,1)*PV(5,1)) PV(4,2)=SQRT(PF*PF+PV(5,2)*PV(5,2)) C** C** SET |T| AND |TMIN| C** CALL GRNDM(RNDM,2) CALL LENGTX(3,PIN) BTRANG=B*4.*PIN*PF C** C** SIMPLY A PROTECTION AGAINST EXPONENT OVERFLOW 1.E20 IS BIG ENOUGH C** EXINDT=-1. IF(BTRANG.LT.46) EXINDT=EXINDT+EXP(-BTRANG) TDN=LOG(1.+RNDM(1)*EXINDT)/BTRANG C** C** CACULATE (SIN(TETA/2.)**2 AND COS(TETA), SET AZIMUTH ANGLE PHI C** CTET=1.+2.*TDN IF(ABS(CTET).GT.1.) CTET=SIGN(1.,CTET) STET=SQRT((1.-CTET)*(1.+CTET)) PHI=RNDM(2)*TWPI C** C** CALCULATE FINAL STATE MOMENTA IN CMS C** PV(1,1)=PF*STET*SIN(PHI) PV(2,1)=PF*STET*COS(PHI) PV(3,1)=PF*CTET PV(1,2)=-PV(1,1) PV(2,2)=-PV(2,1) PV(3,2)=-PV(3,1) C** C** TRANSFORM INTO LAB C** DO 11 I=1,2 CALL LOR(I,4,I) CALL DEFS1(I,MXGKPV-1,I) IF(ATNO2.LT.1.5) GOTO 11 CALL LENGTX(I,PP) IF(PP.LT.0.001) GOTO 11 EKIN=PV(4,I)-ABS(PV(5,I)) CALL NORMAL(RAN) EKIN=EKIN-CFA*(1.+0.5*RAN) IF(EKIN.LT.0.0001) EKIN=0.0001 PP1=SQRT(EKIN*(EKIN+2.*ABS(PV(5,I)))) PV(4,I)=EKIN+ABS(PV(5,I)) PV(1,I)=PV(1,I)*PP1/PP PV(2,I)=PV(2,I)*PP1/PP PV(3,I)=PV(3,I)*PP1/PP 11 CONTINUE NT=2 C** C** ADD BLACK TRACK PARTICLES . C** HERE THE PROCEDURE IS SOMEWHAT DIFFERENT AS IN 'TWOCLU' AND 'GENXPT' C** THE REASON IS, THAT WE HAVE TO SIMULATE ALSO THE NUCLEAR REACTIONS C** AT LOW ENERGIES LIKE A(H,P)B, A(H,P P)B, A(H,N)B E.T.C. C** 200 IF(ENP(1).LE.0.0001.AND.ENP(3).LE.0.0001) GOTO 40 SPALL=0. TEX=ENP(1) IF(TEX.LT.0.0001) GOTO 445 BLACK=TEX/0.02 CALL POISSO(BLACK,NBL) IF(NBL.GT.ATNO2) NBL=ATNO2 IF(ENP(1).GT.0.0001.AND.NBL.LE.0) NBL=1 IF (NPRT(4)) WRITE(NEWBCD,3003) NBL,TEX IF(NT+NBL.GT.MXGKPV-2) NBL=MXGKPV-2-NT IF(NBL.LE.0) GOTO 445 EKIN=TEX/NBL EKIN2=0. CALL STEEP(XX) DO 441 I=1,NBL IF(NT.EQ.MXGKPV-2) GOTO 441 IF(EKIN2.GT.TEX) GOTO 443 CALL GRNDM(RNDM,1) RAN1=RNDM(1) CALL NORMAL(RAN2) EKIN1=-EKIN*LOG(RAN1)-CFA*(1.+0.5*RAN2) IF(EKIN1.LT.0.0) EKIN1=-0.010*LOG(RAN1) EKIN1=EKIN1*XX EKIN2=EKIN2+EKIN1 IF(EKIN2.GT.TEX) EKIN1=TEX-(EKIN2-EKIN1) IF(EKIN1.LT.0.) EKIN1=0.0001 IPA1=16 PNRAT=1.-ZNO2/ATNO2 CALL GRNDM(RNDM,3) IF(RNDM(1).GT.PNRAT) IPA1=14 NT=NT+1 SPALL=SPALL+1. COST=-1.+RNDM(2)*2. SINT=SQRT(ABS(1.-COST*COST)) PHI=TWPI*RNDM(3) IPA(NT)=-IPA1 PV(5,NT)=ABS(RMASS(IPA1)) PV(6,NT)=RCHARG(IPA1) PV(7,NT)=2. PV(4,NT)=EKIN1+PV(5,NT) PP=SQRT(ABS(PV(4,NT)**2-PV(5,NT)**2)) PV(1,NT)=PP*SINT*SIN(PHI) PV(2,NT)=PP*SINT*COS(PHI) PV(3,NT)=PP*COST 441 CONTINUE 443 IF(ATNO2.LT.10.) GOTO 445 IF(EK.GT.2.0) GOTO 445 II=NT+1 KK=0 EKA=EK IF(EKA.GT.1.) EKA=EKA*EKA IF(EKA.LT.0.1) EKA=0.1 IKA=3.6*EXP((ZNO2**2/ATNO2-35.56)/6.45)/EKA IF(IKA.LE.0) GO TO 445 DO 444 I=1,NT II=II-1 IF(IPA(II).NE.-14) GOTO 444 IPA(II)=-16 IPA1 = 16 PV(5,II)=ABS(RMASS(IPA1)) PV(6,II)=RCHARG(IPA1) KK=KK+1 IF(KK.GT.IKA) GOTO 445 444 CONTINUE 445 TEX=ENP(3) IF(TEX.LT.0.0001) GOTO 40 NBL=IFIX(2.*LOG(ATNO2)) IF(NT+NBL.GT.MXGKPV-2) NBL=MXGKPV-2-NT IF(NBL.LE.0) GOTO 40 EKIN=TEX/NBL EKIN2=0. CALL STEEP(XX) IF (NPRT(4)) WRITE(NEWBCD,3004) NBL,TEX DO 442 I=1,NBL IF(NT.EQ.MXGKPV-2) GOTO 442 IF(EKIN2.GT.TEX) GOTO 40 CALL GRNDM(RNDM,1) RAN1=RNDM(1) CALL NORMAL(RAN2) EKIN1=-EKIN*LOG(RAN1)-CFA*(1.+0.5*RAN2) IF(EKIN1.LT.0.0) EKIN1=-0.010*LOG(RAN1) EKIN1=EKIN1*XX EKIN2=EKIN2+EKIN1 IF(EKIN2.GT.TEX) EKIN1=TEX-(EKIN2-EKIN1) IF(EKIN1.LT.0.) EKIN1=0.0001 CALL GRNDM(RNDM,3) COST=-1.+RNDM(1)*2. SINT=SQRT(ABS(1.-COST*COST)) PHI=TWPI*RNDM(2) RAN=RNDM(3) IPA(NT+1)=-30 IF(RAN.GT.0.60) IPA(NT+1)=-31 IF(RAN.GT.0.90) IPA(NT+1)=-32 INVE=ABS(IPA(NT+1)) PV(5,NT+1)=RMASS(INVE) SPALL=SPALL+PV(5,NT+1)*1.066 IF(SPALL.GT.ATNO2) GOTO 40 NT=NT+1 PV(6,NT)=RCHARG(INVE) PV(7,NT)=2. PV(4,NT)=PV(5,NT)+EKIN1 PP=SQRT(ABS(PV(4,NT)**2-PV(5,NT)**2)) PV(1,NT)=PP*SINT*SIN(PHI) PV(2,NT)=PP*SINT*COS(PHI) PV(3,NT)=PP*COST 442 CONTINUE C** C** STORE ON EVENT COMMON C** 40 EKIN=PV(4,MXGKPV)-ABS(PV(5,MXGKPV)) EKIN1=PV(4,MXGKPV-1)-ABS(PV(5,MXGKPV-1)) EKIN2=0. CALL TDELAY(TOF1) CALL GRNDM(RNDM,1) RAN=RNDM(1) TOF=TOF-TOF1*LOG(RAN) DO 1 I=1,NT EKIN2=EKIN2+PV(4,I)-ABS(PV(5,I)) IF(PV(7,I).LT.0.) PV(5,I)=-PV(5,I) PV(7,I)=TOF PV(8,I)=ABS(IPA(I)) PV(9,I)=0. 1 PV(10,I)=0. IF (NPRT(4)) WRITE(NEWBCD,1003) NT,EKIN,EKIN1,EKIN2 INTCT=INTCT+1. CALL SETCUR(NT) NTK=NTK+1 IF(NT.EQ.1) GO TO 9999 DO 50 II=2,NT I=II-1 IF(NTOT.LT.NSIZE/12) GOTO 43 RETURN 43 CALL SETTRK(I) 50 CONTINUE C 1002 FORMAT(' *TWOB* ',5F10.4,10X,5F10.4/1H ,7X,5F10.4,10X,5F10.4/ $ ' LAB SYSTEM FINAL STATE FOUR VECTORS') 1003 FORMAT(' *TWOB* COMPARISON',2X,I5,2X,3F10.4) 4001 FORMAT(' *TWOB* ',10F10.4,2X,2I3) 4002 FORMAT(' *TWOB* ',7F10.4) 3003 FORMAT(' *TWOB* ',I3,' BLACK TRACK PARTICLES PRODUCED', $ ' WITH TOTAL KINETIC ENERGY OF ',F8.3,' GEV') 3004 FORMAT(' *TWOB* ',I5,' HEAVY FRAGMENTS PRODUCED', $ ' WITH TOTAL ENERGY OF',F8.4,' GEV') C 9999 CONTINUE C RETURN END *CMZ : 3.16/00 05/11/93 19.46.20 BY FEDERICO CARMINATI *-- AUTHOR : C--------------------------------------------------------------------- SUBROUTINE TWOCLU(IPPP,NFL,AVERN) C C *** GENERATION OF X- AND PT- VALUES FOR ALL PRODUCED PARTICLES *** C *** NVE 01-AUG-1988 CERN GENEVA *** C C ORIGIN : H.FESEFELDT (11-OCT-1987) C C A SIMPLE TWO CLUSTER MODEL IS USED C THIS SHOULD BE SUFFICIENT FOR LOW ENERGY INTERACTIONS C PARAMETER (MXGKGH=100) COMMON/CONSTS/ PI,TWPI,PIBTW,MP,MPI,MMU,MEL,MKCH,MK0,SMP,SMPI, $ SMU,CT,CTKCH,CTK0, $ ML0,MSP,MS0,MSM,MX0,MXM,CTL0,CTSP,CTSM,CTX0,CTXM, $ RMASS(35),RCHARG(35) C REAL MP,MPI,MMU,MEL,MKCH,MK0, * ML0,MSP,MS0,MSM,MX0,MXM C PARAMETER (MXGKCU=MXGKGH) COMMON/CURPAR/WEIGHT(10),DDELTN,IFILE,IRUN,NEVT,NEVENT,SHFLAG, * ITHST,ITTOT,ITLST,IFRND,TOFCUT,CMOM(5),CENG(5), * RS,S,ENP(10),NP,NM,NN,NR,NO,NZ,IPA(MXGKCU), * ATNO2,ZNO2 C COMMON/RESULT/XEND,YEND,ZEND,RCA,RCE,AMAS,NCH,TOF,PX,PY,PZ, * USERW,INTCT,P,EN,EK,AMASQ,DELTN,ITK,NTK,IPART,IND, * LCALO,ICEL,SINL,COSL,SINP,COSP, * XOLD,YOLD,ZOLD,POLD,PXOLD,PYOLD,PZOLD, * XSCAT,YSCAT,ZSCAT,PSCAT,PXSCAT,PYSCAT,PZSCAT REAL NCH,INTCT C COMMON/MAT / LMAT, * DEN(21),RADLTH(21),ATNO(21),ZNO(21),ABSL(21), * CDEN(21),MDEN(21),X0DEN(21),X1DEN(21),RION(21), * MATID(21),MATID1(21,24),PARMAT(21,10), * IFRAT,IFRAC(21),FRAC1(21,10),DEN1(21,10), * ATNO1(21,10),ZNO1(21,10) C PARAMETER (MXEVEN=12*MXGKGH) COMMON/EVENT / NSIZE,NCUR,NEXT,NTOT,EVE(MXEVEN) C COMMON/PRNTFL/INBCD,NEWBCD,INBIN,NEWBIN,NPEVT,NEVTP,LPRT,NPRT(10) LOGICAL LPRT,NPRT C COMMON/ERRCOM/ IER(100) C PARAMETER (MXGKPV=MXGKGH) COMMON /VECUTY/ PV(10,MXGKPV) C C COMMON/GENIN /TECM,AMASS(18),NPG,KGENEV COMMON/GENOUT/PCM(5,18),WGT C REAL NUCSUP DIMENSION SIDE(MXGKCU),C1PAR(5),G1PAR(5),NUCSUP(5) DIMENSION RNDM(3) SAVE DATA C1PAR/0.6,0.6,0.35,0.15,0.10/ DATA G1PAR/2.6,2.6,1.8,1.30,1.20/ DATA NUCSUP/1.0,0.8,0.6,0.5,0.4/ C DATA CB/3.0/ DATA CB/0.01/ C C BPP(X)=4.000+1.600*LOG(X) C MX =MXGKPV-20 MX1=MX+1 MX2=MX+2 MX3=MX+3 MX4=MX+4 MX5=MX+5 MX6=MX+6 MX7=MX+7 MX8=MX+8 EK=ENP(5) EN=ENP(6) P=ENP(7) S=ENP(8) RS=ENP(9) CFA=0.025*((ATNO2-1.)/120.)*EXP(-(ATNO2-1.)/120.) IF(P.LT.0.001) GOTO 60 NT=0 C** C** CHECK MASS-INDICES FOR ALL PARTICLES C** DO 1 I=1,100 IF(IPA(I).EQ.0) GOTO 1 NT=NT+1 IPA(NT)=IPA(I) 1 CONTINUE * CALL VZERO(IPA(NT+1),MXGKCU-NT) CDH DO III = NT+1, MXGKCU IPA(III) = 0 ENDDO C** C** SET THE EFFECTICE 4-MOMENTUM-VECTOR FOR INTERACTION C** PV( 1,MXGKPV-1)=P*PX PV( 2,MXGKPV-1)=P*PY PV( 3,MXGKPV-1)=P*PZ PV( 4,MXGKPV-1)=EN PV( 5,MXGKPV-1)=AMAS PV( 6,MXGKPV-1)=NCH PV( 7,MXGKPV-1)=TOF PV( 8,MXGKPV-1)=IPART PV( 9,MXGKPV-1)=0. PV(10,MXGKPV-1)=USERW IER(48)=IER(48)+1 C** C** DISTRIBUTE PARTICLES IN FORWARD AND BACKWARD HEMISPHERE OF CMS C** OF THE HADRON NUCLEON INTERACTION C** SIDE(1)= 1. SIDE(2)=-1. TARG=0. IFOR=1 IBACK=1 DO 3 I=1,NT IF (I .LE. 2) GO TO 78 SIDE(I)=1. CALL GRNDM(RNDM,1) IF (RNDM(1) .LT. 0.5) SIDE(I)=-1. IF (SIDE(I) .LT. 0.) GO TO 76 C C --- PARTICLE IN FORWARD HEMISPHERE --- 77 CONTINUE IFOR=IFOR+1 IF (IFOR .LE. 18) GO TO 78 C C --- CHANGE IT TO BACKWARD --- SIDE(I)=-1. IFOR=IFOR-1 IBACK=IBACK+1 GO TO 78 C C --- PARTICLE IN BACKWARD HEMISPHERE --- 76 CONTINUE IBACK=IBACK+1 IF (IBACK .LE. 18) GO TO 78 C C --- CHANGE IT TO FORWARD --- SIDE(I)=1. IBACK=IBACK-1 IFOR=IFOR+1 C** C** SUPPRESSION OF CHARGED PIONS FOR VARIOUS REASONS C** 78 IF(IPART.EQ.15.OR.IPART.GE.17) GOTO 3 IF(ABS(IPA(I)).GE.10) GOTO 3 IF(ABS(IPA(I)).EQ. 8) GOTO 3 CALL GRNDM(RNDM,1) IF(RNDM(1).GT.(10.-P)/6.) GOTO 3 CALL GRNDM(RNDM,1) IF(RNDM(1).GT.ATNO2/300.) GOTO 3 IPA(I)=14 CALL GRNDM(RNDM,1) IF(RNDM(1).GT.ZNO2/ATNO2) IPA(I)=16 TARG=TARG+1. 3 CONTINUE TB=2.*IBACK CALL GRNDM(RNDM,1) IF(RS.LT.(2.0+RNDM(1))) TB=(2.*IBACK+NT)/2. C** C** NUCLEONS + SOME PIONS FROM INTRANUCLEAR CASCADE C** AFC=0.312+0.200*LOG(LOG(S)) XTARG=AFC*(ATNO2**0.33-1.0)*TB IF(XTARG.LE.0.) XTARG=0.01 CALL POISSO(XTARG,NTARG) NT2=NT+NTARG IF(NT2.LE.MXGKPV-30) GOTO 2 NT2=MXGKPV-30 NTARG=NT2-NT 2 CONTINUE IF(NPRT(4)) *WRITE(NEWBCD,3001) NTARG,NT NT1=NT+1 IF(NTARG.EQ.0) GOTO 51 IPX=IFIX(P/3.)+1 IF(IPX.GT.5) IPX=5 DO 4 I=NT1,NT2 CALL GRNDM(RNDM,1) RAN=RNDM(1) IF(RAN.LT.NUCSUP(IPX)) GOTO 52 CALL GRNDM(RNDM,1) IPA(I)=-(7+IFIX(RNDM(1)*3.0)) GOTO 4 52 IPA(I)=-16 PNRAT=1.-ZNO2/ATNO2 CALL GRNDM(RNDM,1) IF(RNDM(1).GT.PNRAT) IPA(I)=-14 TARG=TARG+1. 4 SIDE(I)=-2. NT=NT2 C** C** CHOOSE MASSES AND CHARGES FOR ALL PARTICLES C** 51 DO 5 I=1,NT IPA1=ABS(IPA(I)) PV(5,I)=RMASS(IPA1) PV(6,I)=RCHARG(IPA1) PV(7,I)=1. IF(PV(5,I).LT.0.) PV(7,I)=-1. PV(5,I)=ABS(PV(5,I)) 5 CONTINUE C** C** MARK LEADING STRANGE PARTICLES C** LEAD=0 IF(IPART.LT.10.OR.IPART.EQ.14.OR.IPART.EQ.16) GOTO 6 IPA1=ABS(IPA(1)) IF(IPA1.LT.10.OR.IPA1.EQ.14.OR.IPA1.EQ.16) GOTO 531 LEAD=IPA1 GOTO 6 531 IPA1=ABS(IPA(2)) IF(IPA1.LT.10.OR.IPA1.EQ.14.OR.IPA1.EQ.16) GOTO 6 LEAD=IPA1 C** C** CHECK AVAILABLE KINETIC ENERGY , CHANGE HEMISPHERE FOR PARTICLES C** UNTIL IT FITS C** 6 IF(NT.LE.1) GOTO 60 TAVAI=0. DO 7 I=1,NT IF(SIDE(I).LT.-1.5) GOTO 7 TAVAI=TAVAI+ABS(PV(5,I)) 7 CONTINUE CJOK MODIFIED ACCORDING TO D.HECK IF(TAVAI.LT.RS-0.00001) GOTO 12 IF(NPRT(4)) $ WRITE(NEWBCD,3002) (IPA(I),I=1,20),(SIDE(I),I=1,20),TAVAI,RS 3002 FORMAT(' *TWOCLU* CHECK AVAILABLE ENERGIES'/ $ 1H ,20I5/1H ,20F5.0/1H ,'TAVAI,RS ',2F10.3) DO 10 I=1,NT II=NT-I+1 IF(SIDE(II).LT.-1.5) GOTO 10 IF(II.EQ.NT) GOTO 11 NT1=II+1 NT2=NT DO 8 J=NT1,NT2 IPA(J-1)=IPA(J) SIDE(J-1)=SIDE(J) DO 8 K=1,10 8 PV(K,J-1)=PV(K,J) GOTO 11 10 CONTINUE 11 SIDE(NT)=0. IPA(NT)=0 NT=NT-1 GOTO 6 12 IF(NT.LE.1) GOTO 60 B=BPP(P) IF(B.LT.CB) B=CB C** C** CHOOSE MASSES FOR THE 3 CLUSTER: 1. FORWARD CLUSTER C** 2. BACKWARD MESON CLUSTER 3. BACKWARD NUCLEON CLUSTER C** RMC0=0. RMD0=0. RME0=0. NTC=0 NTD=0 NTE=0 DO 31 I=1,NT IF(SIDE(I).GT.0.) RMC0=RMC0+ABS(PV(5,I)) IF(SIDE(I).GT.0.) NTC =NTC +1 IF(SIDE(I).LT.0..AND.SIDE(I).GT.-1.5) RMD0=RMD0+ABS(PV(5,I)) IF( SIDE(I).LT.-1.5) RME0=RME0+ABS(PV(5,I)) IF(SIDE(I).LT.0..AND.SIDE(I).GT.-1.5) NTD =NTD +1 IF( SIDE(I).LT.-1.5) NTE =NTE +1 31 CONTINUE 32 CALL GRNDM(RNDM,1) RAN=RNDM(1) RMC=RMC0 IF(NTC.LE.1) GOTO 33 NTC1=NTC IF(NTC1.GT.5) NTC1=5 RMC=-LOG(1.-RAN) GPAR=G1PAR(NTC1) CPAR=C1PAR(NTC1) DUMNVE=GPAR IF (DUMNVE .EQ. 0.0) DUMNVE=1.0E-10 RMC=RMC0+RMC**CPAR/DUMNVE 33 RMD=RMD0 IF(NTD.LE.1) GOTO 34 NTD1=NTD IF(NTD1.GT.5) NTD1=5 CALL GRNDM(RNDM,1) RAN=RNDM(1) RMD=-LOG(1.-RAN) GPAR=G1PAR(NTD1) CPAR=C1PAR(NTD1) DUMNVE=GPAR IF (DUMNVE .EQ. 0.0) DUMNVE=1.0E-10 RMD=RMD0+RMD**CPAR/DUMNVE 34 IF(RMC+RMD.LE.RS) GOTO 35 IF (RMC.LE.RMC0.AND.RMD.LE.RMD0) THEN HNRMDC = 0.999*RS/(RMC+RMD) RMD = RMD*HNRMDC RMC = RMC*HNRMDC ELSE RMC=0.1*RMC0+0.9*RMC RMD=0.1*RMD0+0.9*RMD ENDIF GOTO 34 35 CONTINUE IF(NTE.LE.0) GOTO 38 RME=RME0 IF(NTE.EQ.1) GOTO 38 NTE1=NTE IF(NTE1.GT.5) NTE1=5 CALL GRNDM(RNDM,1) RAN=RNDM(1) RME=-LOG(1.-RAN) GPAR=G1PAR(NTE1) CPAR=C1PAR(NTE1) DUMNVE=GPAR IF (DUMNVE .EQ. 0.0) DUMNVE=1.0E-10 RME=RME0+RME**CPAR/DUMNVE C** C** SET BEAM , TARGET OF FIRST INTERACTION IN CMS C** 38 PV( 1,MX1) =0. PV( 2,MX1) =0. PV( 3,MX1) =P PV( 5,MX1) =ABS(AMAS) PV( 4,MX1) =SQRT(P*P+AMAS*AMAS) PV( 1,MX2) =0. PV( 2,MX2) =0. PV( 3,MX2) =0. PV( 4,MX2) =MP PV( 5,MX2) =MP C** TRANSFORM INTO CMS. CALL ADD(MX1,MX2,MX) CALL LOR(MX1,MX,MX1) CALL LOR(MX2,MX,MX2) PF=(S+RMD*RMD-RMC*RMC)**2 - 4*S*RMD*RMD IF(PF.LT.0.0001) PF=0.0001 DUMNVE=2.0*RS IF (DUMNVE .EQ. 0.0) DUMNVE=1.0E-10 PF=SQRT(PF)/DUMNVE IF(NPRT(4)) WRITE(6,2002) PF,RMC,RMD,RS C** C** SET FINAL STATE MASSES AND ENERGIES IN CMS C** PV(5,MX3) =RMC PV(5,MX4) =RMD PV(4,MX3) =SQRT(PF*PF+RMC*RMC) PV(4,MX4) =SQRT(PF*PF+RMD*RMD) C** C** SET |T| AND |TMIN| C** T=-1.0E10 CALL GRNDM(RNDM,1) IF (B .NE. 0.0) T=LOG(1.-RNDM(1))/B CALL LENGTX(MX1,PIN) TACMIN=(PV(4,MX1) -PV(4,MX3))**2 -(PIN-PF)**2 C** C** CACULATE (SIN(TETA/2.)**2 AND COS(TETA), SET AZIMUTH ANGLE PHI C** DUMNVE=4.0*PIN*PF IF (DUMNVE .EQ. 0.0) DUMNVE=1.0E-10 CTET=-(T-TACMIN)/DUMNVE CTET=1.0-2.0*CTET IF (CTET .GT. 1.0) CTET=1.0 IF (CTET .LT. -1.0) CTET=-1.0 DUMNVE=1.0-CTET*CTET IF (DUMNVE .LT. 0.0) DUMNVE=0.0 STET=SQRT(DUMNVE) CALL GRNDM(RNDM,1) PHI=RNDM(1)*TWPI C** C** CALCULATE FINAL STATE MOMENTA IN CMS C** PV(1,MX3) =PF*STET*SIN(PHI) PV(2,MX3) =PF*STET*COS(PHI) PV(3,MX3) =PF*CTET PV(1,MX4) =-PV(1,MX3) PV(2,MX4) =-PV(2,MX3) PV(3,MX4) =-PV(3,MX3) C** C** SIMULATE BACKWARD NUCLEON CLUSTER IN LAB. SYSTEM AND TRANSFORM IN C** CMS. C** IF(NTE.EQ.0) GOTO 28 GA=1.2 EKIT1=0.04 EKIT2=0.6 IF(EK.GT.5.) GOTO 666 EKIT1=EKIT1*EK**2/25. EKIT2=EKIT2*EK**2/25. 666 A=(1.-GA)/(EKIT2**(1.-GA)-EKIT1**(1.-GA)) DO 29 I=1,NT IF(SIDE(I).GT.-1.5) GOTO 29 CALL GRNDM(RNDM,3) RAN=RNDM(1) EKIT=(RAN*(1.-GA)/A+EKIT1**(1.-GA))**(1./(1.-GA)) PV(4,I)=EKIT+PV(5,I) DUMNVE=ABS(PV(4,I)**2-PV(5,I)**2) PP=SQRT(DUMNVE) RAN=RNDM(2) COST=LOG(2.23*RAN+0.383)/0.96 IF (COST .LT. -1.0) COST=-1.0 IF (COST .GT. 1.0) COST=1.0 DUMNVE=1.0-COST*COST IF (DUMNVE .LT. 0.0) DUMNVE=0.0 SINT=SQRT(DUMNVE) PHI=TWPI*RNDM(3) PV(1,I)=PP*SINT*SIN(PHI) PV(2,I)=PP*SINT*COS(PHI) PV(3,I)=PP*COST CALL LOR(I,MX,I) 29 CONTINUE C** C** FRAGMENTATION OF FORWARD CLUSTER AND BACKWARD MESON CLUSTER C** 28 PV(1,1)=PV(1,MX3) PV(2,1)=PV(2,MX3) PV(3,1)=PV(3,MX3) PV(4,1)=PV(4,MX3) PV(1,2)=PV(1,MX4) PV(2,2)=PV(2,MX4) PV(3,2)=PV(3,MX4) PV(4,2)=PV(4,MX4) DO 17 I=MX5,MX6 DO 16 J=1,3 16 PV(J,I)=-PV(J,I-2) DO 17 J=4,5 17 PV(J,I)= PV(J,I-2) KGENEV=1 IF(NTC.LE.1) GOTO 26 TECM=PV(5,MX3) NPG=0 DO 18 I=1,NT IF(SIDE(I).LT.0.) GOTO 18 IF(NPG.EQ.18) THEN SIDE(I)=-SIDE(I) GOTO 18 ENDIF NPG=NPG+1 AMASS(NPG)=ABS(PV(5,I)) 18 CONTINUE IF(NPRT(4)) WRITE(NEWBCD,2004) TECM,NPG,(AMASS(I),I=1,NPG) CALL PHASP NPG=0 DO 19 I=1,NT IF(SIDE(I).LT.0.) GOTO 19 NPG=NPG+1 PV(1,I)=PCM(1,NPG) PV(2,I)=PCM(2,NPG) PV(3,I)=PCM(3,NPG) PV(4,I)=PCM(4,NPG) IF(NPRT(4)) WRITE(NEWBCD,2001) I,(PV(J,I),J=1,5) CALL LOR(I,MX5,I) IF(NPRT(4)) WRITE(NEWBCD,2001) I,(PV(J,I),J=1,10),IPA(I),SIDE(I) 19 CONTINUE 26 IF(NTD.LE.1) GOTO 27 TECM=PV(5,MX4) NPG=0 DO 20 I=1,NT IF(SIDE(I).GT.0..OR.SIDE(I).LT.-1.5) GOTO 20 IF(NPG.EQ.18) THEN SIDE(I)=-2. PV(4,I)=ABS(PV(5,I)) DO 24 J=1,3 PV(J,I)=0. 24 CONTINUE GOTO 20 ENDIF NPG=NPG+1 AMASS(NPG)=ABS(PV(5,I)) 20 CONTINUE IF(NPRT(4)) WRITE(NEWBCD,2004) TECM,NPG,(AMASS(I),I=1,NPG) CALL PHASP NPG=0 DO 21 I=1,NT IF(SIDE(I).GT.0..OR.SIDE(I).LT.-1.5) GOTO 21 NPG=NPG+1 PV(1,I)=PCM(1,NPG) PV(2,I)=PCM(2,NPG) PV(3,I)=PCM(3,NPG) PV(4,I)=PCM(4,NPG) IF(NPRT(4)) WRITE(NEWBCD,2001) I,(PV(J,I),J=1,5) CALL LOR(I,MX6,I) IF(NPRT(4)) WRITE(NEWBCD,2001) I,(PV(J,I),J=1,10),IPA(I),SIDE(I) 21 CONTINUE C** C** LORENTZ TRANSFORMATION IN LAB SYSTEM C** 27 TARG=0. DO 36 I=1,NT IF(PV(5,I).GT.0.5) TARG=TARG+1. CALL LOR(I,MX2,I) 36 CONTINUE IF(TARG.LT.0.5) TARG=1. C** C** SOMETIMES THE LEADING STRANGE PARTICLES ARE LOST , SET THEM BACK C** IF(LEAD.EQ.0) GOTO 6085 DO 6081 I=1,NT IF(ABS(IPA(I)).EQ.LEAD) GOTO 6085 6081 CONTINUE I=1 IF(LEAD.GE.14.AND.ABS(IPA(2)).GE.14) I=2 IF(LEAD.LT.14.AND.ABS(IPA(2)).LT.14) I=2 IPA(I)=LEAD EKIN=PV(4,I)-ABS(PV(5,I)) PV(5,I)=RMASS(LEAD) PV(7,I)=1. IF(PV(5,I).LT.0.) PV(7,I)=-1. PV(5,I)=ABS(PV(5,I)) PV(6,I)=RCHARG(LEAD) PV(4,I)=PV(5,I)+EKIN CALL LENGTX(I,PP) DUMNVE=ABS(PV(4,I)**2-PV(5,I)**2) PP1=SQRT(DUMNVE) C IF (PP .GE. 1.0E-6) GO TO 8000 CALL GRNDM(RNDM,2) RTHNVE=PI*RNDM(1) PHINVE=TWPI*RNDM(2) PV(1,I)=PP1*SIN(RTHNVE)*COS(PHINVE) PV(2,I)=PP1*SIN(RTHNVE)*SIN(PHINVE) PV(3,I)=PP1*COS(RTHNVE) GO TO 8001 8000 CONTINUE PV(1,I)=PV(1,I)*PP1/PP PV(2,I)=PV(2,I)*PP1/PP PV(3,I)=PV(3,I)*PP1/PP 8001 CONTINUE C C** FOR VARIOUS REASONS, THE ENERGY BALANCE IS NOT SUFFICIENT, C** CHECK THAT, ENERGY BALANCE, ANGLE OF FINAL SYSTEM E.T.C. 6085 KGENEV=1 PV(1,MX4) =0. PV(2,MX4) =0. PV(3,MX4) =P PV(4,MX4) =SQRT(P*P+AMAS*AMAS) PV(5,MX4) =ABS(AMAS) EKIN0=PV(4,MX4) -PV(5,MX4) PV(1,MX5) =0. PV(2,MX5) =0. PV(3,MX5) =0. PV(4,MX5) =MP*TARG PV(5,MX5) =PV(4,MX5) EKIN=PV(4,MX4) +PV(4,MX5) I=MX4 IF(NPRT(4)) WRITE(NEWBCD,2001) I,(PV(J,I),J=1,5) I=MX5 IF(NPRT(4)) WRITE(NEWBCD,2001) I,(PV(J,I),J=1,5) CALL ADD(MX4,MX5,MX6) CALL LOR(MX4,MX6,MX4) CALL LOR(MX5,MX6,MX5) TECM=PV(4,MX4) +PV(4,MX5) NPG=NT PV(1,MX8) =0. PV(2,MX8) =0. PV(3,MX8) =0. PV(4,MX8) =0. PV(5,MX8) =0. EKIN1=0. DO 598 I=1,NPG IF(NPRT(4)) WRITE(NEWBCD,2001) I,(PV(J,I),J=1,10),IPA(I),SIDE(I) CALL ADD(MX8,I,MX8) EKIN1=EKIN1+PV(4,I)-PV(5,I) EKIN=EKIN-PV(5,I) IF(I.GT.18) GOTO 598 AMASS(I)=PV(5,I) 598 CONTINUE IF(NPG.GT.18) GOTO 597 CALL PHASP EKIN=0. DO 599 I=1,NPG PV(1,MX7)=PCM(1,I) PV(2,MX7)=PCM(2,I) PV(3,MX7)=PCM(3,I) PV(4,MX7)=PCM(4,I) PV(5,MX7)=AMASS(I) CALL LOR(MX7,MX5,MX7) 599 EKIN=EKIN+PV(4,MX7)-PV(5,MX7) CALL ANG(MX8,MX4,COST,TETA) IF(NPRT(4)) WRITE(NEWBCD,2003) TETA,EKIN0,EKIN1,EKIN C** C** MAKE SHURE, THAT KINETIC ENERGIES ARE CORRECT C** THE 3. CLUSTER IS NOT PRODUCED WITHIN PROPER KINEMATICS!!! C** EKIN= KINETIC ENERGY THEORETICALLY C** EKIN1= KINETIC ENERGY SIMULATED C** 597 IF(EKIN1.EQ.0.) GOTO 600 PV(1,MX7) =0. PV(2,MX7) =0. PV(3,MX7) =0. PV(4,MX7) =0. PV(5,MX7) =0. WGT=EKIN/EKIN1 EKIN1=0. DO 602 I=1,NT EKIN=PV(4,I)-PV(5,I) EKIN=EKIN*WGT PV(4,I)=EKIN+PV(5,I) DUMNVE=ABS(PV(4,I)**2-PV(5,I)**2) PP=SQRT(DUMNVE) CALL LENGTX(I,PP1) C IF (PP1 .GE. 1.0E-6) GO TO 8002 CALL GRNDM(RNDM,2) RTHNVE=PI*RNDM(1) PHINVE=TWPI*RNDM(2) PV(1,I)=PP*SIN(RTHNVE)*COS(PHINVE) PV(2,I)=PP*SIN(RTHNVE)*SIN(PHINVE) PV(3,I)=PP*COS(RTHNVE) GO TO 8003 8002 CONTINUE PV(1,I)=PV(1,I)*PP/PP1 PV(2,I)=PV(2,I)*PP/PP1 PV(3,I)=PV(3,I)*PP/PP1 8003 CONTINUE C EKIN1=EKIN1+EKIN CALL ADD(MX7,I,MX7) 602 CONTINUE CALL ANG(MX7,MX4,COST,TETA) IF(NPRT(4)) WRITE(NEWBCD,2003) TETA,EKIN0,EKIN1 C** C** ROTATE IN DIRECTION OF Z-AXIS, SEE COMMENTS IN 'GENXPT' C** 600 PV(1,MX7)=0. PV(2,MX7)=0. PV(3,MX7)=0. PV(4,MX7)=0. PV(5,MX7)=0. DO 596 I=1,NT CALL ADD(MX7,I,MX7) 596 CONTINUE * CALL RANNOR(RAN1,RAN2) CALL GRNDM(RNDM,2) RY=RNDM(1) RZ=RNDM(2) RX=6.283185*RZ A1=SQRT(-2.*LOG(RY)) RAN1=A1*SIN(RX) RAN2=A1*COS(RX) PV(1,MX7)=PV(1,MX7)+RAN1*0.020*TARG PV(2,MX7)=PV(2,MX7)+RAN2*0.020*TARG CALL DEFS(MX4,MX7,MX8) PV(1,MX7)=0. PV(2,MX7)=0. PV(3,MX7)=0. PV(4,MX7)=0. PV(5,MX7)=0. DO 595 I=1,NT CALL TRAC(I,MX8,I) CALL ADD(MX7,I,MX7) 595 CONTINUE CALL ANG(MX7,MX4,COST,TETA) IF(NPRT(4)) WRITE(NEWBCD,2003) TETA C** C** ROTATE IN DIRECTION OF PRIMARY PARTICLE C** DEKIN=0. NPIONS=0 EK1=0. DO 25 I=1,NT CALL DEFS1(I,MXGKPV-1,I) IF(NPRT(4)) WRITE(NEWBCD,2001) I,(PV(J,I),J=1,10),IPA(I),SIDE(I) IF(ATNO2.LT.1.5) GOTO 25 CALL LENGTX(I,PP) EKIN=PV(4,I)-ABS(PV(5,I)) CALL NORMAL(RAN) EKIN=EKIN-CFA*(1.+0.5*RAN) IF (EKIN .LT. 1.0E-6) EKIN=1.0E-6 CALL STEEQ(XXH,I) DEKIN=DEKIN+EKIN*(1.-XXH) EKIN=EKIN*XXH IF(ABS(IPA(I)).GE.7.AND.ABS(IPA(I)).LE.9) NPIONS=NPIONS+1 IF(ABS(IPA(I)).GE.7.AND.ABS(IPA(I)).LE.9) EK1=EK1+EKIN PP1=SQRT(EKIN*(EKIN+2.*ABS(PV(5,I)))) PV(4,I)=EKIN+ABS(PV(5,I)) C IF (PP .GE. 1.0E-6) GO TO 8004 CALL GRNDM(RNDM,2) RTHNVE=PI*RNDM(1) PHINVE=TWPI*RNDM(2) PV(1,I)=PP1*SIN(RTHNVE)*COS(PHINVE) PV(2,I)=PP1*SIN(RTHNVE)*SIN(PHINVE) PV(3,I)=PP1*COS(RTHNVE) GO TO 8005 8004 CONTINUE PV(1,I)=PV(1,I)*PP1/PP PV(2,I)=PV(2,I)*PP1/PP PV(3,I)=PV(3,I)*PP1/PP 8005 CONTINUE C 25 CONTINUE IF(EK1.EQ.0.) GOTO 23 IF(NPIONS.LE.0) GOTO 23 DEKIN=1.+DEKIN/EK1 DO 22 I=1,NT IF(ABS(IPA(I)).LT.7.OR.ABS(IPA(I)).GT.9) GOTO 22 CALL LENGTX(I,PP) EKIN=PV(4,I)-ABS(PV(5,I)) EKIN=EKIN*DEKIN IF (EKIN .LT. 1.0E-6) EKIN=1.0E-6 PP1=SQRT(EKIN*(EKIN+2.*ABS(PV(5,I)))) PV(4,I)=EKIN+ABS(PV(5,I)) C IF (PP .GE. 1.0E-6) GO TO 8006 CALL GRNDM(RNDM,2) RTHNVE=PI*RNDM(1) PHINVE=TWPI*RNDM(2) PV(1,I)=PP1*SIN(RTHNVE)*COS(PHINVE) PV(2,I)=PP1*SIN(RTHNVE)*SIN(PHINVE) PV(3,I)=PP1*COS(RTHNVE) GO TO 8007 8006 CONTINUE PV(1,I)=PV(1,I)*PP1/PP PV(2,I)=PV(2,I)*PP1/PP PV(3,I)=PV(3,I)*PP1/PP 8007 CONTINUE C 22 CONTINUE 23 IF(ATNO2.LT.1.5) GOTO 40 C** C** ADD BLACK TRACK PARTICLES C** CALL SELFAB(SPROB) TEX=ENP(1) SPALL=TARG IF(TEX.LT.0.001) GOTO 445 BLACK=(1.5+1.25*TARG)*ENP(1)/(ENP(1)+ENP(3)) CALL POISSO(BLACK,NBL) IF(NPRT(4)) *WRITE(NEWBCD,3003) NBL,TEX IF(IFIX(TARG)+NBL.GT.ATNO2) NBL=ATNO2-TARG IF(NT+NBL.GT.MXGKPV-2) NBL=MXGKPV-2-NT IF(NBL.LE.0) GOTO 445 EKIN=TEX/NBL EKIN2=0. CALL STEEP(XX) DO 441 I=1,NBL CALL GRNDM(RNDM,1) IF(RNDM(1).LT.SPROB) GOTO 441 IF(NT.EQ.MXGKPV-2) GOTO 441 IF(EKIN2.GT.TEX) GOTO 443 CALL GRNDM(RNDM,1) RAN1=RNDM(1) CALL NORMAL(RAN2) EKIN1=-EKIN*LOG(RAN1)-CFA*(1.+0.5*RAN2) IF(EKIN1.LT.0.0) EKIN1=-0.010*LOG(RAN1) EKIN1=EKIN1*XX EKIN2=EKIN2+EKIN1 IF(EKIN2.GT.TEX) EKIN1=TEX-(EKIN2-EKIN1) IF (EKIN1 .LT. 0.0) EKIN1=1.0E-6 IPA1=16 PNRAT=1.-ZNO2/ATNO2 CALL GRNDM(RNDM,3) IF(RNDM(1).GT.PNRAT) IPA1=14 NT=NT+1 SPALL=SPALL+1. COST=-1.0+RNDM(2)*2.0 DUMNVE=1.0-COST*COST IF (DUMNVE .LT. 0.0) DUMNVE=0.0 SINT=SQRT(DUMNVE) PHI=TWPI*RNDM(3) IPA(NT)=-IPA1 SIDE(NT)=-4. PV(5,NT)=ABS(RMASS(IPA1)) PV(6,NT)=RCHARG(IPA1) PV(7,NT)=1. PV(4,NT)=EKIN1+PV(5,NT) DUMNVE=ABS(PV(4,NT)**2-PV(5,NT)**2) PP=SQRT(DUMNVE) PV(1,NT)=PP*SINT*SIN(PHI) PV(2,NT)=PP*SINT*COS(PHI) PV(3,NT)=PP*COST 441 CONTINUE 443 IF(ATNO2.LT.10.) GOTO 445 IF(EK.GT.2.0) GOTO 445 II=NT+1 KK=0 EKA=EK IF(EKA.GT.1.) EKA=EKA*EKA IF(EKA.LT.0.1) EKA=0.1 IKA=3.6*EXP((ZNO2**2/ATNO2-35.56)/6.45)/EKA IF(IKA.LE.0) GO TO 445 DO 444 I=1,NT II=II-1 IF(IPA(II).NE.-14) GOTO 444 IPA(II)=-16 IPA1 = 16 PV(5,II)=ABS(RMASS(IPA1)) PV(6,II)=RCHARG(IPA1) KK=KK+1 IF(KK.GT.IKA) GOTO 445 444 CONTINUE 445 TEX=ENP(3) IF(TEX.LT.0.001) GOTO 40 BLACK=(1.5+1.25*TARG)*ENP(3)/(ENP(1)+ENP(3)) CALL POISSO(BLACK,NBL) IF(NT+NBL.GT.MXGKPV-2) NBL=MXGKPV-2-NT IF(NBL.LE.0) GOTO 40 EKIN=TEX/NBL EKIN2=0. CALL STEEP(XX) IF(NPRT(4)) *WRITE(NEWBCD,3004) NBL,TEX DO 442 I=1,NBL CALL GRNDM(RNDM,1) IF(RNDM(1).LT.SPROB) GOTO 442 IF(NT.EQ.MXGKPV-2) GOTO 442 IF(EKIN2.GT.TEX) GOTO 40 CALL GRNDM(RNDM,1) RAN1=RNDM(1) CALL NORMAL(RAN2) EKIN1=-EKIN*LOG(RAN1)-CFA*(1.+0.5*RAN2) IF(EKIN1.LT.0.0) EKIN1=-0.005*LOG(RAN1) EKIN1=EKIN1*XX EKIN2=EKIN2+EKIN1 IF(EKIN2.GT.TEX) EKIN1=TEX-(EKIN2-EKIN1) IF (EKIN1 .LT. 0.0) EKIN1=1.0E-6 CALL GRNDM(RNDM,3) COST=-1.0+RNDM(1)*2.0 DUMNVE=1.0-COST*COST IF (DUMNVE .LT. 0.0) DUMNVE=0.0 SINT=SQRT(DUMNVE) PHI=TWPI*RNDM(2) RAN=RNDM(3) IPA(NT+1)=-30 IF(RAN.GT.0.60) IPA(NT+1)=-31 IF(RAN.GT.0.90) IPA(NT+1)=-32 SIDE(NT+1)=-4. PV(5,NT+1)=(ABS(IPA(NT+1))-28)*MP SPALL=SPALL+PV(5,NT+1)*1.066 IF(SPALL.GT.ATNO2) GOTO 40 NT=NT+1 PV(6,NT)=1. IF(IPA(NT).EQ.-32) PV(6,NT)=2. PV(7,NT)=1. PV(4,NT)=PV(5,NT)+EKIN1 DUMNVE=ABS(PV(4,NT)**2-PV(5,NT)**2) PP=SQRT(DUMNVE) PV(1,NT)=PP*SINT*SIN(PHI) PV(2,NT)=PP*SINT*COS(PHI) PV(3,NT)=PP*COST 442 CONTINUE C** C** STORE ON EVENT COMMON C** 40 CALL GRNDM(RNDM,1) IF(RS.GT.(4.+RNDM(1)*1.)) GOTO 42 DO 41 I=1,NT CALL LENGTX(I,ETB) IF(ETB.LT.P) GOTO 41 ETF=P PV(4,I)=SQRT(PV(5,I)**2+ETF**2) DUMNVE=ETB IF (DUMNVE .EQ. 0.0) DUMNVE=1.0E-10 ETF=ETF/DUMNVE PV(1,I)=PV(1,I)*ETF PV(2,I)=PV(2,I)*ETF PV(3,I)=PV(3,I)*ETF 41 CONTINUE 42 EKIN=PV(4,MXGKPV)-ABS(PV(5,MXGKPV)) EKIN1=PV(4,MXGKPV-1)-ABS(PV(5,MXGKPV-1)) EKIN2=0. CALL TDELAY(TOF1) CALL GRNDM(RNDM,1) RAN=RNDM(1) TOF=TOF-TOF1*LOG(RAN) DO 44 I=1,NT EKIN2=EKIN2+PV(4,I)-ABS(PV(5,I)) IF(PV(7,I).LT.0.) PV(5,I)=-PV(5,I) PV(7,I)=TOF PV(8,I)=ABS(IPA(I)) PV(9,I)=0. 44 PV(10,I)=0. IF(NPRT(4)) WRITE(NEWBCD,2006) NT,EKIN,ENP(1),ENP(3),EKIN1,EKIN2 INTCT=INTCT+1. CALL SETCUR(NT) NTK=NTK+1 IF(NT.EQ.1) GOTO 300 DO 50 II=2,NT I=II-1 IF(NTOT.LT.NSIZE/12) GOTO 43 GO TO 9999 43 CALL SETTRK(I) 50 CONTINUE 300 CONTINUE GO TO 9999 C** C** IT IS NOT POSSIBLE TO PRODUCE A PROPER TWO CLUSTER FINAL STATE. C** CONTINUE WITH QUASI ELASTIC SCATTERING C** 60 IF(NPRT(4)) WRITE(NEWBCD,2005) DO 61 I=3,MXGKCU 61 IPA(I)=0 IPA(1)=IPART IPA(2)=14 IF(NFL.EQ.2) IPA(2)=16 CALL TWOB(IPPP,NFL,AVERN) GO TO 9999 C 2000 FORMAT(' *TWOCLU* CMS PARAMETERS OF FINAL STATE PARTICLES', $ ' AFTER ',I3,' TRIALS') 2001 FORMAT(' *TWOCLU* TRACK',2X,I3,2X,10F8.2,2X,I3,2X,F3.0) 2002 FORMAT(' *TWOCLU* MOMENTUM ',F8.3,' MASSES ',2F8.4,' RS ',F8.4) 2003 FORMAT(' *TWOCLU* TETA,EKIN0,EKIN1,EKIN ',4F10.4) 2004 FORMAT(' *TWOCLU* TECM,NPB,MASSES: ',F10.4,1X,I3,1X,8F10.4/ $ 1H ,26X,15X,8F10.4) 2005 FORMAT(' *TWOCLU* NUMBER OF FINAL STATE PARTICLES', $ ' LESS THAN 2 ==> CONTINUE WITH 2-BODY SCATTERING') 2006 FORMAT(' *TWOCLU* COMP.',1X,I5,1X,5F7.2) 3001 FORMAT(' *TWOCLU* NUCLEAR EXCITATION ',I5,' PARTICLES PRODUCED', $ ' IN ADDITION TO',I5,' NORMAL PARTICLES') 3003 FORMAT(' *TWOCLU* ',I3,' BLACK TRACK PARTICLES PRODUCED', $ ' WITH TOTAL KINETIC ENERGY OF ',F8.3,' GEV') 3004 FORMAT(' *TWOCLU* ',I5,' HEAVY FRAGMENTS WITH TOTAL ENERGY OF ', $ F8.4,' GEV') C 9999 CONTINUE RETURN END