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           else
1832              T0=0.19733/WID
1833              GFACTR=E1/EM1
1834              T0=T0*GFACTR
1835              IF(T0.GT.0.)THEN
1836                 PDECAY=1.-EXP(-DT/T0)
1837              ELSE
1838                 PDECAY=0.
1839              ENDIF
1840           endif
1841           XDECAY=RANART(NSEED)
1842
1843 cc dilepton production from rho0, omega, phi decay
1844 cc        if(lb1.eq.26 .or. lb1.eq.28 .or. lb1.eq.29)
1845 cc     &   call dec_ceres(nt,ntmax,irun,i1)
1846 cc
1847           IF(XDECAY.LT.PDECAY) THEN
1848 clin-10/25/02 get rid of argument usage mismatch in rhocay():
1849              idecay=irun
1850              tfnl=nt*dt
1851 clin-10/28/03 keep formation time of hadrons unformed at nt=ntmax-1:
1852              if(nt.eq.ntmax.and.ftsv(i1).gt.((ntmax-1)*dt))
1853      1            tfnl=ftsv(i1)
1854              xfnl=x1
1855              yfnl=y1
1856              zfnl=z1
1857 * use PYTHIA to perform decays of eta,rho,omega,phi,K*,(K0s) and Delta:
1858              if(lb1.eq.0.or.lb1.eq.25.or.lb1.eq.26.or.lb1.eq.27
1859      &           .or.lb1.eq.28.or.lb1.eq.29.or.iabs(lb1).eq.30
1860      &           .or.(iabs(lb1).ge.6.and.iabs(lb1).le.9)
1861      &           .or.(iksdcy.eq.1.and.lb1.eq.24)
1862      &           .or.iabs(lb1).eq.16) then
1863 c     previous rho decay performed in rhodecay():
1864 c                nnn=nnn+1
1865 c                call rhodecay(idecay,i1,nnn,iseed)
1866 c
1867 ctest off record decays of phi,K*,Lambda(1520) resonances:
1868 c                if(lb1.eq.29.or.iabs(lb1).eq.30)
1869 c     1               write(18,112) 'decay',lb1,px1,py1,pz1,am1,nt
1870                 call resdec(i1,nt,nnn,wid,idecay)
1871                 p(1,i1)=px1n
1872                 p(2,i1)=py1n
1873                 p(3,i1)=pz1n
1874 clin-5/2008:
1875                 dpertp(i1)=dp1n
1876 c     add decay time to freezeout positions & time at the last timestep:
1877                 if(nt.eq.ntmax) then
1878                    R(1,i1)=xfnl
1879                    R(2,i1)=yfnl
1880                    R(3,i1)=zfnl
1881                    tfdcy(i1)=tfnl
1882                 endif
1883 c
1884 * decay number for baryon resonance or L/S decay
1885                 if(iabs(lb1).ge.6.and.iabs(lb1).le.9) then
1886                    LDECAY=LDECAY+1
1887                 endif
1888
1889 * for a1 decay
1890 c             elseif(lb1.eq.32)then
1891 c                NNN=NNN+1
1892 c                call a1decay(idecay,i1,nnn,iseed,rhomp)
1893
1894 * FOR N*(1440)
1895              elseif(iabs(LB1).EQ.10.OR.iabs(LB1).EQ.11) THEN
1896                 NNN=NNN+1
1897                 LDECAY=LDECAY+1
1898                 PNSTAR=1.
1899                 IF(E(I1).GT.1.22)PNSTAR=0.6
1900                 IF(RANART(NSEED).LE.PNSTAR)THEN
1901 * (1) DECAY TO SINGLE PION+NUCLEON
1902                    CALL DECAY(idecay,I1,NNN,ISEED,wid,nt)
1903                 ELSE
1904 * (2) DECAY TO TWO PIONS + NUCLEON
1905                    CALL DECAY2(idecay,I1,NNN,ISEED,wid,nt)
1906                    NNN=NNN+1
1907                 ENDIF
1908 c for N*(1535) decay
1909              elseif(iabs(LB1).eq.12.or.iabs(LB1).eq.13) then
1910                 NNN=NNN+1
1911                 CALL DECAY(idecay,I1,NNN,ISEED,wid,nt)
1912                 LDECAY=LDECAY+1
1913              endif
1914 c
1915 *COM: AT HIGH ENERGIES WE USE VERY SHORT TIME STEPS,
1916 *     IN ORDER TO TAKE INTO ACCOUNT THE FINITE FORMATIOM TIME, WE
1917 *     DO NOT ALLOW PARTICLES FROM THE DECAY OF RESONANCE TO INTERACT
1918 *     WITH OTHERS IN THE SAME TIME STEP. CHANGE 9000 TO REVERSE THIS
1919 *     ASSUMPTION. EFFECTS OF THIS ASSUMPTION CAN BE STUDIED BY CHANGING
1920 *     THE STATEMENT OF 9000. See notebook for discussions on effects of
1921 *     changing statement 9000.
1922 c
1923 c     kaons from K* decay are converted to k0short (and k0long),
1924 c     phi decay may produce rho, K0S or eta, N*(1535) decay may produce eta,
1925 c     and these decay daughters need to decay again if at the last timestep:
1926 c     (note: these daughters have been assigned to lb(i1) only, not to lpion)
1927 c             if(nt.eq.ntmax.and.(lb1.eq.29.or.iabs(lb1).eq.30
1928 c     1            .iabs(lb1).eq.12.or.iabs(lb1).eq.13)) then
1929              if(nt.eq.ntmax) then
1930                 if(lb(i1).eq.25.or.lb(i1).eq.26.or.lb(i1).eq.27) then
1931                    wid=0.151
1932                 elseif(lb(i1).eq.0) then
1933                    wid=1.18e-6
1934                 elseif(lb(i1).eq.24.and.iksdcy.eq.1) then
1935                    wid=7.36e-17
1936                 else
1937                    goto 9000
1938                 endif
1939                 LB1=LB(I1)
1940                 PX1=P(1,I1)
1941                 PY1=P(2,I1)
1942                 PZ1=P(3,I1)
1943                 EM1=E(I1)
1944                 E1=SQRT(EM1**2+PX1**2+PY1**2+PZ1**2)
1945                 call resdec(i1,nt,nnn,wid,idecay)
1946                 p(1,i1)=px1n
1947                 p(2,i1)=py1n
1948                 p(3,i1)=pz1n
1949                 R(1,i1)=xfnl
1950                 R(2,i1)=yfnl
1951                 R(3,i1)=zfnl
1952                 tfdcy(i1)=tfnl
1953 clin-5/2008:
1954                 dpertp(i1)=dp1n
1955              endif
1956
1957 * negelecting the Pauli blocking at high energies
1958  9000        go to 800
1959           ENDIF
1960 * LOOP OVER ALL PSEUDOPARTICLES 2 IN THE SAME RUN
1961 * SAVE ALL THE COORDINATES FOR POSSIBLE CHANGE IN THE FOLLOWING COLLISION
1962  1        if(nt.eq.ntmax)go to 800
1963           X1 = R(1,I1)
1964           Y1 = R(2,I1)
1965           Z1 = R(3,I1)
1966 c
1967            DO 600 J2 = 1,J1-1
1968             I2  = J2 + MSUM
1969 * IF I2 IS A MESON BEING ABSORBED, THEN GO OUT OF THE LOOP
1970             IF(E(I2).EQ.0.) GO TO 600
1971 clin-5/2008 in case the first particle is already destroyed:
1972             IF(E(I1).EQ.0.) GO TO 800
1973             IF (LB(I2) .LT. -45 .OR. LB(I2) .GT. 45) GOTO 600
1974 clin-7/26/03 improve speed
1975             X2=R(1,I2)
1976             Y2=R(2,I2)
1977             Z2=R(3,I2)
1978             dr0max=5.
1979 clin-9/2008 deuteron+nucleon elastic cross sections could reach ~2810mb:
1980             ilb1=iabs(LB(I1))
1981             ilb2=iabs(LB(I2))
1982             IF(ilb1.EQ.42.or.ilb2.EQ.42) THEN
1983                if((ILB1.GE.1.AND.ILB1.LE.2)
1984      1              .or.(ILB1.GE.6.AND.ILB1.LE.13)
1985      2              .or.(ILB2.GE.1.AND.ILB2.LE.2)
1986      3              .or.(ILB2.GE.6.AND.ILB2.LE.13)) then
1987                   if((lb(i1)*lb(i2)).gt.0) dr0max=10.
1988                endif
1989             ENDIF
1990 c
1991             if(((X1-X2)**2+(Y1-Y2)**2+(Z1-Z2)**2).GT.dr0max**2)
1992      1           GO TO 600
1993             IF (ID(I1)*ID(I2).EQ.IAVOID) GOTO 400
1994             ID1=ID(I1)
1995             ID2 = ID(I2)
1996 c
1997             ix1= nint(x1/dx)
1998             iy1= nint(y1/dy)
1999             iz1= nint(z1/dz)
2000             PX1=P(1,I1)
2001             PY1=P(2,I1)
2002             PZ1=P(3,I1)
2003             EM1=E(I1)
2004             AM1=EM1
2005             LB1=LB(I1)
2006             E1=SQRT(EM1**2+PX1**2+PY1**2+PZ1**2)
2007             IPX1=NINT(PX1/DPX)
2008             IPY1=NINT(PY1/DPY)
2009             IPZ1=NINT(PZ1/DPZ)
2010             LB2 = LB(I2)
2011             PX2 = P(1,I2)
2012             PY2 = P(2,I2)
2013             PZ2 = P(3,I2)
2014             EM2=E(I2)
2015             AM2=EM2
2016             lb1i=lb(i1)
2017             lb2i=lb(i2)
2018             px1i=P(1,I1)
2019             py1i=P(2,I1)
2020             pz1i=P(3,I1)
2021             em1i=E(I1)
2022             px2i=P(1,I2)
2023             py2i=P(2,I2)
2024             pz2i=P(3,I2)
2025             em2i=E(I2)
2026 clin-2/26/03 ctest off check energy conservation after each binary search:
2027             eini=SQRT(E(I1)**2+P(1,I1)**2+P(2,I1)**2+P(3,I1)**2)
2028      1           +SQRT(E(I2)**2+P(1,I2)**2+P(2,I2)**2+P(3,I2)**2)
2029             pxini=P(1,I1)+P(1,I2)
2030             pyini=P(2,I1)+P(2,I2)
2031             pzini=P(3,I1)+P(3,I2)
2032             nnnini=nnn
2033 c
2034 clin-4/30/03 initialize value:
2035             iblock=0
2036 c
2037 * TO SAVE COMPUTING TIME we do the following
2038 * (1) make a ROUGH estimate to see whether particle i2 will collide with
2039 * particle I1, and (2) skip the particle pairs for which collisions are
2040 * not modeled in the code.
2041 * FOR MESON-BARYON AND MESON-MESON COLLISIONS, we use a maximum
2042 * interaction distance DELTR0=2.6
2043 * for ppbar production from meson (pi rho omega) interactions:
2044 c
2045             DELTR0=3.
2046         if( (iabs(lb1).ge.14.and.iabs(lb1).le.17) .or.
2047      &      (iabs(lb1).ge.30.and.iabs(lb1).le.45) ) DELTR0=5.0
2048         if( (iabs(lb2).ge.14.and.iabs(lb2).le.17) .or.
2049      &      (iabs(lb2).ge.30.and.iabs(lb2).le.45) ) DELTR0=5.0
2050
2051             if(lb1.eq.28.and.lb2.eq.28) DELTR0=4.84
2052 clin-10/08/00 to include pi pi -> rho rho:
2053             if((lb1.ge.3.and.lb1.le.5).and.(lb2.ge.3.and.lb2.le.5)) then
2054                E2=SQRT(EM2**2+PX2**2+PY2**2+PZ2**2)
2055          spipi=(e1+e2)**2-(px1+px2)**2-(py1+py2)**2-(pz1+pz2)**2
2056                if(spipi.ge.(4*0.77**2)) DELTR0=3.5
2057             endif
2058
2059 c khyperon
2060         IF (LB1.EQ.23 .AND. (LB2.GE.14.AND.LB2.LE.17)) GOTO 3699
2061         IF (LB2.EQ.23 .AND. (LB1.GE.14.AND.LB1.LE.17)) GOTO 3699
2062
2063 * K(K*) + Kbar(K*bar) scattering including
2064 *     K(K*) + Kbar(K*bar) --> phi + pi(rho,omega) and pi pi(rho,omega)
2065        if(lb1.eq.21.and.lb2.eq.23)go to 3699
2066        if(lb2.eq.21.and.lb1.eq.23)go to 3699
2067        if(lb1.eq.30.and.lb2.eq.21)go to 3699
2068        if(lb2.eq.30.and.lb1.eq.21)go to 3699
2069        if(lb1.eq.-30.and.lb2.eq.23)go to 3699
2070        if(lb2.eq.-30.and.lb1.eq.23)go to 3699
2071        if(lb1.eq.-30.and.lb2.eq.30)go to 3699
2072        if(lb2.eq.-30.and.lb1.eq.30)go to 3699
2073 c
2074 clin-12/15/00
2075 c     kaon+rho(omega,eta) collisions:
2076       if(lb1.eq.21.or.lb1.eq.23) then
2077          if(lb2.eq.0.or.(lb2.ge.25.and.lb2.le.28)) then
2078             go to 3699
2079          endif
2080       elseif(lb2.eq.21.or.lb2.eq.23) then
2081          if(lb1.eq.0.or.(lb1.ge.25.and.lb1.le.28)) then
2082             goto 3699
2083          endif
2084       endif
2085
2086 clin-8/14/02 K* (pi, rho, omega, eta) collisions:
2087       if(iabs(lb1).eq.30 .and.
2088      1     (lb2.eq.0.or.(lb2.ge.25.and.lb2.le.28)
2089      2     .or.(lb2.ge.3.and.lb2.le.5))) then
2090          go to 3699
2091       elseif(iabs(lb2).eq.30 .and.
2092      1        (lb1.eq.0.or.(lb1.ge.25.and.lb1.le.28)
2093      2        .or.(lb1.ge.3.and.lb1.le.5))) then
2094          goto 3699
2095 clin-8/14/02-end
2096 c K*/K*-bar + baryon/antibaryon collisions:
2097         elseif( iabs(lb1).eq.30 .and.
2098      1     (iabs(lb2).eq.1.or.iabs(lb2).eq.2.or.
2099      2     (iabs(lb2).ge.6.and.iabs(lb2).le.13)) )then
2100               go to 3699
2101            endif
2102          if( iabs(lb2).eq.30 .and.
2103      1         (iabs(lb1).eq.1.or.iabs(lb1).eq.2.or.
2104      2         (iabs(lb1).ge.6.and.iabs(lb1).le.13)) )then
2105                 go to 3699
2106         endif
2107 * K^+ baryons and antibaryons:
2108 c** K+ + B-bar  --> La(Si)-bar + pi
2109 * K^- and antibaryons, note K^- and baryons are included in newka():
2110 * note that we fail to satisfy charge conjugation for these cross sections:
2111         if((lb1.eq.23.or.lb1.eq.21).and.
2112      1       (iabs(lb2).eq.1.or.iabs(lb2).eq.2.or.
2113      2       (iabs(lb2).ge.6.and.iabs(lb2).le.13))) then
2114            go to 3699
2115         elseif((lb2.eq.23.or.lb2.eq.21).and.
2116      1       (iabs(lb1).eq.1.or.iabs(lb1).eq.2.or.
2117      2       (iabs(lb1).ge.6.and.iabs(lb1).le.13))) then
2118            go to 3699
2119         endif
2120 *
2121 * For anti-nucleons annihilations:
2122 * Assumptions:
2123 * (1) for collisions involving a p_bar or n_bar,
2124 * we allow only collisions between a p_bar and a baryon or a baryon
2125 * resonance (as well as a n_bar and a baryon or a baryon resonance),
2126 * we skip all other reactions involving a p_bar or n_bar,
2127 * such as collisions between p_bar (n_bar) and mesons,
2128 * and collisions between two p_bar's (n_bar's).
2129 * (2) we introduce a new parameter rppmax: the maximum interaction
2130 * distance to make the quick collision check,rppmax=3.57 fm
2131 * corresponding to a cutoff of annihilation xsection= 400mb which is
2132 * also used consistently in the actual annihilation xsection to be
2133 * used in the following as given in the subroutine xppbar(srt)
2134         rppmax=3.57
2135 * anti-baryon on baryons
2136         if((lb1.eq.-1.or.lb1.eq.-2.or.(lb1.ge.-13.and.lb1.le.-6))
2137      1 .and.(lb2.eq.1.or.lb2.eq.2.or.(lb2.ge.6.and.lb2.le.13))) then
2138             DELTR0 = RPPMAX
2139             GOTO 2699
2140        else if((lb2.eq.-1.or.lb2.eq.-2.or.(lb2.ge.-13.and.lb2.le.-6))
2141      1 .and.(lb1.eq.1.or.lb1.eq.2.or.(lb1.ge.6.and.lb1.le.13))) then
2142             DELTR0 = RPPMAX
2143             GOTO 2699
2144          END IF
2145
2146 c*  ((anti) lambda, cascade, omega  should not be rejected)
2147         if( (iabs(lb1).ge.14.and.iabs(lb1).le.17) .or.
2148      &      (iabs(lb2).ge.14.and.iabs(lb2).le.17) )go to 3699
2149 c
2150 clin-9/2008 maximum sigma~2810mb for deuteron+nucleon elastic collisions:
2151          IF (iabs(LB1).EQ.42.or.iabs(LB2).EQ.42) THEN
2152             ilb1=iabs(LB1)
2153             ilb2=iabs(LB2)
2154             if((ILB1.GE.1.AND.ILB1.LE.2)
2155      1           .or.(ILB1.GE.6.AND.ILB1.LE.13)
2156      2           .or.(ILB2.GE.1.AND.ILB2.LE.2)
2157      3           .or.(ILB2.GE.6.AND.ILB2.LE.13)) then
2158                if((lb1*lb2).gt.0) deltr0=9.5
2159             endif
2160          ENDIF
2161 c
2162         if( (iabs(lb1).ge.40.and.iabs(lb1).le.45) .or.
2163      &      (iabs(lb2).ge.40.and.iabs(lb2).le.45) )go to 3699
2164 c
2165 c* phi channel --> elastic + inelastic scatt.
2166          IF( (lb1.eq.29 .and.((lb2.ge.1.and.lb2.le.13).or.
2167      &       (lb2.ge.21.and.lb2.le.28).or.iabs(lb2).eq.30)) .OR.
2168      &     (lb2.eq.29 .and.((lb1.ge.1.and.lb1.le.13).or.
2169      &       (lb1.ge.21.and.lb1.le.28).or.iabs(lb1).eq.30)) )THEN
2170              DELTR0=3.0
2171              go to 3699
2172         endif
2173 c
2174 c  La/Si, Cas, Om (bar)-meson elastic colln
2175 * pion vs. La & Ca (bar) coll. are treated in resp. subroutines
2176
2177 * SKIP all other K* RESCATTERINGS
2178         If(iabs(lb1).eq.30.or.iabs(lb2).eq.30) go to 400
2179 * SKIP KAON(+) RESCATTERINGS WITH particles other than pions and baryons
2180          If(lb1.eq.23.and.(lb2.lt.1.or.lb2.gt.17))go to 400
2181          If(lb2.eq.23.and.(lb1.lt.1.or.lb1.gt.17))go to 400
2182 c
2183 c anti-baryon proccess: B-bar+M, N-bar+R-bar, N-bar+N-bar, R-bar+R-bar
2184 c  R = (D,N*)
2185          if( ((lb1.le.-1.and.lb1.ge.-13)
2186      &        .and.(lb2.eq.0.or.(lb2.ge.3.and.lb2.le.5)
2187      &            .or.(lb2.ge.25.and.lb2.le.28)))
2188      &      .OR.((lb2.le.-1.and.lb2.ge.-13)
2189      &         .and.(lb1.eq.0.or.(lb1.ge.3.and.lb1.le.5)
2190      &              .or.(lb1.ge.25.and.lb1.le.28))) ) then
2191          elseIF( ((LB1.eq.-1.or.lb1.eq.-2).
2192      &             and.(LB2.LT.-5.and.lb2.ge.-13))
2193      &      .OR. ((LB2.eq.-1.or.lb2.eq.-2).
2194      &             and.(LB1.LT.-5.and.lb1.ge.-13)) )then
2195          elseIF((LB1.eq.-1.or.lb1.eq.-2)
2196      &     .AND.(LB2.eq.-1.or.lb2.eq.-2))then
2197          elseIF((LB1.LT.-5.and.lb1.ge.-13).AND.
2198      &          (LB2.LT.-5.and.lb2.ge.-13)) then
2199 c        elseif((lb1.lt.0).or.(lb2.lt.0)) then
2200 c         go to 400
2201        endif
2202
2203  2699    CONTINUE
2204 * for baryon-baryon collisions
2205          IF (LB1 .EQ. 1 .OR. LB1 .EQ. 2 .OR. (LB1 .GE. 6 .AND.
2206      &        LB1 .LE. 17)) THEN
2207             IF (LB2 .EQ. 1 .OR. LB2 .EQ. 2 .OR. (LB2 .GE. 6 .AND.
2208      &           LB2 .LE. 17)) THEN
2209                DELTR0 = 2.
2210             END IF
2211          END IF
2212 c
2213  3699   RSQARE = (X1-X2)**2 + (Y1-Y2)**2 + (Z1-Z2)**2
2214         IF (RSQARE .GT. DELTR0**2) GO TO 400
2215 *NOW PARTICLES ARE CLOSE ENOUGH TO EACH OTHER !
2216 * KEEP ALL COORDINATES FOR POSSIBLE PHASE SPACE CHANGE
2217             ix2 = nint(x2/dx)
2218             iy2 = nint(y2/dy)
2219             iz2 = nint(z2/dz)
2220             ipx2 = nint(px2/dpx)
2221             ipy2 = nint(py2/dpy)
2222             ipz2 = nint(pz2/dpz)
2223 * FIND MOMENTA OF PARTICLES IN THE CMS OF THE TWO COLLIDING PARTICLES
2224 * AND THE CMS ENERGY SRT
2225           CALL CMS(I1,I2,PCX,PCY,PCZ,SRT)
2226 clin-7/26/03 improve speed
2227           drmax=dr0max
2228           call distc0(drmax,deltr0,DT,
2229      1         Ifirst,PCX,PCY,PCZ,
2230      2         x1,y1,z1,px1,py1,pz1,em1,x2,y2,z2,px2,py2,pz2,em2)
2231           if(Ifirst.eq.-1) goto 400
2232
2233          ISS=NINT(SRT/ESBIN)
2234 clin-4/2008 use last bin if ISS is out of EKAON's upper bound of 2000:
2235          if(ISS.gt.2000) ISS=2000
2236 *Sort collisions
2237 c
2238 clin-8/2008 Deuteron+Meson->B+B;
2239 c     meson=(pi,rho,omega,eta), B=(n,p,Delta,N*1440,N*1535):
2240          IF (iabs(LB1).EQ.42.or.iabs(LB2).EQ.42) THEN
2241             ilb1=iabs(LB1)
2242             ilb2=iabs(LB2)
2243             if(LB1.eq.0.or.(LB1.GE.3.AND.LB1.LE.5)
2244      1           .or.(LB1.GE.25.AND.LB1.LE.28)
2245      2           .or.
2246      3           LB2.eq.0.or.(LB2.GE.3.AND.LB2.LE.5)
2247      4           .or.(LB2.GE.25.AND.LB2.LE.28)) then
2248                GOTO 505
2249 clin-9/2008 Deuteron+Baryon or antiDeuteron+antiBaryon elastic collisions:
2250             elseif(((ILB1.GE.1.AND.ILB1.LE.2)
2251      1              .or.(ILB1.GE.6.AND.ILB1.LE.13)
2252      2              .or.(ILB2.GE.1.AND.ILB2.LE.2)
2253      3              .or.(ILB2.GE.6.AND.ILB2.LE.13))
2254      4              .and.(lb1*lb2).gt.0) then
2255                GOTO 506
2256             else
2257                GOTO 400
2258             endif
2259          ENDIF
2260 c
2261 * K+ + (N,N*,D)-bar --> L/S-bar + pi
2262           if( ((lb1.eq.23.or.lb1.eq.30).and.
2263      &         (lb2.eq.-1.or.lb2.eq.-2.or.(lb2.ge.-13.and.lb2.le.-6)))
2264      &         .OR.((lb2.eq.23.or.lb2.eq.30).and.
2265      &         (lb1.eq.-1.or.lb1.eq.-2.or.(lb1.ge.-13.and.lb1.le.-6))) )
2266      &         then
2267              bmass=0.938
2268              if(srt.le.(bmass+aka)) then
2269                 pkaon=0.
2270              else
2271                 pkaon=sqrt(((srt**2-(aka**2+bmass**2))
2272      1               /2./bmass)**2-aka**2)
2273              endif
2274 clin-10/31/02 cross sections are isospin-averaged, same as those in newka
2275 c     for K- + (N,N*,D) --> L/S + pi:
2276              sigela = 0.5 * (AKPEL(PKAON) + AKNEL(PKAON))
2277              SIGSGM = 1.5 * AKPSGM(PKAON) + AKNSGM(PKAON)
2278              SIG = sigela + SIGSGM + AKPLAM(PKAON)
2279              if(sig.gt.1.e-7) then
2280 c     ! K+ + N-bar reactions
2281                 icase=3
2282                 brel=sigela/sig
2283                 brsgm=sigsgm/sig
2284                 brsig = sig
2285                 nchrg = 1
2286                 go to 3555
2287              endif
2288              go to 400
2289           endif
2290 c
2291 c
2292 c  meson + hyperon-bar -> K+ + N-bar
2293           if(((lb1.ge.-17.and.lb1.le.-14).and.(lb2.ge.3.and.lb2.le.5))
2294      &         .OR.((lb2.ge.-17.and.lb2.le.-14)
2295      &         .and.(lb1.ge.3.and.lb1.le.5)))then
2296              nchrg=-100
2297
2298 C*       first classify the reactions due to total charge.
2299              if((lb1.eq.-15.and.(lb2.eq.5.or.lb2.eq.27)).OR.
2300      &            (lb2.eq.-15.and.(lb1.eq.5.or.lb1.eq.27))) then
2301                 nchrg=-2
2302 c     ! D-(bar)
2303                 bmass=1.232
2304                 go to 110
2305              endif
2306              if( (lb1.eq.-15.and.(lb2.eq.0.or.lb2.eq.4.or.lb2.eq.26.or.
2307      &            lb2.eq.28)).OR.(lb2.eq.-15.and.(lb1.eq.0.or.
2308      &            lb1.eq.4.or.lb1.eq.26.or.lb1.eq.28)).OR.
2309      &   ((lb1.eq.-14.or.lb1.eq.-16).and.(lb2.eq.5.or.lb2.eq.27)).OR.
2310      &   ((lb2.eq.-14.or.lb2.eq.-16).and.(lb1.eq.5.or.lb1.eq.27)) )then
2311                 nchrg=-1
2312 c     ! n-bar
2313                 bmass=0.938
2314                 go to 110
2315              endif
2316              if(  (lb1.eq.-15.and.(lb2.eq.3.or.lb2.eq.25)).OR.
2317      &            (lb2.eq.-15.and.(lb1.eq.3.or.lb1.eq.25)).OR.
2318      &            (lb1.eq.-17.and.(lb2.eq.5.or.lb2.eq.27)).OR.
2319      &            (lb2.eq.-17.and.(lb1.eq.5.or.lb1.eq.27)).OR.
2320      &            ((lb1.eq.-14.or.lb1.eq.-16).and.(lb2.eq.0.or.lb2.eq.4
2321      &            .or.lb2.eq.26.or.lb2.eq.28)).OR.
2322      &            ((lb2.eq.-14.or.lb2.eq.-16).and.(lb1.eq.0.or.lb1.eq.4
2323      &            .or.lb1.eq.26.or.lb1.eq.28)) )then
2324                nchrg=0
2325 c     ! p-bar
2326                 bmass=0.938
2327                 go to 110
2328              endif
2329              if( (lb1.eq.-17.and.(lb2.eq.0.or.lb2.eq.4.or.lb2.eq.26.or.
2330      &            lb2.eq.28)).OR.(lb2.eq.-17.and.(lb1.eq.0.or.
2331      &            lb1.eq.4.or.lb1.eq.26.or.lb1.eq.28)).OR.
2332      &  ((lb1.eq.-14.or.lb1.eq.-16).and.(lb2.eq.3.or.lb2.eq.25)).OR.
2333      &  ((lb2.eq.-14.or.lb2.eq.-16).and.(lb1.eq.3.or.lb1.eq.25)))then
2334                nchrg=1
2335 c     ! D++(bar)
2336                 bmass=1.232
2337              endif
2338 c
2339 c 110     if(nchrg.ne.-100.and.srt.ge.(aka+bmass))then !! for elastic
2340  110         sig = 0.
2341 c !! for elastic
2342          if(nchrg.ne.-100.and.srt.ge.(aka+bmass))then
2343 cc110        if(nchrg.eq.-100.or.srt.lt.(aka+bmass)) go to 400
2344 c             ! PI + La(Si)-bar => K+ + N-bar reactions
2345             icase=4
2346 cc       pkaon=sqrt(((srt**2-(aka**2+bmass**2))/2./bmass)**2-aka**2)
2347             pkaon=sqrt(((srt**2-(aka**2+0.938**2))/2./0.938)**2-aka**2)
2348 c ! lambda-bar + Pi
2349             if(lb1.eq.-14.or.lb2.eq.-14) then
2350                if(nchrg.ge.0) sigma0=akPlam(pkaon)
2351                if(nchrg.lt.0) sigma0=akNlam(pkaon)
2352 c                ! sigma-bar + pi
2353             else
2354 c !K-p or K-D++
2355                if(nchrg.ge.0) sigma0=akPsgm(pkaon)
2356 c !K-n or K-D-
2357                if(nchrg.lt.0) sigma0=akNsgm(pkaon)
2358                SIGMA0 = 1.5 * AKPSGM(PKAON) + AKNSGM(PKAON)
2359             endif
2360             sig=(srt**2-(aka+bmass)**2)*(srt**2-(aka-bmass)**2)/
2361      &           (srt**2-(em1+em2)**2)/(srt**2-(em1-em2)**2)*sigma0
2362 c ! K0barD++, K-D-
2363             if(nchrg.eq.-2.or.nchrg.eq.2) sig=2.*sig
2364 C*     the factor 2 comes from spin of delta, which is 3/2
2365 C*     detailed balance. copy from Page 423 of N.P. A614 1997
2366             IF (LB1 .EQ. -14 .OR. LB2 .EQ. -14) THEN
2367                SIG = 4.0 / 3.0 * SIG
2368             ELSE IF (NCHRG .EQ. -2 .OR. NCHRG .EQ. 2) THEN
2369                SIG = 8.0 / 9.0 * SIG
2370             ELSE
2371                SIG = 4.0 / 9.0 * SIG
2372             END IF
2373 cc        brel=0.
2374 cc        brsgm=0.
2375 cc        brsig = sig
2376 cc          if(sig.lt.1.e-7) go to 400
2377 *-
2378          endif
2379 c                ! PI + La(Si)-bar => elastic included
2380          icase=4
2381          sigela = 10.
2382          sig = sig + sigela
2383          brel= sigela/sig
2384          brsgm=0.
2385          brsig = sig
2386 *-
2387          go to 3555
2388       endif
2389
2390 ** MULTISTRANGE PARTICLE (Cas,Omega -bar) PRODUCTION - (NON)PERTURBATIVE
2391
2392 * K-/K*0bar + La/Si --> cascade + pi/eta
2393       if( ((lb1.eq.21.or.lb1.eq.-30).and.(lb2.ge.14.and.lb2.le.17)).OR.
2394      &  ((lb2.eq.21.or.lb2.eq.-30).and.(lb1.ge.14.and.lb1.le.17)) )then
2395           kp = 0
2396           go to 3455
2397         endif
2398 c K+/K*0 + La/Si(bar) --> cascade-bar + pi/eta
2399       if( ((lb1.eq.23.or.lb1.eq.30).and.(lb2.le.-14.and.lb2.ge.-17)).OR.
2400      &  ((lb2.eq.23.or.lb2.eq.30).and.(lb1.le.-14.and.lb1.ge.-17)) )then
2401           kp = 1
2402           go to 3455
2403         endif
2404 * K-/K*0bar + cascade --> omega + pi
2405        if( ((lb1.eq.21.or.lb1.eq.-30).and.(lb2.eq.40.or.lb2.eq.41)).OR.
2406      & ((lb2.eq.21.or.lb2.eq.-30).and.(lb1.eq.40.or.lb1.eq.41)) )then
2407           kp = 0
2408           go to 3455
2409         endif
2410 * K+/K*0 + cascade-bar --> omega-bar + pi
2411        if( ((lb1.eq.23.or.lb1.eq.30).and.(lb2.eq.-40.or.lb2.eq.-41)).OR.
2412      &  ((lb2.eq.23.or.lb2.eq.30).and.(lb1.eq.-40.or.lb1.eq.-41)) )then
2413           kp = 1
2414           go to 3455
2415         endif
2416 * Omega + Omega --> Di-Omega + photon(eta)
2417 cc        if( lb1.eq.45.and.lb2.eq.45 ) go to 3455
2418
2419 c annhilation of cascade(bar), omega(bar)
2420          kp = 3
2421 * K- + L/S <-- cascade(bar) + pi/eta
2422        if( (((lb1.ge.3.and.lb1.le.5).or.lb1.eq.0)
2423      &       .and.(iabs(lb2).eq.40.or.iabs(lb2).eq.41))
2424      & .OR. (((lb2.ge.3.and.lb2.le.5).or.lb2.eq.0)
2425      &       .and.(iabs(lb1).eq.40.or.iabs(lb1).eq.41)) )go to 3455
2426 * K- + cascade(bar) <-- omega(bar) + pi
2427 *         if(  (lb1.eq.0.and.iabs(lb2).eq.45)
2428 *    &       .OR. (lb2.eq.0.and.iabs(lb1).eq.45) )go to 3455
2429         if( ((lb1.ge.3.and.lb1.le.5).and.iabs(lb2).eq.45)
2430      &  .OR.((lb2.ge.3.and.lb2.le.5).and.iabs(lb1).eq.45) )go to 3455
2431 c
2432
2433 ***  MULTISTRANGE PARTICLE PRODUCTION  (END)
2434
2435 c* K+ + La(Si) --> Meson + B
2436         IF (LB1.EQ.23 .AND. (LB2.GE.14.AND.LB2.LE.17)) GOTO 5699
2437         IF (LB2.EQ.23 .AND. (LB1.GE.14.AND.LB1.LE.17)) GOTO 5699
2438 c* K- + La(Si)-bar --> Meson + B-bar
2439        IF (LB1.EQ.21 .AND. (LB2.GE.-17.AND.LB2.LE.-14)) GOTO 5699
2440        IF (LB2.EQ.21 .AND. (LB1.GE.-17.AND.LB1.LE.-14)) GOTO 5699
2441
2442 c La/Si-bar + B --> pi + K+
2443        IF( (((LB1.eq.1.or.LB1.eq.2).or.(LB1.ge.6.and.LB1.le.13))
2444      &       .AND.(LB2.GE.-17.AND.LB2.LE.-14)) .OR.
2445      &     (((LB2.eq.1.or.LB2.eq.2).or.(LB2.ge.6.and.LB2.le.13))
2446      &      .AND.(LB1.GE.-17.AND.LB1.LE.-14)) )go to 5999
2447 c La/Si + B-bar --> pi + K-
2448        IF( (((LB1.eq.-1.or.LB1.eq.-2).or.(LB1.le.-6.and.LB1.ge.-13))
2449      &       .AND.(LB2.GE.14.AND.LB2.LE.17)) .OR.
2450      &     (((LB2.eq.-1.or.LB2.eq.-2).or.(LB2.le.-6.and.LB2.ge.-13))
2451      &       .AND.(LB1.GE.14.AND.LB1.LE.17)) )go to 5999
2452 *
2453 *
2454 * K(K*) + Kbar(K*bar) --> phi + pi(rho,omega), M + M (M=pi,rho,omega,eta)
2455        if(lb1.eq.21.and.lb2.eq.23) go to 8699
2456        if(lb2.eq.21.and.lb1.eq.23) go to 8699
2457        if(lb1.eq.30.and.lb2.eq.21) go to 8699
2458        if(lb2.eq.30.and.lb1.eq.21) go to 8699
2459        if(lb1.eq.-30.and.lb2.eq.23) go to 8699
2460        if(lb2.eq.-30.and.lb1.eq.23) go to 8699
2461        if(lb1.eq.-30.and.lb2.eq.30) go to 8699
2462        if(lb2.eq.-30.and.lb1.eq.30) go to 8699
2463 c* (K,K*)-bar + rho(omega) --> phi +(K,K*)-bar, piK and elastic
2464        IF( ((lb1.eq.23.or.lb1.eq.21.or.iabs(lb1).eq.30) .and.
2465      &      (lb2.ge.25.and.lb2.le.28)) .OR.
2466      &     ((lb2.eq.23.or.lb2.eq.21.or.iabs(lb2).eq.30) .and.
2467      &      (lb1.ge.25.and.lb1.le.28)) ) go to 8799
2468 c
2469 c* K*(-bar) + pi --> phi + (K,K*)-bar
2470        IF( (iabs(lb1).eq.30.and.(lb2.ge.3.and.lb2.le.5)) .OR.
2471      &     (iabs(lb2).eq.30.and.(lb1.ge.3.and.lb1.le.5)) )go to 8799
2472 *
2473 c
2474 c* phi + N --> pi+N(D),  rho+N(D),  K+ +La
2475 c* phi + D --> pi+N(D),  rho+N(D)
2476        IF( (lb1.eq.29 .and.(lb2.eq.1.or.lb2.eq.2.or.
2477      &       (lb2.ge.6.and.lb2.le.9))) .OR.
2478      &     (lb2.eq.29 .and.(lb1.eq.1.or.lb1.eq.2.or.
2479      &       (lb1.ge.6.and.lb1.le.9))) )go to 7222
2480 c
2481 c* phi + (pi,rho,ome,K,K*-bar) --> K+K, K+K*, K*+K*, (pi,rho,omega)+(K,K*-bar)
2482        IF( (lb1.eq.29 .and.((lb2.ge.3.and.lb2.le.5).or.
2483      &      (lb2.ge.21.and.lb2.le.28).or.iabs(lb2).eq.30)) .OR.
2484      &     (lb2.eq.29 .and.((lb1.ge.3.and.lb1.le.5).or.
2485      &      (lb1.ge.21.and.lb1.le.28).or.iabs(lb1).eq.30)) )THEN
2486              go to 7444
2487       endif
2488 *
2489 c
2490 * La/Si, Cas, Om (bar)-(rho,omega,phi) elastic colln
2491 * pion vs. La, Ca, Omega-(bar) elastic coll. treated in resp. subroutines
2492       if( ((iabs(lb1).ge.14.and.iabs(lb1).le.17).or.iabs(lb1).ge.40)
2493      &    .and.((lb2.ge.25.and.lb2.le.29).or.lb2.eq.0) )go to 888
2494       if( ((iabs(lb2).ge.14.and.iabs(lb2).le.17).or.iabs(lb2).ge.40)
2495      &    .and.((lb1.ge.25.and.lb1.le.29).or.lb1.eq.0) )go to 888
2496 c
2497 c K+/K* (N,R)  OR   K-/K*- (N,R)-bar  elastic scatt
2498         if( ((lb1.eq.23.or.lb1.eq.30).and.(lb2.eq.1.or.lb2.eq.2.or.
2499      &         (lb2.ge.6.and.lb2.le.13))) .OR.
2500      &      ((lb2.eq.23.or.lb2.eq.30).and.(lb1.eq.1.or.lb1.eq.2.or.
2501      &         (lb1.ge.6.and.lb1.le.13))) ) go to 888
2502         if( ((lb1.eq.21.or.lb1.eq.-30).and.(lb2.eq.-1.or.lb2.eq.-2.or.
2503      &       (lb2.ge.-13.and.lb2.le.-6))) .OR.
2504      &      ((lb2.eq.21.or.lb2.eq.-30).and.(lb1.eq.-1.or.lb1.eq.-2.or.
2505      &       (lb1.ge.-13.and.lb1.le.-6))) ) go to 888
2506 c
2507 * L/S-baryon elastic collision
2508        If( ((lb1.ge.14.and.lb1.le.17).and.(lb2.ge.6.and.lb2.le.13))
2509      & .OR.((lb2.ge.14.and.lb2.le.17).and.(lb1.ge.6.and.lb1.le.13)) )
2510      &   go to 7799
2511        If(((lb1.le.-14.and.lb1.ge.-17).and.(lb2.le.-6.and.lb2.ge.-13))
2512      &.OR.((lb2.le.-14.and.lb2.ge.-17).and.(lb1.le.-6.and.lb1.ge.-13)))
2513      &   go to 7799
2514 c
2515 c skip other collns with perturbative particles or hyperon-bar
2516        if( iabs(lb1).ge.40 .or. iabs(lb2).ge.40
2517      &    .or. (lb1.le.-14.and.lb1.ge.-17)
2518      &    .or. (lb2.le.-14.and.lb2.ge.-17) )go to 400
2519 c
2520 c
2521 * anti-baryon on baryon resonaces
2522         if((lb1.eq.-1.or.lb1.eq.-2.or.(lb1.ge.-13.and.lb1.le.-6))
2523      1 .and.(lb2.eq.1.or.lb2.eq.2.or.(lb2.ge.6.and.lb2.le.13))) then
2524             GOTO 2799
2525        else if((lb2.eq.-1.or.lb2.eq.-2.or.(lb2.ge.-13.and.lb2.le.-6))
2526      1 .and.(lb1.eq.1.or.lb1.eq.2.or.(lb1.ge.6.and.lb1.le.13))) then
2527             GOTO 2799
2528          END IF
2529 c
2530 clin-10/25/02 get rid of argument usage mismatch in newka():
2531          inewka=irun
2532 c        call newka(icase,irun,iseed,dt,nt,
2533 clin-5/01/03 set iblock value in art1f.f, necessary for resonance studies:
2534 c        call newka(icase,inewka,iseed,dt,nt,
2535 c     &                  ictrl,i1,i2,srt,pcx,pcy,pcz)
2536         call newka(icase,inewka,iseed,dt,nt,
2537      &                  ictrl,i1,i2,srt,pcx,pcy,pcz,iblock)
2538
2539 clin-10/25/02-end
2540         IF (ICTRL .EQ. 1) GOTO 400
2541 c
2542 * SEPARATE NUCLEON+NUCLEON( BARYON RESONANCE+ BARYON RESONANCE ELASTIC
2543 * COLLISION), BARYON RESONANCE+NUCLEON AND BARYON-PION
2544 * COLLISIONS INTO THREE PARTS TO CHECK IF THEY ARE GOING TO SCATTER,
2545 * WE only allow L/S to COLLIDE elastically with a nucleon and meson
2546        if((iabs(lb1).ge.14.and.iabs(lb1).le.17).
2547      &  or.(iabs(lb2).ge.14.and.iabs(lb2).le.17))go to 400
2548 * IF PION+PION COLLISIONS GO TO 777
2549 * if pion+eta, eta+eta to create kaons go to 777
2550        IF((lb1.ge.3.and.lb1.le.5).and.(lb2.ge.3.and.lb2.le.5))GO TO 777
2551        if(lb1.eq.0.and.(lb2.ge.3.and.lb2.le.5)) go to 777
2552        if(lb2.eq.0.and.(lb1.ge.3.and.lb1.le.5)) go to 777
2553        if(lb1.eq.0.and.lb2.eq.0)go to 777
2554 * we assume that rho and omega behave the same way as pions in
2555 * kaon production
2556 * (1) rho(omega)+rho(omega)
2557        if( (lb1.ge.25.and.lb1.le.28).and.
2558      &     (lb2.ge.25.and.lb2.le.28) )goto 777
2559 * (2) rho(omega)+pion
2560       If((lb1.ge.25.and.lb1.le.28).and.(lb2.ge.3.and.lb2.le.5))go to 777
2561       If((lb2.ge.25.and.lb2.le.28).and.(lb1.ge.3.and.lb1.le.5))go to 777
2562 * (3) rho(omega)+eta
2563        if((lb1.ge.25.and.lb1.le.28).and.lb2.eq.0)go to 777
2564        if((lb2.ge.25.and.lb2.le.28).and.lb1.eq.0)go to 777
2565 c
2566 * if kaon+pion collisions go to 889
2567        if((lb1.eq.23.or.lb1.eq.21).and.(lb2.ge.3.and.lb2.le.5))go to 889
2568        if((lb2.eq.23.or.lb2.eq.21).and.(lb1.ge.3.and.lb1.le.5))go to 889
2569 c
2570 clin-2/06/03 skip all other (K K* Kbar K*bar) channels:
2571 * SKIP all other K and K* RESCATTERINGS
2572         If(iabs(lb1).eq.30.or.iabs(lb2).eq.30) go to 400
2573         If(lb1.eq.21.or.lb2.eq.21) go to 400
2574         If(lb1.eq.23.or.lb2.eq.23) go to 400
2575 c
2576 * IF PION+baryon COLLISION GO TO 3
2577            IF( (LB1.ge.3.and.LB1.le.5) .and.
2578      &         (iabs(LB2).eq.1.or.iabs(LB2).eq.2.or.
2579      &          (iabs(LB2).ge.6.and.iabs(LB2).le.13)) )GO TO 3
2580            IF( (LB2.ge.3.and.LB2.le.5) .and.
2581      &         (iabs(LB1).eq.1.or.iabs(LB1).eq.2.or.
2582      &          (iabs(LB1).ge.6.and.iabs(LB1).le.13)) )GO TO 3
2583 c
2584 * IF rho(omega)+NUCLEON (baryon resonance) COLLISION GO TO 33
2585            IF( (LB1.ge.25.and.LB1.le.28) .and.
2586      &         (iabs(LB2).eq.1.or.iabs(LB2).eq.2.or.
2587      &          (iabs(LB2).ge.6.and.iabs(LB2).le.13)) )GO TO 33
2588            IF( (LB2.ge.25.and.LB2.le.28) .and.
2589      &         (iabs(LB1).eq.1.or.iabs(LB1).eq.2.or.
2590      &          (iabs(LB1).ge.6.and.iabs(LB1).le.13)) )GO TO 33
2591 c
2592 * IF ETA+NUCLEON (baryon resonance) COLLISIONS GO TO 547
2593            IF( LB1.eq.0 .and.
2594      &         (iabs(LB2).eq.1.or.iabs(LB2).eq.2.or.
2595      &          (iabs(LB2).ge.6.and.iabs(LB2).le.13)) )GO TO 547
2596            IF( LB2.eq.0 .and.
2597      &         (iabs(LB1).eq.1.or.iabs(LB1).eq.2.or.
2598      &          (iabs(LB1).ge.6.and.iabs(LB1).le.13)) )GO TO 547
2599 c
2600 * IF NUCLEON+BARYON RESONANCE COLLISION GO TO 44
2601             IF((LB1.eq.1.or.lb1.eq.2).
2602      &        AND.(LB2.GT.5.and.lb2.le.13))GOTO 44
2603             IF((LB2.eq.1.or.lb2.eq.2).
2604      &        AND.(LB1.GT.5.and.lb1.le.13))GOTO 44
2605             IF((LB1.eq.-1.or.lb1.eq.-2).
2606      &        AND.(LB2.LT.-5.and.lb2.ge.-13))GOTO 44
2607             IF((LB2.eq.-1.or.lb2.eq.-2).
2608      &        AND.(LB1.LT.-5.and.lb1.ge.-13))GOTO 44
2609 c
2610 * IF NUCLEON+NUCLEON COLLISION GO TO 4
2611        IF((LB1.eq.1.or.lb1.eq.2).AND.(LB2.eq.1.or.lb2.eq.2))GOTO 4
2612        IF((LB1.eq.-1.or.lb1.eq.-2).AND.(LB2.eq.-1.or.lb2.eq.-2))GOTO 4
2613 c
2614 * IF BARYON RESONANCE+BARYON RESONANCE COLLISION GO TO 444
2615             IF((LB1.GT.5.and.lb1.le.13).AND.
2616      &         (LB2.GT.5.and.lb2.le.13)) GOTO 444
2617             IF((LB1.LT.-5.and.lb1.ge.-13).AND.
2618      &         (LB2.LT.-5.and.lb2.ge.-13)) GOTO 444
2619 c
2620 * if L/S+L/S or L/s+nucleon go to 400
2621 * otherwise, develop a model for their collisions
2622        if((lb1.lt.3).and.(lb2.ge.14.and.lb2.le.17))goto 400
2623        if((lb2.lt.3).and.(lb1.ge.14.and.lb1.le.17))goto 400
2624        if((lb1.ge.14.and.lb1.le.17).and.
2625      &  (lb2.ge.14.and.lb2.le.17))goto 400
2626 c
2627 * otherwise, go out of the loop
2628               go to 400
2629 *
2630 *
2631 547           IF(LB1*LB2.EQ.0)THEN
2632 * (1) FOR ETA+NUCLEON SYSTEM, we allow both elastic collision,
2633 *     i.e. N*(1535) formation and kaon production
2634 *     the total kaon production cross section is
2635 *     ASSUMED to be THE SAME AS PION+NUCLEON COLLISIONS
2636 * (2) for eta+baryon resonance we only allow kaon production
2637            ece=(em1+em2+0.02)**2
2638            xkaon0=0.
2639            if(srt.ge.1.63.AND.SRT.LE.1.7)xkaon0=pnlka(srt)
2640            IF(SRT.GT.1.7)XKAON0=PNLKA(SRT)+pnska(srt)
2641 cbz3/7/99 neutralk
2642             XKAON0 = 2.0 * XKAON0
2643 cbz3/7/99 neutralk end
2644
2645 * Here we negelect eta+n inelastic collisions other than the
2646 * kaon production, therefore the total inelastic cross section
2647 * xkaon equals to the xkaon0 (kaon production cross section)
2648            xkaon=xkaon0
2649 * note here the xkaon is in unit of fm**2
2650             XETA=XN1535(I1,I2,0)
2651         If((iabs(LB(I1)).ge.6.and.iabs(LB(I1)).le.13).or.
2652      &     (iabs(LB(I2)).ge.6.and.iabs(LB(I2)).le.13)) xeta=0.
2653             IF((XETA+xkaon).LE.1.e-06)GO TO 400
2654             DSE=SQRT((XETA+XKAON)/PI)
2655            DELTRE=DSE+0.1
2656         px1cm=pcx
2657         py1cm=pcy
2658         pz1cm=pcz
2659 * CHECK IF N*(1535) resonance CAN BE FORMED
2660          CALL DISTCE(I1,I2,DELTRE,DSE,DT,ECE,SRT,IC,
2661      1   PCX,PCY,PCZ)
2662          IF(IC.EQ.-1) GO TO 400
2663          ekaon(4,iss)=ekaon(4,iss)+1
2664         IF(XKAON0/(XKAON+XETA).GT.RANART(NSEED))then
2665 * kaon production, USE CREN TO CALCULATE THE MOMENTUM OF L/S K+
2666         CALL CREN(PX1CM,PY1CM,PZ1CM,SRT,I1,I2,IBLOCK)
2667 * kaon production
2668        IF(IBLOCK.EQ.7) then
2669           LPN=LPN+1
2670        elseIF(IBLOCK.EQ.-7) then
2671        endif
2672 c
2673        em1=e(i1)
2674        em2=e(i2)
2675        GO TO 440
2676        endif
2677 * N*(1535) FORMATION
2678         resona=1.
2679          GO TO 98
2680          ENDIF
2681 *IF PION+NUCLEON (baryon resonance) COLLISION THEN
2682 3           CONTINUE
2683            px1cm=pcx
2684            py1cm=pcy
2685            pz1cm=pcz
2686 * the total kaon production cross section for pion+baryon (resonance) is
2687 * assumed to be the same as in pion+nucleon
2688            xkaon0=0.
2689            if(srt.ge.1.63.AND.SRT.LE.1.7)xkaon0=pnlka(srt)
2690            IF(SRT.GT.1.7)XKAON0=PNLKA(SRT)+pnska(srt)
2691             XKAON0 = 2.0 * XKAON0
2692 c
2693 c sp11/21/01  phi production: pi +N(D) -> phi + N(D)
2694          Xphi = 0.
2695        if( ( ((lb1.ge.1.and.lb1.le.2).or.
2696      &        (lb1.ge.6.and.lb1.le.9))
2697      &   .OR.((lb2.ge.1.and.lb2.le.2).or.
2698      &        (lb2.ge.6.and.lb2.le.9)) )
2699      &       .AND. srt.gt.1.958)
2700      &        call pibphi(srt,lb1,lb2,em1,em2,Xphi,xphin)
2701 c !! in fm^2 above
2702
2703 * if a pion collide with a baryon resonance,
2704 * we only allow kaon production AND the reabsorption
2705 * processes: Delta+pion-->N+pion, N*+pion-->N+pion
2706 * Later put in pion+baryon resonance elastic
2707 * cross through forming higher resonances implicitly.
2708 c          If(em1.gt.1.or.em2.gt.1.)go to 31
2709          If((iabs(LB(I1)).ge.6.and.iabs(LB(I1)).le.13).or.
2710      &      (iabs(LB(I2)).ge.6.and.iabs(LB(I2)).le.13)) go to 31
2711 * For pion+nucleon collisions:
2712 * using the experimental pion+nucleon inelastic cross section, we assume it
2713 * is exhausted by the Delta+pion, Delta+rho and Delta+omega production
2714 * and kaon production. In the following we first check whether
2715 * inelastic pion+n collision can happen or not, then determine in
2716 * crpn whether it is through pion production or through kaon production
2717 * note that the xkaon0 is the kaon production cross section
2718 * Note in particular that:
2719 * xkaon in the following is the total pion+nucleon inelastic cross section
2720 * note here the xkaon is in unit of fm**2, xnpi is also in unit of fm**2
2721 * FOR PION+NUCLEON SYSTEM, THE MINIMUM S IS 1.2056 the minimum srt for
2722 * elastic scattering, and it is 1.60 for pion production, 1.63 for LAMBDA+kaon
2723 * production and 1.7 FOR SIGMA+KAON
2724 * (EC = PION MASS+NUCLEON MASS+20MEV)**2
2725             EC=(em1+em2+0.02)**2
2726            xkaon=0.
2727            if(srt.gt.1.23)xkaon=(pionpp(srt)+PIPP1(SRT))/2.
2728 * pion+nucleon elastic cross section is divided into two parts:
2729 * (1) forming D(1232)+N*(1440) +N*(1535)
2730 * (2) cross sections forming higher resonances are calculated as
2731 *     the difference between the total elastic and (1), this part is
2732 *     treated as direct process since we do not explicitLY include
2733 *     higher resonances.
2734 * the following is the resonance formation cross sections.
2735 *1. PION(+)+PROTON-->DELTA++,PION(-)+NEUTRON-->DELTA(-)
2736            IF( (LB1*LB2.EQ.5.OR.((LB1*LB2.EQ.6).AND.
2737      &         (LB1.EQ.3.OR.LB2.EQ.3)))
2738      &    .OR. (LB1*LB2.EQ.-3.OR.((LB1*LB2.EQ.-10).AND.
2739      &         (LB1.EQ.5.OR.LB2.EQ.5))) )then
2740               XMAX=190.
2741               xmaxn=0
2742               xmaxn1=0
2743               xdirct=dirct1(srt)
2744                go to 678
2745            endif
2746 *2. PION(-)+PROTON-->DELTA0,PION(+)+NEUTRON-->DELTA+
2747 *   or N*(+)(1440) or N*(+)(1535)
2748 * note the factor 2/3 is from the isospin consideration and
2749 * the factor 0.6 or 0.5 is the branching ratio for the resonance to decay
2750 * into pion+nucleon
2751             IF( (LB1*LB2.EQ.3.OR.((LB1*LB2.EQ.10).AND.
2752      &          (LB1.EQ.5.OR.LB2.EQ.5)))
2753      &     .OR. (LB1*LB2.EQ.-5.OR.((LB1*LB2.EQ.-6).AND.
2754      &          (LB1.EQ.3.OR.LB2.EQ.3))) )then
2755               XMAX=27.
2756               xmaxn=2./3.*25.*0.6
2757                xmaxn1=2./3.*40.*0.5
2758               xdirct=dirct2(srt)
2759                go to 678
2760               endif
2761 *3. PION0+PROTON-->DELTA+,PION0+NEUTRON-->DELTA0, or N*(0)(1440) or N*(0)(1535)
2762             IF((LB1.EQ.4.OR.LB2.EQ.4).AND.
2763      &         (iabs(LB1*LB2).EQ.4.OR.iabs(LB1*LB2).EQ.8))then
2764               XMAX=50.
2765               xmaxn=1./3.*25*0.6
2766               xmaxn1=1/3.*40.*0.5
2767               xdirct=dirct3(srt)
2768                 go to 678
2769               endif
2770 678           xnpin1=0
2771            xnpin=0
2772             XNPID=XNPI(I1,I2,1,XMAX)
2773            if(xmaxn1.ne.0)xnpin1=XNPI(i1,i2,2,XMAXN1)
2774             if(xmaxn.ne.0)XNPIN=XNPI(I1,I2,0,XMAXN)
2775 * the following
2776            xres=xnpid+xnpin+xnpin1
2777            xnelas=xres+xdirct
2778            icheck=1
2779            go to 34
2780 * For pion + baryon resonance the reabsorption
2781 * cross section is calculated from the detailed balance
2782 * using reab(i1,i2,srt,ictrl), ictrl=1, 2 and 3
2783 * for pion, rho and omega + baryon resonance
2784 31           ec=(em1+em2+0.02)**2
2785            xreab=reab(i1,i2,srt,1)
2786
2787 clin-12/02/00 to satisfy detailed balance, forbid N* absorptions:
2788           if((iabs(lb1).ge.10.and.iabs(lb1).le.13)
2789      1         .or.(iabs(lb2).ge.10.and.iabs(lb2).le.13)) XREAB = 0.
2790
2791            xkaon=xkaon0+xreab
2792 * a constant of 10 mb IS USED FOR PION + N* RESONANCE,
2793         IF((iabs(LB1).GT.9.AND.iabs(LB1).LE.13) .OR.
2794      &      (iabs(LB2).GT.9.AND.iabs(LB2).LE.13))THEN
2795            Xnelas=1.0
2796         ELSE
2797            XNELAS=DPION(EM1,EM2,LB1,LB2,SRT)
2798         ENDIF
2799            icheck=2
2800 34          IF((Xnelas+xkaon+Xphi).LE.0.000001)GO TO 400
2801             DS=SQRT((Xnelas+xkaon+Xphi)/PI)
2802 csp09/20/01
2803 c           totcr = xnelas+xkaon
2804 c           if(srt .gt. 3.5)totcr = max1(totcr,3.)
2805 c           DS=SQRT(totcr/PI)
2806 csp09/20/01 end
2807
2808            deltar=ds+0.1
2809          CALL DISTCE(I1,I2,DELTAR,DS,DT,EC,SRT,IC,
2810      1   PCX,PCY,PCZ)
2811          IF(IC.EQ.-1) GO TO 400
2812        ekaon(4,iss)=ekaon(4,iss)+1
2813 c***
2814 * check what kind of collision has happened
2815 * (1) pion+baryon resonance
2816 * if direct elastic process
2817         if(icheck.eq.2)then
2818 c  !!sp11/21/01
2819       if(xnelas/(xnelas+xkaon+Xphi).ge.RANART(NSEED))then
2820 c               call Crdir(PX1CM,PY1CM,PZ1CM,SRT,I1,I2)
2821                call Crdir(PX1CM,PY1CM,PZ1CM,SRT,I1,I2,IBLOCK)
2822               go to 440
2823               else
2824 * for inelastic process, go to 96 to check
2825 * kaon production and pion reabsorption : pion+D(N*)-->pion+N
2826                go to 96
2827                 endif
2828               endif
2829 *(2) pion+n
2830 * CHECK IF inELASTIC COLLISION IS POSSIBLE FOR PION+N COLLISIONS
2831 clin-8/17/00 typo corrected, many other occurences:
2832 c        IF(XKAON/(XKAON+Xnelas).GT.RANART(NSEED))GO TO 95
2833        IF((XKAON+Xphi)/(XKAON+Xphi+Xnelas).GT.RANART(NSEED))GO TO 95
2834
2835 * direct process
2836         if(xdirct/xnelas.ge.RANART(NSEED))then
2837 c               call Crdir(PX1CM,PY1CM,PZ1CM,SRT,I1,I2)
2838                call Crdir(PX1CM,PY1CM,PZ1CM,SRT,I1,I2,IBLOCK)
2839               go to 440
2840               endif
2841 * now resonance formation or direct process (higher resonances)
2842            IF( (LB1*LB2.EQ.5.OR.((LB1*LB2.EQ.6).AND.
2843      &         (LB1.EQ.3.OR.LB2.EQ.3)))
2844      &    .OR. (LB1*LB2.EQ.-3.OR.((LB1*LB2.EQ.-10).AND.
2845      &         (LB1.EQ.5.OR.LB2.EQ.5))) )then
2846 c
2847 * ONLY DELTA RESONANCE IS POSSIBLE, go to 99
2848         GO TO 99
2849        else
2850 * NOW BOTH DELTA AND N* RESORANCE ARE POSSIBLE
2851 * DETERMINE THE RESORANT STATE BY USING THE MONTRE CARLO METHOD
2852             XX=(XNPIN+xnpin1)/xres
2853             IF(RANART(NSEED).LT.XX)THEN
2854 * N* RESONANCE IS SELECTED
2855 * decide N*(1440) or N*(1535) formation
2856         xx0=xnpin/(xnpin+xnpin1)
2857         if(RANART(NSEED).lt.xx0)then
2858          RESONA=0.
2859 * N*(1440) formation
2860          GO TO 97
2861         else
2862 * N*(1535) formation
2863         resona=1.
2864          GO TO 98
2865         endif
2866          ELSE
2867 * DELTA RESONANCE IS SELECTED
2868          GO TO 99
2869          ENDIF
2870          ENDIF
2871 97       CONTINUE
2872             IF(RESONA.EQ.0.)THEN
2873 *N*(1440) IS PRODUCED,WE DETERMINE THE CHARGE STATE OF THE PRODUCED N*
2874             I=I1
2875             IF(EM1.LT.0.6)I=I2
2876 * (0.1) n+pion(+)-->N*(+)
2877            IF( (LB1*LB2.EQ.10.AND.(LB1.EQ.5.OR.LB2.EQ.5))
2878      &      .OR.(LB1*LB2.EQ.-6.AND.(LB1.EQ.3.OR.LB2.EQ.3)) )THEN
2879             LB(I)=11
2880            go to 303
2881             ENDIF
2882 * (0.2) p+pion(0)-->N*(+)
2883 c            IF(LB(I1)*LB(I2).EQ.4.AND.(LB(I1).EQ.1.OR.LB(I2).EQ.1))THEN
2884             IF(iabs(LB(I1)*LB(I2)).EQ.4.AND.
2885      &         (LB(I1).EQ.4.OR.LB(I2).EQ.4))THEN
2886             LB(I)=11
2887            go to 303
2888             ENDIF
2889 * (0.3) n+pion(0)-->N*(0)
2890 c            IF(LB(I1)*LB(I2).EQ.8.AND.(LB(I1).EQ.2.OR.LB(I2).EQ.2))THEN
2891             IF(iabs(LB(I1)*LB(I2)).EQ.8.AND.
2892      &        (LB(I1).EQ.4.OR.LB(I2).EQ.4))THEN
2893             LB(I)=10
2894            go to 303
2895             ENDIF
2896 * (0.4) p+pion(-)-->N*(0)
2897 c            IF(LB(I1)*LB(I2).EQ.3)THEN
2898             IF( (LB(I1)*LB(I2).EQ.3)
2899      &      .OR.(LB(I1)*LB(I2).EQ.-5) )THEN
2900             LB(I)=10
2901             ENDIF
2902 303         CALL DRESON(I1,I2)
2903             if(LB1.lt.0.or.LB2.lt.0) LB(I)=-LB(I)
2904             lres=lres+1
2905             GO TO 101
2906 *COM: GO TO 101 TO CHANGE THE PHASE SPACE DENSITY OF THE NUCLEON
2907             ENDIF
2908 98          IF(RESONA.EQ.1.)THEN
2909 *N*(1535) IS PRODUCED, WE DETERMINE THE CHARGE STATE OF THE PRODUCED N*
2910             I=I1
2911             IF(EM1.LT.0.6)I=I2
2912 * note: this condition applies to both eta and pion
2913 * (0.1) n+pion(+)-->N*(+)
2914 c            IF(LB1*LB2.EQ.10.AND.(LB1.EQ.2.OR.LB2.EQ.2))THEN
2915             IF( (LB1*LB2.EQ.10.AND.(LB1.EQ.5.OR.LB2.EQ.5))
2916      &      .OR.(LB1*LB2.EQ.-6.AND.(LB1.EQ.3.OR.LB2.EQ.3)) )THEN
2917             LB(I)=13
2918            go to 304
2919             ENDIF
2920 * (0.2) p+pion(0)-->N*(+)
2921 c            IF(LB(I1)*LB(I2).EQ.4.AND.(LB(I1).EQ.1.OR.LB(I2).EQ.1))THEN
2922             IF(iabs(LB(I1)*LB(I2)).EQ.4.AND.
2923      &           (LB(I1).EQ.4.OR.LB(I2).EQ.4))THEN
2924             LB(I)=13
2925            go to 304
2926             ENDIF
2927 * (0.3) n+pion(0)-->N*(0)
2928 c            IF(LB(I1)*LB(I2).EQ.8.AND.(LB(I1).EQ.2.OR.LB(I2).EQ.2))THEN
2929             IF(iabs(LB(I1)*LB(I2)).EQ.8.AND.
2930      &           (LB(I1).EQ.4.OR.LB(I2).EQ.4))THEN
2931             LB(I)=12
2932            go to 304
2933             ENDIF
2934 * (0.4) p+pion(-)-->N*(0)
2935 c            IF(LB(I1)*LB(I2).EQ.3)THEN
2936             IF( (LB(I1)*LB(I2).EQ.3)
2937      &      .OR.(LB(I1)*LB(I2).EQ.-5) )THEN
2938             LB(I)=12
2939            go to 304
2940            endif
2941 * (0.5) p+eta-->N*(+)(1535),n+eta-->N*(0)(1535)
2942            if(lb(i1)*lb(i2).eq.0)then
2943 c            if((lb(i1).eq.1).or.(lb(i2).eq.1))then
2944             if(iabs(lb(i1)).eq.1.or.iabs(lb(i2)).eq.1)then
2945            LB(I)=13
2946            go to 304
2947            ELSE
2948            LB(I)=12
2949            ENDIF
2950            endif
2951 304         CALL DRESON(I1,I2)
2952             if(LB1.lt.0.or.LB2.lt.0) LB(I)=-LB(I)
2953             lres=lres+1
2954             GO TO 101
2955 *COM: GO TO 101 TO CHANGE THE PHASE SPACE DENSITY OF THE NUCLEON
2956             ENDIF
2957 *DELTA IS PRODUCED,IN THE FOLLOWING WE DETERMINE THE
2958 *CHARGE STATE OF THE PRODUCED DELTA
2959 99      LRES=LRES+1
2960         I=I1
2961         IF(EM1.LE.0.6)I=I2
2962 * (1) p+pion(+)-->DELTA(++)
2963 c        IF(LB(I1)*LB(I2).EQ.5)THEN
2964             IF( (LB(I1)*LB(I2).EQ.5)
2965      &      .OR.(LB(I1)*LB(I2).EQ.-3) )THEN
2966         LB(I)=9
2967        go to 305
2968         ENDIF
2969 * (2) p+pion(0)-->delta(+)
2970 c        IF(LB(I1)*LB(I2).EQ.4.AND.(LB(I1).EQ.1.OR.LB(I2).EQ.1))then
2971        IF(iabs(LB(I1)*LB(I2)).EQ.4.AND.(LB(I1).EQ.4.OR.LB(I2).EQ.4))then
2972         LB(I)=8
2973        go to 305
2974         ENDIF
2975 * (3) n+pion(+)-->delta(+)
2976 c        IF(LB(I1)*LB(I2).EQ.10.AND.(LB(I1).EQ.2.OR.LB(I2).EQ.2))THEN
2977        IF( (LB(I1)*LB(I2).EQ.10.AND.(LB(I1).EQ.5.OR.LB(I2).EQ.5))
2978      & .OR.(LB(I1)*LB(I2).EQ.-6.AND.(LB(I1).EQ.3.OR.LB(I2).EQ.3)) )THEN
2979         LB(I)=8
2980        go to 305
2981         ENDIF
2982 * (4) n+pion(0)-->delta(0)
2983 c        IF(LB(I1)*LB(I2).EQ.8.AND.(LB(I1).EQ.2.OR.LB(I2).EQ.2))THEN
2984        IF(iabs(LB(I1)*LB(I2)).EQ.8.AND.(LB(I1).EQ.4.OR.LB(I2).EQ.4))THEN
2985         LB(I)=7
2986        go to 305
2987         ENDIF
2988 * (5) p+pion(-)-->delta(0)
2989 c        IF(LB(I1)*LB(I2).EQ.3)THEN
2990             IF( (LB(I1)*LB(I2).EQ.3)
2991      &      .OR.(LB(I1)*LB(I2).EQ.-5) )THEN
2992         LB(I)=7
2993        go to 305
2994         ENDIF
2995 * (6) n+pion(-)-->delta(-)
2996 c        IF(LB(I1)*LB(I2).EQ.6.AND.(LB(I1).EQ.2.OR.LB(I2).EQ.2))THEN
2997        IF( (LB(I1)*LB(I2).EQ.6.AND.(LB(I1).EQ.3.OR.LB(I2).EQ.3))
2998      & .OR.(LB(I1)*LB(I2).EQ.-10.AND.(LB(I1).EQ.5.OR.LB(I2).EQ.5)) )THEN
2999         LB(I)=6
3000         ENDIF
3001 305     CALL DRESON(I1,I2)
3002         if(LB1.lt.0.or.LB2.lt.0) LB(I)=-LB(I)
3003        GO TO 101
3004
3005 csp-11/08/01 K*
3006 * FOR kaON+pion COLLISIONS, form K* (bar) or
3007 c La/Si-bar + N <-- pi + K+
3008 c La/Si + N-bar <-- pi + K-
3009 c phi + K <-- pi + K
3010 clin (rho,omega) + K* <-- pi + K
3011 889       CONTINUE
3012         PX1CM=PCX
3013         PY1CM=PCY
3014         PZ1CM=PCZ
3015         EC=(em1+em2+0.02)**2
3016 * the cross section is from C.M. Ko, PRC 23, 2760 (1981).
3017        spika=60./(1.+4.*(srt-0.895)**2/(0.05)**2)
3018 c
3019 cc       if(lb(i1).eq.23.or.lb(i2).eq.23)then   !! block  K- + pi->La + B-bar
3020
3021         call Crkpla(PX1CM,PY1CM,PZ1CM,EC,SRT,spika,
3022      &                  emm1,emm2,lbp1,lbp2,I1,I2,icase,srhoks)
3023 cc
3024 c* only K* or K*bar formation
3025 c       else
3026 c      DSkn=SQRT(spika/PI/10.)
3027 c      dsknr=dskn+0.1
3028 c      CALL DISTCE(I1,I2,dsknr,DSkn,DT,EC,SRT,IC,
3029 c    1     PX1CM,PY1CM,PZ1CM)
3030 c        IF(IC.EQ.-1) GO TO 400
3031 c       icase = 1
3032 c      endif
3033 c
3034          if(icase .eq. 0) then
3035             iblock=0
3036             go to 400
3037          endif
3038
3039        if(icase .eq. 1)then
3040              call KSRESO(I1,I2)
3041 clin-4/30/03 give non-zero iblock for resonance selections:
3042              iblock = 171
3043 ctest off for resonance (phi, K*) studies:
3044 c             if(iabs(lb(i1)).eq.30) then
3045 c             write(17,112) 'ks',lb(i1),p(1,i1),p(2,i1),p(3,i1),e(i1),nt
3046 c             elseif(iabs(lb(i2)).eq.30) then
3047 c             write(17,112) 'ks',lb(i2),p(1,i2),p(2,i2),p(3,i2),e(i2),nt
3048 c             endif
3049 c
3050               lres=lres+1
3051               go to 101
3052        elseif(icase .eq. 2)then
3053              iblock = 71
3054 c
3055 * La/Si (bar) formation
3056
3057        elseif(iabs(icase).eq.5)then
3058              iblock = 88
3059
3060        else
3061 *
3062 * phi formation
3063              iblock = 222
3064        endif
3065              LB(I1) = lbp1
3066              LB(I2) = lbp2
3067              E(I1) = emm1
3068              E(I2) = emm2
3069              em1=e(i1)
3070              em2=e(i2)
3071              ntag = 0
3072              go to 440
3073 c
3074 33       continue
3075        em1=e(i1)
3076        em2=e(i2)
3077 * (1) if rho or omega collide with a nucleon we allow both elastic
3078 *     scattering and kaon production to happen if collision conditions
3079 *     are satisfied.
3080 * (2) if rho or omega collide with a baryon resonance we allow
3081 *     kaon production, pion reabsorption: rho(omega)+D(N*)-->pion+N
3082 *     and NO elastic scattering to happen
3083            xelstc=0
3084             if((lb1.ge.25.and.lb1.le.28).and.
3085      &    (iabs(lb2).eq.1.or.iabs(lb2).eq.2))
3086      &      xelstc=ERHON(EM1,EM2,LB1,LB2,SRT)
3087             if((lb2.ge.25.and.lb2.le.28).and.
3088      &   (iabs(lb1).eq.1.or.iabs(lb1).eq.2))
3089      &      xelstc=ERHON(EM1,EM2,LB1,LB2,SRT)
3090             ec=(em1+em2+0.02)**2
3091 * the kaon production cross section is
3092            xkaon0=0
3093            if(srt.ge.1.63.AND.SRT.LE.1.7)xkaon0=pnlka(srt)
3094            IF(SRT.GT.1.7)XKAON0=PNLKA(SRT)+pnska(srt)
3095            if(xkaon0.lt.0)xkaon0=0
3096
3097 cbz3/7/99 neutralk
3098             XKAON0 = 2.0 * XKAON0
3099 cbz3/7/99 neutralk end
3100
3101 * the total inelastic cross section for rho(omega)+N is
3102            xkaon=xkaon0
3103            ichann=0
3104 * the total inelastic cross section for rho (omega)+D(N*) is
3105 * xkaon=xkaon0+reab(**)
3106
3107 c sp11/21/01  phi production: rho + N(D) -> phi + N(D)
3108          Xphi = 0.
3109        if( ( (((lb1.ge.1.and.lb1.le.2).or.
3110      &         (lb1.ge.6.and.lb1.le.9))
3111      &         .and.(lb2.ge.25.and.lb2.le.27))
3112      &   .OR.(((lb2.ge.1.and.lb2.le.2).or.
3113      &         (lb2.ge.6.and.lb2.le.9))
3114      &        .and.(lb1.ge.25.and.lb1.le.27)) ).AND. srt.gt.1.958)
3115      &    call pibphi(srt,lb1,lb2,em1,em2,Xphi,xphin)
3116 c !! in fm^2 above
3117 c
3118         if((iabs(lb1).ge.6.and.lb2.ge.25).or.
3119      &    (lb1.ge.25.and.iabs(lb2).ge.6))then
3120            ichann=1
3121            ictrl=2
3122            if(lb1.eq.28.or.lb2.eq.28)ictrl=3
3123             xreab=reab(i1,i2,srt,ictrl)
3124
3125 clin-12/02/00 to satisfy detailed balance, forbid N* absorptions:
3126             if((iabs(lb1).ge.10.and.iabs(lb1).le.13)
3127      1           .or.(iabs(lb2).ge.10.and.iabs(lb2).le.13)) XREAB = 0.
3128
3129         if(xreab.lt.0)xreab=1.E-06
3130             xkaon=xkaon0+xreab
3131           XELSTC=1.0
3132            endif
3133             DS=SQRT((XKAON+Xphi+xelstc)/PI)
3134 c
3135 csp09/20/01
3136 c           totcr = xelstc+xkaon
3137 c           if(srt .gt. 3.5)totcr = max1(totcr,3.)
3138 c           DS=SQRT(totcr/PI)
3139 csp09/20/01 end
3140 c
3141         DELTAR=DS+0.1
3142        px1cm=pcx
3143        py1cm=pcy
3144        pz1cm=pcz
3145 * CHECK IF the collision can happen
3146          CALL DISTCE(I1,I2,DELTAR,DS,DT,EC,SRT,IC,
3147      1   PCX,PCY,PCZ)
3148          IF(IC.EQ.-1) GO TO 400
3149         ekaon(4,iss)=ekaon(4,iss)+1
3150 c*
3151 * NOW rho(omega)+N or D(N*) COLLISION IS POSSIBLE
3152 * (1) check elastic collision
3153        if(xelstc/(xelstc+xkaon+Xphi).gt.RANART(NSEED))then
3154 c       call crdir(px1CM,py1CM,pz1CM,srt,I1,i2)
3155        call crdir(px1CM,py1CM,pz1CM,srt,I1,i2,IBLOCK)
3156        go to 440
3157        endif
3158 * (2) check pion absorption or kaon production
3159         CALL CRRD(PX1CM,PY1CM,PZ1CM,SRT,I1,I2,
3160      1  IBLOCK,xkaon0,xkaon,Xphi,xphin)
3161
3162 * kaon production
3163 csp05/16/01
3164        IF(IBLOCK.EQ.7) then
3165           LPN=LPN+1
3166        elseIF(IBLOCK.EQ.-7) then
3167        endif
3168 csp05/16/01 end
3169 * rho obsorption
3170        if(iblock.eq.81) lrhor=lrhor+1
3171 * omega obsorption
3172        if(iblock.eq.82) lomgar=lomgar+1
3173        em1=e(i1)
3174        em2=e(i2)
3175        GO TO 440
3176 * for pion+n now using the subroutine crpn to change
3177 * the particle label and set the new momentum of L/S+K final state
3178 95       continue
3179 * NOW PION+N INELASTIC COLLISION IS POSSIBLE
3180 * check pion production or kaon production
3181         CALL CRPN(PX1CM,PY1CM,PZ1CM,SRT,I1,I2,
3182      1  IBLOCK,xkaon0,xkaon,Xphi,xphin)
3183
3184 * kaon production
3185 csp05/16/01
3186        IF(IBLOCK.EQ.7) then
3187           LPN=LPN+1
3188        elseIF(IBLOCK.EQ.-7) then
3189        endif
3190 csp05/16/01 end
3191 * pion production
3192        if(iblock.eq.77) lpd=lpd+1
3193 * rho production
3194        if(iblock.eq.78) lrho=lrho+1
3195 * omega production
3196        if(iblock.eq.79) lomega=lomega+1
3197        em1=e(i1)
3198        em2=e(i2)
3199        GO TO 440
3200 * for pion+D(N*) now using the subroutine crpd to
3201 * (1) check kaon production or pion reabsorption
3202 * (2) change the particle label and set the new
3203 *     momentum of L/S+K final state
3204 96       continue
3205         CALL CRPD(PX1CM,PY1CM,PZ1CM,SRT,I1,I2,
3206      1  IBLOCK,xkaon0,xkaon,Xphi,xphin)
3207
3208 * kaon production
3209 csp05/16/01
3210        IF(IBLOCK.EQ.7) then
3211           LPN=LPN+1
3212        elseIF(IBLOCK.EQ.-7) then
3213        endif
3214 csp05/16/01 end
3215 * pion obserption
3216        if(iblock.eq.80) lpdr=lpdr+1
3217        em1=e(i1)
3218        em2=e(i2)
3219        GO TO 440
3220 * CALCULATE KAON PRODUCTION PROBABILITY FROM PION + N COLLISIONS
3221 C        IF(SRT.GT.1.615)THEN
3222 C        CALL PKAON(SRT,XXp,PK)
3223 C        TKAON(7)=TKAON(7)+PK
3224 C        EKAON(7,ISS)=EKAON(7,ISS)+1
3225 c        CALL KSPEC1(SRT,PK)
3226 C        call LK(3,srt,iseed,pk)
3227 C        ENDIF
3228 * negelecting the pauli blocking at high energies
3229
3230 101       continue
3231         IF(E(I2).EQ.0.)GO TO 600
3232         IF(E(I1).EQ.0.)GO TO 800
3233 * IF NUCLEON+BARYON RESONANCE COLLISIONS
3234 44      CONTINUE
3235 * CALCULATE THE TOTAL CROSS SECTION OF NUCLEON+ BARYON RESONANCE COLLISION
3236 * WE ASSUME THAT THE ELASTIC CROSS SECTION IS THE SAME AS NUCLEON+NUCLEON
3237 * COM: WE USE THE PARAMETERISATION BY CUGNON FOR LOW ENERGIES
3238 *      AND THE PARAMETERIZATIONS FROM CERN DATA BOOK FOR HIGHER
3239 *      ENERGIES. THE CUTOFF FOR THE TOTAL CROSS SECTION IS 55 MB
3240        cutoff=em1+em2+0.02
3241        IF(SRT.LE.CUTOFF)GO TO 400
3242         IF(SRT.GT.2.245)THEN
3243        SIGNN=PP2(SRT)
3244        ELSE
3245         SIGNN = 35.0 / (1. + (SRT - CUTOFF) * 100.0)  +  20.0
3246        ENDIF
3247         call XND(pcx,pcy,pcz,srt,I1,I2,xinel,
3248      &               sigk,xsk1,xsk2,xsk3,xsk4,xsk5)
3249        sig=signn+xinel
3250 * For nucleon+baryon resonance collision, the minimum cms**2 energy is
3251         EC=(EM1+EM2+0.02)**2
3252 * CHECK THE DISTENCE BETWEEN THE TWO PARTICLES
3253         PX1CM=PCX
3254         PY1CM=PCY
3255         PZ1CM=PCZ
3256
3257 clin-6/2008 Deuteron production:
3258         ianti=0
3259         if(lb(i1).lt.0 .and. lb(i2).lt.0) ianti=1
3260         call sbbdm(srt,sdprod,ianti,lbm,xmm,pfinal)
3261         sig=sig+sdprod
3262 clin-6/2008 perturbative treatment of deuterons:
3263         ipdflag=0
3264         if(idpert.eq.1) then
3265            ipert1=1
3266            sigr0=sig
3267            dspert=sqrt(sigr0/pi/10.)
3268            dsrpert=dspert+0.1
3269            CALL DISTCE(I1,I2,dsrpert,dspert,DT,EC,SRT,IC,
3270      1          PX1CM,PY1CM,PZ1CM)
3271            IF(IC.EQ.-1) GO TO 363
3272            signn0=0.
3273            CALL CRND(IRUN,PX1CM,PY1CM,PZ1CM,SRT,I1,I2,
3274      &  IBLOCK,SIGNN0,SIGr0,sigk,xsk1,xsk2,xsk3,xsk4,xsk5,NT,ipert1)
3275 c     &  IBLOCK,SIGNN,SIG,sigk,xsk1,xsk2,xsk3,xsk4,xsk5)
3276            ipdflag=1
3277  363       continue
3278            ipert1=0
3279         endif
3280         if(idpert.eq.2) ipert1=1
3281 c
3282         DS=SQRT(SIG/(10.*PI))
3283         DELTAR=DS+0.1
3284         CALL DISTCE(I1,I2,DELTAR,DS,DT,EC,SRT,IC,
3285      1  PX1CM,PY1CM,PZ1CM)
3286 c        IF(IC.EQ.-1)GO TO 400
3287         IF(IC.EQ.-1) then
3288            if(ipdflag.eq.1) iblock=501
3289            GO TO 400
3290         endif
3291
3292         ekaon(3,iss)=ekaon(3,iss)+1
3293 * CALCULATE KAON PRODUCTION PROBABILITY FROM NUCLEON + BARYON RESONANCE
3294 * COLLISIONS
3295         go to 361
3296
3297 * CHECK WHAT KIND OF COLLISION HAS HAPPENED
3298  361    continue
3299         CALL CRND(IRUN,PX1CM,PY1CM,PZ1CM,SRT,I1,I2,
3300      &     IBLOCK,SIGNN,SIG,sigk,xsk1,xsk2,xsk3,xsk4,xsk5,NT,ipert1)
3301 c     &  IBLOCK,SIGNN,SIG,sigk,xsk1,xsk2,xsk3,xsk4,xsk5)
3302         IF(iblock.eq.0.and.ipdflag.eq.1) iblock=501
3303         IF(IBLOCK.EQ.11)THEN
3304            LNDK=LNDK+1
3305            GO TO 400
3306 c        elseIF(IBLOCK.EQ.-11) then
3307         elseIF(IBLOCK.EQ.-11.or.iblock.eq.501) then
3308            GO TO 400
3309         ENDIF
3310         if(iblock .eq. 222)then
3311 c    !! sp12/17/01
3312            GO TO 400
3313         ENDIF
3314         em1=e(i1)
3315         em2=e(i2)
3316         GO TO 440
3317 * IF NUCLEON+NUCLEON OR BARYON RESONANCE+BARYON RESONANCE COLLISIONS
3318 4       CONTINUE
3319 * PREPARE THE EALSTIC CROSS SECTION FOR BARYON+BARYON COLLISIONS
3320 * COM: WE USE THE PARAMETERISATION BY CUGNON FOR SRT LEQ 2.0 GEV
3321 *      AND THE PARAMETERIZATIONS FROM CERN DATA BOOK FOR HIGHER
3322 *      ENERGIES. THE CUTOFF FOR THE TOTAL CROSS SECTION IS 55 MB
3323 *      WITH LOW-ENERGY-CUTOFF
3324         CUTOFF=em1+em2+0.14
3325 * AT HIGH ENERGIES THE ISOSPIN DEPENDENCE IS NEGLIGIBLE
3326 * THE TOTAL CROSS SECTION IS TAKEN AS THAT OF THE PP
3327 * ABOVE E_KIN=800 MEV, WE USE THE ISOSPIN INDEPENDNET XSECTION
3328         IF(SRT.GT.2.245)THEN
3329            SIG=ppt(srt)
3330            SIGNN=SIG-PP1(SRT)
3331         ELSE
3332 * AT LOW ENERGIES THE ISOSPIN DEPENDENCE FOR NN COLLISION IS STRONG
3333            SIG=XPP(SRT)
3334            IF(ZET(LB(I1))*ZET(LB(I2)).LE.0)SIG=XNP(SRT)
3335            IF(ZET(LB(I1))*ZET(LB(I2)).GT.0)SIG=XPP(SRT)
3336            IF(ZET(LB(I1)).EQ.0.
3337      &          AND.ZET(LB(I2)).EQ.0)SIG=XPP(SRT)
3338            if((lb(i1).eq.-1.and.lb(i2).eq.-2) .or.
3339      &          (lb(i2).eq.-1.and.lb(i1).eq.-2))sig=xnp(srt)
3340 *     WITH LOW-ENERGY-CUTOFF
3341            IF (SRT .LT. 1.897) THEN
3342               SIGNN = SIG
3343            ELSE
3344               SIGNN = 35.0 / (1. + (SRT - 1.897) * 100.0)  +  20.0
3345            ENDIF
3346         ENDIF
3347         PX1CM=PCX
3348         PY1CM=PCY
3349         PZ1CM=PCZ
3350 clin-5/2008 Deuteron production cross sections were not included
3351 c     in the previous parameterized inelastic cross section of NN collisions
3352 c     (SIGinel=SIG-SIGNN), so they are added here:
3353         ianti=0
3354         if(lb(i1).lt.0 .and. lb(i2).lt.0) ianti=1
3355         call sbbdm(srt,sdprod,ianti,lbm,xmm,pfinal)
3356         sig=sig+sdprod
3357 c
3358 clin-5/2008 perturbative treatment of deuterons:
3359         ipdflag=0
3360         if(idpert.eq.1) then
3361 c     For idpert=1: ipert1=1 means we will first treat deuteron perturbatively,
3362 c     then we set ipert1=0 to treat regular NN or NbarNbar collisions including
3363 c     the regular deuteron productions.
3364 c     ipdflag=1 means perturbative deuterons are produced here:
3365            ipert1=1
3366            EC=2.012**2
3367 c     Use the same cross section for NN/NNBAR collisions
3368 c     to trigger perturbative production
3369            sigr0=sig
3370 c     One can also trigger with X*sbbdm() so the weight will not be too small;
3371 c     but make sure to limit the maximum trigger Xsec:
3372 c           sigr0=sdprod*25.
3373 c           if(sigr0.ge.100.) sigr0=100.
3374            dspert=sqrt(sigr0/pi/10.)
3375            dsrpert=dspert+0.1
3376            CALL DISTCE(I1,I2,dsrpert,dspert,DT,EC,SRT,IC,
3377      1          PX1CM,PY1CM,PZ1CM)
3378            IF(IC.EQ.-1) GO TO 365
3379            signn0=0.
3380            CALL CRNN(IRUN,PX1CM,PY1CM,PZ1CM,SRT,I1,I2,IBLOCK,
3381      1          NTAG,signn0,sigr0,NT,ipert1)
3382            ipdflag=1
3383  365       continue
3384            ipert1=0
3385         endif
3386         if(idpert.eq.2) ipert1=1
3387 c
3388 clin-5/2008 in case perturbative deuterons are produced for idpert=1:
3389 c        IF(SIGNN.LE.0)GO TO 400
3390         IF(SIGNN.LE.0) then
3391            if(ipdflag.eq.1) iblock=501
3392            GO TO 400
3393         endif
3394 c
3395         EC=3.59709
3396         ds=sqrt(sig/pi/10.)
3397         dsr=ds+0.1
3398         IF((E(I1).GE.1.).AND.(e(I2).GE.1.))EC=4.75
3399         CALL DISTCE(I1,I2,dsr,ds,DT,EC,SRT,IC,
3400      1       PX1CM,PY1CM,PZ1CM)
3401 clin-5/2008 in case perturbative deuterons are produced above:
3402 c        IF(IC.EQ.-1) GO TO 400
3403         IF(IC.EQ.-1) then
3404            if(ipdflag.eq.1) iblock=501
3405            GO TO 400
3406         endif
3407 c
3408 * CALCULATE KAON PRODUCTION PROBABILITY FROM NUCLEON+NUCLEON OR
3409 * RESONANCE+RESONANCE COLLISIONS
3410         go to 362
3411
3412 C CHECK WHAT KIND OF COLLISION HAS HAPPENED
3413  362    ekaon(1,iss)=ekaon(1,iss)+1
3414         CALL CRNN(IRUN,PX1CM,PY1CM,PZ1CM,SRT,I1,I2,IBLOCK,
3415      1       NTAG,SIGNN,SIG,NT,ipert1)
3416 clin-5/2008 give iblock # in case pert deuterons are produced for idpert=1:
3417         IF(iblock.eq.0.and.ipdflag.eq.1) iblock=501
3418 clin-5/2008 add iblock # for deuteron formation:
3419 c        IF(IBLOCK.EQ.4.OR.IBLOCK.Eq.9.or.iblock.ge.44.OR.IBLOCK.EQ.-9
3420 c     &       .or.iblock.eq.222)THEN
3421         IF(IBLOCK.EQ.4.OR.IBLOCK.Eq.9.or.iblock.ge.44.OR.IBLOCK.EQ.-9
3422      &       .or.iblock.eq.222.or.iblock.eq.501)THEN
3423 c
3424 c     !! sp12/17/01 above
3425 * momentum of the three particles in the final state have been calculated
3426 * in the crnn, go out of the loop
3427            LCOLL=LCOLL+1
3428            if(iblock.eq.4)then
3429               LDIRT=LDIRT+1
3430            elseif(iblock.eq.44)then
3431               LDdrho=LDdrho+1
3432            elseif(iblock.eq.45)then
3433               Lnnrho=Lnnrho+1
3434            elseif(iblock.eq.46)then
3435               Lnnom=Lnnom+1
3436            elseif(iblock .eq. 222)then
3437            elseIF(IBLOCK.EQ.9) then
3438               LNNK=LNNK+1
3439            elseIF(IBLOCK.EQ.-9) then
3440            endif
3441            GO TO 400
3442         ENDIF
3443
3444         em1=e(i1)
3445         em2=e(i2)
3446         GO TO 440
3447 clin-8/2008 B+B->Deuteron+Meson over
3448 c
3449 clin-8/2008 Deuteron+Meson->B+B collisions:
3450  505    continue
3451         ianti=0
3452         if(lb(i1).lt.0 .or. lb(i2).lt.0) ianti=1
3453         call sdmbb(SRT,sdm,ianti)
3454         PX1CM=PCX
3455         PY1CM=PCY
3456         PZ1CM=PCZ
3457 c     minimum srt**2, note a 2.012GeV lower cutoff is used in N+N->Deuteron+pi:
3458         EC=2.012**2
3459         ds=sqrt(sdm/31.4)
3460         dsr=ds+0.1
3461         CALL DISTCE(I1,I2,dsr,ds,DT,EC,SRT,IC,PX1CM,PY1CM,PZ1CM)
3462         IF(IC.EQ.-1) GO TO 400
3463         CALL crdmbb(PX1CM,PY1CM,PZ1CM,SRT,I1,I2,IBLOCK,
3464      1       NTAG,sdm,NT,ianti)
3465         LCOLL=LCOLL+1
3466         GO TO 400
3467 clin-8/2008 Deuteron+Meson->B+B collisions over
3468 c
3469 clin-9/2008 Deuteron+Baryon elastic collisions:
3470  506    continue
3471         ianti=0
3472         if(lb(i1).lt.0 .or. lb(i2).lt.0) ianti=1
3473         call sdbelastic(SRT,sdb)
3474         PX1CM=PCX
3475         PY1CM=PCY
3476         PZ1CM=PCZ
3477 c     minimum srt**2, note a 2.012GeV lower cutoff is used in N+N->Deuteron+pi:
3478         EC=2.012**2
3479         ds=sqrt(sdb/31.4)
3480         dsr=ds+0.1
3481         CALL DISTCE(I1,I2,dsr,ds,DT,EC,SRT,IC,PX1CM,PY1CM,PZ1CM)
3482         IF(IC.EQ.-1) GO TO 400
3483         CALL crdbel(PX1CM,PY1CM,PZ1CM,SRT,I1,I2,IBLOCK,
3484      1       NTAG,sdb,NT,ianti)
3485         LCOLL=LCOLL+1
3486         GO TO 400
3487 clin-9/2008 Deuteron+Baryon elastic collisions over
3488 c
3489 * IF BARYON RESONANCE+BARYON RESONANCE COLLISIONS
3490  444    CONTINUE
3491 * PREPARE THE EALSTIC CROSS SECTION FOR BARYON+BARYON COLLISIONS
3492        CUTOFF=em1+em2+0.02
3493 * AT HIGH ENERGIES THE ISOSPIN DEPENDENCE IS NEGLIGIBLE
3494 * THE TOTAL CROSS SECTION IS TAKEN AS THAT OF THE PP
3495        IF(SRT.LE.CUTOFF)GO TO 400
3496         IF(SRT.GT.2.245)THEN
3497        SIGNN=PP2(SRT)
3498        ELSE
3499         SIGNN = 35.0 / (1. + (SRT - CUTOFF) * 100.0)  +  20.0
3500        ENDIF
3501        IF(SIGNN.LE.0)GO TO 400
3502       CALL XDDIN(PCX,PCY,PCZ,SRT,I1,I2,
3503      &XINEL,SIGK,XSK1,XSK2,XSK3,XSK4,XSK5)
3504        SIG=SIGNN+XINEL
3505        EC=(EM1+EM2+0.02)**2
3506         PX1CM=PCX
3507         PY1CM=PCY
3508         PZ1CM=PCZ
3509
3510 clin-6/2008 Deuteron production:
3511         ianti=0
3512         if(lb(i1).lt.0 .and. lb(i2).lt.0) ianti=1
3513         call sbbdm(srt,sdprod,ianti,lbm,xmm,pfinal)
3514         sig=sig+sdprod
3515 clin-6/2008 perturbative treatment of deuterons:
3516         ipdflag=0
3517         if(idpert.eq.1) then
3518            ipert1=1
3519            sigr0=sig
3520            dspert=sqrt(sigr0/pi/10.)
3521            dsrpert=dspert+0.1
3522            CALL DISTCE(I1,I2,dsrpert,dspert,DT,EC,SRT,IC,
3523      1          PX1CM,PY1CM,PZ1CM)
3524            IF(IC.EQ.-1) GO TO 367
3525            signn0=0.
3526            CALL CRDD(IRUN,PX1CM,PY1CM,PZ1CM,SRT,I1,I2,
3527      1          IBLOCK,NTAG,SIGNN0,SIGr0,NT,ipert1)
3528 c     1          IBLOCK,NTAG,SIGNN,SIG)
3529            ipdflag=1
3530  367       continue
3531            ipert1=0
3532         endif
3533         if(idpert.eq.2) ipert1=1
3534 c
3535         ds=sqrt(sig/31.4)
3536         dsr=ds+0.1
3537         CALL DISTCE(I1,I2,dsr,ds,DT,EC,SRT,IC,
3538      1  PX1CM,PY1CM,PZ1CM)
3539 c        IF(IC.EQ.-1) GO TO 400
3540         IF(IC.EQ.-1) then
3541            if(ipdflag.eq.1) iblock=501
3542            GO TO 400
3543         endif
3544
3545 * CALCULATE KAON PRODUCTION PROBABILITY FROM NUCLEON+NUCLEON OR
3546 * RESONANCE+RESONANCE COLLISIONS
3547        go to 364
3548
3549 C CHECK WHAT KIND OF COLLISION HAS HAPPENED
3550 364       ekaon(2,iss)=ekaon(2,iss)+1
3551 * for resonance+resonance
3552 clin-6/2008:
3553         CALL CRDD(IRUN,PX1CM,PY1CM,PZ1CM,SRT,I1,I2,
3554      1  IBLOCK,NTAG,SIGNN,SIG,NT,ipert1)
3555 c     1  IBLOCK,NTAG,SIGNN,SIG)
3556         IF(iblock.eq.0.and.ipdflag.eq.1) iblock=501
3557 c
3558         IF(iabs(IBLOCK).EQ.10)THEN
3559 * momentum of the three particles in the final state have been calculated
3560 * in the crnn, go out of the loop
3561            LCOLL=LCOLL+1
3562            IF(IBLOCK.EQ.10)THEN
3563               LDDK=LDDK+1
3564            elseIF(IBLOCK.EQ.-10) then
3565            endif
3566            GO TO 400
3567         ENDIF
3568 clin-6/2008
3569 c        if(iblock .eq. 222)then
3570         if(iblock .eq. 222.or.iblock.eq.501)then
3571 c    !! sp12/17/01
3572            GO TO 400
3573         ENDIF
3574         em1=e(i1)
3575         em2=e(i2)
3576         GO TO 440
3577 * FOR PION+PION,pion+eta, eta+eta and rho(omega)+pion(rho,omega) or eta
3578 777       CONTINUE
3579         PX1CM=PCX
3580         PY1CM=PCY
3581         PZ1CM=PCZ
3582 * energy thresh for collisions
3583        ec0=em1+em2+0.02
3584        IF(SRT.LE.ec0)GO TO 400
3585        ec=(em1+em2+0.02)**2
3586 * we negelect the elastic collision between mesons except that betwen
3587 * two pions because of the lack of information about these collisions
3588 * However, we do let them to collide inelastically to produce kaons
3589 clin-8/15/02       ppel=1.e-09
3590        ppel=20.
3591         ipp=1
3592        if(lb1.lt.3.or.lb1.gt.5.or.lb2.lt.3.or.lb2.gt.5)go to 778
3593        CALL PPXS(LB1,LB2,SRT,PPSIG,spprho,IPP)
3594        ppel=ppsig
3595 778       ppink=pipik(srt)
3596
3597 * pi+eta and eta+eta are assumed to be the same as pipik( for pi+pi -> K+K-)
3598 * estimated from Ko's paper:
3599         ppink = 2.0 * ppink
3600        if(lb1.ge.25.and.lb2.ge.25) ppink=rrkk
3601
3602 clin-2/13/03 include omega the same as rho, eta the same as pi:
3603 c        if(((lb1.ge.3.and.lb1.le.5).and.(lb2.ge.25.and.lb2.le.27))
3604 c     1  .or.((lb2.ge.3.and.lb2.le.5).and.(lb1.ge.25.and.lb1.le.27)))
3605         if( ( (lb1.eq.0.or.(lb1.ge.3.and.lb1.le.5))
3606      1       .and.(lb2.ge.25.and.lb2.le.28))
3607      2       .or. ( (lb2.eq.0.or.(lb2.ge.3.and.lb2.le.5))
3608      3       .and.(lb1.ge.25.and.lb1.le.28))) then
3609            ppink=0.
3610            if(srt.ge.(aka+aks)) ppink = prkk
3611         endif
3612
3613 c pi pi <-> rho rho:
3614         call spprr(lb1,lb2,srt)
3615 clin-4/03/02 pi pi <-> eta eta:
3616         call sppee(lb1,lb2,srt)
3617 clin-4/03/02 pi pi <-> pi eta:
3618         call spppe(lb1,lb2,srt)
3619 clin-4/03/02 rho pi <-> rho eta:
3620         call srpre(lb1,lb2,srt)
3621 clin-4/03/02 omega pi <-> omega eta:
3622         call sopoe(lb1,lb2,srt)
3623 clin-4/03/02 rho rho <-> eta eta:
3624         call srree(lb1,lb2,srt)
3625
3626         ppinnb=0.
3627         if(srt.gt.thresh(1)) then
3628            call getnst(srt)
3629            if(lb1.ge.3.and.lb1.le.5.and.lb2.ge.3.and.lb2.le.5) then
3630               ppinnb=ppbbar(srt)
3631            elseif((lb1.ge.3.and.lb1.le.5.and.lb2.ge.25.and.lb2.le.27)
3632      1 .or.(lb2.ge.3.and.lb2.le.5.and.lb1.ge.25.and.lb1.le.27)) then
3633               ppinnb=prbbar(srt)
3634            elseif(lb1.ge.25.and.lb1.le.27
3635      1             .and.lb2.ge.25.and.lb2.le.27) then
3636               ppinnb=rrbbar(srt)
3637            elseif((lb1.ge.3.and.lb1.le.5.and.lb2.eq.28)
3638      1             .or.(lb2.ge.3.and.lb2.le.5.and.lb1.eq.28)) then
3639               ppinnb=pobbar(srt)
3640            elseif((lb1.ge.25.and.lb1.le.27.and.lb2.eq.28)
3641      1             .or.(lb2.ge.25.and.lb2.le.27.and.lb1.eq.28)) then
3642               ppinnb=robbar(srt)
3643            elseif(lb1.eq.28.and.lb2.eq.28) then
3644               ppinnb=oobbar(srt)
3645            else
3646               if(lb1.ne.0.and.lb2.ne.0)
3647      1             write(6,*) 'missed MM lb1,lb2=',lb1,lb2
3648            endif
3649         endif
3650         ppin=ppink+ppinnb+pprr+ppee+pppe+rpre+xopoe+rree
3651
3652 * check if a collision can happen
3653        if((ppel+ppin).le.0.01)go to 400
3654        DSPP=SQRT((ppel+ppin)/31.4)
3655        dsppr=dspp+0.1
3656         CALL DISTCE(I1,I2,dsppr,DSPP,DT,EC,SRT,IC,
3657      1  PX1CM,PY1CM,PZ1CM)
3658         IF(IC.EQ.-1) GO TO 400
3659        if(ppel.eq.0)go to 400
3660 * the collision can happen
3661 * check what kind collision has happened
3662        ekaon(5,iss)=ekaon(5,iss)+1
3663         CALL CRPP(PX1CM,PY1CM,PZ1CM,SRT,I1,I2,
3664      1  IBLOCK,ppel,ppin,spprho,ipp)
3665
3666 * rho formation, go to 400
3667 c       if(iblock.eq.666)go to 600
3668        if(iblock.eq.666)go to 555
3669        if(iblock.eq.6)LPP=LPP+1
3670        if(iblock.eq.66)then
3671           LPPk=LPPk+1
3672        elseif(iblock.eq.366)then
3673           LPPk=LPPk+1
3674        elseif(iblock.eq.367)then
3675           LPPk=LPPk+1
3676        endif
3677        em1=e(i1)
3678        em2=e(i2)
3679        go to 440
3680
3681 * In this block we treat annihilations of
3682 clin-9/28/00* an anti-nucleon and a baryon or baryon resonance
3683 * an anti-baryon and a baryon (including resonances)
3684 2799        CONTINUE
3685         PX1CM=PCX
3686         PY1CM=PCY
3687         PZ1CM=PCZ
3688         EC=(em1+em2+0.02)**2
3689 clin assume the same cross section (as a function of sqrt s) as for PPbar:
3690
3691 clin-ctest annih maximum
3692 c        DSppb=SQRT(amin1(xppbar(srt),30.)/PI/10.)
3693        DSppb=SQRT(xppbar(srt)/PI/10.)
3694        dsppbr=dsppb+0.1
3695         CALL DISTCE(I1,I2,dsppbr,DSppb,DT,EC,SRT,IC,
3696      1  PX1CM,PY1CM,PZ1CM)
3697         IF(IC.EQ.-1) GO TO 400
3698         CALL Crppba(PX1CM,PY1CM,PZ1CM,SRT,I1,I2,
3699      1  IBLOCK)
3700        em1=e(i1)
3701        em2=e(i2)
3702        go to 440
3703 c
3704 3555    PX1CM=PCX
3705         PY1CM=PCY
3706         PZ1CM=PCZ
3707         EC=(em1+em2+0.02)**2
3708        DSkk=SQRT(SIG/PI/10.)
3709        dskk0=dskk+0.1
3710         CALL DISTCE(I1,I2,dskk0,DSkk,DT,EC,SRT,IC,
3711      1  PX1CM,PY1CM,PZ1CM)
3712         IF(IC.EQ.-1) GO TO 400
3713         CALL Crlaba(PX1CM,PY1CM,PZ1CM,SRT,brel,brsgm,
3714      &                  I1,I2,nt,IBLOCK,nchrg,icase)
3715        em1=e(i1)
3716        em2=e(i2)
3717        go to 440
3718 *
3719 c perturbative production of cascade and omega
3720 3455    PX1CM=PCX
3721         PY1CM=PCY
3722         PZ1CM=PCZ
3723         call pertur(PX1CM,PY1CM,PZ1CM,SRT,IRUN,I1,I2,nt,kp,icontp)
3724         if(icontp .eq. 0)then
3725 c     inelastic collisions:
3726          em1 = e(i1)
3727          em2 = e(i2)
3728          iblock = 727
3729           go to 440
3730         endif
3731 c     elastic collisions:
3732         if (e(i1) .eq. 0.) go to 800
3733         if (e(i2) .eq. 0.) go to 600
3734         go to 400
3735 *
3736 c* phi + N --> pi+N(D),  N(D,N*)+N(D,N*),  K+ +La
3737 c* phi + D --> pi+N(D)
3738 7222        CONTINUE
3739         PX1CM=PCX
3740         PY1CM=PCY
3741         PZ1CM=PCZ
3742         EC=(em1+em2+0.02)**2
3743         CALL XphiB(LB1, LB2, EM1, EM2, SRT,
3744      &             XSK1, XSK2, XSK3, XSK4, XSK5, SIGP)
3745        DSkk=SQRT(SIGP/PI/10.)
3746        dskk0=dskk+0.1
3747         CALL DISTCE(I1,I2,dskk0,DSkk,DT,EC,SRT,IC,
3748      1  PX1CM,PY1CM,PZ1CM)
3749         IF(IC.EQ.-1) GO TO 400
3750         CALL CRPHIB(PX1CM,PY1CM,PZ1CM,SRT,I1,I2,
3751      &     XSK1, XSK2, XSK3, XSK4, XSK5, SIGP, IBLOCK)
3752        em1=e(i1)
3753        em2=e(i2)
3754        go to 440
3755 *
3756 c* phi + M --> K+ + K* .....
3757 7444        CONTINUE
3758         PX1CM=PCX
3759         PY1CM=PCY
3760         PZ1CM=PCZ
3761         EC=(em1+em2+0.02)**2
3762         CALL PHIMES(I1, I2, SRT, XSK1, XSK2, XSK3, XSK4, XSK5,
3763      1     XSK6, XSK7, SIGPHI)
3764        DSkk=SQRT(SIGPHI/PI/10.)
3765        dskk0=dskk+0.1
3766         CALL DISTCE(I1,I2,dskk0,DSkk,DT,EC,SRT,IC,
3767      1  PX1CM,PY1CM,PZ1CM)
3768         IF(IC.EQ.-1) GO TO 400
3769 c*---
3770         PZRT = p(3,i1)+p(3,i2)
3771         ER1 = sqrt( p(1,i1)**2+p(2,i1)**2+p(3,i1)**2+E(i1)**2 )
3772         ER2 = sqrt( p(1,i2)**2+p(2,i2)**2+p(3,i2)**2+E(i2)**2 )
3773         ERT = ER1+ER2
3774         yy = 0.5*log( (ERT+PZRT)/(ERT-PZRT) )
3775 c*------
3776         CALL CRPHIM(PX1CM,PY1CM,PZ1CM,SRT,I1,I2,
3777      &  XSK1, XSK2, XSK3, XSK4, XSK5, XSK6, SIGPHI, IKKG, IKKL, IBLOCK)
3778        em1=e(i1)
3779        em2=e(i2)
3780        go to 440
3781 c
3782 c lambda-N elastic xsection, Li & Ko, PRC 54(1996)1897.
3783  7799    CONTINUE
3784          PX1CM=PCX
3785          PY1CM=PCY
3786          PZ1CM=PCZ
3787          EC=(em1+em2+0.02)**2
3788          call lambar(i1,i2,srt,siglab)
3789         DShn=SQRT(siglab/PI/10.)
3790         dshnr=dshn+0.1
3791          CALL DISTCE(I1,I2,dshnr,DShn,DT,EC,SRT,IC,
3792      1    PX1CM,PY1CM,PZ1CM)
3793         IF(IC.EQ.-1) GO TO 400
3794          CALL Crhb(PX1CM,PY1CM,PZ1CM,SRT,I1,I2,IBLOCK)
3795         em1=e(i1)
3796         em2=e(i2)
3797         go to 440
3798 c
3799 c* K+ + La(Si) --> Meson + B
3800 c* K- + La(Si)-bar --> Meson + B-bar
3801 5699        CONTINUE
3802         PX1CM=PCX
3803         PY1CM=PCY
3804         PZ1CM=PCZ
3805         EC=(em1+em2+0.02)**2
3806         CALL XKHYPE(I1, I2, SRT, XKY1, XKY2, XKY3, XKY4, XKY5,
3807      &     XKY6, XKY7, XKY8, XKY9, XKY10, XKY11, XKY12, XKY13,
3808      &     XKY14, XKY15, XKY16, XKY17, SIGK)
3809        DSkk=SQRT(sigk/PI)
3810        dskk0=dskk+0.1
3811         CALL DISTCE(I1,I2,dskk0,DSkk,DT,EC,SRT,IC,
3812      1  PX1CM,PY1CM,PZ1CM)
3813         IF(IC.EQ.-1) GO TO 400
3814 c
3815        if(lb(i1).eq.23 .or. lb(i2).eq.23)then
3816              IKMP = 1
3817         else
3818              IKMP = -1
3819         endif
3820         CALL Crkhyp(PX1CM,PY1CM,PZ1CM,SRT,I1,I2,
3821      &     XKY1, XKY2, XKY3, XKY4, XKY5,
3822      &     XKY6, XKY7, XKY8, XKY9, XKY10, XKY11, XKY12, XKY13,
3823      &     XKY14, XKY15, XKY16, XKY17, SIGK, IKMP,
3824      1  IBLOCK)
3825        em1=e(i1)
3826        em2=e(i2)
3827        go to 440
3828 c khyperon end
3829 *
3830 csp11/03/01 La/Si-bar + N --> pi + K+
3831 c  La/Si + N-bar --> pi + K-
3832 5999     CONTINUE
3833         PX1CM=PCX
3834         PY1CM=PCY
3835         PZ1CM=PCZ
3836         EC=(em1+em2+0.02)**2
3837         sigkp = 15.
3838 c      if((lb1.ge.14.and.lb1.le.17)
3839 c     &    .or.(lb2.ge.14.and.lb2.le.17))sigkp=10.
3840         DSkk=SQRT(SIGKP/PI/10.)
3841         dskk0=dskk+0.1
3842         CALL DISTCE(I1,I2,dskk0,DSkk,DT,EC,SRT,IC,
3843      1  PX1CM,PY1CM,PZ1CM)
3844         IF(IC.EQ.-1) GO TO 400
3845 c
3846         CALL CRLAN(PX1CM,PY1CM,PZ1CM,SRT,I1,I2,IBLOCK)
3847         em1=e(i1)
3848         em2=e(i2)
3849         go to 440
3850 c
3851 c*
3852 * K(K*) + K(K*) --> phi + pi(rho,omega)
3853 8699     CONTINUE
3854         PX1CM=PCX
3855         PY1CM=PCY
3856         PZ1CM=PCZ
3857         EC=(em1+em2+0.02)**2
3858 *  CALL CROSSKKPHI(PX1CM,PY1CM,PZ1CM,SRT,I1,I2,IBLOCK)  used for KK*->phi+rho
3859
3860          CALL Crkphi(PX1CM,PY1CM,PZ1CM,EC,SRT,IBLOCK,
3861      &                  emm1,emm2,lbp1,lbp2,I1,I2,ikk,icase,rrkk,prkk)
3862          if(icase .eq. 0) then
3863             iblock=0
3864             go to 400
3865          endif
3866
3867 c*---
3868          if(lbp1.eq.29.or.lbp2.eq.29) then
3869         PZRT = p(3,i1)+p(3,i2)
3870         ER1 = sqrt( p(1,i1)**2+p(2,i1)**2+p(3,i1)**2+E(i1)**2 )
3871         ER2 = sqrt( p(1,i2)**2+p(2,i2)**2+p(3,i2)**2+E(i2)**2 )
3872         ERT = ER1+ER2
3873         yy = 0.5*log( (ERT+PZRT)/(ERT-PZRT) )
3874 c*------
3875              iblock = 222
3876              ntag = 0
3877           endif
3878
3879              LB(I1) = lbp1
3880              LB(I2) = lbp2
3881              E(I1) = emm1
3882              E(I2) = emm2
3883              em1=e(i1)
3884              em2=e(i2)
3885              go to 440
3886 c*
3887 * rho(omega) + K(K*)  --> phi + K(K*)
3888 8799     CONTINUE
3889         PX1CM=PCX
3890         PY1CM=PCY
3891         PZ1CM=PCZ
3892         EC=(em1+em2+0.02)**2
3893 *  CALL CROSSKKPHI(PX1CM,PY1CM,PZ1CM,SRT,I1,I2,IBLOCK)  used for KK*->phi+rho
3894          CALL Crksph(PX1CM,PY1CM,PZ1CM,EC,SRT,
3895      &       emm1,emm2,lbp1,lbp2,I1,I2,ikkg,ikkl,iblock,icase,srhoks)
3896          if(icase .eq. 0) then
3897             iblock=0
3898             go to 400
3899          endif
3900 c
3901          if(lbp1.eq.29.or.lbp2.eq.20) then
3902 c*---
3903         PZRT = p(3,i1)+p(3,i2)
3904         ER1 = sqrt( p(1,i1)**2+p(2,i1)**2+p(3,i1)**2+E(i1)**2 )
3905         ER2 = sqrt( p(1,i2)**2+p(2,i2)**2+p(3,i2)**2+E(i2)**2 )
3906         ERT = ER1+ER2
3907         yy = 0.5*log( (ERT+PZRT)/(ERT-PZRT) )
3908           endif
3909
3910              LB(I1) = lbp1
3911              LB(I2) = lbp2
3912              E(I1) = emm1
3913              E(I2) = emm2
3914              em1=e(i1)
3915              em2=e(i2)
3916              go to 440
3917
3918 * for kaon+baryon scattering, using a constant xsection of 10 mb.
3919 888       CONTINUE
3920         PX1CM=PCX
3921         PY1CM=PCY
3922         PZ1CM=PCZ
3923         EC=(em1+em2+0.02)**2
3924          sig = 10.
3925          if(iabs(lb1).eq.14.or.iabs(lb2).eq.14 .or.
3926      &      iabs(lb1).eq.30.or.iabs(lb2).eq.30)sig=20.
3927          if(lb1.eq.29.or.lb2.eq.29)sig=5.0
3928
3929        DSkn=SQRT(sig/PI/10.)
3930        dsknr=dskn+0.1
3931         CALL DISTCE(I1,I2,dsknr,DSkn,DT,EC,SRT,IC,
3932      1  PX1CM,PY1CM,PZ1CM)
3933         IF(IC.EQ.-1) GO TO 400
3934         CALL Crkn(PX1CM,PY1CM,PZ1CM,SRT,I1,I2,
3935      1  IBLOCK)
3936        em1=e(i1)
3937        em2=e(i2)
3938        go to 440
3939 ***
3940
3941  440    CONTINUE
3942 *                IBLOCK = 0 ; NOTHING HAS HAPPENED
3943 *                IBLOCK = 1 ; ELASTIC N-N COLLISION
3944 *                IBLOCK = 2 ; N + N -> N + DELTA
3945 *                IBLOCK = 3 ; N + DELTA -> N + N
3946 *                IBLOCK = 4 ; N + N -> d + d + PION,DIRECT PROCESS
3947 *               IBLOCK = 5 ; D(N*)+D(N*) COLLISIONS
3948 *                IBLOCK = 6 ; PION+PION COLLISIONS
3949 *                iblock = 7 ; pion+nucleon-->l/s+kaon
3950 *               iblock =77;  pion+nucleon-->delta+pion
3951 *               iblock = 8 ; kaon+baryon rescattering
3952 *                IBLOCK = 9 ; NN-->KAON+X
3953 *                IBLOCK = 10; DD-->KAON+X
3954 *               IBLOCK = 11; ND-->KAON+X
3955 cbali2/1/99
3956 *
3957 *           iblock   - 1902 annihilation-->pion(+)+pion(-)   (2 pion)
3958 *           iblock   - 1903 annihilation-->pion(+)+rho(-)    (3 pion)
3959 *           iblock   - 1904 annihilation-->rho(+)+rho(-)     (4 pion)
3960 *           iblock   - 1905 annihilation-->rho(0)+omega      (5 pion)
3961 *           iblock   - 1906 annihilation-->omega+omega       (6 pion)
3962 cbali3/5/99
3963 *           iblock   - 1907 K+K- to pi+pi-
3964 cbali3/5/99 end
3965 cbz3/9/99 khyperon
3966 *           iblock   - 1908 K+Y -> piN
3967 cbz3/9/99 khyperon end
3968 cbali2/1/99end
3969
3970 clin-9/28/00 Processes: m(pi rho omega)+m(pi rho omega)
3971 c     to anti-(p n D N*1 N*2)+(p n D N*1 N*2):
3972 *           iblock   - 1801  mm -->pbar p
3973 *           iblock   - 18021 mm -->pbar n
3974 *           iblock   - 18022 mm -->nbar p
3975 *           iblock   - 1803  mm -->nbar n
3976 *           iblock   - 18041 mm -->pbar Delta
3977 *           iblock   - 18042 mm -->anti-Delta p
3978 *           iblock   - 18051 mm -->nbar Delta
3979 *           iblock   - 18052 mm -->anti-Delta n
3980 *           iblock   - 18061 mm -->pbar N*(1400)
3981 *           iblock   - 18062 mm -->anti-N*(1400) p
3982 *           iblock   - 18071 mm -->nbar N*(1400)
3983 *           iblock   - 18072 mm -->anti-N*(1400) n
3984 *           iblock   - 1808  mm -->anti-Delta Delta
3985 *           iblock   - 18091 mm -->pbar N*(1535)
3986 *           iblock   - 18092 mm -->anti-N*(1535) p
3987 *           iblock   - 18101 mm -->nbar N*(1535)
3988 *           iblock   - 18102 mm -->anti-N*(1535) n
3989 *           iblock   - 18111 mm -->anti-Delta N*(1440)
3990 *           iblock   - 18112 mm -->anti-N*(1440) Delta
3991 *           iblock   - 18121 mm -->anti-Delta N*(1535)
3992 *           iblock   - 18122 mm -->anti-N*(1535) Delta
3993 *           iblock   - 1813  mm -->anti-N*(1440) N*(1440)
3994 *           iblock   - 18141 mm -->anti-N*(1440) N*(1535)
3995 *           iblock   - 18142 mm -->anti-N*(1535) N*(1440)
3996 *           iblock   - 1815  mm -->anti-N*(1535) N*(1535)
3997 clin-9/28/00-end
3998
3999 clin-10/08/00 Processes: pi pi <-> rho rho
4000 *           iblock   - 1850  pi pi -> rho rho
4001 *           iblock   - 1851  rho rho -> pi pi
4002 clin-10/08/00-end
4003
4004 clin-08/14/02 Processes: pi pi <-> eta eta
4005 *           iblock   - 1860  pi pi -> eta eta
4006 *           iblock   - 1861  eta eta -> pi pi
4007 * Processes: pi pi <-> pi eta
4008 *           iblock   - 1870  pi pi -> pi eta
4009 *           iblock   - 1871  pi eta -> pi pi
4010 * Processes: rho pi <-> rho eta
4011 *           iblock   - 1880  pi pi -> pi eta
4012 *           iblock   - 1881  pi eta -> pi pi
4013 * Processes: omega pi <-> omega eta
4014 *           iblock   - 1890  pi pi -> pi eta
4015 *           iblock   - 1891  pi eta -> pi pi
4016 * Processes: rho rho <-> eta eta
4017 *           iblock   - 1895  rho rho -> eta eta
4018 *           iblock   - 1896  eta eta -> rho rho
4019 clin-08/14/02-end
4020
4021 clin-11/07/00 Processes:
4022 *           iblock   - 366  pi rho -> K* Kbar or K*bar K
4023 *           iblock   - 466  pi rho <- K* Kbar or K*bar K
4024
4025 clin-9/2008 Deuteron:
4026 *           iblock   - 501  B+B -> Deuteron+Meson
4027 *           iblock   - 502  Deuteron+Meson -> B+B
4028 *           iblock   - 503  Deuteron+Baryon elastic
4029 *           iblock   - 504  Deuteron+Meson elastic
4030 c
4031                  IF(IBLOCK.EQ.0)        GOTO 400
4032 *COM: FOR DIRECT PROCESS WE HAVE TREATED THE PAULI BLOCKING AND FIND
4033 *     THE MOMENTUM OF PARTICLES IN THE ''LAB'' FRAME. SO GO TO 400
4034 * A COLLISION HAS TAKEN PLACE !!
4035               LCOLL = LCOLL +1
4036 * WAS COLLISION PAULI-FORBIDEN? IF YES, NTAG = -1
4037               NTAG = 0
4038 *
4039 *             LORENTZ-TRANSFORMATION INTO CMS FRAME
4040               E1CM    = SQRT (EM1**2 + PX1CM**2 + PY1CM**2 + PZ1CM**2)
4041               P1BETA  = PX1CM*BETAX + PY1CM*BETAY + PZ1CM*BETAZ
4042               TRANSF  = GAMMA * ( GAMMA * P1BETA / (GAMMA + 1) + E1CM )
4043               Pt1I1 = BETAX * TRANSF + PX1CM
4044               Pt2I1 = BETAY * TRANSF + PY1CM
4045               Pt3I1 = BETAZ * TRANSF + PZ1CM
4046 * negelect the pauli blocking at high energies
4047               go to 90002
4048
4049 clin-10/25/02-comment out following, since there is no path to it:
4050 c*CHECK IF PARTICLE #1 IS PAULI BLOCKED
4051 c              CALL PAULat(I1,occup)
4052 c              if (RANART(NSEED) .lt. occup) then
4053 c                ntag = -1
4054 c              else
4055 c                ntag = 0
4056 c              end if
4057 clin-10/25/02-end
4058
4059 90002              continue
4060 *IF PARTICLE #1 IS NOT PAULI BLOCKED
4061 c              IF (NTAG .NE. -1) THEN
4062                 E2CM    = SQRT (EM2**2 + PX1CM**2 + PY1CM**2 + PZ1CM**2)
4063                 TRANSF  = GAMMA * (-GAMMA*P1BETA / (GAMMA + 1.) + E2CM)
4064                 Pt1I2 = BETAX * TRANSF - PX1CM
4065                 Pt2I2 = BETAY * TRANSF - PY1CM
4066                 Pt3I2 = BETAZ * TRANSF - PZ1CM
4067               go to 90003
4068
4069 clin-10/25/02-comment out following, since there is no path to it:
4070 c*CHECK IF PARTICLE #2 IS PAULI BLOCKED
4071 c                CALL PAULat(I2,occup)
4072 c                if (RANART(NSEED) .lt. occup) then
4073 c                  ntag = -1
4074 c                else
4075 c                  ntag = 0
4076 c                end if
4077 cc              END IF
4078 c* IF COLLISION IS BLOCKED,RESTORE THE MOMENTUM,MASSES
4079 c* AND LABELS OF I1 AND I2
4080 cc             IF (NTAG .EQ. -1) THEN
4081 c                LBLOC  = LBLOC + 1
4082 c                P(1,I1) = PX1
4083 c                P(2,I1) = PY1
4084 c                P(3,I1) = PZ1
4085 c                P(1,I2) = PX2
4086 c                P(2,I2) = PY2
4087 c                P(3,I2) = PZ2
4088 c                E(I1)   = EM1
4089 c                E(I2)   = EM2
4090 c                LB(I1)  = LB1
4091 c                LB(I2)  = LB2
4092 cc              ELSE
4093 clin-10/25/02-end
4094
4095 90003           IF(IBLOCK.EQ.1) LCNNE=LCNNE+1
4096               IF(IBLOCK.EQ.5) LDD=LDD+1
4097                 if(iblock.eq.2) LCNND=LCNND+1
4098               IF(IBLOCK.EQ.8) LKN=LKN+1
4099                    if(iblock.eq.43) Ldou=Ldou+1
4100 c                IF(IBLOCK.EQ.2) THEN
4101 * CALCULATE THE AVERAGE SRT FOR N + N---> N + DELTA PROCESS
4102 C                NODELT=NODELT+1
4103 C                SUMSRT=SUMSRT+SRT
4104 c                ENDIF
4105                 IF(IBLOCK.EQ.3) LCNDN=LCNDN+1
4106 * assign final momenta to particles while keep the leadng particle
4107 * behaviour
4108 C              if((pt1i1*px1+pt2i1*py1+pt3i1*pz1).gt.0)then
4109               p(1,i1)=pt1i1
4110               p(2,i1)=pt2i1
4111               p(3,i1)=pt3i1
4112               p(1,i2)=pt1i2
4113               p(2,i2)=pt2i2
4114               p(3,i2)=pt3i2
4115 C              else
4116 C              p(1,i1)=pt1i2
4117 C              p(2,i1)=pt2i2
4118 C              p(3,i1)=pt3i2
4119 C              p(1,i2)=pt1i1
4120 C              p(2,i2)=pt2i1
4121 C              p(3,i2)=pt3i1
4122 C              endif
4123                 PX1     = P(1,I1)
4124                 PY1     = P(2,I1)
4125                 PZ1     = P(3,I1)
4126                 EM1     = E(I1)
4127                 EM2     = E(I2)
4128                 LB1     = LB(I1)
4129                 LB2     = LB(I2)
4130                 ID(I1)  = 2
4131                 ID(I2)  = 2
4132                 E1      = SQRT( EM1**2 + PX1**2 + PY1**2 + PZ1**2 )
4133                 ID1     = ID(I1)
4134               go to 90004
4135 clin-10/25/02-comment out following, since there is no path to it:
4136 c* change phase space density FOR NUCLEONS INVOLVED :
4137 c* NOTE THAT f is the phase space distribution function for nucleons only
4138 c                if ((abs(ix1).le.mx) .and. (abs(iy1).le.my) .and.
4139 c     &              (abs(iz1).le.mz)) then
4140 c                  ipx1p = nint(p(1,i1)/dpx)
4141 c                  ipy1p = nint(p(2,i1)/dpy)
4142 c                  ipz1p = nint(p(3,i1)/dpz)
4143 c                  if ((ipx1p.ne.ipx1) .or. (ipy1p.ne.ipy1) .or.
4144 c     &                (ipz1p.ne.ipz1)) then
4145 c                    if ((abs(ipx1).le.mpx) .and. (abs(ipy1).le.my)
4146 c     &                .and. (ipz1.ge.-mpz) .and. (ipz1.le.mpzp)
4147 c     &                .AND. (AM1.LT.1.))
4148 c     &                f(ix1,iy1,iz1,ipx1,ipy1,ipz1) =
4149 c     &                f(ix1,iy1,iz1,ipx1,ipy1,ipz1) - 1.
4150 c                    if ((abs(ipx1p).le.mpx) .and. (abs(ipy1p).le.my)
4151 c     &                .and. (ipz1p.ge.-mpz).and. (ipz1p.le.mpzp)
4152 c     &                .AND. (EM1.LT.1.))
4153 c     &                f(ix1,iy1,iz1,ipx1p,ipy1p,ipz1p) =
4154 c     &                f(ix1,iy1,iz1,ipx1p,ipy1p,ipz1p) + 1.
4155 c                  end if
4156 c                end if
4157 c                if ((abs(ix2).le.mx) .and. (abs(iy2).le.my) .and.
4158 c     &              (abs(iz2).le.mz)) then
4159 c                  ipx2p = nint(p(1,i2)/dpx)
4160 c                  ipy2p = nint(p(2,i2)/dpy)
4161 c                  ipz2p = nint(p(3,i2)/dpz)
4162 c                  if ((ipx2p.ne.ipx2) .or. (ipy2p.ne.ipy2) .or.
4163 c     &                (ipz2p.ne.ipz2)) then
4164 c                    if ((abs(ipx2).le.mpx) .and. (abs(ipy2).le.my)
4165 c     &                .and. (ipz2.ge.-mpz) .and. (ipz2.le.mpzp)
4166 c     &                .AND. (AM2.LT.1.))
4167 c     &                f(ix2,iy2,iz2,ipx2,ipy2,ipz2) =
4168 c     &                f(ix2,iy2,iz2,ipx2,ipy2,ipz2) - 1.
4169 c                    if ((abs(ipx2p).le.mpx) .and. (abs(ipy2p).le.my)
4170 c     &                .and. (ipz2p.ge.-mpz) .and. (ipz2p.le.mpzp)
4171 c     &                .AND. (EM2.LT.1.))
4172 c     &                f(ix2,iy2,iz2,ipx2p,ipy2p,ipz2p) =
4173 c     &                f(ix2,iy2,iz2,ipx2p,ipy2p,ipz2p) + 1.
4174 c                  end if
4175 c                end if
4176 clin-10/25/02-end
4177
4178 90004              continue
4179             AM1=EM1
4180             AM2=EM2
4181 c            END IF
4182
4183
4184   400       CONTINUE
4185 c
4186 clin-6/10/03 skips the info output on resonance creations:
4187 c            goto 550
4188 cclin-4/30/03 study phi,K*,Lambda(1520) resonances at creation:
4189 cc     note that no decays give these particles, so don't need to consider nnn:
4190 c            if(iblock.ne.0.and.(lb(i1).eq.29.or.iabs(lb(i1)).eq.30
4191 c     1           .or.lb(i2).eq.29.or.iabs(lb(i2)).eq.30
4192 c     2           .or.lb1i.eq.29.or.iabs(lb1i).eq.30
4193 c     3           .or.lb2i.eq.29.or.iabs(lb2i).eq.30)) then
4194 c               lb1now=lb(i1)
4195 c               lb2now=lb(i2)
4196 cc
4197 c               nphi0=0
4198 c               nksp0=0
4199 c               nksm0=0
4200 cc               nlar0=0
4201 cc               nlarbar0=0
4202 c               if(lb1i.eq.29) then
4203 c                  nphi0=nphi0+1
4204 c               elseif(lb1i.eq.30) then
4205 c                  nksp0=nksp0+1
4206 c               elseif(lb1i.eq.-30) then
4207 c                  nksm0=nksm0+1
4208 c               endif
4209 c               if(lb2i.eq.29) then
4210 c                  nphi0=nphi0+1
4211 c               elseif(lb2i.eq.30) then
4212 c                  nksp0=nksp0+1
4213 c               elseif(lb2i.eq.-30) then
4214 c                  nksm0=nksm0+1
4215 c               endif
4216 cc
4217 c               nphi=0
4218 c               nksp=0
4219 c               nksm=0
4220 c               nlar=0
4221 c               nlarbar=0
4222 c               if(lb1now.eq.29) then
4223 c                  nphi=nphi+1
4224 c               elseif(lb1now.eq.30) then
4225 c                  nksp=nksp+1
4226 c               elseif(lb1now.eq.-30) then
4227 c                  nksm=nksm+1
4228 c               endif
4229 c               if(lb2now.eq.29) then
4230 c                  nphi=nphi+1
4231 c               elseif(lb2now.eq.30) then
4232 c                  nksp=nksp+1
4233 c               elseif(lb2now.eq.-30) then
4234 c                  nksm=nksm+1
4235 c               endif
4236 cc
4237 c               if(nphi.eq.2.or.nksp.eq.2.or.nksm.eq.2) then
4238 c                  write(91,*) '2 same resonances in one reaction!'
4239 c                  write(91,*) nphi,nksp,nksm,iblock
4240 c               endif
4241 c
4242 cc     All reactions create or destroy no more than 1 these resonance,
4243 cc     otherwise file "fort.91" warns us:
4244 c               do 222 ires=1,3
4245 c                  if(ires.eq.1.and.nphi.ne.nphi0) then
4246 c                     idr=29
4247 c                  elseif(ires.eq.2.and.nksp.ne.nksp0) then
4248 c                     idr=30
4249 c                  elseif(ires.eq.3.and.nksm.ne.nksm0) then
4250 c                     idr=-30
4251 c                  else
4252 c                     goto 222
4253 c                  endif
4254 cctest off for resonance (phi, K*) studies:
4255 cc               if(lb1now.eq.idr) then
4256 cc       write(17,112) 'collision',lb1now,P(1,I1),P(2,I1),P(3,I1),e(I1),nt
4257 cc               elseif(lb2now.eq.idr) then
4258 cc       write(17,112) 'collision',lb2now,P(1,I2),P(2,I2),P(3,I2),e(I2),nt
4259 cc               elseif(lb1i.eq.idr) then
4260 cc       write(18,112) 'collision',lb1i,px1i,py1i,pz1i,em1i,nt
4261 cc               elseif(lb2i.eq.idr) then
4262 cc       write(18,112) 'collision',lb2i,px2i,py2i,pz2i,em2i,nt
4263 cc               endif
4264 c 222           continue
4265 c
4266 c            else
4267 c            endif
4268 cc 112        format(a10,I4,4(1x,f9.3),1x,I4)
4269 c
4270 clin-2/26/03 skips the check of energy conservation after each binary search:
4271 c 550        goto 555
4272 c            pxfin=0
4273 c            pyfin=0
4274 c            pzfin=0
4275 c            efin=0
4276 c            if(e(i1).ne.0.or.lb(i1).eq.10022) then
4277 c               efin=efin+SQRT(E(I1)**2+P(1,I1)**2+P(2,I1)**2+P(3,I1)**2)
4278 c               pxfin=pxfin+P(1,I1)
4279 c               pyfin=pyfin+P(2,I1)
4280 c               pzfin=pzfin+P(3,I1)
4281 c            endif
4282 c            if(e(i2).ne.0.or.lb(i2).eq.10022) then
4283 c               efin=efin+SQRT(E(I2)**2+P(1,I2)**2+P(2,I2)**2+P(3,I2)**2)
4284 c               pxfin=pxfin+P(1,I2)
4285 c               pyfin=pyfin+P(2,I2)
4286 c               pzfin=pzfin+P(3,I2)
4287 c            endif
4288 c            if((nnn-nnnini).ge.1) then
4289 c               do imore=nnnini+1,nnn
4290 c                  if(EPION(imore,IRUN).ne.0) then
4291 c                     efin=efin+SQRT(EPION(imore,IRUN)**2
4292 c     1                    +PPION(1,imore,IRUN)**2+PPION(2,imore,IRUN)**2
4293 c     2                    +PPION(3,imore,IRUN)**2)
4294 c                     pxfin=pxfin+PPION(1,imore,IRUN)
4295 c                     pyfin=pyfin+PPION(2,imore,IRUN)
4296 c                     pzfin=pzfin+PPION(3,imore,IRUN)
4297 c                  endif
4298 c               enddo
4299 c            endif
4300 c            devio=sqrt((pxfin-pxini)**2+(pyfin-pyini)**2
4301 c     1           +(pzfin-pzini)**2+(efin-eini)**2)
4302 cc
4303 c            if(devio.ge.0.1) then
4304 c               write(92,'a20,5(1x,i6),2(1x,f8.3)') 'iblock,lb,npi=',
4305 c     1              iblock,lb1i,lb2i,lb(i1),lb(i2),e(i1),e(i2)
4306 c               do imore=nnnini+1,nnn
4307 c                  if(EPION(imore,IRUN).ne.0) then
4308 c                     write(92,'a10,2(1x,i6)') 'ipi,lbm=',
4309 c     1                    imore,LPION(imore,IRUN)
4310 c                  endif
4311 c               enddo
4312 c               write(92,'a3,4(1x,f8.3)') 'I:',eini,pxini,pyini,pzini
4313 c               write(92,'a3,5(1x,f8.3)')
4314 c     1              'F:',efin,pxfin,pyfin,pzfin,devio
4315 c            endif
4316 c
4317  555        continue
4318 ctest off only one collision for the same 2 particles in the same timestep:
4319 c            if(iblock.ne.0) then
4320 c               goto 800
4321 c            endif
4322 ctest off collisions history:
4323 c            if(iblock.ne.0) then
4324 c               write(10,*) nt,i1,i2,iblock,x1,z1,x2,z2
4325 c            endif
4326
4327   600     CONTINUE
4328   800   CONTINUE
4329 * RELABLE MESONS LEFT IN THIS RUN EXCLUDING THOSE BEING CREATED DURING
4330 * THIS TIME STEP AND COUNT THE TOTAL NO. OF PARTICLES IN THIS RUN
4331 * note that the first mass=mta+mpr particles are baryons
4332 c        write(*,*)'I: NNN,massr ', nnn,massr(irun)
4333         N0=MASS+MSUM
4334         DO 1005 N=N0+1,MASSR(IRUN)+MSUM
4335 cbz11/25/98
4336 clin-2/19/03 lb>5000: keep particles with no LB codes in ART(photon,lepton,..):
4337 c        IF(E(N).GT.0.)THEN
4338         IF(E(N) .GT. 0. .OR. LB(N) .GT. 5000)THEN
4339 cbz11/25/98end
4340         NNN=NNN+1
4341         RPION(1,NNN,IRUN)=R(1,N)
4342         RPION(2,NNN,IRUN)=R(2,N)
4343         RPION(3,NNN,IRUN)=R(3,N)
4344 clin-10/28/03:
4345         if(nt.eq.ntmax) then
4346            ftpisv(NNN,IRUN)=ftsv(N)
4347            tfdpi(NNN,IRUN)=tfdcy(N)
4348         endif
4349 c
4350         PPION(1,NNN,IRUN)=P(1,N)
4351         PPION(2,NNN,IRUN)=P(2,N)
4352         PPION(3,NNN,IRUN)=P(3,N)
4353         EPION(NNN,IRUN)=E(N)
4354         LPION(NNN,IRUN)=LB(N)
4355 c       !! sp 12/19/00
4356         PROPI(NNN,IRUN)=PROPER(N)
4357 clin-5/2008:
4358         dppion(NNN,IRUN)=dpertp(N)
4359 c        if(lb(n) .eq. 45)
4360 c    &   write(*,*)'IN-1  NT,NNN,LB,P ',nt,NNN,lb(n),proper(n)
4361         ENDIF
4362  1005 CONTINUE
4363         MASSRN(IRUN)=NNN+MASS
4364 c        write(*,*)'F: NNN,massrn ', nnn,massrn(irun)
4365 1000   CONTINUE
4366 * CALCULATE THE AVERAGE SRT FOR N + N--->N +DELTA PROCESSES
4367 C        IF(NODELT.NE.0)THEN
4368 C        AVSRT=SUMSRT/FLOAT(NODELT)
4369 C        ELSE
4370 C        AVSRT=0.
4371 C        ENDIF
4372 C        WRITE(1097,'(F8.2,2X,E10.3)')FLOAT(NT)*DT,AVSRT
4373 * RELABLE ALL THE PARTICLES EXISTING AFTER THIS TIME STEP
4374         IA=0
4375         IB=0
4376         DO 10001 IRUN=1,NUM
4377         IA=IA+MASSR(IRUN-1)
4378         IB=IB+MASSRN(IRUN-1)
4379         DO 10001 IC=1,MASSRN(IRUN)
4380         IE=IA+IC
4381         IG=IB+IC
4382         IF(IC.LE.MASS)THEN
4383         RT(1,IG)=R(1,IE)
4384         RT(2,IG)=R(2,IE)
4385         RT(3,IG)=R(3,IE)
4386 clin-10/28/03:
4387         if(nt.eq.ntmax) then
4388            fttemp(IG)=ftsv(IE)
4389            tft(IG)=tfdcy(IE)
4390         endif
4391 c
4392         PT(1,IG)=P(1,IE)
4393         PT(2,IG)=P(2,IE)
4394         PT(3,IG)=P(3,IE)
4395         ET(IG)=E(IE)
4396         LT(IG)=LB(IE)
4397         PROT(IG)=PROPER(IE)
4398 clin-5/2008:
4399         dptemp(IG)=dpertp(IE)
4400         ELSE
4401         I0=IC-MASS
4402         RT(1,IG)=RPION(1,I0,IRUN)
4403         RT(2,IG)=RPION(2,I0,IRUN)
4404         RT(3,IG)=RPION(3,I0,IRUN)
4405 clin-10/28/03:
4406         if(nt.eq.ntmax) then
4407            fttemp(IG)=ftpisv(I0,IRUN)
4408            tft(IG)=tfdpi(I0,IRUN)
4409         endif
4410 c
4411         PT(1,IG)=PPION(1,I0,IRUN)
4412         PT(2,IG)=PPION(2,I0,IRUN)
4413         PT(3,IG)=PPION(3,I0,IRUN)
4414         ET(IG)=EPION(I0,IRUN)
4415         LT(IG)=LPION(I0,IRUN)
4416         PROT(IG)=PROPI(I0,IRUN)
4417 clin-5/2008:
4418         dptemp(IG)=dppion(I0,IRUN)
4419         ENDIF
4420 10001   CONTINUE
4421 c
4422         IL=0
4423 clin-10/26/01-hbt:
4424 c        DO 10002 IRUN=1,NUM
4425         DO 10003 IRUN=1,NUM
4426
4427         MASSR(IRUN)=MASSRN(IRUN)
4428         IL=IL+MASSR(IRUN-1)
4429         DO 10002 IM=1,MASSR(IRUN)
4430         IN=IL+IM
4431         R(1,IN)=RT(1,IN)
4432         R(2,IN)=RT(2,IN)
4433         R(3,IN)=RT(3,IN)
4434 clin-10/28/03:
4435         if(nt.eq.ntmax) then
4436            ftsv(IN)=fttemp(IN)
4437            tfdcy(IN)=tft(IN)
4438         endif
4439         P(1,IN)=PT(1,IN)
4440         P(2,IN)=PT(2,IN)
4441         P(3,IN)=PT(3,IN)
4442         E(IN)=ET(IN)
4443         LB(IN)=LT(IN)
4444         PROPER(IN)=PROT(IN)
4445 clin-5/2008:
4446         dpertp(IN)=dptemp(IN)
4447        IF(LB(IN).LT.1.OR.LB(IN).GT.2)ID(IN)=0
4448 10002   CONTINUE
4449 clin-ctest off check energy conservation after each timestep
4450 c         enetot=0.
4451 c         do ip=1,MASSR(IRUN)
4452 c            if(e(ip).ne.0.or.lb(ip).eq.10022) enetot=enetot
4453 c     1           +sqrt(p(1,ip)**2+p(2,ip)**2+p(3,ip)**2+e(ip)**2)
4454 c         enddo
4455 c         write(91,*) 'B:',nt,enetot,massr(irun),bimp
4456 clin-3/2009 move to the end of a timestep to take care of freezeout spacetime:
4457 c        call hbtout(MASSR(IRUN),nt,ntmax)
4458 10003 CONTINUE
4459 c
4460       RETURN
4461       END
4462 ****************************************
4463             SUBROUTINE CMS(I1,I2,PX1CM,PY1CM,PZ1CM,SRT)
4464 * PURPOSE : FIND THE MOMENTA OF PARTICLES IN THE CMS OF THE
4465 *          TWO COLLIDING PARTICLES
4466 * VARIABLES :
4467 *****************************************
4468             PARAMETER (MAXSTR=150001)
4469             COMMON   /AA/  R(3,MAXSTR)
4470 cc      SAVE /AA/
4471             COMMON   /BB/  P(3,MAXSTR)
4472 cc      SAVE /BB/
4473             COMMON   /CC/  E(MAXSTR)
4474 cc      SAVE /CC/
4475             COMMON   /BG/  BETAX,BETAY,BETAZ,GAMMA
4476 cc      SAVE /BG/
4477       SAVE
4478             PX1=P(1,I1)
4479             PY1=P(2,I1)
4480             PZ1=P(3,I1)
4481             PX2=P(1,I2)
4482             PY2=P(2,I2)
4483             PZ2=P(3,I2)
4484             EM1=E(I1)
4485             EM2=E(I2)
4486             E1=SQRT(EM1**2+PX1**2+PY1**2+PZ1**2)
4487             E2=SQRT(EM2**2 + PX2**2 + PY2**2 + PZ2**2 )
4488             S=(E1+E2)**2-(PX1+PX2)**2-(PY1+PY2)**2-(PZ1+PZ2)**2
4489             SRT=SQRT(S)
4490 *LORENTZ-TRANSFORMATION IN I1-I2-C.M. SYSTEM
4491               ETOTAL = E1 + E2
4492               BETAX  = (PX1+PX2) / ETOTAL
4493               BETAY  = (PY1+PY2) / ETOTAL
4494               BETAZ  = (PZ1+PZ2) / ETOTAL
4495               GAMMA  = 1.0 / SQRT(1.0-BETAX**2-BETAY**2-BETAZ**2)
4496 *TRANSFORMATION OF MOMENTA (PX1CM = - PX2CM)
4497               P1BETA = PX1*BETAX + PY1*BETAY + PZ1 * BETAZ
4498               TRANSF = GAMMA * ( GAMMA * P1BETA / (GAMMA + 1) - E1 )
4499               PX1CM  = BETAX * TRANSF + PX1
4500               PY1CM  = BETAY * TRANSF + PY1
4501               PZ1CM  = BETAZ * TRANSF + PZ1
4502               RETURN
4503               END
4504 ***************************************
4505             SUBROUTINE DISTCE(I1,I2,DELTAR,DS,DT,EC,SRT
4506      1      ,IC,PX1CM,PY1CM,PZ1CM)
4507 * PURPOSE : CHECK IF THE COLLISION BETWEEN TWO PARTICLES CAN HAPPEN
4508 *           BY CHECKING
4509 *                      (1) IF THE DISTANCE BETWEEN THEM IS SMALLER
4510 *           THAN THE MAXIMUM DISTANCE DETERMINED FROM THE CROSS SECTION.
4511 *                      (2) IF PARTICLE WILL PASS EACH OTHER WITHIN
4512 *           TWO HARD CORE RADIUS.
4513 *                      (3) IF PARTICLES WILL GET CLOSER.
4514 * VARIABLES :
4515 *           IC=1 COLLISION HAPPENED
4516 *           IC=-1 COLLISION CAN NOT HAPPEN
4517 *****************************************
4518             PARAMETER (MAXSTR=150001)
4519             COMMON   /AA/  R(3,MAXSTR)
4520 cc      SAVE /AA/
4521             COMMON   /BB/  P(3,MAXSTR)
4522 cc      SAVE /BB/
4523             COMMON   /CC/  E(MAXSTR)
4524 cc      SAVE /CC/
4525             COMMON   /BG/  BETAX,BETAY,BETAZ,GAMMA
4526             COMMON  /EE/      ID(MAXSTR),LB(MAXSTR)
4527 cc      SAVE /BG/
4528             common/leadng/lb1,px1,py1,pz1,em1,e1,xfnl,yfnl,zfnl,tfnl,
4529      1           px1n,py1n,pz1n,dp1n
4530             common /dpi/em2,lb2
4531             SAVE
4532             IC=0
4533             X1=R(1,I1)
4534             Y1=R(2,I1)
4535             Z1=R(3,I1)
4536             PX1=P(1,I1)
4537             PY1=P(2,I1)
4538             PZ1=P(3,I1)
4539             X2=R(1,I2)
4540             Y2=R(2,I2)
4541             Z2=R(3,I2)
4542             PX2=P(1,I2)
4543             PY2=P(2,I2)
4544             PZ2=P(3,I2)
4545             EM1=E(I1)
4546             EM2=E(I2)
4547             E1=SQRT(EM1**2+PX1**2+PY1**2+PZ1**2)
4548 c            IF (ABS(X1-X2) .GT. DELTAR) GO TO 400
4549 c            IF (ABS(Y1-Y2) .GT. DELTAR) GO TO 400
4550 c            IF (ABS(Z1-Z2) .GT. DELTAR) GO TO 400
4551             RSQARE = (X1-X2)**2 + (Y1-Y2)**2 + (Z1-Z2)**2
4552             IF (RSQARE .GT. DELTAR**2) GO TO 400
4553 *NOW PARTICLES ARE CLOSE ENOUGH TO EACH OTHER !
4554               E2     = SQRT ( EM2**2 + PX2**2 + PY2**2 + PZ2**2 )
4555               S      = SRT*SRT
4556             IF (S .LT. EC) GO TO 400
4557 *NOW THERE IS ENOUGH ENERGY AVAILABLE !
4558 *LORENTZ-TRANSFORMATION IN I1-I2-C.M. SYSTEM
4559 * BETAX, BETAY, BETAZ AND GAMMA HAVE BEEN GIVEN IN THE SUBROUTINE CMS
4560 *TRANSFORMATION OF MOMENTA (PX1CM = - PX2CM)
4561               P1BETA = PX1*BETAX + PY1*BETAY + PZ1 * BETAZ
4562               TRANSF = GAMMA * ( GAMMA * P1BETA / (GAMMA + 1) - E1 )
4563               PRCM   = SQRT (PX1CM**2 + PY1CM**2 + PZ1CM**2)
4564               IF (PRCM .LE. 0.00001) GO TO 400
4565 *TRANSFORMATION OF SPATIAL DISTANCE
4566               DRBETA = BETAX*(X1-X2) + BETAY*(Y1-Y2) + BETAZ*(Z1-Z2)
4567               TRANSF = GAMMA * GAMMA * DRBETA / (GAMMA + 1)
4568               DXCM   = BETAX * TRANSF + X1 - X2
4569               DYCM   = BETAY * TRANSF + Y1 - Y2
4570               DZCM   = BETAZ * TRANSF + Z1 - Z2
4571 *DETERMINING IF THIS IS THE POINT OF CLOSEST APPROACH
4572               DRCM   = SQRT (DXCM**2  + DYCM**2  + DZCM**2 )
4573               DZZ    = (PX1CM*DXCM + PY1CM*DYCM + PZ1CM*DZCM) / PRCM
4574               if ((drcm**2 - dzz**2) .le. 0.) then
4575                 BBB = 0.
4576               else
4577                 BBB    = SQRT (DRCM**2 - DZZ**2)
4578               end if
4579 *WILL PARTICLE PASS EACH OTHER WITHIN 2 * HARD CORE RADIUS ?
4580               IF (BBB .GT. DS) GO TO 400
4581               RELVEL = PRCM * (1.0/E1 + 1.0/E2)
4582               DDD    = RELVEL * DT * 0.5
4583 *WILL PARTICLES GET CLOSER ?
4584               IF (ABS(DDD) .LT. ABS(DZZ)) GO TO 400
4585               IC=1
4586               GO TO 500
4587 400           IC=-1
4588 500           CONTINUE
4589               RETURN
4590               END
4591 ****************************************
4592 *                                                                      *
4593 *                                                                      *
4594       SUBROUTINE CRNN(IRUN,PX,PY,PZ,SRT,I1,I2,IBLOCK,
4595      1NTAG,SIGNN,SIG,NT,ipert1)
4596 *     PURPOSE:                                                         *
4597 *             DEALING WITH NUCLEON-NUCLEON COLLISIONS                    *
4598 *     NOTE   :                                                         *
4599 *     QUANTITIES:                                                 *
4600 *           PX,PY,PZ - MOMENTUM COORDINATES OF ONE PARTICLE IN CM FRAME*
4601 *           SRT      - SQRT OF S                                       *
4602 *           NSTAR =1 INCLUDING N* RESORANCE,ELSE NOT                   *
4603 *           NDIRCT=1 INCLUDING DIRECT PION PRODUCTION PROCESS         *
4604 *           IBLOCK   - THE INFORMATION BACK                            *
4605 *                      0-> COLLISION CANNOT HAPPEN                     *
4606 *                      1-> N-N ELASTIC COLLISION                       *
4607 *                      2-> N+N->N+DELTA,OR N+N->N+N* REACTION          *
4608 *                      3-> N+DELTA->N+N OR N+N*->N+N REACTION          *
4609 *                      4-> N+N->D+D+pion reaction
4610 *                     43->N+N->D(N*)+D(N*) reaction
4611 *                     44->N+N->D+D+rho reaction
4612 *                     45->N+N->N+N+rho
4613 *                     46->N+N->N+N+omega
4614 *           N12       - IS USED TO SPECIFY BARYON-BARYON REACTION      *
4615 *                      CHANNELS. M12 IS THE REVERSAL CHANNEL OF N12    *
4616 *                      N12,                                            *
4617 *                      M12=1 FOR p+n-->delta(+)+ n                     *
4618 *                          2     p+n-->delta(0)+ p                     *
4619 *                          3     p+p-->delta(++)+n                     *
4620 *                          4     p+p-->delta(+)+p                      *
4621 *                          5     n+n-->delta(0)+n                      *
4622 *                          6     n+n-->delta(-)+p                      *
4623 *                          7     n+p-->N*(0)(1440)+p                   *
4624 *                          8     n+p-->N*(+)(1440)+n                   *
4625 *                        9     p+p-->N*(+)(1535)+p                     *
4626 *                        10    n+n-->N*(0)(1535)+n                     *
4627 *                         11    n+p-->N*(+)(1535)+n                     *
4628 *                        12    n+p-->N*(0)(1535)+p
4629 *                        13    D(++)+D(-)-->N*(+)(1440)+n
4630 *                         14    D(++)+D(-)-->N*(0)(1440)+p
4631 *                        15    D(+)+D(0)--->N*(+)(1440)+n
4632 *                        16    D(+)+D(0)--->N*(0)(1440)+p
4633 *                        17    D(++)+D(0)-->N*(+)(1535)+p
4634 *                        18    D(++)+D(-)-->N*(0)(1535)+p
4635 *                        19    D(++)+D(-)-->N*(+)(1535)+n
4636 *                        20    D(+)+D(+)-->N*(+)(1535)+p
4637 *                        21    D(+)+D(0)-->N*(+)(1535)+n
4638 *                        22    D(+)+D(0)-->N*(0)(1535)+p
4639 *                        23    D(+)+D(-)-->N*(0)(1535)+n
4640 *                        24    D(0)+D(0)-->N*(0)(1535)+n
4641 *                          25    N*(+)(14)+N*(+)(14)-->N*(+)(15)+p
4642 *                          26    N*(0)(14)+N*(0)(14)-->N*(0)(15)+n
4643 *                          27    N*(+)(14)+N*(0)(14)-->N*(+)(15)+n
4644 *                        28    N*(+)(14)+N*(0)(14)-->N*(0)(15)+p
4645 *                        29    N*(+)(14)+D+-->N*(+)(15)+p
4646 *                        30    N*(+)(14)+D0-->N*(+)(15)+n
4647 *                        31    N*(+)(14)+D(-)-->N*(0)(1535)+n
4648 *                        32    N*(0)(14)+D++--->N*(+)(15)+p
4649 *                        33    N*(0)(14)+D+--->N*(+)(15)+n
4650 *                        34    N*(0)(14)+D+--->N*(0)(15)+p
4651 *                        35    N*(0)(14)+D0-->N*(0)(15)+n
4652 *                        36    N*(+)(14)+D0--->N*(0)(15)+p
4653 *                        ++    see the note book for more listing
4654 *
4655 *
4656 *     NOTE ABOUT N*(1440) RESORANCE IN Nucleon+NUCLEON COLLISION:      *
4657 *     As it has been discussed in VerWest's paper,I= 1(initial isospin)*
4658 *     channel can all be attributed to delta resorance while I= 0      *
4659 *     channel can all be  attribured to N* resorance.Only in n+p       *
4660 *     one can have I=0 channel so is the N*(1440) resonance            *
4661 *                                                                      *
4662 *                             REFERENCES:                            *
4663 *                    J. CUGNON ET AL., NUCL. PHYS. A352, 505 (1981)    *
4664 *                    Y. KITAZOE ET AL., PHYS. LETT. 166B, 35 (1986)    *
4665 *                    B. VerWest el al., PHYS. PRV. C25 (1982)1979      *
4666 *                    Gy. Wolf  et al, Nucl Phys A517 (1990) 615;       *
4667 *                                     Nucl phys A552 (1993) 349.       *
4668 **********************************
4669         PARAMETER (MAXSTR=150001,MAXR=1,AMN=0.939457,
4670      1  AMP=0.93828,AP1=0.13496,aka=0.498,AP2=0.13957,AM0=1.232,
4671      2  PI=3.1415926,CUTOFF=1.8966,AVMASS=0.9383,APHI=1.020)
4672         parameter     (MX=4,MY=4,MZ=8,MPX=4,MPY=4,mpz=10,mpzp=10)
4673         parameter (xmd=1.8756,npdmax=10000)
4674         COMMON /AA/ R(3,MAXSTR)
4675 cc      SAVE /AA/
4676         COMMON /BB/ P(3,MAXSTR)
4677 cc      SAVE /BB/
4678         COMMON /CC/ E(MAXSTR)
4679 cc      SAVE /CC/
4680         COMMON /EE/ ID(MAXSTR),LB(MAXSTR)
4681 cc      SAVE /EE/
4682         common /ff/f(-mx:mx,-my:my,-mz:mz,-mpx:mpx,-mpy:mpy,-mpz:mpzp)
4683 cc      SAVE /ff/
4684         common /gg/ dx,dy,dz,dpx,dpy,dpz
4685 cc      SAVE /gg/
4686         COMMON /INPUT/ NSTAR,NDIRCT,DIR
4687 cc      SAVE /INPUT/
4688         COMMON /NN/NNN
4689 cc      SAVE /NN/
4690         COMMON /BG/BETAX,BETAY,BETAZ,GAMMA
4691 cc      SAVE /BG/
4692         COMMON   /RUN/NUM
4693 cc      SAVE /RUN/
4694         COMMON   /PA/RPION(3,MAXSTR,MAXR)
4695 cc      SAVE /PA/
4696         COMMON   /PB/PPION(3,MAXSTR,MAXR)
4697 cc      SAVE /PB/
4698         COMMON   /PC/EPION(MAXSTR,MAXR)
4699 cc      SAVE /PC/
4700         COMMON   /PD/LPION(MAXSTR,MAXR)
4701 cc      SAVE /PD/
4702         COMMON/TABLE/ xarray(0:1000),earray(0:1000)
4703 cc      SAVE /TABLE/
4704         common/input1/ MASSPR,MASSTA,ISEED,IAVOID,DT
4705 cc      SAVE /input1/
4706       common/leadng/lb1,px1,py1,pz1,em1,e1,xfnl,yfnl,zfnl,tfnl,
4707      1 px1n,py1n,pz1n,dp1n
4708 cc      SAVE /leadng/
4709       COMMON/RNDF77/NSEED
4710 cc      SAVE /RNDF77/
4711       common /dpi/em2,lb2
4712       COMMON /dpert/dpertt(MAXSTR,MAXR),dpertp(MAXSTR),dplast(MAXSTR),
4713      1     dpdcy(MAXSTR),dpdpi(MAXSTR,MAXR),dpt(MAXSTR, MAXR),
4714      2     dpp1(MAXSTR,MAXR),dppion(MAXSTR,MAXR)
4715       common /para8/ idpert,npertd,idxsec
4716       dimension ppd(3,npdmax),lbpd(npdmax)
4717       SAVE
4718 *-----------------------------------------------------------------------
4719       n12=0
4720       m12=0
4721       IBLOCK=0
4722       NTAG=0
4723       EM1=E(I1)
4724       EM2=E(I2)
4725       PR=SQRT( PX**2 + PY**2 + PZ**2 )
4726       C2=PZ / PR
4727       X1=RANART(NSEED)
4728       ianti=0
4729       if(lb(i1).lt.0 .and. lb(i2).lt.0) ianti=1
4730       call sbbdm(srt,sdprod,ianti,lbm,xmm,pfinal)
4731 clin-5/2008 Production of perturbative deuterons for idpert=1:
4732       if(idpert.eq.1.and.ipert1.eq.1) then
4733          IF (SRT .LT. 2.012) RETURN
4734          if((iabs(lb(i1)).eq.1.or.iabs(lb(i1)).eq.2)
4735      1        .and.(iabs(lb(i2)).eq.1.or.iabs(lb(i2)).eq.2)) then
4736             goto 108
4737          else
4738             return
4739          endif
4740       endif
4741 c
4742 *-----------------------------------------------------------------------
4743 *COM: TEST FOR ELASTIC SCATTERING (EITHER N-N OR DELTA-DELTA 0R
4744 *      N-DELTA OR N*-N* or N*-Delta)
4745 c      IF (X1 .LE. SIGNN/SIG) THEN
4746       IF (X1.LE.(SIGNN/SIG)) THEN
4747 *COM:  PARAMETRISATION IS TAKEN FROM THE CUGNON-PAPER
4748          AS  = ( 3.65 * (SRT - 1.8766) )**6
4749          A   = 6.0 * AS / (1.0 + AS)
4750          TA  = -2.0 * PR**2
4751          X   = RANART(NSEED)
4752 clin-10/24/02        T1  = DLOG( (1-X) * DEXP(dble(A)*dble(TA)) + X )  /  A
4753          T1  = sngl(DLOG(dble(1.-X)*DEXP(dble(A)*dble(TA))+dble(X)))/  A
4754          C1  = 1.0 - T1/TA
4755          T1  = 2.0 * PI * RANART(NSEED)
4756          IBLOCK=1
4757          GO TO 107
4758       ELSE
4759 *COM: TEST FOR INELASTIC SCATTERING
4760 *     IF THE AVAILABLE ENERGY IS LESS THAN THE PION-MASS, NOTHING
4761 *     CAN HAPPEN ANY MORE ==> RETURN (2.012 = 2*AVMASS + PI-MASS)
4762 clin-5/2008: Mdeuteron+Mpi=2.0106 to 2.0152 GeV/c2, so we can still use this:
4763          IF (SRT .LT. 2.012) RETURN
4764 *     calculate the N*(1535) production cross section in N+N collisions
4765 *     note that the cross sections in this subroutine are in units of mb
4766 *     as only ratios of the cross sections are used to determine the
4767 *     reaction channels
4768        call N1535(iabs(lb(i1)),iabs(lb(i2)),srt,x1535)
4769 *COM: HERE WE HAVE A PROCESS N+N ==> N+DELTA,OR N+N==>N+N*(144) or N*(1535)
4770 *     OR
4771 * 3 pi channel : N+N==>d1+d2+PION
4772        SIG3=3.*(X3pi(SRT)+x33pi(srt))
4773 * 2 pi channel : N+N==>d1+d2+d1*n*+n*n*
4774        SIG4=4.*X2pi(srt)
4775 * 4 pi channel : N+N==>d1+d2+rho
4776        s4pi=x4pi(srt)
4777 * N+N-->NN+rho channel
4778        srho=xrho(srt)
4779 * N+N-->NN+omega
4780        somega=omega(srt)
4781 * CROSS SECTION FOR KAON PRODUCTION from the four channels
4782 * for NLK channel
4783        akp=0.498
4784        ak0=0.498
4785        ana=0.94
4786        ada=1.232
4787        al=1.1157
4788        as=1.1197
4789        xsk1=0
4790        xsk2=0
4791        xsk3=0
4792        xsk4=0
4793        xsk5=0
4794        t1nlk=ana+al+akp
4795        if(srt.le.t1nlk)go to 222
4796        XSK1=1.5*PPLPK(SRT)
4797 * for DLK channel
4798        t1dlk=ada+al+akp
4799        t2dlk=ada+al-akp
4800        if(srt.le.t1dlk)go to 222
4801        es=srt
4802        pmdlk2=(es**2-t1dlk**2)*(es**2-t2dlk**2)/(4.*es**2)
4803        pmdlk=sqrt(pmdlk2)
4804        XSK3=1.5*PPLPK(srt)
4805 * for NSK channel
4806        t1nsk=ana+as+akp
4807        t2nsk=ana+as-akp
4808        if(srt.le.t1nsk)go to 222
4809        pmnsk2=(es**2-t1nsk**2)*(es**2-t2nsk**2)/(4.*es**2)
4810        pmnsk=sqrt(pmnsk2)
4811        XSK2=1.5*(PPK1(srt)+PPK0(srt))
4812 * for DSK channel
4813        t1DSk=aDa+aS+akp
4814        t2DSk=aDa+aS-akp
4815        if(srt.le.t1dsk)go to 222
4816        pmDSk2=(es**2-t1DSk**2)*(es**2-t2DSk**2)/(4.*es**2)
4817        pmDSk=sqrt(pmDSk2)
4818        XSK4=1.5*(PPK1(srt)+PPK0(srt))
4819 csp11/21/01
4820 c phi production
4821        if(srt.le.(2.*amn+aphi))go to 222
4822 c  !! mb put the correct form
4823        xsk5 = 0.0001
4824 csp11/21/01 end
4825 c
4826 * THE TOTAL KAON+ PRODUCTION CROSS SECTION IS THEN
4827  222   SIGK=XSK1+XSK2+XSK3+XSK4
4828
4829 cbz3/7/99 neutralk
4830         XSK1 = 2.0 * XSK1
4831         XSK2 = 2.0 * XSK2
4832         XSK3 = 2.0 * XSK3
4833         XSK4 = 2.0 * XSK4
4834         SIGK = 2.0 * SIGK + xsk5
4835 cbz3/7/99 neutralk end
4836 c
4837 ** FOR P+P or L/S+L/S COLLISION:
4838 c       lb1=lb(i1)
4839 c       lb2=lb(i2)
4840         lb1=iabs(lb(i1))
4841         lb2=iabs(lb(i2))
4842         IF((LB(I1)*LB(I2).EQ.1).or.
4843      &       ((lb1.le.17.and.lb1.ge.14).and.(lb2.le.17.and.lb2.ge.14)).
4844      &       or.((lb1.le.2).and.(lb2.le.17.and.lb2.ge.14)).
4845      &       or.((lb2.le.2).and.(lb1.le.17.and.lb1.ge.14)))THEN
4846 clin-8/2008 PP->d+meson here:
4847            IF(X1.LE.((SIGNN+sdprod)/SIG)) GO TO 108
4848            SIG1=SIGMA(SRT,1,1,0)+0.5*SIGMA(SRT,1,1,1)
4849            SIG2=1.5*SIGMA(SRT,1,1,1)
4850            SIGND=SIG1+SIG2+SIG3+SIG4+X1535+SIGK+s4pi+srho+somega
4851 clin-5/2008:
4852 c           IF (X1.GT.(SIGNN+SIGND)/SIG)RETURN
4853            IF (X1.GT.(SIGNN+SIGND+sdprod)/SIG)RETURN
4854            DIR=SIG3/SIGND
4855            IF(RANART(NSEED).LE.DIR)GO TO 106
4856            IF(RANART(NSEED).LE.SIGK/(SIGK+X1535+SIG4+SIG2+SIG1
4857      &          +s4pi+srho+somega))GO TO 306
4858            if(RANART(NSEED).le.s4pi/(x1535+sig4+sig2+sig1
4859      &          +s4pi+srho+somega))go to 307
4860            if(RANART(NSEED).le.srho/(x1535+sig4+sig2+sig1
4861      &          +srho+somega))go to 308
4862            if(RANART(NSEED).le.somega/(x1535+sig4+sig2+sig1
4863      &          +somega))go to 309
4864            if(RANART(NSEED).le.x1535/(sig1+sig2+sig4+x1535))then
4865 * N*(1535) production
4866               N12=9
4867            ELSE
4868               IF(RANART(NSEED).LE.SIG4/(SIG1+sig2+sig4))THEN
4869 * DOUBLE DELTA PRODUCTION
4870                  N12=66
4871                  GO TO 1012
4872               else
4873 *DELTA PRODUCTION
4874                  N12=3
4875                  IF (RANART(NSEED).GT.SIG1/(SIG1+SIG2))N12=4
4876               ENDIF
4877            endif
4878            GO TO 1011
4879         ENDIF
4880 ** FOR N+N COLLISION:
4881         IF(iabs(LB(I1)).EQ.2.AND.iabs(LB(I2)).EQ.2)THEN
4882 clin-8/2008 NN->d+meson here:
4883            IF(X1.LE.((SIGNN+sdprod)/SIG)) GO TO 108
4884            SIG1=SIGMA(SRT,1,1,0)+0.5*SIGMA(SRT,1,1,1)
4885            SIG2=1.5*SIGMA(SRT,1,1,1)
4886            SIGND=SIG1+SIG2+X1535+SIG3+SIG4+SIGK+s4pi+srho+somega
4887 clin-5/2008:
4888 c           IF (X1.GT.(SIGNN+SIGND)/SIG)RETURN
4889            IF (X1.GT.(SIGNN+SIGND+sdprod)/SIG)RETURN
4890            dir=sig3/signd
4891            IF(RANART(NSEED).LE.DIR)GO TO 106
4892            IF(RANART(NSEED).LE.SIGK/(SIGK+X1535+SIG4+SIG2+SIG1
4893      &          +s4pi+srho+somega))GO TO 306
4894            if(RANART(NSEED).le.s4pi/(x1535+sig4+sig2+sig1
4895      &          +s4pi+srho+somega))go to 307
4896            if(RANART(NSEED).le.srho/(x1535+sig4+sig2+sig1
4897      &          +srho+somega))go to 308
4898            if(RANART(NSEED).le.somega/(x1535+sig4+sig2+sig1
4899      &          +somega))go to 309
4900            IF(RANART(NSEED).LE.X1535/(x1535+sig1+sig2+sig4))THEN
4901 * N*(1535) PRODUCTION
4902               N12=10
4903            ELSE
4904               if(RANART(NSEED).le.sig4/(sig1+sig2+sig4))then
4905 * double delta production
4906                  N12=67
4907                  GO TO 1013
4908               else
4909 * DELTA PRODUCTION
4910                  N12=6
4911                  IF (RANART(NSEED).GT.SIG1/(SIG1+SIG2))N12=5
4912               ENDIF
4913            endif
4914            GO TO 1011
4915         ENDIF
4916 ** FOR N+P COLLISION
4917         IF(LB(I1)*LB(I2).EQ.2)THEN
4918 clin-5/2008 NP->d+meson here:
4919            IF(X1.LE.((SIGNN+sdprod)/SIG)) GO TO 108
4920            SIG1=0.5*SIGMA(SRT,1,1,1)+0.25*SIGMA(SRT,1,1,0)
4921            IF(NSTAR.EQ.1)THEN
4922               SIG2=(3./4.)*SIGMA(SRT,2,0,1)
4923            ELSE
4924               SIG2=0.
4925            ENDIF
4926            SIGND=2.*(SIG1+SIG2+X1535)+sig3+sig4+SIGK+s4pi+srho+somega
4927 clin-5/2008:
4928 c           IF (X1.GT.(SIGNN+SIGND)/SIG)RETURN
4929            IF (X1.GT.(SIGNN+SIGND+sdprod)/SIG)RETURN
4930            dir=sig3/signd
4931            IF(RANART(NSEED).LE.DIR)GO TO 106
4932            IF(RANART(NSEED).LE.SIGK/(SIGND-SIG3))GO TO 306
4933            if(RANART(NSEED).le.s4pi/(signd-sig3-sigk))go to 307
4934            if(RANART(NSEED).le.srho/(signd-sig3-sigk-s4pi))go to 308
4935            if(RANART(NSEED).le.somega/(signd-sig3-sigk-s4pi-srho))
4936      1          go to 309
4937            IF(RANART(NSEED).LT.X1535/(SIG1+SIG2+X1535+0.5*sig4))THEN
4938 * N*(1535) PRODUCTION
4939               N12=11
4940               IF(RANART(NSEED).LE.0.5)N12=12
4941            ELSE
4942               if(RANART(NSEED).le.sig4/(sig4+2.*(sig1+sig2)))then
4943 * double resonance production
4944                  N12=68
4945                  GO TO 1014
4946               else
4947                  IF(RANART(NSEED).LE.SIG1/(SIG1+SIG2))THEN
4948 * DELTA PRODUCTION
4949                     N12=2
4950                     IF(RANART(NSEED).GE.0.5)N12=1
4951                  ELSE
4952 * N*(1440) PRODUCTION
4953                     N12=8
4954                     IF(RANART(NSEED).GE.0.5)N12=7
4955                  ENDIF
4956               ENDIF
4957            ENDIF
4958         endif
4959  1011   iblock=2
4960         CONTINUE
4961 *PARAMETRIZATION OF THE SHAPE OF THE DELTA RESONANCE ACCORDING
4962 *     TO kitazoe's or J.D.JACKSON'S MASS FORMULA AND BREIT WIGNER
4963 *     FORMULA FOR N* RESORANCE
4964 *     DETERMINE DELTA MASS VIA REJECTION METHOD.
4965           DMAX = SRT - AVMASS-0.005
4966           DMAX = SRT - AVMASS-0.005
4967           DMIN = 1.078
4968                    IF(N12.LT.7)THEN
4969 * Delta(1232) production
4970           IF(DMAX.LT.1.232) THEN
4971           FM=FDE(DMAX,SRT,0.)
4972           ELSE
4973
4974 clin-10/25/02 get rid of argument usage mismatch in FDE():
4975              xdmass=1.232
4976 c          FM=FDE(1.232,SRT,1.)
4977           FM=FDE(xdmass,SRT,1.)
4978 clin-10/25/02-end
4979
4980           ENDIF
4981           IF(FM.EQ.0.)FM=1.E-09
4982           NTRY1=0
4983 10        DM = RANART(NSEED) * (DMAX-DMIN) + DMIN
4984           NTRY1=NTRY1+1
4985           IF((RANART(NSEED) .GT. FDE(DM,SRT,1.)/FM).AND.
4986      1    (NTRY1.LE.30)) GOTO 10
4987
4988 clin-2/26/03 limit the Delta mass below a certain value
4989 c     (here taken as its central value + 2* B-W fullwidth):
4990           if(dm.gt.1.47) goto 10
4991
4992               GO TO 13
4993               ENDIF
4994                    IF((n12.eq.7).or.(n12.eq.8))THEN
4995 * N*(1440) production
4996           IF(DMAX.LT.1.44) THEN
4997           FM=FNS(DMAX,SRT,0.)
4998           ELSE
4999
5000 clin-10/25/02 get rid of argument usage mismatch in FNS():
5001              xdmass=1.44
5002 c          FM=FNS(1.44,SRT,1.)
5003           FM=FNS(xdmass,SRT,1.)
5004 clin-10/25/02-end
5005
5006           ENDIF
5007           IF(FM.EQ.0.)FM=1.E-09
5008           NTRY2=0
5009 11        DM=RANART(NSEED)*(DMAX-DMIN)+DMIN
5010           NTRY2=NTRY2+1
5011           IF((RANART(NSEED).GT.FNS(DM,SRT,1.)/FM).AND.
5012      1    (NTRY2.LE.10)) GO TO 11
5013
5014 clin-2/26/03 limit the N* mass below a certain value
5015 c     (here taken as its central value + 2* B-W fullwidth):
5016           if(dm.gt.2.14) goto 11
5017
5018               GO TO 13
5019               ENDIF
5020                     IF(n12.ge.17)then
5021 * N*(1535) production
5022           IF(DMAX.LT.1.535) THEN
5023           FM=FD5(DMAX,SRT,0.)
5024           ELSE
5025
5026 clin-10/25/02 get rid of argument usage mismatch in FNS():
5027              xdmass=1.535
5028 c          FM=FD5(1.535,SRT,1.)
5029           FM=FD5(xdmass,SRT,1.)
5030 clin-10/25/02-end
5031
5032           ENDIF
5033           IF(FM.EQ.0.)FM=1.E-09
5034           NTRY1=0
5035 12        DM = RANART(NSEED) * (DMAX-DMIN) + DMIN
5036           NTRY1=NTRY1+1
5037           IF((RANART(NSEED) .GT. FD5(DM,SRT,1.)/FM).AND.
5038      1    (NTRY1.LE.10)) GOTO 12
5039
5040 clin-2/26/03 limit the N* mass below a certain value
5041 c     (here taken as its central value + 2* B-W fullwidth):
5042           if(dm.gt.1.84) goto 12
5043
5044          GO TO 13
5045              ENDIF
5046 * CALCULATE THE MASSES OF BARYON RESONANCES IN THE DOUBLE RESONANCE
5047 * PRODUCTION PROCESS AND RELABLE THE PARTICLES
5048 1012       iblock=43
5049        call Rmasdd(srt,1.232,1.232,1.08,
5050      &  1.08,ISEED,1,dm1,dm2)
5051        call Rmasdd(srt,1.232,1.44,1.08,
5052      &  1.08,ISEED,3,dm1n,dm2n)
5053        IF(N12.EQ.66)THEN
5054 *(1) PP-->DOUBLE RESONANCES
5055 * DETERMINE THE FINAL STATE
5056        XFINAL=RANART(NSEED)
5057        IF(XFINAL.LE.0.25)THEN
5058 * (1.1) D+++D0
5059        LB(I1)=9
5060        LB(I2)=7
5061        e(i1)=dm1
5062        e(i2)=dm2
5063        GO TO 200
5064 * go to 200 to set the new momentum
5065        ENDIF
5066        IF((XFINAL.gt.0.25).and.(xfinal.le.0.5))THEN
5067 * (1.2) D++D+
5068        LB(I1)=8
5069        LB(I2)=8
5070        e(i1)=dm1
5071        e(i2)=dm2
5072        GO TO 200
5073 * go to 200 to set the new momentum
5074        ENDIF
5075        IF((XFINAL.gt.0.5).and.(xfinal.le.0.75))THEN
5076 * (1.3) D+++N*0
5077        LB(I1)=9
5078        LB(I2)=10
5079        e(i1)=dm1n
5080        e(i2)=dm2n
5081        GO TO 200
5082 * go to 200 to set the new momentum
5083        ENDIF
5084        IF(XFINAL.gt.0.75)then
5085 * (1.4) D++N*+
5086        LB(I1)=8
5087        LB(I2)=11
5088        e(i1)=dm1n
5089        e(i2)=dm2n
5090        GO TO 200
5091 * go to 200 to set the new momentum
5092        ENDIF
5093        ENDIF
5094 1013       iblock=43
5095        call Rmasdd(srt,1.232,1.232,1.08,
5096      &  1.08,ISEED,1,dm1,dm2)
5097        call Rmasdd(srt,1.232,1.44,1.08,
5098      &  1.08,ISEED,3,dm1n,dm2n)
5099        IF(N12.EQ.67)THEN
5100 *(2) NN-->DOUBLE RESONANCES
5101 * DETERMINE THE FINAL STATE
5102        XFINAL=RANART(NSEED)
5103        IF(XFINAL.LE.0.25)THEN
5104 * (2.1) D0+D0
5105        LB(I1)=7
5106        LB(I2)=7
5107        e(i1)=dm1
5108        e(i2)=dm2
5109        GO TO 200
5110 * go to 200 to set the new momentum
5111         ENDIF
5112        IF((XFINAL.gt.0.25).and.(xfinal.le.0.5))THEN
5113 * (2.2) D++D+
5114        LB(I1)=6
5115        LB(I2)=8
5116        e(i1)=dm1
5117        e(i2)=dm2
5118        GO TO 200
5119 * go to 200 to set the new momentum
5120        ENDIF
5121        IF((XFINAL.gt.0.5).and.(xfinal.le.0.75))THEN
5122 * (2.3) D0+N*0
5123        LB(I1)=7
5124        LB(I2)=10
5125        e(i1)=dm1n
5126        e(i2)=dm2n
5127        GO TO 200
5128 * go to 200 to set the new momentum
5129        ENDIF
5130        IF(XFINAL.gt.0.75)then
5131 * (2.4) D++N*+
5132        LB(I1)=8
5133        LB(I2)=11
5134        e(i1)=dm1n
5135        e(i2)=dm2n
5136        GO TO 200
5137 * go to 200 to set the new momentum
5138        ENDIF
5139        ENDIF
5140 1014       iblock=43
5141        call Rmasdd(srt,1.232,1.232,1.08,
5142      &  1.08,ISEED,1,dm1,dm2)
5143        call Rmasdd(srt,1.232,1.44,1.08,
5144      &  1.08,ISEED,3,dm1n,dm2n)
5145        IF(N12.EQ.68)THEN
5146 *(3) NP-->DOUBLE RESONANCES
5147 * DETERMINE THE FINAL STATE
5148        XFINAL=RANART(NSEED)
5149        IF(XFINAL.LE.0.25)THEN
5150 * (3.1) D0+D+
5151        LB(I1)=7
5152        LB(I2)=8
5153        e(i1)=dm1
5154        e(i2)=dm2
5155        GO TO 200
5156 * go to 200 to set the new momentum
5157        ENDIF
5158        IF((XFINAL.gt.0.25).and.(xfinal.le.0.5))THEN
5159 * (3.2) D+++D-
5160        LB(I1)=9
5161        LB(I2)=6
5162        e(i1)=dm1
5163        e(i2)=dm2
5164        GO TO 200
5165 * go to 200 to set the new momentum
5166        ENDIF
5167        IF((XFINAL.gt.0.5).and.(xfinal.le.0.75))THEN
5168 * (3.3) D0+N*+
5169        LB(I1)=7
5170        LB(I2)=11
5171        e(i1)=dm1n
5172        e(i2)=dm2n
5173        GO TO 200
5174 * go to 200 to set the new momentum
5175        ENDIF
5176        IF(XFINAL.gt.0.75)then
5177 * (3.4) D++N*0
5178        LB(I1)=8
5179        LB(I2)=10
5180        e(i1)=dm1n
5181        e(i2)=dm2n
5182        GO TO 200
5183 * go to 200 to set the new momentum
5184        ENDIF
5185        ENDIF
5186 13       CONTINUE
5187 *-------------------------------------------------------
5188 * RELABLE BARYON I1 AND I2
5189 *1. p+n-->delta(+)+n
5190           IF(N12.EQ.1)THEN
5191           IF(iabs(LB(I1)).EQ.1)THEN
5192           LB(I2)=2
5193           LB(I1)=8
5194           E(I1)=DM
5195           ELSE
5196           LB(I1)=2
5197           LB(I2)=8
5198           E(I2)=DM
5199           ENDIF
5200          GO TO 200
5201           ENDIF
5202 *2 p+n-->delta(0)+p
5203           IF(N12.EQ.2)THEN
5204           IF(iabs(LB(I1)).EQ.2)THEN
5205           LB(I2)=1
5206           LB(I1)=7
5207           E(I1)=DM
5208           ELSE
5209           LB(I1)=1
5210           LB(I2)=7
5211           E(I2)=DM
5212           ENDIF
5213          GO TO 200
5214           ENDIF
5215 *3 p+p-->delta(++)+n
5216           IF(N12.EQ.3)THEN
5217           LB(I1)=9
5218           E(I1)=DM
5219           LB(I2)=2
5220           E(I2)=AMN
5221          GO TO 200
5222           ENDIF
5223 *4 p+p-->delta(+)+p
5224           IF(N12.EQ.4)THEN
5225           LB(I2)=1
5226           LB(I1)=8
5227           E(I1)=DM
5228          GO TO 200
5229           ENDIF
5230 *5 n+n--> delta(0)+n
5231           IF(N12.EQ.5)THEN
5232           LB(I2)=2
5233           LB(I1)=7
5234           E(I1)=DM
5235          GO TO 200
5236           ENDIF
5237 *6 n+n--> delta(-)+p
5238           IF(N12.EQ.6)THEN
5239           LB(I1)=6
5240           E(I1)=DM
5241           LB(I2)=1
5242           E(I2)=AMP
5243          GO TO 200
5244           ENDIF
5245 *7 n+p--> N*(0)+p
5246           IF(N12.EQ.7)THEN
5247           IF(iabs(LB(I1)).EQ.1)THEN
5248           LB(I1)=1
5249           LB(I2)=10
5250           E(I2)=DM
5251           ELSE
5252           LB(I2)=1
5253           LB(I1)=10
5254           E(I1)=DM
5255           ENDIF
5256          GO TO 200
5257           ENDIF
5258 *8 n+p--> N*(+)+n
5259           IF(N12.EQ.8)THEN
5260           IF(iabs(LB(I1)).EQ.1)THEN
5261           LB(I2)=2
5262           LB(I1)=11
5263           E(I1)=DM
5264           ELSE
5265           LB(I1)=2
5266           LB(I2)=11
5267           E(I2)=DM
5268           ENDIF
5269          GO TO 200
5270           ENDIF
5271 *9 p+p--> N*(+)(1535)+p
5272           IF(N12.EQ.9)THEN
5273           IF(RANART(NSEED).le.0.5)THEN
5274           LB(I2)=1
5275           LB(I1)=13
5276           E(I1)=DM
5277           ELSE
5278           LB(I1)=1
5279           LB(I2)=13
5280           E(I2)=DM
5281           ENDIF
5282          GO TO 200
5283           ENDIF
5284 *10 n+n--> N*(0)(1535)+n
5285           IF(N12.EQ.10)THEN
5286           IF(RANART(NSEED).le.0.5)THEN
5287           LB(I2)=2
5288           LB(I1)=12
5289           E(I1)=DM
5290           ELSE
5291           LB(I1)=2
5292           LB(I2)=12
5293           E(I2)=DM
5294           ENDIF
5295          GO TO 200
5296           ENDIF
5297 *11 n+p--> N*(+)(1535)+n
5298           IF(N12.EQ.11)THEN
5299           IF(iabs(LB(I1)).EQ.2)THEN
5300           LB(I1)=2
5301           LB(I2)=13
5302           E(I2)=DM
5303           ELSE
5304           LB(I2)=2
5305           LB(I1)=13
5306           E(I1)=DM
5307           ENDIF
5308          GO TO 200
5309           ENDIF
5310 *12 n+p--> N*(0)(1535)+p
5311           IF(N12.EQ.12)THEN
5312           IF(iabs(LB(I1)).EQ.1)THEN
5313           LB(I1)=1
5314           LB(I2)=12
5315           E(I2)=DM
5316           ELSE
5317           LB(I2)=1
5318           LB(I1)=12
5319           E(I1)=DM
5320           ENDIF
5321           ENDIF
5322          endif
5323 * CALCULATE THE MAGNITUDE OF THE FINAL MOMENTUM THROUGH
5324 * ENERGY CONSERVATION
5325 200       EM1=E(I1)
5326           EM2=E(I2)
5327           PR2   = (SRT**2 - EM1**2 - EM2**2)**2
5328      1                - 4.0 * (EM1*EM2)**2
5329           IF(PR2.LE.0.)PR2=1.e-09
5330           PR=SQRT(PR2)/(2.*SRT)
5331               if(srt.le.2.14)C1= 1.0 - 2.0 * RANART(NSEED)
5332          if(srt.gt.2.14.and.srt.le.2.4)c1=ang(srt,iseed)
5333          if(srt.gt.2.4)then
5334
5335 clin-10/25/02 get rid of argument usage mismatch in PTR():
5336              xptr=0.33*pr
5337 c         cc1=ptr(0.33*pr,iseed)
5338              cc1=ptr(xptr,iseed)
5339 clin-10/25/02-end
5340
5341          c1=sqrt(pr**2-cc1**2)/pr
5342          endif
5343           T1   = 2.0 * PI * RANART(NSEED)
5344        if(ianti.eq.1 .and. lb(i1).ge.1 .and. lb(i2).ge.1)then
5345          lb(i1) = -lb(i1)
5346          lb(i2) = -lb(i2)
5347        endif
5348           GO TO 107
5349 *FOR THE NN-->D1+D2+PI PROCESS, FIND MOMENTUM OF THE FINAL TWO
5350 *DELTAS AND PION IN THE NUCLEUS-NUCLEUS CMS.
5351 106     CONTINUE
5352            NTRY1=0
5353 123        CALL DDP2(SRT,ISEED,PX3,PY3,PZ3,DM3,PX4,PY4,PZ4,DM4,
5354      &  PPX,PPY,PPZ,icou1)
5355        NTRY1=NTRY1+1
5356        if((icou1.lt.0).AND.(NTRY1.LE.40))GO TO 123
5357 C       if(icou1.lt.0)return
5358 * ROTATE THE MOMENTA OF PARTICLES IN THE CMS OF P1+P2
5359        CALL ROTATE(PX,PY,PZ,PX3,PY3,PZ3)
5360        CALL ROTATE(PX,PY,PZ,PX4,PY4,PZ4)
5361        CALL ROTATE(PX,PY,PZ,PPX,PPY,PPZ)
5362                 NNN=NNN+1
5363 * DETERMINE THE CHARGE STATES OF PARTICLES IN THE FINAL STATE
5364 * (1) FOR P+P
5365               XDIR=RANART(NSEED)
5366                 IF(LB(I1)*LB(I2).EQ.1)THEN
5367                 IF(XDIR.Le.0.2)then
5368 * (1.1)P+P-->D+++D0+PION(0)
5369                 LPION(NNN,IRUN)=4
5370                 EPION(NNN,IRUN)=AP1
5371               LB(I1)=9
5372               LB(I2)=7
5373        GO TO 205
5374                 ENDIF
5375 * (1.2)P+P -->D++D+PION(0)
5376                 IF((XDIR.LE.0.4).AND.(XDIR.GT.0.2))THEN
5377                 LPION(NNN,IRUN)=4
5378                 EPION(NNN,IRUN)=AP1
5379                 LB(I1)=8
5380                 LB(I2)=8
5381        GO TO 205
5382               ENDIF
5383 * (1.3)P+P-->D+++D+PION(-)
5384                 IF((XDIR.LE.0.6).AND.(XDIR.GT.0.4))THEN
5385                 LPION(NNN,IRUN)=3
5386                 EPION(NNN,IRUN)=AP2
5387                 LB(I1)=9
5388                 LB(I2)=8
5389        GO TO 205
5390               ENDIF
5391                 IF((XDIR.LE.0.8).AND.(XDIR.GT.0.6))THEN
5392                 LPION(NNN,IRUN)=5
5393                 EPION(NNN,IRUN)=AP2
5394                 LB(I1)=9
5395                 LB(I2)=6
5396        GO TO 205
5397               ENDIF
5398                 IF(XDIR.GT.0.8)THEN
5399                 LPION(NNN,IRUN)=5
5400                 EPION(NNN,IRUN)=AP2
5401                 LB(I1)=7
5402                 LB(I2)=8
5403        GO TO 205
5404               ENDIF
5405                ENDIF
5406 * (2)FOR N+N
5407                 IF(iabs(LB(I1)).EQ.2.AND.iabs(LB(I2)).EQ.2)THEN
5408                 IF(XDIR.Le.0.2)then
5409 * (2.1)N+N-->D++D-+PION(0)
5410                 LPION(NNN,IRUN)=4
5411                 EPION(NNN,IRUN)=AP1
5412               LB(I1)=6
5413               LB(I2)=7
5414        GO TO 205
5415                 ENDIF
5416 * (2.2)N+N -->D+++D-+PION(-)
5417                 IF((XDIR.LE.0.4).AND.(XDIR.GT.0.2))THEN
5418                 LPION(NNN,IRUN)=3
5419                 EPION(NNN,IRUN)=AP2
5420                 LB(I1)=6
5421                 LB(I2)=9
5422        GO TO 205
5423               ENDIF
5424 * (2.3)P+P-->D0+D-+PION(+)
5425                 IF((XDIR.GT.0.4).AND.(XDIR.LE.0.6))THEN
5426                 LPION(NNN,IRUN)=5
5427                 EPION(NNN,IRUN)=AP2
5428                 LB(I1)=9
5429                 LB(I2)=8
5430        GO TO 205
5431               ENDIF
5432 * (2.4)P+P-->D0+D0+PION(0)
5433                 IF((XDIR.GT.0.6).AND.(XDIR.LE.0.8))THEN
5434                 LPION(NNN,IRUN)=4
5435                 EPION(NNN,IRUN)=AP1
5436                 LB(I1)=7
5437                 LB(I2)=7
5438        GO TO 205
5439               ENDIF
5440 * (2.5)P+P-->D0+D++PION(-)
5441                 IF(XDIR.GT.0.8)THEN
5442                 LPION(NNN,IRUN)=3
5443                 EPION(NNN,IRUN)=AP2
5444                 LB(I1)=7
5445                 LB(I2)=8
5446        GO TO 205
5447               ENDIF
5448               ENDIF
5449 * (3)FOR N+P
5450                 IF(LB(I1)*LB(I2).EQ.2)THEN
5451                 IF(XDIR.Le.0.17)then
5452 * (3.1)N+P-->D+++D-+PION(0)
5453                 LPION(NNN,IRUN)=4
5454                 EPION(NNN,IRUN)=AP1
5455               LB(I1)=6
5456               LB(I2)=9
5457        GO TO 205
5458                 ENDIF
5459 * (3.2)N+P -->D+++D0+PION(-)
5460                 IF((XDIR.LE.0.34).AND.(XDIR.GT.0.17))THEN
5461                 LPION(NNN,IRUN)=3
5462                 EPION(NNN,IRUN)=AP2
5463                 LB(I1)=7
5464                 LB(I2)=9
5465        GO TO 205
5466               ENDIF
5467 * (3.3)N+P-->D++D-+PION(+)
5468                 IF((XDIR.GT.0.34).AND.(XDIR.LE.0.51))THEN
5469                 LPION(NNN,IRUN)=5
5470                 EPION(NNN,IRUN)=AP2
5471                 LB(I1)=7
5472                 LB(I2)=8
5473        GO TO 205
5474               ENDIF
5475 * (3.4)N+P-->D++D++PION(-)
5476                 IF((XDIR.GT.0.51).AND.(XDIR.LE.0.68))THEN
5477                 LPION(NNN,IRUN)=3
5478                 EPION(NNN,IRUN)=AP2
5479                 LB(I1)=8
5480                 LB(I2)=8
5481        GO TO 205
5482               ENDIF
5483 * (3.5)N+P-->D0+D++PION(0)
5484                 IF((XDIR.GT.0.68).AND.(XDIR.LE.0.85))THEN
5485                 LPION(NNN,IRUN)=4
5486                 EPION(NNN,IRUN)=AP2
5487                 LB(I1)=7
5488                 LB(I2)=8
5489        GO TO 205
5490               ENDIF
5491 * (3.6)N+P-->D0+D0+PION(+)
5492                 IF(XDIR.GT.0.85)THEN
5493                 LPION(NNN,IRUN)=5
5494                 EPION(NNN,IRUN)=AP2
5495                 LB(I1)=7
5496                 LB(I2)=7
5497               ENDIF
5498                 ENDIF
5499 * FIND THE MOMENTUM OF PARTICLES IN THE FINAL STATE IN THE NUCLEUS-
5500 * NUCLEUS CMS. FRAME
5501 *             LORENTZ-TRANSFORMATION INTO LAB FRAME FOR DELTA1
5502 205           E1CM    = SQRT (dm3**2 + PX3**2 + PY3**2 + PZ3**2)
5503               P1BETA  = PX3*BETAX + PY3*BETAY + PZ3*BETAZ
5504               TRANSF  = GAMMA * ( GAMMA * P1BETA / (GAMMA + 1) + E1CM )
5505               Pt1i1 = BETAX * TRANSF + PX3
5506               Pt2i1 = BETAY * TRANSF + PY3
5507               Pt3i1 = BETAZ * TRANSF + PZ3
5508              Eti1   = DM3
5509 c
5510              if(ianti.eq.1 .and. lb(i1).ge.1 .and. lb(i2).ge.1)then
5511                lb(i1) = -lb(i1)
5512                lb(i2) = -lb(i2)
5513                 if(LPION(NNN,IRUN) .eq. 3)then
5514                   LPION(NNN,IRUN)=5
5515                 elseif(LPION(NNN,IRUN) .eq. 5)then
5516                   LPION(NNN,IRUN)=3
5517                 endif
5518                endif
5519 c
5520              lb1=lb(i1)
5521 * FOR DELTA2
5522                 E2CM    = SQRT (dm4**2 + PX4**2 + PY4**2 + PZ4**2)
5523                 P2BETA  = PX4*BETAX+PY4*BETAY+PZ4*BETAZ
5524                 TRANSF  = GAMMA * (GAMMA*P2BETA / (GAMMA + 1.) + E2CM)
5525                 Pt1I2 = BETAX * TRANSF + PX4
5526                 Pt2I2 = BETAY * TRANSF + PY4
5527                 Pt3I2 = BETAZ * TRANSF + PZ4
5528               EtI2   = DM4
5529               lb2=lb(i2)
5530 * assign delta1 and delta2 to i1 or i2 to keep the leadng particle
5531 * behaviour
5532 C              if((pt1i1*px1+pt2i1*py1+pt3i1*pz1).gt.0)then
5533               p(1,i1)=pt1i1
5534               p(2,i1)=pt2i1
5535               p(3,i1)=pt3i1
5536               e(i1)=eti1
5537               lb(i1)=lb1
5538               p(1,i2)=pt1i2
5539               p(2,i2)=pt2i2
5540               p(3,i2)=pt3i2
5541               e(i2)=eti2
5542               lb(i2)=lb2
5543                 PX1     = P(1,I1)
5544                 PY1     = P(2,I1)
5545                 PZ1     = P(3,I1)
5546               EM1       = E(I1)
5547                 ID(I1)  = 2
5548                 ID(I2)  = 2
5549                 ID1     = ID(I1)
5550                 IBLOCK=4
5551 * GET PION'S MOMENTUM AND COORDINATES IN NUCLEUS-NUCLEUS CMS. FRAME
5552                 EPCM=SQRT(EPION(NNN,IRUN)**2+PPX**2+PPY**2+PPZ**2)
5553                 PPBETA=PPX*BETAX+PPY*BETAY+PPZ*BETAZ
5554                 TRANSF=GAMMA*(GAMMA*PPBETA/(GAMMA+1.)+EPCM)
5555                 PPION(1,NNN,IRUN)=BETAX*TRANSF+PPX
5556                 PPION(2,NNN,IRUN)=BETAY*TRANSF+PPY
5557                 PPION(3,NNN,IRUN)=BETAZ*TRANSF+PPZ
5558 clin-5/2008:
5559                 dppion(nnn,irun)=dpertp(i1)*dpertp(i2)
5560 clin-5/2008 do not allow smearing in position of produced particles
5561 c     to avoid immediate reinteraction with the particle I1, I2 or themselves:
5562 c2002        X01 = 1.0 - 2.0 * RANART(NSEED)
5563 c            Y01 = 1.0 - 2.0 * RANART(NSEED)
5564 c            Z01 = 1.0 - 2.0 * RANART(NSEED)
5565 c        IF ((X01*X01+Y01*Y01+Z01*Z01) .GT. 1.0) GOTO 2002
5566 c                RPION(1,NNN,IRUN)=R(1,I1)+0.5*x01
5567 c                RPION(2,NNN,IRUN)=R(2,I1)+0.5*y01
5568 c                RPION(3,NNN,IRUN)=R(3,I1)+0.5*z01
5569                 RPION(1,NNN,IRUN)=R(1,I1)
5570                 RPION(2,NNN,IRUN)=R(2,I1)
5571                 RPION(3,NNN,IRUN)=R(3,I1)
5572 c
5573               go to 90005
5574 clin-5/2008 N+N->Deuteron+pi:
5575 *     FIND MOMENTUM OF THE FINAL PARTICLES IN THE NUCLEUS-NUCLEUS CMS.
5576  108       CONTINUE
5577            if(idpert.eq.1.and.ipert1.eq.1.and.npertd.ge.1) then
5578 c     For idpert=1: we produce npertd pert deuterons:
5579               ndloop=npertd
5580            elseif(idpert.eq.2.and.npertd.ge.1) then
5581 c     For idpert=2: we first save information for npertd pert deuterons;
5582 c     at the last ndloop we create the regular deuteron+pi
5583 c     and those pert deuterons:
5584               ndloop=npertd+1
5585            else
5586 c     Just create the regular deuteron+pi:
5587               ndloop=1
5588            endif
5589 c
5590            dprob1=sdprod/sig/float(npertd)
5591            do idloop=1,ndloop
5592               CALL bbdangle(pxd,pyd,pzd,nt,ipert1,ianti,idloop,pfinal,
5593      1 dprob1,lbm)
5594               CALL ROTATE(PX,PY,PZ,PXd,PYd,PZd)
5595 *     LORENTZ-TRANSFORMATION OF THE MOMENTUM OF PARTICLES IN THE FINAL STATE
5596 *     FROM THE NN CMS FRAME INTO THE GLOBAL CMS FRAME:
5597 *     For the Deuteron:
5598               xmass=xmd
5599               E1dCM=SQRT(xmass**2+PXd**2+PYd**2+PZd**2)
5600               P1dBETA=PXd*BETAX+PYd*BETAY+PZd*BETAZ
5601               TRANSF=GAMMA*(GAMMA*P1dBETA/(GAMMA+1.)+E1dCM)
5602               pxi1=BETAX*TRANSF+PXd
5603               pyi1=BETAY*TRANSF+PYd
5604               pzi1=BETAZ*TRANSF+PZd
5605               if(ianti.eq.0)then
5606                  lbd=42
5607               else
5608                  lbd=-42
5609               endif
5610               if(idpert.eq.1.and.ipert1.eq.1.and.npertd.ge.1) then
5611 cccc  Perturbative production for idpert=1:
5612                  nnn=nnn+1
5613                  PPION(1,NNN,IRUN)=pxi1
5614                  PPION(2,NNN,IRUN)=pyi1
5615                  PPION(3,NNN,IRUN)=pzi1
5616                  EPION(NNN,IRUN)=xmd
5617                  LPION(NNN,IRUN)=lbd
5618                  RPION(1,NNN,IRUN)=R(1,I1)
5619                  RPION(2,NNN,IRUN)=R(2,I1)
5620                  RPION(3,NNN,IRUN)=R(3,I1)
5621 clin-5/2008 assign the perturbative probability:
5622                  dppion(NNN,IRUN)=sdprod/sig/float(npertd)
5623               elseif(idpert.eq.2.and.idloop.le.npertd) then
5624 clin-5/2008 For idpert=2, we produce NPERTD perturbative (anti)deuterons
5625 c     only when a regular (anti)deuteron+pi is produced in NN collisions.
5626 c     First save the info for the perturbative deuterons:
5627                  ppd(1,idloop)=pxi1
5628                  ppd(2,idloop)=pyi1
5629                  ppd(3,idloop)=pzi1
5630                  lbpd(idloop)=lbd
5631               else
5632 cccc  Regular production:
5633 c     For the regular pion: do LORENTZ-TRANSFORMATION:
5634                  E(i1)=xmm
5635                  E2piCM=SQRT(xmm**2+PXd**2+PYd**2+PZd**2)
5636                  P2piBETA=-PXd*BETAX-PYd*BETAY-PZd*BETAZ
5637                  TRANSF=GAMMA*(GAMMA*P2piBETA/(GAMMA+1.)+E2piCM)
5638                  pxi2=BETAX*TRANSF-PXd
5639                  pyi2=BETAY*TRANSF-PYd
5640                  pzi2=BETAZ*TRANSF-PZd
5641                  p(1,i1)=pxi2
5642                  p(2,i1)=pyi2
5643                  p(3,i1)=pzi2
5644 c     Remove regular pion to check the equivalence
5645 c     between the perturbative and regular deuteron results:
5646 c                 E(i1)=0.
5647 c
5648                  LB(I1)=lbm
5649                  PX1=P(1,I1)
5650                  PY1=P(2,I1)
5651                  PZ1=P(3,I1)
5652                  EM1=E(I1)
5653                  ID(I1)=2
5654                  ID1=ID(I1)
5655                  E1=SQRT(EM1**2+PX1**2+PY1**2+PZ1**2)
5656                  lb1=lb(i1)
5657 c     For the regular deuteron:
5658                  p(1,i2)=pxi1
5659                  p(2,i2)=pyi1
5660                  p(3,i2)=pzi1
5661                  lb(i2)=lbd
5662                  lb2=lb(i2)
5663                  E(i2)=xmd
5664                  EtI2=E(I2)
5665                  ID(I2)=2
5666 c     For idpert=2: create the perturbative deuterons:
5667                  if(idpert.eq.2.and.idloop.eq.ndloop) then
5668                     do ipertd=1,npertd
5669                        nnn=nnn+1
5670                        PPION(1,NNN,IRUN)=ppd(1,ipertd)
5671                        PPION(2,NNN,IRUN)=ppd(2,ipertd)
5672                        PPION(3,NNN,IRUN)=ppd(3,ipertd)
5673                        EPION(NNN,IRUN)=xmd
5674                        LPION(NNN,IRUN)=lbpd(ipertd)
5675                        RPION(1,NNN,IRUN)=R(1,I1)
5676                        RPION(2,NNN,IRUN)=R(2,I1)
5677                        RPION(3,NNN,IRUN)=R(3,I1)
5678 clin-5/2008 assign the perturbative probability:
5679                        dppion(NNN,IRUN)=1./float(npertd)
5680                     enddo
5681                  endif
5682               endif
5683            enddo
5684            IBLOCK=501
5685            go to 90005
5686 clin-5/2008 N+N->Deuteron+pi over
5687 * FOR THE NN-->KAON+X PROCESS, FIND MOMENTUM OF THE FINAL PARTICLES IN
5688 * THE NUCLEUS-NUCLEUS CMS.
5689 306     CONTINUE
5690 csp11/21/01 phi production
5691               if(XSK5/sigK.gt.RANART(NSEED))then
5692               pz1=p(3,i1)
5693               pz2=p(3,i2)
5694                 LB(I1) = 1 + int(2 * RANART(NSEED))
5695                 LB(I2) = 1 + int(2 * RANART(NSEED))
5696               nnn=nnn+1
5697                 LPION(NNN,IRUN)=29
5698                 EPION(NNN,IRUN)=APHI
5699                 iblock = 222
5700               GO TO 208
5701                ENDIF
5702 c
5703                  IBLOCK=9
5704                  if(ianti .eq. 1)iblock=-9
5705 c
5706               pz1=p(3,i1)
5707               pz2=p(3,i2)
5708 * DETERMINE THE CHARGE STATES OF PARTICLES IN THE FINAL STATE
5709               nnn=nnn+1
5710                 LPION(NNN,IRUN)=23
5711                 EPION(NNN,IRUN)=Aka
5712               if(srt.le.2.63)then
5713 * only lambda production is possible
5714 * (1.1)P+P-->p+L+kaon+
5715               ic=1
5716                 LB(I1) = 1 + int(2 * RANART(NSEED))
5717               LB(I2)=14
5718               GO TO 208
5719                 ENDIF
5720        if(srt.le.2.74.and.srt.gt.2.63)then
5721 * both Lambda and sigma production are possible
5722               if(XSK1/(XSK1+XSK2).gt.RANART(NSEED))then
5723 * lambda production
5724               ic=1
5725                 LB(I1) = 1 + int(2 * RANART(NSEED))
5726               LB(I2)=14
5727               else
5728 * sigma production
5729                 LB(I1) = 1 + int(2 * RANART(NSEED))
5730                 LB(I2) = 15 + int(3 * RANART(NSEED))
5731               ic=2
5732               endif
5733               GO TO 208
5734        endif
5735        if(srt.le.2.77.and.srt.gt.2.74)then
5736 * then pp-->Delta lamda kaon can happen
5737               if(xsk1/(xsk1+xsk2+xsk3).
5738      1          gt.RANART(NSEED))then
5739 * * (1.1)P+P-->p+L+kaon+
5740               ic=1
5741                 LB(I1) = 1 + int(2 * RANART(NSEED))
5742               LB(I2)=14
5743               go to 208
5744               else
5745               if(xsk2/(xsk2+xsk3).gt.RANART(NSEED))then
5746 * pp-->psk
5747               ic=2
5748                 LB(I1) = 1 + int(2 * RANART(NSEED))
5749                 LB(I2) = 15 + int(3 * RANART(NSEED))
5750               else
5751 * pp-->D+l+k
5752               ic=3
5753                 LB(I1) = 6 + int(4 * RANART(NSEED))
5754               lb(i2)=14
5755               endif
5756               GO TO 208
5757               endif
5758        endif
5759        if(srt.gt.2.77)then
5760 * all four channels are possible
5761               if(xsk1/(xsk1+xsk2+xsk3+xsk4).gt.RANART(NSEED))then
5762 * p lambda k production
5763               ic=1
5764                 LB(I1) = 1 + int(2 * RANART(NSEED))
5765               LB(I2)=14
5766               go to 208
5767        else
5768           if(xsk3/(xsk2+xsk3+xsk4).gt.RANART(NSEED))then
5769 * delta l K production
5770               ic=3
5771                 LB(I1) = 6 + int(4 * RANART(NSEED))
5772               lb(i2)=14
5773               go to 208
5774           else
5775               if(xsk2/(xsk2+xsk4).gt.RANART(NSEED))then
5776 * n sigma k production
5777                    LB(I1) = 1 + int(2 * RANART(NSEED))
5778                    LB(I2) = 15 + int(3 * RANART(NSEED))
5779               ic=2
5780               else
5781               ic=4
5782                 LB(I1) = 6 + int(4 * RANART(NSEED))
5783                 LB(I2) = 15 + int(3 * RANART(NSEED))
5784               endif
5785               go to 208
5786           endif
5787        endif
5788        endif
5789 208             continue
5790          if(ianti.eq.1 .and. lb(i1).ge.1 .and. lb(i2).ge.1)then
5791           lb(i1) = - lb(i1)
5792           lb(i2) = - lb(i2)
5793           if(LPION(NNN,IRUN) .eq. 23)LPION(NNN,IRUN)=21
5794          endif
5795 * KEEP ALL COORDINATES OF PARTICLE 2 FOR POSSIBLE PHASE SPACE CHANGE
5796            NTRY1=0
5797 127        CALL BBKAON(ic,SRT,PX3,PY3,PZ3,DM3,PX4,PY4,PZ4,DM4,
5798      &  PPX,PPY,PPZ,icou1)
5799        NTRY1=NTRY1+1
5800        if((icou1.lt.0).AND.(NTRY1.LE.20))GO TO 127
5801 c       if(icou1.lt.0)return
5802 * ROTATE THE MOMENTA OF PARTICLES IN THE CMS OF P1+P2
5803        CALL ROTATE(PX,PY,PZ,PX3,PY3,PZ3)
5804        CALL ROTATE(PX,PY,PZ,PX4,PY4,PZ4)
5805        CALL ROTATE(PX,PY,PZ,PPX,PPY,PPZ)
5806 * FIND THE MOMENTUM OF PARTICLES IN THE FINAL STATE IN THE NUCLEUS-
5807 * NUCLEUS CMS. FRAME
5808 * (1) for the necleon/delta
5809 *             LORENTZ-TRANSFORMATION INTO LAB FRAME FOR DELTA1
5810               E1CM    = SQRT (dm3**2 + PX3**2 + PY3**2 + PZ3**2)
5811               P1BETA  = PX3*BETAX + PY3*BETAY + PZ3*BETAZ
5812               TRANSF  = GAMMA * ( GAMMA * P1BETA / (GAMMA + 1) + E1CM )
5813               Pt1i1 = BETAX * TRANSF + PX3
5814               Pt2i1 = BETAY * TRANSF + PY3
5815               Pt3i1 = BETAZ * TRANSF + PZ3
5816              Eti1   = DM3
5817              lbi1=lb(i1)
5818 * (2) for the lambda/sigma
5819                 E2CM    = SQRT (dm4**2 + PX4**2 + PY4**2 + PZ4**2)
5820                 P2BETA  = PX4*BETAX+PY4*BETAY+PZ4*BETAZ
5821                 TRANSF  = GAMMA * (GAMMA*P2BETA / (GAMMA + 1.) + E2CM)
5822                 Pt1I2 = BETAX * TRANSF + PX4
5823                 Pt2I2 = BETAY * TRANSF + PY4
5824                 Pt3I2 = BETAZ * TRANSF + PZ4
5825               EtI2   = DM4
5826               lbi2=lb(i2)
5827 * GET the kaon'S MOMENTUM AND COORDINATES IN NUCLEUS-NUCLEUS CMS. FRAME
5828                 EPCM=SQRT(aka**2+PPX**2+PPY**2+PPZ**2)
5829                 PPBETA=PPX*BETAX+PPY*BETAY+PPZ*BETAZ
5830                 TRANSF=GAMMA*(GAMMA*PPBETA/(GAMMA+1.)+EPCM)
5831                 PPION(1,NNN,IRUN)=BETAX*TRANSF+PPX
5832                 PPION(2,NNN,IRUN)=BETAY*TRANSF+PPY
5833                 PPION(3,NNN,IRUN)=BETAZ*TRANSF+PPZ
5834 clin-5/2008
5835                 dppion(nnn,irun)=dpertp(i1)*dpertp(i2)
5836 clin-5/2008
5837 c2003        X01 = 1.0 - 2.0 * RANART(NSEED)
5838 c            Y01 = 1.0 - 2.0 * RANART(NSEED)
5839 c            Z01 = 1.0 - 2.0 * RANART(NSEED)
5840 c        IF ((X01*X01+Y01*Y01+Z01*Z01) .GT. 1.0) GOTO 2003
5841 c                RPION(1,NNN,IRUN)=R(1,I1)+0.5*x01
5842 c                RPION(2,NNN,IRUN)=R(2,I1)+0.5*y01
5843 c                RPION(3,NNN,IRUN)=R(3,I1)+0.5*z01
5844                 RPION(1,NNN,IRUN)=R(1,I1)
5845                 RPION(2,NNN,IRUN)=R(2,I1)
5846                 RPION(3,NNN,IRUN)=R(3,I1)
5847 c
5848 * assign the nucleon/delta and lambda/sigma to i1 or i2 to keep the
5849 * leadng particle behaviour
5850 C              if((pt1i1*px1+pt2i1*py1+pt3i1*pz1).gt.0)then
5851               p(1,i1)=pt1i1
5852               p(2,i1)=pt2i1
5853               p(3,i1)=pt3i1
5854               e(i1)=eti1
5855               lb(i1)=lbi1
5856               p(1,i2)=pt1i2
5857               p(2,i2)=pt2i2
5858               p(3,i2)=pt3i2
5859               e(i2)=eti2
5860               lb(i2)=lbi2
5861                 PX1     = P(1,I1)
5862                 PY1     = P(2,I1)
5863                 PZ1     = P(3,I1)
5864               EM1       = E(I1)
5865                 ID(I1)  = 2
5866                 ID(I2)  = 2
5867                 ID1     = ID(I1)
5868               go to 90005
5869 * FOR THE NN-->Delta+Delta+rho PROCESS, FIND MOMENTUM OF THE FINAL
5870 * PARTICLES IN THE NUCLEUS-NUCLEUS CMS.
5871 307     CONTINUE
5872            NTRY1=0
5873 125        CALL DDrho(SRT,ISEED,PX3,PY3,PZ3,DM3,PX4,PY4,PZ4,DM4,
5874      &  PPX,PPY,PPZ,amrho,icou1)
5875        NTRY1=NTRY1+1
5876        if((icou1.lt.0).AND.(NTRY1.LE.20))GO TO 125
5877 C       if(icou1.lt.0)return
5878 * ROTATE THE MOMENTA OF PARTICLES IN THE CMS OF P1+P2
5879        CALL ROTATE(PX,PY,PZ,PX3,PY3,PZ3)
5880        CALL ROTATE(PX,PY,PZ,PX4,PY4,PZ4)
5881        CALL ROTATE(PX,PY,PZ,PPX,PPY,PPZ)
5882                 NNN=NNN+1
5883               arho=amrho
5884 * DETERMINE THE CHARGE STATES OF PARTICLES IN THE FINAL STATE
5885 * (1) FOR P+P
5886               XDIR=RANART(NSEED)
5887                 IF(LB(I1)*LB(I2).EQ.1)THEN
5888                 IF(XDIR.Le.0.2)then
5889 * (1.1)P+P-->D+++D0+rho(0)
5890                 LPION(NNN,IRUN)=26
5891                 EPION(NNN,IRUN)=Arho
5892               LB(I1)=9
5893               LB(I2)=7
5894        GO TO 2051
5895                 ENDIF
5896 * (1.2)P+P -->D++D+rho(0)
5897                 IF((XDIR.LE.0.4).AND.(XDIR.GT.0.2))THEN
5898                 LPION(NNN,IRUN)=26
5899                 EPION(NNN,IRUN)=Arho
5900                 LB(I1)=8
5901                 LB(I2)=8
5902        GO TO 2051
5903               ENDIF
5904 * (1.3)P+P-->D+++D+arho(-)
5905                 IF((XDIR.LE.0.6).AND.(XDIR.GT.0.4))THEN
5906                 LPION(NNN,IRUN)=25
5907                 EPION(NNN,IRUN)=Arho
5908                 LB(I1)=9
5909                 LB(I2)=8
5910        GO TO 2051
5911               ENDIF
5912                 IF((XDIR.LE.0.8).AND.(XDIR.GT.0.6))THEN
5913                 LPION(NNN,IRUN)=27
5914                 EPION(NNN,IRUN)=Arho
5915                 LB(I1)=9
5916                 LB(I2)=6
5917        GO TO 2051
5918               ENDIF
5919                 IF(XDIR.GT.0.8)THEN
5920                 LPION(NNN,IRUN)=27
5921                 EPION(NNN,IRUN)=Arho
5922                 LB(I1)=7
5923                 LB(I2)=8
5924        GO TO 2051
5925               ENDIF
5926                ENDIF
5927 * (2)FOR N+N
5928                 IF(iabs(LB(I1)).EQ.2.AND.iabs(LB(I2)).EQ.2)THEN
5929                 IF(XDIR.Le.0.2)then
5930 * (2.1)N+N-->D++D-+rho(0)
5931                 LPION(NNN,IRUN)=26
5932                 EPION(NNN,IRUN)=Arho
5933               LB(I1)=6
5934               LB(I2)=7
5935        GO TO 2051
5936                 ENDIF
5937 * (2.2)N+N -->D+++D-+rho(-)
5938                 IF((XDIR.LE.0.4).AND.(XDIR.GT.0.2))THEN
5939                 LPION(NNN,IRUN)=25
5940                 EPION(NNN,IRUN)=Arho
5941                 LB(I1)=6
5942                 LB(I2)=9
5943        GO TO 2051
5944               ENDIF
5945 * (2.3)P+P-->D0+D-+rho(+)
5946                 IF((XDIR.GT.0.4).AND.(XDIR.LE.0.6))THEN
5947                 LPION(NNN,IRUN)=27
5948                 EPION(NNN,IRUN)=Arho
5949                 LB(I1)=9
5950                 LB(I2)=8
5951        GO TO 2051
5952               ENDIF
5953 * (2.4)P+P-->D0+D0+rho(0)
5954                 IF((XDIR.GT.0.6).AND.(XDIR.LE.0.8))THEN
5955                 LPION(NNN,IRUN)=26
5956                 EPION(NNN,IRUN)=Arho
5957                 LB(I1)=7
5958                 LB(I2)=7
5959        GO TO 2051
5960               ENDIF
5961 * (2.5)P+P-->D0+D++rho(-)
5962                 IF(XDIR.GT.0.8)THEN
5963                 LPION(NNN,IRUN)=25
5964                 EPION(NNN,IRUN)=Arho
5965                 LB(I1)=7
5966                 LB(I2)=8
5967        GO TO 2051
5968               ENDIF
5969               ENDIF
5970 * (3)FOR N+P
5971                 IF(LB(I1)*LB(I2).EQ.2)THEN
5972                 IF(XDIR.Le.0.17)then
5973 * (3.1)N+P-->D+++D-+rho(0)
5974                 LPION(NNN,IRUN)=25
5975                 EPION(NNN,IRUN)=Arho
5976               LB(I1)=6
5977               LB(I2)=9
5978        GO TO 2051
5979                 ENDIF
5980 * (3.2)N+P -->D+++D0+rho(-)
5981                 IF((XDIR.LE.0.34).AND.(XDIR.GT.0.17))THEN
5982                 LPION(NNN,IRUN)=25
5983                 EPION(NNN,IRUN)=Arho
5984                 LB(I1)=7
5985                 LB(I2)=9
5986        GO TO 2051
5987               ENDIF
5988 * (3.3)N+P-->D++D-+rho(+)
5989                 IF((XDIR.GT.0.34).AND.(XDIR.LE.0.51))THEN
5990                 LPION(NNN,IRUN)=27
5991                 EPION(NNN,IRUN)=Arho
5992                 LB(I1)=7
5993                 LB(I2)=8
5994        GO TO 2051
5995               ENDIF
5996 * (3.4)N+P-->D++D++rho(-)
5997                 IF((XDIR.GT.0.51).AND.(XDIR.LE.0.68))THEN
5998                 LPION(NNN,IRUN)=25
5999                 EPION(NNN,IRUN)=Arho
6000                 LB(I1)=8
6001                 LB(I2)=8
6002        GO TO 2051
6003               ENDIF
6004 * (3.5)N+P-->D0+D++rho(0)
6005                 IF((XDIR.GT.0.68).AND.(XDIR.LE.0.85))THEN
6006                 LPION(NNN,IRUN)=26
6007                 EPION(NNN,IRUN)=Arho
6008                 LB(I1)=7
6009                 LB(I2)=8
6010        GO TO 2051
6011               ENDIF
6012 * (3.6)N+P-->D0+D0+rho(+)
6013                 IF(XDIR.GT.0.85)THEN
6014                 LPION(NNN,IRUN)=27
6015                 EPION(NNN,IRUN)=Arho
6016                 LB(I1)=7
6017                 LB(I2)=7
6018               ENDIF
6019                 ENDIF
6020 * FIND THE MOMENTUM OF PARTICLES IN THE FINAL STATE IN THE NUCLEUS-
6021 * NUCLEUS CMS. FRAME
6022 *             LORENTZ-TRANSFORMATION INTO LAB FRAME FOR DELTA1
6023 2051          E1CM    = SQRT (dm3**2 + PX3**2 + PY3**2 + PZ3**2)
6024               P1BETA  = PX3*BETAX + PY3*BETAY + PZ3*BETAZ
6025               TRANSF  = GAMMA * ( GAMMA * P1BETA / (GAMMA + 1) + E1CM )
6026               Pt1i1 = BETAX * TRANSF + PX3
6027               Pt2i1 = BETAY * TRANSF + PY3
6028               Pt3i1 = BETAZ * TRANSF + PZ3
6029              Eti1   = DM3
6030 c
6031              if(ianti.eq.1 .and. lb(i1).ge.1 .and. lb(i2).ge.1)then
6032                lb(i1) = -lb(i1)
6033                lb(i2) = -lb(i2)
6034                 if(LPION(NNN,IRUN) .eq. 25)then
6035                   LPION(NNN,IRUN)=27
6036                 elseif(LPION(NNN,IRUN) .eq. 27)then
6037                   LPION(NNN,IRUN)=25
6038                 endif
6039                endif
6040 c
6041              lb1=lb(i1)
6042 * FOR DELTA2
6043                 E2CM    = SQRT (dm4**2 + PX4**2 + PY4**2 + PZ4**2)
6044                 P2BETA  = PX4*BETAX+PY4*BETAY+PZ4*BETAZ
6045                 TRANSF  = GAMMA * (GAMMA*P2BETA / (GAMMA + 1.) + E2CM)
6046                 Pt1I2 = BETAX * TRANSF + PX4
6047                 Pt2I2 = BETAY * TRANSF + PY4
6048                 Pt3I2 = BETAZ * TRANSF + PZ4
6049               EtI2   = DM4
6050               lb2=lb(i2)
6051 * assign delta1 and delta2 to i1 or i2 to keep the leadng particle
6052 * behaviour
6053 C              if((pt1i1*px1+pt2i1*py1+pt3i1*pz1).gt.0)then
6054               p(1,i1)=pt1i1
6055               p(2,i1)=pt2i1
6056               p(3,i1)=pt3i1
6057               e(i1)=eti1
6058               lb(i1)=lb1
6059               p(1,i2)=pt1i2
6060               p(2,i2)=pt2i2
6061               p(3,i2)=pt3i2
6062               e(i2)=eti2
6063               lb(i2)=lb2
6064                 PX1     = P(1,I1)
6065                 PY1     = P(2,I1)
6066                 PZ1     = P(3,I1)
6067               EM1       = E(I1)
6068                 ID(I1)  = 2
6069                 ID(I2)  = 2
6070                 ID1     = ID(I1)
6071                 IBLOCK=44
6072 * GET rho'S MOMENTUM AND COORDINATES IN NUCLEUS-NUCLEUS CMS. FRAME
6073                 EPCM=SQRT(EPION(NNN,IRUN)**2+PPX**2+PPY**2+PPZ**2)
6074                 PPBETA=PPX*BETAX+PPY*BETAY+PPZ*BETAZ
6075                 TRANSF=GAMMA*(GAMMA*PPBETA/(GAMMA+1.)+EPCM)
6076                 PPION(1,NNN,IRUN)=BETAX*TRANSF+PPX
6077                 PPION(2,NNN,IRUN)=BETAY*TRANSF+PPY
6078                 PPION(3,NNN,IRUN)=BETAZ*TRANSF+PPZ
6079 clin-5/2008:
6080                 dppion(nnn,irun)=dpertp(i1)*dpertp(i2)
6081 clin-5/2008:
6082 c2004        X01 = 1.0 - 2.0 * RANART(NSEED)
6083 c            Y01 = 1.0 - 2.0 * RANART(NSEED)
6084 c            Z01 = 1.0 - 2.0 * RANART(NSEED)
6085 c        IF ((X01*X01+Y01*Y01+Z01*Z01) .GT. 1.0) GOTO 2004
6086 c                RPION(1,NNN,IRUN)=R(1,I1)+0.5*x01
6087 c                RPION(2,NNN,IRUN)=R(2,I1)+0.5*y01
6088 c                RPION(3,NNN,IRUN)=R(3,I1)+0.5*z01
6089                 RPION(1,NNN,IRUN)=R(1,I1)
6090                 RPION(2,NNN,IRUN)=R(2,I1)
6091                 RPION(3,NNN,IRUN)=R(3,I1)
6092 c
6093               go to 90005
6094 * FOR THE NN-->N+N+rho PROCESS, FIND MOMENTUM OF THE FINAL
6095 * PARTICLES IN THE NUCLEUS-NUCLEUS CMS.
6096 308     CONTINUE
6097            NTRY1=0
6098 126        CALL pprho(SRT,ISEED,PX3,PY3,PZ3,DM3,PX4,PY4,PZ4,DM4,
6099      &  PPX,PPY,PPZ,amrho,icou1)
6100        NTRY1=NTRY1+1
6101        if((icou1.lt.0).AND.(NTRY1.LE.20))GO TO 126
6102 C       if(icou1.lt.0)return
6103 * ROTATE THE MOMENTA OF PARTICLES IN THE CMS OF P1+P2
6104        CALL ROTATE(PX,PY,PZ,PX3,PY3,PZ3)
6105        CALL ROTATE(PX,PY,PZ,PX4,PY4,PZ4)
6106        CALL ROTATE(PX,PY,PZ,PPX,PPY,PPZ)
6107                 NNN=NNN+1
6108               arho=amrho
6109 * DETERMINE THE CHARGE STATES OF PARTICLES IN THE FINAL STATE
6110 * (1) FOR P+P
6111               XDIR=RANART(NSEED)
6112                 IF(LB(I1)*LB(I2).EQ.1)THEN
6113                 IF(XDIR.Le.0.5)then
6114 * (1.1)P+P-->P+P+rho(0)
6115                 LPION(NNN,IRUN)=26
6116                 EPION(NNN,IRUN)=Arho
6117               LB(I1)=1
6118               LB(I2)=1
6119        GO TO 2052
6120                 Else
6121 * (1.2)P+P -->p+n+rho(+)
6122                 LPION(NNN,IRUN)=27
6123                 EPION(NNN,IRUN)=Arho
6124                 LB(I1)=1
6125                 LB(I2)=2
6126        GO TO 2052
6127               ENDIF
6128               endif
6129 * (2)FOR N+N
6130                 IF(iabs(LB(I1)).EQ.2.AND.iabs(LB(I2)).EQ.2)THEN
6131                 IF(XDIR.Le.0.5)then
6132 * (2.1)N+N-->N+N+rho(0)
6133                 LPION(NNN,IRUN)=26
6134                 EPION(NNN,IRUN)=Arho
6135               LB(I1)=2
6136               LB(I2)=2
6137        GO TO 2052
6138                 Else
6139 * (2.2)N+N -->N+P+rho(-)
6140                 LPION(NNN,IRUN)=25
6141                 EPION(NNN,IRUN)=Arho
6142                 LB(I1)=1
6143                 LB(I2)=2
6144        GO TO 2052
6145               ENDIF
6146               endif
6147 * (3)FOR N+P
6148                 IF(LB(I1)*LB(I2).EQ.2)THEN
6149                 IF(XDIR.Le.0.33)then
6150 * (3.1)N+P-->N+P+rho(0)
6151                 LPION(NNN,IRUN)=26
6152                 EPION(NNN,IRUN)=Arho
6153               LB(I1)=1
6154               LB(I2)=2
6155        GO TO 2052
6156 * (3.2)N+P -->P+P+rho(-)
6157                 else IF((XDIR.LE.0.67).AND.(XDIR.GT.0.34))THEN
6158                 LPION(NNN,IRUN)=25
6159                 EPION(NNN,IRUN)=Arho
6160                 LB(I1)=1
6161                 LB(I2)=1
6162        GO TO 2052
6163               Else
6164 * (3.3)N+P-->N+N+rho(+)
6165                 LPION(NNN,IRUN)=27
6166                 EPION(NNN,IRUN)=Arho
6167                 LB(I1)=2
6168                 LB(I2)=2
6169        GO TO 2052
6170               ENDIF
6171               endif
6172 * FIND THE MOMENTUM OF PARTICLES IN THE FINAL STATE IN THE NUCLEUS-
6173 * NUCLEUS CMS. FRAME
6174 *             LORENTZ-TRANSFORMATION INTO LAB FRAME FOR DELTA1
6175 2052          E1CM    = SQRT (dm3**2 + PX3**2 + PY3**2 + PZ3**2)
6176               P1BETA  = PX3*BETAX + PY3*BETAY + PZ3*BETAZ
6177               TRANSF  = GAMMA * ( GAMMA * P1BETA / (GAMMA + 1) + E1CM )
6178               Pt1i1 = BETAX * TRANSF + PX3
6179               Pt2i1 = BETAY * TRANSF + PY3
6180               Pt3i1 = BETAZ * TRANSF + PZ3
6181              Eti1   = DM3
6182 c
6183               if(ianti.eq.1 .and. lb(i1).ge.1 .and. lb(i2).ge.1)then
6184                lb(i1) = -lb(i1)
6185                lb(i2) = -lb(i2)
6186                 if(LPION(NNN,IRUN) .eq. 25)then
6187                   LPION(NNN,IRUN)=27
6188                 elseif(LPION(NNN,IRUN) .eq. 27)then
6189                   LPION(NNN,IRUN)=25
6190                 endif
6191                endif
6192 c
6193              lb1=lb(i1)
6194 * FOR p2
6195                 E2CM    = SQRT (dm4**2 + PX4**2 + PY4**2 + PZ4**2)
6196                 P2BETA  = PX4*BETAX+PY4*BETAY+PZ4*BETAZ
6197                 TRANSF  = GAMMA * (GAMMA*P2BETA / (GAMMA + 1.) + E2CM)
6198                 Pt1I2 = BETAX * TRANSF + PX4
6199                 Pt2I2 = BETAY * TRANSF + PY4
6200                 Pt3I2 = BETAZ * TRANSF + PZ4
6201               EtI2   = DM4
6202               lb2=lb(i2)
6203 * assign p1 and p2 to i1 or i2 to keep the leadng particle
6204 * behaviour
6205 C              if((pt1i1*px1+pt2i1*py1+pt3i1*pz1).gt.0)then
6206               p(1,i1)=pt1i1
6207               p(2,i1)=pt2i1
6208               p(3,i1)=pt3i1
6209               e(i1)=eti1
6210               lb(i1)=lb1
6211               p(1,i2)=pt1i2
6212               p(2,i2)=pt2i2
6213               p(3,i2)=pt3i2
6214               e(i2)=eti2
6215               lb(i2)=lb2
6216                 PX1     = P(1,I1)
6217                 PY1     = P(2,I1)
6218                 PZ1     = P(3,I1)
6219               EM1       = E(I1)
6220                 ID(I1)  = 2
6221                 ID(I2)  = 2
6222                 ID1     = ID(I1)
6223                 IBLOCK=45
6224 * GET rho'S MOMENTUM AND COORDINATES IN NUCLEUS-NUCLEUS CMS. FRAME
6225                 EPCM=SQRT(EPION(NNN,IRUN)**2+PPX**2+PPY**2+PPZ**2)
6226                 PPBETA=PPX*BETAX+PPY*BETAY+PPZ*BETAZ
6227                 TRANSF=GAMMA*(GAMMA*PPBETA/(GAMMA+1.)+EPCM)
6228                 PPION(1,NNN,IRUN)=BETAX*TRANSF+PPX
6229                 PPION(2,NNN,IRUN)=BETAY*TRANSF+PPY
6230                 PPION(3,NNN,IRUN)=BETAZ*TRANSF+PPZ
6231 clin-5/2008:
6232                 dppion(nnn,irun)=dpertp(i1)*dpertp(i2)
6233 clin-5/2008:
6234 c2005        X01 = 1.0 - 2.0 * RANART(NSEED)
6235 c            Y01 = 1.0 - 2.0 * RANART(NSEED)
6236 c            Z01 = 1.0 - 2.0 * RANART(NSEED)
6237 c        IF ((X01*X01+Y01*Y01+Z01*Z01) .GT. 1.0) GOTO 2005
6238 c                RPION(1,NNN,IRUN)=R(1,I1)+0.5*x01
6239 c                RPION(2,NNN,IRUN)=R(2,I1)+0.5*y01
6240 c                RPION(3,NNN,IRUN)=R(3,I1)+0.5*z01
6241                 RPION(1,NNN,IRUN)=R(1,I1)
6242                 RPION(2,NNN,IRUN)=R(2,I1)
6243                 RPION(3,NNN,IRUN)=R(3,I1)
6244 c
6245               go to 90005
6246 * FOR THE NN-->p+p+omega PROCESS, FIND MOMENTUM OF THE FINAL
6247 * PARTICLES IN THE NUCLEUS-NUCLEUS CMS.
6248 309     CONTINUE
6249            NTRY1=0
6250 138        CALL ppomga(SRT,ISEED,PX3,PY3,PZ3,DM3,PX4,PY4,PZ4,DM4,
6251      &  PPX,PPY,PPZ,icou1)
6252        NTRY1=NTRY1+1
6253        if((icou1.lt.0).AND.(NTRY1.LE.20))GO TO 138
6254 C       if(icou1.lt.0)return
6255 * ROTATE THE MOMENTA OF PARTICLES IN THE CMS OF P1+P2
6256        CALL ROTATE(PX,PY,PZ,PX3,PY3,PZ3)
6257        CALL ROTATE(PX,PY,PZ,PX4,PY4,PZ4)
6258        CALL ROTATE(PX,PY,PZ,PPX,PPY,PPZ)
6259                 NNN=NNN+1
6260               aomega=0.782
6261 * DETERMINE THE CHARGE STATES OF PARTICLES IN THE FINAL STATE
6262 * (1) FOR P+P
6263                 IF(LB(I1)*LB(I2).EQ.1)THEN
6264 * (1.1)P+P-->P+P+omega(0)
6265                 LPION(NNN,IRUN)=28
6266                 EPION(NNN,IRUN)=Aomega
6267               LB(I1)=1
6268               LB(I2)=1
6269        GO TO 2053
6270                 ENDIF
6271 * (2)FOR N+N
6272                 IF(iabs(LB(I1)).EQ.2.AND.iabs(LB(I2)).EQ.2)THEN
6273 * (2.1)N+N-->N+N+omega(0)
6274                 LPION(NNN,IRUN)=28
6275                 EPION(NNN,IRUN)=Aomega
6276               LB(I1)=2
6277               LB(I2)=2
6278        GO TO 2053
6279                 ENDIF
6280 * (3)FOR N+P
6281                 IF(LB(I1)*LB(I2).EQ.2)THEN
6282 * (3.1)N+P-->N+P+omega(0)
6283                 LPION(NNN,IRUN)=28
6284                 EPION(NNN,IRUN)=Aomega
6285               LB(I1)=1
6286               LB(I2)=2
6287        GO TO 2053
6288                 ENDIF
6289 * FIND THE MOMENTUM OF PARTICLES IN THE FINAL STATE IN THE NUCLEUS-
6290 * NUCLEUS CMS. FRAME
6291 *             LORENTZ-TRANSFORMATION INTO LAB FRAME FOR DELTA1
6292 2053          E1CM    = SQRT (dm3**2 + PX3**2 + PY3**2 + PZ3**2)
6293               P1BETA  = PX3*BETAX + PY3*BETAY + PZ3*BETAZ
6294               TRANSF  = GAMMA * ( GAMMA * P1BETA / (GAMMA + 1) + E1CM )
6295               Pt1i1 = BETAX * TRANSF + PX3
6296               Pt2i1 = BETAY * TRANSF + PY3
6297               Pt3i1 = BETAZ * TRANSF + PZ3
6298              Eti1   = DM3
6299               if(ianti.eq.1 .and. lb(i1).ge.1 .and. lb(i2).ge.1)then
6300                lb(i1) = -lb(i1)
6301                lb(i2) = -lb(i2)
6302                endif
6303              lb1=lb(i1)
6304 * FOR DELTA2
6305                 E2CM    = SQRT (dm4**2 + PX4**2 + PY4**2 + PZ4**2)
6306                 P2BETA  = PX4*BETAX+PY4*BETAY+PZ4*BETAZ
6307                 TRANSF  = GAMMA * (GAMMA*P2BETA / (GAMMA + 1.) + E2CM)
6308                 Pt1I2 = BETAX * TRANSF + PX4
6309                 Pt2I2 = BETAY * TRANSF + PY4
6310                 Pt3I2 = BETAZ * TRANSF + PZ4
6311               EtI2   = DM4
6312                 lb2=lb(i2)
6313 * assign delta1 and delta2 to i1 or i2 to keep the leadng particle
6314 * behaviour
6315 C              if((pt1i1*px1+pt2i1*py1+pt3i1*pz1).gt.0)then
6316               p(1,i1)=pt1i1
6317               p(2,i1)=pt2i1
6318               p(3,i1)=pt3i1
6319               e(i1)=eti1
6320               lb(i1)=lb1
6321               p(1,i2)=pt1i2
6322               p(2,i2)=pt2i2
6323               p(3,i2)=pt3i2
6324               e(i2)=eti2
6325               lb(i2)=lb2
6326                 PX1     = P(1,I1)
6327                 PY1     = P(2,I1)
6328                 PZ1     = P(3,I1)
6329               EM1       = E(I1)
6330                 ID(I1)  = 2
6331                 ID(I2)  = 2
6332                 ID1     = ID(I1)
6333                 IBLOCK=46
6334 * GET omega'S MOMENTUM AND COORDINATES IN NUCLEUS-NUCLEUS CMS. FRAME
6335                 EPCM=SQRT(EPION(NNN,IRUN)**2+PPX**2+PPY**2+PPZ**2)
6336                 PPBETA=PPX*BETAX+PPY*BETAY+PPZ*BETAZ
6337                 TRANSF=GAMMA*(GAMMA*PPBETA/(GAMMA+1.)+EPCM)
6338                 PPION(1,NNN,IRUN)=BETAX*TRANSF+PPX
6339                 PPION(2,NNN,IRUN)=BETAY*TRANSF+PPY
6340                 PPION(3,NNN,IRUN)=BETAZ*TRANSF+PPZ
6341 clin-5/2008:
6342                 dppion(nnn,irun)=dpertp(i1)*dpertp(i2)
6343 clin-5/2008:
6344 c2006        X01 = 1.0 - 2.0 * RANART(NSEED)
6345 c            Y01 = 1.0 - 2.0 * RANART(NSEED)
6346 c            Z01 = 1.0 - 2.0 * RANART(NSEED)
6347 c        IF ((X01*X01+Y01*Y01+Z01*Z01) .GT. 1.0) GOTO 2006
6348 c                RPION(1,NNN,IRUN)=R(1,I1)+0.5*x01
6349 c                RPION(2,NNN,IRUN)=R(2,I1)+0.5*y01
6350 c                RPION(3,NNN,IRUN)=R(3,I1)+0.5*z01
6351                     RPION(1,NNN,IRUN)=R(1,I1)
6352                     RPION(2,NNN,IRUN)=R(2,I1)
6353                     RPION(3,NNN,IRUN)=R(3,I1)
6354 c
6355               go to 90005
6356 * change phase space density FOR NUCLEONS AFTER THE PROCESS
6357
6358 clin-10/25/02-comment out following, since there is no path to it:
6359 clin-8/16/02 used before set
6360 c     IX1,IY1,IZ1,IPX1,IPY1,IPZ1, IX2,IY2,IZ2,IPX2,IPY2,IPZ2:
6361 c                if ((abs(ix1).le.mx) .and. (abs(iy1).le.my) .and.
6362 c     &              (abs(iz1).le.mz)) then
6363 c                  ipx1p = nint(p(1,i1)/dpx)
6364 c                  ipy1p = nint(p(2,i1)/dpy)
6365 c                  ipz1p = nint(p(3,i1)/dpz)
6366 c                  if ((ipx1p.ne.ipx1) .or. (ipy1p.ne.ipy1) .or.
6367 c     &                (ipz1p.ne.ipz1)) then
6368 c                    if ((abs(ipx1).le.mpx) .and. (abs(ipy1).le.my)
6369 c     &                .and. (ipz1.ge.-mpz) .and. (ipz1.le.mpzp))
6370 c     &                f(ix1,iy1,iz1,ipx1,ipy1,ipz1) =
6371 c     &                f(ix1,iy1,iz1,ipx1,ipy1,ipz1) - 1.
6372 c                    if ((abs(ipx1p).le.mpx) .and. (abs(ipy1p).le.my)
6373 c     &                .and. (ipz1p.ge.-mpz).and. (ipz1p.le.mpzp))
6374 c     &                f(ix1,iy1,iz1,ipx1p,ipy1p,ipz1p) =
6375 c     &                f(ix1,iy1,iz1,ipx1p,ipy1p,ipz1p) + 1.
6376 c                  end if
6377 c                end if
6378 c                if ((abs(ix2).le.mx) .and. (abs(iy2).le.my) .and.
6379 c     &              (abs(iz2).le.mz)) then
6380 c                  ipx2p = nint(p(1,i2)/dpx)
6381 c                  ipy2p = nint(p(2,i2)/dpy)
6382 c                  ipz2p = nint(p(3,i2)/dpz)
6383 c                  if ((ipx2p.ne.ipx2) .or. (ipy2p.ne.ipy2) .or.
6384 c     &                (ipz2p.ne.ipz2)) then
6385 c                    if ((abs(ipx2).le.mpx) .and. (abs(ipy2).le.my)
6386 c     &                .and. (ipz2.ge.-mpz) .and. (ipz2.le.mpzp))
6387 c     &                f(ix2,iy2,iz2,ipx2,ipy2,ipz2) =
6388 c     &                f(ix2,iy2,iz2,ipx2,ipy2,ipz2) - 1.
6389 c                    if ((abs(ipx2p).le.mpx) .and. (abs(ipy2p).le.my)
6390 c     &                .and. (ipz2p.ge.-mpz) .and. (ipz2p.le.mpzp))
6391 c     &                f(ix2,iy2,iz2,ipx2p,ipy2p,ipz2p) =
6392 c     &                f(ix2,iy2,iz2,ipx2p,ipy2p,ipz2p) + 1.
6393 c                  end if
6394 c                end if
6395 clin-10/25/02-end
6396
6397 90005       continue
6398        RETURN
6399 *-----------------------------------------------------------------------
6400 *COM: SET THE NEW MOMENTUM COORDINATES
6401 107     IF(PX .EQ. 0.0 .AND. PY .EQ. 0.0) THEN
6402         T2 = 0.0
6403       ELSE
6404         T2=ATAN2(PY,PX)
6405       END IF
6406       S1   = 1.0 - C1**2
6407        IF(S1.LE.0)S1=0
6408        S1=SQRT(S1)
6409       S2  =  SQRT( 1.0 - C2**2 )
6410       CT1  = COS(T1)
6411       ST1  = SIN(T1)
6412       CT2  = COS(T2)
6413       ST2  = SIN(T2)
6414       PZ   = PR * ( C1*C2 - S1*S2*CT1 )
6415       SS   = C2 * S1 * CT1  +  S2 * C1
6416       PX   = PR * ( SS*CT2 - S1*ST1*ST2 )
6417       PY   = PR * ( SS*ST2 + S1*ST1*CT2 )
6418       RETURN
6419       END
6420 clin-5/2008 CRNN over
6421
6422 **********************************
6423 **********************************
6424 *                                                                      *
6425 *                                                                      *
6426 c
6427       SUBROUTINE CRPP(PX,PY,PZ,SRT,I1,I2,IBLOCK,
6428      &ppel,ppin,spprho,ipp)
6429 *     PURPOSE:                                                         *
6430 *             DEALING WITH PION-PION COLLISIONS                        *
6431 *     NOTE   :                                                         *
6432 *           VALID ONLY FOR PION-PION-DISTANCES LESS THAN 2.5 FM        *
6433 *     QUANTITIES:                                                 *
6434 *           PX,PY,PZ - MOMENTUM COORDINATES OF ONE PARTICLE IN CM FRAME*
6435 *           SRT      - SQRT OF S                                       *
6436 *           IBLOCK   - THE INFORMATION BACK                            *
6437 *                     6-> Meson+Meson elastic
6438 *                     66-> Meson+meson-->K+K-
6439 **********************************
6440       PARAMETER (MAXSTR=150001,MAXR=1,AMN=0.939457,
6441      1     AMP=0.93828,AP1=0.13496,
6442      2 AP2=0.13957,AM0=1.232,PI=3.1415926,CUTOFF=1.8966,AVMASS=0.9383)
6443       PARAMETER      (AKA=0.498,aks=0.895)
6444       parameter     (MX=4,MY=4,MZ=8,MPX=4,MPY=4,mpz=10,mpzp=10)
6445       COMMON /AA/ R(3,MAXSTR)
6446 cc      SAVE /AA/
6447       COMMON /BB/ P(3,MAXSTR)
6448 cc      SAVE /BB/
6449       COMMON /CC/ E(MAXSTR)
6450 cc      SAVE /CC/
6451       COMMON /EE/ ID(MAXSTR),LB(MAXSTR)
6452 cc      SAVE /EE/
6453       common/input1/ MASSPR,MASSTA,ISEED,IAVOID,DT
6454 cc      SAVE /input1/
6455       common/ppb1/ene,factr2(6),fsum,ppinnb,s,wtot
6456 cc      SAVE /ppb1/
6457       common/ppmm/pprr,ppee,pppe,rpre,xopoe,rree
6458 cc      SAVE /ppmm/
6459       COMMON/RNDF77/NSEED
6460 cc      SAVE /RNDF77/
6461       SAVE
6462
6463       lb1i=lb(i1)
6464       lb2i=lb(i2)
6465
6466        PX0=PX
6467        PY0=PY
6468        PZ0=PZ
6469         iblock=1
6470 *-----------------------------------------------------------------------
6471 * check Meson+Meson inelastic collisions
6472 clin-9/28/00
6473 c        if((srt.gt.1.).and.(ppin/(ppin+ppel).gt.RANART(NSEED)))then
6474 c        iblock=66
6475 c        e(i1)=0.498
6476 c        e(i2)=0.498
6477 c        lb(i1)=21
6478 c        lb(i2)=23
6479 c        go to 10
6480 clin-11/07/00
6481 c        if(srt.gt.1.and.(ppin/(ppin+ppel)).gt.RANART(NSEED)) then
6482 clin-4/03/02
6483         if(srt.gt.(2*aka).and.(ppin/(ppin+ppel)).gt.RANART(NSEED)) then
6484 c        if(ppin/(ppin+ppel).gt.RANART(NSEED)) then
6485 clin-10/08/00
6486
6487            ranpi=RANART(NSEED)
6488            if((pprr/ppin).ge.ranpi) then
6489
6490 c     1) pi pi <-> rho rho:
6491               call pi2ro2(i1,i2,lbb1,lbb2,ei1,ei2,iblock,iseed)
6492
6493 clin-4/03/02 eta equilibration:
6494            elseif((pprr+ppee)/ppin.ge.ranpi) then
6495 c     4) pi pi <-> eta eta:
6496               call pi2et2(i1,i2,lbb1,lbb2,ei1,ei2,iblock,iseed)
6497            elseif(((pprr+ppee+pppe)/ppin).ge.ranpi) then
6498 c     5) pi pi <-> pi eta:
6499               call pi3eta(i1,i2,lbb1,lbb2,ei1,ei2,iblock,iseed)
6500            elseif(((pprr+ppee+pppe+rpre)/ppin).ge.ranpi) then
6501 c     6) rho pi <-> pi eta:
6502               call rpiret(i1,i2,lbb1,lbb2,ei1,ei2,iblock,iseed)
6503            elseif(((pprr+ppee+pppe+rpre+xopoe)/ppin).ge.ranpi) then
6504 c     7) omega pi <-> omega eta:
6505               call opioet(i1,i2,lbb1,lbb2,ei1,ei2,iblock,iseed)
6506            elseif(((pprr+ppee+pppe+rpre+xopoe+rree)
6507      1             /ppin).ge.ranpi) then
6508 c     8) rho rho <-> eta eta:
6509               call ro2et2(i1,i2,lbb1,lbb2,ei1,ei2,iblock,iseed)
6510 clin-4/03/02-end
6511
6512 c     2) BBbar production:
6513            elseif(((pprr+ppee+pppe+rpre+xopoe+rree+ppinnb)/ppin)
6514      1             .ge.ranpi) then
6515
6516               call bbarfs(lbb1,lbb2,ei1,ei2,iblock,iseed)
6517 c     3) KKbar production:
6518            else
6519               iblock=66
6520               ei1=aka
6521               ei2=aka
6522               lbb1=21
6523               lbb2=23
6524 clin-11/07/00 pi rho -> K* Kbar and K*bar K productions:
6525               lb1=lb(i1)
6526               lb2=lb(i2)
6527 clin-2/13/03 include omega the same as rho, eta the same as pi:
6528 c        if(((lb1.ge.3.and.lb1.le.5).and.(lb2.ge.25.and.lb2.le.27))
6529 c     1  .or.((lb2.ge.3.and.lb2.le.5).and.(lb1.ge.25.and.lb1.le.27)))
6530         if( ( (lb1.eq.0.or.(lb1.ge.3.and.lb1.le.5))
6531      1       .and.(lb2.ge.25.and.lb2.le.28))
6532      2       .or. ( (lb2.eq.0.or.(lb2.ge.3.and.lb2.le.5))
6533      3       .and.(lb1.ge.25.and.lb1.le.28))) then
6534            ei1=aks
6535            ei2=aka
6536            if(RANART(NSEED).ge.0.5) then
6537               iblock=366
6538               lbb1=30
6539               lbb2=21
6540            else
6541               iblock=367
6542               lbb1=-30
6543               lbb2=23
6544            endif
6545         endif
6546 clin-11/07/00-end
6547            endif
6548 clin-ppbar-8/25/00
6549            e(i1)=ei1
6550            e(i2)=ei2
6551            lb(i1)=lbb1
6552            lb(i2)=lbb2
6553 clin-10/08/00-end
6554
6555        else
6556 cbzdbg10/15/99
6557 c.....for meson+meson elastic srt.le.2Mk, if not pi+pi collision return
6558          if ((lb(i1).lt.3.or.lb(i1).gt.5).and.
6559      &        (lb(i2).lt.3.or.lb(i2).gt.5)) return
6560 cbzdbg10/15/99 end
6561
6562 * check Meson+Meson elastic collisions
6563         IBLOCK=6
6564 * direct process
6565        if(ipp.eq.1.or.ipp.eq.4.or.ipp.eq.6)go to 10
6566        if(spprho/ppel.gt.RANART(NSEED))go to 20
6567        endif
6568 10      NTAG=0
6569         EM1=E(I1)
6570         EM2=E(I2)
6571
6572 *-----------------------------------------------------------------------
6573 * CALCULATE THE MAGNITUDE OF THE FINAL MOMENTUM THROUGH
6574 * ENERGY CONSERVATION
6575           PR2   = (SRT**2 - EM1**2 - EM2**2)**2
6576      1                - 4.0 * (EM1*EM2)**2
6577           IF(PR2.LE.0.)PR2=1.e-09
6578           PR=SQRT(PR2)/(2.*SRT)
6579           C1   = 1.0 - 2.0 * RANART(NSEED)
6580           T1   = 2.0 * PI * RANART(NSEED)
6581       S1   = SQRT( 1.0 - C1**2 )
6582       CT1  = COS(T1)
6583       ST1  = SIN(T1)
6584       PZ   = PR * C1
6585       PX   = PR * S1*CT1
6586       PY   = PR * S1*ST1
6587 * for isotropic distribution no need to ROTATE THE MOMENTUM
6588
6589 * ROTATE IT
6590       CALL ROTATE(PX0,PY0,PZ0,PX,PY,PZ)
6591
6592       RETURN
6593 20       continue
6594        iblock=666
6595 * treat rho formation in pion+pion collisions
6596 * calculate the mass and momentum of rho in the nucleus-nucleus frame
6597        call rhores(i1,i2)
6598        if(ipp.eq.2)lb(i1)=27
6599        if(ipp.eq.3)lb(i1)=26
6600        if(ipp.eq.5)lb(i1)=25
6601        return
6602       END
6603 **********************************
6604 **********************************
6605 *                                                                      *
6606 *                                                                      *
6607       SUBROUTINE CRND(IRUN,PX,PY,PZ,SRT,I1,I2,IBLOCK,
6608      &SIGNN,SIG,sigk,xsk1,xsk2,xsk3,xsk4,xsk5,NT,ipert1)
6609 *     PURPOSE:                                                         *
6610 *             DEALING WITH NUCLEON-BARYON RESONANCE COLLISIONS         *
6611 *     NOTE   :                                                         *
6612 *           VALID ONLY FOR BARYON-BARYON-DISTANCES LESS THAN 1.32 FM   *
6613 *           (1.32 = 2 * HARD-CORE-RADIUS [HRC] )                       *
6614 *     QUANTITIES:                                                 *
6615 *           PX,PY,PZ - MOMENTUM COORDINATES OF ONE PARTICLE IN CM FRAME*
6616 *           SRT      - SQRT OF S                                       *
6617 *           NSTAR =1 INCLUDING N* RESORANCE,ELSE NOT                   *
6618 *           NDIRCT=1 INCLUDING DIRECT PION PRODUCTION PROCESS         *
6619 *           IBLOCK   - THE INFORMATION BACK                            *
6620 *                      0-> COLLISION CANNOT HAPPEN                     *
6621 *                      1-> N-N ELASTIC COLLISION                       *
6622 *                      2-> N+N->N+DELTA,OR N+N->N+N* REACTION          *
6623 *                      3-> N+DELTA->N+N OR N+N*->N+N REACTION          *
6624 *                      4-> N+N->N+N+PION,DIRTCT PROCESS                *
6625 *           N12       - IS USED TO SPECIFY BARYON-BARYON REACTION      *
6626 *                      CHANNELS. M12 IS THE REVERSAL CHANNEL OF N12    *
6627 *                      N12,                                            *
6628 *                      M12=1 FOR p+n-->delta(+)+ n                     *
6629 *                          2     p+n-->delta(0)+ p                     *
6630 *                          3     p+p-->delta(++)+n                     *
6631 *                          4     p+p-->delta(+)+p                      *
6632 *                          5     n+n-->delta(0)+n                      *
6633 *                          6     n+n-->delta(-)+p                      *
6634 *                          7     n+p-->N*(0)(1440)+p                   *
6635 *                          8     n+p-->N*(+)(1440)+n                   *
6636 *                        9     p+p-->N*(+)(1535)+p                     *
6637 *                        10    n+n-->N*(0)(1535)+n                     *
6638 *                         11    n+p-->N*(+)(1535)+n                     *
6639 *                        12    n+p-->N*(0)(1535)+p
6640 *                        13    D(++)+D(-)-->N*(+)(1440)+n
6641 *                         14    D(++)+D(-)-->N*(0)(1440)+p
6642 *                        15    D(+)+D(0)--->N*(+)(1440)+n
6643 *                        16    D(+)+D(0)--->N*(0)(1440)+p
6644 *                        17    D(++)+D(0)-->N*(+)(1535)+p
6645 *                        18    D(++)+D(-)-->N*(0)(1535)+p
6646 *                        19    D(++)+D(-)-->N*(+)(1535)+n
6647 *                        20    D(+)+D(+)-->N*(+)(1535)+p
6648 *                        21    D(+)+D(0)-->N*(+)(1535)+n
6649 *                        22    D(+)+D(0)-->N*(0)(1535)+p
6650 *                        23    D(+)+D(-)-->N*(0)(1535)+n
6651 *                        24    D(0)+D(0)-->N*(0)(1535)+n
6652 *                          25    N*(+)(14)+N*(+)(14)-->N*(+)(15)+p
6653 *                          26    N*(0)(14)+N*(0)(14)-->N*(0)(15)+n
6654 *                          27    N*(+)(14)+N*(0)(14)-->N*(+)(15)+n
6655 *                        28    N*(+)(14)+N*(0)(14)-->N*(0)(15)+p
6656 *                        29    N*(+)(14)+D+-->N*(+)(15)+p
6657 *                        30    N*(+)(14)+D0-->N*(+)(15)+n
6658 *                        31    N*(+)(14)+D(-)-->N*(0)(1535)+n
6659 *                        32    N*(0)(14)+D++--->N*(+)(15)+p
6660 *                        33    N*(0)(14)+D+--->N*(+)(15)+n
6661 *                        34    N*(0)(14)+D+--->N*(0)(15)+p
6662 *                        35    N*(0)(14)+D0-->N*(0)(15)+n
6663 *                        36    N*(+)(14)+D0--->N*(0)(15)+p
6664 *                        ++    see the note book for more listing
6665 **********************************
6666         PARAMETER (MAXSTR=150001,MAXR=1,AMN=0.939457,
6667      1  AMP=0.93828,AP1=0.13496,AKA=0.498,APHI=1.020,
6668      2  AP2=0.13957,AM0=1.232,PI=3.1415926,CUTOFF=1.8966,AVMASS=0.9383)
6669         parameter     (MX=4,MY=4,MZ=8,MPX=4,MPY=4,mpz=10,mpzp=10)
6670         parameter (xmd=1.8756,npdmax=10000)
6671         COMMON /AA/ R(3,MAXSTR)
6672 cc      SAVE /AA/
6673         COMMON /BB/ P(3,MAXSTR)
6674 cc      SAVE /BB/
6675         COMMON /CC/ E(MAXSTR)
6676 cc      SAVE /CC/
6677         COMMON /EE/ ID(MAXSTR),LB(MAXSTR)
6678 cc      SAVE /EE/
6679         common /ff/f(-mx:mx,-my:my,-mz:mz,-mpx:mpx,-mpy:mpy,-mpz:mpzp)
6680 cc      SAVE /ff/
6681         common /gg/ dx,dy,dz,dpx,dpy,dpz
6682 cc      SAVE /gg/
6683         COMMON /INPUT/ NSTAR,NDIRCT,DIR
6684 cc      SAVE /INPUT/
6685         COMMON /NN/NNN
6686 cc      SAVE /NN/
6687         COMMON /BG/BETAX,BETAY,BETAZ,GAMMA
6688 cc      SAVE /BG/
6689         COMMON   /RUN/NUM
6690 cc      SAVE /RUN/
6691         COMMON   /PA/RPION(3,MAXSTR,MAXR)
6692 cc      SAVE /PA/
6693         COMMON   /PB/PPION(3,MAXSTR,MAXR)
6694 cc      SAVE /PB/
6695         COMMON   /PC/EPION(MAXSTR,MAXR)
6696 cc      SAVE /PC/
6697         COMMON   /PD/LPION(MAXSTR,MAXR)
6698 cc      SAVE /PD/
6699         common/input1/ MASSPR,MASSTA,ISEED,IAVOID,DT
6700 cc      SAVE /input1/
6701       common/leadng/lb1,px1,py1,pz1,em1,e1,xfnl,yfnl,zfnl,tfnl,
6702      1 px1n,py1n,pz1n,dp1n
6703 cc      SAVE /leadng/
6704       COMMON/RNDF77/NSEED
6705 cc      SAVE /RNDF77/
6706       COMMON /dpert/dpertt(MAXSTR,MAXR),dpertp(MAXSTR),dplast(MAXSTR),
6707      1     dpdcy(MAXSTR),dpdpi(MAXSTR,MAXR),dpt(MAXSTR, MAXR),
6708      2     dpp1(MAXSTR,MAXR),dppion(MAXSTR,MAXR)
6709       common /dpi/em2,lb2
6710       common /para8/ idpert,npertd,idxsec
6711       dimension ppd(3,npdmax),lbpd(npdmax)
6712       SAVE
6713 *-----------------------------------------------------------------------
6714        n12=0
6715        m12=0
6716         IBLOCK=0
6717         NTAG=0
6718         EM1=E(I1)
6719         EM2=E(I2)
6720         PR  = SQRT( PX**2 + PY**2 + PZ**2 )
6721         C2  = PZ / PR
6722         X1  = RANART(NSEED)
6723         ianti=0
6724         if(lb(i1).lt.0 .and. lb(i2).lt.0)ianti=1
6725
6726 clin-6/2008 Production of perturbative deuterons for idpert=1:
6727       call sbbdm(srt,sdprod,ianti,lbm,xmm,pfinal)
6728       if(idpert.eq.1.and.ipert1.eq.1) then
6729          IF (SRT .LT. 2.012) RETURN
6730          if((iabs(lb(i1)).eq.1.or.iabs(lb(i1)).eq.2)
6731      1        .and.(iabs(lb(i2)).ge.6.and.iabs(lb(i2)).le.13)) then
6732             goto 108
6733          elseif((iabs(lb(i2)).eq.1.or.iabs(lb(i2)).eq.2)
6734      1           .and.(iabs(lb(i1)).ge.6.and.iabs(lb(i1)).le.13)) then
6735             goto 108
6736          else
6737             return
6738          endif
6739       endif
6740 *-----------------------------------------------------------------------
6741 *COM: TEST FOR ELASTIC SCATTERING (EITHER N-N OR DELTA-DELTA 0R
6742 *      N-DELTA OR N*-N* or N*-Delta)
6743       IF (X1 .LE. SIGNN/SIG) THEN
6744 *COM:  PARAMETRISATION IS TAKEN FROM THE CUGNON-PAPER
6745         AS  = ( 3.65 * (SRT - 1.8766) )**6
6746         A   = 6.0 * AS / (1.0 + AS)
6747         TA  = -2.0 * PR**2
6748         X   = RANART(NSEED)
6749 clin-10/24/02        T1  = ALOG( (1-X) * DEXP(dble(A)*dble(TA)) + X )  /  A
6750         T1  = sngl(DLOG(dble(1.-X)*DEXP(dble(A)*dble(TA))+dble(X)))/  A
6751         C1  = 1.0 - T1/TA
6752         T1  = 2.0 * PI * RANART(NSEED)
6753         IBLOCK=1
6754        GO TO 107
6755       ELSE
6756 *COM: TEST FOR INELASTIC SCATTERING
6757 *     IF THE AVAILABLE ENERGY IS LESS THAN THE PION-MASS, NOTHING
6758 *     CAN HAPPEN ANY MORE ==> RETURN (2.04 = 2*AVMASS + PI-MASS+0.02)
6759         IF (SRT .LT. 2.04) RETURN
6760 clin-6/2008 add d+meson production for n*N*(0)(1440) and p*N*(+)(1440) channels
6761 c     (they did not have any inelastic reactions before):
6762         if(((iabs(LB(I1)).EQ.2.or.iabs(LB(I2)).EQ.2).AND.
6763      1       (LB(I1)*LB(I2)).EQ.20).or.(LB(I1)*LB(I2)).EQ.13) then
6764            IF(X1.LE.((SIGNN+sdprod)/SIG)) GO TO 108
6765         ENDIF
6766 c
6767 * Resonance absorption or Delta + N-->N*(1440), N*(1535)
6768 * COM: TEST FOR DELTA OR N* ABSORPTION
6769 *      IN THE PROCESS DELTA+N-->NN, N*+N-->NN
6770         PRF=SQRT(0.25*SRT**2-AVMASS**2)
6771         IF(EM1.GT.1.)THEN
6772         DELTAM=EM1
6773         ELSE
6774         DELTAM=EM2
6775         ENDIF
6776         RENOM=DELTAM*PRF**2/DENOM(SRT,1.)/PR
6777         RENOMN=DELTAM*PRF**2/DENOM(SRT,2.)/PR
6778         RENOM1=DELTAM*PRF**2/DENOM(SRT,-1.)/PR
6779 * avoid the inelastic collisions between n+delta- -->N+N
6780 *       and p+delta++ -->N+N due to charge conservation,
6781 *       but they can scatter to produce kaons
6782        if((iabs(lb(i1)).eq.2).and.(iabs(lb(i2)).eq.6)) renom=0.
6783        if((iabs(lb(i2)).eq.2).and.(iabs(lb(i1)).eq.6)) renom=0.
6784        if((iabs(lb(i1)).eq.1).and.(iabs(lb(i2)).eq.9)) renom=0.
6785        if((iabs(lb(i2)).eq.1).and.(iabs(lb(i1)).eq.9)) renom=0.
6786        Call M1535(iabs(lb(i1)),iabs(lb(i2)),srt,x1535)
6787         X1440=(3./4.)*SIGMA(SRT,2,0,1)
6788 * CROSS SECTION FOR KAON PRODUCTION from the four channels
6789 * for NLK channel
6790 * avoid the inelastic collisions between n+delta- -->N+N
6791 *       and p+delta++ -->N+N due to charge conservation,
6792 *       but they can scatter to produce kaons
6793        if(((iabs(lb(i1)).eq.2).and.(iabs(lb(i2)).eq.6)).OR.
6794      &         ((iabs(lb(i2)).eq.2).and.(iabs(lb(i1)).eq.6)).OR.
6795      &         ((iabs(lb(i1)).eq.1).and.(iabs(lb(i2)).eq.9)).OR.
6796      &         ((iabs(lb(i2)).eq.1).and.(iabs(lb(i1)).eq.9)))THEN
6797 clin-6/2008
6798           IF(X1.LE.((SIGNN+sdprod)/SIG)) GO TO 108
6799 c          IF((SIGK+SIGNN)/SIG.GE.X1)GO TO 306
6800           IF((SIGK+SIGNN+sdprod)/SIG.GE.X1)GO TO 306
6801 c
6802        ENDIF
6803 * WE DETERMINE THE REACTION CHANNELS IN THE FOLLOWING
6804 * FOR n+delta(++)-->p+p or n+delta(++)-->n+N*(+)(1440),n+N*(+)(1535)
6805 * REABSORPTION OR N*(1535) PRODUCTION LIKE IN P+P OR N*(1440) LIKE PN,
6806         IF(LB(I1)*LB(I2).EQ.18.AND.
6807      &  (iabs(LB(I1)).EQ.2.OR.iabs(LB(I2)).EQ.2))then
6808         SIGND=SIGMA(SRT,1,1,0)+0.5*SIGMA(SRT,1,1,1)
6809         SIGDN=0.25*SIGND*RENOM
6810 clin-6/2008
6811         IF(X1.LE.((SIGNN+sdprod)/SIG)) GO TO 108
6812 c        IF(X1.GT.(SIGNN+SIGDN+X1440+X1535+SIGK)/SIG)RETURN
6813         IF(X1.GT.(SIGNN+SIGDN+X1440+X1535+SIGK+sdprod)/SIG)RETURN
6814 c
6815        IF(SIGK/(SIGK+SIGDN+X1440+X1535).GT.RANART(NSEED))GO TO 306
6816 * REABSORPTION:
6817        IF(RANART(NSEED).LT.SIGDN/(SIGDN+X1440+X1535))THEN
6818         M12=3
6819        GO TO 206
6820        ELSE
6821 * N* PRODUCTION
6822               IF(RANART(NSEED).LT.X1440/(X1440+X1535))THEN
6823 * N*(1440)
6824               M12=37
6825               ELSE
6826 * N*(1535)       M12=38
6827 clin-2/26/03 why is the above commented out? leads to M12=0 but
6828 c     particle mass is changed after 204 (causes energy violation).
6829 c     replace by elastic process (return):
6830                    return
6831
6832               ENDIF
6833        GO TO 204
6834        ENDIF
6835         ENDIF
6836 * FOR p+delta(-)-->n+n or p+delta(-)-->n+N*(0)(1440),n+N*(0)(1535)
6837 * REABSORPTION OR N*(1535) PRODUCTION LIKE IN P+P OR N*(1440) LIKE PN,
6838         IF(LB(I1)*LB(I2).EQ.6.AND.
6839      &   ((iabs(LB(I1)).EQ.1).OR.(iabs(LB(I2)).EQ.1)))then
6840         SIGND=SIGMA(SRT,1,1,0)+0.5*SIGMA(SRT,1,1,1)
6841         SIGDN=0.25*SIGND*RENOM
6842 clin-6/2008
6843         IF(X1.LE.((SIGNN+sdprod)/SIG)) GO TO 108
6844 c        IF (X1.GT.(SIGNN+SIGDN+X1440+X1535+SIGK)/SIG)RETURN
6845         IF (X1.GT.(SIGNN+SIGDN+X1440+X1535+SIGK+sdprod)/SIG)RETURN
6846 c
6847        IF(SIGK/(SIGK+SIGDN+X1440+X1535).GT.RANART(NSEED))GO TO 306
6848 * REABSORPTION:
6849        IF(RANART(NSEED).LT.SIGDN/(SIGDN+X1440+X1535))THEN
6850         M12=6
6851        GO TO 206
6852        ELSE
6853 * N* PRODUCTION
6854               IF(RANART(NSEED).LT.X1440/(X1440+X1535))THEN
6855 * N*(1440)
6856               M12=47
6857               ELSE
6858 * N*(1535)       M12=48
6859 clin-2/26/03 causes energy violation, replace by elastic process (return):
6860                    return
6861
6862               ENDIF
6863        GO TO 204
6864        ENDIF
6865         ENDIF
6866 * FOR p+delta(+)-->p+p, N*(+)(144)+p, N*(+)(1535)+p
6867         IF(LB(I1)*LB(I2).EQ.8.AND.
6868      &   (iabs(LB(I1)).EQ.1.OR.iabs(LB(I2)).EQ.1))THEN
6869         SIGND=1.5*SIGMA(SRT,1,1,1)
6870         SIGDN=0.25*SIGND*RENOM
6871 clin-6/2008
6872         IF(X1.LE.((SIGNN+sdprod)/SIG)) GO TO 108
6873 c        IF(X1.GT.(SIGNN+SIGDN+x1440+x1535+SIGK)/SIG)RETURN
6874         IF(X1.GT.(SIGNN+SIGDN+x1440+x1535+SIGK+sdprod)/SIG)RETURN
6875 c
6876        IF(SIGK/(SIGK+SIGDN+X1440+X1535).GT.RANART(NSEED))GO TO 306
6877        IF(RANART(NSEED).LT.SIGDN/(SIGDN+X1440+X1535))THEN
6878         M12=4
6879        GO TO 206
6880        ELSE
6881               IF(RANART(NSEED).LT.X1440/(X1440+X1535))THEN
6882 * N*(144)
6883               M12=39
6884               ELSE
6885               M12=40
6886               ENDIF
6887               GO TO 204
6888        ENDIF
6889         ENDIF
6890 * FOR n+delta(0)-->n+n, N*(0)(144)+n, N*(0)(1535)+n
6891         IF(LB(I1)*LB(I2).EQ.14.AND.
6892      &   (iabs(LB(I1)).EQ.2.OR.iabs(LB(I2)).EQ.2))THEN
6893         SIGND=1.5*SIGMA(SRT,1,1,1)
6894         SIGDN=0.25*SIGND*RENOM
6895 clin-6/2008
6896         IF(X1.LE.((SIGNN+sdprod)/SIG)) GO TO 108
6897 c        IF(X1.GT.(SIGNN+SIGDN+x1440+x1535+SIGK)/SIG)RETURN
6898         IF(X1.GT.(SIGNN+SIGDN+x1440+x1535+SIGK+sdprod)/SIG)RETURN
6899 c
6900        IF(SIGK/(SIGK+SIGDN+X1440+X1535).GT.RANART(NSEED))GO TO 306
6901        IF(RANART(NSEED).LT.SIGDN/(SIGDN+X1440+X1535))THEN
6902         M12=5
6903        GO TO 206
6904        ELSE
6905               IF(RANART(NSEED).LT.X1440/(X1440+X1535))THEN
6906 * N*(144)
6907               M12=48
6908               ELSE
6909               M12=49
6910               ENDIF
6911               GO TO 204
6912        ENDIF
6913         ENDIF
6914 * FOR n+delta(+)-->n+p, N*(+)(1440)+n,N*(0)(1440)+p,
6915 *                       N*(+)(1535)+n,N*(0)(1535)+p
6916         IF(LB(I1)*LB(I2).EQ.16.AND.
6917      &   (iabs(LB(I1)).EQ.2.OR.iabs(LB(I2)).EQ.2))THEN
6918         SIGND=0.5*SIGMA(SRT,1,1,1)+0.25*SIGMA(SRT,1,1,0)
6919         SIGDN=0.5*SIGND*RENOM
6920 clin-6/2008
6921         IF(X1.LE.((SIGNN+sdprod)/SIG)) GO TO 108
6922 c        IF(X1.GT.(SIGNN+SIGDN+2.*x1440+2.*x1535+SIGK)/SIG)RETURN
6923         IF(X1.GT.(SIGNN+SIGDN+2.*x1440+2.*x1535+SIGK+sdprod)/SIG)RETURN
6924 c
6925        IF(SIGK/(SIGK+SIGDN+2*X1440+2*X1535).GT.RANART(NSEED))GO TO 306
6926        IF(RANART(NSEED).LT.SIGDN/(SIGDN+2.*X1440+2.*X1535))THEN
6927         M12=1
6928        GO TO 206
6929        ELSE
6930               IF(RANART(NSEED).LT.X1440/(X1440+X1535))THEN
6931               M12=41
6932               IF(RANART(NSEED).LE.0.5)M12=43
6933               ELSE
6934               M12=42
6935               IF(RANART(NSEED).LE.0.5)M12=44
6936               ENDIF
6937               GO TO 204
6938        ENDIF
6939         ENDIF
6940 * FOR p+delta(0)-->n+p, N*(+)(1440)+n,N*(0)(1440)+p,
6941 *                       N*(+)(1535)+n,N*(0)(1535)+p
6942         IF(LB(I1)*LB(I2).EQ.7)THEN
6943         SIGND=0.5*SIGMA(SRT,1,1,1)+0.25*SIGMA(SRT,1,1,0)
6944         SIGDN=0.5*SIGND*RENOM
6945 clin-6/2008
6946         IF(X1.LE.((SIGNN+sdprod)/SIG)) GO TO 108
6947 c        IF(X1.GT.(SIGNN+SIGDN+2.*x1440+2.*x1535+SIGK)/SIG)RETURN
6948         IF(X1.GT.(SIGNN+SIGDN+2.*x1440+2.*x1535+SIGK+sdprod)/SIG)RETURN
6949 c
6950        IF(SIGK/(SIGK+SIGDN+2*X1440+2*X1535).GT.RANART(NSEED))GO TO 306
6951        IF(RANART(NSEED).LT.SIGDN/(SIGDN+2.*X1440+2.*X1535))THEN
6952         M12=2
6953        GO TO 206
6954        ELSE
6955               IF(RANART(NSEED).LT.X1440/(X1440+X1535))THEN
6956               M12=50
6957               IF(RANART(NSEED).LE.0.5)M12=51
6958               ELSE
6959               M12=52
6960               IF(RANART(NSEED).LE.0.5)M12=53
6961               ENDIF
6962               GO TO 204
6963        ENDIF
6964         ENDIF
6965 * FOR p+N*(0)(14)-->p+n, N*(+)(1535)+n,N*(0)(1535)+p
6966 * OR  P+N*(0)(14)-->D(+)+N, D(0)+P,
6967         IF(LB(I1)*LB(I2).EQ.10.AND.
6968      &  (iabs(LB(I1)).EQ.1.OR.iabs(LB(I2)).EQ.1))then
6969         SIGND=(3./4.)*SIGMA(SRT,2,0,1)
6970         SIGDN=SIGND*RENOMN
6971 clin-6/2008
6972         IF(X1.LE.((SIGNN+sdprod)/SIG)) GO TO 108
6973 c        IF(X1.GT.(SIGNN+SIGDN+X1535+SIGK)/SIG)RETURN
6974         IF(X1.GT.(SIGNN+SIGDN+X1535+SIGK+sdprod)/SIG)RETURN
6975 c
6976        IF(SIGK/(SIGK+SIGDN+X1535).GT.RANART(NSEED))GO TO 306
6977        IF(RANART(NSEED).LT.SIGDN/(SIGDN+X1535))THEN
6978         M12=7
6979         GO TO 206
6980        ELSE
6981        M12=54
6982        IF(RANART(NSEED).LE.0.5)M12=55
6983        ENDIF
6984        GO TO 204
6985         ENDIF
6986 * FOR n+N*(+)-->p+n, N*(+)(1535)+n,N*(0)(1535)+p
6987         IF(LB(I1)*LB(I2).EQ.22.AND.
6988      &   (iabs(LB(I1)).EQ.2.OR.iabs(LB(I2)).EQ.2))then
6989         SIGND=(3./4.)*SIGMA(SRT,2,0,1)
6990         SIGDN=SIGND*RENOMN
6991 clin-6/2008
6992         IF(X1.LE.((SIGNN+sdprod)/SIG)) GO TO 108
6993 c        IF(X1.GT.(SIGNN+SIGDN+X1535+SIGK)/SIG)RETURN
6994         IF(X1.GT.(SIGNN+SIGDN+X1535+SIGK+sdprod)/SIG)RETURN
6995 c
6996        IF(SIGK/(SIGK+SIGDN+X1535).GT.RANART(NSEED))GO TO 306
6997        IF(RANART(NSEED).LT.SIGDN/(SIGDN+X1535))THEN
6998         M12=8
6999         GO TO 206
7000        ELSE
7001        M12=56
7002        IF(RANART(NSEED).LE.0.5)M12=57
7003        ENDIF
7004        GO TO 204
7005         ENDIF
7006 * FOR N*(1535)+N-->N+N COLLISIONS
7007         IF((iabs(LB(I1)).EQ.12).OR.(iabs(LB(I1)).EQ.13).OR.
7008      1  (iabs(LB(I2)).EQ.12).OR.(iabs(LB(I2)).EQ.13))THEN
7009         SIGND=X1535
7010         SIGDN=SIGND*RENOM1
7011 clin-6/2008
7012         IF(X1.LE.((SIGNN+sdprod)/SIG)) GO TO 108
7013 c        IF(X1.GT.(SIGNN+SIGDN+SIGK)/SIG)RETURN
7014         IF(X1.GT.(SIGNN+SIGDN+SIGK+sdprod)/SIG)RETURN
7015 c
7016        IF(SIGK/(SIGK+SIGDN).GT.RANART(NSEED))GO TO 306
7017         IF(LB(I1)*LB(I2).EQ.24)M12=10
7018         IF(LB(I1)*LB(I2).EQ.12)M12=12
7019         IF(LB(I1)*LB(I2).EQ.26)M12=11
7020        IF(LB(I1)*LB(I2).EQ.13)M12=9
7021        GO TO 206
7022         ENDIF
7023 204       CONTINUE
7024 * (1) GENERATE THE MASS FOR THE N*(1440) AND N*(1535)
7025 * (2) CALCULATE THE FINAL MOMENTUM OF THE n+N* SYSTEM
7026 * (3) RELABLE THE FINAL STATE PARTICLES
7027 *PARAMETRIZATION OF THE SHAPE OF THE N* RESONANCE ACCORDING
7028 *     TO kitazoe's or J.D.JACKSON'S MASS FORMULA AND BREIT WIGNER
7029 *     FORMULA FOR N* RESORANCE
7030 *     DETERMINE DELTA MASS VIA REJECTION METHOD.
7031           DMAX = SRT - AVMASS-0.005
7032           DMIN = 1.078
7033           IF((M12.eq.37).or.(M12.eq.39).or.
7034      1    (M12.eQ.41).OR.(M12.eQ.43).OR.(M12.EQ.46).
7035      2     OR.(M12.EQ.48).OR.(M12.EQ.50).OR.(M12.EQ.51))then
7036 * N*(1440) production
7037           IF(DMAX.LT.1.44) THEN
7038           FM=FNS(DMAX,SRT,0.)
7039           ELSE
7040
7041 clin-10/25/02 get rid of argument usage mismatch in FNS():
7042              xdmass=1.44
7043 c          FM=FNS(1.44,SRT,1.)
7044           FM=FNS(xdmass,SRT,1.)
7045 clin-10/25/02-end
7046
7047           ENDIF
7048           IF(FM.EQ.0.)FM=1.E-09
7049           NTRY2=0
7050 11        DM=RANART(NSEED)*(DMAX-DMIN)+DMIN
7051           NTRY2=NTRY2+1
7052           IF((RANART(NSEED).GT.FNS(DM,SRT,1.)/FM).AND.
7053      1    (NTRY2.LE.10)) GO TO 11
7054
7055 clin-2/26/03 limit the N* mass below a certain value
7056 c     (here taken as its central value + 2* B-W fullwidth):
7057           if(dm.gt.2.14) goto 11
7058
7059               GO TO 13
7060               ELSE
7061 * N*(1535) production
7062           IF(DMAX.LT.1.535) THEN
7063           FM=FD5(DMAX,SRT,0.)
7064           ELSE
7065
7066 clin-10/25/02 get rid of argument usage mismatch in FNS():
7067              xdmass=1.535
7068 c          FM=FD5(1.535,SRT,1.)
7069           FM=FD5(xdmass,SRT,1.)
7070 clin-10/25/02-end
7071
7072           ENDIF
7073           IF(FM.EQ.0.)FM=1.E-09
7074           NTRY1=0
7075 12        DM = RANART(NSEED) * (DMAX-DMIN) + DMIN
7076           NTRY1=NTRY1+1
7077           IF((RANART(NSEED) .GT. FD5(DM,SRT,1.)/FM).AND.
7078      1    (NTRY1.LE.10)) GOTO 12
7079
7080 clin-2/26/03 limit the N* mass below a certain value
7081 c     (here taken as its central value + 2* B-W fullwidth):
7082           if(dm.gt.1.84) goto 12
7083
7084              ENDIF
7085 13       CONTINUE
7086 * (2) DETERMINE THE FINAL MOMENTUM
7087        PRF=0.
7088        PF2=((SRT**2-DM**2+AVMASS**2)/(2.*SRT))**2-AVMASS**2
7089        IF(PF2.GT.0.)PRF=SQRT(PF2)
7090 * (3) RELABLE FINAL STATE PARTICLES
7091 * 37 D(++)+n-->N*(+)(14)+p
7092           IF(M12.EQ.37)THEN
7093           IF(iabs(LB(I1)).EQ.9)THEN
7094           LB(I1)=1
7095           E(I1)=AMP
7096          LB(I2)=11
7097          E(I2)=DM
7098           ELSE
7099           LB(I2)=1
7100           E(I2)=AMP
7101          LB(I1)=11
7102          E(I1)=DM
7103           ENDIF
7104          GO TO 207
7105           ENDIF
7106 * 38 D(++)+n-->N*(+)(15)+p
7107           IF(M12.EQ.38)THEN
7108           IF(iabs(LB(I1)).EQ.9)THEN
7109           LB(I1)=1
7110           E(I1)=AMP
7111          LB(I2)=13
7112          E(I2)=DM
7113           ELSE
7114           LB(I2)=1
7115           E(I2)=AMP
7116          LB(I1)=13
7117          E(I1)=DM
7118           ENDIF
7119          GO TO 207
7120          ENDIF
7121 * 39 D(+)+P-->N*(+)(14)+p
7122           IF(M12.EQ.39)THEN
7123           IF(iabs(LB(I1)).EQ.8)THEN
7124           LB(I1)=1
7125           E(I1)=AMP
7126          LB(I2)=11
7127          E(I2)=DM
7128           ELSE
7129           LB(I2)=1
7130           E(I2)=AMP
7131          LB(I1)=11
7132          E(I1)=DM
7133           ENDIF
7134          GO TO 207
7135          ENDIF
7136 * 40 D(+)+P-->N*(+)(15)+p
7137           IF(M12.EQ.40)THEN
7138           IF(iabs(LB(I1)).EQ.8)THEN
7139           LB(I1)=1
7140           E(I1)=AMP
7141          LB(I2)=13
7142          E(I2)=DM
7143           ELSE
7144           LB(I2)=1
7145           E(I2)=AMP
7146          LB(I1)=13
7147          E(I1)=DM
7148           ENDIF
7149          GO TO 207
7150          ENDIF
7151 * 41 D(+)+N-->N*(+)(14)+N
7152           IF(M12.EQ.41)THEN
7153           IF(iabs(LB(I1)).EQ.8)THEN
7154           LB(I1)=2
7155           E(I1)=AMN
7156          LB(I2)=11
7157          E(I2)=DM
7158           ELSE
7159           LB(I2)=2
7160           E(I2)=AMN
7161          LB(I1)=11
7162          E(I1)=DM
7163           ENDIF
7164          GO TO 207
7165          ENDIF
7166 * 42 D(+)+N-->N*(+)(15)+N
7167           IF(M12.EQ.42)THEN
7168           IF(iabs(LB(I1)).EQ.8)THEN
7169           LB(I1)=2
7170           E(I1)=AMN
7171          LB(I2)=13
7172          E(I2)=DM
7173           ELSE
7174           LB(I2)=2
7175           E(I2)=AMN
7176          LB(I1)=13
7177          E(I1)=DM
7178           ENDIF
7179          GO TO 207
7180          ENDIF
7181 * 43 D(+)+N-->N*(0)(14)+P
7182           IF(M12.EQ.43)THEN
7183           IF(iabs(LB(I1)).EQ.8)THEN
7184           LB(I1)=1
7185           E(I1)=AMP
7186          LB(I2)=10
7187          E(I2)=DM
7188           ELSE
7189           LB(I2)=1
7190           E(I2)=AMP
7191          LB(I1)=10
7192          E(I1)=DM
7193           ENDIF
7194          GO TO 207
7195          ENDIF
7196 * 44 D(+)+N-->N*(0)(15)+P
7197           IF(M12.EQ.44)THEN
7198           IF(iabs(LB(I1)).EQ.8)THEN
7199           LB(I1)=1
7200           E(I1)=AMP
7201          LB(I2)=12
7202          E(I2)=DM
7203           ELSE
7204           LB(I2)=1
7205           E(I2)=AMP
7206          LB(I1)=12
7207          E(I1)=DM
7208           ENDIF
7209          GO TO 207
7210          ENDIF
7211 * 46 D(-)+P-->N*(0)(14)+N
7212           IF(M12.EQ.46)THEN
7213           IF(iabs(LB(I1)).EQ.6)THEN
7214           LB(I1)=2
7215           E(I1)=AMN
7216          LB(I2)=10
7217          E(I2)=DM
7218           ELSE
7219           LB(I2)=2
7220           E(I2)=AMN
7221          LB(I1)=10
7222          E(I1)=DM
7223           ENDIF
7224          GO TO 207
7225          ENDIF
7226 * 47 D(-)+P-->N*(0)(15)+N
7227           IF(M12.EQ.47)THEN
7228           IF(iabs(LB(I1)).EQ.6)THEN
7229           LB(I1)=2
7230           E(I1)=AMN
7231          LB(I2)=12
7232          E(I2)=DM
7233           ELSE
7234           LB(I2)=2
7235           E(I2)=AMN
7236          LB(I1)=12
7237          E(I1)=DM
7238           ENDIF
7239          GO TO 207
7240          ENDIF
7241 * 48 D(0)+N-->N*(0)(14)+N
7242           IF(M12.EQ.48)THEN
7243           IF(iabs(LB(I1)).EQ.7)THEN
7244           LB(I1)=2
7245           E(I1)=AMN
7246          LB(I2)=11
7247          E(I2)=DM
7248           ELSE
7249           LB(I2)=2
7250           E(I2)=AMN
7251          LB(I1)=11
7252          E(I1)=DM
7253           ENDIF
7254          GO TO 207
7255          ENDIF
7256 * 49 D(0)+N-->N*(0)(15)+N
7257           IF(M12.EQ.49)THEN
7258           IF(iabs(LB(I1)).EQ.7)THEN
7259           LB(I1)=2
7260           E(I1)=AMN
7261          LB(I2)=12
7262          E(I2)=DM
7263           ELSE
7264           LB(I2)=2
7265           E(I2)=AMN
7266          LB(I1)=12
7267          E(I1)=DM
7268           ENDIF
7269          GO TO 207
7270          ENDIF
7271 * 50 D(0)+P-->N*(0)(14)+P
7272           IF(M12.EQ.50)THEN
7273           IF(iabs(LB(I1)).EQ.7)THEN
7274           LB(I1)=1
7275           E(I1)=AMP
7276          LB(I2)=10
7277          E(I2)=DM
7278           ELSE
7279           LB(I2)=1
7280           E(I2)=AMP
7281          LB(I1)=10
7282          E(I1)=DM
7283           ENDIF
7284          GO TO 207
7285          ENDIF
7286 * 51 D(0)+P-->N*(+)(14)+N
7287           IF(M12.EQ.51)THEN
7288           IF(iabs(LB(I1)).EQ.7)THEN
7289           LB(I1)=2
7290           E(I1)=AMN
7291          LB(I2)=11
7292          E(I2)=DM
7293           ELSE
7294           LB(I2)=2
7295           E(I2)=AMN
7296          LB(I1)=11
7297          E(I1)=DM
7298           ENDIF
7299          GO TO 207
7300          ENDIF
7301 * 52 D(0)+P-->N*(0)(15)+P
7302           IF(M12.EQ.52)THEN
7303           IF(iabs(LB(I1)).EQ.7)THEN
7304           LB(I1)=1
7305           E(I1)=AMP
7306          LB(I2)=12
7307          E(I2)=DM
7308           ELSE
7309           LB(I2)=1
7310           E(I2)=AMP
7311          LB(I1)=12
7312          E(I1)=DM
7313           ENDIF
7314          GO TO 207
7315          ENDIF
7316 * 53 D(0)+P-->N*(+)(15)+N
7317           IF(M12.EQ.53)THEN
7318           IF(iabs(LB(I1)).EQ.7)THEN
7319           LB(I1)=2
7320           E(I1)=AMN
7321          LB(I2)=13
7322          E(I2)=DM
7323           ELSE
7324           LB(I2)=2
7325           E(I2)=AMN
7326          LB(I1)=13
7327          E(I1)=DM
7328           ENDIF
7329          GO TO 207
7330          ENDIF
7331 * 54 N*(0)(14)+P-->N*(+)(15)+N
7332           IF(M12.EQ.54)THEN
7333           IF(iabs(LB(I1)).EQ.10)THEN
7334           LB(I1)=2
7335           E(I1)=AMN
7336          LB(I2)=13
7337          E(I2)=DM
7338           ELSE
7339           LB(I2)=2
7340           E(I2)=AMN
7341          LB(I1)=13
7342          E(I1)=DM
7343           ENDIF
7344          GO TO 207
7345          ENDIF
7346 * 55 N*(0)(14)+P-->N*(0)(15)+P
7347           IF(M12.EQ.55)THEN
7348           IF(iabs(LB(I1)).EQ.10)THEN
7349           LB(I1)=1
7350           E(I1)=AMP
7351          LB(I2)=12
7352          E(I2)=DM
7353           ELSE
7354           LB(I2)=1
7355           E(I2)=AMP
7356          LB(I1)=12
7357          E(I1)=DM
7358           ENDIF
7359          GO TO 207
7360          ENDIF
7361 * 56 N*(+)(14)+N-->N*(+)(15)+N
7362           IF(M12.EQ.56)THEN
7363           IF(iabs(LB(I1)).EQ.11)THEN
7364           LB(I1)=2
7365           E(I1)=AMN
7366          LB(I2)=13
7367          E(I2)=DM
7368           ELSE
7369           LB(I2)=2
7370           E(I2)=AMN
7371          LB(I1)=13
7372          E(I1)=DM
7373           ENDIF
7374          GO TO 207
7375          ENDIF
7376 * 57 N*(+)(14)+N-->N*(0)(15)+P
7377           IF(M12.EQ.57)THEN
7378           IF(iabs(LB(I1)).EQ.11)THEN
7379           LB(I1)=1
7380           E(I1)=AMP
7381          LB(I2)=12
7382          E(I2)=DM
7383           ELSE
7384           LB(I2)=1
7385           E(I2)=AMP
7386          LB(I1)=12
7387          E(I1)=DM
7388           ENDIF
7389          ENDIF
7390           GO TO 207
7391 *------------------------------------------------
7392 * RELABLE NUCLEONS AFTER DELTA OR N* BEING ABSORBED
7393 *(1) n+delta(+)-->n+p
7394 206       IF(M12.EQ.1)THEN
7395           IF(iabs(LB(I1)).EQ.8)THEN
7396           LB(I2)=2
7397           LB(I1)=1
7398           E(I1)=AMP
7399           ELSE
7400           LB(I1)=2
7401           LB(I2)=1
7402           E(I2)=AMP
7403           ENDIF
7404          GO TO 207
7405           ENDIF
7406 *(2) p+delta(0)-->p+n
7407           IF(M12.EQ.2)THEN
7408           IF(iabs(LB(I1)).EQ.7)THEN
7409           LB(I2)=1
7410           LB(I1)=2
7411           E(I1)=AMN
7412           ELSE
7413           LB(I1)=1
7414           LB(I2)=2
7415           E(I2)=AMN
7416           ENDIF
7417          GO TO 207
7418           ENDIF
7419 *(3) n+delta(++)-->p+p
7420           IF(M12.EQ.3)THEN
7421           LB(I1)=1
7422           LB(I2)=1
7423           E(I1)=AMP
7424           E(I2)=AMP
7425          GO TO 207
7426           ENDIF
7427 *(4) p+delta(+)-->p+p
7428           IF(M12.EQ.4)THEN
7429           LB(I1)=1
7430           LB(I2)=1
7431           E(I1)=AMP
7432           E(I2)=AMP
7433          GO TO 207
7434           ENDIF
7435 *(5) n+delta(0)-->n+n
7436           IF(M12.EQ.5)THEN
7437           LB(I1)=2
7438           LB(I2)=2
7439           E(I1)=AMN
7440           E(I2)=AMN
7441          GO TO 207
7442           ENDIF
7443 *(6) p+delta(-)-->n+n
7444           IF(M12.EQ.6)THEN
7445           LB(I1)=2
7446           LB(I2)=2
7447           E(I1)=AMN
7448           E(I2)=AMN
7449          GO TO 207
7450           ENDIF
7451 *(7) p+N*(0)-->n+p
7452           IF(M12.EQ.7)THEN
7453           IF(iabs(LB(I1)).EQ.1)THEN
7454           LB(I1)=1
7455           LB(I2)=2
7456           E(I1)=AMP
7457           E(I2)=AMN
7458           ELSE
7459           LB(I1)=2
7460           LB(I2)=1
7461           E(I1)=AMN
7462           E(I2)=AMP
7463           ENDIF
7464          GO TO 207
7465           ENDIF
7466 *(8) n+N*(+)-->n+p
7467           IF(M12.EQ.8)THEN
7468           IF(iabs(LB(I1)).EQ.2)THEN
7469           LB(I1)=2
7470           LB(I2)=1
7471           E(I1)=AMN
7472           E(I2)=AMP
7473           ELSE
7474           LB(I1)=1
7475           LB(I2)=2
7476           E(I1)=AMP
7477           E(I2)=AMN
7478           ENDIF
7479          GO TO 207
7480           ENDIF
7481 clin-6/2008
7482 c*(9) N*(+)p-->pp
7483 *(9) N*(+)(1535) p-->pp
7484           IF(M12.EQ.9)THEN
7485           LB(I1)=1
7486           LB(I2)=1
7487           E(I1)=AMP
7488           E(I2)=AMP
7489          GO TO 207
7490          ENDIF
7491 *(12) N*(0)P-->nP
7492           IF(M12.EQ.12)THEN
7493           LB(I1)=2
7494           LB(I2)=1
7495           E(I1)=AMN
7496           E(I2)=AMP
7497          GO TO 207
7498          ENDIF
7499 *(11) N*(+)n-->nP
7500           IF(M12.EQ.11)THEN
7501           LB(I1)=2
7502           LB(I2)=1
7503           E(I1)=AMN
7504           E(I2)=AMP
7505          GO TO 207
7506          ENDIF
7507 clin-6/2008
7508 c*(12) N*(0)p-->Np
7509 *(12) N*(0)(1535) p-->Np
7510           IF(M12.EQ.12)THEN
7511           LB(I1)=1
7512           LB(I2)=2
7513           E(I1)=AMP
7514           E(I2)=AMN
7515          ENDIF
7516 *----------------------------------------------
7517 207       PR   = PRF
7518           C1   = 1.0 - 2.0 * RANART(NSEED)
7519               if(srt.le.2.14)C1= 1.0 - 2.0 * RANART(NSEED)
7520          if(srt.gt.2.14.and.srt.le.2.4)c1=ang(srt,iseed)
7521          if(srt.gt.2.4)then
7522
7523 clin-10/25/02 get rid of argument usage mismatch in PTR():
7524              xptr=0.33*pr
7525 c         cc1=ptr(0.33*pr,iseed)
7526          cc1=ptr(xptr,iseed)
7527 clin-10/25/02-end
7528
7529          c1=sqrt(pr**2-cc1**2)/pr
7530          endif
7531           T1   = 2.0 * PI * RANART(NSEED)
7532           IBLOCK=3
7533       ENDIF
7534       if(ianti.eq.1 .and. lb(i1).ge.1 .and. lb(i2).ge.1)then
7535          lb(i1) = -lb(i1)
7536          lb(i2) = -lb(i2)
7537       endif
7538
7539 *-----------------------------------------------------------------------
7540 *COM: SET THE NEW MOMENTUM COORDINATES
7541  107  IF(PX .EQ. 0.0 .AND. PY .EQ. 0.0) THEN
7542          T2 = 0.0
7543       ELSE
7544          T2=ATAN2(PY,PX)
7545       END IF
7546       S1   = SQRT( 1.0 - C1**2 )
7547       S2  =  SQRT( 1.0 - C2**2 )
7548       CT1  = COS(T1)
7549       ST1  = SIN(T1)
7550       CT2  = COS(T2)
7551       ST2  = SIN(T2)
7552       PZ   = PR * ( C1*C2 - S1*S2*CT1 )
7553       SS   = C2 * S1 * CT1  +  S2 * C1
7554       PX   = PR * ( SS*CT2 - S1*ST1*ST2 )
7555       PY   = PR * ( SS*ST2 + S1*ST1*CT2 )
7556       RETURN
7557 * FOR THE NN-->KAON+X PROCESS, FIND MOMENTUM OF THE FINAL PARTICLES IN
7558 * THE NUCLEUS-NUCLEUS CMS.
7559 306     CONTINUE
7560 csp11/21/01 phi production
7561               if(XSK5/sigK.gt.RANART(NSEED))then
7562               pz1=p(3,i1)
7563               pz2=p(3,i2)
7564                 LB(I1) = 1 + int(2 * RANART(NSEED))
7565                 LB(I2) = 1 + int(2 * RANART(NSEED))
7566               nnn=nnn+1
7567                 LPION(NNN,IRUN)=29
7568                 EPION(NNN,IRUN)=APHI
7569                 iblock = 222
7570               GO TO 208
7571                ENDIF
7572 csp11/21/01 end
7573                 IBLOCK=11
7574                 if(ianti .eq. 1)iblock=-11
7575 c
7576               pz1=p(3,i1)
7577               pz2=p(3,i2)
7578 * DETERMINE THE CHARGE STATES OF PARTICLES IN THE FINAL STATE
7579               nnn=nnn+1
7580                 LPION(NNN,IRUN)=23
7581                 EPION(NNN,IRUN)=Aka
7582               if(srt.le.2.63)then
7583 * only lambda production is possible
7584 * (1.1)P+P-->p+L+kaon+
7585               ic=1
7586
7587                 LB(I1) = 1 + int(2 * RANART(NSEED))
7588               LB(I2)=14
7589               GO TO 208
7590                 ENDIF
7591        if(srt.le.2.74.and.srt.gt.2.63)then
7592 * both Lambda and sigma production are possible
7593               if(XSK1/(XSK1+XSK2).gt.RANART(NSEED))then
7594 * lambda production
7595               ic=1
7596
7597                 LB(I1) = 1 + int(2 * RANART(NSEED))
7598               LB(I2)=14
7599               else
7600 * sigma production
7601
7602                    LB(I1) = 1 + int(2 * RANART(NSEED))
7603                    LB(I2) = 15 + int(3 * RANART(NSEED))
7604               ic=2
7605               endif
7606               GO TO 208
7607        endif
7608        if(srt.le.2.77.and.srt.gt.2.74)then
7609 * then pp-->Delta lamda kaon can happen
7610               if(xsk1/(xsk1+xsk2+xsk3).
7611      1          gt.RANART(NSEED))then
7612 * * (1.1)P+P-->p+L+kaon+
7613               ic=1
7614
7615                 LB(I1) = 1 + int(2 * RANART(NSEED))
7616               LB(I2)=14
7617               go to 208
7618               else
7619               if(xsk2/(xsk2+xsk3).gt.RANART(NSEED))then
7620 * pp-->psk
7621               ic=2
7622
7623                 LB(I1) = 1 + int(2 * RANART(NSEED))
7624                 LB(I2) = 15 + int(3 * RANART(NSEED))
7625
7626               else
7627 * pp-->D+l+k
7628               ic=3
7629
7630                 LB(I1) = 6 + int(4 * RANART(NSEED))
7631               lb(i2)=14
7632               endif
7633               GO TO 208
7634               endif
7635        endif
7636        if(srt.gt.2.77)then
7637 * all four channels are possible
7638               if(xsk1/(xsk1+xsk2+xsk3+xsk4).gt.RANART(NSEED))then
7639 * p lambda k production
7640               ic=1
7641
7642                 LB(I1) = 1 + int(2 * RANART(NSEED))
7643               LB(I2)=14
7644               go to 208
7645        else
7646           if(xsk3/(xsk2+xsk3+xsk4).gt.RANART(NSEED))then
7647 * delta l K production
7648               ic=3
7649
7650                 LB(I1) = 6 + int(4 * RANART(NSEED))
7651               lb(i2)=14
7652               go to 208
7653           else
7654               if(xsk2/(xsk2+xsk4).gt.RANART(NSEED))then
7655 * n sigma k production
7656
7657                    LB(I1) = 1 + int(2 * RANART(NSEED))
7658                    LB(I2) = 15 + int(3 * RANART(NSEED))
7659
7660               ic=2
7661               else
7662               ic=4
7663
7664                 LB(I1) = 6 + int(4 * RANART(NSEED))
7665                 LB(I2) = 15 + int(3 * RANART(NSEED))
7666
7667               endif
7668               go to 208
7669           endif
7670        endif
7671        endif
7672 208             continue
7673          if(ianti.eq.1 .and. lb(i1).ge.1 .and. lb(i2).ge.1)then
7674           lb(i1) = - lb(i1)
7675           lb(i2) = - lb(i2)
7676           if(LPION(NNN,IRUN) .eq. 23)LPION(NNN,IRUN)=21
7677          endif
7678        lbi1=lb(i1)
7679        lbi2=lb(i2)
7680 * KEEP ALL COORDINATES OF PARTICLE 2 FOR POSSIBLE PHASE SPACE CHANGE
7681            NTRY1=0
7682 128        CALL BBKAON(ic,SRT,PX3,PY3,PZ3,DM3,PX4,PY4,PZ4,DM4,
7683      &  PPX,PPY,PPZ,icou1)
7684        NTRY1=NTRY1+1
7685        if((icou1.lt.0).AND.(NTRY1.LE.20))GO TO 128
7686 c       if(icou1.lt.0)return
7687 * ROTATE THE MOMENTA OF PARTICLES IN THE CMS OF P1+P2
7688        CALL ROTATE(PX,PY,PZ,PX3,PY3,PZ3)
7689        CALL ROTATE(PX,PY,PZ,PX4,PY4,PZ4)
7690        CALL ROTATE(PX,PY,PZ,PPX,PPY,PPZ)
7691 * FIND THE MOMENTUM OF PARTICLES IN THE FINAL STATE IN THE NUCLEUS-
7692 * NUCLEUS CMS. FRAME
7693 * (1) for the necleon/delta
7694 *             LORENTZ-TRANSFORMATION INTO LAB FRAME FOR DELTA1
7695               E1CM    = SQRT (dm3**2 + PX3**2 + PY3**2 + PZ3**2)
7696               P1BETA  = PX3*BETAX + PY3*BETAY + PZ3*BETAZ
7697               TRANSF  = GAMMA * ( GAMMA * P1BETA / (GAMMA + 1) + E1CM )
7698               Pt1i1 = BETAX * TRANSF + PX3
7699               Pt2i1 = BETAY * TRANSF + PY3
7700               Pt3i1 = BETAZ * TRANSF + PZ3
7701              Eti1   = DM3
7702 * (2) for the lambda/sigma
7703                 E2CM    = SQRT (dm4**2 + PX4**2 + PY4**2 + PZ4**2)
7704                 P2BETA  = PX4*BETAX+PY4*BETAY+PZ4*BETAZ
7705                 TRANSF  = GAMMA * (GAMMA*P2BETA / (GAMMA + 1.) + E2CM)
7706                 Pt1I2 = BETAX * TRANSF + PX4
7707                 Pt2I2 = BETAY * TRANSF + PY4
7708                 Pt3I2 = BETAZ * TRANSF + PZ4
7709               EtI2   = DM4
7710 * GET the kaon'S MOMENTUM AND COORDINATES IN NUCLEUS-NUCLEUS CMS. FRAME
7711                 EPCM=SQRT(aka**2+PPX**2+PPY**2+PPZ**2)
7712                 PPBETA=PPX*BETAX+PPY*BETAY+PPZ*BETAZ
7713                 TRANSF=GAMMA*(GAMMA*PPBETA/(GAMMA+1.)+EPCM)
7714                 PPION(1,NNN,IRUN)=BETAX*TRANSF+PPX
7715                 PPION(2,NNN,IRUN)=BETAY*TRANSF+PPY
7716                 PPION(3,NNN,IRUN)=BETAZ*TRANSF+PPZ
7717 clin-5/2008:
7718                 dppion(nnn,irun)=dpertp(i1)*dpertp(i2)
7719 clin-5/2008:
7720 c2008        X01 = 1.0 - 2.0 * RANART(NSEED)
7721 c            Y01 = 1.0 - 2.0 * RANART(NSEED)
7722 c            Z01 = 1.0 - 2.0 * RANART(NSEED)
7723 c        IF ((X01*X01+Y01*Y01+Z01*Z01) .GT. 1.0) GOTO 2008
7724 c                RPION(1,NNN,IRUN)=R(1,I1)+0.5*x01
7725 c                RPION(2,NNN,IRUN)=R(2,I1)+0.5*y01
7726 c                RPION(3,NNN,IRUN)=R(3,I1)+0.5*z01
7727                     RPION(1,NNN,IRUN)=R(1,I1)
7728                     RPION(2,NNN,IRUN)=R(2,I1)
7729                     RPION(3,NNN,IRUN)=R(3,I1)
7730 c
7731 * assign the nucleon/delta and lambda/sigma to i1 or i2 to keep the
7732 * leadng particle behaviour
7733 C              if((pt1i1*px1+pt2i1*py1+pt3i1*pz1).gt.0)then
7734               p(1,i1)=pt1i1
7735               p(2,i1)=pt2i1
7736               p(3,i1)=pt3i1
7737               e(i1)=eti1
7738               lb(i1)=lbi1
7739               p(1,i2)=pt1i2
7740               p(2,i2)=pt2i2
7741               p(3,i2)=pt3i2
7742               e(i2)=eti2
7743               lb(i2)=lbi2
7744                 PX1     = P(1,I1)
7745                 PY1     = P(2,I1)
7746                 PZ1     = P(3,I1)
7747               EM1       = E(I1)
7748                 ID(I1)  = 2
7749                 ID(I2)  = 2
7750                 ID1     = ID(I1)
7751                 if(LPION(NNN,IRUN) .ne. 29) IBLOCK=11
7752         LB1=LB(I1)
7753         LB2=LB(I2)
7754         AM1=EM1
7755        am2=em2
7756         E1= SQRT( EM1**2 + PX1**2 + PY1**2 + PZ1**2 )
7757        RETURN
7758
7759 clin-6/2008 N+D->Deuteron+pi:
7760 *     FIND MOMENTUM OF THE FINAL PARTICLES IN THE NUCLEUS-NUCLEUS CMS.
7761  108   CONTINUE
7762            if(idpert.eq.1.and.ipert1.eq.1.and.npertd.ge.1) then
7763 c     For idpert=1: we produce npertd pert deuterons:
7764               ndloop=npertd
7765            elseif(idpert.eq.2.and.npertd.ge.1) then
7766 c     For idpert=2: we first save information for npertd pert deuterons;
7767 c     at the last ndloop we create the regular deuteron+pi
7768 c     and those pert deuterons:
7769               ndloop=npertd+1
7770            else
7771 c     Just create the regular deuteron+pi:
7772               ndloop=1
7773            endif
7774 c
7775            dprob1=sdprod/sig/float(npertd)
7776            do idloop=1,ndloop
7777               CALL bbdangle(pxd,pyd,pzd,nt,ipert1,ianti,idloop,pfinal,
7778      1 dprob1,lbm)
7779               CALL ROTATE(PX,PY,PZ,PXd,PYd,PZd)
7780 *     LORENTZ-TRANSFORMATION OF THE MOMENTUM OF PARTICLES IN THE FINAL STATE
7781 *     FROM THE NN CMS FRAME INTO THE GLOBAL CMS FRAME:
7782 *     For the Deuteron:
7783               xmass=xmd
7784               E1dCM=SQRT(xmass**2+PXd**2+PYd**2+PZd**2)
7785               P1dBETA=PXd*BETAX+PYd*BETAY+PZd*BETAZ
7786               TRANSF=GAMMA*(GAMMA*P1dBETA/(GAMMA+1.)+E1dCM)
7787               pxi1=BETAX*TRANSF+PXd
7788               pyi1=BETAY*TRANSF+PYd
7789               pzi1=BETAZ*TRANSF+PZd
7790               if(ianti.eq.0)then
7791                  lbd=42
7792               else
7793                  lbd=-42
7794               endif
7795               if(idpert.eq.1.and.ipert1.eq.1.and.npertd.ge.1) then
7796 cccc  Perturbative production for idpert=1:
7797                  nnn=nnn+1
7798                  PPION(1,NNN,IRUN)=pxi1
7799                  PPION(2,NNN,IRUN)=pyi1
7800                  PPION(3,NNN,IRUN)=pzi1
7801                  EPION(NNN,IRUN)=xmd
7802                  LPION(NNN,IRUN)=lbd
7803                  RPION(1,NNN,IRUN)=R(1,I1)
7804                  RPION(2,NNN,IRUN)=R(2,I1)
7805                  RPION(3,NNN,IRUN)=R(3,I1)
7806 clin-6/2008 assign the perturbative probability:
7807                  dppion(NNN,IRUN)=sdprod/sig/float(npertd)
7808               elseif(idpert.eq.2.and.idloop.le.npertd) then
7809 clin-6/2008 For idpert=2, we produce NPERTD perturbative (anti)deuterons
7810 c     only when a regular (anti)deuteron+pi is produced in NN collisions.
7811 c     First save the info for the perturbative deuterons:
7812                  ppd(1,idloop)=pxi1
7813                  ppd(2,idloop)=pyi1
7814                  ppd(3,idloop)=pzi1
7815                  lbpd(idloop)=lbd
7816               else
7817 cccc  Regular production:
7818 c     For the regular pion: do LORENTZ-TRANSFORMATION:
7819                  E(i1)=xmm
7820                  E2piCM=SQRT(xmm**2+PXd**2+PYd**2+PZd**2)
7821                  P2piBETA=-PXd*BETAX-PYd*BETAY-PZd*BETAZ
7822                  TRANSF=GAMMA*(GAMMA*P2piBETA/(GAMMA+1.)+E2piCM)
7823                  pxi2=BETAX*TRANSF-PXd
7824                  pyi2=BETAY*TRANSF-PYd
7825                  pzi2=BETAZ*TRANSF-PZd
7826                  p(1,i1)=pxi2
7827                  p(2,i1)=pyi2
7828                  p(3,i1)=pzi2
7829 c     Remove regular pion to check the equivalence
7830 c     between the perturbative and regular deuteron results:
7831 c                 E(i1)=0.
7832 c
7833                  LB(I1)=lbm
7834                  PX1=P(1,I1)
7835                  PY1=P(2,I1)
7836                  PZ1=P(3,I1)
7837                  EM1=E(I1)
7838                  ID(I1)=2
7839                  ID1=ID(I1)
7840                  E1=SQRT(EM1**2+PX1**2+PY1**2+PZ1**2)
7841                  lb1=lb(i1)
7842 c     For the regular deuteron:
7843                  p(1,i2)=pxi1
7844                  p(2,i2)=pyi1
7845                  p(3,i2)=pzi1
7846                  lb(i2)=lbd
7847                  lb2=lb(i2)
7848                  E(i2)=xmd
7849                  EtI2=E(I2)
7850                  ID(I2)=2
7851 c     For idpert=2: create the perturbative deuterons:
7852                  if(idpert.eq.2.and.idloop.eq.ndloop) then
7853                     do ipertd=1,npertd
7854                        nnn=nnn+1
7855                        PPION(1,NNN,IRUN)=ppd(1,ipertd)
7856                        PPION(2,NNN,IRUN)=ppd(2,ipertd)
7857                        PPION(3,NNN,IRUN)=ppd(3,ipertd)
7858                        EPION(NNN,IRUN)=xmd
7859                        LPION(NNN,IRUN)=lbpd(ipertd)
7860                        RPION(1,NNN,IRUN)=R(1,I1)
7861                        RPION(2,NNN,IRUN)=R(2,I1)
7862                        RPION(3,NNN,IRUN)=R(3,I1)
7863 clin-6/2008 assign the perturbative probability:
7864                        dppion(NNN,IRUN)=1./float(npertd)
7865                     enddo
7866                  endif
7867               endif
7868            enddo
7869            IBLOCK=501
7870            return
7871 clin-6/2008 N+D->Deuteron+pi over
7872
7873       END
7874 **********************************
7875 *                                                                      *
7876 *                                                                      *
7877       SUBROUTINE CRDD(IRUN,PX,PY,PZ,SRT,I1,I2,IBLOCK,
7878      1NTAG,SIGNN,SIG,NT,ipert1)
7879 c     1NTAG,SIGNN,SIG)
7880 *     PURPOSE:                                                         *
7881 *             DEALING WITH BARYON RESONANCE-BARYON RESONANCE COLLISIONS*
7882 *     NOTE   :                                                         *
7883 *     QUANTITIES:                                                 *
7884 *           PX,PY,PZ - MOMENTUM COORDINATES OF ONE PARTICLE IN CM FRAME*
7885 *           SRT      - SQRT OF S                                       *
7886 *           NSTAR =1 INCLUDING N* RESORANCE,ELSE NOT                   *
7887 *           NDIRCT=1 INCLUDING DIRECT PION PRODUCTION PROCESS         *
7888 *           IBLOCK   - THE INFORMATION BACK                            *
7889 *                      0-> COLLISION CANNOT HAPPEN                     *
7890 *                      1-> N-N ELASTIC COLLISION                       *
7891 *                      2-> N+N->N+DELTA,OR N+N->N+N* REACTION          *
7892 *                      3-> N+DELTA->N+N OR N+N*->N+N REACTION          *
7893 *                      4-> N+N->N+N+PION,DIRTCT PROCESS                *
7894 *                     5-> DELTA(N*)+DELTA(N*)   TOTAL   COLLISIONS    *
7895 *           N12       - IS USED TO SPECIFY BARYON-BARYON REACTION      *
7896 *                      CHANNELS. M12 IS THE REVERSAL CHANNEL OF N12    *
7897 *                      N12,                                            *
7898 *                      M12=1 FOR p+n-->delta(+)+ n                     *
7899 *                          2     p+n-->delta(0)+ p                     *
7900 *                          3     p+p-->delta(++)+n                     *
7901 *                          4     p+p-->delta(+)+p                      *
7902 *                          5     n+n-->delta(0)+n                      *
7903 *                          6     n+n-->delta(-)+p                      *
7904 *                          7     n+p-->N*(0)(1440)+p                   *
7905 *                          8     n+p-->N*(+)(1440)+n                   *
7906 *                        9     p+p-->N*(+)(1535)+p                     *
7907 *                        10    n+n-->N*(0)(1535)+n                     *
7908 *                         11    n+p-->N*(+)(1535)+n                     *
7909 *                        12    n+p-->N*(0)(1535)+p
7910 *                        13    D(++)+D(-)-->N*(+)(1440)+n
7911 *                         14    D(++)+D(-)-->N*(0)(1440)+p
7912 *                        15    D(+)+D(0)--->N*(+)(1440)+n
7913 *                        16    D(+)+D(0)--->N*(0)(1440)+p
7914 *                        17    D(++)+D(0)-->N*(+)(1535)+p
7915 *                        18    D(++)+D(-)-->N*(0)(1535)+p
7916 *                        19    D(++)+D(-)-->N*(+)(1535)+n
7917 *                        20    D(+)+D(+)-->N*(+)(1535)+p
7918 *                        21    D(+)+D(0)-->N*(+)(1535)+n
7919 *                        22    D(+)+D(0)-->N*(0)(1535)+p
7920 *                        23    D(+)+D(-)-->N*(0)(1535)+n
7921 *                        24    D(0)+D(0)-->N*(0)(1535)+n
7922 *                          25    N*(+)(14)+N*(+)(14)-->N*(+)(15)+p
7923 *                          26    N*(0)(14)+N*(0)(14)-->N*(0)(15)+n
7924 *                          27    N*(+)(14)+N*(0)(14)-->N*(+)(15)+n
7925 *                        28    N*(+)(14)+N*(0)(14)-->N*(0)(15)+p
7926 *                        29    N*(+)(14)+D+-->N*(+)(15)+p
7927 *                        30    N*(+)(14)+D0-->N*(+)(15)+n
7928 *                        31    N*(+)(14)+D(-)-->N*(0)(1535)+n
7929 *                        32    N*(0)(14)+D++--->N*(+)(15)+p
7930 *                        33    N*(0)(14)+D+--->N*(+)(15)+n
7931 *                        34    N*(0)(14)+D+--->N*(0)(15)+p
7932 *                        35    N*(0)(14)+D0-->N*(0)(15)+n
7933 *                        36    N*(+)(14)+D0--->N*(0)(15)+p
7934 *                        +++
7935 *               AND MORE CHANNELS AS LISTED IN THE NOTE BOOK
7936 *
7937 * NOTE ABOUT N*(1440) RESORANCE:                                       *
7938 *     As it has been discussed in VerWest's paper,I= 1 (initial isospin)
7939 *     channel can all be attributed to delta resorance while I= 0      *
7940 *     channel can all be  attribured to N* resorance.Only in n+p       *
7941 *     one can have I=0 channel so is the N*(1440) resorance            *
7942 * REFERENCES:    J. CUGNON ET AL., NUCL. PHYS. A352, 505 (1981)        *
7943 *                    Y. KITAZOE ET AL., PHYS. LETT. 166B, 35 (1986)    *
7944 *                    B. VerWest el al., PHYS. PRV. C25 (1982)1979      *
7945 *                    Gy. Wolf  et al, Nucl Phys A517 (1990) 615        *
7946 *                    CUTOFF = 2 * AVMASS + 20 MEV                      *
7947 *                                                                      *
7948 *       for N*(1535) we use the parameterization by Gy. Wolf et al     *
7949 *       Nucl phys A552 (1993) 349, added May 18, 1994                  *
7950 **********************************
7951         PARAMETER (MAXSTR=150001,MAXR=1,AMN=0.939457,
7952      1  AMP=0.93828,AP1=0.13496,AKA=0.498,APHI=1.020,
7953      2  AP2=0.13957,AM0=1.232,PI=3.1415926,CUTOFF=1.8966,AVMASS=0.9383)
7954         parameter     (MX=4,MY=4,MZ=8,MPX=4,MPY=4,mpz=10,mpzp=10)
7955         parameter (xmd=1.8756,npdmax=10000)
7956         COMMON /AA/ R(3,MAXSTR)
7957 cc      SAVE /AA/
7958         COMMON /BB/ P(3,MAXSTR)
7959 cc      SAVE /BB/
7960         COMMON /CC/ E(MAXSTR)
7961 cc      SAVE /CC/
7962         COMMON /EE/ ID(MAXSTR),LB(MAXSTR)
7963 cc      SAVE /EE/
7964         common /ff/f(-mx:mx,-my:my,-mz:mz,-mpx:mpx,-mpy:mpy,-mpz:mpzp)
7965 cc      SAVE /ff/
7966         common /gg/ dx,dy,dz,dpx,dpy,dpz
7967 cc      SAVE /gg/
7968         COMMON /INPUT/ NSTAR,NDIRCT,DIR
7969 cc      SAVE /INPUT/
7970         COMMON /NN/NNN
7971 cc      SAVE /NN/
7972         COMMON /BG/BETAX,BETAY,BETAZ,GAMMA
7973 cc      SAVE /BG/
7974         COMMON   /RUN/NUM
7975 cc      SAVE /RUN/
7976         COMMON   /PA/RPION(3,MAXSTR,MAXR)
7977 cc      SAVE /PA/
7978         COMMON   /PB/PPION(3,MAXSTR,MAXR)
7979 cc      SAVE /PB/
7980         COMMON   /PC/EPION(MAXSTR,MAXR)
7981 cc      SAVE /PC/
7982         COMMON   /PD/LPION(MAXSTR,MAXR)
7983 cc      SAVE /PD/
7984         common/input1/ MASSPR,MASSTA,ISEED,IAVOID,DT
7985 cc      SAVE /input1/
7986       common/leadng/lb1,px1,py1,pz1,em1,e1,xfnl,yfnl,zfnl,tfnl,
7987      1 px1n,py1n,pz1n,dp1n
7988 cc      SAVE /leadng/
7989       COMMON/RNDF77/NSEED
7990 cc      SAVE /RNDF77/
7991       COMMON /dpert/dpertt(MAXSTR,MAXR),dpertp(MAXSTR),dplast(MAXSTR),
7992      1     dpdcy(MAXSTR),dpdpi(MAXSTR,MAXR),dpt(MAXSTR, MAXR),
7993      2     dpp1(MAXSTR,MAXR),dppion(MAXSTR,MAXR)
7994       common /dpi/em2,lb2
7995       common /para8/ idpert,npertd,idxsec
7996       dimension ppd(3,npdmax),lbpd(npdmax)
7997       SAVE
7998 *-----------------------------------------------------------------------
7999        n12=0
8000        m12=0
8001         IBLOCK=0
8002         NTAG=0
8003         EM1=E(I1)
8004         EM2=E(I2)
8005       PR  = SQRT( PX**2 + PY**2 + PZ**2 )
8006       C2  = PZ / PR
8007       IF(PX .EQ. 0.0 .AND. PY .EQ. 0.0) THEN
8008         T2 = 0.0
8009       ELSE
8010         T2=ATAN2(PY,PX)
8011       END IF
8012       X1  = RANART(NSEED)
8013       ianti=0
8014       if(lb(i1).lt.0 .and. lb(i2).lt.0)ianti=1
8015
8016 clin-6/2008 Production of perturbative deuterons for idpert=1:
8017       call sbbdm(srt,sdprod,ianti,lbm,xmm,pfinal)
8018       if(idpert.eq.1.and.ipert1.eq.1) then
8019          IF (SRT .LT. 2.012) RETURN
8020          if((iabs(lb(i1)).ge.6.and.iabs(lb(i1)).le.13)
8021      1        .and.(iabs(lb(i2)).ge.6.and.iabs(lb(i2)).le.13)) then
8022             goto 108
8023          else
8024             return
8025          endif
8026       endif
8027
8028 *-----------------------------------------------------------------------
8029 *COM: TEST FOR ELASTIC SCATTERING (EITHER N-N OR DELTA-DELTA 0R
8030 *      N-DELTA OR N*-N* or N*-Delta)
8031       IF (X1 .LE. SIGNN/SIG) THEN
8032 *COM:  PARAMETRISATION IS TAKEN FROM THE CUGNON-PAPER
8033         AS  = ( 3.65 * (SRT - 1.8766) )**6
8034         A   = 6.0 * AS / (1.0 + AS)
8035         TA  = -2.0 * PR**2
8036         X   = RANART(NSEED)
8037 clin-10/24/02        T1  = DLOG( (1-X) * DEXP(dble(A)*dble(TA)) + X )  /  A
8038         T1  = sngl(DLOG(dble(1.-X)*DEXP(dble(A)*dble(TA))+dble(X)))/  A
8039         C1  = 1.0 - T1/TA
8040         T1  = 2.0 * PI * RANART(NSEED)
8041         IBLOCK=20
8042        GO TO 107
8043       ELSE
8044 *COM: TEST FOR INELASTIC SCATTERING
8045 *     IF THE AVAILABLE ENERGY IS LESS THAN THE PION-MASS, NOTHING
8046 *     CAN HAPPEN ANY MORE ==> RETURN (2.15 = 2*AVMASS +2*PI-MASS)
8047         IF (SRT .LT. 2.15) RETURN
8048 *     IF THERE WERE 2 N*(1535) AND THEY DIDN'T SCATT. ELAST.,
8049 *     ALLOW THEM TO PRODUCE KAONS. NO OTHER INELASTIC CHANNELS
8050 *     ARE KNOWN
8051 C       if((lb(i1).ge.12).and.(lb(i2).ge.12))return
8052 *     ALL the inelastic collisions between N*(1535) and Delta as well
8053 *     as N*(1440) TO PRODUCE KAONS, NO OTHER CHANNELS ARE KNOWN
8054 C       if((lb(i1).ge.12).and.(lb(i2).ge.3))return
8055 C       if((lb(i2).ge.12).and.(lb(i1).ge.3))return
8056 *     calculate the N*(1535) production cross section in I1+I2 collisions
8057        call N1535(iabs(lb(i1)),iabs(lb(i2)),srt,X1535)
8058
8059 * for Delta+Delta-->N*(1440 OR 1535)+N AND N*(1440)+N*(1440)-->N*(1535)+X
8060 *     AND DELTA+N*(1440)-->N*(1535)+X
8061 * WE ASSUME THEY HAVE THE SAME CROSS SECTIONS as CORRESPONDING N+N COLLISION):
8062 * FOR D++D0, D+D+,D+D-,D0D0,N*+N*+,N*0N*0,N*(+)D+,N*(+)D(-),N*(0)D(0)
8063 * N*(1535) production, kaon production and reabsorption through
8064 * D(N*)+D(N*)-->NN are ALLOWED.
8065 * CROSS SECTION FOR KAON PRODUCTION from the four channels are
8066 * for NLK channel
8067        akp=0.498
8068        ak0=0.498
8069        ana=0.938
8070        ada=1.232
8071        al=1.1157
8072        as=1.1197
8073        xsk1=0
8074        xsk2=0
8075        xsk3=0
8076        xsk4=0
8077        xsk5=0
8078        t1nlk=ana+al+akp
8079        if(srt.le.t1nlk)go to 222
8080        XSK1=1.5*PPLPK(SRT)
8081 * for DLK channel
8082        t1dlk=ada+al+akp
8083        t2dlk=ada+al-akp
8084        if(srt.le.t1dlk)go to 222
8085        es=srt
8086        pmdlk2=(es**2-t1dlk**2)*(es**2-t2dlk**2)/(4.*es**2)
8087        pmdlk=sqrt(pmdlk2)
8088        XSK3=1.5*PPLPK(srt)
8089 * for NSK channel
8090        t1nsk=ana+as+akp
8091        t2nsk=ana+as-akp
8092        if(srt.le.t1nsk)go to 222
8093        pmnsk2=(es**2-t1nsk**2)*(es**2-t2nsk**2)/(4.*es**2)
8094        pmnsk=sqrt(pmnsk2)
8095        XSK2=1.5*(PPK1(srt)+PPK0(srt))
8096 * for DSK channel
8097        t1DSk=aDa+aS+akp
8098        t2DSk=aDa+aS-akp
8099        if(srt.le.t1dsk)go to 222
8100        pmDSk2=(es**2-t1DSk**2)*(es**2-t2DSk**2)/(4.*es**2)
8101        pmDSk=sqrt(pmDSk2)
8102        XSK4=1.5*(PPK1(srt)+PPK0(srt))
8103 csp11/21/01
8104 c phi production
8105        if(srt.le.(2.*amn+aphi))go to 222
8106 c  !! mb put the correct form
8107          xsk5 = 0.0001
8108 csp11/21/01 end
8109 * THE TOTAL KAON+ PRODUCTION CROSS SECTION IS THEN
8110 222       SIGK=XSK1+XSK2+XSK3+XSK4
8111
8112 cbz3/7/99 neutralk
8113         XSK1 = 2.0 * XSK1
8114         XSK2 = 2.0 * XSK2
8115         XSK3 = 2.0 * XSK3
8116         XSK4 = 2.0 * XSK4
8117         SIGK = 2.0 * SIGK + xsk5
8118 cbz3/7/99 neutralk end
8119
8120 * The reabsorption cross section for the process
8121 * D(N*)D(N*)-->NN is
8122        s2d=reab2d(i1,i2,srt)
8123
8124 cbz3/16/99 pion
8125         S2D = 0.
8126 cbz3/16/99 pion end
8127
8128 *(1) N*(1535)+D(N*(1440)) reactions
8129 *    we allow kaon production and reabsorption only
8130        if(((iabs(lb(i1)).ge.12).and.(iabs(lb(i2)).ge.12)).OR.
8131      &       ((iabs(lb(i1)).ge.12).and.(iabs(lb(i2)).ge.6)).OR.
8132      &       ((iabs(lb(i2)).ge.12).and.(iabs(lb(i1)).ge.6)))THEN
8133        signd=sigk+s2d
8134 clin-6/2008
8135        IF(X1.LE.((SIGNN+sdprod)/SIG)) GO TO 108
8136 c       if(x1.gt.(signd+signn)/sig)return
8137        if(x1.gt.(signd+signn+sdprod)/sig)return
8138 c
8139 * if kaon production
8140 clin-6/2008
8141 c       IF(SIGK/SIG.GE.RANART(NSEED))GO TO 306
8142        IF((SIGK+sdprod)/SIG.GE.RANART(NSEED))GO TO 306
8143 c
8144 * if reabsorption
8145        go to 1012
8146        ENDIF
8147        IDD=iabs(LB(I1)*LB(I2))
8148 * channels have the same charge as pp
8149         IF((IDD.EQ.63).OR.(IDD.EQ.64).OR.(IDD.EQ.48).
8150      1  OR.(IDD.EQ.49).OR.(IDD.EQ.11*11).OR.(IDD.EQ.10*10).
8151      2  OR.(IDD.EQ.88).OR.(IDD.EQ.66).
8152      3  OR.(IDD.EQ.90).OR.(IDD.EQ.70))THEN
8153         SIGND=X1535+SIGK+s2d
8154 clin-6/2008
8155         IF(X1.LE.((SIGNN+sdprod)/SIG)) GO TO 108
8156 c        IF (X1.GT.(SIGNN+SIGND)/SIG)RETURN
8157         IF (X1.GT.(SIGNN+SIGND+sdprod)/SIG)RETURN
8158 c
8159 * if kaon production
8160        IF(SIGK/SIGND.GT.RANART(NSEED))GO TO 306
8161 * if reabsorption
8162        if(s2d/(x1535+s2d).gt.RANART(NSEED))go to 1012
8163 * if N*(1535) production
8164        IF(IDD.EQ.63)N12=17
8165        IF(IDD.EQ.64)N12=20
8166        IF(IDD.EQ.48)N12=23
8167        IF(IDD.EQ.49)N12=24
8168        IF(IDD.EQ.121)N12=25
8169        IF(IDD.EQ.100)N12=26
8170        IF(IDD.EQ.88)N12=29
8171        IF(IDD.EQ.66)N12=31
8172        IF(IDD.EQ.90)N12=32
8173        IF(IDD.EQ.70)N12=35
8174        GO TO 1011
8175         ENDIF
8176 * IN DELTA+N*(1440) and N*(1440)+N*(1440) COLLISIONS,
8177 * N*(1535), kaon production and reabsorption are ALLOWED
8178 * IN N*(1440)+N*(1440) COLLISIONS, ONLY N*(1535) IS ALLOWED
8179        IF((IDD.EQ.110).OR.(IDD.EQ.77).OR.(IDD.EQ.80))THEN
8180 clin-6/2008
8181           IF(X1.LE.((SIGNN+sdprod)/SIG)) GO TO 108
8182 c       IF(X1.GT.(SIGNN+X1535+SIGK+s2d)/SIG)RETURN
8183           IF(X1.GT.(SIGNN+X1535+SIGK+s2d+sdprod)/SIG)RETURN
8184 c
8185        IF(SIGK/(X1535+SIGK+s2d).GT.RANART(NSEED))GO TO 306
8186        if(s2d/(x1535+s2d).gt.RANART(NSEED))go to 1012
8187        IF(IDD.EQ.77)N12=30
8188        IF((IDD.EQ.77).AND.(RANART(NSEED).LE.0.5))N12=36
8189        IF(IDD.EQ.80)N12=34
8190        IF((IDD.EQ.80).AND.(RANART(NSEED).LE.0.5))N12=35
8191        IF(IDD.EQ.110)N12=27
8192        IF((IDD.EQ.110).AND.(RANART(NSEED).LE.0.5))N12=28
8193        GO TO 1011
8194         ENDIF
8195        IF((IDD.EQ.54).OR.(IDD.EQ.56))THEN
8196 * LIKE FOR N+P COLLISION,
8197 * IN DELTA+DELTA COLLISIONS BOTH N*(1440) AND N*(1535) CAN BE PRODUCED
8198         SIG2=(3./4.)*SIGMA(SRT,2,0,1)
8199         SIGND=2.*(SIG2+X1535)+SIGK+s2d
8200 clin-6/2008
8201         IF(X1.LE.((SIGNN+sdprod)/SIG)) GO TO 108
8202 c        IF(X1.GT.(SIGNN+SIGND)/SIG)RETURN
8203         IF(X1.GT.(SIGNN+SIGND+sdprod)/SIG)RETURN
8204 c
8205        IF(SIGK/SIGND.GT.RANART(NSEED))GO TO 306
8206        if(s2d/(2.*(sig2+x1535)+s2d).gt.RANART(NSEED))go to 1012
8207        IF(RANART(NSEED).LT.X1535/(SIG2+X1535))THEN
8208 * N*(1535) PRODUCTION
8209        IF(IDD.EQ.54)N12=18
8210        IF((IDD.EQ.54).AND.(RANART(NSEED).LE.0.5))N12=19
8211        IF(IDD.EQ.56)N12=21
8212        IF((IDD.EQ.56).AND.(RANART(NSEED).LE.0.5))N12=22
8213                ELSE
8214 * N*(144) PRODUCTION
8215        IF(IDD.EQ.54)N12=13
8216        IF((IDD.EQ.54).AND.(RANART(NSEED).LE.0.5))N12=14
8217        IF(IDD.EQ.56)N12=15
8218        IF((IDD.EQ.56).AND.(RANART(NSEED).LE.0.5))N12=16
8219               ENDIF
8220        ENDIF
8221 1011       CONTINUE
8222        iblock=5
8223 *PARAMETRIZATION OF THE SHAPE OF THE N*(1440) AND N*(1535)
8224 * RESONANCE ACCORDING
8225 *     TO kitazoe's or J.D.JACKSON'S MASS FORMULA AND BREIT WIGNER
8226 *     FORMULA FOR N* RESORANCE
8227 *     DETERMINE DELTA MASS VIA REJECTION METHOD.
8228           DMAX = SRT - AVMASS-0.005
8229           DMIN = 1.078
8230           IF((n12.ge.13).and.(n12.le.16))then
8231 * N*(1440) production
8232           IF(DMAX.LT.1.44) THEN
8233           FM=FNS(DMAX,SRT,0.)
8234           ELSE
8235
8236 clin-10/25/02 get rid of argument usage mismatch in FNS():
8237              xdmass=1.44
8238 c          FM=FNS(1.44,SRT,1.)
8239           FM=FNS(xdmass,SRT,1.)
8240 clin-10/25/02-end
8241
8242           ENDIF
8243           IF(FM.EQ.0.)FM=1.E-09
8244           NTRY2=0
8245 11        DM=RANART(NSEED)*(DMAX-DMIN)+DMIN
8246           NTRY2=NTRY2+1
8247           IF((RANART(NSEED).GT.FNS(DM,SRT,1.)/FM).AND.
8248      1    (NTRY2.LE.10)) GO TO 11
8249
8250 clin-2/26/03 limit the N* mass below a certain value
8251 c     (here taken as its central value + 2* B-W fullwidth):
8252           if(dm.gt.2.14) goto 11
8253
8254               GO TO 13
8255               ENDIF
8256                     IF((n12.ge.17).AND.(N12.LE.36))then
8257 * N*(1535) production
8258           IF(DMAX.LT.1.535) THEN
8259           FM=FD5(DMAX,SRT,0.)
8260           ELSE
8261
8262 clin-10/25/02 get rid of argument usage mismatch in FNS():
8263              xdmass=1.535
8264 c          FM=FD5(1.535,SRT,1.)
8265           FM=FD5(xdmass,SRT,1.)
8266 clin-10/25/02-end
8267
8268           ENDIF
8269           IF(FM.EQ.0.)FM=1.E-09
8270           NTRY1=0
8271 12        DM = RANART(NSEED) * (DMAX-DMIN) + DMIN
8272           NTRY1=NTRY1+1
8273           IF((RANART(NSEED) .GT. FD5(DM,SRT,1.)/FM).AND.
8274      1    (NTRY1.LE.10)) GOTO 12
8275
8276 clin-2/26/03 limit the N* mass below a certain value
8277 c     (here taken as its central value + 2* B-W fullwidth):
8278           if(dm.gt.1.84) goto 12
8279
8280              ENDIF
8281 13       CONTINUE
8282 *-------------------------------------------------------
8283 * RELABLE BARYON I1 AND I2
8284 *13 D(++)+D(-)--> N*(+)(14)+n
8285           IF(N12.EQ.13)THEN
8286           IF(RANART(NSEED).LE.0.5)THEN
8287           LB(I2)=11
8288           E(I2)=DM
8289          LB(I1)=2
8290          E(I1)=AMN
8291           ELSE
8292           LB(I1)=11
8293           E(I1)=DM
8294          LB(I2)=2
8295          E(I2)=AMN
8296           ENDIF
8297          go to 200
8298           ENDIF
8299 *14 D(++)+D(-)--> N*(0)(14)+P
8300           IF(N12.EQ.14)THEN
8301           IF(RANART(NSEED).LE.0.5)THEN
8302           LB(I2)=10
8303           E(I2)=DM
8304          LB(I1)=1
8305          E(I1)=AMP
8306           ELSE
8307           LB(I1)=10
8308           E(I1)=DM
8309          LB(I2)=1
8310          E(I2)=AMP
8311           ENDIF
8312          go to 200
8313           ENDIF
8314 *15 D(+)+D(0)--> N*(+)(14)+n
8315           IF(N12.EQ.15)THEN
8316           IF(RANART(NSEED).LE.0.5)THEN
8317           LB(I2)=11
8318           E(I2)=DM
8319          LB(I1)=2
8320          E(I1)=AMN
8321           ELSE
8322           LB(I1)=11
8323           E(I1)=DM
8324          LB(I2)=2
8325          E(I2)=AMN
8326           ENDIF
8327          go to 200
8328           ENDIF
8329 *16 D(+)+D(0)--> N*(0)(14)+P
8330           IF(N12.EQ.16)THEN
8331           IF(RANART(NSEED).LE.0.5)THEN
8332           LB(I2)=10
8333           E(I2)=DM
8334          LB(I1)=1
8335          E(I1)=AMP
8336           ELSE
8337           LB(I1)=10
8338           E(I1)=DM
8339          LB(I2)=1
8340          E(I2)=AMP
8341           ENDIF
8342          go to 200
8343           ENDIF
8344 *17 D(++)+D(0)--> N*(+)(14)+P
8345           IF(N12.EQ.17)THEN
8346           LB(I2)=13
8347           E(I2)=DM
8348          LB(I1)=1
8349          E(I1)=AMP
8350          go to 200
8351           ENDIF
8352 *18 D(++)+D(-)--> N*(0)(15)+P
8353           IF(N12.EQ.18)THEN
8354           IF(RANART(NSEED).LE.0.5)THEN
8355           LB(I2)=12
8356           E(I2)=DM
8357          LB(I1)=1
8358          E(I1)=AMP
8359           ELSE
8360           LB(I1)=12
8361           E(I1)=DM
8362          LB(I2)=1
8363          E(I2)=AMP
8364           ENDIF
8365          go to 200
8366           ENDIF
8367 *19 D(++)+D(-)--> N*(+)(15)+N
8368           IF(N12.EQ.19)THEN
8369           IF(RANART(NSEED).LE.0.5)THEN
8370           LB(I2)=13
8371           E(I2)=DM
8372          LB(I1)=2
8373          E(I1)=AMN
8374           ELSE
8375           LB(I1)=13
8376           E(I1)=DM
8377          LB(I2)=2
8378          E(I2)=AMN
8379           ENDIF
8380          go to 200
8381           ENDIF
8382 *20 D(+)+D(+)--> N*(+)(15)+P
8383           IF(N12.EQ.20)THEN
8384           IF(RANART(NSEED).LE.0.5)THEN
8385           LB(I2)=13
8386           E(I2)=DM
8387          LB(I1)=1
8388          E(I1)=AMP
8389           ELSE
8390           LB(I1)=13
8391           E(I1)=DM
8392          LB(I2)=1
8393          E(I2)=AMP
8394           ENDIF
8395          go to 200
8396           ENDIF
8397 *21 D(+)+D(0)--> N*(+)(15)+N
8398           IF(N12.EQ.21)THEN
8399           IF(RANART(NSEED).LE.0.5)THEN
8400           LB(I2)=13
8401           E(I2)=DM
8402          LB(I1)=2
8403          E(I1)=AMN
8404           ELSE
8405           LB(I1)=13
8406           E(I1)=DM
8407          LB(I2)=2
8408          E(I2)=AMN
8409           ENDIF
8410          go to 200
8411           ENDIF
8412 *22 D(+)+D(0)--> N*(0)(15)+P
8413           IF(N12.EQ.22)THEN
8414           IF(RANART(NSEED).LE.0.5)THEN
8415           LB(I2)=12
8416           E(I2)=DM
8417          LB(I1)=1
8418          E(I1)=AMP
8419           ELSE
8420           LB(I1)=12
8421           E(I1)=DM
8422          LB(I2)=1
8423          E(I2)=AMP
8424           ENDIF
8425          go to 200
8426           ENDIF
8427 *23 D(+)+D(-)--> N*(0)(15)+N
8428           IF(N12.EQ.23)THEN
8429           IF(RANART(NSEED).LE.0.5)THEN
8430           LB(I2)=12
8431           E(I2)=DM
8432          LB(I1)=2
8433          E(I1)=AMN
8434           ELSE
8435           LB(I1)=12
8436           E(I1)=DM
8437          LB(I2)=2
8438          E(I2)=AMN
8439           ENDIF
8440          go to 200
8441           ENDIF
8442 *24 D(0)+D(0)--> N*(0)(15)+N
8443           IF(N12.EQ.24)THEN
8444           LB(I2)=12
8445           E(I2)=DM
8446          LB(I1)=2
8447          E(I1)=AMN
8448          go to 200
8449           ENDIF
8450 *25 N*(+)+N*(+)--> N*(0)(15)+P
8451           IF(N12.EQ.25)THEN
8452           LB(I2)=12
8453           E(I2)=DM
8454          LB(I1)=1
8455          E(I1)=AMP
8456          go to 200
8457           ENDIF
8458 *26 N*(0)+N*(0)--> N*(0)(15)+N
8459           IF(N12.EQ.26)THEN
8460           LB(I2)=12
8461           E(I2)=DM
8462          LB(I1)=2
8463          E(I1)=AMN
8464          go to 200
8465           ENDIF
8466 *27 N*(+)+N*(0)--> N*(+)(15)+N
8467           IF(N12.EQ.27)THEN
8468           IF(RANART(NSEED).LE.0.5)THEN
8469           LB(I2)=13
8470           E(I2)=DM
8471          LB(I1)=2
8472          E(I1)=AMN
8473           ELSE
8474           LB(I1)=13
8475           E(I1)=DM
8476          LB(I2)=2
8477          E(I2)=AMN
8478           ENDIF
8479          go to 200
8480           ENDIF
8481 *28 N*(+)+N*(0)--> N*(0)(15)+P
8482           IF(N12.EQ.28)THEN
8483           IF(RANART(NSEED).LE.0.5)THEN
8484           LB(I2)=12
8485           E(I2)=DM
8486          LB(I1)=1
8487          E(I1)=AMP
8488           ELSE
8489           LB(I1)=12
8490           E(I1)=DM
8491          LB(I2)=1
8492          E(I2)=AMP
8493           ENDIF
8494          go to 200
8495           ENDIF
8496 *27 N*(+)+N*(0)--> N*(+)(15)+N
8497           IF(N12.EQ.27)THEN
8498           IF(RANART(NSEED).LE.0.5)THEN
8499           LB(I2)=13
8500           E(I2)=DM
8501          LB(I1)=2
8502          E(I1)=AMN
8503           ELSE
8504           LB(I1)=13
8505           E(I1)=DM
8506          LB(I2)=2
8507          E(I2)=AMN
8508           ENDIF
8509          go to 200
8510           ENDIF
8511 *29 N*(+)+D(+)--> N*(+)(15)+P
8512           IF(N12.EQ.29)THEN
8513           IF(RANART(NSEED).LE.0.5)THEN
8514           LB(I2)=13
8515           E(I2)=DM
8516          LB(I1)=1
8517          E(I1)=AMP
8518           ELSE
8519           LB(I1)=13
8520           E(I1)=DM
8521          LB(I2)=1
8522          E(I2)=AMP
8523           ENDIF
8524          go to 200
8525           ENDIF
8526 *30 N*(+)+D(0)--> N*(+)(15)+N
8527           IF(N12.EQ.30)THEN
8528           IF(RANART(NSEED).LE.0.5)THEN
8529           LB(I2)=13
8530           E(I2)=DM
8531          LB(I1)=2
8532          E(I1)=AMN
8533           ELSE
8534           LB(I1)=13
8535           E(I1)=DM
8536          LB(I2)=2
8537          E(I2)=AMN
8538           ENDIF
8539          go to 200
8540           ENDIF
8541 *31 N*(+)+D(-)--> N*(0)(15)+N
8542           IF(N12.EQ.31)THEN
8543           IF(RANART(NSEED).LE.0.5)THEN
8544           LB(I2)=12
8545           E(I2)=DM
8546          LB(I1)=2
8547          E(I1)=AMN
8548           ELSE
8549           LB(I1)=12
8550           E(I1)=DM
8551          LB(I2)=2
8552          E(I2)=AMN
8553           ENDIF
8554          go to 200
8555           ENDIF
8556 *32 N*(0)+D(++)--> N*(+)(15)+P
8557           IF(N12.EQ.32)THEN
8558           IF(RANART(NSEED).LE.0.5)THEN
8559           LB(I2)=13
8560           E(I2)=DM
8561          LB(I1)=1
8562          E(I1)=AMP
8563           ELSE
8564           LB(I1)=13
8565           E(I1)=DM
8566          LB(I2)=1
8567          E(I2)=AMP
8568           ENDIF
8569          go to 200
8570           ENDIF
8571 *33 N*(0)+D(+)--> N*(+)(15)+N
8572           IF(N12.EQ.33)THEN
8573           IF(RANART(NSEED).LE.0.5)THEN
8574           LB(I2)=13
8575           E(I2)=DM
8576          LB(I1)=2
8577          E(I1)=AMN
8578           ELSE
8579           LB(I1)=13
8580           E(I1)=DM
8581          LB(I2)=2
8582          E(I2)=AMN
8583           ENDIF
8584          go to 200
8585           ENDIF
8586 *34 N*(0)+D(+)--> N*(0)(15)+P
8587           IF(N12.EQ.34)THEN
8588           IF(RANART(NSEED).LE.0.5)THEN
8589           LB(I2)=12
8590           E(I2)=DM
8591          LB(I1)=1
8592          E(I1)=AMP
8593           ELSE
8594           LB(I1)=12
8595           E(I1)=DM
8596          LB(I2)=1
8597          E(I2)=AMP
8598           ENDIF
8599          go to 200
8600           ENDIF
8601 *35 N*(0)+D(0)--> N*(0)(15)+N
8602           IF(N12.EQ.35)THEN
8603           IF(RANART(NSEED).LE.0.5)THEN
8604           LB(I2)=12
8605           E(I2)=DM
8606          LB(I1)=2
8607          E(I1)=AMN
8608           ELSE
8609           LB(I1)=12
8610           E(I1)=DM
8611          LB(I2)=2
8612          E(I2)=AMN
8613           ENDIF
8614          go to 200
8615           ENDIF
8616 *36 N*(+)+D(0)--> N*(0)(15)+P
8617           IF(N12.EQ.36)THEN
8618           IF(RANART(NSEED).LE.0.5)THEN
8619           LB(I2)=12
8620           E(I2)=DM
8621          LB(I1)=1
8622          E(I1)=AMP
8623           ELSE
8624           LB(I1)=12
8625           E(I1)=DM
8626          LB(I2)=1
8627          E(I2)=AMP
8628           ENDIF
8629          go to 200
8630           ENDIF
8631 1012         continue
8632          iblock=55
8633          lb1=lb(i1)
8634          lb2=lb(i2)
8635          ich=iabs(lb1*lb2)
8636 *-------------------------------------------------------
8637 * RELABLE BARYON I1 AND I2 in the reabsorption processes
8638 *37 D(++)+D(-)--> n+p
8639           IF(ich.EQ.9*6)THEN
8640           IF(RANART(NSEED).LE.0.5)THEN
8641           LB(I2)=1
8642           E(I2)=amp
8643          LB(I1)=2
8644          E(I1)=AMN
8645           ELSE
8646           LB(I1)=1
8647           E(I1)=amp
8648          LB(I2)=2
8649          E(I2)=AMN
8650           ENDIF
8651          go to 200
8652           ENDIF
8653 *38 D(+)+D(0)--> n+p
8654           IF(ich.EQ.8*7)THEN
8655           IF(RANART(NSEED).LE.0.5)THEN
8656           LB(I2)=1
8657           E(I2)=amp
8658          LB(I1)=2
8659          E(I1)=AMN
8660           ELSE
8661           LB(I1)=1
8662           E(I1)=amp
8663          LB(I2)=2
8664          E(I2)=AMN
8665           ENDIF
8666          go to 200
8667           ENDIF
8668 *39 D(++)+D(0)--> p+p
8669           IF(ich.EQ.9*7)THEN
8670           LB(I2)=1
8671           E(I2)=amp
8672          LB(I1)=1
8673          E(I1)=AMP
8674          go to 200
8675           ENDIF
8676 *40 D(+)+D(+)--> p+p
8677           IF(ich.EQ.8*8)THEN
8678           LB(I2)=1
8679           E(I2)=amp
8680          LB(I1)=1
8681          E(I1)=AMP
8682           go to 200
8683           ENDIF
8684 *41 D(+)+D(-)--> n+n
8685           IF(ich.EQ.8*6)THEN
8686           LB(I2)=2
8687           E(I2)=amn
8688          LB(I1)=2
8689          E(I1)=AMN
8690           go to 200
8691           ENDIF
8692 *42 D(0)+D(0)--> n+n
8693           IF(ich.EQ.6*6)THEN
8694           LB(I2)=2
8695           E(I2)=amn
8696          LB(I1)=2
8697          E(I1)=AMN
8698          go to 200
8699           ENDIF
8700 *43 N*(+)+N*(+)--> p+p
8701           IF(ich.EQ.11*11.or.ich.eq.13*13.or.ich.eq.11*13)THEN
8702           LB(I2)=1
8703           E(I2)=amp
8704          LB(I1)=1
8705          E(I1)=AMP
8706          go to 200
8707           ENDIF
8708 *44 N*(0)(1440)+N*(0)--> n+n
8709           IF(ich.EQ.10*10.or.ich.eq.12*12.or.ich.eq.10*12)THEN
8710           LB(I2)=2
8711           E(I2)=amn
8712          LB(I1)=2
8713          E(I1)=AMN
8714          go to 200
8715           ENDIF
8716 *45 N*(+)+N*(0)--> n+p
8717           IF(ich.EQ.10*11.or.ich.eq.12*13.or.ich.
8718      &    eq.10*13.or.ich.eq.11*12)THEN
8719           IF(RANART(NSEED).LE.0.5)THEN
8720           LB(I2)=1
8721           E(I2)=amp
8722          LB(I1)=2
8723          E(I1)=AMN
8724           ELSE
8725           LB(I1)=1
8726           E(I1)=amp
8727          LB(I2)=2
8728          E(I2)=AMN
8729           ENDIF
8730          go to 200
8731           ENDIF
8732 *46 N*(+)+D(+)--> p+p
8733           IF(ich.eq.11*8.or.ich.eq.13*8)THEN
8734           LB(I2)=1
8735           E(I2)=amp
8736          LB(I1)=1
8737          E(I1)=AMP
8738           go to 200
8739           ENDIF
8740 *47 N*(+)+D(0)--> n+p
8741           IF(ich.EQ.11*7.or.ich.eq.13*7)THEN
8742           IF(RANART(NSEED).LE.0.5)THEN
8743           LB(I2)=1
8744           E(I2)=amp
8745          LB(I1)=2
8746          E(I1)=AMN
8747           ELSE
8748           LB(I1)=1
8749           E(I1)=amp
8750          LB(I2)=2
8751          E(I2)=AMN
8752           ENDIF
8753          go to 200
8754           ENDIF
8755 *48 N*(+)+D(-)--> n+n
8756           IF(ich.EQ.11*6.or.ich.eq.13*6)THEN
8757           LB(I2)=2
8758           E(I2)=amn
8759          LB(I1)=2
8760          E(I1)=AMN
8761           go to 200
8762           ENDIF
8763 *49 N*(0)+D(++)--> p+p
8764           IF(ich.EQ.10*9.or.ich.eq.12*9)THEN
8765           LB(I2)=1
8766           E(I2)=amp
8767          LB(I1)=1
8768          E(I1)=AMP
8769          go to 200
8770           ENDIF
8771 *50 N*(0)+D(0)--> n+n
8772           IF(ich.EQ.10*7.or.ich.eq.12*7)THEN
8773           LB(I2)=2
8774           E(I2)=amn
8775          LB(I1)=2
8776          E(I1)=AMN
8777           go to 200
8778           ENDIF
8779 *51 N*(0)+D(+)--> n+p
8780           IF(ich.EQ.10*8.or.ich.eq.12*8)THEN
8781           IF(RANART(NSEED).LE.0.5)THEN
8782           LB(I2)=2
8783           E(I2)=amn
8784          LB(I1)=1
8785          E(I1)=AMP
8786           ELSE
8787           LB(I1)=2
8788           E(I1)=amn
8789          LB(I2)=1
8790          E(I2)=AMP
8791           ENDIF
8792          go to 200
8793           ENDIF
8794          lb(i1)=1
8795          e(i1)=amp
8796          lb(i2)=2
8797          e(i2)=amn
8798 * CALCULATE THE MAGNITUDE OF THE FINAL MOMENTUM THROUGH
8799 * ENERGY CONSERVATION
8800 * resonance production or absorption in resonance+resonance collisions is
8801 * assumed to have the same pt distribution as pp
8802 200       EM1=E(I1)
8803           EM2=E(I2)
8804           PR2   = (SRT**2 - EM1**2 - EM2**2)**2
8805      1                - 4.0 * (EM1*EM2)**2
8806           IF(PR2.LE.0.)PR2=1.e-09
8807           PR=SQRT(PR2)/(2.*SRT)
8808              if(srt.le.2.14)C1= 1.0 - 2.0 * RANART(NSEED)
8809          if(srt.gt.2.14.and.srt.le.2.4)c1=ang(srt,iseed)
8810          if(srt.gt.2.4)then
8811
8812 clin-10/25/02 get rid of argument usage mismatch in PTR():
8813              xptr=0.33*pr
8814 c         cc1=ptr(0.33*pr,iseed)
8815          cc1=ptr(xptr,iseed)
8816 clin-10/25/02-end
8817
8818          c1=sqrt(pr**2-cc1**2)/pr
8819          endif
8820           T1   = 2.0 * PI * RANART(NSEED)
8821        if(ianti.eq.1 .and. lb(i1).ge.1 .and. lb(i2).ge.1)then
8822          lb(i1) = -lb(i1)
8823          lb(i2) = -lb(i2)
8824        endif
8825          ENDIF
8826 *COM: SET THE NEW MOMENTUM COORDINATES
8827 107   S1   = SQRT( 1.0 - C1**2 )
8828       S2  =  SQRT( 1.0 - C2**2 )
8829       CT1  = COS(T1)
8830       ST1  = SIN(T1)
8831       CT2  = COS(T2)
8832       ST2  = SIN(T2)
8833       PZ   = PR * ( C1*C2 - S1*S2*CT1 )
8834       SS   = C2 * S1 * CT1  +  S2 * C1
8835       PX   = PR * ( SS*CT2 - S1*ST1*ST2 )
8836       PY   = PR * ( SS*ST2 + S1*ST1*CT2 )
8837       RETURN
8838 * FOR THE DD-->KAON+X PROCESS, FIND MOMENTUM OF THE FINAL PARTICLES IN
8839 * THE NUCLEUS-NUCLEUS CMS.
8840 306     CONTINUE
8841 csp11/21/01 phi production
8842               if(XSK5/sigK.gt.RANART(NSEED))then
8843               pz1=p(3,i1)
8844               pz2=p(3,i2)
8845                 LB(I1) = 1 + int(2 * RANART(NSEED))
8846                 LB(I2) = 1 + int(2 * RANART(NSEED))
8847               nnn=nnn+1
8848                 LPION(NNN,IRUN)=29
8849                 EPION(NNN,IRUN)=APHI
8850                 iblock = 222
8851               GO TO 208
8852                ENDIF
8853               iblock=10
8854                 if(ianti .eq. 1)iblock=-10
8855               pz1=p(3,i1)
8856               pz2=p(3,i2)
8857 * DETERMINE THE CHARGE STATES OF PARTICLES IN THE FINAL STATE
8858               nnn=nnn+1
8859                 LPION(NNN,IRUN)=23
8860                 EPION(NNN,IRUN)=Aka
8861               if(srt.le.2.63)then
8862 * only lambda production is possible
8863 * (1.1)P+P-->p+L+kaon+
8864               ic=1
8865                 LB(I1) = 1 + int(2 * RANART(NSEED))
8866               LB(I2)=14
8867               GO TO 208
8868                 ENDIF
8869        if(srt.le.2.74.and.srt.gt.2.63)then
8870 * both Lambda and sigma production are possible
8871               if(XSK1/(XSK1+XSK2).gt.RANART(NSEED))then
8872 * lambda production
8873               ic=1
8874                 LB(I1) = 1 + int(2 * RANART(NSEED))
8875               LB(I2)=14
8876               else
8877 * sigma production
8878                 LB(I1) = 1 + int(2 * RANART(NSEED))
8879                 LB(I2) = 15 + int(3 * RANART(NSEED))
8880               ic=2
8881               endif
8882               GO TO 208
8883        endif
8884        if(srt.le.2.77.and.srt.gt.2.74)then
8885 * then pp-->Delta lamda kaon can happen
8886               if(xsk1/(xsk1+xsk2+xsk3).gt.RANART(NSEED))then
8887 * * (1.1)P+P-->p+L+kaon+
8888               ic=1
8889                 LB(I1) = 1 + int(2 * RANART(NSEED))
8890               LB(I2)=14
8891               go to 208
8892               else
8893               if(xsk2/(xsk2+xsk3).gt.RANART(NSEED))then
8894 * pp-->psk
8895               ic=2
8896                 LB(I1) = 1 + int(2 * RANART(NSEED))
8897                 LB(I2) = 15 + int(3 * RANART(NSEED))
8898               else
8899 * pp-->D+l+k
8900               ic=3
8901                 LB(I1) = 6 + int(4 * RANART(NSEED))
8902               lb(i2)=14
8903               endif
8904               GO TO 208
8905               endif
8906        endif
8907        if(srt.gt.2.77)then
8908 * all four channels are possible
8909               if(xsk1/(xsk1+xsk2+xsk3+xsk4).gt.RANART(NSEED))then
8910 * p lambda k production
8911               ic=1
8912                 LB(I1) = 1 + int(2 * RANART(NSEED))
8913               LB(I2)=14
8914               go to 208
8915        else
8916           if(xsk3/(xsk2+xsk3+xsk4).gt.RANART(NSEED))then
8917 * delta l K production
8918               ic=3
8919                 LB(I1) = 6 + int(4 * RANART(NSEED))
8920               lb(i2)=14
8921               go to 208
8922           else
8923               if(xsk2/(xsk2+xsk4).gt.RANART(NSEED))then
8924 * n sigma k production
8925                 LB(I1) = 1 + int(2 * RANART(NSEED))
8926                 LB(I2) = 15 + int(3 * RANART(NSEED))
8927               ic=2
8928               else
8929 * D sigma K
8930               ic=4
8931                 LB(I1) = 6 + int(4 * RANART(NSEED))
8932                 LB(I2) = 15 + int(3 * RANART(NSEED))
8933               endif
8934               go to 208
8935           endif
8936        endif
8937        endif
8938 208             continue
8939          if(ianti.eq.1 .and. lb(i1).ge.1 .and. lb(i2).ge.1)then
8940           lb(i1) = - lb(i1)
8941           lb(i2) = - lb(i2)
8942           if(LPION(NNN,IRUN) .eq. 23)LPION(NNN,IRUN)=21
8943          endif
8944        lbi1=lb(i1)
8945        lbi2=lb(i2)
8946 * KEEP ALL COORDINATES OF PARTICLE 2 FOR POSSIBLE PHASE SPACE CHANGE
8947            NTRY1=0
8948 129        CALL BBKAON(ic,SRT,PX3,PY3,PZ3,DM3,PX4,PY4,PZ4,DM4,
8949      &  PPX,PPY,PPZ,icou1)
8950        NTRY1=NTRY1+1
8951        if((icou1.lt.0).AND.(NTRY1.LE.20))GO TO 129
8952 c       if(icou1.lt.0)return
8953 * ROTATE THE MOMENTA OF PARTICLES IN THE CMS OF P1+P2
8954        CALL ROTATE(PX,PY,PZ,PX3,PY3,PZ3)
8955        CALL ROTATE(PX,PY,PZ,PX4,PY4,PZ4)
8956        CALL ROTATE(PX,PY,PZ,PPX,PPY,PPZ)
8957 * FIND THE MOMENTUM OF PARTICLES IN THE FINAL STATE IN THE NUCLEUS-
8958 * NUCLEUS CMS. FRAME
8959 * (1) for the necleon/delta
8960 *             LORENTZ-TRANSFORMATION INTO LAB FRAME FOR DELTA1
8961               E1CM    = SQRT (dm3**2 + PX3**2 + PY3**2 + PZ3**2)
8962               P1BETA  = PX3*BETAX + PY3*BETAY + PZ3*BETAZ
8963               TRANSF  = GAMMA * ( GAMMA * P1BETA / (GAMMA + 1) + E1CM )
8964               Pt1i1 = BETAX * TRANSF + PX3
8965               Pt2i1 = BETAY * TRANSF + PY3
8966               Pt3i1 = BETAZ * TRANSF + PZ3
8967              Eti1   = DM3
8968 * (2) for the lambda/sigma
8969                 E2CM    = SQRT (dm4**2 + PX4**2 + PY4**2 + PZ4**2)
8970                 P2BETA  = PX4*BETAX+PY4*BETAY+PZ4*BETAZ
8971                 TRANSF  = GAMMA * (GAMMA*P2BETA / (GAMMA + 1.) + E2CM)
8972                 Pt1I2 = BETAX * TRANSF + PX4
8973                 Pt2I2 = BETAY * TRANSF + PY4
8974                 Pt3I2 = BETAZ * TRANSF + PZ4
8975               EtI2   = DM4
8976 * GET the kaon'S MOMENTUM AND COORDINATES IN NUCLEUS-NUCLEUS CMS. FRAME
8977                 EPCM=SQRT(aka**2+PPX**2+PPY**2+PPZ**2)
8978                 PPBETA=PPX*BETAX+PPY*BETAY+PPZ*BETAZ
8979                 TRANSF=GAMMA*(GAMMA*PPBETA/(GAMMA+1.)+EPCM)
8980                 PPION(1,NNN,IRUN)=BETAX*TRANSF+PPX
8981                 PPION(2,NNN,IRUN)=BETAY*TRANSF+PPY
8982                 PPION(3,NNN,IRUN)=BETAZ*TRANSF+PPZ
8983 clin-5/2008:
8984                 dppion(nnn,irun)=dpertp(i1)*dpertp(i2)
8985 clin-5/2008:
8986 c2007        X01 = 1.0 - 2.0 * RANART(NSEED)
8987 c            Y01 = 1.0 - 2.0 * RANART(NSEED)
8988 c            Z01 = 1.0 - 2.0 * RANART(NSEED)
8989 c        IF ((X01*X01+Y01*Y01+Z01*Z01) .GT. 1.0) GOTO 2007
8990 c                RPION(1,NNN,IRUN)=R(1,I1)+0.5*x01
8991 c                RPION(2,NNN,IRUN)=R(2,I1)+0.5*y01
8992 c                RPION(3,NNN,IRUN)=R(3,I1)+0.5*z01
8993                     RPION(1,NNN,IRUN)=R(1,I1)
8994                     RPION(2,NNN,IRUN)=R(2,I1)
8995                     RPION(3,NNN,IRUN)=R(3,I1)
8996 c
8997 * assign the nucleon/delta and lambda/sigma to i1 or i2 to keep the
8998 * leadng particle behaviour
8999 C              if((pt1i1*px1+pt2i1*py1+pt3i1*pz1).gt.0)then
9000               p(1,i1)=pt1i1
9001               p(2,i1)=pt2i1
9002               p(3,i1)=pt3i1
9003               e(i1)=eti1
9004               lb(i1)=lbi1
9005               p(1,i2)=pt1i2
9006               p(2,i2)=pt2i2
9007               p(3,i2)=pt3i2
9008               e(i2)=eti2
9009               lb(i2)=lbi2
9010                 PX1     = P(1,I1)
9011                 PY1     = P(2,I1)
9012                 PZ1     = P(3,I1)
9013               EM1       = E(I1)
9014                 ID(I1)  = 2
9015                 ID(I2)  = 2
9016                 ID1     = ID(I1)
9017         LB1=LB(I1)
9018         LB2=LB(I2)
9019         AM1=EM1
9020        am2=em2
9021         E1= SQRT( EM1**2 + PX1**2 + PY1**2 + PZ1**2 )
9022        RETURN
9023
9024 clin-6/2008 D+D->Deuteron+pi:
9025 *     FIND MOMENTUM OF THE FINAL PARTICLES IN THE NUCLEUS-NUCLEUS CMS.
9026  108   CONTINUE
9027            if(idpert.eq.1.and.ipert1.eq.1.and.npertd.ge.1) then
9028 c     For idpert=1: we produce npertd pert deuterons:
9029               ndloop=npertd
9030            elseif(idpert.eq.2.and.npertd.ge.1) then
9031 c     For idpert=2: we first save information for npertd pert deuterons;
9032 c     at the last ndloop we create the regular deuteron+pi
9033 c     and those pert deuterons:
9034               ndloop=npertd+1
9035            else
9036 c     Just create the regular deuteron+pi:
9037               ndloop=1
9038            endif
9039 c
9040            dprob1=sdprod/sig/float(npertd)
9041            do idloop=1,ndloop
9042               CALL bbdangle(pxd,pyd,pzd,nt,ipert1,ianti,idloop,pfinal,
9043      1 dprob1,lbm)
9044               CALL ROTATE(PX,PY,PZ,PXd,PYd,PZd)
9045 *     LORENTZ-TRANSFORMATION OF THE MOMENTUM OF PARTICLES IN THE FINAL STATE
9046 *     FROM THE NN CMS FRAME INTO THE GLOBAL CMS FRAME:
9047 *     For the Deuteron:
9048               xmass=xmd
9049               E1dCM=SQRT(xmass**2+PXd**2+PYd**2+PZd**2)
9050               P1dBETA=PXd*BETAX+PYd*BETAY+PZd*BETAZ
9051               TRANSF=GAMMA*(GAMMA*P1dBETA/(GAMMA+1.)+E1dCM)
9052               pxi1=BETAX*TRANSF+PXd
9053               pyi1=BETAY*TRANSF+PYd
9054               pzi1=BETAZ*TRANSF+PZd
9055               if(ianti.eq.0)then
9056                  lbd=42
9057               else
9058                  lbd=-42
9059               endif
9060               if(idpert.eq.1.and.ipert1.eq.1.and.npertd.ge.1) then
9061 cccc  Perturbative production for idpert=1:
9062                  nnn=nnn+1
9063                  PPION(1,NNN,IRUN)=pxi1
9064                  PPION(2,NNN,IRUN)=pyi1
9065                  PPION(3,NNN,IRUN)=pzi1
9066                  EPION(NNN,IRUN)=xmd
9067                  LPION(NNN,IRUN)=lbd
9068                  RPION(1,NNN,IRUN)=R(1,I1)
9069                  RPION(2,NNN,IRUN)=R(2,I1)
9070                  RPION(3,NNN,IRUN)=R(3,I1)
9071 clin-6/2008 assign the perturbative probability:
9072                  dppion(NNN,IRUN)=sdprod/sig/float(npertd)
9073               elseif(idpert.eq.2.and.idloop.le.npertd) then
9074 clin-6/2008 For idpert=2, we produce NPERTD perturbative (anti)deuterons
9075 c     only when a regular (anti)deuteron+pi is produced in NN collisions.
9076 c     First save the info for the perturbative deuterons:
9077                  ppd(1,idloop)=pxi1
9078                  ppd(2,idloop)=pyi1
9079                  ppd(3,idloop)=pzi1
9080                  lbpd(idloop)=lbd
9081               else
9082 cccc  Regular production:
9083 c     For the regular pion: do LORENTZ-TRANSFORMATION:
9084                  E(i1)=xmm
9085                  E2piCM=SQRT(xmm**2+PXd**2+PYd**2+PZd**2)
9086                  P2piBETA=-PXd*BETAX-PYd*BETAY-PZd*BETAZ
9087                  TRANSF=GAMMA*(GAMMA*P2piBETA/(GAMMA+1.)+E2piCM)
9088                  pxi2=BETAX*TRANSF-PXd
9089                  pyi2=BETAY*TRANSF-PYd
9090                  pzi2=BETAZ*TRANSF-PZd
9091                  p(1,i1)=pxi2
9092                  p(2,i1)=pyi2
9093                  p(3,i1)=pzi2
9094 c     Remove regular pion to check the equivalence
9095 c     between the perturbative and regular deuteron results:
9096 c                 E(i1)=0.
9097 c
9098                  LB(I1)=lbm
9099                  PX1=P(1,I1)
9100                  PY1=P(2,I1)
9101                  PZ1=P(3,I1)
9102                  EM1=E(I1)
9103                  ID(I1)=2
9104                  ID1=ID(I1)
9105                  E1=SQRT(EM1**2+PX1**2+PY1**2+PZ1**2)
9106                  lb1=lb(i1)
9107 c     For the regular deuteron:
9108                  p(1,i2)=pxi1
9109                  p(2,i2)=pyi1
9110                  p(3,i2)=pzi1
9111                  lb(i2)=lbd
9112                  lb2=lb(i2)
9113                  E(i2)=xmd
9114                  EtI2=E(I2)
9115                  ID(I2)=2
9116 c     For idpert=2: create the perturbative deuterons:
9117                  if(idpert.eq.2.and.idloop.eq.ndloop) then
9118                     do ipertd=1,npertd
9119                        nnn=nnn+1
9120                        PPION(1,NNN,IRUN)=ppd(1,ipertd)
9121                        PPION(2,NNN,IRUN)=ppd(2,ipertd)
9122                        PPION(3,NNN,IRUN)=ppd(3,ipertd)
9123                        EPION(NNN,IRUN)=xmd
9124                        LPION(NNN,IRUN)=lbpd(ipertd)
9125                        RPION(1,NNN,IRUN)=R(1,I1)
9126                        RPION(2,NNN,IRUN)=R(2,I1)
9127                        RPION(3,NNN,IRUN)=R(3,I1)
9128 clin-6/2008 assign the perturbative probability:
9129                        dppion(NNN,IRUN)=1./float(npertd)
9130                     enddo
9131                  endif
9132               endif
9133            enddo
9134            IBLOCK=501
9135            return
9136 clin-6/2008 D+D->Deuteron+pi over
9137
9138         END
9139 **********************************
9140 **********************************
9141 *                                                                      *
9142       SUBROUTINE INIT(MINNUM,MAXNUM,NUM,RADIUS,X0,Z0,P0,
9143      &                GAMMA,ISEED,MASS,IOPT)
9144 *                                                                      *
9145 *       PURPOSE:     PROVIDING INITIAL CONDITIONS FOR PHASE-SPACE      *
9146 *                    DISTRIBUTION OF TESTPARTICLES                     *
9147 *       VARIABLES:   (ALL INPUT)                                       *
9148 *         MINNUM  - FIRST TESTPARTICLE TREATED IN ONE RUN    (INTEGER) *
9149 *         MAXNUM  - LAST TESTPARTICLE TREATED IN ONE RUN     (INTEGER) *
9150 *         NUM     - NUMBER OF TESTPARTICLES PER NUCLEON      (INTEGER) *
9151 *         RADIUS  - RADIUS OF NUCLEUS "FM"                      (REAL) *
9152 *         X0,Z0   - DISPLACEMENT OF CENTER OF NUCLEUS IN X,Z-          *
9153 *                   DIRECTION "FM"                              (REAL) *
9154 *         P0      - MOMENTUM-BOOST IN C.M. FRAME "GEV/C"        (REAL) *
9155 *         GAMMA   - RELATIVISTIC GAMMA-FACTOR                   (REAL) *
9156 *         ISEED   - SEED FOR RANDOM-NUMBER GENERATOR         (INTEGER) *
9157 *         MASS    - TOTAL MASS OF THE SYSTEM                 (INTEGER) *
9158 *         IOPT    - OPTION FOR DIFFERENT OCCUPATION OF MOMENTUM        *
9159 *                   SPACE                                    (INTEGER) *
9160 *                                                                      *
9161 **********************************
9162       PARAMETER     (MAXSTR=150001,  AMU   = 0.9383)
9163       PARAMETER     (MAXX   =   20,  MAXZ  =    24)
9164       PARAMETER     (PI=3.1415926)
9165 *
9166       REAL              PTOT(3)
9167       COMMON  /AA/      R(3,MAXSTR)
9168 cc      SAVE /AA/
9169       COMMON  /BB/      P(3,MAXSTR)
9170 cc      SAVE /BB/
9171       COMMON  /CC/      E(MAXSTR)
9172 cc      SAVE /CC/
9173       COMMON  /DD/      RHO(-MAXX:MAXX,-MAXX:MAXX,-MAXZ:MAXZ),
9174      &                     RHOP(-MAXX:MAXX,-MAXX:MAXX,-MAXZ:MAXZ),
9175      &                     RHON(-MAXX:MAXX,-MAXX:MAXX,-MAXZ:MAXZ)
9176 cc      SAVE /DD/
9177       COMMON  /EE/      ID(MAXSTR),LB(MAXSTR)
9178 cc      SAVE /EE/
9179       common  /ss/      inout(20)
9180 cc      SAVE /ss/
9181       COMMON/RNDF77/NSEED
9182 cc      SAVE /RNDF77/
9183       SAVE
9184 *----------------------------------------------------------------------
9185 *     PREPARATION FOR LORENTZ-TRANSFORMATIONS
9186 *
9187       ISEED=ISEED
9188       IF (P0 .NE. 0.) THEN
9189         SIGN = P0 / ABS(P0)
9190       ELSE
9191         SIGN = 0.
9192       END IF
9193       BETA = SIGN * SQRT(GAMMA**2-1.)/GAMMA
9194 *-----------------------------------------------------------------------
9195 *     TARGET-ID = 1 AND PROJECTILE-ID = -1
9196 *
9197       IF (MINNUM .EQ. 1) THEN
9198         IDNUM = 1
9199       ELSE
9200         IDNUM = -1
9201       END IF
9202 *-----------------------------------------------------------------------
9203 *     IDENTIFICATION OF TESTPARTICLES AND ASSIGMENT OF RESTMASS
9204 *
9205 *     LOOP OVER ALL PARALLEL RUNS:
9206       DO 400 IRUN = 1,NUM
9207         DO 100 I = MINNUM+(IRUN-1)*MASS,MAXNUM+(IRUN-1)*MASS
9208           ID(I) = IDNUM
9209           E(I)  = AMU
9210   100   CONTINUE
9211 *-----------------------------------------------------------------------
9212 *       OCCUPATION OF COORDINATE-SPACE
9213 *
9214         DO 300 I = MINNUM+(IRUN-1)*MASS,MAXNUM+(IRUN-1)*MASS
9215   200     CONTINUE
9216             X = 1.0 - 2.0 * RANART(NSEED)
9217             Y = 1.0 - 2.0 * RANART(NSEED)
9218             Z = 1.0 - 2.0 * RANART(NSEED)
9219           IF ((X*X+Y*Y+Z*Z) .GT. 1.0) GOTO 200
9220           R(1,I) = X * RADIUS
9221           R(2,I) = Y * RADIUS
9222           R(3,I) = Z * RADIUS
9223   300   CONTINUE
9224   400 CONTINUE
9225 *=======================================================================
9226       IF (IOPT .NE. 3) THEN
9227 *-----
9228 *     OPTION 1: USE WOODS-SAXON PARAMETRIZATION FOR DENSITY AND
9229 *-----          CALCULATE LOCAL FERMI-MOMENTUM
9230 *
9231         RHOW0  = 0.168
9232         DO 1000 IRUN = 1,NUM
9233           DO 600 I = MINNUM+(IRUN-1)*MASS,MAXNUM+(IRUN-1)*MASS
9234   500       CONTINUE
9235               PX = 1.0 - 2.0 * RANART(NSEED)
9236               PY = 1.0 - 2.0 * RANART(NSEED)
9237               PZ = 1.0 - 2.0 * RANART(NSEED)
9238             IF (PX*PX+PY*PY+PZ*PZ .GT. 1.0) GOTO 500
9239             RDIST  = SQRT( R(1,I)**2 + R(2,I)**2 + R(3,I)**2 )
9240             RHOWS  = RHOW0 / (  1.0 + EXP( (RDIST-RADIUS) / 0.55 )  )
9241             PFERMI = 0.197 * (1.5 * PI*PI * RHOWS)**(1./3.)
9242 *-----
9243 *     OPTION 2: NUCLEAR MATTER CASE
9244             IF(IOPT.EQ.2) PFERMI=0.27
9245            if(iopt.eq.4) pfermi=0.
9246 *-----
9247             P(1,I) = PFERMI * PX
9248             P(2,I) = PFERMI * PY
9249             P(3,I) = PFERMI * PZ
9250   600     CONTINUE
9251 *
9252 *         SET TOTAL MOMENTUM TO 0 IN REST FRAME AND BOOST
9253 *
9254           DO 700 IDIR = 1,3
9255             PTOT(IDIR) = 0.0
9256   700     CONTINUE
9257           NPART = 0
9258           DO 900 I = MINNUM+(IRUN-1)*MASS,MAXNUM+(IRUN-1)*MASS
9259             NPART = NPART + 1
9260             DO 800 IDIR = 1,3
9261               PTOT(IDIR) = PTOT(IDIR) + P(IDIR,I)
9262   800       CONTINUE
9263   900     CONTINUE
9264           DO 950 I = MINNUM+(IRUN-1)*MASS,MAXNUM+(IRUN-1)*MASS
9265             DO 925 IDIR = 1,3
9266               P(IDIR,I) = P(IDIR,I) - PTOT(IDIR) / FLOAT(NPART)
9267   925       CONTINUE
9268 *           BOOST
9269             IF ((IOPT .EQ. 1).or.(iopt.eq.2)) THEN
9270               EPART = SQRT(P(1,I)**2+P(2,I)**2+P(3,I)**2+AMU**2)
9271               P(3,I) = GAMMA*(P(3,I) + BETA*EPART)
9272             ELSE
9273               P(3,I) = P(3,I) + P0
9274             END IF
9275   950     CONTINUE
9276  1000   CONTINUE
9277 *-----
9278       ELSE
9279 *-----
9280 *     OPTION 3: GIVE ALL NUCLEONS JUST A Z-MOMENTUM ACCORDING TO
9281 *               THE BOOST OF THE NUCLEI
9282 *
9283         DO 1200 IRUN = 1,NUM
9284           DO 1100 I = MINNUM+(IRUN-1)*MASS,MAXNUM+(IRUN-1)*MASS
9285             P(1,I) = 0.0
9286             P(2,I) = 0.0
9287             P(3,I) = P0
9288  1100     CONTINUE
9289  1200   CONTINUE
9290 *-----
9291       END IF
9292 *=======================================================================
9293 *     PUT PARTICLES IN THEIR POSITION IN COORDINATE-SPACE
9294 *     (SHIFT AND RELATIVISTIC CONTRACTION)
9295 *
9296       DO 1400 IRUN = 1,NUM
9297         DO 1300 I = MINNUM+(IRUN-1)*MASS,MAXNUM+(IRUN-1)*MASS
9298           R(1,I) = R(1,I) + X0
9299 * two nuclei in touch after contraction
9300           R(3,I) = (R(3,I)+Z0)/ GAMMA
9301 * two nuclei in touch before contraction
9302 c          R(3,I) = R(3,I) / GAMMA + Z0
9303  1300   CONTINUE
9304  1400 CONTINUE
9305 *
9306       RETURN
9307       END
9308 **********************************
9309 *                                                                      *
9310       SUBROUTINE DENS(IPOT,MASS,NUM,NESC)
9311 *                                                                      *
9312 *       PURPOSE:     CALCULATION OF LOCAL BARYON, MESON AND ENERGY     *
9313 *                    DENSITY FROM SPATIAL DISTRIBUTION OF TESTPARTICLES*
9314 *                                                                      *
9315 *       VARIABLES (ALL INPUT, ALL INTEGER)                             *
9316 *         MASS    -  MASS NUMBER OF THE SYSTEM                         *
9317 *         NUM     -  NUMBER OF TESTPARTICLES PER NUCLEON               *
9318 *                                                                      *
9319 *         NESC    -  NUMBER OF ESCAPED PARTICLES      (INTEGER,OUTPUT) *
9320 *                                                                      *
9321 **********************************
9322       PARAMETER     (MAXSTR= 150001,MAXR=1)
9323       PARAMETER     (MAXX   =    20,  MAXZ  =    24)
9324 *
9325       dimension pxl(-maxx:maxx,-maxx:maxx,-maxz:maxz),
9326      1          pyl(-maxx:maxx,-maxx:maxx,-maxz:maxz),
9327      2          pzl(-maxx:maxx,-maxx:maxx,-maxz:maxz)
9328       COMMON  /AA/      R(3,MAXSTR)
9329 cc      SAVE /AA/
9330       COMMON  /BB/      P(3,MAXSTR)
9331 cc      SAVE /BB/
9332       COMMON  /CC/      E(MAXSTR)
9333 cc      SAVE /CC/
9334       COMMON  /DD/      RHO(-MAXX:MAXX,-MAXX:MAXX,-MAXZ:MAXZ),
9335      &                     RHOP(-MAXX:MAXX,-MAXX:MAXX,-MAXZ:MAXZ),
9336      &                     RHON(-MAXX:MAXX,-MAXX:MAXX,-MAXZ:MAXZ)
9337 cc      SAVE /DD/
9338       COMMON  /DDpi/    piRHO(-MAXX:MAXX,-MAXX:MAXX,-MAXZ:MAXZ)
9339 cc      SAVE /DDpi/
9340       COMMON  /EE/      ID(MAXSTR),LB(MAXSTR)
9341 cc      SAVE /EE/
9342       common  /ss/  inout(20)
9343 cc      SAVE /ss/
9344       COMMON  /RR/  MASSR(0:MAXR)
9345 cc      SAVE /RR/
9346       common  /tt/  PEL(-maxx:maxx,-maxx:maxx,-maxz:maxz)
9347      &,rxy(-maxx:maxx,-maxx:maxx,-maxz:maxz)
9348 cc      SAVE /tt/
9349       common  /bbb/ bxx(-maxx:maxx,-maxx:maxx,-maxz:maxz),
9350      &byy(-maxx:maxx,-maxx:maxx,-maxz:maxz),
9351      &bzz(-maxx:maxx,-maxx:maxx,-maxz:maxz)
9352 *
9353       real zet(-45:45)
9354       SAVE
9355       data zet /
9356      4     1.,0.,0.,0.,0.,
9357      3     1.,0.,0.,0.,0.,0.,0.,0.,0.,0.,
9358      2     -1.,0.,0.,0.,0.,0.,0.,0.,0.,0.,
9359      1     0.,0.,0.,-1.,0.,1.,0.,-1.,0.,-1.,
9360      s     0.,-2.,-1.,0.,1.,0.,0.,0.,0.,-1.,
9361      e     0.,
9362      s     1.,0.,-1.,0.,1.,-1.,0.,1.,2.,0.,
9363      1     1.,0.,1.,0.,-1.,0.,1.,0.,0.,0.,
9364      2     -1.,0.,1.,0.,-1.,0.,1.,0.,0.,1.,
9365      3     0.,0.,0.,0.,0.,0.,0.,0.,0.,-1.,
9366      4     0.,0.,0.,0.,-1./
9367
9368       DO 300 IZ = -MAXZ,MAXZ
9369         DO 200 IY = -MAXX,MAXX
9370           DO 100 IX = -MAXX,MAXX
9371             RHO(IX,IY,IZ) = 0.0
9372             RHOn(IX,IY,IZ) = 0.0
9373             RHOp(IX,IY,IZ) = 0.0
9374             piRHO(IX,IY,IZ) = 0.0
9375            pxl(ix,iy,iz) = 0.0
9376            pyl(ix,iy,iz) = 0.0
9377            pzl(ix,iy,iz) = 0.0
9378            pel(ix,iy,iz) = 0.0
9379            bxx(ix,iy,iz) = 0.0
9380            byy(ix,iy,iz) = 0.0
9381            bzz(ix,iy,iz) = 0.0
9382   100     CONTINUE
9383   200   CONTINUE
9384   300 CONTINUE
9385 *
9386       NESC  = 0
9387       BIG   = 1.0 / ( 3.0 * FLOAT(NUM) )
9388       SMALL = 1.0 / ( 9.0 * FLOAT(NUM) )
9389 *
9390       MSUM=0
9391       DO 400 IRUN = 1,NUM
9392       MSUM=MSUM+MASSR(IRUN-1)
9393       DO 400 J=1,MASSr(irun)
9394       I=J+MSUM
9395         IX = NINT( R(1,I) )
9396         IY = NINT( R(2,I) )
9397         IZ = NINT( R(3,I) )
9398         IF( IX .LE. -MAXX .OR. IX .GE. MAXX .OR.
9399      &      IY .LE. -MAXX .OR. IY .GE. MAXX .OR.
9400      &      IZ .LE. -MAXZ .OR. IZ .GE. MAXZ )    THEN
9401           NESC = NESC + 1
9402         ELSE
9403 c
9404 csp01/04/02 include baryon density
9405           if(j.gt.mass)go to 30
9406 c         if( (lb(i).eq.1.or.lb(i).eq.2) .or.
9407 c    &    (lb(i).ge.6.and.lb(i).le.17) )then
9408 * (1) baryon density
9409           RHO(IX,  IY,  IZ  ) = RHO(IX,  IY,  IZ  ) + BIG
9410           RHO(IX+1,IY,  IZ  ) = RHO(IX+1,IY,  IZ  ) + SMALL
9411           RHO(IX-1,IY,  IZ  ) = RHO(IX-1,IY,  IZ  ) + SMALL
9412           RHO(IX,  IY+1,IZ  ) = RHO(IX,  IY+1,IZ  ) + SMALL
9413           RHO(IX,  IY-1,IZ  ) = RHO(IX,  IY-1,IZ  ) + SMALL
9414           RHO(IX,  IY,  IZ+1) = RHO(IX,  IY,  IZ+1) + SMALL
9415           RHO(IX,  IY,  IZ-1) = RHO(IX,  IY,  IZ-1) + SMALL
9416 * (2) CALCULATE THE PROTON DENSITY
9417          IF(ZET(LB(I)).NE.0)THEN
9418           RHOP(IX,  IY,  IZ  ) = RHOP(IX,  IY,  IZ  ) + BIG
9419           RHOP(IX+1,IY,  IZ  ) = RHOP(IX+1,IY,  IZ  ) + SMALL
9420           RHOP(IX-1,IY,  IZ  ) = RHOP(IX-1,IY,  IZ  ) + SMALL
9421           RHOP(IX,  IY+1,IZ  ) = RHOP(IX,  IY+1,IZ  ) + SMALL
9422           RHOP(IX,  IY-1,IZ  ) = RHOP(IX,  IY-1,IZ  ) + SMALL
9423           RHOP(IX,  IY,  IZ+1) = RHOP(IX,  IY,  IZ+1) + SMALL
9424           RHOP(IX,  IY,  IZ-1) = RHOP(IX,  IY,  IZ-1) + SMALL
9425          go to 40
9426          ENDIF
9427 * (3) CALCULATE THE NEUTRON DENSITY
9428          IF(ZET(LB(I)).EQ.0)THEN
9429           RHON(IX,  IY,  IZ  ) = RHON(IX,  IY,  IZ  ) + BIG
9430           RHON(IX+1,IY,  IZ  ) = RHON(IX+1,IY,  IZ  ) + SMALL
9431           RHON(IX-1,IY,  IZ  ) = RHON(IX-1,IY,  IZ  ) + SMALL
9432           RHON(IX,  IY+1,IZ  ) = RHON(IX,  IY+1,IZ  ) + SMALL
9433           RHON(IX,  IY-1,IZ  ) = RHON(IX,  IY-1,IZ  ) + SMALL
9434           RHON(IX,  IY,  IZ+1) = RHON(IX,  IY,  IZ+1) + SMALL
9435           RHON(IX,  IY,  IZ-1) = RHON(IX,  IY,  IZ-1) + SMALL
9436          go to 40
9437           END IF
9438 c           else    !! sp01/04/02
9439 * (4) meson density
9440 30              piRHO(IX,  IY,  IZ  ) = piRHO(IX,  IY,  IZ  ) + BIG
9441           piRHO(IX+1,IY,  IZ  ) = piRHO(IX+1,IY,  IZ  ) + SMALL
9442           piRHO(IX-1,IY,  IZ  ) = piRHO(IX-1,IY,  IZ  ) + SMALL
9443           piRHO(IX,  IY+1,IZ  ) = piRHO(IX,  IY+1,IZ  ) + SMALL
9444           piRHO(IX,  IY-1,IZ  ) = piRHO(IX,  IY-1,IZ  ) + SMALL
9445           piRHO(IX,  IY,  IZ+1) = piRHO(IX,  IY,  IZ+1) + SMALL
9446           piRHO(IX,  IY,  IZ-1) = piRHO(IX,  IY,  IZ-1) + SMALL
9447 c           endif    !! sp01/04/02
9448 * to calculate the Gamma factor in each cell
9449 *(1) PX
9450 40       pxl(ix,iy,iz)=pxl(ix,iy,iz)+p(1,I)*BIG
9451        pxl(ix+1,iy,iz)=pxl(ix+1,iy,iz)+p(1,I)*SMALL
9452        pxl(ix-1,iy,iz)=pxl(ix-1,iy,iz)+p(1,I)*SMALL
9453        pxl(ix,iy+1,iz)=pxl(ix,iy+1,iz)+p(1,I)*SMALL
9454        pxl(ix,iy-1,iz)=pxl(ix,iy-1,iz)+p(1,I)*SMALL
9455        pxl(ix,iy,iz+1)=pxl(ix,iy,iz+1)+p(1,I)*SMALL
9456        pxl(ix,iy,iz-1)=pxl(ix,iy,iz-1)+p(1,I)*SMALL
9457 *(2) PY
9458        pYl(ix,iy,iz)=pYl(ix,iy,iz)+p(2,I)*BIG
9459        pYl(ix+1,iy,iz)=pYl(ix+1,iy,iz)+p(2,I)*SMALL
9460        pYl(ix-1,iy,iz)=pYl(ix-1,iy,iz)+p(2,I)*SMALL
9461        pYl(ix,iy+1,iz)=pYl(ix,iy+1,iz)+p(2,I)*SMALL
9462        pYl(ix,iy-1,iz)=pYl(ix,iy-1,iz)+p(2,I)*SMALL
9463        pYl(ix,iy,iz+1)=pYl(ix,iy,iz+1)+p(2,I)*SMALL
9464        pYl(ix,iy,iz-1)=pYl(ix,iy,iz-1)+p(2,I)*SMALL
9465 * (3) PZ
9466        pZl(ix,iy,iz)=pZl(ix,iy,iz)+p(3,I)*BIG
9467        pZl(ix+1,iy,iz)=pZl(ix+1,iy,iz)+p(3,I)*SMALL
9468        pZl(ix-1,iy,iz)=pZl(ix-1,iy,iz)+p(3,I)*SMALL
9469        pZl(ix,iy+1,iz)=pZl(ix,iy+1,iz)+p(3,I)*SMALL
9470        pZl(ix,iy-1,iz)=pZl(ix,iy-1,iz)+p(3,I)*SMALL
9471        pZl(ix,iy,iz+1)=pZl(ix,iy,iz+1)+p(3,I)*SMALL
9472        pZl(ix,iy,iz-1)=pZl(ix,iy,iz-1)+p(3,I)*SMALL
9473 * (4) ENERGY
9474        pel(ix,iy,iz)=pel(ix,iy,iz)
9475      1     +sqrt(e(I)**2+p(1,i)**2+p(2,I)**2+p(3,I)**2)*BIG
9476        pel(ix+1,iy,iz)=pel(ix+1,iy,iz)
9477      1     +sqrt(e(I)**2+p(1,i)**2+p(2,I)**2+p(3,I)**2)*SMALL
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,iy+1,iz)=pel(ix,iy+1,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,iz+1)=pel(ix,iy,iz+1)
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         END IF
9489   400 CONTINUE
9490 *
9491       DO 301 IZ = -MAXZ,MAXZ
9492         DO 201 IY = -MAXX,MAXX
9493           DO 101 IX = -MAXX,MAXX
9494       IF((RHO(IX,IY,IZ).EQ.0).OR.(PEL(IX,IY,IZ).EQ.0))
9495      1GO TO 101
9496       SMASS2=PEL(IX,IY,IZ)**2-PXL(IX,IY,IZ)**2
9497      1-PYL(IX,IY,IZ)**2-PZL(IX,IY,IZ)**2
9498        IF(SMASS2.LE.0)SMASS2=1.E-06
9499        SMASS=SQRT(SMASS2)
9500            IF(SMASS.EQ.0.)SMASS=1.e-06
9501            GAMMA=PEL(IX,IY,IZ)/SMASS
9502            if(gamma.eq.0)go to 101
9503        bxx(ix,iy,iz)=pxl(ix,iy,iz)/pel(ix,iy,iz)
9504        byy(ix,iy,iz)=pyl(ix,iy,iz)/pel(ix,iy,iz)
9505        bzz(ix,iy,iz)=pzl(ix,iy,iz)/pel(ix,iy,iz)
9506             RHO(IX,IY,IZ) = RHO(IX,IY,IZ)/GAMMA
9507             RHOn(IX,IY,IZ) = RHOn(IX,IY,IZ)/GAMMA
9508             RHOp(IX,IY,IZ) = RHOp(IX,IY,IZ)/GAMMA
9509             piRHO(IX,IY,IZ) = piRHO(IX,IY,IZ)/GAMMA
9510             pEL(IX,IY,IZ) = pEL(IX,IY,IZ)/(GAMMA**2)
9511            rho0=0.163
9512            IF(IPOT.EQ.0)THEN
9513            U=0
9514            GO TO 70
9515            ENDIF
9516            IF(IPOT.EQ.1.or.ipot.eq.6)THEN
9517            A=-0.1236
9518            B=0.0704
9519            S=2
9520            GO TO 60
9521            ENDIF
9522            IF(IPOT.EQ.2.or.ipot.eq.7)THEN
9523            A=-0.218
9524            B=0.164
9525            S=4./3.
9526            ENDIF
9527            IF(IPOT.EQ.3)THEN
9528            a=-0.3581
9529            b=0.3048
9530            S=1.167
9531            GO TO 60
9532            ENDIF
9533            IF(IPOT.EQ.4)THEN
9534            denr=rho(ix,iy,iz)/rho0
9535            b=0.3048
9536            S=1.167
9537            if(denr.le.4.or.denr.gt.7)then
9538            a=-0.3581
9539            else
9540            a=-b*denr**(1./6.)-2.*0.036/3.*denr**(-0.333)
9541            endif
9542            GO TO 60
9543            ENDIF
9544 60           U = 0.5*A*RHO(IX,IY,IZ)**2/RHO0
9545      1        + B/(1+S) * (RHO(IX,IY,IZ)/RHO0)**S*RHO(IX,IY,IZ)
9546 70           PEL(IX,IY,IZ)=PEL(IX,IY,IZ)+U
9547   101     CONTINUE
9548   201   CONTINUE
9549   301 CONTINUE
9550       RETURN
9551       END
9552
9553 **********************************
9554 *                                                                      *
9555       SUBROUTINE GRADU(IOPT,IX,IY,IZ,GRADX,GRADY,GRADZ)
9556 *                                                                      *
9557 *       PURPOSE:     DETERMINE GRAD(U(RHO(X,Y,Z)))                     *
9558 *       VARIABLES:                                                     *
9559 *         IOPT                - METHOD FOR EVALUATING THE GRADIENT     *
9560 *                                                      (INTEGER,INPUT) *
9561 *         IX, IY, IZ          - COORDINATES OF POINT   (INTEGER,INPUT) *
9562 *         GRADX, GRADY, GRADZ - GRADIENT OF U            (REAL,OUTPUT) *
9563 *                                                                      *
9564 **********************************
9565       PARAMETER         (MAXX =    20,  MAXZ =   24)
9566       PARAMETER         (RHO0 = 0.167)
9567 *
9568       COMMON  /DD/      RHO(-MAXX:MAXX,-MAXX:MAXX,-MAXZ:MAXZ),
9569      &                  RHOP(-MAXX:MAXX,-MAXX:MAXX,-MAXZ:MAXZ),
9570      &                  RHON(-MAXX:MAXX,-MAXX:MAXX,-MAXZ:MAXZ)
9571 cc      SAVE /DD/
9572       common  /ss/      inout(20)
9573 cc      SAVE /ss/
9574       common  /tt/  PEL(-maxx:maxx,-maxx:maxx,-maxz:maxz)
9575      &,rxy(-maxx:maxx,-maxx:maxx,-maxz:maxz)
9576 cc      SAVE /tt/
9577       SAVE
9578 *
9579       RXPLUS   = RHO(IX+1,IY,  IZ  ) / RHO0
9580       RXMINS   = RHO(IX-1,IY,  IZ  ) / RHO0
9581       RYPLUS   = RHO(IX,  IY+1,IZ  ) / RHO0
9582       RYMINS   = RHO(IX,  IY-1,IZ  ) / RHO0
9583       RZPLUS   = RHO(IX,  IY,  IZ+1) / RHO0
9584       RZMINS   = RHO(IX,  IY,  IZ-1) / RHO0
9585       den0     = RHO(IX,  IY,  IZ) / RHO0
9586       ene0     = pel(IX,  IY,  IZ)
9587 *-----------------------------------------------------------------------
9588       GOTO (1,2,3,4,5) IOPT
9589        if(iopt.eq.6)go to 6
9590        if(iopt.eq.7)go to 7
9591 *
9592     1 CONTINUE
9593 *       POTENTIAL USED IN 1) (STIFF):
9594 *       U = -.124 * RHO/RHO0 + .0705 (RHO/RHO0)**2 GEV
9595 *
9596            GRADX  = -0.062 * (RXPLUS - RXMINS) + 0.03525 * (RXPLUS**2 -
9597      &                                                      RXMINS**2)
9598            GRADY  = -0.062 * (RYPLUS - RYMINS) + 0.03525 * (RYPLUS**2 -
9599      &                                                      RYMINS**2)
9600            GRADZ  = -0.062 * (RZPLUS - RZMINS) + 0.03525 * (RZPLUS**2 -
9601      &                                                      RZMINS**2)
9602            RETURN
9603 *
9604     2 CONTINUE
9605 *       POTENTIAL USED IN 2):
9606 *       U = -.218 * RHO/RHO0 + .164 (RHO/RHO0)**(4/3) GEV
9607 *
9608            EXPNT = 1.3333333
9609            GRADX = -0.109 * (RXPLUS - RXMINS)
9610      &     + 0.082 * (RXPLUS**EXPNT-RXMINS**EXPNT)
9611            GRADY = -0.109 * (RYPLUS - RYMINS)
9612      &     + 0.082 * (RYPLUS**EXPNT-RYMINS**EXPNT)
9613            GRADZ = -0.109 * (RZPLUS - RZMINS)
9614      &     + 0.082 * (RZPLUS**EXPNT-RZMINS**EXPNT)
9615            RETURN
9616 *
9617     3 CONTINUE
9618 *       POTENTIAL USED IN 3) (SOFT):
9619 *       U = -.356 * RHO/RHO0 + .303 * (RHO/RHO0)**(7/6)  GEV
9620 *
9621            EXPNT = 1.1666667
9622           acoef = 0.178
9623            GRADX = -acoef * (RXPLUS - RXMINS)
9624      &     + 0.1515 * (RXPLUS**EXPNT-RXMINS**EXPNT)
9625            GRADY = -acoef * (RYPLUS - RYMINS)
9626      &     + 0.1515 * (RYPLUS**EXPNT-RYMINS**EXPNT)
9627            GRADZ = -acoef * (RZPLUS - RZMINS)
9628      &     + 0.1515 * (RZPLUS**EXPNT-RZMINS**EXPNT)
9629                  RETURN
9630 *
9631 *
9632     4   CONTINUE
9633 *       POTENTIAL USED IN 4) (super-soft in the mixed phase of 4 < rho/rho <7):
9634 *       U1 = -.356 * RHO/RHO0 + .303 * (RHO/RHO0)**(7/6)  GEV
9635 *       normal phase, soft eos of iopt=3
9636 *       U2 = -.02 * (RHO/RHO0)**(2/3) -0.0253 * (RHO/RHO0)**(7/6)  GEV
9637 *
9638        eh=4.
9639        eqgp=7.
9640            acoef=0.178
9641            EXPNT = 1.1666667
9642        denr=rho(ix,iy,iz)/rho0
9643        if(denr.le.eh.or.denr.ge.eqgp)then
9644            GRADX = -acoef * (RXPLUS - RXMINS)
9645      &     + 0.1515 * (RXPLUS**EXPNT-RXMINS**EXPNT)
9646            GRADY = -acoef * (RYPLUS - RYMINS)
9647      &     + 0.1515 * (RYPLUS**EXPNT-RYMINS**EXPNT)
9648            GRADZ = -acoef * (RZPLUS - RZMINS)
9649      &     + 0.1515 * (RZPLUS**EXPNT-RZMINS**EXPNT)
9650        else
9651           acoef1=0.178
9652           acoef2=0.0
9653           expnt2=2./3.
9654            GRADX =-acoef1* (RXPLUS**EXPNT-RXMINS**EXPNT)
9655      &                 -acoef2* (RXPLUS**expnt2 - RXMINS**expnt2)
9656            GRADy =-acoef1* (RyPLUS**EXPNT-RyMINS**EXPNT)
9657      &                 -acoef2* (RyPLUS**expnt2 - RyMINS**expnt2)
9658            GRADz =-acoef1* (RzPLUS**EXPNT-RzMINS**EXPNT)
9659      &                 -acoef2* (RzPLUS**expnt2 - RzMINS**expnt2)
9660        endif
9661        return
9662 *
9663     5   CONTINUE
9664 *       POTENTIAL USED IN 5) (SUPER STIFF):
9665 *       U = -.10322 * RHO/RHO0 + .04956 * (RHO/RHO0)**(2.77)  GEV
9666 *
9667            EXPNT = 2.77
9668            GRADX = -0.0516 * (RXPLUS - RXMINS)
9669      &     + 0.02498 * (RXPLUS**EXPNT-RXMINS**EXPNT)
9670            GRADY = -0.0516 * (RYPLUS - RYMINS)
9671      &     + 0.02498 * (RYPLUS**EXPNT-RYMINS**EXPNT)
9672            GRADZ = -0.0516 * (RZPLUS - RZMINS)
9673      &     + 0.02498 * (RZPLUS**EXPNT-RZMINS**EXPNT)
9674            RETURN
9675 *
9676     6 CONTINUE
9677 *       POTENTIAL USED IN 6) (STIFF-qgp):
9678 *       U = -.124 * RHO/RHO0 + .0705 (RHO/RHO0)**2 GEV
9679 *
9680        if(ene0.le.0.5)then
9681            GRADX  = -0.062 * (RXPLUS - RXMINS) + 0.03525 * (RXPLUS**2 -
9682      &                                                      RXMINS**2)
9683            GRADY  = -0.062 * (RYPLUS - RYMINS) + 0.03525 * (RYPLUS**2 -
9684      &                                                      RYMINS**2)
9685            GRADZ  = -0.062 * (RZPLUS - RZMINS) + 0.03525 * (RZPLUS**2 -
9686      &                                                      RZMINS**2)
9687            RETURN
9688        endif
9689        if(ene0.gt.0.5.and.ene0.le.1.5)then
9690 *       U=c1-ef*rho/rho0**2/3
9691        ef=36./1000.
9692            GRADX  = -0.5*ef* (RXPLUS**0.67-RXMINS**0.67)
9693            GRADy  = -0.5*ef* (RyPLUS**0.67-RyMINS**0.67)
9694            GRADz  = -0.5*ef* (RzPLUS**0.67-RzMINS**0.67)
9695            RETURN
9696        endif
9697        if(ene0.gt.1.5)then
9698 * U=800*(rho/rho0)**1/3.-Ef*(rho/rho0)**2/3.-c2
9699        ef=36./1000.
9700        cf0=0.8
9701         GRADX  =0.5*cf0*(rxplus**0.333-rxmins**0.333)
9702      &         -0.5*ef* (RXPLUS**0.67-RXMINS**0.67)
9703         GRADy  =0.5*cf0*(ryplus**0.333-rymins**0.333)
9704      &         -0.5*ef* (RyPLUS**0.67-RyMINS**0.67)
9705         GRADz  =0.5*cf0*(rzplus**0.333-rzmins**0.333)
9706      &         -0.5*ef* (RzPLUS**0.67-RzMINS**0.67)
9707            RETURN
9708        endif
9709 *
9710     7 CONTINUE
9711 *       POTENTIAL USED IN 7) (Soft-qgp):
9712        if(den0.le.4.5)then
9713 *       POTENTIAL USED is the same as IN 3) (SOFT):
9714 *       U = -.356 * RHO/RHO0 + .303 * (RHO/RHO0)**(7/6)  GEV
9715 *
9716            EXPNT = 1.1666667
9717           acoef = 0.178
9718            GRADX = -acoef * (RXPLUS - RXMINS)
9719      &     + 0.1515 * (RXPLUS**EXPNT-RXMINS**EXPNT)
9720            GRADY = -acoef * (RYPLUS - RYMINS)
9721      &     + 0.1515 * (RYPLUS**EXPNT-RYMINS**EXPNT)
9722            GRADZ = -acoef * (RZPLUS - RZMINS)
9723      &     + 0.1515 * (RZPLUS**EXPNT-RZMINS**EXPNT)
9724        return
9725        endif
9726        if(den0.gt.4.5.and.den0.le.5.1)then
9727 *       U=c1-ef*rho/rho0**2/3
9728        ef=36./1000.
9729            GRADX  = -0.5*ef* (RXPLUS**0.67-RXMINS**0.67)
9730            GRADy  = -0.5*ef* (RyPLUS**0.67-RyMINS**0.67)
9731            GRADz  = -0.5*ef* (RzPLUS**0.67-RzMINS**0.67)
9732            RETURN
9733        endif
9734        if(den0.gt.5.1)then
9735 * U=800*(rho/rho0)**1/3.-Ef*(rho/rho0)**2/3.-c2
9736        ef=36./1000.
9737        cf0=0.8
9738         GRADX  =0.5*cf0*(rxplus**0.333-rxmins**0.333)
9739      &         -0.5*ef* (RXPLUS**0.67-RXMINS**0.67)
9740         GRADy  =0.5*cf0*(ryplus**0.333-rymins**0.333)
9741      &         -0.5*ef* (RyPLUS**0.67-RyMINS**0.67)
9742         GRADz  =0.5*cf0*(rzplus**0.333-rzmins**0.333)
9743      &         -0.5*ef* (RzPLUS**0.67-RzMINS**0.67)
9744            RETURN
9745        endif
9746         END
9747 **********************************
9748 *                                                                      *
9749       SUBROUTINE GRADUK(IX,IY,IZ,GRADXk,GRADYk,GRADZk)
9750 *                                                                      *
9751 *       PURPOSE:     DETERMINE the baryon density gradient for         *
9752 *                    proporgating kaons in a mean field caused by      *
9753 *                    surrounding baryons                               *
9754 *       VARIABLES:                                                     *
9755 *         IX, IY, IZ          - COORDINATES OF POINT   (INTEGER,INPUT) *
9756 *         GRADXk, GRADYk, GRADZk                       (REAL,OUTPUT)   *
9757 *                                                                      *
9758 **********************************
9759       PARAMETER         (MAXX =    20,  MAXZ =   24)
9760       PARAMETER         (RHO0 = 0.168)
9761 *
9762       COMMON  /DD/      RHO(-MAXX:MAXX,-MAXX:MAXX,-MAXZ:MAXZ),
9763      &                  RHOP(-MAXX:MAXX,-MAXX:MAXX,-MAXZ:MAXZ),
9764      &                  RHON(-MAXX:MAXX,-MAXX:MAXX,-MAXZ:MAXZ)
9765 cc      SAVE /DD/
9766       common  /ss/      inout(20)
9767 cc      SAVE /ss/
9768       SAVE
9769 *
9770       RXPLUS   = RHO(IX+1,IY,  IZ  )
9771       RXMINS   = RHO(IX-1,IY,  IZ  )
9772       RYPLUS   = RHO(IX,  IY+1,IZ  )
9773       RYMINS   = RHO(IX,  IY-1,IZ  )
9774       RZPLUS   = RHO(IX,  IY,  IZ+1)
9775       RZMINS   = RHO(IX,  IY,  IZ-1)
9776            GRADXk  = (RXPLUS - RXMINS)/2.
9777            GRADYk  = (RYPLUS - RYMINS)/2.
9778            GRADZk  = (RZPLUS - RZMINS)/2.
9779            RETURN
9780            END
9781 *-----------------------------------------------------------------------
9782       SUBROUTINE GRADUP(IX,IY,IZ,GRADXP,GRADYP,GRADZP)
9783 *                                                                      *
9784 *       PURPOSE:     DETERMINE THE GRADIENT OF THE PROTON DENSITY      *
9785 *       VARIABLES:                                                     *
9786 *                                                                           *
9787 *         IX, IY, IZ          - COORDINATES OF POINT   (INTEGER,INPUT) *
9788 *         GRADXP, GRADYP, GRADZP - GRADIENT OF THE PROTON              *
9789 *                                  DENSITY(REAL,OUTPUT)                *
9790 *                                                                      *
9791 **********************************
9792       PARAMETER         (MAXX =    20,  MAXZ =   24)
9793       PARAMETER         (RHO0 = 0.168)
9794 *
9795       COMMON  /DD/      RHO(-MAXX:MAXX,-MAXX:MAXX,-MAXZ:MAXZ),
9796      &                     RHOP(-MAXX:MAXX,-MAXX:MAXX,-MAXZ:MAXZ),
9797      &                     RHON(-MAXX:MAXX,-MAXX:MAXX,-MAXZ:MAXZ)
9798 cc      SAVE /DD/
9799       common  /ss/      inout(20)
9800 cc      SAVE /ss/
9801       SAVE
9802 *
9803       RXPLUS   = RHOP(IX+1,IY,  IZ  ) / RHO0
9804       RXMINS   = RHOP(IX-1,IY,  IZ  ) / RHO0
9805       RYPLUS   = RHOP(IX,  IY+1,IZ  ) / RHO0
9806       RYMINS   = RHOP(IX,  IY-1,IZ  ) / RHO0
9807       RZPLUS   = RHOP(IX,  IY,  IZ+1) / RHO0
9808       RZMINS   = RHOP(IX,  IY,  IZ-1) / RHO0
9809 *-----------------------------------------------------------------------
9810 *
9811            GRADXP  = (RXPLUS - RXMINS)/2.
9812            GRADYP  = (RYPLUS - RYMINS)/2.
9813            GRADZP  = (RZPLUS - RZMINS)/2.
9814            RETURN
9815       END
9816 *-----------------------------------------------------------------------
9817       SUBROUTINE GRADUN(IX,IY,IZ,GRADXN,GRADYN,GRADZN)
9818 *                                                                      *
9819 *       PURPOSE:     DETERMINE THE GRADIENT OF THE NEUTRON DENSITY     *
9820 *       VARIABLES:                                                     *
9821 *                                                                           *
9822 *         IX, IY, IZ          - COORDINATES OF POINT   (INTEGER,INPUT) *
9823 *         GRADXN, GRADYN, GRADZN - GRADIENT OF THE NEUTRON             *
9824 *                                  DENSITY(REAL,OUTPUT)                *
9825 *                                                                      *
9826 **********************************
9827       PARAMETER         (MAXX =    20,  MAXZ =   24)
9828       PARAMETER         (RHO0 = 0.168)
9829 *
9830       COMMON  /DD/      RHO(-MAXX:MAXX,-MAXX:MAXX,-MAXZ:MAXZ),
9831      &                     RHOP(-MAXX:MAXX,-MAXX:MAXX,-MAXZ:MAXZ),
9832      &                     RHON(-MAXX:MAXX,-MAXX:MAXX,-MAXZ:MAXZ)
9833 cc      SAVE /DD/
9834       common  /ss/      inout(20)
9835 cc      SAVE /ss/
9836       SAVE
9837 *
9838       RXPLUS   = RHON(IX+1,IY,  IZ  ) / RHO0
9839       RXMINS   = RHON(IX-1,IY,  IZ  ) / RHO0
9840       RYPLUS   = RHON(IX,  IY+1,IZ  ) / RHO0
9841       RYMINS   = RHON(IX,  IY-1,IZ  ) / RHO0
9842       RZPLUS   = RHON(IX,  IY,  IZ+1) / RHO0
9843       RZMINS   = RHON(IX,  IY,  IZ-1) / RHO0
9844 *-----------------------------------------------------------------------
9845 *
9846            GRADXN  = (RXPLUS - RXMINS)/2.
9847            GRADYN  = (RYPLUS - RYMINS)/2.
9848            GRADZN  = (RZPLUS - RZMINS)/2.
9849            RETURN
9850       END
9851
9852 *-----------------------------------------------------------------------------
9853 *FUNCTION FDE(DMASS) GIVES DELTA MASS DISTRIBUTION BY USING OF
9854 *KITAZOE'S FORMULA
9855         REAL FUNCTION FDE(DMASS,SRT,CON)
9856       SAVE
9857         AMN=0.938869
9858         AVPI=0.13803333
9859         AM0=1.232
9860         FD=4.*(AM0**2)*WIDTH(DMASS)/((DMASS**2-1.232**2)**2
9861      1  +AM0**2*WIDTH(DMASS)**2)
9862         IF(CON.EQ.1.)THEN
9863         P11=(SRT**2+DMASS**2-AMN**2)**2
9864      1  /(4.*SRT**2)-DMASS**2
9865        if(p11.le.0)p11=1.E-06
9866        p1=sqrt(p11)
9867         ELSE
9868         DMASS=AMN+AVPI
9869         P11=(SRT**2+DMASS**2-AMN**2)**2
9870      1  /(4.*SRT**2)-DMASS**2
9871        if(p11.le.0)p11=1.E-06
9872        p1=sqrt(p11)
9873         ENDIF
9874         FDE=FD*P1*DMASS
9875         RETURN
9876         END
9877 *-------------------------------------------------------------
9878 *FUNCTION FDE(DMASS) GIVES N*(1535) MASS DISTRIBUTION BY USING OF
9879 *KITAZOE'S FORMULA
9880         REAL FUNCTION FD5(DMASS,SRT,CON)
9881       SAVE
9882         AMN=0.938869
9883         AVPI=0.13803333
9884         AM0=1.535
9885         FD=4.*(AM0**2)*W1535(DMASS)/((DMASS**2-1.535**2)**2
9886      1  +AM0**2*W1535(DMASS)**2)
9887         IF(CON.EQ.1.)THEN
9888         P1=SQRT((SRT**2+DMASS**2-AMN**2)**2
9889      1  /(4.*SRT**2)-DMASS**2)
9890         ELSE
9891         DMASS=AMN+AVPI
9892         P1=SQRT((SRT**2+DMASS**2-AMN**2)**2
9893      1  /(4.*SRT**2)-DMASS**2)
9894         ENDIF
9895         FD5=FD*P1*DMASS
9896         RETURN
9897         END
9898 *--------------------------------------------------------------------------
9899 *FUNCTION FNS(DMASS) GIVES N* MASS DISTRIBUTION
9900 c     BY USING OF BREIT-WIGNER FORMULA
9901         REAL FUNCTION FNS(DMASS,SRT,CON)
9902       SAVE
9903         WIDTH=0.2
9904         AMN=0.938869
9905         AVPI=0.13803333
9906         AN0=1.43
9907         FN=4.*(AN0**2)*WIDTH/((DMASS**2-1.44**2)**2+AN0**2*WIDTH**2)
9908         IF(CON.EQ.1.)THEN
9909         P1=SQRT((SRT**2+DMASS**2-AMN**2)**2
9910      1  /(4.*SRT**2)-DMASS**2)
9911         ELSE
9912         DMASS=AMN+AVPI
9913         P1=SQRT((SRT**2+DMASS**2-AMN**2)**2
9914      1  /(4.*SRT**2)-DMASS**2)
9915         ENDIF
9916         FNS=FN*P1*DMASS
9917         RETURN
9918         END
9919 *-----------------------------------------------------------------------------
9920 *-----------------------------------------------------------------------------
9921 * PURPOSE:1. SORT N*(1440) and N*(1535) 2-body DECAY PRODUCTS
9922 *         2. DETERMINE THE MOMENTUM AND COORDINATES OF NUCLEON AND PION
9923 *            AFTER THE DELTA OR N* DECAYING
9924 * DATE   : JAN. 24,1990, MODIFIED ON MAY 17, 1994 TO INCLUDE ETA
9925         SUBROUTINE DECAY(IRUN,I,NNN,ISEED,wid,nt)
9926         PARAMETER (MAXSTR=150001,MAXR=1,
9927      1  AMN=0.939457,ETAM=0.5475,AMP=0.93828,AP1=0.13496,
9928      2  AP2=0.13957,AM0=1.232,PI=3.1415926)
9929         COMMON /AA/ R(3,MAXSTR)
9930 cc      SAVE /AA/
9931         COMMON /BB/ P(3,MAXSTR)
9932 cc      SAVE /BB/
9933         COMMON /CC/ E(MAXSTR)
9934 cc      SAVE /CC/
9935         COMMON /EE/ ID(MAXSTR),LB(MAXSTR)
9936 cc      SAVE /EE/
9937         COMMON   /RUN/NUM
9938 cc      SAVE /RUN/
9939         COMMON   /PA/RPION(3,MAXSTR,MAXR)
9940 cc      SAVE /PA/
9941         COMMON   /PB/PPION(3,MAXSTR,MAXR)
9942 cc      SAVE /PB/
9943         COMMON   /PC/EPION(MAXSTR,MAXR)
9944 cc      SAVE /PC/
9945         COMMON   /PD/LPION(MAXSTR,MAXR)
9946 cc      SAVE /PD/
9947         COMMON /INPUT2/ ILAB, MANYB, NTMAX, ICOLL, INSYS, IPOT, MODE,
9948      &       IMOMEN, NFREQ, ICFLOW, ICRHO, ICOU, KPOTEN, KMUL
9949 cc      SAVE /INPUT2/
9950       COMMON/RNDF77/NSEED
9951       COMMON /dpert/dpertt(MAXSTR,MAXR),dpertp(MAXSTR),dplast(MAXSTR),
9952      1     dpdcy(MAXSTR),dpdpi(MAXSTR,MAXR),dpt(MAXSTR, MAXR),
9953      2     dpp1(MAXSTR,MAXR),dppion(MAXSTR,MAXR)
9954 cc      SAVE /RNDF77/
9955       SAVE
9956         lbanti=LB(I)
9957 c
9958         DM=E(I)
9959 *1. FOR N*+(1440) DECAY
9960         IF(iabs(LB(I)).EQ.11)THEN
9961            X3=RANART(NSEED)
9962            IF(X3.GT.(1./3.))THEN
9963               LB(I)=2
9964               NLAB=2
9965               LPION(NNN,IRUN)=5
9966               EPION(NNN,IRUN)=AP2
9967            ELSE
9968               LB(I)=1
9969               NLAB=1
9970               LPION(NNN,IRUN)=4
9971               EPION(NNN,IRUN)=AP1
9972            ENDIF
9973 *2. FOR N*0(1440) DECAY
9974         ELSEIF(iabs(LB(I)).EQ.10)THEN
9975            X4=RANART(NSEED)
9976            IF(X4.GT.(1./3.))THEN
9977               LB(I)=1
9978               NLAB=1
9979               LPION(NNN,IRUN)=3
9980               EPION(NNN,IRUN)=AP2
9981            ELSE
9982               LB(I)=2
9983               NALB=2
9984               LPION(NNN,IRUN)=4
9985               EPION(NNN,IRUN)=AP1
9986            ENDIF
9987 * N*(1535) CAN DECAY TO A PION OR AN ETA IF DM > 1.49 GeV
9988 *3 N*(0)(1535) DECAY
9989         ELSEIF(iabs(LB(I)).EQ.12)THEN
9990            CTRL=0.65
9991            IF(DM.lE.1.49)ctrl=-1.
9992            X5=RANART(NSEED)
9993            IF(X5.GE.ctrl)THEN
9994 * DECAY TO PION+NUCLEON
9995               X6=RANART(NSEED)
9996               IF(X6.GT.(1./3.))THEN
9997                  LB(I)=1
9998                  NLAB=1
9999                  LPION(NNN,IRUN)=3
10000                  EPION(NNN,IRUN)=AP2
10001               ELSE
10002                  LB(I)=2
10003                  NALB=2
10004                  LPION(NNN,IRUN)=4
10005                  EPION(NNN,IRUN)=AP1
10006               ENDIF
10007            ELSE
10008 * DECAY TO ETA+NEUTRON
10009               LB(I)=2
10010               NLAB=2
10011               LPION(NNN,IRUN)=0
10012               EPION(NNN,IRUN)=ETAM
10013            ENDIF
10014 *4. FOR N*+(1535) DECAY
10015         ELSEIF(iabs(LB(I)).EQ.13)THEN
10016            CTRL=0.65
10017            IF(DM.lE.1.49)ctrl=-1.
10018            X5=RANART(NSEED)
10019            IF(X5.GE.ctrl)THEN
10020 * DECAY TO PION+NUCLEON
10021               X8=RANART(NSEED)
10022               IF(X8.GT.(1./3.))THEN
10023                  LB(I)=2
10024                  NLAB=2
10025                  LPION(NNN,IRUN)=5
10026                  EPION(NNN,IRUN)=AP2
10027               ELSE
10028                  LB(I)=1
10029                  NLAB=1
10030                  LPION(NNN,IRUN)=4
10031                  EPION(NNN,IRUN)=AP1
10032               ENDIF
10033            ELSE
10034 * DECAY TO ETA+NUCLEON
10035               LB(I)=1
10036               NLAB=1
10037               LPION(NNN,IRUN)=0
10038               EPION(NNN,IRUN)=ETAM
10039            ENDIF
10040         ENDIF
10041 c
10042         CALL DKINE(IRUN,I,NNN,NLAB,ISEED,wid,nt)
10043 c
10044 c     anti-particle ID for anti-N* decays:
10045         if(lbanti.lt.0) then
10046            lbi=LB(I)
10047            if(lbi.eq.1.or.lbi.eq.2) then
10048               lbi=-lbi
10049            elseif(lbi.eq.3) then
10050               lbi=5
10051            elseif(lbi.eq.5) then
10052               lbi=3
10053            endif
10054            LB(I)=lbi
10055 c
10056            lbi=LPION(NNN,IRUN)
10057            if(lbi.eq.3) then
10058               lbi=5
10059            elseif(lbi.eq.5) then
10060               lbi=3
10061            elseif(lbi.eq.1.or.lbi.eq.2) then
10062               lbi=-lbi
10063            endif
10064            LPION(NNN,IRUN)=lbi
10065         endif
10066 c
10067         if(nt.eq.ntmax) then
10068 c     at the last timestep, assign rho or eta (decay daughter)
10069 c     to lb(i1) only (not to lpion) in order to decay them again:
10070            lbm=LPION(NNN,IRUN)
10071            if(lbm.eq.0.or.lbm.eq.25
10072      1          .or.lbm.eq.26.or.lbm.eq.27) then
10073 c     switch rho or eta with baryon, positions are the same (no change needed):
10074               lbsave=lbm
10075               xmsave=EPION(NNN,IRUN)
10076               pxsave=PPION(1,NNN,IRUN)
10077               pysave=PPION(2,NNN,IRUN)
10078               pzsave=PPION(3,NNN,IRUN)
10079 clin-5/2008:
10080               dpsave=dppion(NNN,IRUN)
10081               LPION(NNN,IRUN)=LB(I)
10082               EPION(NNN,IRUN)=E(I)
10083               PPION(1,NNN,IRUN)=P(1,I)
10084               PPION(2,NNN,IRUN)=P(2,I)
10085               PPION(3,NNN,IRUN)=P(3,I)
10086 clin-5/2008:
10087               dppion(NNN,IRUN)=dpertp(I)
10088               LB(I)=lbsave
10089               E(I)=xmsave
10090               P(1,I)=pxsave
10091               P(2,I)=pysave
10092               P(3,I)=pzsave
10093 clin-5/2008:
10094               dpertp(I)=dpsave
10095            endif
10096         endif
10097
10098        RETURN
10099        END
10100
10101 *-------------------------------------------------------------------
10102 *-------------------------------------------------------------------
10103 * PURPOSE:
10104 *         CALCULATE THE MOMENTUM OF NUCLEON AND PION (OR ETA)
10105 *         IN THE LAB. FRAME AFTER DELTA OR N* DECAY
10106 * DATE   : JAN. 24,1990, MODIFIED ON MAY 17, 1994 TO INCLUDE ETA PRODUCTION
10107         SUBROUTINE DKINE(IRUN,I,NNN,NLAB,ISEED,wid,nt)
10108         PARAMETER (hbarc=0.19733)
10109         PARAMETER (MAXSTR=150001,MAXR=1,
10110      1  AMN=0.939457,AMP=0.93828,ETAM=0.5475,
10111      2  AP1=0.13496,AP2=0.13957,AM0=1.232,PI=3.1415926)
10112         COMMON /AA/ R(3,MAXSTR)
10113 cc      SAVE /AA/
10114         COMMON /BB/ P(3,MAXSTR)
10115 cc      SAVE /BB/
10116         COMMON /CC/ E(MAXSTR)
10117 cc      SAVE /CC/
10118         COMMON /EE/ ID(MAXSTR),LB(MAXSTR)
10119 cc      SAVE /EE/
10120         COMMON   /RUN/NUM
10121 cc      SAVE /RUN/
10122         COMMON   /PA/RPION(3,MAXSTR,MAXR)
10123 cc      SAVE /PA/
10124         COMMON   /PB/PPION(3,MAXSTR,MAXR)
10125 cc      SAVE /PB/
10126         COMMON   /PC/EPION(MAXSTR,MAXR)
10127 cc      SAVE /PC/
10128         COMMON   /PD/LPION(MAXSTR,MAXR)
10129 cc      SAVE /PD/
10130       common/leadng/lb1,px1,py1,pz1,em1,e1,xfnl,yfnl,zfnl,tfnl,
10131      1 px1n,py1n,pz1n,dp1n
10132 cc      SAVE /leadng/
10133         COMMON/tdecay/tfdcy(MAXSTR),tfdpi(MAXSTR,MAXR),tft(MAXSTR)
10134 cc      SAVE /tdecay/
10135         COMMON /INPUT2/ ILAB, MANYB, NTMAX, ICOLL, INSYS, IPOT, MODE,
10136      &       IMOMEN, NFREQ, ICFLOW, ICRHO, ICOU, KPOTEN, KMUL
10137 cc      SAVE /INPUT2/
10138       COMMON/RNDF77/NSEED
10139 cc      SAVE /RNDF77/
10140       COMMON /dpert/dpertt(MAXSTR,MAXR),dpertp(MAXSTR),dplast(MAXSTR),
10141      1     dpdcy(MAXSTR),dpdpi(MAXSTR,MAXR),dpt(MAXSTR, MAXR),
10142      2     dpp1(MAXSTR,MAXR),dppion(MAXSTR,MAXR)
10143         EXTERNAL IARFLV, INVFLV
10144       SAVE
10145         ISEED=ISEED
10146 * READ IN THE COORDINATES OF DELTA OR N* UNDERGOING DECAY
10147         PX=P(1,I)
10148         PY=P(2,I)
10149         PZ=P(3,I)
10150         RX=R(1,I)
10151         RY=R(2,I)
10152         RZ=R(3,I)
10153         DM=E(I)
10154         EDELTA=SQRT(DM**2+PX**2+PY**2+PZ**2)
10155         PM=EPION(NNN,IRUN)
10156         AM=AMP
10157         IF(NLAB.EQ.2)AM=AMN
10158 * FIND OUT THE MOMENTUM AND ENERGY OF PION AND NUCLEON IN DELTA REST FRAME
10159 * THE MAGNITUDE OF MOMENTUM IS DETERMINED BY ENERGY CONSERVATION ,THE FORMULA
10160 * CAN BE FOUND ON PAGE 716,W BAUER P.R.C40,1989
10161 * THE DIRECTION OF THE MOMENTUM IS ASSUMED ISOTROPIC. NOTE THAT P(PION)=-P(N)
10162         Q2=((DM**2-AM**2+PM**2)/(2.*DM))**2-PM**2
10163         IF(Q2.LE.0.)Q2=1.e-09
10164         Q=SQRT(Q2)
10165 11      QX=1.-2.*RANART(NSEED)
10166         QY=1.-2.*RANART(NSEED)
10167         QZ=1.-2.*RANART(NSEED)
10168         QS=QX**2+QY**2+QZ**2
10169         IF(QS.GT.1.) GO TO 11
10170         PXP=Q*QX/SQRT(QS)
10171         PYP=Q*QY/SQRT(QS)
10172         PZP=Q*QZ/SQRT(QS)
10173         EP=SQRT(Q**2+PM**2)
10174         PXN=-PXP
10175         PYN=-PYP
10176         PZN=-PZP
10177         EN=SQRT(Q**2+AM**2)
10178 * TRANSFORM INTO THE LAB. FRAME. THE GENERAL LORENTZ TRANSFORMATION CAN
10179 * BE FOUND ON PAGE 34 OF R. HAGEDORN " RELATIVISTIC KINEMATICS"
10180         GD=EDELTA/DM
10181         FGD=GD/(1.+GD)
10182         BDX=PX/EDELTA
10183         BDY=PY/EDELTA
10184         BDZ=PZ/EDELTA
10185         BPP=BDX*PXP+BDY*PYP+BDZ*PZP
10186         BPN=BDX*PXN+BDY*PYN+BDZ*PZN
10187         P(1,I)=PXN+BDX*GD*(FGD*BPN+EN)
10188         P(2,I)=PYN+BDY*GD*(FGD*BPN+EN)
10189         P(3,I)=PZN+BDZ*GD*(FGD*BPN+EN)
10190         E(I)=AM
10191 * WE ASSUME THAT THE SPACIAL COORDINATE OF THE NUCLEON
10192 * IS THAT OF THE DELTA
10193         PPION(1,NNN,IRUN)=PXP+BDX*GD*(FGD*BPP+EP)
10194         PPION(2,NNN,IRUN)=PYP+BDY*GD*(FGD*BPP+EP)
10195         PPION(3,NNN,IRUN)=PZP+BDZ*GD*(FGD*BPP+EP)
10196 clin-5/2008:
10197         dppion(NNN,IRUN)=dpertp(I)
10198 * WE ASSUME THE PION OR ETA COMING FROM DELTA DECAY IS LOCATED ON THE SPHERE
10199 * OF RADIUS 0.5FM AROUND DELTA, THIS POINT NEED TO BE CHECKED
10200 * AND OTHER CRIERTION MAY BE TRIED
10201 clin-2/20/03 no additional smearing for position of decay daughters:
10202 c200         X0 = 1.0 - 2.0 * RANART(NSEED)
10203 c            Y0 = 1.0 - 2.0 * RANART(NSEED)
10204 c            Z0 = 1.0 - 2.0 * RANART(NSEED)
10205 c        IF ((X0*X0+Y0*Y0+Z0*Z0) .GT. 1.0) GOTO 200
10206 c        RPION(1,NNN,IRUN)=R(1,I)+0.5*x0
10207 c        RPION(2,NNN,IRUN)=R(2,I)+0.5*y0
10208 c        RPION(3,NNN,IRUN)=R(3,I)+0.5*z0
10209         RPION(1,NNN,IRUN)=R(1,I)
10210         RPION(2,NNN,IRUN)=R(2,I)
10211         RPION(3,NNN,IRUN)=R(3,I)
10212 c
10213         devio=SQRT(EPION(NNN,IRUN)**2+PPION(1,NNN,IRUN)**2
10214      1       +PPION(2,NNN,IRUN)**2+PPION(3,NNN,IRUN)**2)
10215      2       +SQRT(E(I)**2+P(1,I)**2+P(2,I)**2+P(3,I)**2)-e1
10216 c        if(abs(devio).gt.0.02) write(93,*) 'decay(): nt=',nt,devio,lb1
10217
10218 c     add decay time to daughter's formation time at the last timestep:
10219         if(nt.eq.ntmax) then
10220            tau0=hbarc/wid
10221            taudcy=tau0*(-1.)*alog(1.-RANART(NSEED))
10222 c     lorentz boost:
10223            taudcy=taudcy*e1/em1
10224            tfnl=tfnl+taudcy
10225            xfnl=xfnl+px1/e1*taudcy
10226            yfnl=yfnl+py1/e1*taudcy
10227            zfnl=zfnl+pz1/e1*taudcy
10228            R(1,I)=xfnl
10229            R(2,I)=yfnl
10230            R(3,I)=zfnl
10231            tfdcy(I)=tfnl
10232            RPION(1,NNN,IRUN)=xfnl
10233            RPION(2,NNN,IRUN)=yfnl
10234            RPION(3,NNN,IRUN)=zfnl
10235            tfdpi(NNN,IRUN)=tfnl
10236         endif
10237
10238 cc 200    format(a30,2(1x,e10.4))
10239 cc 210    format(i6,5(1x,f8.3))
10240 cc 220    format(a2,i5,5(1x,f8.3))
10241
10242         RETURN
10243         END
10244
10245 *-----------------------------------------------------------------------------
10246 *-----------------------------------------------------------------------------
10247 * PURPOSE:1. N*-->N+PION+PION  DECAY PRODUCTS
10248 *         2. DETERMINE THE MOMENTUM AND COORDINATES OF NUCLEON AND PION
10249 *            AFTER THE DELTA OR N* DECAYING
10250 * DATE   : NOV.7,1994
10251 *----------------------------------------------------------------------------
10252         SUBROUTINE DECAY2(IRUN,I,NNN,ISEED,wid,nt)
10253         PARAMETER (MAXSTR=150001,MAXR=1,
10254      1  AMN=0.939457,ETAM=0.5475,AMP=0.93828,AP1=0.13496,
10255      2  AP2=0.13957,AM0=1.232,PI=3.1415926)
10256         COMMON /AA/ R(3,MAXSTR)
10257 cc      SAVE /AA/
10258         COMMON /BB/ P(3,MAXSTR)
10259 cc      SAVE /BB/
10260         COMMON /CC/ E(MAXSTR)
10261 cc      SAVE /CC/
10262         COMMON /EE/ ID(MAXSTR),LB(MAXSTR)
10263 cc      SAVE /EE/
10264         COMMON   /RUN/NUM
10265 cc      SAVE /RUN/
10266         COMMON   /PA/RPION(3,MAXSTR,MAXR)
10267 cc      SAVE /PA/
10268         COMMON   /PB/PPION(3,MAXSTR,MAXR)
10269 cc      SAVE /PB/
10270         COMMON   /PC/EPION(MAXSTR,MAXR)
10271 cc      SAVE /PC/
10272         COMMON   /PD/LPION(MAXSTR,MAXR)
10273 cc      SAVE /PD/
10274       COMMON/RNDF77/NSEED
10275 cc      SAVE /RNDF77/
10276       SAVE
10277
10278         lbanti=LB(I)
10279 c
10280         DM=E(I)
10281 * DETERMINE THE DECAY PRODUCTS
10282 * FOR N*+(1440) DECAY
10283         IF(iabs(LB(I)).EQ.11)THEN
10284            X3=RANART(NSEED)
10285            IF(X3.LT.(1./3))THEN
10286               LB(I)=2
10287               NLAB=2
10288               LPION(NNN,IRUN)=5
10289               EPION(NNN,IRUN)=AP2
10290               LPION(NNN+1,IRUN)=4
10291               EPION(NNN+1,IRUN)=AP1
10292            ELSEIF(X3.LT.2./3.AND.X3.GT.1./3.)THEN
10293               LB(I)=1
10294               NLAB=1
10295               LPION(NNN,IRUN)=5
10296               EPION(NNN,IRUN)=AP2
10297               LPION(NNN+1,IRUN)=3
10298               EPION(NNN+1,IRUN)=AP2
10299            ELSE
10300               LB(I)=1
10301               NLAB=1
10302               LPION(NNN,IRUN)=4
10303               EPION(NNN,IRUN)=AP1
10304               LPION(NNN+1,IRUN)=4
10305               EPION(NNN+1,IRUN)=AP1
10306            ENDIF
10307 * FOR N*0(1440) DECAY
10308         ELSEIF(iabs(LB(I)).EQ.10)THEN
10309            X3=RANART(NSEED)
10310            IF(X3.LT.(1./3))THEN
10311               LB(I)=2
10312               NLAB=2
10313               LPION(NNN,IRUN)=4
10314               EPION(NNN,IRUN)=AP1
10315               LPION(NNN+1,IRUN)=4
10316               EPION(NNN+1,IRUN)=AP1
10317            ELSEIF(X3.LT.2./3.AND.X3.GT.1./3.)THEN
10318               LB(I)=1
10319               NLAB=1
10320               LPION(NNN,IRUN)=3
10321               EPION(NNN,IRUN)=AP2
10322               LPION(NNN+1,IRUN)=4
10323               EPION(NNN+1,IRUN)=AP1
10324            ELSE
10325               LB(I)=2
10326               NLAB=2
10327               LPION(NNN,IRUN)=5
10328               EPION(NNN,IRUN)=AP2
10329               LPION(NNN+1,IRUN)=3
10330               EPION(NNN+1,IRUN)=AP2
10331            ENDIF
10332         ENDIF
10333
10334         CALL DKINE2(IRUN,I,NNN,NLAB,ISEED,wid,nt)
10335 c
10336 c     anti-particle ID for anti-N* decays:
10337         if(lbanti.lt.0) then
10338            lbi=LB(I)
10339            if(lbi.eq.1.or.lbi.eq.2) then
10340               lbi=-lbi
10341            elseif(lbi.eq.3) then
10342               lbi=5
10343            elseif(lbi.eq.5) then
10344               lbi=3
10345            endif
10346            LB(I)=lbi
10347 c
10348            lbi=LPION(NNN,IRUN)
10349            if(lbi.eq.3) then
10350               lbi=5
10351            elseif(lbi.eq.5) then
10352               lbi=3
10353            elseif(lbi.eq.1.or.lbi.eq.2) then
10354               lbi=-lbi
10355            endif
10356            LPION(NNN,IRUN)=lbi
10357 c
10358            lbi=LPION(NNN+1,IRUN)
10359            if(lbi.eq.3) then
10360               lbi=5
10361            elseif(lbi.eq.5) then
10362               lbi=3
10363            elseif(lbi.eq.1.or.lbi.eq.2) then
10364               lbi=-lbi
10365            endif
10366            LPION(NNN+1,IRUN)=lbi
10367         endif
10368 c
10369        RETURN
10370        END
10371 *-------------------------------------------------------------------
10372 *--------------------------------------------------------------------------
10373 *         CALCULATE THE MOMENTUM OF NUCLEON AND PION (OR ETA)
10374 *         IN THE LAB. FRAME AFTER DELTA OR N* DECAY
10375 * DATE   : JAN. 24,1990, MODIFIED ON MAY 17, 1994 TO INCLUDE ETA PRODUCTION
10376 *--------------------------------------------------------------------------
10377         SUBROUTINE DKINE2(IRUN,I,NNN,NLAB,ISEED,wid,nt)
10378         PARAMETER (hbarc=0.19733)
10379         PARAMETER (MAXSTR=150001,MAXR=1,
10380      1  AMN=0.939457,AMP=0.93828,ETAM=0.5475,
10381      2  AP1=0.13496,AP2=0.13957,AM0=1.232,PI=3.1415926)
10382         COMMON /AA/ R(3,MAXSTR)
10383 cc      SAVE /AA/
10384         COMMON /BB/ P(3,MAXSTR)
10385 cc      SAVE /BB/
10386         COMMON /CC/ E(MAXSTR)
10387 cc      SAVE /CC/
10388         COMMON /EE/ ID(MAXSTR),LB(MAXSTR)
10389 cc      SAVE /EE/
10390         COMMON   /RUN/NUM
10391 cc      SAVE /RUN/
10392         COMMON   /PA/RPION(3,MAXSTR,MAXR)
10393 cc      SAVE /PA/
10394         COMMON   /PB/PPION(3,MAXSTR,MAXR)
10395 cc      SAVE /PB/
10396         COMMON   /PC/EPION(MAXSTR,MAXR)
10397 cc      SAVE /PC/
10398         COMMON   /PD/LPION(MAXSTR,MAXR)
10399 cc      SAVE /PD/
10400       common/leadng/lb1,px1,py1,pz1,em1,e1,xfnl,yfnl,zfnl,tfnl,
10401      1 px1n,py1n,pz1n,dp1n
10402 cc      SAVE /leadng/
10403         COMMON/tdecay/tfdcy(MAXSTR),tfdpi(MAXSTR,MAXR),tft(MAXSTR)
10404 cc      SAVE /tdecay/
10405         COMMON /INPUT2/ ILAB, MANYB, NTMAX, ICOLL, INSYS, IPOT, MODE,
10406      &       IMOMEN, NFREQ, ICFLOW, ICRHO, ICOU, KPOTEN, KMUL
10407 cc      SAVE /INPUT2/
10408         EXTERNAL IARFLV, INVFLV
10409       COMMON/RNDF77/NSEED
10410 cc      SAVE /RNDF77/
10411       COMMON /dpert/dpertt(MAXSTR,MAXR),dpertp(MAXSTR),dplast(MAXSTR),
10412      1     dpdcy(MAXSTR),dpdpi(MAXSTR,MAXR),dpt(MAXSTR, MAXR),
10413      2     dpp1(MAXSTR,MAXR),dppion(MAXSTR,MAXR)
10414       SAVE
10415
10416         ISEED=ISEED
10417 * READ IN THE COORDINATES OF THE N*(1440) UNDERGOING DECAY
10418         PX=P(1,I)
10419         PY=P(2,I)
10420         PZ=P(3,I)
10421         RX=R(1,I)
10422         RY=R(2,I)
10423         RZ=R(3,I)
10424         DM=E(I)
10425         EDELTA=SQRT(DM**2+PX**2+PY**2+PZ**2)
10426         PM1=EPION(NNN,IRUN)
10427         PM2=EPION(NNN+1,IRUN)
10428         AM=AMN
10429        IF(NLAB.EQ.1)AM=AMP
10430 * THE MAXIMUM MOMENTUM OF THE NUCLEON FROM THE DECAY OF A N*
10431        PMAX2=(DM**2-(AM+PM1+PM2)**2)*(DM**2-(AM-PM1-PM2)**2)/4/DM**2
10432        PMAX=SQRT(PMAX2)
10433 * GENERATE THE MOMENTUM OF THE NUCLEON IN THE N* REST FRAME
10434        CSS=1.-2.*RANART(NSEED)
10435        SSS=SQRT(1-CSS**2)
10436        FAI=2*PI*RANART(NSEED)
10437        PX0=PMAX*SSS*COS(FAI)
10438        PY0=PMAX*SSS*SIN(FAI)
10439        PZ0=PMAX*CSS
10440        EP0=SQRT(PX0**2+PY0**2+PZ0**2+AM**2)
10441 clin-5/23/01 bug: P0 for pion0 is equal to PMAX, leaving pion+ and pion-
10442 c     without no relative momentum, thus producing them with equal momenta,
10443 * BETA AND GAMMA OF THE CMS OF PION+-PION-
10444        BETAX=-PX0/(DM-EP0)
10445        BETAY=-PY0/(DM-EP0)
10446        BETAZ=-PZ0/(DM-EP0)
10447        GD1=1./SQRT(1-BETAX**2-BETAY**2-BETAZ**2)
10448        FGD1=GD1/(1+GD1)
10449 * GENERATE THE MOMENTA OF PIONS IN THE CMS OF PION+PION-
10450         Q2=((DM-EP0)/(2.*GD1))**2-PM1**2
10451         IF(Q2.LE.0.)Q2=1.E-09
10452         Q=SQRT(Q2)
10453 11      QX=1.-2.*RANART(NSEED)
10454         QY=1.-2.*RANART(NSEED)
10455         QZ=1.-2.*RANART(NSEED)
10456         QS=QX**2+QY**2+QZ**2
10457         IF(QS.GT.1.) GO TO 11
10458         PXP=Q*QX/SQRT(QS)
10459         PYP=Q*QY/SQRT(QS)
10460         PZP=Q*QZ/SQRT(QS)
10461         EP=SQRT(Q**2+PM1**2)
10462         PXN=-PXP
10463         PYN=-PYP
10464         PZN=-PZP
10465         EN=SQRT(Q**2+PM2**2)
10466 * TRANSFORM THE MOMENTA OF PION+PION- INTO THE N* REST FRAME
10467         BPP1=BETAX*PXP+BETAY*PYP+BETAZ*PZP
10468         BPN1=BETAX*PXN+BETAY*PYN+BETAZ*PZN
10469 * FOR PION-
10470         P1M=PXN+BETAX*GD1*(FGD1*BPN1+EN)
10471         P2M=PYN+BETAY*GD1*(FGD1*BPN1+EN)
10472         P3M=PZN+BETAZ*GD1*(FGD1*BPN1+EN)
10473        EPN=SQRT(P1M**2+P2M**2+P3M**2+PM2**2)
10474 * FOR PION+
10475         P1P=PXP+BETAX*GD1*(FGD1*BPP1+EP)
10476         P2P=PYP+BETAY*GD1*(FGD1*BPP1+EP)
10477         P3P=PZP+BETAZ*GD1*(FGD1*BPP1+EP)
10478        EPP=SQRT(P1P**2+P2P**2+P3P**2+PM1**2)
10479 * TRANSFORM MOMENTA OF THE THREE PIONS INTO THE
10480 * THE NUCLEUS-NUCLEUS CENTER OF MASS  FRAME.
10481 * THE GENERAL LORENTZ TRANSFORMATION CAN
10482 * BE FOUND ON PAGE 34 OF R. HAGEDORN " RELATIVISTIC KINEMATICS"
10483         GD=EDELTA/DM
10484         FGD=GD/(1.+GD)
10485         BDX=PX/EDELTA
10486         BDY=PY/EDELTA
10487         BDZ=PZ/EDELTA
10488        BP0=BDX*PX0+BDY*PY0+BDZ*PZ0
10489         BPP=BDX*P1P+BDY*P2P+BDZ*P3P
10490         BPN=BDX*P1M+BDY*P2M+BDZ*P3M
10491 * FOR THE NUCLEON
10492         P(1,I)=PX0+BDX*GD*(FGD*BP0+EP0)
10493         P(2,I)=PY0+BDY*GD*(FGD*BP0+EP0)
10494         P(3,I)=PZ0+BDZ*GD*(FGD*BP0+EP0)
10495        E(I)=am
10496        ID(I)=0
10497        enucl=sqrt(p(1,i)**2+p(2,i)**2+p(3,i)**2+e(i)**2)
10498 * WE ASSUME THAT THE SPACIAL COORDINATE OF THE PION0
10499 * IS in a sphere of radius 0.5 fm around N*
10500 * FOR PION+
10501         PPION(1,NNN,IRUN)=P1P+BDX*GD*(FGD*BPP+EPP)
10502         PPION(2,NNN,IRUN)=P2P+BDY*GD*(FGD*BPP+EPP)
10503         PPION(3,NNN,IRUN)=P3P+BDZ*GD*(FGD*BPP+EPP)
10504        epion1=sqrt(ppion(1,nnn,irun)**2
10505      &  +ppion(2,nnn,irun)**2+ppion(3,nnn,irun)**2
10506      &  +epion(nnn,irun)**2)
10507 clin-2/20/03 no additional smearing for position of decay daughters:
10508 c200         X0 = 1.0 - 2.0 * RANART(NSEED)
10509 c            Y0 = 1.0 - 2.0 * RANART(NSEED)
10510 c            Z0 = 1.0 - 2.0 * RANART(NSEED)
10511 c        IF ((X0*X0+Y0*Y0+Z0*Z0) .GT. 1.0) GOTO 200
10512 c        RPION(1,NNN,IRUN)=R(1,I)+0.5*x0
10513 c        RPION(2,NNN,IRUN)=R(2,I)+0.5*y0
10514 c        RPION(3,NNN,IRUN)=R(3,I)+0.5*z0
10515         RPION(1,NNN,IRUN)=R(1,I)
10516         RPION(2,NNN,IRUN)=R(2,I)
10517         RPION(3,NNN,IRUN)=R(3,I)
10518 * FOR PION-
10519         PPION(1,NNN+1,IRUN)=P1M+BDX*GD*(FGD*BPN+EPN)
10520         PPION(2,NNN+1,IRUN)=P2M+BDY*GD*(FGD*BPN+EPN)
10521         PPION(3,NNN+1,IRUN)=P3M+BDZ*GD*(FGD*BPN+EPN)
10522 clin-5/2008:
10523         dppion(NNN,IRUN)=dpertp(I)
10524         dppion(NNN+1,IRUN)=dpertp(I)
10525 c
10526        epion2=sqrt(ppion(1,nnn+1,irun)**2
10527      &  +ppion(2,nnn+1,irun)**2+ppion(3,nnn+1,irun)**2
10528      &  +epion(nnn+1,irun)**2)
10529 clin-2/20/03 no additional smearing for position of decay daughters:
10530 c300         X0 = 1.0 - 2.0 * RANART(NSEED)
10531 c            Y0 = 1.0 - 2.0 * RANART(NSEED)
10532 c            Z0 = 1.0 - 2.0 * RANART(NSEED)
10533 c        IF ((X0*X0+Y0*Y0+Z0*Z0) .GT. 1.0) GOTO 300
10534 c        RPION(1,NNN+1,IRUN)=R(1,I)+0.5*x0
10535 c        RPION(2,NNN+1,IRUN)=R(2,I)+0.5*y0
10536 c        RPION(3,NNN+1,IRUN)=R(3,I)+0.5*z0
10537         RPION(1,NNN+1,IRUN)=R(1,I)
10538         RPION(2,NNN+1,IRUN)=R(2,I)
10539         RPION(3,NNN+1,IRUN)=R(3,I)
10540 c
10541 * check energy conservation in the decay
10542 c       efinal=enucl+epion1+epion2
10543 c       DEEE=(EDELTA-EFINAL)/EDELTA
10544 c       IF(ABS(DEEE).GE.1.E-03)write(6,*)1,edelta,efinal
10545
10546         devio=SQRT(EPION(NNN,IRUN)**2+PPION(1,NNN,IRUN)**2
10547      1       +PPION(2,NNN,IRUN)**2+PPION(3,NNN,IRUN)**2)
10548      2       +SQRT(E(I)**2+P(1,I)**2+P(2,I)**2+P(3,I)**2)
10549      3       +SQRT(EPION(NNN+1,IRUN)**2+PPION(1,NNN+1,IRUN)**2
10550      4       +PPION(2,NNN+1,IRUN)**2+PPION(3,NNN+1,IRUN)**2)-e1
10551 c        if(abs(devio).gt.0.02) write(93,*) 'decay2(): nt=',nt,devio,lb1
10552
10553 c     add decay time to daughter's formation time at the last timestep:
10554         if(nt.eq.ntmax) then
10555            tau0=hbarc/wid
10556            taudcy=tau0*(-1.)*alog(1.-RANART(NSEED))
10557 c     lorentz boost:
10558            taudcy=taudcy*e1/em1
10559            tfnl=tfnl+taudcy
10560            xfnl=xfnl+px1/e1*taudcy
10561            yfnl=yfnl+py1/e1*taudcy
10562            zfnl=zfnl+pz1/e1*taudcy
10563            R(1,I)=xfnl
10564            R(2,I)=yfnl
10565            R(3,I)=zfnl
10566            tfdcy(I)=tfnl
10567            RPION(1,NNN,IRUN)=xfnl
10568            RPION(2,NNN,IRUN)=yfnl
10569            RPION(3,NNN,IRUN)=zfnl
10570            tfdpi(NNN,IRUN)=tfnl
10571            RPION(1,NNN+1,IRUN)=xfnl
10572            RPION(2,NNN+1,IRUN)=yfnl
10573            RPION(3,NNN+1,IRUN)=zfnl
10574            tfdpi(NNN+1,IRUN)=tfnl
10575         endif
10576
10577 cc 200    format(a30,2(1x,e10.4))
10578 cc 210    format(i6,5(1x,f8.3))
10579 cc 220    format(a2,i5,5(1x,f8.3))
10580
10581         RETURN
10582         END
10583 *---------------------------------------------------------------------------
10584 *---------------------------------------------------------------------------
10585 * PURPOSE : CALCULATE THE MASS AND MOMENTUM OF BARYON RESONANCE
10586 *           AFTER PION OR ETA BEING ABSORBED BY A NUCLEON
10587 * NOTE    :
10588 *
10589 * DATE    : JAN.29,1990
10590         SUBROUTINE DRESON(I1,I2)
10591         PARAMETER (MAXSTR=150001,MAXR=1,
10592      1  AMN=0.939457,AMP=0.93828,
10593      2  AP1=0.13496,AP2=0.13957,AM0=1.232,PI=3.1415926)
10594         COMMON /AA/ R(3,MAXSTR)
10595 cc      SAVE /AA/
10596         COMMON /BB/ P(3,MAXSTR)
10597 cc      SAVE /BB/
10598         COMMON /CC/ E(MAXSTR)
10599 cc      SAVE /CC/
10600         COMMON /EE/ ID(MAXSTR),LB(MAXSTR)
10601 cc      SAVE /EE/
10602         COMMON   /RUN/NUM
10603 cc      SAVE /RUN/
10604         COMMON   /PA/RPION(3,MAXSTR,MAXR)
10605 cc      SAVE /PA/
10606         COMMON   /PB/PPION(3,MAXSTR,MAXR)
10607 cc      SAVE /PB/
10608         COMMON   /PC/EPION(MAXSTR,MAXR)
10609 cc      SAVE /PC/
10610         COMMON   /PD/LPION(MAXSTR,MAXR)
10611 cc      SAVE /PD/
10612       SAVE
10613 * 1. DETERMINE THE MOMENTUM COMPONENT OF DELTA/N* IN THE LAB. FRAME
10614         E10=SQRT(E(I1)**2+P(1,I1)**2+P(2,I1)**2+P(3,I1)**2)
10615         E20=SQRT(E(I2)**2+P(1,I2)**2+P(2,I2)**2+P(3,I2)**2)
10616         IF(iabs(LB(I2)) .EQ. 1 .OR. iabs(LB(I2)) .EQ. 2 .OR.
10617      &     (iabs(LB(I2)) .GE. 6 .AND. iabs(LB(I2)) .LE. 17)) THEN
10618         E(I1)=0.
10619         I=I2
10620         ELSE
10621         E(I2)=0.
10622         I=I1
10623         ENDIF
10624         P(1,I)=P(1,I1)+P(1,I2)
10625         P(2,I)=P(2,I1)+P(2,I2)
10626         P(3,I)=P(3,I1)+P(3,I2)
10627 * 2. DETERMINE THE MASS OF DELTA/N* BY USING THE REACTION KINEMATICS
10628         DM=SQRT((E10+E20)**2-P(1,I)**2-P(2,I)**2-P(3,I)**2)
10629         E(I)=DM
10630         RETURN
10631         END
10632 *---------------------------------------------------------------------------
10633 * PURPOSE : CALCULATE THE MASS AND MOMENTUM OF RHO RESONANCE
10634 *           AFTER PION + PION COLLISION
10635 * DATE    : NOV. 30,1994
10636         SUBROUTINE RHORES(I1,I2)
10637         PARAMETER (MAXSTR=150001,MAXR=1,
10638      1  AMN=0.939457,AMP=0.93828,
10639      2  AP1=0.13496,AP2=0.13957,AM0=1.232,PI=3.1415926)
10640         COMMON /AA/ R(3,MAXSTR)
10641 cc      SAVE /AA/
10642         COMMON /BB/ P(3,MAXSTR)
10643 cc      SAVE /BB/
10644         COMMON /CC/ E(MAXSTR)
10645 cc      SAVE /CC/
10646         COMMON /EE/ ID(MAXSTR),LB(MAXSTR)
10647 cc      SAVE /EE/
10648         COMMON   /RUN/NUM
10649 cc      SAVE /RUN/
10650         COMMON   /PA/RPION(3,MAXSTR,MAXR)
10651 cc      SAVE /PA/
10652         COMMON   /PB/PPION(3,MAXSTR,MAXR)
10653 cc      SAVE /PB/
10654         COMMON   /PC/EPION(MAXSTR,MAXR)
10655 cc      SAVE /PC/
10656         COMMON   /PD/LPION(MAXSTR,MAXR)
10657 cc      SAVE /PD/
10658       SAVE
10659 * 1. DETERMINE THE MOMENTUM COMPONENT OF THE RHO IN THE CMS OF NN FRAME
10660 *    WE LET I1 TO BE THE RHO AND ABSORB I2
10661         E10=SQRT(E(I1)**2+P(1,I1)**2+P(2,I1)**2+P(3,I1)**2)
10662         E20=SQRT(E(I2)**2+P(1,I2)**2+P(2,I2)**2+P(3,I2)**2)
10663         P(1,I1)=P(1,I1)+P(1,I2)
10664         P(2,I1)=P(2,I1)+P(2,I2)
10665         P(3,I1)=P(3,I1)+P(3,I2)
10666 * 2. DETERMINE THE MASS OF THE RHO BY USING THE REACTION KINEMATICS
10667         DM=SQRT((E10+E20)**2-P(1,I1)**2-P(2,I1)**2-P(3,I1)**2)
10668         E(I1)=DM
10669        E(I2)=0
10670         RETURN
10671         END
10672 *---------------------------------------------------------------------------
10673 * PURPOSE : CALCULATE THE PION+NUCLEON CROSS SECTION ACCORDING TO THE
10674 *           BREIT-WIGNER FORMULA/(p*)**2
10675 * VARIABLE : LA = 1 FOR DELTA RESONANCE
10676 *            LA = 0 FOR N*(1440) RESONANCE
10677 *            LA = 2 FRO N*(1535) RESONANCE
10678 * DATE    : JAN.29,1990
10679         REAL FUNCTION XNPI(I1,I2,LA,XMAX)
10680         PARAMETER (MAXSTR=150001,MAXR=1,
10681      1  AMN=0.939457,AMP=0.93828,
10682      2  AP1=0.13496,AP2=0.13957,AM0=1.232,PI=3.1415926)
10683         COMMON /AA/ R(3,MAXSTR)
10684 cc      SAVE /AA/
10685         COMMON /BB/ P(3,MAXSTR)
10686 cc      SAVE /BB/
10687         COMMON /CC/ E(MAXSTR)
10688 cc      SAVE /CC/
10689         COMMON /EE/ ID(MAXSTR),LB(MAXSTR)
10690 cc      SAVE /EE/
10691         COMMON   /RUN/NUM
10692 cc      SAVE /RUN/
10693         COMMON   /PA/RPION(3,MAXSTR,MAXR)
10694 cc      SAVE /PA/
10695         COMMON   /PB/PPION(3,MAXSTR,MAXR)
10696 cc      SAVE /PB/
10697         COMMON   /PC/EPION(MAXSTR,MAXR)
10698 cc      SAVE /PC/
10699         COMMON   /PD/LPION(MAXSTR,MAXR)
10700 cc      SAVE /PD/
10701       SAVE
10702         AVMASS=0.5*(AMN+AMP)
10703         AVPI=(2.*AP2+AP1)/3.
10704 * 1. DETERMINE THE MOMENTUM COMPONENT OF DELTA IN THE LAB. FRAME
10705         E10=SQRT(E(I1)**2+P(1,I1)**2+P(2,I1)**2+P(3,I1)**2)
10706         E20=SQRT(E(I2)**2+P(1,I2)**2+P(2,I2)**2+P(3,I2)**2)
10707         P1=P(1,I1)+P(1,I2)
10708         P2=P(2,I1)+P(2,I2)
10709         P3=P(3,I1)+P(3,I2)
10710 * 2. DETERMINE THE MASS OF DELTA BY USING OF THE REACTION KINEMATICS
10711         DM=SQRT((E10+E20)**2-P1**2-P2**2-P3**2)
10712         IF(DM.LE.1.1) THEN
10713         XNPI=1.e-09
10714         RETURN
10715         ENDIF
10716 * 3. DETERMINE THE PION+NUCLEON CROSS SECTION ACCORDING TO THE
10717 *    BREIT-WIGNER FORMULA IN UNIT OF FM**2
10718         IF(LA.EQ.1)THEN
10719         GAM=WIDTH(DM)
10720         F1=0.25*GAM**2/(0.25*GAM**2+(DM-1.232)**2)
10721         PDELT2=0.051622
10722         GO TO 10
10723        ENDIF
10724        IF(LA.EQ.0)THEN
10725         GAM=W1440(DM)
10726         F1=0.25*GAM**2/(0.25*GAM**2+(DM-1.440)**2)
10727         PDELT2=0.157897
10728        GO TO 10
10729         ENDIF
10730        IF(LA.EQ.2)THEN
10731         GAM=W1535(DM)
10732         F1=0.25*GAM**2/(0.25*GAM**2+(DM-1.535)**2)
10733         PDELT2=0.2181
10734         ENDIF
10735 10      PSTAR2=((DM**2-AVMASS**2+AVPI**2)/(2.*DM))**2-AVPI**2
10736         IF(PSTAR2.LE.0.)THEN
10737         XNPI=1.e-09
10738         ELSE
10739 * give the cross section in unit of fm**2
10740         XNPI=F1*(PDELT2/PSTAR2)*XMAX/10.
10741         ENDIF
10742         RETURN
10743         END
10744 *------------------------------------------------------------------------------
10745 *****************************************
10746         REAL FUNCTION SIGMA(SRT,ID,IOI,IOF)
10747 *PURPOSE : THIS IS THE PROGRAM TO CALCULATE THE ISOSPIN DECOMPOSED CROSS
10748 *       SECTION BY USING OF B.J.VerWEST AND R.A.ARNDT'S PARAMETERIZATION
10749 *REFERENCE: PHYS. REV. C25(1982)1979
10750 *QUANTITIES: IOI -- INITIAL ISOSPIN OF THE TWO NUCLEON SYSTEM
10751 *            IOF -- FINAL   ISOSPIN -------------------------
10752 *            ID -- =1 FOR DELTA RESORANCE
10753 *                  =2 FOR N*    RESORANCE
10754 *DATE : MAY 15,1990
10755 *****************************************
10756         PARAMETER (AMU=0.9383,AMP=0.1384,PI=3.1415926,HC=0.19733)
10757       SAVE
10758         IF(ID.EQ.1)THEN
10759         AMASS0=1.22
10760         T0 =0.12
10761         ELSE
10762         AMASS0=1.43
10763         T0 =0.2
10764         ENDIF
10765         IF((IOI.EQ.1).AND.(IOF.EQ.1))THEN
10766         ALFA=3.772
10767         BETA=1.262
10768         AM0=1.188
10769         T=0.09902
10770         ENDIF
10771         IF((IOI.EQ.1).AND.(IOF.EQ.0))THEN
10772         ALFA=15.28
10773         BETA=0.
10774         AM0=1.245
10775         T=0.1374
10776         ENDIF
10777         IF((IOI.EQ.0).AND.(IOF.EQ.1))THEN
10778         ALFA=146.3
10779         BETA=0.
10780         AM0=1.472
10781         T=0.02649
10782         ENDIF
10783         ZPLUS=(SRT-AMU-AMASS0)*2./T0
10784         ZMINUS=(AMU+AMP-AMASS0)*2./T0
10785         deln=ATAN(ZPLUS)-ATAN(ZMINUS)
10786        if(deln.eq.0)deln=1.E-06
10787         AMASS=AMASS0+(T0/4.)*ALOG((1.+ZPLUS**2)/(1.+ZMINUS**2))
10788      1  /deln
10789         S=SRT**2
10790         P2=S/4.-AMU**2
10791         S0=(AMU+AM0)**2
10792         P02=S0/4.-AMU**2
10793         P0=SQRT(P02)
10794         PR2=(S-(AMU-AMASS)**2)*(S-(AMU+AMASS)**2)/(4.*S)
10795         IF(PR2.GT.1.E-06)THEN
10796         PR=SQRT(PR2)
10797         ELSE
10798         PR=0.
10799         SIGMA=1.E-06
10800         RETURN
10801         ENDIF
10802         SS=AMASS**2
10803         Q2=(SS-(AMU-AMP)**2)*(SS-(AMU+AMP)**2)/(4.*SS)
10804         IF(Q2.GT.1.E-06)THEN
10805         Q=SQRT(Q2)
10806         ELSE
10807         Q=0.
10808         SIGMA=1.E-06
10809         RETURN
10810         ENDIF
10811         SS0=AM0**2
10812         Q02=(SS0-(AMU-AMP)**2)*(SS0-(AMU+AMP)**2)/(4.*SS0)
10813         Q0=SQRT(Q02)
10814         SIGMA=PI*(HC)**2/(2.*P2)*ALFA*(PR/P0)**BETA*AM0**2*T**2
10815      1  *(Q/Q0)**3/((SS-AM0**2)**2+AM0**2*T**2)
10816         SIGMA=SIGMA*10.
10817        IF(SIGMA.EQ.0)SIGMA=1.E-06
10818         RETURN
10819         END
10820
10821 *****************************
10822         REAL FUNCTION DENOM(SRT,CON)
10823 * NOTE: CON=1 FOR DELTA RESONANCE, CON=2 FOR N*(1440) RESONANCE
10824 *       con=-1 for N*(1535)
10825 * PURPOSE : CALCULATE THE INTEGRAL IN THE DETAILED BALANCE
10826 *
10827 * DATE : NOV. 15, 1991
10828 *******************************
10829         PARAMETER (AP1=0.13496,
10830      1  AP2=0.13957,PI=3.1415926,AVMASS=0.9383)
10831       SAVE
10832         AVPI=(AP1+2.*AP2)/3.
10833         AM0=1.232
10834         AMN=AVMASS
10835         AMP=AVPI
10836         AMAX=SRT-AVMASS
10837         AMIN=AVMASS+AVPI
10838         NMAX=200
10839         DMASS=(AMAX-AMIN)/FLOAT(NMAX)
10840         SUM=0.
10841         DO 10 I=1,NMAX+1
10842         DM=AMIN+FLOAT(I-1)*DMASS
10843         IF(CON.EQ.1.)THEN
10844         Q2=((DM**2-AMN**2+AMP**2)/(2.*DM))**2-AMP**2
10845            IF(Q2.GT.0.)THEN
10846            Q=SQRT(Q2)
10847            ELSE
10848            Q=1.E-06
10849            ENDIF
10850         TQ=0.47*(Q**3)/(AMP**2*(1.+0.6*(Q/AMP)**2))
10851         ELSE if(con.eq.2)then
10852         TQ=0.2
10853         AM0=1.44
10854        else if(con.eq.-1.)then
10855        tq=0.1
10856        am0=1.535
10857         ENDIF
10858         A1=4.*TQ*AM0**2/(AM0**2*TQ**2+(DM**2-AM0**2)**2)
10859         S=SRT**2
10860         P0=(S+DM**2-AMN**2)**2/(4.*S)-DM**2
10861         IF(P0.LE.0.)THEN
10862         P1=1.E-06
10863         ELSE
10864         P1=SQRT(P0)
10865         ENDIF
10866         F=DM*A1*P1
10867         IF((I.EQ.1).OR.(I.EQ.(NMAX+1)))THEN
10868         SUM=SUM+F*0.5
10869         ELSE
10870         SUM=SUM+F
10871         ENDIF
10872 10      CONTINUE
10873         DENOM=SUM*DMASS/(2.*PI)
10874         RETURN
10875         END
10876 **********************************
10877 * subroutine : ang.FOR
10878 * PURPOSE : Calculate the angular distribution of Delta production process
10879 * DATE    : Nov. 19, 1992
10880 * REFERENCE: G. WOLF ET. AL., NUCL. PHYS. A517 (1990) 615
10881 * Note: this function applies when srt is larger than 2.14 GeV,
10882 * for less energetic reactions, we assume the angular distribution
10883 * is isotropic.
10884 ***********************************
10885        real function ang(srt,iseed)
10886       COMMON/RNDF77/NSEED
10887 cc      SAVE /RNDF77/
10888       SAVE
10889       ISEED=ISEED
10890 c        if(srt.le.2.14)then
10891 c       b1s=0.5
10892 c       b2s=0.
10893 c      endif
10894       if((srt.gt.2.14).and.(srt.le.2.4))then
10895        b1s=29.03-23.75*srt+4.865*srt**2
10896          b2s=-30.33+25.53*srt-5.301*srt**2
10897       endif
10898       if(srt.gt.2.4)then
10899        b1s=0.06
10900          b2s=0.4
10901       endif
10902         x=RANART(NSEED)
10903        p=b1s/b2s
10904        q=(2.*x-1.)*(b1s+b2s)/b2s
10905        IF((-q/2.+sqrt((q/2.)**2+(p/3.)**3)).GE.0.)THEN
10906        ang1=(-q/2.+sqrt((q/2.)**2+(p/3.)**3))**(1./3.)
10907        ELSE
10908        ang1=-(q/2.-sqrt((q/2.)**2+(p/3.)**3))**(1./3.)
10909        ENDIF
10910        IF((-q/2.-sqrt((q/2.)**2+(p/3.)**3).GE.0.))THEN
10911        ang2=(-q/2.-sqrt((q/2.)**2+(p/3.)**3))**(1./3.)
10912        ELSE
10913        ang2=-(q/2.+sqrt((q/2.)**2+(p/3.)**3))**(1./3.)
10914        ENDIF
10915        ANG=ANG1+ANG2
10916        return
10917        end
10918 *--------------------------------------------------------------------------
10919 *****subprogram * kaon production from pi+B collisions *******************
10920       real function PNLKA(srt)
10921       SAVE
10922 * units: fm**2
10923 ***********************************C
10924       ala=1.116
10925       aka=0.498
10926       ana=0.939
10927       t1=ala+aka
10928       if(srt.le.t1) THEN
10929       Pnlka=0
10930       Else
10931       IF(SRT.LT.1.7)sbbk=(0.9/0.091)*(SRT-T1)
10932       IF(SRT.GE.1.7)sbbk=0.09/(SRT-1.6)
10933       Pnlka=0.25*sbbk
10934 * give the cross section in units of fm**2
10935        pnlka=pnlka/10.
10936       endif
10937       return
10938       end
10939 *-------------------------------------------------------------------------
10940 *****subprogram * kaon production from pi+B collisions *******************
10941       real function PNSKA(srt)
10942       SAVE
10943 ***********************************
10944        if(srt.gt.3.0)then
10945        pnska=0
10946        return
10947        endif
10948       ala=1.116
10949       aka=0.498
10950       ana=0.939
10951       asa=1.197
10952       t1=asa+aka
10953       if(srt.le.t1) THEN
10954       Pnska=0
10955        return
10956       Endif
10957       IF(SRT.LT.1.9)SBB1=(0.7/0.218)*(SRT-T1)
10958       IF(SRT.GE.1.9)SBB1=0.14/(SRT-1.7)
10959       sbb2=0.
10960        if(srt.gT.1.682)sbb2=0.5*(1.-0.75*(srt-1.682))
10961        pnska=0.25*(sbb1+sbb2)
10962 * give the cross section in fm**2
10963        pnska=pnska/10.
10964       return
10965       end
10966
10967 ********************************
10968 *
10969 *       Kaon momentum distribution in baryon-baryon-->N lamda K process
10970 *
10971 *       NOTE: dsima/dp is prototional to (1-p/p_max)(p/p_max)^2
10972 *              we use rejection method to generate kaon momentum
10973 *
10974 *       Variables: Fkaon = F(p)/F_max
10975 *                 srt   = cms energy of the colliding pair,
10976 *                          used to calculate the P_max
10977 *       Date: Feb. 8, 1994
10978 *
10979 *       Reference: C. M. Ko et al.
10980 ********************************
10981        Real function fkaon(p,pmax)
10982       SAVE
10983        fmax=0.148
10984        if(pmax.eq.0.)pmax=0.000001
10985        fkaon=(1.-p/pmax)*(p/pmax)**2
10986        if(fkaon.gt.fmax)fkaon=fmax
10987        fkaon=fkaon/fmax
10988        return
10989        end
10990
10991 *************************
10992 * cross section for N*(1535) production in ND OR NN* collisions
10993 * VARIABLES:
10994 * LB1,LB2 ARE THE LABLES OF THE TWO COLLIDING PARTICLES
10995 * SRT IS THE CMS ENERGY
10996 * X1535 IS THE N*(1535) PRODUCTION CROSS SECTION
10997 * NOTE THAT THE N*(1535) PRODUCTION CROSS SECTION IS 2 TIMES THE ETA
10998 * PRODUCTION CROSS SECTION
10999 * DATE: MAY 18, 1994
11000 * ***********************
11001        Subroutine M1535(LB1,LB2,SRT,X1535)
11002       SAVE
11003        S0=2.424
11004        x1535=0.
11005        IF(SRT.LE.S0)RETURN
11006        SIGMA=2.*0.102*(SRT-S0)/(0.058+(SRT-S0)**2)
11007 * I N*(1535) PRODUCTION IN NUCLEON-DELTA COLLISIONS
11008 *(1) nD(++)->pN*(+)(1535), pD(-)->nN*(0)(1535),pD(+)-->N*(+)p
11009 cbz11/25/98
11010 c       IF((LB1*LB2.EQ.18).OR.(LB1*LB2.EQ.6).
11011 c     1  or.(lb1*lb2).eq.8)then
11012        IF((LB1*LB2.EQ.18.AND.(LB1.EQ.2.OR.LB2.EQ.2)).OR.
11013      &     (LB1*LB2.EQ.6.AND.(LB1.EQ.1.OR.LB2.EQ.1)).or.
11014      &     (lb1*lb2.eq.8.AND.(LB1.EQ.1.OR.LB2.EQ.1)))then
11015 cbz11/25/98end
11016        X1535=SIGMA
11017        return
11018        ENDIF
11019 *(2) pD(0)->pN*(0)(1535),pD(0)->nN*(+)(1535)
11020        IF(LB1*LB2.EQ.7)THEN
11021        X1535=3.*SIGMA
11022        RETURN
11023        ENDIF
11024 * II N*(1535) PRODUCTION IN N*(1440)+NUCLEON REACTIONS
11025 *(3) N*(+)(1440)p->N*(0+)(1535)p, N*(0)(1440)n->N*(0)(1535)
11026 cbz11/25/98
11027 c       IF((LB1*LB2.EQ.11).OR.(LB1*LB2.EQ.20))THEN
11028        IF((LB1*LB2.EQ.11).OR.
11029      &     (LB1*LB2.EQ.20.AND.(LB1.EQ.2.OR.LB2.EQ.2)))THEN
11030 cbz11/25/98end
11031        X1535=SIGMA
11032        RETURN
11033        ENDIF
11034 *(4) N*(0)(1440)p->N*(0+) or N*(+)(1440)n->N*(0+)(1535)
11035 cbz11/25/98
11036 c       IF((LB1*LB2.EQ.10).OR.(LB1*LB2.EQ.22))X1535=3.*SIGMA
11037        IF((LB1*LB2.EQ.10.AND.(LB1.EQ.1.OR.LB2.EQ.1)).OR.
11038      &     (LB1*LB2.EQ.22.AND.(LB1.EQ.2.OR.LB2.EQ.2)))
11039      &     X1535=3.*SIGMA
11040 cbz11/25/98end
11041        RETURN
11042        END
11043 *************************
11044 * cross section for N*(1535) production in NN collisions
11045 * VARIABLES:
11046 * LB1,LB2 ARE THE LABLES OF THE TWO COLLIDING PARTICLES
11047 * SRT IS THE CMS ENERGY
11048 * X1535 IS THE N*(1535) PRODUCTION CROSS SECTION
11049 * NOTE THAT THE N*(1535) PRODUCTION CROSS SECTION IS 2 TIMES THE ETA
11050 * PRODUCTION CROSS SECTION
11051 * DATE: MAY 18, 1994
11052 * ***********************
11053        Subroutine N1535(LB1,LB2,SRT,X1535)
11054       SAVE
11055        S0=2.424
11056        x1535=0.
11057        IF(SRT.LE.S0)RETURN
11058        SIGMA=2.*0.102*(SRT-S0)/(0.058+(SRT-S0)**2)
11059 * I N*(1535) PRODUCTION IN NUCLEON-NUCLEON COLLISIONS
11060 *(1) pp->pN*(+)(1535), nn->nN*(0)(1535)
11061 cbdbg11/25/98
11062 c       IF((LB1*LB2.EQ.1).OR.(LB1*LB2.EQ.4))then
11063        IF((LB1*LB2.EQ.1).OR.
11064      &     (LB1.EQ.2.AND.LB2.EQ.2))then
11065 cbz11/25/98end
11066        X1535=SIGMA
11067        return
11068        endif
11069 *(2) pn->pN*(0)(1535),pn->nN*(+)(1535)
11070        IF(LB1*LB2.EQ.2)then
11071        X1535=3.*SIGMA
11072        return
11073        endif
11074 * III N*(1535) PRODUCTION IN DELTA+DELTA REACTIONS
11075 * (5) D(++)+D(0), D(+)+D(+),D(+)+D(-),D(0)+D(0)
11076 cbz11/25/98
11077 c       IF((LB1*LB2.EQ.63).OR.(LB1*LB2.EQ.64).OR.(LB1*LB2.EQ.48).
11078 c     1  OR.(LB1*LB2.EQ.49))then
11079        IF((LB1*LB2.EQ.63.AND.(LB1.EQ.7.OR.LB2.EQ.7)).OR.
11080      &     (LB1*LB2.EQ.64.AND.(LB1.EQ.8.OR.LB2.EQ.8)).OR.
11081      &     (LB1*LB2.EQ.48.AND.(LB1.EQ.6.OR.LB2.EQ.6)).OR.
11082      &     (LB1*LB2.EQ.49.AND.(LB1.EQ.7.OR.LB2.EQ.7)))then
11083 cbz11/25/98end
11084        X1535=SIGMA
11085        return
11086        endif
11087 * (6) D(++)+D(-),D(+)+D(0)
11088 cbz11/25/98
11089 c       IF((LB1*LB2.EQ.54).OR.(LB1*LB2.EQ.56))then
11090        IF((LB1*LB2.EQ.54.AND.(LB1.EQ.6.OR.LB2.EQ.6)).OR.
11091      &     (LB1*LB2.EQ.56.AND.(LB1.EQ.7.OR.LB2.EQ.7)))then
11092 cbz11/25/98end
11093        X1535=3.*SIGMA
11094        return
11095        endif
11096 * IV N*(1535) PRODUCTION IN N*(1440)+N*(1440) REACTIONS
11097 cbz11/25/98
11098 c       IF((LB1*LB2.EQ.100).OR.(LB1*LB2.EQ.11*11))X1535=SIGMA
11099        IF((LB1.EQ.10.AND.LB2.EQ.10).OR.
11100      &     (LB1.EQ.11.AND.LB2.EQ.11))X1535=SIGMA
11101 c       IF(LB1*LB2.EQ.110)X1535=3.*SIGMA
11102        IF(LB1*LB2.EQ.110.AND.(LB1.EQ.10.OR.LB2.EQ.10))X1535=3.*SIGMA
11103 cbdbg11/25/98end
11104        RETURN
11105        END
11106 ************************************
11107 * FUNCTION WA1(DMASS) GIVES THE A1 DECAY WIDTH
11108
11109         subroutine WIDA1(DMASS,rhomp,wa1,iseed)
11110       SAVE
11111 c
11112         PIMASS=0.137265
11113         coupa = 14.8
11114 c
11115        RHOMAX = DMASS-PIMASS-0.02
11116        IF(RHOMAX.LE.0)then
11117          rhomp=0.
11118 c   !! no decay
11119          wa1=-10.
11120         endif
11121         icount = 0
11122 711       rhomp=RHOMAS(RHOMAX,ISEED)
11123       icount=icount+1
11124       if(dmass.le.(pimass+rhomp)) then
11125        if(icount.le.100) then
11126         goto 711
11127        else
11128          rhomp=0.
11129 c   !! no decay
11130          wa1=-10.
11131         return
11132        endif
11133       endif
11134       qqp2=(dmass**2-(rhomp+pimass)**2)*(dmass**2-(rhomp-pimass)**2)
11135       qqp=sqrt(qqp2)/(2.0*dmass)
11136       epi=sqrt(pimass**2+qqp**2)
11137       erho=sqrt(rhomp**2+qqp**2)
11138       epirho=2.0*(epi*erho+qqp**2)**2+rhomp**2*epi**2
11139       wa1=coupa**2*qqp*epirho/(24.0*3.1416*dmass**2)
11140        return
11141        end
11142 ************************************
11143 * FUNCTION W1535(DMASS) GIVES THE N*(1535) DECAY WIDTH
11144 c     FOR A GIVEN N*(1535) MASS
11145 * HERE THE FORMULA GIVEN BY KITAZOE IS USED
11146         REAL FUNCTION W1535(DMASS)
11147       SAVE
11148         AVMASS=0.938868
11149         PIMASS=0.137265
11150            AUX = 0.25*(DMASS**2-AVMASS**2-PIMASS**2)**2
11151      &           -(AVMASS*PIMASS)**2
11152             IF (AUX .GT. 0.) THEN
11153               QAVAIL = SQRT(AUX / DMASS**2)
11154             ELSE
11155               QAVAIL = 1.E-06
11156             END IF
11157             W1535 = 0.15* QAVAIL/0.467
11158 c       W1535=0.15
11159         RETURN
11160         END
11161 ************************************
11162 * FUNCTION W1440(DMASS) GIVES THE N*(1440) DECAY WIDTH
11163 c     FOR A GIVEN N*(1535) MASS
11164 * HERE THE FORMULA GIVEN BY KITAZOE IS USED
11165         REAL FUNCTION W1440(DMASS)
11166       SAVE
11167         AVMASS=0.938868
11168         PIMASS=0.137265
11169            AUX = 0.25*(DMASS**2-AVMASS**2-PIMASS**2)**2
11170      &           -(AVMASS*PIMASS)**2
11171             IF (AUX .GT. 0.) THEN
11172               QAVAIL = SQRT(AUX)/DMASS
11173             ELSE
11174               QAVAIL = 1.E-06
11175             END IF
11176 c              w1440=0.2
11177            W1440 = 0.2* (QAVAIL/0.397)**3
11178         RETURN
11179         END
11180 ****************
11181 * PURPOSE : CALCULATE THE PION(ETA)+NUCLEON CROSS SECTION
11182 *           ACCORDING TO THE BREIT-WIGNER FORMULA,
11183 *           NOTE THAT N*(1535) IS S_11
11184 * VARIABLE : LA = 1 FOR PI+N
11185 *            LA = 0 FOR ETA+N
11186 * DATE    : MAY 16, 1994
11187 ****************
11188         REAL FUNCTION XN1535(I1,I2,LA)
11189         PARAMETER (MAXSTR=150001,MAXR=1,
11190      1  AMN=0.939457,AMP=0.93828,ETAM=0.5475,
11191      2  AP1=0.13496,AP2=0.13957,AM0=1.232,PI=3.1415926)
11192         COMMON /AA/ R(3,MAXSTR)
11193 cc      SAVE /AA/
11194         COMMON /BB/ P(3,MAXSTR)
11195 cc      SAVE /BB/
11196         COMMON /CC/ E(MAXSTR)
11197 cc      SAVE /CC/
11198         COMMON /EE/ ID(MAXSTR),LB(MAXSTR)
11199 cc      SAVE /EE/
11200         COMMON   /RUN/NUM
11201 cc      SAVE /RUN/
11202         COMMON   /PA/RPION(3,MAXSTR,MAXR)
11203 cc      SAVE /PA/
11204         COMMON   /PB/PPION(3,MAXSTR,MAXR)
11205 cc      SAVE /PB/
11206         COMMON   /PC/EPION(MAXSTR,MAXR)
11207 cc      SAVE /PC/
11208         COMMON   /PD/LPION(MAXSTR,MAXR)
11209 cc      SAVE /PD/
11210       SAVE
11211         AVMASS=0.5*(AMN+AMP)
11212         AVPI=(2.*AP2+AP1)/3.
11213 * 1. DETERMINE THE MOMENTUM COMPONENT OF N*(1535) IN THE LAB. FRAME
11214         E10=SQRT(E(I1)**2+P(1,I1)**2+P(2,I1)**2+P(3,I1)**2)
11215         E20=SQRT(E(I2)**2+P(1,I2)**2+P(2,I2)**2+P(3,I2)**2)
11216         P1=P(1,I1)+P(1,I2)
11217         P2=P(2,I1)+P(2,I2)
11218         P3=P(3,I1)+P(3,I2)
11219 * 2. DETERMINE THE MASS OF DELTA BY USING OF THE REACTION KINEMATICS
11220         DM=SQRT((E10+E20)**2-P1**2-P2**2-P3**2)
11221         IF(DM.LE.1.1) THEN
11222         XN1535=1.E-06
11223         RETURN
11224         ENDIF
11225 * 3. DETERMINE THE PION(ETA)+NUCLEON->N*(1535) CROSS SECTION ACCORDING TO THE
11226 *    BREIT-WIGNER FORMULA IN UNIT OF FM**2
11227         GAM=W1535(DM)
11228        GAM0=0.15
11229         F1=0.25*GAM0**2/(0.25*GAM**2+(DM-1.535)**2)
11230         IF(LA.EQ.1)THEN
11231        XMAX=11.3
11232         ELSE
11233        XMAX=74.
11234         ENDIF
11235         XN1535=F1*XMAX/10.
11236         RETURN
11237         END
11238 ***************************8
11239 *FUNCTION FDE(DMASS) GIVES DELTA MASS DISTRIBUTION BY USING OF
11240 *KITAZOE'S FORMULA
11241         REAL FUNCTION FDELTA(DMASS)
11242       SAVE
11243         AMN=0.938869
11244         AVPI=0.13803333
11245         AM0=1.232
11246         FD=0.25*WIDTH(DMASS)**2/((DMASS-1.232)**2
11247      1  +0.25*WIDTH(DMASS)**2)
11248         FDELTA=FD
11249         RETURN
11250         END
11251 * FUNCTION WIDTH(DMASS) GIVES THE DELTA DECAY WIDTH FOR A GIVEN DELTA MASS
11252 * HERE THE FORMULA GIVEN BY KITAZOE IS USED
11253         REAL FUNCTION WIDTH(DMASS)
11254       SAVE
11255         AVMASS=0.938868
11256         PIMASS=0.137265
11257            AUX = 0.25*(DMASS**2-AVMASS**2-PIMASS**2)**2
11258      &           -(AVMASS*PIMASS)**2
11259             IF (AUX .GT. 0.) THEN
11260               QAVAIL = SQRT(AUX / DMASS**2)
11261             ELSE
11262               QAVAIL = 1.E-06
11263             END IF
11264             WIDTH = 0.47 * QAVAIL**3 /
11265      &              (PIMASS**2 * (1.+0.6*(QAVAIL/PIMASS)**2))
11266 c       width=0.115
11267         RETURN
11268         END
11269 ************************************
11270         SUBROUTINE ddp2(SRT,ISEED,PX,PY,PZ,DM1,PNX,
11271      &  PNY,PNZ,DM2,PPX,PPY,PPZ,icou1)
11272 * PURPOSE : CALCULATE MOMENTUM OF PARTICLES IN THE FINAL SATAT FROM
11273 * THE PROCESS N+N--->D1+D2+PION
11274 *       DATE : July 25, 1994
11275 * Generate the masses and momentum for particles in the NN-->DDpi process
11276 * for a given center of mass energy srt, the momenta are given in the center
11277 * of mass of the NN
11278 *****************************************
11279         COMMON/TABLE/ xarray(0:1000),earray(0:1000)
11280 cc      SAVE /TABLE/
11281       COMMON/RNDF77/NSEED
11282 cc      SAVE /RNDF77/
11283       SAVE
11284        icou1=0
11285        pi=3.1415926
11286         AMN=938.925/1000.
11287         AMP=137.265/1000.
11288 * (1) GENGRATE THE MASS OF DELTA1 AND DELTA2 USING
11289        srt1=srt-amp-0.02
11290        ntrym=0
11291 8       call Rmasdd(srt1,1.232,1.232,1.08,
11292      &  1.08,ISEED,1,dm1,dm2)
11293        ntrym=ntrym+1
11294 * CONSTANTS FOR GENERATING THE LONGITUDINAL MOMENTUM
11295 * FOR ONE OF THE RESONANCES
11296        V=0.43
11297        W=-0.84
11298 * (2) Generate the transverse momentum
11299 *     OF DELTA1
11300 * (2.1) estimate the maximum transverse momentum
11301        PTMAX2=(SRT**2-(DM1+DM2+AMP)**2)*
11302      1  (SRT**2-(DM1-AMP-DM2)**2)/4./SRT**2
11303        if(ptmax2.le.0)go to 8
11304        PTMAX=SQRT(PTMAX2)*1./3.
11305 7       PT=PTR(PTMAX,ISEED)
11306 * (3.1) THE MAXIMUM LONGITUDINAL MOMENTUM IS
11307        PZMAX2=(SRT**2-(DM1+DM2+AMP)**2)*
11308      1  (SRT**2-(DM1-AMP-DM2)**2)/4./SRT**2-PT**2
11309        IF((PZMAX2.LT.0.).and.ntrym.le.100)then
11310        go to 7
11311        else
11312        pzmax2=1.E-09
11313        endif
11314        PZMAX=SQRT(PZMAX2)
11315        XMAX=2.*PZMAX/SRT
11316 * (3.2) THE GENERATED X IS
11317 * THE DSTRIBUTION HAS A MAXIMUM AT X0=-V/(2*w), f(X0)=1.056
11318        ntryx=0
11319        fmax00=1.056
11320        x00=0.26
11321        if(abs(xmax).gt.0.26)then
11322        f00=fmax00
11323        else
11324        f00=1.+v*abs(xmax)+w*xmax**2
11325        endif
11326 9       X=XMAX*(1.-2.*RANART(NSEED))
11327        ntryx=ntryx+1
11328        xratio=(1.+V*ABS(X)+W*X**2)/f00
11329 clin-8/17/00       IF(xratio.LT.RANART(NSEED).and.ntryx.le.50)GO TO 9
11330        IF(xratio.LT.RANART(NSEED).and.ntryx.le.50)GO TO 9
11331 * (3.5) THE PZ IS
11332        PZ=0.5*SRT*X
11333 * The x and y components of the deltA1
11334        fai=2.*pi*RANART(NSEED)
11335        Px=pt*cos(fai)
11336        Py=pt*sin(fai)
11337 * find the momentum of delta2 and pion
11338 * the energy of the delta1
11339        ek=sqrt(dm1**2+PT**2+Pz**2)
11340 * (1) Generate the momentum of the delta2 in the cms of delta2 and pion
11341 *     the energy of the cms of DP
11342         eln=srt-ek
11343        IF(ELN.lE.0)then
11344        icou1=-1
11345        return
11346        endif
11347 * beta and gamma of the cms of delta2+pion
11348        bx=-Px/eln
11349        by=-Py/eln
11350        bz=-Pz/eln
11351        ga=1./sqrt(1.-bx**2-by**2-bz**2)
11352 * the momentum of delta2 and pion in their cms frame
11353        elnc=eln/ga
11354        pn2=((elnc**2+dm2**2-amp**2)/(2.*elnc))**2-dm2**2
11355        if(pn2.le.0)then
11356        icou1=-1
11357        return
11358        endif
11359        pn=sqrt(pn2)
11360
11361 clin-10/25/02 get rid of argument usage mismatch in PTR():
11362         xptr=0.33*PN
11363 c       PNT=PTR(0.33*PN,ISEED)
11364        PNT=PTR(xptr,ISEED)
11365 clin-10/25/02-end
11366
11367        fain=2.*pi*RANART(NSEED)
11368        pnx=pnT*cos(fain)
11369        pny=pnT*sin(fain)
11370        SIG=1
11371        IF(X.GT.0)SIG=-1
11372        pnz=SIG*SQRT(pn**2-PNT**2)
11373        en=sqrt(dm2**2+pnx**2+pny**2+pnz**2)
11374 * (2) the momentum for the pion
11375        ppx=-pnx
11376        ppy=-pny
11377        ppz=-pnz
11378        ep=sqrt(amp**2+ppx**2+ppy**2+ppz**2)
11379 * (3) for the delta2, LORENTZ-TRANSFORMATION INTO nn cms FRAME
11380         PBETA  = PnX*BX + PnY*By+ PnZ*Bz
11381               TRANS0  = GA * ( GA * PBETA / (GA + 1.) + En )
11382               Pnx = BX * TRANS0 + PnX
11383               Pny = BY * TRANS0 + PnY
11384               Pnz = BZ * TRANS0 + PnZ
11385 * (4) for the pion, LORENTZ-TRANSFORMATION INTO nn cms FRAME
11386              if(ep.eq.0.)ep=1.E-09
11387               PBETA  = PPX*BX + PPY*By+ PPZ*Bz
11388               TRANS0  = GA * ( GA * PBETA / (GA + 1.) + EP )
11389               PPx = BX * TRANS0 + PPX
11390               PPy = BY * TRANS0 + PPY
11391               PPz = BZ * TRANS0 + PPZ
11392        return
11393        end
11394 ****************************************
11395         SUBROUTINE ddrho(SRT,ISEED,PX,PY,PZ,DM1,PNX,
11396      &  PNY,PNZ,DM2,PPX,PPY,PPZ,amp,icou1)
11397 * PURPOSE : CALCULATE MOMENTUM OF PARTICLES IN THE FINAL SATAT FROM
11398 * THE PROCESS N+N--->D1+D2+rho
11399 *       DATE : Nov.5, 1994
11400 * Generate the masses and momentum for particles in the NN-->DDrho process
11401 * for a given center of mass energy srt, the momenta are given in the center
11402 * of mass of the NN
11403 *****************************************
11404         COMMON/TABLE/ xarray(0:1000),earray(0:1000)
11405 cc      SAVE /TABLE/
11406       COMMON/RNDF77/NSEED
11407 cc      SAVE /RNDF77/
11408       SAVE
11409        icou1=0
11410        pi=3.1415926
11411         AMN=938.925/1000.
11412         AMP=770./1000.
11413 * (1) GENGRATE THE MASS OF DELTA1 AND DELTA2 USING
11414        srt1=srt-amp-0.02
11415        ntrym=0
11416 8       call Rmasdd(srt1,1.232,1.232,1.08,
11417      &  1.08,ISEED,1,dm1,dm2)
11418        ntrym=ntrym+1
11419 * GENERATE THE MASS FOR THE RHO
11420        RHOMAX = SRT-DM1-DM2-0.02
11421        IF(RHOMAX.LE.0.and.ntrym.le.20)go to 8
11422        AMP=RHOMAS(RHOMAX,ISEED)
11423 * CONSTANTS FOR GENERATING THE LONGITUDINAL MOMENTUM
11424 * FOR ONE OF THE RESONANCES
11425        V=0.43
11426        W=-0.84
11427 * (2) Generate the transverse momentum
11428 *     OF DELTA1
11429 * (2.1) estimate the maximum transverse momentum
11430        PTMAX2=(SRT**2-(DM1+DM2+AMP)**2)*
11431      1  (SRT**2-(DM1-AMP-DM2)**2)/4./SRT**2
11432        PTMAX=SQRT(PTMAX2)*1./3.
11433 7       PT=PTR(PTMAX,ISEED)
11434 * (3) GENGRATE THE LONGITUDINAL MOMENTUM FOR DM1
11435 *     USING THE GIVEN DISTRIBUTION
11436 * (3.1) THE MAXIMUM LONGITUDINAL MOMENTUM IS
11437        PZMAX2=(SRT**2-(DM1+DM2+AMP)**2)*
11438      1  (SRT**2-(DM1-AMP-DM2)**2)/4./SRT**2-PT**2
11439        IF((PZMAX2.LT.0.).and.ntrym.le.100)then
11440        go to 7
11441        else
11442        pzmax2=1.E-06
11443        endif
11444        PZMAX=SQRT(PZMAX2)
11445        XMAX=2.*PZMAX/SRT
11446 * (3.2) THE GENERATED X IS
11447 * THE DSTRIBUTION HAS A MAXIMUM AT X0=-V/(2*w), f(X0)=1.056
11448        ntryx=0
11449        fmax00=1.056
11450        x00=0.26
11451        if(abs(xmax).gt.0.26)then
11452        f00=fmax00
11453        else
11454        f00=1.+v*abs(xmax)+w*xmax**2
11455        endif
11456 9       X=XMAX*(1.-2.*RANART(NSEED))
11457        ntryx=ntryx+1
11458        xratio=(1.+V*ABS(X)+W*X**2)/f00
11459 clin-8/17/00       IF(xratio.LT.RANART(NSEED).and.ntryx.le.50)GO TO 9
11460        IF(xratio.LT.RANART(NSEED).and.ntryx.le.50)GO TO 9
11461 * (3.5) THE PZ IS
11462        PZ=0.5*SRT*X
11463 * The x and y components of the delta1
11464        fai=2.*pi*RANART(NSEED)
11465        Px=pt*cos(fai)
11466        Py=pt*sin(fai)
11467 * find the momentum of delta2 and rho
11468 * the energy of the delta1
11469        ek=sqrt(dm1**2+PT**2+Pz**2)
11470 * (1) Generate the momentum of the delta2 in the cms of delta2 and rho
11471 *     the energy of the cms of Drho
11472         eln=srt-ek
11473        IF(ELN.lE.0)then
11474        icou1=-1
11475        return
11476        endif
11477 * beta and gamma of the cms of delta2 and rho
11478        bx=-Px/eln
11479        by=-Py/eln
11480        bz=-Pz/eln
11481        ga=1./sqrt(1.-bx**2-by**2-bz**2)
11482        elnc=eln/ga
11483        pn2=((elnc**2+dm2**2-amp**2)/(2.*elnc))**2-dm2**2
11484        if(pn2.le.0)then
11485        icou1=-1
11486        return
11487        endif
11488        pn=sqrt(pn2)
11489
11490 clin-10/25/02 get rid of argument usage mismatch in PTR():
11491         xptr=0.33*PN
11492 c       PNT=PTR(0.33*PN,ISEED)
11493        PNT=PTR(xptr,ISEED)
11494 clin-10/25/02-end
11495
11496        fain=2.*pi*RANART(NSEED)
11497        pnx=pnT*cos(fain)
11498        pny=pnT*sin(fain)
11499        SIG=1
11500        IF(X.GT.0)SIG=-1
11501        pnz=SIG*SQRT(pn**2-PNT**2)
11502        en=sqrt(dm2**2+pnx**2+pny**2+pnz**2)
11503 * (2) the momentum for the rho
11504        ppx=-pnx
11505        ppy=-pny
11506        ppz=-pnz
11507        ep=sqrt(amp**2+ppx**2+ppy**2+ppz**2)
11508 * (3) for the delta2, LORENTZ-TRANSFORMATION INTO nn cms FRAME
11509         PBETA  = PnX*BX + PnY*By+ PnZ*Bz
11510               TRANS0  = GA * ( GA * PBETA / (GA + 1.) + En )
11511               Pnx = BX * TRANS0 + PnX
11512               Pny = BY * TRANS0 + PnY
11513               Pnz = BZ * TRANS0 + PnZ
11514 * (4) for the rho, LORENTZ-TRANSFORMATION INTO nn cms FRAME
11515              if(ep.eq.0.)ep=1.e-09
11516               PBETA  = PPX*BX + PPY*By+ PPZ*Bz
11517               TRANS0  = GA * ( GA * PBETA / (GA + 1.) + EP )
11518               PPx = BX * TRANS0 + PPX
11519               PPy = BY * TRANS0 + PPY
11520               PPz = BZ * TRANS0 + PPZ
11521        return
11522        end
11523 ****************************************
11524         SUBROUTINE pprho(SRT,ISEED,PX,PY,PZ,DM1,PNX,
11525      &  PNY,PNZ,DM2,PPX,PPY,PPZ,amp,icou1)
11526 * PURPOSE : CALCULATE MOMENTUM OF PARTICLES IN THE FINAL SATAT FROM
11527 * THE PROCESS N+N--->N1+N2+rho
11528 *       DATE : Nov.5, 1994
11529 * Generate the masses and momentum for particles in the NN--> process
11530 * for a given center of mass energy srt, the momenta are given in the center
11531 * of mass of the NN
11532 *****************************************
11533         COMMON/TABLE/ xarray(0:1000),earray(0:1000)
11534 cc      SAVE /TABLE/
11535       COMMON/RNDF77/NSEED
11536 cc      SAVE /RNDF77/
11537       SAVE
11538         ntrym=0
11539        icou1=0
11540        pi=3.1415926
11541         AMN=938.925/1000.
11542 *        AMP=770./1000.
11543        DM1=amn
11544        DM2=amn
11545 * GENERATE THE MASS FOR THE RHO
11546        RHOMAX=SRT-DM1-DM2-0.02
11547        IF(RHOMAX.LE.0)THEN
11548        ICOU=-1
11549        RETURN
11550        ENDIF
11551        AMP=RHOMAS(RHOMAX,ISEED)
11552 * CONSTANTS FOR GENERATING THE LONGITUDINAL MOMENTUM
11553 * FOR ONE OF THE nucleons
11554        V=0.43
11555        W=-0.84
11556 * (2) Generate the transverse momentum
11557 *     OF p1
11558 * (2.1) estimate the maximum transverse momentum
11559        PTMAX2=(SRT**2-(DM1+DM2+AMP)**2)*
11560      1  (SRT**2-(DM1-AMP-DM2)**2)/4./SRT**2
11561        PTMAX=SQRT(PTMAX2)*1./3.
11562 7       PT=PTR(PTMAX,ISEED)
11563 * (3) GENGRATE THE LONGITUDINAL MOMENTUM FOR DM1
11564 *     USING THE GIVEN DISTRIBUTION
11565 * (3.1) THE MAXIMUM LONGITUDINAL MOMENTUM IS
11566        PZMAX2=(SRT**2-(DM1+DM2+AMP)**2)*
11567      1  (SRT**2-(DM1-AMP-DM2)**2)/4./SRT**2-PT**2
11568        NTRYM=NTRYM+1
11569        IF((PZMAX2.LT.0.).and.ntrym.le.100)then
11570        go to 7
11571        else
11572        pzmax2=1.E-06
11573        endif
11574        PZMAX=SQRT(PZMAX2)
11575        XMAX=2.*PZMAX/SRT
11576 * (3.2) THE GENERATED X IS
11577 * THE DSTRIBUTION HAS A MAXIMUM AT X0=-V/(2*w), f(X0)=1.056
11578        ntryx=0
11579        fmax00=1.056
11580        x00=0.26
11581        if(abs(xmax).gt.0.26)then
11582        f00=fmax00
11583        else
11584        f00=1.+v*abs(xmax)+w*xmax**2
11585        endif
11586 9       X=XMAX*(1.-2.*RANART(NSEED))
11587        ntryx=ntryx+1
11588        xratio=(1.+V*ABS(X)+W*X**2)/f00
11589 clin-8/17/00       IF(xratio.LT.RANART(NSEED).and.ntryx.le.50)GO TO 9
11590        IF(xratio.LT.RANART(NSEED).and.ntryx.le.50)GO TO 9
11591 * (3.5) THE PZ IS
11592        PZ=0.5*SRT*X
11593 * The x and y components of the delta1
11594        fai=2.*pi*RANART(NSEED)
11595        Px=pt*cos(fai)
11596        Py=pt*sin(fai)
11597 * find the momentum of delta2 and rho
11598 * the energy of the delta1
11599        ek=sqrt(dm1**2+PT**2+Pz**2)
11600 * (1) Generate the momentum of the delta2 in the cms of delta2 and rho
11601 *     the energy of the cms of Drho
11602         eln=srt-ek
11603        IF(ELN.lE.0)then
11604        icou1=-1
11605        return
11606        endif
11607 * beta and gamma of the cms of the two partciles
11608        bx=-Px/eln
11609        by=-Py/eln
11610        bz=-Pz/eln
11611        ga=1./sqrt(1.-bx**2-by**2-bz**2)
11612         elnc=eln/ga
11613        pn2=((elnc**2+dm2**2-amp**2)/(2.*elnc))**2-dm2**2
11614        if(pn2.le.0)then
11615        icou1=-1
11616        return
11617        endif
11618        pn=sqrt(pn2)
11619
11620 clin-10/25/02 get rid of argument usage mismatch in PTR():
11621         xptr=0.33*PN
11622 c       PNT=PTR(0.33*PN,ISEED)
11623        PNT=PTR(xptr,ISEED)
11624 clin-10/25/02-end
11625
11626        fain=2.*pi*RANART(NSEED)
11627        pnx=pnT*cos(fain)
11628        pny=pnT*sin(fain)
11629        SIG=1
11630        IF(X.GT.0)SIG=-1
11631        pnz=SIG*SQRT(pn**2-PNT**2)
11632        en=sqrt(dm2**2+pnx**2+pny**2+pnz**2)
11633 * (2) the momentum for the rho
11634        ppx=-pnx
11635        ppy=-pny
11636        ppz=-pnz
11637        ep=sqrt(amp**2+ppx**2+ppy**2+ppz**2)
11638 * (3) for the delta2, LORENTZ-TRANSFORMATION INTO nn cms FRAME
11639         PBETA  = PnX*BX + PnY*By+ PnZ*Bz
11640               TRANS0  = GA * ( GA * PBETA / (GA + 1.) + En )
11641               Pnx = BX * TRANS0 + PnX
11642               Pny = BY * TRANS0 + PnY
11643               Pnz = BZ * TRANS0 + PnZ
11644 * (4) for the rho, LORENTZ-TRANSFORMATION INTO nn cms FRAME
11645              if(ep.eq.0.)ep=1.e-09
11646               PBETA  = PPX*BX + PPY*By+ PPZ*Bz
11647               TRANS0  = GA * ( GA * PBETA / (GA + 1.) + EP )
11648               PPx = BX * TRANS0 + PPX
11649               PPy = BY * TRANS0 + PPY
11650               PPz = BZ * TRANS0 + PPZ
11651        return
11652        end
11653 ***************************8
11654 ****************************************
11655         SUBROUTINE ppomga(SRT,ISEED,PX,PY,PZ,DM1,PNX,
11656      &  PNY,PNZ,DM2,PPX,PPY,PPZ,icou1)
11657 * PURPOSE : CALCULATE MOMENTUM OF PARTICLES IN THE FINAL SATAT FROM
11658 * THE PROCESS N+N--->N1+N2+OMEGA
11659 *       DATE : Nov.5, 1994
11660 * Generate the masses and momentum for particles in the NN--> process
11661 * for a given center of mass energy srt, the momenta are given in the center
11662 * of mass of the NN
11663 *****************************************
11664         COMMON/TABLE/ xarray(0:1000),earray(0:1000)
11665 cc      SAVE /TABLE/
11666       COMMON/RNDF77/NSEED
11667 cc      SAVE /RNDF77/
11668       SAVE
11669         ntrym=0
11670        icou1=0
11671        pi=3.1415926
11672         AMN=938.925/1000.
11673         AMP=782./1000.
11674        DM1=amn
11675        DM2=amn
11676 * CONSTANTS FOR GENERATING THE LONGITUDINAL MOMENTUM
11677 * FOR ONE OF THE nucleons
11678        V=0.43
11679        W=-0.84
11680 * (2) Generate the transverse momentum
11681 *     OF p1
11682 * (2.1) estimate the maximum transverse momentum
11683        PTMAX2=(SRT**2-(DM1+DM2+AMP)**2)*
11684      1  (SRT**2-(DM1-AMP-DM2)**2)/4./SRT**2
11685        PTMAX=SQRT(PTMAX2)*1./3.
11686 7       PT=PTR(PTMAX,ISEED)
11687 * (3) GENGRATE THE LONGITUDINAL MOMENTUM FOR DM1
11688 *     USING THE GIVEN DISTRIBUTION
11689 * (3.1) THE MAXIMUM LONGITUDINAL MOMENTUM IS
11690        PZMAX2=(SRT**2-(DM1+DM2+AMP)**2)*
11691      1  (SRT**2-(DM1-AMP-DM2)**2)/4./SRT**2-PT**2
11692        NTRYM=NTRYM+1
11693        IF((PZMAX2.LT.0.).and.ntrym.le.100)then
11694        go to 7
11695        else
11696        pzmax2=1.E-09
11697        endif
11698        PZMAX=SQRT(PZMAX2)
11699        XMAX=2.*PZMAX/SRT
11700 * (3.2) THE GENERATED X IS
11701 * THE DSTRIBUTION HAS A MAXIMUM AT X0=-V/(2*w), f(X0)=1.056
11702        ntryx=0
11703        fmax00=1.056
11704        x00=0.26
11705        if(abs(xmax).gt.0.26)then
11706        f00=fmax00
11707        else
11708        f00=1.+v*abs(xmax)+w*xmax**2
11709        endif
11710 9       X=XMAX*(1.-2.*RANART(NSEED))
11711        ntryx=ntryx+1
11712        xratio=(1.+V*ABS(X)+W*X**2)/f00
11713 clin-8/17/00       IF(xratio.LT.RANART(NSEED).and.ntryx.le.50)GO TO 9
11714        IF(xratio.LT.RANART(NSEED).and.ntryx.le.50)GO TO 9
11715 * (3.5) THE PZ IS
11716        PZ=0.5*SRT*X
11717 * The x and y components of the delta1
11718        fai=2.*pi*RANART(NSEED)
11719        Px=pt*cos(fai)
11720        Py=pt*sin(fai)
11721 * find the momentum of delta2 and rho
11722 * the energy of the delta1
11723        ek=sqrt(dm1**2+PT**2+Pz**2)
11724 * (1) Generate the momentum of the delta2 in the cms of delta2 and rho
11725 *     the energy of the cms of Drho
11726         eln=srt-ek
11727        IF(ELN.lE.0)then
11728        icou1=-1
11729        return
11730        endif
11731        bx=-Px/eln
11732        by=-Py/eln
11733        bz=-Pz/eln
11734        ga=1./sqrt(1.-bx**2-by**2-bz**2)
11735        elnc=eln/ga
11736        pn2=((elnc**2+dm2**2-amp**2)/(2.*elnc))**2-dm2**2
11737        if(pn2.le.0)then
11738        icou1=-1
11739        return
11740        endif
11741        pn=sqrt(pn2)
11742
11743 clin-10/25/02 get rid of argument usage mismatch in PTR():
11744         xptr=0.33*PN
11745 c       PNT=PTR(0.33*PN,ISEED)
11746        PNT=PTR(xptr,ISEED)
11747 clin-10/25/02-end
11748
11749        fain=2.*pi*RANART(NSEED)
11750        pnx=pnT*cos(fain)
11751        pny=pnT*sin(fain)
11752        SIG=1
11753        IF(X.GT.0)SIG=-1
11754        pnz=SIG*SQRT(pn**2-PNT**2)
11755        en=sqrt(dm2**2+pnx**2+pny**2+pnz**2)
11756 * (2) the momentum for the rho
11757        ppx=-pnx
11758        ppy=-pny
11759        ppz=-pnz
11760        ep=sqrt(amp**2+ppx**2+ppy**2+ppz**2)
11761 * (3) for the delta2, LORENTZ-TRANSFORMATION INTO nn cms FRAME
11762         PBETA  = PnX*BX + PnY*By+ PnZ*Bz
11763               TRANS0  = GA * ( GA * PBETA / (GA + 1.) + En )
11764               Pnx = BX * TRANS0 + PnX
11765               Pny = BY * TRANS0 + PnY
11766               Pnz = BZ * TRANS0 + PnZ
11767 * (4) for the rho, LORENTZ-TRANSFORMATION INTO nn cms FRAME
11768              if(ep.eq.0.)ep=1.E-09
11769               PBETA  = PPX*BX + PPY*By+ PPZ*Bz
11770               TRANS0  = GA * ( GA * PBETA / (GA + 1.) + EP )
11771               PPx = BX * TRANS0 + PPX
11772               PPy = BY * TRANS0 + PPY
11773               PPz = BZ * TRANS0 + PPZ
11774        return
11775        end
11776 ***************************8
11777 ***************************8
11778 *   DELTA MASS GENERATOR
11779        REAL FUNCTION RMASS(DMAX,ISEED)
11780       COMMON/RNDF77/NSEED
11781 cc      SAVE /RNDF77/
11782       SAVE
11783           ISEED=ISEED
11784 * THE MINIMUM MASS FOR DELTA
11785           DMIN = 1.078
11786 * Delta(1232) production
11787           IF(DMAX.LT.1.232) THEN
11788           FM=FDELTA(DMAX)
11789           ELSE
11790           FM=1.
11791           ENDIF
11792           IF(FM.EQ.0.)FM=1.E-06
11793           NTRY1=0
11794 10        DM = RANART(NSEED) * (DMAX-DMIN) + DMIN
11795           NTRY1=NTRY1+1
11796           IF((RANART(NSEED) .GT. FDELTA(DM)/FM).AND.
11797      1    (NTRY1.LE.10)) GOTO 10
11798 clin-2/26/03 sometimes Delta mass can reach very high values (e.g. 15.GeV),
11799 c     thus violating the thresh of the collision which produces it
11800 c     and leads to large violation of energy conservation.
11801 c     To limit the above, limit the Delta mass below a certain value
11802 c     (here taken as its central value + 2* B-W fullwidth):
11803           if(dm.gt.1.47) goto 10
11804
11805        RMASS=DM
11806        RETURN
11807        END
11808
11809 *------------------------------------------------------------------
11810 * THE Breit Wigner FORMULA
11811         REAL FUNCTION FRHO(DMASS)
11812       SAVE
11813         AM0=0.77
11814        WID=0.153
11815         FD=0.25*wid**2/((DMASS-AM0)**2+0.25*WID**2)
11816         FRHO=FD
11817         RETURN
11818         END
11819 ***************************8
11820 *   RHO MASS GENERATOR
11821        REAL FUNCTION RHOMAS(DMAX,ISEED)
11822       COMMON/RNDF77/NSEED
11823 cc      SAVE /RNDF77/
11824       SAVE
11825           ISEED=ISEED
11826 * THE MINIMUM MASS FOR DELTA
11827           DMIN = 0.28
11828 * RHO(770) production
11829           IF(DMAX.LT.0.77) THEN
11830           FM=FRHO(DMAX)
11831           ELSE
11832           FM=1.
11833           ENDIF
11834           IF(FM.EQ.0.)FM=1.E-06
11835           NTRY1=0
11836 10        DM = RANART(NSEED) * (DMAX-DMIN) + DMIN
11837           NTRY1=NTRY1+1
11838           IF((RANART(NSEED) .GT. FRHO(DM)/FM).AND.
11839      1    (NTRY1.LE.10)) GOTO 10
11840 clin-2/26/03 limit the rho mass below a certain value
11841 c     (here taken as its central value + 2* B-W fullwidth):
11842           if(dm.gt.1.07) goto 10
11843
11844        RHOMAS=DM
11845        RETURN
11846        END
11847 ******************************************
11848 * for pp-->pp+2pi
11849 c      real*4 function X2pi(srt)
11850       real function X2pi(srt)
11851 *  This function contains the experimental
11852 c     total pp-pp+pi(+)pi(-) Xsections    *
11853 *  srt    = DSQRT(s) in GeV                                                  *
11854 *  xsec   = production cross section in mb                                   *
11855 *  earray = EXPerimental table with proton momentum in GeV/c                 *
11856 *  xarray = EXPerimental table with cross sections in mb (curve to guide eye)*
11857 *                                                                            *
11858 ******************************************
11859 c      real*4   xarray(15), earray(15)
11860       real   xarray(15), earray(15)
11861       SAVE
11862       data earray /2.23,2.81,3.67,4.0,4.95,5.52,5.97,6.04,
11863      &6.6,6.9,7.87,8.11,10.01,16.0,19./
11864       data xarray /1.22,2.51,2.67,2.95,2.96,2.84,2.8,3.2,
11865      &2.7,3.0,2.54,2.46,2.4,1.66,1.5/
11866
11867            pmass=0.9383
11868 * 1.Calculate p(lab)  from srt [GeV]
11869 *   Formula used:   DSQRT(s) = 2 m DSQRT(E_kin/(2m) + 1)
11870 c      ekin = 2.*pmass*((srt/(2.*pmass))**2 - 1.)
11871        x2pi=0.000001
11872        if(srt.le.2.2)return
11873       plab=sqrt(((srt**2-2.*pmass**2)/(2.*pmass))**2-pmass**2)
11874       if (plab .lt. earray(1)) then
11875         x2pi = xarray(1)
11876         return
11877       end if
11878 *
11879 * 2.Interpolate double logarithmically to find sigma(srt)
11880 *
11881       do 1001 ie = 1,15
11882         if (earray(ie) .eq. plab) then
11883           x2pi= xarray(ie)
11884           return
11885         else if (earray(ie) .gt. plab) then
11886           ymin = alog(xarray(ie-1))
11887           ymax = alog(xarray(ie))
11888           xmin = alog(earray(ie-1))
11889           xmax = alog(earray(ie))
11890           X2pi = exp(ymin + (alog(plab)-xmin)*(ymax-ymin)
11891      &    /(xmax-xmin) )
11892           return
11893         end if
11894  1001 continue
11895       return
11896         END
11897 ******************************************
11898 * for pp-->pn+pi(+)pi(+)pi(-)
11899 c      real*4 function X3pi(srt)
11900       real function X3pi(srt)
11901 *  This function contains the experimental pp->pp+3pi cross sections          *
11902 *  srt    = DSQRT(s) in GeV                                                   *
11903 *  xsec   = production cross section in mb                                    *
11904 *  earray = EXPerimental table with proton energies in MeV                    *
11905 *  xarray = EXPerimental table with cross sections in mb (curve to guide eye) *
11906 *                                                                             *
11907 ******************************************
11908 c      real*4   xarray(12), earray(12)
11909       real   xarray(12), earray(12)
11910       SAVE
11911       data xarray /0.02,0.4,1.15,1.60,2.19,2.85,2.30,
11912      &3.10,2.47,2.60,2.40,1.70/
11913       data earray /2.23,2.81,3.67,4.00,4.95,5.52,5.97,
11914      &6.04,6.60,6.90,10.01,19./
11915
11916            pmass=0.9383
11917 * 1.Calculate p(lab)  from srt [GeV]
11918 *   Formula used:   DSQRT(s) = 2 m DSQRT(E_kin/(2m) + 1)
11919 c      ekin = 2.*pmass*((srt/(2.*pmass))**2 - 1.)
11920        x3pi=1.E-06
11921        if(srt.le.2.3)return
11922       plab=sqrt(((srt**2-2.*pmass**2)/(2.*pmass))**2-pmass**2)
11923       if (plab .lt. earray(1)) then
11924         x3pi = xarray(1)
11925         return
11926       end if
11927 *
11928 * 2.Interpolate double logarithmically to find sigma(srt)
11929 *
11930       do 1001 ie = 1,12
11931         if (earray(ie) .eq. plab) then
11932           x3pi= xarray(ie)
11933           return
11934         else if (earray(ie) .gt. plab) then
11935           ymin = alog(xarray(ie-1))
11936           ymax = alog(xarray(ie))
11937           xmin = alog(earray(ie-1))
11938           xmax = alog(earray(ie))
11939           X3pi= exp(ymin + (alog(plab)-xmin)*(ymax-ymin)
11940      &                                            /(xmax-xmin) )
11941           return
11942         end if
11943  1001 continue
11944       return
11945         END
11946 ******************************************
11947 ******************************************
11948 * for pp-->pp+pi(+)pi(-)pi(0)
11949 c      real*4 function X33pi(srt)
11950       real function X33pi(srt)
11951 *  This function contains the experimental pp->pp+3pi cross sections          *
11952 *  srt    = DSQRT(s) in GeV                                                   *
11953 *  xsec   = production cross section in mb                                    *
11954 *  earray = EXPerimental table with proton energies in MeV                    *
11955 *  xarray = EXPerimental table with cross sections in mb (curve to guide eye) *
11956 *                                                                             *
11957 ******************************************
11958 c      real*4   xarray(12), earray(12)
11959       real   xarray(12), earray(12)
11960       SAVE
11961       data xarray /0.02,0.22,0.74,1.10,1.76,1.84,2.20,
11962      &2.40,2.15,2.60,2.30,1.70/
11963       data earray /2.23,2.81,3.67,4.00,4.95,5.52,5.97,
11964      &6.04,6.60,6.90,10.01,19./
11965
11966            pmass=0.9383
11967        x33pi=1.E-06
11968        if(srt.le.2.3)return
11969 * 1.Calculate p(lab)  from srt [GeV]
11970 *   Formula used:   DSQRT(s) = 2 m DSQRT(E_kin/(2m) + 1)
11971 c      ekin = 2.*pmass*((srt/(2.*pmass))**2 - 1.)
11972       plab=sqrt(((srt**2-2.*pmass**2)/(2.*pmass))**2-pmass**2)
11973       if (plab .lt. earray(1)) then
11974         x33pi = xarray(1)
11975         return
11976       end if
11977 *
11978 * 2.Interpolate double logarithmically to find sigma(srt)
11979 *
11980       do 1001 ie = 1,12
11981         if (earray(ie) .eq. plab) then
11982           x33pi= xarray(ie)
11983           return
11984         else if (earray(ie) .gt. plab) then
11985           ymin = alog(xarray(ie-1))
11986           ymax = alog(xarray(ie))
11987           xmin = alog(earray(ie-1))
11988           xmax = alog(earray(ie))
11989           x33pi= exp(ymin + (alog(plab)-xmin)*(ymax-ymin)
11990      &    /(xmax-xmin))
11991           return
11992         end if
11993  1001   continue
11994         return
11995         END
11996 ******************************************
11997 c       REAL*4 FUNCTION X4pi(SRT)
11998       REAL FUNCTION X4pi(SRT)
11999       SAVE
12000 *       CROSS SECTION FOR NN-->DD+rho PROCESS
12001 * *****************************
12002        akp=0.498
12003        ak0=0.498
12004        ana=0.94
12005        ada=1.232
12006        al=1.1157
12007        as=1.1197
12008        pmass=0.9383
12009        ES=SRT
12010        IF(ES.LE.4)THEN
12011        X4pi=0.
12012        ELSE
12013 * cross section for two resonance pp-->DD+DN*+N*N*
12014        xpp2pi=4.*x2pi(es)
12015 * cross section for pp-->pp+spi
12016        xpp3pi=3.*(x3pi(es)+x33pi(es))
12017 * cross section for pp-->pD+ and nD++
12018        pps1=sigma(es,1,1,0)+0.5*sigma(es,1,1,1)
12019        pps2=1.5*sigma(es,1,1,1)
12020        ppsngl=pps1+pps2+s1535(es)
12021 * CROSS SECTION FOR KAON PRODUCTION from the four channels
12022 * for NLK channel
12023        xk1=0
12024        xk2=0
12025        xk3=0
12026        xk4=0
12027        t1nlk=ana+al+akp
12028        t2nlk=ana+al-akp
12029        if(es.le.t1nlk)go to 333
12030        pmnlk2=(es**2-t1nlk**2)*(es**2-t2nlk**2)/(4.*es**2)
12031        pmnlk=sqrt(pmnlk2)
12032        xk1=pplpk(es)
12033 * for DLK channel
12034        t1dlk=ada+al+akp
12035        t2dlk=ada+al-akp
12036        if(es.le.t1dlk)go to 333
12037        pmdlk2=(es**2-t1dlk**2)*(es**2-t2dlk**2)/(4.*es**2)
12038        pmdlk=sqrt(pmdlk2)
12039        xk3=pplpk(es)
12040 * for NSK channel
12041        t1nsk=ana+as+akp
12042        t2nsk=ana+as-akp
12043        if(es.le.t1nsk)go to 333
12044        pmnsk2=(es**2-t1nsk**2)*(es**2-t2nsk**2)/(4.*es**2)
12045        pmnsk=sqrt(pmnsk2)
12046        xk2=ppk1(es)+ppk0(es)
12047 * for DSK channel
12048        t1DSk=aDa+aS+akp
12049        t2DSk=aDa+aS-akp
12050        if(es.le.t1dsk)go to 333
12051        pmDSk2=(es**2-t1DSk**2)*(es**2-t2DSk**2)/(4.*es**2)
12052        pmDSk=sqrt(pmDSk2)
12053        xk4=ppk1(es)+ppk0(es)
12054 * THE TOTAL KAON+ AND KAON0 PRODUCTION CROSS SECTION IS THEN
12055 333       XKAON=3.*(xk1+xk2+xk3+xk4)
12056 * cross section for pp-->DD+rho
12057        x4pi=pp1(es)-ppsngl-xpp2pi-xpp3pi-XKAON
12058        if(x4pi.le.0)x4pi=1.E-06
12059        ENDIF
12060        RETURN
12061        END
12062 ******************************************
12063 * for pp-->inelastic
12064 c      real*4 function pp1(srt)
12065       real function pp1(srt)
12066       SAVE
12067 *  srt    = DSQRT(s) in GeV                                                   *
12068 *  xsec   = production cross section in mb                                    *
12069 *  earray = EXPerimental table with proton energies in MeV                    *
12070 *  xarray = EXPerimental table with cross sections in mb (curve to guide eye) *
12071 *                                                                             *
12072 ******************************************
12073            pmass=0.9383
12074        PP1=0.
12075 * 1.Calculate p(lab)  from srt [GeV]
12076 *   Formula used:   DSQRT(s) = 2 m DSQRT(E_kin/(2m) + 1)
12077 c      ekin = 2.*pmass*((srt/(2.*pmass))**2 - 1.)
12078       plab2=((srt**2-2.*pmass**2)/(2.*pmass))**2-pmass**2
12079        IF(PLAB2.LE.0)RETURN
12080       plab=sqrt(PLAB2)
12081        pmin=0.968
12082        pmax=2080
12083       if ((plab .lt. pmin).or.(plab.gt.pmax)) then
12084         pp1 = 0.
12085         return
12086       end if
12087 c* fit parameters
12088        a=30.9
12089        b=-28.9
12090        c=0.192
12091        d=-0.835
12092        an=-2.46
12093         pp1 = a+b*(plab**an)+c*(alog(plab))**2
12094        if(pp1.le.0)pp1=0.0
12095         return
12096         END
12097 ******************************************
12098 * for pp-->elastic
12099 c      real*4 function pp2(srt)
12100       real function pp2(srt)
12101       SAVE
12102 *  srt    = DSQRT(s) in GeV                                                   *
12103 *  xsec   = production cross section in mb                                    *
12104 *  earray = EXPerimental table with proton energies in MeV                    *
12105 *  xarray = EXPerimental table with cross sections in mb (curve to guide eye) *
12106 *                                                                             *
12107 ******************************************
12108            pmass=0.9383
12109 * 1.Calculate p(lab)  from srt [GeV]
12110 *   Formula used:   DSQRT(s) = 2 m DSQRT(E_kin/(2m) + 1)
12111 c      ekin = 2.*pmass*((srt/(2.*pmass))**2 - 1.)
12112       plab=sqrt(((srt**2-2.*pmass**2)/(2.*pmass))**2-pmass**2)
12113        pmin=2.
12114        pmax=2050
12115        if(plab.gt.pmax)then
12116        pp2=8.
12117        return
12118        endif
12119         if(plab .lt. pmin)then
12120         pp2 = 25.
12121         return
12122         end if
12123 c* fit parameters
12124        a=11.2
12125        b=25.5
12126        c=0.151
12127        d=-1.62
12128        an=-1.12
12129         pp2 = a+b*(plab**an)+c*(alog(plab))**2+d*alog(plab)
12130        if(pp2.le.0)pp2=0
12131         return
12132         END
12133
12134 ******************************************
12135 * for pp-->total
12136 c      real*4 function ppt(srt)
12137       real function ppt(srt)
12138       SAVE
12139 *  srt    = DSQRT(s) in GeV                                                   *
12140 *  xsec   = production cross section in mb                                    *
12141 *  earray = EXPerimental table with proton energies in MeV                    *
12142 *  xarray = EXPerimental table with cross sections in mb (curve to guide eye) *
12143 *                                                                             *
12144 ******************************************
12145            pmass=0.9383
12146 * 1.Calculate p(lab)  from srt [GeV]
12147 *   Formula used:   DSQRT(s) = 2 m DSQRT(E_kin/(2m) + 1)
12148 c      ekin = 2.*pmass*((srt/(2.*pmass))**2 - 1.)
12149       plab=sqrt(((srt**2-2.*pmass**2)/(2.*pmass))**2-pmass**2)
12150        pmin=3.
12151        pmax=2100
12152       if ((plab .lt. pmin).or.(plab.gt.pmax)) then
12153         ppt = 55.
12154         return
12155       end if
12156 c* fit parameters
12157        a=45.6
12158        b=219.0
12159        c=0.410
12160        d=-3.41
12161        an=-4.23
12162         ppt = a+b*(plab**an)+c*(alog(plab))**2+d*alog(plab)
12163        if(ppt.le.0)ppt=0.0
12164         return
12165         END
12166
12167 *************************
12168 * cross section for N*(1535) production in PP collisions
12169 * VARIABLES:
12170 * LB1,LB2 ARE THE LABLES OF THE TWO COLLIDING PARTICLES
12171 * SRT IS THE CMS ENERGY
12172 * X1535 IS THE N*(1535) PRODUCTION CROSS SECTION
12173 * NOTE THAT THE N*(1535) PRODUCTION CROSS SECTION IS 2 TIMES THE ETA
12174 * PRODUCTION CROSS SECTION
12175 * DATE: Aug. 1 , 1994
12176 * ********************************
12177        real function s1535(SRT)
12178       SAVE
12179        S0=2.424
12180        s1535=0.
12181        IF(SRT.LE.S0)RETURN
12182        S1535=2.*0.102*(SRT-S0)/(0.058+(SRT-S0)**2)
12183        return
12184        end
12185 ****************************************
12186 * generate a table for pt distribution for
12187        subroutine tablem
12188 * THE PROCESS N+N--->N+N+PION
12189 *       DATE : July 11, 1994
12190 *****************************************
12191         COMMON/TABLE/ xarray(0:1000),earray(0:1000)
12192 cc      SAVE /TABLE/
12193       SAVE
12194        ptmax=2.01
12195        anorm=ptdis(ptmax)
12196        do 10 L=0,200
12197        x=0.01*float(L+1)
12198        rr=ptdis(x)/anorm
12199        earray(l)=rr
12200        xarray(l)=x
12201 10       continue
12202        RETURN
12203        end
12204 *********************************
12205        real function ptdis(x)
12206       SAVE
12207 * NUCLEON TRANSVERSE MOMENTUM DISTRIBUTION AT HIGH ENERGIES
12208 * DATE: Aug. 11, 1994
12209 *********************************
12210        b=3.78
12211        c=0.47
12212        d=3.60
12213 c       b=b*3
12214 c       d=d*3
12215        ptdis=1./(2.*b)*(1.-exp(-b*x**2))-c/d*x*exp(-d*x)
12216      1     -c/D**2*(exp(-d*x)-1.)
12217        return
12218        end
12219 *****************************
12220        subroutine ppxS(lb1,lb2,srt,ppsig,spprho,ipp)
12221 * purpose: this subroutine gives the cross section for pion+pion
12222 *          elastic collision
12223 * variables:
12224 *       input: lb1,lb2 and srt are the labels and srt for I1 and I2
12225 *       output: ppsig: pp xsection
12226 *               ipp: label for the pion+pion channel
12227 *               Ipp=0 NOTHING HAPPEND
12228 *                  1 for Pi(+)+PI(+) DIRECT
12229 *                   2     PI(+)+PI(0) FORMING RHO(+)
12230 *                  3     PI(+)+PI(-) FORMING RHO(0)
12231 *                   4     PI(0)+PI(O) DIRECT
12232 *                  5     PI(0)+PI(-) FORMING RHO(-)
12233 *                  6     PI(-)+PI(-) DIRECT
12234 * reference: G.F. Bertsch, Phys. Rev. D37 (1988) 1202.
12235 * date : Aug 29, 1994
12236 *****************************
12237        parameter (amp=0.14,pi=3.1415926)
12238       SAVE
12239        PPSIG=0.0
12240
12241 cbzdbg10/15/99
12242         spprho=0.0
12243 cbzdbg10/15/99 end
12244
12245        IPP=0
12246        IF(SRT.LE.0.3)RETURN
12247        q=sqrt((srt/2)**2-amp**2)
12248        esigma=5.8*amp
12249        tsigma=2.06*q
12250        erho=0.77
12251        trho=0.095*q*(q/amp/(1.+(q/erho)**2))**2
12252        esi=esigma-srt
12253        if(esi.eq.0)then
12254        d00=pi/2.
12255        go to 10
12256        endif
12257        d00=atan(tsigma/2./esi)
12258 10       erh=erho-srt
12259        if(erh.eq.0.)then
12260        d11=pi/2.
12261        go to 20
12262        endif
12263        d11=atan(trho/2./erh)
12264 20       d20=-0.12*q/amp
12265        s0=8.*pi*sin(d00)**2/q**2
12266        s1=8*pi*3*sin(d11)**2/q**2
12267        s2=8*pi*5*sin(d20)**2/q**2
12268 c    !! GeV^-2 to mb
12269         s0=s0*0.197**2*10.
12270         s1=s1*0.197**2*10.
12271         s2=s2*0.197**2*10.
12272 C       ppXS=s0/9.+s1/3.+s2*0.56
12273 C       if(ppxs.le.0)ppxs=0.00001
12274        spprho=s1/2.
12275 * (1) PI(+)+PI(+)
12276        IF(LB1.EQ.5.AND.LB2.EQ.5)THEN
12277        IPP=1
12278        PPSIG=S2
12279        RETURN
12280        ENDIF
12281 * (2) PI(+)+PI(0)
12282        IF((LB1.EQ.5.AND.LB2.EQ.4).OR.(LB1.EQ.4.AND.LB2.EQ.5))THEN
12283        IPP=2
12284        PPSIG=S2/2.+S1/2.
12285        RETURN
12286        ENDIF
12287 * (3) PI(+)+PI(-)
12288        IF((LB1.EQ.5.AND.LB2.EQ.3).OR.(LB1.EQ.3.AND.LB2.EQ.5))THEN
12289        IPP=3
12290        PPSIG=S2/6.+S1/2.+S0/3.
12291        RETURN
12292        ENDIF
12293 * (4) PI(0)+PI(0)
12294        IF(LB1.EQ.4.AND.LB2.EQ.4)THEN
12295        IPP=4
12296        PPSIG=2*S2/3.+S0/3.
12297        RETURN
12298        ENDIF
12299 * (5) PI(0)+PI(-)
12300        IF((LB1.EQ.4.AND.LB2.EQ.3).OR.(LB1.EQ.3.AND.LB2.EQ.4))THEN
12301        IPP=5
12302        PPSIG=S2/2.+S1/2.
12303        RETURN
12304        ENDIF
12305 * (6) PI(-)+PI(-)
12306        IF(LB1.EQ.3.AND.LB2.EQ.3)THEN
12307        IPP=6
12308        PPSIG=S2
12309        ENDIF
12310        return
12311        end
12312 **********************************
12313 * elementary kaon production cross sections
12314 *  from the CERN data book
12315 *  date: Sept.2, 1994
12316 *  for pp-->pLK+
12317 c      real*4 function pplpk(srt)
12318       real function pplpk(srt)
12319       SAVE
12320 *  srt    = DSQRT(s) in GeV                                                   *
12321 *  xsec   = production cross section in mb                                    *
12322 *  earray = EXPerimental table with proton energies in MeV                    *
12323 *  xarray = EXPerimental table with cross sections in mb (curve to guide eye) *
12324 *                                                                             *
12325 ******************************************
12326            pmass=0.9383
12327 * 1.Calculate p(lab)  from srt [GeV]
12328 *   Formula used:   DSQRT(s) = 2 m DSQRT(E_kin/(2m) + 1)
12329 *   find the center of mass energy corresponding to the given pm as
12330 *   if Lambda+N+K are produced
12331        pplpk=0.
12332         plab=sqrt(((srt**2-2.*pmass**2)/(2.*pmass))**2-pmass**2)
12333        pmin=2.82
12334        pmax=25.0
12335        if(plab.gt.pmax)then
12336        pplpk=0.036
12337        return
12338        endif
12339         if(plab .lt. pmin)then
12340         pplpk = 0.
12341         return
12342         end if
12343 c* fit parameters
12344        a=0.0654
12345        b=-3.16
12346        c=-0.0029
12347        an=-4.14
12348         pplpk = a+b*(plab**an)+c*(alog(plab))**2
12349        if(pplpk.le.0)pplpk=0
12350         return
12351         END
12352
12353 ******************************************
12354 * for pp-->pSigma+K0
12355 c      real*4 function ppk0(srt)
12356       real function ppk0(srt)
12357 *  srt    = DSQRT(s) in GeV                                                   *
12358 *  xsec   = production cross section in mb                                    *
12359 *                                                                             *
12360 ******************************************
12361 c      real*4   xarray(7), earray(7)
12362       real   xarray(7), earray(7)
12363       SAVE
12364       data xarray /0.030,0.025,0.025,0.026,0.02,0.014,0.06/
12365       data earray /3.67,4.95,5.52,6.05,6.92,7.87,10./
12366
12367            pmass=0.9383
12368 * 1.Calculate p(lab)  from srt [GeV]
12369 *   Formula used:   DSQRT(s) = 2 m DSQRT(E_kin/(2m) + 1)
12370 c      ekin = 2.*pmass*((srt/(2.*pmass))**2 - 1.)
12371        ppk0=0
12372        if(srt.le.2.63)return
12373        if(srt.gt.4.54)then
12374        ppk0=0.037
12375        return
12376        endif
12377         plab=sqrt(((srt**2-2.*pmass**2)/(2.*pmass))**2-pmass**2)
12378         if (plab .lt. earray(1)) then
12379         ppk0 = xarray(1)
12380         return
12381       end if
12382 *
12383 * 2.Interpolate double logarithmically to find sigma(srt)
12384 *
12385       do 1001 ie = 1,7
12386         if (earray(ie) .eq. plab) then
12387           ppk0 = xarray(ie)
12388           go to 10
12389         else if (earray(ie) .gt. plab) then
12390           ymin = alog(xarray(ie-1))
12391           ymax = alog(xarray(ie))
12392           xmin = alog(earray(ie-1))
12393           xmax = alog(earray(ie))
12394           ppk0 = exp(ymin + (alog(plab)-xmin)*(ymax-ymin)
12395      &/(xmax-xmin) )
12396           go to 10
12397         end if
12398  1001 continue
12399 10       continue
12400       return
12401         END
12402 ******************************************
12403 * for pp-->pSigma0K+
12404 c      real*4 function ppk1(srt)
12405       real function ppk1(srt)
12406 *  srt    = DSQRT(s) in GeV                                                   *
12407 *  xsec   = production cross section in mb                                    *
12408 *                                                                             *
12409 ******************************************
12410 c      real*4   xarray(7), earray(7)
12411       real   xarray(7), earray(7)
12412       SAVE
12413       data xarray /0.013,0.025,0.016,0.012,0.017,0.029,0.025/
12414       data earray /3.67,4.95,5.52,5.97,6.05,6.92,7.87/
12415
12416            pmass=0.9383
12417 * 1.Calculate p(lab)  from srt [GeV]
12418 *   Formula used:   DSQRT(s) = 2 m DSQRT(E_kin/(2m) + 1)
12419 c      ekin = 2.*pmass*((srt/(2.*pmass))**2 - 1.)
12420        ppk1=0.
12421        if(srt.le.2.63)return
12422        if(srt.gt.4.08)then
12423        ppk1=0.025
12424        return
12425        endif
12426         plab=sqrt(((srt**2-2.*pmass**2)/(2.*pmass))**2-pmass**2)
12427         if (plab .lt. earray(1)) then
12428         ppk1 =xarray(1)
12429         return
12430       end if
12431 *
12432 * 2.Interpolate double logarithmically to find sigma(srt)
12433 *
12434       do 1001 ie = 1,7
12435         if (earray(ie) .eq. plab) then
12436           ppk1 = xarray(ie)
12437           go to 10
12438         else if (earray(ie) .gt. plab) then
12439           ymin = alog(xarray(ie-1))
12440           ymax = alog(xarray(ie))
12441           xmin = alog(earray(ie-1))
12442           xmax = alog(earray(ie))
12443           ppk1 = exp(ymin + (alog(plab)-xmin)*(ymax-ymin)
12444      &/(xmax-xmin) )
12445           go to 10
12446         end if
12447  1001 continue
12448 10       continue
12449       return
12450         END
12451 **********************************
12452 *                                                                      *
12453 *                                                                      *
12454       SUBROUTINE CRPN(PX,PY,PZ,SRT,I1,I2,
12455      & IBLOCK,xkaon0,xkaon,Xphi,xphin)
12456 *     PURPOSE:                                                         *
12457 *           DEALING WITH PION+N-->L/S+KAON PROCESS AND PION PRODUCTION *
12458 *     NOTE   :                                                         *
12459 *
12460 *     QUANTITIES:                                                 *
12461 *           PX,PY,PZ - MOMENTUM COORDINATES OF ONE PARTICLE IN CM FRAME*
12462 *           SRT      - SQRT OF S                                       *
12463 *           IBLOCK   - THE INFORMATION BACK                            *
12464 *                     7  PION+N-->L/S+KAON
12465 *           iblock   - 77 pion+N-->Delta+pion
12466 *           iblock   - 78 pion+N-->Delta+RHO
12467 *           iblock   - 79 pion+N-->Delta+OMEGA
12468 *           iblock   - 222 pion+N-->Phi
12469 **********************************
12470         PARAMETER (MAXSTR=150001,MAXR=1,AMN=0.939457,
12471      1  AMP=0.93828,AP1=0.13496,APHI=1.020,
12472      2  AP2=0.13957,AM0=1.232,PI=3.1415926,CUTOFF=1.8966,AVMASS=0.9383)
12473         PARAMETER      (AKA=0.498,ALA=1.1157,ASA=1.1974)
12474         parameter     (MX=4,MY=4,MZ=8,MPX=4,MPY=4,mpz=10,mpzp=10)
12475         COMMON /AA/ R(3,MAXSTR)
12476 cc      SAVE /AA/
12477         COMMON /BB/ P(3,MAXSTR)
12478 cc      SAVE /BB/
12479         COMMON /CC/ E(MAXSTR)
12480 cc      SAVE /CC/
12481         COMMON /EE/ ID(MAXSTR),LB(MAXSTR)
12482 cc      SAVE /EE/
12483         common/input1/ MASSPR,MASSTA,ISEED,IAVOID,DT
12484 cc      SAVE /input1/
12485       COMMON/RNDF77/NSEED
12486 cc      SAVE /RNDF77/
12487       SAVE
12488
12489       PX0=PX
12490       PY0=PY
12491       PZ0=PZ
12492       iblock=1
12493       x1=RANART(NSEED)
12494       ianti=0
12495       if(lb(i1).lt.0 .or. lb(i2).lt.0) ianti=1
12496       if(xkaon0/(xkaon+Xphi).ge.x1)then
12497 * kaon production
12498 *-----------------------------------------------------------------------
12499         IBLOCK=7
12500         if(ianti .eq. 1)iblock=-7
12501         NTAG=0
12502 * RELABLE PARTICLES FOR THE PROCESS PION+n-->LAMBDA K OR SIGMA k
12503 * DECIDE LAMBDA OR SIGMA PRODUCTION, AND TO CALCULATE THE NEW
12504 * MOMENTA FOR PARTICLES IN THE FINAL STATE.
12505        KAONC=0
12506        IF(PNLKA(SRT)/(PNLKA(SRT)
12507      &       +PNSKA(SRT)).GT.RANART(NSEED))KAONC=1
12508        IF(E(I1).LE.0.2)THEN
12509            LB(I1)=23
12510            E(I1)=AKA
12511            IF(KAONC.EQ.1)THEN
12512               LB(I2)=14
12513               E(I2)=ALA
12514            ELSE
12515               LB(I2) = 15 + int(3 * RANART(NSEED))
12516               E(I2)=ASA
12517            ENDIF
12518            if(ianti .eq. 1)then
12519               lb(i1) = 21
12520               lb(i2) = -lb(i2)
12521            endif
12522        ELSE
12523            LB(I2)=23
12524            E(I2)=AKA
12525            IF(KAONC.EQ.1)THEN
12526               LB(I1)=14
12527               E(I1)=ALA
12528            ELSE
12529               LB(I1) = 15 + int(3 * RANART(NSEED))
12530               E(I1)=ASA
12531            ENDIF
12532            if(ianti .eq. 1)then
12533               lb(i2) = 21
12534               lb(i1) = -lb(i1)
12535            endif
12536        ENDIF
12537         EM1=E(I1)
12538         EM2=E(I2)
12539         go to 50
12540 * to gererate the momentum for the kaon and L/S
12541       elseif(Xphi/(xkaon+Xphi).ge.x1)then
12542           iblock=222
12543          if(xphin/Xphi .ge. RANART(NSEED))then
12544           LB(I1)= 1+int(2*RANART(NSEED))
12545            E(I1)=AMN
12546          else
12547           LB(I1)= 6+int(4*RANART(NSEED))
12548            E(I1)=AM0
12549          endif
12550 c  !! at present only baryon
12551          if(ianti .eq. 1)lb(i1)=-lb(i1)
12552           LB(I2)= 29
12553            E(I2)=APHI
12554         EM1=E(I1)
12555         EM2=E(I2)
12556        go to 50
12557          else
12558 * CHECK WHAT KIND OF PION PRODUCTION PROCESS HAS HAPPENED
12559        IF(RANART(NSEED).LE.TWOPI(SRT)/
12560      &  (TWOPI(SRT)+THREPI(SRT)+FOURPI(SRT)))THEN
12561        iblock=77
12562        ELSE
12563         IF(THREPI(SRT)/(THREPI(SRT)+FOURPI(SRT)).
12564      &  GT.RANART(NSEED))THEN
12565        IBLOCK=78
12566        ELSE
12567        IBLOCK=79
12568        ENDIF
12569        endif
12570        ntag=0
12571 * pion production (Delta+pion/rho/omega in the final state)
12572 * generate the mass of the delta resonance
12573        X2=RANART(NSEED)
12574 * relable the particles
12575        if(iblock.eq.77)then
12576 * GENERATE THE DELTA MASS
12577        dmax=srt-ap1-0.02
12578        dm=rmass(dmax,iseed)
12579 * pion+baryon-->pion+delta
12580 * Relable particles, I1 is assigned to the Delta and I2 is assigned to the
12581 * meson
12582 *(1) for pi(+)+p-->D(+)+P(+) OR D(++)+p(0)
12583        if( ((lb(i1).eq.1.and.lb(i2).eq.5).
12584      &  or.(lb(i1).eq.5.and.lb(i2).eq.1))
12585      &       .OR. ((lb(i1).eq.-1.and.lb(i2).eq.3).
12586      &  or.(lb(i1).eq.3.and.lb(i2).eq.-1)) )then
12587               if(iabs(lb(i1)).eq.1)then
12588         ii = i1
12589        IF(X2.LE.0.5)THEN
12590        lb(i1)=8
12591        e(i1)=dm
12592        lb(i2)=5
12593        e(i2)=ap1
12594        go to 40
12595        ELSE
12596        lb(i1)=9
12597        e(i1)=dm
12598        lb(i2)=4
12599         ipi = 4
12600        e(i2)=ap1
12601        go to 40
12602        endif
12603               else
12604         ii = i2
12605        IF(X2.LE.0.5)THEN
12606        lb(i2)=8
12607        e(i2)=dm
12608        lb(i1)=5
12609        e(i1)=ap1
12610        go to 40
12611        ELSE
12612        lb(i2)=9
12613        e(i2)=dm
12614        lb(i1)=4
12615        e(i1)=ap1
12616        go to 40
12617        endif
12618               endif
12619        endif
12620 *(2) for pi(-)+p-->D(0)+P(0) OR D(+)+p(-),or D(-)+p(+)
12621        if( ((lb(i1).eq.1.and.lb(i2).eq.3).
12622      &  or.(lb(i1).eq.3.and.lb(i2).eq.1))
12623      &        .OR. ((lb(i1).eq.-1.and.lb(i2).eq.5).
12624      &  or.(lb(i1).eq.5.and.lb(i2).eq.-1)) )then
12625               if(iabs(lb(i1)).eq.1)then
12626         ii = i1
12627        IF(X2.LE.0.33)THEN
12628        lb(i1)=6
12629        e(i1)=dm
12630        lb(i2)=5
12631        e(i2)=ap1
12632        go to 40
12633        ENDIF
12634        if(X2.gt.0.33.and.X2.le.0.67)then
12635        lb(i1)=7
12636        e(i1)=dm
12637        lb(i2)=4
12638        e(i2)=ap1
12639        go to 40
12640        endif
12641        if(X2.gt.0.67)then
12642        lb(i1)=8
12643        e(i1)=dm
12644        lb(i2)=3
12645        e(i2)=ap1
12646        go to 40
12647        endif
12648               else
12649         ii = i2
12650        IF(X2.LE.0.33)THEN
12651        lb(i2)=6
12652        e(i2)=dm
12653        lb(i1)=5
12654        e(i1)=ap1
12655        go to 40
12656        ENDIF
12657        if(X2.gt.0.33.and.X2.le.0.67)then
12658        lb(i2)=7
12659        e(i2)=dm
12660        lb(i1)=4
12661        e(i1)=ap1
12662        go to 40
12663        endif
12664        if(X2.gt.0.67)then
12665        lb(i2)=8
12666        e(i2)=dm
12667        lb(i1)=3
12668        e(i1)=ap1
12669        go to 40
12670        endif
12671               endif
12672        endif
12673 *(3) for pi(+)+n-->D(+)+Pi(0) OR D(++)+p(-) or D(0)+pi(+)
12674        if( ((lb(i1).eq.2.and.lb(i2).eq.5).
12675      &   or.(lb(i1).eq.5.and.lb(i2).eq.2))
12676      & .OR. ((lb(i1).eq.-2.and.lb(i2).eq.3).
12677      &   or.(lb(i1).eq.3.and.lb(i2).eq.-2)) )then
12678               if(iabs(lb(i1)).eq.2)then
12679         ii = i1
12680        IF(X2.LE.0.33)THEN
12681        lb(i1)=8
12682        e(i1)=dm
12683        lb(i2)=4
12684        e(i2)=ap1
12685        go to 40
12686        ENDIF
12687        if(X2.gt.0.33.and.X2.le.0.67)then
12688        lb(i1)=7
12689        e(i1)=dm
12690        lb(i2)=5
12691        e(i2)=ap1
12692        go to 40
12693        endif
12694        if(X2.gt.0.67)then
12695        lb(i1)=9
12696        e(i1)=dm
12697        lb(i2)=3
12698        e(i2)=ap1
12699        go to 40
12700        endif
12701               else
12702         ii = i2
12703        IF(X2.LE.0.33)THEN
12704        lb(i2)=8
12705        e(i2)=dm
12706        lb(i1)=4
12707        e(i1)=ap1
12708        go to 40
12709        ENDIF
12710        if(X2.gt.0.33.and.X2.le.0.67)then
12711        lb(i2)=7
12712        e(i2)=dm
12713        lb(i1)=5
12714        e(i1)=ap1
12715        go to 40
12716        endif
12717        if(X2.gt.0.67)then
12718        lb(i2)=9
12719        e(i2)=dm
12720        lb(i1)=3
12721        e(i1)=ap1
12722        go to 40
12723        endif
12724               endif
12725        endif
12726 *(4) for pi(0)+p-->D(+)+Pi(0) OR D(++)+p(-) or D(0)+pi(+)
12727        if((iabs(lb(i1)).eq.1.and.lb(i2).eq.4).
12728      &  or.(lb(i1).eq.4.and.iabs(lb(i2)).eq.1))then
12729               if(iabs(lb(i1)).eq.1)then
12730         ii = i1
12731        IF(X2.LE.0.33)THEN
12732        lb(i1)=8
12733        e(i1)=dm
12734        lb(i2)=4
12735        e(i2)=ap1
12736        go to 40
12737        ENDIF
12738        if(X2.gt.0.33.and.X2.le.0.67)then
12739        lb(i1)=7
12740        e(i1)=dm
12741        lb(i2)=5
12742        e(i2)=ap1
12743        go to 40
12744        endif
12745        if(X2.gt.0.67)then
12746        lb(i1)=9
12747        e(i1)=dm
12748        lb(i2)=3
12749        e(i2)=ap1
12750        go to 40
12751        endif
12752               else
12753         ii = i2
12754        IF(X2.LE.0.33)THEN
12755        lb(i2)=8
12756        e(i2)=dm
12757        lb(i1)=4
12758        e(i1)=ap1
12759        go to 40
12760        ENDIF
12761        if(X2.gt.0.33.and.X2.le.0.67)then
12762        lb(i2)=7
12763        e(i2)=dm
12764        lb(i1)=5
12765        e(i1)=ap1
12766        go to 40
12767        endif
12768        if(X2.gt.0.67)then
12769        lb(i2)=9
12770        e(i2)=dm
12771        lb(i1)=3
12772        e(i1)=ap1
12773        go to 40
12774        endif
12775               endif
12776        endif
12777 *(5) for pi(-)+n-->D(-)+P(0) OR D(0)+p(-)
12778        if( ((lb(i1).eq.2.and.lb(i2).eq.3).
12779      &  or.(lb(i1).eq.3.and.lb(i2).eq.2))
12780      &         .OR. ((lb(i1).eq.-2.and.lb(i2).eq.5).
12781      &  or.(lb(i1).eq.5.and.lb(i2).eq.-2)) )then
12782               if(iabs(lb(i1)).eq.2)then
12783         ii = i1
12784        IF(X2.LE.0.5)THEN
12785        lb(i1)=6
12786        e(i1)=dm
12787        lb(i2)=4
12788        e(i2)=ap1
12789        go to 40
12790        ELSE
12791        lb(i1)=7
12792        e(i1)=dm
12793        lb(i2)=3
12794        e(i2)=ap1
12795        go to 40
12796        endif
12797               else
12798         ii = i2
12799        IF(X2.LE.0.5)THEN
12800        lb(i2)=6
12801        e(i2)=dm
12802        lb(i1)=4
12803        e(i1)=ap1
12804        go to 40
12805        ELSE
12806        lb(i2)=7
12807        e(i2)=dm
12808        lb(i1)=3
12809        e(i1)=ap1
12810        go to 40
12811        endif
12812               endif
12813        ENDIF
12814 *(6) for pi(0)+n-->D(0)+P(0), D(-)+p(+) or D(+)+p(-)
12815        if((iabs(lb(i1)).eq.2.and.lb(i2).eq.4).
12816      &  or.(lb(i1).eq.4.and.iabs(lb(i2)).eq.2))then
12817               if(iabs(lb(i1)).eq.2)then
12818         ii = i1
12819        IF(X2.LE.0.33)THEN
12820        lb(i1)=7
12821        e(i1)=dm
12822        lb(i2)=4
12823        e(i2)=ap1
12824        go to 40
12825        Endif
12826        IF(X2.LE.0.67.AND.X2.GT.0.33)THEN
12827        lb(i1)=6
12828        e(i1)=dm
12829        lb(i2)=5
12830        e(i2)=ap1
12831        go to 40
12832        endif
12833        IF(X2.GT.0.67)THEN
12834        LB(I1)=8
12835        E(I1)=DM
12836        LB(I2)=3
12837        E(I2)=AP1
12838        GO TO 40
12839        ENDIF
12840               else
12841         ii = i2
12842        IF(X2.LE.0.33)THEN
12843        lb(i2)=7
12844        e(i2)=dm
12845        lb(i1)=4
12846        e(i1)=ap1
12847        go to 40
12848        ENDIF
12849        IF(X2.LE.0.67.AND.X2.GT.0.33)THEN
12850        lb(i2)=6
12851        e(i2)=dm
12852        lb(i1)=5
12853        e(i1)=ap1
12854        go to 40
12855        endif
12856        IF(X2.GT.0.67)THEN
12857        LB(I2)=8
12858        E(I2)=DM
12859        LB(I1)=3
12860        E(I1)=AP1
12861        GO TO 40
12862        ENDIF
12863               endif
12864        endif
12865                      ENDIF
12866        if(iblock.eq.78)then
12867        call Rmasdd(srt,1.232,0.77,1.08,
12868      &  0.28,ISEED,4,dm,ameson)
12869        arho=AMESON
12870 * pion+baryon-->Rho+delta
12871 *(1) for pi(+)+p-->D(+)+rho(+) OR D(++)+rho(0)
12872        if( ((lb(i1).eq.1.and.lb(i2).eq.5).
12873      &  or.(lb(i1).eq.5.and.lb(i2).eq.1))
12874      &        .OR. ((lb(i1).eq.-1.and.lb(i2).eq.3).
12875      &  or.(lb(i1).eq.3.and.lb(i2).eq.-1)) )then
12876               if(iabs(lb(i1)).eq.1)then
12877         ii = i1
12878        IF(X2.LE.0.5)THEN
12879        lb(i1)=8
12880        e(i1)=dm
12881        lb(i2)=27
12882        e(i2)=arho
12883        go to 40
12884        ELSE
12885        lb(i1)=9
12886        e(i1)=dm
12887        lb(i2)=26
12888        e(i2)=arho
12889        go to 40
12890        endif
12891               else
12892         ii = i2
12893        IF(X2.LE.0.5)THEN
12894        lb(i2)=8
12895        e(i2)=dm
12896        lb(i1)=27
12897        e(i1)=arho
12898        go to 40
12899        ELSE
12900        lb(i2)=9
12901        e(i2)=dm
12902        lb(i1)=26
12903        e(i1)=arho
12904        go to 40
12905        endif
12906               endif
12907        endif
12908 *(2) for pi(-)+p-->D(+)+rho(-) OR D(0)+rho(0) or D(-)+rho(+)
12909        if( ((lb(i1).eq.1.and.lb(i2).eq.3).
12910      &  or.(lb(i1).eq.3.and.lb(i2).eq.1))
12911      &        .OR. ((lb(i1).eq.-1.and.lb(i2).eq.5).
12912      &  or.(lb(i1).eq.5.and.lb(i2).eq.-1)) )then
12913               if(iabs(lb(i1)).eq.1)then
12914         ii = i1
12915        IF(X2.LE.0.33)THEN
12916        lb(i1)=6
12917        e(i1)=dm
12918        lb(i2)=27
12919        e(i2)=arho
12920        go to 40
12921        ENDIF
12922        if(X2.gt.0.33.and.X2.le.0.67)then
12923        lb(i1)=7
12924        e(i1)=dm
12925        lb(i2)=26
12926        e(i2)=arho
12927        go to 40
12928        endif
12929        if(X2.gt.0.67)then
12930        lb(i1)=8
12931        e(i1)=dm
12932        lb(i2)=25
12933        e(i2)=arho
12934        go to 40
12935        endif
12936               else
12937         ii = i2
12938        IF(X2.LE.0.33)THEN
12939        lb(i2)=6
12940        e(i2)=dm
12941        lb(i1)=27
12942        e(i1)=arho
12943        go to 40
12944        ENDIF
12945        if(X2.gt.0.33.and.X2.le.0.67)then
12946        lb(i2)=7
12947        e(i2)=dm
12948        lb(i1)=26
12949        e(i1)=arho
12950        go to 40
12951        endif
12952        if(X2.gt.0.67)then
12953        lb(i2)=8
12954        e(i2)=dm
12955        lb(i1)=25
12956        e(i1)=arho
12957        go to 40
12958        endif
12959               endif
12960        endif
12961 *(3) for pi(+)+n-->D(+)+rho(0) OR D(++)+rho(-) or D(0)+rho(+)
12962        if( ((lb(i1).eq.2.and.lb(i2).eq.5).
12963      &  or.(lb(i1).eq.5.and.lb(i2).eq.2))
12964      &       .OR.((lb(i1).eq.-2.and.lb(i2).eq.3).
12965      &  or.(lb(i1).eq.3.and.lb(i2).eq.-2)) )then
12966               if(iabs(lb(i1)).eq.2)then
12967         ii = i1
12968        IF(X2.LE.0.33)THEN
12969        lb(i1)=8
12970        e(i1)=dm
12971        lb(i2)=26
12972        e(i2)=arho
12973        go to 40
12974        ENDIF
12975        if(X2.gt.0.33.and.X2.le.0.67)then
12976        lb(i1)=7
12977        e(i1)=dm
12978        lb(i2)=27
12979        e(i2)=arho
12980        go to 40
12981        endif
12982        if(X2.gt.0.67)then
12983        lb(i1)=9
12984        e(i1)=dm
12985        lb(i2)=25
12986        e(i2)=arho
12987        go to 40
12988        endif
12989               else
12990         ii = i2
12991        IF(X2.LE.0.33)THEN
12992        lb(i2)=8
12993        e(i2)=dm
12994        lb(i1)=26
12995        e(i1)=arho
12996        go to 40
12997        ENDIF
12998        if(X2.gt.0.33.and.X2.le.0.67)then
12999        lb(i2)=7
13000        e(i2)=dm
13001        lb(i1)=27
13002        e(i1)=arho
13003        go to 40
13004        endif
13005        if(X2.gt.0.67)then
13006        lb(i2)=9
13007        e(i2)=dm
13008        lb(i1)=25
13009        e(i1)=arho
13010        go to 40
13011        endif
13012               endif
13013        endif
13014 *(4) for pi(0)+p-->D(+)+rho(0) OR D(++)+rho(-) or D(0)+rho(+)
13015        if((iabs(lb(i1)).eq.1.and.lb(i2).eq.4).
13016      &  or.(lb(i1).eq.4.and.iabs(lb(i2)).eq.1))then
13017               if(iabs(lb(i1)).eq.1)then
13018         ii = i1
13019        IF(X2.LE.0.33)THEN
13020        lb(i1)=7
13021        e(i1)=dm
13022        lb(i2)=27
13023        e(i2)=arho
13024        go to 40
13025        ENDIF
13026        if(X2.gt.0.33.and.X2.le.0.67)then
13027        lb(i1)=8
13028        e(i1)=dm
13029        lb(i2)=26
13030        e(i2)=arho
13031        go to 40
13032        endif
13033        if(X2.gt.0.67)then
13034        lb(i1)=9
13035        e(i1)=dm
13036        lb(i2)=25
13037        e(i2)=arho
13038        go to 40
13039        endif
13040               else
13041         ii = i2
13042        IF(X2.LE.0.33)THEN
13043        lb(i2)=7
13044        e(i2)=dm
13045        lb(i1)=27
13046        e(i1)=arho
13047        go to 40
13048        ENDIF
13049        if(X2.gt.0.33.and.X2.le.0.67)then
13050        lb(i2)=8
13051        e(i2)=dm
13052        lb(i1)=26
13053        e(i1)=arho
13054        go to 40
13055        endif
13056        if(X2.gt.0.67)then
13057        lb(i2)=9
13058        e(i2)=dm
13059        lb(i1)=25
13060        e(i1)=arho
13061        go to 40
13062        endif
13063               endif
13064        endif
13065 *(5) for pi(-)+n-->D(-)+rho(0) OR D(0)+rho(-)
13066        if( ((lb(i1).eq.2.and.lb(i2).eq.3).
13067      &  or.(lb(i1).eq.3.and.lb(i2).eq.2))
13068      &        .OR. ((lb(i1).eq.-2.and.lb(i2).eq.5).
13069      &  or.(lb(i1).eq.5.and.lb(i2).eq.-2)) )then
13070               if(iabs(lb(i1)).eq.2)then
13071         ii = i1
13072        IF(X2.LE.0.5)THEN
13073        lb(i1)=6
13074        e(i1)=dm
13075        lb(i2)=26
13076        e(i2)=arho
13077        go to 40
13078        ELSE
13079        lb(i1)=7
13080        e(i1)=dm
13081        lb(i2)=25
13082        e(i2)=arho
13083        go to 40
13084        endif
13085               else
13086         ii = i2
13087        IF(X2.LE.0.5)THEN
13088        lb(i2)=6
13089        e(i2)=dm
13090        lb(i1)=26
13091        e(i1)=arho
13092        go to 40
13093        ELSE
13094        lb(i2)=7
13095        e(i2)=dm
13096        lb(i1)=25
13097        e(i1)=arho
13098        go to 40
13099        endif
13100               endif
13101        ENDIF
13102 *(6) for pi(0)+n-->D(0)+rho(0), D(-)+rho(+) and D(+)+rho(-)
13103        if((iabs(lb(i1)).eq.2.and.lb(i2).eq.4).
13104      &  or.(lb(i1).eq.4.and.iabs(lb(i2)).eq.2))then
13105               if(iabs(lb(i1)).eq.2)then
13106         ii = i1
13107        IF(X2.LE.0.33)THEN
13108        lb(i1)=7
13109        e(i1)=dm
13110        lb(i2)=26
13111        e(i2)=arho
13112        go to 40
13113        endif
13114        if(x2.gt.0.33.and.x2.le.0.67)then
13115        lb(i1)=6
13116        e(i1)=dm
13117        lb(i2)=27
13118        e(i2)=arho
13119        go to 40
13120        endif
13121        if(x2.gt.0.67)then
13122        lb(i1)=8
13123        e(i1)=dm
13124        lb(i2)=25
13125        e(i2)=arho
13126        endif
13127               else
13128         ii = i2
13129        IF(X2.LE.0.33)THEN
13130        lb(i2)=7
13131        e(i2)=dm
13132        lb(i1)=26
13133        e(i1)=arho
13134        go to 40
13135        endif
13136        if(x2.le.0.67.and.x2.gt.0.33)then
13137        lb(i2)=6
13138        e(i2)=dm
13139        lb(i1)=27
13140        e(i1)=arho
13141        go to 40
13142        endif
13143        if(x2.gt.0.67)then
13144        lb(i2)=8
13145        e(i2)=dm
13146        lb(i1)=25
13147        e(i1)=arho
13148        endif
13149               endif
13150        endif
13151                      Endif
13152        if(iblock.eq.79)then
13153        aomega=0.782
13154 * GENERATE THE DELTA MASS
13155        dmax=srt-0.782-0.02
13156        dm=rmass(dmax,iseed)
13157 * pion+baryon-->omega+delta
13158 *(1) for pi(+)+p-->D(++)+omega(0)
13159        if( ((lb(i1).eq.1.and.lb(i2).eq.5).
13160      &  or.(lb(i1).eq.5.and.lb(i2).eq.1))
13161      &  .OR.((lb(i1).eq.-1.and.lb(i2).eq.3).
13162      &  or.(lb(i1).eq.3.and.lb(i2).eq.-1)) )then
13163               if(iabs(lb(i1)).eq.1)then
13164         ii = i1
13165        lb(i1)=9
13166        e(i1)=dm
13167        lb(i2)=28
13168        e(i2)=aomega
13169        go to 40
13170               else
13171         ii = i2
13172        lb(i2)=9
13173        e(i2)=dm
13174        lb(i1)=28
13175        e(i1)=aomega
13176        go to 40
13177               endif
13178        endif
13179 *(2) for pi(-)+p-->D(0)+omega(0)
13180        if( ((lb(i1).eq.1.and.lb(i2).eq.3).
13181      &  or.(lb(i1).eq.3.and.lb(i2).eq.1))
13182      &        .OR. ((lb(i1).eq.-1.and.lb(i2).eq.5).
13183      &  or.(lb(i1).eq.5.and.lb(i2).eq.-1)) )then
13184               if(iabs(lb(i1)).eq.1)then
13185         ii = i1
13186        lb(i1)=7
13187        e(i1)=dm
13188        lb(i2)=28
13189        e(i2)=aomega
13190        go to 40
13191               else
13192         ii = i2
13193        lb(i2)=7
13194        e(i2)=dm
13195        lb(i1)=28
13196        e(i1)=aomega
13197        go to 40
13198               endif
13199        endif
13200 *(3) for pi(+)+n-->D(+)+omega(0)
13201        if( ((lb(i1).eq.2.and.lb(i2).eq.5).
13202      &  or.(lb(i1).eq.5.and.lb(i2).eq.2))
13203      &       .OR. ((lb(i1).eq.-2.and.lb(i2).eq.3).
13204      &  or.(lb(i1).eq.3.and.lb(i2).eq.-2)) )then
13205               if(iabs(lb(i1)).eq.2)then
13206         ii = i1
13207        lb(i1)=8
13208        e(i1)=dm
13209        lb(i2)=28
13210        e(i2)=aomega
13211        go to 40
13212               else
13213         ii = i2
13214        lb(i2)=8
13215        e(i2)=dm
13216        lb(i1)=28
13217        e(i1)=aomega
13218        go to 40
13219               endif
13220        endif
13221 *(4) for pi(0)+p-->D(+)+omega(0)
13222        if((iabs(lb(i1)).eq.1.and.lb(i2).eq.4).
13223      &  or.(lb(i1).eq.4.and.iabs(lb(i2)).eq.1))then
13224               if(iabs(lb(i1)).eq.1)then
13225         ii = i1
13226        lb(i1)=8
13227        e(i1)=dm
13228        lb(i2)=28
13229        e(i2)=aomega
13230        go to 40
13231               else
13232         ii = i2
13233        lb(i2)=8
13234        e(i2)=dm
13235        lb(i1)=28
13236        e(i1)=aomega
13237        go to 40
13238               endif
13239        endif
13240 *(5) for pi(-)+n-->D(-)+omega(0)
13241        if( ((lb(i1).eq.2.and.lb(i2).eq.3).
13242      &  or.(lb(i1).eq.3.and.lb(i2).eq.2))
13243      &        .OR. ((lb(i1).eq.-2.and.lb(i2).eq.5).
13244      &  or.(lb(i1).eq.5.and.lb(i2).eq.-2)) )then
13245               if(iabs(lb(i1)).eq.2)then
13246         ii = i1
13247        lb(i1)=6
13248        e(i1)=dm
13249        lb(i2)=28
13250        e(i2)=aomega
13251        go to 40
13252               ELSE
13253         ii = i2
13254        lb(i2)=6
13255        e(i2)=dm
13256        lb(i1)=28
13257        e(i1)=aomega
13258               endif
13259        ENDIF
13260 *(6) for pi(0)+n-->D(0)+omega(0)
13261        if((iabs(lb(i1)).eq.2.and.lb(i2).eq.4).
13262      &  or.(lb(i1).eq.4.and.iabs(lb(i2)).eq.2))then
13263               if(iabs(lb(i1)).eq.2)then
13264         ii = i1
13265        lb(i1)=7
13266        e(i1)=dm
13267        lb(i2)=28
13268        e(i2)=aomega
13269        go to 40
13270               else
13271         ii = i2
13272        lb(i2)=7
13273        e(i2)=dm
13274        lb(i1)=26
13275        e(i1)=arho
13276        go to 40
13277               endif
13278        endif
13279                      Endif
13280 40       em1=e(i1)
13281        em2=e(i2)
13282        if(ianti.eq.1 .and. lb(i1).ge.1 .and. lb(i2).ge.1)then
13283          lb(ii) = -lb(ii)
13284            jj = i2
13285           if(ii .eq. i2)jj = i1
13286          if(iblock .eq. 77)then
13287           if(lb(jj).eq.3)then
13288            lb(jj) = 5
13289           elseif(lb(jj).eq.5)then
13290            lb(jj) = 3
13291           endif
13292          elseif(iblock .eq. 78)then
13293           if(lb(jj).eq.25)then
13294            lb(jj) = 27
13295           elseif(lb(jj).eq.27)then
13296            lb(jj) = 25
13297           endif
13298          endif
13299        endif
13300            endif
13301 *-----------------------------------------------------------------------
13302 * CALCULATE THE MAGNITUDE OF THE FINAL MOMENTUM THROUGH
13303 * ENERGY CONSERVATION
13304 50          PR2   = (SRT**2 - EM1**2 - EM2**2)**2
13305      1                - 4.0 * (EM1*EM2)**2
13306           IF(PR2.LE.0.)PR2=0.00000001
13307           PR=SQRT(PR2)/(2.*SRT)
13308 * here we use the same transverse momentum distribution as for
13309 * pp collisions, it might be necessary to use a different distribution
13310
13311 clin-10/25/02 get rid of argument usage mismatch in PTR():
13312           xptr=0.33*pr
13313 c         cc1=ptr(0.33*pr,iseed)
13314          cc1=ptr(xptr,iseed)
13315 clin-10/25/02-end
13316
13317          c1=sqrt(pr**2-cc1**2)/pr
13318 *          C1   = 1.0 - 2.0 * RANART(NSEED)
13319           T1   = 2.0 * PI * RANART(NSEED)
13320       S1   = SQRT( 1.0 - C1**2 )
13321       CT1  = COS(T1)
13322       ST1  = SIN(T1)
13323 * THE MOMENTUM IN THE CMS IN THE FINAL STATE
13324       PZ   = PR * C1
13325       PX   = PR * S1*CT1
13326       PY   = PR * S1*ST1
13327 * ROTATE IT
13328        CALL ROTATE(PX0,PY0,PZ0,PX,PY,PZ)
13329       RETURN
13330       END
13331 **********************************
13332 *                                                                      *
13333 *                                                                      *
13334       SUBROUTINE CREN(PX,PY,PZ,SRT,I1,I2,IBLOCK)
13335 *     PURPOSE:                                                         *
13336 *             DEALING WITH ETA+N-->L/S+KAON PROCESS                   *
13337 *     NOTE   :                                                         *
13338 *
13339 *     QUANTITIES:                                                 *
13340 *           PX,PY,PZ - MOMENTUM COORDINATES OF ONE PARTICLE IN CM FRAME*
13341 *           SRT      - SQRT OF S                                       *
13342 *           IBLOCK   - THE INFORMATION BACK                            *
13343 *                     7  ETA+N-->L/S+KAON
13344 **********************************
13345         PARAMETER (MAXSTR=150001,MAXR=1,AMN=0.939457,
13346      1  AMP=0.93828,AP1=0.13496,
13347      2  AP2=0.13957,AM0=1.232,PI=3.1415926,CUTOFF=1.8966,AVMASS=0.9383)
13348         PARAMETER      (AKA=0.498,ALA=1.1157,ASA=1.1974)
13349         parameter     (MX=4,MY=4,MZ=8,MPX=4,MPY=4,mpz=10,mpzp=10)
13350         COMMON /AA/ R(3,MAXSTR)
13351 cc      SAVE /AA/
13352         COMMON /BB/ P(3,MAXSTR)
13353 cc      SAVE /BB/
13354         COMMON /CC/ E(MAXSTR)
13355 cc      SAVE /CC/
13356         COMMON /EE/ ID(MAXSTR),LB(MAXSTR)
13357 cc      SAVE /EE/
13358         common/input1/ MASSPR,MASSTA,ISEED,IAVOID,DT
13359 cc      SAVE /input1/
13360       COMMON/RNDF77/NSEED
13361 cc      SAVE /RNDF77/
13362       SAVE
13363
13364        PX0=PX
13365        PY0=PY
13366        PZ0=PZ
13367         NTAG=0
13368         IBLOCK=7
13369         ianti=0
13370         if(lb(i1).lt.0 .or. lb(i2).lt.0)then
13371           ianti=1
13372           iblock=-7
13373         endif
13374 * RELABLE PARTICLES FOR THE PROCESS eta+n-->LAMBDA K OR SIGMA k
13375 * DECIDE LAMBDA OR SIGMA PRODUCTION, AND TO CALCULATE THE NEW
13376 * MOMENTA FOR PARTICLES IN THE FINAL STATE.
13377        KAONC=0
13378        IF(PNLKA(SRT)/(PNLKA(SRT)
13379      & +PNSKA(SRT)).GT.RANART(NSEED))KAONC=1
13380        IF(E(I1).LE.0.6)THEN
13381        LB(I1)=23
13382        E(I1)=AKA
13383         IF(KAONC.EQ.1)THEN
13384        LB(I2)=14
13385        E(I2)=ALA
13386         ELSE
13387         LB(I2) = 15 + int(3 * RANART(NSEED))
13388        E(I2)=ASA
13389         ENDIF
13390           if(ianti .eq. 1)then
13391             lb(i1)=21
13392             lb(i2)=-lb(i2)
13393           endif
13394        ELSE
13395        LB(I2)=23
13396        E(I2)=AKA
13397         IF(KAONC.EQ.1)THEN
13398        LB(I1)=14
13399        E(I1)=ALA
13400         ELSE
13401          LB(I1) = 15 + int(3 * RANART(NSEED))
13402        E(I1)=ASA
13403         ENDIF
13404           if(ianti .eq. 1)then
13405             lb(i2)=21
13406             lb(i1)=-lb(i1)
13407           endif
13408        ENDIF
13409         EM1=E(I1)
13410         EM2=E(I2)
13411 *-----------------------------------------------------------------------
13412 * CALCULATE THE MAGNITUDE OF THE FINAL MOMENTUM THROUGH
13413 * ENERGY CONSERVATION
13414         PR2   = (SRT**2 - EM1**2 - EM2**2)**2
13415      1                - 4.0 * (EM1*EM2)**2
13416           IF(PR2.LE.0.)PR2=1.e-09
13417           PR=SQRT(PR2)/(2.*SRT)
13418           C1   = 1.0 - 2.0 * RANART(NSEED)
13419           T1   = 2.0 * PI * RANART(NSEED)
13420       S1   = SQRT( 1.0 - C1**2 )
13421       CT1  = COS(T1)
13422       ST1  = SIN(T1)
13423 * THE MOMENTUM IN THE CMS IN THE FINAL STATE
13424       PZ   = PR * C1
13425       PX   = PR * S1*CT1
13426       PY   = PR * S1*ST1
13427 * FOR THE ISOTROPIC DISTRIBUTION THERE IS NO NEED TO ROTATE
13428       RETURN
13429       END
13430 **********************************
13431 *                                                                      *
13432 *                                                                      *
13433 c      SUBROUTINE Crdir(PX,PY,PZ,SRT,I1,I2)
13434       SUBROUTINE Crdir(PX,PY,PZ,SRT,I1,I2,IBLOCK)
13435 *     PURPOSE:                                                         *
13436 *             DEALING WITH pion+N-->pion+N PROCESS                   *
13437 *     NOTE   :                                                         *
13438 *
13439 *     QUANTITIES:                                                 *
13440 *           PX,PY,PZ - MOMENTUM COORDINATES OF ONE PARTICLE IN CM FRAME*
13441 *           SRT      - SQRT OF S                                       *
13442 *           IBLOCK   - THE INFORMATION BACK                            *
13443 *
13444 **********************************
13445         PARAMETER (MAXSTR=150001,MAXR=1,AMN=0.939457,
13446      1  AMP=0.93828,AP1=0.13496,
13447      2  AP2=0.13957,AM0=1.232,PI=3.1415926,CUTOFF=1.8966,AVMASS=0.9383)
13448         PARAMETER      (AKA=0.498,ALA=1.1157,ASA=1.1974)
13449         parameter     (MX=4,MY=4,MZ=8,MPX=4,MPY=4,mpz=10,mpzp=10)
13450         COMMON /AA/ R(3,MAXSTR)
13451 cc      SAVE /AA/
13452         COMMON /BB/ P(3,MAXSTR)
13453 cc      SAVE /BB/
13454         COMMON /CC/ E(MAXSTR)
13455 cc      SAVE /CC/
13456         COMMON /EE/ ID(MAXSTR),LB(MAXSTR)
13457 cc      SAVE /EE/
13458         common/input1/ MASSPR,MASSTA,ISEED,IAVOID,DT
13459 cc      SAVE /input1/
13460       COMMON/RNDF77/NSEED
13461 cc      SAVE /RNDF77/
13462       SAVE
13463
13464        PX0=PX
13465        PY0=PY
13466        PZ0=PZ
13467         IBLOCK=999
13468         NTAG=0
13469         EM1=E(I1)
13470         EM2=E(I2)
13471 *-----------------------------------------------------------------------
13472 * CALCULATE THE MAGNITUDE OF THE FINAL MOMENTUM THROUGH
13473 * ENERGY CONSERVATION
13474         PR2   = (SRT**2 - EM1**2 - EM2**2)**2
13475      1                - 4.0 * (EM1*EM2)**2
13476           IF(PR2.LE.0.)PR2=1.e-09
13477           PR=SQRT(PR2)/(2.*SRT)
13478
13479 clin-10/25/02 get rid of argument usage mismatch in PTR():
13480           xptr=0.33*pr
13481 c         cc1=ptr(0.33*pr,iseed)
13482          cc1=ptr(xptr,iseed)
13483 clin-10/25/02-end
13484
13485          c1=sqrt(pr**2-cc1**2)/pr
13486            T1   = 2.0 * PI * RANART(NSEED)
13487       S1   = SQRT( 1.0 - C1**2 )
13488       CT1  = COS(T1)
13489       ST1  = SIN(T1)
13490 * THE MOMENTUM IN THE CMS IN THE FINAL STATE
13491       PZ   = PR * C1
13492       PX   = PR * S1*CT1
13493       PY   = PR * S1*ST1
13494 * ROTATE the momentum
13495       call rotate(px0,py0,pz0,px,py,pz)
13496       RETURN
13497       END
13498 **********************************
13499 *                                                                      *
13500 *                                                                      *
13501       SUBROUTINE CRPD(PX,PY,PZ,SRT,I1,I2,
13502      & IBLOCK,xkaon0,xkaon,Xphi,xphin)
13503 *     PURPOSE:                                                         *
13504 *     DEALING WITH PION+D(N*)-->PION +N OR
13505 *                                             L/S+KAON PROCESS         *
13506 *     NOTE   :                                                         *
13507 *
13508 *     QUANTITIES:                                                 *
13509 *           PX,PY,PZ - MOMENTUM COORDINATES OF ONE PARTICLE IN CM FRAME*
13510 *           SRT      - SQRT OF S                                       *
13511 *           IBLOCK   - THE INFORMATION BACK                            *
13512 *                     7  PION+D(N*)-->L/S+KAON
13513 *           iblock   - 80 pion+D(N*)-->pion+N
13514 *           iblock   - 81 RHO+D(N*)-->PION+N
13515 *           iblock   - 82 OMEGA+D(N*)-->PION+N
13516 *                     222  PION+D --> PHI
13517 **********************************
13518         PARAMETER (MAXSTR=150001,MAXR=1,AMN=0.939457,
13519      1  AMP=0.93828,AP1=0.13496,APHI=1.020,
13520      2  AP2=0.13957,AM0=1.232,PI=3.1415926,CUTOFF=1.8966,AVMASS=0.9383)
13521         PARAMETER      (AKA=0.498,ALA=1.1157,ASA=1.1974)
13522         parameter     (MX=4,MY=4,MZ=8,MPX=4,MPY=4,mpz=10,mpzp=10)
13523         COMMON /AA/ R(3,MAXSTR)
13524 cc      SAVE /AA/
13525         COMMON /BB/ P(3,MAXSTR)
13526 cc      SAVE /BB/
13527         COMMON /CC/ E(MAXSTR)
13528 cc      SAVE /CC/
13529         COMMON /EE/ ID(MAXSTR),LB(MAXSTR)
13530 cc      SAVE /EE/
13531         common/input1/ MASSPR,MASSTA,ISEED,IAVOID,DT
13532 cc      SAVE /input1/
13533       COMMON/RNDF77/NSEED
13534 cc      SAVE /RNDF77/
13535       SAVE
13536
13537        PX0=PX
13538        PY0=PY
13539        PZ0=PZ
13540         IBLOCK=1
13541        x1=RANART(NSEED)
13542         ianti=0
13543         if(lb(i1).lt.0 .or. lb(i2).lt.0)ianti=1
13544        if(xkaon0/(xkaon+Xphi).ge.x1)then
13545 * kaon production
13546 *-----------------------------------------------------------------------
13547         IBLOCK=7
13548         if(ianti .eq. 1)iblock=-7
13549         NTAG=0
13550 * RELABLE PARTICLES FOR THE PROCESS PION+n-->LAMBDA K OR SIGMA k
13551 * DECIDE LAMBDA OR SIGMA PRODUCTION, AND TO CALCULATE THE NEW
13552 * MOMENTA FOR PARTICLES IN THE FINAL STATE.
13553        KAONC=0
13554        IF(PNLKA(SRT)/(PNLKA(SRT)
13555      &       +PNSKA(SRT)).GT.RANART(NSEED))KAONC=1
13556 clin-8/17/00     & +PNSKA(SRT)).GT.RANART(NSEED))KAONC=1
13557        IF(E(I1).LE.0.2)THEN
13558            LB(I1)=23
13559            E(I1)=AKA
13560            IF(KAONC.EQ.1)THEN
13561               LB(I2)=14
13562               E(I2)=ALA
13563            ELSE
13564               LB(I2) = 15 + int(3 * RANART(NSEED))
13565               E(I2)=ASA
13566            ENDIF
13567            if(ianti .eq. 1)then
13568               lb(i1)=21
13569               lb(i2)=-lb(i2)
13570            endif
13571        ELSE
13572            LB(I2)=23
13573            E(I2)=AKA
13574            IF(KAONC.EQ.1)THEN
13575               LB(I1)=14
13576               E(I1)=ALA
13577            ELSE
13578               LB(I1) = 15 + int(3 * RANART(NSEED))
13579               E(I1)=ASA
13580            ENDIF
13581            if(ianti .eq. 1)then
13582               lb(i2)=21
13583               lb(i1)=-lb(i1)
13584            endif
13585        ENDIF
13586         EM1=E(I1)
13587         EM2=E(I2)
13588        go to 50
13589 * to gererate the momentum for the kaon and L/S
13590 c
13591 c* Phi production
13592        elseif(Xphi/(xkaon+Xphi).ge.x1)then
13593           iblock=222
13594          if(xphin/Xphi .ge. RANART(NSEED))then
13595           LB(I1)= 1+int(2*RANART(NSEED))
13596            E(I1)=AMN
13597          else
13598           LB(I1)= 6+int(4*RANART(NSEED))
13599            E(I1)=AM0
13600          endif
13601 c   !! at present only baryon
13602           if(ianti .eq. 1)lb(i1)=-lb(i1)
13603           LB(I2)= 29
13604            E(I2)=APHI
13605         EM1=E(I1)
13606         EM2=E(I2)
13607        go to 50
13608          else
13609 * PION REABSORPTION HAS HAPPENED
13610        X2=RANART(NSEED)
13611        IBLOCK=80
13612        ntag=0
13613 * Relable particles, I1 is assigned to the nucleon
13614 * and I2 is assigned to the pion
13615 * for the reverse of the following process
13616 *(1) for D(+)+P(+)-->p+pion(+)
13617         if( ((lb(i1).eq.8.and.lb(i2).eq.5).
13618      &       or.(lb(i1).eq.5.and.lb(i2).eq.8))
13619      &       .OR.((lb(i1).eq.-8.and.lb(i2).eq.3).
13620      &       or.(lb(i1).eq.3.and.lb(i2).eq.-8)) )then
13621            if(iabs(lb(i1)).eq.8)then
13622               ii = i1
13623               lb(i1)=1
13624               e(i1)=amn
13625               lb(i2)=5
13626               e(i2)=ap1
13627               go to 40
13628            else
13629               ii = i2
13630               lb(i2)=1
13631               e(i2)=amn
13632               lb(i1)=5
13633               e(i1)=ap1
13634               go to 40
13635            endif
13636        endif
13637 c
13638 *(2) for D(0)+P(0)-->n+pi(0) or p+pi(-)
13639        if((iabs(lb(i1)).eq.7.and.lb(i2).eq.4).
13640      &  or.(lb(i1).eq.4.and.iabs(lb(i2)).eq.7))then
13641               if(iabs(lb(i1)).eq.7)then
13642         ii = i1
13643        IF(X2.LE.0.5)THEN
13644        lb(i1)=2
13645        e(i1)=amn
13646        lb(i2)=4
13647        e(i2)=ap1
13648        go to 40
13649        Else
13650        lb(i1)=1
13651        e(i1)=amn
13652        lb(i2)=3
13653        e(i2)=ap1
13654        go to 40
13655        endif
13656               else
13657         ii = i2
13658        IF(X2.LE.0.5)THEN
13659        lb(i2)=2
13660        e(i2)=amn
13661        lb(i1)=4
13662        e(i1)=ap1
13663        go to 40
13664        Else
13665        lb(i2)=1
13666        e(i2)=amn
13667        lb(i1)=3
13668        e(i1)=ap1
13669        go to 40
13670        endif
13671               endif
13672        endif
13673 *(3) for D(+)+Pi(0)-->pi(+)+n or pi(0)+p
13674        if((iabs(lb(i1)).eq.8.and.lb(i2).eq.4).
13675      &  or.(lb(i1).eq.4.and.iabs(lb(i2)).eq.8))then
13676               if(iabs(lb(i1)).eq.8)then
13677         ii = i1
13678        IF(X2.LE.0.5)THEN
13679        lb(i1)=2
13680        e(i1)=amn
13681        lb(i2)=5
13682        e(i2)=ap1
13683        go to 40
13684        Else
13685        lb(i1)=1
13686        e(i1)=amn
13687        lb(i2)=4
13688        e(i2)=ap1
13689        go to 40
13690        endif
13691               else
13692         ii = i2
13693        IF(X2.LE.0.5)THEN
13694        lb(i2)=2
13695        e(i2)=amn
13696        lb(i1)=5
13697        e(i1)=ap1
13698        go to 40
13699        Else
13700        lb(i2)=1
13701        e(i2)=amn
13702        lb(i1)=4
13703        e(i1)=ap1
13704        go to 40
13705        endif
13706               endif
13707        endif
13708 *(4) for D(-)+Pi(0)-->n+pi(-)
13709        if((iabs(lb(i1)).eq.6.and.lb(i2).eq.4).
13710      &  or.(lb(i1).eq.4.and.iabs(lb(i2)).eq.6))then
13711               if(iabs(lb(i1)).eq.6)then
13712         ii = i1
13713        lb(i1)=2
13714        e(i1)=amn
13715        lb(i2)=3
13716        e(i2)=ap1
13717        go to 40
13718        else
13719         ii = i2
13720        lb(i2)=2
13721        e(i2)=amn
13722        lb(i1)=3
13723        e(i1)=ap1
13724        go to 40
13725        ENDIF
13726        endif
13727 *(5) for D(+)+Pi(-)-->pi(0)+n or pi(-)+p
13728        if( ((lb(i1).eq.8.and.lb(i2).eq.3).
13729      &  or.(lb(i1).eq.3.and.lb(i2).eq.8))
13730      &        .OR.((lb(i1).eq.-8.and.lb(i2).eq.5).
13731      &  or.(lb(i1).eq.5.and.lb(i2).eq.-8)) )then
13732               if(iabs(lb(i1)).eq.8)then
13733         ii = i1
13734         IF(X2.LE.0.5)THEN
13735        lb(i1)=2
13736        e(i1)=amn
13737        lb(i2)=4
13738        e(i2)=ap1
13739        go to 40
13740        ELSE
13741        lb(i1)=1
13742        e(i1)=amn
13743        lb(i2)=3
13744        e(i2)=ap1
13745        go to 40
13746        endif
13747               else
13748         ii = i2
13749         IF(X2.LE.0.5)THEN
13750        lb(i2)=2
13751        e(i2)=amn
13752        lb(i1)=4
13753        e(i1)=ap1
13754        go to 40
13755        ELSE
13756        lb(i2)=1
13757        e(i2)=amn
13758        lb(i1)=3
13759        e(i1)=ap1
13760        go to 40
13761        endif
13762               endif
13763        ENDIF
13764 *(6) D(0)+P(+)-->n+pi(+) or p+pi(0)
13765        if( ((lb(i1).eq.7.and.lb(i2).eq.5).
13766      &  or.(lb(i1).eq.5.and.lb(i2).eq.7))
13767      &        .OR.((lb(i1).eq.-7.and.lb(i2).eq.3).
13768      &  or.(lb(i1).eq.3.and.lb(i2).eq.-7)) )then
13769               if(iabs(lb(i1)).eq.7)then
13770         ii = i1
13771          IF(X2.LE.0.5)THEN
13772        lb(i1)=2
13773        e(i1)=amn
13774        lb(i2)=5
13775        e(i2)=ap1
13776        go to 40
13777        else
13778        lb(i1)=1
13779        e(i1)=amn
13780        lb(i2)=4
13781        e(i2)=ap1
13782        go to 40
13783        endif
13784               else
13785         ii = i2
13786          IF(X2.LE.0.5)THEN
13787        lb(i2)=2
13788        e(i2)=amn
13789        lb(i1)=5
13790        e(i1)=ap1
13791        go to 40
13792        Else
13793        lb(i2)=1
13794        e(i2)=amn
13795        lb(i1)=4
13796        e(i1)=ap1
13797        go to 40
13798        endif
13799               endif
13800        ENDIF
13801 *(7) for D(0)+Pi(-)-->n+pi(-)
13802        if( ((lb(i1).eq.7.and.lb(i2).eq.3).
13803      &  or.(lb(i1).eq.3.and.lb(i2).eq.7))
13804      &        .OR.((lb(i1).eq.-7.and.lb(i2).eq.5).
13805      &  or.(lb(i1).eq.5.and.lb(i2).eq.-7)) )then
13806               if(iabs(lb(i1)).eq.7)then
13807         ii = i1
13808        lb(i1)=2
13809        e(i1)=amn
13810        lb(i2)=3
13811        e(i2)=ap1
13812        go to 40
13813        else
13814         ii = i2
13815        lb(i2)=2
13816        e(i2)=amn
13817        lb(i1)=3
13818        e(i1)=ap1
13819        go to 40
13820        ENDIF
13821        endif
13822 *(8) D(-)+P(+)-->n+pi(0) or p+pi(-)
13823        if( ((lb(i1).eq.6.and.lb(i2).eq.5)
13824      &      .or.(lb(i1).eq.5.and.lb(i2).eq.6))
13825      &   .OR.((lb(i1).eq.-6.and.lb(i2).eq.3).
13826      &      or.(lb(i1).eq.3.and.lb(i2).eq.-6)) )then
13827               if(iabs(lb(i1)).eq.6)then
13828          ii = i1
13829        IF(X2.LE.0.5)THEN
13830        lb(i1)=2
13831        e(i1)=amn
13832        lb(i2)=4
13833        e(i2)=ap1
13834        go to 40
13835        else
13836        lb(i1)=1
13837        e(i1)=amn
13838        lb(i2)=3
13839        e(i2)=ap1
13840        go to 40
13841        endif
13842               else
13843          ii = i2
13844        IF(X2.LE.0.5)THEN
13845        lb(i2)=2
13846        e(i2)=amn
13847        lb(i1)=4
13848        e(i1)=ap1
13849        go to 40
13850        Else
13851        lb(i2)=1
13852        e(i2)=amn
13853        lb(i1)=3
13854        e(i1)=ap1
13855        go to 40
13856        endif
13857               endif
13858        ENDIF
13859 c
13860 *(9) D(++)+P(-)-->n+pi(+) or p+pi(0)
13861        if( ((lb(i1).eq.9.and.lb(i2).eq.3)
13862      &   .or.(lb(i1).eq.3.and.lb(i2).eq.9))
13863      &       .OR. ((lb(i1).eq.-9.and.lb(i2).eq.5)
13864      &   .or.(lb(i1).eq.5.and.lb(i2).eq.-9)) )then
13865               if(iabs(lb(i1)).eq.9)then
13866         ii = i1
13867        IF(X2.LE.0.5)THEN
13868        lb(i1)=2
13869        e(i1)=amn
13870        lb(i2)=5
13871        e(i2)=ap1
13872        go to 40
13873        else
13874        lb(i1)=1
13875        e(i1)=amn
13876        lb(i2)=4
13877        e(i2)=ap1
13878        go to 40
13879        endif
13880               else
13881         ii = i2
13882        IF(X2.LE.0.5)THEN
13883        lb(i2)=2
13884        e(i2)=amn
13885        lb(i1)=5
13886        e(i1)=ap1
13887        go to 40
13888        Else
13889        lb(i2)=1
13890        e(i2)=amn
13891        lb(i1)=4
13892        e(i1)=ap1
13893        go to 40
13894        endif
13895               endif
13896        ENDIF
13897 *(10) for D(++)+Pi(0)-->p+pi(+)
13898        if((iabs(lb(i1)).eq.9.and.lb(i2).eq.4)
13899      &    .or.(lb(i1).eq.4.and.iabs(lb(i2)).eq.9))then
13900            if(iabs(lb(i1)).eq.9)then
13901         ii = i1
13902        lb(i1)=1
13903        e(i1)=amn
13904        lb(i2)=5
13905        e(i2)=ap1
13906        go to 40
13907        else
13908         ii = i2
13909        lb(i2)=1
13910        e(i2)=amn
13911        lb(i1)=5
13912        e(i1)=ap1
13913        go to 40
13914        ENDIF
13915        endif
13916 *(11) for N*(1440)(+)or N*(1535)(+)+P(+)-->p+pion(+)
13917        if( ((lb(i1).eq.11.and.lb(i2).eq.5).
13918      &  or.(lb(i1).eq.5.and.lb(i2).eq.11).
13919      &  or.(lb(i1).eq.13.and.lb(i2).eq.5).
13920      &  or.(lb(i1).eq.5.and.lb(i2).eq.13))
13921      &        .OR.((lb(i1).eq.-11.and.lb(i2).eq.3).
13922      &  or.(lb(i1).eq.3.and.lb(i2).eq.-11).
13923      &  or.(lb(i1).eq.-13.and.lb(i2).eq.3).
13924      &  or.(lb(i1).eq.3.and.lb(i2).eq.-13)) )then
13925               if(iabs(lb(i1)).eq.11.or.iabs(lb(i1)).eq.13)then
13926         ii = i1
13927        lb(i1)=1
13928        e(i1)=amn
13929        lb(i2)=5
13930        e(i2)=ap1
13931        go to 40
13932        else
13933         ii = i2
13934        lb(i2)=1
13935        e(i2)=amn
13936        lb(i1)=5
13937        e(i1)=ap1
13938        go to 40
13939               endif
13940        endif
13941 *(12) for N*(1440) or N*(1535)(0)+P(0)-->n+pi(0) or p+pi(-)
13942        if((iabs(lb(i1)).eq.10.and.lb(i2).eq.4).
13943      &  or.(lb(i1).eq.4.and.iabs(lb(i2)).eq.10).
13944      &  or.(lb(i1).eq.4.and.iabs(lb(i2)).eq.12).
13945      &  or.(lb(i2).eq.4.and.iabs(lb(i1)).eq.12))then
13946               if(iabs(lb(i1)).eq.10.or.iabs(lb(i1)).eq.12)then
13947         ii = i1
13948        IF(X2.LE.0.5)THEN
13949        lb(i1)=2
13950        e(i1)=amn
13951        lb(i2)=4
13952        e(i2)=ap1
13953        go to 40
13954        Else
13955        lb(i1)=1
13956        e(i1)=amn
13957        lb(i2)=3
13958        e(i2)=ap1
13959        go to 40
13960        endif
13961               else
13962         ii = i2
13963        IF(X2.LE.0.5)THEN
13964        lb(i2)=2
13965        e(i2)=amn
13966        lb(i1)=4
13967        e(i1)=ap1
13968        go to 40
13969        Else
13970        lb(i2)=1
13971        e(i2)=amn
13972        lb(i1)=3
13973        e(i1)=ap1
13974        go to 40
13975        endif
13976               endif
13977        endif
13978 *(13) for N*(1440) or N*(1535)(+)+Pi(0)-->pi(+)+n or pi(0)+p
13979        if((iabs(lb(i1)).eq.11.and.lb(i2).eq.4).
13980      &  or.(lb(i1).eq.4.and.iabs(lb(i2)).eq.11).
13981      &  or.(lb(i1).eq.4.and.iabs(lb(i2)).eq.13).
13982      &  or.(lb(i2).eq.4.and.iabs(lb(i1)).eq.13))then
13983               if(iabs(lb(i1)).eq.11.or.iabs(lb(i1)).eq.13)then
13984         ii = i1
13985        IF(X2.LE.0.5)THEN
13986        lb(i1)=2
13987        e(i1)=amn
13988        lb(i2)=5
13989        e(i2)=ap1
13990        go to 40
13991        Else
13992        lb(i1)=1
13993        e(i1)=amn
13994        lb(i2)=4
13995        e(i2)=ap1
13996        go to 40
13997        endif
13998               else
13999         ii = i2
14000        IF(X2.LE.0.5)THEN
14001        lb(i2)=2
14002        e(i2)=amn
14003        lb(i1)=5
14004        e(i1)=ap1
14005        go to 40
14006        Else
14007        lb(i2)=1
14008        e(i2)=amn
14009        lb(i1)=4
14010        e(i1)=ap1
14011        go to 40
14012        endif
14013               endif
14014        endif
14015 *(14) for N*(1440) or N*(1535)(+)+Pi(-)-->pi(0)+n or pi(-)+p
14016        if( ((lb(i1).eq.11.and.lb(i2).eq.3).
14017      &  or.(lb(i1).eq.3.and.lb(i2).eq.11).
14018      &  or.(lb(i1).eq.3.and.lb(i2).eq.13).
14019      &  or.(lb(i2).eq.3.and.lb(i1).eq.13))
14020      &        .OR.((lb(i1).eq.-11.and.lb(i2).eq.5).
14021      &  or.(lb(i1).eq.5.and.lb(i2).eq.-11).
14022      &  or.(lb(i1).eq.5.and.lb(i2).eq.-13).
14023      &  or.(lb(i2).eq.5.and.lb(i1).eq.-13)) )then
14024        if(iabs(lb(i1)).eq.11.or.iabs(lb(i1)).eq.13)then
14025         ii = i1
14026          IF(X2.LE.0.5)THEN
14027        lb(i1)=2
14028        e(i1)=amn
14029        lb(i2)=4
14030        e(i2)=ap1
14031        go to 40
14032        ELSE
14033        lb(i1)=1
14034        e(i1)=amn
14035        lb(i2)=3
14036        e(i2)=ap1
14037        go to 40
14038        endif
14039               else
14040         ii = i2
14041          IF(X2.LE.0.5)THEN
14042        lb(i2)=2
14043        e(i2)=amn
14044        lb(i1)=4
14045        e(i1)=ap1
14046        go to 40
14047        ELSE
14048        lb(i2)=1
14049        e(i2)=amn
14050        lb(i1)=3
14051        e(i1)=ap1
14052        go to 40
14053        endif
14054               endif
14055        ENDIF
14056 *(15) N*(1440) or N*(1535)(0)+P(+)-->n+pi(+) or p+pi(0)
14057        if( ((lb(i1).eq.10.and.lb(i2).eq.5).
14058      &  or.(lb(i1).eq.5.and.lb(i2).eq.10).
14059      &  or.(lb(i1).eq.12.and.lb(i2).eq.5).
14060      &  or.(lb(i1).eq.5.and.lb(i2).eq.12))
14061      &        .OR.((lb(i1).eq.-10.and.lb(i2).eq.3).
14062      &  or.(lb(i1).eq.3.and.lb(i2).eq.-10).
14063      &  or.(lb(i1).eq.-12.and.lb(i2).eq.3).
14064      &  or.(lb(i1).eq.3.and.lb(i2).eq.-12)) )then
14065        if(iabs(lb(i1)).eq.10.or.iabs(lb(i1)).eq.12)then
14066         ii = i1
14067         IF(X2.LE.0.5)THEN
14068        lb(i1)=2
14069        e(i1)=amn
14070        lb(i2)=5
14071        e(i2)=ap1
14072        go to 40
14073        else
14074        lb(i1)=1
14075        e(i1)=amn
14076        lb(i2)=4
14077        e(i2)=ap1
14078        go to 40
14079        endif
14080               else
14081         ii = i2
14082         IF(X2.LE.0.5)THEN
14083        lb(i2)=2
14084        e(i2)=amn
14085        lb(i1)=5
14086        e(i1)=ap1
14087        go to 40
14088        Else
14089        lb(i2)=1
14090        e(i2)=amn
14091        lb(i1)=4
14092        e(i1)=ap1
14093        go to 40
14094        endif
14095               endif
14096        ENDIF
14097 *(16) for N*(1440) or N*(1535) (0)+Pi(-)-->n+pi(-)
14098        if( ((lb(i1).eq.10.and.lb(i2).eq.3).
14099      &  or.(lb(i1).eq.3.and.lb(i2).eq.10).
14100      &  or.(lb(i1).eq.3.and.lb(i2).eq.12).
14101      &  or.(lb(i1).eq.12.and.lb(i2).eq.3))
14102      &        .OR.((lb(i1).eq.-10.and.lb(i2).eq.5).
14103      &  or.(lb(i1).eq.5.and.lb(i2).eq.-10).
14104      &  or.(lb(i1).eq.5.and.lb(i2).eq.-12).
14105      &  or.(lb(i1).eq.-12.and.lb(i2).eq.5)) )then
14106            if(iabs(lb(i1)).eq.10.or.iabs(lb(i1)).eq.12)then
14107         ii = i1
14108        lb(i1)=2
14109        e(i1)=amn
14110        lb(i2)=3
14111        e(i2)=ap1
14112        go to 40
14113        else
14114         ii = i2
14115        lb(i2)=2
14116        e(i2)=amn
14117        lb(i1)=3
14118        e(i1)=ap1
14119        go to 40
14120        ENDIF
14121        endif
14122 40       em1=e(i1)
14123        em2=e(i2)
14124        if(ianti.eq.1 .and.  lb(i1).ge.1 .and. lb(i2).ge.1)then
14125          lb(ii) = -lb(ii)
14126            jj = i2
14127           if(ii .eq. i2)jj = i1
14128           if(lb(jj).eq.3)then
14129            lb(jj) = 5
14130           elseif(lb(jj).eq.5)then
14131            lb(jj) = 3
14132           endif
14133          endif
14134           endif
14135 *-----------------------------------------------------------------------
14136 * CALCULATE THE MAGNITUDE OF THE FINAL MOMENTUM THROUGH
14137 * ENERGY CONSERVATION
14138 50          PR2   = (SRT**2 - EM1**2 - EM2**2)**2
14139      1                - 4.0 * (EM1*EM2)**2
14140           IF(PR2.LE.0.)PR2=1.E-09
14141           PR=SQRT(PR2)/(2.*SRT)
14142
14143 clin-10/25/02 get rid of argument usage mismatch in PTR():
14144           xptr=0.33*pr
14145 c         cc1=ptr(0.33*pr,iseed)
14146          cc1=ptr(xptr,iseed)
14147 clin-10/25/02-end
14148
14149          c1=sqrt(pr**2-cc1**2)/pr
14150 c         C1   = 1.0 - 2.0 * RANART(NSEED)
14151           T1   = 2.0 * PI * RANART(NSEED)
14152       S1   = SQRT( 1.0 - C1**2 )
14153       CT1  = COS(T1)
14154       ST1  = SIN(T1)
14155       PZ   = PR * C1
14156       PX   = PR * S1*CT1
14157       PY   = PR * S1*ST1
14158 * rotate the momentum
14159        call rotate(px0,py0,pz0,px,py,pz)
14160       RETURN
14161       END
14162 **********************************
14163 *                                                                      *
14164 *                                                                      *
14165       SUBROUTINE CRRD(PX,PY,PZ,SRT,I1,I2,
14166      & IBLOCK,xkaon0,xkaon,Xphi,xphin)
14167 *     PURPOSE:                                                         *
14168 *     DEALING WITH rho(omega)+N or D(N*)-->PION +N OR
14169 *                                             L/S+KAON PROCESS         *
14170 *     NOTE   :                                                         *
14171 *
14172 *     QUANTITIES:                                                 *
14173 *           PX,PY,PZ - MOMENTUM COORDINATES OF ONE PARTICLE IN CM FRAME*
14174 *           SRT      - SQRT OF S                                       *
14175 *           IBLOCK   - THE INFORMATION BACK                            *
14176 *                     7  rho(omega)+N or D(N*)-->L/S+KAON
14177 *           iblock   - 80 pion+D(N*)-->pion+N
14178 *           iblock   - 81 RHO+D(N*)-->PION+N
14179 *           iblock   - 82 OMEGA+D(N*)-->PION+N
14180 *           iblock   - 222 pion+N-->Phi
14181 **********************************
14182         PARAMETER (MAXSTR=150001,MAXR=1,AMN=0.939457,
14183      1  AMP=0.93828,AP1=0.13496,
14184      2  AP2=0.13957,AM0=1.232,PI=3.1415926,CUTOFF=1.8966,AVMASS=0.9383)
14185         PARAMETER     (AKA=0.498,ALA=1.1157,ASA=1.1974,APHI=1.02)
14186         parameter     (MX=4,MY=4,MZ=8,MPX=4,MPY=4,mpz=10,mpzp=10)
14187         COMMON /AA/ R(3,MAXSTR)
14188 cc      SAVE /AA/
14189         COMMON /BB/ P(3,MAXSTR)
14190 cc      SAVE /BB/
14191         COMMON /CC/ E(MAXSTR)
14192 cc      SAVE /CC/
14193         COMMON /EE/ ID(MAXSTR),LB(MAXSTR)
14194 cc      SAVE /EE/
14195         common/input1/ MASSPR,MASSTA,ISEED,IAVOID,DT
14196 cc      SAVE /input1/
14197       COMMON/RNDF77/NSEED
14198 cc      SAVE /RNDF77/
14199       SAVE
14200
14201        PX0=PX
14202        PY0=PY
14203        PZ0=PZ
14204        IBLOCK=1
14205        ianti=0
14206        if(lb(i1).lt.0 .or. lb(i2).lt.0) ianti=1
14207        x1=RANART(NSEED)
14208        if(xkaon0/(xkaon+Xphi).ge.x1)then
14209 * kaon production
14210 *-----------------------------------------------------------------------
14211         IBLOCK=7
14212         if(ianti .eq. 1)iblock=-7
14213         NTAG=0
14214 * RELABLE PARTICLES FOR THE PROCESS PION+n-->LAMBDA K OR SIGMA k
14215 * DECIDE LAMBDA OR SIGMA PRODUCTION, AND TO CALCULATE THE NEW
14216 * MOMENTA FOR PARTICLES IN THE FINAL STATE.
14217        KAONC=0
14218        IF(PNLKA(SRT)/(PNLKA(SRT)
14219      & +PNSKA(SRT)).GT.RANART(NSEED))KAONC=1
14220 clin-8/17/00     & +PNSKA(SRT)).GT.RANART(NSEED))KAONC=1
14221        IF(E(I1).LE.0.92)THEN
14222        LB(I1)=23
14223        E(I1)=AKA
14224               IF(KAONC.EQ.1)THEN
14225        LB(I2)=14
14226        E(I2)=ALA
14227               ELSE
14228         LB(I2) = 15 + int(3 * RANART(NSEED))
14229        E(I2)=ASA
14230               ENDIF
14231          if(ianti .eq. 1)then
14232           lb(i1) = 21
14233           lb(i2) = -lb(i2)
14234          endif
14235        ELSE
14236        LB(I2)=23
14237        E(I2)=AKA
14238               IF(KAONC.EQ.1)THEN
14239        LB(I1)=14
14240        E(I1)=ALA
14241               ELSE
14242          LB(I1) = 15 + int(3 * RANART(NSEED))
14243        E(I1)=ASA
14244               ENDIF
14245          if(ianti .eq. 1)then
14246           lb(i2) = 21
14247           lb(i1) = -lb(i1)
14248          endif
14249        ENDIF
14250         EM1=E(I1)
14251         EM2=E(I2)
14252        go to 50
14253 * to gererate the momentum for the kaon and L/S
14254 c
14255 c* Phi production
14256        elseif(Xphi/(xkaon+Xphi).ge.x1)then
14257           iblock=222
14258          if(xphin/Xphi .ge. RANART(NSEED))then
14259           LB(I1)= 1+int(2*RANART(NSEED))
14260            E(I1)=AMN
14261          else
14262           LB(I1)= 6+int(4*RANART(NSEED))
14263            E(I1)=AM0
14264          endif
14265 c   !! at present only baryon
14266          if(ianti .eq. 1)lb(i1)=-lb(i1)
14267           LB(I2)= 29
14268            E(I2)=APHI
14269         EM1=E(I1)
14270         EM2=E(I2)
14271        go to 50
14272          else
14273 * rho(omega) REABSORPTION HAS HAPPENED
14274        X2=RANART(NSEED)
14275        IBLOCK=81
14276        ntag=0
14277        if(lb(i1).eq.28.or.lb(i2).eq.28)go to 60
14278 * we treat Rho reabsorption in the following
14279 * Relable particles, I1 is assigned to the Delta
14280 * and I2 is assigned to the meson
14281 * for the reverse of the following process
14282 *(1) for D(+)+rho(+)-->p+pion(+)
14283        if( ((lb(i1).eq.8.and.lb(i2).eq.27).
14284      &  or.(lb(i1).eq.27.and.lb(i2).eq.8))
14285      &        .OR. ((lb(i1).eq.-8.and.lb(i2).eq.25).
14286      &  or.(lb(i1).eq.25.and.lb(i2).eq.-8)) )then
14287               if(iabs(lb(i1)).eq.8)then
14288         ii = i1
14289        lb(i1)=1
14290        e(i1)=amn
14291        lb(i2)=5
14292        e(i2)=ap1
14293        go to 40
14294        else
14295         ii = i2
14296        lb(i2)=1
14297        e(i2)=amn
14298        lb(i1)=5
14299        e(i1)=ap1
14300        go to 40
14301               endif
14302        endif
14303 *(2) for D(0)+rho(0)-->n+pi(0) or p+pi(-)
14304        if((iabs(lb(i1)).eq.7.and.lb(i2).eq.26).
14305      &  or.(lb(i1).eq.26.and.iabs(lb(i2)).eq.7))then
14306               if(iabs(lb(i1)).eq.7)then
14307         ii = i1
14308        IF(X2.LE.0.5)THEN
14309        lb(i1)=2
14310        e(i1)=amn
14311        lb(i2)=4
14312        e(i2)=ap1
14313        go to 40
14314        Else
14315        lb(i1)=1
14316        e(i1)=amn
14317        lb(i2)=3
14318        e(i2)=ap1
14319        go to 40
14320        endif
14321               else
14322         ii = i2
14323        IF(X2.LE.0.5)THEN
14324        lb(i2)=2
14325        e(i2)=amn
14326        lb(i1)=4
14327        e(i1)=ap1
14328        go to 40
14329        Else
14330        lb(i2)=1
14331        e(i2)=amn
14332        lb(i1)=3
14333        e(i1)=ap1
14334        go to 40
14335        endif
14336               endif
14337        endif
14338 *(3) for D(+)+rho(0)-->pi(+)+n or pi(0)+p
14339        if((iabs(lb(i1)).eq.8.and.lb(i2).eq.26).
14340      &  or.(lb(i1).eq.26.and.iabs(lb(i2)).eq.8))then
14341               if(iabs(lb(i1)).eq.8)then
14342         ii = i1
14343        IF(X2.LE.0.5)THEN
14344        lb(i1)=2
14345        e(i1)=amn
14346        lb(i2)=5
14347        e(i2)=ap1
14348        go to 40
14349        Else
14350        lb(i1)=1
14351        e(i1)=amn
14352        lb(i2)=4
14353        e(i2)=ap1
14354        go to 40
14355        endif
14356               else
14357         ii = i2
14358        IF(X2.LE.0.5)THEN
14359        lb(i2)=2
14360        e(i2)=amn
14361        lb(i1)=5
14362        e(i1)=ap1
14363        go to 40
14364        Else
14365        lb(i2)=1
14366        e(i2)=amn
14367        lb(i1)=4
14368        e(i1)=ap1
14369        go to 40
14370        endif
14371               endif
14372        endif
14373 *(4) for D(-)+rho(0)-->n+pi(-)
14374        if((iabs(lb(i1)).eq.6.and.lb(i2).eq.26).
14375      &  or.(lb(i1).eq.26.and.iabs(lb(i2)).eq.6))then
14376               if(iabs(lb(i1)).eq.6)then
14377         ii = i1
14378        lb(i1)=2
14379        e(i1)=amn
14380        lb(i2)=3
14381        e(i2)=ap1
14382        go to 40
14383        else
14384         ii = i2
14385        lb(i2)=2
14386        e(i2)=amn
14387        lb(i1)=3
14388        e(i1)=ap1
14389        go to 40
14390        ENDIF
14391        endif
14392 *(5) for D(+)+rho(-)-->pi(0)+n or pi(-)+p
14393        if( ((lb(i1).eq.8.and.lb(i2).eq.25).
14394      &  or.(lb(i1).eq.25.and.lb(i2).eq.8))
14395      &        .OR. ((lb(i1).eq.-8.and.lb(i2).eq.27).
14396      &  or.(lb(i1).eq.27.and.lb(i2).eq.-8)) )then
14397               if(iabs(lb(i1)).eq.8)then
14398         ii = i1
14399        IF(X2.LE.0.5)THEN
14400        lb(i1)=2
14401        e(i1)=amn
14402        lb(i2)=4
14403        e(i2)=ap1
14404        go to 40
14405        ELSE
14406        lb(i1)=1
14407        e(i1)=amn
14408        lb(i2)=3
14409        e(i2)=ap1
14410        go to 40
14411        endif
14412               else
14413         ii = i2
14414        IF(X2.LE.0.5)THEN
14415        lb(i2)=2
14416        e(i2)=amn
14417        lb(i1)=4
14418        e(i1)=ap1
14419        go to 40
14420        ELSE
14421        lb(i2)=1
14422        e(i2)=amn
14423        lb(i1)=3
14424        e(i1)=ap1
14425        go to 40
14426        endif
14427               endif
14428        ENDIF
14429 *(6) D(0)+rho(+)-->n+pi(+) or p+pi(0)
14430        if( ((lb(i1).eq.7.and.lb(i2).eq.27).
14431      &  or.(lb(i1).eq.27.and.lb(i2).eq.7))
14432      &       .OR.((lb(i1).eq.-7.and.lb(i2).eq.25).
14433      &  or.(lb(i1).eq.25.and.lb(i2).eq.-7)) )then
14434               if(iabs(lb(i1)).eq.7)then
14435         ii = i1
14436        IF(X2.LE.0.5)THEN
14437        lb(i1)=2
14438        e(i1)=amn
14439        lb(i2)=5
14440        e(i2)=ap1
14441        go to 40
14442        else
14443        lb(i1)=1
14444        e(i1)=amn
14445        lb(i2)=4
14446        e(i2)=ap1
14447        go to 40
14448        endif
14449               else
14450         ii = i2
14451        IF(X2.LE.0.5)THEN
14452        lb(i2)=2
14453        e(i2)=amn
14454        lb(i1)=5
14455        e(i1)=ap1
14456        go to 40
14457        Else
14458        lb(i2)=1
14459        e(i2)=amn
14460        lb(i1)=4
14461        e(i1)=ap1
14462        go to 40
14463        endif
14464               endif
14465        ENDIF
14466 *(7) for D(0)+rho(-)-->n+pi(-)
14467        if( ((lb(i1).eq.7.and.lb(i2).eq.25).
14468      &  or.(lb(i1).eq.25.and.lb(i2).eq.7))
14469      &       .OR.((lb(i1).eq.-7.and.lb(i2).eq.27).
14470      &  or.(lb(i1).eq.27.and.lb(i2).eq.-7)) )then
14471               if(iabs(lb(i1)).eq.7)then
14472         ii = i1
14473        lb(i1)=2
14474        e(i1)=amn
14475        lb(i2)=3
14476        e(i2)=ap1
14477        go to 40
14478        else
14479         ii = i2
14480        lb(i2)=2
14481        e(i2)=amn
14482        lb(i1)=3
14483        e(i1)=ap1
14484        go to 40
14485        ENDIF
14486        endif
14487 *(8) D(-)+rho(+)-->n+pi(0) or p+pi(-)
14488        if( ((lb(i1).eq.6.and.lb(i2).eq.27).
14489      &  or.(lb(i1).eq.27.and.lb(i2).eq.6))
14490      &        .OR. ((lb(i1).eq.-6.and.lb(i2).eq.25).
14491      &  or.(lb(i1).eq.25.and.lb(i2).eq.-6)) )then
14492               if(iabs(lb(i1)).eq.6)then
14493         ii = i1
14494        IF(X2.LE.0.5)THEN
14495        lb(i1)=2
14496        e(i1)=amn
14497        lb(i2)=4
14498        e(i2)=ap1
14499        go to 40
14500        else
14501        lb(i1)=1
14502        e(i1)=amn
14503        lb(i2)=3
14504        e(i2)=ap1
14505        go to 40
14506        endif
14507               else
14508         ii = i2
14509        IF(X2.LE.0.5)THEN
14510        lb(i2)=2
14511        e(i2)=amn
14512        lb(i1)=4
14513        e(i1)=ap1
14514        go to 40
14515        Else
14516        lb(i2)=1
14517        e(i2)=amn
14518        lb(i1)=3
14519        e(i1)=ap1
14520        go to 40
14521        endif
14522               endif
14523        ENDIF
14524 *(9) D(++)+rho(-)-->n+pi(+) or p+pi(0)
14525        if( ((lb(i1).eq.9.and.lb(i2).eq.25).
14526      &  or.(lb(i1).eq.25.and.lb(i2).eq.9))
14527      &        .OR.((lb(i1).eq.-9.and.lb(i2).eq.27).
14528      &  or.(lb(i1).eq.27.and.lb(i2).eq.-9)) )then
14529               if(iabs(lb(i1)).eq.9)then
14530         ii = i1
14531        IF(X2.LE.0.5)THEN
14532        lb(i1)=2
14533        e(i1)=amn
14534        lb(i2)=5
14535        e(i2)=ap1
14536        go to 40
14537        else
14538        lb(i1)=1
14539        e(i1)=amn
14540        lb(i2)=4
14541        e(i2)=ap1
14542        go to 40
14543        endif
14544               else
14545         ii = i2
14546        IF(X2.LE.0.5)THEN
14547        lb(i2)=2
14548        e(i2)=amn
14549        lb(i1)=5
14550        e(i1)=ap1
14551        go to 40
14552        Else
14553        lb(i2)=1
14554        e(i2)=amn
14555        lb(i1)=4
14556        e(i1)=ap1
14557        go to 40
14558        endif
14559               endif
14560        ENDIF
14561 *(10) for D(++)+rho(0)-->p+pi(+)
14562        if((iabs(lb(i1)).eq.9.and.lb(i2).eq.26).
14563      &  or.(lb(i1).eq.26.and.iabs(lb(i2)).eq.9))then
14564               if(iabs(lb(i1)).eq.9)then
14565         ii = i1
14566        lb(i1)=1
14567        e(i1)=amn
14568        lb(i2)=5
14569        e(i2)=ap1
14570        go to 40
14571        else
14572         ii = i2
14573        lb(i2)=1
14574        e(i2)=amn
14575        lb(i1)=5
14576        e(i1)=ap1
14577        go to 40
14578        ENDIF
14579        endif
14580 *(11) for N*(1440)(+)or N*(1535)(+)+rho(+)-->p+pion(+)
14581        if( ((lb(i1).eq.11.and.lb(i2).eq.27).
14582      &  or.(lb(i1).eq.27.and.lb(i2).eq.11).
14583      &  or.(lb(i1).eq.13.and.lb(i2).eq.27).
14584      &  or.(lb(i1).eq.27.and.lb(i2).eq.13))
14585      &        .OR. ((lb(i1).eq.-11.and.lb(i2).eq.25).
14586      &  or.(lb(i1).eq.25.and.lb(i2).eq.-11).
14587      &  or.(lb(i1).eq.-13.and.lb(i2).eq.25).
14588      &  or.(lb(i1).eq.25.and.lb(i2).eq.-13)) )then
14589               if(iabs(lb(i1)).eq.11.or.iabs(lb(i1)).eq.13)then
14590         ii = i1
14591        lb(i1)=1
14592        e(i1)=amn
14593        lb(i2)=5
14594        e(i2)=ap1
14595        go to 40
14596        else
14597         ii = i2
14598        lb(i2)=1
14599        e(i2)=amn
14600        lb(i1)=5
14601        e(i1)=ap1
14602        go to 40
14603               endif
14604        endif
14605 *(12) for N*(1440) or N*(1535)(0)+rho(0)-->n+pi(0) or p+pi(-)
14606        if((iabs(lb(i1)).eq.10.and.lb(i2).eq.26).
14607      &  or.(lb(i1).eq.26.and.iabs(lb(i2)).eq.10).
14608      &  or.(lb(i1).eq.26.and.iabs(lb(i2)).eq.12).
14609      &  or.(lb(i2).eq.26.and.iabs(lb(i1)).eq.12))then
14610               if(iabs(lb(i1)).eq.10.or.iabs(lb(i1)).eq.12)then
14611         ii = i1
14612        IF(X2.LE.0.5)THEN
14613        lb(i1)=2
14614        e(i1)=amn
14615        lb(i2)=4
14616        e(i2)=ap1
14617        go to 40
14618        Else
14619        lb(i1)=1
14620        e(i1)=amn
14621        lb(i2)=3
14622        e(i2)=ap1
14623        go to 40
14624        endif
14625               else
14626         ii = i2
14627        IF(X2.LE.0.5)THEN
14628        lb(i2)=2
14629        e(i2)=amn
14630        lb(i1)=4
14631        e(i1)=ap1
14632        go to 40
14633        Else
14634        lb(i2)=1
14635        e(i2)=amn
14636        lb(i1)=3
14637        e(i1)=ap1
14638        go to 40
14639        endif
14640               endif
14641        endif
14642 *(13) for N*(1440) or N*(1535)(+)+rho(0)-->pi(+)+n or pi(0)+p
14643        if((iabs(lb(i1)).eq.11.and.lb(i2).eq.26).
14644      &  or.(lb(i1).eq.26.and.iabs(lb(i2)).eq.11).
14645      &  or.(lb(i1).eq.26.and.iabs(lb(i2)).eq.13).
14646      &  or.(lb(i2).eq.26.and.iabs(lb(i1)).eq.13))then
14647               if(iabs(lb(i1)).eq.11.or.iabs(lb(i1)).eq.13)then
14648         ii = i1
14649        IF(X2.LE.0.5)THEN
14650        lb(i1)=2
14651        e(i1)=amn
14652        lb(i2)=5
14653        e(i2)=ap1
14654        go to 40
14655        Else
14656        lb(i1)=1
14657        e(i1)=amn
14658        lb(i2)=4
14659        e(i2)=ap1
14660        go to 40
14661        endif
14662               else
14663         ii = i2
14664        IF(X2.LE.0.5)THEN
14665        lb(i2)=2
14666        e(i2)=amn
14667        lb(i1)=5
14668        e(i1)=ap1
14669        go to 40
14670        Else
14671        lb(i2)=1
14672        e(i2)=amn
14673        lb(i1)=4
14674        e(i1)=ap1
14675        go to 40
14676        endif
14677               endif
14678        endif
14679 *(14) for N*(1440) or N*(1535)(+)+rho(-)-->pi(0)+n or pi(-)+p
14680        if( ((lb(i1).eq.11.and.lb(i2).eq.25).
14681      &  or.(lb(i1).eq.25.and.lb(i2).eq.11).
14682      &  or.(lb(i1).eq.25.and.lb(i2).eq.13).
14683      &  or.(lb(i2).eq.25.and.lb(i1).eq.13))
14684      &        .OR.((lb(i1).eq.-11.and.lb(i2).eq.27).
14685      &  or.(lb(i1).eq.27.and.lb(i2).eq.-11).
14686      &  or.(lb(i1).eq.27.and.lb(i2).eq.-13).
14687      &  or.(lb(i2).eq.27.and.lb(i1).eq.-13)) )then
14688        if(iabs(lb(i1)).eq.11.or.iabs(lb(i1)).eq.13)then
14689         ii = i1
14690        IF(X2.LE.0.5)THEN
14691        lb(i1)=2
14692        e(i1)=amn
14693        lb(i2)=4
14694        e(i2)=ap1
14695        go to 40
14696        ELSE
14697        lb(i1)=1
14698        e(i1)=amn
14699        lb(i2)=3
14700        e(i2)=ap1
14701        go to 40
14702        endif
14703               else
14704         ii = i2
14705        IF(X2.LE.0.5)THEN
14706        lb(i2)=2
14707        e(i2)=amn
14708        lb(i1)=4
14709        e(i1)=ap1
14710        go to 40
14711        ELSE
14712        lb(i2)=1
14713        e(i2)=amn
14714        lb(i1)=3
14715        e(i1)=ap1
14716        go to 40
14717        endif
14718               endif
14719        ENDIF
14720 *(15) N*(1440) or N*(1535)(0)+rho(+)-->n+pi(+) or p+pi(0)
14721        if( ((lb(i1).eq.10.and.lb(i2).eq.27).
14722      &  or.(lb(i1).eq.27.and.lb(i2).eq.10).
14723      &  or.(lb(i1).eq.12.and.lb(i2).eq.27).
14724      &  or.(lb(i1).eq.27.and.lb(i2).eq.12))
14725      &         .OR.((lb(i1).eq.-10.and.lb(i2).eq.25).
14726      &  or.(lb(i1).eq.25.and.lb(i2).eq.-10).
14727      &  or.(lb(i1).eq.-12.and.lb(i2).eq.25).
14728      &  or.(lb(i1).eq.25.and.lb(i2).eq.-12)) )then
14729        if(iabs(lb(i1)).eq.10.or.iabs(lb(i1)).eq.12)then
14730         ii = i1
14731        IF(X2.LE.0.5)THEN
14732        lb(i1)=2
14733        e(i1)=amn
14734        lb(i2)=5
14735        e(i2)=ap1
14736        go to 40
14737        else
14738        lb(i1)=1
14739        e(i1)=amn
14740        lb(i2)=4
14741        e(i2)=ap1
14742        go to 40
14743        endif
14744               else
14745         ii = i2
14746        IF(X2.LE.0.5)THEN
14747        lb(i2)=2
14748        e(i2)=amn
14749        lb(i1)=5
14750        e(i1)=ap1
14751        go to 40
14752        Else
14753        lb(i2)=1
14754        e(i2)=amn
14755        lb(i1)=4
14756        e(i1)=ap1
14757        go to 40
14758        endif
14759               endif
14760        ENDIF
14761 *(16) for N*(1440) or N*(1535) (0)+rho(-)-->n+pi(-)
14762        if( ((lb(i1).eq.10.and.lb(i2).eq.25).
14763      &  or.(lb(i1).eq.25.and.lb(i2).eq.10).
14764      &  or.(lb(i1).eq.25.and.lb(i2).eq.12).
14765      &  or.(lb(i1).eq.12.and.lb(i2).eq.25))
14766      &       .OR. ((lb(i1).eq.-10.and.lb(i2).eq.27).
14767      &  or.(lb(i1).eq.27.and.lb(i2).eq.-10).
14768      &  or.(lb(i1).eq.27.and.lb(i2).eq.-12).
14769      &  or.(lb(i1).eq.-12.and.lb(i2).eq.27)) )then
14770        if(iabs(lb(i1)).eq.10.or.iabs(lb(i1)).eq.12)then
14771         ii = i1
14772        lb(i1)=2
14773        e(i1)=amn
14774        lb(i2)=3
14775        e(i2)=ap1
14776        go to 40
14777        else
14778         ii = i2
14779        lb(i2)=2
14780        e(i2)=amn
14781        lb(i1)=3
14782        e(i1)=ap1
14783        go to 40
14784        ENDIF
14785        endif
14786 60       IBLOCK=82
14787 * FOR OMEGA REABSORPTION
14788 * Relable particles, I1 is assigned to the Delta
14789 * and I2 is assigned to the meson
14790 * for the reverse of the following process
14791 *(1) for D(0)+OMEGA(0)-->n+pi(0) or p+pi(-)
14792        if((iabs(lb(i1)).eq.7.and.lb(i2).eq.28).
14793      &  or.(lb(i1).eq.28.and.iabs(lb(i2)).eq.7))then
14794               if(iabs(lb(i1)).eq.7)then
14795         ii = i1
14796        IF(X2.LE.0.5)THEN
14797        lb(i1)=2
14798        e(i1)=amn
14799        lb(i2)=4
14800        e(i2)=ap1
14801        go to 40
14802        Else
14803        lb(i1)=1
14804        e(i1)=amn
14805        lb(i2)=3
14806        e(i2)=ap1
14807        go to 40
14808        endif
14809               else
14810         ii = i2
14811        IF(X2.LE.0.5)THEN
14812        lb(i2)=2
14813        e(i2)=amn
14814        lb(i1)=4
14815        e(i1)=ap1
14816        go to 40
14817        Else
14818        lb(i2)=1
14819        e(i2)=amn
14820        lb(i1)=3
14821        e(i1)=ap1
14822        go to 40
14823        endif
14824               endif
14825        endif
14826 *(2) for D(+)+OMEGA(0)-->pi(+)+n or pi(0)+p
14827        if((iabs(lb(i1)).eq.8.and.lb(i2).eq.28).
14828      &  or.(lb(i1).eq.28.and.iabs(lb(i2)).eq.8))then
14829               if(iabs(lb(i1)).eq.8)then
14830         ii = i1
14831        IF(X2.LE.0.5)THEN
14832        lb(i1)=2
14833        e(i1)=amn
14834        lb(i2)=5
14835        e(i2)=ap1
14836        go to 40
14837        Else
14838        lb(i1)=1
14839        e(i1)=amn
14840        lb(i2)=4
14841        e(i2)=ap1
14842        go to 40
14843        endif
14844               else
14845         ii = i2
14846        IF(X2.LE.0.5)THEN
14847        lb(i2)=2
14848        e(i2)=amn
14849        lb(i1)=5
14850        e(i1)=ap1
14851        go to 40
14852        Else
14853        lb(i2)=1
14854        e(i2)=amn
14855        lb(i1)=4
14856        e(i1)=ap1
14857        go to 40
14858        endif
14859               endif
14860        endif
14861 *(3) for D(-)+OMEGA(0)-->n+pi(-)
14862        if((iabs(lb(i1)).eq.6.and.lb(i2).eq.28).
14863      &  or.(lb(i1).eq.28.and.iabs(lb(i2)).eq.6))then
14864               if(iabs(lb(i1)).eq.6)then
14865         ii = i1
14866        lb(i1)=2
14867        e(i1)=amn
14868        lb(i2)=3
14869        e(i2)=ap1
14870        go to 40
14871        else
14872         ii = i2
14873        lb(i2)=2
14874        e(i2)=amn
14875        lb(i1)=3
14876        e(i1)=ap1
14877        go to 40
14878        ENDIF
14879        endif
14880 *(4) for D(++)+OMEGA(0)-->p+pi(+)
14881        if((iabs(lb(i1)).eq.9.and.lb(i2).eq.28).
14882      &  or.(lb(i1).eq.28.and.iabs(lb(i2)).eq.9))then
14883               if(iabs(lb(i1)).eq.9)then
14884         ii = i1
14885        lb(i1)=1
14886        e(i1)=amn
14887        lb(i2)=5
14888        e(i2)=ap1
14889        go to 40
14890        else
14891         ii = i2
14892        lb(i2)=1
14893        e(i2)=amn
14894        lb(i1)=5
14895        e(i1)=ap1
14896        go to 40
14897        ENDIF
14898        endif
14899 *(5) for N*(1440) or N*(1535)(0)+omega(0)-->n+pi(0) or p+pi(-)
14900        if((iabs(lb(i1)).eq.10.and.lb(i2).eq.28).
14901      &  or.(lb(i1).eq.28.and.iabs(lb(i2)).eq.10).
14902      &  or.(lb(i1).eq.28.and.iabs(lb(i2)).eq.12).
14903      &  or.(lb(i2).eq.28.and.iabs(lb(i1)).eq.12))then
14904               if(iabs(lb(i1)).eq.10.or.iabs(lb(i1)).eq.12)then
14905         ii = i1
14906        IF(X2.LE.0.5)THEN
14907        lb(i1)=2
14908        e(i1)=amn
14909        lb(i2)=4
14910        e(i2)=ap1
14911        go to 40
14912        Else
14913        lb(i1)=1
14914        e(i1)=amn
14915        lb(i2)=3
14916        e(i2)=ap1
14917        go to 40
14918        endif
14919               else
14920         ii = i2
14921        IF(X2.LE.0.5)THEN
14922        lb(i2)=2
14923        e(i2)=amn
14924        lb(i1)=4
14925        e(i1)=ap1
14926        go to 40
14927        Else
14928        lb(i2)=1
14929        e(i2)=amn
14930        lb(i1)=3
14931        e(i1)=ap1
14932        go to 40
14933        endif
14934               endif
14935        endif
14936 *(6) for N*(1440) or N*(1535)(+)+omega(0)-->pi(+)+n or pi(0)+p
14937        if((iabs(lb(i1)).eq.11.and.lb(i2).eq.28).
14938      &  or.(lb(i1).eq.28.and.iabs(lb(i2)).eq.11).
14939      &  or.(lb(i1).eq.28.and.iabs(lb(i2)).eq.13).
14940      &  or.(lb(i2).eq.28.and.iabs(lb(i1)).eq.13))then
14941               if(iabs(lb(i1)).eq.11.or.iabs(lb(i1)).eq.13)then
14942         ii = i1
14943        IF(X2.LE.0.5)THEN
14944        lb(i1)=2
14945        e(i1)=amn
14946        lb(i2)=5
14947        e(i2)=ap1
14948        go to 40
14949        Else
14950        lb(i1)=1
14951        e(i1)=amn
14952        lb(i2)=4
14953        e(i2)=ap1
14954        go to 40
14955        endif
14956               else
14957         ii = i2
14958        IF(X2.LE.0.5)THEN
14959        lb(i2)=2
14960        e(i2)=amn
14961        lb(i1)=5
14962        e(i1)=ap1
14963        go to 40
14964        Else
14965        lb(i2)=1
14966        e(i2)=amn
14967        lb(i1)=4
14968        e(i1)=ap1
14969        go to 40
14970        endif
14971               endif
14972        endif
14973 40       em1=e(i1)
14974        em2=e(i2)
14975        if(ianti.eq.1 .and. lb(i1).ge.1 .and. lb(i2).ge.1)then
14976          lb(ii) = -lb(ii)
14977            jj = i2
14978           if(ii .eq. i2)jj = i1
14979           if(lb(jj).eq.3)then
14980            lb(jj) = 5
14981           elseif(lb(jj).eq.5)then
14982            lb(jj) = 3
14983           endif
14984          endif
14985        endif
14986 *-----------------------------------------------------------------------
14987 * CALCULATE THE MAGNITUDE OF THE FINAL MOMENTUM THROUGH
14988 * ENERGY CONSERVATION
14989 50          PR2   = (SRT**2 - EM1**2 - EM2**2)**2
14990      1                - 4.0 * (EM1*EM2)**2
14991           IF(PR2.LE.0.)PR2=1.E-09
14992           PR=SQRT(PR2)/(2.*SRT)
14993 *          C1   = 1.0 - 2.0 * RANART(NSEED)
14994
14995 clin-10/25/02 get rid of argument usage mismatch in PTR():
14996           xptr=0.33*pr
14997 c         cc1=ptr(0.33*pr,iseed)
14998          cc1=ptr(xptr,iseed)
14999 clin-10/25/02-end
15000
15001          c1=sqrt(pr**2-cc1**2)/pr
15002           T1   = 2.0 * PI * RANART(NSEED)
15003       S1   = SQRT( 1.0 - C1**2 )
15004       CT1  = COS(T1)
15005       ST1  = SIN(T1)
15006       PZ   = PR * C1
15007       PX   = PR * S1*CT1
15008       PY   = PR * S1*ST1
15009 * ROTATE THE MOMENTUM
15010        CALL ROTATE(PX0,PY0,PZ0,PX,PY,PZ)
15011       RETURN
15012       END
15013 **********************************
15014 * sp 03/19/01                                                          *
15015 *                                                                      *
15016         SUBROUTINE Crlaba(PX,PY,PZ,SRT,brel,brsgm,
15017      &                        I1,I2,nt,IBLOCK,nchrg,icase)
15018 *     PURPOSE:                                                         *
15019 *            DEALING WITH   K+ + N(D,N*)-bar <-->  La(Si)-bar + pi     *
15020 *     NOTE   :                                                         *
15021 *                                                                      *
15022 *     QUANTITIES:                                                 *
15023 *           PX,PY,PZ - MOMENTUM COORDINATES OF ONE PARTICLE IN CM FRAME*
15024 *           SRT      - SQRT OF S                                       *
15025 *           IBLOCK   - THE INFORMATION BACK                            *
15026 *                     8-> elastic scatt                               *
15027 *                     100-> K+ + N-bar -> Sigma-bar + PI
15028 *                     102-> PI + Sigma(Lambda)-bar -> K+ + N-bar
15029 **********************************
15030         PARAMETER (MAXSTR=150001, MAXR=1, AMN=0.939457,
15031      1  AMP=0.93828,AP1=0.13496,
15032      2  AP2=0.13957,AM0=1.232,PI=3.1415926,CUTOFF=1.8966,AVMASS=0.9383)
15033         PARAMETER  (AKA=0.498,ALA=1.1157,ASA=1.1974)
15034         PARAMETER  (ETAM=0.5475, AOMEGA=0.782, ARHO=0.77)
15035         COMMON /AA/ R(3,MAXSTR)
15036 cc      SAVE /AA/
15037         COMMON /BB/ P(3,MAXSTR)
15038 cc      SAVE /BB/
15039         COMMON /CC/ E(MAXSTR)
15040 cc      SAVE /CC/
15041         COMMON /EE/ ID(MAXSTR),LB(MAXSTR)
15042 cc      SAVE /EE/
15043         common/input1/ MASSPR,MASSTA,ISEED,IAVOID,DT
15044 cc      SAVE /input1/
15045       COMMON/RNDF77/NSEED
15046 cc      SAVE /RNDF77/
15047       SAVE
15048       NT=NT
15049 c
15050       PX0=PX
15051       PY0=PY
15052       PZ0=PZ
15053 c
15054       if(icase .eq. 3)then
15055          rrr=RANART(NSEED)
15056          if(rrr.lt.brel) then
15057 c            !! elastic scat.  (avoid in reverse process)
15058             IBLOCK=8
15059         else
15060             IBLOCK=100
15061             if(rrr.lt.(brel+brsgm)) then
15062 c*    K+ + N-bar -> Sigma-bar + PI
15063                LB(i1) = -15 - int(3 * RANART(NSEED))
15064
15065                e(i1)=asa
15066             else
15067 c*    K+ + N-bar -> Lambda-bar + PI
15068                LB(i1)= -14
15069                e(i1)=ala
15070             endif
15071             LB(i2) = 3 + int(3 * RANART(NSEED))
15072             e(i2)=0.138
15073         endif
15074       endif
15075 c
15076 c
15077       if(icase .eq. 4)then
15078          rrr=RANART(NSEED)
15079          if(rrr.lt.brel) then
15080 c            !! elastic scat.
15081             IBLOCK=8
15082          else
15083             IBLOCK=102
15084 c    PI + Sigma(Lambda)-bar -> K+ + N-bar
15085 c         ! K+
15086             LB(i1) = 23
15087             LB(i2) = -1 - int(2 * RANART(NSEED))
15088             if(nchrg.eq.-2) LB(i2) = -6
15089             if(nchrg.eq. 1) LB(i2) = -9
15090             e(i1) = aka
15091             e(i2) = 0.938
15092             if(nchrg.eq.-2.or.nchrg.eq.1) e(i2)=1.232
15093          endif
15094       endif
15095 c
15096       EM1=E(I1)
15097       EM2=E(I2)
15098 * CALCULATE THE MAGNITUDE OF THE FINAL MOMENTUM THROUGH
15099 * ENERGY CONSERVATION
15100       PR2   = (SRT**2 - EM1**2 - EM2**2)**2
15101      1     - 4.0 * (EM1*EM2)**2
15102       IF(PR2.LE.0.)PR2=1.e-09
15103       PR=SQRT(PR2)/(2.*SRT)
15104       C1   = 1.0 - 2.0 * RANART(NSEED)
15105       T1   = 2.0 * PI * RANART(NSEED)
15106       S1   = SQRT( 1.0 - C1**2 )
15107       CT1  = COS(T1)
15108       ST1  = SIN(T1)
15109       PZ   = PR * C1
15110       PX   = PR * S1*CT1
15111       PY   = PR * S1*ST1
15112 * ROTATE IT
15113       CALL ROTATE(PX0,PY0,PZ0,PX,PY,PZ)
15114       RETURN
15115       END
15116 **********************************
15117 *                                                                      *
15118 *                                                                      *
15119       SUBROUTINE Crkn(PX,PY,PZ,SRT,I1,I2,IBLOCK)
15120 *     PURPOSE:                                                         *
15121 *             DEALING WITH kaON+N/pi-->KAON +N/pi elastic PROCESS      *
15122 *     NOTE   :                                                         *
15123 *
15124 *     QUANTITIES:                                                 *
15125 *           PX,PY,PZ - MOMENTUM COORDINATES OF ONE PARTICLE IN CM FRAME*
15126 *           SRT      - SQRT OF S                                       *
15127 *           IBLOCK   - THE INFORMATION BACK                            *
15128 *                     8-> PION+N-->L/S+KAON
15129 **********************************
15130         PARAMETER (MAXSTR=150001,MAXR=1,AMN=0.939457,
15131      1  AMP=0.93828,AP1=0.13496,
15132      2  AP2=0.13957,AM0=1.232,PI=3.1415926,CUTOFF=1.8966,AVMASS=0.9383)
15133         PARAMETER      (AKA=0.498,ALA=1.1157,ASA=1.1974)
15134         parameter     (MX=4,MY=4,MZ=8,MPX=4,MPY=4,mpz=10,mpzp=10)
15135         COMMON /AA/ R(3,MAXSTR)
15136 cc      SAVE /AA/
15137         COMMON /BB/ P(3,MAXSTR)
15138 cc      SAVE /BB/
15139         COMMON /CC/ E(MAXSTR)
15140 cc      SAVE /CC/
15141         COMMON /EE/ ID(MAXSTR),LB(MAXSTR)
15142 cc      SAVE /EE/
15143         common/input1/ MASSPR,MASSTA,ISEED,IAVOID,DT
15144 cc      SAVE /input1/
15145       COMMON/RNDF77/NSEED
15146 cc      SAVE /RNDF77/
15147       SAVE
15148
15149        PX0=PX
15150        PY0=PY
15151        PZ0=PZ
15152 *-----------------------------------------------------------------------
15153         IBLOCK=8
15154         NTAG=0
15155         EM1=E(I1)
15156         EM2=E(I2)
15157 *-----------------------------------------------------------------------
15158 * CALCULATE THE MAGNITUDE OF THE FINAL MOMENTUM THROUGH
15159 * ENERGY CONSERVATION
15160           PR2   = (SRT**2 - EM1**2 - EM2**2)**2
15161      1                - 4.0 * (EM1*EM2)**2
15162           IF(PR2.LE.0.)PR2=1.e-09
15163           PR=SQRT(PR2)/(2.*SRT)
15164           C1   = 1.0 - 2.0 * RANART(NSEED)
15165           T1   = 2.0 * PI * RANART(NSEED)
15166       S1   = SQRT( 1.0 - C1**2 )
15167       CT1  = COS(T1)
15168       ST1  = SIN(T1)
15169       PZ   = PR * C1
15170       PX   = PR * S1*CT1
15171       PY   = PR * S1*ST1
15172       RETURN
15173       END
15174 **********************************
15175 *                                                                      *
15176 *                                                                      *
15177       SUBROUTINE Crppba(PX,PY,PZ,SRT,I1,I2,IBLOCK)
15178 *     PURPOSE:                                                         *
15179
15180 clin-8/29/00*             DEALING WITH anti-nucleon annihilation with
15181 *             DEALING WITH anti-baryon annihilation with
15182
15183 *             nucleons or baryon resonances
15184 *             Determine:                                               *
15185 *             (1) no. of pions in the final state
15186 *             (2) relable particles in the final state
15187 *             (3) new momenta of final state particles                 *
15188 *
15189 *     QUANTITIES:                                                      *
15190 *           PX,PY,PZ - MOMENTUM COORDINATES OF ONE PARTICLE IN CM FRAME*
15191 *           SRT      - SQRT OF S                                       *
15192 *           IBLOCK   - INFORMATION about the reaction channel          *
15193 *
15194 *           iblock   - 1902 annihilation-->pion(+)+pion(-)   (2 pion)
15195 *           iblock   - 1903 annihilation-->pion(+)+rho(-)    (3 pion)
15196 *           iblock   - 1904 annihilation-->rho(+)+rho(-)     (4 pion)
15197 *           iblock   - 1905 annihilation-->rho(0)+omega      (5 pion)
15198 *           iblock   - 1906 annihilation-->omega+omega       (6 pion)
15199 *       charge conservation is enforced in relabling particles
15200 *       in the final state (note: at the momentum we don't check the
15201 *       initial charges while dealing with annihilation, since some
15202 *       annihilation channels between antinucleons and nucleons (baryon
15203 *       resonances) might be forbiden by charge conservation, this effect
15204 *       should be small, but keep it in mind.
15205 **********************************
15206         PARAMETER (MAXSTR=150001,MAXR=1,AMN=0.939457,
15207      1  AMP=0.93828,AP1=0.13496,AMRHO=0.769,AMOMGA=0.782,
15208      2  AP2=0.13957,AM0=1.232,PI=3.1415926,CUTOFF=1.8966,AVMASS=0.9383)
15209         PARAMETER      (AKA=0.498,ALA=1.1157,ASA=1.1974)
15210         parameter     (MX=4,MY=4,MZ=8,MPX=4,MPY=4,mpz=10,mpzp=10)
15211         COMMON /AA/ R(3,MAXSTR)
15212 cc      SAVE /AA/
15213         COMMON /BB/ P(3,MAXSTR)
15214 cc      SAVE /BB/
15215         COMMON /CC/ E(MAXSTR)
15216 cc      SAVE /CC/
15217         COMMON /EE/ ID(MAXSTR),LB(MAXSTR)
15218 cc      SAVE /EE/
15219         common/input1/ MASSPR,MASSTA,ISEED,IAVOID,DT
15220 cc      SAVE /input1/
15221       COMMON/RNDF77/NSEED
15222 cc      SAVE /RNDF77/
15223       SAVE
15224
15225        PX0=PX
15226        PY0=PY
15227        PZ0=PZ
15228 * determine the no. of pions in the final state using a
15229 * statistical model
15230        call pbarfs(srt,npion,iseed)
15231 * find the masses of the final state particles before calculate
15232 * their momenta, and relable them. The masses of rho and omega
15233 * will be generated according to the Breit Wigner formula       (NOTE!!!
15234 * NOT DONE YET, AT THE MOMENT LET US USE FIXED RHO AND OMEGA MAEES)
15235 cbali2/22/99
15236 * Here we generate two stes of integer random numbers (3,4,5)
15237 * one or both of them are used directly as the lables of pions
15238 * similarly, 22+nchrg1 and 22+nchrg2 are used directly
15239 * to label rhos
15240        nchrg1=3+int(3*RANART(NSEED))
15241        nchrg2=3+int(3*RANART(NSEED))
15242 * the corresponding masses of pions
15243       pmass1=ap1
15244        pmass2=ap1
15245        if(nchrg1.eq.3.or.nchrg1.eq.5)pmass1=ap2
15246        if(nchrg2.eq.3.or.nchrg2.eq.5)pmass2=ap2
15247 * (1) for 2 pion production
15248        IF(NPION.EQ.2)THEN
15249        IBLOCK=1902
15250 * randomly generate the charges of final state particles,
15251        LB(I1)=nchrg1
15252        E(I1)=pmass1
15253        LB(I2)=nchrg2
15254        E(I2)=pmass2
15255 * TO CALCULATE THE FINAL MOMENTA
15256        GO TO 50
15257        ENDIF
15258 * (2) FOR 3 PION PRODUCTION
15259        IF(NPION.EQ.3)THEN
15260        IBLOCK=1903
15261        LB(I1)=nchrg1
15262        E(I1)=pmass1
15263        LB(I2)=22+nchrg2
15264             E(I2)=AMRHO
15265        GO TO 50
15266        ENDIF
15267 * (3) FOR 4 PION PRODUCTION
15268 * we allow both rho+rho and pi+omega with 50-50% probability
15269         IF(NPION.EQ.4)THEN
15270        IBLOCK=1904
15271 * determine rho+rho or pi+omega
15272        if(RANART(NSEED).ge.0.5)then
15273 * rho+rho
15274        LB(I1)=22+nchrg1
15275        E(I1)=AMRHO
15276        LB(I2)=22+nchrg2
15277             E(I2)=AMRHO
15278        else
15279 * pion+omega
15280        LB(I1)=nchrg1
15281        E(I1)=pmass1
15282        LB(I2)=28
15283             E(I2)=AMOMGA
15284        endif
15285        GO TO 50
15286        ENDIF
15287 * (4) FOR 5 PION PRODUCTION
15288         IF(NPION.EQ.5)THEN
15289        IBLOCK=1905
15290 * RHO AND OMEGA
15291         LB(I1)=22+nchrg1
15292        E(I1)=AMRHO
15293        LB(I2)=28
15294        E(I2)=AMOMGA
15295        GO TO 50
15296        ENDIF
15297 * (5) FOR 6 PION PRODUCTION
15298          IF(NPION.EQ.6)THEN
15299        IBLOCK=1906
15300 * OMEGA AND OMEGA
15301         LB(I1)=28
15302        E(I1)=AMOMGA
15303        LB(I2)=28
15304           E(I2)=AMOMGA
15305        ENDIF
15306 cbali2/22/99
15307 50    EM1=E(I1)
15308       EM2=E(I2)
15309 *-----------------------------------------------------------------------
15310 * CALCULATE THE MAGNITUDE OF THE FINAL MOMENTUM THROUGH
15311 * ENERGY CONSERVATION
15312           PR2   = (SRT**2 - EM1**2 - EM2**2)**2
15313      1                - 4.0 * (EM1*EM2)**2
15314           IF(PR2.LE.0.)PR2=1.E-08
15315           PR=SQRT(PR2)/(2.*SRT)
15316 * WE ASSUME AN ISOTROPIC ANGULAR DISTRIBUTION IN THE CMS
15317           C1   = 1.0 - 2.0 * RANART(NSEED)
15318           T1   = 2.0 * PI * RANART(NSEED)
15319       S1   = SQRT( 1.0 - C1**2 )
15320       CT1  = COS(T1)
15321       ST1  = SIN(T1)
15322 * THE MOMENTUM IN THE CMS IN THE FINAL STATE
15323       PZ   = PR * C1
15324       PX   = PR * S1*CT1
15325       PY   = PR * S1*ST1
15326 * ROTATE IT
15327        CALL ROTATE(PX0,PY0,PZ0,PX,PY,PZ)
15328       RETURN
15329       END
15330 cbali2/7/99end
15331 cbali3/5/99
15332 **********************************
15333 *     PURPOSE:                                                         *
15334 *     assign final states for K+K- --> light mesons
15335 *
15336       SUBROUTINE crkkpi(I1,I2,XSK1, XSK2, XSK3, XSK4,
15337      &             XSK5, XSK6, XSK7, XSK8, XSK9, XSK10, XSK11, SIGK,
15338      &             IBLOCK,lbp1,lbp2,emm1,emm2)
15339 *
15340 *     QUANTITIES:                                                     *
15341 *           IBLOCK   - INFORMATION about the reaction channel          *
15342 *
15343 *             iblock   - 1907
15344 **********************************
15345         PARAMETER (MAXSTR=150001,MAXR=1,AMN=0.939457,
15346      1  AMP=0.93828,AP1=0.13496,AMRHO=0.769,AMOMGA=0.782,
15347      &  AMETA = 0.5473,
15348      2  AP2=0.13957,AM0=1.232,PI=3.1415926,CUTOFF=1.8966,AVMASS=0.9383)
15349         PARAMETER      (AKA=0.498,ALA=1.1157,ASA=1.1974)
15350         parameter     (MX=4,MY=4,MZ=8,MPX=4,MPY=4,mpz=10,mpzp=10)
15351         COMMON /AA/ R(3,MAXSTR)
15352 cc      SAVE /AA/
15353         COMMON /BB/ P(3,MAXSTR)
15354 cc      SAVE /BB/
15355         COMMON /CC/ E(MAXSTR)
15356 cc      SAVE /CC/
15357         COMMON /EE/ ID(MAXSTR),LB(MAXSTR)
15358 cc      SAVE /EE/
15359         common/input1/ MASSPR,MASSTA,ISEED,IAVOID,DT
15360 cc      SAVE /input1/
15361       COMMON/RNDF77/NSEED
15362 cc      SAVE /RNDF77/
15363       SAVE
15364
15365         XSK11=XSK11
15366         IBLOCK=1907
15367         X1 = RANART(NSEED) * SIGK
15368         XSK2 = XSK1 + XSK2
15369         XSK3 = XSK2 + XSK3
15370         XSK4 = XSK3 + XSK4
15371         XSK5 = XSK4 + XSK5
15372         XSK6 = XSK5 + XSK6
15373         XSK7 = XSK6 + XSK7
15374         XSK8 = XSK7 + XSK8
15375         XSK9 = XSK8 + XSK9
15376         XSK10 = XSK9 + XSK10
15377         IF (X1 .LE. XSK1) THEN
15378            LB(I1) = 3 + int(3 * RANART(NSEED))
15379            LB(I2) = 3 + int(3 * RANART(NSEED))
15380            E(I1) = AP2
15381            E(I2) = AP2
15382            GOTO 100
15383         ELSE IF (X1 .LE. XSK2) THEN
15384            LB(I1) = 3 + int(3 * RANART(NSEED))
15385            LB(I2) = 25 + int(3 * RANART(NSEED))
15386            E(I1) = AP2
15387            E(I2) = AMRHO
15388            GOTO 100
15389         ELSE IF (X1 .LE. XSK3) THEN
15390            LB(I1) = 3 + int(3 * RANART(NSEED))
15391            LB(I2) = 28
15392            E(I1) = AP2
15393            E(I2) = AMOMGA
15394            GOTO 100
15395         ELSE IF (X1 .LE. XSK4) THEN
15396            LB(I1) = 3 + int(3 * RANART(NSEED))
15397            LB(I2) = 0
15398            E(I1) = AP2
15399            E(I2) = AMETA
15400            GOTO 100
15401         ELSE IF (X1 .LE. XSK5) THEN
15402            LB(I1) = 25 + int(3 * RANART(NSEED))
15403            LB(I2) = 25 + int(3 * RANART(NSEED))
15404            E(I1) = AMRHO
15405            E(I2) = AMRHO
15406            GOTO 100
15407         ELSE IF (X1 .LE. XSK6) THEN
15408            LB(I1) = 25 + int(3 * RANART(NSEED))
15409            LB(I2) = 28
15410            E(I1) = AMRHO
15411            E(I2) = AMOMGA
15412            GOTO 100
15413         ELSE IF (X1 .LE. XSK7) THEN
15414            LB(I1) = 25 + int(3 * RANART(NSEED))
15415            LB(I2) = 0
15416            E(I1) = AMRHO
15417            E(I2) = AMETA
15418            GOTO 100
15419         ELSE IF (X1 .LE. XSK8) THEN
15420            LB(I1) = 28
15421            LB(I2) = 28
15422            E(I1) = AMOMGA
15423            E(I2) = AMOMGA
15424            GOTO 100
15425         ELSE IF (X1 .LE. XSK9) THEN
15426            LB(I1) = 28
15427            LB(I2) = 0
15428            E(I1) = AMOMGA
15429            E(I2) = AMETA
15430            GOTO 100
15431         ELSE IF (X1 .LE. XSK10) THEN
15432            LB(I1) = 0
15433            LB(I2) = 0
15434            E(I1) = AMETA
15435            E(I2) = AMETA
15436         ELSE
15437           iblock = 222
15438           call rhores(i1,i2)
15439 c     !! phi
15440           lb(i1) = 29
15441 c          return
15442           e(i2)=0.
15443         END IF
15444
15445  100    CONTINUE
15446         lbp1=lb(i1)
15447         lbp2=lb(i2)
15448         emm1=e(i1)
15449         emm2=e(i2)
15450
15451       RETURN
15452       END
15453 **********************************
15454 *     PURPOSE:                                                         *
15455 *             DEALING WITH K+Y -> piN scattering
15456 *
15457       SUBROUTINE Crkhyp(PX,PY,PZ,SRT,I1,I2,
15458      &     XKY1, XKY2, XKY3, XKY4, XKY5,
15459      &     XKY6, XKY7, XKY8, XKY9, XKY10, XKY11, XKY12, XKY13,
15460      &     XKY14, XKY15, XKY16, XKY17, SIGK, IKMP,
15461      &     IBLOCK)
15462 *
15463 *             Determine:                                               *
15464 *             (1) relable particles in the final state                 *
15465 *             (2) new momenta of final state particles                 *
15466 *                                                                        *
15467 *     QUANTITIES:                                                    *
15468 *           PX,PY,PZ - MOMENTUM COORDINATES OF ONE PARTICLE IN CM FRAME*
15469 *           SRT      - SQRT OF S                                       *
15470 *           IBLOCK   - INFORMATION about the reaction channel          *
15471 *                                                                     *
15472 *             iblock   - 1908                                          *
15473 *             iblock   - 222   !! phi                                  *
15474 **********************************
15475         PARAMETER (MAXSTR=150001,MAXR=1,AMN=0.939457,
15476      1  AMP=0.93828,AP1=0.13496,AMRHO=0.769,AMOMGA=0.782,APHI=1.02,
15477      2  AP2=0.13957,AM0=1.232,PI=3.1415926,CUTOFF=1.8966,AVMASS=0.9383)
15478           parameter (pimass=0.140, AMETA = 0.5473, aka=0.498,
15479      &     aml=1.116,ams=1.193, AM1440 = 1.44, AM1535 = 1.535)
15480         parameter     (MX=4,MY=4,MZ=8,MPX=4,MPY=4,mpz=10,mpzp=10)
15481         COMMON /AA/ R(3,MAXSTR)
15482 cc      SAVE /AA/
15483         COMMON /BB/ P(3,MAXSTR)
15484 cc      SAVE /BB/
15485         COMMON /CC/ E(MAXSTR)
15486 cc      SAVE /CC/
15487         COMMON /EE/ ID(MAXSTR),LB(MAXSTR)
15488 cc      SAVE /EE/
15489         common/input1/ MASSPR,MASSTA,ISEED,IAVOID,DT
15490 cc      SAVE /input1/
15491       COMMON/RNDF77/NSEED
15492 cc      SAVE /RNDF77/
15493       SAVE
15494
15495        XKY17=XKY17
15496        PX0=PX
15497        PY0=PY
15498        PZ0=PZ
15499        IBLOCK=1908
15500 c
15501         X1 = RANART(NSEED) * SIGK
15502         XKY2 = XKY1 + XKY2
15503         XKY3 = XKY2 + XKY3
15504         XKY4 = XKY3 + XKY4
15505         XKY5 = XKY4 + XKY5
15506         XKY6 = XKY5 + XKY6
15507         XKY7 = XKY6 + XKY7
15508         XKY8 = XKY7 + XKY8
15509         XKY9 = XKY8 + XKY9
15510         XKY10 = XKY9 + XKY10
15511         XKY11 = XKY10 + XKY11
15512         XKY12 = XKY11 + XKY12
15513         XKY13 = XKY12 + XKY13
15514         XKY14 = XKY13 + XKY14
15515         XKY15 = XKY14 + XKY15
15516         XKY16 = XKY15 + XKY16
15517         IF (X1 .LE. XKY1) THEN
15518            LB(I1) = 3 + int(3 * RANART(NSEED))
15519            LB(I2) = 1 + int(2 * RANART(NSEED))
15520            E(I1) = PIMASS
15521            E(I2) = AMP
15522            GOTO 100
15523         ELSE IF (X1 .LE. XKY2) THEN
15524            LB(I1) = 3 + int(3 * RANART(NSEED))
15525            LB(I2) = 6 + int(4 * RANART(NSEED))
15526            E(I1) = PIMASS
15527            E(I2) = AM0
15528            GOTO 100
15529         ELSE IF (X1 .LE. XKY3) THEN
15530            LB(I1) = 3 + int(3 * RANART(NSEED))
15531            LB(I2) = 10 + int(2 * RANART(NSEED))
15532            E(I1) = PIMASS
15533            E(I2) = AM1440
15534            GOTO 100
15535         ELSE IF (X1 .LE. XKY4) THEN
15536            LB(I1) = 3 + int(3 * RANART(NSEED))
15537            LB(I2) = 12 + int(2 * RANART(NSEED))
15538            E(I1) = PIMASS
15539            E(I2) = AM1535
15540            GOTO 100
15541         ELSE IF (X1 .LE. XKY5) THEN
15542            LB(I1) = 25 + int(3 * RANART(NSEED))
15543            LB(I2) = 1 + int(2 * RANART(NSEED))
15544            E(I1) = AMRHO
15545            E(I2) = AMP
15546            GOTO 100
15547         ELSE IF (X1 .LE. XKY6) THEN
15548            LB(I1) = 25 + int(3 * RANART(NSEED))
15549            LB(I2) = 6 + int(4 * RANART(NSEED))
15550            E(I1) = AMRHO
15551            E(I2) = AM0
15552            GOTO 100
15553         ELSE IF (X1 .LE. XKY7) THEN
15554            LB(I1) = 25 + int(3 * RANART(NSEED))
15555            LB(I2) = 10 + int(2 * RANART(NSEED))
15556            E(I1) = AMRHO
15557            E(I2) = AM1440
15558            GOTO 100
15559         ELSE IF (X1 .LE. XKY8) THEN
15560            LB(I1) = 25 + int(3 * RANART(NSEED))
15561            LB(I2) = 12 + int(2 * RANART(NSEED))
15562            E(I1) = AMRHO
15563            E(I2) = AM1535
15564            GOTO 100
15565         ELSE IF (X1 .LE. XKY9) THEN
15566            LB(I1) = 28
15567            LB(I2) = 1 + int(2 * RANART(NSEED))
15568            E(I1) = AMOMGA
15569            E(I2) = AMP
15570            GOTO 100
15571         ELSE IF (X1 .LE. XKY10) THEN
15572            LB(I1) = 28
15573            LB(I2) = 6 + int(4 * RANART(NSEED))
15574            E(I1) = AMOMGA
15575            E(I2) = AM0
15576            GOTO 100
15577         ELSE IF (X1 .LE. XKY11) THEN
15578            LB(I1) = 28
15579            LB(I2) = 10 + int(2 * RANART(NSEED))
15580            E(I1) = AMOMGA
15581            E(I2) = AM1440
15582            GOTO 100
15583         ELSE IF (X1 .LE. XKY12) THEN
15584            LB(I1) = 28
15585            LB(I2) = 12 + int(2 * RANART(NSEED))
15586            E(I1) = AMOMGA
15587            E(I2) = AM1535
15588            GOTO 100
15589         ELSE IF (X1 .LE. XKY13) THEN
15590            LB(I1) = 0
15591            LB(I2) = 1 + int(2 * RANART(NSEED))
15592            E(I1) = AMETA
15593            E(I2) = AMP
15594            GOTO 100
15595         ELSE IF (X1 .LE. XKY14) THEN
15596            LB(I1) = 0
15597            LB(I2) = 6 + int(4 * RANART(NSEED))
15598            E(I1) = AMETA
15599            E(I2) = AM0
15600            GOTO 100
15601         ELSE IF (X1 .LE. XKY15) THEN
15602            LB(I1) = 0
15603            LB(I2) = 10 + int(2 * RANART(NSEED))
15604            E(I1) = AMETA
15605            E(I2) = AM1440
15606            GOTO 100
15607         ELSE IF (X1 .LE. XKY16) THEN
15608            LB(I1) = 0
15609            LB(I2) = 12 + int(2 * RANART(NSEED))
15610            E(I1) = AMETA
15611            E(I2) = AM1535
15612            GOTO 100
15613         ELSE
15614            LB(I1) = 29
15615            LB(I2) = 1 + int(2 * RANART(NSEED))
15616            E(I1) = APHI
15617            E(I2) = AMN
15618           IBLOCK=222
15619            GOTO 100
15620         END IF
15621
15622  100    CONTINUE
15623          if(IKMP .eq. -1) LB(I2) = -LB(I2)
15624
15625       EM1=E(I1)
15626       EM2=E(I2)
15627 *-----------------------------------------------------------------------
15628 * CALCULATE THE MAGNITUDE OF THE FINAL MOMENTUM THROUGH
15629 * ENERGY CONSERVATION
15630           PR2   = (SRT**2 - EM1**2 - EM2**2)**2
15631      1                - 4.0 * (EM1*EM2)**2
15632           IF(PR2.LE.0.)PR2=1.E-08
15633           PR=SQRT(PR2)/(2.*SRT)
15634 * WE ASSUME AN ISOTROPIC ANGULAR DISTRIBUTION IN THE CMS
15635           C1   = 1.0 - 2.0 * RANART(NSEED)
15636           T1   = 2.0 * PI * RANART(NSEED)
15637       S1   = SQRT( 1.0 - C1**2 )
15638       CT1  = COS(T1)
15639       ST1  = SIN(T1)
15640 * THE MOMENTUM IN THE CMS IN THE FINAL STATE
15641       PZ   = PR * C1
15642       PX   = PR * S1*CT1
15643       PY   = PR * S1*ST1
15644 * ROTATE IT
15645        CALL ROTATE(PX0,PY0,PZ0,PX,PY,PZ)
15646       RETURN
15647       END
15648 **********************************
15649 *                                                                      *
15650 *                                                                      *
15651       SUBROUTINE CRLAN(PX,PY,PZ,SRT,I1,I2,IBLOCK)
15652 *     PURPOSE:                                                         *
15653 *      DEALING WITH La/Si-bar + N --> K+ + pi PROCESS                  *
15654 *                   La/Si + N-bar --> K- + pi                          *
15655 *     NOTE   :                                                         *
15656 *
15657 *     QUANTITIES:                                                      *
15658 *           PX,PY,PZ - MOMENTUM COORDINATES OF ONE PARTICLE IN CM FRAME*
15659 *           SRT      - SQRT OF S                                       *
15660 *           IBLOCK   - THE INFORMATION BACK                            *
15661 *                      71
15662 **********************************
15663         PARAMETER (MAXSTR=150001,MAXR=1,AMN=0.939457,
15664      1  AMP=0.93828,AP1=0.13496,
15665      2  AP2=0.13957,AM0=1.232,PI=3.1415926,CUTOFF=1.8966,AVMASS=0.9383)
15666         PARAMETER      (AKA=0.498,ALA=1.1157,ASA=1.1974)
15667         parameter     (MX=4,MY=4,MZ=8,MPX=4,MPY=4,mpz=10,mpzp=10)
15668         COMMON /AA/ R(3,MAXSTR)
15669 cc      SAVE /AA/
15670         COMMON /BB/ P(3,MAXSTR)
15671 cc      SAVE /BB/
15672         COMMON /CC/ E(MAXSTR)
15673 cc      SAVE /CC/
15674         COMMON /EE/ ID(MAXSTR),LB(MAXSTR)
15675 cc      SAVE /EE/
15676         common/input1/ MASSPR,MASSTA,ISEED,IAVOID,DT
15677 cc      SAVE /input1/
15678       COMMON/RNDF77/NSEED
15679 cc      SAVE /RNDF77/
15680       SAVE
15681
15682         PX0=PX
15683         PY0=PY
15684         PZ0=PZ
15685         IBLOCK=71
15686         NTAG=0
15687        if( (lb(i1).ge.14.and.lb(i1).le.17) .OR.
15688      &     (lb(i2).ge.14.and.lb(i2).le.17) )then
15689         LB(I1)=21
15690        else
15691         LB(I1)=23
15692        endif
15693         LB(I2)= 3 + int(3 * RANART(NSEED))
15694         E(I1)=AKA
15695         E(I2)=0.138
15696         EM1=E(I1)
15697         EM2=E(I2)
15698 *-----------------------------------------------------------------------
15699 * CALCULATE THE MAGNITUDE OF THE FINAL MOMENTUM THROUGH
15700 * ENERGY CONSERVATION
15701         PR2   = (SRT**2 - EM1**2 - EM2**2)**2
15702      1                - 4.0 * (EM1*EM2)**2
15703           IF(PR2.LE.0.)PR2=1.e-09
15704           PR=SQRT(PR2)/(2.*SRT)
15705           C1   = 1.0 - 2.0 * RANART(NSEED)
15706           T1   = 2.0 * PI * RANART(NSEED)
15707       S1   = SQRT( 1.0 - C1**2 )
15708       CT1  = COS(T1)
15709       ST1  = SIN(T1)
15710 * THE MOMENTUM IN THE CMS IN THE FINAL STATE
15711       PZ   = PR * C1
15712       PX   = PR * S1*CT1
15713       PY   = PR * S1*ST1
15714 * FOR THE ISOTROPIC DISTRIBUTION THERE IS NO NEED TO ROTATE
15715       RETURN
15716       END
15717 csp11/03/01 end
15718 **********************************
15719 **********************************
15720 *                                                                      *
15721 *                                                                      *
15722         SUBROUTINE Crkpla(PX,PY,PZ,EC,SRT,spika,
15723      &                  emm1,emm2,lbp1,lbp2,I1,I2,icase,srhoks)
15724
15725 *     PURPOSE:                                                         *
15726 *     DEALING WITH  K+ + Pi ---> La/Si-bar + B, phi+K, phi+K* OR  K* *
15727 *                   K- + Pi ---> La/Si + B-bar  OR   K*-bar          *
15728
15729 *     NOTE   :                                                         *
15730 *
15731 *     QUANTITIES:                                                      *
15732 *           PX,PY,PZ - MOMENTUM COORDINATES OF ONE PARTICLE IN CM FRAME*
15733 *           SRT      - SQRT OF S                                       *
15734 *           IBLOCK   - THE INFORMATION BACK                            *
15735 *                      71
15736 **********************************
15737         PARAMETER (MAXSTR=150001,MAXR=1,AMN=0.939457,
15738      1  AMP=0.93828,AP1=0.13496,AP2=0.13957,AMRHO=0.769,AMOMGA=0.782,
15739      2  AM0=1.232,PI=3.1415926,CUTOFF=1.8966,AVMASS=0.9383)
15740         PARAMETER (AKA=0.498,AKS=0.895,ALA=1.1157,ASA=1.1974
15741      1 ,APHI=1.02)
15742         PARAMETER (AM1440 = 1.44, AM1535 = 1.535)
15743         parameter     (MX=4,MY=4,MZ=8,MPX=4,MPY=4,mpz=10,mpzp=10)
15744         COMMON /AA/ R(3,MAXSTR)
15745 cc      SAVE /AA/
15746         COMMON /BB/ P(3,MAXSTR)
15747 cc      SAVE /BB/
15748         COMMON /CC/ E(MAXSTR)
15749 cc      SAVE /CC/
15750         COMMON /EE/ ID(MAXSTR),LB(MAXSTR)
15751 cc      SAVE /EE/
15752         common/input1/ MASSPR,MASSTA,ISEED,IAVOID,DT
15753 cc      SAVE /input1/
15754       COMMON/RNDF77/NSEED
15755 cc      SAVE /RNDF77/
15756       SAVE
15757
15758           emm1=0.
15759           emm2=0.
15760           lbp1=0
15761           lbp2=0
15762            XKP0 = spika
15763            XKP1 = 0.
15764            XKP2 = 0.
15765            XKP3 = 0.
15766            XKP4 = 0.
15767            XKP5 = 0.
15768            XKP6 = 0.
15769            XKP7 = 0.
15770            XKP8 = 0.
15771            XKP9 = 0.
15772            XKP10 = 0.
15773            sigm = 15.
15774 c         if(lb(i1).eq.21.or.lb(i2).eq.21)sigm=10.
15775         pdd = (srt**2-(aka+ap1)**2)*(srt**2-(aka-ap1)**2)
15776 c
15777          if(srt .lt. (ala+amn))go to 70
15778         XKP1 = sigm*(4./3.)*(srt**2-(ala+amn)**2)*
15779      &           (srt**2-(ala-amn)**2)/pdd
15780          if(srt .gt. (ala+am0))then
15781         XKP2 = sigm*(16./3.)*(srt**2-(ala+am0)**2)*
15782      &           (srt**2-(ala-am0)**2)/pdd
15783          endif
15784          if(srt .gt. (ala+am1440))then
15785         XKP3 = sigm*(4./3.)*(srt**2-(ala+am1440)**2)*
15786      &           (srt**2-(ala-am1440)**2)/pdd
15787          endif
15788          if(srt .gt. (ala+am1535))then
15789         XKP4 = sigm*(4./3.)*(srt**2-(ala+am1535)**2)*
15790      &           (srt**2-(ala-am1535)**2)/pdd
15791          endif
15792 c
15793          if(srt .gt. (asa+amn))then
15794         XKP5 = sigm*4.*(srt**2-(asa+amn)**2)*
15795      &           (srt**2-(asa-amn)**2)/pdd
15796          endif
15797          if(srt .gt. (asa+am0))then
15798         XKP6 = sigm*16.*(srt**2-(asa+am0)**2)*
15799      &           (srt**2-(asa-am0)**2)/pdd
15800          endif
15801          if(srt .gt. (asa+am1440))then
15802         XKP7 = sigm*4.*(srt**2-(asa+am1440)**2)*
15803      &           (srt**2-(asa-am1440)**2)/pdd
15804          endif
15805          if(srt .gt. (asa+am1535))then
15806         XKP8 = sigm*4.*(srt**2-(asa+am1535)**2)*
15807      &           (srt**2-(asa-am1535)**2)/pdd
15808          endif
15809 70     continue
15810           sig1 = 195.639
15811           sig2 = 372.378
15812        if(srt .gt. aphi+aka)then
15813         pff = sqrt((srt**2-(aphi+aka)**2)*(srt**2-(aphi-aka)**2))
15814          XKP9 = sig1*pff/sqrt(pdd)*1./32./pi/srt**2
15815         if(srt .gt. aphi+aks)then
15816         pff = sqrt((srt**2-(aphi+aks)**2)*(srt**2-(aphi-aks)**2))
15817          XKP10 = sig2*pff/sqrt(pdd)*3./32./pi/srt**2
15818        endif
15819         endif
15820
15821 clin-8/15/02 K pi -> K* (rho omega), from detailed balance,
15822 c neglect rho and omega mass difference for now:
15823         sigpik=0.
15824         if(srt.gt.(amrho+aks)) then
15825            sigpik=srhoks*9.
15826      1          *(srt**2-(0.77-aks)**2)*(srt**2-(0.77+aks)**2)/4
15827      2          /srt**2/(px**2+py**2+pz**2)
15828            if(srt.gt.(amomga+aks)) sigpik=sigpik*12./9.
15829         endif
15830
15831 c
15832          sigkp = XKP0 + XKP1 + XKP2 + XKP3 + XKP4
15833      &         + XKP5 + XKP6 + XKP7 + XKP8 + XKP9 + XKP10 +sigpik
15834            icase = 0
15835          DSkn=SQRT(sigkp/PI/10.)
15836         dsknr=dskn+0.1
15837         CALL DISTCE(I1,I2,dsknr,DSkn,DT,EC,SRT,IC,
15838      1  PX,PY,PZ)
15839         IF(IC.EQ.-1)return
15840 c
15841         randu = RANART(NSEED)*sigkp
15842         XKP1 = XKP0 + XKP1
15843         XKP2 = XKP1 + XKP2
15844         XKP3 = XKP2 + XKP3
15845         XKP4 = XKP3 + XKP4
15846         XKP5 = XKP4 + XKP5
15847         XKP6 = XKP5 + XKP6
15848         XKP7 = XKP6 + XKP7
15849         XKP8 = XKP7 + XKP8
15850         XKP9 = XKP8 + XKP9
15851
15852         XKP10 = XKP9 + XKP10
15853 c
15854 c   !! K* formation
15855          if(randu .le. XKP0)then
15856            icase = 1
15857             return
15858          else
15859 * La/Si-bar + B formation
15860            icase = 2
15861          if( randu .le. XKP1 )then
15862              lbp1 = -14
15863              lbp2 = 1 + int(2*RANART(NSEED))
15864              emm1 = ala
15865              emm2 = amn
15866              go to 60
15867          elseif( randu .le. XKP2 )then
15868              lbp1 = -14
15869              lbp2 = 6 + int(4*RANART(NSEED))
15870              emm1 = ala
15871              emm2 = am0
15872              go to 60
15873          elseif( randu .le. XKP3 )then
15874              lbp1 = -14
15875              lbp2 = 10 + int(2*RANART(NSEED))
15876              emm1 = ala
15877              emm2 = am1440
15878              go to 60
15879          elseif( randu .le. XKP4 )then
15880              lbp1 = -14
15881              lbp2 = 12 + int(2*RANART(NSEED))
15882              emm1 = ala
15883              emm2 = am1535
15884              go to 60
15885          elseif( randu .le. XKP5 )then
15886              lbp1 = -15 - int(3*RANART(NSEED))
15887              lbp2 = 1 + int(2*RANART(NSEED))
15888              emm1 = asa
15889              emm2 = amn
15890              go to 60
15891          elseif( randu .le. XKP6 )then
15892              lbp1 = -15 - int(3*RANART(NSEED))
15893              lbp2 = 6 + int(4*RANART(NSEED))
15894              emm1 = asa
15895              emm2 = am0
15896              go to 60
15897           elseif( randu .lt. XKP7 )then
15898              lbp1 = -15 - int(3*RANART(NSEED))
15899              lbp2 = 10 + int(2*RANART(NSEED))
15900              emm1 = asa
15901              emm2 = am1440
15902              go to 60
15903           elseif( randu .lt. XKP8 )then
15904              lbp1 = -15 - int(3*RANART(NSEED))
15905              lbp2 = 12 + int(2*RANART(NSEED))
15906              emm1 = asa
15907              emm2 = am1535
15908              go to 60
15909           elseif( randu .lt. XKP9 )then
15910 c       !! phi +K  formation (iblock=224)
15911             icase = 3
15912              lbp1 = 29
15913              lbp2 = 23
15914              emm1 = aphi
15915              emm2 = aka
15916            if(lb(i1).eq.21.or.lb(i2).eq.21)then
15917 c         !! phi +K-bar  formation (iblock=124)
15918              lbp2 = 21
15919              icase = -3
15920            endif
15921              go to 60
15922           elseif( randu .lt. XKP10 )then
15923 c       !! phi +K* formation (iblock=226)
15924             icase = 4
15925              lbp1 = 29
15926              lbp2 = 30
15927              emm1 = aphi
15928              emm2 = aks
15929            if(lb(i1).eq.21.or.lb(i2).eq.21)then
15930              lbp2 = -30
15931              icase = -4
15932            endif
15933            go to 60
15934
15935           else
15936 c       !! (rho,omega) +K* formation (iblock=88)
15937             icase=5
15938             lbp1=25+int(3*RANART(NSEED))
15939             lbp2=30
15940             emm1=amrho
15941             emm2=aks
15942             if(srt.gt.(amomga+aks).and.RANART(NSEED).lt.0.25) then
15943                lbp1=28
15944                emm1=amomga
15945             endif
15946             if(lb(i1).eq.21.or.lb(i2).eq.21)then
15947                lbp2=-30
15948                icase=-5
15949             endif
15950
15951           endif
15952           endif
15953 c
15954 60       if( icase.eq.2 .and. (lb(i1).eq.21.or.lb(i2).eq.21) )then
15955             lbp1 = -lbp1
15956             lbp2 = -lbp2
15957          endif
15958         PX0=PX
15959         PY0=PY
15960         PZ0=PZ
15961 *-----------------------------------------------------------------------
15962 * CALCULATE THE MAGNITUDE OF THE FINAL MOMENTUM THROUGH
15963 * ENERGY CONSERVATION
15964            PR2   = (SRT**2 - EMM1**2 - EMM2**2)**2
15965      1                - 4.0 * (EMM1*EMM2)**2
15966           IF(PR2.LE.0.)PR2=1.e-09
15967           PR=SQRT(PR2)/(2.*SRT)
15968           C1   = 1.0 - 2.0 * RANART(NSEED)
15969           T1   = 2.0 * PI * RANART(NSEED)
15970       S1   = SQRT( 1.0 - C1**2 )
15971       CT1  = COS(T1)
15972       ST1  = SIN(T1)
15973 * THE MOMENTUM IN THE CMS IN THE FINAL STATE
15974       PZ   = PR * C1
15975       PX   = PR * S1*CT1
15976       PY   = PR * S1*ST1
15977 * FOR THE ISOTROPIC DISTRIBUTION THERE IS NO NEED TO ROTATE
15978       RETURN
15979       END
15980 **********************************
15981 *                                                                      *
15982 *                                                                      *
15983         SUBROUTINE Crkphi(PX,PY,PZ,EC,SRT,IBLOCK,
15984      &                  emm1,emm2,lbp1,lbp2,I1,I2,ikk,icase,rrkk,prkk)
15985
15986 *     PURPOSE:                                                         *
15987 *     DEALING WITH   KKbar, KK*bar, KbarK*, K*K*bar --> Phi + pi(rho,omega)
15988 *     and KKbar --> (pi eta) (pi eta), (rho omega) (rho omega)
15989 *     and KK*bar or Kbar K* --> (pi eta) (rho omega)
15990 *
15991 *     NOTE   :                                                         *
15992 *
15993 *     QUANTITIES:                                                      *
15994 *           PX,PY,PZ - MOMENTUM COORDINATES OF ONE PARTICLE IN CM FRAME*
15995 *           SRT      - SQRT OF S                                       *
15996 *           IBLOCK   - THE INFORMATION BACK                            *
15997 *                      222
15998 **********************************
15999         PARAMETER (MAXSTR=150001,MAXR=1,AMN=0.939457,
16000      1  AMP=0.93828,AP1=0.13496,AP2=0.13957,APHI=1.02,
16001      2  AM0=1.232,AMNS=1.52,PI=3.1415926,CUTOFF=1.8966,AVMASS=0.9383)
16002         PARAMETER      (AKA=0.498,ALA=1.1157,ASA=1.1974,ACAS=1.3213)
16003         PARAMETER      (AKS=0.895,AOMEGA=0.7819, ARHO=0.77)
16004         parameter     (MX=4,MY=4,MZ=8,MPX=4,MPY=4,mpz=10,mpzp=10)
16005         COMMON /AA/ R(3,MAXSTR)
16006 cc      SAVE /AA/
16007         COMMON /BB/ P(3,MAXSTR)
16008 cc      SAVE /BB/
16009         COMMON /CC/ E(MAXSTR)
16010 cc      SAVE /CC/
16011         COMMON /EE/ ID(MAXSTR),LB(MAXSTR)
16012 cc      SAVE /EE/
16013         common/input1/ MASSPR,MASSTA,ISEED,IAVOID,DT
16014 cc      SAVE /input1/
16015       COMMON/RNDF77/NSEED
16016 cc      SAVE /RNDF77/
16017       SAVE
16018
16019         lb1 = lb(i1)
16020         lb2 = lb(i2)
16021         icase = 0
16022
16023 c        if(srt .lt. aphi+ap1)return
16024 cc        if(srt .lt. aphi+ap1) then
16025         if(srt .lt. (aphi+ap1)) then
16026            sig1 = 0.
16027            sig2 = 0.
16028            sig3 = 0.
16029         else
16030 c
16031          if((lb1.eq.23.and.lb2.eq.21).or.(lb2.eq.23.and.lb1.eq.21))then
16032             dnr =  4.
16033             ikk = 2
16034           elseif((lb1.eq.21.and.lb2.eq.30).or.(lb2.eq.21.and.lb1.eq.30)
16035      & .or.(lb1.eq.23.and.lb2.eq.-30).or.(lb2.eq.23.and.lb1.eq.-30))then
16036              dnr = 12.
16037              ikk = 1
16038           else
16039              dnr = 36.
16040              ikk = 0
16041           endif
16042
16043           sig1 = 0.
16044           sig2 = 0.
16045           sig3 = 0.
16046           srri = E(i1)+E(i2)
16047           srr1 = aphi+ap1
16048           srr2 = aphi+aomega
16049           srr3 = aphi+arho
16050 c
16051           pii = (srt**2-(e(i1)+e(i2))**2)*(srt**2-(e(i1)-e(i2))**2)
16052           srrt = srt - amax1(srri,srr1)
16053 cc   to avoid divergent/negative values at small srrt:
16054 c          if(srrt .lt. 0.3)then
16055           if(srrt .lt. 0.3 .and. srrt .gt. 0.01)then
16056           sig = 1.69/(srrt**0.141 - 0.407)
16057          else
16058           sig = 3.74 + 0.008*srrt**1.9
16059          endif
16060           sig1=sig*(9./dnr)*(srt**2-(aphi+ap1)**2)*
16061      &           (srt**2-(aphi-ap1)**2)/pii
16062           if(srt .gt. aphi+aomega)then
16063           srrt = srt - amax1(srri,srr2)
16064 cc         if(srrt .lt. 0.3)then
16065           if(srrt .lt. 0.3 .and. srrt .gt. 0.01)then
16066           sig = 1.69/(srrt**0.141 - 0.407)
16067          else
16068           sig = 3.74 + 0.008*srrt**1.9
16069          endif
16070           sig2=sig*(9./dnr)*(srt**2-(aphi+aomega)**2)*
16071      &           (srt**2-(aphi-aomega)**2)/pii
16072            endif
16073          if(srt .gt. aphi+arho)then
16074           srrt = srt - amax1(srri,srr3)
16075 cc         if(srrt .lt. 0.3)then
16076           if(srrt .lt. 0.3 .and. srrt .gt. 0.01)then
16077           sig = 1.69/(srrt**0.141 - 0.407)
16078          else
16079           sig = 3.74 + 0.008*srrt**1.9
16080          endif
16081           sig3=sig*(27./dnr)*(srt**2-(aphi+arho)**2)*
16082      &           (srt**2-(aphi-arho)**2)/pii
16083          endif
16084 c         sig1 = amin1(20.,sig1)
16085 c         sig2 = amin1(20.,sig2)
16086 c         sig3 = amin1(20.,sig3)
16087         endif
16088
16089         rrkk0=rrkk
16090         prkk0=prkk
16091         SIGM=0.
16092         if((lb1.eq.23.and.lb2.eq.21).or.(lb2.eq.23.and.lb1.eq.21))then
16093            CALL XKKANN(SRT, XSK1, XSK2, XSK3, XSK4, XSK5,
16094      &          XSK6, XSK7, XSK8, XSK9, XSK10, XSK11, SIGM, rrkk0)
16095         elseif((lb1.eq.21.and.lb2.eq.30).or.(lb2.eq.21.and.lb1.eq.30)
16096      & .or.(lb1.eq.23.and.lb2.eq.-30).or.(lb2.eq.23.and.lb1.eq.-30))then
16097            CALL XKKSAN(i1,i2,SRT,SIGKS1,SIGKS2,SIGKS3,SIGKS4,SIGM,prkk0)
16098         else
16099         endif
16100 c
16101 c         sigks = sig1 + sig2 + sig3
16102         sigm0=sigm
16103         sigks = sig1 + sig2 + sig3 + SIGM
16104         DSkn=SQRT(sigks/PI/10.)
16105         dsknr=dskn+0.1
16106         CALL DISTCE(I1,I2,dsknr,DSkn,DT,EC,SRT,IC,
16107      1  PX,PY,PZ)
16108         IF(IC.EQ.-1)return
16109         icase = 1
16110         ranx = RANART(NSEED)
16111
16112         lbp1 = 29
16113         emm1 = aphi
16114         if(ranx .le. sig1/sigks)then
16115            lbp2 = 3 + int(3*RANART(NSEED))
16116            emm2 = ap1
16117         elseif(ranx .le. (sig1+sig2)/sigks)then
16118            lbp2 = 28
16119            emm2 = aomega
16120         elseif(ranx .le. (sig1+sig2+sig3)/sigks)then
16121            lbp2 = 25 + int(3*RANART(NSEED))
16122            emm2 = arho
16123         else
16124            if((lb1.eq.23.and.lb2.eq.21)
16125      &          .or.(lb2.eq.23.and.lb1.eq.21))then
16126               CALL crkkpi(I1,I2,XSK1, XSK2, XSK3, XSK4,
16127      &             XSK5, XSK6, XSK7, XSK8, XSK9, XSK10, XSK11, SIGM0,
16128      &             IBLOCK,lbp1,lbp2,emm1,emm2)
16129            elseif((lb1.eq.21.and.lb2.eq.30)
16130      &             .or.(lb2.eq.21.and.lb1.eq.30)
16131      &             .or.(lb1.eq.23.and.lb2.eq.-30)
16132      &             .or.(lb2.eq.23.and.lb1.eq.-30))then
16133               CALL crkspi(I1,I2,SIGKS1, SIGKS2, SIGKS3, SIGKS4,
16134      &             SIGM0,IBLOCK,lbp1,lbp2,emm1,emm2)
16135            else
16136            endif
16137         endif
16138 *
16139         PX0=PX
16140         PY0=PY
16141         PZ0=PZ
16142 *-----------------------------------------------------------------------
16143 * CALCULATE THE MAGNITUDE OF THE FINAL MOMENTUM THROUGH
16144 * ENERGY CONSERVATION
16145            PR2   = (SRT**2 - EMM1**2 - EMM2**2)**2
16146      1                - 4.0 * (EMM1*EMM2)**2
16147           IF(PR2.LE.0.)PR2=1.e-09
16148           PR=SQRT(PR2)/(2.*SRT)
16149           C1   = 1.0 - 2.0 * RANART(NSEED)
16150           T1   = 2.0 * PI * RANART(NSEED)
16151       S1   = SQRT( 1.0 - C1**2 )
16152       CT1  = COS(T1)
16153       ST1  = SIN(T1)
16154 * THE MOMENTUM IN THE CMS IN THE FINAL STATE
16155       PZ   = PR * C1
16156       PX   = PR * S1*CT1
16157       PY   = PR * S1*ST1
16158 * FOR THE ISOTROPIC DISTRIBUTION THERE IS NO NEED TO ROTATE
16159       RETURN
16160       END
16161 csp11/21/01 end
16162 **********************************
16163 *                                                                      *
16164 *                                                                      *
16165         SUBROUTINE Crksph(PX,PY,PZ,EC,SRT,
16166      &     emm1,emm2,lbp1,lbp2,I1,I2,ikkg,ikkl,iblock,
16167      &     icase,srhoks)
16168
16169 *     PURPOSE:                                                         *
16170 *     DEALING WITH   K + rho(omega) or K* + pi(rho,omega)
16171 *                    --> Phi + K(K*), pi + K* or pi + K, and elastic
16172 *     NOTE   :                                                         *
16173 *
16174 *     QUANTITIES:                                                      *
16175 *           PX,PY,PZ - MOMENTUM COORDINATES OF ONE PARTICLE IN CM FRAME*
16176 *           SRT      - SQRT OF S                                       *
16177 *           IBLOCK   - THE INFORMATION BACK                            *
16178 *                      222
16179 *                      223 --> phi + pi(rho,omega)
16180 *                      224 --> phi + K <-> K + pi(rho,omega)
16181 *                      225 --> phi + K <-> K* + pi(rho,omega)
16182 *                      226 --> phi + K* <-> K + pi(rho,omega)
16183 *                      227 --> phi + K* <-> K* + pi(rho,omega)
16184 **********************************
16185         PARAMETER (MAXSTR=150001,MAXR=1,AMN=0.939457,
16186      1  AMP=0.93828,AP1=0.13496,AP2=0.13957,APHI=1.02,
16187      2  AM0=1.232,AMNS=1.52,PI=3.1415926,CUTOFF=1.8966,AVMASS=0.9383)
16188         PARAMETER      (AKA=0.498,ALA=1.1157,ASA=1.1974,ACAS=1.3213)
16189         PARAMETER      (AKS=0.895,AOMEGA=0.7819, ARHO=0.77)
16190         parameter     (MX=4,MY=4,MZ=8,MPX=4,MPY=4,mpz=10,mpzp=10)
16191         COMMON /AA/ R(3,MAXSTR)
16192 cc      SAVE /AA/
16193         COMMON /BB/ P(3,MAXSTR)
16194 cc      SAVE /BB/
16195         COMMON /CC/ E(MAXSTR)
16196 cc      SAVE /CC/
16197         COMMON /EE/ ID(MAXSTR),LB(MAXSTR)
16198 cc      SAVE /EE/
16199         common/input1/ MASSPR,MASSTA,ISEED,IAVOID,DT
16200 cc      SAVE /input1/
16201       COMMON/RNDF77/NSEED
16202 cc      SAVE /RNDF77/
16203       SAVE
16204
16205         lb1 = lb(i1)
16206         lb2 = lb(i2)
16207         icase = 0
16208         sigela=10.
16209         sigkm=0.
16210 c     K(K*) + rho(omega) -> pi K*(K)
16211         if((lb1.ge.25.and.lb1.le.28).or.(lb2.ge.25.and.lb2.le.28)) then
16212            if(iabs(lb1).eq.30.or.iabs(lb2).eq.30) then
16213               sigkm=srhoks
16214 clin-2/26/03 check whether (rho K) is above the (pi K*) thresh:
16215            elseif((lb1.eq.23.or.lb1.eq.21.or.lb2.eq.23.or.lb2.eq.21)
16216      1             .and.srt.gt.(ap2+aks)) then
16217               sigkm=srhoks
16218            endif
16219         endif
16220
16221 c        if(srt .lt. aphi+aka)return
16222         if(srt .lt. (aphi+aka)) then
16223            sig11=0.
16224            sig22=0.
16225         else
16226
16227 c K*-bar +pi --> phi + (K,K*)-bar
16228          if( (iabs(lb1).eq.30.and.(lb2.ge.3.and.lb2.le.5)) .or.
16229      &       (iabs(lb2).eq.30.and.(lb1.ge.3.and.lb1.le.5)) )then
16230               dnr =  18.
16231               ikkl = 0
16232               IBLOCK = 225
16233 c               sig1 = 15.0
16234 c               sig2 = 30.0
16235 clin-2/06/03 these large values reduces to ~10 mb for sig11 or sig22
16236 c     due to the factors of ~1/(32*pi*s)~1/200:
16237                sig1 = 2047.042
16238                sig2 = 1496.692
16239 c K(-bar)+rho --> phi + (K,K*)-bar
16240        elseif((lb1.eq.23.or.lb1.eq.21.and.(lb2.ge.25.and.lb2.le.27)).or.
16241      &      (lb2.eq.23.or.lb2.eq.21.and.(lb1.ge.25.and.lb1.le.27)) )then
16242               dnr =  18.
16243               ikkl = 1
16244               IBLOCK = 224
16245 c               sig1 = 3.5
16246 c               sig2 = 9.0
16247                sig1 = 526.702
16248                sig2 = 1313.960
16249 c K*(-bar) +rho
16250          elseif( (iabs(lb1).eq.30.and.(lb2.ge.25.and.lb2.le.27)) .or.
16251      &           (iabs(lb2).eq.30.and.(lb1.ge.25.and.lb1.le.27)) )then
16252               dnr =  54.
16253               ikkl = 0
16254               IBLOCK = 225
16255 c               sig1 = 3.5
16256 c               sig2 = 9.0
16257                sig1 = 1371.257
16258                sig2 = 6999.840
16259 c K(-bar) + omega
16260          elseif( ((lb1.eq.23.or.lb1.eq.21) .and. lb2.eq.28).or.
16261      &           ((lb2.eq.23.or.lb2.eq.21) .and. lb1.eq.28) )then
16262               dnr = 6.
16263               ikkl = 1
16264               IBLOCK = 224
16265 c               sig1 = 3.5
16266 c               sig2 = 6.5
16267                sig1 = 355.429
16268                sig2 = 440.558
16269 c K*(-bar) +omega
16270           else
16271               dnr = 18.
16272               ikkl = 0
16273               IBLOCK = 225
16274 c               sig1 = 3.5
16275 c               sig2 = 15.0
16276                sig1 = 482.292
16277                sig2 = 1698.903
16278           endif
16279
16280             sig11 = 0.
16281             sig22 = 0.
16282 c         sig11=sig1*(6./dnr)*(srt**2-(aphi+aka)**2)*
16283 c    &           (srt**2-(aphi-aka)**2)/(srt**2-(e(i1)+e(i2))**2)/
16284 c    &           (srt**2-(e(i1)-e(i2))**2)
16285         pii = sqrt((srt**2-(e(i1)+e(i2))**2)*(srt**2-(e(i1)-e(i2))**2))
16286         pff = sqrt((srt**2-(aphi+aka)**2)*(srt**2-(aphi-aka)**2))
16287           sig11 = sig1*pff/pii*6./dnr/32./pi/srt**2
16288 c
16289           if(srt .gt. aphi+aks)then
16290 c         sig22=sig2*(18./dnr)*(srt**2-(aphi+aks)**2)*
16291 c    &           (srt**2-(aphi-aks)**2)/(srt**2-(e(i1)+e(i2))**2)/
16292 c    &           (srt**2-(e(i1)-e(i2))**2)
16293         pff = sqrt((srt**2-(aphi+aks)**2)*(srt**2-(aphi-aks)**2))
16294           sig22 = sig2*pff/pii*18./dnr/32./pi/srt**2
16295            endif
16296 c         sig11 = amin1(20.,sig11)
16297 c         sig22 = amin1(20.,sig22)
16298 c
16299         endif
16300
16301 c         sigks = sig11 + sig22
16302          sigks=sig11+sig22+sigela+sigkm
16303 c
16304         DSkn=SQRT(sigks/PI/10.)
16305         dsknr=dskn+0.1
16306         CALL DISTCE(I1,I2,dsknr,DSkn,DT,EC,SRT,IC,
16307      1  PX,PY,PZ)
16308         IF(IC.EQ.-1)return
16309         icase = 1
16310         ranx = RANART(NSEED)
16311
16312          if(ranx .le. (sigela/sigks))then
16313             lbp1=lb1
16314             emm1=e(i1)
16315             lbp2=lb2
16316             emm2=e(i2)
16317             iblock=111
16318          elseif(ranx .le. ((sigela+sigkm)/sigks))then
16319             lbp1=3+int(3*RANART(NSEED))
16320             emm1=0.14
16321             if(lb1.eq.23.or.lb2.eq.23) then
16322                lbp2=30
16323                emm2=aks
16324             elseif(lb1.eq.21.or.lb2.eq.21) then
16325                lbp2=-30
16326                emm2=aks
16327             elseif(lb1.eq.30.or.lb2.eq.30) then
16328                lbp2=23
16329                emm2=aka
16330             else
16331                lbp2=21
16332                emm2=aka
16333             endif
16334             iblock=112
16335          elseif(ranx .le. ((sigela+sigkm+sig11)/sigks))then
16336             lbp2 = 23
16337             emm2 = aka
16338             ikkg = 1
16339             if(lb1.eq.21.or.lb2.eq.21.or.lb1.eq.-30.or.lb2.eq.-30)then
16340                lbp2=21
16341                iblock=iblock-100
16342             endif
16343             lbp1 = 29
16344             emm1 = aphi
16345          else
16346             lbp2 = 30
16347             emm2 = aks
16348             ikkg = 0
16349             IBLOCK=IBLOCK+2
16350             if(lb1.eq.21.or.lb2.eq.21.or.lb1.eq.-30.or.lb2.eq.-30)then
16351                lbp2=-30
16352                iblock=iblock-100
16353             endif
16354             lbp1 = 29
16355             emm1 = aphi
16356          endif
16357 *
16358         PX0=PX
16359         PY0=PY
16360         PZ0=PZ
16361 *-----------------------------------------------------------------------
16362 * CALCULATE THE MAGNITUDE OF THE FINAL MOMENTUM THROUGH
16363 * ENERGY CONSERVATION
16364            PR2   = (SRT**2 - EMM1**2 - EMM2**2)**2
16365      1                - 4.0 * (EMM1*EMM2)**2
16366           IF(PR2.LE.0.)PR2=1.e-09
16367           PR=SQRT(PR2)/(2.*SRT)
16368           C1   = 1.0 - 2.0 * RANART(NSEED)
16369           T1   = 2.0 * PI * RANART(NSEED)
16370       S1   = SQRT( 1.0 - C1**2 )
16371       CT1  = COS(T1)
16372       ST1  = SIN(T1)
16373 * THE MOMENTUM IN THE CMS IN THE FINAL STATE
16374       PZ   = PR * C1
16375       PX   = PR * S1*CT1
16376       PY   = PR * S1*ST1
16377 * FOR THE ISOTROPIC DISTRIBUTION THERE IS NO NEED TO ROTATE
16378       RETURN
16379       END
16380 csp11/21/01 end
16381 **********************************
16382 **********************************
16383         SUBROUTINE bbkaon(ic,SRT,PX,PY,PZ,ana,PlX,
16384      &  PlY,PlZ,ala,pkX,PkY,PkZ,icou1)
16385 * purpose: generate the momenta for kaon,lambda/sigma and nucleon/delta
16386 *          in the BB-->nlk process
16387 * date: Sept. 9, 1994
16388 c
16389         common/input1/ MASSPR,MASSTA,ISEED,IAVOID,DT
16390 cc      SAVE /input1/
16391       COMMON/RNDF77/NSEED
16392 cc      SAVE /RNDF77/
16393       SAVE
16394
16395        PI=3.1415962
16396        icou1=0
16397        aka=0.498
16398         ala=1.116
16399        if(ic.eq.2.or.ic.eq.4)ala=1.197
16400        ana=0.939
16401 * generate the mass of the delta
16402        if(ic.gt.2)then
16403        dmax=srt-aka-ala-0.02
16404         DM1=RMASS(DMAX,ISEED)
16405        ana=dm1
16406        endif
16407        t1=aka+ana+ala
16408        t2=ana+ala-aka
16409        if(srt.le.t1)then
16410        icou1=-1
16411        return
16412        endif
16413        pmax=sqrt((srt**2-t1**2)*(srt**2-t2**2))/(2.*srt)
16414        if(pmax.eq.0.)pmax=1.e-09
16415 * (1) Generate the momentum of the kaon according to the distribution Fkaon
16416 *     and assume that the angular distribution is isotropic
16417 *     in the cms of the colliding pair
16418        ntry=0
16419 1       pk=pmax*RANART(NSEED)
16420        ntry=ntry+1
16421        prob=fkaon(pk,pmax)
16422        if((prob.lt.RANART(NSEED)).and.(ntry.le.40))go to 1
16423        cs=1.-2.*RANART(NSEED)
16424        ss=sqrt(1.-cs**2)
16425        fai=2.*3.14*RANART(NSEED)
16426        pkx=pk*ss*cos(fai)
16427        pky=pk*ss*sin(fai)
16428        pkz=pk*cs
16429 * the energy of the kaon
16430        ek=sqrt(aka**2+pk**2)
16431 * (2) Generate the momentum of the nucleon/delta in the cms of N/delta
16432 *     and lamda/sigma
16433 *  the energy of the cms of NL
16434         eln=srt-ek
16435        if(eln.le.0)then
16436        icou1=-1
16437        return
16438        endif
16439 * beta and gamma of the cms of L/S+N
16440        bx=-pkx/eln
16441        by=-pky/eln
16442        bz=-pkz/eln
16443        ga=1./sqrt(1.-bx**2-by**2-bz**2)
16444         elnc=eln/ga
16445        pn2=((elnc**2+ana**2-ala**2)/(2.*elnc))**2-ana**2
16446        if(pn2.le.0.)pn2=1.e-09
16447        pn=sqrt(pn2)
16448        csn=1.-2.*RANART(NSEED)
16449        ssn=sqrt(1.-csn**2)
16450        fain=2.*3.14*RANART(NSEED)
16451        px=pn*ssn*cos(fain)
16452        py=pn*ssn*sin(fain)
16453        pz=pn*csn
16454        en=sqrt(ana**2+pn2)
16455 * the momentum of the lambda/sigma in the n-l cms frame is
16456        plx=-px
16457        ply=-py
16458        plz=-pz
16459 * (3) LORENTZ-TRANSFORMATION INTO nn cms FRAME for the neutron/delta
16460         PBETA  = PX*BX + PY*By+ PZ*Bz
16461               TRANS0  = GA * ( GA * PBETA / (GA + 1.) + En )
16462               Px = BX * TRANS0 + PX
16463               Py = BY * TRANS0 + PY
16464               Pz = BZ * TRANS0 + PZ
16465 * (4) Lorentz-transformation for the lambda/sigma
16466        el=sqrt(ala**2+plx**2+ply**2+plz**2)
16467         PBETA  = PlX*BX + PlY*By+ PlZ*Bz
16468               TRANS0  = GA * ( GA * PBETA / (GA + 1.) + El )
16469               Plx = BX * TRANS0 + PlX
16470               Ply = BY * TRANS0 + PlY
16471               Plz = BZ * TRANS0 + PlZ
16472              return
16473              end
16474 ******************************************
16475 * for pion+pion-->K+K-
16476 c      real*4 function pipik(srt)
16477       real function pipik(srt)
16478 *  srt    = DSQRT(s) in GeV                                                   *
16479 *  xsec   = production cross section in mb                                    *
16480 *  NOTE: DEVIDE THE CROSS SECTION TO OBTAIN K+ PRODUCTION                     *
16481 ******************************************
16482 c      real*4   xarray(5), earray(5)
16483       real   xarray(5), earray(5)
16484       SAVE
16485       data xarray /0.001, 0.7,1.5,1.7,2.0/
16486       data earray /1.,1.2,1.6,2.0,2.4/
16487
16488            pmass=0.9383
16489 * 1.Calculate p(lab)  from srt [GeV]
16490 *   Formula used:   DSQRT(s) = 2 m DSQRT(E_kin/(2m) + 1)
16491 c      ekin = 2.*pmass*((srt/(2.*pmass))**2 - 1.)
16492        pipik=0.
16493        if(srt.le.1.)return
16494        if(srt.gt.2.4)then
16495            pipik=2.0/2.
16496            return
16497        endif
16498         if (srt .lt. earray(1)) then
16499            pipik =xarray(1)/2.
16500            return
16501         end if
16502 *
16503 * 2.Interpolate double logarithmically to find sigma(srt)
16504 *
16505       do 1001 ie = 1,5
16506         if (earray(ie) .eq. srt) then
16507           pipik = xarray(ie)
16508           go to 10
16509         else if (earray(ie) .gt. srt) then
16510           ymin = alog(xarray(ie-1))
16511           ymax = alog(xarray(ie))
16512           xmin = alog(earray(ie-1))
16513           xmax = alog(earray(ie))
16514           pipik = exp(ymin + (alog(srt)-xmin)*(ymax-ymin)
16515      &/(xmax-xmin) )
16516           go to 10
16517         end if
16518  1001 continue
16519 10       PIPIK=PIPIK/2.
16520        continue
16521       return
16522         END
16523 **********************************
16524 * TOTAL PION-P INELASTIC CROSS SECTION
16525 *  from the CERN data book
16526 *  date: Sept.2, 1994
16527 *  for pion++p-->Delta+pion
16528 c      real*4 function pionpp(srt)
16529       real function pionpp(srt)
16530       SAVE
16531 *  srt    = DSQRT(s) in GeV                                                   *
16532 *  xsec   = production cross section in fm**2                                 *
16533 *  earray = EXPerimental table with proton energies in MeV                    *
16534 *  xarray = EXPerimental table with cross sections in mb (curve to guide eye) *
16535 *                                                                             *
16536 ******************************************
16537            pmass=0.14
16538        pmass1=0.938
16539        PIONPP=0.00001
16540        IF(SRT.LE.1.22)RETURN
16541 * 1.Calculate p(lab)  from srt [GeV]
16542 *   Formula used:   DSQRT(s) = 2 m DSQRT(E_kin/(2m) + 1)
16543 c      ekin = 2.*pmass*((srt/(2.*pmass))**2 - 1.)
16544         plab=sqrt(((srt**2-pmass**2-pmass1**2)/(2.*pmass1))**2-pmass**2)
16545        pmin=0.3
16546        pmax=25.0
16547        if(plab.gt.pmax)then
16548        pionpp=20./10.
16549        return
16550        endif
16551         if(plab .lt. pmin)then
16552         pionpp = 0.
16553         return
16554         end if
16555 c* fit parameters
16556        a=24.3
16557        b=-12.3
16558        c=0.324
16559        an=-1.91
16560        d=-2.44
16561         pionpp = a+b*(plab**an)+c*(alog(plab))**2+d*alog(plab)
16562        if(pionpp.le.0)pionpp=0
16563        pionpp=pionpp/10.
16564         return
16565         END
16566 **********************************
16567 * elementary cross sections
16568 *  from the CERN data book
16569 *  date: Sept.2, 1994
16570 *  for pion-+p-->INELASTIC
16571 c      real*4 function pipp1(srt)
16572       real function pipp1(srt)
16573       SAVE
16574 *  srt    = DSQRT(s) in GeV                                                   *
16575 *  xsec   = production cross section in fm**2                                 *
16576 *  earray = EXPerimental table with proton energies in MeV                    *
16577 *  xarray = EXPerimental table with cross sections in mb (curve to guide eye) *
16578 *  UNITS: FM**2
16579 ******************************************
16580            pmass=0.14
16581        pmass1=0.938
16582        PIPP1=0.0001
16583        IF(SRT.LE.1.22)RETURN
16584 * 1.Calculate p(lab)  from srt [GeV]
16585 *   Formula used:   DSQRT(s) = 2 m DSQRT(E_kin/(2m) + 1)
16586 c      ekin = 2.*pmass*((srt/(2.*pmass))**2 - 1.)
16587         plab=sqrt(((srt**2-pmass**2-pmass1**2)/(2.*pmass1))**2-pmass**2)
16588        pmin=0.3
16589        pmax=25.0
16590        if(plab.gt.pmax)then
16591        pipp1=20./10.
16592        return
16593        endif
16594         if(plab .lt. pmin)then
16595         pipp1 = 0.
16596         return
16597         end if
16598 c* fit parameters
16599        a=26.6
16600        b=-7.18
16601        c=0.327
16602        an=-1.86
16603        d=-2.81
16604         pipp1 = a+b*(plab**an)+c*(alog(plab))**2+d*alog(plab)
16605        if(pipp1.le.0)pipp1=0
16606        PIPP1=PIPP1/10.
16607         return
16608         END
16609 * *****************************
16610 c       real*4 function xrho(srt)
16611       real function xrho(srt)
16612       SAVE
16613 *       xsection for pp-->pp+rho
16614 * *****************************
16615        pmass=0.9383
16616        rmass=0.77
16617        trho=0.151
16618        xrho=0.000000001
16619        if(srt.le.2.67)return
16620        ESMIN=2.*0.9383+rmass-trho/2.
16621        ES=srt
16622 * the cross section for tho0 production is
16623        xrho0=0.24*(es-esmin)/(1.4+(es-esmin)**2)
16624        xrho=3.*Xrho0
16625        return
16626        end
16627 * *****************************
16628 c       real*4 function omega(srt)
16629       real function omega(srt)
16630       SAVE
16631 *       xsection for pp-->pp+omega
16632 * *****************************
16633        pmass=0.9383
16634        omass=0.782
16635        tomega=0.0084
16636        omega=0.00000001
16637        if(srt.le.2.68)return
16638        ESMIN=2.*0.9383+omass-tomega/2.
16639        es=srt
16640        omega=0.36*(es-esmin)/(1.25+(es-esmin)**2)
16641        return
16642        end
16643 ******************************************
16644 * for ppi(+)-->DELTA+pi
16645 c      real*4 function TWOPI(srt)
16646       real function TWOPI(srt)
16647 *  This function contains the experimental pi+p-->DELTA+PION cross sections   *
16648 *  srt    = DSQRT(s) in GeV                                                   *
16649 *  xsec   = production cross section in mb                                    *
16650 *  earray = EXPerimental table with proton energies in MeV                    *
16651 *  xarray = EXPerimental table with cross sections in mb (curve to guide eye) *
16652 *                                                                             *
16653 ******************************************
16654 c      real*4   xarray(19), earray(19)
16655       real   xarray(19), earray(19)
16656       SAVE
16657       data xarray /0.300E-05,0.187E+01,0.110E+02,0.149E+02,0.935E+01,
16658      &0.765E+01,0.462E+01,0.345E+01,0.241E+01,0.185E+01,0.165E+01,
16659      &0.150E+01,0.132E+01,0.117E+01,0.116E+01,0.100E+01,0.856E+00,
16660      &0.745E+00,0.300E-05/
16661       data earray /0.122E+01, 0.147E+01, 0.172E+01, 0.197E+01,
16662      &0.222E+01, 0.247E+01, 0.272E+01, 0.297E+01, 0.322E+01,
16663      &0.347E+01, 0.372E+01, 0.397E+01, 0.422E+01, 0.447E+01,
16664      &0.472E+01, 0.497E+01, 0.522E+01, 0.547E+01, 0.572E+01/
16665
16666            pmass=0.14
16667        pmass1=0.938
16668        TWOPI=0.000001
16669        if(srt.le.1.22)return
16670 * 1.Calculate p(lab)  from srt [GeV]
16671 *   Formula used:   DSQRT(s) = 2 m DSQRT(E_kin/(2m) + 1)
16672         plab=SRT
16673       if (plab .lt. earray(1)) then
16674         TWOPI= 0.00001
16675         return
16676       end if
16677 *
16678 * 2.Interpolate double logarithmically to find sigma(srt)
16679 *
16680       do 1001 ie = 1,19
16681         if (earray(ie) .eq. plab) then
16682           TWOPI= xarray(ie)
16683           return
16684         else if (earray(ie) .gt. plab) then
16685           ymin = alog(xarray(ie-1))
16686           ymax = alog(xarray(ie))
16687           xmin = alog(earray(ie-1))
16688           xmax = alog(earray(ie))
16689           TWOPI= exp(ymin + (alog(plab)-xmin)*(ymax-ymin)
16690      &    /(xmax-xmin) )
16691           return
16692         end if
16693  1001   continue
16694       return
16695         END
16696 ******************************************
16697 ******************************************
16698 * for ppi(+)-->DELTA+RHO
16699 c      real*4 function THREPI(srt)
16700       real function THREPI(srt)
16701 *  This function contains the experimental pi+p-->DELTA + rho cross sections  *
16702 *  srt    = DSQRT(s) in GeV                                                   *
16703 *  xsec   = production cross section in mb                                    *
16704 *  earray = EXPerimental table with proton energies in MeV                    *
16705 *  xarray = EXPerimental table with cross sections in mb (curve to guide eye) *
16706 *                                                                             *
16707 ******************************************
16708 c      real*4   xarray(15), earray(15)
16709       real   xarray(15), earray(15)
16710       SAVE
16711       data xarray /8.0000000E-06,6.1999999E-05,1.881940,5.025690,
16712      &11.80154,13.92114,15.07308,11.79571,11.53772,10.01197,9.792673,
16713      &9.465264,8.970490,7.944254,6.886320/
16714       data earray /0.122E+01, 0.147E+01, 0.172E+01, 0.197E+01,
16715      &0.222E+01, 0.247E+01, 0.272E+01, 0.297E+01, 0.322E+01,
16716      &0.347E+01, 0.372E+01, 0.397E+01, 0.422E+01, 0.447E+01,
16717      &0.472E+01/
16718
16719            pmass=0.14
16720        pmass1=0.938
16721        THREPI=0.000001
16722        if(srt.le.1.36)return
16723 * 1.Calculate p(lab)  from srt [GeV]
16724 *   Formula used:   DSQRT(s) = 2 m DSQRT(E_kin/(2m) + 1)
16725         plab=SRT
16726       if (plab .lt. earray(1)) then
16727         THREPI = 0.00001
16728         return
16729       end if
16730 *
16731 * 2.Interpolate double logarithmically to find sigma(srt)
16732 *
16733       do 1001 ie = 1,15
16734         if (earray(ie) .eq. plab) then
16735           THREPI= xarray(ie)
16736           return
16737         else if (earray(ie) .gt. plab) then
16738           ymin = alog(xarray(ie-1))
16739           ymax = alog(xarray(ie))
16740           xmin = alog(earray(ie-1))
16741           xmax = alog(earray(ie))
16742           THREPI = exp(ymin + (alog(plab)-xmin)*(ymax-ymin)
16743      &    /(xmax-xmin) )
16744           return
16745         end if
16746  1001   continue
16747       return
16748         END
16749 ******************************************
16750 ******************************************
16751 * for ppi(+)-->DELTA+omega
16752 c      real*4 function FOURPI(srt)
16753       real function FOURPI(srt)
16754 *  This function contains the experimental pi+p-->DELTA+PION cross sections   *
16755 *  srt    = DSQRT(s) in GeV                                                   *
16756 *  xsec   = production cross section in mb                                    *
16757 *  earray = EXPerimental table with proton energies in MeV                    *
16758 *  xarray = EXPerimental table with cross sections in mb (curve to guide eye) *
16759 *                                                                             *
16760 ******************************************
16761 c      real*4   xarray(10), earray(10)
16762       real   xarray(10), earray(10)
16763       SAVE
16764       data xarray /0.0001,1.986597,6.411932,7.636956,
16765      &9.598362,9.889740,10.24317,10.80138,11.86988,12.83925/
16766       data earray /2.468,2.718,2.968,0.322E+01,
16767      &0.347E+01, 0.372E+01, 0.397E+01, 0.422E+01, 0.447E+01,
16768      &0.472E+01/
16769
16770            pmass=0.14
16771        pmass1=0.938
16772        FOURPI=0.000001
16773        if(srt.le.1.52)return
16774 * 1.Calculate p(lab)  from srt [GeV]
16775 *   Formula used:   DSQRT(s) = 2 m DSQRT(E_kin/(2m) + 1)
16776         plab=SRT
16777       if (plab .lt. earray(1)) then
16778         FOURPI= 0.00001
16779         return
16780       end if
16781 *
16782 * 2.Interpolate double logarithmically to find sigma(srt)
16783 *
16784       do 1001 ie = 1,10
16785         if (earray(ie) .eq. plab) then
16786           FOURPI= xarray(ie)
16787           return
16788         else if (earray(ie) .gt. plab) then
16789           ymin = alog(xarray(ie-1))
16790           ymax = alog(xarray(ie))
16791           xmin = alog(earray(ie-1))
16792           xmax = alog(earray(ie))
16793           FOURPI= exp(ymin + (alog(plab)-xmin)*(ymax-ymin)
16794      &    /(xmax-xmin) )
16795           return
16796         end if
16797  1001   continue
16798       return
16799         END
16800 ******************************************
16801 ******************************************
16802 * for pion (rho or omega)+baryon resonance collisions
16803 c      real*4 function reab(i1,i2,srt,ictrl)
16804       real function reab(i1,i2,srt,ictrl)
16805 *  This function calculates the cross section for
16806 *  pi+Delta(N*)-->N+PION process                                              *
16807 *  srt    = DSQRT(s) in GeV                                                   *
16808 *  reab   = cross section in fm**2                                            *
16809 *  ictrl=1,2,3 for pion, rho and omega+D(N*)
16810 ****************************************
16811       PARAMETER (MAXSTR=150001,MAXR=1,PI=3.1415926)
16812       parameter      (MX=4,MY=4,MZ=8,MPX=4,MPY=4,mpz=10,mpzp=10)
16813       PARAMETER      (AKA=0.498,ALA=1.1157,ASA=1.1974)
16814       parameter      (amn=0.938,ap1=0.14,arho=0.77,aomega=0.782)
16815        parameter       (maxx=20,maxz=24)
16816       COMMON   /AA/  R(3,MAXSTR)
16817 cc      SAVE /AA/
16818       COMMON   /BB/  P(3,MAXSTR)
16819 cc      SAVE /BB/
16820       COMMON   /CC/  E(MAXSTR)
16821 cc      SAVE /CC/
16822       COMMON  /DD/      RHO(-MAXX:MAXX,-MAXX:MAXX,-MAXZ:MAXZ),
16823      &                     RHOP(-MAXX:MAXX,-MAXX:MAXX,-MAXZ:MAXZ),
16824      &                     RHON(-MAXX:MAXX,-MAXX:MAXX,-MAXZ:MAXZ)
16825 cc      SAVE /DD/
16826       COMMON  /EE/      ID(MAXSTR),LB(MAXSTR)
16827 cc      SAVE /EE/
16828       SAVE
16829        LB1=LB(I1)
16830        LB2=LB(I2)
16831        reab=0
16832        if(ictrl.eq.1.and.srt.le.(amn+2.*ap1+0.02))return
16833        if(ictrl.eq.3.and.srt.le.(amn+ap1+aomega+0.02))return
16834        pin2=((srt**2+ap1**2-amn**2)/(2.*srt))**2-ap1**2
16835        if(pin2.le.0)return
16836 * for pion+D(N*)-->pion+N
16837        if(ictrl.eq.1)then
16838        if(e(i1).gt.1)then
16839        ed=e(i1)
16840        else
16841        ed=e(i2)
16842        endif
16843        pout2=((srt**2+ap1**2-ed**2)/(2.*srt))**2-ap1**2
16844        if(pout2.le.0)return
16845        xpro=twopi(srt)/10.
16846        factor=1/3.
16847        if( ((lb1.eq.8.and.lb2.eq.5).or.
16848      &    (lb1.eq.5.and.lb2.eq.8))
16849      &        .OR.((lb1.eq.-8.and.lb2.eq.3).or.
16850      &    (lb1.eq.3.and.lb2.eq.-8)) )factor=1/4.
16851        if((iabs(lb1).ge.10.and.iabs(lb1).le.13).
16852      &  or.(iabs(lb2).ge.10.and.iabs(lb2).le.13))factor=1.
16853        reab=factor*pin2/pout2*xpro
16854        return
16855        endif
16856 * for rho reabsorption
16857        if(ictrl.eq.2)then
16858        if(lb(i2).ge.25)then
16859        ed=e(i1)
16860        arho1=e(i2)
16861        else
16862        ed=e(i2)
16863        arho1=e(i1)
16864        endif
16865        if(srt.le.(amn+ap1+arho1+0.02))return
16866        pout2=((srt**2+arho1**2-ed**2)/(2.*srt))**2-arho1**2
16867        if(pout2.le.0)return
16868        xpro=threpi(srt)/10.
16869        factor=1/3.
16870        if( ((lb1.eq.8.and.lb2.eq.27).or.
16871      &       (lb1.eq.27.and.lb2.eq.8))
16872      & .OR. ((lb1.eq.-8.and.lb2.eq.25).or.
16873      &       (lb1.eq.25.and.lb2.eq.-8)) )factor=1/4.
16874        if((iabs(lb1).ge.10.and.iabs(lb1).le.13).
16875      &  or.(iabs(lb2).ge.10.and.iabs(lb2).le.13))factor=1.
16876        reab=factor*pin2/pout2*xpro
16877        return
16878        endif
16879 * for omega reabsorption
16880        if(ictrl.eq.3)then
16881        if(e(i1).gt.1)ed=e(i1)
16882        if(e(i2).gt.1)ed=e(i2)
16883        pout2=((srt**2+aomega**2-ed**2)/(2.*srt))**2-aomega**2
16884        if(pout2.le.0)return
16885        xpro=fourpi(srt)/10.
16886        factor=1/6.
16887        if((iabs(lb1).ge.10.and.iabs(lb1).le.13).
16888      &  or.(iabs(lb2).ge.10.and.iabs(lb2).le.13))factor=1./3.
16889        reab=factor*pin2/pout2*xpro
16890        endif
16891       return
16892         END
16893 ******************************************
16894 * for the reabsorption of two resonances
16895 * This function calculates the cross section for
16896 * DD-->NN, N*N*-->NN and DN*-->NN
16897 c      real*4 function reab2d(i1,i2,srt)
16898       real function reab2d(i1,i2,srt)
16899 *  srt    = DSQRT(s) in GeV                                                   *
16900 *  reab   = cross section in mb
16901 ****************************************
16902       PARAMETER      (MAXSTR=150001,MAXR=1,PI=3.1415926)
16903       parameter      (MX=4,MY=4,MZ=8,MPX=4,MPY=4,mpz=10,mpzp=10)
16904       PARAMETER      (AKA=0.498,ALA=1.1157,ASA=1.1974)
16905       parameter      (amn=0.938,ap1=0.14,arho=0.77,aomega=0.782)
16906        parameter       (maxx=20,maxz=24)
16907       COMMON   /AA/  R(3,MAXSTR)
16908 cc      SAVE /AA/
16909       COMMON   /BB/  P(3,MAXSTR)
16910 cc      SAVE /BB/
16911       COMMON   /CC/  E(MAXSTR)
16912 cc      SAVE /CC/
16913       COMMON  /DD/      RHO(-MAXX:MAXX,-MAXX:MAXX,-MAXZ:MAXZ),
16914      &                     RHOP(-MAXX:MAXX,-MAXX:MAXX,-MAXZ:MAXZ),
16915      &                     RHON(-MAXX:MAXX,-MAXX:MAXX,-MAXZ:MAXZ)
16916 cc      SAVE /DD/
16917       COMMON  /EE/      ID(MAXSTR),LB(MAXSTR)
16918 cc      SAVE /EE/
16919       SAVE
16920        reab2d=0
16921        LB1=iabs(LB(I1))
16922        LB2=iabs(LB(I2))
16923        ed1=e(i1)
16924        ed2=e(i2)
16925        pin2=(srt/2.)**2-amn**2
16926        pout2=((srt**2+ed1**2-ed2**2)/(2.*srt))**2-ed1**2
16927        if(pout2.le.0)return
16928        xpro=x2pi(srt)
16929        factor=1/4.
16930        if((lb1.ge.10.and.lb1.le.13).and.
16931      &    (lb2.ge.10.and.lb2.le.13))factor=1.
16932        if((lb1.ge.6.and.lb1.le.9).and.
16933      &    (lb2.gt.10.and.lb2.le.13))factor=1/2.
16934        if((lb2.ge.6.and.lb2.le.9).and.
16935      &    (lb1.gt.10.and.lb1.le.13))factor=1/2.
16936        reab2d=factor*pin2/pout2*xpro
16937        return
16938        end
16939 ***************************************
16940       SUBROUTINE rotate(PX0,PY0,PZ0,px,py,pz)
16941       SAVE
16942 * purpose: rotate the momentum of a particle in the CMS of p1+p2 such that
16943 * the x' y' and z' in the cms of p1+p2 is the same as the fixed x y and z
16944 * quantities:
16945 *            px0,py0 and pz0 are the cms momentum of the incoming colliding
16946 *            particles
16947 *            px, py and pz are the cms momentum of any one of the particles
16948 *            after the collision to be rotated
16949 ***************************************
16950 * the momentum, polar and azimuthal angles of the incoming momentm
16951       PR0  = SQRT( PX0**2 + PY0**2 + PZ0**2 )
16952       IF(PR0.EQ.0)PR0=0.00000001
16953       C2  = PZ0 / PR0
16954       IF(PX0 .EQ. 0.0 .AND. PY0 .EQ. 0.0) THEN
16955         T2 = 0.0
16956       ELSE
16957         T2=ATAN2(PY0,PX0)
16958       END IF
16959       S2  =  SQRT( 1.0 - C2**2 )
16960       CT2  = COS(T2)
16961       ST2  = SIN(T2)
16962 * the momentum, polar and azimuthal angles of the momentum to be rotated
16963       PR=SQRT(PX**2+PY**2+PZ**2)
16964       IF(PR.EQ.0)PR=0.0000001
16965       C1=PZ/PR
16966       IF(PX.EQ.0.AND.PY.EQ.0)THEN
16967       T1=0.
16968       ELSE
16969       T1=ATAN2(PY,PX)
16970       ENDIF
16971       S1   = SQRT( 1.0 - C1**2 )
16972       CT1  = COS(T1)
16973       ST1  = SIN(T1)
16974       SS   = C2 * S1 * CT1  +  S2 * C1
16975 * THE MOMENTUM AFTER ROTATION
16976       PX   = PR * ( SS*CT2 - S1*ST1*ST2 )
16977       PY   = PR * ( SS*ST2 + S1*ST1*CT2 )
16978       PZ   = PR * ( C1*C2 - S1*S2*CT1 )
16979       RETURN
16980       END
16981 ******************************************
16982 c      real*4 function Xpp(srt)
16983       real function Xpp(srt)
16984 *  This function contains the experimental total n-p cross sections           *
16985 *  srt    = DSQRT(s) in GeV                                                   *
16986 *  xsec   = production cross section in mb                                    *
16987 *  earray = EXPerimental table with proton energies in MeV                    *
16988 *  xarray = EXPerimental table with cross sections in mb (curve to guide eye) *
16989 *  WITH A CUTOFF AT 55MB                                                      *
16990 ******************************************
16991 c      real*4   xarray(14), earray(14)
16992       real   xarray(14), earray(14)
16993       SAVE
16994       data earray /20.,30.,40.,60.,80.,100.,
16995      &170.,250.,310.,
16996      &350.,460.,560.,660.,800./
16997       data xarray /150.,90.,80.6,48.0,36.6,
16998      &31.6,25.9,24.0,23.1,
16999      &24.0,28.3,33.6,41.5,47/
17000
17001       xpp=0.
17002        pmass=0.9383
17003 * 1.Calculate E_kin(lab) [MeV] from srt [GeV]
17004 *   Formula used:   DSQRT(s) = 2 m DSQRT(E_kin/(2m) + 1)
17005       ekin = 2000.*pmass*((srt/(2.*pmass))**2 - 1.)
17006       if (ekin .lt. earray(1)) then
17007         xpp = xarray(1)
17008        IF(XPP.GT.55)XPP=55
17009         return
17010       end if
17011        IF(EKIN.GT.EARRAY(14))THEN
17012        XPP=XARRAY(14)
17013        RETURN
17014        ENDIF
17015 *
17016 *
17017 * 2.Interpolate double logarithmically to find sigma(srt)
17018 *
17019       do 1001 ie = 1,14
17020         if (earray(ie) .eq. ekin) then
17021           xPP= xarray(ie)
17022        if(xpp.gt.55)xpp=55.
17023           return
17024        endif
17025         if (earray(ie) .gt. ekin) then
17026           ymin = alog(xarray(ie-1))
17027           ymax = alog(xarray(ie))
17028           xmin = alog(earray(ie-1))
17029           xmax = alog(earray(ie))
17030           XPP = exp(ymin + (alog(ekin)-xmin)
17031      &          *(ymax-ymin)/(xmax-xmin) )
17032        IF(XPP.GT.55)XPP=55.
17033        go to 50
17034         end if
17035  1001 continue
17036 50       continue
17037         return
17038         END
17039 ******************************************
17040       real function Xnp(srt)
17041 *  This function contains the experimental total n-p cross sections           *
17042 *  srt    = DSQRT(s) in GeV                                                   *
17043 *  xsec   = production cross section in mb                                    *
17044 *  earray = EXPerimental table with proton energies in MeV                    *
17045 *  xarray = EXPerimental table with cross sections in mb (curve to guide eye) *
17046 *  WITH  A CUTOFF AT 55MB                                                *
17047 ******************************************
17048 c      real*4   xarray(11), earray(11)
17049       real   xarray(11), earray(11)
17050       SAVE
17051       data   earray /20.,30.,40.,60.,90.,135.0,200.,
17052      &300.,400.,600.,800./
17053       data  xarray / 410.,270.,214.5,130.,78.,53.5,
17054      &41.6,35.9,34.2,34.3,34.9/
17055
17056        xnp=0.
17057        pmass=0.9383
17058 * 1.Calculate E_kin(lab) [MeV] from srt [GeV]
17059 *   Formula used:   DSQRT(s) = 2 m DSQRT(E_kin/(2m) + 1)
17060       ekin = 2000.*pmass*((srt/(2.*pmass))**2 - 1.)
17061       if (ekin .lt. earray(1)) then
17062         xnp = xarray(1)
17063        IF(XNP.GT.55)XNP=55
17064         return
17065       end if
17066        IF(EKIN.GT.EARRAY(11))THEN
17067        XNP=XARRAY(11)
17068        RETURN
17069        ENDIF
17070 *
17071 *Interpolate double logarithmically to find sigma(srt)
17072 *
17073       do 1001 ie = 1,11
17074         if (earray(ie) .eq. ekin) then
17075           xNP = xarray(ie)
17076          if(xnp.gt.55)xnp=55.
17077           return
17078        endif
17079         if (earray(ie) .gt. ekin) then
17080           ymin = alog(xarray(ie-1))
17081           ymax = alog(xarray(ie))
17082           xmin = alog(earray(ie-1))
17083           xmax = alog(earray(ie))
17084           xNP = exp(ymin + (alog(ekin)-xmin)
17085      &          *(ymax-ymin)/(xmax-xmin) )
17086        IF(XNP.GT.55)XNP=55
17087        go to 50
17088         end if
17089  1001 continue
17090 50       continue
17091         return
17092         END
17093 *******************************
17094        function ptr(ptmax,iseed)
17095 * (2) Generate the transverse momentum
17096 *     OF nucleons
17097 *******************************
17098         COMMON/TABLE/ xarray(0:1000),earray(0:1000)
17099 cc      SAVE /TABLE/
17100       COMMON/RNDF77/NSEED
17101 cc      SAVE /RNDF77/
17102       SAVE
17103        ISEED=ISEED
17104        ptr=0.
17105        if(ptmax.le.1.e-02)then
17106        ptr=ptmax
17107        return
17108        endif
17109        if(ptmax.gt.2.01)ptmax=2.01
17110        tryial=ptdis(ptmax)/ptdis(2.01)
17111        XT=RANART(NSEED)*tryial
17112 * look up the table and
17113 *Interpolate double logarithmically to find pt
17114         do 50 ie = 1,200
17115         if (earray(ie) .eq. xT) then
17116           ptr = xarray(ie)
17117        return
17118        end if
17119           if(xarray(ie-1).le.0.00001)go to 50
17120           if(xarray(ie).le.0.00001)go to 50
17121           if(earray(ie-1).le.0.00001)go to 50
17122           if(earray(ie).le.0.00001)go to 50
17123         if (earray(ie) .gt. xT) then
17124           ymin = alog(xarray(ie-1))
17125           ymax = alog(xarray(ie))
17126           xmin = alog(earray(ie-1))
17127           xmax = alog(earray(ie))
17128           ptr= exp(ymin + (alog(xT)-xmin)*(ymax-ymin)
17129      &    /(xmax-xmin) )
17130        if(ptr.gt.ptmax)ptr=ptmax
17131        return
17132        endif
17133 50      continue
17134        return
17135        end
17136
17137 **********************************
17138 **********************************
17139 *                                                                      *
17140 *                                                                      *
17141       SUBROUTINE XND(px,py,pz,srt,I1,I2,xinel,
17142      &               sigk,xsk1,xsk2,xsk3,xsk4,xsk5)
17143 *     PURPOSE:                                                         *
17144 *             calculate NUCLEON-BARYON RESONANCE inelatic Xsection     *
17145 *     NOTE   :                                                         *
17146 *     QUANTITIES:                                                 *
17147 *                      CHANNELS. M12 IS THE REVERSAL CHANNEL OF N12    *
17148 *                      N12,                                            *
17149 *                      M12=1 FOR p+n-->delta(+)+ n                     *
17150 *                          2     p+n-->delta(0)+ p                     *
17151 *                          3     p+p-->delta(++)+n                     *
17152 *                          4     p+p-->delta(+)+p                      *
17153 *                          5     n+n-->delta(0)+n                      *
17154 *                          6     n+n-->delta(-)+p                      *
17155 *                          7     n+p-->N*(0)(1440)+p                   *
17156 *                          8     n+p-->N*(+)(1440)+n                   *
17157 *                        9     p+p-->N*(+)(1535)+p                     *
17158 *                        10    n+n-->N*(0)(1535)+n                     *
17159 *                         11    n+p-->N*(+)(1535)+n                     *
17160 *                        12    n+p-->N*(0)(1535)+p
17161 *                        13    D(++)+D(-)-->N*(+)(1440)+n
17162 *                         14    D(++)+D(-)-->N*(0)(1440)+p
17163 *                        15    D(+)+D(0)--->N*(+)(1440)+n
17164 *                        16    D(+)+D(0)--->N*(0)(1440)+p
17165 *                        17    D(++)+D(0)-->N*(+)(1535)+p
17166 *                        18    D(++)+D(-)-->N*(0)(1535)+p
17167 *                        19    D(++)+D(-)-->N*(+)(1535)+n
17168 *                        20    D(+)+D(+)-->N*(+)(1535)+p
17169 *                        21    D(+)+D(0)-->N*(+)(1535)+n
17170 *                        22    D(+)+D(0)-->N*(0)(1535)+p
17171 *                        23    D(+)+D(-)-->N*(0)(1535)+n
17172 *                        24    D(0)+D(0)-->N*(0)(1535)+n
17173 *                          25    N*(+)(14)+N*(+)(14)-->N*(+)(15)+p
17174 *                          26    N*(0)(14)+N*(0)(14)-->N*(0)(15)+n
17175 *                          27    N*(+)(14)+N*(0)(14)-->N*(+)(15)+n
17176 *                        28    N*(+)(14)+N*(0)(14)-->N*(0)(15)+p
17177 *                        29    N*(+)(14)+D+-->N*(+)(15)+p
17178 *                        30    N*(+)(14)+D0-->N*(+)(15)+n
17179 *                        31    N*(+)(14)+D(-)-->N*(0)(1535)+n
17180 *                        32    N*(0)(14)+D++--->N*(+)(15)+p
17181 *                        33    N*(0)(14)+D+--->N*(+)(15)+n
17182 *                        34    N*(0)(14)+D+--->N*(0)(15)+p
17183 *                        35    N*(0)(14)+D0-->N*(0)(15)+n
17184 *                        36    N*(+)(14)+D0--->N*(0)(15)+p
17185 *                            and more
17186 ***********************************
17187         PARAMETER (MAXSTR=150001,MAXR=1,AMN=0.939457,
17188      1  AMP=0.93828,AP1=0.13496,AKA=0.498,APHI=1.020,
17189      2  AP2=0.13957,AM0=1.232,PI=3.1415926,CUTOFF=1.8966,AVMASS=0.9383)
17190         parameter     (MX=4,MY=4,MZ=8,MPX=4,MPY=4,mpz=10,mpzp=10)
17191         COMMON /AA/ R(3,MAXSTR)
17192 cc      SAVE /AA/
17193         COMMON /BB/ P(3,MAXSTR)
17194 cc      SAVE /BB/
17195         COMMON /CC/ E(MAXSTR)
17196 cc      SAVE /CC/
17197         COMMON /EE/ ID(MAXSTR),LB(MAXSTR)
17198 cc      SAVE /EE/
17199         common /ff/f(-mx:mx,-my:my,-mz:mz,-mpx:mpx,-mpy:mpy,-mpz:mpzp)
17200 cc      SAVE /ff/
17201         common /gg/ dx,dy,dz,dpx,dpy,dpz
17202 cc      SAVE /gg/
17203         COMMON /INPUT/ NSTAR,NDIRCT,DIR
17204 cc      SAVE /INPUT/
17205         COMMON /NN/NNN
17206 cc      SAVE /NN/
17207         COMMON /BG/BETAX,BETAY,BETAZ,GAMMA
17208 cc      SAVE /BG/
17209         COMMON   /RUN/NUM
17210 cc      SAVE /RUN/
17211         COMMON   /PA/RPION(3,MAXSTR,MAXR)
17212 cc      SAVE /PA/
17213         COMMON   /PB/PPION(3,MAXSTR,MAXR)
17214 cc      SAVE /PB/
17215         COMMON   /PC/EPION(MAXSTR,MAXR)
17216 cc      SAVE /PC/
17217         COMMON   /PD/LPION(MAXSTR,MAXR)
17218 cc      SAVE /PD/
17219         common/input1/ MASSPR,MASSTA,ISEED,IAVOID,DT
17220 cc      SAVE /input1/
17221       SAVE
17222
17223 *-----------------------------------------------------------------------
17224        xinel=0.
17225        sigk=0
17226        xsk1=0
17227        xsk2=0
17228        xsk3=0
17229        xsk4=0
17230        xsk5=0
17231         EM1=E(I1)
17232         EM2=E(I2)
17233       PR  = SQRT( PX**2 + PY**2 + PZ**2 )
17234 *     CAN HAPPEN ANY MORE ==> RETURN (2.04 = 2*AVMASS + PI-MASS+0.02)
17235         IF (SRT .LT. 2.04) RETURN
17236 * Resonance absorption or Delta + N-->N*(1440), N*(1535)
17237 * COM: TEST FOR DELTA OR N* ABSORPTION
17238 *      IN THE PROCESS DELTA+N-->NN, N*+N-->NN
17239         PRF=SQRT(0.25*SRT**2-AVMASS**2)
17240         IF(EM1.GT.1.)THEN
17241         DELTAM=EM1
17242         ELSE
17243         DELTAM=EM2
17244         ENDIF
17245         RENOM=DELTAM*PRF**2/DENOM(SRT,1.)/PR
17246         RENOMN=DELTAM*PRF**2/DENOM(SRT,2.)/PR
17247         RENOM1=DELTAM*PRF**2/DENOM(SRT,-1.)/PR
17248 * avoid the inelastic collisions between n+delta- -->N+N
17249 *       and p+delta++ -->N+N due to charge conservation,
17250 *       but they can scatter to produce kaons
17251        if((iabs(lb(i1)).eq.2).and.(iabs(lb(i2)).eq.6)) renom=0.
17252        if((iabs(lb(i2)).eq.2).and.(iabs(lb(i1)).eq.6)) renom=0.
17253        if((iabs(lb(i1)).eq.1).and.(iabs(lb(i2)).eq.9)) renom=0.
17254        if((iabs(lb(i2)).eq.1).and.(iabs(lb(i1)).eq.9)) renom=0.
17255        Call M1535(iabs(lb(i1)),iabs(lb(i2)),srt,x1535)
17256         X1440=(3./4.)*SIGMA(SRT,2,0,1)
17257 * CROSS SECTION FOR KAON PRODUCTION from the four channels
17258 * for NLK channel
17259        akp=0.498
17260        ak0=0.498
17261        ana=0.94
17262        ada=1.232
17263        al=1.1157
17264        as=1.1197
17265        xsk1=0
17266        xsk2=0
17267        xsk3=0
17268        xsk4=0
17269 c      !! phi production
17270        xsk5=0
17271        t1nlk=ana+al+akp
17272        if(srt.le.t1nlk)go to 222
17273        XSK1=1.5*PPLPK(SRT)
17274 * for DLK channel
17275        t1dlk=ada+al+akp
17276        t2dlk=ada+al-akp
17277        if(srt.le.t1dlk)go to 222
17278        es=srt
17279        pmdlk2=(es**2-t1dlk**2)*(es**2-t2dlk**2)/(4.*es**2)
17280        pmdlk=sqrt(pmdlk2)
17281        XSK3=1.5*PPLPK(srt)
17282 * for NSK channel
17283        t1nsk=ana+as+akp
17284        t2nsk=ana+as-akp
17285        if(srt.le.t1nsk)go to 222
17286        pmnsk2=(es**2-t1nsk**2)*(es**2-t2nsk**2)/(4.*es**2)
17287        pmnsk=sqrt(pmnsk2)
17288        XSK2=1.5*(PPK1(srt)+PPK0(srt))
17289 * for DSK channel
17290        t1DSk=aDa+aS+akp
17291        t2DSk=aDa+aS-akp
17292        if(srt.le.t1dsk)go to 222
17293        pmDSk2=(es**2-t1DSk**2)*(es**2-t2DSk**2)/(4.*es**2)
17294        pmDSk=sqrt(pmDSk2)
17295        XSK4=1.5*(PPK1(srt)+PPK0(srt))
17296 csp11/21/01
17297 c phi production
17298        if(srt.le.(2.*amn+aphi))go to 222
17299 c  !! mb put the correct form
17300          xsk5 = 0.0001
17301 csp11/21/01 end
17302
17303 * THE TOTAL KAON+ PRODUCTION CROSS SECTION IS THEN
17304 222       SIGK=XSK1+XSK2+XSK3+XSK4
17305
17306 cbz3/7/99 neutralk
17307         XSK1 = 2.0 * XSK1
17308         XSK2 = 2.0 * XSK2
17309         XSK3 = 2.0 * XSK3
17310         XSK4 = 2.0 * XSK4
17311         SIGK = 2.0 * SIGK + xsk5
17312 cbz3/7/99 neutralk end
17313
17314 * avoid the inelastic collisions between n+delta- -->N+N
17315 *       and p+delta++ -->N+N due to charge conservation,
17316 *       but they can scatter to produce kaons
17317        if(((iabs(lb(i1)).eq.2).and.(iabs(lb(i2)).eq.6)).OR.
17318      &         ((iabs(lb(i2)).eq.2).and.(iabs(lb(i1)).eq.6)).OR.
17319      &         ((iabs(lb(i1)).eq.1).and.(iabs(lb(i2)).eq.9)).OR.
17320      &         ((iabs(lb(i2)).eq.1).and.(iabs(lb(i1)).eq.9)))THEN
17321        xinel=sigk
17322        return
17323        ENDIF
17324 * WE DETERMINE THE REACTION CHANNELS IN THE FOLLOWING
17325 * FOR n+delta(++)-->p+p or n+delta(++)-->n+N*(+)(1440),n+N*(+)(1535)
17326 * REABSORPTION OR N*(1535) PRODUCTION LIKE IN P+P OR N*(1440) LIKE PN,
17327         IF(LB(I1)*LB(I2).EQ.18.AND.
17328      &    (iabs(LB(I1)).EQ.2.OR.iabs(LB(I2)).EQ.2))then
17329         SIGND=SIGMA(SRT,1,1,0)+0.5*SIGMA(SRT,1,1,1)
17330         SIGDN=0.25*SIGND*RENOM
17331         xinel=SIGDN+X1440+X1535+SIGK
17332        RETURN
17333        endif
17334 * FOR p+delta(-)-->n+n or p+delta(-)-->n+N*(0)(1440),n+N*(0)(1535)
17335 * REABSORPTION OR N*(1535) PRODUCTION LIKE IN P+P OR N*(1440) LIKE PN,
17336         IF(LB(I1)*LB(I2).EQ.6.AND.
17337      &    (iabs(LB(I1)).EQ.1.OR.iabs(LB(I2)).EQ.1))THEN
17338         SIGND=SIGMA(SRT,1,1,0)+0.5*SIGMA(SRT,1,1,1)
17339         SIGDN=0.25*SIGND*RENOM
17340         xinel=SIGDN+X1440+X1535+SIGK
17341        RETURN
17342        endif
17343 * FOR p+delta(+)-->p+p, N*(+)(144)+p, N*(+)(1535)+p
17344 cbz11/25/98
17345         IF(LB(I1)*LB(I2).EQ.8.AND.
17346      &    (iabs(LB(I1)).EQ.1.OR.iabs(LB(I2)).EQ.1))THEN
17347         SIGND=1.5*SIGMA(SRT,1,1,1)
17348         SIGDN=0.25*SIGND*RENOM
17349         xinel=SIGDN+x1440+x1535+SIGK
17350        RETURN
17351        endif
17352 * FOR n+delta(0)-->n+n, N*(0)(144)+n, N*(0)(1535)+n
17353         IF(LB(I1)*LB(I2).EQ.14.AND.
17354      &   (iabs(LB(I1)).EQ.2.AND.iabs(LB(I2)).EQ.2))THEN
17355         SIGND=1.5*SIGMA(SRT,1,1,1)
17356         SIGDN=0.25*SIGND*RENOM
17357         xinel=SIGDN+x1440+x1535+SIGK
17358        RETURN
17359        endif
17360 * FOR n+delta(+)-->n+p, N*(+)(1440)+n,N*(0)(1440)+p,
17361 *                       N*(+)(1535)+n,N*(0)(1535)+p
17362         IF(LB(I1)*LB(I2).EQ.16.AND.
17363      &     (iabs(LB(I1)).EQ.2.OR.iabs(LB(I2)).EQ.2))THEN
17364         SIGND=0.5*SIGMA(SRT,1,1,1)+0.25*SIGMA(SRT,1,1,0)
17365         SIGDN=0.5*SIGND*RENOM
17366         xinel=SIGDN+2.*x1440+2.*x1535+SIGK
17367        RETURN
17368        endif
17369 * FOR p+delta(0)-->n+p, N*(+)(1440)+n,N*(0)(1440)+p,
17370 *                       N*(+)(1535)+n,N*(0)(1535)+p
17371         IF(LB(I1)*LB(I2).EQ.7)THEN
17372         SIGND=0.5*SIGMA(SRT,1,1,1)+0.25*SIGMA(SRT,1,1,0)
17373         SIGDN=0.5*SIGND*RENOM
17374         xinel=SIGDN+2.*x1440+2.*x1535+SIGK
17375        RETURN
17376        endif
17377 * FOR p+N*(0)(14)-->p+n, N*(+)(1535)+n,N*(0)(1535)+p
17378 * OR  P+N*(0)(14)-->D(+)+N, D(0)+P,
17379         IF(LB(I1)*LB(I2).EQ.10.AND.
17380      &   (iabs(LB(I1)).EQ.1.OR.iabs(LB(I2)).EQ.1))then
17381         SIGND=(3./4.)*SIGMA(SRT,2,0,1)
17382         SIGDN=SIGND*RENOMN
17383         xinel=SIGDN+X1535+SIGK
17384        RETURN
17385        endif
17386 * FOR n+N*(+)-->p+n, N*(+)(1535)+n,N*(0)(1535)+p
17387         IF(LB(I1)*LB(I2).EQ.22.AND.
17388      &   (iabs(LB(I1)).EQ.2.OR.iabs(LB(I2)).EQ.2))then
17389         SIGND=(3./4.)*SIGMA(SRT,2,0,1)
17390         SIGDN=SIGND*RENOMN
17391         xinel=SIGDN+X1535+SIGK
17392        RETURN
17393        endif
17394 * FOR N*(1535)+N-->N+N COLLISIONS
17395         IF((iabs(LB(I1)).EQ.12).OR.(iabs(LB(I1)).EQ.13).OR.
17396      1  (iabs(LB(I2)).EQ.12).OR.(iabs(LB(I2)).EQ.13))THEN
17397         SIGND=X1535
17398         SIGDN=SIGND*RENOM1
17399         xinel=SIGDN+SIGK
17400        RETURN
17401        endif
17402         RETURN
17403        end
17404 **********************************
17405 *                                                                      *
17406 *                                                                      *
17407       SUBROUTINE XDDIN(PX,PY,PZ,SRT,I1,I2,
17408      &XINEL,SIGK,XSK1,XSK2,XSK3,XSK4,XSK5)
17409 *     PURPOSE:                                                         *
17410 *             DEALING WITH BARYON RESONANCE-BARYON RESONANCE COLLISIONS*
17411 *     NOTE   :                                                         *
17412 *           VALID ONLY FOR BARYON-BARYON-DISTANCES LESS THAN 1.32 FM   *
17413 *           (1.32 = 2 * HARD-CORE-RADIUS [HRC] )                       *
17414 *     QUANTITIES:                                                 *
17415 *           PX,PY,PZ - MOMENTUM COORDINATES OF ONE PARTICLE IN CM FRAME*
17416 *           SRT      - SQRT OF S                                       *
17417 *           NSTAR =1 INCLUDING N* RESORANCE,ELSE NOT                   *
17418 *           NDIRCT=1 INCLUDING DIRECT PION PRODUCTION PROCESS         *
17419 *           IBLOCK   - THE INFORMATION BACK                            *
17420 *                      0-> COLLISION CANNOT HAPPEN                     *
17421 *                      1-> N-N ELASTIC COLLISION                       *
17422 *                      2-> N+N->N+DELTA,OR N+N->N+N* REACTION          *
17423 *                      3-> N+DELTA->N+N OR N+N*->N+N REACTION          *
17424 *                      4-> N+N->N+N+PION,DIRTCT PROCESS                *
17425 *                     5-> DELTA(N*)+DELTA(N*)   TOTAL   COLLISIONS    *
17426 *           N12       - IS USED TO SPECIFY BARYON-BARYON REACTION      *
17427 *                      CHANNELS. M12 IS THE REVERSAL CHANNEL OF N12    *
17428 *                      N12,                                            *
17429 *                      M12=1 FOR p+n-->delta(+)+ n                     *
17430 *                          2     p+n-->delta(0)+ p                     *
17431 *                          3     p+p-->delta(++)+n                     *
17432 *                          4     p+p-->delta(+)+p                      *
17433 *                          5     n+n-->delta(0)+n                      *
17434 *                          6     n+n-->delta(-)+p                      *
17435 *                          7     n+p-->N*(0)(1440)+p                   *
17436 *                          8     n+p-->N*(+)(1440)+n                   *
17437 *                        9     p+p-->N*(+)(1535)+p                     *
17438 *                        10    n+n-->N*(0)(1535)+n                     *
17439 *                         11    n+p-->N*(+)(1535)+n                     *
17440 *                        12    n+p-->N*(0)(1535)+p
17441 *                        13    D(++)+D(-)-->N*(+)(1440)+n
17442 *                         14    D(++)+D(-)-->N*(0)(1440)+p
17443 *                        15    D(+)+D(0)--->N*(+)(1440)+n
17444 *                        16    D(+)+D(0)--->N*(0)(1440)+p
17445 *                        17    D(++)+D(0)-->N*(+)(1535)+p
17446 *                        18    D(++)+D(-)-->N*(0)(1535)+p
17447 *                        19    D(++)+D(-)-->N*(+)(1535)+n
17448 *                        20    D(+)+D(+)-->N*(+)(1535)+p
17449 *                        21    D(+)+D(0)-->N*(+)(1535)+n
17450 *                        22    D(+)+D(0)-->N*(0)(1535)+p
17451 *                        23    D(+)+D(-)-->N*(0)(1535)+n
17452 *                        24    D(0)+D(0)-->N*(0)(1535)+n
17453 *                          25    N*(+)(14)+N*(+)(14)-->N*(+)(15)+p
17454 *                          26    N*(0)(14)+N*(0)(14)-->N*(0)(15)+n
17455 *                          27    N*(+)(14)+N*(0)(14)-->N*(+)(15)+n
17456 *                        28    N*(+)(14)+N*(0)(14)-->N*(0)(15)+p
17457 *                        29    N*(+)(14)+D+-->N*(+)(15)+p
17458 *                        30    N*(+)(14)+D0-->N*(+)(15)+n
17459 *                        31    N*(+)(14)+D(-)-->N*(0)(1535)+n
17460 *                        32    N*(0)(14)+D++--->N*(+)(15)+p
17461 *                        33    N*(0)(14)+D+--->N*(+)(15)+n
17462 *                        34    N*(0)(14)+D+--->N*(0)(15)+p
17463 *                        35    N*(0)(14)+D0-->N*(0)(15)+n
17464 *                        36    N*(+)(14)+D0--->N*(0)(15)+p
17465 *                        +++
17466 *               AND MORE CHANNELS AS LISTED IN THE NOTE BOOK
17467 *
17468 * NOTE ABOUT N*(1440) RESORANCE:                                       *
17469 *     As it has been discussed in VerWest's paper,I= 1 (initial isospin)
17470 *     channel can all be attributed to delta resorance while I= 0      *
17471 *     channel can all be  attribured to N* resorance.Only in n+p       *
17472 *     one can have I=0 channel so is the N*(1440) resorance            *
17473 * REFERENCES:    J. CUGNON ET AL., NUCL. PHYS. A352, 505 (1981)        *
17474 *                    Y. KITAZOE ET AL., PHYS. LETT. 166B, 35 (1986)    *
17475 *                    B. VerWest el al., PHYS. PRV. C25 (1982)1979      *
17476 *                    Gy. Wolf  et al, Nucl Phys A517 (1990) 615        *
17477 *                    CUTOFF = 2 * AVMASS + 20 MEV                      *
17478 *                                                                      *
17479 *       for N*(1535) we use the parameterization by Gy. Wolf et al     *
17480 *       Nucl phys A552 (1993) 349, added May 18, 1994                  *
17481 **********************************
17482         PARAMETER (MAXSTR=150001,MAXR=1,AMN=0.939457,
17483      1  AMP=0.93828,AP1=0.13496,AKA=0.498,APHI=1.020,
17484      2  AP2=0.13957,AM0=1.232,PI=3.1415926,CUTOFF=1.8966,AVMASS=0.9383)
17485         parameter     (MX=4,MY=4,MZ=8,MPX=4,MPY=4,mpz=10,mpzp=10)
17486         COMMON /AA/ R(3,MAXSTR)
17487 cc      SAVE /AA/
17488         COMMON /BB/ P(3,MAXSTR)
17489 cc      SAVE /BB/
17490         COMMON /CC/ E(MAXSTR)
17491 cc      SAVE /CC/
17492         COMMON /EE/ ID(MAXSTR),LB(MAXSTR)
17493 cc      SAVE /EE/
17494         common /ff/f(-mx:mx,-my:my,-mz:mz,-mpx:mpx,-mpy:mpy,-mpz:mpzp)
17495 cc      SAVE /ff/
17496         common /gg/ dx,dy,dz,dpx,dpy,dpz
17497 cc      SAVE /gg/
17498         COMMON /INPUT/ NSTAR,NDIRCT,DIR
17499 cc      SAVE /INPUT/
17500         COMMON /NN/NNN
17501 cc      SAVE /NN/
17502         COMMON /BG/BETAX,BETAY,BETAZ,GAMMA
17503 cc      SAVE /BG/
17504         COMMON   /RUN/NUM
17505 cc      SAVE /RUN/
17506         COMMON   /PA/RPION(3,MAXSTR,MAXR)
17507 cc      SAVE /PA/
17508         COMMON   /PB/PPION(3,MAXSTR,MAXR)
17509 cc      SAVE /PB/
17510         COMMON   /PC/EPION(MAXSTR,MAXR)
17511 cc      SAVE /PC/
17512         COMMON   /PD/LPION(MAXSTR,MAXR)
17513 cc      SAVE /PD/
17514         common/input1/ MASSPR,MASSTA,ISEED,IAVOID,DT
17515 cc      SAVE /input1/
17516       SAVE
17517 *-----------------------------------------------------------------------
17518        XINEL=0
17519        SIGK=0
17520        XSK1=0
17521        XSK2=0
17522        XSK3=0
17523        XSK4=0
17524        XSK5=0
17525         EM1=E(I1)
17526         EM2=E(I2)
17527       PR  = SQRT( PX**2 + PY**2 + PZ**2 )
17528 *     IF THERE WERE 2 N*(1535) AND THEY DIDN'T SCATT. ELAST.,
17529 *     ALLOW THEM TO PRODUCE KAONS. NO OTHER INELASTIC CHANNELS
17530 *     ARE KNOWN
17531 C       if((lb(i1).ge.12).and.(lb(i2).ge.12))return
17532 *     ALL the inelastic collisions between N*(1535) and Delta as well
17533 *     as N*(1440) TO PRODUCE KAONS, NO OTHER CHANNELS ARE KNOWN
17534 C       if((lb(i1).ge.12).and.(lb(i2).ge.3))return
17535 C       if((lb(i2).ge.12).and.(lb(i1).ge.3))return
17536 *     calculate the N*(1535) production cross section in I1+I2 collisions
17537        call N1535(iabs(lb(i1)),iabs(lb(i2)),srt,X1535)
17538 c
17539 * for Delta+Delta-->N*(1440 OR 1535)+N AND N*(1440)+N*(1440)-->N*(1535)+X
17540 *     AND DELTA+N*(1440)-->N*(1535)+X
17541 * WE ASSUME THEY HAVE THE SAME CROSS SECTIONS as CORRESPONDING N+N COLLISION):
17542 * FOR D++D0, D+D+,D+D-,D0D0,N*+N*+,N*0N*0,N*(+)D+,N*(+)D(-),N*(0)D(0)
17543 * N*(1535) production, kaon production and reabsorption through
17544 * D(N*)+D(N*)-->NN are ALLOWED.
17545 * CROSS SECTION FOR KAON PRODUCTION from the four channels are
17546 * for NLK channel
17547        akp=0.498
17548        ak0=0.498
17549        ana=0.94
17550        ada=1.232
17551        al=1.1157
17552        as=1.1197
17553        xsk1=0
17554        xsk2=0
17555        xsk3=0
17556        xsk4=0
17557        t1nlk=ana+al+akp
17558        if(srt.le.t1nlk)go to 222
17559        XSK1=1.5*PPLPK(SRT)
17560 * for DLK channel
17561        t1dlk=ada+al+akp
17562        t2dlk=ada+al-akp
17563        if(srt.le.t1dlk)go to 222
17564        es=srt
17565        pmdlk2=(es**2-t1dlk**2)*(es**2-t2dlk**2)/(4.*es**2)
17566        pmdlk=sqrt(pmdlk2)
17567        XSK3=1.5*PPLPK(srt)
17568 * for NSK channel
17569        t1nsk=ana+as+akp
17570        t2nsk=ana+as-akp
17571        if(srt.le.t1nsk)go to 222
17572        pmnsk2=(es**2-t1nsk**2)*(es**2-t2nsk**2)/(4.*es**2)
17573        pmnsk=sqrt(pmnsk2)
17574        XSK2=1.5*(PPK1(srt)+PPK0(srt))
17575 * for DSK channel
17576        t1DSk=aDa+aS+akp
17577        t2DSk=aDa+aS-akp
17578        if(srt.le.t1dsk)go to 222
17579        pmDSk2=(es**2-t1DSk**2)*(es**2-t2DSk**2)/(4.*es**2)
17580        pmDSk=sqrt(pmDSk2)
17581        XSK4=1.5*(PPK1(srt)+PPK0(srt))
17582 csp11/21/01
17583 c phi production
17584        if(srt.le.(2.*amn+aphi))go to 222
17585 c  !! mb put the correct form
17586          xsk5 = 0.0001
17587 csp11/21/01 end
17588 * THE TOTAL KAON+ PRODUCTION CROSS SECTION IS THEN
17589 222       SIGK=XSK1+XSK2+XSK3+XSK4
17590
17591 cbz3/7/99 neutralk
17592         XSK1 = 2.0 * XSK1
17593         XSK2 = 2.0 * XSK2
17594         XSK3 = 2.0 * XSK3
17595         XSK4 = 2.0 * XSK4
17596         SIGK = 2.0 * SIGK + xsk5
17597 cbz3/7/99 neutralk end
17598
17599         IDD=iabs(LB(I1)*LB(I2))
17600 * The reabsorption cross section for the process
17601 * D(N*)D(N*)-->NN is
17602        s2d=reab2d(i1,i2,srt)
17603
17604 cbz3/16/99 pion
17605         S2D = 0.
17606 cbz3/16/99 pion end
17607
17608 *(1) N*(1535)+D(N*(1440)) reactions
17609 *    we allow kaon production and reabsorption only
17610        if(((iabs(lb(i1)).ge.12).and.(iabs(lb(i2)).ge.12)).OR.
17611      &       ((iabs(lb(i1)).ge.12).and.(iabs(lb(i2)).ge.6)).OR.
17612      &       ((iabs(lb(i2)).ge.12).and.(iabs(lb(i1)).ge.6)))THEN
17613        XINEL=sigk+s2d
17614        RETURN
17615        ENDIF
17616 * channels have the same charge as pp
17617         IF((IDD.EQ.63).OR.(IDD.EQ.64).OR.(IDD.EQ.48).
17618      1  OR.(IDD.EQ.49).OR.(IDD.EQ.11*11).OR.(IDD.EQ.10*10).
17619      2  OR.(IDD.EQ.88).OR.(IDD.EQ.66).
17620      3  OR.(IDD.EQ.90).OR.(IDD.EQ.70))THEN
17621         XINEL=X1535+SIGK+s2d
17622        RETURN
17623         ENDIF
17624 * IN DELTA+N*(1440) and N*(1440)+N*(1440) COLLISIONS,
17625 * N*(1535), kaon production and reabsorption are ALLOWED
17626 * IN N*(1440)+N*(1440) COLLISIONS, ONLY N*(1535) IS ALLOWED
17627        IF((IDD.EQ.110).OR.(IDD.EQ.77).OR.(IDD.EQ.80))THEN
17628        XINEL=X1535+SIGK+s2d
17629        RETURN
17630        ENDIF
17631        IF((IDD.EQ.54).OR.(IDD.EQ.56))THEN
17632 * LIKE FOR N+P COLLISION,
17633 * IN DELTA+DELTA COLLISIONS BOTH N*(1440) AND N*(1535) CAN BE PRODUCED
17634         SIG2=(3./4.)*SIGMA(SRT,2,0,1)
17635         XINEL=2.*(SIG2+X1535)+SIGK+s2d
17636        RETURN
17637        ENDIF
17638        RETURN
17639        END
17640 ******************************************
17641       real function dirct1(srt)
17642 *  This function contains the experimental, direct pion(+) + p cross sections *
17643 *  srt    = DSQRT(s) in GeV                                                   *
17644 *  dirct1  = cross section in fm**2                                     *
17645 *  earray = EXPerimental table with the srt
17646 *  xarray = EXPerimental table with cross sections in mb (curve to guide eye) *
17647 ******************************************
17648 c      real*4   xarray(122), earray(122)
17649       real   xarray(122), earray(122)
17650       SAVE
17651       data   earray /
17652      &1.568300,1.578300,1.588300,1.598300,1.608300,1.618300,1.628300,
17653      &1.638300,1.648300,1.658300,1.668300,1.678300,1.688300,1.698300,
17654      &1.708300,1.718300,1.728300,1.738300,1.748300,1.758300,1.768300,
17655      &1.778300,1.788300,1.798300,1.808300,1.818300,1.828300,1.838300,
17656      &1.848300,1.858300,1.868300,1.878300,1.888300,1.898300,1.908300,
17657      &1.918300,1.928300,1.938300,1.948300,1.958300,1.968300,1.978300,
17658      &1.988300,1.998300,2.008300,2.018300,2.028300,2.038300,2.048300,
17659      &2.058300,2.068300,2.078300,2.088300,2.098300,2.108300,2.118300,
17660      &2.128300,2.138300,2.148300,2.158300,2.168300,2.178300,2.188300,
17661      &2.198300,2.208300,2.218300,2.228300,2.238300,2.248300,2.258300,
17662      &2.268300,2.278300,2.288300,2.298300,2.308300,2.318300,2.328300,
17663      &2.338300,2.348300,2.358300,2.368300,2.378300,2.388300,2.398300,
17664      &2.408300,2.418300,2.428300,2.438300,2.448300,2.458300,2.468300,
17665      &2.478300,2.488300,2.498300,2.508300,2.518300,2.528300,2.538300,
17666      &2.548300,2.558300,2.568300,2.578300,2.588300,2.598300,2.608300,
17667      &2.618300,2.628300,2.638300,2.648300,2.658300,2.668300,2.678300,
17668      &2.688300,2.698300,2.708300,2.718300,2.728300,2.738300,2.748300,
17669      &2.758300,2.768300,2.778300/
17670       data xarray/
17671      &1.7764091E-02,0.5643668,0.8150568,1.045565,2.133695,3.327922,
17672      &4.206488,3.471242,4.486876,5.542213,6.800052,7.192446,6.829848,
17673      &6.580306,6.868410,8.527946,10.15720,9.716511,9.298335,8.901310,
17674      &10.31213,10.52185,11.17630,11.61639,12.05577,12.71596,13.46036,
17675      &14.22060,14.65449,14.94775,14.93310,15.32907,16.56481,16.29422,
17676      &15.18548,14.12658,13.72544,13.24488,13.31003,14.42680,12.84423,
17677      &12.49025,12.14858,11.81870,11.18993,11.35816,11.09447,10.83873,
17678      &10.61592,10.53754,9.425521,8.195912,9.661075,9.696192,9.200142,
17679      &8.953734,8.715461,8.484999,8.320765,8.255512,8.190969,8.127125,
17680      &8.079508,8.073004,8.010611,7.948909,7.887895,7.761005,7.626290,
17681      &7.494696,7.366132,7.530178,8.392097,9.046881,8.962544,8.879403,
17682      &8.797427,8.716601,8.636904,8.558312,8.404368,8.328978,8.254617,
17683      &8.181265,8.108907,8.037527,7.967100,7.897617,7.829057,7.761405,
17684      &7.694647,7.628764,7.563742,7.499570,7.387562,7.273281,7.161334,
17685      &6.973375,6.529592,6.280323,6.293136,6.305725,6.318097,6.330258,
17686      &6.342214,6.353968,6.365528,6.376895,6.388079,6.399081,6.409906,
17687      &6.420560,6.431045,6.441367,6.451529,6.461533,6.471386,6.481091,
17688      &6.490650,6.476413,6.297259,6.097826/
17689
17690       dirct1=0
17691       if (srt .lt. earray(1)) then
17692         dirct1 = 0.00001
17693         return
17694       end if
17695       if (srt .gt. earray(122)) then
17696         dirct1 = xarray(122)
17697        dirct1=dirct1/10.
17698         return
17699       end if
17700 *
17701 *Interpolate double logarithmically to find xdirct2(srt)
17702 *
17703       do 1001 ie = 1,122
17704         if (earray(ie) .eq. srt) then
17705           dirct1= xarray(ie)
17706          dirct1=dirct1/10.
17707           return
17708        endif
17709         if (earray(ie) .gt. srt) then
17710           ymin = alog(xarray(ie-1))
17711           ymax = alog(xarray(ie))
17712           xmin = alog(earray(ie-1))
17713           xmax = alog(earray(ie))
17714           dirct1= exp(ymin + (alog(srt)-xmin)
17715      &          *(ymax-ymin)/(xmax-xmin) )
17716        dirct1=dirct1/10.
17717        go to 50
17718         end if
17719  1001 continue
17720 50       continue
17721         return
17722         END
17723 *******************************
17724 ******************************************
17725       real function dirct2(srt)
17726 *  This function contains the experimental, direct pion(-) + p cross sections *
17727 *  srt    = DSQRT(s) in GeV                                                   *
17728 *  dirct2 = cross section in fm**2
17729 *  earray = EXPerimental table with the srt
17730 *  xarray = EXPerimental table with cross sections in mb (curve to guide eye) *
17731 ******************************************
17732 c      real*4   xarray(122), earray(122)
17733       real   xarray(122), earray(122)
17734       SAVE
17735       data   earray /
17736      &1.568300,1.578300,1.588300,1.598300,1.608300,1.618300,1.628300,
17737      &1.638300,1.648300,1.658300,1.668300,1.678300,1.688300,1.698300,
17738      &1.708300,1.718300,1.728300,1.738300,1.748300,1.758300,1.768300,
17739      &1.778300,1.788300,1.798300,1.808300,1.818300,1.828300,1.838300,
17740      &1.848300,1.858300,1.868300,1.878300,1.888300,1.898300,1.908300,
17741      &1.918300,1.928300,1.938300,1.948300,1.958300,1.968300,1.978300,
17742      &1.988300,1.998300,2.008300,2.018300,2.028300,2.038300,2.048300,
17743      &2.058300,2.068300,2.078300,2.088300,2.098300,2.108300,2.118300,
17744      &2.128300,2.138300,2.148300,2.158300,2.168300,2.178300,2.188300,
17745      &2.198300,2.208300,2.218300,2.228300,2.238300,2.248300,2.258300,
17746      &2.268300,2.278300,2.288300,2.298300,2.308300,2.318300,2.328300,
17747      &2.338300,2.348300,2.358300,2.368300,2.378300,2.388300,2.398300,
17748      &2.408300,2.418300,2.428300,2.438300,2.448300,2.458300,2.468300,
17749      &2.478300,2.488300,2.498300,2.508300,2.518300,2.528300,2.538300,
17750      &2.548300,2.558300,2.568300,2.578300,2.588300,2.598300,2.608300,
17751      &2.618300,2.628300,2.638300,2.648300,2.658300,2.668300,2.678300,
17752      &2.688300,2.698300,2.708300,2.718300,2.728300,2.738300,2.748300,
17753      &2.758300,2.768300,2.778300/
17754       data xarray/0.5773182,1.404156,2.578629,3.832013,4.906011,
17755      &9.076963,13.10492,10.65975,15.31156,19.77611,19.92874,18.68979,
17756      &19.80114,18.39536,14.34269,13.35353,13.58822,14.57031,10.24686,
17757      &11.23386,9.764803,10.35652,10.53539,10.07524,9.582198,9.596469,
17758      &9.818489,9.012848,9.378012,9.529244,9.529698,8.835624,6.671396,
17759      &8.797758,8.133437,7.866227,7.823946,7.808504,7.791755,7.502062,
17760      &7.417275,7.592349,7.752028,7.910585,8.068122,8.224736,8.075289,
17761      &7.895902,7.721359,7.551512,7.386224,7.225343,7.068739,6.916284,
17762      &6.767842,6.623294,6.482520,6.345404,6.211833,7.339510,7.531462,
17763      &7.724824,7.919620,7.848021,7.639856,7.571083,7.508881,7.447474,
17764      &7.386855,7.327011,7.164454,7.001266,6.842526,6.688094,6.537823,
17765      &6.391583,6.249249,6.110689,5.975790,5.894200,5.959503,6.024602,
17766      &6.089505,6.154224,6.218760,6.283128,6.347331,6.297411,6.120248,
17767      &5.948606,6.494864,6.357106,6.222824,6.091910,5.964267,5.839795,
17768      &5.718402,5.599994,5.499146,5.451325,5.404156,5.357625,5.311721,
17769      &5.266435,5.301964,5.343963,5.385833,5.427577,5.469200,5.510702,
17770      &5.552088,5.593359,5.634520,5.675570,5.716515,5.757356,5.798093,
17771      &5.838732,5.879272,5.919717,5.960068,5.980941/
17772
17773       dirct2=0.
17774       if (srt .lt. earray(1)) then
17775         dirct2 = 0.00001
17776         return
17777       end if
17778       if (srt .gt. earray(122)) then
17779         dirct2 = xarray(122)
17780        dirct2=dirct2/10.
17781         return
17782       end if
17783 *
17784 *Interpolate double logarithmically to find xdirct2(srt)
17785 *
17786       do 1001 ie = 1,122
17787         if (earray(ie) .eq. srt) then
17788           dirct2= xarray(ie)
17789          dirct2=dirct2/10.
17790           return
17791        endif
17792         if (earray(ie) .gt. srt) then
17793           ymin = alog(xarray(ie-1))
17794           ymax = alog(xarray(ie))
17795           xmin = alog(earray(ie-1))
17796           xmax = alog(earray(ie))
17797           dirct2= exp(ymin + (alog(srt)-xmin)
17798      &          *(ymax-ymin)/(xmax-xmin) )
17799        dirct2=dirct2/10.
17800        go to 50
17801         end if
17802  1001 continue
17803 50       continue
17804         return
17805         END
17806 *******************************
17807 ******************************
17808 * this program calculates the elastic cross section for rho+nucleon
17809 * through higher resonances
17810 c       real*4 function ErhoN(em1,em2,lb1,lb2,srt)
17811        real function ErhoN(em1,em2,lb1,lb2,srt)
17812 * date : Dec. 19, 1994
17813 * ****************************
17814 c       implicit real*4 (a-h,o-z)
17815       dimension   arrayj(19),arrayl(19),arraym(19),
17816      &arrayw(19),arrayb(19)
17817       SAVE
17818       data arrayj /0.5,1.5,0.5,0.5,2.5,2.5,1.5,0.5,1.5,3.5,
17819      &1.5,0.5,1.5,0.5,2.5,0.5,1.5,2.5,3.5/
17820       data arrayl/1,2,0,0,2,3,2,1,1,3,
17821      &1,0,2,0,3,1,1,2,3/
17822       data arraym /1.44,1.52,1.535,1.65,1.675,1.68,1.70,1.71,
17823      &1.72,1.99,1.60,1.62,1.70,1.90,1.905,1.910,
17824      &1.86,1.93,1.95/
17825       data arrayw/0.2,0.125,0.15,0.15,0.155,0.125,0.1,0.11,
17826      &0.2,0.29,0.25,0.16,0.28,0.15,0.3,0.22,0.25,
17827      &0.25,0.24/
17828       data arrayb/0.15,0.20,0.05,0.175,0.025,0.125,0.1,0.20,
17829      &0.53,0.34,0.05,0.07,0.15,0.45,0.45,0.058,
17830      &0.08,0.12,0.08/
17831
17832 * the minimum energy for pion+delta collision
17833        pi=3.1415926
17834        xs=0
17835 * include contribution from each resonance
17836        do 1001 ir=1,19
17837 cbz11/25/98
17838        IF(IR.LE.8)THEN
17839 c       if(lb1*lb2.eq.27.OR.LB1*LB2.EQ.25*2)branch=0.
17840 c       if(lb1*lb2.eq.26.OR.LB1*LB2.EQ.26*2)branch=1./3.
17841 c       if(lb1*lb2.eq.27*2.OR.LB1*LB2.EQ.25)branch=2./3.
17842 c       ELSE
17843 c       if(lb1*lb2.eq.27.OR.LB1*LB2.EQ.25*2)branch=1.
17844 c       if(lb1*lb2.eq.26.OR.LB1*LB2.EQ.26*2)branch=2./3.
17845 c       if(lb1*lb2.eq.27*2.OR.LB1*LB2.EQ.25)branch=1./3.
17846 c       ENDIF
17847        if( ((lb1*lb2.eq.27.AND.(LB1.EQ.1.OR.LB2.EQ.1)).OR.
17848      &     (LB1*LB2.EQ.25*2.AND.(LB1.EQ.2.OR.LB2.EQ.2)))
17849      &       .OR.((lb1*lb2.eq.-25.AND.(LB1.EQ.-1.OR.LB2.EQ.-1)).OR.
17850      &     (LB1*LB2.EQ.-27*2.AND.(LB1.EQ.-2.OR.LB2.EQ.-2))) )
17851      &     branch=0.
17852         if((iabs(lb1*lb2).eq.26.AND.(iabs(LB1).EQ.1.OR.iabs(LB2).EQ.1))
17853      &   .OR.(iabs(LB1*LB2).EQ.26*2
17854      &   .AND.(iabs(LB1).EQ.2.OR.iabs(LB2).EQ.2)))
17855      &     branch=1./3.
17856        if( ((lb1*lb2.eq.27*2.AND.(LB1.EQ.2.OR.LB2.EQ.2)).OR.
17857      &     (LB1*LB2.EQ.25.AND.(LB1.EQ.1.OR.LB2.EQ.1)))
17858      &  .OR.((lb1*lb2.eq.-25*2.AND.(LB1.EQ.-2.OR.LB2.EQ.-2)).OR.
17859      &     (LB1*LB2.EQ.-27.AND.(LB1.EQ.-1.OR.LB2.EQ.-1))) )
17860      &     branch=2./3.
17861        ELSE
17862        if( ((lb1*lb2.eq.27.AND.(LB1.EQ.1.OR.LB2.EQ.1)).OR.
17863      &     (LB1*LB2.EQ.25*2.AND.(LB1.EQ.2.OR.LB2.EQ.2)))
17864      &       .OR.((lb1*lb2.eq.-25.AND.(LB1.EQ.-1.OR.LB2.EQ.-1)).OR.
17865      &     (LB1*LB2.EQ.-27*2.AND.(LB1.EQ.-2.OR.LB2.EQ.-2))) )
17866      &     branch=1.
17867         if((iabs(lb1*lb2).eq.26.AND.(iabs(LB1).EQ.1.OR.iabs(LB2).EQ.1))
17868      &   .OR.(iabs(LB1*LB2).EQ.26*2
17869      &   .AND.(iabs(LB1).EQ.2.OR.iabs(LB2).EQ.2)))
17870      &     branch=2./3.
17871        if( ((lb1*lb2.eq.27*2.AND.(LB1.EQ.2.OR.LB2.EQ.2)).OR.
17872      &     (LB1*LB2.EQ.25.AND.(LB1.EQ.1.OR.LB2.EQ.1)))
17873      &  .OR.((lb1*lb2.eq.-25*2.AND.(LB1.EQ.-2.OR.LB2.EQ.-2)).OR.
17874      &     (LB1*LB2.EQ.-27.AND.(LB1.EQ.-1.OR.LB2.EQ.-1))) )
17875      &     branch=1./3.
17876        ENDIF
17877 cbz11/25/98end
17878        xs0=fdR(arraym(ir),arrayj(ir),arrayl(ir),
17879      &arrayw(ir),arrayb(ir),srt,EM1,EM2)
17880        xs=xs+1.3*pi*branch*xs0*(0.1973)**2
17881  1001 continue
17882        Erhon=xs
17883        return
17884        end
17885 ***************************8
17886 *FUNCTION FDE(DMASS) GIVES DELTA MASS DISTRIBUTION BY USING OF
17887 *KITAZOE'S FORMULA
17888 c        REAL*4 FUNCTION FDR(DMASS,aj,al,width,widb0,srt,em1,em2)
17889       REAL FUNCTION FDR(DMASS,aj,al,width,widb0,srt,em1,em2)
17890       SAVE
17891         AMd=em1
17892         AmP=em2
17893            Ak02= 0.25*(DMASS**2-amd**2-amp**2)**2
17894      &           -(Amp*amd)**2
17895             IF (ak02 .GT. 0.) THEN
17896               Q0 = SQRT(ak02/DMASS)
17897             ELSE
17898               Q0= 0.0
17899              fdR=0
17900            return
17901             END IF
17902            Ak2= 0.25*(srt**2-amd**2-amp**2)**2
17903      &           -(Amp*amd)**2
17904             IF (ak2 .GT. 0.) THEN
17905               Q = SQRT(ak2/DMASS)
17906             ELSE
17907               Q= 0.00
17908              fdR=0
17909              return
17910             END IF
17911        b=widb0*1.2*dmass/srt*(q/q0)**(2.*al+1)
17912      &  /(1.+0.2*(q/q0)**(2*al))
17913         FDR=(2.*aj+1)*WIDTH**2*b/((srt-dmass)**2
17914      1  +0.25*WIDTH**2)/(6.*q**2)
17915         RETURN
17916         END
17917 ******************************
17918 * this program calculates the elastic cross section for pion+delta
17919 * through higher resonances
17920 c       REAL*4 FUNCTION DIRCT3(SRT)
17921       REAL FUNCTION DIRCT3(SRT)
17922 * date : Dec. 19, 1994
17923 * ****************************
17924 c     implicit real*4 (a-h,o-z)
17925       dimension   arrayj(17),arrayl(17),arraym(17),
17926      &arrayw(17),arrayb(17)
17927       SAVE
17928       data arrayj /1.5,0.5,2.5,2.5,1.5,0.5,1.5,3.5,
17929      &1.5,0.5,1.5,0.5,2.5,0.5,1.5,2.5,3.5/
17930       data arrayl/2,0,2,3,2,1,1,3,
17931      &1,0,2,0,3,1,1,2,3/
17932       data arraym /1.52,1.65,1.675,1.68,1.70,1.71,
17933      &1.72,1.99,1.60,1.62,1.70,1.90,1.905,1.910,
17934      &1.86,1.93,1.95/
17935       data arrayw/0.125,0.15,0.155,0.125,0.1,0.11,
17936      &0.2,0.29,0.25,0.16,0.28,0.15,0.3,0.22,0.25,
17937      &0.25,0.24/
17938       data arrayb/0.55,0.6,0.375,0.6,0.1,0.15,
17939      &0.15,0.05,0.35,0.3,0.15,0.1,0.1,0.22,
17940      &0.2,0.09,0.4/
17941
17942 * the minimum energy for pion+delta collision
17943        pi=3.1415926
17944        amn=0.938
17945        amp=0.138
17946        xs=0
17947 * include contribution from each resonance
17948        branch=1./3.
17949        do 1001 ir=1,17
17950        if(ir.gt.8)branch=2./3.
17951        xs0=fd1(arraym(ir),arrayj(ir),arrayl(ir),
17952      &arrayw(ir),arrayb(ir),srt)
17953        xs=xs+1.3*pi*branch*xs0*(0.1973)**2
17954  1001   continue
17955        DIRCT3=XS
17956        RETURN
17957        end
17958 ***************************8
17959 *FUNCTION FDE(DMASS) GIVES DELTA MASS DISTRIBUTION BY USING OF
17960 *KITAZOE'S FORMULA
17961 c        REAL*4 FUNCTION FD1(DMASS,aj,al,width,widb0,srt)
17962       REAL FUNCTION FD1(DMASS,aj,al,width,widb0,srt)
17963       SAVE
17964         AMN=0.938
17965         AmP=0.138
17966        amd=amn
17967            Ak02= 0.25*(DMASS**2-amd**2-amp**2)**2
17968      &           -(Amp*amd)**2
17969             IF (ak02 .GT. 0.) THEN
17970               Q0 = SQRT(ak02/DMASS)
17971             ELSE
17972               Q0= 0.0
17973              fd1=0
17974            return
17975             END IF
17976            Ak2= 0.25*(srt**2-amd**2-amp**2)**2
17977      &           -(Amp*amd)**2
17978             IF (ak2 .GT. 0.) THEN
17979               Q = SQRT(ak2/DMASS)
17980             ELSE
17981               Q= 0.00
17982              fd1=0
17983              return
17984             END IF
17985        b=widb0*1.2*dmass/srt*(q/q0)**(2.*al+1)
17986      &  /(1.+0.2*(q/q0)**(2*al))
17987         FD1=(2.*aj+1)*WIDTH**2*b/((srt-dmass)**2
17988      1  +0.25*WIDTH**2)/(2.*q**2)
17989         RETURN
17990         END
17991 ******************************
17992 * this program calculates the elastic cross section for pion+delta
17993 * through higher resonances
17994 c       REAL*4 FUNCTION DPION(EM1,EM2,LB1,LB2,SRT)
17995       REAL FUNCTION DPION(EM1,EM2,LB1,LB2,SRT)
17996 * date : Dec. 19, 1994
17997 * ****************************
17998 c     implicit real*4 (a-h,o-z)
17999       dimension   arrayj(19),arrayl(19),arraym(19),
18000      &arrayw(19),arrayb(19)
18001       SAVE
18002       data arrayj /0.5,1.5,0.5,0.5,2.5,2.5,1.5,0.5,1.5,3.5,
18003      &1.5,0.5,1.5,0.5,2.5,0.5,1.5,2.5,3.5/
18004       data arrayl/1,2,0,0,2,3,2,1,1,3,
18005      &1,0,2,0,3,1,1,2,3/
18006       data arraym /1.44,1.52,1.535,1.65,1.675,1.68,1.70,1.71,
18007      &1.72,1.99,1.60,1.62,1.70,1.90,1.905,1.910,
18008      &1.86,1.93,1.95/
18009       data arrayw/0.2,0.125,0.15,0.15,0.155,0.125,0.1,0.11,
18010      &0.2,0.29,0.25,0.16,0.28,0.15,0.3,0.22,0.25,
18011      &0.25,0.24/
18012       data arrayb/0.15,0.25,0.,0.05,0.575,0.125,0.379,0.10,
18013      &0.10,0.062,0.45,0.60,0.6984,0.05,0.25,0.089,
18014      &0.19,0.2,0.13/
18015
18016 * the minimum energy for pion+delta collision
18017        pi=3.1415926
18018        amn=0.94
18019        amp=0.14
18020        xs=0
18021 * include contribution from each resonance
18022        do 1001 ir=1,19
18023        BRANCH=0.
18024 cbz11/25/98
18025        if(ir.LE.8)THEN
18026 c       IF(LB1*LB2.EQ.5*7.OR.LB1*LB2.EQ.3*8)branch=1./6.
18027 c       IF(LB1*LB2.EQ.4*7.OR.LB1*LB2.EQ.4*8)branch=1./3.
18028 c       IF(LB1*LB2.EQ.5*6.OR.LB1*LB2.EQ.3*9)branch=1./2.
18029 c       ELSE
18030 c       IF(LB1*LB2.EQ.5*8.OR.LB1*LB2.EQ.5*6)branch=2./5.
18031 c       IF(LB1*LB2.EQ.3*9.OR.LB1*LB2.EQ.3*7)branch=2./5.
18032 c       IF(LB1*LB2.EQ.5*7.OR.LB1*LB2.EQ.3*8)branch=8./15.
18033 c       IF(LB1*LB2.EQ.4*7.OR.LB1*LB2.EQ.4*8)branch=1./15.
18034 c       IF(LB1*LB2.EQ.4*9.OR.LB1*LB2.EQ.4*6)branch=3./5.
18035 c       ENDIF
18036        IF( ((LB1*LB2.EQ.5*7.AND.(LB1.EQ.5.OR.LB2.EQ.5)).OR.
18037      &     (LB1*LB2.EQ.3*8.AND.(LB1.EQ.3.OR.LB2.EQ.3)))
18038      &       .OR.((LB1*LB2.EQ.-3*7.AND.(LB1.EQ.3.OR.LB2.EQ.3)).OR.
18039      &     (LB1*LB2.EQ.-5*8.AND.(LB1.EQ.5.OR.LB2.EQ.5))) )
18040      &     branch=1./6.
18041        IF((iabs(LB1*LB2).EQ.4*7.AND.(LB1.EQ.4.OR.LB2.EQ.4)).OR.
18042      &     (iabs(LB1*LB2).EQ.4*8.AND.(LB1.EQ.4.OR.LB2.EQ.4)))
18043      &     branch=1./3.
18044        IF( ((LB1*LB2.EQ.5*6.AND.(LB1.EQ.5.OR.LB2.EQ.5)).OR.
18045      &     (LB1*LB2.EQ.3*9.AND.(LB1.EQ.3.OR.LB2.EQ.3)))
18046      &       .OR.((LB1*LB2.EQ.-3*6.AND.(LB1.EQ.3.OR.LB2.EQ.3)).OR.
18047      &     (LB1*LB2.EQ.-5*9.AND.(LB1.EQ.5.OR.LB2.EQ.5))) )
18048      &     branch=1./2.
18049        ELSE
18050        IF( ((LB1*LB2.EQ.5*8.AND.(LB1.EQ.5.OR.LB2.EQ.5)).OR.
18051      &     (LB1*LB2.EQ.5*6.AND.(LB1.EQ.5.OR.LB2.EQ.5)))
18052      &        .OR.((LB1*LB2.EQ.-3*8.AND.(LB1.EQ.3.OR.LB2.EQ.3)).OR.
18053      &     (LB1*LB2.EQ.-3*6.AND.(LB1.EQ.3.OR.LB2.EQ.3))) )
18054      &     branch=2./5.
18055        IF( ((LB1*LB2.EQ.3*9.AND.(LB1.EQ.3.OR.LB2.EQ.3)).OR.
18056      &     (LB1*LB2.EQ.3*7.AND.(LB1.EQ.3.OR.LB2.EQ.3)))
18057      &        .OR. ((LB1*LB2.EQ.-5*9.AND.(LB1.EQ.5.OR.LB2.EQ.5)).OR.
18058      &     (LB1*LB2.EQ.-5*7.AND.(LB1.EQ.5.OR.LB2.EQ.5))) )
18059      &     branch=2./5.
18060        IF( ((LB1*LB2.EQ.5*7.AND.(LB1.EQ.5.OR.LB2.EQ.5)).OR.
18061      &     (LB1*LB2.EQ.3*8.AND.(LB1.EQ.3.OR.LB2.EQ.3)))
18062      &        .OR.((LB1*LB2.EQ.-3*7.AND.(LB1.EQ.3.OR.LB2.EQ.3)).OR.
18063      &     (LB1*LB2.EQ.-5*8.AND.(LB1.EQ.5.OR.LB2.EQ.5))) )
18064      &     branch=8./15.
18065        IF((iabs(LB1*LB2).EQ.4*7.AND.(LB1.EQ.4.OR.LB2.EQ.4)).OR.
18066      &     (iabs(LB1*LB2).EQ.4*8.AND.(LB1.EQ.4.OR.LB2.EQ.4)))
18067      &     branch=1./15.
18068        IF((iabs(LB1*LB2).EQ.4*9.AND.(LB1.EQ.4.OR.LB2.EQ.4)).OR.
18069      &     (iabs(LB1*LB2).EQ.4*6.AND.(LB1.EQ.4.OR.LB2.EQ.4)))
18070      &     branch=3./5.
18071        ENDIF
18072 cbz11/25/98end
18073        xs0=fd2(arraym(ir),arrayj(ir),arrayl(ir),
18074      &arrayw(ir),arrayb(ir),EM1,EM2,srt)
18075        xs=xs+1.3*pi*branch*xs0*(0.1973)**2
18076  1001   continue
18077        DPION=XS
18078        RETURN
18079        end
18080 ***************************8
18081 *FUNCTION FDE(DMASS) GIVES DELTA MASS DISTRIBUTION BY USING OF
18082 *KITAZOE'S FORMULA
18083 c        REAL*4 FUNCTION FD2(DMASS,aj,al,width,widb0,EM1,EM2,srt)
18084       REAL FUNCTION FD2(DMASS,aj,al,width,widb0,EM1,EM2,srt)
18085       SAVE
18086         AmP=EM1
18087        amd=EM2
18088            Ak02= 0.25*(DMASS**2-amd**2-amp**2)**2
18089      &           -(Amp*amd)**2
18090             IF (ak02 .GT. 0.) THEN
18091               Q0 = SQRT(ak02/DMASS)
18092             ELSE
18093               Q0= 0.0
18094              fd2=0
18095            return
18096             END IF
18097            Ak2= 0.25*(srt**2-amd**2-amp**2)**2
18098      &           -(Amp*amd)**2
18099             IF (ak2 .GT. 0.) THEN
18100               Q = SQRT(ak2/DMASS)
18101             ELSE
18102               Q= 0.00
18103              fd2=0
18104              return
18105             END IF
18106        b=widb0*1.2*dmass/srt*(q/q0)**(2.*al+1)
18107      &  /(1.+0.2*(q/q0)**(2*al))
18108         FD2=(2.*aj+1)*WIDTH**2*b/((srt-dmass)**2
18109      1  +0.25*WIDTH**2)/(4.*q**2)
18110         RETURN
18111         END
18112 ***************************8
18113 *   MASS GENERATOR for two resonances simultaneously
18114        subroutine Rmasdd(srt,am10,am20,
18115      &dmin1,dmin2,ISEED,ic,dm1,dm2)
18116       COMMON/RNDF77/NSEED
18117 cc      SAVE /RNDF77/
18118       SAVE
18119        ISEED=ISEED
18120        amn=0.94
18121        amp=0.14
18122 * the maximum mass for resonance 1
18123          dmax1=srt-dmin2
18124 * generate the mass for the first resonance
18125  5        NTRY1=0
18126          ntry2=0
18127          ntry=0
18128          ictrl=0
18129 10        DM1 = RANART(NSEED) * (DMAX1-DMIN1) + DMIN1
18130           NTRY1=NTRY1+1
18131 * the maximum mass for resonance 2
18132          if(ictrl.eq.0)dmax2=srt-dm1
18133 * generate the mass for the second resonance
18134 20         dm2=RANART(NSEED)*(dmax2-dmin2)+dmin2
18135           NTRY2=NTRY2+1
18136 * check the energy-momentum conservation with two masses
18137 * q2 in the following is q**2*4*srt**2
18138          q2=((srt**2-dm1**2-dm2**2)**2-4.*dm1**2*dm2**2)
18139          if(q2.le.0)then
18140          dmax2=dm2-0.01
18141 c         dmax1=dm1-0.01
18142          ictrl=1
18143          go to 20
18144          endif
18145 * determine the weight of the mass pair
18146           IF(DMAX1.LT.am10) THEN
18147           if(ic.eq.1)FM1=Fmassd(DMAX1)
18148           if(ic.eq.2)FM1=Fmassn(DMAX1)
18149           if(ic.eq.3)FM1=Fmassd(DMAX1)
18150           if(ic.eq.4)FM1=Fmassd(DMAX1)
18151           ELSE
18152           if(ic.eq.1)FM1=Fmassd(am10)
18153           if(ic.eq.2)FM1=Fmassn(am10)
18154           if(ic.eq.3)FM1=Fmassd(am10)
18155           if(ic.eq.4)FM1=Fmassd(am10)
18156           ENDIF
18157           IF(DMAX2.LT.am20) THEN
18158           if(ic.eq.1)FM2=Fmassd(DMAX2)
18159           if(ic.eq.2)FM2=Fmassn(DMAX2)
18160           if(ic.eq.3)FM2=Fmassn(DMAX2)
18161           if(ic.eq.4)FM2=Fmassr(DMAX2)
18162           ELSE
18163           if(ic.eq.1)FM2=Fmassd(am20)
18164           if(ic.eq.2)FM2=Fmassn(am20)
18165           if(ic.eq.3)FM2=Fmassn(am20)
18166           if(ic.eq.4)FM2=Fmassr(am20)
18167           ENDIF
18168           IF(FM1.EQ.0.)FM1=1.e-04
18169           IF(FM2.EQ.0.)FM2=1.e-04
18170          prob0=fm1*fm2
18171           if(ic.eq.1)prob=Fmassd(dm1)*fmassd(dm2)
18172           if(ic.eq.2)prob=Fmassn(dm1)*fmassn(dm2)
18173           if(ic.eq.3)prob=Fmassd(dm1)*fmassn(dm2)
18174           if(ic.eq.4)prob=Fmassd(dm1)*fmassr(dm2)
18175          if(prob.le.1.e-06)prob=1.e-06
18176          fff=prob/prob0
18177          ntry=ntry+1
18178           IF(RANART(NSEED).GT.fff.AND.
18179      1    NTRY.LE.20) GO TO 10
18180
18181 clin-2/26/03 limit the mass of (rho,Delta,N*1440) below a certain value
18182 c     (here taken as its central value + 2* B-W fullwidth):
18183           if((abs(am10-0.77).le.0.01.and.dm1.gt.1.07)
18184      1         .or.(abs(am10-1.232).le.0.01.and.dm1.gt.1.47)
18185      2         .or.(abs(am10-1.44).le.0.01.and.dm1.gt.2.14)) goto 5
18186           if((abs(am20-0.77).le.0.01.and.dm2.gt.1.07)
18187      1         .or.(abs(am20-1.232).le.0.01.and.dm2.gt.1.47)
18188      2         .or.(abs(am20-1.44).le.0.01.and.dm2.gt.2.14)) goto 5
18189
18190        RETURN
18191        END
18192 *FUNCTION Fmassd(DMASS) GIVES the delta MASS DISTRIBUTION
18193         REAL FUNCTION Fmassd(DMASS)
18194       SAVE
18195         AM0=1.232
18196         Fmassd=am0*WIDTH(DMASS)/((DMASS**2-am0**2)**2
18197      1  +am0**2*WIDTH(DMASS)**2)
18198         RETURN
18199         END
18200 *FUNCTION Fmassn(DMASS) GIVES the N* MASS DISTRIBUTION
18201         REAL FUNCTION Fmassn(DMASS)
18202       SAVE
18203         AM0=1.44
18204         Fmassn=am0*W1440(DMASS)/((DMASS**2-am0**2)**2
18205      1  +am0**2*W1440(DMASS)**2)
18206         RETURN
18207         END
18208 *FUNCTION Fmassr(DMASS) GIVES the rho MASS DISTRIBUTION
18209         REAL FUNCTION Fmassr(DMASS)
18210       SAVE
18211         AM0=0.77
18212        wid=0.153
18213         Fmassr=am0*Wid/((DMASS**2-am0**2)**2
18214      1  +am0**2*Wid**2)
18215         RETURN
18216         END
18217 **********************************
18218 * PURPOSE : flow analysis
18219 * DATE : Feb. 1, 1995
18220 ***********************************
18221        subroutine flow(nt)
18222 c       IMPLICIT REAL*4 (A-H,O-Z)
18223        PARAMETER ( PI=3.1415926,APion=0.13957,aka=0.498)
18224         PARAMETER   (MAXSTR=150001,MAXR=1,AMU= 0.9383,etaM=0.5475)
18225        DIMENSION ypion(-80:80),ypr(-80:80),ykaon(-80:80)
18226        dimension pxpion(-80:80),pxpro(-80:80),pxkaon(-80:80)
18227 *----------------------------------------------------------------------*
18228       COMMON  /AA/      R(3,MAXSTR)
18229 cc      SAVE /AA/
18230       COMMON  /BB/      P(3,MAXSTR)
18231 cc      SAVE /BB/
18232       COMMON  /CC/      E(MAXSTR)
18233 cc      SAVE /CC/
18234       COMMON  /EE/      ID(MAXSTR),LB(MAXSTR)
18235 cc      SAVE /EE/
18236       COMMON  /RR/      MASSR(0:MAXR)
18237 cc      SAVE /RR/
18238       COMMON  /RUN/     NUM
18239 cc      SAVE /RUN/
18240       common/input1/ MASSPR,MASSTA,ISEED,IAVOID,DT
18241 cc      SAVE /input1/
18242       SAVE
18243 *----------------------------------------------------------------------*
18244        NT=NT
18245        ycut1=-2.6
18246        ycut2=2.6
18247        DY=0.2
18248        LY=NINT((YCUT2-YCUT1)/DY)
18249 ***********************************
18250 C initialize the transverse momentum counters
18251        do 11 kk=-80,80
18252        pxpion(kk)=0
18253        pxpro(kk)=0
18254        pxkaon(kk)=0
18255 11       continue
18256        DO 701 J=-LY,LY
18257        ypion(j)=0
18258        ykaon(j)=0
18259        ypr(j)=0
18260   701   CONTINUE
18261        nkaon=0
18262        npr=0
18263        npion=0
18264           IS=0
18265           DO 20 NRUN=1,NUM
18266           IS=IS+MASSR(NRUN-1)
18267           DO 20 J=1,MASSR(NRUN)
18268           I=J+IS
18269 * for protons go to 200 to calculate its rapidity and transvese momentum
18270 * distributions
18271        e00=sqrt(P(1,I)**2+P(2,i)**2+P(3,i)**2+e(I)**2)
18272        y00=0.5*alog((e00+p(3,i))/(e00-p(3,i)))
18273        if(abs(y00).ge.ycut2)go to 20
18274        iy=nint(y00/DY)
18275        if(abs(iy).ge.80)go to 20
18276        if(e(i).eq.0)go to 20
18277        if(lb(i).ge.25)go to 20
18278        if((lb(i).le.5).and.(lb(i).ge.3))go to 50
18279        if(lb(i).eq.1.or.lb(i).eq.2)go to 200
18280 cbz3/10/99
18281 c       if(lb(i).ge.6.and.lb(i).le.15)go to 200
18282        if(lb(i).ge.6.and.lb(i).le.17)go to 200
18283 cbz3/10/99 end
18284        if(lb(i).eq.23)go to 400
18285        go to 20
18286 * calculate rapidity and transverse momentum distribution for pions
18287 50       npion=npion+1
18288 * (2) rapidity distribution in the cms frame
18289         ypion(iy)=ypion(iy)+1
18290        pxpion(iy)=pxpion(iy)+p(1,i)/e(I)
18291        go TO 20
18292 * calculate rapidity and transverse energy distribution for baryons
18293 200      npr=npr+1
18294                 pxpro(iy)=pxpro(iy)+p(1,I)/E(I)
18295                  ypr(iy)=ypr(iy)+1.
18296         go to 20
18297 400     nkaon=nkaon+1
18298                  ykaon(iy)=ykaon(iy)+1.
18299                 pxkaon(iy)=pxkaon(iy)+p(1,i)/E(i)
18300 20      CONTINUE
18301 C PRINT OUT NUCLEON'S TRANSVERSE MOMENTUM distribution
18302 c       write(1041,*)Nt
18303 c       write(1042,*)Nt
18304 c       write(1043,*)Nt
18305 c       write(1090,*)Nt
18306 c       write(1091,*)Nt
18307 c       write(1092,*)Nt
18308        do 3 npt=-10,10
18309        IF(ypr(npt).eq.0) go to 101
18310        pxpro(NPT)=-Pxpro(NPT)/ypr(NPT)
18311        DNUC=Pxpro(NPT)/SQRT(ypr(NPT))
18312 c       WRITE(1041,*)NPT*DY,Pxpro(NPT),DNUC
18313 c print pion's transverse momentum distribution
18314 101       IF(ypion(npt).eq.0) go to 102
18315        pxpion(NPT)=-pxpion(NPT)/ypion(NPT)
18316        DNUCp=pxpion(NPT)/SQRT(ypion(NPT))
18317 c       WRITE(1042,*)NPT*DY,Pxpion(NPT),DNUCp
18318 c kaons
18319 102       IF(ykaon(npt).eq.0) go to 3
18320        pxkaon(NPT)=-pxkaon(NPT)/ykaon(NPT)
18321        DNUCk=pxkaon(NPT)/SQRT(ykaon(NPT))
18322 c       WRITE(1043,*)NPT*DY,Pxkaon(NPT),DNUCk
18323 3       CONTINUE
18324 ********************************
18325 * OUTPUT PION AND PROTON RAPIDITY DISTRIBUTIONS
18326        DO 1001 M=-LY,LY
18327 * PROTONS
18328        DYPR=0
18329        IF(YPR(M).NE.0)DYPR=SQRT(YPR(M))/FLOAT(NRUN)/DY
18330        YPR(M)=YPR(M)/FLOAT(NRUN)/DY
18331 c       WRITE(1090,'(E11.3,2X,E11.3,2X,E11.3)')m*DY,YPR(M),DYPR
18332 * PIONS
18333        DYPION=0
18334        IF(YPION(M).NE.0)DYPION=SQRT(YPION(M))/FLOAT(NRUN)/DY
18335        YPION(M)=YPION(M)/FLOAT(NRUN)/DY
18336 c       WRITE(1091,'(E11.3,2X,E11.3,2X,E11.3)')m*DY,YPION(M),DYPION
18337 * KAONS
18338        DYKAON=0
18339        IF(YKAON(M).NE.0)DYKAON=SQRT(YKAON(M))/FLOAT(NRUN)/DY
18340        YKAON(M)=YKAON(M)/FLOAT(NRUN)/DY
18341 c       WRITE(1092,'(E11.3,2X,E11.3,2X,E11.3)')m*DY,YKAON(M),DYKAON
18342  1001 CONTINUE
18343        return
18344        end
18345 cbali1/16/99
18346 ********************************************
18347 * Purpose: pp_bar annihilation cross section as a functon of their cms energy
18348 c      real*4 function xppbar(srt)
18349       real function xppbar(srt)
18350 *  srt    = DSQRT(s) in GeV                                                   *
18351 *  xppbar = pp_bar annihilation cross section in mb                           *
18352 *
18353 *  Reference: G.J. Wang, R. Bellwied, C. Pruneau and G. Welke
18354 *             Proc. of the 14th Winter Workshop on Nuclear Dynamics,
18355 *             Snowbird, Utah 31, Eds. W. Bauer and H.G. Ritter
18356 *             (Plenum Publishing, 1998)                             *
18357 *
18358 ******************************************
18359        Parameter (pmass=0.9383,xmax=400.)
18360       SAVE
18361 * Note:
18362 * (1) we introduce a new parameter xmax=400 mb:
18363 *     the maximum annihilation xsection
18364 * there are shadowing effects in pp_bar annihilation, with this parameter
18365 * we can probably look at these effects
18366 * (2) Calculate p(lab) from srt [GeV], since the formular in the
18367 * reference applies only to the case of a p_bar on a proton at rest
18368 * Formula used: srt**2=2.*pmass*(pmass+sqrt(pmass**2+plab**2))
18369        xppbar=1.e-06
18370        plab2=(srt**2/(2.*pmass)-pmass)**2-pmass**2
18371        if(plab2.gt.0)then
18372            plab=sqrt(plab2)
18373        xppbar=67./(plab**0.7)
18374        if(xppbar.gt.xmax)xppbar=xmax
18375        endif
18376          return
18377       END
18378 cbali1/16/99 end
18379 **********************************
18380 cbali2/6/99
18381 ********************************************
18382 * Purpose: To generate randomly the no. of pions in the final
18383 *          state of pp_bar annihilation according to a statistical
18384 *          model by using of the rejection method.
18385 cbz2/25/99
18386 c      real*4 function pbarfs(srt,npion,iseed)
18387       subroutine pbarfs(srt,npion,iseed)
18388 cbz2/25/99end
18389 * Quantities:
18390 *  srt: DSQRT(s) in GeV                                                    *
18391 *  npion: No. of pions produced in the annihilation of ppbar at srt        *
18392 *  nmax=6, cutoff of the maximum no. of n the code can handle
18393 *
18394 *  Reference: C.M. Ko and R. Yuan, Phys. Lett. B192 (1987) 31      *
18395 *
18396 ******************************************
18397        parameter (pimass=0.140,pi=3.1415926)
18398        Dimension factor(6),pnpi(6)
18399       COMMON/RNDF77/NSEED
18400 cc      SAVE /RNDF77/
18401       SAVE
18402        ISEED=ISEED
18403 C the factorial coefficients in the pion no. distribution
18404 * from n=2 to 6 calculated use the formula in the reference
18405        factor(2)=1.
18406        factor(3)=1.17e-01
18407        factor(4)=3.27e-03
18408        factor(5)=3.58e-05
18409        factor(6)=1.93e-07
18410        ene=(srt/pimass)**3/(6.*pi**2)
18411 c the relative probability from n=2 to 6
18412        do 1001 n=2,6
18413            pnpi(n)=ene**n*factor(n)
18414  1001   continue
18415 c find the maximum of the probabilities, I checked a
18416 c Fortan manual: max() returns the maximum value of
18417 c the same type as in the argument list
18418        pmax=max(pnpi(2),pnpi(3),pnpi(4),pnpi(5),pnpi(6))
18419 c randomly generate n between 2 and 6
18420        ntry=0
18421  10    npion=2+int(5*RANART(NSEED))
18422 clin-4/2008 check bounds:
18423        if(npion.gt.6) goto 10
18424        thisp=pnpi(npion)/pmax
18425        ntry=ntry+1
18426 c decide whether to take this npion according to the distribution
18427 c using rejection method.
18428        if((thisp.lt.RANART(NSEED)).and.(ntry.le.20)) go to 10
18429 c now take the last generated npion and return
18430        return
18431        END
18432 **********************************
18433 cbali2/6/99 end
18434 cbz3/9/99 kkbar
18435 cbali3/5/99
18436 ******************************************
18437 * purpose: Xsection for K+ K- to pi+ pi-
18438 c      real*4 function xkkpi(srt)
18439 *  srt    = DSQRT(s) in GeV                                  *
18440 *  xkkpi   = xsection in mb obtained from
18441 *           the detailed balance                             *
18442 * ******************************************
18443 c          parameter (pimass=0.140,aka=0.498)
18444 c       xkkpi=1.e-08
18445 c       ppi2=(srt/2)**2-pimass**2
18446 c       pk2=(srt/2)**2-aka**2
18447 c       if(ppi2.le.0.or.pk2.le.0)return
18448 cbz3/9/99 kkbar
18449 c       xkkpi=ppi2/pk2*pipik(srt)
18450 c       xkkpi=9.0 / 4.0 * ppi2/pk2*pipik(srt)
18451 c        xkkpi = 2.0 * xkkpi
18452 cbz3/9/99 kkbar end
18453
18454 cbz3/9/99 kkbar
18455 c       end
18456 c       return
18457 c        END
18458 cbz3/9/99 kkbar end
18459
18460 cbali3/5/99 end
18461 cbz3/9/99 kkbar end
18462
18463 cbz3/9/99 kkbar
18464 *****************************
18465 * purpose: Xsection for K+ K- to pi+ pi-
18466       SUBROUTINE XKKANN(SRT, XSK1, XSK2, XSK3, XSK4, XSK5,
18467      &     XSK6, XSK7, XSK8, XSK9, XSK10, XSK11, SIGK, rrkk)
18468 *  srt    = DSQRT(s) in GeV                                       *
18469 *  xsk1   = annihilation into pi pi                               *
18470 *  xsk2   = annihilation into pi rho (shifted to XKKSAN)         *
18471 *  xsk3   = annihilation into pi omega (shifted to XKKSAN)       *
18472 *  xsk4   = annihilation into pi eta                              *
18473 *  xsk5   = annihilation into rho rho                             *
18474 *  xsk6   = annihilation into rho omega                           *
18475 *  xsk7   = annihilation into rho eta (shifted to XKKSAN)        *
18476 *  xsk8   = annihilation into omega omega                         *
18477 *  xsk9   = annihilation into omega eta (shifted to XKKSAN)      *
18478 *  xsk10  = annihilation into eta eta                             *
18479 *  sigk   = xsection in mb obtained from                          *
18480 *           the detailed balance                                  *
18481 * ***************************
18482       PARAMETER  (MAXSTR=150001, MAXX=20,  MAXZ=24)
18483           PARAMETER (AKA=0.498, PIMASS=0.140, RHOM = 0.770,
18484      &     OMEGAM = 0.7819, ETAM = 0.5473, APHI=1.02)
18485       COMMON  /AA/ R(3,MAXSTR)
18486 cc      SAVE /AA/
18487       COMMON /BB/  P(3,MAXSTR)
18488 cc      SAVE /BB/
18489       COMMON /EE/ ID(MAXSTR),LB(MAXSTR)
18490 cc      SAVE /EE/
18491       COMMON  /DD/      RHO(-MAXX:MAXX,-MAXX:MAXX,-MAXZ:MAXZ),
18492      &                     RHOP(-MAXX:MAXX,-MAXX:MAXX,-MAXZ:MAXZ),
18493      &                     RHON(-MAXX:MAXX,-MAXX:MAXX,-MAXZ:MAXZ)
18494 cc      SAVE /DD/
18495       SAVE
18496
18497         S = SRT ** 2
18498        SIGK = 1.E-08
18499         XSK1 = 0.0
18500         XSK2 = 0.0
18501         XSK3 = 0.0
18502         XSK4 = 0.0
18503         XSK5 = 0.0
18504         XSK6 = 0.0
18505         XSK7 = 0.0
18506         XSK8 = 0.0
18507         XSK9 = 0.0
18508         XSK10 = 0.0
18509         XSK11 = 0.0
18510
18511         XPION0 = PIPIK(SRT)
18512 c.....take into account both K+ and K0
18513         XPION0 = 2.0 * XPION0
18514         PI2 = S * (S - 4.0 * AKA ** 2)
18515          if(PI2 .le. 0.0)return
18516
18517         XM1 = PIMASS
18518         XM2 = PIMASS
18519         PF2 = (S - (XM1 + XM2) ** 2) * (S - (XM1 - XM2) ** 2)
18520         IF (PF2 .GT. 0.0) THEN
18521            XSK1 = 9.0 / 4.0 * PF2 / PI2 * XPION0
18522         END IF
18523
18524 clin-8/28/00 (pi eta) eta -> K+K- is assumed the same as pi pi -> K+K-:
18525         XM1 = PIMASS
18526         XM2 = ETAM
18527         PF2 = (S - (XM1 + XM2) ** 2) * (S - (XM1 - XM2) ** 2)
18528         IF (PF2 .GT. 0.0) THEN
18529            XSK4 = 3.0 / 4.0 * PF2 / PI2 * XPION0
18530         END IF
18531
18532         XM1 = ETAM
18533         XM2 = ETAM
18534         PF2 = (S - (XM1 + XM2) ** 2) * (S - (XM1 - XM2) ** 2)
18535         IF (PF2 .GT. 0.0) THEN
18536            XSK10 = 1.0 / 4.0 * PF2 / PI2 * XPION0
18537         END IF
18538
18539         XPION0 = rrkk
18540
18541 clin-11/07/00: (pi eta) (rho omega) -> K* Kbar (or K*bar K) instead to K Kbar:
18542 c        XM1 = PIMASS
18543 c        XM2 = RHOM
18544 c        PF2 = (S - (XM1 + XM2) ** 2) * (S - (XM1 - XM2) ** 2)
18545 c        IF (PF2 .GT. 0.0) THEN
18546 c           XSK2 = 27.0 / 4.0 * PF2 / PI2 * XPION0
18547 c        END IF
18548
18549 c        XM1 = PIMASS
18550 c        XM2 = OMEGAM
18551 c        PF2 = (S - (XM1 + XM2) ** 2) * (S - (XM1 - XM2) ** 2)
18552 c        IF (PF2 .GT. 0.0) THEN
18553 c           XSK3 = 9.0 / 4.0 * PF2 / PI2 * XPION0
18554 c        END IF
18555
18556         XM1 = RHOM
18557         XM2 = RHOM
18558         PF2 = (S - (XM1 + XM2) ** 2) * (S - (XM1 - XM2) ** 2)
18559         IF (PF2 .GT. 0.0) THEN
18560            XSK5 = 81.0 / 4.0 * PF2 / PI2 * XPION0
18561         END IF
18562
18563         XM1 = RHOM
18564         XM2 = OMEGAM
18565         PF2 = (S - (XM1 + XM2) ** 2) * (S - (XM1 - XM2) ** 2)
18566         IF (PF2 .GT. 0.0) THEN
18567            XSK6 = 27.0 / 4.0 * PF2 / PI2 * XPION0
18568         END IF
18569
18570 c        XM1 = RHOM
18571 c        XM2 = ETAM
18572 c        PF2 = (S - (XM1 + XM2) ** 2) * (S - (XM1 - XM2) ** 2)
18573 c        IF (PF2 .GT. 0.0) THEN
18574 c           XSK7 = 9.0 / 4.0 * PF2 / PI2 * XPION0
18575 c        END IF
18576
18577         XM1 = OMEGAM
18578         XM2 = OMEGAM
18579         PF2 = (S - (XM1 + XM2) ** 2) * (S - (XM1 - XM2) ** 2)
18580         IF (PF2 .GT. 0.0) THEN
18581            XSK8 = 9.0 / 4.0 * PF2 / PI2 * XPION0
18582         END IF
18583
18584 c        XM1 = OMEGAM
18585 c        XM2 = ETAM
18586 c        PF2 = (S - (XM1 + XM2) ** 2) * (S - (XM1 - XM2) ** 2)
18587 c        IF (PF2 .GT. 0.0) THEN
18588 c           XSK9 = 3.0 / 4.0 * PF2 / PI2 * XPION0
18589 c        END IF
18590
18591 c* K+ + K- --> phi
18592           fwdp = 1.68*(aphi**2-4.*aka**2)**1.5/6./aphi/aphi
18593           pkaon=0.5*sqrt(srt**2-4.0*aka**2)
18594           XSK11 = 30.*3.14159*0.1973**2*(aphi*fwdp)**2/
18595      &             ((srt**2-aphi**2)**2+(aphi*fwdp)**2)/pkaon**2
18596 c
18597         SIGK = XSK1 + XSK2 + XSK3 + XSK4 + XSK5 +
18598      &     XSK6 + XSK7 + XSK8 + XSK9 + XSK10 + XSK11
18599
18600        RETURN
18601         END
18602 cbz3/9/99 kkbar end
18603
18604 *****************************
18605 * purpose: Xsection for Phi + B
18606        SUBROUTINE XphiB(LB1, LB2, EM1, EM2, SRT,
18607      &                  XSK1, XSK2, XSK3, XSK4, XSK5, SIGP)
18608 c
18609 * ***************************
18610         PARAMETER (MAXSTR=150001,MAXR=1,AMN=0.939457,
18611      1  AMP=0.93828,AP1=0.13496,AP2=0.13957,AM0=1.232,PI=3.1415926)
18612           PARAMETER (AKA=0.498, ALA = 1.1157, PIMASS=0.140, APHI=1.02)
18613         parameter (arho=0.77)
18614       SAVE
18615
18616        SIGP = 1.E-08
18617         XSK1 = 0.0
18618         XSK2 = 0.0
18619         XSK3 = 0.0
18620         XSK4 = 0.0
18621         XSK5 = 0.0
18622         XSK6 = 0.0
18623           srrt = srt - (em1+em2)
18624
18625 c* phi + N(D) -> elastic scattering
18626 c            XSK1 = 0.56  !! mb
18627 c  !! mb  (photo-production xsecn used)
18628             XSK1 = 8.00
18629 c
18630 c* phi + N(D) -> pi + N
18631         IF (srt  .GT. (ap1+amn)) THEN
18632              XSK2 = 0.0235*srrt**(-0.519)
18633         END IF
18634 c
18635 c* phi + N(D) -> pi + D
18636         IF (srt  .GT. (ap1+am0)) THEN
18637             if(srrt .lt. 0.7)then
18638              XSK3 = 0.0119*srrt**(-0.534)
18639             else
18640              XSK3 = 0.0130*srrt**(-0.304)
18641             endif
18642         END IF
18643 c
18644 c* phi + N(D) -> rho + N
18645         IF (srt  .GT. (arho+amn)) THEN
18646            if(srrt .lt. 0.7)then
18647              XSK4 = 0.0166*srrt**(-0.786)
18648             else
18649              XSK4 = 0.0189*srrt**(-0.277)
18650             endif
18651         END IF
18652 c
18653 c* phi + N(D) -> rho + D   (same as pi + D)
18654         IF (srt  .GT. (arho+am0)) THEN
18655             if(srrt .lt. 0.7)then
18656              XSK5 = 0.0119*srrt**(-0.534)
18657             else
18658              XSK5 = 0.0130*srrt**(-0.304)
18659             endif
18660         END IF
18661 c
18662 c* phi + N -> K+ + La
18663        IF( (lb1.ge.1.and.lb1.le.2) .or. (lb2.ge.1.and.lb2.le.2) )THEN
18664         IF (srt  .GT. (aka+ala)) THEN
18665            XSK6 = 1.715/((srrt+3.508)**2-12.138)
18666         END IF
18667        END IF
18668         SIGP = XSK1 + XSK2 + XSK3 + XSK4 + XSK5 + XSK6
18669        RETURN
18670         END
18671 c
18672 **********************************
18673 *
18674         SUBROUTINE CRPHIB(PX,PY,PZ,SRT,I1,I2,
18675      &     XSK1, XSK2, XSK3, XSK4, XSK5, SIGP, IBLOCK)
18676 *
18677 *     PURPOSE:                                                         *
18678 *             DEALING WITH PHI + N(D) --> pi+N(D), rho+N(D),  K+ + La
18679 *     QUANTITIES:                                                      *
18680 *           PX,PY,PZ - MOMENTUM COORDINATES OF ONE PARTICLE IN CM FRAME*
18681 *           SRT      - SQRT OF S                                       *
18682 *           IBLOCK   - INFORMATION about the reaction channel          *
18683 *
18684 *             iblock   - 20  elastic
18685 *             iblock   - 221  K+ formation
18686 *             iblock   - 223  others
18687 **********************************
18688         PARAMETER (MAXSTR=150001,MAXR=1,AMN=0.939457,
18689      1  AMP=0.93828,AP1=0.13496,AMRHO=0.769,AMOMGA=0.782,
18690      2  AP2=0.13957,AM0=1.232,PI=3.1415926,CUTOFF=1.8966,AVMASS=0.9383)
18691         PARAMETER      (AKA=0.498,ALA=1.1157,ASA=1.1974,ARHO=0.77)
18692         parameter     (MX=4,MY=4,MZ=8,MPX=4,MPY=4,mpz=10,mpzp=10)
18693         COMMON /AA/ R(3,MAXSTR)
18694 cc      SAVE /AA/
18695         COMMON /BB/ P(3,MAXSTR)
18696 cc      SAVE /BB/
18697         COMMON /CC/ E(MAXSTR)
18698 cc      SAVE /CC/
18699         COMMON /EE/ ID(MAXSTR),LB(MAXSTR)
18700 cc      SAVE /EE/
18701         common/input1/ MASSPR,MASSTA,ISEED,IAVOID,DT
18702 cc      SAVE /input1/
18703       COMMON/RNDF77/NSEED
18704 cc      SAVE /RNDF77/
18705       SAVE
18706 c
18707        PX0=PX
18708        PY0=PY
18709        PZ0=PZ
18710        IBLOCK=223
18711 c
18712         X1 = RANART(NSEED) * SIGP
18713         XSK2 = XSK1 + XSK2
18714         XSK3 = XSK2 + XSK3
18715         XSK4 = XSK3 + XSK4
18716         XSK5 = XSK4 + XSK5
18717 c
18718 c  !! elastic scatt.
18719         IF (X1 .LE. XSK1) THEN
18720            iblock=20
18721            GOTO 100
18722         ELSE IF (X1 .LE. XSK2) THEN
18723            LB(I1) = 3 + int(3 * RANART(NSEED))
18724            LB(I2) = 1 + int(2 * RANART(NSEED))
18725            E(I1) = AP1
18726            E(I2) = AMN
18727            GOTO 100
18728         ELSE IF (X1 .LE. XSK3) THEN
18729            LB(I1) = 3 + int(3 * RANART(NSEED))
18730            LB(I2) = 6 + int(4 * RANART(NSEED))
18731            E(I1) = AP1
18732            E(I2) = AM0
18733            GOTO 100
18734         ELSE IF (X1 .LE. XSK4) THEN
18735            LB(I1) = 25 + int(3 * RANART(NSEED))
18736            LB(I2) = 1 + int(2 * RANART(NSEED))
18737            E(I1) = ARHO
18738            E(I2) = AMN
18739            GOTO 100
18740         ELSE IF (X1 .LE. XSK5) THEN
18741            LB(I1) = 25 + int(3 * RANART(NSEED))
18742            LB(I2) = 6 + int(4 * RANART(NSEED))
18743            E(I1) = ARHO
18744            E(I2) = AM0
18745            GOTO 100
18746         ELSE
18747            LB(I1) = 23
18748            LB(I2) = 14
18749            E(I1) = AKA
18750            E(I2) = ALA
18751           IBLOCK=221
18752          ENDIF
18753  100    CONTINUE
18754       EM1=E(I1)
18755       EM2=E(I2)
18756 *-----------------------------------------------------------------------
18757 * CALCULATE THE MAGNITUDE OF THE FINAL MOMENTUM THROUGH
18758 * ENERGY CONSERVATION
18759           PR2   = (SRT**2 - EM1**2 - EM2**2)**2
18760      1                - 4.0 * (EM1*EM2)**2
18761           IF(PR2.LE.0.)PR2=1.E-08
18762           PR=SQRT(PR2)/(2.*SRT)
18763 * WE ASSUME AN ISOTROPIC ANGULAR DISTRIBUTION IN THE CMS
18764           C1   = 1.0 - 2.0 * RANART(NSEED)
18765           T1   = 2.0 * PI * RANART(NSEED)
18766       S1   = SQRT( 1.0 - C1**2 )
18767       CT1  = COS(T1)
18768       ST1  = SIN(T1)
18769 * THE MOMENTUM IN THE CMS IN THE FINAL STATE
18770       PZ   = PR * C1
18771       PX   = PR * S1*CT1
18772       PY   = PR * S1*ST1
18773 * ROTATE IT
18774        CALL ROTATE(PX0,PY0,PZ0,PX,PY,PZ)
18775       RETURN
18776       END
18777 c
18778 *****************************
18779 * purpose: Xsection for Phi + B
18780 c!! in fm^2
18781       SUBROUTINE pibphi(srt,lb1,lb2,em1,em2,Xphi,xphin)
18782 c
18783 *      phi + N(D) <- pi + N
18784 *      phi + N(D) <- pi + D
18785 *      phi + N(D) <- rho + N
18786 *      phi + N(D) <- rho + D   (same as pi + D)
18787 c
18788 * ***************************
18789         PARAMETER (MAXSTR=150001,MAXR=1,AMN=0.939457,
18790      1  AMP=0.93828,AP1=0.13496,AP2=0.13957,AM0=1.232,PI=3.1415926)
18791           PARAMETER (AKA=0.498, ALA = 1.1157, PIMASS=0.140, APHI=1.02)
18792         parameter (arho=0.77)
18793       SAVE
18794
18795        Xphi = 0.0
18796        xphin = 0.0
18797        xphid = 0.0
18798 c
18799        if( (lb1.ge.3.and.lb1.le.5) .or.
18800      &     (lb2.ge.3.and.lb2.le.5) )then
18801 c
18802        if( (iabs(lb1).ge.1.and.iabs(lb1).le.2) .or.
18803      &     (iabs(lb2).ge.1.and.iabs(lb2).le.2) )then
18804 c* phi + N <- pi + N
18805         IF (srt  .GT. (aphi+amn)) THEN
18806              srrt = srt - (aphi+amn)
18807              sig = 0.0235*srrt**(-0.519)
18808           xphin=sig*1.*(srt**2-(aphi+amn)**2)*
18809      &           (srt**2-(aphi-amn)**2)/(srt**2-(em1+em2)**2)/
18810      &           (srt**2-(em1-em2)**2)
18811         END IF
18812 c* phi + D <- pi + N
18813         IF (srt  .GT. (aphi+am0)) THEN
18814              srrt = srt - (aphi+am0)
18815              sig = 0.0235*srrt**(-0.519)
18816           xphid=sig*4.*(srt**2-(aphi+am0)**2)*
18817      &           (srt**2-(aphi-am0)**2)/(srt**2-(em1+em2)**2)/
18818      &           (srt**2-(em1-em2)**2)
18819         END IF
18820        else
18821 c* phi + N <- pi + D
18822         IF (srt  .GT. (aphi+amn)) THEN
18823              srrt = srt - (aphi+amn)
18824             if(srrt .lt. 0.7)then
18825              sig = 0.0119*srrt**(-0.534)
18826             else
18827              sig = 0.0130*srrt**(-0.304)
18828             endif
18829           xphin=sig*(1./4.)*(srt**2-(aphi+amn)**2)*
18830      &           (srt**2-(aphi-amn)**2)/(srt**2-(em1+em2)**2)/
18831      &           (srt**2-(em1-em2)**2)
18832         END IF
18833 c* phi + D <- pi + D
18834         IF (srt  .GT. (aphi+am0)) THEN
18835              srrt = srt - (aphi+am0)
18836              if(srrt .lt. 0.7)then
18837              sig = 0.0119*srrt**(-0.534)
18838             else
18839              sig = 0.0130*srrt**(-0.304)
18840             endif
18841           xphid=sig*1.*(srt**2-(aphi+am0)**2)*
18842      &           (srt**2-(aphi-am0)**2)/(srt**2-(em1+em2)**2)/
18843      &           (srt**2-(em1-em2)**2)
18844         END IF
18845        endif
18846 c
18847 c
18848 C** for rho + N(D) colln
18849 c
18850        else
18851 c
18852        if( (iabs(lb1).ge.1.and.iabs(lb1).le.2) .or.
18853      &     (iabs(lb2).ge.1.and.iabs(lb2).le.2) )then
18854 c
18855 c* phi + N <- rho + N
18856         IF (srt  .GT. (aphi+amn)) THEN
18857              srrt = srt - (aphi+amn)
18858            if(srrt .lt. 0.7)then
18859              sig = 0.0166*srrt**(-0.786)
18860             else
18861              sig = 0.0189*srrt**(-0.277)
18862             endif
18863           xphin=sig*(1./3.)*(srt**2-(aphi+amn)**2)*
18864      &           (srt**2-(aphi-amn)**2)/(srt**2-(em1+em2)**2)/
18865      &           (srt**2-(em1-em2)**2)
18866         END IF
18867 c* phi + D <- rho + N
18868         IF (srt  .GT. (aphi+am0)) THEN
18869              srrt = srt - (aphi+am0)
18870            if(srrt .lt. 0.7)then
18871              sig = 0.0166*srrt**(-0.786)
18872             else
18873              sig = 0.0189*srrt**(-0.277)
18874             endif
18875           xphid=sig*(4./3.)*(srt**2-(aphi+am0)**2)*
18876      &           (srt**2-(aphi-am0)**2)/(srt**2-(em1+em2)**2)/
18877      &           (srt**2-(em1-em2)**2)
18878         END IF
18879        else
18880 c* phi + N <- rho + D  (same as pi+D->phi+N)
18881         IF (srt  .GT. (aphi+amn)) THEN
18882              srrt = srt - (aphi+amn)
18883             if(srrt .lt. 0.7)then
18884              sig = 0.0119*srrt**(-0.534)
18885             else
18886              sig = 0.0130*srrt**(-0.304)
18887             endif
18888           xphin=sig*(1./12.)*(srt**2-(aphi+amn)**2)*
18889      &           (srt**2-(aphi-amn)**2)/(srt**2-(em1+em2)**2)/
18890      &           (srt**2-(em1-em2)**2)
18891         END IF
18892 c* phi + D <- rho + D  (same as pi+D->phi+D)
18893         IF (srt  .GT. (aphi+am0)) THEN
18894              srrt = srt - (aphi+am0)
18895              if(srrt .lt. 0.7)then
18896              sig = 0.0119*srrt**(-0.534)
18897             else
18898              sig = 0.0130*srrt**(-0.304)
18899             endif
18900           xphid=sig*(1./3.)*(srt**2-(aphi+am0)**2)*
18901      &           (srt**2-(aphi-am0)**2)/(srt**2-(em1+em2)**2)/
18902      &           (srt**2-(em1-em2)**2)
18903         END IF
18904        endif
18905         END IF
18906 c   !! in fm^2
18907          xphin = xphin/10.
18908 c   !! in fm^2
18909          xphid = xphid/10.
18910          Xphi = xphin + xphid
18911
18912        RETURN
18913         END
18914 c
18915 *****************************
18916 * purpose: Xsection for phi +M to K+K etc
18917       SUBROUTINE PHIMES(I1, I2, SRT, XSK1, XSK2, XSK3, XSK4, XSK5,
18918      1     XSK6, XSK7, SIGPHI)
18919
18920 *     QUANTITIES:                                                      *
18921 *           PX,PY,PZ - MOMENTUM COORDINATES OF ONE PARTICLE IN CM FRAME*
18922 *           SRT      - SQRT OF S                                       *
18923 *           IBLOCK   - THE INFORMATION BACK                            *
18924 *                      223 --> phi destruction
18925 *                      20 -->  elastic
18926 **********************************
18927         PARAMETER (MAXSTR=150001,MAXR=1,AMN=0.939457,
18928      1  AMP=0.93828,AP1=0.13496,
18929      2  AP2=0.13957,AM0=1.232,PI=3.1415926,CUTOFF=1.8966,AVMASS=0.9383)
18930         PARAMETER  (AKA=0.498, AKS=0.895, AOMEGA=0.7819,
18931      3               ARHO=0.77, APHI=1.02)
18932         parameter     (MX=4,MY=4,MZ=8,MPX=4,MPY=4,mpz=10,mpzp=10)
18933         PARAMETER  (MAXX=20,  MAXZ=24)
18934         COMMON /AA/ R(3,MAXSTR)
18935 cc      SAVE /AA/
18936         COMMON /BB/ P(3,MAXSTR)
18937 cc      SAVE /BB/
18938         COMMON /CC/ E(MAXSTR)
18939 cc      SAVE /CC/
18940       COMMON  /DD/      RHO(-MAXX:MAXX,-MAXX:MAXX,-MAXZ:MAXZ),
18941      &                     RHOP(-MAXX:MAXX,-MAXX:MAXX,-MAXZ:MAXZ),
18942      &                     RHON(-MAXX:MAXX,-MAXX:MAXX,-MAXZ:MAXZ)
18943 cc      SAVE /DD/
18944         COMMON /EE/ ID(MAXSTR),LB(MAXSTR)
18945 cc      SAVE /EE/
18946       SAVE
18947
18948         S = SRT ** 2
18949        SIGPHI = 1.E-08
18950         XSK1 = 0.0
18951         XSK2 = 0.0
18952         XSK3 = 0.0
18953         XSK4 = 0.0
18954         XSK5 = 0.0
18955         XSK6 = 0.0
18956         XSK7 = 0.0
18957          em1 = E(i1)
18958          em2 = E(i2)
18959          LB1 = LB(i1)
18960          LB2 = LB(i2)
18961          akap = aka
18962 c******
18963 c
18964 c   !! mb, elastic
18965          XSK1 = 5.0
18966
18967            pii = sqrt((S-(em1+em2)**2)*(S-(em1-em2)**2))
18968 * phi + K(-bar) channel
18969        if( lb1.eq.23.or.lb2.eq.23 .or. lb1.eq.21.or.lb2.eq.21 )then
18970           if(srt .gt. (ap1+akap))then
18971 c             XSK2 = 2.5
18972            pff = sqrt((S-(ap1+akap)**2)*(S-(ap1-akap)**2))
18973            XSK2 = 195.639*pff/pii/32./pi/S
18974           endif
18975           if(srt .gt. (arho+akap))then
18976 c              XSK3 = 3.5
18977            pff = sqrt((S-(arho+akap)**2)*(S-(arho-akap)**2))
18978            XSK3 = 526.702*pff/pii/32./pi/S
18979           endif
18980           if(srt .gt. (aomega+akap))then
18981 c               XSK4 = 3.5
18982            pff = sqrt((S-(aomega+akap)**2)*(S-(aomega-akap)**2))
18983            XSK4 = 355.429*pff/pii/32./pi/S
18984           endif
18985           if(srt .gt. (ap1+aks))then
18986 c           XSK5 = 15.0
18987            pff = sqrt((S-(ap1+aks)**2)*(S-(ap1-aks)**2))
18988            XSK5 = 2047.042*pff/pii/32./pi/S
18989           endif
18990           if(srt .gt. (arho+aks))then
18991 c            XSK6 = 3.5
18992            pff = sqrt((S-(arho+aks)**2)*(S-(arho-aks)**2))
18993            XSK6 = 1371.257*pff/pii/32./pi/S
18994           endif
18995           if(srt .gt. (aomega+aks))then
18996 c            XSK7 = 3.5
18997            pff = sqrt((S-(aomega+aks)**2)*(S-(aomega-aks)**2))
18998            XSK7 = 482.292*pff/pii/32./pi/S
18999           endif
19000 c
19001        elseif( iabs(lb1).eq.30.or.iabs(lb2).eq.30 )then
19002 * phi + K*(-bar) channel
19003 c
19004           if(srt .gt. (ap1+akap))then
19005 c             XSK2 = 3.5
19006            pff = sqrt((S-(ap1+akap)**2)*(S-(ap1-akap)**2))
19007            XSK2 = 372.378*pff/pii/32./pi/S
19008           endif
19009           if(srt .gt. (arho+akap))then
19010 c              XSK3 = 9.0
19011            pff = sqrt((S-(arho+akap)**2)*(S-(arho-akap)**2))
19012            XSK3 = 1313.960*pff/pii/32./pi/S
19013           endif
19014           if(srt .gt. (aomega+akap))then
19015 c               XSK4 = 6.5
19016            pff = sqrt((S-(aomega+akap)**2)*(S-(aomega-akap)**2))
19017            XSK4 = 440.558*pff/pii/32./pi/S
19018           endif
19019           if(srt .gt. (ap1+aks))then
19020 c           XSK5 = 30.0 !wrong
19021            pff = sqrt((S-(ap1+aks)**2)*(S-(ap1-aks)**2))
19022            XSK5 = 1496.692*pff/pii/32./pi/S
19023           endif
19024           if(srt .gt. (arho+aks))then
19025 c            XSK6 = 9.0
19026            pff = sqrt((S-(arho+aks)**2)*(S-(arho-aks)**2))
19027            XSK6 = 6999.840*pff/pii/32./pi/S
19028           endif
19029           if(srt .gt. (aomega+aks))then
19030 c            XSK7 = 15.0
19031            pff = sqrt((S-(aomega+aks)**2)*(S-(aomega-aks)**2))
19032            XSK7 = 1698.903*pff/pii/32./pi/S
19033           endif
19034        else
19035 c
19036 * phi + rho(pi,omega) channel
19037 c
19038            srr1 = em1+em2
19039          if(srt .gt. (akap+akap))then
19040           srrt = srt - srr1
19041 cc          if(srrt .lt. 0.3)then
19042           if(srrt .lt. 0.3 .and. srrt .gt. 0.01)then
19043           XSK2 = 1.69/(srrt**0.141 - 0.407)
19044           else
19045           XSK2 = 3.74 + 0.008*srrt**1.9
19046           endif
19047          endif
19048          if(srt .gt. (akap+aks))then
19049           srr2 = akap+aks
19050           srr = amax1(srr1,srr2)
19051           srrt = srt - srr
19052 cc          if(srrt .lt. 0.3)then
19053           if(srrt .lt. 0.3 .and. srrt .gt. 0.01)then
19054           XSK3 = 1.69/(srrt**0.141 - 0.407)
19055           else
19056           XSK3 = 3.74 + 0.008*srrt**1.9
19057           endif
19058          endif
19059          if(srt .gt. (aks+aks))then
19060           srr2 = aks+aks
19061           srr = amax1(srr1,srr2)
19062           srrt = srt - srr
19063 cc          if(srrt .lt. 0.3)then
19064           if(srrt .lt. 0.3 .and. srrt .gt. 0.01)then
19065           XSK4 = 1.69/(srrt**0.141 - 0.407)
19066           else
19067           XSK4 = 3.74 + 0.008*srrt**1.9
19068           endif
19069          endif
19070 c          xsk2 = amin1(20.,xsk2)
19071 c          xsk3 = amin1(20.,xsk3)
19072 c          xsk4 = amin1(20.,xsk4)
19073       endif
19074
19075         SIGPHI = XSK1 + XSK2 + XSK3 + XSK4 + XSK5 + XSK6 + XSK7
19076
19077        RETURN
19078        END
19079
19080 **********************************
19081 *     PURPOSE:                                                         *
19082 *             DEALING WITH phi+M  scatt.
19083 *
19084        SUBROUTINE CRPHIM(PX,PY,PZ,SRT,I1,I2,
19085      &  XSK1, XSK2, XSK3, XSK4, XSK5, XSK6, SIGPHI, IKKG, IKKL, IBLOCK)
19086 *
19087 *     QUANTITIES:                                                      *
19088 *           PX,PY,PZ - MOMENTUM COORDINATES OF ONE PARTICLE IN CM FRAME*
19089 *           SRT      - SQRT OF S                                       *
19090 *           IBLOCK   - THE INFORMATION BACK                            *
19091 *                      20 -->  elastic
19092 *                      223 --> phi + pi(rho,omega)
19093 *                      224 --> phi + K -> K + pi(rho,omega)
19094 *                      225 --> phi + K -> K* + pi(rho,omega)
19095 *                      226 --> phi + K* -> K + pi(rho,omega)
19096 *                      227 --> phi + K* -> K* + pi(rho,omega)
19097 **********************************
19098         PARAMETER (MAXSTR=150001,MAXR=1,AMN=0.939457,
19099      1  AMP=0.93828,AP1=0.13496,ARHO=0.77,AOMEGA=0.7819,
19100      2  AP2=0.13957,AM0=1.232,PI=3.1415926,CUTOFF=1.8966,AVMASS=0.9383)
19101         PARAMETER    (AKA=0.498,AKS=0.895)
19102         parameter   (MX=4,MY=4,MZ=8,MPX=4,MPY=4,mpz=10,mpzp=10)
19103         COMMON /AA/ R(3,MAXSTR)
19104 cc      SAVE /AA/
19105         COMMON /BB/ P(3,MAXSTR)
19106 cc      SAVE /BB/
19107         COMMON /CC/ E(MAXSTR)
19108 cc      SAVE /CC/
19109         COMMON /EE/ ID(MAXSTR),LB(MAXSTR)
19110 cc      SAVE /EE/
19111         common/input1/ MASSPR,MASSTA,ISEED,IAVOID,DT
19112 cc      SAVE /input1/
19113       COMMON/RNDF77/NSEED
19114 cc      SAVE /RNDF77/
19115       SAVE
19116 c
19117        PX0=PX
19118        PY0=PY
19119        PZ0=PZ
19120          LB1 = LB(i1)
19121          LB2 = LB(i2)
19122
19123         X1 = RANART(NSEED) * SIGPHI
19124         XSK2 = XSK1 + XSK2
19125         XSK3 = XSK2 + XSK3
19126         XSK4 = XSK3 + XSK4
19127         XSK5 = XSK4 + XSK5
19128         XSK6 = XSK5 + XSK6
19129         IF (X1 .LE. XSK1) THEN
19130 c        !! elastic scatt
19131            IBLOCK=20
19132            GOTO 100
19133         ELSE
19134 c
19135 *phi + (K,K*)-bar
19136        if( lb1.eq.23.or.lb1.eq.21.or.iabs(lb1).eq.30 .OR.
19137      &     lb2.eq.23.or.lb2.eq.21.or.iabs(lb2).eq.30 )then
19138 c
19139              if(lb1.eq.23.or.lb2.eq.23)then
19140                IKKL=1
19141                IBLOCK=224
19142                iad1 = 23
19143                iad2 = 30
19144               elseif(lb1.eq.30.or.lb2.eq.30)then
19145                IKKL=0
19146                IBLOCK=226
19147                iad1 = 23
19148                iad2 = 30
19149              elseif(lb1.eq.21.or.lb2.eq.21)then
19150                IKKL=1
19151                IBLOCK=124
19152                iad1 = 21
19153                iad2 = -30
19154 c         !! -30
19155              else
19156                IKKL=0
19157                IBLOCK=126
19158                iad1 = 21
19159                iad2 = -30
19160               endif
19161          IF (X1 .LE. XSK2) THEN
19162            LB(I1) = 3 + int(3 * RANART(NSEED))
19163            LB(I2) = iad1
19164            E(I1) = AP1
19165            E(I2) = AKA
19166            IKKG = 1
19167            GOTO 100
19168         ELSE IF (X1 .LE. XSK3) THEN
19169            LB(I1) = 25 + int(3 * RANART(NSEED))
19170            LB(I2) = iad1
19171            E(I1) = ARHO
19172            E(I2) = AKA
19173            IKKG = 1
19174            GOTO 100
19175         ELSE IF (X1 .LE. XSK4) THEN
19176            LB(I1) = 28
19177            LB(I2) = iad1
19178            E(I1) = AOMEGA
19179            E(I2) = AKA
19180            IKKG = 1
19181            GOTO 100
19182         ELSE IF (X1 .LE. XSK5) THEN
19183            LB(I1) = 3 + int(3 * RANART(NSEED))
19184            LB(I2) = iad2
19185            E(I1) = AP1
19186            E(I2) = AKS
19187            IKKG = 0
19188            IBLOCK=IBLOCK+1
19189            GOTO 100
19190         ELSE IF (X1 .LE. XSK6) THEN
19191            LB(I1) = 25 + int(3 * RANART(NSEED))
19192            LB(I2) = iad2
19193            E(I1) = ARHO
19194            E(I2) = AKS
19195            IKKG = 0
19196            IBLOCK=IBLOCK+1
19197            GOTO 100
19198         ELSE
19199            LB(I1) = 28
19200            LB(I2) = iad2
19201            E(I1) = AOMEGA
19202            E(I2) = AKS
19203            IKKG = 0
19204            IBLOCK=IBLOCK+1
19205            GOTO 100
19206          ENDIF
19207        else
19208 c      !! phi destruction via (pi,rho,omega)
19209           IBLOCK=223
19210 *phi + pi(rho,omega)
19211          IF (X1 .LE. XSK2) THEN
19212            LB(I1) = 23
19213            LB(I2) = 21
19214            E(I1) = AKA
19215            E(I2) = AKA
19216            IKKG = 2
19217            IKKL = 0
19218            GOTO 100
19219         ELSE IF (X1 .LE. XSK3) THEN
19220            LB(I1) = 23
19221 c           LB(I2) = 30
19222            LB(I2) = -30
19223 clin-2/10/03 currently take XSK3 to be the sum of KK*bar & KbarK*:
19224            if(RANART(NSEED).le.0.5) then
19225               LB(I1) = 21
19226               LB(I2) = 30
19227            endif
19228
19229            E(I1) = AKA
19230            E(I2) = AKS
19231            IKKG = 1
19232            IKKL = 0
19233            GOTO 100
19234         ELSE IF (X1 .LE. XSK4) THEN
19235            LB(I1) = 30
19236 c           LB(I2) = 30
19237            LB(I2) = -30
19238            E(I1) = AKS
19239            E(I2) = AKS
19240            IKKG = 0
19241            IKKL = 0
19242            GOTO 100
19243          ENDIF
19244        endif
19245          ENDIF
19246 *
19247 100    CONTINUE
19248        EM1=E(I1)
19249        EM2=E(I2)
19250
19251 *-----------------------------------------------------------------------
19252 * CALCULATE THE MAGNITUDE OF THE FINAL MOMENTUM THROUGH
19253 * ENERGY CONSERVATION
19254           PR2   = (SRT**2 - EM1**2 - EM2**2)**2
19255      1                - 4.0 * (EM1*EM2)**2
19256           IF(PR2.LE.0.)PR2=1.E-08
19257           PR=SQRT(PR2)/(2.*SRT)
19258 * WE ASSUME AN ISOTROPIC ANGULAR DISTRIBUTION IN THE CMS
19259           C1   = 1.0 - 2.0 * RANART(NSEED)
19260           T1   = 2.0 * PI * RANART(NSEED)
19261       S1   = SQRT( 1.0 - C1**2 )
19262       CT1  = COS(T1)
19263       ST1  = SIN(T1)
19264 * THE MOMENTUM IN THE CMS IN THE FINAL STATE
19265       PZ   = PR * C1
19266       PX   = PR * S1*CT1
19267       PY   = PR * S1*ST1
19268 * ROTATE IT
19269        CALL ROTATE(PX0,PY0,PZ0,PX,PY,PZ)
19270       RETURN
19271       END
19272 **********************************
19273 **********************************
19274 cbz3/9/99 khyperon
19275 *************************************
19276 * purpose: Xsection for K+Y ->  piN                                       *
19277 *          Xsection for K+Y-bar ->  piN-bar   !! sp03/29/01               *
19278 *
19279         SUBROUTINE XKHYPE(I1, I2, SRT, XKY1, XKY2, XKY3, XKY4, XKY5,
19280      &     XKY6, XKY7, XKY8, XKY9, XKY10, XKY11, XKY12, XKY13,
19281      &     XKY14, XKY15, XKY16, XKY17, SIGK)
19282 c      subroutine xkhype(i1, i2, srt, sigk)
19283 *  srt    = DSQRT(s) in GeV                                               *
19284 *  xkkpi   = xsection in mb obtained from                                 *
19285 *           the detailed balance                                          *
19286 * ***********************************
19287         PARAMETER (MAXSTR=150001,MAXR=1,AMN=0.939457,
19288      1  AMP=0.93828,AP1=0.13496,AMRHO=0.769,AMOMGA=0.782,APHI=1.02,
19289      2  AP2=0.13957,AM0=1.232,PI=3.1415926,CUTOFF=1.8966,AVMASS=0.9383)
19290           parameter (pimass=0.140, AMETA = 0.5473, aka=0.498,
19291      &     aml=1.116,ams=1.193, AM1440 = 1.44, AM1535 = 1.535)
19292         COMMON  /EE/ID(MAXSTR), LB(MAXSTR)
19293 cc      SAVE /EE/
19294       SAVE
19295
19296         S = SRT ** 2
19297        SIGK=1.E-08
19298         XKY1 = 0.0
19299         XKY2 = 0.0
19300         XKY3 = 0.0
19301         XKY4 = 0.0
19302         XKY5 = 0.0
19303         XKY6 = 0.0
19304         XKY7 = 0.0
19305         XKY8 = 0.0
19306         XKY9 = 0.0
19307         XKY10 = 0.0
19308         XKY11 = 0.0
19309         XKY12 = 0.0
19310         XKY13 = 0.0
19311         XKY14 = 0.0
19312         XKY15 = 0.0
19313         XKY16 = 0.0
19314         XKY17 = 0.0
19315
19316         LB1 = LB(I1)
19317         LB2 = LB(I2)
19318         IF (iabs(LB1) .EQ. 14 .OR. iabs(LB2) .EQ. 14) THEN
19319            XKAON0 = PNLKA(SRT)
19320            XKAON0 = 2.0 * XKAON0
19321            PI2 = (S - (AML + AKA) ** 2) * (S - (AML - AKA) ** 2)
19322         ELSE
19323            XKAON0 = PNSKA(SRT)
19324            XKAON0 = 2.0 * XKAON0
19325            PI2 = (S - (AMS + AKA) ** 2) * (S - (AMS - AKA) ** 2)
19326         END IF
19327           if(PI2 .le. 0.0)return
19328
19329         XM1 = PIMASS
19330         XM2 = AMP
19331         PF2 = (S - (XM1 + XM2) ** 2) * (S - (XM1 - XM2) ** 2)
19332         IF (PF2 .GT. 0.0) THEN
19333            XKY1 = 3.0 * PF2 / PI2 * XKAON0
19334         END IF
19335
19336         XM1 = PIMASS
19337         XM2 = AM0
19338         PF2 = (S - (XM1 + XM2) ** 2) * (S - (XM1 - XM2) ** 2)
19339         IF (PF2 .GT. 0.0) THEN
19340            XKY2 = 12.0 * PF2 / PI2 * XKAON0
19341         END IF
19342
19343         XM1 = PIMASS
19344         XM2 = AM1440
19345         PF2 = (S - (XM1 + XM2) ** 2) * (S - (XM1 - XM2) ** 2)
19346         IF (PF2 .GT. 0.0) THEN
19347            XKY3 = 3.0 * PF2 / PI2 * XKAON0
19348         END IF
19349
19350         XM1 = PIMASS
19351         XM2 = AM1535
19352         PF2 = (S - (XM1 + XM2) ** 2) * (S - (XM1 - XM2) ** 2)
19353         IF (PF2 .GT. 0.0) THEN
19354            XKY4 = 3.0 * PF2 / PI2 * XKAON0
19355         END IF
19356
19357         XM1 = AMRHO
19358         XM2 = AMP
19359         PF2 = (S - (XM1 + XM2) ** 2) * (S - (XM1 - XM2) ** 2)
19360         IF (PF2 .GT. 0.0) THEN
19361            XKY5 = 9.0 * PF2 / PI2 * XKAON0
19362         END IF
19363
19364         XM1 = AMRHO
19365         XM2 = AM0
19366         PF2 = (S - (XM1 + XM2) ** 2) * (S - (XM1 - XM2) ** 2)
19367         IF (PF2 .GT. 0.0) THEN
19368            XKY6 = 36.0 * PF2 / PI2 * XKAON0
19369         END IF
19370
19371         XM1 = AMRHO
19372         XM2 = AM1440
19373         PF2 = (S - (XM1 + XM2) ** 2) * (S - (XM1 - XM2) ** 2)
19374         IF (PF2 .GT. 0.0) THEN
19375            XKY7 = 9.0 * PF2 / PI2 * XKAON0
19376         END IF
19377
19378         XM1 = AMRHO
19379         XM2 = AM1535
19380         PF2 = (S - (XM1 + XM2) ** 2) * (S - (XM1 - XM2) ** 2)
19381         IF (PF2 .GT. 0.0) THEN
19382            XKY8 = 9.0 * PF2 / PI2 * XKAON0
19383         END IF
19384
19385         XM1 = AMOMGA
19386         XM2 = AMP
19387         PF2 = (S - (XM1 + XM2) ** 2) * (S - (XM1 - XM2) ** 2)
19388         IF (PF2 .GT. 0.0) THEN
19389            XKY9 = 3.0 * PF2 / PI2 * XKAON0
19390         END IF
19391
19392         XM1 = AMOMGA
19393         XM2 = AM0
19394         PF2 = (S - (XM1 + XM2) ** 2) * (S - (XM1 - XM2) ** 2)
19395         IF (PF2 .GT. 0.0) THEN
19396            XKY10 = 12.0 * PF2 / PI2 * XKAON0
19397         END IF
19398
19399         XM1 = AMOMGA
19400         XM2 = AM1440
19401         PF2 = (S - (XM1 + XM2) ** 2) * (S - (XM1 - XM2) ** 2)
19402         IF (PF2 .GT. 0.0) THEN
19403            XKY11 = 3.0 * PF2 / PI2 * XKAON0
19404         END IF
19405
19406         XM1 = AMOMGA
19407         XM2 = AM1535
19408         PF2 = (S - (XM1 + XM2) ** 2) * (S - (XM1 - XM2) ** 2)
19409         IF (PF2 .GT. 0.0) THEN
19410            XKY12 = 3.0 * PF2 / PI2 * XKAON0
19411         END IF
19412
19413         XM1 = AMETA
19414         XM2 = AMP
19415         PF2 = (S - (XM1 + XM2) ** 2) * (S - (XM1 - XM2) ** 2)
19416         IF (PF2 .GT. 0.0) THEN
19417            XKY13 = 1.0 * PF2 / PI2 * XKAON0
19418         END IF
19419
19420         XM1 = AMETA
19421         XM2 = AM0
19422         PF2 = (S - (XM1 + XM2) ** 2) * (S - (XM1 - XM2) ** 2)
19423         IF (PF2 .GT. 0.0) THEN
19424            XKY14 = 4.0 * PF2 / PI2 * XKAON0
19425         END IF
19426
19427         XM1 = AMETA
19428         XM2 = AM1440
19429         PF2 = (S - (XM1 + XM2) ** 2) * (S - (XM1 - XM2) ** 2)
19430         IF (PF2 .GT. 0.0) THEN
19431            XKY15 = 1.0 * PF2 / PI2 * XKAON0
19432         END IF
19433
19434         XM1 = AMETA
19435         XM2 = AM1535
19436         PF2 = (S - (XM1 + XM2) ** 2) * (S - (XM1 - XM2) ** 2)
19437         IF (PF2 .GT. 0.0) THEN
19438            XKY16 = 1.0 * PF2 / PI2 * XKAON0
19439         END IF
19440
19441 csp11/21/01  K+ + La --> phi + N
19442         if(lb1.eq.14 .or. lb2.eq.14)then
19443          if(srt .gt. (aphi+amn))then
19444            srrt = srt - (aphi+amn)
19445            sig = 1.715/((srrt+3.508)**2-12.138)
19446          XM1 = AMN
19447          XM2 = APHI
19448          PF2 = (S - (XM1 + XM2) ** 2) * (S - (XM1 - XM2) ** 2)
19449 c     ! fm^-1
19450          XKY17 = 3.0 * PF2 / PI2 * SIG/10.
19451         endif
19452        endif
19453 csp11/21/01  end
19454 c
19455
19456        IF ((iabs(LB1) .GE. 15 .AND. iabs(LB1) .LE. 17) .OR.
19457      &     (iabs(LB2) .GE. 15 .AND. iabs(LB2) .LE. 17)) THEN
19458            DDF = 3.0
19459            XKY1 = XKY1 / DDF
19460            XKY2 = XKY2 / DDF
19461            XKY3 = XKY3 / DDF
19462            XKY4 = XKY4 / DDF
19463            XKY5 = XKY5 / DDF
19464            XKY6 = XKY6 / DDF
19465            XKY7 = XKY7 / DDF
19466            XKY8 = XKY8 / DDF
19467            XKY9 = XKY9 / DDF
19468            XKY10 = XKY10/ DDF
19469            XKY11 = XKY11 / DDF
19470            XKY12 = XKY12 / DDF
19471            XKY13 = XKY13 / DDF
19472            XKY14 = XKY14 / DDF
19473            XKY15 = XKY15 / DDF
19474            XKY16 = XKY16 / DDF
19475         END IF
19476
19477         SIGK = XKY1 + XKY2 + XKY3 + XKY4 +
19478      &       XKY5 + XKY6 + XKY7 + XKY8 +
19479      &       XKY9 + XKY10 + XKY11 + XKY12 +
19480      &       XKY13 + XKY14 + XKY15 + XKY16 + XKY17
19481
19482        RETURN
19483        END
19484
19485 C*******************************
19486       BLOCK DATA PPBDAT
19487
19488       parameter (AMP=0.93828,AMN=0.939457,
19489      1     AM0=1.232,AM1440 = 1.44, AM1535 = 1.535)
19490
19491 c     to give default values to parameters for BbarB production from mesons
19492       COMMON/ppbmas/niso(15),nstate,ppbm(15,2),thresh(15),weight(15)
19493 cc      SAVE /ppbmas/
19494       common/ppb1/ene,factr2(6),fsum,ppinnb,s,wtot
19495 cc      SAVE /ppb1/
19496       common/ppmm/pprr,ppee,pppe,rpre,xopoe,rree
19497 cc      SAVE /ppmm/
19498       SAVE
19499 c     thresh(i) gives the mass thresh for final channel i:
19500       DATA thresh/1.87656,1.877737,1.878914,2.17028,
19501      1     2.171457,2.37828,2.379457,2.464,2.47328,2.474457,
19502      2     2.672,2.767,2.88,2.975,3.07/
19503 c     ppbm(i,j=1,2) gives masses for the two final baryons of channel i,
19504 c     with j=1 for the lighter baryon:
19505       DATA (ppbm(i,1),i=1,15)/amp,amp,amn,amp,amn,amp,amn,
19506      1     am0,amp,amn,am0,am0,am1440,am1440,am1535/
19507       DATA (ppbm(i,2),i=1,15)/amp,amn,amn,am0,am0,am1440,am1440,
19508      1     am0,am1535,am1535,am1440,am1535,am1440,am1535,am1535/
19509 c     factr2(i) gives weights for producing i pions from ppbar annihilation:
19510       DATA factr2/0,1,1.17e-01,3.27e-03,3.58e-05,1.93e-07/
19511 c     niso(i) gives the degeneracy factor for final channel i:
19512       DATA niso/1,2,1,16,16,4,4,64,4,4,32,32,4,8,4/
19513
19514       END
19515
19516
19517 *****************************************
19518 * get the number of BbarB states available for mm collisions of energy srt
19519       subroutine getnst(srt)
19520 *  srt    = DSQRT(s) in GeV                                                   *
19521 *****************************************
19522       parameter (pimass=0.140,pi=3.1415926)
19523       COMMON/ppbmas/niso(15),nstate,ppbm(15,2),thresh(15),weight(15)
19524 cc      SAVE /ppbmas/
19525       common/ppb1/ene,factr2(6),fsum,ppinnb,s,wtot
19526 cc      SAVE /ppb1/
19527       common/ppmm/pprr,ppee,pppe,rpre,xopoe,rree
19528 cc      SAVE /ppmm/
19529       SAVE
19530
19531       s=srt**2
19532       nstate=0
19533       wtot=0.
19534       if(srt.le.thresh(1)) return
19535       do 1001 i=1,15
19536          weight(i)=0.
19537          if(srt.gt.thresh(i)) nstate=i
19538  1001 continue
19539       do 1002 i=1,nstate
19540          pf2=(s-(ppbm(i,1)+ppbm(i,2))**2)
19541      1        *(s-(ppbm(i,1)-ppbm(i,2))**2)/4/s
19542          weight(i)=pf2*niso(i)
19543          wtot=wtot+weight(i)
19544  1002 continue
19545       ene=(srt/pimass)**3/(6.*pi**2)
19546       fsum=factr2(2)+factr2(3)*ene+factr2(4)*ene**2
19547      1     +factr2(5)*ene**3+factr2(6)*ene**4
19548
19549       return
19550       END
19551
19552 *****************************************
19553 * for pion+pion-->Bbar B                                                      *
19554 c      real*4 function ppbbar(srt)
19555       real function ppbbar(srt)
19556 *****************************************
19557       parameter (pimass=0.140,arho=0.77,aomega=0.782)
19558       common/ppb1/ene,factr2(6),fsum,ppinnb,s,wtot
19559 cc      SAVE /ppb1/
19560       common/ppmm/pprr,ppee,pppe,rpre,xopoe,rree
19561 cc      SAVE /ppmm/
19562       SAVE
19563
19564       sppb2p=xppbar(srt)*factr2(2)/fsum
19565       pi2=(s-4*pimass**2)/4
19566       ppbbar=4./9.*sppb2p/pi2*wtot
19567
19568       return
19569       END
19570
19571 *****************************************
19572 * for pion+rho-->Bbar B                                                      *
19573 c      real*4 function prbbar(srt)
19574       real function prbbar(srt)
19575 *****************************************
19576       parameter (pimass=0.140,arho=0.77,aomega=0.782)
19577       common/ppb1/ene,factr2(6),fsum,ppinnb,s,wtot
19578 cc      SAVE /ppb1/
19579       common/ppmm/pprr,ppee,pppe,rpre,xopoe,rree
19580 cc      SAVE /ppmm/
19581       SAVE
19582
19583       sppb3p=xppbar(srt)*factr2(3)*ene/fsum
19584       pi2=(s-(pimass+arho)**2)*(s-(pimass-arho)**2)/4/s
19585       prbbar=4./27.*sppb3p/pi2*wtot
19586
19587       return
19588       END
19589
19590 *****************************************
19591 * for rho+rho-->Bbar B                                                      *
19592 c      real*4 function rrbbar(srt)
19593       real function rrbbar(srt)
19594 *****************************************
19595       parameter (pimass=0.140,arho=0.77,aomega=0.782)
19596       common/ppb1/ene,factr2(6),fsum,ppinnb,s,wtot
19597 cc      SAVE /ppb1/
19598       common/ppmm/pprr,ppee,pppe,rpre,xopoe,rree
19599 cc      SAVE /ppmm/
19600       SAVE
19601
19602       sppb4p=xppbar(srt)*factr2(4)*ene**2/fsum
19603       pi2=(s-4*arho**2)/4
19604       rrbbar=4./81.*(sppb4p/2)/pi2*wtot
19605
19606       return
19607       END
19608
19609 *****************************************
19610 * for pi+omega-->Bbar B                                                      *
19611 c      real*4 function pobbar(srt)
19612       real function pobbar(srt)
19613 *****************************************
19614       parameter (pimass=0.140,arho=0.77,aomega=0.782)
19615       common/ppb1/ene,factr2(6),fsum,ppinnb,s,wtot
19616 cc      SAVE /ppb1/
19617       common/ppmm/pprr,ppee,pppe,rpre,xopoe,rree
19618 cc      SAVE /ppmm/
19619       SAVE
19620
19621       sppb4p=xppbar(srt)*factr2(4)*ene**2/fsum
19622       pi2=(s-(pimass+aomega)**2)*(s-(pimass-aomega)**2)/4/s
19623       pobbar=4./9.*(sppb4p/2)/pi2*wtot
19624
19625       return
19626       END
19627
19628 *****************************************
19629 * for rho+omega-->Bbar B                                                      *
19630 c      real*4 function robbar(srt)
19631       real function robbar(srt)
19632 *****************************************
19633       parameter (pimass=0.140,arho=0.77,aomega=0.782)
19634       common/ppb1/ene,factr2(6),fsum,ppinnb,s,wtot
19635 cc      SAVE /ppb1/
19636       common/ppmm/pprr,ppee,pppe,rpre,xopoe,rree
19637 cc      SAVE /ppmm/
19638       SAVE
19639
19640       sppb5p=xppbar(srt)*factr2(5)*ene**3/fsum
19641       pi2=(s-(arho+aomega)**2)*(s-(arho-aomega)**2)/4/s
19642       robbar=4./27.*sppb5p/pi2*wtot
19643
19644       return
19645       END
19646
19647 *****************************************
19648 * for omega+omega-->Bbar B                                                    *
19649 c      real*4 function oobbar(srt)
19650       real function oobbar(srt)
19651 *****************************************
19652       parameter (pimass=0.140,arho=0.77,aomega=0.782)
19653       common/ppb1/ene,factr2(6),fsum,ppinnb,s,wtot
19654 cc      SAVE /ppb1/
19655       common/ppmm/pprr,ppee,pppe,rpre,xopoe,rree
19656 cc      SAVE /ppmm/
19657       SAVE
19658
19659       sppb6p=xppbar(srt)*factr2(6)*ene**4/fsum
19660       pi2=(s-4*aomega**2)/4
19661       oobbar=4./9.*sppb6p/pi2*wtot
19662
19663       return
19664       END
19665
19666 *****************************************
19667 * Generate final states for mm-->Bbar B                                       *
19668       SUBROUTINE bbarfs(lbb1,lbb2,ei1,ei2,iblock,iseed)
19669 *****************************************
19670       COMMON/ppbmas/niso(15),nstate,ppbm(15,2),thresh(15),weight(15)
19671 cc      SAVE /ppbmas/
19672       common/ppb1/ene,factr2(6),fsum,ppinnb,s,wtot
19673 cc      SAVE /ppb1/
19674       common/ppmm/pprr,ppee,pppe,rpre,xopoe,rree
19675 cc      SAVE /ppmm/
19676       COMMON/RNDF77/NSEED
19677 cc      SAVE /RNDF77/
19678       SAVE
19679       ISEED=ISEED
19680 c     determine which final BbarB channel occurs:
19681       rd=RANART(NSEED)
19682       wsum=0.
19683       do 1001 i=1,nstate
19684          wsum=wsum+weight(i)
19685          if(rd.le.(wsum/wtot)) then
19686             ifs=i
19687             ei1=ppbm(i,1)
19688             ei2=ppbm(i,2)
19689             goto 10
19690          endif
19691  1001 continue
19692  10   continue
19693
19694 c1    pbar p
19695       if(ifs.eq.1) then
19696          iblock=1801
19697          lbb1=-1
19698          lbb2=1
19699       elseif(ifs.eq.2) then
19700 c2    pbar n
19701          if(RANART(NSEED).le.0.5) then
19702             iblock=18021
19703             lbb1=-1
19704             lbb2=2
19705 c2    nbar p
19706          else
19707             iblock=18022
19708             lbb1=1
19709             lbb2=-2
19710          endif
19711 c3    nbar n
19712       elseif(ifs.eq.3) then
19713          iblock=1803
19714          lbb1=-2
19715          lbb2=2
19716 c4&5  (pbar nbar) Delta, (p n) anti-Delta
19717       elseif(ifs.eq.4.or.ifs.eq.5) then
19718          rd=RANART(NSEED)
19719          if(rd.le.0.5) then
19720 c     (pbar nbar) Delta
19721             if(ifs.eq.4) then
19722                iblock=18041
19723                lbb1=-1
19724             else
19725                iblock=18051
19726                lbb1=-2
19727             endif
19728             rd2=RANART(NSEED)
19729             if(rd2.le.0.25) then
19730                lbb2=6
19731             elseif(rd2.le.0.5) then
19732                lbb2=7
19733             elseif(rd2.le.0.75) then
19734                lbb2=8
19735             else
19736                lbb2=9
19737             endif
19738          else
19739 c     (p n) anti-Delta
19740             if(ifs.eq.4) then
19741                iblock=18042
19742                lbb1=1
19743             else
19744                iblock=18052
19745                lbb1=2
19746             endif
19747             rd2=RANART(NSEED)
19748             if(rd2.le.0.25) then
19749                lbb2=-6
19750             elseif(rd2.le.0.5) then
19751                lbb2=-7
19752             elseif(rd2.le.0.75) then
19753                lbb2=-8
19754             else
19755                lbb2=-9
19756             endif
19757          endif
19758 c6&7  (pbar nbar) N*(1440), (p n) anti-N*(1440)
19759       elseif(ifs.eq.6.or.ifs.eq.7) then
19760          rd=RANART(NSEED)
19761          if(rd.le.0.5) then
19762 c     (pbar nbar) N*(1440)
19763             if(ifs.eq.6) then
19764                iblock=18061
19765                lbb1=-1
19766             else
19767                iblock=18071
19768                lbb1=-2
19769             endif
19770             rd2=RANART(NSEED)
19771             if(rd2.le.0.5) then
19772                lbb2=10
19773             else
19774                lbb2=11
19775             endif
19776          else
19777 c     (p n) anti-N*(1440)
19778             if(ifs.eq.6) then
19779                iblock=18062
19780                lbb1=1
19781             else
19782                iblock=18072
19783                lbb1=2
19784             endif
19785             rd2=RANART(NSEED)
19786             if(rd2.le.0.5) then
19787                lbb2=-10
19788             else
19789                lbb2=-11
19790             endif
19791          endif
19792 c8    Delta anti-Delta
19793       elseif(ifs.eq.8) then
19794          iblock=1808
19795          rd1=RANART(NSEED)
19796          if(rd1.le.0.25) then
19797             lbb1=6
19798          elseif(rd1.le.0.5) then
19799             lbb1=7
19800          elseif(rd1.le.0.75) then
19801             lbb1=8
19802          else
19803             lbb1=9
19804          endif
19805          rd2=RANART(NSEED)
19806          if(rd2.le.0.25) then
19807             lbb2=-6
19808          elseif(rd2.le.0.5) then
19809             lbb2=-7
19810          elseif(rd2.le.0.75) then
19811             lbb2=-8
19812          else
19813             lbb2=-9
19814          endif
19815 c9&10 (pbar nbar) N*(1535), (p n) anti-N*(1535)
19816       elseif(ifs.eq.9.or.ifs.eq.10) then
19817          rd=RANART(NSEED)
19818          if(rd.le.0.5) then
19819 c     (pbar nbar) N*(1440)
19820             if(ifs.eq.9) then
19821                iblock=18091
19822                lbb1=-1
19823             else
19824                iblock=18101
19825                lbb1=-2
19826             endif
19827             rd2=RANART(NSEED)
19828             if(rd2.le.0.5) then
19829                lbb2=12
19830             else
19831                lbb2=13
19832             endif
19833          else
19834 c     (p n) anti-N*(1535)
19835             if(ifs.eq.9) then
19836                iblock=18092
19837                lbb1=1
19838             else
19839                iblock=18102
19840                lbb1=2
19841             endif
19842             rd2=RANART(NSEED)
19843             if(rd2.le.0.5) then
19844                lbb2=-12
19845             else
19846                lbb2=-13
19847             endif
19848          endif
19849 c11&12 anti-Delta N*, Delta anti-N*
19850       elseif(ifs.eq.11.or.ifs.eq.12) then
19851          rd=RANART(NSEED)
19852          if(rd.le.0.5) then
19853 c     anti-Delta N*
19854             rd1=RANART(NSEED)
19855             if(rd1.le.0.25) then
19856                lbb1=-6
19857             elseif(rd1.le.0.5) then
19858                lbb1=-7
19859             elseif(rd1.le.0.75) then
19860                lbb1=-8
19861             else
19862                lbb1=-9
19863             endif
19864             if(ifs.eq.11) then
19865                iblock=18111
19866                rd2=RANART(NSEED)
19867                if(rd2.le.0.5) then
19868                   lbb2=10
19869                else
19870                   lbb2=11
19871                endif
19872             else
19873                iblock=18121
19874                rd2=RANART(NSEED)
19875                if(rd2.le.0.5) then
19876                   lbb2=12
19877                else
19878                   lbb2=13
19879                endif
19880             endif
19881          else
19882 c     Delta anti-N*
19883             rd1=RANART(NSEED)
19884             if(rd1.le.0.25) then
19885                lbb1=6
19886             elseif(rd1.le.0.5) then
19887                lbb1=7
19888             elseif(rd1.le.0.75) then
19889                lbb1=8
19890             else
19891                lbb1=9
19892             endif
19893             if(ifs.eq.11) then
19894                iblock=18112
19895                rd2=RANART(NSEED)
19896                if(rd2.le.0.5) then
19897                   lbb2=-10
19898                else
19899                   lbb2=-11
19900                endif
19901             else
19902                iblock=18122
19903                rd2=RANART(NSEED)
19904                if(rd2.le.0.5) then
19905                   lbb2=-12
19906                else
19907                   lbb2=-13
19908                endif
19909             endif
19910          endif
19911 c13   N*(1440) anti-N*(1440)
19912       elseif(ifs.eq.13) then
19913          iblock=1813
19914          rd1=RANART(NSEED)
19915          if(rd1.le.0.5) then
19916             lbb1=10
19917          else
19918             lbb1=11
19919          endif
19920          rd2=RANART(NSEED)
19921          if(rd2.le.0.5) then
19922             lbb2=-10
19923          else
19924             lbb2=-11
19925          endif
19926 c14   anti-N*(1440) N*(1535), N*(1440) anti-N*(1535)
19927       elseif(ifs.eq.14) then
19928          rd=RANART(NSEED)
19929          if(rd.le.0.5) then
19930 c     anti-N*(1440) N*(1535)
19931             iblock=18141
19932             rd1=RANART(NSEED)
19933             if(rd1.le.0.5) then
19934                lbb1=-10
19935             else
19936                lbb1=-11
19937             endif
19938             rd2=RANART(NSEED)
19939             if(rd2.le.0.5) then
19940                lbb2=12
19941             else
19942                lbb2=13
19943             endif
19944          else
19945 c     N*(1440) anti-N*(1535)
19946             iblock=18142
19947             rd1=RANART(NSEED)
19948             if(rd1.le.0.5) then
19949                lbb1=10
19950             else
19951                lbb1=11
19952             endif
19953             rd2=RANART(NSEED)
19954             if(rd2.le.0.5) then
19955                lbb2=-12
19956             else
19957                lbb2=-13
19958             endif
19959          endif
19960 c15   N*(1535) anti-N*(1535)
19961       elseif(ifs.eq.15) then
19962          iblock=1815
19963          rd1=RANART(NSEED)
19964          if(rd1.le.0.5) then
19965             lbb1=12
19966          else
19967             lbb1=13
19968          endif
19969          rd2=RANART(NSEED)
19970          if(rd2.le.0.5) then
19971             lbb2=-12
19972          else
19973             lbb2=-13
19974          endif
19975       else
19976       endif
19977
19978       RETURN
19979       END
19980
19981 *****************************************
19982 * for pi pi <-> rho rho cross sections
19983         SUBROUTINE spprr(lb1,lb2,srt)
19984         parameter (arho=0.77)
19985       common/ppb1/ene,factr2(6),fsum,ppinnb,s,wtot
19986 cc      SAVE /ppb1/
19987       common/ppmm/pprr,ppee,pppe,rpre,xopoe,rree
19988 cc      SAVE /ppmm/
19989       SAVE
19990
19991         pprr=0.
19992         if((lb1.ge.3.and.lb1.le.5).and.(lb2.ge.3.and.lb2.le.5)) then
19993 c     for now, rho mass taken to be the central value in these two processes
19994            if(srt.gt.(2*arho)) pprr=ptor(srt)
19995         elseif((lb1.ge.25.and.lb1.le.27).and.(lb2.ge.25.and.lb2.le.27))
19996      1          then
19997            pprr=rtop(srt)
19998         endif
19999 c
20000         return
20001         END
20002
20003 *****************************************
20004 * for pi pi -> rho rho, determined from detailed balance
20005       real function ptor(srt)
20006 *****************************************
20007       parameter (pimass=0.140,arho=0.77)
20008       common/ppb1/ene,factr2(6),fsum,ppinnb,s,wtot
20009 cc      SAVE /ppb1/
20010       common/ppmm/pprr,ppee,pppe,rpre,xopoe,rree
20011 cc      SAVE /ppmm/
20012       SAVE
20013
20014       s2=srt**2
20015       ptor=9*(s2-4*arho**2)/(s2-4*pimass**2)*rtop(srt)
20016
20017       return
20018       END
20019
20020 *****************************************
20021 * for rho rho -> pi pi, assumed a constant cross section (in mb)
20022       real function rtop(srt)
20023 *****************************************
20024       srt=srt
20025       rtop=5.
20026       return
20027       END
20028
20029 *****************************************
20030 * for pi pi <-> rho rho final states
20031       SUBROUTINE pi2ro2(i1,i2,lbb1,lbb2,ei1,ei2,iblock,iseed)
20032       PARAMETER (MAXSTR=150001)
20033       PARAMETER (AP1=0.13496,AP2=0.13957)
20034       COMMON /EE/ ID(MAXSTR),LB(MAXSTR)
20035 cc      SAVE /EE/
20036       common/ppb1/ene,factr2(6),fsum,ppinnb,s,wtot
20037 cc      SAVE /ppb1/
20038       common/ppmm/pprr,ppee,pppe,rpre,xopoe,rree
20039 cc      SAVE /ppmm/
20040       COMMON/RNDF77/NSEED
20041 cc      SAVE /RNDF77/
20042       SAVE
20043       iseed=iseed
20044       if((lb(i1).ge.3.and.lb(i1).le.5)
20045      1     .and.(lb(i2).ge.3.and.lb(i2).le.5)) then
20046          iblock=1850
20047          ei1=0.77
20048          ei2=0.77
20049 c     for now, we don't check isospin states(allowing pi+pi+ & pi0pi0 -> 2rho)
20050 c     thus the cross sections used are considered as the isospin-averaged ones.
20051          lbb1=25+int(3*RANART(NSEED))
20052          lbb2=25+int(3*RANART(NSEED))
20053       elseif((lb(i1).ge.25.and.lb(i1).le.27)
20054      1     .and.(lb(i2).ge.25.and.lb(i2).le.27)) then
20055          iblock=1851
20056          lbb1=3+int(3*RANART(NSEED))
20057          lbb2=3+int(3*RANART(NSEED))
20058          ei1=ap2
20059          ei2=ap2
20060          if(lbb1.eq.4) ei1=ap1
20061          if(lbb2.eq.4) ei2=ap1
20062       endif
20063
20064       return
20065       END
20066
20067 *****************************************
20068 * for pi pi <-> eta eta cross sections
20069         SUBROUTINE sppee(lb1,lb2,srt)
20070         parameter (ETAM=0.5475)
20071       common/ppb1/ene,factr2(6),fsum,ppinnb,s,wtot
20072 cc      SAVE /ppb1/
20073       common/ppmm/pprr,ppee,pppe,rpre,xopoe,rree
20074 cc      SAVE /ppmm/
20075       SAVE
20076
20077         ppee=0.
20078         if((lb1.ge.3.and.lb1.le.5).and.(lb2.ge.3.and.lb2.le.5)) then
20079            if(srt.gt.(2*ETAM)) ppee=ptoe(srt)
20080         elseif(lb1.eq.0.and.lb2.eq.0) then
20081            ppee=etop(srt)
20082         endif
20083
20084         return
20085         END
20086
20087 *****************************************
20088 * for pi pi -> eta eta, determined from detailed balance, spin-isospin averaged
20089       real function ptoe(srt)
20090 *****************************************
20091       parameter (pimass=0.140,ETAM=0.5475)
20092       common/ppb1/ene,factr2(6),fsum,ppinnb,s,wtot
20093 cc      SAVE /ppb1/
20094       common/ppmm/pprr,ppee,pppe,rpre,xopoe,rree
20095 cc      SAVE /ppmm/
20096       SAVE
20097
20098       s2=srt**2
20099       ptoe=1./9.*(s2-4*etam**2)/(s2-4*pimass**2)*etop(srt)
20100
20101       return
20102       END
20103 *****************************************
20104 * for eta eta -> pi pi, assumed a constant cross section (in mb)
20105       real function etop(srt)
20106 *****************************************
20107       srt=srt
20108 c     eta equilibration:
20109 c     most important channel is found to be pi pi <-> pi eta, then
20110 c     rho pi <-> rho eta.
20111       etop=5.
20112       return
20113       END
20114
20115 *****************************************
20116 * for pi pi <-> eta eta final states
20117       SUBROUTINE pi2et2(i1,i2,lbb1,lbb2,ei1,ei2,iblock,iseed)
20118       PARAMETER (MAXSTR=150001)
20119       PARAMETER (AP1=0.13496,AP2=0.13957,ETAM=0.5475)
20120       COMMON /EE/ ID(MAXSTR),LB(MAXSTR)
20121 cc      SAVE /EE/
20122       common/ppb1/ene,factr2(6),fsum,ppinnb,s,wtot
20123 cc      SAVE /ppb1/
20124       common/ppmm/pprr,ppee,pppe,rpre,xopoe,rree
20125 cc      SAVE /ppmm/
20126       COMMON/RNDF77/NSEED
20127 cc      SAVE /RNDF77/
20128       SAVE
20129
20130       iseed=iseed
20131       if((lb(i1).ge.3.and.lb(i1).le.5)
20132      1     .and.(lb(i2).ge.3.and.lb(i2).le.5)) then
20133          iblock=1860
20134          ei1=etam
20135          ei2=etam
20136 c     for now, we don't check isospin states(allowing pi+pi+ & pi0pi0 -> 2rho)
20137 c     thus the cross sections used are considered as the isospin-averaged ones.
20138          lbb1=0
20139          lbb2=0
20140       elseif(lb(i1).eq.0.and.lb(i2).eq.0) then
20141          iblock=1861
20142          lbb1=3+int(3*RANART(NSEED))
20143          lbb2=3+int(3*RANART(NSEED))
20144          ei1=ap2
20145          ei2=ap2
20146          if(lbb1.eq.4) ei1=ap1
20147          if(lbb2.eq.4) ei2=ap1
20148       endif
20149
20150       return
20151       END
20152
20153 *****************************************
20154 * for pi pi <-> pi eta cross sections
20155         SUBROUTINE spppe(lb1,lb2,srt)
20156         parameter (pimass=0.140,ETAM=0.5475)
20157       common/ppb1/ene,factr2(6),fsum,ppinnb,s,wtot
20158 cc      SAVE /ppb1/
20159       common/ppmm/pprr,ppee,pppe,rpre,xopoe,rree
20160 cc      SAVE /ppmm/
20161       SAVE
20162
20163         pppe=0.
20164         if((lb1.ge.3.and.lb1.le.5).and.(lb2.ge.3.and.lb2.le.5)) then
20165            if(srt.gt.(ETAM+pimass)) pppe=pptope(srt)
20166         elseif((lb1.ge.3.and.lb1.le.5).and.lb2.eq.0) then
20167            pppe=petopp(srt)
20168         elseif((lb2.ge.3.and.lb2.le.5).and.lb1.eq.0) then
20169            pppe=petopp(srt)
20170         endif
20171
20172         return
20173         END
20174
20175 *****************************************
20176 * for pi pi -> pi eta, determined from detailed balance, spin-isospin averaged
20177       real function pptope(srt)
20178 *****************************************
20179       parameter (pimass=0.140,ETAM=0.5475)
20180       common/ppb1/ene,factr2(6),fsum,ppinnb,s,wtot
20181 cc      SAVE /ppb1/
20182       common/ppmm/pprr,ppee,pppe,rpre,xopoe,rree
20183 cc      SAVE /ppmm/
20184       SAVE
20185
20186       s2=srt**2
20187       pf2=(s2-(pimass+ETAM)**2)*(s2-(pimass-ETAM)**2)/2/sqrt(s2)
20188       pi2=(s2-4*pimass**2)*s2/2/sqrt(s2)
20189       pptope=1./3.*pf2/pi2*petopp(srt)
20190
20191       return
20192       END
20193 *****************************************
20194 * for pi eta -> pi pi, assumed a constant cross section (in mb)
20195       real function petopp(srt)
20196 *****************************************
20197       srt=srt
20198 c     eta equilibration:
20199       petopp=5.
20200       return
20201       END
20202
20203 *****************************************
20204 * for pi pi <-> pi eta final states
20205       SUBROUTINE pi3eta(i1,i2,lbb1,lbb2,ei1,ei2,iblock,iseed)
20206       PARAMETER (MAXSTR=150001)
20207       PARAMETER (AP1=0.13496,AP2=0.13957,ETAM=0.5475)
20208       COMMON /EE/ ID(MAXSTR),LB(MAXSTR)
20209 cc      SAVE /EE/
20210       common/ppb1/ene,factr2(6),fsum,ppinnb,s,wtot
20211 cc      SAVE /ppb1/
20212       common/ppmm/pprr,ppee,pppe,rpre,xopoe,rree
20213 cc      SAVE /ppmm/
20214       COMMON/RNDF77/NSEED
20215 cc      SAVE /RNDF77/
20216       SAVE
20217
20218       ISEED=ISEED
20219       if((lb(i1).ge.3.and.lb(i1).le.5)
20220      1     .and.(lb(i2).ge.3.and.lb(i2).le.5)) then
20221          iblock=1870
20222          ei1=ap2
20223          ei2=etam
20224 c     for now, we don't check isospin states(allowing pi+pi+ & pi0pi0 -> 2rho)
20225 c     thus the cross sections used are considered as the isospin-averaged ones.
20226          lbb1=3+int(3*RANART(NSEED))
20227          if(lbb1.eq.4) ei1=ap1
20228          lbb2=0
20229       elseif((lb(i1).ge.3.and.lb(i1).le.5.and.lb(i2).eq.0).or.
20230      1        (lb(i2).ge.3.and.lb(i2).le.5.and.lb(i1).eq.0)) then
20231          iblock=1871
20232          lbb1=3+int(3*RANART(NSEED))
20233          lbb2=3+int(3*RANART(NSEED))
20234          ei1=ap2
20235          ei2=ap2
20236          if(lbb1.eq.4) ei1=ap1
20237          if(lbb2.eq.4) ei2=ap1
20238       endif
20239
20240       return
20241       END
20242
20243 *****************************************
20244 * for rho pi <-> rho eta cross sections
20245         SUBROUTINE srpre(lb1,lb2,srt)
20246         parameter (pimass=0.140,ETAM=0.5475,arho=0.77)
20247         common/ppb1/ene,factr2(6),fsum,ppinnb,s,wtot
20248 cc      SAVE /ppb1/
20249         common/ppmm/pprr,ppee,pppe,rpre,xopoe,rree
20250 cc      SAVE /ppmm/
20251       SAVE
20252
20253         rpre=0.
20254         if(lb1.ge.25.and.lb1.le.27.and.lb2.ge.3.and.lb2.le.5) then
20255            if(srt.gt.(ETAM+arho)) rpre=rptore(srt)
20256         elseif(lb2.ge.25.and.lb2.le.27.and.lb1.ge.3.and.lb1.le.5) then
20257            if(srt.gt.(ETAM+arho)) rpre=rptore(srt)
20258         elseif(lb1.ge.25.and.lb1.le.27.and.lb2.eq.0) then
20259            if(srt.gt.(pimass+arho)) rpre=retorp(srt)
20260         elseif(lb2.ge.25.and.lb2.le.27.and.lb1.eq.0) then
20261            if(srt.gt.(pimass+arho)) rpre=retorp(srt)
20262         endif
20263
20264         return
20265         END
20266
20267 *****************************************
20268 * for rho pi->rho eta, determined from detailed balance, spin-isospin averaged
20269       real function rptore(srt)
20270 *****************************************
20271       parameter (pimass=0.140,ETAM=0.5475,arho=0.77)
20272       common/ppb1/ene,factr2(6),fsum,ppinnb,s,wtot
20273 cc      SAVE /ppb1/
20274       common/ppmm/pprr,ppee,pppe,rpre,xopoe,rree
20275 cc      SAVE /ppmm/
20276       SAVE
20277
20278       s2=srt**2
20279       pf2=(s2-(arho+ETAM)**2)*(s2-(arho-ETAM)**2)/2/sqrt(s2)
20280       pi2=(s2-(arho+pimass)**2)*(s2-(arho-pimass)**2)/2/sqrt(s2)
20281       rptore=1./3.*pf2/pi2*retorp(srt)
20282
20283       return
20284       END
20285 *****************************************
20286 * for rho eta -> rho pi, assumed a constant cross section (in mb)
20287       real function retorp(srt)
20288 *****************************************
20289       srt=srt
20290 c     eta equilibration:
20291       retorp=5.
20292       return
20293       END
20294
20295 *****************************************
20296 * for rho pi <-> rho eta final states
20297       SUBROUTINE rpiret(i1,i2,lbb1,lbb2,ei1,ei2,iblock,iseed)
20298       PARAMETER (MAXSTR=150001)
20299       PARAMETER (AP1=0.13496,AP2=0.13957,ETAM=0.5475,arho=0.77)
20300       COMMON /EE/ ID(MAXSTR),LB(MAXSTR)
20301 cc      SAVE /EE/
20302       common/ppb1/ene,factr2(6),fsum,ppinnb,s,wtot
20303 cc      SAVE /ppb1/
20304       common/ppmm/pprr,ppee,pppe,rpre,xopoe,rree
20305 cc      SAVE /ppmm/
20306       COMMON/RNDF77/NSEED
20307 cc      SAVE /RNDF77/
20308       SAVE
20309       ISEED=ISEED
20310       if((lb(i1).ge.25.and.lb(i1).le.27
20311      1     .and.lb(i2).ge.3.and.lb(i2).le.5).or.
20312      2     (lb(i1).ge.3.and.lb(i1).le.5
20313      3     .and.lb(i2).ge.25.and.lb(i2).le.27)) then
20314          iblock=1880
20315          ei1=arho
20316          ei2=etam
20317 c     for now, we don't check isospin states(allowing pi+pi+ & pi0pi0 -> 2rho)
20318 c     thus the cross sections used are considered as the isospin-averaged ones.
20319          lbb1=25+int(3*RANART(NSEED))
20320          lbb2=0
20321       elseif((lb(i1).ge.25.and.lb(i1).le.27.and.lb(i2).eq.0).or.
20322      1        (lb(i2).ge.25.and.lb(i2).le.27.and.lb(i1).eq.0)) then
20323          iblock=1881
20324          lbb1=25+int(3*RANART(NSEED))
20325          lbb2=3+int(3*RANART(NSEED))
20326          ei1=arho
20327          ei2=ap2
20328          if(lbb2.eq.4) ei2=ap1
20329       endif
20330
20331       return
20332       END
20333
20334 *****************************************
20335 * for omega pi <-> omega eta cross sections
20336         SUBROUTINE sopoe(lb1,lb2,srt)
20337         parameter (ETAM=0.5475,aomega=0.782)
20338       common/ppb1/ene,factr2(6),fsum,ppinnb,s,wtot
20339 cc      SAVE /ppb1/
20340       common/ppmm/pprr,ppee,pppe,rpre,xopoe,rree
20341 cc      SAVE /ppmm/
20342       SAVE
20343
20344         xopoe=0.
20345         if((lb1.eq.28.and.lb2.ge.3.and.lb2.le.5).or.
20346      1       (lb2.eq.28.and.lb1.ge.3.and.lb1.le.5)) then
20347            if(srt.gt.(aomega+ETAM)) xopoe=xop2oe(srt)
20348         elseif((lb1.eq.28.and.lb2.eq.0).or.
20349      1          (lb1.eq.0.and.lb2.eq.28)) then
20350            if(srt.gt.(aomega+ETAM)) xopoe=xoe2op(srt)
20351         endif
20352
20353         return
20354         END
20355
20356 *****************************************
20357 * for omega pi -> omega eta,
20358 c     determined from detailed balance, spin-isospin averaged
20359       real function xop2oe(srt)
20360 *****************************************
20361       parameter (pimass=0.140,ETAM=0.5475,aomega=0.782)
20362       common/ppb1/ene,factr2(6),fsum,ppinnb,s,wtot
20363 cc      SAVE /ppb1/
20364       common/ppmm/pprr,ppee,pppe,rpre,xopoe,rree
20365 cc      SAVE /ppmm/
20366       SAVE
20367
20368       s2=srt**2
20369       pf2=(s2-(aomega+ETAM)**2)*(s2-(aomega-ETAM)**2)/2/sqrt(s2)
20370       pi2=(s2-(aomega+pimass)**2)*(s2-(aomega-pimass)**2)/2/sqrt(s2)
20371       xop2oe=1./3.*pf2/pi2*xoe2op(srt)
20372
20373       return
20374       END
20375 *****************************************
20376 * for omega eta -> omega pi, assumed a constant cross section (in mb)
20377       real function xoe2op(srt)
20378 *****************************************
20379       srt=srt
20380 c     eta equilibration:
20381       xoe2op=5.
20382       return
20383       END
20384
20385 *****************************************
20386 * for omega pi <-> omega eta final states
20387       SUBROUTINE opioet(i1,i2,lbb1,lbb2,ei1,ei2,iblock,iseed)
20388       PARAMETER (MAXSTR=150001)
20389       PARAMETER (AP1=0.13496,AP2=0.13957,ETAM=0.5475,aomega=0.782)
20390       COMMON /EE/ ID(MAXSTR),LB(MAXSTR)
20391 cc      SAVE /EE/
20392       common/ppb1/ene,factr2(6),fsum,ppinnb,s,wtot
20393 cc      SAVE /ppb1/
20394       common/ppmm/pprr,ppee,pppe,rpre,xopoe,rree
20395 cc      SAVE /ppmm/
20396       COMMON/RNDF77/NSEED
20397 cc      SAVE /RNDF77/
20398       SAVE
20399
20400       iseed=iseed
20401       if((lb(i1).ge.3.and.lb(i1).le.5.and.lb(i2).eq.28).or.
20402      1     (lb(i2).ge.3.and.lb(i2).le.5.and.lb(i1).eq.28)) then
20403          iblock=1890
20404          ei1=aomega
20405          ei2=etam
20406 c     for now, we don't check isospin states(allowing pi+pi+ & pi0pi0 -> 2rho)
20407 c     thus the cross sections used are considered as the isospin-averaged ones.
20408          lbb1=28
20409          lbb2=0
20410       elseif((lb(i1).eq.28.and.lb(i2).eq.0).or.
20411      1        (lb(i1).eq.0.and.lb(i2).eq.28)) then
20412          iblock=1891
20413          lbb1=28
20414          lbb2=3+int(3*RANART(NSEED))
20415          ei1=aomega
20416          ei2=ap2
20417          if(lbb2.eq.4) ei2=ap1
20418       endif
20419
20420       return
20421       END
20422
20423 *****************************************
20424 * for rho rho <-> eta eta cross sections
20425         SUBROUTINE srree(lb1,lb2,srt)
20426         parameter (ETAM=0.5475,arho=0.77)
20427       common/ppb1/ene,factr2(6),fsum,ppinnb,s,wtot
20428 cc      SAVE /ppb1/
20429       common/ppmm/pprr,ppee,pppe,rpre,xopoe,rree
20430 cc      SAVE /ppmm/
20431       SAVE
20432
20433         rree=0.
20434         if(lb1.ge.25.and.lb1.le.27.and.
20435      1       lb2.ge.25.and.lb2.le.27) then
20436            if(srt.gt.(2*ETAM)) rree=rrtoee(srt)
20437         elseif(lb1.eq.0.and.lb2.eq.0) then
20438            if(srt.gt.(2*arho)) rree=eetorr(srt)
20439         endif
20440
20441         return
20442         END
20443
20444 *****************************************
20445 * for eta eta -> rho rho
20446 c     determined from detailed balance, spin-isospin averaged
20447       real function eetorr(srt)
20448 *****************************************
20449       parameter (ETAM=0.5475,arho=0.77)
20450       common/ppb1/ene,factr2(6),fsum,ppinnb,s,wtot
20451 cc      SAVE /ppb1/
20452       common/ppmm/pprr,ppee,pppe,rpre,xopoe,rree
20453 cc      SAVE /ppmm/
20454       SAVE
20455
20456       s2=srt**2
20457       eetorr=81.*(s2-4*arho**2)/(s2-4*etam**2)*rrtoee(srt)
20458
20459       return
20460       END
20461 *****************************************
20462 * for rho rho -> eta eta, assumed a constant cross section (in mb)
20463       real function rrtoee(srt)
20464 *****************************************
20465       srt=srt
20466 c     eta equilibration:
20467       rrtoee=5.
20468       return
20469       END
20470
20471 *****************************************
20472 * for rho rho <-> eta eta final states
20473       SUBROUTINE ro2et2(i1,i2,lbb1,lbb2,ei1,ei2,iblock,iseed)
20474       PARAMETER (MAXSTR=150001)
20475       parameter (ETAM=0.5475,arho=0.77)
20476       COMMON /EE/ ID(MAXSTR),LB(MAXSTR)
20477 cc      SAVE /EE/
20478       common/ppb1/ene,factr2(6),fsum,ppinnb,s,wtot
20479 cc      SAVE /ppb1/
20480       common/ppmm/pprr,ppee,pppe,rpre,xopoe,rree
20481 cc      SAVE /ppmm/
20482       COMMON/RNDF77/NSEED
20483 cc      SAVE /RNDF77/
20484       SAVE
20485
20486       ISEED=ISEED
20487       if(lb(i1).ge.25.and.lb(i1).le.27.and.
20488      1     lb(i2).ge.25.and.lb(i2).le.27) then
20489          iblock=1895
20490          ei1=etam
20491          ei2=etam
20492 c     for now, we don't check isospin states(allowing pi+pi+ & pi0pi0 -> 2rho)
20493 c     thus the cross sections used are considered as the isospin-averaged ones.
20494          lbb1=0
20495          lbb2=0
20496       elseif(lb(i1).eq.0.and.lb(i2).eq.0) then
20497          iblock=1896
20498          lbb1=25+int(3*RANART(NSEED))
20499          lbb2=25+int(3*RANART(NSEED))
20500          ei1=arho
20501          ei2=arho
20502       endif
20503
20504       return
20505       END
20506
20507 *****************************
20508 * purpose: Xsection for K* Kbar or K*bar K to pi(eta) rho(omega)
20509       SUBROUTINE XKKSAN(i1,i2,SRT,SIGKS1,SIGKS2,SIGKS3,SIGKS4,SIGK,prkk)
20510 *  srt    = DSQRT(s) in GeV                                       *
20511 *  sigk   = xsection in mb obtained from                          *
20512 *           the detailed balance                                  *
20513 * ***************************
20514           PARAMETER (AKA=0.498, PIMASS=0.140, RHOM = 0.770,aks=0.895,
20515      & OMEGAM = 0.7819, ETAM = 0.5473)
20516       PARAMETER (MAXSTR=150001)
20517       COMMON  /CC/      E(MAXSTR)
20518 cc      SAVE /CC/
20519       SAVE
20520
20521         S = SRT ** 2
20522        SIGKS1 = 1.E-08
20523        SIGKS2 = 1.E-08
20524        SIGKS3 = 1.E-08
20525        SIGKS4 = 1.E-08
20526
20527         XPION0 = prkk
20528 clin note that prkk is for pi (rho omega) -> K* Kbar (AND!) K*bar K:
20529         XPION0 = XPION0/2
20530
20531 cc
20532 c        PI2 = (S - (aks + AKA) ** 2) * (S - (aks - AKA) ** 2)
20533         PI2 = (S - (e(i1) + e(i2)) ** 2) * (S - (e(i1) - e(i2)) ** 2)
20534         SIGK = 1.E-08
20535         if(PI2 .le. 0.0) return
20536
20537         XM1 = PIMASS
20538         XM2 = RHOM
20539         PF2 = (S - (XM1 + XM2) ** 2) * (S - (XM1 - XM2) ** 2)
20540         IF (PI2 .GT. 0.0 .AND. PF2 .GT. 0.0) THEN
20541            SIGKS1 = 27.0 / 4.0 * PF2 / PI2 * XPION0
20542         END IF
20543
20544         XM1 = PIMASS
20545         XM2 = OMEGAM
20546         PF2 = (S - (XM1 + XM2) ** 2) * (S - (XM1 - XM2) ** 2)
20547         IF (PI2 .GT. 0.0 .AND. PF2 .GT. 0.0) THEN
20548            SIGKS2 = 9.0 / 4.0 * PF2 / PI2 * XPION0
20549         END IF
20550
20551         XM1 = RHOM
20552         XM2 = ETAM
20553         PF2 = (S - (XM1 + XM2) ** 2) * (S - (XM1 - XM2) ** 2)
20554         IF (PF2 .GT. 0.0) THEN
20555            SIGKS3 = 9.0 / 4.0 * PF2 / PI2 * XPION0
20556         END IF
20557
20558         XM1 = OMEGAM
20559         XM2 = ETAM
20560         PF2 = (S - (XM1 + XM2) ** 2) * (S - (XM1 - XM2) ** 2)
20561         IF (PF2 .GT. 0.0) THEN
20562            SIGKS4 = 3.0 / 4.0 * PF2 / PI2 * XPION0
20563         END IF
20564
20565         SIGK=SIGKS1+SIGKS2+SIGKS3+SIGKS4
20566
20567        RETURN
20568         END
20569
20570 **********************************
20571 *     PURPOSE:                                                         *
20572 *     assign final states for KK*bar or K*Kbar --> light mesons
20573 *
20574 c      SUBROUTINE Crkspi(PX,PY,PZ,SRT,I1,I2,IBLOCK)
20575       SUBROUTINE crkspi(I1,I2,XSK1, XSK2, XSK3, XSK4, SIGK,
20576      & IBLOCK,lbp1,lbp2,emm1,emm2)
20577 *             iblock   - 466
20578 **********************************
20579         PARAMETER (MAXSTR=150001,MAXR=1)
20580           PARAMETER (AP1=0.13496,AP2=0.13957,RHOM = 0.770,PI=3.1415926)
20581         PARAMETER (AETA=0.548,AMOMGA=0.782)
20582         parameter (MX=4,MY=4,MZ=8,MPX=4,MPY=4,mpz=10,mpzp=10)
20583         COMMON /AA/ R(3,MAXSTR)
20584 cc      SAVE /AA/
20585         COMMON /BB/ P(3,MAXSTR)
20586 cc      SAVE /BB/
20587         COMMON /CC/ E(MAXSTR)
20588 cc      SAVE /CC/
20589         COMMON /EE/ ID(MAXSTR),LB(MAXSTR)
20590 cc      SAVE /EE/
20591         common/input1/ MASSPR,MASSTA,ISEED,IAVOID,DT
20592 cc      SAVE /input1/
20593       COMMON/RNDF77/NSEED
20594 cc      SAVE /RNDF77/
20595       SAVE
20596
20597        IBLOCK=466
20598 * charges of final state mesons:
20599
20600         X1 = RANART(NSEED) * SIGK
20601         XSK2 = XSK1 + XSK2
20602         XSK3 = XSK2 + XSK3
20603         XSK4 = XSK3 + XSK4
20604         IF (X1 .LE. XSK1) THEN
20605            LB(I1) = 3 + int(3 * RANART(NSEED))
20606            LB(I2) = 25 + int(3 * RANART(NSEED))
20607            E(I1) = AP2
20608            E(I2) = rhom
20609         ELSE IF (X1 .LE. XSK2) THEN
20610            LB(I1) = 3 + int(3 * RANART(NSEED))
20611            LB(I2) = 28
20612            E(I1) = AP2
20613            E(I2) = AMOMGA
20614         ELSE IF (X1 .LE. XSK3) THEN
20615            LB(I1) = 0
20616            LB(I2) = 25 + int(3 * RANART(NSEED))
20617            E(I1) = AETA
20618            E(I2) = rhom
20619         ELSE
20620            LB(I1) = 0
20621            LB(I2) = 28
20622            E(I1) = AETA
20623            E(I2) = AMOMGA
20624         ENDIF
20625
20626         if(lb(i1).eq.4) E(I1) = AP1
20627         lbp1=lb(i1)
20628         lbp2=lb(i2)
20629         emm1=e(i1)
20630         emm2=e(i2)
20631
20632       RETURN
20633       END
20634
20635 *---------------------------------------------------------------------------
20636 * PURPOSE : CALCULATE THE MASS AND MOMENTUM OF K* RESONANCE
20637 *           AFTER PION + KAON COLLISION
20638 *clin only here the K* mass may be different from aks=0.895
20639         SUBROUTINE KSRESO(I1,I2)
20640         PARAMETER (MAXSTR=150001,MAXR=1,
20641      1  AMN=0.939457,AMP=0.93828,
20642      2  AP1=0.13496,AP2=0.13957,AM0=1.232,PI=3.1415926)
20643         COMMON /AA/ R(3,MAXSTR)
20644 cc      SAVE /AA/
20645         COMMON /BB/ P(3,MAXSTR)
20646 cc      SAVE /BB/
20647         COMMON /CC/ E(MAXSTR)
20648 cc      SAVE /CC/
20649         COMMON /EE/ ID(MAXSTR),LB(MAXSTR)
20650 cc      SAVE /EE/
20651         COMMON   /RUN/NUM
20652 cc      SAVE /RUN/
20653         COMMON   /PA/RPION(3,MAXSTR,MAXR)
20654 cc      SAVE /PA/
20655         COMMON   /PB/PPION(3,MAXSTR,MAXR)
20656 cc      SAVE /PB/
20657         COMMON   /PC/EPION(MAXSTR,MAXR)
20658 cc      SAVE /PC/
20659         COMMON   /PD/LPION(MAXSTR,MAXR)
20660 cc      SAVE /PD/
20661       SAVE
20662 * 1. DETERMINE THE MOMENTUM COMPONENT OF THE K* IN THE CMS OF PI-K FRAME
20663 *    WE LET I1 TO BE THE K* AND ABSORB I2
20664         E10=SQRT(E(I1)**2+P(1,I1)**2+P(2,I1)**2+P(3,I1)**2)
20665         E20=SQRT(E(I2)**2+P(1,I2)**2+P(2,I2)**2+P(3,I2)**2)
20666         IF(LB(I2) .EQ. 21 .OR. LB(I2) .EQ. 23) THEN
20667         E(I1)=0.
20668         I=I2
20669         ELSE
20670         E(I2)=0.
20671         I=I1
20672         ENDIF
20673         if(LB(I).eq.23) then
20674            LB(I)=30
20675         else if(LB(I).eq.21) then
20676            LB(I)=-30
20677         endif
20678         P(1,I)=P(1,I1)+P(1,I2)
20679         P(2,I)=P(2,I1)+P(2,I2)
20680         P(3,I)=P(3,I1)+P(3,I2)
20681 * 2. DETERMINE THE MASS OF K* BY USING THE REACTION KINEMATICS
20682         DM=SQRT((E10+E20)**2-P(1,I)**2-P(2,I)**2-P(3,I)**2)
20683         E(I)=DM
20684         RETURN
20685         END
20686
20687 c--------------------------------------------------------
20688 *************************************
20689 *                                                                         *
20690       SUBROUTINE pertur(PX,PY,PZ,SRT,IRUN,I1,I2,nt,kp,icont)
20691 *                                                                         *
20692 *       PURPOSE:   TO PRODUCE CASCADE AND OMEGA PERTURBATIVELY            *
20693 c sp 01/03/01
20694 *                   40 cascade-
20695 *                  -40 cascade-(bar)
20696 *                   41 cascade0
20697 *                  -41 cascade0(bar)
20698 *                   45 Omega baryon
20699 *                  -45 Omega baryon(bar)
20700 *                   44 Di-Omega
20701 **********************************
20702       PARAMETER      (MAXSTR=150001,MAXR=1,PI=3.1415926)
20703       parameter      (MX=4,MY=4,MZ=8,MPX=4,MPY=4,mpz=10,mpzp=10)
20704       PARAMETER (AMN=0.939457,AMP=0.93828,AP1=0.13496,AP2=0.13957)
20705       PARAMETER      (AKA=0.498,ALA=1.1157,ASA=1.1974,aks=0.895)
20706       PARAMETER      (ACAS=1.3213,AOME=1.6724,AMRHO=0.769,AMOMGA=0.782)
20707       PARAMETER      (AETA=0.548,ADIOMG=3.2288)
20708       parameter            (maxx=20,maxz=24)
20709       COMMON   /AA/  R(3,MAXSTR)
20710 cc      SAVE /AA/
20711       COMMON   /BB/  P(3,MAXSTR)
20712 cc      SAVE /BB/
20713       COMMON   /CC/  E(MAXSTR)
20714 cc      SAVE /CC/
20715       COMMON   /EE/  ID(MAXSTR),LB(MAXSTR)
20716 cc      SAVE /EE/
20717       COMMON   /HH/  PROPER(MAXSTR)
20718 cc      SAVE /HH/
20719       common /ff/f(-mx:mx,-my:my,-mz:mz,-mpx:mpx,-mpy:mpy,-mpz:mpzp)
20720 cc      SAVE /ff/
20721       common   /gg/  dx,dy,dz,dpx,dpy,dpz
20722 cc      SAVE /gg/
20723       COMMON   /INPUT/ NSTAR,NDIRCT,DIR
20724 cc      SAVE /INPUT/
20725       COMMON   /NN/NNN
20726 cc      SAVE /NN/
20727       COMMON   /PA/RPION(3,MAXSTR,MAXR)
20728 cc      SAVE /PA/
20729       COMMON   /PB/PPION(3,MAXSTR,MAXR)
20730 cc      SAVE /PB/
20731       COMMON   /PC/EPION(MAXSTR,MAXR)
20732 cc      SAVE /PC/
20733       COMMON   /PD/LPION(MAXSTR,MAXR)
20734 cc      SAVE /PD/
20735       COMMON   /PE/PROPI(MAXSTR,MAXR)
20736 cc      SAVE /PE/
20737       COMMON   /RR/  MASSR(0:MAXR)
20738 cc      SAVE /RR/
20739       COMMON   /BG/BETAX,BETAY,BETAZ,GAMMA
20740 cc      SAVE /BG/
20741       common/input1/ MASSPR,MASSTA,ISEED,IAVOID,DT
20742 cc      SAVE /input1/
20743 c     perturbative method is disabled:
20744 c      common /imulst/ iperts
20745 c
20746       COMMON/RNDF77/NSEED
20747 cc      SAVE /RNDF77/
20748       COMMON /dpert/dpertt(MAXSTR,MAXR),dpertp(MAXSTR),dplast(MAXSTR),
20749      1     dpdcy(MAXSTR),dpdpi(MAXSTR,MAXR),dpt(MAXSTR, MAXR),
20750      2     dpp1(MAXSTR,MAXR),dppion(MAXSTR,MAXR)
20751       SAVE
20752       kp=kp
20753       nt=nt
20754
20755       px0 = px
20756       py0 = py
20757       pz0 = pz
20758       LB1 = LB(I1)
20759       EM1 = E(I1)
20760       X1  = R(1,I1)
20761       Y1  = R(2,I1)
20762       Z1  = R(3,I1)
20763       prob1 = PROPER(I1)
20764 c
20765       LB2 = LB(I2)
20766       EM2 = E(I2)
20767       X2  = R(1,I2)
20768       Y2  = R(2,I2)
20769       Z2  = R(3,I2)
20770       prob2 = PROPER(I2)
20771 c
20772 c                 !! flag for real 2-body process (1/0=no/yes)
20773       icont = 1
20774 c                !! flag for elastic scatt only (-1=no)
20775       icsbel = -1
20776
20777 * K-/K*0bar + La/Si --> cascade + pi
20778 * K+/K*0 + La/Si (bar) --> cascade-bar + pi
20779        if( (lb1.eq.21.or.lb1.eq.23.or.iabs(lb1).eq.30) .and.
20780      &     (iabs(lb2).ge.14.and.iabs(lb2).le.17) )go to 60
20781        if( (lb2.eq.21.or.lb2.eq.23.or.iabs(lb2).eq.30) .and.
20782      &     (iabs(lb1).ge.14.and.iabs(lb1).le.17) )go to 60
20783 * K-/K*0bar + cascade --> omega + pi
20784 * K+/K*0 + cascade-bar --> omega-bar + pi
20785         if( (lb1.eq.21.or.lb1.eq.23.or.iabs(lb1).eq.30) .and.
20786      &      (iabs(lb2).eq.40.or.iabs(lb2).eq.41) )go to 70
20787         if( (lb2.eq.21.or.lb2.eq.23.or.iabs(lb2).eq.30) .and.
20788      &      (iabs(lb1).eq.40.or.iabs(lb1).eq.41) )go to 70
20789 c
20790 c annhilation of cascade,cascade-bar, omega,omega-bar
20791 c
20792 * K- + La/Si <-- cascade + pi(eta,rho,omega)
20793 * K+ + La/Si(bar) <-- cascade-bar + pi(eta,rho,omega)
20794        if( (((lb1.ge.3.and.lb1.le.5).or.lb1.eq.0)
20795      &        .and.(iabs(lb2).eq.40.or.iabs(lb2).eq.41))
20796      & .OR. (((lb2.ge.3.and.lb2.le.5).or.lb2.eq.0)
20797      &        .and.(iabs(lb1).eq.40.or.iabs(lb1).eq.41)) )go to 90
20798 * K- + cascade <-- omega + pi
20799 * K+ + cascade-bar <-- omega-bar + pi
20800 c         if( (lb1.eq.0.and.iabs(lb2).eq.45)
20801 c    &    .OR. (lb2.eq.0.and.iabs(lb1).eq.45) ) go to 110
20802        if( ((lb1.ge.3.and.lb1.le.5).and.iabs(lb2).eq.45)
20803      & .OR.((lb2.ge.3.and.lb2.le.5).and.iabs(lb1).eq.45) )go to 110
20804 c
20805
20806 c----------------------------------------------------
20807 *  for process:  K-bar + L(S) --> Ca + pi
20808 *
20809 60         if(iabs(lb1).ge.14 .and. iabs(lb1).le.17)then
20810              asap = e(i1)
20811              akap = e(i2)
20812              idp = i1
20813            else
20814              asap = e(i2)
20815              akap = e(i1)
20816              idp = i2
20817            endif
20818           app = 0.138
20819          if(srt .lt. (acas+app))return
20820           srrt = srt - (acas+app) + (amn+akap)
20821           pkaon = sqrt(((srrt**2-(amn**2+akap**2))/2./amn)**2 - akap**2)
20822           sigca = 1.5*( akNPsg(pkaon)+akNPsg(pkaon) )
20823 clin pii & pff should be each divided by (4*srt**2),
20824 c     but these two factors cancel out in the ratio pii/pff:
20825           pii = sqrt((srt**2-(amn+akap)**2)*(srt**2-(amn-akap)**2))
20826           pff = sqrt((srt**2-(asap+app)**2)*(srt**2-(asap-app)**2))
20827          cmat = sigca*pii/pff
20828          sigpi = cmat*
20829      &            sqrt((srt**2-(acas+app)**2)*(srt**2-(acas-app)**2))/
20830      &            sqrt((srt**2-(asap+akap)**2)*(srt**2-(asap-akap)**2))
20831 c
20832          sigeta = 0.
20833         if(srt .gt. (acas+aeta))then
20834            srrt = srt - (acas+aeta) + (amn+akap)
20835          pkaon = sqrt(((srrt**2-(amn**2+akap**2))/2./amn)**2 - akap**2)
20836             sigca = 1.5*( akNPsg(pkaon)+akNPsg(pkaon) )
20837          cmat = sigca*pii/pff
20838          sigeta = cmat*
20839      &            sqrt((srt**2-(acas+aeta)**2)*(srt**2-(acas-aeta)**2))/
20840      &            sqrt((srt**2-(asap+akap)**2)*(srt**2-(asap-akap)**2))
20841         endif
20842 c
20843          sigca = sigpi + sigeta
20844          sigpe = 0.
20845 clin-2/25/03 disable the perturb option:
20846 c        if(iperts .eq. 1) sigpe = 40.   !! perturbative xsecn
20847            sig = amax1(sigpe,sigca)
20848          ds = sqrt(sig/31.4)
20849          dsr = ds + 0.1
20850          ec = (em1+em2+0.02)**2
20851          call distce(i1,i2,dsr,ds,dt,ec,srt,ic,px,py,pz)
20852            if(ic .eq. -1)return
20853           brpp = sigca/sig
20854 c
20855 c else particle production
20856           if( (lb1.ge.14.and.lb1.le.17) .or.
20857      &          (lb2.ge.14.and.lb2.le.17) )then
20858 c   !! cascade- or cascde0
20859             lbpp1 = 40 + int(2*RANART(NSEED))
20860           else
20861 * elseif(lb1 .eq. -14 .or. lb2 .eq. -14)
20862 c     !! cascade-bar- or cascde0 -bar
20863             lbpp1 = -40 - int(2*RANART(NSEED))
20864           endif
20865               empp1 = acas
20866            if(RANART(NSEED) .lt. sigpi/sigca)then
20867 c    !! pion
20868             lbpp2 = 3 + int(3*RANART(NSEED))
20869             empp2 = 0.138
20870            else
20871 c    !! eta
20872             lbpp2 = 0
20873             empp2 = aeta
20874            endif
20875 c* check real process of cascade(bar) and pion formation
20876           if(RANART(NSEED) .lt. brpp)then
20877 c       !! real process flag
20878             icont = 0
20879             lb(i1) = lbpp1
20880             e(i1) = empp1
20881 c  !! cascade formed with prob Gam
20882             proper(i1) = brpp
20883             lb(i2) = lbpp2
20884             e(i2) = empp2
20885 c         !! pion/eta formed with prob 1.
20886             proper(i2) = 1.
20887            endif
20888 c else only cascade(bar) formed perturbatively
20889              go to 700
20890
20891 c----------------------------------------------------
20892 *  for process:  Cas(bar) + K_bar(K) --> Om(bar) + pi  !! eta
20893 *
20894 70         if(iabs(lb1).eq.40 .or. iabs(lb1).eq.41)then
20895              acap = e(i1)
20896              akap = e(i2)
20897              idp = i1
20898            else
20899              acap = e(i2)
20900              akap = e(i1)
20901              idp = i2
20902            endif
20903            app = 0.138
20904 *         ames = aeta
20905 c  !! only pion
20906            ames = 0.138
20907          if(srt .lt. (aome+ames))return
20908           srrt = srt - (aome+ames) + (amn+akap)
20909          pkaon = sqrt(((srrt**2-(amn**2+akap**2))/2./amn)**2 - akap**2)
20910 c use K(bar) + Ca --> Om + eta  xsecn same as  K(bar) + N --> Si + Pi
20911 *  as Omega have no resonances
20912 c** using same matrix elements as K-bar + N -> Si + pi
20913          sigomm = 1.5*( akNPsg(pkaon)+akNPsg(pkaon) )
20914          cmat = sigomm*
20915      &          sqrt((srt**2-(amn+akap)**2)*(srt**2-(amn-akap)**2))/
20916      &          sqrt((srt**2-(asa+app)**2)*(srt**2-(asa-app)**2))
20917         sigom = cmat*
20918      &           sqrt((srt**2-(aome+ames)**2)*(srt**2-(aome-ames)**2))/
20919      &           sqrt((srt**2-(acap+akap)**2)*(srt**2-(acap-akap)**2))
20920           sigpe = 0.
20921 clin-2/25/03 disable the perturb option:
20922 c         if(iperts .eq. 1) sigpe = 40.   !! perturbative xsecn
20923           sig = amax1(sigpe,sigom)
20924          ds = sqrt(sig/31.4)
20925          dsr = ds + 0.1
20926          ec = (em1+em2+0.02)**2
20927          call distce(i1,i2,dsr,ds,dt,ec,srt,ic,px,py,pz)
20928            if(ic .eq. -1)return
20929            brpp = sigom/sig
20930 c
20931 c else particle production
20932            if( (lb1.ge.40.and.lb1.le.41) .or.
20933      &           (lb2.ge.40.and.lb2.le.41) )then
20934 c    !! omega
20935             lbpp1 = 45
20936            else
20937 * elseif(lb1 .eq. -40 .or. lb2 .eq. -40)
20938 c    !! omega-bar
20939             lbpp1 = -45
20940            endif
20941            empp1 = aome
20942 *           lbpp2 = 0    !! eta
20943 c    !! pion
20944            lbpp2 = 3 + int(3*RANART(NSEED))
20945            empp2 = ames
20946 c
20947 c* check real process of omega(bar) and pion formation
20948            xrand=RANART(NSEED)
20949          if(xrand .lt. (proper(idp)*brpp))then
20950 c       !! real process flag
20951             icont = 0
20952             lb(i1) = lbpp1
20953             e(i1) = empp1
20954 c  !! P_Om = P_Cas*Gam
20955             proper(i1) = proper(idp)*brpp
20956             lb(i2) = lbpp2
20957             e(i2) = empp2
20958 c   !! pion formed with prob 1.
20959             proper(i2) = 1.
20960           elseif(xrand.lt.brpp) then
20961 c else omega(bar) formed perturbatively and cascade destroyed
20962              e(idp) = 0.
20963           endif
20964              go to 700
20965
20966 c-----------------------------------------------------------
20967 *  for process:  Ca + pi/eta --> K-bar + L(S)
20968 *
20969 90         if(iabs(lb1).eq.40 .or. iabs(lb1).eq.41)then
20970              acap = e(i1)
20971              app = e(i2)
20972              idp = i1
20973              idn = i2
20974            else
20975              acap = e(i2)
20976              app = e(i1)
20977              idp = i2
20978              idn = i1
20979            endif
20980 c            akal = (aka+aks)/2.  !! average of K and K* taken
20981 c  !! using K only
20982             akal = aka
20983 c
20984          alas = ala
20985        if(srt .le. (alas+aka))return
20986            srrt = srt - (acap+app) + (amn+aka)
20987          pkaon = sqrt(((srrt**2-(amn**2+aka**2))/2./amn)**2 - aka**2)
20988 c** using same matrix elements as K-bar + N -> La/Si + pi
20989          sigca = 1.5*( akNPsg(pkaon)+akNPsg(pkaon) )
20990          cmat = sigca*
20991      &          sqrt((srt**2-(amn+aka)**2)*(srt**2-(amn-aka)**2))/
20992      &          sqrt((srt**2-(alas+0.138)**2)*(srt**2-(alas-0.138)**2))
20993          sigca = cmat*
20994      &            sqrt((srt**2-(acap+app)**2)*(srt**2-(acap-app)**2))/
20995      &            sqrt((srt**2-(alas+aka)**2)*(srt**2-(alas-aka)**2))
20996 c    !! pi
20997             dfr = 1./3.
20998 c       !! eta
20999            if(lb(idn).eq.0)dfr = 1.
21000         sigcal = sigca*dfr*(srt**2-(alas+aka)**2)*
21001      &           (srt**2-(alas-aka)**2)/(srt**2-(acap+app)**2)/
21002      &           (srt**2-(acap-app)**2)
21003 c
21004           alas = ASA
21005        if(srt .le. (alas+aka))then
21006          sigcas = 0.
21007        else
21008            srrt = srt - (acap+app) + (amn+aka)
21009         pkaon = sqrt(((srrt**2-(amn**2+aka**2))/2./amn)**2 - aka**2)
21010 c use K(bar) + La/Si --> Ca + Pi  xsecn same as  K(bar) + N --> Si + Pi
21011 c** using same matrix elements as K-bar + N -> La/Si + pi
21012           sigca = 1.5*( akNPsg(pkaon)+akNPsg(pkaon) )
21013          cmat = sigca*
21014      &          sqrt((srt**2-(amn+aka)**2)*(srt**2-(amn-aka)**2))/
21015      &          sqrt((srt**2-(alas+0.138)**2)*(srt**2-(alas-0.138)**2))
21016          sigca = cmat*
21017      &            sqrt((srt**2-(acap+app)**2)*(srt**2-(acap-app)**2))/
21018      &            sqrt((srt**2-(alas+aka)**2)*(srt**2-(alas-aka)**2))
21019 c    !! pi
21020             dfr = 1.
21021 c    !! eta
21022            if(lb(idn).eq.0)dfr = 3.
21023         sigcas = sigca*dfr*(srt**2-(alas+aka)**2)*
21024      &           (srt**2-(alas-aka)**2)/(srt**2-(acap+app)**2)/
21025      &           (srt**2-(acap-app)**2)
21026        endif
21027 c
21028          sig = sigcal + sigcas
21029          brpp = 1.
21030          ds = sqrt(sig/31.4)
21031          dsr = ds + 0.1
21032          ec = (em1+em2+0.02)**2
21033          call distce(i1,i2,dsr,ds,dt,ec,srt,ic,px,py,pz)
21034 c
21035 clin-2/25/03: checking elastic scatt after failure of inelastic scatt gives
21036 c     conditional probability (in general incorrect), tell Pal to correct:
21037        if(ic .eq. -1)then
21038 c check for elastic scatt, no particle annhilation
21039 c  !! elastic cross section of 20 mb
21040          ds = sqrt(20.0/31.4)
21041          dsr = ds + 0.1
21042          call distce(i1,i2,dsr,ds,dt,ec,srt,icsbel,px,py,pz)
21043            if(icsbel .eq. -1)return
21044             empp1 = EM1
21045             empp2 = EM2
21046              go to 700
21047        endif
21048 c
21049 c else pert. produced cascade(bar) is annhilated OR real process
21050 c
21051 * DECIDE LAMBDA OR SIGMA PRODUCTION
21052 c
21053        IF(sigcal/sig .GT. RANART(NSEED))THEN
21054           if(lb1.eq.40.or.lb1.eq.41.or.lb2.eq.40.or.lb2.eq.41)then
21055           lbpp1 = 21
21056            lbpp2 = 14
21057           else
21058            lbpp1 = 23
21059            lbpp2 = -14
21060           endif
21061          alas = ala
21062        ELSE
21063           if(lb1.eq.40.or.lb1.eq.41.or.lb2.eq.40.or.lb2.eq.41)then
21064            lbpp1 = 21
21065             lbpp2 = 15 + int(3 * RANART(NSEED))
21066           else
21067             lbpp1 = 23
21068             lbpp2 = -15 - int(3 * RANART(NSEED))
21069           endif
21070          alas = ASA
21071         ENDIF
21072              empp1 = aka
21073              empp2 = alas
21074 c
21075 c check for real process for L/S(bar) and K(bar) formation
21076           if(RANART(NSEED) .lt. proper(idp))then
21077 * real process
21078 c       !! real process flag
21079             icont = 0
21080             lb(i1) = lbpp1
21081             e(i1) = empp1
21082 c   !! K(bar) formed with prob 1.
21083             proper(i1) = 1.
21084             lb(i2) = lbpp2
21085             e(i2) = empp2
21086 c   !! L/S(bar) formed with prob 1.
21087             proper(i2) = 1.
21088              go to 700
21089            else
21090 c else only cascade(bar) annhilation & go out
21091             e(idp) = 0.
21092            endif
21093           return
21094 c
21095 c----------------------------------------------------
21096 *  for process:  Om(bar) + pi --> Cas(bar) + K_bar(K)
21097 *
21098 110         if(lb1 .eq. 45 .or. lb1 .eq. -45)then
21099              aomp = e(i1)
21100              app = e(i2)
21101              idp = i1
21102              idn = i2
21103            else
21104              aomp = e(i2)
21105              app = e(i1)
21106              idp = i2
21107              idn = i1
21108            endif
21109 c            akal = (aka+aks)/2.  !! average of K and K* taken
21110 c  !! using K only
21111             akal = aka
21112        if(srt .le. (acas+aka))return
21113            srrt = srt - (aome+app) + (amn+aka)
21114          pkaon = sqrt(((srrt**2-(amn**2+aka**2))/2./amn)**2 - aka**2)
21115 c use K(bar) + Ca --> Om + eta  xsecn same as  K(bar) + N --> Si + Pi
21116 c** using same matrix elements as K-bar + N -> La/Si + pi
21117            sigca = 1.5*( akNPsg(pkaon)+akNPsg(pkaon) )
21118          cmat = sigca*
21119      &          sqrt((srt**2-(amn+aka)**2)*(srt**2-(amn-aka)**2))/
21120      &          sqrt((srt**2-(asa+0.138)**2)*(srt**2-(asa-0.138)**2))
21121          sigom = cmat*
21122      &            sqrt((srt**2-(aomp+app)**2)*(srt**2-(aomp-app)**2))/
21123      &            sqrt((srt**2-(acas+aka)**2)*(srt**2-(acas-aka)**2))
21124 c            dfr = 2.    !! eta
21125 c    !! pion
21126            dfr = 2./3.
21127         sigom = sigom*dfr*(srt**2-(acas+aka)**2)*
21128      &           (srt**2-(acas-aka)**2)/(srt**2-(aomp+app)**2)/
21129      &           (srt**2-(aomp-app)**2)
21130 c
21131          brpp = 1.
21132          ds = sqrt(sigom/31.4)
21133          dsr = ds + 0.1
21134          ec = (em1+em2+0.02)**2
21135          call distce(i1,i2,dsr,ds,dt,ec,srt,ic,px,py,pz)
21136 c
21137 clin-2/25/03: checking elastic scatt after failure of inelastic scatt gives
21138 c     conditional probability (in general incorrect), tell Pal to correct:
21139        if(ic .eq. -1)then
21140 c check for elastic scatt, no particle annhilation
21141 c  !! elastic cross section of 20 mb
21142          ds = sqrt(20.0/31.4)
21143          dsr = ds + 0.1
21144          call distce(i1,i2,dsr,ds,dt,ec,srt,icsbel,px,py,pz)
21145            if(icsbel .eq. -1)return
21146             empp1 = EM1
21147             empp2 = EM2
21148              go to 700
21149        endif
21150 c
21151 c else pert. produced omega(bar) annhilated  OR real process
21152 c annhilate only pert. omega, rest from hijing go out WITHOUT annhil.
21153            if(lb1.eq.45 .or. lb2.eq.45)then
21154 c  !! Ca
21155              lbpp1 = 40 + int(2*RANART(NSEED))
21156 c   !! K-
21157              lbpp2 = 21
21158             else
21159 * elseif(lb1 .eq. -45 .or. lb2 .eq. -45)
21160 c    !! Ca-bar
21161             lbpp1 = -40 - int(2*RANART(NSEED))
21162 c      !! K+
21163             lbpp2 = 23
21164            endif
21165              empp1 = acas
21166              empp2 = aka
21167 c
21168 c check for real process for Cas(bar) and K(bar) formation
21169           if(RANART(NSEED) .lt. proper(idp))then
21170 c       !! real process flag
21171             icont = 0
21172             lb(i1) = lbpp1
21173             e(i1) = empp1
21174 c   !! P_Cas(bar) = P_Om(bar)
21175             proper(i1) = proper(idp)
21176             lb(i2) = lbpp2
21177             e(i2) = empp2
21178 c   !! K(bar) formed with prob 1.
21179             proper(i2) = 1.
21180 c
21181            else
21182 c else Cascade(bar)  produced and Omega(bar) annhilated
21183             e(idp) = 0.
21184            endif
21185 c   !! for produced particles
21186              go to 700
21187 c
21188 c-----------------------------------------------------------
21189 700    continue
21190 * CALCULATE THE MAGNITUDE OF THE FINAL MOMENTUM THROUGH
21191 * ENERGY CONSERVATION
21192           PR2   = (SRT**2 - EMpp1**2 - EMpp2**2)**2
21193      &                - 4.0 * (EMpp1*EMpp2)**2
21194           IF(PR2.LE.0.)PR2=0.00000001
21195           PR=SQRT(PR2)/(2.*SRT)
21196 * using isotropic
21197       C1   = 1.0 - 2.0 * RANART(NSEED)
21198       T1   = 2.0 * PI * RANART(NSEED)
21199       S1   = SQRT( 1.0 - C1**2 )
21200       CT1  = COS(T1)
21201       ST1  = SIN(T1)
21202 * THE MOMENTUM IN THE CMS IN THE FINAL STATE
21203       PZ   = PR * C1
21204       PX   = PR * S1*CT1
21205       PY   = PR * S1*ST1
21206 * ROTATE IT
21207        CALL ROTATE(PX0,PY0,PZ0,PX,PY,PZ)
21208        if(icont .eq. 0)return
21209 c
21210 * LORENTZ-TRANSFORMATION INTO CMS FRAME
21211               E1CM    = SQRT (EMpp1**2 + PX**2 + PY**2 + PZ**2)
21212               P1BETA  = PX*BETAX + PY*BETAY + PZ*BETAZ
21213               TRANSF  = GAMMA * ( GAMMA * P1BETA / (GAMMA + 1) + E1CM )
21214               Ppt11 = BETAX * TRANSF + PX
21215               Ppt12 = BETAY * TRANSF + PY
21216               Ppt13 = BETAZ * TRANSF + PZ
21217 c
21218 cc** for elastic scattering update the momentum of pertb particles
21219          if(icsbel .ne. -1)then
21220 c            if(EMpp1 .gt. 0.9)then
21221               p(1,i1) = Ppt11
21222               p(2,i1) = Ppt12
21223               p(3,i1) = Ppt13
21224 c            else
21225               E2CM    = SQRT (EMpp2**2 + PX**2 + PY**2 + PZ**2)
21226               TRANSF  = GAMMA * ( -GAMMA * P1BETA / (GAMMA + 1) + E2CM )
21227               Ppt21 = BETAX * TRANSF - PX
21228               Ppt22 = BETAY * TRANSF - PY
21229               Ppt23 = BETAZ * TRANSF - PZ
21230               p(1,i2) = Ppt21
21231               p(2,i2) = Ppt22
21232               p(3,i2) = Ppt23
21233 c            endif
21234              return
21235           endif
21236 clin-5/2008:
21237 c2008        X01 = 1.0 - 2.0 * RANART(NSEED)
21238 c            Y01 = 1.0 - 2.0 * RANART(NSEED)
21239 c            Z01 = 1.0 - 2.0 * RANART(NSEED)
21240 c        IF ((X01*X01+Y01*Y01+Z01*Z01) .GT. 1.0) GOTO 2008
21241 c                Xpt=X1+0.5*x01
21242 c                Ypt=Y1+0.5*y01
21243 c                Zpt=Z1+0.5*z01
21244                 Xpt=X1
21245                 Ypt=Y1
21246                 Zpt=Z1
21247 c
21248 c
21249 c          if(lbpp1 .eq. 45)then
21250 c           write(*,*)'II lb1,lb2,lbpp1,empp1,proper(idp),brpp'
21251 c           write(*,*)lb1,lb2,lbpp1,empp1,proper(idp),brpp
21252 c          endif
21253 c
21254                NNN=NNN+1
21255                PROPI(NNN,IRUN)= proper(idp)*brpp
21256                LPION(NNN,IRUN)= lbpp1
21257                EPION(NNN,IRUN)= empp1
21258                 RPION(1,NNN,IRUN)=Xpt
21259                 RPION(2,NNN,IRUN)=Ypt
21260                 RPION(3,NNN,IRUN)=Zpt
21261                PPION(1,NNN,IRUN)=Ppt11
21262                PPION(2,NNN,IRUN)=Ppt12
21263                PPION(3,NNN,IRUN)=Ppt13
21264 clin-5/2008:
21265                dppion(nnn,irun)=dpertp(i1)*dpertp(i2)
21266             RETURN
21267             END
21268 **********************************
21269 *  sp 12/08/00                                                         *
21270       SUBROUTINE Crhb(PX,PY,PZ,SRT,I1,I2,IBLOCK)
21271 *     PURPOSE:                                                         *
21272 *        DEALING WITH hyperon+N(D,N*)->hyp+N(D,N*) elastic PROCESS     *
21273 *     NOTE   :                                                         *
21274 *
21275 *     QUANTITIES:                                                 *
21276 *           PX,PY,PZ - MOMENTUM COORDINATES OF ONE PARTICLE IN CM FRAME*
21277 *           SRT      - SQRT OF S                                       *
21278 *           IBLOCK   - THE INFORMATION BACK                            *
21279 *                     144-> hyp+N(D,N*)->hyp+N(D,N*)
21280 **********************************
21281         PARAMETER (MAXSTR=150001,MAXR=1,AMN=0.939457,
21282      1  AMP=0.93828,AP1=0.13496,
21283      2  AP2=0.13957,AM0=1.232,PI=3.1415926,CUTOFF=1.8966,AVMASS=0.9383)
21284         PARAMETER      (AKA=0.498,ALA=1.1157,ASA=1.1974)
21285         parameter     (MX=4,MY=4,MZ=8,MPX=4,MPY=4,mpz=10,mpzp=10)
21286         COMMON /AA/ R(3,MAXSTR)
21287 cc      SAVE /AA/
21288         COMMON /BB/ P(3,MAXSTR)
21289 cc      SAVE /BB/
21290         COMMON /CC/ E(MAXSTR)
21291 cc      SAVE /CC/
21292         COMMON /EE/ ID(MAXSTR),LB(MAXSTR)
21293 cc      SAVE /EE/
21294         common/input1/ MASSPR,MASSTA,ISEED,IAVOID,DT
21295 cc      SAVE /input1/
21296       COMMON/RNDF77/NSEED
21297 cc      SAVE /RNDF77/
21298       SAVE
21299
21300        PX0=PX
21301        PY0=PY
21302        PZ0=PZ
21303 *-----------------------------------------------------------------------
21304         IBLOCK=144
21305         NTAG=0
21306         EM1=E(I1)
21307         EM2=E(I2)
21308 *-----------------------------------------------------------------------
21309 * CALCULATE THE MAGNITUDE OF THE FINAL MOMENTUM THROUGH
21310 * ENERGY CONSERVATION
21311           PR2   = (SRT**2 - EM1**2 - EM2**2)**2
21312      1                - 4.0 * (EM1*EM2)**2
21313           IF(PR2.LE.0.)PR2=1.e-09
21314           PR=SQRT(PR2)/(2.*SRT)
21315           C1   = 1.0 - 2.0 * RANART(NSEED)
21316           T1   = 2.0 * PI * RANART(NSEED)
21317       S1   = SQRT( 1.0 - C1**2 )
21318       CT1  = COS(T1)
21319       ST1  = SIN(T1)
21320       PZ   = PR * C1
21321       PX   = PR * S1*CT1
21322       PY   = PR * S1*ST1
21323       RETURN
21324       END
21325 ****************************************
21326 c sp 04/05/01
21327 * Purpose: lambda-baryon elastic xsection as a functon of their cms energy
21328          subroutine lambar(i1,i2,srt,siglab)
21329 *  srt    = DSQRT(s) in GeV                                               *
21330 *  siglab = lambda-nuclar elastic cross section in mb
21331 *         = 12 + 0.43/p_lab**3.3 (mb)
21332 *
21333 * (2) Calculate p(lab) from srt [GeV], since the formular in the
21334 * reference applies only to the case of a p_bar on a proton at rest
21335 * Formula used: srt**2=2.*pmass*(pmass+sqrt(pmass**2+plab**2))
21336 *****************************
21337         PARAMETER (MAXSTR=150001)
21338         COMMON /AA/ R(3,MAXSTR)
21339 cc      SAVE /AA/
21340         COMMON /BB/ P(3,MAXSTR)
21341 cc      SAVE /BB/
21342         COMMON /CC/ E(MAXSTR)
21343 cc      SAVE /CC/
21344         COMMON /EE/ ID(MAXSTR),LB(MAXSTR)
21345 cc      SAVE /EE/
21346       SAVE
21347
21348           siglab=1.e-06
21349         if( iabs(lb(i1)).ge.14.and.iabs(lb(i1)).le.17 )then
21350           eml = e(i1)
21351           emb = e(i2)
21352          else
21353           eml = e(i2)
21354           emb = e(i1)
21355         endif
21356        pthr = srt**2-eml**2-emb**2
21357         if(pthr .gt. 0.)then
21358        plab2=(pthr/2./emb)**2-eml**2
21359        if(plab2.gt.0)then
21360          plab=sqrt(plab2)
21361          siglab=12. + 0.43/(plab**3.3)
21362        if(siglab.gt.200.)siglab=200.
21363        endif
21364        endif
21365          return
21366       END
21367 C------------------------------------------------------------------
21368 clin-7/26/03 improve speed
21369 ***************************************
21370             SUBROUTINE distc0(drmax,deltr0,DT,
21371      1     Ifirst,PX1CM,PY1CM,PZ1CM,
21372      2     x1,y1,z1,px1,py1,pz1,em1,x2,y2,z2,px2,py2,pz2,em2)
21373 * PURPOSE : CHECK IF THE COLLISION BETWEEN TWO PARTICLES CAN HAPPEN
21374 *           BY CHECKING
21375 *                      (2) IF PARTICLE WILL PASS EACH OTHER WITHIN
21376 *           TWO HARD CORE RADIUS.
21377 *                      (3) IF PARTICLES WILL GET CLOSER.
21378 * VARIABLES :
21379 *           Ifirst=1 COLLISION may HAPPENED
21380 *           Ifirst=-1 COLLISION CAN NOT HAPPEN
21381 *****************************************
21382             COMMON   /BG/  BETAX,BETAY,BETAZ,GAMMA
21383 cc      SAVE /BG/
21384       SAVE
21385             deltr0=deltr0
21386             Ifirst=-1
21387             E1=SQRT(EM1**2+PX1**2+PY1**2+PZ1**2)
21388 *NOW PARTICLES ARE CLOSE ENOUGH TO EACH OTHER !
21389             E2     = SQRT ( EM2**2 + PX2**2 + PY2**2 + PZ2**2 )
21390 *NOW THERE IS ENOUGH ENERGY AVAILABLE !
21391 *LORENTZ-TRANSFORMATION IN I1-I2-C.M. SYSTEM
21392 * BETAX, BETAY, BETAZ AND GAMMA HAVE BEEN GIVEN IN THE SUBROUTINE CMS
21393 *TRANSFORMATION OF MOMENTA (PX1CM = - PX2CM)
21394               P1BETA = PX1*BETAX + PY1*BETAY + PZ1 * BETAZ
21395               TRANSF = GAMMA * ( GAMMA * P1BETA / (GAMMA + 1) - E1 )
21396               PRCM   = SQRT (PX1CM**2 + PY1CM**2 + PZ1CM**2)
21397               IF (PRCM .LE. 0.00001) return
21398 *TRANSFORMATION OF SPATIAL DISTANCE
21399               DRBETA = BETAX*(X1-X2) + BETAY*(Y1-Y2) + BETAZ*(Z1-Z2)
21400               TRANSF = GAMMA * GAMMA * DRBETA / (GAMMA + 1)
21401               DXCM   = BETAX * TRANSF + X1 - X2
21402               DYCM   = BETAY * TRANSF + Y1 - Y2
21403               DZCM   = BETAZ * TRANSF + Z1 - Z2
21404 *DETERMINING IF THIS IS THE POINT OF CLOSEST APPROACH
21405               DRCM   = SQRT (DXCM**2  + DYCM**2  + DZCM**2 )
21406               DZZ    = (PX1CM*DXCM + PY1CM*DYCM + PZ1CM*DZCM) / PRCM
21407               if ((drcm**2 - dzz**2) .le. 0.) then
21408                 BBB = 0.
21409               else
21410                 BBB    = SQRT (DRCM**2 - DZZ**2)
21411               end if
21412 *WILL PARTICLE PASS EACH OTHER WITHIN 2 * HARD CORE RADIUS ?
21413               IF (BBB .GT. drmax) return
21414               RELVEL = PRCM * (1.0/E1 + 1.0/E2)
21415               DDD    = RELVEL * DT * 0.5
21416 *WILL PARTICLES GET CLOSER ?
21417               IF (ABS(DDD) .LT. ABS(DZZ)) return
21418               Ifirst=1
21419               RETURN
21420               END
21421 *---------------------------------------------------------------------------
21422 c
21423 clin-8/2008 B+B->Deuteron+Meson cross section in mb:
21424       subroutine sbbdm(srt,sdprod,ianti,lbm,xmm,pfinal)
21425       PARAMETER (xmd=1.8756,AP1=0.13496,AP2=0.13957,
21426      1     xmrho=0.770,xmomega=0.782,xmeta=0.548,srt0=2.012)
21427       common/leadng/lb1,px1,py1,pz1,em1,e1,xfnl,yfnl,zfnl,tfnl,
21428      1     px1n,py1n,pz1n,dp1n
21429       common /dpi/em2,lb2
21430       common /para8/ idpert,npertd,idxsec
21431       COMMON/RNDF77/NSEED
21432       SAVE
21433 c
21434       sdprod=0.
21435       sbbdpi=0.
21436       sbbdrho=0.
21437       sbbdomega=0.
21438       sbbdeta=0.
21439       if(srt.le.(em1+em2)) return
21440 c
21441       ilb1=iabs(lb1)
21442       ilb2=iabs(lb2)
21443 ctest off check Xsec using fixed mass for resonances:
21444 c      if(ilb1.ge.6.and.ilb1.le.9) then
21445 c         em1=1.232
21446 c      elseif(ilb1.ge.10.and.ilb1.le.11) then
21447 c         em1=1.44
21448 c      elseif(ilb1.ge.12.and.ilb1.le.13) then
21449 c         em1=1.535
21450 c      endif
21451 c      if(ilb2.ge.6.and.ilb2.le.9) then
21452 c         em2=1.232
21453 c      elseif(ilb2.ge.10.and.ilb2.le.11) then
21454 c         em2=1.44
21455 c      elseif(ilb2.ge.12.and.ilb2.le.13) then
21456 c         em2=1.535
21457 c      endif
21458 c
21459       s=srt**2
21460       pinitial=sqrt((s-(em1+em2)**2)*(s-(em1-em2)**2))/2./srt
21461       fs=fnndpi(s)
21462 c     Determine isospin and spin factors for the ratio between
21463 c     BB->Deuteron+Meson and Deuteron+Meson->BB cross sections:
21464       if(idxsec.eq.1.or.idxsec.eq.2) then
21465 c     Assume B+B -> d+Meson has the same cross sections as N+N -> d+pi:
21466       else
21467 c     Assume d+Meson -> B+B has the same cross sections as d+pi -> N+N,
21468 c     then determine B+B -> d+Meson cross sections:
21469          if(ilb1.ge.1.and.ilb1.le.2.and.
21470      1        ilb2.ge.1.and.ilb2.le.2) then
21471             pifactor=9./8.
21472          elseif((ilb1.ge.1.and.ilb1.le.2.and.
21473      1           ilb2.ge.6.and.ilb2.le.9).or.
21474      2           (ilb2.ge.1.and.ilb2.le.2.and.
21475      1           ilb1.ge.6.and.ilb1.le.9)) then
21476             pifactor=9./64.
21477          elseif((ilb1.ge.1.and.ilb1.le.2.and.
21478      1           ilb2.ge.10.and.ilb2.le.13).or.
21479      2           (ilb2.ge.1.and.ilb2.le.2.and.
21480      1           ilb1.ge.10.and.ilb1.le.13)) then
21481             pifactor=9./16.
21482          elseif(ilb1.ge.6.and.ilb1.le.9.and.
21483      1           ilb2.ge.6.and.ilb2.le.9) then
21484             pifactor=9./128.
21485          elseif((ilb1.ge.6.and.ilb1.le.9.and.
21486      1           ilb2.ge.10.and.ilb2.le.13).or.
21487      2           (ilb2.ge.6.and.ilb2.le.9.and.
21488      1           ilb1.ge.10.and.ilb1.le.13)) then
21489             pifactor=9./64.
21490          elseif((ilb1.ge.10.and.ilb1.le.11.and.
21491      1           ilb2.ge.10.and.ilb2.le.11).or.
21492      2           (ilb2.ge.12.and.ilb2.le.13.and.
21493      1           ilb1.ge.12.and.ilb1.le.13)) then
21494             pifactor=9./8.
21495          elseif((ilb1.ge.10.and.ilb1.le.11.and.
21496      1           ilb2.ge.12.and.ilb2.le.13).or.
21497      2           (ilb2.ge.10.and.ilb2.le.11.and.
21498      1           ilb1.ge.12.and.ilb1.le.13)) then
21499             pifactor=9./16.
21500          endif
21501       endif
21502 c     d pi: DETERMINE THE CHARGE STATES OF PARTICLES IN THE FINAL STATE
21503 *     (1) FOR P+P->Deuteron+pi+:
21504       IF((ilb1*ilb2).EQ.1)THEN
21505          lbm=5
21506          if(ianti.eq.1) lbm=3
21507          xmm=ap2
21508 *     (2)FOR N+N->Deuteron+pi-:
21509       ELSEIF(ilb1.EQ.2.AND.ilb2.EQ.2)THEN
21510          lbm=3
21511          if(ianti.eq.1) lbm=5
21512          xmm=ap2
21513 *     (3)FOR N+P->Deuteron+pi0:
21514       ELSEIF((ilb1*ilb2).EQ.2)THEN
21515          lbm=4
21516          xmm=ap1
21517       ELSE
21518 c     For baryon resonances, use isospin-averaged cross sections:
21519          lbm=3+int(3 * RANART(NSEED))
21520          if(lbm.eq.4) then
21521             xmm=ap1
21522          else
21523             xmm=ap2
21524          endif
21525       ENDIF
21526 c
21527       if(srt.ge.(xmd+xmm)) then
21528          pfinal=sqrt((s-(xmd+xmm)**2)*(s-(xmd-xmm)**2))/2./srt
21529          if((ilb1.eq.1.and.ilb2.eq.1).or.
21530      1        (ilb1.eq.2.and.ilb2.eq.2)) then
21531 c     for pp or nn initial states:
21532             sbbdpi=fs*pfinal/pinitial/4.
21533          elseif((ilb1.eq.1.and.ilb2.eq.2).or.
21534      1           (ilb1.eq.2.and.ilb2.eq.1)) then
21535 c     factor of 1/2 for pn or np initial states:
21536             sbbdpi=fs*pfinal/pinitial/4./2.
21537          else
21538 c     for other BB initial states (spin- and isospin averaged):
21539             if(idxsec.eq.1) then
21540 c     1: assume the same |matrix element|**2 (after averaging over initial
21541 c     spins and isospins) for B+B -> deuteron+meson at the same sqrt(s);
21542                sbbdpi=fs*pfinal/pinitial*3./16.
21543             elseif(idxsec.eq.2.or.idxsec.eq.4) then
21544                threshold=amax1(xmd+xmm,em1+em2)
21545                snew=(srt-threshold+srt0)**2
21546                if(idxsec.eq.2) then
21547 c     2: assume the same |matrix element|**2 for B+B -> deuteron+meson
21548 c     at the same sqrt(s)-threshold:
21549                   sbbdpi=fnndpi(snew)*pfinal/pinitial*3./16.
21550                elseif(idxsec.eq.4) then
21551 c     4: assume the same |matrix element|**2 for B+B <- deuteron+meson
21552 c     at the same sqrt(s)-threshold:
21553                   sbbdpi=fnndpi(snew)*pfinal/pinitial/6.*pifactor
21554                endif
21555             elseif(idxsec.eq.3) then
21556 c     3: assume the same |matrix element|**2 for B+B <- deuteron+meson
21557 c     at the same sqrt(s):
21558                sbbdpi=fs*pfinal/pinitial/6.*pifactor
21559             endif
21560 c
21561          endif
21562       endif
21563 c
21564 *     d rho: DETERMINE THE CROSS SECTION TO THIS FINAL STATE:
21565       if(srt.gt.(xmd+xmrho)) then
21566          pfinal=sqrt((s-(xmd+xmrho)**2)*(s-(xmd-xmrho)**2))/2./srt
21567          if(idxsec.eq.1) then
21568             sbbdrho=fs*pfinal/pinitial*3./16.
21569          elseif(idxsec.eq.2.or.idxsec.eq.4) then
21570             threshold=amax1(xmd+xmrho,em1+em2)
21571             snew=(srt-threshold+srt0)**2
21572             if(idxsec.eq.2) then
21573                sbbdrho=fnndpi(snew)*pfinal/pinitial*3./16.
21574             elseif(idxsec.eq.4) then
21575 c     The spin- and isospin-averaged factor is 3-times larger for rho:
21576                sbbdrho=fnndpi(snew)*pfinal/pinitial/6.*(pifactor*3.)
21577             endif
21578          elseif(idxsec.eq.3) then
21579             sbbdrho=fs*pfinal/pinitial/6.*(pifactor*3.)
21580          endif
21581       endif
21582 c
21583 *     d omega: DETERMINE THE CROSS SECTION TO THIS FINAL STATE:
21584       if(srt.gt.(xmd+xmomega)) then
21585          pfinal=sqrt((s-(xmd+xmomega)**2)*(s-(xmd-xmomega)**2))/2./srt
21586          if(idxsec.eq.1) then
21587             sbbdomega=fs*pfinal/pinitial*3./16.
21588          elseif(idxsec.eq.2.or.idxsec.eq.4) then
21589             threshold=amax1(xmd+xmomega,em1+em2)
21590             snew=(srt-threshold+srt0)**2
21591             if(idxsec.eq.2) then
21592                sbbdomega=fnndpi(snew)*pfinal/pinitial*3./16.
21593             elseif(idxsec.eq.4) then
21594                sbbdomega=fnndpi(snew)*pfinal/pinitial/6.*pifactor
21595             endif
21596          elseif(idxsec.eq.3) then
21597             sbbdomega=fs*pfinal/pinitial/6.*pifactor
21598          endif
21599       endif
21600 c
21601 *     d eta: DETERMINE THE CROSS SECTION TO THIS FINAL STATE:
21602       if(srt.gt.(xmd+xmeta)) then
21603          pfinal=sqrt((s-(xmd+xmeta)**2)*(s-(xmd-xmeta)**2))/2./srt
21604          if(idxsec.eq.1) then
21605             sbbdeta=fs*pfinal/pinitial*3./16.
21606          elseif(idxsec.eq.2.or.idxsec.eq.4) then
21607             threshold=amax1(xmd+xmeta,em1+em2)
21608             snew=(srt-threshold+srt0)**2
21609             if(idxsec.eq.2) then
21610                sbbdeta=fnndpi(snew)*pfinal/pinitial*3./16.
21611             elseif(idxsec.eq.4) then
21612                sbbdeta=fnndpi(snew)*pfinal/pinitial/6.*(pifactor/3.)
21613             endif
21614          elseif(idxsec.eq.3) then
21615             sbbdeta=fs*pfinal/pinitial/6.*(pifactor/3.)
21616          endif
21617       endif
21618 c
21619       sdprod=sbbdpi+sbbdrho+sbbdomega+sbbdeta
21620 ctest off
21621 c      write(99,111) srt,sbbdpi,sbbdrho,sbbdomega,sbbdeta,sdprod
21622 c 111  format(6(f8.2,1x))
21623 c
21624       if(sdprod.le.0) return
21625 c
21626 c     choose final state and assign masses here:
21627       x1=RANART(NSEED)
21628       if(x1.le.sbbdpi/sdprod) then
21629 c     use the above-determined lbm and xmm.
21630       elseif(x1.le.(sbbdpi+sbbdrho)/sdprod) then
21631          lbm=25+int(3*RANART(NSEED))
21632          xmm=xmrho
21633       elseif(x1.le.(sbbdpi+sbbdrho+sbbdomega)/sdprod) then
21634          lbm=28
21635          xmm=xmomega
21636       else
21637          lbm=0
21638          xmm=xmeta
21639       endif
21640 c
21641       return
21642       end
21643 c
21644 c     Generate angular distribution of Deuteron in the CMS frame:
21645       subroutine bbdangle(pxd,pyd,pzd,nt,ipert1,ianti,idloop,pfinal,
21646      1 dprob1,lbm)
21647       PARAMETER (PI=3.1415926)
21648       common/leadng/lb1,px1,py1,pz1,em1,e1,xfnl,yfnl,zfnl,tfnl,
21649      1     px1n,py1n,pz1n,dp1n
21650       common /dpi/em2,lb2
21651       COMMON/RNDF77/NSEED
21652       common /para8/ idpert,npertd,idxsec
21653       COMMON /AREVT/ IAEVT, IARUN, MISS
21654       SAVE
21655 c     take isotropic distribution for now:
21656       C1=1.0-2.0*RANART(NSEED)
21657       T1=2.0*PI*RANART(NSEED)
21658       S1=SQRT(1.0-C1**2)
21659       CT1=COS(T1)
21660       ST1=SIN(T1)
21661 * THE MOMENTUM IN THE CMS IN THE FINAL STATE
21662       PZd=pfinal*C1
21663       PXd=pfinal*S1*CT1
21664       PYd=pfinal*S1*ST1
21665 clin-5/2008 track the number of produced deuterons:
21666       if(idpert.eq.1.and.npertd.ge.1) then
21667          dprob=dprob1
21668       elseif(idpert.eq.2.and.npertd.ge.1) then
21669          dprob=1./float(npertd)
21670       endif
21671 c      if(ianti.eq.0) then
21672 c         if(idpert.eq.0.or.(idpert.eq.1.and.ipert1.eq.0).or.
21673 c     1        (idpert.eq.2.and.idloop.eq.(npertd+1))) then
21674 c            write (91,*) lb1,' *',lb2,' ->d+',lbm,' (regular d prodn)
21675 c     1 @evt#',iaevt,' @nt=',nt
21676 c         elseif((idpert.eq.1.or.idpert.eq.2).and.idloop.eq.npertd) then
21677 c            write (91,*) lb1,' *',lb2,' ->d+',lbm,' (pert d prodn)
21678 c     1 @evt#',iaevt,' @nt=',nt,' @prob=',dprob
21679 c         endif
21680 c      else
21681 c         if(idpert.eq.0.or.(idpert.eq.1.and.ipert1.eq.0).or.
21682 c     1        (idpert.eq.2.and.idloop.eq.(npertd+1))) then
21683 c            write (91,*) lb1,' *',lb2,' ->d+',lbm,' (regular dbar prodn)
21684 c     1 @evt#',iaevt,' @nt=',nt
21685 c         elseif((idpert.eq.1.or.idpert.eq.2).and.idloop.eq.npertd) then
21686 c            write (91,*) lb1,' *',lb2,' ->d+',lbm,' (pert dbar prodn)
21687 c     1 @evt#',iaevt,' @nt=',nt,' @prob=',dprob
21688 c         endif
21689 c      endif
21690 c
21691       return
21692       end
21693 c
21694 c     Deuteron+Meson->B+B cross section (in mb)
21695       subroutine sdmbb(SRT,sdm,ianti)
21696       PARAMETER (AMN=0.939457,AMP=0.93828,
21697      1     AM0=1.232,AM1440=1.44,AM1535=1.535,srt0=2.012)
21698       common/leadng/lb1,px1,py1,pz1,em1,e1,xfnl,yfnl,zfnl,tfnl,
21699      1     px1n,py1n,pz1n,dp1n
21700       common /dpi/em2,lb2
21701       common /dpifsl/lbnn1,lbnn2,lbnd1,lbnd2,lbns1,lbns2,lbnp1,lbnp2,
21702      1     lbdd1,lbdd2,lbds1,lbds2,lbdp1,lbdp2,lbss1,lbss2,
21703      2     lbsp1,lbsp2,lbpp1,lbpp2
21704       common /dpifsm/xmnn1,xmnn2,xmnd1,xmnd2,xmns1,xmns2,xmnp1,xmnp2,
21705      1     xmdd1,xmdd2,xmds1,xmds2,xmdp1,xmdp2,xmss1,xmss2,
21706      2     xmsp1,xmsp2,xmpp1,xmpp2
21707       common /dpisig/sdmel,sdmnn,sdmnd,sdmns,sdmnp,sdmdd,sdmds,sdmdp,
21708      1     sdmss,sdmsp,sdmpp
21709       common /para8/ idpert,npertd,idxsec
21710       COMMON/RNDF77/NSEED
21711       SAVE
21712 c
21713       sdm=0.
21714       sdmel=0.
21715       sdmnn=0.
21716       sdmnd=0.
21717       sdmns=0.
21718       sdmnp=0.
21719       sdmdd=0.
21720       sdmds=0.
21721       sdmdp=0.
21722       sdmss=0.
21723       sdmsp=0.
21724       sdmpp=0.
21725 ctest off check Xsec using fixed mass for resonances:
21726 c      if(lb1.ge.25.and.lb1.le.27) then
21727 c         em1=0.776
21728 c      elseif(lb1.eq.28) then
21729 c         em1=0.783
21730 c      elseif(lb1.eq.0) then
21731 c         em1=0.548
21732 c      endif
21733 c      if(lb2.ge.25.and.lb2.le.27) then
21734 c         em2=0.776
21735 c      elseif(lb2.eq.28) then
21736 c         em2=0.783
21737 c      elseif(lb2.eq.0) then
21738 c         em2=0.548
21739 c      endif
21740 c
21741       if(srt.le.(em1+em2)) return
21742       s=srt**2
21743       pinitial=sqrt((s-(em1+em2)**2)*(s-(em1-em2)**2))/2./srt
21744       fs=fnndpi(s)
21745 c     Determine isospin and spin factors for the ratio between
21746 c     Deuteron+Meson->BB and BB->Deuteron+Meson cross sections:
21747       if(idxsec.eq.1.or.idxsec.eq.2) then
21748 c     Assume B+B -> d+Meson has the same cross sections as N+N -> d+pi,
21749 c     then determine d+Meson -> B+B cross sections:
21750          if((lb1.ge.3.and.lb1.le.5).or.
21751      1        (lb2.ge.3.and.lb2.le.5)) then
21752             xnnfactor=8./9.
21753          elseif((lb1.ge.25.and.lb1.le.27).or.
21754      1           (lb2.ge.25.and.lb2.le.27)) then
21755             xnnfactor=8./27.
21756          elseif(lb1.eq.28.or.lb2.eq.28) then
21757             xnnfactor=8./9.
21758          elseif(lb1.eq.0.or.lb2.eq.0) then
21759             xnnfactor=8./3.
21760          endif
21761       else
21762 c     Assume d+Meson -> B+B has the same cross sections as d+pi -> N+N:
21763       endif
21764 clin-9/2008 For elastic collisions:
21765       if(idxsec.eq.1.or.idxsec.eq.3) then
21766 c     1/3: assume the same |matrix element|**2 (after averaging over initial
21767 c     spins and isospins) for d+Meson elastic at the same sqrt(s);
21768          sdmel=fdpiel(s)
21769       elseif(idxsec.eq.2.or.idxsec.eq.4) then
21770 c     2/4: assume the same |matrix element|**2 (after averaging over initial
21771 c     spins and isospins) for d+Meson elastic at the same sqrt(s)-threshold:
21772          threshold=em1+em2
21773          snew=(srt-threshold+srt0)**2
21774          sdmel=fdpiel(snew)
21775       endif
21776 c
21777 *     NN: DETERMINE THE CHARGE STATES OF PARTICLESIN THE FINAL STATE
21778       IF(((lb1.eq.5.or.lb2.eq.5.or.lb1.eq.27.or.lb2.eq.27)
21779      1     .and.ianti.eq.0).or.
21780      2     ((lb1.eq.3.or.lb2.eq.3.or.lb1.eq.25.or.lb2.eq.25)
21781      3     .and.ianti.eq.1))THEN
21782 *     (1) FOR Deuteron+(pi+,rho+) -> P+P or DeuteronBar+(pi-,rho-)-> PBar+PBar:
21783          lbnn1=1
21784          lbnn2=1
21785          xmnn1=amp
21786          xmnn2=amp
21787       ELSEIF(lb1.eq.3.or.lb2.eq.3.or.lb1.eq.26.or.lb2.eq.26
21788      1        .or.lb1.eq.28.or.lb2.eq.28.or.lb1.eq.0.or.lb2.eq.0)THEN
21789 *     (2) FOR Deuteron+(pi0,rho0,omega,eta) -> N+P
21790 *     or DeuteronBar+(pi0,rho0,omega,eta) ->NBar+PBar:
21791          lbnn1=2
21792          lbnn2=1
21793          xmnn1=amn
21794          xmnn2=amp
21795       ELSE
21796 *     (3) FOR Deuteron+(pi-,rho-) -> N+N or DeuteronBar+(pi+,rho+)-> NBar+NBar:
21797          lbnn1=2
21798          lbnn2=2
21799          xmnn1=amn
21800          xmnn2=amn
21801       ENDIF
21802       if(srt.gt.(xmnn1+xmnn2)) then
21803          pfinal=sqrt((s-(xmnn1+xmnn2)**2)*(s-(xmnn1-xmnn2)**2))/2./srt
21804          if(idxsec.eq.1) then
21805 c     1: assume the same |matrix element|**2 (after averaging over initial
21806 c     spins and isospins) for B+B -> deuteron+meson at the same sqrt(s);
21807             sdmnn=fs*pfinal/pinitial*3./16.*xnnfactor
21808          elseif(idxsec.eq.2.or.idxsec.eq.4) then
21809             threshold=amax1(xmnn1+xmnn2,em1+em2)
21810             snew=(srt-threshold+srt0)**2
21811             if(idxsec.eq.2) then
21812 c     2: assume the same |matrix element|**2 for B+B -> deuteron+meson
21813 c     at the same sqrt(s)-threshold:
21814                sdmnn=fnndpi(snew)*pfinal/pinitial*3./16.*xnnfactor
21815             elseif(idxsec.eq.4) then
21816 c     4: assume the same |matrix element|**2 for B+B <- deuteron+meson
21817 c     at the same sqrt(s)-threshold:
21818                sdmnn=fnndpi(snew)*pfinal/pinitial/6.
21819             endif
21820          elseif(idxsec.eq.3) then
21821 c     3: assume the same |matrix element|**2 for B+B <- deuteron+meson
21822 c     at the same sqrt(s):
21823             sdmnn=fs*pfinal/pinitial/6.
21824          endif
21825       endif
21826 c
21827 *     ND: DETERMINE THE CHARGE STATES OF PARTICLES IN THE FINAL STATE
21828       lbnd1=1+int(2*RANART(NSEED))
21829       lbnd2=6+int(4*RANART(NSEED))
21830       if(lbnd1.eq.1) then
21831          xmnd1=amp
21832       elseif(lbnd1.eq.2) then
21833          xmnd1=amn
21834       endif
21835       xmnd2=am0
21836       if(srt.gt.(xmnd1+xmnd2)) then
21837          pfinal=sqrt((s-(xmnd1+xmnd2)**2)*(s-(xmnd1-xmnd2)**2))/2./srt
21838          if(idxsec.eq.1) then
21839 c     The spin- and isospin-averaged factor is 8-times larger for ND:
21840             sdmnd=fs*pfinal/pinitial*3./16.*(xnnfactor*8.)
21841          elseif(idxsec.eq.2.or.idxsec.eq.4) then
21842             threshold=amax1(xmnd1+xmnd2,em1+em2)
21843             snew=(srt-threshold+srt0)**2
21844             if(idxsec.eq.2) then
21845                sdmnd=fnndpi(snew)*pfinal/pinitial*3./16.*(xnnfactor*8.)
21846             elseif(idxsec.eq.4) then
21847                sdmnd=fnndpi(snew)*pfinal/pinitial/6.
21848             endif
21849          elseif(idxsec.eq.3) then
21850             sdmnd=fs*pfinal/pinitial/6.
21851          endif
21852       endif
21853 c
21854 *     NS: DETERMINE THE CHARGE STATES OF PARTICLES IN THE FINAL STATE
21855       lbns1=1+int(2*RANART(NSEED))
21856       lbns2=10+int(2*RANART(NSEED))
21857       if(lbns1.eq.1) then
21858          xmns1=amp
21859       elseif(lbns1.eq.2) then
21860          xmns1=amn
21861       endif
21862       xmns2=am1440
21863       if(srt.gt.(xmns1+xmns2)) then
21864          pfinal=sqrt((s-(xmns1+xmns2)**2)*(s-(xmns1-xmns2)**2))/2./srt
21865          if(idxsec.eq.1) then
21866             sdmns=fs*pfinal/pinitial*3./16.*(xnnfactor*2.)
21867          elseif(idxsec.eq.2.or.idxsec.eq.4) then
21868             threshold=amax1(xmns1+xmns2,em1+em2)
21869             snew=(srt-threshold+srt0)**2
21870             if(idxsec.eq.2) then
21871                sdmns=fnndpi(snew)*pfinal/pinitial*3./16.*(xnnfactor*2.)
21872             elseif(idxsec.eq.4) then
21873                sdmns=fnndpi(snew)*pfinal/pinitial/6.
21874             endif
21875          elseif(idxsec.eq.3) then
21876             sdmns=fs*pfinal/pinitial/6.
21877          endif
21878       endif
21879 c
21880 *     NP: DETERMINE THE CHARGE STATES OF PARTICLES IN THE FINAL STATE
21881       lbnp1=1+int(2*RANART(NSEED))
21882       lbnp2=12+int(2*RANART(NSEED))
21883       if(lbnp1.eq.1) then
21884          xmnp1=amp
21885       elseif(lbnp1.eq.2) then
21886          xmnp1=amn
21887       endif
21888       xmnp2=am1535
21889       if(srt.gt.(xmnp1+xmnp2)) then
21890          pfinal=sqrt((s-(xmnp1+xmnp2)**2)*(s-(xmnp1-xmnp2)**2))/2./srt
21891          if(idxsec.eq.1) then
21892             sdmnp=fs*pfinal/pinitial*3./16.*(xnnfactor*2.)
21893          elseif(idxsec.eq.2.or.idxsec.eq.4) then
21894             threshold=amax1(xmnp1+xmnp2,em1+em2)
21895             snew=(srt-threshold+srt0)**2
21896             if(idxsec.eq.2) then
21897                sdmnp=fnndpi(snew)*pfinal/pinitial*3./16.*(xnnfactor*2.)
21898             elseif(idxsec.eq.4) then
21899                sdmnp=fnndpi(snew)*pfinal/pinitial/6.
21900             endif
21901          elseif(idxsec.eq.3) then
21902             sdmnp=fs*pfinal/pinitial/6.
21903          endif
21904       endif
21905 c
21906 *     DD: DETERMINE THE CHARGE STATES OF PARTICLES IN THE FINAL STATE
21907       lbdd1=6+int(4*RANART(NSEED))
21908       lbdd2=6+int(4*RANART(NSEED))
21909       xmdd1=am0
21910       xmdd2=am0
21911       if(srt.gt.(xmdd1+xmdd2)) then
21912          pfinal=sqrt((s-(xmdd1+xmdd2)**2)*(s-(xmdd1-xmdd2)**2))/2./srt
21913          if(idxsec.eq.1) then
21914             sdmdd=fs*pfinal/pinitial*3./16.*(xnnfactor*16.)
21915          elseif(idxsec.eq.2.or.idxsec.eq.4) then
21916             threshold=amax1(xmdd1+xmdd2,em1+em2)
21917             snew=(srt-threshold+srt0)**2
21918             if(idxsec.eq.2) then
21919                sdmdd=fnndpi(snew)*pfinal/pinitial*3./16.*(xnnfactor*16.)
21920             elseif(idxsec.eq.4) then
21921                sdmdd=fnndpi(snew)*pfinal/pinitial/6.
21922             endif
21923          elseif(idxsec.eq.3) then
21924             sdmdd=fs*pfinal/pinitial/6.
21925          endif
21926       endif
21927 c
21928 *     DS: DETERMINE THE CHARGE STATES OF PARTICLES IN THE FINAL STATE
21929       lbds1=6+int(4*RANART(NSEED))
21930       lbds2=10+int(2*RANART(NSEED))
21931       xmds1=am0
21932       xmds2=am1440
21933       if(srt.gt.(xmds1+xmds2)) then
21934          pfinal=sqrt((s-(xmds1+xmds2)**2)*(s-(xmds1-xmds2)**2))/2./srt
21935          if(idxsec.eq.1) then
21936             sdmds=fs*pfinal/pinitial*3./16.*(xnnfactor*8.)
21937          elseif(idxsec.eq.2.or.idxsec.eq.4) then
21938             threshold=amax1(xmds1+xmds2,em1+em2)
21939             snew=(srt-threshold+srt0)**2
21940             if(idxsec.eq.2) then
21941                sdmds=fnndpi(snew)*pfinal/pinitial*3./16.*(xnnfactor*8.)
21942             elseif(idxsec.eq.4) then
21943                sdmds=fnndpi(snew)*pfinal/pinitial/6.
21944             endif
21945          elseif(idxsec.eq.3) then
21946             sdmds=fs*pfinal/pinitial/6.
21947          endif
21948       endif
21949 c
21950 *     DP: DETERMINE THE CHARGE STATES OF PARTICLES IN THE FINAL STATE
21951       lbdp1=6+int(4*RANART(NSEED))
21952       lbdp2=12+int(2*RANART(NSEED))
21953       xmdp1=am0
21954       xmdp2=am1535
21955       if(srt.gt.(xmdp1+xmdp2)) then
21956          pfinal=sqrt((s-(xmdp1+xmdp2)**2)*(s-(xmdp1-xmdp2)**2))/2./srt
21957          if(idxsec.eq.1) then
21958             sdmdp=fs*pfinal/pinitial*3./16.*(xnnfactor*8.)
21959          elseif(idxsec.eq.2.or.idxsec.eq.4) then
21960             threshold=amax1(xmdp1+xmdp2,em1+em2)
21961             snew=(srt-threshold+srt0)**2
21962             if(idxsec.eq.2) then
21963                sdmdp=fnndpi(snew)*pfinal/pinitial*3./16.*(xnnfactor*8.)
21964             elseif(idxsec.eq.4) then
21965                sdmdp=fnndpi(snew)*pfinal/pinitial/6.
21966             endif
21967          elseif(idxsec.eq.3) then
21968             sdmdp=fs*pfinal/pinitial/6.
21969          endif
21970       endif
21971 c
21972 *     SS: DETERMINE THE CHARGE STATES OF PARTICLES IN THE FINAL STATE
21973       lbss1=10+int(2*RANART(NSEED))
21974       lbss2=10+int(2*RANART(NSEED))
21975       xmss1=am1440
21976       xmss2=am1440
21977       if(srt.gt.(xmss1+xmss2)) then
21978          pfinal=sqrt((s-(xmss1+xmss2)**2)*(s-(xmss1-xmss2)**2))/2./srt
21979          if(idxsec.eq.1) then
21980             sdmss=fs*pfinal/pinitial*3./16.*xnnfactor
21981          elseif(idxsec.eq.2.or.idxsec.eq.4) then
21982             threshold=amax1(xmss1+xmss2,em1+em2)
21983             snew=(srt-threshold+srt0)**2
21984             if(idxsec.eq.2) then
21985                sdmss=fnndpi(snew)*pfinal/pinitial*3./16.*xnnfactor
21986             elseif(idxsec.eq.4) then
21987                sdmss=fnndpi(snew)*pfinal/pinitial/6.
21988             endif
21989          elseif(idxsec.eq.3) then
21990             sdmns=fs*pfinal/pinitial/6.
21991          endif
21992       endif
21993 c
21994 *     SP: DETERMINE THE CHARGE STATES OF PARTICLES IN THE FINAL STATE
21995       lbsp1=10+int(2*RANART(NSEED))
21996       lbsp2=12+int(2*RANART(NSEED))
21997       xmsp1=am1440
21998       xmsp2=am1535
21999       if(srt.gt.(xmsp1+xmsp2)) then
22000          pfinal=sqrt((s-(xmsp1+xmsp2)**2)*(s-(xmsp1-xmsp2)**2))/2./srt
22001          if(idxsec.eq.1) then
22002             sdmsp=fs*pfinal/pinitial*3./16.*(xnnfactor*2.)
22003          elseif(idxsec.eq.2.or.idxsec.eq.4) then
22004             threshold=amax1(xmsp1+xmsp2,em1+em2)
22005             snew=(srt-threshold+srt0)**2
22006             if(idxsec.eq.2) then
22007                sdmsp=fnndpi(snew)*pfinal/pinitial*3./16.*(xnnfactor*2.)
22008             elseif(idxsec.eq.4) then
22009                sdmsp=fnndpi(snew)*pfinal/pinitial/6.
22010             endif
22011          elseif(idxsec.eq.3) then
22012             sdmsp=fs*pfinal/pinitial/6.
22013          endif
22014       endif
22015 c
22016 *     PP: DETERMINE THE CHARGE STATES OF PARTICLES IN THE FINAL STATE
22017       lbpp1=12+int(2*RANART(NSEED))
22018       lbpp2=12+int(2*RANART(NSEED))
22019       xmpp1=am1535
22020       xmpp2=am1535
22021       if(srt.gt.(xmpp1+xmpp2)) then
22022          pfinal=sqrt((s-(xmpp1+xmpp2)**2)*(s-(xmpp1-xmpp2)**2))/2./srt
22023          if(idxsec.eq.1) then
22024             sdmpp=fs*pfinal/pinitial*3./16.*xnnfactor
22025          elseif(idxsec.eq.2.or.idxsec.eq.4) then
22026             threshold=amax1(xmpp1+xmpp2,em1+em2)
22027             snew=(srt-threshold+srt0)**2
22028             if(idxsec.eq.2) then
22029                sdmpp=fnndpi(snew)*pfinal/pinitial*3./16.*xnnfactor
22030             elseif(idxsec.eq.4) then
22031                sdmpp=fnndpi(snew)*pfinal/pinitial/6.
22032             endif
22033          elseif(idxsec.eq.3) then
22034             sdmpp=fs*pfinal/pinitial/6.
22035          endif
22036       endif
22037 c
22038       sdm=sdmel+sdmnn+sdmnd+sdmns+sdmnp+sdmdd+sdmds+sdmdp
22039      1     +sdmss+sdmsp+sdmpp
22040       if(ianti.eq.1) then
22041          lbnn1=-lbnn1
22042          lbnn2=-lbnn2
22043          lbnd1=-lbnd1
22044          lbnd2=-lbnd2
22045          lbns1=-lbns1
22046          lbns2=-lbns2
22047          lbnp1=-lbnp1
22048          lbnp2=-lbnp2
22049          lbdd1=-lbdd1
22050          lbdd2=-lbdd2
22051          lbds1=-lbds1
22052          lbds2=-lbds2
22053          lbdp1=-lbdp1
22054          lbdp2=-lbdp2
22055          lbss1=-lbss1
22056          lbss2=-lbss2
22057          lbsp1=-lbsp1
22058          lbsp2=-lbsp2
22059          lbpp1=-lbpp1
22060          lbpp2=-lbpp2
22061       endif
22062 ctest off
22063 c      write(98,100) srt,sdmnn,sdmnd,sdmns,sdmnp,sdmdd,sdmds,sdmdp,
22064 c     1     sdmss,sdmsp,sdmpp,sdm
22065 c 100  format(f5.2,11(1x,f5.1))
22066 c
22067       return
22068       end
22069 c
22070 clin-9/2008 Deuteron+Meson ->B+B and elastic collisions
22071       SUBROUTINE crdmbb(PX,PY,PZ,SRT,I1,I2,IBLOCK,
22072      1     NTAG,sig,NT,ianti)
22073       PARAMETER (MAXSTR=150001,MAXR=1)
22074       COMMON /AA/R(3,MAXSTR)
22075       COMMON /BB/ P(3,MAXSTR)
22076       COMMON /BG/BETAX,BETAY,BETAZ,GAMMA
22077       COMMON /CC/ E(MAXSTR)
22078       COMMON /EE/ ID(MAXSTR),LB(MAXSTR)
22079       COMMON /AREVT/ IAEVT, IARUN, MISS
22080       common/leadng/lb1,px1,py1,pz1,em1,e1,xfnl,yfnl,zfnl,tfnl,
22081      1     px1n,py1n,pz1n,dp1n
22082       common /dpi/em2,lb2
22083       common /para8/ idpert,npertd,idxsec
22084       COMMON /dpert/dpertt(MAXSTR,MAXR),dpertp(MAXSTR),dplast(MAXSTR),
22085      1     dpdcy(MAXSTR),dpdpi(MAXSTR,MAXR),dpt(MAXSTR, MAXR),
22086      2     dpp1(MAXSTR,MAXR),dppion(MAXSTR,MAXR)
22087       common /dpifsl/lbnn1,lbnn2,lbnd1,lbnd2,lbns1,lbns2,lbnp1,lbnp2,
22088      1     lbdd1,lbdd2,lbds1,lbds2,lbdp1,lbdp2,lbss1,lbss2,
22089      2     lbsp1,lbsp2,lbpp1,lbpp2
22090       common /dpifsm/xmnn1,xmnn2,xmnd1,xmnd2,xmns1,xmns2,xmnp1,xmnp2,
22091      1     xmdd1,xmdd2,xmds1,xmds2,xmdp1,xmdp2,xmss1,xmss2,
22092      2     xmsp1,xmsp2,xmpp1,xmpp2
22093       common /dpisig/sdmel,sdmnn,sdmnd,sdmns,sdmnp,sdmdd,sdmds,sdmdp,
22094      1     sdmss,sdmsp,sdmpp
22095       COMMON/RNDF77/NSEED
22096       SAVE
22097 *-----------------------------------------------------------------------
22098       IBLOCK=0
22099       NTAG=0
22100       EM1=E(I1)
22101       EM2=E(I2)
22102       s=srt**2
22103       if(sig.le.0) return
22104 c
22105       if(iabs(lb1).eq.42) then
22106          ideut=i1
22107          lbm=lb2
22108          idm=i2
22109       else
22110          ideut=i2
22111          lbm=lb1
22112          idm=i1
22113       endif
22114 cccc  Elastic collision or destruction of perturbatively-produced deuterons:
22115       if((idpert.eq.1.or.idpert.eq.2).and.dpertp(ideut).ne.1.) then
22116 c     choose reaction channels:
22117          x1=RANART(NSEED)
22118          if(x1.le.sdmel/sig)then
22119 c     Elastic collisions:
22120 c            if(ianti.eq.0) then
22121 c               write(91,*) '  d+',lbm,' (pert d M elastic) @nt=',nt
22122 c     1              ,' @prob=',dpertp(ideut)
22123 c            else
22124 c               write(91,*) '  d+',lbm,' (pert dbar M elastic) @nt=',nt
22125 c     1              ,' @prob=',dpertp(ideut)
22126 c            endif
22127             pfinal=sqrt((s-(em1+em2)**2)*(s-(em1-em2)**2))/2./srt
22128             CALL dmelangle(pxn,pyn,pzn,pfinal)
22129             CALL ROTATE(PX,PY,PZ,Pxn,Pyn,Pzn)
22130             EdCM=SQRT(E(ideut)**2+Pxn**2+Pyn**2+Pzn**2)
22131             PdBETA=Pxn*BETAX+Pyn*BETAY+Pzn*BETAZ
22132             TRANSF=GAMMA*(GAMMA*PdBETA/(GAMMA+1.)+EdCM)
22133             Pt1d=BETAX*TRANSF+Pxn
22134             Pt2d=BETAY*TRANSF+Pyn
22135             Pt3d=BETAZ*TRANSF+Pzn
22136             p(1,ideut)=pt1d
22137             p(2,ideut)=pt2d
22138             p(3,ideut)=pt3d
22139             IBLOCK=504
22140             PX1=P(1,I1)
22141             PY1=P(2,I1)
22142             PZ1=P(3,I1)
22143             ID(I1)=2
22144             ID(I2)=2
22145 c     Change the position of the perturbative deuteron to that of
22146 c     the meson to avoid consecutive collisions between them:
22147             R(1,ideut)=R(1,idm)
22148             R(2,ideut)=R(2,idm)
22149             R(3,ideut)=R(3,idm)
22150          else
22151 c     Destruction of deuterons:
22152 c            if(ianti.eq.0) then
22153 c               write(91,*) '  d+',lbm,' ->BB (pert d destrn) @nt=',nt
22154 c     1              ,' @prob=',dpertp(ideut)
22155 c            else
22156 c               write(91,*) '  d+',lbm,' ->BB (pert dbar destrn) @nt=',nt
22157 c     1              ,' @prob=',dpertp(ideut)
22158 c            endif
22159             e(ideut)=0.
22160             IBLOCK=502
22161          endif
22162          return
22163       endif
22164 c
22165 cccc  Destruction of regularly-produced deuterons:
22166       IBLOCK=502
22167 c     choose final state and assign masses here:
22168       x1=RANART(NSEED)
22169       if(x1.le.sdmnn/sig)then
22170          lbb1=lbnn1
22171          lbb2=lbnn2
22172          xmb1=xmnn1
22173          xmb2=xmnn2
22174       elseif(x1.le.(sdmnn+sdmnd)/sig)then
22175          lbb1=lbnd1
22176          lbb2=lbnd2
22177          xmb1=xmnd1
22178          xmb2=xmnd2
22179       elseif(x1.le.(sdmnn+sdmnd+sdmns)/sig)then
22180          lbb1=lbns1
22181          lbb2=lbns2
22182          xmb1=xmns1
22183          xmb2=xmns2
22184       elseif(x1.le.(sdmnn+sdmnd+sdmns+sdmnp)/sig)then
22185          lbb1=lbnp1
22186          lbb2=lbnp2
22187          xmb1=xmnp1
22188          xmb2=xmnp2
22189       elseif(x1.le.(sdmnn+sdmnd+sdmns+sdmnp+sdmdd)/sig)then
22190          lbb1=lbdd1
22191          lbb2=lbdd2
22192          xmb1=xmdd1
22193          xmb2=xmdd2
22194       elseif(x1.le.(sdmnn+sdmnd+sdmns+sdmnp+sdmdd+sdmds)/sig)then
22195          lbb1=lbds1
22196          lbb2=lbds2
22197          xmb1=xmds1
22198          xmb2=xmds2
22199       elseif(x1.le.(sdmnn+sdmnd+sdmns+sdmnp+sdmdd+sdmds+sdmdp)/sig)then
22200          lbb1=lbdp1
22201          lbb2=lbdp2
22202          xmb1=xmdp1
22203          xmb2=xmdp2
22204       elseif(x1.le.(sdmnn+sdmnd+sdmns+sdmnp+sdmdd+sdmds+sdmdp
22205      1        +sdmss)/sig)then
22206          lbb1=lbss1
22207          lbb2=lbss2
22208          xmb1=xmss1
22209          xmb2=xmss2
22210       elseif(x1.le.(sdmnn+sdmnd+sdmns+sdmnp+sdmdd+sdmds+sdmdp
22211      1        +sdmss+sdmsp)/sig)then
22212          lbb1=lbsp1
22213          lbb2=lbsp2
22214          xmb1=xmsp1
22215          xmb2=xmsp2
22216       elseif(x1.le.(sdmnn+sdmnd+sdmns+sdmnp+sdmdd+sdmds+sdmdp
22217      1        +sdmss+sdmsp+sdmpp)/sig)then
22218          lbb1=lbpp1
22219          lbb2=lbpp2
22220          xmb1=xmpp1
22221          xmb2=xmpp2
22222       else
22223 c     Elastic collision:
22224          lbb1=lb1
22225          lbb2=lb2
22226          xmb1=em1
22227          xmb2=em2
22228          IBLOCK=504
22229       endif
22230       LB(I1)=lbb1
22231       E(i1)=xmb1
22232       LB(I2)=lbb2
22233       E(I2)=xmb2
22234       lb1=lb(i1)
22235       lb2=lb(i2)
22236       pfinal=sqrt((s-(xmb1+xmb2)**2)*(s-(xmb1-xmb2)**2))/2./srt
22237 c
22238       if(iblock.eq.502) then
22239          CALL dmangle(pxn,pyn,pzn,nt,ianti,pfinal,lbm)
22240       elseif(iblock.eq.504) then
22241 c         if(ianti.eq.0) then
22242 c            write (91,*) ' d+',lbm,' (regular d M elastic) @evt#',
22243 c     1           iaevt,' @nt=',nt,' lb1,2=',lb1,lb2
22244 c         else
22245 c            write (91,*) ' d+',lbm,' (regular dbar M elastic) @evt#',
22246 c     1           iaevt,' @nt=',nt,' lb1,2=',lb1,lb2
22247 c         endif
22248          CALL dmelangle(pxn,pyn,pzn,pfinal)
22249       else
22250          print *, 'Wrong iblock number in crdmbb()'
22251          stop
22252       endif
22253 *     ROTATE THE MOMENTA OF PARTICLES IN THE CMS OF P1+P2
22254 c     (This is not needed for isotropic distributions)
22255       CALL ROTATE(PX,PY,PZ,Pxn,Pyn,Pzn)
22256 *     LORENTZ-TRANSFORMATION OF THE MOMENTUM OF PARTICLES IN THE FINAL STATE
22257 *     FROM THE NUCLEUS-NUCLEUS CMS. FRAME INTO LAB FRAME:
22258 *     For the 1st baryon:
22259       E1CM=SQRT(E(I1)**2+Pxn**2+Pyn**2+Pzn**2)
22260       P1BETA=Pxn*BETAX+Pyn*BETAY+Pzn*BETAZ
22261       TRANSF=GAMMA*(GAMMA*P1BETA/(GAMMA+1.)+E1CM)
22262       Pt1i1=BETAX*TRANSF+Pxn
22263       Pt2i1=BETAY*TRANSF+Pyn
22264       Pt3i1=BETAZ*TRANSF+Pzn
22265 c
22266       p(1,i1)=pt1i1
22267       p(2,i1)=pt2i1
22268       p(3,i1)=pt3i1
22269 *     For the 2nd baryon:
22270       E2CM=SQRT(E(I2)**2+Pxn**2+Pyn**2+Pzn**2)
22271       P2BETA=-Pxn*BETAX-Pyn*BETAY-Pzn*BETAZ
22272       TRANSF=GAMMA*(GAMMA*P2BETA/(GAMMA+1.)+E2CM)
22273       Pt1I2=BETAX*TRANSF-Pxn
22274       Pt2I2=BETAY*TRANSF-Pyn
22275       Pt3I2=BETAZ*TRANSF-Pzn
22276 c
22277       p(1,i2)=pt1i2
22278       p(2,i2)=pt2i2
22279       p(3,i2)=pt3i2
22280 c
22281       PX1=P(1,I1)
22282       PY1=P(2,I1)
22283       PZ1=P(3,I1)
22284       EM1=E(I1)
22285       EM2=E(I2)
22286       ID(I1)=2
22287       ID(I2)=2
22288       RETURN
22289       END
22290 c
22291 c     Generate angular distribution of BB from d+meson in the CMS frame:
22292       subroutine dmangle(pxn,pyn,pzn,nt,ianti,pfinal,lbm)
22293       PARAMETER (PI=3.1415926)
22294       common/leadng/lb1,px1,py1,pz1,em1,e1,xfnl,yfnl,zfnl,tfnl,
22295      1     px1n,py1n,pz1n,dp1n
22296       common /dpi/em2,lb2
22297       COMMON /AREVT/ IAEVT, IARUN, MISS
22298       COMMON/RNDF77/NSEED
22299       SAVE
22300 c     take isotropic distribution for now:
22301       C1=1.0-2.0*RANART(NSEED)
22302       T1=2.0*PI*RANART(NSEED)
22303       S1=SQRT(1.0-C1**2)
22304       CT1=COS(T1)
22305       ST1=SIN(T1)
22306 * THE MOMENTUM IN THE CMS IN THE FINAL STATE
22307       Pzn=pfinal*C1
22308       Pxn=pfinal*S1*CT1
22309       Pyn=pfinal*S1*ST1
22310 clin-5/2008 track the number of regularly-destructed deuterons:
22311 c      if(ianti.eq.0) then
22312 c         write (91,*) ' d+',lbm,' ->BB (regular d destrn) @evt#',
22313 c     1        iaevt,' @nt=',nt,' lb1,2=',lb1,lb2
22314 c      else
22315 c         write (91,*) ' d+',lbm,' ->BB (regular dbar destrn) @evt#',
22316 c     1        iaevt,' @nt=',nt,' lb1,2=',lb1,lb2
22317 c      endif
22318 c
22319       return
22320       end
22321 c
22322 c     Angular distribution of d+meson elastic collisions in the CMS frame:
22323       subroutine dmelangle(pxn,pyn,pzn,pfinal)
22324       PARAMETER (PI=3.1415926)
22325       COMMON/RNDF77/NSEED
22326       SAVE
22327 c     take isotropic distribution for now:
22328       C1=1.0-2.0*RANART(NSEED)
22329       T1=2.0*PI*RANART(NSEED)
22330       S1=SQRT(1.0-C1**2)
22331       CT1=COS(T1)
22332       ST1=SIN(T1)
22333 * THE MOMENTUM IN THE CMS IN THE FINAL STATE
22334       Pzn=pfinal*C1
22335       Pxn=pfinal*S1*CT1
22336       Pyn=pfinal*S1*ST1
22337       return
22338       end
22339 c
22340 clin-9/2008 Deuteron+Baryon elastic cross section (in mb)
22341       subroutine sdbelastic(SRT,sdb)
22342       PARAMETER (srt0=2.012)
22343       common/leadng/lb1,px1,py1,pz1,em1,e1,xfnl,yfnl,zfnl,tfnl,
22344      1     px1n,py1n,pz1n,dp1n
22345       common /dpi/em2,lb2
22346       common /para8/ idpert,npertd,idxsec
22347       SAVE
22348 c
22349       sdb=0.
22350       sdbel=0.
22351       if(srt.le.(em1+em2)) return
22352       s=srt**2
22353 c     For elastic collisions:
22354       if(idxsec.eq.1.or.idxsec.eq.3) then
22355 c     1/3: assume the same |matrix element|**2 (after averaging over initial
22356 c     spins and isospins) for d+Baryon elastic at the same sqrt(s);
22357          sdbel=fdbel(s)
22358       elseif(idxsec.eq.2.or.idxsec.eq.4) then
22359 c     2/4: assume the same |matrix element|**2 (after averaging over initial
22360 c     spins and isospins) for d+Baryon elastic at the same sqrt(s)-threshold:
22361          threshold=em1+em2
22362          snew=(srt-threshold+srt0)**2
22363          sdbel=fdbel(snew)
22364       endif
22365       sdb=sdbel
22366       return
22367       end
22368 clin-9/2008 Deuteron+Baryon elastic collisions
22369       SUBROUTINE crdbel(PX,PY,PZ,SRT,I1,I2,IBLOCK,
22370      1     NTAG,sig,NT,ianti)
22371       PARAMETER (MAXSTR=150001,MAXR=1)
22372       COMMON /AA/R(3,MAXSTR)
22373       COMMON /BB/ P(3,MAXSTR)
22374       COMMON /BG/BETAX,BETAY,BETAZ,GAMMA
22375       COMMON /CC/ E(MAXSTR)
22376       COMMON /EE/ ID(MAXSTR),LB(MAXSTR)
22377       COMMON /AREVT/ IAEVT, IARUN, MISS
22378       common/leadng/lb1,px1,py1,pz1,em1,e1,xfnl,yfnl,zfnl,tfnl,
22379      1     px1n,py1n,pz1n,dp1n
22380       common /dpi/em2,lb2
22381       common /para8/ idpert,npertd,idxsec
22382       COMMON /dpert/dpertt(MAXSTR,MAXR),dpertp(MAXSTR),dplast(MAXSTR),
22383      1     dpdcy(MAXSTR),dpdpi(MAXSTR,MAXR),dpt(MAXSTR, MAXR),
22384      2     dpp1(MAXSTR,MAXR),dppion(MAXSTR,MAXR)
22385       SAVE
22386 *-----------------------------------------------------------------------
22387       IBLOCK=0
22388       NTAG=0
22389       EM1=E(I1)
22390       EM2=E(I2)
22391       s=srt**2
22392       if(sig.le.0) return
22393       IBLOCK=503
22394 c
22395       if(iabs(lb1).eq.42) then
22396          ideut=i1
22397          lbb=lb2
22398          idb=i2
22399       else
22400          ideut=i2
22401          lbb=lb1
22402          idb=i1
22403       endif
22404 cccc  Elastic collision of perturbatively-produced deuterons:
22405       if((idpert.eq.1.or.idpert.eq.2).and.dpertp(ideut).ne.1.) then
22406 c         if(ianti.eq.0) then
22407 c            write(91,*) '  d+',lbb,' (pert d B elastic) @nt=',nt
22408 c     1           ,' @prob=',dpertp(ideut),p(1,idb),p(2,idb)
22409 c     2           ,p(1,ideut),p(2,ideut)
22410 c         else
22411 c            write(91,*) '  d+',lbb,' (pert dbar Bbar elastic) @nt=',nt
22412 c     1           ,' @prob=',dpertp(ideut),p(1,idb),p(2,idb)
22413 c     2           ,p(1,ideut),p(2,ideut)
22414 c         endif
22415          pfinal=sqrt((s-(em1+em2)**2)*(s-(em1-em2)**2))/2./srt
22416          CALL dbelangle(pxn,pyn,pzn,pfinal)
22417          CALL ROTATE(PX,PY,PZ,Pxn,Pyn,Pzn)
22418          EdCM=SQRT(E(ideut)**2+Pxn**2+Pyn**2+Pzn**2)
22419          PdBETA=Pxn*BETAX+Pyn*BETAY+Pzn*BETAZ
22420          TRANSF=GAMMA*(GAMMA*PdBETA/(GAMMA+1.)+EdCM)
22421          Pt1d=BETAX*TRANSF+Pxn
22422          Pt2d=BETAY*TRANSF+Pyn
22423          Pt3d=BETAZ*TRANSF+Pzn
22424          p(1,ideut)=pt1d
22425          p(2,ideut)=pt2d
22426          p(3,ideut)=pt3d
22427          PX1=P(1,I1)
22428          PY1=P(2,I1)
22429          PZ1=P(3,I1)
22430          ID(I1)=2
22431          ID(I2)=2
22432 c     Change the position of the perturbative deuteron to that of
22433 c     the baryon to avoid consecutive collisions between them:
22434          R(1,ideut)=R(1,idb)
22435          R(2,ideut)=R(2,idb)
22436          R(3,ideut)=R(3,idb)
22437          return
22438       endif
22439 c
22440 c     Elastic collision of regularly-produced deuterons:
22441 c      if(ianti.eq.0) then
22442 c         write (91,*) ' d+',lbb,' (regular d B elastic) @evt#',
22443 c     1        iaevt,' @nt=',nt,' lb1,2=',lb1,lb2
22444 c      else
22445 c         write (91,*) ' d+',lbb,' (regular dbar Bbar elastic) @evt#',
22446 c     1        iaevt,' @nt=',nt,' lb1,2=',lb1,lb2
22447 c      endif
22448       pfinal=sqrt((s-(em1+em2)**2)*(s-(em1-em2)**2))/2./srt
22449       CALL dbelangle(pxn,pyn,pzn,pfinal)
22450 *     ROTATE THE MOMENTA OF PARTICLES IN THE CMS OF P1+P2
22451 c     (This is not needed for isotropic distributions)
22452       CALL ROTATE(PX,PY,PZ,Pxn,Pyn,Pzn)
22453 *     LORENTZ-TRANSFORMATION OF THE MOMENTUM OF PARTICLES IN THE FINAL STATE
22454 *     FROM THE NUCLEUS-NUCLEUS CMS. FRAME INTO LAB FRAME:
22455 *     For the 1st baryon:
22456       E1CM=SQRT(E(I1)**2+Pxn**2+Pyn**2+Pzn**2)
22457       P1BETA=Pxn*BETAX+Pyn*BETAY+Pzn*BETAZ
22458       TRANSF=GAMMA*(GAMMA*P1BETA/(GAMMA+1.)+E1CM)
22459       Pt1i1=BETAX*TRANSF+Pxn
22460       Pt2i1=BETAY*TRANSF+Pyn
22461       Pt3i1=BETAZ*TRANSF+Pzn
22462 c
22463       p(1,i1)=pt1i1
22464       p(2,i1)=pt2i1
22465       p(3,i1)=pt3i1
22466 *     For the 2nd baryon:
22467       E2CM=SQRT(E(I2)**2+Pxn**2+Pyn**2+Pzn**2)
22468       P2BETA=-Pxn*BETAX-Pyn*BETAY-Pzn*BETAZ
22469       TRANSF=GAMMA*(GAMMA*P2BETA/(GAMMA+1.)+E2CM)
22470       Pt1I2=BETAX*TRANSF-Pxn
22471       Pt2I2=BETAY*TRANSF-Pyn
22472       Pt3I2=BETAZ*TRANSF-Pzn
22473 c
22474       p(1,i2)=pt1i2
22475       p(2,i2)=pt2i2
22476       p(3,i2)=pt3i2
22477 c
22478       PX1=P(1,I1)
22479       PY1=P(2,I1)
22480       PZ1=P(3,I1)
22481       EM1=E(I1)
22482       EM2=E(I2)
22483       ID(I1)=2
22484       ID(I2)=2
22485       RETURN
22486       END
22487 c
22488 c     Part of the cross section function of NN->Deuteron+Pi (in mb):
22489       function fnndpi(s)
22490       parameter(srt0=2.012)
22491       if(s.le.srt0**2) then
22492          fnndpi=0.
22493       else
22494          fnndpi=26.*exp(-(s-4.65)**2/0.1)+4.*exp(-(s-4.65)**2/2.)
22495      1        +0.28*exp(-(s-6.)**2/10.)
22496       endif
22497       return
22498       end
22499 c
22500 c     Angular distribution of d+baryon elastic collisions in the CMS frame:
22501       subroutine dbelangle(pxn,pyn,pzn,pfinal)
22502       PARAMETER (PI=3.1415926)
22503       COMMON/RNDF77/NSEED
22504       SAVE
22505 c     take isotropic distribution for now:
22506       C1=1.0-2.0*RANART(NSEED)
22507       T1=2.0*PI*RANART(NSEED)
22508       S1=SQRT(1.0-C1**2)
22509       CT1=COS(T1)
22510       ST1=SIN(T1)
22511 * THE MOMENTUM IN THE CMS IN THE FINAL STATE
22512       Pzn=pfinal*C1
22513       Pxn=pfinal*S1*CT1
22514       Pyn=pfinal*S1*ST1
22515       return
22516       end
22517 c
22518 c     Cross section of Deuteron+Pi elastic (in mb):
22519       function fdpiel(s)
22520       parameter(srt0=2.012)
22521       if(s.le.srt0**2) then
22522          fdpiel=0.
22523       else
22524          fdpiel=63.*exp(-(s-4.67)**2/0.15)+15.*exp(-(s-6.25)**2/0.3)
22525       endif
22526       return
22527       end
22528 c
22529 c     Cross section of Deuteron+N elastic (in mb):
22530       function fdbel(s)
22531       parameter(srt0=2.012)
22532       if(s.le.srt0**2) then
22533          fdbel=0.
22534       else
22535          fdbel=2500.*exp(-(s-7.93)**2/0.003)
22536      1        +300.*exp(-(s-7.93)**2/0.1)+10.
22537       endif
22538       return
22539       end