Project CMSSW displayed by LXR CMSSW_15_0_X_2024-12-08-2300/​GeneratorInterface/​AMPTInterface/​src/​art1f.f	Source navigation Diff markup Identifier search General search
	Version: CMSSW_15_0_X_2024-12-08-2300 CMSSW_15_0_X_2024-12-06-2300 CMSSW_15_0_X_2024-12-05-2300 CMSSW_15_0_X_2024-12-04-2300 CMSSW_15_0_X_2024-12-03-2300 CMSSW_15_0_X_2024-12-02-2300 Revert   Change

File indexing completed on 2024-04-06 12:13:19

 c....................art1f.f
 **************************************
 *
 *                           PROGRAM ART1.0 
 *
 *        A relativistic transport (ART) model for heavy-ion collisions
 *
 *   sp/01/04/2002
 *   calculates K+K- from phi decay, dimuons from phi decay
 *   has finite baryon density & possibilites of varying Kaon 
 *   in-medium mass in phiproduction-annhilation channel only.
 *
 *
 * RELEASING DATE: JAN., 1997 
 ***************************************
 * 
 * Bao-An Li & Che Ming Ko
 * Cyclotron Institute, Texas A&M University.
 * Phone: (409) 845-1411
 * e-mail: Bali@comp.tamu.edu & Ko@comp.tamu.edu 
 * http://wwwcyc.tamu.edu/~bali
 ***************************************
 * Speical notice on the limitation of the code:
 * 
 * (1) ART is a hadronic transport model
 * 
 * (2) E_beam/A <= 15 GeV
 * 
 * (3) The mass of the colliding system is limited by the dimensions of arrays
 *    which can be extended purposely. Presently the dimensions are large enough
 *     for running Au+Au at 15 GeV/A.
 *
 * (4) The production and absorption of antiparticles (e.g., ki-, anti-nucleons,
 *     etc) are not fully included in this version of the model. They, however, 
 *     have essentially no effect on the reaction dynamics and observables 
 *     related to nucleons, pions and kaons (K+) at and below AGS energies.
 * 
 * (5) Bose enhancement for mesons and Pauli blocking for fermions are 
 *     turned off.
 * 
 *********************************
 *
 * USEFUL REFERENCES ON PHYSICS AND NUMERICS OF NUCLEAR TRANSPORT MODELS:
 *     G.F. BERTSCH AND DAS GUPTA, PHYS. REP. 160 (1988) 189.
 *     B.A. LI AND W. BAUER, PHYS. REV. C44 (1991) 450.
 *     B.A. LI, W. BAUER AND G.F. BERTSCH, PHYS. REV. C44 (1991) 2095.
 *     P. DANIELEWICZ AND G.F. BERTSCH, NUCL. PHYS. A533 (1991) 712.
 * 
 * MAIN REFERENCES ON THIS VERSION OF ART MODEL:
 *     B.A. LI AND C.M. KO, PHYS. REV. C52 (1995) 2037; 
 *                          NUCL. PHYS. A601 (1996) 457. 
 *
 **********************************
 **********************************
 *  VARIABLES IN INPUT-SECTION:                                               * 
 *                                                                      *
 *  1) TARGET-RELATED QUANTITIES                                        *
 *       MASSTA, ZTA -  TARGET MASS IN AMU, TARGET CHARGE  (INTEGER)    *
 *                                                                      *
 *  2) PROJECTILE-RELATED QUANTITIES                                    *
 *       MASSPR, ZPR -  PROJECTILE MASS IN AMU, PROJ. CHARGE(INTEGER)   *
 *       ELAB     -  BEAM ENERGY IN [MEV/NUCLEON]               (REAL)  *
 *       ZEROPT   -  DISPLACEMENT OF THE SYSTEM IN Z-DIREC. [FM](REAL)  *
 *       B        -  IMPACT PARAMETER [FM]                      (REAL)  *
 *                                                                      *
 *  3) PROGRAM-CONTROL PARAMETERS                                       *
 *       ISEED    -  SEED FOR RANDOM NUMBER GENERATOR        (INTEGER)  *
 *       DT       -  TIME-STEP-SIZE [FM/C]                      (REAL)  *
 *       NTMAX    -  TOTAL NUMBER OF TIMESTEPS               (INTEGER)  *
 *       ICOLL    -  (= 1 -> MEAN FIELD ONLY,                           *
 *                -   =-1 -> CACADE ONLY, ELSE FULL ART)     (INTEGER)  *
 *       NUM      -  NUMBER OF TESTPARTICLES PER NUCLEON     (INTEGER)  *
 *       INSYS    -  (=0 -> LAB-SYSTEM, ELSE C.M. SYSTEM)    (INTEGER)  *
 *       IPOT     -  1 -> SIGMA=2; 2 -> SIGMA=4/3; 3 -> SIGMA=7/6       *
 *                   IN MEAN FIELD POTENTIAL                 (INTEGER)  *
 *       MODE     -  (=1 -> interpolation for pauli-blocking,           *
 *                    =2 -> local lookup, other -> unblocked)(integer)  *
 *       DX,DY,DZ -  widths of cell for paulat in coor. sp. [fm](real)  *
 *       DPX,DPY,DPZ-widths of cell for paulat in mom. sp.[GeV/c](real) *
 *       IAVOID   -  (=1 -> AVOID FIRST COLL. WITHIN SAME NUCL.         *
 *                    =0 -> ALLOW THEM)                      (INTEGER)  *
 *       IMOMEN   -  FLAG FOR CHOICE OF INITIAL MOMENTUM DISTRIBUTION   *
 *                   (=1 -> WOODS-SAXON DENSITY AND LOCAL THOMAS-FERMI  *
 *                    =2 -> NUCLEAR MATTER DEN. AND LOCAL THOMAS-FERMI  *
 *                    =3 -> COHERENT BOOST IN Z-DIRECTION)   (INTEGER)  *
 *  4) CONTROL-PRINTOUT OPTIONS                                         *
 *       NFREQ    -  NUMBER OF TIMSTEPS AFTER WHICH PRINTOUT            *
 *                   IS REQUIRED OR ON-LINE ANALYSIS IS PERFORMED       *
 *       ICFLOW      =1 PERFORM ON-LINE FLOW ANALYSIS EVERY NFREQ STEPS *
 *       ICRHO       =1 PRINT OUT THE BARYON,PION AND ENERGY MATRIX IN  *
 *                      THE REACTION PLANE EVERY NFREQ TIME-STEPS       *
 *  5)
 *       CYCBOX   -  ne.0 => cyclic boundary conditions;boxsize CYCBOX  *
 *
 **********************************
 *               Lables of particles used in this code                     *
 **********************************
 *         
 *         LB(I) IS USED TO LABEL PARTICLE'S CHARGE STATE
 *    
 *         LB(I)   =
 clin-11/07/00:
 *                -30 K*-
 clin-8/29/00
 *                -13 anti-N*(+1)(1535),s_11
 *                -12 anti-N*0(1535),s_11
 *                 -11 anti-N*(+1)(1440),p_11
 *                 -10 anti-N*0(1440), p_11
 *                  -9 anti-DELTA+2
 *                  -8 anti-DELTA+1
 *                  -7 anti-DELTA0
 *                  -6 anti-DELTA-1
 clin-8/29/00-end
 
 cbali2/7/99 
 *                  -2 antineutron 
 *                             -1       antiproton
 cbali2/7/99 end 
 *                   0 eta
 *                        1 PROTON
 *                   2 NUETRON
 *                   3 PION-
 *                   4 PION0
 *                   5 PION+
 *                   6 DELTA-1
 *                   7 DELTA0
 *                   8 DELTA+1
 *                   9 DELTA+2
 *                   10 N*0(1440), p_11
 *                   11 N*(+1)(1440),p_11
 *                  12 N*0(1535),s_11
 *                  13 N*(+1)(1535),s_11
 *                  14 LAMBDA
 *                   15 sigma-, since we used isospin averaged xsection for
 *                   16 sigma0  sigma associated K+ production, sigma0 and 
 *                   17 sigma+  sigma+ are counted as sigma-
 *                   21 kaon-
 *                   23 KAON+
 *                   24 kaon0
 *                   25 rho-
 *                         26 rho0
 *                   27 rho+
 *                   28 omega meson
 *                   29 phi
 clin-11/07/00:
 *                  30 K*+
 * sp01/03/01
 *                 -14 LAMBDA(bar)
 *                  -15 sigma-(bar)
 *                  -16 sigma0(bar)
 *                  -17 sigma+(bar)
 *                   31 eta-prime
 *                   40 cascade-
 *                  -40 cascade-(bar)
 *                   41 cascade0
 *                  -41 cascade0(bar)
 *                   45 Omega baryon
 *                  -45 Omega baryon(bar)
 * sp01/03/01 end
 clin-5/2008:
 *                   42 Deuteron (same in ampt.dat)
 *                  -42 anti-Deuteron (same in ampt.dat)
 c
 *                   ++  ------- SEE BAO-AN LI'S NOTE BOOK
 **********************************
 cbz11/16/98
 c      PROGRAM ART
        SUBROUTINE ARTMN
 cbz11/16/98end
 **********************************
 * PARAMETERS:                                                           *
 *  MAXPAR     - MAXIMUM NUMBER OF PARTICLES      PROGRAM CAN HANDLE     *
 *  MAXP       - MAXIMUM NUMBER OF CREATED MESONS PROGRAM CAN HANDLE     *
 *  MAXR       - MAXIMUM NUMBER OF EVENTS AT EACH IMPACT PARAMETER       *
 *  MAXX       - NUMBER OF MESHPOINTS IN X AND Y DIRECTION = 2 MAXX + 1  *
 *  MAXZ       - NUMBER OF MESHPOINTS IN Z DIRECTION       = 2 MAXZ + 1  *
 *  AMU        - 1 ATOMIC MASS UNIT "GEV/C**2"                           *
 *  MX,MY,MZ   - MESH SIZES IN COORDINATE SPACE [FM] FOR PAULI LATTICE   *
 *  MPX,MPY,MPZ- MESH SIZES IN MOMENTUM SPACE [GEV/C] FOR PAULI LATTICE  *
 *---------------------------------------------------------------------- *
 clin      PARAMETER     (maxpar=200000,MAXR=50,AMU= 0.9383,
       PARAMETER     (MAXSTR=150001,MAXR=1,AMU= 0.9383,
      1               AKA=0.498,etaM=0.5475)
       PARAMETER     (MAXX   =   20,  MAXZ  =    24)
       PARAMETER     (ISUM   =   1001,  IGAM  =    1100)
       parameter     (MX=4,MY=4,MZ=8,MPX=4,MPY=4,mpz=10,mpzp=10)
 clin      PARAMETER (MAXP = 14000)
 *----------------------------------------------------------------------*
       INTEGER   OUTPAR, zta,zpr
       COMMON  /AA/      R(3,MAXSTR)
 cc      SAVE /AA/
       COMMON  /BB/      P(3,MAXSTR)
 cc      SAVE /BB/
       COMMON  /CC/      E(MAXSTR)
 cc      SAVE /CC/
       COMMON  /DD/      RHO(-MAXX:MAXX,-MAXX:MAXX,-MAXZ:MAXZ),
      &                     RHOP(-MAXX:MAXX,-MAXX:MAXX,-MAXZ:MAXZ),
      &                     RHON(-MAXX:MAXX,-MAXX:MAXX,-MAXZ:MAXZ)
 cc      SAVE /DD/
       COMMON  /EE/      ID(MAXSTR),LB(MAXSTR)
 cc      SAVE /EE/
       COMMON  /HH/  PROPER(MAXSTR)
 cc      SAVE /HH/
       common  /ff/f(-mx:mx,-my:my,-mz:mz,-mpx:mpx,-mpy:mpy,-mpz:mpzp)
 cc      SAVE /ff/
       common  /gg/      dx,dy,dz,dpx,dpy,dpz
 cc      SAVE /gg/
       COMMON  /INPUT/ NSTAR,NDIRCT,DIR
 cc      SAVE /INPUT/
       COMMON  /PP/      PRHO(-20:20,-24:24)
       COMMON  /QQ/      PHRHO(-MAXZ:MAXZ,-24:24)
       COMMON  /RR/      MASSR(0:MAXR)
 cc      SAVE /RR/
       common  /ss/      inout(20)
 cc      SAVE /ss/
       common  /zz/      zta,zpr
 cc      SAVE /zz/
       COMMON  /RUN/     NUM
 cc      SAVE /RUN/
 clin-4/2008:
 c      COMMON  /KKK/     TKAON(7),EKAON(7,0:200)
       COMMON  /KKK/     TKAON(7),EKAON(7,0:2000)
 cc      SAVE /KKK/
       COMMON  /KAON/    AK(3,50,36),SPECK(50,36,7),MF
 cc      SAVE /KAON/
       COMMON/TABLE/ xarray(0:1000),earray(0:1000)
 cc      SAVE /TABLE/
       common/input1/ MASSPR,MASSTA,ISEED,IAVOID,DT
 cc      SAVE /input1/
       COMMON  /DDpi/    piRHO(-MAXX:MAXX,-MAXX:MAXX,-MAXZ:MAXZ)
 cc      SAVE /DDpi/
       common  /tt/  PEL(-maxx:maxx,-maxx:maxx,-maxz:maxz)
      &,rxy(-maxx:maxx,-maxx:maxx,-maxz:maxz)
 cc      SAVE /tt/
 clin-4/2008:
 c      DIMENSION TEMP(3,MAXSTR),SKAON(7),SEKAON(7,0:200)
       DIMENSION TEMP(3,MAXSTR),SKAON(7),SEKAON(7,0:2000)
 cbz12/2/98
       COMMON /INPUT2/ ILAB, MANYB, NTMAX, ICOLL, INSYS, IPOT, MODE, 
      &   IMOMEN, NFREQ, ICFLOW, ICRHO, ICOU, KPOTEN, KMUL
 cc      SAVE /INPUT2/
       COMMON /INPUT3/ PLAB, ELAB, ZEROPT, B0, BI, BM, DENCUT, CYCBOX
 cc      SAVE /INPUT3/
 cbz12/2/98end
 cbz11/16/98
       COMMON /ARPRNT/ ARPAR1(100), IAPAR2(50), ARINT1(100), IAINT2(50)
 cc      SAVE /ARPRNT/
 
 c.....note in the below, since a common block in ART is called EE,
 c.....the variable EE in /ARPRC/is changed to PEAR.
 clin-9/29/03 changed name in order to distinguish from /prec2/
 c        COMMON /ARPRC/ ITYPAR(MAXSTR),
 c     &       GXAR(MAXSTR), GYAR(MAXSTR), GZAR(MAXSTR), FTAR(MAXSTR),
 c     &       PXAR(MAXSTR), PYAR(MAXSTR), PZAR(MAXSTR), PEAR(MAXSTR),
 c     &       XMAR(MAXSTR)
 cc      SAVE /ARPRC/
 clin-9/29/03-end
       COMMON /ARERCP/PRO1(MAXSTR, MAXR)
 cc      SAVE /ARERCP/
       COMMON /ARERC1/MULTI1(MAXR)
 cc      SAVE /ARERC1/
       COMMON /ARPRC1/ITYP1(MAXSTR, MAXR),
      &     GX1(MAXSTR, MAXR), GY1(MAXSTR, MAXR), GZ1(MAXSTR, MAXR), 
      &     FT1(MAXSTR, MAXR),
      &     PX1(MAXSTR, MAXR), PY1(MAXSTR, MAXR), PZ1(MAXSTR, MAXR),
      &     EE1(MAXSTR, MAXR), XM1(MAXSTR, MAXR)
 cc      SAVE /ARPRC1/
 c
       DIMENSION NPI(MAXR)
       DIMENSION RT(3, MAXSTR, MAXR), PT(3, MAXSTR, MAXR)
      &     , ET(MAXSTR, MAXR), LT(MAXSTR, MAXR), PROT(MAXSTR, MAXR)
 
       EXTERNAL IARFLV, INVFLV
 cbz11/16/98end
       common /lastt/itimeh,bimp 
 cc      SAVE /lastt/
       common/snn/efrm,npart1,npart2,epsiPz,epsiPt,PZPROJ,PZTARG
 cc      SAVE /snn/
       COMMON/hbt/lblast(MAXSTR),xlast(4,MAXSTR),plast(4,MAXSTR),nlast
 cc      SAVE /hbt/
       common/resdcy/NSAV,iksdcy
 cc      SAVE /resdcy/
       COMMON/RNDF77/NSEED
 cc      SAVE /RNDF77/
       COMMON/FTMAX/ftsv(MAXSTR),ftsvt(MAXSTR, MAXR)
       COMMON /dpert/dpertt(MAXSTR,MAXR),dpertp(MAXSTR),dplast(MAXSTR),
      1     dpdcy(MAXSTR),dpdpi(MAXSTR,MAXR),dpt(MAXSTR, MAXR),
      2     dpp1(MAXSTR,MAXR),dppion(MAXSTR,MAXR)
       COMMON/HPARNT/HIPR1(100),IHPR2(50),HINT1(100),IHNT2(50)
 clin-4/2008 zet() expanded to avoid out-of-bound errors:
       real zet(-45:45)
       SAVE   
       data zet /
      4     1.,0.,0.,0.,0.,
      3     1.,0.,0.,0.,0.,0.,0.,0.,0.,0.,
      2     -1.,0.,0.,0.,0.,0.,0.,0.,0.,0.,
      1     0.,0.,0.,-1.,0.,1.,0.,-1.,0.,-1.,
      s     0.,-2.,-1.,0.,1.,0.,0.,0.,0.,-1.,
      e     0.,
      s     1.,0.,-1.,0.,1.,-1.,0.,1.,2.,0.,
      1     1.,0.,1.,0.,-1.,0.,1.,0.,0.,0.,
      2     -1.,0.,1.,0.,-1.,0.,1.,0.,0.,1.,
      3     0.,0.,0.,0.,0.,0.,0.,0.,0.,-1.,
      4     0.,0.,0.,0.,-1./
 
       nlast=0
       do 1002 i=1,MAXSTR
          ftsv(i)=0.
          do 1101 irun=1,maxr
             ftsvt(i,irun)=0.
  1101    continue
          lblast(i)=999
          do 1001 j=1,4
 clin-4/2008 bugs pointed out by Vander Molen & Westfall:
 c            xlast(i,j)=0.
 c            plast(i,j)=0.
             xlast(j,i)=0.
             plast(j,i)=0.
  1001    continue
  1002 continue
 
 *-------------------------------------------------------------------*
 * Input information about the reaction system and contral parameters* 
 *-------------------------------------------------------------------*
 *              input section starts here                           *
 *-------------------------------------------------------------------*
 
 cbz12/2/98
 c.....input section is moved to subroutine ARTSET
 cbz12/2/98end
 
 *-----------------------------------------------------------------------*
 *                   input section ends here                            *
 *-----------------------------------------------------------------------*
 * read in the table for gengrating the transverse momentum
 * IN THE NN-->DDP PROCESS
        call tablem
 * several control parameters, keep them fixed in this code. 
        ikaon=1
        nstar=1
        ndirct=0
        dir=0.02
        asy=0.032
        ESBIN=0.04
        MF=36
 *----------------------------------------------------------------------*
 c      CALL FRONT(12,MASSTA,MASSPR,ELAB)
 *----------------------------------------------------------------------*
       RADTA  = 1.124 * FLOAT(MASSTA)**(1./3.)
       RADPR  = 1.124 * FLOAT(MASSPR)**(1./3.)
       ZDIST  = RADTA + RADPR
 c      if ( cycbox.ne.0 ) zdist=0
       BMAX   = RADTA + RADPR
       MASS   = MASSTA + MASSPR
       NTOTAL = NUM * MASS
 *
       IF (NTOTAL .GT. MAXSTR) THEN
         WRITE(12,'(//10X,''**** FATAL ERROR: TOO MANY TEST PART. ****'//
      & ' '')')
         STOP
       END IF
 *
 *-----------------------------------------------------------------------
 *       RELATIVISTIC KINEMATICS
 *
 *       1) LABSYSTEM
 *
       ETA    = FLOAT(MASSTA) * AMU
       PZTA   = 0.0
       BETATA = 0.0
       GAMMTA = 1.0
 *
       EPR    = FLOAT(MASSPR) * (AMU + 0.001 * ELAB)
       PZPR   = SQRT( EPR**2 - (AMU * FLOAT(MASSPR))**2 )
       BETAPR = PZPR / EPR
       GAMMPR = 1.0 / SQRT( 1.0 - BETAPR**2 )
 *
 * BETAC AND GAMMAC OF THE C.M. OBSERVED IN THE LAB. FRAME
         BETAC=(PZPR+PZTA)/(EPR+ETA)
         GAMMC=1.0 / SQRT(1.-BETAC**2)
 *
 c      WRITE(12,'(/10x,''****    KINEMATICAL PARAMETERS    ****''/)')
 c      WRITE(12,'(10x,''1) LAB-FRAME:        TARGET PROJECTILE'')')
 c      WRITE(12,'(10x,''   ETOTAL "GEV" '',2F11.4)') ETA, EPR
 c      WRITE(12,'(10x,''   P "GEV/C"    '',2F11.4)') PZTA, PZPR
 c      WRITE(12,'(10x,''   BETA         '',2F11.4)') BETATA, BETAPR
 c      WRITE(12,'(10x,''   GAMMA        '',2F11.4)') GAMMTA, GAMMPR
       IF (INSYS .NE. 0) THEN
 *
 *       2) C.M. SYSTEM
 *
         S      = (EPR+ETA)**2 - PZPR**2
         xx1=4.*alog(float(massta))
         xx2=4.*alog(float(masspr))
         xx1=exp(xx1)
         xx2=exp(xx2)
         PSQARE = (S**2 + (xx1+ xx2) * AMU**4
      &             - 2.0 * S * AMU**2 * FLOAT(MASSTA**2 + MASSPR**2)
      &             - 2.0 * FLOAT(MASSTA**2 * MASSPR**2) * AMU**4)
      &           / (4.0 * S)
 *
         ETA    = SQRT ( PSQARE + (FLOAT(MASSTA) * AMU)**2 )
         PZTA   = - SQRT(PSQARE)
         BETATA = PZTA / ETA
         GAMMTA = 1.0 / SQRT( 1.0 - BETATA**2 )
 *
         EPR    = SQRT ( PSQARE + (FLOAT(MASSPR) * AMU)**2 )
         PZPR   = SQRT(PSQARE)
         BETAPR = PZPR/ EPR
         GAMMPR = 1.0 / SQRT( 1.0 - BETAPR**2 )
 *
 c        WRITE(12,'(10x,''2) C.M.-FRAME:  '')')
 c        WRITE(12,'(10x,''   ETOTAL "GEV" '',2F11.4)') ETA, EPR
 c        WRITE(12,'(10x,''   P "GEV/C"    '',2F11.4)') PZTA, PZPR
 c        WRITE(12,'(10x,''   BETA         '',2F11.4)') BETATA, BETAPR
 c        WRITE(12,'(10x,''   GAMMA        '',2F11.4)') GAMMTA, GAMMPR
 c        WRITE(12,'(10x,''S "GEV**2"      '',F11.4)')  S
 c        WRITE(12,'(10x,''PSQARE "GEV/C"2 '',E14.3)')  PSQARE
 c        WRITE(12,'(/10x,''*** CALCULATION DONE IN CM-FRAME ***''/)')
       ELSE
 c        WRITE(12,'(/10x,''*** CALCULATION DONE IN LAB-FRAME ***''/)')
       END IF
 * MOMENTUM PER PARTICLE
       PZTA = PZTA / FLOAT(MASSTA)
       PZPR = PZPR / FLOAT(MASSPR)
 * total initial energy in the N-N cms frame
       ECMS0=ETA+EPR
 *-----------------------------------------------------------------------
 *
 * Start loop over many runs of different impact parameters
 * IF MANYB=1, RUN AT A FIXED IMPACT PARAMETER B0, OTHERWISE GENERATE 
 * MINIMUM BIAS EVENTS WITHIN THE IMPACT PARAMETER RANGE OF B_MIN AND B_MAX
        DO 50000 IMANY=1,MANYB
 *------------------------------------------------------------------------
 * Initialize the impact parameter B
        if (manyb. gt.1) then
 111       BX=1.0-2.0*RANART(NSEED)
        BY=1.0-2.0*RANART(NSEED)
        B2=BX*BX+BY*BY
        IF(B2.GT.1.0) GO TO 111       
        B=SQRT(B2)*(BM-BI)+BI
        ELSE
        B=B0
        ENDIF
 c      WRITE(12,'(///10X,''RUN NUMBER:'',I6)') IMANY       
 c      WRITE(12,'(//10X,''IMPACT PARAMETER B FOR THIS RUN:'',
 c     &             F9.3,'' FM''/10X,49(''*'')/)') B
 *
 *-----------------------------------------------------------------------
 *       INITIALIZATION
 *1 INITIALIZATION IN ISOSPIN SPACE FOR BOTH THE PROJECTILE AND TARGET
       call coulin(masspr,massta,NUM)
 *2 INITIALIZATION IN PHASE SPACE FOR THE TARGET
       CALL INIT(1       ,MASSTA   ,NUM     ,RADTA,
      &          B/2.    ,ZEROPT+ZDIST/2.   ,PZTA,
      &          GAMMTA  ,ISEED    ,MASS    ,IMOMEN)
 *3.1 INITIALIZATION IN PHASE SPACE FOR THE PROJECTILE
       CALL INIT(1+MASSTA,MASS     ,NUM     ,RADPR,
      &          -B/2.   ,ZEROPT-ZDIST/2.   ,PZPR,
      &          GAMMPR  ,ISEED    ,MASS    ,IMOMEN)
 *3.2 OUTPAR IS THE NO. OF ESCAPED PARTICLES
       OUTPAR = 0
 *3.3 INITIALIZATION FOR THE NO. OF PARTICLES IN EACH SAMPLE
 *    THIS IS NEEDED DUE TO THE FACT THAT PIONS CAN BE PRODUCED OR ABSORBED
       MASSR(0)=0
       DO 1003 IR =1,NUM
       MASSR(IR)=MASS
  1003 CONTINUE
 *3.4 INITIALIZation FOR THE KAON SPECTRUM
 *      CALL KSPEC0(BETAC,GAMMC)
 * calculate the local baryon density matrix
       CALL DENS(IPOT,MASS,NUM,OUTPAR)
 *
 *-----------------------------------------------------------------------
 *       CONTROL PRINTOUT OF INITIAL CONFIGURATION
 *
 *      WRITE(12,'(''**********  INITIAL CONFIGURATION  **********''/)')
 *
 c print out the INITIAL density matrix in the reaction plane
 c       do ix=-10,10
 c       do iz=-10,10
 c       write(1053,992)ix,iz,rho(ix,0,iz)/0.168
 c       end do
 c       end do
 *-----------------------------------------------------------------------
 *       CALCULATE MOMENTA FOR T = 0.5 * DT 
 *       (TO OBTAIN 2ND DEGREE ACCURACY!)
 *       "Reference: J. AICHELIN ET AL., PHYS. REV. C31, 1730 (1985)"
 *
       IF (ICOLL .NE. -1) THEN
         DO 700 I = 1,NTOTAL
           IX = NINT( R(1,I) )
           IY = NINT( R(2,I) )
           IZ = NINT( R(3,I) )
 clin-4/2008 check bounds:
           IF(IX.GE.MAXX.OR.IY.GE.MAXX.OR.IZ.GE.MAXZ
      1         .OR.IX.LE.-MAXX.OR.IY.LE.-MAXX.OR.IZ.LE.-MAXZ) goto 700
           CALL GRADU(IPOT,IX,IY,IZ,GRADX,GRADY,GRADZ)
           P(1,I) = P(1,I) - (0.5 * DT) * GRADX
           P(2,I) = P(2,I) - (0.5 * DT) * GRADY
           P(3,I) = P(3,I) - (0.5 * DT) * GRADZ
   700   CONTINUE
       END IF
 *-----------------------------------------------------------------------
 *-----------------------------------------------------------------------
 *4 INITIALIZATION OF TIME-LOOP VARIABLES
 *4.1 COLLISION NUMBER COUNTERS
 clin 51      RCNNE  = 0
         RCNNE  = 0
        RDD  = 0
        RPP  = 0
        rppk = 0
        RPN  = 0
        rpd  = 0
        RKN  = 0
        RNNK = 0
        RDDK = 0
        RNDK = 0
       RCNND  = 0
       RCNDN  = 0
       RCOLL  = 0
       RBLOC  = 0
       RDIRT  = 0
       RDECAY = 0
       RRES   = 0
 *4.11 KAON PRODUCTION PROBABILITY COUNTER FOR PERTURBATIVE CALCULATIONS ONLY
       DO 1005 KKK=1,5
          SKAON(KKK)  = 0
          DO 1004 IS=1,2000
             SEKAON(KKK,IS)=0
  1004    CONTINUE
  1005 CONTINUE
 *4.12 anti-proton and anti-kaon counters
        pr0=0.
        pr1=0.
        ska0=0.
        ska1=0.
 *       ============== LOOP OVER ALL TIME STEPS ================       *
 *                             STARTS HERE                              *
 *       ========================================================       *
 cbz11/16/98
       IF (IAPAR2(1) .NE. 1) THEN
          DO 1016 I = 1, MAXSTR
             DO 1015 J = 1, 3
                R(J, I) = 0.
                P(J, I) = 0.
  1015       CONTINUE
             E(I) = 0.
             LB(I) = 0
 cbz3/25/00
             ID(I)=0
 c     sp 12/19/00
            PROPER(I) = 1.
  1016   CONTINUE
          MASS = 0
 cbz12/22/98
 c         MASSR(1) = 0
 c         NP = 0
 c         NPI = 1
          NP = 0
          DO 1017 J = 1, NUM
             MASSR(J) = 0
             NPI(J) = 1
  1017    CONTINUE
          DO 1019 I = 1, MAXR
             DO 1018 J = 1, MAXSTR
                RT(1, J, I) = 0.
                RT(2, J, I) = 0.
                RT(3, J, I) = 0.
                PT(1, J, I) = 0.
                PT(2, J, I) = 0.
                PT(3, J, I) = 0.
                ET(J, I) = 0.
                LT(J, I) = 0
 c     sp 12/19/00
                PROT(J, I) = 1.
  1018       CONTINUE
  1019    CONTINUE
 cbz12/22/98end
       END IF
 cbz11/16/98end
         
       DO 10000 NT = 1,NTMAX
 *TEMPORARY PARTICLE COUNTERS
 *4.2 PION COUNTERS : LP1,LP2 AND LP3 ARE THE NO. OF P+,P0 AND P-
       LP1=0
       LP2=0
       LP3=0
 *4.3 DELTA COUNTERS : LD1,LD2,LD3 AND LD4 ARE THE NO. OF D++,D+,D0 AND D-
       LD1=0
       LD2=0
       LD3=0
       LD4=0
 *4.4 N*(1440) COUNTERS : LN1 AND LN2 ARE THE NO. OF N*+ AND N*0
       LN1=0
       LN2=0
 *4.5 N*(1535) counters
       LN5=0
 *4.6 ETA COUNTERS
       LE=0
 *4.7 KAON COUNTERS
       LKAON=0
 
 clin-11/09/00:
 * KAON* COUNTERS
       LKAONS=0
 
 *-----------------------------------------------------------------------
         IF (ICOLL .NE. 1) THEN
 * STUDYING BINARY COLLISIONS AMONG PARTICLES DURING THIS TIME INTERVAL *
 clin-10/25/02 get rid of argument usage mismatch in relcol(.nt.):
            numnt=nt
           CALL RELCOL(LCOLL,LBLOC,LCNNE,LDD,LPP,lppk,
      &    LPN,lpd,LRHO,LOMEGA,LKN,LNNK,LDDK,LNDK,LCNND,
      &    LCNDN,LDIRT,LDECAY,LRES,LDOU,LDDRHO,LNNRHO,
      &    LNNOM,numnt,ntmax,sp,akaon,sk)
 c     &    LNNOM,NT,ntmax,sp,akaon,sk)
 clin-10/25/02-end
 *-----------------------------------------------------------------------
 
 c dilepton production from Dalitz decay
 c of pi0 at final time
 *      if(nt .eq. ntmax) call dalitz_pi(nt,ntmax)
 *                                                                      *
 **********************************
 *                Lables of collision channels                             *
 **********************************
 *         LCOLL   - NUMBER OF COLLISIONS              (INTEGER,OUTPUT) *
 *         LBLOC   - NUMBER OF PULI-BLOCKED COLLISIONS (INTEGER,OUTPUT) *
 *         LCNNE   - NUMBER OF ELASTIC COLLISION       (INTEGER,OUTPUT) *
 *         LCNND   - NUMBER OF N+N->N+DELTA REACTION   (INTEGER,OUTPUT) *
 *         LCNDN   - NUMBER OF N+DELTA->N+N REACTION   (INTEGER,OUTPUT) *
 *         LDD     - NUMBER OF RESONANCE+RESONANCE COLLISIONS
 *         LPP     - NUMBER OF PION+PION elastic COLIISIONS
 *         lppk    - number of pion(RHO,OMEGA)+pion(RHO,OMEGA)
 *                 -->K+K- collisions
 *         LPN     - NUMBER OF PION+N-->KAON+X
 *         lpd     - number of pion+n-->delta+pion
 *         lrho    - number of pion+n-->Delta+rho
 *         lomega  - number of pion+n-->Delta+omega
 *         LKN     - NUMBER OF KAON RESCATTERINGS
 *         LNNK    - NUMBER OF bb-->kAON PROCESS
 *         LDDK    - NUMBER OF DD-->KAON PROCESS
 *         LNDK    - NUMBER OF ND-->KAON PROCESS
 ***********************************
 * TIME-INTEGRATED COLLISIONS NUMBERS OF VARIOUS PROCESSES
           RCOLL = RCOLL + FLOAT(LCOLL)/num
           RBLOC = RBLOC + FLOAT(LBLOC)/num
           RCNNE = RCNNE + FLOAT(LCNNE)/num
          RDD   = RDD   + FLOAT(LDD)/num
          RPP   = RPP   + FLOAT(LPP)/NUM
          rppk  =rppk   + float(lppk)/num
          RPN   = RPN   + FLOAT(LPN)/NUM
          rpd   =rpd    + float(lpd)/num
          RKN   = RKN   + FLOAT(LKN)/NUM
          RNNK  =RNNK   + FLOAT(LNNK)/NUM
          RDDK  =RDDK   + FLOAT(LDDK)/NUM
          RNDK  =RNDK   + FLOAT(LNDK)/NUM
           RCNND = RCNND + FLOAT(LCNND)/num
           RCNDN = RCNDN + FLOAT(LCNDN)/num
           RDIRT = RDIRT + FLOAT(LDIRT)/num
           RDECAY= RDECAY+ FLOAT(LDECAY)/num
           RRES  = RRES  + FLOAT(LRES)/num
 * AVERAGE RATES OF VARIOUS COLLISIONS IN THE CURRENT TIME STEP
           ADIRT=LDIRT/DT/num
           ACOLL=(LCOLL-LBLOC)/DT/num
           ACNND=LCNND/DT/num
           ACNDN=LCNDN/DT/num
           ADECAY=LDECAY/DT/num
           ARES=LRES/DT/num
          ADOU=LDOU/DT/NUM
          ADDRHO=LDDRHO/DT/NUM
          ANNRHO=LNNRHO/DT/NUM
          ANNOM=LNNOM/DT/NUM
          ADD=LDD/DT/num
          APP=LPP/DT/num
          appk=lppk/dt/num
           APN=LPN/DT/num
          apd=lpd/dt/num
          arh=lrho/dt/num
          aom=lomega/dt/num
          AKN=LKN/DT/num
          ANNK=LNNK/DT/num
          ADDK=LDDK/DT/num
          ANDK=LNDK/DT/num
 * PRINT OUT THE VARIOUS COLLISION RATES
 * (1)N-N COLLISIONS 
 c       WRITE(1010,9991)NT*DT,ACNND,ADOU,ADIRT,ADDRHO,ANNRHO+ANNOM
 c9991       FORMAT(6(E10.3,2X))
 * (2)PION-N COLLISIONS
 c       WRITE(1011,'(5(E10.3,2X))')NT*DT,apd,ARH,AOM,APN
 * (3)KAON PRODUCTION CHANNELS
 c        WRITE(1012,9993)NT*DT,ANNK,ADDK,ANDK,APN,Appk
 * (4)D(N*)+D(N*) COLLISION
 c       WRITE(1013,'(4(E10.3,2X))')NT*DT,ADDK,ADD,ADD+ADDK
 * (5)MESON+MESON
 c       WRITE(1014,'(4(E10.3,2X))')NT*DT,APPK,APP,APP+APPK
 * (6)DECAY AND RESONANCE
 c       WRITE(1016,'(3(E10.3,2X))')NT*DT,ARES,ADECAY
 * (7)N+D(N*)
 c       WRITE(1017,'(4(E10.3,2X))')NT*DT,ACNDN,ANDK,ACNDN+ANDK
 c9992    FORMAT(5(E10.3,2X))
 c9993    FORMAT(6(E10.3,2X))
 * PRINT OUT TIME-INTEGRATED COLLISION INFORMATION
 cbz12/28/98
 c        write(1018,'(5(e10.3,2x),/, 4(e10.3,2x))')
 c     &           RCNNE,RCNND,RCNDN,RDIRT,rpd,
 c     &           RDECAY,RRES,RDD,RPP
 c        write(1018,'(6(e10.3,2x),/, 5(e10.3,2x))')
 c     &           NT*DT,RCNNE,RCNND,RCNDN,RDIRT,rpd,
 c     &           NT*DT,RDECAY,RRES,RDD,RPP
 cbz12/18/98end
 * PRINT OUT TIME-INTEGRATED KAON MULTIPLICITIES FROM DIFFERENT CHANNELS
 c       WRITE(1019,'(7(E10.3,2X))')NT*DT,RNNK,RDDK,RNDK,RPN,Rppk,
 c     &                           RNNK+RDDK+RNDK+RPN+Rppk
 *                                                                      *
 
         END IF
 *
 *       UPDATE BARYON DENSITY
 *
         CALL DENS(IPOT,MASS,NUM,OUTPAR)
 *
 *       UPDATE POSITIONS FOR ALL THE PARTICLES PRESENT AT THIS TIME
 *
        sumene=0
         ISO=0
         DO 201 MRUN=1,NUM
         ISO=ISO+MASSR(MRUN-1)
         DO 201 I0=1,MASSR(MRUN)
         I =I0+ISO
         ETOTAL = SQRT( E(I)**2 + P(1,I)**2 + P(2,I)**2 +P(3,I)**2 )
        sumene=sumene+etotal
 C for kaons, if there is a potential
 C CALCULATE THE ENERGY OF THE KAON ACCORDING TO THE IMPULSE APPROXIMATION
 C REFERENCE: B.A. LI AND C.M. KO, PHYS. REV. C 54 (1996) 3283. 
          if(kpoten.ne.0.and.lb(i).eq.23)then
              den=0.
               IX = NINT( R(1,I) )
               IY = NINT( R(2,I) )
               IZ = NINT( R(3,I) )
 clin-4/2008:
 c       IF (ABS(IX) .LT. MAXX .AND. ABS(IY) .LT. MAXX .AND.
 c     & ABS(IZ) .LT. MAXZ) den=rho(ix,iy,iz)
               IF(IX.LT.MAXX.AND.IY.LT.MAXX.AND.IZ.LT.MAXZ
      1             .AND.IX.GT.-MAXX.AND.IY.GT.-MAXX.AND.IZ.GT.-MAXZ)
      2             den=rho(ix,iy,iz)
 c         ecor=0.1973**2*0.255*kmul*4*3.14159*(1.+0.4396/0.938)
 c         etotal=sqrt(etotal**2+ecor*den)
 c** G.Q Li potential form with n_s = n_b and pot(n_0)=29 MeV, m^*=m
 c     GeV^2 fm^3
           akg = 0.1727
 c     GeV fm^3
           bkg = 0.333
          rnsg = den
          ecor = - akg*rnsg + (bkg*den)**2
          etotal = sqrt(etotal**2 + ecor)
          endif
 c
          if(kpoten.ne.0.and.lb(i).eq.21)then
              den=0.
               IX = NINT( R(1,I) )
               IY = NINT( R(2,I) )
               IZ = NINT( R(3,I) )
 clin-4/2008:
 c       IF (ABS(IX) .LT. MAXX .AND. ABS(IY) .LT. MAXX .AND.
 c     & ABS(IZ) .LT. MAXZ) den=rho(ix,iy,iz)
               IF(IX.LT.MAXX.AND.IY.LT.MAXX.AND.IZ.LT.MAXZ
      1             .AND.IX.GT.-MAXX.AND.IY.GT.-MAXX.AND.IZ.GT.-MAXZ)
      2             den=rho(ix,iy,iz)
 c* for song potential no effect on position
 c** G.Q Li potential form with n_s = n_b and pot(n_0)=29 MeV, m^*=m
 c     GeV^2 fm^3
           akg = 0.1727
 c     GeV fm^3
           bkg = 0.333
          rnsg = den
          ecor = - akg*rnsg + (bkg*den)**2
          etotal = sqrt(etotal**2 + ecor)
           endif
 c
 C UPDATE POSITIONS
           R(1,I) = R(1,I) + DT*P(1,I)/ETOTAL
           R(2,I) = R(2,I) + DT*P(2,I)/ETOTAL
           R(3,I) = R(3,I) + DT*P(3,I)/ETOTAL
 c use cyclic boundary conitions
             if ( cycbox.ne.0 ) then
               if ( r(1,i).gt. cycbox/2 ) r(1,i)=r(1,i)-cycbox
               if ( r(1,i).le.-cycbox/2 ) r(1,i)=r(1,i)+cycbox
               if ( r(2,i).gt. cycbox/2 ) r(2,i)=r(2,i)-cycbox
               if ( r(2,i).le.-cycbox/2 ) r(2,i)=r(2,i)+cycbox
               if ( r(3,i).gt. cycbox/2 ) r(3,i)=r(3,i)-cycbox
               if ( r(3,i).le.-cycbox/2 ) r(3,i)=r(3,i)+cycbox
             end if
 * UPDATE THE DELTA, N* AND PION COUNTERS
           LB1=LB(I)
 * 1. FOR DELTA++
         IF(LB1.EQ.9)LD1=LD1+1
 * 2. FOR DELTA+
         IF(LB1.EQ.8)LD2=LD2+1
 * 3. FOR DELTA0
         IF(LB1.EQ.7)LD3=LD3+1
 * 4. FOR DELTA-
         IF(LB1.EQ.6)LD4=LD4+1
 * 5. FOR N*+(1440)
         IF(LB1.EQ.11)LN1=LN1+1
 * 6. FOR N*0(1440)
         IF(LB1.EQ.10)LN2=LN2+1
 * 6.1 FOR N*(1535)
        IF((LB1.EQ.13).OR.(LB1.EQ.12))LN5=LN5+1
 * 6.2 FOR ETA
        IF(LB1.EQ.0)LE=LE+1
 * 6.3 FOR KAONS
        IF(LB1.EQ.23)LKAON=LKAON+1
 clin-11/09/00: FOR KAON*
        IF(LB1.EQ.30)LKAONS=LKAONS+1
 
 * UPDATE PION COUNTER
 * 7. FOR PION+
         IF(LB1.EQ.5)LP1=LP1+1
 * 8. FOR PION0
         IF(LB1.EQ.4)LP2=LP2+1
 * 9. FOR PION-
         IF(LB1.EQ.3)LP3=LP3+1
 201     CONTINUE
         LP=LP1+LP2+LP3
         LD=LD1+LD2+LD3+LD4
         LN=LN1+LN2
         ALP=FLOAT(LP)/FLOAT(NUM)
         ALD=FLOAT(LD)/FLOAT(NUM)
         ALN=FLOAT(LN)/FLOAT(NUM)
        ALN5=FLOAT(LN5)/FLOAT(NUM)
         ATOTAL=ALP+ALD+ALN+0.5*ALN5
        ALE=FLOAT(LE)/FLOAT(NUM)
        ALKAON=FLOAT(LKAON)/FLOAT(NUM)
 * UPDATE MOMENTUM DUE TO COULOMB INTERACTION 
         if (icou .eq. 1) then
 *       with Coulomb interaction
           iso=0
           do 1026 irun = 1,num
             iso=iso+massr(irun-1)
             do 1021 il = 1,massr(irun)
                temp(1,il) = 0.
                temp(2,il) = 0.
                temp(3,il) = 0.
  1021       continue
             do 1023 il = 1, massr(irun)
               i=iso+il
               if (zet(lb(i)).ne.0) then
                 do 1022 jl = 1,il-1
                   j=iso+jl
                   if (zet(lb(j)).ne.0) then
                     ddx=r(1,i)-r(1,j)
                     ddy=r(2,i)-r(2,j)
                     ddz=r(3,i)-r(3,j)
                     rdiff = sqrt(ddx**2+ddy**2+ddz**2)
                     if (rdiff .le. 1.) rdiff = 1.
                     grp=zet(lb(i))*zet(lb(j))/rdiff**3
                     ddx=ddx*grp
                     ddy=ddy*grp
                     ddz=ddz*grp
                     temp(1,il)=temp(1,il)+ddx
                     temp(2,il)=temp(2,il)+ddy
                     temp(3,il)=temp(3,il)+ddz
                     temp(1,jl)=temp(1,jl)-ddx
                     temp(2,jl)=temp(2,jl)-ddy
                     temp(3,jl)=temp(3,jl)-ddz
                   end if
  1022          continue
               end if
  1023      continue
             do 1025 il = 1,massr(irun)
               i= iso+il
               if (zet(lb(i)).ne.0) then
                 do 1024 idir = 1,3
                   p(idir,i) = p(idir,i) + temp(idir,il)
      &                                    * dt * 0.00144
  1024          continue
               end if
  1025      continue
  1026   continue
         end if
 *       In the following, we shall:  
 *       (1) UPDATE MOMENTA DUE TO THE MEAN FIELD FOR BARYONS AND KAONS,
 *       (2) calculate the thermalization, temperature in a sphere of 
 *           radius 2.0 fm AROUND THE CM
 *       (3) AND CALCULATE THE NUMBER OF PARTICLES IN THE HIGH DENSITY REGION 
        spt=0
        spz=0
        ncen=0
        ekin=0
           NLOST = 0
           MEAN=0
          nquark=0
          nbaryn=0
 csp06/18/01
            rads = 2.
            zras = 0.1
            denst = 0.
            edenst = 0.
 csp06/18/01 end
           DO 6000 IRUN = 1,NUM
           MEAN=MEAN+MASSR(IRUN-1)
           DO 5800 J = 1,MASSR(irun)
           I=J+MEAN
 c
 csp06/18/01
            radut = sqrt(r(1,i)**2+r(2,i)**2)
        if( radut .le. rads )then
         if( abs(r(3,i)) .le. zras*nt*dt )then
 c         vols = 3.14159*radut**2*abs(r(3,i))      ! cylinder pi*r^2*l
 c     cylinder pi*r^2*l
          vols = 3.14159*rads**2*zras
          engs=sqrt(p(1,i)**2+p(2,i)**2+p(3,i)**2+e(i)**2)
          gammas=1.
          if(e(i).ne.0.)gammas=engs/e(i)
 c     rho
          denst = denst + 1./gammas/vols
 c     energy density
          edenst = edenst + engs/gammas/gammas/vols
         endif
        endif
 csp06/18/01 end
 c
          drr=sqrt(r(1,i)**2+r(2,i)**2+r(3,i)**2)
          if(drr.le.2.0)then
          spt=spt+p(1,i)**2+p(2,i)**2
          spz=spz+p(3,i)**2
          ncen=ncen+1
          ekin=ekin+sqrt(p(1,i)**2+p(2,i)**2+p(3,i)**2+e(i)**2)-e(i)
          endif
               IX = NINT( R(1,I) )
               IY = NINT( R(2,I) )
               IZ = NINT( R(3,I) )
 C calculate the No. of particles in the high density region
 clin-4/2008:
 c              IF (ABS(IX) .LT. MAXX .AND. ABS(IY) .LT. MAXX .AND.
 c     & ABS(IZ) .LT. MAXZ) THEN
               IF(IX.LT.MAXX.AND.IY.LT.MAXX.AND.IZ.LT.MAXZ
      1          .AND.IX.GT.-MAXX.AND.IY.GT.-MAXX.AND.IZ.GT.-MAXZ) THEN
        if(rho(ix,iy,iz)/0.168.gt.dencut)go to 5800
        if((rho(ix,iy,iz)/0.168.gt.5.).and.(e(i).gt.0.9))
      &  nbaryn=nbaryn+1
        if(pel(ix,iy,iz).gt.2.0)nquark=nquark+1
        endif
 c*
 c If there is a kaon potential, propogating kaons 
         if(kpoten.ne.0.and.lb(i).eq.23)then
         den=0.
 clin-4/2008:
 c       IF (ABS(IX) .LT. MAXX .AND. ABS(IY) .LT. MAXX .AND.
 c     & ABS(IZ) .LT. MAXZ)then
         IF(IX.LT.MAXX.AND.IY.LT.MAXX.AND.IZ.LT.MAXZ
      1       .AND.IX.GT.-MAXX.AND.IY.GT.-MAXX.AND.IZ.GT.-MAXZ) THEN
            den=rho(ix,iy,iz)
 c        ecor=0.1973**2*0.255*kmul*4*3.14159*(1.+0.4396/0.938)
 c       etotal=sqrt(P(1,i)**2+p(2,I)**2+p(3,i)**2+e(i)**2+ecor*den)
 c** for G.Q Li potential form with n_s = n_b and pot(n_0)=29 MeV
 c     !! GeV^2 fm^3
             akg = 0.1727
 c     !! GeV fm^3
             bkg = 0.333
           rnsg = den
           ecor = - akg*rnsg + (bkg*den)**2
           etotal = sqrt(P(1,i)**2+p(2,I)**2+p(3,i)**2+e(i)**2 + ecor)
           ecor = - akg + 2.*bkg**2*den + 2.*bkg*etotal
 c** G.Q. Li potential (END)           
         CALL GRADUK(IX,IY,IZ,GRADXk,GRADYk,GRADZk)
         P(1,I) = P(1,I) - DT * GRADXk*ecor/(2.*etotal)
         P(2,I) = P(2,I) - DT * GRADYk*ecor/(2.*etotal)
         P(3,I) = P(3,I) - DT * GRADZk*ecor/(2.*etotal)
         endif
          endif
 c
         if(kpoten.ne.0.and.lb(i).eq.21)then
          den=0.
 clin-4/2008:
 c           IF (ABS(IX) .LT. MAXX .AND. ABS(IY) .LT. MAXX .AND.
 c     &        ABS(IZ) .LT. MAXZ)then
          IF(IX.LT.MAXX.AND.IY.LT.MAXX.AND.IZ.LT.MAXZ
      1        .AND.IX.GT.-MAXX.AND.IY.GT.-MAXX.AND.IZ.GT.-MAXZ) THEN
                den=rho(ix,iy,iz)
         CALL GRADUK(IX,IY,IZ,GRADXk,GRADYk,GRADZk)
 c        P(1,I) = P(1,I) - DT * GRADXk*(-0.12/0.168)    !! song potential
 c        P(2,I) = P(2,I) - DT * GRADYk*(-0.12/0.168)
 c        P(3,I) = P(3,I) - DT * GRADZk*(-0.12/0.168)
 c** for G.Q Li potential form with n_s = n_b and pot(n_0)=29 MeV
 c    !! GeV^2 fm^3
             akg = 0.1727
 c     !! GeV fm^3
             bkg = 0.333
           rnsg = den
           ecor = - akg*rnsg + (bkg*den)**2
           etotal = sqrt(P(1,i)**2+p(2,I)**2+p(3,i)**2+e(i)**2 + ecor)
           ecor = - akg + 2.*bkg**2*den - 2.*bkg*etotal
         P(1,I) = P(1,I) - DT * GRADXk*ecor/(2.*etotal)
         P(2,I) = P(2,I) - DT * GRADYk*ecor/(2.*etotal)
         P(3,I) = P(3,I) - DT * GRADZk*ecor/(2.*etotal)
 c** G.Q. Li potential (END)           
         endif
          endif
 c
 c for other mesons, there is no potential
        if(j.gt.mass)go to 5800         
 c  with mean field interaction for baryons   (open endif below) !!sp05
 **      if( (iabs(lb(i)).eq.1.or.iabs(lb(i)).eq.2) .or.
 **    &     (iabs(lb(i)).ge.6.and.iabs(lb(i)).le.17) .or.
 **    &      iabs(lb(i)).eq.40.or.iabs(lb(i)).eq.41 )then  
         IF (ICOLL .NE. -1) THEN
 * check if the baryon has run off the lattice
 *             IX0=NINT(R(1,I)/DX)
 *             IY0=NINT(R(2,I)/DY)
 *             IZ0=NINT(R(3,I)/DZ)
 *             IPX0=NINT(P(1,I)/DPX)
 *             IPY0=NINT(P(2,I)/DPY)
 *             IPZ0=NINT(P(3,I)/DPZ)
 *      if ( (abs(ix0).gt.mx) .or. (abs(iy0).gt.my) .or. (abs(iz0).gt.mz)
 *     &  .or. (abs(ipx0).gt.mpx) .or. (abs(ipy0) 
 *     &  .or. (ipz0.lt.-mpz) .or. (ipz0.gt.mpzp)) NLOST=NLOST+1
 clin-4/2008:
 c              IF (ABS(IX) .LT. MAXX .AND. ABS(IY) .LT. MAXX .AND.
 c     &                                    ABS(IZ) .LT. MAXZ     ) THEN
            IF(IX.LT.MAXX.AND.IY.LT.MAXX.AND.IZ.LT.MAXZ
      1          .AND.IX.GT.-MAXX.AND.IY.GT.-MAXX.AND.IZ.GT.-MAXZ) THEN
                 CALL GRADU(IPOT,IX,IY,IZ,GRADX,GRADY,GRADZ)
               TZ=0.
               GRADXN=0
               GRADYN=0
               GRADZN=0
               GRADXP=0
               GRADYP=0
               GRADZP=0
              IF(ICOU.EQ.1)THEN
                 CALL GRADUP(IX,IY,IZ,GRADXP,GRADYP,GRADZP)
                 CALL GRADUN(IX,IY,IZ,GRADXN,GRADYN,GRADZN)
                IF(ZET(LB(I)).NE.0)TZ=-1
                IF(ZET(LB(I)).EQ.0)TZ= 1
              END IF
            if(iabs(lb(i)).ge.14.and.iabs(lb(i)).le.17)then
               facl = 2./3.
             elseif(iabs(lb(i)).eq.40.or.iabs(lb(i)).eq.41)then
               facl = 1./3.
             else
               facl = 1.
             endif
         P(1,I) = P(1,I) - facl*DT * (GRADX+asy*(GRADXN-GRADXP)*TZ)
         P(2,I) = P(2,I) - facl*DT * (GRADY+asy*(GRADYN-GRADYP)*TZ)
         P(3,I) = P(3,I) - facl*DT * (GRADZ+asy*(GRADZN-GRADZP)*TZ)
                 end if                                                       
               ENDIF
 **          endif          !!sp05     
  5800       CONTINUE
  6000       CONTINUE
 c print out the average no. of particles in regions where the local 
 c baryon density is higher than 5*rho0 
 c       write(1072,'(e10.3,2x,e10.3)')nt*dt,float(nbaryn)/float(num)
 C print out the average no. of particles in regions where the local 
 c energy density is higher than 2 GeV/fm^3. 
 c       write(1073,'(e10.3,2x,e10.3)')nt*dt,float(nquark)/float(num)
 c print out the no. of particles that have run off the lattice
 *          IF (NLOST .NE. 0 .AND. (NT/NFREQ)*NFREQ .EQ. NT) THEN
 *            WRITE(12,'(5X,''***'',I7,'' TESTPARTICLES LOST AFTER '',
 *     &                   ''TIME STEP NUMBER'',I4)') NLOST, NT
 *         END IF
 *
 *       update phase space density
 *        call platin(mode,mass,num,dx,dy,dz,dpx,dpy,dpz,fnorm)
 *
 *       CONTROL-PRINTOUT OF CONFIGURATION (IF REQUIRED)
 *
 *        if (inout(5) .eq. 2) CALL ENERGY(NT,IPOT,NUM,MASS,EMIN,EMAX)
 *
 * 
 * print out central baryon density as a function of time
        CDEN=RHO(0,0,0)/0.168
 cc        WRITE(1002,990)FLOAT(NT)*DT,CDEN
 c        WRITE(1002,1990)FLOAT(NT)*DT,CDEN,denst/real(num)
 * print out the central energy density as a function of time
 cc        WRITE(1003,990)FLOAT(NT)*DT,PEL(0,0,0)
 c        WRITE(1003,1990)FLOAT(NT)*DT,PEL(0,0,0),edenst/real(num)
 * print out the no. of pion-like particles as a function of time 
 c        WRITE(1004,9999)FLOAT(NT)*DT,ALD,ALN,ALP,ALN5,
 c     &               ALD+ALN+ALP+0.5*ALN5
 * print out the no. of eta-like particles as a function of time
 c        WRITE(1005,991)FLOAT(NT)*DT,ALN5,ALE,ALE+0.5*ALN5
 c990       FORMAT(E10.3,2X,E10.3)
 c1990       FORMAT(E10.3,2X,E10.3,2X,E10.3)
 c991       FORMAT(E10.3,2X,E10.3,2X,E10.3,2X,E10.3)
 c9999    FORMAT(e10.3,2X,e10.3,2X,E10.3,2X,E10.3,2X,
 c     1  E10.3,2X,E10.3)
 C THE FOLLOWING OUTPUTS CAN BE TURNED ON/OFF by setting icflow and icrho=0  
 c print out the baryon and meson density matrix in the reaction plane
         IF ((NT/NFREQ)*NFREQ .EQ. NT ) THEN
        if(icflow.eq.1)call flow(nt)
 cbz11/18/98
 c       if(icrho.ne.1)go to 10000 
 c       if (icrho .eq. 1) then 
 cbz11/18/98end
 c       do ix=-10,10
 c       do iz=-10,10
 c       write(1053,992)ix,iz,rho(ix,0,iz)/0.168
 c       write(1054,992)ix,iz,pirho(ix,0,iz)/0.168
 c       write(1055,992)ix,iz,pel(ix,0,iz)
 c       end do
 c       end do
 cbz11/18/98
 c        end if
 cbz11/18/98end
 c992       format(i3,i3,e11.4)
        endif
 c print out the ENERGY density matrix in the reaction plane
 C CHECK LOCAL MOMENTUM EQUILIBRIUM IN EACH CELL, 
 C AND PERFORM ON-LINE FLOW ANALYSIS AT A FREQUENCY OF NFREQ
 c        IF ((NT/NFREQ)*NFREQ .EQ. NT ) THEN
 c       call flow(nt)
 c       call equ(ipot,mass,num,outpar)
 c       do ix=-10,10
 c       do iz=-10,10
 c       write(1055,992)ix,iz,pel(ix,0,iz)
 c       write(1056,992)ix,iz,rxy(ix,0,iz)
 c       end do
 c       end do
 c       endif
 C calculate the volume of high BARYON AND ENERGY density 
 C matter as a function of time
 c       vbrho=0.
 c       verho=0.
 c       do ix=-20,20
 c       do iy=-20,20
 c       do iz=-20,20
 c       if(rho(ix,iy,iz)/0.168.gt.5.)vbrho=vbrho+1.
 c       if(pel(ix,iy,iz).gt.2.)verho=verho+1.
 c       end do
 c       end do
 c       end do
 c       write(1081,993)dt*nt,vbrho
 c       write(1082,993)dt*nt,verho
 c993       format(e11.4,2x,e11.4)
 *-----------------------------------------------------------------------
 cbz11/16/98
 c.....for read-in initial conditions produce particles from read-in 
 c.....common block.
 c.....note that this part is only for cascade with number of test particles
 c.....NUM = 1.
       IF (IAPAR2(1) .NE. 1) THEN
          CT = NT * DT
 cbz12/22/98
 c         NP = MASSR(1)
 c         DO WHILE (FTAR(NPI) .GT. CT - DT .AND. FTAR(NPI) .LE. CT)
 c            NP = NP + 1
 c            R(1, NP) = GXAR(NPI) + PXAR(NPI) / PEAR(NPI) * (CT - FTAR(NPI))
 c            R(2, NP) = GYAR(NPI) + PYAR(NPI) / PEAR(NPI) * (CT - FTAR(NPI))
 c            R(3, NP) = GZAR(NPI) + PZAR(NPI) / PEAR(NPI) * (CT - FTAR(NPI))
 c            P(1, NP) = PXAR(NPI)
 c            P(2, NP) = PYAR(NPI)
 c            P(3, NP) = PZAR(NPI)
 c            E(NP) = XMAR(NPI)
 c            LB(NP) = IARFLV(ITYPAR(NPI))
 c            NPI = NPI + 1
 c         END DO
 c         MASSR(1) = NP
          IA = 0
          DO 1028 IRUN = 1, NUM
             DO 1027 IC = 1, MASSR(IRUN)
                IE = IA + IC
                RT(1, IC, IRUN) = R(1, IE)
                RT(2, IC, IRUN) = R(2, IE)
                RT(3, IC, IRUN) = R(3, IE)
                PT(1, IC, IRUN) = P(1, IE)
                PT(2, IC, IRUN) = P(2, IE)
                PT(3, IC, IRUN) = P(3, IE)
                ET(IC, IRUN) = E(IE)
                LT(IC, IRUN) = LB(IE)
 c         !! sp 12/19/00
                PROT(IC, IRUN) = PROPER(IE)
 clin-5/2008:
                dpertt(IC, IRUN)=dpertp(IE)
  1027       CONTINUE
             NP = MASSR(IRUN)
             NP1 = NPI(IRUN)
 
 cbz10/05/99
 c            DO WHILE (FT1(NP1, IRUN) .GT. CT - DT .AND. 
 c     &           FT1(NP1, IRUN) .LE. CT)
 cbz10/06/99
 c            DO WHILE (NPI(IRUN).LE.MULTI1(IRUN).AND.
 cbz10/06/99 end
 clin-11/13/00 finally read in all unformed particles and do the decays in ART:
 c           DO WHILE (NP1.LE.MULTI1(IRUN).AND.
 c    &           FT1(NP1, IRUN) .GT. CT - DT .AND. 
 c    &           FT1(NP1, IRUN) .LE. CT)
 c
                ctlong = ct
              if(nt .eq. (ntmax-1))then
                ctlong = 1.E30
              elseif(nt .eq. ntmax)then
                go to 1111
              endif
             DO WHILE (NP1.LE.MULTI1(IRUN).AND.
      &           FT1(NP1, IRUN) .GT. (CT - DT) .AND. 
      &           FT1(NP1, IRUN) .LE. ctlong)
                NP = NP + 1
                UDT = (CT - FT1(NP1, IRUN)) / EE1(NP1, IRUN)
 clin-10/28/03 since all unformed hadrons at time ct are read in at nt=ntmax-1, 
 c     their positions should not be propagated to time ct:
                if(nt.eq.(ntmax-1)) then
                   ftsvt(NP,IRUN)=FT1(NP1, IRUN)
                   if(FT1(NP1, IRUN).gt.ct) UDT=0.
                endif
                RT(1, NP, IRUN) = GX1(NP1, IRUN) + 
      &              PX1(NP1, IRUN) * UDT
                RT(2, NP, IRUN) = GY1(NP1, IRUN) + 
      &              PY1(NP1, IRUN) * UDT
                RT(3, NP, IRUN) = GZ1(NP1, IRUN) + 
      &              PZ1(NP1, IRUN) * UDT
                PT(1, NP, IRUN) = PX1(NP1, IRUN)
                PT(2, NP, IRUN) = PY1(NP1, IRUN)
                PT(3, NP, IRUN) = PZ1(NP1, IRUN)
                ET(NP, IRUN) = XM1(NP1, IRUN)
                LT(NP, IRUN) = IARFLV(ITYP1(NP1, IRUN))
 clin-5/2008:
                dpertt(NP,IRUN)=dpp1(NP1,IRUN)
 clin-4/30/03 ctest off 
 c     record initial phi,K*,Lambda(1520) resonances formed during the timestep:
 c               if(LT(NP, IRUN).eq.29.or.iabs(LT(NP, IRUN)).eq.30)
 c     1              write(17,112) 'formed',LT(NP, IRUN),PX1(NP1, IRUN),
 c     2 PY1(NP1, IRUN),PZ1(NP1, IRUN),XM1(NP1, IRUN),nt
 c 112           format(a10,1x,I4,4(1x,f9.3),1x,I4)
 c
                NP1 = NP1 + 1
 c     !! sp 12/19/00
                PROT(NP, IRUN) = 1.
             END DO
 *
  1111      continue
             NPI(IRUN) = NP1
             IA = IA + MASSR(IRUN)
             MASSR(IRUN) = NP
  1028    CONTINUE
          IA = 0
          DO 1030 IRUN = 1, NUM
             IA = IA + MASSR(IRUN - 1)
             DO 1029 IC = 1, MASSR(IRUN)
                IE = IA + IC
                R(1, IE) = RT(1, IC, IRUN)
                R(2, IE) = RT(2, IC, IRUN)
                R(3, IE) = RT(3, IC, IRUN)
                P(1, IE) = PT(1, IC, IRUN)
                P(2, IE) = PT(2, IC, IRUN)
                P(3, IE) = PT(3, IC, IRUN)
                E(IE) = ET(IC, IRUN)
                LB(IE) = LT(IC, IRUN)
 c     !! sp 12/19/00
                PROPER(IE) = PROT(IC, IRUN)
                if(nt.eq.(ntmax-1)) ftsv(IE)=ftsvt(IC,IRUN)
 clin-5/2008:
                dpertp(IE)=dpertt(IC, IRUN)
  1029       CONTINUE
 clin-3/2009 Moved here to better take care of freezeout spacetime:
             call hbtout(MASSR(IRUN),nt,ntmax)
  1030    CONTINUE
 cbz12/22/98end
       END IF
 cbz11/16/98end
 
 clin-5/2009 ctest off:
 c      call flowh(ct) 
 
 10000       continue
 
 *                                                                      *
 *       ==============  END OF TIME STEP LOOP   ================       *
 
 ************************************
 *     WRITE OUT particle's MOMENTA ,and/OR COORDINATES ,
 *     label and/or their local baryon density in the final state
         iss=0
         do 1032 lrun=1,num
            iss=iss+massr(lrun-1)
            do 1031 l0=1,massr(lrun)
               ipart=iss+l0
  1031      continue
  1032   continue
 
 cbz11/16/98
       IF (IAPAR2(1) .NE. 1) THEN
 cbz12/22/98
 c        NSH = MASSR(1) - NPI + 1
 c        IAINT2(1) = IAINT2(1) + NSH
 c.....to shift the unformed particles to the end of the common block
 c        IF (NSH .GT. 0) THEN
 c           IB = IAINT2(1)
 c           IE = MASSR(1) + 1
 c           II = -1
 c        ELSE IF (NSH .LT. 0) THEN
 c           IB = MASSR(1) + 1
 c           IE = IAINT2(1)
 c           II = 1
 c        END IF
 c        IF (NSH .NE. 0) THEN
 c           DO I = IB, IE, II
 c              J = I - NSH
 c              ITYPAR(I) = ITYPAR(J)
 c              GXAR(I) = GXAR(J)
 c              GYAR(I) = GYAR(J)
 c              GZAR(I) = GZAR(J)
 c              FTAR(I) = FTAR(J)
 c              PXAR(I) = PXAR(J)
 c              PYAR(I) = PYAR(J)
 c              PZAR(I) = PZAR(J)
 c              PEAR(I) = PEAR(J)
 c              XMAR(I) = XMAR(J)
 c           END DO
 c        END IF
 
 c.....to copy ART particle info to COMMON /ARPRC/
 c        DO I = 1, MASSR(1)
 c           ITYPAR(I) = INVFLV(LB(I))
 c           GXAR(I) = R(1, I)
 c           GYAR(I) = R(2, I)
 c           GZAR(I) = R(3, I)
 c           FTAR(I) = CT
 c           PXAR(I) = P(1, I)
 c           PYAR(I) = P(2, I)
 c           PZAR(I) = P(3, I)
 c           XMAR(I) = E(I)
 c           PEAR(I) = SQRT(PXAR(I) ** 2 + PYAR(I) ** 2 + PZAR(I) ** 2
 c     &        + XMAR(I) ** 2)
 c        END DO
         IA = 0
         DO 1035 IRUN = 1, NUM
            IA = IA + MASSR(IRUN - 1)
            NP1 = NPI(IRUN)
            NSH = MASSR(IRUN) - NP1 + 1
            MULTI1(IRUN) = MULTI1(IRUN) + NSH
 c.....to shift the unformed particles to the end of the common block
            IF (NSH .GT. 0) THEN
               IB = MULTI1(IRUN)
               IE = MASSR(IRUN) + 1
               II = -1
            ELSE IF (NSH .LT. 0) THEN
               IB = MASSR(IRUN) + 1
               IE = MULTI1(IRUN)
               II = 1
            END IF
            IF (NSH .NE. 0) THEN
               DO 1033 I = IB, IE, II
                  J = I - NSH
                  ITYP1(I, IRUN) = ITYP1(J, IRUN)
                  GX1(I, IRUN) = GX1(J, IRUN)
                  GY1(I, IRUN) = GY1(J, IRUN)
                  GZ1(I, IRUN) = GZ1(J, IRUN)
                  FT1(I, IRUN) = FT1(J, IRUN)
                  PX1(I, IRUN) = PX1(J, IRUN)
                  PY1(I, IRUN) = PY1(J, IRUN)
                  PZ1(I, IRUN) = PZ1(J, IRUN)
                  EE1(I, IRUN) = EE1(J, IRUN)
                  XM1(I, IRUN) = XM1(J, IRUN)
 c     !! sp 12/19/00
                  PRO1(I, IRUN) = PRO1(J, IRUN)
 clin-5/2008:
                  dpp1(I,IRUN)=dpp1(J,IRUN)
  1033         CONTINUE
            END IF
            
 c.....to copy ART particle info to COMMON /ARPRC1/
            DO 1034 I = 1, MASSR(IRUN)
               IB = IA + I
               ITYP1(I, IRUN) = INVFLV(LB(IB))
               GX1(I, IRUN) = R(1, IB)
               GY1(I, IRUN) = R(2, IB)
               GZ1(I, IRUN) = R(3, IB)
 clin-10/28/03:
 c since all unformed hadrons at time ct are read in at nt=ntmax-1, 
 c their formation time ft1 should be kept to determine their freezeout(x,t):
 c              FT1(I, IRUN) = CT
               if(FT1(I, IRUN).lt.CT) FT1(I, IRUN) = CT
               PX1(I, IRUN) = P(1, IB)
               PY1(I, IRUN) = P(2, IB)
               PZ1(I, IRUN) = P(3, IB)
               XM1(I, IRUN) = E(IB)
               EE1(I, IRUN) = SQRT(PX1(I, IRUN) ** 2 + 
      &             PY1(I, IRUN) ** 2 +
      &             PZ1(I, IRUN) ** 2 + 
      &             XM1(I, IRUN) ** 2)
 c     !! sp 12/19/00
               PRO1(I, IRUN) = PROPER(IB)
  1034      CONTINUE
  1035   CONTINUE
 cbz12/22/98end
       END IF
 cbz11/16/98end
 c
 **********************************
 *                                                                      *
 *       ======= END OF MANY LOOPS OVER IMPACT PARAMETERS ==========    *
 *                                                               *
 **********************************
 50000   CONTINUE
 *
 *-----------------------------------------------------------------------
 *                       ==== ART COMPLETED ====
 *-----------------------------------------------------------------------
 cbz11/16/98
 c      STOP
       RETURN
 cbz11/16/98end
       END
 **********************************
       subroutine coulin(masspr,massta,NUM)
 *                                                                      *
 *     purpose:   initialization of array zet() and lb() for all runs  *
 *                lb(i) = 1   =>  proton                               *
 *                lb(i) = 2   =>  neutron                              *
 **********************************
         integer  zta,zpr
         PARAMETER (MAXSTR=150001)
         common  /EE/ ID(MAXSTR),LB(MAXSTR)
 cc      SAVE /EE/
         COMMON  /ZZ/ ZTA,ZPR
 cc      SAVE /zz/
       SAVE   
         MASS=MASSTA+MASSPR
         DO 500 IRUN=1,NUM
         do 100 i = 1+(IRUN-1)*MASS,zta+(IRUN-1)*MASS
         LB(i) = 1
   100   continue
         do 200 i = zta+1+(IRUN-1)*MASS,massta+(IRUN-1)*MASS
         LB(i) = 2
   200   continue
         do 300 i = massta+1+(IRUN-1)*MASS,massta+zpr+(IRUN-1)*MASS
         LB(i) = 1
   300   continue
         do 400 i = massta+zpr+1+(IRUN-1)*MASS,
      1  massta+masspr+(IRUN-1)*MASS
         LB(i) = 2
   400   continue
   500   CONTINUE
         return
         end
 **********************************
 *                                                                      *
       SUBROUTINE RELCOL(LCOLL,LBLOC,LCNNE,LDD,LPP,lppk,
      &LPN,lpd,lrho,lomega,LKN,LNNK,LDDK,LNDK,LCNND,LCNDN,
      &LDIRT,LDECAY,LRES,LDOU,LDDRHO,LNNRHO,LNNOM,
      &NT,ntmax,sp,akaon,sk)
 *                                                                      *
 *       PURPOSE:    CHECK CONDITIONS AND CALCULATE THE KINEMATICS      * 
 *                   FOR BINARY COLLISIONS AMONG PARTICLES              *
 *                                 - RELATIVISTIC FORMULA USED          *
 *                                                                      *
 *       REFERENCES: HAGEDORN, RELATIVISTIC KINEMATICS (1963)           *
 *                                                                      *
 *       VARIABLES:                                                     *
 *         MASSPR  - NUMBER OF NUCLEONS IN PROJECTILE   (INTEGER,INPUT) *
 *         MASSTA  - NUMBER OF NUCLEONS IN TARGET       (INTEGER,INPUT) *
 *         NUM     - NUMBER OF TESTPARTICLES PER NUCLEON(INTEGER,INPUT) *
 *         ISEED   - SEED FOR RANDOM NUMBER GENERATOR   (INTEGER,INPUT) *
 *         IAVOID  - (= 1 => AVOID FIRST CLLISIONS WITHIN THE SAME      *
 *                   NUCLEUS, ELSE ALL COLLISIONS)      (INTEGER,INPUT) *
 *         DELTAR  - MAXIMUM SPATIAL DISTANCE FOR WHICH A COLLISION     *
 *                   STILL CAN OCCUR                       (REAL,INPUT) *
 *         DT      - TIME STEP SIZE                        (REAL,INPUT) *
 *         LCOLL   - NUMBER OF COLLISIONS              (INTEGER,OUTPUT) *
 *         LBLOC   - NUMBER OF PULI-BLOCKED COLLISIONS (INTEGER,OUTPUT) *
 *         LCNNE   - NUMBER OF ELASTIC COLLISION       (INTEGER,OUTPUT) *
 *         LCNND   - NUMBER OF N+N->N+DELTA REACTION   (INTEGER,OUTPUT) *
 *         LCNDN   - NUMBER OF N+DELTA->N+N REACTION   (INTEGER,OUTPUT) *
 *         LDD     - NUMBER OF RESONANCE+RESONANCE COLLISIONS
 *         LPP     - NUMBER OF PION+PION elastic COLIISIONS
 *         lppk    - number of pion(RHO,OMEGA)+pion(RHO,OMEGA)
 *                   -->K+K- collisions
 *         LPN     - NUMBER OF PION+N-->KAON+X
 *         lpd     - number of pion+n-->delta+pion
 *         lrho    - number of pion+n-->Delta+rho
 *         lomega  - number of pion+n-->Delta+omega
 *         LKN     - NUMBER OF KAON RESCATTERINGS
 *         LNNK    - NUMBER OF bb-->kAON PROCESS
 *         LDDK    - NUMBER OF DD-->KAON PROCESS
 *         LNDK    - NUMBER OF ND-->KAON PROCESS
 *         LB(I) IS USED TO LABEL PARTICLE'S CHARGE STATE
 *         LB(I)   = 
 cbali2/7/99 
 *                 -45 Omega baryon(bar)
 *                 -41 cascade0(bar)
 *                 -40 cascade-(bar)
 clin-11/07/00:
 *                 -30 K*-
 *                 -17 sigma+(bar)
 *                 -16 sigma0(bar)
 *                 -15 sigma-(bar)
 *                 -14 LAMBDA(bar)
 clin-8/29/00
 *                 -13 anti-N*(+1)(1535),s_11
 *                 -12 anti-N*0(1535),s_11
 *                 -11 anti-N*(+1)(1440),p_11
 *                 -10 anti-N*0(1440), p_11
 *                  -9 anti-DELTA+2
 *                  -8 anti-DELTA+1
 *                  -7 anti-DELTA0
 *                  -6 anti-DELTA-1
 *
 *                  -2 antineutron 
 *                  -1 antiproton
 cbali2/7/99end 
 *                   0 eta
 *                   1 PROTON
 *                   2 NUETRON
 *                   3 PION-
 *                   4 PION0
 *                   5 PION+          
 *                   6 DELTA-1
 *                   7 DELTA0
 *                   8 DELTA+1
 *                   9 DELTA+2
 *                   10 N*0(1440), p_11
 *                   11 N*(+1)(1440),p_11
 *                  12 N*0(1535),s_11
 *                  13 N*(+1)(1535),s_11
 *                  14 LAMBDA
 *                   15 sigma-
 *                   16 sigma0
 *                   17 sigma+
 *                   21 kaon-
 clin-2/23/03        22 Kaon0Long (converted at the last timestep)
 *                   23 KAON+
 *                   24 Kaon0short (converted at the last timestep then decay)
 *                   25 rho-
 *                   26 rho0
 *                   27 rho+
 *                   28 omega meson
 *                   29 phi
 *                   30 K*+
 * sp01/03/01
 *                   31 eta-prime
 *                   40 cascade-
 *                   41 cascade0
 *                   45 Omega baryon
 * sp01/03/01 end
 *                   
 *                   ++  ------- SEE NOTE BOOK
 *         NSTAR=1 INCLUDING N* RESORANCE
 *         ELSE DELTA RESORANCE ONLY
 *         NDIRCT=1 INCLUDING DIRECT PROCESS,ELSE NOT
 *         DIR - PERCENTAGE OF DIRECT PION PRODUCTION PROCESS
 **********************************
       PARAMETER      (MAXSTR=150001,MAXR=1,PI=3.1415926)
       parameter      (MX=4,MY=4,MZ=8,MPX=4,MPY=4,mpz=10,mpzp=10)
       PARAMETER      (AKA=0.498,ALA=1.1157,ASA=1.1974,aks=0.895)
       PARAMETER      (AA1=1.26,APHI=1.02,AP1=0.13496)
       parameter            (maxx=20,maxz=24)
       parameter            (rrkk=0.6,prkk=0.3,srhoks=5.,ESBIN=0.04)
       DIMENSION MASSRN(0:MAXR),RT(3,MAXSTR),PT(3,MAXSTR),ET(MAXSTR)
       DIMENSION LT(MAXSTR), PROT(MAXSTR)
       COMMON   /AA/  R(3,MAXSTR)
 cc      SAVE /AA/
       COMMON   /BB/  P(3,MAXSTR)
 cc      SAVE /BB/
       COMMON   /CC/  E(MAXSTR)
 cc      SAVE /CC/
       COMMON  /DD/      RHO(-MAXX:MAXX,-MAXX:MAXX,-MAXZ:MAXZ),
      &                     RHOP(-MAXX:MAXX,-MAXX:MAXX,-MAXZ:MAXZ),
      &                     RHON(-MAXX:MAXX,-MAXX:MAXX,-MAXZ:MAXZ)
 cc      SAVE /DD/
       COMMON   /EE/  ID(MAXSTR),LB(MAXSTR)
 cc      SAVE /EE/
       COMMON   /HH/  PROPER(MAXSTR)
 cc      SAVE /HH/
       common /ff/f(-mx:mx,-my:my,-mz:mz,-mpx:mpx,-mpy:mpy,-mpz:mpzp)
 cc      SAVE /ff/
       common   /gg/  dx,dy,dz,dpx,dpy,dpz
 cc      SAVE /gg/
       COMMON   /INPUT/ NSTAR,NDIRCT,DIR
 cc      SAVE /INPUT/
       COMMON   /NN/NNN
 cc      SAVE /NN/
       COMMON   /RR/  MASSR(0:MAXR)
 cc      SAVE /RR/
       common   /ss/  inout(20)
 cc      SAVE /ss/
       COMMON   /BG/BETAX,BETAY,BETAZ,GAMMA
 cc      SAVE /BG/
       COMMON   /RUN/NUM
 cc      SAVE /RUN/
       COMMON   /PA/RPION(3,MAXSTR,MAXR)
 cc      SAVE /PA/
       COMMON   /PB/PPION(3,MAXSTR,MAXR)
 cc      SAVE /PB/
       COMMON   /PC/EPION(MAXSTR,MAXR)
 cc      SAVE /PC/
       COMMON   /PD/LPION(MAXSTR,MAXR)
 cc      SAVE /PD/
       COMMON   /PE/PROPI(MAXSTR,MAXR)
 cc      SAVE /PE/
       COMMON   /KKK/TKAON(7),EKAON(7,0:2000)
 cc      SAVE /KKK/
       COMMON  /KAON/    AK(3,50,36),SPECK(50,36,7),MF
 cc      SAVE /KAON/
       COMMON/TABLE/ xarray(0:1000),earray(0:1000)
 cc      SAVE /TABLE/
       common/input1/ MASSPR,MASSTA,ISEED,IAVOID,DT
 cc      SAVE /input1/
       common/leadng/lb1,px1,py1,pz1,em1,e1,xfnl,yfnl,zfnl,tfnl,
      1 px1n,py1n,pz1n,dp1n
 cc      SAVE /leadng/
       COMMON/tdecay/tfdcy(MAXSTR),tfdpi(MAXSTR,MAXR),tft(MAXSTR)
 cc      SAVE /tdecay/
       common /lastt/itimeh,bimp 
 cc      SAVE /lastt/
 c
       COMMON/ppbmas/niso(15),nstate,ppbm(15,2),thresh(15),weight(15)
 cc      SAVE /ppbmas/
       common/ppb1/ene,factr2(6),fsum,ppinnb,s,wtot
 cc      SAVE /ppb1/
       common/ppmm/pprr,ppee,pppe,rpre,xopoe,rree
 cc      SAVE /ppmm/
       COMMON/hbt/lblast(MAXSTR),xlast(4,MAXSTR),plast(4,MAXSTR),nlast
 cc      SAVE /hbt/
       common/resdcy/NSAV,iksdcy
 cc      SAVE /resdcy/
       COMMON/RNDF77/NSEED
 cc      SAVE /RNDF77/
       COMMON/FTMAX/ftsv(MAXSTR),ftsvt(MAXSTR, MAXR)
       dimension ftpisv(MAXSTR,MAXR),fttemp(MAXSTR)
       common /dpi/em2,lb2
       common/phidcy/iphidcy,pttrig,ntrig,maxmiss,ipi0dcy
 clin-5/2008:
       DIMENSION dptemp(MAXSTR)
       common /para8/ idpert,npertd,idxsec
       COMMON /dpert/dpertt(MAXSTR,MAXR),dpertp(MAXSTR),dplast(MAXSTR),
      1     dpdcy(MAXSTR),dpdpi(MAXSTR,MAXR),dpt(MAXSTR, MAXR),
      2     dpp1(MAXSTR,MAXR),dppion(MAXSTR,MAXR)
 c
       real zet(-45:45)
       SAVE   
       data zet /
      4     1.,0.,0.,0.,0.,
      3     1.,0.,0.,0.,0.,0.,0.,0.,0.,0.,
      2     -1.,0.,0.,0.,0.,0.,0.,0.,0.,0.,
      1     0.,0.,0.,-1.,0.,1.,0.,-1.,0.,-1.,
      s     0.,-2.,-1.,0.,1.,0.,0.,0.,0.,-1.,
      e     0.,
      s     1.,0.,-1.,0.,1.,-1.,0.,1.,2.,0.,
      1     1.,0.,1.,0.,-1.,0.,1.,0.,0.,0.,
      2     -1.,0.,1.,0.,-1.,0.,1.,0.,0.,1.,
      3     0.,0.,0.,0.,0.,0.,0.,0.,0.,-1.,
      4     0.,0.,0.,0.,-1./
 
 clin-2/19/03 initialize n and nsav for resonance decay at each timestep
 c     in order to prevent integer overflow:
       call inidcy
 
 c OFF skip ART collisions to reproduce HJ:      
 cc       if(nt.ne.ntmax) return
 
 clin-11/07/00 rrkk is assumed to be 0.6mb(default) for mm->KKbar 
 c     with m=rho or omega, estimated from Ko's paper:
 c      rrkk=0.6
 c prkk: cross section of pi (rho or omega) -> K* Kbar (AND) K*bar K:
 c      prkk=0.3
 c     cross section in mb for (rho or omega) K* -> pi K:
 c      srhoks=5.
 clin-11/07/00-end
 c      ESBIN=0.04
       RESONA=5.
 *-----------------------------------------------------------------------
 *     INITIALIZATION OF COUNTING VARIABLES
       NODELT=0
       SUMSRT =0.
       LCOLL  = 0
       LBLOC  = 0
       LCNNE  = 0
       LDD  = 0
       LPP  = 0
       lpd  = 0
       lpdr=0
       lrho = 0
       lrhor=0
       lomega=0
       lomgar=0
       LPN  = 0
       LKN  = 0
       LNNK = 0
       LDDK = 0
       LNDK = 0
       lppk =0
       LCNND  = 0
       LCNDN  = 0
       LDIRT  = 0
       LDECAY = 0
       LRES   = 0
       Ldou   = 0
       LDDRHO = 0
       LNNRHO = 0
       LNNOM  = 0
       MSUM   = 0
       MASSRN(0)=0
 * COM: MSUM IS USED TO COUNT THE TOTAL NO. OF PARTICLES 
 *      IN PREVIOUS IRUN-1 RUNS
 * KAON COUNTERS
       DO 1002 IL=1,5
          TKAON(IL)=0
          DO 1001 IS=1,2000
             EKAON(IL,IS)=0
  1001    CONTINUE
  1002 CONTINUE
 c sp 12/19/00
       DO 1004 i =1,NUM
          DO 1003 j =1,MAXSTR
             PROPI(j,i) = 1.
  1003    CONTINUE
  1004 CONTINUE
       
       do 1102 i=1,maxstr
          fttemp(i)=0.
          do 1101 irun=1,maxr
             ftpisv(i,irun)=0.
  1101    continue
  1102 continue
 
 c sp 12/19/00 end
       sp=0
 * antikaon counters
       akaon=0
       sk=0
 *-----------------------------------------------------------------------
 *     LOOP OVER ALL PARALLEL RUNS
 cbz11/17/98
 c      MASS=MASSPR+MASSTA
       MASS = 0
 cbz11/17/98end
       DO 1000 IRUN = 1,NUM
          NNN=0
          MSUM=MSUM+MASSR(IRUN-1)
 *     LOOP OVER ALL PSEUDOPARTICLES 1 IN THE SAME RUN
          J10=2
          IF(NT.EQ.NTMAX)J10=1
 c
 ctest off skips the check of energy conservation after each timestep:
 c         enetot=0.
 c         do ip=1,MASSR(IRUN)
 c            if(e(ip).ne.0.or.lb(ip).eq.10022) enetot=enetot
 c     1           +sqrt(p(1,ip)**2+p(2,ip)**2+p(3,ip)**2+e(ip)**2)
 c         enddo
 c         write(91,*) 'A:',nt,enetot,massr(irun),bimp 
 
          DO 800 J1 = J10,MASSR(IRUN)
             I1  = J1 + MSUM
 * E(I)=0 are for pions having been absorbed or photons which do not enter here:
 clin-4/2012 option of pi0 decays:
 c            IF(E(I1).EQ.0.)GO TO 800
             IF(E(I1).EQ.0.)GO TO 798
 c     To include anti-(Delta,N*1440 and N*1535):
 c          IF ((LB(I1) .LT. -13 .OR. LB(I1) .GT. 28)
 c     1         .and.iabs(LB(I1)) .ne. 30 ) GOTO 800
 clin-4/2012 option of pi0 decays:
 c            IF (LB(I1) .LT. -45 .OR. LB(I1) .GT. 45) GOTO 800
             IF (LB(I1) .LT. -45 .OR. LB(I1) .GT. 45) GOTO 798
             X1  = R(1,I1)
             Y1  = R(2,I1)
             Z1  = R(3,I1)
             PX1 = P(1,I1)
             PY1 = P(2,I1)
             PZ1 = P(3,I1)
             EM1 = E(I1)
             am1= em1
             E1  = SQRT( EM1**2 + PX1**2 + PY1**2 + PZ1**2 )
             ID1 = ID(I1)
             LB1 = LB(I1)
 
 c     generate k0short and k0long from K+ and K- at the last timestep:
             if(nt.eq.ntmax.and.(lb1.eq.21.or.lb1.eq.23)) then
                pk0=RANART(NSEED)
                if(pk0.lt.0.25) then
                   LB(I1)=22
                elseif(pk0.lt.0.50) then
                   LB(I1)=24
                endif
                LB1=LB(I1)
             endif
             
 clin-8/07/02 these particles don't decay strongly, so skip decay routines:     
 c            IF( (lb1.ge.-2.and.lb1.le.5) .OR. lb1.eq.31 .OR.
 c     &           (iabs(lb1).ge.14.and.iabs(lb1).le.24) .OR.
 c     &           (iabs(lb1).ge.40.and.iabs(lb1).le.45) .or. 
 c     &           lb1.eq.31)GO TO 1 
 c     only decay K0short when iksdcy=1:
             if(lb1.eq.0.or.lb1.eq.25.or.lb1.eq.26.or.lb1.eq.27
      &           .or.lb1.eq.28.or.lb1.eq.29.or.iabs(lb1).eq.30
      &           .or.(iabs(lb1).ge.6.and.iabs(lb1).le.13)
      &           .or.(iksdcy.eq.1.and.lb1.eq.24)
      &           .or.iabs(lb1).eq.16
      &           .or.(ipi0dcy.eq.1.and.nt.eq.ntmax.and.lb1.eq.4)) then
 clin-4/2012-above for option of pi0 decay:
 c     &           .or.iabs(lb1).eq.16) then
                continue
             else
                goto 1
             endif
 * IF I1 IS A RESONANCE, CHECK WHETHER IT DECAYS DURING THIS TIME STEP
          IF(lb1.ge.25.and.lb1.le.27) then
              wid=0.151
          ELSEIF(lb1.eq.28) then
              wid=0.00841
          ELSEIF(lb1.eq.29) then
              wid=0.00443
           ELSEIF(iabs(LB1).eq.30) then
              WID=0.051
          ELSEIF(lb1.eq.0) then
              wid=1.18e-6
 c     to give K0short ct0=2.676cm:
          ELSEIF(iksdcy.eq.1.and.lb1.eq.24) then
              wid=7.36e-15
 clin-4/29/03 add Sigma0 decay to Lambda, ct0=2.22E-11m:
          ELSEIF(iabs(lb1).eq.16) then
              wid=8.87e-6
 csp-07/25/01 test a1 resonance:
 cc          ELSEIF(LB1.EQ.32) then
 cc             WID=0.40
           ELSEIF(LB1.EQ.32) then
              call WIDA1(EM1,rhomp,WID,iseed)
           ELSEIF(iabs(LB1).ge.6.and.iabs(LB1).le.9) then
              WID=WIDTH(EM1)
           ELSEIF((iabs(LB1).EQ.10).OR.(iabs(LB1).EQ.11)) then
              WID=W1440(EM1)
           ELSEIF((iabs(LB1).EQ.12).OR.(iabs(LB1).EQ.13)) then
              WID=W1535(EM1)
 clin-4/2012 for option of pi0 decay:
           ELSEIF(ipi0dcy.eq.1.and.nt.eq.ntmax.and.lb1.eq.4) then
              wid=7.85e-9
           ENDIF
 
 * if it is the last time step, FORCE all resonance to strong-decay
 * and go out of the loop
           if(nt.eq.ntmax)then
              pdecay=1.1
 clin-5b/2008 forbid phi decay at the end of hadronic cascade:
              if(iphidcy.eq.0.and.iabs(LB1).eq.29) pdecay=0.
 ctest off clin-9/2012 forbid long-time decays (eta,omega,K*,Sigma0)
 c     at the end of hadronic cascade to analyze freezeout time:
 c             if(LB1.eq.0.or.LB1.eq.28.or.iabs(LB1).eq.30
 c     1            .or.iabs(LB1).eq.16) pdecay=0.
           else
              T0=0.19733/WID
              GFACTR=E1/EM1
              T0=T0*GFACTR
              IF(T0.GT.0.)THEN
                 PDECAY=1.-EXP(-DT/T0)
              ELSE
                 PDECAY=0.
              ENDIF
           endif
           XDECAY=RANART(NSEED)
 
 cc dilepton production from rho0, omega, phi decay 
 cc        if(lb1.eq.26 .or. lb1.eq.28 .or. lb1.eq.29)
 cc     &   call dec_ceres(nt,ntmax,irun,i1)
 cc
           IF(XDECAY.LT.PDECAY) THEN
 clin-10/25/02 get rid of argument usage mismatch in rhocay():
              idecay=irun
              tfnl=nt*dt
 clin-10/28/03 keep formation time of hadrons unformed at nt=ntmax-1:
              if(nt.eq.ntmax.and.ftsv(i1).gt.((ntmax-1)*dt)) 
      1            tfnl=ftsv(i1)
              xfnl=x1
              yfnl=y1
              zfnl=z1
 * use PYTHIA to perform decays of eta,rho,omega,phi,K*,(K0s) and Delta:
              if(lb1.eq.0.or.lb1.eq.25.or.lb1.eq.26.or.lb1.eq.27
      &           .or.lb1.eq.28.or.lb1.eq.29.or.iabs(lb1).eq.30
      &           .or.(iabs(lb1).ge.6.and.iabs(lb1).le.9)
      &           .or.(iksdcy.eq.1.and.lb1.eq.24)
      &           .or.iabs(lb1).eq.16
      &           .or.(ipi0dcy.eq.1.and.nt.eq.ntmax.and.lb1.eq.4)) then
 clin-4/2012 Above for option of pi0 decay:
 c     &           .or.iabs(lb1).eq.16) then
 c     previous rho decay performed in rhodecay():
 c                nnn=nnn+1
 c                call rhodecay(idecay,i1,nnn,iseed)
 c
 ctest off record decays of phi,K*,Lambda(1520) resonances:
 c                if(lb1.eq.29.or.iabs(lb1).eq.30) 
 c     1               write(18,112) 'decay',lb1,px1,py1,pz1,am1,nt
 c
 clin-4/2012 option of pi0 decays:
 c                call resdec(i1,nt,nnn,wid,idecay)
                 call resdec(i1,nt,nnn,wid,idecay,0)
                 p(1,i1)=px1n
                 p(2,i1)=py1n
                 p(3,i1)=pz1n
 clin-5/2008:
                 dpertp(i1)=dp1n
 c     add decay time to freezeout positions & time at the last timestep:
                 if(nt.eq.ntmax) then
                    R(1,i1)=xfnl
                    R(2,i1)=yfnl
                    R(3,i1)=zfnl
                    tfdcy(i1)=tfnl
                 endif
 c
 * decay number for baryon resonance or L/S decay
                 if(iabs(lb1).ge.6.and.iabs(lb1).le.9) then
                    LDECAY=LDECAY+1
                 endif
 
 * for a1 decay 
 c             elseif(lb1.eq.32)then
 c                NNN=NNN+1
 c                call a1decay(idecay,i1,nnn,iseed,rhomp)
 
 * FOR N*(1440)
              elseif(iabs(LB1).EQ.10.OR.iabs(LB1).EQ.11) THEN
                 NNN=NNN+1
                 LDECAY=LDECAY+1
                 PNSTAR=1.
                 IF(E(I1).GT.1.22)PNSTAR=0.6
                 IF(RANART(NSEED).LE.PNSTAR)THEN
 * (1) DECAY TO SINGLE PION+NUCLEON
                    CALL DECAY(idecay,I1,NNN,ISEED,wid,nt)
                 ELSE
 * (2) DECAY TO TWO PIONS + NUCLEON
                    CALL DECAY2(idecay,I1,NNN,ISEED,wid,nt)
                    NNN=NNN+1
                 ENDIF
 c for N*(1535) decay
              elseif(iabs(LB1).eq.12.or.iabs(LB1).eq.13) then
                 NNN=NNN+1
                 CALL DECAY(idecay,I1,NNN,ISEED,wid,nt)
                 LDECAY=LDECAY+1
              endif
 c
 *COM: AT HIGH ENERGIES WE USE VERY SHORT TIME STEPS,
 *     IN ORDER TO TAKE INTO ACCOUNT THE FINITE FORMATIOM TIME, WE
 *     DO NOT ALLOW PARTICLES FROM THE DECAY OF RESONANCE TO INTERACT 
 *     WITH OTHERS IN THE SAME TIME STEP. CHANGE 9000 TO REVERSE THIS 
 *     ASSUMPTION. EFFECTS OF THIS ASSUMPTION CAN BE STUDIED BY CHANGING 
 *     THE STATEMENT OF 9000. See notebook for discussions on effects of
 *     changing statement 9000.
 c
 c     kaons from K* decay are converted to k0short (and k0long), 
 c     phi decay may produce rho, K0S or eta, N*(1535) decay may produce eta,
 c     and these decay daughters need to decay again if at the last timestep:
 c     (note: these daughters have been assigned to lb(i1) only, not to lpion)
 c             if(nt.eq.ntmax.and.(lb1.eq.29.or.iabs(lb1).eq.30
 c     1            .iabs(lb1).eq.12.or.iabs(lb1).eq.13)) then
              if(nt.eq.ntmax) then
                 if(lb(i1).eq.25.or.lb(i1).eq.26.or.lb(i1).eq.27) then
                    wid=0.151
                 elseif(lb(i1).eq.0) then
                    wid=1.18e-6
                 elseif(lb(i1).eq.24.and.iksdcy.eq.1) then
 clin-4/2012 corrected K0s decay width:
 c                   wid=7.36e-17
                    wid=7.36e-15
 clin-4/2012 option of pi0 decays:
                 elseif(ipi0dcy.eq.1.and.lb(i1).eq.4) then
                    wid=7.85e-9
                 else
                    goto 9000
                 endif
                 LB1=LB(I1)
                 PX1=P(1,I1)
                 PY1=P(2,I1)
                 PZ1=P(3,I1)
                 EM1=E(I1)
                 E1=SQRT(EM1**2+PX1**2+PY1**2+PZ1**2)
 clin-4/2012 option of pi0 decays:
 c                call resdec(i1,nt,nnn,wid,idecay)
                 call resdec(i1,nt,nnn,wid,idecay,0)
                 p(1,i1)=px1n
                 p(2,i1)=py1n
                 p(3,i1)=pz1n
                 R(1,i1)=xfnl
                 R(2,i1)=yfnl
                 R(3,i1)=zfnl
                 tfdcy(i1)=tfnl
 clin-5/2008:
                 dpertp(i1)=dp1n
              endif
 
 c     Decay daughter of the above decay in lb(i1) may be a pi0:
              if(nt.eq.ntmax.and.ipi0dcy.eq.1.and.lb(i1).eq.4) then
                 wid=7.85e-9
                 LB1=LB(I1)
                 PX1=P(1,I1)
                 PY1=P(2,I1)
                 PZ1=P(3,I1)
                 EM1=E(I1)
                 E1=SQRT(EM1**2+PX1**2+PY1**2+PZ1**2)
                 call resdec(i1,nt,nnn,wid,idecay,0)
                 p(1,i1)=px1n
                 p(2,i1)=py1n
                 p(3,i1)=pz1n
                 R(1,i1)=xfnl
                 R(2,i1)=yfnl
                 R(3,i1)=zfnl
                 tfdcy(i1)=tfnl
                 dpertp(i1)=dp1n
              endif
 
 * negelecting the Pauli blocking at high energies
 clin-4/2012 option of pi0 decays:
 c 9000        go to 800
  9000        go to 798
 
           ENDIF
 * LOOP OVER ALL PSEUDOPARTICLES 2 IN THE SAME RUN
 * SAVE ALL THE COORDINATES FOR POSSIBLE CHANGE IN THE FOLLOWING COLLISION
 clin-4/2012 option of pi0 decays:
 c 1        if(nt.eq.ntmax)go to 800
  1        if(nt.eq.ntmax)go to 798
 
           X1 = R(1,I1)
           Y1 = R(2,I1)
           Z1 = R(3,I1)
 c
            DO 600 J2 = 1,J1-1
             I2  = J2 + MSUM
 * IF I2 IS A MESON BEING ABSORBED, THEN GO OUT OF THE LOOP
             IF(E(I2).EQ.0.) GO TO 600
 clin-5/2008 in case the first particle is already destroyed:
             IF(E(I1).EQ.0.) GO TO 800
 clin-4/2012 option of pi0 decays:
             IF (LB(I2) .LT. -45 .OR. LB(I2) .GT. 45) GOTO 600
 clin-7/26/03 improve speed
             X2=R(1,I2)
             Y2=R(2,I2)
             Z2=R(3,I2)
             dr0max=5.
 clin-9/2008 deuteron+nucleon elastic cross sections could reach ~2810mb:
             ilb1=iabs(LB(I1))
             ilb2=iabs(LB(I2))
             IF(ilb1.EQ.42.or.ilb2.EQ.42) THEN
                if((ILB1.GE.1.AND.ILB1.LE.2)
      1              .or.(ILB1.GE.6.AND.ILB1.LE.13)
      2              .or.(ILB2.GE.1.AND.ILB2.LE.2)
      3              .or.(ILB2.GE.6.AND.ILB2.LE.13)) then
                   if((lb(i1)*lb(i2)).gt.0) dr0max=10.
                endif
             ENDIF
 c
             if(((X1-X2)**2+(Y1-Y2)**2+(Z1-Z2)**2).GT.dr0max**2)
      1           GO TO 600
             IF (ID(I1)*ID(I2).EQ.IAVOID) GOTO 400
             ID1=ID(I1)
             ID2 = ID(I2)
 c
             ix1= nint(x1/dx)
             iy1= nint(y1/dy)
             iz1= nint(z1/dz)
             PX1=P(1,I1)
             PY1=P(2,I1)
             PZ1=P(3,I1)
             EM1=E(I1)
             AM1=EM1
             LB1=LB(I1)
             E1=SQRT(EM1**2+PX1**2+PY1**2+PZ1**2)
             IPX1=NINT(PX1/DPX)
             IPY1=NINT(PY1/DPY)
             IPZ1=NINT(PZ1/DPZ)         
             LB2 = LB(I2)
             PX2 = P(1,I2)
             PY2 = P(2,I2)
             PZ2 = P(3,I2)
             EM2=E(I2)
             AM2=EM2
             lb1i=lb(i1)
             lb2i=lb(i2)
             px1i=P(1,I1)
             py1i=P(2,I1)
             pz1i=P(3,I1)
             em1i=E(I1)
             px2i=P(1,I2)
             py2i=P(2,I2)
             pz2i=P(3,I2)
             em2i=E(I2)
 clin-2/26/03 ctest off check energy conservation after each binary search:
             eini=SQRT(E(I1)**2+P(1,I1)**2+P(2,I1)**2+P(3,I1)**2)
      1           +SQRT(E(I2)**2+P(1,I2)**2+P(2,I2)**2+P(3,I2)**2)
             pxini=P(1,I1)+P(1,I2)
             pyini=P(2,I1)+P(2,I2)
             pzini=P(3,I1)+P(3,I2)
             nnnini=nnn
 c
 clin-4/30/03 initialize value:
             iblock=0
 c
 * TO SAVE COMPUTING TIME we do the following
 * (1) make a ROUGH estimate to see whether particle i2 will collide with
 * particle I1, and (2) skip the particle pairs for which collisions are 
 * not modeled in the code.
 * FOR MESON-BARYON AND MESON-MESON COLLISIONS, we use a maximum 
 * interaction distance DELTR0=2.6
 * for ppbar production from meson (pi rho omega) interactions:
 c
             DELTR0=3.
         if( (iabs(lb1).ge.14.and.iabs(lb1).le.17) .or.
      &      (iabs(lb1).ge.30.and.iabs(lb1).le.45) ) DELTR0=5.0
         if( (iabs(lb2).ge.14.and.iabs(lb2).le.17) .or.
      &      (iabs(lb2).ge.30.and.iabs(lb2).le.45) ) DELTR0=5.0
 
             if(lb1.eq.28.and.lb2.eq.28) DELTR0=4.84
 clin-10/08/00 to include pi pi -> rho rho:
             if((lb1.ge.3.and.lb1.le.5).and.(lb2.ge.3.and.lb2.le.5)) then
                E2=SQRT(EM2**2+PX2**2+PY2**2+PZ2**2)
          spipi=(e1+e2)**2-(px1+px2)**2-(py1+py2)**2-(pz1+pz2)**2
                if(spipi.ge.(4*0.77**2)) DELTR0=3.5
             endif
 
 c khyperon
         IF (LB1.EQ.23 .AND. (LB2.GE.14.AND.LB2.LE.17)) GOTO 3699
         IF (LB2.EQ.23 .AND. (LB1.GE.14.AND.LB1.LE.17)) GOTO 3699
 
 * K(K*) + Kbar(K*bar) scattering including 
 *     K(K*) + Kbar(K*bar) --> phi + pi(rho,omega) and pi pi(rho,omega)
        if(lb1.eq.21.and.lb2.eq.23)go to 3699
        if(lb2.eq.21.and.lb1.eq.23)go to 3699
        if(lb1.eq.30.and.lb2.eq.21)go to 3699
        if(lb2.eq.30.and.lb1.eq.21)go to 3699
        if(lb1.eq.-30.and.lb2.eq.23)go to 3699
        if(lb2.eq.-30.and.lb1.eq.23)go to 3699
        if(lb1.eq.-30.and.lb2.eq.30)go to 3699
        if(lb2.eq.-30.and.lb1.eq.30)go to 3699
 c
 clin-12/15/00
 c     kaon+rho(omega,eta) collisions:
       if(lb1.eq.21.or.lb1.eq.23) then
          if(lb2.eq.0.or.(lb2.ge.25.and.lb2.le.28)) then
             go to 3699
          endif
       elseif(lb2.eq.21.or.lb2.eq.23) then
          if(lb1.eq.0.or.(lb1.ge.25.and.lb1.le.28)) then
             goto 3699
          endif
       endif
 
 clin-8/14/02 K* (pi, rho, omega, eta) collisions:
       if(iabs(lb1).eq.30 .and.
      1     (lb2.eq.0.or.(lb2.ge.25.and.lb2.le.28)
      2     .or.(lb2.ge.3.and.lb2.le.5))) then
          go to 3699
       elseif(iabs(lb2).eq.30 .and.
      1        (lb1.eq.0.or.(lb1.ge.25.and.lb1.le.28)
      2        .or.(lb1.ge.3.and.lb1.le.5))) then
          goto 3699
 clin-8/14/02-end
 c K*/K*-bar + baryon/antibaryon collisions:
         elseif( iabs(lb1).eq.30 .and.
      1     (iabs(lb2).eq.1.or.iabs(lb2).eq.2.or.
      2     (iabs(lb2).ge.6.and.iabs(lb2).le.13)) )then
               go to 3699
            endif
          if( iabs(lb2).eq.30 .and.
      1         (iabs(lb1).eq.1.or.iabs(lb1).eq.2.or.
      2         (iabs(lb1).ge.6.and.iabs(lb1).le.13)) )then
                 go to 3699
         endif                                                              
 * K^+ baryons and antibaryons:
 c** K+ + B-bar  --> La(Si)-bar + pi
 * K^- and antibaryons, note K^- and baryons are included in newka():
 * note that we fail to satisfy charge conjugation for these cross sections:
         if((lb1.eq.23.or.lb1.eq.21).and.
      1       (iabs(lb2).eq.1.or.iabs(lb2).eq.2.or.
      2       (iabs(lb2).ge.6.and.iabs(lb2).le.13))) then
            go to 3699
         elseif((lb2.eq.23.or.lb2.eq.21).and.
      1       (iabs(lb1).eq.1.or.iabs(lb1).eq.2.or.
      2       (iabs(lb1).ge.6.and.iabs(lb1).le.13))) then
            go to 3699
         endif
 *
 * For anti-nucleons annihilations:
 * Assumptions: 
 * (1) for collisions involving a p_bar or n_bar,
 * we allow only collisions between a p_bar and a baryon or a baryon 
 * resonance (as well as a n_bar and a baryon or a baryon resonance),
 * we skip all other reactions involving a p_bar or n_bar, 
 * such as collisions between p_bar (n_bar) and mesons, 
 * and collisions between two p_bar's (n_bar's). 
 * (2) we introduce a new parameter rppmax: the maximum interaction 
 * distance to make the quick collision check,rppmax=3.57 fm 
 * corresponding to a cutoff of annihilation xsection= 400mb which is
 * also used consistently in the actual annihilation xsection to be 
 * used in the following as given in the subroutine xppbar(srt)
         rppmax=3.57   
 * anti-baryon on baryons
         if((lb1.eq.-1.or.lb1.eq.-2.or.(lb1.ge.-13.and.lb1.le.-6))
      1 .and.(lb2.eq.1.or.lb2.eq.2.or.(lb2.ge.6.and.lb2.le.13))) then
             DELTR0 = RPPMAX
             GOTO 2699
        else if((lb2.eq.-1.or.lb2.eq.-2.or.(lb2.ge.-13.and.lb2.le.-6))
      1 .and.(lb1.eq.1.or.lb1.eq.2.or.(lb1.ge.6.and.lb1.le.13))) then
             DELTR0 = RPPMAX
             GOTO 2699
          END IF
 
 c*  ((anti) lambda, cascade, omega  should not be rejected)
         if( (iabs(lb1).ge.14.and.iabs(lb1).le.17) .or.
      &      (iabs(lb2).ge.14.and.iabs(lb2).le.17) )go to 3699
 c
 clin-9/2008 maximum sigma~2810mb for deuteron+nucleon elastic collisions:
          IF (iabs(LB1).EQ.42.or.iabs(LB2).EQ.42) THEN
             ilb1=iabs(LB1)
             ilb2=iabs(LB2)
             if((ILB1.GE.1.AND.ILB1.LE.2)
      1           .or.(ILB1.GE.6.AND.ILB1.LE.13)
      2           .or.(ILB2.GE.1.AND.ILB2.LE.2)
      3           .or.(ILB2.GE.6.AND.ILB2.LE.13)) then
                if((lb1*lb2).gt.0) deltr0=9.5
             endif
          ENDIF
 c
         if( (iabs(lb1).ge.40.and.iabs(lb1).le.45) .or. 
      &      (iabs(lb2).ge.40.and.iabs(lb2).le.45) )go to 3699
 c
 c* phi channel --> elastic + inelastic scatt.  
          IF( (lb1.eq.29 .and.((lb2.ge.1.and.lb2.le.13).or.  
      &       (lb2.ge.21.and.lb2.le.28).or.iabs(lb2).eq.30)) .OR.
      &     (lb2.eq.29 .and.((lb1.ge.1.and.lb1.le.13).or.
      &       (lb1.ge.21.and.lb1.le.28).or.iabs(lb1).eq.30)) )THEN
              DELTR0=3.0
              go to 3699
         endif
 c
 c  La/Si, Cas, Om (bar)-meson elastic colln
 * pion vs. La & Ca (bar) coll. are treated in resp. subroutines
 
 * SKIP all other K* RESCATTERINGS
         If(iabs(lb1).eq.30.or.iabs(lb2).eq.30) go to 400
 * SKIP KAON(+) RESCATTERINGS WITH particles other than pions and baryons 
          If(lb1.eq.23.and.(lb2.lt.1.or.lb2.gt.17))go to 400
          If(lb2.eq.23.and.(lb1.lt.1.or.lb1.gt.17))go to 400
 c
 c anti-baryon proccess: B-bar+M, N-bar+R-bar, N-bar+N-bar, R-bar+R-bar
 c  R = (D,N*)
          if( ((lb1.le.-1.and.lb1.ge.-13)
      &        .and.(lb2.eq.0.or.(lb2.ge.3.and.lb2.le.5)
      &            .or.(lb2.ge.25.and.lb2.le.28))) 
      &      .OR.((lb2.le.-1.and.lb2.ge.-13)
      &         .and.(lb1.eq.0.or.(lb1.ge.3.and.lb1.le.5)
      &              .or.(lb1.ge.25.and.lb1.le.28))) ) then
          elseIF( ((LB1.eq.-1.or.lb1.eq.-2).
      &             and.(LB2.LT.-5.and.lb2.ge.-13))
      &      .OR. ((LB2.eq.-1.or.lb2.eq.-2).
      &             and.(LB1.LT.-5.and.lb1.ge.-13)) )then
          elseIF((LB1.eq.-1.or.lb1.eq.-2)
      &     .AND.(LB2.eq.-1.or.lb2.eq.-2))then
          elseIF((LB1.LT.-5.and.lb1.ge.-13).AND.
      &          (LB2.LT.-5.and.lb2.ge.-13)) then
 c        elseif((lb1.lt.0).or.(lb2.lt.0)) then
 c         go to 400
        endif               
 
  2699    CONTINUE
 * for baryon-baryon collisions
          IF (LB1 .EQ. 1 .OR. LB1 .EQ. 2 .OR. (LB1 .GE. 6 .AND.
      &        LB1 .LE. 17)) THEN
             IF (LB2 .EQ. 1 .OR. LB2 .EQ. 2 .OR. (LB2 .GE. 6 .AND.
      &           LB2 .LE. 17)) THEN
                DELTR0 = 2.
             END IF
          END IF
 c
  3699   RSQARE = (X1-X2)**2 + (Y1-Y2)**2 + (Z1-Z2)**2
         IF (RSQARE .GT. DELTR0**2) GO TO 400
 *NOW PARTICLES ARE CLOSE ENOUGH TO EACH OTHER !
 * KEEP ALL COORDINATES FOR POSSIBLE PHASE SPACE CHANGE
             ix2 = nint(x2/dx)
             iy2 = nint(y2/dy)
             iz2 = nint(z2/dz)
             ipx2 = nint(px2/dpx)
             ipy2 = nint(py2/dpy)
             ipz2 = nint(pz2/dpz)
 * FIND MOMENTA OF PARTICLES IN THE CMS OF THE TWO COLLIDING PARTICLES
 * AND THE CMS ENERGY SRT
             CALL CMS(I1,I2,PCX,PCY,PCZ,SRT)
 
 clin-7/26/03 improve speed
           drmax=dr0max
           call distc0(drmax,deltr0,DT,
      1         Ifirst,PCX,PCY,PCZ,
      2         x1,y1,z1,px1,py1,pz1,em1,x2,y2,z2,px2,py2,pz2,em2)
           if(Ifirst.eq.-1) goto 400
 
          ISS=NINT(SRT/ESBIN)
 clin-4/2008 use last bin if ISS is out of EKAON's upper bound of 2000:
          if(ISS.gt.2000) ISS=2000
 *Sort collisions
 c
 clin-8/2008 Deuteron+Meson->B+B; 
 c     meson=(pi,rho,omega,eta), B=(n,p,Delta,N*1440,N*1535):
          IF (iabs(LB1).EQ.42.or.iabs(LB2).EQ.42) THEN
             ilb1=iabs(LB1)
             ilb2=iabs(LB2)
             if(LB1.eq.0.or.(LB1.GE.3.AND.LB1.LE.5)
      1           .or.(LB1.GE.25.AND.LB1.LE.28)
      2           .or.
      3           LB2.eq.0.or.(LB2.GE.3.AND.LB2.LE.5)
      4           .or.(LB2.GE.25.AND.LB2.LE.28)) then
                GOTO 505
 clin-9/2008 Deuteron+Baryon or antiDeuteron+antiBaryon elastic collisions:
             elseif(((ILB1.GE.1.AND.ILB1.LE.2)
      1              .or.(ILB1.GE.6.AND.ILB1.LE.13)
      2              .or.(ILB2.GE.1.AND.ILB2.LE.2)
      3              .or.(ILB2.GE.6.AND.ILB2.LE.13))
      4              .and.(lb1*lb2).gt.0) then
                GOTO 506
             else
                GOTO 400
             endif
          ENDIF
 c
 * K+ + (N,N*,D)-bar --> L/S-bar + pi
           if( ((lb1.eq.23.or.lb1.eq.30).and.
      &         (lb2.eq.-1.or.lb2.eq.-2.or.(lb2.ge.-13.and.lb2.le.-6))) 
      &         .OR.((lb2.eq.23.or.lb2.eq.30).and.
      &         (lb1.eq.-1.or.lb1.eq.-2.or.(lb1.ge.-13.and.lb1.le.-6))) )
      &         then
              bmass=0.938
              if(srt.le.(bmass+aka)) then
                 pkaon=0.
              else
                 pkaon=sqrt(((srt**2-(aka**2+bmass**2))
      1               /2./bmass)**2-aka**2)
              endif
 clin-10/31/02 cross sections are isospin-averaged, same as those in newka
 c     for K- + (N,N*,D) --> L/S + pi:
              sigela = 0.5 * (AKPEL(PKAON) + AKNEL(PKAON))
              SIGSGM = 1.5 * AKPSGM(PKAON) + AKNSGM(PKAON)
              SIG = sigela + SIGSGM + AKPLAM(PKAON)
              if(sig.gt.1.e-7) then
 c     ! K+ + N-bar reactions
                 icase=3
                 brel=sigela/sig
                 brsgm=sigsgm/sig
                 brsig = sig
                 nchrg = 1
                 go to 3555
              endif
              go to 400
           endif
 c
 c
 c  meson + hyperon-bar -> K+ + N-bar
           if(((lb1.ge.-17.and.lb1.le.-14).and.(lb2.ge.3.and.lb2.le.5)) 
      &         .OR.((lb2.ge.-17.and.lb2.le.-14)
      &         .and.(lb1.ge.3.and.lb1.le.5)))then
              nchrg=-100
  
 C*       first classify the reactions due to total charge.
              if((lb1.eq.-15.and.(lb2.eq.5.or.lb2.eq.27)).OR.
      &            (lb2.eq.-15.and.(lb1.eq.5.or.lb1.eq.27))) then
                 nchrg=-2
 c     ! D-(bar)
                 bmass=1.232
                 go to 110
              endif
              if( (lb1.eq.-15.and.(lb2.eq.0.or.lb2.eq.4.or.lb2.eq.26.or.
      &            lb2.eq.28)).OR.(lb2.eq.-15.and.(lb1.eq.0.or.
      &            lb1.eq.4.or.lb1.eq.26.or.lb1.eq.28)).OR.
      &   ((lb1.eq.-14.or.lb1.eq.-16).and.(lb2.eq.5.or.lb2.eq.27)).OR.
      &   ((lb2.eq.-14.or.lb2.eq.-16).and.(lb1.eq.5.or.lb1.eq.27)) )then
                 nchrg=-1
 c     ! n-bar
                 bmass=0.938
                 go to 110
              endif
              if(  (lb1.eq.-15.and.(lb2.eq.3.or.lb2.eq.25)).OR.
      &            (lb2.eq.-15.and.(lb1.eq.3.or.lb1.eq.25)).OR.
      &            (lb1.eq.-17.and.(lb2.eq.5.or.lb2.eq.27)).OR.
      &            (lb2.eq.-17.and.(lb1.eq.5.or.lb1.eq.27)).OR.
      &            ((lb1.eq.-14.or.lb1.eq.-16).and.(lb2.eq.0.or.lb2.eq.4
      &            .or.lb2.eq.26.or.lb2.eq.28)).OR.
      &            ((lb2.eq.-14.or.lb2.eq.-16).and.(lb1.eq.0.or.lb1.eq.4
      &            .or.lb1.eq.26.or.lb1.eq.28)) )then
                nchrg=0
 c     ! p-bar
                 bmass=0.938
                 go to 110
              endif
              if( (lb1.eq.-17.and.(lb2.eq.0.or.lb2.eq.4.or.lb2.eq.26.or.
      &            lb2.eq.28)).OR.(lb2.eq.-17.and.(lb1.eq.0.or.
      &            lb1.eq.4.or.lb1.eq.26.or.lb1.eq.28)).OR.
      &  ((lb1.eq.-14.or.lb1.eq.-16).and.(lb2.eq.3.or.lb2.eq.25)).OR.
      &  ((lb2.eq.-14.or.lb2.eq.-16).and.(lb1.eq.3.or.lb1.eq.25)))then
                nchrg=1
 c     ! D++(bar)
                 bmass=1.232
              endif
 c
 c 110     if(nchrg.ne.-100.and.srt.ge.(aka+bmass))then !! for elastic
  110         sig = 0.
 c !! for elastic
          if(nchrg.ne.-100.and.srt.ge.(aka+bmass))then
 cc110        if(nchrg.eq.-100.or.srt.lt.(aka+bmass)) go to 400
 c             ! PI + La(Si)-bar => K+ + N-bar reactions
             icase=4
 cc       pkaon=sqrt(((srt**2-(aka**2+bmass**2))/2./bmass)**2-aka**2)
             pkaon=sqrt(((srt**2-(aka**2+0.938**2))/2./0.938)**2-aka**2)
 c ! lambda-bar + Pi
             if(lb1.eq.-14.or.lb2.eq.-14) then
                if(nchrg.ge.0) sigma0=akPlam(pkaon)
                if(nchrg.lt.0) sigma0=akNlam(pkaon)
 c                ! sigma-bar + pi
             else
 c !K-p or K-D++
                if(nchrg.ge.0) sigma0=akPsgm(pkaon)
 c !K-n or K-D-
                if(nchrg.lt.0) sigma0=akNsgm(pkaon)
                SIGMA0 = 1.5 * AKPSGM(PKAON) + AKNSGM(PKAON)
             endif
             sig=(srt**2-(aka+bmass)**2)*(srt**2-(aka-bmass)**2)/
      &           (srt**2-(em1+em2)**2)/(srt**2-(em1-em2)**2)*sigma0
 c ! K0barD++, K-D-
             if(nchrg.eq.-2.or.nchrg.eq.2) sig=2.*sig
 C*     the factor 2 comes from spin of delta, which is 3/2
 C*     detailed balance. copy from Page 423 of N.P. A614 1997
             IF (LB1 .EQ. -14 .OR. LB2 .EQ. -14) THEN
                SIG = 4.0 / 3.0 * SIG
             ELSE IF (NCHRG .EQ. -2 .OR. NCHRG .EQ. 2) THEN
                SIG = 8.0 / 9.0 * SIG
             ELSE
                SIG = 4.0 / 9.0 * SIG
             END IF
 cc        brel=0.
 cc        brsgm=0.
 cc        brsig = sig
 cc          if(sig.lt.1.e-7) go to 400
 *-
          endif
 c                ! PI + La(Si)-bar => elastic included
          icase=4
          sigela = 10.
          sig = sig + sigela
          brel= sigela/sig
          brsgm=0.
          brsig = sig
 *-
          go to 3555
       endif
       
 ** MULTISTRANGE PARTICLE (Cas,Omega -bar) PRODUCTION - (NON)PERTURBATIVE
 
 * K-/K*0bar + La/Si --> cascade + pi/eta
       if( ((lb1.eq.21.or.lb1.eq.-30).and.(lb2.ge.14.and.lb2.le.17)).OR.
      &  ((lb2.eq.21.or.lb2.eq.-30).and.(lb1.ge.14.and.lb1.le.17)) )then
           kp = 0
           go to 3455
         endif
 c K+/K*0 + La/Si(bar) --> cascade-bar + pi/eta
       if( ((lb1.eq.23.or.lb1.eq.30).and.(lb2.le.-14.and.lb2.ge.-17)).OR.
      &  ((lb2.eq.23.or.lb2.eq.30).and.(lb1.le.-14.and.lb1.ge.-17)) )then
           kp = 1
           go to 3455
         endif
 * K-/K*0bar + cascade --> omega + pi
        if( ((lb1.eq.21.or.lb1.eq.-30).and.(lb2.eq.40.or.lb2.eq.41)).OR.
      & ((lb2.eq.21.or.lb2.eq.-30).and.(lb1.eq.40.or.lb1.eq.41)) )then
           kp = 0
           go to 3455
         endif
 * K+/K*0 + cascade-bar --> omega-bar + pi
        if( ((lb1.eq.23.or.lb1.eq.30).and.(lb2.eq.-40.or.lb2.eq.-41)).OR.
      &  ((lb2.eq.23.or.lb2.eq.30).and.(lb1.eq.-40.or.lb1.eq.-41)) )then
           kp = 1
           go to 3455
         endif
 * Omega + Omega --> Di-Omega + photon(eta)
 cc        if( lb1.eq.45.and.lb2.eq.45 ) go to 3455
 
 c annhilation of cascade(bar), omega(bar)
          kp = 3
 * K- + L/S <-- cascade(bar) + pi/eta
        if( (((lb1.ge.3.and.lb1.le.5).or.lb1.eq.0) 
      &       .and.(iabs(lb2).eq.40.or.iabs(lb2).eq.41))
      & .OR. (((lb2.ge.3.and.lb2.le.5).or.lb2.eq.0) 
      &       .and.(iabs(lb1).eq.40.or.iabs(lb1).eq.41)) )go to 3455
 * K- + cascade(bar) <-- omega(bar) + pi
 *         if(  (lb1.eq.0.and.iabs(lb2).eq.45)
 *    &       .OR. (lb2.eq.0.and.iabs(lb1).eq.45) )go to 3455
         if( ((lb1.ge.3.and.lb1.le.5).and.iabs(lb2).eq.45)
      &  .OR.((lb2.ge.3.and.lb2.le.5).and.iabs(lb1).eq.45) )go to 3455
 c
 
 ***  MULTISTRANGE PARTICLE PRODUCTION  (END)
 
 c* K+ + La(Si) --> Meson + B
         IF (LB1.EQ.23 .AND. (LB2.GE.14.AND.LB2.LE.17)) GOTO 5699
         IF (LB2.EQ.23 .AND. (LB1.GE.14.AND.LB1.LE.17)) GOTO 5699
 c* K- + La(Si)-bar --> Meson + B-bar
        IF (LB1.EQ.21 .AND. (LB2.GE.-17.AND.LB2.LE.-14)) GOTO 5699
        IF (LB2.EQ.21 .AND. (LB1.GE.-17.AND.LB1.LE.-14)) GOTO 5699
 
 c La/Si-bar + B --> pi + K+
        IF( (((LB1.eq.1.or.LB1.eq.2).or.(LB1.ge.6.and.LB1.le.13))
      &       .AND.(LB2.GE.-17.AND.LB2.LE.-14)) .OR.
      &     (((LB2.eq.1.or.LB2.eq.2).or.(LB2.ge.6.and.LB2.le.13))
      &      .AND.(LB1.GE.-17.AND.LB1.LE.-14)) )go to 5999
 c La/Si + B-bar --> pi + K-
        IF( (((LB1.eq.-1.or.LB1.eq.-2).or.(LB1.le.-6.and.LB1.ge.-13))
      &       .AND.(LB2.GE.14.AND.LB2.LE.17)) .OR.
      &     (((LB2.eq.-1.or.LB2.eq.-2).or.(LB2.le.-6.and.LB2.ge.-13))
      &       .AND.(LB1.GE.14.AND.LB1.LE.17)) )go to 5999 
 *
 *
 * K(K*) + Kbar(K*bar) --> phi + pi(rho,omega), M + M (M=pi,rho,omega,eta)
        if(lb1.eq.21.and.lb2.eq.23) go to 8699
        if(lb2.eq.21.and.lb1.eq.23) go to 8699
        if(lb1.eq.30.and.lb2.eq.21) go to 8699
        if(lb2.eq.30.and.lb1.eq.21) go to 8699
        if(lb1.eq.-30.and.lb2.eq.23) go to 8699
        if(lb2.eq.-30.and.lb1.eq.23) go to 8699
        if(lb1.eq.-30.and.lb2.eq.30) go to 8699
        if(lb2.eq.-30.and.lb1.eq.30) go to 8699
 c* (K,K*)-bar + rho(omega) --> phi +(K,K*)-bar, piK and elastic
        IF( ((lb1.eq.23.or.lb1.eq.21.or.iabs(lb1).eq.30) .and.
      &      (lb2.ge.25.and.lb2.le.28)) .OR.
      &     ((lb2.eq.23.or.lb2.eq.21.or.iabs(lb2).eq.30) .and.
      &      (lb1.ge.25.and.lb1.le.28)) ) go to 8799
 c
 c* K*(-bar) + pi --> phi + (K,K*)-bar
        IF( (iabs(lb1).eq.30.and.(lb2.ge.3.and.lb2.le.5)) .OR.
      &     (iabs(lb2).eq.30.and.(lb1.ge.3.and.lb1.le.5)) )go to 8799
 *
 c
 c* phi + N --> pi+N(D),  rho+N(D),  K+ +La
 c* phi + D --> pi+N(D),  rho+N(D)
        IF( (lb1.eq.29 .and.(lb2.eq.1.or.lb2.eq.2.or.
      &       (lb2.ge.6.and.lb2.le.9))) .OR.
      &     (lb2.eq.29 .and.(lb1.eq.1.or.lb1.eq.2.or.
      &       (lb1.ge.6.and.lb1.le.9))) )go to 7222
 c
 c* phi + (pi,rho,ome,K,K*-bar) --> K+K, K+K*, K*+K*, (pi,rho,omega)+(K,K*-bar)
        IF( (lb1.eq.29 .and.((lb2.ge.3.and.lb2.le.5).or.
      &      (lb2.ge.21.and.lb2.le.28).or.iabs(lb2).eq.30)) .OR.
      &     (lb2.eq.29 .and.((lb1.ge.3.and.lb1.le.5).or.
      &      (lb1.ge.21.and.lb1.le.28).or.iabs(lb1).eq.30)) )THEN
              go to 7444
       endif
 *
 c
 * La/Si, Cas, Om (bar)-(rho,omega,phi) elastic colln
 * pion vs. La, Ca, Omega-(bar) elastic coll. treated in resp. subroutines
       if( ((iabs(lb1).ge.14.and.iabs(lb1).le.17).or.iabs(lb1).ge.40)
      &    .and.((lb2.ge.25.and.lb2.le.29).or.lb2.eq.0) )go to 888
       if( ((iabs(lb2).ge.14.and.iabs(lb2).le.17).or.iabs(lb2).ge.40)
      &    .and.((lb1.ge.25.and.lb1.le.29).or.lb1.eq.0) )go to 888
 c
 c K+/K* (N,R)  OR   K-/K*- (N,R)-bar  elastic scatt
         if( ((lb1.eq.23.or.lb1.eq.30).and.(lb2.eq.1.or.lb2.eq.2.or.
      &         (lb2.ge.6.and.lb2.le.13))) .OR.
      &      ((lb2.eq.23.or.lb2.eq.30).and.(lb1.eq.1.or.lb1.eq.2.or.
      &         (lb1.ge.6.and.lb1.le.13))) ) go to 888
         if( ((lb1.eq.21.or.lb1.eq.-30).and.(lb2.eq.-1.or.lb2.eq.-2.or.
      &       (lb2.ge.-13.and.lb2.le.-6))) .OR. 
      &      ((lb2.eq.21.or.lb2.eq.-30).and.(lb1.eq.-1.or.lb1.eq.-2.or.
      &       (lb1.ge.-13.and.lb1.le.-6))) ) go to 888
 c
 * L/S-baryon elastic collision 
        If( ((lb1.ge.14.and.lb1.le.17).and.(lb2.ge.6.and.lb2.le.13))
      & .OR.((lb2.ge.14.and.lb2.le.17).and.(lb1.ge.6.and.lb1.le.13)) )
      &   go to 7799
        If(((lb1.le.-14.and.lb1.ge.-17).and.(lb2.le.-6.and.lb2.ge.-13))
      &.OR.((lb2.le.-14.and.lb2.ge.-17).and.(lb1.le.-6.and.lb1.ge.-13)))
      &   go to 7799
 c
 c skip other collns with perturbative particles or hyperon-bar
        if( iabs(lb1).ge.40 .or. iabs(lb2).ge.40
      &    .or. (lb1.le.-14.and.lb1.ge.-17) 
      &    .or. (lb2.le.-14.and.lb2.ge.-17) )go to 400
 c
 c
 * anti-baryon on baryon resonaces 
         if((lb1.eq.-1.or.lb1.eq.-2.or.(lb1.ge.-13.and.lb1.le.-6))
      1 .and.(lb2.eq.1.or.lb2.eq.2.or.(lb2.ge.6.and.lb2.le.13))) then
             GOTO 2799
        else if((lb2.eq.-1.or.lb2.eq.-2.or.(lb2.ge.-13.and.lb2.le.-6))
      1 .and.(lb1.eq.1.or.lb1.eq.2.or.(lb1.ge.6.and.lb1.le.13))) then
             GOTO 2799
          END IF
 c
 clin-10/25/02 get rid of argument usage mismatch in newka():
          inewka=irun
 c        call newka(icase,irun,iseed,dt,nt,
 clin-5/01/03 set iblock value in art1f.f, necessary for resonance studies:
 c        call newka(icase,inewka,iseed,dt,nt,
 c     &                  ictrl,i1,i2,srt,pcx,pcy,pcz)
         call newka(icase,inewka,iseed,dt,nt,
      &                  ictrl,i1,i2,srt,pcx,pcy,pcz,iblock)
 
 clin-10/25/02-end
         IF (ICTRL .EQ. 1) GOTO 400
 c
 * SEPARATE NUCLEON+NUCLEON( BARYON RESONANCE+ BARYON RESONANCE ELASTIC
 * COLLISION), BARYON RESONANCE+NUCLEON AND BARYON-PION
 * COLLISIONS INTO THREE PARTS TO CHECK IF THEY ARE GOING TO SCATTER,
 * WE only allow L/S to COLLIDE elastically with a nucleon and meson
        if((iabs(lb1).ge.14.and.iabs(lb1).le.17).
      &  or.(iabs(lb2).ge.14.and.iabs(lb2).le.17))go to 400
 * IF PION+PION COLLISIONS GO TO 777
 * if pion+eta, eta+eta to create kaons go to 777 
        IF((lb1.ge.3.and.lb1.le.5).and.(lb2.ge.3.and.lb2.le.5))GO TO 777
        if(lb1.eq.0.and.(lb2.ge.3.and.lb2.le.5)) go to 777
        if(lb2.eq.0.and.(lb1.ge.3.and.lb1.le.5)) go to 777
        if(lb1.eq.0.and.lb2.eq.0)go to 777
 * we assume that rho and omega behave the same way as pions in 
 * kaon production
 * (1) rho(omega)+rho(omega)
        if( (lb1.ge.25.and.lb1.le.28).and.
      &     (lb2.ge.25.and.lb2.le.28) )goto 777
 * (2) rho(omega)+pion
       If((lb1.ge.25.and.lb1.le.28).and.(lb2.ge.3.and.lb2.le.5))go to 777
       If((lb2.ge.25.and.lb2.le.28).and.(lb1.ge.3.and.lb1.le.5))go to 777
 * (3) rho(omega)+eta
        if((lb1.ge.25.and.lb1.le.28).and.lb2.eq.0)go to 777
        if((lb2.ge.25.and.lb2.le.28).and.lb1.eq.0)go to 777
 c
 * if kaon+pion collisions go to 889
        if((lb1.eq.23.or.lb1.eq.21).and.(lb2.ge.3.and.lb2.le.5))go to 889
        if((lb2.eq.23.or.lb2.eq.21).and.(lb1.ge.3.and.lb1.le.5))go to 889
 c
 clin-2/06/03 skip all other (K K* Kbar K*bar) channels:
 * SKIP all other K and K* RESCATTERINGS
         If(iabs(lb1).eq.30.or.iabs(lb2).eq.30) go to 400
         If(lb1.eq.21.or.lb2.eq.21) go to 400
         If(lb1.eq.23.or.lb2.eq.23) go to 400
 c
 * IF PION+baryon COLLISION GO TO 3
            IF( (LB1.ge.3.and.LB1.le.5) .and. 
      &         (iabs(LB2).eq.1.or.iabs(LB2).eq.2.or.
      &          (iabs(LB2).ge.6.and.iabs(LB2).le.13)) )GO TO 3
            IF( (LB2.ge.3.and.LB2.le.5) .and. 
      &         (iabs(LB1).eq.1.or.iabs(LB1).eq.2.or.
      &          (iabs(LB1).ge.6.and.iabs(LB1).le.13)) )GO TO 3
 c
 * IF rho(omega)+NUCLEON (baryon resonance) COLLISION GO TO 33
            IF( (LB1.ge.25.and.LB1.le.28) .and. 
      &         (iabs(LB2).eq.1.or.iabs(LB2).eq.2.or.
      &          (iabs(LB2).ge.6.and.iabs(LB2).le.13)) )GO TO 33
            IF( (LB2.ge.25.and.LB2.le.28) .and. 
      &         (iabs(LB1).eq.1.or.iabs(LB1).eq.2.or.
      &          (iabs(LB1).ge.6.and.iabs(LB1).le.13)) )GO TO 33
 c
 * IF ETA+NUCLEON (baryon resonance) COLLISIONS GO TO 547
            IF( LB1.eq.0 .and. 
      &         (iabs(LB2).eq.1.or.iabs(LB2).eq.2.or.
      &          (iabs(LB2).ge.6.and.iabs(LB2).le.13)) )GO TO 547
            IF( LB2.eq.0 .and. 
      &         (iabs(LB1).eq.1.or.iabs(LB1).eq.2.or.
      &          (iabs(LB1).ge.6.and.iabs(LB1).le.13)) )GO TO 547
 c
 * IF NUCLEON+BARYON RESONANCE COLLISION GO TO 44
             IF((LB1.eq.1.or.lb1.eq.2).
      &        AND.(LB2.GT.5.and.lb2.le.13))GOTO 44
             IF((LB2.eq.1.or.lb2.eq.2).
      &        AND.(LB1.GT.5.and.lb1.le.13))GOTO 44
             IF((LB1.eq.-1.or.lb1.eq.-2).
      &        AND.(LB2.LT.-5.and.lb2.ge.-13))GOTO 44
             IF((LB2.eq.-1.or.lb2.eq.-2).
      &        AND.(LB1.LT.-5.and.lb1.ge.-13))GOTO 44
 c
 * IF NUCLEON+NUCLEON COLLISION GO TO 4
        IF((LB1.eq.1.or.lb1.eq.2).AND.(LB2.eq.1.or.lb2.eq.2))GOTO 4
        IF((LB1.eq.-1.or.lb1.eq.-2).AND.(LB2.eq.-1.or.lb2.eq.-2))GOTO 4
 c
 * IF BARYON RESONANCE+BARYON RESONANCE COLLISION GO TO 444
             IF((LB1.GT.5.and.lb1.le.13).AND.
      &         (LB2.GT.5.and.lb2.le.13)) GOTO 444
             IF((LB1.LT.-5.and.lb1.ge.-13).AND.
      &         (LB2.LT.-5.and.lb2.ge.-13)) GOTO 444
 c
 * if L/S+L/S or L/s+nucleon go to 400
 * otherwise, develop a model for their collisions
        if((lb1.lt.3).and.(lb2.ge.14.and.lb2.le.17))goto 400
        if((lb2.lt.3).and.(lb1.ge.14.and.lb1.le.17))goto 400
        if((lb1.ge.14.and.lb1.le.17).and.
      &  (lb2.ge.14.and.lb2.le.17))goto 400
 c
 * otherwise, go out of the loop
               go to 400
 *
 *
 547           IF(LB1*LB2.EQ.0)THEN
 * (1) FOR ETA+NUCLEON SYSTEM, we allow both elastic collision, 
 *     i.e. N*(1535) formation and kaon production
 *     the total kaon production cross section is
 *     ASSUMED to be THE SAME AS PION+NUCLEON COLLISIONS
 * (2) for eta+baryon resonance we only allow kaon production
            ece=(em1+em2+0.02)**2
            xkaon0=0.
            if(srt.ge.1.63.AND.SRT.LE.1.7)xkaon0=pnlka(srt)
            IF(SRT.GT.1.7)XKAON0=PNLKA(SRT)+pnska(srt)
 cbz3/7/99 neutralk
             XKAON0 = 2.0 * XKAON0
 cbz3/7/99 neutralk end
 
 * Here we negelect eta+n inelastic collisions other than the 
 * kaon production, therefore the total inelastic cross section
 * xkaon equals to the xkaon0 (kaon production cross section)
            xkaon=xkaon0
 * note here the xkaon is in unit of fm**2
             XETA=XN1535(I1,I2,0)
         If((iabs(LB(I1)).ge.6.and.iabs(LB(I1)).le.13).or.
      &     (iabs(LB(I2)).ge.6.and.iabs(LB(I2)).le.13)) xeta=0.      
             IF((XETA+xkaon).LE.1.e-06)GO TO 400
             DSE=SQRT((XETA+XKAON)/PI)
            DELTRE=DSE+0.1
         px1cm=pcx
         py1cm=pcy
         pz1cm=pcz
 * CHECK IF N*(1535) resonance CAN BE FORMED
          CALL DISTCE(I1,I2,DELTRE,DSE,DT,ECE,SRT,IC,
      1   PCX,PCY,PCZ)
          IF(IC.EQ.-1) GO TO 400
          ekaon(4,iss)=ekaon(4,iss)+1
         IF(XKAON0/(XKAON+XETA).GT.RANART(NSEED))then
 * kaon production, USE CREN TO CALCULATE THE MOMENTUM OF L/S K+
         CALL CREN(PX1CM,PY1CM,PZ1CM,SRT,I1,I2,IBLOCK)
 * kaon production
        IF(IBLOCK.EQ.7) then
           LPN=LPN+1
        elseIF(IBLOCK.EQ.-7) then
        endif
 c
        em1=e(i1)
        em2=e(i2)
        GO TO 440
        endif
 * N*(1535) FORMATION
         resona=1.
          GO TO 98
          ENDIF
 *IF PION+NUCLEON (baryon resonance) COLLISION THEN
 3           CONTINUE
            px1cm=pcx
            py1cm=pcy
            pz1cm=pcz
 * the total kaon production cross section for pion+baryon (resonance) is
 * assumed to be the same as in pion+nucleon
            xkaon0=0.
            if(srt.ge.1.63.AND.SRT.LE.1.7)xkaon0=pnlka(srt)
            IF(SRT.GT.1.7)XKAON0=PNLKA(SRT)+pnska(srt)
             XKAON0 = 2.0 * XKAON0
 c
 c sp11/21/01  phi production: pi +N(D) -> phi + N(D)
          Xphi = 0.
        if( ( ((lb1.ge.1.and.lb1.le.2).or.
      &        (lb1.ge.6.and.lb1.le.9))
      &   .OR.((lb2.ge.1.and.lb2.le.2).or.
      &        (lb2.ge.6.and.lb2.le.9)) )
      &       .AND. srt.gt.1.958)
      &        call pibphi(srt,lb1,lb2,em1,em2,Xphi,xphin)
 c !! in fm^2 above
 
 * if a pion collide with a baryon resonance, 
 * we only allow kaon production AND the reabsorption 
 * processes: Delta+pion-->N+pion, N*+pion-->N+pion
 * Later put in pion+baryon resonance elastic
 * cross through forming higher resonances implicitly.
 c          If(em1.gt.1.or.em2.gt.1.)go to 31
          If((iabs(LB(I1)).ge.6.and.iabs(LB(I1)).le.13).or.
      &      (iabs(LB(I2)).ge.6.and.iabs(LB(I2)).le.13)) go to 31
 * For pion+nucleon collisions: 
 * using the experimental pion+nucleon inelastic cross section, we assume it
 * is exhausted by the Delta+pion, Delta+rho and Delta+omega production 
 * and kaon production. In the following we first check whether 
 * inelastic pion+n collision can happen or not, then determine in 
 * crpn whether it is through pion production or through kaon production
 * note that the xkaon0 is the kaon production cross section
 * Note in particular that: 
 * xkaon in the following is the total pion+nucleon inelastic cross section
 * note here the xkaon is in unit of fm**2, xnpi is also in unit of fm**2
 * FOR PION+NUCLEON SYSTEM, THE MINIMUM S IS 1.2056 the minimum srt for 
 * elastic scattering, and it is 1.60 for pion production, 1.63 for LAMBDA+kaon 
 * production and 1.7 FOR SIGMA+KAON
 * (EC = PION MASS+NUCLEON MASS+20MEV)**2
             EC=(em1+em2+0.02)**2
            xkaon=0.
            if(srt.gt.1.23)xkaon=(pionpp(srt)+PIPP1(SRT))/2.
 * pion+nucleon elastic cross section is divided into two parts:
 * (1) forming D(1232)+N*(1440) +N*(1535)
 * (2) cross sections forming higher resonances are calculated as
 *     the difference between the total elastic and (1), this part is 
 *     treated as direct process since we do not explicitLY include
 *     higher resonances.
 * the following is the resonance formation cross sections.
 *1. PION(+)+PROTON-->DELTA++,PION(-)+NEUTRON-->DELTA(-)
            IF( (LB1*LB2.EQ.5.OR.((LB1*LB2.EQ.6).AND.
      &         (LB1.EQ.3.OR.LB2.EQ.3)))
      &    .OR. (LB1*LB2.EQ.-3.OR.((LB1*LB2.EQ.-10).AND.
      &         (LB1.EQ.5.OR.LB2.EQ.5))) )then    
               XMAX=190.
               xmaxn=0
               xmaxn1=0
               xdirct=dirct1(srt)
                go to 678
            endif
 *2. PION(-)+PROTON-->DELTA0,PION(+)+NEUTRON-->DELTA+ 
 *   or N*(+)(1440) or N*(+)(1535)
 * note the factor 2/3 is from the isospin consideration and
 * the factor 0.6 or 0.5 is the branching ratio for the resonance to decay
 * into pion+nucleon
             IF( (LB1*LB2.EQ.3.OR.((LB1*LB2.EQ.10).AND.
      &          (LB1.EQ.5.OR.LB2.EQ.5)))
      &     .OR. (LB1*LB2.EQ.-5.OR.((LB1*LB2.EQ.-6).AND.
      &          (LB1.EQ.3.OR.LB2.EQ.3))) )then      
               XMAX=27.
               xmaxn=2./3.*25.*0.6
                xmaxn1=2./3.*40.*0.5
               xdirct=dirct2(srt)
                go to 678
               endif
 *3. PION0+PROTON-->DELTA+,PION0+NEUTRON-->DELTA0, or N*(0)(1440) or N*(0)(1535)
             IF((LB1.EQ.4.OR.LB2.EQ.4).AND.
      &         (iabs(LB1*LB2).EQ.4.OR.iabs(LB1*LB2).EQ.8))then
               XMAX=50.
               xmaxn=1./3.*25*0.6
               xmaxn1=1/3.*40.*0.5
               xdirct=dirct3(srt)
                 go to 678
               endif
 678           xnpin1=0
            xnpin=0
             XNPID=XNPI(I1,I2,1,XMAX)
            if(xmaxn1.ne.0)xnpin1=XNPI(i1,i2,2,XMAXN1)
             if(xmaxn.ne.0)XNPIN=XNPI(I1,I2,0,XMAXN)
 * the following 
            xres=xnpid+xnpin+xnpin1
            xnelas=xres+xdirct 
            icheck=1
            go to 34
 * For pion + baryon resonance the reabsorption 
 * cross section is calculated from the detailed balance
 * using reab(i1,i2,srt,ictrl), ictrl=1, 2 and 3
 * for pion, rho and omega + baryon resonance
 31           ec=(em1+em2+0.02)**2
            xreab=reab(i1,i2,srt,1)
 
 clin-12/02/00 to satisfy detailed balance, forbid N* absorptions:
           if((iabs(lb1).ge.10.and.iabs(lb1).le.13)
      1         .or.(iabs(lb2).ge.10.and.iabs(lb2).le.13)) XREAB = 0.
 
            xkaon=xkaon0+xreab
 * a constant of 10 mb IS USED FOR PION + N* RESONANCE, 
         IF((iabs(LB1).GT.9.AND.iabs(LB1).LE.13) .OR.
      &      (iabs(LB2).GT.9.AND.iabs(LB2).LE.13))THEN
            Xnelas=1.0
         ELSE
            XNELAS=DPION(EM1,EM2,LB1,LB2,SRT)
         ENDIF
            icheck=2
 34          IF((Xnelas+xkaon+Xphi).LE.0.000001)GO TO 400
             DS=SQRT((Xnelas+xkaon+Xphi)/PI)
 csp09/20/01
 c           totcr = xnelas+xkaon
 c           if(srt .gt. 3.5)totcr = max1(totcr,3.)
 c           DS=SQRT(totcr/PI)
 csp09/20/01 end
             
            deltar=ds+0.1
          CALL DISTCE(I1,I2,DELTAR,DS,DT,EC,SRT,IC,
      1   PCX,PCY,PCZ)
          IF(IC.EQ.-1) GO TO 400
        ekaon(4,iss)=ekaon(4,iss)+1
 c***
 * check what kind of collision has happened
 * (1) pion+baryon resonance
 * if direct elastic process
         if(icheck.eq.2)then
 c  !!sp11/21/01
       if(xnelas/(xnelas+xkaon+Xphi).ge.RANART(NSEED))then
 c               call Crdir(PX1CM,PY1CM,PZ1CM,SRT,I1,I2)
                call Crdir(PX1CM,PY1CM,PZ1CM,SRT,I1,I2,IBLOCK)
               go to 440
               else
 * for inelastic process, go to 96 to check
 * kaon production and pion reabsorption : pion+D(N*)-->pion+N
                go to 96
                 endif
               endif
 *(2) pion+n
 * CHECK IF inELASTIC COLLISION IS POSSIBLE FOR PION+N COLLISIONS
 clin-8/17/00 typo corrected, many other occurences:
 c        IF(XKAON/(XKAON+Xnelas).GT.RANART(NSEED))GO TO 95
        IF((XKAON+Xphi)/(XKAON+Xphi+Xnelas).GT.RANART(NSEED))GO TO 95
 
 * direct process
         if(xdirct/xnelas.ge.RANART(NSEED))then
 c               call Crdir(PX1CM,PY1CM,PZ1CM,SRT,I1,I2)
                call Crdir(PX1CM,PY1CM,PZ1CM,SRT,I1,I2,IBLOCK)
               go to 440
               endif
 * now resonance formation or direct process (higher resonances)
            IF( (LB1*LB2.EQ.5.OR.((LB1*LB2.EQ.6).AND.
      &         (LB1.EQ.3.OR.LB2.EQ.3)))
      &    .OR. (LB1*LB2.EQ.-3.OR.((LB1*LB2.EQ.-10).AND.
      &         (LB1.EQ.5.OR.LB2.EQ.5))) )then    
 c
 * ONLY DELTA RESONANCE IS POSSIBLE, go to 99
         GO TO 99
        else
 * NOW BOTH DELTA AND N* RESORANCE ARE POSSIBLE
 * DETERMINE THE RESORANT STATE BY USING THE MONTRE CARLO METHOD
             XX=(XNPIN+xnpin1)/xres
             IF(RANART(NSEED).LT.XX)THEN
 * N* RESONANCE IS SELECTED
 * decide N*(1440) or N*(1535) formation
         xx0=xnpin/(xnpin+xnpin1)
         if(RANART(NSEED).lt.xx0)then
          RESONA=0.
 * N*(1440) formation
          GO TO 97
         else
 * N*(1535) formation
         resona=1.
          GO TO 98
         endif
          ELSE
 * DELTA RESONANCE IS SELECTED
          GO TO 99
          ENDIF
          ENDIF
 97       CONTINUE
             IF(RESONA.EQ.0.)THEN
 *N*(1440) IS PRODUCED,WE DETERMINE THE CHARGE STATE OF THE PRODUCED N*
             I=I1
             IF(EM1.LT.0.6)I=I2
 * (0.1) n+pion(+)-->N*(+)
            IF( (LB1*LB2.EQ.10.AND.(LB1.EQ.5.OR.LB2.EQ.5))
      &      .OR.(LB1*LB2.EQ.-6.AND.(LB1.EQ.3.OR.LB2.EQ.3)) )THEN
             LB(I)=11
            go to 303
             ENDIF
 * (0.2) p+pion(0)-->N*(+)
 c            IF(LB(I1)*LB(I2).EQ.4.AND.(LB(I1).EQ.1.OR.LB(I2).EQ.1))THEN
             IF(iabs(LB(I1)*LB(I2)).EQ.4.AND.
      &         (LB(I1).EQ.4.OR.LB(I2).EQ.4))THEN    
             LB(I)=11
            go to 303
             ENDIF
 * (0.3) n+pion(0)-->N*(0)
 c            IF(LB(I1)*LB(I2).EQ.8.AND.(LB(I1).EQ.2.OR.LB(I2).EQ.2))THEN
             IF(iabs(LB(I1)*LB(I2)).EQ.8.AND.
      &        (LB(I1).EQ.4.OR.LB(I2).EQ.4))THEN    
             LB(I)=10
            go to 303
             ENDIF
 * (0.4) p+pion(-)-->N*(0)
 c            IF(LB(I1)*LB(I2).EQ.3)THEN
             IF( (LB(I1)*LB(I2).EQ.3)
      &      .OR.(LB(I1)*LB(I2).EQ.-5) )THEN
             LB(I)=10
             ENDIF
 303         CALL DRESON(I1,I2)
             if(LB1.lt.0.or.LB2.lt.0) LB(I)=-LB(I)
             lres=lres+1
             GO TO 101
 *COM: GO TO 101 TO CHANGE THE PHASE SPACE DENSITY OF THE NUCLEON
             ENDIF
 98          IF(RESONA.EQ.1.)THEN
 *N*(1535) IS PRODUCED, WE DETERMINE THE CHARGE STATE OF THE PRODUCED N*
             I=I1
             IF(EM1.LT.0.6)I=I2
 * note: this condition applies to both eta and pion
 * (0.1) n+pion(+)-->N*(+)
 c            IF(LB1*LB2.EQ.10.AND.(LB1.EQ.2.OR.LB2.EQ.2))THEN
             IF( (LB1*LB2.EQ.10.AND.(LB1.EQ.5.OR.LB2.EQ.5))
      &      .OR.(LB1*LB2.EQ.-6.AND.(LB1.EQ.3.OR.LB2.EQ.3)) )THEN
             LB(I)=13
            go to 304
             ENDIF
 * (0.2) p+pion(0)-->N*(+)
 c            IF(LB(I1)*LB(I2).EQ.4.AND.(LB(I1).EQ.1.OR.LB(I2).EQ.1))THEN
             IF(iabs(LB(I1)*LB(I2)).EQ.4.AND.
      &           (LB(I1).EQ.4.OR.LB(I2).EQ.4))THEN 
             LB(I)=13
            go to 304
             ENDIF
 * (0.3) n+pion(0)-->N*(0)
 c            IF(LB(I1)*LB(I2).EQ.8.AND.(LB(I1).EQ.2.OR.LB(I2).EQ.2))THEN
             IF(iabs(LB(I1)*LB(I2)).EQ.8.AND.
      &           (LB(I1).EQ.4.OR.LB(I2).EQ.4))THEN      
             LB(I)=12
            go to 304
             ENDIF
 * (0.4) p+pion(-)-->N*(0)
 c            IF(LB(I1)*LB(I2).EQ.3)THEN
             IF( (LB(I1)*LB(I2).EQ.3)
      &      .OR.(LB(I1)*LB(I2).EQ.-5) )THEN
             LB(I)=12
            go to 304
            endif
 * (0.5) p+eta-->N*(+)(1535),n+eta-->N*(0)(1535)
            if(lb(i1)*lb(i2).eq.0)then
 c            if((lb(i1).eq.1).or.(lb(i2).eq.1))then
             if(iabs(lb(i1)).eq.1.or.iabs(lb(i2)).eq.1)then
            LB(I)=13
            go to 304
            ELSE
            LB(I)=12
            ENDIF
            endif
 304         CALL DRESON(I1,I2)
             if(LB1.lt.0.or.LB2.lt.0) LB(I)=-LB(I) 
             lres=lres+1
             GO TO 101
 *COM: GO TO 101 TO CHANGE THE PHASE SPACE DENSITY OF THE NUCLEON
             ENDIF
 *DELTA IS PRODUCED,IN THE FOLLOWING WE DETERMINE THE
 *CHARGE STATE OF THE PRODUCED DELTA
 99      LRES=LRES+1
         I=I1
         IF(EM1.LE.0.6)I=I2
 * (1) p+pion(+)-->DELTA(++)
 c        IF(LB(I1)*LB(I2).EQ.5)THEN
             IF( (LB(I1)*LB(I2).EQ.5)
      &      .OR.(LB(I1)*LB(I2).EQ.-3) )THEN
         LB(I)=9
        go to 305
         ENDIF
 * (2) p+pion(0)-->delta(+)
 c        IF(LB(I1)*LB(I2).EQ.4.AND.(LB(I1).EQ.1.OR.LB(I2).EQ.1))then
        IF(iabs(LB(I1)*LB(I2)).EQ.4.AND.(LB(I1).EQ.4.OR.LB(I2).EQ.4))then
         LB(I)=8
        go to 305
         ENDIF
 * (3) n+pion(+)-->delta(+)
 c        IF(LB(I1)*LB(I2).EQ.10.AND.(LB(I1).EQ.2.OR.LB(I2).EQ.2))THEN
        IF( (LB(I1)*LB(I2).EQ.10.AND.(LB(I1).EQ.5.OR.LB(I2).EQ.5))
      & .OR.(LB(I1)*LB(I2).EQ.-6.AND.(LB(I1).EQ.3.OR.LB(I2).EQ.3)) )THEN
         LB(I)=8
        go to 305
         ENDIF
 * (4) n+pion(0)-->delta(0)
 c        IF(LB(I1)*LB(I2).EQ.8.AND.(LB(I1).EQ.2.OR.LB(I2).EQ.2))THEN
        IF(iabs(LB(I1)*LB(I2)).EQ.8.AND.(LB(I1).EQ.4.OR.LB(I2).EQ.4))THEN
         LB(I)=7
        go to 305
         ENDIF
 * (5) p+pion(-)-->delta(0)
 c        IF(LB(I1)*LB(I2).EQ.3)THEN
             IF( (LB(I1)*LB(I2).EQ.3)
      &      .OR.(LB(I1)*LB(I2).EQ.-5) )THEN
         LB(I)=7
        go to 305
         ENDIF
 * (6) n+pion(-)-->delta(-)
 c        IF(LB(I1)*LB(I2).EQ.6.AND.(LB(I1).EQ.2.OR.LB(I2).EQ.2))THEN
        IF( (LB(I1)*LB(I2).EQ.6.AND.(LB(I1).EQ.3.OR.LB(I2).EQ.3))
      & .OR.(LB(I1)*LB(I2).EQ.-10.AND.(LB(I1).EQ.5.OR.LB(I2).EQ.5)) )THEN 
         LB(I)=6
         ENDIF
 305     CALL DRESON(I1,I2)
         if(LB1.lt.0.or.LB2.lt.0) LB(I)=-LB(I) 
        GO TO 101
 
 csp-11/08/01 K*
 * FOR kaON+pion COLLISIONS, form K* (bar) or
 c La/Si-bar + N <-- pi + K+
 c La/Si + N-bar <-- pi + K-                                             
 c phi + K <-- pi + K                                             
 clin (rho,omega) + K* <-- pi + K
 889       CONTINUE
         PX1CM=PCX
         PY1CM=PCY
         PZ1CM=PCZ
         EC=(em1+em2+0.02)**2
 * the cross section is from C.M. Ko, PRC 23, 2760 (1981).
        spika=60./(1.+4.*(srt-0.895)**2/(0.05)**2)
 c
 cc       if(lb(i1).eq.23.or.lb(i2).eq.23)then   !! block  K- + pi->La + B-bar
 
         call Crkpla(PX1CM,PY1CM,PZ1CM,EC,SRT,spika,
      &                  emm1,emm2,lbp1,lbp2,I1,I2,icase,srhoks)
 cc
 c* only K* or K*bar formation
 c       else 
 c      DSkn=SQRT(spika/PI/10.)
 c      dsknr=dskn+0.1
 c      CALL DISTCE(I1,I2,dsknr,DSkn,DT,EC,SRT,IC,
 c    1     PX1CM,PY1CM,PZ1CM)
 c        IF(IC.EQ.-1) GO TO 400
 c       icase = 1
 c      endif
 c
          if(icase .eq. 0) then
             iblock=0
             go to 400
          endif
 
        if(icase .eq. 1)then
              call KSRESO(I1,I2)
 clin-4/30/03 give non-zero iblock for resonance selections:
              iblock = 171
 ctest off for resonance (phi, K*) studies:
 c             if(iabs(lb(i1)).eq.30) then
 c             write(17,112) 'ks',lb(i1),p(1,i1),p(2,i1),p(3,i1),e(i1),nt
 c             elseif(iabs(lb(i2)).eq.30) then
 c             write(17,112) 'ks',lb(i2),p(1,i2),p(2,i2),p(3,i2),e(i2),nt
 c             endif
 c
               lres=lres+1
               go to 101
        elseif(icase .eq. 2)then
              iblock = 71
 c
 * La/Si (bar) formation                                                   
 
        elseif(iabs(icase).eq.5)then
              iblock = 88
 
        else
 *
 * phi formation
              iblock = 222
        endif
              LB(I1) = lbp1
              LB(I2) = lbp2
              E(I1) = emm1
              E(I2) = emm2
              em1=e(i1)
              em2=e(i2)
              ntag = 0
              go to 440
 c             
 33       continue
        em1=e(i1)
        em2=e(i2)
 * (1) if rho or omega collide with a nucleon we allow both elastic 
 *     scattering and kaon production to happen if collision conditions 
 *     are satisfied.
 * (2) if rho or omega collide with a baryon resonance we allow
 *     kaon production, pion reabsorption: rho(omega)+D(N*)-->pion+N
 *     and NO elastic scattering to happen
            xelstc=0
             if((lb1.ge.25.and.lb1.le.28).and.
      &    (iabs(lb2).eq.1.or.iabs(lb2).eq.2))
      &      xelstc=ERHON(EM1,EM2,LB1,LB2,SRT)
             if((lb2.ge.25.and.lb2.le.28).and.
      &   (iabs(lb1).eq.1.or.iabs(lb1).eq.2))
      &      xelstc=ERHON(EM1,EM2,LB1,LB2,SRT)
             ec=(em1+em2+0.02)**2
 * the kaon production cross section is
            xkaon0=0
            if(srt.ge.1.63.AND.SRT.LE.1.7)xkaon0=pnlka(srt)
            IF(SRT.GT.1.7)XKAON0=PNLKA(SRT)+pnska(srt)
            if(xkaon0.lt.0)xkaon0=0
 
 cbz3/7/99 neutralk
             XKAON0 = 2.0 * XKAON0
 cbz3/7/99 neutralk end
 
 * the total inelastic cross section for rho(omega)+N is
            xkaon=xkaon0
            ichann=0
 * the total inelastic cross section for rho (omega)+D(N*) is 
 * xkaon=xkaon0+reab(**) 
 
 c sp11/21/01  phi production: rho + N(D) -> phi + N(D)
          Xphi = 0.
        if( ( (((lb1.ge.1.and.lb1.le.2).or.
      &         (lb1.ge.6.and.lb1.le.9))
      &         .and.(lb2.ge.25.and.lb2.le.27))
      &   .OR.(((lb2.ge.1.and.lb2.le.2).or.
      &         (lb2.ge.6.and.lb2.le.9))
      &        .and.(lb1.ge.25.and.lb1.le.27)) ).AND. srt.gt.1.958)
      &    call pibphi(srt,lb1,lb2,em1,em2,Xphi,xphin)
 c !! in fm^2 above
 c
         if((iabs(lb1).ge.6.and.lb2.ge.25).or.
      &    (lb1.ge.25.and.iabs(lb2).ge.6))then
            ichann=1
            ictrl=2
            if(lb1.eq.28.or.lb2.eq.28)ictrl=3
             xreab=reab(i1,i2,srt,ictrl)
 
 clin-12/02/00 to satisfy detailed balance, forbid N* absorptions:
             if((iabs(lb1).ge.10.and.iabs(lb1).le.13)
      1           .or.(iabs(lb2).ge.10.and.iabs(lb2).le.13)) XREAB = 0.
 
         if(xreab.lt.0)xreab=1.E-06
             xkaon=xkaon0+xreab
           XELSTC=1.0
            endif
             DS=SQRT((XKAON+Xphi+xelstc)/PI)
 c
 csp09/20/01
 c           totcr = xelstc+xkaon
 c           if(srt .gt. 3.5)totcr = max1(totcr,3.)
 c           DS=SQRT(totcr/PI)
 csp09/20/01 end
 c
         DELTAR=DS+0.1
        px1cm=pcx
        py1cm=pcy
        pz1cm=pcz
 * CHECK IF the collision can happen
          CALL DISTCE(I1,I2,DELTAR,DS,DT,EC,SRT,IC,
      1   PCX,PCY,PCZ)
          IF(IC.EQ.-1) GO TO 400
         ekaon(4,iss)=ekaon(4,iss)+1
 c*
 * NOW rho(omega)+N or D(N*) COLLISION IS POSSIBLE
 * (1) check elastic collision
        if(xelstc/(xelstc+xkaon+Xphi).gt.RANART(NSEED))then
 c       call crdir(px1CM,py1CM,pz1CM,srt,I1,i2)
        call crdir(px1CM,py1CM,pz1CM,srt,I1,i2,IBLOCK)
        go to 440
        endif
 * (2) check pion absorption or kaon production
         CALL CRRD(PX1CM,PY1CM,PZ1CM,SRT,I1,I2,
      1  IBLOCK,xkaon0,xkaon,Xphi,xphin)
 
 * kaon production
 csp05/16/01
        IF(IBLOCK.EQ.7) then
           LPN=LPN+1
        elseIF(IBLOCK.EQ.-7) then
        endif
 csp05/16/01 end
 * rho obsorption
        if(iblock.eq.81) lrhor=lrhor+1
 * omega obsorption
        if(iblock.eq.82) lomgar=lomgar+1
        em1=e(i1)
        em2=e(i2)
        GO TO 440
 * for pion+n now using the subroutine crpn to change 
 * the particle label and set the new momentum of L/S+K final state
 95       continue
 * NOW PION+N INELASTIC COLLISION IS POSSIBLE
 * check pion production or kaon production
         CALL CRPN(PX1CM,PY1CM,PZ1CM,SRT,I1,I2,
      1  IBLOCK,xkaon0,xkaon,Xphi,xphin)
 
 * kaon production
 csp05/16/01
        IF(IBLOCK.EQ.7) then
           LPN=LPN+1
        elseIF(IBLOCK.EQ.-7) then
        endif
 csp05/16/01 end
 * pion production
        if(iblock.eq.77) lpd=lpd+1
 * rho production
        if(iblock.eq.78) lrho=lrho+1
 * omega production
        if(iblock.eq.79) lomega=lomega+1
        em1=e(i1)
        em2=e(i2)
        GO TO 440
 * for pion+D(N*) now using the subroutine crpd to 
 * (1) check kaon production or pion reabsorption 
 * (2) change the particle label and set the new 
 *     momentum of L/S+K final state
 96       continue
         CALL CRPD(PX1CM,PY1CM,PZ1CM,SRT,I1,I2,
      1  IBLOCK,xkaon0,xkaon,Xphi,xphin)
 
 * kaon production
 csp05/16/01
        IF(IBLOCK.EQ.7) then
           LPN=LPN+1
        elseIF(IBLOCK.EQ.-7) then
        endif
 csp05/16/01 end
 * pion obserption
        if(iblock.eq.80) lpdr=lpdr+1
        em1=e(i1)
        em2=e(i2)
        GO TO 440
 * CALCULATE KAON PRODUCTION PROBABILITY FROM PION + N COLLISIONS
 C        IF(SRT.GT.1.615)THEN
 C        CALL PKAON(SRT,XXp,PK)
 C        TKAON(7)=TKAON(7)+PK 
 C        EKAON(7,ISS)=EKAON(7,ISS)+1
 c        CALL KSPEC1(SRT,PK)
 C        call LK(3,srt,iseed,pk)
 C        ENDIF
 * negelecting the pauli blocking at high energies
 
 101       continue
         IF(E(I2).EQ.0.)GO TO 600
         IF(E(I1).EQ.0.)GO TO 800
 * IF NUCLEON+BARYON RESONANCE COLLISIONS
 44      CONTINUE
 * CALCULATE THE TOTAL CROSS SECTION OF NUCLEON+ BARYON RESONANCE COLLISION
 * WE ASSUME THAT THE ELASTIC CROSS SECTION IS THE SAME AS NUCLEON+NUCLEON
 * COM: WE USE THE PARAMETERISATION BY CUGNON FOR LOW ENERGIES
 *      AND THE PARAMETERIZATIONS FROM CERN DATA BOOK FOR HIGHER 
 *      ENERGIES. THE CUTOFF FOR THE TOTAL CROSS SECTION IS 55 MB 
        cutoff=em1+em2+0.02
        IF(SRT.LE.CUTOFF)GO TO 400
         IF(SRT.GT.2.245)THEN
        SIGNN=PP2(SRT)
        ELSE
         SIGNN = 35.0 / (1. + (SRT - CUTOFF) * 100.0)  +  20.0
        ENDIF 
         call XND(pcx,pcy,pcz,srt,I1,I2,xinel,
      &               sigk,xsk1,xsk2,xsk3,xsk4,xsk5)
        sig=signn+xinel
 * For nucleon+baryon resonance collision, the minimum cms**2 energy is
         EC=(EM1+EM2+0.02)**2
 * CHECK THE DISTENCE BETWEEN THE TWO PARTICLES
         PX1CM=PCX
         PY1CM=PCY
         PZ1CM=PCZ
 
 clin-6/2008 Deuteron production:
         ianti=0
         if(lb(i1).lt.0 .and. lb(i2).lt.0) ianti=1
         call sbbdm(srt,sdprod,ianti,lbm,xmm,pfinal)
         sig=sig+sdprod
 clin-6/2008 perturbative treatment of deuterons:
         ipdflag=0
         if(idpert.eq.1) then
            ipert1=1
            sigr0=sig
            dspert=sqrt(sigr0/pi/10.)
            dsrpert=dspert+0.1
            CALL DISTCE(I1,I2,dsrpert,dspert,DT,EC,SRT,IC,
      1          PX1CM,PY1CM,PZ1CM)
            IF(IC.EQ.-1) GO TO 363
            signn0=0.
            CALL CRND(IRUN,PX1CM,PY1CM,PZ1CM,SRT,I1,I2,
      &  IBLOCK,SIGNN0,SIGr0,sigk,xsk1,xsk2,xsk3,xsk4,xsk5,NT,ipert1)
 c     &  IBLOCK,SIGNN,SIG,sigk,xsk1,xsk2,xsk3,xsk4,xsk5)
            ipdflag=1
  363       continue
            ipert1=0
         endif
         if(idpert.eq.2) ipert1=1
 c
         DS=SQRT(SIG/(10.*PI))
         DELTAR=DS+0.1
         CALL DISTCE(I1,I2,DELTAR,DS,DT,EC,SRT,IC,
      1  PX1CM,PY1CM,PZ1CM)
 c        IF(IC.EQ.-1)GO TO 400
         IF(IC.EQ.-1) then
            if(ipdflag.eq.1) iblock=501
            GO TO 400
         endif
 
         ekaon(3,iss)=ekaon(3,iss)+1
 * CALCULATE KAON PRODUCTION PROBABILITY FROM NUCLEON + BARYON RESONANCE 
 * COLLISIONS
         go to 361
 
 * CHECK WHAT KIND OF COLLISION HAS HAPPENED
  361    continue 
         CALL CRND(IRUN,PX1CM,PY1CM,PZ1CM,SRT,I1,I2,
      &     IBLOCK,SIGNN,SIG,sigk,xsk1,xsk2,xsk3,xsk4,xsk5,NT,ipert1)
 c     &  IBLOCK,SIGNN,SIG,sigk,xsk1,xsk2,xsk3,xsk4,xsk5)
         IF(iblock.eq.0.and.ipdflag.eq.1) iblock=501
         IF(IBLOCK.EQ.11)THEN
            LNDK=LNDK+1
            GO TO 400
 c        elseIF(IBLOCK.EQ.-11) then
         elseIF(IBLOCK.EQ.-11.or.iblock.eq.501) then
            GO TO 400
         ENDIF
         if(iblock .eq. 222)then
 c    !! sp12/17/01 
            GO TO 400
         ENDIF
         em1=e(i1)
         em2=e(i2)
         GO TO 440
 * IF NUCLEON+NUCLEON OR BARYON RESONANCE+BARYON RESONANCE COLLISIONS
 4       CONTINUE
 * PREPARE THE EALSTIC CROSS SECTION FOR BARYON+BARYON COLLISIONS
 * COM: WE USE THE PARAMETERISATION BY CUGNON FOR SRT LEQ 2.0 GEV
 *      AND THE PARAMETERIZATIONS FROM CERN DATA BOOK FOR HIGHER 
 *      ENERGIES. THE CUTOFF FOR THE TOTAL CROSS SECTION IS 55 MB 
 *      WITH LOW-ENERGY-CUTOFF
         CUTOFF=em1+em2+0.14
 * AT HIGH ENERGIES THE ISOSPIN DEPENDENCE IS NEGLIGIBLE
 * THE TOTAL CROSS SECTION IS TAKEN AS THAT OF THE PP 
 * ABOVE E_KIN=800 MEV, WE USE THE ISOSPIN INDEPENDNET XSECTION
         IF(SRT.GT.2.245)THEN
            SIG=ppt(srt)
            SIGNN=SIG-PP1(SRT)
         ELSE
 * AT LOW ENERGIES THE ISOSPIN DEPENDENCE FOR NN COLLISION IS STRONG
            SIG=XPP(SRT)
            IF(ZET(LB(I1))*ZET(LB(I2)).LE.0)SIG=XNP(SRT)
            IF(ZET(LB(I1))*ZET(LB(I2)).GT.0)SIG=XPP(SRT)
            IF(ZET(LB(I1)).EQ.0.
      &          AND.ZET(LB(I2)).EQ.0)SIG=XPP(SRT)
            if((lb(i1).eq.-1.and.lb(i2).eq.-2) .or.
      &          (lb(i2).eq.-1.and.lb(i1).eq.-2))sig=xnp(srt)
 *     WITH LOW-ENERGY-CUTOFF
            IF (SRT .LT. 1.897) THEN
               SIGNN = SIG
            ELSE 
               SIGNN = 35.0 / (1. + (SRT - 1.897) * 100.0)  +  20.0
            ENDIF
         ENDIF 
         PX1CM=PCX
         PY1CM=PCY
         PZ1CM=PCZ
 clin-5/2008 Deuteron production cross sections were not included 
 c     in the previous parameterized inelastic cross section of NN collisions  
 c     (SIGinel=SIG-SIGNN), so they are added here:
         ianti=0
         if(lb(i1).lt.0 .and. lb(i2).lt.0) ianti=1
         call sbbdm(srt,sdprod,ianti,lbm,xmm,pfinal)
         sig=sig+sdprod
 c
 clin-5/2008 perturbative treatment of deuterons:
         ipdflag=0
         if(idpert.eq.1) then
 c     For idpert=1: ipert1=1 means we will first treat deuteron perturbatively,
 c     then we set ipert1=0 to treat regular NN or NbarNbar collisions including
 c     the regular deuteron productions.
 c     ipdflag=1 means perturbative deuterons are produced here:
            ipert1=1
            EC=2.012**2
 c     Use the same cross section for NN/NNBAR collisions 
 c     to trigger perturbative production
            sigr0=sig
 c     One can also trigger with X*sbbdm() so the weight will not be too small;
 c     but make sure to limit the maximum trigger Xsec:
 c           sigr0=sdprod*25.
 c           if(sigr0.ge.100.) sigr0=100.
            dspert=sqrt(sigr0/pi/10.)
            dsrpert=dspert+0.1
            CALL DISTCE(I1,I2,dsrpert,dspert,DT,EC,SRT,IC,
      1          PX1CM,PY1CM,PZ1CM)
            IF(IC.EQ.-1) GO TO 365
            signn0=0.
            CALL CRNN(IRUN,PX1CM,PY1CM,PZ1CM,SRT,I1,I2,IBLOCK,
      1          NTAG,signn0,sigr0,NT,ipert1)
            ipdflag=1
  365       continue
            ipert1=0
         endif
         if(idpert.eq.2) ipert1=1
 c
 clin-5/2008 in case perturbative deuterons are produced for idpert=1:
 c        IF(SIGNN.LE.0)GO TO 400
         IF(SIGNN.LE.0) then
            if(ipdflag.eq.1) iblock=501
            GO TO 400
         endif
 c
         EC=3.59709
         ds=sqrt(sig/pi/10.)
         dsr=ds+0.1
         IF((E(I1).GE.1.).AND.(e(I2).GE.1.))EC=4.75
         CALL DISTCE(I1,I2,dsr,ds,DT,EC,SRT,IC,
      1       PX1CM,PY1CM,PZ1CM)
 clin-5/2008 in case perturbative deuterons are produced above:
 c        IF(IC.EQ.-1) GO TO 400
         IF(IC.EQ.-1) then
            if(ipdflag.eq.1) iblock=501
            GO TO 400
         endif
 c
 * CALCULATE KAON PRODUCTION PROBABILITY FROM NUCLEON+NUCLEON OR 
 * RESONANCE+RESONANCE COLLISIONS
         go to 362
 
 C CHECK WHAT KIND OF COLLISION HAS HAPPENED 
  362    ekaon(1,iss)=ekaon(1,iss)+1
         CALL CRNN(IRUN,PX1CM,PY1CM,PZ1CM,SRT,I1,I2,IBLOCK,
      1       NTAG,SIGNN,SIG,NT,ipert1)
 clin-5/2008 give iblock # in case pert deuterons are produced for idpert=1:
         IF(iblock.eq.0.and.ipdflag.eq.1) iblock=501
 clin-5/2008 add iblock # for deuteron formation:
 c        IF(IBLOCK.EQ.4.OR.IBLOCK.Eq.9.or.iblock.ge.44.OR.IBLOCK.EQ.-9
 c     &       .or.iblock.eq.222)THEN
         IF(IBLOCK.EQ.4.OR.IBLOCK.Eq.9.or.iblock.ge.44.OR.IBLOCK.EQ.-9
      &       .or.iblock.eq.222.or.iblock.eq.501)THEN
 c
 c     !! sp12/17/01 above
 * momentum of the three particles in the final state have been calculated
 * in the crnn, go out of the loop
            LCOLL=LCOLL+1
            if(iblock.eq.4)then
               LDIRT=LDIRT+1
            elseif(iblock.eq.44)then
               LDdrho=LDdrho+1
            elseif(iblock.eq.45)then
               Lnnrho=Lnnrho+1
            elseif(iblock.eq.46)then
               Lnnom=Lnnom+1
            elseif(iblock .eq. 222)then
            elseIF(IBLOCK.EQ.9) then
               LNNK=LNNK+1
            elseIF(IBLOCK.EQ.-9) then
            endif
            GO TO 400
         ENDIF
 
         em1=e(i1)
         em2=e(i2)
         GO TO 440
 clin-8/2008 B+B->Deuteron+Meson over
 c
 clin-8/2008 Deuteron+Meson->B+B collisions:
  505    continue
         ianti=0
         if(lb(i1).lt.0 .or. lb(i2).lt.0) ianti=1
         call sdmbb(SRT,sdm,ianti)
         PX1CM=PCX
         PY1CM=PCY
         PZ1CM=PCZ
 c     minimum srt**2, note a 2.012GeV lower cutoff is used in N+N->Deuteron+pi:
         EC=2.012**2
         ds=sqrt(sdm/31.4)
         dsr=ds+0.1
         CALL DISTCE(I1,I2,dsr,ds,DT,EC,SRT,IC,PX1CM,PY1CM,PZ1CM)
         IF(IC.EQ.-1) GO TO 400
         CALL crdmbb(PX1CM,PY1CM,PZ1CM,SRT,I1,I2,IBLOCK,
      1       NTAG,sdm,NT,ianti)
         LCOLL=LCOLL+1
         GO TO 400
 clin-8/2008 Deuteron+Meson->B+B collisions over
 c
 clin-9/2008 Deuteron+Baryon elastic collisions:
  506    continue
         ianti=0
         if(lb(i1).lt.0 .or. lb(i2).lt.0) ianti=1
         call sdbelastic(SRT,sdb)
         PX1CM=PCX
         PY1CM=PCY
         PZ1CM=PCZ
 c     minimum srt**2, note a 2.012GeV lower cutoff is used in N+N->Deuteron+pi:
         EC=2.012**2
         ds=sqrt(sdb/31.4)
         dsr=ds+0.1
         CALL DISTCE(I1,I2,dsr,ds,DT,EC,SRT,IC,PX1CM,PY1CM,PZ1CM)
         IF(IC.EQ.-1) GO TO 400
         CALL crdbel(PX1CM,PY1CM,PZ1CM,SRT,I1,I2,IBLOCK,
      1       NTAG,sdb,NT,ianti)
         LCOLL=LCOLL+1
         GO TO 400
 clin-9/2008 Deuteron+Baryon elastic collisions over
 c
 * IF BARYON RESONANCE+BARYON RESONANCE COLLISIONS
  444    CONTINUE
 * PREPARE THE EALSTIC CROSS SECTION FOR BARYON+BARYON COLLISIONS
        CUTOFF=em1+em2+0.02
 * AT HIGH ENERGIES THE ISOSPIN DEPENDENCE IS NEGLIGIBLE
 * THE TOTAL CROSS SECTION IS TAKEN AS THAT OF THE PP 
        IF(SRT.LE.CUTOFF)GO TO 400
         IF(SRT.GT.2.245)THEN
        SIGNN=PP2(SRT)
        ELSE
         SIGNN = 35.0 / (1. + (SRT - CUTOFF) * 100.0)  +  20.0
        ENDIF 
        IF(SIGNN.LE.0)GO TO 400
       CALL XDDIN(PCX,PCY,PCZ,SRT,I1,I2,
      &XINEL,SIGK,XSK1,XSK2,XSK3,XSK4,XSK5)
        SIG=SIGNN+XINEL
        EC=(EM1+EM2+0.02)**2
         PX1CM=PCX
         PY1CM=PCY
         PZ1CM=PCZ
 
 clin-6/2008 Deuteron production:
         ianti=0
         if(lb(i1).lt.0 .and. lb(i2).lt.0) ianti=1
         call sbbdm(srt,sdprod,ianti,lbm,xmm,pfinal)
         sig=sig+sdprod
 clin-6/2008 perturbative treatment of deuterons:
         ipdflag=0
         if(idpert.eq.1) then
            ipert1=1
            sigr0=sig
            dspert=sqrt(sigr0/pi/10.)
            dsrpert=dspert+0.1
            CALL DISTCE(I1,I2,dsrpert,dspert,DT,EC,SRT,IC,
      1          PX1CM,PY1CM,PZ1CM)
            IF(IC.EQ.-1) GO TO 367
            signn0=0.
            CALL CRDD(IRUN,PX1CM,PY1CM,PZ1CM,SRT,I1,I2,
      1          IBLOCK,NTAG,SIGNN0,SIGr0,NT,ipert1)
 c     1          IBLOCK,NTAG,SIGNN,SIG)
            ipdflag=1
  367       continue
            ipert1=0
         endif
         if(idpert.eq.2) ipert1=1
 c
         ds=sqrt(sig/31.4)
         dsr=ds+0.1
         CALL DISTCE(I1,I2,dsr,ds,DT,EC,SRT,IC,
      1  PX1CM,PY1CM,PZ1CM)
 c        IF(IC.EQ.-1) GO TO 400
         IF(IC.EQ.-1) then
            if(ipdflag.eq.1) iblock=501
            GO TO 400
         endif
 
 * CALCULATE KAON PRODUCTION PROBABILITY FROM NUCLEON+NUCLEON OR 
 * RESONANCE+RESONANCE COLLISIONS
        go to 364
 
 C CHECK WHAT KIND OF COLLISION HAS HAPPENED 
 364       ekaon(2,iss)=ekaon(2,iss)+1
 * for resonance+resonance
 clin-6/2008:
         CALL CRDD(IRUN,PX1CM,PY1CM,PZ1CM,SRT,I1,I2,
      1  IBLOCK,NTAG,SIGNN,SIG,NT,ipert1)
 c     1  IBLOCK,NTAG,SIGNN,SIG)
         IF(iblock.eq.0.and.ipdflag.eq.1) iblock=501
 c
         IF(iabs(IBLOCK).EQ.10)THEN
 * momentum of the three particles in the final state have been calculated
 * in the crnn, go out of the loop
            LCOLL=LCOLL+1
            IF(IBLOCK.EQ.10)THEN
               LDDK=LDDK+1
            elseIF(IBLOCK.EQ.-10) then
            endif
            GO TO 400
         ENDIF
 clin-6/2008
 c        if(iblock .eq. 222)then
         if(iblock .eq. 222.or.iblock.eq.501)then
 c    !! sp12/17/01 
            GO TO 400
         ENDIF
         em1=e(i1)
         em2=e(i2)
         GO TO 440
 * FOR PION+PION,pion+eta, eta+eta and rho(omega)+pion(rho,omega) or eta 
 777       CONTINUE
         PX1CM=PCX
         PY1CM=PCY
         PZ1CM=PCZ
 * energy thresh for collisions
        ec0=em1+em2+0.02
        IF(SRT.LE.ec0)GO TO 400
        ec=(em1+em2+0.02)**2
 * we negelect the elastic collision between mesons except that betwen
 * two pions because of the lack of information about these collisions
 * However, we do let them to collide inelastically to produce kaons
 clin-8/15/02       ppel=1.e-09
        ppel=20.
         ipp=1
        if(lb1.lt.3.or.lb1.gt.5.or.lb2.lt.3.or.lb2.gt.5)go to 778       
        CALL PPXS(LB1,LB2,SRT,PPSIG,spprho,IPP)
        ppel=ppsig
 778       ppink=pipik(srt)
 
 * pi+eta and eta+eta are assumed to be the same as pipik( for pi+pi -> K+K-) 
 * estimated from Ko's paper:
         ppink = 2.0 * ppink
        if(lb1.ge.25.and.lb2.ge.25) ppink=rrkk
 
 clin-2/13/03 include omega the same as rho, eta the same as pi:
 c        if(((lb1.ge.3.and.lb1.le.5).and.(lb2.ge.25.and.lb2.le.27))
 c     1  .or.((lb2.ge.3.and.lb2.le.5).and.(lb1.ge.25.and.lb1.le.27)))
         if( ( (lb1.eq.0.or.(lb1.ge.3.and.lb1.le.5))
      1       .and.(lb2.ge.25.and.lb2.le.28))
      2       .or. ( (lb2.eq.0.or.(lb2.ge.3.and.lb2.le.5))
      3       .and.(lb1.ge.25.and.lb1.le.28))) then
            ppink=0.
            if(srt.ge.(aka+aks)) ppink = prkk
         endif
 
 c pi pi <-> rho rho:
         call spprr(lb1,lb2,srt)
 clin-4/03/02 pi pi <-> eta eta:
         call sppee(lb1,lb2,srt)
 clin-4/03/02 pi pi <-> pi eta:
         call spppe(lb1,lb2,srt)
 clin-4/03/02 rho pi <-> rho eta:
         call srpre(lb1,lb2,srt)
 clin-4/03/02 omega pi <-> omega eta:
         call sopoe(lb1,lb2,srt)
 clin-4/03/02 rho rho <-> eta eta:
         call srree(lb1,lb2,srt)
 
         ppinnb=0.
         if(srt.gt.thresh(1)) then
            call getnst(srt)
            if(lb1.ge.3.and.lb1.le.5.and.lb2.ge.3.and.lb2.le.5) then
               ppinnb=ppbbar(srt)
            elseif((lb1.ge.3.and.lb1.le.5.and.lb2.ge.25.and.lb2.le.27)
      1 .or.(lb2.ge.3.and.lb2.le.5.and.lb1.ge.25.and.lb1.le.27)) then
               ppinnb=prbbar(srt)
            elseif(lb1.ge.25.and.lb1.le.27
      1             .and.lb2.ge.25.and.lb2.le.27) then
               ppinnb=rrbbar(srt)
            elseif((lb1.ge.3.and.lb1.le.5.and.lb2.eq.28)
      1             .or.(lb2.ge.3.and.lb2.le.5.and.lb1.eq.28)) then
               ppinnb=pobbar(srt)
            elseif((lb1.ge.25.and.lb1.le.27.and.lb2.eq.28)
      1             .or.(lb2.ge.25.and.lb2.le.27.and.lb1.eq.28)) then
               ppinnb=robbar(srt)
            elseif(lb1.eq.28.and.lb2.eq.28) then
               ppinnb=oobbar(srt)
            else
               if(lb1.ne.0.and.lb2.ne.0) 
      1             write(6,*) 'missed MM lb1,lb2=',lb1,lb2
            endif
         endif
         ppin=ppink+ppinnb+pprr+ppee+pppe+rpre+xopoe+rree
 
 * check if a collision can happen
        if((ppel+ppin).le.0.01)go to 400
        DSPP=SQRT((ppel+ppin)/31.4)
        dsppr=dspp+0.1
         CALL DISTCE(I1,I2,dsppr,DSPP,DT,EC,SRT,IC,
      1  PX1CM,PY1CM,PZ1CM)
         IF(IC.EQ.-1) GO TO 400
        if(ppel.eq.0)go to 400
 * the collision can happen
 * check what kind collision has happened
        ekaon(5,iss)=ekaon(5,iss)+1
         CALL CRPP(PX1CM,PY1CM,PZ1CM,SRT,I1,I2,
      1  IBLOCK,ppel,ppin,spprho,ipp)
 
 * rho formation, go to 400
 c       if(iblock.eq.666)go to 600
        if(iblock.eq.666)go to 555
        if(iblock.eq.6)LPP=LPP+1
        if(iblock.eq.66)then
           LPPk=LPPk+1
        elseif(iblock.eq.366)then
           LPPk=LPPk+1
        elseif(iblock.eq.367)then
           LPPk=LPPk+1
        endif
        em1=e(i1)
        em2=e(i2)
        go to 440
 
 * In this block we treat annihilations of
 clin-9/28/00* an anti-nucleon and a baryon or baryon resonance  
 * an anti-baryon and a baryon (including resonances)
 2799        CONTINUE
         PX1CM=PCX
         PY1CM=PCY
         PZ1CM=PCZ
         EC=(em1+em2+0.02)**2
 clin assume the same cross section (as a function of sqrt s) as for PPbar:
 
 clin-ctest annih maximum
 c        DSppb=SQRT(amin1(xppbar(srt),30.)/PI/10.)
        DSppb=SQRT(xppbar(srt)/PI/10.)
        dsppbr=dsppb+0.1
         CALL DISTCE(I1,I2,dsppbr,DSppb,DT,EC,SRT,IC,
      1  PX1CM,PY1CM,PZ1CM)
         IF(IC.EQ.-1) GO TO 400
         CALL Crppba(PX1CM,PY1CM,PZ1CM,SRT,I1,I2,
      1  IBLOCK)
        em1=e(i1)
        em2=e(i2)
        go to 440
 c
 3555    PX1CM=PCX
         PY1CM=PCY
         PZ1CM=PCZ
         EC=(em1+em2+0.02)**2
        DSkk=SQRT(SIG/PI/10.)
        dskk0=dskk+0.1
         CALL DISTCE(I1,I2,dskk0,DSkk,DT,EC,SRT,IC,
      1  PX1CM,PY1CM,PZ1CM)
         IF(IC.EQ.-1) GO TO 400
         CALL Crlaba(PX1CM,PY1CM,PZ1CM,SRT,brel,brsgm,
      &                  I1,I2,nt,IBLOCK,nchrg,icase)
        em1=e(i1)
        em2=e(i2)
        go to 440
 *
 c perturbative production of cascade and omega
 3455    PX1CM=PCX
         PY1CM=PCY
         PZ1CM=PCZ
         call pertur(PX1CM,PY1CM,PZ1CM,SRT,IRUN,I1,I2,nt,kp,icontp)
         if(icontp .eq. 0)then
 c     inelastic collisions:
          em1 = e(i1)
          em2 = e(i2)
          iblock = 727
           go to 440
         endif
 c     elastic collisions:
         if (e(i1) .eq. 0.) go to 800
         if (e(i2) .eq. 0.) go to 600
         go to 400
 *
 c* phi + N --> pi+N(D),  N(D,N*)+N(D,N*),  K+ +La
 c* phi + D --> pi+N(D)
 7222        CONTINUE
         PX1CM=PCX
         PY1CM=PCY
         PZ1CM=PCZ
         EC=(em1+em2+0.02)**2
         CALL XphiB(LB1, LB2, EM1, EM2, SRT,
      &             XSK1, XSK2, XSK3, XSK4, XSK5, SIGP)
        DSkk=SQRT(SIGP/PI/10.)
        dskk0=dskk+0.1
         CALL DISTCE(I1,I2,dskk0,DSkk,DT,EC,SRT,IC,
      1  PX1CM,PY1CM,PZ1CM)
         IF(IC.EQ.-1) GO TO 400
         CALL CRPHIB(PX1CM,PY1CM,PZ1CM,SRT,I1,I2,
      &     XSK1, XSK2, XSK3, XSK4, XSK5, SIGP, IBLOCK)
        em1=e(i1)
        em2=e(i2)
        go to 440
 *
 c* phi + M --> K+ + K* .....
 7444        CONTINUE
         PX1CM=PCX
         PY1CM=PCY
         PZ1CM=PCZ
         EC=(em1+em2+0.02)**2
         CALL PHIMES(I1, I2, SRT, XSK1, XSK2, XSK3, XSK4, XSK5,
      1     XSK6, XSK7, SIGPHI)
        DSkk=SQRT(SIGPHI/PI/10.)
        dskk0=dskk+0.1
         CALL DISTCE(I1,I2,dskk0,DSkk,DT,EC,SRT,IC,
      1  PX1CM,PY1CM,PZ1CM)
         IF(IC.EQ.-1) GO TO 400
 c*---
         PZRT = p(3,i1)+p(3,i2)
         ER1 = sqrt( p(1,i1)**2+p(2,i1)**2+p(3,i1)**2+E(i1)**2 )
         ER2 = sqrt( p(1,i2)**2+p(2,i2)**2+p(3,i2)**2+E(i2)**2 )
         ERT = ER1+ER2
         yy = 0.5*log( (ERT+PZRT)/(ERT-PZRT) )
 c*------
         CALL CRPHIM(PX1CM,PY1CM,PZ1CM,SRT,I1,I2,
      &  XSK1, XSK2, XSK3, XSK4, XSK5, XSK6, SIGPHI, IKKG, IKKL, IBLOCK)
        em1=e(i1)
        em2=e(i2)
        go to 440
 c
 c lambda-N elastic xsection, Li & Ko, PRC 54(1996)1897.
  7799    CONTINUE
          PX1CM=PCX
          PY1CM=PCY
          PZ1CM=PCZ
          EC=(em1+em2+0.02)**2
          call lambar(i1,i2,srt,siglab)
         DShn=SQRT(siglab/PI/10.)
         dshnr=dshn+0.1
          CALL DISTCE(I1,I2,dshnr,DShn,DT,EC,SRT,IC,
      1    PX1CM,PY1CM,PZ1CM)
         IF(IC.EQ.-1) GO TO 400
          CALL Crhb(PX1CM,PY1CM,PZ1CM,SRT,I1,I2,IBLOCK)
         em1=e(i1)
         em2=e(i2)
         go to 440
 c
 c* K+ + La(Si) --> Meson + B
 c* K- + La(Si)-bar --> Meson + B-bar
 5699        CONTINUE
         PX1CM=PCX
         PY1CM=PCY
         PZ1CM=PCZ
         EC=(em1+em2+0.02)**2
         CALL XKHYPE(I1, I2, SRT, XKY1, XKY2, XKY3, XKY4, XKY5,
      &     XKY6, XKY7, XKY8, XKY9, XKY10, XKY11, XKY12, XKY13,
      &     XKY14, XKY15, XKY16, XKY17, SIGK)
        DSkk=SQRT(sigk/PI)
        dskk0=dskk+0.1
         CALL DISTCE(I1,I2,dskk0,DSkk,DT,EC,SRT,IC,
      1  PX1CM,PY1CM,PZ1CM)
         IF(IC.EQ.-1) GO TO 400
 c
        if(lb(i1).eq.23 .or. lb(i2).eq.23)then
              IKMP = 1
         else
              IKMP = -1
         endif
         CALL Crkhyp(PX1CM,PY1CM,PZ1CM,SRT,I1,I2,
      &     XKY1, XKY2, XKY3, XKY4, XKY5,
      &     XKY6, XKY7, XKY8, XKY9, XKY10, XKY11, XKY12, XKY13,
      &     XKY14, XKY15, XKY16, XKY17, SIGK, IKMP,
      1  IBLOCK)
        em1=e(i1)
        em2=e(i2)
        go to 440
 c khyperon end
 *
 csp11/03/01 La/Si-bar + N --> pi + K+
 c  La/Si + N-bar --> pi + K-
 5999     CONTINUE
         PX1CM=PCX
         PY1CM=PCY
         PZ1CM=PCZ
         EC=(em1+em2+0.02)**2
         sigkp = 15.
 c      if((lb1.ge.14.and.lb1.le.17)
 c     &    .or.(lb2.ge.14.and.lb2.le.17))sigkp=10.
         DSkk=SQRT(SIGKP/PI/10.)
         dskk0=dskk+0.1
         CALL DISTCE(I1,I2,dskk0,DSkk,DT,EC,SRT,IC,
      1  PX1CM,PY1CM,PZ1CM)
         IF(IC.EQ.-1) GO TO 400
 c
         CALL CRLAN(PX1CM,PY1CM,PZ1CM,SRT,I1,I2,IBLOCK)
         em1=e(i1)
         em2=e(i2)
         go to 440
 c
 c*
 * K(K*) + K(K*) --> phi + pi(rho,omega)
 8699     CONTINUE
         PX1CM=PCX
         PY1CM=PCY
         PZ1CM=PCZ
         EC=(em1+em2+0.02)**2
 *  CALL CROSSKKPHI(PX1CM,PY1CM,PZ1CM,SRT,I1,I2,IBLOCK)  used for KK*->phi+rho
 
          CALL Crkphi(PX1CM,PY1CM,PZ1CM,EC,SRT,IBLOCK,
      &                  emm1,emm2,lbp1,lbp2,I1,I2,ikk,icase,rrkk,prkk)
          if(icase .eq. 0) then
             iblock=0
             go to 400
          endif
 
 c*---
          if(lbp1.eq.29.or.lbp2.eq.29) then
         PZRT = p(3,i1)+p(3,i2)
         ER1 = sqrt( p(1,i1)**2+p(2,i1)**2+p(3,i1)**2+E(i1)**2 )
         ER2 = sqrt( p(1,i2)**2+p(2,i2)**2+p(3,i2)**2+E(i2)**2 )
         ERT = ER1+ER2
         yy = 0.5*log( (ERT+PZRT)/(ERT-PZRT) )
 c*------
              iblock = 222
              ntag = 0
           endif
 
              LB(I1) = lbp1
              LB(I2) = lbp2
              E(I1) = emm1
              E(I2) = emm2
              em1=e(i1)
              em2=e(i2)
              go to 440
 c*
 * rho(omega) + K(K*)  --> phi + K(K*)
 8799     CONTINUE
         PX1CM=PCX
         PY1CM=PCY
         PZ1CM=PCZ
         EC=(em1+em2+0.02)**2
 *  CALL CROSSKKPHI(PX1CM,PY1CM,PZ1CM,SRT,I1,I2,IBLOCK)  used for KK*->phi+rho
          CALL Crksph(PX1CM,PY1CM,PZ1CM,EC,SRT,
      &       emm1,emm2,lbp1,lbp2,I1,I2,ikkg,ikkl,iblock,icase,srhoks)
          if(icase .eq. 0) then
             iblock=0
             go to 400
          endif
 c
          if(lbp1.eq.29.or.lbp2.eq.20) then
 c*---
         PZRT = p(3,i1)+p(3,i2)
         ER1 = sqrt( p(1,i1)**2+p(2,i1)**2+p(3,i1)**2+E(i1)**2 )
         ER2 = sqrt( p(1,i2)**2+p(2,i2)**2+p(3,i2)**2+E(i2)**2 )
         ERT = ER1+ER2
         yy = 0.5*log( (ERT+PZRT)/(ERT-PZRT) )
           endif
 
              LB(I1) = lbp1
              LB(I2) = lbp2
              E(I1) = emm1
              E(I2) = emm2
              em1=e(i1)
              em2=e(i2)
              go to 440
 
 * for kaon+baryon scattering, using a constant xsection of 10 mb.
 888       CONTINUE
         PX1CM=PCX
         PY1CM=PCY
         PZ1CM=PCZ
         EC=(em1+em2+0.02)**2
          sig = 10.
          if(iabs(lb1).eq.14.or.iabs(lb2).eq.14 .or.
      &      iabs(lb1).eq.30.or.iabs(lb2).eq.30)sig=20.
          if(lb1.eq.29.or.lb2.eq.29)sig=5.0
 
        DSkn=SQRT(sig/PI/10.)
        dsknr=dskn+0.1
         CALL DISTCE(I1,I2,dsknr,DSkn,DT,EC,SRT,IC,
      1  PX1CM,PY1CM,PZ1CM)
         IF(IC.EQ.-1) GO TO 400
         CALL Crkn(PX1CM,PY1CM,PZ1CM,SRT,I1,I2,
      1  IBLOCK)
        em1=e(i1)
        em2=e(i2)
        go to 440
 ***
 
  440    CONTINUE
 *                IBLOCK = 0 ; NOTHING HAS HAPPENED
 *                IBLOCK = 1 ; ELASTIC N-N COLLISION
 *                IBLOCK = 2 ; N + N -> N + DELTA
 *                IBLOCK = 3 ; N + DELTA -> N + N
 *                IBLOCK = 4 ; N + N -> d + d + PION,DIRECT PROCESS
 *               IBLOCK = 5 ; D(N*)+D(N*) COLLISIONS
 *                IBLOCK = 6 ; PION+PION COLLISIONS
 *                iblock = 7 ; pion+nucleon-->l/s+kaon
 *               iblock =77;  pion+nucleon-->delta+pion
 *               iblock = 8 ; kaon+baryon rescattering
 *                IBLOCK = 9 ; NN-->KAON+X
 *                IBLOCK = 10; DD-->KAON+X
 *               IBLOCK = 11; ND-->KAON+X
 cbali2/1/99
 *                
 *           iblock   - 1902 annihilation-->pion(+)+pion(-)   (2 pion)
 *           iblock   - 1903 annihilation-->pion(+)+rho(-)    (3 pion)
 *           iblock   - 1904 annihilation-->rho(+)+rho(-)     (4 pion)
 *           iblock   - 1905 annihilation-->rho(0)+omega      (5 pion)
 *           iblock   - 1906 annihilation-->omega+omega       (6 pion)
 cbali3/5/99
 *           iblock   - 1907 K+K- to pi+pi-
 cbali3/5/99 end
 cbz3/9/99 khyperon
 *           iblock   - 1908 K+Y -> piN
 cbz3/9/99 khyperon end
 cbali2/1/99end
 
 clin-9/28/00 Processes: m(pi rho omega)+m(pi rho omega)
 c     to anti-(p n D N*1 N*2)+(p n D N*1 N*2):
 *           iblock   - 1801  mm -->pbar p 
 *           iblock   - 18021 mm -->pbar n 
 *           iblock   - 18022 mm -->nbar p 
 *           iblock   - 1803  mm -->nbar n 
 *           iblock   - 18041 mm -->pbar Delta 
 *           iblock   - 18042 mm -->anti-Delta p
 *           iblock   - 18051 mm -->nbar Delta 
 *           iblock   - 18052 mm -->anti-Delta n
 *           iblock   - 18061 mm -->pbar N*(1400) 
 *           iblock   - 18062 mm -->anti-N*(1400) p
 *           iblock   - 18071 mm -->nbar N*(1400)
 *           iblock   - 18072 mm -->anti-N*(1400) n
 *           iblock   - 1808  mm -->anti-Delta Delta 
 *           iblock   - 18091 mm -->pbar N*(1535)
 *           iblock   - 18092 mm -->anti-N*(1535) p
 *           iblock   - 18101 mm -->nbar N*(1535)
 *           iblock   - 18102 mm -->anti-N*(1535) n
 *           iblock   - 18111 mm -->anti-Delta N*(1440)
 *           iblock   - 18112 mm -->anti-N*(1440) Delta
 *           iblock   - 18121 mm -->anti-Delta N*(1535)
 *           iblock   - 18122 mm -->anti-N*(1535) Delta
 *           iblock   - 1813  mm -->anti-N*(1440) N*(1440)
 *           iblock   - 18141 mm -->anti-N*(1440) N*(1535)
 *           iblock   - 18142 mm -->anti-N*(1535) N*(1440)
 *           iblock   - 1815  mm -->anti-N*(1535) N*(1535)
 clin-9/28/00-end
 
 clin-10/08/00 Processes: pi pi <-> rho rho
 *           iblock   - 1850  pi pi -> rho rho
 *           iblock   - 1851  rho rho -> pi pi
 clin-10/08/00-end
 
 clin-08/14/02 Processes: pi pi <-> eta eta
 *           iblock   - 1860  pi pi -> eta eta
 *           iblock   - 1861  eta eta -> pi pi
 * Processes: pi pi <-> pi eta
 *           iblock   - 1870  pi pi -> pi eta
 *           iblock   - 1871  pi eta -> pi pi
 * Processes: rho pi <-> rho eta
 *           iblock   - 1880  pi pi -> pi eta
 *           iblock   - 1881  pi eta -> pi pi
 * Processes: omega pi <-> omega eta
 *           iblock   - 1890  pi pi -> pi eta
 *           iblock   - 1891  pi eta -> pi pi
 * Processes: rho rho <-> eta eta
 *           iblock   - 1895  rho rho -> eta eta
 *           iblock   - 1896  eta eta -> rho rho
 clin-08/14/02-end
 
 clin-11/07/00 Processes: 
 *           iblock   - 366  pi rho -> K* Kbar or K*bar K
 *           iblock   - 466  pi rho <- K* Kbar or K*bar K
 
 clin-9/2008 Deuteron:
 *           iblock   - 501  B+B -> Deuteron+Meson
 *           iblock   - 502  Deuteron+Meson -> B+B
 *           iblock   - 503  Deuteron+Baryon elastic
 *           iblock   - 504  Deuteron+Meson elastic
 c
                  IF(IBLOCK.EQ.0)        GOTO 400
 *COM: FOR DIRECT PROCESS WE HAVE TREATED THE PAULI BLOCKING AND FIND
 *     THE MOMENTUM OF PARTICLES IN THE ''LAB'' FRAME. SO GO TO 400
 * A COLLISION HAS TAKEN PLACE !!
               LCOLL = LCOLL +1
 * WAS COLLISION PAULI-FORBIDEN? IF YES, NTAG = -1
               NTAG = 0
 *
 *             LORENTZ-TRANSFORMATION INTO CMS FRAME
               E1CM    = SQRT (EM1**2 + PX1CM**2 + PY1CM**2 + PZ1CM**2)
               P1BETA  = PX1CM*BETAX + PY1CM*BETAY + PZ1CM*BETAZ
               TRANSF  = GAMMA * ( GAMMA * P1BETA / (GAMMA + 1) + E1CM )
               Pt1I1 = BETAX * TRANSF + PX1CM
               Pt2I1 = BETAY * TRANSF + PY1CM
               Pt3I1 = BETAZ * TRANSF + PZ1CM
 * negelect the pauli blocking at high energies
               go to 90002
 
 clin-10/25/02-comment out following, since there is no path to it:
 c*CHECK IF PARTICLE #1 IS PAULI BLOCKED
 c              CALL PAULat(I1,occup)
 c              if (RANART(NSEED) .lt. occup) then
 c                ntag = -1
 c              else
 c                ntag = 0
 c              end if
 clin-10/25/02-end
 
 90002              continue
 *IF PARTICLE #1 IS NOT PAULI BLOCKED
 c              IF (NTAG .NE. -1) THEN
                 E2CM    = SQRT (EM2**2 + PX1CM**2 + PY1CM**2 + PZ1CM**2)
                 TRANSF  = GAMMA * (-GAMMA*P1BETA / (GAMMA + 1.) + E2CM)
                 Pt1I2 = BETAX * TRANSF - PX1CM
                 Pt2I2 = BETAY * TRANSF - PY1CM
                 Pt3I2 = BETAZ * TRANSF - PZ1CM
               go to 90003
 
 clin-10/25/02-comment out following, since there is no path to it:
 c*CHECK IF PARTICLE #2 IS PAULI BLOCKED
 c                CALL PAULat(I2,occup)
 c                if (RANART(NSEED) .lt. occup) then
 c                  ntag = -1
 c                else
 c                  ntag = 0
 c                end if
 cc              END IF
 c* IF COLLISION IS BLOCKED,RESTORE THE MOMENTUM,MASSES
 c* AND LABELS OF I1 AND I2
 cc             IF (NTAG .EQ. -1) THEN
 c                LBLOC  = LBLOC + 1
 c                P(1,I1) = PX1
 c                P(2,I1) = PY1
 c                P(3,I1) = PZ1
 c                P(1,I2) = PX2
 c                P(2,I2) = PY2
 c                P(3,I2) = PZ2
 c                E(I1)   = EM1
 c                E(I2)   = EM2
 c                LB(I1)  = LB1
 c                LB(I2)  = LB2
 cc              ELSE
 clin-10/25/02-end
 
 90003           IF(IBLOCK.EQ.1) LCNNE=LCNNE+1
               IF(IBLOCK.EQ.5) LDD=LDD+1
                 if(iblock.eq.2) LCNND=LCNND+1
               IF(IBLOCK.EQ.8) LKN=LKN+1
                    if(iblock.eq.43) Ldou=Ldou+1
 c                IF(IBLOCK.EQ.2) THEN
 * CALCULATE THE AVERAGE SRT FOR N + N---> N + DELTA PROCESS
 C                NODELT=NODELT+1
 C                SUMSRT=SUMSRT+SRT
 c                ENDIF
                 IF(IBLOCK.EQ.3) LCNDN=LCNDN+1
 * assign final momenta to particles while keep the leadng particle
 * behaviour
 C              if((pt1i1*px1+pt2i1*py1+pt3i1*pz1).gt.0)then
               p(1,i1)=pt1i1
               p(2,i1)=pt2i1
               p(3,i1)=pt3i1
               p(1,i2)=pt1i2
               p(2,i2)=pt2i2
               p(3,i2)=pt3i2
 C              else
 C              p(1,i1)=pt1i2
 C              p(2,i1)=pt2i2
 C              p(3,i1)=pt3i2
 C              p(1,i2)=pt1i1
 C              p(2,i2)=pt2i1
 C              p(3,i2)=pt3i1
 C              endif
                 PX1     = P(1,I1)
                 PY1     = P(2,I1)
                 PZ1     = P(3,I1)
                 EM1     = E(I1)
                 EM2     = E(I2)
                 LB1     = LB(I1)
                 LB2     = LB(I2)
                 ID(I1)  = 2
                 ID(I2)  = 2
                 E1      = SQRT( EM1**2 + PX1**2 + PY1**2 + PZ1**2 )
                 ID1     = ID(I1)
               go to 90004
 clin-10/25/02-comment out following, since there is no path to it:
 c* change phase space density FOR NUCLEONS INVOLVED :
 c* NOTE THAT f is the phase space distribution function for nucleons only
 c                if ((abs(ix1).le.mx) .and. (abs(iy1).le.my) .and.
 c     &              (abs(iz1).le.mz)) then
 c                  ipx1p = nint(p(1,i1)/dpx)
 c                  ipy1p = nint(p(2,i1)/dpy)
 c                  ipz1p = nint(p(3,i1)/dpz)
 c                  if ((ipx1p.ne.ipx1) .or. (ipy1p.ne.ipy1) .or.
 c     &                (ipz1p.ne.ipz1)) then
 c                    if ((abs(ipx1).le.mpx) .and. (abs(ipy1).le.my)
 c     &                .and. (ipz1.ge.-mpz) .and. (ipz1.le.mpzp)
 c     &                .AND. (AM1.LT.1.))
 c     &                f(ix1,iy1,iz1,ipx1,ipy1,ipz1) =
 c     &                f(ix1,iy1,iz1,ipx1,ipy1,ipz1) - 1.
 c                    if ((abs(ipx1p).le.mpx) .and. (abs(ipy1p).le.my)
 c     &                .and. (ipz1p.ge.-mpz).and. (ipz1p.le.mpzp)
 c     &                .AND. (EM1.LT.1.))
 c     &                f(ix1,iy1,iz1,ipx1p,ipy1p,ipz1p) =
 c     &                f(ix1,iy1,iz1,ipx1p,ipy1p,ipz1p) + 1.
 c                  end if
 c                end if
 c                if ((abs(ix2).le.mx) .and. (abs(iy2).le.my) .and.
 c     &              (abs(iz2).le.mz)) then
 c                  ipx2p = nint(p(1,i2)/dpx)
 c                  ipy2p = nint(p(2,i2)/dpy)
 c                  ipz2p = nint(p(3,i2)/dpz)
 c                  if ((ipx2p.ne.ipx2) .or. (ipy2p.ne.ipy2) .or.
 c     &                (ipz2p.ne.ipz2)) then
 c                    if ((abs(ipx2).le.mpx) .and. (abs(ipy2).le.my)
 c     &                .and. (ipz2.ge.-mpz) .and. (ipz2.le.mpzp)
 c     &                .AND. (AM2.LT.1.))
 c     &                f(ix2,iy2,iz2,ipx2,ipy2,ipz2) =
 c     &                f(ix2,iy2,iz2,ipx2,ipy2,ipz2) - 1.
 c                    if ((abs(ipx2p).le.mpx) .and. (abs(ipy2p).le.my)
 c     &                .and. (ipz2p.ge.-mpz) .and. (ipz2p.le.mpzp)
 c     &                .AND. (EM2.LT.1.))
 c     &                f(ix2,iy2,iz2,ipx2p,ipy2p,ipz2p) =
 c     &                f(ix2,iy2,iz2,ipx2p,ipy2p,ipz2p) + 1.
 c                  end if
 c                end if
 clin-10/25/02-end
 
 90004              continue
             AM1=EM1
             AM2=EM2
 c            END IF
 
 
   400       CONTINUE
 c
 clin-6/10/03 skips the info output on resonance creations:
 c            goto 550
 cclin-4/30/03 study phi,K*,Lambda(1520) resonances at creation:
 cc     note that no decays give these particles, so don't need to consider nnn:
 c            if(iblock.ne.0.and.(lb(i1).eq.29.or.iabs(lb(i1)).eq.30
 c     1           .or.lb(i2).eq.29.or.iabs(lb(i2)).eq.30
 c     2           .or.lb1i.eq.29.or.iabs(lb1i).eq.30
 c     3           .or.lb2i.eq.29.or.iabs(lb2i).eq.30)) then
 c               lb1now=lb(i1)
 c               lb2now=lb(i2)
 cc
 c               nphi0=0
 c               nksp0=0
 c               nksm0=0
 cc               nlar0=0
 cc               nlarbar0=0
 c               if(lb1i.eq.29) then
 c                  nphi0=nphi0+1
 c               elseif(lb1i.eq.30) then
 c                  nksp0=nksp0+1
 c               elseif(lb1i.eq.-30) then
 c                  nksm0=nksm0+1
 c               endif
 c               if(lb2i.eq.29) then
 c                  nphi0=nphi0+1
 c               elseif(lb2i.eq.30) then
 c                  nksp0=nksp0+1
 c               elseif(lb2i.eq.-30) then
 c                  nksm0=nksm0+1
 c               endif
 cc
 c               nphi=0
 c               nksp=0
 c               nksm=0
 c               nlar=0
 c               nlarbar=0
 c               if(lb1now.eq.29) then
 c                  nphi=nphi+1
 c               elseif(lb1now.eq.30) then
 c                  nksp=nksp+1
 c               elseif(lb1now.eq.-30) then
 c                  nksm=nksm+1
 c               endif
 c               if(lb2now.eq.29) then
 c                  nphi=nphi+1
 c               elseif(lb2now.eq.30) then
 c                  nksp=nksp+1
 c               elseif(lb2now.eq.-30) then
 c                  nksm=nksm+1
 c               endif
 cc     
 c               if(nphi.eq.2.or.nksp.eq.2.or.nksm.eq.2) then
 c                  write(91,*) '2 same resonances in one reaction!'
 c                  write(91,*) nphi,nksp,nksm,iblock
 c               endif
 c
 cc     All reactions create or destroy no more than 1 these resonance,
 cc     otherwise file "fort.91" warns us:
 c               do 222 ires=1,3
 c                  if(ires.eq.1.and.nphi.ne.nphi0) then
 c                     idr=29
 c                  elseif(ires.eq.2.and.nksp.ne.nksp0) then
 c                     idr=30
 c                  elseif(ires.eq.3.and.nksm.ne.nksm0) then
 c                     idr=-30
 c                  else
 c                     goto 222
 c                  endif
 cctest off for resonance (phi, K*) studies:
 cc               if(lb1now.eq.idr) then
 cc       write(17,112) 'collision',lb1now,P(1,I1),P(2,I1),P(3,I1),e(I1),nt
 cc               elseif(lb2now.eq.idr) then
 cc       write(17,112) 'collision',lb2now,P(1,I2),P(2,I2),P(3,I2),e(I2),nt
 cc               elseif(lb1i.eq.idr) then
 cc       write(18,112) 'collision',lb1i,px1i,py1i,pz1i,em1i,nt
 cc               elseif(lb2i.eq.idr) then
 cc       write(18,112) 'collision',lb2i,px2i,py2i,pz2i,em2i,nt
 cc               endif
 c 222           continue
 c
 c            else
 c            endif
 cc 112        format(a10,I4,4(1x,f9.3),1x,I4)
 c
 clin-2/26/03 skips the check of energy conservation after each binary search:
 c 550        goto 555
 c            pxfin=0
 c            pyfin=0
 c            pzfin=0
 c            efin=0
 c            if(e(i1).ne.0.or.lb(i1).eq.10022) then
 c               efin=efin+SQRT(E(I1)**2+P(1,I1)**2+P(2,I1)**2+P(3,I1)**2)
 c               pxfin=pxfin+P(1,I1)
 c               pyfin=pyfin+P(2,I1)
 c               pzfin=pzfin+P(3,I1)
 c            endif
 c            if(e(i2).ne.0.or.lb(i2).eq.10022) then
 c               efin=efin+SQRT(E(I2)**2+P(1,I2)**2+P(2,I2)**2+P(3,I2)**2)
 c               pxfin=pxfin+P(1,I2)
 c               pyfin=pyfin+P(2,I2)
 c               pzfin=pzfin+P(3,I2)
 c            endif
 c            if((nnn-nnnini).ge.1) then
 c               do imore=nnnini+1,nnn
 c                  if(EPION(imore,IRUN).ne.0) then
 c                     efin=efin+SQRT(EPION(imore,IRUN)**2
 c     1                    +PPION(1,imore,IRUN)**2+PPION(2,imore,IRUN)**2
 c     2                    +PPION(3,imore,IRUN)**2)
 c                     pxfin=pxfin+PPION(1,imore,IRUN)
 c                     pyfin=pyfin+PPION(2,imore,IRUN)
 c                     pzfin=pzfin+PPION(3,imore,IRUN)
 c                  endif
 c               enddo
 c            endif
 c            devio=sqrt((pxfin-pxini)**2+(pyfin-pyini)**2
 c     1           +(pzfin-pzini)**2+(efin-eini)**2)
 cc
 c            if(devio.ge.0.1) then
 c               write(92,'a20,5(1x,i6),2(1x,f8.3)') 'iblock,lb,npi=',
 c     1              iblock,lb1i,lb2i,lb(i1),lb(i2),e(i1),e(i2)
 c               do imore=nnnini+1,nnn
 c                  if(EPION(imore,IRUN).ne.0) then
 c                     write(92,'a10,2(1x,i6)') 'ipi,lbm=',
 c     1                    imore,LPION(imore,IRUN)
 c                  endif
 c               enddo
 c               write(92,'a3,4(1x,f8.3)') 'I:',eini,pxini,pyini,pzini
 c               write(92,'a3,5(1x,f8.3)') 
 c     1              'F:',efin,pxfin,pyfin,pzfin,devio
 c            endif
 c
  555        continue
 ctest off only one collision for the same 2 particles in the same timestep:
 c            if(iblock.ne.0) then
 c               goto 800
 c            endif
 ctest off collisions history:
 c            if(iblock.ne.0) then 
 c               write(10,*) nt,i1,i2,iblock,x1,z1,x2,z2
 c            endif
 
   600     CONTINUE
 
 clin-4/2012 option of pi0 decays:
 c     particles in lpion() may be a pi0, and when ipi0dcy=1 
 c     we need to decay them at nt=ntmax after all lb(i1) decays are done:
  798      if(nt.eq.ntmax.and.ipi0dcy.eq.1
      1         .and.i1.eq.(MASSR(IRUN)+MSUM)) then
              do ipion=1,NNN
                 if(LPION(ipion,IRUN).eq.4) then
                    wid=7.85e-9
                    call resdec(i1,nt,nnn,wid,idecay,ipion)
                 endif
              enddo
           endif
 ctest off
 c          if(nt.eq.ntmax.and.i1.eq.(MASSR(IRUN)+MSUM)) then
 c             do ip=1,i1
 c                write(98,*) lb(ip),e(ip),ip
 c             enddo
 c          endif
 
 clin-4/2012 option of pi0 decays-end
 
   800   CONTINUE
 * RELABLE MESONS LEFT IN THIS RUN EXCLUDING THOSE BEING CREATED DURING
 * THIS TIME STEP AND COUNT THE TOTAL NO. OF PARTICLES IN THIS RUN
 * note that the first mass=mta+mpr particles are baryons
 c        write(*,*)'I: NNN,massr ', nnn,massr(irun)
         N0=MASS+MSUM
         DO 1005 N=N0+1,MASSR(IRUN)+MSUM
 cbz11/25/98
 clin-2/19/03 lb>5000: keep particles with no LB codes in ART(photon,lepton,..):
 c        IF(E(N).GT.0.)THEN
         IF(E(N) .GT. 0. .OR. LB(N) .GT. 5000)THEN
 cbz11/25/98end
         NNN=NNN+1
         RPION(1,NNN,IRUN)=R(1,N)
         RPION(2,NNN,IRUN)=R(2,N)
         RPION(3,NNN,IRUN)=R(3,N)
 clin-10/28/03:
         if(nt.eq.ntmax) then
            ftpisv(NNN,IRUN)=ftsv(N)
            tfdpi(NNN,IRUN)=tfdcy(N)
         endif
 c
         PPION(1,NNN,IRUN)=P(1,N)
         PPION(2,NNN,IRUN)=P(2,N)
         PPION(3,NNN,IRUN)=P(3,N)
         EPION(NNN,IRUN)=E(N)
         LPION(NNN,IRUN)=LB(N)
 c       !! sp 12/19/00
         PROPI(NNN,IRUN)=PROPER(N)
 clin-5/2008:
         dppion(NNN,IRUN)=dpertp(N)
 c        if(lb(n) .eq. 45)
 c    &   write(*,*)'IN-1  NT,NNN,LB,P ',nt,NNN,lb(n),proper(n)
         ENDIF
  1005 CONTINUE
         MASSRN(IRUN)=NNN+MASS
 c        write(*,*)'F: NNN,massrn ', nnn,massrn(irun)
 1000   CONTINUE
 * CALCULATE THE AVERAGE SRT FOR N + N--->N +DELTA PROCESSES
 C        IF(NODELT.NE.0)THEN
 C        AVSRT=SUMSRT/FLOAT(NODELT)
 C        ELSE
 C        AVSRT=0.
 C        ENDIF
 C        WRITE(1097,'(F8.2,2X,E10.3)')FLOAT(NT)*DT,AVSRT
 * RELABLE ALL THE PARTICLES EXISTING AFTER THIS TIME STEP
         IA=0
         IB=0
         DO 10001 IRUN=1,NUM
         IA=IA+MASSR(IRUN-1)
         IB=IB+MASSRN(IRUN-1)
         DO 10001 IC=1,MASSRN(IRUN)
         IE=IA+IC
         IG=IB+IC
         IF(IC.LE.MASS)THEN
         RT(1,IG)=R(1,IE)
         RT(2,IG)=R(2,IE)
         RT(3,IG)=R(3,IE)
 clin-10/28/03:
         if(nt.eq.ntmax) then
            fttemp(IG)=ftsv(IE)
            tft(IG)=tfdcy(IE)
         endif
 c
         PT(1,IG)=P(1,IE)
         PT(2,IG)=P(2,IE)
         PT(3,IG)=P(3,IE)
         ET(IG)=E(IE)
         LT(IG)=LB(IE)
         PROT(IG)=PROPER(IE)
 clin-5/2008:
         dptemp(IG)=dpertp(IE)
         ELSE
         I0=IC-MASS
         RT(1,IG)=RPION(1,I0,IRUN)
         RT(2,IG)=RPION(2,I0,IRUN)
         RT(3,IG)=RPION(3,I0,IRUN)
 clin-10/28/03:
         if(nt.eq.ntmax) then
            fttemp(IG)=ftpisv(I0,IRUN)
            tft(IG)=tfdpi(I0,IRUN)
         endif
 c
         PT(1,IG)=PPION(1,I0,IRUN)
         PT(2,IG)=PPION(2,I0,IRUN)
         PT(3,IG)=PPION(3,I0,IRUN)
         ET(IG)=EPION(I0,IRUN)
         LT(IG)=LPION(I0,IRUN)
         PROT(IG)=PROPI(I0,IRUN)
 clin-5/2008:
         dptemp(IG)=dppion(I0,IRUN)
         ENDIF
 10001   CONTINUE
 c
         IL=0
 clin-10/26/01-hbt:
 c        DO 10002 IRUN=1,NUM
         DO 10003 IRUN=1,NUM
 
         MASSR(IRUN)=MASSRN(IRUN)
         IL=IL+MASSR(IRUN-1)
         DO 10002 IM=1,MASSR(IRUN)
         IN=IL+IM
         R(1,IN)=RT(1,IN)
         R(2,IN)=RT(2,IN)
         R(3,IN)=RT(3,IN)
 clin-10/28/03:
         if(nt.eq.ntmax) then
            ftsv(IN)=fttemp(IN)
            tfdcy(IN)=tft(IN)
         endif
         P(1,IN)=PT(1,IN)
         P(2,IN)=PT(2,IN)
         P(3,IN)=PT(3,IN)
         E(IN)=ET(IN)
         LB(IN)=LT(IN)
         PROPER(IN)=PROT(IN)
 clin-5/2008:
         dpertp(IN)=dptemp(IN)
        IF(LB(IN).LT.1.OR.LB(IN).GT.2)ID(IN)=0
 10002   CONTINUE
 clin-ctest off check energy conservation after each timestep
 c         enetot=0.
 c         do ip=1,MASSR(IRUN)
 c            if(e(ip).ne.0.or.lb(ip).eq.10022) enetot=enetot
 c     1           +sqrt(p(1,ip)**2+p(2,ip)**2+p(3,ip)**2+e(ip)**2)
 c         enddo
 c         write(91,*) 'B:',nt,enetot,massr(irun),bimp 
 clin-3/2009 move to the end of a timestep to take care of freezeout spacetime:
 c        call hbtout(MASSR(IRUN),nt,ntmax)
 10003 CONTINUE
 c
       RETURN
       END
 
 clin-9/2012: use double precision for S in CMS(): to avoid crash 
 c     (segmentation fault due to s<0, which happened at high energies 
 c     such as LHC with large NTMAX for two almost-comoving hadrons
 c     that have small Pt but large |Pz|):
 ****************************************
 c            SUBROUTINE CMS(I1,I2,PX1CM,PY1CM,PZ1CM,SRT)
 * PURPOSE : FIND THE MOMENTA OF PARTICLES IN THE CMS OF THE
 *          TWO COLLIDING PARTICLES
 * VARIABLES :
 *****************************************
 c            PARAMETER (MAXSTR=150001)
 c            COMMON   /AA/  R(3,MAXSTR)
 ccc      SAVE /AA/
 c            COMMON   /BB/  P(3,MAXSTR)
 ccc      SAVE /BB/
 c            COMMON   /CC/  E(MAXSTR)
 ccc      SAVE /CC/
 c            COMMON   /BG/  BETAX,BETAY,BETAZ,GAMMA
 ccc      SAVE /BG/
 c            SAVE   
 c            PX1=P(1,I1)
 c            PY1=P(2,I1)
 c            PZ1=P(3,I1)
 c            PX2=P(1,I2)
 c            PY2=P(2,I2)
 c            PZ2=P(3,I2)
 c            EM1=E(I1)
 c            EM2=E(I2)
 c            E1=SQRT(EM1**2+PX1**2+PY1**2+PZ1**2)
 c            E2=SQRT(EM2**2 + PX2**2 + PY2**2 + PZ2**2 )
 c            S=(E1+E2)**2-(PX1+PX2)**2-(PY1+PY2)**2-(PZ1+PZ2)**2
 c            SRT=SQRT(S)
 c*LORENTZ-TRANSFORMATION IN I1-I2-C.M. SYSTEM
 c              ETOTAL = E1 + E2
 c              BETAX  = (PX1+PX2) / ETOTAL
 c              BETAY  = (PY1+PY2) / ETOTAL
 c              BETAZ  = (PZ1+PZ2) / ETOTAL
 c              GAMMA  = 1.0 / SQRT(1.0-BETAX**2-BETAY**2-BETAZ**2)
 c*TRANSFORMATION OF MOMENTA (PX1CM = - PX2CM)
 c              P1BETA = PX1*BETAX + PY1*BETAY + PZ1 * BETAZ
 c              TRANSF = GAMMA * ( GAMMA * P1BETA / (GAMMA + 1) - E1 )
 c              PX1CM  = BETAX * TRANSF + PX1
 c              PY1CM  = BETAY * TRANSF + PY1
 c              PZ1CM  = BETAZ * TRANSF + PZ1
 c              RETURN
 c              END
 ****************************************
             SUBROUTINE CMS(I1,I2,PX1CM,PY1CM,PZ1CM,SRT)
 * PURPOSE : FIND THE MOMENTA OF PARTICLES IN THE CMS OF THE
 *          TWO COLLIDING PARTICLES
 * VARIABLES :
 *****************************************
             PARAMETER (MAXSTR=150001)
             double precision px1,py1,pz1,px2,py2,pz2,em1,em2,e1,e2,
      1      s,ETOTAL,P1BETA,TRANSF,dBETAX,dBETAY,dBETAZ,dGAMMA,scheck
             COMMON   /BB/  P(3,MAXSTR)
             COMMON   /CC/  E(MAXSTR)
             COMMON   /BG/  BETAX,BETAY,BETAZ,GAMMA
             SAVE   
             PX1=dble(P(1,I1))
             PY1=dble(P(2,I1))
             PZ1=dble(P(3,I1))
             PX2=dble(P(1,I2))
             PY2=dble(P(2,I2))
             PZ2=dble(P(3,I2))
             EM1=dble(E(I1))
             EM2=dble(E(I2))
             E1=dSQRT(EM1**2+PX1**2+PY1**2+PZ1**2)
             E2=dSQRT(EM2**2+PX2**2+PY2**2+PZ2**2)
             S=(E1+E2)**2-(PX1+PX2)**2-(PY1+PY2)**2-(PZ1+PZ2)**2
             IF(S.LE.0) S=0d0
             SRT=sngl(dSQRT(S))
 *LORENTZ-TRANSFORMATION IN I1-I2-C.M. SYSTEM
             ETOTAL = E1 + E2
             dBETAX  = (PX1+PX2) / ETOTAL
             dBETAY  = (PY1+PY2) / ETOTAL
             dBETAZ  = (PZ1+PZ2) / ETOTAL
 clin-9/2012: check argument in sqrt():
             scheck=1.d0-dBETAX**2-dBETAY**2-dBETAZ**2
             if(scheck.le.0d0) then
                write(99,*) 'scheck1: ', scheck
                stop
             endif
             dGAMMA=1.d0/dSQRT(scheck)
 *TRANSFORMATION OF MOMENTA (PX1CM = - PX2CM)
             P1BETA = PX1*dBETAX + PY1*dBETAY + PZ1 * dBETAZ
             TRANSF = dGAMMA * ( dGAMMA * P1BETA / (dGAMMA + 1d0) - E1 )
             PX1CM  = sngl(dBETAX * TRANSF + PX1)
             PY1CM  = sngl(dBETAY * TRANSF + PY1)
             PZ1CM  = sngl(dBETAZ * TRANSF + PZ1)
             BETAX  = sngl(dBETAX)
             BETAY  = sngl(dBETAY)
             BETAZ  = sngl(dBETAZ)
             GAMMA  = sngl(dGAMMA)
             RETURN
             END
 clin-9/2012-end
 
 ***************************************
             SUBROUTINE DISTCE(I1,I2,DELTAR,DS,DT,EC,SRT
      1      ,IC,PX1CM,PY1CM,PZ1CM)
 * PURPOSE : CHECK IF THE COLLISION BETWEEN TWO PARTICLES CAN HAPPEN
 *           BY CHECKING
 *                      (1) IF THE DISTANCE BETWEEN THEM IS SMALLER
 *           THAN THE MAXIMUM DISTANCE DETERMINED FROM THE CROSS SECTION.
 *                      (2) IF PARTICLE WILL PASS EACH OTHER WITHIN
 *           TWO HARD CORE RADIUS.
 *                      (3) IF PARTICLES WILL GET CLOSER.
 * VARIABLES :
 *           IC=1 COLLISION HAPPENED
 *           IC=-1 COLLISION CAN NOT HAPPEN
 *****************************************
             PARAMETER (MAXSTR=150001)
             COMMON   /AA/  R(3,MAXSTR)
 cc      SAVE /AA/
             COMMON   /BB/  P(3,MAXSTR)
 cc      SAVE /BB/
             COMMON   /CC/  E(MAXSTR)
 cc      SAVE /CC/
             COMMON   /BG/  BETAX,BETAY,BETAZ,GAMMA
             COMMON  /EE/      ID(MAXSTR),LB(MAXSTR)
 cc      SAVE /BG/
             common/leadng/lb1,px1,py1,pz1,em1,e1,xfnl,yfnl,zfnl,tfnl,
      1           px1n,py1n,pz1n,dp1n
             common /dpi/em2,lb2
             SAVE   
             IC=0
             X1=R(1,I1)
             Y1=R(2,I1)
             Z1=R(3,I1)
             PX1=P(1,I1)
             PY1=P(2,I1)
             PZ1=P(3,I1)
             X2=R(1,I2)
             Y2=R(2,I2)
             Z2=R(3,I2)
             PX2=P(1,I2)
             PY2=P(2,I2)
             PZ2=P(3,I2)
             EM1=E(I1)
             EM2=E(I2)
             E1=SQRT(EM1**2+PX1**2+PY1**2+PZ1**2)
 c            IF (ABS(X1-X2) .GT. DELTAR) GO TO 400
 c            IF (ABS(Y1-Y2) .GT. DELTAR) GO TO 400
 c            IF (ABS(Z1-Z2) .GT. DELTAR) GO TO 400
             RSQARE = (X1-X2)**2 + (Y1-Y2)**2 + (Z1-Z2)**2
             IF (RSQARE .GT. DELTAR**2) GO TO 400
 *NOW PARTICLES ARE CLOSE ENOUGH TO EACH OTHER !
               E2     = SQRT ( EM2**2 + PX2**2 + PY2**2 + PZ2**2 )
               S      = SRT*SRT
             IF (S .LT. EC) GO TO 400
 *NOW THERE IS ENOUGH ENERGY AVAILABLE !
 *LORENTZ-TRANSFORMATION IN I1-I2-C.M. SYSTEM
 * BETAX, BETAY, BETAZ AND GAMMA HAVE BEEN GIVEN IN THE SUBROUTINE CMS
 *TRANSFORMATION OF MOMENTA (PX1CM = - PX2CM)
               P1BETA = PX1*BETAX + PY1*BETAY + PZ1 * BETAZ
               TRANSF = GAMMA * ( GAMMA * P1BETA / (GAMMA + 1) - E1 )
               PRCM   = SQRT (PX1CM**2 + PY1CM**2 + PZ1CM**2)
               IF (PRCM .LE. 0.00001) GO TO 400
 *TRANSFORMATION OF SPATIAL DISTANCE
               DRBETA = BETAX*(X1-X2) + BETAY*(Y1-Y2) + BETAZ*(Z1-Z2)
               TRANSF = GAMMA * GAMMA * DRBETA / (GAMMA + 1)
               DXCM   = BETAX * TRANSF + X1 - X2
               DYCM   = BETAY * TRANSF + Y1 - Y2
               DZCM   = BETAZ * TRANSF + Z1 - Z2
 *DETERMINING IF THIS IS THE POINT OF CLOSEST APPROACH
               DRCM   = SQRT (DXCM**2  + DYCM**2  + DZCM**2 )
               DZZ    = (PX1CM*DXCM + PY1CM*DYCM + PZ1CM*DZCM) / PRCM
               if ((drcm**2 - dzz**2) .le. 0.) then
                 BBB = 0.
               else
                 BBB    = SQRT (DRCM**2 - DZZ**2)
               end if
 *WILL PARTICLE PASS EACH OTHER WITHIN 2 * HARD CORE RADIUS ?
               IF (BBB .GT. DS) GO TO 400
               RELVEL = PRCM * (1.0/E1 + 1.0/E2)
               DDD    = RELVEL * DT * 0.5
 *WILL PARTICLES GET CLOSER ?
               IF (ABS(DDD) .LT. ABS(DZZ)) GO TO 400
               IC=1
               GO TO 500
 400           IC=-1
 500           CONTINUE
               RETURN
               END
 ****************************************
 *                                                                      *
 *                                                                      *
       SUBROUTINE CRNN(IRUN,PX,PY,PZ,SRT,I1,I2,IBLOCK,
      1NTAG,SIGNN,SIG,NT,ipert1)
 *     PURPOSE:                                                         *
 *             DEALING WITH NUCLEON-NUCLEON COLLISIONS                    *
 *     NOTE   :                                                         *
 *     QUANTITIES:                                                 *
 *           PX,PY,PZ - MOMENTUM COORDINATES OF ONE PARTICLE IN CM FRAME*
 *           SRT      - SQRT OF S                                       *
 *           NSTAR =1 INCLUDING N* RESORANCE,ELSE NOT                   *
 *           NDIRCT=1 INCLUDING DIRECT PION PRODUCTION PROCESS         *
 *           IBLOCK   - THE INFORMATION BACK                            *
 *                      0-> COLLISION CANNOT HAPPEN                     *
 *                      1-> N-N ELASTIC COLLISION                       *
 *                      2-> N+N->N+DELTA,OR N+N->N+N* REACTION          *
 *                      3-> N+DELTA->N+N OR N+N*->N+N REACTION          *
 *                      4-> N+N->D+D+pion reaction
 *                     43->N+N->D(N*)+D(N*) reaction
 *                     44->N+N->D+D+rho reaction
 *                     45->N+N->N+N+rho
 *                     46->N+N->N+N+omega
 *           N12       - IS USED TO SPECIFY BARYON-BARYON REACTION      *
 *                      CHANNELS. M12 IS THE REVERSAL CHANNEL OF N12    *
 *                      N12,                                            *
 *                      M12=1 FOR p+n-->delta(+)+ n                     *
 *                          2     p+n-->delta(0)+ p                     *
 *                          3     p+p-->delta(++)+n                     *
 *                          4     p+p-->delta(+)+p                      *
 *                          5     n+n-->delta(0)+n                      *
 *                          6     n+n-->delta(-)+p                      *
 *                          7     n+p-->N*(0)(1440)+p                   *
 *                          8     n+p-->N*(+)(1440)+n                   *
 *                        9     p+p-->N*(+)(1535)+p                     *
 *                        10    n+n-->N*(0)(1535)+n                     *
 *                         11    n+p-->N*(+)(1535)+n                     *
 *                        12    n+p-->N*(0)(1535)+p
 *                        13    D(++)+D(-)-->N*(+)(1440)+n
 *                         14    D(++)+D(-)-->N*(0)(1440)+p
 *                        15    D(+)+D(0)--->N*(+)(1440)+n
 *                        16    D(+)+D(0)--->N*(0)(1440)+p
 *                        17    D(++)+D(0)-->N*(+)(1535)+p
 *                        18    D(++)+D(-)-->N*(0)(1535)+p
 *                        19    D(++)+D(-)-->N*(+)(1535)+n
 *                        20    D(+)+D(+)-->N*(+)(1535)+p
 *                        21    D(+)+D(0)-->N*(+)(1535)+n
 *                        22    D(+)+D(0)-->N*(0)(1535)+p
 *                        23    D(+)+D(-)-->N*(0)(1535)+n
 *                        24    D(0)+D(0)-->N*(0)(1535)+n
 *                          25    N*(+)(14)+N*(+)(14)-->N*(+)(15)+p
 *                          26    N*(0)(14)+N*(0)(14)-->N*(0)(15)+n
 *                          27    N*(+)(14)+N*(0)(14)-->N*(+)(15)+n
 *                        28    N*(+)(14)+N*(0)(14)-->N*(0)(15)+p
 *                        29    N*(+)(14)+D+-->N*(+)(15)+p
 *                        30    N*(+)(14)+D0-->N*(+)(15)+n
 *                        31    N*(+)(14)+D(-)-->N*(0)(1535)+n
 *                        32    N*(0)(14)+D++--->N*(+)(15)+p
 *                        33    N*(0)(14)+D+--->N*(+)(15)+n
 *                        34    N*(0)(14)+D+--->N*(0)(15)+p
 *                        35    N*(0)(14)+D0-->N*(0)(15)+n
 *                        36    N*(+)(14)+D0--->N*(0)(15)+p
 *                        ++    see the note book for more listing
 *                     
 *
 *     NOTE ABOUT N*(1440) RESORANCE IN Nucleon+NUCLEON COLLISION:      * 
 *     As it has been discussed in VerWest's paper,I= 1(initial isospin)*
 *     channel can all be attributed to delta resorance while I= 0      *
 *     channel can all be  attribured to N* resorance.Only in n+p       *
 *     one can have I=0 channel so is the N*(1440) resonance            *
 *                                                                      *
 *                             REFERENCES:                            *    
 *                    J. CUGNON ET AL., NUCL. PHYS. A352, 505 (1981)    *
 *                    Y. KITAZOE ET AL., PHYS. LETT. 166B, 35 (1986)    *
 *                    B. VerWest el al., PHYS. PRV. C25 (1982)1979      *
 *                    Gy. Wolf  et al, Nucl Phys A517 (1990) 615;       *
 *                                     Nucl phys A552 (1993) 349.       *
 **********************************
         PARAMETER (MAXSTR=150001,MAXR=1,AMN=0.939457,
      1  AMP=0.93828,AP1=0.13496,aka=0.498,AP2=0.13957,AM0=1.232,
      2  PI=3.1415926,CUTOFF=1.8966,AVMASS=0.9383,APHI=1.020)
         parameter     (MX=4,MY=4,MZ=8,MPX=4,MPY=4,mpz=10,mpzp=10)
         parameter (xmd=1.8756,npdmax=10000)
         COMMON /AA/ R(3,MAXSTR)
 cc      SAVE /AA/
         COMMON /BB/ P(3,MAXSTR)
 cc      SAVE /BB/
         COMMON /CC/ E(MAXSTR)
 cc      SAVE /CC/
         COMMON /EE/ ID(MAXSTR),LB(MAXSTR)
 cc      SAVE /EE/
         common /ff/f(-mx:mx,-my:my,-mz:mz,-mpx:mpx,-mpy:mpy,-mpz:mpzp)
 cc      SAVE /ff/
         common /gg/ dx,dy,dz,dpx,dpy,dpz
 cc      SAVE /gg/
         COMMON /INPUT/ NSTAR,NDIRCT,DIR
 cc      SAVE /INPUT/
         COMMON /NN/NNN
 cc      SAVE /NN/
         COMMON /BG/BETAX,BETAY,BETAZ,GAMMA
 cc      SAVE /BG/
         COMMON   /RUN/NUM
 cc      SAVE /RUN/
         COMMON   /PA/RPION(3,MAXSTR,MAXR)
 cc      SAVE /PA/
         COMMON   /PB/PPION(3,MAXSTR,MAXR)
 cc      SAVE /PB/
         COMMON   /PC/EPION(MAXSTR,MAXR)
 cc      SAVE /PC/
         COMMON   /PD/LPION(MAXSTR,MAXR)
 cc      SAVE /PD/
         COMMON/TABLE/ xarray(0:1000),earray(0:1000)
 cc      SAVE /TABLE/
         common/input1/ MASSPR,MASSTA,ISEED,IAVOID,DT
 cc      SAVE /input1/
       common/leadng/lb1,px1,py1,pz1,em1,e1,xfnl,yfnl,zfnl,tfnl,
      1 px1n,py1n,pz1n,dp1n
 cc      SAVE /leadng/
       COMMON/RNDF77/NSEED
 cc      SAVE /RNDF77/
       common /dpi/em2,lb2
       COMMON /dpert/dpertt(MAXSTR,MAXR),dpertp(MAXSTR),dplast(MAXSTR),
      1     dpdcy(MAXSTR),dpdpi(MAXSTR,MAXR),dpt(MAXSTR, MAXR),
      2     dpp1(MAXSTR,MAXR),dppion(MAXSTR,MAXR)
       common /para8/ idpert,npertd,idxsec
       dimension ppd(3,npdmax),lbpd(npdmax)
       SAVE   
 *-----------------------------------------------------------------------
       n12=0
       m12=0
       IBLOCK=0
       NTAG=0
       EM1=E(I1)
       EM2=E(I2)
       PR=SQRT( PX**2 + PY**2 + PZ**2 )
       C2=PZ / PR
       X1=RANART(NSEED)
       ianti=0
       if(lb(i1).lt.0 .and. lb(i2).lt.0) ianti=1
       call sbbdm(srt,sdprod,ianti,lbm,xmm,pfinal)
 clin-5/2008 Production of perturbative deuterons for idpert=1:
       if(idpert.eq.1.and.ipert1.eq.1) then
          IF (SRT .LT. 2.012) RETURN
          if((iabs(lb(i1)).eq.1.or.iabs(lb(i1)).eq.2)
      1        .and.(iabs(lb(i2)).eq.1.or.iabs(lb(i2)).eq.2)) then
             goto 108
          else
             return
          endif
       endif
 c
 *-----------------------------------------------------------------------
 *COM: TEST FOR ELASTIC SCATTERING (EITHER N-N OR DELTA-DELTA 0R
 *      N-DELTA OR N*-N* or N*-Delta)
 c      IF (X1 .LE. SIGNN/SIG) THEN
       IF (X1.LE.(SIGNN/SIG)) THEN
 *COM:  PARAMETRISATION IS TAKEN FROM THE CUGNON-PAPER
          AS  = ( 3.65 * (SRT - 1.8766) )**6
          A   = 6.0 * AS / (1.0 + AS)
          TA  = -2.0 * PR**2
          X   = RANART(NSEED)
 clin-10/24/02        T1  = DLOG( (1-X) * DEXP(dble(A)*dble(TA)) + X )  /  A
          T1  = sngl(DLOG(dble(1.-X)*DEXP(dble(A)*dble(TA))+dble(X)))/  A
          C1  = 1.0 - T1/TA
          T1  = 2.0 * PI * RANART(NSEED)
          IBLOCK=1
          GO TO 107
       ELSE
 *COM: TEST FOR INELASTIC SCATTERING
 *     IF THE AVAILABLE ENERGY IS LESS THAN THE PION-MASS, NOTHING
 *     CAN HAPPEN ANY MORE ==> RETURN (2.012 = 2*AVMASS + PI-MASS)
 clin-5/2008: Mdeuteron+Mpi=2.0106 to 2.0152 GeV/c2, so we can still use this:
          IF (SRT .LT. 2.012) RETURN
 *     calculate the N*(1535) production cross section in N+N collisions
 *     note that the cross sections in this subroutine are in units of mb
 *     as only ratios of the cross sections are used to determine the
 *     reaction channels
        call N1535(iabs(lb(i1)),iabs(lb(i2)),srt,x1535)
 *COM: HERE WE HAVE A PROCESS N+N ==> N+DELTA,OR N+N==>N+N*(144) or N*(1535)
 *     OR 
 * 3 pi channel : N+N==>d1+d2+PION
        SIG3=3.*(X3pi(SRT)+x33pi(srt))
 * 2 pi channel : N+N==>d1+d2+d1*n*+n*n*
        SIG4=4.*X2pi(srt)
 * 4 pi channel : N+N==>d1+d2+rho
        s4pi=x4pi(srt)
 * N+N-->NN+rho channel
        srho=xrho(srt)
 * N+N-->NN+omega
        somega=omega(srt)
 * CROSS SECTION FOR KAON PRODUCTION from the four channels
 * for NLK channel
        akp=0.498
        ak0=0.498
        ana=0.94
        ada=1.232
        al=1.1157
        as=1.1197
        xsk1=0
        xsk2=0
        xsk3=0
        xsk4=0
        xsk5=0
        t1nlk=ana+al+akp
        if(srt.le.t1nlk)go to 222
        XSK1=1.5*PPLPK(SRT)
 * for DLK channel
        t1dlk=ada+al+akp
        t2dlk=ada+al-akp
        if(srt.le.t1dlk)go to 222
        es=srt
        pmdlk2=(es**2-t1dlk**2)*(es**2-t2dlk**2)/(4.*es**2)
        pmdlk=sqrt(pmdlk2)
        XSK3=1.5*PPLPK(srt)
 * for NSK channel
        t1nsk=ana+as+akp
        t2nsk=ana+as-akp
        if(srt.le.t1nsk)go to 222
        pmnsk2=(es**2-t1nsk**2)*(es**2-t2nsk**2)/(4.*es**2)
        pmnsk=sqrt(pmnsk2)
        XSK2=1.5*(PPK1(srt)+PPK0(srt))
 * for DSK channel
        t1DSk=aDa+aS+akp
        t2DSk=aDa+aS-akp
        if(srt.le.t1dsk)go to 222
        pmDSk2=(es**2-t1DSk**2)*(es**2-t2DSk**2)/(4.*es**2)
        pmDSk=sqrt(pmDSk2)
        XSK4=1.5*(PPK1(srt)+PPK0(srt))
 csp11/21/01
 c phi production
        if(srt.le.(2.*amn+aphi))go to 222
 c  !! mb put the correct form
        xsk5 = 0.0001
 csp11/21/01 end
 c
 * THE TOTAL KAON+ PRODUCTION CROSS SECTION IS THEN
  222   SIGK=XSK1+XSK2+XSK3+XSK4
 
 cbz3/7/99 neutralk
         XSK1 = 2.0 * XSK1
         XSK2 = 2.0 * XSK2
         XSK3 = 2.0 * XSK3
         XSK4 = 2.0 * XSK4
         SIGK = 2.0 * SIGK + xsk5
 cbz3/7/99 neutralk end
 c
 ** FOR P+P or L/S+L/S COLLISION:
 c       lb1=lb(i1)
 c       lb2=lb(i2)
         lb1=iabs(lb(i1))
         lb2=iabs(lb(i2))
         IF((LB(I1)*LB(I2).EQ.1).or.
      &       ((lb1.le.17.and.lb1.ge.14).and.(lb2.le.17.and.lb2.ge.14)).
      &       or.((lb1.le.2).and.(lb2.le.17.and.lb2.ge.14)).
      &       or.((lb2.le.2).and.(lb1.le.17.and.lb1.ge.14)))THEN
 clin-8/2008 PP->d+meson here:
            IF(X1.LE.((SIGNN+sdprod)/SIG)) GO TO 108
            SIG1=SIGMA(SRT,1,1,0)+0.5*SIGMA(SRT,1,1,1)
            SIG2=1.5*SIGMA(SRT,1,1,1)
            SIGND=SIG1+SIG2+SIG3+SIG4+X1535+SIGK+s4pi+srho+somega
 clin-5/2008:
 c           IF (X1.GT.(SIGNN+SIGND)/SIG)RETURN
            IF (X1.GT.(SIGNN+SIGND+sdprod)/SIG)RETURN
            DIR=SIG3/SIGND
            IF(RANART(NSEED).LE.DIR)GO TO 106
            IF(RANART(NSEED).LE.SIGK/(SIGK+X1535+SIG4+SIG2+SIG1
      &          +s4pi+srho+somega))GO TO 306
            if(RANART(NSEED).le.s4pi/(x1535+sig4+sig2+sig1
      &          +s4pi+srho+somega))go to 307
            if(RANART(NSEED).le.srho/(x1535+sig4+sig2+sig1
      &          +srho+somega))go to 308
            if(RANART(NSEED).le.somega/(x1535+sig4+sig2+sig1
      &          +somega))go to 309
            if(RANART(NSEED).le.x1535/(sig1+sig2+sig4+x1535))then
 * N*(1535) production
               N12=9
            ELSE 
               IF(RANART(NSEED).LE.SIG4/(SIG1+sig2+sig4))THEN
 * DOUBLE DELTA PRODUCTION
                  N12=66
                  GO TO 1012
               else
 *DELTA PRODUCTION
                  N12=3
                  IF (RANART(NSEED).GT.SIG1/(SIG1+SIG2))N12=4
               ENDIF
            endif
            GO TO 1011
         ENDIF
 ** FOR N+N COLLISION:
         IF(iabs(LB(I1)).EQ.2.AND.iabs(LB(I2)).EQ.2)THEN
 clin-8/2008 NN->d+meson here:
            IF(X1.LE.((SIGNN+sdprod)/SIG)) GO TO 108
            SIG1=SIGMA(SRT,1,1,0)+0.5*SIGMA(SRT,1,1,1)
            SIG2=1.5*SIGMA(SRT,1,1,1)
            SIGND=SIG1+SIG2+X1535+SIG3+SIG4+SIGK+s4pi+srho+somega
 clin-5/2008:
 c           IF (X1.GT.(SIGNN+SIGND)/SIG)RETURN
            IF (X1.GT.(SIGNN+SIGND+sdprod)/SIG)RETURN
            dir=sig3/signd
            IF(RANART(NSEED).LE.DIR)GO TO 106
            IF(RANART(NSEED).LE.SIGK/(SIGK+X1535+SIG4+SIG2+SIG1
      &          +s4pi+srho+somega))GO TO 306
            if(RANART(NSEED).le.s4pi/(x1535+sig4+sig2+sig1
      &          +s4pi+srho+somega))go to 307
            if(RANART(NSEED).le.srho/(x1535+sig4+sig2+sig1
      &          +srho+somega))go to 308
            if(RANART(NSEED).le.somega/(x1535+sig4+sig2+sig1
      &          +somega))go to 309
            IF(RANART(NSEED).LE.X1535/(x1535+sig1+sig2+sig4))THEN
 * N*(1535) PRODUCTION
               N12=10
            ELSE 
               if(RANART(NSEED).le.sig4/(sig1+sig2+sig4))then
 * double delta production
                  N12=67
                  GO TO 1013
               else
 * DELTA PRODUCTION
                  N12=6
                  IF (RANART(NSEED).GT.SIG1/(SIG1+SIG2))N12=5
               ENDIF
            endif
            GO TO 1011
         ENDIF
 ** FOR N+P COLLISION
         IF(LB(I1)*LB(I2).EQ.2)THEN
 clin-5/2008 NP->d+meson here:
            IF(X1.LE.((SIGNN+sdprod)/SIG)) GO TO 108
            SIG1=0.5*SIGMA(SRT,1,1,1)+0.25*SIGMA(SRT,1,1,0)
            IF(NSTAR.EQ.1)THEN
               SIG2=(3./4.)*SIGMA(SRT,2,0,1)
            ELSE
               SIG2=0.
            ENDIF
            SIGND=2.*(SIG1+SIG2+X1535)+sig3+sig4+SIGK+s4pi+srho+somega
 clin-5/2008:
 c           IF (X1.GT.(SIGNN+SIGND)/SIG)RETURN
            IF (X1.GT.(SIGNN+SIGND+sdprod)/SIG)RETURN
            dir=sig3/signd
            IF(RANART(NSEED).LE.DIR)GO TO 106
            IF(RANART(NSEED).LE.SIGK/(SIGND-SIG3))GO TO 306
            if(RANART(NSEED).le.s4pi/(signd-sig3-sigk))go to 307
            if(RANART(NSEED).le.srho/(signd-sig3-sigk-s4pi))go to 308
            if(RANART(NSEED).le.somega/(signd-sig3-sigk-s4pi-srho))
      1          go to 309
            IF(RANART(NSEED).LT.X1535/(SIG1+SIG2+X1535+0.5*sig4))THEN
 * N*(1535) PRODUCTION
               N12=11
               IF(RANART(NSEED).LE.0.5)N12=12
            ELSE 
               if(RANART(NSEED).le.sig4/(sig4+2.*(sig1+sig2)))then
 * double resonance production
                  N12=68
                  GO TO 1014
               else
                  IF(RANART(NSEED).LE.SIG1/(SIG1+SIG2))THEN
 * DELTA PRODUCTION
                     N12=2
                     IF(RANART(NSEED).GE.0.5)N12=1
                  ELSE
 * N*(1440) PRODUCTION
                     N12=8
                     IF(RANART(NSEED).GE.0.5)N12=7
                  ENDIF
               ENDIF
            ENDIF
         endif
  1011   iblock=2
         CONTINUE
 *PARAMETRIZATION OF THE SHAPE OF THE DELTA RESONANCE ACCORDING
 *     TO kitazoe's or J.D.JACKSON'S MASS FORMULA AND BREIT WIGNER
 *     FORMULA FOR N* RESORANCE
 *     DETERMINE DELTA MASS VIA REJECTION METHOD.
           DMAX = SRT - AVMASS-0.005
           DMAX = SRT - AVMASS-0.005
           DMIN = 1.078
                    IF(N12.LT.7)THEN
 * Delta(1232) production
           IF(DMAX.LT.1.232) THEN
           FM=FDE(DMAX,SRT,0.)
           ELSE
 
 clin-10/25/02 get rid of argument usage mismatch in FDE():
              xdmass=1.232
 c          FM=FDE(1.232,SRT,1.)
           FM=FDE(xdmass,SRT,1.)
 clin-10/25/02-end
 
           ENDIF
           IF(FM.EQ.0.)FM=1.E-09
           NTRY1=0
 10        DM = RANART(NSEED) * (DMAX-DMIN) + DMIN
           NTRY1=NTRY1+1
           IF((RANART(NSEED) .GT. FDE(DM,SRT,1.)/FM).AND.
      1    (NTRY1.LE.30)) GOTO 10
 
 clin-2/26/03 limit the Delta mass below a certain value 
 c     (here taken as its central value + 2* B-W fullwidth):
           if(dm.gt.1.47) goto 10
 
               GO TO 13
               ENDIF
                    IF((n12.eq.7).or.(n12.eq.8))THEN
 * N*(1440) production
           IF(DMAX.LT.1.44) THEN
           FM=FNS(DMAX,SRT,0.)
           ELSE
 
 clin-10/25/02 get rid of argument usage mismatch in FNS():
              xdmass=1.44
 c          FM=FNS(1.44,SRT,1.)
           FM=FNS(xdmass,SRT,1.)
 clin-10/25/02-end
 
           ENDIF
           IF(FM.EQ.0.)FM=1.E-09
           NTRY2=0
 11        DM=RANART(NSEED)*(DMAX-DMIN)+DMIN
           NTRY2=NTRY2+1
           IF((RANART(NSEED).GT.FNS(DM,SRT,1.)/FM).AND.
      1    (NTRY2.LE.10)) GO TO 11
 
 clin-2/26/03 limit the N* mass below a certain value 
 c     (here taken as its central value + 2* B-W fullwidth):
           if(dm.gt.2.14) goto 11
 
               GO TO 13
               ENDIF
                     IF(n12.ge.17)then
 * N*(1535) production
           IF(DMAX.LT.1.535) THEN
           FM=FD5(DMAX,SRT,0.)
           ELSE
 
 clin-10/25/02 get rid of argument usage mismatch in FNS():
              xdmass=1.535
 c          FM=FD5(1.535,SRT,1.)
           FM=FD5(xdmass,SRT,1.)
 clin-10/25/02-end
 
           ENDIF
           IF(FM.EQ.0.)FM=1.E-09
           NTRY1=0
 12        DM = RANART(NSEED) * (DMAX-DMIN) + DMIN
           NTRY1=NTRY1+1
           IF((RANART(NSEED) .GT. FD5(DM,SRT,1.)/FM).AND.
      1    (NTRY1.LE.10)) GOTO 12
 
 clin-2/26/03 limit the N* mass below a certain value 
 c     (here taken as its central value + 2* B-W fullwidth):
           if(dm.gt.1.84) goto 12
 
          GO TO 13
              ENDIF
 * CALCULATE THE MASSES OF BARYON RESONANCES IN THE DOUBLE RESONANCE
 * PRODUCTION PROCESS AND RELABLE THE PARTICLES
 1012       iblock=43
        call Rmasdd(srt,1.232,1.232,1.08,
      &  1.08,ISEED,1,dm1,dm2)
        call Rmasdd(srt,1.232,1.44,1.08,
      &  1.08,ISEED,3,dm1n,dm2n)
        IF(N12.EQ.66)THEN
 *(1) PP-->DOUBLE RESONANCES
 * DETERMINE THE FINAL STATE
        XFINAL=RANART(NSEED)
        IF(XFINAL.LE.0.25)THEN
 * (1.1) D+++D0 
        LB(I1)=9
        LB(I2)=7
        e(i1)=dm1
        e(i2)=dm2
        GO TO 200
 * go to 200 to set the new momentum
        ENDIF
        IF((XFINAL.gt.0.25).and.(xfinal.le.0.5))THEN
 * (1.2) D++D+
        LB(I1)=8
        LB(I2)=8
        e(i1)=dm1
        e(i2)=dm2
        GO TO 200
 * go to 200 to set the new momentum
        ENDIF
        IF((XFINAL.gt.0.5).and.(xfinal.le.0.75))THEN
 * (1.3) D+++N*0 
        LB(I1)=9
        LB(I2)=10
        e(i1)=dm1n
        e(i2)=dm2n
        GO TO 200
 * go to 200 to set the new momentum
        ENDIF
        IF(XFINAL.gt.0.75)then
 * (1.4) D++N*+ 
        LB(I1)=8
        LB(I2)=11
        e(i1)=dm1n
        e(i2)=dm2n
        GO TO 200
 * go to 200 to set the new momentum
        ENDIF
        ENDIF
 1013       iblock=43
        call Rmasdd(srt,1.232,1.232,1.08,
      &  1.08,ISEED,1,dm1,dm2)
        call Rmasdd(srt,1.232,1.44,1.08,
      &  1.08,ISEED,3,dm1n,dm2n)
        IF(N12.EQ.67)THEN
 *(2) NN-->DOUBLE RESONANCES
 * DETERMINE THE FINAL STATE
        XFINAL=RANART(NSEED)
        IF(XFINAL.LE.0.25)THEN
 * (2.1) D0+D0 
        LB(I1)=7
        LB(I2)=7
        e(i1)=dm1
        e(i2)=dm2
        GO TO 200
 * go to 200 to set the new momentum
         ENDIF
        IF((XFINAL.gt.0.25).and.(xfinal.le.0.5))THEN
 * (2.2) D++D+
        LB(I1)=6
        LB(I2)=8
        e(i1)=dm1
        e(i2)=dm2
        GO TO 200
 * go to 200 to set the new momentum
        ENDIF
        IF((XFINAL.gt.0.5).and.(xfinal.le.0.75))THEN
 * (2.3) D0+N*0 
        LB(I1)=7
        LB(I2)=10
        e(i1)=dm1n
        e(i2)=dm2n
        GO TO 200
 * go to 200 to set the new momentum
        ENDIF
        IF(XFINAL.gt.0.75)then
 * (2.4) D++N*+ 
        LB(I1)=8
        LB(I2)=11
        e(i1)=dm1n
        e(i2)=dm2n
        GO TO 200
 * go to 200 to set the new momentum
        ENDIF
        ENDIF
 1014       iblock=43
        call Rmasdd(srt,1.232,1.232,1.08,
      &  1.08,ISEED,1,dm1,dm2)
        call Rmasdd(srt,1.232,1.44,1.08,
      &  1.08,ISEED,3,dm1n,dm2n)
        IF(N12.EQ.68)THEN
 *(3) NP-->DOUBLE RESONANCES
 * DETERMINE THE FINAL STATE
        XFINAL=RANART(NSEED)
        IF(XFINAL.LE.0.25)THEN
 * (3.1) D0+D+ 
        LB(I1)=7
        LB(I2)=8
        e(i1)=dm1
        e(i2)=dm2
        GO TO 200
 * go to 200 to set the new momentum
        ENDIF
        IF((XFINAL.gt.0.25).and.(xfinal.le.0.5))THEN
 * (3.2) D+++D-
        LB(I1)=9
        LB(I2)=6
        e(i1)=dm1
        e(i2)=dm2
        GO TO 200
 * go to 200 to set the new momentum
        ENDIF
        IF((XFINAL.gt.0.5).and.(xfinal.le.0.75))THEN
 * (3.3) D0+N*+ 
        LB(I1)=7
        LB(I2)=11
        e(i1)=dm1n
        e(i2)=dm2n
        GO TO 200
 * go to 200 to set the new momentum
        ENDIF
        IF(XFINAL.gt.0.75)then
 * (3.4) D++N*0
        LB(I1)=8
        LB(I2)=10
        e(i1)=dm1n
        e(i2)=dm2n
        GO TO 200
 * go to 200 to set the new momentum
        ENDIF
        ENDIF
 13       CONTINUE
 *-------------------------------------------------------
 * RELABLE BARYON I1 AND I2
 *1. p+n-->delta(+)+n
           IF(N12.EQ.1)THEN
           IF(iabs(LB(I1)).EQ.1)THEN
           LB(I2)=2
           LB(I1)=8
           E(I1)=DM
           ELSE
           LB(I1)=2
           LB(I2)=8
           E(I2)=DM
           ENDIF
          GO TO 200
           ENDIF
 *2 p+n-->delta(0)+p
           IF(N12.EQ.2)THEN
           IF(iabs(LB(I1)).EQ.2)THEN
           LB(I2)=1
           LB(I1)=7
           E(I1)=DM
           ELSE
           LB(I1)=1
           LB(I2)=7
           E(I2)=DM
           ENDIF
          GO TO 200
           ENDIF
 *3 p+p-->delta(++)+n
           IF(N12.EQ.3)THEN
           LB(I1)=9
           E(I1)=DM
           LB(I2)=2
           E(I2)=AMN
          GO TO 200
           ENDIF
 *4 p+p-->delta(+)+p
           IF(N12.EQ.4)THEN
           LB(I2)=1
           LB(I1)=8
           E(I1)=DM
          GO TO 200
           ENDIF
 *5 n+n--> delta(0)+n
           IF(N12.EQ.5)THEN
           LB(I2)=2
           LB(I1)=7
           E(I1)=DM
          GO TO 200
           ENDIF
 *6 n+n--> delta(-)+p
           IF(N12.EQ.6)THEN
           LB(I1)=6
           E(I1)=DM
           LB(I2)=1
           E(I2)=AMP
          GO TO 200
           ENDIF
 *7 n+p--> N*(0)+p
           IF(N12.EQ.7)THEN
           IF(iabs(LB(I1)).EQ.1)THEN
           LB(I1)=1
           LB(I2)=10
           E(I2)=DM
           ELSE
           LB(I2)=1
           LB(I1)=10
           E(I1)=DM
           ENDIF
          GO TO 200
           ENDIF
 *8 n+p--> N*(+)+n
           IF(N12.EQ.8)THEN
           IF(iabs(LB(I1)).EQ.1)THEN
           LB(I2)=2
           LB(I1)=11
           E(I1)=DM
           ELSE
           LB(I1)=2
           LB(I2)=11
           E(I2)=DM
           ENDIF
          GO TO 200
           ENDIF
 *9 p+p--> N*(+)(1535)+p
           IF(N12.EQ.9)THEN
           IF(RANART(NSEED).le.0.5)THEN
           LB(I2)=1
           LB(I1)=13
           E(I1)=DM
           ELSE
           LB(I1)=1
           LB(I2)=13
           E(I2)=DM
           ENDIF
          GO TO 200
           ENDIF
 *10 n+n--> N*(0)(1535)+n
           IF(N12.EQ.10)THEN
           IF(RANART(NSEED).le.0.5)THEN
           LB(I2)=2
           LB(I1)=12
           E(I1)=DM
           ELSE
           LB(I1)=2
           LB(I2)=12
           E(I2)=DM
           ENDIF
          GO TO 200
           ENDIF
 *11 n+p--> N*(+)(1535)+n
           IF(N12.EQ.11)THEN
           IF(iabs(LB(I1)).EQ.2)THEN
           LB(I1)=2
           LB(I2)=13
           E(I2)=DM
           ELSE
           LB(I2)=2
           LB(I1)=13
           E(I1)=DM
           ENDIF
          GO TO 200
           ENDIF
 *12 n+p--> N*(0)(1535)+p
           IF(N12.EQ.12)THEN
           IF(iabs(LB(I1)).EQ.1)THEN
           LB(I1)=1
           LB(I2)=12
           E(I2)=DM
           ELSE
           LB(I2)=1
           LB(I1)=12
           E(I1)=DM
           ENDIF
           ENDIF
          endif
 * CALCULATE THE MAGNITUDE OF THE FINAL MOMENTUM THROUGH
 * ENERGY CONSERVATION
 200       EM1=E(I1)
           EM2=E(I2)
           PR2   = (SRT**2 - EM1**2 - EM2**2)**2
      1                - 4.0 * (EM1*EM2)**2
           IF(PR2.LE.0.)PR2=1.e-09
           PR=SQRT(PR2)/(2.*SRT)
               if(srt.le.2.14)C1= 1.0 - 2.0 * RANART(NSEED)
          if(srt.gt.2.14.and.srt.le.2.4)c1=ang(srt,iseed)
          if(srt.gt.2.4)then
 
 clin-10/25/02 get rid of argument usage mismatch in PTR():
              xptr=0.33*pr
 c         cc1=ptr(0.33*pr,iseed)
              cc1=ptr(xptr,iseed)
 clin-10/25/02-end
 
 clin-9/2012: check argument in sqrt():
              scheck=pr**2-cc1**2
              if(scheck.lt.0) then
                 write(99,*) 'scheck2: ', scheck
                 scheck=0.
              endif
              c1=sqrt(scheck)/pr
 c             c1=sqrt(pr**2-cc1**2)/pr
 
          endif
           T1   = 2.0 * PI * RANART(NSEED)
        if(ianti.eq.1 .and. lb(i1).ge.1 .and. lb(i2).ge.1)then
          lb(i1) = -lb(i1)
          lb(i2) = -lb(i2)
        endif
           GO TO 107
 *FOR THE NN-->D1+D2+PI PROCESS, FIND MOMENTUM OF THE FINAL TWO
 *DELTAS AND PION IN THE NUCLEUS-NUCLEUS CMS.
 106     CONTINUE
            NTRY1=0
 123        CALL DDP2(SRT,ISEED,PX3,PY3,PZ3,DM3,PX4,PY4,PZ4,DM4,
      &  PPX,PPY,PPZ,icou1)
        NTRY1=NTRY1+1
        if((icou1.lt.0).AND.(NTRY1.LE.40))GO TO 123
 C       if(icou1.lt.0)return
 * ROTATE THE MOMENTA OF PARTICLES IN THE CMS OF P1+P2
        CALL ROTATE(PX,PY,PZ,PX3,PY3,PZ3)
        CALL ROTATE(PX,PY,PZ,PX4,PY4,PZ4)
        CALL ROTATE(PX,PY,PZ,PPX,PPY,PPZ)
                 NNN=NNN+1
 * DETERMINE THE CHARGE STATES OF PARTICLES IN THE FINAL STATE
 * (1) FOR P+P
               XDIR=RANART(NSEED)
                 IF(LB(I1)*LB(I2).EQ.1)THEN
                 IF(XDIR.Le.0.2)then
 * (1.1)P+P-->D+++D0+PION(0)
                 LPION(NNN,IRUN)=4
                 EPION(NNN,IRUN)=AP1
               LB(I1)=9
               LB(I2)=7
        GO TO 205
                 ENDIF
 * (1.2)P+P -->D++D+PION(0)
                 IF((XDIR.LE.0.4).AND.(XDIR.GT.0.2))THEN
                 LPION(NNN,IRUN)=4
                 EPION(NNN,IRUN)=AP1
                 LB(I1)=8
                 LB(I2)=8
        GO TO 205
               ENDIF 
 * (1.3)P+P-->D+++D+PION(-)
                 IF((XDIR.LE.0.6).AND.(XDIR.GT.0.4))THEN
                 LPION(NNN,IRUN)=3
                 EPION(NNN,IRUN)=AP2
                 LB(I1)=9
                 LB(I2)=8
        GO TO 205
               ENDIF 
                 IF((XDIR.LE.0.8).AND.(XDIR.GT.0.6))THEN
                 LPION(NNN,IRUN)=5
                 EPION(NNN,IRUN)=AP2
                 LB(I1)=9
                 LB(I2)=6
        GO TO 205
               ENDIF 
                 IF(XDIR.GT.0.8)THEN
                 LPION(NNN,IRUN)=5
                 EPION(NNN,IRUN)=AP2
                 LB(I1)=7
                 LB(I2)=8
        GO TO 205
               ENDIF 
                ENDIF
 * (2)FOR N+N
                 IF(iabs(LB(I1)).EQ.2.AND.iabs(LB(I2)).EQ.2)THEN
                 IF(XDIR.Le.0.2)then
 * (2.1)N+N-->D++D-+PION(0)
                 LPION(NNN,IRUN)=4
                 EPION(NNN,IRUN)=AP1
               LB(I1)=6
               LB(I2)=7
        GO TO 205
                 ENDIF
 * (2.2)N+N -->D+++D-+PION(-)
                 IF((XDIR.LE.0.4).AND.(XDIR.GT.0.2))THEN
                 LPION(NNN,IRUN)=3
                 EPION(NNN,IRUN)=AP2
                 LB(I1)=6
                 LB(I2)=9
        GO TO 205
               ENDIF 
 * (2.3)P+P-->D0+D-+PION(+)
                 IF((XDIR.GT.0.4).AND.(XDIR.LE.0.6))THEN
                 LPION(NNN,IRUN)=5
                 EPION(NNN,IRUN)=AP2
                 LB(I1)=9
                 LB(I2)=8
        GO TO 205
               ENDIF 
 * (2.4)P+P-->D0+D0+PION(0)
                 IF((XDIR.GT.0.6).AND.(XDIR.LE.0.8))THEN
                 LPION(NNN,IRUN)=4
                 EPION(NNN,IRUN)=AP1
                 LB(I1)=7
                 LB(I2)=7
        GO TO 205
               ENDIF 
 * (2.5)P+P-->D0+D++PION(-)
                 IF(XDIR.GT.0.8)THEN
                 LPION(NNN,IRUN)=3
                 EPION(NNN,IRUN)=AP2
                 LB(I1)=7
                 LB(I2)=8
        GO TO 205
               ENDIF 
               ENDIF
 * (3)FOR N+P
                 IF(LB(I1)*LB(I2).EQ.2)THEN
                 IF(XDIR.Le.0.17)then
 * (3.1)N+P-->D+++D-+PION(0)
                 LPION(NNN,IRUN)=4
                 EPION(NNN,IRUN)=AP1
               LB(I1)=6
               LB(I2)=9
        GO TO 205
                 ENDIF
 * (3.2)N+P -->D+++D0+PION(-)
                 IF((XDIR.LE.0.34).AND.(XDIR.GT.0.17))THEN
                 LPION(NNN,IRUN)=3
                 EPION(NNN,IRUN)=AP2
                 LB(I1)=7
                 LB(I2)=9
        GO TO 205
               ENDIF 
 * (3.3)N+P-->D++D-+PION(+)
                 IF((XDIR.GT.0.34).AND.(XDIR.LE.0.51))THEN
                 LPION(NNN,IRUN)=5
                 EPION(NNN,IRUN)=AP2
                 LB(I1)=7
                 LB(I2)=8
        GO TO 205
               ENDIF 
 * (3.4)N+P-->D++D++PION(-)
                 IF((XDIR.GT.0.51).AND.(XDIR.LE.0.68))THEN
                 LPION(NNN,IRUN)=3
                 EPION(NNN,IRUN)=AP2
                 LB(I1)=8
                 LB(I2)=8
        GO TO 205
               ENDIF 
 * (3.5)N+P-->D0+D++PION(0)
                 IF((XDIR.GT.0.68).AND.(XDIR.LE.0.85))THEN
                 LPION(NNN,IRUN)=4
                 EPION(NNN,IRUN)=AP2
                 LB(I1)=7
                 LB(I2)=8
        GO TO 205
               ENDIF 
 * (3.6)N+P-->D0+D0+PION(+)
                 IF(XDIR.GT.0.85)THEN
                 LPION(NNN,IRUN)=5
                 EPION(NNN,IRUN)=AP2
                 LB(I1)=7
                 LB(I2)=7
               ENDIF 
                 ENDIF
 * FIND THE MOMENTUM OF PARTICLES IN THE FINAL STATE IN THE NUCLEUS-
 * NUCLEUS CMS. FRAME 
 *             LORENTZ-TRANSFORMATION INTO LAB FRAME FOR DELTA1
 205           E1CM    = SQRT (dm3**2 + PX3**2 + PY3**2 + PZ3**2)
               P1BETA  = PX3*BETAX + PY3*BETAY + PZ3*BETAZ
               TRANSF  = GAMMA * ( GAMMA * P1BETA / (GAMMA + 1) + E1CM )
               Pt1i1 = BETAX * TRANSF + PX3
               Pt2i1 = BETAY * TRANSF + PY3
               Pt3i1 = BETAZ * TRANSF + PZ3
              Eti1   = DM3
 c
              if(ianti.eq.1 .and. lb(i1).ge.1 .and. lb(i2).ge.1)then
                lb(i1) = -lb(i1)
                lb(i2) = -lb(i2)
                 if(LPION(NNN,IRUN) .eq. 3)then
                   LPION(NNN,IRUN)=5
                 elseif(LPION(NNN,IRUN) .eq. 5)then
                   LPION(NNN,IRUN)=3
                 endif
                endif
 c
              lb1=lb(i1)
 * FOR DELTA2
                 E2CM    = SQRT (dm4**2 + PX4**2 + PY4**2 + PZ4**2)
                 P2BETA  = PX4*BETAX+PY4*BETAY+PZ4*BETAZ
                 TRANSF  = GAMMA * (GAMMA*P2BETA / (GAMMA + 1.) + E2CM)
                 Pt1I2 = BETAX * TRANSF + PX4
                 Pt2I2 = BETAY * TRANSF + PY4
                 Pt3I2 = BETAZ * TRANSF + PZ4
               EtI2   = DM4
               lb2=lb(i2)
 * assign delta1 and delta2 to i1 or i2 to keep the leadng particle
 * behaviour
 C              if((pt1i1*px1+pt2i1*py1+pt3i1*pz1).gt.0)then
               p(1,i1)=pt1i1
               p(2,i1)=pt2i1
               p(3,i1)=pt3i1
               e(i1)=eti1
               lb(i1)=lb1
               p(1,i2)=pt1i2
               p(2,i2)=pt2i2
               p(3,i2)=pt3i2
               e(i2)=eti2
               lb(i2)=lb2
                 PX1     = P(1,I1)
                 PY1     = P(2,I1)
                 PZ1     = P(3,I1)
               EM1       = E(I1)
                 ID(I1)  = 2
                 ID(I2)  = 2
                 ID1     = ID(I1)
                 IBLOCK=4
 * GET PION'S MOMENTUM AND COORDINATES IN NUCLEUS-NUCLEUS CMS. FRAME
                 EPCM=SQRT(EPION(NNN,IRUN)**2+PPX**2+PPY**2+PPZ**2)
                 PPBETA=PPX*BETAX+PPY*BETAY+PPZ*BETAZ
                 TRANSF=GAMMA*(GAMMA*PPBETA/(GAMMA+1.)+EPCM)
                 PPION(1,NNN,IRUN)=BETAX*TRANSF+PPX
                 PPION(2,NNN,IRUN)=BETAY*TRANSF+PPY
                 PPION(3,NNN,IRUN)=BETAZ*TRANSF+PPZ
 clin-5/2008:
                 dppion(nnn,irun)=dpertp(i1)*dpertp(i2)
 clin-5/2008 do not allow smearing in position of produced particles 
 c     to avoid immediate reinteraction with the particle I1, I2 or themselves:
 c2002        X01 = 1.0 - 2.0 * RANART(NSEED)
 c            Y01 = 1.0 - 2.0 * RANART(NSEED)
 c            Z01 = 1.0 - 2.0 * RANART(NSEED)
 c        IF ((X01*X01+Y01*Y01+Z01*Z01) .GT. 1.0) GOTO 2002
 c                RPION(1,NNN,IRUN)=R(1,I1)+0.5*x01
 c                RPION(2,NNN,IRUN)=R(2,I1)+0.5*y01
 c                RPION(3,NNN,IRUN)=R(3,I1)+0.5*z01
                 RPION(1,NNN,IRUN)=R(1,I1)
                 RPION(2,NNN,IRUN)=R(2,I1)
                 RPION(3,NNN,IRUN)=R(3,I1)
 c
               go to 90005
 clin-5/2008 N+N->Deuteron+pi:
 *     FIND MOMENTUM OF THE FINAL PARTICLES IN THE NUCLEUS-NUCLEUS CMS.
  108       CONTINUE
            if(idpert.eq.1.and.ipert1.eq.1.and.npertd.ge.1) then
 c     For idpert=1: we produce npertd pert deuterons:
               ndloop=npertd
            elseif(idpert.eq.2.and.npertd.ge.1) then
 c     For idpert=2: we first save information for npertd pert deuterons;
 c     at the last ndloop we create the regular deuteron+pi 
 c     and those pert deuterons:
               ndloop=npertd+1
            else
 c     Just create the regular deuteron+pi:
               ndloop=1
            endif
 c
            dprob1=sdprod/sig/float(npertd)
            do idloop=1,ndloop
               CALL bbdangle(pxd,pyd,pzd,nt,ipert1,ianti,idloop,pfinal,
      1 dprob1,lbm)
               CALL ROTATE(PX,PY,PZ,PXd,PYd,PZd)
 *     LORENTZ-TRANSFORMATION OF THE MOMENTUM OF PARTICLES IN THE FINAL STATE 
 *     FROM THE NN CMS FRAME INTO THE GLOBAL CMS FRAME:
 *     For the Deuteron:
               xmass=xmd
               E1dCM=SQRT(xmass**2+PXd**2+PYd**2+PZd**2)
               P1dBETA=PXd*BETAX+PYd*BETAY+PZd*BETAZ
               TRANSF=GAMMA*(GAMMA*P1dBETA/(GAMMA+1.)+E1dCM)
               pxi1=BETAX*TRANSF+PXd
               pyi1=BETAY*TRANSF+PYd
               pzi1=BETAZ*TRANSF+PZd
               if(ianti.eq.0)then
                  lbd=42
               else
                  lbd=-42
               endif
               if(idpert.eq.1.and.ipert1.eq.1.and.npertd.ge.1) then
 cccc  Perturbative production for idpert=1:
                  nnn=nnn+1
                  PPION(1,NNN,IRUN)=pxi1
                  PPION(2,NNN,IRUN)=pyi1
                  PPION(3,NNN,IRUN)=pzi1
                  EPION(NNN,IRUN)=xmd
                  LPION(NNN,IRUN)=lbd
                  RPION(1,NNN,IRUN)=R(1,I1)
                  RPION(2,NNN,IRUN)=R(2,I1)
                  RPION(3,NNN,IRUN)=R(3,I1)
 clin-5/2008 assign the perturbative probability:
                  dppion(NNN,IRUN)=sdprod/sig/float(npertd)
               elseif(idpert.eq.2.and.idloop.le.npertd) then
 clin-5/2008 For idpert=2, we produce NPERTD perturbative (anti)deuterons 
 c     only when a regular (anti)deuteron+pi is produced in NN collisions.
 c     First save the info for the perturbative deuterons:
                  ppd(1,idloop)=pxi1
                  ppd(2,idloop)=pyi1
                  ppd(3,idloop)=pzi1
                  lbpd(idloop)=lbd
               else
 cccc  Regular production:
 c     For the regular pion: do LORENTZ-TRANSFORMATION:
                  E(i1)=xmm
                  E2piCM=SQRT(xmm**2+PXd**2+PYd**2+PZd**2)
                  P2piBETA=-PXd*BETAX-PYd*BETAY-PZd*BETAZ
                  TRANSF=GAMMA*(GAMMA*P2piBETA/(GAMMA+1.)+E2piCM)
                  pxi2=BETAX*TRANSF-PXd
                  pyi2=BETAY*TRANSF-PYd
                  pzi2=BETAZ*TRANSF-PZd
                  p(1,i1)=pxi2
                  p(2,i1)=pyi2
                  p(3,i1)=pzi2
 c     Remove regular pion to check the equivalence 
 c     between the perturbative and regular deuteron results:
 c                 E(i1)=0.
 c
                  LB(I1)=lbm
                  PX1=P(1,I1)
                  PY1=P(2,I1)
                  PZ1=P(3,I1)
                  EM1=E(I1)
                  ID(I1)=2
                  ID1=ID(I1)
                  E1=SQRT(EM1**2+PX1**2+PY1**2+PZ1**2)
                  lb1=lb(i1)
 c     For the regular deuteron:
                  p(1,i2)=pxi1
                  p(2,i2)=pyi1
                  p(3,i2)=pzi1
                  lb(i2)=lbd
                  lb2=lb(i2)
                  E(i2)=xmd
                  EtI2=E(I2)
                  ID(I2)=2
 c     For idpert=2: create the perturbative deuterons:
                  if(idpert.eq.2.and.idloop.eq.ndloop) then
                     do ipertd=1,npertd
                        nnn=nnn+1
                        PPION(1,NNN,IRUN)=ppd(1,ipertd)
                        PPION(2,NNN,IRUN)=ppd(2,ipertd)
                        PPION(3,NNN,IRUN)=ppd(3,ipertd)
                        EPION(NNN,IRUN)=xmd
                        LPION(NNN,IRUN)=lbpd(ipertd)
                        RPION(1,NNN,IRUN)=R(1,I1)
                        RPION(2,NNN,IRUN)=R(2,I1)
                        RPION(3,NNN,IRUN)=R(3,I1)
 clin-5/2008 assign the perturbative probability:
                        dppion(NNN,IRUN)=1./float(npertd)
                     enddo
                  endif
               endif
            enddo
            IBLOCK=501
            go to 90005
 clin-5/2008 N+N->Deuteron+pi over
 * FOR THE NN-->KAON+X PROCESS, FIND MOMENTUM OF THE FINAL PARTICLES IN 
 * THE NUCLEUS-NUCLEUS CMS.
 306     CONTINUE
 csp11/21/01 phi production
               if(XSK5/sigK.gt.RANART(NSEED))then
               pz1=p(3,i1)
               pz2=p(3,i2)
                 LB(I1) = 1 + int(2 * RANART(NSEED))
                 LB(I2) = 1 + int(2 * RANART(NSEED))
               nnn=nnn+1
                 LPION(NNN,IRUN)=29
                 EPION(NNN,IRUN)=APHI
                 iblock = 222
               GO TO 208
                ENDIF
 c
                  IBLOCK=9
                  if(ianti .eq. 1)iblock=-9
 c
               pz1=p(3,i1)
               pz2=p(3,i2)
 * DETERMINE THE CHARGE STATES OF PARTICLES IN THE FINAL STATE
               nnn=nnn+1
                 LPION(NNN,IRUN)=23
                 EPION(NNN,IRUN)=Aka
               if(srt.le.2.63)then
 * only lambda production is possible
 * (1.1)P+P-->p+L+kaon+
               ic=1
                 LB(I1) = 1 + int(2 * RANART(NSEED))
               LB(I2)=14
               GO TO 208
                 ENDIF
        if(srt.le.2.74.and.srt.gt.2.63)then
 * both Lambda and sigma production are possible
               if(XSK1/(XSK1+XSK2).gt.RANART(NSEED))then
 * lambda production
               ic=1
                 LB(I1) = 1 + int(2 * RANART(NSEED))
               LB(I2)=14
               else
 * sigma production
                 LB(I1) = 1 + int(2 * RANART(NSEED))
                 LB(I2) = 15 + int(3 * RANART(NSEED))
               ic=2
               endif
               GO TO 208
        endif
        if(srt.le.2.77.and.srt.gt.2.74)then
 * then pp-->Delta lamda kaon can happen
               if(xsk1/(xsk1+xsk2+xsk3).
      1          gt.RANART(NSEED))then
 * * (1.1)P+P-->p+L+kaon+
               ic=1
                 LB(I1) = 1 + int(2 * RANART(NSEED))
               LB(I2)=14
               go to 208
               else
               if(xsk2/(xsk2+xsk3).gt.RANART(NSEED))then
 * pp-->psk
               ic=2
                 LB(I1) = 1 + int(2 * RANART(NSEED))
                 LB(I2) = 15 + int(3 * RANART(NSEED))
               else
 * pp-->D+l+k        
               ic=3
                 LB(I1) = 6 + int(4 * RANART(NSEED))
               lb(i2)=14
               endif
               GO TO 208
               endif
        endif
        if(srt.gt.2.77)then
 * all four channels are possible
               if(xsk1/(xsk1+xsk2+xsk3+xsk4).gt.RANART(NSEED))then
 * p lambda k production
               ic=1
                 LB(I1) = 1 + int(2 * RANART(NSEED))
               LB(I2)=14
               go to 208
        else
           if(xsk3/(xsk2+xsk3+xsk4).gt.RANART(NSEED))then
 * delta l K production
               ic=3
                 LB(I1) = 6 + int(4 * RANART(NSEED))
               lb(i2)=14
               go to 208
           else
               if(xsk2/(xsk2+xsk4).gt.RANART(NSEED))then
 * n sigma k production
                    LB(I1) = 1 + int(2 * RANART(NSEED))
                    LB(I2) = 15 + int(3 * RANART(NSEED))
               ic=2
               else
               ic=4
                 LB(I1) = 6 + int(4 * RANART(NSEED))
                 LB(I2) = 15 + int(3 * RANART(NSEED))
               endif
               go to 208
           endif
        endif
        endif
 208             continue
          if(ianti.eq.1 .and. lb(i1).ge.1 .and. lb(i2).ge.1)then
           lb(i1) = - lb(i1)
           lb(i2) = - lb(i2)
           if(LPION(NNN,IRUN) .eq. 23)LPION(NNN,IRUN)=21
          endif
 * KEEP ALL COORDINATES OF PARTICLE 2 FOR POSSIBLE PHASE SPACE CHANGE
            NTRY1=0
 127        CALL BBKAON(ic,SRT,PX3,PY3,PZ3,DM3,PX4,PY4,PZ4,DM4,
      &  PPX,PPY,PPZ,icou1)
        NTRY1=NTRY1+1
        if((icou1.lt.0).AND.(NTRY1.LE.20))GO TO 127
 c       if(icou1.lt.0)return
 * ROTATE THE MOMENTA OF PARTICLES IN THE CMS OF P1+P2
        CALL ROTATE(PX,PY,PZ,PX3,PY3,PZ3)
        CALL ROTATE(PX,PY,PZ,PX4,PY4,PZ4)
        CALL ROTATE(PX,PY,PZ,PPX,PPY,PPZ)
 * FIND THE MOMENTUM OF PARTICLES IN THE FINAL STATE IN THE NUCLEUS-
 * NUCLEUS CMS. FRAME 
 * (1) for the necleon/delta
 *             LORENTZ-TRANSFORMATION INTO LAB FRAME FOR DELTA1
               E1CM    = SQRT (dm3**2 + PX3**2 + PY3**2 + PZ3**2)
               P1BETA  = PX3*BETAX + PY3*BETAY + PZ3*BETAZ
               TRANSF  = GAMMA * ( GAMMA * P1BETA / (GAMMA + 1) + E1CM )
               Pt1i1 = BETAX * TRANSF + PX3
               Pt2i1 = BETAY * TRANSF + PY3
               Pt3i1 = BETAZ * TRANSF + PZ3
              Eti1   = DM3
              lbi1=lb(i1)
 * (2) for the lambda/sigma
                 E2CM    = SQRT (dm4**2 + PX4**2 + PY4**2 + PZ4**2)
                 P2BETA  = PX4*BETAX+PY4*BETAY+PZ4*BETAZ
                 TRANSF  = GAMMA * (GAMMA*P2BETA / (GAMMA + 1.) + E2CM)
                 Pt1I2 = BETAX * TRANSF + PX4
                 Pt2I2 = BETAY * TRANSF + PY4
                 Pt3I2 = BETAZ * TRANSF + PZ4
               EtI2   = DM4
               lbi2=lb(i2)
 * GET the kaon'S MOMENTUM AND COORDINATES IN NUCLEUS-NUCLEUS CMS. FRAME
                 EPCM=SQRT(aka**2+PPX**2+PPY**2+PPZ**2)
                 PPBETA=PPX*BETAX+PPY*BETAY+PPZ*BETAZ
                 TRANSF=GAMMA*(GAMMA*PPBETA/(GAMMA+1.)+EPCM)
                 PPION(1,NNN,IRUN)=BETAX*TRANSF+PPX
                 PPION(2,NNN,IRUN)=BETAY*TRANSF+PPY
                 PPION(3,NNN,IRUN)=BETAZ*TRANSF+PPZ
 clin-5/2008
                 dppion(nnn,irun)=dpertp(i1)*dpertp(i2)
 clin-5/2008
 c2003        X01 = 1.0 - 2.0 * RANART(NSEED)
 c            Y01 = 1.0 - 2.0 * RANART(NSEED)
 c            Z01 = 1.0 - 2.0 * RANART(NSEED)
 c        IF ((X01*X01+Y01*Y01+Z01*Z01) .GT. 1.0) GOTO 2003
 c                RPION(1,NNN,IRUN)=R(1,I1)+0.5*x01
 c                RPION(2,NNN,IRUN)=R(2,I1)+0.5*y01
 c                RPION(3,NNN,IRUN)=R(3,I1)+0.5*z01
                 RPION(1,NNN,IRUN)=R(1,I1)
                 RPION(2,NNN,IRUN)=R(2,I1)
                 RPION(3,NNN,IRUN)=R(3,I1)
 c
 * assign the nucleon/delta and lambda/sigma to i1 or i2 to keep the 
 * leadng particle behaviour
 C              if((pt1i1*px1+pt2i1*py1+pt3i1*pz1).gt.0)then
               p(1,i1)=pt1i1
               p(2,i1)=pt2i1
               p(3,i1)=pt3i1
               e(i1)=eti1
               lb(i1)=lbi1
               p(1,i2)=pt1i2
               p(2,i2)=pt2i2
               p(3,i2)=pt3i2
               e(i2)=eti2
               lb(i2)=lbi2
                 PX1     = P(1,I1)
                 PY1     = P(2,I1)
                 PZ1     = P(3,I1)
               EM1       = E(I1)
                 ID(I1)  = 2
                 ID(I2)  = 2
                 ID1     = ID(I1)
               go to 90005
 * FOR THE NN-->Delta+Delta+rho PROCESS, FIND MOMENTUM OF THE FINAL 
 * PARTICLES IN THE NUCLEUS-NUCLEUS CMS.
 307     CONTINUE
            NTRY1=0
 125        CALL DDrho(SRT,ISEED,PX3,PY3,PZ3,DM3,PX4,PY4,PZ4,DM4,
      &  PPX,PPY,PPZ,amrho,icou1)
        NTRY1=NTRY1+1
        if((icou1.lt.0).AND.(NTRY1.LE.20))GO TO 125
 C       if(icou1.lt.0)return
 * ROTATE THE MOMENTA OF PARTICLES IN THE CMS OF P1+P2
        CALL ROTATE(PX,PY,PZ,PX3,PY3,PZ3)
        CALL ROTATE(PX,PY,PZ,PX4,PY4,PZ4)
        CALL ROTATE(PX,PY,PZ,PPX,PPY,PPZ)
                 NNN=NNN+1
               arho=amrho
 * DETERMINE THE CHARGE STATES OF PARTICLES IN THE FINAL STATE
 * (1) FOR P+P
               XDIR=RANART(NSEED)
                 IF(LB(I1)*LB(I2).EQ.1)THEN
                 IF(XDIR.Le.0.2)then
 * (1.1)P+P-->D+++D0+rho(0)
                 LPION(NNN,IRUN)=26
                 EPION(NNN,IRUN)=Arho
               LB(I1)=9
               LB(I2)=7
        GO TO 2051
                 ENDIF
 * (1.2)P+P -->D++D+rho(0)
                 IF((XDIR.LE.0.4).AND.(XDIR.GT.0.2))THEN
                 LPION(NNN,IRUN)=26
                 EPION(NNN,IRUN)=Arho
                 LB(I1)=8
                 LB(I2)=8
        GO TO 2051
               ENDIF 
 * (1.3)P+P-->D+++D+arho(-)
                 IF((XDIR.LE.0.6).AND.(XDIR.GT.0.4))THEN
                 LPION(NNN,IRUN)=25
                 EPION(NNN,IRUN)=Arho
                 LB(I1)=9
                 LB(I2)=8
        GO TO 2051
               ENDIF 
                 IF((XDIR.LE.0.8).AND.(XDIR.GT.0.6))THEN
                 LPION(NNN,IRUN)=27
                 EPION(NNN,IRUN)=Arho
                 LB(I1)=9
                 LB(I2)=6
        GO TO 2051
               ENDIF 
                 IF(XDIR.GT.0.8)THEN
                 LPION(NNN,IRUN)=27
                 EPION(NNN,IRUN)=Arho
                 LB(I1)=7
                 LB(I2)=8
        GO TO 2051
               ENDIF 
                ENDIF
 * (2)FOR N+N
                 IF(iabs(LB(I1)).EQ.2.AND.iabs(LB(I2)).EQ.2)THEN
                 IF(XDIR.Le.0.2)then
 * (2.1)N+N-->D++D-+rho(0)
                 LPION(NNN,IRUN)=26
                 EPION(NNN,IRUN)=Arho
               LB(I1)=6
               LB(I2)=7
        GO TO 2051
                 ENDIF
 * (2.2)N+N -->D+++D-+rho(-)
                 IF((XDIR.LE.0.4).AND.(XDIR.GT.0.2))THEN
                 LPION(NNN,IRUN)=25
                 EPION(NNN,IRUN)=Arho
                 LB(I1)=6
                 LB(I2)=9
        GO TO 2051
               ENDIF 
 * (2.3)P+P-->D0+D-+rho(+)
                 IF((XDIR.GT.0.4).AND.(XDIR.LE.0.6))THEN
                 LPION(NNN,IRUN)=27
                 EPION(NNN,IRUN)=Arho
                 LB(I1)=9
                 LB(I2)=8
        GO TO 2051
               ENDIF 
 * (2.4)P+P-->D0+D0+rho(0)
                 IF((XDIR.GT.0.6).AND.(XDIR.LE.0.8))THEN
                 LPION(NNN,IRUN)=26
                 EPION(NNN,IRUN)=Arho
                 LB(I1)=7
                 LB(I2)=7
        GO TO 2051
               ENDIF 
 * (2.5)P+P-->D0+D++rho(-)
                 IF(XDIR.GT.0.8)THEN
                 LPION(NNN,IRUN)=25
                 EPION(NNN,IRUN)=Arho
                 LB(I1)=7
                 LB(I2)=8
        GO TO 2051
               ENDIF 
               ENDIF
 * (3)FOR N+P
                 IF(LB(I1)*LB(I2).EQ.2)THEN
                 IF(XDIR.Le.0.17)then
 * (3.1)N+P-->D+++D-+rho(0)
                 LPION(NNN,IRUN)=25
                 EPION(NNN,IRUN)=Arho
               LB(I1)=6
               LB(I2)=9
        GO TO 2051
                 ENDIF
 * (3.2)N+P -->D+++D0+rho(-)
                 IF((XDIR.LE.0.34).AND.(XDIR.GT.0.17))THEN
                 LPION(NNN,IRUN)=25
                 EPION(NNN,IRUN)=Arho
                 LB(I1)=7
                 LB(I2)=9
        GO TO 2051
               ENDIF 
 * (3.3)N+P-->D++D-+rho(+)
                 IF((XDIR.GT.0.34).AND.(XDIR.LE.0.51))THEN
                 LPION(NNN,IRUN)=27
                 EPION(NNN,IRUN)=Arho
                 LB(I1)=7
                 LB(I2)=8
        GO TO 2051
               ENDIF 
 * (3.4)N+P-->D++D++rho(-)
                 IF((XDIR.GT.0.51).AND.(XDIR.LE.0.68))THEN
                 LPION(NNN,IRUN)=25
                 EPION(NNN,IRUN)=Arho
                 LB(I1)=8
                 LB(I2)=8
        GO TO 2051
               ENDIF 
 * (3.5)N+P-->D0+D++rho(0)
                 IF((XDIR.GT.0.68).AND.(XDIR.LE.0.85))THEN
                 LPION(NNN,IRUN)=26
                 EPION(NNN,IRUN)=Arho
                 LB(I1)=7
                 LB(I2)=8
        GO TO 2051
               ENDIF 
 * (3.6)N+P-->D0+D0+rho(+)
                 IF(XDIR.GT.0.85)THEN
                 LPION(NNN,IRUN)=27
                 EPION(NNN,IRUN)=Arho
                 LB(I1)=7
                 LB(I2)=7
               ENDIF 
                 ENDIF
 * FIND THE MOMENTUM OF PARTICLES IN THE FINAL STATE IN THE NUCLEUS-
 * NUCLEUS CMS. FRAME 
 *             LORENTZ-TRANSFORMATION INTO LAB FRAME FOR DELTA1
 2051          E1CM    = SQRT (dm3**2 + PX3**2 + PY3**2 + PZ3**2)
               P1BETA  = PX3*BETAX + PY3*BETAY + PZ3*BETAZ
               TRANSF  = GAMMA * ( GAMMA * P1BETA / (GAMMA + 1) + E1CM )
               Pt1i1 = BETAX * TRANSF + PX3
               Pt2i1 = BETAY * TRANSF + PY3
               Pt3i1 = BETAZ * TRANSF + PZ3
              Eti1   = DM3
 c
              if(ianti.eq.1 .and. lb(i1).ge.1 .and. lb(i2).ge.1)then
                lb(i1) = -lb(i1)
                lb(i2) = -lb(i2)
                 if(LPION(NNN,IRUN) .eq. 25)then
                   LPION(NNN,IRUN)=27
                 elseif(LPION(NNN,IRUN) .eq. 27)then
                   LPION(NNN,IRUN)=25
                 endif
                endif
 c
              lb1=lb(i1)
 * FOR DELTA2
                 E2CM    = SQRT (dm4**2 + PX4**2 + PY4**2 + PZ4**2)
                 P2BETA  = PX4*BETAX+PY4*BETAY+PZ4*BETAZ
                 TRANSF  = GAMMA * (GAMMA*P2BETA / (GAMMA + 1.) + E2CM)
                 Pt1I2 = BETAX * TRANSF + PX4
                 Pt2I2 = BETAY * TRANSF + PY4
                 Pt3I2 = BETAZ * TRANSF + PZ4
               EtI2   = DM4
               lb2=lb(i2)
 * assign delta1 and delta2 to i1 or i2 to keep the leadng particle
 * behaviour
 C              if((pt1i1*px1+pt2i1*py1+pt3i1*pz1).gt.0)then
               p(1,i1)=pt1i1
               p(2,i1)=pt2i1
               p(3,i1)=pt3i1
               e(i1)=eti1
               lb(i1)=lb1
               p(1,i2)=pt1i2
               p(2,i2)=pt2i2
               p(3,i2)=pt3i2
               e(i2)=eti2
               lb(i2)=lb2
                 PX1     = P(1,I1)
                 PY1     = P(2,I1)
                 PZ1     = P(3,I1)
               EM1       = E(I1)
                 ID(I1)  = 2
                 ID(I2)  = 2
                 ID1     = ID(I1)
                 IBLOCK=44
 * GET rho'S MOMENTUM AND COORDINATES IN NUCLEUS-NUCLEUS CMS. FRAME
                 EPCM=SQRT(EPION(NNN,IRUN)**2+PPX**2+PPY**2+PPZ**2)
                 PPBETA=PPX*BETAX+PPY*BETAY+PPZ*BETAZ
                 TRANSF=GAMMA*(GAMMA*PPBETA/(GAMMA+1.)+EPCM)
                 PPION(1,NNN,IRUN)=BETAX*TRANSF+PPX
                 PPION(2,NNN,IRUN)=BETAY*TRANSF+PPY
                 PPION(3,NNN,IRUN)=BETAZ*TRANSF+PPZ
 clin-5/2008:
                 dppion(nnn,irun)=dpertp(i1)*dpertp(i2)
 clin-5/2008:
 c2004        X01 = 1.0 - 2.0 * RANART(NSEED)
 c            Y01 = 1.0 - 2.0 * RANART(NSEED)
 c            Z01 = 1.0 - 2.0 * RANART(NSEED)
 c        IF ((X01*X01+Y01*Y01+Z01*Z01) .GT. 1.0) GOTO 2004
 c                RPION(1,NNN,IRUN)=R(1,I1)+0.5*x01
 c                RPION(2,NNN,IRUN)=R(2,I1)+0.5*y01
 c                RPION(3,NNN,IRUN)=R(3,I1)+0.5*z01
                 RPION(1,NNN,IRUN)=R(1,I1)
                 RPION(2,NNN,IRUN)=R(2,I1)
                 RPION(3,NNN,IRUN)=R(3,I1)
 c
               go to 90005
 * FOR THE NN-->N+N+rho PROCESS, FIND MOMENTUM OF THE FINAL 
 * PARTICLES IN THE NUCLEUS-NUCLEUS CMS.
 308     CONTINUE
            NTRY1=0
 126        CALL pprho(SRT,ISEED,PX3,PY3,PZ3,DM3,PX4,PY4,PZ4,DM4,
      &  PPX,PPY,PPZ,amrho,icou1)
        NTRY1=NTRY1+1
        if((icou1.lt.0).AND.(NTRY1.LE.20))GO TO 126
 C       if(icou1.lt.0)return
 * ROTATE THE MOMENTA OF PARTICLES IN THE CMS OF P1+P2
        CALL ROTATE(PX,PY,PZ,PX3,PY3,PZ3)
        CALL ROTATE(PX,PY,PZ,PX4,PY4,PZ4)
        CALL ROTATE(PX,PY,PZ,PPX,PPY,PPZ)
                 NNN=NNN+1
               arho=amrho
 * DETERMINE THE CHARGE STATES OF PARTICLES IN THE FINAL STATE
 * (1) FOR P+P
               XDIR=RANART(NSEED)
                 IF(LB(I1)*LB(I2).EQ.1)THEN
                 IF(XDIR.Le.0.5)then
 * (1.1)P+P-->P+P+rho(0)
                 LPION(NNN,IRUN)=26
                 EPION(NNN,IRUN)=Arho
               LB(I1)=1
               LB(I2)=1
        GO TO 2052
                 Else
 * (1.2)P+P -->p+n+rho(+)
                 LPION(NNN,IRUN)=27
                 EPION(NNN,IRUN)=Arho
                 LB(I1)=1
                 LB(I2)=2
        GO TO 2052
               ENDIF 
               endif
 * (2)FOR N+N
                 IF(iabs(LB(I1)).EQ.2.AND.iabs(LB(I2)).EQ.2)THEN
                 IF(XDIR.Le.0.5)then
 * (2.1)N+N-->N+N+rho(0)
                 LPION(NNN,IRUN)=26
                 EPION(NNN,IRUN)=Arho
               LB(I1)=2
               LB(I2)=2
        GO TO 2052
                 Else
 * (2.2)N+N -->N+P+rho(-)
                 LPION(NNN,IRUN)=25
                 EPION(NNN,IRUN)=Arho
                 LB(I1)=1
                 LB(I2)=2
        GO TO 2052
               ENDIF 
               endif
 * (3)FOR N+P
                 IF(LB(I1)*LB(I2).EQ.2)THEN
                 IF(XDIR.Le.0.33)then
 * (3.1)N+P-->N+P+rho(0)
                 LPION(NNN,IRUN)=26
                 EPION(NNN,IRUN)=Arho
               LB(I1)=1
               LB(I2)=2
        GO TO 2052
 * (3.2)N+P -->P+P+rho(-)
                 else IF((XDIR.LE.0.67).AND.(XDIR.GT.0.34))THEN
                 LPION(NNN,IRUN)=25
                 EPION(NNN,IRUN)=Arho
                 LB(I1)=1
                 LB(I2)=1
        GO TO 2052
               Else 
 * (3.3)N+P-->N+N+rho(+)
                 LPION(NNN,IRUN)=27
                 EPION(NNN,IRUN)=Arho
                 LB(I1)=2
                 LB(I2)=2
        GO TO 2052
               ENDIF 
               endif
 * FIND THE MOMENTUM OF PARTICLES IN THE FINAL STATE IN THE NUCLEUS-
 * NUCLEUS CMS. FRAME 
 *             LORENTZ-TRANSFORMATION INTO LAB FRAME FOR DELTA1
 2052          E1CM    = SQRT (dm3**2 + PX3**2 + PY3**2 + PZ3**2)
               P1BETA  = PX3*BETAX + PY3*BETAY + PZ3*BETAZ
               TRANSF  = GAMMA * ( GAMMA * P1BETA / (GAMMA + 1) + E1CM )
               Pt1i1 = BETAX * TRANSF + PX3
               Pt2i1 = BETAY * TRANSF + PY3
               Pt3i1 = BETAZ * TRANSF + PZ3
              Eti1   = DM3
 c
               if(ianti.eq.1 .and. lb(i1).ge.1 .and. lb(i2).ge.1)then
                lb(i1) = -lb(i1)
                lb(i2) = -lb(i2)
                 if(LPION(NNN,IRUN) .eq. 25)then
                   LPION(NNN,IRUN)=27
                 elseif(LPION(NNN,IRUN) .eq. 27)then
                   LPION(NNN,IRUN)=25
                 endif
                endif
 c
              lb1=lb(i1)
 * FOR p2
                 E2CM    = SQRT (dm4**2 + PX4**2 + PY4**2 + PZ4**2)
                 P2BETA  = PX4*BETAX+PY4*BETAY+PZ4*BETAZ
                 TRANSF  = GAMMA * (GAMMA*P2BETA / (GAMMA + 1.) + E2CM)
                 Pt1I2 = BETAX * TRANSF + PX4
                 Pt2I2 = BETAY * TRANSF + PY4
                 Pt3I2 = BETAZ * TRANSF + PZ4
               EtI2   = DM4
               lb2=lb(i2)
 * assign p1 and p2 to i1 or i2 to keep the leadng particle
 * behaviour
 C              if((pt1i1*px1+pt2i1*py1+pt3i1*pz1).gt.0)then
               p(1,i1)=pt1i1
               p(2,i1)=pt2i1
               p(3,i1)=pt3i1
               e(i1)=eti1
               lb(i1)=lb1
               p(1,i2)=pt1i2
               p(2,i2)=pt2i2
               p(3,i2)=pt3i2
               e(i2)=eti2
               lb(i2)=lb2
                 PX1     = P(1,I1)
                 PY1     = P(2,I1)
                 PZ1     = P(3,I1)
               EM1       = E(I1)
                 ID(I1)  = 2
                 ID(I2)  = 2
                 ID1     = ID(I1)
                 IBLOCK=45
 * GET rho'S MOMENTUM AND COORDINATES IN NUCLEUS-NUCLEUS CMS. FRAME
                 EPCM=SQRT(EPION(NNN,IRUN)**2+PPX**2+PPY**2+PPZ**2)
                 PPBETA=PPX*BETAX+PPY*BETAY+PPZ*BETAZ
                 TRANSF=GAMMA*(GAMMA*PPBETA/(GAMMA+1.)+EPCM)
                 PPION(1,NNN,IRUN)=BETAX*TRANSF+PPX
                 PPION(2,NNN,IRUN)=BETAY*TRANSF+PPY
                 PPION(3,NNN,IRUN)=BETAZ*TRANSF+PPZ
 clin-5/2008:
                 dppion(nnn,irun)=dpertp(i1)*dpertp(i2)
 clin-5/2008:
 c2005        X01 = 1.0 - 2.0 * RANART(NSEED)
 c            Y01 = 1.0 - 2.0 * RANART(NSEED)
 c            Z01 = 1.0 - 2.0 * RANART(NSEED)
 c        IF ((X01*X01+Y01*Y01+Z01*Z01) .GT. 1.0) GOTO 2005
 c                RPION(1,NNN,IRUN)=R(1,I1)+0.5*x01
 c                RPION(2,NNN,IRUN)=R(2,I1)+0.5*y01
 c                RPION(3,NNN,IRUN)=R(3,I1)+0.5*z01
                 RPION(1,NNN,IRUN)=R(1,I1)
                 RPION(2,NNN,IRUN)=R(2,I1)
                 RPION(3,NNN,IRUN)=R(3,I1)
 c
               go to 90005
 * FOR THE NN-->p+p+omega PROCESS, FIND MOMENTUM OF THE FINAL 
 * PARTICLES IN THE NUCLEUS-NUCLEUS CMS.
 309     CONTINUE
            NTRY1=0
 138        CALL ppomga(SRT,ISEED,PX3,PY3,PZ3,DM3,PX4,PY4,PZ4,DM4,
      &  PPX,PPY,PPZ,icou1)
        NTRY1=NTRY1+1
        if((icou1.lt.0).AND.(NTRY1.LE.20))GO TO 138
 C       if(icou1.lt.0)return
 * ROTATE THE MOMENTA OF PARTICLES IN THE CMS OF P1+P2
        CALL ROTATE(PX,PY,PZ,PX3,PY3,PZ3)
        CALL ROTATE(PX,PY,PZ,PX4,PY4,PZ4)
        CALL ROTATE(PX,PY,PZ,PPX,PPY,PPZ)
                 NNN=NNN+1
               aomega=0.782
 * DETERMINE THE CHARGE STATES OF PARTICLES IN THE FINAL STATE
 * (1) FOR P+P
                 IF(LB(I1)*LB(I2).EQ.1)THEN
 * (1.1)P+P-->P+P+omega(0)
                 LPION(NNN,IRUN)=28
                 EPION(NNN,IRUN)=Aomega
               LB(I1)=1
               LB(I2)=1
        GO TO 2053
                 ENDIF
 * (2)FOR N+N
                 IF(iabs(LB(I1)).EQ.2.AND.iabs(LB(I2)).EQ.2)THEN
 * (2.1)N+N-->N+N+omega(0)
                 LPION(NNN,IRUN)=28
                 EPION(NNN,IRUN)=Aomega
               LB(I1)=2
               LB(I2)=2
        GO TO 2053
                 ENDIF
 * (3)FOR N+P
                 IF(LB(I1)*LB(I2).EQ.2)THEN
 * (3.1)N+P-->N+P+omega(0)
                 LPION(NNN,IRUN)=28
                 EPION(NNN,IRUN)=Aomega
               LB(I1)=1
               LB(I2)=2
        GO TO 2053
                 ENDIF
 * FIND THE MOMENTUM OF PARTICLES IN THE FINAL STATE IN THE NUCLEUS-
 * NUCLEUS CMS. FRAME 
 *             LORENTZ-TRANSFORMATION INTO LAB FRAME FOR DELTA1
 2053          E1CM    = SQRT (dm3**2 + PX3**2 + PY3**2 + PZ3**2)
               P1BETA  = PX3*BETAX + PY3*BETAY + PZ3*BETAZ
               TRANSF  = GAMMA * ( GAMMA * P1BETA / (GAMMA + 1) + E1CM )
               Pt1i1 = BETAX * TRANSF + PX3
               Pt2i1 = BETAY * TRANSF + PY3
               Pt3i1 = BETAZ * TRANSF + PZ3
              Eti1   = DM3
               if(ianti.eq.1 .and. lb(i1).ge.1 .and. lb(i2).ge.1)then
                lb(i1) = -lb(i1)
                lb(i2) = -lb(i2)
                endif
              lb1=lb(i1)
 * FOR DELTA2
                 E2CM    = SQRT (dm4**2 + PX4**2 + PY4**2 + PZ4**2)
                 P2BETA  = PX4*BETAX+PY4*BETAY+PZ4*BETAZ
                 TRANSF  = GAMMA * (GAMMA*P2BETA / (GAMMA + 1.) + E2CM)
                 Pt1I2 = BETAX * TRANSF + PX4
                 Pt2I2 = BETAY * TRANSF + PY4
                 Pt3I2 = BETAZ * TRANSF + PZ4
               EtI2   = DM4
                 lb2=lb(i2)
 * assign delta1 and delta2 to i1 or i2 to keep the leadng particle
 * behaviour
 C              if((pt1i1*px1+pt2i1*py1+pt3i1*pz1).gt.0)then
               p(1,i1)=pt1i1
               p(2,i1)=pt2i1
               p(3,i1)=pt3i1
               e(i1)=eti1
               lb(i1)=lb1
               p(1,i2)=pt1i2
               p(2,i2)=pt2i2
               p(3,i2)=pt3i2
               e(i2)=eti2
               lb(i2)=lb2
                 PX1     = P(1,I1)
                 PY1     = P(2,I1)
                 PZ1     = P(3,I1)
               EM1       = E(I1)
                 ID(I1)  = 2
                 ID(I2)  = 2
                 ID1     = ID(I1)
                 IBLOCK=46
 * GET omega'S MOMENTUM AND COORDINATES IN NUCLEUS-NUCLEUS CMS. FRAME
                 EPCM=SQRT(EPION(NNN,IRUN)**2+PPX**2+PPY**2+PPZ**2)
                 PPBETA=PPX*BETAX+PPY*BETAY+PPZ*BETAZ
                 TRANSF=GAMMA*(GAMMA*PPBETA/(GAMMA+1.)+EPCM)
                 PPION(1,NNN,IRUN)=BETAX*TRANSF+PPX
                 PPION(2,NNN,IRUN)=BETAY*TRANSF+PPY
                 PPION(3,NNN,IRUN)=BETAZ*TRANSF+PPZ
 clin-5/2008:
                 dppion(nnn,irun)=dpertp(i1)*dpertp(i2)
 clin-5/2008:
 c2006        X01 = 1.0 - 2.0 * RANART(NSEED)
 c            Y01 = 1.0 - 2.0 * RANART(NSEED)
 c            Z01 = 1.0 - 2.0 * RANART(NSEED)
 c        IF ((X01*X01+Y01*Y01+Z01*Z01) .GT. 1.0) GOTO 2006
 c                RPION(1,NNN,IRUN)=R(1,I1)+0.5*x01
 c                RPION(2,NNN,IRUN)=R(2,I1)+0.5*y01
 c                RPION(3,NNN,IRUN)=R(3,I1)+0.5*z01
                     RPION(1,NNN,IRUN)=R(1,I1)
                     RPION(2,NNN,IRUN)=R(2,I1)
                     RPION(3,NNN,IRUN)=R(3,I1)
 c
               go to 90005
 * change phase space density FOR NUCLEONS AFTER THE PROCESS
 
 clin-10/25/02-comment out following, since there is no path to it:
 clin-8/16/02 used before set
 c     IX1,IY1,IZ1,IPX1,IPY1,IPZ1, IX2,IY2,IZ2,IPX2,IPY2,IPZ2:
 c                if ((abs(ix1).le.mx) .and. (abs(iy1).le.my) .and.
 c     &              (abs(iz1).le.mz)) then
 c                  ipx1p = nint(p(1,i1)/dpx)
 c                  ipy1p = nint(p(2,i1)/dpy)
 c                  ipz1p = nint(p(3,i1)/dpz)
 c                  if ((ipx1p.ne.ipx1) .or. (ipy1p.ne.ipy1) .or.
 c     &                (ipz1p.ne.ipz1)) then
 c                    if ((abs(ipx1).le.mpx) .and. (abs(ipy1).le.my)
 c     &                .and. (ipz1.ge.-mpz) .and. (ipz1.le.mpzp))
 c     &                f(ix1,iy1,iz1,ipx1,ipy1,ipz1) =
 c     &                f(ix1,iy1,iz1,ipx1,ipy1,ipz1) - 1.
 c                    if ((abs(ipx1p).le.mpx) .and. (abs(ipy1p).le.my)
 c     &                .and. (ipz1p.ge.-mpz).and. (ipz1p.le.mpzp))
 c     &                f(ix1,iy1,iz1,ipx1p,ipy1p,ipz1p) =
 c     &                f(ix1,iy1,iz1,ipx1p,ipy1p,ipz1p) + 1.
 c                  end if
 c                end if
 c                if ((abs(ix2).le.mx) .and. (abs(iy2).le.my) .and.
 c     &              (abs(iz2).le.mz)) then
 c                  ipx2p = nint(p(1,i2)/dpx)
 c                  ipy2p = nint(p(2,i2)/dpy)
 c                  ipz2p = nint(p(3,i2)/dpz)
 c                  if ((ipx2p.ne.ipx2) .or. (ipy2p.ne.ipy2) .or.
 c     &                (ipz2p.ne.ipz2)) then
 c                    if ((abs(ipx2).le.mpx) .and. (abs(ipy2).le.my)
 c     &                .and. (ipz2.ge.-mpz) .and. (ipz2.le.mpzp))
 c     &                f(ix2,iy2,iz2,ipx2,ipy2,ipz2) =
 c     &                f(ix2,iy2,iz2,ipx2,ipy2,ipz2) - 1.
 c                    if ((abs(ipx2p).le.mpx) .and. (abs(ipy2p).le.my)
 c     &                .and. (ipz2p.ge.-mpz) .and. (ipz2p.le.mpzp))
 c     &                f(ix2,iy2,iz2,ipx2p,ipy2p,ipz2p) =
 c     &                f(ix2,iy2,iz2,ipx2p,ipy2p,ipz2p) + 1.
 c                  end if
 c                end if
 clin-10/25/02-end
 
 90005       continue
        RETURN
 *-----------------------------------------------------------------------
 *COM: SET THE NEW MOMENTUM COORDINATES
 107     IF(PX .EQ. 0.0 .AND. PY .EQ. 0.0) THEN
         T2 = 0.0
       ELSE
         T2=ATAN2(PY,PX)
       END IF
       S1   = 1.0 - C1**2 
        IF(S1.LE.0)S1=0
        S1=SQRT(S1)
 
 clin-9/2012: check argument in sqrt():
        scheck=1.0 - C2**2
        if(scheck.lt.0) then
           write(99,*) 'scheck3: ', scheck
           scheck=0.
        endif
        S2=SQRT(scheck)
 c       S2  =  SQRT( 1.0 - C2**2 )
 
       CT1  = COS(T1)
       ST1  = SIN(T1)
       CT2  = COS(T2)
       ST2  = SIN(T2)
       PZ   = PR * ( C1*C2 - S1*S2*CT1 )
       SS   = C2 * S1 * CT1  +  S2 * C1
       PX   = PR * ( SS*CT2 - S1*ST1*ST2 )
       PY   = PR * ( SS*ST2 + S1*ST1*CT2 )
       RETURN
       END
 clin-5/2008 CRNN over
 
 **********************************
 **********************************
 *                                                                      *
 *                                                                      *
 c
       SUBROUTINE CRPP(PX,PY,PZ,SRT,I1,I2,IBLOCK,
      &ppel,ppin,spprho,ipp)
 *     PURPOSE:                                                         *
 *             DEALING WITH PION-PION COLLISIONS                        *
 *     NOTE   :                                                         *
 *           VALID ONLY FOR PION-PION-DISTANCES LESS THAN 2.5 FM        *
 *     QUANTITIES:                                                 *
 *           PX,PY,PZ - MOMENTUM COORDINATES OF ONE PARTICLE IN CM FRAME*
 *           SRT      - SQRT OF S                                       *
 *           IBLOCK   - THE INFORMATION BACK                            *
 *                     6-> Meson+Meson elastic
 *                     66-> Meson+meson-->K+K-
 **********************************
       PARAMETER (MAXSTR=150001,MAXR=1,AMN=0.939457,
      1     AMP=0.93828,AP1=0.13496,
      2 AP2=0.13957,AM0=1.232,PI=3.1415926,CUTOFF=1.8966,AVMASS=0.9383)
       PARAMETER      (AKA=0.498,aks=0.895)
       parameter     (MX=4,MY=4,MZ=8,MPX=4,MPY=4,mpz=10,mpzp=10)
       COMMON /AA/ R(3,MAXSTR)
 cc      SAVE /AA/
       COMMON /BB/ P(3,MAXSTR)
 cc      SAVE /BB/
       COMMON /CC/ E(MAXSTR)
 cc      SAVE /CC/
       COMMON /EE/ ID(MAXSTR),LB(MAXSTR)
 cc      SAVE /EE/
       common/input1/ MASSPR,MASSTA,ISEED,IAVOID,DT
 cc      SAVE /input1/
       common/ppb1/ene,factr2(6),fsum,ppinnb,s,wtot
 cc      SAVE /ppb1/
       common/ppmm/pprr,ppee,pppe,rpre,xopoe,rree
 cc      SAVE /ppmm/
       COMMON/RNDF77/NSEED
 cc      SAVE /RNDF77/
       SAVE   
 
       lb1i=lb(i1)
       lb2i=lb(i2)
 
        PX0=PX
        PY0=PY
        PZ0=PZ
         iblock=1
 *-----------------------------------------------------------------------
 * check Meson+Meson inelastic collisions
 clin-9/28/00
 c        if((srt.gt.1.).and.(ppin/(ppin+ppel).gt.RANART(NSEED)))then
 c        iblock=66
 c        e(i1)=0.498
 c        e(i2)=0.498
 c        lb(i1)=21
 c        lb(i2)=23
 c        go to 10
 clin-11/07/00
 c        if(srt.gt.1.and.(ppin/(ppin+ppel)).gt.RANART(NSEED)) then
 clin-4/03/02
         if(srt.gt.(2*aka).and.(ppin/(ppin+ppel)).gt.RANART(NSEED)) then
 c        if(ppin/(ppin+ppel).gt.RANART(NSEED)) then
 clin-10/08/00
 
            ranpi=RANART(NSEED)
            if((pprr/ppin).ge.ranpi) then
 
 c     1) pi pi <-> rho rho:
               call pi2ro2(i1,i2,lbb1,lbb2,ei1,ei2,iblock,iseed)
 
 clin-4/03/02 eta equilibration:
            elseif((pprr+ppee)/ppin.ge.ranpi) then
 c     4) pi pi <-> eta eta:
               call pi2et2(i1,i2,lbb1,lbb2,ei1,ei2,iblock,iseed)
            elseif(((pprr+ppee+pppe)/ppin).ge.ranpi) then
 c     5) pi pi <-> pi eta:
               call pi3eta(i1,i2,lbb1,lbb2,ei1,ei2,iblock,iseed)
            elseif(((pprr+ppee+pppe+rpre)/ppin).ge.ranpi) then
 c     6) rho pi <-> pi eta:
               call rpiret(i1,i2,lbb1,lbb2,ei1,ei2,iblock,iseed)
            elseif(((pprr+ppee+pppe+rpre+xopoe)/ppin).ge.ranpi) then
 c     7) omega pi <-> omega eta:
               call opioet(i1,i2,lbb1,lbb2,ei1,ei2,iblock,iseed)
            elseif(((pprr+ppee+pppe+rpre+xopoe+rree)
      1             /ppin).ge.ranpi) then
 c     8) rho rho <-> eta eta:
               call ro2et2(i1,i2,lbb1,lbb2,ei1,ei2,iblock,iseed)
 clin-4/03/02-end
 
 c     2) BBbar production:
            elseif(((pprr+ppee+pppe+rpre+xopoe+rree+ppinnb)/ppin)
      1             .ge.ranpi) then
 
               call bbarfs(lbb1,lbb2,ei1,ei2,iblock,iseed)
 c     3) KKbar production:
            else
               iblock=66
               ei1=aka
               ei2=aka
               lbb1=21
               lbb2=23
 clin-11/07/00 pi rho -> K* Kbar and K*bar K productions:
               lb1=lb(i1)
               lb2=lb(i2)
 clin-2/13/03 include omega the same as rho, eta the same as pi:
 c        if(((lb1.ge.3.and.lb1.le.5).and.(lb2.ge.25.and.lb2.le.27))
 c     1  .or.((lb2.ge.3.and.lb2.le.5).and.(lb1.ge.25.and.lb1.le.27)))
         if( ( (lb1.eq.0.or.(lb1.ge.3.and.lb1.le.5))
      1       .and.(lb2.ge.25.and.lb2.le.28))
      2       .or. ( (lb2.eq.0.or.(lb2.ge.3.and.lb2.le.5))
      3       .and.(lb1.ge.25.and.lb1.le.28))) then
            ei1=aks
            ei2=aka
            if(RANART(NSEED).ge.0.5) then
               iblock=366
               lbb1=30
               lbb2=21
            else
               iblock=367
               lbb1=-30
               lbb2=23
            endif
         endif
 clin-11/07/00-end
            endif
 clin-ppbar-8/25/00
            e(i1)=ei1
            e(i2)=ei2
            lb(i1)=lbb1
            lb(i2)=lbb2
 clin-10/08/00-end
 
        else
 cbzdbg10/15/99
 c.....for meson+meson elastic srt.le.2Mk, if not pi+pi collision return
          if ((lb(i1).lt.3.or.lb(i1).gt.5).and.
      &        (lb(i2).lt.3.or.lb(i2).gt.5)) return
 cbzdbg10/15/99 end
 
 * check Meson+Meson elastic collisions
         IBLOCK=6
 * direct process
        if(ipp.eq.1.or.ipp.eq.4.or.ipp.eq.6)go to 10
        if(spprho/ppel.gt.RANART(NSEED))go to 20
        endif
 10      NTAG=0
         EM1=E(I1)
         EM2=E(I2)
 
 *-----------------------------------------------------------------------
 * CALCULATE THE MAGNITUDE OF THE FINAL MOMENTUM THROUGH
 * ENERGY CONSERVATION
           PR2   = (SRT**2 - EM1**2 - EM2**2)**2
      1                - 4.0 * (EM1*EM2)**2
           IF(PR2.LE.0.)PR2=1.e-09
           PR=SQRT(PR2)/(2.*SRT)
           C1   = 1.0 - 2.0 * RANART(NSEED)
           T1   = 2.0 * PI * RANART(NSEED)
           S1   = SQRT( 1.0 - C1**2 )
       CT1  = COS(T1)
       ST1  = SIN(T1)
       PZ   = PR * C1
       PX   = PR * S1*CT1 
       PY   = PR * S1*ST1
 * for isotropic distribution no need to ROTATE THE MOMENTUM
 
 * ROTATE IT 
       CALL ROTATE(PX0,PY0,PZ0,PX,PY,PZ) 
 
       RETURN
 20       continue
        iblock=666
 * treat rho formation in pion+pion collisions
 * calculate the mass and momentum of rho in the nucleus-nucleus frame
        call rhores(i1,i2)
        if(ipp.eq.2)lb(i1)=27
        if(ipp.eq.3)lb(i1)=26
        if(ipp.eq.5)lb(i1)=25
        return       
       END
 **********************************
 **********************************
 *                                                                      *
 *                                                                      *
       SUBROUTINE CRND(IRUN,PX,PY,PZ,SRT,I1,I2,IBLOCK,
      &SIGNN,SIG,sigk,xsk1,xsk2,xsk3,xsk4,xsk5,NT,ipert1)
 *     PURPOSE:                                                         *
 *             DEALING WITH NUCLEON-BARYON RESONANCE COLLISIONS         *
 *     NOTE   :                                                         *
 *           VALID ONLY FOR BARYON-BARYON-DISTANCES LESS THAN 1.32 FM   *
 *           (1.32 = 2 * HARD-CORE-RADIUS [HRC] )                       *
 *     QUANTITIES:                                                 *
 *           PX,PY,PZ - MOMENTUM COORDINATES OF ONE PARTICLE IN CM FRAME*
 *           SRT      - SQRT OF S                                       *
 *           NSTAR =1 INCLUDING N* RESORANCE,ELSE NOT                   *
 *           NDIRCT=1 INCLUDING DIRECT PION PRODUCTION PROCESS         *
 *           IBLOCK   - THE INFORMATION BACK                            *
 *                      0-> COLLISION CANNOT HAPPEN                     *
 *                      1-> N-N ELASTIC COLLISION                       *
 *                      2-> N+N->N+DELTA,OR N+N->N+N* REACTION          *
 *                      3-> N+DELTA->N+N OR N+N*->N+N REACTION          *
 *                      4-> N+N->N+N+PION,DIRTCT PROCESS                *
 *           N12       - IS USED TO SPECIFY BARYON-BARYON REACTION      *
 *                      CHANNELS. M12 IS THE REVERSAL CHANNEL OF N12    *
 *                      N12,                                            *
 *                      M12=1 FOR p+n-->delta(+)+ n                     *
 *                          2     p+n-->delta(0)+ p                     *
 *                          3     p+p-->delta(++)+n                     *
 *                          4     p+p-->delta(+)+p                      *
 *                          5     n+n-->delta(0)+n                      *
 *                          6     n+n-->delta(-)+p                      *
 *                          7     n+p-->N*(0)(1440)+p                   *
 *                          8     n+p-->N*(+)(1440)+n                   *
 *                        9     p+p-->N*(+)(1535)+p                     *
 *                        10    n+n-->N*(0)(1535)+n                     *
 *                         11    n+p-->N*(+)(1535)+n                     *
 *                        12    n+p-->N*(0)(1535)+p
 *                        13    D(++)+D(-)-->N*(+)(1440)+n
 *                         14    D(++)+D(-)-->N*(0)(1440)+p
 *                        15    D(+)+D(0)--->N*(+)(1440)+n
 *                        16    D(+)+D(0)--->N*(0)(1440)+p
 *                        17    D(++)+D(0)-->N*(+)(1535)+p
 *                        18    D(++)+D(-)-->N*(0)(1535)+p
 *                        19    D(++)+D(-)-->N*(+)(1535)+n
 *                        20    D(+)+D(+)-->N*(+)(1535)+p
 *                        21    D(+)+D(0)-->N*(+)(1535)+n
 *                        22    D(+)+D(0)-->N*(0)(1535)+p
 *                        23    D(+)+D(-)-->N*(0)(1535)+n
 *                        24    D(0)+D(0)-->N*(0)(1535)+n
 *                          25    N*(+)(14)+N*(+)(14)-->N*(+)(15)+p
 *                          26    N*(0)(14)+N*(0)(14)-->N*(0)(15)+n
 *                          27    N*(+)(14)+N*(0)(14)-->N*(+)(15)+n
 *                        28    N*(+)(14)+N*(0)(14)-->N*(0)(15)+p
 *                        29    N*(+)(14)+D+-->N*(+)(15)+p
 *                        30    N*(+)(14)+D0-->N*(+)(15)+n
 *                        31    N*(+)(14)+D(-)-->N*(0)(1535)+n
 *                        32    N*(0)(14)+D++--->N*(+)(15)+p
 *                        33    N*(0)(14)+D+--->N*(+)(15)+n
 *                        34    N*(0)(14)+D+--->N*(0)(15)+p
 *                        35    N*(0)(14)+D0-->N*(0)(15)+n
 *                        36    N*(+)(14)+D0--->N*(0)(15)+p
 *                        ++    see the note book for more listing
 **********************************
         PARAMETER (MAXSTR=150001,MAXR=1,AMN=0.939457,
      1  AMP=0.93828,AP1=0.13496,AKA=0.498,APHI=1.020,
      2  AP2=0.13957,AM0=1.232,PI=3.1415926,CUTOFF=1.8966,AVMASS=0.9383)
         parameter     (MX=4,MY=4,MZ=8,MPX=4,MPY=4,mpz=10,mpzp=10)
         parameter (xmd=1.8756,npdmax=10000)
         COMMON /AA/ R(3,MAXSTR)
 cc      SAVE /AA/
         COMMON /BB/ P(3,MAXSTR)
 cc      SAVE /BB/
         COMMON /CC/ E(MAXSTR)
 cc      SAVE /CC/
         COMMON /EE/ ID(MAXSTR),LB(MAXSTR)
 cc      SAVE /EE/
         common /ff/f(-mx:mx,-my:my,-mz:mz,-mpx:mpx,-mpy:mpy,-mpz:mpzp)
 cc      SAVE /ff/
         common /gg/ dx,dy,dz,dpx,dpy,dpz
 cc      SAVE /gg/
         COMMON /INPUT/ NSTAR,NDIRCT,DIR
 cc      SAVE /INPUT/
         COMMON /NN/NNN
 cc      SAVE /NN/
         COMMON /BG/BETAX,BETAY,BETAZ,GAMMA
 cc      SAVE /BG/
         COMMON   /RUN/NUM
 cc      SAVE /RUN/
         COMMON   /PA/RPION(3,MAXSTR,MAXR)
 cc      SAVE /PA/
         COMMON   /PB/PPION(3,MAXSTR,MAXR)
 cc      SAVE /PB/
         COMMON   /PC/EPION(MAXSTR,MAXR)
 cc      SAVE /PC/
         COMMON   /PD/LPION(MAXSTR,MAXR)
 cc      SAVE /PD/
         common/input1/ MASSPR,MASSTA,ISEED,IAVOID,DT
 cc      SAVE /input1/
       common/leadng/lb1,px1,py1,pz1,em1,e1,xfnl,yfnl,zfnl,tfnl,
      1 px1n,py1n,pz1n,dp1n
 cc      SAVE /leadng/
       COMMON/RNDF77/NSEED
 cc      SAVE /RNDF77/
       COMMON /dpert/dpertt(MAXSTR,MAXR),dpertp(MAXSTR),dplast(MAXSTR),
      1     dpdcy(MAXSTR),dpdpi(MAXSTR,MAXR),dpt(MAXSTR, MAXR),
      2     dpp1(MAXSTR,MAXR),dppion(MAXSTR,MAXR)
       common /dpi/em2,lb2
       common /para8/ idpert,npertd,idxsec
       dimension ppd(3,npdmax),lbpd(npdmax)
       SAVE   
 *-----------------------------------------------------------------------
        n12=0
        m12=0
         IBLOCK=0
         NTAG=0
         EM1=E(I1)
         EM2=E(I2)
         PR  = SQRT( PX**2 + PY**2 + PZ**2 )
         C2  = PZ / PR
         X1  = RANART(NSEED)
         ianti=0
         if(lb(i1).lt.0 .and. lb(i2).lt.0)ianti=1
 
 clin-6/2008 Production of perturbative deuterons for idpert=1:
       call sbbdm(srt,sdprod,ianti,lbm,xmm,pfinal)
       if(idpert.eq.1.and.ipert1.eq.1) then
          IF (SRT .LT. 2.012) RETURN
          if((iabs(lb(i1)).eq.1.or.iabs(lb(i1)).eq.2)
      1        .and.(iabs(lb(i2)).ge.6.and.iabs(lb(i2)).le.13)) then
             goto 108
          elseif((iabs(lb(i2)).eq.1.or.iabs(lb(i2)).eq.2)
      1           .and.(iabs(lb(i1)).ge.6.and.iabs(lb(i1)).le.13)) then
             goto 108
          else
             return
          endif
       endif
 *-----------------------------------------------------------------------
 *COM: TEST FOR ELASTIC SCATTERING (EITHER N-N OR DELTA-DELTA 0R
 *      N-DELTA OR N*-N* or N*-Delta)
       IF (X1 .LE. SIGNN/SIG) THEN
 *COM:  PARAMETRISATION IS TAKEN FROM THE CUGNON-PAPER
         AS  = ( 3.65 * (SRT - 1.8766) )**6
         A   = 6.0 * AS / (1.0 + AS)
         TA  = -2.0 * PR**2
         X   = RANART(NSEED)
 clin-10/24/02        T1  = ALOG( (1-X) * DEXP(dble(A)*dble(TA)) + X )  /  A
         T1  = sngl(DLOG(dble(1.-X)*DEXP(dble(A)*dble(TA))+dble(X)))/  A
         C1  = 1.0 - T1/TA
         T1  = 2.0 * PI * RANART(NSEED)
         IBLOCK=1
        GO TO 107
       ELSE
 *COM: TEST FOR INELASTIC SCATTERING
 *     IF THE AVAILABLE ENERGY IS LESS THAN THE PION-MASS, NOTHING
 *     CAN HAPPEN ANY MORE ==> RETURN (2.04 = 2*AVMASS + PI-MASS+0.02)
         IF (SRT .LT. 2.04) RETURN
 clin-6/2008 add d+meson production for n*N*(0)(1440) and p*N*(+)(1440) channels
 c     (they did not have any inelastic reactions before):
         if(((iabs(LB(I1)).EQ.2.or.iabs(LB(I2)).EQ.2).AND.
      1       (LB(I1)*LB(I2)).EQ.20).or.(LB(I1)*LB(I2)).EQ.13) then
            IF(X1.LE.((SIGNN+sdprod)/SIG)) GO TO 108
         ENDIF
 c
 * Resonance absorption or Delta + N-->N*(1440), N*(1535)
 * COM: TEST FOR DELTA OR N* ABSORPTION
 *      IN THE PROCESS DELTA+N-->NN, N*+N-->NN
         PRF=SQRT(0.25*SRT**2-AVMASS**2)
         IF(EM1.GT.1.)THEN
         DELTAM=EM1
         ELSE
         DELTAM=EM2
         ENDIF
         RENOM=DELTAM*PRF**2/DENOM(SRT,1.)/PR
         RENOMN=DELTAM*PRF**2/DENOM(SRT,2.)/PR
         RENOM1=DELTAM*PRF**2/DENOM(SRT,-1.)/PR
 * avoid the inelastic collisions between n+delta- -->N+N 
 *       and p+delta++ -->N+N due to charge conservation,
 *       but they can scatter to produce kaons 
        if((iabs(lb(i1)).eq.2).and.(iabs(lb(i2)).eq.6)) renom=0.
        if((iabs(lb(i2)).eq.2).and.(iabs(lb(i1)).eq.6)) renom=0.
        if((iabs(lb(i1)).eq.1).and.(iabs(lb(i2)).eq.9)) renom=0.
        if((iabs(lb(i2)).eq.1).and.(iabs(lb(i1)).eq.9)) renom=0.
        Call M1535(iabs(lb(i1)),iabs(lb(i2)),srt,x1535)
         X1440=(3./4.)*SIGMA(SRT,2,0,1)
 * CROSS SECTION FOR KAON PRODUCTION from the four channels
 * for NLK channel
 * avoid the inelastic collisions between n+delta- -->N+N 
 *       and p+delta++ -->N+N due to charge conservation,
 *       but they can scatter to produce kaons 
        if(((iabs(lb(i1)).eq.2).and.(iabs(lb(i2)).eq.6)).OR. 
      &         ((iabs(lb(i2)).eq.2).and.(iabs(lb(i1)).eq.6)).OR.
      &         ((iabs(lb(i1)).eq.1).and.(iabs(lb(i2)).eq.9)).OR.
      &         ((iabs(lb(i2)).eq.1).and.(iabs(lb(i1)).eq.9)))THEN
 clin-6/2008
           IF(X1.LE.((SIGNN+sdprod)/SIG)) GO TO 108
 c          IF((SIGK+SIGNN)/SIG.GE.X1)GO TO 306
           IF((SIGK+SIGNN+sdprod)/SIG.GE.X1)GO TO 306
 c
        ENDIF
 * WE DETERMINE THE REACTION CHANNELS IN THE FOLLOWING
 * FOR n+delta(++)-->p+p or n+delta(++)-->n+N*(+)(1440),n+N*(+)(1535)
 * REABSORPTION OR N*(1535) PRODUCTION LIKE IN P+P OR N*(1440) LIKE PN, 
         IF(LB(I1)*LB(I2).EQ.18.AND.
      &  (iabs(LB(I1)).EQ.2.OR.iabs(LB(I2)).EQ.2))then
         SIGND=SIGMA(SRT,1,1,0)+0.5*SIGMA(SRT,1,1,1)
         SIGDN=0.25*SIGND*RENOM
 clin-6/2008
         IF(X1.LE.((SIGNN+sdprod)/SIG)) GO TO 108
 c        IF(X1.GT.(SIGNN+SIGDN+X1440+X1535+SIGK)/SIG)RETURN
         IF(X1.GT.(SIGNN+SIGDN+X1440+X1535+SIGK+sdprod)/SIG)RETURN
 c
        IF(SIGK/(SIGK+SIGDN+X1440+X1535).GT.RANART(NSEED))GO TO 306
 * REABSORPTION:
        IF(RANART(NSEED).LT.SIGDN/(SIGDN+X1440+X1535))THEN
         M12=3
        GO TO 206
        ELSE
 * N* PRODUCTION
               IF(RANART(NSEED).LT.X1440/(X1440+X1535))THEN
 * N*(1440)
               M12=37
               ELSE
 * N*(1535)       M12=38
 clin-2/26/03 why is the above commented out? leads to M12=0 but 
 c     particle mass is changed after 204 (causes energy violation).
 c     replace by elastic process (return):
                    return
 
               ENDIF
        GO TO 204
        ENDIF
         ENDIF
 * FOR p+delta(-)-->n+n or p+delta(-)-->n+N*(0)(1440),n+N*(0)(1535)
 * REABSORPTION OR N*(1535) PRODUCTION LIKE IN P+P OR N*(1440) LIKE PN, 
         IF(LB(I1)*LB(I2).EQ.6.AND.
      &   ((iabs(LB(I1)).EQ.1).OR.(iabs(LB(I2)).EQ.1)))then
         SIGND=SIGMA(SRT,1,1,0)+0.5*SIGMA(SRT,1,1,1)
         SIGDN=0.25*SIGND*RENOM
 clin-6/2008
         IF(X1.LE.((SIGNN+sdprod)/SIG)) GO TO 108
 c        IF (X1.GT.(SIGNN+SIGDN+X1440+X1535+SIGK)/SIG)RETURN
         IF (X1.GT.(SIGNN+SIGDN+X1440+X1535+SIGK+sdprod)/SIG)RETURN
 c
        IF(SIGK/(SIGK+SIGDN+X1440+X1535).GT.RANART(NSEED))GO TO 306
 * REABSORPTION:
        IF(RANART(NSEED).LT.SIGDN/(SIGDN+X1440+X1535))THEN
         M12=6
        GO TO 206
        ELSE
 * N* PRODUCTION
               IF(RANART(NSEED).LT.X1440/(X1440+X1535))THEN
 * N*(1440)
               M12=47
               ELSE
 * N*(1535)       M12=48
 clin-2/26/03 causes energy violation, replace by elastic process (return):
                    return
 
               ENDIF
        GO TO 204
        ENDIF
         ENDIF
 * FOR p+delta(+)-->p+p, N*(+)(144)+p, N*(+)(1535)+p
         IF(LB(I1)*LB(I2).EQ.8.AND.
      &   (iabs(LB(I1)).EQ.1.OR.iabs(LB(I2)).EQ.1))THEN
         SIGND=1.5*SIGMA(SRT,1,1,1)
         SIGDN=0.25*SIGND*RENOM
 clin-6/2008
         IF(X1.LE.((SIGNN+sdprod)/SIG)) GO TO 108
 c        IF(X1.GT.(SIGNN+SIGDN+x1440+x1535+SIGK)/SIG)RETURN
         IF(X1.GT.(SIGNN+SIGDN+x1440+x1535+SIGK+sdprod)/SIG)RETURN
 c
        IF(SIGK/(SIGK+SIGDN+X1440+X1535).GT.RANART(NSEED))GO TO 306
        IF(RANART(NSEED).LT.SIGDN/(SIGDN+X1440+X1535))THEN
         M12=4
        GO TO 206
        ELSE
               IF(RANART(NSEED).LT.X1440/(X1440+X1535))THEN
 * N*(144)
               M12=39
               ELSE
               M12=40
               ENDIF
               GO TO 204
        ENDIF
         ENDIF
 * FOR n+delta(0)-->n+n, N*(0)(144)+n, N*(0)(1535)+n
         IF(LB(I1)*LB(I2).EQ.14.AND.
      &   (iabs(LB(I1)).EQ.2.OR.iabs(LB(I2)).EQ.2))THEN
         SIGND=1.5*SIGMA(SRT,1,1,1)
         SIGDN=0.25*SIGND*RENOM
 clin-6/2008
         IF(X1.LE.((SIGNN+sdprod)/SIG)) GO TO 108
 c        IF(X1.GT.(SIGNN+SIGDN+x1440+x1535+SIGK)/SIG)RETURN
         IF(X1.GT.(SIGNN+SIGDN+x1440+x1535+SIGK+sdprod)/SIG)RETURN
 c
        IF(SIGK/(SIGK+SIGDN+X1440+X1535).GT.RANART(NSEED))GO TO 306
        IF(RANART(NSEED).LT.SIGDN/(SIGDN+X1440+X1535))THEN
         M12=5
        GO TO 206
        ELSE
               IF(RANART(NSEED).LT.X1440/(X1440+X1535))THEN
 * N*(144)
               M12=48
               ELSE
               M12=49
               ENDIF
               GO TO 204
        ENDIF
         ENDIF
 * FOR n+delta(+)-->n+p, N*(+)(1440)+n,N*(0)(1440)+p,
 *                       N*(+)(1535)+n,N*(0)(1535)+p
         IF(LB(I1)*LB(I2).EQ.16.AND.
      &   (iabs(LB(I1)).EQ.2.OR.iabs(LB(I2)).EQ.2))THEN
         SIGND=0.5*SIGMA(SRT,1,1,1)+0.25*SIGMA(SRT,1,1,0)
         SIGDN=0.5*SIGND*RENOM
 clin-6/2008
         IF(X1.LE.((SIGNN+sdprod)/SIG)) GO TO 108
 c        IF(X1.GT.(SIGNN+SIGDN+2.*x1440+2.*x1535+SIGK)/SIG)RETURN
         IF(X1.GT.(SIGNN+SIGDN+2.*x1440+2.*x1535+SIGK+sdprod)/SIG)RETURN
 c
        IF(SIGK/(SIGK+SIGDN+2*X1440+2*X1535).GT.RANART(NSEED))GO TO 306
        IF(RANART(NSEED).LT.SIGDN/(SIGDN+2.*X1440+2.*X1535))THEN
         M12=1
        GO TO 206
        ELSE
               IF(RANART(NSEED).LT.X1440/(X1440+X1535))THEN
               M12=41
               IF(RANART(NSEED).LE.0.5)M12=43
               ELSE
               M12=42
               IF(RANART(NSEED).LE.0.5)M12=44
               ENDIF
               GO TO 204
        ENDIF
         ENDIF
 * FOR p+delta(0)-->n+p, N*(+)(1440)+n,N*(0)(1440)+p,
 *                       N*(+)(1535)+n,N*(0)(1535)+p
         IF(LB(I1)*LB(I2).EQ.7)THEN
         SIGND=0.5*SIGMA(SRT,1,1,1)+0.25*SIGMA(SRT,1,1,0)
         SIGDN=0.5*SIGND*RENOM
 clin-6/2008
         IF(X1.LE.((SIGNN+sdprod)/SIG)) GO TO 108
 c        IF(X1.GT.(SIGNN+SIGDN+2.*x1440+2.*x1535+SIGK)/SIG)RETURN
         IF(X1.GT.(SIGNN+SIGDN+2.*x1440+2.*x1535+SIGK+sdprod)/SIG)RETURN
 c
        IF(SIGK/(SIGK+SIGDN+2*X1440+2*X1535).GT.RANART(NSEED))GO TO 306
        IF(RANART(NSEED).LT.SIGDN/(SIGDN+2.*X1440+2.*X1535))THEN
         M12=2
        GO TO 206
        ELSE
               IF(RANART(NSEED).LT.X1440/(X1440+X1535))THEN
               M12=50
               IF(RANART(NSEED).LE.0.5)M12=51
               ELSE
               M12=52
               IF(RANART(NSEED).LE.0.5)M12=53
               ENDIF
               GO TO 204
        ENDIF
         ENDIF
 * FOR p+N*(0)(14)-->p+n, N*(+)(1535)+n,N*(0)(1535)+p
 * OR  P+N*(0)(14)-->D(+)+N, D(0)+P, 
         IF(LB(I1)*LB(I2).EQ.10.AND.
      &  (iabs(LB(I1)).EQ.1.OR.iabs(LB(I2)).EQ.1))then
         SIGND=(3./4.)*SIGMA(SRT,2,0,1)
         SIGDN=SIGND*RENOMN
 clin-6/2008
         IF(X1.LE.((SIGNN+sdprod)/SIG)) GO TO 108
 c        IF(X1.GT.(SIGNN+SIGDN+X1535+SIGK)/SIG)RETURN
         IF(X1.GT.(SIGNN+SIGDN+X1535+SIGK+sdprod)/SIG)RETURN
 c
        IF(SIGK/(SIGK+SIGDN+X1535).GT.RANART(NSEED))GO TO 306
        IF(RANART(NSEED).LT.SIGDN/(SIGDN+X1535))THEN
         M12=7
         GO TO 206
        ELSE
        M12=54
        IF(RANART(NSEED).LE.0.5)M12=55
        ENDIF
        GO TO 204
         ENDIF
 * FOR n+N*(+)-->p+n, N*(+)(1535)+n,N*(0)(1535)+p
         IF(LB(I1)*LB(I2).EQ.22.AND.
      &   (iabs(LB(I1)).EQ.2.OR.iabs(LB(I2)).EQ.2))then
         SIGND=(3./4.)*SIGMA(SRT,2,0,1)
         SIGDN=SIGND*RENOMN
 clin-6/2008
         IF(X1.LE.((SIGNN+sdprod)/SIG)) GO TO 108
 c        IF(X1.GT.(SIGNN+SIGDN+X1535+SIGK)/SIG)RETURN
         IF(X1.GT.(SIGNN+SIGDN+X1535+SIGK+sdprod)/SIG)RETURN
 c
        IF(SIGK/(SIGK+SIGDN+X1535).GT.RANART(NSEED))GO TO 306
        IF(RANART(NSEED).LT.SIGDN/(SIGDN+X1535))THEN
         M12=8
         GO TO 206
        ELSE
        M12=56
        IF(RANART(NSEED).LE.0.5)M12=57
        ENDIF
        GO TO 204
         ENDIF
 * FOR N*(1535)+N-->N+N COLLISIONS
         IF((iabs(LB(I1)).EQ.12).OR.(iabs(LB(I1)).EQ.13).OR.
      1  (iabs(LB(I2)).EQ.12).OR.(iabs(LB(I2)).EQ.13))THEN
         SIGND=X1535
         SIGDN=SIGND*RENOM1
 clin-6/2008
         IF(X1.LE.((SIGNN+sdprod)/SIG)) GO TO 108
 c        IF(X1.GT.(SIGNN+SIGDN+SIGK)/SIG)RETURN
         IF(X1.GT.(SIGNN+SIGDN+SIGK+sdprod)/SIG)RETURN
 c
        IF(SIGK/(SIGK+SIGDN).GT.RANART(NSEED))GO TO 306
         IF(LB(I1)*LB(I2).EQ.24)M12=10
         IF(LB(I1)*LB(I2).EQ.12)M12=12
         IF(LB(I1)*LB(I2).EQ.26)M12=11
        IF(LB(I1)*LB(I2).EQ.13)M12=9
        GO TO 206
         ENDIF
 204       CONTINUE
 * (1) GENERATE THE MASS FOR THE N*(1440) AND N*(1535)
 * (2) CALCULATE THE FINAL MOMENTUM OF THE n+N* SYSTEM
 * (3) RELABLE THE FINAL STATE PARTICLES
 *PARAMETRIZATION OF THE SHAPE OF THE N* RESONANCE ACCORDING
 *     TO kitazoe's or J.D.JACKSON'S MASS FORMULA AND BREIT WIGNER
 *     FORMULA FOR N* RESORANCE
 *     DETERMINE DELTA MASS VIA REJECTION METHOD.
           DMAX = SRT - AVMASS-0.005
           DMIN = 1.078
           IF((M12.eq.37).or.(M12.eq.39).or.
      1    (M12.eQ.41).OR.(M12.eQ.43).OR.(M12.EQ.46).
      2     OR.(M12.EQ.48).OR.(M12.EQ.50).OR.(M12.EQ.51))then
 * N*(1440) production
           IF(DMAX.LT.1.44) THEN
           FM=FNS(DMAX,SRT,0.)
           ELSE
 
 clin-10/25/02 get rid of argument usage mismatch in FNS():
              xdmass=1.44
 c          FM=FNS(1.44,SRT,1.)
           FM=FNS(xdmass,SRT,1.)
 clin-10/25/02-end
 
           ENDIF
           IF(FM.EQ.0.)FM=1.E-09
           NTRY2=0
 11        DM=RANART(NSEED)*(DMAX-DMIN)+DMIN
           NTRY2=NTRY2+1
           IF((RANART(NSEED).GT.FNS(DM,SRT,1.)/FM).AND.
      1    (NTRY2.LE.10)) GO TO 11
 
 clin-2/26/03 limit the N* mass below a certain value 
 c     (here taken as its central value + 2* B-W fullwidth):
           if(dm.gt.2.14) goto 11
 
               GO TO 13
               ELSE
 * N*(1535) production
           IF(DMAX.LT.1.535) THEN
           FM=FD5(DMAX,SRT,0.)
           ELSE
 
 clin-10/25/02 get rid of argument usage mismatch in FNS():
              xdmass=1.535
 c          FM=FD5(1.535,SRT,1.)
           FM=FD5(xdmass,SRT,1.)
 clin-10/25/02-end
 
           ENDIF
           IF(FM.EQ.0.)FM=1.E-09
           NTRY1=0
 12        DM = RANART(NSEED) * (DMAX-DMIN) + DMIN
           NTRY1=NTRY1+1
           IF((RANART(NSEED) .GT. FD5(DM,SRT,1.)/FM).AND.
      1    (NTRY1.LE.10)) GOTO 12
 
 clin-2/26/03 limit the N* mass below a certain value 
 c     (here taken as its central value + 2* B-W fullwidth):
           if(dm.gt.1.84) goto 12
 
              ENDIF
 13       CONTINUE
 * (2) DETERMINE THE FINAL MOMENTUM
        PRF=0.
        PF2=((SRT**2-DM**2+AVMASS**2)/(2.*SRT))**2-AVMASS**2
        IF(PF2.GT.0.)PRF=SQRT(PF2)
 * (3) RELABLE FINAL STATE PARTICLES
 * 37 D(++)+n-->N*(+)(14)+p
           IF(M12.EQ.37)THEN
           IF(iabs(LB(I1)).EQ.9)THEN
           LB(I1)=1
           E(I1)=AMP
          LB(I2)=11
          E(I2)=DM
           ELSE
           LB(I2)=1
           E(I2)=AMP
          LB(I1)=11
          E(I1)=DM
           ENDIF
          GO TO 207
           ENDIF
 * 38 D(++)+n-->N*(+)(15)+p
           IF(M12.EQ.38)THEN
           IF(iabs(LB(I1)).EQ.9)THEN
           LB(I1)=1
           E(I1)=AMP
          LB(I2)=13
          E(I2)=DM
           ELSE
           LB(I2)=1
           E(I2)=AMP
          LB(I1)=13
          E(I1)=DM
           ENDIF
          GO TO 207
          ENDIF
 * 39 D(+)+P-->N*(+)(14)+p
           IF(M12.EQ.39)THEN
           IF(iabs(LB(I1)).EQ.8)THEN
           LB(I1)=1
           E(I1)=AMP
          LB(I2)=11
          E(I2)=DM
           ELSE
           LB(I2)=1
           E(I2)=AMP
          LB(I1)=11
          E(I1)=DM
           ENDIF
          GO TO 207
          ENDIF
 * 40 D(+)+P-->N*(+)(15)+p
           IF(M12.EQ.40)THEN
           IF(iabs(LB(I1)).EQ.8)THEN
           LB(I1)=1
           E(I1)=AMP
          LB(I2)=13
          E(I2)=DM
           ELSE
           LB(I2)=1
           E(I2)=AMP
          LB(I1)=13
          E(I1)=DM
           ENDIF
          GO TO 207
          ENDIF
 * 41 D(+)+N-->N*(+)(14)+N
           IF(M12.EQ.41)THEN
           IF(iabs(LB(I1)).EQ.8)THEN
           LB(I1)=2
           E(I1)=AMN
          LB(I2)=11
          E(I2)=DM
           ELSE
           LB(I2)=2
           E(I2)=AMN
          LB(I1)=11
          E(I1)=DM