Back to home page

Project CMSSW displayed by LXR

 
 

    


File indexing completed on 2021-02-14 13:29:28

0001 c....................art1f.f
0002 **************************************
0003 *
0004 *                           PROGRAM ART1.0 
0005 *
0006 *        A relativistic transport (ART) model for heavy-ion collisions
0007 *
0008 *   sp/01/04/2002
0009 *   calculates K+K- from phi decay, dimuons from phi decay
0010 *   has finite baryon density & possibilites of varying Kaon 
0011 *   in-medium mass in phiproduction-annhilation channel only.
0012 *
0013 *
0014 * RELEASING DATE: JAN., 1997 
0015 ***************************************
0016 * 
0017 * Bao-An Li & Che Ming Ko
0018 * Cyclotron Institute, Texas A&M University.
0019 * Phone: (409) 845-1411
0020 * e-mail: Bali@comp.tamu.edu & Ko@comp.tamu.edu 
0021 * http://wwwcyc.tamu.edu/~bali
0022 ***************************************
0023 * Speical notice on the limitation of the code:
0024 * 
0025 * (1) ART is a hadronic transport model
0026 * 
0027 * (2) E_beam/A <= 15 GeV
0028 * 
0029 * (3) The mass of the colliding system is limited by the dimensions of arrays
0030 *    which can be extended purposely. Presently the dimensions are large enough
0031 *     for running Au+Au at 15 GeV/A.
0032 *
0033 * (4) The production and absorption of antiparticles (e.g., ki-, anti-nucleons,
0034 *     etc) are not fully included in this version of the model. They, however, 
0035 *     have essentially no effect on the reaction dynamics and observables 
0036 *     related to nucleons, pions and kaons (K+) at and below AGS energies.
0037 * 
0038 * (5) Bose enhancement for mesons and Pauli blocking for fermions are 
0039 *     turned off.
0040 * 
0041 *********************************
0042 *
0043 * USEFUL REFERENCES ON PHYSICS AND NUMERICS OF NUCLEAR TRANSPORT MODELS:
0044 *     G.F. BERTSCH AND DAS GUPTA, PHYS. REP. 160 (1988) 189.
0045 *     B.A. LI AND W. BAUER, PHYS. REV. C44 (1991) 450.
0046 *     B.A. LI, W. BAUER AND G.F. BERTSCH, PHYS. REV. C44 (1991) 2095.
0047 *     P. DANIELEWICZ AND G.F. BERTSCH, NUCL. PHYS. A533 (1991) 712.
0048 * 
0049 * MAIN REFERENCES ON THIS VERSION OF ART MODEL:
0050 *     B.A. LI AND C.M. KO, PHYS. REV. C52 (1995) 2037; 
0051 *                          NUCL. PHYS. A601 (1996) 457. 
0052 *
0053 **********************************
0054 **********************************
0055 *  VARIABLES IN INPUT-SECTION:                                               * 
0056 *                                                                      *
0057 *  1) TARGET-RELATED QUANTITIES                                        *
0058 *       MASSTA, ZTA -  TARGET MASS IN AMU, TARGET CHARGE  (INTEGER)    *
0059 *                                                                      *
0060 *  2) PROJECTILE-RELATED QUANTITIES                                    *
0061 *       MASSPR, ZPR -  PROJECTILE MASS IN AMU, PROJ. CHARGE(INTEGER)   *
0062 *       ELAB     -  BEAM ENERGY IN [MEV/NUCLEON]               (REAL)  *
0063 *       ZEROPT   -  DISPLACEMENT OF THE SYSTEM IN Z-DIREC. [FM](REAL)  *
0064 *       B        -  IMPACT PARAMETER [FM]                      (REAL)  *
0065 *                                                                      *
0066 *  3) PROGRAM-CONTROL PARAMETERS                                       *
0067 *       ISEED    -  SEED FOR RANDOM NUMBER GENERATOR        (INTEGER)  *
0068 *       DT       -  TIME-STEP-SIZE [FM/C]                      (REAL)  *
0069 *       NTMAX    -  TOTAL NUMBER OF TIMESTEPS               (INTEGER)  *
0070 *       ICOLL    -  (= 1 -> MEAN FIELD ONLY,                           *
0071 *                -   =-1 -> CACADE ONLY, ELSE FULL ART)     (INTEGER)  *
0072 *       NUM      -  NUMBER OF TESTPARTICLES PER NUCLEON     (INTEGER)  *
0073 *       INSYS    -  (=0 -> LAB-SYSTEM, ELSE C.M. SYSTEM)    (INTEGER)  *
0074 *       IPOT     -  1 -> SIGMA=2; 2 -> SIGMA=4/3; 3 -> SIGMA=7/6       *
0075 *                   IN MEAN FIELD POTENTIAL                 (INTEGER)  *
0076 *       MODE     -  (=1 -> interpolation for pauli-blocking,           *
0077 *                    =2 -> local lookup, other -> unblocked)(integer)  *
0078 *       DX,DY,DZ -  widths of cell for paulat in coor. sp. [fm](real)  *
0079 *       DPX,DPY,DPZ-widths of cell for paulat in mom. sp.[GeV/c](real) *
0080 *       IAVOID   -  (=1 -> AVOID FIRST COLL. WITHIN SAME NUCL.         *
0081 *                    =0 -> ALLOW THEM)                      (INTEGER)  *
0082 *       IMOMEN   -  FLAG FOR CHOICE OF INITIAL MOMENTUM DISTRIBUTION   *
0083 *                   (=1 -> WOODS-SAXON DENSITY AND LOCAL THOMAS-FERMI  *
0084 *                    =2 -> NUCLEAR MATTER DEN. AND LOCAL THOMAS-FERMI  *
0085 *                    =3 -> COHERENT BOOST IN Z-DIRECTION)   (INTEGER)  *
0086 *  4) CONTROL-PRINTOUT OPTIONS                                         *
0087 *       NFREQ    -  NUMBER OF TIMSTEPS AFTER WHICH PRINTOUT            *
0088 *                   IS REQUIRED OR ON-LINE ANALYSIS IS PERFORMED       *
0089 *       ICFLOW      =1 PERFORM ON-LINE FLOW ANALYSIS EVERY NFREQ STEPS *
0090 *       ICRHO       =1 PRINT OUT THE BARYON,PION AND ENERGY MATRIX IN  *
0091 *                      THE REACTION PLANE EVERY NFREQ TIME-STEPS       *
0092 *  5)
0093 *       CYCBOX   -  ne.0 => cyclic boundary conditions;boxsize CYCBOX  *
0094 *
0095 **********************************
0096 *               Lables of particles used in this code                     *
0097 **********************************
0098 *         
0099 *         LB(I) IS USED TO LABEL PARTICLE'S CHARGE STATE
0100 *    
0101 *         LB(I)   =
0102 clin-11/07/00:
0103 *                -30 K*-
0104 clin-8/29/00
0105 *                -13 anti-N*(+1)(1535),s_11
0106 *                -12 anti-N*0(1535),s_11
0107 *                 -11 anti-N*(+1)(1440),p_11
0108 *                 -10 anti-N*0(1440), p_11
0109 *                  -9 anti-DELTA+2
0110 *                  -8 anti-DELTA+1
0111 *                  -7 anti-DELTA0
0112 *                  -6 anti-DELTA-1
0113 clin-8/29/00-end
0114 
0115 cbali2/7/99 
0116 *                  -2 antineutron 
0117 *                             -1       antiproton
0118 cbali2/7/99 end 
0119 *                   0 eta
0120 *                        1 PROTON
0121 *                   2 NUETRON
0122 *                   3 PION-
0123 *                   4 PION0
0124 *                   5 PION+
0125 *                   6 DELTA-1
0126 *                   7 DELTA0
0127 *                   8 DELTA+1
0128 *                   9 DELTA+2
0129 *                   10 N*0(1440), p_11
0130 *                   11 N*(+1)(1440),p_11
0131 *                  12 N*0(1535),s_11
0132 *                  13 N*(+1)(1535),s_11
0133 *                  14 LAMBDA
0134 *                   15 sigma-, since we used isospin averaged xsection for
0135 *                   16 sigma0  sigma associated K+ production, sigma0 and 
0136 *                   17 sigma+  sigma+ are counted as sigma-
0137 *                   21 kaon-
0138 *                   23 KAON+
0139 *                   24 kaon0
0140 *                   25 rho-
0141 *                         26 rho0
0142 *                   27 rho+
0143 *                   28 omega meson
0144 *                   29 phi
0145 clin-11/07/00:
0146 *                  30 K*+
0147 * sp01/03/01
0148 *                 -14 LAMBDA(bar)
0149 *                  -15 sigma-(bar)
0150 *                  -16 sigma0(bar)
0151 *                  -17 sigma+(bar)
0152 *                   31 eta-prime
0153 *                   40 cascade-
0154 *                  -40 cascade-(bar)
0155 *                   41 cascade0
0156 *                  -41 cascade0(bar)
0157 *                   45 Omega baryon
0158 *                  -45 Omega baryon(bar)
0159 * sp01/03/01 end
0160 clin-5/2008:
0161 *                   42 Deuteron (same in ampt.dat)
0162 *                  -42 anti-Deuteron (same in ampt.dat)
0163 c
0164 *                   ++  ------- SEE BAO-AN LI'S NOTE BOOK
0165 **********************************
0166 cbz11/16/98
0167 c      PROGRAM ART
0168        SUBROUTINE ARTMN
0169 cbz11/16/98end
0170 **********************************
0171 * PARAMETERS:                                                           *
0172 *  MAXPAR     - MAXIMUM NUMBER OF PARTICLES      PROGRAM CAN HANDLE     *
0173 *  MAXP       - MAXIMUM NUMBER OF CREATED MESONS PROGRAM CAN HANDLE     *
0174 *  MAXR       - MAXIMUM NUMBER OF EVENTS AT EACH IMPACT PARAMETER       *
0175 *  MAXX       - NUMBER OF MESHPOINTS IN X AND Y DIRECTION = 2 MAXX + 1  *
0176 *  MAXZ       - NUMBER OF MESHPOINTS IN Z DIRECTION       = 2 MAXZ + 1  *
0177 *  AMU        - 1 ATOMIC MASS UNIT "GEV/C**2"                           *
0178 *  MX,MY,MZ   - MESH SIZES IN COORDINATE SPACE [FM] FOR PAULI LATTICE   *
0179 *  MPX,MPY,MPZ- MESH SIZES IN MOMENTUM SPACE [GEV/C] FOR PAULI LATTICE  *
0180 *---------------------------------------------------------------------- *
0181 clin      PARAMETER     (maxpar=200000,MAXR=50,AMU= 0.9383,
0182       PARAMETER     (MAXSTR=150001,MAXR=1,AMU= 0.9383,
0183      1               AKA=0.498,etaM=0.5475)
0184       PARAMETER     (MAXX   =   20,  MAXZ  =    24)
0185       PARAMETER     (ISUM   =   1001,  IGAM  =    1100)
0186       parameter     (MX=4,MY=4,MZ=8,MPX=4,MPY=4,mpz=10,mpzp=10)
0187 clin      PARAMETER (MAXP = 14000)
0188 *----------------------------------------------------------------------*
0189       INTEGER   OUTPAR, zta,zpr
0190       COMMON  /AA/      R(3,MAXSTR)
0191 cc      SAVE /AA/
0192       COMMON  /BB/      P(3,MAXSTR)
0193 cc      SAVE /BB/
0194       COMMON  /CC/      E(MAXSTR)
0195 cc      SAVE /CC/
0196       COMMON  /DD/      RHO(-MAXX:MAXX,-MAXX:MAXX,-MAXZ:MAXZ),
0197      &                     RHOP(-MAXX:MAXX,-MAXX:MAXX,-MAXZ:MAXZ),
0198      &                     RHON(-MAXX:MAXX,-MAXX:MAXX,-MAXZ:MAXZ)
0199 cc      SAVE /DD/
0200       COMMON  /EE/      ID(MAXSTR),LB(MAXSTR)
0201 cc      SAVE /EE/
0202       COMMON  /HH/  PROPER(MAXSTR)
0203 cc      SAVE /HH/
0204       common  /ff/f(-mx:mx,-my:my,-mz:mz,-mpx:mpx,-mpy:mpy,-mpz:mpzp)
0205 cc      SAVE /ff/
0206       common  /gg/      dx,dy,dz,dpx,dpy,dpz
0207 cc      SAVE /gg/
0208       COMMON  /INPUT/ NSTAR,NDIRCT,DIR
0209 cc      SAVE /INPUT/
0210       COMMON  /PP/      PRHO(-20:20,-24:24)
0211       COMMON  /QQ/      PHRHO(-MAXZ:MAXZ,-24:24)
0212       COMMON  /RR/      MASSR(0:MAXR)
0213 cc      SAVE /RR/
0214       common  /ss/      inout(20)
0215 cc      SAVE /ss/
0216       common  /zz/      zta,zpr
0217 cc      SAVE /zz/
0218       COMMON  /RUN/     NUM
0219 cc      SAVE /RUN/
0220 clin-4/2008:
0221 c      COMMON  /KKK/     TKAON(7),EKAON(7,0:200)
0222       COMMON  /KKK/     TKAON(7),EKAON(7,0:2000)
0223 cc      SAVE /KKK/
0224       COMMON  /KAON/    AK(3,50,36),SPECK(50,36,7),MF
0225 cc      SAVE /KAON/
0226       COMMON/TABLE/ xarray(0:1000),earray(0:1000)
0227 cc      SAVE /TABLE/
0228       common/input1/ MASSPR,MASSTA,ISEED,IAVOID,DT
0229 cc      SAVE /input1/
0230       COMMON  /DDpi/    piRHO(-MAXX:MAXX,-MAXX:MAXX,-MAXZ:MAXZ)
0231 cc      SAVE /DDpi/
0232       common  /tt/  PEL(-maxx:maxx,-maxx:maxx,-maxz:maxz)
0233      &,rxy(-maxx:maxx,-maxx:maxx,-maxz:maxz)
0234 cc      SAVE /tt/
0235 clin-4/2008:
0236 c      DIMENSION TEMP(3,MAXSTR),SKAON(7),SEKAON(7,0:200)
0237       DIMENSION TEMP(3,MAXSTR),SKAON(7),SEKAON(7,0:2000)
0238 cbz12/2/98
0239       COMMON /INPUT2/ ILAB, MANYB, NTMAX, ICOLL, INSYS, IPOT, MODE, 
0240      &   IMOMEN, NFREQ, ICFLOW, ICRHO, ICOU, KPOTEN, KMUL
0241 cc      SAVE /INPUT2/
0242       COMMON /INPUT3/ PLAB, ELAB, ZEROPT, B0, BI, BM, DENCUT, CYCBOX
0243 cc      SAVE /INPUT3/
0244 cbz12/2/98end
0245 cbz11/16/98
0246       COMMON /ARPRNT/ ARPAR1(100), IAPAR2(50), ARINT1(100), IAINT2(50)
0247 cc      SAVE /ARPRNT/
0248 
0249 c.....note in the below, since a common block in ART is called EE,
0250 c.....the variable EE in /ARPRC/is changed to PEAR.
0251 clin-9/29/03 changed name in order to distinguish from /prec2/
0252 c        COMMON /ARPRC/ ITYPAR(MAXSTR),
0253 c     &       GXAR(MAXSTR), GYAR(MAXSTR), GZAR(MAXSTR), FTAR(MAXSTR),
0254 c     &       PXAR(MAXSTR), PYAR(MAXSTR), PZAR(MAXSTR), PEAR(MAXSTR),
0255 c     &       XMAR(MAXSTR)
0256 cc      SAVE /ARPRC/
0257 clin-9/29/03-end
0258       COMMON /ARERCP/PRO1(MAXSTR, MAXR)
0259 cc      SAVE /ARERCP/
0260       COMMON /ARERC1/MULTI1(MAXR)
0261 cc      SAVE /ARERC1/
0262       COMMON /ARPRC1/ITYP1(MAXSTR, MAXR),
0263      &     GX1(MAXSTR, MAXR), GY1(MAXSTR, MAXR), GZ1(MAXSTR, MAXR), 
0264      &     FT1(MAXSTR, MAXR),
0265      &     PX1(MAXSTR, MAXR), PY1(MAXSTR, MAXR), PZ1(MAXSTR, MAXR),
0266      &     EE1(MAXSTR, MAXR), XM1(MAXSTR, MAXR)
0267 cc      SAVE /ARPRC1/
0268 c
0269       DIMENSION NPI(MAXR)
0270       DIMENSION RT(3, MAXSTR, MAXR), PT(3, MAXSTR, MAXR)
0271      &     , ET(MAXSTR, MAXR), LT(MAXSTR, MAXR), PROT(MAXSTR, MAXR)
0272 
0273       EXTERNAL IARFLV, INVFLV
0274 cbz11/16/98end
0275       common /lastt/itimeh,bimp 
0276 cc      SAVE /lastt/
0277       common/snn/efrm,npart1,npart2,epsiPz,epsiPt,PZPROJ,PZTARG
0278 cc      SAVE /snn/
0279       COMMON/hbt/lblast(MAXSTR),xlast(4,MAXSTR),plast(4,MAXSTR),nlast
0280 cc      SAVE /hbt/
0281       common/resdcy/NSAV,iksdcy
0282 cc      SAVE /resdcy/
0283       COMMON/RNDF77/NSEED
0284 cc      SAVE /RNDF77/
0285       COMMON/FTMAX/ftsv(MAXSTR),ftsvt(MAXSTR, MAXR)
0286       COMMON /dpert/dpertt(MAXSTR,MAXR),dpertp(MAXSTR),dplast(MAXSTR),
0287      1     dpdcy(MAXSTR),dpdpi(MAXSTR,MAXR),dpt(MAXSTR, MAXR),
0288      2     dpp1(MAXSTR,MAXR),dppion(MAXSTR,MAXR)
0289       COMMON/HPARNT/HIPR1(100),IHPR2(50),HINT1(100),IHNT2(50)
0290 clin-4/2008 zet() expanded to avoid out-of-bound errors:
0291       real zet(-45:45)
0292       SAVE   
0293       data zet /
0294      4     1.,0.,0.,0.,0.,
0295      3     1.,0.,0.,0.,0.,0.,0.,0.,0.,0.,
0296      2     -1.,0.,0.,0.,0.,0.,0.,0.,0.,0.,
0297      1     0.,0.,0.,-1.,0.,1.,0.,-1.,0.,-1.,
0298      s     0.,-2.,-1.,0.,1.,0.,0.,0.,0.,-1.,
0299      e     0.,
0300      s     1.,0.,-1.,0.,1.,-1.,0.,1.,2.,0.,
0301      1     1.,0.,1.,0.,-1.,0.,1.,0.,0.,0.,
0302      2     -1.,0.,1.,0.,-1.,0.,1.,0.,0.,1.,
0303      3     0.,0.,0.,0.,0.,0.,0.,0.,0.,-1.,
0304      4     0.,0.,0.,0.,-1./
0305 
0306       nlast=0
0307       do 1002 i=1,MAXSTR
0308          ftsv(i)=0.
0309          do 1101 irun=1,maxr
0310             ftsvt(i,irun)=0.
0311  1101    continue
0312          lblast(i)=999
0313          do 1001 j=1,4
0314 clin-4/2008 bugs pointed out by Vander Molen & Westfall:
0315 c            xlast(i,j)=0.
0316 c            plast(i,j)=0.
0317             xlast(j,i)=0.
0318             plast(j,i)=0.
0319  1001    continue
0320  1002 continue
0321 
0322 *-------------------------------------------------------------------*
0323 * Input information about the reaction system and contral parameters* 
0324 *-------------------------------------------------------------------*
0325 *              input section starts here                           *
0326 *-------------------------------------------------------------------*
0327 
0328 cbz12/2/98
0329 c.....input section is moved to subroutine ARTSET
0330 cbz12/2/98end
0331 
0332 *-----------------------------------------------------------------------*
0333 *                   input section ends here                            *
0334 *-----------------------------------------------------------------------*
0335 * read in the table for gengrating the transverse momentum
0336 * IN THE NN-->DDP PROCESS
0337        call tablem
0338 * several control parameters, keep them fixed in this code. 
0339        ikaon=1
0340        nstar=1
0341        ndirct=0
0342        dir=0.02
0343        asy=0.032
0344        ESBIN=0.04
0345        MF=36
0346 *----------------------------------------------------------------------*
0347 c      CALL FRONT(12,MASSTA,MASSPR,ELAB)
0348 *----------------------------------------------------------------------*
0349       RADTA  = 1.124 * FLOAT(MASSTA)**(1./3.)
0350       RADPR  = 1.124 * FLOAT(MASSPR)**(1./3.)
0351       ZDIST  = RADTA + RADPR
0352 c      if ( cycbox.ne.0 ) zdist=0
0353       BMAX   = RADTA + RADPR
0354       MASS   = MASSTA + MASSPR
0355       NTOTAL = NUM * MASS
0356 *
0357       IF (NTOTAL .GT. MAXSTR) THEN
0358         WRITE(12,'(//10X,''**** FATAL ERROR: TOO MANY TEST PART. ****'//
0359      & ' '')')
0360         STOP
0361       END IF
0362 *
0363 *-----------------------------------------------------------------------
0364 *       RELATIVISTIC KINEMATICS
0365 *
0366 *       1) LABSYSTEM
0367 *
0368       ETA    = FLOAT(MASSTA) * AMU
0369       PZTA   = 0.0
0370       BETATA = 0.0
0371       GAMMTA = 1.0
0372 *
0373       EPR    = FLOAT(MASSPR) * (AMU + 0.001 * ELAB)
0374       PZPR   = SQRT( EPR**2 - (AMU * FLOAT(MASSPR))**2 )
0375       BETAPR = PZPR / EPR
0376       GAMMPR = 1.0 / SQRT( 1.0 - BETAPR**2 )
0377 *
0378 * BETAC AND GAMMAC OF THE C.M. OBSERVED IN THE LAB. FRAME
0379         BETAC=(PZPR+PZTA)/(EPR+ETA)
0380         GAMMC=1.0 / SQRT(1.-BETAC**2)
0381 *
0382 c      WRITE(12,'(/10x,''****    KINEMATICAL PARAMETERS    ****''/)')
0383 c      WRITE(12,'(10x,''1) LAB-FRAME:        TARGET PROJECTILE'')')
0384 c      WRITE(12,'(10x,''   ETOTAL "GEV" '',2F11.4)') ETA, EPR
0385 c      WRITE(12,'(10x,''   P "GEV/C"    '',2F11.4)') PZTA, PZPR
0386 c      WRITE(12,'(10x,''   BETA         '',2F11.4)') BETATA, BETAPR
0387 c      WRITE(12,'(10x,''   GAMMA        '',2F11.4)') GAMMTA, GAMMPR
0388       IF (INSYS .NE. 0) THEN
0389 *
0390 *       2) C.M. SYSTEM
0391 *
0392         S      = (EPR+ETA)**2 - PZPR**2
0393         xx1=4.*alog(float(massta))
0394         xx2=4.*alog(float(masspr))
0395         xx1=exp(xx1)
0396         xx2=exp(xx2)
0397         PSQARE = (S**2 + (xx1+ xx2) * AMU**4
0398      &             - 2.0 * S * AMU**2 * FLOAT(MASSTA**2 + MASSPR**2)
0399      &             - 2.0 * FLOAT(MASSTA**2 * MASSPR**2) * AMU**4)
0400      &           / (4.0 * S)
0401 *
0402         ETA    = SQRT ( PSQARE + (FLOAT(MASSTA) * AMU)**2 )
0403         PZTA   = - SQRT(PSQARE)
0404         BETATA = PZTA / ETA
0405         GAMMTA = 1.0 / SQRT( 1.0 - BETATA**2 )
0406 *
0407         EPR    = SQRT ( PSQARE + (FLOAT(MASSPR) * AMU)**2 )
0408         PZPR   = SQRT(PSQARE)
0409         BETAPR = PZPR/ EPR
0410         GAMMPR = 1.0 / SQRT( 1.0 - BETAPR**2 )
0411 *
0412 c        WRITE(12,'(10x,''2) C.M.-FRAME:  '')')
0413 c        WRITE(12,'(10x,''   ETOTAL "GEV" '',2F11.4)') ETA, EPR
0414 c        WRITE(12,'(10x,''   P "GEV/C"    '',2F11.4)') PZTA, PZPR
0415 c        WRITE(12,'(10x,''   BETA         '',2F11.4)') BETATA, BETAPR
0416 c        WRITE(12,'(10x,''   GAMMA        '',2F11.4)') GAMMTA, GAMMPR
0417 c        WRITE(12,'(10x,''S "GEV**2"      '',F11.4)')  S
0418 c        WRITE(12,'(10x,''PSQARE "GEV/C"2 '',E14.3)')  PSQARE
0419 c        WRITE(12,'(/10x,''*** CALCULATION DONE IN CM-FRAME ***''/)')
0420       ELSE
0421 c        WRITE(12,'(/10x,''*** CALCULATION DONE IN LAB-FRAME ***''/)')
0422       END IF
0423 * MOMENTUM PER PARTICLE
0424       PZTA = PZTA / FLOAT(MASSTA)
0425       PZPR = PZPR / FLOAT(MASSPR)
0426 * total initial energy in the N-N cms frame
0427       ECMS0=ETA+EPR
0428 *-----------------------------------------------------------------------
0429 *
0430 * Start loop over many runs of different impact parameters
0431 * IF MANYB=1, RUN AT A FIXED IMPACT PARAMETER B0, OTHERWISE GENERATE 
0432 * MINIMUM BIAS EVENTS WITHIN THE IMPACT PARAMETER RANGE OF B_MIN AND B_MAX
0433        DO 50000 IMANY=1,MANYB
0434 *------------------------------------------------------------------------
0435 * Initialize the impact parameter B
0436        if (manyb. gt.1) then
0437 111       BX=1.0-2.0*RANART(NSEED)
0438        BY=1.0-2.0*RANART(NSEED)
0439        B2=BX*BX+BY*BY
0440        IF(B2.GT.1.0) GO TO 111       
0441        B=SQRT(B2)*(BM-BI)+BI
0442        ELSE
0443        B=B0
0444        ENDIF
0445 c      WRITE(12,'(///10X,''RUN NUMBER:'',I6)') IMANY       
0446 c      WRITE(12,'(//10X,''IMPACT PARAMETER B FOR THIS RUN:'',
0447 c     &             F9.3,'' FM''/10X,49(''*'')/)') B
0448 *
0449 *-----------------------------------------------------------------------
0450 *       INITIALIZATION
0451 *1 INITIALIZATION IN ISOSPIN SPACE FOR BOTH THE PROJECTILE AND TARGET
0452       call coulin(masspr,massta,NUM)
0453 *2 INITIALIZATION IN PHASE SPACE FOR THE TARGET
0454       CALL INIT(1       ,MASSTA   ,NUM     ,RADTA,
0455      &          B/2.    ,ZEROPT+ZDIST/2.   ,PZTA,
0456      &          GAMMTA  ,ISEED    ,MASS    ,IMOMEN)
0457 *3.1 INITIALIZATION IN PHASE SPACE FOR THE PROJECTILE
0458       CALL INIT(1+MASSTA,MASS     ,NUM     ,RADPR,
0459      &          -B/2.   ,ZEROPT-ZDIST/2.   ,PZPR,
0460      &          GAMMPR  ,ISEED    ,MASS    ,IMOMEN)
0461 *3.2 OUTPAR IS THE NO. OF ESCAPED PARTICLES
0462       OUTPAR = 0
0463 *3.3 INITIALIZATION FOR THE NO. OF PARTICLES IN EACH SAMPLE
0464 *    THIS IS NEEDED DUE TO THE FACT THAT PIONS CAN BE PRODUCED OR ABSORBED
0465       MASSR(0)=0
0466       DO 1003 IR =1,NUM
0467       MASSR(IR)=MASS
0468  1003 CONTINUE
0469 *3.4 INITIALIZation FOR THE KAON SPECTRUM
0470 *      CALL KSPEC0(BETAC,GAMMC)
0471 * calculate the local baryon density matrix
0472       CALL DENS(IPOT,MASS,NUM,OUTPAR)
0473 *
0474 *-----------------------------------------------------------------------
0475 *       CONTROL PRINTOUT OF INITIAL CONFIGURATION
0476 *
0477 *      WRITE(12,'(''**********  INITIAL CONFIGURATION  **********''/)')
0478 *
0479 c print out the INITIAL density matrix in the reaction plane
0480 c       do ix=-10,10
0481 c       do iz=-10,10
0482 c       write(1053,992)ix,iz,rho(ix,0,iz)/0.168
0483 c       end do
0484 c       end do
0485 *-----------------------------------------------------------------------
0486 *       CALCULATE MOMENTA FOR T = 0.5 * DT 
0487 *       (TO OBTAIN 2ND DEGREE ACCURACY!)
0488 *       "Reference: J. AICHELIN ET AL., PHYS. REV. C31, 1730 (1985)"
0489 *
0490       IF (ICOLL .NE. -1) THEN
0491         DO 700 I = 1,NTOTAL
0492           IX = NINT( R(1,I) )
0493           IY = NINT( R(2,I) )
0494           IZ = NINT( R(3,I) )
0495 clin-4/2008 check bounds:
0496           IF(IX.GE.MAXX.OR.IY.GE.MAXX.OR.IZ.GE.MAXZ
0497      1         .OR.IX.LE.-MAXX.OR.IY.LE.-MAXX.OR.IZ.LE.-MAXZ) goto 700
0498           CALL GRADU(IPOT,IX,IY,IZ,GRADX,GRADY,GRADZ)
0499           P(1,I) = P(1,I) - (0.5 * DT) * GRADX
0500           P(2,I) = P(2,I) - (0.5 * DT) * GRADY
0501           P(3,I) = P(3,I) - (0.5 * DT) * GRADZ
0502   700   CONTINUE
0503       END IF
0504 *-----------------------------------------------------------------------
0505 *-----------------------------------------------------------------------
0506 *4 INITIALIZATION OF TIME-LOOP VARIABLES
0507 *4.1 COLLISION NUMBER COUNTERS
0508 clin 51      RCNNE  = 0
0509         RCNNE  = 0
0510        RDD  = 0
0511        RPP  = 0
0512        rppk = 0
0513        RPN  = 0
0514        rpd  = 0
0515        RKN  = 0
0516        RNNK = 0
0517        RDDK = 0
0518        RNDK = 0
0519       RCNND  = 0
0520       RCNDN  = 0
0521       RCOLL  = 0
0522       RBLOC  = 0
0523       RDIRT  = 0
0524       RDECAY = 0
0525       RRES   = 0
0526 *4.11 KAON PRODUCTION PROBABILITY COUNTER FOR PERTURBATIVE CALCULATIONS ONLY
0527       DO 1005 KKK=1,5
0528          SKAON(KKK)  = 0
0529          DO 1004 IS=1,2000
0530             SEKAON(KKK,IS)=0
0531  1004    CONTINUE
0532  1005 CONTINUE
0533 *4.12 anti-proton and anti-kaon counters
0534        pr0=0.
0535        pr1=0.
0536        ska0=0.
0537        ska1=0.
0538 *       ============== LOOP OVER ALL TIME STEPS ================       *
0539 *                             STARTS HERE                              *
0540 *       ========================================================       *
0541 cbz11/16/98
0542       IF (IAPAR2(1) .NE. 1) THEN
0543          DO 1016 I = 1, MAXSTR
0544             DO 1015 J = 1, 3
0545                R(J, I) = 0.
0546                P(J, I) = 0.
0547  1015       CONTINUE
0548             E(I) = 0.
0549             LB(I) = 0
0550 cbz3/25/00
0551             ID(I)=0
0552 c     sp 12/19/00
0553            PROPER(I) = 1.
0554  1016   CONTINUE
0555          MASS = 0
0556 cbz12/22/98
0557 c         MASSR(1) = 0
0558 c         NP = 0
0559 c         NPI = 1
0560          NP = 0
0561          DO 1017 J = 1, NUM
0562             MASSR(J) = 0
0563             NPI(J) = 1
0564  1017    CONTINUE
0565          DO 1019 I = 1, MAXR
0566             DO 1018 J = 1, MAXSTR
0567                RT(1, J, I) = 0.
0568                RT(2, J, I) = 0.
0569                RT(3, J, I) = 0.
0570                PT(1, J, I) = 0.
0571                PT(2, J, I) = 0.
0572                PT(3, J, I) = 0.
0573                ET(J, I) = 0.
0574                LT(J, I) = 0
0575 c     sp 12/19/00
0576                PROT(J, I) = 1.
0577  1018       CONTINUE
0578  1019    CONTINUE
0579 cbz12/22/98end
0580       END IF
0581 cbz11/16/98end
0582         
0583       DO 10000 NT = 1,NTMAX
0584 *TEMPORARY PARTICLE COUNTERS
0585 *4.2 PION COUNTERS : LP1,LP2 AND LP3 ARE THE NO. OF P+,P0 AND P-
0586       LP1=0
0587       LP2=0
0588       LP3=0
0589 *4.3 DELTA COUNTERS : LD1,LD2,LD3 AND LD4 ARE THE NO. OF D++,D+,D0 AND D-
0590       LD1=0
0591       LD2=0
0592       LD3=0
0593       LD4=0
0594 *4.4 N*(1440) COUNTERS : LN1 AND LN2 ARE THE NO. OF N*+ AND N*0
0595       LN1=0
0596       LN2=0
0597 *4.5 N*(1535) counters
0598       LN5=0
0599 *4.6 ETA COUNTERS
0600       LE=0
0601 *4.7 KAON COUNTERS
0602       LKAON=0
0603 
0604 clin-11/09/00:
0605 * KAON* COUNTERS
0606       LKAONS=0
0607 
0608 *-----------------------------------------------------------------------
0609         IF (ICOLL .NE. 1) THEN
0610 * STUDYING BINARY COLLISIONS AMONG PARTICLES DURING THIS TIME INTERVAL *
0611 clin-10/25/02 get rid of argument usage mismatch in relcol(.nt.):
0612            numnt=nt
0613           CALL RELCOL(LCOLL,LBLOC,LCNNE,LDD,LPP,lppk,
0614      &    LPN,lpd,LRHO,LOMEGA,LKN,LNNK,LDDK,LNDK,LCNND,
0615      &    LCNDN,LDIRT,LDECAY,LRES,LDOU,LDDRHO,LNNRHO,
0616      &    LNNOM,numnt,ntmax,sp,akaon,sk)
0617 c     &    LNNOM,NT,ntmax,sp,akaon,sk)
0618 clin-10/25/02-end
0619 *-----------------------------------------------------------------------
0620 
0621 c dilepton production from Dalitz decay
0622 c of pi0 at final time
0623 *      if(nt .eq. ntmax) call dalitz_pi(nt,ntmax)
0624 *                                                                      *
0625 **********************************
0626 *                Lables of collision channels                             *
0627 **********************************
0628 *         LCOLL   - NUMBER OF COLLISIONS              (INTEGER,OUTPUT) *
0629 *         LBLOC   - NUMBER OF PULI-BLOCKED COLLISIONS (INTEGER,OUTPUT) *
0630 *         LCNNE   - NUMBER OF ELASTIC COLLISION       (INTEGER,OUTPUT) *
0631 *         LCNND   - NUMBER OF N+N->N+DELTA REACTION   (INTEGER,OUTPUT) *
0632 *         LCNDN   - NUMBER OF N+DELTA->N+N REACTION   (INTEGER,OUTPUT) *
0633 *         LDD     - NUMBER OF RESONANCE+RESONANCE COLLISIONS
0634 *         LPP     - NUMBER OF PION+PION elastic COLIISIONS
0635 *         lppk    - number of pion(RHO,OMEGA)+pion(RHO,OMEGA)
0636 *                 -->K+K- collisions
0637 *         LPN     - NUMBER OF PION+N-->KAON+X
0638 *         lpd     - number of pion+n-->delta+pion
0639 *         lrho    - number of pion+n-->Delta+rho
0640 *         lomega  - number of pion+n-->Delta+omega
0641 *         LKN     - NUMBER OF KAON RESCATTERINGS
0642 *         LNNK    - NUMBER OF bb-->kAON PROCESS
0643 *         LDDK    - NUMBER OF DD-->KAON PROCESS
0644 *         LNDK    - NUMBER OF ND-->KAON PROCESS
0645 ***********************************
0646 * TIME-INTEGRATED COLLISIONS NUMBERS OF VARIOUS PROCESSES
0647           RCOLL = RCOLL + FLOAT(LCOLL)/num
0648           RBLOC = RBLOC + FLOAT(LBLOC)/num
0649           RCNNE = RCNNE + FLOAT(LCNNE)/num
0650          RDD   = RDD   + FLOAT(LDD)/num
0651          RPP   = RPP   + FLOAT(LPP)/NUM
0652          rppk  =rppk   + float(lppk)/num
0653          RPN   = RPN   + FLOAT(LPN)/NUM
0654          rpd   =rpd    + float(lpd)/num
0655          RKN   = RKN   + FLOAT(LKN)/NUM
0656          RNNK  =RNNK   + FLOAT(LNNK)/NUM
0657          RDDK  =RDDK   + FLOAT(LDDK)/NUM
0658          RNDK  =RNDK   + FLOAT(LNDK)/NUM
0659           RCNND = RCNND + FLOAT(LCNND)/num
0660           RCNDN = RCNDN + FLOAT(LCNDN)/num
0661           RDIRT = RDIRT + FLOAT(LDIRT)/num
0662           RDECAY= RDECAY+ FLOAT(LDECAY)/num
0663           RRES  = RRES  + FLOAT(LRES)/num
0664 * AVERAGE RATES OF VARIOUS COLLISIONS IN THE CURRENT TIME STEP
0665           ADIRT=LDIRT/DT/num
0666           ACOLL=(LCOLL-LBLOC)/DT/num
0667           ACNND=LCNND/DT/num
0668           ACNDN=LCNDN/DT/num
0669           ADECAY=LDECAY/DT/num
0670           ARES=LRES/DT/num
0671          ADOU=LDOU/DT/NUM
0672          ADDRHO=LDDRHO/DT/NUM
0673          ANNRHO=LNNRHO/DT/NUM
0674          ANNOM=LNNOM/DT/NUM
0675          ADD=LDD/DT/num
0676          APP=LPP/DT/num
0677          appk=lppk/dt/num
0678           APN=LPN/DT/num
0679          apd=lpd/dt/num
0680          arh=lrho/dt/num
0681          aom=lomega/dt/num
0682          AKN=LKN/DT/num
0683          ANNK=LNNK/DT/num
0684          ADDK=LDDK/DT/num
0685          ANDK=LNDK/DT/num
0686 * PRINT OUT THE VARIOUS COLLISION RATES
0687 * (1)N-N COLLISIONS 
0688 c       WRITE(1010,9991)NT*DT,ACNND,ADOU,ADIRT,ADDRHO,ANNRHO+ANNOM
0689 c9991       FORMAT(6(E10.3,2X))
0690 * (2)PION-N COLLISIONS
0691 c       WRITE(1011,'(5(E10.3,2X))')NT*DT,apd,ARH,AOM,APN
0692 * (3)KAON PRODUCTION CHANNELS
0693 c        WRITE(1012,9993)NT*DT,ANNK,ADDK,ANDK,APN,Appk
0694 * (4)D(N*)+D(N*) COLLISION
0695 c       WRITE(1013,'(4(E10.3,2X))')NT*DT,ADDK,ADD,ADD+ADDK
0696 * (5)MESON+MESON
0697 c       WRITE(1014,'(4(E10.3,2X))')NT*DT,APPK,APP,APP+APPK
0698 * (6)DECAY AND RESONANCE
0699 c       WRITE(1016,'(3(E10.3,2X))')NT*DT,ARES,ADECAY
0700 * (7)N+D(N*)
0701 c       WRITE(1017,'(4(E10.3,2X))')NT*DT,ACNDN,ANDK,ACNDN+ANDK
0702 c9992    FORMAT(5(E10.3,2X))
0703 c9993    FORMAT(6(E10.3,2X))
0704 * PRINT OUT TIME-INTEGRATED COLLISION INFORMATION
0705 cbz12/28/98
0706 c        write(1018,'(5(e10.3,2x),/, 4(e10.3,2x))')
0707 c     &           RCNNE,RCNND,RCNDN,RDIRT,rpd,
0708 c     &           RDECAY,RRES,RDD,RPP
0709 c        write(1018,'(6(e10.3,2x),/, 5(e10.3,2x))')
0710 c     &           NT*DT,RCNNE,RCNND,RCNDN,RDIRT,rpd,
0711 c     &           NT*DT,RDECAY,RRES,RDD,RPP
0712 cbz12/18/98end
0713 * PRINT OUT TIME-INTEGRATED KAON MULTIPLICITIES FROM DIFFERENT CHANNELS
0714 c       WRITE(1019,'(7(E10.3,2X))')NT*DT,RNNK,RDDK,RNDK,RPN,Rppk,
0715 c     &                           RNNK+RDDK+RNDK+RPN+Rppk
0716 *                                                                      *
0717 
0718         END IF
0719 *
0720 *       UPDATE BARYON DENSITY
0721 *
0722         CALL DENS(IPOT,MASS,NUM,OUTPAR)
0723 *
0724 *       UPDATE POSITIONS FOR ALL THE PARTICLES PRESENT AT THIS TIME
0725 *
0726        sumene=0
0727         ISO=0
0728         DO 201 MRUN=1,NUM
0729         ISO=ISO+MASSR(MRUN-1)
0730         DO 201 I0=1,MASSR(MRUN)
0731         I =I0+ISO
0732         ETOTAL = SQRT( E(I)**2 + P(1,I)**2 + P(2,I)**2 +P(3,I)**2 )
0733        sumene=sumene+etotal
0734 C for kaons, if there is a potential
0735 C CALCULATE THE ENERGY OF THE KAON ACCORDING TO THE IMPULSE APPROXIMATION
0736 C REFERENCE: B.A. LI AND C.M. KO, PHYS. REV. C 54 (1996) 3283. 
0737          if(kpoten.ne.0.and.lb(i).eq.23)then
0738              den=0.
0739               IX = NINT( R(1,I) )
0740               IY = NINT( R(2,I) )
0741               IZ = NINT( R(3,I) )
0742 clin-4/2008:
0743 c       IF (ABS(IX) .LT. MAXX .AND. ABS(IY) .LT. MAXX .AND.
0744 c     & ABS(IZ) .LT. MAXZ) den=rho(ix,iy,iz)
0745               IF(IX.LT.MAXX.AND.IY.LT.MAXX.AND.IZ.LT.MAXZ
0746      1             .AND.IX.GT.-MAXX.AND.IY.GT.-MAXX.AND.IZ.GT.-MAXZ)
0747      2             den=rho(ix,iy,iz)
0748 c         ecor=0.1973**2*0.255*kmul*4*3.14159*(1.+0.4396/0.938)
0749 c         etotal=sqrt(etotal**2+ecor*den)
0750 c** G.Q Li potential form with n_s = n_b and pot(n_0)=29 MeV, m^*=m
0751 c     GeV^2 fm^3
0752           akg = 0.1727
0753 c     GeV fm^3
0754           bkg = 0.333
0755          rnsg = den
0756          ecor = - akg*rnsg + (bkg*den)**2
0757          etotal = sqrt(etotal**2 + ecor)
0758          endif
0759 c
0760          if(kpoten.ne.0.and.lb(i).eq.21)then
0761              den=0.
0762               IX = NINT( R(1,I) )
0763               IY = NINT( R(2,I) )
0764               IZ = NINT( R(3,I) )
0765 clin-4/2008:
0766 c       IF (ABS(IX) .LT. MAXX .AND. ABS(IY) .LT. MAXX .AND.
0767 c     & ABS(IZ) .LT. MAXZ) den=rho(ix,iy,iz)
0768               IF(IX.LT.MAXX.AND.IY.LT.MAXX.AND.IZ.LT.MAXZ
0769      1             .AND.IX.GT.-MAXX.AND.IY.GT.-MAXX.AND.IZ.GT.-MAXZ)
0770      2             den=rho(ix,iy,iz)
0771 c* for song potential no effect on position
0772 c** G.Q Li potential form with n_s = n_b and pot(n_0)=29 MeV, m^*=m
0773 c     GeV^2 fm^3
0774           akg = 0.1727
0775 c     GeV fm^3
0776           bkg = 0.333
0777          rnsg = den
0778          ecor = - akg*rnsg + (bkg*den)**2
0779          etotal = sqrt(etotal**2 + ecor)
0780           endif
0781 c
0782 C UPDATE POSITIONS
0783           R(1,I) = R(1,I) + DT*P(1,I)/ETOTAL
0784           R(2,I) = R(2,I) + DT*P(2,I)/ETOTAL
0785           R(3,I) = R(3,I) + DT*P(3,I)/ETOTAL
0786 c use cyclic boundary conitions
0787             if ( cycbox.ne.0 ) then
0788               if ( r(1,i).gt. cycbox/2 ) r(1,i)=r(1,i)-cycbox
0789               if ( r(1,i).le.-cycbox/2 ) r(1,i)=r(1,i)+cycbox
0790               if ( r(2,i).gt. cycbox/2 ) r(2,i)=r(2,i)-cycbox
0791               if ( r(2,i).le.-cycbox/2 ) r(2,i)=r(2,i)+cycbox
0792               if ( r(3,i).gt. cycbox/2 ) r(3,i)=r(3,i)-cycbox
0793               if ( r(3,i).le.-cycbox/2 ) r(3,i)=r(3,i)+cycbox
0794             end if
0795 * UPDATE THE DELTA, N* AND PION COUNTERS
0796           LB1=LB(I)
0797 * 1. FOR DELTA++
0798         IF(LB1.EQ.9)LD1=LD1+1
0799 * 2. FOR DELTA+
0800         IF(LB1.EQ.8)LD2=LD2+1
0801 * 3. FOR DELTA0
0802         IF(LB1.EQ.7)LD3=LD3+1
0803 * 4. FOR DELTA-
0804         IF(LB1.EQ.6)LD4=LD4+1
0805 * 5. FOR N*+(1440)
0806         IF(LB1.EQ.11)LN1=LN1+1
0807 * 6. FOR N*0(1440)
0808         IF(LB1.EQ.10)LN2=LN2+1
0809 * 6.1 FOR N*(1535)
0810        IF((LB1.EQ.13).OR.(LB1.EQ.12))LN5=LN5+1
0811 * 6.2 FOR ETA
0812        IF(LB1.EQ.0)LE=LE+1
0813 * 6.3 FOR KAONS
0814        IF(LB1.EQ.23)LKAON=LKAON+1
0815 clin-11/09/00: FOR KAON*
0816        IF(LB1.EQ.30)LKAONS=LKAONS+1
0817 
0818 * UPDATE PION COUNTER
0819 * 7. FOR PION+
0820         IF(LB1.EQ.5)LP1=LP1+1
0821 * 8. FOR PION0
0822         IF(LB1.EQ.4)LP2=LP2+1
0823 * 9. FOR PION-
0824         IF(LB1.EQ.3)LP3=LP3+1
0825 201     CONTINUE
0826         LP=LP1+LP2+LP3
0827         LD=LD1+LD2+LD3+LD4
0828         LN=LN1+LN2
0829         ALP=FLOAT(LP)/FLOAT(NUM)
0830         ALD=FLOAT(LD)/FLOAT(NUM)
0831         ALN=FLOAT(LN)/FLOAT(NUM)
0832        ALN5=FLOAT(LN5)/FLOAT(NUM)
0833         ATOTAL=ALP+ALD+ALN+0.5*ALN5
0834        ALE=FLOAT(LE)/FLOAT(NUM)
0835        ALKAON=FLOAT(LKAON)/FLOAT(NUM)
0836 * UPDATE MOMENTUM DUE TO COULOMB INTERACTION 
0837         if (icou .eq. 1) then
0838 *       with Coulomb interaction
0839           iso=0
0840           do 1026 irun = 1,num
0841             iso=iso+massr(irun-1)
0842             do 1021 il = 1,massr(irun)
0843                temp(1,il) = 0.
0844                temp(2,il) = 0.
0845                temp(3,il) = 0.
0846  1021       continue
0847             do 1023 il = 1, massr(irun)
0848               i=iso+il
0849               if (zet(lb(i)).ne.0) then
0850                 do 1022 jl = 1,il-1
0851                   j=iso+jl
0852                   if (zet(lb(j)).ne.0) then
0853                     ddx=r(1,i)-r(1,j)
0854                     ddy=r(2,i)-r(2,j)
0855                     ddz=r(3,i)-r(3,j)
0856                     rdiff = sqrt(ddx**2+ddy**2+ddz**2)
0857                     if (rdiff .le. 1.) rdiff = 1.
0858                     grp=zet(lb(i))*zet(lb(j))/rdiff**3
0859                     ddx=ddx*grp
0860                     ddy=ddy*grp
0861                     ddz=ddz*grp
0862                     temp(1,il)=temp(1,il)+ddx
0863                     temp(2,il)=temp(2,il)+ddy
0864                     temp(3,il)=temp(3,il)+ddz
0865                     temp(1,jl)=temp(1,jl)-ddx
0866                     temp(2,jl)=temp(2,jl)-ddy
0867                     temp(3,jl)=temp(3,jl)-ddz
0868                   end if
0869  1022          continue
0870               end if
0871  1023      continue
0872             do 1025 il = 1,massr(irun)
0873               i= iso+il
0874               if (zet(lb(i)).ne.0) then
0875                 do 1024 idir = 1,3
0876                   p(idir,i) = p(idir,i) + temp(idir,il)
0877      &                                    * dt * 0.00144
0878  1024          continue
0879               end if
0880  1025      continue
0881  1026   continue
0882         end if
0883 *       In the following, we shall:  
0884 *       (1) UPDATE MOMENTA DUE TO THE MEAN FIELD FOR BARYONS AND KAONS,
0885 *       (2) calculate the thermalization, temperature in a sphere of 
0886 *           radius 2.0 fm AROUND THE CM
0887 *       (3) AND CALCULATE THE NUMBER OF PARTICLES IN THE HIGH DENSITY REGION 
0888        spt=0
0889        spz=0
0890        ncen=0
0891        ekin=0
0892           NLOST = 0
0893           MEAN=0
0894          nquark=0
0895          nbaryn=0
0896 csp06/18/01
0897            rads = 2.
0898            zras = 0.1
0899            denst = 0.
0900            edenst = 0.
0901 csp06/18/01 end
0902           DO 6000 IRUN = 1,NUM
0903           MEAN=MEAN+MASSR(IRUN-1)
0904           DO 5800 J = 1,MASSR(irun)
0905           I=J+MEAN
0906 c
0907 csp06/18/01
0908            radut = sqrt(r(1,i)**2+r(2,i)**2)
0909        if( radut .le. rads )then
0910         if( abs(r(3,i)) .le. zras*nt*dt )then
0911 c         vols = 3.14159*radut**2*abs(r(3,i))      ! cylinder pi*r^2*l
0912 c     cylinder pi*r^2*l
0913          vols = 3.14159*rads**2*zras
0914          engs=sqrt(p(1,i)**2+p(2,i)**2+p(3,i)**2+e(i)**2)
0915          gammas=1.
0916          if(e(i).ne.0.)gammas=engs/e(i)
0917 c     rho
0918          denst = denst + 1./gammas/vols
0919 c     energy density
0920          edenst = edenst + engs/gammas/gammas/vols
0921         endif
0922        endif
0923 csp06/18/01 end
0924 c
0925          drr=sqrt(r(1,i)**2+r(2,i)**2+r(3,i)**2)
0926          if(drr.le.2.0)then
0927          spt=spt+p(1,i)**2+p(2,i)**2
0928          spz=spz+p(3,i)**2
0929          ncen=ncen+1
0930          ekin=ekin+sqrt(p(1,i)**2+p(2,i)**2+p(3,i)**2+e(i)**2)-e(i)
0931          endif
0932               IX = NINT( R(1,I) )
0933               IY = NINT( R(2,I) )
0934               IZ = NINT( R(3,I) )
0935 C calculate the No. of particles in the high density region
0936 clin-4/2008:
0937 c              IF (ABS(IX) .LT. MAXX .AND. ABS(IY) .LT. MAXX .AND.
0938 c     & ABS(IZ) .LT. MAXZ) THEN
0939               IF(IX.LT.MAXX.AND.IY.LT.MAXX.AND.IZ.LT.MAXZ
0940      1          .AND.IX.GT.-MAXX.AND.IY.GT.-MAXX.AND.IZ.GT.-MAXZ) THEN
0941        if(rho(ix,iy,iz)/0.168.gt.dencut)go to 5800
0942        if((rho(ix,iy,iz)/0.168.gt.5.).and.(e(i).gt.0.9))
0943      &  nbaryn=nbaryn+1
0944        if(pel(ix,iy,iz).gt.2.0)nquark=nquark+1
0945        endif
0946 c*
0947 c If there is a kaon potential, propogating kaons 
0948         if(kpoten.ne.0.and.lb(i).eq.23)then
0949         den=0.
0950 clin-4/2008:
0951 c       IF (ABS(IX) .LT. MAXX .AND. ABS(IY) .LT. MAXX .AND.
0952 c     & ABS(IZ) .LT. MAXZ)then
0953         IF(IX.LT.MAXX.AND.IY.LT.MAXX.AND.IZ.LT.MAXZ
0954      1       .AND.IX.GT.-MAXX.AND.IY.GT.-MAXX.AND.IZ.GT.-MAXZ) THEN
0955            den=rho(ix,iy,iz)
0956 c        ecor=0.1973**2*0.255*kmul*4*3.14159*(1.+0.4396/0.938)
0957 c       etotal=sqrt(P(1,i)**2+p(2,I)**2+p(3,i)**2+e(i)**2+ecor*den)
0958 c** for G.Q Li potential form with n_s = n_b and pot(n_0)=29 MeV
0959 c     !! GeV^2 fm^3
0960             akg = 0.1727
0961 c     !! GeV fm^3
0962             bkg = 0.333
0963           rnsg = den
0964           ecor = - akg*rnsg + (bkg*den)**2
0965           etotal = sqrt(P(1,i)**2+p(2,I)**2+p(3,i)**2+e(i)**2 + ecor)
0966           ecor = - akg + 2.*bkg**2*den + 2.*bkg*etotal
0967 c** G.Q. Li potential (END)           
0968         CALL GRADUK(IX,IY,IZ,GRADXk,GRADYk,GRADZk)
0969         P(1,I) = P(1,I) - DT * GRADXk*ecor/(2.*etotal)
0970         P(2,I) = P(2,I) - DT * GRADYk*ecor/(2.*etotal)
0971         P(3,I) = P(3,I) - DT * GRADZk*ecor/(2.*etotal)
0972         endif
0973          endif
0974 c
0975         if(kpoten.ne.0.and.lb(i).eq.21)then
0976          den=0.
0977 clin-4/2008:
0978 c           IF (ABS(IX) .LT. MAXX .AND. ABS(IY) .LT. MAXX .AND.
0979 c     &        ABS(IZ) .LT. MAXZ)then
0980          IF(IX.LT.MAXX.AND.IY.LT.MAXX.AND.IZ.LT.MAXZ
0981      1        .AND.IX.GT.-MAXX.AND.IY.GT.-MAXX.AND.IZ.GT.-MAXZ) THEN
0982                den=rho(ix,iy,iz)
0983         CALL GRADUK(IX,IY,IZ,GRADXk,GRADYk,GRADZk)
0984 c        P(1,I) = P(1,I) - DT * GRADXk*(-0.12/0.168)    !! song potential
0985 c        P(2,I) = P(2,I) - DT * GRADYk*(-0.12/0.168)
0986 c        P(3,I) = P(3,I) - DT * GRADZk*(-0.12/0.168)
0987 c** for G.Q Li potential form with n_s = n_b and pot(n_0)=29 MeV
0988 c    !! GeV^2 fm^3
0989             akg = 0.1727
0990 c     !! GeV fm^3
0991             bkg = 0.333
0992           rnsg = den
0993           ecor = - akg*rnsg + (bkg*den)**2
0994           etotal = sqrt(P(1,i)**2+p(2,I)**2+p(3,i)**2+e(i)**2 + ecor)
0995           ecor = - akg + 2.*bkg**2*den - 2.*bkg*etotal
0996         P(1,I) = P(1,I) - DT * GRADXk*ecor/(2.*etotal)
0997         P(2,I) = P(2,I) - DT * GRADYk*ecor/(2.*etotal)
0998         P(3,I) = P(3,I) - DT * GRADZk*ecor/(2.*etotal)
0999 c** G.Q. Li potential (END)           
1000         endif
1001          endif
1002 c
1003 c for other mesons, there is no potential
1004        if(j.gt.mass)go to 5800         
1005 c  with mean field interaction for baryons   (open endif below) !!sp05
1006 **      if( (iabs(lb(i)).eq.1.or.iabs(lb(i)).eq.2) .or.
1007 **    &     (iabs(lb(i)).ge.6.and.iabs(lb(i)).le.17) .or.
1008 **    &      iabs(lb(i)).eq.40.or.iabs(lb(i)).eq.41 )then  
1009         IF (ICOLL .NE. -1) THEN
1010 * check if the baryon has run off the lattice
1011 *             IX0=NINT(R(1,I)/DX)
1012 *             IY0=NINT(R(2,I)/DY)
1013 *             IZ0=NINT(R(3,I)/DZ)
1014 *             IPX0=NINT(P(1,I)/DPX)
1015 *             IPY0=NINT(P(2,I)/DPY)
1016 *             IPZ0=NINT(P(3,I)/DPZ)
1017 *      if ( (abs(ix0).gt.mx) .or. (abs(iy0).gt.my) .or. (abs(iz0).gt.mz)
1018 *     &  .or. (abs(ipx0).gt.mpx) .or. (abs(ipy0) 
1019 *     &  .or. (ipz0.lt.-mpz) .or. (ipz0.gt.mpzp)) NLOST=NLOST+1
1020 clin-4/2008:
1021 c              IF (ABS(IX) .LT. MAXX .AND. ABS(IY) .LT. MAXX .AND.
1022 c     &                                    ABS(IZ) .LT. MAXZ     ) THEN
1023            IF(IX.LT.MAXX.AND.IY.LT.MAXX.AND.IZ.LT.MAXZ
1024      1          .AND.IX.GT.-MAXX.AND.IY.GT.-MAXX.AND.IZ.GT.-MAXZ) THEN
1025                 CALL GRADU(IPOT,IX,IY,IZ,GRADX,GRADY,GRADZ)
1026               TZ=0.
1027               GRADXN=0
1028               GRADYN=0
1029               GRADZN=0
1030               GRADXP=0
1031               GRADYP=0
1032               GRADZP=0
1033              IF(ICOU.EQ.1)THEN
1034                 CALL GRADUP(IX,IY,IZ,GRADXP,GRADYP,GRADZP)
1035                 CALL GRADUN(IX,IY,IZ,GRADXN,GRADYN,GRADZN)
1036                IF(ZET(LB(I)).NE.0)TZ=-1
1037                IF(ZET(LB(I)).EQ.0)TZ= 1
1038              END IF
1039            if(iabs(lb(i)).ge.14.and.iabs(lb(i)).le.17)then
1040               facl = 2./3.
1041             elseif(iabs(lb(i)).eq.40.or.iabs(lb(i)).eq.41)then
1042               facl = 1./3.
1043             else
1044               facl = 1.
1045             endif
1046         P(1,I) = P(1,I) - facl*DT * (GRADX+asy*(GRADXN-GRADXP)*TZ)
1047         P(2,I) = P(2,I) - facl*DT * (GRADY+asy*(GRADYN-GRADYP)*TZ)
1048         P(3,I) = P(3,I) - facl*DT * (GRADZ+asy*(GRADZN-GRADZP)*TZ)
1049                 end if                                                       
1050               ENDIF
1051 **          endif          !!sp05     
1052  5800       CONTINUE
1053  6000       CONTINUE
1054 c print out the average no. of particles in regions where the local 
1055 c baryon density is higher than 5*rho0 
1056 c       write(1072,'(e10.3,2x,e10.3)')nt*dt,float(nbaryn)/float(num)
1057 C print out the average no. of particles in regions where the local 
1058 c energy density is higher than 2 GeV/fm^3. 
1059 c       write(1073,'(e10.3,2x,e10.3)')nt*dt,float(nquark)/float(num)
1060 c print out the no. of particles that have run off the lattice
1061 *          IF (NLOST .NE. 0 .AND. (NT/NFREQ)*NFREQ .EQ. NT) THEN
1062 *            WRITE(12,'(5X,''***'',I7,'' TESTPARTICLES LOST AFTER '',
1063 *     &                   ''TIME STEP NUMBER'',I4)') NLOST, NT
1064 *         END IF
1065 *
1066 *       update phase space density
1067 *        call platin(mode,mass,num,dx,dy,dz,dpx,dpy,dpz,fnorm)
1068 *
1069 *       CONTROL-PRINTOUT OF CONFIGURATION (IF REQUIRED)
1070 *
1071 *        if (inout(5) .eq. 2) CALL ENERGY(NT,IPOT,NUM,MASS,EMIN,EMAX)
1072 *
1073 * 
1074 * print out central baryon density as a function of time
1075        CDEN=RHO(0,0,0)/0.168
1076 cc        WRITE(1002,990)FLOAT(NT)*DT,CDEN
1077 c        WRITE(1002,1990)FLOAT(NT)*DT,CDEN,denst/real(num)
1078 * print out the central energy density as a function of time
1079 cc        WRITE(1003,990)FLOAT(NT)*DT,PEL(0,0,0)
1080 c        WRITE(1003,1990)FLOAT(NT)*DT,PEL(0,0,0),edenst/real(num)
1081 * print out the no. of pion-like particles as a function of time 
1082 c        WRITE(1004,9999)FLOAT(NT)*DT,ALD,ALN,ALP,ALN5,
1083 c     &               ALD+ALN+ALP+0.5*ALN5
1084 * print out the no. of eta-like particles as a function of time
1085 c        WRITE(1005,991)FLOAT(NT)*DT,ALN5,ALE,ALE+0.5*ALN5
1086 c990       FORMAT(E10.3,2X,E10.3)
1087 c1990       FORMAT(E10.3,2X,E10.3,2X,E10.3)
1088 c991       FORMAT(E10.3,2X,E10.3,2X,E10.3,2X,E10.3)
1089 c9999    FORMAT(e10.3,2X,e10.3,2X,E10.3,2X,E10.3,2X,
1090 c     1  E10.3,2X,E10.3)
1091 C THE FOLLOWING OUTPUTS CAN BE TURNED ON/OFF by setting icflow and icrho=0  
1092 c print out the baryon and meson density matrix in the reaction plane
1093         IF ((NT/NFREQ)*NFREQ .EQ. NT ) THEN
1094        if(icflow.eq.1)call flow(nt)
1095 cbz11/18/98
1096 c       if(icrho.ne.1)go to 10000 
1097 c       if (icrho .eq. 1) then 
1098 cbz11/18/98end
1099 c       do ix=-10,10
1100 c       do iz=-10,10
1101 c       write(1053,992)ix,iz,rho(ix,0,iz)/0.168
1102 c       write(1054,992)ix,iz,pirho(ix,0,iz)/0.168
1103 c       write(1055,992)ix,iz,pel(ix,0,iz)
1104 c       end do
1105 c       end do
1106 cbz11/18/98
1107 c        end if
1108 cbz11/18/98end
1109 c992       format(i3,i3,e11.4)
1110        endif
1111 c print out the ENERGY density matrix in the reaction plane
1112 C CHECK LOCAL MOMENTUM EQUILIBRIUM IN EACH CELL, 
1113 C AND PERFORM ON-LINE FLOW ANALYSIS AT A FREQUENCY OF NFREQ
1114 c        IF ((NT/NFREQ)*NFREQ .EQ. NT ) THEN
1115 c       call flow(nt)
1116 c       call equ(ipot,mass,num,outpar)
1117 c       do ix=-10,10
1118 c       do iz=-10,10
1119 c       write(1055,992)ix,iz,pel(ix,0,iz)
1120 c       write(1056,992)ix,iz,rxy(ix,0,iz)
1121 c       end do
1122 c       end do
1123 c       endif
1124 C calculate the volume of high BARYON AND ENERGY density 
1125 C matter as a function of time
1126 c       vbrho=0.
1127 c       verho=0.
1128 c       do ix=-20,20
1129 c       do iy=-20,20
1130 c       do iz=-20,20
1131 c       if(rho(ix,iy,iz)/0.168.gt.5.)vbrho=vbrho+1.
1132 c       if(pel(ix,iy,iz).gt.2.)verho=verho+1.
1133 c       end do
1134 c       end do
1135 c       end do
1136 c       write(1081,993)dt*nt,vbrho
1137 c       write(1082,993)dt*nt,verho
1138 c993       format(e11.4,2x,e11.4)
1139 *-----------------------------------------------------------------------
1140 cbz11/16/98
1141 c.....for read-in initial conditions produce particles from read-in 
1142 c.....common block.
1143 c.....note that this part is only for cascade with number of test particles
1144 c.....NUM = 1.
1145       IF (IAPAR2(1) .NE. 1) THEN
1146          CT = NT * DT
1147 cbz12/22/98
1148 c         NP = MASSR(1)
1149 c         DO WHILE (FTAR(NPI) .GT. CT - DT .AND. FTAR(NPI) .LE. CT)
1150 c            NP = NP + 1
1151 c            R(1, NP) = GXAR(NPI) + PXAR(NPI) / PEAR(NPI) * (CT - FTAR(NPI))
1152 c            R(2, NP) = GYAR(NPI) + PYAR(NPI) / PEAR(NPI) * (CT - FTAR(NPI))
1153 c            R(3, NP) = GZAR(NPI) + PZAR(NPI) / PEAR(NPI) * (CT - FTAR(NPI))
1154 c            P(1, NP) = PXAR(NPI)
1155 c            P(2, NP) = PYAR(NPI)
1156 c            P(3, NP) = PZAR(NPI)
1157 c            E(NP) = XMAR(NPI)
1158 c            LB(NP) = IARFLV(ITYPAR(NPI))
1159 c            NPI = NPI + 1
1160 c         END DO
1161 c         MASSR(1) = NP
1162          IA = 0
1163          DO 1028 IRUN = 1, NUM
1164             DO 1027 IC = 1, MASSR(IRUN)
1165                IE = IA + IC
1166                RT(1, IC, IRUN) = R(1, IE)
1167                RT(2, IC, IRUN) = R(2, IE)
1168                RT(3, IC, IRUN) = R(3, IE)
1169                PT(1, IC, IRUN) = P(1, IE)
1170                PT(2, IC, IRUN) = P(2, IE)
1171                PT(3, IC, IRUN) = P(3, IE)
1172                ET(IC, IRUN) = E(IE)
1173                LT(IC, IRUN) = LB(IE)
1174 c         !! sp 12/19/00
1175                PROT(IC, IRUN) = PROPER(IE)
1176 clin-5/2008:
1177                dpertt(IC, IRUN)=dpertp(IE)
1178  1027       CONTINUE
1179             NP = MASSR(IRUN)
1180             NP1 = NPI(IRUN)
1181 
1182 cbz10/05/99
1183 c            DO WHILE (FT1(NP1, IRUN) .GT. CT - DT .AND. 
1184 c     &           FT1(NP1, IRUN) .LE. CT)
1185 cbz10/06/99
1186 c            DO WHILE (NPI(IRUN).LE.MULTI1(IRUN).AND.
1187 cbz10/06/99 end
1188 clin-11/13/00 finally read in all unformed particles and do the decays in ART:
1189 c           DO WHILE (NP1.LE.MULTI1(IRUN).AND.
1190 c    &           FT1(NP1, IRUN) .GT. CT - DT .AND. 
1191 c    &           FT1(NP1, IRUN) .LE. CT)
1192 c
1193                ctlong = ct
1194              if(nt .eq. (ntmax-1))then
1195                ctlong = 1.E30
1196              elseif(nt .eq. ntmax)then
1197                go to 1111
1198              endif
1199             DO WHILE (NP1.LE.MULTI1(IRUN).AND.
1200      &           FT1(NP1, IRUN) .GT. (CT - DT) .AND. 
1201      &           FT1(NP1, IRUN) .LE. ctlong)
1202                NP = NP + 1
1203                UDT = (CT - FT1(NP1, IRUN)) / EE1(NP1, IRUN)
1204 clin-10/28/03 since all unformed hadrons at time ct are read in at nt=ntmax-1, 
1205 c     their positions should not be propagated to time ct:
1206                if(nt.eq.(ntmax-1)) then
1207                   ftsvt(NP,IRUN)=FT1(NP1, IRUN)
1208                   if(FT1(NP1, IRUN).gt.ct) UDT=0.
1209                endif
1210                RT(1, NP, IRUN) = GX1(NP1, IRUN) + 
1211      &              PX1(NP1, IRUN) * UDT
1212                RT(2, NP, IRUN) = GY1(NP1, IRUN) + 
1213      &              PY1(NP1, IRUN) * UDT
1214                RT(3, NP, IRUN) = GZ1(NP1, IRUN) + 
1215      &              PZ1(NP1, IRUN) * UDT
1216                PT(1, NP, IRUN) = PX1(NP1, IRUN)
1217                PT(2, NP, IRUN) = PY1(NP1, IRUN)
1218                PT(3, NP, IRUN) = PZ1(NP1, IRUN)
1219                ET(NP, IRUN) = XM1(NP1, IRUN)
1220                LT(NP, IRUN) = IARFLV(ITYP1(NP1, IRUN))
1221 clin-5/2008:
1222                dpertt(NP,IRUN)=dpp1(NP1,IRUN)
1223 clin-4/30/03 ctest off 
1224 c     record initial phi,K*,Lambda(1520) resonances formed during the timestep:
1225 c               if(LT(NP, IRUN).eq.29.or.iabs(LT(NP, IRUN)).eq.30)
1226 c     1              write(17,112) 'formed',LT(NP, IRUN),PX1(NP1, IRUN),
1227 c     2 PY1(NP1, IRUN),PZ1(NP1, IRUN),XM1(NP1, IRUN),nt
1228 c 112           format(a10,1x,I4,4(1x,f9.3),1x,I4)
1229 c
1230                NP1 = NP1 + 1
1231 c     !! sp 12/19/00
1232                PROT(NP, IRUN) = 1.
1233             END DO
1234 *
1235  1111      continue
1236             NPI(IRUN) = NP1
1237             IA = IA + MASSR(IRUN)
1238             MASSR(IRUN) = NP
1239  1028    CONTINUE
1240          IA = 0
1241          DO 1030 IRUN = 1, NUM
1242             IA = IA + MASSR(IRUN - 1)
1243             DO 1029 IC = 1, MASSR(IRUN)
1244                IE = IA + IC
1245                R(1, IE) = RT(1, IC, IRUN)
1246                R(2, IE) = RT(2, IC, IRUN)
1247                R(3, IE) = RT(3, IC, IRUN)
1248                P(1, IE) = PT(1, IC, IRUN)
1249                P(2, IE) = PT(2, IC, IRUN)
1250                P(3, IE) = PT(3, IC, IRUN)
1251                E(IE) = ET(IC, IRUN)
1252                LB(IE) = LT(IC, IRUN)
1253 c     !! sp 12/19/00
1254                PROPER(IE) = PROT(IC, IRUN)
1255                if(nt.eq.(ntmax-1)) ftsv(IE)=ftsvt(IC,IRUN)
1256 clin-5/2008:
1257                dpertp(IE)=dpertt(IC, IRUN)
1258  1029       CONTINUE
1259 clin-3/2009 Moved here to better take care of freezeout spacetime:
1260             call hbtout(MASSR(IRUN),nt,ntmax)
1261  1030    CONTINUE
1262 cbz12/22/98end
1263       END IF
1264 cbz11/16/98end
1265 
1266 clin-5/2009 ctest off:
1267 c      call flowh(ct) 
1268 
1269 10000       continue
1270 
1271 *                                                                      *
1272 *       ==============  END OF TIME STEP LOOP   ================       *
1273 
1274 ************************************
1275 *     WRITE OUT particle's MOMENTA ,and/OR COORDINATES ,
1276 *     label and/or their local baryon density in the final state
1277         iss=0
1278         do 1032 lrun=1,num
1279            iss=iss+massr(lrun-1)
1280            do 1031 l0=1,massr(lrun)
1281               ipart=iss+l0
1282  1031      continue
1283  1032   continue
1284 
1285 cbz11/16/98
1286       IF (IAPAR2(1) .NE. 1) THEN
1287 cbz12/22/98
1288 c        NSH = MASSR(1) - NPI + 1
1289 c        IAINT2(1) = IAINT2(1) + NSH
1290 c.....to shift the unformed particles to the end of the common block
1291 c        IF (NSH .GT. 0) THEN
1292 c           IB = IAINT2(1)
1293 c           IE = MASSR(1) + 1
1294 c           II = -1
1295 c        ELSE IF (NSH .LT. 0) THEN
1296 c           IB = MASSR(1) + 1
1297 c           IE = IAINT2(1)
1298 c           II = 1
1299 c        END IF
1300 c        IF (NSH .NE. 0) THEN
1301 c           DO I = IB, IE, II
1302 c              J = I - NSH
1303 c              ITYPAR(I) = ITYPAR(J)
1304 c              GXAR(I) = GXAR(J)
1305 c              GYAR(I) = GYAR(J)
1306 c              GZAR(I) = GZAR(J)
1307 c              FTAR(I) = FTAR(J)
1308 c              PXAR(I) = PXAR(J)
1309 c              PYAR(I) = PYAR(J)
1310 c              PZAR(I) = PZAR(J)
1311 c              PEAR(I) = PEAR(J)
1312 c              XMAR(I) = XMAR(J)
1313 c           END DO
1314 c        END IF
1315 
1316 c.....to copy ART particle info to COMMON /ARPRC/
1317 c        DO I = 1, MASSR(1)
1318 c           ITYPAR(I) = INVFLV(LB(I))
1319 c           GXAR(I) = R(1, I)
1320 c           GYAR(I) = R(2, I)
1321 c           GZAR(I) = R(3, I)
1322 c           FTAR(I) = CT
1323 c           PXAR(I) = P(1, I)
1324 c           PYAR(I) = P(2, I)
1325 c           PZAR(I) = P(3, I)
1326 c           XMAR(I) = E(I)
1327 c           PEAR(I) = SQRT(PXAR(I) ** 2 + PYAR(I) ** 2 + PZAR(I) ** 2
1328 c     &        + XMAR(I) ** 2)
1329 c        END DO
1330         IA = 0
1331         DO 1035 IRUN = 1, NUM
1332            IA = IA + MASSR(IRUN - 1)
1333            NP1 = NPI(IRUN)
1334            NSH = MASSR(IRUN) - NP1 + 1
1335            MULTI1(IRUN) = MULTI1(IRUN) + NSH
1336 c.....to shift the unformed particles to the end of the common block
1337            IF (NSH .GT. 0) THEN
1338               IB = MULTI1(IRUN)
1339               IE = MASSR(IRUN) + 1
1340               II = -1
1341            ELSE IF (NSH .LT. 0) THEN
1342               IB = MASSR(IRUN) + 1
1343               IE = MULTI1(IRUN)
1344               II = 1
1345            END IF
1346            IF (NSH .NE. 0) THEN
1347               DO 1033 I = IB, IE, II
1348                  J = I - NSH
1349                  ITYP1(I, IRUN) = ITYP1(J, IRUN)
1350                  GX1(I, IRUN) = GX1(J, IRUN)
1351                  GY1(I, IRUN) = GY1(J, IRUN)
1352                  GZ1(I, IRUN) = GZ1(J, IRUN)
1353                  FT1(I, IRUN) = FT1(J, IRUN)
1354                  PX1(I, IRUN) = PX1(J, IRUN)
1355                  PY1(I, IRUN) = PY1(J, IRUN)
1356                  PZ1(I, IRUN) = PZ1(J, IRUN)
1357                  EE1(I, IRUN) = EE1(J, IRUN)
1358                  XM1(I, IRUN) = XM1(J, IRUN)
1359 c     !! sp 12/19/00
1360                  PRO1(I, IRUN) = PRO1(J, IRUN)
1361 clin-5/2008:
1362                  dpp1(I,IRUN)=dpp1(J,IRUN)
1363  1033         CONTINUE
1364            END IF
1365            
1366 c.....to copy ART particle info to COMMON /ARPRC1/
1367            DO 1034 I = 1, MASSR(IRUN)
1368               IB = IA + I
1369               ITYP1(I, IRUN) = INVFLV(LB(IB))
1370               GX1(I, IRUN) = R(1, IB)
1371               GY1(I, IRUN) = R(2, IB)
1372               GZ1(I, IRUN) = R(3, IB)
1373 clin-10/28/03:
1374 c since all unformed hadrons at time ct are read in at nt=ntmax-1, 
1375 c their formation time ft1 should be kept to determine their freezeout(x,t):
1376 c              FT1(I, IRUN) = CT
1377               if(FT1(I, IRUN).lt.CT) FT1(I, IRUN) = CT
1378               PX1(I, IRUN) = P(1, IB)
1379               PY1(I, IRUN) = P(2, IB)
1380               PZ1(I, IRUN) = P(3, IB)
1381               XM1(I, IRUN) = E(IB)
1382               EE1(I, IRUN) = SQRT(PX1(I, IRUN) ** 2 + 
1383      &             PY1(I, IRUN) ** 2 +
1384      &             PZ1(I, IRUN) ** 2 + 
1385      &             XM1(I, IRUN) ** 2)
1386 c     !! sp 12/19/00
1387               PRO1(I, IRUN) = PROPER(IB)
1388  1034      CONTINUE
1389  1035   CONTINUE
1390 cbz12/22/98end
1391       END IF
1392 cbz11/16/98end
1393 c
1394 **********************************
1395 *                                                                      *
1396 *       ======= END OF MANY LOOPS OVER IMPACT PARAMETERS ==========    *
1397 *                                                               *
1398 **********************************
1399 50000   CONTINUE
1400 *
1401 *-----------------------------------------------------------------------
1402 *                       ==== ART COMPLETED ====
1403 *-----------------------------------------------------------------------
1404 cbz11/16/98
1405 c      STOP
1406       RETURN
1407 cbz11/16/98end
1408       END
1409 **********************************
1410       subroutine coulin(masspr,massta,NUM)
1411 *                                                                      *
1412 *     purpose:   initialization of array zet() and lb() for all runs  *
1413 *                lb(i) = 1   =>  proton                               *
1414 *                lb(i) = 2   =>  neutron                              *
1415 **********************************
1416         integer  zta,zpr
1417         PARAMETER (MAXSTR=150001)
1418         common  /EE/ ID(MAXSTR),LB(MAXSTR)
1419 cc      SAVE /EE/
1420         COMMON  /ZZ/ ZTA,ZPR
1421 cc      SAVE /zz/
1422       SAVE   
1423         MASS=MASSTA+MASSPR
1424         DO 500 IRUN=1,NUM
1425         do 100 i = 1+(IRUN-1)*MASS,zta+(IRUN-1)*MASS
1426         LB(i) = 1
1427   100   continue
1428         do 200 i = zta+1+(IRUN-1)*MASS,massta+(IRUN-1)*MASS
1429         LB(i) = 2
1430   200   continue
1431         do 300 i = massta+1+(IRUN-1)*MASS,massta+zpr+(IRUN-1)*MASS
1432         LB(i) = 1
1433   300   continue
1434         do 400 i = massta+zpr+1+(IRUN-1)*MASS,
1435      1  massta+masspr+(IRUN-1)*MASS
1436         LB(i) = 2
1437   400   continue
1438   500   CONTINUE
1439         return
1440         end
1441 **********************************
1442 *                                                                      *
1443       SUBROUTINE RELCOL(LCOLL,LBLOC,LCNNE,LDD,LPP,lppk,
1444      &LPN,lpd,lrho,lomega,LKN,LNNK,LDDK,LNDK,LCNND,LCNDN,
1445      &LDIRT,LDECAY,LRES,LDOU,LDDRHO,LNNRHO,LNNOM,
1446      &NT,ntmax,sp,akaon,sk)
1447 *                                                                      *
1448 *       PURPOSE:    CHECK CONDITIONS AND CALCULATE THE KINEMATICS      * 
1449 *                   FOR BINARY COLLISIONS AMONG PARTICLES              *
1450 *                                 - RELATIVISTIC FORMULA USED          *
1451 *                                                                      *
1452 *       REFERENCES: HAGEDORN, RELATIVISTIC KINEMATICS (1963)           *
1453 *                                                                      *
1454 *       VARIABLES:                                                     *
1455 *         MASSPR  - NUMBER OF NUCLEONS IN PROJECTILE   (INTEGER,INPUT) *
1456 *         MASSTA  - NUMBER OF NUCLEONS IN TARGET       (INTEGER,INPUT) *
1457 *         NUM     - NUMBER OF TESTPARTICLES PER NUCLEON(INTEGER,INPUT) *
1458 *         ISEED   - SEED FOR RANDOM NUMBER GENERATOR   (INTEGER,INPUT) *
1459 *         IAVOID  - (= 1 => AVOID FIRST CLLISIONS WITHIN THE SAME      *
1460 *                   NUCLEUS, ELSE ALL COLLISIONS)      (INTEGER,INPUT) *
1461 *         DELTAR  - MAXIMUM SPATIAL DISTANCE FOR WHICH A COLLISION     *
1462 *                   STILL CAN OCCUR                       (REAL,INPUT) *
1463 *         DT      - TIME STEP SIZE                        (REAL,INPUT) *
1464 *         LCOLL   - NUMBER OF COLLISIONS              (INTEGER,OUTPUT) *
1465 *         LBLOC   - NUMBER OF PULI-BLOCKED COLLISIONS (INTEGER,OUTPUT) *
1466 *         LCNNE   - NUMBER OF ELASTIC COLLISION       (INTEGER,OUTPUT) *
1467 *         LCNND   - NUMBER OF N+N->N+DELTA REACTION   (INTEGER,OUTPUT) *
1468 *         LCNDN   - NUMBER OF N+DELTA->N+N REACTION   (INTEGER,OUTPUT) *
1469 *         LDD     - NUMBER OF RESONANCE+RESONANCE COLLISIONS
1470 *         LPP     - NUMBER OF PION+PION elastic COLIISIONS
1471 *         lppk    - number of pion(RHO,OMEGA)+pion(RHO,OMEGA)
1472 *                   -->K+K- collisions
1473 *         LPN     - NUMBER OF PION+N-->KAON+X
1474 *         lpd     - number of pion+n-->delta+pion
1475 *         lrho    - number of pion+n-->Delta+rho
1476 *         lomega  - number of pion+n-->Delta+omega
1477 *         LKN     - NUMBER OF KAON RESCATTERINGS
1478 *         LNNK    - NUMBER OF bb-->kAON PROCESS
1479 *         LDDK    - NUMBER OF DD-->KAON PROCESS
1480 *         LNDK    - NUMBER OF ND-->KAON PROCESS
1481 *         LB(I) IS USED TO LABEL PARTICLE'S CHARGE STATE
1482 *         LB(I)   = 
1483 cbali2/7/99 
1484 *                 -45 Omega baryon(bar)
1485 *                 -41 cascade0(bar)
1486 *                 -40 cascade-(bar)
1487 clin-11/07/00:
1488 *                 -30 K*-
1489 *                 -17 sigma+(bar)
1490 *                 -16 sigma0(bar)
1491 *                 -15 sigma-(bar)
1492 *                 -14 LAMBDA(bar)
1493 clin-8/29/00
1494 *                 -13 anti-N*(+1)(1535),s_11
1495 *                 -12 anti-N*0(1535),s_11
1496 *                 -11 anti-N*(+1)(1440),p_11
1497 *                 -10 anti-N*0(1440), p_11
1498 *                  -9 anti-DELTA+2
1499 *                  -8 anti-DELTA+1
1500 *                  -7 anti-DELTA0
1501 *                  -6 anti-DELTA-1
1502 *
1503 *                  -2 antineutron 
1504 *                  -1 antiproton
1505 cbali2/7/99end 
1506 *                   0 eta
1507 *                   1 PROTON
1508 *                   2 NUETRON
1509 *                   3 PION-
1510 *                   4 PION0
1511 *                   5 PION+          
1512 *                   6 DELTA-1
1513 *                   7 DELTA0
1514 *                   8 DELTA+1
1515 *                   9 DELTA+2
1516 *                   10 N*0(1440), p_11
1517 *                   11 N*(+1)(1440),p_11
1518 *                  12 N*0(1535),s_11
1519 *                  13 N*(+1)(1535),s_11
1520 *                  14 LAMBDA
1521 *                   15 sigma-
1522 *                   16 sigma0
1523 *                   17 sigma+
1524 *                   21 kaon-
1525 clin-2/23/03        22 Kaon0Long (converted at the last timestep)
1526 *                   23 KAON+
1527 *                   24 Kaon0short (converted at the last timestep then decay)
1528 *                   25 rho-
1529 *                   26 rho0
1530 *                   27 rho+
1531 *                   28 omega meson
1532 *                   29 phi
1533 *                   30 K*+
1534 * sp01/03/01
1535 *                   31 eta-prime
1536 *                   40 cascade-
1537 *                   41 cascade0
1538 *                   45 Omega baryon
1539 * sp01/03/01 end
1540 *                   
1541 *                   ++  ------- SEE NOTE BOOK
1542 *         NSTAR=1 INCLUDING N* RESORANCE
1543 *         ELSE DELTA RESORANCE ONLY
1544 *         NDIRCT=1 INCLUDING DIRECT PROCESS,ELSE NOT
1545 *         DIR - PERCENTAGE OF DIRECT PION PRODUCTION PROCESS
1546 **********************************
1547       PARAMETER      (MAXSTR=150001,MAXR=1,PI=3.1415926)
1548       parameter      (MX=4,MY=4,MZ=8,MPX=4,MPY=4,mpz=10,mpzp=10)
1549       PARAMETER      (AKA=0.498,ALA=1.1157,ASA=1.1974,aks=0.895)
1550       PARAMETER      (AA1=1.26,APHI=1.02,AP1=0.13496)
1551       parameter            (maxx=20,maxz=24)
1552       parameter            (rrkk=0.6,prkk=0.3,srhoks=5.,ESBIN=0.04)
1553       DIMENSION MASSRN(0:MAXR),RT(3,MAXSTR),PT(3,MAXSTR),ET(MAXSTR)
1554       DIMENSION LT(MAXSTR), PROT(MAXSTR)
1555       COMMON   /AA/  R(3,MAXSTR)
1556 cc      SAVE /AA/
1557       COMMON   /BB/  P(3,MAXSTR)
1558 cc      SAVE /BB/
1559       COMMON   /CC/  E(MAXSTR)
1560 cc      SAVE /CC/
1561       COMMON  /DD/      RHO(-MAXX:MAXX,-MAXX:MAXX,-MAXZ:MAXZ),
1562      &                     RHOP(-MAXX:MAXX,-MAXX:MAXX,-MAXZ:MAXZ),
1563      &                     RHON(-MAXX:MAXX,-MAXX:MAXX,-MAXZ:MAXZ)
1564 cc      SAVE /DD/
1565       COMMON   /EE/  ID(MAXSTR),LB(MAXSTR)
1566 cc      SAVE /EE/
1567       COMMON   /HH/  PROPER(MAXSTR)
1568 cc      SAVE /HH/
1569       common /ff/f(-mx:mx,-my:my,-mz:mz,-mpx:mpx,-mpy:mpy,-mpz:mpzp)
1570 cc      SAVE /ff/
1571       common   /gg/  dx,dy,dz,dpx,dpy,dpz
1572 cc      SAVE /gg/
1573       COMMON   /INPUT/ NSTAR,NDIRCT,DIR
1574 cc      SAVE /INPUT/
1575       COMMON   /NN/NNN
1576 cc      SAVE /NN/
1577       COMMON   /RR/  MASSR(0:MAXR)
1578 cc      SAVE /RR/
1579       common   /ss/  inout(20)
1580 cc      SAVE /ss/
1581       COMMON   /BG/BETAX,BETAY,BETAZ,GAMMA
1582 cc      SAVE /BG/
1583       COMMON   /RUN/NUM
1584 cc      SAVE /RUN/
1585       COMMON   /PA/RPION(3,MAXSTR,MAXR)
1586 cc      SAVE /PA/
1587       COMMON   /PB/PPION(3,MAXSTR,MAXR)
1588 cc      SAVE /PB/
1589       COMMON   /PC/EPION(MAXSTR,MAXR)
1590 cc      SAVE /PC/
1591       COMMON   /PD/LPION(MAXSTR,MAXR)
1592 cc      SAVE /PD/
1593       COMMON   /PE/PROPI(MAXSTR,MAXR)
1594 cc      SAVE /PE/
1595       COMMON   /KKK/TKAON(7),EKAON(7,0:2000)
1596 cc      SAVE /KKK/
1597       COMMON  /KAON/    AK(3,50,36),SPECK(50,36,7),MF
1598 cc      SAVE /KAON/
1599       COMMON/TABLE/ xarray(0:1000),earray(0:1000)
1600 cc      SAVE /TABLE/
1601       common/input1/ MASSPR,MASSTA,ISEED,IAVOID,DT
1602 cc      SAVE /input1/
1603       common/leadng/lb1,px1,py1,pz1,em1,e1,xfnl,yfnl,zfnl,tfnl,
1604      1 px1n,py1n,pz1n,dp1n
1605 cc      SAVE /leadng/
1606       COMMON/tdecay/tfdcy(MAXSTR),tfdpi(MAXSTR,MAXR),tft(MAXSTR)
1607 cc      SAVE /tdecay/
1608       common /lastt/itimeh,bimp 
1609 cc      SAVE /lastt/
1610 c
1611       COMMON/ppbmas/niso(15),nstate,ppbm(15,2),thresh(15),weight(15)
1612 cc      SAVE /ppbmas/
1613       common/ppb1/ene,factr2(6),fsum,ppinnb,s,wtot
1614 cc      SAVE /ppb1/
1615       common/ppmm/pprr,ppee,pppe,rpre,xopoe,rree
1616 cc      SAVE /ppmm/
1617       COMMON/hbt/lblast(MAXSTR),xlast(4,MAXSTR),plast(4,MAXSTR),nlast
1618 cc      SAVE /hbt/
1619       common/resdcy/NSAV,iksdcy
1620 cc      SAVE /resdcy/
1621       COMMON/RNDF77/NSEED
1622 cc      SAVE /RNDF77/
1623       COMMON/FTMAX/ftsv(MAXSTR),ftsvt(MAXSTR, MAXR)
1624       dimension ftpisv(MAXSTR,MAXR),fttemp(MAXSTR)
1625       common /dpi/em2,lb2
1626       common/phidcy/iphidcy,pttrig,ntrig,maxmiss,ipi0dcy
1627 clin-5/2008:
1628       DIMENSION dptemp(MAXSTR)
1629       common /para8/ idpert,npertd,idxsec
1630       COMMON /dpert/dpertt(MAXSTR,MAXR),dpertp(MAXSTR),dplast(MAXSTR),
1631      1     dpdcy(MAXSTR),dpdpi(MAXSTR,MAXR),dpt(MAXSTR, MAXR),
1632      2     dpp1(MAXSTR,MAXR),dppion(MAXSTR,MAXR)
1633 c
1634       real zet(-45:45)
1635       SAVE   
1636       data zet /
1637      4     1.,0.,0.,0.,0.,
1638      3     1.,0.,0.,0.,0.,0.,0.,0.,0.,0.,
1639      2     -1.,0.,0.,0.,0.,0.,0.,0.,0.,0.,
1640      1     0.,0.,0.,-1.,0.,1.,0.,-1.,0.,-1.,
1641      s     0.,-2.,-1.,0.,1.,0.,0.,0.,0.,-1.,
1642      e     0.,
1643      s     1.,0.,-1.,0.,1.,-1.,0.,1.,2.,0.,
1644      1     1.,0.,1.,0.,-1.,0.,1.,0.,0.,0.,
1645      2     -1.,0.,1.,0.,-1.,0.,1.,0.,0.,1.,
1646      3     0.,0.,0.,0.,0.,0.,0.,0.,0.,-1.,
1647      4     0.,0.,0.,0.,-1./
1648 
1649 clin-2/19/03 initialize n and nsav for resonance decay at each timestep
1650 c     in order to prevent integer overflow:
1651       call inidcy
1652 
1653 c OFF skip ART collisions to reproduce HJ:      
1654 cc       if(nt.ne.ntmax) return
1655 
1656 clin-11/07/00 rrkk is assumed to be 0.6mb(default) for mm->KKbar 
1657 c     with m=rho or omega, estimated from Ko's paper:
1658 c      rrkk=0.6
1659 c prkk: cross section of pi (rho or omega) -> K* Kbar (AND) K*bar K:
1660 c      prkk=0.3
1661 c     cross section in mb for (rho or omega) K* -> pi K:
1662 c      srhoks=5.
1663 clin-11/07/00-end
1664 c      ESBIN=0.04
1665       RESONA=5.
1666 *-----------------------------------------------------------------------
1667 *     INITIALIZATION OF COUNTING VARIABLES
1668       NODELT=0
1669       SUMSRT =0.
1670       LCOLL  = 0
1671       LBLOC  = 0
1672       LCNNE  = 0
1673       LDD  = 0
1674       LPP  = 0
1675       lpd  = 0
1676       lpdr=0
1677       lrho = 0
1678       lrhor=0
1679       lomega=0
1680       lomgar=0
1681       LPN  = 0
1682       LKN  = 0
1683       LNNK = 0
1684       LDDK = 0
1685       LNDK = 0
1686       lppk =0
1687       LCNND  = 0
1688       LCNDN  = 0
1689       LDIRT  = 0
1690       LDECAY = 0
1691       LRES   = 0
1692       Ldou   = 0
1693       LDDRHO = 0
1694       LNNRHO = 0
1695       LNNOM  = 0
1696       MSUM   = 0
1697       MASSRN(0)=0
1698 * COM: MSUM IS USED TO COUNT THE TOTAL NO. OF PARTICLES 
1699 *      IN PREVIOUS IRUN-1 RUNS
1700 * KAON COUNTERS
1701       DO 1002 IL=1,5
1702          TKAON(IL)=0
1703          DO 1001 IS=1,2000
1704             EKAON(IL,IS)=0
1705  1001    CONTINUE
1706  1002 CONTINUE
1707 c sp 12/19/00
1708       DO 1004 i =1,NUM
1709          DO 1003 j =1,MAXSTR
1710             PROPI(j,i) = 1.
1711  1003    CONTINUE
1712  1004 CONTINUE
1713       
1714       do 1102 i=1,maxstr
1715          fttemp(i)=0.
1716          do 1101 irun=1,maxr
1717             ftpisv(i,irun)=0.
1718  1101    continue
1719  1102 continue
1720 
1721 c sp 12/19/00 end
1722       sp=0
1723 * antikaon counters
1724       akaon=0
1725       sk=0
1726 *-----------------------------------------------------------------------
1727 *     LOOP OVER ALL PARALLEL RUNS
1728 cbz11/17/98
1729 c      MASS=MASSPR+MASSTA
1730       MASS = 0
1731 cbz11/17/98end
1732       DO 1000 IRUN = 1,NUM
1733          NNN=0
1734          MSUM=MSUM+MASSR(IRUN-1)
1735 *     LOOP OVER ALL PSEUDOPARTICLES 1 IN THE SAME RUN
1736          J10=2
1737          IF(NT.EQ.NTMAX)J10=1
1738 c
1739 ctest off skips the check of energy conservation after each timestep:
1740 c         enetot=0.
1741 c         do ip=1,MASSR(IRUN)
1742 c            if(e(ip).ne.0.or.lb(ip).eq.10022) enetot=enetot
1743 c     1           +sqrt(p(1,ip)**2+p(2,ip)**2+p(3,ip)**2+e(ip)**2)
1744 c         enddo
1745 c         write(91,*) 'A:',nt,enetot,massr(irun),bimp 
1746 
1747          DO 800 J1 = J10,MASSR(IRUN)
1748             I1  = J1 + MSUM
1749 * E(I)=0 are for pions having been absorbed or photons which do not enter here:
1750 clin-4/2012 option of pi0 decays:
1751 c            IF(E(I1).EQ.0.)GO TO 800
1752             IF(E(I1).EQ.0.)GO TO 798
1753 c     To include anti-(Delta,N*1440 and N*1535):
1754 c          IF ((LB(I1) .LT. -13 .OR. LB(I1) .GT. 28)
1755 c     1         .and.iabs(LB(I1)) .ne. 30 ) GOTO 800
1756 clin-4/2012 option of pi0 decays:
1757 c            IF (LB(I1) .LT. -45 .OR. LB(I1) .GT. 45) GOTO 800
1758             IF (LB(I1) .LT. -45 .OR. LB(I1) .GT. 45) GOTO 798
1759             X1  = R(1,I1)
1760             Y1  = R(2,I1)
1761             Z1  = R(3,I1)
1762             PX1 = P(1,I1)
1763             PY1 = P(2,I1)
1764             PZ1 = P(3,I1)
1765             EM1 = E(I1)
1766             am1= em1
1767             E1  = SQRT( EM1**2 + PX1**2 + PY1**2 + PZ1**2 )
1768             ID1 = ID(I1)
1769             LB1 = LB(I1)
1770 
1771 c     generate k0short and k0long from K+ and K- at the last timestep:
1772             if(nt.eq.ntmax.and.(lb1.eq.21.or.lb1.eq.23)) then
1773                pk0=RANART(NSEED)
1774                if(pk0.lt.0.25) then
1775                   LB(I1)=22
1776                elseif(pk0.lt.0.50) then
1777                   LB(I1)=24
1778                endif
1779                LB1=LB(I1)
1780             endif
1781             
1782 clin-8/07/02 these particles don't decay strongly, so skip decay routines:     
1783 c            IF( (lb1.ge.-2.and.lb1.le.5) .OR. lb1.eq.31 .OR.
1784 c     &           (iabs(lb1).ge.14.and.iabs(lb1).le.24) .OR.
1785 c     &           (iabs(lb1).ge.40.and.iabs(lb1).le.45) .or. 
1786 c     &           lb1.eq.31)GO TO 1 
1787 c     only decay K0short when iksdcy=1:
1788             if(lb1.eq.0.or.lb1.eq.25.or.lb1.eq.26.or.lb1.eq.27
1789      &           .or.lb1.eq.28.or.lb1.eq.29.or.iabs(lb1).eq.30
1790      &           .or.(iabs(lb1).ge.6.and.iabs(lb1).le.13)
1791      &           .or.(iksdcy.eq.1.and.lb1.eq.24)
1792      &           .or.iabs(lb1).eq.16
1793      &           .or.(ipi0dcy.eq.1.and.nt.eq.ntmax.and.lb1.eq.4)) then
1794 clin-4/2012-above for option of pi0 decay:
1795 c     &           .or.iabs(lb1).eq.16) then
1796                continue
1797             else
1798                goto 1
1799             endif
1800 * IF I1 IS A RESONANCE, CHECK WHETHER IT DECAYS DURING THIS TIME STEP
1801          IF(lb1.ge.25.and.lb1.le.27) then
1802              wid=0.151
1803          ELSEIF(lb1.eq.28) then
1804              wid=0.00841
1805          ELSEIF(lb1.eq.29) then
1806              wid=0.00443
1807           ELSEIF(iabs(LB1).eq.30) then
1808              WID=0.051
1809          ELSEIF(lb1.eq.0) then
1810              wid=1.18e-6
1811 c     to give K0short ct0=2.676cm:
1812          ELSEIF(iksdcy.eq.1.and.lb1.eq.24) then
1813              wid=7.36e-15
1814 clin-4/29/03 add Sigma0 decay to Lambda, ct0=2.22E-11m:
1815          ELSEIF(iabs(lb1).eq.16) then
1816              wid=8.87e-6
1817 csp-07/25/01 test a1 resonance:
1818 cc          ELSEIF(LB1.EQ.32) then
1819 cc             WID=0.40
1820           ELSEIF(LB1.EQ.32) then
1821              call WIDA1(EM1,rhomp,WID,iseed)
1822           ELSEIF(iabs(LB1).ge.6.and.iabs(LB1).le.9) then
1823              WID=WIDTH(EM1)
1824           ELSEIF((iabs(LB1).EQ.10).OR.(iabs(LB1).EQ.11)) then
1825              WID=W1440(EM1)
1826           ELSEIF((iabs(LB1).EQ.12).OR.(iabs(LB1).EQ.13)) then
1827              WID=W1535(EM1)
1828 clin-4/2012 for option of pi0 decay:
1829           ELSEIF(ipi0dcy.eq.1.and.nt.eq.ntmax.and.lb1.eq.4) then
1830              wid=7.85e-9
1831           ENDIF
1832 
1833 * if it is the last time step, FORCE all resonance to strong-decay
1834 * and go out of the loop
1835           if(nt.eq.ntmax)then
1836              pdecay=1.1
1837 clin-5b/2008 forbid phi decay at the end of hadronic cascade:
1838              if(iphidcy.eq.0.and.iabs(LB1).eq.29) pdecay=0.
1839 ctest off clin-9/2012 forbid long-time decays (eta,omega,K*,Sigma0)
1840 c     at the end of hadronic cascade to analyze freezeout time:
1841 c             if(LB1.eq.0.or.LB1.eq.28.or.iabs(LB1).eq.30
1842 c     1            .or.iabs(LB1).eq.16) pdecay=0.
1843           else
1844              T0=0.19733/WID
1845              GFACTR=E1/EM1
1846              T0=T0*GFACTR
1847              IF(T0.GT.0.)THEN
1848                 PDECAY=1.-EXP(-DT/T0)
1849              ELSE
1850                 PDECAY=0.
1851              ENDIF
1852           endif
1853           XDECAY=RANART(NSEED)
1854 
1855 cc dilepton production from rho0, omega, phi decay 
1856 cc        if(lb1.eq.26 .or. lb1.eq.28 .or. lb1.eq.29)
1857 cc     &   call dec_ceres(nt,ntmax,irun,i1)
1858 cc
1859           IF(XDECAY.LT.PDECAY) THEN
1860 clin-10/25/02 get rid of argument usage mismatch in rhocay():
1861              idecay=irun
1862              tfnl=nt*dt
1863 clin-10/28/03 keep formation time of hadrons unformed at nt=ntmax-1:
1864              if(nt.eq.ntmax.and.ftsv(i1).gt.((ntmax-1)*dt)) 
1865      1            tfnl=ftsv(i1)
1866              xfnl=x1
1867              yfnl=y1
1868              zfnl=z1
1869 * use PYTHIA to perform decays of eta,rho,omega,phi,K*,(K0s) and Delta:
1870              if(lb1.eq.0.or.lb1.eq.25.or.lb1.eq.26.or.lb1.eq.27
1871      &           .or.lb1.eq.28.or.lb1.eq.29.or.iabs(lb1).eq.30
1872      &           .or.(iabs(lb1).ge.6.and.iabs(lb1).le.9)
1873      &           .or.(iksdcy.eq.1.and.lb1.eq.24)
1874      &           .or.iabs(lb1).eq.16
1875      &           .or.(ipi0dcy.eq.1.and.nt.eq.ntmax.and.lb1.eq.4)) then
1876 clin-4/2012 Above for option of pi0 decay:
1877 c     &           .or.iabs(lb1).eq.16) then
1878 c     previous rho decay performed in rhodecay():
1879 c                nnn=nnn+1
1880 c                call rhodecay(idecay,i1,nnn,iseed)
1881 c
1882 ctest off record decays of phi,K*,Lambda(1520) resonances:
1883 c                if(lb1.eq.29.or.iabs(lb1).eq.30) 
1884 c     1               write(18,112) 'decay',lb1,px1,py1,pz1,am1,nt
1885 c
1886 clin-4/2012 option of pi0 decays:
1887 c                call resdec(i1,nt,nnn,wid,idecay)
1888                 call resdec(i1,nt,nnn,wid,idecay,0)
1889                 p(1,i1)=px1n
1890                 p(2,i1)=py1n
1891                 p(3,i1)=pz1n
1892 clin-5/2008:
1893                 dpertp(i1)=dp1n
1894 c     add decay time to freezeout positions & time at the last timestep:
1895                 if(nt.eq.ntmax) then
1896                    R(1,i1)=xfnl
1897                    R(2,i1)=yfnl
1898                    R(3,i1)=zfnl
1899                    tfdcy(i1)=tfnl
1900                 endif
1901 c
1902 * decay number for baryon resonance or L/S decay
1903                 if(iabs(lb1).ge.6.and.iabs(lb1).le.9) then
1904                    LDECAY=LDECAY+1
1905                 endif
1906 
1907 * for a1 decay 
1908 c             elseif(lb1.eq.32)then
1909 c                NNN=NNN+1
1910 c                call a1decay(idecay,i1,nnn,iseed,rhomp)
1911 
1912 * FOR N*(1440)
1913              elseif(iabs(LB1).EQ.10.OR.iabs(LB1).EQ.11) THEN
1914                 NNN=NNN+1
1915                 LDECAY=LDECAY+1
1916                 PNSTAR=1.
1917                 IF(E(I1).GT.1.22)PNSTAR=0.6
1918                 IF(RANART(NSEED).LE.PNSTAR)THEN
1919 * (1) DECAY TO SINGLE PION+NUCLEON
1920                    CALL DECAY(idecay,I1,NNN,ISEED,wid,nt)
1921                 ELSE
1922 * (2) DECAY TO TWO PIONS + NUCLEON
1923                    CALL DECAY2(idecay,I1,NNN,ISEED,wid,nt)
1924                    NNN=NNN+1
1925                 ENDIF
1926 c for N*(1535) decay
1927              elseif(iabs(LB1).eq.12.or.iabs(LB1).eq.13) then
1928                 NNN=NNN+1
1929                 CALL DECAY(idecay,I1,NNN,ISEED,wid,nt)
1930                 LDECAY=LDECAY+1
1931              endif
1932 c
1933 *COM: AT HIGH ENERGIES WE USE VERY SHORT TIME STEPS,
1934 *     IN ORDER TO TAKE INTO ACCOUNT THE FINITE FORMATIOM TIME, WE
1935 *     DO NOT ALLOW PARTICLES FROM THE DECAY OF RESONANCE TO INTERACT 
1936 *     WITH OTHERS IN THE SAME TIME STEP. CHANGE 9000 TO REVERSE THIS 
1937 *     ASSUMPTION. EFFECTS OF THIS ASSUMPTION CAN BE STUDIED BY CHANGING 
1938 *     THE STATEMENT OF 9000. See notebook for discussions on effects of
1939 *     changing statement 9000.
1940 c
1941 c     kaons from K* decay are converted to k0short (and k0long), 
1942 c     phi decay may produce rho, K0S or eta, N*(1535) decay may produce eta,
1943 c     and these decay daughters need to decay again if at the last timestep:
1944 c     (note: these daughters have been assigned to lb(i1) only, not to lpion)
1945 c             if(nt.eq.ntmax.and.(lb1.eq.29.or.iabs(lb1).eq.30
1946 c     1            .iabs(lb1).eq.12.or.iabs(lb1).eq.13)) then
1947              if(nt.eq.ntmax) then
1948                 if(lb(i1).eq.25.or.lb(i1).eq.26.or.lb(i1).eq.27) then
1949                    wid=0.151
1950                 elseif(lb(i1).eq.0) then
1951                    wid=1.18e-6
1952                 elseif(lb(i1).eq.24.and.iksdcy.eq.1) then
1953 clin-4/2012 corrected K0s decay width:
1954 c                   wid=7.36e-17
1955                    wid=7.36e-15
1956 clin-4/2012 option of pi0 decays:
1957                 elseif(ipi0dcy.eq.1.and.lb(i1).eq.4) then
1958                    wid=7.85e-9
1959                 else
1960                    goto 9000
1961                 endif
1962                 LB1=LB(I1)
1963                 PX1=P(1,I1)
1964                 PY1=P(2,I1)
1965                 PZ1=P(3,I1)
1966                 EM1=E(I1)
1967                 E1=SQRT(EM1**2+PX1**2+PY1**2+PZ1**2)
1968 clin-4/2012 option of pi0 decays:
1969 c                call resdec(i1,nt,nnn,wid,idecay)
1970                 call resdec(i1,nt,nnn,wid,idecay,0)
1971                 p(1,i1)=px1n
1972                 p(2,i1)=py1n
1973                 p(3,i1)=pz1n
1974                 R(1,i1)=xfnl
1975                 R(2,i1)=yfnl
1976                 R(3,i1)=zfnl
1977                 tfdcy(i1)=tfnl
1978 clin-5/2008:
1979                 dpertp(i1)=dp1n
1980              endif
1981 
1982 c     Decay daughter of the above decay in lb(i1) may be a pi0:
1983              if(nt.eq.ntmax.and.ipi0dcy.eq.1.and.lb(i1).eq.4) then
1984                 wid=7.85e-9
1985                 LB1=LB(I1)
1986                 PX1=P(1,I1)
1987                 PY1=P(2,I1)
1988                 PZ1=P(3,I1)
1989                 EM1=E(I1)
1990                 E1=SQRT(EM1**2+PX1**2+PY1**2+PZ1**2)
1991                 call resdec(i1,nt,nnn,wid,idecay,0)
1992                 p(1,i1)=px1n
1993                 p(2,i1)=py1n
1994                 p(3,i1)=pz1n
1995                 R(1,i1)=xfnl
1996                 R(2,i1)=yfnl
1997                 R(3,i1)=zfnl
1998                 tfdcy(i1)=tfnl
1999                 dpertp(i1)=dp1n
2000              endif
2001 
2002 * negelecting the Pauli blocking at high energies
2003 clin-4/2012 option of pi0 decays:
2004 c 9000        go to 800
2005  9000        go to 798
2006 
2007           ENDIF
2008 * LOOP OVER ALL PSEUDOPARTICLES 2 IN THE SAME RUN
2009 * SAVE ALL THE COORDINATES FOR POSSIBLE CHANGE IN THE FOLLOWING COLLISION
2010 clin-4/2012 option of pi0 decays:
2011 c 1        if(nt.eq.ntmax)go to 800
2012  1        if(nt.eq.ntmax)go to 798
2013 
2014           X1 = R(1,I1)
2015           Y1 = R(2,I1)
2016           Z1 = R(3,I1)
2017 c
2018            DO 600 J2 = 1,J1-1
2019             I2  = J2 + MSUM
2020 * IF I2 IS A MESON BEING ABSORBED, THEN GO OUT OF THE LOOP
2021             IF(E(I2).EQ.0.) GO TO 600
2022 clin-5/2008 in case the first particle is already destroyed:
2023             IF(E(I1).EQ.0.) GO TO 800
2024 clin-4/2012 option of pi0 decays:
2025             IF (LB(I2) .LT. -45 .OR. LB(I2) .GT. 45) GOTO 600
2026 clin-7/26/03 improve speed
2027             X2=R(1,I2)
2028             Y2=R(2,I2)
2029             Z2=R(3,I2)
2030             dr0max=5.
2031 clin-9/2008 deuteron+nucleon elastic cross sections could reach ~2810mb:
2032             ilb1=iabs(LB(I1))
2033             ilb2=iabs(LB(I2))
2034             IF(ilb1.EQ.42.or.ilb2.EQ.42) THEN
2035                if((ILB1.GE.1.AND.ILB1.LE.2)
2036      1              .or.(ILB1.GE.6.AND.ILB1.LE.13)
2037      2              .or.(ILB2.GE.1.AND.ILB2.LE.2)
2038      3              .or.(ILB2.GE.6.AND.ILB2.LE.13)) then
2039                   if((lb(i1)*lb(i2)).gt.0) dr0max=10.
2040                endif
2041             ENDIF
2042 c
2043             if(((X1-X2)**2+(Y1-Y2)**2+(Z1-Z2)**2).GT.dr0max**2)
2044      1           GO TO 600
2045             IF (ID(I1)*ID(I2).EQ.IAVOID) GOTO 400
2046             ID1=ID(I1)
2047             ID2 = ID(I2)
2048 c
2049             ix1= nint(x1/dx)
2050             iy1= nint(y1/dy)
2051             iz1= nint(z1/dz)
2052             PX1=P(1,I1)
2053             PY1=P(2,I1)
2054             PZ1=P(3,I1)
2055             EM1=E(I1)
2056             AM1=EM1
2057             LB1=LB(I1)
2058             E1=SQRT(EM1**2+PX1**2+PY1**2+PZ1**2)
2059             IPX1=NINT(PX1/DPX)
2060             IPY1=NINT(PY1/DPY)
2061             IPZ1=NINT(PZ1/DPZ)         
2062             LB2 = LB(I2)
2063             PX2 = P(1,I2)
2064             PY2 = P(2,I2)
2065             PZ2 = P(3,I2)
2066             EM2=E(I2)
2067             AM2=EM2
2068             lb1i=lb(i1)
2069             lb2i=lb(i2)
2070             px1i=P(1,I1)
2071             py1i=P(2,I1)
2072             pz1i=P(3,I1)
2073             em1i=E(I1)
2074             px2i=P(1,I2)
2075             py2i=P(2,I2)
2076             pz2i=P(3,I2)
2077             em2i=E(I2)
2078 clin-2/26/03 ctest off check energy conservation after each binary search:
2079             eini=SQRT(E(I1)**2+P(1,I1)**2+P(2,I1)**2+P(3,I1)**2)
2080      1           +SQRT(E(I2)**2+P(1,I2)**2+P(2,I2)**2+P(3,I2)**2)
2081             pxini=P(1,I1)+P(1,I2)
2082             pyini=P(2,I1)+P(2,I2)
2083             pzini=P(3,I1)+P(3,I2)
2084             nnnini=nnn
2085 c
2086 clin-4/30/03 initialize value:
2087             iblock=0
2088 c
2089 * TO SAVE COMPUTING TIME we do the following
2090 * (1) make a ROUGH estimate to see whether particle i2 will collide with
2091 * particle I1, and (2) skip the particle pairs for which collisions are 
2092 * not modeled in the code.
2093 * FOR MESON-BARYON AND MESON-MESON COLLISIONS, we use a maximum 
2094 * interaction distance DELTR0=2.6
2095 * for ppbar production from meson (pi rho omega) interactions:
2096 c
2097             DELTR0=3.
2098         if( (iabs(lb1).ge.14.and.iabs(lb1).le.17) .or.
2099      &      (iabs(lb1).ge.30.and.iabs(lb1).le.45) ) DELTR0=5.0
2100         if( (iabs(lb2).ge.14.and.iabs(lb2).le.17) .or.
2101      &      (iabs(lb2).ge.30.and.iabs(lb2).le.45) ) DELTR0=5.0
2102 
2103             if(lb1.eq.28.and.lb2.eq.28) DELTR0=4.84
2104 clin-10/08/00 to include pi pi -> rho rho:
2105             if((lb1.ge.3.and.lb1.le.5).and.(lb2.ge.3.and.lb2.le.5)) then
2106                E2=SQRT(EM2**2+PX2**2+PY2**2+PZ2**2)
2107          spipi=(e1+e2)**2-(px1+px2)**2-(py1+py2)**2-(pz1+pz2)**2
2108                if(spipi.ge.(4*0.77**2)) DELTR0=3.5
2109             endif
2110 
2111 c khyperon
2112         IF (LB1.EQ.23 .AND. (LB2.GE.14.AND.LB2.LE.17)) GOTO 3699
2113         IF (LB2.EQ.23 .AND. (LB1.GE.14.AND.LB1.LE.17)) GOTO 3699
2114 
2115 * K(K*) + Kbar(K*bar) scattering including 
2116 *     K(K*) + Kbar(K*bar) --> phi + pi(rho,omega) and pi pi(rho,omega)
2117        if(lb1.eq.21.and.lb2.eq.23)go to 3699
2118        if(lb2.eq.21.and.lb1.eq.23)go to 3699
2119        if(lb1.eq.30.and.lb2.eq.21)go to 3699
2120        if(lb2.eq.30.and.lb1.eq.21)go to 3699
2121        if(lb1.eq.-30.and.lb2.eq.23)go to 3699
2122        if(lb2.eq.-30.and.lb1.eq.23)go to 3699
2123        if(lb1.eq.-30.and.lb2.eq.30)go to 3699
2124        if(lb2.eq.-30.and.lb1.eq.30)go to 3699
2125 c
2126 clin-12/15/00
2127 c     kaon+rho(omega,eta) collisions:
2128       if(lb1.eq.21.or.lb1.eq.23) then
2129          if(lb2.eq.0.or.(lb2.ge.25.and.lb2.le.28)) then
2130             go to 3699
2131          endif
2132       elseif(lb2.eq.21.or.lb2.eq.23) then
2133          if(lb1.eq.0.or.(lb1.ge.25.and.lb1.le.28)) then
2134             goto 3699
2135          endif
2136       endif
2137 
2138 clin-8/14/02 K* (pi, rho, omega, eta) collisions:
2139       if(iabs(lb1).eq.30 .and.
2140      1     (lb2.eq.0.or.(lb2.ge.25.and.lb2.le.28)
2141      2     .or.(lb2.ge.3.and.lb2.le.5))) then
2142          go to 3699
2143       elseif(iabs(lb2).eq.30 .and.
2144      1        (lb1.eq.0.or.(lb1.ge.25.and.lb1.le.28)
2145      2        .or.(lb1.ge.3.and.lb1.le.5))) then
2146          goto 3699
2147 clin-8/14/02-end
2148 c K*/K*-bar + baryon/antibaryon collisions:
2149         elseif( iabs(lb1).eq.30 .and.
2150      1     (iabs(lb2).eq.1.or.iabs(lb2).eq.2.or.
2151      2     (iabs(lb2).ge.6.and.iabs(lb2).le.13)) )then
2152               go to 3699
2153            endif
2154          if( iabs(lb2).eq.30 .and.
2155      1         (iabs(lb1).eq.1.or.iabs(lb1).eq.2.or.
2156      2         (iabs(lb1).ge.6.and.iabs(lb1).le.13)) )then
2157                 go to 3699
2158         endif                                                              
2159 * K^+ baryons and antibaryons:
2160 c** K+ + B-bar  --> La(Si)-bar + pi
2161 * K^- and antibaryons, note K^- and baryons are included in newka():
2162 * note that we fail to satisfy charge conjugation for these cross sections:
2163         if((lb1.eq.23.or.lb1.eq.21).and.
2164      1       (iabs(lb2).eq.1.or.iabs(lb2).eq.2.or.
2165      2       (iabs(lb2).ge.6.and.iabs(lb2).le.13))) then
2166            go to 3699
2167         elseif((lb2.eq.23.or.lb2.eq.21).and.
2168      1       (iabs(lb1).eq.1.or.iabs(lb1).eq.2.or.
2169      2       (iabs(lb1).ge.6.and.iabs(lb1).le.13))) then
2170            go to 3699
2171         endif
2172 *
2173 * For anti-nucleons annihilations:
2174 * Assumptions: 
2175 * (1) for collisions involving a p_bar or n_bar,
2176 * we allow only collisions between a p_bar and a baryon or a baryon 
2177 * resonance (as well as a n_bar and a baryon or a baryon resonance),
2178 * we skip all other reactions involving a p_bar or n_bar, 
2179 * such as collisions between p_bar (n_bar) and mesons, 
2180 * and collisions between two p_bar's (n_bar's). 
2181 * (2) we introduce a new parameter rppmax: the maximum interaction 
2182 * distance to make the quick collision check,rppmax=3.57 fm 
2183 * corresponding to a cutoff of annihilation xsection= 400mb which is
2184 * also used consistently in the actual annihilation xsection to be 
2185 * used in the following as given in the subroutine xppbar(srt)
2186         rppmax=3.57   
2187 * anti-baryon on baryons
2188         if((lb1.eq.-1.or.lb1.eq.-2.or.(lb1.ge.-13.and.lb1.le.-6))
2189      1 .and.(lb2.eq.1.or.lb2.eq.2.or.(lb2.ge.6.and.lb2.le.13))) then
2190             DELTR0 = RPPMAX
2191             GOTO 2699
2192        else if((lb2.eq.-1.or.lb2.eq.-2.or.(lb2.ge.-13.and.lb2.le.-6))
2193      1 .and.(lb1.eq.1.or.lb1.eq.2.or.(lb1.ge.6.and.lb1.le.13))) then
2194             DELTR0 = RPPMAX
2195             GOTO 2699
2196          END IF
2197 
2198 c*  ((anti) lambda, cascade, omega  should not be rejected)
2199         if( (iabs(lb1).ge.14.and.iabs(lb1).le.17) .or.
2200      &      (iabs(lb2).ge.14.and.iabs(lb2).le.17) )go to 3699
2201 c
2202 clin-9/2008 maximum sigma~2810mb for deuteron+nucleon elastic collisions:
2203          IF (iabs(LB1).EQ.42.or.iabs(LB2).EQ.42) THEN
2204             ilb1=iabs(LB1)
2205             ilb2=iabs(LB2)
2206             if((ILB1.GE.1.AND.ILB1.LE.2)
2207      1           .or.(ILB1.GE.6.AND.ILB1.LE.13)
2208      2           .or.(ILB2.GE.1.AND.ILB2.LE.2)
2209      3           .or.(ILB2.GE.6.AND.ILB2.LE.13)) then
2210                if((lb1*lb2).gt.0) deltr0=9.5
2211             endif
2212          ENDIF
2213 c
2214         if( (iabs(lb1).ge.40.and.iabs(lb1).le.45) .or. 
2215      &      (iabs(lb2).ge.40.and.iabs(lb2).le.45) )go to 3699
2216 c
2217 c* phi channel --> elastic + inelastic scatt.  
2218          IF( (lb1.eq.29 .and.((lb2.ge.1.and.lb2.le.13).or.  
2219      &       (lb2.ge.21.and.lb2.le.28).or.iabs(lb2).eq.30)) .OR.
2220      &     (lb2.eq.29 .and.((lb1.ge.1.and.lb1.le.13).or.
2221      &       (lb1.ge.21.and.lb1.le.28).or.iabs(lb1).eq.30)) )THEN
2222              DELTR0=3.0
2223              go to 3699
2224         endif
2225 c
2226 c  La/Si, Cas, Om (bar)-meson elastic colln
2227 * pion vs. La & Ca (bar) coll. are treated in resp. subroutines
2228 
2229 * SKIP all other K* RESCATTERINGS
2230         If(iabs(lb1).eq.30.or.iabs(lb2).eq.30) go to 400
2231 * SKIP KAON(+) RESCATTERINGS WITH particles other than pions and baryons 
2232          If(lb1.eq.23.and.(lb2.lt.1.or.lb2.gt.17))go to 400
2233          If(lb2.eq.23.and.(lb1.lt.1.or.lb1.gt.17))go to 400
2234 c
2235 c anti-baryon proccess: B-bar+M, N-bar+R-bar, N-bar+N-bar, R-bar+R-bar
2236 c  R = (D,N*)
2237          if( ((lb1.le.-1.and.lb1.ge.-13)
2238      &        .and.(lb2.eq.0.or.(lb2.ge.3.and.lb2.le.5)
2239      &            .or.(lb2.ge.25.and.lb2.le.28))) 
2240      &      .OR.((lb2.le.-1.and.lb2.ge.-13)
2241      &         .and.(lb1.eq.0.or.(lb1.ge.3.and.lb1.le.5)
2242      &              .or.(lb1.ge.25.and.lb1.le.28))) ) then
2243          elseIF( ((LB1.eq.-1.or.lb1.eq.-2).
2244      &             and.(LB2.LT.-5.and.lb2.ge.-13))
2245      &      .OR. ((LB2.eq.-1.or.lb2.eq.-2).
2246      &             and.(LB1.LT.-5.and.lb1.ge.-13)) )then
2247          elseIF((LB1.eq.-1.or.lb1.eq.-2)
2248      &     .AND.(LB2.eq.-1.or.lb2.eq.-2))then
2249          elseIF((LB1.LT.-5.and.lb1.ge.-13).AND.
2250      &          (LB2.LT.-5.and.lb2.ge.-13)) then
2251 c        elseif((lb1.lt.0).or.(lb2.lt.0)) then
2252 c         go to 400
2253        endif               
2254 
2255  2699    CONTINUE
2256 * for baryon-baryon collisions
2257          IF (LB1 .EQ. 1 .OR. LB1 .EQ. 2 .OR. (LB1 .GE. 6 .AND.
2258      &        LB1 .LE. 17)) THEN
2259             IF (LB2 .EQ. 1 .OR. LB2 .EQ. 2 .OR. (LB2 .GE. 6 .AND.
2260      &           LB2 .LE. 17)) THEN
2261                DELTR0 = 2.
2262             END IF
2263          END IF
2264 c
2265  3699   RSQARE = (X1-X2)**2 + (Y1-Y2)**2 + (Z1-Z2)**2
2266         IF (RSQARE .GT. DELTR0**2) GO TO 400
2267 *NOW PARTICLES ARE CLOSE ENOUGH TO EACH OTHER !
2268 * KEEP ALL COORDINATES FOR POSSIBLE PHASE SPACE CHANGE
2269             ix2 = nint(x2/dx)
2270             iy2 = nint(y2/dy)
2271             iz2 = nint(z2/dz)
2272             ipx2 = nint(px2/dpx)
2273             ipy2 = nint(py2/dpy)
2274             ipz2 = nint(pz2/dpz)
2275 * FIND MOMENTA OF PARTICLES IN THE CMS OF THE TWO COLLIDING PARTICLES
2276 * AND THE CMS ENERGY SRT
2277             CALL CMS(I1,I2,PCX,PCY,PCZ,SRT)
2278 
2279 clin-7/26/03 improve speed
2280           drmax=dr0max
2281           call distc0(drmax,deltr0,DT,
2282      1         Ifirst,PCX,PCY,PCZ,
2283      2         x1,y1,z1,px1,py1,pz1,em1,x2,y2,z2,px2,py2,pz2,em2)
2284           if(Ifirst.eq.-1) goto 400
2285 
2286          ISS=NINT(SRT/ESBIN)
2287 clin-4/2008 use last bin if ISS is out of EKAON's upper bound of 2000:
2288          if(ISS.gt.2000) ISS=2000
2289 *Sort collisions
2290 c
2291 clin-8/2008 Deuteron+Meson->B+B; 
2292 c     meson=(pi,rho,omega,eta), B=(n,p,Delta,N*1440,N*1535):
2293          IF (iabs(LB1).EQ.42.or.iabs(LB2).EQ.42) THEN
2294             ilb1=iabs(LB1)
2295             ilb2=iabs(LB2)
2296             if(LB1.eq.0.or.(LB1.GE.3.AND.LB1.LE.5)
2297      1           .or.(LB1.GE.25.AND.LB1.LE.28)
2298      2           .or.
2299      3           LB2.eq.0.or.(LB2.GE.3.AND.LB2.LE.5)
2300      4           .or.(LB2.GE.25.AND.LB2.LE.28)) then
2301                GOTO 505
2302 clin-9/2008 Deuteron+Baryon or antiDeuteron+antiBaryon elastic collisions:
2303             elseif(((ILB1.GE.1.AND.ILB1.LE.2)
2304      1              .or.(ILB1.GE.6.AND.ILB1.LE.13)
2305      2              .or.(ILB2.GE.1.AND.ILB2.LE.2)
2306      3              .or.(ILB2.GE.6.AND.ILB2.LE.13))
2307      4              .and.(lb1*lb2).gt.0) then
2308                GOTO 506
2309             else
2310                GOTO 400
2311             endif
2312          ENDIF
2313 c
2314 * K+ + (N,N*,D)-bar --> L/S-bar + pi
2315           if( ((lb1.eq.23.or.lb1.eq.30).and.
2316      &         (lb2.eq.-1.or.lb2.eq.-2.or.(lb2.ge.-13.and.lb2.le.-6))) 
2317      &         .OR.((lb2.eq.23.or.lb2.eq.30).and.
2318      &         (lb1.eq.-1.or.lb1.eq.-2.or.(lb1.ge.-13.and.lb1.le.-6))) )
2319      &         then
2320              bmass=0.938
2321              if(srt.le.(bmass+aka)) then
2322                 pkaon=0.
2323              else
2324                 pkaon=sqrt(((srt**2-(aka**2+bmass**2))
2325      1               /2./bmass)**2-aka**2)
2326              endif
2327 clin-10/31/02 cross sections are isospin-averaged, same as those in newka
2328 c     for K- + (N,N*,D) --> L/S + pi:
2329              sigela = 0.5 * (AKPEL(PKAON) + AKNEL(PKAON))
2330              SIGSGM = 1.5 * AKPSGM(PKAON) + AKNSGM(PKAON)
2331              SIG = sigela + SIGSGM + AKPLAM(PKAON)
2332              if(sig.gt.1.e-7) then
2333 c     ! K+ + N-bar reactions
2334                 icase=3
2335                 brel=sigela/sig
2336                 brsgm=sigsgm/sig
2337                 brsig = sig
2338                 nchrg = 1
2339                 go to 3555
2340              endif
2341              go to 400
2342           endif
2343 c
2344 c
2345 c  meson + hyperon-bar -> K+ + N-bar
2346           if(((lb1.ge.-17.and.lb1.le.-14).and.(lb2.ge.3.and.lb2.le.5)) 
2347      &         .OR.((lb2.ge.-17.and.lb2.le.-14)
2348      &         .and.(lb1.ge.3.and.lb1.le.5)))then
2349              nchrg=-100
2350  
2351 C*       first classify the reactions due to total charge.
2352              if((lb1.eq.-15.and.(lb2.eq.5.or.lb2.eq.27)).OR.
2353      &            (lb2.eq.-15.and.(lb1.eq.5.or.lb1.eq.27))) then
2354                 nchrg=-2
2355 c     ! D-(bar)
2356                 bmass=1.232
2357                 go to 110
2358              endif
2359              if( (lb1.eq.-15.and.(lb2.eq.0.or.lb2.eq.4.or.lb2.eq.26.or.
2360      &            lb2.eq.28)).OR.(lb2.eq.-15.and.(lb1.eq.0.or.
2361      &            lb1.eq.4.or.lb1.eq.26.or.lb1.eq.28)).OR.
2362      &   ((lb1.eq.-14.or.lb1.eq.-16).and.(lb2.eq.5.or.lb2.eq.27)).OR.
2363      &   ((lb2.eq.-14.or.lb2.eq.-16).and.(lb1.eq.5.or.lb1.eq.27)) )then
2364                 nchrg=-1
2365 c     ! n-bar
2366                 bmass=0.938
2367                 go to 110
2368              endif
2369              if(  (lb1.eq.-15.and.(lb2.eq.3.or.lb2.eq.25)).OR.
2370      &            (lb2.eq.-15.and.(lb1.eq.3.or.lb1.eq.25)).OR.
2371      &            (lb1.eq.-17.and.(lb2.eq.5.or.lb2.eq.27)).OR.
2372      &            (lb2.eq.-17.and.(lb1.eq.5.or.lb1.eq.27)).OR.
2373      &            ((lb1.eq.-14.or.lb1.eq.-16).and.(lb2.eq.0.or.lb2.eq.4
2374      &            .or.lb2.eq.26.or.lb2.eq.28)).OR.
2375      &            ((lb2.eq.-14.or.lb2.eq.-16).and.(lb1.eq.0.or.lb1.eq.4
2376      &            .or.lb1.eq.26.or.lb1.eq.28)) )then
2377                nchrg=0
2378 c     ! p-bar
2379                 bmass=0.938
2380                 go to 110
2381              endif
2382              if( (lb1.eq.-17.and.(lb2.eq.0.or.lb2.eq.4.or.lb2.eq.26.or.
2383      &            lb2.eq.28)).OR.(lb2.eq.-17.and.(lb1.eq.0.or.
2384      &            lb1.eq.4.or.lb1.eq.26.or.lb1.eq.28)).OR.
2385      &  ((lb1.eq.-14.or.lb1.eq.-16).and.(lb2.eq.3.or.lb2.eq.25)).OR.
2386      &  ((lb2.eq.-14.or.lb2.eq.-16).and.(lb1.eq.3.or.lb1.eq.25)))then
2387                nchrg=1
2388 c     ! D++(bar)
2389                 bmass=1.232
2390              endif
2391 c
2392 c 110     if(nchrg.ne.-100.and.srt.ge.(aka+bmass))then !! for elastic
2393  110         sig = 0.
2394 c !! for elastic
2395          if(nchrg.ne.-100.and.srt.ge.(aka+bmass))then
2396 cc110        if(nchrg.eq.-100.or.srt.lt.(aka+bmass)) go to 400
2397 c             ! PI + La(Si)-bar => K+ + N-bar reactions
2398             icase=4
2399 cc       pkaon=sqrt(((srt**2-(aka**2+bmass**2))/2./bmass)**2-aka**2)
2400             pkaon=sqrt(((srt**2-(aka**2+0.938**2))/2./0.938)**2-aka**2)
2401 c ! lambda-bar + Pi
2402             if(lb1.eq.-14.or.lb2.eq.-14) then
2403                if(nchrg.ge.0) sigma0=akPlam(pkaon)
2404                if(nchrg.lt.0) sigma0=akNlam(pkaon)
2405 c                ! sigma-bar + pi
2406             else
2407 c !K-p or K-D++
2408                if(nchrg.ge.0) sigma0=akPsgm(pkaon)
2409 c !K-n or K-D-
2410                if(nchrg.lt.0) sigma0=akNsgm(pkaon)
2411                SIGMA0 = 1.5 * AKPSGM(PKAON) + AKNSGM(PKAON)
2412             endif
2413             sig=(srt**2-(aka+bmass)**2)*(srt**2-(aka-bmass)**2)/
2414      &           (srt**2-(em1+em2)**2)/(srt**2-(em1-em2)**2)*sigma0
2415 c ! K0barD++, K-D-
2416             if(nchrg.eq.-2.or.nchrg.eq.2) sig=2.*sig
2417 C*     the factor 2 comes from spin of delta, which is 3/2
2418 C*     detailed balance. copy from Page 423 of N.P. A614 1997
2419             IF (LB1 .EQ. -14 .OR. LB2 .EQ. -14) THEN
2420                SIG = 4.0 / 3.0 * SIG
2421             ELSE IF (NCHRG .EQ. -2 .OR. NCHRG .EQ. 2) THEN
2422                SIG = 8.0 / 9.0 * SIG
2423             ELSE
2424                SIG = 4.0 / 9.0 * SIG
2425             END IF
2426 cc        brel=0.
2427 cc        brsgm=0.
2428 cc        brsig = sig
2429 cc          if(sig.lt.1.e-7) go to 400
2430 *-
2431          endif
2432 c                ! PI + La(Si)-bar => elastic included
2433          icase=4
2434          sigela = 10.
2435          sig = sig + sigela
2436          brel= sigela/sig
2437          brsgm=0.
2438          brsig = sig
2439 *-
2440          go to 3555
2441       endif
2442       
2443 ** MULTISTRANGE PARTICLE (Cas,Omega -bar) PRODUCTION - (NON)PERTURBATIVE
2444 
2445 * K-/K*0bar + La/Si --> cascade + pi/eta
2446       if( ((lb1.eq.21.or.lb1.eq.-30).and.(lb2.ge.14.and.lb2.le.17)).OR.
2447      &  ((lb2.eq.21.or.lb2.eq.-30).and.(lb1.ge.14.and.lb1.le.17)) )then
2448           kp = 0
2449           go to 3455
2450         endif
2451 c K+/K*0 + La/Si(bar) --> cascade-bar + pi/eta
2452       if( ((lb1.eq.23.or.lb1.eq.30).and.(lb2.le.-14.and.lb2.ge.-17)).OR.
2453      &  ((lb2.eq.23.or.lb2.eq.30).and.(lb1.le.-14.and.lb1.ge.-17)) )then
2454           kp = 1
2455           go to 3455
2456         endif
2457 * K-/K*0bar + cascade --> omega + pi
2458        if( ((lb1.eq.21.or.lb1.eq.-30).and.(lb2.eq.40.or.lb2.eq.41)).OR.
2459      & ((lb2.eq.21.or.lb2.eq.-30).and.(lb1.eq.40.or.lb1.eq.41)) )then
2460           kp = 0
2461           go to 3455
2462         endif
2463 * K+/K*0 + cascade-bar --> omega-bar + pi
2464        if( ((lb1.eq.23.or.lb1.eq.30).and.(lb2.eq.-40.or.lb2.eq.-41)).OR.
2465      &  ((lb2.eq.23.or.lb2.eq.30).and.(lb1.eq.-40.or.lb1.eq.-41)) )then
2466           kp = 1
2467           go to 3455
2468         endif
2469 * Omega + Omega --> Di-Omega + photon(eta)
2470 cc        if( lb1.eq.45.and.lb2.eq.45 ) go to 3455
2471 
2472 c annhilation of cascade(bar), omega(bar)
2473          kp = 3
2474 * K- + L/S <-- cascade(bar) + pi/eta
2475        if( (((lb1.ge.3.and.lb1.le.5).or.lb1.eq.0) 
2476      &       .and.(iabs(lb2).eq.40.or.iabs(lb2).eq.41))
2477      & .OR. (((lb2.ge.3.and.lb2.le.5).or.lb2.eq.0) 
2478      &       .and.(iabs(lb1).eq.40.or.iabs(lb1).eq.41)) )go to 3455
2479 * K- + cascade(bar) <-- omega(bar) + pi
2480 *         if(  (lb1.eq.0.and.iabs(lb2).eq.45)
2481 *    &       .OR. (lb2.eq.0.and.iabs(lb1).eq.45) )go to 3455
2482         if( ((lb1.ge.3.and.lb1.le.5).and.iabs(lb2).eq.45)
2483      &  .OR.((lb2.ge.3.and.lb2.le.5).and.iabs(lb1).eq.45) )go to 3455
2484 c
2485 
2486 ***  MULTISTRANGE PARTICLE PRODUCTION  (END)
2487 
2488 c* K+ + La(Si) --> Meson + B
2489         IF (LB1.EQ.23 .AND. (LB2.GE.14.AND.LB2.LE.17)) GOTO 5699
2490         IF (LB2.EQ.23 .AND. (LB1.GE.14.AND.LB1.LE.17)) GOTO 5699
2491 c* K- + La(Si)-bar --> Meson + B-bar
2492        IF (LB1.EQ.21 .AND. (LB2.GE.-17.AND.LB2.LE.-14)) GOTO 5699
2493        IF (LB2.EQ.21 .AND. (LB1.GE.-17.AND.LB1.LE.-14)) GOTO 5699
2494 
2495 c La/Si-bar + B --> pi + K+
2496        IF( (((LB1.eq.1.or.LB1.eq.2).or.(LB1.ge.6.and.LB1.le.13))
2497      &       .AND.(LB2.GE.-17.AND.LB2.LE.-14)) .OR.
2498      &     (((LB2.eq.1.or.LB2.eq.2).or.(LB2.ge.6.and.LB2.le.13))
2499      &      .AND.(LB1.GE.-17.AND.LB1.LE.-14)) )go to 5999
2500 c La/Si + B-bar --> pi + K-
2501        IF( (((LB1.eq.-1.or.LB1.eq.-2).or.(LB1.le.-6.and.LB1.ge.-13))
2502      &       .AND.(LB2.GE.14.AND.LB2.LE.17)) .OR.
2503      &     (((LB2.eq.-1.or.LB2.eq.-2).or.(LB2.le.-6.and.LB2.ge.-13))
2504      &       .AND.(LB1.GE.14.AND.LB1.LE.17)) )go to 5999 
2505 *
2506 *
2507 * K(K*) + Kbar(K*bar) --> phi + pi(rho,omega), M + M (M=pi,rho,omega,eta)
2508        if(lb1.eq.21.and.lb2.eq.23) go to 8699
2509        if(lb2.eq.21.and.lb1.eq.23) go to 8699
2510        if(lb1.eq.30.and.lb2.eq.21) go to 8699
2511        if(lb2.eq.30.and.lb1.eq.21) go to 8699
2512        if(lb1.eq.-30.and.lb2.eq.23) go to 8699
2513        if(lb2.eq.-30.and.lb1.eq.23) go to 8699
2514        if(lb1.eq.-30.and.lb2.eq.30) go to 8699
2515        if(lb2.eq.-30.and.lb1.eq.30) go to 8699
2516 c* (K,K*)-bar + rho(omega) --> phi +(K,K*)-bar, piK and elastic
2517        IF( ((lb1.eq.23.or.lb1.eq.21.or.iabs(lb1).eq.30) .and.
2518      &      (lb2.ge.25.and.lb2.le.28)) .OR.
2519      &     ((lb2.eq.23.or.lb2.eq.21.or.iabs(lb2).eq.30) .and.
2520      &      (lb1.ge.25.and.lb1.le.28)) ) go to 8799
2521 c
2522 c* K*(-bar) + pi --> phi + (K,K*)-bar
2523        IF( (iabs(lb1).eq.30.and.(lb2.ge.3.and.lb2.le.5)) .OR.
2524      &     (iabs(lb2).eq.30.and.(lb1.ge.3.and.lb1.le.5)) )go to 8799
2525 *
2526 c
2527 c* phi + N --> pi+N(D),  rho+N(D),  K+ +La
2528 c* phi + D --> pi+N(D),  rho+N(D)
2529        IF( (lb1.eq.29 .and.(lb2.eq.1.or.lb2.eq.2.or.
2530      &       (lb2.ge.6.and.lb2.le.9))) .OR.
2531      &     (lb2.eq.29 .and.(lb1.eq.1.or.lb1.eq.2.or.
2532      &       (lb1.ge.6.and.lb1.le.9))) )go to 7222
2533 c
2534 c* phi + (pi,rho,ome,K,K*-bar) --> K+K, K+K*, K*+K*, (pi,rho,omega)+(K,K*-bar)
2535        IF( (lb1.eq.29 .and.((lb2.ge.3.and.lb2.le.5).or.
2536      &      (lb2.ge.21.and.lb2.le.28).or.iabs(lb2).eq.30)) .OR.
2537      &     (lb2.eq.29 .and.((lb1.ge.3.and.lb1.le.5).or.
2538      &      (lb1.ge.21.and.lb1.le.28).or.iabs(lb1).eq.30)) )THEN
2539              go to 7444
2540       endif
2541 *
2542 c
2543 * La/Si, Cas, Om (bar)-(rho,omega,phi) elastic colln
2544 * pion vs. La, Ca, Omega-(bar) elastic coll. treated in resp. subroutines
2545       if( ((iabs(lb1).ge.14.and.iabs(lb1).le.17).or.iabs(lb1).ge.40)
2546      &    .and.((lb2.ge.25.and.lb2.le.29).or.lb2.eq.0) )go to 888
2547       if( ((iabs(lb2).ge.14.and.iabs(lb2).le.17).or.iabs(lb2).ge.40)
2548      &    .and.((lb1.ge.25.and.lb1.le.29).or.lb1.eq.0) )go to 888
2549 c
2550 c K+/K* (N,R)  OR   K-/K*- (N,R)-bar  elastic scatt
2551         if( ((lb1.eq.23.or.lb1.eq.30).and.(lb2.eq.1.or.lb2.eq.2.or.
2552      &         (lb2.ge.6.and.lb2.le.13))) .OR.
2553      &      ((lb2.eq.23.or.lb2.eq.30).and.(lb1.eq.1.or.lb1.eq.2.or.
2554      &         (lb1.ge.6.and.lb1.le.13))) ) go to 888
2555         if( ((lb1.eq.21.or.lb1.eq.-30).and.(lb2.eq.-1.or.lb2.eq.-2.or.
2556      &       (lb2.ge.-13.and.lb2.le.-6))) .OR. 
2557      &      ((lb2.eq.21.or.lb2.eq.-30).and.(lb1.eq.-1.or.lb1.eq.-2.or.
2558      &       (lb1.ge.-13.and.lb1.le.-6))) ) go to 888
2559 c
2560 * L/S-baryon elastic collision 
2561        If( ((lb1.ge.14.and.lb1.le.17).and.(lb2.ge.6.and.lb2.le.13))
2562      & .OR.((lb2.ge.14.and.lb2.le.17).and.(lb1.ge.6.and.lb1.le.13)) )
2563      &   go to 7799
2564        If(((lb1.le.-14.and.lb1.ge.-17).and.(lb2.le.-6.and.lb2.ge.-13))
2565      &.OR.((lb2.le.-14.and.lb2.ge.-17).and.(lb1.le.-6.and.lb1.ge.-13)))
2566      &   go to 7799
2567 c
2568 c skip other collns with perturbative particles or hyperon-bar
2569        if( iabs(lb1).ge.40 .or. iabs(lb2).ge.40
2570      &    .or. (lb1.le.-14.and.lb1.ge.-17) 
2571      &    .or. (lb2.le.-14.and.lb2.ge.-17) )go to 400
2572 c
2573 c
2574 * anti-baryon on baryon resonaces 
2575         if((lb1.eq.-1.or.lb1.eq.-2.or.(lb1.ge.-13.and.lb1.le.-6))
2576      1 .and.(lb2.eq.1.or.lb2.eq.2.or.(lb2.ge.6.and.lb2.le.13))) then
2577             GOTO 2799
2578        else if((lb2.eq.-1.or.lb2.eq.-2.or.(lb2.ge.-13.and.lb2.le.-6))
2579      1 .and.(lb1.eq.1.or.lb1.eq.2.or.(lb1.ge.6.and.lb1.le.13))) then
2580             GOTO 2799
2581          END IF
2582 c
2583 clin-10/25/02 get rid of argument usage mismatch in newka():
2584          inewka=irun
2585 c        call newka(icase,irun,iseed,dt,nt,
2586 clin-5/01/03 set iblock value in art1f.f, necessary for resonance studies:
2587 c        call newka(icase,inewka,iseed,dt,nt,
2588 c     &                  ictrl,i1,i2,srt,pcx,pcy,pcz)
2589         call newka(icase,inewka,iseed,dt,nt,
2590      &                  ictrl,i1,i2,srt,pcx,pcy,pcz,iblock)
2591 
2592 clin-10/25/02-end
2593         IF (ICTRL .EQ. 1) GOTO 400
2594 c
2595 * SEPARATE NUCLEON+NUCLEON( BARYON RESONANCE+ BARYON RESONANCE ELASTIC
2596 * COLLISION), BARYON RESONANCE+NUCLEON AND BARYON-PION
2597 * COLLISIONS INTO THREE PARTS TO CHECK IF THEY ARE GOING TO SCATTER,
2598 * WE only allow L/S to COLLIDE elastically with a nucleon and meson
2599        if((iabs(lb1).ge.14.and.iabs(lb1).le.17).
2600      &  or.(iabs(lb2).ge.14.and.iabs(lb2).le.17))go to 400
2601 * IF PION+PION COLLISIONS GO TO 777
2602 * if pion+eta, eta+eta to create kaons go to 777 
2603        IF((lb1.ge.3.and.lb1.le.5).and.(lb2.ge.3.and.lb2.le.5))GO TO 777
2604        if(lb1.eq.0.and.(lb2.ge.3.and.lb2.le.5)) go to 777
2605        if(lb2.eq.0.and.(lb1.ge.3.and.lb1.le.5)) go to 777
2606        if(lb1.eq.0.and.lb2.eq.0)go to 777
2607 * we assume that rho and omega behave the same way as pions in 
2608 * kaon production
2609 * (1) rho(omega)+rho(omega)
2610        if( (lb1.ge.25.and.lb1.le.28).and.
2611      &     (lb2.ge.25.and.lb2.le.28) )goto 777
2612 * (2) rho(omega)+pion
2613       If((lb1.ge.25.and.lb1.le.28).and.(lb2.ge.3.and.lb2.le.5))go to 777
2614       If((lb2.ge.25.and.lb2.le.28).and.(lb1.ge.3.and.lb1.le.5))go to 777
2615 * (3) rho(omega)+eta
2616        if((lb1.ge.25.and.lb1.le.28).and.lb2.eq.0)go to 777
2617        if((lb2.ge.25.and.lb2.le.28).and.lb1.eq.0)go to 777
2618 c
2619 * if kaon+pion collisions go to 889
2620        if((lb1.eq.23.or.lb1.eq.21).and.(lb2.ge.3.and.lb2.le.5))go to 889
2621        if((lb2.eq.23.or.lb2.eq.21).and.(lb1.ge.3.and.lb1.le.5))go to 889
2622 c
2623 clin-2/06/03 skip all other (K K* Kbar K*bar) channels:
2624 * SKIP all other K and K* RESCATTERINGS
2625         If(iabs(lb1).eq.30.or.iabs(lb2).eq.30) go to 400
2626         If(lb1.eq.21.or.lb2.eq.21) go to 400
2627         If(lb1.eq.23.or.lb2.eq.23) go to 400
2628 c
2629 * IF PION+baryon COLLISION GO TO 3
2630            IF( (LB1.ge.3.and.LB1.le.5) .and. 
2631      &         (iabs(LB2).eq.1.or.iabs(LB2).eq.2.or.
2632      &          (iabs(LB2).ge.6.and.iabs(LB2).le.13)) )GO TO 3
2633            IF( (LB2.ge.3.and.LB2.le.5) .and. 
2634      &         (iabs(LB1).eq.1.or.iabs(LB1).eq.2.or.
2635      &          (iabs(LB1).ge.6.and.iabs(LB1).le.13)) )GO TO 3
2636 c
2637 * IF rho(omega)+NUCLEON (baryon resonance) COLLISION GO TO 33
2638            IF( (LB1.ge.25.and.LB1.le.28) .and. 
2639      &         (iabs(LB2).eq.1.or.iabs(LB2).eq.2.or.
2640      &          (iabs(LB2).ge.6.and.iabs(LB2).le.13)) )GO TO 33
2641            IF( (LB2.ge.25.and.LB2.le.28) .and. 
2642      &         (iabs(LB1).eq.1.or.iabs(LB1).eq.2.or.
2643      &          (iabs(LB1).ge.6.and.iabs(LB1).le.13)) )GO TO 33
2644 c
2645 * IF ETA+NUCLEON (baryon resonance) COLLISIONS GO TO 547
2646            IF( LB1.eq.0 .and. 
2647      &         (iabs(LB2).eq.1.or.iabs(LB2).eq.2.or.
2648      &          (iabs(LB2).ge.6.and.iabs(LB2).le.13)) )GO TO 547
2649            IF( LB2.eq.0 .and. 
2650      &         (iabs(LB1).eq.1.or.iabs(LB1).eq.2.or.
2651      &          (iabs(LB1).ge.6.and.iabs(LB1).le.13)) )GO TO 547
2652 c
2653 * IF NUCLEON+BARYON RESONANCE COLLISION GO TO 44
2654             IF((LB1.eq.1.or.lb1.eq.2).
2655      &        AND.(LB2.GT.5.and.lb2.le.13))GOTO 44
2656             IF((LB2.eq.1.or.lb2.eq.2).
2657      &        AND.(LB1.GT.5.and.lb1.le.13))GOTO 44
2658             IF((LB1.eq.-1.or.lb1.eq.-2).
2659      &        AND.(LB2.LT.-5.and.lb2.ge.-13))GOTO 44
2660             IF((LB2.eq.-1.or.lb2.eq.-2).
2661      &        AND.(LB1.LT.-5.and.lb1.ge.-13))GOTO 44
2662 c
2663 * IF NUCLEON+NUCLEON COLLISION GO TO 4
2664        IF((LB1.eq.1.or.lb1.eq.2).AND.(LB2.eq.1.or.lb2.eq.2))GOTO 4
2665        IF((LB1.eq.-1.or.lb1.eq.-2).AND.(LB2.eq.-1.or.lb2.eq.-2))GOTO 4
2666 c
2667 * IF BARYON RESONANCE+BARYON RESONANCE COLLISION GO TO 444
2668             IF((LB1.GT.5.and.lb1.le.13).AND.
2669      &         (LB2.GT.5.and.lb2.le.13)) GOTO 444
2670             IF((LB1.LT.-5.and.lb1.ge.-13).AND.
2671      &         (LB2.LT.-5.and.lb2.ge.-13)) GOTO 444
2672 c
2673 * if L/S+L/S or L/s+nucleon go to 400
2674 * otherwise, develop a model for their collisions
2675        if((lb1.lt.3).and.(lb2.ge.14.and.lb2.le.17))goto 400
2676        if((lb2.lt.3).and.(lb1.ge.14.and.lb1.le.17))goto 400
2677        if((lb1.ge.14.and.lb1.le.17).and.
2678      &  (lb2.ge.14.and.lb2.le.17))goto 400
2679 c
2680 * otherwise, go out of the loop
2681               go to 400
2682 *
2683 *
2684 547           IF(LB1*LB2.EQ.0)THEN
2685 * (1) FOR ETA+NUCLEON SYSTEM, we allow both elastic collision, 
2686 *     i.e. N*(1535) formation and kaon production
2687 *     the total kaon production cross section is
2688 *     ASSUMED to be THE SAME AS PION+NUCLEON COLLISIONS
2689 * (2) for eta+baryon resonance we only allow kaon production
2690            ece=(em1+em2+0.02)**2
2691            xkaon0=0.
2692            if(srt.ge.1.63.AND.SRT.LE.1.7)xkaon0=pnlka(srt)
2693            IF(SRT.GT.1.7)XKAON0=PNLKA(SRT)+pnska(srt)
2694 cbz3/7/99 neutralk
2695             XKAON0 = 2.0 * XKAON0
2696 cbz3/7/99 neutralk end
2697 
2698 * Here we negelect eta+n inelastic collisions other than the 
2699 * kaon production, therefore the total inelastic cross section
2700 * xkaon equals to the xkaon0 (kaon production cross section)
2701            xkaon=xkaon0
2702 * note here the xkaon is in unit of fm**2
2703             XETA=XN1535(I1,I2,0)
2704         If((iabs(LB(I1)).ge.6.and.iabs(LB(I1)).le.13).or.
2705      &     (iabs(LB(I2)).ge.6.and.iabs(LB(I2)).le.13)) xeta=0.      
2706             IF((XETA+xkaon).LE.1.e-06)GO TO 400
2707             DSE=SQRT((XETA+XKAON)/PI)
2708            DELTRE=DSE+0.1
2709         px1cm=pcx
2710         py1cm=pcy
2711         pz1cm=pcz
2712 * CHECK IF N*(1535) resonance CAN BE FORMED
2713          CALL DISTCE(I1,I2,DELTRE,DSE,DT,ECE,SRT,IC,
2714      1   PCX,PCY,PCZ)
2715          IF(IC.EQ.-1) GO TO 400
2716          ekaon(4,iss)=ekaon(4,iss)+1
2717         IF(XKAON0/(XKAON+XETA).GT.RANART(NSEED))then
2718 * kaon production, USE CREN TO CALCULATE THE MOMENTUM OF L/S K+
2719         CALL CREN(PX1CM,PY1CM,PZ1CM,SRT,I1,I2,IBLOCK)
2720 * kaon production
2721        IF(IBLOCK.EQ.7) then
2722           LPN=LPN+1
2723        elseIF(IBLOCK.EQ.-7) then
2724        endif
2725 c
2726        em1=e(i1)
2727        em2=e(i2)
2728        GO TO 440
2729        endif
2730 * N*(1535) FORMATION
2731         resona=1.
2732          GO TO 98
2733          ENDIF
2734 *IF PION+NUCLEON (baryon resonance) COLLISION THEN
2735 3           CONTINUE
2736            px1cm=pcx
2737            py1cm=pcy
2738            pz1cm=pcz
2739 * the total kaon production cross section for pion+baryon (resonance) is
2740 * assumed to be the same as in pion+nucleon
2741            xkaon0=0.
2742            if(srt.ge.1.63.AND.SRT.LE.1.7)xkaon0=pnlka(srt)
2743            IF(SRT.GT.1.7)XKAON0=PNLKA(SRT)+pnska(srt)
2744             XKAON0 = 2.0 * XKAON0
2745 c
2746 c sp11/21/01  phi production: pi +N(D) -> phi + N(D)
2747          Xphi = 0.
2748        if( ( ((lb1.ge.1.and.lb1.le.2).or.
2749      &        (lb1.ge.6.and.lb1.le.9))
2750      &   .OR.((lb2.ge.1.and.lb2.le.2).or.
2751      &        (lb2.ge.6.and.lb2.le.9)) )
2752      &       .AND. srt.gt.1.958)
2753      &        call pibphi(srt,lb1,lb2,em1,em2,Xphi,xphin)
2754 c !! in fm^2 above
2755 
2756 * if a pion collide with a baryon resonance, 
2757 * we only allow kaon production AND the reabsorption 
2758 * processes: Delta+pion-->N+pion, N*+pion-->N+pion
2759 * Later put in pion+baryon resonance elastic
2760 * cross through forming higher resonances implicitly.
2761 c          If(em1.gt.1.or.em2.gt.1.)go to 31
2762          If((iabs(LB(I1)).ge.6.and.iabs(LB(I1)).le.13).or.
2763      &      (iabs(LB(I2)).ge.6.and.iabs(LB(I2)).le.13)) go to 31
2764 * For pion+nucleon collisions: 
2765 * using the experimental pion+nucleon inelastic cross section, we assume it
2766 * is exhausted by the Delta+pion, Delta+rho and Delta+omega production 
2767 * and kaon production. In the following we first check whether 
2768 * inelastic pion+n collision can happen or not, then determine in 
2769 * crpn whether it is through pion production or through kaon production
2770 * note that the xkaon0 is the kaon production cross section
2771 * Note in particular that: 
2772 * xkaon in the following is the total pion+nucleon inelastic cross section
2773 * note here the xkaon is in unit of fm**2, xnpi is also in unit of fm**2
2774 * FOR PION+NUCLEON SYSTEM, THE MINIMUM S IS 1.2056 the minimum srt for 
2775 * elastic scattering, and it is 1.60 for pion production, 1.63 for LAMBDA+kaon 
2776 * production and 1.7 FOR SIGMA+KAON
2777 * (EC = PION MASS+NUCLEON MASS+20MEV)**2
2778             EC=(em1+em2+0.02)**2
2779            xkaon=0.
2780            if(srt.gt.1.23)xkaon=(pionpp(srt)+PIPP1(SRT))/2.
2781 * pion+nucleon elastic cross section is divided into two parts:
2782 * (1) forming D(1232)+N*(1440) +N*(1535)
2783 * (2) cross sections forming higher resonances are calculated as
2784 *     the difference between the total elastic and (1), this part is 
2785 *     treated as direct process since we do not explicitLY include
2786 *     higher resonances.
2787 * the following is the resonance formation cross sections.
2788 *1. PION(+)+PROTON-->DELTA++,PION(-)+NEUTRON-->DELTA(-)
2789            IF( (LB1*LB2.EQ.5.OR.((LB1*LB2.EQ.6).AND.
2790      &         (LB1.EQ.3.OR.LB2.EQ.3)))
2791      &    .OR. (LB1*LB2.EQ.-3.OR.((LB1*LB2.EQ.-10).AND.
2792      &         (LB1.EQ.5.OR.LB2.EQ.5))) )then    
2793               XMAX=190.
2794               xmaxn=0
2795               xmaxn1=0
2796               xdirct=dirct1(srt)
2797                go to 678
2798            endif
2799 *2. PION(-)+PROTON-->DELTA0,PION(+)+NEUTRON-->DELTA+ 
2800 *   or N*(+)(1440) or N*(+)(1535)
2801 * note the factor 2/3 is from the isospin consideration and
2802 * the factor 0.6 or 0.5 is the branching ratio for the resonance to decay
2803 * into pion+nucleon
2804             IF( (LB1*LB2.EQ.3.OR.((LB1*LB2.EQ.10).AND.
2805      &          (LB1.EQ.5.OR.LB2.EQ.5)))
2806      &     .OR. (LB1*LB2.EQ.-5.OR.((LB1*LB2.EQ.-6).AND.
2807      &          (LB1.EQ.3.OR.LB2.EQ.3))) )then      
2808               XMAX=27.
2809               xmaxn=2./3.*25.*0.6
2810                xmaxn1=2./3.*40.*0.5
2811               xdirct=dirct2(srt)
2812                go to 678
2813               endif
2814 *3. PION0+PROTON-->DELTA+,PION0+NEUTRON-->DELTA0, or N*(0)(1440) or N*(0)(1535)
2815             IF((LB1.EQ.4.OR.LB2.EQ.4).AND.
2816      &         (iabs(LB1*LB2).EQ.4.OR.iabs(LB1*LB2).EQ.8))then
2817               XMAX=50.
2818               xmaxn=1./3.*25*0.6
2819               xmaxn1=1/3.*40.*0.5
2820               xdirct=dirct3(srt)
2821                 go to 678
2822               endif
2823 678           xnpin1=0
2824            xnpin=0
2825             XNPID=XNPI(I1,I2,1,XMAX)
2826            if(xmaxn1.ne.0)xnpin1=XNPI(i1,i2,2,XMAXN1)
2827             if(xmaxn.ne.0)XNPIN=XNPI(I1,I2,0,XMAXN)
2828 * the following 
2829            xres=xnpid+xnpin+xnpin1
2830            xnelas=xres+xdirct 
2831            icheck=1
2832            go to 34
2833 * For pion + baryon resonance the reabsorption 
2834 * cross section is calculated from the detailed balance
2835 * using reab(i1,i2,srt,ictrl), ictrl=1, 2 and 3
2836 * for pion, rho and omega + baryon resonance
2837 31           ec=(em1+em2+0.02)**2
2838            xreab=reab(i1,i2,srt,1)
2839 
2840 clin-12/02/00 to satisfy detailed balance, forbid N* absorptions:
2841           if((iabs(lb1).ge.10.and.iabs(lb1).le.13)
2842      1         .or.(iabs(lb2).ge.10.and.iabs(lb2).le.13)) XREAB = 0.
2843 
2844            xkaon=xkaon0+xreab
2845 * a constant of 10 mb IS USED FOR PION + N* RESONANCE, 
2846         IF((iabs(LB1).GT.9.AND.iabs(LB1).LE.13) .OR.
2847      &      (iabs(LB2).GT.9.AND.iabs(LB2).LE.13))THEN
2848            Xnelas=1.0
2849         ELSE
2850            XNELAS=DPION(EM1,EM2,LB1,LB2,SRT)
2851         ENDIF
2852            icheck=2
2853 34          IF((Xnelas+xkaon+Xphi).LE.0.000001)GO TO 400
2854             DS=SQRT((Xnelas+xkaon+Xphi)/PI)
2855 csp09/20/01
2856 c           totcr = xnelas+xkaon
2857 c           if(srt .gt. 3.5)totcr = max1(totcr,3.)
2858 c           DS=SQRT(totcr/PI)
2859 csp09/20/01 end
2860             
2861            deltar=ds+0.1
2862          CALL DISTCE(I1,I2,DELTAR,DS,DT,EC,SRT,IC,
2863      1   PCX,PCY,PCZ)
2864          IF(IC.EQ.-1) GO TO 400
2865        ekaon(4,iss)=ekaon(4,iss)+1
2866 c***
2867 * check what kind of collision has happened
2868 * (1) pion+baryon resonance
2869 * if direct elastic process
2870         if(icheck.eq.2)then
2871 c  !!sp11/21/01
2872       if(xnelas/(xnelas+xkaon+Xphi).ge.RANART(NSEED))then
2873 c               call Crdir(PX1CM,PY1CM,PZ1CM,SRT,I1,I2)
2874                call Crdir(PX1CM,PY1CM,PZ1CM,SRT,I1,I2,IBLOCK)
2875               go to 440
2876               else
2877 * for inelastic process, go to 96 to check
2878 * kaon production and pion reabsorption : pion+D(N*)-->pion+N
2879                go to 96
2880                 endif
2881               endif
2882 *(2) pion+n
2883 * CHECK IF inELASTIC COLLISION IS POSSIBLE FOR PION+N COLLISIONS
2884 clin-8/17/00 typo corrected, many other occurences:
2885 c        IF(XKAON/(XKAON+Xnelas).GT.RANART(NSEED))GO TO 95
2886        IF((XKAON+Xphi)/(XKAON+Xphi+Xnelas).GT.RANART(NSEED))GO TO 95
2887 
2888 * direct process
2889         if(xdirct/xnelas.ge.RANART(NSEED))then
2890 c               call Crdir(PX1CM,PY1CM,PZ1CM,SRT,I1,I2)
2891                call Crdir(PX1CM,PY1CM,PZ1CM,SRT,I1,I2,IBLOCK)
2892               go to 440
2893               endif
2894 * now resonance formation or direct process (higher resonances)
2895            IF( (LB1*LB2.EQ.5.OR.((LB1*LB2.EQ.6).AND.
2896      &         (LB1.EQ.3.OR.LB2.EQ.3)))
2897      &    .OR. (LB1*LB2.EQ.-3.OR.((LB1*LB2.EQ.-10).AND.
2898      &         (LB1.EQ.5.OR.LB2.EQ.5))) )then    
2899 c
2900 * ONLY DELTA RESONANCE IS POSSIBLE, go to 99
2901         GO TO 99
2902        else
2903 * NOW BOTH DELTA AND N* RESORANCE ARE POSSIBLE
2904 * DETERMINE THE RESORANT STATE BY USING THE MONTRE CARLO METHOD
2905             XX=(XNPIN+xnpin1)/xres
2906             IF(RANART(NSEED).LT.XX)THEN
2907 * N* RESONANCE IS SELECTED
2908 * decide N*(1440) or N*(1535) formation
2909         xx0=xnpin/(xnpin+xnpin1)
2910         if(RANART(NSEED).lt.xx0)then
2911          RESONA=0.
2912 * N*(1440) formation
2913          GO TO 97
2914         else
2915 * N*(1535) formation
2916         resona=1.
2917          GO TO 98
2918         endif
2919          ELSE
2920 * DELTA RESONANCE IS SELECTED
2921          GO TO 99
2922          ENDIF
2923          ENDIF
2924 97       CONTINUE
2925             IF(RESONA.EQ.0.)THEN
2926 *N*(1440) IS PRODUCED,WE DETERMINE THE CHARGE STATE OF THE PRODUCED N*
2927             I=I1
2928             IF(EM1.LT.0.6)I=I2
2929 * (0.1) n+pion(+)-->N*(+)
2930            IF( (LB1*LB2.EQ.10.AND.(LB1.EQ.5.OR.LB2.EQ.5))
2931      &      .OR.(LB1*LB2.EQ.-6.AND.(LB1.EQ.3.OR.LB2.EQ.3)) )THEN
2932             LB(I)=11
2933            go to 303
2934             ENDIF
2935 * (0.2) p+pion(0)-->N*(+)
2936 c            IF(LB(I1)*LB(I2).EQ.4.AND.(LB(I1).EQ.1.OR.LB(I2).EQ.1))THEN
2937             IF(iabs(LB(I1)*LB(I2)).EQ.4.AND.
2938      &         (LB(I1).EQ.4.OR.LB(I2).EQ.4))THEN    
2939             LB(I)=11
2940            go to 303
2941             ENDIF
2942 * (0.3) n+pion(0)-->N*(0)
2943 c            IF(LB(I1)*LB(I2).EQ.8.AND.(LB(I1).EQ.2.OR.LB(I2).EQ.2))THEN
2944             IF(iabs(LB(I1)*LB(I2)).EQ.8.AND.
2945      &        (LB(I1).EQ.4.OR.LB(I2).EQ.4))THEN    
2946             LB(I)=10
2947            go to 303
2948             ENDIF
2949 * (0.4) p+pion(-)-->N*(0)
2950 c            IF(LB(I1)*LB(I2).EQ.3)THEN
2951             IF( (LB(I1)*LB(I2).EQ.3)
2952      &      .OR.(LB(I1)*LB(I2).EQ.-5) )THEN
2953             LB(I)=10
2954             ENDIF
2955 303         CALL DRESON(I1,I2)
2956             if(LB1.lt.0.or.LB2.lt.0) LB(I)=-LB(I)
2957             lres=lres+1
2958             GO TO 101
2959 *COM: GO TO 101 TO CHANGE THE PHASE SPACE DENSITY OF THE NUCLEON
2960             ENDIF
2961 98          IF(RESONA.EQ.1.)THEN
2962 *N*(1535) IS PRODUCED, WE DETERMINE THE CHARGE STATE OF THE PRODUCED N*
2963             I=I1
2964             IF(EM1.LT.0.6)I=I2
2965 * note: this condition applies to both eta and pion
2966 * (0.1) n+pion(+)-->N*(+)
2967 c            IF(LB1*LB2.EQ.10.AND.(LB1.EQ.2.OR.LB2.EQ.2))THEN
2968             IF( (LB1*LB2.EQ.10.AND.(LB1.EQ.5.OR.LB2.EQ.5))
2969      &      .OR.(LB1*LB2.EQ.-6.AND.(LB1.EQ.3.OR.LB2.EQ.3)) )THEN
2970             LB(I)=13
2971            go to 304
2972             ENDIF
2973 * (0.2) p+pion(0)-->N*(+)
2974 c            IF(LB(I1)*LB(I2).EQ.4.AND.(LB(I1).EQ.1.OR.LB(I2).EQ.1))THEN
2975             IF(iabs(LB(I1)*LB(I2)).EQ.4.AND.
2976      &           (LB(I1).EQ.4.OR.LB(I2).EQ.4))THEN 
2977             LB(I)=13
2978            go to 304
2979             ENDIF
2980 * (0.3) n+pion(0)-->N*(0)
2981 c            IF(LB(I1)*LB(I2).EQ.8.AND.(LB(I1).EQ.2.OR.LB(I2).EQ.2))THEN
2982             IF(iabs(LB(I1)*LB(I2)).EQ.8.AND.
2983      &           (LB(I1).EQ.4.OR.LB(I2).EQ.4))THEN      
2984             LB(I)=12
2985            go to 304
2986             ENDIF
2987 * (0.4) p+pion(-)-->N*(0)
2988 c            IF(LB(I1)*LB(I2).EQ.3)THEN
2989             IF( (LB(I1)*LB(I2).EQ.3)
2990      &      .OR.(LB(I1)*LB(I2).EQ.-5) )THEN
2991             LB(I)=12
2992            go to 304
2993            endif
2994 * (0.5) p+eta-->N*(+)(1535),n+eta-->N*(0)(1535)
2995            if(lb(i1)*lb(i2).eq.0)then
2996 c            if((lb(i1).eq.1).or.(lb(i2).eq.1))then
2997             if(iabs(lb(i1)).eq.1.or.iabs(lb(i2)).eq.1)then
2998            LB(I)=13
2999            go to 304
3000            ELSE
3001            LB(I)=12
3002            ENDIF
3003            endif
3004 304         CALL DRESON(I1,I2)
3005             if(LB1.lt.0.or.LB2.lt.0) LB(I)=-LB(I) 
3006             lres=lres+1
3007             GO TO 101
3008 *COM: GO TO 101 TO CHANGE THE PHASE SPACE DENSITY OF THE NUCLEON
3009             ENDIF
3010 *DELTA IS PRODUCED,IN THE FOLLOWING WE DETERMINE THE
3011 *CHARGE STATE OF THE PRODUCED DELTA
3012 99      LRES=LRES+1
3013         I=I1
3014         IF(EM1.LE.0.6)I=I2
3015 * (1) p+pion(+)-->DELTA(++)
3016 c        IF(LB(I1)*LB(I2).EQ.5)THEN
3017             IF( (LB(I1)*LB(I2).EQ.5)
3018      &      .OR.(LB(I1)*LB(I2).EQ.-3) )THEN
3019         LB(I)=9
3020        go to 305
3021         ENDIF
3022 * (2) p+pion(0)-->delta(+)
3023 c        IF(LB(I1)*LB(I2).EQ.4.AND.(LB(I1).EQ.1.OR.LB(I2).EQ.1))then
3024        IF(iabs(LB(I1)*LB(I2)).EQ.4.AND.(LB(I1).EQ.4.OR.LB(I2).EQ.4))then
3025         LB(I)=8
3026        go to 305
3027         ENDIF
3028 * (3) n+pion(+)-->delta(+)
3029 c        IF(LB(I1)*LB(I2).EQ.10.AND.(LB(I1).EQ.2.OR.LB(I2).EQ.2))THEN
3030        IF( (LB(I1)*LB(I2).EQ.10.AND.(LB(I1).EQ.5.OR.LB(I2).EQ.5))
3031      & .OR.(LB(I1)*LB(I2).EQ.-6.AND.(LB(I1).EQ.3.OR.LB(I2).EQ.3)) )THEN
3032         LB(I)=8
3033        go to 305
3034         ENDIF
3035 * (4) n+pion(0)-->delta(0)
3036 c        IF(LB(I1)*LB(I2).EQ.8.AND.(LB(I1).EQ.2.OR.LB(I2).EQ.2))THEN
3037        IF(iabs(LB(I1)*LB(I2)).EQ.8.AND.(LB(I1).EQ.4.OR.LB(I2).EQ.4))THEN
3038         LB(I)=7
3039        go to 305
3040         ENDIF
3041 * (5) p+pion(-)-->delta(0)
3042 c        IF(LB(I1)*LB(I2).EQ.3)THEN
3043             IF( (LB(I1)*LB(I2).EQ.3)
3044      &      .OR.(LB(I1)*LB(I2).EQ.-5) )THEN
3045         LB(I)=7
3046        go to 305
3047         ENDIF
3048 * (6) n+pion(-)-->delta(-)
3049 c        IF(LB(I1)*LB(I2).EQ.6.AND.(LB(I1).EQ.2.OR.LB(I2).EQ.2))THEN
3050        IF( (LB(I1)*LB(I2).EQ.6.AND.(LB(I1).EQ.3.OR.LB(I2).EQ.3))
3051      & .OR.(LB(I1)*LB(I2).EQ.-10.AND.(LB(I1).EQ.5.OR.LB(I2).EQ.5)) )THEN 
3052         LB(I)=6
3053         ENDIF
3054 305     CALL DRESON(I1,I2)
3055         if(LB1.lt.0.or.LB2.lt.0) LB(I)=-LB(I) 
3056        GO TO 101
3057 
3058 csp-11/08/01 K*
3059 * FOR kaON+pion COLLISIONS, form K* (bar) or
3060 c La/Si-bar + N <-- pi + K+
3061 c La/Si + N-bar <-- pi + K-                                             
3062 c phi + K <-- pi + K                                             
3063 clin (rho,omega) + K* <-- pi + K
3064 889       CONTINUE
3065         PX1CM=PCX
3066         PY1CM=PCY
3067         PZ1CM=PCZ
3068         EC=(em1+em2+0.02)**2
3069 * the cross section is from C.M. Ko, PRC 23, 2760 (1981).
3070        spika=60./(1.+4.*(srt-0.895)**2/(0.05)**2)
3071 c
3072 cc       if(lb(i1).eq.23.or.lb(i2).eq.23)then   !! block  K- + pi->La + B-bar
3073 
3074         call Crkpla(PX1CM,PY1CM,PZ1CM,EC,SRT,spika,
3075      &                  emm1,emm2,lbp1,lbp2,I1,I2,icase,srhoks)
3076 cc
3077 c* only K* or K*bar formation
3078 c       else 
3079 c      DSkn=SQRT(spika/PI/10.)
3080 c      dsknr=dskn+0.1
3081 c      CALL DISTCE(I1,I2,dsknr,DSkn,DT,EC,SRT,IC,
3082 c    1     PX1CM,PY1CM,PZ1CM)
3083 c        IF(IC.EQ.-1) GO TO 400
3084 c       icase = 1
3085 c      endif
3086 c
3087          if(icase .eq. 0) then
3088             iblock=0
3089             go to 400
3090          endif
3091 
3092        if(icase .eq. 1)then
3093              call KSRESO(I1,I2)
3094 clin-4/30/03 give non-zero iblock for resonance selections:
3095              iblock = 171
3096 ctest off for resonance (phi, K*) studies:
3097 c             if(iabs(lb(i1)).eq.30) then
3098 c             write(17,112) 'ks',lb(i1),p(1,i1),p(2,i1),p(3,i1),e(i1),nt
3099 c             elseif(iabs(lb(i2)).eq.30) then
3100 c             write(17,112) 'ks',lb(i2),p(1,i2),p(2,i2),p(3,i2),e(i2),nt
3101 c             endif
3102 c
3103               lres=lres+1
3104               go to 101
3105        elseif(icase .eq. 2)then
3106              iblock = 71
3107 c
3108 * La/Si (bar) formation                                                   
3109 
3110        elseif(iabs(icase).eq.5)then
3111              iblock = 88
3112 
3113        else
3114 *
3115 * phi formation
3116              iblock = 222
3117        endif
3118              LB(I1) = lbp1
3119              LB(I2) = lbp2
3120              E(I1) = emm1
3121              E(I2) = emm2
3122              em1=e(i1)
3123              em2=e(i2)
3124              ntag = 0
3125              go to 440
3126 c             
3127 33       continue
3128        em1=e(i1)
3129        em2=e(i2)
3130 * (1) if rho or omega collide with a nucleon we allow both elastic 
3131 *     scattering and kaon production to happen if collision conditions 
3132 *     are satisfied.
3133 * (2) if rho or omega collide with a baryon resonance we allow
3134 *     kaon production, pion reabsorption: rho(omega)+D(N*)-->pion+N
3135 *     and NO elastic scattering to happen
3136            xelstc=0
3137             if((lb1.ge.25.and.lb1.le.28).and.
3138      &    (iabs(lb2).eq.1.or.iabs(lb2).eq.2))
3139      &      xelstc=ERHON(EM1,EM2,LB1,LB2,SRT)
3140             if((lb2.ge.25.and.lb2.le.28).and.
3141      &   (iabs(lb1).eq.1.or.iabs(lb1).eq.2))
3142      &      xelstc=ERHON(EM1,EM2,LB1,LB2,SRT)
3143             ec=(em1+em2+0.02)**2
3144 * the kaon production cross section is
3145            xkaon0=0
3146            if(srt.ge.1.63.AND.SRT.LE.1.7)xkaon0=pnlka(srt)
3147            IF(SRT.GT.1.7)XKAON0=PNLKA(SRT)+pnska(srt)
3148            if(xkaon0.lt.0)xkaon0=0
3149 
3150 cbz3/7/99 neutralk
3151             XKAON0 = 2.0 * XKAON0
3152 cbz3/7/99 neutralk end
3153 
3154 * the total inelastic cross section for rho(omega)+N is
3155            xkaon=xkaon0
3156            ichann=0
3157 * the total inelastic cross section for rho (omega)+D(N*) is 
3158 * xkaon=xkaon0+reab(**) 
3159 
3160 c sp11/21/01  phi production: rho + N(D) -> phi + N(D)
3161          Xphi = 0.
3162        if( ( (((lb1.ge.1.and.lb1.le.2).or.
3163      &         (lb1.ge.6.and.lb1.le.9))
3164      &         .and.(lb2.ge.25.and.lb2.le.27))
3165      &   .OR.(((lb2.ge.1.and.lb2.le.2).or.
3166      &         (lb2.ge.6.and.lb2.le.9))
3167      &        .and.(lb1.ge.25.and.lb1.le.27)) ).AND. srt.gt.1.958)
3168      &    call pibphi(srt,lb1,lb2,em1,em2,Xphi,xphin)
3169 c !! in fm^2 above
3170 c
3171         if((iabs(lb1).ge.6.and.lb2.ge.25).or.
3172      &    (lb1.ge.25.and.iabs(lb2).ge.6))then
3173            ichann=1
3174            ictrl=2
3175            if(lb1.eq.28.or.lb2.eq.28)ictrl=3
3176             xreab=reab(i1,i2,srt,ictrl)
3177 
3178 clin-12/02/00 to satisfy detailed balance, forbid N* absorptions:
3179             if((iabs(lb1).ge.10.and.iabs(lb1).le.13)
3180      1           .or.(iabs(lb2).ge.10.and.iabs(lb2).le.13)) XREAB = 0.
3181 
3182         if(xreab.lt.0)xreab=1.E-06
3183             xkaon=xkaon0+xreab
3184           XELSTC=1.0
3185            endif
3186             DS=SQRT((XKAON+Xphi+xelstc)/PI)
3187 c
3188 csp09/20/01
3189 c           totcr = xelstc+xkaon
3190 c           if(srt .gt. 3.5)totcr = max1(totcr,3.)
3191 c           DS=SQRT(totcr/PI)
3192 csp09/20/01 end
3193 c
3194         DELTAR=DS+0.1
3195        px1cm=pcx
3196        py1cm=pcy
3197        pz1cm=pcz
3198 * CHECK IF the collision can happen
3199          CALL DISTCE(I1,I2,DELTAR,DS,DT,EC,SRT,IC,
3200      1   PCX,PCY,PCZ)
3201          IF(IC.EQ.-1) GO TO 400
3202         ekaon(4,iss)=ekaon(4,iss)+1
3203 c*
3204 * NOW rho(omega)+N or D(N*) COLLISION IS POSSIBLE
3205 * (1) check elastic collision
3206        if(xelstc/(xelstc+xkaon+Xphi).gt.RANART(NSEED))then
3207 c       call crdir(px1CM,py1CM,pz1CM,srt,I1,i2)
3208        call crdir(px1CM,py1CM,pz1CM,srt,I1,i2,IBLOCK)
3209        go to 440
3210        endif
3211 * (2) check pion absorption or kaon production
3212         CALL CRRD(PX1CM,PY1CM,PZ1CM,SRT,I1,I2,
3213      1  IBLOCK,xkaon0,xkaon,Xphi,xphin)
3214 
3215 * kaon production
3216 csp05/16/01
3217        IF(IBLOCK.EQ.7) then
3218           LPN=LPN+1
3219        elseIF(IBLOCK.EQ.-7) then
3220        endif
3221 csp05/16/01 end
3222 * rho obsorption
3223        if(iblock.eq.81) lrhor=lrhor+1
3224 * omega obsorption
3225        if(iblock.eq.82) lomgar=lomgar+1
3226        em1=e(i1)
3227        em2=e(i2)
3228        GO TO 440
3229 * for pion+n now using the subroutine crpn to change 
3230 * the particle label and set the new momentum of L/S+K final state
3231 95       continue
3232 * NOW PION+N INELASTIC COLLISION IS POSSIBLE
3233 * check pion production or kaon production
3234         CALL CRPN(PX1CM,PY1CM,PZ1CM,SRT,I1,I2,
3235      1  IBLOCK,xkaon0,xkaon,Xphi,xphin)
3236 
3237 * kaon production
3238 csp05/16/01
3239        IF(IBLOCK.EQ.7) then
3240           LPN=LPN+1
3241        elseIF(IBLOCK.EQ.-7) then
3242        endif
3243 csp05/16/01 end
3244 * pion production
3245        if(iblock.eq.77) lpd=lpd+1
3246 * rho production
3247        if(iblock.eq.78) lrho=lrho+1
3248 * omega production
3249        if(iblock.eq.79) lomega=lomega+1
3250        em1=e(i1)
3251        em2=e(i2)
3252        GO TO 440
3253 * for pion+D(N*) now using the subroutine crpd to 
3254 * (1) check kaon production or pion reabsorption 
3255 * (2) change the particle label and set the new 
3256 *     momentum of L/S+K final state
3257 96       continue
3258         CALL CRPD(PX1CM,PY1CM,PZ1CM,SRT,I1,I2,
3259      1  IBLOCK,xkaon0,xkaon,Xphi,xphin)
3260 
3261 * kaon production
3262 csp05/16/01
3263        IF(IBLOCK.EQ.7) then
3264           LPN=LPN+1
3265        elseIF(IBLOCK.EQ.-7) then
3266        endif
3267 csp05/16/01 end
3268 * pion obserption
3269        if(iblock.eq.80) lpdr=lpdr+1
3270        em1=e(i1)
3271        em2=e(i2)
3272        GO TO 440
3273 * CALCULATE KAON PRODUCTION PROBABILITY FROM PION + N COLLISIONS
3274 C        IF(SRT.GT.1.615)THEN
3275 C        CALL PKAON(SRT,XXp,PK)
3276 C        TKAON(7)=TKAON(7)+PK 
3277 C        EKAON(7,ISS)=EKAON(7,ISS)+1
3278 c        CALL KSPEC1(SRT,PK)
3279 C        call LK(3,srt,iseed,pk)
3280 C        ENDIF
3281 * negelecting the pauli blocking at high energies
3282 
3283 101       continue
3284         IF(E(I2).EQ.0.)GO TO 600
3285         IF(E(I1).EQ.0.)GO TO 800
3286 * IF NUCLEON+BARYON RESONANCE COLLISIONS
3287 44      CONTINUE
3288 * CALCULATE THE TOTAL CROSS SECTION OF NUCLEON+ BARYON RESONANCE COLLISION
3289 * WE ASSUME THAT THE ELASTIC CROSS SECTION IS THE SAME AS NUCLEON+NUCLEON
3290 * COM: WE USE THE PARAMETERISATION BY CUGNON FOR LOW ENERGIES
3291 *      AND THE PARAMETERIZATIONS FROM CERN DATA BOOK FOR HIGHER 
3292 *      ENERGIES. THE CUTOFF FOR THE TOTAL CROSS SECTION IS 55 MB 
3293        cutoff=em1+em2+0.02
3294        IF(SRT.LE.CUTOFF)GO TO 400
3295         IF(SRT.GT.2.245)THEN
3296        SIGNN=PP2(SRT)
3297        ELSE
3298         SIGNN = 35.0 / (1. + (SRT - CUTOFF) * 100.0)  +  20.0
3299        ENDIF 
3300         call XND(pcx,pcy,pcz,srt,I1,I2,xinel,
3301      &               sigk,xsk1,xsk2,xsk3,xsk4,xsk5)
3302        sig=signn+xinel
3303 * For nucleon+baryon resonance collision, the minimum cms**2 energy is
3304         EC=(EM1+EM2+0.02)**2
3305 * CHECK THE DISTENCE BETWEEN THE TWO PARTICLES
3306         PX1CM=PCX
3307         PY1CM=PCY
3308         PZ1CM=PCZ
3309 
3310 clin-6/2008 Deuteron production:
3311         ianti=0
3312         if(lb(i1).lt.0 .and. lb(i2).lt.0) ianti=1
3313         call sbbdm(srt,sdprod,ianti,lbm,xmm,pfinal)
3314         sig=sig+sdprod
3315 clin-6/2008 perturbative treatment of deuterons:
3316         ipdflag=0
3317         if(idpert.eq.1) then
3318            ipert1=1
3319            sigr0=sig
3320            dspert=sqrt(sigr0/pi/10.)
3321            dsrpert=dspert+0.1
3322            CALL DISTCE(I1,I2,dsrpert,dspert,DT,EC,SRT,IC,
3323      1          PX1CM,PY1CM,PZ1CM)
3324            IF(IC.EQ.-1) GO TO 363
3325            signn0=0.
3326            CALL CRND(IRUN,PX1CM,PY1CM,PZ1CM,SRT,I1,I2,
3327      &  IBLOCK,SIGNN0,SIGr0,sigk,xsk1,xsk2,xsk3,xsk4,xsk5,NT,ipert1)
3328 c     &  IBLOCK,SIGNN,SIG,sigk,xsk1,xsk2,xsk3,xsk4,xsk5)
3329            ipdflag=1
3330  363       continue
3331            ipert1=0
3332         endif
3333         if(idpert.eq.2) ipert1=1
3334 c
3335         DS=SQRT(SIG/(10.*PI))
3336         DELTAR=DS+0.1
3337         CALL DISTCE(I1,I2,DELTAR,DS,DT,EC,SRT,IC,
3338      1  PX1CM,PY1CM,PZ1CM)
3339 c        IF(IC.EQ.-1)GO TO 400
3340         IF(IC.EQ.-1) then
3341            if(ipdflag.eq.1) iblock=501
3342            GO TO 400
3343         endif
3344 
3345         ekaon(3,iss)=ekaon(3,iss)+1
3346 * CALCULATE KAON PRODUCTION PROBABILITY FROM NUCLEON + BARYON RESONANCE 
3347 * COLLISIONS
3348         go to 361
3349 
3350 * CHECK WHAT KIND OF COLLISION HAS HAPPENED
3351  361    continue 
3352         CALL CRND(IRUN,PX1CM,PY1CM,PZ1CM,SRT,I1,I2,
3353      &     IBLOCK,SIGNN,SIG,sigk,xsk1,xsk2,xsk3,xsk4,xsk5,NT,ipert1)
3354 c     &  IBLOCK,SIGNN,SIG,sigk,xsk1,xsk2,xsk3,xsk4,xsk5)
3355         IF(iblock.eq.0.and.ipdflag.eq.1) iblock=501
3356         IF(IBLOCK.EQ.11)THEN
3357            LNDK=LNDK+1
3358            GO TO 400
3359 c        elseIF(IBLOCK.EQ.-11) then
3360         elseIF(IBLOCK.EQ.-11.or.iblock.eq.501) then
3361            GO TO 400
3362         ENDIF
3363         if(iblock .eq. 222)then
3364 c    !! sp12/17/01 
3365            GO TO 400
3366         ENDIF
3367         em1=e(i1)
3368         em2=e(i2)
3369         GO TO 440
3370 * IF NUCLEON+NUCLEON OR BARYON RESONANCE+BARYON RESONANCE COLLISIONS
3371 4       CONTINUE
3372 * PREPARE THE EALSTIC CROSS SECTION FOR BARYON+BARYON COLLISIONS
3373 * COM: WE USE THE PARAMETERISATION BY CUGNON FOR SRT LEQ 2.0 GEV
3374 *      AND THE PARAMETERIZATIONS FROM CERN DATA BOOK FOR HIGHER 
3375 *      ENERGIES. THE CUTOFF FOR THE TOTAL CROSS SECTION IS 55 MB 
3376 *      WITH LOW-ENERGY-CUTOFF
3377         CUTOFF=em1+em2+0.14
3378 * AT HIGH ENERGIES THE ISOSPIN DEPENDENCE IS NEGLIGIBLE
3379 * THE TOTAL CROSS SECTION IS TAKEN AS THAT OF THE PP 
3380 * ABOVE E_KIN=800 MEV, WE USE THE ISOSPIN INDEPENDNET XSECTION
3381         IF(SRT.GT.2.245)THEN
3382            SIG=ppt(srt)
3383            SIGNN=SIG-PP1(SRT)
3384         ELSE
3385 * AT LOW ENERGIES THE ISOSPIN DEPENDENCE FOR NN COLLISION IS STRONG
3386            SIG=XPP(SRT)
3387            IF(ZET(LB(I1))*ZET(LB(I2)).LE.0)SIG=XNP(SRT)
3388            IF(ZET(LB(I1))*ZET(LB(I2)).GT.0)SIG=XPP(SRT)
3389            IF(ZET(LB(I1)).EQ.0.
3390      &          AND.ZET(LB(I2)).EQ.0)SIG=XPP(SRT)
3391            if((lb(i1).eq.-1.and.lb(i2).eq.-2) .or.
3392      &          (lb(i2).eq.-1.and.lb(i1).eq.-2))sig=xnp(srt)
3393 *     WITH LOW-ENERGY-CUTOFF
3394            IF (SRT .LT. 1.897) THEN
3395               SIGNN = SIG
3396            ELSE 
3397               SIGNN = 35.0 / (1. + (SRT - 1.897) * 100.0)  +  20.0
3398            ENDIF
3399         ENDIF 
3400         PX1CM=PCX
3401         PY1CM=PCY
3402         PZ1CM=PCZ
3403 clin-5/2008 Deuteron production cross sections were not included 
3404 c     in the previous parameterized inelastic cross section of NN collisions  
3405 c     (SIGinel=SIG-SIGNN), so they are added here:
3406         ianti=0
3407         if(lb(i1).lt.0 .and. lb(i2).lt.0) ianti=1
3408         call sbbdm(srt,sdprod,ianti,lbm,xmm,pfinal)
3409         sig=sig+sdprod
3410 c
3411 clin-5/2008 perturbative treatment of deuterons:
3412         ipdflag=0
3413         if(idpert.eq.1) then
3414 c     For idpert=1: ipert1=1 means we will first treat deuteron perturbatively,
3415 c     then we set ipert1=0 to treat regular NN or NbarNbar collisions including
3416 c     the regular deuteron productions.
3417 c     ipdflag=1 means perturbative deuterons are produced here:
3418            ipert1=1
3419            EC=2.012**2
3420 c     Use the same cross section for NN/NNBAR collisions 
3421 c     to trigger perturbative production
3422            sigr0=sig
3423 c     One can also trigger with X*sbbdm() so the weight will not be too small;
3424 c     but make sure to limit the maximum trigger Xsec:
3425 c           sigr0=sdprod*25.
3426 c           if(sigr0.ge.100.) sigr0=100.
3427            dspert=sqrt(sigr0/pi/10.)
3428            dsrpert=dspert+0.1
3429            CALL DISTCE(I1,I2,dsrpert,dspert,DT,EC,SRT,IC,
3430      1          PX1CM,PY1CM,PZ1CM)
3431            IF(IC.EQ.-1) GO TO 365
3432            signn0=0.
3433            CALL CRNN(IRUN,PX1CM,PY1CM,PZ1CM,SRT,I1,I2,IBLOCK,
3434      1          NTAG,signn0,sigr0,NT,ipert1)
3435            ipdflag=1
3436  365       continue
3437            ipert1=0
3438         endif
3439         if(idpert.eq.2) ipert1=1
3440 c
3441 clin-5/2008 in case perturbative deuterons are produced for idpert=1:
3442 c        IF(SIGNN.LE.0)GO TO 400
3443         IF(SIGNN.LE.0) then
3444            if(ipdflag.eq.1) iblock=501
3445            GO TO 400
3446         endif
3447 c
3448         EC=3.59709
3449         ds=sqrt(sig/pi/10.)
3450         dsr=ds+0.1
3451         IF((E(I1).GE.1.).AND.(e(I2).GE.1.))EC=4.75
3452         CALL DISTCE(I1,I2,dsr,ds,DT,EC,SRT,IC,
3453      1       PX1CM,PY1CM,PZ1CM)
3454 clin-5/2008 in case perturbative deuterons are produced above:
3455 c        IF(IC.EQ.-1) GO TO 400
3456         IF(IC.EQ.-1) then
3457            if(ipdflag.eq.1) iblock=501
3458            GO TO 400
3459         endif
3460 c
3461 * CALCULATE KAON PRODUCTION PROBABILITY FROM NUCLEON+NUCLEON OR 
3462 * RESONANCE+RESONANCE COLLISIONS
3463         go to 362
3464 
3465 C CHECK WHAT KIND OF COLLISION HAS HAPPENED 
3466  362    ekaon(1,iss)=ekaon(1,iss)+1
3467         CALL CRNN(IRUN,PX1CM,PY1CM,PZ1CM,SRT,I1,I2,IBLOCK,
3468      1       NTAG,SIGNN,SIG,NT,ipert1)
3469 clin-5/2008 give iblock # in case pert deuterons are produced for idpert=1:
3470         IF(iblock.eq.0.and.ipdflag.eq.1) iblock=501
3471 clin-5/2008 add iblock # for deuteron formation:
3472 c        IF(IBLOCK.EQ.4.OR.IBLOCK.Eq.9.or.iblock.ge.44.OR.IBLOCK.EQ.-9
3473 c     &       .or.iblock.eq.222)THEN
3474         IF(IBLOCK.EQ.4.OR.IBLOCK.Eq.9.or.iblock.ge.44.OR.IBLOCK.EQ.-9
3475      &       .or.iblock.eq.222.or.iblock.eq.501)THEN
3476 c
3477 c     !! sp12/17/01 above
3478 * momentum of the three particles in the final state have been calculated
3479 * in the crnn, go out of the loop
3480            LCOLL=LCOLL+1
3481            if(iblock.eq.4)then
3482               LDIRT=LDIRT+1
3483            elseif(iblock.eq.44)then
3484               LDdrho=LDdrho+1
3485            elseif(iblock.eq.45)then
3486               Lnnrho=Lnnrho+1
3487            elseif(iblock.eq.46)then
3488               Lnnom=Lnnom+1
3489            elseif(iblock .eq. 222)then
3490            elseIF(IBLOCK.EQ.9) then
3491               LNNK=LNNK+1
3492            elseIF(IBLOCK.EQ.-9) then
3493            endif
3494            GO TO 400
3495         ENDIF
3496 
3497         em1=e(i1)
3498         em2=e(i2)
3499         GO TO 440
3500 clin-8/2008 B+B->Deuteron+Meson over
3501 c
3502 clin-8/2008 Deuteron+Meson->B+B collisions:
3503  505    continue
3504         ianti=0
3505         if(lb(i1).lt.0 .or. lb(i2).lt.0) ianti=1
3506         call sdmbb(SRT,sdm,ianti)
3507         PX1CM=PCX
3508         PY1CM=PCY
3509         PZ1CM=PCZ
3510 c     minimum srt**2, note a 2.012GeV lower cutoff is used in N+N->Deuteron+pi:
3511         EC=2.012**2
3512         ds=sqrt(sdm/31.4)
3513         dsr=ds+0.1
3514         CALL DISTCE(I1,I2,dsr,ds,DT,EC,SRT,IC,PX1CM,PY1CM,PZ1CM)
3515         IF(IC.EQ.-1) GO TO 400
3516         CALL crdmbb(PX1CM,PY1CM,PZ1CM,SRT,I1,I2,IBLOCK,
3517      1       NTAG,sdm,NT,ianti)
3518         LCOLL=LCOLL+1
3519         GO TO 400
3520 clin-8/2008 Deuteron+Meson->B+B collisions over
3521 c
3522 clin-9/2008 Deuteron+Baryon elastic collisions:
3523  506    continue
3524         ianti=0
3525         if(lb(i1).lt.0 .or. lb(i2).lt.0) ianti=1
3526         call sdbelastic(SRT,sdb)
3527         PX1CM=PCX
3528         PY1CM=PCY
3529         PZ1CM=PCZ
3530 c     minimum srt**2, note a 2.012GeV lower cutoff is used in N+N->Deuteron+pi:
3531         EC=2.012**2
3532         ds=sqrt(sdb/31.4)
3533         dsr=ds+0.1
3534         CALL DISTCE(I1,I2,dsr,ds,DT,EC,SRT,IC,PX1CM,PY1CM,PZ1CM)
3535         IF(IC.EQ.-1) GO TO 400
3536         CALL crdbel(PX1CM,PY1CM,PZ1CM,SRT,I1,I2,IBLOCK,
3537      1       NTAG,sdb,NT,ianti)
3538         LCOLL=LCOLL+1
3539         GO TO 400
3540 clin-9/2008 Deuteron+Baryon elastic collisions over
3541 c
3542 * IF BARYON RESONANCE+BARYON RESONANCE COLLISIONS
3543  444    CONTINUE
3544 * PREPARE THE EALSTIC CROSS SECTION FOR BARYON+BARYON COLLISIONS
3545        CUTOFF=em1+em2+0.02
3546 * AT HIGH ENERGIES THE ISOSPIN DEPENDENCE IS NEGLIGIBLE
3547 * THE TOTAL CROSS SECTION IS TAKEN AS THAT OF THE PP 
3548        IF(SRT.LE.CUTOFF)GO TO 400
3549         IF(SRT.GT.2.245)THEN
3550        SIGNN=PP2(SRT)
3551        ELSE
3552         SIGNN = 35.0 / (1. + (SRT - CUTOFF) * 100.0)  +  20.0
3553        ENDIF 
3554        IF(SIGNN.LE.0)GO TO 400
3555       CALL XDDIN(PCX,PCY,PCZ,SRT,I1,I2,
3556      &XINEL,SIGK,XSK1,XSK2,XSK3,XSK4,XSK5)
3557        SIG=SIGNN+XINEL
3558        EC=(EM1+EM2+0.02)**2
3559         PX1CM=PCX
3560         PY1CM=PCY
3561         PZ1CM=PCZ
3562 
3563 clin-6/2008 Deuteron production:
3564         ianti=0
3565         if(lb(i1).lt.0 .and. lb(i2).lt.0) ianti=1
3566         call sbbdm(srt,sdprod,ianti,lbm,xmm,pfinal)
3567         sig=sig+sdprod
3568 clin-6/2008 perturbative treatment of deuterons:
3569         ipdflag=0
3570         if(idpert.eq.1) then
3571            ipert1=1
3572            sigr0=sig
3573            dspert=sqrt(sigr0/pi/10.)
3574            dsrpert=dspert+0.1
3575            CALL DISTCE(I1,I2,dsrpert,dspert,DT,EC,SRT,IC,
3576      1          PX1CM,PY1CM,PZ1CM)
3577            IF(IC.EQ.-1) GO TO 367
3578            signn0=0.
3579            CALL CRDD(IRUN,PX1CM,PY1CM,PZ1CM,SRT,I1,I2,
3580      1          IBLOCK,NTAG,SIGNN0,SIGr0,NT,ipert1)
3581 c     1          IBLOCK,NTAG,SIGNN,SIG)
3582            ipdflag=1
3583  367       continue
3584            ipert1=0
3585         endif
3586         if(idpert.eq.2) ipert1=1
3587 c
3588         ds=sqrt(sig/31.4)
3589         dsr=ds+0.1
3590         CALL DISTCE(I1,I2,dsr,ds,DT,EC,SRT,IC,
3591      1  PX1CM,PY1CM,PZ1CM)
3592 c        IF(IC.EQ.-1) GO TO 400
3593         IF(IC.EQ.-1) then
3594            if(ipdflag.eq.1) iblock=501
3595            GO TO 400
3596         endif
3597 
3598 * CALCULATE KAON PRODUCTION PROBABILITY FROM NUCLEON+NUCLEON OR 
3599 * RESONANCE+RESONANCE COLLISIONS
3600        go to 364
3601 
3602 C CHECK WHAT KIND OF COLLISION HAS HAPPENED 
3603 364       ekaon(2,iss)=ekaon(2,iss)+1
3604 * for resonance+resonance
3605 clin-6/2008:
3606         CALL CRDD(IRUN,PX1CM,PY1CM,PZ1CM,SRT,I1,I2,
3607      1  IBLOCK,NTAG,SIGNN,SIG,NT,ipert1)
3608 c     1  IBLOCK,NTAG,SIGNN,SIG)
3609         IF(iblock.eq.0.and.ipdflag.eq.1) iblock=501
3610 c
3611         IF(iabs(IBLOCK).EQ.10)THEN
3612 * momentum of the three particles in the final state have been calculated
3613 * in the crnn, go out of the loop
3614            LCOLL=LCOLL+1
3615            IF(IBLOCK.EQ.10)THEN
3616               LDDK=LDDK+1
3617            elseIF(IBLOCK.EQ.-10) then
3618            endif
3619            GO TO 400
3620         ENDIF
3621 clin-6/2008
3622 c        if(iblock .eq. 222)then
3623         if(iblock .eq. 222.or.iblock.eq.501)then
3624 c    !! sp12/17/01 
3625            GO TO 400
3626         ENDIF
3627         em1=e(i1)
3628         em2=e(i2)
3629         GO TO 440
3630 * FOR PION+PION,pion+eta, eta+eta and rho(omega)+pion(rho,omega) or eta 
3631 777       CONTINUE
3632         PX1CM=PCX
3633         PY1CM=PCY
3634         PZ1CM=PCZ
3635 * energy thresh for collisions
3636        ec0=em1+em2+0.02
3637        IF(SRT.LE.ec0)GO TO 400
3638        ec=(em1+em2+0.02)**2
3639 * we negelect the elastic collision between mesons except that betwen
3640 * two pions because of the lack of information about these collisions
3641 * However, we do let them to collide inelastically to produce kaons
3642 clin-8/15/02       ppel=1.e-09
3643        ppel=20.
3644         ipp=1
3645        if(lb1.lt.3.or.lb1.gt.5.or.lb2.lt.3.or.lb2.gt.5)go to 778       
3646        CALL PPXS(LB1,LB2,SRT,PPSIG,spprho,IPP)
3647        ppel=ppsig
3648 778       ppink=pipik(srt)
3649 
3650 * pi+eta and eta+eta are assumed to be the same as pipik( for pi+pi -> K+K-) 
3651 * estimated from Ko's paper:
3652         ppink = 2.0 * ppink
3653        if(lb1.ge.25.and.lb2.ge.25) ppink=rrkk
3654 
3655 clin-2/13/03 include omega the same as rho, eta the same as pi:
3656 c        if(((lb1.ge.3.and.lb1.le.5).and.(lb2.ge.25.and.lb2.le.27))
3657 c     1  .or.((lb2.ge.3.and.lb2.le.5).and.(lb1.ge.25.and.lb1.le.27)))
3658         if( ( (lb1.eq.0.or.(lb1.ge.3.and.lb1.le.5))
3659      1       .and.(lb2.ge.25.and.lb2.le.28))
3660      2       .or. ( (lb2.eq.0.or.(lb2.ge.3.and.lb2.le.5))
3661      3       .and.(lb1.ge.25.and.lb1.le.28))) then
3662            ppink=0.
3663            if(srt.ge.(aka+aks)) ppink = prkk
3664         endif
3665 
3666 c pi pi <-> rho rho:
3667         call spprr(lb1,lb2,srt)
3668 clin-4/03/02 pi pi <-> eta eta:
3669         call sppee(lb1,lb2,srt)
3670 clin-4/03/02 pi pi <-> pi eta:
3671         call spppe(lb1,lb2,srt)
3672 clin-4/03/02 rho pi <-> rho eta:
3673         call srpre(lb1,lb2,srt)
3674 clin-4/03/02 omega pi <-> omega eta:
3675         call sopoe(lb1,lb2,srt)
3676 clin-4/03/02 rho rho <-> eta eta:
3677         call srree(lb1,lb2,srt)
3678 
3679         ppinnb=0.
3680         if(srt.gt.thresh(1)) then
3681            call getnst(srt)
3682            if(lb1.ge.3.and.lb1.le.5.and.lb2.ge.3.and.lb2.le.5) then
3683               ppinnb=ppbbar(srt)
3684            elseif((lb1.ge.3.and.lb1.le.5.and.lb2.ge.25.and.lb2.le.27)
3685      1 .or.(lb2.ge.3.and.lb2.le.5.and.lb1.ge.25.and.lb1.le.27)) then
3686               ppinnb=prbbar(srt)
3687            elseif(lb1.ge.25.and.lb1.le.27
3688      1             .and.lb2.ge.25.and.lb2.le.27) then
3689               ppinnb=rrbbar(srt)
3690            elseif((lb1.ge.3.and.lb1.le.5.and.lb2.eq.28)
3691      1             .or.(lb2.ge.3.and.lb2.le.5.and.lb1.eq.28)) then
3692               ppinnb=pobbar(srt)
3693            elseif((lb1.ge.25.and.lb1.le.27.and.lb2.eq.28)
3694      1             .or.(lb2.ge.25.and.lb2.le.27.and.lb1.eq.28)) then
3695               ppinnb=robbar(srt)
3696            elseif(lb1.eq.28.and.lb2.eq.28) then
3697               ppinnb=oobbar(srt)
3698            else
3699               if(lb1.ne.0.and.lb2.ne.0) 
3700      1             write(6,*) 'missed MM lb1,lb2=',lb1,lb2
3701            endif
3702         endif
3703         ppin=ppink+ppinnb+pprr+ppee+pppe+rpre+xopoe+rree
3704 
3705 * check if a collision can happen
3706        if((ppel+ppin).le.0.01)go to 400
3707        DSPP=SQRT((ppel+ppin)/31.4)
3708        dsppr=dspp+0.1
3709         CALL DISTCE(I1,I2,dsppr,DSPP,DT,EC,SRT,IC,
3710      1  PX1CM,PY1CM,PZ1CM)
3711         IF(IC.EQ.-1) GO TO 400
3712        if(ppel.eq.0)go to 400
3713 * the collision can happen
3714 * check what kind collision has happened
3715        ekaon(5,iss)=ekaon(5,iss)+1
3716         CALL CRPP(PX1CM,PY1CM,PZ1CM,SRT,I1,I2,
3717      1  IBLOCK,ppel,ppin,spprho,ipp)
3718 
3719 * rho formation, go to 400
3720 c       if(iblock.eq.666)go to 600
3721        if(iblock.eq.666)go to 555
3722        if(iblock.eq.6)LPP=LPP+1
3723        if(iblock.eq.66)then
3724           LPPk=LPPk+1
3725        elseif(iblock.eq.366)then
3726           LPPk=LPPk+1
3727        elseif(iblock.eq.367)then
3728           LPPk=LPPk+1
3729        endif
3730        em1=e(i1)
3731        em2=e(i2)
3732        go to 440
3733 
3734 * In this block we treat annihilations of
3735 clin-9/28/00* an anti-nucleon and a baryon or baryon resonance  
3736 * an anti-baryon and a baryon (including resonances)
3737 2799        CONTINUE
3738         PX1CM=PCX
3739         PY1CM=PCY
3740         PZ1CM=PCZ
3741         EC=(em1+em2+0.02)**2
3742 clin assume the same cross section (as a function of sqrt s) as for PPbar:
3743 
3744 clin-ctest annih maximum
3745 c        DSppb=SQRT(amin1(xppbar(srt),30.)/PI/10.)
3746        DSppb=SQRT(xppbar(srt)/PI/10.)
3747        dsppbr=dsppb+0.1
3748         CALL DISTCE(I1,I2,dsppbr,DSppb,DT,EC,SRT,IC,
3749      1  PX1CM,PY1CM,PZ1CM)
3750         IF(IC.EQ.-1) GO TO 400
3751         CALL Crppba(PX1CM,PY1CM,PZ1CM,SRT,I1,I2,
3752      1  IBLOCK)
3753        em1=e(i1)
3754        em2=e(i2)
3755        go to 440
3756 c
3757 3555    PX1CM=PCX
3758         PY1CM=PCY
3759         PZ1CM=PCZ
3760         EC=(em1+em2+0.02)**2
3761        DSkk=SQRT(SIG/PI/10.)
3762        dskk0=dskk+0.1
3763         CALL DISTCE(I1,I2,dskk0,DSkk,DT,EC,SRT,IC,
3764      1  PX1CM,PY1CM,PZ1CM)
3765         IF(IC.EQ.-1) GO TO 400
3766         CALL Crlaba(PX1CM,PY1CM,PZ1CM,SRT,brel,brsgm,
3767      &                  I1,I2,nt,IBLOCK,nchrg,icase)
3768        em1=e(i1)
3769        em2=e(i2)
3770        go to 440
3771 *
3772 c perturbative production of cascade and omega
3773 3455    PX1CM=PCX
3774         PY1CM=PCY
3775         PZ1CM=PCZ
3776         call pertur(PX1CM,PY1CM,PZ1CM,SRT,IRUN,I1,I2,nt,kp,icontp)
3777         if(icontp .eq. 0)then
3778 c     inelastic collisions:
3779          em1 = e(i1)
3780          em2 = e(i2)
3781          iblock = 727
3782           go to 440
3783         endif
3784 c     elastic collisions:
3785         if (e(i1) .eq. 0.) go to 800
3786         if (e(i2) .eq. 0.) go to 600
3787         go to 400
3788 *
3789 c* phi + N --> pi+N(D),  N(D,N*)+N(D,N*),  K+ +La
3790 c* phi + D --> pi+N(D)
3791 7222        CONTINUE
3792         PX1CM=PCX
3793         PY1CM=PCY
3794         PZ1CM=PCZ
3795         EC=(em1+em2+0.02)**2
3796         CALL XphiB(LB1, LB2, EM1, EM2, SRT,
3797      &             XSK1, XSK2, XSK3, XSK4, XSK5, SIGP)
3798        DSkk=SQRT(SIGP/PI/10.)
3799        dskk0=dskk+0.1
3800         CALL DISTCE(I1,I2,dskk0,DSkk,DT,EC,SRT,IC,
3801      1  PX1CM,PY1CM,PZ1CM)
3802         IF(IC.EQ.-1) GO TO 400
3803         CALL CRPHIB(PX1CM,PY1CM,PZ1CM,SRT,I1,I2,
3804      &     XSK1, XSK2, XSK3, XSK4, XSK5, SIGP, IBLOCK)
3805        em1=e(i1)
3806        em2=e(i2)
3807        go to 440
3808 *
3809 c* phi + M --> K+ + K* .....
3810 7444        CONTINUE
3811         PX1CM=PCX
3812         PY1CM=PCY
3813         PZ1CM=PCZ
3814         EC=(em1+em2+0.02)**2
3815         CALL PHIMES(I1, I2, SRT, XSK1, XSK2, XSK3, XSK4, XSK5,
3816      1     XSK6, XSK7, SIGPHI)
3817        DSkk=SQRT(SIGPHI/PI/10.)
3818        dskk0=dskk+0.1
3819         CALL DISTCE(I1,I2,dskk0,DSkk,DT,EC,SRT,IC,
3820      1  PX1CM,PY1CM,PZ1CM)
3821         IF(IC.EQ.-1) GO TO 400
3822 c*---
3823         PZRT = p(3,i1)+p(3,i2)
3824         ER1 = sqrt( p(1,i1)**2+p(2,i1)**2+p(3,i1)**2+E(i1)**2 )
3825         ER2 = sqrt( p(1,i2)**2+p(2,i2)**2+p(3,i2)**2+E(i2)**2 )
3826         ERT = ER1+ER2
3827         yy = 0.5*log( (ERT+PZRT)/(ERT-PZRT) )
3828 c*------
3829         CALL CRPHIM(PX1CM,PY1CM,PZ1CM,SRT,I1,I2,
3830      &  XSK1, XSK2, XSK3, XSK4, XSK5, XSK6, SIGPHI, IKKG, IKKL, IBLOCK)
3831        em1=e(i1)
3832        em2=e(i2)
3833        go to 440
3834 c
3835 c lambda-N elastic xsection, Li & Ko, PRC 54(1996)1897.
3836  7799    CONTINUE
3837          PX1CM=PCX
3838          PY1CM=PCY
3839          PZ1CM=PCZ
3840          EC=(em1+em2+0.02)**2
3841          call lambar(i1,i2,srt,siglab)
3842         DShn=SQRT(siglab/PI/10.)
3843         dshnr=dshn+0.1
3844          CALL DISTCE(I1,I2,dshnr,DShn,DT,EC,SRT,IC,
3845      1    PX1CM,PY1CM,PZ1CM)
3846         IF(IC.EQ.-1) GO TO 400
3847          CALL Crhb(PX1CM,PY1CM,PZ1CM,SRT,I1,I2,IBLOCK)
3848         em1=e(i1)
3849         em2=e(i2)
3850         go to 440
3851 c
3852 c* K+ + La(Si) --> Meson + B
3853 c* K- + La(Si)-bar --> Meson + B-bar
3854 5699        CONTINUE
3855         PX1CM=PCX
3856         PY1CM=PCY
3857         PZ1CM=PCZ
3858         EC=(em1+em2+0.02)**2
3859         CALL XKHYPE(I1, I2, SRT, XKY1, XKY2, XKY3, XKY4, XKY5,
3860      &     XKY6, XKY7, XKY8, XKY9, XKY10, XKY11, XKY12, XKY13,
3861      &     XKY14, XKY15, XKY16, XKY17, SIGK)
3862        DSkk=SQRT(sigk/PI)
3863        dskk0=dskk+0.1
3864         CALL DISTCE(I1,I2,dskk0,DSkk,DT,EC,SRT,IC,
3865      1  PX1CM,PY1CM,PZ1CM)
3866         IF(IC.EQ.-1) GO TO 400
3867 c
3868        if(lb(i1).eq.23 .or. lb(i2).eq.23)then
3869              IKMP = 1
3870         else
3871              IKMP = -1
3872         endif
3873         CALL Crkhyp(PX1CM,PY1CM,PZ1CM,SRT,I1,I2,
3874      &     XKY1, XKY2, XKY3, XKY4, XKY5,
3875      &     XKY6, XKY7, XKY8, XKY9, XKY10, XKY11, XKY12, XKY13,
3876      &     XKY14, XKY15, XKY16, XKY17, SIGK, IKMP,
3877      1  IBLOCK)
3878        em1=e(i1)
3879        em2=e(i2)
3880        go to 440
3881 c khyperon end
3882 *
3883 csp11/03/01 La/Si-bar + N --> pi + K+
3884 c  La/Si + N-bar --> pi + K-
3885 5999     CONTINUE
3886         PX1CM=PCX
3887         PY1CM=PCY
3888         PZ1CM=PCZ
3889         EC=(em1+em2+0.02)**2
3890         sigkp = 15.
3891 c      if((lb1.ge.14.and.lb1.le.17)
3892 c     &    .or.(lb2.ge.14.and.lb2.le.17))sigkp=10.
3893         DSkk=SQRT(SIGKP/PI/10.)
3894         dskk0=dskk+0.1
3895         CALL DISTCE(I1,I2,dskk0,DSkk,DT,EC,SRT,IC,
3896      1  PX1CM,PY1CM,PZ1CM)
3897         IF(IC.EQ.-1) GO TO 400
3898 c
3899         CALL CRLAN(PX1CM,PY1CM,PZ1CM,SRT,I1,I2,IBLOCK)
3900         em1=e(i1)
3901         em2=e(i2)
3902         go to 440
3903 c
3904 c*
3905 * K(K*) + K(K*) --> phi + pi(rho,omega)
3906 8699     CONTINUE
3907         PX1CM=PCX
3908         PY1CM=PCY
3909         PZ1CM=PCZ
3910         EC=(em1+em2+0.02)**2
3911 *  CALL CROSSKKPHI(PX1CM,PY1CM,PZ1CM,SRT,I1,I2,IBLOCK)  used for KK*->phi+rho
3912 
3913          CALL Crkphi(PX1CM,PY1CM,PZ1CM,EC,SRT,IBLOCK,
3914      &                  emm1,emm2,lbp1,lbp2,I1,I2,ikk,icase,rrkk,prkk)
3915          if(icase .eq. 0) then
3916             iblock=0
3917             go to 400
3918          endif
3919 
3920 c*---
3921          if(lbp1.eq.29.or.lbp2.eq.29) then
3922         PZRT = p(3,i1)+p(3,i2)
3923         ER1 = sqrt( p(1,i1)**2+p(2,i1)**2+p(3,i1)**2+E(i1)**2 )
3924         ER2 = sqrt( p(1,i2)**2+p(2,i2)**2+p(3,i2)**2+E(i2)**2 )
3925         ERT = ER1+ER2
3926         yy = 0.5*log( (ERT+PZRT)/(ERT-PZRT) )
3927 c*------
3928              iblock = 222
3929              ntag = 0
3930           endif
3931 
3932              LB(I1) = lbp1
3933              LB(I2) = lbp2
3934              E(I1) = emm1
3935              E(I2) = emm2
3936              em1=e(i1)
3937              em2=e(i2)
3938              go to 440
3939 c*
3940 * rho(omega) + K(K*)  --> phi + K(K*)
3941 8799     CONTINUE
3942         PX1CM=PCX
3943         PY1CM=PCY
3944         PZ1CM=PCZ
3945         EC=(em1+em2+0.02)**2
3946 *  CALL CROSSKKPHI(PX1CM,PY1CM,PZ1CM,SRT,I1,I2,IBLOCK)  used for KK*->phi+rho
3947          CALL Crksph(PX1CM,PY1CM,PZ1CM,EC,SRT,
3948      &       emm1,emm2,lbp1,lbp2,I1,I2,ikkg,ikkl,iblock,icase,srhoks)
3949          if(icase .eq. 0) then
3950             iblock=0
3951             go to 400
3952          endif
3953 c
3954          if(lbp1.eq.29.or.lbp2.eq.20) then
3955 c*---
3956         PZRT = p(3,i1)+p(3,i2)
3957         ER1 = sqrt( p(1,i1)**2+p(2,i1)**2+p(3,i1)**2+E(i1)**2 )
3958         ER2 = sqrt( p(1,i2)**2+p(2,i2)**2+p(3,i2)**2+E(i2)**2 )
3959         ERT = ER1+ER2
3960         yy = 0.5*log( (ERT+PZRT)/(ERT-PZRT) )
3961           endif
3962 
3963              LB(I1) = lbp1
3964              LB(I2) = lbp2
3965              E(I1) = emm1
3966              E(I2) = emm2
3967              em1=e(i1)
3968              em2=e(i2)
3969              go to 440
3970 
3971 * for kaon+baryon scattering, using a constant xsection of 10 mb.
3972 888       CONTINUE
3973         PX1CM=PCX
3974         PY1CM=PCY
3975         PZ1CM=PCZ
3976         EC=(em1+em2+0.02)**2
3977          sig = 10.
3978          if(iabs(lb1).eq.14.or.iabs(lb2).eq.14 .or.
3979      &      iabs(lb1).eq.30.or.iabs(lb2).eq.30)sig=20.
3980          if(lb1.eq.29.or.lb2.eq.29)sig=5.0
3981 
3982        DSkn=SQRT(sig/PI/10.)
3983        dsknr=dskn+0.1
3984         CALL DISTCE(I1,I2,dsknr,DSkn,DT,EC,SRT,IC,
3985      1  PX1CM,PY1CM,PZ1CM)
3986         IF(IC.EQ.-1) GO TO 400
3987         CALL Crkn(PX1CM,PY1CM,PZ1CM,SRT,I1,I2,
3988      1  IBLOCK)
3989        em1=e(i1)
3990        em2=e(i2)
3991        go to 440
3992 ***
3993 
3994  440    CONTINUE
3995 *                IBLOCK = 0 ; NOTHING HAS HAPPENED
3996 *                IBLOCK = 1 ; ELASTIC N-N COLLISION
3997 *                IBLOCK = 2 ; N + N -> N + DELTA
3998 *                IBLOCK = 3 ; N + DELTA -> N + N
3999 *                IBLOCK = 4 ; N + N -> d + d + PION,DIRECT PROCESS
4000 *               IBLOCK = 5 ; D(N*)+D(N*) COLLISIONS
4001 *                IBLOCK = 6 ; PION+PION COLLISIONS
4002 *                iblock = 7 ; pion+nucleon-->l/s+kaon
4003 *               iblock =77;  pion+nucleon-->delta+pion
4004 *               iblock = 8 ; kaon+baryon rescattering
4005 *                IBLOCK = 9 ; NN-->KAON+X
4006 *                IBLOCK = 10; DD-->KAON+X
4007 *               IBLOCK = 11; ND-->KAON+X
4008 cbali2/1/99
4009 *                
4010 *           iblock   - 1902 annihilation-->pion(+)+pion(-)   (2 pion)
4011 *           iblock   - 1903 annihilation-->pion(+)+rho(-)    (3 pion)
4012 *           iblock   - 1904 annihilation-->rho(+)+rho(-)     (4 pion)
4013 *           iblock   - 1905 annihilation-->rho(0)+omega      (5 pion)
4014 *           iblock   - 1906 annihilation-->omega+omega       (6 pion)
4015 cbali3/5/99
4016 *           iblock   - 1907 K+K- to pi+pi-
4017 cbali3/5/99 end
4018 cbz3/9/99 khyperon
4019 *           iblock   - 1908 K+Y -> piN
4020 cbz3/9/99 khyperon end
4021 cbali2/1/99end
4022 
4023 clin-9/28/00 Processes: m(pi rho omega)+m(pi rho omega)
4024 c     to anti-(p n D N*1 N*2)+(p n D N*1 N*2):
4025 *           iblock   - 1801  mm -->pbar p 
4026 *           iblock   - 18021 mm -->pbar n 
4027 *           iblock   - 18022 mm -->nbar p 
4028 *           iblock   - 1803  mm -->nbar n 
4029 *           iblock   - 18041 mm -->pbar Delta 
4030 *           iblock   - 18042 mm -->anti-Delta p
4031 *           iblock   - 18051 mm -->nbar Delta 
4032 *           iblock   - 18052 mm -->anti-Delta n
4033 *           iblock   - 18061 mm -->pbar N*(1400) 
4034 *           iblock   - 18062 mm -->anti-N*(1400) p
4035 *           iblock   - 18071 mm -->nbar N*(1400)
4036 *           iblock   - 18072 mm -->anti-N*(1400) n
4037 *           iblock   - 1808  mm -->anti-Delta Delta 
4038 *           iblock   - 18091 mm -->pbar N*(1535)
4039 *           iblock   - 18092 mm -->anti-N*(1535) p
4040 *           iblock   - 18101 mm -->nbar N*(1535)
4041 *           iblock   - 18102 mm -->anti-N*(1535) n
4042 *           iblock   - 18111 mm -->anti-Delta N*(1440)
4043 *           iblock   - 18112 mm -->anti-N*(1440) Delta
4044 *           iblock   - 18121 mm -->anti-Delta N*(1535)
4045 *           iblock   - 18122 mm -->anti-N*(1535) Delta
4046 *           iblock   - 1813  mm -->anti-N*(1440) N*(1440)
4047 *           iblock   - 18141 mm -->anti-N*(1440) N*(1535)
4048 *           iblock   - 18142 mm -->anti-N*(1535) N*(1440)
4049 *           iblock   - 1815  mm -->anti-N*(1535) N*(1535)
4050 clin-9/28/00-end
4051 
4052 clin-10/08/00 Processes: pi pi <-> rho rho
4053 *           iblock   - 1850  pi pi -> rho rho
4054 *           iblock   - 1851  rho rho -> pi pi
4055 clin-10/08/00-end
4056 
4057 clin-08/14/02 Processes: pi pi <-> eta eta
4058 *           iblock   - 1860  pi pi -> eta eta
4059 *           iblock   - 1861  eta eta -> pi pi
4060 * Processes: pi pi <-> pi eta
4061 *           iblock   - 1870  pi pi -> pi eta
4062 *           iblock   - 1871  pi eta -> pi pi
4063 * Processes: rho pi <-> rho eta
4064 *           iblock   - 1880  pi pi -> pi eta
4065 *           iblock   - 1881  pi eta -> pi pi
4066 * Processes: omega pi <-> omega eta
4067 *           iblock   - 1890  pi pi -> pi eta
4068 *           iblock   - 1891  pi eta -> pi pi
4069 * Processes: rho rho <-> eta eta
4070 *           iblock   - 1895  rho rho -> eta eta
4071 *           iblock   - 1896  eta eta -> rho rho
4072 clin-08/14/02-end
4073 
4074 clin-11/07/00 Processes: 
4075 *           iblock   - 366  pi rho -> K* Kbar or K*bar K
4076 *           iblock   - 466  pi rho <- K* Kbar or K*bar K
4077 
4078 clin-9/2008 Deuteron:
4079 *           iblock   - 501  B+B -> Deuteron+Meson
4080 *           iblock   - 502  Deuteron+Meson -> B+B
4081 *           iblock   - 503  Deuteron+Baryon elastic
4082 *           iblock   - 504  Deuteron+Meson elastic
4083 c
4084                  IF(IBLOCK.EQ.0)        GOTO 400
4085 *COM: FOR DIRECT PROCESS WE HAVE TREATED THE PAULI BLOCKING AND FIND
4086 *     THE MOMENTUM OF PARTICLES IN THE ''LAB'' FRAME. SO GO TO 400
4087 * A COLLISION HAS TAKEN PLACE !!
4088               LCOLL = LCOLL +1
4089 * WAS COLLISION PAULI-FORBIDEN? IF YES, NTAG = -1
4090               NTAG = 0
4091 *
4092 *             LORENTZ-TRANSFORMATION INTO CMS FRAME
4093               E1CM    = SQRT (EM1**2 + PX1CM**2 + PY1CM**2 + PZ1CM**2)
4094               P1BETA  = PX1CM*BETAX + PY1CM*BETAY + PZ1CM*BETAZ
4095               TRANSF  = GAMMA * ( GAMMA * P1BETA / (GAMMA + 1) + E1CM )
4096               Pt1I1 = BETAX * TRANSF + PX1CM
4097               Pt2I1 = BETAY * TRANSF + PY1CM
4098               Pt3I1 = BETAZ * TRANSF + PZ1CM
4099 * negelect the pauli blocking at high energies
4100               go to 90002
4101 
4102 clin-10/25/02-comment out following, since there is no path to it:
4103 c*CHECK IF PARTICLE #1 IS PAULI BLOCKED
4104 c              CALL PAULat(I1,occup)
4105 c              if (RANART(NSEED) .lt. occup) then
4106 c                ntag = -1
4107 c              else
4108 c                ntag = 0
4109 c              end if
4110 clin-10/25/02-end
4111 
4112 90002              continue
4113 *IF PARTICLE #1 IS NOT PAULI BLOCKED
4114 c              IF (NTAG .NE. -1) THEN
4115                 E2CM    = SQRT (EM2**2 + PX1CM**2 + PY1CM**2 + PZ1CM**2)
4116                 TRANSF  = GAMMA * (-GAMMA*P1BETA / (GAMMA + 1.) + E2CM)
4117                 Pt1I2 = BETAX * TRANSF - PX1CM
4118                 Pt2I2 = BETAY * TRANSF - PY1CM
4119                 Pt3I2 = BETAZ * TRANSF - PZ1CM
4120               go to 90003
4121 
4122 clin-10/25/02-comment out following, since there is no path to it:
4123 c*CHECK IF PARTICLE #2 IS PAULI BLOCKED
4124 c                CALL PAULat(I2,occup)
4125 c                if (RANART(NSEED) .lt. occup) then
4126 c                  ntag = -1
4127 c                else
4128 c                  ntag = 0
4129 c                end if
4130 cc              END IF
4131 c* IF COLLISION IS BLOCKED,RESTORE THE MOMENTUM,MASSES
4132 c* AND LABELS OF I1 AND I2
4133 cc             IF (NTAG .EQ. -1) THEN
4134 c                LBLOC  = LBLOC + 1
4135 c                P(1,I1) = PX1
4136 c                P(2,I1) = PY1
4137 c                P(3,I1) = PZ1
4138 c                P(1,I2) = PX2
4139 c                P(2,I2) = PY2
4140 c                P(3,I2) = PZ2
4141 c                E(I1)   = EM1
4142 c                E(I2)   = EM2
4143 c                LB(I1)  = LB1
4144 c                LB(I2)  = LB2
4145 cc              ELSE
4146 clin-10/25/02-end
4147 
4148 90003           IF(IBLOCK.EQ.1) LCNNE=LCNNE+1
4149               IF(IBLOCK.EQ.5) LDD=LDD+1
4150                 if(iblock.eq.2) LCNND=LCNND+1
4151               IF(IBLOCK.EQ.8) LKN=LKN+1
4152                    if(iblock.eq.43) Ldou=Ldou+1
4153 c                IF(IBLOCK.EQ.2) THEN
4154 * CALCULATE THE AVERAGE SRT FOR N + N---> N + DELTA PROCESS
4155 C                NODELT=NODELT+1
4156 C                SUMSRT=SUMSRT+SRT
4157 c                ENDIF
4158                 IF(IBLOCK.EQ.3) LCNDN=LCNDN+1
4159 * assign final momenta to particles while keep the leadng particle
4160 * behaviour
4161 C              if((pt1i1*px1+pt2i1*py1+pt3i1*pz1).gt.0)then
4162               p(1,i1)=pt1i1
4163               p(2,i1)=pt2i1
4164               p(3,i1)=pt3i1
4165               p(1,i2)=pt1i2
4166               p(2,i2)=pt2i2
4167               p(3,i2)=pt3i2
4168 C              else
4169 C              p(1,i1)=pt1i2
4170 C              p(2,i1)=pt2i2
4171 C              p(3,i1)=pt3i2
4172 C              p(1,i2)=pt1i1
4173 C              p(2,i2)=pt2i1
4174 C              p(3,i2)=pt3i1
4175 C              endif
4176                 PX1     = P(1,I1)
4177                 PY1     = P(2,I1)
4178                 PZ1     = P(3,I1)
4179                 EM1     = E(I1)
4180                 EM2     = E(I2)
4181                 LB1     = LB(I1)
4182                 LB2     = LB(I2)
4183                 ID(I1)  = 2
4184                 ID(I2)  = 2
4185                 E1      = SQRT( EM1**2 + PX1**2 + PY1**2 + PZ1**2 )
4186                 ID1     = ID(I1)
4187               go to 90004
4188 clin-10/25/02-comment out following, since there is no path to it:
4189 c* change phase space density FOR NUCLEONS INVOLVED :
4190 c* NOTE THAT f is the phase space distribution function for nucleons only
4191 c                if ((abs(ix1).le.mx) .and. (abs(iy1).le.my) .and.
4192 c     &              (abs(iz1).le.mz)) then
4193 c                  ipx1p = nint(p(1,i1)/dpx)
4194 c                  ipy1p = nint(p(2,i1)/dpy)
4195 c                  ipz1p = nint(p(3,i1)/dpz)
4196 c                  if ((ipx1p.ne.ipx1) .or. (ipy1p.ne.ipy1) .or.
4197 c     &                (ipz1p.ne.ipz1)) then
4198 c                    if ((abs(ipx1).le.mpx) .and. (abs(ipy1).le.my)
4199 c     &                .and. (ipz1.ge.-mpz) .and. (ipz1.le.mpzp)
4200 c     &                .AND. (AM1.LT.1.))
4201 c     &                f(ix1,iy1,iz1,ipx1,ipy1,ipz1) =
4202 c     &                f(ix1,iy1,iz1,ipx1,ipy1,ipz1) - 1.
4203 c                    if ((abs(ipx1p).le.mpx) .and. (abs(ipy1p).le.my)
4204 c     &                .and. (ipz1p.ge.-mpz).and. (ipz1p.le.mpzp)
4205 c     &                .AND. (EM1.LT.1.))
4206 c     &                f(ix1,iy1,iz1,ipx1p,ipy1p,ipz1p) =
4207 c     &                f(ix1,iy1,iz1,ipx1p,ipy1p,ipz1p) + 1.
4208 c                  end if
4209 c                end if
4210 c                if ((abs(ix2).le.mx) .and. (abs(iy2).le.my) .and.
4211 c     &              (abs(iz2).le.mz)) then
4212 c                  ipx2p = nint(p(1,i2)/dpx)
4213 c                  ipy2p = nint(p(2,i2)/dpy)
4214 c                  ipz2p = nint(p(3,i2)/dpz)
4215 c                  if ((ipx2p.ne.ipx2) .or. (ipy2p.ne.ipy2) .or.
4216 c     &                (ipz2p.ne.ipz2)) then
4217 c                    if ((abs(ipx2).le.mpx) .and. (abs(ipy2).le.my)
4218 c     &                .and. (ipz2.ge.-mpz) .and. (ipz2.le.mpzp)
4219 c     &                .AND. (AM2.LT.1.))
4220 c     &                f(ix2,iy2,iz2,ipx2,ipy2,ipz2) =
4221 c     &                f(ix2,iy2,iz2,ipx2,ipy2,ipz2) - 1.
4222 c                    if ((abs(ipx2p).le.mpx) .and. (abs(ipy2p).le.my)
4223 c     &                .and. (ipz2p.ge.-mpz) .and. (ipz2p.le.mpzp)
4224 c     &                .AND. (EM2.LT.1.))
4225 c     &                f(ix2,iy2,iz2,ipx2p,ipy2p,ipz2p) =
4226 c     &                f(ix2,iy2,iz2,ipx2p,ipy2p,ipz2p) + 1.
4227 c                  end if
4228 c                end if
4229 clin-10/25/02-end
4230 
4231 90004              continue
4232             AM1=EM1
4233             AM2=EM2
4234 c            END IF
4235 
4236 
4237   400       CONTINUE
4238 c
4239 clin-6/10/03 skips the info output on resonance creations:
4240 c            goto 550
4241 cclin-4/30/03 study phi,K*,Lambda(1520) resonances at creation:
4242 cc     note that no decays give these particles, so don't need to consider nnn:
4243 c            if(iblock.ne.0.and.(lb(i1).eq.29.or.iabs(lb(i1)).eq.30
4244 c     1           .or.lb(i2).eq.29.or.iabs(lb(i2)).eq.30
4245 c     2           .or.lb1i.eq.29.or.iabs(lb1i).eq.30
4246 c     3           .or.lb2i.eq.29.or.iabs(lb2i).eq.30)) then
4247 c               lb1now=lb(i1)
4248 c               lb2now=lb(i2)
4249 cc
4250 c               nphi0=0
4251 c               nksp0=0
4252 c               nksm0=0
4253 cc               nlar0=0
4254 cc               nlarbar0=0
4255 c               if(lb1i.eq.29) then
4256 c                  nphi0=nphi0+1
4257 c               elseif(lb1i.eq.30) then
4258 c                  nksp0=nksp0+1
4259 c               elseif(lb1i.eq.-30) then
4260 c                  nksm0=nksm0+1
4261 c               endif
4262 c               if(lb2i.eq.29) then
4263 c                  nphi0=nphi0+1
4264 c               elseif(lb2i.eq.30) then
4265 c                  nksp0=nksp0+1
4266 c               elseif(lb2i.eq.-30) then
4267 c                  nksm0=nksm0+1
4268 c               endif
4269 cc
4270 c               nphi=0
4271 c               nksp=0
4272 c               nksm=0
4273 c               nlar=0
4274 c               nlarbar=0
4275 c               if(lb1now.eq.29) then
4276 c                  nphi=nphi+1
4277 c               elseif(lb1now.eq.30) then
4278 c                  nksp=nksp+1
4279 c               elseif(lb1now.eq.-30) then
4280 c                  nksm=nksm+1
4281 c               endif
4282 c               if(lb2now.eq.29) then
4283 c                  nphi=nphi+1
4284 c               elseif(lb2now.eq.30) then
4285 c                  nksp=nksp+1
4286 c               elseif(lb2now.eq.-30) then
4287 c                  nksm=nksm+1
4288 c               endif
4289 cc     
4290 c               if(nphi.eq.2.or.nksp.eq.2.or.nksm.eq.2) then
4291 c                  write(91,*) '2 same resonances in one reaction!'
4292 c                  write(91,*) nphi,nksp,nksm,iblock
4293 c               endif
4294 c
4295 cc     All reactions create or destroy no more than 1 these resonance,
4296 cc     otherwise file "fort.91" warns us:
4297 c               do 222 ires=1,3
4298 c                  if(ires.eq.1.and.nphi.ne.nphi0) then
4299 c                     idr=29
4300 c                  elseif(ires.eq.2.and.nksp.ne.nksp0) then
4301 c                     idr=30
4302 c                  elseif(ires.eq.3.and.nksm.ne.nksm0) then
4303 c                     idr=-30
4304 c                  else
4305 c                     goto 222
4306 c                  endif
4307 cctest off for resonance (phi, K*) studies:
4308 cc               if(lb1now.eq.idr) then
4309 cc       write(17,112) 'collision',lb1now,P(1,I1),P(2,I1),P(3,I1),e(I1),nt
4310 cc               elseif(lb2now.eq.idr) then
4311 cc       write(17,112) 'collision',lb2now,P(1,I2),P(2,I2),P(3,I2),e(I2),nt
4312 cc               elseif(lb1i.eq.idr) then
4313 cc       write(18,112) 'collision',lb1i,px1i,py1i,pz1i,em1i,nt
4314 cc               elseif(lb2i.eq.idr) then
4315 cc       write(18,112) 'collision',lb2i,px2i,py2i,pz2i,em2i,nt
4316 cc               endif
4317 c 222           continue
4318 c
4319 c            else
4320 c            endif
4321 cc 112        format(a10,I4,4(1x,f9.3),1x,I4)
4322 c
4323 clin-2/26/03 skips the check of energy conservation after each binary search:
4324 c 550        goto 555
4325 c            pxfin=0
4326 c            pyfin=0
4327 c            pzfin=0
4328 c            efin=0
4329 c            if(e(i1).ne.0.or.lb(i1).eq.10022) then
4330 c               efin=efin+SQRT(E(I1)**2+P(1,I1)**2+P(2,I1)**2+P(3,I1)**2)
4331 c               pxfin=pxfin+P(1,I1)
4332 c               pyfin=pyfin+P(2,I1)
4333 c               pzfin=pzfin+P(3,I1)
4334 c            endif
4335 c            if(e(i2).ne.0.or.lb(i2).eq.10022) then
4336 c               efin=efin+SQRT(E(I2)**2+P(1,I2)**2+P(2,I2)**2+P(3,I2)**2)
4337 c               pxfin=pxfin+P(1,I2)
4338 c               pyfin=pyfin+P(2,I2)
4339 c               pzfin=pzfin+P(3,I2)
4340 c            endif
4341 c            if((nnn-nnnini).ge.1) then
4342 c               do imore=nnnini+1,nnn
4343 c                  if(EPION(imore,IRUN).ne.0) then
4344 c                     efin=efin+SQRT(EPION(imore,IRUN)**2
4345 c     1                    +PPION(1,imore,IRUN)**2+PPION(2,imore,IRUN)**2
4346 c     2                    +PPION(3,imore,IRUN)**2)
4347 c                     pxfin=pxfin+PPION(1,imore,IRUN)
4348 c                     pyfin=pyfin+PPION(2,imore,IRUN)
4349 c                     pzfin=pzfin+PPION(3,imore,IRUN)
4350 c                  endif
4351 c               enddo
4352 c            endif
4353 c            devio=sqrt((pxfin-pxini)**2+(pyfin-pyini)**2
4354 c     1           +(pzfin-pzini)**2+(efin-eini)**2)
4355 cc
4356 c            if(devio.ge.0.1) then
4357 c               write(92,'a20,5(1x,i6),2(1x,f8.3)') 'iblock,lb,npi=',
4358 c     1              iblock,lb1i,lb2i,lb(i1),lb(i2),e(i1),e(i2)
4359 c               do imore=nnnini+1,nnn
4360 c                  if(EPION(imore,IRUN).ne.0) then
4361 c                     write(92,'a10,2(1x,i6)') 'ipi,lbm=',
4362 c     1                    imore,LPION(imore,IRUN)
4363 c                  endif
4364 c               enddo
4365 c               write(92,'a3,4(1x,f8.3)') 'I:',eini,pxini,pyini,pzini
4366 c               write(92,'a3,5(1x,f8.3)') 
4367 c     1              'F:',efin,pxfin,pyfin,pzfin,devio
4368 c            endif
4369 c
4370  555        continue
4371 ctest off only one collision for the same 2 particles in the same timestep:
4372 c            if(iblock.ne.0) then
4373 c               goto 800
4374 c            endif
4375 ctest off collisions history:
4376 c            if(iblock.ne.0) then 
4377 c               write(10,*) nt,i1,i2,iblock,x1,z1,x2,z2
4378 c            endif
4379 
4380   600     CONTINUE
4381 
4382 clin-4/2012 option of pi0 decays:
4383 c     particles in lpion() may be a pi0, and when ipi0dcy=1 
4384 c     we need to decay them at nt=ntmax after all lb(i1) decays are done:
4385  798      if(nt.eq.ntmax.and.ipi0dcy.eq.1
4386      1         .and.i1.eq.(MASSR(IRUN)+MSUM)) then
4387              do ipion=1,NNN
4388                 if(LPION(ipion,IRUN).eq.4) then
4389                    wid=7.85e-9
4390                    call resdec(i1,nt,nnn,wid,idecay,ipion)
4391                 endif
4392              enddo
4393           endif
4394 ctest off
4395 c          if(nt.eq.ntmax.and.i1.eq.(MASSR(IRUN)+MSUM)) then
4396 c             do ip=1,i1
4397 c                write(98,*) lb(ip),e(ip),ip
4398 c             enddo
4399 c          endif
4400 
4401 clin-4/2012 option of pi0 decays-end
4402 
4403   800   CONTINUE
4404 * RELABLE MESONS LEFT IN THIS RUN EXCLUDING THOSE BEING CREATED DURING
4405 * THIS TIME STEP AND COUNT THE TOTAL NO. OF PARTICLES IN THIS RUN
4406 * note that the first mass=mta+mpr particles are baryons
4407 c        write(*,*)'I: NNN,massr ', nnn,massr(irun)
4408         N0=MASS+MSUM
4409         DO 1005 N=N0+1,MASSR(IRUN)+MSUM
4410 cbz11/25/98
4411 clin-2/19/03 lb>5000: keep particles with no LB codes in ART(photon,lepton,..):
4412 c        IF(E(N).GT.0.)THEN
4413         IF(E(N) .GT. 0. .OR. LB(N) .GT. 5000)THEN
4414 cbz11/25/98end
4415         NNN=NNN+1
4416         RPION(1,NNN,IRUN)=R(1,N)
4417         RPION(2,NNN,IRUN)=R(2,N)
4418         RPION(3,NNN,IRUN)=R(3,N)
4419 clin-10/28/03:
4420         if(nt.eq.ntmax) then
4421            ftpisv(NNN,IRUN)=ftsv(N)
4422            tfdpi(NNN,IRUN)=tfdcy(N)
4423         endif
4424 c
4425         PPION(1,NNN,IRUN)=P(1,N)
4426         PPION(2,NNN,IRUN)=P(2,N)
4427         PPION(3,NNN,IRUN)=P(3,N)
4428         EPION(NNN,IRUN)=E(N)
4429         LPION(NNN,IRUN)=LB(N)
4430 c       !! sp 12/19/00
4431         PROPI(NNN,IRUN)=PROPER(N)
4432 clin-5/2008:
4433         dppion(NNN,IRUN)=dpertp(N)
4434 c        if(lb(n) .eq. 45)
4435 c    &   write(*,*)'IN-1  NT,NNN,LB,P ',nt,NNN,lb(n),proper(n)
4436         ENDIF
4437  1005 CONTINUE
4438         MASSRN(IRUN)=NNN+MASS
4439 c        write(*,*)'F: NNN,massrn ', nnn,massrn(irun)
4440 1000   CONTINUE
4441 * CALCULATE THE AVERAGE SRT FOR N + N--->N +DELTA PROCESSES
4442 C        IF(NODELT.NE.0)THEN
4443 C        AVSRT=SUMSRT/FLOAT(NODELT)
4444 C        ELSE
4445 C        AVSRT=0.
4446 C        ENDIF
4447 C        WRITE(1097,'(F8.2,2X,E10.3)')FLOAT(NT)*DT,AVSRT
4448 * RELABLE ALL THE PARTICLES EXISTING AFTER THIS TIME STEP
4449         IA=0
4450         IB=0
4451         DO 10001 IRUN=1,NUM
4452         IA=IA+MASSR(IRUN-1)
4453         IB=IB+MASSRN(IRUN-1)
4454         DO 10001 IC=1,MASSRN(IRUN)
4455         IE=IA+IC
4456         IG=IB+IC
4457         IF(IC.LE.MASS)THEN
4458         RT(1,IG)=R(1,IE)
4459         RT(2,IG)=R(2,IE)
4460         RT(3,IG)=R(3,IE)
4461 clin-10/28/03:
4462         if(nt.eq.ntmax) then
4463            fttemp(IG)=ftsv(IE)
4464            tft(IG)=tfdcy(IE)
4465         endif
4466 c
4467         PT(1,IG)=P(1,IE)
4468         PT(2,IG)=P(2,IE)
4469         PT(3,IG)=P(3,IE)
4470         ET(IG)=E(IE)
4471         LT(IG)=LB(IE)
4472         PROT(IG)=PROPER(IE)
4473 clin-5/2008:
4474         dptemp(IG)=dpertp(IE)
4475         ELSE
4476         I0=IC-MASS
4477         RT(1,IG)=RPION(1,I0,IRUN)
4478         RT(2,IG)=RPION(2,I0,IRUN)
4479         RT(3,IG)=RPION(3,I0,IRUN)
4480 clin-10/28/03:
4481         if(nt.eq.ntmax) then
4482            fttemp(IG)=ftpisv(I0,IRUN)
4483            tft(IG)=tfdpi(I0,IRUN)
4484         endif
4485 c
4486         PT(1,IG)=PPION(1,I0,IRUN)
4487         PT(2,IG)=PPION(2,I0,IRUN)
4488         PT(3,IG)=PPION(3,I0,IRUN)
4489         ET(IG)=EPION(I0,IRUN)
4490         LT(IG)=LPION(I0,IRUN)
4491         PROT(IG)=PROPI(I0,IRUN)
4492 clin-5/2008:
4493         dptemp(IG)=dppion(I0,IRUN)
4494         ENDIF
4495 10001   CONTINUE
4496 c
4497         IL=0
4498 clin-10/26/01-hbt:
4499 c        DO 10002 IRUN=1,NUM
4500         DO 10003 IRUN=1,NUM
4501 
4502         MASSR(IRUN)=MASSRN(IRUN)
4503         IL=IL+MASSR(IRUN-1)
4504         DO 10002 IM=1,MASSR(IRUN)
4505         IN=IL+IM
4506         R(1,IN)=RT(1,IN)
4507         R(2,IN)=RT(2,IN)
4508         R(3,IN)=RT(3,IN)
4509 clin-10/28/03:
4510         if(nt.eq.ntmax) then
4511            ftsv(IN)=fttemp(IN)
4512            tfdcy(IN)=tft(IN)
4513         endif
4514         P(1,IN)=PT(1,IN)
4515         P(2,IN)=PT(2,IN)
4516         P(3,IN)=PT(3,IN)
4517         E(IN)=ET(IN)
4518         LB(IN)=LT(IN)
4519         PROPER(IN)=PROT(IN)
4520 clin-5/2008:
4521         dpertp(IN)=dptemp(IN)
4522        IF(LB(IN).LT.1.OR.LB(IN).GT.2)ID(IN)=0
4523 10002   CONTINUE
4524 clin-ctest off check energy conservation after each timestep
4525 c         enetot=0.
4526 c         do ip=1,MASSR(IRUN)
4527 c            if(e(ip).ne.0.or.lb(ip).eq.10022) enetot=enetot
4528 c     1           +sqrt(p(1,ip)**2+p(2,ip)**2+p(3,ip)**2+e(ip)**2)
4529 c         enddo
4530 c         write(91,*) 'B:',nt,enetot,massr(irun),bimp 
4531 clin-3/2009 move to the end of a timestep to take care of freezeout spacetime:
4532 c        call hbtout(MASSR(IRUN),nt,ntmax)
4533 10003 CONTINUE
4534 c
4535       RETURN
4536       END
4537 
4538 clin-9/2012: use double precision for S in CMS(): to avoid crash 
4539 c     (segmentation fault due to s<0, which happened at high energies 
4540 c     such as LHC with large NTMAX for two almost-comoving hadrons
4541 c     that have small Pt but large |Pz|):
4542 ****************************************
4543 c            SUBROUTINE CMS(I1,I2,PX1CM,PY1CM,PZ1CM,SRT)
4544 * PURPOSE : FIND THE MOMENTA OF PARTICLES IN THE CMS OF THE
4545 *          TWO COLLIDING PARTICLES
4546 * VARIABLES :
4547 *****************************************
4548 c            PARAMETER (MAXSTR=150001)
4549 c            COMMON   /AA/  R(3,MAXSTR)
4550 ccc      SAVE /AA/
4551 c            COMMON   /BB/  P(3,MAXSTR)
4552 ccc      SAVE /BB/
4553 c            COMMON   /CC/  E(MAXSTR)
4554 ccc      SAVE /CC/
4555 c            COMMON   /BG/  BETAX,BETAY,BETAZ,GAMMA
4556 ccc      SAVE /BG/
4557 c            SAVE   
4558 c            PX1=P(1,I1)
4559 c            PY1=P(2,I1)
4560 c            PZ1=P(3,I1)
4561 c            PX2=P(1,I2)
4562 c            PY2=P(2,I2)
4563 c            PZ2=P(3,I2)
4564 c            EM1=E(I1)
4565 c            EM2=E(I2)
4566 c            E1=SQRT(EM1**2+PX1**2+PY1**2+PZ1**2)
4567 c            E2=SQRT(EM2**2 + PX2**2 + PY2**2 + PZ2**2 )
4568 c            S=(E1+E2)**2-(PX1+PX2)**2-(PY1+PY2)**2-(PZ1+PZ2)**2
4569 c            SRT=SQRT(S)
4570 c*LORENTZ-TRANSFORMATION IN I1-I2-C.M. SYSTEM
4571 c              ETOTAL = E1 + E2
4572 c              BETAX  = (PX1+PX2) / ETOTAL
4573 c              BETAY  = (PY1+PY2) / ETOTAL
4574 c              BETAZ  = (PZ1+PZ2) / ETOTAL
4575 c              GAMMA  = 1.0 / SQRT(1.0-BETAX**2-BETAY**2-BETAZ**2)
4576 c*TRANSFORMATION OF MOMENTA (PX1CM = - PX2CM)
4577 c              P1BETA = PX1*BETAX + PY1*BETAY + PZ1 * BETAZ
4578 c              TRANSF = GAMMA * ( GAMMA * P1BETA / (GAMMA + 1) - E1 )
4579 c              PX1CM  = BETAX * TRANSF + PX1
4580 c              PY1CM  = BETAY * TRANSF + PY1
4581 c              PZ1CM  = BETAZ * TRANSF + PZ1
4582 c              RETURN
4583 c              END
4584 ****************************************
4585             SUBROUTINE CMS(I1,I2,PX1CM,PY1CM,PZ1CM,SRT)
4586 * PURPOSE : FIND THE MOMENTA OF PARTICLES IN THE CMS OF THE
4587 *          TWO COLLIDING PARTICLES
4588 * VARIABLES :
4589 *****************************************
4590             PARAMETER (MAXSTR=150001)
4591             double precision px1,py1,pz1,px2,py2,pz2,em1,em2,e1,e2,
4592      1      s,ETOTAL,P1BETA,TRANSF,dBETAX,dBETAY,dBETAZ,dGAMMA,scheck
4593             COMMON   /BB/  P(3,MAXSTR)
4594             COMMON   /CC/  E(MAXSTR)
4595             COMMON   /BG/  BETAX,BETAY,BETAZ,GAMMA
4596             SAVE   
4597             PX1=dble(P(1,I1))
4598             PY1=dble(P(2,I1))
4599             PZ1=dble(P(3,I1))
4600             PX2=dble(P(1,I2))
4601             PY2=dble(P(2,I2))
4602             PZ2=dble(P(3,I2))
4603             EM1=dble(E(I1))
4604             EM2=dble(E(I2))
4605             E1=dSQRT(EM1**2+PX1**2+PY1**2+PZ1**2)
4606             E2=dSQRT(EM2**2+PX2**2+PY2**2+PZ2**2)
4607             S=(E1+E2)**2-(PX1+PX2)**2-(PY1+PY2)**2-(PZ1+PZ2)**2
4608             IF(S.LE.0) S=0d0
4609             SRT=sngl(dSQRT(S))
4610 *LORENTZ-TRANSFORMATION IN I1-I2-C.M. SYSTEM
4611             ETOTAL = E1 + E2
4612             dBETAX  = (PX1+PX2) / ETOTAL
4613             dBETAY  = (PY1+PY2) / ETOTAL
4614             dBETAZ  = (PZ1+PZ2) / ETOTAL
4615 clin-9/2012: check argument in sqrt():
4616             scheck=1.d0-dBETAX**2-dBETAY**2-dBETAZ**2
4617             if(scheck.le.0d0) then
4618                write(99,*) 'scheck1: ', scheck
4619                stop
4620             endif
4621             dGAMMA=1.d0/dSQRT(scheck)
4622 *TRANSFORMATION OF MOMENTA (PX1CM = - PX2CM)
4623             P1BETA = PX1*dBETAX + PY1*dBETAY + PZ1 * dBETAZ
4624             TRANSF = dGAMMA * ( dGAMMA * P1BETA / (dGAMMA + 1d0) - E1 )
4625             PX1CM  = sngl(dBETAX * TRANSF + PX1)
4626             PY1CM  = sngl(dBETAY * TRANSF + PY1)
4627             PZ1CM  = sngl(dBETAZ * TRANSF + PZ1)
4628             BETAX  = sngl(dBETAX)
4629             BETAY  = sngl(dBETAY)
4630             BETAZ  = sngl(dBETAZ)
4631             GAMMA  = sngl(dGAMMA)
4632             RETURN
4633             END
4634 clin-9/2012-end
4635 
4636 ***************************************
4637             SUBROUTINE DISTCE(I1,I2,DELTAR,DS,DT,EC,SRT
4638      1      ,IC,PX1CM,PY1CM,PZ1CM)
4639 * PURPOSE : CHECK IF THE COLLISION BETWEEN TWO PARTICLES CAN HAPPEN
4640 *           BY CHECKING
4641 *                      (1) IF THE DISTANCE BETWEEN THEM IS SMALLER
4642 *           THAN THE MAXIMUM DISTANCE DETERMINED FROM THE CROSS SECTION.
4643 *                      (2) IF PARTICLE WILL PASS EACH OTHER WITHIN
4644 *           TWO HARD CORE RADIUS.
4645 *                      (3) IF PARTICLES WILL GET CLOSER.
4646 * VARIABLES :
4647 *           IC=1 COLLISION HAPPENED
4648 *           IC=-1 COLLISION CAN NOT HAPPEN
4649 *****************************************
4650             PARAMETER (MAXSTR=150001)
4651             COMMON   /AA/  R(3,MAXSTR)
4652 cc      SAVE /AA/
4653             COMMON   /BB/  P(3,MAXSTR)
4654 cc      SAVE /BB/
4655             COMMON   /CC/  E(MAXSTR)
4656 cc      SAVE /CC/
4657             COMMON   /BG/  BETAX,BETAY,BETAZ,GAMMA
4658             COMMON  /EE/      ID(MAXSTR),LB(MAXSTR)
4659 cc      SAVE /BG/
4660             common/leadng/lb1,px1,py1,pz1,em1,e1,xfnl,yfnl,zfnl,tfnl,
4661      1           px1n,py1n,pz1n,dp1n
4662             common /dpi/em2,lb2
4663             SAVE   
4664             IC=0
4665             X1=R(1,I1)
4666             Y1=R(2,I1)
4667             Z1=R(3,I1)
4668             PX1=P(1,I1)
4669             PY1=P(2,I1)
4670             PZ1=P(3,I1)
4671             X2=R(1,I2)
4672             Y2=R(2,I2)
4673             Z2=R(3,I2)
4674             PX2=P(1,I2)
4675             PY2=P(2,I2)
4676             PZ2=P(3,I2)
4677             EM1=E(I1)
4678             EM2=E(I2)
4679             E1=SQRT(EM1**2+PX1**2+PY1**2+PZ1**2)
4680 c            IF (ABS(X1-X2) .GT. DELTAR) GO TO 400
4681 c            IF (ABS(Y1-Y2) .GT. DELTAR) GO TO 400
4682 c            IF (ABS(Z1-Z2) .GT. DELTAR) GO TO 400
4683             RSQARE = (X1-X2)**2 + (Y1-Y2)**2 + (Z1-Z2)**2
4684             IF (RSQARE .GT. DELTAR**2) GO TO 400
4685 *NOW PARTICLES ARE CLOSE ENOUGH TO EACH OTHER !
4686               E2     = SQRT ( EM2**2 + PX2**2 + PY2**2 + PZ2**2 )
4687               S      = SRT*SRT
4688             IF (S .LT. EC) GO TO 400
4689 *NOW THERE IS ENOUGH ENERGY AVAILABLE !
4690 *LORENTZ-TRANSFORMATION IN I1-I2-C.M. SYSTEM
4691 * BETAX, BETAY, BETAZ AND GAMMA HAVE BEEN GIVEN IN THE SUBROUTINE CMS
4692 *TRANSFORMATION OF MOMENTA (PX1CM = - PX2CM)
4693               P1BETA = PX1*BETAX + PY1*BETAY + PZ1 * BETAZ
4694               TRANSF = GAMMA * ( GAMMA * P1BETA / (GAMMA + 1) - E1 )
4695               PRCM   = SQRT (PX1CM**2 + PY1CM**2 + PZ1CM**2)
4696               IF (PRCM .LE. 0.00001) GO TO 400
4697 *TRANSFORMATION OF SPATIAL DISTANCE
4698               DRBETA = BETAX*(X1-X2) + BETAY*(Y1-Y2) + BETAZ*(Z1-Z2)
4699               TRANSF = GAMMA * GAMMA * DRBETA / (GAMMA + 1)
4700               DXCM   = BETAX * TRANSF + X1 - X2
4701               DYCM   = BETAY * TRANSF + Y1 - Y2
4702               DZCM   = BETAZ * TRANSF + Z1 - Z2
4703 *DETERMINING IF THIS IS THE POINT OF CLOSEST APPROACH
4704               DRCM   = SQRT (DXCM**2  + DYCM**2  + DZCM**2 )
4705               DZZ    = (PX1CM*DXCM + PY1CM*DYCM + PZ1CM*DZCM) / PRCM
4706               if ((drcm**2 - dzz**2) .le. 0.) then
4707                 BBB = 0.
4708               else
4709                 BBB    = SQRT (DRCM**2 - DZZ**2)
4710               end if
4711 *WILL PARTICLE PASS EACH OTHER WITHIN 2 * HARD CORE RADIUS ?
4712               IF (BBB .GT. DS) GO TO 400
4713               RELVEL = PRCM * (1.0/E1 + 1.0/E2)
4714               DDD    = RELVEL * DT * 0.5
4715 *WILL PARTICLES GET CLOSER ?
4716               IF (ABS(DDD) .LT. ABS(DZZ)) GO TO 400
4717               IC=1
4718               GO TO 500
4719 400           IC=-1
4720 500           CONTINUE
4721               RETURN
4722               END
4723 ****************************************
4724 *                                                                      *
4725 *                                                                      *
4726       SUBROUTINE CRNN(IRUN,PX,PY,PZ,SRT,I1,I2,IBLOCK,
4727      1NTAG,SIGNN,SIG,NT,ipert1)
4728 *     PURPOSE:                                                         *
4729 *             DEALING WITH NUCLEON-NUCLEON COLLISIONS                    *
4730 *     NOTE   :                                                         *
4731 *     QUANTITIES:                                                 *
4732 *           PX,PY,PZ - MOMENTUM COORDINATES OF ONE PARTICLE IN CM FRAME*
4733 *           SRT      - SQRT OF S                                       *
4734 *           NSTAR =1 INCLUDING N* RESORANCE,ELSE NOT                   *
4735 *           NDIRCT=1 INCLUDING DIRECT PION PRODUCTION PROCESS         *
4736 *           IBLOCK   - THE INFORMATION BACK                            *
4737 *                      0-> COLLISION CANNOT HAPPEN                     *
4738 *                      1-> N-N ELASTIC COLLISION                       *
4739 *                      2-> N+N->N+DELTA,OR N+N->N+N* REACTION          *
4740 *                      3-> N+DELTA->N+N OR N+N*->N+N REACTION          *
4741 *                      4-> N+N->D+D+pion reaction
4742 *                     43->N+N->D(N*)+D(N*) reaction
4743 *                     44->N+N->D+D+rho reaction
4744 *                     45->N+N->N+N+rho
4745 *                     46->N+N->N+N+omega
4746 *           N12       - IS USED TO SPECIFY BARYON-BARYON REACTION      *
4747 *                      CHANNELS. M12 IS THE REVERSAL CHANNEL OF N12    *
4748 *                      N12,                                            *
4749 *                      M12=1 FOR p+n-->delta(+)+ n                     *
4750 *                          2     p+n-->delta(0)+ p                     *
4751 *                          3     p+p-->delta(++)+n                     *
4752 *                          4     p+p-->delta(+)+p                      *
4753 *                          5     n+n-->delta(0)+n                      *
4754 *                          6     n+n-->delta(-)+p                      *
4755 *                          7     n+p-->N*(0)(1440)+p                   *
4756 *                          8     n+p-->N*(+)(1440)+n                   *
4757 *                        9     p+p-->N*(+)(1535)+p                     *
4758 *                        10    n+n-->N*(0)(1535)+n                     *
4759 *                         11    n+p-->N*(+)(1535)+n                     *
4760 *                        12    n+p-->N*(0)(1535)+p
4761 *                        13    D(++)+D(-)-->N*(+)(1440)+n
4762 *                         14    D(++)+D(-)-->N*(0)(1440)+p
4763 *                        15    D(+)+D(0)--->N*(+)(1440)+n
4764 *                        16    D(+)+D(0)--->N*(0)(1440)+p
4765 *                        17    D(++)+D(0)-->N*(+)(1535)+p
4766 *                        18    D(++)+D(-)-->N*(0)(1535)+p
4767 *                        19    D(++)+D(-)-->N*(+)(1535)+n
4768 *                        20    D(+)+D(+)-->N*(+)(1535)+p
4769 *                        21    D(+)+D(0)-->N*(+)(1535)+n
4770 *                        22    D(+)+D(0)-->N*(0)(1535)+p
4771 *                        23    D(+)+D(-)-->N*(0)(1535)+n
4772 *                        24    D(0)+D(0)-->N*(0)(1535)+n
4773 *                          25    N*(+)(14)+N*(+)(14)-->N*(+)(15)+p
4774 *                          26    N*(0)(14)+N*(0)(14)-->N*(0)(15)+n
4775 *                          27    N*(+)(14)+N*(0)(14)-->N*(+)(15)+n
4776 *                        28    N*(+)(14)+N*(0)(14)-->N*(0)(15)+p
4777 *                        29    N*(+)(14)+D+-->N*(+)(15)+p
4778 *                        30    N*(+)(14)+D0-->N*(+)(15)+n
4779 *                        31    N*(+)(14)+D(-)-->N*(0)(1535)+n
4780 *                        32    N*(0)(14)+D++--->N*(+)(15)+p
4781 *                        33    N*(0)(14)+D+--->N*(+)(15)+n
4782 *                        34    N*(0)(14)+D+--->N*(0)(15)+p
4783 *                        35    N*(0)(14)+D0-->N*(0)(15)+n
4784 *                        36    N*(+)(14)+D0--->N*(0)(15)+p
4785 *                        ++    see the note book for more listing
4786 *                     
4787 *
4788 *     NOTE ABOUT N*(1440) RESORANCE IN Nucleon+NUCLEON COLLISION:      * 
4789 *     As it has been discussed in VerWest's paper,I= 1(initial isospin)*
4790 *     channel can all be attributed to delta resorance while I= 0      *
4791 *     channel can all be  attribured to N* resorance.Only in n+p       *
4792 *     one can have I=0 channel so is the N*(1440) resonance            *
4793 *                                                                      *
4794 *                             REFERENCES:                            *    
4795 *                    J. CUGNON ET AL., NUCL. PHYS. A352, 505 (1981)    *
4796 *                    Y. KITAZOE ET AL., PHYS. LETT. 166B, 35 (1986)    *
4797 *                    B. VerWest el al., PHYS. PRV. C25 (1982)1979      *
4798 *                    Gy. Wolf  et al, Nucl Phys A517 (1990) 615;       *
4799 *                                     Nucl phys A552 (1993) 349.       *
4800 **********************************
4801         PARAMETER (MAXSTR=150001,MAXR=1,AMN=0.939457,
4802      1  AMP=0.93828,AP1=0.13496,aka=0.498,AP2=0.13957,AM0=1.232,
4803      2  PI=3.1415926,CUTOFF=1.8966,AVMASS=0.9383,APHI=1.020)
4804         parameter     (MX=4,MY=4,MZ=8,MPX=4,MPY=4,mpz=10,mpzp=10)
4805         parameter (xmd=1.8756,npdmax=10000)
4806         COMMON /AA/ R(3,MAXSTR)
4807 cc      SAVE /AA/
4808         COMMON /BB/ P(3,MAXSTR)
4809 cc      SAVE /BB/
4810         COMMON /CC/ E(MAXSTR)
4811 cc      SAVE /CC/
4812         COMMON /EE/ ID(MAXSTR),LB(MAXSTR)
4813 cc      SAVE /EE/
4814         common /ff/f(-mx:mx,-my:my,-mz:mz,-mpx:mpx,-mpy:mpy,-mpz:mpzp)
4815 cc      SAVE /ff/
4816         common /gg/ dx,dy,dz,dpx,dpy,dpz
4817 cc      SAVE /gg/
4818         COMMON /INPUT/ NSTAR,NDIRCT,DIR
4819 cc      SAVE /INPUT/
4820         COMMON /NN/NNN
4821 cc      SAVE /NN/
4822         COMMON /BG/BETAX,BETAY,BETAZ,GAMMA
4823 cc      SAVE /BG/
4824         COMMON   /RUN/NUM
4825 cc      SAVE /RUN/
4826         COMMON   /PA/RPION(3,MAXSTR,MAXR)
4827 cc      SAVE /PA/
4828         COMMON   /PB/PPION(3,MAXSTR,MAXR)
4829 cc      SAVE /PB/
4830         COMMON   /PC/EPION(MAXSTR,MAXR)
4831 cc      SAVE /PC/
4832         COMMON   /PD/LPION(MAXSTR,MAXR)
4833 cc      SAVE /PD/
4834         COMMON/TABLE/ xarray(0:1000),earray(0:1000)
4835 cc      SAVE /TABLE/
4836         common/input1/ MASSPR,MASSTA,ISEED,IAVOID,DT
4837 cc      SAVE /input1/
4838       common/leadng/lb1,px1,py1,pz1,em1,e1,xfnl,yfnl,zfnl,tfnl,
4839      1 px1n,py1n,pz1n,dp1n
4840 cc      SAVE /leadng/
4841       COMMON/RNDF77/NSEED
4842 cc      SAVE /RNDF77/
4843       common /dpi/em2,lb2
4844       COMMON /dpert/dpertt(MAXSTR,MAXR),dpertp(MAXSTR),dplast(MAXSTR),
4845      1     dpdcy(MAXSTR),dpdpi(MAXSTR,MAXR),dpt(MAXSTR, MAXR),
4846      2     dpp1(MAXSTR,MAXR),dppion(MAXSTR,MAXR)
4847       common /para8/ idpert,npertd,idxsec
4848       dimension ppd(3,npdmax),lbpd(npdmax)
4849       SAVE   
4850 *-----------------------------------------------------------------------
4851       n12=0
4852       m12=0
4853       IBLOCK=0
4854       NTAG=0
4855       EM1=E(I1)
4856       EM2=E(I2)
4857       PR=SQRT( PX**2 + PY**2 + PZ**2 )
4858       C2=PZ / PR
4859       X1=RANART(NSEED)
4860       ianti=0
4861       if(lb(i1).lt.0 .and. lb(i2).lt.0) ianti=1
4862       call sbbdm(srt,sdprod,ianti,lbm,xmm,pfinal)
4863 clin-5/2008 Production of perturbative deuterons for idpert=1:
4864       if(idpert.eq.1.and.ipert1.eq.1) then
4865          IF (SRT .LT. 2.012) RETURN
4866          if((iabs(lb(i1)).eq.1.or.iabs(lb(i1)).eq.2)
4867      1        .and.(iabs(lb(i2)).eq.1.or.iabs(lb(i2)).eq.2)) then
4868             goto 108
4869          else
4870             return
4871          endif
4872       endif
4873 c
4874 *-----------------------------------------------------------------------
4875 *COM: TEST FOR ELASTIC SCATTERING (EITHER N-N OR DELTA-DELTA 0R
4876 *      N-DELTA OR N*-N* or N*-Delta)
4877 c      IF (X1 .LE. SIGNN/SIG) THEN
4878       IF (X1.LE.(SIGNN/SIG)) THEN
4879 *COM:  PARAMETRISATION IS TAKEN FROM THE CUGNON-PAPER
4880          AS  = ( 3.65 * (SRT - 1.8766) )**6
4881          A   = 6.0 * AS / (1.0 + AS)
4882          TA  = -2.0 * PR**2
4883          X   = RANART(NSEED)
4884 clin-10/24/02        T1  = DLOG( (1-X) * DEXP(dble(A)*dble(TA)) + X )  /  A
4885          T1  = sngl(DLOG(dble(1.-X)*DEXP(dble(A)*dble(TA))+dble(X)))/  A
4886          C1  = 1.0 - T1/TA
4887          T1  = 2.0 * PI * RANART(NSEED)
4888          IBLOCK=1
4889          GO TO 107
4890       ELSE
4891 *COM: TEST FOR INELASTIC SCATTERING
4892 *     IF THE AVAILABLE ENERGY IS LESS THAN THE PION-MASS, NOTHING
4893 *     CAN HAPPEN ANY MORE ==> RETURN (2.012 = 2*AVMASS + PI-MASS)
4894 clin-5/2008: Mdeuteron+Mpi=2.0106 to 2.0152 GeV/c2, so we can still use this:
4895          IF (SRT .LT. 2.012) RETURN
4896 *     calculate the N*(1535) production cross section in N+N collisions
4897 *     note that the cross sections in this subroutine are in units of mb
4898 *     as only ratios of the cross sections are used to determine the
4899 *     reaction channels
4900        call N1535(iabs(lb(i1)),iabs(lb(i2)),srt,x1535)
4901 *COM: HERE WE HAVE A PROCESS N+N ==> N+DELTA,OR N+N==>N+N*(144) or N*(1535)
4902 *     OR 
4903 * 3 pi channel : N+N==>d1+d2+PION
4904        SIG3=3.*(X3pi(SRT)+x33pi(srt))
4905 * 2 pi channel : N+N==>d1+d2+d1*n*+n*n*
4906        SIG4=4.*X2pi(srt)
4907 * 4 pi channel : N+N==>d1+d2+rho
4908        s4pi=x4pi(srt)
4909 * N+N-->NN+rho channel
4910        srho=xrho(srt)
4911 * N+N-->NN+omega
4912        somega=omega(srt)
4913 * CROSS SECTION FOR KAON PRODUCTION from the four channels
4914 * for NLK channel
4915        akp=0.498
4916        ak0=0.498
4917        ana=0.94
4918        ada=1.232
4919        al=1.1157
4920        as=1.1197
4921        xsk1=0
4922        xsk2=0
4923        xsk3=0
4924        xsk4=0
4925        xsk5=0
4926        t1nlk=ana+al+akp
4927        if(srt.le.t1nlk)go to 222
4928        XSK1=1.5*PPLPK(SRT)
4929 * for DLK channel
4930        t1dlk=ada+al+akp
4931        t2dlk=ada+al-akp
4932        if(srt.le.t1dlk)go to 222
4933        es=srt
4934        pmdlk2=(es**2-t1dlk**2)*(es**2-t2dlk**2)/(4.*es**2)
4935        pmdlk=sqrt(pmdlk2)
4936        XSK3=1.5*PPLPK(srt)
4937 * for NSK channel
4938        t1nsk=ana+as+akp
4939        t2nsk=ana+as-akp
4940        if(srt.le.t1nsk)go to 222
4941        pmnsk2=(es**2-t1nsk**2)*(es**2-t2nsk**2)/(4.*es**2)
4942        pmnsk=sqrt(pmnsk2)
4943        XSK2=1.5*(PPK1(srt)+PPK0(srt))
4944 * for DSK channel
4945        t1DSk=aDa+aS+akp
4946        t2DSk=aDa+aS-akp
4947        if(srt.le.t1dsk)go to 222
4948        pmDSk2=(es**2-t1DSk**2)*(es**2-t2DSk**2)/(4.*es**2)
4949        pmDSk=sqrt(pmDSk2)
4950        XSK4=1.5*(PPK1(srt)+PPK0(srt))
4951 csp11/21/01
4952 c phi production
4953        if(srt.le.(2.*amn+aphi))go to 222
4954 c  !! mb put the correct form
4955        xsk5 = 0.0001
4956 csp11/21/01 end
4957 c
4958 * THE TOTAL KAON+ PRODUCTION CROSS SECTION IS THEN
4959  222   SIGK=XSK1+XSK2+XSK3+XSK4
4960 
4961 cbz3/7/99 neutralk
4962         XSK1 = 2.0 * XSK1
4963         XSK2 = 2.0 * XSK2
4964         XSK3 = 2.0 * XSK3
4965         XSK4 = 2.0 * XSK4
4966         SIGK = 2.0 * SIGK + xsk5
4967 cbz3/7/99 neutralk end
4968 c
4969 ** FOR P+P or L/S+L/S COLLISION:
4970 c       lb1=lb(i1)
4971 c       lb2=lb(i2)
4972         lb1=iabs(lb(i1))
4973         lb2=iabs(lb(i2))
4974         IF((LB(I1)*LB(I2).EQ.1).or.
4975      &       ((lb1.le.17.and.lb1.ge.14).and.(lb2.le.17.and.lb2.ge.14)).
4976      &       or.((lb1.le.2).and.(lb2.le.17.and.lb2.ge.14)).
4977      &       or.((lb2.le.2).and.(lb1.le.17.and.lb1.ge.14)))THEN
4978 clin-8/2008 PP->d+meson here:
4979            IF(X1.LE.((SIGNN+sdprod)/SIG)) GO TO 108
4980            SIG1=SIGMA(SRT,1,1,0)+0.5*SIGMA(SRT,1,1,1)
4981            SIG2=1.5*SIGMA(SRT,1,1,1)
4982            SIGND=SIG1+SIG2+SIG3+SIG4+X1535+SIGK+s4pi+srho+somega
4983 clin-5/2008:
4984 c           IF (X1.GT.(SIGNN+SIGND)/SIG)RETURN
4985            IF (X1.GT.(SIGNN+SIGND+sdprod)/SIG)RETURN
4986            DIR=SIG3/SIGND
4987            IF(RANART(NSEED).LE.DIR)GO TO 106
4988            IF(RANART(NSEED).LE.SIGK/(SIGK+X1535+SIG4+SIG2+SIG1
4989      &          +s4pi+srho+somega))GO TO 306
4990            if(RANART(NSEED).le.s4pi/(x1535+sig4+sig2+sig1
4991      &          +s4pi+srho+somega))go to 307
4992            if(RANART(NSEED).le.srho/(x1535+sig4+sig2+sig1
4993      &          +srho+somega))go to 308
4994            if(RANART(NSEED).le.somega/(x1535+sig4+sig2+sig1
4995      &          +somega))go to 309
4996            if(RANART(NSEED).le.x1535/(sig1+sig2+sig4+x1535))then
4997 * N*(1535) production
4998               N12=9
4999            ELSE 
5000               IF(RANART(NSEED).LE.SIG4/(SIG1+sig2+sig4))THEN
5001 * DOUBLE DELTA PRODUCTION
5002                  N12=66
5003                  GO TO 1012
5004               else
5005 *DELTA PRODUCTION
5006                  N12=3
5007                  IF (RANART(NSEED).GT.SIG1/(SIG1+SIG2))N12=4
5008               ENDIF
5009            endif
5010            GO TO 1011
5011         ENDIF
5012 ** FOR N+N COLLISION:
5013         IF(iabs(LB(I1)).EQ.2.AND.iabs(LB(I2)).EQ.2)THEN
5014 clin-8/2008 NN->d+meson here:
5015            IF(X1.LE.((SIGNN+sdprod)/SIG)) GO TO 108
5016            SIG1=SIGMA(SRT,1,1,0)+0.5*SIGMA(SRT,1,1,1)
5017            SIG2=1.5*SIGMA(SRT,1,1,1)
5018            SIGND=SIG1+SIG2+X1535+SIG3+SIG4+SIGK+s4pi+srho+somega
5019 clin-5/2008:
5020 c           IF (X1.GT.(SIGNN+SIGND)/SIG)RETURN
5021            IF (X1.GT.(SIGNN+SIGND+sdprod)/SIG)RETURN
5022            dir=sig3/signd
5023            IF(RANART(NSEED).LE.DIR)GO TO 106
5024            IF(RANART(NSEED).LE.SIGK/(SIGK+X1535+SIG4+SIG2+SIG1
5025      &          +s4pi+srho+somega))GO TO 306
5026            if(RANART(NSEED).le.s4pi/(x1535+sig4+sig2+sig1
5027      &          +s4pi+srho+somega))go to 307
5028            if(RANART(NSEED).le.srho/(x1535+sig4+sig2+sig1
5029      &          +srho+somega))go to 308
5030            if(RANART(NSEED).le.somega/(x1535+sig4+sig2+sig1
5031      &          +somega))go to 309
5032            IF(RANART(NSEED).LE.X1535/(x1535+sig1+sig2+sig4))THEN
5033 * N*(1535) PRODUCTION
5034               N12=10
5035            ELSE 
5036               if(RANART(NSEED).le.sig4/(sig1+sig2+sig4))then
5037 * double delta production
5038                  N12=67
5039                  GO TO 1013
5040               else
5041 * DELTA PRODUCTION
5042                  N12=6
5043                  IF (RANART(NSEED).GT.SIG1/(SIG1+SIG2))N12=5
5044               ENDIF
5045            endif
5046            GO TO 1011
5047         ENDIF
5048 ** FOR N+P COLLISION
5049         IF(LB(I1)*LB(I2).EQ.2)THEN
5050 clin-5/2008 NP->d+meson here:
5051            IF(X1.LE.((SIGNN+sdprod)/SIG)) GO TO 108
5052            SIG1=0.5*SIGMA(SRT,1,1,1)+0.25*SIGMA(SRT,1,1,0)
5053            IF(NSTAR.EQ.1)THEN
5054               SIG2=(3./4.)*SIGMA(SRT,2,0,1)
5055            ELSE
5056               SIG2=0.
5057            ENDIF
5058            SIGND=2.*(SIG1+SIG2+X1535)+sig3+sig4+SIGK+s4pi+srho+somega
5059 clin-5/2008:
5060 c           IF (X1.GT.(SIGNN+SIGND)/SIG)RETURN
5061            IF (X1.GT.(SIGNN+SIGND+sdprod)/SIG)RETURN
5062            dir=sig3/signd
5063            IF(RANART(NSEED).LE.DIR)GO TO 106
5064            IF(RANART(NSEED).LE.SIGK/(SIGND-SIG3))GO TO 306
5065            if(RANART(NSEED).le.s4pi/(signd-sig3-sigk))go to 307
5066            if(RANART(NSEED).le.srho/(signd-sig3-sigk-s4pi))go to 308
5067            if(RANART(NSEED).le.somega/(signd-sig3-sigk-s4pi-srho))
5068      1          go to 309
5069            IF(RANART(NSEED).LT.X1535/(SIG1+SIG2+X1535+0.5*sig4))THEN
5070 * N*(1535) PRODUCTION
5071               N12=11
5072               IF(RANART(NSEED).LE.0.5)N12=12
5073            ELSE 
5074               if(RANART(NSEED).le.sig4/(sig4+2.*(sig1+sig2)))then
5075 * double resonance production
5076                  N12=68
5077                  GO TO 1014
5078               else
5079                  IF(RANART(NSEED).LE.SIG1/(SIG1+SIG2))THEN
5080 * DELTA PRODUCTION
5081                     N12=2
5082                     IF(RANART(NSEED).GE.0.5)N12=1
5083                  ELSE
5084 * N*(1440) PRODUCTION
5085                     N12=8
5086                     IF(RANART(NSEED).GE.0.5)N12=7
5087                  ENDIF
5088               ENDIF
5089            ENDIF
5090         endif
5091  1011   iblock=2
5092         CONTINUE
5093 *PARAMETRIZATION OF THE SHAPE OF THE DELTA RESONANCE ACCORDING
5094 *     TO kitazoe's or J.D.JACKSON'S MASS FORMULA AND BREIT WIGNER
5095 *     FORMULA FOR N* RESORANCE
5096 *     DETERMINE DELTA MASS VIA REJECTION METHOD.
5097           DMAX = SRT - AVMASS-0.005
5098           DMAX = SRT - AVMASS-0.005
5099           DMIN = 1.078
5100                    IF(N12.LT.7)THEN
5101 * Delta(1232) production
5102           IF(DMAX.LT.1.232) THEN
5103           FM=FDE(DMAX,SRT,0.)
5104           ELSE
5105 
5106 clin-10/25/02 get rid of argument usage mismatch in FDE():
5107              xdmass=1.232
5108 c          FM=FDE(1.232,SRT,1.)
5109           FM=FDE(xdmass,SRT,1.)
5110 clin-10/25/02-end
5111 
5112           ENDIF
5113           IF(FM.EQ.0.)FM=1.E-09
5114           NTRY1=0
5115 10        DM = RANART(NSEED) * (DMAX-DMIN) + DMIN
5116           NTRY1=NTRY1+1
5117           IF((RANART(NSEED) .GT. FDE(DM,SRT,1.)/FM).AND.
5118      1    (NTRY1.LE.30)) GOTO 10
5119 
5120 clin-2/26/03 limit the Delta mass below a certain value 
5121 c     (here taken as its central value + 2* B-W fullwidth):
5122           if(dm.gt.1.47) goto 10
5123 
5124               GO TO 13
5125               ENDIF
5126                    IF((n12.eq.7).or.(n12.eq.8))THEN
5127 * N*(1440) production
5128           IF(DMAX.LT.1.44) THEN
5129           FM=FNS(DMAX,SRT,0.)
5130           ELSE
5131 
5132 clin-10/25/02 get rid of argument usage mismatch in FNS():
5133              xdmass=1.44
5134 c          FM=FNS(1.44,SRT,1.)
5135           FM=FNS(xdmass,SRT,1.)
5136 clin-10/25/02-end
5137 
5138           ENDIF
5139           IF(FM.EQ.0.)FM=1.E-09
5140           NTRY2=0
5141 11        DM=RANART(NSEED)*(DMAX-DMIN)+DMIN
5142           NTRY2=NTRY2+1
5143           IF((RANART(NSEED).GT.FNS(DM,SRT,1.)/FM).AND.
5144      1    (NTRY2.LE.10)) GO TO 11
5145 
5146 clin-2/26/03 limit the N* mass below a certain value 
5147 c     (here taken as its central value + 2* B-W fullwidth):
5148           if(dm.gt.2.14) goto 11
5149 
5150               GO TO 13
5151               ENDIF
5152                     IF(n12.ge.17)then
5153 * N*(1535) production
5154           IF(DMAX.LT.1.535) THEN
5155           FM=FD5(DMAX,SRT,0.)
5156           ELSE
5157 
5158 clin-10/25/02 get rid of argument usage mismatch in FNS():
5159              xdmass=1.535
5160 c          FM=FD5(1.535,SRT,1.)
5161           FM=FD5(xdmass,SRT,1.)
5162 clin-10/25/02-end
5163 
5164           ENDIF
5165           IF(FM.EQ.0.)FM=1.E-09
5166           NTRY1=0
5167 12        DM = RANART(NSEED) * (DMAX-DMIN) + DMIN
5168           NTRY1=NTRY1+1
5169           IF((RANART(NSEED) .GT. FD5(DM,SRT,1.)/FM).AND.
5170      1    (NTRY1.LE.10)) GOTO 12
5171 
5172 clin-2/26/03 limit the N* mass below a certain value 
5173 c     (here taken as its central value + 2* B-W fullwidth):
5174           if(dm.gt.1.84) goto 12
5175 
5176          GO TO 13
5177              ENDIF
5178 * CALCULATE THE MASSES OF BARYON RESONANCES IN THE DOUBLE RESONANCE
5179 * PRODUCTION PROCESS AND RELABLE THE PARTICLES
5180 1012       iblock=43
5181        call Rmasdd(srt,1.232,1.232,1.08,
5182      &  1.08,ISEED,1,dm1,dm2)
5183        call Rmasdd(srt,1.232,1.44,1.08,
5184      &  1.08,ISEED,3,dm1n,dm2n)
5185        IF(N12.EQ.66)THEN
5186 *(1) PP-->DOUBLE RESONANCES
5187 * DETERMINE THE FINAL STATE
5188        XFINAL=RANART(NSEED)
5189        IF(XFINAL.LE.0.25)THEN
5190 * (1.1) D+++D0 
5191        LB(I1)=9
5192        LB(I2)=7
5193        e(i1)=dm1
5194        e(i2)=dm2
5195        GO TO 200
5196 * go to 200 to set the new momentum
5197        ENDIF
5198        IF((XFINAL.gt.0.25).and.(xfinal.le.0.5))THEN
5199 * (1.2) D++D+
5200        LB(I1)=8
5201        LB(I2)=8
5202        e(i1)=dm1
5203        e(i2)=dm2
5204        GO TO 200
5205 * go to 200 to set the new momentum
5206        ENDIF
5207        IF((XFINAL.gt.0.5).and.(xfinal.le.0.75))THEN
5208 * (1.3) D+++N*0 
5209        LB(I1)=9
5210        LB(I2)=10
5211        e(i1)=dm1n
5212        e(i2)=dm2n
5213        GO TO 200
5214 * go to 200 to set the new momentum
5215        ENDIF
5216        IF(XFINAL.gt.0.75)then
5217 * (1.4) D++N*+ 
5218        LB(I1)=8
5219        LB(I2)=11
5220        e(i1)=dm1n
5221        e(i2)=dm2n
5222        GO TO 200
5223 * go to 200 to set the new momentum
5224        ENDIF
5225        ENDIF
5226 1013       iblock=43
5227        call Rmasdd(srt,1.232,1.232,1.08,
5228      &  1.08,ISEED,1,dm1,dm2)
5229        call Rmasdd(srt,1.232,1.44,1.08,
5230      &  1.08,ISEED,3,dm1n,dm2n)
5231        IF(N12.EQ.67)THEN
5232 *(2) NN-->DOUBLE RESONANCES
5233 * DETERMINE THE FINAL STATE
5234        XFINAL=RANART(NSEED)
5235        IF(XFINAL.LE.0.25)THEN
5236 * (2.1) D0+D0 
5237        LB(I1)=7
5238        LB(I2)=7
5239        e(i1)=dm1
5240        e(i2)=dm2
5241        GO TO 200
5242 * go to 200 to set the new momentum
5243         ENDIF
5244        IF((XFINAL.gt.0.25).and.(xfinal.le.0.5))THEN
5245 * (2.2) D++D+
5246        LB(I1)=6
5247        LB(I2)=8
5248        e(i1)=dm1
5249        e(i2)=dm2
5250        GO TO 200
5251 * go to 200 to set the new momentum
5252        ENDIF
5253        IF((XFINAL.gt.0.5).and.(xfinal.le.0.75))THEN
5254 * (2.3) D0+N*0 
5255        LB(I1)=7
5256        LB(I2)=10
5257        e(i1)=dm1n
5258        e(i2)=dm2n
5259        GO TO 200
5260 * go to 200 to set the new momentum
5261        ENDIF
5262        IF(XFINAL.gt.0.75)then
5263 * (2.4) D++N*+ 
5264        LB(I1)=8
5265        LB(I2)=11
5266        e(i1)=dm1n
5267        e(i2)=dm2n
5268        GO TO 200
5269 * go to 200 to set the new momentum
5270        ENDIF
5271        ENDIF
5272 1014       iblock=43
5273        call Rmasdd(srt,1.232,1.232,1.08,
5274      &  1.08,ISEED,1,dm1,dm2)
5275        call Rmasdd(srt,1.232,1.44,1.08,
5276      &  1.08,ISEED,3,dm1n,dm2n)
5277        IF(N12.EQ.68)THEN
5278 *(3) NP-->DOUBLE RESONANCES
5279 * DETERMINE THE FINAL STATE
5280        XFINAL=RANART(NSEED)
5281        IF(XFINAL.LE.0.25)THEN
5282 * (3.1) D0+D+ 
5283        LB(I1)=7
5284        LB(I2)=8
5285        e(i1)=dm1
5286        e(i2)=dm2
5287        GO TO 200
5288 * go to 200 to set the new momentum
5289        ENDIF
5290        IF((XFINAL.gt.0.25).and.(xfinal.le.0.5))THEN
5291 * (3.2) D+++D-
5292        LB(I1)=9
5293        LB(I2)=6
5294        e(i1)=dm1
5295        e(i2)=dm2
5296        GO TO 200
5297 * go to 200 to set the new momentum
5298        ENDIF
5299        IF((XFINAL.gt.0.5).and.(xfinal.le.0.75))THEN
5300 * (3.3) D0+N*+ 
5301        LB(I1)=7
5302        LB(I2)=11
5303        e(i1)=dm1n
5304        e(i2)=dm2n
5305        GO TO 200
5306 * go to 200 to set the new momentum
5307        ENDIF
5308        IF(XFINAL.gt.0.75)then
5309 * (3.4) D++N*0
5310        LB(I1)=8
5311        LB(I2)=10
5312        e(i1)=dm1n
5313        e(i2)=dm2n
5314        GO TO 200
5315 * go to 200 to set the new momentum
5316        ENDIF
5317        ENDIF
5318 13       CONTINUE
5319 *-------------------------------------------------------
5320 * RELABLE BARYON I1 AND I2
5321 *1. p+n-->delta(+)+n
5322           IF(N12.EQ.1)THEN
5323           IF(iabs(LB(I1)).EQ.1)THEN
5324           LB(I2)=2
5325           LB(I1)=8
5326           E(I1)=DM
5327           ELSE
5328           LB(I1)=2
5329           LB(I2)=8
5330           E(I2)=DM
5331           ENDIF
5332          GO TO 200
5333           ENDIF
5334 *2 p+n-->delta(0)+p
5335           IF(N12.EQ.2)THEN
5336           IF(iabs(LB(I1)).EQ.2)THEN
5337           LB(I2)=1
5338           LB(I1)=7
5339           E(I1)=DM
5340           ELSE
5341           LB(I1)=1
5342           LB(I2)=7
5343           E(I2)=DM
5344           ENDIF
5345          GO TO 200
5346           ENDIF
5347 *3 p+p-->delta(++)+n
5348           IF(N12.EQ.3)THEN
5349           LB(I1)=9
5350           E(I1)=DM
5351           LB(I2)=2
5352           E(I2)=AMN
5353          GO TO 200
5354           ENDIF
5355 *4 p+p-->delta(+)+p
5356           IF(N12.EQ.4)THEN
5357           LB(I2)=1
5358           LB(I1)=8
5359           E(I1)=DM
5360          GO TO 200
5361           ENDIF
5362 *5 n+n--> delta(0)+n
5363           IF(N12.EQ.5)THEN
5364           LB(I2)=2
5365           LB(I1)=7
5366           E(I1)=DM
5367          GO TO 200
5368           ENDIF
5369 *6 n+n--> delta(-)+p
5370           IF(N12.EQ.6)THEN
5371           LB(I1)=6
5372           E(I1)=DM
5373           LB(I2)=1
5374           E(I2)=AMP
5375          GO TO 200
5376           ENDIF
5377 *7 n+p--> N*(0)+p
5378           IF(N12.EQ.7)THEN
5379           IF(iabs(LB(I1)).EQ.1)THEN
5380           LB(I1)=1
5381           LB(I2)=10
5382           E(I2)=DM
5383           ELSE
5384           LB(I2)=1
5385           LB(I1)=10
5386           E(I1)=DM
5387           ENDIF
5388          GO TO 200
5389           ENDIF
5390 *8 n+p--> N*(+)+n
5391           IF(N12.EQ.8)THEN
5392           IF(iabs(LB(I1)).EQ.1)THEN
5393           LB(I2)=2
5394           LB(I1)=11
5395           E(I1)=DM
5396           ELSE
5397           LB(I1)=2
5398           LB(I2)=11
5399           E(I2)=DM
5400           ENDIF
5401          GO TO 200
5402           ENDIF
5403 *9 p+p--> N*(+)(1535)+p
5404           IF(N12.EQ.9)THEN
5405           IF(RANART(NSEED).le.0.5)THEN
5406           LB(I2)=1
5407           LB(I1)=13
5408           E(I1)=DM
5409           ELSE
5410           LB(I1)=1
5411           LB(I2)=13
5412           E(I2)=DM
5413           ENDIF
5414          GO TO 200
5415           ENDIF
5416 *10 n+n--> N*(0)(1535)+n
5417           IF(N12.EQ.10)THEN
5418           IF(RANART(NSEED).le.0.5)THEN
5419           LB(I2)=2
5420           LB(I1)=12
5421           E(I1)=DM
5422           ELSE
5423           LB(I1)=2
5424           LB(I2)=12
5425           E(I2)=DM
5426           ENDIF
5427          GO TO 200
5428           ENDIF
5429 *11 n+p--> N*(+)(1535)+n
5430           IF(N12.EQ.11)THEN
5431           IF(iabs(LB(I1)).EQ.2)THEN
5432           LB(I1)=2
5433           LB(I2)=13
5434           E(I2)=DM
5435           ELSE
5436           LB(I2)=2
5437           LB(I1)=13
5438           E(I1)=DM
5439           ENDIF
5440          GO TO 200
5441           ENDIF
5442 *12 n+p--> N*(0)(1535)+p
5443           IF(N12.EQ.12)THEN
5444           IF(iabs(LB(I1)).EQ.1)THEN
5445           LB(I1)=1
5446           LB(I2)=12
5447           E(I2)=DM
5448           ELSE
5449           LB(I2)=1
5450           LB(I1)=12
5451           E(I1)=DM
5452           ENDIF
5453           ENDIF
5454          endif
5455 * CALCULATE THE MAGNITUDE OF THE FINAL MOMENTUM THROUGH
5456 * ENERGY CONSERVATION
5457 200       EM1=E(I1)
5458           EM2=E(I2)
5459           PR2   = (SRT**2 - EM1**2 - EM2**2)**2
5460      1                - 4.0 * (EM1*EM2)**2
5461           IF(PR2.LE.0.)PR2=1.e-09
5462           PR=SQRT(PR2)/(2.*SRT)
5463               if(srt.le.2.14)C1= 1.0 - 2.0 * RANART(NSEED)
5464          if(srt.gt.2.14.and.srt.le.2.4)c1=ang(srt,iseed)
5465          if(srt.gt.2.4)then
5466 
5467 clin-10/25/02 get rid of argument usage mismatch in PTR():
5468              xptr=0.33*pr
5469 c         cc1=ptr(0.33*pr,iseed)
5470              cc1=ptr(xptr,iseed)
5471 clin-10/25/02-end
5472 
5473 clin-9/2012: check argument in sqrt():
5474              scheck=pr**2-cc1**2
5475              if(scheck.lt.0) then
5476                 write(99,*) 'scheck2: ', scheck
5477                 scheck=0.
5478              endif
5479              c1=sqrt(scheck)/pr
5480 c             c1=sqrt(pr**2-cc1**2)/pr
5481 
5482          endif
5483           T1   = 2.0 * PI * RANART(NSEED)
5484        if(ianti.eq.1 .and. lb(i1).ge.1 .and. lb(i2).ge.1)then
5485          lb(i1) = -lb(i1)
5486          lb(i2) = -lb(i2)
5487        endif
5488           GO TO 107
5489 *FOR THE NN-->D1+D2+PI PROCESS, FIND MOMENTUM OF THE FINAL TWO
5490 *DELTAS AND PION IN THE NUCLEUS-NUCLEUS CMS.
5491 106     CONTINUE
5492            NTRY1=0
5493 123        CALL DDP2(SRT,ISEED,PX3,PY3,PZ3,DM3,PX4,PY4,PZ4,DM4,
5494      &  PPX,PPY,PPZ,icou1)
5495        NTRY1=NTRY1+1
5496        if((icou1.lt.0).AND.(NTRY1.LE.40))GO TO 123
5497 C       if(icou1.lt.0)return
5498 * ROTATE THE MOMENTA OF PARTICLES IN THE CMS OF P1+P2
5499        CALL ROTATE(PX,PY,PZ,PX3,PY3,PZ3)
5500        CALL ROTATE(PX,PY,PZ,PX4,PY4,PZ4)
5501        CALL ROTATE(PX,PY,PZ,PPX,PPY,PPZ)
5502                 NNN=NNN+1
5503 * DETERMINE THE CHARGE STATES OF PARTICLES IN THE FINAL STATE
5504 * (1) FOR P+P
5505               XDIR=RANART(NSEED)
5506                 IF(LB(I1)*LB(I2).EQ.1)THEN
5507                 IF(XDIR.Le.0.2)then
5508 * (1.1)P+P-->D+++D0+PION(0)
5509                 LPION(NNN,IRUN)=4
5510                 EPION(NNN,IRUN)=AP1
5511               LB(I1)=9
5512               LB(I2)=7
5513        GO TO 205
5514                 ENDIF
5515 * (1.2)P+P -->D++D+PION(0)
5516                 IF((XDIR.LE.0.4).AND.(XDIR.GT.0.2))THEN
5517                 LPION(NNN,IRUN)=4
5518                 EPION(NNN,IRUN)=AP1
5519                 LB(I1)=8
5520                 LB(I2)=8
5521        GO TO 205
5522               ENDIF 
5523 * (1.3)P+P-->D+++D+PION(-)
5524                 IF((XDIR.LE.0.6).AND.(XDIR.GT.0.4))THEN
5525                 LPION(NNN,IRUN)=3
5526                 EPION(NNN,IRUN)=AP2
5527                 LB(I1)=9
5528                 LB(I2)=8
5529        GO TO 205
5530               ENDIF 
5531                 IF((XDIR.LE.0.8).AND.(XDIR.GT.0.6))THEN
5532                 LPION(NNN,IRUN)=5
5533                 EPION(NNN,IRUN)=AP2
5534                 LB(I1)=9
5535                 LB(I2)=6
5536        GO TO 205
5537               ENDIF 
5538                 IF(XDIR.GT.0.8)THEN
5539                 LPION(NNN,IRUN)=5
5540                 EPION(NNN,IRUN)=AP2
5541                 LB(I1)=7
5542                 LB(I2)=8
5543        GO TO 205
5544               ENDIF 
5545                ENDIF
5546 * (2)FOR N+N
5547                 IF(iabs(LB(I1)).EQ.2.AND.iabs(LB(I2)).EQ.2)THEN
5548                 IF(XDIR.Le.0.2)then
5549 * (2.1)N+N-->D++D-+PION(0)
5550                 LPION(NNN,IRUN)=4
5551                 EPION(NNN,IRUN)=AP1
5552               LB(I1)=6
5553               LB(I2)=7
5554        GO TO 205
5555                 ENDIF
5556 * (2.2)N+N -->D+++D-+PION(-)
5557                 IF((XDIR.LE.0.4).AND.(XDIR.GT.0.2))THEN
5558                 LPION(NNN,IRUN)=3
5559                 EPION(NNN,IRUN)=AP2
5560                 LB(I1)=6
5561                 LB(I2)=9
5562        GO TO 205
5563               ENDIF 
5564 * (2.3)P+P-->D0+D-+PION(+)
5565                 IF((XDIR.GT.0.4).AND.(XDIR.LE.0.6))THEN
5566                 LPION(NNN,IRUN)=5
5567                 EPION(NNN,IRUN)=AP2
5568                 LB(I1)=9
5569                 LB(I2)=8
5570        GO TO 205
5571               ENDIF 
5572 * (2.4)P+P-->D0+D0+PION(0)
5573                 IF((XDIR.GT.0.6).AND.(XDIR.LE.0.8))THEN
5574                 LPION(NNN,IRUN)=4
5575                 EPION(NNN,IRUN)=AP1
5576                 LB(I1)=7
5577                 LB(I2)=7
5578        GO TO 205
5579               ENDIF 
5580 * (2.5)P+P-->D0+D++PION(-)
5581                 IF(XDIR.GT.0.8)THEN
5582                 LPION(NNN,IRUN)=3
5583                 EPION(NNN,IRUN)=AP2
5584                 LB(I1)=7
5585                 LB(I2)=8
5586        GO TO 205
5587               ENDIF 
5588               ENDIF
5589 * (3)FOR N+P
5590                 IF(LB(I1)*LB(I2).EQ.2)THEN
5591                 IF(XDIR.Le.0.17)then
5592 * (3.1)N+P-->D+++D-+PION(0)
5593                 LPION(NNN,IRUN)=4
5594                 EPION(NNN,IRUN)=AP1
5595               LB(I1)=6
5596               LB(I2)=9
5597        GO TO 205
5598                 ENDIF
5599 * (3.2)N+P -->D+++D0+PION(-)
5600                 IF((XDIR.LE.0.34).AND.(XDIR.GT.0.17))THEN
5601                 LPION(NNN,IRUN)=3
5602                 EPION(NNN,IRUN)=AP2
5603                 LB(I1)=7
5604                 LB(I2)=9
5605        GO TO 205
5606               ENDIF 
5607 * (3.3)N+P-->D++D-+PION(+)
5608                 IF((XDIR.GT.0.34).AND.(XDIR.LE.0.51))THEN
5609                 LPION(NNN,IRUN)=5
5610                 EPION(NNN,IRUN)=AP2
5611                 LB(I1)=7
5612                 LB(I2)=8
5613        GO TO 205
5614               ENDIF 
5615 * (3.4)N+P-->D++D++PION(-)
5616                 IF((XDIR.GT.0.51).AND.(XDIR.LE.0.68))THEN
5617                 LPION(NNN,IRUN)=3
5618                 EPION(NNN,IRUN)=AP2
5619                 LB(I1)=8
5620                 LB(I2)=8
5621        GO TO 205
5622               ENDIF 
5623 * (3.5)N+P-->D0+D++PION(0)
5624                 IF((XDIR.GT.0.68).AND.(XDIR.LE.0.85))THEN
5625                 LPION(NNN,IRUN)=4
5626                 EPION(NNN,IRUN)=AP2
5627                 LB(I1)=7
5628                 LB(I2)=8
5629        GO TO 205
5630               ENDIF 
5631 * (3.6)N+P-->D0+D0+PION(+)
5632                 IF(XDIR.GT.0.85)THEN
5633                 LPION(NNN,IRUN)=5
5634                 EPION(NNN,IRUN)=AP2
5635                 LB(I1)=7
5636                 LB(I2)=7
5637               ENDIF 
5638                 ENDIF
5639 * FIND THE MOMENTUM OF PARTICLES IN THE FINAL STATE IN THE NUCLEUS-
5640 * NUCLEUS CMS. FRAME 
5641 *             LORENTZ-TRANSFORMATION INTO LAB FRAME FOR DELTA1
5642 205           E1CM    = SQRT (dm3**2 + PX3**2 + PY3**2 + PZ3**2)
5643               P1BETA  = PX3*BETAX + PY3*BETAY + PZ3*BETAZ
5644               TRANSF  = GAMMA * ( GAMMA * P1BETA / (GAMMA + 1) + E1CM )
5645               Pt1i1 = BETAX * TRANSF + PX3
5646               Pt2i1 = BETAY * TRANSF + PY3
5647               Pt3i1 = BETAZ * TRANSF + PZ3
5648              Eti1   = DM3
5649 c
5650              if(ianti.eq.1 .and. lb(i1).ge.1 .and. lb(i2).ge.1)then
5651                lb(i1) = -lb(i1)
5652                lb(i2) = -lb(i2)
5653                 if(LPION(NNN,IRUN) .eq. 3)then
5654                   LPION(NNN,IRUN)=5
5655                 elseif(LPION(NNN,IRUN) .eq. 5)then
5656                   LPION(NNN,IRUN)=3
5657                 endif
5658                endif
5659 c
5660              lb1=lb(i1)
5661 * FOR DELTA2
5662                 E2CM    = SQRT (dm4**2 + PX4**2 + PY4**2 + PZ4**2)
5663                 P2BETA  = PX4*BETAX+PY4*BETAY+PZ4*BETAZ
5664                 TRANSF  = GAMMA * (GAMMA*P2BETA / (GAMMA + 1.) + E2CM)
5665                 Pt1I2 = BETAX * TRANSF + PX4
5666                 Pt2I2 = BETAY * TRANSF + PY4
5667                 Pt3I2 = BETAZ * TRANSF + PZ4
5668               EtI2   = DM4
5669               lb2=lb(i2)
5670 * assign delta1 and delta2 to i1 or i2 to keep the leadng particle
5671 * behaviour
5672 C              if((pt1i1*px1+pt2i1*py1+pt3i1*pz1).gt.0)then
5673               p(1,i1)=pt1i1
5674               p(2,i1)=pt2i1
5675               p(3,i1)=pt3i1
5676               e(i1)=eti1
5677               lb(i1)=lb1
5678               p(1,i2)=pt1i2
5679               p(2,i2)=pt2i2
5680               p(3,i2)=pt3i2
5681               e(i2)=eti2
5682               lb(i2)=lb2
5683                 PX1     = P(1,I1)
5684                 PY1     = P(2,I1)
5685                 PZ1     = P(3,I1)
5686               EM1       = E(I1)
5687                 ID(I1)  = 2
5688                 ID(I2)  = 2
5689                 ID1     = ID(I1)
5690                 IBLOCK=4
5691 * GET PION'S MOMENTUM AND COORDINATES IN NUCLEUS-NUCLEUS CMS. FRAME
5692                 EPCM=SQRT(EPION(NNN,IRUN)**2+PPX**2+PPY**2+PPZ**2)
5693                 PPBETA=PPX*BETAX+PPY*BETAY+PPZ*BETAZ
5694                 TRANSF=GAMMA*(GAMMA*PPBETA/(GAMMA+1.)+EPCM)
5695                 PPION(1,NNN,IRUN)=BETAX*TRANSF+PPX
5696                 PPION(2,NNN,IRUN)=BETAY*TRANSF+PPY
5697                 PPION(3,NNN,IRUN)=BETAZ*TRANSF+PPZ
5698 clin-5/2008:
5699                 dppion(nnn,irun)=dpertp(i1)*dpertp(i2)
5700 clin-5/2008 do not allow smearing in position of produced particles 
5701 c     to avoid immediate reinteraction with the particle I1, I2 or themselves:
5702 c2002        X01 = 1.0 - 2.0 * RANART(NSEED)
5703 c            Y01 = 1.0 - 2.0 * RANART(NSEED)
5704 c            Z01 = 1.0 - 2.0 * RANART(NSEED)
5705 c        IF ((X01*X01+Y01*Y01+Z01*Z01) .GT. 1.0) GOTO 2002
5706 c                RPION(1,NNN,IRUN)=R(1,I1)+0.5*x01
5707 c                RPION(2,NNN,IRUN)=R(2,I1)+0.5*y01
5708 c                RPION(3,NNN,IRUN)=R(3,I1)+0.5*z01
5709                 RPION(1,NNN,IRUN)=R(1,I1)
5710                 RPION(2,NNN,IRUN)=R(2,I1)
5711                 RPION(3,NNN,IRUN)=R(3,I1)
5712 c
5713               go to 90005
5714 clin-5/2008 N+N->Deuteron+pi:
5715 *     FIND MOMENTUM OF THE FINAL PARTICLES IN THE NUCLEUS-NUCLEUS CMS.
5716  108       CONTINUE
5717            if(idpert.eq.1.and.ipert1.eq.1.and.npertd.ge.1) then
5718 c     For idpert=1: we produce npertd pert deuterons:
5719               ndloop=npertd
5720            elseif(idpert.eq.2.and.npertd.ge.1) then
5721 c     For idpert=2: we first save information for npertd pert deuterons;
5722 c     at the last ndloop we create the regular deuteron+pi 
5723 c     and those pert deuterons:
5724               ndloop=npertd+1
5725            else
5726 c     Just create the regular deuteron+pi:
5727               ndloop=1
5728            endif
5729 c
5730            dprob1=sdprod/sig/float(npertd)
5731            do idloop=1,ndloop
5732               CALL bbdangle(pxd,pyd,pzd,nt,ipert1,ianti,idloop,pfinal,
5733      1 dprob1,lbm)
5734               CALL ROTATE(PX,PY,PZ,PXd,PYd,PZd)
5735 *     LORENTZ-TRANSFORMATION OF THE MOMENTUM OF PARTICLES IN THE FINAL STATE 
5736 *     FROM THE NN CMS FRAME INTO THE GLOBAL CMS FRAME:
5737 *     For the Deuteron:
5738               xmass=xmd
5739               E1dCM=SQRT(xmass**2+PXd**2+PYd**2+PZd**2)
5740               P1dBETA=PXd*BETAX+PYd*BETAY+PZd*BETAZ
5741               TRANSF=GAMMA*(GAMMA*P1dBETA/(GAMMA+1.)+E1dCM)
5742               pxi1=BETAX*TRANSF+PXd
5743               pyi1=BETAY*TRANSF+PYd
5744               pzi1=BETAZ*TRANSF+PZd
5745               if(ianti.eq.0)then
5746                  lbd=42
5747               else
5748                  lbd=-42
5749               endif
5750               if(idpert.eq.1.and.ipert1.eq.1.and.npertd.ge.1) then
5751 cccc  Perturbative production for idpert=1:
5752                  nnn=nnn+1
5753                  PPION(1,NNN,IRUN)=pxi1
5754                  PPION(2,NNN,IRUN)=pyi1
5755                  PPION(3,NNN,IRUN)=pzi1
5756                  EPION(NNN,IRUN)=xmd
5757                  LPION(NNN,IRUN)=lbd
5758                  RPION(1,NNN,IRUN)=R(1,I1)
5759                  RPION(2,NNN,IRUN)=R(2,I1)
5760                  RPION(3,NNN,IRUN)=R(3,I1)
5761 clin-5/2008 assign the perturbative probability:
5762                  dppion(NNN,IRUN)=sdprod/sig/float(npertd)
5763               elseif(idpert.eq.2.and.idloop.le.npertd) then
5764 clin-5/2008 For idpert=2, we produce NPERTD perturbative (anti)deuterons 
5765 c     only when a regular (anti)deuteron+pi is produced in NN collisions.
5766 c     First save the info for the perturbative deuterons:
5767                  ppd(1,idloop)=pxi1
5768                  ppd(2,idloop)=pyi1
5769                  ppd(3,idloop)=pzi1
5770                  lbpd(idloop)=lbd
5771               else
5772 cccc  Regular production:
5773 c     For the regular pion: do LORENTZ-TRANSFORMATION:
5774                  E(i1)=xmm
5775                  E2piCM=SQRT(xmm**2+PXd**2+PYd**2+PZd**2)
5776                  P2piBETA=-PXd*BETAX-PYd*BETAY-PZd*BETAZ
5777                  TRANSF=GAMMA*(GAMMA*P2piBETA/(GAMMA+1.)+E2piCM)
5778                  pxi2=BETAX*TRANSF-PXd
5779                  pyi2=BETAY*TRANSF-PYd
5780                  pzi2=BETAZ*TRANSF-PZd
5781                  p(1,i1)=pxi2
5782                  p(2,i1)=pyi2
5783                  p(3,i1)=pzi2
5784 c     Remove regular pion to check the equivalence 
5785 c     between the perturbative and regular deuteron results:
5786 c                 E(i1)=0.
5787 c
5788                  LB(I1)=lbm
5789                  PX1=P(1,I1)
5790                  PY1=P(2,I1)
5791                  PZ1=P(3,I1)
5792                  EM1=E(I1)
5793                  ID(I1)=2
5794                  ID1=ID(I1)
5795                  E1=SQRT(EM1**2+PX1**2+PY1**2+PZ1**2)
5796                  lb1=lb(i1)
5797 c     For the regular deuteron:
5798                  p(1,i2)=pxi1
5799                  p(2,i2)=pyi1
5800                  p(3,i2)=pzi1
5801                  lb(i2)=lbd
5802                  lb2=lb(i2)
5803                  E(i2)=xmd
5804                  EtI2=E(I2)
5805                  ID(I2)=2
5806 c     For idpert=2: create the perturbative deuterons:
5807                  if(idpert.eq.2.and.idloop.eq.ndloop) then
5808                     do ipertd=1,npertd
5809                        nnn=nnn+1
5810                        PPION(1,NNN,IRUN)=ppd(1,ipertd)
5811                        PPION(2,NNN,IRUN)=ppd(2,ipertd)
5812                        PPION(3,NNN,IRUN)=ppd(3,ipertd)
5813                        EPION(NNN,IRUN)=xmd
5814                        LPION(NNN,IRUN)=lbpd(ipertd)
5815                        RPION(1,NNN,IRUN)=R(1,I1)
5816                        RPION(2,NNN,IRUN)=R(2,I1)
5817                        RPION(3,NNN,IRUN)=R(3,I1)
5818 clin-5/2008 assign the perturbative probability:
5819                        dppion(NNN,IRUN)=1./float(npertd)
5820                     enddo
5821                  endif
5822               endif
5823            enddo
5824            IBLOCK=501
5825            go to 90005
5826 clin-5/2008 N+N->Deuteron+pi over
5827 * FOR THE NN-->KAON+X PROCESS, FIND MOMENTUM OF THE FINAL PARTICLES IN 
5828 * THE NUCLEUS-NUCLEUS CMS.
5829 306     CONTINUE
5830 csp11/21/01 phi production
5831               if(XSK5/sigK.gt.RANART(NSEED))then
5832               pz1=p(3,i1)
5833               pz2=p(3,i2)
5834                 LB(I1) = 1 + int(2 * RANART(NSEED))
5835                 LB(I2) = 1 + int(2 * RANART(NSEED))
5836               nnn=nnn+1
5837                 LPION(NNN,IRUN)=29
5838                 EPION(NNN,IRUN)=APHI
5839                 iblock = 222
5840               GO TO 208
5841                ENDIF
5842 c
5843                  IBLOCK=9
5844                  if(ianti .eq. 1)iblock=-9
5845 c
5846               pz1=p(3,i1)
5847               pz2=p(3,i2)
5848 * DETERMINE THE CHARGE STATES OF PARTICLES IN THE FINAL STATE
5849               nnn=nnn+1
5850                 LPION(NNN,IRUN)=23
5851                 EPION(NNN,IRUN)=Aka
5852               if(srt.le.2.63)then
5853 * only lambda production is possible
5854 * (1.1)P+P-->p+L+kaon+
5855               ic=1
5856                 LB(I1) = 1 + int(2 * RANART(NSEED))
5857               LB(I2)=14
5858               GO TO 208
5859                 ENDIF
5860        if(srt.le.2.74.and.srt.gt.2.63)then
5861 * both Lambda and sigma production are possible
5862               if(XSK1/(XSK1+XSK2).gt.RANART(NSEED))then
5863 * lambda production
5864               ic=1
5865                 LB(I1) = 1 + int(2 * RANART(NSEED))
5866               LB(I2)=14
5867               else
5868 * sigma production
5869                 LB(I1) = 1 + int(2 * RANART(NSEED))
5870                 LB(I2) = 15 + int(3 * RANART(NSEED))
5871               ic=2
5872               endif
5873               GO TO 208
5874        endif
5875        if(srt.le.2.77.and.srt.gt.2.74)then
5876 * then pp-->Delta lamda kaon can happen
5877               if(xsk1/(xsk1+xsk2+xsk3).
5878      1          gt.RANART(NSEED))then
5879 * * (1.1)P+P-->p+L+kaon+
5880               ic=1
5881                 LB(I1) = 1 + int(2 * RANART(NSEED))
5882               LB(I2)=14
5883               go to 208
5884               else
5885               if(xsk2/(xsk2+xsk3).gt.RANART(NSEED))then
5886 * pp-->psk
5887               ic=2
5888                 LB(I1) = 1 + int(2 * RANART(NSEED))
5889                 LB(I2) = 15 + int(3 * RANART(NSEED))
5890               else
5891 * pp-->D+l+k        
5892               ic=3
5893                 LB(I1) = 6 + int(4 * RANART(NSEED))
5894               lb(i2)=14
5895               endif
5896               GO TO 208
5897               endif
5898        endif
5899        if(srt.gt.2.77)then
5900 * all four channels are possible
5901               if(xsk1/(xsk1+xsk2+xsk3+xsk4).gt.RANART(NSEED))then
5902 * p lambda k production
5903               ic=1
5904                 LB(I1) = 1 + int(2 * RANART(NSEED))
5905               LB(I2)=14
5906               go to 208
5907        else
5908           if(xsk3/(xsk2+xsk3+xsk4).gt.RANART(NSEED))then
5909 * delta l K production
5910               ic=3
5911                 LB(I1) = 6 + int(4 * RANART(NSEED))
5912               lb(i2)=14
5913               go to 208
5914           else
5915               if(xsk2/(xsk2+xsk4).gt.RANART(NSEED))then
5916 * n sigma k production
5917                    LB(I1) = 1 + int(2 * RANART(NSEED))
5918                    LB(I2) = 15 + int(3 * RANART(NSEED))
5919               ic=2
5920               else
5921               ic=4
5922                 LB(I1) = 6 + int(4 * RANART(NSEED))
5923                 LB(I2) = 15 + int(3 * RANART(NSEED))
5924               endif
5925               go to 208
5926           endif
5927        endif
5928        endif
5929 208             continue
5930          if(ianti.eq.1 .and. lb(i1).ge.1 .and. lb(i2).ge.1)then
5931           lb(i1) = - lb(i1)
5932           lb(i2) = - lb(i2)
5933           if(LPION(NNN,IRUN) .eq. 23)LPION(NNN,IRUN)=21
5934          endif
5935 * KEEP ALL COORDINATES OF PARTICLE 2 FOR POSSIBLE PHASE SPACE CHANGE
5936            NTRY1=0
5937 127        CALL BBKAON(ic,SRT,PX3,PY3,PZ3,DM3,PX4,PY4,PZ4,DM4,
5938      &  PPX,PPY,PPZ,icou1)
5939        NTRY1=NTRY1+1
5940        if((icou1.lt.0).AND.(NTRY1.LE.20))GO TO 127
5941 c       if(icou1.lt.0)return
5942 * ROTATE THE MOMENTA OF PARTICLES IN THE CMS OF P1+P2
5943        CALL ROTATE(PX,PY,PZ,PX3,PY3,PZ3)
5944        CALL ROTATE(PX,PY,PZ,PX4,PY4,PZ4)
5945        CALL ROTATE(PX,PY,PZ,PPX,PPY,PPZ)
5946 * FIND THE MOMENTUM OF PARTICLES IN THE FINAL STATE IN THE NUCLEUS-
5947 * NUCLEUS CMS. FRAME 
5948 * (1) for the necleon/delta
5949 *             LORENTZ-TRANSFORMATION INTO LAB FRAME FOR DELTA1
5950               E1CM    = SQRT (dm3**2 + PX3**2 + PY3**2 + PZ3**2)
5951               P1BETA  = PX3*BETAX + PY3*BETAY + PZ3*BETAZ
5952               TRANSF  = GAMMA * ( GAMMA * P1BETA / (GAMMA + 1) + E1CM )
5953               Pt1i1 = BETAX * TRANSF + PX3
5954               Pt2i1 = BETAY * TRANSF + PY3
5955               Pt3i1 = BETAZ * TRANSF + PZ3
5956              Eti1   = DM3
5957              lbi1=lb(i1)
5958 * (2) for the lambda/sigma
5959                 E2CM    = SQRT (dm4**2 + PX4**2 + PY4**2 + PZ4**2)
5960                 P2BETA  = PX4*BETAX+PY4*BETAY+PZ4*BETAZ
5961                 TRANSF  = GAMMA * (GAMMA*P2BETA / (GAMMA + 1.) + E2CM)
5962                 Pt1I2 = BETAX * TRANSF + PX4
5963                 Pt2I2 = BETAY * TRANSF + PY4
5964                 Pt3I2 = BETAZ * TRANSF + PZ4
5965               EtI2   = DM4
5966               lbi2=lb(i2)
5967 * GET the kaon'S MOMENTUM AND COORDINATES IN NUCLEUS-NUCLEUS CMS. FRAME
5968                 EPCM=SQRT(aka**2+PPX**2+PPY**2+PPZ**2)
5969                 PPBETA=PPX*BETAX+PPY*BETAY+PPZ*BETAZ
5970                 TRANSF=GAMMA*(GAMMA*PPBETA/(GAMMA+1.)+EPCM)
5971                 PPION(1,NNN,IRUN)=BETAX*TRANSF+PPX
5972                 PPION(2,NNN,IRUN)=BETAY*TRANSF+PPY
5973                 PPION(3,NNN,IRUN)=BETAZ*TRANSF+PPZ
5974 clin-5/2008
5975                 dppion(nnn,irun)=dpertp(i1)*dpertp(i2)
5976 clin-5/2008
5977 c2003        X01 = 1.0 - 2.0 * RANART(NSEED)
5978 c            Y01 = 1.0 - 2.0 * RANART(NSEED)
5979 c            Z01 = 1.0 - 2.0 * RANART(NSEED)
5980 c        IF ((X01*X01+Y01*Y01+Z01*Z01) .GT. 1.0) GOTO 2003
5981 c                RPION(1,NNN,IRUN)=R(1,I1)+0.5*x01
5982 c                RPION(2,NNN,IRUN)=R(2,I1)+0.5*y01
5983 c                RPION(3,NNN,IRUN)=R(3,I1)+0.5*z01
5984                 RPION(1,NNN,IRUN)=R(1,I1)
5985                 RPION(2,NNN,IRUN)=R(2,I1)
5986                 RPION(3,NNN,IRUN)=R(3,I1)
5987 c
5988 * assign the nucleon/delta and lambda/sigma to i1 or i2 to keep the 
5989 * leadng particle behaviour
5990 C              if((pt1i1*px1+pt2i1*py1+pt3i1*pz1).gt.0)then
5991               p(1,i1)=pt1i1
5992               p(2,i1)=pt2i1
5993               p(3,i1)=pt3i1
5994               e(i1)=eti1
5995               lb(i1)=lbi1
5996               p(1,i2)=pt1i2
5997               p(2,i2)=pt2i2
5998               p(3,i2)=pt3i2
5999               e(i2)=eti2
6000               lb(i2)=lbi2
6001                 PX1     = P(1,I1)
6002                 PY1     = P(2,I1)
6003                 PZ1     = P(3,I1)
6004               EM1       = E(I1)
6005                 ID(I1)  = 2
6006                 ID(I2)  = 2
6007                 ID1     = ID(I1)
6008               go to 90005
6009 * FOR THE NN-->Delta+Delta+rho PROCESS, FIND MOMENTUM OF THE FINAL 
6010 * PARTICLES IN THE NUCLEUS-NUCLEUS CMS.
6011 307     CONTINUE
6012            NTRY1=0
6013 125        CALL DDrho(SRT,ISEED,PX3,PY3,PZ3,DM3,PX4,PY4,PZ4,DM4,
6014      &  PPX,PPY,PPZ,amrho,icou1)
6015        NTRY1=NTRY1+1
6016        if((icou1.lt.0).AND.(NTRY1.LE.20))GO TO 125
6017 C       if(icou1.lt.0)return
6018 * ROTATE THE MOMENTA OF PARTICLES IN THE CMS OF P1+P2
6019        CALL ROTATE(PX,PY,PZ,PX3,PY3,PZ3)
6020        CALL ROTATE(PX,PY,PZ,PX4,PY4,PZ4)
6021        CALL ROTATE(PX,PY,PZ,PPX,PPY,PPZ)
6022                 NNN=NNN+1
6023               arho=amrho
6024 * DETERMINE THE CHARGE STATES OF PARTICLES IN THE FINAL STATE
6025 * (1) FOR P+P
6026               XDIR=RANART(NSEED)
6027                 IF(LB(I1)*LB(I2).EQ.1)THEN
6028                 IF(XDIR.Le.0.2)then
6029 * (1.1)P+P-->D+++D0+rho(0)
6030                 LPION(NNN,IRUN)=26
6031                 EPION(NNN,IRUN)=Arho
6032               LB(I1)=9
6033               LB(I2)=7
6034        GO TO 2051
6035                 ENDIF
6036 * (1.2)P+P -->D++D+rho(0)
6037                 IF((XDIR.LE.0.4).AND.(XDIR.GT.0.2))THEN
6038                 LPION(NNN,IRUN)=26
6039                 EPION(NNN,IRUN)=Arho
6040                 LB(I1)=8
6041                 LB(I2)=8
6042        GO TO 2051
6043               ENDIF 
6044 * (1.3)P+P-->D+++D+arho(-)
6045                 IF((XDIR.LE.0.6).AND.(XDIR.GT.0.4))THEN
6046                 LPION(NNN,IRUN)=25
6047                 EPION(NNN,IRUN)=Arho
6048                 LB(I1)=9
6049                 LB(I2)=8
6050        GO TO 2051
6051               ENDIF 
6052                 IF((XDIR.LE.0.8).AND.(XDIR.GT.0.6))THEN
6053                 LPION(NNN,IRUN)=27
6054                 EPION(NNN,IRUN)=Arho
6055                 LB(I1)=9
6056                 LB(I2)=6
6057        GO TO 2051
6058               ENDIF 
6059                 IF(XDIR.GT.0.8)THEN
6060                 LPION(NNN,IRUN)=27
6061                 EPION(NNN,IRUN)=Arho
6062                 LB(I1)=7
6063                 LB(I2)=8
6064        GO TO 2051
6065               ENDIF 
6066                ENDIF
6067 * (2)FOR N+N
6068                 IF(iabs(LB(I1)).EQ.2.AND.iabs(LB(I2)).EQ.2)THEN
6069                 IF(XDIR.Le.0.2)then
6070 * (2.1)N+N-->D++D-+rho(0)
6071                 LPION(NNN,IRUN)=26
6072                 EPION(NNN,IRUN)=Arho
6073               LB(I1)=6
6074               LB(I2)=7
6075        GO TO 2051
6076                 ENDIF
6077 * (2.2)N+N -->D+++D-+rho(-)
6078                 IF((XDIR.LE.0.4).AND.(XDIR.GT.0.2))THEN
6079                 LPION(NNN,IRUN)=25
6080                 EPION(NNN,IRUN)=Arho
6081                 LB(I1)=6
6082                 LB(I2)=9
6083        GO TO 2051
6084               ENDIF 
6085 * (2.3)P+P-->D0+D-+rho(+)
6086                 IF((XDIR.GT.0.4).AND.(XDIR.LE.0.6))THEN
6087                 LPION(NNN,IRUN)=27
6088                 EPION(NNN,IRUN)=Arho
6089                 LB(I1)=9
6090                 LB(I2)=8
6091        GO TO 2051
6092               ENDIF 
6093 * (2.4)P+P-->D0+D0+rho(0)
6094                 IF((XDIR.GT.0.6).AND.(XDIR.LE.0.8))THEN
6095                 LPION(NNN,IRUN)=26
6096                 EPION(NNN,IRUN)=Arho
6097                 LB(I1)=7
6098                 LB(I2)=7
6099        GO TO 2051
6100               ENDIF 
6101 * (2.5)P+P-->D0+D++rho(-)
6102                 IF(XDIR.GT.0.8)THEN
6103                 LPION(NNN,IRUN)=25
6104                 EPION(NNN,IRUN)=Arho
6105                 LB(I1)=7
6106                 LB(I2)=8
6107        GO TO 2051
6108               ENDIF 
6109               ENDIF
6110 * (3)FOR N+P
6111                 IF(LB(I1)*LB(I2).EQ.2)THEN
6112                 IF(XDIR.Le.0.17)then
6113 * (3.1)N+P-->D+++D-+rho(0)
6114                 LPION(NNN,IRUN)=25
6115                 EPION(NNN,IRUN)=Arho
6116               LB(I1)=6
6117               LB(I2)=9
6118        GO TO 2051
6119                 ENDIF
6120 * (3.2)N+P -->D+++D0+rho(-)
6121                 IF((XDIR.LE.0.34).AND.(XDIR.GT.0.17))THEN
6122                 LPION(NNN,IRUN)=25
6123                 EPION(NNN,IRUN)=Arho
6124                 LB(I1)=7
6125                 LB(I2)=9
6126        GO TO 2051
6127               ENDIF 
6128 * (3.3)N+P-->D++D-+rho(+)
6129                 IF((XDIR.GT.0.34).AND.(XDIR.LE.0.51))THEN
6130                 LPION(NNN,IRUN)=27
6131                 EPION(NNN,IRUN)=Arho
6132                 LB(I1)=7
6133                 LB(I2)=8
6134        GO TO 2051
6135               ENDIF 
6136 * (3.4)N+P-->D++D++rho(-)
6137                 IF((XDIR.GT.0.51).AND.(XDIR.LE.0.68))THEN
6138                 LPION(NNN,IRUN)=25
6139                 EPION(NNN,IRUN)=Arho
6140                 LB(I1)=8
6141                 LB(I2)=8
6142        GO TO 2051
6143               ENDIF 
6144 * (3.5)N+P-->D0+D++rho(0)
6145                 IF((XDIR.GT.0.68).AND.(XDIR.LE.0.85))THEN
6146                 LPION(NNN,IRUN)=26
6147                 EPION(NNN,IRUN)=Arho
6148                 LB(I1)=7
6149                 LB(I2)=8
6150        GO TO 2051
6151               ENDIF 
6152 * (3.6)N+P-->D0+D0+rho(+)
6153                 IF(XDIR.GT.0.85)THEN
6154                 LPION(NNN,IRUN)=27
6155                 EPION(NNN,IRUN)=Arho
6156                 LB(I1)=7
6157                 LB(I2)=7
6158               ENDIF 
6159                 ENDIF
6160 * FIND THE MOMENTUM OF PARTICLES IN THE FINAL STATE IN THE NUCLEUS-
6161 * NUCLEUS CMS. FRAME 
6162 *             LORENTZ-TRANSFORMATION INTO LAB FRAME FOR DELTA1
6163 2051          E1CM    = SQRT (dm3**2 + PX3**2 + PY3**2 + PZ3**2)
6164               P1BETA  = PX3*BETAX + PY3*BETAY + PZ3*BETAZ
6165               TRANSF  = GAMMA * ( GAMMA * P1BETA / (GAMMA + 1) + E1CM )
6166               Pt1i1 = BETAX * TRANSF + PX3
6167               Pt2i1 = BETAY * TRANSF + PY3
6168               Pt3i1 = BETAZ * TRANSF + PZ3
6169              Eti1   = DM3
6170 c
6171              if(ianti.eq.1 .and. lb(i1).ge.1 .and. lb(i2).ge.1)then
6172                lb(i1) = -lb(i1)
6173                lb(i2) = -lb(i2)
6174                 if(LPION(NNN,IRUN) .eq. 25)then
6175                   LPION(NNN,IRUN)=27
6176                 elseif(LPION(NNN,IRUN) .eq. 27)then
6177                   LPION(NNN,IRUN)=25
6178                 endif
6179                endif
6180 c
6181              lb1=lb(i1)
6182 * FOR DELTA2
6183                 E2CM    = SQRT (dm4**2 + PX4**2 + PY4**2 + PZ4**2)
6184                 P2BETA  = PX4*BETAX+PY4*BETAY+PZ4*BETAZ
6185                 TRANSF  = GAMMA * (GAMMA*P2BETA / (GAMMA + 1.) + E2CM)
6186                 Pt1I2 = BETAX * TRANSF + PX4
6187                 Pt2I2 = BETAY * TRANSF + PY4
6188                 Pt3I2 = BETAZ * TRANSF + PZ4
6189               EtI2   = DM4
6190               lb2=lb(i2)
6191 * assign delta1 and delta2 to i1 or i2 to keep the leadng particle
6192 * behaviour
6193 C              if((pt1i1*px1+pt2i1*py1+pt3i1*pz1).gt.0)then
6194               p(1,i1)=pt1i1
6195               p(2,i1)=pt2i1
6196               p(3,i1)=pt3i1
6197               e(i1)=eti1
6198               lb(i1)=lb1
6199               p(1,i2)=pt1i2
6200               p(2,i2)=pt2i2
6201               p(3,i2)=pt3i2
6202               e(i2)=eti2
6203               lb(i2)=lb2
6204                 PX1     = P(1,I1)
6205                 PY1     = P(2,I1)
6206                 PZ1     = P(3,I1)
6207               EM1       = E(I1)
6208                 ID(I1)  = 2
6209                 ID(I2)  = 2
6210                 ID1     = ID(I1)
6211                 IBLOCK=44
6212 * GET rho'S MOMENTUM AND COORDINATES IN NUCLEUS-NUCLEUS CMS. FRAME
6213                 EPCM=SQRT(EPION(NNN,IRUN)**2+PPX**2+PPY**2+PPZ**2)
6214                 PPBETA=PPX*BETAX+PPY*BETAY+PPZ*BETAZ
6215                 TRANSF=GAMMA*(GAMMA*PPBETA/(GAMMA+1.)+EPCM)
6216                 PPION(1,NNN,IRUN)=BETAX*TRANSF+PPX
6217                 PPION(2,NNN,IRUN)=BETAY*TRANSF+PPY
6218                 PPION(3,NNN,IRUN)=BETAZ*TRANSF+PPZ
6219 clin-5/2008:
6220                 dppion(nnn,irun)=dpertp(i1)*dpertp(i2)
6221 clin-5/2008:
6222 c2004        X01 = 1.0 - 2.0 * RANART(NSEED)
6223 c            Y01 = 1.0 - 2.0 * RANART(NSEED)
6224 c            Z01 = 1.0 - 2.0 * RANART(NSEED)
6225 c        IF ((X01*X01+Y01*Y01+Z01*Z01) .GT. 1.0) GOTO 2004
6226 c                RPION(1,NNN,IRUN)=R(1,I1)+0.5*x01
6227 c                RPION(2,NNN,IRUN)=R(2,I1)+0.5*y01
6228 c                RPION(3,NNN,IRUN)=R(3,I1)+0.5*z01
6229                 RPION(1,NNN,IRUN)=R(1,I1)
6230                 RPION(2,NNN,IRUN)=R(2,I1)
6231                 RPION(3,NNN,IRUN)=R(3,I1)
6232 c
6233               go to 90005
6234 * FOR THE NN-->N+N+rho PROCESS, FIND MOMENTUM OF THE FINAL 
6235 * PARTICLES IN THE NUCLEUS-NUCLEUS CMS.
6236 308     CONTINUE
6237            NTRY1=0
6238 126        CALL pprho(SRT,ISEED,PX3,PY3,PZ3,DM3,PX4,PY4,PZ4,DM4,
6239      &  PPX,PPY,PPZ,amrho,icou1)
6240        NTRY1=NTRY1+1
6241        if((icou1.lt.0).AND.(NTRY1.LE.20))GO TO 126
6242 C       if(icou1.lt.0)return
6243 * ROTATE THE MOMENTA OF PARTICLES IN THE CMS OF P1+P2
6244        CALL ROTATE(PX,PY,PZ,PX3,PY3,PZ3)
6245        CALL ROTATE(PX,PY,PZ,PX4,PY4,PZ4)
6246        CALL ROTATE(PX,PY,PZ,PPX,PPY,PPZ)
6247                 NNN=NNN+1
6248               arho=amrho
6249 * DETERMINE THE CHARGE STATES OF PARTICLES IN THE FINAL STATE
6250 * (1) FOR P+P
6251               XDIR=RANART(NSEED)
6252                 IF(LB(I1)*LB(I2).EQ.1)THEN
6253                 IF(XDIR.Le.0.5)then
6254 * (1.1)P+P-->P+P+rho(0)
6255                 LPION(NNN,IRUN)=26
6256                 EPION(NNN,IRUN)=Arho
6257               LB(I1)=1
6258               LB(I2)=1
6259        GO TO 2052
6260                 Else
6261 * (1.2)P+P -->p+n+rho(+)
6262                 LPION(NNN,IRUN)=27
6263                 EPION(NNN,IRUN)=Arho
6264                 LB(I1)=1
6265                 LB(I2)=2
6266        GO TO 2052
6267               ENDIF 
6268               endif
6269 * (2)FOR N+N
6270                 IF(iabs(LB(I1)).EQ.2.AND.iabs(LB(I2)).EQ.2)THEN
6271                 IF(XDIR.Le.0.5)then
6272 * (2.1)N+N-->N+N+rho(0)
6273                 LPION(NNN,IRUN)=26
6274                 EPION(NNN,IRUN)=Arho
6275               LB(I1)=2
6276               LB(I2)=2
6277        GO TO 2052
6278                 Else
6279 * (2.2)N+N -->N+P+rho(-)
6280                 LPION(NNN,IRUN)=25
6281                 EPION(NNN,IRUN)=Arho
6282                 LB(I1)=1
6283                 LB(I2)=2
6284        GO TO 2052
6285               ENDIF 
6286               endif
6287 * (3)FOR N+P
6288                 IF(LB(I1)*LB(I2).EQ.2)THEN
6289                 IF(XDIR.Le.0.33)then
6290 * (3.1)N+P-->N+P+rho(0)
6291                 LPION(NNN,IRUN)=26
6292                 EPION(NNN,IRUN)=Arho
6293               LB(I1)=1
6294               LB(I2)=2
6295        GO TO 2052
6296 * (3.2)N+P -->P+P+rho(-)
6297                 else IF((XDIR.LE.0.67).AND.(XDIR.GT.0.34))THEN
6298                 LPION(NNN,IRUN)=25
6299                 EPION(NNN,IRUN)=Arho
6300                 LB(I1)=1
6301                 LB(I2)=1
6302        GO TO 2052
6303               Else 
6304 * (3.3)N+P-->N+N+rho(+)
6305                 LPION(NNN,IRUN)=27
6306                 EPION(NNN,IRUN)=Arho
6307                 LB(I1)=2
6308                 LB(I2)=2
6309        GO TO 2052
6310               ENDIF 
6311               endif
6312 * FIND THE MOMENTUM OF PARTICLES IN THE FINAL STATE IN THE NUCLEUS-
6313 * NUCLEUS CMS. FRAME 
6314 *             LORENTZ-TRANSFORMATION INTO LAB FRAME FOR DELTA1
6315 2052          E1CM    = SQRT (dm3**2 + PX3**2 + PY3**2 + PZ3**2)
6316               P1BETA  = PX3*BETAX + PY3*BETAY + PZ3*BETAZ
6317               TRANSF  = GAMMA * ( GAMMA * P1BETA / (GAMMA + 1) + E1CM )
6318               Pt1i1 = BETAX * TRANSF + PX3
6319               Pt2i1 = BETAY * TRANSF + PY3
6320               Pt3i1 = BETAZ * TRANSF + PZ3
6321              Eti1   = DM3
6322 c
6323               if(ianti.eq.1 .and. lb(i1).ge.1 .and. lb(i2).ge.1)then
6324                lb(i1) = -lb(i1)
6325                lb(i2) = -lb(i2)
6326                 if(LPION(NNN,IRUN) .eq. 25)then
6327                   LPION(NNN,IRUN)=27
6328                 elseif(LPION(NNN,IRUN) .eq. 27)then
6329                   LPION(NNN,IRUN)=25
6330                 endif
6331                endif
6332 c
6333              lb1=lb(i1)
6334 * FOR p2
6335                 E2CM    = SQRT (dm4**2 + PX4**2 + PY4**2 + PZ4**2)
6336                 P2BETA  = PX4*BETAX+PY4*BETAY+PZ4*BETAZ
6337                 TRANSF  = GAMMA * (GAMMA*P2BETA / (GAMMA + 1.) + E2CM)
6338                 Pt1I2 = BETAX * TRANSF + PX4
6339                 Pt2I2 = BETAY * TRANSF + PY4
6340                 Pt3I2 = BETAZ * TRANSF + PZ4
6341               EtI2   = DM4
6342               lb2=lb(i2)
6343 * assign p1 and p2 to i1 or i2 to keep the leadng particle
6344 * behaviour
6345 C              if((pt1i1*px1+pt2i1*py1+pt3i1*pz1).gt.0)then
6346               p(1,i1)=pt1i1
6347               p(2,i1)=pt2i1
6348               p(3,i1)=pt3i1
6349               e(i1)=eti1
6350               lb(i1)=lb1
6351               p(1,i2)=pt1i2
6352               p(2,i2)=pt2i2
6353               p(3,i2)=pt3i2
6354               e(i2)=eti2
6355               lb(i2)=lb2
6356                 PX1     = P(1,I1)
6357                 PY1     = P(2,I1)
6358                 PZ1     = P(3,I1)
6359               EM1       = E(I1)
6360                 ID(I1)  = 2
6361                 ID(I2)  = 2
6362                 ID1     = ID(I1)
6363                 IBLOCK=45
6364 * GET rho'S MOMENTUM AND COORDINATES IN NUCLEUS-NUCLEUS CMS. FRAME
6365                 EPCM=SQRT(EPION(NNN,IRUN)**2+PPX**2+PPY**2+PPZ**2)
6366                 PPBETA=PPX*BETAX+PPY*BETAY+PPZ*BETAZ
6367                 TRANSF=GAMMA*(GAMMA*PPBETA/(GAMMA+1.)+EPCM)
6368                 PPION(1,NNN,IRUN)=BETAX*TRANSF+PPX
6369                 PPION(2,NNN,IRUN)=BETAY*TRANSF+PPY
6370                 PPION(3,NNN,IRUN)=BETAZ*TRANSF+PPZ
6371 clin-5/2008:
6372                 dppion(nnn,irun)=dpertp(i1)*dpertp(i2)
6373 clin-5/2008:
6374 c2005        X01 = 1.0 - 2.0 * RANART(NSEED)
6375 c            Y01 = 1.0 - 2.0 * RANART(NSEED)
6376 c            Z01 = 1.0 - 2.0 * RANART(NSEED)
6377 c        IF ((X01*X01+Y01*Y01+Z01*Z01) .GT. 1.0) GOTO 2005
6378 c                RPION(1,NNN,IRUN)=R(1,I1)+0.5*x01
6379 c                RPION(2,NNN,IRUN)=R(2,I1)+0.5*y01
6380 c                RPION(3,NNN,IRUN)=R(3,I1)+0.5*z01
6381                 RPION(1,NNN,IRUN)=R(1,I1)
6382                 RPION(2,NNN,IRUN)=R(2,I1)
6383                 RPION(3,NNN,IRUN)=R(3,I1)
6384 c
6385               go to 90005
6386 * FOR THE NN-->p+p+omega PROCESS, FIND MOMENTUM OF THE FINAL 
6387 * PARTICLES IN THE NUCLEUS-NUCLEUS CMS.
6388 309     CONTINUE
6389            NTRY1=0
6390 138        CALL ppomga(SRT,ISEED,PX3,PY3,PZ3,DM3,PX4,PY4,PZ4,DM4,
6391      &  PPX,PPY,PPZ,icou1)
6392        NTRY1=NTRY1+1
6393        if((icou1.lt.0).AND.(NTRY1.LE.20))GO TO 138
6394 C       if(icou1.lt.0)return
6395 * ROTATE THE MOMENTA OF PARTICLES IN THE CMS OF P1+P2
6396        CALL ROTATE(PX,PY,PZ,PX3,PY3,PZ3)
6397        CALL ROTATE(PX,PY,PZ,PX4,PY4,PZ4)
6398        CALL ROTATE(PX,PY,PZ,PPX,PPY,PPZ)
6399                 NNN=NNN+1
6400               aomega=0.782
6401 * DETERMINE THE CHARGE STATES OF PARTICLES IN THE FINAL STATE
6402 * (1) FOR P+P
6403                 IF(LB(I1)*LB(I2).EQ.1)THEN
6404 * (1.1)P+P-->P+P+omega(0)
6405                 LPION(NNN,IRUN)=28
6406                 EPION(NNN,IRUN)=Aomega
6407               LB(I1)=1
6408               LB(I2)=1
6409        GO TO 2053
6410                 ENDIF
6411 * (2)FOR N+N
6412                 IF(iabs(LB(I1)).EQ.2.AND.iabs(LB(I2)).EQ.2)THEN
6413 * (2.1)N+N-->N+N+omega(0)
6414                 LPION(NNN,IRUN)=28
6415                 EPION(NNN,IRUN)=Aomega
6416               LB(I1)=2
6417               LB(I2)=2
6418        GO TO 2053
6419                 ENDIF
6420 * (3)FOR N+P
6421                 IF(LB(I1)*LB(I2).EQ.2)THEN
6422 * (3.1)N+P-->N+P+omega(0)
6423                 LPION(NNN,IRUN)=28
6424                 EPION(NNN,IRUN)=Aomega
6425               LB(I1)=1
6426               LB(I2)=2
6427        GO TO 2053
6428                 ENDIF
6429 * FIND THE MOMENTUM OF PARTICLES IN THE FINAL STATE IN THE NUCLEUS-
6430 * NUCLEUS CMS. FRAME 
6431 *             LORENTZ-TRANSFORMATION INTO LAB FRAME FOR DELTA1
6432 2053          E1CM    = SQRT (dm3**2 + PX3**2 + PY3**2 + PZ3**2)
6433               P1BETA  = PX3*BETAX + PY3*BETAY + PZ3*BETAZ
6434               TRANSF  = GAMMA * ( GAMMA * P1BETA / (GAMMA + 1) + E1CM )
6435               Pt1i1 = BETAX * TRANSF + PX3
6436               Pt2i1 = BETAY * TRANSF + PY3
6437               Pt3i1 = BETAZ * TRANSF + PZ3
6438              Eti1   = DM3
6439               if(ianti.eq.1 .and. lb(i1).ge.1 .and. lb(i2).ge.1)then
6440                lb(i1) = -lb(i1)
6441                lb(i2) = -lb(i2)
6442                endif
6443              lb1=lb(i1)
6444 * FOR DELTA2
6445                 E2CM    = SQRT (dm4**2 + PX4**2 + PY4**2 + PZ4**2)
6446                 P2BETA  = PX4*BETAX+PY4*BETAY+PZ4*BETAZ
6447                 TRANSF  = GAMMA * (GAMMA*P2BETA / (GAMMA + 1.) + E2CM)
6448                 Pt1I2 = BETAX * TRANSF + PX4
6449                 Pt2I2 = BETAY * TRANSF + PY4
6450                 Pt3I2 = BETAZ * TRANSF + PZ4
6451               EtI2   = DM4
6452                 lb2=lb(i2)
6453 * assign delta1 and delta2 to i1 or i2 to keep the leadng particle
6454 * behaviour
6455 C              if((pt1i1*px1+pt2i1*py1+pt3i1*pz1).gt.0)then
6456               p(1,i1)=pt1i1
6457               p(2,i1)=pt2i1
6458               p(3,i1)=pt3i1
6459               e(i1)=eti1
6460               lb(i1)=lb1
6461               p(1,i2)=pt1i2
6462               p(2,i2)=pt2i2
6463               p(3,i2)=pt3i2
6464               e(i2)=eti2
6465               lb(i2)=lb2
6466                 PX1     = P(1,I1)
6467                 PY1     = P(2,I1)
6468                 PZ1     = P(3,I1)
6469               EM1       = E(I1)
6470                 ID(I1)  = 2
6471                 ID(I2)  = 2
6472                 ID1     = ID(I1)
6473                 IBLOCK=46
6474 * GET omega'S MOMENTUM AND COORDINATES IN NUCLEUS-NUCLEUS CMS. FRAME
6475                 EPCM=SQRT(EPION(NNN,IRUN)**2+PPX**2+PPY**2+PPZ**2)
6476                 PPBETA=PPX*BETAX+PPY*BETAY+PPZ*BETAZ
6477                 TRANSF=GAMMA*(GAMMA*PPBETA/(GAMMA+1.)+EPCM)
6478                 PPION(1,NNN,IRUN)=BETAX*TRANSF+PPX
6479                 PPION(2,NNN,IRUN)=BETAY*TRANSF+PPY
6480                 PPION(3,NNN,IRUN)=BETAZ*TRANSF+PPZ
6481 clin-5/2008:
6482                 dppion(nnn,irun)=dpertp(i1)*dpertp(i2)
6483 clin-5/2008:
6484 c2006        X01 = 1.0 - 2.0 * RANART(NSEED)
6485 c            Y01 = 1.0 - 2.0 * RANART(NSEED)
6486 c            Z01 = 1.0 - 2.0 * RANART(NSEED)
6487 c        IF ((X01*X01+Y01*Y01+Z01*Z01) .GT. 1.0) GOTO 2006
6488 c                RPION(1,NNN,IRUN)=R(1,I1)+0.5*x01
6489 c                RPION(2,NNN,IRUN)=R(2,I1)+0.5*y01
6490 c                RPION(3,NNN,IRUN)=R(3,I1)+0.5*z01
6491                     RPION(1,NNN,IRUN)=R(1,I1)
6492                     RPION(2,NNN,IRUN)=R(2,I1)
6493                     RPION(3,NNN,IRUN)=R(3,I1)
6494 c
6495               go to 90005
6496 * change phase space density FOR NUCLEONS AFTER THE PROCESS
6497 
6498 clin-10/25/02-comment out following, since there is no path to it:
6499 clin-8/16/02 used before set
6500 c     IX1,IY1,IZ1,IPX1,IPY1,IPZ1, IX2,IY2,IZ2,IPX2,IPY2,IPZ2:
6501 c                if ((abs(ix1).le.mx) .and. (abs(iy1).le.my) .and.
6502 c     &              (abs(iz1).le.mz)) then
6503 c                  ipx1p = nint(p(1,i1)/dpx)
6504 c                  ipy1p = nint(p(2,i1)/dpy)
6505 c                  ipz1p = nint(p(3,i1)/dpz)
6506 c                  if ((ipx1p.ne.ipx1) .or. (ipy1p.ne.ipy1) .or.
6507 c     &                (ipz1p.ne.ipz1)) then
6508 c                    if ((abs(ipx1).le.mpx) .and. (abs(ipy1).le.my)
6509 c     &                .and. (ipz1.ge.-mpz) .and. (ipz1.le.mpzp))
6510 c     &                f(ix1,iy1,iz1,ipx1,ipy1,ipz1) =
6511 c     &                f(ix1,iy1,iz1,ipx1,ipy1,ipz1) - 1.
6512 c                    if ((abs(ipx1p).le.mpx) .and. (abs(ipy1p).le.my)
6513 c     &                .and. (ipz1p.ge.-mpz).and. (ipz1p.le.mpzp))
6514 c     &                f(ix1,iy1,iz1,ipx1p,ipy1p,ipz1p) =
6515 c     &                f(ix1,iy1,iz1,ipx1p,ipy1p,ipz1p) + 1.
6516 c                  end if
6517 c                end if
6518 c                if ((abs(ix2).le.mx) .and. (abs(iy2).le.my) .and.
6519 c     &              (abs(iz2).le.mz)) then
6520 c                  ipx2p = nint(p(1,i2)/dpx)
6521 c                  ipy2p = nint(p(2,i2)/dpy)
6522 c                  ipz2p = nint(p(3,i2)/dpz)
6523 c                  if ((ipx2p.ne.ipx2) .or. (ipy2p.ne.ipy2) .or.
6524 c     &                (ipz2p.ne.ipz2)) then
6525 c                    if ((abs(ipx2).le.mpx) .and. (abs(ipy2).le.my)
6526 c     &                .and. (ipz2.ge.-mpz) .and. (ipz2.le.mpzp))
6527 c     &                f(ix2,iy2,iz2,ipx2,ipy2,ipz2) =
6528 c     &                f(ix2,iy2,iz2,ipx2,ipy2,ipz2) - 1.
6529 c                    if ((abs(ipx2p).le.mpx) .and. (abs(ipy2p).le.my)
6530 c     &                .and. (ipz2p.ge.-mpz) .and. (ipz2p.le.mpzp))
6531 c     &                f(ix2,iy2,iz2,ipx2p,ipy2p,ipz2p) =
6532 c     &                f(ix2,iy2,iz2,ipx2p,ipy2p,ipz2p) + 1.
6533 c                  end if
6534 c                end if
6535 clin-10/25/02-end
6536 
6537 90005       continue
6538        RETURN
6539 *-----------------------------------------------------------------------
6540 *COM: SET THE NEW MOMENTUM COORDINATES
6541 107     IF(PX .EQ. 0.0 .AND. PY .EQ. 0.0) THEN
6542         T2 = 0.0
6543       ELSE
6544         T2=ATAN2(PY,PX)
6545       END IF
6546       S1   = 1.0 - C1**2 
6547        IF(S1.LE.0)S1=0
6548        S1=SQRT(S1)
6549 
6550 clin-9/2012: check argument in sqrt():
6551        scheck=1.0 - C2**2
6552        if(scheck.lt.0) then
6553           write(99,*) 'scheck3: ', scheck
6554           scheck=0.
6555        endif
6556        S2=SQRT(scheck)
6557 c       S2  =  SQRT( 1.0 - C2**2 )
6558 
6559       CT1  = COS(T1)
6560       ST1  = SIN(T1)
6561       CT2  = COS(T2)
6562       ST2  = SIN(T2)
6563       PZ   = PR * ( C1*C2 - S1*S2*CT1 )
6564       SS   = C2 * S1 * CT1  +  S2 * C1
6565       PX   = PR * ( SS*CT2 - S1*ST1*ST2 )
6566       PY   = PR * ( SS*ST2 + S1*ST1*CT2 )
6567       RETURN
6568       END
6569 clin-5/2008 CRNN over
6570 
6571 **********************************
6572 **********************************
6573 *                                                                      *
6574 *                                                                      *
6575 c
6576       SUBROUTINE CRPP(PX,PY,PZ,SRT,I1,I2,IBLOCK,
6577      &ppel,ppin,spprho,ipp)
6578 *     PURPOSE:                                                         *
6579 *             DEALING WITH PION-PION COLLISIONS                        *
6580 *     NOTE   :                                                         *
6581 *           VALID ONLY FOR PION-PION-DISTANCES LESS THAN 2.5 FM        *
6582 *     QUANTITIES:                                                 *
6583 *           PX,PY,PZ - MOMENTUM COORDINATES OF ONE PARTICLE IN CM FRAME*
6584 *           SRT      - SQRT OF S                                       *
6585 *           IBLOCK   - THE INFORMATION BACK                            *
6586 *                     6-> Meson+Meson elastic
6587 *                     66-> Meson+meson-->K+K-
6588 **********************************
6589       PARAMETER (MAXSTR=150001,MAXR=1,AMN=0.939457,
6590      1     AMP=0.93828,AP1=0.13496,
6591      2 AP2=0.13957,AM0=1.232,PI=3.1415926,CUTOFF=1.8966,AVMASS=0.9383)
6592       PARAMETER      (AKA=0.498,aks=0.895)
6593       parameter     (MX=4,MY=4,MZ=8,MPX=4,MPY=4,mpz=10,mpzp=10)
6594       COMMON /AA/ R(3,MAXSTR)
6595 cc      SAVE /AA/
6596       COMMON /BB/ P(3,MAXSTR)
6597 cc      SAVE /BB/
6598       COMMON /CC/ E(MAXSTR)
6599 cc      SAVE /CC/
6600       COMMON /EE/ ID(MAXSTR),LB(MAXSTR)
6601 cc      SAVE /EE/
6602       common/input1/ MASSPR,MASSTA,ISEED,IAVOID,DT
6603 cc      SAVE /input1/
6604       common/ppb1/ene,factr2(6),fsum,ppinnb,s,wtot
6605 cc      SAVE /ppb1/
6606       common/ppmm/pprr,ppee,pppe,rpre,xopoe,rree
6607 cc      SAVE /ppmm/
6608       COMMON/RNDF77/NSEED
6609 cc      SAVE /RNDF77/
6610       SAVE   
6611 
6612       lb1i=lb(i1)
6613       lb2i=lb(i2)
6614 
6615        PX0=PX
6616        PY0=PY
6617        PZ0=PZ
6618         iblock=1
6619 *-----------------------------------------------------------------------
6620 * check Meson+Meson inelastic collisions
6621 clin-9/28/00
6622 c        if((srt.gt.1.).and.(ppin/(ppin+ppel).gt.RANART(NSEED)))then
6623 c        iblock=66
6624 c        e(i1)=0.498
6625 c        e(i2)=0.498
6626 c        lb(i1)=21
6627 c        lb(i2)=23
6628 c        go to 10
6629 clin-11/07/00
6630 c        if(srt.gt.1.and.(ppin/(ppin+ppel)).gt.RANART(NSEED)) then
6631 clin-4/03/02
6632         if(srt.gt.(2*aka).and.(ppin/(ppin+ppel)).gt.RANART(NSEED)) then
6633 c        if(ppin/(ppin+ppel).gt.RANART(NSEED)) then
6634 clin-10/08/00
6635 
6636            ranpi=RANART(NSEED)
6637            if((pprr/ppin).ge.ranpi) then
6638 
6639 c     1) pi pi <-> rho rho:
6640               call pi2ro2(i1,i2,lbb1,lbb2,ei1,ei2,iblock,iseed)
6641 
6642 clin-4/03/02 eta equilibration:
6643            elseif((pprr+ppee)/ppin.ge.ranpi) then
6644 c     4) pi pi <-> eta eta:
6645               call pi2et2(i1,i2,lbb1,lbb2,ei1,ei2,iblock,iseed)
6646            elseif(((pprr+ppee+pppe)/ppin).ge.ranpi) then
6647 c     5) pi pi <-> pi eta:
6648               call pi3eta(i1,i2,lbb1,lbb2,ei1,ei2,iblock,iseed)
6649            elseif(((pprr+ppee+pppe+rpre)/ppin).ge.ranpi) then
6650 c     6) rho pi <-> pi eta:
6651               call rpiret(i1,i2,lbb1,lbb2,ei1,ei2,iblock,iseed)
6652            elseif(((pprr+ppee+pppe+rpre+xopoe)/ppin).ge.ranpi) then
6653 c     7) omega pi <-> omega eta:
6654               call opioet(i1,i2,lbb1,lbb2,ei1,ei2,iblock,iseed)
6655            elseif(((pprr+ppee+pppe+rpre+xopoe+rree)
6656      1             /ppin).ge.ranpi) then
6657 c     8) rho rho <-> eta eta:
6658               call ro2et2(i1,i2,lbb1,lbb2,ei1,ei2,iblock,iseed)
6659 clin-4/03/02-end
6660 
6661 c     2) BBbar production:
6662            elseif(((pprr+ppee+pppe+rpre+xopoe+rree+ppinnb)/ppin)
6663      1             .ge.ranpi) then
6664 
6665               call bbarfs(lbb1,lbb2,ei1,ei2,iblock,iseed)
6666 c     3) KKbar production:
6667            else
6668               iblock=66
6669               ei1=aka
6670               ei2=aka
6671               lbb1=21
6672               lbb2=23
6673 clin-11/07/00 pi rho -> K* Kbar and K*bar K productions:
6674               lb1=lb(i1)
6675               lb2=lb(i2)
6676 clin-2/13/03 include omega the same as rho, eta the same as pi:
6677 c        if(((lb1.ge.3.and.lb1.le.5).and.(lb2.ge.25.and.lb2.le.27))
6678 c     1  .or.((lb2.ge.3.and.lb2.le.5).and.(lb1.ge.25.and.lb1.le.27)))
6679         if( ( (lb1.eq.0.or.(lb1.ge.3.and.lb1.le.5))
6680      1       .and.(lb2.ge.25.and.lb2.le.28))
6681      2       .or. ( (lb2.eq.0.or.(lb2.ge.3.and.lb2.le.5))
6682      3       .and.(lb1.ge.25.and.lb1.le.28))) then
6683            ei1=aks
6684            ei2=aka
6685            if(RANART(NSEED).ge.0.5) then
6686               iblock=366
6687               lbb1=30
6688               lbb2=21
6689            else
6690               iblock=367
6691               lbb1=-30
6692               lbb2=23
6693            endif
6694         endif
6695 clin-11/07/00-end
6696            endif
6697 clin-ppbar-8/25/00
6698            e(i1)=ei1
6699            e(i2)=ei2
6700            lb(i1)=lbb1
6701            lb(i2)=lbb2
6702 clin-10/08/00-end
6703 
6704        else
6705 cbzdbg10/15/99
6706 c.....for meson+meson elastic srt.le.2Mk, if not pi+pi collision return
6707          if ((lb(i1).lt.3.or.lb(i1).gt.5).and.
6708      &        (lb(i2).lt.3.or.lb(i2).gt.5)) return
6709 cbzdbg10/15/99 end
6710 
6711 * check Meson+Meson elastic collisions
6712         IBLOCK=6
6713 * direct process
6714        if(ipp.eq.1.or.ipp.eq.4.or.ipp.eq.6)go to 10
6715        if(spprho/ppel.gt.RANART(NSEED))go to 20
6716        endif
6717 10      NTAG=0
6718         EM1=E(I1)
6719         EM2=E(I2)
6720 
6721 *-----------------------------------------------------------------------
6722 * CALCULATE THE MAGNITUDE OF THE FINAL MOMENTUM THROUGH
6723 * ENERGY CONSERVATION
6724           PR2   = (SRT**2 - EM1**2 - EM2**2)**2
6725      1                - 4.0 * (EM1*EM2)**2
6726           IF(PR2.LE.0.)PR2=1.e-09
6727           PR=SQRT(PR2)/(2.*SRT)
6728           C1   = 1.0 - 2.0 * RANART(NSEED)
6729           T1   = 2.0 * PI * RANART(NSEED)
6730           S1   = SQRT( 1.0 - C1**2 )
6731       CT1  = COS(T1)
6732       ST1  = SIN(T1)
6733       PZ   = PR * C1
6734       PX   = PR * S1*CT1 
6735       PY   = PR * S1*ST1
6736 * for isotropic distribution no need to ROTATE THE MOMENTUM
6737 
6738 * ROTATE IT 
6739       CALL ROTATE(PX0,PY0,PZ0,PX,PY,PZ) 
6740 
6741       RETURN
6742 20       continue
6743        iblock=666
6744 * treat rho formation in pion+pion collisions
6745 * calculate the mass and momentum of rho in the nucleus-nucleus frame
6746        call rhores(i1,i2)
6747        if(ipp.eq.2)lb(i1)=27
6748        if(ipp.eq.3)lb(i1)=26
6749        if(ipp.eq.5)lb(i1)=25
6750        return       
6751       END
6752 **********************************
6753 **********************************
6754 *                                                                      *
6755 *                                                                      *
6756       SUBROUTINE CRND(IRUN,PX,PY,PZ,SRT,I1,I2,IBLOCK,
6757      &SIGNN,SIG,sigk,xsk1,xsk2,xsk3,xsk4,xsk5,NT,ipert1)
6758 *     PURPOSE:                                                         *
6759 *             DEALING WITH NUCLEON-BARYON RESONANCE COLLISIONS         *
6760 *     NOTE   :                                                         *
6761 *           VALID ONLY FOR BARYON-BARYON-DISTANCES LESS THAN 1.32 FM   *
6762 *           (1.32 = 2 * HARD-CORE-RADIUS [HRC] )                       *
6763 *     QUANTITIES:                                                 *
6764 *           PX,PY,PZ - MOMENTUM COORDINATES OF ONE PARTICLE IN CM FRAME*
6765 *           SRT      - SQRT OF S                                       *
6766 *           NSTAR =1 INCLUDING N* RESORANCE,ELSE NOT                   *
6767 *           NDIRCT=1 INCLUDING DIRECT PION PRODUCTION PROCESS         *
6768 *           IBLOCK   - THE INFORMATION BACK                            *
6769 *                      0-> COLLISION CANNOT HAPPEN                     *
6770 *                      1-> N-N ELASTIC COLLISION                       *
6771 *                      2-> N+N->N+DELTA,OR N+N->N+N* REACTION          *
6772 *                      3-> N+DELTA->N+N OR N+N*->N+N REACTION          *
6773 *                      4-> N+N->N+N+PION,DIRTCT PROCESS                *
6774 *           N12       - IS USED TO SPECIFY BARYON-BARYON REACTION      *
6775 *                      CHANNELS. M12 IS THE REVERSAL CHANNEL OF N12    *
6776 *                      N12,                                            *
6777 *                      M12=1 FOR p+n-->delta(+)+ n                     *
6778 *                          2     p+n-->delta(0)+ p                     *
6779 *                          3     p+p-->delta(++)+n                     *
6780 *                          4     p+p-->delta(+)+p                      *
6781 *                          5     n+n-->delta(0)+n                      *
6782 *                          6     n+n-->delta(-)+p                      *
6783 *                          7     n+p-->N*(0)(1440)+p                   *
6784 *                          8     n+p-->N*(+)(1440)+n                   *
6785 *                        9     p+p-->N*(+)(1535)+p                     *
6786 *                        10    n+n-->N*(0)(1535)+n                     *
6787 *                         11    n+p-->N*(+)(1535)+n                     *
6788 *                        12    n+p-->N*(0)(1535)+p
6789 *                        13    D(++)+D(-)-->N*(+)(1440)+n
6790 *                         14    D(++)+D(-)-->N*(0)(1440)+p
6791 *                        15    D(+)+D(0)--->N*(+)(1440)+n
6792 *                        16    D(+)+D(0)--->N*(0)(1440)+p
6793 *                        17    D(++)+D(0)-->N*(+)(1535)+p
6794 *                        18    D(++)+D(-)-->N*(0)(1535)+p
6795 *                        19    D(++)+D(-)-->N*(+)(1535)+n
6796 *                        20    D(+)+D(+)-->N*(+)(1535)+p
6797 *                        21    D(+)+D(0)-->N*(+)(1535)+n
6798 *                        22    D(+)+D(0)-->N*(0)(1535)+p
6799 *                        23    D(+)+D(-)-->N*(0)(1535)+n
6800 *                        24    D(0)+D(0)-->N*(0)(1535)+n
6801 *                          25    N*(+)(14)+N*(+)(14)-->N*(+)(15)+p
6802 *                          26    N*(0)(14)+N*(0)(14)-->N*(0)(15)+n
6803 *                          27    N*(+)(14)+N*(0)(14)-->N*(+)(15)+n
6804 *                        28    N*(+)(14)+N*(0)(14)-->N*(0)(15)+p
6805 *                        29    N*(+)(14)+D+-->N*(+)(15)+p
6806 *                        30    N*(+)(14)+D0-->N*(+)(15)+n
6807 *                        31    N*(+)(14)+D(-)-->N*(0)(1535)+n
6808 *                        32    N*(0)(14)+D++--->N*(+)(15)+p
6809 *                        33    N*(0)(14)+D+--->N*(+)(15)+n
6810 *                        34    N*(0)(14)+D+--->N*(0)(15)+p
6811 *                        35    N*(0)(14)+D0-->N*(0)(15)+n
6812 *                        36    N*(+)(14)+D0--->N*(0)(15)+p
6813 *                        ++    see the note book for more listing
6814 **********************************
6815         PARAMETER (MAXSTR=150001,MAXR=1,AMN=0.939457,
6816      1  AMP=0.93828,AP1=0.13496,AKA=0.498,APHI=1.020,
6817      2  AP2=0.13957,AM0=1.232,PI=3.1415926,CUTOFF=1.8966,AVMASS=0.9383)
6818         parameter     (MX=4,MY=4,MZ=8,MPX=4,MPY=4,mpz=10,mpzp=10)
6819         parameter (xmd=1.8756,npdmax=10000)
6820         COMMON /AA/ R(3,MAXSTR)
6821 cc      SAVE /AA/
6822         COMMON /BB/ P(3,MAXSTR)
6823 cc      SAVE /BB/
6824         COMMON /CC/ E(MAXSTR)
6825 cc      SAVE /CC/
6826         COMMON /EE/ ID(MAXSTR),LB(MAXSTR)
6827 cc      SAVE /EE/
6828         common /ff/f(-mx:mx,-my:my,-mz:mz,-mpx:mpx,-mpy:mpy,-mpz:mpzp)
6829 cc      SAVE /ff/
6830         common /gg/ dx,dy,dz,dpx,dpy,dpz
6831 cc      SAVE /gg/
6832         COMMON /INPUT/ NSTAR,NDIRCT,DIR
6833 cc      SAVE /INPUT/
6834         COMMON /NN/NNN
6835 cc      SAVE /NN/
6836         COMMON /BG/BETAX,BETAY,BETAZ,GAMMA
6837 cc      SAVE /BG/
6838         COMMON   /RUN/NUM
6839 cc      SAVE /RUN/
6840         COMMON   /PA/RPION(3,MAXSTR,MAXR)
6841 cc      SAVE /PA/
6842         COMMON   /PB/PPION(3,MAXSTR,MAXR)
6843 cc      SAVE /PB/
6844         COMMON   /PC/EPION(MAXSTR,MAXR)
6845 cc      SAVE /PC/
6846         COMMON   /PD/LPION(MAXSTR,MAXR)
6847 cc      SAVE /PD/
6848         common/input1/ MASSPR,MASSTA,ISEED,IAVOID,DT
6849 cc      SAVE /input1/
6850       common/leadng/lb1,px1,py1,pz1,em1,e1,xfnl,yfnl,zfnl,tfnl,
6851      1 px1n,py1n,pz1n,dp1n
6852 cc      SAVE /leadng/
6853       COMMON/RNDF77/NSEED
6854 cc      SAVE /RNDF77/
6855       COMMON /dpert/dpertt(MAXSTR,MAXR),dpertp(MAXSTR),dplast(MAXSTR),
6856      1     dpdcy(MAXSTR),dpdpi(MAXSTR,MAXR),dpt(MAXSTR, MAXR),
6857      2     dpp1(MAXSTR,MAXR),dppion(MAXSTR,MAXR)
6858       common /dpi/em2,lb2
6859       common /para8/ idpert,npertd,idxsec
6860       dimension ppd(3,npdmax),lbpd(npdmax)
6861       SAVE   
6862 *-----------------------------------------------------------------------
6863        n12=0
6864        m12=0
6865         IBLOCK=0
6866         NTAG=0
6867         EM1=E(I1)
6868         EM2=E(I2)
6869         PR  = SQRT( PX**2 + PY**2 + PZ**2 )
6870         C2  = PZ / PR
6871         X1  = RANART(NSEED)
6872         ianti=0
6873         if(lb(i1).lt.0 .and. lb(i2).lt.0)ianti=1
6874 
6875 clin-6/2008 Production of perturbative deuterons for idpert=1:
6876       call sbbdm(srt,sdprod,ianti,lbm,xmm,pfinal)
6877       if(idpert.eq.1.and.ipert1.eq.1) then
6878          IF (SRT .LT. 2.012) RETURN
6879          if((iabs(lb(i1)).eq.1.or.iabs(lb(i1)).eq.2)
6880      1        .and.(iabs(lb(i2)).ge.6.and.iabs(lb(i2)).le.13)) then
6881             goto 108
6882          elseif((iabs(lb(i2)).eq.1.or.iabs(lb(i2)).eq.2)
6883      1           .and.(iabs(lb(i1)).ge.6.and.iabs(lb(i1)).le.13)) then
6884             goto 108
6885          else
6886             return
6887          endif
6888       endif
6889 *-----------------------------------------------------------------------
6890 *COM: TEST FOR ELASTIC SCATTERING (EITHER N-N OR DELTA-DELTA 0R
6891 *      N-DELTA OR N*-N* or N*-Delta)
6892       IF (X1 .LE. SIGNN/SIG) THEN
6893 *COM:  PARAMETRISATION IS TAKEN FROM THE CUGNON-PAPER
6894         AS  = ( 3.65 * (SRT - 1.8766) )**6
6895         A   = 6.0 * AS / (1.0 + AS)
6896         TA  = -2.0 * PR**2
6897         X   = RANART(NSEED)
6898 clin-10/24/02        T1  = ALOG( (1-X) * DEXP(dble(A)*dble(TA)) + X )  /  A
6899         T1  = sngl(DLOG(dble(1.-X)*DEXP(dble(A)*dble(TA))+dble(X)))/  A
6900         C1  = 1.0 - T1/TA
6901         T1  = 2.0 * PI * RANART(NSEED)
6902         IBLOCK=1
6903        GO TO 107
6904       ELSE
6905 *COM: TEST FOR INELASTIC SCATTERING
6906 *     IF THE AVAILABLE ENERGY IS LESS THAN THE PION-MASS, NOTHING
6907 *     CAN HAPPEN ANY MORE ==> RETURN (2.04 = 2*AVMASS + PI-MASS+0.02)
6908         IF (SRT .LT. 2.04) RETURN
6909 clin-6/2008 add d+meson production for n*N*(0)(1440) and p*N*(+)(1440) channels
6910 c     (they did not have any inelastic reactions before):
6911         if(((iabs(LB(I1)).EQ.2.or.iabs(LB(I2)).EQ.2).AND.
6912      1       (LB(I1)*LB(I2)).EQ.20).or.(LB(I1)*LB(I2)).EQ.13) then
6913            IF(X1.LE.((SIGNN+sdprod)/SIG)) GO TO 108
6914         ENDIF
6915 c
6916 * Resonance absorption or Delta + N-->N*(1440), N*(1535)
6917 * COM: TEST FOR DELTA OR N* ABSORPTION
6918 *      IN THE PROCESS DELTA+N-->NN, N*+N-->NN
6919         PRF=SQRT(0.25*SRT**2-AVMASS**2)
6920         IF(EM1.GT.1.)THEN
6921         DELTAM=EM1
6922         ELSE
6923         DELTAM=EM2
6924         ENDIF
6925         RENOM=DELTAM*PRF**2/DENOM(SRT,1.)/PR
6926         RENOMN=DELTAM*PRF**2/DENOM(SRT,2.)/PR
6927         RENOM1=DELTAM*PRF**2/DENOM(SRT,-1.)/PR
6928 * avoid the inelastic collisions between n+delta- -->N+N 
6929 *       and p+delta++ -->N+N due to charge conservation,
6930 *       but they can scatter to produce kaons 
6931        if((iabs(lb(i1)).eq.2).and.(iabs(lb(i2)).eq.6)) renom=0.
6932        if((iabs(lb(i2)).eq.2).and.(iabs(lb(i1)).eq.6)) renom=0.
6933        if((iabs(lb(i1)).eq.1).and.(iabs(lb(i2)).eq.9)) renom=0.
6934        if((iabs(lb(i2)).eq.1).and.(iabs(lb(i1)).eq.9)) renom=0.
6935        Call M1535(iabs(lb(i1)),iabs(lb(i2)),srt,x1535)
6936         X1440=(3./4.)*SIGMA(SRT,2,0,1)
6937 * CROSS SECTION FOR KAON PRODUCTION from the four channels
6938 * for NLK channel
6939 * avoid the inelastic collisions between n+delta- -->N+N 
6940 *       and p+delta++ -->N+N due to charge conservation,
6941 *       but they can scatter to produce kaons 
6942        if(((iabs(lb(i1)).eq.2).and.(iabs(lb(i2)).eq.6)).OR. 
6943      &         ((iabs(lb(i2)).eq.2).and.(iabs(lb(i1)).eq.6)).OR.
6944      &         ((iabs(lb(i1)).eq.1).and.(iabs(lb(i2)).eq.9)).OR.
6945      &         ((iabs(lb(i2)).eq.1).and.(iabs(lb(i1)).eq.9)))THEN
6946 clin-6/2008
6947           IF(X1.LE.((SIGNN+sdprod)/SIG)) GO TO 108
6948 c          IF((SIGK+SIGNN)/SIG.GE.X1)GO TO 306
6949           IF((SIGK+SIGNN+sdprod)/SIG.GE.X1)GO TO 306
6950 c
6951        ENDIF
6952 * WE DETERMINE THE REACTION CHANNELS IN THE FOLLOWING
6953 * FOR n+delta(++)-->p+p or n+delta(++)-->n+N*(+)(1440),n+N*(+)(1535)
6954 * REABSORPTION OR N*(1535) PRODUCTION LIKE IN P+P OR N*(1440) LIKE PN, 
6955         IF(LB(I1)*LB(I2).EQ.18.AND.
6956      &  (iabs(LB(I1)).EQ.2.OR.iabs(LB(I2)).EQ.2))then
6957         SIGND=SIGMA(SRT,1,1,0)+0.5*SIGMA(SRT,1,1,1)
6958         SIGDN=0.25*SIGND*RENOM
6959 clin-6/2008
6960         IF(X1.LE.((SIGNN+sdprod)/SIG)) GO TO 108
6961 c        IF(X1.GT.(SIGNN+SIGDN+X1440+X1535+SIGK)/SIG)RETURN
6962         IF(X1.GT.(SIGNN+SIGDN+X1440+X1535+SIGK+sdprod)/SIG)RETURN
6963 c
6964        IF(SIGK/(SIGK+SIGDN+X1440+X1535).GT.RANART(NSEED))GO TO 306
6965 * REABSORPTION:
6966        IF(RANART(NSEED).LT.SIGDN/(SIGDN+X1440+X1535))THEN
6967         M12=3
6968        GO TO 206
6969        ELSE
6970 * N* PRODUCTION
6971               IF(RANART(NSEED).LT.X1440/(X1440+X1535))THEN
6972 * N*(1440)
6973               M12=37
6974               ELSE
6975 * N*(1535)       M12=38
6976 clin-2/26/03 why is the above commented out? leads to M12=0 but 
6977 c     particle mass is changed after 204 (causes energy violation).
6978 c     replace by elastic process (return):
6979                    return
6980 
6981               ENDIF
6982        GO TO 204
6983        ENDIF
6984         ENDIF
6985 * FOR p+delta(-)-->n+n or p+delta(-)-->n+N*(0)(1440),n+N*(0)(1535)
6986 * REABSORPTION OR N*(1535) PRODUCTION LIKE IN P+P OR N*(1440) LIKE PN, 
6987         IF(LB(I1)*LB(I2).EQ.6.AND.
6988      &   ((iabs(LB(I1)).EQ.1).OR.(iabs(LB(I2)).EQ.1)))then
6989         SIGND=SIGMA(SRT,1,1,0)+0.5*SIGMA(SRT,1,1,1)
6990         SIGDN=0.25*SIGND*RENOM
6991 clin-6/2008
6992         IF(X1.LE.((SIGNN+sdprod)/SIG)) GO TO 108
6993 c        IF (X1.GT.(SIGNN+SIGDN+X1440+X1535+SIGK)/SIG)RETURN
6994         IF (X1.GT.(SIGNN+SIGDN+X1440+X1535+SIGK+sdprod)/SIG)RETURN
6995 c
6996        IF(SIGK/(SIGK+SIGDN+X1440+X1535).GT.RANART(NSEED))GO TO 306
6997 * REABSORPTION:
6998        IF(RANART(NSEED).LT.SIGDN/(SIGDN+X1440+X1535))THEN
6999         M12=6
7000        GO TO 206
7001        ELSE
7002 * N* PRODUCTION
7003               IF(RANART(NSEED).LT.X1440/(X1440+X1535))THEN
7004 * N*(1440)
7005               M12=47
7006               ELSE
7007 * N*(1535)       M12=48
7008 clin-2/26/03 causes energy violation, replace by elastic process (return):
7009                    return
7010 
7011               ENDIF
7012        GO TO 204
7013        ENDIF
7014         ENDIF
7015 * FOR p+delta(+)-->p+p, N*(+)(144)+p, N*(+)(1535)+p
7016         IF(LB(I1)*LB(I2).EQ.8.AND.
7017      &   (iabs(LB(I1)).EQ.1.OR.iabs(LB(I2)).EQ.1))THEN
7018         SIGND=1.5*SIGMA(SRT,1,1,1)
7019         SIGDN=0.25*SIGND*RENOM
7020 clin-6/2008
7021         IF(X1.LE.((SIGNN+sdprod)/SIG)) GO TO 108
7022 c        IF(X1.GT.(SIGNN+SIGDN+x1440+x1535+SIGK)/SIG)RETURN
7023         IF(X1.GT.(SIGNN+SIGDN+x1440+x1535+SIGK+sdprod)/SIG)RETURN
7024 c
7025        IF(SIGK/(SIGK+SIGDN+X1440+X1535).GT.RANART(NSEED))GO TO 306
7026        IF(RANART(NSEED).LT.SIGDN/(SIGDN+X1440+X1535))THEN
7027         M12=4
7028        GO TO 206
7029        ELSE
7030               IF(RANART(NSEED).LT.X1440/(X1440+X1535))THEN
7031 * N*(144)
7032               M12=39
7033               ELSE
7034               M12=40
7035               ENDIF
7036               GO TO 204
7037        ENDIF
7038         ENDIF
7039 * FOR n+delta(0)-->n+n, N*(0)(144)+n, N*(0)(1535)+n
7040         IF(LB(I1)*LB(I2).EQ.14.AND.
7041      &   (iabs(LB(I1)).EQ.2.OR.iabs(LB(I2)).EQ.2))THEN
7042         SIGND=1.5*SIGMA(SRT,1,1,1)
7043         SIGDN=0.25*SIGND*RENOM
7044 clin-6/2008
7045         IF(X1.LE.((SIGNN+sdprod)/SIG)) GO TO 108
7046 c        IF(X1.GT.(SIGNN+SIGDN+x1440+x1535+SIGK)/SIG)RETURN
7047         IF(X1.GT.(SIGNN+SIGDN+x1440+x1535+SIGK+sdprod)/SIG)RETURN
7048 c
7049        IF(SIGK/(SIGK+SIGDN+X1440+X1535).GT.RANART(NSEED))GO TO 306
7050        IF(RANART(NSEED).LT.SIGDN/(SIGDN+X1440+X1535))THEN
7051         M12=5
7052        GO TO 206
7053        ELSE
7054               IF(RANART(NSEED).LT.X1440/(X1440+X1535))THEN
7055 * N*(144)
7056               M12=48
7057               ELSE
7058               M12=49
7059               ENDIF
7060               GO TO 204
7061        ENDIF
7062         ENDIF
7063 * FOR n+delta(+)-->n+p, N*(+)(1440)+n,N*(0)(1440)+p,
7064 *                       N*(+)(1535)+n,N*(0)(1535)+p
7065         IF(LB(I1)*LB(I2).EQ.16.AND.
7066      &   (iabs(LB(I1)).EQ.2.OR.iabs(LB(I2)).EQ.2))THEN
7067         SIGND=0.5*SIGMA(SRT,1,1,1)+0.25*SIGMA(SRT,1,1,0)
7068         SIGDN=0.5*SIGND*RENOM
7069 clin-6/2008
7070         IF(X1.LE.((SIGNN+sdprod)/SIG)) GO TO 108
7071 c        IF(X1.GT.(SIGNN+SIGDN+2.*x1440+2.*x1535+SIGK)/SIG)RETURN
7072         IF(X1.GT.(SIGNN+SIGDN+2.*x1440+2.*x1535+SIGK+sdprod)/SIG)RETURN
7073 c
7074        IF(SIGK/(SIGK+SIGDN+2*X1440+2*X1535).GT.RANART(NSEED))GO TO 306
7075        IF(RANART(NSEED).LT.SIGDN/(SIGDN+2.*X1440+2.*X1535))THEN
7076         M12=1
7077        GO TO 206
7078        ELSE
7079               IF(RANART(NSEED).LT.X1440/(X1440+X1535))THEN
7080               M12=41
7081               IF(RANART(NSEED).LE.0.5)M12=43
7082               ELSE
7083               M12=42
7084               IF(RANART(NSEED).LE.0.5)M12=44
7085               ENDIF
7086               GO TO 204
7087        ENDIF
7088         ENDIF
7089 * FOR p+delta(0)-->n+p, N*(+)(1440)+n,N*(0)(1440)+p,
7090 *                       N*(+)(1535)+n,N*(0)(1535)+p
7091         IF(LB(I1)*LB(I2).EQ.7)THEN
7092         SIGND=0.5*SIGMA(SRT,1,1,1)+0.25*SIGMA(SRT,1,1,0)
7093         SIGDN=0.5*SIGND*RENOM
7094 clin-6/2008
7095         IF(X1.LE.((SIGNN+sdprod)/SIG)) GO TO 108
7096 c        IF(X1.GT.(SIGNN+SIGDN+2.*x1440+2.*x1535+SIGK)/SIG)RETURN
7097         IF(X1.GT.(SIGNN+SIGDN+2.*x1440+2.*x1535+SIGK+sdprod)/SIG)RETURN
7098 c
7099        IF(SIGK/(SIGK+SIGDN+2*X1440+2*X1535).GT.RANART(NSEED))GO TO 306
7100        IF(RANART(NSEED).LT.SIGDN/(SIGDN+2.*X1440+2.*X1535))THEN
7101         M12=2
7102        GO TO 206
7103        ELSE
7104               IF(RANART(NSEED).LT.X1440/(X1440+X1535))THEN
7105               M12=50
7106               IF(RANART(NSEED).LE.0.5)M12=51
7107               ELSE
7108               M12=52
7109               IF(RANART(NSEED).LE.0.5)M12=53
7110               ENDIF
7111               GO TO 204
7112        ENDIF
7113         ENDIF
7114 * FOR p+N*(0)(14)-->p+n, N*(+)(1535)+n,N*(0)(1535)+p
7115 * OR  P+N*(0)(14)-->D(+)+N, D(0)+P, 
7116         IF(LB(I1)*LB(I2).EQ.10.AND.
7117      &  (iabs(LB(I1)).EQ.1.OR.iabs(LB(I2)).EQ.1))then
7118         SIGND=(3./4.)*SIGMA(SRT,2,0,1)
7119         SIGDN=SIGND*RENOMN
7120 clin-6/2008
7121         IF(X1.LE.((SIGNN+sdprod)/SIG)) GO TO 108
7122 c        IF(X1.GT.(SIGNN+SIGDN+X1535+SIGK)/SIG)RETURN
7123         IF(X1.GT.(SIGNN+SIGDN+X1535+SIGK+sdprod)/SIG)RETURN
7124 c
7125        IF(SIGK/(SIGK+SIGDN+X1535).GT.RANART(NSEED))GO TO 306
7126        IF(RANART(NSEED).LT.SIGDN/(SIGDN+X1535))THEN
7127         M12=7
7128         GO TO 206
7129        ELSE
7130        M12=54
7131        IF(RANART(NSEED).LE.0.5)M12=55
7132        ENDIF
7133        GO TO 204
7134         ENDIF
7135 * FOR n+N*(+)-->p+n, N*(+)(1535)+n,N*(0)(1535)+p
7136         IF(LB(I1)*LB(I2).EQ.22.AND.
7137      &   (iabs(LB(I1)).EQ.2.OR.iabs(LB(I2)).EQ.2))then
7138         SIGND=(3./4.)*SIGMA(SRT,2,0,1)
7139         SIGDN=SIGND*RENOMN
7140 clin-6/2008
7141         IF(X1.LE.((SIGNN+sdprod)/SIG)) GO TO 108
7142 c        IF(X1.GT.(SIGNN+SIGDN+X1535+SIGK)/SIG)RETURN
7143         IF(X1.GT.(SIGNN+SIGDN+X1535+SIGK+sdprod)/SIG)RETURN
7144 c
7145        IF(SIGK/(SIGK+SIGDN+X1535).GT.RANART(NSEED))GO TO 306
7146        IF(RANART(NSEED).LT.SIGDN/(SIGDN+X1535))THEN
7147         M12=8
7148         GO TO 206
7149        ELSE
7150        M12=56
7151        IF(RANART(NSEED).LE.0.5)M12=57
7152        ENDIF
7153        GO TO 204
7154         ENDIF
7155 * FOR N*(1535)+N-->N+N COLLISIONS
7156         IF((iabs(LB(I1)).EQ.12).OR.(iabs(LB(I1)).EQ.13).OR.
7157      1  (iabs(LB(I2)).EQ.12).OR.(iabs(LB(I2)).EQ.13))THEN
7158         SIGND=X1535
7159         SIGDN=SIGND*RENOM1
7160 clin-6/2008
7161         IF(X1.LE.((SIGNN+sdprod)/SIG)) GO TO 108
7162 c        IF(X1.GT.(SIGNN+SIGDN+SIGK)/SIG)RETURN
7163         IF(X1.GT.(SIGNN+SIGDN+SIGK+sdprod)/SIG)RETURN
7164 c
7165        IF(SIGK/(SIGK+SIGDN).GT.RANART(NSEED))GO TO 306
7166         IF(LB(I1)*LB(I2).EQ.24)M12=10
7167         IF(LB(I1)*LB(I2).EQ.12)M12=12
7168         IF(LB(I1)*LB(I2).EQ.26)M12=11
7169        IF(LB(I1)*LB(I2).EQ.13)M12=9
7170        GO TO 206
7171         ENDIF
7172 204       CONTINUE
7173 * (1) GENERATE THE MASS FOR THE N*(1440) AND N*(1535)
7174 * (2) CALCULATE THE FINAL MOMENTUM OF THE n+N* SYSTEM
7175 * (3) RELABLE THE FINAL STATE PARTICLES
7176 *PARAMETRIZATION OF THE SHAPE OF THE N* RESONANCE ACCORDING
7177 *     TO kitazoe's or J.D.JACKSON'S MASS FORMULA AND BREIT WIGNER
7178 *     FORMULA FOR N* RESORANCE
7179 *     DETERMINE DELTA MASS VIA REJECTION METHOD.
7180           DMAX = SRT - AVMASS-0.005
7181           DMIN = 1.078
7182           IF((M12.eq.37).or.(M12.eq.39).or.
7183      1    (M12.eQ.41).OR.(M12.eQ.43).OR.(M12.EQ.46).
7184      2     OR.(M12.EQ.48).OR.(M12.EQ.50).OR.(M12.EQ.51))then
7185 * N*(1440) production
7186           IF(DMAX.LT.1.44) THEN
7187           FM=FNS(DMAX,SRT,0.)
7188           ELSE
7189 
7190 clin-10/25/02 get rid of argument usage mismatch in FNS():
7191              xdmass=1.44
7192 c          FM=FNS(1.44,SRT,1.)
7193           FM=FNS(xdmass,SRT,1.)
7194 clin-10/25/02-end
7195 
7196           ENDIF
7197           IF(FM.EQ.0.)FM=1.E-09
7198           NTRY2=0
7199 11        DM=RANART(NSEED)*(DMAX-DMIN)+DMIN
7200           NTRY2=NTRY2+1
7201           IF((RANART(NSEED).GT.FNS(DM,SRT,1.)/FM).AND.
7202      1    (NTRY2.LE.10)) GO TO 11
7203 
7204 clin-2/26/03 limit the N* mass below a certain value 
7205 c     (here taken as its central value + 2* B-W fullwidth):
7206           if(dm.gt.2.14) goto 11
7207 
7208               GO TO 13
7209               ELSE
7210 * N*(1535) production
7211           IF(DMAX.LT.1.535) THEN
7212           FM=FD5(DMAX,SRT,0.)
7213           ELSE
7214 
7215 clin-10/25/02 get rid of argument usage mismatch in FNS():
7216              xdmass=1.535
7217 c          FM=FD5(1.535,SRT,1.)
7218           FM=FD5(xdmass,SRT,1.)
7219 clin-10/25/02-end
7220 
7221           ENDIF
7222           IF(FM.EQ.0.)FM=1.E-09
7223           NTRY1=0
7224 12        DM = RANART(NSEED) * (DMAX-DMIN) + DMIN
7225           NTRY1=NTRY1+1
7226           IF((RANART(NSEED) .GT. FD5(DM,SRT,1.)/FM).AND.
7227      1    (NTRY1.LE.10)) GOTO 12
7228 
7229 clin-2/26/03 limit the N* mass below a certain value 
7230 c     (here taken as its central value + 2* B-W fullwidth):
7231           if(dm.gt.1.84) goto 12
7232 
7233              ENDIF
7234 13       CONTINUE
7235 * (2) DETERMINE THE FINAL MOMENTUM
7236        PRF=0.
7237        PF2=((SRT**2-DM**2+AVMASS**2)/(2.*SRT))**2-AVMASS**2
7238        IF(PF2.GT.0.)PRF=SQRT(PF2)
7239 * (3) RELABLE FINAL STATE PARTICLES
7240 * 37 D(++)+n-->N*(+)(14)+p
7241           IF(M12.EQ.37)THEN
7242           IF(iabs(LB(I1)).EQ.9)THEN
7243           LB(I1)=1
7244           E(I1)=AMP
7245          LB(I2)=11
7246          E(I2)=DM
7247           ELSE
7248           LB(I2)=1
7249           E(I2)=AMP
7250          LB(I1)=11
7251          E(I1)=DM
7252           ENDIF
7253          GO TO 207
7254           ENDIF
7255 * 38 D(++)+n-->N*(+)(15)+p
7256           IF(M12.EQ.38)THEN
7257           IF(iabs(LB(I1)).EQ.9)THEN
7258           LB(I1)=1
7259           E(I1)=AMP
7260          LB(I2)=13
7261          E(I2)=DM
7262           ELSE
7263           LB(I2)=1
7264           E(I2)=AMP
7265          LB(I1)=13
7266          E(I1)=DM
7267           ENDIF
7268          GO TO 207
7269          ENDIF
7270 * 39 D(+)+P-->N*(+)(14)+p
7271           IF(M12.EQ.39)THEN
7272           IF(iabs(LB(I1)).EQ.8)THEN
7273           LB(I1)=1
7274           E(I1)=AMP
7275          LB(I2)=11
7276          E(I2)=DM
7277           ELSE
7278           LB(I2)=1
7279           E(I2)=AMP
7280          LB(I1)=11
7281          E(I1)=DM
7282           ENDIF
7283          GO TO 207
7284          ENDIF
7285 * 40 D(+)+P-->N*(+)(15)+p
7286           IF(M12.EQ.40)THEN
7287           IF(iabs(LB(I1)).EQ.8)THEN
7288           LB(I1)=1
7289           E(I1)=AMP
7290          LB(I2)=13
7291          E(I2)=DM
7292           ELSE
7293           LB(I2)=1
7294           E(I2)=AMP
7295          LB(I1)=13
7296          E(I1)=DM
7297           ENDIF
7298          GO TO 207
7299          ENDIF
7300 * 41 D(+)+N-->N*(+)(14)+N
7301           IF(M12.EQ.41)THEN
7302           IF(iabs(LB(I1)).EQ.8)THEN
7303           LB(I1)=2
7304           E(I1)=AMN
7305          LB(I2)=11
7306          E(