*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,'    <NTOT>',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,
     $ '    <NTOT>',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,'    <NTOT>',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,
     $ '    <NTOT>',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,'    <NTOT>',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,
     $ '    <NTOT>',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,'    <NTOT>',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,
     $ '    <NTOT>',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,'    <NTOT>',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,
     $ '    <NTOT>',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,'    <NTOT>',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,
     $ '    <NTOT>',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,'    <NTOT>',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,
     $ '    <NTOT>',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,'    <NTOT>',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,
     $ '    <NTOT>',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,'    <NTOT>',2X,F8.4,2X,'FROM',4(2X,I3),2X,'PARTICLES')
1004  FORMAT(' *CASN* NEUTRON-INDUCED CASCADE,',
     $ ' EXCLUSIVE REACTION NOT FOUND',
     $ ' TRY ELASTIC SCATTERING',/,'    AVAIL. ENERGY',2X,F8.4,/,2X,
     $ '    <NTOT>',2X,F8.4)
2001  FORMAT(' *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,'    <NTOT>',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,
     $ '    <NTOT>',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,'<NTOT>',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,
     $ '<NTOT>',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,'    <NTOT>',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,
     $ '    <NTOT>',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,'    <NTOT>',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,
     $ '    <NTOT>',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,'    <NTOT>',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,
     $ '    <NTOT>',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,'    <NTOT>',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,
     $ '    <NTOT>',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,'    <NTOT>',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,
     * '    <NTOT>',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,'   <NTOT>',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,
     $ '    <NTOT>',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,'<NTOT>',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,
     $ '<NTOT>',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,'<NTOT>',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,
     $ '<NTOT>',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 <X> > 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 = <X>
    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 <K KB> VS AVAILABLE ENERGY
C                  AND <K Y>  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
