TAmpt/AMPT/art1f.f

   1 c....................art1f.f
   2 **************************************
   3 *
   4 *                           PROGRAM ART1.0
   5 *
   6 *        A relativistic transport (ART) model for heavy-ion collisions
   7 *
   8 *   sp/01/04/2002
   9 *   calculates K+K- from phi decay, dimuons from phi decay
  10 *   has finite baryon density & possibilites of varying Kaon
  11 *   in-medium mass in phiproduction-annhilation channel only.
  12 *
  13 *
  14 * RELEASING DATE: JAN., 1997
  15 ***************************************
  16 *
  17 * Bao-An Li & Che Ming Ko
  18 * Cyclotron Institute, Texas A&M University.
  19 * Phone: (409) 845-1411
  20 * e-mail: Bali@comp.tamu.edu & Ko@comp.tamu.edu
  21 * http://wwwcyc.tamu.edu/~bali
  22 ***************************************
  23 * Speical notice on the limitation of the code:
  24 *
  25 * (1) ART is a hadronic transport model
  26 *
  27 * (2) E_beam/A <= 15 GeV
  28 *
  29 * (3) The mass of the colliding system is limited by the dimensions of arrays
  30 *    which can be extended purposely. Presently the dimensions are large enough
  31 *     for running Au+Au at 15 GeV/A.
  32 *
  33 * (4) The production and absorption of antiparticles (e.g., ki-, anti-nucleons,
  34 *     etc) are not fully included in this version of the model. They, however,
  35 *     have essentially no effect on the reaction dynamics and observables
  36 *     related to nucleons, pions and kaons (K+) at and below AGS energies.
  37 *
  38 * (5) Bose enhancement for mesons and Pauli blocking for fermions are
  39 *     turned off.
  40 *
  41 *********************************
  42 *
  43 * USEFUL REFERENCES ON PHYSICS AND NUMERICS OF NUCLEAR TRANSPORT MODELS:
  44 *     G.F. BERTSCH AND DAS GUPTA, PHYS. REP. 160 (1988) 189.
  45 *     B.A. LI AND W. BAUER, PHYS. REV. C44 (1991) 450.
  46 *     B.A. LI, W. BAUER AND G.F. BERTSCH, PHYS. REV. C44 (1991) 2095.
  47 *     P. DANIELEWICZ AND G.F. BERTSCH, NUCL. PHYS. A533 (1991) 712.
  48 *
  49 * MAIN REFERENCES ON THIS VERSION OF ART MODEL:
  50 *     B.A. LI AND C.M. KO, PHYS. REV. C52 (1995) 2037;
  51 *                          NUCL. PHYS. A601 (1996) 457.
  52 *
  53 **********************************
  54 **********************************
  55 *  VARIABLES IN INPUT-SECTION:                                               *
  56 *                                                                      *
  57 *  1) TARGET-RELATED QUANTITIES                                        *
  58 *       MASSTA, ZTA -  TARGET MASS IN AMU, TARGET CHARGE  (INTEGER)    *
  59 *                                                                      *
  60 *  2) PROJECTILE-RELATED QUANTITIES                                    *
  61 *       MASSPR, ZPR -  PROJECTILE MASS IN AMU, PROJ. CHARGE(INTEGER)   *
  62 *       ELAB     -  BEAM ENERGY IN [MEV/NUCLEON]               (REAL)  *
  63 *       ZEROPT   -  DISPLACEMENT OF THE SYSTEM IN Z-DIREC. [FM](REAL)  *
  64 *       B        -  IMPACT PARAMETER [FM]                      (REAL)  *
  65 *                                                                      *
  66 *  3) PROGRAM-CONTROL PARAMETERS                                       *
  67 *       ISEED    -  SEED FOR RANDOM NUMBER GENERATOR        (INTEGER)  *
  68 *       DT       -  TIME-STEP-SIZE [FM/C]                      (REAL)  *
  69 *       NTMAX    -  TOTAL NUMBER OF TIMESTEPS               (INTEGER)  *
  70 *       ICOLL    -  (= 1 -> MEAN FIELD ONLY,                           *
  71 *                -   =-1 -> CACADE ONLY, ELSE FULL ART)     (INTEGER)  *
  72 *       NUM      -  NUMBER OF TESTPARTICLES PER NUCLEON     (INTEGER)  *
  73 *       INSYS    -  (=0 -> LAB-SYSTEM, ELSE C.M. SYSTEM)    (INTEGER)  *
  74 *       IPOT     -  1 -> SIGMA=2; 2 -> SIGMA=4/3; 3 -> SIGMA=7/6       *
  75 *                   IN MEAN FIELD POTENTIAL                 (INTEGER)  *
  76 *       MODE     -  (=1 -> interpolation for pauli-blocking,           *
  77 *                    =2 -> local lookup, other -> unblocked)(integer)  *
  78 *       DX,DY,DZ -  widths of cell for paulat in coor. sp. [fm](real)  *
  79 *       DPX,DPY,DPZ-widths of cell for paulat in mom. sp.[GeV/c](real) *
  80 *       IAVOID   -  (=1 -> AVOID FIRST COLL. WITHIN SAME NUCL.         *
  81 *                    =0 -> ALLOW THEM)                      (INTEGER)  *
  82 *       IMOMEN   -  FLAG FOR CHOICE OF INITIAL MOMENTUM DISTRIBUTION   *
  83 *                   (=1 -> WOODS-SAXON DENSITY AND LOCAL THOMAS-FERMI  *
  84 *                    =2 -> NUCLEAR MATTER DEN. AND LOCAL THOMAS-FERMI  *
  85 *                    =3 -> COHERENT BOOST IN Z-DIRECTION)   (INTEGER)  *
  86 *  4) CONTROL-PRINTOUT OPTIONS                                         *
  87 *       NFREQ    -  NUMBER OF TIMSTEPS AFTER WHICH PRINTOUT            *
  88 *                   IS REQUIRED OR ON-LINE ANALYSIS IS PERFORMED       *
  89 *       ICFLOW      =1 PERFORM ON-LINE FLOW ANALYSIS EVERY NFREQ STEPS *
  90 *       ICRHO       =1 PRINT OUT THE BARYON,PION AND ENERGY MATRIX IN  *
  91 *                      THE REACTION PLANE EVERY NFREQ TIME-STEPS       *
  92 *  5)
  93 *       CYCBOX   -  ne.0 => cyclic boundary conditions;boxsize CYCBOX  *
  94 *
  95 **********************************
  96 *               Lables of particles used in this code                     *
  97 **********************************
  98 *
  99 *         LB(I) IS USED TO LABEL PARTICLE'S CHARGE STATE
 100 *
 101 *         LB(I)   =
 102 clin-11/07/00:
 103 *                -30 K*-
 104 clin-8/29/00
 105 *                -13 anti-N*(+1)(1535),s_11
 106 *                -12 anti-N*0(1535),s_11
 107 *                 -11 anti-N*(+1)(1440),p_11
 108 *                 -10 anti-N*0(1440), p_11
 109 *                  -9 anti-DELTA+2
 110 *                  -8 anti-DELTA+1
 111 *                  -7 anti-DELTA0
 112 *                  -6 anti-DELTA-1
 113 clin-8/29/00-end
 114
 115 cbali2/7/99
 116 *                  -2 antineutron
 117 *                             -1       antiproton
 118 cbali2/7/99 end
 119 *                   0 eta
 120 *                        1 PROTON
 121 *                   2 NUETRON
 122 *                   3 PION-
 123 *                   4 PION0
 124 *                   5 PION+
 125 *                   6 DELTA-1
 126 *                   7 DELTA0
 127 *                   8 DELTA+1
 128 *                   9 DELTA+2
 129 *                   10 N*0(1440), p_11
 130 *                   11 N*(+1)(1440),p_11
 131 *                  12 N*0(1535),s_11
 132 *                  13 N*(+1)(1535),s_11
 133 *                  14 LAMBDA
 134 *                   15 sigma-, since we used isospin averaged xsection for
 135 *                   16 sigma0  sigma associated K+ production, sigma0 and
 136 *                   17 sigma+  sigma+ are counted as sigma-
 137 *                   21 kaon-
 138 *                   23 KAON+
 139 *                   24 kaon0
 140 *                   25 rho-
 141 *                         26 rho0
 142 *                   27 rho+
 143 *                   28 omega meson
 144 *                   29 phi
 145 clin-11/07/00:
 146 *                  30 K*+
 147 * sp01/03/01
 148 *                 -14 LAMBDA(bar)
 149 *                  -15 sigma-(bar)
 150 *                  -16 sigma0(bar)
 151 *                  -17 sigma+(bar)
 152 *                   31 eta-prime
 153 *                   40 cascade-
 154 *                  -40 cascade-(bar)
 155 *                   41 cascade0
 156 *                  -41 cascade0(bar)
 157 *                   45 Omega baryon
 158 *                  -45 Omega baryon(bar)
 159 * sp01/03/01 end
 160 clin-5/2008:
 161 *                   42 Deuteron (same in ampt.dat)
 162 *                  -42 anti-Deuteron (same in ampt.dat)
 163 c
 164 *                   ++  ------- SEE BAO-AN LI'S NOTE BOOK
 165 **********************************
 166 cbz11/16/98
 167 c      PROGRAM ART
 168        SUBROUTINE ARTMN
 169 cbz11/16/98end
 170 **********************************
 171 * PARAMETERS:                                                           *
 172 *  MAXPAR     - MAXIMUM NUMBER OF PARTICLES      PROGRAM CAN HANDLE     *
 173 *  MAXP       - MAXIMUM NUMBER OF CREATED MESONS PROGRAM CAN HANDLE     *
 174 *  MAXR       - MAXIMUM NUMBER OF EVENTS AT EACH IMPACT PARAMETER       *
 175 *  MAXX       - NUMBER OF MESHPOINTS IN X AND Y DIRECTION = 2 MAXX + 1  *
 176 *  MAXZ       - NUMBER OF MESHPOINTS IN Z DIRECTION       = 2 MAXZ + 1  *
 177 *  AMU        - 1 ATOMIC MASS UNIT "GEV/C**2"                           *
 178 *  MX,MY,MZ   - MESH SIZES IN COORDINATE SPACE [FM] FOR PAULI LATTICE   *
 179 *  MPX,MPY,MPZ- MESH SIZES IN MOMENTUM SPACE [GEV/C] FOR PAULI LATTICE  *
 180 *---------------------------------------------------------------------- *
 181 clin      PARAMETER     (maxpar=200000,MAXR=50,AMU= 0.9383,
 182       PARAMETER     (MAXSTR=150001,MAXR=1,AMU= 0.9383,
 183      1               AKA=0.498,etaM=0.5475)
 184       PARAMETER     (MAXX   =   20,  MAXZ  =    24)
 185       PARAMETER     (ISUM   =   1001,  IGAM  =    1100)
 186       parameter     (MX=4,MY=4,MZ=8,MPX=4,MPY=4,mpz=10,mpzp=10)
 187 clin      PARAMETER (MAXP = 14000)
 188 *----------------------------------------------------------------------*
 189       INTEGER   OUTPAR, zta,zpr
 190       COMMON  /AA/      R(3,MAXSTR)
 191 cc      SAVE /AA/
 192       COMMON  /BB/      P(3,MAXSTR)
 193 cc      SAVE /BB/
 194       COMMON  /CC/      E(MAXSTR)
 195 cc      SAVE /CC/
 196       COMMON  /DD/      RHO(-MAXX:MAXX,-MAXX:MAXX,-MAXZ:MAXZ),
 197      &                     RHOP(-MAXX:MAXX,-MAXX:MAXX,-MAXZ:MAXZ),
 198      &                     RHON(-MAXX:MAXX,-MAXX:MAXX,-MAXZ:MAXZ)
 199 cc      SAVE /DD/
 200       COMMON  /EE/      ID(MAXSTR),LB(MAXSTR)
 201 cc      SAVE /EE/
 202       COMMON  /HH/  PROPER(MAXSTR)
 203 cc      SAVE /HH/
 204       common  /ff/f(-mx:mx,-my:my,-mz:mz,-mpx:mpx,-mpy:mpy,-mpz:mpzp)
 205 cc      SAVE /ff/
 206       common  /gg/      dx,dy,dz,dpx,dpy,dpz
 207 cc      SAVE /gg/
 208       COMMON  /INPUT/ NSTAR,NDIRCT,DIR
 209 cc      SAVE /INPUT/
 210       COMMON  /PP/      PRHO(-20:20,-24:24)
 211       COMMON  /QQ/      PHRHO(-MAXZ:MAXZ,-24:24)
 212       COMMON  /RR/      MASSR(0:MAXR)
 213 cc      SAVE /RR/
 214       common  /ss/      inout(20)
 215 cc      SAVE /ss/
 216       common  /zz/      zta,zpr
 217 cc      SAVE /zz/
 218       COMMON  /RUN/     NUM
 219 cc      SAVE /RUN/
 220 clin-4/2008:
 221 c      COMMON  /KKK/     TKAON(7),EKAON(7,0:200)
 222       COMMON  /KKK/     TKAON(7),EKAON(7,0:2000)
 223 cc      SAVE /KKK/
 224       COMMON  /KAON/    AK(3,50,36),SPECK(50,36,7),MF
 225 cc      SAVE /KAON/
 226       COMMON/TABLE/ xarray(0:1000),earray(0:1000)
 227 cc      SAVE /TABLE/
 228       common/input1/ MASSPR,MASSTA,ISEED,IAVOID,DT
 229 cc      SAVE /input1/
 230       COMMON  /DDpi/    piRHO(-MAXX:MAXX,-MAXX:MAXX,-MAXZ:MAXZ)
 231 cc      SAVE /DDpi/
 232       common  /tt/  PEL(-maxx:maxx,-maxx:maxx,-maxz:maxz)
 233      &,rxy(-maxx:maxx,-maxx:maxx,-maxz:maxz)
 234 cc      SAVE /tt/
 235 clin-4/2008:
 236 c      DIMENSION TEMP(3,MAXSTR),SKAON(7),SEKAON(7,0:200)
 237       DIMENSION TEMP(3,MAXSTR),SKAON(7),SEKAON(7,0:2000)
 238 cbz12/2/98
 239       COMMON /INPUT2/ ILAB, MANYB, NTMAX, ICOLL, INSYS, IPOT, MODE,
 240      &   IMOMEN, NFREQ, ICFLOW, ICRHO, ICOU, KPOTEN, KMUL
 241 cc      SAVE /INPUT2/
 242       COMMON /INPUT3/ PLAB, ELAB, ZEROPT, B0, BI, BM, DENCUT, CYCBOX
 243 cc      SAVE /INPUT3/
 244 cbz12/2/98end
 245 cbz11/16/98
 246       COMMON /ARPRNT/ ARPAR1(100), IAPAR2(50), ARINT1(100), IAINT2(50)
 247 cc      SAVE /ARPRNT/
 248
 249 c.....note in the below, since a common block in ART is called EE,
 250 c.....the variable EE in /ARPRC/is changed to PEAR.
 251 clin-9/29/03 changed name in order to distinguish from /prec2/
 252 c        COMMON /ARPRC/ ITYPAR(MAXSTR),
 253 c     &       GXAR(MAXSTR), GYAR(MAXSTR), GZAR(MAXSTR), FTAR(MAXSTR),
 254 c     &       PXAR(MAXSTR), PYAR(MAXSTR), PZAR(MAXSTR), PEAR(MAXSTR),
 255 c     &       XMAR(MAXSTR)
 256 cc      SAVE /ARPRC/
 257 clin-9/29/03-end
 258       COMMON /ARERCP/PRO1(MAXSTR, MAXR)
 259 cc      SAVE /ARERCP/
 260       COMMON /ARERC1/MULTI1(MAXR)
 261 cc      SAVE /ARERC1/
 262       COMMON /ARPRC1/ITYP1(MAXSTR, MAXR),
 263      &     GX1(MAXSTR, MAXR), GY1(MAXSTR, MAXR), GZ1(MAXSTR, MAXR),
 264      &     FT1(MAXSTR, MAXR),
 265      &     PX1(MAXSTR, MAXR), PY1(MAXSTR, MAXR), PZ1(MAXSTR, MAXR),
 266      &     EE1(MAXSTR, MAXR), XM1(MAXSTR, MAXR)
 267 cc      SAVE /ARPRC1/
 268 c
 269       DIMENSION NPI(MAXR)
 270       DIMENSION RT(3, MAXSTR, MAXR), PT(3, MAXSTR, MAXR)
 271      &     , ET(MAXSTR, MAXR), LT(MAXSTR, MAXR), PROT(MAXSTR, MAXR)
 272
 273       EXTERNAL IARFLV, INVFLV
 274 cbz11/16/98end
 275       common /lastt/itimeh,bimp
 276 cc      SAVE /lastt/
 277       common/snn/efrm,npart1,npart2
 278 cc      SAVE /snn/
 279       COMMON/hbt/lblast(MAXSTR),xlast(4,MAXSTR),plast(4,MAXSTR),nlast
 280 cc      SAVE /hbt/
 281       common/resdcy/NSAV,iksdcy
 282 cc      SAVE /resdcy/
 283       COMMON/RNDF77/NSEED
 284 cc      SAVE /RNDF77/
 285       COMMON/FTMAX/ftsv(MAXSTR),ftsvt(MAXSTR, MAXR)
 286       COMMON /dpert/dpertt(MAXSTR,MAXR),dpertp(MAXSTR),dplast(MAXSTR),
 287      1     dpdcy(MAXSTR),dpdpi(MAXSTR,MAXR),dpt(MAXSTR, MAXR),
 288      2     dpp1(MAXSTR,MAXR),dppion(MAXSTR,MAXR)
 289       COMMON/HPARNT/HIPR1(100),IHPR2(50),HINT1(100),IHNT2(50)
 290 clin-4/2008 zet() expanded to avoid out-of-bound errors:
 291       real zet(-45:45)
 292       SAVE
 293       data zet /
 294      4     1.,0.,0.,0.,0.,
 295      3     1.,0.,0.,0.,0.,0.,0.,0.,0.,0.,
 296      2     -1.,0.,0.,0.,0.,0.,0.,0.,0.,0.,
 297      1     0.,0.,0.,-1.,0.,1.,0.,-1.,0.,-1.,
 298      s     0.,-2.,-1.,0.,1.,0.,0.,0.,0.,-1.,
 299      e     0.,
 300      s     1.,0.,-1.,0.,1.,-1.,0.,1.,2.,0.,
 301      1     1.,0.,1.,0.,-1.,0.,1.,0.,0.,0.,
 302      2     -1.,0.,1.,0.,-1.,0.,1.,0.,0.,1.,
 303      3     0.,0.,0.,0.,0.,0.,0.,0.,0.,-1.,
 304      4     0.,0.,0.,0.,-1./
 305
 306       nlast=0
 307       do 1002 i=1,MAXSTR
 308          ftsv(i)=0.
 309          do 1101 irun=1,maxr
 310             ftsvt(i,irun)=0.
 311  1101    continue
 312          lblast(i)=999
 313          do 1001 j=1,4
 314 clin-4/2008 bugs pointed out by Vander Molen & Westfall:
 315 c            xlast(i,j)=0.
 316 c            plast(i,j)=0.
 317             xlast(j,i)=0.
 318             plast(j,i)=0.
 319  1001    continue
 320  1002 continue
 321
 322 *-------------------------------------------------------------------*
 323 * Input information about the reaction system and contral parameters*
 324 *-------------------------------------------------------------------*
 325 *              input section starts here                           *
 326 *-------------------------------------------------------------------*
 327
 328 cbz12/2/98
 329 c.....input section is moved to subroutine ARTSET
 330 cbz12/2/98end
 331
 332 *-----------------------------------------------------------------------*
 333 *                   input section ends here                            *
 334 *-----------------------------------------------------------------------*
 335 * read in the table for gengrating the transverse momentum
 336 * IN THE NN-->DDP PROCESS
 337        call tablem
 338 * several control parameters, keep them fixed in this code.
 339        ikaon=1
 340        nstar=1
 341        ndirct=0
 342        dir=0.02
 343        asy=0.032
 344        ESBIN=0.04
 345        MF=36
 346 *----------------------------------------------------------------------*
 347 c      CALL FRONT(12,MASSTA,MASSPR,ELAB)
 348 *----------------------------------------------------------------------*
 349       RADTA  = 1.124 * FLOAT(MASSTA)**(1./3.)
 350       RADPR  = 1.124 * FLOAT(MASSPR)**(1./3.)
 351       ZDIST  = RADTA + RADPR
 352 c      if ( cycbox.ne.0 ) zdist=0
 353       BMAX   = RADTA + RADPR
 354       MASS   = MASSTA + MASSPR
 355       NTOTAL = NUM * MASS
 356 *
 357       IF (NTOTAL .GT. MAXSTR) THEN
 358         WRITE(12,'(//10X,''**** FATAL ERROR: TOO MANY TEST PART. ****'//
 359      & ' '')')
 360         STOP
 361       END IF
 362 *
 363 *-----------------------------------------------------------------------
 364 *       RELATIVISTIC KINEMATICS
 365 *
 366 *       1) LABSYSTEM
 367 *
 368       ETA    = FLOAT(MASSTA) * AMU
 369       PZTA   = 0.0
 370       BETATA = 0.0
 371       GAMMTA = 1.0
 372 *
 373       EPR    = FLOAT(MASSPR) * (AMU + 0.001 * ELAB)
 374       PZPR   = SQRT( EPR**2 - (AMU * FLOAT(MASSPR))**2 )
 375       BETAPR = PZPR / EPR
 376       GAMMPR = 1.0 / SQRT( 1.0 - BETAPR**2 )
 377 *
 378 * BETAC AND GAMMAC OF THE C.M. OBSERVED IN THE LAB. FRAME
 379         BETAC=(PZPR+PZTA)/(EPR+ETA)
 380         GAMMC=1.0 / SQRT(1.-BETAC**2)
 381 *
 382 c      WRITE(12,'(/10x,''****    KINEMATICAL PARAMETERS    ****''/)')
 383 c      WRITE(12,'(10x,''1) LAB-FRAME:        TARGET PROJECTILE'')')
 384 c      WRITE(12,'(10x,''   ETOTAL "GEV" '',2F11.4)') ETA, EPR
 385 c      WRITE(12,'(10x,''   P "GEV/C"    '',2F11.4)') PZTA, PZPR
 386 c      WRITE(12,'(10x,''   BETA         '',2F11.4)') BETATA, BETAPR
 387 c      WRITE(12,'(10x,''   GAMMA        '',2F11.4)') GAMMTA, GAMMPR
 388       IF (INSYS .NE. 0) THEN
 389 *
 390 *       2) C.M. SYSTEM
 391 *
 392         S      = (EPR+ETA)**2 - PZPR**2
 393         xx1=4.*alog(float(massta))
 394         xx2=4.*alog(float(masspr))
 395         xx1=exp(xx1)
 396         xx2=exp(xx2)
 397         PSQARE = (S**2 + (xx1+ xx2) * AMU**4
 398      &             - 2.0 * S * AMU**2 * FLOAT(MASSTA**2 + MASSPR**2)
 399      &             - 2.0 * FLOAT(MASSTA**2 * MASSPR**2) * AMU**4)
 400      &           / (4.0 * S)
 401 *
 402         ETA    = SQRT ( PSQARE + (FLOAT(MASSTA) * AMU)**2 )
 403         PZTA   = - SQRT(PSQARE)
 404         BETATA = PZTA / ETA
 405         GAMMTA = 1.0 / SQRT( 1.0 - BETATA**2 )
 406 *
 407         EPR    = SQRT ( PSQARE + (FLOAT(MASSPR) * AMU)**2 )
 408         PZPR   = SQRT(PSQARE)
 409         BETAPR = PZPR/ EPR
 410         GAMMPR = 1.0 / SQRT( 1.0 - BETAPR**2 )
 411 *
 412 c        WRITE(12,'(10x,''2) C.M.-FRAME:  '')')
 413 c        WRITE(12,'(10x,''   ETOTAL "GEV" '',2F11.4)') ETA, EPR
 414 c        WRITE(12,'(10x,''   P "GEV/C"    '',2F11.4)') PZTA, PZPR
 415 c        WRITE(12,'(10x,''   BETA         '',2F11.4)') BETATA, BETAPR
 416 c        WRITE(12,'(10x,''   GAMMA        '',2F11.4)') GAMMTA, GAMMPR
 417 c        WRITE(12,'(10x,''S "GEV**2"      '',F11.4)')  S
 418 c        WRITE(12,'(10x,''PSQARE "GEV/C"2 '',E14.3)')  PSQARE
 419 c        WRITE(12,'(/10x,''*** CALCULATION DONE IN CM-FRAME ***''/)')
 420       ELSE
 421 c        WRITE(12,'(/10x,''*** CALCULATION DONE IN LAB-FRAME ***''/)')
 422       END IF
 423 * MOMENTUM PER PARTICLE
 424       PZTA = PZTA / FLOAT(MASSTA)
 425       PZPR = PZPR / FLOAT(MASSPR)
 426 * total initial energy in the N-N cms frame
 427       ECMS0=ETA+EPR
 428 *-----------------------------------------------------------------------
 429 *
 430 * Start loop over many runs of different impact parameters
 431 * IF MANYB=1, RUN AT A FIXED IMPACT PARAMETER B0, OTHERWISE GENERATE
 432 * MINIMUM BIAS EVENTS WITHIN THE IMPACT PARAMETER RANGE OF B_MIN AND B_MAX
 433        DO 50000 IMANY=1,MANYB
 434 *------------------------------------------------------------------------
 435 * Initialize the impact parameter B
 436        if (manyb. gt.1) then
 437 111       BX=1.0-2.0*RANART(NSEED)
 438        BY=1.0-2.0*RANART(NSEED)
 439        B2=BX*BX+BY*BY
 440        IF(B2.GT.1.0) GO TO 111
 441        B=SQRT(B2)*(BM-BI)+BI
 442        ELSE
 443        B=B0
 444        ENDIF
 445 c      WRITE(12,'(///10X,''RUN NUMBER:'',I6)') IMANY
 446 c      WRITE(12,'(//10X,''IMPACT PARAMETER B FOR THIS RUN:'',
 447 c     &             F9.3,'' FM''/10X,49(''*'')/)') B
 448 *
 449 *-----------------------------------------------------------------------
 450 *       INITIALIZATION
 451 *1 INITIALIZATION IN ISOSPIN SPACE FOR BOTH THE PROJECTILE AND TARGET
 452       call coulin(masspr,massta,NUM)
 453 *2 INITIALIZATION IN PHASE SPACE FOR THE TARGET
 454       CALL INIT(1       ,MASSTA   ,NUM     ,RADTA,
 455      &          B/2.    ,ZEROPT+ZDIST/2.   ,PZTA,
 456      &          GAMMTA  ,ISEED    ,MASS    ,IMOMEN)
 457 *3.1 INITIALIZATION IN PHASE SPACE FOR THE PROJECTILE
 458       CALL INIT(1+MASSTA,MASS     ,NUM     ,RADPR,
 459      &          -B/2.   ,ZEROPT-ZDIST/2.   ,PZPR,
 460      &          GAMMPR  ,ISEED    ,MASS    ,IMOMEN)
 461 *3.2 OUTPAR IS THE NO. OF ESCAPED PARTICLES
 462       OUTPAR = 0
 463 *3.3 INITIALIZATION FOR THE NO. OF PARTICLES IN EACH SAMPLE
 464 *    THIS IS NEEDED DUE TO THE FACT THAT PIONS CAN BE PRODUCED OR ABSORBED
 465       MASSR(0)=0
 466       DO 1003 IR =1,NUM
 467       MASSR(IR)=MASS
 468  1003 CONTINUE
 469 *3.4 INITIALIZation FOR THE KAON SPECTRUM
 470 *      CALL KSPEC0(BETAC,GAMMC)
 471 * calculate the local baryon density matrix
 472       CALL DENS(IPOT,MASS,NUM,OUTPAR)
 473 *
 474 *-----------------------------------------------------------------------
 475 *       CONTROL PRINTOUT OF INITIAL CONFIGURATION
 476 *
 477 *      WRITE(12,'(''**********  INITIAL CONFIGURATION  **********''/)')
 478 *
 479 c print out the INITIAL density matrix in the reaction plane
 480 c       do ix=-10,10
 481 c       do iz=-10,10
 482 c       write(1053,992)ix,iz,rho(ix,0,iz)/0.168
 483 c       end do
 484 c       end do
 485 *-----------------------------------------------------------------------
 486 *       CALCULATE MOMENTA FOR T = 0.5 * DT
 487 *       (TO OBTAIN 2ND DEGREE ACCURACY!)
 488 *       "Reference: J. AICHELIN ET AL., PHYS. REV. C31, 1730 (1985)"
 489 *
 490       IF (ICOLL .NE. -1) THEN
 491         DO 700 I = 1,NTOTAL
 492           IX = NINT( R(1,I) )
 493           IY = NINT( R(2,I) )
 494           IZ = NINT( R(3,I) )
 495 clin-4/2008 check bounds:
 496           IF(IX.GE.MAXX.OR.IY.GE.MAXX.OR.IZ.GE.MAXZ
 497      1         .OR.IX.LE.-MAXX.OR.IY.LE.-MAXX.OR.IZ.LE.-MAXZ) goto 700
 498           CALL GRADU(IPOT,IX,IY,IZ,GRADX,GRADY,GRADZ)
 499           P(1,I) = P(1,I) - (0.5 * DT) * GRADX
 500           P(2,I) = P(2,I) - (0.5 * DT) * GRADY
 501           P(3,I) = P(3,I) - (0.5 * DT) * GRADZ
 502   700   CONTINUE
 503       END IF
 504 *-----------------------------------------------------------------------
 505 *-----------------------------------------------------------------------
 506 *4 INITIALIZATION OF TIME-LOOP VARIABLES
 507 *4.1 COLLISION NUMBER COUNTERS
 508 clin 51      RCNNE  = 0
 509         RCNNE  = 0
 510        RDD  = 0
 511        RPP  = 0
 512        rppk = 0
 513        RPN  = 0
 514        rpd  = 0
 515        RKN  = 0
 516        RNNK = 0
 517        RDDK = 0
 518        RNDK = 0
 519       RCNND  = 0
 520       RCNDN  = 0
 521       RCOLL  = 0
 522       RBLOC  = 0
 523       RDIRT  = 0
 524       RDECAY = 0
 525       RRES   = 0
 526 *4.11 KAON PRODUCTION PROBABILITY COUNTER FOR PERTURBATIVE CALCULATIONS ONLY
 527       DO 1005 KKK=1,5
 528          SKAON(KKK)  = 0
 529          DO 1004 IS=1,2000
 530             SEKAON(KKK,IS)=0
 531  1004    CONTINUE
 532  1005 CONTINUE
 533 *4.12 anti-proton and anti-kaon counters
 534        pr0=0.
 535        pr1=0.
 536        ska0=0.
 537        ska1=0.
 538 *       ============== LOOP OVER ALL TIME STEPS ================       *
 539 *                             STARTS HERE                              *
 540 *       ========================================================       *
 541 cbz11/16/98
 542       IF (IAPAR2(1) .NE. 1) THEN
 543          DO 1016 I = 1, MAXSTR
 544             DO 1015 J = 1, 3
 545                R(J, I) = 0.
 546                P(J, I) = 0.
 547  1015       CONTINUE
 548             E(I) = 0.
 549             LB(I) = 0
 550 cbz3/25/00
 551             ID(I)=0
 552 c     sp 12/19/00
 553            PROPER(I) = 1.
 554  1016   CONTINUE
 555          MASS = 0
 556 cbz12/22/98
 557 c         MASSR(1) = 0
 558 c         NP = 0
 559 c         NPI = 1
 560          NP = 0
 561          DO 1017 J = 1, NUM
 562             MASSR(J) = 0
 563             NPI(J) = 1
 564  1017    CONTINUE
 565          DO 1019 I = 1, MAXR
 566             DO 1018 J = 1, MAXSTR
 567                RT(1, J, I) = 0.
 568                RT(2, J, I) = 0.
 569                RT(3, J, I) = 0.
 570                PT(1, J, I) = 0.
 571                PT(2, J, I) = 0.
 572                PT(3, J, I) = 0.
 573                ET(J, I) = 0.
 574                LT(J, I) = 0
 575 c     sp 12/19/00
 576                PROT(J, I) = 1.
 577  1018       CONTINUE
 578  1019    CONTINUE
 579 cbz12/22/98end
 580       END IF
 581 cbz11/16/98end
 582
 583       DO 10000 NT = 1,NTMAX
 584
 585 *TEMPORARY PARTICLE COUNTERS
 586 *4.2 PION COUNTERS : LP1,LP2 AND LP3 ARE THE NO. OF P+,P0 AND P-
 587       LP1=0
 588       LP2=0
 589       LP3=0
 590 *4.3 DELTA COUNTERS : LD1,LD2,LD3 AND LD4 ARE THE NO. OF D++,D+,D0 AND D-
 591       LD1=0
 592       LD2=0
 593       LD3=0
 594       LD4=0
 595 *4.4 N*(1440) COUNTERS : LN1 AND LN2 ARE THE NO. OF N*+ AND N*0
 596       LN1=0
 597       LN2=0
 598 *4.5 N*(1535) counters
 599       LN5=0
 600 *4.6 ETA COUNTERS
 601       LE=0
 602 *4.7 KAON COUNTERS
 603       LKAON=0
 604
 605 clin-11/09/00:
 606 * KAON* COUNTERS
 607       LKAONS=0
 608
 609 *-----------------------------------------------------------------------
 610         IF (ICOLL .NE. 1) THEN
 611 * STUDYING BINARY COLLISIONS AMONG PARTICLES DURING THIS TIME INTERVAL *
 612 clin-10/25/02 get rid of argument usage mismatch in relcol(.nt.):
 613            numnt=nt
 614           CALL RELCOL(LCOLL,LBLOC,LCNNE,LDD,LPP,lppk,
 615      &    LPN,lpd,LRHO,LOMEGA,LKN,LNNK,LDDK,LNDK,LCNND,
 616      &    LCNDN,LDIRT,LDECAY,LRES,LDOU,LDDRHO,LNNRHO,
 617      &    LNNOM,numnt,ntmax,sp,akaon,sk)
 618 c     &    LNNOM,NT,ntmax,sp,akaon,sk)
 619 clin-10/25/02-end
 620 *-----------------------------------------------------------------------
 621
 622 c dilepton production from Dalitz decay
 623 c of pi0 at final time
 624 *      if(nt .eq. ntmax) call dalitz_pi(nt,ntmax)
 625 *                                                                      *
 626 **********************************
 627 *                Lables of collision channels                             *
 628 **********************************
 629 *         LCOLL   - NUMBER OF COLLISIONS              (INTEGER,OUTPUT) *
 630 *         LBLOC   - NUMBER OF PULI-BLOCKED COLLISIONS (INTEGER,OUTPUT) *
 631 *         LCNNE   - NUMBER OF ELASTIC COLLISION       (INTEGER,OUTPUT) *
 632 *         LCNND   - NUMBER OF N+N->N+DELTA REACTION   (INTEGER,OUTPUT) *
 633 *         LCNDN   - NUMBER OF N+DELTA->N+N REACTION   (INTEGER,OUTPUT) *
 634 *         LDD     - NUMBER OF RESONANCE+RESONANCE COLLISIONS
 635 *         LPP     - NUMBER OF PION+PION elastic COLIISIONS
 636 *         lppk    - number of pion(RHO,OMEGA)+pion(RHO,OMEGA)
 637 *                 -->K+K- collisions
 638 *         LPN     - NUMBER OF PION+N-->KAON+X
 639 *         lpd     - number of pion+n-->delta+pion
 640 *         lrho    - number of pion+n-->Delta+rho
 641 *         lomega  - number of pion+n-->Delta+omega
 642 *         LKN     - NUMBER OF KAON RESCATTERINGS
 643 *         LNNK    - NUMBER OF bb-->kAON PROCESS
 644 *         LDDK    - NUMBER OF DD-->KAON PROCESS
 645 *         LNDK    - NUMBER OF ND-->KAON PROCESS
 646 ***********************************
 647 * TIME-INTEGRATED COLLISIONS NUMBERS OF VARIOUS PROCESSES
 648           RCOLL = RCOLL + FLOAT(LCOLL)/num
 649           RBLOC = RBLOC + FLOAT(LBLOC)/num
 650           RCNNE = RCNNE + FLOAT(LCNNE)/num
 651          RDD   = RDD   + FLOAT(LDD)/num
 652          RPP   = RPP   + FLOAT(LPP)/NUM
 653          rppk  =rppk   + float(lppk)/num
 654          RPN   = RPN   + FLOAT(LPN)/NUM
 655          rpd   =rpd    + float(lpd)/num
 656          RKN   = RKN   + FLOAT(LKN)/NUM
 657          RNNK  =RNNK   + FLOAT(LNNK)/NUM
 658          RDDK  =RDDK   + FLOAT(LDDK)/NUM
 659          RNDK  =RNDK   + FLOAT(LNDK)/NUM
 660           RCNND = RCNND + FLOAT(LCNND)/num
 661           RCNDN = RCNDN + FLOAT(LCNDN)/num
 662           RDIRT = RDIRT + FLOAT(LDIRT)/num
 663           RDECAY= RDECAY+ FLOAT(LDECAY)/num
 664           RRES  = RRES  + FLOAT(LRES)/num
 665 * AVERAGE RATES OF VARIOUS COLLISIONS IN THE CURRENT TIME STEP
 666           ADIRT=LDIRT/DT/num
 667           ACOLL=(LCOLL-LBLOC)/DT/num
 668           ACNND=LCNND/DT/num
 669           ACNDN=LCNDN/DT/num
 670           ADECAY=LDECAY/DT/num
 671           ARES=LRES/DT/num
 672          ADOU=LDOU/DT/NUM
 673          ADDRHO=LDDRHO/DT/NUM
 674          ANNRHO=LNNRHO/DT/NUM
 675          ANNOM=LNNOM/DT/NUM
 676          ADD=LDD/DT/num
 677          APP=LPP/DT/num
 678          appk=lppk/dt/num
 679           APN=LPN/DT/num
 680          apd=lpd/dt/num
 681          arh=lrho/dt/num
 682          aom=lomega/dt/num
 683          AKN=LKN/DT/num
 684          ANNK=LNNK/DT/num
 685          ADDK=LDDK/DT/num
 686          ANDK=LNDK/DT/num
 687 * PRINT OUT THE VARIOUS COLLISION RATES
 688 * (1)N-N COLLISIONS
 689 c       WRITE(1010,9991)NT*DT,ACNND,ADOU,ADIRT,ADDRHO,ANNRHO+ANNOM
 690 c9991       FORMAT(6(E10.3,2X))
 691 * (2)PION-N COLLISIONS
 692 c       WRITE(1011,'(5(E10.3,2X))')NT*DT,apd,ARH,AOM,APN
 693 * (3)KAON PRODUCTION CHANNELS
 694 c        WRITE(1012,9993)NT*DT,ANNK,ADDK,ANDK,APN,Appk
 695 * (4)D(N*)+D(N*) COLLISION
 696 c       WRITE(1013,'(4(E10.3,2X))')NT*DT,ADDK,ADD,ADD+ADDK
 697 * (5)MESON+MESON
 698 c       WRITE(1014,'(4(E10.3,2X))')NT*DT,APPK,APP,APP+APPK
 699 * (6)DECAY AND RESONANCE
 700 c       WRITE(1016,'(3(E10.3,2X))')NT*DT,ARES,ADECAY
 701 * (7)N+D(N*)
 702 c       WRITE(1017,'(4(E10.3,2X))')NT*DT,ACNDN,ANDK,ACNDN+ANDK
 703 c9992    FORMAT(5(E10.3,2X))
 704 c9993    FORMAT(6(E10.3,2X))
 705 * PRINT OUT TIME-INTEGRATED COLLISION INFORMATION
 706 cbz12/28/98
 707 c        write(1018,'(5(e10.3,2x),/, 4(e10.3,2x))')
 708 c     &           RCNNE,RCNND,RCNDN,RDIRT,rpd,
 709 c     &           RDECAY,RRES,RDD,RPP
 710 c        write(1018,'(6(e10.3,2x),/, 5(e10.3,2x))')
 711 c     &           NT*DT,RCNNE,RCNND,RCNDN,RDIRT,rpd,
 712 c     &           NT*DT,RDECAY,RRES,RDD,RPP
 713 cbz12/18/98end
 714 * PRINT OUT TIME-INTEGRATED KAON MULTIPLICITIES FROM DIFFERENT CHANNELS
 715 c       WRITE(1019,'(7(E10.3,2X))')NT*DT,RNNK,RDDK,RNDK,RPN,Rppk,
 716 c     &                           RNNK+RDDK+RNDK+RPN+Rppk
 717 *                                                                      *
 718
 719         END IF
 720 *
 721 *       UPDATE BARYON DENSITY
 722 *
 723         CALL DENS(IPOT,MASS,NUM,OUTPAR)
 724 *
 725 *       UPDATE POSITIONS FOR ALL THE PARTICLES PRESENT AT THIS TIME
 726 *
 727        sumene=0
 728         ISO=0
 729         DO 201 MRUN=1,NUM
 730         ISO=ISO+MASSR(MRUN-1)
 731         DO 201 I0=1,MASSR(MRUN)
 732         I =I0+ISO
 733         ETOTAL = SQRT( E(I)**2 + P(1,I)**2 + P(2,I)**2 +P(3,I)**2 )
 734        sumene=sumene+etotal
 735 C for kaons, if there is a potential
 736 C CALCULATE THE ENERGY OF THE KAON ACCORDING TO THE IMPULSE APPROXIMATION
 737 C REFERENCE: B.A. LI AND C.M. KO, PHYS. REV. C 54 (1996) 3283.
 738          if(kpoten.ne.0.and.lb(i).eq.23)then
 739              den=0.
 740               IX = NINT( R(1,I) )
 741               IY = NINT( R(2,I) )
 742               IZ = NINT( R(3,I) )
 743 clin-4/2008:
 744 c       IF (ABS(IX) .LT. MAXX .AND. ABS(IY) .LT. MAXX .AND.
 745 c     & ABS(IZ) .LT. MAXZ) den=rho(ix,iy,iz)
 746               IF(IX.LT.MAXX.AND.IY.LT.MAXX.AND.IZ.LT.MAXZ
 747      1             .AND.IX.GT.-MAXX.AND.IY.GT.-MAXX.AND.IZ.GT.-MAXZ)
 748      2             den=rho(ix,iy,iz)
 749 c         ecor=0.1973**2*0.255*kmul*4*3.14159*(1.+0.4396/0.938)
 750 c         etotal=sqrt(etotal**2+ecor*den)
 751 c** G.Q Li potential form with n_s = n_b and pot(n_0)=29 MeV, m^*=m
 752 c     GeV^2 fm^3
 753           akg = 0.1727
 754 c     GeV fm^3
 755           bkg = 0.333
 756          rnsg = den
 757          ecor = - akg*rnsg + (bkg*den)**2
 758          etotal = sqrt(etotal**2 + ecor)
 759          endif
 760 c
 761          if(kpoten.ne.0.and.lb(i).eq.21)then
 762              den=0.
 763               IX = NINT( R(1,I) )
 764               IY = NINT( R(2,I) )
 765               IZ = NINT( R(3,I) )
 766 clin-4/2008:
 767 c       IF (ABS(IX) .LT. MAXX .AND. ABS(IY) .LT. MAXX .AND.
 768 c     & ABS(IZ) .LT. MAXZ) den=rho(ix,iy,iz)
 769               IF(IX.LT.MAXX.AND.IY.LT.MAXX.AND.IZ.LT.MAXZ
 770      1             .AND.IX.GT.-MAXX.AND.IY.GT.-MAXX.AND.IZ.GT.-MAXZ)
 771      2             den=rho(ix,iy,iz)
 772 c* for song potential no effect on position
 773 c** G.Q Li potential form with n_s = n_b and pot(n_0)=29 MeV, m^*=m
 774 c     GeV^2 fm^3
 775           akg = 0.1727
 776 c     GeV fm^3
 777           bkg = 0.333
 778          rnsg = den
 779          ecor = - akg*rnsg + (bkg*den)**2
 780          etotal = sqrt(etotal**2 + ecor)
 781           endif
 782 c
 783 C UPDATE POSITIONS
 784           R(1,I) = R(1,I) + DT*P(1,I)/ETOTAL
 785           R(2,I) = R(2,I) + DT*P(2,I)/ETOTAL
 786           R(3,I) = R(3,I) + DT*P(3,I)/ETOTAL
 787 c use cyclic boundary conitions
 788             if ( cycbox.ne.0 ) then
 789               if ( r(1,i).gt. cycbox/2 ) r(1,i)=r(1,i)-cycbox
 790               if ( r(1,i).le.-cycbox/2 ) r(1,i)=r(1,i)+cycbox
 791               if ( r(2,i).gt. cycbox/2 ) r(2,i)=r(2,i)-cycbox
 792               if ( r(2,i).le.-cycbox/2 ) r(2,i)=r(2,i)+cycbox
 793               if ( r(3,i).gt. cycbox/2 ) r(3,i)=r(3,i)-cycbox
 794               if ( r(3,i).le.-cycbox/2 ) r(3,i)=r(3,i)+cycbox
 795             end if
 796 * UPDATE THE DELTA, N* AND PION COUNTERS
 797           LB1=LB(I)
 798 * 1. FOR DELTA++
 799         IF(LB1.EQ.9)LD1=LD1+1
 800 * 2. FOR DELTA+
 801         IF(LB1.EQ.8)LD2=LD2+1
 802 * 3. FOR DELTA0
 803         IF(LB1.EQ.7)LD3=LD3+1
 804 * 4. FOR DELTA-
 805         IF(LB1.EQ.6)LD4=LD4+1
 806 * 5. FOR N*+(1440)
 807         IF(LB1.EQ.11)LN1=LN1+1
 808 * 6. FOR N*0(1440)
 809         IF(LB1.EQ.10)LN2=LN2+1
 810 * 6.1 FOR N*(1535)
 811        IF((LB1.EQ.13).OR.(LB1.EQ.12))LN5=LN5+1
 812 * 6.2 FOR ETA
 813        IF(LB1.EQ.0)LE=LE+1
 814 * 6.3 FOR KAONS
 815        IF(LB1.EQ.23)LKAON=LKAON+1
 816 clin-11/09/00: FOR KAON*
 817        IF(LB1.EQ.30)LKAONS=LKAONS+1
 818
 819 * UPDATE PION COUNTER
 820 * 7. FOR PION+
 821         IF(LB1.EQ.5)LP1=LP1+1
 822 * 8. FOR PION0
 823         IF(LB1.EQ.4)LP2=LP2+1
 824 * 9. FOR PION-
 825         IF(LB1.EQ.3)LP3=LP3+1
 826 201     CONTINUE
 827         LP=LP1+LP2+LP3
 828         LD=LD1+LD2+LD3+LD4
 829         LN=LN1+LN2
 830         ALP=FLOAT(LP)/FLOAT(NUM)
 831         ALD=FLOAT(LD)/FLOAT(NUM)
 832         ALN=FLOAT(LN)/FLOAT(NUM)
 833        ALN5=FLOAT(LN5)/FLOAT(NUM)
 834         ATOTAL=ALP+ALD+ALN+0.5*ALN5
 835        ALE=FLOAT(LE)/FLOAT(NUM)
 836        ALKAON=FLOAT(LKAON)/FLOAT(NUM)
 837 * UPDATE MOMENTUM DUE TO COULOMB INTERACTION
 838         if (icou .eq. 1) then
 839 *       with Coulomb interaction
 840           iso=0
 841           do 1026 irun = 1,num
 842             iso=iso+massr(irun-1)
 843             do 1021 il = 1,massr(irun)
 844                temp(1,il) = 0.
 845                temp(2,il) = 0.
 846                temp(3,il) = 0.
 847  1021       continue
 848             do 1023 il = 1, massr(irun)
 849               i=iso+il
 850               if (zet(lb(i)).ne.0) then
 851                 do 1022 jl = 1,il-1
 852                   j=iso+jl
 853                   if (zet(lb(j)).ne.0) then
 854                     ddx=r(1,i)-r(1,j)
 855                     ddy=r(2,i)-r(2,j)
 856                     ddz=r(3,i)-r(3,j)
 857                     rdiff = sqrt(ddx**2+ddy**2+ddz**2)
 858                     if (rdiff .le. 1.) rdiff = 1.
 859                     grp=zet(lb(i))*zet(lb(j))/rdiff**3
 860                     ddx=ddx*grp
 861                     ddy=ddy*grp
 862                     ddz=ddz*grp
 863                     temp(1,il)=temp(1,il)+ddx
 864                     temp(2,il)=temp(2,il)+ddy
 865                     temp(3,il)=temp(3,il)+ddz
 866                     temp(1,jl)=temp(1,jl)-ddx
 867                     temp(2,jl)=temp(2,jl)-ddy
 868                     temp(3,jl)=temp(3,jl)-ddz
 869                   end if
 870  1022          continue
 871               end if
 872  1023      continue
 873             do 1025 il = 1,massr(irun)
 874               i= iso+il
 875               if (zet(lb(i)).ne.0) then
 876                 do 1024 idir = 1,3
 877                   p(idir,i) = p(idir,i) + temp(idir,il)
 878      &                                    * dt * 0.00144
 879  1024          continue
 880               end if
 881  1025      continue
 882  1026   continue
 883         end if
 884 *       In the following, we shall:
 885 *       (1) UPDATE MOMENTA DUE TO THE MEAN FIELD FOR BARYONS AND KAONS,
 886 *       (2) calculate the thermalization, temperature in a sphere of
 887 *           radius 2.0 fm AROUND THE CM
 888 *       (3) AND CALCULATE THE NUMBER OF PARTICLES IN THE HIGH DENSITY REGION
 889        spt=0
 890        spz=0
 891        ncen=0
 892        ekin=0
 893           NLOST = 0
 894           MEAN=0
 895          nquark=0
 896          nbaryn=0
 897 csp06/18/01
 898            rads = 2.
 899            zras = 0.1
 900            denst = 0.
 901            edenst = 0.
 902 csp06/18/01 end
 903           DO 6000 IRUN = 1,NUM
 904           MEAN=MEAN+MASSR(IRUN-1)
 905           DO 5800 J = 1,MASSR(irun)
 906           I=J+MEAN
 907 c
 908 csp06/18/01
 909            radut = sqrt(r(1,i)**2+r(2,i)**2)
 910        if( radut .le. rads )then
 911         if( abs(r(3,i)) .le. zras*nt*dt )then
 912 c         vols = 3.14159*radut**2*abs(r(3,i))      ! cylinder pi*r^2*l
 913 c     cylinder pi*r^2*l
 914          vols = 3.14159*rads**2*zras
 915          engs=sqrt(p(1,i)**2+p(2,i)**2+p(3,i)**2+e(i)**2)
 916          gammas=1.
 917          if(e(i).ne.0.)gammas=engs/e(i)
 918 c     rho
 919          denst = denst + 1./gammas/vols
 920 c     energy density
 921          edenst = edenst + engs/gammas/gammas/vols
 922         endif
 923        endif
 924 csp06/18/01 end
 925 c
 926          drr=sqrt(r(1,i)**2+r(2,i)**2+r(3,i)**2)
 927          if(drr.le.2.0)then
 928          spt=spt+p(1,i)**2+p(2,i)**2
 929          spz=spz+p(3,i)**2
 930          ncen=ncen+1
 931          ekin=ekin+sqrt(p(1,i)**2+p(2,i)**2+p(3,i)**2+e(i)**2)-e(i)
 932          endif
 933               IX = NINT( R(1,I) )
 934               IY = NINT( R(2,I) )
 935               IZ = NINT( R(3,I) )
 936 C calculate the No. of particles in the high density region
 937 clin-4/2008:
 938 c              IF (ABS(IX) .LT. MAXX .AND. ABS(IY) .LT. MAXX .AND.
 939 c     & ABS(IZ) .LT. MAXZ) THEN
 940               IF(IX.LT.MAXX.AND.IY.LT.MAXX.AND.IZ.LT.MAXZ
 941      1          .AND.IX.GT.-MAXX.AND.IY.GT.-MAXX.AND.IZ.GT.-MAXZ) THEN
 942        if(rho(ix,iy,iz)/0.168.gt.dencut)go to 5800
 943        if((rho(ix,iy,iz)/0.168.gt.5.).and.(e(i).gt.0.9))
 944      &  nbaryn=nbaryn+1
 945        if(pel(ix,iy,iz).gt.2.0)nquark=nquark+1
 946        endif
 947 c*
 948 c If there is a kaon potential, propogating kaons
 949         if(kpoten.ne.0.and.lb(i).eq.23)then
 950         den=0.
 951 clin-4/2008:
 952 c       IF (ABS(IX) .LT. MAXX .AND. ABS(IY) .LT. MAXX .AND.
 953 c     & ABS(IZ) .LT. MAXZ)then
 954         IF(IX.LT.MAXX.AND.IY.LT.MAXX.AND.IZ.LT.MAXZ
 955      1       .AND.IX.GT.-MAXX.AND.IY.GT.-MAXX.AND.IZ.GT.-MAXZ) THEN
 956            den=rho(ix,iy,iz)
 957 c        ecor=0.1973**2*0.255*kmul*4*3.14159*(1.+0.4396/0.938)
 958 c       etotal=sqrt(P(1,i)**2+p(2,I)**2+p(3,i)**2+e(i)**2+ecor*den)
 959 c** for G.Q Li potential form with n_s = n_b and pot(n_0)=29 MeV
 960 c     !! GeV^2 fm^3
 961             akg = 0.1727
 962 c     !! GeV fm^3
 963             bkg = 0.333
 964           rnsg = den
 965           ecor = - akg*rnsg + (bkg*den)**2
 966           etotal = sqrt(P(1,i)**2+p(2,I)**2+p(3,i)**2+e(i)**2 + ecor)
 967           ecor = - akg + 2.*bkg**2*den + 2.*bkg*etotal
 968 c** G.Q. Li potential (END)
 969         CALL GRADUK(IX,IY,IZ,GRADXk,GRADYk,GRADZk)
 970         P(1,I) = P(1,I) - DT * GRADXk*ecor/(2.*etotal)
 971         P(2,I) = P(2,I) - DT * GRADYk*ecor/(2.*etotal)
 972         P(3,I) = P(3,I) - DT * GRADZk*ecor/(2.*etotal)
 973         endif
 974          endif
 975 c
 976         if(kpoten.ne.0.and.lb(i).eq.21)then
 977          den=0.
 978 clin-4/2008:
 979 c           IF (ABS(IX) .LT. MAXX .AND. ABS(IY) .LT. MAXX .AND.
 980 c     &        ABS(IZ) .LT. MAXZ)then
 981          IF(IX.LT.MAXX.AND.IY.LT.MAXX.AND.IZ.LT.MAXZ
 982      1        .AND.IX.GT.-MAXX.AND.IY.GT.-MAXX.AND.IZ.GT.-MAXZ) THEN
 983                den=rho(ix,iy,iz)
 984         CALL GRADUK(IX,IY,IZ,GRADXk,GRADYk,GRADZk)
 985 c        P(1,I) = P(1,I) - DT * GRADXk*(-0.12/0.168)    !! song potential
 986 c        P(2,I) = P(2,I) - DT * GRADYk*(-0.12/0.168)
 987 c        P(3,I) = P(3,I) - DT * GRADZk*(-0.12/0.168)
 988 c** for G.Q Li potential form with n_s = n_b and pot(n_0)=29 MeV
 989 c    !! GeV^2 fm^3
 990             akg = 0.1727
 991 c     !! GeV fm^3
 992             bkg = 0.333
 993           rnsg = den
 994           ecor = - akg*rnsg + (bkg*den)**2
 995           etotal = sqrt(P(1,i)**2+p(2,I)**2+p(3,i)**2+e(i)**2 + ecor)
 996           ecor = - akg + 2.*bkg**2*den - 2.*bkg*etotal
 997         P(1,I) = P(1,I) - DT * GRADXk*ecor/(2.*etotal)
 998         P(2,I) = P(2,I) - DT * GRADYk*ecor/(2.*etotal)
 999         P(3,I) = P(3,I) - DT * GRADZk*ecor/(2.*etotal)
1000 c** G.Q. Li potential (END)
1001         endif
1002          endif
1003 c
1004 c for other mesons, there is no potential
1005        if(j.gt.mass)go to 5800
1006 c  with mean field interaction for baryons   (open endif below) !!sp05
1007 **      if( (iabs(lb(i)).eq.1.or.iabs(lb(i)).eq.2) .or.
1008 **    &     (iabs(lb(i)).ge.6.and.iabs(lb(i)).le.17) .or.
1009 **    &      iabs(lb(i)).eq.40.or.iabs(lb(i)).eq.41 )then
1010         IF (ICOLL .NE. -1) THEN
1011 * check if the baryon has run off the lattice
1012 *             IX0=NINT(R(1,I)/DX)
1013 *             IY0=NINT(R(2,I)/DY)
1014 *             IZ0=NINT(R(3,I)/DZ)
1015 *             IPX0=NINT(P(1,I)/DPX)
1016 *             IPY0=NINT(P(2,I)/DPY)
1017 *             IPZ0=NINT(P(3,I)/DPZ)
1018 *      if ( (abs(ix0).gt.mx) .or. (abs(iy0).gt.my) .or. (abs(iz0).gt.mz)
1019 *     &  .or. (abs(ipx0).gt.mpx) .or. (abs(ipy0)
1020 *     &  .or. (ipz0.lt.-mpz) .or. (ipz0.gt.mpzp)) NLOST=NLOST+1
1021 clin-4/2008:
1022 c              IF (ABS(IX) .LT. MAXX .AND. ABS(IY) .LT. MAXX .AND.
1023 c     &                                    ABS(IZ) .LT. MAXZ     ) THEN
1024            IF(IX.LT.MAXX.AND.IY.LT.MAXX.AND.IZ.LT.MAXZ
1025      1          .AND.IX.GT.-MAXX.AND.IY.GT.-MAXX.AND.IZ.GT.-MAXZ) THEN
1026                 CALL GRADU(IPOT,IX,IY,IZ,GRADX,GRADY,GRADZ)
1027               TZ=0.
1028               GRADXN=0
1029               GRADYN=0
1030               GRADZN=0
1031               GRADXP=0
1032               GRADYP=0
1033               GRADZP=0
1034              IF(ICOU.EQ.1)THEN
1035                 CALL GRADUP(IX,IY,IZ,GRADXP,GRADYP,GRADZP)
1036                 CALL GRADUN(IX,IY,IZ,GRADXN,GRADYN,GRADZN)
1037                IF(ZET(LB(I)).NE.0)TZ=-1
1038                IF(ZET(LB(I)).EQ.0)TZ= 1
1039              END IF
1040            if(iabs(lb(i)).ge.14.and.iabs(lb(i)).le.17)then
1041               facl = 2./3.
1042             elseif(iabs(lb(i)).eq.40.or.iabs(lb(i)).eq.41)then
1043               facl = 1./3.
1044             else
1045               facl = 1.
1046             endif
1047         P(1,I) = P(1,I) - facl*DT * (GRADX+asy*(GRADXN-GRADXP)*TZ)
1048         P(2,I) = P(2,I) - facl*DT * (GRADY+asy*(GRADYN-GRADYP)*TZ)
1049         P(3,I) = P(3,I) - facl*DT * (GRADZ+asy*(GRADZN-GRADZP)*TZ)
1050                 end if
1051               ENDIF
1052 **          endif          !!sp05
1053  5800       CONTINUE
1054  6000       CONTINUE
1055 c print out the average no. of particles in regions where the local
1056 c baryon density is higher than 5*rho0
1057 c       write(1072,'(e10.3,2x,e10.3)')nt*dt,float(nbaryn)/float(num)
1058 C print out the average no. of particles in regions where the local
1059 c energy density is higher than 2 GeV/fm^3.
1060 c       write(1073,'(e10.3,2x,e10.3)')nt*dt,float(nquark)/float(num)
1061 c print out the no. of particles that have run off the lattice
1062 *          IF (NLOST .NE. 0 .AND. (NT/NFREQ)*NFREQ .EQ. NT) THEN
1063 *            WRITE(12,'(5X,''***'',I7,'' TESTPARTICLES LOST AFTER '',
1064 *     &                   ''TIME STEP NUMBER'',I4)') NLOST, NT
1065 *         END IF
1066 *
1067 *       update phase space density
1068 *        call platin(mode,mass,num,dx,dy,dz,dpx,dpy,dpz,fnorm)
1069 *
1070 *       CONTROL-PRINTOUT OF CONFIGURATION (IF REQUIRED)
1071 *
1072 *        if (inout(5) .eq. 2) CALL ENERGY(NT,IPOT,NUM,MASS,EMIN,EMAX)
1073 *
1074 *
1075 * print out central baryon density as a function of time
1076        CDEN=RHO(0,0,0)/0.168
1077 cc        WRITE(1002,990)FLOAT(NT)*DT,CDEN
1078 c        WRITE(1002,1990)FLOAT(NT)*DT,CDEN,denst/real(num)
1079 * print out the central energy density as a function of time
1080 cc        WRITE(1003,990)FLOAT(NT)*DT,PEL(0,0,0)
1081 c        WRITE(1003,1990)FLOAT(NT)*DT,PEL(0,0,0),edenst/real(num)
1082 * print out the no. of pion-like particles as a function of time
1083 c        WRITE(1004,9999)FLOAT(NT)*DT,ALD,ALN,ALP,ALN5,
1084 c     &               ALD+ALN+ALP+0.5*ALN5
1085 * print out the no. of eta-like particles as a function of time
1086 c        WRITE(1005,991)FLOAT(NT)*DT,ALN5,ALE,ALE+0.5*ALN5
1087 c990       FORMAT(E10.3,2X,E10.3)
1088 c1990       FORMAT(E10.3,2X,E10.3,2X,E10.3)
1089 c991       FORMAT(E10.3,2X,E10.3,2X,E10.3,2X,E10.3)
1090 c9999    FORMAT(e10.3,2X,e10.3,2X,E10.3,2X,E10.3,2X,
1091 c     1  E10.3,2X,E10.3)
1092 C THE FOLLOWING OUTPUTS CAN BE TURNED ON/OFF by setting icflow and icrho=0
1093 c print out the baryon and meson density matrix in the reaction plane
1094         IF ((NT/NFREQ)*NFREQ .EQ. NT ) THEN
1095        if(icflow.eq.1)call flow(nt)
1096 cbz11/18/98
1097 c       if(icrho.ne.1)go to 10000
1098 c       if (icrho .eq. 1) then
1099 cbz11/18/98end
1100 c       do ix=-10,10
1101 c       do iz=-10,10
1102 c       write(1053,992)ix,iz,rho(ix,0,iz)/0.168
1103 c       write(1054,992)ix,iz,pirho(ix,0,iz)/0.168
1104 c       write(1055,992)ix,iz,pel(ix,0,iz)
1105 c       end do
1106 c       end do
1107 cbz11/18/98
1108 c        end if
1109 cbz11/18/98end
1110 c992       format(i3,i3,e11.4)
1111        endif
1112 c print out the ENERGY density matrix in the reaction plane
1113 C CHECK LOCAL MOMENTUM EQUILIBRIUM IN EACH CELL,
1114 C AND PERFORM ON-LINE FLOW ANALYSIS AT A FREQUENCY OF NFREQ
1115 c        IF ((NT/NFREQ)*NFREQ .EQ. NT ) THEN
1116 c       call flow(nt)
1117 c       call equ(ipot,mass,num,outpar)
1118 c       do ix=-10,10
1119 c       do iz=-10,10
1120 c       write(1055,992)ix,iz,pel(ix,0,iz)
1121 c       write(1056,992)ix,iz,rxy(ix,0,iz)
1122 c       end do
1123 c       end do
1124 c       endif
1125 C calculate the volume of high BARYON AND ENERGY density
1126 C matter as a function of time
1127 c       vbrho=0.
1128 c       verho=0.
1129 c       do ix=-20,20
1130 c       do iy=-20,20
1131 c       do iz=-20,20
1132 c       if(rho(ix,iy,iz)/0.168.gt.5.)vbrho=vbrho+1.
1133 c       if(pel(ix,iy,iz).gt.2.)verho=verho+1.
1134 c       end do
1135 c       end do
1136 c       end do
1137 c       write(1081,993)dt*nt,vbrho
1138 c       write(1082,993)dt*nt,verho
1139 c993       format(e11.4,2x,e11.4)
1140 *-----------------------------------------------------------------------
1141 cbz11/16/98
1142 c.....for read-in initial conditions produce particles from read-in
1143 c.....common block.
1144 c.....note that this part is only for cascade with number of test particles
1145 c.....NUM = 1.
1146       IF (IAPAR2(1) .NE. 1) THEN
1147          CT = NT * DT
1148 cbz12/22/98
1149 c         NP = MASSR(1)
1150 c         DO WHILE (FTAR(NPI) .GT. CT - DT .AND. FTAR(NPI) .LE. CT)
1151 c            NP = NP + 1
1152 c            R(1, NP) = GXAR(NPI) + PXAR(NPI) / PEAR(NPI) * (CT - FTAR(NPI))
1153 c            R(2, NP) = GYAR(NPI) + PYAR(NPI) / PEAR(NPI) * (CT - FTAR(NPI))
1154 c            R(3, NP) = GZAR(NPI) + PZAR(NPI) / PEAR(NPI) * (CT - FTAR(NPI))
1155 c            P(1, NP) = PXAR(NPI)
1156 c            P(2, NP) = PYAR(NPI)
1157 c            P(3, NP) = PZAR(NPI)
1158 c            E(NP) = XMAR(NPI)
1159 c            LB(NP) = IARFLV(ITYPAR(NPI))
1160 c            NPI = NPI + 1
1161 c         END DO
1162 c         MASSR(1) = NP
1163          IA = 0
1164          DO 1028 IRUN = 1, NUM
1165             DO 1027 IC = 1, MASSR(IRUN)
1166                IE = IA + IC
1167                RT(1, IC, IRUN) = R(1, IE)
1168                RT(2, IC, IRUN) = R(2, IE)
1169                RT(3, IC, IRUN) = R(3, IE)
1170                PT(1, IC, IRUN) = P(1, IE)
1171                PT(2, IC, IRUN) = P(2, IE)
1172                PT(3, IC, IRUN) = P(3, IE)
1173                ET(IC, IRUN) = E(IE)
1174                LT(IC, IRUN) = LB(IE)
1175 c         !! sp 12/19/00
1176                PROT(IC, IRUN) = PROPER(IE)
1177 clin-5/2008:
1178                dpertt(IC, IRUN)=dpertp(IE)
1179  1027       CONTINUE
1180             NP = MASSR(IRUN)
1181             NP1 = NPI(IRUN)
1182
1183 cbz10/05/99
1184 c            DO WHILE (FT1(NP1, IRUN) .GT. CT - DT .AND.
1185 c     &           FT1(NP1, IRUN) .LE. CT)
1186 cbz10/06/99
1187 c            DO WHILE (NPI(IRUN).LE.MULTI1(IRUN).AND.
1188 cbz10/06/99 end
1189 clin-11/13/00 finally read in all unformed particles and do the decays in ART:
1190 c           DO WHILE (NP1.LE.MULTI1(IRUN).AND.
1191 c    &           FT1(NP1, IRUN) .GT. CT - DT .AND.
1192 c    &           FT1(NP1, IRUN) .LE. CT)
1193 c
1194                ctlong = ct
1195              if(nt .eq. (ntmax-1))then
1196                ctlong = 1.E30
1197              elseif(nt .eq. ntmax)then
1198                go to 1111
1199              endif
1200             DO WHILE (NP1.LE.MULTI1(IRUN).AND.
1201      &           FT1(NP1, IRUN) .GT. (CT - DT) .AND.
1202      &           FT1(NP1, IRUN) .LE. ctlong)
1203                NP = NP + 1
1204                UDT = (CT - FT1(NP1, IRUN)) / EE1(NP1, IRUN)
1205 clin-10/28/03 since all unformed hadrons at time ct are read in at nt=ntmax-1,
1206 c     their positions should not be propagated to time ct:
1207                if(nt.eq.(ntmax-1)) then
1208                   ftsvt(NP,IRUN)=FT1(NP1, IRUN)
1209                   if(FT1(NP1, IRUN).gt.ct) UDT=0.
1210                endif
1211                RT(1, NP, IRUN) = GX1(NP1, IRUN) +
1212      &              PX1(NP1, IRUN) * UDT
1213                RT(2, NP, IRUN) = GY1(NP1, IRUN) +
1214      &              PY1(NP1, IRUN) * UDT
1215                RT(3, NP, IRUN) = GZ1(NP1, IRUN) +
1216      &              PZ1(NP1, IRUN) * UDT
1217                PT(1, NP, IRUN) = PX1(NP1, IRUN)
1218                PT(2, NP, IRUN) = PY1(NP1, IRUN)
1219                PT(3, NP, IRUN) = PZ1(NP1, IRUN)
1220                ET(NP, IRUN) = XM1(NP1, IRUN)
1221                LT(NP, IRUN) = IARFLV(ITYP1(NP1, IRUN))
1222 clin-5/2008:
1223                dpertt(NP,IRUN)=dpp1(NP1,IRUN)
1224 clin-4/30/03 ctest off
1225 c     record initial phi,K*,Lambda(1520) resonances formed during the timestep:
1226 c               if(LT(NP, IRUN).eq.29.or.iabs(LT(NP, IRUN)).eq.30)
1227 c     1              write(17,112) 'formed',LT(NP, IRUN),PX1(NP1, IRUN),
1228 c     2 PY1(NP1, IRUN),PZ1(NP1, IRUN),XM1(NP1, IRUN),nt
1229 c 112           format(a10,1x,I4,4(1x,f9.3),1x,I4)
1230 c
1231                NP1 = NP1 + 1
1232 c     !! sp 12/19/00
1233                PROT(NP, IRUN) = 1.
1234             END DO
1235 *
1236  1111      continue
1237             NPI(IRUN) = NP1
1238             IA = IA + MASSR(IRUN)
1239             MASSR(IRUN) = NP
1240  1028    CONTINUE
1241          IA = 0
1242          DO 1030 IRUN = 1, NUM
1243             IA = IA + MASSR(IRUN - 1)
1244             DO 1029 IC = 1, MASSR(IRUN)
1245                IE = IA + IC
1246                R(1, IE) = RT(1, IC, IRUN)
1247                R(2, IE) = RT(2, IC, IRUN)
1248                R(3, IE) = RT(3, IC, IRUN)
1249                P(1, IE) = PT(1, IC, IRUN)
1250                P(2, IE) = PT(2, IC, IRUN)
1251                P(3, IE) = PT(3, IC, IRUN)
1252                E(IE) = ET(IC, IRUN)
1253                LB(IE) = LT(IC, IRUN)
1254 c     !! sp 12/19/00
1255                PROPER(IE) = PROT(IC, IRUN)
1256                if(nt.eq.(ntmax-1)) ftsv(IE)=ftsvt(IC,IRUN)
1257 clin-5/2008:
1258                dpertp(IE)=dpertt(IC, IRUN)
1259  1029       CONTINUE
1260 clin-3/2009 Moved here to better take care of freezeout spacetime:
1261             call hbtout(MASSR(IRUN),nt,ntmax)
1262  1030    CONTINUE
1263 cbz12/22/98end
1264       END IF
1265 cbz11/16/98end
1266
1267 clin-5/2009 ctest off:
1268 c      call flowh(ct)
1269
1270 10000       continue
1271
1272 *                                                                      *
1273 *       ==============  END OF TIME STEP LOOP   ================       *
1274
1275 ************************************
1276 *     WRITE OUT particle's MOMENTA ,and/OR COORDINATES ,
1277 *     label and/or their local baryon density in the final state
1278         iss=0
1279         do 1032 lrun=1,num
1280            iss=iss+massr(lrun-1)
1281            do 1031 l0=1,massr(lrun)
1282               ipart=iss+l0
1283  1031      continue
1284  1032   continue
1285
1286 cbz11/16/98
1287       IF (IAPAR2(1) .NE. 1) THEN
1288 cbz12/22/98
1289 c        NSH = MASSR(1) - NPI + 1
1290 c        IAINT2(1) = IAINT2(1) + NSH
1291 c.....to shift the unformed particles to the end of the common block
1292 c        IF (NSH .GT. 0) THEN
1293 c           IB = IAINT2(1)
1294 c           IE = MASSR(1) + 1
1295 c           II = -1
1296 c        ELSE IF (NSH .LT. 0) THEN
1297 c           IB = MASSR(1) + 1
1298 c           IE = IAINT2(1)
1299 c           II = 1
1300 c        END IF
1301 c        IF (NSH .NE. 0) THEN
1302 c           DO I = IB, IE, II
1303 c              J = I - NSH
1304 c              ITYPAR(I) = ITYPAR(J)
1305 c              GXAR(I) = GXAR(J)
1306 c              GYAR(I) = GYAR(J)
1307 c              GZAR(I) = GZAR(J)
1308 c              FTAR(I) = FTAR(J)
1309 c              PXAR(I) = PXAR(J)
1310 c              PYAR(I) = PYAR(J)
1311 c              PZAR(I) = PZAR(J)
1312 c              PEAR(I) = PEAR(J)
1313 c              XMAR(I) = XMAR(J)
1314 c           END DO
1315 c        END IF
1316
1317 c.....to copy ART particle info to COMMON /ARPRC/
1318 c        DO I = 1, MASSR(1)
1319 c           ITYPAR(I) = INVFLV(LB(I))
1320 c           GXAR(I) = R(1, I)
1321 c           GYAR(I) = R(2, I)
1322 c           GZAR(I) = R(3, I)
1323 c           FTAR(I) = CT
1324 c           PXAR(I) = P(1, I)
1325 c           PYAR(I) = P(2, I)
1326 c           PZAR(I) = P(3, I)
1327 c           XMAR(I) = E(I)
1328 c           PEAR(I) = SQRT(PXAR(I) ** 2 + PYAR(I) ** 2 + PZAR(I) ** 2
1329 c     &        + XMAR(I) ** 2)
1330 c        END DO
1331         IA = 0
1332         DO 1035 IRUN = 1, NUM
1333            IA = IA + MASSR(IRUN - 1)
1334            NP1 = NPI(IRUN)
1335            NSH = MASSR(IRUN) - NP1 + 1
1336            MULTI1(IRUN) = MULTI1(IRUN) + NSH
1337 c.....to shift the unformed particles to the end of the common block
1338            IF (NSH .GT. 0) THEN
1339               IB = MULTI1(IRUN)
1340               IE = MASSR(IRUN) + 1
1341               II = -1
1342            ELSE IF (NSH .LT. 0) THEN
1343               IB = MASSR(IRUN) + 1
1344               IE = MULTI1(IRUN)
1345               II = 1
1346            END IF
1347            IF (NSH .NE. 0) THEN
1348               DO 1033 I = IB, IE, II
1349                  J = I - NSH
1350                  ITYP1(I, IRUN) = ITYP1(J, IRUN)
1351                  GX1(I, IRUN) = GX1(J, IRUN)
1352                  GY1(I, IRUN) = GY1(J, IRUN)
1353                  GZ1(I, IRUN) = GZ1(J, IRUN)
1354                  FT1(I, IRUN) = FT1(J, IRUN)
1355                  PX1(I, IRUN) = PX1(J, IRUN)
1356                  PY1(I, IRUN) = PY1(J, IRUN)
1357                  PZ1(I, IRUN) = PZ1(J, IRUN)
1358                  EE1(I, IRUN) = EE1(J, IRUN)
1359                  XM1(I, IRUN) = XM1(J, IRUN)
1360 c     !! sp 12/19/00
1361                  PRO1(I, IRUN) = PRO1(J, IRUN)
1362 clin-5/2008:
1363                  dpp1(I,IRUN)=dpp1(J,IRUN)
1364  1033         CONTINUE
1365            END IF
1366
1367 c.....to copy ART particle info to COMMON /ARPRC1/
1368            DO 1034 I = 1, MASSR(IRUN)
1369               IB = IA + I
1370               ITYP1(I, IRUN) = INVFLV(LB(IB))
1371               GX1(I, IRUN) = R(1, IB)
1372               GY1(I, IRUN) = R(2, IB)
1373               GZ1(I, IRUN) = R(3, IB)
1374 clin-10/28/03:
1375 c since all unformed hadrons at time ct are read in at nt=ntmax-1,
1376 c their formation time ft1 should be kept to determine their freezeout(x,t):
1377 c              FT1(I, IRUN) = CT
1378               if(FT1(I, IRUN).lt.CT) FT1(I, IRUN) = CT
1379               PX1(I, IRUN) = P(1, IB)
1380               PY1(I, IRUN) = P(2, IB)
1381               PZ1(I, IRUN) = P(3, IB)
1382               XM1(I, IRUN) = E(IB)
1383               EE1(I, IRUN) = SQRT(PX1(I, IRUN) ** 2 +
1384      &             PY1(I, IRUN) ** 2 +
1385      &             PZ1(I, IRUN) ** 2 +
1386      &             XM1(I, IRUN) ** 2)
1387 c     !! sp 12/19/00
1388               PRO1(I, IRUN) = PROPER(IB)
1389  1034      CONTINUE
1390  1035   CONTINUE
1391 cbz12/22/98end
1392       END IF
1393 cbz11/16/98end
1394 c
1395 **********************************
1396 *                                                                      *
1397 *       ======= END OF MANY LOOPS OVER IMPACT PARAMETERS ==========    *
1398 *                                                               *
1399 **********************************
1400 50000   CONTINUE
1401 *
1402 *-----------------------------------------------------------------------
1403 *                       ==== ART COMPLETED ====
1404 *-----------------------------------------------------------------------
1405 cbz11/16/98
1406 c      STOP
1407       RETURN
1408 cbz11/16/98end
1409       END
1410 **********************************
1411       subroutine coulin(masspr,massta,NUM)
1412 *                                                                      *
1413 *     purpose:   initialization of array zet() and lb() for all runs  *
1414 *                lb(i) = 1   =>  proton                               *
1415 *                lb(i) = 2   =>  neutron                              *
1416 **********************************
1417         integer  zta,zpr
1418         PARAMETER (MAXSTR=150001)
1419         common  /EE/ ID(MAXSTR),LB(MAXSTR)
1420 cc      SAVE /EE/
1421         COMMON  /ZZ/ ZTA,ZPR
1422 cc      SAVE /zz/
1423       SAVE
1424         MASS=MASSTA+MASSPR
1425         DO 500 IRUN=1,NUM
1426         do 100 i = 1+(IRUN-1)*MASS,zta+(IRUN-1)*MASS
1427         LB(i) = 1
1428   100   continue
1429         do 200 i = zta+1+(IRUN-1)*MASS,massta+(IRUN-1)*MASS
1430         LB(i) = 2
1431   200   continue
1432         do 300 i = massta+1+(IRUN-1)*MASS,massta+zpr+(IRUN-1)*MASS
1433         LB(i) = 1
1434   300   continue
1435         do 400 i = massta+zpr+1+(IRUN-1)*MASS,
1436      1  massta+masspr+(IRUN-1)*MASS
1437         LB(i) = 2
1438   400   continue
1439   500   CONTINUE
1440         return
1441         end
1442 **********************************
1443 *                                                                      *
1444       SUBROUTINE RELCOL(LCOLL,LBLOC,LCNNE,LDD,LPP,lppk,
1445      &LPN,lpd,lrho,lomega,LKN,LNNK,LDDK,LNDK,LCNND,LCNDN,
1446      &LDIRT,LDECAY,LRES,LDOU,LDDRHO,LNNRHO,LNNOM,
1447      &NT,ntmax,sp,akaon,sk)
1448 *                                                                      *
1449 *       PURPOSE:    CHECK CONDITIONS AND CALCULATE THE KINEMATICS      *
1450 *                   FOR BINARY COLLISIONS AMONG PARTICLES              *
1451 *                                 - RELATIVISTIC FORMULA USED          *
1452 *                                                                      *
1453 *       REFERENCES: HAGEDORN, RELATIVISTIC KINEMATICS (1963)           *
1454 *                                                                      *
1455 *       VARIABLES:                                                     *
1456 *         MASSPR  - NUMBER OF NUCLEONS IN PROJECTILE   (INTEGER,INPUT) *
1457 *         MASSTA  - NUMBER OF NUCLEONS IN TARGET       (INTEGER,INPUT) *
1458 *         NUM     - NUMBER OF TESTPARTICLES PER NUCLEON(INTEGER,INPUT) *
1459 *         ISEED   - SEED FOR RANDOM NUMBER GENERATOR   (INTEGER,INPUT) *
1460 *         IAVOID  - (= 1 => AVOID FIRST CLLISIONS WITHIN THE SAME      *
1461 *                   NUCLEUS, ELSE ALL COLLISIONS)      (INTEGER,INPUT) *
1462 *         DELTAR  - MAXIMUM SPATIAL DISTANCE FOR WHICH A COLLISION     *
1463 *                   STILL CAN OCCUR                       (REAL,INPUT) *
1464 *         DT      - TIME STEP SIZE                        (REAL,INPUT) *
1465 *         LCOLL   - NUMBER OF COLLISIONS              (INTEGER,OUTPUT) *
1466 *         LBLOC   - NUMBER OF PULI-BLOCKED COLLISIONS (INTEGER,OUTPUT) *
1467 *         LCNNE   - NUMBER OF ELASTIC COLLISION       (INTEGER,OUTPUT) *
1468 *         LCNND   - NUMBER OF N+N->N+DELTA REACTION   (INTEGER,OUTPUT) *
1469 *         LCNDN   - NUMBER OF N+DELTA->N+N REACTION   (INTEGER,OUTPUT) *
1470 *         LDD     - NUMBER OF RESONANCE+RESONANCE COLLISIONS
1471 *         LPP     - NUMBER OF PION+PION elastic COLIISIONS
1472 *         lppk    - number of pion(RHO,OMEGA)+pion(RHO,OMEGA)
1473 *                   -->K+K- collisions
1474 *         LPN     - NUMBER OF PION+N-->KAON+X
1475 *         lpd     - number of pion+n-->delta+pion
1476 *         lrho    - number of pion+n-->Delta+rho
1477 *         lomega  - number of pion+n-->Delta+omega
1478 *         LKN     - NUMBER OF KAON RESCATTERINGS
1479 *         LNNK    - NUMBER OF bb-->kAON PROCESS
1480 *         LDDK    - NUMBER OF DD-->KAON PROCESS
1481 *         LNDK    - NUMBER OF ND-->KAON PROCESS
1482 *         LB(I) IS USED TO LABEL PARTICLE'S CHARGE STATE
1483 *         LB(I)   =
1484 cbali2/7/99
1485 *                 -45 Omega baryon(bar)
1486 *                 -41 cascade0(bar)
1487 *                 -40 cascade-(bar)
1488 clin-11/07/00:
1489 *                 -30 K*-
1490 *                 -17 sigma+(bar)
1491 *                 -16 sigma0(bar)
1492 *                 -15 sigma-(bar)
1493 *                 -14 LAMBDA(bar)
1494 clin-8/29/00
1495 *                 -13 anti-N*(+1)(1535),s_11
1496 *                 -12 anti-N*0(1535),s_11
1497 *                 -11 anti-N*(+1)(1440),p_11
1498 *                 -10 anti-N*0(1440), p_11
1499 *                  -9 anti-DELTA+2
1500 *                  -8 anti-DELTA+1
1501 *                  -7 anti-DELTA0
1502 *                  -6 anti-DELTA-1
1503 *
1504 *                  -2 antineutron
1505 *                  -1 antiproton
1506 cbali2/7/99end
1507 *                   0 eta
1508 *                   1 PROTON
1509 *                   2 NUETRON
1510 *                   3 PION-
1511 *                   4 PION0
1512 *                   5 PION+
1513 *                   6 DELTA-1
1514 *                   7 DELTA0
1515 *                   8 DELTA+1
1516 *                   9 DELTA+2
1517 *                   10 N*0(1440), p_11
1518 *                   11 N*(+1)(1440),p_11
1519 *                  12 N*0(1535),s_11
1520 *                  13 N*(+1)(1535),s_11
1521 *                  14 LAMBDA
1522 *                   15 sigma-
1523 *                   16 sigma0
1524 *                   17 sigma+
1525 *                   21 kaon-
1526 clin-2/23/03        22 Kaon0Long (converted at the last timestep)
1527 *                   23 KAON+
1528 *                   24 Kaon0short (converted at the last timestep then decay)
1529 *                   25 rho-
1530 *                   26 rho0
1531 *                   27 rho+
1532 *                   28 omega meson
1533 *                   29 phi
1534 *                   30 K*+
1535 * sp01/03/01
1536 *                   31 eta-prime
1537 *                   40 cascade-
1538 *                   41 cascade0
1539 *                   45 Omega baryon
1540 * sp01/03/01 end
1541 *
1542 *                   ++  ------- SEE NOTE BOOK
1543 *         NSTAR=1 INCLUDING N* RESORANCE
1544 *         ELSE DELTA RESORANCE ONLY
1545 *         NDIRCT=1 INCLUDING DIRECT PROCESS,ELSE NOT
1546 *         DIR - PERCENTAGE OF DIRECT PION PRODUCTION PROCESS
1547 **********************************
1548       PARAMETER      (MAXSTR=150001,MAXR=1,PI=3.1415926)
1549       parameter      (MX=4,MY=4,MZ=8,MPX=4,MPY=4,mpz=10,mpzp=10)
1550       PARAMETER      (AKA=0.498,ALA=1.1157,ASA=1.1974,aks=0.895)
1551       PARAMETER      (AA1=1.26,APHI=1.02,AP1=0.13496)
1552       parameter            (maxx=20,maxz=24)
1553       parameter            (rrkk=0.6,prkk=0.3,srhoks=5.,ESBIN=0.04)
1554       DIMENSION MASSRN(0:MAXR),RT(3,MAXSTR),PT(3,MAXSTR),ET(MAXSTR)
1555       DIMENSION LT(MAXSTR), PROT(MAXSTR)
1556       COMMON   /AA/  R(3,MAXSTR)
1557 cc      SAVE /AA/
1558       COMMON   /BB/  P(3,MAXSTR)
1559 cc      SAVE /BB/
1560       COMMON   /CC/  E(MAXSTR)
1561 cc      SAVE /CC/
1562       COMMON  /DD/      RHO(-MAXX:MAXX,-MAXX:MAXX,-MAXZ:MAXZ),
1563      &                     RHOP(-MAXX:MAXX,-MAXX:MAXX,-MAXZ:MAXZ),
1564      &                     RHON(-MAXX:MAXX,-MAXX:MAXX,-MAXZ:MAXZ)
1565 cc      SAVE /DD/
1566       COMMON   /EE/  ID(MAXSTR),LB(MAXSTR)
1567 cc      SAVE /EE/
1568       COMMON   /HH/  PROPER(MAXSTR)
1569 cc      SAVE /HH/
1570       common /ff/f(-mx:mx,-my:my,-mz:mz,-mpx:mpx,-mpy:mpy,-mpz:mpzp)
1571 cc      SAVE /ff/
1572       common   /gg/  dx,dy,dz,dpx,dpy,dpz
1573 cc      SAVE /gg/
1574       COMMON   /INPUT/ NSTAR,NDIRCT,DIR
1575 cc      SAVE /INPUT/
1576       COMMON   /NN/NNN
1577 cc      SAVE /NN/
1578       COMMON   /RR/  MASSR(0:MAXR)
1579 cc      SAVE /RR/
1580       common   /ss/  inout(20)
1581 cc      SAVE /ss/
1582       COMMON   /BG/BETAX,BETAY,BETAZ,GAMMA
1583 cc      SAVE /BG/
1584       COMMON   /RUN/NUM
1585 cc      SAVE /RUN/
1586       COMMON   /PA/RPION(3,MAXSTR,MAXR)
1587 cc      SAVE /PA/
1588       COMMON   /PB/PPION(3,MAXSTR,MAXR)
1589 cc      SAVE /PB/
1590       COMMON   /PC/EPION(MAXSTR,MAXR)
1591 cc      SAVE /PC/
1592       COMMON   /PD/LPION(MAXSTR,MAXR)
1593 cc      SAVE /PD/
1594       COMMON   /PE/PROPI(MAXSTR,MAXR)
1595 cc      SAVE /PE/
1596       COMMON   /KKK/TKAON(7),EKAON(7,0:2000)
1597 cc      SAVE /KKK/
1598       COMMON  /KAON/    AK(3,50,36),SPECK(50,36,7),MF
1599 cc      SAVE /KAON/
1600       COMMON/TABLE/ xarray(0:1000),earray(0:1000)
1601 cc      SAVE /TABLE/
1602       common/input1/ MASSPR,MASSTA,ISEED,IAVOID,DT
1603 cc      SAVE /input1/
1604       common/leadng/lb1,px1,py1,pz1,em1,e1,xfnl,yfnl,zfnl,tfnl,
1605      1 px1n,py1n,pz1n,dp1n
1606 cc      SAVE /leadng/
1607       COMMON/tdecay/tfdcy(MAXSTR),tfdpi(MAXSTR,MAXR),tft(MAXSTR)
1608 cc      SAVE /tdecay/
1609       common /lastt/itimeh,bimp
1610 cc      SAVE /lastt/
1611 c
1612       COMMON/ppbmas/niso(15),nstate,ppbm(15,2),thresh(15),weight(15)
1613 cc      SAVE /ppbmas/
1614       common/ppb1/ene,factr2(6),fsum,ppinnb,s,wtot
1615 cc      SAVE /ppb1/
1616       common/ppmm/pprr,ppee,pppe,rpre,xopoe,rree
1617 cc      SAVE /ppmm/
1618       COMMON/hbt/lblast(MAXSTR),xlast(4,MAXSTR),plast(4,MAXSTR),nlast
1619 cc      SAVE /hbt/
1620       common/resdcy/NSAV,iksdcy
1621 cc      SAVE /resdcy/
1622       COMMON/RNDF77/NSEED
1623 cc      SAVE /RNDF77/
1624       COMMON/FTMAX/ftsv(MAXSTR),ftsvt(MAXSTR, MAXR)
1625       dimension ftpisv(MAXSTR,MAXR),fttemp(MAXSTR)
1626       common /dpi/em2,lb2
1627       common/phidcy/iphidcy,pttrig,ntrig,maxmiss
1628 clin-5/2008:
1629       DIMENSION dptemp(MAXSTR)
1630       common /para8/ idpert,npertd,idxsec
1631       COMMON /dpert/dpertt(MAXSTR,MAXR),dpertp(MAXSTR),dplast(MAXSTR),
1632      1     dpdcy(MAXSTR),dpdpi(MAXSTR,MAXR),dpt(MAXSTR, MAXR),
1633      2     dpp1(MAXSTR,MAXR),dppion(MAXSTR,MAXR)
1634 c
1635       real zet(-45:45)
1636       SAVE
1637       data zet /
1638      4     1.,0.,0.,0.,0.,
1639      3     1.,0.,0.,0.,0.,0.,0.,0.,0.,0.,
1640      2     -1.,0.,0.,0.,0.,0.,0.,0.,0.,0.,
1641      1     0.,0.,0.,-1.,0.,1.,0.,-1.,0.,-1.,
1642      s     0.,-2.,-1.,0.,1.,0.,0.,0.,0.,-1.,
1643      e     0.,
1644      s     1.,0.,-1.,0.,1.,-1.,0.,1.,2.,0.,
1645      1     1.,0.,1.,0.,-1.,0.,1.,0.,0.,0.,
1646      2     -1.,0.,1.,0.,-1.,0.,1.,0.,0.,1.,
1647      3     0.,0.,0.,0.,0.,0.,0.,0.,0.,-1.,
1648      4     0.,0.,0.,0.,-1./
1649
1650 clin-2/19/03 initialize n and nsav for resonance decay at each timestep
1651 c     in order to prevent integer overflow:
1652       call inidcy
1653
1654 c OFF skip ART collisions to reproduce HJ:
1655 cc       if(nt.ne.ntmax) return
1656
1657 clin-11/07/00 rrkk is assumed to be 0.6mb(default) for mm->KKbar
1658 c     with m=rho or omega, estimated from Ko's paper:
1659 c      rrkk=0.6
1660 c prkk: cross section of pi (rho or omega) -> K* Kbar (AND) K*bar K:
1661 c      prkk=0.3
1662 c     cross section in mb for (rho or omega) K* -> pi K:
1663 c      srhoks=5.
1664 clin-11/07/00-end
1665 c      ESBIN=0.04
1666       RESONA=5.
1667 *-----------------------------------------------------------------------
1668 *     INITIALIZATION OF COUNTING VARIABLES
1669       NODELT=0
1670       SUMSRT =0.
1671       LCOLL  = 0
1672       LBLOC  = 0
1673       LCNNE  = 0
1674       LDD  = 0
1675       LPP  = 0
1676       lpd  = 0
1677       lpdr=0
1678       lrho = 0
1679       lrhor=0
1680       lomega=0
1681       lomgar=0
1682       LPN  = 0
1683       LKN  = 0
1684       LNNK = 0
1685       LDDK = 0
1686       LNDK = 0
1687       lppk =0
1688       LCNND  = 0
1689       LCNDN  = 0
1690       LDIRT  = 0
1691       LDECAY = 0
1692       LRES   = 0
1693       Ldou   = 0
1694       LDDRHO = 0
1695       LNNRHO = 0
1696       LNNOM  = 0
1697       MSUM   = 0
1698       MASSRN(0)=0
1699 * COM: MSUM IS USED TO COUNT THE TOTAL NO. OF PARTICLES
1700 *      IN PREVIOUS IRUN-1 RUNS
1701 * KAON COUNTERS
1702       DO 1002 IL=1,5
1703          TKAON(IL)=0
1704          DO 1001 IS=1,2000
1705             EKAON(IL,IS)=0
1706  1001    CONTINUE
1707  1002 CONTINUE
1708 c sp 12/19/00
1709       DO 1004 i =1,NUM
1710          DO 1003 j =1,MAXSTR
1711             PROPI(j,i) = 1.
1712  1003    CONTINUE
1713  1004 CONTINUE
1714
1715       do 1102 i=1,maxstr
1716          fttemp(i)=0.
1717          do 1101 irun=1,maxr
1718             ftpisv(i,irun)=0.
1719  1101    continue
1720  1102 continue
1721
1722 c sp 12/19/00 end
1723       sp=0
1724 * antikaon counters
1725       akaon=0
1726       sk=0
1727 *-----------------------------------------------------------------------
1728 *     LOOP OVER ALL PARALLEL RUNS
1729 cbz11/17/98
1730 c      MASS=MASSPR+MASSTA
1731       MASS = 0
1732 cbz11/17/98end
1733       DO 1000 IRUN = 1,NUM
1734          NNN=0
1735          MSUM=MSUM+MASSR(IRUN-1)
1736 *     LOOP OVER ALL PSEUDOPARTICLES 1 IN THE SAME RUN
1737          J10=2
1738          IF(NT.EQ.NTMAX)J10=1
1739 c
1740 ctest off skips the check of energy conservation after each timestep:
1741 c         enetot=0.
1742 c         do ip=1,MASSR(IRUN)
1743 c            if(e(ip).ne.0.or.lb(ip).eq.10022) enetot=enetot
1744 c     1           +sqrt(p(1,ip)**2+p(2,ip)**2+p(3,ip)**2+e(ip)**2)
1745 c         enddo
1746 c         write(91,*) 'A:',nt,enetot,massr(irun),bimp
1747
1748          DO 800 J1 = J10,MASSR(IRUN)
1749             I1  = J1 + MSUM
1750 * E(I)=0 are for pions having been absorbed or photons which do not enter here:
1751             IF(E(I1).EQ.0.)GO TO 800
1752
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             IF (LB(I1) .LT. -45 .OR. LB(I1) .GT. 45) GOTO 800
1757             X1  = R(1,I1)
1758             Y1  = R(2,I1)
1759             Z1  = R(3,I1)
1760             PX1 = P(1,I1)
1761             PY1 = P(2,I1)
1762             PZ1 = P(3,I1)
1763             EM1 = E(I1)
1764             am1= em1
1765             E1  = SQRT( EM1**2 + PX1**2 + PY1**2 + PZ1**2 )
1766             ID1 = ID(I1)
1767             LB1 = LB(I1)
1768
1769 c     generate k0short and k0long from K+ and K- at the last timestep:
1770             if(nt.eq.ntmax.and.(lb1.eq.21.or.lb1.eq.23)) then
1771                pk0=RANART(NSEED)
1772                if(pk0.lt.0.25) then
1773                   LB(I1)=22
1774                elseif(pk0.lt.0.50) then
1775                   LB(I1)=24
1776                endif
1777                LB1=LB(I1)
1778             endif
1779
1780 clin-8/07/02 these particles don't decay strongly, so skip decay routines:
1781 c            IF( (lb1.ge.-2.and.lb1.le.5) .OR. lb1.eq.31 .OR.
1782 c     &           (iabs(lb1).ge.14.and.iabs(lb1).le.24) .OR.
1783 c     &           (iabs(lb1).ge.40.and.iabs(lb1).le.45) .or.
1784 c     &           lb1.eq.31)GO TO 1
1785 c     only decay K0short when iksdcy=1:
1786             if(lb1.eq.0.or.lb1.eq.25.or.lb1.eq.26.or.lb1.eq.27
1787      &           .or.lb1.eq.28.or.lb1.eq.29.or.iabs(lb1).eq.30
1788      &           .or.(iabs(lb1).ge.6.and.iabs(lb1).le.13)
1789      &           .or.(iksdcy.eq.1.and.lb1.eq.24)
1790      &           .or.iabs(lb1).eq.16) then
1791                continue
1792             else
1793                goto 1
1794             endif
1795 * IF I1 IS A RESONANCE, CHECK WHETHER IT DECAYS DURING THIS TIME STEP
1796          IF(lb1.ge.25.and.lb1.le.27) then
1797              wid=0.151
1798          ELSEIF(lb1.eq.28) then
1799              wid=0.00841
1800          ELSEIF(lb1.eq.29) then
1801              wid=0.00443
1802           ELSEIF(iabs(LB1).eq.30) then
1803              WID=0.051
1804          ELSEIF(lb1.eq.0) then
1805              wid=1.18e-6
1806 c     to give K0short ct0=2.676cm:
1807          ELSEIF(iksdcy.eq.1.and.lb1.eq.24) then
1808              wid=7.36e-15
1809 clin-4/29/03 add Sigma0 decay to Lambda, ct0=2.22E-11m:
1810          ELSEIF(iabs(lb1).eq.16) then
1811              wid=8.87e-6
1812 csp-07/25/01 test a1 resonance:
1813 cc          ELSEIF(LB1.EQ.32) then
1814 cc             WID=0.40
1815           ELSEIF(LB1.EQ.32) then
1816              call WIDA1(EM1,rhomp,WID,iseed)
1817           ELSEIF(iabs(LB1).ge.6.and.iabs(LB1).le.9) then
1818              WID=WIDTH(EM1)
1819           ELSEIF((iabs(LB1).EQ.10).OR.(iabs(LB1).EQ.11)) then
1820              WID=W1440(EM1)
1821           ELSEIF((iabs(LB1).EQ.12).OR.(iabs(LB1).EQ.13)) then
1822              WID=W1535(EM1)
1823           ENDIF
1824
1825 * if it is the last time step, FORCE all resonance to strong-decay
1826 * and go out of the loop
1827           if(nt.eq.ntmax)then
1828              pdecay=1.1
1829 clin-5b/2008 forbid phi decay at the end of hadronic cascade:
1830              if(iphidcy.eq.0.and.iabs(LB1).eq.29) pdecay=0.
1831 cpchrist forbid K* decay at the end of hadronic cascade:
1832              if(ikstardcy.eq.0.and.iabs(LB1).eq.30) pdecay=0.
1833           else
1834              T0=0.19733/WID
1835              GFACTR=E1/EM1
1836              T0=T0*GFACTR
1837              IF(T0.GT.0.)THEN
1838                 PDECAY=1.-EXP(-DT/T0)
1839              ELSE
1840                 PDECAY=0.
1841              ENDIF
1842           endif
1843           XDECAY=RANART(NSEED)
1844
1845 cc dilepton production from rho0, omega, phi decay
1846 cc        if(lb1.eq.26 .or. lb1.eq.28 .or. lb1.eq.29)
1847 cc     &   call dec_ceres(nt,ntmax,irun,i1)
1848 cc
1849           IF(XDECAY.LT.PDECAY) THEN
1850 clin-10/25/02 get rid of argument usage mismatch in rhocay():
1851              idecay=irun
1852              tfnl=nt*dt
1853 clin-10/28/03 keep formation time of hadrons unformed at nt=ntmax-1:
1854              if(nt.eq.ntmax.and.ftsv(i1).gt.((ntmax-1)*dt))
1855      1            tfnl=ftsv(i1)
1856              xfnl=x1
1857              yfnl=y1
1858              zfnl=z1
1859 * use PYTHIA to perform decays of eta,rho,omega,phi,K*,(K0s) and Delta:
1860              if(lb1.eq.0.or.lb1.eq.25.or.lb1.eq.26.or.lb1.eq.27
1861      &           .or.lb1.eq.28.or.lb1.eq.29.or.iabs(lb1).eq.30
1862      &           .or.(iabs(lb1).ge.6.and.iabs(lb1).le.9)
1863      &           .or.(iksdcy.eq.1.and.lb1.eq.24)
1864      &           .or.iabs(lb1).eq.16) then
1865 c     previous rho decay performed in rhodecay():
1866 c                nnn=nnn+1
1867 c                call rhodecay(idecay,i1,nnn,iseed)
1868 c
1869 ctest off record decays of phi,K*,Lambda(1520) resonances:
1870 c                if(lb1.eq.29.or.iabs(lb1).eq.30)
1871 c     1               write(18,112) 'decay',lb1,px1,py1,pz1,am1,nt
1872                 call resdec(i1,nt,nnn,wid,idecay)
1873                 p(1,i1)=px1n
1874                 p(2,i1)=py1n
1875                 p(3,i1)=pz1n
1876 clin-5/2008:
1877                 dpertp(i1)=dp1n
1878 c     add decay time to freezeout positions & time at the last timestep:
1879                 if(nt.eq.ntmax) then
1880                    R(1,i1)=xfnl
1881                    R(2,i1)=yfnl
1882                    R(3,i1)=zfnl
1883                    tfdcy(i1)=tfnl
1884                 endif
1885 c
1886 * decay number for baryon resonance or L/S decay
1887                 if(iabs(lb1).ge.6.and.iabs(lb1).le.9) then
1888                    LDECAY=LDECAY+1
1889                 endif
1890
1891 * for a1 decay
1892 c             elseif(lb1.eq.32)then
1893 c                NNN=NNN+1
1894 c                call a1decay(idecay,i1,nnn,iseed,rhomp)
1895
1896 * FOR N*(1440)
1897              elseif(iabs(LB1).EQ.10.OR.iabs(LB1).EQ.11) THEN
1898                 NNN=NNN+1
1899                 LDECAY=LDECAY+1
1900                 PNSTAR=1.
1901                 IF(E(I1).GT.1.22)PNSTAR=0.6
1902                 IF(RANART(NSEED).LE.PNSTAR)THEN
1903 * (1) DECAY TO SINGLE PION+NUCLEON
1904                    CALL DECAYA(idecay,I1,NNN,ISEED,wid,nt)
1905                 ELSE
1906 * (2) DECAY TO TWO PIONS + NUCLEON
1907                    CALL DECAY2(idecay,I1,NNN,ISEED,wid,nt)
1908                    NNN=NNN+1
1909                 ENDIF
1910 c for N*(1535) decay
1911              elseif(iabs(LB1).eq.12.or.iabs(LB1).eq.13) then
1912                 NNN=NNN+1
1913                 CALL DECAYA(idecay,I1,NNN,ISEED,wid,nt)
1914                 LDECAY=LDECAY+1
1915              endif
1916 c
1917 *COM: AT HIGH ENERGIES WE USE VERY SHORT TIME STEPS,
1918 *     IN ORDER TO TAKE INTO ACCOUNT THE FINITE FORMATIOM TIME, WE
1919 *     DO NOT ALLOW PARTICLES FROM THE DECAY OF RESONANCE TO INTERACT
1920 *     WITH OTHERS IN THE SAME TIME STEP. CHANGE 9000 TO REVERSE THIS
1921 *     ASSUMPTION. EFFECTS OF THIS ASSUMPTION CAN BE STUDIED BY CHANGING
1922 *     THE STATEMENT OF 9000. See notebook for discussions on effects of
1923 *     changing statement 9000.
1924 c
1925 c     kaons from K* decay are converted to k0short (and k0long),
1926 c     phi decay may produce rho, K0S or eta, N*(1535) decay may produce eta,
1927 c     and these decay daughters need to decay again if at the last timestep:
1928 c     (note: these daughters have been assigned to lb(i1) only, not to lpion)
1929 c             if(nt.eq.ntmax.and.(lb1.eq.29.or.iabs(lb1).eq.30
1930 c     1            .iabs(lb1).eq.12.or.iabs(lb1).eq.13)) then
1931              if(nt.eq.ntmax) then
1932                 if(lb(i1).eq.25.or.lb(i1).eq.26.or.lb(i1).eq.27) then
1933                    wid=0.151
1934                 elseif(lb(i1).eq.0) then
1935                    wid=1.18e-6
1936                 elseif(lb(i1).eq.24.and.iksdcy.eq.1) then
1937                    wid=7.36e-17
1938                 else
1939                    goto 9000
1940                 endif
1941                 LB1=LB(I1)
1942                 PX1=P(1,I1)
1943                 PY1=P(2,I1)
1944                 PZ1=P(3,I1)
1945                 EM1=E(I1)
1946                 E1=SQRT(EM1**2+PX1**2+PY1**2+PZ1**2)
1947                 call resdec(i1,nt,nnn,wid,idecay)
1948                 p(1,i1)=px1n
1949                 p(2,i1)=py1n
1950                 p(3,i1)=pz1n
1951                 R(1,i1)=xfnl
1952                 R(2,i1)=yfnl
1953                 R(3,i1)=zfnl
1954                 tfdcy(i1)=tfnl
1955 clin-5/2008:
1956                 dpertp(i1)=dp1n
1957              endif
1958
1959 * negelecting the Pauli blocking at high energies
1960  9000        go to 800
1961           ENDIF
1962 * LOOP OVER ALL PSEUDOPARTICLES 2 IN THE SAME RUN
1963 * SAVE ALL THE COORDINATES FOR POSSIBLE CHANGE IN THE FOLLOWING COLLISION
1964  1        if(nt.eq.ntmax)go to 800
1965           X1 = R(1,I1)
1966           Y1 = R(2,I1)
1967           Z1 = R(3,I1)
1968 c
1969            DO 600 J2 = 1,J1-1
1970             I2  = J2 + MSUM
1971 * IF I2 IS A MESON BEING ABSORBED, THEN GO OUT OF THE LOOP
1972             IF(E(I2).EQ.0.) GO TO 600
1973 clin-5/2008 in case the first particle is already destroyed:
1974             IF(E(I1).EQ.0.) GO TO 800
1975             IF (LB(I2) .LT. -45 .OR. LB(I2) .GT. 45) GOTO 600
1976 clin-7/26/03 improve speed
1977             X2=R(1,I2)
1978             Y2=R(2,I2)
1979             Z2=R(3,I2)
1980             dr0max=5.
1981 clin-9/2008 deuteron+nucleon elastic cross sections could reach ~2810mb:
1982             ilb1=iabs(LB(I1))
1983             ilb2=iabs(LB(I2))
1984             IF(ilb1.EQ.42.or.ilb2.EQ.42) THEN
1985                if((ILB1.GE.1.AND.ILB1.LE.2)
1986      1              .or.(ILB1.GE.6.AND.ILB1.LE.13)
1987      2              .or.(ILB2.GE.1.AND.ILB2.LE.2)
1988      3              .or.(ILB2.GE.6.AND.ILB2.LE.13)) then
1989                   if((lb(i1)*lb(i2)).gt.0) dr0max=10.
1990                endif
1991             ENDIF
1992 c
1993             if(((X1-X2)**2+(Y1-Y2)**2+(Z1-Z2)**2).GT.dr0max**2)
1994      1           GO TO 600
1995             IF (ID(I1)*ID(I2).EQ.IAVOID) GOTO 400
1996             ID1=ID(I1)
1997             ID2 = ID(I2)
1998 c
1999             ix1= nint(x1/dx)
2000             iy1= nint(y1/dy)
2001             iz1= nint(z1/dz)
2002             PX1=P(1,I1)
2003             PY1=P(2,I1)
2004             PZ1=P(3,I1)
2005             EM1=E(I1)
2006             AM1=EM1
2007             LB1=LB(I1)
2008             E1=SQRT(EM1**2+PX1**2+PY1**2+PZ1**2)
2009             IPX1=NINT(PX1/DPX)
2010             IPY1=NINT(PY1/DPY)
2011             IPZ1=NINT(PZ1/DPZ)
2012             LB2 = LB(I2)
2013             PX2 = P(1,I2)
2014             PY2 = P(2,I2)
2015             PZ2 = P(3,I2)
2016             EM2=E(I2)
2017             AM2=EM2
2018             lb1i=lb(i1)
2019             lb2i=lb(i2)
2020             px1i=P(1,I1)
2021             py1i=P(2,I1)
2022             pz1i=P(3,I1)
2023             em1i=E(I1)
2024             px2i=P(1,I2)
2025             py2i=P(2,I2)
2026             pz2i=P(3,I2)
2027             em2i=E(I2)
2028 clin-2/26/03 ctest off check energy conservation after each binary search:
2029             eini=SQRT(E(I1)**2+P(1,I1)**2+P(2,I1)**2+P(3,I1)**2)
2030      1           +SQRT(E(I2)**2+P(1,I2)**2+P(2,I2)**2+P(3,I2)**2)
2031             pxini=P(1,I1)+P(1,I2)
2032             pyini=P(2,I1)+P(2,I2)
2033             pzini=P(3,I1)+P(3,I2)
2034             nnnini=nnn
2035 c
2036 clin-4/30/03 initialize value:
2037             iblock=0
2038 c
2039 * TO SAVE COMPUTING TIME we do the following
2040 * (1) make a ROUGH estimate to see whether particle i2 will collide with
2041 * particle I1, and (2) skip the particle pairs for which collisions are
2042 * not modeled in the code.
2043 * FOR MESON-BARYON AND MESON-MESON COLLISIONS, we use a maximum
2044 * interaction distance DELTR0=2.6
2045 * for ppbar production from meson (pi rho omega) interactions:
2046 c
2047             DELTR0=3.
2048         if( (iabs(lb1).ge.14.and.iabs(lb1).le.17) .or.
2049      &      (iabs(lb1).ge.30.and.iabs(lb1).le.45) ) DELTR0=5.0
2050         if( (iabs(lb2).ge.14.and.iabs(lb2).le.17) .or.
2051      &      (iabs(lb2).ge.30.and.iabs(lb2).le.45) ) DELTR0=5.0
2052
2053             if(lb1.eq.28.and.lb2.eq.28) DELTR0=4.84
2054 clin-10/08/00 to include pi pi -> rho rho:
2055             if((lb1.ge.3.and.lb1.le.5).and.(lb2.ge.3.and.lb2.le.5)) then
2056                E2=SQRT(EM2**2+PX2**2+PY2**2+PZ2**2)
2057          spipi=(e1+e2)**2-(px1+px2)**2-(py1+py2)**2-(pz1+pz2)**2
2058                if(spipi.ge.(4*0.77**2)) DELTR0=3.5
2059             endif
2060
2061 c khyperon
2062         IF (LB1.EQ.23 .AND. (LB2.GE.14.AND.LB2.LE.17)) GOTO 3699
2063         IF (LB2.EQ.23 .AND. (LB1.GE.14.AND.LB1.LE.17)) GOTO 3699
2064
2065 * K(K*) + Kbar(K*bar) scattering including
2066 *     K(K*) + Kbar(K*bar) --> phi + pi(rho,omega) and pi pi(rho,omega)
2067        if(lb1.eq.21.and.lb2.eq.23)go to 3699
2068        if(lb2.eq.21.and.lb1.eq.23)go to 3699
2069        if(lb1.eq.30.and.lb2.eq.21)go to 3699
2070        if(lb2.eq.30.and.lb1.eq.21)go to 3699
2071        if(lb1.eq.-30.and.lb2.eq.23)go to 3699
2072        if(lb2.eq.-30.and.lb1.eq.23)go to 3699
2073        if(lb1.eq.-30.and.lb2.eq.30)go to 3699
2074        if(lb2.eq.-30.and.lb1.eq.30)go to 3699
2075 c
2076 clin-12/15/00
2077 c     kaon+rho(omega,eta) collisions:
2078       if(lb1.eq.21.or.lb1.eq.23) then
2079          if(lb2.eq.0.or.(lb2.ge.25.and.lb2.le.28)) then
2080             go to 3699
2081          endif
2082       elseif(lb2.eq.21.or.lb2.eq.23) then
2083          if(lb1.eq.0.or.(lb1.ge.25.and.lb1.le.28)) then
2084             goto 3699
2085          endif
2086       endif
2087
2088 clin-8/14/02 K* (pi, rho, omega, eta) collisions:
2089       if(iabs(lb1).eq.30 .and.
2090      1     (lb2.eq.0.or.(lb2.ge.25.and.lb2.le.28)
2091      2     .or.(lb2.ge.3.and.lb2.le.5))) then
2092          go to 3699
2093       elseif(iabs(lb2).eq.30 .and.
2094      1        (lb1.eq.0.or.(lb1.ge.25.and.lb1.le.28)
2095      2        .or.(lb1.ge.3.and.lb1.le.5))) then
2096          goto 3699
2097 clin-8/14/02-end
2098 c K*/K*-bar + baryon/antibaryon collisions:
2099         elseif( iabs(lb1).eq.30 .and.
2100      1     (iabs(lb2).eq.1.or.iabs(lb2).eq.2.or.
2101      2     (iabs(lb2).ge.6.and.iabs(lb2).le.13)) )then
2102               go to 3699
2103            endif
2104          if( iabs(lb2).eq.30 .and.
2105      1         (iabs(lb1).eq.1.or.iabs(lb1).eq.2.or.
2106      2         (iabs(lb1).ge.6.and.iabs(lb1).le.13)) )then
2107                 go to 3699
2108         endif
2109 * K^+ baryons and antibaryons:
2110 c** K+ + B-bar  --> La(Si)-bar + pi
2111 * K^- and antibaryons, note K^- and baryons are included in newka():
2112 * note that we fail to satisfy charge conjugation for these cross sections:
2113         if((lb1.eq.23.or.lb1.eq.21).and.
2114      1       (iabs(lb2).eq.1.or.iabs(lb2).eq.2.or.
2115      2       (iabs(lb2).ge.6.and.iabs(lb2).le.13))) then
2116            go to 3699
2117         elseif((lb2.eq.23.or.lb2.eq.21).and.
2118      1       (iabs(lb1).eq.1.or.iabs(lb1).eq.2.or.
2119      2       (iabs(lb1).ge.6.and.iabs(lb1).le.13))) then
2120            go to 3699
2121         endif
2122 *
2123 * For anti-nucleons annihilations:
2124 * Assumptions:
2125 * (1) for collisions involving a p_bar or n_bar,
2126 * we allow only collisions between a p_bar and a baryon or a baryon
2127 * resonance (as well as a n_bar and a baryon or a baryon resonance),
2128 * we skip all other reactions involving a p_bar or n_bar,
2129 * such as collisions between p_bar (n_bar) and mesons,
2130 * and collisions between two p_bar's (n_bar's).
2131 * (2) we introduce a new parameter rppmax: the maximum interaction
2132 * distance to make the quick collision check,rppmax=3.57 fm
2133 * corresponding to a cutoff of annihilation xsection= 400mb which is
2134 * also used consistently in the actual annihilation xsection to be
2135 * used in the following as given in the subroutine xppbar(srt)
2136         rppmax=3.57
2137 * anti-baryon on baryons
2138         if((lb1.eq.-1.or.lb1.eq.-2.or.(lb1.ge.-13.and.lb1.le.-6))
2139      1 .and.(lb2.eq.1.or.lb2.eq.2.or.(lb2.ge.6.and.lb2.le.13))) then
2140             DELTR0 = RPPMAX
2141             GOTO 2699
2142        else if((lb2.eq.-1.or.lb2.eq.-2.or.(lb2.ge.-13.and.lb2.le.-6))
2143      1 .and.(lb1.eq.1.or.lb1.eq.2.or.(lb1.ge.6.and.lb1.le.13))) then
2144             DELTR0 = RPPMAX
2145             GOTO 2699
2146          END IF
2147
2148 c*  ((anti) lambda, cascade, omega  should not be rejected)
2149         if( (iabs(lb1).ge.14.and.iabs(lb1).le.17) .or.
2150      &      (iabs(lb2).ge.14.and.iabs(lb2).le.17) )go to 3699
2151 c
2152 clin-9/2008 maximum sigma~2810mb for deuteron+nucleon elastic collisions:
2153          IF (iabs(LB1).EQ.42.or.iabs(LB2).EQ.42) THEN
2154             ilb1=iabs(LB1)
2155             ilb2=iabs(LB2)
2156             if((ILB1.GE.1.AND.ILB1.LE.2)
2157      1           .or.(ILB1.GE.6.AND.ILB1.LE.13)
2158      2           .or.(ILB2.GE.1.AND.ILB2.LE.2)
2159      3           .or.(ILB2.GE.6.AND.ILB2.LE.13)) then
2160                if((lb1*lb2).gt.0) deltr0=9.5
2161             endif
2162          ENDIF
2163 c
2164         if( (iabs(lb1).ge.40.and.iabs(lb1).le.45) .or.
2165      &      (iabs(lb2).ge.40.and.iabs(lb2).le.45) )go to 3699
2166 c
2167 c* phi channel --> elastic + inelastic scatt.
2168          IF( (lb1.eq.29 .and.((lb2.ge.1.and.lb2.le.13).or.
2169      &       (lb2.ge.21.and.lb2.le.28).or.iabs(lb2).eq.30)) .OR.
2170      &     (lb2.eq.29 .and.((lb1.ge.1.and.lb1.le.13).or.
2171      &       (lb1.ge.21.and.lb1.le.28).or.iabs(lb1).eq.30)) )THEN
2172              DELTR0=3.0
2173              go to 3699
2174         endif
2175 c
2176 c  La/Si, Cas, Om (bar)-meson elastic colln
2177 * pion vs. La & Ca (bar) coll. are treated in resp. subroutines
2178
2179 * SKIP all other K* RESCATTERINGS
2180         If(iabs(lb1).eq.30.or.iabs(lb2).eq.30) go to 400
2181 * SKIP KAON(+) RESCATTERINGS WITH particles other than pions and baryons
2182          If(lb1.eq.23.and.(lb2.lt.1.or.lb2.gt.17))go to 400
2183          If(lb2.eq.23.and.(lb1.lt.1.or.lb1.gt.17))go to 400
2184 c
2185 c anti-baryon proccess: B-bar+M, N-bar+R-bar, N-bar+N-bar, R-bar+R-bar
2186 c  R = (D,N*)
2187          if( ((lb1.le.-1.and.lb1.ge.-13)
2188      &        .and.(lb2.eq.0.or.(lb2.ge.3.and.lb2.le.5)
2189      &            .or.(lb2.ge.25.and.lb2.le.28)))
2190      &      .OR.((lb2.le.-1.and.lb2.ge.-13)
2191      &         .and.(lb1.eq.0.or.(lb1.ge.3.and.lb1.le.5)
2192      &              .or.(lb1.ge.25.and.lb1.le.28))) ) then
2193          elseIF( ((LB1.eq.-1.or.lb1.eq.-2).
2194      &             and.(LB2.LT.-5.and.lb2.ge.-13))
2195      &      .OR. ((LB2.eq.-1.or.lb2.eq.-2).
2196      &             and.(LB1.LT.-5.and.lb1.ge.-13)) )then
2197          elseIF((LB1.eq.-1.or.lb1.eq.-2)
2198      &     .AND.(LB2.eq.-1.or.lb2.eq.-2))then
2199          elseIF((LB1.LT.-5.and.lb1.ge.-13).AND.
2200      &          (LB2.LT.-5.and.lb2.ge.-13)) then
2201 c        elseif((lb1.lt.0).or.(lb2.lt.0)) then
2202 c         go to 400
2203        endif
2204
2205  2699    CONTINUE
2206 * for baryon-baryon collisions
2207          IF (LB1 .EQ. 1 .OR. LB1 .EQ. 2 .OR. (LB1 .GE. 6 .AND.
2208      &        LB1 .LE. 17)) THEN
2209             IF (LB2 .EQ. 1 .OR. LB2 .EQ. 2 .OR. (LB2 .GE. 6 .AND.
2210      &           LB2 .LE. 17)) THEN
2211                DELTR0 = 2.
2212             END IF
2213          END IF
2214 c
2215  3699   RSQARE = (X1-X2)**2 + (Y1-Y2)**2 + (Z1-Z2)**2
2216         IF (RSQARE .GT. DELTR0**2) GO TO 400
2217 *NOW PARTICLES ARE CLOSE ENOUGH TO EACH OTHER !
2218 * KEEP ALL COORDINATES FOR POSSIBLE PHASE SPACE CHANGE
2219             ix2 = nint(x2/dx)
2220             iy2 = nint(y2/dy)
2221             iz2 = nint(z2/dz)
2222             ipx2 = nint(px2/dpx)
2223             ipy2 = nint(py2/dpy)
2224             ipz2 = nint(pz2/dpz)
2225 * FIND MOMENTA OF PARTICLES IN THE CMS OF THE TWO COLLIDING PARTICLES
2226 * AND THE CMS ENERGY SRT
2227           CALL CMS(I1,I2,PCX,PCY,PCZ,SRT)
2228 clin-7/26/03 improve speed
2229           drmax=dr0max
2230           call distc0(drmax,deltr0,DT,
2231      1         Ifirst,PCX,PCY,PCZ,
2232      2         x1,y1,z1,px1,py1,pz1,em1,x2,y2,z2,px2,py2,pz2,em2)
2233           if(Ifirst.eq.-1) goto 400
2234
2235          ISS=NINT(SRT/ESBIN)
2236 clin-4/2008 use last bin if ISS is out of EKAON's upper bound of 2000:
2237          if(ISS.gt.2000) ISS=2000
2238 *Sort collisions
2239 c
2240 clin-8/2008 Deuteron+Meson->B+B;
2241 c     meson=(pi,rho,omega,eta), B=(n,p,Delta,N*1440,N*1535):
2242          IF (iabs(LB1).EQ.42.or.iabs(LB2).EQ.42) THEN
2243             ilb1=iabs(LB1)
2244             ilb2=iabs(LB2)
2245             if(LB1.eq.0.or.(LB1.GE.3.AND.LB1.LE.5)
2246      1           .or.(LB1.GE.25.AND.LB1.LE.28)
2247      2           .or.
2248      3           LB2.eq.0.or.(LB2.GE.3.AND.LB2.LE.5)
2249      4           .or.(LB2.GE.25.AND.LB2.LE.28)) then
2250                GOTO 505
2251 clin-9/2008 Deuteron+Baryon or antiDeuteron+antiBaryon elastic collisions:
2252             elseif(((ILB1.GE.1.AND.ILB1.LE.2)
2253      1              .or.(ILB1.GE.6.AND.ILB1.LE.13)
2254      2              .or.(ILB2.GE.1.AND.ILB2.LE.2)
2255      3              .or.(ILB2.GE.6.AND.ILB2.LE.13))
2256      4              .and.(lb1*lb2).gt.0) then
2257                GOTO 506
2258             else
2259                GOTO 400
2260             endif
2261          ENDIF
2262 c
2263 * K+ + (N,N*,D)-bar --> L/S-bar + pi
2264           if( ((lb1.eq.23.or.lb1.eq.30).and.
2265      &         (lb2.eq.-1.or.lb2.eq.-2.or.(lb2.ge.-13.and.lb2.le.-6)))
2266      &         .OR.((lb2.eq.23.or.lb2.eq.30).and.
2267      &         (lb1.eq.-1.or.lb1.eq.-2.or.(lb1.ge.-13.and.lb1.le.-6))) )
2268      &         then
2269              bmass=0.938
2270              if(srt.le.(bmass+aka)) then
2271                 pkaon=0.
2272              else
2273                 pkaon=sqrt(((srt**2-(aka**2+bmass**2))
2274      1               /2./bmass)**2-aka**2)
2275              endif
2276 clin-10/31/02 cross sections are isospin-averaged, same as those in newka
2277 c     for K- + (N,N*,D) --> L/S + pi:
2278              sigela = 0.5 * (AKPEL(PKAON) + AKNEL(PKAON))
2279              SIGSGM = 1.5 * AKPSGM(PKAON) + AKNSGM(PKAON)
2280              SIG = sigela + SIGSGM + AKPLAM(PKAON)
2281              if(sig.gt.1.e-7) then
2282 c     ! K+ + N-bar reactions
2283                 icase=3
2284                 brel=sigela/sig
2285                 brsgm=sigsgm/sig
2286                 brsig = sig
2287                 nchrg = 1
2288                 go to 3555
2289              endif
2290              go to 400
2291           endif
2292 c
2293 c
2294 c  meson + hyperon-bar -> K+ + N-bar
2295           if(((lb1.ge.-17.and.lb1.le.-14).and.(lb2.ge.3.and.lb2.le.5))
2296      &         .OR.((lb2.ge.-17.and.lb2.le.-14)
2297      &         .and.(lb1.ge.3.and.lb1.le.5)))then
2298              nchrg=-100
2299
2300 C*       first classify the reactions due to total charge.
2301              if((lb1.eq.-15.and.(lb2.eq.5.or.lb2.eq.27)).OR.
2302      &            (lb2.eq.-15.and.(lb1.eq.5.or.lb1.eq.27))) then
2303                 nchrg=-2
2304 c     ! D-(bar)
2305                 bmass=1.232
2306                 go to 110
2307              endif
2308              if( (lb1.eq.-15.and.(lb2.eq.0.or.lb2.eq.4.or.lb2.eq.26.or.
2309      &            lb2.eq.28)).OR.(lb2.eq.-15.and.(lb1.eq.0.or.
2310      &            lb1.eq.4.or.lb1.eq.26.or.lb1.eq.28)).OR.
2311      &   ((lb1.eq.-14.or.lb1.eq.-16).and.(lb2.eq.5.or.lb2.eq.27)).OR.
2312      &   ((lb2.eq.-14.or.lb2.eq.-16).and.(lb1.eq.5.or.lb1.eq.27)) )then
2313                 nchrg=-1
2314 c     ! n-bar
2315                 bmass=0.938
2316                 go to 110
2317              endif
2318              if(  (lb1.eq.-15.and.(lb2.eq.3.or.lb2.eq.25)).OR.
2319      &            (lb2.eq.-15.and.(lb1.eq.3.or.lb1.eq.25)).OR.
2320      &            (lb1.eq.-17.and.(lb2.eq.5.or.lb2.eq.27)).OR.
2321      &            (lb2.eq.-17.and.(lb1.eq.5.or.lb1.eq.27)).OR.
2322      &            ((lb1.eq.-14.or.lb1.eq.-16).and.(lb2.eq.0.or.lb2.eq.4
2323      &            .or.lb2.eq.26.or.lb2.eq.28)).OR.
2324      &            ((lb2.eq.-14.or.lb2.eq.-16).and.(lb1.eq.0.or.lb1.eq.4
2325      &            .or.lb1.eq.26.or.lb1.eq.28)) )then
2326                nchrg=0
2327 c     ! p-bar
2328                 bmass=0.938
2329                 go to 110
2330              endif
2331              if( (lb1.eq.-17.and.(lb2.eq.0.or.lb2.eq.4.or.lb2.eq.26.or.
2332      &            lb2.eq.28)).OR.(lb2.eq.-17.and.(lb1.eq.0.or.
2333      &            lb1.eq.4.or.lb1.eq.26.or.lb1.eq.28)).OR.
2334      &  ((lb1.eq.-14.or.lb1.eq.-16).and.(lb2.eq.3.or.lb2.eq.25)).OR.
2335      &  ((lb2.eq.-14.or.lb2.eq.-16).and.(lb1.eq.3.or.lb1.eq.25)))then
2336                nchrg=1
2337 c     ! D++(bar)
2338                 bmass=1.232
2339              endif
2340 c
2341 c 110     if(nchrg.ne.-100.and.srt.ge.(aka+bmass))then !! for elastic
2342  110         sig = 0.
2343 c !! for elastic
2344          if(nchrg.ne.-100.and.srt.ge.(aka+bmass))then
2345 cc110        if(nchrg.eq.-100.or.srt.lt.(aka+bmass)) go to 400
2346 c             ! PI + La(Si)-bar => K+ + N-bar reactions
2347             icase=4
2348 cc       pkaon=sqrt(((srt**2-(aka**2+bmass**2))/2./bmass)**2-aka**2)
2349             pkaon=sqrt(((srt**2-(aka**2+0.938**2))/2./0.938)**2-aka**2)
2350 c ! lambda-bar + Pi
2351             if(lb1.eq.-14.or.lb2.eq.-14) then
2352                if(nchrg.ge.0) sigma0=akPlam(pkaon)
2353                if(nchrg.lt.0) sigma0=akNlam(pkaon)
2354 c                ! sigma-bar + pi
2355             else
2356 c !K-p or K-D++
2357                if(nchrg.ge.0) sigma0=akPsgm(pkaon)
2358 c !K-n or K-D-
2359                if(nchrg.lt.0) sigma0=akNsgm(pkaon)
2360                SIGMA0 = 1.5 * AKPSGM(PKAON) + AKNSGM(PKAON)
2361             endif
2362             sig=(srt**2-(aka+bmass)**2)*(srt**2-(aka-bmass)**2)/
2363      &           (srt**2-(em1+em2)**2)/(srt**2-(em1-em2)**2)*sigma0
2364 c ! K0barD++, K-D-
2365             if(nchrg.eq.-2.or.nchrg.eq.2) sig=2.*sig
2366 C*     the factor 2 comes from spin of delta, which is 3/2
2367 C*     detailed balance. copy from Page 423 of N.P. A614 1997
2368             IF (LB1 .EQ. -14 .OR. LB2 .EQ. -14) THEN
2369                SIG = 4.0 / 3.0 * SIG
2370             ELSE IF (NCHRG .EQ. -2 .OR. NCHRG .EQ. 2) THEN
2371                SIG = 8.0 / 9.0 * SIG
2372             ELSE
2373                SIG = 4.0 / 9.0 * SIG
2374             END IF
2375 cc        brel=0.
2376 cc        brsgm=0.
2377 cc        brsig = sig
2378 cc          if(sig.lt.1.e-7) go to 400
2379 *-
2380          endif
2381 c                ! PI + La(Si)-bar => elastic included
2382          icase=4
2383          sigela = 10.
2384          sig = sig + sigela
2385          brel= sigela/sig
2386          brsgm=0.
2387          brsig = sig
2388 *-
2389          go to 3555
2390       endif
2391
2392 ** MULTISTRANGE PARTICLE (Cas,Omega -bar) PRODUCTION - (NON)PERTURBATIVE
2393
2394 * K-/K*0bar + La/Si --> cascade + pi/eta
2395       if( ((lb1.eq.21.or.lb1.eq.-30).and.(lb2.ge.14.and.lb2.le.17)).OR.
2396      &  ((lb2.eq.21.or.lb2.eq.-30).and.(lb1.ge.14.and.lb1.le.17)) )then
2397           kp = 0
2398           go to 3455
2399         endif
2400 c K+/K*0 + La/Si(bar) --> cascade-bar + pi/eta
2401       if( ((lb1.eq.23.or.lb1.eq.30).and.(lb2.le.-14.and.lb2.ge.-17)).OR.
2402      &  ((lb2.eq.23.or.lb2.eq.30).and.(lb1.le.-14.and.lb1.ge.-17)) )then
2403           kp = 1
2404           go to 3455
2405         endif
2406 * K-/K*0bar + cascade --> omega + pi
2407        if( ((lb1.eq.21.or.lb1.eq.-30).and.(lb2.eq.40.or.lb2.eq.41)).OR.
2408      & ((lb2.eq.21.or.lb2.eq.-30).and.(lb1.eq.40.or.lb1.eq.41)) )then
2409           kp = 0
2410           go to 3455
2411         endif
2412 * K+/K*0 + cascade-bar --> omega-bar + pi
2413        if( ((lb1.eq.23.or.lb1.eq.30).and.(lb2.eq.-40.or.lb2.eq.-41)).OR.
2414      &  ((lb2.eq.23.or.lb2.eq.30).and.(lb1.eq.-40.or.lb1.eq.-41)) )then
2415           kp = 1
2416           go to 3455
2417         endif
2418 * Omega + Omega --> Di-Omega + photon(eta)
2419 cc        if( lb1.eq.45.and.lb2.eq.45 ) go to 3455
2420
2421 c annhilation of cascade(bar), omega(bar)
2422          kp = 3
2423 * K- + L/S <-- cascade(bar) + pi/eta
2424        if( (((lb1.ge.3.and.lb1.le.5).or.lb1.eq.0)
2425      &       .and.(iabs(lb2).eq.40.or.iabs(lb2).eq.41))
2426      & .OR. (((lb2.ge.3.and.lb2.le.5).or.lb2.eq.0)
2427      &       .and.(iabs(lb1).eq.40.or.iabs(lb1).eq.41)) )go to 3455
2428 * K- + cascade(bar) <-- omega(bar) + pi
2429 *         if(  (lb1.eq.0.and.iabs(lb2).eq.45)
2430 *    &       .OR. (lb2.eq.0.and.iabs(lb1).eq.45) )go to 3455
2431         if( ((lb1.ge.3.and.lb1.le.5).and.iabs(lb2).eq.45)
2432      &  .OR.((lb2.ge.3.and.lb2.le.5).and.iabs(lb1).eq.45) )go to 3455
2433 c
2434
2435 ***  MULTISTRANGE PARTICLE PRODUCTION  (END)
2436
2437 c* K+ + La(Si) --> Meson + B
2438         IF (LB1.EQ.23 .AND. (LB2.GE.14.AND.LB2.LE.17)) GOTO 5699
2439         IF (LB2.EQ.23 .AND. (LB1.GE.14.AND.LB1.LE.17)) GOTO 5699
2440 c* K- + La(Si)-bar --> Meson + B-bar
2441        IF (LB1.EQ.21 .AND. (LB2.GE.-17.AND.LB2.LE.-14)) GOTO 5699
2442        IF (LB2.EQ.21 .AND. (LB1.GE.-17.AND.LB1.LE.-14)) GOTO 5699
2443
2444 c La/Si-bar + B --> pi + K+
2445        IF( (((LB1.eq.1.or.LB1.eq.2).or.(LB1.ge.6.and.LB1.le.13))
2446      &       .AND.(LB2.GE.-17.AND.LB2.LE.-14)) .OR.
2447      &     (((LB2.eq.1.or.LB2.eq.2).or.(LB2.ge.6.and.LB2.le.13))
2448      &      .AND.(LB1.GE.-17.AND.LB1.LE.-14)) )go to 5999
2449 c La/Si + B-bar --> pi + K-
2450        IF( (((LB1.eq.-1.or.LB1.eq.-2).or.(LB1.le.-6.and.LB1.ge.-13))
2451      &       .AND.(LB2.GE.14.AND.LB2.LE.17)) .OR.
2452      &     (((LB2.eq.-1.or.LB2.eq.-2).or.(LB2.le.-6.and.LB2.ge.-13))
2453      &       .AND.(LB1.GE.14.AND.LB1.LE.17)) )go to 5999
2454 *
2455 *
2456 * K(K*) + Kbar(K*bar) --> phi + pi(rho,omega), M + M (M=pi,rho,omega,eta)
2457        if(lb1.eq.21.and.lb2.eq.23) go to 8699
2458        if(lb2.eq.21.and.lb1.eq.23) go to 8699
2459        if(lb1.eq.30.and.lb2.eq.21) go to 8699
2460        if(lb2.eq.30.and.lb1.eq.21) go to 8699
2461        if(lb1.eq.-30.and.lb2.eq.23) go to 8699
2462        if(lb2.eq.-30.and.lb1.eq.23) go to 8699
2463        if(lb1.eq.-30.and.lb2.eq.30) go to 8699
2464        if(lb2.eq.-30.and.lb1.eq.30) go to 8699
2465 c* (K,K*)-bar + rho(omega) --> phi +(K,K*)-bar, piK and elastic
2466        IF( ((lb1.eq.23.or.lb1.eq.21.or.iabs(lb1).eq.30) .and.
2467      &      (lb2.ge.25.and.lb2.le.28)) .OR.
2468      &     ((lb2.eq.23.or.lb2.eq.21.or.iabs(lb2).eq.30) .and.
2469      &      (lb1.ge.25.and.lb1.le.28)) ) go to 8799
2470 c
2471 c* K*(-bar) + pi --> phi + (K,K*)-bar
2472        IF( (iabs(lb1).eq.30.and.(lb2.ge.3.and.lb2.le.5)) .OR.
2473      &     (iabs(lb2).eq.30.and.(lb1.ge.3.and.lb1.le.5)) )go to 8799
2474 *
2475 c
2476 c* phi + N --> pi+N(D),  rho+N(D),  K+ +La
2477 c* phi + D --> pi+N(D),  rho+N(D)
2478        IF( (lb1.eq.29 .and.(lb2.eq.1.or.lb2.eq.2.or.
2479      &       (lb2.ge.6.and.lb2.le.9))) .OR.
2480      &     (lb2.eq.29 .and.(lb1.eq.1.or.lb1.eq.2.or.
2481      &       (lb1.ge.6.and.lb1.le.9))) )go to 7222
2482 c
2483 c* phi + (pi,rho,ome,K,K*-bar) --> K+K, K+K*, K*+K*, (pi,rho,omega)+(K,K*-bar)
2484        IF( (lb1.eq.29 .and.((lb2.ge.3.and.lb2.le.5).or.
2485      &      (lb2.ge.21.and.lb2.le.28).or.iabs(lb2).eq.30)) .OR.
2486      &     (lb2.eq.29 .and.((lb1.ge.3.and.lb1.le.5).or.
2487      &      (lb1.ge.21.and.lb1.le.28).or.iabs(lb1).eq.30)) )THEN
2488              go to 7444
2489       endif
2490 *
2491 c
2492 * La/Si, Cas, Om (bar)-(rho,omega,phi) elastic colln
2493 * pion vs. La, Ca, Omega-(bar) elastic coll. treated in resp. subroutines
2494       if( ((iabs(lb1).ge.14.and.iabs(lb1).le.17).or.iabs(lb1).ge.40)
2495      &    .and.((lb2.ge.25.and.lb2.le.29).or.lb2.eq.0) )go to 888
2496       if( ((iabs(lb2).ge.14.and.iabs(lb2).le.17).or.iabs(lb2).ge.40)
2497      &    .and.((lb1.ge.25.and.lb1.le.29).or.lb1.eq.0) )go to 888
2498 c
2499 c K+/K* (N,R)  OR   K-/K*- (N,R)-bar  elastic scatt
2500         if( ((lb1.eq.23.or.lb1.eq.30).and.(lb2.eq.1.or.lb2.eq.2.or.
2501      &         (lb2.ge.6.and.lb2.le.13))) .OR.
2502      &      ((lb2.eq.23.or.lb2.eq.30).and.(lb1.eq.1.or.lb1.eq.2.or.
2503      &         (lb1.ge.6.and.lb1.le.13))) ) go to 888
2504         if( ((lb1.eq.21.or.lb1.eq.-30).and.(lb2.eq.-1.or.lb2.eq.-2.or.
2505      &       (lb2.ge.-13.and.lb2.le.-6))) .OR.
2506      &      ((lb2.eq.21.or.lb2.eq.-30).and.(lb1.eq.-1.or.lb1.eq.-2.or.
2507      &       (lb1.ge.-13.and.lb1.le.-6))) ) go to 888
2508 c
2509 * L/S-baryon elastic collision
2510        If( ((lb1.ge.14.and.lb1.le.17).and.(lb2.ge.6.and.lb2.le.13))
2511      & .OR.((lb2.ge.14.and.lb2.le.17).and.(lb1.ge.6.and.lb1.le.13)) )
2512      &   go to 7799
2513        If(((lb1.le.-14.and.lb1.ge.-17).and.(lb2.le.-6.and.lb2.ge.-13))
2514      &.OR.((lb2.le.-14.and.lb2.ge.-17).and.(lb1.le.-6.and.lb1.ge.-13)))
2515      &   go to 7799
2516 c
2517 c skip other collns with perturbative particles or hyperon-bar
2518        if( iabs(lb1).ge.40 .or. iabs(lb2).ge.40
2519      &    .or. (lb1.le.-14.and.lb1.ge.-17)
2520      &    .or. (lb2.le.-14.and.lb2.ge.-17) )go to 400
2521 c
2522 c
2523 * anti-baryon on baryon resonaces
2524         if((lb1.eq.-1.or.lb1.eq.-2.or.(lb1.ge.-13.and.lb1.le.-6))
2525      1 .and.(lb2.eq.1.or.lb2.eq.2.or.(lb2.ge.6.and.lb2.le.13))) then
2526             GOTO 2799
2527        else if((lb2.eq.-1.or.lb2.eq.-2.or.(lb2.ge.-13.and.lb2.le.-6))
2528      1 .and.(lb1.eq.1.or.lb1.eq.2.or.(lb1.ge.6.and.lb1.le.13))) then
2529             GOTO 2799
2530          END IF
2531 c
2532 clin-10/25/02 get rid of argument usage mismatch in newka():
2533          inewka=irun
2534 c        call newka(icase,irun,iseed,dt,nt,
2535 clin-5/01/03 set iblock value in art1f.f, necessary for resonance studies:
2536 c        call newka(icase,inewka,iseed,dt,nt,
2537 c     &                  ictrl,i1,i2,srt,pcx,pcy,pcz)
2538         call newka(icase,inewka,iseed,dt,nt,
2539      &                  ictrl,i1,i2,srt,pcx,pcy,pcz,iblock)
2540
2541 clin-10/25/02-end
2542         IF (ICTRL .EQ. 1) GOTO 400
2543 c
2544 * SEPARATE NUCLEON+NUCLEON( BARYON RESONANCE+ BARYON RESONANCE ELASTIC
2545 * COLLISION), BARYON RESONANCE+NUCLEON AND BARYON-PION
2546 * COLLISIONS INTO THREE PARTS TO CHECK IF THEY ARE GOING TO SCATTER,
2547 * WE only allow L/S to COLLIDE elastically with a nucleon and meson
2548        if((iabs(lb1).ge.14.and.iabs(lb1).le.17).
2549      &  or.(iabs(lb2).ge.14.and.iabs(lb2).le.17))go to 400
2550 * IF PION+PION COLLISIONS GO TO 777
2551 * if pion+eta, eta+eta to create kaons go to 777
2552        IF((lb1.ge.3.and.lb1.le.5).and.(lb2.ge.3.and.lb2.le.5))GO TO 777
2553        if(lb1.eq.0.and.(lb2.ge.3.and.lb2.le.5)) go to 777
2554        if(lb2.eq.0.and.(lb1.ge.3.and.lb1.le.5)) go to 777
2555        if(lb1.eq.0.and.lb2.eq.0)go to 777
2556 * we assume that rho and omega behave the same way as pions in
2557 * kaon production
2558 * (1) rho(omega)+rho(omega)
2559        if( (lb1.ge.25.and.lb1.le.28).and.
2560      &     (lb2.ge.25.and.lb2.le.28) )goto 777
2561 * (2) rho(omega)+pion
2562       If((lb1.ge.25.and.lb1.le.28).and.(lb2.ge.3.and.lb2.le.5))go to 777
2563       If((lb2.ge.25.and.lb2.le.28).and.(lb1.ge.3.and.lb1.le.5))go to 777
2564 * (3) rho(omega)+eta
2565        if((lb1.ge.25.and.lb1.le.28).and.lb2.eq.0)go to 777
2566        if((lb2.ge.25.and.lb2.le.28).and.lb1.eq.0)go to 777
2567 c
2568 * if kaon+pion collisions go to 889
2569        if((lb1.eq.23.or.lb1.eq.21).and.(lb2.ge.3.and.lb2.le.5))go to 889
2570        if((lb2.eq.23.or.lb2.eq.21).and.(lb1.ge.3.and.lb1.le.5))go to 889
2571 c
2572 clin-2/06/03 skip all other (K K* Kbar K*bar) channels:
2573 * SKIP all other K and K* RESCATTERINGS
2574         If(iabs(lb1).eq.30.or.iabs(lb2).eq.30) go to 400
2575         If(lb1.eq.21.or.lb2.eq.21) go to 400
2576         If(lb1.eq.23.or.lb2.eq.23) go to 400
2577 c
2578 * IF PION+baryon COLLISION GO TO 3
2579            IF( (LB1.ge.3.and.LB1.le.5) .and.
2580      &         (iabs(LB2).eq.1.or.iabs(LB2).eq.2.or.
2581      &          (iabs(LB2).ge.6.and.iabs(LB2).le.13)) )GO TO 3
2582            IF( (LB2.ge.3.and.LB2.le.5) .and.
2583      &         (iabs(LB1).eq.1.or.iabs(LB1).eq.2.or.
2584      &          (iabs(LB1).ge.6.and.iabs(LB1).le.13)) )GO TO 3
2585 c
2586 * IF rho(omega)+NUCLEON (baryon resonance) COLLISION GO TO 33
2587            IF( (LB1.ge.25.and.LB1.le.28) .and.
2588      &         (iabs(LB2).eq.1.or.iabs(LB2).eq.2.or.
2589      &          (iabs(LB2).ge.6.and.iabs(LB2).le.13)) )GO TO 33
2590            IF( (LB2.ge.25.and.LB2.le.28) .and.
2591      &         (iabs(LB1).eq.1.or.iabs(LB1).eq.2.or.
2592      &          (iabs(LB1).ge.6.and.iabs(LB1).le.13)) )GO TO 33
2593 c
2594 * IF ETA+NUCLEON (baryon resonance) COLLISIONS GO TO 547
2595            IF( LB1.eq.0 .and.
2596      &         (iabs(LB2).eq.1.or.iabs(LB2).eq.2.or.
2597      &          (iabs(LB2).ge.6.and.iabs(LB2).le.13)) )GO TO 547
2598            IF( LB2.eq.0 .and.
2599      &         (iabs(LB1).eq.1.or.iabs(LB1).eq.2.or.
2600      &          (iabs(LB1).ge.6.and.iabs(LB1).le.13)) )GO TO 547
2601 c
2602 * IF NUCLEON+BARYON RESONANCE COLLISION GO TO 44
2603             IF((LB1.eq.1.or.lb1.eq.2).
2604      &        AND.(LB2.GT.5.and.lb2.le.13))GOTO 44
2605             IF((LB2.eq.1.or.lb2.eq.2).
2606      &        AND.(LB1.GT.5.and.lb1.le.13))GOTO 44
2607             IF((LB1.eq.-1.or.lb1.eq.-2).
2608      &        AND.(LB2.LT.-5.and.lb2.ge.-13))GOTO 44
2609             IF((LB2.eq.-1.or.lb2.eq.-2).
2610      &        AND.(LB1.LT.-5.and.lb1.ge.-13))GOTO 44
2611 c
2612 * IF NUCLEON+NUCLEON COLLISION GO TO 4
2613        IF((LB1.eq.1.or.lb1.eq.2).AND.(LB2.eq.1.or.lb2.eq.2))GOTO 4
2614        IF((LB1.eq.-1.or.lb1.eq.-2).AND.(LB2.eq.-1.or.lb2.eq.-2))GOTO 4
2615 c
2616 * IF BARYON RESONANCE+BARYON RESONANCE COLLISION GO TO 444
2617             IF((LB1.GT.5.and.lb1.le.13).AND.
2618      &         (LB2.GT.5.and.lb2.le.13)) GOTO 444
2619             IF((LB1.LT.-5.and.lb1.ge.-13).AND.
2620      &         (LB2.LT.-5.and.lb2.ge.-13)) GOTO 444
2621 c
2622 * if L/S+L/S or L/s+nucleon go to 400
2623 * otherwise, develop a model for their collisions
2624        if((lb1.lt.3).and.(lb2.ge.14.and.lb2.le.17))goto 400
2625        if((lb2.lt.3).and.(lb1.ge.14.and.lb1.le.17))goto 400
2626        if((lb1.ge.14.and.lb1.le.17).and.
2627      &  (lb2.ge.14.and.lb2.le.17))goto 400
2628 c
2629 * otherwise, go out of the loop
2630               go to 400
2631 *
2632 *
2633 547           IF(LB1*LB2.EQ.0)THEN
2634 * (1) FOR ETA+NUCLEON SYSTEM, we allow both elastic collision,
2635 *     i.e. N*(1535) formation and kaon production
2636 *     the total kaon production cross section is
2637 *     ASSUMED to be THE SAME AS PION+NUCLEON COLLISIONS
2638 * (2) for eta+baryon resonance we only allow kaon production
2639            ece=(em1+em2+0.02)**2
2640            xkaon0=0.
2641            if(srt.ge.1.63.AND.SRT.LE.1.7)xkaon0=pnlka(srt)
2642            IF(SRT.GT.1.7)XKAON0=PNLKA(SRT)+pnska(srt)
2643 cbz3/7/99 neutralk
2644             XKAON0 = 2.0 * XKAON0
2645 cbz3/7/99 neutralk end
2646
2647 * Here we negelect eta+n inelastic collisions other than the
2648 * kaon production, therefore the total inelastic cross section
2649 * xkaon equals to the xkaon0 (kaon production cross section)
2650            xkaon=xkaon0
2651 * note here the xkaon is in unit of fm**2
2652             XETA=XN1535(I1,I2,0)
2653         If((iabs(LB(I1)).ge.6.and.iabs(LB(I1)).le.13).or.
2654      &     (iabs(LB(I2)).ge.6.and.iabs(LB(I2)).le.13)) xeta=0.
2655             IF((XETA+xkaon).LE.1.e-06)GO TO 400
2656             DSE=SQRT((XETA+XKAON)/PI)
2657            DELTRE=DSE+0.1
2658         px1cm=pcx
2659         py1cm=pcy
2660         pz1cm=pcz
2661 * CHECK IF N*(1535) resonance CAN BE FORMED
2662          CALL DISTCE(I1,I2,DELTRE,DSE,DT,ECE,SRT,IC,
2663      1   PCX,PCY,PCZ)
2664          IF(IC.EQ.-1) GO TO 400
2665          ekaon(4,iss)=ekaon(4,iss)+1
2666         IF(XKAON0/(XKAON+XETA).GT.RANART(NSEED))then
2667 * kaon production, USE CREN TO CALCULATE THE MOMENTUM OF L/S K+
2668         CALL CREN(PX1CM,PY1CM,PZ1CM,SRT,I1,I2,IBLOCK)
2669 * kaon production
2670        IF(IBLOCK.EQ.7) then
2671           LPN=LPN+1
2672        elseIF(IBLOCK.EQ.-7) then
2673        endif
2674 c
2675        em1=e(i1)
2676        em2=e(i2)
2677        GO TO 440
2678        endif
2679 * N*(1535) FORMATION
2680         resona=1.
2681          GO TO 98
2682          ENDIF
2683 *IF PION+NUCLEON (baryon resonance) COLLISION THEN
2684 3           CONTINUE
2685            px1cm=pcx
2686            py1cm=pcy
2687            pz1cm=pcz
2688 * the total kaon production cross section for pion+baryon (resonance) is
2689 * assumed to be the same as in pion+nucleon
2690            xkaon0=0.
2691            if(srt.ge.1.63.AND.SRT.LE.1.7)xkaon0=pnlka(srt)
2692            IF(SRT.GT.1.7)XKAON0=PNLKA(SRT)+pnska(srt)
2693             XKAON0 = 2.0 * XKAON0
2694 c
2695 c sp11/21/01  phi production: pi +N(D) -> phi + N(D)
2696          Xphi = 0.
2697        if( ( ((lb1.ge.1.and.lb1.le.2).or.
2698      &        (lb1.ge.6.and.lb1.le.9))
2699      &   .OR.((lb2.ge.1.and.lb2.le.2).or.
2700      &        (lb2.ge.6.and.lb2.le.9)) )
2701      &       .AND. srt.gt.1.958)
2702      &        call pibphi(srt,lb1,lb2,em1,em2,Xphi,xphin)
2703 c !! in fm^2 above
2704
2705 * if a pion collide with a baryon resonance,
2706 * we only allow kaon production AND the reabsorption
2707 * processes: Delta+pion-->N+pion, N*+pion-->N+pion
2708 * Later put in pion+baryon resonance elastic
2709 * cross through forming higher resonances implicitly.
2710 c          If(em1.gt.1.or.em2.gt.1.)go to 31
2711          If((iabs(LB(I1)).ge.6.and.iabs(LB(I1)).le.13).or.
2712      &      (iabs(LB(I2)).ge.6.and.iabs(LB(I2)).le.13)) go to 31
2713 * For pion+nucleon collisions:
2714 * using the experimental pion+nucleon inelastic cross section, we assume it
2715 * is exhausted by the Delta+pion, Delta+rho and Delta+omega production
2716 * and kaon production. In the following we first check whether
2717 * inelastic pion+n collision can happen or not, then determine in
2718 * crpn whether it is through pion production or through kaon production
2719 * note that the xkaon0 is the kaon production cross section
2720 * Note in particular that:
2721 * xkaon in the following is the total pion+nucleon inelastic cross section
2722 * note here the xkaon is in unit of fm**2, xnpi is also in unit of fm**2
2723 * FOR PION+NUCLEON SYSTEM, THE MINIMUM S IS 1.2056 the minimum srt for
2724 * elastic scattering, and it is 1.60 for pion production, 1.63 for LAMBDA+kaon
2725 * production and 1.7 FOR SIGMA+KAON
2726 * (EC = PION MASS+NUCLEON MASS+20MEV)**2
2727             EC=(em1+em2+0.02)**2
2728            xkaon=0.
2729            if(srt.gt.1.23)xkaon=(pionpp(srt)+PIPP1(SRT))/2.
2730 * pion+nucleon elastic cross section is divided into two parts:
2731 * (1) forming D(1232)+N*(1440) +N*(1535)
2732 * (2) cross sections forming higher resonances are calculated as
2733 *     the difference between the total elastic and (1), this part is
2734 *     treated as direct process since we do not explicitLY include
2735 *     higher resonances.
2736 * the following is the resonance formation cross sections.
2737 *1. PION(+)+PROTON-->DELTA++,PION(-)+NEUTRON-->DELTA(-)
2738            IF( (LB1*LB2.EQ.5.OR.((LB1*LB2.EQ.6).AND.
2739      &         (LB1.EQ.3.OR.LB2.EQ.3)))
2740      &    .OR. (LB1*LB2.EQ.-3.OR.((LB1*LB2.EQ.-10).AND.
2741      &         (LB1.EQ.5.OR.LB2.EQ.5))) )then
2742               XMAX=190.
2743               xmaxn=0
2744               xmaxn1=0
2745               xdirct=dirct1(srt)
2746                go to 678
2747            endif
2748 *2. PION(-)+PROTON-->DELTA0,PION(+)+NEUTRON-->DELTA+
2749 *   or N*(+)(1440) or N*(+)(1535)
2750 * note the factor 2/3 is from the isospin consideration and
2751 * the factor 0.6 or 0.5 is the branching ratio for the resonance to decay
2752 * into pion+nucleon
2753             IF( (LB1*LB2.EQ.3.OR.((LB1*LB2.EQ.10).AND.
2754      &          (LB1.EQ.5.OR.LB2.EQ.5)))
2755      &     .OR. (LB1*LB2.EQ.-5.OR.((LB1*LB2.EQ.-6).AND.
2756      &          (LB1.EQ.3.OR.LB2.EQ.3))) )then
2757               XMAX=27.
2758               xmaxn=2./3.*25.*0.6
2759                xmaxn1=2./3.*40.*0.5
2760               xdirct=dirct2(srt)
2761                go to 678
2762               endif
2763 *3. PION0+PROTON-->DELTA+,PION0+NEUTRON-->DELTA0, or N*(0)(1440) or N*(0)(1535)
2764             IF((LB1.EQ.4.OR.LB2.EQ.4).AND.
2765      &         (iabs(LB1*LB2).EQ.4.OR.iabs(LB1*LB2).EQ.8))then
2766               XMAX=50.
2767               xmaxn=1./3.*25*0.6
2768               xmaxn1=1/3.*40.*0.5
2769               xdirct=dirct3(srt)
2770                 go to 678
2771               endif
2772 678           xnpin1=0
2773            xnpin=0
2774             XNPID=XNPI(I1,I2,1,XMAX)
2775            if(xmaxn1.ne.0)xnpin1=XNPI(i1,i2,2,XMAXN1)
2776             if(xmaxn.ne.0)XNPIN=XNPI(I1,I2,0,XMAXN)
2777 * the following
2778            xres=xnpid+xnpin+xnpin1
2779            xnelas=xres+xdirct
2780            icheck=1
2781            go to 34
2782 * For pion + baryon resonance the reabsorption
2783 * cross section is calculated from the detailed balance
2784 * using reab(i1,i2,srt,ictrl), ictrl=1, 2 and 3
2785 * for pion, rho and omega + baryon resonance
2786 31           ec=(em1+em2+0.02)**2
2787            xreab=reab(i1,i2,srt,1)
2788
2789 clin-12/02/00 to satisfy detailed balance, forbid N* absorptions:
2790           if((iabs(lb1).ge.10.and.iabs(lb1).le.13)
2791      1         .or.(iabs(lb2).ge.10.and.iabs(lb2).le.13)) XREAB = 0.
2792
2793            xkaon=xkaon0+xreab
2794 * a constant of 10 mb IS USED FOR PION + N* RESONANCE,
2795         IF((iabs(LB1).GT.9.AND.iabs(LB1).LE.13) .OR.
2796      &      (iabs(LB2).GT.9.AND.iabs(LB2).LE.13))THEN
2797            Xnelas=1.0
2798         ELSE
2799            XNELAS=DPION(EM1,EM2,LB1,LB2,SRT)
2800         ENDIF
2801            icheck=2
2802 34          IF((Xnelas+xkaon+Xphi).LE.0.000001)GO TO 400
2803             DS=SQRT((Xnelas+xkaon+Xphi)/PI)
2804 csp09/20/01
2805 c           totcr = xnelas+xkaon
2806 c           if(srt .gt. 3.5)totcr = max1(totcr,3.)
2807 c           DS=SQRT(totcr/PI)
2808 csp09/20/01 end
2809
2810            deltar=ds+0.1
2811          CALL DISTCE(I1,I2,DELTAR,DS,DT,EC,SRT,IC,
2812      1   PCX,PCY,PCZ)
2813          IF(IC.EQ.-1) GO TO 400
2814        ekaon(4,iss)=ekaon(4,iss)+1
2815 c***
2816 * check what kind of collision has happened
2817 * (1) pion+baryon resonance
2818 * if direct elastic process
2819         if(icheck.eq.2)then
2820 c  !!sp11/21/01
2821       if(xnelas/(xnelas+xkaon+Xphi).ge.RANART(NSEED))then
2822 c               call Crdir(PX1CM,PY1CM,PZ1CM,SRT,I1,I2)
2823                call Crdir(PX1CM,PY1CM,PZ1CM,SRT,I1,I2,IBLOCK)
2824               go to 440
2825               else
2826 * for inelastic process, go to 96 to check
2827 * kaon production and pion reabsorption : pion+D(N*)-->pion+N
2828                go to 96
2829                 endif
2830               endif
2831 *(2) pion+n
2832 * CHECK IF inELASTIC COLLISION IS POSSIBLE FOR PION+N COLLISIONS
2833 clin-8/17/00 typo corrected, many other occurences:
2834 c        IF(XKAON/(XKAON+Xnelas).GT.RANART(NSEED))GO TO 95
2835        IF((XKAON+Xphi)/(XKAON+Xphi+Xnelas).GT.RANART(NSEED))GO TO 95
2836
2837 * direct process
2838         if(xdirct/xnelas.ge.RANART(NSEED))then
2839 c               call Crdir(PX1CM,PY1CM,PZ1CM,SRT,I1,I2)
2840                call Crdir(PX1CM,PY1CM,PZ1CM,SRT,I1,I2,IBLOCK)
2841               go to 440
2842               endif
2843 * now resonance formation or direct process (higher resonances)
2844            IF( (LB1*LB2.EQ.5.OR.((LB1*LB2.EQ.6).AND.
2845      &         (LB1.EQ.3.OR.LB2.EQ.3)))
2846      &    .OR. (LB1*LB2.EQ.-3.OR.((LB1*LB2.EQ.-10).AND.
2847      &         (LB1.EQ.5.OR.LB2.EQ.5))) )then
2848 c
2849 * ONLY DELTA RESONANCE IS POSSIBLE, go to 99
2850         GO TO 99
2851        else
2852 * NOW BOTH DELTA AND N* RESORANCE ARE POSSIBLE
2853 * DETERMINE THE RESORANT STATE BY USING THE MONTRE CARLO METHOD
2854             XX=(XNPIN+xnpin1)/xres
2855             IF(RANART(NSEED).LT.XX)THEN
2856 * N* RESONANCE IS SELECTED
2857 * decide N*(1440) or N*(1535) formation
2858         xx0=xnpin/(xnpin+xnpin1)
2859         if(RANART(NSEED).lt.xx0)then
2860          RESONA=0.
2861 * N*(1440) formation
2862          GO TO 97
2863         else
2864 * N*(1535) formation
2865         resona=1.
2866          GO TO 98
2867         endif
2868          ELSE
2869 * DELTA RESONANCE IS SELECTED
2870          GO TO 99
2871          ENDIF
2872          ENDIF
2873 97       CONTINUE
2874             IF(RESONA.EQ.0.)THEN
2875 *N*(1440) IS PRODUCED,WE DETERMINE THE CHARGE STATE OF THE PRODUCED N*
2876             I=I1
2877             IF(EM1.LT.0.6)I=I2
2878 * (0.1) n+pion(+)-->N*(+)
2879            IF( (LB1*LB2.EQ.10.AND.(LB1.EQ.5.OR.LB2.EQ.5))
2880      &      .OR.(LB1*LB2.EQ.-6.AND.(LB1.EQ.3.OR.LB2.EQ.3)) )THEN
2881             LB(I)=11
2882            go to 303
2883             ENDIF
2884 * (0.2) p+pion(0)-->N*(+)
2885 c            IF(LB(I1)*LB(I2).EQ.4.AND.(LB(I1).EQ.1.OR.LB(I2).EQ.1))THEN
2886             IF(iabs(LB(I1)*LB(I2)).EQ.4.AND.
2887      &         (LB(I1).EQ.4.OR.LB(I2).EQ.4))THEN
2888             LB(I)=11
2889            go to 303
2890             ENDIF
2891 * (0.3) n+pion(0)-->N*(0)
2892 c            IF(LB(I1)*LB(I2).EQ.8.AND.(LB(I1).EQ.2.OR.LB(I2).EQ.2))THEN
2893             IF(iabs(LB(I1)*LB(I2)).EQ.8.AND.
2894      &        (LB(I1).EQ.4.OR.LB(I2).EQ.4))THEN
2895             LB(I)=10
2896            go to 303
2897             ENDIF
2898 * (0.4) p+pion(-)-->N*(0)
2899 c            IF(LB(I1)*LB(I2).EQ.3)THEN
2900             IF( (LB(I1)*LB(I2).EQ.3)
2901      &      .OR.(LB(I1)*LB(I2).EQ.-5) )THEN
2902             LB(I)=10
2903             ENDIF
2904 303         CALL DRESON(I1,I2)
2905             if(LB1.lt.0.or.LB2.lt.0) LB(I)=-LB(I)
2906             lres=lres+1
2907             GO TO 101
2908 *COM: GO TO 101 TO CHANGE THE PHASE SPACE DENSITY OF THE NUCLEON
2909             ENDIF
2910 98          IF(RESONA.EQ.1.)THEN
2911 *N*(1535) IS PRODUCED, WE DETERMINE THE CHARGE STATE OF THE PRODUCED N*
2912             I=I1
2913             IF(EM1.LT.0.6)I=I2
2914 * note: this condition applies to both eta and pion
2915 * (0.1) n+pion(+)-->N*(+)
2916 c            IF(LB1*LB2.EQ.10.AND.(LB1.EQ.2.OR.LB2.EQ.2))THEN
2917             IF( (LB1*LB2.EQ.10.AND.(LB1.EQ.5.OR.LB2.EQ.5))
2918      &      .OR.(LB1*LB2.EQ.-6.AND.(LB1.EQ.3.OR.LB2.EQ.3)) )THEN
2919             LB(I)=13
2920            go to 304
2921             ENDIF
2922 * (0.2) p+pion(0)-->N*(+)
2923 c            IF(LB(I1)*LB(I2).EQ.4.AND.(LB(I1).EQ.1.OR.LB(I2).EQ.1))THEN
2924             IF(iabs(LB(I1)*LB(I2)).EQ.4.AND.
2925      &           (LB(I1).EQ.4.OR.LB(I2).EQ.4))THEN
2926             LB(I)=13
2927            go to 304
2928             ENDIF
2929 * (0.3) n+pion(0)-->N*(0)
2930 c            IF(LB(I1)*LB(I2).EQ.8.AND.(LB(I1).EQ.2.OR.LB(I2).EQ.2))THEN
2931             IF(iabs(LB(I1)*LB(I2)).EQ.8.AND.
2932      &           (LB(I1).EQ.4.OR.LB(I2).EQ.4))THEN
2933             LB(I)=12
2934            go to 304
2935             ENDIF
2936 * (0.4) p+pion(-)-->N*(0)
2937 c            IF(LB(I1)*LB(I2).EQ.3)THEN
2938             IF( (LB(I1)*LB(I2).EQ.3)
2939      &      .OR.(LB(I1)*LB(I2).EQ.-5) )THEN
2940             LB(I)=12
2941            go to 304
2942            endif
2943 * (0.5) p+eta-->N*(+)(1535),n+eta-->N*(0)(1535)
2944            if(lb(i1)*lb(i2).eq.0)then
2945 c            if((lb(i1).eq.1).or.(lb(i2).eq.1))then
2946             if(iabs(lb(i1)).eq.1.or.iabs(lb(i2)).eq.1)then
2947            LB(I)=13
2948            go to 304
2949            ELSE
2950            LB(I)=12
2951            ENDIF
2952            endif
2953 304         CALL DRESON(I1,I2)
2954             if(LB1.lt.0.or.LB2.lt.0) LB(I)=-LB(I)
2955             lres=lres+1
2956             GO TO 101
2957 *COM: GO TO 101 TO CHANGE THE PHASE SPACE DENSITY OF THE NUCLEON
2958             ENDIF
2959 *DELTA IS PRODUCED,IN THE FOLLOWING WE DETERMINE THE
2960 *CHARGE STATE OF THE PRODUCED DELTA
2961 99      LRES=LRES+1
2962         I=I1
2963         IF(EM1.LE.0.6)I=I2
2964 * (1) p+pion(+)-->DELTA(++)
2965 c        IF(LB(I1)*LB(I2).EQ.5)THEN
2966             IF( (LB(I1)*LB(I2).EQ.5)
2967      &      .OR.(LB(I1)*LB(I2).EQ.-3) )THEN
2968         LB(I)=9
2969        go to 305
2970         ENDIF
2971 * (2) p+pion(0)-->delta(+)
2972 c        IF(LB(I1)*LB(I2).EQ.4.AND.(LB(I1).EQ.1.OR.LB(I2).EQ.1))then
2973        IF(iabs(LB(I1)*LB(I2)).EQ.4.AND.(LB(I1).EQ.4.OR.LB(I2).EQ.4))then
2974         LB(I)=8
2975        go to 305
2976         ENDIF
2977 * (3) n+pion(+)-->delta(+)
2978 c        IF(LB(I1)*LB(I2).EQ.10.AND.(LB(I1).EQ.2.OR.LB(I2).EQ.2))THEN
2979        IF( (LB(I1)*LB(I2).EQ.10.AND.(LB(I1).EQ.5.OR.LB(I2).EQ.5))
2980      & .OR.(LB(I1)*LB(I2).EQ.-6.AND.(LB(I1).EQ.3.OR.LB(I2).EQ.3)) )THEN
2981         LB(I)=8
2982        go to 305
2983         ENDIF
2984 * (4) n+pion(0)-->delta(0)
2985 c        IF(LB(I1)*LB(I2).EQ.8.AND.(LB(I1).EQ.2.OR.LB(I2).EQ.2))THEN
2986        IF(iabs(LB(I1)*LB(I2)).EQ.8.AND.(LB(I1).EQ.4.OR.LB(I2).EQ.4))THEN
2987         LB(I)=7
2988        go to 305
2989         ENDIF
2990 * (5) p+pion(-)-->delta(0)
2991 c        IF(LB(I1)*LB(I2).EQ.3)THEN
2992             IF( (LB(I1)*LB(I2).EQ.3)
2993      &      .OR.(LB(I1)*LB(I2).EQ.-5) )THEN
2994         LB(I)=7
2995        go to 305
2996         ENDIF
2997 * (6) n+pion(-)-->delta(-)
2998 c        IF(LB(I1)*LB(I2).EQ.6.AND.(LB(I1).EQ.2.OR.LB(I2).EQ.2))THEN
2999        IF( (LB(I1)*LB(I2).EQ.6.AND.(LB(I1).EQ.3.OR.LB(I2).EQ.3))
3000      & .OR.(LB(I1)*LB(I2).EQ.-10.AND.(LB(I1).EQ.5.OR.LB(I2).EQ.5)) )THEN
3001         LB(I)=6
3002         ENDIF
3003 305     CALL DRESON(I1,I2)
3004         if(LB1.lt.0.or.LB2.lt.0) LB(I)=-LB(I)
3005        GO TO 101
3006
3007 csp-11/08/01 K*
3008 * FOR kaON+pion COLLISIONS, form K* (bar) or
3009 c La/Si-bar + N <-- pi + K+
3010 c La/Si + N-bar <-- pi + K-
3011 c phi + K <-- pi + K
3012 clin (rho,omega) + K* <-- pi + K
3013 889       CONTINUE
3014         PX1CM=PCX
3015         PY1CM=PCY
3016         PZ1CM=PCZ
3017         EC=(em1+em2+0.02)**2
3018 * the cross section is from C.M. Ko, PRC 23, 2760 (1981).
3019        spika=60./(1.+4.*(srt-0.895)**2/(0.05)**2)
3020 c
3021 cc       if(lb(i1).eq.23.or.lb(i2).eq.23)then   !! block  K- + pi->La + B-bar
3022
3023         call Crkpla(PX1CM,PY1CM,PZ1CM,EC,SRT,spika,
3024      &                  emm1,emm2,lbp1,lbp2,I1,I2,icase,srhoks)
3025 cc
3026 c* only K* or K*bar formation
3027 c       else
3028 c      DSkn=SQRT(spika/PI/10.)
3029 c      dsknr=dskn+0.1
3030 c      CALL DISTCE(I1,I2,dsknr,DSkn,DT,EC,SRT,IC,
3031 c    1     PX1CM,PY1CM,PZ1CM)
3032 c        IF(IC.EQ.-1) GO TO 400
3033 c       icase = 1
3034 c      endif
3035 c
3036          if(icase .eq. 0) then
3037             iblock=0
3038             go to 400
3039          endif
3040
3041        if(icase .eq. 1)then
3042              call KSRESO(I1,I2)
3043 clin-4/30/03 give non-zero iblock for resonance selections:
3044              iblock = 171
3045 ctest off for resonance (phi, K*) studies:
3046 c             if(iabs(lb(i1)).eq.30) then
3047 c             write(17,112) 'ks',lb(i1),p(1,i1),p(2,i1),p(3,i1),e(i1),nt
3048 c             elseif(iabs(lb(i2)).eq.30) then
3049 c             write(17,112) 'ks',lb(i2),p(1,i2),p(2,i2),p(3,i2),e(i2),nt
3050 c             endif
3051 c
3052               lres=lres+1
3053               go to 101
3054        elseif(icase .eq. 2)then
3055              iblock = 71
3056 c
3057 * La/Si (bar) formation
3058
3059        elseif(iabs(icase).eq.5)then
3060              iblock = 88
3061
3062        else
3063 *
3064 * phi formation
3065              iblock = 222
3066        endif
3067              LB(I1) = lbp1
3068              LB(I2) = lbp2
3069              E(I1) = emm1
3070              E(I2) = emm2
3071              em1=e(i1)
3072              em2=e(i2)
3073              ntag = 0
3074              go to 440
3075 c
3076 33       continue
3077        em1=e(i1)
3078        em2=e(i2)
3079 * (1) if rho or omega collide with a nucleon we allow both elastic
3080 *     scattering and kaon production to happen if collision conditions
3081 *     are satisfied.
3082 * (2) if rho or omega collide with a baryon resonance we allow
3083 *     kaon production, pion reabsorption: rho(omega)+D(N*)-->pion+N
3084 *     and NO elastic scattering to happen
3085            xelstc=0
3086             if((lb1.ge.25.and.lb1.le.28).and.
3087      &    (iabs(lb2).eq.1.or.iabs(lb2).eq.2))
3088      &      xelstc=ERHON(EM1,EM2,LB1,LB2,SRT)
3089             if((lb2.ge.25.and.lb2.le.28).and.
3090      &   (iabs(lb1).eq.1.or.iabs(lb1).eq.2))
3091      &      xelstc=ERHON(EM1,EM2,LB1,LB2,SRT)
3092             ec=(em1+em2+0.02)**2
3093 * the kaon production cross section is
3094            xkaon0=0
3095            if(srt.ge.1.63.AND.SRT.LE.1.7)xkaon0=pnlka(srt)
3096            IF(SRT.GT.1.7)XKAON0=PNLKA(SRT)+pnska(srt)
3097            if(xkaon0.lt.0)xkaon0=0
3098
3099 cbz3/7/99 neutralk
3100             XKAON0 = 2.0 * XKAON0
3101 cbz3/7/99 neutralk end
3102
3103 * the total inelastic cross section for rho(omega)+N is
3104            xkaon=xkaon0
3105            ichann=0
3106 * the total inelastic cross section for rho (omega)+D(N*) is
3107 * xkaon=xkaon0+reab(**)
3108
3109 c sp11/21/01  phi production: rho + N(D) -> phi + N(D)
3110          Xphi = 0.
3111        if( ( (((lb1.ge.1.and.lb1.le.2).or.
3112      &         (lb1.ge.6.and.lb1.le.9))
3113      &         .and.(lb2.ge.25.and.lb2.le.27))
3114      &   .OR.(((lb2.ge.1.and.lb2.le.2).or.
3115      &         (lb2.ge.6.and.lb2.le.9))
3116      &        .and.(lb1.ge.25.and.lb1.le.27)) ).AND. srt.gt.1.958)
3117      &    call pibphi(srt,lb1,lb2,em1,em2,Xphi,xphin)
3118 c !! in fm^2 above
3119 c
3120         if((iabs(lb1).ge.6.and.lb2.ge.25).or.
3121      &    (lb1.ge.25.and.iabs(lb2).ge.6))then
3122            ichann=1
3123            ictrl=2
3124            if(lb1.eq.28.or.lb2.eq.28)ictrl=3
3125             xreab=reab(i1,i2,srt,ictrl)
3126
3127 clin-12/02/00 to satisfy detailed balance, forbid N* absorptions:
3128             if((iabs(lb1).ge.10.and.iabs(lb1).le.13)
3129      1           .or.(iabs(lb2).ge.10.and.iabs(lb2).le.13)) XREAB = 0.
3130
3131         if(xreab.lt.0)xreab=1.E-06
3132             xkaon=xkaon0+xreab
3133           XELSTC=1.0
3134            endif
3135             DS=SQRT((XKAON+Xphi+xelstc)/PI)
3136 c
3137 csp09/20/01
3138 c           totcr = xelstc+xkaon
3139 c           if(srt .gt. 3.5)totcr = max1(totcr,3.)
3140 c           DS=SQRT(totcr/PI)
3141 csp09/20/01 end
3142 c
3143         DELTAR=DS+0.1
3144        px1cm=pcx
3145        py1cm=pcy
3146        pz1cm=pcz
3147 * CHECK IF the collision can happen
3148          CALL DISTCE(I1,I2,DELTAR,DS,DT,EC,SRT,IC,
3149      1   PCX,PCY,PCZ)
3150          IF(IC.EQ.-1) GO TO 400
3151         ekaon(4,iss)=ekaon(4,iss)+1
3152 c*
3153 * NOW rho(omega)+N or D(N*) COLLISION IS POSSIBLE
3154 * (1) check elastic collision
3155        if(xelstc/(xelstc+xkaon+Xphi).gt.RANART(NSEED))then
3156 c       call crdir(px1CM,py1CM,pz1CM,srt,I1,i2)
3157        call crdir(px1CM,py1CM,pz1CM,srt,I1,i2,IBLOCK)
3158        go to 440
3159        endif
3160 * (2) check pion absorption or kaon production
3161         CALL CRRD(PX1CM,PY1CM,PZ1CM,SRT,I1,I2,
3162      1  IBLOCK,xkaon0,xkaon,Xphi,xphin)
3163
3164 * kaon production
3165 csp05/16/01
3166        IF(IBLOCK.EQ.7) then
3167           LPN=LPN+1
3168        elseIF(IBLOCK.EQ.-7) then
3169        endif
3170 csp05/16/01 end
3171 * rho obsorption
3172        if(iblock.eq.81) lrhor=lrhor+1
3173 * omega obsorption
3174        if(iblock.eq.82) lomgar=lomgar+1
3175        em1=e(i1)
3176        em2=e(i2)
3177        GO TO 440
3178 * for pion+n now using the subroutine crpn to change
3179 * the particle label and set the new momentum of L/S+K final state
3180 95       continue
3181 * NOW PION+N INELASTIC COLLISION IS POSSIBLE
3182 * check pion production or kaon production
3183         CALL CRPN(PX1CM,PY1CM,PZ1CM,SRT,I1,I2,
3184      1  IBLOCK,xkaon0,xkaon,Xphi,xphin)
3185
3186 * kaon production
3187 csp05/16/01
3188        IF(IBLOCK.EQ.7) then
3189           LPN=LPN+1
3190        elseIF(IBLOCK.EQ.-7) then
3191        endif
3192 csp05/16/01 end
3193 * pion production
3194        if(iblock.eq.77) lpd=lpd+1
3195 * rho production
3196        if(iblock.eq.78) lrho=lrho+1
3197 * omega production
3198        if(iblock.eq.79) lomega=lomega+1
3199        em1=e(i1)
3200        em2=e(i2)
3201        GO TO 440
3202 * for pion+D(N*) now using the subroutine crpd to
3203 * (1) check kaon production or pion reabsorption
3204 * (2) change the particle label and set the new
3205 *     momentum of L/S+K final state
3206 96       continue
3207         CALL CRPD(PX1CM,PY1CM,PZ1CM,SRT,I1,I2,
3208      1  IBLOCK,xkaon0,xkaon,Xphi,xphin)
3209
3210 * kaon production
3211 csp05/16/01
3212        IF(IBLOCK.EQ.7) then
3213           LPN=LPN+1
3214        elseIF(IBLOCK.EQ.-7) then
3215        endif
3216 csp05/16/01 end
3217 * pion obserption
3218        if(iblock.eq.80) lpdr=lpdr+1
3219        em1=e(i1)
3220        em2=e(i2)
3221        GO TO 440
3222 * CALCULATE KAON PRODUCTION PROBABILITY FROM PION + N COLLISIONS
3223 C        IF(SRT.GT.1.615)THEN
3224 C        CALL PKAON(SRT,XXp,PK)
3225 C        TKAON(7)=TKAON(7)+PK
3226 C        EKAON(7,ISS)=EKAON(7,ISS)+1
3227 c        CALL KSPEC1(SRT,PK)
3228 C        call LK(3,srt,iseed,pk)
3229 C        ENDIF
3230 * negelecting the pauli blocking at high energies
3231
3232 101       continue
3233         IF(E(I2).EQ.0.)GO TO 600
3234         IF(E(I1).EQ.0.)GO TO 800
3235 * IF NUCLEON+BARYON RESONANCE COLLISIONS
3236 44      CONTINUE
3237 * CALCULATE THE TOTAL CROSS SECTION OF NUCLEON+ BARYON RESONANCE COLLISION
3238 * WE ASSUME THAT THE ELASTIC CROSS SECTION IS THE SAME AS NUCLEON+NUCLEON
3239 * COM: WE USE THE PARAMETERISATION BY CUGNON FOR LOW ENERGIES
3240 *      AND THE PARAMETERIZATIONS FROM CERN DATA BOOK FOR HIGHER
3241 *      ENERGIES. THE CUTOFF FOR THE TOTAL CROSS SECTION IS 55 MB
3242        cutoff=em1+em2+0.02
3243        IF(SRT.LE.CUTOFF)GO TO 400
3244         IF(SRT.GT.2.245)THEN
3245        SIGNN=PP2(SRT)
3246        ELSE
3247         SIGNN = 35.0 / (1. + (SRT - CUTOFF) * 100.0)  +  20.0
3248        ENDIF
3249         call XND(pcx,pcy,pcz,srt,I1,I2,xinel,
3250      &               sigk,xsk1,xsk2,xsk3,xsk4,xsk5)
3251        sig=signn+xinel
3252 * For nucleon+baryon resonance collision, the minimum cms**2 energy is
3253         EC=(EM1+EM2+0.02)**2
3254 * CHECK THE DISTENCE BETWEEN THE TWO PARTICLES
3255         PX1CM=PCX
3256         PY1CM=PCY
3257         PZ1CM=PCZ
3258
3259 clin-6/2008 Deuteron production:
3260         ianti=0
3261         if(lb(i1).lt.0 .and. lb(i2).lt.0) ianti=1
3262         call sbbdm(srt,sdprod,ianti,lbm,xmm,pfinal)
3263         sig=sig+sdprod
3264 clin-6/2008 perturbative treatment of deuterons:
3265         ipdflag=0
3266         if(idpert.eq.1) then
3267            ipert1=1
3268            sigr0=sig
3269            dspert=sqrt(sigr0/pi/10.)
3270            dsrpert=dspert+0.1
3271            CALL DISTCE(I1,I2,dsrpert,dspert,DT,EC,SRT,IC,
3272      1          PX1CM,PY1CM,PZ1CM)
3273            IF(IC.EQ.-1) GO TO 363
3274            signn0=0.
3275            CALL CRND(IRUN,PX1CM,PY1CM,PZ1CM,SRT,I1,I2,
3276      &  IBLOCK,SIGNN0,SIGr0,sigk,xsk1,xsk2,xsk3,xsk4,xsk5,NT,ipert1)
3277 c     &  IBLOCK,SIGNN,SIG,sigk,xsk1,xsk2,xsk3,xsk4,xsk5)
3278            ipdflag=1
3279  363       continue
3280            ipert1=0
3281         endif
3282         if(idpert.eq.2) ipert1=1
3283 c
3284         DS=SQRT(SIG/(10.*PI))
3285         DELTAR=DS+0.1
3286         CALL DISTCE(I1,I2,DELTAR,DS,DT,EC,SRT,IC,
3287      1  PX1CM,PY1CM,PZ1CM)
3288 c        IF(IC.EQ.-1)GO TO 400
3289         IF(IC.EQ.-1) then
3290            if(ipdflag.eq.1) iblock=501
3291            GO TO 400
3292         endif
3293
3294         ekaon(3,iss)=ekaon(3,iss)+1
3295 * CALCULATE KAON PRODUCTION PROBABILITY FROM NUCLEON + BARYON RESONANCE
3296 * COLLISIONS
3297         go to 361
3298
3299 * CHECK WHAT KIND OF COLLISION HAS HAPPENED
3300  361    continue
3301         CALL CRND(IRUN,PX1CM,PY1CM,PZ1CM,SRT,I1,I2,
3302      &     IBLOCK,SIGNN,SIG,sigk,xsk1,xsk2,xsk3,xsk4,xsk5,NT,ipert1)
3303 c     &  IBLOCK,SIGNN,SIG,sigk,xsk1,xsk2,xsk3,xsk4,xsk5)
3304         IF(iblock.eq.0.and.ipdflag.eq.1) iblock=501
3305         IF(IBLOCK.EQ.11)THEN
3306            LNDK=LNDK+1
3307            GO TO 400
3308 c        elseIF(IBLOCK.EQ.-11) then
3309         elseIF(IBLOCK.EQ.-11.or.iblock.eq.501) then
3310            GO TO 400
3311         ENDIF
3312         if(iblock .eq. 222)then
3313 c    !! sp12/17/01
3314            GO TO 400
3315         ENDIF
3316         em1=e(i1)
3317         em2=e(i2)
3318         GO TO 440
3319 * IF NUCLEON+NUCLEON OR BARYON RESONANCE+BARYON RESONANCE COLLISIONS
3320 4       CONTINUE
3321 * PREPARE THE EALSTIC CROSS SECTION FOR BARYON+BARYON COLLISIONS
3322 * COM: WE USE THE PARAMETERISATION BY CUGNON FOR SRT LEQ 2.0 GEV
3323 *      AND THE PARAMETERIZATIONS FROM CERN DATA BOOK FOR HIGHER
3324 *      ENERGIES. THE CUTOFF FOR THE TOTAL CROSS SECTION IS 55 MB
3325 *      WITH LOW-ENERGY-CUTOFF
3326         CUTOFF=em1+em2+0.14
3327 * AT HIGH ENERGIES THE ISOSPIN DEPENDENCE IS NEGLIGIBLE
3328 * THE TOTAL CROSS SECTION IS TAKEN AS THAT OF THE PP
3329 * ABOVE E_KIN=800 MEV, WE USE THE ISOSPIN INDEPENDNET XSECTION
3330         IF(SRT.GT.2.245)THEN
3331            SIG=ppt(srt)
3332            SIGNN=SIG-PP1(SRT)
3333         ELSE
3334 * AT LOW ENERGIES THE ISOSPIN DEPENDENCE FOR NN COLLISION IS STRONG
3335            SIG=XPP(SRT)
3336            IF(ZET(LB(I1))*ZET(LB(I2)).LE.0)SIG=XNP(SRT)
3337            IF(ZET(LB(I1))*ZET(LB(I2)).GT.0)SIG=XPP(SRT)
3338            IF(ZET(LB(I1)).EQ.0.
3339      &          AND.ZET(LB(I2)).EQ.0)SIG=XPP(SRT)
3340            if((lb(i1).eq.-1.and.lb(i2).eq.-2) .or.
3341      &          (lb(i2).eq.-1.and.lb(i1).eq.-2))sig=xnp(srt)
3342 *     WITH LOW-ENERGY-CUTOFF
3343            IF (SRT .LT. 1.897) THEN
3344               SIGNN = SIG
3345            ELSE
3346               SIGNN = 35.0 / (1. + (SRT - 1.897) * 100.0)  +  20.0
3347            ENDIF
3348         ENDIF
3349         PX1CM=PCX
3350         PY1CM=PCY
3351         PZ1CM=PCZ
3352 clin-5/2008 Deuteron production cross sections were not included
3353 c     in the previous parameterized inelastic cross section of NN collisions
3354 c     (SIGinel=SIG-SIGNN), so they are added here:
3355         ianti=0
3356         if(lb(i1).lt.0 .and. lb(i2).lt.0) ianti=1
3357         call sbbdm(srt,sdprod,ianti,lbm,xmm,pfinal)
3358         sig=sig+sdprod
3359 c
3360 clin-5/2008 perturbative treatment of deuterons:
3361         ipdflag=0
3362         if(idpert.eq.1) then
3363 c     For idpert=1: ipert1=1 means we will first treat deuteron perturbatively,
3364 c     then we set ipert1=0 to treat regular NN or NbarNbar collisions including
3365 c     the regular deuteron productions.
3366 c     ipdflag=1 means perturbative deuterons are produced here:
3367            ipert1=1
3368            EC=2.012**2
3369 c     Use the same cross section for NN/NNBAR collisions
3370 c     to trigger perturbative production
3371            sigr0=sig
3372 c     One can also trigger with X*sbbdm() so the weight will not be too small;
3373 c     but make sure to limit the maximum trigger Xsec:
3374 c           sigr0=sdprod*25.
3375 c           if(sigr0.ge.100.) sigr0=100.
3376            dspert=sqrt(sigr0/pi/10.)
3377            dsrpert=dspert+0.1
3378            CALL DISTCE(I1,I2,dsrpert,dspert,DT,EC,SRT,IC,
3379      1          PX1CM,PY1CM,PZ1CM)
3380            IF(IC.EQ.-1) GO TO 365
3381            signn0=0.
3382            CALL CRNN(IRUN,PX1CM,PY1CM,PZ1CM,SRT,I1,I2,IBLOCK,
3383      1          NTAG,signn0,sigr0,NT,ipert1)
3384            ipdflag=1
3385  365       continue
3386            ipert1=0
3387         endif
3388         if(idpert.eq.2) ipert1=1
3389 c
3390 clin-5/2008 in case perturbative deuterons are produced for idpert=1:
3391 c        IF(SIGNN.LE.0)GO TO 400
3392         IF(SIGNN.LE.0) then
3393            if(ipdflag.eq.1) iblock=501
3394            GO TO 400
3395         endif
3396 c
3397         EC=3.59709
3398         ds=sqrt(sig/pi/10.)
3399         dsr=ds+0.1
3400         IF((E(I1).GE.1.).AND.(e(I2).GE.1.))EC=4.75
3401         CALL DISTCE(I1,I2,dsr,ds,DT,EC,SRT,IC,
3402      1       PX1CM,PY1CM,PZ1CM)
3403 clin-5/2008 in case perturbative deuterons are produced above:
3404 c        IF(IC.EQ.-1) GO TO 400
3405         IF(IC.EQ.-1) then
3406            if(ipdflag.eq.1) iblock=501
3407            GO TO 400
3408         endif
3409 c
3410 * CALCULATE KAON PRODUCTION PROBABILITY FROM NUCLEON+NUCLEON OR
3411 * RESONANCE+RESONANCE COLLISIONS
3412         go to 362
3413
3414 C CHECK WHAT KIND OF COLLISION HAS HAPPENED
3415  362    ekaon(1,iss)=ekaon(1,iss)+1
3416         CALL CRNN(IRUN,PX1CM,PY1CM,PZ1CM,SRT,I1,I2,IBLOCK,
3417      1       NTAG,SIGNN,SIG,NT,ipert1)
3418 clin-5/2008 give iblock # in case pert deuterons are produced for idpert=1:
3419         IF(iblock.eq.0.and.ipdflag.eq.1) iblock=501
3420 clin-5/2008 add iblock # for deuteron formation:
3421 c        IF(IBLOCK.EQ.4.OR.IBLOCK.Eq.9.or.iblock.ge.44.OR.IBLOCK.EQ.-9
3422 c     &       .or.iblock.eq.222)THEN
3423         IF(IBLOCK.EQ.4.OR.IBLOCK.Eq.9.or.iblock.ge.44.OR.IBLOCK.EQ.-9
3424      &       .or.iblock.eq.222.or.iblock.eq.501)THEN
3425 c
3426 c     !! sp12/17/01 above
3427 * momentum of the three particles in the final state have been calculated
3428 * in the crnn, go out of the loop
3429            LCOLL=LCOLL+1
3430            if(iblock.eq.4)then
3431               LDIRT=LDIRT+1
3432            elseif(iblock.eq.44)then
3433               LDdrho=LDdrho+1
3434            elseif(iblock.eq.45)then
3435               Lnnrho=Lnnrho+1
3436            elseif(iblock.eq.46)then
3437               Lnnom=Lnnom+1
3438            elseif(iblock .eq. 222)then
3439            elseIF(IBLOCK.EQ.9) then
3440               LNNK=LNNK+1
3441            elseIF(IBLOCK.EQ.-9) then
3442            endif
3443            GO TO 400
3444         ENDIF
3445
3446         em1=e(i1)
3447         em2=e(i2)
3448         GO TO 440
3449 clin-8/2008 B+B->Deuteron+Meson over
3450 c
3451 clin-8/2008 Deuteron+Meson->B+B collisions:
3452  505    continue
3453         ianti=0
3454         if(lb(i1).lt.0 .or. lb(i2).lt.0) ianti=1
3455         call sdmbb(SRT,sdm,ianti)
3456         PX1CM=PCX
3457         PY1CM=PCY
3458         PZ1CM=PCZ
3459 c     minimum srt**2, note a 2.012GeV lower cutoff is used in N+N->Deuteron+pi:
3460         EC=2.012**2
3461         ds=sqrt(sdm/31.4)
3462         dsr=ds+0.1
3463         CALL DISTCE(I1,I2,dsr,ds,DT,EC,SRT,IC,PX1CM,PY1CM,PZ1CM)
3464         IF(IC.EQ.-1) GO TO 400
3465         CALL crdmbb(PX1CM,PY1CM,PZ1CM,SRT,I1,I2,IBLOCK,
3466      1       NTAG,sdm,NT,ianti)
3467         LCOLL=LCOLL+1
3468         GO TO 400
3469 clin-8/2008 Deuteron+Meson->B+B collisions over
3470 c
3471 clin-9/2008 Deuteron+Baryon elastic collisions:
3472  506    continue
3473         ianti=0
3474         if(lb(i1).lt.0 .or. lb(i2).lt.0) ianti=1
3475         call sdbelastic(SRT,sdb)
3476         PX1CM=PCX
3477         PY1CM=PCY
3478         PZ1CM=PCZ
3479 c     minimum srt**2, note a 2.012GeV lower cutoff is used in N+N->Deuteron+pi:
3480         EC=2.012**2
3481         ds=sqrt(sdb/31.4)
3482         dsr=ds+0.1
3483         CALL DISTCE(I1,I2,dsr,ds,DT,EC,SRT,IC,PX1CM,PY1CM,PZ1CM)
3484         IF(IC.EQ.-1) GO TO 400
3485         CALL crdbel(PX1CM,PY1CM,PZ1CM,SRT,I1,I2,IBLOCK,
3486      1       NTAG,sdb,NT,ianti)
3487         LCOLL=LCOLL+1
3488         GO TO 400
3489 clin-9/2008 Deuteron+Baryon elastic collisions over
3490 c
3491 * IF BARYON RESONANCE+BARYON RESONANCE COLLISIONS
3492  444    CONTINUE
3493 * PREPARE THE EALSTIC CROSS SECTION FOR BARYON+BARYON COLLISIONS
3494        CUTOFF=em1+em2+0.02
3495 * AT HIGH ENERGIES THE ISOSPIN DEPENDENCE IS NEGLIGIBLE
3496 * THE TOTAL CROSS SECTION IS TAKEN AS THAT OF THE PP
3497        IF(SRT.LE.CUTOFF)GO TO 400
3498         IF(SRT.GT.2.245)THEN
3499        SIGNN=PP2(SRT)
3500        ELSE
3501         SIGNN = 35.0 / (1. + (SRT - CUTOFF) * 100.0)  +  20.0
3502        ENDIF
3503        IF(SIGNN.LE.0)GO TO 400
3504       CALL XDDIN(PCX,PCY,PCZ,SRT,I1,I2,
3505      &XINEL,SIGK,XSK1,XSK2,XSK3,XSK4,XSK5)
3506        SIG=SIGNN+XINEL
3507        EC=(EM1+EM2+0.02)**2
3508         PX1CM=PCX
3509         PY1CM=PCY
3510         PZ1CM=PCZ
3511
3512 clin-6/2008 Deuteron production:
3513         ianti=0
3514         if(lb(i1).lt.0 .and. lb(i2).lt.0) ianti=1
3515         call sbbdm(srt,sdprod,ianti,lbm,xmm,pfinal)
3516         sig=sig+sdprod
3517 clin-6/2008 perturbative treatment of deuterons:
3518         ipdflag=0
3519         if(idpert.eq.1) then
3520            ipert1=1
3521            sigr0=sig
3522            dspert=sqrt(sigr0/pi/10.)
3523            dsrpert=dspert+0.1
3524            CALL DISTCE(I1,I2,dsrpert,dspert,DT,EC,SRT,IC,
3525      1          PX1CM,PY1CM,PZ1CM)
3526            IF(IC.EQ.-1) GO TO 367
3527            signn0=0.
3528            CALL CRDD(IRUN,PX1CM,PY1CM,PZ1CM,SRT,I1,I2,
3529      1          IBLOCK,NTAG,SIGNN0,SIGr0,NT,ipert1)
3530 c     1          IBLOCK,NTAG,SIGNN,SIG)
3531            ipdflag=1
3532  367       continue
3533            ipert1=0
3534         endif
3535         if(idpert.eq.2) ipert1=1
3536 c
3537         ds=sqrt(sig/31.4)
3538         dsr=ds+0.1
3539         CALL DISTCE(I1,I2,dsr,ds,DT,EC,SRT,IC,
3540      1  PX1CM,PY1CM,PZ1CM)
3541 c        IF(IC.EQ.-1) GO TO 400
3542         IF(IC.EQ.-1) then
3543            if(ipdflag.eq.1) iblock=501
3544            GO TO 400
3545         endif
3546
3547 * CALCULATE KAON PRODUCTION PROBABILITY FROM NUCLEON+NUCLEON OR
3548 * RESONANCE+RESONANCE COLLISIONS
3549        go to 364
3550
3551 C CHECK WHAT KIND OF COLLISION HAS HAPPENED
3552 364       ekaon(2,iss)=ekaon(2,iss)+1
3553 * for resonance+resonance
3554 clin-6/2008:
3555         CALL CRDD(IRUN,PX1CM,PY1CM,PZ1CM,SRT,I1,I2,
3556      1  IBLOCK,NTAG,SIGNN,SIG,NT,ipert1)
3557 c     1  IBLOCK,NTAG,SIGNN,SIG)
3558         IF(iblock.eq.0.and.ipdflag.eq.1) iblock=501
3559 c
3560         IF(iabs(IBLOCK).EQ.10)THEN
3561 * momentum of the three particles in the final state have been calculated
3562 * in the crnn, go out of the loop
3563            LCOLL=LCOLL+1
3564            IF(IBLOCK.EQ.10)THEN
3565               LDDK=LDDK+1
3566            elseIF(IBLOCK.EQ.-10) then
3567            endif
3568            GO TO 400
3569         ENDIF
3570 clin-6/2008
3571 c        if(iblock .eq. 222)then
3572         if(iblock .eq. 222.or.iblock.eq.501)then
3573 c    !! sp12/17/01
3574            GO TO 400
3575         ENDIF
3576         em1=e(i1)
3577         em2=e(i2)
3578         GO TO 440
3579 * FOR PION+PION,pion+eta, eta+eta and rho(omega)+pion(rho,omega) or eta
3580 777       CONTINUE
3581         PX1CM=PCX
3582         PY1CM=PCY
3583         PZ1CM=PCZ
3584 * energy thresh for collisions
3585        ec0=em1+em2+0.02
3586        IF(SRT.LE.ec0)GO TO 400
3587        ec=(em1+em2+0.02)**2
3588 * we negelect the elastic collision between mesons except that betwen
3589 * two pions because of the lack of information about these collisions
3590 * However, we do let them to collide inelastically to produce kaons
3591 clin-8/15/02       ppel=1.e-09
3592        ppel=20.
3593         ipp=1
3594        if(lb1.lt.3.or.lb1.gt.5.or.lb2.lt.3.or.lb2.gt.5)go to 778
3595        CALL PPXS(LB1,LB2,SRT,PPSIG,spprho,IPP)
3596        ppel=ppsig
3597 778       ppink=pipik(srt)
3598
3599 * pi+eta and eta+eta are assumed to be the same as pipik( for pi+pi -> K+K-)
3600 * estimated from Ko's paper:
3601         ppink = 2.0 * ppink
3602        if(lb1.ge.25.and.lb2.ge.25) ppink=rrkk
3603
3604 clin-2/13/03 include omega the same as rho, eta the same as pi:
3605 c        if(((lb1.ge.3.and.lb1.le.5).and.(lb2.ge.25.and.lb2.le.27))
3606 c     1  .or.((lb2.ge.3.and.lb2.le.5).and.(lb1.ge.25.and.lb1.le.27)))
3607         if( ( (lb1.eq.0.or.(lb1.ge.3.and.lb1.le.5))
3608      1       .and.(lb2.ge.25.and.lb2.le.28))
3609      2       .or. ( (lb2.eq.0.or.(lb2.ge.3.and.lb2.le.5))
3610      3       .and.(lb1.ge.25.and.lb1.le.28))) then
3611            ppink=0.
3612            if(srt.ge.(aka+aks)) ppink = prkk
3613         endif
3614
3615 c pi pi <-> rho rho:
3616         call spprr(lb1,lb2,srt)
3617 clin-4/03/02 pi pi <-> eta eta:
3618         call sppee(lb1,lb2,srt)
3619 clin-4/03/02 pi pi <-> pi eta:
3620         call spppe(lb1,lb2,srt)
3621 clin-4/03/02 rho pi <-> rho eta:
3622         call srpre(lb1,lb2,srt)
3623 clin-4/03/02 omega pi <-> omega eta:
3624         call sopoe(lb1,lb2,srt)
3625 clin-4/03/02 rho rho <-> eta eta:
3626         call srree(lb1,lb2,srt)
3627
3628         ppinnb=0.
3629         if(srt.gt.thresh(1)) then
3630            call getnst(srt)
3631            if(lb1.ge.3.and.lb1.le.5.and.lb2.ge.3.and.lb2.le.5) then
3632               ppinnb=ppbbar(srt)
3633            elseif((lb1.ge.3.and.lb1.le.5.and.lb2.ge.25.and.lb2.le.27)
3634      1 .or.(lb2.ge.3.and.lb2.le.5.and.lb1.ge.25.and.lb1.le.27)) then
3635               ppinnb=prbbar(srt)
3636            elseif(lb1.ge.25.and.lb1.le.27
3637      1             .and.lb2.ge.25.and.lb2.le.27) then
3638               ppinnb=rrbbar(srt)
3639            elseif((lb1.ge.3.and.lb1.le.5.and.lb2.eq.28)
3640      1             .or.(lb2.ge.3.and.lb2.le.5.and.lb1.eq.28)) then
3641               ppinnb=pobbar(srt)
3642            elseif((lb1.ge.25.and.lb1.le.27.and.lb2.eq.28)
3643      1             .or.(lb2.ge.25.and.lb2.le.27.and.lb1.eq.28)) then
3644               ppinnb=robbar(srt)
3645            elseif(lb1.eq.28.and.lb2.eq.28) then
3646               ppinnb=oobbar(srt)
3647            else
3648               if(lb1.ne.0.and.lb2.ne.0)
3649      1             write(6,*) 'missed MM lb1,lb2=',lb1,lb2
3650            endif
3651         endif
3652         ppin=ppink+ppinnb+pprr+ppee+pppe+rpre+xopoe+rree
3653
3654 * check if a collision can happen
3655        if((ppel+ppin).le.0.01)go to 400
3656        DSPP=SQRT((ppel+ppin)/31.4)
3657        dsppr=dspp+0.1
3658         CALL DISTCE(I1,I2,dsppr,DSPP,DT,EC,SRT,IC,
3659      1  PX1CM,PY1CM,PZ1CM)
3660         IF(IC.EQ.-1) GO TO 400
3661        if(ppel.eq.0)go to 400
3662 * the collision can happen
3663 * check what kind collision has happened
3664        ekaon(5,iss)=ekaon(5,iss)+1
3665         CALL CRPP(PX1CM,PY1CM,PZ1CM,SRT,I1,I2,
3666      1  IBLOCK,ppel,ppin,spprho,ipp)
3667
3668 * rho formation, go to 400
3669 c       if(iblock.eq.666)go to 600
3670        if(iblock.eq.666)go to 555
3671        if(iblock.eq.6)LPP=LPP+1
3672        if(iblock.eq.66)then
3673           LPPk=LPPk+1
3674        elseif(iblock.eq.366)then
3675           LPPk=LPPk+1
3676        elseif(iblock.eq.367)then
3677           LPPk=LPPk+1
3678        endif
3679        em1=e(i1)
3680        em2=e(i2)
3681        go to 440
3682
3683 * In this block we treat annihilations of
3684 clin-9/28/00* an anti-nucleon and a baryon or baryon resonance
3685 * an anti-baryon and a baryon (including resonances)
3686 2799        CONTINUE
3687         PX1CM=PCX
3688         PY1CM=PCY
3689         PZ1CM=PCZ
3690         EC=(em1+em2+0.02)**2
3691 clin assume the same cross section (as a function of sqrt s) as for PPbar:
3692
3693 clin-ctest annih maximum
3694 c        DSppb=SQRT(amin1(xppbar(srt),30.)/PI/10.)
3695        DSppb=SQRT(xppbar(srt)/PI/10.)
3696        dsppbr=dsppb+0.1
3697         CALL DISTCE(I1,I2,dsppbr,DSppb,DT,EC,SRT,IC,
3698      1  PX1CM,PY1CM,PZ1CM)
3699         IF(IC.EQ.-1) GO TO 400
3700         CALL Crppba(PX1CM,PY1CM,PZ1CM,SRT,I1,I2,
3701      1  IBLOCK)
3702        em1=e(i1)
3703        em2=e(i2)
3704        go to 440
3705 c
3706 3555    PX1CM=PCX
3707         PY1CM=PCY
3708         PZ1CM=PCZ
3709         EC=(em1+em2+0.02)**2
3710        DSkk=SQRT(SIG/PI/10.)
3711        dskk0=dskk+0.1
3712         CALL DISTCE(I1,I2,dskk0,DSkk,DT,EC,SRT,IC,
3713      1  PX1CM,PY1CM,PZ1CM)
3714         IF(IC.EQ.-1) GO TO 400
3715         CALL Crlaba(PX1CM,PY1CM,PZ1CM,SRT,brel,brsgm,
3716      &                  I1,I2,nt,IBLOCK,nchrg,icase)
3717        em1=e(i1)
3718        em2=e(i2)
3719        go to 440
3720 *
3721 c perturbative production of cascade and omega
3722 3455    PX1CM=PCX
3723         PY1CM=PCY
3724         PZ1CM=PCZ
3725         call pertur(PX1CM,PY1CM,PZ1CM,SRT,IRUN,I1,I2,nt,kp,icontp)
3726         if(icontp .eq. 0)then
3727 c     inelastic collisions:
3728          em1 = e(i1)
3729          em2 = e(i2)
3730          iblock = 727
3731           go to 440
3732         endif
3733 c     elastic collisions:
3734         if (e(i1) .eq. 0.) go to 800
3735         if (e(i2) .eq. 0.) go to 600
3736         go to 400
3737 *
3738 c* phi + N --> pi+N(D),  N(D,N*)+N(D,N*),  K+ +La
3739 c* phi + D --> pi+N(D)
3740 7222        CONTINUE
3741         PX1CM=PCX
3742         PY1CM=PCY
3743         PZ1CM=PCZ
3744         EC=(em1+em2+0.02)**2
3745         CALL XphiB(LB1, LB2, EM1, EM2, SRT,
3746      &             XSK1, XSK2, XSK3, XSK4, XSK5, SIGP)
3747        DSkk=SQRT(SIGP/PI/10.)
3748        dskk0=dskk+0.1
3749         CALL DISTCE(I1,I2,dskk0,DSkk,DT,EC,SRT,IC,
3750      1  PX1CM,PY1CM,PZ1CM)
3751         IF(IC.EQ.-1) GO TO 400
3752         CALL CRPHIB(PX1CM,PY1CM,PZ1CM,SRT,I1,I2,
3753      &     XSK1, XSK2, XSK3, XSK4, XSK5, SIGP, IBLOCK)
3754        em1=e(i1)
3755        em2=e(i2)
3756        go to 440
3757 *
3758 c* phi + M --> K+ + K* .....
3759 7444        CONTINUE
3760         PX1CM=PCX
3761         PY1CM=PCY
3762         PZ1CM=PCZ
3763         EC=(em1+em2+0.02)**2
3764         CALL PHIMES(I1, I2, SRT, XSK1, XSK2, XSK3, XSK4, XSK5,
3765      1     XSK6, XSK7, SIGPHI)
3766        DSkk=SQRT(SIGPHI/PI/10.)
3767        dskk0=dskk+0.1
3768         CALL DISTCE(I1,I2,dskk0,DSkk,DT,EC,SRT,IC,
3769      1  PX1CM,PY1CM,PZ1CM)
3770         IF(IC.EQ.-1) GO TO 400
3771 c*---
3772         PZRT = p(3,i1)+p(3,i2)
3773         ER1 = sqrt( p(1,i1)**2+p(2,i1)**2+p(3,i1)**2+E(i1)**2 )
3774         ER2 = sqrt( p(1,i2)**2+p(2,i2)**2+p(3,i2)**2+E(i2)**2 )
3775         ERT = ER1+ER2
3776         yy = 0.5*log( (ERT+PZRT)/(ERT-PZRT) )
3777 c*------
3778         CALL CRPHIM(PX1CM,PY1CM,PZ1CM,SRT,I1,I2,
3779      &  XSK1, XSK2, XSK3, XSK4, XSK5, XSK6, SIGPHI, IKKG, IKKL, IBLOCK)
3780        em1=e(i1)
3781        em2=e(i2)
3782        go to 440
3783 c
3784 c lambda-N elastic xsection, Li & Ko, PRC 54(1996)1897.
3785  7799    CONTINUE
3786          PX1CM=PCX
3787          PY1CM=PCY
3788          PZ1CM=PCZ
3789          EC=(em1+em2+0.02)**2
3790          call lambar(i1,i2,srt,siglab)
3791         DShn=SQRT(siglab/PI/10.)
3792         dshnr=dshn+0.1
3793          CALL DISTCE(I1,I2,dshnr,DShn,DT,EC,SRT,IC,
3794      1    PX1CM,PY1CM,PZ1CM)
3795         IF(IC.EQ.-1) GO TO 400
3796          CALL Crhb(PX1CM,PY1CM,PZ1CM,SRT,I1,I2,IBLOCK)
3797         em1=e(i1)
3798         em2=e(i2)
3799         go to 440
3800 c
3801 c* K+ + La(Si) --> Meson + B
3802 c* K- + La(Si)-bar --> Meson + B-bar
3803 5699        CONTINUE
3804         PX1CM=PCX
3805         PY1CM=PCY
3806         PZ1CM=PCZ
3807         EC=(em1+em2+0.02)**2
3808         CALL XKHYPE(I1, I2, SRT, XKY1, XKY2, XKY3, XKY4, XKY5,
3809      &     XKY6, XKY7, XKY8, XKY9, XKY10, XKY11, XKY12, XKY13,
3810      &     XKY14, XKY15, XKY16, XKY17, SIGK)
3811        DSkk=SQRT(sigk/PI)
3812        dskk0=dskk+0.1
3813         CALL DISTCE(I1,I2,dskk0,DSkk,DT,EC,SRT,IC,
3814      1  PX1CM,PY1CM,PZ1CM)
3815         IF(IC.EQ.-1) GO TO 400
3816 c
3817        if(lb(i1).eq.23 .or. lb(i2).eq.23)then
3818              IKMP = 1
3819         else
3820              IKMP = -1
3821         endif
3822         CALL Crkhyp(PX1CM,PY1CM,PZ1CM,SRT,I1,I2,
3823      &     XKY1, XKY2, XKY3, XKY4, XKY5,
3824      &     XKY6, XKY7, XKY8, XKY9, XKY10, XKY11, XKY12, XKY13,
3825      &     XKY14, XKY15, XKY16, XKY17, SIGK, IKMP,
3826      1  IBLOCK)
3827        em1=e(i1)
3828        em2=e(i2)
3829        go to 440
3830 c khyperon end
3831 *
3832 csp11/03/01 La/Si-bar + N --> pi + K+
3833 c  La/Si + N-bar --> pi + K-
3834 5999     CONTINUE
3835         PX1CM=PCX
3836         PY1CM=PCY
3837         PZ1CM=PCZ
3838         EC=(em1+em2+0.02)**2
3839         sigkp = 15.
3840 c      if((lb1.ge.14.and.lb1.le.17)
3841 c     &    .or.(lb2.ge.14.and.lb2.le.17))sigkp=10.
3842         DSkk=SQRT(SIGKP/PI/10.)
3843         dskk0=dskk+0.1
3844         CALL DISTCE(I1,I2,dskk0,DSkk,DT,EC,SRT,IC,
3845      1  PX1CM,PY1CM,PZ1CM)
3846         IF(IC.EQ.-1) GO TO 400
3847 c
3848         CALL CRLAN(PX1CM,PY1CM,PZ1CM,SRT,I1,I2,IBLOCK)
3849         em1=e(i1)
3850         em2=e(i2)
3851         go to 440
3852 c
3853 c*
3854 * K(K*) + K(K*) --> phi + pi(rho,omega)
3855 8699     CONTINUE
3856         PX1CM=PCX
3857         PY1CM=PCY
3858         PZ1CM=PCZ
3859         EC=(em1+em2+0.02)**2
3860 *  CALL CROSSKKPHI(PX1CM,PY1CM,PZ1CM,SRT,I1,I2,IBLOCK)  used for KK*->phi+rho
3861
3862          CALL Crkphi(PX1CM,PY1CM,PZ1CM,EC,SRT,IBLOCK,
3863      &                  emm1,emm2,lbp1,lbp2,I1,I2,ikk,icase,rrkk,prkk)
3864          if(icase .eq. 0) then
3865             iblock=0
3866             go to 400
3867          endif
3868
3869 c*---
3870          if(lbp1.eq.29.or.lbp2.eq.29) then
3871         PZRT = p(3,i1)+p(3,i2)
3872         ER1 = sqrt( p(1,i1)**2+p(2,i1)**2+p(3,i1)**2+E(i1)**2 )
3873         ER2 = sqrt( p(1,i2)**2+p(2,i2)**2+p(3,i2)**2+E(i2)**2 )
3874         ERT = ER1+ER2
3875         yy = 0.5*log( (ERT+PZRT)/(ERT-PZRT) )
3876 c*------
3877              iblock = 222
3878              ntag = 0
3879           endif
3880
3881              LB(I1) = lbp1
3882              LB(I2) = lbp2
3883              E(I1) = emm1
3884              E(I2) = emm2
3885              em1=e(i1)
3886              em2=e(i2)
3887              go to 440
3888 c*
3889 * rho(omega) + K(K*)  --> phi + K(K*)
3890 8799     CONTINUE
3891         PX1CM=PCX
3892         PY1CM=PCY
3893         PZ1CM=PCZ
3894         EC=(em1+em2+0.02)**2
3895 *  CALL CROSSKKPHI(PX1CM,PY1CM,PZ1CM,SRT,I1,I2,IBLOCK)  used for KK*->phi+rho
3896          CALL Crksph(PX1CM,PY1CM,PZ1CM,EC,SRT,
3897      &       emm1,emm2,lbp1,lbp2,I1,I2,ikkg,ikkl,iblock,icase,srhoks)
3898          if(icase .eq. 0) then
3899             iblock=0
3900             go to 400
3901          endif
3902 c
3903          if(lbp1.eq.29.or.lbp2.eq.20) then
3904 c*---
3905         PZRT = p(3,i1)+p(3,i2)
3906         ER1 = sqrt( p(1,i1)**2+p(2,i1)**2+p(3,i1)**2+E(i1)**2 )
3907         ER2 = sqrt( p(1,i2)**2+p(2,i2)**2+p(3,i2)**2+E(i2)**2 )
3908         ERT = ER1+ER2
3909         yy = 0.5*log( (ERT+PZRT)/(ERT-PZRT) )
3910           endif
3911
3912              LB(I1) = lbp1
3913              LB(I2) = lbp2
3914              E(I1) = emm1
3915              E(I2) = emm2
3916              em1=e(i1)
3917              em2=e(i2)
3918              go to 440
3919
3920 * for kaon+baryon scattering, using a constant xsection of 10 mb.
3921 888       CONTINUE
3922         PX1CM=PCX
3923         PY1CM=PCY
3924         PZ1CM=PCZ
3925         EC=(em1+em2+0.02)**2
3926          sig = 10.
3927          if(iabs(lb1).eq.14.or.iabs(lb2).eq.14 .or.
3928      &      iabs(lb1).eq.30.or.iabs(lb2).eq.30)sig=20.
3929          if(lb1.eq.29.or.lb2.eq.29)sig=5.0
3930
3931        DSkn=SQRT(sig/PI/10.)
3932        dsknr=dskn+0.1
3933         CALL DISTCE(I1,I2,dsknr,DSkn,DT,EC,SRT,IC,
3934      1  PX1CM,PY1CM,PZ1CM)
3935         IF(IC.EQ.-1) GO TO 400
3936         CALL Crkn(PX1CM,PY1CM,PZ1CM,SRT,I1,I2,
3937      1  IBLOCK)
3938        em1=e(i1)
3939        em2=e(i2)
3940        go to 440
3941 ***
3942
3943  440    CONTINUE
3944 *                IBLOCK = 0 ; NOTHING HAS HAPPENED
3945 *                IBLOCK = 1 ; ELASTIC N-N COLLISION
3946 *                IBLOCK = 2 ; N + N -> N + DELTA
3947 *                IBLOCK = 3 ; N + DELTA -> N + N
3948 *                IBLOCK = 4 ; N + N -> d + d + PION,DIRECT PROCESS
3949 *               IBLOCK = 5 ; D(N*)+D(N*) COLLISIONS
3950 *                IBLOCK = 6 ; PION+PION COLLISIONS
3951 *                iblock = 7 ; pion+nucleon-->l/s+kaon
3952 *               iblock =77;  pion+nucleon-->delta+pion
3953 *               iblock = 8 ; kaon+baryon rescattering
3954 *                IBLOCK = 9 ; NN-->KAON+X
3955 *                IBLOCK = 10; DD-->KAON+X
3956 *               IBLOCK = 11; ND-->KAON+X
3957 cbali2/1/99
3958 *
3959 *           iblock   - 1902 annihilation-->pion(+)+pion(-)   (2 pion)
3960 *           iblock   - 1903 annihilation-->pion(+)+rho(-)    (3 pion)
3961 *           iblock   - 1904 annihilation-->rho(+)+rho(-)     (4 pion)
3962 *           iblock   - 1905 annihilation-->rho(0)+omega      (5 pion)
3963 *           iblock   - 1906 annihilation-->omega+omega       (6 pion)
3964 cbali3/5/99
3965 *           iblock   - 1907 K+K- to pi+pi-
3966 cbali3/5/99 end
3967 cbz3/9/99 khyperon
3968 *           iblock   - 1908 K+Y -> piN
3969 cbz3/9/99 khyperon end
3970 cbali2/1/99end
3971
3972 clin-9/28/00 Processes: m(pi rho omega)+m(pi rho omega)
3973 c     to anti-(p n D N*1 N*2)+(p n D N*1 N*2):
3974 *           iblock   - 1801  mm -->pbar p
3975 *           iblock   - 18021 mm -->pbar n
3976 *           iblock   - 18022 mm -->nbar p
3977 *           iblock   - 1803  mm -->nbar n
3978 *           iblock   - 18041 mm -->pbar Delta
3979 *           iblock   - 18042 mm -->anti-Delta p
3980 *           iblock   - 18051 mm -->nbar Delta
3981 *           iblock   - 18052 mm -->anti-Delta n
3982 *           iblock   - 18061 mm -->pbar N*(1400)
3983 *           iblock   - 18062 mm -->anti-N*(1400) p
3984 *           iblock   - 18071 mm -->nbar N*(1400)
3985 *           iblock   - 18072 mm -->anti-N*(1400) n
3986 *           iblock   - 1808  mm -->anti-Delta Delta
3987 *           iblock   - 18091 mm -->pbar N*(1535)
3988 *           iblock   - 18092 mm -->anti-N*(1535) p
3989 *           iblock   - 18101 mm -->nbar N*(1535)
3990 *           iblock   - 18102 mm -->anti-N*(1535) n
3991 *           iblock   - 18111 mm -->anti-Delta N*(1440)
3992 *           iblock   - 18112 mm -->anti-N*(1440) Delta
3993 *           iblock   - 18121 mm -->anti-Delta N*(1535)
3994 *           iblock   - 18122 mm -->anti-N*(1535) Delta
3995 *           iblock   - 1813  mm -->anti-N*(1440) N*(1440)
3996 *           iblock   - 18141 mm -->anti-N*(1440) N*(1535)
3997 *           iblock   - 18142 mm -->anti-N*(1535) N*(1440)
3998 *           iblock   - 1815  mm -->anti-N*(1535) N*(1535)
3999 clin-9/28/00-end
4000
4001 clin-10/08/00 Processes: pi pi <-> rho rho
4002 *           iblock   - 1850  pi pi -> rho rho
4003 *           iblock   - 1851  rho rho -> pi pi
4004 clin-10/08/00-end
4005
4006 clin-08/14/02 Processes: pi pi <-> eta eta
4007 *           iblock   - 1860  pi pi -> eta eta
4008 *           iblock   - 1861  eta eta -> pi pi
4009 * Processes: pi pi <-> pi eta
4010 *           iblock   - 1870  pi pi -> pi eta
4011 *           iblock   - 1871  pi eta -> pi pi
4012 * Processes: rho pi <-> rho eta
4013 *           iblock   - 1880  pi pi -> pi eta
4014 *           iblock   - 1881  pi eta -> pi pi
4015 * Processes: omega pi <-> omega eta
4016 *           iblock   - 1890  pi pi -> pi eta
4017 *           iblock   - 1891  pi eta -> pi pi
4018 * Processes: rho rho <-> eta eta
4019 *           iblock   - 1895  rho rho -> eta eta
4020 *           iblock   - 1896  eta eta -> rho rho
4021 clin-08/14/02-end
4022
4023 clin-11/07/00 Processes:
4024 *           iblock   - 366  pi rho -> K* Kbar or K*bar K
4025 *           iblock   - 466  pi rho <- K* Kbar or K*bar K
4026
4027 clin-9/2008 Deuteron:
4028 *           iblock   - 501  B+B -> Deuteron+Meson
4029 *           iblock   - 502  Deuteron+Meson -> B+B
4030 *           iblock   - 503  Deuteron+Baryon elastic
4031 *           iblock   - 504  Deuteron+Meson elastic
4032 c
4033                  IF(IBLOCK.EQ.0)        GOTO 400
4034 *COM: FOR DIRECT PROCESS WE HAVE TREATED THE PAULI BLOCKING AND FIND
4035 *     THE MOMENTUM OF PARTICLES IN THE ''LAB'' FRAME. SO GO TO 400
4036 * A COLLISION HAS TAKEN PLACE !!
4037               LCOLL = LCOLL +1
4038 * WAS COLLISION PAULI-FORBIDEN? IF YES, NTAG = -1
4039               NTAG = 0
4040 *
4041 *             LORENTZ-TRANSFORMATION INTO CMS FRAME
4042               E1CM    = SQRT (EM1**2 + PX1CM**2 + PY1CM**2 + PZ1CM**2)
4043               P1BETA  = PX1CM*BETAX + PY1CM*BETAY + PZ1CM*BETAZ
4044               TRANSF  = GAMMA * ( GAMMA * P1BETA / (GAMMA + 1) + E1CM )
4045               Pt1I1 = BETAX * TRANSF + PX1CM
4046               Pt2I1 = BETAY * TRANSF + PY1CM
4047               Pt3I1 = BETAZ * TRANSF + PZ1CM
4048 * negelect the pauli blocking at high energies
4049               go to 90002
4050
4051 clin-10/25/02-comment out following, since there is no path to it:
4052 c*CHECK IF PARTICLE #1 IS PAULI BLOCKED
4053 c              CALL PAULat(I1,occup)
4054 c              if (RANART(NSEED) .lt. occup) then
4055 c                ntag = -1
4056 c              else
4057 c                ntag = 0
4058 c              end if
4059 clin-10/25/02-end
4060
4061 90002              continue
4062 *IF PARTICLE #1 IS NOT PAULI BLOCKED
4063 c              IF (NTAG .NE. -1) THEN
4064                 E2CM    = SQRT (EM2**2 + PX1CM**2 + PY1CM**2 + PZ1CM**2)
4065                 TRANSF  = GAMMA * (-GAMMA*P1BETA / (GAMMA + 1.) + E2CM)
4066                 Pt1I2 = BETAX * TRANSF - PX1CM
4067                 Pt2I2 = BETAY * TRANSF - PY1CM
4068                 Pt3I2 = BETAZ * TRANSF - PZ1CM
4069               go to 90003
4070
4071 clin-10/25/02-comment out following, since there is no path to it:
4072 c*CHECK IF PARTICLE #2 IS PAULI BLOCKED
4073 c                CALL PAULat(I2,occup)
4074 c                if (RANART(NSEED) .lt. occup) then
4075 c                  ntag = -1
4076 c                else
4077 c                  ntag = 0
4078 c                end if
4079 cc              END IF
4080 c* IF COLLISION IS BLOCKED,RESTORE THE MOMENTUM,MASSES
4081 c* AND LABELS OF I1 AND I2
4082 cc             IF (NTAG .EQ. -1) THEN
4083 c                LBLOC  = LBLOC + 1
4084 c                P(1,I1) = PX1
4085 c                P(2,I1) = PY1
4086 c                P(3,I1) = PZ1
4087 c                P(1,I2) = PX2
4088 c                P(2,I2) = PY2
4089 c                P(3,I2) = PZ2
4090 c                E(I1)   = EM1
4091 c                E(I2)   = EM2
4092 c                LB(I1)  = LB1
4093 c                LB(I2)  = LB2
4094 cc              ELSE
4095 clin-10/25/02-end
4096
4097 90003           IF(IBLOCK.EQ.1) LCNNE=LCNNE+1
4098               IF(IBLOCK.EQ.5) LDD=LDD+1
4099                 if(iblock.eq.2) LCNND=LCNND+1
4100               IF(IBLOCK.EQ.8) LKN=LKN+1
4101                    if(iblock.eq.43) Ldou=Ldou+1
4102 c                IF(IBLOCK.EQ.2) THEN
4103 * CALCULATE THE AVERAGE SRT FOR N + N---> N + DELTA PROCESS
4104 C                NODELT=NODELT+1
4105 C                SUMSRT=SUMSRT+SRT
4106 c                ENDIF
4107                 IF(IBLOCK.EQ.3) LCNDN=LCNDN+1
4108 * assign final momenta to particles while keep the leadng particle
4109 * behaviour
4110 C              if((pt1i1*px1+pt2i1*py1+pt3i1*pz1).gt.0)then
4111               p(1,i1)=pt1i1
4112               p(2,i1)=pt2i1
4113               p(3,i1)=pt3i1
4114               p(1,i2)=pt1i2
4115               p(2,i2)=pt2i2
4116               p(3,i2)=pt3i2
4117 C              else
4118 C              p(1,i1)=pt1i2
4119 C              p(2,i1)=pt2i2
4120 C              p(3,i1)=pt3i2
4121 C              p(1,i2)=pt1i1
4122 C              p(2,i2)=pt2i1
4123 C              p(3,i2)=pt3i1
4124 C              endif
4125                 PX1     = P(1,I1)
4126                 PY1     = P(2,I1)
4127                 PZ1     = P(3,I1)
4128                 EM1     = E(I1)
4129                 EM2     = E(I2)
4130                 LB1     = LB(I1)
4131                 LB2     = LB(I2)
4132                 ID(I1)  = 2
4133                 ID(I2)  = 2
4134                 E1      = SQRT( EM1**2 + PX1**2 + PY1**2 + PZ1**2 )
4135                 ID1     = ID(I1)
4136               go to 90004
4137 clin-10/25/02-comment out following, since there is no path to it:
4138 c* change phase space density FOR NUCLEONS INVOLVED :
4139 c* NOTE THAT f is the phase space distribution function for nucleons only
4140 c                if ((abs(ix1).le.mx) .and. (abs(iy1).le.my) .and.
4141 c     &              (abs(iz1).le.mz)) then
4142 c                  ipx1p = nint(p(1,i1)/dpx)
4143 c                  ipy1p = nint(p(2,i1)/dpy)
4144 c                  ipz1p = nint(p(3,i1)/dpz)
4145 c                  if ((ipx1p.ne.ipx1) .or. (ipy1p.ne.ipy1) .or.
4146 c     &                (ipz1p.ne.ipz1)) then
4147 c                    if ((abs(ipx1).le.mpx) .and. (abs(ipy1).le.my)
4148 c     &                .and. (ipz1.ge.-mpz) .and. (ipz1.le.mpzp)
4149 c     &                .AND. (AM1.LT.1.))
4150 c     &                f(ix1,iy1,iz1,ipx1,ipy1,ipz1) =
4151 c     &                f(ix1,iy1,iz1,ipx1,ipy1,ipz1) - 1.
4152 c                    if ((abs(ipx1p).le.mpx) .and. (abs(ipy1p).le.my)
4153 c     &                .and. (ipz1p.ge.-mpz).and. (ipz1p.le.mpzp)
4154 c     &                .AND. (EM1.LT.1.))
4155 c     &                f(ix1,iy1,iz1,ipx1p,ipy1p,ipz1p) =
4156 c     &                f(ix1,iy1,iz1,ipx1p,ipy1p,ipz1p) + 1.
4157 c                  end if
4158 c                end if
4159 c                if ((abs(ix2).le.mx) .and. (abs(iy2).le.my) .and.
4160 c     &              (abs(iz2).le.mz)) then
4161 c                  ipx2p = nint(p(1,i2)/dpx)
4162 c                  ipy2p = nint(p(2,i2)/dpy)
4163 c                  ipz2p = nint(p(3,i2)/dpz)
4164 c                  if ((ipx2p.ne.ipx2) .or. (ipy2p.ne.ipy2) .or.
4165 c     &                (ipz2p.ne.ipz2)) then
4166 c                    if ((abs(ipx2).le.mpx) .and. (abs(ipy2).le.my)
4167 c     &                .and. (ipz2.ge.-mpz) .and. (ipz2.le.mpzp)
4168 c     &                .AND. (AM2.LT.1.))
4169 c     &                f(ix2,iy2,iz2,ipx2,ipy2,ipz2) =
4170 c     &                f(ix2,iy2,iz2,ipx2,ipy2,ipz2) - 1.
4171 c                    if ((abs(ipx2p).le.mpx) .and. (abs(ipy2p).le.my)
4172 c     &                .and. (ipz2p.ge.-mpz) .and. (ipz2p.le.mpzp)
4173 c     &                .AND. (EM2.LT.1.))
4174 c     &                f(ix2,iy2,iz2,ipx2p,ipy2p,ipz2p) =
4175 c     &                f(ix2,iy2,iz2,ipx2p,ipy2p,ipz2p) + 1.
4176 c                  end if
4177 c                end if
4178 clin-10/25/02-end
4179
4180 90004              continue
4181             AM1=EM1
4182             AM2=EM2
4183 c            END IF
4184
4185
4186   400       CONTINUE
4187 c
4188 clin-6/10/03 skips the info output on resonance creations:
4189 c            goto 550
4190 cclin-4/30/03 study phi,K*,Lambda(1520) resonances at creation:
4191 cc     note that no decays give these particles, so don't need to consider nnn:
4192 c            if(iblock.ne.0.and.(lb(i1).eq.29.or.iabs(lb(i1)).eq.30
4193 c     1           .or.lb(i2).eq.29.or.iabs(lb(i2)).eq.30
4194 c     2           .or.lb1i.eq.29.or.iabs(lb1i).eq.30
4195 c     3           .or.lb2i.eq.29.or.iabs(lb2i).eq.30)) then
4196 c               lb1now=lb(i1)
4197 c               lb2now=lb(i2)
4198 cc
4199 c               nphi0=0
4200 c               nksp0=0
4201 c               nksm0=0
4202 cc               nlar0=0
4203 cc               nlarbar0=0
4204 c               if(lb1i.eq.29) then
4205 c                  nphi0=nphi0+1
4206 c               elseif(lb1i.eq.30) then
4207 c                  nksp0=nksp0+1
4208 c               elseif(lb1i.eq.-30) then
4209 c                  nksm0=nksm0+1
4210 c               endif
4211 c               if(lb2i.eq.29) then
4212 c                  nphi0=nphi0+1
4213 c               elseif(lb2i.eq.30) then
4214 c                  nksp0=nksp0+1
4215 c               elseif(lb2i.eq.-30) then
4216 c                  nksm0=nksm0+1
4217 c               endif
4218 cc
4219 c               nphi=0
4220 c               nksp=0
4221 c               nksm=0
4222 c               nlar=0
4223 c               nlarbar=0
4224 c               if(lb1now.eq.29) then
4225 c                  nphi=nphi+1
4226 c               elseif(lb1now.eq.30) then
4227 c                  nksp=nksp+1
4228 c               elseif(lb1now.eq.-30) then
4229 c                  nksm=nksm+1
4230 c               endif
4231 c               if(lb2now.eq.29) then
4232 c                  nphi=nphi+1
4233 c               elseif(lb2now.eq.30) then
4234 c                  nksp=nksp+1
4235 c               elseif(lb2now.eq.-30) then
4236 c                  nksm=nksm+1
4237 c               endif
4238 cc
4239 c               if(nphi.eq.2.or.nksp.eq.2.or.nksm.eq.2) then
4240 c                  write(91,*) '2 same resonances in one reaction!'
4241 c                  write(91,*) nphi,nksp,nksm,iblock
4242 c               endif
4243 c
4244 cc     All reactions create or destroy no more than 1 these resonance,
4245 cc     otherwise file "fort.91" warns us:
4246 c               do 222 ires=1,3
4247 c                  if(ires.eq.1.and.nphi.ne.nphi0) then
4248 c                     idr=29
4249 c                  elseif(ires.eq.2.and.nksp.ne.nksp0) then
4250 c                     idr=30
4251 c                  elseif(ires.eq.3.and.nksm.ne.nksm0) then
4252 c                     idr=-30
4253 c                  else
4254 c                     goto 222
4255 c                  endif
4256 cctest off for resonance (phi, K*) studies:
4257 cc               if(lb1now.eq.idr) then
4258 cc       write(17,112) 'collision',lb1now,P(1,I1),P(2,I1),P(3,I1),e(I1),nt
4259 cc               elseif(lb2now.eq.idr) then
4260 cc       write(17,112) 'collision',lb2now,P(1,I2),P(2,I2),P(3,I2),e(I2),nt
4261 cc               elseif(lb1i.eq.idr) then
4262 cc       write(18,112) 'collision',lb1i,px1i,py1i,pz1i,em1i,nt
4263 cc               elseif(lb2i.eq.idr) then
4264 cc       write(18,112) 'collision',lb2i,px2i,py2i,pz2i,em2i,nt
4265 cc               endif
4266 c 222           continue
4267 c
4268 c            else
4269 c            endif
4270 cc 112        format(a10,I4,4(1x,f9.3),1x,I4)
4271 c
4272 clin-2/26/03 skips the check of energy conservation after each binary search:
4273 c 550        goto 555
4274 c            pxfin=0
4275 c            pyfin=0
4276 c            pzfin=0
4277 c            efin=0
4278 c            if(e(i1).ne.0.or.lb(i1).eq.10022) then
4279 c               efin=efin+SQRT(E(I1)**2+P(1,I1)**2+P(2,I1)**2+P(3,I1)**2)
4280 c               pxfin=pxfin+P(1,I1)
4281 c               pyfin=pyfin+P(2,I1)
4282 c               pzfin=pzfin+P(3,I1)
4283 c            endif
4284 c            if(e(i2).ne.0.or.lb(i2).eq.10022) then
4285 c               efin=efin+SQRT(E(I2)**2+P(1,I2)**2+P(2,I2)**2+P(3,I2)**2)
4286 c               pxfin=pxfin+P(1,I2)
4287 c               pyfin=pyfin+P(2,I2)
4288 c               pzfin=pzfin+P(3,I2)
4289 c            endif
4290 c            if((nnn-nnnini).ge.1) then
4291 c               do imore=nnnini+1,nnn
4292 c                  if(EPION(imore,IRUN).ne.0) then
4293 c                     efin=efin+SQRT(EPION(imore,IRUN)**2
4294 c     1                    +PPION(1,imore,IRUN)**2+PPION(2,imore,IRUN)**2
4295 c     2                    +PPION(3,imore,IRUN)**2)
4296 c                     pxfin=pxfin+PPION(1,imore,IRUN)
4297 c                     pyfin=pyfin+PPION(2,imore,IRUN)
4298 c                     pzfin=pzfin+PPION(3,imore,IRUN)
4299 c                  endif
4300 c               enddo
4301 c            endif
4302 c            devio=sqrt((pxfin-pxini)**2+(pyfin-pyini)**2
4303 c     1           +(pzfin-pzini)**2+(efin-eini)**2)
4304 cc
4305 c            if(devio.ge.0.1) then
4306 c               write(92,'a20,5(1x,i6),2(1x,f8.3)') 'iblock,lb,npi=',
4307 c     1              iblock,lb1i,lb2i,lb(i1),lb(i2),e(i1),e(i2)
4308 c               do imore=nnnini+1,nnn
4309 c                  if(EPION(imore,IRUN).ne.0) then
4310 c                     write(92,'a10,2(1x,i6)') 'ipi,lbm=',
4311 c     1                    imore,LPION(imore,IRUN)
4312 c                  endif
4313 c               enddo
4314 c               write(92,'a3,4(1x,f8.3)') 'I:',eini,pxini,pyini,pzini
4315 c               write(92,'a3,5(1x,f8.3)')
4316 c     1              'F:',efin,pxfin,pyfin,pzfin,devio
4317 c            endif
4318 c
4319  555        continue
4320 ctest off only one collision for the same 2 particles in the same timestep:
4321 c            if(iblock.ne.0) then
4322 c               goto 800
4323 c            endif
4324 ctest off collisions history:
4325 c            if(iblock.ne.0) then
4326 c               write(10,*) nt,i1,i2,iblock,x1,z1,x2,z2
4327 c            endif
4328
4329   600     CONTINUE
4330   800   CONTINUE
4331 * RELABLE MESONS LEFT IN THIS RUN EXCLUDING THOSE BEING CREATED DURING
4332 * THIS TIME STEP AND COUNT THE TOTAL NO. OF PARTICLES IN THIS RUN
4333 * note that the first mass=mta+mpr particles are baryons
4334 c        write(*,*)'I: NNN,massr ', nnn,massr(irun)
4335         N0=MASS+MSUM
4336         DO 1005 N=N0+1,MASSR(IRUN)+MSUM
4337 cbz11/25/98
4338 clin-2/19/03 lb>5000: keep particles with no LB codes in ART(photon,lepton,..):
4339 c        IF(E(N).GT.0.)THEN
4340         IF(E(N) .GT. 0. .OR. LB(N) .GT. 5000)THEN
4341 cbz11/25/98end
4342         NNN=NNN+1
4343         RPION(1,NNN,IRUN)=R(1,N)
4344         RPION(2,NNN,IRUN)=R(2,N)
4345         RPION(3,NNN,IRUN)=R(3,N)
4346 clin-10/28/03:
4347         if(nt.eq.ntmax) then
4348            ftpisv(NNN,IRUN)=ftsv(N)
4349            tfdpi(NNN,IRUN)=tfdcy(N)
4350         endif
4351 c
4352         PPION(1,NNN,IRUN)=P(1,N)
4353         PPION(2,NNN,IRUN)=P(2,N)
4354         PPION(3,NNN,IRUN)=P(3,N)
4355         EPION(NNN,IRUN)=E(N)
4356         LPION(NNN,IRUN)=LB(N)
4357 c       !! sp 12/19/00
4358         PROPI(NNN,IRUN)=PROPER(N)
4359 clin-5/2008:
4360         dppion(NNN,IRUN)=dpertp(N)
4361 c        if(lb(n) .eq. 45)
4362 c    &   write(*,*)'IN-1  NT,NNN,LB,P ',nt,NNN,lb(n),proper(n)
4363         ENDIF
4364  1005 CONTINUE
4365         MASSRN(IRUN)=NNN+MASS
4366 c        write(*,*)'F: NNN,massrn ', nnn,massrn(irun)
4367 1000   CONTINUE
4368 * CALCULATE THE AVERAGE SRT FOR N + N--->N +DELTA PROCESSES
4369 C        IF(NODELT.NE.0)THEN
4370 C        AVSRT=SUMSRT/FLOAT(NODELT)
4371 C        ELSE
4372 C        AVSRT=0.
4373 C        ENDIF
4374 C        WRITE(1097,'(F8.2,2X,E10.3)')FLOAT(NT)*DT,AVSRT
4375 * RELABLE ALL THE PARTICLES EXISTING AFTER THIS TIME STEP
4376         IA=0
4377         IB=0
4378         DO 10001 IRUN=1,NUM
4379         IA=IA+MASSR(IRUN-1)
4380         IB=IB+MASSRN(IRUN-1)
4381         DO 10001 IC=1,MASSRN(IRUN)
4382         IE=IA+IC
4383         IG=IB+IC
4384         IF(IC.LE.MASS)THEN
4385         RT(1,IG)=R(1,IE)
4386         RT(2,IG)=R(2,IE)
4387         RT(3,IG)=R(3,IE)
4388 clin-10/28/03:
4389         if(nt.eq.ntmax) then
4390            fttemp(IG)=ftsv(IE)
4391            tft(IG)=tfdcy(IE)
4392         endif
4393 c
4394         PT(1,IG)=P(1,IE)
4395         PT(2,IG)=P(2,IE)
4396         PT(3,IG)=P(3,IE)
4397         ET(IG)=E(IE)
4398         LT(IG)=LB(IE)
4399         PROT(IG)=PROPER(IE)
4400 clin-5/2008:
4401         dptemp(IG)=dpertp(IE)
4402         ELSE
4403         I0=IC-MASS
4404         RT(1,IG)=RPION(1,I0,IRUN)
4405         RT(2,IG)=RPION(2,I0,IRUN)
4406         RT(3,IG)=RPION(3,I0,IRUN)
4407 clin-10/28/03:
4408         if(nt.eq.ntmax) then
4409            fttemp(IG)=ftpisv(I0,IRUN)
4410            tft(IG)=tfdpi(I0,IRUN)
4411         endif
4412 c
4413         PT(1,IG)=PPION(1,I0,IRUN)
4414         PT(2,IG)=PPION(2,I0,IRUN)
4415         PT(3,IG)=PPION(3,I0,IRUN)
4416         ET(IG)=EPION(I0,IRUN)
4417         LT(IG)=LPION(I0,IRUN)
4418         PROT(IG)=PROPI(I0,IRUN)
4419 clin-5/2008:
4420         dptemp(IG)=dppion(I0,IRUN)
4421         ENDIF
4422 10001   CONTINUE
4423 c
4424         IL=0
4425 clin-10/26/01-hbt:
4426 c        DO 10002 IRUN=1,NUM
4427         DO 10003 IRUN=1,NUM
4428
4429         MASSR(IRUN)=MASSRN(IRUN)
4430         IL=IL+MASSR(IRUN-1)
4431         DO 10002 IM=1,MASSR(IRUN)
4432         IN=IL+IM
4433         R(1,IN)=RT(1,IN)
4434         R(2,IN)=RT(2,IN)
4435         R(3,IN)=RT(3,IN)
4436 clin-10/28/03:
4437         if(nt.eq.ntmax) then
4438            ftsv(IN)=fttemp(IN)
4439            tfdcy(IN)=tft(IN)
4440         endif
4441         P(1,IN)=PT(1,IN)
4442         P(2,IN)=PT(2,IN)
4443         P(3,IN)=PT(3,IN)
4444         E(IN)=ET(IN)
4445         LB(IN)=LT(IN)
4446         PROPER(IN)=PROT(IN)
4447 clin-5/2008:
4448         dpertp(IN)=dptemp(IN)
4449        IF(LB(IN).LT.1.OR.LB(IN).GT.2)ID(IN)=0
4450 10002   CONTINUE
4451 clin-ctest off check energy conservation after each timestep
4452 c         enetot=0.
4453 c         do ip=1,MASSR(IRUN)
4454 c            if(e(ip).ne.0.or.lb(ip).eq.10022) enetot=enetot
4455 c     1           +sqrt(p(1,ip)**2+p(2,ip)**2+p(3,ip)**2+e(ip)**2)
4456 c         enddo
4457 c         write(91,*) 'B:',nt,enetot,massr(irun),bimp
4458 clin-3/2009 move to the end of a timestep to take care of freezeout spacetime:
4459 c        call hbtout(MASSR(IRUN),nt,ntmax)
4460 10003 CONTINUE
4461 c
4462       RETURN
4463       END
4464 ****************************************
4465             SUBROUTINE CMS(I1,I2,PX1CM,PY1CM,PZ1CM,SRT)
4466 * PURPOSE : FIND THE MOMENTA OF PARTICLES IN THE CMS OF THE
4467 *          TWO COLLIDING PARTICLES
4468 * VARIABLES :
4469 *****************************************
4470             PARAMETER (MAXSTR=150001)
4471             COMMON   /AA/  R(3,MAXSTR)
4472 cc      SAVE /AA/
4473             COMMON   /BB/  P(3,MAXSTR)
4474 cc      SAVE /BB/
4475             COMMON   /CC/  E(MAXSTR)
4476 cc      SAVE /CC/
4477             COMMON   /BG/  BETAX,BETAY,BETAZ,GAMMA
4478 cc      SAVE /BG/
4479       SAVE
4480             PX1=P(1,I1)
4481             PY1=P(2,I1)
4482             PZ1=P(3,I1)
4483             PX2=P(1,I2)
4484             PY2=P(2,I2)
4485             PZ2=P(3,I2)
4486             EM1=E(I1)
4487             EM2=E(I2)
4488             E1=SQRT(EM1**2+PX1**2+PY1**2+PZ1**2)
4489             E2=SQRT(EM2**2 + PX2**2 + PY2**2 + PZ2**2 )
4490             S=(E1+E2)**2-(PX1+PX2)**2-(PY1+PY2)**2-(PZ1+PZ2)**2
4491             SRT=SQRT(S)
4492 *LORENTZ-TRANSFORMATION IN I1-I2-C.M. SYSTEM
4493               ETOTAL = E1 + E2
4494               BETAX  = (PX1+PX2) / ETOTAL
4495               BETAY  = (PY1+PY2) / ETOTAL
4496               BETAZ  = (PZ1+PZ2) / ETOTAL
4497               GAMMA  = 1.0 / SQRT(1.0-BETAX**2-BETAY**2-BETAZ**2)
4498 *TRANSFORMATION OF MOMENTA (PX1CM = - PX2CM)
4499               P1BETA = PX1*BETAX + PY1*BETAY + PZ1 * BETAZ
4500               TRANSF = GAMMA * ( GAMMA * P1BETA / (GAMMA + 1) - E1 )
4501               PX1CM  = BETAX * TRANSF + PX1
4502               PY1CM  = BETAY * TRANSF + PY1
4503               PZ1CM  = BETAZ * TRANSF + PZ1
4504               RETURN
4505               END
4506 ***************************************
4507             SUBROUTINE DISTCE(I1,I2,DELTAR,DS,DT,EC,SRT
4508      1      ,IC,PX1CM,PY1CM,PZ1CM)
4509 * PURPOSE : CHECK IF THE COLLISION BETWEEN TWO PARTICLES CAN HAPPEN
4510 *           BY CHECKING
4511 *                      (1) IF THE DISTANCE BETWEEN THEM IS SMALLER
4512 *           THAN THE MAXIMUM DISTANCE DETERMINED FROM THE CROSS SECTION.
4513 *                      (2) IF PARTICLE WILL PASS EACH OTHER WITHIN
4514 *           TWO HARD CORE RADIUS.
4515 *                      (3) IF PARTICLES WILL GET CLOSER.
4516 * VARIABLES :
4517 *           IC=1 COLLISION HAPPENED
4518 *           IC=-1 COLLISION CAN NOT HAPPEN
4519 *****************************************
4520             PARAMETER (MAXSTR=150001)
4521             COMMON   /AA/  R(3,MAXSTR)
4522 cc      SAVE /AA/
4523             COMMON   /BB/  P(3,MAXSTR)
4524 cc      SAVE /BB/
4525             COMMON   /CC/  E(MAXSTR)
4526 cc      SAVE /CC/
4527             COMMON   /BG/  BETAX,BETAY,BETAZ,GAMMA
4528             COMMON  /EE/      ID(MAXSTR),LB(MAXSTR)
4529 cc      SAVE /BG/
4530             common/leadng/lb1,px1,py1,pz1,em1,e1,xfnl,yfnl,zfnl,tfnl,
4531      1           px1n,py1n,pz1n,dp1n
4532             common /dpi/em2,lb2
4533             SAVE
4534             IC=0
4535             X1=R(1,I1)
4536             Y1=R(2,I1)
4537             Z1=R(3,I1)
4538             PX1=P(1,I1)
4539             PY1=P(2,I1)
4540             PZ1=P(3,I1)
4541             X2=R(1,I2)
4542             Y2=R(2,I2)
4543             Z2=R(3,I2)
4544             PX2=P(1,I2)
4545             PY2=P(2,I2)
4546             PZ2=P(3,I2)
4547             EM1=E(I1)
4548             EM2=E(I2)
4549             E1=SQRT(EM1**2+PX1**2+PY1**2+PZ1**2)
4550 c            IF (ABS(X1-X2) .GT. DELTAR) GO TO 400
4551 c            IF (ABS(Y1-Y2) .GT. DELTAR) GO TO 400
4552 c            IF (ABS(Z1-Z2) .GT. DELTAR) GO TO 400
4553             RSQARE = (X1-X2)**2 + (Y1-Y2)**2 + (Z1-Z2)**2
4554             IF (RSQARE .GT. DELTAR**2) GO TO 400
4555 *NOW PARTICLES ARE CLOSE ENOUGH TO EACH OTHER !
4556               E2     = SQRT ( EM2**2 + PX2**2 + PY2**2 + PZ2**2 )
4557               S      = SRT*SRT
4558             IF (S .LT. EC) GO TO 400
4559 *NOW THERE IS ENOUGH ENERGY AVAILABLE !
4560 *LORENTZ-TRANSFORMATION IN I1-I2-C.M. SYSTEM
4561 * BETAX, BETAY, BETAZ AND GAMMA HAVE BEEN GIVEN IN THE SUBROUTINE CMS
4562 *TRANSFORMATION OF MOMENTA (PX1CM = - PX2CM)
4563               P1BETA = PX1*BETAX + PY1*BETAY + PZ1 * BETAZ
4564               TRANSF = GAMMA * ( GAMMA * P1BETA / (GAMMA + 1) - E1 )
4565               PRCM   = SQRT (PX1CM**2 + PY1CM**2 + PZ1CM**2)
4566               IF (PRCM .LE. 0.00001) GO TO 400
4567 *TRANSFORMATION OF SPATIAL DISTANCE
4568               DRBETA = BETAX*(X1-X2) + BETAY*(Y1-Y2) + BETAZ*(Z1-Z2)
4569               TRANSF = GAMMA * GAMMA * DRBETA / (GAMMA + 1)
4570               DXCM   = BETAX * TRANSF + X1 - X2
4571               DYCM   = BETAY * TRANSF + Y1 - Y2
4572               DZCM   = BETAZ * TRANSF + Z1 - Z2
4573 *DETERMINING IF THIS IS THE POINT OF CLOSEST APPROACH
4574               DRCM   = SQRT (DXCM**2  + DYCM**2  + DZCM**2 )
4575               DZZ    = (PX1CM*DXCM + PY1CM*DYCM + PZ1CM*DZCM) / PRCM
4576               if ((drcm**2 - dzz**2) .le. 0.) then
4577                 BBB = 0.
4578               else
4579                 BBB    = SQRT (DRCM**2 - DZZ**2)
4580               end if
4581 *WILL PARTICLE PASS EACH OTHER WITHIN 2 * HARD CORE RADIUS ?
4582               IF (BBB .GT. DS) GO TO 400
4583               RELVEL = PRCM * (1.0/E1 + 1.0/E2)
4584               DDD    = RELVEL * DT * 0.5
4585 *WILL PARTICLES GET CLOSER ?
4586               IF (ABS(DDD) .LT. ABS(DZZ)) GO TO 400
4587               IC=1
4588               GO TO 500
4589 400           IC=-1
4590 500           CONTINUE
4591               RETURN
4592               END
4593 ****************************************
4594 *                                                                      *
4595 *                                                                      *
4596       SUBROUTINE CRNN(IRUN,PX,PY,PZ,SRT,I1,I2,IBLOCK,
4597      1NTAG,SIGNN,SIG,NT,ipert1)
4598 *     PURPOSE:                                                         *
4599 *             DEALING WITH NUCLEON-NUCLEON COLLISIONS                    *
4600 *     NOTE   :                                                         *
4601 *     QUANTITIES:                                                 *
4602 *           PX,PY,PZ - MOMENTUM COORDINATES OF ONE PARTICLE IN CM FRAME*
4603 *           SRT      - SQRT OF S                                       *
4604 *           NSTAR =1 INCLUDING N* RESORANCE,ELSE NOT                   *
4605 *           NDIRCT=1 INCLUDING DIRECT PION PRODUCTION PROCESS         *
4606 *           IBLOCK   - THE INFORMATION BACK                            *
4607 *                      0-> COLLISION CANNOT HAPPEN                     *
4608 *                      1-> N-N ELASTIC COLLISION                       *
4609 *                      2-> N+N->N+DELTA,OR N+N->N+N* REACTION          *
4610 *                      3-> N+DELTA->N+N OR N+N*->N+N REACTION          *
4611 *                      4-> N+N->D+D+pion reaction
4612 *                     43->N+N->D(N*)+D(N*) reaction
4613 *                     44->N+N->D+D+rho reaction
4614 *                     45->N+N->N+N+rho
4615 *                     46->N+N->N+N+omega
4616 *           N12       - IS USED TO SPECIFY BARYON-BARYON REACTION      *
4617 *                      CHANNELS. M12 IS THE REVERSAL CHANNEL OF N12    *
4618 *                      N12,                                            *
4619 *                      M12=1 FOR p+n-->delta(+)+ n                     *
4620 *                          2     p+n-->delta(0)+ p                     *
4621 *                          3     p+p-->delta(++)+n                     *
4622 *                          4     p+p-->delta(+)+p                      *
4623 *                          5     n+n-->delta(0)+n                      *
4624 *                          6     n+n-->delta(-)+p                      *
4625 *                          7     n+p-->N*(0)(1440)+p                   *
4626 *                          8     n+p-->N*(+)(1440)+n                   *
4627 *                        9     p+p-->N*(+)(1535)+p                     *
4628 *                        10    n+n-->N*(0)(1535)+n                     *
4629 *                         11    n+p-->N*(+)(1535)+n                     *
4630 *                        12    n+p-->N*(0)(1535)+p
4631 *                        13    D(++)+D(-)-->N*(+)(1440)+n
4632 *                         14    D(++)+D(-)-->N*(0)(1440)+p
4633 *                        15    D(+)+D(0)--->N*(+)(1440)+n
4634 *                        16    D(+)+D(0)--->N*(0)(1440)+p
4635 *                        17    D(++)+D(0)-->N*(+)(1535)+p
4636 *                        18    D(++)+D(-)-->N*(0)(1535)+p
4637 *                        19    D(++)+D(-)-->N*(+)(1535)+n
4638 *                        20    D(+)+D(+)-->N*(+)(1535)+p
4639 *                        21    D(+)+D(0)-->N*(+)(1535)+n
4640 *                        22    D(+)+D(0)-->N*(0)(1535)+p
4641 *                        23    D(+)+D(-)-->N*(0)(1535)+n
4642 *                        24    D(0)+D(0)-->N*(0)(1535)+n
4643 *                          25    N*(+)(14)+N*(+)(14)-->N*(+)(15)+p
4644 *                          26    N*(0)(14)+N*(0)(14)-->N*(0)(15)+n
4645 *                          27    N*(+)(14)+N*(0)(14)-->N*(+)(15)+n
4646 *                        28    N*(+)(14)+N*(0)(14)-->N*(0)(15)+p
4647 *                        29    N*(+)(14)+D+-->N*(+)(15)+p
4648 *                        30    N*(+)(14)+D0-->N*(+)(15)+n
4649 *                        31    N*(+)(14)+D(-)-->N*(0)(1535)+n
4650 *                        32    N*(0)(14)+D++--->N*(+)(15)+p
4651 *                        33    N*(0)(14)+D+--->N*(+)(15)+n
4652 *                        34    N*(0)(14)+D+--->N*(0)(15)+p
4653 *                        35    N*(0)(14)+D0-->N*(0)(15)+n
4654 *                        36    N*(+)(14)+D0--->N*(0)(15)+p
4655 *                        ++    see the note book for more listing
4656 *
4657 *
4658 *     NOTE ABOUT N*(1440) RESORANCE IN Nucleon+NUCLEON COLLISION:      *
4659 *     As it has been discussed in VerWest's paper,I= 1(initial isospin)*
4660 *     channel can all be attributed to delta resorance while I= 0      *
4661 *     channel can all be  attribured to N* resorance.Only in n+p       *
4662 *     one can have I=0 channel so is the N*(1440) resonance            *
4663 *                                                                      *
4664 *                             REFERENCES:                            *
4665 *                    J. CUGNON ET AL., NUCL. PHYS. A352, 505 (1981)    *
4666 *                    Y. KITAZOE ET AL., PHYS. LETT. 166B, 35 (1986)    *
4667 *                    B. VerWest el al., PHYS. PRV. C25 (1982)1979      *
4668 *                    Gy. Wolf  et al, Nucl Phys A517 (1990) 615;       *
4669 *                                     Nucl phys A552 (1993) 349.       *
4670 **********************************
4671         PARAMETER (MAXSTR=150001,MAXR=1,AMN=0.939457,
4672      1  AMP=0.93828,AP1=0.13496,aka=0.498,AP2=0.13957,AM0=1.232,
4673      2  PI=3.1415926,CUTOFF=1.8966,AVMASS=0.9383,APHI=1.020)
4674         parameter     (MX=4,MY=4,MZ=8,MPX=4,MPY=4,mpz=10,mpzp=10)
4675         parameter (xmd=1.8756,npdmax=10000)
4676         COMMON /AA/ R(3,MAXSTR)
4677 cc      SAVE /AA/
4678         COMMON /BB/ P(3,MAXSTR)
4679 cc      SAVE /BB/
4680         COMMON /CC/ E(MAXSTR)
4681 cc      SAVE /CC/
4682         COMMON /EE/ ID(MAXSTR),LB(MAXSTR)
4683 cc      SAVE /EE/
4684         common /ff/f(-mx:mx,-my:my,-mz:mz,-mpx:mpx,-mpy:mpy,-mpz:mpzp)
4685 cc      SAVE /ff/
4686         common /gg/ dx,dy,dz,dpx,dpy,dpz
4687 cc      SAVE /gg/
4688         COMMON /INPUT/ NSTAR,NDIRCT,DIR
4689 cc      SAVE /INPUT/
4690         COMMON /NN/NNN
4691 cc      SAVE /NN/
4692         COMMON /BG/BETAX,BETAY,BETAZ,GAMMA
4693 cc      SAVE /BG/
4694         COMMON   /RUN/NUM
4695 cc      SAVE /RUN/
4696         COMMON   /PA/RPION(3,MAXSTR,MAXR)
4697 cc      SAVE /PA/
4698         COMMON   /PB/PPION(3,MAXSTR,MAXR)
4699 cc      SAVE /PB/
4700         COMMON   /PC/EPION(MAXSTR,MAXR)
4701 cc      SAVE /PC/
4702         COMMON   /PD/LPION(MAXSTR,MAXR)
4703 cc      SAVE /PD/
4704         COMMON/TABLE/ xarray(0:1000),earray(0:1000)
4705 cc      SAVE /TABLE/
4706         common/input1/ MASSPR,MASSTA,ISEED,IAVOID,DT
4707 cc      SAVE /input1/
4708       common/leadng/lb1,px1,py1,pz1,em1,e1,xfnl,yfnl,zfnl,tfnl,
4709      1 px1n,py1n,pz1n,dp1n
4710 cc      SAVE /leadng/
4711       COMMON/RNDF77/NSEED
4712 cc      SAVE /RNDF77/
4713       common /dpi/em2,lb2
4714       COMMON /dpert/dpertt(MAXSTR,MAXR),dpertp(MAXSTR),dplast(MAXSTR),
4715      1     dpdcy(MAXSTR),dpdpi(MAXSTR,MAXR),dpt(MAXSTR, MAXR),
4716      2     dpp1(MAXSTR,MAXR),dppion(MAXSTR,MAXR)
4717       common /para8/ idpert,npertd,idxsec
4718       dimension ppd(3,npdmax),lbpd(npdmax)
4719       SAVE
4720 *-----------------------------------------------------------------------
4721       n12=0
4722       m12=0
4723       IBLOCK=0
4724       NTAG=0
4725       EM1=E(I1)
4726       EM2=E(I2)
4727       PR=SQRT( PX**2 + PY**2 + PZ**2 )
4728       C2=PZ / PR
4729       X1=RANART(NSEED)
4730       ianti=0
4731       if(lb(i1).lt.0 .and. lb(i2).lt.0) ianti=1
4732       call sbbdm(srt,sdprod,ianti,lbm,xmm,pfinal)
4733 clin-5/2008 Production of perturbative deuterons for idpert=1:
4734       if(idpert.eq.1.and.ipert1.eq.1) then
4735          IF (SRT .LT. 2.012) RETURN
4736          if((iabs(lb(i1)).eq.1.or.iabs(lb(i1)).eq.2)
4737      1        .and.(iabs(lb(i2)).eq.1.or.iabs(lb(i2)).eq.2)) then
4738             goto 108
4739          else
4740             return
4741          endif
4742       endif
4743 c
4744 *-----------------------------------------------------------------------
4745 *COM: TEST FOR ELASTIC SCATTERING (EITHER N-N OR DELTA-DELTA 0R
4746 *      N-DELTA OR N*-N* or N*-Delta)
4747 c      IF (X1 .LE. SIGNN/SIG) THEN
4748       IF (X1.LE.(SIGNN/SIG)) THEN
4749 *COM:  PARAMETRISATION IS TAKEN FROM THE CUGNON-PAPER
4750          AS  = ( 3.65 * (SRT - 1.8766) )**6
4751          A   = 6.0 * AS / (1.0 + AS)
4752          TA  = -2.0 * PR**2
4753          X   = RANART(NSEED)
4754 clin-10/24/02        T1  = DLOG( (1-X) * DEXP(dble(A)*dble(TA)) + X )  /  A
4755          T1  = sngl(DLOG(dble(1.-X)*DEXP(dble(A)*dble(TA))+dble(X)))/  A
4756          C1  = 1.0 - T1/TA
4757          T1  = 2.0 * PI * RANART(NSEED)
4758          IBLOCK=1
4759          GO TO 107
4760       ELSE
4761 *COM: TEST FOR INELASTIC SCATTERING
4762 *     IF THE AVAILABLE ENERGY IS LESS THAN THE PION-MASS, NOTHING
4763 *     CAN HAPPEN ANY MORE ==> RETURN (2.012 = 2*AVMASS + PI-MASS)
4764 clin-5/2008: Mdeuteron+Mpi=2.0106 to 2.0152 GeV/c2, so we can still use this:
4765          IF (SRT .LT. 2.012) RETURN
4766 *     calculate the N*(1535) production cross section in N+N collisions
4767 *     note that the cross sections in this subroutine are in units of mb
4768 *     as only ratios of the cross sections are used to determine the
4769 *     reaction channels
4770        call N1535(iabs(lb(i1)),iabs(lb(i2)),srt,x1535)
4771 *COM: HERE WE HAVE A PROCESS N+N ==> N+DELTA,OR N+N==>N+N*(144) or N*(1535)
4772 *     OR
4773 * 3 pi channel : N+N==>d1+d2+PION
4774        SIG3=3.*(X3pi(SRT)+x33pi(srt))
4775 * 2 pi channel : N+N==>d1+d2+d1*n*+n*n*
4776        SIG4=4.*X2pi(srt)
4777 * 4 pi channel : N+N==>d1+d2+rho
4778        s4pi=x4pi(srt)
4779 * N+N-->NN+rho channel
4780        srho=xrho(srt)
4781 * N+N-->NN+omega
4782        somega=omega(srt)
4783 * CROSS SECTION FOR KAON PRODUCTION from the four channels
4784 * for NLK channel
4785        akp=0.498
4786        ak0=0.498
4787        ana=0.94
4788        ada=1.232
4789        al=1.1157
4790        as=1.1197
4791        xsk1=0
4792        xsk2=0
4793        xsk3=0
4794        xsk4=0
4795        xsk5=0
4796        t1nlk=ana+al+akp
4797        if(srt.le.t1nlk)go to 222
4798        XSK1=1.5*PPLPK(SRT)
4799 * for DLK channel
4800        t1dlk=ada+al+akp
4801        t2dlk=ada+al-akp
4802        if(srt.le.t1dlk)go to 222
4803        es=srt
4804        pmdlk2=(es**2-t1dlk**2)*(es**2-t2dlk**2)/(4.*es**2)
4805        pmdlk=sqrt(pmdlk2)
4806        XSK3=1.5*PPLPK(srt)
4807 * for NSK channel
4808        t1nsk=ana+as+akp
4809        t2nsk=ana+as-akp
4810        if(srt.le.t1nsk)go to 222
4811        pmnsk2=(es**2-t1nsk**2)*(es**2-t2nsk**2)/(4.*es**2)
4812        pmnsk=sqrt(pmnsk2)
4813        XSK2=1.5*(PPK1(srt)+PPK0(srt))
4814 * for DSK channel
4815        t1DSk=aDa+aS+akp
4816        t2DSk=aDa+aS-akp
4817        if(srt.le.t1dsk)go to 222
4818        pmDSk2=(es**2-t1DSk**2)*(es**2-t2DSk**2)/(4.*es**2)
4819        pmDSk=sqrt(pmDSk2)
4820        XSK4=1.5*(PPK1(srt)+PPK0(srt))
4821 csp11/21/01
4822 c phi production
4823        if(srt.le.(2.*amn+aphi))go to 222
4824 c  !! mb put the correct form
4825        xsk5 = 0.0001
4826 csp11/21/01 end
4827 c
4828 * THE TOTAL KAON+ PRODUCTION CROSS SECTION IS THEN
4829  222   SIGK=XSK1+XSK2+XSK3+XSK4
4830
4831 cbz3/7/99 neutralk
4832         XSK1 = 2.0 * XSK1
4833         XSK2 = 2.0 * XSK2
4834         XSK3 = 2.0 * XSK3
4835         XSK4 = 2.0 * XSK4
4836         SIGK = 2.0 * SIGK + xsk5
4837 cbz3/7/99 neutralk end
4838 c
4839 ** FOR P+P or L/S+L/S COLLISION:
4840 c       lb1=lb(i1)
4841 c       lb2=lb(i2)
4842         lb1=iabs(lb(i1))
4843         lb2=iabs(lb(i2))
4844         IF((LB(I1)*LB(I2).EQ.1).or.
4845      &       ((lb1.le.17.and.lb1.ge.14).and.(lb2.le.17.and.lb2.ge.14)).
4846      &       or.((lb1.le.2).and.(lb2.le.17.and.lb2.ge.14)).
4847      &       or.((lb2.le.2).and.(lb1.le.17.and.lb1.ge.14)))THEN
4848 clin-8/2008 PP->d+meson here:
4849            IF(X1.LE.((SIGNN+sdprod)/SIG)) GO TO 108
4850            SIG1=SIGMA(SRT,1,1,0)+0.5*SIGMA(SRT,1,1,1)
4851            SIG2=1.5*SIGMA(SRT,1,1,1)
4852            SIGND=SIG1+SIG2+SIG3+SIG4+X1535+SIGK+s4pi+srho+somega
4853 clin-5/2008:
4854 c           IF (X1.GT.(SIGNN+SIGND)/SIG)RETURN
4855            IF (X1.GT.(SIGNN+SIGND+sdprod)/SIG)RETURN
4856            DIR=SIG3/SIGND
4857            IF(RANART(NSEED).LE.DIR)GO TO 106
4858            IF(RANART(NSEED).LE.SIGK/(SIGK+X1535+SIG4+SIG2+SIG1
4859      &          +s4pi+srho+somega))GO TO 306
4860            if(RANART(NSEED).le.s4pi/(x1535+sig4+sig2+sig1
4861      &          +s4pi+srho+somega))go to 307
4862            if(RANART(NSEED).le.srho/(x1535+sig4+sig2+sig1
4863      &          +srho+somega))go to 308
4864            if(RANART(NSEED).le.somega/(x1535+sig4+sig2+sig1
4865      &          +somega))go to 309
4866            if(RANART(NSEED).le.x1535/(sig1+sig2+sig4+x1535))then
4867 * N*(1535) production
4868               N12=9
4869            ELSE
4870               IF(RANART(NSEED).LE.SIG4/(SIG1+sig2+sig4))THEN
4871 * DOUBLE DELTA PRODUCTION
4872                  N12=66
4873                  GO TO 1012
4874               else
4875 *DELTA PRODUCTION
4876                  N12=3
4877                  IF (RANART(NSEED).GT.SIG1/(SIG1+SIG2))N12=4
4878               ENDIF
4879            endif
4880            GO TO 1011
4881         ENDIF
4882 ** FOR N+N COLLISION:
4883         IF(iabs(LB(I1)).EQ.2.AND.iabs(LB(I2)).EQ.2)THEN
4884 clin-8/2008 NN->d+meson here:
4885            IF(X1.LE.((SIGNN+sdprod)/SIG)) GO TO 108
4886            SIG1=SIGMA(SRT,1,1,0)+0.5*SIGMA(SRT,1,1,1)
4887            SIG2=1.5*SIGMA(SRT,1,1,1)
4888            SIGND=SIG1+SIG2+X1535+SIG3+SIG4+SIGK+s4pi+srho+somega
4889 clin-5/2008:
4890 c           IF (X1.GT.(SIGNN+SIGND)/SIG)RETURN
4891            IF (X1.GT.(SIGNN+SIGND+sdprod)/SIG)RETURN
4892            dir=sig3/signd
4893            IF(RANART(NSEED).LE.DIR)GO TO 106
4894            IF(RANART(NSEED).LE.SIGK/(SIGK+X1535+SIG4+SIG2+SIG1
4895      &          +s4pi+srho+somega))GO TO 306
4896            if(RANART(NSEED).le.s4pi/(x1535+sig4+sig2+sig1
4897      &          +s4pi+srho+somega))go to 307
4898            if(RANART(NSEED).le.srho/(x1535+sig4+sig2+sig1
4899      &          +srho+somega))go to 308
4900            if(RANART(NSEED).le.somega/(x1535+sig4+sig2+sig1
4901      &          +somega))go to 309
4902            IF(RANART(NSEED).LE.X1535/(x1535+sig1+sig2+sig4))THEN
4903 * N*(1535) PRODUCTION
4904               N12=10
4905            ELSE
4906               if(RANART(NSEED).le.sig4/(sig1+sig2+sig4))then
4907 * double delta production
4908                  N12=67
4909                  GO TO 1013
4910               else
4911 * DELTA PRODUCTION
4912                  N12=6
4913                  IF (RANART(NSEED).GT.SIG1/(SIG1+SIG2))N12=5
4914               ENDIF
4915            endif
4916            GO TO 1011
4917         ENDIF
4918 ** FOR N+P COLLISION
4919         IF(LB(I1)*LB(I2).EQ.2)THEN
4920 clin-5/2008 NP->d+meson here:
4921            IF(X1.LE.((SIGNN+sdprod)/SIG)) GO TO 108
4922            SIG1=0.5*SIGMA(SRT,1,1,1)+0.25*SIGMA(SRT,1,1,0)
4923            IF(NSTAR.EQ.1)THEN
4924               SIG2=(3./4.)*SIGMA(SRT,2,0,1)
4925            ELSE
4926               SIG2=0.
4927            ENDIF
4928            SIGND=2.*(SIG1+SIG2+X1535)+sig3+sig4+SIGK+s4pi+srho+somega
4929 clin-5/2008:
4930 c           IF (X1.GT.(SIGNN+SIGND)/SIG)RETURN
4931            IF (X1.GT.(SIGNN+SIGND+sdprod)/SIG)RETURN
4932            dir=sig3/signd
4933            IF(RANART(NSEED).LE.DIR)GO TO 106
4934            IF(RANART(NSEED).LE.SIGK/(SIGND-SIG3))GO TO 306
4935            if(RANART(NSEED).le.s4pi/(signd-sig3-sigk))go to 307
4936            if(RANART(NSEED).le.srho/(signd-sig3-sigk-s4pi))go to 308
4937            if(RANART(NSEED).le.somega/(signd-sig3-sigk-s4pi-srho))
4938      1          go to 309
4939            IF(RANART(NSEED).LT.X1535/(SIG1+SIG2+X1535+0.5*sig4))THEN
4940 * N*(1535) PRODUCTION
4941               N12=11
4942               IF(RANART(NSEED).LE.0.5)N12=12
4943            ELSE
4944               if(RANART(NSEED).le.sig4/(sig4+2.*(sig1+sig2)))then
4945 * double resonance production
4946                  N12=68
4947                  GO TO 1014
4948               else
4949                  IF(RANART(NSEED).LE.SIG1/(SIG1+SIG2))THEN
4950 * DELTA PRODUCTION
4951                     N12=2
4952                     IF(RANART(NSEED).GE.0.5)N12=1
4953                  ELSE
4954 * N*(1440) PRODUCTION
4955                     N12=8
4956                     IF(RANART(NSEED).GE.0.5)N12=7
4957                  ENDIF
4958               ENDIF
4959            ENDIF
4960         endif
4961  1011   iblock=2
4962         CONTINUE
4963 *PARAMETRIZATION OF THE SHAPE OF THE DELTA RESONANCE ACCORDING
4964 *     TO kitazoe's or J.D.JACKSON'S MASS FORMULA AND BREIT WIGNER
4965 *     FORMULA FOR N* RESORANCE
4966 *     DETERMINE DELTA MASS VIA REJECTION METHOD.
4967           DMAX = SRT - AVMASS-0.005
4968           DMAX = SRT - AVMASS-0.005
4969           DMIN = 1.078
4970                    IF(N12.LT.7)THEN
4971 * Delta(1232) production
4972           IF(DMAX.LT.1.232) THEN
4973           FM=FDE(DMAX,SRT,0.)
4974           ELSE
4975
4976 clin-10/25/02 get rid of argument usage mismatch in FDE():
4977              xdmass=1.232
4978 c          FM=FDE(1.232,SRT,1.)
4979           FM=FDE(xdmass,SRT,1.)
4980 clin-10/25/02-end
4981
4982           ENDIF
4983           IF(FM.EQ.0.)FM=1.E-09
4984           NTRY1=0
4985 10        DM = RANART(NSEED) * (DMAX-DMIN) + DMIN
4986           NTRY1=NTRY1+1
4987           IF((RANART(NSEED) .GT. FDE(DM,SRT,1.)/FM).AND.
4988      1    (NTRY1.LE.30)) GOTO 10
4989
4990 clin-2/26/03 limit the Delta mass below a certain value
4991 c     (here taken as its central value + 2* B-W fullwidth):
4992           if(dm.gt.1.47) goto 10
4993
4994               GO TO 13
4995               ENDIF
4996                    IF((n12.eq.7).or.(n12.eq.8))THEN
4997 * N*(1440) production
4998           IF(DMAX.LT.1.44) THEN
4999           FM=FNS(DMAX,SRT,0.)
5000           ELSE
5001
5002 clin-10/25/02 get rid of argument usage mismatch in FNS():
5003              xdmass=1.44
5004 c          FM=FNS(1.44,SRT,1.)
5005           FM=FNS(xdmass,SRT,1.)
5006 clin-10/25/02-end
5007
5008           ENDIF
5009           IF(FM.EQ.0.)FM=1.E-09
5010           NTRY2=0
5011 11        DM=RANART(NSEED)*(DMAX-DMIN)+DMIN
5012           NTRY2=NTRY2+1
5013           IF((RANART(NSEED).GT.FNS(DM,SRT,1.)/FM).AND.
5014      1    (NTRY2.LE.10)) GO TO 11
5015
5016 clin-2/26/03 limit the N* mass below a certain value
5017 c     (here taken as its central value + 2* B-W fullwidth):
5018           if(dm.gt.2.14) goto 11
5019
5020               GO TO 13
5021               ENDIF
5022                     IF(n12.ge.17)then
5023 * N*(1535) production
5024           IF(DMAX.LT.1.535) THEN
5025           FM=FD5(DMAX,SRT,0.)
5026           ELSE
5027
5028 clin-10/25/02 get rid of argument usage mismatch in FNS():
5029              xdmass=1.535
5030 c          FM=FD5(1.535,SRT,1.)
5031           FM=FD5(xdmass,SRT,1.)
5032 clin-10/25/02-end
5033
5034           ENDIF
5035           IF(FM.EQ.0.)FM=1.E-09
5036           NTRY1=0
5037 12        DM = RANART(NSEED) * (DMAX-DMIN) + DMIN
5038           NTRY1=NTRY1+1
5039           IF((RANART(NSEED) .GT. FD5(DM,SRT,1.)/FM).AND.
5040      1    (NTRY1.LE.10)) GOTO 12
5041
5042 clin-2/26/03 limit the N* mass below a certain value
5043 c     (here taken as its central value + 2* B-W fullwidth):
5044           if(dm.gt.1.84) goto 12
5045
5046          GO TO 13
5047              ENDIF
5048 * CALCULATE THE MASSES OF BARYON RESONANCES IN THE DOUBLE RESONANCE
5049 * PRODUCTION PROCESS AND RELABLE THE PARTICLES
5050 1012       iblock=43
5051        call Rmasdd(srt,1.232,1.232,1.08,
5052      &  1.08,ISEED,1,dm1,dm2)
5053        call Rmasdd(srt,1.232,1.44,1.08,
5054      &  1.08,ISEED,3,dm1n,dm2n)
5055        IF(N12.EQ.66)THEN
5056 *(1) PP-->DOUBLE RESONANCES
5057 * DETERMINE THE FINAL STATE
5058        XFINAL=RANART(NSEED)
5059        IF(XFINAL.LE.0.25)THEN
5060 * (1.1) D+++D0
5061        LB(I1)=9
5062        LB(I2)=7
5063        e(i1)=dm1
5064        e(i2)=dm2
5065        GO TO 200
5066 * go to 200 to set the new momentum
5067        ENDIF
5068        IF((XFINAL.gt.0.25).and.(xfinal.le.0.5))THEN
5069 * (1.2) D++D+
5070        LB(I1)=8
5071        LB(I2)=8
5072        e(i1)=dm1
5073        e(i2)=dm2
5074        GO TO 200
5075 * go to 200 to set the new momentum
5076        ENDIF
5077        IF((XFINAL.gt.0.5).and.(xfinal.le.0.75))THEN
5078 * (1.3) D+++N*0
5079        LB(I1)=9
5080        LB(I2)=10
5081        e(i1)=dm1n
5082        e(i2)=dm2n
5083        GO TO 200
5084 * go to 200 to set the new momentum
5085        ENDIF
5086        IF(XFINAL.gt.0.75)then
5087 * (1.4) D++N*+
5088        LB(I1)=8
5089        LB(I2)=11
5090        e(i1)=dm1n
5091        e(i2)=dm2n
5092        GO TO 200
5093 * go to 200 to set the new momentum
5094        ENDIF
5095        ENDIF
5096 1013       iblock=43
5097        call Rmasdd(srt,1.232,1.232,1.08,
5098      &  1.08,ISEED,1,dm1,dm2)
5099        call Rmasdd(srt,1.232,1.44,1.08,
5100      &  1.08,ISEED,3,dm1n,dm2n)
5101        IF(N12.EQ.67)THEN
5102 *(2) NN-->DOUBLE RESONANCES
5103 * DETERMINE THE FINAL STATE
5104        XFINAL=RANART(NSEED)
5105        IF(XFINAL.LE.0.25)THEN
5106 * (2.1) D0+D0
5107        LB(I1)=7
5108        LB(I2)=7
5109        e(i1)=dm1
5110        e(i2)=dm2
5111        GO TO 200
5112 * go to 200 to set the new momentum
5113         ENDIF
5114        IF((XFINAL.gt.0.25).and.(xfinal.le.0.5))THEN
5115 * (2.2) D++D+
5116        LB(I1)=6
5117        LB(I2)=8
5118        e(i1)=dm1
5119        e(i2)=dm2
5120        GO TO 200
5121 * go to 200 to set the new momentum
5122        ENDIF
5123        IF((XFINAL.gt.0.5).and.(xfinal.le.0.75))THEN
5124 * (2.3) D0+N*0
5125        LB(I1)=7
5126        LB(I2)=10
5127        e(i1)=dm1n
5128        e(i2)=dm2n
5129        GO TO 200
5130 * go to 200 to set the new momentum
5131        ENDIF
5132        IF(XFINAL.gt.0.75)then
5133 * (2.4) D++N*+
5134        LB(I1)=8
5135        LB(I2)=11
5136        e(i1)=dm1n
5137        e(i2)=dm2n
5138        GO TO 200
5139 * go to 200 to set the new momentum
5140        ENDIF
5141        ENDIF
5142 1014       iblock=43
5143        call Rmasdd(srt,1.232,1.232,1.08,
5144      &  1.08,ISEED,1,dm1,dm2)
5145        call Rmasdd(srt,1.232,1.44,1.08,
5146      &  1.08,ISEED,3,dm1n,dm2n)
5147        IF(N12.EQ.68)THEN
5148 *(3) NP-->DOUBLE RESONANCES
5149 * DETERMINE THE FINAL STATE
5150        XFINAL=RANART(NSEED)
5151        IF(XFINAL.LE.0.25)THEN
5152 * (3.1) D0+D+
5153        LB(I1)=7
5154        LB(I2)=8
5155        e(i1)=dm1
5156        e(i2)=dm2
5157        GO TO 200
5158 * go to 200 to set the new momentum
5159        ENDIF
5160        IF((XFINAL.gt.0.25).and.(xfinal.le.0.5))THEN
5161 * (3.2) D+++D-
5162        LB(I1)=9
5163        LB(I2)=6
5164        e(i1)=dm1
5165        e(i2)=dm2
5166        GO TO 200
5167 * go to 200 to set the new momentum
5168        ENDIF
5169        IF((XFINAL.gt.0.5).and.(xfinal.le.0.75))THEN
5170 * (3.3) D0+N*+
5171        LB(I1)=7
5172        LB(I2)=11
5173        e(i1)=dm1n
5174        e(i2)=dm2n
5175        GO TO 200
5176 * go to 200 to set the new momentum
5177        ENDIF
5178        IF(XFINAL.gt.0.75)then
5179 * (3.4) D++N*0
5180        LB(I1)=8
5181        LB(I2)=10
5182        e(i1)=dm1n
5183        e(i2)=dm2n
5184        GO TO 200
5185 * go to 200 to set the new momentum
5186        ENDIF
5187        ENDIF
5188 13       CONTINUE
5189 *-------------------------------------------------------
5190 * RELABLE BARYON I1 AND I2
5191 *1. p+n-->delta(+)+n
5192           IF(N12.EQ.1)THEN
5193           IF(iabs(LB(I1)).EQ.1)THEN
5194           LB(I2)=2
5195           LB(I1)=8
5196           E(I1)=DM
5197           ELSE
5198           LB(I1)=2
5199           LB(I2)=8
5200           E(I2)=DM
5201           ENDIF
5202          GO TO 200
5203           ENDIF
5204 *2 p+n-->delta(0)+p
5205           IF(N12.EQ.2)THEN
5206           IF(iabs(LB(I1)).EQ.2)THEN
5207           LB(I2)=1
5208           LB(I1)=7
5209           E(I1)=DM
5210           ELSE
5211           LB(I1)=1
5212           LB(I2)=7
5213           E(I2)=DM
5214           ENDIF
5215          GO TO 200
5216           ENDIF
5217 *3 p+p-->delta(++)+n
5218           IF(N12.EQ.3)THEN
5219           LB(I1)=9
5220           E(I1)=DM
5221           LB(I2)=2
5222           E(I2)=AMN
5223          GO TO 200
5224           ENDIF
5225 *4 p+p-->delta(+)+p
5226           IF(N12.EQ.4)THEN
5227           LB(I2)=1
5228           LB(I1)=8
5229           E(I1)=DM
5230          GO TO 200
5231           ENDIF
5232 *5 n+n--> delta(0)+n
5233           IF(N12.EQ.5)THEN
5234           LB(I2)=2
5235           LB(I1)=7
5236           E(I1)=DM
5237          GO TO 200
5238           ENDIF
5239 *6 n+n--> delta(-)+p
5240           IF(N12.EQ.6)THEN
5241           LB(I1)=6
5242           E(I1)=DM
5243           LB(I2)=1
5244           E(I2)=AMP
5245          GO TO 200
5246           ENDIF
5247 *7 n+p--> N*(0)+p
5248           IF(N12.EQ.7)THEN
5249           IF(iabs(LB(I1)).EQ.1)THEN
5250           LB(I1)=1
5251           LB(I2)=10
5252           E(I2)=DM
5253           ELSE
5254           LB(I2)=1
5255           LB(I1)=10
5256           E(I1)=DM
5257           ENDIF
5258          GO TO 200
5259           ENDIF
5260 *8 n+p--> N*(+)+n
5261           IF(N12.EQ.8)THEN
5262           IF(iabs(LB(I1)).EQ.1)THEN
5263           LB(I2)=2
5264           LB(I1)=11
5265           E(I1)=DM
5266           ELSE
5267           LB(I1)=2
5268           LB(I2)=11
5269           E(I2)=DM
5270           ENDIF
5271          GO TO 200
5272           ENDIF
5273 *9 p+p--> N*(+)(1535)+p
5274           IF(N12.EQ.9)THEN
5275           IF(RANART(NSEED).le.0.5)THEN
5276           LB(I2)=1
5277           LB(I1)=13
5278           E(I1)=DM
5279           ELSE
5280           LB(I1)=1
5281           LB(I2)=13
5282           E(I2)=DM
5283           ENDIF
5284          GO TO 200
5285           ENDIF
5286 *10 n+n--> N*(0)(1535)+n
5287           IF(N12.EQ.10)THEN
5288           IF(RANART(NSEED).le.0.5)THEN
5289           LB(I2)=2
5290           LB(I1)=12
5291           E(I1)=DM
5292           ELSE
5293           LB(I1)=2
5294           LB(I2)=12
5295           E(I2)=DM
5296           ENDIF
5297          GO TO 200
5298           ENDIF
5299 *11 n+p--> N*(+)(1535)+n
5300           IF(N12.EQ.11)THEN
5301           IF(iabs(LB(I1)).EQ.2)THEN
5302           LB(I1)=2
5303           LB(I2)=13
5304           E(I2)=DM
5305           ELSE
5306           LB(I2)=2
5307           LB(I1)=13
5308           E(I1)=DM
5309           ENDIF
5310          GO TO 200
5311           ENDIF
5312 *12 n+p--> N*(0)(1535)+p
5313           IF(N12.EQ.12)THEN
5314           IF(iabs(LB(I1)).EQ.1)THEN
5315           LB(I1)=1
5316           LB(I2)=12
5317           E(I2)=DM
5318           ELSE
5319           LB(I2)=1
5320           LB(I1)=12
5321           E(I1)=DM
5322           ENDIF
5323           ENDIF
5324          endif
5325 * CALCULATE THE MAGNITUDE OF THE FINAL MOMENTUM THROUGH
5326 * ENERGY CONSERVATION
5327 200       EM1=E(I1)
5328           EM2=E(I2)
5329           PR2   = (SRT**2 - EM1**2 - EM2**2)**2
5330      1                - 4.0 * (EM1*EM2)**2
5331           IF(PR2.LE.0.)PR2=1.e-09
5332           PR=SQRT(PR2)/(2.*SRT)
5333               if(srt.le.2.14)C1= 1.0 - 2.0 * RANART(NSEED)
5334          if(srt.gt.2.14.and.srt.le.2.4)c1=anga(srt,iseed)
5335          if(srt.gt.2.4)then
5336
5337 clin-10/25/02 get rid of argument usage mismatch in PTR():
5338              xptr=0.33*pr
5339 c         cc1=ptr(0.33*pr,iseed)
5340              cc1=ptr(xptr,iseed)
5341 clin-10/25/02-end
5342
5343          c1=sqrt(pr**2-cc1**2)/pr
5344          endif
5345           T1   = 2.0 * PI * RANART(NSEED)
5346        if(ianti.eq.1 .and. lb(i1).ge.1 .and. lb(i2).ge.1)then
5347          lb(i1) = -lb(i1)
5348          lb(i2) = -lb(i2)
5349        endif
5350           GO TO 107
5351 *FOR THE NN-->D1+D2+PI PROCESS, FIND MOMENTUM OF THE FINAL TWO
5352 *DELTAS AND PION IN THE NUCLEUS-NUCLEUS CMS.
5353 106     CONTINUE
5354            NTRY1=0
5355 123        CALL DDP2(SRT,ISEED,PX3,PY3,PZ3,DM3,PX4,PY4,PZ4,DM4,
5356      &  PPX,PPY,PPZ,icou1)
5357        NTRY1=NTRY1+1
5358        if((icou1.lt.0).AND.(NTRY1.LE.40))GO TO 123
5359 C       if(icou1.lt.0)return
5360 * ROTATE THE MOMENTA OF PARTICLES IN THE CMS OF P1+P2
5361        CALL ROTATE(PX,PY,PZ,PX3,PY3,PZ3)
5362        CALL ROTATE(PX,PY,PZ,PX4,PY4,PZ4)
5363        CALL ROTATE(PX,PY,PZ,PPX,PPY,PPZ)
5364                 NNN=NNN+1
5365 * DETERMINE THE CHARGE STATES OF PARTICLES IN THE FINAL STATE
5366 * (1) FOR P+P
5367               XDIR=RANART(NSEED)
5368                 IF(LB(I1)*LB(I2).EQ.1)THEN
5369                 IF(XDIR.Le.0.2)then
5370 * (1.1)P+P-->D+++D0+PION(0)
5371                 LPION(NNN,IRUN)=4
5372                 EPION(NNN,IRUN)=AP1
5373               LB(I1)=9
5374               LB(I2)=7
5375        GO TO 205
5376                 ENDIF
5377 * (1.2)P+P -->D++D+PION(0)
5378                 IF((XDIR.LE.0.4).AND.(XDIR.GT.0.2))THEN
5379                 LPION(NNN,IRUN)=4
5380                 EPION(NNN,IRUN)=AP1
5381                 LB(I1)=8
5382                 LB(I2)=8
5383        GO TO 205
5384               ENDIF
5385 * (1.3)P+P-->D+++D+PION(-)
5386                 IF((XDIR.LE.0.6).AND.(XDIR.GT.0.4))THEN
5387                 LPION(NNN,IRUN)=3
5388                 EPION(NNN,IRUN)=AP2
5389                 LB(I1)=9
5390                 LB(I2)=8
5391        GO TO 205
5392               ENDIF
5393                 IF((XDIR.LE.0.8).AND.(XDIR.GT.0.6))THEN
5394                 LPION(NNN,IRUN)=5
5395                 EPION(NNN,IRUN)=AP2
5396                 LB(I1)=9
5397                 LB(I2)=6
5398        GO TO 205
5399               ENDIF
5400                 IF(XDIR.GT.0.8)THEN
5401                 LPION(NNN,IRUN)=5
5402                 EPION(NNN,IRUN)=AP2
5403                 LB(I1)=7
5404                 LB(I2)=8
5405        GO TO 205
5406               ENDIF
5407                ENDIF
5408 * (2)FOR N+N
5409                 IF(iabs(LB(I1)).EQ.2.AND.iabs(LB(I2)).EQ.2)THEN
5410                 IF(XDIR.Le.0.2)then
5411 * (2.1)N+N-->D++D-+PION(0)
5412                 LPION(NNN,IRUN)=4
5413                 EPION(NNN,IRUN)=AP1
5414               LB(I1)=6
5415               LB(I2)=7
5416        GO TO 205
5417                 ENDIF
5418 * (2.2)N+N -->D+++D-+PION(-)
5419                 IF((XDIR.LE.0.4).AND.(XDIR.GT.0.2))THEN
5420                 LPION(NNN,IRUN)=3
5421                 EPION(NNN,IRUN)=AP2
5422                 LB(I1)=6
5423                 LB(I2)=9
5424        GO TO 205
5425               ENDIF
5426 * (2.3)P+P-->D0+D-+PION(+)
5427                 IF((XDIR.GT.0.4).AND.(XDIR.LE.0.6))THEN
5428                 LPION(NNN,IRUN)=5
5429                 EPION(NNN,IRUN)=AP2
5430                 LB(I1)=9
5431                 LB(I2)=8
5432        GO TO 205
5433               ENDIF
5434 * (2.4)P+P-->D0+D0+PION(0)
5435                 IF((XDIR.GT.0.6).AND.(XDIR.LE.0.8))THEN
5436                 LPION(NNN,IRUN)=4
5437                 EPION(NNN,IRUN)=AP1
5438                 LB(I1)=7
5439                 LB(I2)=7
5440        GO TO 205
5441               ENDIF
5442 * (2.5)P+P-->D0+D++PION(-)
5443                 IF(XDIR.GT.0.8)THEN
5444                 LPION(NNN,IRUN)=3
5445                 EPION(NNN,IRUN)=AP2
5446                 LB(I1)=7
5447                 LB(I2)=8
5448        GO TO 205
5449               ENDIF
5450               ENDIF
5451 * (3)FOR N+P
5452                 IF(LB(I1)*LB(I2).EQ.2)THEN
5453                 IF(XDIR.Le.0.17)then
5454 * (3.1)N+P-->D+++D-+PION(0)
5455                 LPION(NNN,IRUN)=4
5456                 EPION(NNN,IRUN)=AP1
5457               LB(I1)=6
5458               LB(I2)=9
5459        GO TO 205
5460                 ENDIF
5461 * (3.2)N+P -->D+++D0+PION(-)
5462                 IF((XDIR.LE.0.34).AND.(XDIR.GT.0.17))THEN
5463                 LPION(NNN,IRUN)=3
5464                 EPION(NNN,IRUN)=AP2
5465                 LB(I1)=7
5466                 LB(I2)=9
5467        GO TO 205
5468               ENDIF
5469 * (3.3)N+P-->D++D-+PION(+)
5470                 IF((XDIR.GT.0.34).AND.(XDIR.LE.0.51))THEN
5471                 LPION(NNN,IRUN)=5
5472                 EPION(NNN,IRUN)=AP2
5473                 LB(I1)=7
5474                 LB(I2)=8
5475        GO TO 205
5476               ENDIF
5477 * (3.4)N+P-->D++D++PION(-)
5478                 IF((XDIR.GT.0.51).AND.(XDIR.LE.0.68))THEN
5479                 LPION(NNN,IRUN)=3
5480                 EPION(NNN,IRUN)=AP2
5481                 LB(I1)=8
5482                 LB(I2)=8
5483        GO TO 205
5484               ENDIF
5485 * (3.5)N+P-->D0+D++PION(0)
5486                 IF((XDIR.GT.0.68).AND.(XDIR.LE.0.85))THEN
5487                 LPION(NNN,IRUN)=4
5488                 EPION(NNN,IRUN)=AP2
5489                 LB(I1)=7
5490                 LB(I2)=8
5491        GO TO 205
5492               ENDIF
5493 * (3.6)N+P-->D0+D0+PION(+)
5494                 IF(XDIR.GT.0.85)THEN
5495                 LPION(NNN,IRUN)=5
5496                 EPION(NNN,IRUN)=AP2
5497                 LB(I1)=7
5498                 LB(I2)=7
5499               ENDIF
5500                 ENDIF
5501 * FIND THE MOMENTUM OF PARTICLES IN THE FINAL STATE IN THE NUCLEUS-
5502 * NUCLEUS CMS. FRAME
5503 *             LORENTZ-TRANSFORMATION INTO LAB FRAME FOR DELTA1
5504 205           E1CM    = SQRT (dm3**2 + PX3**2 + PY3**2 + PZ3**2)
5505               P1BETA  = PX3*BETAX + PY3*BETAY + PZ3*BETAZ
5506               TRANSF  = GAMMA * ( GAMMA * P1BETA / (GAMMA + 1) + E1CM )
5507               Pt1i1 = BETAX * TRANSF + PX3
5508               Pt2i1 = BETAY * TRANSF + PY3
5509               Pt3i1 = BETAZ * TRANSF + PZ3
5510              Eti1   = DM3
5511 c
5512              if(ianti.eq.1 .and. lb(i1).ge.1 .and. lb(i2).ge.1)then
5513                lb(i1) = -lb(i1)
5514                lb(i2) = -lb(i2)
5515                 if(LPION(NNN,IRUN) .eq. 3)then
5516                   LPION(NNN,IRUN)=5
5517                 elseif(LPION(NNN,IRUN) .eq. 5)then
5518                   LPION(NNN,IRUN)=3
5519                 endif
5520                endif
5521 c
5522              lb1=lb(i1)
5523 * FOR DELTA2
5524                 E2CM    = SQRT (dm4**2 + PX4**2 + PY4**2 + PZ4**2)
5525                 P2BETA  = PX4*BETAX+PY4*BETAY+PZ4*BETAZ
5526                 TRANSF  = GAMMA * (GAMMA*P2BETA / (GAMMA + 1.) + E2CM)
5527                 Pt1I2 = BETAX * TRANSF + PX4
5528                 Pt2I2 = BETAY * TRANSF + PY4
5529                 Pt3I2 = BETAZ * TRANSF + PZ4
5530               EtI2   = DM4
5531               lb2=lb(i2)
5532 * assign delta1 and delta2 to i1 or i2 to keep the leadng particle
5533 * behaviour
5534 C              if((pt1i1*px1+pt2i1*py1+pt3i1*pz1).gt.0)then
5535               p(1,i1)=pt1i1
5536               p(2,i1)=pt2i1
5537               p(3,i1)=pt3i1
5538               e(i1)=eti1
5539               lb(i1)=lb1
5540               p(1,i2)=pt1i2
5541               p(2,i2)=pt2i2
5542               p(3,i2)=pt3i2
5543               e(i2)=eti2
5544               lb(i2)=lb2
5545                 PX1     = P(1,I1)
5546                 PY1     = P(2,I1)
5547                 PZ1     = P(3,I1)
5548               EM1       = E(I1)
5549                 ID(I1)  = 2
5550                 ID(I2)  = 2
5551                 ID1     = ID(I1)
5552                 IBLOCK=4
5553 * GET PION'S MOMENTUM AND COORDINATES IN NUCLEUS-NUCLEUS CMS. FRAME
5554                 EPCM=SQRT(EPION(NNN,IRUN)**2+PPX**2+PPY**2+PPZ**2)
5555                 PPBETA=PPX*BETAX+PPY*BETAY+PPZ*BETAZ
5556                 TRANSF=GAMMA*(GAMMA*PPBETA/(GAMMA+1.)+EPCM)
5557                 PPION(1,NNN,IRUN)=BETAX*TRANSF+PPX
5558                 PPION(2,NNN,IRUN)=BETAY*TRANSF+PPY
5559                 PPION(3,NNN,IRUN)=BETAZ*TRANSF+PPZ
5560 clin-5/2008:
5561                 dppion(nnn,irun)=dpertp(i1)*dpertp(i2)
5562 clin-5/2008 do not allow smearing in position of produced particles
5563 c     to avoid immediate reinteraction with the particle I1, I2 or themselves:
5564 c2002        X01 = 1.0 - 2.0 * RANART(NSEED)
5565 c            Y01 = 1.0 - 2.0 * RANART(NSEED)
5566 c            Z01 = 1.0 - 2.0 * RANART(NSEED)
5567 c        IF ((X01*X01+Y01*Y01+Z01*Z01) .GT. 1.0) GOTO 2002
5568 c                RPION(1,NNN,IRUN)=R(1,I1)+0.5*x01
5569 c                RPION(2,NNN,IRUN)=R(2,I1)+0.5*y01
5570 c                RPION(3,NNN,IRUN)=R(3,I1)+0.5*z01
5571                 RPION(1,NNN,IRUN)=R(1,I1)
5572                 RPION(2,NNN,IRUN)=R(2,I1)
5573                 RPION(3,NNN,IRUN)=R(3,I1)
5574 c
5575               go to 90005
5576 clin-5/2008 N+N->Deuteron+pi:
5577 *     FIND MOMENTUM OF THE FINAL PARTICLES IN THE NUCLEUS-NUCLEUS CMS.
5578  108       CONTINUE
5579            if(idpert.eq.1.and.ipert1.eq.1.and.npertd.ge.1) then
5580 c     For idpert=1: we produce npertd pert deuterons:
5581               ndloop=npertd
5582            elseif(idpert.eq.2.and.npertd.ge.1) then
5583 c     For idpert=2: we first save information for npertd pert deuterons;
5584 c     at the last ndloop we create the regular deuteron+pi
5585 c     and those pert deuterons:
5586               ndloop=npertd+1
5587            else
5588 c     Just create the regular deuteron+pi:
5589               ndloop=1
5590            endif
5591 c
5592            dprob1=sdprod/sig/float(npertd)
5593            do idloop=1,ndloop
5594               CALL bbdangle(pxd,pyd,pzd,nt,ipert1,ianti,idloop,pfinal,
5595      1 dprob1,lbm)
5596               CALL ROTATE(PX,PY,PZ,PXd,PYd,PZd)
5597 *     LORENTZ-TRANSFORMATION OF THE MOMENTUM OF PARTICLES IN THE FINAL STATE
5598 *     FROM THE NN CMS FRAME INTO THE GLOBAL CMS FRAME:
5599 *     For the Deuteron:
5600               xmass=xmd
5601               E1dCM=SQRT(xmass**2+PXd**2+PYd**2+PZd**2)
5602               P1dBETA=PXd*BETAX+PYd*BETAY+PZd*BETAZ
5603               TRANSF=GAMMA*(GAMMA*P1dBETA/(GAMMA+1.)+E1dCM)
5604               pxi1=BETAX*TRANSF+PXd
5605               pyi1=BETAY*TRANSF+PYd
5606               pzi1=BETAZ*TRANSF+PZd
5607               if(ianti.eq.0)then
5608                  lbd=42
5609               else
5610                  lbd=-42
5611               endif
5612               if(idpert.eq.1.and.ipert1.eq.1.and.npertd.ge.1) then
5613 cccc  Perturbative production for idpert=1:
5614                  nnn=nnn+1
5615                  PPION(1,NNN,IRUN)=pxi1
5616                  PPION(2,NNN,IRUN)=pyi1
5617                  PPION(3,NNN,IRUN)=pzi1
5618                  EPION(NNN,IRUN)=xmd
5619                  LPION(NNN,IRUN)=lbd
5620                  RPION(1,NNN,IRUN)=R(1,I1)
5621                  RPION(2,NNN,IRUN)=R(2,I1)
5622                  RPION(3,NNN,IRUN)=R(3,I1)
5623 clin-5/2008 assign the perturbative probability:
5624                  dppion(NNN,IRUN)=sdprod/sig/float(npertd)
5625               elseif(idpert.eq.2.and.idloop.le.npertd) then
5626 clin-5/2008 For idpert=2, we produce NPERTD perturbative (anti)deuterons
5627 c     only when a regular (anti)deuteron+pi is produced in NN collisions.
5628 c     First save the info for the perturbative deuterons:
5629                  ppd(1,idloop)=pxi1
5630                  ppd(2,idloop)=pyi1
5631                  ppd(3,idloop)=pzi1
5632                  lbpd(idloop)=lbd
5633               else
5634 cccc  Regular production:
5635 c     For the regular pion: do LORENTZ-TRANSFORMATION:
5636                  E(i1)=xmm
5637                  E2piCM=SQRT(xmm**2+PXd**2+PYd**2+PZd**2)
5638                  P2piBETA=-PXd*BETAX-PYd*BETAY-PZd*BETAZ
5639                  TRANSF=GAMMA*(GAMMA*P2piBETA/(GAMMA+1.)+E2piCM)
5640                  pxi2=BETAX*TRANSF-PXd
5641                  pyi2=BETAY*TRANSF-PYd
5642                  pzi2=BETAZ*TRANSF-PZd
5643                  p(1,i1)=pxi2
5644                  p(2,i1)=pyi2
5645                  p(3,i1)=pzi2
5646 c     Remove regular pion to check the equivalence
5647 c     between the perturbative and regular deuteron results:
5648 c                 E(i1)=0.
5649 c
5650                  LB(I1)=lbm
5651                  PX1=P(1,I1)
5652                  PY1=P(2,I1)
5653                  PZ1=P(3,I1)
5654                  EM1=E(I1)
5655                  ID(I1)=2
5656                  ID1=ID(I1)
5657                  E1=SQRT(EM1**2+PX1**2+PY1**2+PZ1**2)
5658                  lb1=lb(i1)
5659 c     For the regular deuteron:
5660                  p(1,i2)=pxi1
5661                  p(2,i2)=pyi1
5662                  p(3,i2)=pzi1
5663                  lb(i2)=lbd
5664                  lb2=lb(i2)
5665                  E(i2)=xmd
5666                  EtI2=E(I2)
5667                  ID(I2)=2
5668 c     For idpert=2: create the perturbative deuterons:
5669                  if(idpert.eq.2.and.idloop.eq.ndloop) then
5670                     do ipertd=1,npertd
5671                        nnn=nnn+1
5672                        PPION(1,NNN,IRUN)=ppd(1,ipertd)
5673                        PPION(2,NNN,IRUN)=ppd(2,ipertd)
5674                        PPION(3,NNN,IRUN)=ppd(3,ipertd)
5675                        EPION(NNN,IRUN)=xmd
5676                        LPION(NNN,IRUN)=lbpd(ipertd)
5677                        RPION(1,NNN,IRUN)=R(1,I1)
5678                        RPION(2,NNN,IRUN)=R(2,I1)
5679                        RPION(3,NNN,IRUN)=R(3,I1)
5680 clin-5/2008 assign the perturbative probability:
5681                        dppion(NNN,IRUN)=1./float(npertd)
5682                     enddo
5683                  endif
5684               endif
5685            enddo
5686            IBLOCK=501
5687            go to 90005
5688 clin-5/2008 N+N->Deuteron+pi over
5689 * FOR THE NN-->KAON+X PROCESS, FIND MOMENTUM OF THE FINAL PARTICLES IN
5690 * THE NUCLEUS-NUCLEUS CMS.
5691 306     CONTINUE
5692 csp11/21/01 phi production
5693               if(XSK5/sigK.gt.RANART(NSEED))then
5694               pz1=p(3,i1)
5695               pz2=p(3,i2)
5696                 LB(I1) = 1 + int(2 * RANART(NSEED))
5697                 LB(I2) = 1 + int(2 * RANART(NSEED))
5698               nnn=nnn+1
5699                 LPION(NNN,IRUN)=29
5700                 EPION(NNN,IRUN)=APHI
5701                 iblock = 222
5702               GO TO 208
5703                ENDIF
5704 c
5705                  IBLOCK=9
5706                  if(ianti .eq. 1)iblock=-9
5707 c
5708               pz1=p(3,i1)
5709               pz2=p(3,i2)
5710 * DETERMINE THE CHARGE STATES OF PARTICLES IN THE FINAL STATE
5711               nnn=nnn+1
5712                 LPION(NNN,IRUN)=23
5713                 EPION(NNN,IRUN)=Aka
5714               if(srt.le.2.63)then
5715 * only lambda production is possible
5716 * (1.1)P+P-->p+L+kaon+
5717               ic=1
5718                 LB(I1) = 1 + int(2 * RANART(NSEED))
5719               LB(I2)=14
5720               GO TO 208
5721                 ENDIF
5722        if(srt.le.2.74.and.srt.gt.2.63)then
5723 * both Lambda and sigma production are possible
5724               if(XSK1/(XSK1+XSK2).gt.RANART(NSEED))then
5725 * lambda production
5726               ic=1
5727                 LB(I1) = 1 + int(2 * RANART(NSEED))
5728               LB(I2)=14
5729               else
5730 * sigma production
5731                 LB(I1) = 1 + int(2 * RANART(NSEED))
5732                 LB(I2) = 15 + int(3 * RANART(NSEED))
5733               ic=2
5734               endif
5735               GO TO 208
5736        endif
5737        if(srt.le.2.77.and.srt.gt.2.74)then
5738 * then pp-->Delta lamda kaon can happen
5739               if(xsk1/(xsk1+xsk2+xsk3).
5740      1          gt.RANART(NSEED))then
5741 * * (1.1)P+P-->p+L+kaon+
5742               ic=1
5743                 LB(I1) = 1 + int(2 * RANART(NSEED))
5744               LB(I2)=14
5745               go to 208
5746               else
5747               if(xsk2/(xsk2+xsk3).gt.RANART(NSEED))then
5748 * pp-->psk
5749               ic=2
5750                 LB(I1) = 1 + int(2 * RANART(NSEED))
5751                 LB(I2) = 15 + int(3 * RANART(NSEED))
5752               else
5753 * pp-->D+l+k
5754               ic=3
5755                 LB(I1) = 6 + int(4 * RANART(NSEED))
5756               lb(i2)=14
5757               endif
5758               GO TO 208
5759               endif
5760        endif
5761        if(srt.gt.2.77)then
5762 * all four channels are possible
5763               if(xsk1/(xsk1+xsk2+xsk3+xsk4).gt.RANART(NSEED))then
5764 * p lambda k production
5765               ic=1
5766                 LB(I1) = 1 + int(2 * RANART(NSEED))
5767               LB(I2)=14
5768               go to 208
5769        else
5770           if(xsk3/(xsk2+xsk3+xsk4).gt.RANART(NSEED))then
5771 * delta l K production
5772               ic=3
5773                 LB(I1) = 6 + int(4 * RANART(NSEED))
5774               lb(i2)=14
5775               go to 208
5776           else
5777               if(xsk2/(xsk2+xsk4).gt.RANART(NSEED))then
5778 * n sigma k production
5779                    LB(I1) = 1 + int(2 * RANART(NSEED))
5780                    LB(I2) = 15 + int(3 * RANART(NSEED))
5781               ic=2
5782               else
5783               ic=4
5784                 LB(I1) = 6 + int(4 * RANART(NSEED))
5785                 LB(I2) = 15 + int(3 * RANART(NSEED))
5786               endif
5787               go to 208
5788           endif
5789        endif
5790        endif
5791 208             continue
5792          if(ianti.eq.1 .and. lb(i1).ge.1 .and. lb(i2).ge.1)then
5793           lb(i1) = - lb(i1)
5794           lb(i2) = - lb(i2)
5795           if(LPION(NNN,IRUN) .eq. 23)LPION(NNN,IRUN)=21
5796          endif
5797 * KEEP ALL COORDINATES OF PARTICLE 2 FOR POSSIBLE PHASE SPACE CHANGE
5798            NTRY1=0
5799 127        CALL BBKAON(ic,SRT,PX3,PY3,PZ3,DM3,PX4,PY4,PZ4,DM4,
5800      &  PPX,PPY,PPZ,icou1)
5801        NTRY1=NTRY1+1
5802        if((icou1.lt.0).AND.(NTRY1.LE.20))GO TO 127
5803 c       if(icou1.lt.0)return
5804 * ROTATE THE MOMENTA OF PARTICLES IN THE CMS OF P1+P2
5805        CALL ROTATE(PX,PY,PZ,PX3,PY3,PZ3)
5806        CALL ROTATE(PX,PY,PZ,PX4,PY4,PZ4)
5807        CALL ROTATE(PX,PY,PZ,PPX,PPY,PPZ)
5808 * FIND THE MOMENTUM OF PARTICLES IN THE FINAL STATE IN THE NUCLEUS-
5809 * NUCLEUS CMS. FRAME
5810 * (1) for the necleon/delta
5811 *             LORENTZ-TRANSFORMATION INTO LAB FRAME FOR DELTA1
5812               E1CM    = SQRT (dm3**2 + PX3**2 + PY3**2 + PZ3**2)
5813               P1BETA  = PX3*BETAX + PY3*BETAY + PZ3*BETAZ
5814               TRANSF  = GAMMA * ( GAMMA * P1BETA / (GAMMA + 1) + E1CM )
5815               Pt1i1 = BETAX * TRANSF + PX3
5816               Pt2i1 = BETAY * TRANSF + PY3
5817               Pt3i1 = BETAZ * TRANSF + PZ3
5818              Eti1   = DM3
5819              lbi1=lb(i1)
5820 * (2) for the lambda/sigma
5821                 E2CM    = SQRT (dm4**2 + PX4**2 + PY4**2 + PZ4**2)
5822                 P2BETA  = PX4*BETAX+PY4*BETAY+PZ4*BETAZ
5823                 TRANSF  = GAMMA * (GAMMA*P2BETA / (GAMMA + 1.) + E2CM)
5824                 Pt1I2 = BETAX * TRANSF + PX4
5825                 Pt2I2 = BETAY * TRANSF + PY4
5826                 Pt3I2 = BETAZ * TRANSF + PZ4
5827               EtI2   = DM4
5828               lbi2=lb(i2)
5829 * GET the kaon'S MOMENTUM AND COORDINATES IN NUCLEUS-NUCLEUS CMS. FRAME
5830                 EPCM=SQRT(aka**2+PPX**2+PPY**2+PPZ**2)
5831                 PPBETA=PPX*BETAX+PPY*BETAY+PPZ*BETAZ
5832                 TRANSF=GAMMA*(GAMMA*PPBETA/(GAMMA+1.)+EPCM)
5833                 PPION(1,NNN,IRUN)=BETAX*TRANSF+PPX
5834                 PPION(2,NNN,IRUN)=BETAY*TRANSF+PPY
5835                 PPION(3,NNN,IRUN)=BETAZ*TRANSF+PPZ
5836 clin-5/2008
5837                 dppion(nnn,irun)=dpertp(i1)*dpertp(i2)
5838 clin-5/2008
5839 c2003        X01 = 1.0 - 2.0 * RANART(NSEED)
5840 c            Y01 = 1.0 - 2.0 * RANART(NSEED)
5841 c            Z01 = 1.0 - 2.0 * RANART(NSEED)
5842 c        IF ((X01*X01+Y01*Y01+Z01*Z01) .GT. 1.0) GOTO 2003
5843 c                RPION(1,NNN,IRUN)=R(1,I1)+0.5*x01
5844 c                RPION(2,NNN,IRUN)=R(2,I1)+0.5*y01
5845 c                RPION(3,NNN,IRUN)=R(3,I1)+0.5*z01
5846                 RPION(1,NNN,IRUN)=R(1,I1)
5847                 RPION(2,NNN,IRUN)=R(2,I1)
5848                 RPION(3,NNN,IRUN)=R(3,I1)
5849 c
5850 * assign the nucleon/delta and lambda/sigma to i1 or i2 to keep the
5851 * leadng particle behaviour
5852 C              if((pt1i1*px1+pt2i1*py1+pt3i1*pz1).gt.0)then
5853               p(1,i1)=pt1i1
5854               p(2,i1)=pt2i1
5855               p(3,i1)=pt3i1
5856               e(i1)=eti1
5857               lb(i1)=lbi1
5858               p(1,i2)=pt1i2
5859               p(2,i2)=pt2i2
5860               p(3,i2)=pt3i2
5861               e(i2)=eti2
5862               lb(i2)=lbi2
5863                 PX1     = P(1,I1)
5864                 PY1     = P(2,I1)
5865                 PZ1     = P(3,I1)
5866               EM1       = E(I1)
5867                 ID(I1)  = 2
5868                 ID(I2)  = 2
5869                 ID1     = ID(I1)
5870               go to 90005
5871 * FOR THE NN-->Delta+Delta+rho PROCESS, FIND MOMENTUM OF THE FINAL
5872 * PARTICLES IN THE NUCLEUS-NUCLEUS CMS.
5873 307     CONTINUE
5874            NTRY1=0
5875 125        CALL DDrho(SRT,ISEED,PX3,PY3,PZ3,DM3,PX4,PY4,PZ4,DM4,
5876      &  PPX,PPY,PPZ,amrho,icou1)
5877        NTRY1=NTRY1+1
5878        if((icou1.lt.0).AND.(NTRY1.LE.20))GO TO 125
5879 C       if(icou1.lt.0)return
5880 * ROTATE THE MOMENTA OF PARTICLES IN THE CMS OF P1+P2
5881        CALL ROTATE(PX,PY,PZ,PX3,PY3,PZ3)
5882        CALL ROTATE(PX,PY,PZ,PX4,PY4,PZ4)
5883        CALL ROTATE(PX,PY,PZ,PPX,PPY,PPZ)
5884                 NNN=NNN+1
5885               arho=amrho
5886 * DETERMINE THE CHARGE STATES OF PARTICLES IN THE FINAL STATE
5887 * (1) FOR P+P
5888               XDIR=RANART(NSEED)
5889                 IF(LB(I1)*LB(I2).EQ.1)THEN
5890                 IF(XDIR.Le.0.2)then
5891 * (1.1)P+P-->D+++D0+rho(0)
5892                 LPION(NNN,IRUN)=26
5893                 EPION(NNN,IRUN)=Arho
5894               LB(I1)=9
5895               LB(I2)=7
5896        GO TO 2051
5897                 ENDIF
5898 * (1.2)P+P -->D++D+rho(0)
5899                 IF((XDIR.LE.0.4).AND.(XDIR.GT.0.2))THEN
5900                 LPION(NNN,IRUN)=26
5901                 EPION(NNN,IRUN)=Arho
5902                 LB(I1)=8
5903                 LB(I2)=8
5904        GO TO 2051
5905               ENDIF
5906 * (1.3)P+P-->D+++D+arho(-)
5907                 IF((XDIR.LE.0.6).AND.(XDIR.GT.0.4))THEN
5908                 LPION(NNN,IRUN)=25
5909                 EPION(NNN,IRUN)=Arho
5910                 LB(I1)=9
5911                 LB(I2)=8
5912        GO TO 2051
5913               ENDIF
5914                 IF((XDIR.LE.0.8).AND.(XDIR.GT.0.6))THEN
5915                 LPION(NNN,IRUN)=27
5916                 EPION(NNN,IRUN)=Arho
5917                 LB(I1)=9
5918                 LB(I2)=6
5919        GO TO 2051
5920               ENDIF
5921                 IF(XDIR.GT.0.8)THEN
5922                 LPION(NNN,IRUN)=27
5923                 EPION(NNN,IRUN)=Arho
5924                 LB(I1)=7
5925                 LB(I2)=8
5926        GO TO 2051
5927               ENDIF
5928                ENDIF
5929 * (2)FOR N+N
5930                 IF(iabs(LB(I1)).EQ.2.AND.iabs(LB(I2)).EQ.2)THEN
5931                 IF(XDIR.Le.0.2)then
5932 * (2.1)N+N-->D++D-+rho(0)
5933                 LPION(NNN,IRUN)=26
5934                 EPION(NNN,IRUN)=Arho
5935               LB(I1)=6
5936               LB(I2)=7
5937        GO TO 2051
5938                 ENDIF
5939 * (2.2)N+N -->D+++D-+rho(-)
5940                 IF((XDIR.LE.0.4).AND.(XDIR.GT.0.2))THEN
5941                 LPION(NNN,IRUN)=25
5942                 EPION(NNN,IRUN)=Arho
5943                 LB(I1)=6
5944                 LB(I2)=9
5945        GO TO 2051
5946               ENDIF
5947 * (2.3)P+P-->D0+D-+rho(+)
5948                 IF((XDIR.GT.0.4).AND.(XDIR.LE.0.6))THEN
5949                 LPION(NNN,IRUN)=27
5950                 EPION(NNN,IRUN)=Arho
5951                 LB(I1)=9
5952                 LB(I2)=8
5953        GO TO 2051
5954               ENDIF
5955 * (2.4)P+P-->D0+D0+rho(0)
5956                 IF((XDIR.GT.0.6).AND.(XDIR.LE.0.8))THEN
5957                 LPION(NNN,IRUN)=26
5958                 EPION(NNN,IRUN)=Arho
5959                 LB(I1)=7
5960                 LB(I2)=7
5961        GO TO 2051
5962               ENDIF
5963 * (2.5)P+P-->D0+D++rho(-)
5964                 IF(XDIR.GT.0.8)THEN
5965                 LPION(NNN,IRUN)=25
5966                 EPION(NNN,IRUN)=Arho
5967                 LB(I1)=7
5968                 LB(I2)=8
5969        GO TO 2051
5970               ENDIF
5971               ENDIF
5972 * (3)FOR N+P
5973                 IF(LB(I1)*LB(I2).EQ.2)THEN
5974                 IF(XDIR.Le.0.17)then
5975 * (3.1)N+P-->D+++D-+rho(0)
5976                 LPION(NNN,IRUN)=25
5977                 EPION(NNN,IRUN)=Arho
5978               LB(I1)=6
5979               LB(I2)=9
5980        GO TO 2051
5981                 ENDIF
5982 * (3.2)N+P -->D+++D0+rho(-)
5983                 IF((XDIR.LE.0.34).AND.(XDIR.GT.0.17))THEN
5984                 LPION(NNN,IRUN)=25
5985                 EPION(NNN,IRUN)=Arho
5986                 LB(I1)=7
5987                 LB(I2)=9
5988        GO TO 2051
5989               ENDIF
5990 * (3.3)N+P-->D++D-+rho(+)
5991                 IF((XDIR.GT.0.34).AND.(XDIR.LE.0.51))THEN
5992                 LPION(NNN,IRUN)=27
5993                 EPION(NNN,IRUN)=Arho
5994                 LB(I1)=7
5995                 LB(I2)=8
5996        GO TO 2051
5997               ENDIF
5998 * (3.4)N+P-->D++D++rho(-)
5999                 IF((XDIR.GT.0.51).AND.(XDIR.LE.0.68))THEN
6000                 LPION(NNN,IRUN)=25
6001                 EPION(NNN,IRUN)=Arho
6002                 LB(I1)=8
6003                 LB(I2)=8
6004        GO TO 2051
6005               ENDIF
6006 * (3.5)N+P-->D0+D++rho(0)
6007                 IF((XDIR.GT.0.68).AND.(XDIR.LE.0.85))THEN
6008                 LPION(NNN,IRUN)=26
6009                 EPION(NNN,IRUN)=Arho
6010                 LB(I1)=7
6011                 LB(I2)=8
6012        GO TO 2051
6013               ENDIF
6014 * (3.6)N+P-->D0+D0+rho(+)
6015                 IF(XDIR.GT.0.85)THEN
6016                 LPION(NNN,IRUN)=27
6017                 EPION(NNN,IRUN)=Arho
6018                 LB(I1)=7
6019                 LB(I2)=7
6020               ENDIF
6021                 ENDIF
6022 * FIND THE MOMENTUM OF PARTICLES IN THE FINAL STATE IN THE NUCLEUS-
6023 * NUCLEUS CMS. FRAME
6024 *             LORENTZ-TRANSFORMATION INTO LAB FRAME FOR DELTA1
6025 2051          E1CM    = SQRT (dm3**2 + PX3**2 + PY3**2 + PZ3**2)
6026               P1BETA  = PX3*BETAX + PY3*BETAY + PZ3*BETAZ
6027               TRANSF  = GAMMA * ( GAMMA * P1BETA / (GAMMA + 1) + E1CM )
6028               Pt1i1 = BETAX * TRANSF + PX3
6029               Pt2i1 = BETAY * TRANSF + PY3
6030               Pt3i1 = BETAZ * TRANSF + PZ3
6031              Eti1   = DM3
6032 c
6033              if(ianti.eq.1 .and. lb(i1).ge.1 .and. lb(i2).ge.1)then
6034                lb(i1) = -lb(i1)
6035                lb(i2) = -lb(i2)
6036                 if(LPION(NNN,IRUN) .eq. 25)then
6037                   LPION(NNN,IRUN)=27
6038                 elseif(LPION(NNN,IRUN) .eq. 27)then
6039                   LPION(NNN,IRUN)=25
6040                 endif
6041                endif
6042 c
6043              lb1=lb(i1)
6044 * FOR DELTA2
6045                 E2CM    = SQRT (dm4**2 + PX4**2 + PY4**2 + PZ4**2)
6046                 P2BETA  = PX4*BETAX+PY4*BETAY+PZ4*BETAZ
6047                 TRANSF  = GAMMA * (GAMMA*P2BETA / (GAMMA + 1.) + E2CM)
6048                 Pt1I2 = BETAX * TRANSF + PX4
6049                 Pt2I2 = BETAY * TRANSF + PY4
6050                 Pt3I2 = BETAZ * TRANSF + PZ4
6051               EtI2   = DM4
6052               lb2=lb(i2)
6053 * assign delta1 and delta2 to i1 or i2 to keep the leadng particle
6054 * behaviour
6055 C              if((pt1i1*px1+pt2i1*py1+pt3i1*pz1).gt.0)then
6056               p(1,i1)=pt1i1
6057               p(2,i1)=pt2i1
6058               p(3,i1)=pt3i1
6059               e(i1)=eti1
6060               lb(i1)=lb1
6061               p(1,i2)=pt1i2
6062               p(2,i2)=pt2i2
6063               p(3,i2)=pt3i2
6064               e(i2)=eti2
6065               lb(i2)=lb2
6066                 PX1     = P(1,I1)
6067                 PY1     = P(2,I1)
6068                 PZ1     = P(3,I1)
6069               EM1       = E(I1)
6070                 ID(I1)  = 2
6071                 ID(I2)  = 2
6072                 ID1     = ID(I1)
6073                 IBLOCK=44
6074 * GET rho'S MOMENTUM AND COORDINATES IN NUCLEUS-NUCLEUS CMS. FRAME
6075                 EPCM=SQRT(EPION(NNN,IRUN)**2+PPX**2+PPY**2+PPZ**2)
6076                 PPBETA=PPX*BETAX+PPY*BETAY+PPZ*BETAZ
6077                 TRANSF=GAMMA*(GAMMA*PPBETA/(GAMMA+1.)+EPCM)
6078                 PPION(1,NNN,IRUN)=BETAX*TRANSF+PPX
6079                 PPION(2,NNN,IRUN)=BETAY*TRANSF+PPY
6080                 PPION(3,NNN,IRUN)=BETAZ*TRANSF+PPZ
6081 clin-5/2008:
6082                 dppion(nnn,irun)=dpertp(i1)*dpertp(i2)
6083 clin-5/2008:
6084 c2004        X01 = 1.0 - 2.0 * RANART(NSEED)
6085 c            Y01 = 1.0 - 2.0 * RANART(NSEED)
6086 c            Z01 = 1.0 - 2.0 * RANART(NSEED)
6087 c        IF ((X01*X01+Y01*Y01+Z01*Z01) .GT. 1.0) GOTO 2004
6088 c                RPION(1,NNN,IRUN)=R(1,I1)+0.5*x01
6089 c                RPION(2,NNN,IRUN)=R(2,I1)+0.5*y01
6090 c                RPION(3,NNN,IRUN)=R(3,I1)+0.5*z01
6091                 RPION(1,NNN,IRUN)=R(1,I1)
6092                 RPION(2,NNN,IRUN)=R(2,I1)
6093                 RPION(3,NNN,IRUN)=R(3,I1)
6094 c
6095               go to 90005
6096 * FOR THE NN-->N+N+rho PROCESS, FIND MOMENTUM OF THE FINAL
6097 * PARTICLES IN THE NUCLEUS-NUCLEUS CMS.
6098 308     CONTINUE
6099            NTRY1=0
6100 126        CALL pprho(SRT,ISEED,PX3,PY3,PZ3,DM3,PX4,PY4,PZ4,DM4,
6101      &  PPX,PPY,PPZ,amrho,icou1)
6102        NTRY1=NTRY1+1
6103        if((icou1.lt.0).AND.(NTRY1.LE.20))GO TO 126
6104 C       if(icou1.lt.0)return
6105 * ROTATE THE MOMENTA OF PARTICLES IN THE CMS OF P1+P2
6106        CALL ROTATE(PX,PY,PZ,PX3,PY3,PZ3)
6107        CALL ROTATE(PX,PY,PZ,PX4,PY4,PZ4)
6108        CALL ROTATE(PX,PY,PZ,PPX,PPY,PPZ)
6109                 NNN=NNN+1
6110               arho=amrho
6111 * DETERMINE THE CHARGE STATES OF PARTICLES IN THE FINAL STATE
6112 * (1) FOR P+P
6113               XDIR=RANART(NSEED)
6114                 IF(LB(I1)*LB(I2).EQ.1)THEN
6115                 IF(XDIR.Le.0.5)then
6116 * (1.1)P+P-->P+P+rho(0)
6117                 LPION(NNN,IRUN)=26
6118                 EPION(NNN,IRUN)=Arho
6119               LB(I1)=1
6120               LB(I2)=1
6121        GO TO 2052
6122                 Else
6123 * (1.2)P+P -->p+n+rho(+)
6124                 LPION(NNN,IRUN)=27
6125                 EPION(NNN,IRUN)=Arho
6126                 LB(I1)=1
6127                 LB(I2)=2
6128        GO TO 2052
6129               ENDIF
6130               endif
6131 * (2)FOR N+N
6132                 IF(iabs(LB(I1)).EQ.2.AND.iabs(LB(I2)).EQ.2)THEN
6133                 IF(XDIR.Le.0.5)then
6134 * (2.1)N+N-->N+N+rho(0)
6135                 LPION(NNN,IRUN)=26
6136                 EPION(NNN,IRUN)=Arho
6137               LB(I1)=2
6138               LB(I2)=2
6139        GO TO 2052
6140                 Else
6141 * (2.2)N+N -->N+P+rho(-)
6142                 LPION(NNN,IRUN)=25
6143                 EPION(NNN,IRUN)=Arho
6144                 LB(I1)=1
6145                 LB(I2)=2
6146        GO TO 2052
6147               ENDIF
6148               endif
6149 * (3)FOR N+P
6150                 IF(LB(I1)*LB(I2).EQ.2)THEN
6151                 IF(XDIR.Le.0.33)then
6152 * (3.1)N+P-->N+P+rho(0)
6153                 LPION(NNN,IRUN)=26
6154                 EPION(NNN,IRUN)=Arho
6155               LB(I1)=1
6156               LB(I2)=2
6157        GO TO 2052
6158 * (3.2)N+P -->P+P+rho(-)
6159                 else IF((XDIR.LE.0.67).AND.(XDIR.GT.0.34))THEN
6160                 LPION(NNN,IRUN)=25
6161                 EPION(NNN,IRUN)=Arho
6162                 LB(I1)=1
6163                 LB(I2)=1
6164        GO TO 2052
6165               Else
6166 * (3.3)N+P-->N+N+rho(+)
6167                 LPION(NNN,IRUN)=27
6168                 EPION(NNN,IRUN)=Arho
6169                 LB(I1)=2
6170                 LB(I2)=2
6171        GO TO 2052
6172               ENDIF
6173               endif
6174 * FIND THE MOMENTUM OF PARTICLES IN THE FINAL STATE IN THE NUCLEUS-
6175 * NUCLEUS CMS. FRAME
6176 *             LORENTZ-TRANSFORMATION INTO LAB FRAME FOR DELTA1
6177 2052          E1CM    = SQRT (dm3**2 + PX3**2 + PY3**2 + PZ3**2)
6178               P1BETA  = PX3*BETAX + PY3*BETAY + PZ3*BETAZ
6179               TRANSF  = GAMMA * ( GAMMA * P1BETA / (GAMMA + 1) + E1CM )
6180               Pt1i1 = BETAX * TRANSF + PX3
6181               Pt2i1 = BETAY * TRANSF + PY3
6182               Pt3i1 = BETAZ * TRANSF + PZ3
6183              Eti1   = DM3
6184 c
6185               if(ianti.eq.1 .and. lb(i1).ge.1 .and. lb(i2).ge.1)then
6186                lb(i1) = -lb(i1)
6187                lb(i2) = -lb(i2)
6188                 if(LPION(NNN,IRUN) .eq. 25)then
6189                   LPION(NNN,IRUN)=27
6190                 elseif(LPION(NNN,IRUN) .eq. 27)then
6191                   LPION(NNN,IRUN)=25
6192                 endif
6193                endif
6194 c
6195              lb1=lb(i1)
6196 * FOR p2
6197                 E2CM    = SQRT (dm4**2 + PX4**2 + PY4**2 + PZ4**2)
6198                 P2BETA  = PX4*BETAX+PY4*BETAY+PZ4*BETAZ
6199                 TRANSF  = GAMMA * (GAMMA*P2BETA / (GAMMA + 1.) + E2CM)
6200                 Pt1I2 = BETAX * TRANSF + PX4
6201                 Pt2I2 = BETAY * TRANSF + PY4
6202                 Pt3I2 = BETAZ * TRANSF + PZ4
6203               EtI2   = DM4
6204               lb2=lb(i2)
6205 * assign p1 and p2 to i1 or i2 to keep the leadng particle
6206 * behaviour
6207 C              if((pt1i1*px1+pt2i1*py1+pt3i1*pz1).gt.0)then
6208               p(1,i1)=pt1i1
6209               p(2,i1)=pt2i1
6210               p(3,i1)=pt3i1
6211               e(i1)=eti1
6212               lb(i1)=lb1
6213               p(1,i2)=pt1i2
6214               p(2,i2)=pt2i2
6215               p(3,i2)=pt3i2
6216               e(i2)=eti2
6217               lb(i2)=lb2
6218                 PX1     = P(1,I1)
6219                 PY1     = P(2,I1)
6220                 PZ1     = P(3,I1)
6221               EM1       = E(I1)
6222                 ID(I1)  = 2
6223                 ID(I2)  = 2
6224                 ID1     = ID(I1)
6225                 IBLOCK=45
6226 * GET rho'S MOMENTUM AND COORDINATES IN NUCLEUS-NUCLEUS CMS. FRAME
6227                 EPCM=SQRT(EPION(NNN,IRUN)**2+PPX**2+PPY**2+PPZ**2)
6228                 PPBETA=PPX*BETAX+PPY*BETAY+PPZ*BETAZ
6229                 TRANSF=GAMMA*(GAMMA*PPBETA/(GAMMA+1.)+EPCM)
6230                 PPION(1,NNN,IRUN)=BETAX*TRANSF+PPX
6231                 PPION(2,NNN,IRUN)=BETAY*TRANSF+PPY
6232                 PPION(3,NNN,IRUN)=BETAZ*TRANSF+PPZ
6233 clin-5/2008:
6234                 dppion(nnn,irun)=dpertp(i1)*dpertp(i2)
6235 clin-5/2008:
6236 c2005        X01 = 1.0 - 2.0 * RANART(NSEED)
6237 c            Y01 = 1.0 - 2.0 * RANART(NSEED)
6238 c            Z01 = 1.0 - 2.0 * RANART(NSEED)
6239 c        IF ((X01*X01+Y01*Y01+Z01*Z01) .GT. 1.0) GOTO 2005
6240 c                RPION(1,NNN,IRUN)=R(1,I1)+0.5*x01
6241 c                RPION(2,NNN,IRUN)=R(2,I1)+0.5*y01
6242 c                RPION(3,NNN,IRUN)=R(3,I1)+0.5*z01
6243                 RPION(1,NNN,IRUN)=R(1,I1)
6244                 RPION(2,NNN,IRUN)=R(2,I1)
6245                 RPION(3,NNN,IRUN)=R(3,I1)
6246 c
6247               go to 90005
6248 * FOR THE NN-->p+p+omega PROCESS, FIND MOMENTUM OF THE FINAL
6249 * PARTICLES IN THE NUCLEUS-NUCLEUS CMS.
6250 309     CONTINUE
6251            NTRY1=0
6252 138        CALL ppomga(SRT,ISEED,PX3,PY3,PZ3,DM3,PX4,PY4,PZ4,DM4,
6253      &  PPX,PPY,PPZ,icou1)
6254        NTRY1=NTRY1+1
6255        if((icou1.lt.0).AND.(NTRY1.LE.20))GO TO 138
6256 C       if(icou1.lt.0)return
6257 * ROTATE THE MOMENTA OF PARTICLES IN THE CMS OF P1+P2
6258        CALL ROTATE(PX,PY,PZ,PX3,PY3,PZ3)
6259        CALL ROTATE(PX,PY,PZ,PX4,PY4,PZ4)
6260        CALL ROTATE(PX,PY,PZ,PPX,PPY,PPZ)
6261                 NNN=NNN+1
6262               aomega=0.782
6263 * DETERMINE THE CHARGE STATES OF PARTICLES IN THE FINAL STATE
6264 * (1) FOR P+P
6265                 IF(LB(I1)*LB(I2).EQ.1)THEN
6266 * (1.1)P+P-->P+P+omega(0)
6267                 LPION(NNN,IRUN)=28
6268                 EPION(NNN,IRUN)=Aomega
6269               LB(I1)=1
6270               LB(I2)=1
6271        GO TO 2053
6272                 ENDIF
6273 * (2)FOR N+N
6274                 IF(iabs(LB(I1)).EQ.2.AND.iabs(LB(I2)).EQ.2)THEN
6275 * (2.1)N+N-->N+N+omega(0)
6276                 LPION(NNN,IRUN)=28
6277                 EPION(NNN,IRUN)=Aomega
6278               LB(I1)=2
6279               LB(I2)=2
6280        GO TO 2053
6281                 ENDIF
6282 * (3)FOR N+P
6283                 IF(LB(I1)*LB(I2).EQ.2)THEN
6284 * (3.1)N+P-->N+P+omega(0)
6285                 LPION(NNN,IRUN)=28
6286                 EPION(NNN,IRUN)=Aomega
6287               LB(I1)=1
6288               LB(I2)=2
6289        GO TO 2053
6290                 ENDIF
6291 * FIND THE MOMENTUM OF PARTICLES IN THE FINAL STATE IN THE NUCLEUS-
6292 * NUCLEUS CMS. FRAME
6293 *             LORENTZ-TRANSFORMATION INTO LAB FRAME FOR DELTA1
6294 2053          E1CM    = SQRT (dm3**2 + PX3**2 + PY3**2 + PZ3**2)
6295               P1BETA  = PX3*BETAX + PY3*BETAY + PZ3*BETAZ
6296               TRANSF  = GAMMA * ( GAMMA * P1BETA / (GAMMA + 1) + E1CM )
6297               Pt1i1 = BETAX * TRANSF + PX3
6298               Pt2i1 = BETAY * TRANSF + PY3
6299               Pt3i1 = BETAZ * TRANSF + PZ3
6300              Eti1   = DM3
6301               if(ianti.eq.1 .and. lb(i1).ge.1 .and. lb(i2).ge.1)then
6302                lb(i1) = -lb(i1)
6303                lb(i2) = -lb(i2)
6304                endif
6305              lb1=lb(i1)
6306 * FOR DELTA2
6307                 E2CM    = SQRT (dm4**2 + PX4**2 + PY4**2 + PZ4**2)
6308                 P2BETA  = PX4*BETAX+PY4*BETAY+PZ4*BETAZ
6309                 TRANSF  = GAMMA * (GAMMA*P2BETA / (GAMMA + 1.) + E2CM)
6310                 Pt1I2 = BETAX * TRANSF + PX4
6311                 Pt2I2 = BETAY * TRANSF + PY4
6312                 Pt3I2 = BETAZ * TRANSF + PZ4
6313               EtI2   = DM4
6314                 lb2=lb(i2)
6315 * assign delta1 and delta2 to i1 or i2 to keep the leadng particle
6316 * behaviour
6317 C              if((pt1i1*px1+pt2i1*py1+pt3i1*pz1).gt.0)then
6318               p(1,i1)=pt1i1
6319               p(2,i1)=pt2i1
6320               p(3,i1)=pt3i1
6321               e(i1)=eti1
6322               lb(i1)=lb1
6323               p(1,i2)=pt1i2
6324               p(2,i2)=pt2i2
6325               p(3,i2)=pt3i2
6326               e(i2)=eti2
6327               lb(i2)=lb2
6328                 PX1     = P(1,I1)
6329                 PY1     = P(2,I1)
6330                 PZ1     = P(3,I1)
6331               EM1       = E(I1)
6332                 ID(I1)  = 2
6333                 ID(I2)  = 2
6334                 ID1     = ID(I1)
6335                 IBLOCK=46
6336 * GET omega'S MOMENTUM AND COORDINATES IN NUCLEUS-NUCLEUS CMS. FRAME
6337                 EPCM=SQRT(EPION(NNN,IRUN)**2+PPX**2+PPY**2+PPZ**2)
6338                 PPBETA=PPX*BETAX+PPY*BETAY+PPZ*BETAZ
6339                 TRANSF=GAMMA*(GAMMA*PPBETA/(GAMMA+1.)+EPCM)
6340                 PPION(1,NNN,IRUN)=BETAX*TRANSF+PPX
6341                 PPION(2,NNN,IRUN)=BETAY*TRANSF+PPY
6342                 PPION(3,NNN,IRUN)=BETAZ*TRANSF+PPZ
6343 clin-5/2008:
6344                 dppion(nnn,irun)=dpertp(i1)*dpertp(i2)
6345 clin-5/2008:
6346 c2006        X01 = 1.0 - 2.0 * RANART(NSEED)
6347 c            Y01 = 1.0 - 2.0 * RANART(NSEED)
6348 c            Z01 = 1.0 - 2.0 * RANART(NSEED)
6349 c        IF ((X01*X01+Y01*Y01+Z01*Z01) .GT. 1.0) GOTO 2006
6350 c                RPION(1,NNN,IRUN)=R(1,I1)+0.5*x01
6351 c                RPION(2,NNN,IRUN)=R(2,I1)+0.5*y01
6352 c                RPION(3,NNN,IRUN)=R(3,I1)+0.5*z01
6353                     RPION(1,NNN,IRUN)=R(1,I1)
6354                     RPION(2,NNN,IRUN)=R(2,I1)
6355                     RPION(3,NNN,IRUN)=R(3,I1)
6356 c
6357               go to 90005
6358 * change phase space density FOR NUCLEONS AFTER THE PROCESS
6359
6360 clin-10/25/02-comment out following, since there is no path to it:
6361 clin-8/16/02 used before set
6362 c     IX1,IY1,IZ1,IPX1,IPY1,IPZ1, IX2,IY2,IZ2,IPX2,IPY2,IPZ2:
6363 c                if ((abs(ix1).le.mx) .and. (abs(iy1).le.my) .and.
6364 c     &              (abs(iz1).le.mz)) then
6365 c                  ipx1p = nint(p(1,i1)/dpx)
6366 c                  ipy1p = nint(p(2,i1)/dpy)
6367 c                  ipz1p = nint(p(3,i1)/dpz)
6368 c                  if ((ipx1p.ne.ipx1) .or. (ipy1p.ne.ipy1) .or.
6369 c     &                (ipz1p.ne.ipz1)) then
6370 c                    if ((abs(ipx1).le.mpx) .and. (abs(ipy1).le.my)
6371 c     &                .and. (ipz1.ge.-mpz) .and. (ipz1.le.mpzp))
6372 c     &                f(ix1,iy1,iz1,ipx1,ipy1,ipz1) =
6373 c     &                f(ix1,iy1,iz1,ipx1,ipy1,ipz1) - 1.
6374 c                    if ((abs(ipx1p).le.mpx) .and. (abs(ipy1p).le.my)
6375 c     &                .and. (ipz1p.ge.-mpz).and. (ipz1p.le.mpzp))
6376 c     &                f(ix1,iy1,iz1,ipx1p,ipy1p,ipz1p) =
6377 c     &                f(ix1,iy1,iz1,ipx1p,ipy1p,ipz1p) + 1.
6378 c                  end if
6379 c                end if
6380 c                if ((abs(ix2).le.mx) .and. (abs(iy2).le.my) .and.
6381 c     &              (abs(iz2).le.mz)) then
6382 c                  ipx2p = nint(p(1,i2)/dpx)
6383 c                  ipy2p = nint(p(2,i2)/dpy)
6384 c                  ipz2p = nint(p(3,i2)/dpz)
6385 c                  if ((ipx2p.ne.ipx2) .or. (ipy2p.ne.ipy2) .or.
6386 c     &                (ipz2p.ne.ipz2)) then
6387 c                    if ((abs(ipx2).le.mpx) .and. (abs(ipy2).le.my)
6388 c     &                .and. (ipz2.ge.-mpz) .and. (ipz2.le.mpzp))
6389 c     &                f(ix2,iy2,iz2,ipx2,ipy2,ipz2) =
6390 c     &                f(ix2,iy2,iz2,ipx2,ipy2,ipz2) - 1.
6391 c                    if ((abs(ipx2p).le.mpx) .and. (abs(ipy2p).le.my)
6392 c     &                .and. (ipz2p.ge.-mpz) .and. (ipz2p.le.mpzp))
6393 c     &                f(ix2,iy2,iz2,ipx2p,ipy2p,ipz2p) =
6394 c     &                f(ix2,iy2,iz2,ipx2p,ipy2p,ipz2p) + 1.
6395 c                  end if
6396 c                end if
6397 clin-10/25/02-end
6398
6399 90005       continue
6400        RETURN
6401 *-----------------------------------------------------------------------
6402 *COM: SET THE NEW MOMENTUM COORDINATES
6403 107     IF(PX .EQ. 0.0 .AND. PY .EQ. 0.0) THEN
6404         T2 = 0.0
6405       ELSE
6406         T2=ATAN2(PY,PX)
6407       END IF
6408       S1   = 1.0 - C1**2
6409        IF(S1.LE.0)S1=0
6410        S1=SQRT(S1)
6411       S2  =  SQRT( 1.0 - C2**2 )
6412       CT1  = COS(T1)
6413       ST1  = SIN(T1)
6414       CT2  = COS(T2)
6415       ST2  = SIN(T2)
6416       PZ   = PR * ( C1*C2 - S1*S2*CT1 )
6417       SS   = C2 * S1 * CT1  +  S2 * C1
6418       PX   = PR * ( SS*CT2 - S1*ST1*ST2 )
6419       PY   = PR * ( SS*ST2 + S1*ST1*CT2 )
6420       RETURN
6421       END
6422 clin-5/2008 CRNN over
6423
6424 **********************************
6425 **********************************
6426 *                                                                      *
6427 *                                                                      *
6428 c
6429       SUBROUTINE CRPP(PX,PY,PZ,SRT,I1,I2,IBLOCK,
6430      &ppel,ppin,spprho,ipp)
6431 *     PURPOSE:                                                         *
6432 *             DEALING WITH PION-PION COLLISIONS                        *
6433 *     NOTE   :                                                         *
6434 *           VALID ONLY FOR PION-PION-DISTANCES LESS THAN 2.5 FM        *
6435 *     QUANTITIES:                                                 *
6436 *           PX,PY,PZ - MOMENTUM COORDINATES OF ONE PARTICLE IN CM FRAME*
6437 *           SRT      - SQRT OF S                                       *
6438 *           IBLOCK   - THE INFORMATION BACK                            *
6439 *                     6-> Meson+Meson elastic
6440 *                     66-> Meson+meson-->K+K-
6441 **********************************
6442       PARAMETER (MAXSTR=150001,MAXR=1,AMN=0.939457,
6443      1     AMP=0.93828,AP1=0.13496,
6444      2 AP2=0.13957,AM0=1.232,PI=3.1415926,CUTOFF=1.8966,AVMASS=0.9383)
6445       PARAMETER      (AKA=0.498,aks=0.895)
6446       parameter     (MX=4,MY=4,MZ=8,MPX=4,MPY=4,mpz=10,mpzp=10)
6447       COMMON /AA/ R(3,MAXSTR)
6448 cc      SAVE /AA/
6449       COMMON /BB/ P(3,MAXSTR)
6450 cc      SAVE /BB/
6451       COMMON /CC/ E(MAXSTR)
6452 cc      SAVE /CC/
6453       COMMON /EE/ ID(MAXSTR),LB(MAXSTR)
6454 cc      SAVE /EE/
6455       common/input1/ MASSPR,MASSTA,ISEED,IAVOID,DT
6456 cc      SAVE /input1/
6457       common/ppb1/ene,factr2(6),fsum,ppinnb,s,wtot
6458 cc      SAVE /ppb1/
6459       common/ppmm/pprr,ppee,pppe,rpre,xopoe,rree
6460 cc      SAVE /ppmm/
6461       COMMON/RNDF77/NSEED
6462 cc      SAVE /RNDF77/
6463       SAVE
6464
6465       lb1i=lb(i1)
6466       lb2i=lb(i2)
6467
6468        PX0=PX
6469        PY0=PY
6470        PZ0=PZ
6471         iblock=1
6472 *-----------------------------------------------------------------------
6473 * check Meson+Meson inelastic collisions
6474 clin-9/28/00
6475 c        if((srt.gt.1.).and.(ppin/(ppin+ppel).gt.RANART(NSEED)))then
6476 c        iblock=66
6477 c        e(i1)=0.498
6478 c        e(i2)=0.498
6479 c        lb(i1)=21
6480 c        lb(i2)=23
6481 c        go to 10
6482 clin-11/07/00
6483 c        if(srt.gt.1.and.(ppin/(ppin+ppel)).gt.RANART(NSEED)) then
6484 clin-4/03/02
6485         if(srt.gt.(2*aka).and.(ppin/(ppin+ppel)).gt.RANART(NSEED)) then
6486 c        if(ppin/(ppin+ppel).gt.RANART(NSEED)) then
6487 clin-10/08/00
6488
6489            ranpi=RANART(NSEED)
6490            if((pprr/ppin).ge.ranpi) then
6491
6492 c     1) pi pi <-> rho rho:
6493               call pi2ro2(i1,i2,lbb1,lbb2,ei1,ei2,iblock,iseed)
6494
6495 clin-4/03/02 eta equilibration:
6496            elseif((pprr+ppee)/ppin.ge.ranpi) then
6497 c     4) pi pi <-> eta eta:
6498               call pi2et2(i1,i2,lbb1,lbb2,ei1,ei2,iblock,iseed)
6499            elseif(((pprr+ppee+pppe)/ppin).ge.ranpi) then
6500 c     5) pi pi <-> pi eta:
6501               call pi3eta(i1,i2,lbb1,lbb2,ei1,ei2,iblock,iseed)
6502            elseif(((pprr+ppee+pppe+rpre)/ppin).ge.ranpi) then
6503 c     6) rho pi <-> pi eta:
6504               call rpiret(i1,i2,lbb1,lbb2,ei1,ei2,iblock,iseed)
6505            elseif(((pprr+ppee+pppe+rpre+xopoe)/ppin).ge.ranpi) then
6506 c     7) omega pi <-> omega eta:
6507               call opioet(i1,i2,lbb1,lbb2,ei1,ei2,iblock,iseed)
6508            elseif(((pprr+ppee+pppe+rpre+xopoe+rree)
6509      1             /ppin).ge.ranpi) then
6510 c     8) rho rho <-> eta eta:
6511               call ro2et2(i1,i2,lbb1,lbb2,ei1,ei2,iblock,iseed)
6512 clin-4/03/02-end
6513
6514 c     2) BBbar production:
6515            elseif(((pprr+ppee+pppe+rpre+xopoe+rree+ppinnb)/ppin)
6516      1             .ge.ranpi) then
6517
6518               call bbarfs(lbb1,lbb2,ei1,ei2,iblock,iseed)
6519 c     3) KKbar production:
6520            else
6521               iblock=66
6522               ei1=aka
6523               ei2=aka
6524               lbb1=21
6525               lbb2=23
6526 clin-11/07/00 pi rho -> K* Kbar and K*bar K productions:
6527               lb1=lb(i1)
6528               lb2=lb(i2)
6529 clin-2/13/03 include omega the same as rho, eta the same as pi:
6530 c        if(((lb1.ge.3.and.lb1.le.5).and.(lb2.ge.25.and.lb2.le.27))
6531 c     1  .or.((lb2.ge.3.and.lb2.le.5).and.(lb1.ge.25.and.lb1.le.27)))
6532         if( ( (lb1.eq.0.or.(lb1.ge.3.and.lb1.le.5))
6533      1       .and.(lb2.ge.25.and.lb2.le.28))
6534      2       .or. ( (lb2.eq.0.or.(lb2.ge.3.and.lb2.le.5))
6535      3       .and.(lb1.ge.25.and.lb1.le.28))) then
6536            ei1=aks
6537            ei2=aka
6538            if(RANART(NSEED).ge.0.5) then
6539               iblock=366
6540               lbb1=30
6541               lbb2=21
6542            else
6543               iblock=367
6544               lbb1=-30
6545               lbb2=23
6546            endif
6547         endif
6548 clin-11/07/00-end
6549            endif
6550 clin-ppbar-8/25/00
6551            e(i1)=ei1
6552            e(i2)=ei2
6553            lb(i1)=lbb1
6554            lb(i2)=lbb2
6555 clin-10/08/00-end
6556
6557        else
6558 cbzdbg10/15/99
6559 c.....for meson+meson elastic srt.le.2Mk, if not pi+pi collision return
6560          if ((lb(i1).lt.3.or.lb(i1).gt.5).and.
6561      &        (lb(i2).lt.3.or.lb(i2).gt.5)) return
6562 cbzdbg10/15/99 end
6563
6564 * check Meson+Meson elastic collisions
6565         IBLOCK=6
6566 * direct process
6567        if(ipp.eq.1.or.ipp.eq.4.or.ipp.eq.6)go to 10
6568        if(spprho/ppel.gt.RANART(NSEED))go to 20
6569        endif
6570 10      NTAG=0
6571         EM1=E(I1)
6572         EM2=E(I2)
6573
6574 *-----------------------------------------------------------------------
6575 * CALCULATE THE MAGNITUDE OF THE FINAL MOMENTUM THROUGH
6576 * ENERGY CONSERVATION
6577           PR2   = (SRT**2 - EM1**2 - EM2**2)**2
6578      1                - 4.0 * (EM1*EM2)**2
6579           IF(PR2.LE.0.)PR2=1.e-09
6580           PR=SQRT(PR2)/(2.*SRT)
6581           C1   = 1.0 - 2.0 * RANART(NSEED)
6582           T1   = 2.0 * PI * RANART(NSEED)
6583       S1   = SQRT( 1.0 - C1**2 )
6584       CT1  = COS(T1)
6585       ST1  = SIN(T1)
6586       PZ   = PR * C1
6587       PX   = PR * S1*CT1
6588       PY   = PR * S1*ST1
6589 * for isotropic distribution no need to ROTATE THE MOMENTUM
6590
6591 * ROTATE IT
6592       CALL ROTATE(PX0,PY0,PZ0,PX,PY,PZ)
6593
6594       RETURN
6595 20       continue
6596        iblock=666
6597 * treat rho formation in pion+pion collisions
6598 * calculate the mass and momentum of rho in the nucleus-nucleus frame
6599        call rhores(i1,i2)
6600        if(ipp.eq.2)lb(i1)=27
6601        if(ipp.eq.3)lb(i1)=26
6602        if(ipp.eq.5)lb(i1)=25
6603        return
6604       END
6605 **********************************
6606 **********************************
6607 *                                                                      *
6608 *                                                                      *
6609       SUBROUTINE CRND(IRUN,PX,PY,PZ,SRT,I1,I2,IBLOCK,
6610      &SIGNN,SIG,sigk,xsk1,xsk2,xsk3,xsk4,xsk5,NT,ipert1)
6611 *     PURPOSE:                                                         *
6612 *             DEALING WITH NUCLEON-BARYON RESONANCE COLLISIONS         *
6613 *     NOTE   :                                                         *
6614 *           VALID ONLY FOR BARYON-BARYON-DISTANCES LESS THAN 1.32 FM   *
6615 *           (1.32 = 2 * HARD-CORE-RADIUS [HRC] )                       *
6616 *     QUANTITIES:                                                 *
6617 *           PX,PY,PZ - MOMENTUM COORDINATES OF ONE PARTICLE IN CM FRAME*
6618 *           SRT      - SQRT OF S                                       *
6619 *           NSTAR =1 INCLUDING N* RESORANCE,ELSE NOT                   *
6620 *           NDIRCT=1 INCLUDING DIRECT PION PRODUCTION PROCESS         *
6621 *           IBLOCK   - THE INFORMATION BACK                            *
6622 *                      0-> COLLISION CANNOT HAPPEN                     *
6623 *                      1-> N-N ELASTIC COLLISION                       *
6624 *                      2-> N+N->N+DELTA,OR N+N->N+N* REACTION          *
6625 *                      3-> N+DELTA->N+N OR N+N*->N+N REACTION          *
6626 *                      4-> N+N->N+N+PION,DIRTCT PROCESS                *
6627 *           N12       - IS USED TO SPECIFY BARYON-BARYON REACTION      *
6628 *                      CHANNELS. M12 IS THE REVERSAL CHANNEL OF N12    *
6629 *                      N12,                                            *
6630 *                      M12=1 FOR p+n-->delta(+)+ n                     *
6631 *                          2     p+n-->delta(0)+ p                     *
6632 *                          3     p+p-->delta(++)+n                     *
6633 *                          4     p+p-->delta(+)+p                      *
6634 *                          5     n+n-->delta(0)+n                      *
6635 *                          6     n+n-->delta(-)+p                      *
6636 *                          7     n+p-->N*(0)(1440)+p                   *
6637 *                          8     n+p-->N*(+)(1440)+n                   *
6638 *                        9     p+p-->N*(+)(1535)+p                     *
6639 *                        10    n+n-->N*(0)(1535)+n                     *
6640 *                         11    n+p-->N*(+)(1535)+n                     *
6641 *                        12    n+p-->N*(0)(1535)+p
6642 *                        13    D(++)+D(-)-->N*(+)(1440)+n
6643 *                         14    D(++)+D(-)-->N*(0)(1440)+p
6644 *                        15    D(+)+D(0)--->N*(+)(1440)+n
6645 *                        16    D(+)+D(0)--->N*(0)(1440)+p
6646 *                        17    D(++)+D(0)-->N*(+)(1535)+p
6647 *                        18    D(++)+D(-)-->N*(0)(1535)+p
6648 *                        19    D(++)+D(-)-->N*(+)(1535)+n
6649 *                        20    D(+)+D(+)-->N*(+)(1535)+p
6650 *                        21    D(+)+D(0)-->N*(+)(1535)+n
6651 *                        22    D(+)+D(0)-->N*(0)(1535)+p
6652 *                        23    D(+)+D(-)-->N*(0)(1535)+n
6653 *                        24    D(0)+D(0)-->N*(0)(1535)+n
6654 *                          25    N*(+)(14)+N*(+)(14)-->N*(+)(15)+p
6655 *                          26    N*(0)(14)+N*(0)(14)-->N*(0)(15)+n
6656 *                          27    N*(+)(14)+N*(0)(14)-->N*(+)(15)+n
6657 *                        28    N*(+)(14)+N*(0)(14)-->N*(0)(15)+p
6658 *                        29    N*(+)(14)+D+-->N*(+)(15)+p
6659 *                        30    N*(+)(14)+D0-->N*(+)(15)+n
6660 *                        31    N*(+)(14)+D(-)-->N*(0)(1535)+n
6661 *                        32    N*(0)(14)+D++--->N*(+)(15)+p
6662 *                        33    N*(0)(14)+D+--->N*(+)(15)+n
6663 *                        34    N*(0)(14)+D+--->N*(0)(15)+p
6664 *                        35    N*(0)(14)+D0-->N*(0)(15)+n
6665 *                        36    N*(+)(14)+D0--->N*(0)(15)+p
6666 *                        ++    see the note book for more listing
6667 **********************************
6668         PARAMETER (MAXSTR=150001,MAXR=1,AMN=0.939457,
6669      1  AMP=0.93828,AP1=0.13496,AKA=0.498,APHI=1.020,
6670      2  AP2=0.13957,AM0=1.232,PI=3.1415926,CUTOFF=1.8966,AVMASS=0.9383)
6671         parameter     (MX=4,MY=4,MZ=8,MPX=4,MPY=4,mpz=10,mpzp=10)
6672         parameter (xmd=1.8756,npdmax=10000)
6673         COMMON /AA/ R(3,MAXSTR)
6674 cc      SAVE /AA/
6675         COMMON /BB/ P(3,MAXSTR)
6676 cc      SAVE /BB/
6677         COMMON /CC/ E(MAXSTR)
6678 cc      SAVE /CC/
6679         COMMON /EE/ ID(MAXSTR),LB(MAXSTR)
6680 cc      SAVE /EE/
6681         common /ff/f(-mx:mx,-my:my,-mz:mz,-mpx:mpx,-mpy:mpy,-mpz:mpzp)
6682 cc      SAVE /ff/
6683         common /gg/ dx,dy,dz,dpx,dpy,dpz
6684 cc      SAVE /gg/
6685         COMMON /INPUT/ NSTAR,NDIRCT,DIR
6686 cc      SAVE /INPUT/
6687         COMMON /NN/NNN
6688 cc      SAVE /NN/
6689         COMMON /BG/BETAX,BETAY,BETAZ,GAMMA
6690 cc      SAVE /BG/
6691         COMMON   /RUN/NUM
6692 cc      SAVE /RUN/
6693         COMMON   /PA/RPION(3,MAXSTR,MAXR)
6694 cc      SAVE /PA/
6695         COMMON   /PB/PPION(3,MAXSTR,MAXR)
6696 cc      SAVE /PB/
6697         COMMON   /PC/EPION(MAXSTR,MAXR)
6698 cc      SAVE /PC/
6699         COMMON   /PD/LPION(MAXSTR,MAXR)
6700 cc      SAVE /PD/
6701         common/input1/ MASSPR,MASSTA,ISEED,IAVOID,DT
6702 cc      SAVE /input1/
6703       common/leadng/lb1,px1,py1,pz1,em1,e1,xfnl,yfnl,zfnl,tfnl,
6704      1 px1n,py1n,pz1n,dp1n
6705 cc      SAVE /leadng/
6706       COMMON/RNDF77/NSEED
6707 cc      SAVE /RNDF77/
6708       COMMON /dpert/dpertt(MAXSTR,MAXR),dpertp(MAXSTR),dplast(MAXSTR),
6709      1     dpdcy(MAXSTR),dpdpi(MAXSTR,MAXR),dpt(MAXSTR, MAXR),
6710      2     dpp1(MAXSTR,MAXR),dppion(MAXSTR,MAXR)
6711       common /dpi/em2,lb2
6712       common /para8/ idpert,npertd,idxsec
6713       dimension ppd(3,npdmax),lbpd(npdmax)
6714       SAVE
6715 *-----------------------------------------------------------------------
6716        n12=0
6717        m12=0
6718         IBLOCK=0
6719         NTAG=0
6720         EM1=E(I1)
6721         EM2=E(I2)
6722         PR  = SQRT( PX**2 + PY**2 + PZ**2 )
6723         C2  = PZ / PR
6724         X1  = RANART(NSEED)
6725         ianti=0
6726         if(lb(i1).lt.0 .and. lb(i2).lt.0)ianti=1
6727
6728 clin-6/2008 Production of perturbative deuterons for idpert=1:
6729       call sbbdm(srt,sdprod,ianti,lbm,xmm,pfinal)
6730       if(idpert.eq.1.and.ipert1.eq.1) then
6731          IF (SRT .LT. 2.012) RETURN
6732          if((iabs(lb(i1)).eq.1.or.iabs(lb(i1)).eq.2)
6733      1        .and.(iabs(lb(i2)).ge.6.and.iabs(lb(i2)).le.13)) then
6734             goto 108
6735          elseif((iabs(lb(i2)).eq.1.or.iabs(lb(i2)).eq.2)
6736      1           .and.(iabs(lb(i1)).ge.6.and.iabs(lb(i1)).le.13)) then
6737             goto 108
6738          else
6739             return
6740          endif
6741       endif
6742 *-----------------------------------------------------------------------
6743 *COM: TEST FOR ELASTIC SCATTERING (EITHER N-N OR DELTA-DELTA 0R
6744 *      N-DELTA OR N*-N* or N*-Delta)
6745       IF (X1 .LE. SIGNN/SIG) THEN
6746 *COM:  PARAMETRISATION IS TAKEN FROM THE CUGNON-PAPER
6747         AS  = ( 3.65 * (SRT - 1.8766) )**6
6748         A   = 6.0 * AS / (1.0 + AS)
6749         TA  = -2.0 * PR**2
6750         X   = RANART(NSEED)
6751 clin-10/24/02        T1  = ALOG( (1-X) * DEXP(dble(A)*dble(TA)) + X )  /  A
6752         T1  = sngl(DLOG(dble(1.-X)*DEXP(dble(A)*dble(TA))+dble(X)))/  A
6753         C1  = 1.0 - T1/TA
6754         T1  = 2.0 * PI * RANART(NSEED)
6755         IBLOCK=1
6756        GO TO 107
6757       ELSE
6758 *COM: TEST FOR INELASTIC SCATTERING
6759 *     IF THE AVAILABLE ENERGY IS LESS THAN THE PION-MASS, NOTHING
6760 *     CAN HAPPEN ANY MORE ==> RETURN (2.04 = 2*AVMASS + PI-MASS+0.02)
6761         IF (SRT .LT. 2.04) RETURN
6762 clin-6/2008 add d+meson production for n*N*(0)(1440) and p*N*(+)(1440) channels
6763 c     (they did not have any inelastic reactions before):
6764         if(((iabs(LB(I1)).EQ.2.or.iabs(LB(I2)).EQ.2).AND.
6765      1       (LB(I1)*LB(I2)).EQ.20).or.(LB(I1)*LB(I2)).EQ.13) then
6766            IF(X1.LE.((SIGNN+sdprod)/SIG)) GO TO 108
6767         ENDIF
6768 c
6769 * Resonance absorption or Delta + N-->N*(1440), N*(1535)
6770 * COM: TEST FOR DELTA OR N* ABSORPTION
6771 *      IN THE PROCESS DELTA+N-->NN, N*+N-->NN
6772         PRF=SQRT(0.25*SRT**2-AVMASS**2)
6773         IF(EM1.GT.1.)THEN
6774         DELTAM=EM1
6775         ELSE
6776         DELTAM=EM2
6777         ENDIF
6778         RENOM=DELTAM*PRF**2/DENOM(SRT,1.)/PR
6779         RENOMN=DELTAM*PRF**2/DENOM(SRT,2.)/PR
6780         RENOM1=DELTAM*PRF**2/DENOM(SRT,-1.)/PR
6781 * avoid the inelastic collisions between n+delta- -->N+N
6782 *       and p+delta++ -->N+N due to charge conservation,
6783 *       but they can scatter to produce kaons
6784        if((iabs(lb(i1)).eq.2).and.(iabs(lb(i2)).eq.6)) renom=0.
6785        if((iabs(lb(i2)).eq.2).and.(iabs(lb(i1)).eq.6)) renom=0.
6786        if((iabs(lb(i1)).eq.1).and.(iabs(lb(i2)).eq.9)) renom=0.
6787        if((iabs(lb(i2)).eq.1).and.(iabs(lb(i1)).eq.9)) renom=0.
6788        Call M1535(iabs(lb(i1)),iabs(lb(i2)),srt,x1535)
6789         X1440=(3./4.)*SIGMA(SRT,2,0,1)
6790 * CROSS SECTION FOR KAON PRODUCTION from the four channels
6791 * for NLK channel
6792 * avoid the inelastic collisions between n+delta- -->N+N
6793 *       and p+delta++ -->N+N due to charge conservation,
6794 *       but they can scatter to produce kaons
6795        if(((iabs(lb(i1)).eq.2).and.(iabs(lb(i2)).eq.6)).OR.
6796      &         ((iabs(lb(i2)).eq.2).and.(iabs(lb(i1)).eq.6)).OR.
6797      &         ((iabs(lb(i1)).eq.1).and.(iabs(lb(i2)).eq.9)).OR.
6798      &         ((iabs(lb(i2)).eq.1).and.(iabs(lb(i1)).eq.9)))THEN
6799 clin-6/2008
6800           IF(X1.LE.((SIGNN+sdprod)/SIG)) GO TO 108
6801 c          IF((SIGK+SIGNN)/SIG.GE.X1)GO TO 306
6802           IF((SIGK+SIGNN+sdprod)/SIG.GE.X1)GO TO 306
6803 c
6804        ENDIF
6805 * WE DETERMINE THE REACTION CHANNELS IN THE FOLLOWING
6806 * FOR n+delta(++)-->p+p or n+delta(++)-->n+N*(+)(1440),n+N*(+)(1535)
6807 * REABSORPTION OR N*(1535) PRODUCTION LIKE IN P+P OR N*(1440) LIKE PN,
6808         IF(LB(I1)*LB(I2).EQ.18.AND.
6809      &  (iabs(LB(I1)).EQ.2.OR.iabs(LB(I2)).EQ.2))then
6810         SIGND=SIGMA(SRT,1,1,0)+0.5*SIGMA(SRT,1,1,1)
6811         SIGDN=0.25*SIGND*RENOM
6812 clin-6/2008
6813         IF(X1.LE.((SIGNN+sdprod)/SIG)) GO TO 108
6814 c        IF(X1.GT.(SIGNN+SIGDN+X1440+X1535+SIGK)/SIG)RETURN
6815         IF(X1.GT.(SIGNN+SIGDN+X1440+X1535+SIGK+sdprod)/SIG)RETURN
6816 c
6817        IF(SIGK/(SIGK+SIGDN+X1440+X1535).GT.RANART(NSEED))GO TO 306
6818 * REABSORPTION:
6819        IF(RANART(NSEED).LT.SIGDN/(SIGDN+X1440+X1535))THEN
6820         M12=3
6821        GO TO 206
6822        ELSE
6823 * N* PRODUCTION
6824               IF(RANART(NSEED).LT.X1440/(X1440+X1535))THEN
6825 * N*(1440)
6826               M12=37
6827               ELSE
6828 * N*(1535)       M12=38
6829 clin-2/26/03 why is the above commented out? leads to M12=0 but
6830 c     particle mass is changed after 204 (causes energy violation).
6831 c     replace by elastic process (return):
6832                    return
6833
6834               ENDIF
6835        GO TO 204
6836        ENDIF
6837         ENDIF
6838 * FOR p+delta(-)-->n+n or p+delta(-)-->n+N*(0)(1440),n+N*(0)(1535)
6839 * REABSORPTION OR N*(1535) PRODUCTION LIKE IN P+P OR N*(1440) LIKE PN,
6840         IF(LB(I1)*LB(I2).EQ.6.AND.
6841      &   ((iabs(LB(I1)).EQ.1).OR.(iabs(LB(I2)).EQ.1)))then
6842         SIGND=SIGMA(SRT,1,1,0)+0.5*SIGMA(SRT,1,1,1)
6843         SIGDN=0.25*SIGND*RENOM
6844 clin-6/2008
6845         IF(X1.LE.((SIGNN+sdprod)/SIG)) GO TO 108
6846 c        IF (X1.GT.(SIGNN+SIGDN+X1440+X1535+SIGK)/SIG)RETURN
6847         IF (X1.GT.(SIGNN+SIGDN+X1440+X1535+SIGK+sdprod)/SIG)RETURN
6848 c
6849        IF(SIGK/(SIGK+SIGDN+X1440+X1535).GT.RANART(NSEED))GO TO 306
6850 * REABSORPTION:
6851        IF(RANART(NSEED).LT.SIGDN/(SIGDN+X1440+X1535))THEN
6852         M12=6
6853        GO TO 206
6854        ELSE
6855 * N* PRODUCTION
6856               IF(RANART(NSEED).LT.X1440/(X1440+X1535))THEN
6857 * N*(1440)
6858               M12=47
6859               ELSE
6860 * N*(1535)       M12=48
6861 clin-2/26/03 causes energy violation, replace by elastic process (return):
6862                    return
6863
6864               ENDIF
6865        GO TO 204
6866        ENDIF
6867         ENDIF
6868 * FOR p+delta(+)-->p+p, N*(+)(144)+p, N*(+)(1535)+p
6869         IF(LB(I1)*LB(I2).EQ.8.AND.
6870      &   (iabs(LB(I1)).EQ.1.OR.iabs(LB(I2)).EQ.1))THEN
6871         SIGND=1.5*SIGMA(SRT,1,1,1)
6872         SIGDN=0.25*SIGND*RENOM
6873 clin-6/2008
6874         IF(X1.LE.((SIGNN+sdprod)/SIG)) GO TO 108
6875 c        IF(X1.GT.(SIGNN+SIGDN+x1440+x1535+SIGK)/SIG)RETURN
6876         IF(X1.GT.(SIGNN+SIGDN+x1440+x1535+SIGK+sdprod)/SIG)RETURN
6877 c
6878        IF(SIGK/(SIGK+SIGDN+X1440+X1535).GT.RANART(NSEED))GO TO 306
6879        IF(RANART(NSEED).LT.SIGDN/(SIGDN+X1440+X1535))THEN
6880         M12=4
6881        GO TO 206
6882        ELSE
6883               IF(RANART(NSEED).LT.X1440/(X1440+X1535))THEN
6884 * N*(144)
6885               M12=39
6886               ELSE
6887               M12=40
6888               ENDIF
6889               GO TO 204
6890        ENDIF
6891         ENDIF
6892 * FOR n+delta(0)-->n+n, N*(0)(144)+n, N*(0)(1535)+n
6893         IF(LB(I1)*LB(I2).EQ.14.AND.
6894      &   (iabs(LB(I1)).EQ.2.OR.iabs(LB(I2)).EQ.2))THEN
6895         SIGND=1.5*SIGMA(SRT,1,1,1)
6896         SIGDN=0.25*SIGND*RENOM
6897 clin-6/2008
6898         IF(X1.LE.((SIGNN+sdprod)/SIG)) GO TO 108
6899 c        IF(X1.GT.(SIGNN+SIGDN+x1440+x1535+SIGK)/SIG)RETURN
6900         IF(X1.GT.(SIGNN+SIGDN+x1440+x1535+SIGK+sdprod)/SIG)RETURN
6901 c
6902        IF(SIGK/(SIGK+SIGDN+X1440+X1535).GT.RANART(NSEED))GO TO 306
6903        IF(RANART(NSEED).LT.SIGDN/(SIGDN+X1440+X1535))THEN
6904         M12=5
6905        GO TO 206
6906        ELSE
6907               IF(RANART(NSEED).LT.X1440/(X1440+X1535))THEN
6908 * N*(144)
6909               M12=48
6910               ELSE
6911               M12=49
6912               ENDIF
6913               GO TO 204
6914        ENDIF
6915         ENDIF
6916 * FOR n+delta(+)-->n+p, N*(+)(1440)+n,N*(0)(1440)+p,
6917 *                       N*(+)(1535)+n,N*(0)(1535)+p
6918         IF(LB(I1)*LB(I2).EQ.16.AND.
6919      &   (iabs(LB(I1)).EQ.2.OR.iabs(LB(I2)).EQ.2))THEN
6920         SIGND=0.5*SIGMA(SRT,1,1,1)+0.25*SIGMA(SRT,1,1,0)
6921         SIGDN=0.5*SIGND*RENOM
6922 clin-6/2008
6923         IF(X1.LE.((SIGNN+sdprod)/SIG)) GO TO 108
6924 c        IF(X1.GT.(SIGNN+SIGDN+2.*x1440+2.*x1535+SIGK)/SIG)RETURN
6925         IF(X1.GT.(SIGNN+SIGDN+2.*x1440+2.*x1535+SIGK+sdprod)/SIG)RETURN
6926 c
6927        IF(SIGK/(SIGK+SIGDN+2*X1440+2*X1535).GT.RANART(NSEED))GO TO 306
6928        IF(RANART(NSEED).LT.SIGDN/(SIGDN+2.*X1440+2.*X1535))THEN
6929         M12=1
6930        GO TO 206
6931        ELSE
6932               IF(RANART(NSEED).LT.X1440/(X1440+X1535))THEN
6933               M12=41
6934               IF(RANART(NSEED).LE.0.5)M12=43
6935               ELSE
6936               M12=42
6937               IF(RANART(NSEED).LE.0.5)M12=44
6938               ENDIF
6939               GO TO 204
6940        ENDIF
6941         ENDIF
6942 * FOR p+delta(0)-->n+p, N*(+)(1440)+n,N*(0)(1440)+p,
6943 *                       N*(+)(1535)+n,N*(0)(1535)+p
6944         IF(LB(I1)*LB(I2).EQ.7)THEN
6945         SIGND=0.5*SIGMA(SRT,1,1,1)+0.25*SIGMA(SRT,1,1,0)
6946         SIGDN=0.5*SIGND*RENOM
6947 clin-6/2008
6948         IF(X1.LE.((SIGNN+sdprod)/SIG)) GO TO 108
6949 c        IF(X1.GT.(SIGNN+SIGDN+2.*x1440+2.*x1535+SIGK)/SIG)RETURN
6950         IF(X1.GT.(SIGNN+SIGDN+2.*x1440+2.*x1535+SIGK+sdprod)/SIG)RETURN
6951 c
6952        IF(SIGK/(SIGK+SIGDN+2*X1440+2*X1535).GT.RANART(NSEED))GO TO 306
6953        IF(RANART(NSEED).LT.SIGDN/(SIGDN+2.*X1440+2.*X1535))THEN
6954         M12=2
6955        GO TO 206
6956        ELSE
6957               IF(RANART(NSEED).LT.X1440/(X1440+X1535))THEN
6958               M12=50
6959               IF(RANART(NSEED).LE.0.5)M12=51
6960               ELSE
6961               M12=52
6962               IF(RANART(NSEED).LE.0.5)M12=53
6963               ENDIF
6964               GO TO 204
6965        ENDIF
6966         ENDIF
6967 * FOR p+N*(0)(14)-->p+n, N*(+)(1535)+n,N*(0)(1535)+p
6968 * OR  P+N*(0)(14)-->D(+)+N, D(0)+P,
6969         IF(LB(I1)*LB(I2).EQ.10.AND.
6970      &  (iabs(LB(I1)).EQ.1.OR.iabs(LB(I2)).EQ.1))then
6971         SIGND=(3./4.)*SIGMA(SRT,2,0,1)
6972         SIGDN=SIGND*RENOMN
6973 clin-6/2008
6974         IF(X1.LE.((SIGNN+sdprod)/SIG)) GO TO 108
6975 c        IF(X1.GT.(SIGNN+SIGDN+X1535+SIGK)/SIG)RETURN
6976         IF(X1.GT.(SIGNN+SIGDN+X1535+SIGK+sdprod)/SIG)RETURN
6977 c
6978        IF(SIGK/(SIGK+SIGDN+X1535).GT.RANART(NSEED))GO TO 306
6979        IF(RANART(NSEED).LT.SIGDN/(SIGDN+X1535))THEN
6980         M12=7
6981         GO TO 206
6982        ELSE
6983        M12=54
6984        IF(RANART(NSEED).LE.0.5)M12=55
6985        ENDIF
6986        GO TO 204
6987         ENDIF
6988 * FOR n+N*(+)-->p+n, N*(+)(1535)+n,N*(0)(1535)+p
6989         IF(LB(I1)*LB(I2).EQ.22.AND.
6990      &   (iabs(LB(I1)).EQ.2.OR.iabs(LB(I2)).EQ.2))then
6991         SIGND=(3./4.)*SIGMA(SRT,2,0,1)
6992         SIGDN=SIGND*RENOMN
6993 clin-6/2008
6994         IF(X1.LE.((SIGNN+sdprod)/SIG)) GO TO 108
6995 c        IF(X1.GT.(SIGNN+SIGDN+X1535+SIGK)/SIG)RETURN
6996         IF(X1.GT.(SIGNN+SIGDN+X1535+SIGK+sdprod)/SIG)RETURN
6997 c
6998        IF(SIGK/(SIGK+SIGDN+X1535).GT.RANART(NSEED))GO TO 306
6999        IF(RANART(NSEED).LT.SIGDN/(SIGDN+X1535))THEN
7000         M12=8
7001         GO TO 206
7002        ELSE
7003        M12=56
7004        IF(RANART(NSEED).LE.0.5)M12=57
7005        ENDIF
7006        GO TO 204
7007         ENDIF
7008 * FOR N*(1535)+N-->N+N COLLISIONS
7009         IF((iabs(LB(I1)).EQ.12).OR.(iabs(LB(I1)).EQ.13).OR.
7010      1  (iabs(LB(I2)).EQ.12).OR.(iabs(LB(I2)).EQ.13))THEN
7011         SIGND=X1535
7012         SIGDN=SIGND*RENOM1
7013 clin-6/2008
7014         IF(X1.LE.((SIGNN+sdprod)/SIG)) GO TO 108
7015 c        IF(X1.GT.(SIGNN+SIGDN+SIGK)/SIG)RETURN
7016         IF(X1.GT.(SIGNN+SIGDN+SIGK+sdprod)/SIG)RETURN
7017 c
7018        IF(SIGK/(SIGK+SIGDN).GT.RANART(NSEED))GO TO 306
7019         IF(LB(I1)*LB(I2).EQ.24)M12=10
7020         IF(LB(I1)*LB(I2).EQ.12)M12=12
7021         IF(LB(I1)*LB(I2).EQ.26)M12=11
7022        IF(LB(I1)*LB(I2).EQ.13)M12=9
7023        GO TO 206
7024         ENDIF
7025 204       CONTINUE
7026 * (1) GENERATE THE MASS FOR THE N*(1440) AND N*(1535)
7027 * (2) CALCULATE THE FINAL MOMENTUM OF THE n+N* SYSTEM
7028 * (3) RELABLE THE FINAL STATE PARTICLES
7029 *PARAMETRIZATION OF THE SHAPE OF THE N* RESONANCE ACCORDING
7030 *     TO kitazoe's or J.D.JACKSON'S MASS FORMULA AND BREIT WIGNER
7031 *     FORMULA FOR N* RESORANCE
7032 *     DETERMINE DELTA MASS VIA REJECTION METHOD.
7033           DMAX = SRT - AVMASS-0.005
7034           DMIN = 1.078
7035           IF((M12.eq.37).or.(M12.eq.39).or.
7036      1    (M12.eQ.41).OR.(M12.eQ.43).OR.(M12.EQ.46).
7037      2     OR.(M12.EQ.48).OR.(M12.EQ.50).OR.(M12.EQ.51))then
7038 * N*(1440) production
7039           IF(DMAX.LT.1.44) THEN
7040           FM=FNS(DMAX,SRT,0.)
7041           ELSE
7042
7043 clin-10/25/02 get rid of argument usage mismatch in FNS():
7044              xdmass=1.44
7045 c          FM=FNS(1.44,SRT,1.)
7046           FM=FNS(xdmass,SRT,1.)
7047 clin-10/25/02-end
7048
7049           ENDIF
7050           IF(FM.EQ.0.)FM=1.E-09
7051           NTRY2=0
7052 11        DM=RANART(NSEED)*(DMAX-DMIN)+DMIN
7053           NTRY2=NTRY2+1
7054           IF((RANART(NSEED).GT.FNS(DM,SRT,1.)/FM).AND.
7055      1    (NTRY2.LE.10)) GO TO 11
7056
7057 clin-2/26/03 limit the N* mass below a certain value
7058 c     (here taken as its central value + 2* B-W fullwidth):
7059           if(dm.gt.2.14) goto 11
7060
7061               GO TO 13
7062               ELSE
7063 * N*(1535) production
7064           IF(DMAX.LT.1.535) THEN
7065           FM=FD5(DMAX,SRT,0.)
7066           ELSE
7067
7068 clin-10/25/02 get rid of argument usage mismatch in FNS():
7069              xdmass=1.535
7070 c          FM=FD5(1.535,SRT,1.)
7071           FM=FD5(xdmass,SRT,1.)
7072 clin-10/25/02-end
7073
7074           ENDIF
7075           IF(FM.EQ.0.)FM=1.E-09
7076           NTRY1=0
7077 12        DM = RANART(NSEED) * (DMAX-DMIN) + DMIN
7078           NTRY1=NTRY1+1
7079           IF((RANART(NSEED) .GT. FD5(DM,SRT,1.)/FM).AND.
7080      1    (NTRY1.LE.10)) GOTO 12
7081
7082 clin-2/26/03 limit the N* mass below a certain value
7083 c     (here taken as its central value + 2* B-W fullwidth):
7084           if(dm.gt.1.84) goto 12
7085
7086              ENDIF
7087 13       CONTINUE
7088 * (2) DETERMINE THE FINAL MOMENTUM
7089        PRF=0.
7090        PF2=((SRT**2-DM**2+AVMASS**2)/(2.*SRT))**2-AVMASS**2
7091        IF(PF2.GT.0.)PRF=SQRT(PF2)
7092 * (3) RELABLE FINAL STATE PARTICLES
7093 * 37 D(++)+n-->N*(+)(14)+p
7094           IF(M12.EQ.37)THEN
7095           IF(iabs(LB(I1)).EQ.9)THEN
7096           LB(I1)=1
7097           E(I1)=AMP
7098          LB(I2)=11
7099          E(I2)=DM
7100           ELSE
7101           LB(I2)=1
7102           E(I2)=AMP
7103          LB(I1)=11
7104          E(I1)=DM
7105           ENDIF
7106          GO TO 207
7107           ENDIF
7108 * 38 D(++)+n-->N*(+)(15)+p
7109           IF(M12.EQ.38)THEN
7110           IF(iabs(LB(I1)).EQ.9)THEN
7111           LB(I1)=1
7112           E(I1)=AMP
7113          LB(I2)=13
7114          E(I2)=DM
7115           ELSE
7116           LB(I2)=1
7117           E(I2)=AMP
7118          LB(I1)=13
7119          E(I1)=DM
7120           ENDIF
7121          GO TO 207
7122          ENDIF
7123 * 39 D(+)+P-->N*(+)(14)+p
7124           IF(M12.EQ.39)THEN
7125           IF(iabs(LB(I1)).EQ.8)THEN
7126           LB(I1)=1
7127           E(I1)=AMP
7128          LB(I2)=11
7129          E(I2)=DM
7130           ELSE
7131           LB(I2)=1
7132           E(I2)=AMP
7133          LB(I1)=11
7134          E(I1)=DM
7135           ENDIF
7136          GO TO 207
7137          ENDIF
7138 * 40 D(+)+P-->N*(+)(15)+p
7139           IF(M12.EQ.40)THEN
7140           IF(iabs(LB(I1)).EQ.8)THEN
7141           LB(I1)=1
7142           E(I1)=AMP
7143          LB(I2)=13
7144          E(I2)=DM
7145           ELSE
7146           LB(I2)=1
7147           E(I2)=AMP
7148          LB(I1)=13
7149          E(I1)=DM
7150           ENDIF
7151          GO TO 207
7152          ENDIF
7153 * 41 D(+)+N-->N*(+)(14)+N
7154           IF(M12.EQ.41)THEN
7155           IF(iabs(LB(I1)).EQ.8)THEN
7156           LB(I1)=2
7157           E(I1)=AMN
7158          LB(I2)=11
7159          E(I2)=DM
7160           ELSE
7161           LB(I2)=2
7162           E(I2)=AMN
7163          LB(I1)=11
7164          E(I1)=DM
7165           ENDIF
7166          GO TO 207
7167          ENDIF
7168 * 42 D(+)+N-->N*(+)(15)+N
7169           IF(M12.EQ.42)THEN
7170           IF(iabs(LB(I1)).EQ.8)THEN
7171           LB(I1)=2
7172           E(I1)=AMN
7173          LB(I2)=13
7174          E(I2)=DM
7175           ELSE
7176           LB(I2)=2
7177           E(I2)=AMN
7178          LB(I1)=13
7179          E(I1)=DM
7180           ENDIF
7181          GO TO 207
7182          ENDIF
7183 * 43 D(+)+N-->N*(0)(14)+P
7184           IF(M12.EQ.43)THEN
7185           IF(iabs(LB(I1)).EQ.8)THEN
7186           LB(I1)=1
7187           E(I1)=AMP
7188          LB(I2)=10
7189          E(I2)=DM
7190           ELSE
7191           LB(I2)=1
7192           E(I2)=AMP
7193          LB(I1)=10
7194          E(I1)=DM
7195           ENDIF
7196          GO TO 207
7197          ENDIF
7198 * 44 D(+)+N-->N*(0)(15)+P
7199           IF(M12.EQ.44)THEN
7200           IF(iabs(LB(I1)).EQ.8)THEN
7201           LB(I1)=1
7202           E(I1)=AMP
7203          LB(I2)=12
7204          E(I2)=DM
7205           ELSE
7206           LB(I2)=1
7207           E(I2)=AMP
7208          LB(I1)=12
7209          E(I1)=DM
7210           ENDIF
7211          GO TO 207
7212          ENDIF
7213 * 46 D(-)+P-->N*(0)(14)+N
7214           IF(M12.EQ.46)THEN
7215           IF(iabs(LB(I1)).EQ.6)THEN
7216           LB(I1)=2
7217           E(I1)=AMN
7218          LB(I2)=10
7219          E(I2)=DM
7220           ELSE
7221           LB(I2)=2
7222           E(I2)=AMN
7223          LB(I1)=10
7224          E(I1)=DM
7225           ENDIF
7226          GO TO 207
7227          ENDIF
7228 * 47 D(-)+P-->N*(0)(15)+N
7229           IF(M12.EQ.47)THEN
7230           IF(iabs(LB(I1)).EQ.6)THEN
7231           LB(I1)=2
7232           E(I1)=AMN
7233          LB(I2)=12
7234          E(I2)=DM
7235           ELSE
7236           LB(I2)=2
7237           E(I2)=AMN
7238          LB(I1)=12
7239          E(I1)=DM
7240           ENDIF
7241          GO TO 207
7242          ENDIF
7243 * 48 D(0)+N-->N*(0)(14)+N
7244           IF(M12.EQ.48)THEN
7245           IF(iabs(LB(I1)).EQ.7)THEN
7246           LB(I1)=2
7247           E(I1)=AMN
7248          LB(I2)=11
7249          E(I2)=DM
7250           ELSE
7251           LB(I2)=2
7252           E(I2)=AMN
7253          LB(I1)=11
7254          E(I1)=DM
7255           ENDIF
7256          GO TO 207
7257          ENDIF
7258 * 49 D(0)+N-->N*(0)(15)+N
7259           IF(M12.EQ.49)THEN
7260           IF(iabs(LB(I1)).EQ.7)THEN
7261           LB(I1)=2
7262           E(I1)=AMN
7263          LB(I2)=12
7264          E(I2)=DM
7265           ELSE
7266           LB(I2)=2
7267           E(I2)=AMN
7268          LB(I1)=12
7269          E(I1)=DM
7270           ENDIF
7271          GO TO 207
7272          ENDIF
7273 * 50 D(0)+P-->N*(0)(14)+P
7274           IF(M12.EQ.50)THEN
7275           IF(iabs(LB(I1)).EQ.7)THEN
7276           LB(I1)=1
7277           E(I1)=AMP
7278          LB(I2)=10
7279          E(I2)=DM
7280           ELSE
7281           LB(I2)=1
7282           E(I2)=AMP
7283          LB(I1)=10
7284          E(I1)=DM
7285           ENDIF
7286          GO TO 207
7287          ENDIF
7288 * 51 D(0)+P-->N*(+)(14)+N
7289           IF(M12.EQ.51)THEN
7290           IF(iabs(LB(I1)).EQ.7)THEN
7291           LB(I1)=2
7292           E(I1)=AMN
7293          LB(I2)=11
7294          E(I2)=DM
7295           ELSE
7296           LB(I2)=2
7297           E(I2)=AMN
7298          LB(I1)=11
7299          E(I1)=DM
7300           ENDIF
7301          GO TO 207
7302          ENDIF
7303 * 52 D(0)+P-->N*(0)(15)+P
7304           IF(M12.EQ.52)THEN
7305           IF(iabs(LB(I1)).EQ.7)THEN
7306           LB(I1)=1
7307           E(I1)=AMP
7308          LB(I2)=12
7309          E(I2)=DM
7310           ELSE
7311           LB(I2)=1
7312           E(I2)=AMP
7313          LB(I1)=12
7314          E(I1)=DM
7315           ENDIF
7316          GO TO 207
7317          ENDIF
7318 * 53 D(0)+P-->N*(+)(15)+N
7319           IF(M12.EQ.53)THEN
7320           IF(iabs(LB(I1)).EQ.7)THEN
7321           LB(I1)=2
7322           E(I1)=AMN
7323          LB(I2)=13
7324          E(I2)=DM
7325           ELSE
7326           LB(I2)=2
7327           E(I2)=AMN
7328          LB(I1)=13
7329          E(I1)=DM
7330           ENDIF
7331          GO TO 207
7332          ENDIF
7333 * 54 N*(0)(14)+P-->N*(+)(15)+N
7334           IF(M12.EQ.54)THEN
7335           IF(iabs(LB(I1)).EQ.10)THEN
7336           LB(I1)=2
7337           E(I1)=AMN
7338          LB(I2)=13
7339          E(I2)=DM
7340           ELSE
7341           LB(I2)=2
7342           E(I2)=AMN
7343          LB(I1)=13
7344          E(I1)=DM
7345           ENDIF
7346          GO TO 207
7347          ENDIF
7348 * 55 N*(0)(14)+P-->N*(0)(15)+P
7349           IF(M12.EQ.55)THEN
7350           IF(iabs(LB(I1)).EQ.10)THEN
7351           LB(I1)=1
7352           E(I1)=AMP
7353          LB(I2)=12
7354          E(I2)=DM
7355           ELSE
7356           LB(I2)=1
7357           E(I2)=AMP
7358          LB(I1)=12
7359          E(I1)=DM
7360           ENDIF
7361          GO TO 207
7362          ENDIF
7363 * 56 N*(+)(14)+N-->N*(+)(15)+N
7364           IF(M12.EQ.56)THEN
7365           IF(iabs(LB(I1)).EQ.11)THEN
7366           LB(I1)=2
7367           E(I1)=AMN
7368          LB(I2)=13
7369          E(I2)=DM
7370           ELSE
7371           LB(I2)=2
7372           E(I2)=AMN
7373          LB(I1)=13
7374          E(I1)=DM
7375           ENDIF
7376          GO TO 207
7377          ENDIF
7378 * 57 N*(+)(14)+N-->N*(0)(15)+P
7379           IF(M12.EQ.57)THEN
7380           IF(iabs(LB(I1)).EQ.11)THEN
7381           LB(I1)=1
7382           E(I1)=AMP
7383          LB(I2)=12
7384          E(I2)=DM
7385           ELSE
7386           LB(I2)=1
7387           E(I2)=AMP
7388          LB(I1)=12
7389          E(I1)=DM
7390           ENDIF
7391          ENDIF
7392           GO TO 207
7393 *------------------------------------------------
7394 * RELABLE NUCLEONS AFTER DELTA OR N* BEING ABSORBED
7395 *(1) n+delta(+)-->n+p
7396 206       IF(M12.EQ.1)THEN
7397           IF(iabs(LB(I1)).EQ.8)THEN
7398           LB(I2)=2
7399           LB(I1)=1
7400           E(I1)=AMP
7401           ELSE
7402           LB(I1)=2
7403           LB(I2)=1
7404           E(I2)=AMP
7405           ENDIF
7406          GO TO 207
7407           ENDIF
7408 *(2) p+delta(0)-->p+n
7409           IF(M12.EQ.2)THEN
7410           IF(iabs(LB(I1)).EQ.7)THEN
7411           LB(I2)=1
7412           LB(I1)=2
7413           E(I1)=AMN
7414           ELSE
7415           LB(I1)=1
7416           LB(I2)=2
7417           E(I2)=AMN
7418           ENDIF
7419          GO TO 207
7420           ENDIF
7421 *(3) n+delta(++)-->p+p
7422           IF(M12.EQ.3)THEN
7423           LB(I1)=1
7424           LB(I2)=1
7425           E(I1)=AMP
7426           E(I2)=AMP
7427          GO TO 207
7428           ENDIF
7429 *(4) p+delta(+)-->p+p
7430           IF(M12.EQ.4)THEN
7431           LB(I1)=1
7432           LB(I2)=1
7433           E(I1)=AMP
7434           E(I2)=AMP
7435          GO TO 207
7436           ENDIF
7437 *(5) n+delta(0)-->n+n
7438           IF(M12.EQ.5)THEN
7439           LB(I1)=2
7440           LB(I2)=2
7441           E(I1)=AMN
7442           E(I2)=AMN
7443          GO TO 207
7444           ENDIF
7445 *(6) p+delta(-)-->n+n
7446           IF(M12.EQ.6)THEN
7447           LB(I1)=2
7448           LB(I2)=2
7449           E(I1)=AMN
7450           E(I2)=AMN
7451          GO TO 207
7452           ENDIF
7453 *(7) p+N*(0)-->n+p
7454           IF(M12.EQ.7)THEN
7455           IF(iabs(LB(I1)).EQ.1)THEN
7456           LB(I1)=1
7457           LB(I2)=2
7458           E(I1)=AMP
7459           E(I2)=AMN
7460           ELSE
7461           LB(I1)=2
7462           LB(I2)=1
7463           E(I1)=AMN
7464           E(I2)=AMP
7465           ENDIF
7466          GO TO 207
7467           ENDIF
7468 *(8) n+N*(+)-->n+p
7469           IF(M12.EQ.8)THEN
7470           IF(iabs(LB(I1)).EQ.2)THEN
7471           LB(I1)=2
7472           LB(I2)=1
7473           E(I1)=AMN
7474           E(I2)=AMP
7475           ELSE
7476           LB(I1)=1
7477           LB(I2)=2
7478           E(I1)=AMP
7479           E(I2)=AMN
7480           ENDIF
7481          GO TO 207
7482           ENDIF
7483 clin-6/2008
7484 c*(9) N*(+)p-->pp
7485 *(9) N*(+)(1535) p-->pp
7486           IF(M12.EQ.9)THEN
7487           LB(I1)=1
7488           LB(I2)=1
7489           E(I1)=AMP
7490           E(I2)=AMP
7491          GO TO 207
7492          ENDIF
7493 *(12) N*(0)P-->nP
7494           IF(M12.EQ.12)THEN
7495           LB(I1)=2
7496           LB(I2)=1
7497           E(I1)=AMN
7498           E(I2)=AMP
7499          GO TO 207
7500          ENDIF
7501 *(11) N*(+)n-->nP
7502           IF(M12.EQ.11)THEN
7503           LB(I1)=2
7504           LB(I2)=1
7505           E(I1)=AMN
7506           E(I2)=AMP
7507          GO TO 207
7508          ENDIF
7509 clin-6/2008
7510 c*(12) N*(0)p-->Np
7511 *(12) N*(0)(1535) p-->Np
7512           IF(M12.EQ.12)THEN
7513           LB(I1)=1
7514           LB(I2)=2
7515           E(I1)=AMP
7516           E(I2)=AMN
7517          ENDIF
7518 *----------------------------------------------
7519 207       PR   = PRF
7520           C1   = 1.0 - 2.0 * RANART(NSEED)
7521               if(srt.le.2.14)C1= 1.0 - 2.0 * RANART(NSEED)
7522          if(srt.gt.2.14.and.srt.le.2.4)c1=anga(srt,iseed)
7523          if(srt.gt.2.4)then
7524
7525 clin-10/25/02 get rid of argument usage mismatch in PTR():
7526              xptr=0.33*pr
7527 c         cc1=ptr(0.33*pr,iseed)
7528          cc1=ptr(xptr,iseed)
7529 clin-10/25/02-end
7530
7531          c1=sqrt(pr**2-cc1**2)/pr
7532          endif
7533           T1   = 2.0 * PI * RANART(NSEED)
7534           IBLOCK=3
7535       ENDIF
7536       if(ianti.eq.1 .and. lb(i1).ge.1 .and. lb(i2).ge.1)then
7537          lb(i1) = -lb(i1)
7538          lb(i2) = -lb(i2)
7539       endif
7540
7541 *-----------------------------------------------------------------------
7542 *COM: SET THE NEW MOMENTUM COORDINATES
7543  107  IF(PX .EQ. 0.0 .AND. PY .EQ. 0.0) THEN
7544          T2 = 0.0
7545       ELSE
7546          T2=ATAN2(PY,PX)
7547       END IF
7548       S1   = SQRT( 1.0 - C1**2 )
7549       S2  =  SQRT( 1.0 - C2**2 )
7550       CT1  = COS(T1)
7551       ST1  = SIN(T1)
7552       CT2  = COS(T2)
7553       ST2  = SIN(T2)
7554       PZ   = PR * ( C1*C2 - S1*S2*CT1 )
7555       SS   = C2 * S1 * CT1  +  S2 * C1
7556       PX   = PR * ( SS*CT2 - S1*ST1*ST2 )
7557       PY   = PR * ( SS*ST2 + S1*ST1*CT2 )
7558       RETURN
7559 * FOR THE NN-->KAON+X PROCESS, FIND MOMENTUM OF THE FINAL PARTICLES IN
7560 * THE NUCLEUS-NUCLEUS CMS.
7561 306     CONTINUE
7562 csp11/21/01 phi production
7563               if(XSK5/sigK.gt.RANART(NSEED))then
7564               pz1=p(3,i1)
7565               pz2=p(3,i2)
7566                 LB(I1) = 1 + int(2 * RANART(NSEED))
7567                 LB(I2) = 1 + int(2 * RANART(NSEED))
7568               nnn=nnn+1
7569                 LPION(NNN,IRUN)=29
7570                 EPION(NNN,IRUN)=APHI
7571                 iblock = 222
7572               GO TO 208
7573                ENDIF
7574 csp11/21/01 end
7575                 IBLOCK=11
7576                 if(ianti .eq. 1)iblock=-11
7577 c
7578               pz1=p(3,i1)
7579               pz2=p(3,i2)
7580 * DETERMINE THE CHARGE STATES OF PARTICLES IN THE FINAL STATE
7581               nnn=nnn+1
7582                 LPION(NNN,IRUN)=23
7583                 EPION(NNN,IRUN)=Aka
7584               if(srt.le.2.63)then
7585 * only lambda production is possible
7586 * (1.1)P+P-->p+L+kaon+
7587               ic=1
7588
7589                 LB(I1) = 1 + int(2 * RANART(NSEED))
7590               LB(I2)=14
7591               GO TO 208
7592                 ENDIF
7593        if(srt.le.2.74.and.srt.gt.2.63)then
7594 * both Lambda and sigma production are possible
7595               if(XSK1/(XSK1+XSK2).gt.RANART(NSEED))then
7596 * lambda production
7597               ic=1
7598
7599                 LB(I1) = 1 + int(2 * RANART(NSEED))
7600               LB(I2)=14
7601               else
7602 * sigma production
7603
7604                    LB(I1) = 1 + int(2 * RANART(NSEED))
7605                    LB(I2) = 15 + int(3 * RANART(NSEED))
7606               ic=2
7607               endif
7608               GO TO 208
7609        endif
7610        if(srt.le.2.77.and.srt.gt.2.74)then
7611 * then pp-->Delta lamda kaon can happen
7612               if(xsk1/(xsk1+xsk2+xsk3).
7613      1          gt.RANART(NSEED))then
7614 * * (1.1)P+P-->p+L+kaon+
7615               ic=1
7616
7617                 LB(I1) = 1 + int(2 * RANART(NSEED))
7618               LB(I2)=14
7619               go to 208
7620               else
7621               if(xsk2/(xsk2+xsk3).gt.RANART(NSEED))then
7622 * pp-->psk
7623               ic=2
7624
7625                 LB(I1) = 1 + int(2 * RANART(NSEED))
7626                 LB(I2) = 15 + int(3 * RANART(NSEED))
7627
7628               else
7629 * pp-->D+l+k
7630               ic=3
7631
7632                 LB(I1) = 6 + int(4 * RANART(NSEED))
7633               lb(i2)=14
7634               endif
7635               GO TO 208
7636               endif
7637        endif
7638        if(srt.gt.2.77)then
7639 * all four channels are possible
7640               if(xsk1/(xsk1+xsk2+xsk3+xsk4).gt.RANART(NSEED))then
7641 * p lambda k production
7642               ic=1
7643
7644                 LB(I1) = 1 + int(2 * RANART(NSEED))
7645               LB(I2)=14
7646               go to 208
7647        else
7648           if(xsk3/(xsk2+xsk3+xsk4).gt.RANART(NSEED))then
7649 * delta l K production
7650               ic=3
7651
7652                 LB(I1) = 6 + int(4 * RANART(NSEED))
7653               lb(i2)=14
7654               go to 208
7655           else
7656               if(xsk2/(xsk2+xsk4).gt.RANART(NSEED))then
7657 * n sigma k production
7658
7659                    LB(I1) = 1 + int(2 * RANART(NSEED))
7660                    LB(I2) = 15 + int(3 * RANART(NSEED))
7661
7662               ic=2
7663               else
7664               ic=4
7665
7666                 LB(I1) = 6 + int(4 * RANART(NSEED))
7667                 LB(I2) = 15 + int(3 * RANART(NSEED))
7668
7669               endif
7670               go to 208
7671           endif
7672        endif
7673        endif
7674 208             continue
7675          if(ianti.eq.1 .and. lb(i1).ge.1 .and. lb(i2).ge.1)then
7676           lb(i1) = - lb(i1)
7677           lb(i2) = - lb(i2)
7678           if(LPION(NNN,IRUN) .eq. 23)LPION(NNN,IRUN)=21
7679          endif
7680        lbi1=lb(i1)
7681        lbi2=lb(i2)
7682 * KEEP ALL COORDINATES OF PARTICLE 2 FOR POSSIBLE PHASE SPACE CHANGE
7683            NTRY1=0
7684 128        CALL BBKAON(ic,SRT,PX3,PY3,PZ3,DM3,PX4,PY4,PZ4,DM4,
7685      &  PPX,PPY,PPZ,icou1)
7686        NTRY1=NTRY1+1
7687        if((icou1.lt.0).AND.(NTRY1.LE.20))GO TO 128
7688 c       if(icou1.lt.0)return
7689 * ROTATE THE MOMENTA OF PARTICLES IN THE CMS OF P1+P2
7690        CALL ROTATE(PX,PY,PZ,PX3,PY3,PZ3)
7691        CALL ROTATE(PX,PY,PZ,PX4,PY4,PZ4)
7692        CALL ROTATE(PX,PY,PZ,PPX,PPY,PPZ)
7693 * FIND THE MOMENTUM OF PARTICLES IN THE FINAL STATE IN THE NUCLEUS-
7694 * NUCLEUS CMS. FRAME
7695 * (1) for the necleon/delta
7696 *             LORENTZ-TRANSFORMATION INTO LAB FRAME FOR DELTA1
7697               E1CM    = SQRT (dm3**2 + PX3**2 + PY3**2 + PZ3**2)
7698               P1BETA  = PX3*BETAX + PY3*BETAY + PZ3*BETAZ
7699               TRANSF  = GAMMA * ( GAMMA * P1BETA / (GAMMA + 1) + E1CM )
7700               Pt1i1 = BETAX * TRANSF + PX3
7701               Pt2i1 = BETAY * TRANSF + PY3
7702               Pt3i1 = BETAZ * TRANSF + PZ3
7703              Eti1   = DM3
7704 * (2) for the lambda/sigma
7705                 E2CM    = SQRT (dm4**2 + PX4**2 + PY4**2 + PZ4**2)
7706                 P2BETA  = PX4*BETAX+PY4*BETAY+PZ4*BETAZ
7707                 TRANSF  = GAMMA * (GAMMA*P2BETA / (GAMMA + 1.) + E2CM)
7708                 Pt1I2 = BETAX * TRANSF + PX4
7709                 Pt2I2 = BETAY * TRANSF + PY4
7710                 Pt3I2 = BETAZ * TRANSF + PZ4
7711               EtI2   = DM4
7712 * GET the kaon'S MOMENTUM AND COORDINATES IN NUCLEUS-NUCLEUS CMS. FRAME
7713                 EPCM=SQRT(aka**2+PPX**2+PPY**2+PPZ**2)
7714                 PPBETA=PPX*BETAX+PPY*BETAY+PPZ*BETAZ
7715                 TRANSF=GAMMA*(GAMMA*PPBETA/(GAMMA+1.)+EPCM)
7716                 PPION(1,NNN,IRUN)=BETAX*TRANSF+PPX
7717                 PPION(2,NNN,IRUN)=BETAY*TRANSF+PPY
7718                 PPION(3,NNN,IRUN)=BETAZ*TRANSF+PPZ
7719 clin-5/2008:
7720                 dppion(nnn,irun)=dpertp(i1)*dpertp(i2)
7721 clin-5/2008:
7722 c2008        X01 = 1.0 - 2.0 * RANART(NSEED)
7723 c            Y01 = 1.0 - 2.0 * RANART(NSEED)
7724 c            Z01 = 1.0 - 2.0 * RANART(NSEED)
7725 c        IF ((X01*X01+Y01*Y01+Z01*Z01) .GT. 1.0) GOTO 2008
7726 c                RPION(1,NNN,IRUN)=R(1,I1)+0.5*x01
7727 c                RPION(2,NNN,IRUN)=R(2,I1)+0.5*y01
7728 c                RPION(3,NNN,IRUN)=R(3,I1)+0.5*z01
7729                     RPION(1,NNN,IRUN)=R(1,I1)
7730                     RPION(2,NNN,IRUN)=R(2,I1)
7731                     RPION(3,NNN,IRUN)=R(3,I1)
7732 c
7733 * assign the nucleon/delta and lambda/sigma to i1 or i2 to keep the
7734 * leadng particle behaviour
7735 C              if((pt1i1*px1+pt2i1*py1+pt3i1*pz1).gt.0)then
7736               p(1,i1)=pt1i1
7737               p(2,i1)=pt2i1
7738               p(3,i1)=pt3i1
7739               e(i1)=eti1
7740               lb(i1)=lbi1
7741               p(1,i2)=pt1i2
7742               p(2,i2)=pt2i2
7743               p(3,i2)=pt3i2
7744               e(i2)=eti2
7745               lb(i2)=lbi2
7746                 PX1     = P(1,I1)
7747                 PY1     = P(2,I1)
7748                 PZ1     = P(3,I1)
7749               EM1       = E(I1)
7750                 ID(I1)  = 2
7751                 ID(I2)  = 2
7752                 ID1     = ID(I1)
7753                 if(LPION(NNN,IRUN) .ne. 29) IBLOCK=11
7754         LB1=LB(I1)
7755         LB2=LB(I2)
7756         AM1=EM1
7757        am2=em2
7758         E1= SQRT( EM1**2 + PX1**2 + PY1**2 + PZ1**2 )
7759        RETURN
7760
7761 clin-6/2008 N+D->Deuteron+pi:
7762 *     FIND MOMENTUM OF THE FINAL PARTICLES IN THE NUCLEUS-NUCLEUS CMS.
7763  108   CONTINUE
7764            if(idpert.eq.1.and.ipert1.eq.1.and.npertd.ge.1) then
7765 c     For idpert=1: we produce npertd pert deuterons:
7766               ndloop=npertd
7767            elseif(idpert.eq.2.and.npertd.ge.1) then
7768 c     For idpert=2: we first save information for npertd pert deuterons;
7769 c     at the last ndloop we create the regular deuteron+pi
7770 c     and those pert deuterons:
7771               ndloop=npertd+1
7772            else
7773 c     Just create the regular deuteron+pi:
7774               ndloop=1
7775            endif
7776 c
7777            dprob1=sdprod/sig/float(npertd)
7778            do idloop=1,ndloop
7779               CALL bbdangle(pxd,pyd,pzd,nt,ipert1,ianti,idloop,pfinal,
7780      1 dprob1,lbm)
7781               CALL ROTATE(PX,PY,PZ,PXd,PYd,PZd)
7782 *     LORENTZ-TRANSFORMATION OF THE MOMENTUM OF PARTICLES IN THE FINAL STATE
7783 *     FROM THE NN CMS FRAME INTO THE GLOBAL CMS FRAME:
7784 *     For the Deuteron:
7785               xmass=xmd
7786               E1dCM=SQRT(xmass**2+PXd**2+PYd**2+PZd**2)
7787               P1dBETA=PXd*BETAX+PYd*BETAY+PZd*BETAZ
7788               TRANSF=GAMMA*(GAMMA*P1dBETA/(GAMMA+1.)+E1dCM)
7789               pxi1=BETAX*TRANSF+PXd
7790               pyi1=BETAY*TRANSF+PYd
7791               pzi1=BETAZ*TRANSF+PZd
7792               if(ianti.eq.0)then
7793                  lbd=42
7794               else
7795                  lbd=-42
7796               endif
7797               if(idpert.eq.1.and.ipert1.eq.1.and.npertd.ge.1) then
7798 cccc  Perturbative production for idpert=1:
7799                  nnn=nnn+1
7800                  PPION(1,NNN,IRUN)=pxi1
7801                  PPION(2,NNN,IRUN)=pyi1
7802                  PPION(3,NNN,IRUN)=pzi1
7803                  EPION(NNN,IRUN)=xmd
7804                  LPION(NNN,IRUN)=lbd
7805                  RPION(1,NNN,IRUN)=R(1,I1)
7806                  RPION(2,NNN,IRUN)=R(2,I1)
7807                  RPION(3,NNN,IRUN)=R(3,I1)
7808 clin-6/2008 assign the perturbative probability:
7809                  dppion(NNN,IRUN)=sdprod/sig/float(npertd)
7810               elseif(idpert.eq.2.and.idloop.le.npertd) then
7811 clin-6/2008 For idpert=2, we produce NPERTD perturbative (anti)deuterons
7812 c     only when a regular (anti)deuteron+pi is produced in NN collisions.
7813 c     First save the info for the perturbative deuterons:
7814                  ppd(1,idloop)=pxi1
7815                  ppd(2,idloop)=pyi1
7816                  ppd(3,idloop)=pzi1
7817                  lbpd(idloop)=lbd
7818               else
7819 cccc  Regular production:
7820 c     For the regular pion: do LORENTZ-TRANSFORMATION:
7821                  E(i1)=xmm
7822                  E2piCM=SQRT(xmm**2+PXd**2+PYd**2+PZd**2)
7823                  P2piBETA=-PXd*BETAX-PYd*BETAY-PZd*BETAZ
7824                  TRANSF=GAMMA*(GAMMA*P2piBETA/(GAMMA+1.)+E2piCM)
7825                  pxi2=BETAX*TRANSF-PXd
7826                  pyi2=BETAY*TRANSF-PYd
7827                  pzi2=BETAZ*TRANSF-PZd
7828                  p(1,i1)=pxi2
7829                  p(2,i1)=pyi2
7830                  p(3,i1)=pzi2
7831 c     Remove regular pion to check the equivalence
7832 c     between the perturbative and regular deuteron results:
7833 c                 E(i1)=0.
7834 c
7835                  LB(I1)=lbm
7836                  PX1=P(1,I1)
7837                  PY1=P(2,I1)
7838                  PZ1=P(3,I1)
7839                  EM1=E(I1)
7840                  ID(I1)=2
7841                  ID1=ID(I1)
7842                  E1=SQRT(EM1**2+PX1**2+PY1**2+PZ1**2)
7843                  lb1=lb(i1)
7844 c     For the regular deuteron:
7845                  p(1,i2)=pxi1
7846                  p(2,i2)=pyi1
7847                  p(3,i2)=pzi1
7848                  lb(i2)=lbd
7849                  lb2=lb(i2)
7850                  E(i2)=xmd
7851                  EtI2=E(I2)
7852                  ID(I2)=2
7853 c     For idpert=2: create the perturbative deuterons:
7854                  if(idpert.eq.2.and.idloop.eq.ndloop) then
7855                     do ipertd=1,npertd
7856                        nnn=nnn+1
7857                        PPION(1,NNN,IRUN)=ppd(1,ipertd)
7858                        PPION(2,NNN,IRUN)=ppd(2,ipertd)
7859                        PPION(3,NNN,IRUN)=ppd(3,ipertd)
7860                        EPION(NNN,IRUN)=xmd
7861                        LPION(NNN,IRUN)=lbpd(ipertd)
7862                        RPION(1,NNN,IRUN)=R(1,I1)
7863                        RPION(2,NNN,IRUN)=R(2,I1)
7864                        RPION(3,NNN,IRUN)=R(3,I1)
7865 clin-6/2008 assign the perturbative probability:
7866                        dppion(NNN,IRUN)=1./float(npertd)
7867                     enddo
7868                  endif
7869               endif
7870            enddo
7871            IBLOCK=501
7872            return
7873 clin-6/2008 N+D->Deuteron+pi over
7874
7875       END
7876 **********************************
7877 *                                                                      *
7878 *                                                                      *
7879       SUBROUTINE CRDD(IRUN,PX,PY,PZ,SRT,I1,I2,IBLOCK,
7880      1NTAG,SIGNN,SIG,NT,ipert1)
7881 c     1NTAG,SIGNN,SIG)
7882 *     PURPOSE:                                                         *
7883 *             DEALING WITH BARYON RESONANCE-BARYON RESONANCE COLLISIONS*
7884 *     NOTE   :                                                         *
7885 *     QUANTITIES:                                                 *
7886 *           PX,PY,PZ - MOMENTUM COORDINATES OF ONE PARTICLE IN CM FRAME*
7887 *           SRT      - SQRT OF S                                       *
7888 *           NSTAR =1 INCLUDING N* RESORANCE,ELSE NOT                   *
7889 *           NDIRCT=1 INCLUDING DIRECT PION PRODUCTION PROCESS         *
7890 *           IBLOCK   - THE INFORMATION BACK                            *
7891 *                      0-> COLLISION CANNOT HAPPEN                     *
7892 *                      1-> N-N ELASTIC COLLISION                       *
7893 *                      2-> N+N->N+DELTA,OR N+N->N+N* REACTION          *
7894 *                      3-> N+DELTA->N+N OR N+N*->N+N REACTION          *
7895 *                      4-> N+N->N+N+PION,DIRTCT PROCESS                *
7896 *                     5-> DELTA(N*)+DELTA(N*)   TOTAL   COLLISIONS    *
7897 *           N12       - IS USED TO SPECIFY BARYON-BARYON REACTION      *
7898 *                      CHANNELS. M12 IS THE REVERSAL CHANNEL OF N12    *
7899 *                      N12,                                            *
7900 *                      M12=1 FOR p+n-->delta(+)+ n                     *
7901 *                          2     p+n-->delta(0)+ p                     *
7902 *                          3     p+p-->delta(++)+n                     *
7903 *                          4     p+p-->delta(+)+p                      *
7904 *                          5     n+n-->delta(0)+n                      *
7905 *                          6     n+n-->delta(-)+p                      *
7906 *                          7     n+p-->N*(0)(1440)+p                   *
7907 *                          8     n+p-->N*(+)(1440)+n                   *
7908 *                        9     p+p-->N*(+)(1535)+p                     *
7909 *                        10    n+n-->N*(0)(1535)+n                     *
7910 *                         11    n+p-->N*(+)(1535)+n                     *
7911 *                        12    n+p-->N*(0)(1535)+p
7912 *                        13    D(++)+D(-)-->N*(+)(1440)+n
7913 *                         14    D(++)+D(-)-->N*(0)(1440)+p
7914 *                        15    D(+)+D(0)--->N*(+)(1440)+n
7915 *                        16    D(+)+D(0)--->N*(0)(1440)+p
7916 *                        17    D(++)+D(0)-->N*(+)(1535)+p
7917 *                        18    D(++)+D(-)-->N*(0)(1535)+p
7918 *                        19    D(++)+D(-)-->N*(+)(1535)+n
7919 *                        20    D(+)+D(+)-->N*(+)(1535)+p
7920 *                        21    D(+)+D(0)-->N*(+)(1535)+n
7921 *                        22    D(+)+D(0)-->N*(0)(1535)+p
7922 *                        23    D(+)+D(-)-->N*(0)(1535)+n
7923 *                        24    D(0)+D(0)-->N*(0)(1535)+n
7924 *                          25    N*(+)(14)+N*(+)(14)-->N*(+)(15)+p
7925 *                          26    N*(0)(14)+N*(0)(14)-->N*(0)(15)+n
7926 *                          27    N*(+)(14)+N*(0)(14)-->N*(+)(15)+n
7927 *                        28    N*(+)(14)+N*(0)(14)-->N*(0)(15)+p
7928 *                        29    N*(+)(14)+D+-->N*(+)(15)+p
7929 *                        30    N*(+)(14)+D0-->N*(+)(15)+n
7930 *                        31    N*(+)(14)+D(-)-->N*(0)(1535)+n
7931 *                        32    N*(0)(14)+D++--->N*(+)(15)+p
7932 *                        33    N*(0)(14)+D+--->N*(+)(15)+n
7933 *                        34    N*(0)(14)+D+--->N*(0)(15)+p
7934 *                        35    N*(0)(14)+D0-->N*(0)(15)+n
7935 *                        36    N*(+)(14)+D0--->N*(0)(15)+p
7936 *                        +++
7937 *               AND MORE CHANNELS AS LISTED IN THE NOTE BOOK
7938 *
7939 * NOTE ABOUT N*(1440) RESORANCE:                                       *
7940 *     As it has been discussed in VerWest's paper,I= 1 (initial isospin)
7941 *     channel can all be attributed to delta resorance while I= 0      *
7942 *     channel can all be  attribured to N* resorance.Only in n+p       *
7943 *     one can have I=0 channel so is the N*(1440) resorance            *
7944 * REFERENCES:    J. CUGNON ET AL., NUCL. PHYS. A352, 505 (1981)        *
7945 *                    Y. KITAZOE ET AL., PHYS. LETT. 166B, 35 (1986)    *
7946 *                    B. VerWest el al., PHYS. PRV. C25 (1982)1979      *
7947 *                    Gy. Wolf  et al, Nucl Phys A517 (1990) 615        *
7948 *                    CUTOFF = 2 * AVMASS + 20 MEV                      *
7949 *                                                                      *
7950 *       for N*(1535) we use the parameterization by Gy. Wolf et al     *
7951 *       Nucl phys A552 (1993) 349, added May 18, 1994                  *
7952 **********************************
7953         PARAMETER (MAXSTR=150001,MAXR=1,AMN=0.939457,
7954      1  AMP=0.93828,AP1=0.13496,AKA=0.498,APHI=1.020,
7955      2  AP2=0.13957,AM0=1.232,PI=3.1415926,CUTOFF=1.8966,AVMASS=0.9383)
7956         parameter     (MX=4,MY=4,MZ=8,MPX=4,MPY=4,mpz=10,mpzp=10)
7957         parameter (xmd=1.8756,npdmax=10000)
7958         COMMON /AA/ R(3,MAXSTR)
7959 cc      SAVE /AA/
7960         COMMON /BB/ P(3,MAXSTR)
7961 cc      SAVE /BB/
7962         COMMON /CC/ E(MAXSTR)
7963 cc      SAVE /CC/
7964         COMMON /EE/ ID(MAXSTR),LB(MAXSTR)
7965 cc      SAVE /EE/
7966         common /ff/f(-mx:mx,-my:my,-mz:mz,-mpx:mpx,-mpy:mpy,-mpz:mpzp)
7967 cc      SAVE /ff/
7968         common /gg/ dx,dy,dz,dpx,dpy,dpz
7969 cc      SAVE /gg/
7970         COMMON /INPUT/ NSTAR,NDIRCT,DIR
7971 cc      SAVE /INPUT/
7972         COMMON /NN/NNN
7973 cc      SAVE /NN/
7974         COMMON /BG/BETAX,BETAY,BETAZ,GAMMA
7975 cc      SAVE /BG/
7976         COMMON   /RUN/NUM
7977 cc      SAVE /RUN/
7978         COMMON   /PA/RPION(3,MAXSTR,MAXR)
7979 cc      SAVE /PA/
7980         COMMON   /PB/PPION(3,MAXSTR,MAXR)
7981 cc      SAVE /PB/
7982         COMMON   /PC/EPION(MAXSTR,MAXR)
7983 cc      SAVE /PC/
7984         COMMON   /PD/LPION(MAXSTR,MAXR)
7985 cc      SAVE /PD/
7986         common/input1/ MASSPR,MASSTA,ISEED,IAVOID,DT
7987 cc      SAVE /input1/
7988       common/leadng/lb1,px1,py1,pz1,em1,e1,xfnl,yfnl,zfnl,tfnl,
7989      1 px1n,py1n,pz1n,dp1n
7990 cc      SAVE /leadng/
7991       COMMON/RNDF77/NSEED
7992 cc      SAVE /RNDF77/
7993       COMMON /dpert/dpertt(MAXSTR,MAXR),dpertp(MAXSTR),dplast(MAXSTR),
7994      1     dpdcy(MAXSTR),dpdpi(MAXSTR,MAXR),dpt(MAXSTR, MAXR),
7995      2     dpp1(MAXSTR,MAXR),dppion(MAXSTR,MAXR)
7996       common /dpi/em2,lb2
7997       common /para8/ idpert,npertd,idxsec
7998       dimension ppd(3,npdmax),lbpd(npdmax)
7999       SAVE
8000 *-----------------------------------------------------------------------
8001        n12=0
8002        m12=0
8003         IBLOCK=0
8004         NTAG=0
8005         EM1=E(I1)
8006         EM2=E(I2)
8007       PR  = SQRT( PX**2 + PY**2 + PZ**2 )
8008       C2  = PZ / PR
8009       IF(PX .EQ. 0.0 .AND. PY .EQ. 0.0) THEN
8010         T2 = 0.0
8011       ELSE
8012         T2=ATAN2(PY,PX)
8013       END IF
8014       X1  = RANART(NSEED)
8015       ianti=0
8016       if(lb(i1).lt.0 .and. lb(i2).lt.0)ianti=1
8017
8018 clin-6/2008 Production of perturbative deuterons for idpert=1:
8019       call sbbdm(srt,sdprod,ianti,lbm,xmm,pfinal)
8020       if(idpert.eq.1.and.ipert1.eq.1) then
8021          IF (SRT .LT. 2.012) RETURN
8022          if((iabs(lb(i1)).ge.6.and.iabs(lb(i1)).le.13)
8023      1        .and.(iabs(lb(i2)).ge.6.and.iabs(lb(i2)).le.13)) then
8024             goto 108
8025          else
8026             return
8027          endif
8028       endif
8029
8030 *-----------------------------------------------------------------------
8031 *COM: TEST FOR ELASTIC SCATTERING (EITHER N-N OR DELTA-DELTA 0R
8032 *      N-DELTA OR N*-N* or N*-Delta)
8033       IF (X1 .LE. SIGNN/SIG) THEN
8034 *COM:  PARAMETRISATION IS TAKEN FROM THE CUGNON-PAPER
8035         AS  = ( 3.65 * (SRT - 1.8766) )**6
8036         A   = 6.0 * AS / (1.0 + AS)
8037         TA  = -2.0 * PR**2
8038         X   = RANART(NSEED)
8039 clin-10/24/02        T1  = DLOG( (1-X) * DEXP(dble(A)*dble(TA)) + X )  /  A
8040         T1  = sngl(DLOG(dble(1.-X)*DEXP(dble(A)*dble(TA))+dble(X)))/  A
8041         C1  = 1.0 - T1/TA
8042         T1  = 2.0 * PI * RANART(NSEED)
8043         IBLOCK=20
8044        GO TO 107
8045       ELSE
8046 *COM: TEST FOR INELASTIC SCATTERING
8047 *     IF THE AVAILABLE ENERGY IS LESS THAN THE PION-MASS, NOTHING
8048 *     CAN HAPPEN ANY MORE ==> RETURN (2.15 = 2*AVMASS +2*PI-MASS)
8049         IF (SRT .LT. 2.15) RETURN
8050 *     IF THERE WERE 2 N*(1535) AND THEY DIDN'T SCATT. ELAST.,
8051 *     ALLOW THEM TO PRODUCE KAONS. NO OTHER INELASTIC CHANNELS
8052 *     ARE KNOWN
8053 C       if((lb(i1).ge.12).and.(lb(i2).ge.12))return
8054 *     ALL the inelastic collisions between N*(1535) and Delta as well
8055 *     as N*(1440) TO PRODUCE KAONS, NO OTHER CHANNELS ARE KNOWN
8056 C       if((lb(i1).ge.12).and.(lb(i2).ge.3))return
8057 C       if((lb(i2).ge.12).and.(lb(i1).ge.3))return
8058 *     calculate the N*(1535) production cross section in I1+I2 collisions
8059        call N1535(iabs(lb(i1)),iabs(lb(i2)),srt,X1535)
8060
8061 * for Delta+Delta-->N*(1440 OR 1535)+N AND N*(1440)+N*(1440)-->N*(1535)+X
8062 *     AND DELTA+N*(1440)-->N*(1535)+X
8063 * WE ASSUME THEY HAVE THE SAME CROSS SECTIONS as CORRESPONDING N+N COLLISION):
8064 * FOR D++D0, D+D+,D+D-,D0D0,N*+N*+,N*0N*0,N*(+)D+,N*(+)D(-),N*(0)D(0)
8065 * N*(1535) production, kaon production and reabsorption through
8066 * D(N*)+D(N*)-->NN are ALLOWED.
8067 * CROSS SECTION FOR KAON PRODUCTION from the four channels are
8068 * for NLK channel
8069        akp=0.498
8070        ak0=0.498
8071        ana=0.938
8072        ada=1.232
8073        al=1.1157
8074        as=1.1197
8075        xsk1=0
8076        xsk2=0
8077        xsk3=0
8078        xsk4=0
8079        xsk5=0
8080        t1nlk=ana+al+akp
8081        if(srt.le.t1nlk)go to 222
8082        XSK1=1.5*PPLPK(SRT)
8083 * for DLK channel
8084        t1dlk=ada+al+akp
8085        t2dlk=ada+al-akp
8086        if(srt.le.t1dlk)go to 222
8087        es=srt
8088        pmdlk2=(es**2-t1dlk**2)*(es**2-t2dlk**2)/(4.*es**2)
8089        pmdlk=sqrt(pmdlk2)
8090        XSK3=1.5*PPLPK(srt)
8091 * for NSK channel
8092        t1nsk=ana+as+akp
8093        t2nsk=ana+as-akp
8094        if(srt.le.t1nsk)go to 222
8095        pmnsk2=(es**2-t1nsk**2)*(es**2-t2nsk**2)/(4.*es**2)
8096        pmnsk=sqrt(pmnsk2)
8097        XSK2=1.5*(PPK1(srt)+PPK0(srt))
8098 * for DSK channel
8099        t1DSk=aDa+aS+akp
8100        t2DSk=aDa+aS-akp
8101        if(srt.le.t1dsk)go to 222
8102        pmDSk2=(es**2-t1DSk**2)*(es**2-t2DSk**2)/(4.*es**2)
8103        pmDSk=sqrt(pmDSk2)
8104        XSK4=1.5*(PPK1(srt)+PPK0(srt))
8105 csp11/21/01
8106 c phi production
8107        if(srt.le.(2.*amn+aphi))go to 222
8108 c  !! mb put the correct form
8109          xsk5 = 0.0001
8110 csp11/21/01 end
8111 * THE TOTAL KAON+ PRODUCTION CROSS SECTION IS THEN
8112 222       SIGK=XSK1+XSK2+XSK3+XSK4
8113
8114 cbz3/7/99 neutralk
8115         XSK1 = 2.0 * XSK1
8116         XSK2 = 2.0 * XSK2
8117         XSK3 = 2.0 * XSK3
8118         XSK4 = 2.0 * XSK4
8119         SIGK = 2.0 * SIGK + xsk5
8120 cbz3/7/99 neutralk end
8121
8122 * The reabsorption cross section for the process
8123 * D(N*)D(N*)-->NN is
8124        s2d=reab2d(i1,i2,srt)
8125
8126 cbz3/16/99 pion
8127         S2D = 0.
8128 cbz3/16/99 pion end
8129
8130 *(1) N*(1535)+D(N*(1440)) reactions
8131 *    we allow kaon production and reabsorption only
8132        if(((iabs(lb(i1)).ge.12).and.(iabs(lb(i2)).ge.12)).OR.
8133      &       ((iabs(lb(i1)).ge.12).and.(iabs(lb(i2)).ge.6)).OR.
8134      &       ((iabs(lb(i2)).ge.12).and.(iabs(lb(i1)).ge.6)))THEN
8135        signd=sigk+s2d
8136 clin-6/2008
8137        IF(X1.LE.((SIGNN+sdprod)/SIG)) GO TO 108
8138 c       if(x1.gt.(signd+signn)/sig)return
8139        if(x1.gt.(signd+signn+sdprod)/sig)return
8140 c
8141 * if kaon production
8142 clin-6/2008
8143 c       IF(SIGK/SIG.GE.RANART(NSEED))GO TO 306
8144        IF((SIGK+sdprod)/SIG.GE.RANART(NSEED))GO TO 306
8145 c
8146 * if reabsorption
8147        go to 1012
8148        ENDIF
8149        IDD=iabs(LB(I1)*LB(I2))
8150 * channels have the same charge as pp
8151         IF((IDD.EQ.63).OR.(IDD.EQ.64).OR.(IDD.EQ.48).
8152      1  OR.(IDD.EQ.49).OR.(IDD.EQ.11*11).OR.(IDD.EQ.10*10).
8153      2  OR.(IDD.EQ.88).OR.(IDD.EQ.66).
8154      3  OR.(IDD.EQ.90).OR.(IDD.EQ.70))THEN
8155         SIGND=X1535+SIGK+s2d
8156 clin-6/2008
8157         IF(X1.LE.((SIGNN+sdprod)/SIG)) GO TO 108
8158 c        IF (X1.GT.(SIGNN+SIGND)/SIG)RETURN
8159         IF (X1.GT.(SIGNN+SIGND+sdprod)/SIG)RETURN
8160 c
8161 * if kaon production
8162        IF(SIGK/SIGND.GT.RANART(NSEED))GO TO 306
8163 * if reabsorption
8164        if(s2d/(x1535+s2d).gt.RANART(NSEED))go to 1012
8165 * if N*(1535) production
8166        IF(IDD.EQ.63)N12=17
8167        IF(IDD.EQ.64)N12=20
8168        IF(IDD.EQ.48)N12=23
8169        IF(IDD.EQ.49)N12=24
8170        IF(IDD.EQ.121)N12=25
8171        IF(IDD.EQ.100)N12=26
8172        IF(IDD.EQ.88)N12=29
8173        IF(IDD.EQ.66)N12=31
8174        IF(IDD.EQ.90)N12=32
8175        IF(IDD.EQ.70)N12=35
8176        GO TO 1011
8177         ENDIF
8178 * IN DELTA+N*(1440) and N*(1440)+N*(1440) COLLISIONS,
8179 * N*(1535), kaon production and reabsorption are ALLOWED
8180 * IN N*(1440)+N*(1440) COLLISIONS, ONLY N*(1535) IS ALLOWED
8181        IF((IDD.EQ.110).OR.(IDD.EQ.77).OR.(IDD.EQ.80))THEN
8182 clin-6/2008
8183           IF(X1.LE.((SIGNN+sdprod)/SIG)) GO TO 108
8184 c       IF(X1.GT.(SIGNN+X1535+SIGK+s2d)/SIG)RETURN
8185           IF(X1.GT.(SIGNN+X1535+SIGK+s2d+sdprod)/SIG)RETURN
8186 c
8187        IF(SIGK/(X1535+SIGK+s2d).GT.RANART(NSEED))GO TO 306
8188        if(s2d/(x1535+s2d).gt.RANART(NSEED))go to 1012
8189        IF(IDD.EQ.77)N12=30
8190        IF((IDD.EQ.77).AND.(RANART(NSEED).LE.0.5))N12=36
8191        IF(IDD.EQ.80)N12=34
8192        IF((IDD.EQ.80).AND.(RANART(NSEED).LE.0.5))N12=35
8193        IF(IDD.EQ.110)N12=27
8194        IF((IDD.EQ.110).AND.(RANART(NSEED).LE.0.5))N12=28
8195        GO TO 1011
8196         ENDIF
8197        IF((IDD.EQ.54).OR.(IDD.EQ.56))THEN
8198 * LIKE FOR N+P COLLISION,
8199 * IN DELTA+DELTA COLLISIONS BOTH N*(1440) AND N*(1535) CAN BE PRODUCED
8200         SIG2=(3./4.)*SIGMA(SRT,2,0,1)
8201         SIGND=2.*(SIG2+X1535)+SIGK+s2d
8202 clin-6/2008
8203         IF(X1.LE.((SIGNN+sdprod)/SIG)) GO TO 108
8204 c        IF(X1.GT.(SIGNN+SIGND)/SIG)RETURN
8205         IF(X1.GT.(SIGNN+SIGND+sdprod)/SIG)RETURN
8206 c
8207        IF(SIGK/SIGND.GT.RANART(NSEED))GO TO 306
8208        if(s2d/(2.*(sig2+x1535)+s2d).gt.RANART(NSEED))go to 1012
8209        IF(RANART(NSEED).LT.X1535/(SIG2+X1535))THEN
8210 * N*(1535) PRODUCTION
8211        IF(IDD.EQ.54)N12=18
8212        IF((IDD.EQ.54).AND.(RANART(NSEED).LE.0.5))N12=19
8213        IF(IDD.EQ.56)N12=21
8214        IF((IDD.EQ.56).AND.(RANART(NSEED).LE.0.5))N12=22
8215                ELSE
8216 * N*(144) PRODUCTION
8217        IF(IDD.EQ.54)N12=13
8218        IF((IDD.EQ.54).AND.(RANART(NSEED).LE.0.5))N12=14
8219        IF(IDD.EQ.56)N12=15
8220        IF((IDD.EQ.56).AND.(RANART(NSEED).LE.0.5))N12=16
8221               ENDIF
8222        ENDIF
8223 1011       CONTINUE
8224        iblock=5
8225 *PARAMETRIZATION OF THE SHAPE OF THE N*(1440) AND N*(1535)
8226 * RESONANCE ACCORDING
8227 *     TO kitazoe's or J.D.JACKSON'S MASS FORMULA AND BREIT WIGNER
8228 *     FORMULA FOR N* RESORANCE
8229 *     DETERMINE DELTA MASS VIA REJECTION METHOD.
8230           DMAX = SRT - AVMASS-0.005
8231           DMIN = 1.078
8232           IF((n12.ge.13).and.(n12.le.16))then
8233 * N*(1440) production
8234           IF(DMAX.LT.1.44) THEN
8235           FM=FNS(DMAX,SRT,0.)
8236           ELSE
8237
8238 clin-10/25/02 get rid of argument usage mismatch in FNS():
8239              xdmass=1.44
8240 c          FM=FNS(1.44,SRT,1.)
8241           FM=FNS(xdmass,SRT,1.)
8242 clin-10/25/02-end
8243
8244           ENDIF
8245           IF(FM.EQ.0.)FM=1.E-09
8246           NTRY2=0
8247 11        DM=RANART(NSEED)*(DMAX-DMIN)+DMIN
8248           NTRY2=NTRY2+1
8249           IF((RANART(NSEED).GT.FNS(DM,SRT,1.)/FM).AND.
8250      1    (NTRY2.LE.10)) GO TO 11
8251
8252 clin-2/26/03 limit the N* mass below a certain value
8253 c     (here taken as its central value + 2* B-W fullwidth):
8254           if(dm.gt.2.14) goto 11
8255
8256               GO TO 13
8257               ENDIF
8258                     IF((n12.ge.17).AND.(N12.LE.36))then
8259 * N*(1535) production
8260           IF(DMAX.LT.1.535) THEN
8261           FM=FD5(DMAX,SRT,0.)
8262           ELSE
8263
8264 clin-10/25/02 get rid of argument usage mismatch in FNS():
8265              xdmass=1.535
8266 c          FM=FD5(1.535,SRT,1.)
8267           FM=FD5(xdmass,SRT,1.)
8268 clin-10/25/02-end
8269
8270           ENDIF
8271           IF(FM.EQ.0.)FM=1.E-09
8272           NTRY1=0
8273 12        DM = RANART(NSEED) * (DMAX-DMIN) + DMIN
8274           NTRY1=NTRY1+1
8275           IF((RANART(NSEED) .GT. FD5(DM,SRT,1.)/FM).AND.
8276      1    (NTRY1.LE.10)) GOTO 12
8277
8278 clin-2/26/03 limit the N* mass below a certain value
8279 c     (here taken as its central value + 2* B-W fullwidth):
8280           if(dm.gt.1.84) goto 12
8281
8282              ENDIF
8283 13       CONTINUE
8284 *-------------------------------------------------------
8285 * RELABLE BARYON I1 AND I2
8286 *13 D(++)+D(-)--> N*(+)(14)+n
8287           IF(N12.EQ.13)THEN
8288           IF(RANART(NSEED).LE.0.5)THEN
8289           LB(I2)=11
8290           E(I2)=DM
8291          LB(I1)=2
8292          E(I1)=AMN
8293           ELSE
8294           LB(I1)=11
8295           E(I1)=DM
8296          LB(I2)=2
8297          E(I2)=AMN
8298           ENDIF
8299          go to 200
8300           ENDIF
8301 *14 D(++)+D(-)--> N*(0)(14)+P
8302           IF(N12.EQ.14)THEN
8303           IF(RANART(NSEED).LE.0.5)THEN
8304           LB(I2)=10
8305           E(I2)=DM
8306          LB(I1)=1
8307          E(I1)=AMP
8308           ELSE
8309           LB(I1)=10
8310           E(I1)=DM
8311          LB(I2)=1
8312          E(I2)=AMP
8313           ENDIF
8314          go to 200
8315           ENDIF
8316 *15 D(+)+D(0)--> N*(+)(14)+n
8317           IF(N12.EQ.15)THEN
8318           IF(RANART(NSEED).LE.0.5)THEN
8319           LB(I2)=11
8320           E(I2)=DM
8321          LB(I1)=2
8322          E(I1)=AMN
8323           ELSE
8324           LB(I1)=11
8325           E(I1)=DM
8326          LB(I2)=2
8327          E(I2)=AMN
8328           ENDIF
8329          go to 200
8330           ENDIF
8331 *16 D(+)+D(0)--> N*(0)(14)+P
8332           IF(N12.EQ.16)THEN
8333           IF(RANART(NSEED).LE.0.5)THEN
8334           LB(I2)=10
8335           E(I2)=DM
8336          LB(I1)=1
8337          E(I1)=AMP
8338           ELSE
8339           LB(I1)=10
8340           E(I1)=DM
8341          LB(I2)=1
8342          E(I2)=AMP
8343           ENDIF
8344          go to 200
8345           ENDIF
8346 *17 D(++)+D(0)--> N*(+)(14)+P
8347           IF(N12.EQ.17)THEN
8348           LB(I2)=13
8349           E(I2)=DM
8350          LB(I1)=1
8351          E(I1)=AMP
8352          go to 200
8353           ENDIF
8354 *18 D(++)+D(-)--> N*(0)(15)+P
8355           IF(N12.EQ.18)THEN
8356           IF(RANART(NSEED).LE.0.5)THEN
8357           LB(I2)=12
8358           E(I2)=DM
8359          LB(I1)=1
8360          E(I1)=AMP
8361           ELSE
8362           LB(I1)=12
8363           E(I1)=DM
8364          LB(I2)=1
8365          E(I2)=AMP
8366           ENDIF
8367          go to 200
8368           ENDIF
8369 *19 D(++)+D(-)--> N*(+)(15)+N
8370           IF(N12.EQ.19)THEN
8371           IF(RANART(NSEED).LE.0.5)THEN
8372           LB(I2)=13
8373           E(I2)=DM
8374          LB(I1)=2
8375          E(I1)=AMN
8376           ELSE
8377           LB(I1)=13
8378           E(I1)=DM
8379          LB(I2)=2
8380          E(I2)=AMN
8381           ENDIF
8382          go to 200
8383           ENDIF
8384 *20 D(+)+D(+)--> N*(+)(15)+P
8385           IF(N12.EQ.20)THEN
8386           IF(RANART(NSEED).LE.0.5)THEN
8387           LB(I2)=13
8388           E(I2)=DM
8389          LB(I1)=1
8390          E(I1)=AMP
8391           ELSE
8392           LB(I1)=13
8393           E(I1)=DM
8394          LB(I2)=1
8395          E(I2)=AMP
8396           ENDIF
8397          go to 200
8398           ENDIF
8399 *21 D(+)+D(0)--> N*(+)(15)+N
8400           IF(N12.EQ.21)THEN
8401           IF(RANART(NSEED).LE.0.5)THEN
8402           LB(I2)=13
8403           E(I2)=DM
8404          LB(I1)=2
8405          E(I1)=AMN
8406           ELSE
8407           LB(I1)=13
8408           E(I1)=DM
8409          LB(I2)=2
8410          E(I2)=AMN
8411           ENDIF
8412          go to 200
8413           ENDIF
8414 *22 D(+)+D(0)--> N*(0)(15)+P
8415           IF(N12.EQ.22)THEN
8416           IF(RANART(NSEED).LE.0.5)THEN
8417           LB(I2)=12
8418           E(I2)=DM
8419          LB(I1)=1
8420          E(I1)=AMP
8421           ELSE
8422           LB(I1)=12
8423           E(I1)=DM
8424          LB(I2)=1
8425          E(I2)=AMP
8426           ENDIF
8427          go to 200
8428           ENDIF
8429 *23 D(+)+D(-)--> N*(0)(15)+N
8430           IF(N12.EQ.23)THEN
8431           IF(RANART(NSEED).LE.0.5)THEN
8432           LB(I2)=12
8433           E(I2)=DM
8434          LB(I1)=2
8435          E(I1)=AMN
8436           ELSE
8437           LB(I1)=12
8438           E(I1)=DM
8439          LB(I2)=2
8440          E(I2)=AMN
8441           ENDIF
8442          go to 200
8443           ENDIF
8444 *24 D(0)+D(0)--> N*(0)(15)+N
8445           IF(N12.EQ.24)THEN
8446           LB(I2)=12
8447           E(I2)=DM
8448          LB(I1)=2
8449          E(I1)=AMN
8450          go to 200
8451           ENDIF
8452 *25 N*(+)+N*(+)--> N*(0)(15)+P
8453           IF(N12.EQ.25)THEN
8454           LB(I2)=12
8455           E(I2)=DM
8456          LB(I1)=1
8457          E(I1)=AMP
8458          go to 200
8459           ENDIF
8460 *26 N*(0)+N*(0)--> N*(0)(15)+N
8461           IF(N12.EQ.26)THEN
8462           LB(I2)=12
8463           E(I2)=DM
8464          LB(I1)=2
8465          E(I1)=AMN
8466          go to 200
8467           ENDIF
8468 *27 N*(+)+N*(0)--> N*(+)(15)+N
8469           IF(N12.EQ.27)THEN
8470           IF(RANART(NSEED).LE.0.5)THEN
8471           LB(I2)=13
8472           E(I2)=DM
8473          LB(I1)=2
8474          E(I1)=AMN
8475           ELSE
8476           LB(I1)=13
8477           E(I1)=DM
8478          LB(I2)=2
8479          E(I2)=AMN
8480           ENDIF
8481          go to 200
8482           ENDIF
8483 *28 N*(+)+N*(0)--> N*(0)(15)+P
8484           IF(N12.EQ.28)THEN
8485           IF(RANART(NSEED).LE.0.5)THEN
8486           LB(I2)=12
8487           E(I2)=DM
8488          LB(I1)=1
8489          E(I1)=AMP
8490           ELSE
8491           LB(I1)=12
8492           E(I1)=DM
8493          LB(I2)=1
8494          E(I2)=AMP
8495           ENDIF
8496          go to 200
8497           ENDIF
8498 *27 N*(+)+N*(0)--> N*(+)(15)+N
8499           IF(N12.EQ.27)THEN
8500           IF(RANART(NSEED).LE.0.5)THEN
8501           LB(I2)=13
8502           E(I2)=DM
8503          LB(I1)=2
8504          E(I1)=AMN
8505           ELSE
8506           LB(I1)=13
8507           E(I1)=DM
8508          LB(I2)=2
8509          E(I2)=AMN
8510           ENDIF
8511          go to 200
8512           ENDIF
8513 *29 N*(+)+D(+)--> N*(+)(15)+P
8514           IF(N12.EQ.29)THEN
8515           IF(RANART(NSEED).LE.0.5)THEN
8516           LB(I2)=13
8517           E(I2)=DM
8518          LB(I1)=1
8519          E(I1)=AMP
8520           ELSE
8521           LB(I1)=13
8522           E(I1)=DM
8523          LB(I2)=1
8524          E(I2)=AMP
8525           ENDIF
8526          go to 200
8527           ENDIF
8528 *30 N*(+)+D(0)--> N*(+)(15)+N
8529           IF(N12.EQ.30)THEN
8530           IF(RANART(NSEED).LE.0.5)THEN
8531           LB(I2)=13
8532           E(I2)=DM
8533          LB(I1)=2
8534          E(I1)=AMN
8535           ELSE
8536           LB(I1)=13
8537           E(I1)=DM
8538          LB(I2)=2
8539          E(I2)=AMN
8540           ENDIF
8541          go to 200
8542           ENDIF
8543 *31 N*(+)+D(-)--> N*(0)(15)+N
8544           IF(N12.EQ.31)THEN
8545           IF(RANART(NSEED).LE.0.5)THEN
8546           LB(I2)=12
8547           E(I2)=DM
8548          LB(I1)=2
8549          E(I1)=AMN
8550           ELSE
8551           LB(I1)=12
8552           E(I1)=DM
8553          LB(I2)=2
8554          E(I2)=AMN
8555           ENDIF
8556          go to 200
8557           ENDIF
8558 *32 N*(0)+D(++)--> N*(+)(15)+P
8559           IF(N12.EQ.32)THEN
8560           IF(RANART(NSEED).LE.0.5)THEN
8561           LB(I2)=13
8562           E(I2)=DM
8563          LB(I1)=1
8564          E(I1)=AMP
8565           ELSE
8566           LB(I1)=13
8567           E(I1)=DM
8568          LB(I2)=1
8569          E(I2)=AMP
8570           ENDIF
8571          go to 200
8572           ENDIF
8573 *33 N*(0)+D(+)--> N*(+)(15)+N
8574           IF(N12.EQ.33)THEN
8575           IF(RANART(NSEED).LE.0.5)THEN
8576           LB(I2)=13
8577           E(I2)=DM
8578          LB(I1)=2
8579          E(I1)=AMN
8580           ELSE
8581           LB(I1)=13
8582           E(I1)=DM
8583          LB(I2)=2
8584          E(I2)=AMN
8585           ENDIF
8586          go to 200
8587           ENDIF
8588 *34 N*(0)+D(+)--> N*(0)(15)+P
8589           IF(N12.EQ.34)THEN
8590           IF(RANART(NSEED).LE.0.5)THEN
8591           LB(I2)=12
8592           E(I2)=DM
8593          LB(I1)=1
8594          E(I1)=AMP
8595           ELSE
8596           LB(I1)=12
8597           E(I1)=DM
8598          LB(I2)=1
8599          E(I2)=AMP
8600           ENDIF
8601          go to 200
8602           ENDIF
8603 *35 N*(0)+D(0)--> N*(0)(15)+N
8604           IF(N12.EQ.35)THEN
8605           IF(RANART(NSEED).LE.0.5)THEN
8606           LB(I2)=12
8607           E(I2)=DM
8608          LB(I1)=2
8609          E(I1)=AMN
8610           ELSE
8611           LB(I1)=12
8612           E(I1)=DM
8613          LB(I2)=2
8614          E(I2)=AMN
8615           ENDIF
8616          go to 200
8617           ENDIF
8618 *36 N*(+)+D(0)--> N*(0)(15)+P
8619           IF(N12.EQ.36)THEN
8620           IF(RANART(NSEED).LE.0.5)THEN
8621           LB(I2)=12
8622           E(I2)=DM
8623          LB(I1)=1
8624          E(I1)=AMP
8625           ELSE
8626           LB(I1)=12
8627           E(I1)=DM
8628          LB(I2)=1
8629          E(I2)=AMP
8630           ENDIF
8631          go to 200
8632           ENDIF
8633 1012         continue
8634          iblock=55
8635          lb1=lb(i1)
8636          lb2=lb(i2)
8637          ich=iabs(lb1*lb2)
8638 *-------------------------------------------------------
8639 * RELABLE BARYON I1 AND I2 in the reabsorption processes
8640 *37 D(++)+D(-)--> n+p
8641           IF(ich.EQ.9*6)THEN
8642           IF(RANART(NSEED).LE.0.5)THEN
8643           LB(I2)=1
8644           E(I2)=amp
8645          LB(I1)=2
8646          E(I1)=AMN
8647           ELSE
8648           LB(I1)=1
8649           E(I1)=amp
8650          LB(I2)=2
8651          E(I2)=AMN
8652           ENDIF
8653          go to 200
8654           ENDIF
8655 *38 D(+)+D(0)--> n+p
8656           IF(ich.EQ.8*7)THEN
8657           IF(RANART(NSEED).LE.0.5)THEN
8658           LB(I2)=1
8659           E(I2)=amp
8660          LB(I1)=2
8661          E(I1)=AMN
8662           ELSE
8663           LB(I1)=1
8664           E(I1)=amp
8665          LB(I2)=2
8666          E(I2)=AMN
8667           ENDIF
8668          go to 200
8669           ENDIF
8670 *39 D(++)+D(0)--> p+p
8671           IF(ich.EQ.9*7)THEN
8672           LB(I2)=1
8673           E(I2)=amp
8674          LB(I1)=1
8675          E(I1)=AMP
8676          go to 200
8677           ENDIF
8678 *40 D(+)+D(+)--> p+p
8679           IF(ich.EQ.8*8)THEN
8680           LB(I2)=1
8681           E(I2)=amp
8682          LB(I1)=1
8683          E(I1)=AMP
8684           go to 200
8685           ENDIF
8686 *41 D(+)+D(-)--> n+n
8687           IF(ich.EQ.8*6)THEN
8688           LB(I2)=2
8689           E(I2)=amn
8690          LB(I1)=2
8691          E(I1)=AMN
8692           go to 200
8693           ENDIF
8694 *42 D(0)+D(0)--> n+n
8695           IF(ich.EQ.6*6)THEN
8696           LB(I2)=2
8697           E(I2)=amn
8698          LB(I1)=2
8699          E(I1)=AMN
8700          go to 200
8701           ENDIF
8702 *43 N*(+)+N*(+)--> p+p
8703           IF(ich.EQ.11*11.or.ich.eq.13*13.or.ich.eq.11*13)THEN
8704           LB(I2)=1
8705           E(I2)=amp
8706          LB(I1)=1
8707          E(I1)=AMP
8708          go to 200
8709           ENDIF
8710 *44 N*(0)(1440)+N*(0)--> n+n
8711           IF(ich.EQ.10*10.or.ich.eq.12*12.or.ich.eq.10*12)THEN
8712           LB(I2)=2
8713           E(I2)=amn
8714          LB(I1)=2
8715          E(I1)=AMN
8716          go to 200
8717           ENDIF
8718 *45 N*(+)+N*(0)--> n+p
8719           IF(ich.EQ.10*11.or.ich.eq.12*13.or.ich.
8720      &    eq.10*13.or.ich.eq.11*12)THEN
8721           IF(RANART(NSEED).LE.0.5)THEN
8722           LB(I2)=1
8723           E(I2)=amp
8724          LB(I1)=2
8725          E(I1)=AMN
8726           ELSE
8727           LB(I1)=1
8728           E(I1)=amp
8729          LB(I2)=2
8730          E(I2)=AMN
8731           ENDIF
8732          go to 200
8733           ENDIF
8734 *46 N*(+)+D(+)--> p+p
8735           IF(ich.eq.11*8.or.ich.eq.13*8)THEN
8736           LB(I2)=1
8737           E(I2)=amp
8738          LB(I1)=1
8739          E(I1)=AMP
8740           go to 200
8741           ENDIF
8742 *47 N*(+)+D(0)--> n+p
8743           IF(ich.EQ.11*7.or.ich.eq.13*7)THEN
8744           IF(RANART(NSEED).LE.0.5)THEN
8745           LB(I2)=1
8746           E(I2)=amp
8747          LB(I1)=2
8748          E(I1)=AMN
8749           ELSE
8750           LB(I1)=1
8751           E(I1)=amp
8752          LB(I2)=2
8753          E(I2)=AMN
8754           ENDIF
8755          go to 200
8756           ENDIF
8757 *48 N*(+)+D(-)--> n+n
8758           IF(ich.EQ.11*6.or.ich.eq.13*6)THEN
8759           LB(I2)=2
8760           E(I2)=amn
8761          LB(I1)=2
8762          E(I1)=AMN
8763           go to 200
8764           ENDIF
8765 *49 N*(0)+D(++)--> p+p
8766           IF(ich.EQ.10*9.or.ich.eq.12*9)THEN
8767           LB(I2)=1
8768           E(I2)=amp
8769          LB(I1)=1
8770          E(I1)=AMP
8771          go to 200
8772           ENDIF
8773 *50 N*(0)+D(0)--> n+n
8774           IF(ich.EQ.10*7.or.ich.eq.12*7)THEN
8775           LB(I2)=2
8776           E(I2)=amn
8777          LB(I1)=2
8778          E(I1)=AMN
8779           go to 200
8780           ENDIF
8781 *51 N*(0)+D(+)--> n+p
8782           IF(ich.EQ.10*8.or.ich.eq.12*8)THEN
8783           IF(RANART(NSEED).LE.0.5)THEN
8784           LB(I2)=2
8785           E(I2)=amn
8786          LB(I1)=1
8787          E(I1)=AMP
8788           ELSE
8789           LB(I1)=2
8790           E(I1)=amn
8791          LB(I2)=1
8792          E(I2)=AMP
8793           ENDIF
8794          go to 200
8795           ENDIF
8796          lb(i1)=1
8797          e(i1)=amp
8798          lb(i2)=2
8799          e(i2)=amn
8800 * CALCULATE THE MAGNITUDE OF THE FINAL MOMENTUM THROUGH
8801 * ENERGY CONSERVATION
8802 * resonance production or absorption in resonance+resonance collisions is
8803 * assumed to have the same pt distribution as pp
8804 200       EM1=E(I1)
8805           EM2=E(I2)
8806           PR2   = (SRT**2 - EM1**2 - EM2**2)**2
8807      1                - 4.0 * (EM1*EM2)**2
8808           IF(PR2.LE.0.)PR2=1.e-09
8809           PR=SQRT(PR2)/(2.*SRT)
8810              if(srt.le.2.14)C1= 1.0 - 2.0 * RANART(NSEED)
8811          if(srt.gt.2.14.and.srt.le.2.4)c1=anga(srt,iseed)
8812          if(srt.gt.2.4)then
8813
8814 clin-10/25/02 get rid of argument usage mismatch in PTR():
8815              xptr=0.33*pr
8816 c         cc1=ptr(0.33*pr,iseed)
8817          cc1=ptr(xptr,iseed)
8818 clin-10/25/02-end
8819
8820          c1=sqrt(pr**2-cc1**2)/pr
8821          endif
8822           T1   = 2.0 * PI * RANART(NSEED)
8823        if(ianti.eq.1 .and. lb(i1).ge.1 .and. lb(i2).ge.1)then
8824          lb(i1) = -lb(i1)
8825          lb(i2) = -lb(i2)
8826        endif
8827          ENDIF
8828 *COM: SET THE NEW MOMENTUM COORDINATES
8829 107   S1   = SQRT( 1.0 - C1**2 )
8830       S2  =  SQRT( 1.0 - C2**2 )
8831       CT1  = COS(T1)
8832       ST1  = SIN(T1)
8833       CT2  = COS(T2)
8834       ST2  = SIN(T2)
8835       PZ   = PR * ( C1*C2 - S1*S2*CT1 )
8836       SS   = C2 * S1 * CT1  +  S2 * C1
8837       PX   = PR * ( SS*CT2 - S1*ST1*ST2 )
8838       PY   = PR * ( SS*ST2 + S1*ST1*CT2 )
8839       RETURN
8840 * FOR THE DD-->KAON+X PROCESS, FIND MOMENTUM OF THE FINAL PARTICLES IN
8841 * THE NUCLEUS-NUCLEUS CMS.
8842 306     CONTINUE
8843 csp11/21/01 phi production
8844               if(XSK5/sigK.gt.RANART(NSEED))then
8845               pz1=p(3,i1)
8846               pz2=p(3,i2)
8847                 LB(I1) = 1 + int(2 * RANART(NSEED))
8848                 LB(I2) = 1 + int(2 * RANART(NSEED))
8849               nnn=nnn+1
8850                 LPION(NNN,IRUN)=29
8851                 EPION(NNN,IRUN)=APHI
8852                 iblock = 222
8853               GO TO 208
8854                ENDIF
8855               iblock=10
8856                 if(ianti .eq. 1)iblock=-10
8857               pz1=p(3,i1)
8858               pz2=p(3,i2)
8859 * DETERMINE THE CHARGE STATES OF PARTICLES IN THE FINAL STATE
8860               nnn=nnn+1
8861                 LPION(NNN,IRUN)=23
8862                 EPION(NNN,IRUN)=Aka
8863               if(srt.le.2.63)then
8864 * only lambda production is possible
8865 * (1.1)P+P-->p+L+kaon+
8866               ic=1
8867                 LB(I1) = 1 + int(2 * RANART(NSEED))
8868               LB(I2)=14
8869               GO TO 208
8870                 ENDIF
8871        if(srt.le.2.74.and.srt.gt.2.63)then
8872 * both Lambda and sigma production are possible
8873               if(XSK1/(XSK1+XSK2).gt.RANART(NSEED))then
8874 * lambda production
8875               ic=1
8876                 LB(I1) = 1 + int(2 * RANART(NSEED))
8877               LB(I2)=14
8878               else
8879 * sigma production
8880                 LB(I1) = 1 + int(2 * RANART(NSEED))
8881                 LB(I2) = 15 + int(3 * RANART(NSEED))
8882               ic=2
8883               endif
8884               GO TO 208
8885        endif
8886        if(srt.le.2.77.and.srt.gt.2.74)then
8887 * then pp-->Delta lamda kaon can happen
8888               if(xsk1/(xsk1+xsk2+xsk3).gt.RANART(NSEED))then
8889 * * (1.1)P+P-->p+L+kaon+
8890               ic=1
8891                 LB(I1) = 1 + int(2 * RANART(NSEED))
8892               LB(I2)=14
8893               go to 208
8894               else
8895               if(xsk2/(xsk2+xsk3).gt.RANART(NSEED))then
8896 * pp-->psk
8897               ic=2
8898                 LB(I1) = 1 + int(2 * RANART(NSEED))
8899                 LB(I2) = 15 + int(3 * RANART(NSEED))
8900               else
8901 * pp-->D+l+k
8902               ic=3
8903                 LB(I1) = 6 + int(4 * RANART(NSEED))
8904               lb(i2)=14
8905               endif
8906               GO TO 208
8907               endif
8908        endif
8909        if(srt.gt.2.77)then
8910 * all four channels are possible
8911               if(xsk1/(xsk1+xsk2+xsk3+xsk4).gt.RANART(NSEED))then
8912 * p lambda k production
8913               ic=1
8914                 LB(I1) = 1 + int(2 * RANART(NSEED))
8915               LB(I2)=14
8916               go to 208
8917        else
8918           if(xsk3/(xsk2+xsk3+xsk4).gt.RANART(NSEED))then
8919 * delta l K production
8920               ic=3
8921                 LB(I1) = 6 + int(4 * RANART(NSEED))
8922               lb(i2)=14
8923               go to 208
8924           else
8925               if(xsk2/(xsk2+xsk4).gt.RANART(NSEED))then
8926 * n sigma k production
8927                 LB(I1) = 1 + int(2 * RANART(NSEED))
8928                 LB(I2) = 15 + int(3 * RANART(NSEED))
8929               ic=2
8930               else
8931 * D sigma K
8932               ic=4
8933                 LB(I1) = 6 + int(4 * RANART(NSEED))
8934                 LB(I2) = 15 + int(3 * RANART(NSEED))
8935               endif
8936               go to 208
8937           endif
8938        endif
8939        endif
8940 208             continue
8941          if(ianti.eq.1 .and. lb(i1).ge.1 .and. lb(i2).ge.1)then
8942           lb(i1) = - lb(i1)
8943           lb(i2) = - lb(i2)
8944           if(LPION(NNN,IRUN) .eq. 23)LPION(NNN,IRUN)=21
8945          endif
8946        lbi1=lb(i1)
8947        lbi2=lb(i2)
8948 * KEEP ALL COORDINATES OF PARTICLE 2 FOR POSSIBLE PHASE SPACE CHANGE
8949            NTRY1=0
8950 129        CALL BBKAON(ic,SRT,PX3,PY3,PZ3,DM3,PX4,PY4,PZ4,DM4,
8951      &  PPX,PPY,PPZ,icou1)
8952        NTRY1=NTRY1+1
8953        if((icou1.lt.0).AND.(NTRY1.LE.20))GO TO 129
8954 c       if(icou1.lt.0)return
8955 * ROTATE THE MOMENTA OF PARTICLES IN THE CMS OF P1+P2
8956        CALL ROTATE(PX,PY,PZ,PX3,PY3,PZ3)
8957        CALL ROTATE(PX,PY,PZ,PX4,PY4,PZ4)
8958        CALL ROTATE(PX,PY,PZ,PPX,PPY,PPZ)
8959 * FIND THE MOMENTUM OF PARTICLES IN THE FINAL STATE IN THE NUCLEUS-
8960 * NUCLEUS CMS. FRAME
8961 * (1) for the necleon/delta
8962 *             LORENTZ-TRANSFORMATION INTO LAB FRAME FOR DELTA1
8963               E1CM    = SQRT (dm3**2 + PX3**2 + PY3**2 + PZ3**2)
8964               P1BETA  = PX3*BETAX + PY3*BETAY + PZ3*BETAZ
8965               TRANSF  = GAMMA * ( GAMMA * P1BETA / (GAMMA + 1) + E1CM )
8966               Pt1i1 = BETAX * TRANSF + PX3
8967               Pt2i1 = BETAY * TRANSF + PY3
8968               Pt3i1 = BETAZ * TRANSF + PZ3
8969              Eti1   = DM3
8970 * (2) for the lambda/sigma
8971                 E2CM    = SQRT (dm4**2 + PX4**2 + PY4**2 + PZ4**2)
8972                 P2BETA  = PX4*BETAX+PY4*BETAY+PZ4*BETAZ
8973                 TRANSF  = GAMMA * (GAMMA*P2BETA / (GAMMA + 1.) + E2CM)
8974                 Pt1I2 = BETAX * TRANSF + PX4
8975                 Pt2I2 = BETAY * TRANSF + PY4
8976                 Pt3I2 = BETAZ * TRANSF + PZ4
8977               EtI2   = DM4
8978 * GET the kaon'S MOMENTUM AND COORDINATES IN NUCLEUS-NUCLEUS CMS. FRAME
8979                 EPCM=SQRT(aka**2+PPX**2+PPY**2+PPZ**2)
8980                 PPBETA=PPX*BETAX+PPY*BETAY+PPZ*BETAZ
8981                 TRANSF=GAMMA*(GAMMA*PPBETA/(GAMMA+1.)+EPCM)
8982                 PPION(1,NNN,IRUN)=BETAX*TRANSF+PPX
8983                 PPION(2,NNN,IRUN)=BETAY*TRANSF+PPY
8984                 PPION(3,NNN,IRUN)=BETAZ*TRANSF+PPZ
8985 clin-5/2008:
8986                 dppion(nnn,irun)=dpertp(i1)*dpertp(i2)
8987 clin-5/2008:
8988 c2007        X01 = 1.0 - 2.0 * RANART(NSEED)
8989 c            Y01 = 1.0 - 2.0 * RANART(NSEED)
8990 c            Z01 = 1.0 - 2.0 * RANART(NSEED)
8991 c        IF ((X01*X01+Y01*Y01+Z01*Z01) .GT. 1.0) GOTO 2007
8992 c                RPION(1,NNN,IRUN)=R(1,I1)+0.5*x01
8993 c                RPION(2,NNN,IRUN)=R(2,I1)+0.5*y01
8994 c                RPION(3,NNN,IRUN)=R(3,I1)+0.5*z01
8995                     RPION(1,NNN,IRUN)=R(1,I1)
8996                     RPION(2,NNN,IRUN)=R(2,I1)
8997                     RPION(3,NNN,IRUN)=R(3,I1)
8998 c
8999 * assign the nucleon/delta and lambda/sigma to i1 or i2 to keep the
9000 * leadng particle behaviour
9001 C              if((pt1i1*px1+pt2i1*py1+pt3i1*pz1).gt.0)then
9002               p(1,i1)=pt1i1
9003               p(2,i1)=pt2i1
9004               p(3,i1)=pt3i1
9005               e(i1)=eti1
9006               lb(i1)=lbi1
9007               p(1,i2)=pt1i2
9008               p(2,i2)=pt2i2
9009               p(3,i2)=pt3i2
9010               e(i2)=eti2
9011               lb(i2)=lbi2
9012                 PX1     = P(1,I1)
9013                 PY1     = P(2,I1)
9014                 PZ1     = P(3,I1)
9015               EM1       = E(I1)
9016                 ID(I1)  = 2
9017                 ID(I2)  = 2
9018                 ID1     = ID(I1)
9019         LB1=LB(I1)
9020         LB2=LB(I2)
9021         AM1=EM1
9022        am2=em2
9023         E1= SQRT( EM1**2 + PX1**2 + PY1**2 + PZ1**2 )
9024        RETURN
9025
9026 clin-6/2008 D+D->Deuteron+pi:
9027 *     FIND MOMENTUM OF THE FINAL PARTICLES IN THE NUCLEUS-NUCLEUS CMS.
9028  108   CONTINUE
9029            if(idpert.eq.1.and.ipert1.eq.1.and.npertd.ge.1) then
9030 c     For idpert=1: we produce npertd pert deuterons:
9031               ndloop=npertd
9032            elseif(idpert.eq.2.and.npertd.ge.1) then
9033 c     For idpert=2: we first save information for npertd pert deuterons;
9034 c     at the last ndloop we create the regular deuteron+pi
9035 c     and those pert deuterons:
9036               ndloop=npertd+1
9037            else
9038 c     Just create the regular deuteron+pi:
9039               ndloop=1
9040            endif
9041 c
9042            dprob1=sdprod/sig/float(npertd)
9043            do idloop=1,ndloop
9044               CALL bbdangle(pxd,pyd,pzd,nt,ipert1,ianti,idloop,pfinal,
9045      1 dprob1,lbm)
9046               CALL ROTATE(PX,PY,PZ,PXd,PYd,PZd)
9047 *     LORENTZ-TRANSFORMATION OF THE MOMENTUM OF PARTICLES IN THE FINAL STATE
9048 *     FROM THE NN CMS FRAME INTO THE GLOBAL CMS FRAME:
9049 *     For the Deuteron:
9050               xmass=xmd
9051               E1dCM=SQRT(xmass**2+PXd**2+PYd**2+PZd**2)
9052               P1dBETA=PXd*BETAX+PYd*BETAY+PZd*BETAZ
9053               TRANSF=GAMMA*(GAMMA*P1dBETA/(GAMMA+1.)+E1dCM)
9054               pxi1=BETAX*TRANSF+PXd
9055               pyi1=BETAY*TRANSF+PYd
9056               pzi1=BETAZ*TRANSF+PZd
9057               if(ianti.eq.0)then
9058                  lbd=42
9059               else
9060                  lbd=-42
9061               endif
9062               if(idpert.eq.1.and.ipert1.eq.1.and.npertd.ge.1) then
9063 cccc  Perturbative production for idpert=1:
9064                  nnn=nnn+1
9065                  PPION(1,NNN,IRUN)=pxi1
9066                  PPION(2,NNN,IRUN)=pyi1
9067                  PPION(3,NNN,IRUN)=pzi1
9068                  EPION(NNN,IRUN)=xmd
9069                  LPION(NNN,IRUN)=lbd
9070                  RPION(1,NNN,IRUN)=R(1,I1)
9071                  RPION(2,NNN,IRUN)=R(2,I1)
9072                  RPION(3,NNN,IRUN)=R(3,I1)
9073 clin-6/2008 assign the perturbative probability:
9074                  dppion(NNN,IRUN)=sdprod/sig/float(npertd)
9075               elseif(idpert.eq.2.and.idloop.le.npertd) then
9076 clin-6/2008 For idpert=2, we produce NPERTD perturbative (anti)deuterons
9077 c     only when a regular (anti)deuteron+pi is produced in NN collisions.
9078 c     First save the info for the perturbative deuterons:
9079                  ppd(1,idloop)=pxi1
9080                  ppd(2,idloop)=pyi1
9081                  ppd(3,idloop)=pzi1
9082                  lbpd(idloop)=lbd
9083               else
9084 cccc  Regular production:
9085 c     For the regular pion: do LORENTZ-TRANSFORMATION:
9086                  E(i1)=xmm
9087                  E2piCM=SQRT(xmm**2+PXd**2+PYd**2+PZd**2)
9088                  P2piBETA=-PXd*BETAX-PYd*BETAY-PZd*BETAZ
9089                  TRANSF=GAMMA*(GAMMA*P2piBETA/(GAMMA+1.)+E2piCM)
9090                  pxi2=BETAX*TRANSF-PXd
9091                  pyi2=BETAY*TRANSF-PYd
9092                  pzi2=BETAZ*TRANSF-PZd
9093                  p(1,i1)=pxi2
9094                  p(2,i1)=pyi2
9095                  p(3,i1)=pzi2
9096 c     Remove regular pion to check the equivalence
9097 c     between the perturbative and regular deuteron results:
9098 c                 E(i1)=0.
9099 c
9100                  LB(I1)=lbm
9101                  PX1=P(1,I1)
9102                  PY1=P(2,I1)
9103                  PZ1=P(3,I1)
9104                  EM1=E(I1)
9105                  ID(I1)=2
9106                  ID1=ID(I1)
9107                  E1=SQRT(EM1**2+PX1**2+PY1**2+PZ1**2)
9108                  lb1=lb(i1)
9109 c     For the regular deuteron:
9110                  p(1,i2)=pxi1
9111                  p(2,i2)=pyi1
9112                  p(3,i2)=pzi1
9113                  lb(i2)=lbd
9114                  lb2=lb(i2)
9115                  E(i2)=xmd
9116                  EtI2=E(I2)
9117                  ID(I2)=2
9118 c     For idpert=2: create the perturbative deuterons:
9119                  if(idpert.eq.2.and.idloop.eq.ndloop) then
9120                     do ipertd=1,npertd
9121                        nnn=nnn+1
9122                        PPION(1,NNN,IRUN)=ppd(1,ipertd)
9123                        PPION(2,NNN,IRUN)=ppd(2,ipertd)
9124                        PPION(3,NNN,IRUN)=ppd(3,ipertd)
9125                        EPION(NNN,IRUN)=xmd
9126                        LPION(NNN,IRUN)=lbpd(ipertd)
9127                        RPION(1,NNN,IRUN)=R(1,I1)
9128                        RPION(2,NNN,IRUN)=R(2,I1)
9129                        RPION(3,NNN,IRUN)=R(3,I1)
9130 clin-6/2008 assign the perturbative probability:
9131                        dppion(NNN,IRUN)=1./float(npertd)
9132                     enddo
9133                  endif
9134               endif
9135            enddo
9136            IBLOCK=501
9137            return
9138 clin-6/2008 D+D->Deuteron+pi over
9139
9140         END
9141 **********************************
9142 **********************************
9143 *                                                                      *
9144       SUBROUTINE INIT(MINNUM,MAXNUM,NUM,RADIUS,X0,Z0,P0,
9145      &                GAMMA,ISEED,MASS,IOPT)
9146 *                                                                      *
9147 *       PURPOSE:     PROVIDING INITIAL CONDITIONS FOR PHASE-SPACE      *
9148 *                    DISTRIBUTION OF TESTPARTICLES                     *
9149 *       VARIABLES:   (ALL INPUT)                                       *
9150 *         MINNUM  - FIRST TESTPARTICLE TREATED IN ONE RUN    (INTEGER) *
9151 *         MAXNUM  - LAST TESTPARTICLE TREATED IN ONE RUN     (INTEGER) *
9152 *         NUM     - NUMBER OF TESTPARTICLES PER NUCLEON      (INTEGER) *
9153 *         RADIUS  - RADIUS OF NUCLEUS "FM"                      (REAL) *
9154 *         X0,Z0   - DISPLACEMENT OF CENTER OF NUCLEUS IN X,Z-          *
9155 *                   DIRECTION "FM"                              (REAL) *
9156 *         P0      - MOMENTUM-BOOST IN C.M. FRAME "GEV/C"        (REAL) *
9157 *         GAMMA   - RELATIVISTIC GAMMA-FACTOR                   (REAL) *
9158 *         ISEED   - SEED FOR RANDOM-NUMBER GENERATOR         (INTEGER) *
9159 *         MASS    - TOTAL MASS OF THE SYSTEM                 (INTEGER) *
9160 *         IOPT    - OPTION FOR DIFFERENT OCCUPATION OF MOMENTUM        *
9161 *                   SPACE                                    (INTEGER) *
9162 *                                                                      *
9163 **********************************
9164       PARAMETER     (MAXSTR=150001,  AMU   = 0.9383)
9165       PARAMETER     (MAXX   =   20,  MAXZ  =    24)
9166       PARAMETER     (PI=3.1415926)
9167 *
9168       REAL              PTOT(3)
9169       COMMON  /AA/      R(3,MAXSTR)
9170 cc      SAVE /AA/
9171       COMMON  /BB/      P(3,MAXSTR)
9172 cc      SAVE /BB/
9173       COMMON  /CC/      E(MAXSTR)
9174 cc      SAVE /CC/
9175       COMMON  /DD/      RHO(-MAXX:MAXX,-MAXX:MAXX,-MAXZ:MAXZ),
9176      &                     RHOP(-MAXX:MAXX,-MAXX:MAXX,-MAXZ:MAXZ),
9177      &                     RHON(-MAXX:MAXX,-MAXX:MAXX,-MAXZ:MAXZ)
9178 cc      SAVE /DD/
9179       COMMON  /EE/      ID(MAXSTR),LB(MAXSTR)
9180 cc      SAVE /EE/
9181       common  /ss/      inout(20)
9182 cc      SAVE /ss/
9183       COMMON/RNDF77/NSEED
9184 cc      SAVE /RNDF77/
9185       SAVE
9186 *----------------------------------------------------------------------
9187 *     PREPARATION FOR LORENTZ-TRANSFORMATIONS
9188 *
9189       ISEED=ISEED
9190       IF (P0 .NE. 0.) THEN
9191         SIGN = P0 / ABS(P0)
9192       ELSE
9193         SIGN = 0.
9194       END IF
9195       BETA = SIGN * SQRT(GAMMA**2-1.)/GAMMA
9196 *-----------------------------------------------------------------------
9197 *     TARGET-ID = 1 AND PROJECTILE-ID = -1
9198 *
9199       IF (MINNUM .EQ. 1) THEN
9200         IDNUM = 1
9201       ELSE
9202         IDNUM = -1
9203       END IF
9204 *-----------------------------------------------------------------------
9205 *     IDENTIFICATION OF TESTPARTICLES AND ASSIGMENT OF RESTMASS
9206 *
9207 *     LOOP OVER ALL PARALLEL RUNS:
9208       DO 400 IRUN = 1,NUM
9209         DO 100 I = MINNUM+(IRUN-1)*MASS,MAXNUM+(IRUN-1)*MASS
9210           ID(I) = IDNUM
9211           E(I)  = AMU
9212   100   CONTINUE
9213 *-----------------------------------------------------------------------
9214 *       OCCUPATION OF COORDINATE-SPACE
9215 *
9216         DO 300 I = MINNUM+(IRUN-1)*MASS,MAXNUM+(IRUN-1)*MASS
9217   200     CONTINUE
9218             X = 1.0 - 2.0 * RANART(NSEED)
9219             Y = 1.0 - 2.0 * RANART(NSEED)
9220             Z = 1.0 - 2.0 * RANART(NSEED)
9221           IF ((X*X+Y*Y+Z*Z) .GT. 1.0) GOTO 200
9222           R(1,I) = X * RADIUS
9223           R(2,I) = Y * RADIUS
9224           R(3,I) = Z * RADIUS
9225   300   CONTINUE
9226   400 CONTINUE
9227 *=======================================================================
9228       IF (IOPT .NE. 3) THEN
9229 *-----
9230 *     OPTION 1: USE WOODS-SAXON PARAMETRIZATION FOR DENSITY AND
9231 *-----          CALCULATE LOCAL FERMI-MOMENTUM
9232 *
9233         RHOW0  = 0.168
9234         DO 1000 IRUN = 1,NUM
9235           DO 600 I = MINNUM+(IRUN-1)*MASS,MAXNUM+(IRUN-1)*MASS
9236   500       CONTINUE
9237               PX = 1.0 - 2.0 * RANART(NSEED)
9238               PY = 1.0 - 2.0 * RANART(NSEED)
9239               PZ = 1.0 - 2.0 * RANART(NSEED)
9240             IF (PX*PX+PY*PY+PZ*PZ .GT. 1.0) GOTO 500
9241             RDIST  = SQRT( R(1,I)**2 + R(2,I)**2 + R(3,I)**2 )
9242             RHOWS  = RHOW0 / (  1.0 + EXP( (RDIST-RADIUS) / 0.55 )  )
9243             PFERMI = 0.197 * (1.5 * PI*PI * RHOWS)**(1./3.)
9244 *-----
9245 *     OPTION 2: NUCLEAR MATTER CASE
9246             IF(IOPT.EQ.2) PFERMI=0.27
9247            if(iopt.eq.4) pfermi=0.
9248 *-----
9249             P(1,I) = PFERMI * PX
9250             P(2,I) = PFERMI * PY
9251             P(3,I) = PFERMI * PZ
9252   600     CONTINUE
9253 *
9254 *         SET TOTAL MOMENTUM TO 0 IN REST FRAME AND BOOST
9255 *
9256           DO 700 IDIR = 1,3
9257             PTOT(IDIR) = 0.0
9258   700     CONTINUE
9259           NPART = 0
9260           DO 900 I = MINNUM+(IRUN-1)*MASS,MAXNUM+(IRUN-1)*MASS
9261             NPART = NPART + 1
9262             DO 800 IDIR = 1,3
9263               PTOT(IDIR) = PTOT(IDIR) + P(IDIR,I)
9264   800       CONTINUE
9265   900     CONTINUE
9266           DO 950 I = MINNUM+(IRUN-1)*MASS,MAXNUM+(IRUN-1)*MASS
9267             DO 925 IDIR = 1,3
9268               P(IDIR,I) = P(IDIR,I) - PTOT(IDIR) / FLOAT(NPART)
9269   925       CONTINUE
9270 *           BOOST
9271             IF ((IOPT .EQ. 1).or.(iopt.eq.2)) THEN
9272               EPART = SQRT(P(1,I)**2+P(2,I)**2+P(3,I)**2+AMU**2)
9273               P(3,I) = GAMMA*(P(3,I) + BETA*EPART)
9274             ELSE
9275               P(3,I) = P(3,I) + P0
9276             END IF
9277   950     CONTINUE
9278  1000   CONTINUE
9279 *-----
9280       ELSE
9281 *-----
9282 *     OPTION 3: GIVE ALL NUCLEONS JUST A Z-MOMENTUM ACCORDING TO
9283 *               THE BOOST OF THE NUCLEI
9284 *
9285         DO 1200 IRUN = 1,NUM
9286           DO 1100 I = MINNUM+(IRUN-1)*MASS,MAXNUM+(IRUN-1)*MASS
9287             P(1,I) = 0.0
9288             P(2,I) = 0.0
9289             P(3,I) = P0
9290  1100     CONTINUE
9291  1200   CONTINUE
9292 *-----
9293       END IF
9294 *=======================================================================
9295 *     PUT PARTICLES IN THEIR POSITION IN COORDINATE-SPACE
9296 *     (SHIFT AND RELATIVISTIC CONTRACTION)
9297 *
9298       DO 1400 IRUN = 1,NUM
9299         DO 1300 I = MINNUM+(IRUN-1)*MASS,MAXNUM+(IRUN-1)*MASS
9300           R(1,I) = R(1,I) + X0
9301 * two nuclei in touch after contraction
9302           R(3,I) = (R(3,I)+Z0)/ GAMMA
9303 * two nuclei in touch before contraction
9304 c          R(3,I) = R(3,I) / GAMMA + Z0
9305  1300   CONTINUE
9306  1400 CONTINUE
9307 *
9308       RETURN
9309       END
9310 **********************************
9311 *                                                                      *
9312       SUBROUTINE DENS(IPOT,MASS,NUM,NESC)
9313 *                                                                      *
9314 *       PURPOSE:     CALCULATION OF LOCAL BARYON, MESON AND ENERGY     *
9315 *                    DENSITY FROM SPATIAL DISTRIBUTION OF TESTPARTICLES*
9316 *                                                                      *
9317 *       VARIABLES (ALL INPUT, ALL INTEGER)                             *
9318 *         MASS    -  MASS NUMBER OF THE SYSTEM                         *
9319 *         NUM     -  NUMBER OF TESTPARTICLES PER NUCLEON               *
9320 *                                                                      *
9321 *         NESC    -  NUMBER OF ESCAPED PARTICLES      (INTEGER,OUTPUT) *
9322 *                                                                      *
9323 **********************************
9324       PARAMETER     (MAXSTR= 150001,MAXR=1)
9325       PARAMETER     (MAXX   =    20,  MAXZ  =    24)
9326 *
9327       dimension pxl(-maxx:maxx,-maxx:maxx,-maxz:maxz),
9328      1          pyl(-maxx:maxx,-maxx:maxx,-maxz:maxz),
9329      2          pzl(-maxx:maxx,-maxx:maxx,-maxz:maxz)
9330       COMMON  /AA/      R(3,MAXSTR)
9331 cc      SAVE /AA/
9332       COMMON  /BB/      P(3,MAXSTR)
9333 cc      SAVE /BB/
9334       COMMON  /CC/      E(MAXSTR)
9335 cc      SAVE /CC/
9336       COMMON  /DD/      RHO(-MAXX:MAXX,-MAXX:MAXX,-MAXZ:MAXZ),
9337      &                     RHOP(-MAXX:MAXX,-MAXX:MAXX,-MAXZ:MAXZ),
9338      &                     RHON(-MAXX:MAXX,-MAXX:MAXX,-MAXZ:MAXZ)
9339 cc      SAVE /DD/
9340       COMMON  /DDpi/    piRHO(-MAXX:MAXX,-MAXX:MAXX,-MAXZ:MAXZ)
9341 cc      SAVE /DDpi/
9342       COMMON  /EE/      ID(MAXSTR),LB(MAXSTR)
9343 cc      SAVE /EE/
9344       common  /ss/  inout(20)
9345 cc      SAVE /ss/
9346       COMMON  /RR/  MASSR(0:MAXR)
9347 cc      SAVE /RR/
9348       common  /tt/  PEL(-maxx:maxx,-maxx:maxx,-maxz:maxz)
9349      &,rxy(-maxx:maxx,-maxx:maxx,-maxz:maxz)
9350 cc      SAVE /tt/
9351       common  /bbb/ bxx(-maxx:maxx,-maxx:maxx,-maxz:maxz),
9352      &byy(-maxx:maxx,-maxx:maxx,-maxz:maxz),
9353      &bzz(-maxx:maxx,-maxx:maxx,-maxz:maxz)
9354 *
9355       real zet(-45:45)
9356       SAVE
9357       data zet /
9358      4     1.,0.,0.,0.,0.,
9359      3     1.,0.,0.,0.,0.,0.,0.,0.,0.,0.,
9360      2     -1.,0.,0.,0.,0.,0.,0.,0.,0.,0.,
9361      1     0.,0.,0.,-1.,0.,1.,0.,-1.,0.,-1.,
9362      s     0.,-2.,-1.,0.,1.,0.,0.,0.,0.,-1.,
9363      e     0.,
9364      s     1.,0.,-1.,0.,1.,-1.,0.,1.,2.,0.,
9365      1     1.,0.,1.,0.,-1.,0.,1.,0.,0.,0.,
9366      2     -1.,0.,1.,0.,-1.,0.,1.,0.,0.,1.,
9367      3     0.,0.,0.,0.,0.,0.,0.,0.,0.,-1.,
9368      4     0.,0.,0.,0.,-1./
9369
9370       DO 300 IZ = -MAXZ,MAXZ
9371         DO 200 IY = -MAXX,MAXX
9372           DO 100 IX = -MAXX,MAXX
9373             RHO(IX,IY,IZ) = 0.0
9374             RHOn(IX,IY,IZ) = 0.0
9375             RHOp(IX,IY,IZ) = 0.0
9376             piRHO(IX,IY,IZ) = 0.0
9377            pxl(ix,iy,iz) = 0.0
9378            pyl(ix,iy,iz) = 0.0
9379            pzl(ix,iy,iz) = 0.0
9380            pel(ix,iy,iz) = 0.0
9381            bxx(ix,iy,iz) = 0.0
9382            byy(ix,iy,iz) = 0.0
9383            bzz(ix,iy,iz) = 0.0
9384   100     CONTINUE
9385   200   CONTINUE
9386   300 CONTINUE
9387 *
9388       NESC  = 0
9389       BIG   = 1.0 / ( 3.0 * FLOAT(NUM) )
9390       SMALL = 1.0 / ( 9.0 * FLOAT(NUM) )
9391 *
9392       MSUM=0
9393       DO 400 IRUN = 1,NUM
9394       MSUM=MSUM+MASSR(IRUN-1)
9395       DO 400 J=1,MASSr(irun)
9396       I=J+MSUM
9397         IX = NINT( R(1,I) )
9398         IY = NINT( R(2,I) )
9399         IZ = NINT( R(3,I) )
9400         IF( IX .LE. -MAXX .OR. IX .GE. MAXX .OR.
9401      &      IY .LE. -MAXX .OR. IY .GE. MAXX .OR.
9402      &      IZ .LE. -MAXZ .OR. IZ .GE. MAXZ )    THEN
9403           NESC = NESC + 1
9404         ELSE
9405 c
9406 csp01/04/02 include baryon density
9407           if(j.gt.mass)go to 30
9408 c         if( (lb(i).eq.1.or.lb(i).eq.2) .or.
9409 c    &    (lb(i).ge.6.and.lb(i).le.17) )then
9410 * (1) baryon density
9411           RHO(IX,  IY,  IZ  ) = RHO(IX,  IY,  IZ  ) + BIG
9412           RHO(IX+1,IY,  IZ  ) = RHO(IX+1,IY,  IZ  ) + SMALL
9413           RHO(IX-1,IY,  IZ  ) = RHO(IX-1,IY,  IZ  ) + SMALL
9414           RHO(IX,  IY+1,IZ  ) = RHO(IX,  IY+1,IZ  ) + SMALL
9415           RHO(IX,  IY-1,IZ  ) = RHO(IX,  IY-1,IZ  ) + SMALL
9416           RHO(IX,  IY,  IZ+1) = RHO(IX,  IY,  IZ+1) + SMALL
9417           RHO(IX,  IY,  IZ-1) = RHO(IX,  IY,  IZ-1) + SMALL
9418 * (2) CALCULATE THE PROTON DENSITY
9419          IF(ZET(LB(I)).NE.0)THEN
9420           RHOP(IX,  IY,  IZ  ) = RHOP(IX,  IY,  IZ  ) + BIG
9421           RHOP(IX+1,IY,  IZ  ) = RHOP(IX+1,IY,  IZ  ) + SMALL
9422           RHOP(IX-1,IY,  IZ  ) = RHOP(IX-1,IY,  IZ  ) + SMALL
9423           RHOP(IX,  IY+1,IZ  ) = RHOP(IX,  IY+1,IZ  ) + SMALL
9424           RHOP(IX,  IY-1,IZ  ) = RHOP(IX,  IY-1,IZ  ) + SMALL
9425           RHOP(IX,  IY,  IZ+1) = RHOP(IX,  IY,  IZ+1) + SMALL
9426           RHOP(IX,  IY,  IZ-1) = RHOP(IX,  IY,  IZ-1) + SMALL
9427          go to 40
9428          ENDIF
9429 * (3) CALCULATE THE NEUTRON DENSITY
9430          IF(ZET(LB(I)).EQ.0)THEN
9431           RHON(IX,  IY,  IZ  ) = RHON(IX,  IY,  IZ  ) + BIG
9432           RHON(IX+1,IY,  IZ  ) = RHON(IX+1,IY,  IZ  ) + SMALL
9433           RHON(IX-1,IY,  IZ  ) = RHON(IX-1,IY,  IZ  ) + SMALL
9434           RHON(IX,  IY+1,IZ  ) = RHON(IX,  IY+1,IZ  ) + SMALL
9435           RHON(IX,  IY-1,IZ  ) = RHON(IX,  IY-1,IZ  ) + SMALL
9436           RHON(IX,  IY,  IZ+1) = RHON(IX,  IY,  IZ+1) + SMALL
9437           RHON(IX,  IY,  IZ-1) = RHON(IX,  IY,  IZ-1) + SMALL
9438          go to 40
9439           END IF
9440 c           else    !! sp01/04/02
9441 * (4) meson density
9442 30              piRHO(IX,  IY,  IZ  ) = piRHO(IX,  IY,  IZ  ) + BIG
9443           piRHO(IX+1,IY,  IZ  ) = piRHO(IX+1,IY,  IZ  ) + SMALL
9444           piRHO(IX-1,IY,  IZ  ) = piRHO(IX-1,IY,  IZ  ) + SMALL
9445           piRHO(IX,  IY+1,IZ  ) = piRHO(IX,  IY+1,IZ  ) + SMALL
9446           piRHO(IX,  IY-1,IZ  ) = piRHO(IX,  IY-1,IZ  ) + SMALL
9447           piRHO(IX,  IY,  IZ+1) = piRHO(IX,  IY,  IZ+1) + SMALL
9448           piRHO(IX,  IY,  IZ-1) = piRHO(IX,  IY,  IZ-1) + SMALL
9449 c           endif    !! sp01/04/02
9450 * to calculate the Gamma factor in each cell
9451 *(1) PX
9452 40       pxl(ix,iy,iz)=pxl(ix,iy,iz)+p(1,I)*BIG
9453        pxl(ix+1,iy,iz)=pxl(ix+1,iy,iz)+p(1,I)*SMALL
9454        pxl(ix-1,iy,iz)=pxl(ix-1,iy,iz)+p(1,I)*SMALL
9455        pxl(ix,iy+1,iz)=pxl(ix,iy+1,iz)+p(1,I)*SMALL
9456        pxl(ix,iy-1,iz)=pxl(ix,iy-1,iz)+p(1,I)*SMALL
9457        pxl(ix,iy,iz+1)=pxl(ix,iy,iz+1)+p(1,I)*SMALL
9458        pxl(ix,iy,iz-1)=pxl(ix,iy,iz-1)+p(1,I)*SMALL
9459 *(2) PY
9460        pYl(ix,iy,iz)=pYl(ix,iy,iz)+p(2,I)*BIG
9461        pYl(ix+1,iy,iz)=pYl(ix+1,iy,iz)+p(2,I)*SMALL
9462        pYl(ix-1,iy,iz)=pYl(ix-1,iy,iz)+p(2,I)*SMALL
9463        pYl(ix,iy+1,iz)=pYl(ix,iy+1,iz)+p(2,I)*SMALL
9464        pYl(ix,iy-1,iz)=pYl(ix,iy-1,iz)+p(2,I)*SMALL
9465        pYl(ix,iy,iz+1)=pYl(ix,iy,iz+1)+p(2,I)*SMALL
9466        pYl(ix,iy,iz-1)=pYl(ix,iy,iz-1)+p(2,I)*SMALL
9467 * (3) PZ
9468        pZl(ix,iy,iz)=pZl(ix,iy,iz)+p(3,I)*BIG
9469        pZl(ix+1,iy,iz)=pZl(ix+1,iy,iz)+p(3,I)*SMALL
9470        pZl(ix-1,iy,iz)=pZl(ix-1,iy,iz)+p(3,I)*SMALL
9471        pZl(ix,iy+1,iz)=pZl(ix,iy+1,iz)+p(3,I)*SMALL
9472        pZl(ix,iy-1,iz)=pZl(ix,iy-1,iz)+p(3,I)*SMALL
9473        pZl(ix,iy,iz+1)=pZl(ix,iy,iz+1)+p(3,I)*SMALL
9474        pZl(ix,iy,iz-1)=pZl(ix,iy,iz-1)+p(3,I)*SMALL
9475 * (4) ENERGY
9476        pel(ix,iy,iz)=pel(ix,iy,iz)
9477      1     +sqrt(e(I)**2+p(1,i)**2+p(2,I)**2+p(3,I)**2)*BIG
9478        pel(ix+1,iy,iz)=pel(ix+1,iy,iz)
9479      1     +sqrt(e(I)**2+p(1,i)**2+p(2,I)**2+p(3,I)**2)*SMALL
9480        pel(ix-1,iy,iz)=pel(ix-1,iy,iz)
9481      1     +sqrt(e(I)**2+p(1,i)**2+p(2,I)**2+p(3,I)**2)*SMALL
9482        pel(ix,iy+1,iz)=pel(ix,iy+1,iz)
9483      1     +sqrt(e(I)**2+p(1,i)**2+p(2,I)**2+p(3,I)**2)*SMALL
9484        pel(ix,iy-1,iz)=pel(ix,iy-1,iz)
9485      1     +sqrt(e(I)**2+p(1,i)**2+p(2,I)**2+p(3,I)**2)*SMALL
9486        pel(ix,iy,iz+1)=pel(ix,iy,iz+1)
9487      1     +sqrt(e(I)**2+p(1,i)**2+p(2,I)**2+p(3,I)**2)*SMALL
9488        pel(ix,iy,iz-1)=pel(ix,iy,iz-1)
9489      1     +sqrt(e(I)**2+p(1,i)**2+p(2,I)**2+p(3,I)**2)*SMALL
9490         END IF
9491   400 CONTINUE
9492 *
9493       DO 301 IZ = -MAXZ,MAXZ
9494         DO 201 IY = -MAXX,MAXX
9495           DO 101 IX = -MAXX,MAXX
9496       IF((RHO(IX,IY,IZ).EQ.0).OR.(PEL(IX,IY,IZ).EQ.0))
9497      1GO TO 101
9498       SMASS2=PEL(IX,IY,IZ)**2-PXL(IX,IY,IZ)**2
9499      1-PYL(IX,IY,IZ)**2-PZL(IX,IY,IZ)**2
9500        IF(SMASS2.LE.0)SMASS2=1.E-06
9501        SMASS=SQRT(SMASS2)
9502            IF(SMASS.EQ.0.)SMASS=1.e-06
9503            GAMMA=PEL(IX,IY,IZ)/SMASS
9504            if(gamma.eq.0)go to 101
9505        bxx(ix,iy,iz)=pxl(ix,iy,iz)/pel(ix,iy,iz)
9506        byy(ix,iy,iz)=pyl(ix,iy,iz)/pel(ix,iy,iz)
9507        bzz(ix,iy,iz)=pzl(ix,iy,iz)/pel(ix,iy,iz)
9508             RHO(IX,IY,IZ) = RHO(IX,IY,IZ)/GAMMA
9509             RHOn(IX,IY,IZ) = RHOn(IX,IY,IZ)/GAMMA
9510             RHOp(IX,IY,IZ) = RHOp(IX,IY,IZ)/GAMMA
9511             piRHO(IX,IY,IZ) = piRHO(IX,IY,IZ)/GAMMA
9512             pEL(IX,IY,IZ) = pEL(IX,IY,IZ)/(GAMMA**2)
9513            rho0=0.163
9514            IF(IPOT.EQ.0)THEN
9515            U=0
9516            GO TO 70
9517            ENDIF
9518            IF(IPOT.EQ.1.or.ipot.eq.6)THEN
9519            A=-0.1236
9520            B=0.0704
9521            S=2
9522            GO TO 60
9523            ENDIF
9524            IF(IPOT.EQ.2.or.ipot.eq.7)THEN
9525            A=-0.218
9526            B=0.164
9527            S=4./3.
9528            ENDIF
9529            IF(IPOT.EQ.3)THEN
9530            a=-0.3581
9531            b=0.3048
9532            S=1.167
9533            GO TO 60
9534            ENDIF
9535            IF(IPOT.EQ.4)THEN
9536            denr=rho(ix,iy,iz)/rho0
9537            b=0.3048
9538            S=1.167
9539            if(denr.le.4.or.denr.gt.7)then
9540            a=-0.3581
9541            else
9542            a=-b*denr**(1./6.)-2.*0.036/3.*denr**(-0.333)
9543            endif
9544            GO TO 60
9545            ENDIF
9546 60           U = 0.5*A*RHO(IX,IY,IZ)**2/RHO0
9547      1        + B/(1+S) * (RHO(IX,IY,IZ)/RHO0)**S*RHO(IX,IY,IZ)
9548 70           PEL(IX,IY,IZ)=PEL(IX,IY,IZ)+U
9549   101     CONTINUE
9550   201   CONTINUE
9551   301 CONTINUE
9552       RETURN
9553       END
9554
9555 **********************************
9556 *                                                                      *
9557       SUBROUTINE GRADU(IOPT,IX,IY,IZ,GRADX,GRADY,GRADZ)
9558 *                                                                      *
9559 *       PURPOSE:     DETERMINE GRAD(U(RHO(X,Y,Z)))                     *
9560 *       VARIABLES:                                                     *
9561 *         IOPT                - METHOD FOR EVALUATING THE GRADIENT     *
9562 *                                                      (INTEGER,INPUT) *
9563 *         IX, IY, IZ          - COORDINATES OF POINT   (INTEGER,INPUT) *
9564 *         GRADX, GRADY, GRADZ - GRADIENT OF U            (REAL,OUTPUT) *
9565 *                                                                      *
9566 **********************************
9567       PARAMETER         (MAXX =    20,  MAXZ =   24)
9568       PARAMETER         (RHO0 = 0.167)
9569 *
9570       COMMON  /DD/      RHO(-MAXX:MAXX,-MAXX:MAXX,-MAXZ:MAXZ),
9571      &                  RHOP(-MAXX:MAXX,-MAXX:MAXX,-MAXZ:MAXZ),
9572      &                  RHON(-MAXX:MAXX,-MAXX:MAXX,-MAXZ:MAXZ)
9573 cc      SAVE /DD/
9574       common  /ss/      inout(20)
9575 cc      SAVE /ss/
9576       common  /tt/  PEL(-maxx:maxx,-maxx:maxx,-maxz:maxz)
9577      &,rxy(-maxx:maxx,-maxx:maxx,-maxz:maxz)
9578 cc      SAVE /tt/
9579       SAVE
9580 *
9581       RXPLUS   = RHO(IX+1,IY,  IZ  ) / RHO0
9582       RXMINS   = RHO(IX-1,IY,  IZ  ) / RHO0
9583       RYPLUS   = RHO(IX,  IY+1,IZ  ) / RHO0
9584       RYMINS   = RHO(IX,  IY-1,IZ  ) / RHO0
9585       RZPLUS   = RHO(IX,  IY,  IZ+1) / RHO0
9586       RZMINS   = RHO(IX,  IY,  IZ-1) / RHO0
9587       den0     = RHO(IX,  IY,  IZ) / RHO0
9588       ene0     = pel(IX,  IY,  IZ)
9589 *-----------------------------------------------------------------------
9590       GOTO (1,2,3,4,5) IOPT
9591        if(iopt.eq.6)go to 6
9592        if(iopt.eq.7)go to 7
9593 *
9594     1 CONTINUE
9595 *       POTENTIAL USED IN 1) (STIFF):
9596 *       U = -.124 * RHO/RHO0 + .0705 (RHO/RHO0)**2 GEV
9597 *
9598            GRADX  = -0.062 * (RXPLUS - RXMINS) + 0.03525 * (RXPLUS**2 -
9599      &                                                      RXMINS**2)
9600            GRADY  = -0.062 * (RYPLUS - RYMINS) + 0.03525 * (RYPLUS**2 -
9601      &                                                      RYMINS**2)
9602            GRADZ  = -0.062 * (RZPLUS - RZMINS) + 0.03525 * (RZPLUS**2 -
9603      &                                                      RZMINS**2)
9604            RETURN
9605 *
9606     2 CONTINUE
9607 *       POTENTIAL USED IN 2):
9608 *       U = -.218 * RHO/RHO0 + .164 (RHO/RHO0)**(4/3) GEV
9609 *
9610            EXPNT = 1.3333333
9611            GRADX = -0.109 * (RXPLUS - RXMINS)
9612      &     + 0.082 * (RXPLUS**EXPNT-RXMINS**EXPNT)
9613            GRADY = -0.109 * (RYPLUS - RYMINS)
9614      &     + 0.082 * (RYPLUS**EXPNT-RYMINS**EXPNT)
9615            GRADZ = -0.109 * (RZPLUS - RZMINS)
9616      &     + 0.082 * (RZPLUS**EXPNT-RZMINS**EXPNT)
9617            RETURN
9618 *
9619     3 CONTINUE
9620 *       POTENTIAL USED IN 3) (SOFT):
9621 *       U = -.356 * RHO/RHO0 + .303 * (RHO/RHO0)**(7/6)  GEV
9622 *
9623            EXPNT = 1.1666667
9624           acoef = 0.178
9625            GRADX = -acoef * (RXPLUS - RXMINS)
9626      &     + 0.1515 * (RXPLUS**EXPNT-RXMINS**EXPNT)
9627            GRADY = -acoef * (RYPLUS - RYMINS)
9628      &     + 0.1515 * (RYPLUS**EXPNT-RYMINS**EXPNT)
9629            GRADZ = -acoef * (RZPLUS - RZMINS)
9630      &     + 0.1515 * (RZPLUS**EXPNT-RZMINS**EXPNT)
9631                  RETURN
9632 *
9633 *
9634     4   CONTINUE
9635 *       POTENTIAL USED IN 4) (super-soft in the mixed phase of 4 < rho/rho <7):
9636 *       U1 = -.356 * RHO/RHO0 + .303 * (RHO/RHO0)**(7/6)  GEV
9637 *       normal phase, soft eos of iopt=3
9638 *       U2 = -.02 * (RHO/RHO0)**(2/3) -0.0253 * (RHO/RHO0)**(7/6)  GEV
9639 *
9640        eh=4.
9641        eqgp=7.
9642            acoef=0.178
9643            EXPNT = 1.1666667
9644        denr=rho(ix,iy,iz)/rho0
9645        if(denr.le.eh.or.denr.ge.eqgp)then
9646            GRADX = -acoef * (RXPLUS - RXMINS)
9647      &     + 0.1515 * (RXPLUS**EXPNT-RXMINS**EXPNT)
9648            GRADY = -acoef * (RYPLUS - RYMINS)
9649      &     + 0.1515 * (RYPLUS**EXPNT-RYMINS**EXPNT)
9650            GRADZ = -acoef * (RZPLUS - RZMINS)
9651      &     + 0.1515 * (RZPLUS**EXPNT-RZMINS**EXPNT)
9652        else
9653           acoef1=0.178
9654           acoef2=0.0
9655           expnt2=2./3.
9656            GRADX =-acoef1* (RXPLUS**EXPNT-RXMINS**EXPNT)
9657      &                 -acoef2* (RXPLUS**expnt2 - RXMINS**expnt2)
9658            GRADy =-acoef1* (RyPLUS**EXPNT-RyMINS**EXPNT)
9659      &                 -acoef2* (RyPLUS**expnt2 - RyMINS**expnt2)
9660            GRADz =-acoef1* (RzPLUS**EXPNT-RzMINS**EXPNT)
9661      &                 -acoef2* (RzPLUS**expnt2 - RzMINS**expnt2)
9662        endif
9663        return
9664 *
9665     5   CONTINUE
9666 *       POTENTIAL USED IN 5) (SUPER STIFF):
9667 *       U = -.10322 * RHO/RHO0 + .04956 * (RHO/RHO0)**(2.77)  GEV
9668 *
9669            EXPNT = 2.77
9670            GRADX = -0.0516 * (RXPLUS - RXMINS)
9671      &     + 0.02498 * (RXPLUS**EXPNT-RXMINS**EXPNT)
9672            GRADY = -0.0516 * (RYPLUS - RYMINS)
9673      &     + 0.02498 * (RYPLUS**EXPNT-RYMINS**EXPNT)
9674            GRADZ = -0.0516 * (RZPLUS - RZMINS)
9675      &     + 0.02498 * (RZPLUS**EXPNT-RZMINS**EXPNT)
9676            RETURN
9677 *
9678     6 CONTINUE
9679 *       POTENTIAL USED IN 6) (STIFF-qgp):
9680 *       U = -.124 * RHO/RHO0 + .0705 (RHO/RHO0)**2 GEV
9681 *
9682        if(ene0.le.0.5)then
9683            GRADX  = -0.062 * (RXPLUS - RXMINS) + 0.03525 * (RXPLUS**2 -
9684      &                                                      RXMINS**2)
9685            GRADY  = -0.062 * (RYPLUS - RYMINS) + 0.03525 * (RYPLUS**2 -
9686      &                                                      RYMINS**2)
9687            GRADZ  = -0.062 * (RZPLUS - RZMINS) + 0.03525 * (RZPLUS**2 -
9688      &                                                      RZMINS**2)
9689            RETURN
9690        endif
9691        if(ene0.gt.0.5.and.ene0.le.1.5)then
9692 *       U=c1-ef*rho/rho0**2/3
9693        ef=36./1000.
9694            GRADX  = -0.5*ef* (RXPLUS**0.67-RXMINS**0.67)
9695            GRADy  = -0.5*ef* (RyPLUS**0.67-RyMINS**0.67)
9696            GRADz  = -0.5*ef* (RzPLUS**0.67-RzMINS**0.67)
9697            RETURN
9698        endif
9699        if(ene0.gt.1.5)then
9700 * U=800*(rho/rho0)**1/3.-Ef*(rho/rho0)**2/3.-c2
9701        ef=36./1000.
9702        cf0=0.8
9703         GRADX  =0.5*cf0*(rxplus**0.333-rxmins**0.333)
9704      &         -0.5*ef* (RXPLUS**0.67-RXMINS**0.67)
9705         GRADy  =0.5*cf0*(ryplus**0.333-rymins**0.333)
9706      &         -0.5*ef* (RyPLUS**0.67-RyMINS**0.67)
9707         GRADz  =0.5*cf0*(rzplus**0.333-rzmins**0.333)
9708      &         -0.5*ef* (RzPLUS**0.67-RzMINS**0.67)
9709            RETURN
9710        endif
9711 *
9712     7 CONTINUE
9713 *       POTENTIAL USED IN 7) (Soft-qgp):
9714        if(den0.le.4.5)then
9715 *       POTENTIAL USED is the same as IN 3) (SOFT):
9716 *       U = -.356 * RHO/RHO0 + .303 * (RHO/RHO0)**(7/6)  GEV
9717 *
9718            EXPNT = 1.1666667
9719           acoef = 0.178
9720            GRADX = -acoef * (RXPLUS - RXMINS)
9721      &     + 0.1515 * (RXPLUS**EXPNT-RXMINS**EXPNT)
9722            GRADY = -acoef * (RYPLUS - RYMINS)
9723      &     + 0.1515 * (RYPLUS**EXPNT-RYMINS**EXPNT)
9724            GRADZ = -acoef * (RZPLUS - RZMINS)
9725      &     + 0.1515 * (RZPLUS**EXPNT-RZMINS**EXPNT)
9726        return
9727        endif
9728        if(den0.gt.4.5.and.den0.le.5.1)then
9729 *       U=c1-ef*rho/rho0**2/3
9730        ef=36./1000.
9731            GRADX  = -0.5*ef* (RXPLUS**0.67-RXMINS**0.67)
9732            GRADy  = -0.5*ef* (RyPLUS**0.67-RyMINS**0.67)
9733            GRADz  = -0.5*ef* (RzPLUS**0.67-RzMINS**0.67)
9734            RETURN
9735        endif
9736        if(den0.gt.5.1)then
9737 * U=800*(rho/rho0)**1/3.-Ef*(rho/rho0)**2/3.-c2
9738        ef=36./1000.
9739        cf0=0.8
9740         GRADX  =0.5*cf0*(rxplus**0.333-rxmins**0.333)
9741      &         -0.5*ef* (RXPLUS**0.67-RXMINS**0.67)
9742         GRADy  =0.5*cf0*(ryplus**0.333-rymins**0.333)
9743      &         -0.5*ef* (RyPLUS**0.67-RyMINS**0.67)
9744         GRADz  =0.5*cf0*(rzplus**0.333-rzmins**0.333)
9745      &         -0.5*ef* (RzPLUS**0.67-RzMINS**0.67)
9746            RETURN
9747        endif
9748         END
9749 **********************************
9750 *                                                                      *
9751       SUBROUTINE GRADUK(IX,IY,IZ,GRADXk,GRADYk,GRADZk)
9752 *                                                                      *
9753 *       PURPOSE:     DETERMINE the baryon density gradient for         *
9754 *                    proporgating kaons in a mean field caused by      *
9755 *                    surrounding baryons                               *
9756 *       VARIABLES:                                                     *
9757 *         IX, IY, IZ          - COORDINATES OF POINT   (INTEGER,INPUT) *
9758 *         GRADXk, GRADYk, GRADZk                       (REAL,OUTPUT)   *
9759 *                                                                      *
9760 **********************************
9761       PARAMETER         (MAXX =    20,  MAXZ =   24)
9762       PARAMETER         (RHO0 = 0.168)
9763 *
9764       COMMON  /DD/      RHO(-MAXX:MAXX,-MAXX:MAXX,-MAXZ:MAXZ),
9765      &                  RHOP(-MAXX:MAXX,-MAXX:MAXX,-MAXZ:MAXZ),
9766      &                  RHON(-MAXX:MAXX,-MAXX:MAXX,-MAXZ:MAXZ)
9767 cc      SAVE /DD/
9768       common  /ss/      inout(20)
9769 cc      SAVE /ss/
9770       SAVE
9771 *
9772       RXPLUS   = RHO(IX+1,IY,  IZ  )
9773       RXMINS   = RHO(IX-1,IY,  IZ  )
9774       RYPLUS   = RHO(IX,  IY+1,IZ  )
9775       RYMINS   = RHO(IX,  IY-1,IZ  )
9776       RZPLUS   = RHO(IX,  IY,  IZ+1)
9777       RZMINS   = RHO(IX,  IY,  IZ-1)
9778            GRADXk  = (RXPLUS - RXMINS)/2.
9779            GRADYk  = (RYPLUS - RYMINS)/2.
9780            GRADZk  = (RZPLUS - RZMINS)/2.
9781            RETURN
9782            END
9783 *-----------------------------------------------------------------------
9784       SUBROUTINE GRADUP(IX,IY,IZ,GRADXP,GRADYP,GRADZP)
9785 *                                                                      *
9786 *       PURPOSE:     DETERMINE THE GRADIENT OF THE PROTON DENSITY      *
9787 *       VARIABLES:                                                     *
9788 *                                                                           *
9789 *         IX, IY, IZ          - COORDINATES OF POINT   (INTEGER,INPUT) *
9790 *         GRADXP, GRADYP, GRADZP - GRADIENT OF THE PROTON              *
9791 *                                  DENSITY(REAL,OUTPUT)                *
9792 *                                                                      *
9793 **********************************
9794       PARAMETER         (MAXX =    20,  MAXZ =   24)
9795       PARAMETER         (RHO0 = 0.168)
9796 *
9797       COMMON  /DD/      RHO(-MAXX:MAXX,-MAXX:MAXX,-MAXZ:MAXZ),
9798      &                     RHOP(-MAXX:MAXX,-MAXX:MAXX,-MAXZ:MAXZ),
9799      &                     RHON(-MAXX:MAXX,-MAXX:MAXX,-MAXZ:MAXZ)
9800 cc      SAVE /DD/
9801       common  /ss/      inout(20)
9802 cc      SAVE /ss/
9803       SAVE
9804 *
9805       RXPLUS   = RHOP(IX+1,IY,  IZ  ) / RHO0
9806       RXMINS   = RHOP(IX-1,IY,  IZ  ) / RHO0
9807       RYPLUS   = RHOP(IX,  IY+1,IZ  ) / RHO0
9808       RYMINS   = RHOP(IX,  IY-1,IZ  ) / RHO0
9809       RZPLUS   = RHOP(IX,  IY,  IZ+1) / RHO0
9810       RZMINS   = RHOP(IX,  IY,  IZ-1) / RHO0
9811 *-----------------------------------------------------------------------
9812 *
9813            GRADXP  = (RXPLUS - RXMINS)/2.
9814            GRADYP  = (RYPLUS - RYMINS)/2.
9815            GRADZP  = (RZPLUS - RZMINS)/2.
9816            RETURN
9817       END
9818 *-----------------------------------------------------------------------
9819       SUBROUTINE GRADUN(IX,IY,IZ,GRADXN,GRADYN,GRADZN)
9820 *                                                                      *
9821 *       PURPOSE:     DETERMINE THE GRADIENT OF THE NEUTRON DENSITY     *
9822 *       VARIABLES:                                                     *
9823 *                                                                           *
9824 *         IX, IY, IZ          - COORDINATES OF POINT   (INTEGER,INPUT) *
9825 *         GRADXN, GRADYN, GRADZN - GRADIENT OF THE NEUTRON             *
9826 *                                  DENSITY(REAL,OUTPUT)                *
9827 *                                                                      *
9828 **********************************
9829       PARAMETER         (MAXX =    20,  MAXZ =   24)
9830       PARAMETER         (RHO0 = 0.168)
9831 *
9832       COMMON  /DD/      RHO(-MAXX:MAXX,-MAXX:MAXX,-MAXZ:MAXZ),
9833      &                     RHOP(-MAXX:MAXX,-MAXX:MAXX,-MAXZ:MAXZ),
9834      &                     RHON(-MAXX:MAXX,-MAXX:MAXX,-MAXZ:MAXZ)
9835 cc      SAVE /DD/
9836       common  /ss/      inout(20)
9837 cc      SAVE /ss/
9838       SAVE
9839 *
9840       RXPLUS   = RHON(IX+1,IY,  IZ  ) / RHO0
9841       RXMINS   = RHON(IX-1,IY,  IZ  ) / RHO0
9842       RYPLUS   = RHON(IX,  IY+1,IZ  ) / RHO0
9843       RYMINS   = RHON(IX,  IY-1,IZ  ) / RHO0
9844       RZPLUS   = RHON(IX,  IY,  IZ+1) / RHO0
9845       RZMINS   = RHON(IX,  IY,  IZ-1) / RHO0
9846 *-----------------------------------------------------------------------
9847 *
9848            GRADXN  = (RXPLUS - RXMINS)/2.
9849            GRADYN  = (RYPLUS - RYMINS)/2.
9850            GRADZN  = (RZPLUS - RZMINS)/2.
9851            RETURN
9852       END
9853
9854 *-----------------------------------------------------------------------------
9855 *FUNCTION FDE(DMASS) GIVES DELTA MASS DISTRIBUTION BY USING OF
9856 *KITAZOE'S FORMULA
9857         REAL FUNCTION FDE(DMASS,SRT,CON)
9858       SAVE
9859         AMN=0.938869
9860         AVPI=0.13803333
9861         AM0=1.232
9862         FD=4.*(AM0**2)*WIDTH(DMASS)/((DMASS**2-1.232**2)**2
9863      1  +AM0**2*WIDTH(DMASS)**2)
9864         IF(CON.EQ.1.)THEN
9865         P11=(SRT**2+DMASS**2-AMN**2)**2
9866      1  /(4.*SRT**2)-DMASS**2
9867        if(p11.le.0)p11=1.E-06
9868        p1=sqrt(p11)
9869         ELSE
9870         DMASS=AMN+AVPI
9871         P11=(SRT**2+DMASS**2-AMN**2)**2
9872      1  /(4.*SRT**2)-DMASS**2
9873        if(p11.le.0)p11=1.E-06
9874        p1=sqrt(p11)
9875         ENDIF
9876         FDE=FD*P1*DMASS
9877         RETURN
9878         END
9879 *-------------------------------------------------------------
9880 *FUNCTION FDE(DMASS) GIVES N*(1535) MASS DISTRIBUTION BY USING OF
9881 *KITAZOE'S FORMULA
9882         REAL FUNCTION FD5(DMASS,SRT,CON)
9883       SAVE
9884         AMN=0.938869
9885         AVPI=0.13803333
9886         AM0=1.535
9887         FD=4.*(AM0**2)*W1535(DMASS)/((DMASS**2-1.535**2)**2
9888      1  +AM0**2*W1535(DMASS)**2)
9889         IF(CON.EQ.1.)THEN
9890         P1=SQRT((SRT**2+DMASS**2-AMN**2)**2
9891      1  /(4.*SRT**2)-DMASS**2)
9892         ELSE
9893         DMASS=AMN+AVPI
9894         P1=SQRT((SRT**2+DMASS**2-AMN**2)**2
9895      1  /(4.*SRT**2)-DMASS**2)
9896         ENDIF
9897         FD5=FD*P1*DMASS
9898         RETURN
9899         END
9900 *--------------------------------------------------------------------------
9901 *FUNCTION FNS(DMASS) GIVES N* MASS DISTRIBUTION
9902 c     BY USING OF BREIT-WIGNER FORMULA
9903         REAL FUNCTION FNS(DMASS,SRT,CON)
9904       SAVE
9905         WIDTH=0.2
9906         AMN=0.938869
9907         AVPI=0.13803333
9908         AN0=1.43
9909         FN=4.*(AN0**2)*WIDTH/((DMASS**2-1.44**2)**2+AN0**2*WIDTH**2)
9910         IF(CON.EQ.1.)THEN
9911         P1=SQRT((SRT**2+DMASS**2-AMN**2)**2
9912      1  /(4.*SRT**2)-DMASS**2)
9913         ELSE
9914         DMASS=AMN+AVPI
9915         P1=SQRT((SRT**2+DMASS**2-AMN**2)**2
9916      1  /(4.*SRT**2)-DMASS**2)
9917         ENDIF
9918         FNS=FN*P1*DMASS
9919         RETURN
9920         END
9921 *-----------------------------------------------------------------------------
9922 *-----------------------------------------------------------------------------
9923 * PURPOSE:1. SORT N*(1440) and N*(1535) 2-body DECAY PRODUCTS
9924 *         2. DETERMINE THE MOMENTUM AND COORDINATES OF NUCLEON AND PION
9925 *            AFTER THE DELTA OR N* DECAYING
9926 * DATE   : JAN. 24,1990, MODIFIED ON MAY 17, 1994 TO INCLUDE ETA
9927         SUBROUTINE DECAYA(IRUN,I,NNN,ISEED,wid,nt)
9928         PARAMETER (MAXSTR=150001,MAXR=1,
9929      1  AMN=0.939457,ETAM=0.5475,AMP=0.93828,AP1=0.13496,
9930      2  AP2=0.13957,AM0=1.232,PI=3.1415926)
9931         COMMON /AA/ R(3,MAXSTR)
9932 cc      SAVE /AA/
9933         COMMON /BB/ P(3,MAXSTR)
9934 cc      SAVE /BB/
9935         COMMON /CC/ E(MAXSTR)
9936 cc      SAVE /CC/
9937         COMMON /EE/ ID(MAXSTR),LB(MAXSTR)
9938 cc      SAVE /EE/
9939         COMMON   /RUN/NUM
9940 cc      SAVE /RUN/
9941         COMMON   /PA/RPION(3,MAXSTR,MAXR)
9942 cc      SAVE /PA/
9943         COMMON   /PB/PPION(3,MAXSTR,MAXR)
9944 cc      SAVE /PB/
9945         COMMON   /PC/EPION(MAXSTR,MAXR)
9946 cc      SAVE /PC/
9947         COMMON   /PD/LPION(MAXSTR,MAXR)
9948 cc      SAVE /PD/
9949         COMMON /INPUT2/ ILAB, MANYB, NTMAX, ICOLL, INSYS, IPOT, MODE,
9950      &       IMOMEN, NFREQ, ICFLOW, ICRHO, ICOU, KPOTEN, KMUL
9951 cc      SAVE /INPUT2/
9952       COMMON/RNDF77/NSEED
9953       COMMON /dpert/dpertt(MAXSTR,MAXR),dpertp(MAXSTR),dplast(MAXSTR),
9954      1     dpdcy(MAXSTR),dpdpi(MAXSTR,MAXR),dpt(MAXSTR, MAXR),
9955      2     dpp1(MAXSTR,MAXR),dppion(MAXSTR,MAXR)
9956 cc      SAVE /RNDF77/
9957       SAVE
9958         lbanti=LB(I)
9959 c
9960         DM=E(I)
9961 *1. FOR N*+(1440) DECAY
9962         IF(iabs(LB(I)).EQ.11)THEN
9963            X3=RANART(NSEED)
9964            IF(X3.GT.(1./3.))THEN
9965               LB(I)=2
9966               NLAB=2
9967               LPION(NNN,IRUN)=5
9968               EPION(NNN,IRUN)=AP2
9969            ELSE
9970               LB(I)=1
9971               NLAB=1
9972               LPION(NNN,IRUN)=4
9973               EPION(NNN,IRUN)=AP1
9974            ENDIF
9975 *2. FOR N*0(1440) DECAY
9976         ELSEIF(iabs(LB(I)).EQ.10)THEN
9977            X4=RANART(NSEED)
9978            IF(X4.GT.(1./3.))THEN
9979               LB(I)=1
9980               NLAB=1
9981               LPION(NNN,IRUN)=3
9982               EPION(NNN,IRUN)=AP2
9983            ELSE
9984               LB(I)=2
9985               NALB=2
9986               LPION(NNN,IRUN)=4
9987               EPION(NNN,IRUN)=AP1
9988            ENDIF
9989 * N*(1535) CAN DECAY TO A PION OR AN ETA IF DM > 1.49 GeV
9990 *3 N*(0)(1535) DECAY
9991         ELSEIF(iabs(LB(I)).EQ.12)THEN
9992            CTRL=0.65
9993            IF(DM.lE.1.49)ctrl=-1.
9994            X5=RANART(NSEED)
9995            IF(X5.GE.ctrl)THEN
9996 * DECAY TO PION+NUCLEON
9997               X6=RANART(NSEED)
9998               IF(X6.GT.(1./3.))THEN
9999                  LB(I)=1
10000                  NLAB=1
10001                  LPION(NNN,IRUN)=3
10002                  EPION(NNN,IRUN)=AP2
10003               ELSE
10004                  LB(I)=2
10005                  NALB=2
10006                  LPION(NNN,IRUN)=4
10007                  EPION(NNN,IRUN)=AP1
10008               ENDIF
10009            ELSE
10010 * DECAY TO ETA+NEUTRON
10011               LB(I)=2
10012               NLAB=2
10013               LPION(NNN,IRUN)=0
10014               EPION(NNN,IRUN)=ETAM
10015            ENDIF
10016 *4. FOR N*+(1535) DECAY
10017         ELSEIF(iabs(LB(I)).EQ.13)THEN
10018            CTRL=0.65
10019            IF(DM.lE.1.49)ctrl=-1.
10020            X5=RANART(NSEED)
10021            IF(X5.GE.ctrl)THEN
10022 * DECAY TO PION+NUCLEON
10023               X8=RANART(NSEED)
10024               IF(X8.GT.(1./3.))THEN
10025                  LB(I)=2
10026                  NLAB=2
10027                  LPION(NNN,IRUN)=5
10028                  EPION(NNN,IRUN)=AP2
10029               ELSE
10030                  LB(I)=1
10031                  NLAB=1
10032                  LPION(NNN,IRUN)=4
10033                  EPION(NNN,IRUN)=AP1
10034               ENDIF
10035            ELSE
10036 * DECAY TO ETA+NUCLEON
10037               LB(I)=1
10038               NLAB=1
10039               LPION(NNN,IRUN)=0
10040               EPION(NNN,IRUN)=ETAM
10041            ENDIF
10042         ENDIF
10043 c
10044         CALL DKINE(IRUN,I,NNN,NLAB,ISEED,wid,nt)
10045 c
10046 c     anti-particle ID for anti-N* decays:
10047         if(lbanti.lt.0) then
10048            lbi=LB(I)
10049            if(lbi.eq.1.or.lbi.eq.2) then
10050               lbi=-lbi
10051            elseif(lbi.eq.3) then
10052               lbi=5
10053            elseif(lbi.eq.5) then
10054               lbi=3
10055            endif
10056            LB(I)=lbi
10057 c
10058            lbi=LPION(NNN,IRUN)
10059            if(lbi.eq.3) then
10060               lbi=5
10061            elseif(lbi.eq.5) then
10062               lbi=3
10063            elseif(lbi.eq.1.or.lbi.eq.2) then
10064               lbi=-lbi
10065            endif
10066            LPION(NNN,IRUN)=lbi
10067         endif
10068 c
10069         if(nt.eq.ntmax) then
10070 c     at the last timestep, assign rho or eta (decay daughter)
10071 c     to lb(i1) only (not to lpion) in order to decay them again:
10072            lbm=LPION(NNN,IRUN)
10073            if(lbm.eq.0.or.lbm.eq.25
10074      1          .or.lbm.eq.26.or.lbm.eq.27) then
10075 c     switch rho or eta with baryon, positions are the same (no change needed):
10076               lbsave=lbm
10077               xmsave=EPION(NNN,IRUN)
10078               pxsave=PPION(1,NNN,IRUN)
10079               pysave=PPION(2,NNN,IRUN)
10080               pzsave=PPION(3,NNN,IRUN)
10081 clin-5/2008:
10082               dpsave=dppion(NNN,IRUN)
10083               LPION(NNN,IRUN)=LB(I)
10084               EPION(NNN,IRUN)=E(I)
10085               PPION(1,NNN,IRUN)=P(1,I)
10086               PPION(2,NNN,IRUN)=P(2,I)
10087               PPION(3,NNN,IRUN)=P(3,I)
10088 clin-5/2008:
10089               dppion(NNN,IRUN)=dpertp(I)
10090               LB(I)=lbsave
10091               E(I)=xmsave
10092               P(1,I)=pxsave
10093               P(2,I)=pysave
10094               P(3,I)=pzsave
10095 clin-5/2008:
10096               dpertp(I)=dpsave
10097            endif
10098         endif
10099
10100        RETURN
10101        END
10102
10103 *-------------------------------------------------------------------
10104 *-------------------------------------------------------------------
10105 * PURPOSE:
10106 *         CALCULATE THE MOMENTUM OF NUCLEON AND PION (OR ETA)
10107 *         IN THE LAB. FRAME AFTER DELTA OR N* DECAY
10108 * DATE   : JAN. 24,1990, MODIFIED ON MAY 17, 1994 TO INCLUDE ETA PRODUCTION
10109         SUBROUTINE DKINE(IRUN,I,NNN,NLAB,ISEED,wid,nt)
10110         PARAMETER (hbarc=0.19733)
10111         PARAMETER (MAXSTR=150001,MAXR=1,
10112      1  AMN=0.939457,AMP=0.93828,ETAM=0.5475,
10113      2  AP1=0.13496,AP2=0.13957,AM0=1.232,PI=3.1415926)
10114         COMMON /AA/ R(3,MAXSTR)
10115 cc      SAVE /AA/
10116         COMMON /BB/ P(3,MAXSTR)
10117 cc      SAVE /BB/
10118         COMMON /CC/ E(MAXSTR)
10119 cc      SAVE /CC/
10120         COMMON /EE/ ID(MAXSTR),LB(MAXSTR)
10121 cc      SAVE /EE/
10122         COMMON   /RUN/NUM
10123 cc      SAVE /RUN/
10124         COMMON   /PA/RPION(3,MAXSTR,MAXR)
10125 cc      SAVE /PA/
10126         COMMON   /PB/PPION(3,MAXSTR,MAXR)
10127 cc      SAVE /PB/
10128         COMMON   /PC/EPION(MAXSTR,MAXR)
10129 cc      SAVE /PC/
10130         COMMON   /PD/LPION(MAXSTR,MAXR)
10131 cc      SAVE /PD/
10132       common/leadng/lb1,px1,py1,pz1,em1,e1,xfnl,yfnl,zfnl,tfnl,
10133      1 px1n,py1n,pz1n,dp1n
10134 cc      SAVE /leadng/
10135         COMMON/tdecay/tfdcy(MAXSTR),tfdpi(MAXSTR,MAXR),tft(MAXSTR)
10136 cc      SAVE /tdecay/
10137         COMMON /INPUT2/ ILAB, MANYB, NTMAX, ICOLL, INSYS, IPOT, MODE,
10138      &       IMOMEN, NFREQ, ICFLOW, ICRHO, ICOU, KPOTEN, KMUL
10139 cc      SAVE /INPUT2/
10140       COMMON/RNDF77/NSEED
10141 cc      SAVE /RNDF77/
10142       COMMON /dpert/dpertt(MAXSTR,MAXR),dpertp(MAXSTR),dplast(MAXSTR),
10143      1     dpdcy(MAXSTR),dpdpi(MAXSTR,MAXR),dpt(MAXSTR, MAXR),
10144      2     dpp1(MAXSTR,MAXR),dppion(MAXSTR,MAXR)
10145         EXTERNAL IARFLV, INVFLV
10146       SAVE
10147         ISEED=ISEED
10148 * READ IN THE COORDINATES OF DELTA OR N* UNDERGOING DECAY
10149         PX=P(1,I)
10150         PY=P(2,I)
10151         PZ=P(3,I)
10152         RX=R(1,I)
10153         RY=R(2,I)
10154         RZ=R(3,I)
10155         DM=E(I)
10156         EDELTA=SQRT(DM**2+PX**2+PY**2+PZ**2)
10157         PM=EPION(NNN,IRUN)
10158         AM=AMP
10159         IF(NLAB.EQ.2)AM=AMN
10160 * FIND OUT THE MOMENTUM AND ENERGY OF PION AND NUCLEON IN DELTA REST FRAME
10161 * THE MAGNITUDE OF MOMENTUM IS DETERMINED BY ENERGY CONSERVATION ,THE FORMULA
10162 * CAN BE FOUND ON PAGE 716,W BAUER P.R.C40,1989
10163 * THE DIRECTION OF THE MOMENTUM IS ASSUMED ISOTROPIC. NOTE THAT P(PION)=-P(N)
10164         Q2=((DM**2-AM**2+PM**2)/(2.*DM))**2-PM**2
10165         IF(Q2.LE.0.)Q2=1.e-09
10166         Q=SQRT(Q2)
10167 11      QX=1.-2.*RANART(NSEED)
10168         QY=1.-2.*RANART(NSEED)
10169         QZ=1.-2.*RANART(NSEED)
10170         QS=QX**2+QY**2+QZ**2
10171         IF(QS.GT.1.) GO TO 11
10172         PXP=Q*QX/SQRT(QS)
10173         PYP=Q*QY/SQRT(QS)
10174         PZP=Q*QZ/SQRT(QS)
10175         EP=SQRT(Q**2+PM**2)
10176         PXN=-PXP
10177         PYN=-PYP
10178         PZN=-PZP
10179         EN=SQRT(Q**2+AM**2)
10180 * TRANSFORM INTO THE LAB. FRAME. THE GENERAL LORENTZ TRANSFORMATION CAN
10181 * BE FOUND ON PAGE 34 OF R. HAGEDORN " RELATIVISTIC KINEMATICS"
10182         GD=EDELTA/DM
10183         FGD=GD/(1.+GD)
10184         BDX=PX/EDELTA
10185         BDY=PY/EDELTA
10186         BDZ=PZ/EDELTA
10187         BPP=BDX*PXP+BDY*PYP+BDZ*PZP
10188         BPN=BDX*PXN+BDY*PYN+BDZ*PZN
10189         P(1,I)=PXN+BDX*GD*(FGD*BPN+EN)
10190         P(2,I)=PYN+BDY*GD*(FGD*BPN+EN)
10191         P(3,I)=PZN+BDZ*GD*(FGD*BPN+EN)
10192         E(I)=AM
10193 * WE ASSUME THAT THE SPACIAL COORDINATE OF THE NUCLEON
10194 * IS THAT OF THE DELTA
10195         PPION(1,NNN,IRUN)=PXP+BDX*GD*(FGD*BPP+EP)
10196         PPION(2,NNN,IRUN)=PYP+BDY*GD*(FGD*BPP+EP)
10197         PPION(3,NNN,IRUN)=PZP+BDZ*GD*(FGD*BPP+EP)
10198 clin-5/2008:
10199         dppion(NNN,IRUN)=dpertp(I)
10200 * WE ASSUME THE PION OR ETA COMING FROM DELTA DECAY IS LOCATED ON THE SPHERE
10201 * OF RADIUS 0.5FM AROUND DELTA, THIS POINT NEED TO BE CHECKED
10202 * AND OTHER CRIERTION MAY BE TRIED
10203 clin-2/20/03 no additional smearing for position of decay daughters:
10204 c200         X0 = 1.0 - 2.0 * RANART(NSEED)
10205 c            Y0 = 1.0 - 2.0 * RANART(NSEED)
10206 c            Z0 = 1.0 - 2.0 * RANART(NSEED)
10207 c        IF ((X0*X0+Y0*Y0+Z0*Z0) .GT. 1.0) GOTO 200
10208 c        RPION(1,NNN,IRUN)=R(1,I)+0.5*x0
10209 c        RPION(2,NNN,IRUN)=R(2,I)+0.5*y0
10210 c        RPION(3,NNN,IRUN)=R(3,I)+0.5*z0
10211         RPION(1,NNN,IRUN)=R(1,I)
10212         RPION(2,NNN,IRUN)=R(2,I)
10213         RPION(3,NNN,IRUN)=R(3,I)
10214 c
10215         devio=SQRT(EPION(NNN,IRUN)**2+PPION(1,NNN,IRUN)**2
10216      1       +PPION(2,NNN,IRUN)**2+PPION(3,NNN,IRUN)**2)
10217      2       +SQRT(E(I)**2+P(1,I)**2+P(2,I)**2+P(3,I)**2)-e1
10218 c        if(abs(devio).gt.0.02) write(93,*) 'decay(): nt=',nt,devio,lb1
10219
10220 c     add decay time to daughter's formation time at the last timestep:
10221         if(nt.eq.ntmax) then
10222            tau0=hbarc/wid
10223            taudcy=tau0*(-1.)*alog(1.-RANART(NSEED))
10224 c     lorentz boost:
10225            taudcy=taudcy*e1/em1
10226            tfnl=tfnl+taudcy
10227            xfnl=xfnl+px1/e1*taudcy
10228            yfnl=yfnl+py1/e1*taudcy
10229            zfnl=zfnl+pz1/e1*taudcy
10230            R(1,I)=xfnl
10231            R(2,I)=yfnl
10232            R(3,I)=zfnl
10233            tfdcy(I)=tfnl
10234            RPION(1,NNN,IRUN)=xfnl
10235            RPION(2,NNN,IRUN)=yfnl
10236            RPION(3,NNN,IRUN)=zfnl
10237            tfdpi(NNN,IRUN)=tfnl
10238         endif
10239
10240 cc 200    format(a30,2(1x,e10.4))
10241 cc 210    format(i6,5(1x,f8.3))
10242 cc 220    format(a2,i5,5(1x,f8.3))
10243
10244         RETURN
10245         END
10246
10247 *-----------------------------------------------------------------------------
10248 *-----------------------------------------------------------------------------
10249 * PURPOSE:1. N*-->N+PION+PION  DECAY PRODUCTS
10250 *         2. DETERMINE THE MOMENTUM AND COORDINATES OF NUCLEON AND PION
10251 *            AFTER THE DELTA OR N* DECAYING
10252 * DATE   : NOV.7,1994
10253 *----------------------------------------------------------------------------
10254         SUBROUTINE DECAY2(IRUN,I,NNN,ISEED,wid,nt)
10255         PARAMETER (MAXSTR=150001,MAXR=1,
10256      1  AMN=0.939457,ETAM=0.5475,AMP=0.93828,AP1=0.13496,
10257      2  AP2=0.13957,AM0=1.232,PI=3.1415926)
10258         COMMON /AA/ R(3,MAXSTR)
10259 cc      SAVE /AA/
10260         COMMON /BB/ P(3,MAXSTR)
10261 cc      SAVE /BB/
10262         COMMON /CC/ E(MAXSTR)
10263 cc      SAVE /CC/
10264         COMMON /EE/ ID(MAXSTR),LB(MAXSTR)
10265 cc      SAVE /EE/
10266         COMMON   /RUN/NUM
10267 cc      SAVE /RUN/
10268         COMMON   /PA/RPION(3,MAXSTR,MAXR)
10269 cc      SAVE /PA/
10270         COMMON   /PB/PPION(3,MAXSTR,MAXR)
10271 cc      SAVE /PB/
10272         COMMON   /PC/EPION(MAXSTR,MAXR)
10273 cc      SAVE /PC/
10274         COMMON   /PD/LPION(MAXSTR,MAXR)
10275 cc      SAVE /PD/
10276       COMMON/RNDF77/NSEED
10277 cc      SAVE /RNDF77/
10278       SAVE
10279
10280         lbanti=LB(I)
10281 c
10282         DM=E(I)
10283 * DETERMINE THE DECAY PRODUCTS
10284 * FOR N*+(1440) DECAY
10285         IF(iabs(LB(I)).EQ.11)THEN
10286            X3=RANART(NSEED)
10287            IF(X3.LT.(1./3))THEN
10288               LB(I)=2
10289               NLAB=2
10290               LPION(NNN,IRUN)=5
10291               EPION(NNN,IRUN)=AP2
10292               LPION(NNN+1,IRUN)=4
10293               EPION(NNN+1,IRUN)=AP1
10294            ELSEIF(X3.LT.2./3.AND.X3.GT.1./3.)THEN
10295               LB(I)=1
10296               NLAB=1
10297               LPION(NNN,IRUN)=5
10298               EPION(NNN,IRUN)=AP2
10299               LPION(NNN+1,IRUN)=3
10300               EPION(NNN+1,IRUN)=AP2
10301            ELSE
10302               LB(I)=1
10303               NLAB=1
10304               LPION(NNN,IRUN)=4
10305               EPION(NNN,IRUN)=AP1
10306               LPION(NNN+1,IRUN)=4
10307               EPION(NNN+1,IRUN)=AP1
10308            ENDIF
10309 * FOR N*0(1440) DECAY
10310         ELSEIF(iabs(LB(I)).EQ.10)THEN
10311            X3=RANART(NSEED)
10312            IF(X3.LT.(1./3))THEN
10313               LB(I)=2
10314               NLAB=2
10315               LPION(NNN,IRUN)=4
10316               EPION(NNN,IRUN)=AP1
10317               LPION(NNN+1,IRUN)=4
10318               EPION(NNN+1,IRUN)=AP1
10319            ELSEIF(X3.LT.2./3.AND.X3.GT.1./3.)THEN
10320               LB(I)=1
10321               NLAB=1
10322               LPION(NNN,IRUN)=3
10323               EPION(NNN,IRUN)=AP2
10324               LPION(NNN+1,IRUN)=4
10325               EPION(NNN+1,IRUN)=AP1
10326            ELSE
10327               LB(I)=2
10328               NLAB=2
10329               LPION(NNN,IRUN)=5
10330               EPION(NNN,IRUN)=AP2
10331               LPION(NNN+1,IRUN)=3
10332               EPION(NNN+1,IRUN)=AP2
10333            ENDIF
10334         ENDIF
10335
10336         CALL DKINE2(IRUN,I,NNN,NLAB,ISEED,wid,nt)
10337 c
10338 c     anti-particle ID for anti-N* decays:
10339         if(lbanti.lt.0) then
10340            lbi=LB(I)
10341            if(lbi.eq.1.or.lbi.eq.2) then
10342               lbi=-lbi
10343            elseif(lbi.eq.3) then
10344               lbi=5
10345            elseif(lbi.eq.5) then
10346               lbi=3
10347            endif
10348            LB(I)=lbi
10349 c
10350            lbi=LPION(NNN,IRUN)
10351            if(lbi.eq.3) then
10352               lbi=5
10353            elseif(lbi.eq.5) then
10354               lbi=3
10355            elseif(lbi.eq.1.or.lbi.eq.2) then
10356               lbi=-lbi
10357            endif
10358            LPION(NNN,IRUN)=lbi
10359 c
10360            lbi=LPION(NNN+1,IRUN)
10361            if(lbi.eq.3) then
10362               lbi=5
10363            elseif(lbi.eq.5) then
10364               lbi=3
10365            elseif(lbi.eq.1.or.lbi.eq.2) then
10366               lbi=-lbi
10367            endif
10368            LPION(NNN+1,IRUN)=lbi
10369         endif
10370 c
10371        RETURN
10372        END
10373 *-------------------------------------------------------------------
10374 *--------------------------------------------------------------------------
10375 *         CALCULATE THE MOMENTUM OF NUCLEON AND PION (OR ETA)
10376 *         IN THE LAB. FRAME AFTER DELTA OR N* DECAY
10377 * DATE   : JAN. 24,1990, MODIFIED ON MAY 17, 1994 TO INCLUDE ETA PRODUCTION
10378 *--------------------------------------------------------------------------
10379         SUBROUTINE DKINE2(IRUN,I,NNN,NLAB,ISEED,wid,nt)
10380         PARAMETER (hbarc=0.19733)
10381         PARAMETER (MAXSTR=150001,MAXR=1,
10382      1  AMN=0.939457,AMP=0.93828,ETAM=0.5475,
10383      2  AP1=0.13496,AP2=0.13957,AM0=1.232,PI=3.1415926)
10384         COMMON /AA/ R(3,MAXSTR)
10385 cc      SAVE /AA/
10386         COMMON /BB/ P(3,MAXSTR)
10387 cc      SAVE /BB/
10388         COMMON /CC/ E(MAXSTR)
10389 cc      SAVE /CC/
10390         COMMON /EE/ ID(MAXSTR),LB(MAXSTR)
10391 cc      SAVE /EE/
10392         COMMON   /RUN/NUM
10393 cc      SAVE /RUN/
10394         COMMON   /PA/RPION(3,MAXSTR,MAXR)
10395 cc      SAVE /PA/
10396         COMMON   /PB/PPION(3,MAXSTR,MAXR)
10397 cc      SAVE /PB/
10398         COMMON   /PC/EPION(MAXSTR,MAXR)
10399 cc      SAVE /PC/
10400         COMMON   /PD/LPION(MAXSTR,MAXR)
10401 cc      SAVE /PD/
10402       common/leadng/lb1,px1,py1,pz1,em1,e1,xfnl,yfnl,zfnl,tfnl,
10403      1 px1n,py1n,pz1n,dp1n
10404 cc      SAVE /leadng/
10405         COMMON/tdecay/tfdcy(MAXSTR),tfdpi(MAXSTR,MAXR),tft(MAXSTR)
10406 cc      SAVE /tdecay/
10407         COMMON /INPUT2/ ILAB, MANYB, NTMAX, ICOLL, INSYS, IPOT, MODE,
10408      &       IMOMEN, NFREQ, ICFLOW, ICRHO, ICOU, KPOTEN, KMUL
10409 cc      SAVE /INPUT2/
10410         EXTERNAL IARFLV, INVFLV
10411       COMMON/RNDF77/NSEED
10412 cc      SAVE /RNDF77/
10413       COMMON /dpert/dpertt(MAXSTR,MAXR),dpertp(MAXSTR),dplast(MAXSTR),
10414      1     dpdcy(MAXSTR),dpdpi(MAXSTR,MAXR),dpt(MAXSTR, MAXR),
10415      2     dpp1(MAXSTR,MAXR),dppion(MAXSTR,MAXR)
10416       SAVE
10417
10418         ISEED=ISEED
10419 * READ IN THE COORDINATES OF THE N*(1440) UNDERGOING DECAY
10420         PX=P(1,I)
10421         PY=P(2,I)
10422         PZ=P(3,I)
10423         RX=R(1,I)
10424         RY=R(2,I)
10425         RZ=R(3,I)
10426         DM=E(I)
10427         EDELTA=SQRT(DM**2+PX**2+PY**2+PZ**2)
10428         PM1=EPION(NNN,IRUN)
10429         PM2=EPION(NNN+1,IRUN)
10430         AM=AMN
10431        IF(NLAB.EQ.1)AM=AMP
10432 * THE MAXIMUM MOMENTUM OF THE NUCLEON FROM THE DECAY OF A N*
10433        PMAX2=(DM**2-(AM+PM1+PM2)**2)*(DM**2-(AM-PM1-PM2)**2)/4/DM**2
10434        PMAX=SQRT(PMAX2)
10435 * GENERATE THE MOMENTUM OF THE NUCLEON IN THE N* REST FRAME
10436        CSS=1.-2.*RANART(NSEED)
10437        SSS=SQRT(1-CSS**2)
10438        FAI=2*PI*RANART(NSEED)
10439        PX0=PMAX*SSS*COS(FAI)
10440        PY0=PMAX*SSS*SIN(FAI)
10441        PZ0=PMAX*CSS
10442        EP0=SQRT(PX0**2+PY0**2+PZ0**2+AM**2)
10443 clin-5/23/01 bug: P0 for pion0 is equal to PMAX, leaving pion+ and pion-
10444 c     without no relative momentum, thus producing them with equal momenta,
10445 * BETA AND GAMMA OF THE CMS OF PION+-PION-
10446        BETAX=-PX0/(DM-EP0)
10447        BETAY=-PY0/(DM-EP0)
10448        BETAZ=-PZ0/(DM-EP0)
10449        GD1=1./SQRT(1-BETAX**2-BETAY**2-BETAZ**2)
10450        FGD1=GD1/(1+GD1)
10451 * GENERATE THE MOMENTA OF PIONS IN THE CMS OF PION+PION-
10452         Q2=((DM-EP0)/(2.*GD1))**2-PM1**2
10453         IF(Q2.LE.0.)Q2=1.E-09
10454         Q=SQRT(Q2)
10455 11      QX=1.-2.*RANART(NSEED)
10456         QY=1.-2.*RANART(NSEED)
10457         QZ=1.-2.*RANART(NSEED)
10458         QS=QX**2+QY**2+QZ**2
10459         IF(QS.GT.1.) GO TO 11
10460         PXP=Q*QX/SQRT(QS)
10461         PYP=Q*QY/SQRT(QS)
10462         PZP=Q*QZ/SQRT(QS)
10463         EP=SQRT(Q**2+PM1**2)
10464         PXN=-PXP
10465         PYN=-PYP
10466         PZN=-PZP
10467         EN=SQRT(Q**2+PM2**2)
10468 * TRANSFORM THE MOMENTA OF PION+PION- INTO THE N* REST FRAME
10469         BPP1=BETAX*PXP+BETAY*PYP+BETAZ*PZP
10470         BPN1=BETAX*PXN+BETAY*PYN+BETAZ*PZN
10471 * FOR PION-
10472         P1M=PXN+BETAX*GD1*(FGD1*BPN1+EN)
10473         P2M=PYN+BETAY*GD1*(FGD1*BPN1+EN)
10474         P3M=PZN+BETAZ*GD1*(FGD1*BPN1+EN)
10475        EPN=SQRT(P1M**2+P2M**2+P3M**2+PM2**2)
10476 * FOR PION+
10477         P1P=PXP+BETAX*GD1*(FGD1*BPP1+EP)
10478         P2P=PYP+BETAY*GD1*(FGD1*BPP1+EP)
10479         P3P=PZP+BETAZ*GD1*(FGD1*BPP1+EP)
10480        EPP=SQRT(P1P**2+P2P**2+P3P**2+PM1**2)
10481 * TRANSFORM MOMENTA OF THE THREE PIONS INTO THE
10482 * THE NUCLEUS-NUCLEUS CENTER OF MASS  FRAME.
10483 * THE GENERAL LORENTZ TRANSFORMATION CAN
10484 * BE FOUND ON PAGE 34 OF R. HAGEDORN " RELATIVISTIC KINEMATICS"
10485         GD=EDELTA/DM
10486         FGD=GD/(1.+GD)
10487         BDX=PX/EDELTA
10488         BDY=PY/EDELTA
10489         BDZ=PZ/EDELTA
10490        BP0=BDX*PX0+BDY*PY0+BDZ*PZ0
10491         BPP=BDX*P1P+BDY*P2P+BDZ*P3P
10492         BPN=BDX*P1M+BDY*P2M+BDZ*P3M
10493 * FOR THE NUCLEON
10494         P(1,I)=PX0+BDX*GD*(FGD*BP0+EP0)
10495         P(2,I)=PY0+BDY*GD*(FGD*BP0+EP0)
10496         P(3,I)=PZ0+BDZ*GD*(FGD*BP0+EP0)
10497        E(I)=am
10498        ID(I)=0
10499        enucl=sqrt(p(1,i)**2+p(2,i)**2+p(3,i)**2+e(i)**2)
10500 * WE ASSUME THAT THE SPACIAL COORDINATE OF THE PION0
10501 * IS in a sphere of radius 0.5 fm around N*
10502 * FOR PION+
10503         PPION(1,NNN,IRUN)=P1P+BDX*GD*(FGD*BPP+EPP)
10504         PPION(2,NNN,IRUN)=P2P+BDY*GD*(FGD*BPP+EPP)
10505         PPION(3,NNN,IRUN)=P3P+BDZ*GD*(FGD*BPP+EPP)
10506        epion1=sqrt(ppion(1,nnn,irun)**2
10507      &  +ppion(2,nnn,irun)**2+ppion(3,nnn,irun)**2
10508      &  +epion(nnn,irun)**2)
10509 clin-2/20/03 no additional smearing for position of decay daughters:
10510 c200         X0 = 1.0 - 2.0 * RANART(NSEED)
10511 c            Y0 = 1.0 - 2.0 * RANART(NSEED)
10512 c            Z0 = 1.0 - 2.0 * RANART(NSEED)
10513 c        IF ((X0*X0+Y0*Y0+Z0*Z0) .GT. 1.0) GOTO 200
10514 c        RPION(1,NNN,IRUN)=R(1,I)+0.5*x0
10515 c        RPION(2,NNN,IRUN)=R(2,I)+0.5*y0
10516 c        RPION(3,NNN,IRUN)=R(3,I)+0.5*z0
10517         RPION(1,NNN,IRUN)=R(1,I)
10518         RPION(2,NNN,IRUN)=R(2,I)
10519         RPION(3,NNN,IRUN)=R(3,I)
10520 * FOR PION-
10521         PPION(1,NNN+1,IRUN)=P1M+BDX*GD*(FGD*BPN+EPN)
10522         PPION(2,NNN+1,IRUN)=P2M+BDY*GD*(FGD*BPN+EPN)
10523         PPION(3,NNN+1,IRUN)=P3M+BDZ*GD*(FGD*BPN+EPN)
10524 clin-5/2008:
10525         dppion(NNN,IRUN)=dpertp(I)
10526         dppion(NNN+1,IRUN)=dpertp(I)
10527 c
10528        epion2=sqrt(ppion(1,nnn+1,irun)**2
10529      &  +ppion(2,nnn+1,irun)**2+ppion(3,nnn+1,irun)**2
10530      &  +epion(nnn+1,irun)**2)
10531 clin-2/20/03 no additional smearing for position of decay daughters:
10532 c300         X0 = 1.0 - 2.0 * RANART(NSEED)
10533 c            Y0 = 1.0 - 2.0 * RANART(NSEED)
10534 c            Z0 = 1.0 - 2.0 * RANART(NSEED)
10535 c        IF ((X0*X0+Y0*Y0+Z0*Z0) .GT. 1.0) GOTO 300
10536 c        RPION(1,NNN+1,IRUN)=R(1,I)+0.5*x0
10537 c        RPION(2,NNN+1,IRUN)=R(2,I)+0.5*y0
10538 c        RPION(3,NNN+1,IRUN)=R(3,I)+0.5*z0
10539         RPION(1,NNN+1,IRUN)=R(1,I)
10540         RPION(2,NNN+1,IRUN)=R(2,I)
10541         RPION(3,NNN+1,IRUN)=R(3,I)
10542 c
10543 * check energy conservation in the decay
10544 c       efinal=enucl+epion1+epion2
10545 c       DEEE=(EDELTA-EFINAL)/EDELTA
10546 c       IF(ABS(DEEE).GE.1.E-03)write(6,*)1,edelta,efinal
10547
10548         devio=SQRT(EPION(NNN,IRUN)**2+PPION(1,NNN,IRUN)**2
10549      1       +PPION(2,NNN,IRUN)**2+PPION(3,NNN,IRUN)**2)
10550      2       +SQRT(E(I)**2+P(1,I)**2+P(2,I)**2+P(3,I)**2)
10551      3       +SQRT(EPION(NNN+1,IRUN)**2+PPION(1,NNN+1,IRUN)**2
10552      4       +PPION(2,NNN+1,IRUN)**2+PPION(3,NNN+1,IRUN)**2)-e1
10553 c        if(abs(devio).gt.0.02) write(93,*) 'decay2(): nt=',nt,devio,lb1
10554
10555 c     add decay time to daughter's formation time at the last timestep:
10556         if(nt.eq.ntmax) then
10557            tau0=hbarc/wid
10558            taudcy=tau0*(-1.)*alog(1.-RANART(NSEED))
10559 c     lorentz boost:
10560            taudcy=taudcy*e1/em1
10561            tfnl=tfnl+taudcy
10562            xfnl=xfnl+px1/e1*taudcy
10563            yfnl=yfnl+py1/e1*taudcy
10564            zfnl=zfnl+pz1/e1*taudcy
10565            R(1,I)=xfnl
10566            R(2,I)=yfnl
10567            R(3,I)=zfnl
10568            tfdcy(I)=tfnl
10569            RPION(1,NNN,IRUN)=xfnl
10570            RPION(2,NNN,IRUN)=yfnl
10571            RPION(3,NNN,IRUN)=zfnl
10572            tfdpi(NNN,IRUN)=tfnl
10573            RPION(1,NNN+1,IRUN)=xfnl
10574            RPION(2,NNN+1,IRUN)=yfnl
10575            RPION(3,NNN+1,IRUN)=zfnl
10576            tfdpi(NNN+1,IRUN)=tfnl
10577         endif
10578
10579 cc 200    format(a30,2(1x,e10.4))
10580 cc 210    format(i6,5(1x,f8.3))
10581 cc 220    format(a2,i5,5(1x,f8.3))
10582
10583         RETURN
10584         END
10585 *---------------------------------------------------------------------------
10586 *---------------------------------------------------------------------------
10587 * PURPOSE : CALCULATE THE MASS AND MOMENTUM OF BARYON RESONANCE
10588 *           AFTER PION OR ETA BEING ABSORBED BY A NUCLEON
10589 * NOTE    :
10590 *
10591 * DATE    : JAN.29,1990
10592         SUBROUTINE DRESON(I1,I2)
10593         PARAMETER (MAXSTR=150001,MAXR=1,
10594      1  AMN=0.939457,AMP=0.93828,
10595      2  AP1=0.13496,AP2=0.13957,AM0=1.232,PI=3.1415926)
10596         COMMON /AA/ R(3,MAXSTR)
10597 cc      SAVE /AA/
10598         COMMON /BB/ P(3,MAXSTR)
10599 cc      SAVE /BB/
10600         COMMON /CC/ E(MAXSTR)
10601 cc      SAVE /CC/
10602         COMMON /EE/ ID(MAXSTR),LB(MAXSTR)
10603 cc      SAVE /EE/
10604         COMMON   /RUN/NUM
10605 cc      SAVE /RUN/
10606         COMMON   /PA/RPION(3,MAXSTR,MAXR)
10607 cc      SAVE /PA/
10608         COMMON   /PB/PPION(3,MAXSTR,MAXR)
10609 cc      SAVE /PB/
10610         COMMON   /PC/EPION(MAXSTR,MAXR)
10611 cc      SAVE /PC/
10612         COMMON   /PD/LPION(MAXSTR,MAXR)
10613 cc      SAVE /PD/
10614       SAVE
10615 * 1. DETERMINE THE MOMENTUM COMPONENT OF DELTA/N* IN THE LAB. FRAME
10616         E10=SQRT(E(I1)**2+P(1,I1)**2+P(2,I1)**2+P(3,I1)**2)
10617         E20=SQRT(E(I2)**2+P(1,I2)**2+P(2,I2)**2+P(3,I2)**2)
10618         IF(iabs(LB(I2)) .EQ. 1 .OR. iabs(LB(I2)) .EQ. 2 .OR.
10619      &     (iabs(LB(I2)) .GE. 6 .AND. iabs(LB(I2)) .LE. 17)) THEN
10620         E(I1)=0.
10621         I=I2
10622         ELSE
10623         E(I2)=0.
10624         I=I1
10625         ENDIF
10626         P(1,I)=P(1,I1)+P(1,I2)
10627         P(2,I)=P(2,I1)+P(2,I2)
10628         P(3,I)=P(3,I1)+P(3,I2)
10629 * 2. DETERMINE THE MASS OF DELTA/N* BY USING THE REACTION KINEMATICS
10630         DM=SQRT((E10+E20)**2-P(1,I)**2-P(2,I)**2-P(3,I)**2)
10631         E(I)=DM
10632         RETURN
10633         END
10634 *---------------------------------------------------------------------------
10635 * PURPOSE : CALCULATE THE MASS AND MOMENTUM OF RHO RESONANCE
10636 *           AFTER PION + PION COLLISION
10637 * DATE    : NOV. 30,1994
10638         SUBROUTINE RHORES(I1,I2)
10639         PARAMETER (MAXSTR=150001,MAXR=1,
10640      1  AMN=0.939457,AMP=0.93828,
10641      2  AP1=0.13496,AP2=0.13957,AM0=1.232,PI=3.1415926)
10642         COMMON /AA/ R(3,MAXSTR)
10643 cc      SAVE /AA/
10644         COMMON /BB/ P(3,MAXSTR)
10645 cc      SAVE /BB/
10646         COMMON /CC/ E(MAXSTR)
10647 cc      SAVE /CC/
10648         COMMON /EE/ ID(MAXSTR),LB(MAXSTR)
10649 cc      SAVE /EE/
10650         COMMON   /RUN/NUM
10651 cc      SAVE /RUN/
10652         COMMON   /PA/RPION(3,MAXSTR,MAXR)
10653 cc      SAVE /PA/
10654         COMMON   /PB/PPION(3,MAXSTR,MAXR)
10655 cc      SAVE /PB/
10656         COMMON   /PC/EPION(MAXSTR,MAXR)
10657 cc      SAVE /PC/
10658         COMMON   /PD/LPION(MAXSTR,MAXR)
10659 cc      SAVE /PD/
10660       SAVE
10661 * 1. DETERMINE THE MOMENTUM COMPONENT OF THE RHO IN THE CMS OF NN FRAME
10662 *    WE LET I1 TO BE THE RHO AND ABSORB I2
10663         E10=SQRT(E(I1)**2+P(1,I1)**2+P(2,I1)**2+P(3,I1)**2)
10664         E20=SQRT(E(I2)**2+P(1,I2)**2+P(2,I2)**2+P(3,I2)**2)
10665         P(1,I1)=P(1,I1)+P(1,I2)
10666         P(2,I1)=P(2,I1)+P(2,I2)
10667         P(3,I1)=P(3,I1)+P(3,I2)
10668 * 2. DETERMINE THE MASS OF THE RHO BY USING THE REACTION KINEMATICS
10669         DM=SQRT((E10+E20)**2-P(1,I1)**2-P(2,I1)**2-P(3,I1)**2)
10670         E(I1)=DM
10671        E(I2)=0
10672         RETURN
10673         END
10674 *---------------------------------------------------------------------------
10675 * PURPOSE : CALCULATE THE PION+NUCLEON CROSS SECTION ACCORDING TO THE
10676 *           BREIT-WIGNER FORMULA/(p*)**2
10677 * VARIABLE : LA = 1 FOR DELTA RESONANCE
10678 *            LA = 0 FOR N*(1440) RESONANCE
10679 *            LA = 2 FRO N*(1535) RESONANCE
10680 * DATE    : JAN.29,1990
10681         REAL FUNCTION XNPI(I1,I2,LA,XMAX)
10682         PARAMETER (MAXSTR=150001,MAXR=1,
10683      1  AMN=0.939457,AMP=0.93828,
10684      2  AP1=0.13496,AP2=0.13957,AM0=1.232,PI=3.1415926)
10685         COMMON /AA/ R(3,MAXSTR)
10686 cc      SAVE /AA/
10687         COMMON /BB/ P(3,MAXSTR)
10688 cc      SAVE /BB/
10689         COMMON /CC/ E(MAXSTR)
10690 cc      SAVE /CC/
10691         COMMON /EE/ ID(MAXSTR),LB(MAXSTR)
10692 cc      SAVE /EE/
10693         COMMON   /RUN/NUM
10694 cc      SAVE /RUN/
10695         COMMON   /PA/RPION(3,MAXSTR,MAXR)
10696 cc      SAVE /PA/
10697         COMMON   /PB/PPION(3,MAXSTR,MAXR)
10698 cc      SAVE /PB/
10699         COMMON   /PC/EPION(MAXSTR,MAXR)
10700 cc      SAVE /PC/
10701         COMMON   /PD/LPION(MAXSTR,MAXR)
10702 cc      SAVE /PD/
10703       SAVE
10704         AVMASS=0.5*(AMN+AMP)
10705         AVPI=(2.*AP2+AP1)/3.
10706 * 1. DETERMINE THE MOMENTUM COMPONENT OF DELTA IN THE LAB. FRAME
10707         E10=SQRT(E(I1)**2+P(1,I1)**2+P(2,I1)**2+P(3,I1)**2)
10708         E20=SQRT(E(I2)**2+P(1,I2)**2+P(2,I2)**2+P(3,I2)**2)
10709         P1=P(1,I1)+P(1,I2)
10710         P2=P(2,I1)+P(2,I2)
10711         P3=P(3,I1)+P(3,I2)
10712 * 2. DETERMINE THE MASS OF DELTA BY USING OF THE REACTION KINEMATICS
10713         DM=SQRT((E10+E20)**2-P1**2-P2**2-P3**2)
10714         IF(DM.LE.1.1) THEN
10715         XNPI=1.e-09
10716         RETURN
10717         ENDIF
10718 * 3. DETERMINE THE PION+NUCLEON CROSS SECTION ACCORDING TO THE
10719 *    BREIT-WIGNER FORMULA IN UNIT OF FM**2
10720         IF(LA.EQ.1)THEN
10721         GAM=WIDTH(DM)
10722         F1=0.25*GAM**2/(0.25*GAM**2+(DM-1.232)**2)
10723         PDELT2=0.051622
10724         GO TO 10
10725        ENDIF
10726        IF(LA.EQ.0)THEN
10727         GAM=W1440(DM)
10728         F1=0.25*GAM**2/(0.25*GAM**2+(DM-1.440)**2)
10729         PDELT2=0.157897
10730        GO TO 10
10731         ENDIF
10732        IF(LA.EQ.2)THEN
10733         GAM=W1535(DM)
10734         F1=0.25*GAM**2/(0.25*GAM**2+(DM-1.535)**2)
10735         PDELT2=0.2181
10736         ENDIF
10737 10      PSTAR2=((DM**2-AVMASS**2+AVPI**2)/(2.*DM))**2-AVPI**2
10738         IF(PSTAR2.LE.0.)THEN
10739         XNPI=1.e-09
10740         ELSE
10741 * give the cross section in unit of fm**2
10742         XNPI=F1*(PDELT2/PSTAR2)*XMAX/10.
10743         ENDIF
10744         RETURN
10745         END
10746 *------------------------------------------------------------------------------
10747 *****************************************
10748         REAL FUNCTION SIGMA(SRT,ID,IOI,IOF)
10749 *PURPOSE : THIS IS THE PROGRAM TO CALCULATE THE ISOSPIN DECOMPOSED CROSS
10750 *       SECTION BY USING OF B.J.VerWEST AND R.A.ARNDT'S PARAMETERIZATION
10751 *REFERENCE: PHYS. REV. C25(1982)1979
10752 *QUANTITIES: IOI -- INITIAL ISOSPIN OF THE TWO NUCLEON SYSTEM
10753 *            IOF -- FINAL   ISOSPIN -------------------------
10754 *            ID -- =1 FOR DELTA RESORANCE
10755 *                  =2 FOR N*    RESORANCE
10756 *DATE : MAY 15,1990
10757 *****************************************
10758         PARAMETER (AMU=0.9383,AMP=0.1384,PI=3.1415926,HC=0.19733)
10759       SAVE
10760         IF(ID.EQ.1)THEN
10761         AMASS0=1.22
10762         T0 =0.12
10763         ELSE
10764         AMASS0=1.43
10765         T0 =0.2
10766         ENDIF
10767         IF((IOI.EQ.1).AND.(IOF.EQ.1))THEN
10768         ALFA=3.772
10769         BETA=1.262
10770         AM0=1.188
10771         T=0.09902
10772         ENDIF
10773         IF((IOI.EQ.1).AND.(IOF.EQ.0))THEN
10774         ALFA=15.28
10775         BETA=0.
10776         AM0=1.245
10777         T=0.1374
10778         ENDIF
10779         IF((IOI.EQ.0).AND.(IOF.EQ.1))THEN
10780         ALFA=146.3
10781         BETA=0.
10782         AM0=1.472
10783         T=0.02649
10784         ENDIF
10785         ZPLUS=(SRT-AMU-AMASS0)*2./T0
10786         ZMINUS=(AMU+AMP-AMASS0)*2./T0
10787         deln=ATAN(ZPLUS)-ATAN(ZMINUS)
10788        if(deln.eq.0)deln=1.E-06
10789         AMASS=AMASS0+(T0/4.)*ALOG((1.+ZPLUS**2)/(1.+ZMINUS**2))
10790      1  /deln
10791         S=SRT**2
10792         P2=S/4.-AMU**2
10793         S0=(AMU+AM0)**2
10794         P02=S0/4.-AMU**2
10795         P0=SQRT(P02)
10796         PR2=(S-(AMU-AMASS)**2)*(S-(AMU+AMASS)**2)/(4.*S)
10797         IF(PR2.GT.1.E-06)THEN
10798         PR=SQRT(PR2)
10799         ELSE
10800         PR=0.
10801         SIGMA=1.E-06
10802         RETURN
10803         ENDIF
10804         SS=AMASS**2
10805         Q2=(SS-(AMU-AMP)**2)*(SS-(AMU+AMP)**2)/(4.*SS)
10806         IF(Q2.GT.1.E-06)THEN
10807         Q=SQRT(Q2)
10808         ELSE
10809         Q=0.
10810         SIGMA=1.E-06
10811         RETURN
10812         ENDIF
10813         SS0=AM0**2
10814         Q02=(SS0-(AMU-AMP)**2)*(SS0-(AMU+AMP)**2)/(4.*SS0)
10815         Q0=SQRT(Q02)
10816         SIGMA=PI*(HC)**2/(2.*P2)*ALFA*(PR/P0)**BETA*AM0**2*T**2
10817      1  *(Q/Q0)**3/((SS-AM0**2)**2+AM0**2*T**2)
10818         SIGMA=SIGMA*10.
10819        IF(SIGMA.EQ.0)SIGMA=1.E-06
10820         RETURN
10821         END
10822
10823 *****************************
10824         REAL FUNCTION DENOM(SRT,CON)
10825 * NOTE: CON=1 FOR DELTA RESONANCE, CON=2 FOR N*(1440) RESONANCE
10826 *       con=-1 for N*(1535)
10827 * PURPOSE : CALCULATE THE INTEGRAL IN THE DETAILED BALANCE
10828 *
10829 * DATE : NOV. 15, 1991
10830 *******************************
10831         PARAMETER (AP1=0.13496,
10832      1  AP2=0.13957,PI=3.1415926,AVMASS=0.9383)
10833       SAVE
10834         AVPI=(AP1+2.*AP2)/3.
10835         AM0=1.232
10836         AMN=AVMASS
10837         AMP=AVPI
10838         AMAX=SRT-AVMASS
10839         AMIN=AVMASS+AVPI
10840         NMAX=200
10841         DMASS=(AMAX-AMIN)/FLOAT(NMAX)
10842         SUM=0.
10843         DO 10 I=1,NMAX+1
10844         DM=AMIN+FLOAT(I-1)*DMASS
10845         IF(CON.EQ.1.)THEN
10846         Q2=((DM**2-AMN**2+AMP**2)/(2.*DM))**2-AMP**2
10847            IF(Q2.GT.0.)THEN
10848            Q=SQRT(Q2)
10849            ELSE
10850            Q=1.E-06
10851            ENDIF
10852         TQ=0.47*(Q**3)/(AMP**2*(1.+0.6*(Q/AMP)**2))
10853         ELSE if(con.eq.2)then
10854         TQ=0.2
10855         AM0=1.44
10856        else if(con.eq.-1.)then
10857        tq=0.1
10858        am0=1.535
10859         ENDIF
10860         A1=4.*TQ*AM0**2/(AM0**2*TQ**2+(DM**2-AM0**2)**2)
10861         S=SRT**2
10862         P0=(S+DM**2-AMN**2)**2/(4.*S)-DM**2
10863         IF(P0.LE.0.)THEN
10864         P1=1.E-06
10865         ELSE
10866         P1=SQRT(P0)
10867         ENDIF
10868         F=DM*A1*P1
10869         IF((I.EQ.1).OR.(I.EQ.(NMAX+1)))THEN
10870         SUM=SUM+F*0.5
10871         ELSE
10872         SUM=SUM+F
10873         ENDIF
10874 10      CONTINUE
10875         DENOM=SUM*DMASS/(2.*PI)
10876         RETURN
10877         END
10878 **********************************
10879 * subroutine : ang.FOR
10880 * PURPOSE : Calculate the angular distribution of Delta production process
10881 * DATE    : Nov. 19, 1992
10882 * REFERENCE: G. WOLF ET. AL., NUCL. PHYS. A517 (1990) 615
10883 * Note: this function applies when srt is larger than 2.14 GeV,
10884 * for less energetic reactions, we assume the angular distribution
10885 * is isotropic.
10886 ***********************************
10887        real function anga(srt,iseed)
10888       COMMON/RNDF77/NSEED
10889 cc      SAVE /RNDF77/
10890       SAVE
10891       ISEED=ISEED
10892 c        if(srt.le.2.14)then
10893 c       b1s=0.5
10894 c       b2s=0.
10895 c      endif
10896       if((srt.gt.2.14).and.(srt.le.2.4))then
10897        b1s=29.03-23.75*srt+4.865*srt**2
10898          b2s=-30.33+25.53*srt-5.301*srt**2
10899       endif
10900       if(srt.gt.2.4)then
10901        b1s=0.06
10902          b2s=0.4
10903       endif
10904         x=RANART(NSEED)
10905        p=b1s/b2s
10906        q=(2.*x-1.)*(b1s+b2s)/b2s
10907        IF((-q/2.+sqrt((q/2.)**2+(p/3.)**3)).GE.0.)THEN
10908        ang1=(-q/2.+sqrt((q/2.)**2+(p/3.)**3))**(1./3.)
10909        ELSE
10910        ang1=-(q/2.-sqrt((q/2.)**2+(p/3.)**3))**(1./3.)
10911        ENDIF
10912        IF((-q/2.-sqrt((q/2.)**2+(p/3.)**3).GE.0.))THEN
10913        ang2=(-q/2.-sqrt((q/2.)**2+(p/3.)**3))**(1./3.)
10914        ELSE
10915        ang2=-(q/2.+sqrt((q/2.)**2+(p/3.)**3))**(1./3.)
10916        ENDIF
10917        ANGA=ANG1+ANG2
10918        return
10919        end
10920 *--------------------------------------------------------------------------
10921 *****subprogram * kaon production from pi+B collisions *******************
10922       real function PNLKA(srt)
10923       SAVE
10924 * units: fm**2
10925 ***********************************C
10926       ala=1.116
10927       aka=0.498
10928       ana=0.939
10929       t1=ala+aka
10930       if(srt.le.t1) THEN
10931       Pnlka=0
10932       Else
10933       IF(SRT.LT.1.7)sbbk=(0.9/0.091)*(SRT-T1)
10934       IF(SRT.GE.1.7)sbbk=0.09/(SRT-1.6)
10935       Pnlka=0.25*sbbk
10936 * give the cross section in units of fm**2
10937        pnlka=pnlka/10.
10938       endif
10939       return
10940       end
10941 *-------------------------------------------------------------------------
10942 *****subprogram * kaon production from pi+B collisions *******************
10943       real function PNSKA(srt)
10944       SAVE
10945 ***********************************
10946        if(srt.gt.3.0)then
10947        pnska=0
10948        return
10949        endif
10950       ala=1.116
10951       aka=0.498
10952       ana=0.939
10953       asa=1.197
10954       t1=asa+aka
10955       if(srt.le.t1) THEN
10956       Pnska=0
10957        return
10958       Endif
10959       IF(SRT.LT.1.9)SBB1=(0.7/0.218)*(SRT-T1)
10960       IF(SRT.GE.1.9)SBB1=0.14/(SRT-1.7)
10961       sbb2=0.
10962        if(srt.gT.1.682)sbb2=0.5*(1.-0.75*(srt-1.682))
10963        pnska=0.25*(sbb1+sbb2)
10964 * give the cross section in fm**2
10965        pnska=pnska/10.
10966       return
10967       end
10968
10969 ********************************
10970 *
10971 *       Kaon momentum distribution in baryon-baryon-->N lamda K process
10972 *
10973 *       NOTE: dsima/dp is prototional to (1-p/p_max)(p/p_max)^2
10974 *              we use rejection method to generate kaon momentum
10975 *
10976 *       Variables: Fkaon = F(p)/F_max
10977 *                 srt   = cms energy of the colliding pair,
10978 *                          used to calculate the P_max
10979 *       Date: Feb. 8, 1994
10980 *
10981 *       Reference: C. M. Ko et al.
10982 ********************************
10983        Real function fkaon(p,pmax)
10984       SAVE
10985        fmax=0.148
10986        if(pmax.eq.0.)pmax=0.000001
10987        fkaon=(1.-p/pmax)*(p/pmax)**2
10988        if(fkaon.gt.fmax)fkaon=fmax
10989        fkaon=fkaon/fmax
10990        return
10991        end
10992
10993 *************************
10994 * cross section for N*(1535) production in ND OR NN* collisions
10995 * VARIABLES:
10996 * LB1,LB2 ARE THE LABLES OF THE TWO COLLIDING PARTICLES
10997 * SRT IS THE CMS ENERGY
10998 * X1535 IS THE N*(1535) PRODUCTION CROSS SECTION
10999 * NOTE THAT THE N*(1535) PRODUCTION CROSS SECTION IS 2 TIMES THE ETA
11000 * PRODUCTION CROSS SECTION
11001 * DATE: MAY 18, 1994
11002 * ***********************
11003        Subroutine M1535(LB1,LB2,SRT,X1535)
11004       SAVE
11005        S0=2.424
11006        x1535=0.
11007        IF(SRT.LE.S0)RETURN
11008        SIGMA=2.*0.102*(SRT-S0)/(0.058+(SRT-S0)**2)
11009 * I N*(1535) PRODUCTION IN NUCLEON-DELTA COLLISIONS
11010 *(1) nD(++)->pN*(+)(1535), pD(-)->nN*(0)(1535),pD(+)-->N*(+)p
11011 cbz11/25/98
11012 c       IF((LB1*LB2.EQ.18).OR.(LB1*LB2.EQ.6).
11013 c     1  or.(lb1*lb2).eq.8)then
11014        IF((LB1*LB2.EQ.18.AND.(LB1.EQ.2.OR.LB2.EQ.2)).OR.
11015      &     (LB1*LB2.EQ.6.AND.(LB1.EQ.1.OR.LB2.EQ.1)).or.
11016      &     (lb1*lb2.eq.8.AND.(LB1.EQ.1.OR.LB2.EQ.1)))then
11017 cbz11/25/98end
11018        X1535=SIGMA
11019        return
11020        ENDIF
11021 *(2) pD(0)->pN*(0)(1535),pD(0)->nN*(+)(1535)
11022        IF(LB1*LB2.EQ.7)THEN
11023        X1535=3.*SIGMA
11024        RETURN
11025        ENDIF
11026 * II N*(1535) PRODUCTION IN N*(1440)+NUCLEON REACTIONS
11027 *(3) N*(+)(1440)p->N*(0+)(1535)p, N*(0)(1440)n->N*(0)(1535)
11028 cbz11/25/98
11029 c       IF((LB1*LB2.EQ.11).OR.(LB1*LB2.EQ.20))THEN
11030        IF((LB1*LB2.EQ.11).OR.
11031      &     (LB1*LB2.EQ.20.AND.(LB1.EQ.2.OR.LB2.EQ.2)))THEN
11032 cbz11/25/98end
11033        X1535=SIGMA
11034        RETURN
11035        ENDIF
11036 *(4) N*(0)(1440)p->N*(0+) or N*(+)(1440)n->N*(0+)(1535)
11037 cbz11/25/98
11038 c       IF((LB1*LB2.EQ.10).OR.(LB1*LB2.EQ.22))X1535=3.*SIGMA
11039        IF((LB1*LB2.EQ.10.AND.(LB1.EQ.1.OR.LB2.EQ.1)).OR.
11040      &     (LB1*LB2.EQ.22.AND.(LB1.EQ.2.OR.LB2.EQ.2)))
11041      &     X1535=3.*SIGMA
11042 cbz11/25/98end
11043        RETURN
11044        END
11045 *************************
11046 * cross section for N*(1535) production in NN collisions
11047 * VARIABLES:
11048 * LB1,LB2 ARE THE LABLES OF THE TWO COLLIDING PARTICLES
11049 * SRT IS THE CMS ENERGY
11050 * X1535 IS THE N*(1535) PRODUCTION CROSS SECTION
11051 * NOTE THAT THE N*(1535) PRODUCTION CROSS SECTION IS 2 TIMES THE ETA
11052 * PRODUCTION CROSS SECTION
11053 * DATE: MAY 18, 1994
11054 * ***********************
11055        Subroutine N1535(LB1,LB2,SRT,X1535)
11056       SAVE
11057        S0=2.424
11058        x1535=0.
11059        IF(SRT.LE.S0)RETURN
11060        SIGMA=2.*0.102*(SRT-S0)/(0.058+(SRT-S0)**2)
11061 * I N*(1535) PRODUCTION IN NUCLEON-NUCLEON COLLISIONS
11062 *(1) pp->pN*(+)(1535), nn->nN*(0)(1535)
11063 cbdbg11/25/98
11064 c       IF((LB1*LB2.EQ.1).OR.(LB1*LB2.EQ.4))then
11065        IF((LB1*LB2.EQ.1).OR.
11066      &     (LB1.EQ.2.AND.LB2.EQ.2))then
11067 cbz11/25/98end
11068        X1535=SIGMA
11069        return
11070        endif
11071 *(2) pn->pN*(0)(1535),pn->nN*(+)(1535)
11072        IF(LB1*LB2.EQ.2)then
11073        X1535=3.*SIGMA
11074        return
11075        endif
11076 * III N*(1535) PRODUCTION IN DELTA+DELTA REACTIONS
11077 * (5) D(++)+D(0), D(+)+D(+),D(+)+D(-),D(0)+D(0)
11078 cbz11/25/98
11079 c       IF((LB1*LB2.EQ.63).OR.(LB1*LB2.EQ.64).OR.(LB1*LB2.EQ.48).
11080 c     1  OR.(LB1*LB2.EQ.49))then
11081        IF((LB1*LB2.EQ.63.AND.(LB1.EQ.7.OR.LB2.EQ.7)).OR.
11082      &     (LB1*LB2.EQ.64.AND.(LB1.EQ.8.OR.LB2.EQ.8)).OR.
11083      &     (LB1*LB2.EQ.48.AND.(LB1.EQ.6.OR.LB2.EQ.6)).OR.
11084      &     (LB1*LB2.EQ.49.AND.(LB1.EQ.7.OR.LB2.EQ.7)))then
11085 cbz11/25/98end
11086        X1535=SIGMA
11087        return
11088        endif
11089 * (6) D(++)+D(-),D(+)+D(0)
11090 cbz11/25/98
11091 c       IF((LB1*LB2.EQ.54).OR.(LB1*LB2.EQ.56))then
11092        IF((LB1*LB2.EQ.54.AND.(LB1.EQ.6.OR.LB2.EQ.6)).OR.
11093      &     (LB1*LB2.EQ.56.AND.(LB1.EQ.7.OR.LB2.EQ.7)))then
11094 cbz11/25/98end
11095        X1535=3.*SIGMA
11096        return
11097        endif
11098 * IV N*(1535) PRODUCTION IN N*(1440)+N*(1440) REACTIONS
11099 cbz11/25/98
11100 c       IF((LB1*LB2.EQ.100).OR.(LB1*LB2.EQ.11*11))X1535=SIGMA
11101        IF((LB1.EQ.10.AND.LB2.EQ.10).OR.
11102      &     (LB1.EQ.11.AND.LB2.EQ.11))X1535=SIGMA
11103 c       IF(LB1*LB2.EQ.110)X1535=3.*SIGMA
11104        IF(LB1*LB2.EQ.110.AND.(LB1.EQ.10.OR.LB2.EQ.10))X1535=3.*SIGMA
11105 cbdbg11/25/98end
11106        RETURN
11107        END
11108 ************************************
11109 * FUNCTION WA1(DMASS) GIVES THE A1 DECAY WIDTH
11110
11111         subroutine WIDA1(DMASS,rhomp,wa1,iseed)
11112       SAVE
11113 c
11114         PIMASS=0.137265
11115         coupa = 14.8
11116 c
11117        RHOMAX = DMASS-PIMASS-0.02
11118        IF(RHOMAX.LE.0)then
11119          rhomp=0.
11120 c   !! no decay
11121          wa1=-10.
11122         endif
11123         icount = 0
11124 711       rhomp=RHOMAS(RHOMAX,ISEED)
11125       icount=icount+1
11126       if(dmass.le.(pimass+rhomp)) then
11127        if(icount.le.100) then
11128         goto 711
11129        else
11130          rhomp=0.
11131 c   !! no decay
11132          wa1=-10.
11133         return
11134        endif
11135       endif
11136       qqp2=(dmass**2-(rhomp+pimass)**2)*(dmass**2-(rhomp-pimass)**2)
11137       qqp=sqrt(qqp2)/(2.0*dmass)
11138       epi=sqrt(pimass**2+qqp**2)
11139       erho=sqrt(rhomp**2+qqp**2)
11140       epirho=2.0*(epi*erho+qqp**2)**2+rhomp**2*epi**2
11141       wa1=coupa**2*qqp*epirho/(24.0*3.1416*dmass**2)
11142        return
11143        end
11144 ************************************
11145 * FUNCTION W1535(DMASS) GIVES THE N*(1535) DECAY WIDTH
11146 c     FOR A GIVEN N*(1535) MASS
11147 * HERE THE FORMULA GIVEN BY KITAZOE IS USED
11148         REAL FUNCTION W1535(DMASS)
11149       SAVE
11150         AVMASS=0.938868
11151         PIMASS=0.137265
11152            AUX = 0.25*(DMASS**2-AVMASS**2-PIMASS**2)**2
11153      &           -(AVMASS*PIMASS)**2
11154             IF (AUX .GT. 0.) THEN
11155               QAVAIL = SQRT(AUX / DMASS**2)
11156             ELSE
11157               QAVAIL = 1.E-06
11158             END IF
11159             W1535 = 0.15* QAVAIL/0.467
11160 c       W1535=0.15
11161         RETURN
11162         END
11163 ************************************
11164 * FUNCTION W1440(DMASS) GIVES THE N*(1440) DECAY WIDTH
11165 c     FOR A GIVEN N*(1535) MASS
11166 * HERE THE FORMULA GIVEN BY KITAZOE IS USED
11167         REAL FUNCTION W1440(DMASS)
11168       SAVE
11169         AVMASS=0.938868
11170         PIMASS=0.137265
11171            AUX = 0.25*(DMASS**2-AVMASS**2-PIMASS**2)**2
11172      &           -(AVMASS*PIMASS)**2
11173             IF (AUX .GT. 0.) THEN
11174               QAVAIL = SQRT(AUX)/DMASS
11175             ELSE
11176               QAVAIL = 1.E-06
11177             END IF
11178 c              w1440=0.2
11179            W1440 = 0.2* (QAVAIL/0.397)**3
11180         RETURN
11181         END
11182 ****************
11183 * PURPOSE : CALCULATE THE PION(ETA)+NUCLEON CROSS SECTION
11184 *           ACCORDING TO THE BREIT-WIGNER FORMULA,
11185 *           NOTE THAT N*(1535) IS S_11
11186 * VARIABLE : LA = 1 FOR PI+N
11187 *            LA = 0 FOR ETA+N
11188 * DATE    : MAY 16, 1994
11189 ****************
11190         REAL FUNCTION XN1535(I1,I2,LA)
11191         PARAMETER (MAXSTR=150001,MAXR=1,
11192      1  AMN=0.939457,AMP=0.93828,ETAM=0.5475,
11193      2  AP1=0.13496,AP2=0.13957,AM0=1.232,PI=3.1415926)
11194         COMMON /AA/ R(3,MAXSTR)
11195 cc      SAVE /AA/
11196         COMMON /BB/ P(3,MAXSTR)
11197 cc      SAVE /BB/
11198         COMMON /CC/ E(MAXSTR)
11199 cc      SAVE /CC/
11200         COMMON /EE/ ID(MAXSTR),LB(MAXSTR)
11201 cc      SAVE /EE/
11202         COMMON   /RUN/NUM
11203 cc      SAVE /RUN/
11204         COMMON   /PA/RPION(3,MAXSTR,MAXR)
11205 cc      SAVE /PA/
11206         COMMON   /PB/PPION(3,MAXSTR,MAXR)
11207 cc      SAVE /PB/
11208         COMMON   /PC/EPION(MAXSTR,MAXR)
11209 cc      SAVE /PC/
11210         COMMON   /PD/LPION(MAXSTR,MAXR)
11211 cc      SAVE /PD/
11212       SAVE
11213         AVMASS=0.5*(AMN+AMP)
11214         AVPI=(2.*AP2+AP1)/3.
11215 * 1. DETERMINE THE MOMENTUM COMPONENT OF N*(1535) IN THE LAB. FRAME
11216         E10=SQRT(E(I1)**2+P(1,I1)**2+P(2,I1)**2+P(3,I1)**2)
11217         E20=SQRT(E(I2)**2+P(1,I2)**2+P(2,I2)**2+P(3,I2)**2)
11218         P1=P(1,I1)+P(1,I2)
11219         P2=P(2,I1)+P(2,I2)
11220         P3=P(3,I1)+P(3,I2)
11221 * 2. DETERMINE THE MASS OF DELTA BY USING OF THE REACTION KINEMATICS
11222         DM=SQRT((E10+E20)**2-P1**2-P2**2-P3**2)
11223         IF(DM.LE.1.1) THEN
11224         XN1535=1.E-06
11225         RETURN
11226         ENDIF
11227 * 3. DETERMINE THE PION(ETA)+NUCLEON->N*(1535) CROSS SECTION ACCORDING TO THE
11228 *    BREIT-WIGNER FORMULA IN UNIT OF FM**2
11229         GAM=W1535(DM)
11230        GAM0=0.15
11231         F1=0.25*GAM0**2/(0.25*GAM**2+(DM-1.535)**2)
11232         IF(LA.EQ.1)THEN
11233        XMAX=11.3
11234         ELSE
11235        XMAX=74.
11236         ENDIF
11237         XN1535=F1*XMAX/10.
11238         RETURN
11239         END
11240 ***************************8
11241 *FUNCTION FDE(DMASS) GIVES DELTA MASS DISTRIBUTION BY USING OF
11242 *KITAZOE'S FORMULA
11243         REAL FUNCTION FDELTA(DMASS)
11244       SAVE
11245         AMN=0.938869
11246         AVPI=0.13803333
11247         AM0=1.232
11248         FD=0.25*WIDTH(DMASS)**2/((DMASS-1.232)**2
11249      1  +0.25*WIDTH(DMASS)**2)
11250         FDELTA=FD
11251         RETURN
11252         END
11253 * FUNCTION WIDTH(DMASS) GIVES THE DELTA DECAY WIDTH FOR A GIVEN DELTA MASS
11254 * HERE THE FORMULA GIVEN BY KITAZOE IS USED
11255         REAL FUNCTION WIDTH(DMASS)
11256       SAVE
11257         AVMASS=0.938868
11258         PIMASS=0.137265
11259            AUX = 0.25*(DMASS**2-AVMASS**2-PIMASS**2)**2
11260      &           -(AVMASS*PIMASS)**2
11261             IF (AUX .GT. 0.) THEN
11262               QAVAIL = SQRT(AUX / DMASS**2)
11263             ELSE
11264               QAVAIL = 1.E-06
11265             END IF
11266             WIDTH = 0.47 * QAVAIL**3 /
11267      &              (PIMASS**2 * (1.+0.6*(QAVAIL/PIMASS)**2))
11268 c       width=0.115
11269         RETURN
11270         END
11271 ************************************
11272         SUBROUTINE ddp2(SRT,ISEED,PX,PY,PZ,DM1,PNX,
11273      &  PNY,PNZ,DM2,PPX,PPY,PPZ,icou1)
11274 * PURPOSE : CALCULATE MOMENTUM OF PARTICLES IN THE FINAL SATAT FROM
11275 * THE PROCESS N+N--->D1+D2+PION
11276 *       DATE : July 25, 1994
11277 * Generate the masses and momentum for particles in the NN-->DDpi process
11278 * for a given center of mass energy srt, the momenta are given in the center
11279 * of mass of the NN
11280 *****************************************
11281         COMMON/TABLE/ xarray(0:1000),earray(0:1000)
11282 cc      SAVE /TABLE/
11283       COMMON/RNDF77/NSEED
11284 cc      SAVE /RNDF77/
11285       SAVE
11286        icou1=0
11287        pi=3.1415926
11288         AMN=938.925/1000.
11289         AMP=137.265/1000.
11290 * (1) GENGRATE THE MASS OF DELTA1 AND DELTA2 USING
11291        srt1=srt-amp-0.02
11292        ntrym=0
11293 8       call Rmasdd(srt1,1.232,1.232,1.08,
11294      &  1.08,ISEED,1,dm1,dm2)
11295        ntrym=ntrym+1
11296 * CONSTANTS FOR GENERATING THE LONGITUDINAL MOMENTUM
11297 * FOR ONE OF THE RESONANCES
11298        V=0.43
11299        W=-0.84
11300 * (2) Generate the transverse momentum
11301 *     OF DELTA1
11302 * (2.1) estimate the maximum transverse momentum
11303        PTMAX2=(SRT**2-(DM1+DM2+AMP)**2)*
11304      1  (SRT**2-(DM1-AMP-DM2)**2)/4./SRT**2
11305        if(ptmax2.le.0)go to 8
11306        PTMAX=SQRT(PTMAX2)*1./3.
11307 7       PT=PTR(PTMAX,ISEED)
11308 * (3.1) THE MAXIMUM LONGITUDINAL MOMENTUM IS
11309        PZMAX2=(SRT**2-(DM1+DM2+AMP)**2)*
11310      1  (SRT**2-(DM1-AMP-DM2)**2)/4./SRT**2-PT**2
11311        IF((PZMAX2.LT.0.).and.ntrym.le.100)then
11312        go to 7
11313        else
11314        pzmax2=1.E-09
11315        endif
11316        PZMAX=SQRT(PZMAX2)
11317        XMAX=2.*PZMAX/SRT
11318 * (3.2) THE GENERATED X IS
11319 * THE DSTRIBUTION HAS A MAXIMUM AT X0=-V/(2*w), f(X0)=1.056
11320        ntryx=0
11321        fmax00=1.056
11322        x00=0.26
11323        if(abs(xmax).gt.0.26)then
11324        f00=fmax00
11325        else
11326        f00=1.+v*abs(xmax)+w*xmax**2
11327        endif
11328 9       X=XMAX*(1.-2.*RANART(NSEED))
11329        ntryx=ntryx+1
11330        xratio=(1.+V*ABS(X)+W*X**2)/f00
11331 clin-8/17/00       IF(xratio.LT.RANART(NSEED).and.ntryx.le.50)GO TO 9
11332        IF(xratio.LT.RANART(NSEED).and.ntryx.le.50)GO TO 9
11333 * (3.5) THE PZ IS
11334        PZ=0.5*SRT*X
11335 * The x and y components of the deltA1
11336        fai=2.*pi*RANART(NSEED)
11337        Px=pt*cos(fai)
11338        Py=pt*sin(fai)
11339 * find the momentum of delta2 and pion
11340 * the energy of the delta1
11341        ek=sqrt(dm1**2+PT**2+Pz**2)
11342 * (1) Generate the momentum of the delta2 in the cms of delta2 and pion
11343 *     the energy of the cms of DP
11344         eln=srt-ek
11345        IF(ELN.lE.0)then
11346        icou1=-1
11347        return
11348        endif
11349 * beta and gamma of the cms of delta2+pion
11350        bx=-Px/eln
11351        by=-Py/eln
11352        bz=-Pz/eln
11353        ga=1./sqrt(1.-bx**2-by**2-bz**2)
11354 * the momentum of delta2 and pion in their cms frame
11355        elnc=eln/ga
11356        pn2=((elnc**2+dm2**2-amp**2)/(2.*elnc))**2-dm2**2
11357        if(pn2.le.0)then
11358        icou1=-1
11359        return
11360        endif
11361        pn=sqrt(pn2)
11362
11363 clin-10/25/02 get rid of argument usage mismatch in PTR():
11364         xptr=0.33*PN
11365 c       PNT=PTR(0.33*PN,ISEED)
11366        PNT=PTR(xptr,ISEED)
11367 clin-10/25/02-end
11368
11369        fain=2.*pi*RANART(NSEED)
11370        pnx=pnT*cos(fain)
11371        pny=pnT*sin(fain)
11372        SIG=1
11373        IF(X.GT.0)SIG=-1
11374        pnz=SIG*SQRT(pn**2-PNT**2)
11375        en=sqrt(dm2**2+pnx**2+pny**2+pnz**2)
11376 * (2) the momentum for the pion
11377        ppx=-pnx
11378        ppy=-pny
11379        ppz=-pnz
11380        ep=sqrt(amp**2+ppx**2+ppy**2+ppz**2)
11381 * (3) for the delta2, LORENTZ-TRANSFORMATION INTO nn cms FRAME
11382         PBETA  = PnX*BX + PnY*By+ PnZ*Bz
11383               TRANS0  = GA * ( GA * PBETA / (GA + 1.) + En )
11384               Pnx = BX * TRANS0 + PnX
11385               Pny = BY * TRANS0 + PnY
11386               Pnz = BZ * TRANS0 + PnZ
11387 * (4) for the pion, LORENTZ-TRANSFORMATION INTO nn cms FRAME
11388              if(ep.eq.0.)ep=1.E-09
11389               PBETA  = PPX*BX + PPY*By+ PPZ*Bz
11390               TRANS0  = GA * ( GA * PBETA / (GA + 1.) + EP )
11391               PPx = BX * TRANS0 + PPX
11392               PPy = BY * TRANS0 + PPY
11393               PPz = BZ * TRANS0 + PPZ
11394        return
11395        end
11396 ****************************************
11397         SUBROUTINE ddrho(SRT,ISEED,PX,PY,PZ,DM1,PNX,
11398      &  PNY,PNZ,DM2,PPX,PPY,PPZ,amp,icou1)
11399 * PURPOSE : CALCULATE MOMENTUM OF PARTICLES IN THE FINAL SATAT FROM
11400 * THE PROCESS N+N--->D1+D2+rho
11401 *       DATE : Nov.5, 1994
11402 * Generate the masses and momentum for particles in the NN-->DDrho process
11403 * for a given center of mass energy srt, the momenta are given in the center
11404 * of mass of the NN
11405 *****************************************
11406         COMMON/TABLE/ xarray(0:1000),earray(0:1000)
11407 cc      SAVE /TABLE/
11408       COMMON/RNDF77/NSEED
11409 cc      SAVE /RNDF77/
11410       SAVE
11411        icou1=0
11412        pi=3.1415926
11413         AMN=938.925/1000.
11414         AMP=770./1000.
11415 * (1) GENGRATE THE MASS OF DELTA1 AND DELTA2 USING
11416        srt1=srt-amp-0.02
11417        ntrym=0
11418 8       call Rmasdd(srt1,1.232,1.232,1.08,
11419      &  1.08,ISEED,1,dm1,dm2)
11420        ntrym=ntrym+1
11421 * GENERATE THE MASS FOR THE RHO
11422        RHOMAX = SRT-DM1-DM2-0.02
11423        IF(RHOMAX.LE.0.and.ntrym.le.20)go to 8
11424        AMP=RHOMAS(RHOMAX,ISEED)
11425 * CONSTANTS FOR GENERATING THE LONGITUDINAL MOMENTUM
11426 * FOR ONE OF THE RESONANCES
11427        V=0.43
11428        W=-0.84
11429 * (2) Generate the transverse momentum
11430 *     OF DELTA1
11431 * (2.1) estimate the maximum transverse momentum
11432        PTMAX2=(SRT**2-(DM1+DM2+AMP)**2)*
11433      1  (SRT**2-(DM1-AMP-DM2)**2)/4./SRT**2
11434        PTMAX=SQRT(PTMAX2)*1./3.
11435 7       PT=PTR(PTMAX,ISEED)
11436 * (3) GENGRATE THE LONGITUDINAL MOMENTUM FOR DM1
11437 *     USING THE GIVEN DISTRIBUTION
11438 * (3.1) THE MAXIMUM LONGITUDINAL MOMENTUM IS
11439        PZMAX2=(SRT**2-(DM1+DM2+AMP)**2)*
11440      1  (SRT**2-(DM1-AMP-DM2)**2)/4./SRT**2-PT**2
11441        IF((PZMAX2.LT.0.).and.ntrym.le.100)then
11442        go to 7
11443        else
11444        pzmax2=1.E-06
11445        endif
11446        PZMAX=SQRT(PZMAX2)
11447        XMAX=2.*PZMAX/SRT
11448 * (3.2) THE GENERATED X IS
11449 * THE DSTRIBUTION HAS A MAXIMUM AT X0=-V/(2*w), f(X0)=1.056
11450        ntryx=0
11451        fmax00=1.056
11452        x00=0.26
11453        if(abs(xmax).gt.0.26)then
11454        f00=fmax00
11455        else
11456        f00=1.+v*abs(xmax)+w*xmax**2
11457        endif
11458 9       X=XMAX*(1.-2.*RANART(NSEED))
11459        ntryx=ntryx+1
11460        xratio=(1.+V*ABS(X)+W*X**2)/f00
11461 clin-8/17/00       IF(xratio.LT.RANART(NSEED).and.ntryx.le.50)GO TO 9
11462        IF(xratio.LT.RANART(NSEED).and.ntryx.le.50)GO TO 9
11463 * (3.5) THE PZ IS
11464        PZ=0.5*SRT*X
11465 * The x and y components of the delta1
11466        fai=2.*pi*RANART(NSEED)
11467        Px=pt*cos(fai)
11468        Py=pt*sin(fai)
11469 * find the momentum of delta2 and rho
11470 * the energy of the delta1
11471        ek=sqrt(dm1**2+PT**2+Pz**2)
11472 * (1) Generate the momentum of the delta2 in the cms of delta2 and rho
11473 *     the energy of the cms of Drho
11474         eln=srt-ek
11475        IF(ELN.lE.0)then
11476        icou1=-1
11477        return
11478        endif
11479 * beta and gamma of the cms of delta2 and rho
11480        bx=-Px/eln
11481        by=-Py/eln
11482        bz=-Pz/eln
11483        ga=1./sqrt(1.-bx**2-by**2-bz**2)
11484        elnc=eln/ga
11485        pn2=((elnc**2+dm2**2-amp**2)/(2.*elnc))**2-dm2**2
11486        if(pn2.le.0)then
11487        icou1=-1
11488        return
11489        endif
11490        pn=sqrt(pn2)
11491
11492 clin-10/25/02 get rid of argument usage mismatch in PTR():
11493         xptr=0.33*PN
11494 c       PNT=PTR(0.33*PN,ISEED)
11495        PNT=PTR(xptr,ISEED)
11496 clin-10/25/02-end
11497
11498        fain=2.*pi*RANART(NSEED)
11499        pnx=pnT*cos(fain)
11500        pny=pnT*sin(fain)
11501        SIG=1
11502        IF(X.GT.0)SIG=-1
11503        pnz=SIG*SQRT(pn**2-PNT**2)
11504        en=sqrt(dm2**2+pnx**2+pny**2+pnz**2)
11505 * (2) the momentum for the rho
11506        ppx=-pnx
11507        ppy=-pny
11508        ppz=-pnz
11509        ep=sqrt(amp**2+ppx**2+ppy**2+ppz**2)
11510 * (3) for the delta2, LORENTZ-TRANSFORMATION INTO nn cms FRAME
11511         PBETA  = PnX*BX + PnY*By+ PnZ*Bz
11512               TRANS0  = GA * ( GA * PBETA / (GA + 1.) + En )
11513               Pnx = BX * TRANS0 + PnX
11514               Pny = BY * TRANS0 + PnY
11515               Pnz = BZ * TRANS0 + PnZ
11516 * (4) for the rho, LORENTZ-TRANSFORMATION INTO nn cms FRAME
11517              if(ep.eq.0.)ep=1.e-09
11518               PBETA  = PPX*BX + PPY*By+ PPZ*Bz
11519               TRANS0  = GA * ( GA * PBETA / (GA + 1.) + EP )
11520               PPx = BX * TRANS0 + PPX
11521               PPy = BY * TRANS0 + PPY
11522               PPz = BZ * TRANS0 + PPZ
11523        return
11524        end
11525 ****************************************
11526         SUBROUTINE pprho(SRT,ISEED,PX,PY,PZ,DM1,PNX,
11527      &  PNY,PNZ,DM2,PPX,PPY,PPZ,amp,icou1)
11528 * PURPOSE : CALCULATE MOMENTUM OF PARTICLES IN THE FINAL SATAT FROM
11529 * THE PROCESS N+N--->N1+N2+rho
11530 *       DATE : Nov.5, 1994
11531 * Generate the masses and momentum for particles in the NN--> process
11532 * for a given center of mass energy srt, the momenta are given in the center
11533 * of mass of the NN
11534 *****************************************
11535         COMMON/TABLE/ xarray(0:1000),earray(0:1000)
11536 cc      SAVE /TABLE/
11537       COMMON/RNDF77/NSEED
11538 cc      SAVE /RNDF77/
11539       SAVE
11540         ntrym=0
11541        icou1=0
11542        pi=3.1415926
11543         AMN=938.925/1000.
11544 *        AMP=770./1000.
11545        DM1=amn
11546        DM2=amn
11547 * GENERATE THE MASS FOR THE RHO
11548        RHOMAX=SRT-DM1-DM2-0.02
11549        IF(RHOMAX.LE.0)THEN
11550        ICOU=-1
11551        RETURN
11552        ENDIF
11553        AMP=RHOMAS(RHOMAX,ISEED)
11554 * CONSTANTS FOR GENERATING THE LONGITUDINAL MOMENTUM
11555 * FOR ONE OF THE nucleons
11556        V=0.43
11557        W=-0.84
11558 * (2) Generate the transverse momentum
11559 *     OF p1
11560 * (2.1) estimate the maximum transverse momentum
11561        PTMAX2=(SRT**2-(DM1+DM2+AMP)**2)*
11562      1  (SRT**2-(DM1-AMP-DM2)**2)/4./SRT**2
11563        PTMAX=SQRT(PTMAX2)*1./3.
11564 7       PT=PTR(PTMAX,ISEED)
11565 * (3) GENGRATE THE LONGITUDINAL MOMENTUM FOR DM1
11566 *     USING THE GIVEN DISTRIBUTION
11567 * (3.1) THE MAXIMUM LONGITUDINAL MOMENTUM IS
11568        PZMAX2=(SRT**2-(DM1+DM2+AMP)**2)*
11569      1  (SRT**2-(DM1-AMP-DM2)**2)/4./SRT**2-PT**2
11570        NTRYM=NTRYM+1
11571        IF((PZMAX2.LT.0.).and.ntrym.le.100)then
11572        go to 7
11573        else
11574        pzmax2=1.E-06
11575        endif
11576        PZMAX=SQRT(PZMAX2)
11577        XMAX=2.*PZMAX/SRT
11578 * (3.2) THE GENERATED X IS
11579 * THE DSTRIBUTION HAS A MAXIMUM AT X0=-V/(2*w), f(X0)=1.056
11580        ntryx=0
11581        fmax00=1.056
11582        x00=0.26
11583        if(abs(xmax).gt.0.26)then
11584        f00=fmax00
11585        else
11586        f00=1.+v*abs(xmax)+w*xmax**2
11587        endif
11588 9       X=XMAX*(1.-2.*RANART(NSEED))
11589        ntryx=ntryx+1
11590        xratio=(1.+V*ABS(X)+W*X**2)/f00
11591 clin-8/17/00       IF(xratio.LT.RANART(NSEED).and.ntryx.le.50)GO TO 9
11592        IF(xratio.LT.RANART(NSEED).and.ntryx.le.50)GO TO 9
11593 * (3.5) THE PZ IS
11594        PZ=0.5*SRT*X
11595 * The x and y components of the delta1
11596        fai=2.*pi*RANART(NSEED)
11597        Px=pt*cos(fai)
11598        Py=pt*sin(fai)
11599 * find the momentum of delta2 and rho
11600 * the energy of the delta1
11601        ek=sqrt(dm1**2+PT**2+Pz**2)
11602 * (1) Generate the momentum of the delta2 in the cms of delta2 and rho
11603 *     the energy of the cms of Drho
11604         eln=srt-ek
11605        IF(ELN.lE.0)then
11606        icou1=-1
11607        return
11608        endif
11609 * beta and gamma of the cms of the two partciles
11610        bx=-Px/eln
11611        by=-Py/eln
11612        bz=-Pz/eln
11613        ga=1./sqrt(1.-bx**2-by**2-bz**2)
11614         elnc=eln/ga
11615        pn2=((elnc**2+dm2**2-amp**2)/(2.*elnc))**2-dm2**2
11616        if(pn2.le.0)then
11617        icou1=-1
11618        return
11619        endif
11620        pn=sqrt(pn2)
11621
11622 clin-10/25/02 get rid of argument usage mismatch in PTR():
11623         xptr=0.33*PN
11624 c       PNT=PTR(0.33*PN,ISEED)
11625        PNT=PTR(xptr,ISEED)
11626 clin-10/25/02-end
11627
11628        fain=2.*pi*RANART(NSEED)
11629        pnx=pnT*cos(fain)
11630        pny=pnT*sin(fain)
11631        SIG=1
11632        IF(X.GT.0)SIG=-1
11633        pnz=SIG*SQRT(pn**2-PNT**2)
11634        en=sqrt(dm2**2+pnx**2+pny**2+pnz**2)
11635 * (2) the momentum for the rho
11636        ppx=-pnx
11637        ppy=-pny
11638        ppz=-pnz
11639        ep=sqrt(amp**2+ppx**2+ppy**2+ppz**2)
11640 * (3) for the delta2, LORENTZ-TRANSFORMATION INTO nn cms FRAME
11641         PBETA  = PnX*BX + PnY*By+ PnZ*Bz
11642               TRANS0  = GA * ( GA * PBETA / (GA + 1.) + En )
11643               Pnx = BX * TRANS0 + PnX
11644               Pny = BY * TRANS0 + PnY
11645               Pnz = BZ * TRANS0 + PnZ
11646 * (4) for the rho, LORENTZ-TRANSFORMATION INTO nn cms FRAME
11647              if(ep.eq.0.)ep=1.e-09
11648               PBETA  = PPX*BX + PPY*By+ PPZ*Bz
11649               TRANS0  = GA * ( GA * PBETA / (GA + 1.) + EP )
11650               PPx = BX * TRANS0 + PPX
11651               PPy = BY * TRANS0 + PPY
11652               PPz = BZ * TRANS0 + PPZ
11653        return
11654        end
11655 ***************************8
11656 ****************************************
11657         SUBROUTINE ppomga(SRT,ISEED,PX,PY,PZ,DM1,PNX,
11658      &  PNY,PNZ,DM2,PPX,PPY,PPZ,icou1)
11659 * PURPOSE : CALCULATE MOMENTUM OF PARTICLES IN THE FINAL SATAT FROM
11660 * THE PROCESS N+N--->N1+N2+OMEGA
11661 *       DATE : Nov.5, 1994
11662 * Generate the masses and momentum for particles in the NN--> process
11663 * for a given center of mass energy srt, the momenta are given in the center
11664 * of mass of the NN
11665 *****************************************
11666         COMMON/TABLE/ xarray(0:1000),earray(0:1000)
11667 cc      SAVE /TABLE/
11668       COMMON/RNDF77/NSEED
11669 cc      SAVE /RNDF77/
11670       SAVE
11671         ntrym=0
11672        icou1=0
11673        pi=3.1415926
11674         AMN=938.925/1000.
11675         AMP=782./1000.
11676        DM1=amn
11677        DM2=amn
11678 * CONSTANTS FOR GENERATING THE LONGITUDINAL MOMENTUM
11679 * FOR ONE OF THE nucleons
11680        V=0.43
11681        W=-0.84
11682 * (2) Generate the transverse momentum
11683 *     OF p1
11684 * (2.1) estimate the maximum transverse momentum
11685        PTMAX2=(SRT**2-(DM1+DM2+AMP)**2)*
11686      1  (SRT**2-(DM1-AMP-DM2)**2)/4./SRT**2
11687        PTMAX=SQRT(PTMAX2)*1./3.
11688 7       PT=PTR(PTMAX,ISEED)
11689 * (3) GENGRATE THE LONGITUDINAL MOMENTUM FOR DM1
11690 *     USING THE GIVEN DISTRIBUTION
11691 * (3.1) THE MAXIMUM LONGITUDINAL MOMENTUM IS
11692        PZMAX2=(SRT**2-(DM1+DM2+AMP)**2)*
11693      1  (SRT**2-(DM1-AMP-DM2)**2)/4./SRT**2-PT**2
11694        NTRYM=NTRYM+1
11695        IF((PZMAX2.LT.0.).and.ntrym.le.100)then
11696        go to 7
11697        else
11698        pzmax2=1.E-09
11699        endif
11700        PZMAX=SQRT(PZMAX2)
11701        XMAX=2.*PZMAX/SRT
11702 * (3.2) THE GENERATED X IS
11703 * THE DSTRIBUTION HAS A MAXIMUM AT X0=-V/(2*w), f(X0)=1.056
11704        ntryx=0
11705        fmax00=1.056
11706        x00=0.26
11707        if(abs(xmax).gt.0.26)then
11708        f00=fmax00
11709        else
11710        f00=1.+v*abs(xmax)+w*xmax**2
11711        endif
11712 9       X=XMAX*(1.-2.*RANART(NSEED))
11713        ntryx=ntryx+1
11714        xratio=(1.+V*ABS(X)+W*X**2)/f00
11715 clin-8/17/00       IF(xratio.LT.RANART(NSEED).and.ntryx.le.50)GO TO 9
11716        IF(xratio.LT.RANART(NSEED).and.ntryx.le.50)GO TO 9
11717 * (3.5) THE PZ IS
11718        PZ=0.5*SRT*X
11719 * The x and y components of the delta1
11720        fai=2.*pi*RANART(NSEED)
11721        Px=pt*cos(fai)
11722        Py=pt*sin(fai)
11723 * find the momentum of delta2 and rho
11724 * the energy of the delta1
11725        ek=sqrt(dm1**2+PT**2+Pz**2)
11726 * (1) Generate the momentum of the delta2 in the cms of delta2 and rho
11727 *     the energy of the cms of Drho
11728         eln=srt-ek
11729        IF(ELN.lE.0)then
11730        icou1=-1
11731        return
11732        endif
11733        bx=-Px/eln
11734        by=-Py/eln
11735        bz=-Pz/eln
11736        ga=1./sqrt(1.-bx**2-by**2-bz**2)
11737        elnc=eln/ga
11738        pn2=((elnc**2+dm2**2-amp**2)/(2.*elnc))**2-dm2**2
11739        if(pn2.le.0)then
11740        icou1=-1
11741        return
11742        endif
11743        pn=sqrt(pn2)
11744
11745 clin-10/25/02 get rid of argument usage mismatch in PTR():
11746         xptr=0.33*PN
11747 c       PNT=PTR(0.33*PN,ISEED)
11748        PNT=PTR(xptr,ISEED)
11749 clin-10/25/02-end
11750
11751        fain=2.*pi*RANART(NSEED)
11752        pnx=pnT*cos(fain)
11753        pny=pnT*sin(fain)
11754        SIG=1
11755        IF(X.GT.0)SIG=-1
11756        pnz=SIG*SQRT(pn**2-PNT**2)
11757        en=sqrt(dm2**2+pnx**2+pny**2+pnz**2)
11758 * (2) the momentum for the rho
11759        ppx=-pnx
11760        ppy=-pny
11761        ppz=-pnz
11762        ep=sqrt(amp**2+ppx**2+ppy**2+ppz**2)
11763 * (3) for the delta2, LORENTZ-TRANSFORMATION INTO nn cms FRAME
11764         PBETA  = PnX*BX + PnY*By+ PnZ*Bz
11765               TRANS0  = GA * ( GA * PBETA / (GA + 1.) + En )
11766               Pnx = BX * TRANS0 + PnX
11767               Pny = BY * TRANS0 + PnY
11768               Pnz = BZ * TRANS0 + PnZ
11769 * (4) for the rho, LORENTZ-TRANSFORMATION INTO nn cms FRAME
11770              if(ep.eq.0.)ep=1.E-09
11771               PBETA  = PPX*BX + PPY*By+ PPZ*Bz
11772               TRANS0  = GA * ( GA * PBETA / (GA + 1.) + EP )
11773               PPx = BX * TRANS0 + PPX
11774               PPy = BY * TRANS0 + PPY
11775               PPz = BZ * TRANS0 + PPZ
11776        return
11777        end
11778 ***************************8
11779 ***************************8
11780 *   DELTA MASS GENERATOR
11781        REAL FUNCTION RMASS(DMAX,ISEED)
11782       COMMON/RNDF77/NSEED
11783 cc      SAVE /RNDF77/
11784       SAVE
11785           ISEED=ISEED
11786 * THE MINIMUM MASS FOR DELTA
11787           DMIN = 1.078
11788 * Delta(1232) production
11789           IF(DMAX.LT.1.232) THEN
11790           FM=FDELTA(DMAX)
11791           ELSE
11792           FM=1.
11793           ENDIF
11794           IF(FM.EQ.0.)FM=1.E-06
11795           NTRY1=0
11796 10        DM = RANART(NSEED) * (DMAX-DMIN) + DMIN
11797           NTRY1=NTRY1+1
11798           IF((RANART(NSEED) .GT. FDELTA(DM)/FM).AND.
11799      1    (NTRY1.LE.10)) GOTO 10
11800 clin-2/26/03 sometimes Delta mass can reach very high values (e.g. 15.GeV),
11801 c     thus violating the thresh of the collision which produces it
11802 c     and leads to large violation of energy conservation.
11803 c     To limit the above, limit the Delta mass below a certain value
11804 c     (here taken as its central value + 2* B-W fullwidth):
11805           if(dm.gt.1.47) goto 10
11806
11807        RMASS=DM
11808        RETURN
11809        END
11810
11811 *------------------------------------------------------------------
11812 * THE Breit Wigner FORMULA
11813         REAL FUNCTION FRHO(DMASS)
11814       SAVE
11815         AM0=0.77
11816        WID=0.153
11817         FD=0.25*wid**2/((DMASS-AM0)**2+0.25*WID**2)
11818         FRHO=FD
11819         RETURN
11820         END
11821 ***************************8
11822 *   RHO MASS GENERATOR
11823        REAL FUNCTION RHOMAS(DMAX,ISEED)
11824       COMMON/RNDF77/NSEED
11825 cc      SAVE /RNDF77/
11826       SAVE
11827           ISEED=ISEED
11828 * THE MINIMUM MASS FOR DELTA
11829           DMIN = 0.28
11830 * RHO(770) production
11831           IF(DMAX.LT.0.77) THEN
11832           FM=FRHO(DMAX)
11833           ELSE
11834           FM=1.
11835           ENDIF
11836           IF(FM.EQ.0.)FM=1.E-06
11837           NTRY1=0
11838 10        DM = RANART(NSEED) * (DMAX-DMIN) + DMIN
11839           NTRY1=NTRY1+1
11840           IF((RANART(NSEED) .GT. FRHO(DM)/FM).AND.
11841      1    (NTRY1.LE.10)) GOTO 10
11842 clin-2/26/03 limit the rho mass below a certain value
11843 c     (here taken as its central value + 2* B-W fullwidth):
11844           if(dm.gt.1.07) goto 10
11845
11846        RHOMAS=DM
11847        RETURN
11848        END
11849 ******************************************
11850 * for pp-->pp+2pi
11851 c      real*4 function X2pi(srt)
11852       real function X2pi(srt)
11853 *  This function contains the experimental
11854 c     total pp-pp+pi(+)pi(-) Xsections    *
11855 *  srt    = DSQRT(s) in GeV                                                  *
11856 *  xsec   = production cross section in mb                                   *
11857 *  earray = EXPerimental table with proton momentum in GeV/c                 *
11858 *  xarray = EXPerimental table with cross sections in mb (curve to guide eye)*
11859 *                                                                            *
11860 ******************************************
11861 c      real*4   xarray(15), earray(15)
11862       real   xarray(15), earray(15)
11863       SAVE
11864       data earray /2.23,2.81,3.67,4.0,4.95,5.52,5.97,6.04,
11865      &6.6,6.9,7.87,8.11,10.01,16.0,19./
11866       data xarray /1.22,2.51,2.67,2.95,2.96,2.84,2.8,3.2,
11867      &2.7,3.0,2.54,2.46,2.4,1.66,1.5/
11868
11869            pmass=0.9383
11870 * 1.Calculate p(lab)  from srt [GeV]
11871 *   Formula used:   DSQRT(s) = 2 m DSQRT(E_kin/(2m) + 1)
11872 c      ekin = 2.*pmass*((srt/(2.*pmass))**2 - 1.)
11873        x2pi=0.000001
11874        if(srt.le.2.2)return
11875       plab=sqrt(((srt**2-2.*pmass**2)/(2.*pmass))**2-pmass**2)
11876       if (plab .lt. earray(1)) then
11877         x2pi = xarray(1)
11878         return
11879       end if
11880 *
11881 * 2.Interpolate double logarithmically to find sigma(srt)
11882 *
11883       do 1001 ie = 1,15
11884         if (earray(ie) .eq. plab) then
11885           x2pi= xarray(ie)
11886           return
11887         else if (earray(ie) .gt. plab) then
11888           ymin = alog(xarray(ie-1))
11889           ymax = alog(xarray(ie))
11890           xmin = alog(earray(ie-1))
11891           xmax = alog(earray(ie))
11892           X2pi = exp(ymin + (alog(plab)-xmin)*(ymax-ymin)
11893      &    /(xmax-xmin) )
11894           return
11895         end if
11896  1001 continue
11897       return
11898         END
11899 ******************************************
11900 * for pp-->pn+pi(+)pi(+)pi(-)
11901 c      real*4 function X3pi(srt)
11902       real function X3pi(srt)
11903 *  This function contains the experimental pp->pp+3pi cross sections          *
11904 *  srt    = DSQRT(s) in GeV                                                   *
11905 *  xsec   = production cross section in mb                                    *
11906 *  earray = EXPerimental table with proton energies in MeV                    *
11907 *  xarray = EXPerimental table with cross sections in mb (curve to guide eye) *
11908 *                                                                             *
11909 ******************************************
11910 c      real*4   xarray(12), earray(12)
11911       real   xarray(12), earray(12)
11912       SAVE
11913       data xarray /0.02,0.4,1.15,1.60,2.19,2.85,2.30,
11914      &3.10,2.47,2.60,2.40,1.70/
11915       data earray /2.23,2.81,3.67,4.00,4.95,5.52,5.97,
11916      &6.04,6.60,6.90,10.01,19./
11917
11918            pmass=0.9383
11919 * 1.Calculate p(lab)  from srt [GeV]
11920 *   Formula used:   DSQRT(s) = 2 m DSQRT(E_kin/(2m) + 1)
11921 c      ekin = 2.*pmass*((srt/(2.*pmass))**2 - 1.)
11922        x3pi=1.E-06
11923        if(srt.le.2.3)return
11924       plab=sqrt(((srt**2-2.*pmass**2)/(2.*pmass))**2-pmass**2)
11925       if (plab .lt. earray(1)) then
11926         x3pi = xarray(1)
11927         return
11928       end if
11929 *
11930 * 2.Interpolate double logarithmically to find sigma(srt)
11931 *
11932       do 1001 ie = 1,12
11933         if (earray(ie) .eq. plab) then
11934           x3pi= xarray(ie)
11935           return
11936         else if (earray(ie) .gt. plab) then
11937           ymin = alog(xarray(ie-1))
11938           ymax = alog(xarray(ie))
11939           xmin = alog(earray(ie-1))
11940           xmax = alog(earray(ie))
11941           X3pi= exp(ymin + (alog(plab)-xmin)*(ymax-ymin)
11942      &                                            /(xmax-xmin) )
11943           return
11944         end if
11945  1001 continue
11946       return
11947         END
11948 ******************************************
11949 ******************************************
11950 * for pp-->pp+pi(+)pi(-)pi(0)
11951 c      real*4 function X33pi(srt)
11952       real function X33pi(srt)
11953 *  This function contains the experimental pp->pp+3pi cross sections          *
11954 *  srt    = DSQRT(s) in GeV                                                   *
11955 *  xsec   = production cross section in mb                                    *
11956 *  earray = EXPerimental table with proton energies in MeV                    *
11957 *  xarray = EXPerimental table with cross sections in mb (curve to guide eye) *
11958 *                                                                             *
11959 ******************************************
11960 c      real*4   xarray(12), earray(12)
11961       real   xarray(12), earray(12)
11962       SAVE
11963       data xarray /0.02,0.22,0.74,1.10,1.76,1.84,2.20,
11964      &2.40,2.15,2.60,2.30,1.70/
11965       data earray /2.23,2.81,3.67,4.00,4.95,5.52,5.97,
11966      &6.04,6.60,6.90,10.01,19./
11967
11968            pmass=0.9383
11969        x33pi=1.E-06
11970        if(srt.le.2.3)return
11971 * 1.Calculate p(lab)  from srt [GeV]
11972 *   Formula used:   DSQRT(s) = 2 m DSQRT(E_kin/(2m) + 1)
11973 c      ekin = 2.*pmass*((srt/(2.*pmass))**2 - 1.)
11974       plab=sqrt(((srt**2-2.*pmass**2)/(2.*pmass))**2-pmass**2)
11975       if (plab .lt. earray(1)) then
11976         x33pi = xarray(1)
11977         return
11978       end if
11979 *
11980 * 2.Interpolate double logarithmically to find sigma(srt)
11981 *
11982       do 1001 ie = 1,12
11983         if (earray(ie) .eq. plab) then
11984           x33pi= xarray(ie)
11985           return
11986         else if (earray(ie) .gt. plab) then
11987           ymin = alog(xarray(ie-1))
11988           ymax = alog(xarray(ie))
11989           xmin = alog(earray(ie-1))
11990           xmax = alog(earray(ie))
11991           x33pi= exp(ymin + (alog(plab)-xmin)*(ymax-ymin)
11992      &    /(xmax-xmin))
11993           return
11994         end if
11995  1001   continue
11996         return
11997         END
11998 ******************************************
11999 c       REAL*4 FUNCTION X4pi(SRT)
12000       REAL FUNCTION X4pi(SRT)
12001       SAVE
12002 *       CROSS SECTION FOR NN-->DD+rho PROCESS
12003 * *****************************
12004        akp=0.498
12005        ak0=0.498
12006        ana=0.94
12007        ada=1.232
12008        al=1.1157
12009        as=1.1197
12010        pmass=0.9383
12011        ES=SRT
12012        IF(ES.LE.4)THEN
12013        X4pi=0.
12014        ELSE
12015 * cross section for two resonance pp-->DD+DN*+N*N*
12016        xpp2pi=4.*x2pi(es)
12017 * cross section for pp-->pp+spi
12018        xpp3pi=3.*(x3pi(es)+x33pi(es))
12019 * cross section for pp-->pD+ and nD++
12020        pps1=sigma(es,1,1,0)+0.5*sigma(es,1,1,1)
12021        pps2=1.5*sigma(es,1,1,1)
12022        ppsngl=pps1+pps2+s1535(es)
12023 * CROSS SECTION FOR KAON PRODUCTION from the four channels
12024 * for NLK channel
12025        xk1=0
12026        xk2=0
12027        xk3=0
12028        xk4=0
12029        t1nlk=ana+al+akp
12030        t2nlk=ana+al-akp
12031        if(es.le.t1nlk)go to 333
12032        pmnlk2=(es**2-t1nlk**2)*(es**2-t2nlk**2)/(4.*es**2)
12033        pmnlk=sqrt(pmnlk2)
12034        xk1=pplpk(es)
12035 * for DLK channel
12036        t1dlk=ada+al+akp
12037        t2dlk=ada+al-akp
12038        if(es.le.t1dlk)go to 333
12039        pmdlk2=(es**2-t1dlk**2)*(es**2-t2dlk**2)/(4.*es**2)
12040        pmdlk=sqrt(pmdlk2)
12041        xk3=pplpk(es)
12042 * for NSK channel
12043        t1nsk=ana+as+akp
12044        t2nsk=ana+as-akp
12045        if(es.le.t1nsk)go to 333
12046        pmnsk2=(es**2-t1nsk**2)*(es**2-t2nsk**2)/(4.*es**2)
12047        pmnsk=sqrt(pmnsk2)
12048        xk2=ppk1(es)+ppk0(es)
12049 * for DSK channel
12050        t1DSk=aDa+aS+akp
12051        t2DSk=aDa+aS-akp
12052        if(es.le.t1dsk)go to 333
12053        pmDSk2=(es**2-t1DSk**2)*(es**2-t2DSk**2)/(4.*es**2)
12054        pmDSk=sqrt(pmDSk2)
12055        xk4=ppk1(es)+ppk0(es)
12056 * THE TOTAL KAON+ AND KAON0 PRODUCTION CROSS SECTION IS THEN
12057 333       XKAON=3.*(xk1+xk2+xk3+xk4)
12058 * cross section for pp-->DD+rho
12059        x4pi=pp1(es)-ppsngl-xpp2pi-xpp3pi-XKAON
12060        if(x4pi.le.0)x4pi=1.E-06
12061        ENDIF
12062        RETURN
12063        END
12064 ******************************************
12065 * for pp-->inelastic
12066 c      real*4 function pp1(srt)
12067       real function pp1(srt)
12068       SAVE
12069 *  srt    = DSQRT(s) in GeV                                                   *
12070 *  xsec   = production cross section in mb                                    *
12071 *  earray = EXPerimental table with proton energies in MeV                    *
12072 *  xarray = EXPerimental table with cross sections in mb (curve to guide eye) *
12073 *                                                                             *
12074 ******************************************
12075            pmass=0.9383
12076        PP1=0.
12077 * 1.Calculate p(lab)  from srt [GeV]
12078 *   Formula used:   DSQRT(s) = 2 m DSQRT(E_kin/(2m) + 1)
12079 c      ekin = 2.*pmass*((srt/(2.*pmass))**2 - 1.)
12080       plab2=((srt**2-2.*pmass**2)/(2.*pmass))**2-pmass**2
12081        IF(PLAB2.LE.0)RETURN
12082       plab=sqrt(PLAB2)
12083        pmin=0.968
12084        pmax=2080
12085       if ((plab .lt. pmin).or.(plab.gt.pmax)) then
12086         pp1 = 0.
12087         return
12088       end if
12089 c* fit parameters
12090        a=30.9
12091        b=-28.9
12092        c=0.192
12093        d=-0.835
12094        an=-2.46
12095         pp1 = a+b*(plab**an)+c*(alog(plab))**2
12096        if(pp1.le.0)pp1=0.0
12097         return
12098         END
12099 ******************************************
12100 * for pp-->elastic
12101 c      real*4 function pp2(srt)
12102       real function pp2(srt)
12103       SAVE
12104 *  srt    = DSQRT(s) in GeV                                                   *
12105 *  xsec   = production cross section in mb                                    *
12106 *  earray = EXPerimental table with proton energies in MeV                    *
12107 *  xarray = EXPerimental table with cross sections in mb (curve to guide eye) *
12108 *                                                                             *
12109 ******************************************
12110            pmass=0.9383
12111 * 1.Calculate p(lab)  from srt [GeV]
12112 *   Formula used:   DSQRT(s) = 2 m DSQRT(E_kin/(2m) + 1)
12113 c      ekin = 2.*pmass*((srt/(2.*pmass))**2 - 1.)
12114       plab=sqrt(((srt**2-2.*pmass**2)/(2.*pmass))**2-pmass**2)
12115        pmin=2.
12116        pmax=2050
12117        if(plab.gt.pmax)then
12118        pp2=8.
12119        return
12120        endif
12121         if(plab .lt. pmin)then
12122         pp2 = 25.
12123         return
12124         end if
12125 c* fit parameters
12126        a=11.2
12127        b=25.5
12128        c=0.151
12129        d=-1.62
12130        an=-1.12
12131         pp2 = a+b*(plab**an)+c*(alog(plab))**2+d*alog(plab)
12132        if(pp2.le.0)pp2=0
12133         return
12134         END
12135
12136 ******************************************
12137 * for pp-->total
12138 c      real*4 function ppt(srt)
12139       real function ppt(srt)
12140       SAVE
12141 *  srt    = DSQRT(s) in GeV                                                   *
12142 *  xsec   = production cross section in mb                                    *
12143 *  earray = EXPerimental table with proton energies in MeV                    *
12144 *  xarray = EXPerimental table with cross sections in mb (curve to guide eye) *
12145 *                                                                             *
12146 ******************************************
12147            pmass=0.9383
12148 * 1.Calculate p(lab)  from srt [GeV]
12149 *   Formula used:   DSQRT(s) = 2 m DSQRT(E_kin/(2m) + 1)
12150 c      ekin = 2.*pmass*((srt/(2.*pmass))**2 - 1.)
12151       plab=sqrt(((srt**2-2.*pmass**2)/(2.*pmass))**2-pmass**2)
12152        pmin=3.
12153        pmax=2100
12154       if ((plab .lt. pmin).or.(plab.gt.pmax)) then
12155         ppt = 55.
12156         return
12157       end if
12158 c* fit parameters
12159        a=45.6
12160        b=219.0
12161        c=0.410
12162        d=-3.41
12163        an=-4.23
12164         ppt = a+b*(plab**an)+c*(alog(plab))**2+d*alog(plab)
12165        if(ppt.le.0)ppt=0.0
12166         return
12167         END
12168
12169 *************************
12170 * cross section for N*(1535) production in PP collisions
12171 * VARIABLES:
12172 * LB1,LB2 ARE THE LABLES OF THE TWO COLLIDING PARTICLES
12173 * SRT IS THE CMS ENERGY
12174 * X1535 IS THE N*(1535) PRODUCTION CROSS SECTION
12175 * NOTE THAT THE N*(1535) PRODUCTION CROSS SECTION IS 2 TIMES THE ETA
12176 * PRODUCTION CROSS SECTION
12177 * DATE: Aug. 1 , 1994
12178 * ********************************
12179        real function s1535(SRT)
12180       SAVE
12181        S0=2.424
12182        s1535=0.
12183        IF(SRT.LE.S0)RETURN
12184        S1535=2.*0.102*(SRT-S0)/(0.058+(SRT-S0)**2)
12185        return
12186        end
12187 ****************************************
12188 * generate a table for pt distribution for
12189        subroutine tablem
12190 * THE PROCESS N+N--->N+N+PION
12191 *       DATE : July 11, 1994
12192 *****************************************
12193         COMMON/TABLE/ xarray(0:1000),earray(0:1000)
12194 cc      SAVE /TABLE/
12195       SAVE
12196        ptmax=2.01
12197        anorm=ptdis(ptmax)
12198        do 10 L=0,200
12199        x=0.01*float(L+1)
12200        rr=ptdis(x)/anorm
12201        earray(l)=rr
12202        xarray(l)=x
12203 10       continue
12204        RETURN
12205        end
12206 *********************************
12207        real function ptdis(x)
12208       SAVE
12209 * NUCLEON TRANSVERSE MOMENTUM DISTRIBUTION AT HIGH ENERGIES
12210 * DATE: Aug. 11, 1994
12211 *********************************
12212        b=3.78
12213        c=0.47
12214        d=3.60
12215 c       b=b*3
12216 c       d=d*3
12217        ptdis=1./(2.*b)*(1.-exp(-b*x**2))-c/d*x*exp(-d*x)
12218      1     -c/D**2*(exp(-d*x)-1.)
12219        return
12220        end
12221 *****************************
12222        subroutine ppxS(lb1,lb2,srt,ppsig,spprho,ipp)
12223 * purpose: this subroutine gives the cross section for pion+pion
12224 *          elastic collision
12225 * variables:
12226 *       input: lb1,lb2 and srt are the labels and srt for I1 and I2
12227 *       output: ppsig: pp xsection
12228 *               ipp: label for the pion+pion channel
12229 *               Ipp=0 NOTHING HAPPEND
12230 *                  1 for Pi(+)+PI(+) DIRECT
12231 *                   2     PI(+)+PI(0) FORMING RHO(+)
12232 *                  3     PI(+)+PI(-) FORMING RHO(0)
12233 *                   4     PI(0)+PI(O) DIRECT
12234 *                  5     PI(0)+PI(-) FORMING RHO(-)
12235 *                  6     PI(-)+PI(-) DIRECT
12236 * reference: G.F. Bertsch, Phys. Rev. D37 (1988) 1202.
12237 * date : Aug 29, 1994
12238 *****************************
12239        parameter (amp=0.14,pi=3.1415926)
12240       SAVE
12241        PPSIG=0.0
12242
12243 cbzdbg10/15/99
12244         spprho=0.0
12245 cbzdbg10/15/99 end
12246
12247        IPP=0
12248        IF(SRT.LE.0.3)RETURN
12249        q=sqrt((srt/2)**2-amp**2)
12250        esigma=5.8*amp
12251        tsigma=2.06*q
12252        erho=0.77
12253        trho=0.095*q*(q/amp/(1.+(q/erho)**2))**2
12254        esi=esigma-srt
12255        if(esi.eq.0)then
12256        d00=pi/2.
12257        go to 10
12258        endif
12259        d00=atan(tsigma/2./esi)
12260 10       erh=erho-srt
12261        if(erh.eq.0.)then
12262        d11=pi/2.
12263        go to 20
12264        endif
12265        d11=atan(trho/2./erh)
12266 20       d20=-0.12*q/amp
12267        s0=8.*pi*sin(d00)**2/q**2
12268        s1=8*pi*3*sin(d11)**2/q**2
12269        s2=8*pi*5*sin(d20)**2/q**2
12270 c    !! GeV^-2 to mb
12271         s0=s0*0.197**2*10.
12272         s1=s1*0.197**2*10.
12273         s2=s2*0.197**2*10.
12274 C       ppXS=s0/9.+s1/3.+s2*0.56
12275 C       if(ppxs.le.0)ppxs=0.00001
12276        spprho=s1/2.
12277 * (1) PI(+)+PI(+)
12278        IF(LB1.EQ.5.AND.LB2.EQ.5)THEN
12279        IPP=1
12280        PPSIG=S2
12281        RETURN
12282        ENDIF
12283 * (2) PI(+)+PI(0)
12284        IF((LB1.EQ.5.AND.LB2.EQ.4).OR.(LB1.EQ.4.AND.LB2.EQ.5))THEN
12285        IPP=2
12286        PPSIG=S2/2.+S1/2.
12287        RETURN
12288        ENDIF
12289 * (3) PI(+)+PI(-)
12290        IF((LB1.EQ.5.AND.LB2.EQ.3).OR.(LB1.EQ.3.AND.LB2.EQ.5))THEN
12291        IPP=3
12292        PPSIG=S2/6.+S1/2.+S0/3.
12293        RETURN
12294        ENDIF
12295 * (4) PI(0)+PI(0)
12296        IF(LB1.EQ.4.AND.LB2.EQ.4)THEN
12297        IPP=4
12298        PPSIG=2*S2/3.+S0/3.
12299        RETURN
12300        ENDIF
12301 * (5) PI(0)+PI(-)
12302        IF((LB1.EQ.4.AND.LB2.EQ.3).OR.(LB1.EQ.3.AND.LB2.EQ.4))THEN
12303        IPP=5
12304        PPSIG=S2/2.+S1/2.
12305        RETURN
12306        ENDIF
12307 * (6) PI(-)+PI(-)
12308        IF(LB1.EQ.3.AND.LB2.EQ.3)THEN
12309        IPP=6
12310        PPSIG=S2
12311        ENDIF
12312        return
12313        end
12314 **********************************
12315 * elementary kaon production cross sections
12316 *  from the CERN data book
12317 *  date: Sept.2, 1994
12318 *  for pp-->pLK+
12319 c      real*4 function pplpk(srt)
12320       real function pplpk(srt)
12321       SAVE
12322 *  srt    = DSQRT(s) in GeV                                                   *
12323 *  xsec   = production cross section in mb                                    *
12324 *  earray = EXPerimental table with proton energies in MeV                    *
12325 *  xarray = EXPerimental table with cross sections in mb (curve to guide eye) *
12326 *                                                                             *
12327 ******************************************
12328            pmass=0.9383
12329 * 1.Calculate p(lab)  from srt [GeV]
12330 *   Formula used:   DSQRT(s) = 2 m DSQRT(E_kin/(2m) + 1)
12331 *   find the center of mass energy corresponding to the given pm as
12332 *   if Lambda+N+K are produced
12333        pplpk=0.
12334         plab=sqrt(((srt**2-2.*pmass**2)/(2.*pmass))**2-pmass**2)
12335        pmin=2.82
12336        pmax=25.0
12337        if(plab.gt.pmax)then
12338        pplpk=0.036
12339        return
12340        endif
12341         if(plab .lt. pmin)then
12342         pplpk = 0.
12343         return
12344         end if
12345 c* fit parameters
12346        a=0.0654
12347        b=-3.16
12348        c=-0.0029
12349        an=-4.14
12350         pplpk = a+b*(plab**an)+c*(alog(plab))**2
12351        if(pplpk.le.0)pplpk=0
12352         return
12353         END
12354
12355 ******************************************
12356 * for pp-->pSigma+K0
12357 c      real*4 function ppk0(srt)
12358       real function ppk0(srt)
12359 *  srt    = DSQRT(s) in GeV                                                   *
12360 *  xsec   = production cross section in mb                                    *
12361 *                                                                             *
12362 ******************************************
12363 c      real*4   xarray(7), earray(7)
12364       real   xarray(7), earray(7)
12365       SAVE
12366       data xarray /0.030,0.025,0.025,0.026,0.02,0.014,0.06/
12367       data earray /3.67,4.95,5.52,6.05,6.92,7.87,10./
12368
12369            pmass=0.9383
12370 * 1.Calculate p(lab)  from srt [GeV]
12371 *   Formula used:   DSQRT(s) = 2 m DSQRT(E_kin/(2m) + 1)
12372 c      ekin = 2.*pmass*((srt/(2.*pmass))**2 - 1.)
12373        ppk0=0
12374        if(srt.le.2.63)return
12375        if(srt.gt.4.54)then
12376        ppk0=0.037
12377        return
12378        endif
12379         plab=sqrt(((srt**2-2.*pmass**2)/(2.*pmass))**2-pmass**2)
12380         if (plab .lt. earray(1)) then
12381         ppk0 = xarray(1)
12382         return
12383       end if
12384 *
12385 * 2.Interpolate double logarithmically to find sigma(srt)
12386 *
12387       do 1001 ie = 1,7
12388         if (earray(ie) .eq. plab) then
12389           ppk0 = xarray(ie)
12390           go to 10
12391         else if (earray(ie) .gt. plab) then
12392           ymin = alog(xarray(ie-1))
12393           ymax = alog(xarray(ie))
12394           xmin = alog(earray(ie-1))
12395           xmax = alog(earray(ie))
12396           ppk0 = exp(ymin + (alog(plab)-xmin)*(ymax-ymin)
12397      &/(xmax-xmin) )
12398           go to 10
12399         end if
12400  1001 continue
12401 10       continue
12402       return
12403         END
12404 ******************************************
12405 * for pp-->pSigma0K+
12406 c      real*4 function ppk1(srt)
12407       real function ppk1(srt)
12408 *  srt    = DSQRT(s) in GeV                                                   *
12409 *  xsec   = production cross section in mb                                    *
12410 *                                                                             *
12411 ******************************************
12412 c      real*4   xarray(7), earray(7)
12413       real   xarray(7), earray(7)
12414       SAVE
12415       data xarray /0.013,0.025,0.016,0.012,0.017,0.029,0.025/
12416       data earray /3.67,4.95,5.52,5.97,6.05,6.92,7.87/
12417
12418            pmass=0.9383
12419 * 1.Calculate p(lab)  from srt [GeV]
12420 *   Formula used:   DSQRT(s) = 2 m DSQRT(E_kin/(2m) + 1)
12421 c      ekin = 2.*pmass*((srt/(2.*pmass))**2 - 1.)
12422        ppk1=0.
12423        if(srt.le.2.63)return
12424        if(srt.gt.4.08)then
12425        ppk1=0.025
12426        return
12427        endif
12428         plab=sqrt(((srt**2-2.*pmass**2)/(2.*pmass))**2-pmass**2)
12429         if (plab .lt. earray(1)) then
12430         ppk1 =xarray(1)
12431         return
12432       end if
12433 *
12434 * 2.Interpolate double logarithmically to find sigma(srt)
12435 *
12436       do 1001 ie = 1,7
12437         if (earray(ie) .eq. plab) then
12438           ppk1 = xarray(ie)
12439           go to 10
12440         else if (earray(ie) .gt. plab) then
12441           ymin = alog(xarray(ie-1))
12442           ymax = alog(xarray(ie))
12443           xmin = alog(earray(ie-1))
12444           xmax = alog(earray(ie))
12445           ppk1 = exp(ymin + (alog(plab)-xmin)*(ymax-ymin)
12446      &/(xmax-xmin) )
12447           go to 10
12448         end if
12449  1001 continue
12450 10       continue
12451       return
12452         END
12453 **********************************
12454 *                                                                      *
12455 *                                                                      *
12456       SUBROUTINE CRPN(PX,PY,PZ,SRT,I1,I2,
12457      & IBLOCK,xkaon0,xkaon,Xphi,xphin)
12458 *     PURPOSE:                                                         *
12459 *           DEALING WITH PION+N-->L/S+KAON PROCESS AND PION PRODUCTION *
12460 *     NOTE   :                                                         *
12461 *
12462 *     QUANTITIES:                                                 *
12463 *           PX,PY,PZ - MOMENTUM COORDINATES OF ONE PARTICLE IN CM FRAME*
12464 *           SRT      - SQRT OF S                                       *
12465 *           IBLOCK   - THE INFORMATION BACK                            *
12466 *                     7  PION+N-->L/S+KAON
12467 *           iblock   - 77 pion+N-->Delta+pion
12468 *           iblock   - 78 pion+N-->Delta+RHO
12469 *           iblock   - 79 pion+N-->Delta+OMEGA
12470 *           iblock   - 222 pion+N-->Phi
12471 **********************************
12472         PARAMETER (MAXSTR=150001,MAXR=1,AMN=0.939457,
12473      1  AMP=0.93828,AP1=0.13496,APHI=1.020,
12474      2  AP2=0.13957,AM0=1.232,PI=3.1415926,CUTOFF=1.8966,AVMASS=0.9383)
12475         PARAMETER      (AKA=0.498,ALA=1.1157,ASA=1.1974)
12476         parameter     (MX=4,MY=4,MZ=8,MPX=4,MPY=4,mpz=10,mpzp=10)
12477         COMMON /AA/ R(3,MAXSTR)
12478 cc      SAVE /AA/
12479         COMMON /BB/ P(3,MAXSTR)
12480 cc      SAVE /BB/
12481         COMMON /CC/ E(MAXSTR)
12482 cc      SAVE /CC/
12483         COMMON /EE/ ID(MAXSTR),LB(MAXSTR)
12484 cc      SAVE /EE/
12485         common/input1/ MASSPR,MASSTA,ISEED,IAVOID,DT
12486 cc      SAVE /input1/
12487       COMMON/RNDF77/NSEED
12488 cc      SAVE /RNDF77/
12489       SAVE
12490
12491       PX0=PX
12492       PY0=PY
12493       PZ0=PZ
12494       iblock=1
12495       x1=RANART(NSEED)
12496       ianti=0
12497       if(lb(i1).lt.0 .or. lb(i2).lt.0) ianti=1
12498       if(xkaon0/(xkaon+Xphi).ge.x1)then
12499 * kaon production
12500 *-----------------------------------------------------------------------
12501         IBLOCK=7
12502         if(ianti .eq. 1)iblock=-7
12503         NTAG=0
12504 * RELABLE PARTICLES FOR THE PROCESS PION+n-->LAMBDA K OR SIGMA k
12505 * DECIDE LAMBDA OR SIGMA PRODUCTION, AND TO CALCULATE THE NEW
12506 * MOMENTA FOR PARTICLES IN THE FINAL STATE.
12507        KAONC=0
12508        IF(PNLKA(SRT)/(PNLKA(SRT)
12509      &       +PNSKA(SRT)).GT.RANART(NSEED))KAONC=1
12510        IF(E(I1).LE.0.2)THEN
12511            LB(I1)=23
12512            E(I1)=AKA
12513            IF(KAONC.EQ.1)THEN
12514               LB(I2)=14
12515               E(I2)=ALA
12516            ELSE
12517               LB(I2) = 15 + int(3 * RANART(NSEED))
12518               E(I2)=ASA
12519            ENDIF
12520            if(ianti .eq. 1)then
12521               lb(i1) = 21
12522               lb(i2) = -lb(i2)
12523            endif
12524        ELSE
12525            LB(I2)=23
12526            E(I2)=AKA
12527            IF(KAONC.EQ.1)THEN
12528               LB(I1)=14
12529               E(I1)=ALA
12530            ELSE
12531               LB(I1) = 15 + int(3 * RANART(NSEED))
12532               E(I1)=ASA
12533            ENDIF
12534            if(ianti .eq. 1)then
12535               lb(i2) = 21
12536               lb(i1) = -lb(i1)
12537            endif
12538        ENDIF
12539         EM1=E(I1)
12540         EM2=E(I2)
12541         go to 50
12542 * to gererate the momentum for the kaon and L/S
12543       elseif(Xphi/(xkaon+Xphi).ge.x1)then
12544           iblock=222
12545          if(xphin/Xphi .ge. RANART(NSEED))then
12546           LB(I1)= 1+int(2*RANART(NSEED))
12547            E(I1)=AMN
12548          else
12549           LB(I1)= 6+int(4*RANART(NSEED))
12550            E(I1)=AM0
12551          endif
12552 c  !! at present only baryon
12553          if(ianti .eq. 1)lb(i1)=-lb(i1)
12554           LB(I2)= 29
12555            E(I2)=APHI
12556         EM1=E(I1)
12557         EM2=E(I2)
12558        go to 50
12559          else
12560 * CHECK WHAT KIND OF PION PRODUCTION PROCESS HAS HAPPENED
12561        IF(RANART(NSEED).LE.TWOPI(SRT)/
12562      &  (TWOPI(SRT)+THREPI(SRT)+FOURPI(SRT)))THEN
12563        iblock=77
12564        ELSE
12565         IF(THREPI(SRT)/(THREPI(SRT)+FOURPI(SRT)).
12566      &  GT.RANART(NSEED))THEN
12567        IBLOCK=78
12568        ELSE
12569        IBLOCK=79
12570        ENDIF
12571        endif
12572        ntag=0
12573 * pion production (Delta+pion/rho/omega in the final state)
12574 * generate the mass of the delta resonance
12575        X2=RANART(NSEED)
12576 * relable the particles
12577        if(iblock.eq.77)then
12578 * GENERATE THE DELTA MASS
12579        dmax=srt-ap1-0.02
12580        dm=rmass(dmax,iseed)
12581 * pion+baryon-->pion+delta
12582 * Relable particles, I1 is assigned to the Delta and I2 is assigned to the
12583 * meson
12584 *(1) for pi(+)+p-->D(+)+P(+) OR D(++)+p(0)
12585        if( ((lb(i1).eq.1.and.lb(i2).eq.5).
12586      &  or.(lb(i1).eq.5.and.lb(i2).eq.1))
12587      &       .OR. ((lb(i1).eq.-1.and.lb(i2).eq.3).
12588      &  or.(lb(i1).eq.3.and.lb(i2).eq.-1)) )then
12589               if(iabs(lb(i1)).eq.1)then
12590         ii = i1
12591        IF(X2.LE.0.5)THEN
12592        lb(i1)=8
12593        e(i1)=dm
12594        lb(i2)=5
12595        e(i2)=ap1
12596        go to 40
12597        ELSE
12598        lb(i1)=9
12599        e(i1)=dm
12600        lb(i2)=4
12601         ipi = 4
12602        e(i2)=ap1
12603        go to 40
12604        endif
12605               else
12606         ii = i2
12607        IF(X2.LE.0.5)THEN
12608        lb(i2)=8
12609        e(i2)=dm
12610        lb(i1)=5
12611        e(i1)=ap1
12612        go to 40
12613        ELSE
12614        lb(i2)=9
12615        e(i2)=dm
12616        lb(i1)=4
12617        e(i1)=ap1
12618        go to 40
12619        endif
12620               endif
12621        endif
12622 *(2) for pi(-)+p-->D(0)+P(0) OR D(+)+p(-),or D(-)+p(+)
12623        if( ((lb(i1).eq.1.and.lb(i2).eq.3).
12624      &  or.(lb(i1).eq.3.and.lb(i2).eq.1))
12625      &        .OR. ((lb(i1).eq.-1.and.lb(i2).eq.5).
12626      &  or.(lb(i1).eq.5.and.lb(i2).eq.-1)) )then
12627               if(iabs(lb(i1)).eq.1)then
12628         ii = i1
12629        IF(X2.LE.0.33)THEN
12630        lb(i1)=6
12631        e(i1)=dm
12632        lb(i2)=5
12633        e(i2)=ap1
12634        go to 40
12635        ENDIF
12636        if(X2.gt.0.33.and.X2.le.0.67)then
12637        lb(i1)=7
12638        e(i1)=dm
12639        lb(i2)=4
12640        e(i2)=ap1
12641        go to 40
12642        endif
12643        if(X2.gt.0.67)then
12644        lb(i1)=8
12645        e(i1)=dm
12646        lb(i2)=3
12647        e(i2)=ap1
12648        go to 40
12649        endif
12650               else
12651         ii = i2
12652        IF(X2.LE.0.33)THEN
12653        lb(i2)=6
12654        e(i2)=dm
12655        lb(i1)=5
12656        e(i1)=ap1
12657        go to 40
12658        ENDIF
12659        if(X2.gt.0.33.and.X2.le.0.67)then
12660        lb(i2)=7
12661        e(i2)=dm
12662        lb(i1)=4
12663        e(i1)=ap1
12664        go to 40
12665        endif
12666        if(X2.gt.0.67)then
12667        lb(i2)=8
12668        e(i2)=dm
12669        lb(i1)=3
12670        e(i1)=ap1
12671        go to 40
12672        endif
12673               endif
12674        endif
12675 *(3) for pi(+)+n-->D(+)+Pi(0) OR D(++)+p(-) or D(0)+pi(+)
12676        if( ((lb(i1).eq.2.and.lb(i2).eq.5).
12677      &   or.(lb(i1).eq.5.and.lb(i2).eq.2))
12678      & .OR. ((lb(i1).eq.-2.and.lb(i2).eq.3).
12679      &   or.(lb(i1).eq.3.and.lb(i2).eq.-2)) )then
12680               if(iabs(lb(i1)).eq.2)then
12681         ii = i1
12682        IF(X2.LE.0.33)THEN
12683        lb(i1)=8
12684        e(i1)=dm
12685        lb(i2)=4
12686        e(i2)=ap1
12687        go to 40
12688        ENDIF
12689        if(X2.gt.0.33.and.X2.le.0.67)then
12690        lb(i1)=7
12691        e(i1)=dm
12692        lb(i2)=5
12693        e(i2)=ap1
12694        go to 40
12695        endif
12696        if(X2.gt.0.67)then
12697        lb(i1)=9
12698        e(i1)=dm
12699        lb(i2)=3
12700        e(i2)=ap1
12701        go to 40
12702        endif
12703               else
12704         ii = i2
12705        IF(X2.LE.0.33)THEN
12706        lb(i2)=8
12707        e(i2)=dm
12708        lb(i1)=4
12709        e(i1)=ap1
12710        go to 40
12711        ENDIF
12712        if(X2.gt.0.33.and.X2.le.0.67)then
12713        lb(i2)=7
12714        e(i2)=dm
12715        lb(i1)=5
12716        e(i1)=ap1
12717        go to 40
12718        endif
12719        if(X2.gt.0.67)then
12720        lb(i2)=9
12721        e(i2)=dm
12722        lb(i1)=3
12723        e(i1)=ap1
12724        go to 40
12725        endif
12726               endif
12727        endif
12728 *(4) for pi(0)+p-->D(+)+Pi(0) OR D(++)+p(-) or D(0)+pi(+)
12729        if((iabs(lb(i1)).eq.1.and.lb(i2).eq.4).
12730      &  or.(lb(i1).eq.4.and.iabs(lb(i2)).eq.1))then
12731               if(iabs(lb(i1)).eq.1)then
12732         ii = i1
12733        IF(X2.LE.0.33)THEN
12734        lb(i1)=8
12735        e(i1)=dm
12736        lb(i2)=4
12737        e(i2)=ap1
12738        go to 40
12739        ENDIF
12740        if(X2.gt.0.33.and.X2.le.0.67)then
12741        lb(i1)=7
12742        e(i1)=dm
12743        lb(i2)=5
12744        e(i2)=ap1
12745        go to 40
12746        endif
12747        if(X2.gt.0.67)then
12748        lb(i1)=9
12749        e(i1)=dm
12750        lb(i2)=3
12751        e(i2)=ap1
12752        go to 40
12753        endif
12754               else
12755         ii = i2
12756        IF(X2.LE.0.33)THEN
12757        lb(i2)=8
12758        e(i2)=dm
12759        lb(i1)=4
12760        e(i1)=ap1
12761        go to 40
12762        ENDIF
12763        if(X2.gt.0.33.and.X2.le.0.67)then
12764        lb(i2)=7
12765        e(i2)=dm
12766        lb(i1)=5
12767        e(i1)=ap1
12768        go to 40
12769        endif
12770        if(X2.gt.0.67)then
12771        lb(i2)=9
12772        e(i2)=dm
12773        lb(i1)=3
12774        e(i1)=ap1
12775        go to 40
12776        endif
12777               endif
12778        endif
12779 *(5) for pi(-)+n-->D(-)+P(0) OR D(0)+p(-)
12780        if( ((lb(i1).eq.2.and.lb(i2).eq.3).
12781      &  or.(lb(i1).eq.3.and.lb(i2).eq.2))
12782      &         .OR. ((lb(i1).eq.-2.and.lb(i2).eq.5).
12783      &  or.(lb(i1).eq.5.and.lb(i2).eq.-2)) )then
12784               if(iabs(lb(i1)).eq.2)then
12785         ii = i1
12786        IF(X2.LE.0.5)THEN
12787        lb(i1)=6
12788        e(i1)=dm
12789        lb(i2)=4
12790        e(i2)=ap1
12791        go to 40
12792        ELSE
12793        lb(i1)=7
12794        e(i1)=dm
12795        lb(i2)=3
12796        e(i2)=ap1
12797        go to 40
12798        endif
12799               else
12800         ii = i2
12801        IF(X2.LE.0.5)THEN
12802        lb(i2)=6
12803        e(i2)=dm
12804        lb(i1)=4
12805        e(i1)=ap1
12806        go to 40
12807        ELSE
12808        lb(i2)=7
12809        e(i2)=dm
12810        lb(i1)=3
12811        e(i1)=ap1
12812        go to 40
12813        endif
12814               endif
12815        ENDIF
12816 *(6) for pi(0)+n-->D(0)+P(0), D(-)+p(+) or D(+)+p(-)
12817        if((iabs(lb(i1)).eq.2.and.lb(i2).eq.4).
12818      &  or.(lb(i1).eq.4.and.iabs(lb(i2)).eq.2))then
12819               if(iabs(lb(i1)).eq.2)then
12820         ii = i1
12821        IF(X2.LE.0.33)THEN
12822        lb(i1)=7
12823        e(i1)=dm
12824        lb(i2)=4
12825        e(i2)=ap1
12826        go to 40
12827        Endif
12828        IF(X2.LE.0.67.AND.X2.GT.0.33)THEN
12829        lb(i1)=6
12830        e(i1)=dm
12831        lb(i2)=5
12832        e(i2)=ap1
12833        go to 40
12834        endif
12835        IF(X2.GT.0.67)THEN
12836        LB(I1)=8
12837        E(I1)=DM
12838        LB(I2)=3
12839        E(I2)=AP1
12840        GO TO 40
12841        ENDIF
12842               else
12843         ii = i2
12844        IF(X2.LE.0.33)THEN
12845        lb(i2)=7
12846        e(i2)=dm
12847        lb(i1)=4
12848        e(i1)=ap1
12849        go to 40
12850        ENDIF
12851        IF(X2.LE.0.67.AND.X2.GT.0.33)THEN
12852        lb(i2)=6
12853        e(i2)=dm
12854        lb(i1)=5
12855        e(i1)=ap1
12856        go to 40
12857        endif
12858        IF(X2.GT.0.67)THEN
12859        LB(I2)=8
12860        E(I2)=DM
12861        LB(I1)=3
12862        E(I1)=AP1
12863        GO TO 40
12864        ENDIF
12865               endif
12866        endif
12867                      ENDIF
12868        if(iblock.eq.78)then
12869        call Rmasdd(srt,1.232,0.77,1.08,
12870      &  0.28,ISEED,4,dm,ameson)
12871        arho=AMESON
12872 * pion+baryon-->Rho+delta
12873 *(1) for pi(+)+p-->D(+)+rho(+) OR D(++)+rho(0)
12874        if( ((lb(i1).eq.1.and.lb(i2).eq.5).
12875      &  or.(lb(i1).eq.5.and.lb(i2).eq.1))
12876      &        .OR. ((lb(i1).eq.-1.and.lb(i2).eq.3).
12877      &  or.(lb(i1).eq.3.and.lb(i2).eq.-1)) )then
12878               if(iabs(lb(i1)).eq.1)then
12879         ii = i1
12880        IF(X2.LE.0.5)THEN
12881        lb(i1)=8
12882        e(i1)=dm
12883        lb(i2)=27
12884        e(i2)=arho
12885        go to 40
12886        ELSE
12887        lb(i1)=9
12888        e(i1)=dm
12889        lb(i2)=26
12890        e(i2)=arho
12891        go to 40
12892        endif
12893               else
12894         ii = i2
12895        IF(X2.LE.0.5)THEN
12896        lb(i2)=8
12897        e(i2)=dm
12898        lb(i1)=27
12899        e(i1)=arho
12900        go to 40
12901        ELSE
12902        lb(i2)=9
12903        e(i2)=dm
12904        lb(i1)=26
12905        e(i1)=arho
12906        go to 40
12907        endif
12908               endif
12909        endif
12910 *(2) for pi(-)+p-->D(+)+rho(-) OR D(0)+rho(0) or D(-)+rho(+)
12911        if( ((lb(i1).eq.1.and.lb(i2).eq.3).
12912      &  or.(lb(i1).eq.3.and.lb(i2).eq.1))
12913      &        .OR. ((lb(i1).eq.-1.and.lb(i2).eq.5).
12914      &  or.(lb(i1).eq.5.and.lb(i2).eq.-1)) )then
12915               if(iabs(lb(i1)).eq.1)then
12916         ii = i1
12917        IF(X2.LE.0.33)THEN
12918        lb(i1)=6
12919        e(i1)=dm
12920        lb(i2)=27
12921        e(i2)=arho
12922        go to 40
12923        ENDIF
12924        if(X2.gt.0.33.and.X2.le.0.67)then
12925        lb(i1)=7
12926        e(i1)=dm
12927        lb(i2)=26
12928        e(i2)=arho
12929        go to 40
12930        endif
12931        if(X2.gt.0.67)then
12932        lb(i1)=8
12933        e(i1)=dm
12934        lb(i2)=25
12935        e(i2)=arho
12936        go to 40
12937        endif
12938               else
12939         ii = i2
12940        IF(X2.LE.0.33)THEN
12941        lb(i2)=6
12942        e(i2)=dm
12943        lb(i1)=27
12944        e(i1)=arho
12945        go to 40
12946        ENDIF
12947        if(X2.gt.0.33.and.X2.le.0.67)then
12948        lb(i2)=7
12949        e(i2)=dm
12950        lb(i1)=26
12951        e(i1)=arho
12952        go to 40
12953        endif
12954        if(X2.gt.0.67)then
12955        lb(i2)=8
12956        e(i2)=dm
12957        lb(i1)=25
12958        e(i1)=arho
12959        go to 40
12960        endif
12961               endif
12962        endif
12963 *(3) for pi(+)+n-->D(+)+rho(0) OR D(++)+rho(-) or D(0)+rho(+)
12964        if( ((lb(i1).eq.2.and.lb(i2).eq.5).
12965      &  or.(lb(i1).eq.5.and.lb(i2).eq.2))
12966      &       .OR.((lb(i1).eq.-2.and.lb(i2).eq.3).
12967      &  or.(lb(i1).eq.3.and.lb(i2).eq.-2)) )then
12968               if(iabs(lb(i1)).eq.2)then
12969         ii = i1
12970        IF(X2.LE.0.33)THEN
12971        lb(i1)=8
12972        e(i1)=dm
12973        lb(i2)=26
12974        e(i2)=arho
12975        go to 40
12976        ENDIF
12977        if(X2.gt.0.33.and.X2.le.0.67)then
12978        lb(i1)=7
12979        e(i1)=dm
12980        lb(i2)=27
12981        e(i2)=arho
12982        go to 40
12983        endif
12984        if(X2.gt.0.67)then
12985        lb(i1)=9
12986        e(i1)=dm
12987        lb(i2)=25
12988        e(i2)=arho
12989        go to 40
12990        endif
12991               else
12992         ii = i2
12993        IF(X2.LE.0.33)THEN
12994        lb(i2)=8
12995        e(i2)=dm
12996        lb(i1)=26
12997        e(i1)=arho
12998        go to 40
12999        ENDIF
13000        if(X2.gt.0.33.and.X2.le.0.67)then
13001        lb(i2)=7
13002        e(i2)=dm
13003        lb(i1)=27
13004        e(i1)=arho
13005        go to 40
13006        endif
13007        if(X2.gt.0.67)then
13008        lb(i2)=9
13009        e(i2)=dm
13010        lb(i1)=25
13011        e(i1)=arho
13012        go to 40
13013        endif
13014               endif
13015        endif
13016 *(4) for pi(0)+p-->D(+)+rho(0) OR D(++)+rho(-) or D(0)+rho(+)
13017        if((iabs(lb(i1)).eq.1.and.lb(i2).eq.4).
13018      &  or.(lb(i1).eq.4.and.iabs(lb(i2)).eq.1))then
13019               if(iabs(lb(i1)).eq.1)then
13020         ii = i1
13021        IF(X2.LE.0.33)THEN
13022        lb(i1)=7
13023        e(i1)=dm
13024        lb(i2)=27
13025        e(i2)=arho
13026        go to 40
13027        ENDIF
13028        if(X2.gt.0.33.and.X2.le.0.67)then
13029        lb(i1)=8
13030        e(i1)=dm
13031        lb(i2)=26
13032        e(i2)=arho
13033        go to 40
13034        endif
13035        if(X2.gt.0.67)then
13036        lb(i1)=9
13037        e(i1)=dm
13038        lb(i2)=25
13039        e(i2)=arho
13040        go to 40
13041        endif
13042               else
13043         ii = i2
13044        IF(X2.LE.0.33)THEN
13045        lb(i2)=7
13046        e(i2)=dm
13047        lb(i1)=27
13048        e(i1)=arho
13049        go to 40
13050        ENDIF
13051        if(X2.gt.0.33.and.X2.le.0.67)then
13052        lb(i2)=8
13053        e(i2)=dm
13054        lb(i1)=26
13055        e(i1)=arho
13056        go to 40
13057        endif
13058        if(X2.gt.0.67)then
13059        lb(i2)=9
13060        e(i2)=dm
13061        lb(i1)=25
13062        e(i1)=arho
13063        go to 40
13064        endif
13065               endif
13066        endif
13067 *(5) for pi(-)+n-->D(-)+rho(0) OR D(0)+rho(-)
13068        if( ((lb(i1).eq.2.and.lb(i2).eq.3).
13069      &  or.(lb(i1).eq.3.and.lb(i2).eq.2))
13070      &        .OR. ((lb(i1).eq.-2.and.lb(i2).eq.5).
13071      &  or.(lb(i1).eq.5.and.lb(i2).eq.-2)) )then
13072               if(iabs(lb(i1)).eq.2)then
13073         ii = i1
13074        IF(X2.LE.0.5)THEN
13075        lb(i1)=6
13076        e(i1)=dm
13077        lb(i2)=26
13078        e(i2)=arho
13079        go to 40
13080        ELSE
13081        lb(i1)=7
13082        e(i1)=dm
13083        lb(i2)=25
13084        e(i2)=arho
13085        go to 40
13086        endif
13087               else
13088         ii = i2
13089        IF(X2.LE.0.5)THEN
13090        lb(i2)=6
13091        e(i2)=dm
13092        lb(i1)=26
13093        e(i1)=arho
13094        go to 40
13095        ELSE
13096        lb(i2)=7
13097        e(i2)=dm
13098        lb(i1)=25
13099        e(i1)=arho
13100        go to 40
13101        endif
13102               endif
13103        ENDIF
13104 *(6) for pi(0)+n-->D(0)+rho(0), D(-)+rho(+) and D(+)+rho(-)
13105        if((iabs(lb(i1)).eq.2.and.lb(i2).eq.4).
13106      &  or.(lb(i1).eq.4.and.iabs(lb(i2)).eq.2))then
13107               if(iabs(lb(i1)).eq.2)then
13108         ii = i1
13109        IF(X2.LE.0.33)THEN
13110        lb(i1)=7
13111        e(i1)=dm
13112        lb(i2)=26
13113        e(i2)=arho
13114        go to 40
13115        endif
13116        if(x2.gt.0.33.and.x2.le.0.67)then
13117        lb(i1)=6
13118        e(i1)=dm
13119        lb(i2)=27
13120        e(i2)=arho
13121        go to 40
13122        endif
13123        if(x2.gt.0.67)then
13124        lb(i1)=8
13125        e(i1)=dm
13126        lb(i2)=25
13127        e(i2)=arho
13128        endif
13129               else
13130         ii = i2
13131        IF(X2.LE.0.33)THEN
13132        lb(i2)=7
13133        e(i2)=dm
13134        lb(i1)=26
13135        e(i1)=arho
13136        go to 40
13137        endif
13138        if(x2.le.0.67.and.x2.gt.0.33)then
13139        lb(i2)=6
13140        e(i2)=dm
13141        lb(i1)=27
13142        e(i1)=arho
13143        go to 40
13144        endif
13145        if(x2.gt.0.67)then
13146        lb(i2)=8
13147        e(i2)=dm
13148        lb(i1)=25
13149        e(i1)=arho
13150        endif
13151               endif
13152        endif
13153                      Endif
13154        if(iblock.eq.79)then
13155        aomega=0.782
13156 * GENERATE THE DELTA MASS
13157        dmax=srt-0.782-0.02
13158        dm=rmass(dmax,iseed)
13159 * pion+baryon-->omega+delta
13160 *(1) for pi(+)+p-->D(++)+omega(0)
13161        if( ((lb(i1).eq.1.and.lb(i2).eq.5).
13162      &  or.(lb(i1).eq.5.and.lb(i2).eq.1))
13163      &  .OR.((lb(i1).eq.-1.and.lb(i2).eq.3).
13164      &  or.(lb(i1).eq.3.and.lb(i2).eq.-1)) )then
13165               if(iabs(lb(i1)).eq.1)then
13166         ii = i1
13167        lb(i1)=9
13168        e(i1)=dm
13169        lb(i2)=28
13170        e(i2)=aomega
13171        go to 40
13172               else
13173         ii = i2
13174        lb(i2)=9
13175        e(i2)=dm
13176        lb(i1)=28
13177        e(i1)=aomega
13178        go to 40
13179               endif
13180        endif
13181 *(2) for pi(-)+p-->D(0)+omega(0)
13182        if( ((lb(i1).eq.1.and.lb(i2).eq.3).
13183      &  or.(lb(i1).eq.3.and.lb(i2).eq.1))
13184      &        .OR. ((lb(i1).eq.-1.and.lb(i2).eq.5).
13185      &  or.(lb(i1).eq.5.and.lb(i2).eq.-1)) )then
13186               if(iabs(lb(i1)).eq.1)then
13187         ii = i1
13188        lb(i1)=7
13189        e(i1)=dm
13190        lb(i2)=28
13191        e(i2)=aomega
13192        go to 40
13193               else
13194         ii = i2
13195        lb(i2)=7
13196        e(i2)=dm
13197        lb(i1)=28
13198        e(i1)=aomega
13199        go to 40
13200               endif
13201        endif
13202 *(3) for pi(+)+n-->D(+)+omega(0)
13203        if( ((lb(i1).eq.2.and.lb(i2).eq.5).
13204      &  or.(lb(i1).eq.5.and.lb(i2).eq.2))
13205      &       .OR. ((lb(i1).eq.-2.and.lb(i2).eq.3).
13206      &  or.(lb(i1).eq.3.and.lb(i2).eq.-2)) )then
13207               if(iabs(lb(i1)).eq.2)then
13208         ii = i1
13209        lb(i1)=8
13210        e(i1)=dm
13211        lb(i2)=28
13212        e(i2)=aomega
13213        go to 40
13214               else
13215         ii = i2
13216        lb(i2)=8
13217        e(i2)=dm
13218        lb(i1)=28
13219        e(i1)=aomega
13220        go to 40
13221               endif
13222        endif
13223 *(4) for pi(0)+p-->D(+)+omega(0)
13224        if((iabs(lb(i1)).eq.1.and.lb(i2).eq.4).
13225      &  or.(lb(i1).eq.4.and.iabs(lb(i2)).eq.1))then
13226               if(iabs(lb(i1)).eq.1)then
13227         ii = i1
13228        lb(i1)=8
13229        e(i1)=dm
13230        lb(i2)=28
13231        e(i2)=aomega
13232        go to 40
13233               else
13234         ii = i2
13235        lb(i2)=8
13236        e(i2)=dm
13237        lb(i1)=28
13238        e(i1)=aomega
13239        go to 40
13240               endif
13241        endif
13242 *(5) for pi(-)+n-->D(-)+omega(0)
13243        if( ((lb(i1).eq.2.and.lb(i2).eq.3).
13244      &  or.(lb(i1).eq.3.and.lb(i2).eq.2))
13245      &        .OR. ((lb(i1).eq.-2.and.lb(i2).eq.5).
13246      &  or.(lb(i1).eq.5.and.lb(i2).eq.-2)) )then
13247               if(iabs(lb(i1)).eq.2)then
13248         ii = i1
13249        lb(i1)=6
13250        e(i1)=dm
13251        lb(i2)=28
13252        e(i2)=aomega
13253        go to 40
13254               ELSE
13255         ii = i2
13256        lb(i2)=6
13257        e(i2)=dm
13258        lb(i1)=28
13259        e(i1)=aomega
13260               endif
13261        ENDIF
13262 *(6) for pi(0)+n-->D(0)+omega(0)
13263        if((iabs(lb(i1)).eq.2.and.lb(i2).eq.4).
13264      &  or.(lb(i1).eq.4.and.iabs(lb(i2)).eq.2))then
13265               if(iabs(lb(i1)).eq.2)then
13266         ii = i1
13267        lb(i1)=7
13268        e(i1)=dm
13269        lb(i2)=28
13270        e(i2)=aomega
13271        go to 40
13272               else
13273         ii = i2
13274        lb(i2)=7
13275        e(i2)=dm
13276        lb(i1)=26
13277        e(i1)=arho
13278        go to 40
13279               endif
13280        endif
13281                      Endif
13282 40       em1=e(i1)
13283        em2=e(i2)
13284        if(ianti.eq.1 .and. lb(i1).ge.1 .and. lb(i2).ge.1)then
13285          lb(ii) = -lb(ii)
13286            jj = i2
13287           if(ii .eq. i2)jj = i1
13288          if(iblock .eq. 77)then
13289           if(lb(jj).eq.3)then
13290            lb(jj) = 5
13291           elseif(lb(jj).eq.5)then
13292            lb(jj) = 3
13293           endif
13294          elseif(iblock .eq. 78)then
13295           if(lb(jj).eq.25)then
13296            lb(jj) = 27
13297           elseif(lb(jj).eq.27)then
13298            lb(jj) = 25
13299           endif
13300          endif
13301        endif
13302            endif
13303 *-----------------------------------------------------------------------
13304 * CALCULATE THE MAGNITUDE OF THE FINAL MOMENTUM THROUGH
13305 * ENERGY CONSERVATION
13306 50          PR2   = (SRT**2 - EM1**2 - EM2**2)**2
13307      1                - 4.0 * (EM1*EM2)**2
13308           IF(PR2.LE.0.)PR2=0.00000001
13309           PR=SQRT(PR2)/(2.*SRT)
13310 * here we use the same transverse momentum distribution as for
13311 * pp collisions, it might be necessary to use a different distribution
13312
13313 clin-10/25/02 get rid of argument usage mismatch in PTR():
13314           xptr=0.33*pr
13315 c         cc1=ptr(0.33*pr,iseed)
13316          cc1=ptr(xptr,iseed)
13317 clin-10/25/02-end
13318
13319          c1=sqrt(pr**2-cc1**2)/pr
13320 *          C1   = 1.0 - 2.0 * RANART(NSEED)
13321           T1   = 2.0 * PI * RANART(NSEED)
13322       S1   = SQRT( 1.0 - C1**2 )
13323       CT1  = COS(T1)
13324       ST1  = SIN(T1)
13325 * THE MOMENTUM IN THE CMS IN THE FINAL STATE
13326       PZ   = PR * C1
13327       PX   = PR * S1*CT1
13328       PY   = PR * S1*ST1
13329 * ROTATE IT
13330        CALL ROTATE(PX0,PY0,PZ0,PX,PY,PZ)
13331       RETURN
13332       END
13333 **********************************
13334 *                                                                      *
13335 *                                                                      *
13336       SUBROUTINE CREN(PX,PY,PZ,SRT,I1,I2,IBLOCK)
13337 *     PURPOSE:                                                         *
13338 *             DEALING WITH ETA+N-->L/S+KAON PROCESS                   *
13339 *     NOTE   :                                                         *
13340 *
13341 *     QUANTITIES:                                                 *
13342 *           PX,PY,PZ - MOMENTUM COORDINATES OF ONE PARTICLE IN CM FRAME*
13343 *           SRT      - SQRT OF S                                       *
13344 *           IBLOCK   - THE INFORMATION BACK                            *
13345 *                     7  ETA+N-->L/S+KAON
13346 **********************************
13347         PARAMETER (MAXSTR=150001,MAXR=1,AMN=0.939457,
13348      1  AMP=0.93828,AP1=0.13496,
13349      2  AP2=0.13957,AM0=1.232,PI=3.1415926,CUTOFF=1.8966,AVMASS=0.9383)
13350         PARAMETER      (AKA=0.498,ALA=1.1157,ASA=1.1974)
13351         parameter     (MX=4,MY=4,MZ=8,MPX=4,MPY=4,mpz=10,mpzp=10)
13352         COMMON /AA/ R(3,MAXSTR)
13353 cc      SAVE /AA/
13354         COMMON /BB/ P(3,MAXSTR)
13355 cc      SAVE /BB/
13356         COMMON /CC/ E(MAXSTR)
13357 cc      SAVE /CC/
13358         COMMON /EE/ ID(MAXSTR),LB(MAXSTR)
13359 cc      SAVE /EE/
13360         common/input1/ MASSPR,MASSTA,ISEED,IAVOID,DT
13361 cc      SAVE /input1/
13362       COMMON/RNDF77/NSEED
13363 cc      SAVE /RNDF77/
13364       SAVE
13365
13366        PX0=PX
13367        PY0=PY
13368        PZ0=PZ
13369         NTAG=0
13370         IBLOCK=7
13371         ianti=0
13372         if(lb(i1).lt.0 .or. lb(i2).lt.0)then
13373           ianti=1
13374           iblock=-7
13375         endif
13376 * RELABLE PARTICLES FOR THE PROCESS eta+n-->LAMBDA K OR SIGMA k
13377 * DECIDE LAMBDA OR SIGMA PRODUCTION, AND TO CALCULATE THE NEW
13378 * MOMENTA FOR PARTICLES IN THE FINAL STATE.
13379        KAONC=0
13380        IF(PNLKA(SRT)/(PNLKA(SRT)
13381      & +PNSKA(SRT)).GT.RANART(NSEED))KAONC=1
13382        IF(E(I1).LE.0.6)THEN
13383        LB(I1)=23
13384        E(I1)=AKA
13385         IF(KAONC.EQ.1)THEN
13386        LB(I2)=14
13387        E(I2)=ALA
13388         ELSE
13389         LB(I2) = 15 + int(3 * RANART(NSEED))
13390        E(I2)=ASA
13391         ENDIF
13392           if(ianti .eq. 1)then
13393             lb(i1)=21
13394             lb(i2)=-lb(i2)
13395           endif
13396        ELSE
13397        LB(I2)=23
13398        E(I2)=AKA
13399         IF(KAONC.EQ.1)THEN
13400        LB(I1)=14
13401        E(I1)=ALA
13402         ELSE
13403          LB(I1) = 15 + int(3 * RANART(NSEED))
13404        E(I1)=ASA
13405         ENDIF
13406           if(ianti .eq. 1)then
13407             lb(i2)=21
13408             lb(i1)=-lb(i1)
13409           endif
13410        ENDIF
13411         EM1=E(I1)
13412         EM2=E(I2)
13413 *-----------------------------------------------------------------------
13414 * CALCULATE THE MAGNITUDE OF THE FINAL MOMENTUM THROUGH
13415 * ENERGY CONSERVATION
13416         PR2   = (SRT**2 - EM1**2 - EM2**2)**2
13417      1                - 4.0 * (EM1*EM2)**2
13418           IF(PR2.LE.0.)PR2=1.e-09
13419           PR=SQRT(PR2)/(2.*SRT)
13420           C1   = 1.0 - 2.0 * RANART(NSEED)
13421           T1   = 2.0 * PI * RANART(NSEED)
13422       S1   = SQRT( 1.0 - C1**2 )
13423       CT1  = COS(T1)
13424       ST1  = SIN(T1)
13425 * THE MOMENTUM IN THE CMS IN THE FINAL STATE
13426       PZ   = PR * C1
13427       PX   = PR * S1*CT1
13428       PY   = PR * S1*ST1
13429 * FOR THE ISOTROPIC DISTRIBUTION THERE IS NO NEED TO ROTATE
13430       RETURN
13431       END
13432 **********************************
13433 *                                                                      *
13434 *                                                                      *
13435 c      SUBROUTINE Crdir(PX,PY,PZ,SRT,I1,I2)
13436       SUBROUTINE Crdir(PX,PY,PZ,SRT,I1,I2,IBLOCK)
13437 *     PURPOSE:                                                         *
13438 *             DEALING WITH pion+N-->pion+N PROCESS                   *
13439 *     NOTE   :                                                         *
13440 *
13441 *     QUANTITIES:                                                 *
13442 *           PX,PY,PZ - MOMENTUM COORDINATES OF ONE PARTICLE IN CM FRAME*
13443 *           SRT      - SQRT OF S                                       *
13444 *           IBLOCK   - THE INFORMATION BACK                            *
13445 *
13446 **********************************
13447         PARAMETER (MAXSTR=150001,MAXR=1,AMN=0.939457,
13448      1  AMP=0.93828,AP1=0.13496,
13449      2  AP2=0.13957,AM0=1.232,PI=3.1415926,CUTOFF=1.8966,AVMASS=0.9383)
13450         PARAMETER      (AKA=0.498,ALA=1.1157,ASA=1.1974)
13451         parameter     (MX=4,MY=4,MZ=8,MPX=4,MPY=4,mpz=10,mpzp=10)
13452         COMMON /AA/ R(3,MAXSTR)
13453 cc      SAVE /AA/
13454         COMMON /BB/ P(3,MAXSTR)
13455 cc      SAVE /BB/
13456         COMMON /CC/ E(MAXSTR)
13457 cc      SAVE /CC/
13458         COMMON /EE/ ID(MAXSTR),LB(MAXSTR)
13459 cc      SAVE /EE/
13460         common/input1/ MASSPR,MASSTA,ISEED,IAVOID,DT
13461 cc      SAVE /input1/
13462       COMMON/RNDF77/NSEED
13463 cc      SAVE /RNDF77/
13464       SAVE
13465
13466        PX0=PX
13467        PY0=PY
13468        PZ0=PZ
13469         IBLOCK=999
13470         NTAG=0
13471         EM1=E(I1)
13472         EM2=E(I2)
13473 *-----------------------------------------------------------------------
13474 * CALCULATE THE MAGNITUDE OF THE FINAL MOMENTUM THROUGH
13475 * ENERGY CONSERVATION
13476         PR2   = (SRT**2 - EM1**2 - EM2**2)**2
13477      1                - 4.0 * (EM1*EM2)**2
13478           IF(PR2.LE.0.)PR2=1.e-09
13479           PR=SQRT(PR2)/(2.*SRT)
13480
13481 clin-10/25/02 get rid of argument usage mismatch in PTR():
13482           xptr=0.33*pr
13483 c         cc1=ptr(0.33*pr,iseed)
13484          cc1=ptr(xptr,iseed)
13485 clin-10/25/02-end
13486
13487          c1=sqrt(pr**2-cc1**2)/pr
13488            T1   = 2.0 * PI * RANART(NSEED)
13489       S1   = SQRT( 1.0 - C1**2 )
13490       CT1  = COS(T1)
13491       ST1  = SIN(T1)
13492 * THE MOMENTUM IN THE CMS IN THE FINAL STATE
13493       PZ   = PR * C1
13494       PX   = PR * S1*CT1
13495       PY   = PR * S1*ST1
13496 * ROTATE the momentum
13497       call rotate(px0,py0,pz0,px,py,pz)
13498       RETURN
13499       END
13500 **********************************
13501 *                                                                      *
13502 *                                                                      *
13503       SUBROUTINE CRPD(PX,PY,PZ,SRT,I1,I2,
13504      & IBLOCK,xkaon0,xkaon,Xphi,xphin)
13505 *     PURPOSE:                                                         *
13506 *     DEALING WITH PION+D(N*)-->PION +N OR
13507 *                                             L/S+KAON PROCESS         *
13508 *     NOTE   :                                                         *
13509 *
13510 *     QUANTITIES:                                                 *
13511 *           PX,PY,PZ - MOMENTUM COORDINATES OF ONE PARTICLE IN CM FRAME*
13512 *           SRT      - SQRT OF S                                       *
13513 *           IBLOCK   - THE INFORMATION BACK                            *
13514 *                     7  PION+D(N*)-->L/S+KAON
13515 *           iblock   - 80 pion+D(N*)-->pion+N
13516 *           iblock   - 81 RHO+D(N*)-->PION+N
13517 *           iblock   - 82 OMEGA+D(N*)-->PION+N
13518 *                     222  PION+D --> PHI
13519 **********************************
13520         PARAMETER (MAXSTR=150001,MAXR=1,AMN=0.939457,
13521      1  AMP=0.93828,AP1=0.13496,APHI=1.020,
13522      2  AP2=0.13957,AM0=1.232,PI=3.1415926,CUTOFF=1.8966,AVMASS=0.9383)
13523         PARAMETER      (AKA=0.498,ALA=1.1157,ASA=1.1974)
13524         parameter     (MX=4,MY=4,MZ=8,MPX=4,MPY=4,mpz=10,mpzp=10)
13525         COMMON /AA/ R(3,MAXSTR)
13526 cc      SAVE /AA/
13527         COMMON /BB/ P(3,MAXSTR)
13528 cc      SAVE /BB/
13529         COMMON /CC/ E(MAXSTR)
13530 cc      SAVE /CC/
13531         COMMON /EE/ ID(MAXSTR),LB(MAXSTR)
13532 cc      SAVE /EE/
13533         common/input1/ MASSPR,MASSTA,ISEED,IAVOID,DT
13534 cc      SAVE /input1/
13535       COMMON/RNDF77/NSEED
13536 cc      SAVE /RNDF77/
13537       SAVE
13538
13539        PX0=PX
13540        PY0=PY
13541        PZ0=PZ
13542         IBLOCK=1
13543        x1=RANART(NSEED)
13544         ianti=0
13545         if(lb(i1).lt.0 .or. lb(i2).lt.0)ianti=1
13546        if(xkaon0/(xkaon+Xphi).ge.x1)then
13547 * kaon production
13548 *-----------------------------------------------------------------------
13549         IBLOCK=7
13550         if(ianti .eq. 1)iblock=-7
13551         NTAG=0
13552 * RELABLE PARTICLES FOR THE PROCESS PION+n-->LAMBDA K OR SIGMA k
13553 * DECIDE LAMBDA OR SIGMA PRODUCTION, AND TO CALCULATE THE NEW
13554 * MOMENTA FOR PARTICLES IN THE FINAL STATE.
13555        KAONC=0
13556        IF(PNLKA(SRT)/(PNLKA(SRT)
13557      &       +PNSKA(SRT)).GT.RANART(NSEED))KAONC=1
13558 clin-8/17/00     & +PNSKA(SRT)).GT.RANART(NSEED))KAONC=1
13559        IF(E(I1).LE.0.2)THEN
13560            LB(I1)=23
13561            E(I1)=AKA
13562            IF(KAONC.EQ.1)THEN
13563               LB(I2)=14
13564               E(I2)=ALA
13565            ELSE
13566               LB(I2) = 15 + int(3 * RANART(NSEED))
13567               E(I2)=ASA
13568            ENDIF
13569            if(ianti .eq. 1)then
13570               lb(i1)=21
13571               lb(i2)=-lb(i2)
13572            endif
13573        ELSE
13574            LB(I2)=23
13575            E(I2)=AKA
13576            IF(KAONC.EQ.1)THEN
13577               LB(I1)=14
13578               E(I1)=ALA
13579            ELSE
13580               LB(I1) = 15 + int(3 * RANART(NSEED))
13581               E(I1)=ASA
13582            ENDIF
13583            if(ianti .eq. 1)then
13584               lb(i2)=21
13585               lb(i1)=-lb(i1)
13586            endif
13587        ENDIF
13588         EM1=E(I1)
13589         EM2=E(I2)
13590        go to 50
13591 * to gererate the momentum for the kaon and L/S
13592 c
13593 c* Phi production
13594        elseif(Xphi/(xkaon+Xphi).ge.x1)then
13595           iblock=222
13596          if(xphin/Xphi .ge. RANART(NSEED))then
13597           LB(I1)= 1+int(2*RANART(NSEED))
13598            E(I1)=AMN
13599          else
13600           LB(I1)= 6+int(4*RANART(NSEED))
13601            E(I1)=AM0
13602          endif
13603 c   !! at present only baryon
13604           if(ianti .eq. 1)lb(i1)=-lb(i1)
13605           LB(I2)= 29
13606            E(I2)=APHI
13607         EM1=E(I1)
13608         EM2=E(I2)
13609        go to 50
13610          else
13611 * PION REABSORPTION HAS HAPPENED
13612        X2=RANART(NSEED)
13613        IBLOCK=80
13614        ntag=0
13615 * Relable particles, I1 is assigned to the nucleon
13616 * and I2 is assigned to the pion
13617 * for the reverse of the following process
13618 *(1) for D(+)+P(+)-->p+pion(+)
13619         if( ((lb(i1).eq.8.and.lb(i2).eq.5).
13620      &       or.(lb(i1).eq.5.and.lb(i2).eq.8))
13621      &       .OR.((lb(i1).eq.-8.and.lb(i2).eq.3).
13622      &       or.(lb(i1).eq.3.and.lb(i2).eq.-8)) )then
13623            if(iabs(lb(i1)).eq.8)then
13624               ii = i1
13625               lb(i1)=1
13626               e(i1)=amn
13627               lb(i2)=5
13628               e(i2)=ap1
13629               go to 40
13630            else
13631               ii = i2
13632               lb(i2)=1
13633               e(i2)=amn
13634               lb(i1)=5
13635               e(i1)=ap1
13636               go to 40
13637            endif
13638        endif
13639 c
13640 *(2) for D(0)+P(0)-->n+pi(0) or p+pi(-)
13641        if((iabs(lb(i1)).eq.7.and.lb(i2).eq.4).
13642      &  or.(lb(i1).eq.4.and.iabs(lb(i2)).eq.7))then
13643               if(iabs(lb(i1)).eq.7)then
13644         ii = i1
13645        IF(X2.LE.0.5)THEN
13646        lb(i1)=2
13647        e(i1)=amn
13648        lb(i2)=4
13649        e(i2)=ap1
13650        go to 40
13651        Else
13652        lb(i1)=1
13653        e(i1)=amn
13654        lb(i2)=3
13655        e(i2)=ap1
13656        go to 40
13657        endif
13658               else
13659         ii = i2
13660        IF(X2.LE.0.5)THEN
13661        lb(i2)=2
13662        e(i2)=amn
13663        lb(i1)=4
13664        e(i1)=ap1
13665        go to 40
13666        Else
13667        lb(i2)=1
13668        e(i2)=amn
13669        lb(i1)=3
13670        e(i1)=ap1
13671        go to 40
13672        endif
13673               endif
13674        endif
13675 *(3) for D(+)+Pi(0)-->pi(+)+n or pi(0)+p
13676        if((iabs(lb(i1)).eq.8.and.lb(i2).eq.4).
13677      &  or.(lb(i1).eq.4.and.iabs(lb(i2)).eq.8))then
13678               if(iabs(lb(i1)).eq.8)then
13679         ii = i1
13680        IF(X2.LE.0.5)THEN
13681        lb(i1)=2
13682        e(i1)=amn
13683        lb(i2)=5
13684        e(i2)=ap1
13685        go to 40
13686        Else
13687        lb(i1)=1
13688        e(i1)=amn
13689        lb(i2)=4
13690        e(i2)=ap1
13691        go to 40
13692        endif
13693               else
13694         ii = i2
13695        IF(X2.LE.0.5)THEN
13696        lb(i2)=2
13697        e(i2)=amn
13698        lb(i1)=5
13699        e(i1)=ap1
13700        go to 40
13701        Else
13702        lb(i2)=1
13703        e(i2)=amn
13704        lb(i1)=4
13705        e(i1)=ap1
13706        go to 40
13707        endif
13708               endif
13709        endif
13710 *(4) for D(-)+Pi(0)-->n+pi(-)
13711        if((iabs(lb(i1)).eq.6.and.lb(i2).eq.4).
13712      &  or.(lb(i1).eq.4.and.iabs(lb(i2)).eq.6))then
13713               if(iabs(lb(i1)).eq.6)then
13714         ii = i1
13715        lb(i1)=2
13716        e(i1)=amn
13717        lb(i2)=3
13718        e(i2)=ap1
13719        go to 40
13720        else
13721         ii = i2
13722        lb(i2)=2
13723        e(i2)=amn
13724        lb(i1)=3
13725        e(i1)=ap1
13726        go to 40
13727        ENDIF
13728        endif
13729 *(5) for D(+)+Pi(-)-->pi(0)+n or pi(-)+p
13730        if( ((lb(i1).eq.8.and.lb(i2).eq.3).
13731      &  or.(lb(i1).eq.3.and.lb(i2).eq.8))
13732      &        .OR.((lb(i1).eq.-8.and.lb(i2).eq.5).
13733      &  or.(lb(i1).eq.5.and.lb(i2).eq.-8)) )then
13734               if(iabs(lb(i1)).eq.8)then
13735         ii = i1
13736         IF(X2.LE.0.5)THEN
13737        lb(i1)=2
13738        e(i1)=amn
13739        lb(i2)=4
13740        e(i2)=ap1
13741        go to 40
13742        ELSE
13743        lb(i1)=1
13744        e(i1)=amn
13745        lb(i2)=3
13746        e(i2)=ap1
13747        go to 40
13748        endif
13749               else
13750         ii = i2
13751         IF(X2.LE.0.5)THEN
13752        lb(i2)=2
13753        e(i2)=amn
13754        lb(i1)=4
13755        e(i1)=ap1
13756        go to 40
13757        ELSE
13758        lb(i2)=1
13759        e(i2)=amn
13760        lb(i1)=3
13761        e(i1)=ap1
13762        go to 40
13763        endif
13764               endif
13765        ENDIF
13766 *(6) D(0)+P(+)-->n+pi(+) or p+pi(0)
13767        if( ((lb(i1).eq.7.and.lb(i2).eq.5).
13768      &  or.(lb(i1).eq.5.and.lb(i2).eq.7))
13769      &        .OR.((lb(i1).eq.-7.and.lb(i2).eq.3).
13770      &  or.(lb(i1).eq.3.and.lb(i2).eq.-7)) )then
13771               if(iabs(lb(i1)).eq.7)then
13772         ii = i1
13773          IF(X2.LE.0.5)THEN
13774        lb(i1)=2
13775        e(i1)=amn
13776        lb(i2)=5
13777        e(i2)=ap1
13778        go to 40
13779        else
13780        lb(i1)=1
13781        e(i1)=amn
13782        lb(i2)=4
13783        e(i2)=ap1
13784        go to 40
13785        endif
13786               else
13787         ii = i2
13788          IF(X2.LE.0.5)THEN
13789        lb(i2)=2
13790        e(i2)=amn
13791        lb(i1)=5
13792        e(i1)=ap1
13793        go to 40
13794        Else
13795        lb(i2)=1
13796        e(i2)=amn
13797        lb(i1)=4
13798        e(i1)=ap1
13799        go to 40
13800        endif
13801               endif
13802        ENDIF
13803 *(7) for D(0)+Pi(-)-->n+pi(-)
13804        if( ((lb(i1).eq.7.and.lb(i2).eq.3).
13805      &  or.(lb(i1).eq.3.and.lb(i2).eq.7))
13806      &        .OR.((lb(i1).eq.-7.and.lb(i2).eq.5).
13807      &  or.(lb(i1).eq.5.and.lb(i2).eq.-7)) )then
13808               if(iabs(lb(i1)).eq.7)then
13809         ii = i1
13810        lb(i1)=2
13811        e(i1)=amn
13812        lb(i2)=3
13813        e(i2)=ap1
13814        go to 40
13815        else
13816         ii = i2
13817        lb(i2)=2
13818        e(i2)=amn
13819        lb(i1)=3
13820        e(i1)=ap1
13821        go to 40
13822        ENDIF
13823        endif
13824 *(8) D(-)+P(+)-->n+pi(0) or p+pi(-)
13825        if( ((lb(i1).eq.6.and.lb(i2).eq.5)
13826      &      .or.(lb(i1).eq.5.and.lb(i2).eq.6))
13827      &   .OR.((lb(i1).eq.-6.and.lb(i2).eq.3).
13828      &      or.(lb(i1).eq.3.and.lb(i2).eq.-6)) )then
13829               if(iabs(lb(i1)).eq.6)then
13830          ii = i1
13831        IF(X2.LE.0.5)THEN
13832        lb(i1)=2
13833        e(i1)=amn
13834        lb(i2)=4
13835        e(i2)=ap1
13836        go to 40
13837        else
13838        lb(i1)=1
13839        e(i1)=amn
13840        lb(i2)=3
13841        e(i2)=ap1
13842        go to 40
13843        endif
13844               else
13845          ii = i2
13846        IF(X2.LE.0.5)THEN
13847        lb(i2)=2
13848        e(i2)=amn
13849        lb(i1)=4
13850        e(i1)=ap1
13851        go to 40
13852        Else
13853        lb(i2)=1
13854        e(i2)=amn
13855        lb(i1)=3
13856        e(i1)=ap1
13857        go to 40
13858        endif
13859               endif
13860        ENDIF
13861 c
13862 *(9) D(++)+P(-)-->n+pi(+) or p+pi(0)
13863        if( ((lb(i1).eq.9.and.lb(i2).eq.3)
13864      &   .or.(lb(i1).eq.3.and.lb(i2).eq.9))
13865      &       .OR. ((lb(i1).eq.-9.and.lb(i2).eq.5)
13866      &   .or.(lb(i1).eq.5.and.lb(i2).eq.-9)) )then
13867               if(iabs(lb(i1)).eq.9)then
13868         ii = i1
13869        IF(X2.LE.0.5)THEN
13870        lb(i1)=2
13871        e(i1)=amn
13872        lb(i2)=5
13873        e(i2)=ap1
13874        go to 40
13875        else
13876        lb(i1)=1
13877        e(i1)=amn
13878        lb(i2)=4
13879        e(i2)=ap1
13880        go to 40
13881        endif
13882               else
13883         ii = i2
13884        IF(X2.LE.0.5)THEN
13885        lb(i2)=2
13886        e(i2)=amn
13887        lb(i1)=5
13888        e(i1)=ap1
13889        go to 40
13890        Else
13891        lb(i2)=1
13892        e(i2)=amn
13893        lb(i1)=4
13894        e(i1)=ap1
13895        go to 40
13896        endif
13897               endif
13898        ENDIF
13899 *(10) for D(++)+Pi(0)-->p+pi(+)
13900        if((iabs(lb(i1)).eq.9.and.lb(i2).eq.4)
13901      &    .or.(lb(i1).eq.4.and.iabs(lb(i2)).eq.9))then
13902            if(iabs(lb(i1)).eq.9)then
13903         ii = i1
13904        lb(i1)=1
13905        e(i1)=amn
13906        lb(i2)=5
13907        e(i2)=ap1
13908        go to 40
13909        else
13910         ii = i2
13911        lb(i2)=1
13912        e(i2)=amn
13913        lb(i1)=5
13914        e(i1)=ap1
13915        go to 40
13916        ENDIF
13917        endif
13918 *(11) for N*(1440)(+)or N*(1535)(+)+P(+)-->p+pion(+)
13919        if( ((lb(i1).eq.11.and.lb(i2).eq.5).
13920      &  or.(lb(i1).eq.5.and.lb(i2).eq.11).
13921      &  or.(lb(i1).eq.13.and.lb(i2).eq.5).
13922      &  or.(lb(i1).eq.5.and.lb(i2).eq.13))
13923      &        .OR.((lb(i1).eq.-11.and.lb(i2).eq.3).
13924      &  or.(lb(i1).eq.3.and.lb(i2).eq.-11).
13925      &  or.(lb(i1).eq.-13.and.lb(i2).eq.3).
13926      &  or.(lb(i1).eq.3.and.lb(i2).eq.-13)) )then
13927               if(iabs(lb(i1)).eq.11.or.iabs(lb(i1)).eq.13)then
13928         ii = i1
13929        lb(i1)=1
13930        e(i1)=amn
13931        lb(i2)=5
13932        e(i2)=ap1
13933        go to 40
13934        else
13935         ii = i2
13936        lb(i2)=1
13937        e(i2)=amn
13938        lb(i1)=5
13939        e(i1)=ap1
13940        go to 40
13941               endif
13942        endif
13943 *(12) for N*(1440) or N*(1535)(0)+P(0)-->n+pi(0) or p+pi(-)
13944        if((iabs(lb(i1)).eq.10.and.lb(i2).eq.4).
13945      &  or.(lb(i1).eq.4.and.iabs(lb(i2)).eq.10).
13946      &  or.(lb(i1).eq.4.and.iabs(lb(i2)).eq.12).
13947      &  or.(lb(i2).eq.4.and.iabs(lb(i1)).eq.12))then
13948               if(iabs(lb(i1)).eq.10.or.iabs(lb(i1)).eq.12)then
13949         ii = i1
13950        IF(X2.LE.0.5)THEN
13951        lb(i1)=2
13952        e(i1)=amn
13953        lb(i2)=4
13954        e(i2)=ap1
13955        go to 40
13956        Else
13957        lb(i1)=1
13958        e(i1)=amn
13959        lb(i2)=3
13960        e(i2)=ap1
13961        go to 40
13962        endif
13963               else
13964         ii = i2
13965        IF(X2.LE.0.5)THEN
13966        lb(i2)=2
13967        e(i2)=amn
13968        lb(i1)=4
13969        e(i1)=ap1
13970        go to 40
13971        Else
13972        lb(i2)=1
13973        e(i2)=amn
13974        lb(i1)=3
13975        e(i1)=ap1
13976        go to 40
13977        endif
13978               endif
13979        endif
13980 *(13) for N*(1440) or N*(1535)(+)+Pi(0)-->pi(+)+n or pi(0)+p
13981        if((iabs(lb(i1)).eq.11.and.lb(i2).eq.4).
13982      &  or.(lb(i1).eq.4.and.iabs(lb(i2)).eq.11).
13983      &  or.(lb(i1).eq.4.and.iabs(lb(i2)).eq.13).
13984      &  or.(lb(i2).eq.4.and.iabs(lb(i1)).eq.13))then
13985               if(iabs(lb(i1)).eq.11.or.iabs(lb(i1)).eq.13)then
13986         ii = i1
13987        IF(X2.LE.0.5)THEN
13988        lb(i1)=2
13989        e(i1)=amn
13990        lb(i2)=5
13991        e(i2)=ap1
13992        go to 40
13993        Else
13994        lb(i1)=1
13995        e(i1)=amn
13996        lb(i2)=4
13997        e(i2)=ap1
13998        go to 40
13999        endif
14000               else
14001         ii = i2
14002        IF(X2.LE.0.5)THEN
14003        lb(i2)=2
14004        e(i2)=amn
14005        lb(i1)=5
14006        e(i1)=ap1
14007        go to 40
14008        Else
14009        lb(i2)=1
14010        e(i2)=amn
14011        lb(i1)=4
14012        e(i1)=ap1
14013        go to 40
14014        endif
14015               endif
14016        endif
14017 *(14) for N*(1440) or N*(1535)(+)+Pi(-)-->pi(0)+n or pi(-)+p
14018        if( ((lb(i1).eq.11.and.lb(i2).eq.3).
14019      &  or.(lb(i1).eq.3.and.lb(i2).eq.11).
14020      &  or.(lb(i1).eq.3.and.lb(i2).eq.13).
14021      &  or.(lb(i2).eq.3.and.lb(i1).eq.13))
14022      &        .OR.((lb(i1).eq.-11.and.lb(i2).eq.5).
14023      &  or.(lb(i1).eq.5.and.lb(i2).eq.-11).
14024      &  or.(lb(i1).eq.5.and.lb(i2).eq.-13).
14025      &  or.(lb(i2).eq.5.and.lb(i1).eq.-13)) )then
14026        if(iabs(lb(i1)).eq.11.or.iabs(lb(i1)).eq.13)then
14027         ii = i1
14028          IF(X2.LE.0.5)THEN
14029        lb(i1)=2
14030        e(i1)=amn
14031        lb(i2)=4
14032        e(i2)=ap1
14033        go to 40
14034        ELSE
14035        lb(i1)=1
14036        e(i1)=amn
14037        lb(i2)=3
14038        e(i2)=ap1
14039        go to 40
14040        endif
14041               else
14042         ii = i2
14043          IF(X2.LE.0.5)THEN
14044        lb(i2)=2
14045        e(i2)=amn
14046        lb(i1)=4
14047        e(i1)=ap1
14048        go to 40
14049        ELSE
14050        lb(i2)=1
14051        e(i2)=amn
14052        lb(i1)=3
14053        e(i1)=ap1
14054        go to 40
14055        endif
14056               endif
14057        ENDIF
14058 *(15) N*(1440) or N*(1535)(0)+P(+)-->n+pi(+) or p+pi(0)
14059        if( ((lb(i1).eq.10.and.lb(i2).eq.5).
14060      &  or.(lb(i1).eq.5.and.lb(i2).eq.10).
14061      &  or.(lb(i1).eq.12.and.lb(i2).eq.5).
14062      &  or.(lb(i1).eq.5.and.lb(i2).eq.12))
14063      &        .OR.((lb(i1).eq.-10.and.lb(i2).eq.3).
14064      &  or.(lb(i1).eq.3.and.lb(i2).eq.-10).
14065      &  or.(lb(i1).eq.-12.and.lb(i2).eq.3).
14066      &  or.(lb(i1).eq.3.and.lb(i2).eq.-12)) )then
14067        if(iabs(lb(i1)).eq.10.or.iabs(lb(i1)).eq.12)then
14068         ii = i1
14069         IF(X2.LE.0.5)THEN
14070        lb(i1)=2
14071        e(i1)=amn
14072        lb(i2)=5
14073        e(i2)=ap1
14074        go to 40
14075        else
14076        lb(i1)=1
14077        e(i1)=amn
14078        lb(i2)=4
14079        e(i2)=ap1
14080        go to 40
14081        endif
14082               else
14083         ii = i2
14084         IF(X2.LE.0.5)THEN
14085        lb(i2)=2
14086        e(i2)=amn
14087        lb(i1)=5
14088        e(i1)=ap1
14089        go to 40
14090        Else
14091        lb(i2)=1
14092        e(i2)=amn
14093        lb(i1)=4
14094        e(i1)=ap1
14095        go to 40
14096        endif
14097               endif
14098        ENDIF
14099 *(16) for N*(1440) or N*(1535) (0)+Pi(-)-->n+pi(-)
14100        if( ((lb(i1).eq.10.and.lb(i2).eq.3).
14101      &  or.(lb(i1).eq.3.and.lb(i2).eq.10).
14102      &  or.(lb(i1).eq.3.and.lb(i2).eq.12).
14103      &  or.(lb(i1).eq.12.and.lb(i2).eq.3))
14104      &        .OR.((lb(i1).eq.-10.and.lb(i2).eq.5).
14105      &  or.(lb(i1).eq.5.and.lb(i2).eq.-10).
14106      &  or.(lb(i1).eq.5.and.lb(i2).eq.-12).
14107      &  or.(lb(i1).eq.-12.and.lb(i2).eq.5)) )then
14108            if(iabs(lb(i1)).eq.10.or.iabs(lb(i1)).eq.12)then
14109         ii = i1
14110        lb(i1)=2
14111        e(i1)=amn
14112        lb(i2)=3
14113        e(i2)=ap1
14114        go to 40
14115        else
14116         ii = i2
14117        lb(i2)=2
14118        e(i2)=amn
14119        lb(i1)=3
14120        e(i1)=ap1
14121        go to 40
14122        ENDIF
14123        endif
14124 40       em1=e(i1)
14125        em2=e(i2)
14126        if(ianti.eq.1 .and.  lb(i1).ge.1 .and. lb(i2).ge.1)then
14127          lb(ii) = -lb(ii)
14128            jj = i2
14129           if(ii .eq. i2)jj = i1
14130           if(lb(jj).eq.3)then
14131            lb(jj) = 5
14132           elseif(lb(jj).eq.5)then
14133            lb(jj) = 3
14134           endif
14135          endif
14136           endif
14137 *-----------------------------------------------------------------------
14138 * CALCULATE THE MAGNITUDE OF THE FINAL MOMENTUM THROUGH
14139 * ENERGY CONSERVATION
14140 50          PR2   = (SRT**2 - EM1**2 - EM2**2)**2
14141      1                - 4.0 * (EM1*EM2)**2
14142           IF(PR2.LE.0.)PR2=1.E-09
14143           PR=SQRT(PR2)/(2.*SRT)
14144
14145 clin-10/25/02 get rid of argument usage mismatch in PTR():
14146           xptr=0.33*pr
14147 c         cc1=ptr(0.33*pr,iseed)
14148          cc1=ptr(xptr,iseed)
14149 clin-10/25/02-end
14150
14151          c1=sqrt(pr**2-cc1**2)/pr
14152 c         C1   = 1.0 - 2.0 * RANART(NSEED)
14153           T1   = 2.0 * PI * RANART(NSEED)
14154       S1   = SQRT( 1.0 - C1**2 )
14155       CT1  = COS(T1)
14156       ST1  = SIN(T1)
14157       PZ   = PR * C1
14158       PX   = PR * S1*CT1
14159       PY   = PR * S1*ST1
14160 * rotate the momentum
14161        call rotate(px0,py0,pz0,px,py,pz)
14162       RETURN
14163       END
14164 **********************************
14165 *                                                                      *
14166 *                                                                      *
14167       SUBROUTINE CRRD(PX,PY,PZ,SRT,I1,I2,
14168      & IBLOCK,xkaon0,xkaon,Xphi,xphin)
14169 *     PURPOSE:                                                         *
14170 *     DEALING WITH rho(omega)+N or D(N*)-->PION +N OR
14171 *                                             L/S+KAON PROCESS         *
14172 *     NOTE   :                                                         *
14173 *
14174 *     QUANTITIES:                                                 *
14175 *           PX,PY,PZ - MOMENTUM COORDINATES OF ONE PARTICLE IN CM FRAME*
14176 *           SRT      - SQRT OF S                                       *
14177 *           IBLOCK   - THE INFORMATION BACK                            *
14178 *                     7  rho(omega)+N or D(N*)-->L/S+KAON
14179 *           iblock   - 80 pion+D(N*)-->pion+N
14180 *           iblock   - 81 RHO+D(N*)-->PION+N
14181 *           iblock   - 82 OMEGA+D(N*)-->PION+N
14182 *           iblock   - 222 pion+N-->Phi
14183 **********************************
14184         PARAMETER (MAXSTR=150001,MAXR=1,AMN=0.939457,
14185      1  AMP=0.93828,AP1=0.13496,
14186      2  AP2=0.13957,AM0=1.232,PI=3.1415926,CUTOFF=1.8966,AVMASS=0.9383)
14187         PARAMETER     (AKA=0.498,ALA=1.1157,ASA=1.1974,APHI=1.02)
14188         parameter     (MX=4,MY=4,MZ=8,MPX=4,MPY=4,mpz=10,mpzp=10)
14189         COMMON /AA/ R(3,MAXSTR)
14190 cc      SAVE /AA/
14191         COMMON /BB/ P(3,MAXSTR)
14192 cc      SAVE /BB/
14193         COMMON /CC/ E(MAXSTR)
14194 cc      SAVE /CC/
14195         COMMON /EE/ ID(MAXSTR),LB(MAXSTR)
14196 cc      SAVE /EE/
14197         common/input1/ MASSPR,MASSTA,ISEED,IAVOID,DT
14198 cc      SAVE /input1/
14199       COMMON/RNDF77/NSEED
14200 cc      SAVE /RNDF77/
14201       SAVE
14202
14203        PX0=PX
14204        PY0=PY
14205        PZ0=PZ
14206        IBLOCK=1
14207        ianti=0
14208        if(lb(i1).lt.0 .or. lb(i2).lt.0) ianti=1
14209        x1=RANART(NSEED)
14210        if(xkaon0/(xkaon+Xphi).ge.x1)then
14211 * kaon production
14212 *-----------------------------------------------------------------------
14213         IBLOCK=7
14214         if(ianti .eq. 1)iblock=-7
14215         NTAG=0
14216 * RELABLE PARTICLES FOR THE PROCESS PION+n-->LAMBDA K OR SIGMA k
14217 * DECIDE LAMBDA OR SIGMA PRODUCTION, AND TO CALCULATE THE NEW
14218 * MOMENTA FOR PARTICLES IN THE FINAL STATE.
14219        KAONC=0
14220        IF(PNLKA(SRT)/(PNLKA(SRT)
14221      & +PNSKA(SRT)).GT.RANART(NSEED))KAONC=1
14222 clin-8/17/00     & +PNSKA(SRT)).GT.RANART(NSEED))KAONC=1
14223        IF(E(I1).LE.0.92)THEN
14224        LB(I1)=23
14225        E(I1)=AKA
14226               IF(KAONC.EQ.1)THEN
14227        LB(I2)=14
14228        E(I2)=ALA
14229               ELSE
14230         LB(I2) = 15 + int(3 * RANART(NSEED))
14231        E(I2)=ASA
14232               ENDIF
14233          if(ianti .eq. 1)then
14234           lb(i1) = 21
14235           lb(i2) = -lb(i2)
14236          endif
14237        ELSE
14238        LB(I2)=23
14239        E(I2)=AKA
14240               IF(KAONC.EQ.1)THEN
14241        LB(I1)=14
14242        E(I1)=ALA
14243               ELSE
14244          LB(I1) = 15 + int(3 * RANART(NSEED))
14245        E(I1)=ASA
14246               ENDIF
14247          if(ianti .eq. 1)then
14248           lb(i2) = 21
14249           lb(i1) = -lb(i1)
14250          endif
14251        ENDIF
14252         EM1=E(I1)
14253         EM2=E(I2)
14254        go to 50
14255 * to gererate the momentum for the kaon and L/S
14256 c
14257 c* Phi production
14258        elseif(Xphi/(xkaon+Xphi).ge.x1)then
14259           iblock=222
14260          if(xphin/Xphi .ge. RANART(NSEED))then
14261           LB(I1)= 1+int(2*RANART(NSEED))
14262            E(I1)=AMN
14263          else
14264           LB(I1)= 6+int(4*RANART(NSEED))
14265            E(I1)=AM0
14266          endif
14267 c   !! at present only baryon
14268          if(ianti .eq. 1)lb(i1)=-lb(i1)
14269           LB(I2)= 29
14270            E(I2)=APHI
14271         EM1=E(I1)
14272         EM2=E(I2)
14273        go to 50
14274          else
14275 * rho(omega) REABSORPTION HAS HAPPENED
14276        X2=RANART(NSEED)
14277        IBLOCK=81
14278        ntag=0
14279        if(lb(i1).eq.28.or.lb(i2).eq.28)go to 60
14280 * we treat Rho reabsorption in the following
14281 * Relable particles, I1 is assigned to the Delta
14282 * and I2 is assigned to the meson
14283 * for the reverse of the following process
14284 *(1) for D(+)+rho(+)-->p+pion(+)
14285        if( ((lb(i1).eq.8.and.lb(i2).eq.27).
14286      &  or.(lb(i1).eq.27.and.lb(i2).eq.8))
14287      &        .OR. ((lb(i1).eq.-8.and.lb(i2).eq.25).
14288      &  or.(lb(i1).eq.25.and.lb(i2).eq.-8)) )then
14289               if(iabs(lb(i1)).eq.8)then
14290         ii = i1
14291        lb(i1)=1
14292        e(i1)=amn
14293        lb(i2)=5
14294        e(i2)=ap1
14295        go to 40
14296        else
14297         ii = i2
14298        lb(i2)=1
14299        e(i2)=amn
14300        lb(i1)=5
14301        e(i1)=ap1
14302        go to 40
14303               endif
14304        endif
14305 *(2) for D(0)+rho(0)-->n+pi(0) or p+pi(-)
14306        if((iabs(lb(i1)).eq.7.and.lb(i2).eq.26).
14307      &  or.(lb(i1).eq.26.and.iabs(lb(i2)).eq.7))then
14308               if(iabs(lb(i1)).eq.7)then
14309         ii = i1
14310        IF(X2.LE.0.5)THEN
14311        lb(i1)=2
14312        e(i1)=amn
14313        lb(i2)=4
14314        e(i2)=ap1
14315        go to 40
14316        Else
14317        lb(i1)=1
14318        e(i1)=amn
14319        lb(i2)=3
14320        e(i2)=ap1
14321        go to 40
14322        endif
14323               else
14324         ii = i2
14325        IF(X2.LE.0.5)THEN
14326        lb(i2)=2
14327        e(i2)=amn
14328        lb(i1)=4
14329        e(i1)=ap1
14330        go to 40
14331        Else
14332        lb(i2)=1
14333        e(i2)=amn
14334        lb(i1)=3
14335        e(i1)=ap1
14336        go to 40
14337        endif
14338               endif
14339        endif
14340 *(3) for D(+)+rho(0)-->pi(+)+n or pi(0)+p
14341        if((iabs(lb(i1)).eq.8.and.lb(i2).eq.26).
14342      &  or.(lb(i1).eq.26.and.iabs(lb(i2)).eq.8))then
14343               if(iabs(lb(i1)).eq.8)then
14344         ii = i1
14345        IF(X2.LE.0.5)THEN
14346        lb(i1)=2
14347        e(i1)=amn
14348        lb(i2)=5
14349        e(i2)=ap1
14350        go to 40
14351        Else
14352        lb(i1)=1
14353        e(i1)=amn
14354        lb(i2)=4
14355        e(i2)=ap1
14356        go to 40
14357        endif
14358               else
14359         ii = i2
14360        IF(X2.LE.0.5)THEN
14361        lb(i2)=2
14362        e(i2)=amn
14363        lb(i1)=5
14364        e(i1)=ap1
14365        go to 40
14366        Else
14367        lb(i2)=1
14368        e(i2)=amn
14369        lb(i1)=4
14370        e(i1)=ap1
14371        go to 40
14372        endif
14373               endif
14374        endif
14375 *(4) for D(-)+rho(0)-->n+pi(-)
14376        if((iabs(lb(i1)).eq.6.and.lb(i2).eq.26).
14377      &  or.(lb(i1).eq.26.and.iabs(lb(i2)).eq.6))then
14378               if(iabs(lb(i1)).eq.6)then
14379         ii = i1
14380        lb(i1)=2
14381        e(i1)=amn
14382        lb(i2)=3
14383        e(i2)=ap1
14384        go to 40
14385        else
14386         ii = i2
14387        lb(i2)=2
14388        e(i2)=amn
14389        lb(i1)=3
14390        e(i1)=ap1
14391        go to 40
14392        ENDIF
14393        endif
14394 *(5) for D(+)+rho(-)-->pi(0)+n or pi(-)+p
14395        if( ((lb(i1).eq.8.and.lb(i2).eq.25).
14396      &  or.(lb(i1).eq.25.and.lb(i2).eq.8))
14397      &        .OR. ((lb(i1).eq.-8.and.lb(i2).eq.27).
14398      &  or.(lb(i1).eq.27.and.lb(i2).eq.-8)) )then
14399               if(iabs(lb(i1)).eq.8)then
14400         ii = i1
14401        IF(X2.LE.0.5)THEN
14402        lb(i1)=2
14403        e(i1)=amn
14404        lb(i2)=4
14405        e(i2)=ap1
14406        go to 40
14407        ELSE
14408        lb(i1)=1
14409        e(i1)=amn
14410        lb(i2)=3
14411        e(i2)=ap1
14412        go to 40
14413        endif
14414               else
14415         ii = i2
14416        IF(X2.LE.0.5)THEN
14417        lb(i2)=2
14418        e(i2)=amn
14419        lb(i1)=4
14420        e(i1)=ap1
14421        go to 40
14422        ELSE
14423        lb(i2)=1
14424        e(i2)=amn
14425        lb(i1)=3
14426        e(i1)=ap1
14427        go to 40
14428        endif
14429               endif
14430        ENDIF
14431 *(6) D(0)+rho(+)-->n+pi(+) or p+pi(0)
14432        if( ((lb(i1).eq.7.and.lb(i2).eq.27).
14433      &  or.(lb(i1).eq.27.and.lb(i2).eq.7))
14434      &       .OR.((lb(i1).eq.-7.and.lb(i2).eq.25).
14435      &  or.(lb(i1).eq.25.and.lb(i2).eq.-7)) )then
14436               if(iabs(lb(i1)).eq.7)then
14437         ii = i1
14438        IF(X2.LE.0.5)THEN
14439        lb(i1)=2
14440        e(i1)=amn
14441        lb(i2)=5
14442        e(i2)=ap1
14443        go to 40
14444        else
14445        lb(i1)=1
14446        e(i1)=amn
14447        lb(i2)=4
14448        e(i2)=ap1
14449        go to 40
14450        endif
14451               else
14452         ii = i2
14453        IF(X2.LE.0.5)THEN
14454        lb(i2)=2
14455        e(i2)=amn
14456        lb(i1)=5
14457        e(i1)=ap1
14458        go to 40
14459        Else
14460        lb(i2)=1
14461        e(i2)=amn
14462        lb(i1)=4
14463        e(i1)=ap1
14464        go to 40
14465        endif
14466               endif
14467        ENDIF
14468 *(7) for D(0)+rho(-)-->n+pi(-)
14469        if( ((lb(i1).eq.7.and.lb(i2).eq.25).
14470      &  or.(lb(i1).eq.25.and.lb(i2).eq.7))
14471      &       .OR.((lb(i1).eq.-7.and.lb(i2).eq.27).
14472      &  or.(lb(i1).eq.27.and.lb(i2).eq.-7)) )then
14473               if(iabs(lb(i1)).eq.7)then
14474         ii = i1
14475        lb(i1)=2
14476        e(i1)=amn
14477        lb(i2)=3
14478        e(i2)=ap1
14479        go to 40
14480        else
14481         ii = i2
14482        lb(i2)=2
14483        e(i2)=amn
14484        lb(i1)=3
14485        e(i1)=ap1
14486        go to 40
14487        ENDIF
14488        endif
14489 *(8) D(-)+rho(+)-->n+pi(0) or p+pi(-)
14490        if( ((lb(i1).eq.6.and.lb(i2).eq.27).
14491      &  or.(lb(i1).eq.27.and.lb(i2).eq.6))
14492      &        .OR. ((lb(i1).eq.-6.and.lb(i2).eq.25).
14493      &  or.(lb(i1).eq.25.and.lb(i2).eq.-6)) )then
14494               if(iabs(lb(i1)).eq.6)then
14495         ii = i1
14496        IF(X2.LE.0.5)THEN
14497        lb(i1)=2
14498        e(i1)=amn
14499        lb(i2)=4
14500        e(i2)=ap1
14501        go to 40
14502        else
14503        lb(i1)=1
14504        e(i1)=amn
14505        lb(i2)=3
14506        e(i2)=ap1
14507        go to 40
14508        endif
14509               else
14510         ii = i2
14511        IF(X2.LE.0.5)THEN
14512        lb(i2)=2
14513        e(i2)=amn
14514        lb(i1)=4
14515        e(i1)=ap1
14516        go to 40
14517        Else
14518        lb(i2)=1
14519        e(i2)=amn
14520        lb(i1)=3
14521        e(i1)=ap1
14522        go to 40
14523        endif
14524               endif
14525        ENDIF
14526 *(9) D(++)+rho(-)-->n+pi(+) or p+pi(0)
14527        if( ((lb(i1).eq.9.and.lb(i2).eq.25).
14528      &  or.(lb(i1).eq.25.and.lb(i2).eq.9))
14529      &        .OR.((lb(i1).eq.-9.and.lb(i2).eq.27).
14530      &  or.(lb(i1).eq.27.and.lb(i2).eq.-9)) )then
14531               if(iabs(lb(i1)).eq.9)then
14532         ii = i1
14533        IF(X2.LE.0.5)THEN
14534        lb(i1)=2
14535        e(i1)=amn
14536        lb(i2)=5
14537        e(i2)=ap1
14538        go to 40
14539        else
14540        lb(i1)=1
14541        e(i1)=amn
14542        lb(i2)=4
14543        e(i2)=ap1
14544        go to 40
14545        endif
14546               else
14547         ii = i2
14548        IF(X2.LE.0.5)THEN
14549        lb(i2)=2
14550        e(i2)=amn
14551        lb(i1)=5
14552        e(i1)=ap1
14553        go to 40
14554        Else
14555        lb(i2)=1
14556        e(i2)=amn
14557        lb(i1)=4
14558        e(i1)=ap1
14559        go to 40
14560        endif
14561               endif
14562        ENDIF
14563 *(10) for D(++)+rho(0)-->p+pi(+)
14564        if((iabs(lb(i1)).eq.9.and.lb(i2).eq.26).
14565      &  or.(lb(i1).eq.26.and.iabs(lb(i2)).eq.9))then
14566               if(iabs(lb(i1)).eq.9)then
14567         ii = i1
14568        lb(i1)=1
14569        e(i1)=amn
14570        lb(i2)=5
14571        e(i2)=ap1
14572        go to 40
14573        else
14574         ii = i2
14575        lb(i2)=1
14576        e(i2)=amn
14577        lb(i1)=5
14578        e(i1)=ap1
14579        go to 40
14580        ENDIF
14581        endif
14582 *(11) for N*(1440)(+)or N*(1535)(+)+rho(+)-->p+pion(+)
14583        if( ((lb(i1).eq.11.and.lb(i2).eq.27).
14584      &  or.(lb(i1).eq.27.and.lb(i2).eq.11).
14585      &  or.(lb(i1).eq.13.and.lb(i2).eq.27).
14586      &  or.(lb(i1).eq.27.and.lb(i2).eq.13))
14587      &        .OR. ((lb(i1).eq.-11.and.lb(i2).eq.25).
14588      &  or.(lb(i1).eq.25.and.lb(i2).eq.-11).
14589      &  or.(lb(i1).eq.-13.and.lb(i2).eq.25).
14590      &  or.(lb(i1).eq.25.and.lb(i2).eq.-13)) )then
14591               if(iabs(lb(i1)).eq.11.or.iabs(lb(i1)).eq.13)then
14592         ii = i1
14593        lb(i1)=1
14594        e(i1)=amn
14595        lb(i2)=5
14596        e(i2)=ap1
14597        go to 40
14598        else
14599         ii = i2
14600        lb(i2)=1
14601        e(i2)=amn
14602        lb(i1)=5
14603        e(i1)=ap1
14604        go to 40
14605               endif
14606        endif
14607 *(12) for N*(1440) or N*(1535)(0)+rho(0)-->n+pi(0) or p+pi(-)
14608        if((iabs(lb(i1)).eq.10.and.lb(i2).eq.26).
14609      &  or.(lb(i1).eq.26.and.iabs(lb(i2)).eq.10).
14610      &  or.(lb(i1).eq.26.and.iabs(lb(i2)).eq.12).
14611      &  or.(lb(i2).eq.26.and.iabs(lb(i1)).eq.12))then
14612               if(iabs(lb(i1)).eq.10.or.iabs(lb(i1)).eq.12)then
14613         ii = i1
14614        IF(X2.LE.0.5)THEN
14615        lb(i1)=2
14616        e(i1)=amn
14617        lb(i2)=4
14618        e(i2)=ap1
14619        go to 40
14620        Else
14621        lb(i1)=1
14622        e(i1)=amn
14623        lb(i2)=3
14624        e(i2)=ap1
14625        go to 40
14626        endif
14627               else
14628         ii = i2
14629        IF(X2.LE.0.5)THEN
14630        lb(i2)=2
14631        e(i2)=amn
14632        lb(i1)=4
14633        e(i1)=ap1
14634        go to 40
14635        Else
14636        lb(i2)=1
14637        e(i2)=amn
14638        lb(i1)=3
14639        e(i1)=ap1
14640        go to 40
14641        endif
14642               endif
14643        endif
14644 *(13) for N*(1440) or N*(1535)(+)+rho(0)-->pi(+)+n or pi(0)+p
14645        if((iabs(lb(i1)).eq.11.and.lb(i2).eq.26).
14646      &  or.(lb(i1).eq.26.and.iabs(lb(i2)).eq.11).
14647      &  or.(lb(i1).eq.26.and.iabs(lb(i2)).eq.13).
14648      &  or.(lb(i2).eq.26.and.iabs(lb(i1)).eq.13))then
14649               if(iabs(lb(i1)).eq.11.or.iabs(lb(i1)).eq.13)then
14650         ii = i1
14651        IF(X2.LE.0.5)THEN
14652        lb(i1)=2
14653        e(i1)=amn
14654        lb(i2)=5
14655        e(i2)=ap1
14656        go to 40
14657        Else
14658        lb(i1)=1
14659        e(i1)=amn
14660        lb(i2)=4
14661        e(i2)=ap1
14662        go to 40
14663        endif
14664               else
14665         ii = i2
14666        IF(X2.LE.0.5)THEN
14667        lb(i2)=2
14668        e(i2)=amn
14669        lb(i1)=5
14670        e(i1)=ap1
14671        go to 40
14672        Else
14673        lb(i2)=1
14674        e(i2)=amn
14675        lb(i1)=4
14676        e(i1)=ap1
14677        go to 40
14678        endif
14679               endif
14680        endif
14681 *(14) for N*(1440) or N*(1535)(+)+rho(-)-->pi(0)+n or pi(-)+p
14682        if( ((lb(i1).eq.11.and.lb(i2).eq.25).
14683      &  or.(lb(i1).eq.25.and.lb(i2).eq.11).
14684      &  or.(lb(i1).eq.25.and.lb(i2).eq.13).
14685      &  or.(lb(i2).eq.25.and.lb(i1).eq.13))
14686      &        .OR.((lb(i1).eq.-11.and.lb(i2).eq.27).
14687      &  or.(lb(i1).eq.27.and.lb(i2).eq.-11).
14688      &  or.(lb(i1).eq.27.and.lb(i2).eq.-13).
14689      &  or.(lb(i2).eq.27.and.lb(i1).eq.-13)) )then
14690        if(iabs(lb(i1)).eq.11.or.iabs(lb(i1)).eq.13)then
14691         ii = i1
14692        IF(X2.LE.0.5)THEN
14693        lb(i1)=2
14694        e(i1)=amn
14695        lb(i2)=4
14696        e(i2)=ap1
14697        go to 40
14698        ELSE
14699        lb(i1)=1
14700        e(i1)=amn
14701        lb(i2)=3
14702        e(i2)=ap1
14703        go to 40
14704        endif
14705               else
14706         ii = i2
14707        IF(X2.LE.0.5)THEN
14708        lb(i2)=2
14709        e(i2)=amn
14710        lb(i1)=4
14711        e(i1)=ap1
14712        go to 40
14713        ELSE
14714        lb(i2)=1
14715        e(i2)=amn
14716        lb(i1)=3
14717        e(i1)=ap1
14718        go to 40
14719        endif
14720               endif
14721        ENDIF
14722 *(15) N*(1440) or N*(1535)(0)+rho(+)-->n+pi(+) or p+pi(0)
14723        if( ((lb(i1).eq.10.and.lb(i2).eq.27).
14724      &  or.(lb(i1).eq.27.and.lb(i2).eq.10).
14725      &  or.(lb(i1).eq.12.and.lb(i2).eq.27).
14726      &  or.(lb(i1).eq.27.and.lb(i2).eq.12))
14727      &         .OR.((lb(i1).eq.-10.and.lb(i2).eq.25).
14728      &  or.(lb(i1).eq.25.and.lb(i2).eq.-10).
14729      &  or.(lb(i1).eq.-12.and.lb(i2).eq.25).
14730      &  or.(lb(i1).eq.25.and.lb(i2).eq.-12)) )then
14731        if(iabs(lb(i1)).eq.10.or.iabs(lb(i1)).eq.12)then
14732         ii = i1
14733        IF(X2.LE.0.5)THEN
14734        lb(i1)=2
14735        e(i1)=amn
14736        lb(i2)=5
14737        e(i2)=ap1
14738        go to 40
14739        else
14740        lb(i1)=1
14741        e(i1)=amn
14742        lb(i2)=4
14743        e(i2)=ap1
14744        go to 40
14745        endif
14746               else
14747         ii = i2
14748        IF(X2.LE.0.5)THEN
14749        lb(i2)=2
14750        e(i2)=amn
14751        lb(i1)=5
14752        e(i1)=ap1
14753        go to 40
14754        Else
14755        lb(i2)=1
14756        e(i2)=amn
14757        lb(i1)=4
14758        e(i1)=ap1
14759        go to 40
14760        endif
14761               endif
14762        ENDIF
14763 *(16) for N*(1440) or N*(1535) (0)+rho(-)-->n+pi(-)
14764        if( ((lb(i1).eq.10.and.lb(i2).eq.25).
14765      &  or.(lb(i1).eq.25.and.lb(i2).eq.10).
14766      &  or.(lb(i1).eq.25.and.lb(i2).eq.12).
14767      &  or.(lb(i1).eq.12.and.lb(i2).eq.25))
14768      &       .OR. ((lb(i1).eq.-10.and.lb(i2).eq.27).
14769      &  or.(lb(i1).eq.27.and.lb(i2).eq.-10).
14770      &  or.(lb(i1).eq.27.and.lb(i2).eq.-12).
14771      &  or.(lb(i1).eq.-12.and.lb(i2).eq.27)) )then
14772        if(iabs(lb(i1)).eq.10.or.iabs(lb(i1)).eq.12)then
14773         ii = i1
14774        lb(i1)=2
14775        e(i1)=amn
14776        lb(i2)=3
14777        e(i2)=ap1
14778        go to 40
14779        else
14780         ii = i2
14781        lb(i2)=2
14782        e(i2)=amn
14783        lb(i1)=3
14784        e(i1)=ap1
14785        go to 40
14786        ENDIF
14787        endif
14788 60       IBLOCK=82
14789 * FOR OMEGA REABSORPTION
14790 * Relable particles, I1 is assigned to the Delta
14791 * and I2 is assigned to the meson
14792 * for the reverse of the following process
14793 *(1) for D(0)+OMEGA(0)-->n+pi(0) or p+pi(-)
14794        if((iabs(lb(i1)).eq.7.and.lb(i2).eq.28).
14795      &  or.(lb(i1).eq.28.and.iabs(lb(i2)).eq.7))then
14796               if(iabs(lb(i1)).eq.7)then
14797         ii = i1
14798        IF(X2.LE.0.5)THEN
14799        lb(i1)=2
14800        e(i1)=amn
14801        lb(i2)=4
14802        e(i2)=ap1
14803        go to 40
14804        Else
14805        lb(i1)=1
14806        e(i1)=amn
14807        lb(i2)=3
14808        e(i2)=ap1
14809        go to 40
14810        endif
14811               else
14812         ii = i2
14813        IF(X2.LE.0.5)THEN
14814        lb(i2)=2
14815        e(i2)=amn
14816        lb(i1)=4
14817        e(i1)=ap1
14818        go to 40
14819        Else
14820        lb(i2)=1
14821        e(i2)=amn
14822        lb(i1)=3
14823        e(i1)=ap1
14824        go to 40
14825        endif
14826               endif
14827        endif
14828 *(2) for D(+)+OMEGA(0)-->pi(+)+n or pi(0)+p
14829        if((iabs(lb(i1)).eq.8.and.lb(i2).eq.28).
14830      &  or.(lb(i1).eq.28.and.iabs(lb(i2)).eq.8))then
14831               if(iabs(lb(i1)).eq.8)then
14832         ii = i1
14833        IF(X2.LE.0.5)THEN
14834        lb(i1)=2
14835        e(i1)=amn
14836        lb(i2)=5
14837        e(i2)=ap1
14838        go to 40
14839        Else
14840        lb(i1)=1
14841        e(i1)=amn
14842        lb(i2)=4
14843        e(i2)=ap1
14844        go to 40
14845        endif
14846               else
14847         ii = i2
14848        IF(X2.LE.0.5)THEN
14849        lb(i2)=2
14850        e(i2)=amn
14851        lb(i1)=5
14852        e(i1)=ap1
14853        go to 40
14854        Else
14855        lb(i2)=1
14856        e(i2)=amn
14857        lb(i1)=4
14858        e(i1)=ap1
14859        go to 40
14860        endif
14861               endif
14862        endif
14863 *(3) for D(-)+OMEGA(0)-->n+pi(-)
14864        if((iabs(lb(i1)).eq.6.and.lb(i2).eq.28).
14865      &  or.(lb(i1).eq.28.and.iabs(lb(i2)).eq.6))then
14866               if(iabs(lb(i1)).eq.6)then
14867         ii = i1
14868        lb(i1)=2
14869        e(i1)=amn
14870        lb(i2)=3
14871        e(i2)=ap1
14872        go to 40
14873        else
14874         ii = i2
14875        lb(i2)=2
14876        e(i2)=amn
14877        lb(i1)=3
14878        e(i1)=ap1
14879        go to 40
14880        ENDIF
14881        endif
14882 *(4) for D(++)+OMEGA(0)-->p+pi(+)
14883        if((iabs(lb(i1)).eq.9.and.lb(i2).eq.28).
14884      &  or.(lb(i1).eq.28.and.iabs(lb(i2)).eq.9))then
14885               if(iabs(lb(i1)).eq.9)then
14886         ii = i1
14887        lb(i1)=1
14888        e(i1)=amn
14889        lb(i2)=5
14890        e(i2)=ap1
14891        go to 40
14892        else
14893         ii = i2
14894        lb(i2)=1
14895        e(i2)=amn
14896        lb(i1)=5
14897        e(i1)=ap1
14898        go to 40
14899        ENDIF
14900        endif
14901 *(5) for N*(1440) or N*(1535)(0)+omega(0)-->n+pi(0) or p+pi(-)
14902        if((iabs(lb(i1)).eq.10.and.lb(i2).eq.28).
14903      &  or.(lb(i1).eq.28.and.iabs(lb(i2)).eq.10).
14904      &  or.(lb(i1).eq.28.and.iabs(lb(i2)).eq.12).
14905      &  or.(lb(i2).eq.28.and.iabs(lb(i1)).eq.12))then
14906               if(iabs(lb(i1)).eq.10.or.iabs(lb(i1)).eq.12)then
14907         ii = i1
14908        IF(X2.LE.0.5)THEN
14909        lb(i1)=2
14910        e(i1)=amn
14911        lb(i2)=4
14912        e(i2)=ap1
14913        go to 40
14914        Else
14915        lb(i1)=1
14916        e(i1)=amn
14917        lb(i2)=3
14918        e(i2)=ap1
14919        go to 40
14920        endif
14921               else
14922         ii = i2
14923        IF(X2.LE.0.5)THEN
14924        lb(i2)=2
14925        e(i2)=amn
14926        lb(i1)=4
14927        e(i1)=ap1
14928        go to 40
14929        Else
14930        lb(i2)=1
14931        e(i2)=amn
14932        lb(i1)=3
14933        e(i1)=ap1
14934        go to 40
14935        endif
14936               endif
14937        endif
14938 *(6) for N*(1440) or N*(1535)(+)+omega(0)-->pi(+)+n or pi(0)+p
14939        if((iabs(lb(i1)).eq.11.and.lb(i2).eq.28).
14940      &  or.(lb(i1).eq.28.and.iabs(lb(i2)).eq.11).
14941      &  or.(lb(i1).eq.28.and.iabs(lb(i2)).eq.13).
14942      &  or.(lb(i2).eq.28.and.iabs(lb(i1)).eq.13))then
14943               if(iabs(lb(i1)).eq.11.or.iabs(lb(i1)).eq.13)then
14944         ii = i1
14945        IF(X2.LE.0.5)THEN
14946        lb(i1)=2
14947        e(i1)=amn
14948        lb(i2)=5
14949        e(i2)=ap1
14950        go to 40
14951        Else
14952        lb(i1)=1
14953        e(i1)=amn
14954        lb(i2)=4
14955        e(i2)=ap1
14956        go to 40
14957        endif
14958               else
14959         ii = i2
14960        IF(X2.LE.0.5)THEN
14961        lb(i2)=2
14962        e(i2)=amn
14963        lb(i1)=5
14964        e(i1)=ap1
14965        go to 40
14966        Else
14967        lb(i2)=1
14968        e(i2)=amn
14969        lb(i1)=4
14970        e(i1)=ap1
14971        go to 40
14972        endif
14973               endif
14974        endif
14975 40       em1=e(i1)
14976        em2=e(i2)
14977        if(ianti.eq.1 .and. lb(i1).ge.1 .and. lb(i2).ge.1)then
14978          lb(ii) = -lb(ii)
14979            jj = i2
14980           if(ii .eq. i2)jj = i1
14981           if(lb(jj).eq.3)then
14982            lb(jj) = 5
14983           elseif(lb(jj).eq.5)then
14984            lb(jj) = 3
14985           endif
14986          endif
14987        endif
14988 *-----------------------------------------------------------------------
14989 * CALCULATE THE MAGNITUDE OF THE FINAL MOMENTUM THROUGH
14990 * ENERGY CONSERVATION
14991 50          PR2   = (SRT**2 - EM1**2 - EM2**2)**2
14992      1                - 4.0 * (EM1*EM2)**2
14993           IF(PR2.LE.0.)PR2=1.E-09
14994           PR=SQRT(PR2)/(2.*SRT)
14995 *          C1   = 1.0 - 2.0 * RANART(NSEED)
14996
14997 clin-10/25/02 get rid of argument usage mismatch in PTR():
14998           xptr=0.33*pr
14999 c         cc1=ptr(0.33*pr,iseed)
15000          cc1=ptr(xptr,iseed)
15001 clin-10/25/02-end
15002
15003          c1=sqrt(pr**2-cc1**2)/pr
15004           T1   = 2.0 * PI * RANART(NSEED)
15005       S1   = SQRT( 1.0 - C1**2 )
15006       CT1  = COS(T1)
15007       ST1  = SIN(T1)
15008       PZ   = PR * C1
15009       PX   = PR * S1*CT1
15010       PY   = PR * S1*ST1
15011 * ROTATE THE MOMENTUM
15012        CALL ROTATE(PX0,PY0,PZ0,PX,PY,PZ)
15013       RETURN
15014       END
15015 **********************************
15016 * sp 03/19/01                                                          *
15017 *                                                                      *
15018         SUBROUTINE Crlaba(PX,PY,PZ,SRT,brel,brsgm,
15019      &                        I1,I2,nt,IBLOCK,nchrg,icase)
15020 *     PURPOSE:                                                         *
15021 *            DEALING WITH   K+ + N(D,N*)-bar <-->  La(Si)-bar + pi     *
15022 *     NOTE   :                                                         *
15023 *                                                                      *
15024 *     QUANTITIES:                                                 *
15025 *           PX,PY,PZ - MOMENTUM COORDINATES OF ONE PARTICLE IN CM FRAME*
15026 *           SRT      - SQRT OF S                                       *
15027 *           IBLOCK   - THE INFORMATION BACK                            *
15028 *                     8-> elastic scatt                               *
15029 *                     100-> K+ + N-bar -> Sigma-bar + PI
15030 *                     102-> PI + Sigma(Lambda)-bar -> K+ + N-bar
15031 **********************************
15032         PARAMETER (MAXSTR=150001, MAXR=1, AMN=0.939457,
15033      1  AMP=0.93828,AP1=0.13496,
15034      2  AP2=0.13957,AM0=1.232,PI=3.1415926,CUTOFF=1.8966,AVMASS=0.9383)
15035         PARAMETER  (AKA=0.498,ALA=1.1157,ASA=1.1974)
15036         PARAMETER  (ETAM=0.5475, AOMEGA=0.782, ARHO=0.77)
15037         COMMON /AA/ R(3,MAXSTR)
15038 cc      SAVE /AA/
15039         COMMON /BB/ P(3,MAXSTR)
15040 cc      SAVE /BB/
15041         COMMON /CC/ E(MAXSTR)
15042 cc      SAVE /CC/
15043         COMMON /EE/ ID(MAXSTR),LB(MAXSTR)
15044 cc      SAVE /EE/
15045         common/input1/ MASSPR,MASSTA,ISEED,IAVOID,DT
15046 cc      SAVE /input1/
15047       COMMON/RNDF77/NSEED
15048 cc      SAVE /RNDF77/
15049       SAVE
15050       NT=NT
15051 c
15052       PX0=PX
15053       PY0=PY
15054       PZ0=PZ
15055 c
15056       if(icase .eq. 3)then
15057          rrr=RANART(NSEED)
15058          if(rrr.lt.brel) then
15059 c            !! elastic scat.  (avoid in reverse process)
15060             IBLOCK=8
15061         else
15062             IBLOCK=100
15063             if(rrr.lt.(brel+brsgm)) then
15064 c*    K+ + N-bar -> Sigma-bar + PI
15065                LB(i1) = -15 - int(3 * RANART(NSEED))
15066
15067                e(i1)=asa
15068             else
15069 c*    K+ + N-bar -> Lambda-bar + PI
15070                LB(i1)= -14
15071                e(i1)=ala
15072             endif
15073             LB(i2) = 3 + int(3 * RANART(NSEED))
15074             e(i2)=0.138
15075         endif
15076       endif
15077 c
15078 c
15079       if(icase .eq. 4)then
15080          rrr=RANART(NSEED)
15081          if(rrr.lt.brel) then
15082 c            !! elastic scat.
15083             IBLOCK=8
15084          else
15085             IBLOCK=102
15086 c    PI + Sigma(Lambda)-bar -> K+ + N-bar
15087 c         ! K+
15088             LB(i1) = 23
15089             LB(i2) = -1 - int(2 * RANART(NSEED))
15090             if(nchrg.eq.-2) LB(i2) = -6
15091             if(nchrg.eq. 1) LB(i2) = -9
15092             e(i1) = aka
15093             e(i2) = 0.938
15094             if(nchrg.eq.-2.or.nchrg.eq.1) e(i2)=1.232
15095          endif
15096       endif
15097 c
15098       EM1=E(I1)
15099       EM2=E(I2)
15100 * CALCULATE THE MAGNITUDE OF THE FINAL MOMENTUM THROUGH
15101 * ENERGY CONSERVATION
15102       PR2   = (SRT**2 - EM1**2 - EM2**2)**2
15103      1     - 4.0 * (EM1*EM2)**2
15104       IF(PR2.LE.0.)PR2=1.e-09
15105       PR=SQRT(PR2)/(2.*SRT)
15106       C1   = 1.0 - 2.0 * RANART(NSEED)
15107       T1   = 2.0 * PI * RANART(NSEED)
15108       S1   = SQRT( 1.0 - C1**2 )
15109       CT1  = COS(T1)
15110       ST1  = SIN(T1)
15111       PZ   = PR * C1
15112       PX   = PR * S1*CT1
15113       PY   = PR * S1*ST1
15114 * ROTATE IT
15115       CALL ROTATE(PX0,PY0,PZ0,PX,PY,PZ)
15116       RETURN
15117       END
15118 **********************************
15119 *                                                                      *
15120 *                                                                      *
15121       SUBROUTINE Crkn(PX,PY,PZ,SRT,I1,I2,IBLOCK)
15122 *     PURPOSE:                                                         *
15123 *             DEALING WITH kaON+N/pi-->KAON +N/pi elastic PROCESS      *
15124 *     NOTE   :                                                         *
15125 *
15126 *     QUANTITIES:                                                 *
15127 *           PX,PY,PZ - MOMENTUM COORDINATES OF ONE PARTICLE IN CM FRAME*
15128 *           SRT      - SQRT OF S                                       *
15129 *           IBLOCK   - THE INFORMATION BACK                            *
15130 *                     8-> PION+N-->L/S+KAON
15131 **********************************
15132         PARAMETER (MAXSTR=150001,MAXR=1,AMN=0.939457,
15133      1  AMP=0.93828,AP1=0.13496,
15134      2  AP2=0.13957,AM0=1.232,PI=3.1415926,CUTOFF=1.8966,AVMASS=0.9383)
15135         PARAMETER      (AKA=0.498,ALA=1.1157,ASA=1.1974)
15136         parameter     (MX=4,MY=4,MZ=8,MPX=4,MPY=4,mpz=10,mpzp=10)
15137         COMMON /AA/ R(3,MAXSTR)
15138 cc      SAVE /AA/
15139         COMMON /BB/ P(3,MAXSTR)
15140 cc      SAVE /BB/
15141         COMMON /CC/ E(MAXSTR)
15142 cc      SAVE /CC/
15143         COMMON /EE/ ID(MAXSTR),LB(MAXSTR)
15144 cc      SAVE /EE/
15145         common/input1/ MASSPR,MASSTA,ISEED,IAVOID,DT
15146 cc      SAVE /input1/
15147       COMMON/RNDF77/NSEED
15148 cc      SAVE /RNDF77/
15149       SAVE
15150
15151        PX0=PX
15152        PY0=PY
15153        PZ0=PZ
15154 *-----------------------------------------------------------------------
15155         IBLOCK=8
15156         NTAG=0
15157         EM1=E(I1)
15158         EM2=E(I2)
15159 *-----------------------------------------------------------------------
15160 * CALCULATE THE MAGNITUDE OF THE FINAL MOMENTUM THROUGH
15161 * ENERGY CONSERVATION
15162           PR2   = (SRT**2 - EM1**2 - EM2**2)**2
15163      1                - 4.0 * (EM1*EM2)**2
15164           IF(PR2.LE.0.)PR2=1.e-09
15165           PR=SQRT(PR2)/(2.*SRT)
15166           C1   = 1.0 - 2.0 * RANART(NSEED)
15167           T1   = 2.0 * PI * RANART(NSEED)
15168       S1   = SQRT( 1.0 - C1**2 )
15169       CT1  = COS(T1)
15170       ST1  = SIN(T1)
15171       PZ   = PR * C1
15172       PX   = PR * S1*CT1
15173       PY   = PR * S1*ST1
15174       RETURN
15175       END
15176 **********************************
15177 *                                                                      *
15178 *                                                                      *
15179       SUBROUTINE Crppba(PX,PY,PZ,SRT,I1,I2,IBLOCK)
15180 *     PURPOSE:                                                         *
15181
15182 clin-8/29/00*             DEALING WITH anti-nucleon annihilation with
15183 *             DEALING WITH anti-baryon annihilation with
15184
15185 *             nucleons or baryon resonances
15186 *             Determine:                                               *
15187 *             (1) no. of pions in the final state
15188 *             (2) relable particles in the final state
15189 *             (3) new momenta of final state particles                 *
15190 *
15191 *     QUANTITIES:                                                      *
15192 *           PX,PY,PZ - MOMENTUM COORDINATES OF ONE PARTICLE IN CM FRAME*
15193 *           SRT      - SQRT OF S                                       *
15194 *           IBLOCK   - INFORMATION about the reaction channel          *
15195 *
15196 *           iblock   - 1902 annihilation-->pion(+)+pion(-)   (2 pion)
15197 *           iblock   - 1903 annihilation-->pion(+)+rho(-)    (3 pion)
15198 *           iblock   - 1904 annihilation-->rho(+)+rho(-)     (4 pion)
15199 *           iblock   - 1905 annihilation-->rho(0)+omega      (5 pion)
15200 *           iblock   - 1906 annihilation-->omega+omega       (6 pion)
15201 *       charge conservation is enforced in relabling particles
15202 *       in the final state (note: at the momentum we don't check the
15203 *       initial charges while dealing with annihilation, since some
15204 *       annihilation channels between antinucleons and nucleons (baryon
15205 *       resonances) might be forbiden by charge conservation, this effect
15206 *       should be small, but keep it in mind.
15207 **********************************
15208         PARAMETER (MAXSTR=150001,MAXR=1,AMN=0.939457,
15209      1  AMP=0.93828,AP1=0.13496,AMRHO=0.769,AMOMGA=0.782,
15210      2  AP2=0.13957,AM0=1.232,PI=3.1415926,CUTOFF=1.8966,AVMASS=0.9383)
15211         PARAMETER      (AKA=0.498,ALA=1.1157,ASA=1.1974)
15212         parameter     (MX=4,MY=4,MZ=8,MPX=4,MPY=4,mpz=10,mpzp=10)
15213         COMMON /AA/ R(3,MAXSTR)
15214 cc      SAVE /AA/
15215         COMMON /BB/ P(3,MAXSTR)
15216 cc      SAVE /BB/
15217         COMMON /CC/ E(MAXSTR)
15218 cc      SAVE /CC/
15219         COMMON /EE/ ID(MAXSTR),LB(MAXSTR)
15220 cc      SAVE /EE/
15221         common/input1/ MASSPR,MASSTA,ISEED,IAVOID,DT
15222 cc      SAVE /input1/
15223       COMMON/RNDF77/NSEED
15224 cc      SAVE /RNDF77/
15225       SAVE
15226
15227        PX0=PX
15228        PY0=PY
15229        PZ0=PZ
15230 * determine the no. of pions in the final state using a
15231 * statistical model
15232        call pbarfs(srt,npion,iseed)
15233 * find the masses of the final state particles before calculate
15234 * their momenta, and relable them. The masses of rho and omega
15235 * will be generated according to the Breit Wigner formula       (NOTE!!!
15236 * NOT DONE YET, AT THE MOMENT LET US USE FIXED RHO AND OMEGA MAEES)
15237 cbali2/22/99
15238 * Here we generate two stes of integer random numbers (3,4,5)
15239 * one or both of them are used directly as the lables of pions
15240 * similarly, 22+nchrg1 and 22+nchrg2 are used directly
15241 * to label rhos
15242        nchrg1=3+int(3*RANART(NSEED))
15243        nchrg2=3+int(3*RANART(NSEED))
15244 * the corresponding masses of pions
15245       pmass1=ap1
15246        pmass2=ap1
15247        if(nchrg1.eq.3.or.nchrg1.eq.5)pmass1=ap2
15248        if(nchrg2.eq.3.or.nchrg2.eq.5)pmass2=ap2
15249 * (1) for 2 pion production
15250        IF(NPION.EQ.2)THEN
15251        IBLOCK=1902
15252 * randomly generate the charges of final state particles,
15253        LB(I1)=nchrg1
15254        E(I1)=pmass1
15255        LB(I2)=nchrg2
15256        E(I2)=pmass2
15257 * TO CALCULATE THE FINAL MOMENTA
15258        GO TO 50
15259        ENDIF
15260 * (2) FOR 3 PION PRODUCTION
15261        IF(NPION.EQ.3)THEN
15262        IBLOCK=1903
15263        LB(I1)=nchrg1
15264        E(I1)=pmass1
15265        LB(I2)=22+nchrg2
15266             E(I2)=AMRHO
15267        GO TO 50
15268        ENDIF
15269 * (3) FOR 4 PION PRODUCTION
15270 * we allow both rho+rho and pi+omega with 50-50% probability
15271         IF(NPION.EQ.4)THEN
15272        IBLOCK=1904
15273 * determine rho+rho or pi+omega
15274        if(RANART(NSEED).ge.0.5)then
15275 * rho+rho
15276        LB(I1)=22+nchrg1
15277        E(I1)=AMRHO
15278        LB(I2)=22+nchrg2
15279             E(I2)=AMRHO
15280        else
15281 * pion+omega
15282        LB(I1)=nchrg1
15283        E(I1)=pmass1
15284        LB(I2)=28
15285             E(I2)=AMOMGA
15286        endif
15287        GO TO 50
15288        ENDIF
15289 * (4) FOR 5 PION PRODUCTION
15290         IF(NPION.EQ.5)THEN
15291        IBLOCK=1905
15292 * RHO AND OMEGA
15293         LB(I1)=22+nchrg1
15294        E(I1)=AMRHO
15295        LB(I2)=28
15296        E(I2)=AMOMGA
15297        GO TO 50
15298        ENDIF
15299 * (5) FOR 6 PION PRODUCTION
15300          IF(NPION.EQ.6)THEN
15301        IBLOCK=1906
15302 * OMEGA AND OMEGA
15303         LB(I1)=28
15304        E(I1)=AMOMGA
15305        LB(I2)=28
15306           E(I2)=AMOMGA
15307        ENDIF
15308 cbali2/22/99
15309 50    EM1=E(I1)
15310       EM2=E(I2)
15311 *-----------------------------------------------------------------------
15312 * CALCULATE THE MAGNITUDE OF THE FINAL MOMENTUM THROUGH
15313 * ENERGY CONSERVATION
15314           PR2   = (SRT**2 - EM1**2 - EM2**2)**2
15315      1                - 4.0 * (EM1*EM2)**2
15316           IF(PR2.LE.0.)PR2=1.E-08
15317           PR=SQRT(PR2)/(2.*SRT)
15318 * WE ASSUME AN ISOTROPIC ANGULAR DISTRIBUTION IN THE CMS
15319           C1   = 1.0 - 2.0 * RANART(NSEED)
15320           T1   = 2.0 * PI * RANART(NSEED)
15321       S1   = SQRT( 1.0 - C1**2 )
15322       CT1  = COS(T1)
15323       ST1  = SIN(T1)
15324 * THE MOMENTUM IN THE CMS IN THE FINAL STATE
15325       PZ   = PR * C1
15326       PX   = PR * S1*CT1
15327       PY   = PR * S1*ST1
15328 * ROTATE IT
15329        CALL ROTATE(PX0,PY0,PZ0,PX,PY,PZ)
15330       RETURN
15331       END
15332 cbali2/7/99end
15333 cbali3/5/99
15334 **********************************
15335 *     PURPOSE:                                                         *
15336 *     assign final states for K+K- --> light mesons
15337 *
15338       SUBROUTINE crkkpi(I1,I2,XSK1, XSK2, XSK3, XSK4,
15339      &             XSK5, XSK6, XSK7, XSK8, XSK9, XSK10, XSK11, SIGK,
15340      &             IBLOCK,lbp1,lbp2,emm1,emm2)
15341 *
15342 *     QUANTITIES:                                                     *
15343 *           IBLOCK   - INFORMATION about the reaction channel          *
15344 *
15345 *             iblock   - 1907
15346 **********************************
15347         PARAMETER (MAXSTR=150001,MAXR=1,AMN=0.939457,
15348      1  AMP=0.93828,AP1=0.13496,AMRHO=0.769,AMOMGA=0.782,
15349      &  AMETA = 0.5473,
15350      2  AP2=0.13957,AM0=1.232,PI=3.1415926,CUTOFF=1.8966,AVMASS=0.9383)
15351         PARAMETER      (AKA=0.498,ALA=1.1157,ASA=1.1974)
15352         parameter     (MX=4,MY=4,MZ=8,MPX=4,MPY=4,mpz=10,mpzp=10)
15353         COMMON /AA/ R(3,MAXSTR)
15354 cc      SAVE /AA/
15355         COMMON /BB/ P(3,MAXSTR)
15356 cc      SAVE /BB/
15357         COMMON /CC/ E(MAXSTR)
15358 cc      SAVE /CC/
15359         COMMON /EE/ ID(MAXSTR),LB(MAXSTR)
15360 cc      SAVE /EE/
15361         common/input1/ MASSPR,MASSTA,ISEED,IAVOID,DT
15362 cc      SAVE /input1/
15363       COMMON/RNDF77/NSEED
15364 cc      SAVE /RNDF77/
15365       SAVE
15366
15367         XSK11=XSK11
15368         IBLOCK=1907
15369         X1 = RANART(NSEED) * SIGK
15370         XSK2 = XSK1 + XSK2
15371         XSK3 = XSK2 + XSK3
15372         XSK4 = XSK3 + XSK4
15373         XSK5 = XSK4 + XSK5
15374         XSK6 = XSK5 + XSK6
15375         XSK7 = XSK6 + XSK7
15376         XSK8 = XSK7 + XSK8
15377         XSK9 = XSK8 + XSK9
15378         XSK10 = XSK9 + XSK10
15379         IF (X1 .LE. XSK1) THEN
15380            LB(I1) = 3 + int(3 * RANART(NSEED))
15381            LB(I2) = 3 + int(3 * RANART(NSEED))
15382            E(I1) = AP2
15383            E(I2) = AP2
15384            GOTO 100
15385         ELSE IF (X1 .LE. XSK2) THEN
15386            LB(I1) = 3 + int(3 * RANART(NSEED))
15387            LB(I2) = 25 + int(3 * RANART(NSEED))
15388            E(I1) = AP2
15389            E(I2) = AMRHO
15390            GOTO 100
15391         ELSE IF (X1 .LE. XSK3) THEN
15392            LB(I1) = 3 + int(3 * RANART(NSEED))
15393            LB(I2) = 28
15394            E(I1) = AP2
15395            E(I2) = AMOMGA
15396            GOTO 100
15397         ELSE IF (X1 .LE. XSK4) THEN
15398            LB(I1) = 3 + int(3 * RANART(NSEED))
15399            LB(I2) = 0
15400            E(I1) = AP2
15401            E(I2) = AMETA
15402            GOTO 100
15403         ELSE IF (X1 .LE. XSK5) THEN
15404            LB(I1) = 25 + int(3 * RANART(NSEED))
15405            LB(I2) = 25 + int(3 * RANART(NSEED))
15406            E(I1) = AMRHO
15407            E(I2) = AMRHO
15408            GOTO 100
15409         ELSE IF (X1 .LE. XSK6) THEN
15410            LB(I1) = 25 + int(3 * RANART(NSEED))
15411            LB(I2) = 28
15412            E(I1) = AMRHO
15413            E(I2) = AMOMGA
15414            GOTO 100
15415         ELSE IF (X1 .LE. XSK7) THEN
15416            LB(I1) = 25 + int(3 * RANART(NSEED))
15417            LB(I2) = 0
15418            E(I1) = AMRHO
15419            E(I2) = AMETA
15420            GOTO 100
15421         ELSE IF (X1 .LE. XSK8) THEN
15422            LB(I1) = 28
15423            LB(I2) = 28
15424            E(I1) = AMOMGA
15425            E(I2) = AMOMGA
15426            GOTO 100
15427         ELSE IF (X1 .LE. XSK9) THEN
15428            LB(I1) = 28
15429            LB(I2) = 0
15430            E(I1) = AMOMGA
15431            E(I2) = AMETA
15432            GOTO 100
15433         ELSE IF (X1 .LE. XSK10) THEN
15434            LB(I1) = 0
15435            LB(I2) = 0
15436            E(I1) = AMETA
15437            E(I2) = AMETA
15438         ELSE
15439           iblock = 222
15440           call rhores(i1,i2)
15441 c     !! phi
15442           lb(i1) = 29
15443 c          return
15444           e(i2)=0.
15445         END IF
15446
15447  100    CONTINUE
15448         lbp1=lb(i1)
15449         lbp2=lb(i2)
15450         emm1=e(i1)
15451         emm2=e(i2)
15452
15453       RETURN
15454       END
15455 **********************************
15456 *     PURPOSE:                                                         *
15457 *             DEALING WITH K+Y -> piN scattering
15458 *
15459       SUBROUTINE Crkhyp(PX,PY,PZ,SRT,I1,I2,
15460      &     XKY1, XKY2, XKY3, XKY4, XKY5,
15461      &     XKY6, XKY7, XKY8, XKY9, XKY10, XKY11, XKY12, XKY13,
15462      &     XKY14, XKY15, XKY16, XKY17, SIGK, IKMP,
15463      &     IBLOCK)
15464 *
15465 *             Determine:                                               *
15466 *             (1) relable particles in the final state                 *
15467 *             (2) new momenta of final state particles                 *
15468 *                                                                        *
15469 *     QUANTITIES:                                                    *
15470 *           PX,PY,PZ - MOMENTUM COORDINATES OF ONE PARTICLE IN CM FRAME*
15471 *           SRT      - SQRT OF S                                       *
15472 *           IBLOCK   - INFORMATION about the reaction channel          *
15473 *                                                                     *
15474 *             iblock   - 1908                                          *
15475 *             iblock   - 222   !! phi                                  *
15476 **********************************
15477         PARAMETER (MAXSTR=150001,MAXR=1,AMN=0.939457,
15478      1  AMP=0.93828,AP1=0.13496,AMRHO=0.769,AMOMGA=0.782,APHI=1.02,
15479      2  AP2=0.13957,AM0=1.232,PI=3.1415926,CUTOFF=1.8966,AVMASS=0.9383)
15480           parameter (pimass=0.140, AMETA = 0.5473, aka=0.498,
15481      &     aml=1.116,ams=1.193, AM1440 = 1.44, AM1535 = 1.535)
15482         parameter     (MX=4,MY=4,MZ=8,MPX=4,MPY=4,mpz=10,mpzp=10)
15483         COMMON /AA/ R(3,MAXSTR)
15484 cc      SAVE /AA/
15485         COMMON /BB/ P(3,MAXSTR)
15486 cc      SAVE /BB/
15487         COMMON /CC/ E(MAXSTR)
15488 cc      SAVE /CC/
15489         COMMON /EE/ ID(MAXSTR),LB(MAXSTR)
15490 cc      SAVE /EE/
15491         common/input1/ MASSPR,MASSTA,ISEED,IAVOID,DT
15492 cc      SAVE /input1/
15493       COMMON/RNDF77/NSEED
15494 cc      SAVE /RNDF77/
15495       SAVE
15496
15497        XKY17=XKY17
15498        PX0=PX
15499        PY0=PY
15500        PZ0=PZ
15501        IBLOCK=1908
15502 c
15503         X1 = RANART(NSEED) * SIGK
15504         XKY2 = XKY1 + XKY2
15505         XKY3 = XKY2 + XKY3
15506         XKY4 = XKY3 + XKY4
15507         XKY5 = XKY4 + XKY5
15508         XKY6 = XKY5 + XKY6
15509         XKY7 = XKY6 + XKY7
15510         XKY8 = XKY7 + XKY8
15511         XKY9 = XKY8 + XKY9
15512         XKY10 = XKY9 + XKY10
15513         XKY11 = XKY10 + XKY11
15514         XKY12 = XKY11 + XKY12
15515         XKY13 = XKY12 + XKY13
15516         XKY14 = XKY13 + XKY14
15517         XKY15 = XKY14 + XKY15
15518         XKY16 = XKY15 + XKY16
15519         IF (X1 .LE. XKY1) THEN
15520            LB(I1) = 3 + int(3 * RANART(NSEED))
15521            LB(I2) = 1 + int(2 * RANART(NSEED))
15522            E(I1) = PIMASS
15523            E(I2) = AMP
15524            GOTO 100
15525         ELSE IF (X1 .LE. XKY2) THEN
15526            LB(I1) = 3 + int(3 * RANART(NSEED))
15527            LB(I2) = 6 + int(4 * RANART(NSEED))
15528            E(I1) = PIMASS
15529            E(I2) = AM0
15530            GOTO 100
15531         ELSE IF (X1 .LE. XKY3) THEN
15532            LB(I1) = 3 + int(3 * RANART(NSEED))
15533            LB(I2) = 10 + int(2 * RANART(NSEED))
15534            E(I1) = PIMASS
15535            E(I2) = AM1440
15536            GOTO 100
15537         ELSE IF (X1 .LE. XKY4) THEN
15538            LB(I1) = 3 + int(3 * RANART(NSEED))
15539            LB(I2) = 12 + int(2 * RANART(NSEED))
15540            E(I1) = PIMASS
15541            E(I2) = AM1535
15542            GOTO 100
15543         ELSE IF (X1 .LE. XKY5) THEN
15544            LB(I1) = 25 + int(3 * RANART(NSEED))
15545            LB(I2) = 1 + int(2 * RANART(NSEED))
15546            E(I1) = AMRHO
15547            E(I2) = AMP
15548            GOTO 100
15549         ELSE IF (X1 .LE. XKY6) THEN
15550            LB(I1) = 25 + int(3 * RANART(NSEED))
15551            LB(I2) = 6 + int(4 * RANART(NSEED))
15552            E(I1) = AMRHO
15553            E(I2) = AM0
15554            GOTO 100
15555         ELSE IF (X1 .LE. XKY7) THEN
15556            LB(I1) = 25 + int(3 * RANART(NSEED))
15557            LB(I2) = 10 + int(2 * RANART(NSEED))
15558            E(I1) = AMRHO
15559            E(I2) = AM1440
15560            GOTO 100
15561         ELSE IF (X1 .LE. XKY8) THEN
15562            LB(I1) = 25 + int(3 * RANART(NSEED))
15563            LB(I2) = 12 + int(2 * RANART(NSEED))
15564            E(I1) = AMRHO
15565            E(I2) = AM1535
15566            GOTO 100
15567         ELSE IF (X1 .LE. XKY9) THEN
15568            LB(I1) = 28
15569            LB(I2) = 1 + int(2 * RANART(NSEED))
15570            E(I1) = AMOMGA
15571            E(I2) = AMP
15572            GOTO 100
15573         ELSE IF (X1 .LE. XKY10) THEN
15574            LB(I1) = 28
15575            LB(I2) = 6 + int(4 * RANART(NSEED))
15576            E(I1) = AMOMGA
15577            E(I2) = AM0
15578            GOTO 100
15579         ELSE IF (X1 .LE. XKY11) THEN
15580            LB(I1) = 28
15581            LB(I2) = 10 + int(2 * RANART(NSEED))
15582            E(I1) = AMOMGA
15583            E(I2) = AM1440
15584            GOTO 100
15585         ELSE IF (X1 .LE. XKY12) THEN
15586            LB(I1) = 28
15587            LB(I2) = 12 + int(2 * RANART(NSEED))
15588            E(I1) = AMOMGA
15589            E(I2) = AM1535
15590            GOTO 100
15591         ELSE IF (X1 .LE. XKY13) THEN
15592            LB(I1) = 0
15593            LB(I2) = 1 + int(2 * RANART(NSEED))
15594            E(I1) = AMETA
15595            E(I2) = AMP
15596            GOTO 100
15597         ELSE IF (X1 .LE. XKY14) THEN
15598            LB(I1) = 0
15599            LB(I2) = 6 + int(4 * RANART(NSEED))
15600            E(I1) = AMETA
15601            E(I2) = AM0
15602            GOTO 100
15603         ELSE IF (X1 .LE. XKY15) THEN
15604            LB(I1) = 0
15605            LB(I2) = 10 + int(2 * RANART(NSEED))
15606            E(I1) = AMETA
15607            E(I2) = AM1440
15608            GOTO 100
15609         ELSE IF (X1 .LE. XKY16) THEN
15610            LB(I1) = 0
15611            LB(I2) = 12 + int(2 * RANART(NSEED))
15612            E(I1) = AMETA
15613            E(I2) = AM1535
15614            GOTO 100
15615         ELSE
15616            LB(I1) = 29
15617            LB(I2) = 1 + int(2 * RANART(NSEED))
15618            E(I1) = APHI
15619            E(I2) = AMN
15620           IBLOCK=222
15621            GOTO 100
15622         END IF
15623
15624  100    CONTINUE
15625          if(IKMP .eq. -1) LB(I2) = -LB(I2)
15626
15627       EM1=E(I1)
15628       EM2=E(I2)
15629 *-----------------------------------------------------------------------
15630 * CALCULATE THE MAGNITUDE OF THE FINAL MOMENTUM THROUGH
15631 * ENERGY CONSERVATION
15632           PR2   = (SRT**2 - EM1**2 - EM2**2)**2
15633      1                - 4.0 * (EM1*EM2)**2
15634           IF(PR2.LE.0.)PR2=1.E-08
15635           PR=SQRT(PR2)/(2.*SRT)
15636 * WE ASSUME AN ISOTROPIC ANGULAR DISTRIBUTION IN THE CMS
15637           C1   = 1.0 - 2.0 * RANART(NSEED)
15638           T1   = 2.0 * PI * RANART(NSEED)
15639       S1   = SQRT( 1.0 - C1**2 )
15640       CT1  = COS(T1)
15641       ST1  = SIN(T1)
15642 * THE MOMENTUM IN THE CMS IN THE FINAL STATE
15643       PZ   = PR * C1
15644       PX   = PR * S1*CT1
15645       PY   = PR * S1*ST1
15646 * ROTATE IT
15647        CALL ROTATE(PX0,PY0,PZ0,PX,PY,PZ)
15648       RETURN
15649       END
15650 **********************************
15651 *                                                                      *
15652 *                                                                      *
15653       SUBROUTINE CRLAN(PX,PY,PZ,SRT,I1,I2,IBLOCK)
15654 *     PURPOSE:                                                         *
15655 *      DEALING WITH La/Si-bar + N --> K+ + pi PROCESS                  *
15656 *                   La/Si + N-bar --> K- + pi                          *
15657 *     NOTE   :                                                         *
15658 *
15659 *     QUANTITIES:                                                      *
15660 *           PX,PY,PZ - MOMENTUM COORDINATES OF ONE PARTICLE IN CM FRAME*
15661 *           SRT      - SQRT OF S                                       *
15662 *           IBLOCK   - THE INFORMATION BACK                            *
15663 *                      71
15664 **********************************
15665         PARAMETER (MAXSTR=150001,MAXR=1,AMN=0.939457,
15666      1  AMP=0.93828,AP1=0.13496,
15667      2  AP2=0.13957,AM0=1.232,PI=3.1415926,CUTOFF=1.8966,AVMASS=0.9383)
15668         PARAMETER      (AKA=0.498,ALA=1.1157,ASA=1.1974)
15669         parameter     (MX=4,MY=4,MZ=8,MPX=4,MPY=4,mpz=10,mpzp=10)
15670         COMMON /AA/ R(3,MAXSTR)
15671 cc      SAVE /AA/
15672         COMMON /BB/ P(3,MAXSTR)
15673 cc      SAVE /BB/
15674         COMMON /CC/ E(MAXSTR)
15675 cc      SAVE /CC/
15676         COMMON /EE/ ID(MAXSTR),LB(MAXSTR)
15677 cc      SAVE /EE/
15678         common/input1/ MASSPR,MASSTA,ISEED,IAVOID,DT
15679 cc      SAVE /input1/
15680       COMMON/RNDF77/NSEED
15681 cc      SAVE /RNDF77/
15682       SAVE
15683
15684         PX0=PX
15685         PY0=PY
15686         PZ0=PZ
15687         IBLOCK=71
15688         NTAG=0
15689        if( (lb(i1).ge.14.and.lb(i1).le.17) .OR.
15690      &     (lb(i2).ge.14.and.lb(i2).le.17) )then
15691         LB(I1)=21
15692        else
15693         LB(I1)=23
15694        endif
15695         LB(I2)= 3 + int(3 * RANART(NSEED))
15696         E(I1)=AKA
15697         E(I2)=0.138
15698         EM1=E(I1)
15699         EM2=E(I2)
15700 *-----------------------------------------------------------------------
15701 * CALCULATE THE MAGNITUDE OF THE FINAL MOMENTUM THROUGH
15702 * ENERGY CONSERVATION
15703         PR2   = (SRT**2 - EM1**2 - EM2**2)**2
15704      1                - 4.0 * (EM1*EM2)**2
15705           IF(PR2.LE.0.)PR2=1.e-09
15706           PR=SQRT(PR2)/(2.*SRT)
15707           C1   = 1.0 - 2.0 * RANART(NSEED)
15708           T1   = 2.0 * PI * RANART(NSEED)
15709       S1   = SQRT( 1.0 - C1**2 )
15710       CT1  = COS(T1)
15711       ST1  = SIN(T1)
15712 * THE MOMENTUM IN THE CMS IN THE FINAL STATE
15713       PZ   = PR * C1
15714       PX   = PR * S1*CT1
15715       PY   = PR * S1*ST1
15716 * FOR THE ISOTROPIC DISTRIBUTION THERE IS NO NEED TO ROTATE
15717       RETURN
15718       END
15719 csp11/03/01 end
15720 **********************************
15721 **********************************
15722 *                                                                      *
15723 *                                                                      *
15724         SUBROUTINE Crkpla(PX,PY,PZ,EC,SRT,spika,
15725      &                  emm1,emm2,lbp1,lbp2,I1,I2,icase,srhoks)
15726
15727 *     PURPOSE:                                                         *
15728 *     DEALING WITH  K+ + Pi ---> La/Si-bar + B, phi+K, phi+K* OR  K* *
15729 *                   K- + Pi ---> La/Si + B-bar  OR   K*-bar          *
15730
15731 *     NOTE   :                                                         *
15732 *
15733 *     QUANTITIES:                                                      *
15734 *           PX,PY,PZ - MOMENTUM COORDINATES OF ONE PARTICLE IN CM FRAME*
15735 *           SRT      - SQRT OF S                                       *
15736 *           IBLOCK   - THE INFORMATION BACK                            *
15737 *                      71
15738 **********************************
15739         PARAMETER (MAXSTR=150001,MAXR=1,AMN=0.939457,
15740      1  AMP=0.93828,AP1=0.13496,AP2=0.13957,AMRHO=0.769,AMOMGA=0.782,
15741      2  AM0=1.232,PI=3.1415926,CUTOFF=1.8966,AVMASS=0.9383)
15742         PARAMETER (AKA=0.498,AKS=0.895,ALA=1.1157,ASA=1.1974
15743      1 ,APHI=1.02)
15744         PARAMETER (AM1440 = 1.44, AM1535 = 1.535)
15745         parameter     (MX=4,MY=4,MZ=8,MPX=4,MPY=4,mpz=10,mpzp=10)
15746         COMMON /AA/ R(3,MAXSTR)
15747 cc      SAVE /AA/
15748         COMMON /BB/ P(3,MAXSTR)
15749 cc      SAVE /BB/
15750         COMMON /CC/ E(MAXSTR)
15751 cc      SAVE /CC/
15752         COMMON /EE/ ID(MAXSTR),LB(MAXSTR)
15753 cc      SAVE /EE/
15754         common/input1/ MASSPR,MASSTA,ISEED,IAVOID,DT
15755 cc      SAVE /input1/
15756       COMMON/RNDF77/NSEED
15757 cc      SAVE /RNDF77/
15758       SAVE
15759
15760           emm1=0.
15761           emm2=0.
15762           lbp1=0
15763           lbp2=0
15764            XKP0 = spika
15765            XKP1 = 0.
15766            XKP2 = 0.
15767            XKP3 = 0.
15768            XKP4 = 0.
15769            XKP5 = 0.
15770            XKP6 = 0.
15771            XKP7 = 0.
15772            XKP8 = 0.
15773            XKP9 = 0.
15774            XKP10 = 0.
15775            sigm = 15.
15776 c         if(lb(i1).eq.21.or.lb(i2).eq.21)sigm=10.
15777         pdd = (srt**2-(aka+ap1)**2)*(srt**2-(aka-ap1)**2)
15778 c
15779          if(srt .lt. (ala+amn))go to 70
15780         XKP1 = sigm*(4./3.)*(srt**2-(ala+amn)**2)*
15781      &           (srt**2-(ala-amn)**2)/pdd
15782          if(srt .gt. (ala+am0))then
15783         XKP2 = sigm*(16./3.)*(srt**2-(ala+am0)**2)*
15784      &           (srt**2-(ala-am0)**2)/pdd
15785          endif
15786          if(srt .gt. (ala+am1440))then
15787         XKP3 = sigm*(4./3.)*(srt**2-(ala+am1440)**2)*
15788      &           (srt**2-(ala-am1440)**2)/pdd
15789          endif
15790          if(srt .gt. (ala+am1535))then
15791         XKP4 = sigm*(4./3.)*(srt**2-(ala+am1535)**2)*
15792      &           (srt**2-(ala-am1535)**2)/pdd
15793          endif
15794 c
15795          if(srt .gt. (asa+amn))then
15796         XKP5 = sigm*4.*(srt**2-(asa+amn)**2)*
15797      &           (srt**2-(asa-amn)**2)/pdd
15798          endif
15799          if(srt .gt. (asa+am0))then
15800         XKP6 = sigm*16.*(srt**2-(asa+am0)**2)*
15801      &           (srt**2-(asa-am0)**2)/pdd
15802          endif
15803          if(srt .gt. (asa+am1440))then
15804         XKP7 = sigm*4.*(srt**2-(asa+am1440)**2)*
15805      &           (srt**2-(asa-am1440)**2)/pdd
15806          endif
15807          if(srt .gt. (asa+am1535))then
15808         XKP8 = sigm*4.*(srt**2-(asa+am1535)**2)*
15809      &           (srt**2-(asa-am1535)**2)/pdd
15810          endif
15811 70     continue
15812           sig1 = 195.639
15813           sig2 = 372.378
15814        if(srt .gt. aphi+aka)then
15815         pff = sqrt((srt**2-(aphi+aka)**2)*(srt**2-(aphi-aka)**2))
15816          XKP9 = sig1*pff/sqrt(pdd)*1./32./pi/srt**2
15817         if(srt .gt. aphi+aks)then
15818         pff = sqrt((srt**2-(aphi+aks)**2)*(srt**2-(aphi-aks)**2))
15819          XKP10 = sig2*pff/sqrt(pdd)*3./32./pi/srt**2
15820        endif
15821         endif
15822
15823 clin-8/15/02 K pi -> K* (rho omega), from detailed balance,
15824 c neglect rho and omega mass difference for now:
15825         sigpik=0.
15826         if(srt.gt.(amrho+aks)) then
15827            sigpik=srhoks*9.
15828      1          *(srt**2-(0.77-aks)**2)*(srt**2-(0.77+aks)**2)/4
15829      2          /srt**2/(px**2+py**2+pz**2)
15830            if(srt.gt.(amomga+aks)) sigpik=sigpik*12./9.
15831         endif
15832
15833 c
15834          sigkp = XKP0 + XKP1 + XKP2 + XKP3 + XKP4
15835      &         + XKP5 + XKP6 + XKP7 + XKP8 + XKP9 + XKP10 +sigpik
15836            icase = 0
15837          DSkn=SQRT(sigkp/PI/10.)
15838         dsknr=dskn+0.1
15839         CALL DISTCE(I1,I2,dsknr,DSkn,DT,EC,SRT,IC,
15840      1  PX,PY,PZ)
15841         IF(IC.EQ.-1)return
15842 c
15843         randu = RANART(NSEED)*sigkp
15844         XKP1 = XKP0 + XKP1
15845         XKP2 = XKP1 + XKP2
15846         XKP3 = XKP2 + XKP3
15847         XKP4 = XKP3 + XKP4
15848         XKP5 = XKP4 + XKP5
15849         XKP6 = XKP5 + XKP6
15850         XKP7 = XKP6 + XKP7
15851         XKP8 = XKP7 + XKP8
15852         XKP9 = XKP8 + XKP9
15853
15854         XKP10 = XKP9 + XKP10
15855 c
15856 c   !! K* formation
15857          if(randu .le. XKP0)then
15858            icase = 1
15859             return
15860          else
15861 * La/Si-bar + B formation
15862            icase = 2
15863          if( randu .le. XKP1 )then
15864              lbp1 = -14
15865              lbp2 = 1 + int(2*RANART(NSEED))
15866              emm1 = ala
15867              emm2 = amn
15868              go to 60
15869          elseif( randu .le. XKP2 )then
15870              lbp1 = -14
15871              lbp2 = 6 + int(4*RANART(NSEED))
15872              emm1 = ala
15873              emm2 = am0
15874              go to 60
15875          elseif( randu .le. XKP3 )then
15876              lbp1 = -14
15877              lbp2 = 10 + int(2*RANART(NSEED))
15878              emm1 = ala
15879              emm2 = am1440
15880              go to 60
15881          elseif( randu .le. XKP4 )then
15882              lbp1 = -14
15883              lbp2 = 12 + int(2*RANART(NSEED))
15884              emm1 = ala
15885              emm2 = am1535
15886              go to 60
15887          elseif( randu .le. XKP5 )then
15888              lbp1 = -15 - int(3*RANART(NSEED))
15889              lbp2 = 1 + int(2*RANART(NSEED))
15890              emm1 = asa
15891              emm2 = amn
15892              go to 60
15893          elseif( randu .le. XKP6 )then
15894              lbp1 = -15 - int(3*RANART(NSEED))
15895              lbp2 = 6 + int(4*RANART(NSEED))
15896              emm1 = asa
15897              emm2 = am0
15898              go to 60
15899           elseif( randu .lt. XKP7 )then
15900              lbp1 = -15 - int(3*RANART(NSEED))
15901              lbp2 = 10 + int(2*RANART(NSEED))
15902              emm1 = asa
15903              emm2 = am1440
15904              go to 60
15905           elseif( randu .lt. XKP8 )then
15906              lbp1 = -15 - int(3*RANART(NSEED))
15907              lbp2 = 12 + int(2*RANART(NSEED))
15908              emm1 = asa
15909              emm2 = am1535
15910              go to 60
15911           elseif( randu .lt. XKP9 )then
15912 c       !! phi +K  formation (iblock=224)
15913             icase = 3
15914              lbp1 = 29
15915              lbp2 = 23
15916              emm1 = aphi
15917              emm2 = aka
15918            if(lb(i1).eq.21.or.lb(i2).eq.21)then
15919 c         !! phi +K-bar  formation (iblock=124)
15920              lbp2 = 21
15921              icase = -3
15922            endif
15923              go to 60
15924           elseif( randu .lt. XKP10 )then
15925 c       !! phi +K* formation (iblock=226)
15926             icase = 4
15927              lbp1 = 29
15928              lbp2 = 30
15929              emm1 = aphi
15930              emm2 = aks
15931            if(lb(i1).eq.21.or.lb(i2).eq.21)then
15932              lbp2 = -30
15933              icase = -4
15934            endif
15935            go to 60
15936
15937           else
15938 c       !! (rho,omega) +K* formation (iblock=88)
15939             icase=5
15940             lbp1=25+int(3*RANART(NSEED))
15941             lbp2=30
15942             emm1=amrho
15943             emm2=aks
15944             if(srt.gt.(amomga+aks).and.RANART(NSEED).lt.0.25) then
15945                lbp1=28
15946                emm1=amomga
15947             endif
15948             if(lb(i1).eq.21.or.lb(i2).eq.21)then
15949                lbp2=-30
15950                icase=-5
15951             endif
15952
15953           endif
15954           endif
15955 c
15956 60       if( icase.eq.2 .and. (lb(i1).eq.21.or.lb(i2).eq.21) )then
15957             lbp1 = -lbp1
15958             lbp2 = -lbp2
15959          endif
15960         PX0=PX
15961         PY0=PY
15962         PZ0=PZ
15963 *-----------------------------------------------------------------------
15964 * CALCULATE THE MAGNITUDE OF THE FINAL MOMENTUM THROUGH
15965 * ENERGY CONSERVATION
15966            PR2   = (SRT**2 - EMM1**2 - EMM2**2)**2
15967      1                - 4.0 * (EMM1*EMM2)**2
15968           IF(PR2.LE.0.)PR2=1.e-09
15969           PR=SQRT(PR2)/(2.*SRT)
15970           C1   = 1.0 - 2.0 * RANART(NSEED)
15971           T1   = 2.0 * PI * RANART(NSEED)
15972       S1   = SQRT( 1.0 - C1**2 )
15973       CT1  = COS(T1)
15974       ST1  = SIN(T1)
15975 * THE MOMENTUM IN THE CMS IN THE FINAL STATE
15976       PZ   = PR * C1
15977       PX   = PR * S1*CT1
15978       PY   = PR * S1*ST1
15979 * FOR THE ISOTROPIC DISTRIBUTION THERE IS NO NEED TO ROTATE
15980       RETURN
15981       END
15982 **********************************
15983 *                                                                      *
15984 *                                                                      *
15985         SUBROUTINE Crkphi(PX,PY,PZ,EC,SRT,IBLOCK,
15986      &                  emm1,emm2,lbp1,lbp2,I1,I2,ikk,icase,rrkk,prkk)
15987
15988 *     PURPOSE:                                                         *
15989 *     DEALING WITH   KKbar, KK*bar, KbarK*, K*K*bar --> Phi + pi(rho,omega)
15990 *     and KKbar --> (pi eta) (pi eta), (rho omega) (rho omega)
15991 *     and KK*bar or Kbar K* --> (pi eta) (rho omega)
15992 *
15993 *     NOTE   :                                                         *
15994 *
15995 *     QUANTITIES:                                                      *
15996 *           PX,PY,PZ - MOMENTUM COORDINATES OF ONE PARTICLE IN CM FRAME*
15997 *           SRT      - SQRT OF S                                       *
15998 *           IBLOCK   - THE INFORMATION BACK                            *
15999 *                      222
16000 **********************************
16001         PARAMETER (MAXSTR=150001,MAXR=1,AMN=0.939457,
16002      1  AMP=0.93828,AP1=0.13496,AP2=0.13957,APHI=1.02,
16003      2  AM0=1.232,AMNS=1.52,PI=3.1415926,CUTOFF=1.8966,AVMASS=0.9383)
16004         PARAMETER      (AKA=0.498,ALA=1.1157,ASA=1.1974,ACAS=1.3213)
16005         PARAMETER      (AKS=0.895,AOMEGA=0.7819, ARHO=0.77)
16006         parameter     (MX=4,MY=4,MZ=8,MPX=4,MPY=4,mpz=10,mpzp=10)
16007         COMMON /AA/ R(3,MAXSTR)
16008 cc      SAVE /AA/
16009         COMMON /BB/ P(3,MAXSTR)
16010 cc      SAVE /BB/
16011         COMMON /CC/ E(MAXSTR)
16012 cc      SAVE /CC/
16013         COMMON /EE/ ID(MAXSTR),LB(MAXSTR)
16014 cc      SAVE /EE/
16015         common/input1/ MASSPR,MASSTA,ISEED,IAVOID,DT
16016 cc      SAVE /input1/
16017       COMMON/RNDF77/NSEED
16018 cc      SAVE /RNDF77/
16019       SAVE
16020
16021         lb1 = lb(i1)
16022         lb2 = lb(i2)
16023         icase = 0
16024
16025 c        if(srt .lt. aphi+ap1)return
16026 cc        if(srt .lt. aphi+ap1) then
16027         if(srt .lt. (aphi+ap1)) then
16028            sig1 = 0.
16029            sig2 = 0.
16030            sig3 = 0.
16031         else
16032 c
16033          if((lb1.eq.23.and.lb2.eq.21).or.(lb2.eq.23.and.lb1.eq.21))then
16034             dnr =  4.
16035             ikk = 2
16036           elseif((lb1.eq.21.and.lb2.eq.30).or.(lb2.eq.21.and.lb1.eq.30)
16037      & .or.(lb1.eq.23.and.lb2.eq.-30).or.(lb2.eq.23.and.lb1.eq.-30))then
16038              dnr = 12.
16039              ikk = 1
16040           else
16041              dnr = 36.
16042              ikk = 0
16043           endif
16044
16045           sig1 = 0.
16046           sig2 = 0.
16047           sig3 = 0.
16048           srri = E(i1)+E(i2)
16049           srr1 = aphi+ap1
16050           srr2 = aphi+aomega
16051           srr3 = aphi+arho
16052 c
16053           pii = (srt**2-(e(i1)+e(i2))**2)*(srt**2-(e(i1)-e(i2))**2)
16054           srrt = srt - amax1(srri,srr1)
16055 cc   to avoid divergent/negative values at small srrt:
16056 c          if(srrt .lt. 0.3)then
16057           if(srrt .lt. 0.3 .and. srrt .gt. 0.01)then
16058           sig = 1.69/(srrt**0.141 - 0.407)
16059          else
16060           sig = 3.74 + 0.008*srrt**1.9
16061          endif
16062           sig1=sig*(9./dnr)*(srt**2-(aphi+ap1)**2)*
16063      &           (srt**2-(aphi-ap1)**2)/pii
16064           if(srt .gt. aphi+aomega)then
16065           srrt = srt - amax1(srri,srr2)
16066 cc         if(srrt .lt. 0.3)then
16067           if(srrt .lt. 0.3 .and. srrt .gt. 0.01)then
16068           sig = 1.69/(srrt**0.141 - 0.407)
16069          else
16070           sig = 3.74 + 0.008*srrt**1.9
16071          endif
16072           sig2=sig*(9./dnr)*(srt**2-(aphi+aomega)**2)*
16073      &           (srt**2-(aphi-aomega)**2)/pii
16074            endif
16075          if(srt .gt. aphi+arho)then
16076           srrt = srt - amax1(srri,srr3)
16077 cc         if(srrt .lt. 0.3)then
16078           if(srrt .lt. 0.3 .and. srrt .gt. 0.01)then
16079           sig = 1.69/(srrt**0.141 - 0.407)
16080          else
16081           sig = 3.74 + 0.008*srrt**1.9
16082          endif
16083           sig3=sig*(27./dnr)*(srt**2-(aphi+arho)**2)*
16084      &           (srt**2-(aphi-arho)**2)/pii
16085          endif
16086 c         sig1 = amin1(20.,sig1)
16087 c         sig2 = amin1(20.,sig2)
16088 c         sig3 = amin1(20.,sig3)
16089         endif
16090
16091         rrkk0=rrkk
16092         prkk0=prkk
16093         SIGM=0.
16094         if((lb1.eq.23.and.lb2.eq.21).or.(lb2.eq.23.and.lb1.eq.21))then
16095            CALL XKKANN(SRT, XSK1, XSK2, XSK3, XSK4, XSK5,
16096      &          XSK6, XSK7, XSK8, XSK9, XSK10, XSK11, SIGM, rrkk0)
16097         elseif((lb1.eq.21.and.lb2.eq.30).or.(lb2.eq.21.and.lb1.eq.30)
16098      & .or.(lb1.eq.23.and.lb2.eq.-30).or.(lb2.eq.23.and.lb1.eq.-30))then
16099            CALL XKKSAN(i1,i2,SRT,SIGKS1,SIGKS2,SIGKS3,SIGKS4,SIGM,prkk0)
16100         else
16101         endif
16102 c
16103 c         sigks = sig1 + sig2 + sig3
16104         sigm0=sigm
16105         sigks = sig1 + sig2 + sig3 + SIGM
16106         DSkn=SQRT(sigks/PI/10.)
16107         dsknr=dskn+0.1
16108         CALL DISTCE(I1,I2,dsknr,DSkn,DT,EC,SRT,IC,
16109      1  PX,PY,PZ)
16110         IF(IC.EQ.-1)return
16111         icase = 1
16112         ranx = RANART(NSEED)
16113
16114         lbp1 = 29
16115         emm1 = aphi
16116         if(ranx .le. sig1/sigks)then
16117            lbp2 = 3 + int(3*RANART(NSEED))
16118            emm2 = ap1
16119         elseif(ranx .le. (sig1+sig2)/sigks)then
16120            lbp2 = 28
16121            emm2 = aomega
16122         elseif(ranx .le. (sig1+sig2+sig3)/sigks)then
16123            lbp2 = 25 + int(3*RANART(NSEED))
16124            emm2 = arho
16125         else
16126            if((lb1.eq.23.and.lb2.eq.21)
16127      &          .or.(lb2.eq.23.and.lb1.eq.21))then
16128               CALL crkkpi(I1,I2,XSK1, XSK2, XSK3, XSK4,
16129      &             XSK5, XSK6, XSK7, XSK8, XSK9, XSK10, XSK11, SIGM0,
16130      &             IBLOCK,lbp1,lbp2,emm1,emm2)
16131            elseif((lb1.eq.21.and.lb2.eq.30)
16132      &             .or.(lb2.eq.21.and.lb1.eq.30)
16133      &             .or.(lb1.eq.23.and.lb2.eq.-30)
16134      &             .or.(lb2.eq.23.and.lb1.eq.-30))then
16135               CALL crkspi(I1,I2,SIGKS1, SIGKS2, SIGKS3, SIGKS4,
16136      &             SIGM0,IBLOCK,lbp1,lbp2,emm1,emm2)
16137            else
16138            endif
16139         endif
16140 *
16141         PX0=PX
16142         PY0=PY
16143         PZ0=PZ
16144 *-----------------------------------------------------------------------
16145 * CALCULATE THE MAGNITUDE OF THE FINAL MOMENTUM THROUGH
16146 * ENERGY CONSERVATION
16147            PR2   = (SRT**2 - EMM1**2 - EMM2**2)**2
16148      1                - 4.0 * (EMM1*EMM2)**2
16149           IF(PR2.LE.0.)PR2=1.e-09
16150           PR=SQRT(PR2)/(2.*SRT)
16151           C1   = 1.0 - 2.0 * RANART(NSEED)
16152           T1   = 2.0 * PI * RANART(NSEED)
16153       S1   = SQRT( 1.0 - C1**2 )
16154       CT1  = COS(T1)
16155       ST1  = SIN(T1)
16156 * THE MOMENTUM IN THE CMS IN THE FINAL STATE
16157       PZ   = PR * C1
16158       PX   = PR * S1*CT1
16159       PY   = PR * S1*ST1
16160 * FOR THE ISOTROPIC DISTRIBUTION THERE IS NO NEED TO ROTATE
16161       RETURN
16162       END
16163 csp11/21/01 end
16164 **********************************
16165 *                                                                      *
16166 *                                                                      *
16167         SUBROUTINE Crksph(PX,PY,PZ,EC,SRT,
16168      &     emm1,emm2,lbp1,lbp2,I1,I2,ikkg,ikkl,iblock,
16169      &     icase,srhoks)
16170
16171 *     PURPOSE:                                                         *
16172 *     DEALING WITH   K + rho(omega) or K* + pi(rho,omega)
16173 *                    --> Phi + K(K*), pi + K* or pi + K, and elastic
16174 *     NOTE   :                                                         *
16175 *
16176 *     QUANTITIES:                                                      *
16177 *           PX,PY,PZ - MOMENTUM COORDINATES OF ONE PARTICLE IN CM FRAME*
16178 *           SRT      - SQRT OF S                                       *
16179 *           IBLOCK   - THE INFORMATION BACK                            *
16180 *                      222
16181 *                      223 --> phi + pi(rho,omega)
16182 *                      224 --> phi + K <-> K + pi(rho,omega)
16183 *                      225 --> phi + K <-> K* + pi(rho,omega)
16184 *                      226 --> phi + K* <-> K + pi(rho,omega)
16185 *                      227 --> phi + K* <-> K* + pi(rho,omega)
16186 **********************************
16187         PARAMETER (MAXSTR=150001,MAXR=1,AMN=0.939457,
16188      1  AMP=0.93828,AP1=0.13496,AP2=0.13957,APHI=1.02,
16189      2  AM0=1.232,AMNS=1.52,PI=3.1415926,CUTOFF=1.8966,AVMASS=0.9383)
16190         PARAMETER      (AKA=0.498,ALA=1.1157,ASA=1.1974,ACAS=1.3213)
16191         PARAMETER      (AKS=0.895,AOMEGA=0.7819, ARHO=0.77)
16192         parameter     (MX=4,MY=4,MZ=8,MPX=4,MPY=4,mpz=10,mpzp=10)
16193         COMMON /AA/ R(3,MAXSTR)
16194 cc      SAVE /AA/
16195         COMMON /BB/ P(3,MAXSTR)
16196 cc      SAVE /BB/
16197         COMMON /CC/ E(MAXSTR)
16198 cc      SAVE /CC/
16199         COMMON /EE/ ID(MAXSTR),LB(MAXSTR)
16200 cc      SAVE /EE/
16201         common/input1/ MASSPR,MASSTA,ISEED,IAVOID,DT
16202 cc      SAVE /input1/
16203       COMMON/RNDF77/NSEED
16204 cc      SAVE /RNDF77/
16205       SAVE
16206
16207         lb1 = lb(i1)
16208         lb2 = lb(i2)
16209         icase = 0
16210         sigela=10.
16211         sigkm=0.
16212 c     K(K*) + rho(omega) -> pi K*(K)
16213         if((lb1.ge.25.and.lb1.le.28).or.(lb2.ge.25.and.lb2.le.28)) then
16214            if(iabs(lb1).eq.30.or.iabs(lb2).eq.30) then
16215               sigkm=srhoks
16216 clin-2/26/03 check whether (rho K) is above the (pi K*) thresh:
16217            elseif((lb1.eq.23.or.lb1.eq.21.or.lb2.eq.23.or.lb2.eq.21)
16218      1             .and.srt.gt.(ap2+aks)) then
16219               sigkm=srhoks
16220            endif
16221         endif
16222
16223 c        if(srt .lt. aphi+aka)return
16224         if(srt .lt. (aphi+aka)) then
16225            sig11=0.
16226            sig22=0.
16227         else
16228
16229 c K*-bar +pi --> phi + (K,K*)-bar
16230          if( (iabs(lb1).eq.30.and.(lb2.ge.3.and.lb2.le.5)) .or.
16231      &       (iabs(lb2).eq.30.and.(lb1.ge.3.and.lb1.le.5)) )then
16232               dnr =  18.
16233               ikkl = 0
16234               IBLOCK = 225
16235 c               sig1 = 15.0
16236 c               sig2 = 30.0
16237 clin-2/06/03 these large values reduces to ~10 mb for sig11 or sig22
16238 c     due to the factors of ~1/(32*pi*s)~1/200:
16239                sig1 = 2047.042
16240                sig2 = 1496.692
16241 c K(-bar)+rho --> phi + (K,K*)-bar
16242        elseif((lb1.eq.23.or.lb1.eq.21.and.(lb2.ge.25.and.lb2.le.27)).or.
16243      &      (lb2.eq.23.or.lb2.eq.21.and.(lb1.ge.25.and.lb1.le.27)) )then
16244               dnr =  18.
16245               ikkl = 1
16246               IBLOCK = 224
16247 c               sig1 = 3.5
16248 c               sig2 = 9.0
16249                sig1 = 526.702
16250                sig2 = 1313.960
16251 c K*(-bar) +rho
16252          elseif( (iabs(lb1).eq.30.and.(lb2.ge.25.and.lb2.le.27)) .or.
16253      &           (iabs(lb2).eq.30.and.(lb1.ge.25.and.lb1.le.27)) )then
16254               dnr =  54.
16255               ikkl = 0
16256               IBLOCK = 225
16257 c               sig1 = 3.5
16258 c               sig2 = 9.0
16259                sig1 = 1371.257
16260                sig2 = 6999.840
16261 c K(-bar) + omega
16262          elseif( ((lb1.eq.23.or.lb1.eq.21) .and. lb2.eq.28).or.
16263      &           ((lb2.eq.23.or.lb2.eq.21) .and. lb1.eq.28) )then
16264               dnr = 6.
16265               ikkl = 1
16266               IBLOCK = 224
16267 c               sig1 = 3.5
16268 c               sig2 = 6.5
16269                sig1 = 355.429
16270                sig2 = 440.558
16271 c K*(-bar) +omega
16272           else
16273               dnr = 18.
16274               ikkl = 0
16275               IBLOCK = 225
16276 c               sig1 = 3.5
16277 c               sig2 = 15.0
16278                sig1 = 482.292
16279                sig2 = 1698.903
16280           endif
16281
16282             sig11 = 0.
16283             sig22 = 0.
16284 c         sig11=sig1*(6./dnr)*(srt**2-(aphi+aka)**2)*
16285 c    &           (srt**2-(aphi-aka)**2)/(srt**2-(e(i1)+e(i2))**2)/
16286 c    &           (srt**2-(e(i1)-e(i2))**2)
16287         pii = sqrt((srt**2-(e(i1)+e(i2))**2)*(srt**2-(e(i1)-e(i2))**2))
16288         pff = sqrt((srt**2-(aphi+aka)**2)*(srt**2-(aphi-aka)**2))
16289           sig11 = sig1*pff/pii*6./dnr/32./pi/srt**2
16290 c
16291           if(srt .gt. aphi+aks)then
16292 c         sig22=sig2*(18./dnr)*(srt**2-(aphi+aks)**2)*
16293 c    &           (srt**2-(aphi-aks)**2)/(srt**2-(e(i1)+e(i2))**2)/
16294 c    &           (srt**2-(e(i1)-e(i2))**2)
16295         pff = sqrt((srt**2-(aphi+aks)**2)*(srt**2-(aphi-aks)**2))
16296           sig22 = sig2*pff/pii*18./dnr/32./pi/srt**2
16297            endif
16298 c         sig11 = amin1(20.,sig11)
16299 c         sig22 = amin1(20.,sig22)
16300 c
16301         endif
16302
16303 c         sigks = sig11 + sig22
16304          sigks=sig11+sig22+sigela+sigkm
16305 c
16306         DSkn=SQRT(sigks/PI/10.)
16307         dsknr=dskn+0.1
16308         CALL DISTCE(I1,I2,dsknr,DSkn,DT,EC,SRT,IC,
16309      1  PX,PY,PZ)
16310         IF(IC.EQ.-1)return
16311         icase = 1
16312         ranx = RANART(NSEED)
16313
16314          if(ranx .le. (sigela/sigks))then
16315             lbp1=lb1
16316             emm1=e(i1)
16317             lbp2=lb2
16318             emm2=e(i2)
16319             iblock=111
16320          elseif(ranx .le. ((sigela+sigkm)/sigks))then
16321             lbp1=3+int(3*RANART(NSEED))
16322             emm1=0.14
16323             if(lb1.eq.23.or.lb2.eq.23) then
16324                lbp2=30
16325                emm2=aks
16326             elseif(lb1.eq.21.or.lb2.eq.21) then
16327                lbp2=-30
16328                emm2=aks
16329             elseif(lb1.eq.30.or.lb2.eq.30) then
16330                lbp2=23
16331                emm2=aka
16332             else
16333                lbp2=21
16334                emm2=aka
16335             endif
16336             iblock=112
16337          elseif(ranx .le. ((sigela+sigkm+sig11)/sigks))then
16338             lbp2 = 23
16339             emm2 = aka
16340             ikkg = 1
16341             if(lb1.eq.21.or.lb2.eq.21.or.lb1.eq.-30.or.lb2.eq.-30)then
16342                lbp2=21
16343                iblock=iblock-100
16344             endif
16345             lbp1 = 29
16346             emm1 = aphi
16347          else
16348             lbp2 = 30
16349             emm2 = aks
16350             ikkg = 0
16351             IBLOCK=IBLOCK+2
16352             if(lb1.eq.21.or.lb2.eq.21.or.lb1.eq.-30.or.lb2.eq.-30)then
16353                lbp2=-30
16354                iblock=iblock-100
16355             endif
16356             lbp1 = 29
16357             emm1 = aphi
16358          endif
16359 *
16360         PX0=PX
16361         PY0=PY
16362         PZ0=PZ
16363 *-----------------------------------------------------------------------
16364 * CALCULATE THE MAGNITUDE OF THE FINAL MOMENTUM THROUGH
16365 * ENERGY CONSERVATION
16366            PR2   = (SRT**2 - EMM1**2 - EMM2**2)**2
16367      1                - 4.0 * (EMM1*EMM2)**2
16368           IF(PR2.LE.0.)PR2=1.e-09
16369           PR=SQRT(PR2)/(2.*SRT)
16370           C1   = 1.0 - 2.0 * RANART(NSEED)
16371           T1   = 2.0 * PI * RANART(NSEED)
16372       S1   = SQRT( 1.0 - C1**2 )
16373       CT1  = COS(T1)
16374       ST1  = SIN(T1)
16375 * THE MOMENTUM IN THE CMS IN THE FINAL STATE
16376       PZ   = PR * C1
16377       PX   = PR * S1*CT1
16378       PY   = PR * S1*ST1
16379 * FOR THE ISOTROPIC DISTRIBUTION THERE IS NO NEED TO ROTATE
16380       RETURN
16381       END
16382 csp11/21/01 end
16383 **********************************
16384 **********************************
16385         SUBROUTINE bbkaon(ic,SRT,PX,PY,PZ,ana,PlX,
16386      &  PlY,PlZ,ala,pkX,PkY,PkZ,icou1)
16387 * purpose: generate the momenta for kaon,lambda/sigma and nucleon/delta
16388 *          in the BB-->nlk process
16389 * date: Sept. 9, 1994
16390 c
16391         common/input1/ MASSPR,MASSTA,ISEED,IAVOID,DT
16392 cc      SAVE /input1/
16393       COMMON/RNDF77/NSEED
16394 cc      SAVE /RNDF77/
16395       SAVE
16396
16397        PI=3.1415962
16398        icou1=0
16399        aka=0.498
16400         ala=1.116
16401        if(ic.eq.2.or.ic.eq.4)ala=1.197
16402        ana=0.939
16403 * generate the mass of the delta
16404        if(ic.gt.2)then
16405        dmax=srt-aka-ala-0.02
16406         DM1=RMASS(DMAX,ISEED)
16407        ana=dm1
16408        endif
16409        t1=aka+ana+ala
16410        t2=ana+ala-aka
16411        if(srt.le.t1)then
16412        icou1=-1
16413        return
16414        endif
16415        pmax=sqrt((srt**2-t1**2)*(srt**2-t2**2))/(2.*srt)
16416        if(pmax.eq.0.)pmax=1.e-09
16417 * (1) Generate the momentum of the kaon according to the distribution Fkaon
16418 *     and assume that the angular distribution is isotropic
16419 *     in the cms of the colliding pair
16420        ntry=0
16421 1       pk=pmax*RANART(NSEED)
16422        ntry=ntry+1
16423        prob=fkaon(pk,pmax)
16424        if((prob.lt.RANART(NSEED)).and.(ntry.le.40))go to 1
16425        cs=1.-2.*RANART(NSEED)
16426        ss=sqrt(1.-cs**2)
16427        fai=2.*3.14*RANART(NSEED)
16428        pkx=pk*ss*cos(fai)
16429        pky=pk*ss*sin(fai)
16430        pkz=pk*cs
16431 * the energy of the kaon
16432        ek=sqrt(aka**2+pk**2)
16433 * (2) Generate the momentum of the nucleon/delta in the cms of N/delta
16434 *     and lamda/sigma
16435 *  the energy of the cms of NL
16436         eln=srt-ek
16437        if(eln.le.0)then
16438        icou1=-1
16439        return
16440        endif
16441 * beta and gamma of the cms of L/S+N
16442        bx=-pkx/eln
16443        by=-pky/eln
16444        bz=-pkz/eln
16445        ga=1./sqrt(1.-bx**2-by**2-bz**2)
16446         elnc=eln/ga
16447        pn2=((elnc**2+ana**2-ala**2)/(2.*elnc))**2-ana**2
16448        if(pn2.le.0.)pn2=1.e-09
16449        pn=sqrt(pn2)
16450        csn=1.-2.*RANART(NSEED)
16451        ssn=sqrt(1.-csn**2)
16452        fain=2.*3.14*RANART(NSEED)
16453        px=pn*ssn*cos(fain)
16454        py=pn*ssn*sin(fain)
16455        pz=pn*csn
16456        en=sqrt(ana**2+pn2)
16457 * the momentum of the lambda/sigma in the n-l cms frame is
16458        plx=-px
16459        ply=-py
16460        plz=-pz
16461 * (3) LORENTZ-TRANSFORMATION INTO nn cms FRAME for the neutron/delta
16462         PBETA  = PX*BX + PY*By+ PZ*Bz
16463               TRANS0  = GA * ( GA * PBETA / (GA + 1.) + En )
16464               Px = BX * TRANS0 + PX
16465               Py = BY * TRANS0 + PY
16466               Pz = BZ * TRANS0 + PZ
16467 * (4) Lorentz-transformation for the lambda/sigma
16468        el=sqrt(ala**2+plx**2+ply**2+plz**2)
16469         PBETA  = PlX*BX + PlY*By+ PlZ*Bz
16470               TRANS0  = GA * ( GA * PBETA / (GA + 1.) + El )
16471               Plx = BX * TRANS0 + PlX
16472               Ply = BY * TRANS0 + PlY
16473               Plz = BZ * TRANS0 + PlZ
16474              return
16475              end
16476 ******************************************
16477 * for pion+pion-->K+K-
16478 c      real*4 function pipik(srt)
16479       real function pipik(srt)
16480 *  srt    = DSQRT(s) in GeV                                                   *
16481 *  xsec   = production cross section in mb                                    *
16482 *  NOTE: DEVIDE THE CROSS SECTION TO OBTAIN K+ PRODUCTION                     *
16483 ******************************************
16484 c      real*4   xarray(5), earray(5)
16485       real   xarray(5), earray(5)
16486       SAVE
16487       data xarray /0.001, 0.7,1.5,1.7,2.0/
16488       data earray /1.,1.2,1.6,2.0,2.4/
16489
16490            pmass=0.9383
16491 * 1.Calculate p(lab)  from srt [GeV]
16492 *   Formula used:   DSQRT(s) = 2 m DSQRT(E_kin/(2m) + 1)
16493 c      ekin = 2.*pmass*((srt/(2.*pmass))**2 - 1.)
16494        pipik=0.
16495        if(srt.le.1.)return
16496        if(srt.gt.2.4)then
16497            pipik=2.0/2.
16498            return
16499        endif
16500         if (srt .lt. earray(1)) then
16501            pipik =xarray(1)/2.
16502            return
16503         end if
16504 *
16505 * 2.Interpolate double logarithmically to find sigma(srt)
16506 *
16507       do 1001 ie = 1,5
16508         if (earray(ie) .eq. srt) then
16509           pipik = xarray(ie)
16510           go to 10
16511         else if (earray(ie) .gt. srt) then
16512           ymin = alog(xarray(ie-1))
16513           ymax = alog(xarray(ie))
16514           xmin = alog(earray(ie-1))
16515           xmax = alog(earray(ie))
16516           pipik = exp(ymin + (alog(srt)-xmin)*(ymax-ymin)
16517      &/(xmax-xmin) )
16518           go to 10
16519         end if
16520  1001 continue
16521 10       PIPIK=PIPIK/2.
16522        continue
16523       return
16524         END
16525 **********************************
16526 * TOTAL PION-P INELASTIC CROSS SECTION
16527 *  from the CERN data book
16528 *  date: Sept.2, 1994
16529 *  for pion++p-->Delta+pion
16530 c      real*4 function pionpp(srt)
16531       real function pionpp(srt)
16532       SAVE
16533 *  srt    = DSQRT(s) in GeV                                                   *
16534 *  xsec   = production cross section in fm**2                                 *
16535 *  earray = EXPerimental table with proton energies in MeV                    *
16536 *  xarray = EXPerimental table with cross sections in mb (curve to guide eye) *
16537 *                                                                             *
16538 ******************************************
16539            pmass=0.14
16540        pmass1=0.938
16541        PIONPP=0.00001
16542        IF(SRT.LE.1.22)RETURN
16543 * 1.Calculate p(lab)  from srt [GeV]
16544 *   Formula used:   DSQRT(s) = 2 m DSQRT(E_kin/(2m) + 1)
16545 c      ekin = 2.*pmass*((srt/(2.*pmass))**2 - 1.)
16546         plab=sqrt(((srt**2-pmass**2-pmass1**2)/(2.*pmass1))**2-pmass**2)
16547        pmin=0.3
16548        pmax=25.0
16549        if(plab.gt.pmax)then
16550        pionpp=20./10.
16551        return
16552        endif
16553         if(plab .lt. pmin)then
16554         pionpp = 0.
16555         return
16556         end if
16557 c* fit parameters
16558        a=24.3
16559        b=-12.3
16560        c=0.324
16561        an=-1.91
16562        d=-2.44
16563         pionpp = a+b*(plab**an)+c*(alog(plab))**2+d*alog(plab)
16564        if(pionpp.le.0)pionpp=0
16565        pionpp=pionpp/10.
16566         return
16567         END
16568 **********************************
16569 * elementary cross sections
16570 *  from the CERN data book
16571 *  date: Sept.2, 1994
16572 *  for pion-+p-->INELASTIC
16573 c      real*4 function pipp1(srt)
16574       real function pipp1(srt)
16575       SAVE
16576 *  srt    = DSQRT(s) in GeV                                                   *
16577 *  xsec   = production cross section in fm**2                                 *
16578 *  earray = EXPerimental table with proton energies in MeV                    *
16579 *  xarray = EXPerimental table with cross sections in mb (curve to guide eye) *
16580 *  UNITS: FM**2
16581 ******************************************
16582            pmass=0.14
16583        pmass1=0.938
16584        PIPP1=0.0001
16585        IF(SRT.LE.1.22)RETURN
16586 * 1.Calculate p(lab)  from srt [GeV]
16587 *   Formula used:   DSQRT(s) = 2 m DSQRT(E_kin/(2m) + 1)
16588 c      ekin = 2.*pmass*((srt/(2.*pmass))**2 - 1.)
16589         plab=sqrt(((srt**2-pmass**2-pmass1**2)/(2.*pmass1))**2-pmass**2)
16590        pmin=0.3
16591        pmax=25.0
16592        if(plab.gt.pmax)then
16593        pipp1=20./10.
16594        return
16595        endif
16596         if(plab .lt. pmin)then
16597         pipp1 = 0.
16598         return
16599         end if
16600 c* fit parameters
16601        a=26.6
16602        b=-7.18
16603        c=0.327
16604        an=-1.86
16605        d=-2.81
16606         pipp1 = a+b*(plab**an)+c*(alog(plab))**2+d*alog(plab)
16607        if(pipp1.le.0)pipp1=0
16608        PIPP1=PIPP1/10.
16609         return
16610         END
16611 * *****************************
16612 c       real*4 function xrho(srt)
16613       real function xrho(srt)
16614       SAVE
16615 *       xsection for pp-->pp+rho
16616 * *****************************
16617        pmass=0.9383
16618        rmass=0.77
16619        trho=0.151
16620        xrho=0.000000001
16621        if(srt.le.2.67)return
16622        ESMIN=2.*0.9383+rmass-trho/2.
16623        ES=srt
16624 * the cross section for tho0 production is
16625        xrho0=0.24*(es-esmin)/(1.4+(es-esmin)**2)
16626        xrho=3.*Xrho0
16627        return
16628        end
16629 * *****************************
16630 c       real*4 function omega(srt)
16631       real function omega(srt)
16632       SAVE
16633 *       xsection for pp-->pp+omega
16634 * *****************************
16635        pmass=0.9383
16636        omass=0.782
16637        tomega=0.0084
16638        omega=0.00000001
16639        if(srt.le.2.68)return
16640        ESMIN=2.*0.9383+omass-tomega/2.
16641        es=srt
16642        omega=0.36*(es-esmin)/(1.25+(es-esmin)**2)
16643        return
16644        end
16645 ******************************************
16646 * for ppi(+)-->DELTA+pi
16647 c      real*4 function TWOPI(srt)
16648       real function TWOPI(srt)
16649 *  This function contains the experimental pi+p-->DELTA+PION cross sections   *
16650 *  srt    = DSQRT(s) in GeV                                                   *
16651 *  xsec   = production cross section in mb                                    *
16652 *  earray = EXPerimental table with proton energies in MeV                    *
16653 *  xarray = EXPerimental table with cross sections in mb (curve to guide eye) *
16654 *                                                                             *
16655 ******************************************
16656 c      real*4   xarray(19), earray(19)
16657       real   xarray(19), earray(19)
16658       SAVE
16659       data xarray /0.300E-05,0.187E+01,0.110E+02,0.149E+02,0.935E+01,
16660      &0.765E+01,0.462E+01,0.345E+01,0.241E+01,0.185E+01,0.165E+01,
16661      &0.150E+01,0.132E+01,0.117E+01,0.116E+01,0.100E+01,0.856E+00,
16662      &0.745E+00,0.300E-05/
16663       data earray /0.122E+01, 0.147E+01, 0.172E+01, 0.197E+01,
16664      &0.222E+01, 0.247E+01, 0.272E+01, 0.297E+01, 0.322E+01,
16665      &0.347E+01, 0.372E+01, 0.397E+01, 0.422E+01, 0.447E+01,
16666      &0.472E+01, 0.497E+01, 0.522E+01, 0.547E+01, 0.572E+01/
16667
16668            pmass=0.14
16669        pmass1=0.938
16670        TWOPI=0.000001
16671        if(srt.le.1.22)return
16672 * 1.Calculate p(lab)  from srt [GeV]
16673 *   Formula used:   DSQRT(s) = 2 m DSQRT(E_kin/(2m) + 1)
16674         plab=SRT
16675       if (plab .lt. earray(1)) then
16676         TWOPI= 0.00001
16677         return
16678       end if
16679 *
16680 * 2.Interpolate double logarithmically to find sigma(srt)
16681 *
16682       do 1001 ie = 1,19
16683         if (earray(ie) .eq. plab) then
16684           TWOPI= xarray(ie)
16685           return
16686         else if (earray(ie) .gt. plab) then
16687           ymin = alog(xarray(ie-1))
16688           ymax = alog(xarray(ie))
16689           xmin = alog(earray(ie-1))
16690           xmax = alog(earray(ie))
16691           TWOPI= exp(ymin + (alog(plab)-xmin)*(ymax-ymin)
16692      &    /(xmax-xmin) )
16693           return
16694         end if
16695  1001   continue
16696       return
16697         END
16698 ******************************************
16699 ******************************************
16700 * for ppi(+)-->DELTA+RHO
16701 c      real*4 function THREPI(srt)
16702       real function THREPI(srt)
16703 *  This function contains the experimental pi+p-->DELTA + rho cross sections  *
16704 *  srt    = DSQRT(s) in GeV                                                   *
16705 *  xsec   = production cross section in mb                                    *
16706 *  earray = EXPerimental table with proton energies in MeV                    *
16707 *  xarray = EXPerimental table with cross sections in mb (curve to guide eye) *
16708 *                                                                             *
16709 ******************************************
16710 c      real*4   xarray(15), earray(15)
16711       real   xarray(15), earray(15)
16712       SAVE
16713       data xarray /8.0000000E-06,6.1999999E-05,1.881940,5.025690,
16714      &11.80154,13.92114,15.07308,11.79571,11.53772,10.01197,9.792673,
16715      &9.465264,8.970490,7.944254,6.886320/
16716       data earray /0.122E+01, 0.147E+01, 0.172E+01, 0.197E+01,
16717      &0.222E+01, 0.247E+01, 0.272E+01, 0.297E+01, 0.322E+01,
16718      &0.347E+01, 0.372E+01, 0.397E+01, 0.422E+01, 0.447E+01,
16719      &0.472E+01/
16720
16721            pmass=0.14
16722        pmass1=0.938
16723        THREPI=0.000001
16724        if(srt.le.1.36)return
16725 * 1.Calculate p(lab)  from srt [GeV]
16726 *   Formula used:   DSQRT(s) = 2 m DSQRT(E_kin/(2m) + 1)
16727         plab=SRT
16728       if (plab .lt. earray(1)) then
16729         THREPI = 0.00001
16730         return
16731       end if
16732 *
16733 * 2.Interpolate double logarithmically to find sigma(srt)
16734 *
16735       do 1001 ie = 1,15
16736         if (earray(ie) .eq. plab) then
16737           THREPI= xarray(ie)
16738           return
16739         else if (earray(ie) .gt. plab) then
16740           ymin = alog(xarray(ie-1))
16741           ymax = alog(xarray(ie))
16742           xmin = alog(earray(ie-1))
16743           xmax = alog(earray(ie))
16744           THREPI = exp(ymin + (alog(plab)-xmin)*(ymax-ymin)
16745      &    /(xmax-xmin) )
16746           return
16747         end if
16748  1001   continue
16749       return
16750         END
16751 ******************************************
16752 ******************************************
16753 * for ppi(+)-->DELTA+omega
16754 c      real*4 function FOURPI(srt)
16755       real function FOURPI(srt)
16756 *  This function contains the experimental pi+p-->DELTA+PION cross sections   *
16757 *  srt    = DSQRT(s) in GeV                                                   *
16758 *  xsec   = production cross section in mb                                    *
16759 *  earray = EXPerimental table with proton energies in MeV                    *
16760 *  xarray = EXPerimental table with cross sections in mb (curve to guide eye) *
16761 *                                                                             *
16762 ******************************************
16763 c      real*4   xarray(10), earray(10)
16764       real   xarray(10), earray(10)
16765       SAVE
16766       data xarray /0.0001,1.986597,6.411932,7.636956,
16767      &9.598362,9.889740,10.24317,10.80138,11.86988,12.83925/
16768       data earray /2.468,2.718,2.968,0.322E+01,
16769      &0.347E+01, 0.372E+01, 0.397E+01, 0.422E+01, 0.447E+01,
16770      &0.472E+01/
16771
16772            pmass=0.14
16773        pmass1=0.938
16774        FOURPI=0.000001
16775        if(srt.le.1.52)return
16776 * 1.Calculate p(lab)  from srt [GeV]
16777 *   Formula used:   DSQRT(s) = 2 m DSQRT(E_kin/(2m) + 1)
16778         plab=SRT
16779       if (plab .lt. earray(1)) then
16780         FOURPI= 0.00001
16781         return
16782       end if
16783 *
16784 * 2.Interpolate double logarithmically to find sigma(srt)
16785 *
16786       do 1001 ie = 1,10
16787         if (earray(ie) .eq. plab) then
16788           FOURPI= xarray(ie)
16789           return
16790         else if (earray(ie) .gt. plab) then
16791           ymin = alog(xarray(ie-1))
16792           ymax = alog(xarray(ie))
16793           xmin = alog(earray(ie-1))
16794           xmax = alog(earray(ie))
16795           FOURPI= exp(ymin + (alog(plab)-xmin)*(ymax-ymin)
16796      &    /(xmax-xmin) )
16797           return
16798         end if
16799  1001   continue
16800       return
16801         END
16802 ******************************************
16803 ******************************************
16804 * for pion (rho or omega)+baryon resonance collisions
16805 c      real*4 function reab(i1,i2,srt,ictrl)
16806       real function reab(i1,i2,srt,ictrl)
16807 *  This function calculates the cross section for
16808 *  pi+Delta(N*)-->N+PION process                                              *
16809 *  srt    = DSQRT(s) in GeV                                                   *
16810 *  reab   = cross section in fm**2                                            *
16811 *  ictrl=1,2,3 for pion, rho and omega+D(N*)
16812 ****************************************
16813       PARAMETER (MAXSTR=150001,MAXR=1,PI=3.1415926)
16814       parameter      (MX=4,MY=4,MZ=8,MPX=4,MPY=4,mpz=10,mpzp=10)
16815       PARAMETER      (AKA=0.498,ALA=1.1157,ASA=1.1974)
16816       parameter      (amn=0.938,ap1=0.14,arho=0.77,aomega=0.782)
16817        parameter       (maxx=20,maxz=24)
16818       COMMON   /AA/  R(3,MAXSTR)
16819 cc      SAVE /AA/
16820       COMMON   /BB/  P(3,MAXSTR)
16821 cc      SAVE /BB/
16822       COMMON   /CC/  E(MAXSTR)
16823 cc      SAVE /CC/
16824       COMMON  /DD/      RHO(-MAXX:MAXX,-MAXX:MAXX,-MAXZ:MAXZ),
16825      &                     RHOP(-MAXX:MAXX,-MAXX:MAXX,-MAXZ:MAXZ),
16826      &                     RHON(-MAXX:MAXX,-MAXX:MAXX,-MAXZ:MAXZ)
16827 cc      SAVE /DD/
16828       COMMON  /EE/      ID(MAXSTR),LB(MAXSTR)
16829 cc      SAVE /EE/
16830       SAVE
16831        LB1=LB(I1)
16832        LB2=LB(I2)
16833        reab=0
16834        if(ictrl.eq.1.and.srt.le.(amn+2.*ap1+0.02))return
16835        if(ictrl.eq.3.and.srt.le.(amn+ap1+aomega+0.02))return
16836        pin2=((srt**2+ap1**2-amn**2)/(2.*srt))**2-ap1**2
16837        if(pin2.le.0)return
16838 * for pion+D(N*)-->pion+N
16839        if(ictrl.eq.1)then
16840        if(e(i1).gt.1)then
16841        ed=e(i1)
16842        else
16843        ed=e(i2)
16844        endif
16845        pout2=((srt**2+ap1**2-ed**2)/(2.*srt))**2-ap1**2
16846        if(pout2.le.0)return
16847        xpro=twopi(srt)/10.
16848        factor=1/3.
16849        if( ((lb1.eq.8.and.lb2.eq.5).or.
16850      &    (lb1.eq.5.and.lb2.eq.8))
16851      &        .OR.((lb1.eq.-8.and.lb2.eq.3).or.
16852      &    (lb1.eq.3.and.lb2.eq.-8)) )factor=1/4.
16853        if((iabs(lb1).ge.10.and.iabs(lb1).le.13).
16854      &  or.(iabs(lb2).ge.10.and.iabs(lb2).le.13))factor=1.
16855        reab=factor*pin2/pout2*xpro
16856        return
16857        endif
16858 * for rho reabsorption
16859        if(ictrl.eq.2)then
16860        if(lb(i2).ge.25)then
16861        ed=e(i1)
16862        arho1=e(i2)
16863        else
16864        ed=e(i2)
16865        arho1=e(i1)
16866        endif
16867        if(srt.le.(amn+ap1+arho1+0.02))return
16868        pout2=((srt**2+arho1**2-ed**2)/(2.*srt))**2-arho1**2
16869        if(pout2.le.0)return
16870        xpro=threpi(srt)/10.
16871        factor=1/3.
16872        if( ((lb1.eq.8.and.lb2.eq.27).or.
16873      &       (lb1.eq.27.and.lb2.eq.8))
16874      & .OR. ((lb1.eq.-8.and.lb2.eq.25).or.
16875      &       (lb1.eq.25.and.lb2.eq.-8)) )factor=1/4.
16876        if((iabs(lb1).ge.10.and.iabs(lb1).le.13).
16877      &  or.(iabs(lb2).ge.10.and.iabs(lb2).le.13))factor=1.
16878        reab=factor*pin2/pout2*xpro
16879        return
16880        endif
16881 * for omega reabsorption
16882        if(ictrl.eq.3)then
16883        if(e(i1).gt.1)ed=e(i1)
16884        if(e(i2).gt.1)ed=e(i2)
16885        pout2=((srt**2+aomega**2-ed**2)/(2.*srt))**2-aomega**2
16886        if(pout2.le.0)return
16887        xpro=fourpi(srt)/10.
16888        factor=1/6.
16889        if((iabs(lb1).ge.10.and.iabs(lb1).le.13).
16890      &  or.(iabs(lb2).ge.10.and.iabs(lb2).le.13))factor=1./3.
16891        reab=factor*pin2/pout2*xpro
16892        endif
16893       return
16894         END
16895 ******************************************
16896 * for the reabsorption of two resonances
16897 * This function calculates the cross section for
16898 * DD-->NN, N*N*-->NN and DN*-->NN
16899 c      real*4 function reab2d(i1,i2,srt)
16900       real function reab2d(i1,i2,srt)
16901 *  srt    = DSQRT(s) in GeV                                                   *
16902 *  reab   = cross section in mb
16903 ****************************************
16904       PARAMETER      (MAXSTR=150001,MAXR=1,PI=3.1415926)
16905       parameter      (MX=4,MY=4,MZ=8,MPX=4,MPY=4,mpz=10,mpzp=10)
16906       PARAMETER      (AKA=0.498,ALA=1.1157,ASA=1.1974)
16907       parameter      (amn=0.938,ap1=0.14,arho=0.77,aomega=0.782)
16908        parameter       (maxx=20,maxz=24)
16909       COMMON   /AA/  R(3,MAXSTR)
16910 cc      SAVE /AA/
16911       COMMON   /BB/  P(3,MAXSTR)
16912 cc      SAVE /BB/
16913       COMMON   /CC/  E(MAXSTR)
16914 cc      SAVE /CC/
16915       COMMON  /DD/      RHO(-MAXX:MAXX,-MAXX:MAXX,-MAXZ:MAXZ),
16916      &                     RHOP(-MAXX:MAXX,-MAXX:MAXX,-MAXZ:MAXZ),
16917      &                     RHON(-MAXX:MAXX,-MAXX:MAXX,-MAXZ:MAXZ)
16918 cc      SAVE /DD/
16919       COMMON  /EE/      ID(MAXSTR),LB(MAXSTR)
16920 cc      SAVE /EE/
16921       SAVE
16922        reab2d=0
16923        LB1=iabs(LB(I1))
16924        LB2=iabs(LB(I2))
16925        ed1=e(i1)
16926        ed2=e(i2)
16927        pin2=(srt/2.)**2-amn**2
16928        pout2=((srt**2+ed1**2-ed2**2)/(2.*srt))**2-ed1**2
16929        if(pout2.le.0)return
16930        xpro=x2pi(srt)
16931        factor=1/4.
16932        if((lb1.ge.10.and.lb1.le.13).and.
16933      &    (lb2.ge.10.and.lb2.le.13))factor=1.
16934        if((lb1.ge.6.and.lb1.le.9).and.
16935      &    (lb2.gt.10.and.lb2.le.13))factor=1/2.
16936        if((lb2.ge.6.and.lb2.le.9).and.
16937      &    (lb1.gt.10.and.lb1.le.13))factor=1/2.
16938        reab2d=factor*pin2/pout2*xpro
16939        return
16940        end
16941 ***************************************
16942       SUBROUTINE rotate(PX0,PY0,PZ0,px,py,pz)
16943       SAVE
16944 * purpose: rotate the momentum of a particle in the CMS of p1+p2 such that
16945 * the x' y' and z' in the cms of p1+p2 is the same as the fixed x y and z
16946 * quantities:
16947 *            px0,py0 and pz0 are the cms momentum of the incoming colliding
16948 *            particles
16949 *            px, py and pz are the cms momentum of any one of the particles
16950 *            after the collision to be rotated
16951 ***************************************
16952 * the momentum, polar and azimuthal angles of the incoming momentm
16953       PR0  = SQRT( PX0**2 + PY0**2 + PZ0**2 )
16954       IF(PR0.EQ.0)PR0=0.00000001
16955       C2  = PZ0 / PR0
16956       IF(PX0 .EQ. 0.0 .AND. PY0 .EQ. 0.0) THEN
16957         T2 = 0.0
16958       ELSE
16959         T2=ATAN2(PY0,PX0)
16960       END IF
16961       S2  =  SQRT( 1.0 - C2**2 )
16962       CT2  = COS(T2)
16963       ST2  = SIN(T2)
16964 * the momentum, polar and azimuthal angles of the momentum to be rotated
16965       PR=SQRT(PX**2+PY**2+PZ**2)
16966       IF(PR.EQ.0)PR=0.0000001
16967       C1=PZ/PR
16968       IF(PX.EQ.0.AND.PY.EQ.0)THEN
16969       T1=0.
16970       ELSE
16971       T1=ATAN2(PY,PX)
16972       ENDIF
16973       S1   = SQRT( 1.0 - C1**2 )
16974       CT1  = COS(T1)
16975       ST1  = SIN(T1)
16976       SS   = C2 * S1 * CT1  +  S2 * C1
16977 * THE MOMENTUM AFTER ROTATION
16978       PX   = PR * ( SS*CT2 - S1*ST1*ST2 )
16979       PY   = PR * ( SS*ST2 + S1*ST1*CT2 )
16980       PZ   = PR * ( C1*C2 - S1*S2*CT1 )
16981       RETURN
16982       END
16983 ******************************************
16984 c      real*4 function Xpp(srt)
16985       real function Xpp(srt)
16986 *  This function contains the experimental total n-p cross sections           *
16987 *  srt    = DSQRT(s) in GeV                                                   *
16988 *  xsec   = production cross section in mb                                    *
16989 *  earray = EXPerimental table with proton energies in MeV                    *
16990 *  xarray = EXPerimental table with cross sections in mb (curve to guide eye) *
16991 *  WITH A CUTOFF AT 55MB                                                      *
16992 ******************************************
16993 c      real*4   xarray(14), earray(14)
16994       real   xarray(14), earray(14)
16995       SAVE
16996       data earray /20.,30.,40.,60.,80.,100.,
16997      &170.,250.,310.,
16998      &350.,460.,560.,660.,800./
16999       data xarray /150.,90.,80.6,48.0,36.6,
17000      &31.6,25.9,24.0,23.1,
17001      &24.0,28.3,33.6,41.5,47/
17002
17003       xpp=0.
17004        pmass=0.9383
17005 * 1.Calculate E_kin(lab) [MeV] from srt [GeV]
17006 *   Formula used:   DSQRT(s) = 2 m DSQRT(E_kin/(2m) + 1)
17007       ekin = 2000.*pmass*((srt/(2.*pmass))**2 - 1.)
17008       if (ekin .lt. earray(1)) then
17009         xpp = xarray(1)
17010        IF(XPP.GT.55)XPP=55
17011         return
17012       end if
17013        IF(EKIN.GT.EARRAY(14))THEN
17014        XPP=XARRAY(14)
17015        RETURN
17016        ENDIF
17017 *
17018 *
17019 * 2.Interpolate double logarithmically to find sigma(srt)
17020 *
17021       do 1001 ie = 1,14
17022         if (earray(ie) .eq. ekin) then
17023           xPP= xarray(ie)
17024        if(xpp.gt.55)xpp=55.
17025           return
17026        endif
17027         if (earray(ie) .gt. ekin) then
17028           ymin = alog(xarray(ie-1))
17029           ymax = alog(xarray(ie))
17030           xmin = alog(earray(ie-1))
17031           xmax = alog(earray(ie))
17032           XPP = exp(ymin + (alog(ekin)-xmin)
17033      &          *(ymax-ymin)/(xmax-xmin) )
17034        IF(XPP.GT.55)XPP=55.
17035        go to 50
17036         end if
17037  1001 continue
17038 50       continue
17039         return
17040         END
17041 ******************************************
17042       real function Xnp(srt)
17043 *  This function contains the experimental total n-p cross sections           *
17044 *  srt    = DSQRT(s) in GeV                                                   *
17045 *  xsec   = production cross section in mb                                    *
17046 *  earray = EXPerimental table with proton energies in MeV                    *
17047 *  xarray = EXPerimental table with cross sections in mb (curve to guide eye) *
17048 *  WITH  A CUTOFF AT 55MB                                                *
17049 ******************************************
17050 c      real*4   xarray(11), earray(11)
17051       real   xarray(11), earray(11)
17052       SAVE
17053       data   earray /20.,30.,40.,60.,90.,135.0,200.,
17054      &300.,400.,600.,800./
17055       data  xarray / 410.,270.,214.5,130.,78.,53.5,
17056      &41.6,35.9,34.2,34.3,34.9/
17057
17058        xnp=0.
17059        pmass=0.9383
17060 * 1.Calculate E_kin(lab) [MeV] from srt [GeV]
17061 *   Formula used:   DSQRT(s) = 2 m DSQRT(E_kin/(2m) + 1)
17062       ekin = 2000.*pmass*((srt/(2.*pmass))**2 - 1.)
17063       if (ekin .lt. earray(1)) then
17064         xnp = xarray(1)
17065        IF(XNP.GT.55)XNP=55
17066         return
17067       end if
17068        IF(EKIN.GT.EARRAY(11))THEN
17069        XNP=XARRAY(11)
17070        RETURN
17071        ENDIF
17072 *
17073 *Interpolate double logarithmically to find sigma(srt)
17074 *
17075       do 1001 ie = 1,11
17076         if (earray(ie) .eq. ekin) then
17077           xNP = xarray(ie)
17078          if(xnp.gt.55)xnp=55.
17079           return
17080        endif
17081         if (earray(ie) .gt. ekin) then
17082           ymin = alog(xarray(ie-1))
17083           ymax = alog(xarray(ie))
17084           xmin = alog(earray(ie-1))
17085           xmax = alog(earray(ie))
17086           xNP = exp(ymin + (alog(ekin)-xmin)
17087      &          *(ymax-ymin)/(xmax-xmin) )
17088        IF(XNP.GT.55)XNP=55
17089        go to 50
17090         end if
17091  1001 continue
17092 50       continue
17093         return
17094         END
17095 *******************************
17096        function ptr(ptmax,iseed)
17097 * (2) Generate the transverse momentum
17098 *     OF nucleons
17099 *******************************
17100         COMMON/TABLE/ xarray(0:1000),earray(0:1000)
17101 cc      SAVE /TABLE/
17102       COMMON/RNDF77/NSEED
17103 cc      SAVE /RNDF77/
17104       SAVE
17105        ISEED=ISEED
17106        ptr=0.
17107        if(ptmax.le.1.e-02)then
17108        ptr=ptmax
17109        return
17110        endif
17111        if(ptmax.gt.2.01)ptmax=2.01
17112        tryial=ptdis(ptmax)/ptdis(2.01)
17113        XT=RANART(NSEED)*tryial
17114 * look up the table and
17115 *Interpolate double logarithmically to find pt
17116         do 50 ie = 1,200
17117         if (earray(ie) .eq. xT) then
17118           ptr = xarray(ie)
17119        return
17120        end if
17121           if(xarray(ie-1).le.0.00001)go to 50
17122           if(xarray(ie).le.0.00001)go to 50
17123           if(earray(ie-1).le.0.00001)go to 50
17124           if(earray(ie).le.0.00001)go to 50
17125         if (earray(ie) .gt. xT) then
17126           ymin = alog(xarray(ie-1))
17127           ymax = alog(xarray(ie))
17128           xmin = alog(earray(ie-1))
17129           xmax = alog(earray(ie))
17130           ptr= exp(ymin + (alog(xT)-xmin)*(ymax-ymin)
17131      &    /(xmax-xmin) )
17132        if(ptr.gt.ptmax)ptr=ptmax
17133        return
17134        endif
17135 50      continue
17136        return
17137        end
17138
17139 **********************************
17140 **********************************
17141 *                                                                      *
17142 *                                                                      *
17143       SUBROUTINE XND(px,py,pz,srt,I1,I2,xinel,
17144      &               sigk,xsk1,xsk2,xsk3,xsk4,xsk5)
17145 *     PURPOSE:                                                         *
17146 *             calculate NUCLEON-BARYON RESONANCE inelatic Xsection     *
17147 *     NOTE   :                                                         *
17148 *     QUANTITIES:                                                 *
17149 *                      CHANNELS. M12 IS THE REVERSAL CHANNEL OF N12    *
17150 *                      N12,                                            *
17151 *                      M12=1 FOR p+n-->delta(+)+ n                     *
17152 *                          2     p+n-->delta(0)+ p                     *
17153 *                          3     p+p-->delta(++)+n                     *
17154 *                          4     p+p-->delta(+)+p                      *
17155 *                          5     n+n-->delta(0)+n                      *
17156 *                          6     n+n-->delta(-)+p                      *
17157 *                          7     n+p-->N*(0)(1440)+p                   *
17158 *                          8     n+p-->N*(+)(1440)+n                   *
17159 *                        9     p+p-->N*(+)(1535)+p                     *
17160 *                        10    n+n-->N*(0)(1535)+n                     *
17161 *                         11    n+p-->N*(+)(1535)+n                     *
17162 *                        12    n+p-->N*(0)(1535)+p
17163 *                        13    D(++)+D(-)-->N*(+)(1440)+n
17164 *                         14    D(++)+D(-)-->N*(0)(1440)+p
17165 *                        15    D(+)+D(0)--->N*(+)(1440)+n
17166 *                        16    D(+)+D(0)--->N*(0)(1440)+p
17167 *                        17    D(++)+D(0)-->N*(+)(1535)+p
17168 *                        18    D(++)+D(-)-->N*(0)(1535)+p
17169 *                        19    D(++)+D(-)-->N*(+)(1535)+n
17170 *                        20    D(+)+D(+)-->N*(+)(1535)+p
17171 *                        21    D(+)+D(0)-->N*(+)(1535)+n
17172 *                        22    D(+)+D(0)-->N*(0)(1535)+p
17173 *                        23    D(+)+D(-)-->N*(0)(1535)+n
17174 *                        24    D(0)+D(0)-->N*(0)(1535)+n
17175 *                          25    N*(+)(14)+N*(+)(14)-->N*(+)(15)+p
17176 *                          26    N*(0)(14)+N*(0)(14)-->N*(0)(15)+n
17177 *                          27    N*(+)(14)+N*(0)(14)-->N*(+)(15)+n
17178 *                        28    N*(+)(14)+N*(0)(14)-->N*(0)(15)+p
17179 *                        29    N*(+)(14)+D+-->N*(+)(15)+p
17180 *                        30    N*(+)(14)+D0-->N*(+)(15)+n
17181 *                        31    N*(+)(14)+D(-)-->N*(0)(1535)+n
17182 *                        32    N*(0)(14)+D++--->N*(+)(15)+p
17183 *                        33    N*(0)(14)+D+--->N*(+)(15)+n
17184 *                        34    N*(0)(14)+D+--->N*(0)(15)+p
17185 *                        35    N*(0)(14)+D0-->N*(0)(15)+n
17186 *                        36    N*(+)(14)+D0--->N*(0)(15)+p
17187 *                            and more
17188 ***********************************
17189         PARAMETER (MAXSTR=150001,MAXR=1,AMN=0.939457,
17190      1  AMP=0.93828,AP1=0.13496,AKA=0.498,APHI=1.020,
17191      2  AP2=0.13957,AM0=1.232,PI=3.1415926,CUTOFF=1.8966,AVMASS=0.9383)
17192         parameter     (MX=4,MY=4,MZ=8,MPX=4,MPY=4,mpz=10,mpzp=10)
17193         COMMON /AA/ R(3,MAXSTR)
17194 cc      SAVE /AA/
17195         COMMON /BB/ P(3,MAXSTR)
17196 cc      SAVE /BB/
17197         COMMON /CC/ E(MAXSTR)
17198 cc      SAVE /CC/
17199         COMMON /EE/ ID(MAXSTR),LB(MAXSTR)
17200 cc      SAVE /EE/
17201         common /ff/f(-mx:mx,-my:my,-mz:mz,-mpx:mpx,-mpy:mpy,-mpz:mpzp)
17202 cc      SAVE /ff/
17203         common /gg/ dx,dy,dz,dpx,dpy,dpz
17204 cc      SAVE /gg/
17205         COMMON /INPUT/ NSTAR,NDIRCT,DIR
17206 cc      SAVE /INPUT/
17207         COMMON /NN/NNN
17208 cc      SAVE /NN/
17209         COMMON /BG/BETAX,BETAY,BETAZ,GAMMA
17210 cc      SAVE /BG/
17211         COMMON   /RUN/NUM
17212 cc      SAVE /RUN/
17213         COMMON   /PA/RPION(3,MAXSTR,MAXR)
17214 cc      SAVE /PA/
17215         COMMON   /PB/PPION(3,MAXSTR,MAXR)
17216 cc      SAVE /PB/
17217         COMMON   /PC/EPION(MAXSTR,MAXR)
17218 cc      SAVE /PC/
17219         COMMON   /PD/LPION(MAXSTR,MAXR)
17220 cc      SAVE /PD/
17221         common/input1/ MASSPR,MASSTA,ISEED,IAVOID,DT
17222 cc      SAVE /input1/
17223       SAVE
17224
17225 *-----------------------------------------------------------------------
17226        xinel=0.
17227        sigk=0
17228        xsk1=0
17229        xsk2=0
17230        xsk3=0
17231        xsk4=0
17232        xsk5=0
17233         EM1=E(I1)
17234         EM2=E(I2)
17235       PR  = SQRT( PX**2 + PY**2 + PZ**2 )
17236 *     CAN HAPPEN ANY MORE ==> RETURN (2.04 = 2*AVMASS + PI-MASS+0.02)
17237         IF (SRT .LT. 2.04) RETURN
17238 * Resonance absorption or Delta + N-->N*(1440), N*(1535)
17239 * COM: TEST FOR DELTA OR N* ABSORPTION
17240 *      IN THE PROCESS DELTA+N-->NN, N*+N-->NN
17241         PRF=SQRT(0.25*SRT**2-AVMASS**2)
17242         IF(EM1.GT.1.)THEN
17243         DELTAM=EM1
17244         ELSE
17245         DELTAM=EM2
17246         ENDIF
17247         RENOM=DELTAM*PRF**2/DENOM(SRT,1.)/PR
17248         RENOMN=DELTAM*PRF**2/DENOM(SRT,2.)/PR
17249         RENOM1=DELTAM*PRF**2/DENOM(SRT,-1.)/PR
17250 * avoid the inelastic collisions between n+delta- -->N+N
17251 *       and p+delta++ -->N+N due to charge conservation,
17252 *       but they can scatter to produce kaons
17253        if((iabs(lb(i1)).eq.2).and.(iabs(lb(i2)).eq.6)) renom=0.
17254        if((iabs(lb(i2)).eq.2).and.(iabs(lb(i1)).eq.6)) renom=0.
17255        if((iabs(lb(i1)).eq.1).and.(iabs(lb(i2)).eq.9)) renom=0.
17256        if((iabs(lb(i2)).eq.1).and.(iabs(lb(i1)).eq.9)) renom=0.
17257        Call M1535(iabs(lb(i1)),iabs(lb(i2)),srt,x1535)
17258         X1440=(3./4.)*SIGMA(SRT,2,0,1)
17259 * CROSS SECTION FOR KAON PRODUCTION from the four channels
17260 * for NLK channel
17261        akp=0.498
17262        ak0=0.498
17263        ana=0.94
17264        ada=1.232
17265        al=1.1157
17266        as=1.1197
17267        xsk1=0
17268        xsk2=0
17269        xsk3=0
17270        xsk4=0
17271 c      !! phi production
17272        xsk5=0
17273        t1nlk=ana+al+akp
17274        if(srt.le.t1nlk)go to 222
17275        XSK1=1.5*PPLPK(SRT)
17276 * for DLK channel
17277        t1dlk=ada+al+akp
17278        t2dlk=ada+al-akp
17279        if(srt.le.t1dlk)go to 222
17280        es=srt
17281        pmdlk2=(es**2-t1dlk**2)*(es**2-t2dlk**2)/(4.*es**2)
17282        pmdlk=sqrt(pmdlk2)
17283        XSK3=1.5*PPLPK(srt)
17284 * for NSK channel
17285        t1nsk=ana+as+akp
17286        t2nsk=ana+as-akp
17287        if(srt.le.t1nsk)go to 222
17288        pmnsk2=(es**2-t1nsk**2)*(es**2-t2nsk**2)/(4.*es**2)
17289        pmnsk=sqrt(pmnsk2)
17290        XSK2=1.5*(PPK1(srt)+PPK0(srt))
17291 * for DSK channel
17292        t1DSk=aDa+aS+akp
17293        t2DSk=aDa+aS-akp
17294        if(srt.le.t1dsk)go to 222
17295        pmDSk2=(es**2-t1DSk**2)*(es**2-t2DSk**2)/(4.*es**2)
17296        pmDSk=sqrt(pmDSk2)
17297        XSK4=1.5*(PPK1(srt)+PPK0(srt))
17298 csp11/21/01
17299 c phi production
17300        if(srt.le.(2.*amn+aphi))go to 222
17301 c  !! mb put the correct form
17302          xsk5 = 0.0001
17303 csp11/21/01 end
17304
17305 * THE TOTAL KAON+ PRODUCTION CROSS SECTION IS THEN
17306 222       SIGK=XSK1+XSK2+XSK3+XSK4
17307
17308 cbz3/7/99 neutralk
17309         XSK1 = 2.0 * XSK1
17310         XSK2 = 2.0 * XSK2
17311         XSK3 = 2.0 * XSK3
17312         XSK4 = 2.0 * XSK4
17313         SIGK = 2.0 * SIGK + xsk5
17314 cbz3/7/99 neutralk end
17315
17316 * avoid the inelastic collisions between n+delta- -->N+N
17317 *       and p+delta++ -->N+N due to charge conservation,
17318 *       but they can scatter to produce kaons
17319        if(((iabs(lb(i1)).eq.2).and.(iabs(lb(i2)).eq.6)).OR.
17320      &         ((iabs(lb(i2)).eq.2).and.(iabs(lb(i1)).eq.6)).OR.
17321      &         ((iabs(lb(i1)).eq.1).and.(iabs(lb(i2)).eq.9)).OR.
17322      &         ((iabs(lb(i2)).eq.1).and.(iabs(lb(i1)).eq.9)))THEN
17323        xinel=sigk
17324        return
17325        ENDIF
17326 * WE DETERMINE THE REACTION CHANNELS IN THE FOLLOWING
17327 * FOR n+delta(++)-->p+p or n+delta(++)-->n+N*(+)(1440),n+N*(+)(1535)
17328 * REABSORPTION OR N*(1535) PRODUCTION LIKE IN P+P OR N*(1440) LIKE PN,
17329         IF(LB(I1)*LB(I2).EQ.18.AND.
17330      &    (iabs(LB(I1)).EQ.2.OR.iabs(LB(I2)).EQ.2))then
17331         SIGND=SIGMA(SRT,1,1,0)+0.5*SIGMA(SRT,1,1,1)
17332         SIGDN=0.25*SIGND*RENOM
17333         xinel=SIGDN+X1440+X1535+SIGK
17334        RETURN
17335        endif
17336 * FOR p+delta(-)-->n+n or p+delta(-)-->n+N*(0)(1440),n+N*(0)(1535)
17337 * REABSORPTION OR N*(1535) PRODUCTION LIKE IN P+P OR N*(1440) LIKE PN,
17338         IF(LB(I1)*LB(I2).EQ.6.AND.
17339      &    (iabs(LB(I1)).EQ.1.OR.iabs(LB(I2)).EQ.1))THEN
17340         SIGND=SIGMA(SRT,1,1,0)+0.5*SIGMA(SRT,1,1,1)
17341         SIGDN=0.25*SIGND*RENOM
17342         xinel=SIGDN+X1440+X1535+SIGK
17343        RETURN
17344        endif
17345 * FOR p+delta(+)-->p+p, N*(+)(144)+p, N*(+)(1535)+p
17346 cbz11/25/98
17347         IF(LB(I1)*LB(I2).EQ.8.AND.
17348      &    (iabs(LB(I1)).EQ.1.OR.iabs(LB(I2)).EQ.1))THEN
17349         SIGND=1.5*SIGMA(SRT,1,1,1)
17350         SIGDN=0.25*SIGND*RENOM
17351         xinel=SIGDN+x1440+x1535+SIGK
17352        RETURN
17353        endif
17354 * FOR n+delta(0)-->n+n, N*(0)(144)+n, N*(0)(1535)+n
17355         IF(LB(I1)*LB(I2).EQ.14.AND.
17356      &   (iabs(LB(I1)).EQ.2.AND.iabs(LB(I2)).EQ.2))THEN
17357         SIGND=1.5*SIGMA(SRT,1,1,1)
17358         SIGDN=0.25*SIGND*RENOM
17359         xinel=SIGDN+x1440+x1535+SIGK
17360        RETURN
17361        endif
17362 * FOR n+delta(+)-->n+p, N*(+)(1440)+n,N*(0)(1440)+p,
17363 *                       N*(+)(1535)+n,N*(0)(1535)+p
17364         IF(LB(I1)*LB(I2).EQ.16.AND.
17365      &     (iabs(LB(I1)).EQ.2.OR.iabs(LB(I2)).EQ.2))THEN
17366         SIGND=0.5*SIGMA(SRT,1,1,1)+0.25*SIGMA(SRT,1,1,0)
17367         SIGDN=0.5*SIGND*RENOM
17368         xinel=SIGDN+2.*x1440+2.*x1535+SIGK
17369        RETURN
17370        endif
17371 * FOR p+delta(0)-->n+p, N*(+)(1440)+n,N*(0)(1440)+p,
17372 *                       N*(+)(1535)+n,N*(0)(1535)+p
17373         IF(LB(I1)*LB(I2).EQ.7)THEN
17374         SIGND=0.5*SIGMA(SRT,1,1,1)+0.25*SIGMA(SRT,1,1,0)
17375         SIGDN=0.5*SIGND*RENOM
17376         xinel=SIGDN+2.*x1440+2.*x1535+SIGK
17377        RETURN
17378        endif
17379 * FOR p+N*(0)(14)-->p+n, N*(+)(1535)+n,N*(0)(1535)+p
17380 * OR  P+N*(0)(14)-->D(+)+N, D(0)+P,
17381         IF(LB(I1)*LB(I2).EQ.10.AND.
17382      &   (iabs(LB(I1)).EQ.1.OR.iabs(LB(I2)).EQ.1))then
17383         SIGND=(3./4.)*SIGMA(SRT,2,0,1)
17384         SIGDN=SIGND*RENOMN
17385         xinel=SIGDN+X1535+SIGK
17386        RETURN
17387        endif
17388 * FOR n+N*(+)-->p+n, N*(+)(1535)+n,N*(0)(1535)+p
17389         IF(LB(I1)*LB(I2).EQ.22.AND.
17390      &   (iabs(LB(I1)).EQ.2.OR.iabs(LB(I2)).EQ.2))then
17391         SIGND=(3./4.)*SIGMA(SRT,2,0,1)
17392         SIGDN=SIGND*RENOMN
17393         xinel=SIGDN+X1535+SIGK
17394        RETURN
17395        endif
17396 * FOR N*(1535)+N-->N+N COLLISIONS
17397         IF((iabs(LB(I1)).EQ.12).OR.(iabs(LB(I1)).EQ.13).OR.
17398      1  (iabs(LB(I2)).EQ.12).OR.(iabs(LB(I2)).EQ.13))THEN
17399         SIGND=X1535
17400         SIGDN=SIGND*RENOM1
17401         xinel=SIGDN+SIGK
17402        RETURN
17403        endif
17404         RETURN
17405        end
17406 **********************************
17407 *                                                                      *
17408 *                                                                      *
17409       SUBROUTINE XDDIN(PX,PY,PZ,SRT,I1,I2,
17410      &XINEL,SIGK,XSK1,XSK2,XSK3,XSK4,XSK5)
17411 *     PURPOSE:                                                         *
17412 *             DEALING WITH BARYON RESONANCE-BARYON RESONANCE COLLISIONS*
17413 *     NOTE   :                                                         *
17414 *           VALID ONLY FOR BARYON-BARYON-DISTANCES LESS THAN 1.32 FM   *
17415 *           (1.32 = 2 * HARD-CORE-RADIUS [HRC] )                       *
17416 *     QUANTITIES:                                                 *
17417 *           PX,PY,PZ - MOMENTUM COORDINATES OF ONE PARTICLE IN CM FRAME*
17418 *           SRT      - SQRT OF S                                       *
17419 *           NSTAR =1 INCLUDING N* RESORANCE,ELSE NOT                   *
17420 *           NDIRCT=1 INCLUDING DIRECT PION PRODUCTION PROCESS         *
17421 *           IBLOCK   - THE INFORMATION BACK                            *
17422 *                      0-> COLLISION CANNOT HAPPEN                     *
17423 *                      1-> N-N ELASTIC COLLISION                       *
17424 *                      2-> N+N->N+DELTA,OR N+N->N+N* REACTION          *
17425 *                      3-> N+DELTA->N+N OR N+N*->N+N REACTION          *
17426 *                      4-> N+N->N+N+PION,DIRTCT PROCESS                *
17427 *                     5-> DELTA(N*)+DELTA(N*)   TOTAL   COLLISIONS    *
17428 *           N12       - IS USED TO SPECIFY BARYON-BARYON REACTION      *
17429 *                      CHANNELS. M12 IS THE REVERSAL CHANNEL OF N12    *
17430 *                      N12,                                            *
17431 *                      M12=1 FOR p+n-->delta(+)+ n                     *
17432 *                          2     p+n-->delta(0)+ p                     *
17433 *                          3     p+p-->delta(++)+n                     *
17434 *                          4     p+p-->delta(+)+p                      *
17435 *                          5     n+n-->delta(0)+n                      *
17436 *                          6     n+n-->delta(-)+p                      *
17437 *                          7     n+p-->N*(0)(1440)+p                   *
17438 *                          8     n+p-->N*(+)(1440)+n                   *
17439 *                        9     p+p-->N*(+)(1535)+p                     *
17440 *                        10    n+n-->N*(0)(1535)+n                     *
17441 *                         11    n+p-->N*(+)(1535)+n                     *
17442 *                        12    n+p-->N*(0)(1535)+p
17443 *                        13    D(++)+D(-)-->N*(+)(1440)+n
17444 *                         14    D(++)+D(-)-->N*(0)(1440)+p
17445 *                        15    D(+)+D(0)--->N*(+)(1440)+n
17446 *                        16    D(+)+D(0)--->N*(0)(1440)+p
17447 *                        17    D(++)+D(0)-->N*(+)(1535)+p
17448 *                        18    D(++)+D(-)-->N*(0)(1535)+p
17449 *                        19    D(++)+D(-)-->N*(+)(1535)+n
17450 *                        20    D(+)+D(+)-->N*(+)(1535)+p
17451 *                        21    D(+)+D(0)-->N*(+)(1535)+n
17452 *                        22    D(+)+D(0)-->N*(0)(1535)+p
17453 *                        23    D(+)+D(-)-->N*(0)(1535)+n
17454 *                        24    D(0)+D(0)-->N*(0)(1535)+n
17455 *                          25    N*(+)(14)+N*(+)(14)-->N*(+)(15)+p
17456 *                          26    N*(0)(14)+N*(0)(14)-->N*(0)(15)+n
17457 *                          27    N*(+)(14)+N*(0)(14)-->N*(+)(15)+n
17458 *                        28    N*(+)(14)+N*(0)(14)-->N*(0)(15)+p
17459 *                        29    N*(+)(14)+D+-->N*(+)(15)+p
17460 *                        30    N*(+)(14)+D0-->N*(+)(15)+n
17461 *                        31    N*(+)(14)+D(-)-->N*(0)(1535)+n
17462 *                        32    N*(0)(14)+D++--->N*(+)(15)+p
17463 *                        33    N*(0)(14)+D+--->N*(+)(15)+n
17464 *                        34    N*(0)(14)+D+--->N*(0)(15)+p
17465 *                        35    N*(0)(14)+D0-->N*(0)(15)+n
17466 *                        36    N*(+)(14)+D0--->N*(0)(15)+p
17467 *                        +++
17468 *               AND MORE CHANNELS AS LISTED IN THE NOTE BOOK
17469 *
17470 * NOTE ABOUT N*(1440) RESORANCE:                                       *
17471 *     As it has been discussed in VerWest's paper,I= 1 (initial isospin)
17472 *     channel can all be attributed to delta resorance while I= 0      *
17473 *     channel can all be  attribured to N* resorance.Only in n+p       *
17474 *     one can have I=0 channel so is the N*(1440) resorance            *
17475 * REFERENCES:    J. CUGNON ET AL., NUCL. PHYS. A352, 505 (1981)        *
17476 *                    Y. KITAZOE ET AL., PHYS. LETT. 166B, 35 (1986)    *
17477 *                    B. VerWest el al., PHYS. PRV. C25 (1982)1979      *
17478 *                    Gy. Wolf  et al, Nucl Phys A517 (1990) 615        *
17479 *                    CUTOFF = 2 * AVMASS + 20 MEV                      *
17480 *                                                                      *
17481 *       for N*(1535) we use the parameterization by Gy. Wolf et al     *
17482 *       Nucl phys A552 (1993) 349, added May 18, 1994                  *
17483 **********************************
17484         PARAMETER (MAXSTR=150001,MAXR=1,AMN=0.939457,
17485      1  AMP=0.93828,AP1=0.13496,AKA=0.498,APHI=1.020,
17486      2  AP2=0.13957,AM0=1.232,PI=3.1415926,CUTOFF=1.8966,AVMASS=0.9383)
17487         parameter     (MX=4,MY=4,MZ=8,MPX=4,MPY=4,mpz=10,mpzp=10)
17488         COMMON /AA/ R(3,MAXSTR)
17489 cc      SAVE /AA/
17490         COMMON /BB/ P(3,MAXSTR)
17491 cc      SAVE /BB/
17492         COMMON /CC/ E(MAXSTR)
17493 cc      SAVE /CC/
17494         COMMON /EE/ ID(MAXSTR),LB(MAXSTR)
17495 cc      SAVE /EE/
17496         common /ff/f(-mx:mx,-my:my,-mz:mz,-mpx:mpx,-mpy:mpy,-mpz:mpzp)
17497 cc      SAVE /ff/
17498         common /gg/ dx,dy,dz,dpx,dpy,dpz
17499 cc      SAVE /gg/
17500         COMMON /INPUT/ NSTAR,NDIRCT,DIR
17501 cc      SAVE /INPUT/
17502         COMMON /NN/NNN
17503 cc      SAVE /NN/
17504         COMMON /BG/BETAX,BETAY,BETAZ,GAMMA
17505 cc      SAVE /BG/
17506         COMMON   /RUN/NUM
17507 cc      SAVE /RUN/
17508         COMMON   /PA/RPION(3,MAXSTR,MAXR)
17509 cc      SAVE /PA/
17510         COMMON   /PB/PPION(3,MAXSTR,MAXR)
17511 cc      SAVE /PB/
17512         COMMON   /PC/EPION(MAXSTR,MAXR)
17513 cc      SAVE /PC/
17514         COMMON   /PD/LPION(MAXSTR,MAXR)
17515 cc      SAVE /PD/
17516         common/input1/ MASSPR,MASSTA,ISEED,IAVOID,DT
17517 cc      SAVE /input1/
17518       SAVE
17519 *-----------------------------------------------------------------------
17520        XINEL=0
17521        SIGK=0
17522        XSK1=0
17523        XSK2=0
17524        XSK3=0
17525        XSK4=0
17526        XSK5=0
17527         EM1=E(I1)
17528         EM2=E(I2)
17529       PR  = SQRT( PX**2 + PY**2 + PZ**2 )
17530 *     IF THERE WERE 2 N*(1535) AND THEY DIDN'T SCATT. ELAST.,
17531 *     ALLOW THEM TO PRODUCE KAONS. NO OTHER INELASTIC CHANNELS
17532 *     ARE KNOWN
17533 C       if((lb(i1).ge.12).and.(lb(i2).ge.12))return
17534 *     ALL the inelastic collisions between N*(1535) and Delta as well
17535 *     as N*(1440) TO PRODUCE KAONS, NO OTHER CHANNELS ARE KNOWN
17536 C       if((lb(i1).ge.12).and.(lb(i2).ge.3))return
17537 C       if((lb(i2).ge.12).and.(lb(i1).ge.3))return
17538 *     calculate the N*(1535) production cross section in I1+I2 collisions
17539        call N1535(iabs(lb(i1)),iabs(lb(i2)),srt,X1535)
17540 c
17541 * for Delta+Delta-->N*(1440 OR 1535)+N AND N*(1440)+N*(1440)-->N*(1535)+X
17542 *     AND DELTA+N*(1440)-->N*(1535)+X
17543 * WE ASSUME THEY HAVE THE SAME CROSS SECTIONS as CORRESPONDING N+N COLLISION):
17544 * FOR D++D0, D+D+,D+D-,D0D0,N*+N*+,N*0N*0,N*(+)D+,N*(+)D(-),N*(0)D(0)
17545 * N*(1535) production, kaon production and reabsorption through
17546 * D(N*)+D(N*)-->NN are ALLOWED.
17547 * CROSS SECTION FOR KAON PRODUCTION from the four channels are
17548 * for NLK channel
17549        akp=0.498
17550        ak0=0.498
17551        ana=0.94
17552        ada=1.232
17553        al=1.1157
17554        as=1.1197
17555        xsk1=0
17556        xsk2=0
17557        xsk3=0
17558        xsk4=0
17559        t1nlk=ana+al+akp
17560        if(srt.le.t1nlk)go to 222
17561        XSK1=1.5*PPLPK(SRT)
17562 * for DLK channel
17563        t1dlk=ada+al+akp
17564        t2dlk=ada+al-akp
17565        if(srt.le.t1dlk)go to 222
17566        es=srt
17567        pmdlk2=(es**2-t1dlk**2)*(es**2-t2dlk**2)/(4.*es**2)
17568        pmdlk=sqrt(pmdlk2)
17569        XSK3=1.5*PPLPK(srt)
17570 * for NSK channel
17571        t1nsk=ana+as+akp
17572        t2nsk=ana+as-akp
17573        if(srt.le.t1nsk)go to 222
17574        pmnsk2=(es**2-t1nsk**2)*(es**2-t2nsk**2)/(4.*es**2)
17575        pmnsk=sqrt(pmnsk2)
17576        XSK2=1.5*(PPK1(srt)+PPK0(srt))
17577 * for DSK channel
17578        t1DSk=aDa+aS+akp
17579        t2DSk=aDa+aS-akp
17580        if(srt.le.t1dsk)go to 222
17581        pmDSk2=(es**2-t1DSk**2)*(es**2-t2DSk**2)/(4.*es**2)
17582        pmDSk=sqrt(pmDSk2)
17583        XSK4=1.5*(PPK1(srt)+PPK0(srt))
17584 csp11/21/01
17585 c phi production
17586        if(srt.le.(2.*amn+aphi))go to 222
17587 c  !! mb put the correct form
17588          xsk5 = 0.0001
17589 csp11/21/01 end
17590 * THE TOTAL KAON+ PRODUCTION CROSS SECTION IS THEN
17591 222       SIGK=XSK1+XSK2+XSK3+XSK4
17592
17593 cbz3/7/99 neutralk
17594         XSK1 = 2.0 * XSK1
17595         XSK2 = 2.0 * XSK2
17596         XSK3 = 2.0 * XSK3
17597         XSK4 = 2.0 * XSK4
17598         SIGK = 2.0 * SIGK + xsk5
17599 cbz3/7/99 neutralk end
17600
17601         IDD=iabs(LB(I1)*LB(I2))
17602 * The reabsorption cross section for the process
17603 * D(N*)D(N*)-->NN is
17604        s2d=reab2d(i1,i2,srt)
17605
17606 cbz3/16/99 pion
17607         S2D = 0.
17608 cbz3/16/99 pion end
17609
17610 *(1) N*(1535)+D(N*(1440)) reactions
17611 *    we allow kaon production and reabsorption only
17612        if(((iabs(lb(i1)).ge.12).and.(iabs(lb(i2)).ge.12)).OR.
17613      &       ((iabs(lb(i1)).ge.12).and.(iabs(lb(i2)).ge.6)).OR.
17614      &       ((iabs(lb(i2)).ge.12).and.(iabs(lb(i1)).ge.6)))THEN
17615        XINEL=sigk+s2d
17616        RETURN
17617        ENDIF
17618 * channels have the same charge as pp
17619         IF((IDD.EQ.63).OR.(IDD.EQ.64).OR.(IDD.EQ.48).
17620      1  OR.(IDD.EQ.49).OR.(IDD.EQ.11*11).OR.(IDD.EQ.10*10).
17621      2  OR.(IDD.EQ.88).OR.(IDD.EQ.66).
17622      3  OR.(IDD.EQ.90).OR.(IDD.EQ.70))THEN
17623         XINEL=X1535+SIGK+s2d
17624        RETURN
17625         ENDIF
17626 * IN DELTA+N*(1440) and N*(1440)+N*(1440) COLLISIONS,
17627 * N*(1535), kaon production and reabsorption are ALLOWED
17628 * IN N*(1440)+N*(1440) COLLISIONS, ONLY N*(1535) IS ALLOWED
17629        IF((IDD.EQ.110).OR.(IDD.EQ.77).OR.(IDD.EQ.80))THEN
17630        XINEL=X1535+SIGK+s2d
17631        RETURN
17632        ENDIF
17633        IF((IDD.EQ.54).OR.(IDD.EQ.56))THEN
17634 * LIKE FOR N+P COLLISION,
17635 * IN DELTA+DELTA COLLISIONS BOTH N*(1440) AND N*(1535) CAN BE PRODUCED
17636         SIG2=(3./4.)*SIGMA(SRT,2,0,1)
17637         XINEL=2.*(SIG2+X1535)+SIGK+s2d
17638        RETURN
17639        ENDIF
17640        RETURN
17641        END
17642 ******************************************
17643       real function dirct1(srt)
17644 *  This function contains the experimental, direct pion(+) + p cross sections *
17645 *  srt    = DSQRT(s) in GeV                                                   *
17646 *  dirct1  = cross section in fm**2                                     *
17647 *  earray = EXPerimental table with the srt
17648 *  xarray = EXPerimental table with cross sections in mb (curve to guide eye) *
17649 ******************************************
17650 c      real*4   xarray(122), earray(122)
17651       real   xarray(122), earray(122)
17652       SAVE
17653       data   earray /
17654      &1.568300,1.578300,1.588300,1.598300,1.608300,1.618300,1.628300,
17655      &1.638300,1.648300,1.658300,1.668300,1.678300,1.688300,1.698300,
17656      &1.708300,1.718300,1.728300,1.738300,1.748300,1.758300,1.768300,
17657      &1.778300,1.788300,1.798300,1.808300,1.818300,1.828300,1.838300,
17658      &1.848300,1.858300,1.868300,1.878300,1.888300,1.898300,1.908300,
17659      &1.918300,1.928300,1.938300,1.948300,1.958300,1.968300,1.978300,
17660      &1.988300,1.998300,2.008300,2.018300,2.028300,2.038300,2.048300,
17661      &2.058300,2.068300,2.078300,2.088300,2.098300,2.108300,2.118300,
17662      &2.128300,2.138300,2.148300,2.158300,2.168300,2.178300,2.188300,
17663      &2.198300,2.208300,2.218300,2.228300,2.238300,2.248300,2.258300,
17664      &2.268300,2.278300,2.288300,2.298300,2.308300,2.318300,2.328300,
17665      &2.338300,2.348300,2.358300,2.368300,2.378300,2.388300,2.398300,
17666      &2.408300,2.418300,2.428300,2.438300,2.448300,2.458300,2.468300,
17667      &2.478300,2.488300,2.498300,2.508300,2.518300,2.528300,2.538300,
17668      &2.548300,2.558300,2.568300,2.578300,2.588300,2.598300,2.608300,
17669      &2.618300,2.628300,2.638300,2.648300,2.658300,2.668300,2.678300,
17670      &2.688300,2.698300,2.708300,2.718300,2.728300,2.738300,2.748300,
17671      &2.758300,2.768300,2.778300/
17672       data xarray/
17673      &1.7764091E-02,0.5643668,0.8150568,1.045565,2.133695,3.327922,
17674      &4.206488,3.471242,4.486876,5.542213,6.800052,7.192446,6.829848,
17675      &6.580306,6.868410,8.527946,10.15720,9.716511,9.298335,8.901310,
17676      &10.31213,10.52185,11.17630,11.61639,12.05577,12.71596,13.46036,
17677      &14.22060,14.65449,14.94775,14.93310,15.32907,16.56481,16.29422,
17678      &15.18548,14.12658,13.72544,13.24488,13.31003,14.42680,12.84423,
17679      &12.49025,12.14858,11.81870,11.18993,11.35816,11.09447,10.83873,
17680      &10.61592,10.53754,9.425521,8.195912,9.661075,9.696192,9.200142,
17681      &8.953734,8.715461,8.484999,8.320765,8.255512,8.190969,8.127125,
17682      &8.079508,8.073004,8.010611,7.948909,7.887895,7.761005,7.626290,
17683      &7.494696,7.366132,7.530178,8.392097,9.046881,8.962544,8.879403,
17684      &8.797427,8.716601,8.636904,8.558312,8.404368,8.328978,8.254617,
17685      &8.181265,8.108907,8.037527,7.967100,7.897617,7.829057,7.761405,
17686      &7.694647,7.628764,7.563742,7.499570,7.387562,7.273281,7.161334,
17687      &6.973375,6.529592,6.280323,6.293136,6.305725,6.318097,6.330258,
17688      &6.342214,6.353968,6.365528,6.376895,6.388079,6.399081,6.409906,
17689      &6.420560,6.431045,6.441367,6.451529,6.461533,6.471386,6.481091,
17690      &6.490650,6.476413,6.297259,6.097826/
17691
17692       dirct1=0
17693       if (srt .lt. earray(1)) then
17694         dirct1 = 0.00001
17695         return
17696       end if
17697       if (srt .gt. earray(122)) then
17698         dirct1 = xarray(122)
17699        dirct1=dirct1/10.
17700         return
17701       end if
17702 *
17703 *Interpolate double logarithmically to find xdirct2(srt)
17704 *
17705       do 1001 ie = 1,122
17706         if (earray(ie) .eq. srt) then
17707           dirct1= xarray(ie)
17708          dirct1=dirct1/10.
17709           return
17710        endif
17711         if (earray(ie) .gt. srt) then
17712           ymin = alog(xarray(ie-1))
17713           ymax = alog(xarray(ie))
17714           xmin = alog(earray(ie-1))
17715           xmax = alog(earray(ie))
17716           dirct1= exp(ymin + (alog(srt)-xmin)
17717      &          *(ymax-ymin)/(xmax-xmin) )
17718        dirct1=dirct1/10.
17719        go to 50
17720         end if
17721  1001 continue
17722 50       continue
17723         return
17724         END
17725 *******************************
17726 ******************************************
17727       real function dirct2(srt)
17728 *  This function contains the experimental, direct pion(-) + p cross sections *
17729 *  srt    = DSQRT(s) in GeV                                                   *
17730 *  dirct2 = cross section in fm**2
17731 *  earray = EXPerimental table with the srt
17732 *  xarray = EXPerimental table with cross sections in mb (curve to guide eye) *
17733 ******************************************
17734 c      real*4   xarray(122), earray(122)
17735       real   xarray(122), earray(122)
17736       SAVE
17737       data   earray /
17738      &1.568300,1.578300,1.588300,1.598300,1.608300,1.618300,1.628300,
17739      &1.638300,1.648300,1.658300,1.668300,1.678300,1.688300,1.698300,
17740      &1.708300,1.718300,1.728300,1.738300,1.748300,1.758300,1.768300,
17741      &1.778300,1.788300,1.798300,1.808300,1.818300,1.828300,1.838300,
17742      &1.848300,1.858300,1.868300,1.878300,1.888300,1.898300,1.908300,
17743      &1.918300,1.928300,1.938300,1.948300,1.958300,1.968300,1.978300,
17744      &1.988300,1.998300,2.008300,2.018300,2.028300,2.038300,2.048300,
17745      &2.058300,2.068300,2.078300,2.088300,2.098300,2.108300,2.118300,
17746      &2.128300,2.138300,2.148300,2.158300,2.168300,2.178300,2.188300,
17747      &2.198300,2.208300,2.218300,2.228300,2.238300,2.248300,2.258300,
17748      &2.268300,2.278300,2.288300,2.298300,2.308300,2.318300,2.328300,
17749      &2.338300,2.348300,2.358300,2.368300,2.378300,2.388300,2.398300,
17750      &2.408300,2.418300,2.428300,2.438300,2.448300,2.458300,2.468300,
17751      &2.478300,2.488300,2.498300,2.508300,2.518300,2.528300,2.538300,
17752      &2.548300,2.558300,2.568300,2.578300,2.588300,2.598300,2.608300,
17753      &2.618300,2.628300,2.638300,2.648300,2.658300,2.668300,2.678300,
17754      &2.688300,2.698300,2.708300,2.718300,2.728300,2.738300,2.748300,
17755      &2.758300,2.768300,2.778300/
17756       data xarray/0.5773182,1.404156,2.578629,3.832013,4.906011,
17757      &9.076963,13.10492,10.65975,15.31156,19.77611,19.92874,18.68979,
17758      &19.80114,18.39536,14.34269,13.35353,13.58822,14.57031,10.24686,
17759      &11.23386,9.764803,10.35652,10.53539,10.07524,9.582198,9.596469,
17760      &9.818489,9.012848,9.378012,9.529244,9.529698,8.835624,6.671396,
17761      &8.797758,8.133437,7.866227,7.823946,7.808504,7.791755,7.502062,
17762      &7.417275,7.592349,7.752028,7.910585,8.068122,8.224736,8.075289,
17763      &7.895902,7.721359,7.551512,7.386224,7.225343,7.068739,6.916284,
17764      &6.767842,6.623294,6.482520,6.345404,6.211833,7.339510,7.531462,
17765      &7.724824,7.919620,7.848021,7.639856,7.571083,7.508881,7.447474,
17766      &7.386855,7.327011,7.164454,7.001266,6.842526,6.688094,6.537823,
17767      &6.391583,6.249249,6.110689,5.975790,5.894200,5.959503,6.024602,
17768      &6.089505,6.154224,6.218760,6.283128,6.347331,6.297411,6.120248,
17769      &5.948606,6.494864,6.357106,6.222824,6.091910,5.964267,5.839795,
17770      &5.718402,5.599994,5.499146,5.451325,5.404156,5.357625,5.311721,
17771      &5.266435,5.301964,5.343963,5.385833,5.427577,5.469200,5.510702,
17772      &5.552088,5.593359,5.634520,5.675570,5.716515,5.757356,5.798093,
17773      &5.838732,5.879272,5.919717,5.960068,5.980941/
17774
17775       dirct2=0.
17776       if (srt .lt. earray(1)) then
17777         dirct2 = 0.00001
17778         return
17779       end if
17780       if (srt .gt. earray(122)) then
17781         dirct2 = xarray(122)
17782        dirct2=dirct2/10.
17783         return
17784       end if
17785 *
17786 *Interpolate double logarithmically to find xdirct2(srt)
17787 *
17788       do 1001 ie = 1,122
17789         if (earray(ie) .eq. srt) then
17790           dirct2= xarray(ie)
17791          dirct2=dirct2/10.
17792           return
17793        endif
17794         if (earray(ie) .gt. srt) then
17795           ymin = alog(xarray(ie-1))
17796           ymax = alog(xarray(ie))
17797           xmin = alog(earray(ie-1))
17798           xmax = alog(earray(ie))
17799           dirct2= exp(ymin + (alog(srt)-xmin)
17800      &          *(ymax-ymin)/(xmax-xmin) )
17801        dirct2=dirct2/10.
17802        go to 50
17803         end if
17804  1001 continue
17805 50       continue
17806         return
17807         END
17808 *******************************
17809 ******************************
17810 * this program calculates the elastic cross section for rho+nucleon
17811 * through higher resonances
17812 c       real*4 function ErhoN(em1,em2,lb1,lb2,srt)
17813        real function ErhoN(em1,em2,lb1,lb2,srt)
17814 * date : Dec. 19, 1994
17815 * ****************************
17816 c       implicit real*4 (a-h,o-z)
17817       dimension   arrayj(19),arrayl(19),arraym(19),
17818      &arrayw(19),arrayb(19)
17819       SAVE
17820       data arrayj /0.5,1.5,0.5,0.5,2.5,2.5,1.5,0.5,1.5,3.5,
17821      &1.5,0.5,1.5,0.5,2.5,0.5,1.5,2.5,3.5/
17822       data arrayl/1,2,0,0,2,3,2,1,1,3,
17823      &1,0,2,0,3,1,1,2,3/
17824       data arraym /1.44,1.52,1.535,1.65,1.675,1.68,1.70,1.71,
17825      &1.72,1.99,1.60,1.62,1.70,1.90,1.905,1.910,
17826      &1.86,1.93,1.95/
17827       data arrayw/0.2,0.125,0.15,0.15,0.155,0.125,0.1,0.11,
17828      &0.2,0.29,0.25,0.16,0.28,0.15,0.3,0.22,0.25,
17829      &0.25,0.24/
17830       data arrayb/0.15,0.20,0.05,0.175,0.025,0.125,0.1,0.20,
17831      &0.53,0.34,0.05,0.07,0.15,0.45,0.45,0.058,
17832      &0.08,0.12,0.08/
17833
17834 * the minimum energy for pion+delta collision
17835        pi=3.1415926
17836        xs=0
17837 * include contribution from each resonance
17838        do 1001 ir=1,19
17839 cbz11/25/98
17840        IF(IR.LE.8)THEN
17841 c       if(lb1*lb2.eq.27.OR.LB1*LB2.EQ.25*2)branch=0.
17842 c       if(lb1*lb2.eq.26.OR.LB1*LB2.EQ.26*2)branch=1./3.
17843 c       if(lb1*lb2.eq.27*2.OR.LB1*LB2.EQ.25)branch=2./3.
17844 c       ELSE
17845 c       if(lb1*lb2.eq.27.OR.LB1*LB2.EQ.25*2)branch=1.
17846 c       if(lb1*lb2.eq.26.OR.LB1*LB2.EQ.26*2)branch=2./3.
17847 c       if(lb1*lb2.eq.27*2.OR.LB1*LB2.EQ.25)branch=1./3.
17848 c       ENDIF
17849        if( ((lb1*lb2.eq.27.AND.(LB1.EQ.1.OR.LB2.EQ.1)).OR.
17850      &     (LB1*LB2.EQ.25*2.AND.(LB1.EQ.2.OR.LB2.EQ.2)))
17851      &       .OR.((lb1*lb2.eq.-25.AND.(LB1.EQ.-1.OR.LB2.EQ.-1)).OR.
17852      &     (LB1*LB2.EQ.-27*2.AND.(LB1.EQ.-2.OR.LB2.EQ.-2))) )
17853      &     branch=0.
17854         if((iabs(lb1*lb2).eq.26.AND.(iabs(LB1).EQ.1.OR.iabs(LB2).EQ.1))
17855      &   .OR.(iabs(LB1*LB2).EQ.26*2
17856      &   .AND.(iabs(LB1).EQ.2.OR.iabs(LB2).EQ.2)))
17857      &     branch=1./3.
17858        if( ((lb1*lb2.eq.27*2.AND.(LB1.EQ.2.OR.LB2.EQ.2)).OR.
17859      &     (LB1*LB2.EQ.25.AND.(LB1.EQ.1.OR.LB2.EQ.1)))
17860      &  .OR.((lb1*lb2.eq.-25*2.AND.(LB1.EQ.-2.OR.LB2.EQ.-2)).OR.
17861      &     (LB1*LB2.EQ.-27.AND.(LB1.EQ.-1.OR.LB2.EQ.-1))) )
17862      &     branch=2./3.
17863        ELSE
17864        if( ((lb1*lb2.eq.27.AND.(LB1.EQ.1.OR.LB2.EQ.1)).OR.
17865      &     (LB1*LB2.EQ.25*2.AND.(LB1.EQ.2.OR.LB2.EQ.2)))
17866      &       .OR.((lb1*lb2.eq.-25.AND.(LB1.EQ.-1.OR.LB2.EQ.-1)).OR.
17867      &     (LB1*LB2.EQ.-27*2.AND.(LB1.EQ.-2.OR.LB2.EQ.-2))) )
17868      &     branch=1.
17869         if((iabs(lb1*lb2).eq.26.AND.(iabs(LB1).EQ.1.OR.iabs(LB2).EQ.1))
17870      &   .OR.(iabs(LB1*LB2).EQ.26*2
17871      &   .AND.(iabs(LB1).EQ.2.OR.iabs(LB2).EQ.2)))
17872      &     branch=2./3.
17873        if( ((lb1*lb2.eq.27*2.AND.(LB1.EQ.2.OR.LB2.EQ.2)).OR.
17874      &     (LB1*LB2.EQ.25.AND.(LB1.EQ.1.OR.LB2.EQ.1)))
17875      &  .OR.((lb1*lb2.eq.-25*2.AND.(LB1.EQ.-2.OR.LB2.EQ.-2)).OR.
17876      &     (LB1*LB2.EQ.-27.AND.(LB1.EQ.-1.OR.LB2.EQ.-1))) )
17877      &     branch=1./3.
17878        ENDIF
17879 cbz11/25/98end
17880        xs0=fdR(arraym(ir),arrayj(ir),arrayl(ir),
17881      &arrayw(ir),arrayb(ir),srt,EM1,EM2)
17882        xs=xs+1.3*pi*branch*xs0*(0.1973)**2
17883  1001 continue
17884        Erhon=xs
17885        return
17886        end
17887 ***************************8
17888 *FUNCTION FDE(DMASS) GIVES DELTA MASS DISTRIBUTION BY USING OF
17889 *KITAZOE'S FORMULA
17890 c        REAL*4 FUNCTION FDR(DMASS,aj,al,width,widb0,srt,em1,em2)
17891       REAL FUNCTION FDR(DMASS,aj,al,width,widb0,srt,em1,em2)
17892       SAVE
17893         AMd=em1
17894         AmP=em2
17895            Ak02= 0.25*(DMASS**2-amd**2-amp**2)**2
17896      &           -(Amp*amd)**2
17897             IF (ak02 .GT. 0.) THEN
17898               Q0 = SQRT(ak02/DMASS)
17899             ELSE
17900               Q0= 0.0
17901              fdR=0
17902            return
17903             END IF
17904            Ak2= 0.25*(srt**2-amd**2-amp**2)**2
17905      &           -(Amp*amd)**2
17906             IF (ak2 .GT. 0.) THEN
17907               Q = SQRT(ak2/DMASS)
17908             ELSE
17909               Q= 0.00
17910              fdR=0
17911              return
17912             END IF
17913        b=widb0*1.2*dmass/srt*(q/q0)**(2.*al+1)
17914      &  /(1.+0.2*(q/q0)**(2*al))
17915         FDR=(2.*aj+1)*WIDTH**2*b/((srt-dmass)**2
17916      1  +0.25*WIDTH**2)/(6.*q**2)
17917         RETURN
17918         END
17919 ******************************
17920 * this program calculates the elastic cross section for pion+delta
17921 * through higher resonances
17922 c       REAL*4 FUNCTION DIRCT3(SRT)
17923       REAL FUNCTION DIRCT3(SRT)
17924 * date : Dec. 19, 1994
17925 * ****************************
17926 c     implicit real*4 (a-h,o-z)
17927       dimension   arrayj(17),arrayl(17),arraym(17),
17928      &arrayw(17),arrayb(17)
17929       SAVE
17930       data arrayj /1.5,0.5,2.5,2.5,1.5,0.5,1.5,3.5,
17931      &1.5,0.5,1.5,0.5,2.5,0.5,1.5,2.5,3.5/
17932       data arrayl/2,0,2,3,2,1,1,3,
17933      &1,0,2,0,3,1,1,2,3/
17934       data arraym /1.52,1.65,1.675,1.68,1.70,1.71,
17935      &1.72,1.99,1.60,1.62,1.70,1.90,1.905,1.910,
17936      &1.86,1.93,1.95/
17937       data arrayw/0.125,0.15,0.155,0.125,0.1,0.11,
17938      &0.2,0.29,0.25,0.16,0.28,0.15,0.3,0.22,0.25,
17939      &0.25,0.24/
17940       data arrayb/0.55,0.6,0.375,0.6,0.1,0.15,
17941      &0.15,0.05,0.35,0.3,0.15,0.1,0.1,0.22,
17942      &0.2,0.09,0.4/
17943
17944 * the minimum energy for pion+delta collision
17945        pi=3.1415926
17946        amn=0.938
17947        amp=0.138
17948        xs=0
17949 * include contribution from each resonance
17950        branch=1./3.
17951        do 1001 ir=1,17
17952        if(ir.gt.8)branch=2./3.
17953        xs0=fd1(arraym(ir),arrayj(ir),arrayl(ir),
17954      &arrayw(ir),arrayb(ir),srt)
17955        xs=xs+1.3*pi*branch*xs0*(0.1973)**2
17956  1001   continue
17957        DIRCT3=XS
17958        RETURN
17959        end
17960 ***************************8
17961 *FUNCTION FDE(DMASS) GIVES DELTA MASS DISTRIBUTION BY USING OF
17962 *KITAZOE'S FORMULA
17963 c        REAL*4 FUNCTION FD1(DMASS,aj,al,width,widb0,srt)
17964       REAL FUNCTION FD1(DMASS,aj,al,width,widb0,srt)
17965       SAVE
17966         AMN=0.938
17967         AmP=0.138
17968        amd=amn
17969            Ak02= 0.25*(DMASS**2-amd**2-amp**2)**2
17970      &           -(Amp*amd)**2
17971             IF (ak02 .GT. 0.) THEN
17972               Q0 = SQRT(ak02/DMASS)
17973             ELSE
17974               Q0= 0.0
17975              fd1=0
17976            return
17977             END IF
17978            Ak2= 0.25*(srt**2-amd**2-amp**2)**2
17979      &           -(Amp*amd)**2
17980             IF (ak2 .GT. 0.) THEN
17981               Q = SQRT(ak2/DMASS)
17982             ELSE
17983               Q= 0.00
17984              fd1=0
17985              return
17986             END IF
17987        b=widb0*1.2*dmass/srt*(q/q0)**(2.*al+1)
17988      &  /(1.+0.2*(q/q0)**(2*al))
17989         FD1=(2.*aj+1)*WIDTH**2*b/((srt-dmass)**2
17990      1  +0.25*WIDTH**2)/(2.*q**2)
17991         RETURN
17992         END
17993 ******************************
17994 * this program calculates the elastic cross section for pion+delta
17995 * through higher resonances
17996 c       REAL*4 FUNCTION DPION(EM1,EM2,LB1,LB2,SRT)
17997       REAL FUNCTION DPION(EM1,EM2,LB1,LB2,SRT)
17998 * date : Dec. 19, 1994
17999 * ****************************
18000 c     implicit real*4 (a-h,o-z)
18001       dimension   arrayj(19),arrayl(19),arraym(19),
18002      &arrayw(19),arrayb(19)
18003       SAVE
18004       data arrayj /0.5,1.5,0.5,0.5,2.5,2.5,1.5,0.5,1.5,3.5,
18005      &1.5,0.5,1.5,0.5,2.5,0.5,1.5,2.5,3.5/
18006       data arrayl/1,2,0,0,2,3,2,1,1,3,
18007      &1,0,2,0,3,1,1,2,3/
18008       data arraym /1.44,1.52,1.535,1.65,1.675,1.68,1.70,1.71,
18009      &1.72,1.99,1.60,1.62,1.70,1.90,1.905,1.910,
18010      &1.86,1.93,1.95/
18011       data arrayw/0.2,0.125,0.15,0.15,0.155,0.125,0.1,0.11,
18012      &0.2,0.29,0.25,0.16,0.28,0.15,0.3,0.22,0.25,
18013      &0.25,0.24/
18014       data arrayb/0.15,0.25,0.,0.05,0.575,0.125,0.379,0.10,
18015      &0.10,0.062,0.45,0.60,0.6984,0.05,0.25,0.089,
18016      &0.19,0.2,0.13/
18017
18018 * the minimum energy for pion+delta collision
18019        pi=3.1415926
18020        amn=0.94
18021        amp=0.14
18022        xs=0
18023 * include contribution from each resonance
18024        do 1001 ir=1,19
18025        BRANCH=0.
18026 cbz11/25/98
18027        if(ir.LE.8)THEN
18028 c       IF(LB1*LB2.EQ.5*7.OR.LB1*LB2.EQ.3*8)branch=1./6.
18029 c       IF(LB1*LB2.EQ.4*7.OR.LB1*LB2.EQ.4*8)branch=1./3.
18030 c       IF(LB1*LB2.EQ.5*6.OR.LB1*LB2.EQ.3*9)branch=1./2.
18031 c       ELSE
18032 c       IF(LB1*LB2.EQ.5*8.OR.LB1*LB2.EQ.5*6)branch=2./5.
18033 c       IF(LB1*LB2.EQ.3*9.OR.LB1*LB2.EQ.3*7)branch=2./5.
18034 c       IF(LB1*LB2.EQ.5*7.OR.LB1*LB2.EQ.3*8)branch=8./15.
18035 c       IF(LB1*LB2.EQ.4*7.OR.LB1*LB2.EQ.4*8)branch=1./15.
18036 c       IF(LB1*LB2.EQ.4*9.OR.LB1*LB2.EQ.4*6)branch=3./5.
18037 c       ENDIF
18038        IF( ((LB1*LB2.EQ.5*7.AND.(LB1.EQ.5.OR.LB2.EQ.5)).OR.
18039      &     (LB1*LB2.EQ.3*8.AND.(LB1.EQ.3.OR.LB2.EQ.3)))
18040      &       .OR.((LB1*LB2.EQ.-3*7.AND.(LB1.EQ.3.OR.LB2.EQ.3)).OR.
18041      &     (LB1*LB2.EQ.-5*8.AND.(LB1.EQ.5.OR.LB2.EQ.5))) )
18042      &     branch=1./6.
18043        IF((iabs(LB1*LB2).EQ.4*7.AND.(LB1.EQ.4.OR.LB2.EQ.4)).OR.
18044      &     (iabs(LB1*LB2).EQ.4*8.AND.(LB1.EQ.4.OR.LB2.EQ.4)))
18045      &     branch=1./3.
18046        IF( ((LB1*LB2.EQ.5*6.AND.(LB1.EQ.5.OR.LB2.EQ.5)).OR.
18047      &     (LB1*LB2.EQ.3*9.AND.(LB1.EQ.3.OR.LB2.EQ.3)))
18048      &       .OR.((LB1*LB2.EQ.-3*6.AND.(LB1.EQ.3.OR.LB2.EQ.3)).OR.
18049      &     (LB1*LB2.EQ.-5*9.AND.(LB1.EQ.5.OR.LB2.EQ.5))) )
18050      &     branch=1./2.
18051        ELSE
18052        IF( ((LB1*LB2.EQ.5*8.AND.(LB1.EQ.5.OR.LB2.EQ.5)).OR.
18053      &     (LB1*LB2.EQ.5*6.AND.(LB1.EQ.5.OR.LB2.EQ.5)))
18054      &        .OR.((LB1*LB2.EQ.-3*8.AND.(LB1.EQ.3.OR.LB2.EQ.3)).OR.
18055      &     (LB1*LB2.EQ.-3*6.AND.(LB1.EQ.3.OR.LB2.EQ.3))) )
18056      &     branch=2./5.
18057        IF( ((LB1*LB2.EQ.3*9.AND.(LB1.EQ.3.OR.LB2.EQ.3)).OR.
18058      &     (LB1*LB2.EQ.3*7.AND.(LB1.EQ.3.OR.LB2.EQ.3)))
18059      &        .OR. ((LB1*LB2.EQ.-5*9.AND.(LB1.EQ.5.OR.LB2.EQ.5)).OR.
18060      &     (LB1*LB2.EQ.-5*7.AND.(LB1.EQ.5.OR.LB2.EQ.5))) )
18061      &     branch=2./5.
18062        IF( ((LB1*LB2.EQ.5*7.AND.(LB1.EQ.5.OR.LB2.EQ.5)).OR.
18063      &     (LB1*LB2.EQ.3*8.AND.(LB1.EQ.3.OR.LB2.EQ.3)))
18064      &        .OR.((LB1*LB2.EQ.-3*7.AND.(LB1.EQ.3.OR.LB2.EQ.3)).OR.
18065      &     (LB1*LB2.EQ.-5*8.AND.(LB1.EQ.5.OR.LB2.EQ.5))) )
18066      &     branch=8./15.
18067        IF((iabs(LB1*LB2).EQ.4*7.AND.(LB1.EQ.4.OR.LB2.EQ.4)).OR.
18068      &     (iabs(LB1*LB2).EQ.4*8.AND.(LB1.EQ.4.OR.LB2.EQ.4)))
18069      &     branch=1./15.
18070        IF((iabs(LB1*LB2).EQ.4*9.AND.(LB1.EQ.4.OR.LB2.EQ.4)).OR.
18071      &     (iabs(LB1*LB2).EQ.4*6.AND.(LB1.EQ.4.OR.LB2.EQ.4)))
18072      &     branch=3./5.
18073        ENDIF
18074 cbz11/25/98end
18075        xs0=fd2(arraym(ir),arrayj(ir),arrayl(ir),
18076      &arrayw(ir),arrayb(ir),EM1,EM2,srt)
18077        xs=xs+1.3*pi*branch*xs0*(0.1973)**2
18078  1001   continue
18079        DPION=XS
18080        RETURN
18081        end
18082 ***************************8
18083 *FUNCTION FDE(DMASS) GIVES DELTA MASS DISTRIBUTION BY USING OF
18084 *KITAZOE'S FORMULA
18085 c        REAL*4 FUNCTION FD2(DMASS,aj,al,width,widb0,EM1,EM2,srt)
18086       REAL FUNCTION FD2(DMASS,aj,al,width,widb0,EM1,EM2,srt)
18087       SAVE
18088         AmP=EM1
18089        amd=EM2
18090            Ak02= 0.25*(DMASS**2-amd**2-amp**2)**2
18091      &           -(Amp*amd)**2
18092             IF (ak02 .GT. 0.) THEN
18093               Q0 = SQRT(ak02/DMASS)
18094             ELSE
18095               Q0= 0.0
18096              fd2=0
18097            return
18098             END IF
18099            Ak2= 0.25*(srt**2-amd**2-amp**2)**2
18100      &           -(Amp*amd)**2
18101             IF (ak2 .GT. 0.) THEN
18102               Q = SQRT(ak2/DMASS)
18103             ELSE
18104               Q= 0.00
18105              fd2=0
18106              return
18107             END IF
18108        b=widb0*1.2*dmass/srt*(q/q0)**(2.*al+1)
18109      &  /(1.+0.2*(q/q0)**(2*al))
18110         FD2=(2.*aj+1)*WIDTH**2*b/((srt-dmass)**2
18111      1  +0.25*WIDTH**2)/(4.*q**2)
18112         RETURN
18113         END
18114 ***************************8
18115 *   MASS GENERATOR for two resonances simultaneously
18116        subroutine Rmasdd(srt,am10,am20,
18117      &dmin1,dmin2,ISEED,ic,dm1,dm2)
18118       COMMON/RNDF77/NSEED
18119 cc      SAVE /RNDF77/
18120       SAVE
18121        ISEED=ISEED
18122        amn=0.94
18123        amp=0.14
18124 * the maximum mass for resonance 1
18125          dmax1=srt-dmin2
18126 * generate the mass for the first resonance
18127  5        NTRY1=0
18128          ntry2=0
18129          ntry=0
18130          ictrl=0
18131 10        DM1 = RANART(NSEED) * (DMAX1-DMIN1) + DMIN1
18132           NTRY1=NTRY1+1
18133 * the maximum mass for resonance 2
18134          if(ictrl.eq.0)dmax2=srt-dm1
18135 * generate the mass for the second resonance
18136 20         dm2=RANART(NSEED)*(dmax2-dmin2)+dmin2
18137           NTRY2=NTRY2+1
18138 * check the energy-momentum conservation with two masses
18139 * q2 in the following is q**2*4*srt**2
18140          q2=((srt**2-dm1**2-dm2**2)**2-4.*dm1**2*dm2**2)
18141          if(q2.le.0)then
18142          dmax2=dm2-0.01
18143 c         dmax1=dm1-0.01
18144          ictrl=1
18145          go to 20
18146          endif
18147 * determine the weight of the mass pair
18148           IF(DMAX1.LT.am10) THEN
18149           if(ic.eq.1)FM1=Fmassd(DMAX1)
18150           if(ic.eq.2)FM1=Fmassn(DMAX1)
18151           if(ic.eq.3)FM1=Fmassd(DMAX1)
18152           if(ic.eq.4)FM1=Fmassd(DMAX1)
18153           ELSE
18154           if(ic.eq.1)FM1=Fmassd(am10)
18155           if(ic.eq.2)FM1=Fmassn(am10)
18156           if(ic.eq.3)FM1=Fmassd(am10)
18157           if(ic.eq.4)FM1=Fmassd(am10)
18158           ENDIF
18159           IF(DMAX2.LT.am20) THEN
18160           if(ic.eq.1)FM2=Fmassd(DMAX2)
18161           if(ic.eq.2)FM2=Fmassn(DMAX2)
18162           if(ic.eq.3)FM2=Fmassn(DMAX2)
18163           if(ic.eq.4)FM2=Fmassr(DMAX2)
18164           ELSE
18165           if(ic.eq.1)FM2=Fmassd(am20)
18166           if(ic.eq.2)FM2=Fmassn(am20)
18167           if(ic.eq.3)FM2=Fmassn(am20)
18168           if(ic.eq.4)FM2=Fmassr(am20)
18169           ENDIF
18170           IF(FM1.EQ.0.)FM1=1.e-04
18171           IF(FM2.EQ.0.)FM2=1.e-04
18172          prob0=fm1*fm2
18173           if(ic.eq.1)prob=Fmassd(dm1)*fmassd(dm2)
18174           if(ic.eq.2)prob=Fmassn(dm1)*fmassn(dm2)
18175           if(ic.eq.3)prob=Fmassd(dm1)*fmassn(dm2)
18176           if(ic.eq.4)prob=Fmassd(dm1)*fmassr(dm2)
18177          if(prob.le.1.e-06)prob=1.e-06
18178          fff=prob/prob0
18179          ntry=ntry+1
18180           IF(RANART(NSEED).GT.fff.AND.
18181      1    NTRY.LE.20) GO TO 10
18182
18183 clin-2/26/03 limit the mass of (rho,Delta,N*1440) below a certain value
18184 c     (here taken as its central value + 2* B-W fullwidth):
18185           if((abs(am10-0.77).le.0.01.and.dm1.gt.1.07)
18186      1         .or.(abs(am10-1.232).le.0.01.and.dm1.gt.1.47)
18187      2         .or.(abs(am10-1.44).le.0.01.and.dm1.gt.2.14)) goto 5
18188           if((abs(am20-0.77).le.0.01.and.dm2.gt.1.07)
18189      1         .or.(abs(am20-1.232).le.0.01.and.dm2.gt.1.47)
18190      2         .or.(abs(am20-1.44).le.0.01.and.dm2.gt.2.14)) goto 5
18191
18192        RETURN
18193        END
18194 *FUNCTION Fmassd(DMASS) GIVES the delta MASS DISTRIBUTION
18195         REAL FUNCTION Fmassd(DMASS)
18196       SAVE
18197         AM0=1.232
18198         Fmassd=am0*WIDTH(DMASS)/((DMASS**2-am0**2)**2
18199      1  +am0**2*WIDTH(DMASS)**2)
18200         RETURN
18201         END
18202 *FUNCTION Fmassn(DMASS) GIVES the N* MASS DISTRIBUTION
18203         REAL FUNCTION Fmassn(DMASS)
18204       SAVE
18205         AM0=1.44
18206         Fmassn=am0*W1440(DMASS)/((DMASS**2-am0**2)**2
18207      1  +am0**2*W1440(DMASS)**2)
18208         RETURN
18209         END
18210 *FUNCTION Fmassr(DMASS) GIVES the rho MASS DISTRIBUTION
18211         REAL FUNCTION Fmassr(DMASS)
18212       SAVE
18213         AM0=0.77
18214        wid=0.153
18215         Fmassr=am0*Wid/((DMASS**2-am0**2)**2
18216      1  +am0**2*Wid**2)
18217         RETURN
18218         END
18219 **********************************
18220 * PURPOSE : flow analysis
18221 * DATE : Feb. 1, 1995
18222 ***********************************
18223        subroutine flow(nt)
18224 c       IMPLICIT REAL*4 (A-H,O-Z)
18225        PARAMETER ( PI=3.1415926,APion=0.13957,aka=0.498)
18226         PARAMETER   (MAXSTR=150001,MAXR=1,AMU= 0.9383,etaM=0.5475)
18227        DIMENSION ypion(-80:80),ypr(-80:80),ykaon(-80:80)
18228        dimension pxpion(-80:80),pxpro(-80:80),pxkaon(-80:80)
18229 *----------------------------------------------------------------------*
18230       COMMON  /AA/      R(3,MAXSTR)
18231 cc      SAVE /AA/
18232       COMMON  /BB/      P(3,MAXSTR)
18233 cc      SAVE /BB/
18234       COMMON  /CC/      E(MAXSTR)
18235 cc      SAVE /CC/
18236       COMMON  /EE/      ID(MAXSTR),LB(MAXSTR)
18237 cc      SAVE /EE/
18238       COMMON  /RR/      MASSR(0:MAXR)
18239 cc      SAVE /RR/
18240       COMMON  /RUN/     NUM
18241 cc      SAVE /RUN/
18242       common/input1/ MASSPR,MASSTA,ISEED,IAVOID,DT
18243 cc      SAVE /input1/
18244       SAVE
18245 *----------------------------------------------------------------------*
18246        NT=NT
18247        ycut1=-2.6
18248        ycut2=2.6
18249        DY=0.2
18250        LY=NINT((YCUT2-YCUT1)/DY)
18251 ***********************************
18252 C initialize the transverse momentum counters
18253        do 11 kk=-80,80
18254        pxpion(kk)=0
18255        pxpro(kk)=0
18256        pxkaon(kk)=0
18257 11       continue
18258        DO 701 J=-LY,LY
18259        ypion(j)=0
18260        ykaon(j)=0
18261        ypr(j)=0
18262   701   CONTINUE
18263        nkaon=0
18264        npr=0
18265        npion=0
18266           IS=0
18267           DO 20 NRUN=1,NUM
18268           IS=IS+MASSR(NRUN-1)
18269           DO 20 J=1,MASSR(NRUN)
18270           I=J+IS
18271 * for protons go to 200 to calculate its rapidity and transvese momentum
18272 * distributions
18273        e00=sqrt(P(1,I)**2+P(2,i)**2+P(3,i)**2+e(I)**2)
18274        y00=0.5*alog((e00+p(3,i))/(e00-p(3,i)))
18275        if(abs(y00).ge.ycut2)go to 20
18276        iy=nint(y00/DY)
18277        if(abs(iy).ge.80)go to 20
18278        if(e(i).eq.0)go to 20
18279        if(lb(i).ge.25)go to 20
18280        if((lb(i).le.5).and.(lb(i).ge.3))go to 50
18281        if(lb(i).eq.1.or.lb(i).eq.2)go to 200
18282 cbz3/10/99
18283 c       if(lb(i).ge.6.and.lb(i).le.15)go to 200
18284        if(lb(i).ge.6.and.lb(i).le.17)go to 200
18285 cbz3/10/99 end
18286        if(lb(i).eq.23)go to 400
18287        go to 20
18288 * calculate rapidity and transverse momentum distribution for pions
18289 50       npion=npion+1
18290 * (2) rapidity distribution in the cms frame
18291         ypion(iy)=ypion(iy)+1
18292        pxpion(iy)=pxpion(iy)+p(1,i)/e(I)
18293        go TO 20
18294 * calculate rapidity and transverse energy distribution for baryons
18295 200      npr=npr+1
18296                 pxpro(iy)=pxpro(iy)+p(1,I)/E(I)
18297                  ypr(iy)=ypr(iy)+1.
18298         go to 20
18299 400     nkaon=nkaon+1
18300                  ykaon(iy)=ykaon(iy)+1.
18301                 pxkaon(iy)=pxkaon(iy)+p(1,i)/E(i)
18302 20      CONTINUE
18303 C PRINT OUT NUCLEON'S TRANSVERSE MOMENTUM distribution
18304 c       write(1041,*)Nt
18305 c       write(1042,*)Nt
18306 c       write(1043,*)Nt
18307 c       write(1090,*)Nt
18308 c       write(1091,*)Nt
18309 c       write(1092,*)Nt
18310        do 3 npt=-10,10
18311        IF(ypr(npt).eq.0) go to 101
18312        pxpro(NPT)=-Pxpro(NPT)/ypr(NPT)
18313        DNUC=Pxpro(NPT)/SQRT(ypr(NPT))
18314 c       WRITE(1041,*)NPT*DY,Pxpro(NPT),DNUC
18315 c print pion's transverse momentum distribution
18316 101       IF(ypion(npt).eq.0) go to 102
18317        pxpion(NPT)=-pxpion(NPT)/ypion(NPT)
18318        DNUCp=pxpion(NPT)/SQRT(ypion(NPT))
18319 c       WRITE(1042,*)NPT*DY,Pxpion(NPT),DNUCp
18320 c kaons
18321 102       IF(ykaon(npt).eq.0) go to 3
18322        pxkaon(NPT)=-pxkaon(NPT)/ykaon(NPT)
18323        DNUCk=pxkaon(NPT)/SQRT(ykaon(NPT))
18324 c       WRITE(1043,*)NPT*DY,Pxkaon(NPT),DNUCk
18325 3       CONTINUE
18326 ********************************
18327 * OUTPUT PION AND PROTON RAPIDITY DISTRIBUTIONS
18328        DO 1001 M=-LY,LY
18329 * PROTONS
18330        DYPR=0
18331        IF(YPR(M).NE.0)DYPR=SQRT(YPR(M))/FLOAT(NRUN)/DY
18332        YPR(M)=YPR(M)/FLOAT(NRUN)/DY
18333 c       WRITE(1090,'(E11.3,2X,E11.3,2X,E11.3)')m*DY,YPR(M),DYPR
18334 * PIONS
18335        DYPION=0
18336        IF(YPION(M).NE.0)DYPION=SQRT(YPION(M))/FLOAT(NRUN)/DY
18337        YPION(M)=YPION(M)/FLOAT(NRUN)/DY
18338 c       WRITE(1091,'(E11.3,2X,E11.3,2X,E11.3)')m*DY,YPION(M),DYPION
18339 * KAONS
18340        DYKAON=0
18341        IF(YKAON(M).NE.0)DYKAON=SQRT(YKAON(M))/FLOAT(NRUN)/DY
18342        YKAON(M)=YKAON(M)/FLOAT(NRUN)/DY
18343 c       WRITE(1092,'(E11.3,2X,E11.3,2X,E11.3)')m*DY,YKAON(M),DYKAON
18344  1001 CONTINUE
18345        return
18346        end
18347 cbali1/16/99
18348 ********************************************
18349 * Purpose: pp_bar annihilation cross section as a functon of their cms energy
18350 c      real*4 function xppbar(srt)
18351       real function xppbar(srt)
18352 *  srt    = DSQRT(s) in GeV                                                   *
18353 *  xppbar = pp_bar annihilation cross section in mb                           *
18354 *
18355 *  Reference: G.J. Wang, R. Bellwied, C. Pruneau and G. Welke
18356 *             Proc. of the 14th Winter Workshop on Nuclear Dynamics,
18357 *             Snowbird, Utah 31, Eds. W. Bauer and H.G. Ritter
18358 *             (Plenum Publishing, 1998)                             *
18359 *
18360 ******************************************
18361        Parameter (pmass=0.9383,xmax=400.)
18362       SAVE
18363 * Note:
18364 * (1) we introduce a new parameter xmax=400 mb:
18365 *     the maximum annihilation xsection
18366 * there are shadowing effects in pp_bar annihilation, with this parameter
18367 * we can probably look at these effects
18368 * (2) Calculate p(lab) from srt [GeV], since the formular in the
18369 * reference applies only to the case of a p_bar on a proton at rest
18370 * Formula used: srt**2=2.*pmass*(pmass+sqrt(pmass**2+plab**2))
18371        xppbar=1.e-06
18372        plab2=(srt**2/(2.*pmass)-pmass)**2-pmass**2
18373        if(plab2.gt.0)then
18374            plab=sqrt(plab2)
18375        xppbar=67./(plab**0.7)
18376        if(xppbar.gt.xmax)xppbar=xmax
18377        endif
18378          return
18379       END
18380 cbali1/16/99 end
18381 **********************************
18382 cbali2/6/99
18383 ********************************************
18384 * Purpose: To generate randomly the no. of pions in the final
18385 *          state of pp_bar annihilation according to a statistical
18386 *          model by using of the rejection method.
18387 cbz2/25/99
18388 c      real*4 function pbarfs(srt,npion,iseed)
18389       subroutine pbarfs(srt,npion,iseed)
18390 cbz2/25/99end
18391 * Quantities:
18392 *  srt: DSQRT(s) in GeV                                                    *
18393 *  npion: No. of pions produced in the annihilation of ppbar at srt        *
18394 *  nmax=6, cutoff of the maximum no. of n the code can handle
18395 *
18396 *  Reference: C.M. Ko and R. Yuan, Phys. Lett. B192 (1987) 31      *
18397 *
18398 ******************************************
18399        parameter (pimass=0.140,pi=3.1415926)
18400        Dimension factor(6),pnpi(6)
18401       COMMON/RNDF77/NSEED
18402 cc      SAVE /RNDF77/
18403       SAVE
18404        ISEED=ISEED
18405 C the factorial coefficients in the pion no. distribution
18406 * from n=2 to 6 calculated use the formula in the reference
18407        factor(2)=1.
18408        factor(3)=1.17e-01
18409        factor(4)=3.27e-03
18410        factor(5)=3.58e-05
18411        factor(6)=1.93e-07
18412        ene=(srt/pimass)**3/(6.*pi**2)
18413 c the relative probability from n=2 to 6
18414        do 1001 n=2,6
18415            pnpi(n)=ene**n*factor(n)
18416  1001   continue
18417 c find the maximum of the probabilities, I checked a
18418 c Fortan manual: max() returns the maximum value of
18419 c the same type as in the argument list
18420        pmax=max(pnpi(2),pnpi(3),pnpi(4),pnpi(5),pnpi(6))
18421 c randomly generate n between 2 and 6
18422        ntry=0
18423  10    npion=2+int(5*RANART(NSEED))
18424 clin-4/2008 check bounds:
18425        if(npion.gt.6) goto 10
18426        thisp=pnpi(npion)/pmax
18427        ntry=ntry+1
18428 c decide whether to take this npion according to the distribution
18429 c using rejection method.
18430        if((thisp.lt.RANART(NSEED)).and.(ntry.le.20)) go to 10
18431 c now take the last generated npion and return
18432        return
18433        END
18434 **********************************
18435 cbali2/6/99 end
18436 cbz3/9/99 kkbar
18437 cbali3/5/99
18438 ******************************************
18439 * purpose: Xsection for K+ K- to pi+ pi-
18440 c      real*4 function xkkpi(srt)
18441 *  srt    = DSQRT(s) in GeV                                  *
18442 *  xkkpi   = xsection in mb obtained from
18443 *           the detailed balance                             *
18444 * ******************************************
18445 c          parameter (pimass=0.140,aka=0.498)
18446 c       xkkpi=1.e-08
18447 c       ppi2=(srt/2)**2-pimass**2
18448 c       pk2=(srt/2)**2-aka**2
18449 c       if(ppi2.le.0.or.pk2.le.0)return
18450 cbz3/9/99 kkbar
18451 c       xkkpi=ppi2/pk2*pipik(srt)
18452 c       xkkpi=9.0 / 4.0 * ppi2/pk2*pipik(srt)
18453 c        xkkpi = 2.0 * xkkpi
18454 cbz3/9/99 kkbar end
18455
18456 cbz3/9/99 kkbar
18457 c       end
18458 c       return
18459 c        END
18460 cbz3/9/99 kkbar end
18461
18462 cbali3/5/99 end
18463 cbz3/9/99 kkbar end
18464
18465 cbz3/9/99 kkbar
18466 *****************************
18467 * purpose: Xsection for K+ K- to pi+ pi-
18468       SUBROUTINE XKKANN(SRT, XSK1, XSK2, XSK3, XSK4, XSK5,
18469      &     XSK6, XSK7, XSK8, XSK9, XSK10, XSK11, SIGK, rrkk)
18470 *  srt    = DSQRT(s) in GeV                                       *
18471 *  xsk1   = annihilation into pi pi                               *
18472 *  xsk2   = annihilation into pi rho (shifted to XKKSAN)         *
18473 *  xsk3   = annihilation into pi omega (shifted to XKKSAN)       *
18474 *  xsk4   = annihilation into pi eta                              *
18475 *  xsk5   = annihilation into rho rho                             *
18476 *  xsk6   = annihilation into rho omega                           *
18477 *  xsk7   = annihilation into rho eta (shifted to XKKSAN)        *
18478 *  xsk8   = annihilation into omega omega                         *
18479 *  xsk9   = annihilation into omega eta (shifted to XKKSAN)      *
18480 *  xsk10  = annihilation into eta eta                             *
18481 *  sigk   = xsection in mb obtained from                          *
18482 *           the detailed balance                                  *
18483 * ***************************
18484       PARAMETER  (MAXSTR=150001, MAXX=20,  MAXZ=24)
18485           PARAMETER (AKA=0.498, PIMASS=0.140, RHOM = 0.770,
18486      &     OMEGAM = 0.7819, ETAM = 0.5473, APHI=1.02)
18487       COMMON  /AA/ R(3,MAXSTR)
18488 cc      SAVE /AA/
18489       COMMON /BB/  P(3,MAXSTR)
18490 cc      SAVE /BB/
18491       COMMON /EE/ ID(MAXSTR),LB(MAXSTR)
18492 cc      SAVE /EE/
18493       COMMON  /DD/      RHO(-MAXX:MAXX,-MAXX:MAXX,-MAXZ:MAXZ),
18494      &                     RHOP(-MAXX:MAXX,-MAXX:MAXX,-MAXZ:MAXZ),
18495      &                     RHON(-MAXX:MAXX,-MAXX:MAXX,-MAXZ:MAXZ)
18496 cc      SAVE /DD/
18497       SAVE
18498
18499         S = SRT ** 2
18500        SIGK = 1.E-08
18501         XSK1 = 0.0
18502         XSK2 = 0.0
18503         XSK3 = 0.0
18504         XSK4 = 0.0
18505         XSK5 = 0.0
18506         XSK6 = 0.0
18507         XSK7 = 0.0
18508         XSK8 = 0.0
18509         XSK9 = 0.0
18510         XSK10 = 0.0
18511         XSK11 = 0.0
18512
18513         XPION0 = PIPIK(SRT)
18514 c.....take into account both K+ and K0
18515         XPION0 = 2.0 * XPION0
18516         PI2 = S * (S - 4.0 * AKA ** 2)
18517          if(PI2 .le. 0.0)return
18518
18519         XM1 = PIMASS
18520         XM2 = PIMASS
18521         PF2 = (S - (XM1 + XM2) ** 2) * (S - (XM1 - XM2) ** 2)
18522         IF (PF2 .GT. 0.0) THEN
18523            XSK1 = 9.0 / 4.0 * PF2 / PI2 * XPION0
18524         END IF
18525
18526 clin-8/28/00 (pi eta) eta -> K+K- is assumed the same as pi pi -> K+K-:
18527         XM1 = PIMASS
18528         XM2 = ETAM
18529         PF2 = (S - (XM1 + XM2) ** 2) * (S - (XM1 - XM2) ** 2)
18530         IF (PF2 .GT. 0.0) THEN
18531            XSK4 = 3.0 / 4.0 * PF2 / PI2 * XPION0
18532         END IF
18533
18534         XM1 = ETAM
18535         XM2 = ETAM
18536         PF2 = (S - (XM1 + XM2) ** 2) * (S - (XM1 - XM2) ** 2)
18537         IF (PF2 .GT. 0.0) THEN
18538            XSK10 = 1.0 / 4.0 * PF2 / PI2 * XPION0
18539         END IF
18540
18541         XPION0 = rrkk
18542
18543 clin-11/07/00: (pi eta) (rho omega) -> K* Kbar (or K*bar K) instead to K Kbar:
18544 c        XM1 = PIMASS
18545 c        XM2 = RHOM
18546 c        PF2 = (S - (XM1 + XM2) ** 2) * (S - (XM1 - XM2) ** 2)
18547 c        IF (PF2 .GT. 0.0) THEN
18548 c           XSK2 = 27.0 / 4.0 * PF2 / PI2 * XPION0
18549 c        END IF
18550
18551 c        XM1 = PIMASS
18552 c        XM2 = OMEGAM
18553 c        PF2 = (S - (XM1 + XM2) ** 2) * (S - (XM1 - XM2) ** 2)
18554 c        IF (PF2 .GT. 0.0) THEN
18555 c           XSK3 = 9.0 / 4.0 * PF2 / PI2 * XPION0
18556 c        END IF
18557
18558         XM1 = RHOM
18559         XM2 = RHOM
18560         PF2 = (S - (XM1 + XM2) ** 2) * (S - (XM1 - XM2) ** 2)
18561         IF (PF2 .GT. 0.0) THEN
18562            XSK5 = 81.0 / 4.0 * PF2 / PI2 * XPION0
18563         END IF
18564
18565         XM1 = RHOM
18566         XM2 = OMEGAM
18567         PF2 = (S - (XM1 + XM2) ** 2) * (S - (XM1 - XM2) ** 2)
18568         IF (PF2 .GT. 0.0) THEN
18569            XSK6 = 27.0 / 4.0 * PF2 / PI2 * XPION0
18570         END IF
18571
18572 c        XM1 = RHOM
18573 c        XM2 = ETAM
18574 c        PF2 = (S - (XM1 + XM2) ** 2) * (S - (XM1 - XM2) ** 2)
18575 c        IF (PF2 .GT. 0.0) THEN
18576 c           XSK7 = 9.0 / 4.0 * PF2 / PI2 * XPION0
18577 c        END IF
18578
18579         XM1 = OMEGAM
18580         XM2 = OMEGAM
18581         PF2 = (S - (XM1 + XM2) ** 2) * (S - (XM1 - XM2) ** 2)
18582         IF (PF2 .GT. 0.0) THEN
18583            XSK8 = 9.0 / 4.0 * PF2 / PI2 * XPION0
18584         END IF
18585
18586 c        XM1 = OMEGAM
18587 c        XM2 = ETAM
18588 c        PF2 = (S - (XM1 + XM2) ** 2) * (S - (XM1 - XM2) ** 2)
18589 c        IF (PF2 .GT. 0.0) THEN
18590 c           XSK9 = 3.0 / 4.0 * PF2 / PI2 * XPION0
18591 c        END IF
18592
18593 c* K+ + K- --> phi
18594           fwdp = 1.68*(aphi**2-4.*aka**2)**1.5/6./aphi/aphi
18595           pkaon=0.5*sqrt(srt**2-4.0*aka**2)
18596           XSK11 = 30.*3.14159*0.1973**2*(aphi*fwdp)**2/
18597      &             ((srt**2-aphi**2)**2+(aphi*fwdp)**2)/pkaon**2
18598 c
18599         SIGK = XSK1 + XSK2 + XSK3 + XSK4 + XSK5 +
18600      &     XSK6 + XSK7 + XSK8 + XSK9 + XSK10 + XSK11
18601
18602        RETURN
18603         END
18604 cbz3/9/99 kkbar end
18605
18606 *****************************
18607 * purpose: Xsection for Phi + B
18608        SUBROUTINE XphiB(LB1, LB2, EM1, EM2, SRT,
18609      &                  XSK1, XSK2, XSK3, XSK4, XSK5, SIGP)
18610 c
18611 * ***************************
18612         PARAMETER (MAXSTR=150001,MAXR=1,AMN=0.939457,
18613      1  AMP=0.93828,AP1=0.13496,AP2=0.13957,AM0=1.232,PI=3.1415926)
18614           PARAMETER (AKA=0.498, ALA = 1.1157, PIMASS=0.140, APHI=1.02)
18615         parameter (arho=0.77)
18616       SAVE
18617
18618        SIGP = 1.E-08
18619         XSK1 = 0.0
18620         XSK2 = 0.0
18621         XSK3 = 0.0
18622         XSK4 = 0.0
18623         XSK5 = 0.0
18624         XSK6 = 0.0
18625           srrt = srt - (em1+em2)
18626
18627 c* phi + N(D) -> elastic scattering
18628 c            XSK1 = 0.56  !! mb
18629 c  !! mb  (photo-production xsecn used)
18630             XSK1 = 8.00
18631 c
18632 c* phi + N(D) -> pi + N
18633         IF (srt  .GT. (ap1+amn)) THEN
18634              XSK2 = 0.0235*srrt**(-0.519)
18635         END IF
18636 c
18637 c* phi + N(D) -> pi + D
18638         IF (srt  .GT. (ap1+am0)) THEN
18639             if(srrt .lt. 0.7)then
18640              XSK3 = 0.0119*srrt**(-0.534)
18641             else
18642              XSK3 = 0.0130*srrt**(-0.304)
18643             endif
18644         END IF
18645 c
18646 c* phi + N(D) -> rho + N
18647         IF (srt  .GT. (arho+amn)) THEN
18648            if(srrt .lt. 0.7)then
18649              XSK4 = 0.0166*srrt**(-0.786)
18650             else
18651              XSK4 = 0.0189*srrt**(-0.277)
18652             endif
18653         END IF
18654 c
18655 c* phi + N(D) -> rho + D   (same as pi + D)
18656         IF (srt  .GT. (arho+am0)) THEN
18657             if(srrt .lt. 0.7)then
18658              XSK5 = 0.0119*srrt**(-0.534)
18659             else
18660              XSK5 = 0.0130*srrt**(-0.304)
18661             endif
18662         END IF
18663 c
18664 c* phi + N -> K+ + La
18665        IF( (lb1.ge.1.and.lb1.le.2) .or. (lb2.ge.1.and.lb2.le.2) )THEN
18666         IF (srt  .GT. (aka+ala)) THEN
18667            XSK6 = 1.715/((srrt+3.508)**2-12.138)
18668         END IF
18669        END IF
18670         SIGP = XSK1 + XSK2 + XSK3 + XSK4 + XSK5 + XSK6
18671        RETURN
18672         END
18673 c
18674 **********************************
18675 *
18676         SUBROUTINE CRPHIB(PX,PY,PZ,SRT,I1,I2,
18677      &     XSK1, XSK2, XSK3, XSK4, XSK5, SIGP, IBLOCK)
18678 *
18679 *     PURPOSE:                                                         *
18680 *             DEALING WITH PHI + N(D) --> pi+N(D), rho+N(D),  K+ + La
18681 *     QUANTITIES:                                                      *
18682 *           PX,PY,PZ - MOMENTUM COORDINATES OF ONE PARTICLE IN CM FRAME*
18683 *           SRT      - SQRT OF S                                       *
18684 *           IBLOCK   - INFORMATION about the reaction channel          *
18685 *
18686 *             iblock   - 20  elastic
18687 *             iblock   - 221  K+ formation
18688 *             iblock   - 223  others
18689 **********************************
18690         PARAMETER (MAXSTR=150001,MAXR=1,AMN=0.939457,
18691      1  AMP=0.93828,AP1=0.13496,AMRHO=0.769,AMOMGA=0.782,
18692      2  AP2=0.13957,AM0=1.232,PI=3.1415926,CUTOFF=1.8966,AVMASS=0.9383)
18693         PARAMETER      (AKA=0.498,ALA=1.1157,ASA=1.1974,ARHO=0.77)
18694         parameter     (MX=4,MY=4,MZ=8,MPX=4,MPY=4,mpz=10,mpzp=10)
18695         COMMON /AA/ R(3,MAXSTR)
18696 cc      SAVE /AA/
18697         COMMON /BB/ P(3,MAXSTR)
18698 cc      SAVE /BB/
18699         COMMON /CC/ E(MAXSTR)
18700 cc      SAVE /CC/
18701         COMMON /EE/ ID(MAXSTR),LB(MAXSTR)
18702 cc      SAVE /EE/
18703         common/input1/ MASSPR,MASSTA,ISEED,IAVOID,DT
18704 cc      SAVE /input1/
18705       COMMON/RNDF77/NSEED
18706 cc      SAVE /RNDF77/
18707       SAVE
18708 c
18709        PX0=PX
18710        PY0=PY
18711        PZ0=PZ
18712        IBLOCK=223
18713 c
18714         X1 = RANART(NSEED) * SIGP
18715         XSK2 = XSK1 + XSK2
18716         XSK3 = XSK2 + XSK3
18717         XSK4 = XSK3 + XSK4
18718         XSK5 = XSK4 + XSK5
18719 c
18720 c  !! elastic scatt.
18721         IF (X1 .LE. XSK1) THEN
18722            iblock=20
18723            GOTO 100
18724         ELSE IF (X1 .LE. XSK2) THEN
18725            LB(I1) = 3 + int(3 * RANART(NSEED))
18726            LB(I2) = 1 + int(2 * RANART(NSEED))
18727            E(I1) = AP1
18728            E(I2) = AMN
18729            GOTO 100
18730         ELSE IF (X1 .LE. XSK3) THEN
18731            LB(I1) = 3 + int(3 * RANART(NSEED))
18732            LB(I2) = 6 + int(4 * RANART(NSEED))
18733            E(I1) = AP1
18734            E(I2) = AM0
18735            GOTO 100
18736         ELSE IF (X1 .LE. XSK4) THEN
18737            LB(I1) = 25 + int(3 * RANART(NSEED))
18738            LB(I2) = 1 + int(2 * RANART(NSEED))
18739            E(I1) = ARHO
18740            E(I2) = AMN
18741            GOTO 100
18742         ELSE IF (X1 .LE. XSK5) THEN
18743            LB(I1) = 25 + int(3 * RANART(NSEED))
18744            LB(I2) = 6 + int(4 * RANART(NSEED))
18745            E(I1) = ARHO
18746            E(I2) = AM0
18747            GOTO 100
18748         ELSE
18749            LB(I1) = 23
18750            LB(I2) = 14
18751            E(I1) = AKA
18752            E(I2) = ALA
18753           IBLOCK=221
18754          ENDIF
18755  100    CONTINUE
18756       EM1=E(I1)
18757       EM2=E(I2)
18758 *-----------------------------------------------------------------------
18759 * CALCULATE THE MAGNITUDE OF THE FINAL MOMENTUM THROUGH
18760 * ENERGY CONSERVATION
18761           PR2   = (SRT**2 - EM1**2 - EM2**2)**2
18762      1                - 4.0 * (EM1*EM2)**2
18763           IF(PR2.LE.0.)PR2=1.E-08
18764           PR=SQRT(PR2)/(2.*SRT)
18765 * WE ASSUME AN ISOTROPIC ANGULAR DISTRIBUTION IN THE CMS
18766           C1   = 1.0 - 2.0 * RANART(NSEED)
18767           T1   = 2.0 * PI * RANART(NSEED)
18768       S1   = SQRT( 1.0 - C1**2 )
18769       CT1  = COS(T1)
18770       ST1  = SIN(T1)
18771 * THE MOMENTUM IN THE CMS IN THE FINAL STATE
18772       PZ   = PR * C1
18773       PX   = PR * S1*CT1
18774       PY   = PR * S1*ST1
18775 * ROTATE IT
18776        CALL ROTATE(PX0,PY0,PZ0,PX,PY,PZ)
18777       RETURN
18778       END
18779 c
18780 *****************************
18781 * purpose: Xsection for Phi + B
18782 c!! in fm^2
18783       SUBROUTINE pibphi(srt,lb1,lb2,em1,em2,Xphi,xphin)
18784 c
18785 *      phi + N(D) <- pi + N
18786 *      phi + N(D) <- pi + D
18787 *      phi + N(D) <- rho + N
18788 *      phi + N(D) <- rho + D   (same as pi + D)
18789 c
18790 * ***************************
18791         PARAMETER (MAXSTR=150001,MAXR=1,AMN=0.939457,
18792      1  AMP=0.93828,AP1=0.13496,AP2=0.13957,AM0=1.232,PI=3.1415926)
18793           PARAMETER (AKA=0.498, ALA = 1.1157, PIMASS=0.140, APHI=1.02)
18794         parameter (arho=0.77)
18795       SAVE
18796
18797        Xphi = 0.0
18798        xphin = 0.0
18799        xphid = 0.0
18800 c
18801        if( (lb1.ge.3.and.lb1.le.5) .or.
18802      &     (lb2.ge.3.and.lb2.le.5) )then
18803 c
18804        if( (iabs(lb1).ge.1.and.iabs(lb1).le.2) .or.
18805      &     (iabs(lb2).ge.1.and.iabs(lb2).le.2) )then
18806 c* phi + N <- pi + N
18807         IF (srt  .GT. (aphi+amn)) THEN
18808              srrt = srt - (aphi+amn)
18809              sig = 0.0235*srrt**(-0.519)
18810           xphin=sig*1.*(srt**2-(aphi+amn)**2)*
18811      &           (srt**2-(aphi-amn)**2)/(srt**2-(em1+em2)**2)/
18812      &           (srt**2-(em1-em2)**2)
18813         END IF
18814 c* phi + D <- pi + N
18815         IF (srt  .GT. (aphi+am0)) THEN
18816              srrt = srt - (aphi+am0)
18817              sig = 0.0235*srrt**(-0.519)
18818           xphid=sig*4.*(srt**2-(aphi+am0)**2)*
18819      &           (srt**2-(aphi-am0)**2)/(srt**2-(em1+em2)**2)/
18820      &           (srt**2-(em1-em2)**2)
18821         END IF
18822        else
18823 c* phi + N <- pi + D
18824         IF (srt  .GT. (aphi+amn)) THEN
18825              srrt = srt - (aphi+amn)
18826             if(srrt .lt. 0.7)then
18827              sig = 0.0119*srrt**(-0.534)
18828             else
18829              sig = 0.0130*srrt**(-0.304)
18830             endif
18831           xphin=sig*(1./4.)*(srt**2-(aphi+amn)**2)*
18832      &           (srt**2-(aphi-amn)**2)/(srt**2-(em1+em2)**2)/
18833      &           (srt**2-(em1-em2)**2)
18834         END IF
18835 c* phi + D <- pi + D
18836         IF (srt  .GT. (aphi+am0)) THEN
18837              srrt = srt - (aphi+am0)
18838              if(srrt .lt. 0.7)then
18839              sig = 0.0119*srrt**(-0.534)
18840             else
18841              sig = 0.0130*srrt**(-0.304)
18842             endif
18843           xphid=sig*1.*(srt**2-(aphi+am0)**2)*
18844      &           (srt**2-(aphi-am0)**2)/(srt**2-(em1+em2)**2)/
18845      &           (srt**2-(em1-em2)**2)
18846         END IF
18847        endif
18848 c
18849 c
18850 C** for rho + N(D) colln
18851 c
18852        else
18853 c
18854        if( (iabs(lb1).ge.1.and.iabs(lb1).le.2) .or.
18855      &     (iabs(lb2).ge.1.and.iabs(lb2).le.2) )then
18856 c
18857 c* phi + N <- rho + N
18858         IF (srt  .GT. (aphi+amn)) THEN
18859              srrt = srt - (aphi+amn)
18860            if(srrt .lt. 0.7)then
18861              sig = 0.0166*srrt**(-0.786)
18862             else
18863              sig = 0.0189*srrt**(-0.277)
18864             endif
18865           xphin=sig*(1./3.)*(srt**2-(aphi+amn)**2)*
18866      &           (srt**2-(aphi-amn)**2)/(srt**2-(em1+em2)**2)/
18867      &           (srt**2-(em1-em2)**2)
18868         END IF
18869 c* phi + D <- rho + N
18870         IF (srt  .GT. (aphi+am0)) THEN
18871              srrt = srt - (aphi+am0)
18872            if(srrt .lt. 0.7)then
18873              sig = 0.0166*srrt**(-0.786)
18874             else
18875              sig = 0.0189*srrt**(-0.277)
18876             endif
18877           xphid=sig*(4./3.)*(srt**2-(aphi+am0)**2)*
18878      &           (srt**2-(aphi-am0)**2)/(srt**2-(em1+em2)**2)/
18879      &           (srt**2-(em1-em2)**2)
18880         END IF
18881        else
18882 c* phi + N <- rho + D  (same as pi+D->phi+N)
18883         IF (srt  .GT. (aphi+amn)) THEN
18884              srrt = srt - (aphi+amn)
18885             if(srrt .lt. 0.7)then
18886              sig = 0.0119*srrt**(-0.534)
18887             else
18888              sig = 0.0130*srrt**(-0.304)
18889             endif
18890           xphin=sig*(1./12.)*(srt**2-(aphi+amn)**2)*
18891      &           (srt**2-(aphi-amn)**2)/(srt**2-(em1+em2)**2)/
18892      &           (srt**2-(em1-em2)**2)
18893         END IF
18894 c* phi + D <- rho + D  (same as pi+D->phi+D)
18895         IF (srt  .GT. (aphi+am0)) THEN
18896              srrt = srt - (aphi+am0)
18897              if(srrt .lt. 0.7)then
18898              sig = 0.0119*srrt**(-0.534)
18899             else
18900              sig = 0.0130*srrt**(-0.304)
18901             endif
18902           xphid=sig*(1./3.)*(srt**2-(aphi+am0)**2)*
18903      &           (srt**2-(aphi-am0)**2)/(srt**2-(em1+em2)**2)/
18904      &           (srt**2-(em1-em2)**2)
18905         END IF
18906        endif
18907         END IF
18908 c   !! in fm^2
18909          xphin = xphin/10.
18910 c   !! in fm^2
18911          xphid = xphid/10.
18912          Xphi = xphin + xphid
18913
18914        RETURN
18915         END
18916 c
18917 *****************************
18918 * purpose: Xsection for phi +M to K+K etc
18919       SUBROUTINE PHIMES(I1, I2, SRT, XSK1, XSK2, XSK3, XSK4, XSK5,
18920      1     XSK6, XSK7, SIGPHI)
18921
18922 *     QUANTITIES:                                                      *
18923 *           PX,PY,PZ - MOMENTUM COORDINATES OF ONE PARTICLE IN CM FRAME*
18924 *           SRT      - SQRT OF S                                       *
18925 *           IBLOCK   - THE INFORMATION BACK                            *
18926 *                      223 --> phi destruction
18927 *                      20 -->  elastic
18928 **********************************
18929         PARAMETER (MAXSTR=150001,MAXR=1,AMN=0.939457,
18930      1  AMP=0.93828,AP1=0.13496,
18931      2  AP2=0.13957,AM0=1.232,PI=3.1415926,CUTOFF=1.8966,AVMASS=0.9383)
18932         PARAMETER  (AKA=0.498, AKS=0.895, AOMEGA=0.7819,
18933      3               ARHO=0.77, APHI=1.02)
18934         parameter     (MX=4,MY=4,MZ=8,MPX=4,MPY=4,mpz=10,mpzp=10)
18935         PARAMETER  (MAXX=20,  MAXZ=24)
18936         COMMON /AA/ R(3,MAXSTR)
18937 cc      SAVE /AA/
18938         COMMON /BB/ P(3,MAXSTR)
18939 cc      SAVE /BB/
18940         COMMON /CC/ E(MAXSTR)
18941 cc      SAVE /CC/
18942       COMMON  /DD/      RHO(-MAXX:MAXX,-MAXX:MAXX,-MAXZ:MAXZ),
18943      &                     RHOP(-MAXX:MAXX,-MAXX:MAXX,-MAXZ:MAXZ),
18944      &                     RHON(-MAXX:MAXX,-MAXX:MAXX,-MAXZ:MAXZ)
18945 cc      SAVE /DD/
18946         COMMON /EE/ ID(MAXSTR),LB(MAXSTR)
18947 cc      SAVE /EE/
18948       SAVE
18949
18950         S = SRT ** 2
18951        SIGPHI = 1.E-08
18952         XSK1 = 0.0
18953         XSK2 = 0.0
18954         XSK3 = 0.0
18955         XSK4 = 0.0
18956         XSK5 = 0.0
18957         XSK6 = 0.0
18958         XSK7 = 0.0
18959          em1 = E(i1)
18960          em2 = E(i2)
18961          LB1 = LB(i1)
18962          LB2 = LB(i2)
18963          akap = aka
18964 c******
18965 c
18966 c   !! mb, elastic
18967          XSK1 = 5.0
18968
18969            pii = sqrt((S-(em1+em2)**2)*(S-(em1-em2)**2))
18970 * phi + K(-bar) channel
18971        if( lb1.eq.23.or.lb2.eq.23 .or. lb1.eq.21.or.lb2.eq.21 )then
18972           if(srt .gt. (ap1+akap))then
18973 c             XSK2 = 2.5
18974            pff = sqrt((S-(ap1+akap)**2)*(S-(ap1-akap)**2))
18975            XSK2 = 195.639*pff/pii/32./pi/S
18976           endif
18977           if(srt .gt. (arho+akap))then
18978 c              XSK3 = 3.5
18979            pff = sqrt((S-(arho+akap)**2)*(S-(arho-akap)**2))
18980            XSK3 = 526.702*pff/pii/32./pi/S
18981           endif
18982           if(srt .gt. (aomega+akap))then
18983 c               XSK4 = 3.5
18984            pff = sqrt((S-(aomega+akap)**2)*(S-(aomega-akap)**2))
18985            XSK4 = 355.429*pff/pii/32./pi/S
18986           endif
18987           if(srt .gt. (ap1+aks))then
18988 c           XSK5 = 15.0
18989            pff = sqrt((S-(ap1+aks)**2)*(S-(ap1-aks)**2))
18990            XSK5 = 2047.042*pff/pii/32./pi/S
18991           endif
18992           if(srt .gt. (arho+aks))then
18993 c            XSK6 = 3.5
18994            pff = sqrt((S-(arho+aks)**2)*(S-(arho-aks)**2))
18995            XSK6 = 1371.257*pff/pii/32./pi/S
18996           endif
18997           if(srt .gt. (aomega+aks))then
18998 c            XSK7 = 3.5
18999            pff = sqrt((S-(aomega+aks)**2)*(S-(aomega-aks)**2))
19000            XSK7 = 482.292*pff/pii/32./pi/S
19001           endif
19002 c
19003        elseif( iabs(lb1).eq.30.or.iabs(lb2).eq.30 )then
19004 * phi + K*(-bar) channel
19005 c
19006           if(srt .gt. (ap1+akap))then
19007 c             XSK2 = 3.5
19008            pff = sqrt((S-(ap1+akap)**2)*(S-(ap1-akap)**2))
19009            XSK2 = 372.378*pff/pii/32./pi/S
19010           endif
19011           if(srt .gt. (arho+akap))then
19012 c              XSK3 = 9.0
19013            pff = sqrt((S-(arho+akap)**2)*(S-(arho-akap)**2))
19014            XSK3 = 1313.960*pff/pii/32./pi/S
19015           endif
19016           if(srt .gt. (aomega+akap))then
19017 c               XSK4 = 6.5
19018            pff = sqrt((S-(aomega+akap)**2)*(S-(aomega-akap)**2))
19019            XSK4 = 440.558*pff/pii/32./pi/S
19020           endif
19021           if(srt .gt. (ap1+aks))then
19022 c           XSK5 = 30.0 !wrong
19023            pff = sqrt((S-(ap1+aks)**2)*(S-(ap1-aks)**2))
19024            XSK5 = 1496.692*pff/pii/32./pi/S
19025           endif
19026           if(srt .gt. (arho+aks))then
19027 c            XSK6 = 9.0
19028            pff = sqrt((S-(arho+aks)**2)*(S-(arho-aks)**2))
19029            XSK6 = 6999.840*pff/pii/32./pi/S
19030           endif
19031           if(srt .gt. (aomega+aks))then
19032 c            XSK7 = 15.0
19033            pff = sqrt((S-(aomega+aks)**2)*(S-(aomega-aks)**2))
19034            XSK7 = 1698.903*pff/pii/32./pi/S
19035           endif
19036        else
19037 c
19038 * phi + rho(pi,omega) channel
19039 c
19040            srr1 = em1+em2
19041          if(srt .gt. (akap+akap))then
19042           srrt = srt - srr1
19043 cc          if(srrt .lt. 0.3)then
19044           if(srrt .lt. 0.3 .and. srrt .gt. 0.01)then
19045           XSK2 = 1.69/(srrt**0.141 - 0.407)
19046           else
19047           XSK2 = 3.74 + 0.008*srrt**1.9
19048           endif
19049          endif
19050          if(srt .gt. (akap+aks))then
19051           srr2 = akap+aks
19052           srr = amax1(srr1,srr2)
19053           srrt = srt - srr
19054 cc          if(srrt .lt. 0.3)then
19055           if(srrt .lt. 0.3 .and. srrt .gt. 0.01)then
19056           XSK3 = 1.69/(srrt**0.141 - 0.407)
19057           else
19058           XSK3 = 3.74 + 0.008*srrt**1.9
19059           endif
19060          endif
19061          if(srt .gt. (aks+aks))then
19062           srr2 = aks+aks
19063           srr = amax1(srr1,srr2)
19064           srrt = srt - srr
19065 cc          if(srrt .lt. 0.3)then
19066           if(srrt .lt. 0.3 .and. srrt .gt. 0.01)then
19067           XSK4 = 1.69/(srrt**0.141 - 0.407)
19068           else
19069           XSK4 = 3.74 + 0.008*srrt**1.9
19070           endif
19071          endif
19072 c          xsk2 = amin1(20.,xsk2)
19073 c          xsk3 = amin1(20.,xsk3)
19074 c          xsk4 = amin1(20.,xsk4)
19075       endif
19076
19077         SIGPHI = XSK1 + XSK2 + XSK3 + XSK4 + XSK5 + XSK6 + XSK7
19078
19079        RETURN
19080        END
19081
19082 **********************************
19083 *     PURPOSE:                                                         *
19084 *             DEALING WITH phi+M  scatt.
19085 *
19086        SUBROUTINE CRPHIM(PX,PY,PZ,SRT,I1,I2,
19087      &  XSK1, XSK2, XSK3, XSK4, XSK5, XSK6, SIGPHI, IKKG, IKKL, IBLOCK)
19088 *
19089 *     QUANTITIES:                                                      *
19090 *           PX,PY,PZ - MOMENTUM COORDINATES OF ONE PARTICLE IN CM FRAME*
19091 *           SRT      - SQRT OF S                                       *
19092 *           IBLOCK   - THE INFORMATION BACK                            *
19093 *                      20 -->  elastic
19094 *                      223 --> phi + pi(rho,omega)
19095 *                      224 --> phi + K -> K + pi(rho,omega)
19096 *                      225 --> phi + K -> K* + pi(rho,omega)
19097 *                      226 --> phi + K* -> K + pi(rho,omega)
19098 *                      227 --> phi + K* -> K* + pi(rho,omega)
19099 **********************************
19100         PARAMETER (MAXSTR=150001,MAXR=1,AMN=0.939457,
19101      1  AMP=0.93828,AP1=0.13496,ARHO=0.77,AOMEGA=0.7819,
19102      2  AP2=0.13957,AM0=1.232,PI=3.1415926,CUTOFF=1.8966,AVMASS=0.9383)
19103         PARAMETER    (AKA=0.498,AKS=0.895)
19104         parameter   (MX=4,MY=4,MZ=8,MPX=4,MPY=4,mpz=10,mpzp=10)
19105         COMMON /AA/ R(3,MAXSTR)
19106 cc      SAVE /AA/
19107         COMMON /BB/ P(3,MAXSTR)
19108 cc      SAVE /BB/
19109         COMMON /CC/ E(MAXSTR)
19110 cc      SAVE /CC/
19111         COMMON /EE/ ID(MAXSTR),LB(MAXSTR)
19112 cc      SAVE /EE/
19113         common/input1/ MASSPR,MASSTA,ISEED,IAVOID,DT
19114 cc      SAVE /input1/
19115       COMMON/RNDF77/NSEED
19116 cc      SAVE /RNDF77/
19117       SAVE
19118 c
19119        PX0=PX
19120        PY0=PY
19121        PZ0=PZ
19122          LB1 = LB(i1)
19123          LB2 = LB(i2)
19124
19125         X1 = RANART(NSEED) * SIGPHI
19126         XSK2 = XSK1 + XSK2
19127         XSK3 = XSK2 + XSK3
19128         XSK4 = XSK3 + XSK4
19129         XSK5 = XSK4 + XSK5
19130         XSK6 = XSK5 + XSK6
19131         IF (X1 .LE. XSK1) THEN
19132 c        !! elastic scatt
19133            IBLOCK=20
19134            GOTO 100
19135         ELSE
19136 c
19137 *phi + (K,K*)-bar
19138        if( lb1.eq.23.or.lb1.eq.21.or.iabs(lb1).eq.30 .OR.
19139      &     lb2.eq.23.or.lb2.eq.21.or.iabs(lb2).eq.30 )then
19140 c
19141              if(lb1.eq.23.or.lb2.eq.23)then
19142                IKKL=1
19143                IBLOCK=224
19144                iad1 = 23
19145                iad2 = 30
19146               elseif(lb1.eq.30.or.lb2.eq.30)then
19147                IKKL=0
19148                IBLOCK=226
19149                iad1 = 23
19150                iad2 = 30
19151              elseif(lb1.eq.21.or.lb2.eq.21)then
19152                IKKL=1
19153                IBLOCK=124
19154                iad1 = 21
19155                iad2 = -30
19156 c         !! -30
19157              else
19158                IKKL=0
19159                IBLOCK=126
19160                iad1 = 21
19161                iad2 = -30
19162               endif
19163          IF (X1 .LE. XSK2) THEN
19164            LB(I1) = 3 + int(3 * RANART(NSEED))
19165            LB(I2) = iad1
19166            E(I1) = AP1
19167            E(I2) = AKA
19168            IKKG = 1
19169            GOTO 100
19170         ELSE IF (X1 .LE. XSK3) THEN
19171            LB(I1) = 25 + int(3 * RANART(NSEED))
19172            LB(I2) = iad1
19173            E(I1) = ARHO
19174            E(I2) = AKA
19175            IKKG = 1
19176            GOTO 100
19177         ELSE IF (X1 .LE. XSK4) THEN
19178            LB(I1) = 28
19179            LB(I2) = iad1
19180            E(I1) = AOMEGA
19181            E(I2) = AKA
19182            IKKG = 1
19183            GOTO 100
19184         ELSE IF (X1 .LE. XSK5) THEN
19185            LB(I1) = 3 + int(3 * RANART(NSEED))
19186            LB(I2) = iad2
19187            E(I1) = AP1
19188            E(I2) = AKS
19189            IKKG = 0
19190            IBLOCK=IBLOCK+1
19191            GOTO 100
19192         ELSE IF (X1 .LE. XSK6) THEN
19193            LB(I1) = 25 + int(3 * RANART(NSEED))
19194            LB(I2) = iad2
19195            E(I1) = ARHO
19196            E(I2) = AKS
19197            IKKG = 0
19198            IBLOCK=IBLOCK+1
19199            GOTO 100
19200         ELSE
19201            LB(I1) = 28
19202            LB(I2) = iad2
19203            E(I1) = AOMEGA
19204            E(I2) = AKS
19205            IKKG = 0
19206            IBLOCK=IBLOCK+1
19207            GOTO 100
19208          ENDIF
19209        else
19210 c      !! phi destruction via (pi,rho,omega)
19211           IBLOCK=223
19212 *phi + pi(rho,omega)
19213          IF (X1 .LE. XSK2) THEN
19214            LB(I1) = 23
19215            LB(I2) = 21
19216            E(I1) = AKA
19217            E(I2) = AKA
19218            IKKG = 2
19219            IKKL = 0
19220            GOTO 100
19221         ELSE IF (X1 .LE. XSK3) THEN
19222            LB(I1) = 23
19223 c           LB(I2) = 30
19224            LB(I2) = -30
19225 clin-2/10/03 currently take XSK3 to be the sum of KK*bar & KbarK*:
19226            if(RANART(NSEED).le.0.5) then
19227               LB(I1) = 21
19228               LB(I2) = 30
19229            endif
19230
19231            E(I1) = AKA
19232            E(I2) = AKS
19233            IKKG = 1
19234            IKKL = 0
19235            GOTO 100
19236         ELSE IF (X1 .LE. XSK4) THEN
19237            LB(I1) = 30
19238 c           LB(I2) = 30
19239            LB(I2) = -30
19240            E(I1) = AKS
19241            E(I2) = AKS
19242            IKKG = 0
19243            IKKL = 0
19244            GOTO 100
19245          ENDIF
19246        endif
19247          ENDIF
19248 *
19249 100    CONTINUE
19250        EM1=E(I1)
19251        EM2=E(I2)
19252
19253 *-----------------------------------------------------------------------
19254 * CALCULATE THE MAGNITUDE OF THE FINAL MOMENTUM THROUGH
19255 * ENERGY CONSERVATION
19256           PR2   = (SRT**2 - EM1**2 - EM2**2)**2
19257      1                - 4.0 * (EM1*EM2)**2
19258           IF(PR2.LE.0.)PR2=1.E-08
19259           PR=SQRT(PR2)/(2.*SRT)
19260 * WE ASSUME AN ISOTROPIC ANGULAR DISTRIBUTION IN THE CMS
19261           C1   = 1.0 - 2.0 * RANART(NSEED)
19262           T1   = 2.0 * PI * RANART(NSEED)
19263       S1   = SQRT( 1.0 - C1**2 )
19264       CT1  = COS(T1)
19265       ST1  = SIN(T1)
19266 * THE MOMENTUM IN THE CMS IN THE FINAL STATE
19267       PZ   = PR * C1
19268       PX   = PR * S1*CT1
19269       PY   = PR * S1*ST1
19270 * ROTATE IT
19271        CALL ROTATE(PX0,PY0,PZ0,PX,PY,PZ)
19272       RETURN
19273       END
19274 **********************************
19275 **********************************
19276 cbz3/9/99 khyperon
19277 *************************************
19278 * purpose: Xsection for K+Y ->  piN                                       *
19279 *          Xsection for K+Y-bar ->  piN-bar   !! sp03/29/01               *
19280 *
19281         SUBROUTINE XKHYPE(I1, I2, SRT, XKY1, XKY2, XKY3, XKY4, XKY5,
19282      &     XKY6, XKY7, XKY8, XKY9, XKY10, XKY11, XKY12, XKY13,
19283      &     XKY14, XKY15, XKY16, XKY17, SIGK)
19284 c      subroutine xkhype(i1, i2, srt, sigk)
19285 *  srt    = DSQRT(s) in GeV                                               *
19286 *  xkkpi   = xsection in mb obtained from                                 *
19287 *           the detailed balance                                          *
19288 * ***********************************
19289         PARAMETER (MAXSTR=150001,MAXR=1,AMN=0.939457,
19290      1  AMP=0.93828,AP1=0.13496,AMRHO=0.769,AMOMGA=0.782,APHI=1.02,
19291      2  AP2=0.13957,AM0=1.232,PI=3.1415926,CUTOFF=1.8966,AVMASS=0.9383)
19292           parameter (pimass=0.140, AMETA = 0.5473, aka=0.498,
19293      &     aml=1.116,ams=1.193, AM1440 = 1.44, AM1535 = 1.535)
19294         COMMON  /EE/ID(MAXSTR), LB(MAXSTR)
19295 cc      SAVE /EE/
19296       SAVE
19297
19298         S = SRT ** 2
19299        SIGK=1.E-08
19300         XKY1 = 0.0
19301         XKY2 = 0.0
19302         XKY3 = 0.0
19303         XKY4 = 0.0
19304         XKY5 = 0.0
19305         XKY6 = 0.0
19306         XKY7 = 0.0
19307         XKY8 = 0.0
19308         XKY9 = 0.0
19309         XKY10 = 0.0
19310         XKY11 = 0.0
19311         XKY12 = 0.0
19312         XKY13 = 0.0
19313         XKY14 = 0.0
19314         XKY15 = 0.0
19315         XKY16 = 0.0
19316         XKY17 = 0.0
19317
19318         LB1 = LB(I1)
19319         LB2 = LB(I2)
19320         IF (iabs(LB1) .EQ. 14 .OR. iabs(LB2) .EQ. 14) THEN
19321            XKAON0 = PNLKA(SRT)
19322            XKAON0 = 2.0 * XKAON0
19323            PI2 = (S - (AML + AKA) ** 2) * (S - (AML - AKA) ** 2)
19324         ELSE
19325            XKAON0 = PNSKA(SRT)
19326            XKAON0 = 2.0 * XKAON0
19327            PI2 = (S - (AMS + AKA) ** 2) * (S - (AMS - AKA) ** 2)
19328         END IF
19329           if(PI2 .le. 0.0)return
19330
19331         XM1 = PIMASS
19332         XM2 = AMP
19333         PF2 = (S - (XM1 + XM2) ** 2) * (S - (XM1 - XM2) ** 2)
19334         IF (PF2 .GT. 0.0) THEN
19335            XKY1 = 3.0 * PF2 / PI2 * XKAON0
19336         END IF
19337
19338         XM1 = PIMASS
19339         XM2 = AM0
19340         PF2 = (S - (XM1 + XM2) ** 2) * (S - (XM1 - XM2) ** 2)
19341         IF (PF2 .GT. 0.0) THEN
19342            XKY2 = 12.0 * PF2 / PI2 * XKAON0
19343         END IF
19344
19345         XM1 = PIMASS
19346         XM2 = AM1440
19347         PF2 = (S - (XM1 + XM2) ** 2) * (S - (XM1 - XM2) ** 2)
19348         IF (PF2 .GT. 0.0) THEN
19349            XKY3 = 3.0 * PF2 / PI2 * XKAON0
19350         END IF
19351
19352         XM1 = PIMASS
19353         XM2 = AM1535
19354         PF2 = (S - (XM1 + XM2) ** 2) * (S - (XM1 - XM2) ** 2)
19355         IF (PF2 .GT. 0.0) THEN
19356            XKY4 = 3.0 * PF2 / PI2 * XKAON0
19357         END IF
19358
19359         XM1 = AMRHO
19360         XM2 = AMP
19361         PF2 = (S - (XM1 + XM2) ** 2) * (S - (XM1 - XM2) ** 2)
19362         IF (PF2 .GT. 0.0) THEN
19363            XKY5 = 9.0 * PF2 / PI2 * XKAON0
19364         END IF
19365
19366         XM1 = AMRHO
19367         XM2 = AM0
19368         PF2 = (S - (XM1 + XM2) ** 2) * (S - (XM1 - XM2) ** 2)
19369         IF (PF2 .GT. 0.0) THEN
19370            XKY6 = 36.0 * PF2 / PI2 * XKAON0
19371         END IF
19372
19373         XM1 = AMRHO
19374         XM2 = AM1440
19375         PF2 = (S - (XM1 + XM2) ** 2) * (S - (XM1 - XM2) ** 2)
19376         IF (PF2 .GT. 0.0) THEN
19377            XKY7 = 9.0 * PF2 / PI2 * XKAON0
19378         END IF
19379
19380         XM1 = AMRHO
19381         XM2 = AM1535
19382         PF2 = (S - (XM1 + XM2) ** 2) * (S - (XM1 - XM2) ** 2)
19383         IF (PF2 .GT. 0.0) THEN
19384            XKY8 = 9.0 * PF2 / PI2 * XKAON0
19385         END IF
19386
19387         XM1 = AMOMGA
19388         XM2 = AMP
19389         PF2 = (S - (XM1 + XM2) ** 2) * (S - (XM1 - XM2) ** 2)
19390         IF (PF2 .GT. 0.0) THEN
19391            XKY9 = 3.0 * PF2 / PI2 * XKAON0
19392         END IF
19393
19394         XM1 = AMOMGA
19395         XM2 = AM0
19396         PF2 = (S - (XM1 + XM2) ** 2) * (S - (XM1 - XM2) ** 2)
19397         IF (PF2 .GT. 0.0) THEN
19398            XKY10 = 12.0 * PF2 / PI2 * XKAON0
19399         END IF
19400
19401         XM1 = AMOMGA
19402         XM2 = AM1440
19403         PF2 = (S - (XM1 + XM2) ** 2) * (S - (XM1 - XM2) ** 2)
19404         IF (PF2 .GT. 0.0) THEN
19405            XKY11 = 3.0 * PF2 / PI2 * XKAON0
19406         END IF
19407
19408         XM1 = AMOMGA
19409         XM2 = AM1535
19410         PF2 = (S - (XM1 + XM2) ** 2) * (S - (XM1 - XM2) ** 2)
19411         IF (PF2 .GT. 0.0) THEN
19412            XKY12 = 3.0 * PF2 / PI2 * XKAON0
19413         END IF
19414
19415         XM1 = AMETA
19416         XM2 = AMP
19417         PF2 = (S - (XM1 + XM2) ** 2) * (S - (XM1 - XM2) ** 2)
19418         IF (PF2 .GT. 0.0) THEN
19419            XKY13 = 1.0 * PF2 / PI2 * XKAON0
19420         END IF
19421
19422         XM1 = AMETA
19423         XM2 = AM0
19424         PF2 = (S - (XM1 + XM2) ** 2) * (S - (XM1 - XM2) ** 2)
19425         IF (PF2 .GT. 0.0) THEN
19426            XKY14 = 4.0 * PF2 / PI2 * XKAON0
19427         END IF
19428
19429         XM1 = AMETA
19430         XM2 = AM1440
19431         PF2 = (S - (XM1 + XM2) ** 2) * (S - (XM1 - XM2) ** 2)
19432         IF (PF2 .GT. 0.0) THEN
19433            XKY15 = 1.0 * PF2 / PI2 * XKAON0
19434         END IF
19435
19436         XM1 = AMETA
19437         XM2 = AM1535
19438         PF2 = (S - (XM1 + XM2) ** 2) * (S - (XM1 - XM2) ** 2)
19439         IF (PF2 .GT. 0.0) THEN
19440            XKY16 = 1.0 * PF2 / PI2 * XKAON0
19441         END IF
19442
19443 csp11/21/01  K+ + La --> phi + N
19444         if(lb1.eq.14 .or. lb2.eq.14)then
19445          if(srt .gt. (aphi+amn))then
19446            srrt = srt - (aphi+amn)
19447            sig = 1.715/((srrt+3.508)**2-12.138)
19448          XM1 = AMN
19449          XM2 = APHI
19450          PF2 = (S - (XM1 + XM2) ** 2) * (S - (XM1 - XM2) ** 2)
19451 c     ! fm^-1
19452          XKY17 = 3.0 * PF2 / PI2 * SIG/10.
19453         endif
19454        endif
19455 csp11/21/01  end
19456 c
19457
19458        IF ((iabs(LB1) .GE. 15 .AND. iabs(LB1) .LE. 17) .OR.
19459      &     (iabs(LB2) .GE. 15 .AND. iabs(LB2) .LE. 17)) THEN
19460            DDF = 3.0
19461            XKY1 = XKY1 / DDF
19462            XKY2 = XKY2 / DDF
19463            XKY3 = XKY3 / DDF
19464            XKY4 = XKY4 / DDF
19465            XKY5 = XKY5 / DDF
19466            XKY6 = XKY6 / DDF
19467            XKY7 = XKY7 / DDF
19468            XKY8 = XKY8 / DDF
19469            XKY9 = XKY9 / DDF
19470            XKY10 = XKY10/ DDF
19471            XKY11 = XKY11 / DDF
19472            XKY12 = XKY12 / DDF
19473            XKY13 = XKY13 / DDF
19474            XKY14 = XKY14 / DDF
19475            XKY15 = XKY15 / DDF
19476            XKY16 = XKY16 / DDF
19477         END IF
19478
19479         SIGK = XKY1 + XKY2 + XKY3 + XKY4 +
19480      &       XKY5 + XKY6 + XKY7 + XKY8 +
19481      &       XKY9 + XKY10 + XKY11 + XKY12 +
19482      &       XKY13 + XKY14 + XKY15 + XKY16 + XKY17
19483
19484        RETURN
19485        END
19486
19487 C*******************************
19488       BLOCK DATA PPBDAT
19489
19490       parameter (AMP=0.93828,AMN=0.939457,
19491      1     AM0=1.232,AM1440 = 1.44, AM1535 = 1.535)
19492
19493 c     to give default values to parameters for BbarB production from mesons
19494       COMMON/ppbmas/niso(15),nstate,ppbm(15,2),thresh(15),weight(15)
19495 cc      SAVE /ppbmas/
19496       common/ppb1/ene,factr2(6),fsum,ppinnb,s,wtot
19497 cc      SAVE /ppb1/
19498       common/ppmm/pprr,ppee,pppe,rpre,xopoe,rree
19499 cc      SAVE /ppmm/
19500       SAVE
19501 c     thresh(i) gives the mass thresh for final channel i:
19502       DATA thresh/1.87656,1.877737,1.878914,2.17028,
19503      1     2.171457,2.37828,2.379457,2.464,2.47328,2.474457,
19504      2     2.672,2.767,2.88,2.975,3.07/
19505 c     ppbm(i,j=1,2) gives masses for the two final baryons of channel i,
19506 c     with j=1 for the lighter baryon:
19507       DATA (ppbm(i,1),i=1,15)/amp,amp,amn,amp,amn,amp,amn,
19508      1     am0,amp,amn,am0,am0,am1440,am1440,am1535/
19509       DATA (ppbm(i,2),i=1,15)/amp,amn,amn,am0,am0,am1440,am1440,
19510      1     am0,am1535,am1535,am1440,am1535,am1440,am1535,am1535/
19511 c     factr2(i) gives weights for producing i pions from ppbar annihilation:
19512       DATA factr2/0,1,1.17e-01,3.27e-03,3.58e-05,1.93e-07/
19513 c     niso(i) gives the degeneracy factor for final channel i:
19514       DATA niso/1,2,1,16,16,4,4,64,4,4,32,32,4,8,4/
19515
19516       END
19517
19518
19519 *****************************************
19520 * get the number of BbarB states available for mm collisions of energy srt
19521       subroutine getnst(srt)
19522 *  srt    = DSQRT(s) in GeV                                                   *
19523 *****************************************
19524       parameter (pimass=0.140,pi=3.1415926)
19525       COMMON/ppbmas/niso(15),nstate,ppbm(15,2),thresh(15),weight(15)
19526 cc      SAVE /ppbmas/
19527       common/ppb1/ene,factr2(6),fsum,ppinnb,s,wtot
19528 cc      SAVE /ppb1/
19529       common/ppmm/pprr,ppee,pppe,rpre,xopoe,rree
19530 cc      SAVE /ppmm/
19531       SAVE
19532
19533       s=srt**2
19534       nstate=0
19535       wtot=0.
19536       if(srt.le.thresh(1)) return
19537       do 1001 i=1,15
19538          weight(i)=0.
19539          if(srt.gt.thresh(i)) nstate=i
19540  1001 continue
19541       do 1002 i=1,nstate
19542          pf2=(s-(ppbm(i,1)+ppbm(i,2))**2)
19543      1        *(s-(ppbm(i,1)-ppbm(i,2))**2)/4/s
19544          weight(i)=pf2*niso(i)
19545          wtot=wtot+weight(i)
19546  1002 continue
19547       ene=(srt/pimass)**3/(6.*pi**2)
19548       fsum=factr2(2)+factr2(3)*ene+factr2(4)*ene**2
19549      1     +factr2(5)*ene**3+factr2(6)*ene**4
19550
19551       return
19552       END
19553
19554 *****************************************
19555 * for pion+pion-->Bbar B                                                      *
19556 c      real*4 function ppbbar(srt)
19557       real function ppbbar(srt)
19558 *****************************************
19559       parameter (pimass=0.140,arho=0.77,aomega=0.782)
19560       common/ppb1/ene,factr2(6),fsum,ppinnb,s,wtot
19561 cc      SAVE /ppb1/
19562       common/ppmm/pprr,ppee,pppe,rpre,xopoe,rree
19563 cc      SAVE /ppmm/
19564       SAVE
19565
19566       sppb2p=xppbar(srt)*factr2(2)/fsum
19567       pi2=(s-4*pimass**2)/4
19568       ppbbar=4./9.*sppb2p/pi2*wtot
19569
19570       return
19571       END
19572
19573 *****************************************
19574 * for pion+rho-->Bbar B                                                      *
19575 c      real*4 function prbbar(srt)
19576       real function prbbar(srt)
19577 *****************************************
19578       parameter (pimass=0.140,arho=0.77,aomega=0.782)
19579       common/ppb1/ene,factr2(6),fsum,ppinnb,s,wtot
19580 cc      SAVE /ppb1/
19581       common/ppmm/pprr,ppee,pppe,rpre,xopoe,rree
19582 cc      SAVE /ppmm/
19583       SAVE
19584
19585       sppb3p=xppbar(srt)*factr2(3)*ene/fsum
19586       pi2=(s-(pimass+arho)**2)*(s-(pimass-arho)**2)/4/s
19587       prbbar=4./27.*sppb3p/pi2*wtot
19588
19589       return
19590       END
19591
19592 *****************************************
19593 * for rho+rho-->Bbar B                                                      *
19594 c      real*4 function rrbbar(srt)
19595       real function rrbbar(srt)
19596 *****************************************
19597       parameter (pimass=0.140,arho=0.77,aomega=0.782)
19598       common/ppb1/ene,factr2(6),fsum,ppinnb,s,wtot
19599 cc      SAVE /ppb1/
19600       common/ppmm/pprr,ppee,pppe,rpre,xopoe,rree
19601 cc      SAVE /ppmm/
19602       SAVE
19603
19604       sppb4p=xppbar(srt)*factr2(4)*ene**2/fsum
19605       pi2=(s-4*arho**2)/4
19606       rrbbar=4./81.*(sppb4p/2)/pi2*wtot
19607
19608       return
19609       END
19610
19611 *****************************************
19612 * for pi+omega-->Bbar B                                                      *
19613 c      real*4 function pobbar(srt)
19614       real function pobbar(srt)
19615 *****************************************
19616       parameter (pimass=0.140,arho=0.77,aomega=0.782)
19617       common/ppb1/ene,factr2(6),fsum,ppinnb,s,wtot
19618 cc      SAVE /ppb1/
19619       common/ppmm/pprr,ppee,pppe,rpre,xopoe,rree
19620 cc      SAVE /ppmm/
19621       SAVE
19622
19623       sppb4p=xppbar(srt)*factr2(4)*ene**2/fsum
19624       pi2=(s-(pimass+aomega)**2)*(s-(pimass-aomega)**2)/4/s
19625       pobbar=4./9.*(sppb4p/2)/pi2*wtot
19626
19627       return
19628       END
19629
19630 *****************************************
19631 * for rho+omega-->Bbar B                                                      *
19632 c      real*4 function robbar(srt)
19633       real function robbar(srt)
19634 *****************************************
19635       parameter (pimass=0.140,arho=0.77,aomega=0.782)
19636       common/ppb1/ene,factr2(6),fsum,ppinnb,s,wtot
19637 cc      SAVE /ppb1/
19638       common/ppmm/pprr,ppee,pppe,rpre,xopoe,rree
19639 cc      SAVE /ppmm/
19640       SAVE
19641
19642       sppb5p=xppbar(srt)*factr2(5)*ene**3/fsum
19643       pi2=(s-(arho+aomega)**2)*(s-(arho-aomega)**2)/4/s
19644       robbar=4./27.*sppb5p/pi2*wtot
19645
19646       return
19647       END
19648
19649 *****************************************
19650 * for omega+omega-->Bbar B                                                    *
19651 c      real*4 function oobbar(srt)
19652       real function oobbar(srt)
19653 *****************************************
19654       parameter (pimass=0.140,arho=0.77,aomega=0.782)
19655       common/ppb1/ene,factr2(6),fsum,ppinnb,s,wtot
19656 cc      SAVE /ppb1/
19657       common/ppmm/pprr,ppee,pppe,rpre,xopoe,rree
19658 cc      SAVE /ppmm/
19659       SAVE
19660
19661       sppb6p=xppbar(srt)*factr2(6)*ene**4/fsum
19662       pi2=(s-4*aomega**2)/4
19663       oobbar=4./9.*sppb6p/pi2*wtot
19664
19665       return
19666       END
19667
19668 *****************************************
19669 * Generate final states for mm-->Bbar B                                       *
19670       SUBROUTINE bbarfs(lbb1,lbb2,ei1,ei2,iblock,iseed)
19671 *****************************************
19672       COMMON/ppbmas/niso(15),nstate,ppbm(15,2),thresh(15),weight(15)
19673 cc      SAVE /ppbmas/
19674       common/ppb1/ene,factr2(6),fsum,ppinnb,s,wtot
19675 cc      SAVE /ppb1/
19676       common/ppmm/pprr,ppee,pppe,rpre,xopoe,rree
19677 cc      SAVE /ppmm/
19678       COMMON/RNDF77/NSEED
19679 cc      SAVE /RNDF77/
19680       SAVE
19681       ISEED=ISEED
19682 c     determine which final BbarB channel occurs:
19683       rd=RANART(NSEED)
19684       wsum=0.
19685       do 1001 i=1,nstate
19686          wsum=wsum+weight(i)
19687          if(rd.le.(wsum/wtot)) then
19688             ifs=i
19689             ei1=ppbm(i,1)
19690             ei2=ppbm(i,2)
19691             goto 10
19692          endif
19693  1001 continue
19694  10   continue
19695
19696 c1    pbar p
19697       if(ifs.eq.1) then
19698          iblock=1801
19699          lbb1=-1
19700          lbb2=1
19701       elseif(ifs.eq.2) then
19702 c2    pbar n
19703          if(RANART(NSEED).le.0.5) then
19704             iblock=18021
19705             lbb1=-1
19706             lbb2=2
19707 c2    nbar p
19708          else
19709             iblock=18022
19710             lbb1=1
19711             lbb2=-2
19712          endif
19713 c3    nbar n
19714       elseif(ifs.eq.3) then
19715          iblock=1803
19716          lbb1=-2
19717          lbb2=2
19718 c4&5  (pbar nbar) Delta, (p n) anti-Delta
19719       elseif(ifs.eq.4.or.ifs.eq.5) then
19720          rd=RANART(NSEED)
19721          if(rd.le.0.5) then
19722 c     (pbar nbar) Delta
19723             if(ifs.eq.4) then
19724                iblock=18041
19725                lbb1=-1
19726             else
19727                iblock=18051
19728                lbb1=-2
19729             endif
19730             rd2=RANART(NSEED)
19731             if(rd2.le.0.25) then
19732                lbb2=6
19733             elseif(rd2.le.0.5) then
19734                lbb2=7
19735             elseif(rd2.le.0.75) then
19736                lbb2=8
19737             else
19738                lbb2=9
19739             endif
19740          else
19741 c     (p n) anti-Delta
19742             if(ifs.eq.4) then
19743                iblock=18042
19744                lbb1=1
19745             else
19746                iblock=18052
19747                lbb1=2
19748             endif
19749             rd2=RANART(NSEED)
19750             if(rd2.le.0.25) then
19751                lbb2=-6
19752             elseif(rd2.le.0.5) then
19753                lbb2=-7
19754             elseif(rd2.le.0.75) then
19755                lbb2=-8
19756             else
19757                lbb2=-9
19758             endif
19759          endif
19760 c6&7  (pbar nbar) N*(1440), (p n) anti-N*(1440)
19761       elseif(ifs.eq.6.or.ifs.eq.7) then
19762          rd=RANART(NSEED)
19763          if(rd.le.0.5) then
19764 c     (pbar nbar) N*(1440)
19765             if(ifs.eq.6) then
19766                iblock=18061
19767                lbb1=-1
19768             else
19769                iblock=18071
19770                lbb1=-2
19771             endif
19772             rd2=RANART(NSEED)
19773             if(rd2.le.0.5) then
19774                lbb2=10
19775             else
19776                lbb2=11
19777             endif
19778          else
19779 c     (p n) anti-N*(1440)
19780             if(ifs.eq.6) then
19781                iblock=18062
19782                lbb1=1
19783             else
19784                iblock=18072
19785                lbb1=2
19786             endif
19787             rd2=RANART(NSEED)
19788             if(rd2.le.0.5) then
19789                lbb2=-10
19790             else
19791                lbb2=-11
19792             endif
19793          endif
19794 c8    Delta anti-Delta
19795       elseif(ifs.eq.8) then
19796          iblock=1808
19797          rd1=RANART(NSEED)
19798          if(rd1.le.0.25) then
19799             lbb1=6
19800          elseif(rd1.le.0.5) then
19801             lbb1=7
19802          elseif(rd1.le.0.75) then
19803             lbb1=8
19804          else
19805             lbb1=9
19806          endif
19807          rd2=RANART(NSEED)
19808          if(rd2.le.0.25) then
19809             lbb2=-6
19810          elseif(rd2.le.0.5) then
19811             lbb2=-7
19812          elseif(rd2.le.0.75) then
19813             lbb2=-8
19814          else
19815             lbb2=-9
19816          endif
19817 c9&10 (pbar nbar) N*(1535), (p n) anti-N*(1535)
19818       elseif(ifs.eq.9.or.ifs.eq.10) then
19819          rd=RANART(NSEED)
19820          if(rd.le.0.5) then
19821 c     (pbar nbar) N*(1440)
19822             if(ifs.eq.9) then
19823                iblock=18091
19824                lbb1=-1
19825             else
19826                iblock=18101
19827                lbb1=-2
19828             endif
19829             rd2=RANART(NSEED)
19830             if(rd2.le.0.5) then
19831                lbb2=12
19832             else
19833                lbb2=13
19834             endif
19835          else
19836 c     (p n) anti-N*(1535)
19837             if(ifs.eq.9) then
19838                iblock=18092
19839                lbb1=1
19840             else
19841                iblock=18102
19842                lbb1=2
19843             endif
19844             rd2=RANART(NSEED)
19845             if(rd2.le.0.5) then
19846                lbb2=-12
19847             else
19848                lbb2=-13
19849             endif
19850          endif
19851 c11&12 anti-Delta N*, Delta anti-N*
19852       elseif(ifs.eq.11.or.ifs.eq.12) then
19853          rd=RANART(NSEED)
19854          if(rd.le.0.5) then
19855 c     anti-Delta N*
19856             rd1=RANART(NSEED)
19857             if(rd1.le.0.25) then
19858                lbb1=-6
19859             elseif(rd1.le.0.5) then
19860                lbb1=-7
19861             elseif(rd1.le.0.75) then
19862                lbb1=-8
19863             else
19864                lbb1=-9
19865             endif
19866             if(ifs.eq.11) then
19867                iblock=18111
19868                rd2=RANART(NSEED)
19869                if(rd2.le.0.5) then
19870                   lbb2=10
19871                else
19872                   lbb2=11
19873                endif
19874             else
19875                iblock=18121
19876                rd2=RANART(NSEED)
19877                if(rd2.le.0.5) then
19878                   lbb2=12
19879                else
19880                   lbb2=13
19881                endif
19882             endif
19883          else
19884 c     Delta anti-N*
19885             rd1=RANART(NSEED)
19886             if(rd1.le.0.25) then
19887                lbb1=6
19888             elseif(rd1.le.0.5) then
19889                lbb1=7
19890             elseif(rd1.le.0.75) then
19891                lbb1=8
19892             else
19893                lbb1=9
19894             endif
19895             if(ifs.eq.11) then
19896                iblock=18112
19897                rd2=RANART(NSEED)
19898                if(rd2.le.0.5) then
19899                   lbb2=-10
19900                else
19901                   lbb2=-11
19902                endif
19903             else
19904                iblock=18122
19905                rd2=RANART(NSEED)
19906                if(rd2.le.0.5) then
19907                   lbb2=-12
19908                else
19909                   lbb2=-13
19910                endif
19911             endif
19912          endif
19913 c13   N*(1440) anti-N*(1440)
19914       elseif(ifs.eq.13) then
19915          iblock=1813
19916          rd1=RANART(NSEED)
19917          if(rd1.le.0.5) then
19918             lbb1=10
19919          else
19920             lbb1=11
19921          endif
19922          rd2=RANART(NSEED)
19923          if(rd2.le.0.5) then
19924             lbb2=-10
19925          else
19926             lbb2=-11
19927          endif
19928 c14   anti-N*(1440) N*(1535), N*(1440) anti-N*(1535)
19929       elseif(ifs.eq.14) then
19930          rd=RANART(NSEED)
19931          if(rd.le.0.5) then
19932 c     anti-N*(1440) N*(1535)
19933             iblock=18141
19934             rd1=RANART(NSEED)
19935             if(rd1.le.0.5) then
19936                lbb1=-10
19937             else
19938                lbb1=-11
19939             endif
19940             rd2=RANART(NSEED)
19941             if(rd2.le.0.5) then
19942                lbb2=12
19943             else
19944                lbb2=13
19945             endif
19946          else
19947 c     N*(1440) anti-N*(1535)
19948             iblock=18142
19949             rd1=RANART(NSEED)
19950             if(rd1.le.0.5) then
19951                lbb1=10
19952             else
19953                lbb1=11
19954             endif
19955             rd2=RANART(NSEED)
19956             if(rd2.le.0.5) then
19957                lbb2=-12
19958             else
19959                lbb2=-13
19960             endif
19961          endif
19962 c15   N*(1535) anti-N*(1535)
19963       elseif(ifs.eq.15) then
19964          iblock=1815
19965          rd1=RANART(NSEED)
19966          if(rd1.le.0.5) then
19967             lbb1=12
19968          else
19969             lbb1=13
19970          endif
19971          rd2=RANART(NSEED)
19972          if(rd2.le.0.5) then
19973             lbb2=-12
19974          else
19975             lbb2=-13
19976          endif
19977       else
19978       endif
19979
19980       RETURN
19981       END
19982
19983 *****************************************
19984 * for pi pi <-> rho rho cross sections
19985         SUBROUTINE spprr(lb1,lb2,srt)
19986         parameter (arho=0.77)
19987       common/ppb1/ene,factr2(6),fsum,ppinnb,s,wtot
19988 cc      SAVE /ppb1/
19989       common/ppmm/pprr,ppee,pppe,rpre,xopoe,rree
19990 cc      SAVE /ppmm/
19991       SAVE
19992
19993         pprr=0.
19994         if((lb1.ge.3.and.lb1.le.5).and.(lb2.ge.3.and.lb2.le.5)) then
19995 c     for now, rho mass taken to be the central value in these two processes
19996            if(srt.gt.(2*arho)) pprr=ptor(srt)
19997         elseif((lb1.ge.25.and.lb1.le.27).and.(lb2.ge.25.and.lb2.le.27))
19998      1          then
19999            pprr=rtop(srt)
20000         endif
20001 c
20002         return
20003         END
20004
20005 *****************************************
20006 * for pi pi -> rho rho, determined from detailed balance
20007       real function ptor(srt)
20008 *****************************************
20009       parameter (pimass=0.140,arho=0.77)
20010       common/ppb1/ene,factr2(6),fsum,ppinnb,s,wtot
20011 cc      SAVE /ppb1/
20012       common/ppmm/pprr,ppee,pppe,rpre,xopoe,rree
20013 cc      SAVE /ppmm/
20014       SAVE
20015
20016       s2=srt**2
20017       ptor=9*(s2-4*arho**2)/(s2-4*pimass**2)*rtop(srt)
20018
20019       return
20020       END
20021
20022 *****************************************
20023 * for rho rho -> pi pi, assumed a constant cross section (in mb)
20024       real function rtop(srt)
20025 *****************************************
20026       srt=srt
20027       rtop=5.
20028       return
20029       END
20030
20031 *****************************************
20032 * for pi pi <-> rho rho final states
20033       SUBROUTINE pi2ro2(i1,i2,lbb1,lbb2,ei1,ei2,iblock,iseed)
20034       PARAMETER (MAXSTR=150001)
20035       PARAMETER (AP1=0.13496,AP2=0.13957)
20036       COMMON /EE/ ID(MAXSTR),LB(MAXSTR)
20037 cc      SAVE /EE/
20038       common/ppb1/ene,factr2(6),fsum,ppinnb,s,wtot
20039 cc      SAVE /ppb1/
20040       common/ppmm/pprr,ppee,pppe,rpre,xopoe,rree
20041 cc      SAVE /ppmm/
20042       COMMON/RNDF77/NSEED
20043 cc      SAVE /RNDF77/
20044       SAVE
20045       iseed=iseed
20046       if((lb(i1).ge.3.and.lb(i1).le.5)
20047      1     .and.(lb(i2).ge.3.and.lb(i2).le.5)) then
20048          iblock=1850
20049          ei1=0.77
20050          ei2=0.77
20051 c     for now, we don't check isospin states(allowing pi+pi+ & pi0pi0 -> 2rho)
20052 c     thus the cross sections used are considered as the isospin-averaged ones.
20053          lbb1=25+int(3*RANART(NSEED))
20054          lbb2=25+int(3*RANART(NSEED))
20055       elseif((lb(i1).ge.25.and.lb(i1).le.27)
20056      1     .and.(lb(i2).ge.25.and.lb(i2).le.27)) then
20057          iblock=1851
20058          lbb1=3+int(3*RANART(NSEED))
20059          lbb2=3+int(3*RANART(NSEED))
20060          ei1=ap2
20061          ei2=ap2
20062          if(lbb1.eq.4) ei1=ap1
20063          if(lbb2.eq.4) ei2=ap1
20064       endif
20065
20066       return
20067       END
20068
20069 *****************************************
20070 * for pi pi <-> eta eta cross sections
20071         SUBROUTINE sppee(lb1,lb2,srt)
20072         parameter (ETAM=0.5475)
20073       common/ppb1/ene,factr2(6),fsum,ppinnb,s,wtot
20074 cc      SAVE /ppb1/
20075       common/ppmm/pprr,ppee,pppe,rpre,xopoe,rree
20076 cc      SAVE /ppmm/
20077       SAVE
20078
20079         ppee=0.
20080         if((lb1.ge.3.and.lb1.le.5).and.(lb2.ge.3.and.lb2.le.5)) then
20081            if(srt.gt.(2*ETAM)) ppee=ptoe(srt)
20082         elseif(lb1.eq.0.and.lb2.eq.0) then
20083            ppee=etop(srt)
20084         endif
20085
20086         return
20087         END
20088
20089 *****************************************
20090 * for pi pi -> eta eta, determined from detailed balance, spin-isospin averaged
20091       real function ptoe(srt)
20092 *****************************************
20093       parameter (pimass=0.140,ETAM=0.5475)
20094       common/ppb1/ene,factr2(6),fsum,ppinnb,s,wtot
20095 cc      SAVE /ppb1/
20096       common/ppmm/pprr,ppee,pppe,rpre,xopoe,rree
20097 cc      SAVE /ppmm/
20098       SAVE
20099
20100       s2=srt**2
20101       ptoe=1./9.*(s2-4*etam**2)/(s2-4*pimass**2)*etop(srt)
20102
20103       return
20104       END
20105 *****************************************
20106 * for eta eta -> pi pi, assumed a constant cross section (in mb)
20107       real function etop(srt)
20108 *****************************************
20109       srt=srt
20110 c     eta equilibration:
20111 c     most important channel is found to be pi pi <-> pi eta, then
20112 c     rho pi <-> rho eta.
20113       etop=5.
20114       return
20115       END
20116
20117 *****************************************
20118 * for pi pi <-> eta eta final states
20119       SUBROUTINE pi2et2(i1,i2,lbb1,lbb2,ei1,ei2,iblock,iseed)
20120       PARAMETER (MAXSTR=150001)
20121       PARAMETER (AP1=0.13496,AP2=0.13957,ETAM=0.5475)
20122       COMMON /EE/ ID(MAXSTR),LB(MAXSTR)
20123 cc      SAVE /EE/
20124       common/ppb1/ene,factr2(6),fsum,ppinnb,s,wtot
20125 cc      SAVE /ppb1/
20126       common/ppmm/pprr,ppee,pppe,rpre,xopoe,rree
20127 cc      SAVE /ppmm/
20128       COMMON/RNDF77/NSEED
20129 cc      SAVE /RNDF77/
20130       SAVE
20131
20132       iseed=iseed
20133       if((lb(i1).ge.3.and.lb(i1).le.5)
20134      1     .and.(lb(i2).ge.3.and.lb(i2).le.5)) then
20135          iblock=1860
20136          ei1=etam
20137          ei2=etam
20138 c     for now, we don't check isospin states(allowing pi+pi+ & pi0pi0 -> 2rho)
20139 c     thus the cross sections used are considered as the isospin-averaged ones.
20140          lbb1=0
20141          lbb2=0
20142       elseif(lb(i1).eq.0.and.lb(i2).eq.0) then
20143          iblock=1861
20144          lbb1=3+int(3*RANART(NSEED))
20145          lbb2=3+int(3*RANART(NSEED))
20146          ei1=ap2
20147          ei2=ap2
20148          if(lbb1.eq.4) ei1=ap1
20149          if(lbb2.eq.4) ei2=ap1
20150       endif
20151
20152       return
20153       END
20154
20155 *****************************************
20156 * for pi pi <-> pi eta cross sections
20157         SUBROUTINE spppe(lb1,lb2,srt)
20158         parameter (pimass=0.140,ETAM=0.5475)
20159       common/ppb1/ene,factr2(6),fsum,ppinnb,s,wtot
20160 cc      SAVE /ppb1/
20161       common/ppmm/pprr,ppee,pppe,rpre,xopoe,rree
20162 cc      SAVE /ppmm/
20163       SAVE
20164
20165         pppe=0.
20166         if((lb1.ge.3.and.lb1.le.5).and.(lb2.ge.3.and.lb2.le.5)) then
20167            if(srt.gt.(ETAM+pimass)) pppe=pptope(srt)
20168         elseif((lb1.ge.3.and.lb1.le.5).and.lb2.eq.0) then
20169            pppe=petopp(srt)
20170         elseif((lb2.ge.3.and.lb2.le.5).and.lb1.eq.0) then
20171            pppe=petopp(srt)
20172         endif
20173
20174         return
20175         END
20176
20177 *****************************************
20178 * for pi pi -> pi eta, determined from detailed balance, spin-isospin averaged
20179       real function pptope(srt)
20180 *****************************************
20181       parameter (pimass=0.140,ETAM=0.5475)
20182       common/ppb1/ene,factr2(6),fsum,ppinnb,s,wtot
20183 cc      SAVE /ppb1/
20184       common/ppmm/pprr,ppee,pppe,rpre,xopoe,rree
20185 cc      SAVE /ppmm/
20186       SAVE
20187
20188       s2=srt**2
20189       pf2=(s2-(pimass+ETAM)**2)*(s2-(pimass-ETAM)**2)/2/sqrt(s2)
20190       pi2=(s2-4*pimass**2)*s2/2/sqrt(s2)
20191       pptope=1./3.*pf2/pi2*petopp(srt)
20192
20193       return
20194       END
20195 *****************************************
20196 * for pi eta -> pi pi, assumed a constant cross section (in mb)
20197       real function petopp(srt)
20198 *****************************************
20199       srt=srt
20200 c     eta equilibration:
20201       petopp=5.
20202       return
20203       END
20204
20205 *****************************************
20206 * for pi pi <-> pi eta final states
20207       SUBROUTINE pi3eta(i1,i2,lbb1,lbb2,ei1,ei2,iblock,iseed)
20208       PARAMETER (MAXSTR=150001)
20209       PARAMETER (AP1=0.13496,AP2=0.13957,ETAM=0.5475)
20210       COMMON /EE/ ID(MAXSTR),LB(MAXSTR)
20211 cc      SAVE /EE/
20212       common/ppb1/ene,factr2(6),fsum,ppinnb,s,wtot
20213 cc      SAVE /ppb1/
20214       common/ppmm/pprr,ppee,pppe,rpre,xopoe,rree
20215 cc      SAVE /ppmm/
20216       COMMON/RNDF77/NSEED
20217 cc      SAVE /RNDF77/
20218       SAVE
20219
20220       ISEED=ISEED
20221       if((lb(i1).ge.3.and.lb(i1).le.5)
20222      1     .and.(lb(i2).ge.3.and.lb(i2).le.5)) then
20223          iblock=1870
20224          ei1=ap2
20225          ei2=etam
20226 c     for now, we don't check isospin states(allowing pi+pi+ & pi0pi0 -> 2rho)
20227 c     thus the cross sections used are considered as the isospin-averaged ones.
20228          lbb1=3+int(3*RANART(NSEED))
20229          if(lbb1.eq.4) ei1=ap1
20230          lbb2=0
20231       elseif((lb(i1).ge.3.and.lb(i1).le.5.and.lb(i2).eq.0).or.
20232      1        (lb(i2).ge.3.and.lb(i2).le.5.and.lb(i1).eq.0)) then
20233          iblock=1871
20234          lbb1=3+int(3*RANART(NSEED))
20235          lbb2=3+int(3*RANART(NSEED))
20236          ei1=ap2
20237          ei2=ap2
20238          if(lbb1.eq.4) ei1=ap1
20239          if(lbb2.eq.4) ei2=ap1
20240       endif
20241
20242       return
20243       END
20244
20245 *****************************************
20246 * for rho pi <-> rho eta cross sections
20247         SUBROUTINE srpre(lb1,lb2,srt)
20248         parameter (pimass=0.140,ETAM=0.5475,arho=0.77)
20249         common/ppb1/ene,factr2(6),fsum,ppinnb,s,wtot
20250 cc      SAVE /ppb1/
20251         common/ppmm/pprr,ppee,pppe,rpre,xopoe,rree
20252 cc      SAVE /ppmm/
20253       SAVE
20254
20255         rpre=0.
20256         if(lb1.ge.25.and.lb1.le.27.and.lb2.ge.3.and.lb2.le.5) then
20257            if(srt.gt.(ETAM+arho)) rpre=rptore(srt)
20258         elseif(lb2.ge.25.and.lb2.le.27.and.lb1.ge.3.and.lb1.le.5) then
20259            if(srt.gt.(ETAM+arho)) rpre=rptore(srt)
20260         elseif(lb1.ge.25.and.lb1.le.27.and.lb2.eq.0) then
20261            if(srt.gt.(pimass+arho)) rpre=retorp(srt)
20262         elseif(lb2.ge.25.and.lb2.le.27.and.lb1.eq.0) then
20263            if(srt.gt.(pimass+arho)) rpre=retorp(srt)
20264         endif
20265
20266         return
20267         END
20268
20269 *****************************************
20270 * for rho pi->rho eta, determined from detailed balance, spin-isospin averaged
20271       real function rptore(srt)
20272 *****************************************
20273       parameter (pimass=0.140,ETAM=0.5475,arho=0.77)
20274       common/ppb1/ene,factr2(6),fsum,ppinnb,s,wtot
20275 cc      SAVE /ppb1/
20276       common/ppmm/pprr,ppee,pppe,rpre,xopoe,rree
20277 cc      SAVE /ppmm/
20278       SAVE
20279
20280       s2=srt**2
20281       pf2=(s2-(arho+ETAM)**2)*(s2-(arho-ETAM)**2)/2/sqrt(s2)
20282       pi2=(s2-(arho+pimass)**2)*(s2-(arho-pimass)**2)/2/sqrt(s2)
20283       rptore=1./3.*pf2/pi2*retorp(srt)
20284
20285       return
20286       END
20287 *****************************************
20288 * for rho eta -> rho pi, assumed a constant cross section (in mb)
20289       real function retorp(srt)
20290 *****************************************
20291       srt=srt
20292 c     eta equilibration:
20293       retorp=5.
20294       return
20295       END
20296
20297 *****************************************
20298 * for rho pi <-> rho eta final states
20299       SUBROUTINE rpiret(i1,i2,lbb1,lbb2,ei1,ei2,iblock,iseed)
20300       PARAMETER (MAXSTR=150001)
20301       PARAMETER (AP1=0.13496,AP2=0.13957,ETAM=0.5475,arho=0.77)
20302       COMMON /EE/ ID(MAXSTR),LB(MAXSTR)
20303 cc      SAVE /EE/
20304       common/ppb1/ene,factr2(6),fsum,ppinnb,s,wtot
20305 cc      SAVE /ppb1/
20306       common/ppmm/pprr,ppee,pppe,rpre,xopoe,rree
20307 cc      SAVE /ppmm/
20308       COMMON/RNDF77/NSEED
20309 cc      SAVE /RNDF77/
20310       SAVE
20311       ISEED=ISEED
20312       if((lb(i1).ge.25.and.lb(i1).le.27
20313      1     .and.lb(i2).ge.3.and.lb(i2).le.5).or.
20314      2     (lb(i1).ge.3.and.lb(i1).le.5
20315      3     .and.lb(i2).ge.25.and.lb(i2).le.27)) then
20316          iblock=1880
20317          ei1=arho
20318          ei2=etam
20319 c     for now, we don't check isospin states(allowing pi+pi+ & pi0pi0 -> 2rho)
20320 c     thus the cross sections used are considered as the isospin-averaged ones.
20321          lbb1=25+int(3*RANART(NSEED))
20322          lbb2=0
20323       elseif((lb(i1).ge.25.and.lb(i1).le.27.and.lb(i2).eq.0).or.
20324      1        (lb(i2).ge.25.and.lb(i2).le.27.and.lb(i1).eq.0)) then
20325          iblock=1881
20326          lbb1=25+int(3*RANART(NSEED))
20327          lbb2=3+int(3*RANART(NSEED))
20328          ei1=arho
20329          ei2=ap2
20330          if(lbb2.eq.4) ei2=ap1
20331       endif
20332
20333       return
20334       END
20335
20336 *****************************************
20337 * for omega pi <-> omega eta cross sections
20338         SUBROUTINE sopoe(lb1,lb2,srt)
20339         parameter (ETAM=0.5475,aomega=0.782)
20340       common/ppb1/ene,factr2(6),fsum,ppinnb,s,wtot
20341 cc      SAVE /ppb1/
20342       common/ppmm/pprr,ppee,pppe,rpre,xopoe,rree
20343 cc      SAVE /ppmm/
20344       SAVE
20345
20346         xopoe=0.
20347         if((lb1.eq.28.and.lb2.ge.3.and.lb2.le.5).or.
20348      1       (lb2.eq.28.and.lb1.ge.3.and.lb1.le.5)) then
20349            if(srt.gt.(aomega+ETAM)) xopoe=xop2oe(srt)
20350         elseif((lb1.eq.28.and.lb2.eq.0).or.
20351      1          (lb1.eq.0.and.lb2.eq.28)) then
20352            if(srt.gt.(aomega+ETAM)) xopoe=xoe2op(srt)
20353         endif
20354
20355         return
20356         END
20357
20358 *****************************************
20359 * for omega pi -> omega eta,
20360 c     determined from detailed balance, spin-isospin averaged
20361       real function xop2oe(srt)
20362 *****************************************
20363       parameter (pimass=0.140,ETAM=0.5475,aomega=0.782)
20364       common/ppb1/ene,factr2(6),fsum,ppinnb,s,wtot
20365 cc      SAVE /ppb1/
20366       common/ppmm/pprr,ppee,pppe,rpre,xopoe,rree
20367 cc      SAVE /ppmm/
20368       SAVE
20369
20370       s2=srt**2
20371       pf2=(s2-(aomega+ETAM)**2)*(s2-(aomega-ETAM)**2)/2/sqrt(s2)
20372       pi2=(s2-(aomega+pimass)**2)*(s2-(aomega-pimass)**2)/2/sqrt(s2)
20373       xop2oe=1./3.*pf2/pi2*xoe2op(srt)
20374
20375       return
20376       END
20377 *****************************************
20378 * for omega eta -> omega pi, assumed a constant cross section (in mb)
20379       real function xoe2op(srt)
20380 *****************************************
20381       srt=srt
20382 c     eta equilibration:
20383       xoe2op=5.
20384       return
20385       END
20386
20387 *****************************************
20388 * for omega pi <-> omega eta final states
20389       SUBROUTINE opioet(i1,i2,lbb1,lbb2,ei1,ei2,iblock,iseed)
20390       PARAMETER (MAXSTR=150001)
20391       PARAMETER (AP1=0.13496,AP2=0.13957,ETAM=0.5475,aomega=0.782)
20392       COMMON /EE/ ID(MAXSTR),LB(MAXSTR)
20393 cc      SAVE /EE/
20394       common/ppb1/ene,factr2(6),fsum,ppinnb,s,wtot
20395 cc      SAVE /ppb1/
20396       common/ppmm/pprr,ppee,pppe,rpre,xopoe,rree
20397 cc      SAVE /ppmm/
20398       COMMON/RNDF77/NSEED
20399 cc      SAVE /RNDF77/
20400       SAVE
20401
20402       iseed=iseed
20403       if((lb(i1).ge.3.and.lb(i1).le.5.and.lb(i2).eq.28).or.
20404      1     (lb(i2).ge.3.and.lb(i2).le.5.and.lb(i1).eq.28)) then
20405          iblock=1890
20406          ei1=aomega
20407          ei2=etam
20408 c     for now, we don't check isospin states(allowing pi+pi+ & pi0pi0 -> 2rho)
20409 c     thus the cross sections used are considered as the isospin-averaged ones.
20410          lbb1=28
20411          lbb2=0
20412       elseif((lb(i1).eq.28.and.lb(i2).eq.0).or.
20413      1        (lb(i1).eq.0.and.lb(i2).eq.28)) then
20414          iblock=1891
20415          lbb1=28
20416          lbb2=3+int(3*RANART(NSEED))
20417          ei1=aomega
20418          ei2=ap2
20419          if(lbb2.eq.4) ei2=ap1
20420       endif
20421
20422       return
20423       END
20424
20425 *****************************************
20426 * for rho rho <-> eta eta cross sections
20427         SUBROUTINE srree(lb1,lb2,srt)
20428         parameter (ETAM=0.5475,arho=0.77)
20429       common/ppb1/ene,factr2(6),fsum,ppinnb,s,wtot
20430 cc      SAVE /ppb1/
20431       common/ppmm/pprr,ppee,pppe,rpre,xopoe,rree
20432 cc      SAVE /ppmm/
20433       SAVE
20434
20435         rree=0.
20436         if(lb1.ge.25.and.lb1.le.27.and.
20437      1       lb2.ge.25.and.lb2.le.27) then
20438            if(srt.gt.(2*ETAM)) rree=rrtoee(srt)
20439         elseif(lb1.eq.0.and.lb2.eq.0) then
20440            if(srt.gt.(2*arho)) rree=eetorr(srt)
20441         endif
20442
20443         return
20444         END
20445
20446 *****************************************
20447 * for eta eta -> rho rho
20448 c     determined from detailed balance, spin-isospin averaged
20449       real function eetorr(srt)
20450 *****************************************
20451       parameter (ETAM=0.5475,arho=0.77)
20452       common/ppb1/ene,factr2(6),fsum,ppinnb,s,wtot
20453 cc      SAVE /ppb1/
20454       common/ppmm/pprr,ppee,pppe,rpre,xopoe,rree
20455 cc      SAVE /ppmm/
20456       SAVE
20457
20458       s2=srt**2
20459       eetorr=81.*(s2-4*arho**2)/(s2-4*etam**2)*rrtoee(srt)
20460
20461       return
20462       END
20463 *****************************************
20464 * for rho rho -> eta eta, assumed a constant cross section (in mb)
20465       real function rrtoee(srt)
20466 *****************************************
20467       srt=srt
20468 c     eta equilibration:
20469       rrtoee=5.
20470       return
20471       END
20472
20473 *****************************************
20474 * for rho rho <-> eta eta final states
20475       SUBROUTINE ro2et2(i1,i2,lbb1,lbb2,ei1,ei2,iblock,iseed)
20476       PARAMETER (MAXSTR=150001)
20477       parameter (ETAM=0.5475,arho=0.77)
20478       COMMON /EE/ ID(MAXSTR),LB(MAXSTR)
20479 cc      SAVE /EE/
20480       common/ppb1/ene,factr2(6),fsum,ppinnb,s,wtot
20481 cc      SAVE /ppb1/
20482       common/ppmm/pprr,ppee,pppe,rpre,xopoe,rree
20483 cc      SAVE /ppmm/
20484       COMMON/RNDF77/NSEED
20485 cc      SAVE /RNDF77/
20486       SAVE
20487
20488       ISEED=ISEED
20489       if(lb(i1).ge.25.and.lb(i1).le.27.and.
20490      1     lb(i2).ge.25.and.lb(i2).le.27) then
20491          iblock=1895
20492          ei1=etam
20493          ei2=etam
20494 c     for now, we don't check isospin states(allowing pi+pi+ & pi0pi0 -> 2rho)
20495 c     thus the cross sections used are considered as the isospin-averaged ones.
20496          lbb1=0
20497          lbb2=0
20498       elseif(lb(i1).eq.0.and.lb(i2).eq.0) then
20499          iblock=1896
20500          lbb1=25+int(3*RANART(NSEED))
20501          lbb2=25+int(3*RANART(NSEED))
20502          ei1=arho
20503          ei2=arho
20504       endif
20505
20506       return
20507       END
20508
20509 *****************************
20510 * purpose: Xsection for K* Kbar or K*bar K to pi(eta) rho(omega)
20511       SUBROUTINE XKKSAN(i1,i2,SRT,SIGKS1,SIGKS2,SIGKS3,SIGKS4,SIGK,prkk)
20512 *  srt    = DSQRT(s) in GeV                                       *
20513 *  sigk   = xsection in mb obtained from                          *
20514 *           the detailed balance                                  *
20515 * ***************************
20516           PARAMETER (AKA=0.498, PIMASS=0.140, RHOM = 0.770,aks=0.895,
20517      & OMEGAM = 0.7819, ETAM = 0.5473)
20518       PARAMETER (MAXSTR=150001)
20519       COMMON  /CC/      E(MAXSTR)
20520 cc      SAVE /CC/
20521       SAVE
20522
20523         S = SRT ** 2
20524        SIGKS1 = 1.E-08
20525        SIGKS2 = 1.E-08
20526        SIGKS3 = 1.E-08
20527        SIGKS4 = 1.E-08
20528
20529         XPION0 = prkk
20530 clin note that prkk is for pi (rho omega) -> K* Kbar (AND!) K*bar K:
20531         XPION0 = XPION0/2
20532
20533 cc
20534 c        PI2 = (S - (aks + AKA) ** 2) * (S - (aks - AKA) ** 2)
20535         PI2 = (S - (e(i1) + e(i2)) ** 2) * (S - (e(i1) - e(i2)) ** 2)
20536         SIGK = 1.E-08
20537         if(PI2 .le. 0.0) return
20538
20539         XM1 = PIMASS
20540         XM2 = RHOM
20541         PF2 = (S - (XM1 + XM2) ** 2) * (S - (XM1 - XM2) ** 2)
20542         IF (PI2 .GT. 0.0 .AND. PF2 .GT. 0.0) THEN
20543            SIGKS1 = 27.0 / 4.0 * PF2 / PI2 * XPION0
20544         END IF
20545
20546         XM1 = PIMASS
20547         XM2 = OMEGAM
20548         PF2 = (S - (XM1 + XM2) ** 2) * (S - (XM1 - XM2) ** 2)
20549         IF (PI2 .GT. 0.0 .AND. PF2 .GT. 0.0) THEN
20550            SIGKS2 = 9.0 / 4.0 * PF2 / PI2 * XPION0
20551         END IF
20552
20553         XM1 = RHOM
20554         XM2 = ETAM
20555         PF2 = (S - (XM1 + XM2) ** 2) * (S - (XM1 - XM2) ** 2)
20556         IF (PF2 .GT. 0.0) THEN
20557            SIGKS3 = 9.0 / 4.0 * PF2 / PI2 * XPION0
20558         END IF
20559
20560         XM1 = OMEGAM
20561         XM2 = ETAM
20562         PF2 = (S - (XM1 + XM2) ** 2) * (S - (XM1 - XM2) ** 2)
20563         IF (PF2 .GT. 0.0) THEN
20564            SIGKS4 = 3.0 / 4.0 * PF2 / PI2 * XPION0
20565         END IF
20566
20567         SIGK=SIGKS1+SIGKS2+SIGKS3+SIGKS4
20568
20569        RETURN
20570         END
20571
20572 **********************************
20573 *     PURPOSE:                                                         *
20574 *     assign final states for KK*bar or K*Kbar --> light mesons
20575 *
20576 c      SUBROUTINE Crkspi(PX,PY,PZ,SRT,I1,I2,IBLOCK)
20577       SUBROUTINE crkspi(I1,I2,XSK1, XSK2, XSK3, XSK4, SIGK,
20578      & IBLOCK,lbp1,lbp2,emm1,emm2)
20579 *             iblock   - 466
20580 **********************************
20581         PARAMETER (MAXSTR=150001,MAXR=1)
20582           PARAMETER (AP1=0.13496,AP2=0.13957,RHOM = 0.770,PI=3.1415926)
20583         PARAMETER (AETA=0.548,AMOMGA=0.782)
20584         parameter (MX=4,MY=4,MZ=8,MPX=4,MPY=4,mpz=10,mpzp=10)
20585         COMMON /AA/ R(3,MAXSTR)
20586 cc      SAVE /AA/
20587         COMMON /BB/ P(3,MAXSTR)
20588 cc      SAVE /BB/
20589         COMMON /CC/ E(MAXSTR)
20590 cc      SAVE /CC/
20591         COMMON /EE/ ID(MAXSTR),LB(MAXSTR)
20592 cc      SAVE /EE/
20593         common/input1/ MASSPR,MASSTA,ISEED,IAVOID,DT
20594 cc      SAVE /input1/
20595       COMMON/RNDF77/NSEED
20596 cc      SAVE /RNDF77/
20597       SAVE
20598
20599        IBLOCK=466
20600 * charges of final state mesons:
20601
20602         X1 = RANART(NSEED) * SIGK
20603         XSK2 = XSK1 + XSK2
20604         XSK3 = XSK2 + XSK3
20605         XSK4 = XSK3 + XSK4
20606         IF (X1 .LE. XSK1) THEN
20607            LB(I1) = 3 + int(3 * RANART(NSEED))
20608            LB(I2) = 25 + int(3 * RANART(NSEED))
20609            E(I1) = AP2
20610            E(I2) = rhom
20611         ELSE IF (X1 .LE. XSK2) THEN
20612            LB(I1) = 3 + int(3 * RANART(NSEED))
20613            LB(I2) = 28
20614            E(I1) = AP2
20615            E(I2) = AMOMGA
20616         ELSE IF (X1 .LE. XSK3) THEN
20617            LB(I1) = 0
20618            LB(I2) = 25 + int(3 * RANART(NSEED))
20619            E(I1) = AETA
20620            E(I2) = rhom
20621         ELSE
20622            LB(I1) = 0
20623            LB(I2) = 28
20624            E(I1) = AETA
20625            E(I2) = AMOMGA
20626         ENDIF
20627
20628         if(lb(i1).eq.4) E(I1) = AP1
20629         lbp1=lb(i1)
20630         lbp2=lb(i2)
20631         emm1=e(i1)
20632         emm2=e(i2)
20633
20634       RETURN
20635       END
20636
20637 *---------------------------------------------------------------------------
20638 * PURPOSE : CALCULATE THE MASS AND MOMENTUM OF K* RESONANCE
20639 *           AFTER PION + KAON COLLISION
20640 *clin only here the K* mass may be different from aks=0.895
20641         SUBROUTINE KSRESO(I1,I2)
20642         PARAMETER (MAXSTR=150001,MAXR=1,
20643      1  AMN=0.939457,AMP=0.93828,
20644      2  AP1=0.13496,AP2=0.13957,AM0=1.232,PI=3.1415926)
20645         COMMON /AA/ R(3,MAXSTR)
20646 cc      SAVE /AA/
20647         COMMON /BB/ P(3,MAXSTR)
20648 cc      SAVE /BB/
20649         COMMON /CC/ E(MAXSTR)
20650 cc      SAVE /CC/
20651         COMMON /EE/ ID(MAXSTR),LB(MAXSTR)
20652 cc      SAVE /EE/
20653         COMMON   /RUN/NUM
20654 cc      SAVE /RUN/
20655         COMMON   /PA/RPION(3,MAXSTR,MAXR)
20656 cc      SAVE /PA/
20657         COMMON   /PB/PPION(3,MAXSTR,MAXR)
20658 cc      SAVE /PB/
20659         COMMON   /PC/EPION(MAXSTR,MAXR)
20660 cc      SAVE /PC/
20661         COMMON   /PD/LPION(MAXSTR,MAXR)
20662 cc      SAVE /PD/
20663       SAVE
20664 * 1. DETERMINE THE MOMENTUM COMPONENT OF THE K* IN THE CMS OF PI-K FRAME
20665 *    WE LET I1 TO BE THE K* AND ABSORB I2
20666         E10=SQRT(E(I1)**2+P(1,I1)**2+P(2,I1)**2+P(3,I1)**2)
20667         E20=SQRT(E(I2)**2+P(1,I2)**2+P(2,I2)**2+P(3,I2)**2)
20668         IF(LB(I2) .EQ. 21 .OR. LB(I2) .EQ. 23) THEN
20669         E(I1)=0.
20670         I=I2
20671         ELSE
20672         E(I2)=0.
20673         I=I1
20674         ENDIF
20675         if(LB(I).eq.23) then
20676            LB(I)=30
20677         else if(LB(I).eq.21) then
20678            LB(I)=-30
20679         endif
20680         P(1,I)=P(1,I1)+P(1,I2)
20681         P(2,I)=P(2,I1)+P(2,I2)
20682         P(3,I)=P(3,I1)+P(3,I2)
20683 * 2. DETERMINE THE MASS OF K* BY USING THE REACTION KINEMATICS
20684         DM=SQRT((E10+E20)**2-P(1,I)**2-P(2,I)**2-P(3,I)**2)
20685         E(I)=DM
20686         RETURN
20687         END
20688
20689 c--------------------------------------------------------
20690 *************************************
20691 *                                                                         *
20692       SUBROUTINE pertur(PX,PY,PZ,SRT,IRUN,I1,I2,nt,kp,icont)
20693 *                                                                         *
20694 *       PURPOSE:   TO PRODUCE CASCADE AND OMEGA PERTURBATIVELY            *
20695 c sp 01/03/01
20696 *                   40 cascade-
20697 *                  -40 cascade-(bar)
20698 *                   41 cascade0
20699 *                  -41 cascade0(bar)
20700 *                   45 Omega baryon
20701 *                  -45 Omega baryon(bar)
20702 *                   44 Di-Omega
20703 **********************************
20704       PARAMETER      (MAXSTR=150001,MAXR=1,PI=3.1415926)
20705       parameter      (MX=4,MY=4,MZ=8,MPX=4,MPY=4,mpz=10,mpzp=10)
20706       PARAMETER (AMN=0.939457,AMP=0.93828,AP1=0.13496,AP2=0.13957)
20707       PARAMETER      (AKA=0.498,ALA=1.1157,ASA=1.1974,aks=0.895)
20708       PARAMETER      (ACAS=1.3213,AOME=1.6724,AMRHO=0.769,AMOMGA=0.782)
20709       PARAMETER      (AETA=0.548,ADIOMG=3.2288)
20710       parameter            (maxx=20,maxz=24)
20711       COMMON   /AA/  R(3,MAXSTR)
20712 cc      SAVE /AA/
20713       COMMON   /BB/  P(3,MAXSTR)
20714 cc      SAVE /BB/
20715       COMMON   /CC/  E(MAXSTR)
20716 cc      SAVE /CC/
20717       COMMON   /EE/  ID(MAXSTR),LB(MAXSTR)
20718 cc      SAVE /EE/
20719       COMMON   /HH/  PROPER(MAXSTR)
20720 cc      SAVE /HH/
20721       common /ff/f(-mx:mx,-my:my,-mz:mz,-mpx:mpx,-mpy:mpy,-mpz:mpzp)
20722 cc      SAVE /ff/
20723       common   /gg/  dx,dy,dz,dpx,dpy,dpz
20724 cc      SAVE /gg/
20725       COMMON   /INPUT/ NSTAR,NDIRCT,DIR
20726 cc      SAVE /INPUT/
20727       COMMON   /NN/NNN
20728 cc      SAVE /NN/
20729       COMMON   /PA/RPION(3,MAXSTR,MAXR)
20730 cc      SAVE /PA/
20731       COMMON   /PB/PPION(3,MAXSTR,MAXR)
20732 cc      SAVE /PB/
20733       COMMON   /PC/EPION(MAXSTR,MAXR)
20734 cc      SAVE /PC/
20735       COMMON   /PD/LPION(MAXSTR,MAXR)
20736 cc      SAVE /PD/
20737       COMMON   /PE/PROPI(MAXSTR,MAXR)
20738 cc      SAVE /PE/
20739       COMMON   /RR/  MASSR(0:MAXR)
20740 cc      SAVE /RR/
20741       COMMON   /BG/BETAX,BETAY,BETAZ,GAMMA
20742 cc      SAVE /BG/
20743       common/input1/ MASSPR,MASSTA,ISEED,IAVOID,DT
20744 cc      SAVE /input1/
20745 c     perturbative method is disabled:
20746 c      common /imulst/ iperts
20747 c
20748       COMMON/RNDF77/NSEED
20749 cc      SAVE /RNDF77/
20750       COMMON /dpert/dpertt(MAXSTR,MAXR),dpertp(MAXSTR),dplast(MAXSTR),
20751      1     dpdcy(MAXSTR),dpdpi(MAXSTR,MAXR),dpt(MAXSTR, MAXR),
20752      2     dpp1(MAXSTR,MAXR),dppion(MAXSTR,MAXR)
20753       SAVE
20754       kp=kp
20755       nt=nt
20756
20757       px0 = px
20758       py0 = py
20759       pz0 = pz
20760       LB1 = LB(I1)
20761       EM1 = E(I1)
20762       X1  = R(1,I1)
20763       Y1  = R(2,I1)
20764       Z1  = R(3,I1)
20765       prob1 = PROPER(I1)
20766 c
20767       LB2 = LB(I2)
20768       EM2 = E(I2)
20769       X2  = R(1,I2)
20770       Y2  = R(2,I2)
20771       Z2  = R(3,I2)
20772       prob2 = PROPER(I2)
20773 c
20774 c                 !! flag for real 2-body process (1/0=no/yes)
20775       icont = 1
20776 c                !! flag for elastic scatt only (-1=no)
20777       icsbel = -1
20778
20779 * K-/K*0bar + La/Si --> cascade + pi
20780 * K+/K*0 + La/Si (bar) --> cascade-bar + pi
20781        if( (lb1.eq.21.or.lb1.eq.23.or.iabs(lb1).eq.30) .and.
20782      &     (iabs(lb2).ge.14.and.iabs(lb2).le.17) )go to 60
20783        if( (lb2.eq.21.or.lb2.eq.23.or.iabs(lb2).eq.30) .and.
20784      &     (iabs(lb1).ge.14.and.iabs(lb1).le.17) )go to 60
20785 * K-/K*0bar + cascade --> omega + pi
20786 * K+/K*0 + cascade-bar --> omega-bar + pi
20787         if( (lb1.eq.21.or.lb1.eq.23.or.iabs(lb1).eq.30) .and.
20788      &      (iabs(lb2).eq.40.or.iabs(lb2).eq.41) )go to 70
20789         if( (lb2.eq.21.or.lb2.eq.23.or.iabs(lb2).eq.30) .and.
20790      &      (iabs(lb1).eq.40.or.iabs(lb1).eq.41) )go to 70
20791 c
20792 c annhilation of cascade,cascade-bar, omega,omega-bar
20793 c
20794 * K- + La/Si <-- cascade + pi(eta,rho,omega)
20795 * K+ + La/Si(bar) <-- cascade-bar + pi(eta,rho,omega)
20796        if( (((lb1.ge.3.and.lb1.le.5).or.lb1.eq.0)
20797      &        .and.(iabs(lb2).eq.40.or.iabs(lb2).eq.41))
20798      & .OR. (((lb2.ge.3.and.lb2.le.5).or.lb2.eq.0)
20799      &        .and.(iabs(lb1).eq.40.or.iabs(lb1).eq.41)) )go to 90
20800 * K- + cascade <-- omega + pi
20801 * K+ + cascade-bar <-- omega-bar + pi
20802 c         if( (lb1.eq.0.and.iabs(lb2).eq.45)
20803 c    &    .OR. (lb2.eq.0.and.iabs(lb1).eq.45) ) go to 110
20804        if( ((lb1.ge.3.and.lb1.le.5).and.iabs(lb2).eq.45)
20805      & .OR.((lb2.ge.3.and.lb2.le.5).and.iabs(lb1).eq.45) )go to 110
20806 c
20807
20808 c----------------------------------------------------
20809 *  for process:  K-bar + L(S) --> Ca + pi
20810 *
20811 60         if(iabs(lb1).ge.14 .and. iabs(lb1).le.17)then
20812              asap = e(i1)
20813              akap = e(i2)
20814              idp = i1
20815            else
20816              asap = e(i2)
20817              akap = e(i1)
20818              idp = i2
20819            endif
20820           app = 0.138
20821          if(srt .lt. (acas+app))return
20822           srrt = srt - (acas+app) + (amn+akap)
20823           pkaon = sqrt(((srrt**2-(amn**2+akap**2))/2./amn)**2 - akap**2)
20824           sigca = 1.5*( akNPsg(pkaon)+akNPsg(pkaon) )
20825 clin pii & pff should be each divided by (4*srt**2),
20826 c     but these two factors cancel out in the ratio pii/pff:
20827           pii = sqrt((srt**2-(amn+akap)**2)*(srt**2-(amn-akap)**2))
20828           pff = sqrt((srt**2-(asap+app)**2)*(srt**2-(asap-app)**2))
20829          cmat = sigca*pii/pff
20830          sigpi = cmat*
20831      &            sqrt((srt**2-(acas+app)**2)*(srt**2-(acas-app)**2))/
20832      &            sqrt((srt**2-(asap+akap)**2)*(srt**2-(asap-akap)**2))
20833 c
20834          sigeta = 0.
20835         if(srt .gt. (acas+aeta))then
20836            srrt = srt - (acas+aeta) + (amn+akap)
20837          pkaon = sqrt(((srrt**2-(amn**2+akap**2))/2./amn)**2 - akap**2)
20838             sigca = 1.5*( akNPsg(pkaon)+akNPsg(pkaon) )
20839          cmat = sigca*pii/pff
20840          sigeta = cmat*
20841      &            sqrt((srt**2-(acas+aeta)**2)*(srt**2-(acas-aeta)**2))/
20842      &            sqrt((srt**2-(asap+akap)**2)*(srt**2-(asap-akap)**2))
20843         endif
20844 c
20845          sigca = sigpi + sigeta
20846          sigpe = 0.
20847 clin-2/25/03 disable the perturb option:
20848 c        if(iperts .eq. 1) sigpe = 40.   !! perturbative xsecn
20849            sig = amax1(sigpe,sigca)
20850          ds = sqrt(sig/31.4)
20851          dsr = ds + 0.1
20852          ec = (em1+em2+0.02)**2
20853          call distce(i1,i2,dsr,ds,dt,ec,srt,ic,px,py,pz)
20854            if(ic .eq. -1)return
20855           brpp = sigca/sig
20856 c
20857 c else particle production
20858           if( (lb1.ge.14.and.lb1.le.17) .or.
20859      &          (lb2.ge.14.and.lb2.le.17) )then
20860 c   !! cascade- or cascde0
20861             lbpp1 = 40 + int(2*RANART(NSEED))
20862           else
20863 * elseif(lb1 .eq. -14 .or. lb2 .eq. -14)
20864 c     !! cascade-bar- or cascde0 -bar
20865             lbpp1 = -40 - int(2*RANART(NSEED))
20866           endif
20867               empp1 = acas
20868            if(RANART(NSEED) .lt. sigpi/sigca)then
20869 c    !! pion
20870             lbpp2 = 3 + int(3*RANART(NSEED))
20871             empp2 = 0.138
20872            else
20873 c    !! eta
20874             lbpp2 = 0
20875             empp2 = aeta
20876            endif
20877 c* check real process of cascade(bar) and pion formation
20878           if(RANART(NSEED) .lt. brpp)then
20879 c       !! real process flag
20880             icont = 0
20881             lb(i1) = lbpp1
20882             e(i1) = empp1
20883 c  !! cascade formed with prob Gam
20884             proper(i1) = brpp
20885             lb(i2) = lbpp2
20886             e(i2) = empp2
20887 c         !! pion/eta formed with prob 1.
20888             proper(i2) = 1.
20889            endif
20890 c else only cascade(bar) formed perturbatively
20891              go to 700
20892
20893 c----------------------------------------------------
20894 *  for process:  Cas(bar) + K_bar(K) --> Om(bar) + pi  !! eta
20895 *
20896 70         if(iabs(lb1).eq.40 .or. iabs(lb1).eq.41)then
20897              acap = e(i1)
20898              akap = e(i2)
20899              idp = i1
20900            else
20901              acap = e(i2)
20902              akap = e(i1)
20903              idp = i2
20904            endif
20905            app = 0.138
20906 *         ames = aeta
20907 c  !! only pion
20908            ames = 0.138
20909          if(srt .lt. (aome+ames))return
20910           srrt = srt - (aome+ames) + (amn+akap)
20911          pkaon = sqrt(((srrt**2-(amn**2+akap**2))/2./amn)**2 - akap**2)
20912 c use K(bar) + Ca --> Om + eta  xsecn same as  K(bar) + N --> Si + Pi
20913 *  as Omega have no resonances
20914 c** using same matrix elements as K-bar + N -> Si + pi
20915          sigomm = 1.5*( akNPsg(pkaon)+akNPsg(pkaon) )
20916          cmat = sigomm*
20917      &          sqrt((srt**2-(amn+akap)**2)*(srt**2-(amn-akap)**2))/
20918      &          sqrt((srt**2-(asa+app)**2)*(srt**2-(asa-app)**2))
20919         sigom = cmat*
20920      &           sqrt((srt**2-(aome+ames)**2)*(srt**2-(aome-ames)**2))/
20921      &           sqrt((srt**2-(acap+akap)**2)*(srt**2-(acap-akap)**2))
20922           sigpe = 0.
20923 clin-2/25/03 disable the perturb option:
20924 c         if(iperts .eq. 1) sigpe = 40.   !! perturbative xsecn
20925           sig = amax1(sigpe,sigom)
20926          ds = sqrt(sig/31.4)
20927          dsr = ds + 0.1
20928          ec = (em1+em2+0.02)**2
20929          call distce(i1,i2,dsr,ds,dt,ec,srt,ic,px,py,pz)
20930            if(ic .eq. -1)return
20931            brpp = sigom/sig
20932 c
20933 c else particle production
20934            if( (lb1.ge.40.and.lb1.le.41) .or.
20935      &           (lb2.ge.40.and.lb2.le.41) )then
20936 c    !! omega
20937             lbpp1 = 45
20938            else
20939 * elseif(lb1 .eq. -40 .or. lb2 .eq. -40)
20940 c    !! omega-bar
20941             lbpp1 = -45
20942            endif
20943            empp1 = aome
20944 *           lbpp2 = 0    !! eta
20945 c    !! pion
20946            lbpp2 = 3 + int(3*RANART(NSEED))
20947            empp2 = ames
20948 c
20949 c* check real process of omega(bar) and pion formation
20950            xrand=RANART(NSEED)
20951          if(xrand .lt. (proper(idp)*brpp))then
20952 c       !! real process flag
20953             icont = 0
20954             lb(i1) = lbpp1
20955             e(i1) = empp1
20956 c  !! P_Om = P_Cas*Gam
20957             proper(i1) = proper(idp)*brpp
20958             lb(i2) = lbpp2
20959             e(i2) = empp2
20960 c   !! pion formed with prob 1.
20961             proper(i2) = 1.
20962           elseif(xrand.lt.brpp) then
20963 c else omega(bar) formed perturbatively and cascade destroyed
20964              e(idp) = 0.
20965           endif
20966              go to 700
20967
20968 c-----------------------------------------------------------
20969 *  for process:  Ca + pi/eta --> K-bar + L(S)
20970 *
20971 90         if(iabs(lb1).eq.40 .or. iabs(lb1).eq.41)then
20972              acap = e(i1)
20973              app = e(i2)
20974              idp = i1
20975              idn = i2
20976            else
20977              acap = e(i2)
20978              app = e(i1)
20979              idp = i2
20980              idn = i1
20981            endif
20982 c            akal = (aka+aks)/2.  !! average of K and K* taken
20983 c  !! using K only
20984             akal = aka
20985 c
20986          alas = ala
20987        if(srt .le. (alas+aka))return
20988            srrt = srt - (acap+app) + (amn+aka)
20989          pkaon = sqrt(((srrt**2-(amn**2+aka**2))/2./amn)**2 - aka**2)
20990 c** using same matrix elements as K-bar + N -> La/Si + pi
20991          sigca = 1.5*( akNPsg(pkaon)+akNPsg(pkaon) )
20992          cmat = sigca*
20993      &          sqrt((srt**2-(amn+aka)**2)*(srt**2-(amn-aka)**2))/
20994      &          sqrt((srt**2-(alas+0.138)**2)*(srt**2-(alas-0.138)**2))
20995          sigca = cmat*
20996      &            sqrt((srt**2-(acap+app)**2)*(srt**2-(acap-app)**2))/
20997      &            sqrt((srt**2-(alas+aka)**2)*(srt**2-(alas-aka)**2))
20998 c    !! pi
20999             dfr = 1./3.
21000 c       !! eta
21001            if(lb(idn).eq.0)dfr = 1.
21002         sigcal = sigca*dfr*(srt**2-(alas+aka)**2)*
21003      &           (srt**2-(alas-aka)**2)/(srt**2-(acap+app)**2)/
21004      &           (srt**2-(acap-app)**2)
21005 c
21006           alas = ASA
21007        if(srt .le. (alas+aka))then
21008          sigcas = 0.
21009        else
21010            srrt = srt - (acap+app) + (amn+aka)
21011         pkaon = sqrt(((srrt**2-(amn**2+aka**2))/2./amn)**2 - aka**2)
21012 c use K(bar) + La/Si --> Ca + Pi  xsecn same as  K(bar) + N --> Si + Pi
21013 c** using same matrix elements as K-bar + N -> La/Si + pi
21014           sigca = 1.5*( akNPsg(pkaon)+akNPsg(pkaon) )
21015          cmat = sigca*
21016      &          sqrt((srt**2-(amn+aka)**2)*(srt**2-(amn-aka)**2))/
21017      &          sqrt((srt**2-(alas+0.138)**2)*(srt**2-(alas-0.138)**2))
21018          sigca = cmat*
21019      &            sqrt((srt**2-(acap+app)**2)*(srt**2-(acap-app)**2))/
21020      &            sqrt((srt**2-(alas+aka)**2)*(srt**2-(alas-aka)**2))
21021 c    !! pi
21022             dfr = 1.
21023 c    !! eta
21024            if(lb(idn).eq.0)dfr = 3.
21025         sigcas = sigca*dfr*(srt**2-(alas+aka)**2)*
21026      &           (srt**2-(alas-aka)**2)/(srt**2-(acap+app)**2)/
21027      &           (srt**2-(acap-app)**2)
21028        endif
21029 c
21030          sig = sigcal + sigcas
21031          brpp = 1.
21032          ds = sqrt(sig/31.4)
21033          dsr = ds + 0.1
21034          ec = (em1+em2+0.02)**2
21035          call distce(i1,i2,dsr,ds,dt,ec,srt,ic,px,py,pz)
21036 c
21037 clin-2/25/03: checking elastic scatt after failure of inelastic scatt gives
21038 c     conditional probability (in general incorrect), tell Pal to correct:
21039        if(ic .eq. -1)then
21040 c check for elastic scatt, no particle annhilation
21041 c  !! elastic cross section of 20 mb
21042          ds = sqrt(20.0/31.4)
21043          dsr = ds + 0.1
21044          call distce(i1,i2,dsr,ds,dt,ec,srt,icsbel,px,py,pz)
21045            if(icsbel .eq. -1)return
21046             empp1 = EM1
21047             empp2 = EM2
21048              go to 700
21049        endif
21050 c
21051 c else pert. produced cascade(bar) is annhilated OR real process
21052 c
21053 * DECIDE LAMBDA OR SIGMA PRODUCTION
21054 c
21055        IF(sigcal/sig .GT. RANART(NSEED))THEN
21056           if(lb1.eq.40.or.lb1.eq.41.or.lb2.eq.40.or.lb2.eq.41)then
21057           lbpp1 = 21
21058            lbpp2 = 14
21059           else
21060            lbpp1 = 23
21061            lbpp2 = -14
21062           endif
21063          alas = ala
21064        ELSE
21065           if(lb1.eq.40.or.lb1.eq.41.or.lb2.eq.40.or.lb2.eq.41)then
21066            lbpp1 = 21
21067             lbpp2 = 15 + int(3 * RANART(NSEED))
21068           else
21069             lbpp1 = 23
21070             lbpp2 = -15 - int(3 * RANART(NSEED))
21071           endif
21072          alas = ASA
21073         ENDIF
21074              empp1 = aka
21075              empp2 = alas
21076 c
21077 c check for real process for L/S(bar) and K(bar) formation
21078           if(RANART(NSEED) .lt. proper(idp))then
21079 * real process
21080 c       !! real process flag
21081             icont = 0
21082             lb(i1) = lbpp1
21083             e(i1) = empp1
21084 c   !! K(bar) formed with prob 1.
21085             proper(i1) = 1.
21086             lb(i2) = lbpp2
21087             e(i2) = empp2
21088 c   !! L/S(bar) formed with prob 1.
21089             proper(i2) = 1.
21090              go to 700
21091            else
21092 c else only cascade(bar) annhilation & go out
21093             e(idp) = 0.
21094            endif
21095           return
21096 c
21097 c----------------------------------------------------
21098 *  for process:  Om(bar) + pi --> Cas(bar) + K_bar(K)
21099 *
21100 110         if(lb1 .eq. 45 .or. lb1 .eq. -45)then
21101              aomp = e(i1)
21102              app = e(i2)
21103              idp = i1
21104              idn = i2
21105            else
21106              aomp = e(i2)
21107              app = e(i1)
21108              idp = i2
21109              idn = i1
21110            endif
21111 c            akal = (aka+aks)/2.  !! average of K and K* taken
21112 c  !! using K only
21113             akal = aka
21114        if(srt .le. (acas+aka))return
21115            srrt = srt - (aome+app) + (amn+aka)
21116          pkaon = sqrt(((srrt**2-(amn**2+aka**2))/2./amn)**2 - aka**2)
21117 c use K(bar) + Ca --> Om + eta  xsecn same as  K(bar) + N --> Si + Pi
21118 c** using same matrix elements as K-bar + N -> La/Si + pi
21119            sigca = 1.5*( akNPsg(pkaon)+akNPsg(pkaon) )
21120          cmat = sigca*
21121      &          sqrt((srt**2-(amn+aka)**2)*(srt**2-(amn-aka)**2))/
21122      &          sqrt((srt**2-(asa+0.138)**2)*(srt**2-(asa-0.138)**2))
21123          sigom = cmat*
21124      &            sqrt((srt**2-(aomp+app)**2)*(srt**2-(aomp-app)**2))/
21125      &            sqrt((srt**2-(acas+aka)**2)*(srt**2-(acas-aka)**2))
21126 c            dfr = 2.    !! eta
21127 c    !! pion
21128            dfr = 2./3.
21129         sigom = sigom*dfr*(srt**2-(acas+aka)**2)*
21130      &           (srt**2-(acas-aka)**2)/(srt**2-(aomp+app)**2)/
21131      &           (srt**2-(aomp-app)**2)
21132 c
21133          brpp = 1.
21134          ds = sqrt(sigom/31.4)
21135          dsr = ds + 0.1
21136          ec = (em1+em2+0.02)**2
21137          call distce(i1,i2,dsr,ds,dt,ec,srt,ic,px,py,pz)
21138 c
21139 clin-2/25/03: checking elastic scatt after failure of inelastic scatt gives
21140 c     conditional probability (in general incorrect), tell Pal to correct:
21141        if(ic .eq. -1)then
21142 c check for elastic scatt, no particle annhilation
21143 c  !! elastic cross section of 20 mb
21144          ds = sqrt(20.0/31.4)
21145          dsr = ds + 0.1
21146          call distce(i1,i2,dsr,ds,dt,ec,srt,icsbel,px,py,pz)
21147            if(icsbel .eq. -1)return
21148             empp1 = EM1
21149             empp2 = EM2
21150              go to 700
21151        endif
21152 c
21153 c else pert. produced omega(bar) annhilated  OR real process
21154 c annhilate only pert. omega, rest from hijing go out WITHOUT annhil.
21155            if(lb1.eq.45 .or. lb2.eq.45)then
21156 c  !! Ca
21157              lbpp1 = 40 + int(2*RANART(NSEED))
21158 c   !! K-
21159              lbpp2 = 21
21160             else
21161 * elseif(lb1 .eq. -45 .or. lb2 .eq. -45)
21162 c    !! Ca-bar
21163             lbpp1 = -40 - int(2*RANART(NSEED))
21164 c      !! K+
21165             lbpp2 = 23
21166            endif
21167              empp1 = acas
21168              empp2 = aka
21169 c
21170 c check for real process for Cas(bar) and K(bar) formation
21171           if(RANART(NSEED) .lt. proper(idp))then
21172 c       !! real process flag
21173             icont = 0
21174             lb(i1) = lbpp1
21175             e(i1) = empp1
21176 c   !! P_Cas(bar) = P_Om(bar)
21177             proper(i1) = proper(idp)
21178             lb(i2) = lbpp2
21179             e(i2) = empp2
21180 c   !! K(bar) formed with prob 1.
21181             proper(i2) = 1.
21182 c
21183            else
21184 c else Cascade(bar)  produced and Omega(bar) annhilated
21185             e(idp) = 0.
21186            endif
21187 c   !! for produced particles
21188              go to 700
21189 c
21190 c-----------------------------------------------------------
21191 700    continue
21192 * CALCULATE THE MAGNITUDE OF THE FINAL MOMENTUM THROUGH
21193 * ENERGY CONSERVATION
21194           PR2   = (SRT**2 - EMpp1**2 - EMpp2**2)**2
21195      &                - 4.0 * (EMpp1*EMpp2)**2
21196           IF(PR2.LE.0.)PR2=0.00000001
21197           PR=SQRT(PR2)/(2.*SRT)
21198 * using isotropic
21199       C1   = 1.0 - 2.0 * RANART(NSEED)
21200       T1   = 2.0 * PI * RANART(NSEED)
21201       S1   = SQRT( 1.0 - C1**2 )
21202       CT1  = COS(T1)
21203       ST1  = SIN(T1)
21204 * THE MOMENTUM IN THE CMS IN THE FINAL STATE
21205       PZ   = PR * C1
21206       PX   = PR * S1*CT1
21207       PY   = PR * S1*ST1
21208 * ROTATE IT
21209        CALL ROTATE(PX0,PY0,PZ0,PX,PY,PZ)
21210        if(icont .eq. 0)return
21211 c
21212 * LORENTZ-TRANSFORMATION INTO CMS FRAME
21213               E1CM    = SQRT (EMpp1**2 + PX**2 + PY**2 + PZ**2)
21214               P1BETA  = PX*BETAX + PY*BETAY + PZ*BETAZ
21215               TRANSF  = GAMMA * ( GAMMA * P1BETA / (GAMMA + 1) + E1CM )
21216               Ppt11 = BETAX * TRANSF + PX
21217               Ppt12 = BETAY * TRANSF + PY
21218               Ppt13 = BETAZ * TRANSF + PZ
21219 c
21220 cc** for elastic scattering update the momentum of pertb particles
21221          if(icsbel .ne. -1)then
21222 c            if(EMpp1 .gt. 0.9)then
21223               p(1,i1) = Ppt11
21224               p(2,i1) = Ppt12
21225               p(3,i1) = Ppt13
21226 c            else
21227               E2CM    = SQRT (EMpp2**2 + PX**2 + PY**2 + PZ**2)
21228               TRANSF  = GAMMA * ( -GAMMA * P1BETA / (GAMMA + 1) + E2CM )
21229               Ppt21 = BETAX * TRANSF - PX
21230               Ppt22 = BETAY * TRANSF - PY
21231               Ppt23 = BETAZ * TRANSF - PZ
21232               p(1,i2) = Ppt21
21233               p(2,i2) = Ppt22
21234               p(3,i2) = Ppt23
21235 c            endif
21236              return
21237           endif
21238 clin-5/2008:
21239 c2008        X01 = 1.0 - 2.0 * RANART(NSEED)
21240 c            Y01 = 1.0 - 2.0 * RANART(NSEED)
21241 c            Z01 = 1.0 - 2.0 * RANART(NSEED)
21242 c        IF ((X01*X01+Y01*Y01+Z01*Z01) .GT. 1.0) GOTO 2008
21243 c                Xpt=X1+0.5*x01
21244 c                Ypt=Y1+0.5*y01
21245 c                Zpt=Z1+0.5*z01
21246                 Xpt=X1
21247                 Ypt=Y1
21248                 Zpt=Z1
21249 c
21250 c
21251 c          if(lbpp1 .eq. 45)then
21252 c           write(*,*)'II lb1,lb2,lbpp1,empp1,proper(idp),brpp'
21253 c           write(*,*)lb1,lb2,lbpp1,empp1,proper(idp),brpp
21254 c          endif
21255 c
21256                NNN=NNN+1
21257                PROPI(NNN,IRUN)= proper(idp)*brpp
21258                LPION(NNN,IRUN)= lbpp1
21259                EPION(NNN,IRUN)= empp1
21260                 RPION(1,NNN,IRUN)=Xpt
21261                 RPION(2,NNN,IRUN)=Ypt
21262                 RPION(3,NNN,IRUN)=Zpt
21263                PPION(1,NNN,IRUN)=Ppt11
21264                PPION(2,NNN,IRUN)=Ppt12
21265                PPION(3,NNN,IRUN)=Ppt13
21266 clin-5/2008:
21267                dppion(nnn,irun)=dpertp(i1)*dpertp(i2)
21268             RETURN
21269             END
21270 **********************************
21271 *  sp 12/08/00                                                         *
21272       SUBROUTINE Crhb(PX,PY,PZ,SRT,I1,I2,IBLOCK)
21273 *     PURPOSE:                                                         *
21274 *        DEALING WITH hyperon+N(D,N*)->hyp+N(D,N*) elastic PROCESS     *
21275 *     NOTE   :                                                         *
21276 *
21277 *     QUANTITIES:                                                 *
21278 *           PX,PY,PZ - MOMENTUM COORDINATES OF ONE PARTICLE IN CM FRAME*
21279 *           SRT      - SQRT OF S                                       *
21280 *           IBLOCK   - THE INFORMATION BACK                            *
21281 *                     144-> hyp+N(D,N*)->hyp+N(D,N*)
21282 **********************************
21283         PARAMETER (MAXSTR=150001,MAXR=1,AMN=0.939457,
21284      1  AMP=0.93828,AP1=0.13496,
21285      2  AP2=0.13957,AM0=1.232,PI=3.1415926,CUTOFF=1.8966,AVMASS=0.9383)
21286         PARAMETER      (AKA=0.498,ALA=1.1157,ASA=1.1974)
21287         parameter     (MX=4,MY=4,MZ=8,MPX=4,MPY=4,mpz=10,mpzp=10)
21288         COMMON /AA/ R(3,MAXSTR)
21289 cc      SAVE /AA/
21290         COMMON /BB/ P(3,MAXSTR)
21291 cc      SAVE /BB/
21292         COMMON /CC/ E(MAXSTR)
21293 cc      SAVE /CC/
21294         COMMON /EE/ ID(MAXSTR),LB(MAXSTR)
21295 cc      SAVE /EE/
21296         common/input1/ MASSPR,MASSTA,ISEED,IAVOID,DT
21297 cc      SAVE /input1/
21298       COMMON/RNDF77/NSEED
21299 cc      SAVE /RNDF77/
21300       SAVE
21301
21302        PX0=PX
21303        PY0=PY
21304        PZ0=PZ
21305 *-----------------------------------------------------------------------
21306         IBLOCK=144
21307         NTAG=0
21308         EM1=E(I1)
21309         EM2=E(I2)
21310 *-----------------------------------------------------------------------
21311 * CALCULATE THE MAGNITUDE OF THE FINAL MOMENTUM THROUGH
21312 * ENERGY CONSERVATION
21313           PR2   = (SRT**2 - EM1**2 - EM2**2)**2
21314      1                - 4.0 * (EM1*EM2)**2
21315           IF(PR2.LE.0.)PR2=1.e-09
21316           PR=SQRT(PR2)/(2.*SRT)
21317           C1   = 1.0 - 2.0 * RANART(NSEED)
21318           T1   = 2.0 * PI * RANART(NSEED)
21319       S1   = SQRT( 1.0 - C1**2 )
21320       CT1  = COS(T1)
21321       ST1  = SIN(T1)
21322       PZ   = PR * C1
21323       PX   = PR * S1*CT1
21324       PY   = PR * S1*ST1
21325       RETURN
21326       END
21327 ****************************************
21328 c sp 04/05/01
21329 * Purpose: lambda-baryon elastic xsection as a functon of their cms energy
21330          subroutine lambar(i1,i2,srt,siglab)
21331 *  srt    = DSQRT(s) in GeV                                               *
21332 *  siglab = lambda-nuclar elastic cross section in mb
21333 *         = 12 + 0.43/p_lab**3.3 (mb)
21334 *
21335 * (2) Calculate p(lab) from srt [GeV], since the formular in the
21336 * reference applies only to the case of a p_bar on a proton at rest
21337 * Formula used: srt**2=2.*pmass*(pmass+sqrt(pmass**2+plab**2))
21338 *****************************
21339         PARAMETER (MAXSTR=150001)
21340         COMMON /AA/ R(3,MAXSTR)
21341 cc      SAVE /AA/
21342         COMMON /BB/ P(3,MAXSTR)
21343 cc      SAVE /BB/
21344         COMMON /CC/ E(MAXSTR)
21345 cc      SAVE /CC/
21346         COMMON /EE/ ID(MAXSTR),LB(MAXSTR)
21347 cc      SAVE /EE/
21348       SAVE
21349
21350           siglab=1.e-06
21351         if( iabs(lb(i1)).ge.14.and.iabs(lb(i1)).le.17 )then
21352           eml = e(i1)
21353           emb = e(i2)
21354          else
21355           eml = e(i2)
21356           emb = e(i1)
21357         endif
21358        pthr = srt**2-eml**2-emb**2
21359         if(pthr .gt. 0.)then
21360        plab2=(pthr/2./emb)**2-eml**2
21361        if(plab2.gt.0)then
21362          plab=sqrt(plab2)
21363          siglab=12. + 0.43/(plab**3.3)
21364        if(siglab.gt.200.)siglab=200.
21365        endif
21366        endif
21367          return
21368       END
21369 C------------------------------------------------------------------
21370 clin-7/26/03 improve speed
21371 ***************************************
21372             SUBROUTINE distc0(drmax,deltr0,DT,
21373      1     Ifirst,PX1CM,PY1CM,PZ1CM,
21374      2     x1,y1,z1,px1,py1,pz1,em1,x2,y2,z2,px2,py2,pz2,em2)
21375 * PURPOSE : CHECK IF THE COLLISION BETWEEN TWO PARTICLES CAN HAPPEN
21376 *           BY CHECKING
21377 *                      (2) IF PARTICLE WILL PASS EACH OTHER WITHIN
21378 *           TWO HARD CORE RADIUS.
21379 *                      (3) IF PARTICLES WILL GET CLOSER.
21380 * VARIABLES :
21381 *           Ifirst=1 COLLISION may HAPPENED
21382 *           Ifirst=-1 COLLISION CAN NOT HAPPEN
21383 *****************************************
21384             COMMON   /BG/  BETAX,BETAY,BETAZ,GAMMA
21385 cc      SAVE /BG/
21386       SAVE
21387             deltr0=deltr0
21388             Ifirst=-1
21389             E1=SQRT(EM1**2+PX1**2+PY1**2+PZ1**2)
21390 *NOW PARTICLES ARE CLOSE ENOUGH TO EACH OTHER !
21391             E2     = SQRT ( EM2**2 + PX2**2 + PY2**2 + PZ2**2 )
21392 *NOW THERE IS ENOUGH ENERGY AVAILABLE !
21393 *LORENTZ-TRANSFORMATION IN I1-I2-C.M. SYSTEM
21394 * BETAX, BETAY, BETAZ AND GAMMA HAVE BEEN GIVEN IN THE SUBROUTINE CMS
21395 *TRANSFORMATION OF MOMENTA (PX1CM = - PX2CM)
21396               P1BETA = PX1*BETAX + PY1*BETAY + PZ1 * BETAZ
21397               TRANSF = GAMMA * ( GAMMA * P1BETA / (GAMMA + 1) - E1 )
21398               PRCM   = SQRT (PX1CM**2 + PY1CM**2 + PZ1CM**2)
21399               IF (PRCM .LE. 0.00001) return
21400 *TRANSFORMATION OF SPATIAL DISTANCE
21401               DRBETA = BETAX*(X1-X2) + BETAY*(Y1-Y2) + BETAZ*(Z1-Z2)
21402               TRANSF = GAMMA * GAMMA * DRBETA / (GAMMA + 1)
21403               DXCM   = BETAX * TRANSF + X1 - X2
21404               DYCM   = BETAY * TRANSF + Y1 - Y2
21405               DZCM   = BETAZ * TRANSF + Z1 - Z2
21406 *DETERMINING IF THIS IS THE POINT OF CLOSEST APPROACH
21407               DRCM   = SQRT (DXCM**2  + DYCM**2  + DZCM**2 )
21408               DZZ    = (PX1CM*DXCM + PY1CM*DYCM + PZ1CM*DZCM) / PRCM
21409               if ((drcm**2 - dzz**2) .le. 0.) then
21410                 BBB = 0.
21411               else
21412                 BBB    = SQRT (DRCM**2 - DZZ**2)
21413               end if
21414 *WILL PARTICLE PASS EACH OTHER WITHIN 2 * HARD CORE RADIUS ?
21415               IF (BBB .GT. drmax) return
21416               RELVEL = PRCM * (1.0/E1 + 1.0/E2)
21417               DDD    = RELVEL * DT * 0.5
21418 *WILL PARTICLES GET CLOSER ?
21419               IF (ABS(DDD) .LT. ABS(DZZ)) return
21420               Ifirst=1
21421               RETURN
21422               END
21423 *---------------------------------------------------------------------------
21424 c
21425 clin-8/2008 B+B->Deuteron+Meson cross section in mb:
21426       subroutine sbbdm(srt,sdprod,ianti,lbm,xmm,pfinal)
21427       PARAMETER (xmd=1.8756,AP1=0.13496,AP2=0.13957,
21428      1     xmrho=0.770,xmomega=0.782,xmeta=0.548,srt0=2.012)
21429       common/leadng/lb1,px1,py1,pz1,em1,e1,xfnl,yfnl,zfnl,tfnl,
21430      1     px1n,py1n,pz1n,dp1n
21431       common /dpi/em2,lb2
21432       common /para8/ idpert,npertd,idxsec
21433       COMMON/RNDF77/NSEED
21434       SAVE
21435 c
21436       sdprod=0.
21437       sbbdpi=0.
21438       sbbdrho=0.
21439       sbbdomega=0.
21440       sbbdeta=0.
21441       if(srt.le.(em1+em2)) return
21442 c
21443       ilb1=iabs(lb1)
21444       ilb2=iabs(lb2)
21445 ctest off check Xsec using fixed mass for resonances:
21446 c      if(ilb1.ge.6.and.ilb1.le.9) then
21447 c         em1=1.232
21448 c      elseif(ilb1.ge.10.and.ilb1.le.11) then
21449 c         em1=1.44
21450 c      elseif(ilb1.ge.12.and.ilb1.le.13) then
21451 c         em1=1.535
21452 c      endif
21453 c      if(ilb2.ge.6.and.ilb2.le.9) then
21454 c         em2=1.232
21455 c      elseif(ilb2.ge.10.and.ilb2.le.11) then
21456 c         em2=1.44
21457 c      elseif(ilb2.ge.12.and.ilb2.le.13) then
21458 c         em2=1.535
21459 c      endif
21460 c
21461       s=srt**2
21462       pinitial=sqrt((s-(em1+em2)**2)*(s-(em1-em2)**2))/2./srt
21463       fs=fnndpi(s)
21464 c     Determine isospin and spin factors for the ratio between
21465 c     BB->Deuteron+Meson and Deuteron+Meson->BB cross sections:
21466       if(idxsec.eq.1.or.idxsec.eq.2) then
21467 c     Assume B+B -> d+Meson has the same cross sections as N+N -> d+pi:
21468       else
21469 c     Assume d+Meson -> B+B has the same cross sections as d+pi -> N+N,
21470 c     then determine B+B -> d+Meson cross sections:
21471          if(ilb1.ge.1.and.ilb1.le.2.and.
21472      1        ilb2.ge.1.and.ilb2.le.2) then
21473             pifactor=9./8.
21474          elseif((ilb1.ge.1.and.ilb1.le.2.and.
21475      1           ilb2.ge.6.and.ilb2.le.9).or.
21476      2           (ilb2.ge.1.and.ilb2.le.2.and.
21477      1           ilb1.ge.6.and.ilb1.le.9)) then
21478             pifactor=9./64.
21479          elseif((ilb1.ge.1.and.ilb1.le.2.and.
21480      1           ilb2.ge.10.and.ilb2.le.13).or.
21481      2           (ilb2.ge.1.and.ilb2.le.2.and.
21482      1           ilb1.ge.10.and.ilb1.le.13)) then
21483             pifactor=9./16.
21484          elseif(ilb1.ge.6.and.ilb1.le.9.and.
21485      1           ilb2.ge.6.and.ilb2.le.9) then
21486             pifactor=9./128.
21487          elseif((ilb1.ge.6.and.ilb1.le.9.and.
21488      1           ilb2.ge.10.and.ilb2.le.13).or.
21489      2           (ilb2.ge.6.and.ilb2.le.9.and.
21490      1           ilb1.ge.10.and.ilb1.le.13)) then
21491             pifactor=9./64.
21492          elseif((ilb1.ge.10.and.ilb1.le.11.and.
21493      1           ilb2.ge.10.and.ilb2.le.11).or.
21494      2           (ilb2.ge.12.and.ilb2.le.13.and.
21495      1           ilb1.ge.12.and.ilb1.le.13)) then
21496             pifactor=9./8.
21497          elseif((ilb1.ge.10.and.ilb1.le.11.and.
21498      1           ilb2.ge.12.and.ilb2.le.13).or.
21499      2           (ilb2.ge.10.and.ilb2.le.11.and.
21500      1           ilb1.ge.12.and.ilb1.le.13)) then
21501             pifactor=9./16.
21502          endif
21503       endif
21504 c     d pi: DETERMINE THE CHARGE STATES OF PARTICLES IN THE FINAL STATE
21505 *     (1) FOR P+P->Deuteron+pi+:
21506       IF((ilb1*ilb2).EQ.1)THEN
21507          lbm=5
21508          if(ianti.eq.1) lbm=3
21509          xmm=ap2
21510 *     (2)FOR N+N->Deuteron+pi-:
21511       ELSEIF(ilb1.EQ.2.AND.ilb2.EQ.2)THEN
21512          lbm=3
21513          if(ianti.eq.1) lbm=5
21514          xmm=ap2
21515 *     (3)FOR N+P->Deuteron+pi0:
21516       ELSEIF((ilb1*ilb2).EQ.2)THEN
21517          lbm=4
21518          xmm=ap1
21519       ELSE
21520 c     For baryon resonances, use isospin-averaged cross sections:
21521          lbm=3+int(3 * RANART(NSEED))
21522          if(lbm.eq.4) then
21523             xmm=ap1
21524          else
21525             xmm=ap2
21526          endif
21527       ENDIF
21528 c
21529       if(srt.ge.(xmd+xmm)) then
21530          pfinal=sqrt((s-(xmd+xmm)**2)*(s-(xmd-xmm)**2))/2./srt
21531          if((ilb1.eq.1.and.ilb2.eq.1).or.
21532      1        (ilb1.eq.2.and.ilb2.eq.2)) then
21533 c     for pp or nn initial states:
21534             sbbdpi=fs*pfinal/pinitial/4.
21535          elseif((ilb1.eq.1.and.ilb2.eq.2).or.
21536      1           (ilb1.eq.2.and.ilb2.eq.1)) then
21537 c     factor of 1/2 for pn or np initial states:
21538             sbbdpi=fs*pfinal/pinitial/4./2.
21539          else
21540 c     for other BB initial states (spin- and isospin averaged):
21541             if(idxsec.eq.1) then
21542 c     1: assume the same |matrix element|**2 (after averaging over initial
21543 c     spins and isospins) for B+B -> deuteron+meson at the same sqrt(s);
21544                sbbdpi=fs*pfinal/pinitial*3./16.
21545             elseif(idxsec.eq.2.or.idxsec.eq.4) then
21546                threshold=amax1(xmd+xmm,em1+em2)
21547                snew=(srt-threshold+srt0)**2
21548                if(idxsec.eq.2) then
21549 c     2: assume the same |matrix element|**2 for B+B -> deuteron+meson
21550 c     at the same sqrt(s)-threshold:
21551                   sbbdpi=fnndpi(snew)*pfinal/pinitial*3./16.
21552                elseif(idxsec.eq.4) then
21553 c     4: assume the same |matrix element|**2 for B+B <- deuteron+meson
21554 c     at the same sqrt(s)-threshold:
21555                   sbbdpi=fnndpi(snew)*pfinal/pinitial/6.*pifactor
21556                endif
21557             elseif(idxsec.eq.3) then
21558 c     3: assume the same |matrix element|**2 for B+B <- deuteron+meson
21559 c     at the same sqrt(s):
21560                sbbdpi=fs*pfinal/pinitial/6.*pifactor
21561             endif
21562 c
21563          endif
21564       endif
21565 c
21566 *     d rho: DETERMINE THE CROSS SECTION TO THIS FINAL STATE:
21567       if(srt.gt.(xmd+xmrho)) then
21568          pfinal=sqrt((s-(xmd+xmrho)**2)*(s-(xmd-xmrho)**2))/2./srt
21569          if(idxsec.eq.1) then
21570             sbbdrho=fs*pfinal/pinitial*3./16.
21571          elseif(idxsec.eq.2.or.idxsec.eq.4) then
21572             threshold=amax1(xmd+xmrho,em1+em2)
21573             snew=(srt-threshold+srt0)**2
21574             if(idxsec.eq.2) then
21575                sbbdrho=fnndpi(snew)*pfinal/pinitial*3./16.
21576             elseif(idxsec.eq.4) then
21577 c     The spin- and isospin-averaged factor is 3-times larger for rho:
21578                sbbdrho=fnndpi(snew)*pfinal/pinitial/6.*(pifactor*3.)
21579             endif
21580          elseif(idxsec.eq.3) then
21581             sbbdrho=fs*pfinal/pinitial/6.*(pifactor*3.)
21582          endif
21583       endif
21584 c
21585 *     d omega: DETERMINE THE CROSS SECTION TO THIS FINAL STATE:
21586       if(srt.gt.(xmd+xmomega)) then
21587          pfinal=sqrt((s-(xmd+xmomega)**2)*(s-(xmd-xmomega)**2))/2./srt
21588          if(idxsec.eq.1) then
21589             sbbdomega=fs*pfinal/pinitial*3./16.
21590          elseif(idxsec.eq.2.or.idxsec.eq.4) then
21591             threshold=amax1(xmd+xmomega,em1+em2)
21592             snew=(srt-threshold+srt0)**2
21593             if(idxsec.eq.2) then
21594                sbbdomega=fnndpi(snew)*pfinal/pinitial*3./16.
21595             elseif(idxsec.eq.4) then
21596                sbbdomega=fnndpi(snew)*pfinal/pinitial/6.*pifactor
21597             endif
21598          elseif(idxsec.eq.3) then
21599             sbbdomega=fs*pfinal/pinitial/6.*pifactor
21600          endif
21601       endif
21602 c
21603 *     d eta: DETERMINE THE CROSS SECTION TO THIS FINAL STATE:
21604       if(srt.gt.(xmd+xmeta)) then
21605          pfinal=sqrt((s-(xmd+xmeta)**2)*(s-(xmd-xmeta)**2))/2./srt
21606          if(idxsec.eq.1) then
21607             sbbdeta=fs*pfinal/pinitial*3./16.
21608          elseif(idxsec.eq.2.or.idxsec.eq.4) then
21609             threshold=amax1(xmd+xmeta,em1+em2)
21610             snew=(srt-threshold+srt0)**2
21611             if(idxsec.eq.2) then
21612                sbbdeta=fnndpi(snew)*pfinal/pinitial*3./16.
21613             elseif(idxsec.eq.4) then
21614                sbbdeta=fnndpi(snew)*pfinal/pinitial/6.*(pifactor/3.)
21615             endif
21616          elseif(idxsec.eq.3) then
21617             sbbdeta=fs*pfinal/pinitial/6.*(pifactor/3.)
21618          endif
21619       endif
21620 c
21621       sdprod=sbbdpi+sbbdrho+sbbdomega+sbbdeta
21622 ctest off
21623 c      write(99,111) srt,sbbdpi,sbbdrho,sbbdomega,sbbdeta,sdprod
21624 c 111  format(6(f8.2,1x))
21625 c
21626       if(sdprod.le.0) return
21627 c
21628 c     choose final state and assign masses here:
21629       x1=RANART(NSEED)
21630       if(x1.le.sbbdpi/sdprod) then
21631 c     use the above-determined lbm and xmm.
21632       elseif(x1.le.(sbbdpi+sbbdrho)/sdprod) then
21633          lbm=25+int(3*RANART(NSEED))
21634          xmm=xmrho
21635       elseif(x1.le.(sbbdpi+sbbdrho+sbbdomega)/sdprod) then
21636          lbm=28
21637          xmm=xmomega
21638       else
21639          lbm=0
21640          xmm=xmeta
21641       endif
21642 c
21643       return
21644       end
21645 c
21646 c     Generate angular distribution of Deuteron in the CMS frame:
21647       subroutine bbdangle(pxd,pyd,pzd,nt,ipert1,ianti,idloop,pfinal,
21648      1 dprob1,lbm)
21649       PARAMETER (PI=3.1415926)
21650       common/leadng/lb1,px1,py1,pz1,em1,e1,xfnl,yfnl,zfnl,tfnl,
21651      1     px1n,py1n,pz1n,dp1n
21652       common /dpi/em2,lb2
21653       COMMON/RNDF77/NSEED
21654       common /para8/ idpert,npertd,idxsec
21655       COMMON /AREVT/ IAEVT, IARUN, MISS
21656       SAVE
21657 c     take isotropic distribution for now:
21658       C1=1.0-2.0*RANART(NSEED)
21659       T1=2.0*PI*RANART(NSEED)
21660       S1=SQRT(1.0-C1**2)
21661       CT1=COS(T1)
21662       ST1=SIN(T1)
21663 * THE MOMENTUM IN THE CMS IN THE FINAL STATE
21664       PZd=pfinal*C1
21665       PXd=pfinal*S1*CT1
21666       PYd=pfinal*S1*ST1
21667 clin-5/2008 track the number of produced deuterons:
21668       if(idpert.eq.1.and.npertd.ge.1) then
21669          dprob=dprob1
21670       elseif(idpert.eq.2.and.npertd.ge.1) then
21671          dprob=1./float(npertd)
21672       endif
21673 c      if(ianti.eq.0) then
21674 c         if(idpert.eq.0.or.(idpert.eq.1.and.ipert1.eq.0).or.
21675 c     1        (idpert.eq.2.and.idloop.eq.(npertd+1))) then
21676 c            write (91,*) lb1,' *',lb2,' ->d+',lbm,' (regular d prodn)
21677 c     1 @evt#',iaevt,' @nt=',nt
21678 c         elseif((idpert.eq.1.or.idpert.eq.2).and.idloop.eq.npertd) then
21679 c            write (91,*) lb1,' *',lb2,' ->d+',lbm,' (pert d prodn)
21680 c     1 @evt#',iaevt,' @nt=',nt,' @prob=',dprob
21681 c         endif
21682 c      else
21683 c         if(idpert.eq.0.or.(idpert.eq.1.and.ipert1.eq.0).or.
21684 c     1        (idpert.eq.2.and.idloop.eq.(npertd+1))) then
21685 c            write (91,*) lb1,' *',lb2,' ->d+',lbm,' (regular dbar prodn)
21686 c     1 @evt#',iaevt,' @nt=',nt
21687 c         elseif((idpert.eq.1.or.idpert.eq.2).and.idloop.eq.npertd) then
21688 c            write (91,*) lb1,' *',lb2,' ->d+',lbm,' (pert dbar prodn)
21689 c     1 @evt#',iaevt,' @nt=',nt,' @prob=',dprob
21690 c         endif
21691 c      endif
21692 c
21693       return
21694       end
21695 c
21696 c     Deuteron+Meson->B+B cross section (in mb)
21697       subroutine sdmbb(SRT,sdm,ianti)
21698       PARAMETER (AMN=0.939457,AMP=0.93828,
21699      1     AM0=1.232,AM1440=1.44,AM1535=1.535,srt0=2.012)
21700       common/leadng/lb1,px1,py1,pz1,em1,e1,xfnl,yfnl,zfnl,tfnl,
21701      1     px1n,py1n,pz1n,dp1n
21702       common /dpi/em2,lb2
21703       common /dpifsl/lbnn1,lbnn2,lbnd1,lbnd2,lbns1,lbns2,lbnp1,lbnp2,
21704      1     lbdd1,lbdd2,lbds1,lbds2,lbdp1,lbdp2,lbss1,lbss2,
21705      2     lbsp1,lbsp2,lbpp1,lbpp2
21706       common /dpifsm/xmnn1,xmnn2,xmnd1,xmnd2,xmns1,xmns2,xmnp1,xmnp2,
21707      1     xmdd1,xmdd2,xmds1,xmds2,xmdp1,xmdp2,xmss1,xmss2,
21708      2     xmsp1,xmsp2,xmpp1,xmpp2
21709       common /dpisig/sdmel,sdmnn,sdmnd,sdmns,sdmnp,sdmdd,sdmds,sdmdp,
21710      1     sdmss,sdmsp,sdmpp
21711       common /para8/ idpert,npertd,idxsec
21712       COMMON/RNDF77/NSEED
21713       SAVE
21714 c
21715       sdm=0.
21716       sdmel=0.
21717       sdmnn=0.
21718       sdmnd=0.
21719       sdmns=0.
21720       sdmnp=0.
21721       sdmdd=0.
21722       sdmds=0.
21723       sdmdp=0.
21724       sdmss=0.
21725       sdmsp=0.
21726       sdmpp=0.
21727 ctest off check Xsec using fixed mass for resonances:
21728 c      if(lb1.ge.25.and.lb1.le.27) then
21729 c         em1=0.776
21730 c      elseif(lb1.eq.28) then
21731 c         em1=0.783
21732 c      elseif(lb1.eq.0) then
21733 c         em1=0.548
21734 c      endif
21735 c      if(lb2.ge.25.and.lb2.le.27) then
21736 c         em2=0.776
21737 c      elseif(lb2.eq.28) then
21738 c         em2=0.783
21739 c      elseif(lb2.eq.0) then
21740 c         em2=0.548
21741 c      endif
21742 c
21743       if(srt.le.(em1+em2)) return
21744       s=srt**2
21745       pinitial=sqrt((s-(em1+em2)**2)*(s-(em1-em2)**2))/2./srt
21746       fs=fnndpi(s)
21747 c     Determine isospin and spin factors for the ratio between
21748 c     Deuteron+Meson->BB and BB->Deuteron+Meson cross sections:
21749       if(idxsec.eq.1.or.idxsec.eq.2) then
21750 c     Assume B+B -> d+Meson has the same cross sections as N+N -> d+pi,
21751 c     then determine d+Meson -> B+B cross sections:
21752          if((lb1.ge.3.and.lb1.le.5).or.
21753      1        (lb2.ge.3.and.lb2.le.5)) then
21754             xnnfactor=8./9.
21755          elseif((lb1.ge.25.and.lb1.le.27).or.
21756      1           (lb2.ge.25.and.lb2.le.27)) then
21757             xnnfactor=8./27.
21758          elseif(lb1.eq.28.or.lb2.eq.28) then
21759             xnnfactor=8./9.
21760          elseif(lb1.eq.0.or.lb2.eq.0) then
21761             xnnfactor=8./3.
21762          endif
21763       else
21764 c     Assume d+Meson -> B+B has the same cross sections as d+pi -> N+N:
21765       endif
21766 clin-9/2008 For elastic collisions:
21767       if(idxsec.eq.1.or.idxsec.eq.3) then
21768 c     1/3: assume the same |matrix element|**2 (after averaging over initial
21769 c     spins and isospins) for d+Meson elastic at the same sqrt(s);
21770          sdmel=fdpiel(s)
21771       elseif(idxsec.eq.2.or.idxsec.eq.4) then
21772 c     2/4: assume the same |matrix element|**2 (after averaging over initial
21773 c     spins and isospins) for d+Meson elastic at the same sqrt(s)-threshold:
21774          threshold=em1+em2
21775          snew=(srt-threshold+srt0)**2
21776          sdmel=fdpiel(snew)
21777       endif
21778 c
21779 *     NN: DETERMINE THE CHARGE STATES OF PARTICLESIN THE FINAL STATE
21780       IF(((lb1.eq.5.or.lb2.eq.5.or.lb1.eq.27.or.lb2.eq.27)
21781      1     .and.ianti.eq.0).or.
21782      2     ((lb1.eq.3.or.lb2.eq.3.or.lb1.eq.25.or.lb2.eq.25)
21783      3     .and.ianti.eq.1))THEN
21784 *     (1) FOR Deuteron+(pi+,rho+) -> P+P or DeuteronBar+(pi-,rho-)-> PBar+PBar:
21785          lbnn1=1
21786          lbnn2=1
21787          xmnn1=amp
21788          xmnn2=amp
21789       ELSEIF(lb1.eq.3.or.lb2.eq.3.or.lb1.eq.26.or.lb2.eq.26
21790      1        .or.lb1.eq.28.or.lb2.eq.28.or.lb1.eq.0.or.lb2.eq.0)THEN
21791 *     (2) FOR Deuteron+(pi0,rho0,omega,eta) -> N+P
21792 *     or DeuteronBar+(pi0,rho0,omega,eta) ->NBar+PBar:
21793          lbnn1=2
21794          lbnn2=1
21795          xmnn1=amn
21796          xmnn2=amp
21797       ELSE
21798 *     (3) FOR Deuteron+(pi-,rho-) -> N+N or DeuteronBar+(pi+,rho+)-> NBar+NBar:
21799          lbnn1=2
21800          lbnn2=2
21801          xmnn1=amn
21802          xmnn2=amn
21803       ENDIF
21804       if(srt.gt.(xmnn1+xmnn2)) then
21805          pfinal=sqrt((s-(xmnn1+xmnn2)**2)*(s-(xmnn1-xmnn2)**2))/2./srt
21806          if(idxsec.eq.1) then
21807 c     1: assume the same |matrix element|**2 (after averaging over initial
21808 c     spins and isospins) for B+B -> deuteron+meson at the same sqrt(s);
21809             sdmnn=fs*pfinal/pinitial*3./16.*xnnfactor
21810          elseif(idxsec.eq.2.or.idxsec.eq.4) then
21811             threshold=amax1(xmnn1+xmnn2,em1+em2)
21812             snew=(srt-threshold+srt0)**2
21813             if(idxsec.eq.2) then
21814 c     2: assume the same |matrix element|**2 for B+B -> deuteron+meson
21815 c     at the same sqrt(s)-threshold:
21816                sdmnn=fnndpi(snew)*pfinal/pinitial*3./16.*xnnfactor
21817             elseif(idxsec.eq.4) then
21818 c     4: assume the same |matrix element|**2 for B+B <- deuteron+meson
21819 c     at the same sqrt(s)-threshold:
21820                sdmnn=fnndpi(snew)*pfinal/pinitial/6.
21821             endif
21822          elseif(idxsec.eq.3) then
21823 c     3: assume the same |matrix element|**2 for B+B <- deuteron+meson
21824 c     at the same sqrt(s):
21825             sdmnn=fs*pfinal/pinitial/6.
21826          endif
21827       endif
21828 c
21829 *     ND: DETERMINE THE CHARGE STATES OF PARTICLES IN THE FINAL STATE
21830       lbnd1=1+int(2*RANART(NSEED))
21831       lbnd2=6+int(4*RANART(NSEED))
21832       if(lbnd1.eq.1) then
21833          xmnd1=amp
21834       elseif(lbnd1.eq.2) then
21835          xmnd1=amn
21836       endif
21837       xmnd2=am0
21838       if(srt.gt.(xmnd1+xmnd2)) then
21839          pfinal=sqrt((s-(xmnd1+xmnd2)**2)*(s-(xmnd1-xmnd2)**2))/2./srt
21840          if(idxsec.eq.1) then
21841 c     The spin- and isospin-averaged factor is 8-times larger for ND:
21842             sdmnd=fs*pfinal/pinitial*3./16.*(xnnfactor*8.)
21843          elseif(idxsec.eq.2.or.idxsec.eq.4) then
21844             threshold=amax1(xmnd1+xmnd2,em1+em2)
21845             snew=(srt-threshold+srt0)**2
21846             if(idxsec.eq.2) then
21847                sdmnd=fnndpi(snew)*pfinal/pinitial*3./16.*(xnnfactor*8.)
21848             elseif(idxsec.eq.4) then
21849                sdmnd=fnndpi(snew)*pfinal/pinitial/6.
21850             endif
21851          elseif(idxsec.eq.3) then
21852             sdmnd=fs*pfinal/pinitial/6.
21853          endif
21854       endif
21855 c
21856 *     NS: DETERMINE THE CHARGE STATES OF PARTICLES IN THE FINAL STATE
21857       lbns1=1+int(2*RANART(NSEED))
21858       lbns2=10+int(2*RANART(NSEED))
21859       if(lbns1.eq.1) then
21860          xmns1=amp
21861       elseif(lbns1.eq.2) then
21862          xmns1=amn
21863       endif
21864       xmns2=am1440
21865       if(srt.gt.(xmns1+xmns2)) then
21866          pfinal=sqrt((s-(xmns1+xmns2)**2)*(s-(xmns1-xmns2)**2))/2./srt
21867          if(idxsec.eq.1) then
21868             sdmns=fs*pfinal/pinitial*3./16.*(xnnfactor*2.)
21869          elseif(idxsec.eq.2.or.idxsec.eq.4) then
21870             threshold=amax1(xmns1+xmns2,em1+em2)
21871             snew=(srt-threshold+srt0)**2
21872             if(idxsec.eq.2) then
21873                sdmns=fnndpi(snew)*pfinal/pinitial*3./16.*(xnnfactor*2.)
21874             elseif(idxsec.eq.4) then
21875                sdmns=fnndpi(snew)*pfinal/pinitial/6.
21876             endif
21877          elseif(idxsec.eq.3) then
21878             sdmns=fs*pfinal/pinitial/6.
21879          endif
21880       endif
21881 c
21882 *     NP: DETERMINE THE CHARGE STATES OF PARTICLES IN THE FINAL STATE
21883       lbnp1=1+int(2*RANART(NSEED))
21884       lbnp2=12+int(2*RANART(NSEED))
21885       if(lbnp1.eq.1) then
21886          xmnp1=amp
21887       elseif(lbnp1.eq.2) then
21888          xmnp1=amn
21889       endif
21890       xmnp2=am1535
21891       if(srt.gt.(xmnp1+xmnp2)) then
21892          pfinal=sqrt((s-(xmnp1+xmnp2)**2)*(s-(xmnp1-xmnp2)**2))/2./srt
21893          if(idxsec.eq.1) then
21894             sdmnp=fs*pfinal/pinitial*3./16.*(xnnfactor*2.)
21895          elseif(idxsec.eq.2.or.idxsec.eq.4) then
21896             threshold=amax1(xmnp1+xmnp2,em1+em2)
21897             snew=(srt-threshold+srt0)**2
21898             if(idxsec.eq.2) then
21899                sdmnp=fnndpi(snew)*pfinal/pinitial*3./16.*(xnnfactor*2.)
21900             elseif(idxsec.eq.4) then
21901                sdmnp=fnndpi(snew)*pfinal/pinitial/6.
21902             endif
21903          elseif(idxsec.eq.3) then
21904             sdmnp=fs*pfinal/pinitial/6.
21905          endif
21906       endif
21907 c
21908 *     DD: DETERMINE THE CHARGE STATES OF PARTICLES IN THE FINAL STATE
21909       lbdd1=6+int(4*RANART(NSEED))
21910       lbdd2=6+int(4*RANART(NSEED))
21911       xmdd1=am0
21912       xmdd2=am0
21913       if(srt.gt.(xmdd1+xmdd2)) then
21914          pfinal=sqrt((s-(xmdd1+xmdd2)**2)*(s-(xmdd1-xmdd2)**2))/2./srt
21915          if(idxsec.eq.1) then
21916             sdmdd=fs*pfinal/pinitial*3./16.*(xnnfactor*16.)
21917          elseif(idxsec.eq.2.or.idxsec.eq.4) then
21918             threshold=amax1(xmdd1+xmdd2,em1+em2)
21919             snew=(srt-threshold+srt0)**2
21920             if(idxsec.eq.2) then
21921                sdmdd=fnndpi(snew)*pfinal/pinitial*3./16.*(xnnfactor*16.)
21922             elseif(idxsec.eq.4) then
21923                sdmdd=fnndpi(snew)*pfinal/pinitial/6.
21924             endif
21925          elseif(idxsec.eq.3) then
21926             sdmdd=fs*pfinal/pinitial/6.
21927          endif
21928       endif
21929 c
21930 *     DS: DETERMINE THE CHARGE STATES OF PARTICLES IN THE FINAL STATE
21931       lbds1=6+int(4*RANART(NSEED))
21932       lbds2=10+int(2*RANART(NSEED))
21933       xmds1=am0
21934       xmds2=am1440
21935       if(srt.gt.(xmds1+xmds2)) then
21936          pfinal=sqrt((s-(xmds1+xmds2)**2)*(s-(xmds1-xmds2)**2))/2./srt
21937          if(idxsec.eq.1) then
21938             sdmds=fs*pfinal/pinitial*3./16.*(xnnfactor*8.)
21939          elseif(idxsec.eq.2.or.idxsec.eq.4) then
21940             threshold=amax1(xmds1+xmds2,em1+em2)
21941             snew=(srt-threshold+srt0)**2
21942             if(idxsec.eq.2) then
21943                sdmds=fnndpi(snew)*pfinal/pinitial*3./16.*(xnnfactor*8.)
21944             elseif(idxsec.eq.4) then
21945                sdmds=fnndpi(snew)*pfinal/pinitial/6.
21946             endif
21947          elseif(idxsec.eq.3) then
21948             sdmds=fs*pfinal/pinitial/6.
21949          endif
21950       endif
21951 c
21952 *     DP: DETERMINE THE CHARGE STATES OF PARTICLES IN THE FINAL STATE
21953       lbdp1=6+int(4*RANART(NSEED))
21954       lbdp2=12+int(2*RANART(NSEED))
21955       xmdp1=am0
21956       xmdp2=am1535
21957       if(srt.gt.(xmdp1+xmdp2)) then
21958          pfinal=sqrt((s-(xmdp1+xmdp2)**2)*(s-(xmdp1-xmdp2)**2))/2./srt
21959          if(idxsec.eq.1) then
21960             sdmdp=fs*pfinal/pinitial*3./16.*(xnnfactor*8.)
21961          elseif(idxsec.eq.2.or.idxsec.eq.4) then
21962             threshold=amax1(xmdp1+xmdp2,em1+em2)
21963             snew=(srt-threshold+srt0)**2
21964             if(idxsec.eq.2) then
21965                sdmdp=fnndpi(snew)*pfinal/pinitial*3./16.*(xnnfactor*8.)
21966             elseif(idxsec.eq.4) then
21967                sdmdp=fnndpi(snew)*pfinal/pinitial/6.
21968             endif
21969          elseif(idxsec.eq.3) then
21970             sdmdp=fs*pfinal/pinitial/6.
21971          endif
21972       endif
21973 c
21974 *     SS: DETERMINE THE CHARGE STATES OF PARTICLES IN THE FINAL STATE
21975       lbss1=10+int(2*RANART(NSEED))
21976       lbss2=10+int(2*RANART(NSEED))
21977       xmss1=am1440
21978       xmss2=am1440
21979       if(srt.gt.(xmss1+xmss2)) then
21980          pfinal=sqrt((s-(xmss1+xmss2)**2)*(s-(xmss1-xmss2)**2))/2./srt
21981          if(idxsec.eq.1) then
21982             sdmss=fs*pfinal/pinitial*3./16.*xnnfactor
21983          elseif(idxsec.eq.2.or.idxsec.eq.4) then
21984             threshold=amax1(xmss1+xmss2,em1+em2)
21985             snew=(srt-threshold+srt0)**2
21986             if(idxsec.eq.2) then
21987                sdmss=fnndpi(snew)*pfinal/pinitial*3./16.*xnnfactor
21988             elseif(idxsec.eq.4) then
21989                sdmss=fnndpi(snew)*pfinal/pinitial/6.
21990             endif
21991          elseif(idxsec.eq.3) then
21992             sdmns=fs*pfinal/pinitial/6.
21993          endif
21994       endif
21995 c
21996 *     SP: DETERMINE THE CHARGE STATES OF PARTICLES IN THE FINAL STATE
21997       lbsp1=10+int(2*RANART(NSEED))
21998       lbsp2=12+int(2*RANART(NSEED))
21999       xmsp1=am1440
22000       xmsp2=am1535
22001       if(srt.gt.(xmsp1+xmsp2)) then
22002          pfinal=sqrt((s-(xmsp1+xmsp2)**2)*(s-(xmsp1-xmsp2)**2))/2./srt
22003          if(idxsec.eq.1) then
22004             sdmsp=fs*pfinal/pinitial*3./16.*(xnnfactor*2.)
22005          elseif(idxsec.eq.2.or.idxsec.eq.4) then
22006             threshold=amax1(xmsp1+xmsp2,em1+em2)
22007             snew=(srt-threshold+srt0)**2
22008             if(idxsec.eq.2) then
22009                sdmsp=fnndpi(snew)*pfinal/pinitial*3./16.*(xnnfactor*2.)
22010             elseif(idxsec.eq.4) then
22011                sdmsp=fnndpi(snew)*pfinal/pinitial/6.
22012             endif
22013          elseif(idxsec.eq.3) then
22014             sdmsp=fs*pfinal/pinitial/6.
22015          endif
22016       endif
22017 c
22018 *     PP: DETERMINE THE CHARGE STATES OF PARTICLES IN THE FINAL STATE
22019       lbpp1=12+int(2*RANART(NSEED))
22020       lbpp2=12+int(2*RANART(NSEED))
22021       xmpp1=am1535
22022       xmpp2=am1535
22023       if(srt.gt.(xmpp1+xmpp2)) then
22024          pfinal=sqrt((s-(xmpp1+xmpp2)**2)*(s-(xmpp1-xmpp2)**2))/2./srt
22025          if(idxsec.eq.1) then
22026             sdmpp=fs*pfinal/pinitial*3./16.*xnnfactor
22027          elseif(idxsec.eq.2.or.idxsec.eq.4) then
22028             threshold=amax1(xmpp1+xmpp2,em1+em2)
22029             snew=(srt-threshold+srt0)**2
22030             if(idxsec.eq.2) then
22031                sdmpp=fnndpi(snew)*pfinal/pinitial*3./16.*xnnfactor
22032             elseif(idxsec.eq.4) then
22033                sdmpp=fnndpi(snew)*pfinal/pinitial/6.
22034             endif
22035          elseif(idxsec.eq.3) then
22036             sdmpp=fs*pfinal/pinitial/6.
22037          endif
22038       endif
22039 c
22040       sdm=sdmel+sdmnn+sdmnd+sdmns+sdmnp+sdmdd+sdmds+sdmdp
22041      1     +sdmss+sdmsp+sdmpp
22042       if(ianti.eq.1) then
22043          lbnn1=-lbnn1
22044          lbnn2=-lbnn2
22045          lbnd1=-lbnd1
22046          lbnd2=-lbnd2
22047          lbns1=-lbns1
22048          lbns2=-lbns2
22049          lbnp1=-lbnp1
22050          lbnp2=-lbnp2
22051          lbdd1=-lbdd1
22052          lbdd2=-lbdd2
22053          lbds1=-lbds1
22054          lbds2=-lbds2
22055          lbdp1=-lbdp1
22056          lbdp2=-lbdp2
22057          lbss1=-lbss1
22058          lbss2=-lbss2
22059          lbsp1=-lbsp1
22060          lbsp2=-lbsp2
22061          lbpp1=-lbpp1
22062          lbpp2=-lbpp2
22063       endif
22064 ctest off
22065 c      write(98,100) srt,sdmnn,sdmnd,sdmns,sdmnp,sdmdd,sdmds,sdmdp,
22066 c     1     sdmss,sdmsp,sdmpp,sdm
22067 c 100  format(f5.2,11(1x,f5.1))
22068 c
22069       return
22070       end
22071 c
22072 clin-9/2008 Deuteron+Meson ->B+B and elastic collisions
22073       SUBROUTINE crdmbb(PX,PY,PZ,SRT,I1,I2,IBLOCK,
22074      1     NTAG,sig,NT,ianti)
22075       PARAMETER (MAXSTR=150001,MAXR=1)
22076       COMMON /AA/R(3,MAXSTR)
22077       COMMON /BB/ P(3,MAXSTR)
22078       COMMON /BG/BETAX,BETAY,BETAZ,GAMMA
22079       COMMON /CC/ E(MAXSTR)
22080       COMMON /EE/ ID(MAXSTR),LB(MAXSTR)
22081       COMMON /AREVT/ IAEVT, IARUN, MISS
22082       common/leadng/lb1,px1,py1,pz1,em1,e1,xfnl,yfnl,zfnl,tfnl,
22083      1     px1n,py1n,pz1n,dp1n
22084       common /dpi/em2,lb2
22085       common /para8/ idpert,npertd,idxsec
22086       COMMON /dpert/dpertt(MAXSTR,MAXR),dpertp(MAXSTR),dplast(MAXSTR),
22087      1     dpdcy(MAXSTR),dpdpi(MAXSTR,MAXR),dpt(MAXSTR, MAXR),
22088      2     dpp1(MAXSTR,MAXR),dppion(MAXSTR,MAXR)
22089       common /dpifsl/lbnn1,lbnn2,lbnd1,lbnd2,lbns1,lbns2,lbnp1,lbnp2,
22090      1     lbdd1,lbdd2,lbds1,lbds2,lbdp1,lbdp2,lbss1,lbss2,
22091      2     lbsp1,lbsp2,lbpp1,lbpp2
22092       common /dpifsm/xmnn1,xmnn2,xmnd1,xmnd2,xmns1,xmns2,xmnp1,xmnp2,
22093      1     xmdd1,xmdd2,xmds1,xmds2,xmdp1,xmdp2,xmss1,xmss2,
22094      2     xmsp1,xmsp2,xmpp1,xmpp2
22095       common /dpisig/sdmel,sdmnn,sdmnd,sdmns,sdmnp,sdmdd,sdmds,sdmdp,
22096      1     sdmss,sdmsp,sdmpp
22097       COMMON/RNDF77/NSEED
22098       SAVE
22099 *-----------------------------------------------------------------------
22100       IBLOCK=0
22101       NTAG=0
22102       EM1=E(I1)
22103       EM2=E(I2)
22104       s=srt**2
22105       if(sig.le.0) return
22106 c
22107       if(iabs(lb1).eq.42) then
22108          ideut=i1
22109          lbm=lb2
22110          idm=i2
22111       else
22112          ideut=i2
22113          lbm=lb1
22114          idm=i1
22115       endif
22116 cccc  Elastic collision or destruction of perturbatively-produced deuterons:
22117       if((idpert.eq.1.or.idpert.eq.2).and.dpertp(ideut).ne.1.) then
22118 c     choose reaction channels:
22119          x1=RANART(NSEED)
22120          if(x1.le.sdmel/sig)then
22121 c     Elastic collisions:
22122 c            if(ianti.eq.0) then
22123 c               write(91,*) '  d+',lbm,' (pert d M elastic) @nt=',nt
22124 c     1              ,' @prob=',dpertp(ideut)
22125 c            else
22126 c               write(91,*) '  d+',lbm,' (pert dbar M elastic) @nt=',nt
22127 c     1              ,' @prob=',dpertp(ideut)
22128 c            endif
22129             pfinal=sqrt((s-(em1+em2)**2)*(s-(em1-em2)**2))/2./srt
22130             CALL dmelangle(pxn,pyn,pzn,pfinal)
22131             CALL ROTATE(PX,PY,PZ,Pxn,Pyn,Pzn)
22132             EdCM=SQRT(E(ideut)**2+Pxn**2+Pyn**2+Pzn**2)
22133             PdBETA=Pxn*BETAX+Pyn*BETAY+Pzn*BETAZ
22134             TRANSF=GAMMA*(GAMMA*PdBETA/(GAMMA+1.)+EdCM)
22135             Pt1d=BETAX*TRANSF+Pxn
22136             Pt2d=BETAY*TRANSF+Pyn
22137             Pt3d=BETAZ*TRANSF+Pzn
22138             p(1,ideut)=pt1d
22139             p(2,ideut)=pt2d
22140             p(3,ideut)=pt3d
22141             IBLOCK=504
22142             PX1=P(1,I1)
22143             PY1=P(2,I1)
22144             PZ1=P(3,I1)
22145             ID(I1)=2
22146             ID(I2)=2
22147 c     Change the position of the perturbative deuteron to that of
22148 c     the meson to avoid consecutive collisions between them:
22149             R(1,ideut)=R(1,idm)
22150             R(2,ideut)=R(2,idm)
22151             R(3,ideut)=R(3,idm)
22152          else
22153 c     Destruction of deuterons:
22154 c            if(ianti.eq.0) then
22155 c               write(91,*) '  d+',lbm,' ->BB (pert d destrn) @nt=',nt
22156 c     1              ,' @prob=',dpertp(ideut)
22157 c            else
22158 c               write(91,*) '  d+',lbm,' ->BB (pert dbar destrn) @nt=',nt
22159 c     1              ,' @prob=',dpertp(ideut)
22160 c            endif
22161             e(ideut)=0.
22162             IBLOCK=502
22163          endif
22164          return
22165       endif
22166 c
22167 cccc  Destruction of regularly-produced deuterons:
22168       IBLOCK=502
22169 c     choose final state and assign masses here:
22170       x1=RANART(NSEED)
22171       if(x1.le.sdmnn/sig)then
22172          lbb1=lbnn1
22173          lbb2=lbnn2
22174          xmb1=xmnn1
22175          xmb2=xmnn2
22176       elseif(x1.le.(sdmnn+sdmnd)/sig)then
22177          lbb1=lbnd1
22178          lbb2=lbnd2
22179          xmb1=xmnd1
22180          xmb2=xmnd2
22181       elseif(x1.le.(sdmnn+sdmnd+sdmns)/sig)then
22182          lbb1=lbns1
22183          lbb2=lbns2
22184          xmb1=xmns1
22185          xmb2=xmns2
22186       elseif(x1.le.(sdmnn+sdmnd+sdmns+sdmnp)/sig)then
22187          lbb1=lbnp1
22188          lbb2=lbnp2
22189          xmb1=xmnp1
22190          xmb2=xmnp2
22191       elseif(x1.le.(sdmnn+sdmnd+sdmns+sdmnp+sdmdd)/sig)then
22192          lbb1=lbdd1
22193          lbb2=lbdd2
22194          xmb1=xmdd1
22195          xmb2=xmdd2
22196       elseif(x1.le.(sdmnn+sdmnd+sdmns+sdmnp+sdmdd+sdmds)/sig)then
22197          lbb1=lbds1
22198          lbb2=lbds2
22199          xmb1=xmds1
22200          xmb2=xmds2
22201       elseif(x1.le.(sdmnn+sdmnd+sdmns+sdmnp+sdmdd+sdmds+sdmdp)/sig)then
22202          lbb1=lbdp1
22203          lbb2=lbdp2
22204          xmb1=xmdp1
22205          xmb2=xmdp2
22206       elseif(x1.le.(sdmnn+sdmnd+sdmns+sdmnp+sdmdd+sdmds+sdmdp
22207      1        +sdmss)/sig)then
22208          lbb1=lbss1
22209          lbb2=lbss2
22210          xmb1=xmss1
22211          xmb2=xmss2
22212       elseif(x1.le.(sdmnn+sdmnd+sdmns+sdmnp+sdmdd+sdmds+sdmdp
22213      1        +sdmss+sdmsp)/sig)then
22214          lbb1=lbsp1
22215          lbb2=lbsp2
22216          xmb1=xmsp1
22217          xmb2=xmsp2
22218       elseif(x1.le.(sdmnn+sdmnd+sdmns+sdmnp+sdmdd+sdmds+sdmdp
22219      1        +sdmss+sdmsp+sdmpp)/sig)then
22220          lbb1=lbpp1
22221          lbb2=lbpp2
22222          xmb1=xmpp1
22223          xmb2=xmpp2
22224       else
22225 c     Elastic collision:
22226          lbb1=lb1
22227          lbb2=lb2
22228          xmb1=em1
22229          xmb2=em2
22230          IBLOCK=504
22231       endif
22232       LB(I1)=lbb1
22233       E(i1)=xmb1
22234       LB(I2)=lbb2
22235       E(I2)=xmb2
22236       lb1=lb(i1)
22237       lb2=lb(i2)
22238       pfinal=sqrt((s-(xmb1+xmb2)**2)*(s-(xmb1-xmb2)**2))/2./srt
22239 c
22240       if(iblock.eq.502) then
22241          CALL dmangle(pxn,pyn,pzn,nt,ianti,pfinal,lbm)
22242       elseif(iblock.eq.504) then
22243 c         if(ianti.eq.0) then
22244 c            write (91,*) ' d+',lbm,' (regular d M elastic) @evt#',
22245 c     1           iaevt,' @nt=',nt,' lb1,2=',lb1,lb2
22246 c         else
22247 c            write (91,*) ' d+',lbm,' (regular dbar M elastic) @evt#',
22248 c     1           iaevt,' @nt=',nt,' lb1,2=',lb1,lb2
22249 c         endif
22250          CALL dmelangle(pxn,pyn,pzn,pfinal)
22251       else
22252          print *, 'Wrong iblock number in crdmbb()'
22253          stop
22254       endif
22255 *     ROTATE THE MOMENTA OF PARTICLES IN THE CMS OF P1+P2
22256 c     (This is not needed for isotropic distributions)
22257       CALL ROTATE(PX,PY,PZ,Pxn,Pyn,Pzn)
22258 *     LORENTZ-TRANSFORMATION OF THE MOMENTUM OF PARTICLES IN THE FINAL STATE
22259 *     FROM THE NUCLEUS-NUCLEUS CMS. FRAME INTO LAB FRAME:
22260 *     For the 1st baryon:
22261       E1CM=SQRT(E(I1)**2+Pxn**2+Pyn**2+Pzn**2)
22262       P1BETA=Pxn*BETAX+Pyn*BETAY+Pzn*BETAZ
22263       TRANSF=GAMMA*(GAMMA*P1BETA/(GAMMA+1.)+E1CM)
22264       Pt1i1=BETAX*TRANSF+Pxn
22265       Pt2i1=BETAY*TRANSF+Pyn
22266       Pt3i1=BETAZ*TRANSF+Pzn
22267 c
22268       p(1,i1)=pt1i1
22269       p(2,i1)=pt2i1
22270       p(3,i1)=pt3i1
22271 *     For the 2nd baryon:
22272       E2CM=SQRT(E(I2)**2+Pxn**2+Pyn**2+Pzn**2)
22273       P2BETA=-Pxn*BETAX-Pyn*BETAY-Pzn*BETAZ
22274       TRANSF=GAMMA*(GAMMA*P2BETA/(GAMMA+1.)+E2CM)
22275       Pt1I2=BETAX*TRANSF-Pxn
22276       Pt2I2=BETAY*TRANSF-Pyn
22277       Pt3I2=BETAZ*TRANSF-Pzn
22278 c
22279       p(1,i2)=pt1i2
22280       p(2,i2)=pt2i2
22281       p(3,i2)=pt3i2
22282 c
22283       PX1=P(1,I1)
22284       PY1=P(2,I1)
22285       PZ1=P(3,I1)
22286       EM1=E(I1)
22287       EM2=E(I2)
22288       ID(I1)=2
22289       ID(I2)=2
22290       RETURN
22291       END
22292 c
22293 c     Generate angular distribution of BB from d+meson in the CMS frame:
22294       subroutine dmangle(pxn,pyn,pzn,nt,ianti,pfinal,lbm)
22295       PARAMETER (PI=3.1415926)
22296       common/leadng/lb1,px1,py1,pz1,em1,e1,xfnl,yfnl,zfnl,tfnl,
22297      1     px1n,py1n,pz1n,dp1n
22298       common /dpi/em2,lb2
22299       COMMON /AREVT/ IAEVT, IARUN, MISS
22300       COMMON/RNDF77/NSEED
22301       SAVE
22302 c     take isotropic distribution for now:
22303       C1=1.0-2.0*RANART(NSEED)
22304       T1=2.0*PI*RANART(NSEED)
22305       S1=SQRT(1.0-C1**2)
22306       CT1=COS(T1)
22307       ST1=SIN(T1)
22308 * THE MOMENTUM IN THE CMS IN THE FINAL STATE
22309       Pzn=pfinal*C1
22310       Pxn=pfinal*S1*CT1
22311       Pyn=pfinal*S1*ST1
22312 clin-5/2008 track the number of regularly-destructed deuterons:
22313 c      if(ianti.eq.0) then
22314 c         write (91,*) ' d+',lbm,' ->BB (regular d destrn) @evt#',
22315 c     1        iaevt,' @nt=',nt,' lb1,2=',lb1,lb2
22316 c      else
22317 c         write (91,*) ' d+',lbm,' ->BB (regular dbar destrn) @evt#',
22318 c     1        iaevt,' @nt=',nt,' lb1,2=',lb1,lb2
22319 c      endif
22320 c
22321       return
22322       end
22323 c
22324 c     Angular distribution of d+meson elastic collisions in the CMS frame:
22325       subroutine dmelangle(pxn,pyn,pzn,pfinal)
22326       PARAMETER (PI=3.1415926)
22327       COMMON/RNDF77/NSEED
22328       SAVE
22329 c     take isotropic distribution for now:
22330       C1=1.0-2.0*RANART(NSEED)
22331       T1=2.0*PI*RANART(NSEED)
22332       S1=SQRT(1.0-C1**2)
22333       CT1=COS(T1)
22334       ST1=SIN(T1)
22335 * THE MOMENTUM IN THE CMS IN THE FINAL STATE
22336       Pzn=pfinal*C1
22337       Pxn=pfinal*S1*CT1
22338       Pyn=pfinal*S1*ST1
22339       return
22340       end
22341 c
22342 clin-9/2008 Deuteron+Baryon elastic cross section (in mb)
22343       subroutine sdbelastic(SRT,sdb)
22344       PARAMETER (srt0=2.012)
22345       common/leadng/lb1,px1,py1,pz1,em1,e1,xfnl,yfnl,zfnl,tfnl,
22346      1     px1n,py1n,pz1n,dp1n
22347       common /dpi/em2,lb2
22348       common /para8/ idpert,npertd,idxsec
22349       SAVE
22350 c
22351       sdb=0.
22352       sdbel=0.
22353       if(srt.le.(em1+em2)) return
22354       s=srt**2
22355 c     For elastic collisions:
22356       if(idxsec.eq.1.or.idxsec.eq.3) then
22357 c     1/3: assume the same |matrix element|**2 (after averaging over initial
22358 c     spins and isospins) for d+Baryon elastic at the same sqrt(s);
22359          sdbel=fdbel(s)
22360       elseif(idxsec.eq.2.or.idxsec.eq.4) then
22361 c     2/4: assume the same |matrix element|**2 (after averaging over initial
22362 c     spins and isospins) for d+Baryon elastic at the same sqrt(s)-threshold:
22363          threshold=em1+em2
22364          snew=(srt-threshold+srt0)**2
22365          sdbel=fdbel(snew)
22366       endif
22367       sdb=sdbel
22368       return
22369       end
22370 clin-9/2008 Deuteron+Baryon elastic collisions
22371       SUBROUTINE crdbel(PX,PY,PZ,SRT,I1,I2,IBLOCK,
22372      1     NTAG,sig,NT,ianti)
22373       PARAMETER (MAXSTR=150001,MAXR=1)
22374       COMMON /AA/R(3,MAXSTR)
22375       COMMON /BB/ P(3,MAXSTR)
22376       COMMON /BG/BETAX,BETAY,BETAZ,GAMMA
22377       COMMON /CC/ E(MAXSTR)
22378       COMMON /EE/ ID(MAXSTR),LB(MAXSTR)
22379       COMMON /AREVT/ IAEVT, IARUN, MISS
22380       common/leadng/lb1,px1,py1,pz1,em1,e1,xfnl,yfnl,zfnl,tfnl,
22381      1     px1n,py1n,pz1n,dp1n
22382       common /dpi/em2,lb2
22383       common /para8/ idpert,npertd,idxsec
22384       COMMON /dpert/dpertt(MAXSTR,MAXR),dpertp(MAXSTR),dplast(MAXSTR),
22385      1     dpdcy(MAXSTR),dpdpi(MAXSTR,MAXR),dpt(MAXSTR, MAXR),
22386      2     dpp1(MAXSTR,MAXR),dppion(MAXSTR,MAXR)
22387       SAVE
22388 *-----------------------------------------------------------------------
22389       IBLOCK=0
22390       NTAG=0
22391       EM1=E(I1)
22392       EM2=E(I2)
22393       s=srt**2
22394       if(sig.le.0) return
22395       IBLOCK=503
22396 c
22397       if(iabs(lb1).eq.42) then
22398          ideut=i1
22399          lbb=lb2
22400          idb=i2
22401       else
22402          ideut=i2
22403          lbb=lb1
22404          idb=i1
22405       endif
22406 cccc  Elastic collision of perturbatively-produced deuterons:
22407       if((idpert.eq.1.or.idpert.eq.2).and.dpertp(ideut).ne.1.) then
22408 c         if(ianti.eq.0) then
22409 c            write(91,*) '  d+',lbb,' (pert d B elastic) @nt=',nt
22410 c     1           ,' @prob=',dpertp(ideut),p(1,idb),p(2,idb)
22411 c     2           ,p(1,ideut),p(2,ideut)
22412 c         else
22413 c            write(91,*) '  d+',lbb,' (pert dbar Bbar elastic) @nt=',nt
22414 c     1           ,' @prob=',dpertp(ideut),p(1,idb),p(2,idb)
22415 c     2           ,p(1,ideut),p(2,ideut)
22416 c         endif
22417          pfinal=sqrt((s-(em1+em2)**2)*(s-(em1-em2)**2))/2./srt
22418          CALL dbelangle(pxn,pyn,pzn,pfinal)
22419          CALL ROTATE(PX,PY,PZ,Pxn,Pyn,Pzn)
22420          EdCM=SQRT(E(ideut)**2+Pxn**2+Pyn**2+Pzn**2)
22421          PdBETA=Pxn*BETAX+Pyn*BETAY+Pzn*BETAZ
22422          TRANSF=GAMMA*(GAMMA*PdBETA/(GAMMA+1.)+EdCM)
22423          Pt1d=BETAX*TRANSF+Pxn
22424          Pt2d=BETAY*TRANSF+Pyn
22425          Pt3d=BETAZ*TRANSF+Pzn
22426          p(1,ideut)=pt1d
22427          p(2,ideut)=pt2d
22428          p(3,ideut)=pt3d
22429          PX1=P(1,I1)
22430          PY1=P(2,I1)
22431          PZ1=P(3,I1)
22432          ID(I1)=2
22433          ID(I2)=2
22434 c     Change the position of the perturbative deuteron to that of
22435 c     the baryon to avoid consecutive collisions between them:
22436          R(1,ideut)=R(1,idb)
22437          R(2,ideut)=R(2,idb)
22438          R(3,ideut)=R(3,idb)
22439          return
22440       endif
22441 c
22442 c     Elastic collision of regularly-produced deuterons:
22443 c      if(ianti.eq.0) then
22444 c         write (91,*) ' d+',lbb,' (regular d B elastic) @evt#',
22445 c     1        iaevt,' @nt=',nt,' lb1,2=',lb1,lb2
22446 c      else
22447 c         write (91,*) ' d+',lbb,' (regular dbar Bbar elastic) @evt#',
22448 c     1        iaevt,' @nt=',nt,' lb1,2=',lb1,lb2
22449 c      endif
22450       pfinal=sqrt((s-(em1+em2)**2)*(s-(em1-em2)**2))/2./srt
22451       CALL dbelangle(pxn,pyn,pzn,pfinal)
22452 *     ROTATE THE MOMENTA OF PARTICLES IN THE CMS OF P1+P2
22453 c     (This is not needed for isotropic distributions)
22454       CALL ROTATE(PX,PY,PZ,Pxn,Pyn,Pzn)
22455 *     LORENTZ-TRANSFORMATION OF THE MOMENTUM OF PARTICLES IN THE FINAL STATE
22456 *     FROM THE NUCLEUS-NUCLEUS CMS. FRAME INTO LAB FRAME:
22457 *     For the 1st baryon:
22458       E1CM=SQRT(E(I1)**2+Pxn**2+Pyn**2+Pzn**2)
22459       P1BETA=Pxn*BETAX+Pyn*BETAY+Pzn*BETAZ
22460       TRANSF=GAMMA*(GAMMA*P1BETA/(GAMMA+1.)+E1CM)
22461       Pt1i1=BETAX*TRANSF+Pxn
22462       Pt2i1=BETAY*TRANSF+Pyn
22463       Pt3i1=BETAZ*TRANSF+Pzn
22464 c
22465       p(1,i1)=pt1i1
22466       p(2,i1)=pt2i1
22467       p(3,i1)=pt3i1
22468 *     For the 2nd baryon:
22469       E2CM=SQRT(E(I2)**2+Pxn**2+Pyn**2+Pzn**2)
22470       P2BETA=-Pxn*BETAX-Pyn*BETAY-Pzn*BETAZ
22471       TRANSF=GAMMA*(GAMMA*P2BETA/(GAMMA+1.)+E2CM)
22472       Pt1I2=BETAX*TRANSF-Pxn
22473       Pt2I2=BETAY*TRANSF-Pyn
22474       Pt3I2=BETAZ*TRANSF-Pzn
22475 c
22476       p(1,i2)=pt1i2
22477       p(2,i2)=pt2i2
22478       p(3,i2)=pt3i2
22479 c
22480       PX1=P(1,I1)
22481       PY1=P(2,I1)
22482       PZ1=P(3,I1)
22483       EM1=E(I1)
22484       EM2=E(I2)
22485       ID(I1)=2
22486       ID(I2)=2
22487       RETURN
22488       END
22489 c
22490 c     Part of the cross section function of NN->Deuteron+Pi (in mb):
22491       function fnndpi(s)
22492       parameter(srt0=2.012)
22493       if(s.le.srt0**2) then
22494          fnndpi=0.
22495       else
22496          fnndpi=26.*exp(-(s-4.65)**2/0.1)+4.*exp(-(s-4.65)**2/2.)
22497      1        +0.28*exp(-(s-6.)**2/10.)
22498       endif
22499       return
22500       end
22501 c
22502 c     Angular distribution of d+baryon elastic collisions in the CMS frame:
22503       subroutine dbelangle(pxn,pyn,pzn,pfinal)
22504       PARAMETER (PI=3.1415926)
22505       COMMON/RNDF77/NSEED
22506       SAVE
22507 c     take isotropic distribution for now:
22508       C1=1.0-2.0*RANART(NSEED)
22509       T1=2.0*PI*RANART(NSEED)
22510       S1=SQRT(1.0-C1**2)
22511       CT1=COS(T1)
22512       ST1=SIN(T1)
22513 * THE MOMENTUM IN THE CMS IN THE FINAL STATE
22514       Pzn=pfinal*C1
22515       Pxn=pfinal*S1*CT1
22516       Pyn=pfinal*S1*ST1
22517       return
22518       end
22519 c
22520 c     Cross section of Deuteron+Pi elastic (in mb):
22521       function fdpiel(s)
22522       parameter(srt0=2.012)
22523       if(s.le.srt0**2) then
22524          fdpiel=0.
22525       else
22526          fdpiel=63.*exp(-(s-4.67)**2/0.15)+15.*exp(-(s-6.25)**2/0.3)
22527       endif
22528       return
22529       end
22530 c
22531 c     Cross section of Deuteron+N elastic (in mb):
22532       function fdbel(s)
22533       parameter(srt0=2.012)
22534       if(s.le.srt0**2) then
22535          fdbel=0.
22536       else
22537          fdbel=2500.*exp(-(s-7.93)**2/0.003)
22538      1        +300.*exp(-(s-7.93)**2/0.1)+10.
22539       endif
22540       return
22541       end