Project CMSSW displayed by LXR CMSSW_14_1_X_2024-07-25-2300/​GeneratorInterface/​AMPTInterface/​src/​art1f.f	Source navigation Diff markup Identifier search General search
	Version: CMSSW_14_1_X_2024-07-25-2300 CMSSW_14_1_X_2024-07-24-2300 CMSSW_14_1_X_2024-07-23-2300 CMSSW_14_1_X_2024-07-22-2300 CMSSW_14_1_X_2024-07-21-2300 Revert   Change

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

 c....................art1f.f
 **************************************
 *
 *                           PROGRAM ART1.0 
 *
 *        A relativistic transport (ART) model for heavy-ion collisions
 *
 *   sp/01/04/2002
 *   calculates K+K- from phi decay, dimuons from phi decay
 *   has finite baryon density & possibilites of varying Kaon 
 *   in-medium mass in phiproduction-annhilation channel only.
 *
 *
 * RELEASING DATE: JAN., 1997 
 ***************************************
 * 
 * Bao-An Li & Che Ming Ko
 * Cyclotron Institute, Texas A&M University.
 * Phone: (409) 845-1411
 * e-mail: Bali@comp.tamu.edu & Ko@comp.tamu.edu 
 * http://wwwcyc.tamu.edu/~bali
 ***************************************
 * Speical notice on the limitation of the code:
 * 
 * (1) ART is a hadronic transport model
 * 
 * (2) E_beam/A <= 15 GeV
 * 
 * (3) The mass of the colliding system is limited by the dimensions of arrays
 *    which can be extended purposely. Presently the dimensions are large enough
 *     for running Au+Au at 15 GeV/A.
 *
 * (4) The production and absorption of antiparticles (e.g., ki-, anti-nucleons,
 *     etc) are not fully included in this version of the model. They, however, 
 *     have essentially no effect on the reaction dynamics and observables 
 *     related to nucleons, pions and kaons (K+) at and below AGS energies.
 * 
 * (5) Bose enhancement for mesons and Pauli blocking for fermions are 
 *     turned off.
 * 
 *********************************
 *
 * USEFUL REFERENCES ON PHYSICS AND NUMERICS OF NUCLEAR TRANSPORT MODELS:
 *     G.F. BERTSCH AND DAS GUPTA, PHYS. REP. 160 (1988) 189.
 *     B.A. LI AND W. BAUER, PHYS. REV. C44 (1991) 450.
 *     B.A. LI, W. BAUER AND G.F. BERTSCH, PHYS. REV. C44 (1991) 2095.
 *     P. DANIELEWICZ AND G.F. BERTSCH, NUCL. PHYS. A533 (1991) 712.
 * 
 * MAIN REFERENCES ON THIS VERSION OF ART MODEL:
 *     B.A. LI AND C.M. KO, PHYS. REV. C52 (1995) 2037; 
 *                          NUCL. PHYS. A601 (1996) 457. 
 *
 **********************************
 **********************************
 *  VARIABLES IN INPUT-SECTION:                                               * 
 *                                                                      *
 *  1) TARGET-RELATED QUANTITIES                                        *
 *       MASSTA, ZTA -  TARGET MASS IN AMU, TARGET CHARGE  (INTEGER)    *
 *                                                                      *
 *  2) PROJECTILE-RELATED QUANTITIES                                    *
 *       MASSPR, ZPR -  PROJECTILE MASS IN AMU, PROJ. CHARGE(INTEGER)   *
 *       ELAB     -  BEAM ENERGY IN [MEV/NUCLEON]               (REAL)  *
 *       ZEROPT   -  DISPLACEMENT OF THE SYSTEM IN Z-DIREC. [FM](REAL)  *
 *       B        -  IMPACT PARAMETER [FM]                      (REAL)  *
 *                                                                      *
 *  3) PROGRAM-CONTROL PARAMETERS                                       *
 *       ISEED    -  SEED FOR RANDOM NUMBER GENERATOR        (INTEGER)  *
 *       DT       -  TIME-STEP-SIZE [FM/C]                      (REAL)  *
 *       NTMAX    -  TOTAL NUMBER OF TIMESTEPS               (INTEGER)  *
 *       ICOLL    -  (= 1 -> MEAN FIELD ONLY,                           *
 *                -   =-1 -> CACADE ONLY, ELSE FULL ART)     (INTEGER)  *
 *       NUM      -  NUMBER OF TESTPARTICLES PER NUCLEON     (INTEGER)  *
 *       INSYS    -  (=0 -> LAB-SYSTEM, ELSE C.M. SYSTEM)    (INTEGER)  *
 *       IPOT     -  1 -> SIGMA=2; 2 -> SIGMA=4/3; 3 -> SIGMA=7/6       *
 *                   IN MEAN FIELD POTENTIAL                 (INTEGER)  *
 *       MODE     -  (=1 -> interpolation for pauli-blocking,           *
 *                    =2 -> local lookup, other -> unblocked)(integer)  *
 *       DX,DY,DZ -  widths of cell for paulat in coor. sp. [fm](real)  *
 *       DPX,DPY,DPZ-widths of cell for paulat in mom. sp.[GeV/c](real) *
 *       IAVOID   -  (=1 -> AVOID FIRST COLL. WITHIN SAME NUCL.         *
 *                    =0 -> ALLOW THEM)                      (INTEGER)  *
 *       IMOMEN   -  FLAG FOR CHOICE OF INITIAL MOMENTUM DISTRIBUTION   *
 *                   (=1 -> WOODS-SAXON DENSITY AND LOCAL THOMAS-FERMI  *
 *                    =2 -> NUCLEAR MATTER DEN. AND LOCAL THOMAS-FERMI  *
 *                    =3 -> COHERENT BOOST IN Z-DIRECTION)   (INTEGER)  *
 *  4) CONTROL-PRINTOUT OPTIONS                                         *
 *       NFREQ    -  NUMBER OF TIMSTEPS AFTER WHICH PRINTOUT            *
 *                   IS REQUIRED OR ON-LINE ANALYSIS IS PERFORMED       *
 *       ICFLOW      =1 PERFORM ON-LINE FLOW ANALYSIS EVERY NFREQ STEPS *
 *       ICRHO       =1 PRINT OUT THE BARYON,PION AND ENERGY MATRIX IN  *
 *                      THE REACTION PLANE EVERY NFREQ TIME-STEPS       *
 *  5)
 *       CYCBOX   -  ne.0 => cyclic boundary conditions;boxsize CYCBOX  *
 *
 **********************************
 *               Lables of particles used in this code                     *
 **********************************
 *         
 *         LB(I) IS USED TO LABEL PARTICLE'S CHARGE STATE
 *    
 *         LB(I)   =
 clin-11/07/00:
 *                -30 K*-
 clin-8/29/00
 *                -13 anti-N*(+1)(1535),s_11
 *                -12 anti-N*0(1535),s_11
 *                 -11 anti-N*(+1)(1440),p_11
 *                 -10 anti-N*0(1440), p_11
 *                  -9 anti-DELTA+2
 *                  -8 anti-DELTA+1
 *                  -7 anti-DELTA0
 *                  -6 anti-DELTA-1
 clin-8/29/00-end
 
 cbali2/7/99 
 *                  -2 antineutron 
 *                             -1       antiproton
 cbali2/7/99 end 
 *                   0 eta
 *                        1 PROTON
 *                   2 NUETRON
 *                   3 PION-
 *                   4 PION0
 *                   5 PION+
 *                   6 DELTA-1
 *                   7 DELTA0
 *                   8 DELTA+1
 *                   9 DELTA+2
 *                   10 N*0(1440), p_11
 *                   11 N*(+1)(1440),p_11
 *                  12 N*0(1535),s_11
 *                  13 N*(+1)(1535),s_11
 *                  14 LAMBDA
 *                   15 sigma-, since we used isospin averaged xsection for
 *                   16 sigma0  sigma associated K+ production, sigma0 and 
 *                   17 sigma+  sigma+ are counted as sigma-
 *                   21 kaon-
 *                   23 KAON+
 *                   24 kaon0
 *                   25 rho-
 *                         26 rho0
 *                   27 rho+
 *                   28 omega meson
 *                   29 phi
 clin-11/07/00:
 *                  30 K*+
 * sp01/03/01
 *                 -14 LAMBDA(bar)
 *                  -15 sigma-(bar)
 *                  -16 sigma0(bar)
 *                  -17 sigma+(bar)
 *                   31 eta-prime
 *                   40 cascade-
 *                  -40 cascade-(bar)
 *                   41 cascade0
 *                  -41 cascade0(bar)
 *                   45 Omega baryon
 *                  -45 Omega baryon(bar)
 * sp01/03/01 end
 clin-5/2008:
 *                   42 Deuteron (same in ampt.dat)
 *                  -42 anti-Deuteron (same in ampt.dat)
 c
 *                   ++  ------- SEE BAO-AN LI'S NOTE BOOK
 **********************************
 cbz11/16/98
 c      PROGRAM ART
        SUBROUTINE ARTMN
 cbz11/16/98end
 **********************************
 * PARAMETERS:                                                           *
 *  MAXPAR     - MAXIMUM NUMBER OF PARTICLES      PROGRAM CAN HANDLE     *
 *  MAXP       - MAXIMUM NUMBER OF CREATED MESONS PROGRAM CAN HANDLE     *
 *  MAXR       - MAXIMUM NUMBER OF EVENTS AT EACH IMPACT PARAMETER       *
 *  MAXX       - NUMBER OF MESHPOINTS IN X AND Y DIRECTION = 2 MAXX + 1  *
 *  MAXZ       - NUMBER OF MESHPOINTS IN Z DIRECTION       = 2 MAXZ + 1  *
 *  AMU        - 1 ATOMIC MASS UNIT "GEV/C**2"                           *
 *  MX,MY,MZ   - MESH SIZES IN COORDINATE SPACE [FM] FOR PAULI LATTICE   *
 *  MPX,MPY,MPZ- MESH SIZES IN MOMENTUM SPACE [GEV/C] FOR PAULI LATTICE  *
 *---------------------------------------------------------------------- *
 clin      PARAMETER     (maxpar=200000,MAXR=50,AMU= 0.9383,
       PARAMETER     (MAXSTR=150001,MAXR=1,AMU= 0.9383,
      1               AKA=0.498,etaM=0.5475)
       PARAMETER     (MAXX   =   20,  MAXZ  =    24)
       PARAMETER     (ISUM   =   1001,  IGAM  =    1100)
       parameter     (MX=4,MY=4,MZ=8,MPX=4,MPY=4,mpz=10,mpzp=10)
 clin      PARAMETER (MAXP = 14000)
 *----------------------------------------------------------------------*
       INTEGER   OUTPAR, zta,zpr
       COMMON  /AA/      R(3,MAXSTR)
 cc      SAVE /AA/
       COMMON  /BB/      P(3,MAXSTR)
 cc      SAVE /BB/
       COMMON  /CC/      E(MAXSTR)
 cc      SAVE /CC/
       COMMON  /DD/      RHO(-MAXX:MAXX,-MAXX:MAXX,-MAXZ:MAXZ),
      &                     RHOP(-MAXX:MAXX,-MAXX:MAXX,-MAXZ:MAXZ),
      &                     RHON(-MAXX:MAXX,-MAXX:MAXX,-MAXZ:MAXZ)
 cc      SAVE /DD/
       COMMON  /EE/      ID(MAXSTR),LB(MAXSTR)
 cc      SAVE /EE/
       COMMON  /HH/  PROPER(MAXSTR)
 cc      SAVE /HH/
       common  /ff/f(-mx:mx,-my:my,-mz:mz,-mpx:mpx,-mpy:mpy,-mpz:mpzp)
 cc      SAVE /ff/
       common  /gg/      dx,dy,dz,dpx,dpy,dpz
 cc      SAVE /gg/
       COMMON  /INPUT/ NSTAR,NDIRCT,DIR
 cc      SAVE /INPUT/
       COMMON  /PP/      PRHO(-20:20,-24:24)
       COMMON  /QQ/      PHRHO(-MAXZ:MAXZ,-24:24)
       COMMON  /RR/      MASSR(0:MAXR)
 cc      SAVE /RR/
       common  /ss/      inout(20)
 cc      SAVE /ss/
       common  /zz/      zta,zpr
 cc      SAVE /zz/
       COMMON  /RUN/     NUM
 cc      SAVE /RUN/
 clin-4/2008:
 c      COMMON  /KKK/     TKAON(7),EKAON(7,0:200)
       COMMON  /KKK/     TKAON(7),EKAON(7,0:2000)
 cc      SAVE /KKK/
       COMMON  /KAON/    AK(3,50,36),SPECK(50,36,7),MF
 cc      SAVE /KAON/
       COMMON/TABLE/ xarray(0:1000),earray(0:1000)
 cc      SAVE /TABLE/
       common/input1/ MASSPR,MASSTA,ISEED,IAVOID,DT
 cc      SAVE /input1/
       COMMON  /DDpi/    piRHO(-MAXX:MAXX,-MAXX:MAXX,-MAXZ:MAXZ)
 cc      SAVE /DDpi/
       common  /tt/  PEL(-maxx:maxx,-maxx:maxx,-maxz:maxz)
      &,rxy(-maxx:maxx,-maxx:maxx,-maxz:maxz)
 cc      SAVE /tt/
 clin-4/2008:
 c      DIMENSION TEMP(3,MAXSTR),SKAON(7),SEKAON(7,0:200)
       DIMENSION TEMP(3,MAXSTR),SKAON(7),SEKAON(7,0:2000)
 cbz12/2/98
       COMMON /INPUT2/ ILAB, MANYB, NTMAX, ICOLL, INSYS, IPOT, MODE, 
      &   IMOMEN, NFREQ, ICFLOW, ICRHO, ICOU, KPOTEN, KMUL
 cc      SAVE /INPUT2/
       COMMON /INPUT3/ PLAB, ELAB, ZEROPT, B0, BI, BM, DENCUT, CYCBOX
 cc      SAVE /INPUT3/
 cbz12/2/98end
 cbz11/16/98
       COMMON /ARPRNT/ ARPAR1(100), IAPAR2(50), ARINT1(100), IAINT2(50)
 cc      SAVE /ARPRNT/
 
 c.....note in the below, since a common block in ART is called EE,
 c.....the variable EE in /ARPRC/is changed to PEAR.
 clin-9/29/03 changed name in order to distinguish from /prec2/
 c        COMMON /ARPRC/ ITYPAR(MAXSTR),
 c     &       GXAR(MAXSTR), GYAR(MAXSTR), GZAR(MAXSTR), FTAR(MAXSTR),
 c     &       PXAR(MAXSTR), PYAR(MAXSTR), PZAR(MAXSTR), PEAR(MAXSTR),
 c     &       XMAR(MAXSTR)
 cc      SAVE /ARPRC/
 clin-9/29/03-end
       COMMON /ARERCP/PRO1(MAXSTR, MAXR)
 cc      SAVE /ARERCP/
       COMMON /ARERC1/MULTI1(MAXR)
 cc      SAVE /ARERC1/
       COMMON /ARPRC1/ITYP1(MAXSTR, MAXR),
      &     GX1(MAXSTR, MAXR), GY1(MAXSTR, MAXR), GZ1(MAXSTR, MAXR), 
      &     FT1(MAXSTR, MAXR),
      &     PX1(MAXSTR, MAXR), PY1(MAXSTR, MAXR), PZ1(MAXSTR, MAXR),
      &     EE1(MAXSTR, MAXR), XM1(MAXSTR, MAXR)
 cc      SAVE /ARPRC1/
 c
       DIMENSION NPI(MAXR)
       DIMENSION RT(3, MAXSTR, MAXR), PT(3, MAXSTR, MAXR)
      &     , ET(MAXSTR, MAXR), LT(MAXSTR, MAXR), PROT(MAXSTR, MAXR)
 
       EXTERNAL IARFLV, INVFLV
 cbz11/16/98end
       common /lastt/itimeh,bimp 
 cc      SAVE /lastt/
       common/snn/efrm,npart1,npart2,epsiPz,epsiPt,PZPROJ,PZTARG
 cc      SAVE /snn/
       COMMON/hbt/lblast(MAXSTR),xlast(4,MAXSTR),plast(4,MAXSTR),nlast
 cc      SAVE /hbt/
       common/resdcy/NSAV,iksdcy
 cc      SAVE /resdcy/
       COMMON/RNDF77/NSEED
 cc      SAVE /RNDF77/
       COMMON/FTMAX/ftsv(MAXSTR),ftsvt(MAXSTR, MAXR)
       COMMON /dpert/dpertt(MAXSTR,MAXR),dpertp(MAXSTR),dplast(MAXSTR),
      1     dpdcy(MAXSTR),dpdpi(MAXSTR,MAXR),dpt(MAXSTR, MAXR),
      2     dpp1(MAXSTR,MAXR),dppion(MAXSTR,MAXR)
       COMMON/HPARNT/HIPR1(100),IHPR2(50),HINT1(100),IHNT2(50)
 clin-4/2008 zet() expanded to avoid out-of-bound errors:
       real zet(-45:45)
       SAVE   
       data zet /
      4     1.,0.,0.,0.,0.,
      3     1.,0.,0.,0.,0.,0.,0.,0.,0.,0.,
      2     -1.,0.,0.,0.,0.,0.,0.,0.,0.,0.,
      1     0.,0.,0.,-1.,0.,1.,0.,-1.,0.,-1.,
      s     0.,-2.,-1.,0.,1.,0.,0.,0.,0.,-1.,
      e     0.,
      s     1.,0.,-1.,0.,1.,-1.,0.,1.,2.,0.,
      1     1.,0.,1.,0.,-1.,0.,1.,0.,0.,0.,
      2     -1.,0.,1.,0.,-1.,0.,1.,0.,0.,1.,
      3     0.,0.,0.,0.,0.,0.,0.,0.,0.,-1.,
      4     0.,0.,0.,0.,-1./
 
       nlast=0
       do 1002 i=1,MAXSTR
          ftsv(i)=0.
          do 1101 irun=1,maxr
             ftsvt(i,irun)=0.
  1101    continue
          lblast(i)=999
          do 1001 j=1,4
 clin-4/2008 bugs pointed out by Vander Molen & Westfall:
 c            xlast(i,j)=0.
 c            plast(i,j)=0.
             xlast(j,i)=0.
             plast(j,i)=0.
  1001    continue
  1002 continue
 
 *-------------------------------------------------------------------*
 * Input information about the reaction system and contral parameters* 
 *-------------------------------------------------------------------*
 *              input section starts here                           *
 *-------------------------------------------------------------------*
 
 cbz12/2/98
 c.....input section is moved to subroutine ARTSET
 cbz12/2/98end
 
 *-----------------------------------------------------------------------*
 *                   input section ends here                            *
 *-----------------------------------------------------------------------*
 * read in the table for gengrating the transverse momentum
 * IN THE NN-->DDP PROCESS
        call tablem
 * several control parameters, keep them fixed in this code. 
        ikaon=1
        nstar=1
        ndirct=0
        dir=0.02
        asy=0.032
        ESBIN=0.04
        MF=36
 *----------------------------------------------------------------------*
 c      CALL FRONT(12,MASSTA,MASSPR,ELAB)
 *----------------------------------------------------------------------*
       RADTA  = 1.124 * FLOAT(MASSTA)**(1./3.)
       RADPR  = 1.124 * FLOAT(MASSPR)**(1./3.)
       ZDIST  = RADTA + RADPR
 c      if ( cycbox.ne.0 ) zdist=0
       BMAX   = RADTA + RADPR
       MASS   = MASSTA + MASSPR
       NTOTAL = NUM * MASS
 *
       IF (NTOTAL .GT. MAXSTR) THEN
         WRITE(12,'(//10X,''**** FATAL ERROR: TOO MANY TEST PART. ****'//
      & ' '')')
         STOP
       END IF
 *
 *-----------------------------------------------------------------------
 *       RELATIVISTIC KINEMATICS
 *
 *       1) LABSYSTEM
 *
       ETA    = FLOAT(MASSTA) * AMU
       PZTA   = 0.0
       BETATA = 0.0
       GAMMTA = 1.0
 *
       EPR    = FLOAT(MASSPR) * (AMU + 0.001 * ELAB)
       PZPR   = SQRT( EPR**2 - (AMU * FLOAT(MASSPR))**2 )
       BETAPR = PZPR / EPR
       GAMMPR = 1.0 / SQRT( 1.0 - BETAPR**2 )
 *
 * BETAC AND GAMMAC OF THE C.M. OBSERVED IN THE LAB. FRAME
         BETAC=(PZPR+PZTA)/(EPR+ETA)
         GAMMC=1.0 / SQRT(1.-BETAC**2)
 *
 c      WRITE(12,'(/10x,''****    KINEMATICAL PARAMETERS    ****''/)')
 c      WRITE(12,'(10x,''1) LAB-FRAME:        TARGET PROJECTILE'')')
 c      WRITE(12,'(10x,''   ETOTAL "GEV" '',2F11.4)') ETA, EPR
 c      WRITE(12,'(10x,''   P "GEV/C"    '',2F11.4)') PZTA, PZPR
 c      WRITE(12,'(10x,''   BETA         '',2F11.4)') BETATA, BETAPR
 c      WRITE(12,'(10x,''   GAMMA        '',2F11.4)') GAMMTA, GAMMPR
       IF (INSYS .NE. 0) THEN
 *
 *       2) C.M. SYSTEM
 *
         S      = (EPR+ETA)**2 - PZPR**2
         xx1=4.*alog(float(massta))
         xx2=4.*alog(float(masspr))
         xx1=exp(xx1)
         xx2=exp(xx2)
         PSQARE = (S**2 + (xx1+ xx2) * AMU**4
      &             - 2.0 * S * AMU**2 * FLOAT(MASSTA**2 + MASSPR**2)
      &             - 2.0 * FLOAT(MASSTA**2 * MASSPR**2) * AMU**4)
      &           / (4.0 * S)
 *
         ETA    = SQRT ( PSQARE + (FLOAT(MASSTA) * AMU)**2 )
         PZTA   = - SQRT(PSQARE)
         BETATA = PZTA / ETA
         GAMMTA = 1.0 / SQRT( 1.0 - BETATA**2 )
 *
         EPR    = SQRT ( PSQARE + (FLOAT(MASSPR) * AMU)**2 )
         PZPR   = SQRT(PSQARE)
         BETAPR = PZPR/ EPR
         GAMMPR = 1.0 / SQRT( 1.0 - BETAPR**2 )
 *
 c        WRITE(12,'(10x,''2) C.M.-FRAME:  '')')
 c        WRITE(12,'(10x,''   ETOTAL "GEV" '',2F11.4)') ETA, EPR
 c        WRITE(12,'(10x,''   P "GEV/C"    '',2F11.4)') PZTA, PZPR
 c        WRITE(12,'(10x,''   BETA         '',2F11.4)') BETATA, BETAPR
 c        WRITE(12,'(10x,''   GAMMA        '',2F11.4)') GAMMTA, GAMMPR
 c        WRITE(12,'(10x,''S "GEV**2"      '',F11.4)')  S
 c        WRITE(12,'(10x,''PSQARE "GEV/C"2 '',E14.3)')  PSQARE
 c        WRITE(12,'(/10x,''*** CALCULATION DONE IN CM-FRAME ***''/)')
       ELSE
 c        WRITE(12,'(/10x,''*** CALCULATION DONE IN LAB-FRAME ***''/)')
       END IF
 * MOMENTUM PER PARTICLE
       PZTA = PZTA / FLOAT(MASSTA)
       PZPR = PZPR / FLOAT(MASSPR)
 * total initial energy in the N-N cms frame
       ECMS0=ETA+EPR
 *-----------------------------------------------------------------------
 *
 * Start loop over many runs of different impact parameters
 * IF MANYB=1, RUN AT A FIXED IMPACT PARAMETER B0, OTHERWISE GENERATE 
 * MINIMUM BIAS EVENTS WITHIN THE IMPACT PARAMETER RANGE OF B_MIN AND B_MAX
        DO 50000 IMANY=1,MANYB
 *------------------------------------------------------------------------
 * Initialize the impact parameter B
        if (manyb. gt.1) then
 111       BX=1.0-2.0*RANART(NSEED)
        BY=1.0-2.0*RANART(NSEED)
        B2=BX*BX+BY*BY
        IF(B2.GT.1.0) GO TO 111       
        B=SQRT(B2)*(BM-BI)+BI
        ELSE
        B=B0
        ENDIF
 c      WRITE(12,'(///10X,''RUN NUMBER:'',I6)') IMANY       
 c      WRITE(12,'(//10X,''IMPACT PARAMETER B FOR THIS RUN:'',
 c     &             F9.3,'' FM''/10X,49(''*'')/)') B
 *
 *-----------------------------------------------------------------------
 *       INITIALIZATION
 *1 INITIALIZATION IN ISOSPIN SPACE FOR BOTH THE PROJECTILE AND TARGET
       call coulin(masspr,massta,NUM)
 *2 INITIALIZATION IN PHASE SPACE FOR THE TARGET
       CALL INIT(1       ,MASSTA   ,NUM     ,RADTA,
      &          B/2.    ,ZEROPT+ZDIST/2.   ,PZTA,
      &          GAMMTA  ,ISEED    ,MASS    ,IMOMEN)
 *3.1 INITIALIZATION IN PHASE SPACE FOR THE PROJECTILE
       CALL INIT(1+MASSTA,MASS     ,NUM     ,RADPR,
      &          -B/2.   ,ZEROPT-ZDIST/2.   ,PZPR,
      &          GAMMPR  ,ISEED    ,MASS    ,IMOMEN)
 *3.2 OUTPAR IS THE NO. OF ESCAPED PARTICLES
       OUTPAR = 0
 *3.3 INITIALIZATION FOR THE NO. OF PARTICLES IN EACH SAMPLE
 *    THIS IS NEEDED DUE TO THE FACT THAT PIONS CAN BE PRODUCED OR ABSORBED
       MASSR(0)=0
       DO 1003 IR =1,NUM
       MASSR(IR)=MASS
  1003 CONTINUE
 *3.4 INITIALIZation FOR THE KAON SPECTRUM
 *      CALL KSPEC0(BETAC,GAMMC)
 * calculate the local baryon density matrix
       CALL DENS(IPOT,MASS,NUM,OUTPAR)
 *
 *-----------------------------------------------------------------------
 *       CONTROL PRINTOUT OF INITIAL CONFIGURATION
 *
 *      WRITE(12,'(''**********  INITIAL CONFIGURATION  **********''/)')
 *
 c print out the INITIAL density matrix in the reaction plane
 c       do ix=-10,10
 c       do iz=-10,10
 c       write(1053,992)ix,iz,rho(ix,0,iz)/0.168
 c       end do
 c       end do
 *-----------------------------------------------------------------------
 *       CALCULATE MOMENTA FOR T = 0.5 * DT 
 *       (TO OBTAIN 2ND DEGREE ACCURACY!)
 *       "Reference: J. AICHELIN ET AL., PHYS. REV. C31, 1730 (1985)"
 *
       IF (ICOLL .NE. -1) THEN
         DO 700 I = 1,NTOTAL
           IX = NINT( R(1,I) )
           IY = NINT( R(2,I) )
           IZ = NINT( R(3,I) )
 clin-4/2008 check bounds:
           IF(IX.GE.MAXX.OR.IY.GE.MAXX.OR.IZ.GE.MAXZ
      1         .OR.IX.LE.-MAXX.OR.IY.LE.-MAXX.OR.IZ.LE.-MAXZ) goto 700
           CALL GRADU(IPOT,IX,IY,IZ,GRADX,GRADY,GRADZ)
           P(1,I) = P(1,I) - (0.5 * DT) * GRADX
           P(2,I) = P(2,I) - (0.5 * DT) * GRADY
           P(3,I) = P(3,I) - (0.5 * DT) * GRADZ
   700   CONTINUE
       END IF
 *-----------------------------------------------------------------------
 *-----------------------------------------------------------------------
 *4 INITIALIZATION OF TIME-LOOP VARIABLES
 *4.1 COLLISION NUMBER COUNTERS
 clin 51      RCNNE  = 0
         RCNNE  = 0
        RDD  = 0
        RPP  = 0
        rppk = 0
        RPN  = 0
        rpd  = 0
        RKN  = 0
        RNNK = 0
        RDDK = 0
        RNDK = 0
       RCNND  = 0
       RCNDN  = 0
       RCOLL  = 0
       RBLOC  = 0
       RDIRT  = 0
       RDECAY = 0
       RRES   = 0
 *4.11 KAON PRODUCTION PROBABILITY COUNTER FOR PERTURBATIVE CALCULATIONS ONLY
       DO 1005 KKK=1,5
          SKAON(KKK)  = 0
          DO 1004 IS=1,2000
             SEKAON(KKK,IS)=0
  1004    CONTINUE
  1005 CONTINUE
 *4.12 anti-proton and anti-kaon counters
        pr0=0.
        pr1=0.
        ska0=0.
        ska1=0.
 *       ============== LOOP OVER ALL TIME STEPS ================       *
 *                             STARTS HERE                              *
 *       ========================================================       *
 cbz11/16/98
       IF (IAPAR2(1) .NE. 1) THEN
          DO 1016 I = 1, MAXSTR
             DO 1015 J = 1, 3
                R(J, I) = 0.
                P(J, I) = 0.
  1015       CONTINUE
             E(I) = 0.
             LB(I) = 0
 cbz3/25/00
             ID(I)=0
 c     sp 12/19/00
            PROPER(I) = 1.
  1016   CONTINUE
          MASS = 0
 cbz12/22/98
 c         MASSR(1) = 0
 c         NP = 0
 c         NPI = 1
          NP = 0
          DO 1017 J = 1, NUM
             MASSR(J) = 0
             NPI(J) = 1
  1017    CONTINUE
          DO 1019 I = 1, MAXR
             DO 1018 J = 1, MAXSTR
                RT(1, J, I) = 0.
                RT(2, J, I) = 0.
                RT(3, J, I) = 0.
                PT(1, J, I) = 0.
                PT(2, J, I) = 0.
                PT(3, J, I) = 0.
                ET(J, I) = 0.
                LT(J, I) = 0
 c     sp 12/19/00
                PROT(J, I) = 1.
  1018       CONTINUE
  1019    CONTINUE
 cbz12/22/98end
       END IF
 cbz11/16/98end
         
       DO 10000 NT = 1,NTMAX
 *TEMPORARY PARTICLE COUNTERS
 *4.2 PION COUNTERS : LP1,LP2 AND LP3 ARE THE NO. OF P+,P0 AND P-
       LP1=0
       LP2=0
       LP3=0
 *4.3 DELTA COUNTERS : LD1,LD2,LD3 AND LD4 ARE THE NO. OF D++,D+,D0 AND D-
       LD1=0
       LD2=0
       LD3=0
       LD4=0
 *4.4 N*(1440) COUNTERS : LN1 AND LN2 ARE THE NO. OF N*+ AND N*0
       LN1=0
       LN2=0
 *4.5 N*(1535) counters
       LN5=0
 *4.6 ETA COUNTERS
       LE=0
 *4.7 KAON COUNTERS
       LKAON=0
 
 clin-11/09/00:
 * KAON* COUNTERS
       LKAONS=0
 
 *-----------------------------------------------------------------------
         IF (ICOLL .NE. 1) THEN
 * STUDYING BINARY COLLISIONS AMONG PARTICLES DURING THIS TIME INTERVAL *
 clin-10/25/02 get rid of argument usage mismatch in relcol(.nt.):
            numnt=nt
           CALL RELCOL(LCOLL,LBLOC,LCNNE,LDD,LPP,lppk,
      &    LPN,lpd,LRHO,LOMEGA,LKN,LNNK,LDDK,LNDK,LCNND,
      &    LCNDN,LDIRT,LDECAY,LRES,LDOU,LDDRHO,LNNRHO,
      &    LNNOM,numnt,ntmax,sp,akaon,sk)
 c     &    LNNOM,NT,ntmax,sp,akaon,sk)
 clin-10/25/02-end
 *-----------------------------------------------------------------------
 
 c dilepton production from Dalitz decay
 c of pi0 at final time
 *      if(nt .eq. ntmax) call dalitz_pi(nt,ntmax)
 *                                                                      *
 **********************************
 *                Lables of collision channels                             *
 **********************************
 *         LCOLL   - NUMBER OF COLLISIONS              (INTEGER,OUTPUT) *
 *         LBLOC   - NUMBER OF PULI-BLOCKED COLLISIONS (INTEGER,OUTPUT) *
 *         LCNNE   - NUMBER OF ELASTIC COLLISION       (INTEGER,OUTPUT) *
 *         LCNND   - NUMBER OF N+N->N+DELTA REACTION   (INTEGER,OUTPUT) *
 *         LCNDN   - NUMBER OF N+DELTA->N+N REACTION   (INTEGER,OUTPUT) *
 *         LDD     - NUMBER OF RESONANCE+RESONANCE COLLISIONS
 *         LPP     - NUMBER OF PION+PION elastic COLIISIONS
 *         lppk    - number of pion(RHO,OMEGA)+pion(RHO,OMEGA)
 *                 -->K+K- collisions
 *         LPN     - NUMBER OF PION+N-->KAON+X
 *         lpd     - number of pion+n-->delta+pion
 *         lrho    - number of pion+n-->Delta+rho
 *         lomega  - number of pion+n-->Delta+omega
 *         LKN     - NUMBER OF KAON RESCATTERINGS
 *         LNNK    - NUMBER OF bb-->kAON PROCESS
 *         LDDK    - NUMBER OF DD-->KAON PROCESS
 *         LNDK    - NUMBER OF ND-->KAON PROCESS
 ***********************************
 * TIME-INTEGRATED COLLISIONS NUMBERS OF VARIOUS PROCESSES
           RCOLL = RCOLL + FLOAT(LCOLL)/num
           RBLOC = RBLOC + FLOAT(LBLOC)/num
           RCNNE = RCNNE + FLOAT(LCNNE)/num
          RDD   = RDD   + FLOAT(LDD)/num
          RPP   = RPP   + FLOAT(LPP)/NUM
          rppk  =rppk   + float(lppk)/num
          RPN   = RPN   + FLOAT(LPN)/NUM
          rpd   =rpd    + float(lpd)/num
          RKN   = RKN   + FLOAT(LKN)/NUM
          RNNK  =RNNK   + FLOAT(LNNK)/NUM
          RDDK  =RDDK   + FLOAT(LDDK)/NUM
          RNDK  =RNDK   + FLOAT(LNDK)/NUM
           RCNND = RCNND + FLOAT(LCNND)/num
           RCNDN = RCNDN + FLOAT(LCNDN)/num
           RDIRT = RDIRT + FLOAT(LDIRT)/num
           RDECAY= RDECAY+ FLOAT(LDECAY)/num
           RRES  = RRES  + FLOAT(LRES)/num
 * AVERAGE RATES OF VARIOUS COLLISIONS IN THE CURRENT TIME STEP
           ADIRT=LDIRT/DT/num
           ACOLL=(LCOLL-LBLOC)/DT/num
           ACNND=LCNND/DT/num
           ACNDN=LCNDN/DT/num
           ADECAY=LDECAY/DT/num
           ARES=LRES/DT/num
          ADOU=LDOU/DT/NUM
          ADDRHO=LDDRHO/DT/NUM
          ANNRHO=LNNRHO/DT/NUM
          ANNOM=LNNOM/DT/NUM
          ADD=LDD/DT/num
          APP=LPP/DT/num
          appk=lppk/dt/num
           APN=LPN/DT/num
          apd=lpd/dt/num
          arh=lrho/dt/num
          aom=lomega/dt/num
          AKN=LKN/DT/num
          ANNK=LNNK/DT/num
          ADDK=LDDK/DT/num
          ANDK=LNDK/DT/num
 * PRINT OUT THE VARIOUS COLLISION RATES
 * (1)N-N COLLISIONS 
 c       WRITE(1010,9991)NT*DT,ACNND,ADOU,ADIRT,ADDRHO,ANNRHO+ANNOM
 c9991       FORMAT(6(E10.3,2X))
 * (2)PION-N COLLISIONS
 c       WRITE(1011,'(5(E10.3,2X))')NT*DT,apd,ARH,AOM,APN
 * (3)KAON PRODUCTION CHANNELS
 c        WRITE(1012,9993)NT*DT,ANNK,ADDK,ANDK,APN,Appk
 * (4)D(N*)+D(N*) COLLISION
 c       WRITE(1013,'(4(E10.3,2X))')NT*DT,ADDK,ADD,ADD+ADDK
 * (5)MESON+MESON
 c       WRITE(1014,'(4(E10.3,2X))')NT*DT,APPK,APP,APP+APPK
 * (6)DECAY AND RESONANCE
 c       WRITE(1016,'(3(E10.3,2X))')NT*DT,ARES,ADECAY
 * (7)N+D(N*)
 c       WRITE(1017,'(4(E10.3,2X))')NT*DT,ACNDN,ANDK,ACNDN+ANDK
 c9992    FORMAT(5(E10.3,2X))
 c9993    FORMAT(6(E10.3,2X))
 * PRINT OUT TIME-INTEGRATED COLLISION INFORMATION
 cbz12/28/98
 c        write(1018,'(5(e10.3,2x),/, 4(e10.3,2x))')
 c     &           RCNNE,RCNND,RCNDN,RDIRT,rpd,
 c     &           RDECAY,RRES,RDD,RPP
 c        write(1018,'(6(e10.3,2x),/, 5(e10.3,2x))')
 c     &           NT*DT,RCNNE,RCNND,RCNDN,RDIRT,rpd,
 c     &           NT*DT,RDECAY,RRES,RDD,RPP
 cbz12/18/98end
 * PRINT OUT TIME-INTEGRATED KAON MULTIPLICITIES FROM DIFFERENT CHANNELS
 c       WRITE(1019,'(7(E10.3,2X))')NT*DT,RNNK,RDDK,RNDK,RPN,Rppk,
 c     &                           RNNK+RDDK+RNDK+RPN+Rppk
 *                                                                      *
 
         END IF
 *
 *       UPDATE BARYON DENSITY
 *
         CALL DENS(IPOT,MASS,NUM,OUTPAR)
 *
 *       UPDATE POSITIONS FOR ALL THE PARTICLES PRESENT AT THIS TIME
 *
        sumene=0
         ISO=0
         DO 201 MRUN=1,NUM
         ISO=ISO+MASSR(MRUN-1)
         DO 201 I0=1,MASSR(MRUN)
         I =I0+ISO
         ETOTAL = SQRT( E(I)**2 + P(1,I)**2 + P(2,I)**2 +P(3,I)**2 )
        sumene=sumene+etotal
 C for kaons, if there is a potential
 C CALCULATE THE ENERGY OF THE KAON ACCORDING TO THE IMPULSE APPROXIMATION
 C REFERENCE: B.A. LI AND C.M. KO, PHYS. REV. C 54 (1996) 3283. 
          if(kpoten.ne.0.and.lb(i).eq.23)then
              den=0.
               IX = NINT( R(1,I) )
               IY = NINT( R(2,I) )
               IZ = NINT( R(3,I) )
 clin-4/2008:
 c       IF (ABS(IX) .LT. MAXX .AND. ABS(IY) .LT. MAXX .AND.
 c     & ABS(IZ) .LT. MAXZ) den=rho(ix,iy,iz)
               IF(IX.LT.MAXX.AND.IY.LT.MAXX.AND.IZ.LT.MAXZ
      1             .AND.IX.GT.-MAXX.AND.IY.GT.-MAXX.AND.IZ.GT.-MAXZ)
      2             den=rho(ix,iy,iz)
 c         ecor=0.1973**2*0.255*kmul*4*3.14159*(1.+0.4396/0.938)
 c         etotal=sqrt(etotal**2+ecor*den)
 c** G.Q Li potential form with n_s = n_b and pot(n_0)=29 MeV, m^*=m
 c     GeV^2 fm^3
           akg = 0.1727
 c     GeV fm^3
           bkg = 0.333
          rnsg = den
          ecor = - akg*rnsg + (bkg*den)**2
          etotal = sqrt(etotal**2 + ecor)
          endif
 c
          if(kpoten.ne.0.and.lb(i).eq.21)then
              den=0.
               IX = NINT( R(1,I) )
               IY = NINT( R(2,I) )
               IZ = NINT( R(3,I) )
 clin-4/2008:
 c       IF (ABS(IX) .LT. MAXX .AND. ABS(IY) .LT. MAXX .AND.
 c     & ABS(IZ) .LT. MAXZ) den=rho(ix,iy,iz)
               IF(IX.LT.MAXX.AND.IY.LT.MAXX.AND.IZ.LT.MAXZ
      1             .AND.IX.GT.-MAXX.AND.IY.GT.-MAXX.AND.IZ.GT.-MAXZ)
      2             den=rho(ix,iy,iz)
 c* for song potential no effect on position
 c** G.Q Li potential form with n_s = n_b and pot(n_0)=29 MeV, m^*=m
 c     GeV^2 fm^3
           akg = 0.1727
 c     GeV fm^3
           bkg = 0.333
          rnsg = den
          ecor = - akg*rnsg + (bkg*den)**2
          etotal = sqrt(etotal**2 + ecor)
           endif
 c
 C UPDATE POSITIONS
           R(1,I) = R(1,I) + DT*P(1,I)/ETOTAL
           R(2,I) = R(2,I) + DT*P(2,I)/ETOTAL
           R(3,I) = R(3,I) + DT*P(3,I)/ETOTAL
 c use cyclic boundary conitions
             if ( cycbox.ne.0 ) then
               if ( r(1,i).gt. cycbox/2 ) r(1,i)=r(1,i)-cycbox
               if ( r(1,i).le.-cycbox/2 ) r(1,i)=r(1,i)+cycbox
               if ( r(2,i).gt. cycbox/2 ) r(2,i)=r(2,i)-cycbox
               if ( r(2,i).le.-cycbox/2 ) r(2,i)=r(2,i)+cycbox
               if ( r(3,i).gt. cycbox/2 ) r(3,i)=r(3,i)-cycbox
               if ( r(3,i).le.-cycbox/2 ) r(3,i)=r(3,i)+cycbox
             end if
 * UPDATE THE DELTA, N* AND PION COUNTERS
           LB1=LB(I)
 * 1. FOR DELTA++
         IF(LB1.EQ.9)LD1=LD1+1
 * 2. FOR DELTA+
         IF(LB1.EQ.8)LD2=LD2+1
 * 3. FOR DELTA0
         IF(LB1.EQ.7)LD3=LD3+1
 * 4. FOR DELTA-
         IF(LB1.EQ.6)LD4=LD4+1
 * 5. FOR N*+(1440)
         IF(LB1.EQ.11)LN1=LN1+1
 * 6. FOR N*0(1440)
         IF(LB1.EQ.10)LN2=LN2+1
 * 6.1 FOR N*(1535)
        IF((LB1.EQ.13).OR.(LB1.EQ.12))LN5=LN5+1
 * 6.2 FOR ETA
        IF(LB1.EQ.0)LE=LE+1
 * 6.3 FOR KAONS
        IF(LB1.EQ.23)LKAON=LKAON+1
 clin-11/09/00: FOR KAON*
        IF(LB1.EQ.30)LKAONS=LKAONS+1
 
 * UPDATE PION COUNTER
 * 7. FOR PION+
         IF(LB1.EQ.5)LP1=LP1+1
 * 8. FOR PION0
         IF(LB1.EQ.4)LP2=LP2+1
 * 9. FOR PION-
         IF(LB1.EQ.3)LP3=LP3+1
 201     CONTINUE
         LP=LP1+LP2+LP3
         LD=LD1+LD2+LD3+LD4
         LN=LN1+LN2
         ALP=FLOAT(LP)/FLOAT(NUM)
         ALD=FLOAT(LD)/FLOAT(NUM)
         ALN=FLOAT(LN)/FLOAT(NUM)
        ALN5=FLOAT(LN5)/FLOAT(NUM)
         ATOTAL=ALP+ALD+ALN+0.5*ALN5
        ALE=FLOAT(LE)/FLOAT(NUM)
        ALKAON=FLOAT(LKAON)/FLOAT(NUM)
 * UPDATE MOMENTUM DUE TO COULOMB INTERACTION 
         if (icou .eq. 1) then
 *       with Coulomb interaction
           iso=0
           do 1026 irun = 1,num
             iso=iso+massr(irun-1)
             do 1021 il = 1,massr(irun)
                temp(1,il) = 0.
                temp(2,il) = 0.
                temp(3,il) = 0.
  1021       continue
             do 1023 il = 1, massr(irun)
               i=iso+il
               if (zet(lb(i)).ne.0) then
                 do 1022 jl = 1,il-1
                   j=iso+jl
                   if (zet(lb(j)).ne.0) then
                     ddx=r(1,i)-r(1,j)
                     ddy=r(2,i)-r(2,j)
                     ddz=r(3,i)-r(3,j)
                     rdiff = sqrt(ddx**2+ddy**2+ddz**2)
                     if (rdiff .le. 1.) rdiff = 1.
                     grp=zet(lb(i))*zet(lb(j))/rdiff**3
                     ddx=ddx*grp
                     ddy=ddy*grp
                     ddz=ddz*grp
                     temp(1,il)=temp(1,il)+ddx
                     temp(2,il)=temp(2,il)+ddy
                     temp(3,il)=temp(3,il)+ddz
                     temp(1,jl)=temp(1,jl)-ddx
                     temp(2,jl)=temp(2,jl)-ddy
                     temp(3,jl)=temp(3,jl)-ddz
                   end if
  1022          continue
               end if
  1023      continue
             do 1025 il = 1,massr(irun)
               i= iso+il
               if (zet(lb(i)).ne.0) then
                 do 1024 idir = 1,3
                   p(idir,i) = p(idir,i) + temp(idir,il)
      &                                    * dt * 0.00144
  1024          continue
               end if
  1025      continue
  1026   continue
         end if
 *       In the following, we shall:  
 *       (1) UPDATE MOMENTA DUE TO THE MEAN FIELD FOR BARYONS AND KAONS,
 *       (2) calculate the thermalization, temperature in a sphere of 
 *           radius 2.0 fm AROUND THE CM
 *       (3) AND CALCULATE THE NUMBER OF PARTICLES IN THE HIGH DENSITY REGION 
        spt=0
        spz=0
        ncen=0
        ekin=0
           NLOST = 0
           MEAN=0
          nquark=0
          nbaryn=0
 csp06/18/01
            rads = 2.
            zras = 0.1
            denst = 0.
            edenst = 0.
 csp06/18/01 end
           DO 6000 IRUN = 1,NUM
           MEAN=MEAN+MASSR(IRUN-1)
           DO 5800 J = 1,MASSR(irun)
           I=J+MEAN
 c
 csp06/18/01
            radut = sqrt(r(1,i)**2+r(2,i)**2)
        if( radut .le. rads )then
         if( abs(r(3,i)) .le. zras*nt*dt )then
 c         vols = 3.14159*radut**2*abs(r(3,i))      ! cylinder pi*r^2*l
 c     cylinder pi*r^2*l
          vols = 3.14159*rads**2*zras
          engs=sqrt(p(1,i)**2+p(2,i)**2+p(3,i)**2+e(i)**2)
          gammas=1.
          if(e(i).ne.0.)gammas=engs/e(i)
 c     rho
          denst = denst + 1./gammas/vols
 c     energy density
          edenst = edenst + engs/gammas/gammas/vols
         endif
        endif
 csp06/18/01 end
 c
          drr=sqrt(r(1,i)**2+r(2,i)**2+r(3,i)**2)
          if(drr.le.2.0)then
          spt=spt+p(1,i)**2+p(2,i)**2
          spz=spz+p(3,i)**2
          ncen=ncen+1
          ekin=ekin+sqrt(p(1,i)**2+p(2,i)**2+p(3,i)**2+e(i)**2)-e(i)
          endif
               IX = NINT( R(1,I) )
               IY = NINT( R(2,I) )
               IZ = NINT( R(3,I) )
 C calculate the No. of particles in the high density region
 clin-4/2008:
 c              IF (ABS(IX) .LT. MAXX .AND. ABS(IY) .LT. MAXX .AND.
 c     & ABS(IZ) .LT. MAXZ) THEN
               IF(IX.LT.MAXX.AND.IY.LT.MAXX.AND.IZ.LT.MAXZ
      1          .AND.IX.GT.-MAXX.AND.IY.GT.-MAXX.AND.IZ.GT.-MAXZ) THEN
        if(rho(ix,iy,iz)/0.168.gt.dencut)go to 5800
        if((rho(ix,iy,iz)/0.168.gt.5.).and.(e(i).gt.0.9))
      &  nbaryn=nbaryn+1
        if(pel(ix,iy,iz).gt.2.0)nquark=nquark+1
        endif
 c*
 c If there is a kaon potential, propogating kaons 
         if(kpoten.ne.0.and.lb(i).eq.23)then
         den=0.
 clin-4/2008:
 c       IF (ABS(IX) .LT. MAXX .AND. ABS(IY) .LT. MAXX .AND.
 c     & ABS(IZ) .LT. MAXZ)then
         IF(IX.LT.MAXX.AND.IY.LT.MAXX.AND.IZ.LT.MAXZ
      1       .AND.IX.GT.-MAXX.AND.IY.GT.-MAXX.AND.IZ.GT.-MAXZ) THEN
            den=rho(ix,iy,iz)
 c        ecor=0.1973**2*0.255*kmul*4*3.14159*(1.+0.4396/0.938)
 c       etotal=sqrt(P(1,i)**2+p(2,I)**2+p(3,i)**2+e(i)**2+ecor*den)
 c** for G.Q Li potential form with n_s = n_b and pot(n_0)=29 MeV
 c     !! GeV^2 fm^3
             akg = 0.1727
 c     !! GeV fm^3
             bkg = 0.333
           rnsg = den
           ecor = - akg*rnsg + (bkg*den)**2
           etotal = sqrt(P(1,i)**2+p(2,I)**2+p(3,i)**2+e(i)**2 + ecor)
           ecor = - akg + 2.*bkg**2*den + 2.*bkg*etotal
 c** G.Q. Li potential (END)           
         CALL GRADUK(IX,IY,IZ,GRADXk,GRADYk,GRADZk)
         P(1,I) = P(1,I) - DT * GRADXk*ecor/(2.*etotal)
         P(2,I) = P(2,I) - DT * GRADYk*ecor/(2.*etotal)
         P(3,I) = P(3,I) - DT * GRADZk*ecor/(2.*etotal)
         endif
          endif
 c
         if(kpoten.ne.0.and.lb(i).eq.21)then
          den=0.
 clin-4/2008:
 c           IF (ABS(IX) .LT. MAXX .AND. ABS(IY) .LT. MAXX .AND.
 c     &        ABS(IZ) .LT. MAXZ)then
          IF(IX.LT.MAXX.AND.IY.LT.MAXX.AND.IZ.LT.MAXZ
      1        .AND.IX.GT.-MAXX.AND.IY.GT.-MAXX.AND.IZ.GT.-MAXZ) THEN
                den=rho(ix,iy,iz)
         CALL GRADUK(IX,IY,IZ,GRADXk,GRADYk,GRADZk)
 c        P(1,I) = P(1,I) - DT * GRADXk*(-0.12/0.168)    !! song potential
 c        P(2,I) = P(2,I) - DT * GRADYk*(-0.12/0.168)
 c        P(3,I) = P(3,I) - DT * GRADZk*(-0.12/0.168)
 c** for G.Q Li potential form with n_s = n_b and pot(n_0)=29 MeV
 c    !! GeV^2 fm^3
             akg = 0.1727
 c     !! GeV fm^3
             bkg = 0.333
           rnsg = den
           ecor = - akg*rnsg + (bkg*den)**2
           etotal = sqrt(P(1,i)**2+p(2,I)**2+p(3,i)**2+e(i)**2 + ecor)
           ecor = - akg + 2.*bkg**2*den - 2.*bkg*etotal
         P(1,I) = P(1,I) - DT * GRADXk*ecor/(2.*etotal)
         P(2,I) = P(2,I) - DT * GRADYk*ecor/(2.*etotal)
         P(3,I) = P(3,I) - DT * GRADZk*ecor/(2.*etotal)
 c** G.Q. Li potential (END)           
         endif
          endif
 c
 c for other mesons, there is no potential
        if(j.gt.mass)go to 5800         
 c  with mean field interaction for baryons   (open endif below) !!sp05
 **      if( (iabs(lb(i)).eq.1.or.iabs(lb(i)).eq.2) .or.
 **    &     (iabs(lb(i)).ge.6.and.iabs(lb(i)).le.17) .or.
 **    &      iabs(lb(i)).eq.40.or.iabs(lb(i)).eq.41 )then  
         IF (ICOLL .NE. -1) THEN
 * check if the baryon has run off the lattice
 *             IX0=NINT(R(1,I)/DX)
 *             IY0=NINT(R(2,I)/DY)
 *             IZ0=NINT(R(3,I)/DZ)
 *             IPX0=NINT(P(1,I)/DPX)
 *             IPY0=NINT(P(2,I)/DPY)
 *             IPZ0=NINT(P(3,I)/DPZ)
 *      if ( (abs(ix0).gt.mx) .or. (abs(iy0).gt.my) .or. (abs(iz0).gt.mz)
 *     &  .or. (abs(ipx0).gt.mpx) .or. (abs(ipy0) 
 *     &  .or. (ipz0.lt.-mpz) .or. (ipz0.gt.mpzp)) NLOST=NLOST+1
 clin-4/2008:
 c              IF (ABS(IX) .LT. MAXX .AND. ABS(IY) .LT. MAXX .AND.
 c     &                                    ABS(IZ) .LT. MAXZ     ) THEN
            IF(IX.LT.MAXX.AND.IY.LT.MAXX.AND.IZ.LT.MAXZ
      1          .AND.IX.GT.-MAXX.AND.IY.GT.-MAXX.AND.IZ.GT.-MAXZ) THEN
                 CALL GRADU(IPOT,IX,IY,IZ,GRADX,GRADY,GRADZ)
               TZ=0.
               GRADXN=0
               GRADYN=0
               GRADZN=0
               GRADXP=0
               GRADYP=0
               GRADZP=0
              IF(ICOU.EQ.1)THEN
                 CALL GRADUP(IX,IY,IZ,GRADXP,GRADYP,GRADZP)
                 CALL GRADUN(IX,IY,IZ,GRADXN,GRADYN,GRADZN)
                IF(ZET(LB(I)).NE.0)TZ=-1
                IF(ZET(LB(I)).EQ.0)TZ= 1
              END IF
            if(iabs(lb(i)).ge.14.and.iabs(lb(i)).le.17)then
               facl = 2./3.
             elseif(iabs(lb(i)).eq.40.or.iabs(lb(i)).eq.41)then
               facl = 1./3.
             else
               facl = 1.
             endif
         P(1,I) = P(1,I) - facl*DT * (GRADX+asy*(GRADXN-GRADXP)*TZ)
         P(2,I) = P(2,I) - facl*DT * (GRADY+asy*(GRADYN-GRADYP)*TZ)
         P(3,I) = P(3,I) - facl*DT * (GRADZ+asy*(GRADZN-GRADZP)*TZ)
                 end if                                                       
               ENDIF
 **          endif          !!sp05     
  5800       CONTINUE
  6000       CONTINUE
 c print out the average no. of particles in regions where the local 
 c baryon density is higher than 5*rho0 
 c       write(1072,'(e10.3,2x,e10.3)')nt*dt,float(nbaryn)/float(num)
 C print out the average no. of particles in regions where the local 
 c energy density is higher than 2 GeV/fm^3. 
 c       write(1073,'(e10.3,2x,e10.3)')nt*dt,float(nquark)/float(num)
 c print out the no. of particles that have run off the lattice
 *          IF (NLOST .NE. 0 .AND. (NT/NFREQ)*NFREQ .EQ. NT) THEN
 *            WRITE(12,'(5X,''***'',I7,'' TESTPARTICLES LOST AFTER '',
 *     &                   ''TIME STEP NUMBER'',I4)') NLOST, NT
 *         END IF
 *
 *       update phase space density
 *        call platin(mode,mass,num,dx,dy,dz,dpx,dpy,dpz,fnorm)
 *
 *       CONTROL-PRINTOUT OF CONFIGURATION (IF REQUIRED)
 *
 *        if (inout(5) .eq. 2) CALL ENERGY(NT,IPOT,NUM,MASS,EMIN,EMAX)
 *
 * 
 * print out central baryon density as a function of time
        CDEN=RHO(0,0,0)/0.168
 cc        WRITE(1002,990)FLOAT(NT)*DT,CDEN
 c        WRITE(1002,1990)FLOAT(NT)*DT,CDEN,denst/real(num)
 * print out the central energy density as a function of time
 cc        WRITE(1003,990)FLOAT(NT)*DT,PEL(0,0,0)
 c        WRITE(1003,1990)FLOAT(NT)*DT,PEL(0,0,0),edenst/real(num)
 * print out the no. of pion-like particles as a function of time 
 c        WRITE(1004,9999)FLOAT(NT)*DT,ALD,ALN,ALP,ALN5,
 c     &               ALD+ALN+ALP+0.5*ALN5
 * print out the no. of eta-like particles as a function of time
 c        WRITE(1005,991)FLOAT(NT)*DT,ALN5,ALE,ALE+0.5*ALN5
 c990       FORMAT(E10.3,2X,E10.3)
 c1990       FORMAT(E10.3,2X,E10.3,2X,E10.3)
 c991       FORMAT(E10.3,2X,E10.3,2X,E10.3,2X,E10.3)
 c9999    FORMAT(e10.3,2X,e10.3,2X,E10.3,2X,E10.3,2X,
 c     1  E10.3,2X,E10.3)
 C THE FOLLOWING OUTPUTS CAN BE TURNED ON/OFF by setting icflow and icrho=0  
 c print out the baryon and meson density matrix in the reaction plane
         IF ((NT/NFREQ)*NFREQ .EQ. NT ) THEN
        if(icflow.eq.1)call flow(nt)
 cbz11/18/98
 c       if(icrho.ne.1)go to 10000 
 c       if (icrho .eq. 1) then 
 cbz11/18/98end
 c       do ix=-10,10
 c       do iz=-10,10
 c       write(1053,992)ix,iz,rho(ix,0,iz)/0.168
 c       write(1054,992)ix,iz,pirho(ix,0,iz)/0.168
 c       write(1055,992)ix,iz,pel(ix,0,iz)
 c       end do
 c       end do
 cbz11/18/98
 c        end if
 cbz11/18/98end
 c992       format(i3,i3,e11.4)
        endif
 c print out the ENERGY density matrix in the reaction plane
 C CHECK LOCAL MOMENTUM EQUILIBRIUM IN EACH CELL, 
 C AND PERFORM ON-LINE FLOW ANALYSIS AT A FREQUENCY OF NFREQ
 c        IF ((NT/NFREQ)*NFREQ .EQ. NT ) THEN
 c       call flow(nt)
 c       call equ(ipot,mass,num,outpar)
 c       do ix=-10,10
 c       do iz=-10,10
 c       write(1055,992)ix,iz,pel(ix,0,iz)
 c       write(1056,992)ix,iz,rxy(ix,0,iz)
 c       end do
 c       end do
 c       endif
 C calculate the volume of high BARYON AND ENERGY density 
 C matter as a function of time
 c       vbrho=0.
 c       verho=0.
 c       do ix=-20,20
 c       do iy=-20,20
 c       do iz=-20,20
 c       if(rho(ix,iy,iz)/0.168.gt.5.)vbrho=vbrho+1.
 c       if(pel(ix,iy,iz).gt.2.)verho=verho+1.
 c       end do
 c       end do
 c       end do
 c       write(1081,993)dt*nt,vbrho
 c       write(1082,993)dt*nt,verho
 c993       format(e11.4,2x,e11.4)
 *-----------------------------------------------------------------------
 cbz11/16/98
 c.....for read-in initial conditions produce particles from read-in 
 c.....common block.
 c.....note that this part is only for cascade with number of test particles
 c.....NUM = 1.
       IF (IAPAR2(1) .NE. 1) THEN
          CT = NT * DT
 cbz12/22/98
 c         NP = MASSR(1)
 c         DO WHILE (FTAR(NPI) .GT. CT - DT .AND. FTAR(NPI) .LE. CT)
 c            NP = NP + 1
 c            R(1, NP) = GXAR(NPI) + PXAR(NPI) / PEAR(NPI) * (CT - FTAR(NPI))
 c            R(2, NP) = GYAR(NPI) + PYAR(NPI) / PEAR(NPI) * (CT - FTAR(NPI))
 c            R(3, NP) = GZAR(NPI) + PZAR(NPI) / PEAR(NPI) * (CT - FTAR(NPI))
 c            P(1, NP) = PXAR(NPI)
 c            P(2, NP) = PYAR(NPI)
 c            P(3, NP) = PZAR(NPI)
 c            E(NP) = XMAR(NPI)
 c            LB(NP) = IARFLV(ITYPAR(NPI))
 c            NPI = NPI + 1
 c         END DO
 c         MASSR(1) = NP
          IA = 0
          DO 1028 IRUN = 1, NUM
             DO 1027 IC = 1, MASSR(IRUN)
                IE = IA + IC
                RT(1, IC, IRUN) = R(1, IE)
                RT(2, IC, IRUN) = R(2, IE)
                RT(3, IC, IRUN) = R(3, IE)
                PT(1, IC, IRUN) = P(1, IE)
                PT(2, IC, IRUN) = P(2, IE)
                PT(3, IC, IRUN) = P(3, IE)
                ET(IC, IRUN) = E(IE)
                LT(IC, IRUN) = LB(IE)
 c         !! sp 12/19/00
                PROT(IC, IRUN) = PROPER(IE)
 clin-5/2008:
                dpertt(IC, IRUN)=dpertp(IE)
  1027       CONTINUE
             NP = MASSR(IRUN)
             NP1 = NPI(IRUN)
 
 cbz10/05/99
 c            DO WHILE (FT1(NP1, IRUN) .GT. CT - DT .AND. 
 c     &           FT1(NP1, IRUN) .LE. CT)
 cbz10/06/99
 c            DO WHILE (NPI(IRUN).LE.MULTI1(IRUN).AND.
 cbz10/06/99 end
 clin-11/13/00 finally read in all unformed particles and do the decays in ART:
 c           DO WHILE (NP1.LE.MULTI1(IRUN).AND.
 c    &           FT1(NP1, IRUN) .GT. CT - DT .AND. 
 c    &           FT1(NP1, IRUN) .LE. CT)
 c
                ctlong = ct
              if(nt .eq. (ntmax-1))then
                ctlong = 1.E30
              elseif(nt .eq. ntmax)then
                go to 1111
              endif
             DO WHILE (NP1.LE.MULTI1(IRUN).AND.
      &           FT1(NP1, IRUN) .GT. (CT - DT) .AND. 
      &           FT1(NP1, IRUN) .LE. ctlong)
                NP = NP + 1
                UDT = (CT - FT1(NP1, IRUN)) / EE1(NP1, IRUN)
 clin-10/28/03 since all unformed hadrons at time ct are read in at nt=ntmax-1, 
 c     their positions should not be propagated to time ct:
                if(nt.eq.(ntmax-1)) then
                   ftsvt(NP,IRUN)=FT1(NP1, IRUN)
                   if(FT1(NP1, IRUN).gt.ct) UDT=0.
                endif
                RT(1, NP, IRUN) = GX1(NP1, IRUN) + 
      &              PX1(NP1, IRUN) * UDT
                RT(2, NP, IRUN) = GY1(NP1, IRUN) + 
      &              PY1(NP1, IRUN) * UDT
                RT(3, NP, IRUN) = GZ1(NP1, IRUN) + 
      &              PZ1(NP1, IRUN) * UDT
                PT(1, NP, IRUN) = PX1(NP1, IRUN)
                PT(2, NP, IRUN) = PY1(NP1, IRUN)
                PT(3, NP, IRUN) = PZ1(NP1, IRUN)
                ET(NP, IRUN) = XM1(NP1, IRUN)
                LT(NP, IRUN) = IARFLV(ITYP1(NP1, IRUN))
 clin-5/2008:
                dpertt(NP,IRUN)=dpp1(NP1,IRUN)
 clin-4/30/03 ctest off 
 c     record initial phi,K*,Lambda(1520) resonances formed during the timestep:
 c               if(LT(NP, IRUN).eq.29.or.iabs(LT(NP, IRUN)).eq.30)
 c     1              write(17,112) 'formed',LT(NP, IRUN),PX1(NP1, IRUN),
 c     2 PY1(NP1, IRUN),PZ1(NP1, IRUN),XM1(NP1, IRUN),nt
 c 112           format(a10,1x,I4,4(1x,f9.3),1x,I4)
 c
                NP1 = NP1 + 1
 c     !! sp 12/19/00
                PROT(NP, IRUN) = 1.
             END DO
 *
  1111      continue
             NPI(IRUN) = NP1
             IA = IA + MASSR(IRUN)
             MASSR(IRUN) = NP
  1028    CONTINUE
          IA = 0
          DO 1030 IRUN = 1, NUM
             IA = IA + MASSR(IRUN - 1)
             DO 1029 IC = 1, MASSR(IRUN)
                IE = IA + IC
                R(1, IE) = RT(1, IC, IRUN)
                R(2, IE) = RT(2, IC, IRUN)
                R(3, IE) = RT(3, IC, IRUN)
                P(1, IE) = PT(1, IC, IRUN)
                P(2, IE) = PT(2, IC, IRUN)
                P(3, IE) = PT(3, IC, IRUN)
                E(IE) = ET(IC, IRUN)
                LB(IE) = LT(IC, IRUN)
 c     !! sp 12/19/00
                PROPER(IE) = PROT(IC, IRUN)
                if(nt.eq.(ntmax-1)) ftsv(IE)=ftsvt(IC,IRUN)
 clin-5/2008:
                dpertp(IE)=dpertt(IC, IRUN)
  1029       CONTINUE
 clin-3/2009 Moved here to better take care of freezeout spacetime:
             call hbtout(MASSR(IRUN),nt,ntmax)
  1030    CONTINUE
 cbz12/22/98end
       END IF
 cbz11/16/98end
 
 clin-5/2009 ctest off:
 c      call flowh(ct) 
 
 10000       continue
 
 *                                                                      *
 *       ==============  END OF TIME STEP LOOP   ================       *
 
 ************************************
 *     WRITE OUT particle's MOMENTA ,and/OR COORDINATES ,
 *     label and/or their local baryon density in the final state
         iss=0
         do 1032 lrun=1,num
            iss=iss+massr(lrun-1)
            do 1031 l0=1,massr(lrun)
               ipart=iss+l0
  1031      continue
  1032   continue
 
 cbz11/16/98
       IF (IAPAR2(1) .NE. 1) THEN
 cbz12/22/98
 c        NSH = MASSR(1) - NPI + 1
 c        IAINT2(1) = IAINT2(1) + NSH
 c.....to shift the unformed particles to the end of the common block
 c        IF (NSH .GT. 0) THEN
 c           IB = IAINT2(1)
 c           IE = MASSR(1) + 1
 c           II = -1
 c        ELSE IF (NSH .LT. 0) THEN
 c           IB = MASSR(1) + 1
 c           IE = IAINT2(1)
 c           II = 1
 c        END IF
 c        IF (NSH .NE. 0) THEN
 c           DO I = IB, IE, II
 c              J = I - NSH
 c              ITYPAR(I) = ITYPAR(J)
 c              GXAR(I) = GXAR(J)
 c              GYAR(I) = GYAR(J)
 c              GZAR(I) = GZAR(J)
 c              FTAR(I) = FTAR(J)
 c              PXAR(I) = PXAR(J)
 c              PYAR(I) = PYAR(J)
 c              PZAR(I) = PZAR(J)
 c              PEAR(I) = PEAR(J)
 c              XMAR(I) = XMAR(J)
 c           END DO
 c        END IF
 
 c.....to copy ART particle info to COMMON /ARPRC/
 c        DO I = 1, MASSR(1)
 c           ITYPAR(I) = INVFLV(LB(I))
 c           GXAR(I) = R(1, I)
 c           GYAR(I) = R(2, I)
 c           GZAR(I) = R(3, I)
 c           FTAR(I) = CT
 c           PXAR(I) = P(1, I)
 c           PYAR(I) = P(2, I)
 c           PZAR(I) = P(3, I)
 c           XMAR(I) = E(I)
 c           PEAR(I) = SQRT(PXAR(I) ** 2 + PYAR(I) ** 2 + PZAR(I) ** 2
 c     &        + XMAR(I) ** 2)
 c        END DO
         IA = 0
         DO 1035 IRUN = 1, NUM
            IA = IA + MASSR(IRUN - 1)
            NP1 = NPI(IRUN)
            NSH = MASSR(IRUN) - NP1 + 1
            MULTI1(IRUN) = MULTI1(IRUN) + NSH
 c.....to shift the unformed particles to the end of the common block
            IF (NSH .GT. 0) THEN
               IB = MULTI1(IRUN)
               IE = MASSR(IRUN) + 1
               II = -1
            ELSE IF (NSH .LT. 0) THEN
               IB = MASSR(IRUN) + 1
               IE = MULTI1(IRUN)
               II = 1
            END IF
            IF (NSH .NE. 0) THEN
               DO 1033 I = IB, IE, II
                  J = I - NSH
                  ITYP1(I, IRUN) = ITYP1(J, IRUN)
                  GX1(I, IRUN) = GX1(J, IRUN)
                  GY1(I, IRUN) = GY1(J, IRUN)
                  GZ1(I, IRUN) = GZ1(J, IRUN)
                  FT1(I, IRUN) = FT1(J, IRUN)
                  PX1(I, IRUN) = PX1(J, IRUN)
                  PY1(I, IRUN) = PY1(J, IRUN)
                  PZ1(I, IRUN) = PZ1(J, IRUN)
                  EE1(I, IRUN) = EE1(J, IRUN)
                  XM1(I, IRUN) = XM1(J, IRUN)
 c     !! sp 12/19/00
                  PRO1(I, IRUN) = PRO1(J, IRUN)
 clin-5/2008:
                  dpp1(I,IRUN)=dpp1(J,IRUN)
  1033         CONTINUE
            END IF
            
 c.....to copy ART particle info to COMMON /ARPRC1/
            DO 1034 I = 1, MASSR(IRUN)
               IB = IA + I
               ITYP1(I, IRUN) = INVFLV(LB(IB))
               GX1(I, IRUN) = R(1, IB)
               GY1(I, IRUN) = R(2, IB)
               GZ1(I, IRUN) = R(3, IB)
 clin-10/28/03:
 c since all unformed hadrons at time ct are read in at nt=ntmax-1, 
 c their formation time ft1 should be kept to determine their freezeout(x,t):
 c              FT1(I, IRUN) = CT
               if(FT1(I, IRUN).lt.CT) FT1(I, IRUN) = CT
               PX1(I, IRUN) = P(1, IB)
               PY1(I, IRUN) = P(2, IB)
               PZ1(I, IRUN) = P(3, IB)
               XM1(I, IRUN) = E(IB)
               EE1(I, IRUN) = SQRT(PX1(I, IRUN) ** 2 + 
      &             PY1(I, IRUN) ** 2 +
      &             PZ1(I, IRUN) ** 2 + 
      &             XM1(I, IRUN) ** 2)
 c     !! sp 12/19/00
               PRO1(I, IRUN) = PROPER(IB)
  1034      CONTINUE
  1035   CONTINUE
 cbz12/22/98end
       END IF
 cbz11/16/98end
 c
 **********************************
 *                                                                      *
 *       ======= END OF MANY LOOPS OVER IMPACT PARAMETERS ==========    *
 *                                                               *
 **********************************
 50000   CONTINUE
 *
 *-----------------------------------------------------------------------
 *                       ==== ART COMPLETED ====
 *-----------------------------------------------------------------------
 cbz11/16/98
 c      STOP
       RETURN
 cbz11/16/98end
       END
 **********************************
       subroutine coulin(masspr,massta,NUM)
 *                                                                      *
 *     purpose:   initialization of array zet() and lb() for all runs  *
 *                lb(i) = 1   =>  proton                               *
 *                lb(i) = 2   =>  neutron                              *
 **********************************
         integer  zta,zpr
         PARAMETER (MAXSTR=150001)
         common  /EE/ ID(MAXSTR),LB(MAXSTR)
 cc      SAVE /EE/
         COMMON  /ZZ/ ZTA,ZPR
 cc      SAVE /zz/
       SAVE   
         MASS=MASSTA+MASSPR
         DO 500 IRUN=1,NUM
         do 100 i = 1+(IRUN-1)*MASS,zta+(IRUN-1)*MASS
         LB(i) = 1
   100   continue
         do 200 i = zta+1+(IRUN-1)*MASS,massta+(IRUN-1)*MASS
         LB(i) = 2
   200   continue
         do 300 i = massta+1+(IRUN-1)*MASS,massta+zpr+(IRUN-1)*MASS
         LB(i) = 1
   300   continue
         do 400 i = massta+zpr+1+(IRUN-1)*MASS,
      1  massta+masspr+(IRUN-1)*MASS
         LB(i) = 2
   400   continue
   500   CONTINUE
         return
         end
 **********************************
 *                                                                      *
       SUBROUTINE RELCOL(LCOLL,LBLOC,LCNNE,LDD,LPP,lppk,
      &LPN,lpd,lrho,lomega,LKN,LNNK,LDDK,LNDK,LCNND,LCNDN,
      &LDIRT,LDECAY,LRES,LDOU,LDDRHO,LNNRHO,LNNOM,
      &NT,ntmax,sp,akaon,sk)
 *                                                                      *
 *       PURPOSE:    CHECK CONDITIONS AND CALCULATE THE KINEMATICS      * 
 *                   FOR BINARY COLLISIONS AMONG PARTICLES              *
 *                                 - RELATIVISTIC FORMULA USED          *
 *                                                                      *
 *       REFERENCES: HAGEDORN, RELATIVISTIC KINEMATICS (1963)           *
 *                                                                      *
 *       VARIABLES:                                                     *
 *         MASSPR  - NUMBER OF NUCLEONS IN PROJECTILE   (INTEGER,INPUT) *
 *         MASSTA  - NUMBER OF NUCLEONS IN TARGET       (INTEGER,INPUT) *
 *         NUM     - NUMBER OF TESTPARTICLES PER NUCLEON(INTEGER,INPUT) *
 *         ISEED   - SEED FOR RANDOM NUMBER GENERATOR   (INTEGER,INPUT) *
 *         IAVOID  - (= 1 => AVOID FIRST CLLISIONS WITHIN THE SAME      *
 *                   NUCLEUS, ELSE ALL COLLISIONS)      (INTEGER,INPUT) *
 *         DELTAR  - MAXIMUM SPATIAL DISTANCE FOR WHICH A COLLISION     *
 *                   STILL CAN OCCUR                       (REAL,INPUT) *
 *         DT      - TIME STEP SIZE                        (REAL,INPUT) *
 *         LCOLL   - NUMBER OF COLLISIONS              (INTEGER,OUTPUT) *
 *         LBLOC   - NUMBER OF PULI-BLOCKED COLLISIONS (INTEGER,OUTPUT) *
 *         LCNNE   - NUMBER OF ELASTIC COLLISION       (INTEGER,OUTPUT) *
 *         LCNND   - NUMBER OF N+N->N+DELTA REACTION   (INTEGER,OUTPUT) *
 *         LCNDN   - NUMBER OF N+DELTA->N+N REACTION   (INTEGER,OUTPUT) *
 *         LDD     - NUMBER OF RESONANCE+RESONANCE COLLISIONS
 *         LPP     - NUMBER OF PION+PION elastic COLIISIONS
 *         lppk    - number of pion(RHO,OMEGA)+pion(RHO,OMEGA)
 *                   -->K+K- collisions
 *         LPN     - NUMBER OF PION+N-->KAON+X
 *         lpd     - number of pion+n-->delta+pion
 *         lrho    - number of pion+n-->Delta+rho
 *         lomega  - number of pion+n-->Delta+omega
 *         LKN     - NUMBER OF KAON RESCATTERINGS
 *         LNNK    - NUMBER OF bb-->kAON PROCESS
 *         LDDK    - NUMBER OF DD-->KAON PROCESS
 *         LNDK    - NUMBER OF ND-->KAON PROCESS
 *         LB(I) IS USED TO LABEL PARTICLE'S CHARGE STATE
 *         LB(I)   = 
 cbali2/7/99 
 *                 -45 Omega baryon(bar)
 *                 -41 cascade0(bar)
 *                 -40 cascade-(bar)
 clin-11/07/00:
 *                 -30 K*-
 *                 -17 sigma+(bar)
 *                 -16 sigma0(bar)
 *                 -15 sigma-(bar)
 *                 -14 LAMBDA(bar)
 clin-8/29/00
 *                 -13 anti-N*(+1)(1535),s_11
 *                 -12 anti-N*0(1535),s_11
 *                 -11 anti-N*(+1)(1440),p_11
 *                 -10 anti-N*0(1440), p_11
 *                  -9 anti-DELTA+2
 *                  -8 anti-DELTA+1
 *                  -7 anti-DELTA0
 *                  -6 anti-DELTA-1
 *
 *                  -2 antineutron 
 *                  -1 antiproton
 cbali2/7/99end 
 *                   0 eta
 *                   1 PROTON
 *                   2 NUETRON
 *                   3 PION-
 *                   4 PION0
 *                   5 PION+          
 *                   6 DELTA-1
 *                   7 DELTA0
 *                   8 DELTA+1
 *                   9 DELTA+2
 *                   10 N*0(1440), p_11
 *                   11 N*(+1)(1440),p_11
 *                  12 N*0(1535),s_11
 *                  13 N*(+1)(1535),s_11
 *                  14 LAMBDA
 *                   15 sigma-
 *                   16 sigma0
 *                   17 sigma+
 *                   21 kaon-
 clin-2/23/03        22 Kaon0Long (converted at the last timestep)
 *                   23 KAON+
 *                   24 Kaon0short (converted at the last timestep then decay)
 *                   25 rho-
 *                   26 rho0
 *                   27 rho+
 *                   28 omega meson
 *                   29 phi
 *                   30 K*+
 * sp01/03/01
 *                   31 eta-prime
 *                   40 cascade-
 *                   41 cascade0
 *                   45 Omega baryon
 * sp01/03/01 end
 *                   
 *                   ++  ------- SEE NOTE BOOK
 *         NSTAR=1 INCLUDING N* RESORANCE
 *         ELSE DELTA RESORANCE ONLY
 *         NDIRCT=1 INCLUDING DIRECT PROCESS,ELSE NOT
 *         DIR - PERCENTAGE OF DIRECT PION PRODUCTION PROCESS
 **********************************
       PARAMETER      (MAXSTR=150001,MAXR=1,PI=3.1415926)
       parameter      (MX=4,MY=4,MZ=8,MPX=4,MPY=4,mpz=10,mpzp=10)
       PARAMETER      (AKA=0.498,ALA=1.1157,ASA=1.1974,aks=0.895)
       PARAMETER      (AA1=1.26,APHI=1.02,AP1=0.13496)
       parameter            (maxx=20,maxz=24)
       parameter            (rrkk=0.6,prkk=0.3,srhoks=5.,ESBIN=0.04)
       DIMENSION MASSRN(0:MAXR),RT(3,MAXSTR),PT(3,MAXSTR),ET(MAXSTR)
       DIMENSION LT(MAXSTR), PROT(MAXSTR)
       COMMON   /AA/  R(3,MAXSTR)
 cc      SAVE /AA/
       COMMON   /BB/  P(3,MAXSTR)
 cc      SAVE /BB/
       COMMON   /CC/  E(MAXSTR)
 cc      SAVE /CC/
       COMMON  /DD/      RHO(-MAXX:MAXX,-MAXX:MAXX,-MAXZ:MAXZ),
      &                     RHOP(-MAXX:MAXX,-MAXX:MAXX,-MAXZ:MAXZ),
      &                     RHON(-MAXX:MAXX,-MAXX:MAXX,-MAXZ:MAXZ)
 cc      SAVE /DD/
       COMMON   /EE/  ID(MAXSTR),LB(MAXSTR)
 cc      SAVE /EE/
       COMMON   /HH/  PROPER(MAXSTR)
 cc      SAVE /HH/
       common /ff/f(-mx:mx,-my:my,-mz:mz,-mpx:mpx,-mpy:mpy,-mpz:mpzp)
 cc      SAVE /ff/
       common   /gg/  dx,dy,dz,dpx,dpy,dpz
 cc      SAVE /gg/
       COMMON   /INPUT/ NSTAR,NDIRCT,DIR
 cc      SAVE /INPUT/
       COMMON   /NN/NNN
 cc      SAVE /NN/
       COMMON   /RR/  MASSR(0:MAXR)
 cc      SAVE /RR/
       common   /ss/  inout(20)
 cc      SAVE /ss/
       COMMON   /BG/BETAX,BETAY,BETAZ,GAMMA
 cc      SAVE /BG/
       COMMON   /RUN/NUM
 cc      SAVE /RUN/
       COMMON   /PA/RPION(3,MAXSTR,MAXR)
 cc      SAVE /PA/
       COMMON   /PB/PPION(3,MAXSTR,MAXR)
 cc      SAVE /PB/
       COMMON   /PC/EPION(MAXSTR,MAXR)
 cc      SAVE /PC/
       COMMON   /PD/LPION(MAXSTR,MAXR)
 cc      SAVE /PD/
       COMMON   /PE/PROPI(MAXSTR,MAXR)
 cc      SAVE /PE/
       COMMON   /KKK/TKAON(7),EKAON(7,0:2000)
 cc      SAVE /KKK/
       COMMON  /KAON/    AK(3,50,36),SPECK(50,36,7),MF
 cc      SAVE /KAON/
       COMMON/TABLE/ xarray(0:1000),earray(0:1000)
 cc      SAVE /TABLE/
       common/input1/ MASSPR,MASSTA,ISEED,IAVOID,DT
 cc      SAVE /input1/
       common/leadng/lb1,px1,py1,pz1,em1,e1,xfnl,yfnl,zfnl,tfnl,
      1 px1n,py1n,pz1n,dp1n
 cc      SAVE /leadng/
       COMMON/tdecay/tfdcy(MAXSTR),tfdpi(MAXSTR,MAXR),tft(MAXSTR)
 cc      SAVE /tdecay/
       common /lastt/itimeh,bimp 
 cc      SAVE /lastt/
 c
       COMMON/ppbmas/niso(15),nstate,ppbm(15,2),thresh(15),weight(15)
 cc      SAVE /ppbmas/
       common/ppb1/ene,factr2(6),fsum,ppinnb,s,wtot
 cc      SAVE /ppb1/
       common/ppmm/pprr,ppee,pppe,rpre,xopoe,rree
 cc      SAVE /ppmm/
       COMMON/hbt/lblast(MAXSTR),xlast(4,MAXSTR),plast(4,MAXSTR),nlast
 cc      SAVE /hbt/
       common/resdcy/NSAV,iksdcy
 cc      SAVE /resdcy/
       COMMON/RNDF77/NSEED
 cc      SAVE /RNDF77/
       COMMON/FTMAX/ftsv(MAXSTR),ftsvt(MAXSTR, MAXR)
       dimension ftpisv(MAXSTR,MAXR),fttemp(MAXSTR)
       common /dpi/em2,lb2
       common/phidcy/iphidcy,pttrig,ntrig,maxmiss,ipi0dcy
 clin-5/2008:
       DIMENSION dptemp(MAXSTR)
       common /para8/ idpert,npertd,idxsec
       COMMON /dpert/dpertt(MAXSTR,MAXR),dpertp(MAXSTR),dplast(MAXSTR),
      1     dpdcy(MAXSTR),dpdpi(MAXSTR,MAXR),dpt(MAXSTR, MAXR),
      2     dpp1(MAXSTR,MAXR),dppion(MAXSTR,MAXR)
 c
       real zet(-45:45)
       SAVE   
       data zet /
      4     1.,0.,0.,0.,0.,
      3     1.,0.,0.,0.,0.,0.,0.,0.,0.,0.,
      2     -1.,0.,0.,0.,0.,0.,0.,0.,0.,0.,
      1     0.,0.,0.,-1.,0.,1.,0.,-1.,0.,-1.,
      s     0.,-2.,-1.,0.,1.,0.,0.,0.,0.,-1.,
      e     0.,
      s     1.,0.,-1.,0.,1.,-1.,0.,1.,2.,0.,
      1     1.,0.,1.,0.,-1.,0.,1.,0.,0.,0.,
      2     -1.,0.,1.,0.,-1.,0.,1.,0.,0.,1.,
      3     0.,0.,0.,0.,0.,0.,0.,0.,0.,-1.,
      4     0.,0.,0.,0.,-1./
 
 clin-2/19/03 initialize n and nsav for resonance decay at each timestep
 c     in order to prevent integer overflow:
       call inidcy
 
 c OFF skip ART collisions to reproduce HJ:      
 cc       if(nt.ne.ntmax) return
 
 clin-11/07/00 rrkk is assumed to be 0.6mb(default) for mm->KKbar 
 c     with m=rho or omega, estimated from Ko's paper:
 c      rrkk=0.6
 c prkk: cross section of pi (rho or omega) -> K* Kbar (AND) K*bar K:
 c      prkk=0.3
 c     cross section in mb for (rho or omega) K* -> pi K:
 c      srhoks=5.
 clin-11/07/00-end
 c      ESBIN=0.04
       RESONA=5.
 *-----------------------------------------------------------------------
 *     INITIALIZATION OF COUNTING VARIABLES
       NODELT=0
       SUMSRT =0.
       LCOLL  = 0
       LBLOC  = 0
       LCNNE  = 0
       LDD  = 0
       LPP  = 0
       lpd  = 0
       lpdr=0
       lrho = 0
       lrhor=0
       lomega=0
       lomgar=0
       LPN  = 0
       LKN  = 0
       LNNK = 0
       LDDK = 0
       LNDK = 0
       lppk =0
       LCNND  = 0
       LCNDN  = 0
       LDIRT  = 0
       LDECAY = 0
       LRES   = 0
       Ldou   = 0
       LDDRHO = 0
       LNNRHO = 0
       LNNOM  = 0
       MSUM   = 0
       MASSRN(0)=0
 * COM: MSUM IS USED TO COUNT THE TOTAL NO. OF PARTICLES 
 *      IN PREVIOUS IRUN-1 RUNS
 * KAON COUNTERS
       DO 1002 IL=1,5
          TKAON(IL)=0
          DO 1001 IS=1,2000
             EKAON(IL,IS)=0
  1001    CONTINUE
  1002 CONTINUE
 c sp 12/19/00
       DO 1004 i =1,NUM
          DO 1003 j =1,MAXSTR
             PROPI(j,i) = 1.
  1003    CONTINUE
  1004 CONTINUE
       
       do 1102 i=1,maxstr
          fttemp(i)=0.
          do 1101 irun=1,maxr
             ftpisv(i,irun)=0.
  1101    continue
  1102 continue
 
 c sp 12/19/00 end
       sp=0
 * antikaon counters
       akaon=0
       sk=0
 *-----------------------------------------------------------------------
 *     LOOP OVER ALL PARALLEL RUNS
 cbz11/17/98
 c      MASS=MASSPR+MASSTA
       MASS = 0
 cbz11/17/98end
       DO 1000 IRUN = 1,NUM
          NNN=0
          MSUM=MSUM+MASSR(IRUN-1)
 *     LOOP OVER ALL PSEUDOPARTICLES 1 IN THE SAME RUN
          J10=2
          IF(NT.EQ.NTMAX)J10=1
 c
 ctest off skips the check of energy conservation after each timestep:
 c         enetot=0.
 c         do ip=1,MASSR(IRUN)
 c            if(e(ip).ne.0.or.lb(ip).eq.10022) enetot=enetot
 c     1           +sqrt(p(1,ip)**2+p(2,ip)**2+p(3,ip)**2+e(ip)**2)
 c         enddo
 c         write(91,*) 'A:',nt,enetot,massr(irun),bimp 
 
          DO 800 J1 = J10,MASSR(IRUN)
             I1  = J1 + MSUM
 * E(I)=0 are for pions having been absorbed or photons which do not enter here:
 clin-4/2012 option of pi0 decays:
 c            IF(E(I1).EQ.0.)GO TO 800
             IF(E(I1).EQ.0.)GO TO 798
 c     To include anti-(Delta,N*1440 and N*1535):
 c          IF ((LB(I1) .LT. -13 .OR. LB(I1) .GT. 28)
 c     1         .and.iabs(LB(I1)) .ne. 30 ) GOTO 800
 clin-4/2012 option of pi0 decays:
 c            IF (LB(I1) .LT. -45 .OR. LB(I1) .GT. 45) GOTO 800
             IF (LB(I1) .LT. -45 .OR. LB(I1) .GT. 45) GOTO 798
             X1  = R(1,I1)
             Y1  = R(2,I1)
             Z1  = R(3,I1)
             PX1 = P(1,I1)
             PY1 = P(2,I1)
             PZ1 = P(3,I1)
             EM1 = E(I1)
             am1= em1
             E1  = SQRT( EM1**2 + PX1**2 + PY1**2 + PZ1**2 )
             ID1 = ID(I1)
             LB1 = LB(I1)
 
 c     generate k0short and k0long from K+ and K- at the last timestep:
             if(nt.eq.ntmax.and.(lb1.eq.21.or.lb1.eq.23)) then
                pk0=RANART(NSEED)
                if(pk0.lt.0.25) then
                   LB(I1)=22
                elseif(pk0.lt.0.50) then
                   LB(I1)=24
                endif
                LB1=LB(I1)
             endif
             
 clin-8/07/02 these particles don't decay strongly, so skip decay routines:     
 c            IF( (lb1.ge.-2.and.lb1.le.5) .OR. lb1.eq.31 .OR.
 c     &           (iabs(lb1).ge.14.and.iabs(lb1).le.24) .OR.
 c     &           (iabs(lb1).ge.40.and.iabs(lb1).le.45) .or. 
 c     &           lb1.eq.31)GO TO 1 
 c     only decay K0short when iksdcy=1:
             if(lb1.eq.0.or.lb1.eq.25.or.lb1.eq.26.or.lb1.eq.27
      &           .or.lb1.eq.28.or.lb1.eq.29.or.iabs(lb1).eq.30
      &           .or.(iabs(lb1).ge.6.and.iabs(lb1).le.13)
      &           .or.(iksdcy.eq.1.and.lb1.eq.24)
      &           .or.iabs(lb1).eq.16
      &           .or.(ipi0dcy.eq.1.and.nt.eq.ntmax.and.lb1.eq.4)) then
 clin-4/2012-above for option of pi0 decay:
 c     &           .or.iabs(lb1).eq.16) then
                continue
             else
                goto 1
             endif
 * IF I1 IS A RESONANCE, CHECK WHETHER IT DECAYS DURING THIS TIME STEP
          IF(lb1.ge.25.and.lb1.le.27) then
              wid=0.151
          ELSEIF(lb1.eq.28) then
              wid=0.00841
          ELSEIF(lb1.eq.29) then
              wid=0.00443
           ELSEIF(iabs(LB1).eq.30) then
              WID=0.051
          ELSEIF(lb1.eq.0) then
              wid=1.18e-6
 c     to give K0short ct0=2.676cm:
          ELSEIF(iksdcy.eq.1.and.lb1.eq.24) then
              wid=7.36e-15
 clin-4/29/03 add Sigma0 decay to Lambda, ct0=2.22E-11m:
          ELSEIF(iabs(lb1).eq.16) then
              wid=8.87e-6
 csp-07/25/01 test a1 resonance:
 cc          ELSEIF(LB1.EQ.32) then
 cc             WID=0.40
           ELSEIF(LB1.EQ.32) then
              call WIDA1(EM1,rhomp,WID,iseed)
           ELSEIF(iabs(LB1).ge.6.and.iabs(LB1).le.9) then
              WID=WIDTH(EM1)
           ELSEIF((iabs(LB1).EQ.10).OR.(iabs(LB1).EQ.11)) then
              WID=W1440(EM1)
           ELSEIF((iabs(LB1).EQ.12).OR.(iabs(LB1).EQ.13)) then
              WID=W1535(EM1)
 clin-4/2012 for option of pi0 decay:
           ELSEIF(ipi0dcy.eq.1.and.nt.eq.ntmax.and.lb1.eq.4) then
              wid=7.85e-9
           ENDIF
 
 * if it is the last time step, FORCE all resonance to strong-decay
 * and go out of the loop
           if(nt.eq.ntmax)then
              pdecay=1.1
 clin-5b/2008 forbid phi decay at the end of hadronic cascade:
              if(iphidcy.eq.0.and.iabs(LB1).eq.29) pdecay=0.
 ctest off clin-9/2012 forbid long-time decays (eta,omega,K*,Sigma0)
 c     at the end of hadronic cascade to analyze freezeout time:
 c             if(LB1.eq.0.or.LB1.eq.28.or.iabs(LB1).eq.30
 c     1            .or.iabs(LB1).eq.16) pdecay=0.
           else
              T0=0.19733/WID
              GFACTR=E1/EM1
              T0=T0*GFACTR
              IF(T0.GT.0.)THEN
                 PDECAY=1.-EXP(-DT/T0)
              ELSE
                 PDECAY=0.
              ENDIF
           endif
           XDECAY=RANART(NSEED)
 
 cc dilepton production from rho0, omega, phi decay 
 cc        if(lb1.eq.26 .or. lb1.eq.28 .or. lb1.eq.29)
 cc     &   call dec_ceres(nt,ntmax,irun,i1)
 cc
           IF(XDECAY.LT.PDECAY) THEN
 clin-10/25/02 get rid of argument usage mismatch in rhocay():
              idecay=irun
              tfnl=nt*dt
 clin-10/28/03 keep formation time of hadrons unformed at nt=ntmax-1:
              if(nt.eq.ntmax.and.ftsv(i1).gt.((ntmax-1)*dt)) 
      1            tfnl=ftsv(i1)
              xfnl=x1
              yfnl=y1
              zfnl=z1
 * use PYTHIA to perform decays of eta,rho,omega,phi,K*,(K0s) and Delta:
              if(lb1.eq.0.or.lb1.eq.25.or.lb1.eq.26.or.lb1.eq.27
      &           .or.lb1.eq.28.or.lb1.eq.29.or.iabs(lb1).eq.30
      &           .or.(iabs(lb1).ge.6.and.iabs(lb1).le.9)
      &           .or.(iksdcy.eq.1.and.lb1.eq.24)
      &           .or.iabs(lb1).eq.16
      &           .or.(ipi0dcy.eq.1.and.nt.eq.ntmax.and.lb1.eq.4)) then
 clin-4/2012 Above for option of pi0 decay:
 c     &           .or.iabs(lb1).eq.16) then
 c     previous rho decay performed in rhodecay():
 c                nnn=nnn+1
 c                call rhodecay(idecay,i1,nnn,iseed)
 c
 ctest off record decays of phi,K*,Lambda(1520) resonances:
 c                if(lb1.eq.29.or.iabs(lb1).eq.30) 
 c     1               write(18,112) 'decay',lb1,px1,py1,pz1,am1,nt
 c
 clin-4/2012 option of pi0 decays:
 c                call resdec(i1,nt,nnn,wid,idecay)
                 call resdec(i1,nt,nnn,wid,idecay,0)
                 p(1,i1)=px1n
                 p(2,i1)=py1n
                 p(3,i1)=pz1n
 clin-5/2008:
                 dpertp(i1)=dp1n
 c     add decay time to freezeout positions & time at the last timestep:
                 if(nt.eq.ntmax) then
                    R(1,i1)=xfnl
                    R(2,i1)=yfnl
                    R(3,i1)=zfnl
                    tfdcy(i1)=tfnl
                 endif
 c
 * decay number for baryon resonance or L/S decay
                 if(iabs(lb1).ge.6.and.iabs(lb1).le.9) then
                    LDECAY=LDECAY+1
                 endif
 
 * for a1 decay 
 c             elseif(lb1.eq.32)then
 c                NNN=NNN+1
 c                call a1decay(idecay,i1,nnn,iseed,rhomp)
 
 * FOR N*(1440)
              elseif(iabs(LB1).EQ.10.OR.iabs(LB1).EQ.11) THEN
                 NNN=NNN+1
                 LDECAY=LDECAY+1
                 PNSTAR=1.
                 IF(E(I1).GT.1.22)PNSTAR=0.6
                 IF(RANART(NSEED).LE.PNSTAR)THEN
 * (1) DECAY TO SINGLE PION+NUCLEON
                    CALL DECAY(idecay,I1,NNN,ISEED,wid,nt)
                 ELSE
 * (2) DECAY TO TWO PIONS + NUCLEON
                    CALL DECAY2(idecay,I1,NNN,ISEED,wid,nt)
                    NNN=NNN+1
                 ENDIF
 c for N*(1535) decay
              elseif(iabs(LB1).eq.12.or.iabs(LB1).eq.13) then
                 NNN=NNN+1
                 CALL DECAY(idecay,I1,NNN,ISEED,wid,nt)
                 LDECAY=LDECAY+1
              endif
 c
 *COM: AT HIGH ENERGIES WE USE VERY SHORT TIME STEPS,
 *     IN ORDER TO TAKE INTO ACCOUNT THE FINITE FORMATIOM TIME, WE
 *     DO NOT ALLOW PARTICLES FROM THE DECAY OF RESONANCE TO INTERACT 
 *     WITH OTHERS IN THE SAME TIME STEP. CHANGE 9000 TO REVERSE THIS 
 *     ASSUMPTION. EFFECTS OF THIS ASSUMPTION CAN BE STUDIED BY CHANGING 
 *     THE STATEMENT OF 9000. See notebook for discussions on effects of
 *     changing statement 9000.
 c
 c     kaons from K* decay are converted to k0short (and k0long), 
 c     phi decay may produce rho, K0S or eta, N*(1535) decay may produce eta,
 c     and these decay daughters need to decay again if at the last timestep:
 c     (note: these daughters have been assigned to lb(i1) only, not to lpion)
 c             if(nt.eq.ntmax.and.(lb1.eq.29.or.iabs(lb1).eq.30
 c     1            .iabs(lb1).eq.12.or.iabs(lb1).eq.13)) then
              if(nt.eq.ntmax) then
                 if(lb(i1).eq.25.or.lb(i1).eq.26.or.lb(i1).eq.27) then
                    wid=0.151
                 elseif(lb(i1).eq.0) then
                    wid=1.18e-6
                 elseif(lb(i1).eq.24.and.iksdcy.eq.1) then
 clin-4/2012 corrected K0s decay width:
 c                   wid=7.36e-17
                    wid=7.36e-15
 clin-4/2012 option of pi0 decays:
                 elseif(ipi0dcy.eq.1.and.lb(i1).eq.4) then
                    wid=7.85e-9
                 else
                    goto 9000
                 endif
                 LB1=LB(I1)
                 PX1=P(1,I1)
                 PY1=P(2,I1)
                 PZ1=P(3,I1)
                 EM1=E(I1)
                 E1=SQRT(EM1**2+PX1**2+PY1**2+PZ1**2)
 clin-4/2012 option of pi0 decays:
 c                call resdec(i1,nt,nnn,wid,idecay)
                 call resdec(i1,nt,nnn,wid,idecay,0)
                 p(1,i1)=px1n
                 p(2,i1)=py1n
                 p(3,i1)=pz1n
                 R(1,i1)=xfnl
                 R(2,i1)=yfnl
                 R(3,i1)=zfnl
                 tfdcy(i1)=tfnl
 clin-5/2008:
                 dpertp(i1)=dp1n
              endif
 
 c     Decay daughter of the above decay in lb(i1) may be a pi0:
              if(nt.eq.ntmax.and.ipi0dcy.eq.1.and.lb(i1).eq.4) then
                 wid=7.85e-9
                 LB1=LB(I1)
                 PX1=P(1,I1)
                 PY1=P(2,I1)
                 PZ1=P(3,I1)
                 EM1=E(I1)
                 E1=SQRT(EM1**2+PX1**2+PY1**2+PZ1**2)
                 call resdec(i1,nt,nnn,wid,idecay,0)
                 p(1,i1)=px1n
                 p(2,i1)=py1n
                 p(3,i1)=pz1n
                 R(1,i1)=xfnl
                 R(2,i1)=yfnl
                 R(3,i1)=zfnl
                 tfdcy(i1)=tfnl
                 dpertp(i1)=dp1n
              endif
 
 * negelecting the Pauli blocking at high energies
 clin-4/2012 option of pi0 decays:
 c 9000        go to 800
  9000        go to 798
 
           ENDIF
 * LOOP OVER ALL PSEUDOPARTICLES 2 IN THE SAME RUN
 * SAVE ALL THE COORDINATES FOR POSSIBLE CHANGE IN THE FOLLOWING COLLISION
 clin-4/2012 option of pi0 decays:
 c 1        if(nt.eq.ntmax)go to 800
  1        if(nt.eq.ntmax)go to 798
 
           X1 = R(1,I1)
           Y1 = R(2,I1)
           Z1 = R(3,I1)
 c
            DO 600 J2 = 1,J1-1
             I2  = J2 + MSUM
 * IF I2 IS A MESON BEING ABSORBED, THEN GO OUT OF THE LOOP
             IF(E(I2).EQ.0.) GO TO 600
 clin-5/2008 in case the first particle is already destroyed:
             IF(E(I1).EQ.0.) GO TO 800
 clin-4/2012 option of pi0 decays:
             IF (LB(I2) .LT. -45 .OR. LB(I2) .GT. 45) GOTO 600
 clin-7/26/03 improve speed
             X2=R(1,I2)
             Y2=R(2,I2)
             Z2=R(3,I2)
             dr0max=5.
 clin-9/2008 deuteron+nucleon elastic cross sections could reach ~2810mb:
             ilb1=iabs(LB(I1))
             ilb2=iabs(LB(I2))
             IF(ilb1.EQ.42.or.ilb2.EQ.42) THEN
                if((ILB1.GE.1.AND.ILB1.LE.2)
      1              .or.(ILB1.GE.6.AND.ILB1.LE.13)
      2              .or.(ILB2.GE.1.AND.ILB2.LE.2)
      3              .or.(ILB2.GE.6.AND.ILB2.LE.13)) then
                   if((lb(i1)*lb(i2)).gt.0) dr0max=10.
                endif
             ENDIF
 c
             if(((X1-X2)**2+(Y1-Y2)**2+(Z1-Z2)**2).GT.dr0max**2)
      1           GO TO 600
             IF (ID(I1)*ID(I2).EQ.IAVOID) GOTO 400
             ID1=ID(I1)
             ID2 = ID(I2)
 c
             ix1= nint(x1/dx)
             iy1= nint(y1/dy)
             iz1= nint(z1/dz)
             PX1=P(1,I1)
             PY1=P(2,I1)
             PZ1=P(3,I1)
             EM1=E(I1)
             AM1=EM1
             LB1=LB(I1)
             E1=SQRT(EM1**2+PX1**2+PY1**2+PZ1**2)
             IPX1=NINT(PX1/DPX)
             IPY1=NINT(PY1/DPY)
             IPZ1=NINT(PZ1/DPZ)         
             LB2 = LB(I2)
             PX2 = P(1,I2)
             PY2 = P(2,I2)
             PZ2 = P(3,I2)
             EM2=E(I2)
             AM2=EM2
             lb1i=lb(i1)
             lb2i=lb(i2)
             px1i=P(1,I1)
             py1i=P(2,I1)
             pz1i=P(3,I1)
             em1i=E(I1)
             px2i=P(1,I2)
             py2i=P(2,I2)
             pz2i=P(3,I2)
             em2i=E(I2)
 clin-2/26/03 ctest off check energy conservation after each binary search:
             eini=SQRT(E(I1)**2+P(1,I1)**2+P(2,I1)**2+P(3,I1)**2)
      1           +SQRT(E(I2)**2+P(1,I2)**2+P(2,I2)**2+P(3,I2)**2)
             pxini=P(1,I1)+P(1,I2)
             pyini=P(2,I1)+P(2,I2)
             pzini=P(3,I1)+P(3,I2)
             nnnini=nnn
 c
 clin-4/30/03 initialize value:
             iblock=0
 c
 * TO SAVE COMPUTING TIME we do the following
 * (1) make a ROUGH estimate to see whether particle i2 will collide with
 * particle I1, and (2) skip the particle pairs for which collisions are 
 * not modeled in the code.
 * FOR MESON-BARYON AND MESON-MESON COLLISIONS, we use a maximum 
 * interaction distance DELTR0=2.6
 * for ppbar production from meson (pi rho omega) interactions:
 c
             DELTR0=3.
         if( (iabs(lb1).ge.14.and.iabs(lb1).le.17) .or.
      &      (iabs(lb1).ge.30.and.iabs(lb1).le.45) ) DELTR0=5.0
         if( (iabs(lb2).ge.14.and.iabs(lb2).le.17) .or.
      &      (iabs(lb2).ge.30.and.iabs(lb2).le.45) ) DELTR0=5.0
 
             if(lb1.eq.28.and.lb2.eq.28) DELTR0=4.84
 clin-10/08/00 to include pi pi -> rho rho:
             if((lb1.ge.3.and.lb1.le.5).and.(lb2.ge.3.and.lb2.le.5)) then
                E2=SQRT(EM2**2+PX2**2+PY2**2+PZ2**2)
          spipi=(e1+e2)**2-(px1+px2)**2-(py1+py2)**2-(pz1+pz2)**2
                if(spipi.ge.(4*0.77**2)) DELTR0=3.5
             endif
 
 c khyperon
         IF (LB1.EQ.23 .AND. (LB2.GE.14.AND.LB2.LE.17)) GOTO 3699
         IF (LB2.EQ.23 .AND. (LB1.GE.14.AND.LB1.LE.17)) GOTO 3699
 
 * K(K*) + Kbar(K*bar) scattering including 
 *     K(K*) + Kbar(K*bar) --> phi + pi(rho,omega) and pi pi(rho,omega)
        if(lb1.eq.21.and.lb2.eq.23)go to 3699
        if(lb2.eq.21.and.lb1.eq.23)go to 3699
        if(lb1.eq.30.and.lb2.eq.21)go to 3699
        if(lb2.eq.30.and.lb1.eq.21)go to 3699
        if(lb1.eq.-30.and.lb2.eq.23)go to 3699
        if(lb2.eq.-30.and.lb1.eq.23)go to 3699
        if(lb1.eq.-30.and.lb2.eq.30)go to 3699
        if(lb2.eq.-30.and.lb1.eq.30)go to 3699
 c
 clin-12/15/00
 c     kaon+rho(omega,eta) collisions:
       if(lb1.eq.21.or.lb1.eq.23) then
          if(lb2.eq.0.or.(lb2.ge.25.and.lb2.le.28)) then
             go to 3699
          endif
       elseif(lb2.eq.21.or.lb2.eq.23) then
          if(lb1.eq.0.or.(lb1.ge.25.and.lb1.le.28)) then
             goto 3699
          endif
       endif
 
 clin-8/14/02 K* (pi, rho, omega, eta) collisions:
       if(iabs(lb1).eq.30 .and.
      1     (lb2.eq.0.or.(lb2.ge.25.and.lb2.le.28)
      2     .or.(lb2.ge.3.and.lb2.le.5))) then
          go to 3699
       elseif(iabs(lb2).eq.30 .and.
      1        (lb1.eq.0.or.(lb1.ge.25.and.lb1.le.28)
      2        .or.(lb1.ge.3.and.lb1.le.5))) then
          goto 3699
 clin-8/14/02-end
 c K*/K*-bar + baryon/antibaryon collisions:
         elseif( iabs(lb1).eq.30 .and.
      1     (iabs(lb2).eq.1.or.iabs(lb2).eq.2.or.
      2     (iabs(lb2).ge.6.and.iabs(lb2).le.13)) )then
               go to 3699
            endif
          if( iabs(lb2).eq.30 .and.
      1         (iabs(lb1).eq.1.or.iabs(lb1).eq.2.or.
      2         (iabs(lb1).ge.6.and.iabs(lb1).le.13)) )then
                 go to 3699
         endif                                                              
 * K^+ baryons and antibaryons:
 c** K+ + B-bar  --> La(Si)-bar + pi
 * K^- and antibaryons, note K^- and baryons are included in newka():
 * note that we fail to satisfy charge conjugation for these cross sections:
         if((lb1.eq.23.or.lb1.eq.21).and.
      1       (iabs(lb2).eq.1.or.iabs(lb2).eq.2.or.
      2       (iabs(lb2).ge.6.and.iabs(lb2).le.13))) then
            go to 3699
         elseif((lb2.eq.23.or.lb2.eq.21).and.
      1       (iabs(lb1).eq.1.or.iabs(lb1).eq.2.or.
      2       (iabs(lb1).ge.6.and.iabs(lb1).le.13))) then
            go to 3699
         endif
 *
 * For anti-nucleons annihilations:
 * Assumptions: 
 * (1) for collisions involving a p_bar or n_bar,
 * we allow only collisions between a p_bar and a baryon or a baryon 
 * resonance (as well as a n_bar and a baryon or a baryon resonance),
 * we skip all other reactions involving a p_bar or n_bar, 
 * such as collisions between p_bar (n_bar) and mesons, 
 * and collisions between two p_bar's (n_bar's). 
 * (2) we introduce a new parameter rppmax: the maximum interaction 
 * distance to make the quick collision check,rppmax=3.57 fm 
 * corresponding to a cutoff of annihilation xsection= 400mb which is
 * also used consistently in the actual annihilation xsection to be 
 * used in the following as given in the subroutine xppbar(srt)
         rppmax=3.57   
 * anti-baryon on baryons
         if((lb1.eq.-1.or.lb1.eq.-2.or.(lb1.ge.-13.and.lb1.le.-6))
      1 .and.(lb2.eq.1.or.lb2.eq.2.or.(lb2.ge.6.and.lb2.le.13))) then
             DELTR0 = RPPMAX
             GOTO 2699
        else if((lb2.eq.-1.or.lb2.eq.-2.or.(lb2.ge.-13.and.lb2.le.-6))
      1 .and.(lb1.eq.1.or.lb1.eq.2.or.(lb1.ge.6.and.lb1.le.13))) then
             DELTR0 = RPPMAX
             GOTO 2699
          END IF
 
 c*  ((anti) lambda, cascade, omega  should not be rejected)
         if( (iabs(lb1).ge.14.and.iabs(lb1).le.17) .or.
      &      (iabs(lb2).ge.14.and.iabs(lb2).le.17) )go to 3699
 c
 clin-9/2008 maximum sigma~2810mb for deuteron+nucleon elastic collisions:
          IF (iabs(LB1).EQ.42.or.iabs(LB2).EQ.42) THEN
             ilb1=iabs(LB1)
             ilb2=iabs(LB2)
             if((ILB1.GE.1.AND.ILB1.LE.2)
      1           .or.(ILB1.GE.6.AND.ILB1.LE.13)
      2           .or.(ILB2.GE.1.AND.ILB2.LE.2)
      3           .or.(ILB2.GE.6.AND.ILB2.LE.13)) then
                if((lb1*lb2).gt.0) deltr0=9.5
             endif
          ENDIF
 c
         if( (iabs(lb1).ge.40.and.iabs(lb1).le.45) .or. 
      &      (iabs(lb2).ge.40.and.iabs(lb2).le.45) )go to 3699
 c
 c* phi channel --> elastic + inelastic scatt.  
          IF( (lb1.eq.29 .and.((lb2.ge.1.and.lb2.le.13).or.  
      &       (lb2.ge.21.and.lb2.le.28).or.iabs(lb2).eq.30)) .OR.
      &     (lb2.eq.29 .and.((lb1.ge.1.and.lb1.le.13).or.
      &       (lb1.ge.21.and.lb1.le.28).or.iabs(lb1).eq.30)) )THEN
              DELTR0=3.0
              go to 3699
         endif
 c
 c  La/Si, Cas, Om (bar)-meson elastic colln
 * pion vs. La & Ca (bar) coll. are treated in resp. subroutines
 
 * SKIP all other K* RESCATTERINGS
         If(iabs(lb1).eq.30.or.iabs(lb2).eq.30) go to 400
 * SKIP KAON(+) RESCATTERINGS WITH particles other than pions and baryons 
          If(lb1.eq.23.and.(lb2.lt.1.or.lb2.gt.17))go to 400
          If(lb2.eq.23.and.(lb1.lt.1.or.lb1.gt.17))go to 400
 c
 c anti-baryon proccess: B-bar+M, N-bar+R-bar, N-bar+N-bar, R-bar+R-bar
 c  R = (D,N*)
          if( ((lb1.le.-1.and.lb1.ge.-13)
      &        .and.(lb2.eq.0.or.(lb2.ge.3.and.lb2.le.5)
      &            .or.(lb2.ge.25.and.lb2.le.28))) 
      &      .OR.((lb2.le.-1.and.lb2.ge.-13)
      &         .and.(lb1.eq.0.or.(lb1.ge.3.and.lb1.le.5)
      &              .or.(lb1.ge.25.and.lb1.le.28))) ) then
          elseIF( ((LB1.eq.-1.or.lb1.eq.-2).
      &             and.(LB2.LT.-5.and.lb2.ge.-13))
      &      .OR. ((LB2.eq.-1.or.lb2.eq.-2).
      &             and.(LB1.LT.-5.and.lb1.ge.-13)) )then
          elseIF((LB1.eq.-1.or.lb1.eq.-2)
      &     .AND.(LB2.eq.-1.or.lb2.eq.-2))then
          elseIF((LB1.LT.-5.and.lb1.ge.-13).AND.
      &          (LB2.LT.-5.and.lb2.ge.-13)) then
 c        elseif((lb1.lt.0).or.(lb2.lt.0)) then
 c         go to 400
        endif               
 
  2699    CONTINUE
 * for baryon-baryon collisions
          IF (LB1 .EQ. 1 .OR. LB1 .EQ. 2 .OR. (LB1 .GE. 6 .AND.
      &        LB1 .LE. 17)) THEN
             IF (LB2 .EQ. 1 .OR. LB2 .EQ. 2 .OR. (LB2 .GE. 6 .AND.
      &           LB2 .LE. 17)) THEN
                DELTR0 = 2.
             END IF
          END IF
 c
  3699   RSQARE = (X1-X2)**2 + (Y1-Y2)**2 + (Z1-Z2)**2
         IF (RSQARE .GT. DELTR0**2) GO TO 400
 *NOW PARTICLES ARE CLOSE ENOUGH TO EACH OTHER !
 * KEEP ALL COORDINATES FOR POSSIBLE PHASE SPACE CHANGE
             ix2 = nint(x2/dx)
             iy2 = nint(y2/dy)
             iz2 = nint(z2/dz)
             ipx2 = nint(px2/dpx)
             ipy2 = nint(py2/dpy)
             ipz2 = nint(pz2/dpz)
 * FIND MOMENTA OF PARTICLES IN THE CMS OF THE TWO COLLIDING PARTICLES
 * AND THE CMS ENERGY SRT
             CALL CMS(I1,I2,PCX,PCY,PCZ,SRT)
 
 clin-7/26/03 improve speed
           drmax=dr0max
           call distc0(drmax,deltr0,DT,
      1         Ifirst,PCX,PCY,PCZ,
      2         x1,y1,z1,px1,py1,pz1,em1,x2,y2,z2,px2,py2,pz2,em2)
           if(Ifirst.eq.-1) goto 400
 
          ISS=NINT(SRT/ESBIN)
 clin-4/2008 use last bin if ISS is out of EKAON's upper bound of 2000:
          if(ISS.gt.2000) ISS=2000
 *Sort collisions
 c
 clin-8/2008 Deuteron+Meson->B+B; 
 c     meson=(pi,rho,omega,eta), B=(n,p,Delta,N*1440,N*1535):
          IF (iabs(LB1).EQ.42.or.iabs(LB2).EQ.42) THEN
             ilb1=iabs(LB1)
             ilb2=iabs(LB2)
             if(LB1.eq.0.or.(LB1.GE.3.AND.LB1.LE.5)
      1           .or.(LB1.GE.25.AND.LB1.LE.28)
      2           .or.
      3           LB2.eq.0.or.(LB2.GE.3.AND.LB2.LE.5)
      4           .or.(LB2.GE.25.AND.LB2.LE.28)) then
                GOTO 505
 clin-9/2008 Deuteron+Baryon or antiDeuteron+antiBaryon elastic collisions:
             elseif(((ILB1.GE.1.AND.ILB1.LE.2)
      1              .or.(ILB1.GE.6.AND.ILB1.LE.13)
      2              .or.(ILB2.GE.1.AND.ILB2.LE.2)
      3              .or.(ILB2.GE.6.AND.ILB2.LE.13))
      4              .and.(lb1*lb2).gt.0) then
                GOTO 506
             else
                GOTO 400
             endif
          ENDIF
 c
 * K+ + (N,N*,D)-bar --> L/S-bar + pi
           if( ((lb1.eq.23.or.lb1.eq.30).and.
      &         (lb2.eq.-1.or.lb2.eq.-2.or.(lb2.ge.-13.and.lb2.le.-6))) 
      &         .OR.((lb2.eq.23.or.lb2.eq.30).and.
      &         (lb1.eq.-1.or.lb1.eq.-2.or.(lb1.ge.-13.and.lb1.le.-6))) )
      &         then
              bmass=0.938
              if(srt.le.(bmass+aka)) then
                 pkaon=0.
              else
                 pkaon=sqrt(((srt**2-(aka**2+bmass**2))
      1               /2./bmass)**2-aka**2)
              endif
 clin-10/31/02 cross sections are isospin-averaged, same as those in newka
 c     for K- + (N,N*,D) --> L/S + pi:
              sigela = 0.5 * (AKPEL(PKAON) + AKNEL(PKAON))
              SIGSGM = 1.5 * AKPSGM(PKAON) + AKNSGM(PKAON)
              SIG = sigela + SIGSGM + AKPLAM(PKAON)
              if(sig.gt.1.e-7) then
 c     ! K+ + N-bar reactions
                 icase=3
                 brel=sigela/sig
                 brsgm=sigsgm/sig
                 brsig = sig
                 nchrg = 1
                 go to 3555
              endif
              go to 400
           endif
 c
 c
 c  meson + hyperon-bar -> K+ + N-bar
           if(((lb1.ge.-17.and.lb1.le.-14).and.(lb2.ge.3.and.lb2.le.5)) 
      &         .OR.((lb2.ge.-17.and.lb2.le.-14)
      &         .and.(lb1.ge.3.and.lb1.le.5)))then
              nchrg=-100
  
 C*       first classify the reactions due to total charge.
              if((lb1.eq.-15.and.(lb2.eq.5.or.lb2.eq.27)).OR.
      &            (lb2.eq.-15.and.(lb1.eq.5.or.lb1.eq.27))) then
                 nchrg=-2
 c     ! D-(bar)
                 bmass=1.232
                 go to 110
              endif
              if( (lb1.eq.-15.and.(lb2.eq.0.or.lb2.eq.4.or.lb2.eq.26.or.
      &            lb2.eq.28)).OR.(lb2.eq.-15.and.(lb1.eq.0.or.
      &            lb1.eq.4.or.lb1.eq.26.or.lb1.eq.28)).OR.
      &   ((lb1.eq.-14.or.lb1.eq.-16).and.(lb2.eq.5.or.lb2.eq.27)).OR.
      &   ((lb2.eq.-14.or.lb2.eq.-16).and.(lb1.eq.5.or.lb1.eq.27)) )then
                 nchrg=-1
 c     ! n-bar
                 bmass=0.938
                 go to 110
              endif
              if(  (lb1.eq.-15.and.(lb2.eq.3.or.lb2.eq.25)).OR.
      &            (lb2.eq.-15.and.(lb1.eq.3.or.lb1.eq.25)).OR.
      &            (lb1.eq.-17.and.(lb2.eq.5.or.lb2.eq.27)).OR.
      &            (lb2.eq.-17.and.(lb1.eq.5.or.lb1.eq.27)).OR.
      &            ((lb1.eq.-14.or.lb1.eq.-16).and.(lb2.eq.0.or.lb2.eq.4
      &            .or.lb2.eq.26.or.lb2.eq.28)).OR.
      &            ((lb2.eq.-14.or.lb2.eq.-16).and.(lb1.eq.0.or.lb1.eq.4
      &            .or.lb1.eq.26.or.lb1.eq.28)) )then
                nchrg=0
 c     ! p-bar
                 bmass=0.938
                 go to 110
              endif
              if( (lb1.eq.-17.and.(lb2.eq.0.or.lb2.eq.4.or.lb2.eq.26.or.
      &            lb2.eq.28)).OR.(lb2.eq.-17.and.(lb1.eq.0.or.
      &            lb1.eq.4.or.lb1.eq.26.or.lb1.eq.28)).OR.
      &  ((lb1.eq.-14.or.lb1.eq.-16).and.(lb2.eq.3.or.lb2.eq.25)).OR.
      &  ((lb2.eq.-14.or.lb2.eq.-16).and.(lb1.eq.3.or.lb1.eq.25)))then
                nchrg=1
 c     ! D++(bar)
                 bmass=1.232
              endif
 c
 c 110     if(nchrg.ne.-100.and.srt.ge.(aka+bmass))then !! for elastic
  110         sig = 0.
 c !! for elastic
          if(nchrg.ne.-100.and.srt.ge.(aka+bmass))then
 cc110        if(nchrg.eq.-100.or.srt.lt.(aka+bmass)) go to 400
 c             ! PI + La(Si)-bar => K+ + N-bar reactions
             icase=4
 cc       pkaon=sqrt(((srt**2-(aka**2+bmass**2))/2./bmass)**2-aka**2)
             pkaon=sqrt(((srt**2-(aka**2+0.938**2))/2./0.938)**2-aka**2)
 c ! lambda-bar + Pi
             if(lb1.eq.-14.or.lb2.eq.-14) then
                if(nchrg.ge.0) sigma0=akPlam(pkaon)
                if(nchrg.lt.0) sigma0=akNlam(pkaon)
 c                ! sigma-bar + pi
             else
 c !K-p or K-D++
                if(nchrg.ge.0) sigma0=akPsgm(pkaon)
 c !K-n or K-D-
                if(nchrg.lt.0) sigma0=akNsgm(pkaon)
                SIGMA0 = 1.5 * AKPSGM(PKAON) + AKNSGM(PKAON)
             endif
             sig=(srt**2-(aka+bmass)**2)*(srt**2-(aka-bmass)**2)/
      &           (srt**2-(em1+em2)**2)/(srt**2-(em1-em2)**2)*sigma0
 c ! K0barD++, K-D-
             if(nchrg.eq.-2.or.nchrg.eq.2) sig=2.*sig
 C*     the factor 2 comes from spin of delta, which is 3/2
 C*     detailed balance. copy from Page 423 of N.P. A614 1997
             IF (LB1 .EQ. -14 .OR. LB2 .EQ. -14) THEN
                SIG = 4.0 / 3.0 * SIG
             ELSE IF (NCHRG .EQ. -2 .OR. NCHRG .EQ. 2) THEN
                SIG = 8.0 / 9.0 * SIG
             ELSE
                SIG = 4.0 / 9.0 * SIG
             END IF
 cc        brel=0.
 cc        brsgm=0.
 cc        brsig = sig
 cc          if(sig.lt.1.e-7) go to 400
 *-
          endif
 c                ! PI + La(Si)-bar => elastic included
          icase=4
          sigela = 10.
          sig = sig + sigela
          brel= sigela/sig
          brsgm=0.
          brsig = sig
 *-
          go to 3555
       endif
       
 ** MULTISTRANGE PARTICLE (Cas,Omega -bar) PRODUCTION - (NON)PERTURBATIVE
 
 * K-/K*0bar + La/Si --> cascade + pi/eta
       if( ((lb1.eq.21.or.lb1.eq.-30).and.(lb2.ge.14.and.lb2.le.17)).OR.
      &  ((lb2.eq.21.or.lb2.eq.-30).and.(lb1.ge.14.and.lb1.le.17)) )then
           kp = 0
           go to 3455
         endif
 c K+/K*0 + La/Si(bar) --> cascade-bar + pi/eta
       if( ((lb1.eq.23.or.lb1.eq.30).and.(lb2.le.-14.and.lb2.ge.-17)).OR.
      &  ((lb2.eq.23.or.lb2.eq.30).and.(lb1.le.-14.and.lb1.ge.-17)) )then
           kp = 1
           go to 3455
         endif
 * K-/K*0bar + cascade --> omega + pi
        if( ((lb1.eq.21.or.lb1.eq.-30).and.(lb2.eq.40.or.lb2.eq.41)).OR.
      & ((lb2.eq.21.or.lb2.eq.-30).and.(lb1.eq.40.or.lb1.eq.41)) )then
           kp = 0
           go to 3455
         endif
 * K+/K*0 + cascade-bar --> omega-bar + pi
        if( ((lb1.eq.23.or.lb1.eq.30).and.(lb2.eq.-40.or.lb2.eq.-41)).OR.
      &  ((lb2.eq.23.or.lb2.eq.30).and.(lb1.eq.-40.or.lb1.eq.-41)) )then
           kp = 1
           go to 3455
         endif
 * Omega + Omega --> Di-Omega + photon(eta)
 cc        if( lb1.eq.45.and.lb2.eq.45 ) go to 3455
 
 c annhilation of cascade(bar), omega(bar)
          kp = 3
 * K- + L/S <-- cascade(bar) + pi/eta
        if( (((lb1.ge.3.and.lb1.le.5).or.lb1.eq.0) 
      &       .and.(iabs(lb2).eq.40.or.iabs(lb2).eq.41))
      & .OR. (((lb2.ge.3.and.lb2.le.5).or.lb2.eq.0) 
      &       .and.(iabs(lb1).eq.40.or.iabs(lb1).eq.41)) )go to 3455
 * K- + cascade(bar) <-- omega(bar) + pi
 *         if(  (lb1.eq.0.and.iabs(lb2).eq.45)
 *    &       .OR. (lb2.eq.0.and.iabs(lb1).eq.45) )go to 3455
         if( ((lb1.ge.3.and.lb1.le.5).and.iabs(lb2).eq.45)
      &  .OR.((lb2.ge.3.and.lb2.le.5).and.iabs(lb1).eq.45) )go to 3455
 c
 
 ***  MULTISTRANGE PARTICLE PRODUCTION  (END)
 
 c* K+ + La(Si) --> Meson + B
         IF (LB1.EQ.23 .AND. (LB2.GE.14.AND.LB2.LE.17)) GOTO 5699
         IF (LB2.EQ.23 .AND. (LB1.GE.14.AND.LB1.LE.17)) GOTO 5699
 c* K- + La(Si)-bar --> Meson + B-bar
        IF (LB1.EQ.21 .AND. (LB2.GE.-17.AND.LB2.LE.-14)) GOTO 5699
        IF (LB2.EQ.21 .AND. (LB1.GE.-17.AND.LB1.LE.-14)) GOTO 5699
 
 c La/Si-bar + B --> pi + K+
        IF( (((LB1.eq.1.or.LB1.eq.2).or.(LB1.ge.6.and.LB1.le.13))
      &       .AND.(LB2.GE.-17.AND.LB2.LE.-14)) .OR.
      &     (((LB2.eq.1.or.LB2.eq.2).or.(LB2.ge.6.and.LB2.le.13))
      &      .AND.(LB1.GE.-17.AND.LB1.LE.-14)) )go to 5999
 c La/Si + B-bar --> pi + K-
        IF( (((LB1.eq.-1.or.LB1.eq.-2).or.(LB1.le.-6.and.LB1.ge.-13))
      &       .AND.(LB2.GE.14.AND.LB2.LE.17)) .OR.
      &     (((LB2.eq.-1.or.LB2.eq.-2).or.(LB2.le.-6.and.LB2.ge.-13))
      &       .AND.(LB1.GE.14.AND.LB1.LE.17)) )go to 5999 
 *
 *
 * K(K*) + Kbar(K*bar) --> phi + pi(rho,omega), M + M (M=pi,rho,omega,eta)
        if(lb1.eq.21.and.lb2.eq.23) go to 8699
        if(lb2.eq.21.and.lb1.eq.23) go to 8699
        if(lb1.eq.30.and.lb2.eq.21) go to 8699
        if(lb2.eq.30.and.lb1.eq.21) go to 8699
        if(lb1.eq.-30.and.lb2.eq.23) go to 8699
        if(lb2.eq.-30.and.lb1.eq.23) go to 8699
        if(lb1.eq.-30.and.lb2.eq.30) go to 8699
        if(lb2.eq.-30.and.lb1.eq.30) go to 8699
 c* (K,K*)-bar + rho(omega) --> phi +(K,K*)-bar, piK and elastic
        IF( ((lb1.eq.23.or.lb1.eq.21.or.iabs(lb1).eq.30) .and.
      &      (lb2.ge.25.and.lb2.le.28)) .OR.
      &     ((lb2.eq.23.or.lb2.eq.21.or.iabs(lb2).eq.30) .and.
      &      (lb1.ge.25.and.lb1.le.28)) ) go to 8799
 c
 c* K*(-bar) + pi --> phi + (K,K*)-bar
        IF( (iabs(lb1).eq.30.and.(lb2.ge.3.and.lb2.le.5)) .OR.
      &     (iabs(lb2).eq.30.and.(lb1.ge.3.and.lb1.le.5)) )go to 8799
 *
 c
 c* phi + N --> pi+N(D),  rho+N(D),  K+ +La
 c* phi + D --> pi+N(D),  rho+N(D)
        IF( (lb1.eq.29 .and.(lb2.eq.1.or.lb2.eq.2.or.
      &       (lb2.ge.6.and.lb2.le.9))) .OR.
      &     (lb2.eq.29 .and.(lb1.eq.1.or.lb1.eq.2.or.
      &       (lb1.ge.6.and.lb1.le.9))) )go to 7222
 c
 c* phi + (pi,rho,ome,K,K*-bar) --> K+K, K+K*, K*+K*, (pi,rho,omega)+(K,K*-bar)
        IF( (lb1.eq.29 .and.((lb2.ge.3.and.lb2.le.5).or.
      &      (lb2.ge.21.and.lb2.le.28).or.iabs(lb2).eq.30)) .OR.
      &     (lb2.eq.29 .and.((lb1.ge.3.and.lb1.le.5).or.
      &      (lb1.ge.21.and.lb1.le.28).or.iabs(lb1).eq.30)) )THEN
              go to 7444
       endif
 *
 c
 * La/Si, Cas, Om (bar)-(rho,omega,phi) elastic colln
 * pion vs. La, Ca, Omega-(bar) elastic coll. treated in resp. subroutines
       if( ((iabs(lb1).ge.14.and.iabs(lb1).le.17).or.iabs(lb1).ge.40)
      &    .and.((lb2.ge.25.and.lb2.le.29).or.lb2.eq.0) )go to 888
       if( ((iabs(lb2).ge.14.and.iabs(lb2).le.17).or.iabs(lb2).ge.40)
      &    .and.((lb1.ge.25.and.lb1.le.29).or.lb1.eq.0) )go to 888
 c
 c K+/K* (N,R)  OR   K-/K*- (N,R)-bar  elastic scatt
         if( ((lb1.eq.23.or.lb1.eq.30).and.(lb2.eq.1.or.lb2.eq.2.or.
      &         (lb2.ge.6.and.lb2.le.13))) .OR.
      &      ((lb2.eq.23.or.lb2.eq.30).and.(lb1.eq.1.or.lb1.eq.2.or.
      &         (lb1.ge.6.and.lb1.le.13))) ) go to 888
         if( ((lb1.eq.21.or.lb1.eq.-30).and.(lb2.eq.-1.or.lb2.eq.-2.or.
      &       (lb2.ge.-13.and.lb2.le.-6))) .OR. 
      &      ((lb2.eq.21.or.lb2.eq.-30).and.(lb1.eq.-1.or.lb1.eq.-2.or.
      &       (lb1.ge.-13.and.lb1.le.-6))) ) go to 888
 c
 * L/S-baryon elastic collision 
        If( ((lb1.ge.14.and.lb1.le.17).and.(lb2.ge.6.and.lb2.le.13))
      & .OR.((lb2.ge.14.and.lb2.le.17).and.(lb1.ge.6.and.lb1.le.13)) )
      &   go to 7799
        If(((lb1.le.-14.and.lb1.ge.-17).and.(lb2.le.-6.and.lb2.ge.-13))
      &.OR.((lb2.le.-14.and.lb2.ge.-17).and.(lb1.le.-6.and.lb1.ge.-13)))
      &   go to 7799
 c
 c skip other collns with perturbative particles or hyperon-bar
        if( iabs(lb1).ge.40 .or. iabs(lb2).ge.40
      &    .or. (lb1.le.-14.and.lb1.ge.-17) 
      &    .or. (lb2.le.-14.and.lb2.ge.-17) )go to 400
 c
 c
 * anti-baryon on baryon resonaces 
         if((lb1.eq.-1.or.lb1.eq.-2.or.(lb1.ge.-13.and.lb1.le.-6))
      1 .and.(lb2.eq.1.or.lb2.eq.2.or.(lb2.ge.6.and.lb2.le.13))) then
             GOTO 2799
        else if((lb2.eq.-1.or.lb2.eq.-2.or.(lb2.ge.-13.and.lb2.le.-6))
      1 .and.(lb1.eq.1.or.lb1.eq.2.or.(lb1.ge.6.and.lb1.le.13))) then
             GOTO 2799
          END IF
 c
 clin-10/25/02 get rid of argument usage mismatch in newka():
          inewka=irun
 c        call newka(icase,irun,iseed,dt,nt,
 clin-5/01/03 set iblock value in art1f.f, necessary for resonance studies:
 c        call newka(icase,inewka,iseed,dt,nt,
 c     &                  ictrl,i1,i2,srt,pcx,pcy,pcz)
         call newka(icase,inewka,iseed,dt,nt,
      &                  ictrl,i1,i2,srt,pcx,pcy,pcz,iblock)
 
 clin-10/25/02-end
         IF (ICTRL .EQ. 1) GOTO 400
 c
 * SEPARATE NUCLEON+NUCLEON( BARYON RESONANCE+ BARYON RESONANCE ELASTIC
 * COLLISION), BARYON RESONANCE+NUCLEON AND BARYON-PION
 * COLLISIONS INTO THREE PARTS TO CHECK IF THEY ARE GOING TO SCATTER,
 * WE only allow L/S to COLLIDE elastically with a nucleon and meson
        if((iabs(lb1).ge.14.and.iabs(lb1).le.17).
      &  or.(iabs(lb2).ge.14.and.iabs(lb2).le.17))go to 400
 * IF PION+PION COLLISIONS GO TO 777
 * if pion+eta, eta+eta to create kaons go to 777 
        IF((lb1.ge.3.and.lb1.le.5).and.(lb2.ge.3.and.lb2.le.5))GO TO 777
        if(lb1.eq.0.and.(lb2.ge.3.and.lb2.le.5)) go to 777
        if(lb2.eq.0.and.(lb1.ge.3.and.lb1.le.5)) go to 777
        if(lb1.eq.0.and.lb2.eq.0)go to 777
 * we assume that rho and omega behave the same way as pions in 
 * kaon production
 * (1) rho(omega)+rho(omega)
        if( (lb1.ge.25.and.lb1.le.28).and.
      &     (lb2.ge.25.and.lb2.le.28) )goto 777
 * (2) rho(omega)+pion
       If((lb1.ge.25.and.lb1.le.28).and.(lb2.ge.3.and.lb2.le.5))go to 777
       If((lb2.ge.25.and.lb2.le.28).and.(lb1.ge.3.and.lb1.le.5))go to 777
 * (3) rho(omega)+eta
        if((lb1.ge.25.and.lb1.le.28).and.lb2.eq.0)go to 777
        if((lb2.ge.25.and.lb2.le.28).and.lb1.eq.0)go to 777
 c
 * if kaon+pion collisions go to 889
        if((lb1.eq.23.or.lb1.eq.21).and.(lb2.ge.3.and.lb2.le.5))go to 889
        if((lb2.eq.23.or.lb2.eq.21).and.(lb1.ge.3.and.lb1.le.5))go to 889
 c
 clin-2/06/03 skip all other (K K* Kbar K*bar) channels:
 * SKIP all other K and K* RESCATTERINGS
         If(iabs(lb1).eq.30.or.iabs(lb2).eq.30) go to 400
         If(lb1.eq.21.or.lb2.eq.21) go to 400
         If(lb1.eq.23.or.lb2.eq.23) go to 400
 c
 * IF PION+baryon COLLISION GO TO 3
            IF( (LB1.ge.3.and.LB1.le.5) .and. 
      &         (iabs(LB2).eq.1.or.iabs(LB2).eq.2.or.
      &          (iabs(LB2).ge.6.and.iabs(LB2).le.13)) )GO TO 3
            IF( (LB2.ge.3.and.LB2.le.5) .and. 
      &         (iabs(LB1).eq.1.or.iabs(LB1).eq.2.or.
      &          (iabs(LB1).ge.6.and.iabs(LB1).le.13)) )GO TO 3
 c
 * IF rho(omega)+NUCLEON (baryon resonance) COLLISION GO TO 33
            IF( (LB1.ge.25.and.LB1.le.28) .and. 
      &         (iabs(LB2).eq.1.or.iabs(LB2).eq.2.or.
      &          (iabs(LB2).ge.6.and.iabs(LB2).le.13)) )GO TO 33
            IF( (LB2.ge.25.and.LB2.le.28) .and. 
      &         (iabs(LB1).eq.1.or.iabs(LB1).eq.2.or.
      &          (iabs(LB1).ge.6.and.iabs(LB1).le.13)) )GO TO 33
 c
 * IF ETA+NUCLEON (baryon resonance) COLLISIONS GO TO 547
            IF( LB1.eq.0 .and. 
      &         (iabs(LB2).eq.1.or.iabs(LB2).eq.2.or.
      &          (iabs(LB2).ge.6.and.iabs(LB2).le.13)) )GO TO 547
            IF( LB2.eq.0 .and. 
      &         (iabs(LB1).eq.1.or.iabs(LB1).eq.2.or.
      &          (iabs(LB1).ge.6.and.iabs(LB1).le.13)) )GO TO 547
 c
 * IF NUCLEON+BARYON RESONANCE COLLISION GO TO 44
             IF((LB1.eq.1.or.lb1.eq.2).
      &        AND.(LB2.GT.5.and.lb2.le.13))GOTO 44
             IF((LB2.eq.1.or.lb2.eq.2).
      &        AND.(LB1.GT.5.and.lb1.le.13))GOTO 44
             IF((LB1.eq.-1.or.lb1.eq.-2).
      &        AND.(LB2.LT.-5.and.lb2.ge.-13))GOTO 44
             IF((LB2.eq.-1.or.lb2.eq.-2).
      &        AND.(LB1.LT.-5.and.lb1.ge.-13))GOTO 44
 c
 * IF NUCLEON+NUCLEON COLLISION GO TO 4
        IF((LB1.eq.1.or.lb1.eq.2).AND.(LB2.eq.1.or.lb2.eq.2))GOTO 4
        IF((LB1.eq.-1.or.lb1.eq.-2).AND.(LB2.eq.-1.or.lb2.eq.-2))GOTO 4
 c
 * IF BARYON RESONANCE+BARYON RESONANCE COLLISION GO TO 444
             IF((LB1.GT.5.and.lb1.le.13).AND.
      &         (LB2.GT.5.and.lb2.le.13)) GOTO 444
             IF((LB1.LT.-5.and.lb1.ge.-13).AND.
      &         (LB2.LT.-5.and.lb2.ge.-13)) GOTO 444
 c
 * if L/S+L/S or L/s+nucleon go to 400
 * otherwise, develop a model for their collisions
        if((lb1.lt.3).and.(lb2.ge.14.and.lb2.le.17))goto 400
        if((lb2.lt.3).and.(lb1.ge.14.and.lb1.le.17))goto 400
        if((lb1.ge.14.and.lb1.le.17).and.
      &  (lb2.ge.14.and.lb2.le.17))goto 400
 c
 * otherwise, go out of the loop
               go to 400
 *
 *
 547           IF(LB1*LB2.EQ.0)THEN
 * (1) FOR ETA+NUCLEON SYSTEM, we allow both elastic collision, 
 *     i.e. N*(1535) formation and kaon production
 *     the total kaon production cross section is
 *     ASSUMED to be THE SAME AS PION+NUCLEON COLLISIONS
 * (2) for eta+baryon resonance we only allow kaon production
            ece=(em1+em2+0.02)**2
            xkaon0=0.
            if(srt.ge.1.63.AND.SRT.LE.1.7)xkaon0=pnlka(srt)
            IF(SRT.GT.1.7)XKAON0=PNLKA(SRT)+pnska(srt)
 cbz3/7/99 neutralk
             XKAON0 = 2.0 * XKAON0
 cbz3/7/99 neutralk end
 
 * Here we negelect eta+n inelastic collisions other than the 
 * kaon production, therefore the total inelastic cross section
 * xkaon equals to the xkaon0 (kaon production cross section)
            xkaon=xkaon0
 * note here the xkaon is in unit of fm**2
             XETA=XN1535(I1,I2,0)
         If((iabs(LB(I1)).ge.6.and.iabs(LB(I1)).le.13).or.
      &     (iabs(LB(I2)).ge.6.and.iabs(LB(I2)).le.13)) xeta=0.      
             IF((XETA+xkaon).LE.1.e-06)GO TO 400
             DSE=SQRT((XETA+XKAON)/PI)
            DELTRE=DSE+0.1
         px1cm=pcx
         py1cm=pcy
         pz1cm=pcz
 * CHECK IF N*(1535) resonance CAN BE FORMED
          CALL DISTCE(I1,I2,DELTRE,DSE,DT,ECE,SRT,IC,
      1   PCX,PCY,PCZ)
          IF(IC.EQ.-1) GO TO 400
          ekaon(4,iss)=ekaon(4,iss)+1
         IF(XKAON0/(XKAON+XETA).GT.RANART(NSEED))then
 * kaon production, USE CREN TO CALCULATE THE MOMENTUM OF L/S K+
         CALL CREN(PX1CM,PY1CM,PZ1CM,SRT,I1,I2,IBLOCK)
 * kaon production
        IF(IBLOCK.EQ.7) then
           LPN=LPN+1
        elseIF(IBLOCK.EQ.-7) then
        endif
 c
        em1=e(i1)
        em2=e(i2)
        GO TO 440
        endif
 * N*(1535) FORMATION
         resona=1.
          GO TO 98
          ENDIF
 *IF PION+NUCLEON (baryon resonance) COLLISION THEN
 3           CONTINUE
            px1cm=pcx
            py1cm=pcy
            pz1cm=pcz
 * the total kaon production cross section for pion+baryon (resonance) is
 * assumed to be the same as in pion+nucleon
            xkaon0=0.
            if(srt.ge.1.63.AND.SRT.LE.1.7)xkaon0=pnlka(srt)
            IF(SRT.GT.1.7)XKAON0=PNLKA(SRT)+pnska(srt)
             XKAON0 = 2.0 * XKAON0
 c
 c sp11/21/01  phi production: pi +N(D) -> phi + N(D)
          Xphi = 0.
        if( ( ((lb1.ge.1.and.lb1.le.2).or.
      &        (lb1.ge.6.and.lb1.le.9))
      &   .OR.((lb2.ge.1.and.lb2.le.2).or.
      &        (lb2.ge.6.and.lb2.le.9)) )
      &       .AND. srt.gt.1.958)
      &        call pibphi(srt,lb1,lb2,em1,em2,Xphi,xphin)
 c !! in fm^2 above
 
 * if a pion collide with a baryon resonance, 
 * we only allow kaon production AND the reabsorption 
 * processes: Delta+pion-->N+pion, N*+pion-->N+pion
 * Later put in pion+baryon resonance elastic
 * cross through forming higher resonances implicitly.
 c          If(em1.gt.1.or.em2.gt.1.)go to 31
          If((iabs(LB(I1)).ge.6.and.iabs(LB(I1)).le.13).or.
      &      (iabs(LB(I2)).ge.6.and.iabs(LB(I2)).le.13)) go to 31
 * For pion+nucleon collisions: 
 * using the experimental pion+nucleon inelastic cross section, we assume it
 * is exhausted by the Delta+pion, Delta+rho and Delta+omega production 
 * and kaon production. In the following we first check whether 
 * inelastic pion+n collision can happen or not, then determine in 
 * crpn whether it is through pion production or through kaon production
 * note that the xkaon0 is the kaon production cross section
 * Note in particular that: 
 * xkaon in the following is the total pion+nucleon inelastic cross section
 * note here the xkaon is in unit of fm**2, xnpi is also in unit of fm**2
 * FOR PION+NUCLEON SYSTEM, THE MINIMUM S IS 1.2056 the minimum srt for 
 * elastic scattering, and it is 1.60 for pion production, 1.63 for LAMBDA+kaon 
 * production and 1.7 FOR SIGMA+KAON
 * (EC = PION MASS+NUCLEON MASS+20MEV)**2
             EC=(em1+em2+0.02)**2
            xkaon=0.
            if(srt.gt.1.23)xkaon=(pionpp(srt)+PIPP1(SRT))/2.
 * pion+nucleon elastic cross section is divided into two parts:
 * (1) forming D(1232)+N*(1440) +N*(1535)
 * (2) cross sections forming higher resonances are calculated as
 *     the difference between the total elastic and (1), this part is 
 *     treated as direct process since we do not explicitLY include
 *     higher resonances.
 * the following is the resonance formation cross sections.
 *1. PION(+)+PROTON-->DELTA++,PION(-)+NEUTRON-->DELTA(-)
            IF( (LB1*LB2.EQ.5.OR.((LB1*LB2.EQ.6).AND.
      &         (LB1.EQ.3.OR.LB2.EQ.3)))
      &    .OR. (LB1*LB2.EQ.-3.OR.((LB1*LB2.EQ.-10).AND.
      &         (LB1.EQ.5.OR.LB2.EQ.5))) )then    
               XMAX=190.
               xmaxn=0
               xmaxn1=0
               xdirct=dirct1(srt)
                go to 678
            endif
 *2. PION(-)+PROTON-->DELTA0,PION(+)+NEUTRON-->DELTA+ 
 *   or N*(+)(1440) or N*(+)(1535)
 * note the factor 2/3 is from the isospin consideration and
 * the factor 0.6 or 0.5 is the branching ratio for the resonance to decay
 * into pion+nucleon
             IF( (LB1*LB2.EQ.3.OR.((LB1*LB2.EQ.10).AND.
      &          (LB1.EQ.5.OR.LB2.EQ.5)))
      &     .OR. (LB1*LB2.EQ.-5.OR.((LB1*LB2.EQ.-6).AND.
      &          (LB1.EQ.3.OR.LB2.EQ.3))) )then      
               XMAX=27.
               xmaxn=2./3.*25.*0.6
                xmaxn1=2./3.*40.*0.5
               xdirct=dirct2(srt)
                go to 678
               endif
 *3. PION0+PROTON-->DELTA+,PION0+NEUTRON-->DELTA0, or N*(0)(1440) or N*(0)(1535)
             IF((LB1.EQ.4.OR.LB2.EQ.4).AND.
      &         (iabs(LB1*LB2).EQ.4.OR.iabs(LB1*LB2).EQ.8))then
               XMAX=50.
               xmaxn=1./3.*25*0.6
               xmaxn1=1/3.*40.*0.5
               xdirct=dirct3(srt)
                 go to 678
               endif
 678           xnpin1=0
            xnpin=0
             XNPID=XNPI(I1,I2,1,XMAX)
            if(xmaxn1.ne.0)xnpin1=XNPI(i1,i2,2,XMAXN1)
             if(xmaxn.ne.0)XNPIN=XNPI(I1,I2,0,XMAXN)
 * the following 
            xres=xnpid+xnpin+xnpin1
            xnelas=xres+xdirct 
            icheck=1
            go to 34
 * For pion + baryon resonance the reabsorption 
 * cross section is calculated from the detailed balance
 * using reab(i1,i2,srt,ictrl), ictrl=1, 2 and 3
 * for pion, rho and omega + baryon resonance
 31           ec=(em1+em2+0.02)**2
            xreab=reab(i1,i2,srt,1)
 
 clin-12/02/00 to satisfy detailed balance, forbid N* absorptions:
           if((iabs(lb1).ge.10.and.iabs(lb1).le.13)
      1         .or.(iabs(lb2).ge.10.and.iabs(lb2).le.13)) XREAB = 0.
 
            xkaon=xkaon0+xreab
 * a constant of 10 mb IS USED FOR PION + N* RESONANCE, 
         IF((iabs(LB1).GT.9.AND.iabs(LB1).LE.13) .OR.
      &      (iabs(LB2).GT.9.AND.iabs(LB2).LE.13))THEN
            Xnelas=1.0
         ELSE
            XNELAS=DPION(EM1,EM2,LB1,LB2,SRT)
         ENDIF
            icheck=2
 34          IF((Xnelas+xkaon+Xphi).LE.0.000001)GO TO 400
             DS=SQRT((Xnelas+xkaon+Xphi)/PI)
 csp09/20/01
 c           totcr = xnelas+xkaon
 c           if(srt .gt. 3.5)totcr = max1(totcr,3.)
 c           DS=SQRT(totcr/PI)
 csp09/20/01 end
             
            deltar=ds+0.1
          CALL DISTCE(I1,I2,DELTAR,DS,DT,EC,SRT,IC,
      1   PCX,PCY,PCZ)
          IF(IC.EQ.-1) GO TO 400
        ekaon(4,iss)=ekaon(4,iss)+1
 c***
 * check what kind of collision has happened
 * (1) pion+baryon resonance
 * if direct elastic process
         if(icheck.eq.2)then
 c  !!sp11/21/01
       if(xnelas/(xnelas+xkaon+Xphi).ge.RANART(NSEED))then
 c               call Crdir(PX1CM,PY1CM,PZ1CM,SRT,I1,I2)
                call Crdir(PX1CM,PY1CM,PZ1CM,SRT,I1,I2,IBLOCK)
               go to 440
               else
 * for inelastic process, go to 96 to check
 * kaon production and pion reabsorption : pion+D(N*)-->pion+N
                go to 96
                 endif
               endif
 *(2) pion+n
 * CHECK IF inELASTIC COLLISION IS POSSIBLE FOR PION+N COLLISIONS
 clin-8/17/00 typo corrected, many other occurences:
 c        IF(XKAON/(XKAON+Xnelas).GT.RANART(NSEED))GO TO 95
        IF((XKAON+Xphi)/(XKAON+Xphi+Xnelas).GT.RANART(NSEED))GO TO 95
 
 * direct process
         if(xdirct/xnelas.ge.RANART(NSEED))then
 c               call Crdir(PX1CM,PY1CM,PZ1CM,SRT,I1,I2)
                call Crdir(PX1CM,PY1CM,PZ1CM,SRT,I1,I2,IBLOCK)
               go to 440
               endif
 * now resonance formation or direct process (higher resonances)
            IF( (LB1*LB2.EQ.5.OR.((LB1*LB2.EQ.6).AND.
      &         (LB1.EQ.3.OR.LB2.EQ.3)))
      &    .OR. (LB1*LB2.EQ.-3.OR.((LB1*LB2.EQ.-10).AND.
      &         (LB1.EQ.5.OR.LB2.EQ.5))) )then    
 c
 * ONLY DELTA RESONANCE IS POSSIBLE, go to 99
         GO TO 99
        else
 * NOW BOTH DELTA AND N* RESORANCE ARE POSSIBLE
 * DETERMINE THE RESORANT STATE BY USING THE MONTRE CARLO METHOD
             XX=(XNPIN+xnpin1)/xres
             IF(RANART(NSEED).LT.XX)THEN
 * N* RESONANCE IS SELECTED
 * decide N*(1440) or N*(1535) formation
         xx0=xnpin/(xnpin+xnpin1)
         if(RANART(NSEED).lt.xx0)then
          RESONA=0.
 * N*(1440) formation
          GO TO 97
         else
 * N*(1535) formation
         resona=1.
          GO TO 98
         endif
          ELSE
 * DELTA RESONANCE IS SELECTED
          GO TO 99
          ENDIF
          ENDIF
 97       CONTINUE
             IF(RESONA.EQ.0.)THEN
 *N*(1440) IS PRODUCED,WE DETERMINE THE CHARGE STATE OF THE PRODUCED N*
             I=I1
             IF(EM1.LT.0.6)I=I2
 * (0.1) n+pion(+)-->N*(+)
            IF( (LB1*LB2.EQ.10.AND.(LB1.EQ.5.OR.LB2.EQ.5))
      &      .OR.(LB1*LB2.EQ.-6.AND.(LB1.EQ.3.OR.LB2.EQ.3)) )THEN
             LB(I)=11
            go to 303
             ENDIF
 * (0.2) p+pion(0)-->N*(+)
 c            IF(LB(I1)*LB(I2).EQ.4.AND.(LB(I1).EQ.1.OR.LB(I2).EQ.1))THEN
             IF(iabs(LB(I1)*LB(I2)).EQ.4.AND.
      &         (LB(I1).EQ.4.OR.LB(I2).EQ.4))THEN    
             LB(I)=11
            go to 303
             ENDIF
 * (0.3) n+pion(0)-->N*(0)
 c            IF(LB(I1)*LB(I2).EQ.8.AND.(LB(I1).EQ.2.OR.LB(I2).EQ.2))THEN
             IF(iabs(LB(I1)*LB(I2)).EQ.8.AND.
      &        (LB(I1).EQ.4.OR.LB(I2).EQ.4))THEN    
             LB(I)=10
            go to 303
             ENDIF
 * (0.4) p+pion(-)-->N*(0)
 c            IF(LB(I1)*LB(I2).EQ.3)THEN
             IF( (LB(I1)*LB(I2).EQ.3)
      &      .OR.(LB(I1)*LB(I2).EQ.-5) )THEN
             LB(I)=10
             ENDIF
 303         CALL DRESON(I1,I2)
             if(LB1.lt.0.or.LB2.lt.0) LB(I)=-LB(I)
             lres=lres+1
             GO TO 101
 *COM: GO TO 101 TO CHANGE THE PHASE SPACE DENSITY OF THE NUCLEON
             ENDIF
 98          IF(RESONA.EQ.1.)THEN
 *N*(1535) IS PRODUCED, WE DETERMINE THE CHARGE STATE OF THE PRODUCED N*
             I=I1
             IF(EM1.LT.0.6)I=I2
 * note: this condition applies to both eta and pion
 * (0.1) n+pion(+)-->N*(+)
 c            IF(LB1*LB2.EQ.10.AND.(LB1.EQ.2.OR.LB2.EQ.2))THEN
             IF( (LB1*LB2.EQ.10.AND.(LB1.EQ.5.OR.LB2.EQ.5))
      &      .OR.(LB1*LB2.EQ.-6.AND.(LB1.EQ.3.OR.LB2.EQ.3)) )THEN
             LB(I)=13
            go to 304
             ENDIF
 * (0.2) p+pion(0)-->N*(+)
 c            IF(LB(I1)*LB(I2).EQ.4.AND.(LB(I1).EQ.1.OR.LB(I2).EQ.1))THEN
             IF(iabs(LB(I1)*LB(I2)).EQ.4.AND.
      &           (LB(I1).EQ.4.OR.LB(I2).EQ.4))THEN 
             LB(I)=13
            go to 304
             ENDIF
 * (0.3) n+pion(0)-->N*(0)
 c            IF(LB(I1)*LB(I2).EQ.8.AND.(LB(I1).EQ.2.OR.LB(I2).EQ.2))THEN
             IF(iabs(LB(I1)*LB(I2)).EQ.8.AND.
      &           (LB(I1).EQ.4.OR.LB(I2).EQ.4))THEN      
             LB(I)=12
            go to 304
             ENDIF
 * (0.4) p+pion(-)-->N*(0)
 c            IF(LB(I1)*LB(I2).EQ.3)THEN
             IF( (LB(I1)*LB(I2).EQ.3)
      &      .OR.(LB(I1)*LB(I2).EQ.-5) )THEN
             LB(I)=12
            go to 304
            endif
 * (0.5) p+eta-->N*(+)(1535),n+eta-->N*(0)(1535)
            if(lb(i1)*lb(i2).eq.0)then
 c            if((lb(i1).eq.1).or.(lb(i2).eq.1))then
             if(iabs(lb(i1)).eq.1.or.iabs(lb(i2)).eq.1)then
            LB(I)=13
            go to 304
            ELSE
            LB(I)=12
            ENDIF
            endif
 304         CALL DRESON(I1,I2)
             if(LB1.lt.0.or.LB2.lt.0) LB(I)=-LB(I) 
             lres=lres+1
             GO TO 101
 *COM: GO TO 101 TO CHANGE THE PHASE SPACE DENSITY OF THE NUCLEON
             ENDIF
 *DELTA IS PRODUCED,IN THE FOLLOWING WE DETERMINE THE
 *CHARGE STATE OF THE PRODUCED DELTA
 99      LRES=LRES+1
         I=I1
         IF(EM1.LE.0.6)I=I2
 * (1) p+pion(+)-->DELTA(++)
 c        IF(LB(I1)*LB(I2).EQ.5)THEN
             IF( (LB(I1)*LB(I2).EQ.5)
      &      .OR.(LB(I1)*LB(I2).EQ.-3) )THEN
         LB(I)=9
        go to 305
         ENDIF
 * (2) p+pion(0)-->delta(+)
 c        IF(LB(I1)*LB(I2).EQ.4.AND.(LB(I1).EQ.1.OR.LB(I2).EQ.1))then
        IF(iabs(LB(I1)*LB(I2)).EQ.4.AND.(LB(I1).EQ.4.OR.LB(I2).EQ.4))then
         LB(I)=8
        go to 305
         ENDIF
 * (3) n+pion(+)-->delta(+)
 c        IF(LB(I1)*LB(I2).EQ.10.AND.(LB(I1).EQ.2.OR.LB(I2).EQ.2))THEN
        IF( (LB(I1)*LB(I2).EQ.10.AND.(LB(I1).EQ.5.OR.LB(I2).EQ.5))
      & .OR.(LB(I1)*LB(I2).EQ.-6.AND.(LB(I1).EQ.3.OR.LB(I2).EQ.3)) )THEN
         LB(I)=8
        go to 305
         ENDIF
 * (4) n+pion(0)-->delta(0)
 c        IF(LB(I1)*LB(I2).EQ.8.AND.(LB(I1).EQ.2.OR.LB(I2).EQ.2))THEN
        IF(iabs(LB(I1)*LB(I2)).EQ.8.AND.(LB(I1).EQ.4.OR.LB(I2).EQ.4))THEN
         LB(I)=7
        go to 305
         ENDIF
 * (5) p+pion(-)-->delta(0)
 c        IF(LB(I1)*LB(I2).EQ.3)THEN
             IF( (LB(I1)*LB(I2).EQ.3)
      &      .OR.(LB(I1)*LB(I2).EQ.-5) )THEN
         LB(I)=7
        go to 305
         ENDIF
 * (6) n+pion(-)-->delta(-)
 c        IF(LB(I1)*LB(I2).EQ.6.AND.(LB(I1).EQ.2.OR.LB(I2).EQ.2))THEN
        IF( (LB(I1)*LB(I2).EQ.6.AND.(LB(I1).EQ.3.OR.LB(I2).EQ.3))
      & .OR.(LB(I1)*LB(I2).EQ.-10.AND.(LB(I1).EQ.5.OR.LB(I2).EQ.5)) )THEN 
         LB(I)=6
         ENDIF
 305     CALL DRESON(I1,I2)
         if(LB1.lt.0.or.LB2.lt.0) LB(I)=-LB(I) 
        GO TO 101
 
 csp-11/08/01 K*
 * FOR kaON+pion COLLISIONS, form K* (bar) or
 c La/Si-bar + N <-- pi + K+
 c La/Si + N-bar <-- pi + K-                                             
 c phi + K <-- pi + K                                             
 clin (rho,omega) + K* <-- pi + K
 889       CONTINUE
         PX1CM=PCX
         PY1CM=PCY
         PZ1CM=PCZ
         EC=(em1+em2+0.02)**2
 * the cross section is from C.M. Ko, PRC 23, 2760 (1981).
        spika=60./(1.+4.*(srt-0.895)**2/(0.05)**2)
 c
 cc       if(lb(i1).eq.23.or.lb(i2).eq.23)then   !! block  K- + pi->La + B-bar
 
         call Crkpla(PX1CM,PY1CM,PZ1CM,EC,SRT,spika,
      &                  emm1,emm2,lbp1,lbp2,I1,I2,icase,srhoks)
 cc
 c* only K* or K*bar formation
 c       else 
 c      DSkn=SQRT(spika/PI/10.)
 c      dsknr=dskn+0.1
 c      CALL DISTCE(I1,I2,dsknr,DSkn,DT,EC,SRT,IC,
 c    1     PX1CM,PY1CM,PZ1CM)
 c        IF(IC.EQ.-1) GO TO 400
 c       icase = 1
 c      endif
 c
          if(icase .eq. 0) then
             iblock=0
             go to 400
          endif
 
        if(icase .eq. 1)then
              call KSRESO(I1,I2)
 clin-4/30/03 give non-zero iblock for resonance selections:
              iblock = 171
 ctest off for resonance (phi, K*) studies:
 c             if(iabs(lb(i1)).eq.30) then
 c             write(17,112) 'ks',lb(i1),p(1,i1),p(2,i1),p(3,i1),e(i1),nt
 c             elseif(iabs(lb(i2)).eq.30) then
 c             write(17,112) 'ks',lb(i2),p(1,i2),p(2,i2),p(3,i2),e(i2),nt
 c             endif
 c
               lres=lres+1
               go to 101
        elseif(icase .eq. 2)then
              iblock = 71
 c
 * La/Si (bar) formation                                                   
 
        elseif(iabs(icase).eq.5)then
              iblock = 88
 
        else
 *
 * phi formation
              iblock = 222
        endif
              LB(I1) = lbp1
              LB(I2) = lbp2
              E(I1) = emm1
              E(I2) = emm2
              em1=e(i1)
              em2=e(i2)
              ntag = 0
              go to 440
 c             
 33       continue
        em1=e(i1)
        em2=e(i2)
 * (1) if rho or omega collide with a nucleon we allow both elastic 
 *     scattering and kaon production to happen if collision conditions 
 *     are satisfied.
 * (2) if rho or omega collide with a baryon resonance we allow
 *     kaon production, pion reabsorption: rho(omega)+D(N*)-->pion+N
 *     and NO elastic scattering to happen
            xelstc=0
             if((lb1.ge.25.and.lb1.le.28).and.
      &    (iabs(lb2).eq.1.or.iabs(lb2).eq.2))
      &      xelstc=ERHON(EM1,EM2,LB1,LB2,SRT)
             if((lb2.ge.25.and.lb2.le.28).and.
      &   (iabs(lb1).eq.1.or.iabs(lb1).eq.2))
      &      xelstc=ERHON(EM1,EM2,LB1,LB2,SRT)
             ec=(em1+em2+0.02)**2
 * the kaon production cross section is
            xkaon0=0
            if(srt.ge.1.63.AND.SRT.LE.1.7)xkaon0=pnlka(srt)
            IF(SRT.GT.1.7)XKAON0=PNLKA(SRT)+pnska(srt)
            if(xkaon0.lt.0)xkaon0=0
 
 cbz3/7/99 neutralk
             XKAON0 = 2.0 * XKAON0
 cbz3/7/99 neutralk end
 
 * the total inelastic cross section for rho(omega)+N is
            xkaon=xkaon0
            ichann=0
 * the total inelastic cross section for rho (omega)+D(N*) is 
 * xkaon=xkaon0+reab(**) 
 
 c sp11/21/01  phi production: rho + N(D) -> phi + N(D)
          Xphi = 0.
        if( ( (((lb1.ge.1.and.lb1.le.2).or.
      &         (lb1.ge.6.and.lb1.le.9))
      &         .and.(lb2.ge.25.and.lb2.le.27))
      &   .OR.(((lb2.ge.1.and.lb2.le.2).or.
      &         (lb2.ge.6.and.lb2.le.9))
      &        .and.(lb1.ge.25.and.lb1.le.27)) ).AND. srt.gt.1.958)
      &    call pibphi(srt,lb1,lb2,em1,em2,Xphi,xphin)
 c !! in fm^2 above
 c
         if((iabs(lb1).ge.6.and.lb2.ge.25).or.
      &    (lb1.ge.25.and.iabs(lb2).ge.6))then
            ichann=1
            ictrl=2
            if(lb1.eq.28.or.lb2.eq.28)ictrl=3
             xreab=reab(i1,i2,srt,ictrl)
 
 clin-12/02/00 to satisfy detailed balance, forbid N* absorptions:
             if((iabs(lb1).ge.10.and.iabs(lb1).le.13)
      1           .or.(iabs(lb2).ge.10.and.iabs(lb2).le.13)) XREAB = 0.
 
         if(xreab.lt.0)xreab=1.E-06
             xkaon=xkaon0+xreab
           XELSTC=1.0
            endif
             DS=SQRT((XKAON+Xphi+xelstc)/PI)
 c
 csp09/20/01
 c           totcr = xelstc+xkaon
 c           if(srt .gt. 3.5)totcr = max1(totcr,3.)
 c           DS=SQRT(totcr/PI)
 csp09/20/01 end
 c
         DELTAR=DS+0.1
        px1cm=pcx
        py1cm=pcy
        pz1cm=pcz
 * CHECK IF the collision can happen
          CALL DISTCE(I1,I2,DELTAR,DS,DT,EC,SRT,IC,
      1   PCX,PCY,PCZ)
          IF(IC.EQ.-1) GO TO 400
         ekaon(4,iss)=ekaon(4,iss)+1
 c*
 * NOW rho(omega)+N or D(N*) COLLISION IS POSSIBLE
 * (1) check elastic collision
        if(xelstc/(xelstc+xkaon+Xphi).gt.RANART(NSEED))then
 c       call crdir(px1CM,py1CM,pz1CM,srt,I1,i2)
        call crdir(px1CM,py1CM,pz1CM,srt,I1,i2,IBLOCK)
        go to 440
        endif
 * (2) check pion absorption or kaon production
         CALL CRRD(PX1CM,PY1CM,PZ1CM,SRT,I1,I2,
      1  IBLOCK,xkaon0,xkaon,Xphi,xphin)
 
 * kaon production
 csp05/16/01
        IF(IBLOCK.EQ.7) then
           LPN=LPN+1
        elseIF(IBLOCK.EQ.-7) then
        endif
 csp05/16/01 end
 * rho obsorption
        if(iblock.eq.81) lrhor=lrhor+1
 * omega obsorption
        if(iblock.eq.82) lomgar=lomgar+1
        em1=e(i1)
        em2=e(i2)
        GO TO 440
 * for pion+n now using the subroutine crpn to change 
 * the particle label and set the new momentum of L/S+K final state
 95       continue
 * NOW PION+N INELASTIC COLLISION IS POSSIBLE
 * check pion production or kaon production
         CALL CRPN(PX1CM,PY1CM,PZ1CM,SRT,I1,I2,
      1  IBLOCK,xkaon0,xkaon,Xphi,xphin)
 
 * kaon production
 csp05/16/01
        IF(IBLOCK.EQ.7) then
           LPN=LPN+1
        elseIF(IBLOCK.EQ.-7) then
        endif
 csp05/16/01 end
 * pion production
        if(iblock.eq.77) lpd=lpd+1
 * rho production
        if(iblock.eq.78) lrho=lrho+1
 * omega production
        if(iblock.eq.79) lomega=lomega+1
        em1=e(i1)
        em2=e(i2)
        GO TO 440
 * for pion+D(N*) now using the subroutine crpd to 
 * (1) check kaon production or pion reabsorption 
 * (2) change the particle label and set the new 
 *     momentum of L/S+K final state
 96       continue
         CALL CRPD(PX1CM,PY1CM,PZ1CM,SRT,I1,I2,
      1  IBLOCK,xkaon0,xkaon,Xphi,xphin)
 
 * kaon production
 csp05/16/01
        IF(IBLOCK.EQ.7) then
           LPN=LPN+1
        elseIF(IBLOCK.EQ.-7) then
        endif
 csp05/16/01 end
 * pion obserption
        if(iblock.eq.80) lpdr=lpdr+1
        em1=e(i1)
        em2=e(i2)
        GO TO 440
 * CALCULATE KAON PRODUCTION PROBABILITY FROM PION + N COLLISIONS
 C        IF(SRT.GT.1.615)THEN
 C        CALL PKAON(SRT,XXp,PK)
 C        TKAON(7)=TKAON(7)+PK 
 C        EKAON(7,ISS)=EKAON(7,ISS)+1
 c        CALL KSPEC1(SRT,PK)
 C        call LK(3,srt,iseed,pk)
 C        ENDIF
 * negelecting the pauli blocking at high energies
 
 101       continue
         IF(E(I2).EQ.0.)GO TO 600
         IF(E(I1).EQ.0.)GO TO 800
 * IF NUCLEON+BARYON RESONANCE COLLISIONS
 44      CONTINUE
 * CALCULATE THE TOTAL CROSS SECTION OF NUCLEON+ BARYON RESONANCE COLLISION
 * WE ASSUME THAT THE ELASTIC CROSS SECTION IS THE SAME AS NUCLEON+NUCLEON
 * COM: WE USE THE PARAMETERISATION BY CUGNON FOR LOW ENERGIES
 *      AND THE PARAMETERIZATIONS FROM CERN DATA BOOK FOR HIGHER 
 *      ENERGIES. THE CUTOFF FOR THE TOTAL CROSS SECTION IS 55 MB 
        cutoff=em1+em2+0.02
        IF(SRT.LE.CUTOFF)GO TO 400
         IF(SRT.GT.2.245)THEN
        SIGNN=PP2(SRT)
        ELSE
         SIGNN = 35.0 / (1. + (SRT - CUTOFF) * 100.0)  +  20.0
        ENDIF 
         call XND(pcx,pcy,pcz,srt,I1,I2,xinel,
      &               sigk,xsk1,xsk2,xsk3,xsk4,xsk5)
        sig=signn+xinel
 * For nucleon+baryon resonance collision, the minimum cms**2 energy is
         EC=(EM1+EM2+0.02)**2
 * CHECK THE DISTENCE BETWEEN THE TWO PARTICLES
         PX1CM=PCX
         PY1CM=PCY
         PZ1CM=PCZ
 
 clin-6/2008 Deuteron production:
         ianti=0
         if(lb(i1).lt.0 .and. lb(i2).lt.0) ianti=1
         call sbbdm(srt,sdprod,ianti,lbm,xmm,pfinal)
         sig=sig+sdprod
 clin-6/2008 perturbative treatment of deuterons:
         ipdflag=0
         if(idpert.eq.1) then
            ipert1=1
            sigr0=sig
            dspert=sqrt(sigr0/pi/10.)
            dsrpert=dspert+0.1
            CALL DISTCE(I1,I2,dsrpert,dspert,DT,EC,SRT,IC,
      1          PX1CM,PY1CM,PZ1CM)
            IF(IC.EQ.-1) GO TO 363
            signn0=0.
            CALL CRND(IRUN,PX1CM,PY1CM,PZ1CM,SRT,I1,I2,
      &  IBLOCK,SIGNN0,SIGr0,sigk,xsk1,xsk2,xsk3,xsk4,xsk5,NT,ipert1)
 c     &  IBLOCK,SIGNN,SIG,sigk,xsk1,xsk2,xsk3,xsk4,xsk5)
            ipdflag=1
  363       continue
            ipert1=0
         endif
         if(idpert.eq.2) ipert1=1
 c
         DS=SQRT(SIG/(10.*PI))
         DELTAR=DS+0.1
         CALL DISTCE(I1,I2,DELTAR,DS,DT,EC,SRT,IC,
      1  PX1CM,PY1CM,PZ1CM)
 c        IF(IC.EQ.-1)GO TO 400
         IF(IC.EQ.-1) then
            if(ipdflag.eq.1) iblock=501
            GO TO 400
         endif
 
         ekaon(3,iss)=ekaon(3,iss)+1
 * CALCULATE KAON PRODUCTION PROBABILITY FROM NUCLEON + BARYON RESONANCE 
 * COLLISIONS
         go to 361
 
 * CHECK WHAT KIND OF COLLISION HAS HAPPENED
  361    continue 
         CALL CRND(IRUN,PX1CM,PY1CM,PZ1CM,SRT,I1,I2,
      &     IBLOCK,SIGNN,SIG,sigk,xsk1,xsk2,xsk3,xsk4,xsk5,NT,ipert1)
 c     &  IBLOCK,SIGNN,SIG,sigk,xsk1,xsk2,xsk3,xsk4,xsk5)
         IF(iblock.eq.0.and.ipdflag.eq.1) iblock=501
         IF(IBLOCK.EQ.11)THEN
            LNDK=LNDK+1
            GO TO 400
 c        elseIF(IBLOCK.EQ.-11) then
         elseIF(IBLOCK.EQ.-11.or.iblock.eq.501) then
            GO TO 400
         ENDIF
         if(iblock .eq. 222)then
 c    !! sp12/17/01 
            GO TO 400
         ENDIF
         em1=e(i1)
         em2=e(i2)
         GO TO 440
 * IF NUCLEON+NUCLEON OR BARYON RESONANCE+BARYON RESONANCE COLLISIONS
 4       CONTINUE
 * PREPARE THE EALSTIC CROSS SECTION FOR BARYON+BARYON COLLISIONS
 * COM: WE USE THE PARAMETERISATION BY CUGNON FOR SRT LEQ 2.0 GEV
 *      AND THE PARAMETERIZATIONS FROM CERN DATA BOOK FOR HIGHER 
 *      ENERGIES. THE CUTOFF FOR THE TOTAL CROSS SECTION IS 55 MB 
 *      WITH LOW-ENERGY-CUTOFF
         CUTOFF=em1+em2+0.14
 * AT HIGH ENERGIES THE ISOSPIN DEPENDENCE IS NEGLIGIBLE
 * THE TOTAL CROSS SECTION IS TAKEN AS THAT OF THE PP 
 * ABOVE E_KIN=800 MEV, WE USE THE ISOSPIN INDEPENDNET XSECTION
         IF(SRT.GT.2.245)THEN
            SIG=ppt(srt)
            SIGNN=SIG-PP1(SRT)
         ELSE
 * AT LOW ENERGIES THE ISOSPIN DEPENDENCE FOR NN COLLISION IS STRONG
            SIG=XPP(SRT)
            IF(ZET(LB(I1))*ZET(LB(I2)).LE.0)SIG=XNP(SRT)
            IF(ZET(LB(I1))*ZET(LB(I2)).GT.0)SIG=XPP(SRT)
            IF(ZET(LB(I1)).EQ.0.
      &          AND.ZET(LB(I2)).EQ.0)SIG=XPP(SRT)
            if((lb(i1).eq.-1.and.lb(i2).eq.-2) .or.
      &          (lb(i2).eq.-1.and.lb(i1).eq.-2))sig=xnp(srt)
 *     WITH LOW-ENERGY-CUTOFF
            IF (SRT .LT. 1.897) THEN
               SIGNN = SIG
            ELSE 
               SIGNN = 35.0 / (1. + (SRT - 1.897) * 100.0)  +  20.0
            ENDIF
         ENDIF 
         PX1CM=PCX
         PY1CM=PCY
         PZ1CM=PCZ
 clin-5/2008 Deuteron production cross sections were not included 
 c     in the previous parameterized inelastic cross section of NN collisions  
 c     (SIGinel=SIG-SIGNN), so they are added here:
         ianti=0
         if(lb(i1).lt.0 .and. lb(i2).lt.0) ianti=1
         call sbbdm(srt,sdprod,ianti,lbm,xmm,pfinal)
         sig=sig+sdprod
 c
 clin-5/2008 perturbative treatment of deuterons:
         ipdflag=0
         if(idpert.eq.1) then
 c     For idpert=1: ipert1=1 means we will first treat deuteron perturbatively,
 c     then we set ipert1=0 to treat regular NN or NbarNbar collisions including
 c     the regular deuteron productions.
 c     ipdflag=1 means perturbative deuterons are produced here:
            ipert1=1
            EC=2.012**2
 c     Use the same cross section for NN/NNBAR collisions 
 c     to trigger perturbative production
            sigr0=sig
 c     One can also trigger with X*sbbdm() so the weight will not be too small;
 c     but make sure to limit the maximum trigger Xsec:
 c           sigr0=sdprod*25.
 c           if(sigr0.ge.100.) sigr0=100.
            dspert=sqrt(sigr0/pi/10.)
            dsrpert=dspert+0.1
            CALL DISTCE(I1,I2,dsrpert,dspert,DT,EC,SRT,IC,
      1          PX1CM,PY1CM,PZ1CM)
            IF(IC.EQ.-1) GO TO 365
            signn0=0.
            CALL CRNN(IRUN,PX1CM,PY1CM,PZ1CM,SRT,I1,I2,IBLOCK,
      1          NTAG,signn0,sigr0,NT,ipert1)
            ipdflag=1
  365       continue
            ipert1=0
         endif
         if(idpert.eq.2) ipert1=1
 c
 clin-5/2008 in case perturbative deuterons are produced for idpert=1:
 c        IF(SIGNN.LE.0)GO TO 400
         IF(SIGNN.LE.0) then
            if(ipdflag.eq.1) iblock=501
            GO TO 400
         endif
 c
         EC=3.59709
         ds=sqrt(sig/pi/10.)
         dsr=ds+0.1
         IF((E(I1).GE.1.).AND.(e(I2).GE.1.))EC=4.75
         CALL DISTCE(I1,I2,dsr,ds,DT,EC,SRT,IC,
      1       PX1CM,PY1CM,PZ1CM)
 clin-5/2008 in case perturbative deuterons are produced above:
 c        IF(IC.EQ.-1) GO TO 400
         IF(IC.EQ.-1) then
            if(ipdflag.eq.1) iblock=501
            GO TO 400
         endif
 c
 * CALCULATE KAON PRODUCTION PROBABILITY FROM NUCLEON+NUCLEON OR 
 * RESONANCE+RESONANCE COLLISIONS
         go to 362
 
 C CHECK WHAT KIND OF COLLISION HAS HAPPENED 
  362    ekaon(1,iss)=ekaon(1,iss)+1
         CALL CRNN(IRUN,PX1CM,PY1CM,PZ1CM,SRT,I1,I2,IBLOCK,
      1       NTAG,SIGNN,SIG,NT,ipert1)
 clin-5/2008 give iblock # in case pert deuterons are produced for idpert=1:
         IF(iblock.eq.0.and.ipdflag.eq.1) iblock=501
 clin-5/2008 add iblock # for deuteron formation:
 c        IF(IBLOCK.EQ.4.OR.IBLOCK.Eq.9.or.iblock.ge.44.OR.IBLOCK.EQ.-9
 c     &       .or.iblock.eq.222)THEN
         IF(IBLOCK.EQ.4.OR.IBLOCK.Eq.9.or.iblock.ge.44.OR.IBLOCK.EQ.-9
      &       .or.iblock.eq.222.or.iblock.eq.501)THEN
 c
 c     !! sp12/17/01 above
 * momentum of the three particles in the final state have been calculated
 * in the crnn, go out of the loop
            LCOLL=LCOLL+1
            if(iblock.eq.4)then
               LDIRT=LDIRT+1
            elseif(iblock.eq.44)then
               LDdrho=LDdrho+1
            elseif(iblock.eq.45)then
               Lnnrho=Lnnrho+1
            elseif(iblock.eq.46)then
               Lnnom=Lnnom+1
            elseif(iblock .eq. 222)then
            elseIF(IBLOCK.EQ.9) then
               LNNK=LNNK+1
            elseIF(IBLOCK.EQ.-9) then
            endif
            GO TO 400
         ENDIF
 
         em1=e(i1)
         em2=e(i2)
         GO TO 440
 clin-8/2008 B+B->Deuteron+Meson over
 c
 clin-8/2008 Deuteron+Meson->B+B collisions:
  505    continue
         ianti=0
         if(lb(i1).lt.0 .or. lb(i2).lt.0) ianti=1
         call sdmbb(SRT,sdm,ianti)
         PX1CM=PCX
         PY1CM=PCY
         PZ1CM=PCZ
 c     minimum srt**2, note a 2.012GeV lower cutoff is used in N+N->Deuteron+pi:
         EC=2.012**2
         ds=sqrt(sdm/31.4)
         dsr=ds+0.1
         CALL DISTCE(I1,I2,dsr,ds,DT,EC,SRT,IC,PX1CM,PY1CM,PZ1CM)
         IF(IC.EQ.-1) GO TO 400
         CALL crdmbb(PX1CM,PY1CM,PZ1CM,SRT,I1,I2,IBLOCK,
      1       NTAG,sdm,NT,ianti)
         LCOLL=LCOLL+1
         GO TO 400
 clin-8/2008 Deuteron+Meson->B+B collisions over
 c
 clin-9/2008 Deuteron+Baryon elastic collisions:
  506    continue
         ianti=0
         if(lb(i1).lt.0 .or. lb(i2).lt.0) ianti=1
         call sdbelastic(SRT,sdb)
         PX1CM=PCX
         PY1CM=PCY
         PZ1CM=PCZ
 c     minimum srt**2, note a 2.012GeV lower cutoff is used in N+N->Deuteron+pi:
         EC=2.012**2
         ds=sqrt(sdb/31.4)
         dsr=ds+0.1
         CALL DISTCE(I1,I2,dsr,ds,DT,EC,SRT,IC,PX1CM,PY1CM,PZ1CM)
         IF(IC.EQ.-1) GO TO 400
         CALL crdbel(PX1CM,PY1CM,PZ1CM,SRT,I1,I2,IBLOCK,
      1       NTAG,sdb,NT,ianti)
         LCOLL=LCOLL+1
         GO TO 400
 clin-9/2008 Deuteron+Baryon elastic collisions over
 c
 * IF BARYON RESONANCE+BARYON RESONANCE COLLISIONS
  444    CONTINUE
 * PREPARE THE EALSTIC CROSS SECTION FOR BARYON+BARYON COLLISIONS
        CUTOFF=em1+em2+0.02
 * AT HIGH ENERGIES THE ISOSPIN DEPENDENCE IS NEGLIGIBLE
 * THE TOTAL CROSS SECTION IS TAKEN AS THAT OF THE PP 
        IF(SRT.LE.CUTOFF)GO TO 400
         IF(SRT.GT.2.245)THEN
        SIGNN=PP2(SRT)
        ELSE
         SIGNN = 35.0 / (1. + (SRT - CUTOFF) * 100.0)  +  20.0
        ENDIF 
        IF(SIGNN.LE.0)GO TO 400
       CALL XDDIN(PCX,PCY,PCZ,SRT,I1,I2,
      &XINEL,SIGK,XSK1,XSK2,XSK3,XSK4,XSK5)
        SIG=SIGNN+XINEL
        EC=(EM1+EM2+0.02)**2
         PX1CM=PCX
         PY1CM=PCY
         PZ1CM=PCZ
 
 clin-6/2008 Deuteron production:
         ianti=0
         if(lb(i1).lt.0 .and. lb(i2).lt.0) ianti=1
         call sbbdm(srt,sdprod,ianti,lbm,xmm,pfinal)
         sig=sig+sdprod
 clin-6/2008 perturbative treatment of deuterons:
         ipdflag=0
         if(idpert.eq.1) then
            ipert1=1
            sigr0=sig
            dspert=sqrt(sigr0/pi/10.)
            dsrpert=dspert+0.1
            CALL DISTCE(I1,I2,dsrpert,dspert,DT,EC,SRT,IC,
      1          PX1CM,PY1CM,PZ1CM)
            IF(IC.EQ.-1) GO TO 367
            signn0=0.
            CALL CRDD(IRUN,PX1CM,PY1CM,PZ1CM,SRT,I1,I2,
      1          IBLOCK,NTAG,SIGNN0,SIGr0,NT,ipert1)
 c     1          IBLOCK,NTAG,SIGNN,SIG)
            ipdflag=1
  367       continue
            ipert1=0
         endif
         if(idpert.eq.2) ipert1=1
 c
         ds=sqrt(sig/31.4)
         dsr=ds+0.1
         CALL DISTCE(I1,I2,dsr,ds,DT,EC,SRT,IC,
      1  PX1CM,PY1CM,PZ1CM)
 c        IF(IC.EQ.-1) GO TO 400
         IF(IC.EQ.-1) then
            if(ipdflag.eq.1) iblock=501
            GO TO 400
         endif
 
 * CALCULATE KAON PRODUCTION PROBABILITY FROM NUCLEON+NUCLEON OR 
 * RESONANCE+RESONANCE COLLISIONS
        go to 364
 
 C CHECK WHAT KIND OF COLLISION HAS HAPPENED 
 364       ekaon(2,iss)=ekaon(2,iss)+1
 * for resonance+resonance
 clin-6/2008:
         CALL CRDD(IRUN,PX1CM,PY1CM,PZ1CM,SRT,I1,I2,
      1  IBLOCK,NTAG,SIGNN,SIG,NT,ipert1)
 c     1  IBLOCK,NTAG,SIGNN,SIG)
         IF(iblock.eq.0.and.ipdflag.eq.1) iblock=501
 c
         IF(iabs(IBLOCK).EQ.10)THEN
 * momentum of the three particles in the final state have been calculated
 * in the crnn, go out of the loop
            LCOLL=LCOLL+1
            IF(IBLOCK.EQ.10)THEN
               LDDK=LDDK+1
            elseIF(IBLOCK.EQ.-10) then
            endif
            GO TO 400
         ENDIF
 clin-6/2008
 c        if(iblock .eq. 222)then
         if(iblock .eq. 222.or.iblock.eq.501)then
 c    !! sp12/17/01 
            GO TO 400
         ENDIF
         em1=e(i1)
         em2=e(i2)
         GO TO 440
 * FOR PION+PION,pion+eta, eta+eta and rho(omega)+pion(rho,omega) or eta 
 777       CONTINUE
         PX1CM=PCX
         PY1CM=PCY
         PZ1CM=PCZ
 * energy thresh for collisions
        ec0=em1+em2+0.02
        IF(SRT.LE.ec0)GO TO 400
        ec=(em1+em2+0.02)**2
 * we negelect the elastic collision between mesons except that betwen
 * two pions because of the lack of information about these collisions
 * However, we do let them to collide inelastically to produce kaons
 clin-8/15/02       ppel=1.e-09
        ppel=20.
         ipp=1
        if(lb1.lt.3.or.lb1.gt.5.or.lb2.lt.3.or.lb2.gt.5)go to 778       
        CALL PPXS(LB1,LB2,SRT,PPSIG,spprho,IPP)
        ppel=ppsig
 778       ppink=pipik(srt)
 
 * pi+eta and eta+eta are assumed to be the same as pipik( for pi+pi -> K+K-) 
 * estimated from Ko's paper:
         ppink = 2.0 * ppink
        if(lb1.ge.25.and.lb2.ge.25) ppink=rrkk
 
 clin-2/13/03 include omega the same as rho, eta the same as pi:
 c        if(((lb1.ge.3.and.lb1.le.5).and.(lb2.ge.25.and.lb2.le.27))
 c     1  .or.((lb2.ge.3.and.lb2.le.5).and.(lb1.ge.25.and.lb1.le.27)))
         if( ( (lb1.eq.0.or.(lb1.ge.3.and.lb1.le.5))
      1       .and.(lb2.ge.25.and.lb2.le.28))
      2       .or. ( (lb2.eq.0.or.(lb2.ge.3.and.lb2.le.5))
      3       .and.(lb1.ge.25.and.lb1.le.28))) then
            ppink=0.
            if(srt.ge.(aka+aks)) ppink = prkk
         endif
 
 c pi pi <-> rho rho:
         call spprr(lb1,lb2,srt)
 clin-4/03/02 pi pi <-> eta eta:
         call sppee(lb1,lb2,srt)
 clin-4/03/02 pi pi <-> pi eta:
         call spppe(lb1,lb2,srt)
 clin-4/03/02 rho pi <-> rho eta:
         call srpre(lb1,lb2,srt)
 clin-4/03/02 omega pi <-> omega eta:
         call sopoe(lb1,lb2,srt)
 clin-4/03/02 rho rho <-> eta eta:
         call srree(lb1,lb2,srt)
 
         ppinnb=0.
         if(srt.gt.thresh(1)) then
            call getnst(srt)
            if(lb1.ge.3.and.lb1.le.5.and.lb2.ge.3.and.lb2.le.5) then
               ppinnb=ppbbar(srt)
            elseif((lb1.ge.3.and.lb1.le.5.and.lb2.ge.25.and.lb2.le.27)
      1 .or.(lb2.ge.3.and.lb2.le.5.and.lb1.ge.25.and.lb1.le.27)) then
               ppinnb=prbbar(srt)
            elseif(lb1.ge.25.and.lb1.le.27
      1             .and.lb2.ge.25.and.lb2.le.27) then
               ppinnb=rrbbar(srt)
            elseif((lb1.ge.3.and.lb1.le.5.and.lb2.eq.28)
      1             .or.(lb2.ge.3.and.lb2.le.5.and.lb1.eq.28)) then
               ppinnb=pobbar(srt)
            elseif((lb1.ge.25.and.lb1.le.27.and.lb2.eq.28)
      1             .or.(lb2.ge.25.and.lb2.le.27.and.lb1.eq.28)) then
               ppinnb=robbar(srt)
            elseif(lb1.eq.28.and.lb2.eq.28) then
               ppinnb=oobbar(srt)
            else
               if(lb1.ne.0.and.lb2.ne.0) 
      1             write(6,*) 'missed MM lb1,lb2=',lb1,lb2
            endif
         endif
         ppin=ppink+ppinnb+pprr+ppee+pppe+rpre+xopoe+rree
 
 * check if a collision can happen
        if((ppel+ppin).le.0.01)go to 400
        DSPP=SQRT((ppel+ppin)/31.4)
        dsppr=dspp+0.1
         CALL DISTCE(I1,I2,dsppr,DSPP,DT,EC,SRT,IC,
      1  PX1CM,PY1CM,PZ1CM)
         IF(IC.EQ.-1) GO TO 400
        if(ppel.eq.0)go to 400
 * the collision can happen
 * check what kind collision has happened
        ekaon(5,iss)=ekaon(5,iss)+1
         CALL CRPP(PX1CM,PY1CM,PZ1CM,SRT,I1,I2,
      1  IBLOCK,ppel,ppin,spprho,ipp)
 
 * rho formation, go to 400
 c       if(iblock.eq.666)go to 600
        if(iblock.eq.666)go to 555
        if(iblock.eq.6)LPP=LPP+1
        if(iblock.eq.66)then
           LPPk=LPPk+1
        elseif(iblock.eq.366)then
           LPPk=LPPk+1
        elseif(iblock.eq.367)then
           LPPk=LPPk+1
        endif
        em1=e(i1)
        em2=e(i2)
        go to 440
 
 * In this block we treat annihilations of
 clin-9/28/00* an anti-nucleon and a baryon or baryon resonance  
 * an anti-baryon and a baryon (including resonances)
 2799        CONTINUE
         PX1CM=PCX
         PY1CM=PCY
         PZ1CM=PCZ
         EC=(em1+em2+0.02)**2
 clin assume the same cross section (as a function of sqrt s) as for PPbar:
 
 clin-ctest annih maximum
 c        DSppb=SQRT(amin1(xppbar(srt),30.)/PI/10.)
        DSppb=SQRT(xppbar(srt)/PI/10.)
        dsppbr=dsppb+0.1
         CALL DISTCE(I1,I2,dsppbr,DSppb,DT,EC,SRT,IC,
      1  PX1CM,PY1CM,PZ1CM)
         IF(IC.EQ.-1) GO TO 400
         CALL Crppba(PX1CM,PY1CM,PZ1CM,SRT,I1,I2,
      1  IBLOCK)
        em1=e(i1)
        em2=e(i2)
        go to 440
 c
 3555    PX1CM=PCX
         PY1CM=PCY
         PZ1CM=PCZ
         EC=(em1+em2+0.02)**2
        DSkk=SQRT(SIG/PI/10.)
        dskk0=dskk+0.1
         CALL DISTCE(I1,I2,dskk0,DSkk,DT,EC,SRT,IC,
      1  PX1CM,PY1CM,PZ1CM)
         IF(IC.EQ.-1) GO TO 400
         CALL Crlaba(PX1CM,PY1CM,PZ1CM,SRT,brel,brsgm,
      &                  I1,I2,nt,IBLOCK,nchrg,icase)
        em1=e(i1)
        em2=e(i2)
        go to 440
 *
 c perturbative production of cascade and omega
 3455    PX1CM=PCX
         PY1CM=PCY
         PZ1CM=PCZ
         call pertur(PX1CM,PY1CM,PZ1CM,SRT,IRUN,I1,I2,nt,kp,icontp)
         if(icontp .eq. 0)then
 c     inelastic collisions:
          em1 = e(i1)
          em2 = e(i2)
          iblock = 727
           go to 440
         endif
 c     elastic collisions:
         if (e(i1) .eq. 0.) go to 800
         if (e(i2) .eq. 0.) go to 600
         go to 400
 *
 c* phi + N --> pi+N(D),  N(D,N*)+N(D,N*),  K+ +La
 c* phi + D --> pi+N(D)
 7222        CONTINUE
         PX1CM=PCX
         PY1CM=PCY
         PZ1CM=PCZ
         EC=(em1+em2+0.02)**2
         CALL XphiB(LB1, LB2, EM1, EM2, SRT,
      &             XSK1, XSK2, XSK3, XSK4, XSK5, SIGP)
        DSkk=SQRT(SIGP/PI/10.)
        dskk0=dskk+0.1
         CALL DISTCE(I1,I2,dskk0,DSkk,DT,EC,SRT,IC,
      1  PX1CM,PY1CM,PZ1CM)
         IF(IC.EQ.-1) GO TO 400
         CALL CRPHIB(PX1CM,PY1CM,PZ1CM,SRT,I1,I2,
      &     XSK1, XSK2, XSK3, XSK4, XSK5, SIGP, IBLOCK)
        em1=e(i1)
        em2=e(i2)
        go to 440
 *
 c* phi + M --> K+ + K* .....
 7444        CONTINUE
         PX1CM=PCX
         PY1CM=PCY
         PZ1CM=PCZ
         EC=(em1+em2+0.02)**2
         CALL PHIMES(I1, I2, SRT, XSK1, XSK2, XSK3, XSK4, XSK5,
      1     XSK6, XSK7, SIGPHI)
        DSkk=SQRT(SIGPHI/PI/10.)
        dskk0=dskk+0.1
         CALL DISTCE(I1,I2,dskk0,DSkk,DT,EC,SRT,IC,
      1  PX1CM,PY1CM,PZ1CM)
         IF(IC.EQ.-1) GO TO 400
 c*---
         PZRT = p(3,i1)+p(3,i2)
         ER1 = sqrt( p(1,i1)**2+p(2,i1)**2+p(3,i1)**2+E(i1)**2 )
         ER2 = sqrt( p(1,i2)**2+p(2,i2)**2+p(3,i2)**2+E(i2)**2 )
         ERT = ER1+ER2
         yy = 0.5*log( (ERT+PZRT)/(ERT-PZRT) )
 c*------
         CALL CRPHIM(PX1CM,PY1CM,PZ1CM,SRT,I1,I2,
      &  XSK1, XSK2, XSK3, XSK4, XSK5, XSK6, SIGPHI, IKKG, IKKL, IBLOCK)
        em1=e(i1)
        em2=e(i2)
        go to 440
 c
 c lambda-N elastic xsection, Li & Ko, PRC 54(1996)1897.
  7799    CONTINUE
          PX1CM=PCX
          PY1CM=PCY
          PZ1CM=PCZ
          EC=(em1+em2+0.02)**2
          call lambar(i1,i2,srt,siglab)
         DShn=SQRT(siglab/PI/10.)
         dshnr=dshn+0.1
          CALL DISTCE(I1,I2,dshnr,DShn,DT,EC,SRT,IC,
      1    PX1CM,PY1CM,PZ1CM)
         IF(IC.EQ.-1) GO TO 400
          CALL Crhb(PX1CM,PY1CM,PZ1CM,SRT,I1,I2,IBLOCK)
         em1=e(i1)
         em2=e(i2)
         go to 440
 c
 c* K+ + La(Si) --> Meson + B
 c* K- + La(Si)-bar --> Meson + B-bar
 5699        CONTINUE
         PX1CM=PCX
         PY1CM=PCY
         PZ1CM=PCZ
         EC=(em1+em2+0.02)**2
         CALL XKHYPE(I1, I2, SRT, XKY1, XKY2, XKY3, XKY4, XKY5,
      &     XKY6, XKY7, XKY8, XKY9, XKY10, XKY11, XKY12, XKY13,
      &     XKY14, XKY15, XKY16, XKY17, SIGK)
        DSkk=SQRT(sigk/PI)
        dskk0=dskk+0.1
         CALL DISTCE(I1,I2,dskk0,DSkk,DT,EC,SRT,IC,
      1  PX1CM,PY1CM,PZ1CM)
         IF(IC.EQ.-1) GO TO 400
 c
        if(lb(i1).eq.23 .or. lb(i2).eq.23)then
              IKMP = 1
         else
              IKMP = -1
         endif
         CALL Crkhyp(PX1CM,PY1CM,PZ1CM,SRT,I1,I2,
      &     XKY1, XKY2, XKY3, XKY4, XKY5,
      &     XKY6, XKY7, XKY8, XKY9, XKY10, XKY11, XKY12, XKY13,
      &     XKY14, XKY15, XKY16, XKY17, SIGK, IKMP,
      1  IBLOCK)
        em1=e(i1)
        em2=e(i2)
        go to 440
 c khyperon end
 *
 csp11/03/01 La/Si-bar + N --> pi + K+
 c  La/Si + N-bar --> pi + K-
 5999     CONTINUE
         PX1CM=PCX
         PY1CM=PCY
         PZ1CM=PCZ
         EC=(em1+em2+0.02)**2
         sigkp = 15.
 c      if((lb1.ge.14.and.lb1.le.17)
 c     &    .or.(lb2.ge.14.and.lb2.le.17))sigkp=10.
         DSkk=SQRT(SIGKP/PI/10.)
         dskk0=dskk+0.1
         CALL DISTCE(I1,I2,dskk0,DSkk,DT,EC,SRT,IC,
      1  PX1CM,PY1CM,PZ1CM)
         IF(IC.EQ.-1) GO TO 400
 c
         CALL CRLAN(PX1CM,PY1CM,PZ1CM,SRT,I1,I2,IBLOCK)
         em1=e(i1)
         em2=e(i2)
         go to 440
 c
 c*
 * K(K*) + K(K*) --> phi + pi(rho,omega)
 8699     CONTINUE
         PX1CM=PCX
         PY1CM=PCY
         PZ1CM=PCZ
         EC=(em1+em2+0.02)**2
 *  CALL CROSSKKPHI(PX1CM,PY1CM,PZ1CM,SRT,I1,I2,IBLOCK)  used for KK*->phi+rho
 
          CALL Crkphi(PX1CM,PY1CM,PZ1CM,EC,SRT,IBLOCK,
      &                  emm1,emm2,lbp1,lbp2,I1,I2,ikk,icase,rrkk,prkk)
          if(icase .eq. 0) then
             iblock=0
             go to 400
          endif
 
 c*---
          if(lbp1.eq.29.or.lbp2.eq.29) then
         PZRT = p(3,i1)+p(3,i2)
         ER1 = sqrt( p(1,i1)**2+p(2,i1)**2+p(3,i1)**2+E(i1)**2 )
         ER2 = sqrt( p(1,i2)**2+p(2,i2)**2+p(3,i2)**2+E(i2)**2 )
         ERT = ER1+ER2
         yy = 0.5*log( (ERT+PZRT)/(ERT-PZRT) )
 c*------
              iblock = 222
              ntag = 0
           endif
 
              LB(I1) = lbp1
              LB(I2) = lbp2
              E(I1) = emm1
              E(I2) = emm2
              em1=e(i1)
              em2=e(i2)
              go to 440
 c*
 * rho(omega) + K(K*)  --> phi + K(K*)
 8799     CONTINUE
         PX1CM=PCX
         PY1CM=PCY
         PZ1CM=PCZ
         EC=(em1+em2+0.02)**2
 *  CALL CROSSKKPHI(PX1CM,PY1CM,PZ1CM,SRT,I1,I2,IBLOCK)  used for KK*->phi+rho
          CALL Crksph(PX1CM,PY1CM,PZ1CM,EC,SRT,
      &       emm1,emm2,lbp1,lbp2,I1,I2,ikkg,ikkl,iblock,icase,srhoks)
          if(icase .eq. 0) then
             iblock=0
             go to 400
          endif
 c
          if(lbp1.eq.29.or.lbp2.eq.20) then
 c*---
         PZRT = p(3,i1)+p(3,i2)
         ER1 = sqrt( p(1,i1)**2+p(2,i1)**2+p(3,i1)**2+E(i1)**2 )
         ER2 = sqrt( p(1,i2)**2+p(2,i2)**2+p(3,i2)**2+E(i2)**2 )
         ERT = ER1+ER2
         yy = 0.5*log( (ERT+PZRT)/(ERT-PZRT) )
           endif
 
              LB(I1) = lbp1
              LB(I2) = lbp2
              E(I1) = emm1
              E(I2) = emm2
              em1=e(i1)
              em2=e(i2)
              go to 440
 
 * for kaon+baryon scattering, using a constant xsection of 10 mb.
 888       CONTINUE
         PX1CM=PCX
         PY1CM=PCY
         PZ1CM=PCZ
         EC=(em1+em2+0.02)**2
          sig = 10.
          if(iabs(lb1).eq.14.or.iabs(lb2).eq.14 .or.
      &      iabs(lb1).eq.30.or.iabs(lb2).eq.30)sig=20.
          if(lb1.eq.29.or.lb2.eq.29)sig=5.0
 
        DSkn=SQRT(sig/PI/10.)
        dsknr=dskn+0.1
         CALL DISTCE(I1,I2,dsknr,DSkn,DT,EC,SRT,IC,
      1  PX1CM,PY1CM,PZ1CM)
         IF(IC.EQ.-1) GO TO 400
         CALL Crkn(PX1CM,PY1CM,PZ1CM,SRT,I1,I2,
      1  IBLOCK)
        em1=e(i1)
        em2=e(i2)
        go to 440
 ***
 
  440    CONTINUE
 *                IBLOCK = 0 ; NOTHING HAS HAPPENED
 *                IBLOCK = 1 ; ELASTIC N-N COLLISION
 *                IBLOCK = 2 ; N + N -> N + DELTA
 *                IBLOCK = 3 ; N + DELTA -> N + N
 *                IBLOCK = 4 ; N + N -> d + d + PION,DIRECT PROCESS
 *               IBLOCK = 5 ; D(N*)+D(N*) COLLISIONS
 *                IBLOCK = 6 ; PION+PION COLLISIONS
 *                iblock = 7 ; pion+nucleon-->l/s+kaon
 *               iblock =77;  pion+nucleon-->delta+pion
 *               iblock = 8 ; kaon+baryon rescattering
 *                IBLOCK = 9 ; NN-->KAON+X
 *                IBLOCK = 10; DD-->KAON+X
 *               IBLOCK = 11; ND-->KAON+X
 cbali2/1/99
 *                
 *           iblock   - 1902 annihilation-->pion(+)+pion(-)   (2 pion)
 *           iblock   - 1903 annihilation-->pion(+)+rho(-)    (3 pion)
 *           iblock   - 1904 annihilation-->rho(+)+rho(-)     (4 pion)
 *           iblock   - 1905 annihilation-->rho(0)+omega      (5 pion)
 *           iblock   - 1906 annihilation-->omega+omega       (6 pion)
 cbali3/5/99
 *           iblock   - 1907 K+K- to pi+pi-
 cbali3/5/99 end
 cbz3/9/99 khyperon
 *           iblock   - 1908 K+Y -> piN
 cbz3/9/99 khyperon end
 cbali2/1/99end
 
 clin-9/28/00 Processes: m(pi rho omega)+m(pi rho omega)
 c     to anti-(p n D N*1 N*2)+(p n D N*1 N*2):
 *           iblock   - 1801  mm -->pbar p 
 *           iblock   - 18021 mm -->pbar n 
 *           iblock   - 18022 mm -->nbar p 
 *           iblock   - 1803  mm -->nbar n 
 *           iblock   - 18041 mm -->pbar Delta 
 *           iblock   - 18042 mm -->anti-Delta p
 *           iblock   - 18051 mm -->nbar Delta 
 *           iblock   - 18052 mm -->anti-Delta n
 *           iblock   - 18061 mm -->pbar N*(1400) 
 *           iblock   - 18062 mm -->anti-N*(1400) p
 *           iblock   - 18071 mm -->nbar N*(1400)
 *           iblock   - 18072 mm -->anti-N*(1400) n
 *           iblock   - 1808  mm -->anti-Delta Delta 
 *           iblock   - 18091 mm -->pbar N*(1535)
 *           iblock   - 18092 mm -->anti-N*(1535) p
 *           iblock   - 18101 mm -->nbar N*(1535)
 *           iblock   - 18102 mm -->anti-N*(1535) n
 *           iblock   - 18111 mm -->anti-Delta N*(1440)
 *           iblock   - 18112 mm -->anti-N*(1440) Delta
 *           iblock   - 18121 mm -->anti-Delta N*(1535)
 *           iblock   - 18122 mm -->anti-N*(1535) Delta
 *           iblock   - 1813  mm -->anti-N*(1440) N*(1440)
 *           iblock   - 18141 mm -->anti-N*(1440) N*(1535)
 *           iblock   - 18142 mm -->anti-N*(1535) N*(1440)
 *           iblock   - 1815  mm -->anti-N*(1535) N*(1535)
 clin-9/28/00-end
 
 clin-10/08/00 Processes: pi pi <-> rho rho
 *           iblock   - 1850  pi pi -> rho rho
 *           iblock   - 1851  rho rho -> pi pi
 clin-10/08/00-end
 
 clin-08/14/02 Processes: pi pi <-> eta eta
 *           iblock   - 1860  pi pi -> eta eta
 *           iblock   - 1861  eta eta -> pi pi
 * Processes: pi pi <-> pi eta
 *           iblock   - 1870  pi pi -> pi eta
 *           iblock   - 1871  pi eta -> pi pi
 * Processes: rho pi <-> rho eta
 *           iblock   - 1880  pi pi -> pi eta
 *           iblock   - 1881  pi eta -> pi pi
 * Processes: omega pi <-> omega eta
 *           iblock   - 1890  pi pi -> pi eta
 *           iblock   - 1891  pi eta -> pi pi
 * Processes: rho rho <-> eta eta
 *           iblock   - 1895  rho rho -> eta eta
 *           iblock   - 1896  eta eta -> rho rho
 clin-08/14/02-end
 
 clin-11/07/00 Processes: 
 *           iblock   - 366  pi rho -> K* Kbar or K*bar K
 *           iblock   - 466  pi rho <- K* Kbar or K*bar K
 
 clin-9/2008 Deuteron:
 *           iblock   - 501  B+B -> Deuteron+Meson
 *           iblock   - 502  Deuteron+Meson -> B+B
 *           iblock   - 503  Deuteron+Baryon elastic
 *           iblock   - 504  Deuteron+Meson elastic
 c
                  IF(IBLOCK.EQ.0)        GOTO 400
 *COM: FOR DIRECT PROCESS WE HAVE TREATED THE PAULI BLOCKING AND FIND
 *     THE MOMENTUM OF PARTICLES IN THE ''LAB'' FRAME. SO GO TO 400
 * A COLLISION HAS TAKEN PLACE !!
               LCOLL = LCOLL +1
 * WAS COLLISION PAULI-FORBIDEN? IF YES, NTAG = -1
               NTAG = 0
 *
 *             LORENTZ-TRANSFORMATION INTO CMS FRAME
               E1CM    = SQRT (EM1**2 + PX1CM**2 + PY1CM**2 + PZ1CM**2)
               P1BETA  = PX1CM*BETAX + PY1CM*BETAY + PZ1CM*BETAZ
               TRANSF  = GAMMA * ( GAMMA * P1BETA / (GAMMA + 1) + E1CM )
               Pt1I1 = BETAX * TRANSF + PX1CM
               Pt2I1 = BETAY * TRANSF + PY1CM
               Pt3I1 = BETAZ * TRANSF + PZ1CM
 * negelect the pauli blocking at high energies
               go to 90002
 
 clin-10/25/02-comment out following, since there is no path to it:
 c*CHECK IF PARTICLE #1 IS PAULI BLOCKED
 c              CALL PAULat(I1,occup)
 c              if (RANART(NSEED) .lt. occup) then
 c                ntag = -1
 c              else
 c                ntag = 0
 c              end if
 clin-10/25/02-end
 
 90002              continue
 *IF PARTICLE #1 IS NOT PAULI BLOCKED
 c              IF (NTAG .NE. -1) THEN
                 E2CM    = SQRT (EM2**2 + PX1CM**2 + PY1CM**2 + PZ1CM**2)
                 TRANSF  = GAMMA * (-GAMMA*P1BETA / (GAMMA + 1.) + E2CM)
                 Pt1I2 = BETAX * TRANSF - PX1CM
                 Pt2I2 = BETAY * TRANSF - PY1CM
                 Pt3I2 = BETAZ * TRANSF - PZ1CM
               go to 90003
 
 clin-10/25/02-comment out following, since there is no path to it:
 c*CHECK IF PARTICLE #2 IS PAULI BLOCKED
 c                CALL PAULat(I2,occup)
 c                if (RANART(NSEED) .lt. occup) then
 c                  ntag = -1
 c                else
 c                  ntag = 0
 c                end if
 cc              END IF
 c* IF COLLISION IS BLOCKED,RESTORE THE MOMENTUM,MASSES
 c* AND LABELS OF I1 AND I2
 cc             IF (NTAG .EQ. -1) THEN
 c                LBLOC  = LBLOC + 1
 c                P(1,I1) = PX1
 c                P(2,I1) = PY1
 c                P(3,I1) = PZ1
 c                P(1,I2) = PX2
 c                P(2,I2) = PY2
 c                P(3,I2) = PZ2
 c                E(I1)   = EM1
 c                E(I2)   = EM2
 c                LB(I1)  = LB1
 c                LB(I2)  = LB2
 cc              ELSE
 clin-10/25/02-end
 
 90003           IF(IBLOCK.EQ.1) LCNNE=LCNNE+1
               IF(IBLOCK.EQ.5) LDD=LDD+1
                 if(iblock.eq.2) LCNND=LCNND+1
               IF(IBLOCK.EQ.8) LKN=LKN+1
                    if(iblock.eq.43) Ldou=Ldou+1
 c                IF(IBLOCK.EQ.2) THEN
 * CALCULATE THE AVERAGE SRT FOR N + N---> N + DELTA PROCESS
 C                NODELT=NODELT+1
 C                SUMSRT=SUMSRT+SRT
 c                ENDIF
                 IF(IBLOCK.EQ.3) LCNDN=LCNDN+1
 * assign final momenta to particles while keep the leadng particle
 * behaviour
 C              if((pt1i1*px1+pt2i1*py1+pt3i1*pz1).gt.0)then
               p(1,i1)=pt1i1
               p(2,i1)=pt2i1
               p(3,i1)=pt3i1
               p(1,i2)=pt1i2
               p(2,i2)=pt2i2
               p(3,i2)=pt3i2
 C              else
 C              p(1,i1)=pt1i2
 C              p(2,i1)=pt2i2
 C              p(3,i1)=pt3i2
 C              p(1,i2)=pt1i1
 C              p(2,i2)=pt2i1
 C              p(3,i2)=pt3i1
 C              endif
                 PX1     = P(1,I1)
                 PY1     = P(2,I1)
                 PZ1     = P(3,I1)
                 EM1     = E(I1)
                 EM2     = E(I2)
                 LB1     = LB(I1)
                 LB2     = LB(I2)
                 ID(I1)  = 2
                 ID(I2)  = 2
                 E1      = SQRT( EM1**2 + PX1**2 + PY1**2 + PZ1**2 )
                 ID1     = ID(I1)
               go to 90004
 clin-10/25/02-comment out following, since there is no path to it:
 c* change phase space density FOR NUCLEONS INVOLVED :
 c* NOTE THAT f is the phase space distribution function for nucleons only
 c                if ((abs(ix1).le.mx) .and. (abs(iy1).le.my) .and.
 c     &              (abs(iz1).le.mz)) then
 c                  ipx1p = nint(p(1,i1)/dpx)
 c                  ipy1p = nint(p(2,i1)/dpy)
 c                  ipz1p = nint(p(3,i1)/dpz)
 c                  if ((ipx1p.ne.ipx1) .or. (ipy1p.ne.ipy1) .or.
 c     &                (ipz1p.ne.ipz1)) then
 c                    if ((abs(ipx1).le.mpx) .and. (abs(ipy1).le.my)
 c     &                .and. (ipz1.ge.-mpz) .and. (ipz1.le.mpzp)
 c     &                .AND. (AM1.LT.1.))
 c     &                f(ix1,iy1,iz1,ipx1,ipy1,ipz1) =
 c     &                f(ix1,iy1,iz1,ipx1,ipy1,ipz1) - 1.
 c                    if ((abs(ipx1p).le.mpx) .and. (abs(ipy1p).le.my)
 c     &                .and. (ipz1p.ge.-mpz).and. (ipz1p.le.mpzp)
 c     &                .AND. (EM1.LT.1.))
 c     &                f(ix1,iy1,iz1,ipx1p,ipy1p,ipz1p) =
 c     &                f(ix1,iy1,iz1,ipx1p,ipy1p,ipz1p) + 1.
 c                  end if
 c                end if
 c                if ((abs(ix2).le.mx) .and. (abs(iy2).le.my) .and.
 c     &              (abs(iz2).le.mz)) then
 c                  ipx2p = nint(p(1,i2)/dpx)
 c                  ipy2p = nint(p(2,i2)/dpy)
 c                  ipz2p = nint(p(3,i2)/dpz)
 c                  if ((ipx2p.ne.ipx2) .or. (ipy2p.ne.ipy2) .or.
 c     &                (ipz2p.ne.ipz2)) then
 c                    if ((abs(ipx2).le.mpx) .and. (abs(ipy2).le.my)
 c     &                .and. (ipz2.ge.-mpz) .and. (ipz2.le.mpzp)
 c     &                .AND. (AM2.LT.1.))
 c     &                f(ix2,iy2,iz2,ipx2,ipy2,ipz2) =
 c     &                f(ix2,iy2,iz2,ipx2,ipy2,ipz2) - 1.
 c                    if ((abs(ipx2p).le.mpx) .and. (abs(ipy2p).le.my)
 c     &                .and. (ipz2p.ge.-mpz) .and. (ipz2p.le.mpzp)
 c     &                .AND. (EM2.LT.1.))
 c     &                f(ix2,iy2,iz2,ipx2p,ipy2p,ipz2p) =
 c     &                f(ix2,iy2,iz2,ipx2p,ipy2p,ipz2p) + 1.
 c                  end if
 c                end if
 clin-10/25/02-end
 
 90004              continue
             AM1=EM1
             AM2=EM2
 c            END IF
 
 
   400       CONTINUE
 c
 clin-6/10/03 skips the info output on resonance creations:
 c            goto 550
 cclin-4/30/03 study phi,K*,Lambda(1520) resonances at creation:
 cc     note that no decays give these particles, so don't need to consider nnn:
 c            if(iblock.ne.0.and.(lb(i1).eq.29.or.iabs(lb(i1)).eq.30
 c     1           .or.lb(i2).eq.29.or.iabs(lb(i2)).eq.30
 c     2           .or.lb1i.eq.29.or.iabs(lb1i).eq.30
 c     3           .or.lb2i.eq.29.or.iabs(lb2i).eq.30)) then
 c               lb1now=lb(i1)
 c               lb2now=lb(i2)
 cc
 c               nphi0=0
 c               nksp0=0
 c               nksm0=0
 cc               nlar0=0
 cc               nlarbar0=0
 c               if(lb1i.eq.29) then
 c                  nphi0=nphi0+1
 c               elseif(lb1i.eq.30) then
 c                  nksp0=nksp0+1
 c               elseif(lb1i.eq.-30) then
 c                  nksm0=nksm0+1
 c               endif
 c               if(lb2i.eq.29) then
 c                  nphi0=nphi0+1
 c               elseif(lb2i.eq.30) then
 c                  nksp0=nksp0+1
 c               elseif(lb2i.eq.-30) then
 c                  nksm0=nksm0+1
 c               endif
 cc
 c               nphi=0
 c               nksp=0
 c               nksm=0
 c               nlar=0
 c               nlarbar=0
 c               if(lb1now.eq.29) then
 c                  nphi=nphi+1
 c               elseif(lb1now.eq.30) then
 c                  nksp=nksp+1
 c               elseif(lb1now.eq.-30) then
 c                  nksm=nksm+1
 c               endif
 c               if(lb2now.eq.29) then
 c                  nphi=nphi+1
 c               elseif(lb2now.eq.30) then
 c                  nksp=nksp+1
 c               elseif(lb2now.eq.-30) then
 c                  nksm=nksm+1
 c               endif
 cc     
 c               if(nphi.eq.2.or.nksp.eq.2.or.nksm.eq.2) then
 c                  write(91,*) '2 same resonances in one reaction!'
 c                  write(91,*) nphi,nksp,nksm,iblock
 c               endif
 c
 cc     All reactions create or destroy no more than 1 these resonance,
 cc     otherwise file "fort.91" warns us:
 c               do 222 ires=1,3
 c                  if(ires.eq.1.and.nphi.ne.nphi0) then
 c                     idr=29
 c                  elseif(ires.eq.2.and.nksp.ne.nksp0) then
 c                     idr=30
 c                  elseif(ires.eq.3.and.nksm.ne.nksm0) then
 c                     idr=-30
 c                  else
 c                     goto 222
 c                  endif
 cctest off for resonance (phi, K*) studies:
 cc               if(lb1now.eq.idr) then
 cc       write(17,112) 'collision',lb1now,P(1,I1),P(2,I1),P(3,I1),e(I1),nt
 cc               elseif(lb2now.eq.idr) then
 cc       write(17,112) 'collision',lb2now,P(1,I2),P(2,I2),P(3,I2),e(I2),nt
 cc               elseif(lb1i.eq.idr) then
 cc       write(18,112) 'collision',lb1i,px1i,py1i,pz1i,em1i,nt
 cc               elseif(lb2i.eq.idr) then
 cc       write(18,112) 'collision',lb2i,px2i,py2i,pz2i,em2i,nt
 cc               endif
 c 222           continue
 c
 c            else
 c            endif
 cc 112        format(a10,I4,4(1x,f9.3),1x,I4)
 c
 clin-2/26/03 skips the check of energy conservation after each binary search:
 c 550        goto 555
 c            pxfin=0
 c            pyfin=0
 c            pzfin=0
 c            efin=0
 c            if(e(i1).ne.0.or.lb(i1).eq.10022) then
 c               efin=efin+SQRT(E(I1)**2+P(1,I1)**2+P(2,I1)**2+P(3,I1)**2)
 c               pxfin=pxfin+P(1,I1)
 c               pyfin=pyfin+P(2,I1)
 c               pzfin=pzfin+P(3,I1)
 c            endif
 c            if(e(i2).ne.0.or.lb(i2).eq.10022) then
 c               efin=efin+SQRT(E(I2)**2+P(1,I2)**2+P(2,I2)**2+P(3,I2)**2)
 c               pxfin=pxfin+P(1,I2)
 c               pyfin=pyfin+P(2,I2)
 c               pzfin=pzfin+P(3,I2)
 c            endif
 c            if((nnn-nnnini).ge.1) then
 c               do imore=nnnini+1,nnn
 c                  if(EPION(imore,IRUN).ne.0) then
 c                     efin=efin+SQRT(EPION(imore,IRUN)**2
 c     1                    +PPION(1,imore,IRUN)**2+PPION(2,imore,IRUN)**2
 c     2                    +PPION(3,imore,IRUN)**2)
 c                     pxfin=pxfin+PPION(1,imore,IRUN)
 c                     pyfin=pyfin+PPION(2,imore,IRUN)
 c                     pzfin=pzfin+PPION(3,imore,IRUN)
 c                  endif
 c               enddo
 c            endif
 c            devio=sqrt((pxfin-pxini)**2+(pyfin-pyini)**2
 c     1           +(pzfin-pzini)**2+(efin-eini)**2)
 cc
 c            if(devio.ge.0.1) then
 c               write(92,'a20,5(1x,i6),2(1x,f8.3)') 'iblock,lb,npi=',
 c     1              iblock,lb1i,lb2i,lb(i1),lb(i2),e(i1),e(i2)
 c               do imore=nnnini+1,nnn
 c                  if(EPION(imore,IRUN).ne.0) then
 c                     write(92,'a10,2(1x,i6)') 'ipi,lbm=',
 c     1                    imore,LPION(imore,IRUN)
 c                  endif
 c               enddo
 c               write(92,'a3,4(1x,f8.3)') 'I:',eini,pxini,pyini,pzini
 c               write(92,'a3,5(1x,f8.3)') 
 c     1              'F:',efin,pxfin,pyfin,pzfin,devio
 c            endif
 c
  555        continue
 ctest off only one collision for the same 2 particles in the same timestep:
 c            if(iblock.ne.0) then
 c               goto 800
 c            endif
 ctest off collisions history:
 c            if(iblock.ne.0) then 
 c               write(10,*) nt,i1,i2,iblock,x1,z1,x2,z2
 c            endif
 
   600     CONTINUE
 
 clin-4/2012 option of pi0 decays:
 c     particles in lpion() may be a pi0, and when ipi0dcy=1 
 c     we need to decay them at nt=ntmax after all lb(i1) decays are done:
  798      if(nt.eq.ntmax.and.ipi0dcy.eq.1
      1         .and.i1.eq.(MASSR(IRUN)+MSUM)) then
              do ipion=1,NNN
                 if(LPION(ipion,IRUN).eq.4) then
                    wid=7.85e-9
                    call resdec(i1,nt,nnn,wid,idecay,ipion)
                 endif
              enddo
           endif
 ctest off
 c          if(nt.eq.ntmax.and.i1.eq.(MASSR(IRUN)+MSUM)) then
 c             do ip=1,i1
 c                write(98,*) lb(ip),e(ip),ip
 c             enddo
 c          endif
 
 clin-4/2012 option of pi0 decays-end
 
   800   CONTINUE
 * RELABLE MESONS LEFT IN THIS RUN EXCLUDING THOSE BEING CREATED DURING
 * THIS TIME STEP AND COUNT THE TOTAL NO. OF PARTICLES IN THIS RUN
 * note that the first mass=mta+mpr particles are baryons
 c        write(*,*)'I: NNN,massr ', nnn,massr(irun)
         N0=MASS+MSUM
         DO 1005 N=N0+1,MASSR(IRUN)+MSUM
 cbz11/25/98
 clin-2/19/03 lb>5000: keep particles with no LB codes in ART(photon,lepton,..):
 c        IF(E(N).GT.0.)THEN
         IF(E(N) .GT. 0. .OR. LB(N) .GT. 5000)THEN
 cbz11/25/98end
         NNN=NNN+1
         RPION(1,NNN,IRUN)=R(1,N)
         RPION(2,NNN,IRUN)=R(2,N)
         RPION(3,NNN,IRUN)=R(3,N)
 clin-10/28/03:
         if(nt.eq.ntmax) then
            ftpisv(NNN,IRUN)=ftsv(N)
            tfdpi(NNN,IRUN)=tfdcy(N)
         endif
 c
         PPION(1,NNN,IRUN)=P(1,N)
         PPION(2,NNN,IRUN)=P(2,N)
         PPION(3,NNN,IRUN)=P(3,N)
         EPION(NNN,IRUN)=E(N)
         LPION(NNN,IRUN)=LB(N)
 c       !! sp 12/19/00
         PROPI(NNN,IRUN)=PROPER(N)
 clin-5/2008:
         dppion(NNN,IRUN)=dpertp(N)
 c        if(lb(n) .eq. 45)
 c    &   write(*,*)'IN-1  NT,NNN,LB,P ',nt,NNN,lb(n),proper(n)
         ENDIF
  1005 CONTINUE
         MASSRN(IRUN)=NNN+MASS
 c        write(*,*)'F: NNN,massrn ', nnn,massrn(irun)
 1000   CONTINUE
 * CALCULATE THE AVERAGE SRT FOR N + N--->N +DELTA PROCESSES
 C        IF(NODELT.NE.0)THEN
 C        AVSRT=SUMSRT/FLOAT(NODELT)
 C        ELSE
 C        AVSRT=0.
 C        ENDIF
 C        WRITE(1097,'(F8.2,2X,E10.3)')FLOAT(NT)*DT,AVSRT
 * RELABLE ALL THE PARTICLES EXISTING AFTER THIS TIME STEP
         IA=0
         IB=0
         DO 10001 IRUN=1,NUM
         IA=IA+MASSR(IRUN-1)
         IB=IB+MASSRN(IRUN-1)
         DO 10001 IC=1,MASSRN(IRUN)
         IE=IA+IC
         IG=IB+IC
         IF(IC.LE.MASS)THEN
         RT(1,IG)=R(1,IE)
         RT(2,IG)=R(2,IE)
         RT(3,IG)=R(3,IE)
 clin-10/28/03:
         if(nt.eq.ntmax) then
            fttemp(IG)=ftsv(IE)
            tft(IG)=tfdcy(IE)
         endif
 c
         PT(1,IG)=P(1,IE)
         PT(2,IG)=P(2,IE)
         PT(3,IG)=P(3,IE)
         ET(IG)=E(IE)
         LT(IG)=LB(IE)
         PROT(IG)=PROPER(IE)
 clin-5/2008:
         dptemp(IG)=dpertp(IE)
         ELSE
         I0=IC-MASS
         RT(1,IG)=RPION(1,I0,IRUN)
         RT(2,IG)=RPION(2,I0,IRUN)
         RT(3,IG)=RPION(3,I0,IRUN)
 clin-10/28/03:
         if(nt.eq.ntmax) then
            fttemp(IG)=ftpisv(I0,IRUN)
            tft(IG)=tfdpi(I0,IRUN)
         endif
 c
         PT(1,IG)=PPION(1,I0,IRUN)
         PT(2,IG)=PPION(2,I0,IRUN)
         PT(3,IG)=PPION(3,I0,IRUN)
         ET(IG)=EPION(I0,IRUN)
         LT(IG)=LPION(I0,IRUN)
         PROT(IG)=PROPI(I0,IRUN)
 clin-5/2008:
         dptemp(IG)=dppion(I0,IRUN)
         ENDIF
 10001   CONTINUE
 c
         IL=0
 clin-10/26/01-hbt:
 c        DO 10002 IRUN=1,NUM
         DO 10003 IRUN=1,NUM
 
         MASSR(IRUN)=MASSRN(IRUN)
         IL=IL+MASSR(IRUN-1)
         DO 10002 IM=1,MASSR(IRUN)
         IN=IL+IM
         R(1,IN)=RT(1,IN)
         R(2,IN)=RT(2,IN)
         R(3,IN)=RT(3,IN)
 clin-10/28/03:
         if(nt.eq.ntmax) then
            ftsv(IN)=fttemp(IN)
            tfdcy(IN)=tft(IN)
         endif
         P(1,IN)=PT(1,IN)
         P(2,IN)=PT(2,IN)
         P(3,IN)=PT(3,IN)
         E(IN)=ET(IN)
         LB(IN)=LT(IN)
         PROPER(IN)=PROT(IN)
 clin-5/2008:
         dpertp(IN)=dptemp(IN)
        IF(LB(IN).LT.1.OR.LB(IN).GT.2)ID(IN)=0
 10002   CONTINUE
 clin-ctest off check energy conservation after each timestep
 c         enetot=0.
 c         do ip=1,MASSR(IRUN)
 c            if(e(ip).ne.0.or.lb(ip).eq.10022) enetot=enetot
 c     1           +sqrt(p(1,ip)**2+p(2,ip)**2+p(3,ip)**2+e(ip)**2)
 c         enddo
 c         write(91,*) 'B:',nt,enetot,massr(irun),bimp 
 clin-3/2009 move to the end of a timestep to take care of freezeout spacetime:
 c        call hbtout(MASSR(IRUN),nt,ntmax)
 10003 CONTINUE
 c
       RETURN
       END
 
 clin-9/2012: use double precision for S in CMS(): to avoid crash 
 c     (segmentation fault due to s<0, which happened at high energies 
 c     such as LHC with large NTMAX for two almost-comoving hadrons
 c     that have small Pt but large |Pz|):
 ****************************************
 c            SUBROUTINE CMS(I1,I2,PX1CM,PY1CM,PZ1CM,SRT)
 * PURPOSE : FIND THE MOMENTA OF PARTICLES IN THE CMS OF THE
 *          TWO COLLIDING PARTICLES
 * VARIABLES :
 *****************************************
 c            PARAMETER (MAXSTR=150001)
 c            COMMON   /AA/  R(3,MAXSTR)
 ccc      SAVE /AA/
 c            COMMON   /BB/  P(3,MAXSTR)
 ccc      SAVE /BB/
 c            COMMON   /CC/  E(MAXSTR)
 ccc      SAVE /CC/
 c            COMMON   /BG/  BETAX,BETAY,BETAZ,GAMMA
 ccc      SAVE /BG/
 c            SAVE   
 c            PX1=P(1,I1)
 c            PY1=P(2,I1)
 c            PZ1=P(3,I1)
 c            PX2=P(1,I2)
 c            PY2=P(2,I2)
 c            PZ2=P(3,I2)
 c            EM1=E(I1)
 c            EM2=E(I2)
 c            E1=SQRT(EM1**2+PX1**2+PY1**2+PZ1**2)
 c            E2=SQRT(EM2**2 + PX2**2 + PY2**2 + PZ2**2 )
 c            S=(E1+E2)**2-(PX1+PX2)**2-(PY1+PY2)**2-(PZ1+PZ2)**2
 c            SRT=SQRT(S)
 c*LORENTZ-TRANSFORMATION IN I1-I2-C.M. SYSTEM
 c              ETOTAL = E1 + E2
 c              BETAX  = (PX1+PX2) / ETOTAL
 c              BETAY  = (PY1+PY2) / ETOTAL
 c              BETAZ  = (PZ1+PZ2) / ETOTAL
 c              GAMMA  = 1.0 / SQRT(1.0-BETAX**2-BETAY**2-BETAZ**2)
 c*TRANSFORMATION OF MOMENTA (PX1CM = - PX2CM)
 c              P1BETA = PX1*BETAX + PY1*BETAY + PZ1 * BETAZ
 c              TRANSF = GAMMA * ( GAMMA * P1BETA / (GAMMA + 1) - E1 )
 c              PX1CM  = BETAX * TRANSF + PX1
 c              PY1CM  = BETAY * TRANSF + PY1
 c              PZ1CM  = BETAZ * TRANSF + PZ1
 c              RETURN
 c              END
 ****************************************
             SUBROUTINE CMS(I1,I2,PX1CM,PY1CM,PZ1CM,SRT)
 * PURPOSE : FIND THE MOMENTA OF PARTICLES IN THE CMS OF THE
 *          TWO COLLIDING PARTICLES
 * VARIABLES :
 *****************************************
             PARAMETER (MAXSTR=150001)
             double precision px1,py1,pz1,px2,py2,pz2,em1,em2,e1,e2,
      1      s,ETOTAL,P1BETA,TRANSF,dBETAX,dBETAY,dBETAZ,dGAMMA,scheck
             COMMON   /BB/  P(3,MAXSTR)
             COMMON   /CC/  E(MAXSTR)
             COMMON   /BG/  BETAX,BETAY,BETAZ,GAMMA
             SAVE   
             PX1=dble(P(1,I1))
             PY1=dble(P(2,I1))
             PZ1=dble(P(3,I1))
             PX2=dble(P(1,I2))
             PY2=dble(P(2,I2))
             PZ2=dble(P(3,I2))
             EM1=dble(E(I1))
             EM2=dble(E(I2))
             E1=dSQRT(EM1**2+PX1**2+PY1**2+PZ1**2)
             E2=dSQRT(EM2**2+PX2**2+PY2**2+PZ2**2)
             S=(E1+E2)**2-(PX1+PX2)**2-(PY1+PY2)**2-(PZ1+PZ2)**2
             IF(S.LE.0) S=0d0
             SRT=sngl(dSQRT(S))
 *LORENTZ-TRANSFORMATION IN I1-I2-C.M. SYSTEM
             ETOTAL = E1 + E2
             dBETAX  = (PX1+PX2) / ETOTAL
             dBETAY  = (PY1+PY2) / ETOTAL
             dBETAZ  = (PZ1+PZ2) / ETOTAL
 clin-9/2012: check argument in sqrt():
             scheck=1.d0-dBETAX**2-dBETAY**2-dBETAZ**2
             if(scheck.le.0d0) then
                write(99,*) 'scheck1: ', scheck
                stop
             endif
             dGAMMA=1.d0/dSQRT(scheck)
 *TRANSFORMATION OF MOMENTA (PX1CM = - PX2CM)
             P1BETA = PX1*dBETAX + PY1*dBETAY + PZ1 * dBETAZ
             TRANSF = dGAMMA * ( dGAMMA * P1BETA / (dGAMMA + 1d0) - E1 )
             PX1CM  = sngl(dBETAX * TRANSF + PX1)
             PY1CM  = sngl(dBETAY * TRANSF + PY1)
             PZ1CM  = sngl(dBETAZ * TRANSF + PZ1)
             BETAX  = sngl(dBETAX)
             BETAY  = sngl(dBETAY)
             BETAZ  = sngl(dBETAZ)
             GAMMA  = sngl(dGAMMA)
             RETURN
             END
 clin-9/2012-end
 
 ***************************************
             SUBROUTINE DISTCE(I1,I2,DELTAR,DS,DT,EC,SRT
      1      ,IC,PX1CM,PY1CM,PZ1CM)
 * PURPOSE : CHECK IF THE COLLISION BETWEEN TWO PARTICLES CAN HAPPEN
 *           BY CHECKING
 *                      (1) IF THE DISTANCE BETWEEN THEM IS SMALLER
 *           THAN THE MAXIMUM DISTANCE DETERMINED FROM THE CROSS SECTION.
 *                      (2) IF PARTICLE WILL PASS EACH OTHER WITHIN
 *           TWO HARD CORE RADIUS.
 *                      (3) IF PARTICLES WILL GET CLOSER.
 * VARIABLES :
 *           IC=1 COLLISION HAPPENED
 *           IC=-1 COLLISION CAN NOT HAPPEN
 *****************************************
             PARAMETER (MAXSTR=150001)
             COMMON   /AA/  R(3,MAXSTR)
 cc      SAVE /AA/
             COMMON   /BB/  P(3,MAXSTR)
 cc      SAVE /BB/
             COMMON   /CC/  E(MAXSTR)
 cc      SAVE /CC/
             COMMON   /BG/  BETAX,BETAY,BETAZ,GAMMA
             COMMON  /EE/      ID(MAXSTR),LB(MAXSTR)
 cc      SAVE /BG/
             common/leadng/lb1,px1,py1,pz1,em1,e1,xfnl,yfnl,zfnl,tfnl,
      1           px1n,py1n,pz1n,dp1n
             common /dpi/em2,lb2
             SAVE   
             IC=0
             X1=R(1,I1)
             Y1=R(2,I1)
             Z1=R(3,I1)
             PX1=P(1,I1)
             PY1=P(2,I1)
             PZ1=P(3,I1)
             X2=R(1,I2)
             Y2=R(2,I2)
             Z2=R(3,I2)
             PX2=P(1,I2)
             PY2=P(2,I2)
             PZ2=P(3,I2)
             EM1=E(I1)
             EM2=E(I2)
             E1=SQRT(EM1**2+PX1**2+PY1**2+PZ1**2)
 c            IF (ABS(X1-X2) .GT. DELTAR) GO TO 400
 c            IF (ABS(Y1-Y2) .GT. DELTAR) GO TO 400
 c            IF (ABS(Z1-Z2) .GT. DELTAR) GO TO 400
             RSQARE = (X1-X2)**2 + (Y1-Y2)**2 + (Z1-Z2)**2
             IF (RSQARE .GT. DELTAR**2) GO TO 400
 *NOW PARTICLES ARE CLOSE ENOUGH TO EACH OTHER !
               E2     = SQRT ( EM2**2 + PX2**2 + PY2**2 + PZ2**2 )
               S      = SRT*SRT
             IF (S .LT. EC) GO TO 400
 *NOW THERE IS ENOUGH ENERGY AVAILABLE !
 *LORENTZ-TRANSFORMATION IN I1-I2-C.M. SYSTEM
 * BETAX, BETAY, BETAZ AND GAMMA HAVE BEEN GIVEN IN THE SUBROUTINE CMS
 *TRANSFORMATION OF MOMENTA (PX1CM = - PX2CM)
               P1BETA = PX1*BETAX + PY1*BETAY + PZ1 * BETAZ
               TRANSF = GAMMA * ( GAMMA * P1BETA / (GAMMA + 1) - E1 )
               PRCM   = SQRT (PX1CM**2 + PY1CM**2 + PZ1CM**2)
               IF (PRCM .LE. 0.00001) GO TO 400
 *TRANSFORMATION OF SPATIAL DISTANCE
               DRBETA = BETAX*(X1-X2) + BETAY*(Y1-Y2) + BETAZ*(Z1-Z2)
               TRANSF = GAMMA * GAMMA * DRBETA / (GAMMA + 1)
               DXCM   = BETAX * TRANSF + X1 - X2
               DYCM   = BETAY * TRANSF + Y1 - Y2
               DZCM   = BETAZ * TRANSF + Z1 - Z2
 *DETERMINING IF THIS IS THE POINT OF CLOSEST APPROACH
               DRCM   = SQRT (DXCM**2  + DYCM**2  + DZCM**2 )
               DZZ    = (PX1CM*DXCM + PY1CM*DYCM + PZ1CM*DZCM) / PRCM
               if ((drcm**2 - dzz**2) .le. 0.) then
                 BBB = 0.
               else
                 BBB    = SQRT (DRCM**2 - DZZ**2)
               end if
 *WILL PARTICLE PASS EACH OTHER WITHIN 2 * HARD CORE RADIUS ?
               IF (BBB .GT. DS) GO TO 400
               RELVEL = PRCM * (1.0/E1 + 1.0/E2)
               DDD    = RELVEL * DT * 0.5
 *WILL PARTICLES GET CLOSER ?
               IF (ABS(DDD) .LT. ABS(DZZ)) GO TO 400
               IC=1
               GO TO 500
 400           IC=-1
 500           CONTINUE
               RETURN
               END
 ****************************************
 *                                                                      *
 *                                                                      *
       SUBROUTINE CRNN(IRUN,PX,PY,PZ,SRT,I1,I2,IBLOCK,
      1NTAG,SIGNN,SIG,NT,ipert1)
 *     PURPOSE:                                                         *
 *             DEALING WITH NUCLEON-NUCLEON COLLISIONS                    *
 *     NOTE   :                                                         *
 *     QUANTITIES:                                                 *
 *           PX,PY,PZ - MOMENTUM COORDINATES OF ONE PARTICLE IN CM FRAME*
 *           SRT      - SQRT OF S                                       *
 *           NSTAR =1 INCLUDING N* RESORANCE,ELSE NOT                   *
 *           NDIRCT=1 INCLUDING DIRECT PION PRODUCTION PROCESS         *
 *           IBLOCK   - THE INFORMATION BACK                            *
 *                      0-> COLLISION CANNOT HAPPEN                     *
 *                      1-> N-N ELASTIC COLLISION                       *
 *                      2-> N+N->N+DELTA,OR N+N->N+N* REACTION          *
 *                      3-> N+DELTA->N+N OR N+N*->N+N REACTION          *
 *                      4-> N+N->D+D+pion reaction
 *                     43->N+N->D(N*)+D(N*) reaction
 *                     44->N+N->D+D+rho reaction
 *                     45->N+N->N+N+rho
 *                     46->N+N->N+N+omega
 *           N12       - IS USED TO SPECIFY BARYON-BARYON REACTION      *
 *                      CHANNELS. M12 IS THE REVERSAL CHANNEL OF N12    *
 *                      N12,                                            *
 *                      M12=1 FOR p+n-->delta(+)+ n                     *
 *                          2     p+n-->delta(0)+ p                     *
 *                          3     p+p-->delta(++)+n                     *
 *                          4     p+p-->delta(+)+p                      *
 *                          5     n+n-->delta(0)+n                      *
 *                          6     n+n-->delta(-)+p                      *
 *                          7     n+p-->N*(0)(1440)+p                   *
 *                          8     n+p-->N*(+)(1440)+n                   *
 *                        9     p+p-->N*(+)(1535)+p                     *
 *                        10    n+n-->N*(0)(1535)+n                     *
 *                         11    n+p-->N*(+)(1535)+n                     *
 *                        12    n+p-->N*(0)(1535)+p
 *                        13    D(++)+D(-)-->N*(+)(1440)+n
 *                         14    D(++)+D(-)-->N*(0)(1440)+p
 *                        15    D(+)+D(0)--->N*(+)(1440)+n
 *                        16    D(+)+D(0)--->N*(0)(1440)+p
 *                        17    D(++)+D(0)-->N*(+)(1535)+p
 *                        18    D(++)+D(-)-->N*(0)(1535)+p
 *                        19    D(++)+D(-)-->N*(+)(1535)+n
 *                        20    D(+)+D(+)-->N*(+)(1535)+p
 *                        21    D(+)+D(0)-->N*(+)(1535)+n
 *                        22    D(+)+D(0)-->N*(0)(1535)+p
 *                        23    D(+)+D(-)-->N*(0)(1535)+n
 *                        24    D(0)+D(0)-->N*(0)(1535)+n
 *                          25    N*(+)(14)+N*(+)(14)-->N*(+)(15)+p
 *                          26    N*(0)(14)+N*(0)(14)-->N*(0)(15)+n
 *                          27    N*(+)(14)+N*(0)(14)-->N*(+)(15)+n
 *                        28    N*(+)(14)+N*(0)(14)-->N*(0)(15)+p
 *                        29    N*(+)(14)+D+-->N*(+)(15)+p
 *                        30    N*(+)(14)+D0-->N*(+)(15)+n
 *                        31    N*(+)(14)+D(-)-->N*(0)(1535)+n
 *                        32    N*(0)(14)+D++--->N*(+)(15)+p
 *                        33    N*(0)(14)+D+--->N*(+)(15)+n
 *                        34    N*(0)(14)+D+--->N*(0)(15)+p
 *                        35    N*(0)(14)+D0-->N*(0)(15)+n
 *                        36    N*(+)(14)+D0--->N*(0)(15)+p
 *                        ++    see the note book for more listing
 *                     
 *
 *     NOTE ABOUT N*(1440) RESORANCE IN Nucleon+NUCLEON COLLISION:      * 
 *     As it has been discussed in VerWest's paper,I= 1(initial isospin)*
 *     channel can all be attributed to delta resorance while I= 0      *
 *     channel can all be  attribured to N* resorance.Only in n+p       *
 *     one can have I=0 channel so is the N*(1440) resonance            *
 *                                                                      *
 *                             REFERENCES:                            *    
 *                    J. CUGNON ET AL., NUCL. PHYS. A352, 505 (1981)    *
 *                    Y. KITAZOE ET AL., PHYS. LETT. 166B, 35 (1986)    *
 *                    B. VerWest el al., PHYS. PRV. C25 (1982)1979      *
 *                    Gy. Wolf  et al, Nucl Phys A517 (1990) 615;       *
 *                                     Nucl phys A552 (1993) 349.       *
 **********************************
         PARAMETER (MAXSTR=150001,MAXR=1,AMN=0.939457,
      1  AMP=0.93828,AP1=0.13496,aka=0.498,AP2=0.13957,AM0=1.232,
      2  PI=3.1415926,CUTOFF=1.8966,AVMASS=0.9383,APHI=1.020)
         parameter     (MX=4,MY=4,MZ=8,MPX=4,MPY=4,mpz=10,mpzp=10)
         parameter (xmd=1.8756,npdmax=10000)
         COMMON /AA/ R(3,MAXSTR)
 cc      SAVE /AA/
         COMMON /BB/ P(3,MAXSTR)
 cc      SAVE /BB/
         COMMON /CC/ E(MAXSTR)
 cc      SAVE /CC/
         COMMON /EE/ ID(MAXSTR),LB(MAXSTR)
 cc      SAVE /EE/
         common /ff/f(-mx:mx,-my:my,-mz:mz,-mpx:mpx,-mpy:mpy,-mpz:mpzp)
 cc      SAVE /ff/
         common /gg/ dx,dy,dz,dpx,dpy,dpz
 cc      SAVE /gg/
         COMMON /INPUT/ NSTAR,NDIRCT,DIR
 cc      SAVE /INPUT/
         COMMON /NN/NNN
 cc      SAVE /NN/
         COMMON /BG/BETAX,BETAY,BETAZ,GAMMA
 cc      SAVE /BG/
         COMMON   /RUN/NUM
 cc      SAVE /RUN/
         COMMON   /PA/RPION(3,MAXSTR,MAXR)
 cc      SAVE /PA/
         COMMON   /PB/PPION(3,MAXSTR,MAXR)
 cc      SAVE /PB/
         COMMON   /PC/EPION(MAXSTR,MAXR)
 cc      SAVE /PC/
         COMMON   /PD/LPION(MAXSTR,MAXR)
 cc      SAVE /PD/
         COMMON/TABLE/ xarray(0:1000),earray(0:1000)
 cc      SAVE /TABLE/
         common/input1/ MASSPR,MASSTA,ISEED,IAVOID,DT
 cc      SAVE /input1/
       common/leadng/lb1,px1,py1,pz1,em1,e1,xfnl,yfnl,zfnl,tfnl,
      1 px1n,py1n,pz1n,dp1n
 cc      SAVE /leadng/
       COMMON/RNDF77/NSEED
 cc      SAVE /RNDF77/
       common /dpi/em2,lb2
       COMMON /dpert/dpertt(MAXSTR,MAXR),dpertp(MAXSTR),dplast(MAXSTR),
      1     dpdcy(MAXSTR),dpdpi(MAXSTR,MAXR),dpt(MAXSTR, MAXR),
      2     dpp1(MAXSTR,MAXR),dppion(MAXSTR,MAXR)
       common /para8/ idpert,npertd,idxsec
       dimension ppd(3,npdmax),lbpd(npdmax)
       SAVE   
 *-----------------------------------------------------------------------
       n12=0
       m12=0
       IBLOCK=0
       NTAG=0
       EM1=E(I1)
       EM2=E(I2)
       PR=SQRT( PX**2 + PY**2 + PZ**2 )
       C2=PZ / PR
       X1=RANART(NSEED)
       ianti=0
       if(lb(i1).lt.0 .and. lb(i2).lt.0) ianti=1
       call sbbdm(srt,sdprod,ianti,lbm,xmm,pfinal)
 clin-5/2008 Production of perturbative deuterons for idpert=1:
       if(idpert.eq.1.and.ipert1.eq.1) then
          IF (SRT .LT. 2.012) RETURN
          if((iabs(lb(i1)).eq.1.or.iabs(lb(i1)).eq.2)
      1        .and.(iabs(lb(i2)).eq.1.or.iabs(lb(i2)).eq.2)) then
             goto 108
          else
             return
          endif
       endif
 c
 *-----------------------------------------------------------------------
 *COM: TEST FOR ELASTIC SCATTERING (EITHER N-N OR DELTA-DELTA 0R
 *      N-DELTA OR N*-N* or N*-Delta)
 c      IF (X1 .LE. SIGNN/SIG) THEN
       IF (X1.LE.(SIGNN/SIG)) THEN
 *COM:  PARAMETRISATION IS TAKEN FROM THE CUGNON-PAPER
          AS  = ( 3.65 * (SRT - 1.8766) )**6
          A   = 6.0 * AS / (1.0 + AS)
          TA  = -2.0 * PR**2
          X   = RANART(NSEED)
 clin-10/24/02        T1  = DLOG( (1-X) * DEXP(dble(A)*dble(TA)) + X )  /  A
          T1  = sngl(DLOG(dble(1.-X)*DEXP(dble(A)*dble(TA))+dble(X)))/  A
          C1  = 1.0 - T1/TA
          T1  = 2.0 * PI * RANART(NSEED)
          IBLOCK=1
          GO TO 107
       ELSE
 *COM: TEST FOR INELASTIC SCATTERING
 *     IF THE AVAILABLE ENERGY IS LESS THAN THE PION-MASS, NOTHING
 *     CAN HAPPEN ANY MORE ==> RETURN (2.012 = 2*AVMASS + PI-MASS)
 clin-5/2008: Mdeuteron+Mpi=2.0106 to 2.0152 GeV/c2, so we can still use this:
          IF (SRT .LT. 2.012) RETURN
 *     calculate the N*(1535) production cross section in N+N collisions
 *     note that the cross sections in this subroutine are in units of mb
 *     as only ratios of the cross sections are used to determine the
 *     reaction channels
        call N1535(iabs(lb(i1)),iabs(lb(i2)),srt,x1535)
 *COM: HERE WE HAVE A PROCESS N+N ==> N+DELTA,OR N+N==>N+N*(144) or N*(1535)
 *     OR 
 * 3 pi channel : N+N==>d1+d2+PION
        SIG3=3.*(X3pi(SRT)+x33pi(srt))
 * 2 pi channel : N+N==>d1+d2+d1*n*+n*n*
        SIG4=4.*X2pi(srt)
 * 4 pi channel : N+N==>d1+d2+rho
        s4pi=x4pi(srt)
 * N+N-->NN+rho channel
        srho=xrho(srt)
 * N+N-->NN+omega
        somega=omega(srt)
 * CROSS SECTION FOR KAON PRODUCTION from the four channels
 * for NLK channel
        akp=0.498
        ak0=0.498
        ana=0.94
        ada=1.232
        al=1.1157
        as=1.1197
        xsk1=0
        xsk2=0
        xsk3=0
        xsk4=0
        xsk5=0
        t1nlk=ana+al+akp
        if(srt.le.t1nlk)go to 222
        XSK1=1.5*PPLPK(SRT)
 * for DLK channel
        t1dlk=ada+al+akp
        t2dlk=ada+al-akp
        if(srt.le.t1dlk)go to 222
        es=srt
        pmdlk2=(es**2-t1dlk**2)*(es**2-t2dlk**2)/(4.*es**2)
        pmdlk=sqrt(pmdlk2)
        XSK3=1.5*PPLPK(srt)
 * for NSK channel
        t1nsk=ana+as+akp
        t2nsk=ana+as-akp
        if(srt.le.t1nsk)go to 222
        pmnsk2=(es**2-t1nsk**2)*(es**2-t2nsk**2)/(4.*es**2)
        pmnsk=sqrt(pmnsk2)
        XSK2=1.5*(PPK1(srt)+PPK0(srt))
 * for DSK channel
        t1DSk=aDa+aS+akp
        t2DSk=aDa+aS-akp
        if(srt.le.t1dsk)go to 222
        pmDSk2=(es**2-t1DSk**2)*(es**2-t2DSk**2)/(4.*es**2)
        pmDSk=sqrt(pmDSk2)
        XSK4=1.5*(PPK1(srt)+PPK0(srt))
 csp11/21/01
 c phi production
        if(srt.le.(2.*amn+aphi))go to 222
 c  !! mb put the correct form
        xsk5 = 0.0001
 csp11/21/01 end
 c
 * THE TOTAL KAON+ PRODUCTION CROSS SECTION IS THEN
  222   SIGK=XSK1+XSK2+XSK3+XSK4
 
 cbz3/7/99 neutralk
         XSK1 = 2.0 * XSK1
         XSK2 = 2.0 * XSK2
         XSK3 = 2.0 * XSK3
         XSK4 = 2.0 * XSK4
         SIGK = 2.0 * SIGK + xsk5
 cbz3/7/99 neutralk end
 c
 ** FOR P+P or L/S+L/S COLLISION:
 c       lb1=lb(i1)
 c       lb2=lb(i2)
         lb1=iabs(lb(i1))
         lb2=iabs(lb(i2))
         IF((LB(I1)*LB(I2).EQ.1).or.
      &       ((lb1.le.17.and.lb1.ge.14).and.(lb2.le.17.and.lb2.ge.14)).
      &       or.((lb1.le.2).and.(lb2.le.17.and.lb2.ge.14)).
      &       or.((lb2.le.2).and.(lb1.le.17.and.lb1.ge.14)))THEN
 clin-8/2008 PP->d+meson here:
            IF(X1.LE.((SIGNN+sdprod)/SIG)) GO TO 108
            SIG1=SIGMA(SRT,1,1,0)+0.5*SIGMA(SRT,1,1,1)
            SIG2=1.5*SIGMA(SRT,1,1,1)
            SIGND=SIG1+SIG2+SIG3+SIG4+X1535+SIGK+s4pi+srho+somega
 clin-5/2008:
 c           IF (X1.GT.(SIGNN+SIGND)/SIG)RETURN
            IF (X1.GT.(SIGNN+SIGND+sdprod)/SIG)RETURN
            DIR=SIG3/SIGND
            IF(RANART(NSEED).LE.DIR)GO TO 106
            IF(RANART(NSEED).LE.SIGK/(SIGK+X1535+SIG4+SIG2+SIG1
      &          +s4pi+srho+somega))GO TO 306
            if(RANART(NSEED).le.s4pi/(x1535+sig4+sig2+sig1
      &          +s4pi+srho+somega))go to 307
            if(RANART(NSEED).le.srho/(x1535+sig4+sig2+sig1
      &          +srho+somega))go to 308
            if(RANART(NSEED).le.somega/(x1535+sig4+sig2+sig1
      &          +somega))go to 309
            if(RANART(NSEED).le.x1535/(sig1+sig2+sig4+x1535))then
 * N*(1535) production
               N12=9
            ELSE 
               IF(RANART(NSEED).LE.SIG4/(SIG1+sig2+sig4))THEN
 * DOUBLE DELTA PRODUCTION
                  N12=66
                  GO TO 1012
               else
 *DELTA PRODUCTION
                  N12=3
                  IF (RANART(NSEED).GT.SIG1/(SIG1+SIG2))N12=4
               ENDIF
            endif
            GO TO 1011
         ENDIF
 ** FOR N+N COLLISION:
         IF(iabs(LB(I1)).EQ.2.AND.iabs(LB(I2)).EQ.2)THEN
 clin-8/2008 NN->d+meson here:
            IF(X1.LE.((SIGNN+sdprod)/SIG)) GO TO 108
            SIG1=SIGMA(SRT,1,1,0)+0.5*SIGMA(SRT,1,1,1)
            SIG2=1.5*SIGMA(SRT,1,1,1)
            SIGND=SIG1+SIG2+X1535+SIG3+SIG4+SIGK+s4pi+srho+somega
 clin-5/2008:
 c           IF (X1.GT.(SIGNN+SIGND)/SIG)RETURN
            IF (X1.GT.(SIGNN+SIGND+sdprod)/SIG)RETURN
            dir=sig3/signd
            IF(RANART(NSEED).LE.DIR)GO TO 106
            IF(RANART(NSEED).LE.SIGK/(SIGK+X1535+SIG4+SIG2+SIG1
      &          +s4pi+srho+somega))GO TO 306
            if(RANART(NSEED).le.s4pi/(x1535+sig4+sig2+sig1
      &          +s4pi+srho+somega))go to 307
            if(RANART(NSEED).le.srho/(x1535+sig4+sig2+sig1
      &          +srho+somega))go to 308
            if(RANART(NSEED).le.somega/(x1535+sig4+sig2+sig1
      &          +somega))go to 309
            IF(RANART(NSEED).LE.X1535/(x1535+sig1+sig2+sig4))THEN
 * N*(1535) PRODUCTION
               N12=10
            ELSE 
               if(RANART(NSEED).le.sig4/(sig1+sig2+sig4))then
 * double delta production
                  N12=67
                  GO TO 1013
               else
 * DELTA PRODUCTION
                  N12=6
                  IF (RANART(NSEED).GT.SIG1/(SIG1+SIG2))N12=5
               ENDIF
            endif
            GO TO 1011
         ENDIF
 ** FOR N+P COLLISION
         IF(LB(I1)*LB(I2).EQ.2)THEN
 clin-5/2008 NP->d+meson here:
            IF(X1.LE.((SIGNN+sdprod)/SIG)) GO TO 108
            SIG1=0.5*SIGMA(SRT,1,1,1)+0.25*SIGMA(SRT,1,1,0)
            IF(NSTAR.EQ.1)THEN
               SIG2=(3./4.)*SIGMA(SRT,2,0,1)
            ELSE
               SIG2=0.
            ENDIF
            SIGND=2.*(SIG1+SIG2+X1535)+sig3+sig4+SIGK+s4pi+srho+somega
 clin-5/2008:
 c           IF (X1.GT.(SIGNN+SIGND)/SIG)RETURN
            IF (X1.GT.(SIGNN+SIGND+sdprod)/SIG)RETURN
            dir=sig3/signd
            IF(RANART(NSEED).LE.DIR)GO TO 106
            IF(RANART(NSEED).LE.SIGK/(SIGND-SIG3))GO TO 306
            if(RANART(NSEED).le.s4pi/(signd-sig3-sigk))go to 307
            if(RANART(NSEED).le.srho/(signd-sig3-sigk-s4pi))go to 308
            if(RANART(NSEED).le.somega/(signd-sig3-sigk-s4pi-srho))
      1          go to 309
            IF(RANART(NSEED).LT.X1535/(SIG1+SIG2+X1535+0.5*sig4))THEN
 * N*(1535) PRODUCTION
               N12=11
               IF(RANART(NSEED).LE.0.5)N12=12
            ELSE 
               if(RANART(NSEED).le.sig4/(sig4+2.*(sig1+sig2)))then
 * double resonance production
                  N12=68
                  GO TO 1014
               else
                  IF(RANART(NSEED).LE.SIG1/(SIG1+SIG2))THEN
 * DELTA PRODUCTION
                     N12=2
                     IF(RANART(NSEED).GE.0.5)N12=1
                  ELSE
 * N*(1440) PRODUCTION
                     N12=8
                     IF(RANART(NSEED).GE.0.5)N12=7
                  ENDIF
               ENDIF
            ENDIF
         endif
  1011   iblock=2
         CONTINUE
 *PARAMETRIZATION OF THE SHAPE OF THE DELTA RESONANCE ACCORDING
 *     TO kitazoe's or J.D.JACKSON'S MASS FORMULA AND BREIT WIGNER
 *     FORMULA FOR N* RESORANCE
 *     DETERMINE DELTA MASS VIA REJECTION METHOD.
           DMAX = SRT - AVMASS-0.005
           DMAX = SRT - AVMASS-0.005
           DMIN = 1.078
                    IF(N12.LT.7)THEN
 * Delta(1232) production
           IF(DMAX.LT.1.232) THEN
           FM=FDE(DMAX,SRT,0.)
           ELSE
 
 clin-10/25/02 get rid of argument usage mismatch in FDE():
              xdmass=1.232
 c          FM=FDE(1.232,SRT,1.)
           FM=FDE(xdmass,SRT,1.)
 clin-10/25/02-end
 
           ENDIF
           IF(FM.EQ.0.)FM=1.E-09
           NTRY1=0
 10        DM = RANART(NSEED) * (DMAX-DMIN) + DMIN
           NTRY1=NTRY1+1
           IF((RANART(NSEED) .GT. FDE(DM,SRT,1.)/FM).AND.
      1    (NTRY1.LE.30)) GOTO 10
 
 clin-2/26/03 limit the Delta mass below a certain value 
 c     (here taken as its central value + 2* B-W fullwidth):
           if(dm.gt.1.47) goto 10
 
               GO TO 13
               ENDIF
                    IF((n12.eq.7).or.(n12.eq.8))THEN
 * N*(1440) production
           IF(DMAX.LT.1.44) THEN
           FM=FNS(DMAX,SRT,0.)
           ELSE
 
 clin-10/25/02 get rid of argument usage mismatch in FNS():
              xdmass=1.44
 c          FM=FNS(1.44,SRT,1.)
           FM=FNS(xdmass,SRT,1.)
 clin-10/25/02-end
 
           ENDIF
           IF(FM.EQ.0.)FM=1.E-09
           NTRY2=0
 11        DM=RANART(NSEED)*(DMAX-DMIN)+DMIN
           NTRY2=NTRY2+1
           IF((RANART(NSEED).GT.FNS(DM,SRT,1.)/FM).AND.
      1    (NTRY2.LE.10)) GO TO 11
 
 clin-2/26/03 limit the N* mass below a certain value 
 c     (here taken as its central value + 2* B-W fullwidth):
           if(dm.gt.2.14) goto 11
 
               GO TO 13
               ENDIF
                     IF(n12.ge.17)then
 * N*(1535) production
           IF(DMAX.LT.1.535) THEN
           FM=FD5(DMAX,SRT,0.)
           ELSE
 
 clin-10/25/02 get rid of argument usage mismatch in FNS():
              xdmass=1.535
 c          FM=FD5(1.535,SRT,1.)
           FM=FD5(xdmass,SRT,1.)
 clin-10/25/02-end
 
           ENDIF
           IF(FM.EQ.0.)FM=1.E-09
           NTRY1=0
 12        DM = RANART(NSEED) * (DMAX-DMIN) + DMIN
           NTRY1=NTRY1+1
           IF((RANART(NSEED) .GT. FD5(DM,SRT,1.)/FM).AND.
      1    (NTRY1.LE.10)) GOTO 12
 
 clin-2/26/03 limit the N* mass below a certain value 
 c     (here taken as its central value + 2* B-W fullwidth):
           if(dm.gt.1.84) goto 12
 
          GO TO 13
              ENDIF
 * CALCULATE THE MASSES OF BARYON RESONANCES IN THE DOUBLE RESONANCE
 * PRODUCTION PROCESS AND RELABLE THE PARTICLES
 1012       iblock=43
        call Rmasdd(srt,1.232,1.232,1.08,
      &  1.08,ISEED,1,dm1,dm2)
        call Rmasdd(srt,1.232,1.44,1.08,
      &  1.08,ISEED,3,dm1n,dm2n)
        IF(N12.EQ.66)THEN
 *(1) PP-->DOUBLE RESONANCES
 * DETERMINE THE FINAL STATE
        XFINAL=RANART(NSEED)
        IF(XFINAL.LE.0.25)THEN
 * (1.1) D+++D0 
        LB(I1)=9
        LB(I2)=7
        e(i1)=dm1
        e(i2)=dm2
        GO TO 200
 * go to 200 to set the new momentum
        ENDIF
        IF((XFINAL.gt.0.25).and.(xfinal.le.0.5))THEN
 * (1.2) D++D+
        LB(I1)=8
        LB(I2)=8
        e(i1)=dm1
        e(i2)=dm2
        GO TO 200
 * go to 200 to set the new momentum
        ENDIF
        IF((XFINAL.gt.0.5).and.(xfinal.le.0.75))THEN
 * (1.3) D+++N*0 
        LB(I1)=9
        LB(I2)=10
        e(i1)=dm1n
        e(i2)=dm2n
        GO TO 200
 * go to 200 to set the new momentum
        ENDIF
        IF(XFINAL.gt.0.75)then
 * (1.4) D++N*+ 
        LB(I1)=8
        LB(I2)=11
        e(i1)=dm1n
        e(i2)=dm2n
        GO TO 200
 * go to 200 to set the new momentum
        ENDIF
        ENDIF
 1013       iblock=43
        call Rmasdd(srt,1.232,1.232,1.08,
      &  1.08,ISEED,1,dm1,dm2)
        call Rmasdd(srt,1.232,1.44,1.08,
      &  1.08,ISEED,3,dm1n,dm2n)
        IF(N12.EQ.67)THEN
 *(2) NN-->DOUBLE RESONANCES
 * DETERMINE THE FINAL STATE
        XFINAL=RANART(NSEED)
        IF(XFINAL.LE.0.25)THEN
 * (2.1) D0+D0 
        LB(I1)=7
        LB(I2)=7
        e(i1)=dm1
        e(i2)=dm2
        GO TO 200
 * go to 200 to set the new momentum
         ENDIF
        IF((XFINAL.gt.0.25).and.(xfinal.le.0.5))THEN
 * (2.2) D++D+
        LB(I1)=6
        LB(I2)=8
        e(i1)=dm1
        e(i2)=dm2
        GO TO 200
 * go to 200 to set the new momentum
        ENDIF
        IF((XFINAL.gt.0.5).and.(xfinal.le.0.75))THEN
 * (2.3) D0+N*0 
        LB(I1)=7
        LB(I2)=10
        e(i1)=dm1n
        e(i2)=dm2n
        GO TO 200
 * go to 200 to set the new momentum
        ENDIF
        IF(XFINAL.gt.0.75)then
 * (2.4) D++N*+ 
        LB(I1)=8
        LB(I2)=11
        e(i1)=dm1n
        e(i2)=dm2n
        GO TO 200
 * go to 200 to set the new momentum
        ENDIF
        ENDIF
 1014       iblock=43
        call Rmasdd(srt,1.232,1.232,1.08,
      &  1.08,ISEED,1,dm1,dm2)
        call Rmasdd(srt,1.232,1.44,1.08,
      &  1.08,ISEED,3,dm1n,dm2n)
        IF(N12.EQ.68)THEN
 *(3) NP-->DOUBLE RESONANCES
 * DETERMINE THE FINAL STATE
        XFINAL=RANART(NSEED)
        IF(XFINAL.LE.0.25)THEN
 * (3.1) D0+D+ 
        LB(I1)=7
        LB(I2)=8
        e(i1)=dm1
        e(i2)=dm2
        GO TO 200
 * go to 200 to set the new momentum
        ENDIF
        IF((XFINAL.gt.0.25).and.(xfinal.le.0.5))THEN
 * (3.2) D+++D-
        LB(I1)=9
        LB(I2)=6
        e(i1)=dm1
        e(i2)=dm2
        GO TO 200
 * go to 200 to set the new momentum
        ENDIF
        IF((XFINAL.gt.0.5).and.(xfinal.le.0.75))THEN
 * (3.3) D0+N*+ 
        LB(I1)=7
        LB(I2)=11
        e(i1)=dm1n
        e(i2)=dm2n
        GO TO 200
 * go to 200 to set the new momentum
        ENDIF
        IF(XFINAL.gt.0.75)then
 * (3.4) D++N*0
        LB(I1)=8
        LB(I2)=10
        e(i1)=dm1n
        e(i2)=dm2n
        GO TO 200
 * go to 200 to set the new momentum
        ENDIF
        ENDIF
 13       CONTINUE
 *-------------------------------------------------------
 * RELABLE BARYON I1 AND I2
 *1. p+n-->delta(+)+n
           IF(N12.EQ.1)THEN
           IF(iabs(LB(I1)).EQ.1)THEN
           LB(I2)=2
           LB(I1)=8
           E(I1)=DM
           ELSE
           LB(I1)=2
           LB(I2)=8
           E(I2)=DM
           ENDIF
          GO TO 200
           ENDIF
 *2 p+n-->delta(0)+p
           IF(N12.EQ.2)THEN
           IF(iabs(LB(I1)).EQ.2)THEN
           LB(I2)=1
           LB(I1)=7
           E(I1)=DM
           ELSE
           LB(I1)=1
           LB(I2)=7
           E(I2)=DM
           ENDIF
          GO TO 200
           ENDIF
 *3 p+p-->delta(++)+n
           IF(N12.EQ.3)THEN
           LB(I1)=9
           E(I1)=DM
           LB(I2)=2
           E(I2)=AMN
          GO TO 200
           ENDIF
 *4 p+p-->delta(+)+p
           IF(N12.EQ.4)THEN
           LB(I2)=1
           LB(I1)=8
           E(I1)=DM
          GO TO 200
           ENDIF
 *5 n+n--> delta(0)+n
           IF(N12.EQ.5)THEN
           LB(I2)=2
           LB(I1)=7
           E(I1)=DM
          GO TO 200
           ENDIF
 *6 n+n--> delta(-)+p
           IF(N12.EQ.6)THEN
           LB(I1)=6
           E(I1)=DM
           LB(I2)=1
           E(I2)=AMP
          GO TO 200
           ENDIF
 *7 n+p--> N*(0)+p
           IF(N12.EQ.7)THEN
           IF(iabs(LB(I1)).EQ.1)THEN
           LB(I1)=1
           LB(I2)=10
           E(I2)=DM
           ELSE
           LB(I2)=1
           LB(I1)=10
           E(I1)=DM
           ENDIF
          GO TO 200
           ENDIF
 *8 n+p--> N*(+)+n
           IF(N12.EQ.8)THEN
           IF(iabs(LB(I1)).EQ.1)THEN
           LB(I2)=2
           LB(I1)=11
           E(I1)=DM
           ELSE
           LB(I1)=2
           LB(I2)=11
           E(I2)=DM
           ENDIF
          GO TO 200
           ENDIF
 *9 p+p--> N*(+)(1535)+p
           IF(N12.EQ.9)THEN
           IF(RANART(NSEED).le.0.5)THEN
           LB(I2)=1
           LB(I1)=13
           E(I1)=DM
           ELSE
           LB(I1)=1
           LB(I2)=13
           E(I2)=DM
           ENDIF
          GO TO 200
           ENDIF
 *10 n+n--> N*(0)(1535)+n
           IF(N12.EQ.10)THEN
           IF(RANART(NSEED).le.0.5)THEN
           LB(I2)=2
           LB(I1)=12
           E(I1)=DM
           ELSE
           LB(I1)=2
           LB(I2)=12
           E(I2)=DM
           ENDIF
          GO TO 200
           ENDIF
 *11 n+p--> N*(+)(1535)+n
           IF(N12.EQ.11)THEN
           IF(iabs(LB(I1)).EQ.2)THEN
           LB(I1)=2
           LB(I2)=13
           E(I2)=DM
           ELSE
           LB(I2)=2
           LB(I1)=13
           E(I1)=DM
           ENDIF
          GO TO 200
           ENDIF
 *12 n+p--> N*(0)(1535)+p
           IF(N12.EQ.12)THEN
           IF(iabs(LB(I1)).EQ.1)THEN
           LB(I1)=1
           LB(I2)=12
           E(I2)=DM
           ELSE
           LB(I2)=1
           LB(I1)=12
           E(I1)=DM
           ENDIF
           ENDIF
          endif
 * CALCULATE THE MAGNITUDE OF THE FINAL MOMENTUM THROUGH
 * ENERGY CONSERVATION
 200       EM1=E(I1)
           EM2=E(I2)
           PR2   = (SRT**2 - EM1**2 - EM2**2)**2
      1                - 4.0 * (EM1*EM2)**2
           IF(PR2.LE.0.)PR2=1.e-09
           PR=SQRT(PR2)/(2.*SRT)
               if(srt.le.2.14)C1= 1.0 - 2.0 * RANART(NSEED)
          if(srt.gt.2.14.and.srt.le.2.4)c1=ang(srt,iseed)
          if(srt.gt.2.4)then
 
 clin-10/25/02 get rid of argument usage mismatch in PTR():
              xptr=0.33*pr
 c         cc1=ptr(0.33*pr,iseed)
              cc1=ptr(xptr,iseed)
 clin-10/25/02-end
 
 clin-9/2012: check argument in sqrt():
              scheck=pr**2-cc1**2
              if(scheck.lt.0) then
                 write(99,*) 'scheck2: ', scheck
                 scheck=0.
              endif
              c1=sqrt(scheck)/pr
 c             c1=sqrt(pr**2-cc1**2)/pr
 
          endif
           T1   = 2.0 * PI * RANART(NSEED)
        if(ianti.eq.1 .and. lb(i1).ge.1 .and. lb(i2).ge.1)then
          lb(i1) = -lb(i1)
          lb(i2) = -lb(i2)
        endif
           GO TO 107
 *FOR THE NN-->D1+D2+PI PROCESS, FIND MOMENTUM OF THE FINAL TWO
 *DELTAS AND PION IN THE NUCLEUS-NUCLEUS CMS.
 106     CONTINUE
            NTRY1=0
 123        CALL DDP2(SRT,ISEED,PX3,PY3,PZ3,DM3,PX4,PY4,PZ4,DM4,
      &  PPX,PPY,PPZ,icou1)
        NTRY1=NTRY1+1
        if((icou1.lt.0).AND.(NTRY1.LE.40))GO TO 123
 C       if(icou1.lt.0)return
 * ROTATE THE MOMENTA OF PARTICLES IN THE CMS OF P1+P2
        CALL ROTATE(PX,PY,PZ,PX3,PY3,PZ3)
        CALL ROTATE(PX,PY,PZ,PX4,PY4,PZ4)
        CALL ROTATE(PX,PY,PZ,PPX,PPY,PPZ)
                 NNN=NNN+1
 * DETERMINE THE CHARGE STATES OF PARTICLES IN THE FINAL STATE
 * (1) FOR P+P
               XDIR=RANART(NSEED)
                 IF(LB(I1)*LB(I2).EQ.1)THEN
                 IF(XDIR.Le.0.2)then
 * (1.1)P+P-->D+++D0+PION(0)
                 LPION(NNN,IRUN)=4
                 EPION(NNN,IRUN)=AP1
               LB(I1)=9
               LB(I2)=7
        GO TO 205
                 ENDIF
 * (1.2)P+P -->D++D+PION(0)
                 IF((XDIR.LE.0.4).AND.(XDIR.GT.0.2))THEN
                 LPION(NNN,IRUN)=4
                 EPION(NNN,IRUN)=AP1
                 LB(I1)=8
                 LB(I2)=8
        GO TO 205
               ENDIF 
 * (1.3)P+P-->D+++D+PION(-)
                 IF((XDIR.LE.0.6).AND.(XDIR.GT.0.4))THEN
                 LPION(NNN,IRUN)=3
                 EPION(NNN,IRUN)=AP2
                 LB(I1)=9
                 LB(I2)=8
        GO TO 205
               ENDIF 
                 IF((XDIR.LE.0.8).AND.(XDIR.GT.0.6))THEN
                 LPION(NNN,IRUN)=5
                 EPION(NNN,IRUN)=AP2
                 LB(I1)=9
                 LB(I2)=6
        GO TO 205
               ENDIF 
                 IF(XDIR.GT.0.8)THEN
                 LPION(NNN,IRUN)=5
                 EPION(NNN,IRUN)=AP2
                 LB(I1)=7
                 LB(I2)=8
        GO TO 205
               ENDIF 
                ENDIF
 * (2)FOR N+N
                 IF(iabs(LB(I1)).EQ.2.AND.iabs(LB(I2)).EQ.2)THEN
                 IF(XDIR.Le.0.2)then
 * (2.1)N+N-->D++D-+PION(0)
                 LPION(NNN,IRUN)=4
                 EPION(NNN,IRUN)=AP1
               LB(I1)=6
               LB(I2)=7
        GO TO 205
                 ENDIF
 * (2.2)N+N -->D+++D-+PION(-)
                 IF((XDIR.LE.0.4).AND.(XDIR.GT.0.2))THEN
                 LPION(NNN,IRUN)=3
                 EPION(NNN,IRUN)=AP2
                 LB(I1)=6
                 LB(I2)=9
        GO TO 205
               ENDIF 
 * (2.3)P+P-->D0+D-+PION(+)
                 IF((XDIR.GT.0.4).AND.(XDIR.LE.0.6))THEN
                 LPION(NNN,IRUN)=5
                 EPION(NNN,IRUN)=AP2
                 LB(I1)=9
                 LB(I2)=8
        GO TO 205
               ENDIF 
 * (2.4)P+P-->D0+D0+PION(0)
                 IF((XDIR.GT.0.6).AND.(XDIR.LE.0.8))THEN
                 LPION(NNN,IRUN)=4
                 EPION(NNN,IRUN)=AP1
                 LB(I1)=7
                 LB(I2)=7
        GO TO 205
               ENDIF 
 * (2.5)P+P-->D0+D++PION(-)
                 IF(XDIR.GT.0.8)THEN
                 LPION(NNN,IRUN)=3
                 EPION(NNN,IRUN)=AP2
                 LB(I1)=7
                 LB(I2)=8
        GO TO 205
               ENDIF 
               ENDIF
 * (3)FOR N+P
                 IF(LB(I1)*LB(I2).EQ.2)THEN
                 IF(XDIR.Le.0.17)then
 * (3.1)N+P-->D+++D-+PION(0)
                 LPION(NNN,IRUN)=4
                 EPION(NNN,IRUN)=AP1
               LB(I1)=6
               LB(I2)=9
        GO TO 205
                 ENDIF
 * (3.2)N+P -->D+++D0+PION(-)
                 IF((XDIR.LE.0.34).AND.(XDIR.GT.0.17))THEN
                 LPION(NNN,IRUN)=3
                 EPION(NNN,IRUN)=AP2
                 LB(I1)=7
                 LB(I2)=9
        GO TO 205
               ENDIF 
 * (3.3)N+P-->D++D-+PION(+)
                 IF((XDIR.GT.0.34).AND.(XDIR.LE.0.51))THEN
                 LPION(NNN,IRUN)=5
                 EPION(NNN,IRUN)=AP2
                 LB(I1)=7
                 LB(I2)=8
        GO TO 205
               ENDIF 
 * (3.4)N+P-->D++D++PION(-)
                 IF((XDIR.GT.0.51).AND.(XDIR.LE.0.68))THEN
                 LPION(NNN,IRUN)=3
                 EPION(NNN,IRUN)=AP2
                 LB(I1)=8
                 LB(I2)=8
        GO TO 205
               ENDIF 
 * (3.5)N+P-->D0+D++PION(0)
                 IF((XDIR.GT.0.68).AND.(XDIR.LE.0.85))THEN
                 LPION(NNN,IRUN)=4
                 EPION(NNN,IRUN)=AP2
                 LB(I1)=7
                 LB(I2)=8
        GO TO 205
               ENDIF 
 * (3.6)N+P-->D0+D0+PION(+)
                 IF(XDIR.GT.0.85)THEN
                 LPION(NNN,IRUN)=5
                 EPION(NNN,IRUN)=AP2
                 LB(I1)=7
                 LB(I2)=7
               ENDIF 
                 ENDIF
 * FIND THE MOMENTUM OF PARTICLES IN THE FINAL STATE IN THE NUCLEUS-
 * NUCLEUS CMS. FRAME 
 *             LORENTZ-TRANSFORMATION INTO LAB FRAME FOR DELTA1
 205           E1CM    = SQRT (dm3**2 + PX3**2 + PY3**2 + PZ3**2)
               P1BETA  = PX3*BETAX + PY3*BETAY + PZ3*BETAZ
               TRANSF  = GAMMA * ( GAMMA * P1BETA / (GAMMA + 1) + E1CM )
               Pt1i1 = BETAX * TRANSF + PX3
               Pt2i1 = BETAY * TRANSF + PY3
               Pt3i1 = BETAZ * TRANSF + PZ3
              Eti1   = DM3
 c
              if(ianti.eq.1 .and. lb(i1).ge.1 .and. lb(i2).ge.1)then
                lb(i1) = -lb(i1)
                lb(i2) = -lb(i2)
                 if(LPION(NNN,IRUN) .eq. 3)then
                   LPION(NNN,IRUN)=5
                 elseif(LPION(NNN,IRUN) .eq. 5)then
                   LPION(NNN,IRUN)=3
                 endif
                endif
 c
              lb1=lb(i1)
 * FOR DELTA2
                 E2CM    = SQRT (dm4**2 + PX4**2 + PY4**2 + PZ4**2)
                 P2BETA  = PX4*BETAX+PY4*BETAY+PZ4*BETAZ
                 TRANSF  = GAMMA * (GAMMA*P2BETA / (GAMMA + 1.) + E2CM)
                 Pt1I2 = BETAX * TRANSF + PX4
                 Pt2I2 = BETAY * TRANSF + PY4
                 Pt3I2 = BETAZ * TRANSF + PZ4
               EtI2   = DM4
               lb2=lb(i2)
 * assign delta1 and delta2 to i1 or i2 to keep the leadng particle
 * behaviour
 C              if((pt1i1*px1+pt2i1*py1+pt3i1*pz1).gt.0)then
               p(1,i1)=pt1i1
               p(2,i1)=pt2i1
               p(3,i1)=pt3i1
               e(i1)=eti1
               lb(i1)=lb1
               p(1,i2)=pt1i2
               p(2,i2)=pt2i2
               p(3,i2)=pt3i2
               e(i2)=eti2
               lb(i2)=lb2
                 PX1     = P(1,I1)
                 PY1     = P(2,I1)
                 PZ1     = P(3,I1)
               EM1       = E(I1)
                 ID(I1)  = 2
                 ID(I2)  = 2
                 ID1     = ID(I1)
                 IBLOCK=4
 * GET PION'S MOMENTUM AND COORDINATES IN NUCLEUS-NUCLEUS CMS. FRAME
                 EPCM=SQRT(EPION(NNN,IRUN)**2+PPX**2+PPY**2+PPZ**2)
                 PPBETA=PPX*BETAX+PPY*BETAY+PPZ*BETAZ
                 TRANSF=GAMMA*(GAMMA*PPBETA/(GAMMA+1.)+EPCM)
                 PPION(1,NNN,IRUN)=BETAX*TRANSF+PPX
                 PPION(2,NNN,IRUN)=BETAY*TRANSF+PPY
                 PPION(3,NNN,IRUN)=BETAZ*TRANSF+PPZ
 clin-5/2008:
                 dppion(nnn,irun)=dpertp(i1)*dpertp(i2)
 clin-5/2008 do not allow smearing in position of produced particles 
 c     to avoid immediate reinteraction with the particle I1, I2 or themselves:
 c2002        X01 = 1.0 - 2.0 * RANART(NSEED)
 c            Y01 = 1.0 - 2.0 * RANART(NSEED)
 c            Z01 = 1.0 - 2.0 * RANART(NSEED)
 c        IF ((X01*X01+Y01*Y01+Z01*Z01) .GT. 1.0) GOTO 2002
 c                RPION(1,NNN,IRUN)=R(1,I1)+0.5*x01
 c                RPION(2,NNN,IRUN)=R(2,I1)+0.5*y01
 c                RPION(3,NNN,IRUN)=R(3,I1)+0.5*z01
                 RPION(1,NNN,IRUN)=R(1,I1)
                 RPION(2,NNN,IRUN)=R(2,I1)
                 RPION(3,NNN,IRUN)=R(3,I1)
 c
               go to 90005
 clin-5/2008 N+N->Deuteron+pi:
 *     FIND MOMENTUM OF THE FINAL PARTICLES IN THE NUCLEUS-NUCLEUS CMS.
  108       CONTINUE
            if(idpert.eq.1.and.ipert1.eq.1.and.npertd.ge.1) then
 c     For idpert=1: we produce npertd pert deuterons:
               ndloop=npertd
            elseif(idpert.eq.2.and.npertd.ge.1) then
 c     For idpert=2: we first save information for npertd pert deuterons;
 c     at the last ndloop we create the regular deuteron+pi 
 c     and those pert deuterons:
               ndloop=npertd+1
            else
 c     Just create the regular deuteron+pi:
               ndloop=1
            endif
 c
            dprob1=sdprod/sig/float(npertd)
            do idloop=1,ndloop
               CALL bbdangle(pxd,pyd,pzd,nt,ipert1,ianti,idloop,pfinal,
      1 dprob1,lbm)
               CALL ROTATE(PX,PY,PZ,PXd,PYd,PZd)
 *     LORENTZ-TRANSFORMATION OF THE MOMENTUM OF PARTICLES IN THE FINAL STATE 
 *     FROM THE NN CMS FRAME INTO THE GLOBAL CMS FRAME:
 *     For the Deuteron:
               xmass=xmd
               E1dCM=SQRT(xmass**2+PXd**2+PYd**2+PZd**2)
               P1dBETA=PXd*BETAX+PYd*BETAY+PZd*BETAZ
               TRANSF=GAMMA*(GAMMA*P1dBETA/(GAMMA+1.)+E1dCM)
               pxi1=BETAX*TRANSF+PXd
               pyi1=BETAY*TRANSF+PYd
               pzi1=BETAZ*TRANSF+PZd
               if(ianti.eq.0)then
                  lbd=42
               else
                  lbd=-42
               endif
               if(idpert.eq.1.and.ipert1.eq.1.and.npertd.ge.1) then
 cccc  Perturbative production for idpert=1:
                  nnn=nnn+1
                  PPION(1,NNN,IRUN)=pxi1
                  PPION(2,NNN,IRUN)=pyi1
                  PPION(3,NNN,IRUN)=pzi1
                  EPION(NNN,IRUN)=xmd
                  LPION(NNN,IRUN)=lbd
                  RPION(1,NNN,IRUN)=R(1,I1)
                  RPION(2,NNN,IRUN)=R(2,I1)
                  RPION(3,NNN,IRUN)=R(3,I1)
 clin-5/2008 assign the perturbative probability:
                  dppion(NNN,IRUN)=sdprod/sig/float(npertd)
               elseif(idpert.eq.2.and.idloop.le.npertd) then
 clin-5/2008 For idpert=2, we produce NPERTD perturbative (anti)deuterons 
 c     only when a regular (anti)deuteron+pi is produced in NN collisions.
 c     First save the info for the perturbative deuterons:
                  ppd(1,idloop)=pxi1
                  ppd(2,idloop)=pyi1
                  ppd(3,idloop)=pzi1
                  lbpd(idloop)=lbd
               else
 cccc  Regular production:
 c     For the regular pion: do LORENTZ-TRANSFORMATION:
                  E(i1)=xmm
                  E2piCM=SQRT(xmm**2+PXd**2+PYd**2+PZd**2)
                  P2piBETA=-PXd*BETAX-PYd*BETAY-PZd*BETAZ
                  TRANSF=GAMMA*(GAMMA*P2piBETA/(GAMMA+1.)+E2piCM)
                  pxi2=BETAX*TRANSF-PXd
                  pyi2=BETAY*TRANSF-PYd
                  pzi2=BETAZ*TRANSF-PZd
                  p(1,i1)=pxi2
                  p(2,i1)=pyi2
                  p(3,i1)=pzi2
 c     Remove regular pion to check the equivalence 
 c     between the perturbative and regular deuteron results:
 c                 E(i1)=0.
 c
                  LB(I1)=lbm
                  PX1=P(1,I1)
                  PY1=P(2,I1)
                  PZ1=P(3,I1)
                  EM1=E(I1)
                  ID(I1)=2
                  ID1=ID(I1)
                  E1=SQRT(EM1**2+PX1**2+PY1**2+PZ1**2)
                  lb1=lb(i1)
 c     For the regular deuteron:
                  p(1,i2)=pxi1
                  p(2,i2)=pyi1
                  p(3,i2)=pzi1
                  lb(i2)=lbd
                  lb2=lb(i2)
                  E(i2)=xmd
                  EtI2=E(I2)
                  ID(I2)=2
 c     For idpert=2: create the perturbative deuterons:
                  if(idpert.eq.2.and.idloop.eq.ndloop) then
                     do ipertd=1,npertd
                        nnn=nnn+1
                        PPION(1,NNN,IRUN)=ppd(1,ipertd)
                        PPION(2,NNN,IRUN)=ppd(2,ipertd)
                        PPION(3,NNN,IRUN)=ppd(3,ipertd)
                        EPION(NNN,IRUN)=xmd
                        LPION(NNN,IRUN)=lbpd(ipertd)
                        RPION(1,NNN,IRUN)=R(1,I1)
                        RPION(2,NNN,IRUN)=R(2,I1)
                        RPION(3,NNN,IRUN)=R(3,I1)
 clin-5/2008 assign the perturbative probability:
                        dppion(NNN,IRUN)=1./float(npertd)
                     enddo
                  endif
               endif
            enddo
            IBLOCK=501
            go to 90005
 clin-5/2008 N+N->Deuteron+pi over
 * FOR THE NN-->KAON+X PROCESS, FIND MOMENTUM OF THE FINAL PARTICLES IN 
 * THE NUCLEUS-NUCLEUS CMS.
 306     CONTINUE
 csp11/21/01 phi production
               if(XSK5/sigK.gt.RANART(NSEED))then
               pz1=p(3,i1)
               pz2=p(3,i2)
                 LB(I1) = 1 + int(2 * RANART(NSEED))
                 LB(I2) = 1 + int(2 * RANART(NSEED))
               nnn=nnn+1
                 LPION(NNN,IRUN)=29
                 EPION(NNN,IRUN)=APHI
                 iblock = 222
               GO TO 208
                ENDIF
 c
                  IBLOCK=9
                  if(ianti .eq. 1)iblock=-9
 c
               pz1=p(3,i1)
               pz2=p(3,i2)
 * DETERMINE THE CHARGE STATES OF PARTICLES IN THE FINAL STATE
               nnn=nnn+1
                 LPION(NNN,IRUN)=23
                 EPION(NNN,IRUN)=Aka
               if(srt.le.2.63)then
 * only lambda production is possible
 * (1.1)P+P-->p+L+kaon+
               ic=1
                 LB(I1) = 1 + int(2 * RANART(NSEED))
               LB(I2)=14
               GO TO 208
                 ENDIF
        if(srt.le.2.74.and.srt.gt.2.63)then
 * both Lambda and sigma production are possible
               if(XSK1/(XSK1+XSK2).gt.RANART(NSEED))then
 * lambda production
               ic=1
                 LB(I1) = 1 + int(2 * RANART(NSEED))
               LB(I2)=14
               else
 * sigma production
                 LB(I1) = 1 + int(2 * RANART(NSEED))
                 LB(I2) = 15 + int(3 * RANART(NSEED))
               ic=2
               endif
               GO TO 208
        endif
        if(srt.le.2.77.and.srt.gt.2.74)then
 * then pp-->Delta lamda kaon can happen
               if(xsk1/(xsk1+xsk2+xsk3).
      1          gt.RANART(NSEED))then
 * * (1.1)P+P-->p+L+kaon+
               ic=1
                 LB(I1) = 1 + int(2 * RANART(NSEED))
               LB(I2)=14
               go to 208
               else
               if(xsk2/(xsk2+xsk3).gt.RANART(NSEED))then
 * pp-->psk
               ic=2
                 LB(I1) = 1 + int(2 * RANART(NSEED))
                 LB(I2) = 15 + int(3 * RANART(NSEED))
               else
 * pp-->D+l+k        
               ic=3
                 LB(I1) = 6 + int(4 * RANART(NSEED))
               lb(i2)=14
               endif
               GO TO 208
               endif
        endif
        if(srt.gt.2.77)then
 * all four channels are possible
               if(xsk1/(xsk1+xsk2+xsk3+xsk4).gt.RANART(NSEED))then
 * p lambda k production
               ic=1
                 LB(I1) = 1 + int(2 * RANART(NSEED))
               LB(I2)=14
               go to 208
        else
           if(xsk3/(xsk2+xsk3+xsk4).gt.RANART(NSEED))then
 * delta l K production
               ic=3
                 LB(I1) = 6 + int(4 * RANART(NSEED))
               lb(i2)=14
               go to 208
           else
               if(xsk2/(xsk2+xsk4).gt.RANART(NSEED))then
 * n sigma k production
                    LB(I1) = 1 + int(2 * RANART(NSEED))
                    LB(I2) = 15 + int(3 * RANART(NSEED))
               ic=2
               else
               ic=4
                 LB(I1) = 6 + int(4 * RANART(NSEED))
                 LB(I2) = 15 + int(3 * RANART(NSEED))
               endif
               go to 208
           endif
        endif
        endif
 208             continue
          if(ianti.eq.1 .and. lb(i1).ge.1 .and. lb(i2).ge.1)then
           lb(i1) = - lb(i1)
           lb(i2) = - lb(i2)
           if(LPION(NNN,IRUN) .eq. 23)LPION(NNN,IRUN)=21
          endif
 * KEEP ALL COORDINATES OF PARTICLE 2 FOR POSSIBLE PHASE SPACE CHANGE
            NTRY1=0
 127        CALL BBKAON(ic,SRT,PX3,PY3,PZ3,DM3,PX4,PY4,PZ4,DM4,
      &  PPX,PPY,PPZ,icou1)
        NTRY1=NTRY1+1
        if((icou1.lt.0).AND.(NTRY1.LE.20))GO TO 127
 c       if(icou1.lt.0)return
 * ROTATE THE MOMENTA OF PARTICLES IN THE CMS OF P1+P2
        CALL ROTATE(PX,PY,PZ,PX3,PY3,PZ3)
        CALL ROTATE(PX,PY,PZ,PX4,PY4,PZ4)
        CALL ROTATE(PX,PY,PZ,PPX,PPY,PPZ)
 * FIND THE MOMENTUM OF PARTICLES IN THE FINAL STATE IN THE NUCLEUS-
 * NUCLEUS CMS. FRAME 
 * (1) for the necleon/delta
 *             LORENTZ-TRANSFORMATION INTO LAB FRAME FOR DELTA1
               E1CM    = SQRT (dm3**2 + PX3**2 + PY3**2 + PZ3**2)
               P1BETA  = PX3*BETAX + PY3*BETAY + PZ3*BETAZ
               TRANSF  = GAMMA * ( GAMMA * P1BETA / (GAMMA + 1) + E1CM )
               Pt1i1 = BETAX * TRANSF + PX3
               Pt2i1 = BETAY * TRANSF + PY3
               Pt3i1 = BETAZ * TRANSF + PZ3
              Eti1   = DM3
              lbi1=lb(i1)
 * (2) for the lambda/sigma
                 E2CM    = SQRT (dm4**2 + PX4**2 + PY4**2 + PZ4**2)
                 P2BETA  = PX4*BETAX+PY4*BETAY+PZ4*BETAZ
                 TRANSF  = GAMMA * (GAMMA*P2BETA / (GAMMA + 1.) + E2CM)
                 Pt1I2 = BETAX * TRANSF + PX4
                 Pt2I2 = BETAY * TRANSF + PY4
                 Pt3I2 = BETAZ * TRANSF + PZ4
               EtI2   = DM4
               lbi2=lb(i2)
 * GET the kaon'S MOMENTUM AND COORDINATES IN NUCLEUS-NUCLEUS CMS. FRAME
                 EPCM=SQRT(aka**2+PPX**2+PPY**2+PPZ**2)
                 PPBETA=PPX*BETAX+PPY*BETAY+PPZ*BETAZ
                 TRANSF=GAMMA*(GAMMA*PPBETA/(GAMMA+1.)+EPCM)
                 PPION(1,NNN,IRUN)=BETAX*TRANSF+PPX
                 PPION(2,NNN,IRUN)=BETAY*TRANSF+PPY
                 PPION(3,NNN,IRUN)=BETAZ*TRANSF+PPZ
 clin-5/2008
                 dppion(nnn,irun)=dpertp(i1)*dpertp(i2)
 clin-5/2008
 c2003        X01 = 1.0 - 2.0 * RANART(NSEED)
 c            Y01 = 1.0 - 2.0 * RANART(NSEED)
 c            Z01 = 1.0 - 2.0 * RANART(NSEED)
 c        IF ((X01*X01+Y01*Y01+Z01*Z01) .GT. 1.0) GOTO 2003
 c                RPION(1,NNN,IRUN)=R(1,I1)+0.5*x01
 c                RPION(2,NNN,IRUN)=R(2,I1)+0.5*y01
 c                RPION(3,NNN,IRUN)=R(3,I1)+0.5*z01
                 RPION(1,NNN,IRUN)=R(1,I1)
                 RPION(2,NNN,IRUN)=R(2,I1)
                 RPION(3,NNN,IRUN)=R(3,I1)
 c
 * assign the nucleon/delta and lambda/sigma to i1 or i2 to keep the 
 * leadng particle behaviour
 C              if((pt1i1*px1+pt2i1*py1+pt3i1*pz1).gt.0)then
               p(1,i1)=pt1i1
               p(2,i1)=pt2i1
               p(3,i1)=pt3i1
               e(i1)=eti1
               lb(i1)=lbi1
               p(1,i2)=pt1i2
               p(2,i2)=pt2i2
               p(3,i2)=pt3i2
               e(i2)=eti2
               lb(i2)=lbi2
                 PX1     = P(1,I1)
                 PY1     = P(2,I1)
                 PZ1     = P(3,I1)
               EM1       = E(I1)
                 ID(I1)  = 2
                 ID(I2)  = 2
                 ID1     = ID(I1)
               go to 90005
 * FOR THE NN-->Delta+Delta+rho PROCESS, FIND MOMENTUM OF THE FINAL 
 * PARTICLES IN THE NUCLEUS-NUCLEUS CMS.
 307     CONTINUE
            NTRY1=0
 125        CALL DDrho(SRT,ISEED,PX3,PY3,PZ3,DM3,PX4,PY4,PZ4,DM4,
      &  PPX,PPY,PPZ,amrho,icou1)
        NTRY1=NTRY1+1
        if((icou1.lt.0).AND.(NTRY1.LE.20))GO TO 125
 C       if(icou1.lt.0)return
 * ROTATE THE MOMENTA OF PARTICLES IN THE CMS OF P1+P2
        CALL ROTATE(PX,PY,PZ,PX3,PY3,PZ3)
        CALL ROTATE(PX,PY,PZ,PX4,PY4,PZ4)
        CALL ROTATE(PX,PY,PZ,PPX,PPY,PPZ)
                 NNN=NNN+1
               arho=amrho
 * DETERMINE THE CHARGE STATES OF PARTICLES IN THE FINAL STATE
 * (1) FOR P+P
               XDIR=RANART(NSEED)
                 IF(LB(I1)*LB(I2).EQ.1)THEN
                 IF(XDIR.Le.0.2)then
 * (1.1)P+P-->D+++D0+rho(0)
                 LPION(NNN,IRUN)=26
                 EPION(NNN,IRUN)=Arho
               LB(I1)=9
               LB(I2)=7
        GO TO 2051
                 ENDIF
 * (1.2)P+P -->D++D+rho(0)
                 IF((XDIR.LE.0.4).AND.(XDIR.GT.0.2))THEN
                 LPION(NNN,IRUN)=26
                 EPION(NNN,IRUN)=Arho
                 LB(I1)=8
                 LB(I2)=8
        GO TO 2051
               ENDIF 
 * (1.3)P+P-->D+++D+arho(-)
                 IF((XDIR.LE.0.6).AND.(XDIR.GT.0.4))THEN
                 LPION(NNN,IRUN)=25
                 EPION(NNN,IRUN)=Arho
                 LB(I1)=9
                 LB(I2)=8
        GO TO 2051
               ENDIF 
                 IF((XDIR.LE.0.8).AND.(XDIR.GT.0.6))THEN
                 LPION(NNN,IRUN)=27
                 EPION(NNN,IRUN)=Arho
                 LB(I1)=9
                 LB(I2)=6
        GO TO 2051
               ENDIF 
                 IF(XDIR.GT.0.8)THEN
                 LPION(NNN,IRUN)=27
                 EPION(NNN,IRUN)=Arho
                 LB(I1)=7
                 LB(I2)=8
        GO TO 2051
               ENDIF 
                ENDIF
 * (2)FOR N+N
                 IF(iabs(LB(I1)).EQ.2.AND.iabs(LB(I2)).EQ.2)THEN
                 IF(XDIR.Le.0.2)then
 * (2.1)N+N-->D++D-+rho(0)
                 LPION(NNN,IRUN)=26
                 EPION(NNN,IRUN)=Arho
               LB(I1)=6
               LB(I2)=7
        GO TO 2051
                 ENDIF
 * (2.2)N+N -->D+++D-+rho(-)
                 IF((XDIR.LE.0.4).AND.(XDIR.GT.0.2))THEN
                 LPION(NNN,IRUN)=25
                 EPION(NNN,IRUN)=Arho
                 LB(I1)=6
                 LB(I2)=9
        GO TO 2051
               ENDIF 
 * (2.3)P+P-->D0+D-+rho(+)
                 IF((XDIR.GT.0.4).AND.(XDIR.LE.0.6))THEN
                 LPION(NNN,IRUN)=27
                 EPION(NNN,IRUN)=Arho
                 LB(I1)=9
                 LB(I2)=8
        GO TO 2051
               ENDIF 
 * (2.4)P+P-->D0+D0+rho(0)
                 IF((XDIR.GT.0.6).AND.(XDIR.LE.0.8))THEN
                 LPION(NNN,IRUN)=26
                 EPION(NNN,IRUN)=Arho
                 LB(I1)=7
                 LB(I2)=7
        GO TO 2051
               ENDIF 
 * (2.5)P+P-->D0+D++rho(-)
                 IF(XDIR.GT.0.8)THEN
                 LPION(NNN,IRUN)=25
                 EPION(NNN,IRUN)=Arho
                 LB(I1)=7
                 LB(I2)=8
        GO TO 2051
               ENDIF 
               ENDIF
 * (3)FOR N+P
                 IF(LB(I1)*LB(I2).EQ.2)THEN
                 IF(XDIR.Le.0.17)then
 * (3.1)N+P-->D+++D-+rho(0)
                 LPION(NNN,IRUN)=25
                 EPION(NNN,IRUN)=Arho
               LB(I1)=6
               LB(I2)=9
        GO TO 2051
                 ENDIF
 * (3.2)N+P -->D+++D0+rho(-)
                 IF((XDIR.LE.0.34).AND.(XDIR.GT.0.17))THEN
                 LPION(NNN,IRUN)=25
                 EPION(NNN,IRUN)=Arho
                 LB(I1)=7
                 LB(I2)=9
        GO TO 2051
               ENDIF 
 * (3.3)N+P-->D++D-+rho(+)
                 IF((XDIR.GT.0.34).AND.(XDIR.LE.0.51))THEN
                 LPION(NNN,IRUN)=27
                 EPION(NNN,IRUN)=Arho
                 LB(I1)=7
                 LB(I2)=8
        GO TO 2051
               ENDIF 
 * (3.4)N+P-->D++D++rho(-)
                 IF((XDIR.GT.0.51).AND.(XDIR.LE.0.68))THEN
                 LPION(NNN,IRUN)=25
                 EPION(NNN,IRUN)=Arho
                 LB(I1)=8
                 LB(I2)=8
        GO TO 2051
               ENDIF 
 * (3.5)N+P-->D0+D++rho(0)
                 IF((XDIR.GT.0.68).AND.(XDIR.LE.0.85))THEN
                 LPION(NNN,IRUN)=26
                 EPION(NNN,IRUN)=Arho
                 LB(I1)=7
                 LB(I2)=8
        GO TO 2051
               ENDIF 
 * (3.6)N+P-->D0+D0+rho(+)
                 IF(XDIR.GT.0.85)THEN
                 LPION(NNN,IRUN)=27
                 EPION(NNN,IRUN)=Arho
                 LB(I1)=7
                 LB(I2)=7
               ENDIF 
                 ENDIF
 * FIND THE MOMENTUM OF PARTICLES IN THE FINAL STATE IN THE NUCLEUS-
 * NUCLEUS CMS. FRAME 
 *             LORENTZ-TRANSFORMATION INTO LAB FRAME FOR DELTA1
 2051          E1CM    = SQRT (dm3**2 + PX3**2 + PY3**2 + PZ3**2)
               P1BETA  = PX3*BETAX + PY3*BETAY + PZ3*BETAZ
               TRANSF  = GAMMA * ( GAMMA * P1BETA / (GAMMA + 1) + E1CM )
               Pt1i1 = BETAX * TRANSF + PX3
               Pt2i1 = BETAY * TRANSF + PY3
               Pt3i1 = BETAZ * TRANSF + PZ3
              Eti1   = DM3
 c
              if(ianti.eq.1 .and. lb(i1).ge.1 .and. lb(i2).ge.1)then
                lb(i1) = -lb(i1)
                lb(i2) = -lb(i2)
                 if(LPION(NNN,IRUN) .eq. 25)then
                   LPION(NNN,IRUN)=27
                 elseif(LPION(NNN,IRUN) .eq. 27)then
                   LPION(NNN,IRUN)=25
                 endif
                endif
 c
              lb1=lb(i1)
 * FOR DELTA2
                 E2CM    = SQRT (dm4**2 + PX4**2 + PY4**2 + PZ4**2)
                 P2BETA  = PX4*BETAX+PY4*BETAY+PZ4*BETAZ
                 TRANSF  = GAMMA * (GAMMA*P2BETA / (GAMMA + 1.) + E2CM)
                 Pt1I2 = BETAX * TRANSF + PX4
                 Pt2I2 = BETAY * TRANSF + PY4
                 Pt3I2 = BETAZ * TRANSF + PZ4
               EtI2   = DM4
               lb2=lb(i2)
 * assign delta1 and delta2 to i1 or i2 to keep the leadng particle
 * behaviour
 C              if((pt1i1*px1+pt2i1*py1+pt3i1*pz1).gt.0)then
               p(1,i1)=pt1i1
               p(2,i1)=pt2i1
               p(3,i1)=pt3i1
               e(i1)=eti1
               lb(i1)=lb1
               p(1,i2)=pt1i2
               p(2,i2)=pt2i2
               p(3,i2)=pt3i2
               e(i2)=eti2
               lb(i2)=lb2
                 PX1     = P(1,I1)
                 PY1     = P(2,I1)
                 PZ1     = P(3,I1)
               EM1       = E(I1)
                 ID(I1)  = 2
                 ID(I2)  = 2
                 ID1     = ID(I1)
                 IBLOCK=44
 * GET rho'S MOMENTUM AND COORDINATES IN NUCLEUS-NUCLEUS CMS. FRAME
                 EPCM=SQRT(EPION(NNN,IRUN)**2+PPX**2+PPY**2+PPZ**2)
                 PPBETA=PPX*BETAX+PPY*BETAY+PPZ*BETAZ
                 TRANSF=GAMMA*(GAMMA*PPBETA/(GAMMA+1.)+EPCM)
                 PPION(1,NNN,IRUN)=BETAX*TRANSF+PPX
                 PPION(2,NNN,IRUN)=BETAY*TRANSF+PPY
                 PPION(3,NNN,IRUN)=BETAZ*TRANSF+PPZ
 clin-5/2008:
                 dppion(nnn,irun)=dpertp(i1)*dpertp(i2)
 clin-5/2008:
 c2004        X01 = 1.0 - 2.0 * RANART(NSEED)
 c            Y01 = 1.0 - 2.0 * RANART(NSEED)
 c            Z01 = 1.0 - 2.0 * RANART(NSEED)
 c        IF ((X01*X01+Y01*Y01+Z01*Z01) .GT. 1.0) GOTO 2004
 c                RPION(1,NNN,IRUN)=R(1,I1)+0.5*x01
 c                RPION(2,NNN,IRUN)=R(2,I1)+0.5*y01
 c                RPION(3,NNN,IRUN)=R(3,I1)+0.5*z01
                 RPION(1,NNN,IRUN)=R(1,I1)
                 RPION(2,NNN,IRUN)=R(2,I1)
                 RPION(3,NNN,IRUN)=R(3,I1)
 c
               go to 90005
 * FOR THE NN-->N+N+rho PROCESS, FIND MOMENTUM OF THE FINAL 
 * PARTICLES IN THE NUCLEUS-NUCLEUS CMS.
 308     CONTINUE
            NTRY1=0
 126        CALL pprho(SRT,ISEED,PX3,PY3,PZ3,DM3,PX4,PY4,PZ4,DM4,
      &  PPX,PPY,PPZ,amrho,icou1)
        NTRY1=NTRY1+1
        if((icou1.lt.0).AND.(NTRY1.LE.20))GO TO 126
 C       if(icou1.lt.0)return
 * ROTATE THE MOMENTA OF PARTICLES IN THE CMS OF P1+P2
        CALL ROTATE(PX,PY,PZ,PX3,PY3,PZ3)
        CALL ROTATE(PX,PY,PZ,PX4,PY4,PZ4)
        CALL ROTATE(PX,PY,PZ,PPX,PPY,PPZ)
                 NNN=NNN+1
               arho=amrho
 * DETERMINE THE CHARGE STATES OF PARTICLES IN THE FINAL STATE
 * (1) FOR P+P
               XDIR=RANART(NSEED)
                 IF(LB(I1)*LB(I2).EQ.1)THEN
                 IF(XDIR.Le.0.5)then
 * (1.1)P+P-->P+P+rho(0)
                 LPION(NNN,IRUN)=26
                 EPION(NNN,IRUN)=Arho
               LB(I1)=1
               LB(I2)=1
        GO TO 2052
                 Else
 * (1.2)P+P -->p+n+rho(+)
                 LPION(NNN,IRUN)=27
                 EPION(NNN,IRUN)=Arho
                 LB(I1)=1
                 LB(I2)=2
        GO TO 2052
               ENDIF 
               endif
 * (2)FOR N+N
                 IF(iabs(LB(I1)).EQ.2.AND.iabs(LB(I2)).EQ.2)THEN
                 IF(XDIR.Le.0.5)then
 * (2.1)N+N-->N+N+rho(0)
                 LPION(NNN,IRUN)=26
                 EPION(NNN,IRUN)=Arho
               LB(I1)=2
               LB(I2)=2
        GO TO 2052
                 Else
 * (2.2)N+N -->N+P+rho(-)
                 LPION(NNN,IRUN)=25
                 EPION(NNN,IRUN)=Arho
                 LB(I1)=1
                 LB(I2)=2
        GO TO 2052
               ENDIF 
               endif
 * (3)FOR N+P
                 IF(LB(I1)*LB(I2).EQ.2)THEN
                 IF(XDIR.Le.0.33)then
 * (3.1)N+P-->N+P+rho(0)
                 LPION(NNN,IRUN)=26
                 EPION(NNN,IRUN)=Arho
               LB(I1)=1
               LB(I2)=2
        GO TO 2052
 * (3.2)N+P -->P+P+rho(-)
                 else IF((XDIR.LE.0.67).AND.(XDIR.GT.0.34))THEN
                 LPION(NNN,IRUN)=25
                 EPION(NNN,IRUN)=Arho
                 LB(I1)=1
                 LB(I2)=1
        GO TO 2052
               Else 
 * (3.3)N+P-->N+N+rho(+)
                 LPION(NNN,IRUN)=27
                 EPION(NNN,IRUN)=Arho
                 LB(I1)=2
                 LB(I2)=2
        GO TO 2052
               ENDIF 
               endif
 * FIND THE MOMENTUM OF PARTICLES IN THE FINAL STATE IN THE NUCLEUS-
 * NUCLEUS CMS. FRAME 
 *             LORENTZ-TRANSFORMATION INTO LAB FRAME FOR DELTA1
 2052          E1CM    = SQRT (dm3**2 + PX3**2 + PY3**2 + PZ3**2)
               P1BETA  = PX3*BETAX + PY3*BETAY + PZ3*BETAZ
               TRANSF  = GAMMA * ( GAMMA * P1BETA / (GAMMA + 1) + E1CM )
               Pt1i1 = BETAX * TRANSF + PX3
               Pt2i1 = BETAY * TRANSF + PY3
               Pt3i1 = BETAZ * TRANSF + PZ3
              Eti1   = DM3
 c
               if(ianti.eq.1 .and. lb(i1).ge.1 .and. lb(i2).ge.1)then
                lb(i1) = -lb(i1)
                lb(i2) = -lb(i2)
                 if(LPION(NNN,IRUN) .eq. 25)then
                   LPION(NNN,IRUN)=27
                 elseif(LPION(NNN,IRUN) .eq. 27)then
                   LPION(NNN,IRUN)=25
                 endif
                endif
 c
              lb1=lb(i1)
 * FOR p2
                 E2CM    = SQRT (dm4**2 + PX4**2 + PY4**2 + PZ4**2)
                 P2BETA  = PX4*BETAX+PY4*BETAY+PZ4*BETAZ
                 TRANSF  = GAMMA * (GAMMA*P2BETA / (GAMMA + 1.) + E2CM)
                 Pt1I2 = BETAX * TRANSF + PX4
                 Pt2I2 = BETAY * TRANSF + PY4
                 Pt3I2 = BETAZ * TRANSF + PZ4
               EtI2   = DM4
               lb2=lb(i2)
 * assign p1 and p2 to i1 or i2 to keep the leadng particle
 * behaviour
 C              if((pt1i1*px1+pt2i1*py1+pt3i1*pz1).gt.0)then
               p(1,i1)=pt1i1
               p(2,i1)=pt2i1
               p(3,i1)=pt3i1
               e(i1)=eti1
               lb(i1)=lb1
               p(1,i2)=pt1i2
               p(2,i2)=pt2i2
               p(3,i2)=pt3i2
               e(i2)=eti2
               lb(i2)=lb2
                 PX1     = P(1,I1)
                 PY1     = P(2,I1)
                 PZ1     = P(3,I1)
               EM1       = E(I1)
                 ID(I1)  = 2
                 ID(I2)  = 2
                 ID1     = ID(I1)
                 IBLOCK=45
 * GET rho'S MOMENTUM AND COORDINATES IN NUCLEUS-NUCLEUS CMS. FRAME
                 EPCM=SQRT(EPION(NNN,IRUN)**2+PPX**2+PPY**2+PPZ**2)
                 PPBETA=PPX*BETAX+PPY*BETAY+PPZ*BETAZ
                 TRANSF=GAMMA*(GAMMA*PPBETA/(GAMMA+1.)+EPCM)
                 PPION(1,NNN,IRUN)=BETAX*TRANSF+PPX
                 PPION(2,NNN,IRUN)=BETAY*TRANSF+PPY
                 PPION(3,NNN,IRUN)=BETAZ*TRANSF+PPZ
 clin-5/2008:
                 dppion(nnn,irun)=dpertp(i1)*dpertp(i2)
 clin-5/2008:
 c2005        X01 = 1.0 - 2.0 * RANART(NSEED)
 c            Y01 = 1.0 - 2.0 * RANART(NSEED)
 c            Z01 = 1.0 - 2.0 * RANART(NSEED)
 c        IF ((X01*X01+Y01*Y01+Z01*Z01) .GT. 1.0) GOTO 2005
 c                RPION(1,NNN,IRUN)=R(1,I1)+0.5*x01
 c                RPION(2,NNN,IRUN)=R(2,I1)+0.5*y01
 c                RPION(3,NNN,IRUN)=R(3,I1)+0.5*z01
                 RPION(1,NNN,IRUN)=R(1,I1)
                 RPION(2,NNN,IRUN)=R(2,I1)
                 RPION(3,NNN,IRUN)=R(3,I1)
 c
               go to 90005
 * FOR THE NN-->p+p+omega PROCESS, FIND MOMENTUM OF THE FINAL 
 * PARTICLES IN THE NUCLEUS-NUCLEUS CMS.
 309     CONTINUE
            NTRY1=0
 138        CALL ppomga(SRT,ISEED,PX3,PY3,PZ3,DM3,PX4,PY4,PZ4,DM4,
      &  PPX,PPY,PPZ,icou1)
        NTRY1=NTRY1+1
        if((icou1.lt.0).AND.(NTRY1.LE.20))GO TO 138
 C       if(icou1.lt.0)return
 * ROTATE THE MOMENTA OF PARTICLES IN THE CMS OF P1+P2
        CALL ROTATE(PX,PY,PZ,PX3,PY3,PZ3)
        CALL ROTATE(PX,PY,PZ,PX4,PY4,PZ4)
        CALL ROTATE(PX,PY,PZ,PPX,PPY,PPZ)
                 NNN=NNN+1
               aomega=0.782
 * DETERMINE THE CHARGE STATES OF PARTICLES IN THE FINAL STATE
 * (1) FOR P+P
                 IF(LB(I1)*LB(I2).EQ.1)THEN
 * (1.1)P+P-->P+P+omega(0)
                 LPION(NNN,IRUN)=28
                 EPION(NNN,IRUN)=Aomega
               LB(I1)=1
               LB(I2)=1
        GO TO 2053
                 ENDIF
 * (2)FOR N+N
                 IF(iabs(LB(I1)).EQ.2.AND.iabs(LB(I2)).EQ.2)THEN
 * (2.1)N+N-->N+N+omega(0)
                 LPION(NNN,IRUN)=28
                 EPION(NNN,IRUN)=Aomega
               LB(I1)=2
               LB(I2)=2
        GO TO 2053
                 ENDIF
 * (3)FOR N+P
                 IF(LB(I1)*LB(I2).EQ.2)THEN
 * (3.1)N+P-->N+P+omega(0)
                 LPION(NNN,IRUN)=28
                 EPION(NNN,IRUN)=Aomega
               LB(I1)=1
               LB(I2)=2
        GO TO 2053
                 ENDIF
 * FIND THE MOMENTUM OF PARTICLES IN THE FINAL STATE IN THE NUCLEUS-
 * NUCLEUS CMS. FRAME 
 *             LORENTZ-TRANSFORMATION INTO LAB FRAME FOR DELTA1
 2053          E1CM    = SQRT (dm3**2 + PX3**2 + PY3**2 + PZ3**2)
               P1BETA  = PX3*BETAX + PY3*BETAY + PZ3*BETAZ
               TRANSF  = GAMMA * ( GAMMA * P1BETA / (GAMMA + 1) + E1CM )
               Pt1i1 = BETAX * TRANSF + PX3
               Pt2i1 = BETAY * TRANSF + PY3
               Pt3i1 = BETAZ * TRANSF + PZ3
              Eti1   = DM3
               if(ianti.eq.1 .and. lb(i1).ge.1 .and. lb(i2).ge.1)then
                lb(i1) = -lb(i1)
                lb(i2) = -lb(i2)
                endif
              lb1=lb(i1)
 * FOR DELTA2
                 E2CM    = SQRT (dm4**2 + PX4**2 + PY4**2 + PZ4**2)
                 P2BETA  = PX4*BETAX+PY4*BETAY+PZ4*BETAZ
                 TRANSF  = GAMMA * (GAMMA*P2BETA / (GAMMA + 1.) + E2CM)
                 Pt1I2 = BETAX * TRANSF + PX4
                 Pt2I2 = BETAY * TRANSF + PY4
                 Pt3I2 = BETAZ * TRANSF + PZ4
               EtI2   = DM4
                 lb2=lb(i2)
 * assign delta1 and delta2 to i1 or i2 to keep the leadng particle
 * behaviour
 C              if((pt1i1*px1+pt2i1*py1+pt3i1*pz1).gt.0)then
               p(1,i1)=pt1i1
               p(2,i1)=pt2i1
               p(3,i1)=pt3i1
               e(i1)=eti1
               lb(i1)=lb1
               p(1,i2)=pt1i2
               p(2,i2)=pt2i2
               p(3,i2)=pt3i2
               e(i2)=eti2
               lb(i2)=lb2
                 PX1     = P(1,I1)
                 PY1     = P(2,I1)
                 PZ1     = P(3,I1)
               EM1       = E(I1)
                 ID(I1)  = 2
                 ID(I2)  = 2
                 ID1     = ID(I1)
                 IBLOCK=46
 * GET omega'S MOMENTUM AND COORDINATES IN NUCLEUS-NUCLEUS CMS. FRAME
                 EPCM=SQRT(EPION(NNN,IRUN)**2+PPX**2+PPY**2+PPZ**2)
                 PPBETA=PPX*BETAX+PPY*BETAY+PPZ*BETAZ
                 TRANSF=GAMMA*(GAMMA*PPBETA/(GAMMA+1.)+EPCM)
                 PPION(1,NNN,IRUN)=BETAX*TRANSF+PPX
                 PPION(2,NNN,IRUN)=BETAY*TRANSF+PPY
                 PPION(3,NNN,IRUN)=BETAZ*TRANSF+PPZ
 clin-5/2008:
                 dppion(nnn,irun)=dpertp(i1)*dpertp(i2)
 clin-5/2008:
 c2006        X01 = 1.0 - 2.0 * RANART(NSEED)
 c            Y01 = 1.0 - 2.0 * RANART(NSEED)
 c            Z01 = 1.0 - 2.0 * RANART(NSEED)
 c        IF ((X01*X01+Y01*Y01+Z01*Z01) .GT. 1.0) GOTO 2006
 c                RPION(1,NNN,IRUN)=R(1,I1)+0.5*x01
 c                RPION(2,NNN,IRUN)=R(2,I1)+0.5*y01
 c                RPION(3,NNN,IRUN)=R(3,I1)+0.5*z01
                     RPION(1,NNN,IRUN)=R(1,I1)
                     RPION(2,NNN,IRUN)=R(2,I1)
                     RPION(3,NNN,IRUN)=R(3,I1)
 c
               go to 90005
 * change phase space density FOR NUCLEONS AFTER THE PROCESS
 
 clin-10/25/02-comment out following, since there is no path to it:
 clin-8/16/02 used before set
 c     IX1,IY1,IZ1,IPX1,IPY1,IPZ1, IX2,IY2,IZ2,IPX2,IPY2,IPZ2:
 c                if ((abs(ix1).le.mx) .and. (abs(iy1).le.my) .and.
 c     &              (abs(iz1).le.mz)) then
 c                  ipx1p = nint(p(1,i1)/dpx)
 c                  ipy1p = nint(p(2,i1)/dpy)
 c                  ipz1p = nint(p(3,i1)/dpz)
 c                  if ((ipx1p.ne.ipx1) .or. (ipy1p.ne.ipy1) .or.
 c     &                (ipz1p.ne.ipz1)) then
 c                    if ((abs(ipx1).le.mpx) .and. (abs(ipy1).le.my)
 c     &                .and. (ipz1.ge.-mpz) .and. (ipz1.le.mpzp))
 c     &                f(ix1,iy1,iz1,ipx1,ipy1,ipz1) =
 c     &                f(ix1,iy1,iz1,ipx1,ipy1,ipz1) - 1.
 c                    if ((abs(ipx1p).le.mpx) .and. (abs(ipy1p).le.my)
 c     &                .and. (ipz1p.ge.-mpz).and. (ipz1p.le.mpzp))
 c     &                f(ix1,iy1,iz1,ipx1p,ipy1p,ipz1p) =
 c     &                f(ix1,iy1,iz1,ipx1p,ipy1p,ipz1p) + 1.
 c                  end if
 c                end if
 c                if ((abs(ix2).le.mx) .and. (abs(iy2).le.my) .and.
 c     &              (abs(iz2).le.mz)) then
 c                  ipx2p = nint(p(1,i2)/dpx)
 c                  ipy2p = nint(p(2,i2)/dpy)
 c                  ipz2p = nint(p(3,i2)/dpz)
 c                  if ((ipx2p.ne.ipx2) .or. (ipy2p.ne.ipy2) .or.
 c     &                (ipz2p.ne.ipz2)) then
 c                    if ((abs(ipx2).le.mpx) .and. (abs(ipy2).le.my)
 c     &                .and. (ipz2.ge.-mpz) .and. (ipz2.le.mpzp))
 c     &                f(ix2,iy2,iz2,ipx2,ipy2,ipz2) =
 c     &                f(ix2,iy2,iz2,ipx2,ipy2,ipz2) - 1.
 c                    if ((abs(ipx2p).le.mpx) .and. (abs(ipy2p).le.my)
 c     &                .and. (ipz2p.ge.-mpz) .and. (ipz2p.le.mpzp))
 c     &                f(ix2,iy2,iz2,ipx2p,ipy2p,ipz2p) =
 c     &                f(ix2,iy2,iz2,ipx2p,ipy2p,ipz2p) + 1.
 c                  end if
 c                end if
 clin-10/25/02-end
 
 90005       continue
        RETURN
 *-----------------------------------------------------------------------
 *COM: SET THE NEW MOMENTUM COORDINATES
 107     IF(PX .EQ. 0.0 .AND. PY .EQ. 0.0) THEN
         T2 = 0.0
       ELSE
         T2=ATAN2(PY,PX)
       END IF
       S1   = 1.0 - C1**2 
        IF(S1.LE.0)S1=0
        S1=SQRT(S1)
 
 clin-9/2012: check argument in sqrt():
        scheck=1.0 - C2**2
        if(scheck.lt.0) then
           write(99,*) 'scheck3: ', scheck
           scheck=0.
        endif
        S2=SQRT(scheck)
 c       S2  =  SQRT( 1.0 - C2**2 )
 
       CT1  = COS(T1)
       ST1  = SIN(T1)
       CT2  = COS(T2)
       ST2  = SIN(T2)
       PZ   = PR * ( C1*C2 - S1*S2*CT1 )
       SS   = C2 * S1 * CT1  +  S2 * C1
       PX   = PR * ( SS*CT2 - S1*ST1*ST2 )
       PY   = PR * ( SS*ST2 + S1*ST1*CT2 )
       RETURN
       END
 clin-5/2008 CRNN over
 
 **********************************
 **********************************
 *                                                                      *
 *                                                                      *
 c
       SUBROUTINE CRPP(PX,PY,PZ,SRT,I1,I2,IBLOCK,
      &ppel,ppin,spprho,ipp)
 *     PURPOSE:                                                         *
 *             DEALING WITH PION-PION COLLISIONS                        *
 *     NOTE   :                                                         *
 *           VALID ONLY FOR PION-PION-DISTANCES LESS THAN 2.5 FM        *
 *     QUANTITIES:                                                 *
 *           PX,PY,PZ - MOMENTUM COORDINATES OF ONE PARTICLE IN CM FRAME*
 *           SRT      - SQRT OF S                                       *
 *           IBLOCK   - THE INFORMATION BACK                            *
 *                     6-> Meson+Meson elastic
 *                     66-> Meson+meson-->K+K-
 **********************************
       PARAMETER (MAXSTR=150001,MAXR=1,AMN=0.939457,
      1     AMP=0.93828,AP1=0.13496,
      2 AP2=0.13957,AM0=1.232,PI=3.1415926,CUTOFF=1.8966,AVMASS=0.9383)
       PARAMETER      (AKA=0.498,aks=0.895)
       parameter     (MX=4,MY=4,MZ=8,MPX=4,MPY=4,mpz=10,mpzp=10)
       COMMON /AA/ R(3,MAXSTR)
 cc      SAVE /AA/
       COMMON /BB/ P(3,MAXSTR)
 cc      SAVE /BB/
       COMMON /CC/ E(MAXSTR)
 cc      SAVE /CC/
       COMMON /EE/ ID(MAXSTR),LB(MAXSTR)
 cc      SAVE /EE/
       common/input1/ MASSPR,MASSTA,ISEED,IAVOID,DT
 cc      SAVE /input1/
       common/ppb1/ene,factr2(6),fsum,ppinnb,s,wtot
 cc      SAVE /ppb1/
       common/ppmm/pprr,ppee,pppe,rpre,xopoe,rree
 cc      SAVE /ppmm/
       COMMON/RNDF77/NSEED
 cc      SAVE /RNDF77/
       SAVE   
 
       lb1i=lb(i1)
       lb2i=lb(i2)
 
        PX0=PX
        PY0=PY
        PZ0=PZ
         iblock=1
 *-----------------------------------------------------------------------
 * check Meson+Meson inelastic collisions
 clin-9/28/00
 c        if((srt.gt.1.).and.(ppin/(ppin+ppel).gt.RANART(NSEED)))then
 c        iblock=66
 c        e(i1)=0.498
 c        e(i2)=0.498
 c        lb(i1)=21
 c        lb(i2)=23
 c        go to 10
 clin-11/07/00
 c        if(srt.gt.1.and.(ppin/(ppin+ppel)).gt.RANART(NSEED)) then
 clin-4/03/02
         if(srt.gt.(2*aka).and.(ppin/(ppin+ppel)).gt.RANART(NSEED)) then
 c        if(ppin/(ppin+ppel).gt.RANART(NSEED)) then
 clin-10/08/00
 
            ranpi=RANART(NSEED)
            if((pprr/ppin).ge.ranpi) then
 
 c     1) pi pi <-> rho rho:
               call pi2ro2(i1,i2,lbb1,lbb2,ei1,ei2,iblock,iseed)
 
 clin-4/03/02 eta equilibration:
            elseif((pprr+ppee)/ppin.ge.ranpi) then
 c     4) pi pi <-> eta eta:
               call pi2et2(i1,i2,lbb1,lbb2,ei1,ei2,iblock,iseed)
            elseif(((pprr+ppee+pppe)/ppin).ge.ranpi) then
 c     5) pi pi <-> pi eta:
               call pi3eta(i1,i2,lbb1,lbb2,ei1,ei2,iblock,iseed)
            elseif(((pprr+ppee+pppe+rpre)/ppin).ge.ranpi) then
 c     6) rho pi <-> pi eta:
               call rpiret(i1,i2,lbb1,lbb2,ei1,ei2,iblock,iseed)
            elseif(((pprr+ppee+pppe+rpre+xopoe)/ppin).ge.ranpi) then
 c     7) omega pi <-> omega eta:
               call opioet(i1,i2,lbb1,lbb2,ei1,ei2,iblock,iseed)
            elseif(((pprr+ppee+pppe+rpre+xopoe+rree)
      1             /ppin).ge.ranpi) then
 c     8) rho rho <-> eta eta:
               call ro2et2(i1,i2,lbb1,lbb2,ei1,ei2,iblock,iseed)
 clin-4/03/02-end
 
 c     2) BBbar production:
            elseif(((pprr+ppee+pppe+rpre+xopoe+rree+ppinnb)/ppin)
      1             .ge.ranpi) then
 
               call bbarfs(lbb1,lbb2,ei1,ei2,iblock,iseed)
 c     3) KKbar production:
            else
               iblock=66
               ei1=aka
               ei2=aka
               lbb1=21
               lbb2=23
 clin-11/07/00 pi rho -> K* Kbar and K*bar K productions:
               lb1=lb(i1)
               lb2=lb(i2)
 clin-2/13/03 include omega the same as rho, eta the same as pi:
 c        if(((lb1.ge.3.and.lb1.le.5).and.(lb2.ge.25.and.lb2.le.27))
 c     1  .or.((lb2.ge.3.and.lb2.le.5).and.(lb1.ge.25.and.lb1.le.27)))
         if( ( (lb1.eq.0.or.(lb1.ge.3.and.lb1.le.5))
      1       .and.(lb2.ge.25.and.lb2.le.28))
      2       .or. ( (lb2.eq.0.or.(lb2.ge.3.and.lb2.le.5))
      3       .and.(lb1.ge.25.and.lb1.le.28))) then
            ei1=aks
            ei2=aka
            if(RANART(NSEED).ge.0.5) then
               iblock=366
               lbb1=30
               lbb2=21
            else
               iblock=367
               lbb1=-30
               lbb2=23
            endif
         endif
 clin-11/07/00-end
            endif
 clin-ppbar-8/25/00
            e(i1)=ei1
            e(i2)=ei2
            lb(i1)=lbb1
            lb(i2)=lbb2
 clin-10/08/00-end
 
        else
 cbzdbg10/15/99
 c.....for meson+meson elastic srt.le.2Mk, if not pi+pi collision return
          if ((lb(i1).lt.3.or.lb(i1).gt.5).and.
      &        (lb(i2).lt.3.or.lb(i2).gt.5)) return
 cbzdbg10/15/99 end
 
 * check Meson+Meson elastic collisions
         IBLOCK=6
 * direct process
        if(ipp.eq.1.or.ipp.eq.4.or.ipp.eq.6)go to 10
        if(spprho/ppel.gt.RANART(NSEED))go to 20
        endif
 10      NTAG=0
         EM1=E(I1)
         EM2=E(I2)
 
 *-----------------------------------------------------------------------
 * CALCULATE THE MAGNITUDE OF THE FINAL MOMENTUM THROUGH
 * ENERGY CONSERVATION
           PR2   = (SRT**2 - EM1**2 - EM2**2)**2
      1                - 4.0 * (EM1*EM2)**2
           IF(PR2.LE.0.)PR2=1.e-09
           PR=SQRT(PR2)/(2.*SRT)
           C1   = 1.0 - 2.0 * RANART(NSEED)
           T1   = 2.0 * PI * RANART(NSEED)
           S1   = SQRT( 1.0 - C1**2 )
       CT1  = COS(T1)
       ST1  = SIN(T1)
       PZ   = PR * C1
       PX   = PR * S1*CT1 
       PY   = PR * S1*ST1
 * for isotropic distribution no need to ROTATE THE MOMENTUM
 
 * ROTATE IT 
       CALL ROTATE(PX0,PY0,PZ0,PX,PY,PZ) 
 
       RETURN
 20       continue
        iblock=666
 * treat rho formation in pion+pion collisions
 * calculate the mass and momentum of rho in the nucleus-nucleus frame
        call rhores(i1,i2)
        if(ipp.eq.2)lb(i1)=27
        if(ipp.eq.3)lb(i1)=26
        if(ipp.eq.5)lb(i1)=25
        return       
       END
 **********************************
 **********************************
 *                                                                      *
 *                                                                      *
       SUBROUTINE CRND(IRUN,PX,PY,PZ,SRT,I1,I2,IBLOCK,
      &SIGNN,SIG,sigk,xsk1,xsk2,xsk3,xsk4,xsk5,NT,ipert1)
 *     PURPOSE:                                                         *
 *             DEALING WITH NUCLEON-BARYON RESONANCE COLLISIONS         *
 *     NOTE   :                                                         *
 *           VALID ONLY FOR BARYON-BARYON-DISTANCES LESS THAN 1.32 FM   *
 *           (1.32 = 2 * HARD-CORE-RADIUS [HRC] )                       *
 *     QUANTITIES:                                                 *
 *           PX,PY,PZ - MOMENTUM COORDINATES OF ONE PARTICLE IN CM FRAME*
 *           SRT      - SQRT OF S                                       *
 *           NSTAR =1 INCLUDING N* RESORANCE,ELSE NOT                   *
 *           NDIRCT=1 INCLUDING DIRECT PION PRODUCTION PROCESS         *
 *           IBLOCK   - THE INFORMATION BACK                            *
 *                      0-> COLLISION CANNOT HAPPEN                     *
 *                      1-> N-N ELASTIC COLLISION                       *
 *                      2-> N+N->N+DELTA,OR N+N->N+N* REACTION          *
 *                      3-> N+DELTA->N+N OR N+N*->N+N REACTION          *
 *                      4-> N+N->N+N+PION,DIRTCT PROCESS                *
 *           N12       - IS USED TO SPECIFY BARYON-BARYON REACTION      *
 *                      CHANNELS. M12 IS THE REVERSAL CHANNEL OF N12    *
 *                      N12,                                            *
 *                      M12=1 FOR p+n-->delta(+)+ n                     *
 *                          2     p+n-->delta(0)+ p                     *
 *                          3     p+p-->delta(++)+n                     *
 *                          4     p+p-->delta(+)+p                      *
 *                          5     n+n-->delta(0)+n                      *
 *                          6     n+n-->delta(-)+p                      *
 *                          7     n+p-->N*(0)(1440)+p                   *
 *                          8     n+p-->N*(+)(1440)+n                   *
 *                        9     p+p-->N*(+)(1535)+p                     *
 *                        10    n+n-->N*(0)(1535)+n                     *
 *                         11    n+p-->N*(+)(1535)+n                     *
 *                        12    n+p-->N*(0)(1535)+p
 *                        13    D(++)+D(-)-->N*(+)(1440)+n
 *                         14    D(++)+D(-)-->N*(0)(1440)+p
 *                        15    D(+)+D(0)--->N*(+)(1440)+n
 *                        16    D(+)+D(0)--->N*(0)(1440)+p
 *                        17    D(++)+D(0)-->N*(+)(1535)+p
 *                        18    D(++)+D(-)-->N*(0)(1535)+p
 *                        19    D(++)+D(-)-->N*(+)(1535)+n
 *                        20    D(+)+D(+)-->N*(+)(1535)+p
 *                        21    D(+)+D(0)-->N*(+)(1535)+n
 *                        22    D(+)+D(0)-->N*(0)(1535)+p
 *                        23    D(+)+D(-)-->N*(0)(1535)+n
 *                        24    D(0)+D(0)-->N*(0)(1535)+n
 *                          25    N*(+)(14)+N*(+)(14)-->N*(+)(15)+p
 *                          26    N*(0)(14)+N*(0)(14)-->N*(0)(15)+n
 *                          27    N*(+)(14)+N*(0)(14)-->N*(+)(15)+n
 *                        28    N*(+)(14)+N*(0)(14)-->N*(0)(15)+p
 *                        29    N*(+)(14)+D+-->N*(+)(15)+p
 *                        30    N*(+)(14)+D0-->N*(+)(15)+n
 *                        31    N*(+)(14)+D(-)-->N*(0)(1535)+n
 *                        32    N*(0)(14)+D++--->N*(+)(15)+p
 *                        33    N*(0)(14)+D+--->N*(+)(15)+n
 *                        34    N*(0)(14)+D+--->N*(0)(15)+p
 *                        35    N*(0)(14)+D0-->N*(0)(15)+n
 *                        36    N*(+)(14)+D0--->N*(0)(15)+p
 *                        ++    see the note book for more listing
 **********************************
         PARAMETER (MAXSTR=150001,MAXR=1,AMN=0.939457,
      1  AMP=0.93828,AP1=0.13496,AKA=0.498,APHI=1.020,
      2  AP2=0.13957,AM0=1.232,PI=3.1415926,CUTOFF=1.8966,AVMASS=0.9383)
         parameter     (MX=4,MY=4,MZ=8,MPX=4,MPY=4,mpz=10,mpzp=10)
         parameter (xmd=1.8756,npdmax=10000)
         COMMON /AA/ R(3,MAXSTR)
 cc      SAVE /AA/
         COMMON /BB/ P(3,MAXSTR)
 cc      SAVE /BB/
         COMMON /CC/ E(MAXSTR)
 cc      SAVE /CC/
         COMMON /EE/ ID(MAXSTR),LB(MAXSTR)
 cc      SAVE /EE/
         common /ff/f(-mx:mx,-my:my,-mz:mz,-mpx:mpx,-mpy:mpy,-mpz:mpzp)
 cc      SAVE /ff/
         common /gg/ dx,dy,dz,dpx,dpy,dpz
 cc      SAVE /gg/
         COMMON /INPUT/ NSTAR,NDIRCT,DIR
 cc      SAVE /INPUT/
         COMMON /NN/NNN
 cc      SAVE /NN/
         COMMON /BG/BETAX,BETAY,BETAZ,GAMMA
 cc      SAVE /BG/
         COMMON   /RUN/NUM
 cc      SAVE /RUN/
         COMMON   /PA/RPION(3,MAXSTR,MAXR)
 cc      SAVE /PA/
         COMMON   /PB/PPION(3,MAXSTR,MAXR)
 cc      SAVE /PB/
         COMMON   /PC/EPION(MAXSTR,MAXR)
 cc      SAVE /PC/
         COMMON   /PD/LPION(MAXSTR,MAXR)
 cc      SAVE /PD/
         common/input1/ MASSPR,MASSTA,ISEED,IAVOID,DT
 cc      SAVE /input1/
       common/leadng/lb1,px1,py1,pz1,em1,e1,xfnl,yfnl,zfnl,tfnl,
      1 px1n,py1n,pz1n,dp1n
 cc      SAVE /leadng/
       COMMON/RNDF77/NSEED
 cc      SAVE /RNDF77/
       COMMON /dpert/dpertt(MAXSTR,MAXR),dpertp(MAXSTR),dplast(MAXSTR),
      1     dpdcy(MAXSTR),dpdpi(MAXSTR,MAXR),dpt(MAXSTR, MAXR),
      2     dpp1(MAXSTR,MAXR),dppion(MAXSTR,MAXR)
       common /dpi/em2,lb2
       common /para8/ idpert,npertd,idxsec
       dimension ppd(3,npdmax),lbpd(npdmax)
       SAVE   
 *-----------------------------------------------------------------------
        n12=0
        m12=0
         IBLOCK=0
         NTAG=0
         EM1=E(I1)
         EM2=E(I2)
         PR  = SQRT( PX**2 + PY**2 + PZ**2 )
         C2  = PZ / PR
         X1  = RANART(NSEED)
         ianti=0
         if(lb(i1).lt.0 .and. lb(i2).lt.0)ianti=1
 
 clin-6/2008 Production of perturbative deuterons for idpert=1:
       call sbbdm(srt,sdprod,ianti,lbm,xmm,pfinal)
       if(idpert.eq.1.and.ipert1.eq.1) then
          IF (SRT .LT. 2.012) RETURN
          if((iabs(lb(i1)).eq.1.or.iabs(lb(i1)).eq.2)
      1        .and.(iabs(lb(i2)).ge.6.and.iabs(lb(i2)).le.13)) then
             goto 108
          elseif((iabs(lb(i2)).eq.1.or.iabs(lb(i2)).eq.2)
      1           .and.(iabs(lb(i1)).ge.6.and.iabs(lb(i1)).le.13)) then
             goto 108
          else
             return
          endif
       endif
 *-----------------------------------------------------------------------
 *COM: TEST FOR ELASTIC SCATTERING (EITHER N-N OR DELTA-DELTA 0R
 *      N-DELTA OR N*-N* or N*-Delta)
       IF (X1 .LE. SIGNN/SIG) THEN
 *COM:  PARAMETRISATION IS TAKEN FROM THE CUGNON-PAPER
         AS  = ( 3.65 * (SRT - 1.8766) )**6
         A   = 6.0 * AS / (1.0 + AS)
         TA  = -2.0 * PR**2
         X   = RANART(NSEED)
 clin-10/24/02        T1  = ALOG( (1-X) * DEXP(dble(A)*dble(TA)) + X )  /  A
         T1  = sngl(DLOG(dble(1.-X)*DEXP(dble(A)*dble(TA))+dble(X)))/  A
         C1  = 1.0 - T1/TA
         T1  = 2.0 * PI * RANART(NSEED)
         IBLOCK=1
        GO TO 107
       ELSE
 *COM: TEST FOR INELASTIC SCATTERING
 *     IF THE AVAILABLE ENERGY IS LESS THAN THE PION-MASS, NOTHING
 *     CAN HAPPEN ANY MORE ==> RETURN (2.04 = 2*AVMASS + PI-MASS+0.02)
         IF (SRT .LT. 2.04) RETURN
 clin-6/2008 add d+meson production for n*N*(0)(1440) and p*N*(+)(1440) channels
 c     (they did not have any inelastic reactions before):
         if(((iabs(LB(I1)).EQ.2.or.iabs(LB(I2)).EQ.2).AND.
      1       (LB(I1)*LB(I2)).EQ.20).or.(LB(I1)*LB(I2)).EQ.13) then
            IF(X1.LE.((SIGNN+sdprod)/SIG)) GO TO 108
         ENDIF
 c
 * Resonance absorption or Delta + N-->N*(1440), N*(1535)
 * COM: TEST FOR DELTA OR N* ABSORPTION
 *      IN THE PROCESS DELTA+N-->NN, N*+N-->NN
         PRF=SQRT(0.25*SRT**2-AVMASS**2)
         IF(EM1.GT.1.)THEN
         DELTAM=EM1
         ELSE
         DELTAM=EM2
         ENDIF
         RENOM=DELTAM*PRF**2/DENOM(SRT,1.)/PR
         RENOMN=DELTAM*PRF**2/DENOM(SRT,2.)/PR
         RENOM1=DELTAM*PRF**2/DENOM(SRT,-1.)/PR
 * avoid the inelastic collisions between n+delta- -->N+N 
 *       and p+delta++ -->N+N due to charge conservation,
 *       but they can scatter to produce kaons 
        if((iabs(lb(i1)).eq.2).and.(iabs(lb(i2)).eq.6)) renom=0.
        if((iabs(lb(i2)).eq.2).and.(iabs(lb(i1)).eq.6)) renom=0.
        if((iabs(lb(i1)).eq.1).and.(iabs(lb(i2)).eq.9)) renom=0.
        if((iabs(lb(i2)).eq.1).and.(iabs(lb(i1)).eq.9)) renom=0.
        Call M1535(iabs(lb(i1)),iabs(lb(i2)),srt,x1535)
         X1440=(3./4.)*SIGMA(SRT,2,0,1)
 * CROSS SECTION FOR KAON PRODUCTION from the four channels
 * for NLK channel
 * avoid the inelastic collisions between n+delta- -->N+N 
 *       and p+delta++ -->N+N due to charge conservation,
 *       but they can scatter to produce kaons 
        if(((iabs(lb(i1)).eq.2).and.(iabs(lb(i2)).eq.6)).OR. 
      &         ((iabs(lb(i2)).eq.2).and.(iabs(lb(i1)).eq.6)).OR.
      &         ((iabs(lb(i1)).eq.1).and.(iabs(lb(i2)).eq.9)).OR.
      &         ((iabs(lb(i2)).eq.1).and.(iabs(lb(i1)).eq.9)))THEN
 clin-6/2008
           IF(X1.LE.((SIGNN+sdprod)/SIG)) GO TO 108
 c          IF((SIGK+SIGNN)/SIG.GE.X1)GO TO 306
           IF((SIGK+SIGNN+sdprod)/SIG.GE.X1)GO TO 306
 c
        ENDIF
 * WE DETERMINE THE REACTION CHANNELS IN THE FOLLOWING
 * FOR n+delta(++)-->p+p or n+delta(++)-->n+N*(+)(1440),n+N*(+)(1535)
 * REABSORPTION OR N*(1535) PRODUCTION LIKE IN P+P OR N*(1440) LIKE PN, 
         IF(LB(I1)*LB(I2).EQ.18.AND.
      &  (iabs(LB(I1)).EQ.2.OR.iabs(LB(I2)).EQ.2))then
         SIGND=SIGMA(SRT,1,1,0)+0.5*SIGMA(SRT,1,1,1)
         SIGDN=0.25*SIGND*RENOM
 clin-6/2008
         IF(X1.LE.((SIGNN+sdprod)/SIG)) GO TO 108
 c        IF(X1.GT.(SIGNN+SIGDN+X1440+X1535+SIGK)/SIG)RETURN
         IF(X1.GT.(SIGNN+SIGDN+X1440+X1535+SIGK+sdprod)/SIG)RETURN
 c
        IF(SIGK/(SIGK+SIGDN+X1440+X1535).GT.RANART(NSEED))GO TO 306
 * REABSORPTION:
        IF(RANART(NSEED).LT.SIGDN/(SIGDN+X1440+X1535))THEN
         M12=3
        GO TO 206
        ELSE
 * N* PRODUCTION
               IF(RANART(NSEED).LT.X1440/(X1440+X1535))THEN
 * N*(1440)
               M12=37
               ELSE
 * N*(1535)       M12=38
 clin-2/26/03 why is the above commented out? leads to M12=0 but 
 c     particle mass is changed after 204 (causes energy violation).
 c     replace by elastic process (return):
                    return
 
               ENDIF
        GO TO 204
        ENDIF
         ENDIF
 * FOR p+delta(-)-->n+n or p+delta(-)-->n+N*(0)(1440),n+N*(0)(1535)
 * REABSORPTION OR N*(1535) PRODUCTION LIKE IN P+P OR N*(1440) LIKE PN, 
         IF(LB(I1)*LB(I2).EQ.6.AND.
      &   ((iabs(LB(I1)).EQ.1).OR.(iabs(LB(I2)).EQ.1)))then
         SIGND=SIGMA(SRT,1,1,0)+0.5*SIGMA(SRT,1,1,1)
         SIGDN=0.25*SIGND*RENOM
 clin-6/2008
         IF(X1.LE.((SIGNN+sdprod)/SIG)) GO TO 108
 c        IF (X1.GT.(SIGNN+SIGDN+X1440+X1535+SIGK)/SIG)RETURN
         IF (X1.GT.(SIGNN+SIGDN+X1440+X1535+SIGK+sdprod)/SIG)RETURN
 c
        IF(SIGK/(SIGK+SIGDN+X1440+X1535).GT.RANART(NSEED))GO TO 306
 * REABSORPTION:
        IF(RANART(NSEED).LT.SIGDN/(SIGDN+X1440+X1535))THEN
         M12=6
        GO TO 206
        ELSE
 * N* PRODUCTION
               IF(RANART(NSEED).LT.X1440/(X1440+X1535))THEN
 * N*(1440)
               M12=47
               ELSE
 * N*(1535)       M12=48
 clin-2/26/03 causes energy violation, replace by elastic process (return):
                    return
 
               ENDIF
        GO TO 204
        ENDIF
         ENDIF
 * FOR p+delta(+)-->p+p, N*(+)(144)+p, N*(+)(1535)+p
         IF(LB(I1)*LB(I2).EQ.8.AND.
      &   (iabs(LB(I1)).EQ.1.OR.iabs(LB(I2)).EQ.1))THEN
         SIGND=1.5*SIGMA(SRT,1,1,1)
         SIGDN=0.25*SIGND*RENOM
 clin-6/2008
         IF(X1.LE.((SIGNN+sdprod)/SIG)) GO TO 108
 c        IF(X1.GT.(SIGNN+SIGDN+x1440+x1535+SIGK)/SIG)RETURN
         IF(X1.GT.(SIGNN+SIGDN+x1440+x1535+SIGK+sdprod)/SIG)RETURN
 c
        IF(SIGK/(SIGK+SIGDN+X1440+X1535).GT.RANART(NSEED))GO TO 306
        IF(RANART(NSEED).LT.SIGDN/(SIGDN+X1440+X1535))THEN
         M12=4
        GO TO 206
        ELSE
               IF(RANART(NSEED).LT.X1440/(X1440+X1535))THEN
 * N*(144)
               M12=39
               ELSE
               M12=40
               ENDIF
               GO TO 204
        ENDIF
         ENDIF
 * FOR n+delta(0)-->n+n, N*(0)(144)+n, N*(0)(1535)+n
         IF(LB(I1)*LB(I2).EQ.14.AND.
      &   (iabs(LB(I1)).EQ.2.OR.iabs(LB(I2)).EQ.2))THEN
         SIGND=1.5*SIGMA(SRT,1,1,1)
         SIGDN=0.25*SIGND*RENOM
 clin-6/2008
         IF(X1.LE.((SIGNN+sdprod)/SIG)) GO TO 108
 c        IF(X1.GT.(SIGNN+SIGDN+x1440+x1535+SIGK)/SIG)RETURN
         IF(X1.GT.(SIGNN+SIGDN+x1440+x1535+SIGK+sdprod)/SIG)RETURN
 c
        IF(SIGK/(SIGK+SIGDN+X1440+X1535).GT.RANART(NSEED))GO TO 306
        IF(RANART(NSEED).LT.SIGDN/(SIGDN+X1440+X1535))THEN
         M12=5
        GO TO 206
        ELSE
               IF(RANART(NSEED).LT.X1440/(X1440+X1535))THEN
 * N*(144)
               M12=48
               ELSE
               M12=49
               ENDIF
               GO TO 204
        ENDIF
         ENDIF
 * FOR n+delta(+)-->n+p, N*(+)(1440)+n,N*(0)(1440)+p,
 *                       N*(+)(1535)+n,N*(0)(1535)+p
         IF(LB(I1)*LB(I2).EQ.16.AND.
      &   (iabs(LB(I1)).EQ.2.OR.iabs(LB(I2)).EQ.2))THEN
         SIGND=0.5*SIGMA(SRT,1,1,1)+0.25*SIGMA(SRT,1,1,0)
         SIGDN=0.5*SIGND*RENOM
 clin-6/2008
         IF(X1.LE.((SIGNN+sdprod)/SIG)) GO TO 108
 c        IF(X1.GT.(SIGNN+SIGDN+2.*x1440+2.*x1535+SIGK)/SIG)RETURN
         IF(X1.GT.(SIGNN+SIGDN+2.*x1440+2.*x1535+SIGK+sdprod)/SIG)RETURN
 c
        IF(SIGK/(SIGK+SIGDN+2*X1440+2*X1535).GT.RANART(NSEED))GO TO 306
        IF(RANART(NSEED).LT.SIGDN/(SIGDN+2.*X1440+2.*X1535))THEN
         M12=1
        GO TO 206
        ELSE
               IF(RANART(NSEED).LT.X1440/(X1440+X1535))THEN
               M12=41
               IF(RANART(NSEED).LE.0.5)M12=43
               ELSE
               M12=42
               IF(RANART(NSEED).LE.0.5)M12=44
               ENDIF
               GO TO 204
        ENDIF
         ENDIF
 * FOR p+delta(0)-->n+p, N*(+)(1440)+n,N*(0)(1440)+p,
 *                       N*(+)(1535)+n,N*(0)(1535)+p
         IF(LB(I1)*LB(I2).EQ.7)THEN
         SIGND=0.5*SIGMA(SRT,1,1,1)+0.25*SIGMA(SRT,1,1,0)
         SIGDN=0.5*SIGND*RENOM
 clin-6/2008
         IF(X1.LE.((SIGNN+sdprod)/SIG)) GO TO 108
 c        IF(X1.GT.(SIGNN+SIGDN+2.*x1440+2.*x1535+SIGK)/SIG)RETURN
         IF(X1.GT.(SIGNN+SIGDN+2.*x1440+2.*x1535+SIGK+sdprod)/SIG)RETURN
 c
        IF(SIGK/(SIGK+SIGDN+2*X1440+2*X1535).GT.RANART(NSEED))GO TO 306
        IF(RANART(NSEED).LT.SIGDN/(SIGDN+2.*X1440+2.*X1535))THEN
         M12=2
        GO TO 206
        ELSE
               IF(RANART(NSEED).LT.X1440/(X1440+X1535))THEN
               M12=50
               IF(RANART(NSEED).LE.0.5)M12=51
               ELSE
               M12=52
               IF(RANART(NSEED).LE.0.5)M12=53
               ENDIF
               GO TO 204
        ENDIF
         ENDIF
 * FOR p+N*(0)(14)-->p+n, N*(+)(1535)+n,N*(0)(1535)+p
 * OR  P+N*(0)(14)-->D(+)+N, D(0)+P, 
         IF(LB(I1)*LB(I2).EQ.10.AND.
      &  (iabs(LB(I1)).EQ.1.OR.iabs(LB(I2)).EQ.1))then
         SIGND=(3./4.)*SIGMA(SRT,2,0,1)
         SIGDN=SIGND*RENOMN
 clin-6/2008
         IF(X1.LE.((SIGNN+sdprod)/SIG)) GO TO 108
 c        IF(X1.GT.(SIGNN+SIGDN+X1535+SIGK)/SIG)RETURN
         IF(X1.GT.(SIGNN+SIGDN+X1535+SIGK+sdprod)/SIG)RETURN
 c
        IF(SIGK/(SIGK+SIGDN+X1535).GT.RANART(NSEED))GO TO 306
        IF(RANART(NSEED).LT.SIGDN/(SIGDN+X1535))THEN
         M12=7
         GO TO 206
        ELSE
        M12=54
        IF(RANART(NSEED).LE.0.5)M12=55
        ENDIF
        GO TO 204
         ENDIF
 * FOR n+N*(+)-->p+n, N*(+)(1535)+n,N*(0)(1535)+p
         IF(LB(I1)*LB(I2).EQ.22.AND.
      &   (iabs(LB(I1)).EQ.2.OR.iabs(LB(I2)).EQ.2))then
         SIGND=(3./4.)*SIGMA(SRT,2,0,1)
         SIGDN=SIGND*RENOMN
 clin-6/2008
         IF(X1.LE.((SIGNN+sdprod)/SIG)) GO TO 108
 c        IF(X1.GT.(SIGNN+SIGDN+X1535+SIGK)/SIG)RETURN
         IF(X1.GT.(SIGNN+SIGDN+X1535+SIGK+sdprod)/SIG)RETURN
 c
        IF(SIGK/(SIGK+SIGDN+X1535).GT.RANART(NSEED))GO TO 306
        IF(RANART(NSEED).LT.SIGDN/(SIGDN+X1535))THEN
         M12=8
         GO TO 206
        ELSE
        M12=56
        IF(RANART(NSEED).LE.0.5)M12=57
        ENDIF
        GO TO 204
         ENDIF
 * FOR N*(1535)+N-->N+N COLLISIONS
         IF((iabs(LB(I1)).EQ.12).OR.(iabs(LB(I1)).EQ.13).OR.
      1  (iabs(LB(I2)).EQ.12).OR.(iabs(LB(I2)).EQ.13))THEN
         SIGND=X1535
         SIGDN=SIGND*RENOM1
 clin-6/2008
         IF(X1.LE.((SIGNN+sdprod)/SIG)) GO TO 108
 c        IF(X1.GT.(SIGNN+SIGDN+SIGK)/SIG)RETURN
         IF(X1.GT.(SIGNN+SIGDN+SIGK+sdprod)/SIG)RETURN
 c
        IF(SIGK/(SIGK+SIGDN).GT.RANART(NSEED))GO TO 306
         IF(LB(I1)*LB(I2).EQ.24)M12=10
         IF(LB(I1)*LB(I2).EQ.12)M12=12
         IF(LB(I1)*LB(I2).EQ.26)M12=11
        IF(LB(I1)*LB(I2).EQ.13)M12=9
        GO TO 206
         ENDIF
 204       CONTINUE
 * (1) GENERATE THE MASS FOR THE N*(1440) AND N*(1535)
 * (2) CALCULATE THE FINAL MOMENTUM OF THE n+N* SYSTEM
 * (3) RELABLE THE FINAL STATE PARTICLES
 *PARAMETRIZATION OF THE SHAPE OF THE N* RESONANCE ACCORDING
 *     TO kitazoe's or J.D.JACKSON'S MASS FORMULA AND BREIT WIGNER
 *     FORMULA FOR N* RESORANCE
 *     DETERMINE DELTA MASS VIA REJECTION METHOD.
           DMAX = SRT - AVMASS-0.005
           DMIN = 1.078
           IF((M12.eq.37).or.(M12.eq.39).or.
      1    (M12.eQ.41).OR.(M12.eQ.43).OR.(M12.EQ.46).
      2     OR.(M12.EQ.48).OR.(M12.EQ.50).OR.(M12.EQ.51))then
 * N*(1440) production
           IF(DMAX.LT.1.44) THEN
           FM=FNS(DMAX,SRT,0.)
           ELSE
 
 clin-10/25/02 get rid of argument usage mismatch in FNS():
              xdmass=1.44
 c          FM=FNS(1.44,SRT,1.)
           FM=FNS(xdmass,SRT,1.)
 clin-10/25/02-end
 
           ENDIF
           IF(FM.EQ.0.)FM=1.E-09
           NTRY2=0
 11        DM=RANART(NSEED)*(DMAX-DMIN)+DMIN
           NTRY2=NTRY2+1
           IF((RANART(NSEED).GT.FNS(DM,SRT,1.)/FM).AND.
      1    (NTRY2.LE.10)) GO TO 11
 
 clin-2/26/03 limit the N* mass below a certain value 
 c     (here taken as its central value + 2* B-W fullwidth):
           if(dm.gt.2.14) goto 11
 
               GO TO 13
               ELSE
 * N*(1535) production
           IF(DMAX.LT.1.535) THEN
           FM=FD5(DMAX,SRT,0.)
           ELSE
 
 clin-10/25/02 get rid of argument usage mismatch in FNS():
              xdmass=1.535
 c          FM=FD5(1.535,SRT,1.)
           FM=FD5(xdmass,SRT,1.)
 clin-10/25/02-end
 
           ENDIF
           IF(FM.EQ.0.)FM=1.E-09
           NTRY1=0
 12        DM = RANART(NSEED) * (DMAX-DMIN) + DMIN
           NTRY1=NTRY1+1
           IF((RANART(NSEED) .GT. FD5(DM,SRT,1.)/FM).AND.
      1    (NTRY1.LE.10)) GOTO 12
 
 clin-2/26/03 limit the N* mass below a certain value 
 c     (here taken as its central value + 2* B-W fullwidth):
           if(dm.gt.1.84) goto 12
 
              ENDIF
 13       CONTINUE
 * (2) DETERMINE THE FINAL MOMENTUM
        PRF=0.
        PF2=((SRT**2-DM**2+AVMASS**2)/(2.*SRT))**2-AVMASS**2
        IF(PF2.GT.0.)PRF=SQRT(PF2)
 * (3) RELABLE FINAL STATE PARTICLES
 * 37 D(++)+n-->N*(+)(14)+p
           IF(M12.EQ.37)THEN
           IF(iabs(LB(I1)).EQ.9)THEN
           LB(I1)=1
           E(I1)=AMP
          LB(I2)=11
          E(I2)=DM
           ELSE
           LB(I2)=1
           E(I2)=AMP
          LB(I1)=11
          E(I1)=DM
           ENDIF
          GO TO 207
           ENDIF
 * 38 D(++)+n-->N*(+)(15)+p
           IF(M12.EQ.38)THEN
           IF(iabs(LB(I1)).EQ.9)THEN
           LB(I1)=1
           E(I1)=AMP
          LB(I2)=13
          E(I2)=DM
           ELSE
           LB(I2)=1
           E(I2)=AMP
          LB(I1)=13
          E(I1)=DM
           ENDIF
          GO TO 207
          ENDIF
 * 39 D(+)+P-->N*(+)(14)+p
           IF(M12.EQ.39)THEN
           IF(iabs(LB(I1)).EQ.8)THEN
           LB(I1)=1
           E(I1)=AMP
          LB(I2)=11
          E(I2)=DM
           ELSE
           LB(I2)=1
           E(I2)=AMP
          LB(I1)=11
          E(I1)=DM
           ENDIF
          GO TO 207
          ENDIF
 * 40 D(+)+P-->N*(+)(15)+p
           IF(M12.EQ.40)THEN
           IF(iabs(LB(I1)).EQ.8)THEN
           LB(I1)=1
           E(I1)=AMP
          LB(I2)=13
          E(I2)=DM
           ELSE
           LB(I2)=1
           E(I2)=AMP
          LB(I1)=13
          E(I1)=DM
           ENDIF
          GO TO 207
          ENDIF
 * 41 D(+)+N-->N*(+)(14)+N
           IF(M12.EQ.41)THEN
           IF(iabs(LB(I1)).EQ.8)THEN
           LB(I1)=2
           E(I1)=AMN
          LB(I2)=11
          E(I2)=DM
           ELSE
           LB(I2)=2
           E(I2)=AMN
          LB(I1)=11
          E(I1)=DM
           ENDIF
          GO TO 207
          ENDIF
 * 42 D(+)+N-->N*(+)(15)+N
           IF(M12.EQ.42)THEN
           IF(iabs(LB(I1)).EQ.8)THEN
           LB(I1)=2
           E(I1)=AMN
          LB(I2)=13
          E(I2)=DM
           ELSE
           LB(I2)=2
           E(I2)=AMN
          LB(I1)=13
          E(I1)=DM
           ENDIF
          GO TO 207
          ENDIF
 * 43 D(+)+N-->N*(0)(14)+P
           IF(M12.EQ.43)THEN
           IF(iabs(LB(I1)).EQ.8)THEN
           LB(I1)=1
           E(I1)=AMP
          LB(I2)=10
          E(I2)=DM
           ELSE
           LB(I2)=1
           E(I2)=AMP
          LB(I1)=10
          E(I1)=DM
           ENDIF
          GO TO 207
          ENDIF
 * 44 D(+)+N-->N*(0)(15)+P
           IF(M12.EQ.44)THEN
           IF(iabs(LB(I1)).EQ.8)THEN
           LB(I1)=1
           E(I1)=AMP
          LB(I2)=12
          E(I2)=DM
           ELSE
           LB(I2)=1
           E(I2)=AMP
          LB(I1)=12
          E(I1)=DM
           ENDIF
          GO TO 207
          ENDIF
 * 46 D(-)+P-->N*(0)(14)+N
           IF(M12.EQ.46)THEN
           IF(iabs(LB(I1)).EQ.6)THEN
           LB(I1)=2
           E(I1)=AMN
          LB(I2)=10
          E(I2)=DM
           ELSE
           LB(I2)=2
           E(I2)=AMN
          LB(I1)=10
          E(I1)=DM
           ENDIF
          GO TO 207
          ENDIF
 * 47 D(-)+P-->N*(0)(15)+N
           IF(M12.EQ.47)THEN
           IF(iabs(LB(I1)).EQ.6)THEN
           LB(I1)=2
           E(I1)=AMN
          LB(I2)=12
          E(I2)=DM
           ELSE
           LB(I2)=2
           E(I2)=AMN
          LB(I1)=12
          E(I1)=DM
           ENDIF
          GO TO 207
          ENDIF
 * 48 D(0)+N-->N*(0)(14)+N
           IF(M12.EQ.48)THEN
           IF(iabs(LB(I1)).EQ.7)THEN
           LB(I1)=2
           E(I1)=AMN
          LB(I2)=11
          E(I2)=DM
           ELSE
           LB(I2)=2
           E(I2)=AMN
          LB(I1)=11
          E(I1)=DM
           ENDIF
          GO TO 207
          ENDIF
 * 49 D(0)+N-->N*(0)(15)+N
           IF(M12.EQ.49)THEN
           IF(iabs(LB(I1)).EQ.7)THEN
           LB(I1)=2
           E(I1)=AMN
          LB(I2)=12
          E(I2)=DM
           ELSE
           LB(I2)=2
           E(I2)=AMN
          LB(I1)=12
          E(I1)=DM
           ENDIF
          GO TO 207
          ENDIF
 * 50 D(0)+P-->N*(0)(14)+P
           IF(M12.EQ.50)THEN
           IF(iabs(LB(I1)).EQ.7)THEN
           LB(I1)=1
           E(I1)=AMP
          LB(I2)=10
          E(I2)=DM
           ELSE
           LB(I2)=1
           E(I2)=AMP
          LB(I1)=10
          E(I1)=DM
           ENDIF
          GO TO 207
          ENDIF
 * 51 D(0)+P-->N*(+)(14)+N
           IF(M12.EQ.51)THEN
           IF(iabs(LB(I1)).EQ.7)THEN
           LB(I1)=2
           E(I1)=AMN
          LB(I2)=11
          E(I2)=DM
           ELSE
           LB(I2)=2
           E(I2)=AMN
          LB(I1)=11
          E(I1)=DM
           ENDIF
          GO TO 207
          ENDIF
 * 52 D(0)+P-->N*(0)(15)+P
           IF(M12.EQ.52)THEN
           IF(iabs(LB(I1)).EQ.7)THEN
           LB(I1)=1
           E(I1)=AMP
          LB(I2)=12
          E(I2)=DM
           ELSE
           LB(I2)=1
           E(I2)=AMP
          LB(I1)=12
          E(I1)=DM
           ENDIF
          GO TO 207
          ENDIF
 * 53 D(0)+P-->N*(+)(15)+N
           IF(M12.EQ.53)THEN
           IF(iabs(LB(I1)).EQ.7)THEN
           LB(I1)=2
           E(I1)=AMN
          LB(I2)=13
          E(I2)=DM
           ELSE
           LB(I2)=2
           E(I2)=AMN
          LB(I1)=13
          E(I1)=DM
           ENDIF
          GO TO 207
          ENDIF
 * 54 N*(0)(14)+P-->N*(+)(15)+N
           IF(M12.EQ.54)THEN
           IF(iabs(LB(I1)).EQ.10)THEN
           LB(I1)=2
           E(I1)=AMN
          LB(I2)=13
          E(I2)=DM
           ELSE
           LB(I2)=2
           E(I2)=AMN
          LB(I1)=13
          E(I1)=DM
           ENDIF
          GO TO 207
          ENDIF
 * 55 N*(0)(14)+P-->N*(0)(15)+P
           IF(M12.EQ.55)THEN
           IF(iabs(LB(I1)).EQ.10)THEN
           LB(I1)=1
           E(I1)=AMP
          LB(I2)=12
          E(I2)=DM
           ELSE
           LB(I2)=1
           E(I2)=AMP
          LB(I1)=12
          E(I1)=DM
           ENDIF
          GO TO 207
          ENDIF
 * 56 N*(+)(14)+N-->N*(+)(15)+N
           IF(M12.EQ.56)THEN
           IF(iabs(LB(I1)).EQ.11)THEN
           LB(I1)=2
           E(I1)=AMN
          LB(I2)=13
          E(I2)=DM
           ELSE
           LB(I2)=2
           E(I2)=AMN
          LB(I1)=13
          E(I1)=DM
           ENDIF
          GO TO 207
          ENDIF
 * 57 N*(+)(14)+N-->N*(0)(15)+P
           IF(M12.EQ.57)THEN
           IF(iabs(LB(I1)).EQ.11)THEN
           LB(I1)=1
           E(I1)=AMP
          LB(I2)=12
          E(I2)=DM
           ELSE
           LB(I2)=1
           E(I2)=AMP
          LB(I1)=12
          E(I1)=DM
           ENDIF
          ENDIF
           GO TO 207
 *------------------------------------------------
 * RELABLE NUCLEONS AFTER DELTA OR N* BEING ABSORBED
 *(1) n+delta(+)-->n+p
 206       IF(M12.EQ.1)THEN
           IF(iabs(LB(I1)).EQ.8)THEN
           LB(I2)=2
           LB(I1)=1
           E(I1)=AMP
           ELSE
           LB(I1)=2
           LB(I2)=1
           E(I2)=AMP
           ENDIF
          GO TO 207
           ENDIF
 *(2) p+delta(0)-->p+n
           IF(M12.EQ.2)THEN
           IF(iabs(LB(I1)).EQ.7)THEN
           LB(I2)=1
           LB(I1)=2
           E(I1)=AMN
           ELSE
           LB(I1)=1
           LB(I2)=2
           E(I2)=AMN
           ENDIF
          GO TO 207
           ENDIF
 *(3) n+delta(++)-->p+p
           IF(M12.EQ.3)THEN
           LB(I1)=1
           LB(I2)=1
           E(I1)=AMP
           E(I2)=AMP
          GO TO 207
           ENDIF
 *(4) p+delta(+)-->p+p
           IF(M12.EQ.4)THEN
           LB(I1)=1
           LB(I2)=1
           E(I1)=AMP
           E(I2)=AMP
          GO TO 207
           ENDIF
 *(5) n+delta(0)-->n+n
           IF(M12.EQ.5)THEN
           LB(I1)=2
           LB(I2)=2
           E(I1)=AMN
           E(I2)=AMN
          GO TO 207
           ENDIF
 *(6) p+delta(-)-->n+n
           IF(M12.EQ.6)THEN
           LB(I1)=2
           LB(I2)=2
           E(I1)=AMN
           E(I2)=AMN
          GO TO 207
           ENDIF
 *(7) p+N*(0)-->n+p
           IF(M12.EQ.7)THEN
           IF(iabs(LB(I1)).EQ.1)THEN
           LB(I1)=1
           LB(I2)=2
           E(I1)=AMP
           E(I2)=AMN
           ELSE
           LB(I1)=2
           LB(I2)=1
           E(I1)=AMN
           E(I2)=AMP
           ENDIF
          GO TO 207
           ENDIF
 *(8) n+N*(+)-->n+p
           IF(M12.EQ.8)THEN
           IF(iabs(LB(I1)).EQ.2)THEN
           LB(I1)=2
           LB(I2)=1
           E(I1)=AMN
           E(I2)=AMP
           ELSE
           LB(I1)=1
           LB(I2)=2
           E(I1)=AMP
           E(I2)=AMN
           ENDIF
          GO TO 207
           ENDIF
 clin-6/2008
 c*(9) N*(+)p-->pp
 *(9) N*(+)(1535) p-->pp
           IF(M12.EQ.9)THEN
           LB(I1)=1
           LB(I2)=1
           E(I1)=AMP
           E(I2)=AMP
          GO TO 207
          ENDIF
 *(12) N*(0)P-->nP
           IF(M12.EQ.12)THEN
           LB(I1)=2
           LB(I2)=1
           E(I1)=AMN
           E(I2)=AMP
          GO TO 207
          ENDIF
 *(11) N*(+)n-->nP
           IF(M12.EQ.11)THEN
           LB(I1)=2
           LB(I2)=1
           E(I1)=AMN
           E(I2)=AMP
          GO TO 207
          ENDIF
 clin-6/2008
 c*(12) N*(0)p-->Np
 *(12) N*(0)(1535) p-->Np
           IF(M12.EQ.12)THEN
           LB(I1)=1
           LB(I2)=2
           E(I1)=AMP
           E(I2)=AMN
          ENDIF
 *----------------------------------------------
 207       PR   = PRF
           C1   = 1.0 - 2.0 * RANART(NSEED)
               if(srt.le.2.14)C1= 1.0 - 2.0 * RANART(NSEED)
          if(srt.gt.2.14.and.srt.le.2.4)c1=ang(srt,iseed)
          if(srt.gt.2.4)then
 
 clin-10/25/02 get rid of argument usage mismatch in PTR():
              xptr=0.33*pr
 c         cc1=ptr(0.33*pr,iseed)
          cc1=ptr(xptr,iseed)
 clin-10/25/02-end
 
 clin-9/2012: check argument in sqrt():
          scheck=pr**2-cc1**2
          if(scheck.lt.0) then
             write(99,*) 'scheck4: ', scheck
             scheck=0.
          endif
          c1=sqrt(scheck)/pr
 c         c1=sqrt(pr**2-cc1**2)/pr
 
          endif
           T1   = 2.0 * PI * RANART(NSEED)
           IBLOCK=3
       ENDIF
       if(ianti.eq.1 .and. lb(i1).ge.1 .and. lb(i2).ge.1)then
          lb(i1) = -lb(i1)
          lb(i2) = -lb(i2)
       endif
 
 *-----------------------------------------------------------------------
 *COM: SET THE NEW MOMENTUM COORDINATES
  107  IF(PX .EQ. 0.0 .AND. PY .EQ. 0.0) THEN
          T2 = 0.0
       ELSE
          T2=ATAN2(PY,PX)
       END IF
 
 clin-9/2012: check argument in sqrt():
       scheck=1.0 - C1**2
       if(scheck.lt.0) then
          write(99,*) 'scheck5: ', scheck
          scheck=0.
       endif
       S1=SQRT(scheck)
 c      S1   = SQRT( 1.0 - C1**2 )
 
 clin-9/2012: check argument in sqrt():
       scheck=1.0 - C2**2
       if(scheck.lt.0) then
          write(99,*) 'scheck6: ', scheck
          scheck=0.
       endif
       S2=SQRT(scheck)
 c      S2  =  SQRT( 1.0 - C2**2 )
 
       CT1  = COS(T1)
       ST1  = SIN(T1)
       CT2  = COS(T2)
       ST2  = SIN(T2)
       PZ   = PR * ( C1*C2 - S1*S2*CT1 )
       SS   = C2 * S1 * CT1  +  S2 * C1
       PX   = PR * ( SS*CT2 - S1*ST1*ST2 )
       PY   = PR * ( SS*ST2 + S1*ST1*CT2 )
       RETURN
 * FOR THE NN-->KAON+X PROCESS, FIND MOMENTUM OF THE FINAL PARTICLES IN 
 * THE NUCLEUS-NUCLEUS CMS.
 306     CONTINUE
 csp11/21/01 phi production
               if(XSK5/sigK.gt.RANART(NSEED))then
               pz1=p(3,i1)
               pz2=p(3,i2)
                 LB(I1) = 1 + int(2 * RANART(NSEED))
                 LB(I2) = 1 + int(2 * RANART(NSEED))
               nnn=nnn+1
                 LPION(NNN,IRUN)=29
                 EPION(NNN,IRUN)=APHI
                 iblock = 222
               GO TO 208
                ENDIF
 csp11/21/01 end
                 IBLOCK=11
                 if(ianti .eq. 1)iblock=-11
 c
               pz1=p(3,i1)
               pz2=p(3,i2)
 * DETERMINE THE CHARGE STATES OF PARTICLES IN THE FINAL STATE
               nnn=nnn+1
                 LPION(NNN,IRUN)=23
                 EPION(NNN,IRUN)=Aka
               if(srt.le.2.63)then
 * only lambda production is possible
 * (1.1)P+P-->p+L+kaon+
               ic=1
 
                 LB(I1) = 1 + int(2 * RANART(NSEED))
               LB(I2)=14
               GO TO 208
                 ENDIF
        if(srt.le.2.74.and.srt.gt.2.63)then
 * both Lambda and sigma production are possible
               if(XSK1/(XSK1+XSK2).gt.RANART(NSEED))then
 * lambda production
               ic=1
 
                 LB(I1) = 1 + int(2 * RANART(NSEED))
               LB(I2)=14
               else
 * sigma production
 
                    LB(I1) = 1 + int(2 * RANART(NSEED))
                    LB(I2) = 15 + int(3 * RANART(NSEED))
               ic=2
               endif
               GO TO 208
        endif
        if(srt.le.2.77.and.srt.gt.2.74)then
 * then pp-->Delta lamda kaon can happen
               if(xsk1/(xsk1+xsk2+xsk3).
      1          gt.RANART(NSEED))then
 * * (1.1)P+P-->p+L+kaon+
               ic=1
 
                 LB(I1) = 1 + int(2 * RANART(NSEED))
               LB(I2)=14
               go to 208
               else
               if(xsk2/(xsk2+xsk3).gt.RANART(NSEED))then
 * pp-->psk
               ic=2
 
                 LB(I1) = 1 + int(2 * RANART(NSEED))
                 LB(I2) = 15 + int(3 * RANART(NSEED))
 
               else
 * pp-->D+l+k        
               ic=3
 
                 LB(I1) = 6 + int(4 * RANART(NSEED))
               lb(i2)=14
               endif
               GO TO 208
               endif
        endif
        if(srt.gt.2.77)then
 * all four channels are possible
               if(xsk1/(xsk1+xsk2+xsk3+xsk4).gt.RANART(NSEED))then
 * p lambda k production
               ic=1
 
                 LB(I1) = 1 + int(2 * RANART(NSEED))
               LB(I2)=14
               go to 208
        else
           if(xsk3/(xsk2+xsk3+xsk4).gt.RANART(NSEED))then
 * delta l K production
               ic=3
 
                 LB(I1) = 6 + int(4 * RANART(NSEED))
               lb(i2)=14
               go to 208
           else
               if(xsk2/(xsk2+xsk4).gt.RANART(NSEED))then
 * n sigma k production
 
                    LB(I1) = 1 + int(2 * RANART(NSEED))
                    LB(I2) = 15 + int(3 * RANART(NSEED))
 
               ic=2
               else
               ic=4
 
                 LB(I1) = 6 + int(4 * RANART(NSEED))
                 LB(I2) = 15 + int(3 * RANART(NSEED))
 
               endif
               go to 208
           endif
        endif
        endif
 208             continue
          if(ianti.eq.1 .and. lb(i1).ge.1 .and. lb(i2).ge.1)then
           lb(i1) = - lb(i1)
           lb(i2) = - lb(i2)
           if(LPION(NNN,IRUN) .eq. 23)LPION(NNN,IRUN)=21
          endif
        lbi1=lb(i1)
        lbi2=lb(i2)
 * KEEP ALL COORDINATES OF PARTICLE 2 FOR POSSIBLE PHASE SPACE CHANGE
            NTRY1=0
 128        CALL BBKAON(ic,SRT,PX3,PY3,PZ3,DM3,PX4,PY4,PZ4,DM4,
      &  PPX,PPY,PPZ,icou1)
        NTRY1=NTRY1+1
        if((icou1.lt.0).AND.(NTRY1.LE.20))GO TO 128
 c       if(icou1.lt.0)return
 * ROTATE THE MOMENTA OF PARTICLES IN THE CMS OF P1+P2
        CALL ROTATE(PX,PY,PZ,PX3,PY3,PZ3)
        CALL ROTATE(PX,PY,PZ,PX4,PY4,PZ4)
        CALL ROTATE(PX,PY,PZ,PPX,PPY,PPZ)
 * FIND THE MOMENTUM OF PARTICLES IN THE FINAL STATE IN THE NUCLEUS-
 * NUCLEUS CMS. FRAME 
 * (1) for the necleon/delta
 *             LORENTZ-TRANSFORMATION INTO LAB FRAME FOR DELTA1
               E1CM    = SQRT (dm3**2 + PX3**2 + PY3**2 + PZ3**2)
               P1BETA  = PX3*BETAX + PY3*BETAY + PZ3*BETAZ
               TRANSF  = GAMMA * ( GAMMA * P1BETA / (GAMMA + 1) + E1CM )
               Pt1i1 = BETAX * TRANSF + PX3
               Pt2i1 = BETAY * TRANSF + PY3
               Pt3i1 = BETAZ * TRANSF + PZ3
              Eti1   = DM3
 * (2) for the lambda/sigma
                 E2CM    = SQRT (dm4**2 + PX4**2 + PY4**2 + PZ4**2)
                 P2BETA  = PX4*BETAX+PY4*BETAY+PZ4*BETAZ
                 TRANSF  = GAMMA * (GAMMA*P2BETA / (GAMMA + 1.) + E2CM)
                 Pt1I2 = BETAX * TRANSF + PX4
                 Pt2I2 = BETAY * TRANSF + PY4
                 Pt3I2 = BETAZ * TRANSF + PZ4
               EtI2   = DM4
 * GET the kaon'S MOMENTUM AND COORDINATES IN NUCLEUS-NUCLEUS CMS. FRAME
                 EPCM=SQRT(aka**2+PPX**2+PPY**2+PPZ**2)
                 PPBETA=PPX*BETAX+PPY*BETAY+PPZ*BETAZ
                 TRANSF=GAMMA*(GAMMA*PPBETA/(GAMMA+1.)+EPCM)
                 PPION(1,NNN,IRUN)=BETAX*TRANSF+PPX
                 PPION(2,NNN,IRUN)=BETAY*TRANSF+PPY
                 PPION(3,NNN,IRUN)=BETAZ*TRANSF+PPZ
 clin-5/2008:
                 dppion(nnn,irun)=dpertp(i1)*dpertp(i2)
 clin-5/2008:
 c2008        X01 = 1.0 - 2.0 * RANART(NSEED)
 c            Y01 = 1.0 - 2.0 * RANART(NSEED)
 c            Z01 = 1.0 - 2.0 * RANART(NSEED)
 c        IF ((X01*X01+Y01*Y01+Z01*Z01) .GT. 1.0) GOTO 2008
 c                RPION(1,NNN,IRUN)=R(1,I1)+0.5*x01
 c                RPION(2,NNN,IRUN)=R(2,I1)+0.5*y01
 c                RPION(3,NNN,IRUN)=R(3,I1)+0.5*z01
                     RPION(1,NNN,IRUN)=R(1,I1)
                     RPION(2,NNN,IRUN)=R(2,I1)
                     RPION(3,NNN,IRUN)=R(3,I1)
 c
 * assign the nucleon/delta and lambda/sigma to i1 or i2 to keep the 
 * leadng particle behaviour
 C              if((pt1i1*px1+pt2i1*py1+pt3i1*pz1).gt.0)then
               p(1,i1)=pt1i1
               p(2,i1)=pt2i1
               p(3,i1)=pt3i1
               e(i1)=eti1
               lb(i1)=lbi1
               p(1,i2)=pt1i2
               p(2,i2)=pt2i2
               p(3,i2)=pt3i2
               e(i2)=eti2
               lb(i2)=lbi2
                 PX1     = P(1,I1)
                 PY1     = P(2,I1)
                 PZ1     = P(3,I1)
               EM1       = E(I1)
                 ID(I1)  = 2
                 ID(I2)  = 2
                 ID1     = ID(I1)
                 if(LPION(NNN,IRUN) .ne. 29) IBLOCK=11
         LB1=LB(I1)
         LB2=LB(I2)
         AM1=EM1
        am2=em2
         E1= SQRT( EM1**2 + PX1**2 + PY1**2 + PZ1**2 )
        RETURN
 
 clin-6/2008 N+D->Deuteron+pi:
 *     FIND MOMENTUM OF THE FINAL PARTICLES IN THE NUCLEUS-NUCLEUS CMS.
  108   CONTINUE
            if(idpert.eq.1.and.ipert1.eq.1.and.npertd.ge.1) then
 c     For idpert=1: we produce npertd pert deuterons:
               ndloop=npertd
            elseif(idpert.eq.2.and.npertd.ge.1) then
 c     For idpert=2: we first save information for npertd pert deuterons;
 c     at the last ndloop we create the regular deuteron+pi 
 c     and those pert deuterons:
               ndloop=npertd+1
            else
 c     Just create the regular deuteron+pi:
               ndloop=1
            endif
 c
            dprob1=sdprod/sig/float(npertd)
            do idloop=1,ndloop
               CALL bbdangle(pxd,pyd,pzd,nt,ipert1,ianti,idloop,pfinal,
      1 dprob1,lbm)
               CALL ROTATE(PX,PY,PZ,PXd,PYd,PZd)
 *     LORENTZ-TRANSFORMATION OF THE MOMENTUM OF PARTICLES IN THE FINAL STATE 
 *     FROM THE NN CMS FRAME INTO THE GLOBAL CMS FRAME:
 *     For the Deuteron:
               xmass=xmd
               E1dCM=SQRT(xmass**2+PXd**2+PYd**2+PZd**2)
               P1dBETA=PXd*BETAX+PYd*BETAY+PZd*BETAZ
               TRANSF=GAMMA*(GAMMA*P1dBETA/(GAMMA+1.)+E1dCM)
               pxi1=BETAX*TRANSF+PXd
               pyi1=BETAY*TRANSF+PYd
               pzi1=BETAZ*TRANSF+PZd
               if(ianti.eq.0)then
                  lbd=42
               else
                  lbd=-42
               endif
               if(idpert.eq.1.and.ipert1.eq.1.and.npertd.ge.1) then
 cccc  Perturbative production for idpert=1:
                  nnn=nnn+1
                  PPION(1,NNN,IRUN)=pxi1
                  PPION(2,NNN,IRUN)=pyi1
                  PPION(3,NNN,IRUN)=pzi1
                  EPION(NNN,IRUN)=xmd
                  LPION(NNN,IRUN)=lbd
                  RPION(1,NNN,IRUN)=R(1,I1)
                  RPION(2,NNN,IRUN)=R(2,I1)
                  RPION(3,NNN,IRUN)=R(3,I1)
 clin-6/2008 assign the perturbative probability:
                  dppion(NNN,IRUN)=sdprod/sig/float(npertd)
               elseif(idpert.eq.2.and.idloop.le.npertd) then
 clin-6/2008 For idpert=2, we produce NPERTD perturbative (anti)deuterons 
 c     only when a regular (anti)deuteron+pi is produced in NN collisions.
 c     First save the info for the perturbative deuterons:
                  ppd(1,idloop)=pxi1
                  ppd(2,idloop)=pyi1
                  ppd(3,idloop)=pzi1
                  lbpd(idloop)=lbd
               else
 cccc  Regular production:
 c     For the regular pion: do LORENTZ-TRANSFORMATION:
                  E(i1)=xmm
                  E2piCM=SQRT(xmm**2+PXd**2+PYd**2+PZd**2)
                  P2piBETA=-PXd*BETAX-PYd*BETAY-PZd*BETAZ
                  TRANSF=GAMMA*(GAMMA*P2piBETA/(GAMMA+1.)+E2piCM)
                  pxi2=BETAX*TRANSF-PXd
                  pyi2=BETAY*TRANSF-PYd
                  pzi2=BETAZ*TRANSF-PZd
                  p(1,i1)=pxi2
                  p(2,i1)=pyi2
                  p(3,i1)=pzi2
 c     Remove regular pion to check the equivalence 
 c     between the perturbative and regular deuteron results:
 c                 E(i1)=0.
 c
                  LB(I1)=lbm
                  PX1=P(1,I1)
                  PY1=P(2,I1)
                  PZ1=P(3,I1)
                  EM1=E(I1)
                  ID(I1)=2
                  ID1=ID(I1)
                  E1=SQRT(EM1**2+PX1**2+PY1**2+PZ1**2)
                  lb1=lb(i1)
 c     For the regular deuteron:
                  p(1,i2)=pxi1
                  p(2,i2)=pyi1
                  p(3,i2)=pzi1
                  lb(i2)=lbd
                  lb2=lb(i2)
                  E(i2)=xmd
                  EtI2=E(I2)
                  ID(I2)=2
 c     For idpert=2: create the perturbative deuterons:
                  if(idpert.eq.2.and.idloop.eq.ndloop) then
                     do ipertd=1,npertd
                        nnn=nnn+1
                        PPION(1,NNN,IRUN)=ppd(1,ipertd)
                        PPION(2,NNN,IRUN)=ppd(2,ipertd)
                        PPION(3,NNN,IRUN)=ppd(3,ipertd)
                        EPION(NNN,IRUN)=xmd
                        LPION(NNN,IRUN)=lbpd(ipertd)
                        RPION(1,NNN,IRUN)=R(1,I1)
                        RPION(2,NNN,IRUN)=R(2,I1)
                        RPION(3,NNN,IRUN)=R(3,I1)
 clin-6/2008 assign the perturbative probability:
                        dppion(NNN,IRUN)=1./float(npertd)
                     enddo
                  endif
               endif
            enddo
            IBLOCK=501
            return
 clin-6/2008 N+D->Deuteron+pi over
 
       END
 **********************************
 *                                                                      *
 *                                                                      *
       SUBROUTINE CRDD(IRUN,PX,PY,PZ,SRT,I1,I2,IBLOCK,
      1NTAG,SIGNN,SIG,NT,ipert1)
 c     1NTAG,SIGNN,SIG)
 *     PURPOSE:                                                         *
 *             DEALING WITH BARYON RESONANCE-BARYON RESONANCE COLLISIONS*
 *     NOTE   :                                                         *
 *     QUANTITIES:                                                 *
 *           PX,PY,PZ - MOMENTUM COORDINATES OF ONE PARTICLE IN CM FRAME*
 *           SRT      - SQRT OF S                                       *
 *           NSTAR =1 INCLUDING N* RESORANCE,ELSE NOT                   *
 *           NDIRCT=1 INCLUDING DIRECT PION PRODUCTION PROCESS         *
 *           IBLOCK   - THE INFORMATION BACK                            *
 *                      0-> COLLISION CANNOT HAPPEN                     *
 *                      1-> N-N ELASTIC COLLISION                       *
 *                      2-> N+N->N+DELTA,OR N+N->N+N* REACTION          *
 *                      3-> N+DELTA->N+N OR N+N*->N+N REACTION          *
 *                      4-> N+N->N+N+PION,DIRTCT PROCESS                *
 *                     5-> DELTA(N*)+DELTA(N*)   TOTAL   COLLISIONS    *
 *           N12       - IS USED TO SPECIFY BARYON-BARYON REACTION      *
 *                      CHANNELS. M12 IS THE REVERSAL CHANNEL OF N12    *
 *                      N12,                                            *
 *                      M12=1 FOR p+n-->delta(+)+ n                     *
 *                          2     p+n-->delta(0)+ p                     *
 *                          3     p+p-->delta(++)+n                     *
 *                          4     p+p-->delta(+)+p                      *
 *                          5     n+n-->delta(0)+n                      *
 *                          6     n+n-->delta(-)+p                      *
 *                          7     n+p-->N*(0)(1440)+p                   *
 *                          8     n+p-->N*(+)(1440)+n                   *
 *                        9     p+p-->N*(+)(1535)+p                     *
 *                        10    n+n-->N*(0)(1535)+n                     *
 *                         11    n+p-->N*(+)(1535)+n                     *
 *                        12    n+p-->N*(0)(1535)+p
 *                        13    D(++)+D(-)-->N*(+)(1440)+n
 *                         14    D(++)+D(-)-->N*(0)(1440)+p
 *                        15    D(+)+D(0)--->N*(+)(1440)+n
 *                        16    D(+)+D(0)--->N*(0)(1440)+p
 *                        17    D(++)+D(0)-->N*(+)(1535)+p
 *                        18    D(++)+D(-)-->N*(0)(1535)+p
 *                        19    D(++)+D(-)-->N*(+)(1535)+n
 *                        20    D(+)+D(+)-->N*(+)(1535)+p
 *                        21    D(+)+D(0)-->N*(+)(1535)+n
 *                        22    D(+)+D(0)-->N*(0)(1535)+p
 *                        23    D(+)+D(-)-->N*(0)(1535)+n
 *                        24    D(0)+D(0)-->N*(0)(1535)+n
 *                          25    N*(+)(14)+N*(+)(14)-->N*(+)(15)+p
 *                          26    N*(0)(14)+N*(0)(14)-->N*(0)(15)+n
 *                          27    N*(+)(14)+N*(0)(14)-->N*(+)(15)+n
 *                        28    N*(+)(14)+N*(0)(14)-->N*(0)(15)+p
 *                        29    N*(+)(14)+D+-->N*(+)(15)+p
 *                        30    N*(+)(14)+D0-->N*(+)(15)+n
 *                        31    N*(+)(14)+D(-)-->N*(0)(1535)+n
 *                        32    N*(0)(14)+D++--->N*(+)(15)+p
 *                        33    N*(0)(14)+D+--->N*(+)(15)+n
 *                        34    N*(0)(14)+D+--->N*(0)(15)+p
 *                        35    N*(0)(14)+D0-->N*(0)(15)+n
 *                        36    N*(+)(14)+D0--->N*(0)(15)+p
 *                        +++
 *               AND MORE CHANNELS AS LISTED IN THE NOTE BOOK      
 *
 * NOTE ABOUT N*(1440) RESORANCE:                                       *
 *     As it has been discussed in VerWest's paper,I= 1 (initial isospin)
 *     channel can all be attributed to delta resorance while I= 0      *
 *     channel can all be  attribured to N* resorance.Only in n+p       *
 *     one can have I=0 channel so is the N*(1440) resorance            *
 * REFERENCES:    J. CUGNON ET AL., NUCL. PHYS. A352, 505 (1981)        *
 *                    Y. KITAZOE ET AL., PHYS. LETT. 166B, 35 (1986)    *
 *                    B. VerWest el al., PHYS. PRV. C25 (1982)1979      *
 *                    Gy. Wolf  et al, Nucl Phys A517 (1990) 615        *
 *                    CUTOFF = 2 * AVMASS + 20 MEV                      *
 *                                                                      *
 *       for N*(1535) we use the parameterization by Gy. Wolf et al     *
 *       Nucl phys A552 (1993) 349, added May 18, 1994                  *
 **********************************
         PARAMETER (MAXSTR=150001,MAXR=1,AMN=0.939457,
      1  AMP=0.93828,AP1=0.13496,AKA=0.498,APHI=1.020,
      2  AP2=0.13957,AM0=1.232,PI=3.1415926,CUTOFF=1.8966,AVMASS=0.9383)
         parameter     (MX=4,MY=4,MZ=8,MPX=4,MPY=4,mpz=10,mpzp=10)
         parameter (xmd=1.8756,npdmax=10000)
         COMMON /AA/ R(3,MAXSTR)
 cc      SAVE /AA/
         COMMON /BB/ P(3,MAXSTR)
 cc      SAVE /BB/
         COMMON /CC/ E(MAXSTR)
 cc      SAVE /CC/
         COMMON /EE/ ID(MAXSTR),LB(MAXSTR)
 cc      SAVE /EE/
         common /ff/f(-mx:mx,-my:my,-mz:mz,-mpx:mpx,-mpy:mpy,-mpz:mpzp)
 cc      SAVE /ff/
         common /gg/ dx,dy,dz,dpx,dpy,dpz
 cc      SAVE /gg/
         COMMON /INPUT/ NSTAR,NDIRCT,DIR
 cc      SAVE /INPUT/
         COMMON /NN/NNN
 cc      SAVE /NN/
         COMMON /BG/BETAX,BETAY,BETAZ,GAMMA
 cc      SAVE /BG/
         COMMON   /RUN/NUM
 cc      SAVE /RUN/
         COMMON   /PA/RPION(3,MAXSTR,MAXR)
 cc      SAVE /PA/
         COMMON   /PB/PPION(3,MAXSTR,MAXR)
 cc      SAVE /PB/
         COMMON   /PC/EPION(MAXSTR,MAXR)
 cc      SAVE /PC/
         COMMON   /PD/LPION(MAXSTR,MAXR)
 cc      SAVE /PD/
         common/input1/ MASSPR,MASSTA,ISEED,IAVOID,DT
 cc      SAVE /input1/
       common/leadng/lb1,px1,py1,pz1,em1,e1,xfnl,yfnl,zfnl,tfnl,
      1 px1n,py1n,pz1n,dp1n
 cc      SAVE /leadng/
       COMMON/RNDF77/NSEED
 cc      SAVE /RNDF77/
       COMMON /dpert/dpertt(MAXSTR,MAXR),dpertp(MAXSTR),dplast(MAXSTR),
      1     dpdcy(MAXSTR),dpdpi(MAXSTR,MAXR),dpt(MAXSTR, MAXR),
      2     dpp1(MAXSTR,MAXR),dppion(MAXSTR,MAXR)
       common /dpi/em2,lb2
       common /para8/ idpert,npertd,idxsec
       dimension ppd(3,npdmax),lbpd(npdmax)
       SAVE   
 *-----------------------------------------------------------------------
        n12=0
        m12=0
         IBLOCK=0
         NTAG=0
         EM1=E(I1)
         EM2=E(I2)
       PR  = SQRT( PX**2 + PY**2 + PZ**2 )
       C2  = PZ / PR
       IF(PX .EQ. 0.0 .AND. PY .EQ. 0.0) THEN
         T2 = 0.0
       ELSE
         T2=ATAN2(PY,PX)
       END IF
       X1  = RANART(NSEED)
       ianti=0
       if(lb(i1).lt.0 .and. lb(i2).lt.0)ianti=1
 
 clin-6/2008 Production of perturbative deuterons for idpert=1:
       call sbbdm(srt,sdprod,ianti,lbm,xmm,pfinal)
       if(idpert.eq.1.and.ipert1.eq.1) then
          IF (SRT .LT. 2.012) RETURN
          if((iabs(lb(i1)).ge.6.and.iabs(lb(i1)).le.13)
      1        .and.(iabs(lb(i2)).ge.6.and.iabs(lb(i2)).le.13)) then
             goto 108
          else
             return
          endif
       endif
       
 *-----------------------------------------------------------------------
 *COM: TEST FOR ELASTIC SCATTERING (EITHER N-N OR DELTA-DELTA 0R
 *      N-DELTA OR N*-N* or N*-Delta)
       IF (X1 .LE. SIGNN/SIG) THEN
 *COM:  PARAMETRISATION IS TAKEN FROM THE CUGNON-PAPER
         AS  = ( 3.65 * (SRT - 1.8766) )**6
         A   = 6.0 * AS / (1.0 + AS)
         TA  = -2.0 * PR**2
         X   = RANART(NSEED)
 clin-10/24/02        T1  = DLOG( (1-X) * DEXP(dble(A)*dble(TA)) + X )  /  A
         T1  = sngl(DLOG(dble(1.-X)*DEXP(dble(A)*dble(TA))+dble(X)))/  A
         C1  = 1.0 - T1/TA
         T1  = 2.0 * PI * RANART(NSEED)
         IBLOCK=20
        GO TO 107
       ELSE
 *COM: TEST FOR INELASTIC SCATTERING
 *     IF THE AVAILABLE ENERGY IS LESS THAN THE PION-MASS, NOTHING
 *     CAN HAPPEN ANY MORE ==> RETURN (2.15 = 2*AVMASS +2*PI-MASS)
         IF (SRT .LT. 2.15) RETURN
 *     IF THERE WERE 2 N*(1535) AND THEY DIDN'T SCATT. ELAST., 
 *     ALLOW THEM TO PRODUCE KAONS. NO OTHER INELASTIC CHANNELS
 *     ARE KNOWN
 C       if((lb(i1).ge.12).and.(lb(i2).ge.12))return
 *     ALL the inelastic collisions between N*(1535) and Delta as well
 *     as N*(1440) TO PRODUCE KAONS, NO OTHER CHANNELS ARE KNOWN
 C       if((lb(i1).ge.12).and.(lb(i2).ge.3))return
 C       if((lb(i2).ge.12).and.(lb(i1).ge.3))return
 *     calculate the N*(1535) production cross section in I1+I2 collisions
        call N1535(iabs(lb(i1)),iabs(lb(i2)),srt,X1535)
 
 * for Delta+Delta-->N*(1440 OR 1535)+N AND N*(1440)+N*(1440)-->N*(1535)+X 
 *     AND DELTA+N*(1440)-->N*(1535)+X
 * WE ASSUME THEY HAVE THE SAME CROSS SECTIONS as CORRESPONDING N+N COLLISION):
 * FOR D++D0, D+D+,D+D-,D0D0,N*+N*+,N*0N*0,N*(+)D+,N*(+)D(-),N*(0)D(0)
 * N*(1535) production, kaon production and reabsorption through 
 * D(N*)+D(N*)-->NN are ALLOWED.
 * CROSS SECTION FOR KAON PRODUCTION from the four channels are
 * for NLK channel
        akp=0.498
        ak0=0.498
        ana=0.938
        ada=1.232
        al=1.1157
        as=1.1197
        xsk1=0
        xsk2=0
        xsk3=0
        xsk4=0
        xsk5=0
        t1nlk=ana+al+akp
        if(srt.le.t1nlk)go to 222
        XSK1=1.5*PPLPK(SRT)
 * for DLK channel
        t1dlk=ada+al+akp
        t2dlk=ada+al-akp
        if(srt.le.t1dlk)go to 222
        es=srt
        pmdlk2=(es**2-t1dlk**2)*(es**2-t2dlk**2)/(4.*es**2)
        pmdlk=sqrt(pmdlk2)
        XSK3=1.5*PPLPK(srt)
 * for NSK channel
        t1nsk=ana+as+akp
        t2nsk=ana+as-akp
        if(srt.le.t1nsk)go to 222
        pmnsk2=(es**2-t1nsk**2)*(es**2-t2nsk**2)/(4.*es**2)
        pmnsk=sqrt(pmnsk2)
        XSK2=1.5*(PPK1(srt)+PPK0(srt))
 * for DSK channel
        t1DSk=aDa+aS+akp
        t2DSk=aDa+aS-akp
        if(srt.le.t1dsk)go to 222
        pmDSk2=(es**2-t1DSk**2)*(es**2-t2DSk**2)/(4.*es**2)
        pmDSk=sqrt(pmDSk2)
        XSK4=1.5*(PPK1(srt)+PPK0(srt))
 csp11/21/01
 c phi production
        if(srt.le.(2.*amn+aphi))go to 222
 c  !! mb put the correct form
          xsk5 = 0.0001
 csp11/21/01 end
 * THE TOTAL KAON+ PRODUCTION CROSS SECTION IS THEN
 222       SIGK=XSK1+XSK2+XSK3+XSK4
 
 cbz3/7/99 neutralk
         XSK1 = 2.0 * XSK1
         XSK2 = 2.0 * XSK2
         XSK3 = 2.0 * XSK3
         XSK4 = 2.0 * XSK4
         SIGK = 2.0 * SIGK + xsk5
 cbz3/7/99 neutralk end
 
 * The reabsorption cross section for the process
 * D(N*)D(N*)-->NN is
        s2d=reab2d(i1,i2,srt)
 
 cbz3/16/99 pion
         S2D = 0.
 cbz3/16/99 pion end
 
 *(1) N*(1535)+D(N*(1440)) reactions
 *    we allow kaon production and reabsorption only
        if(((iabs(lb(i1)).ge.12).and.(iabs(lb(i2)).ge.12)).OR.
      &       ((iabs(lb(i1)).ge.12).and.(iabs(lb(i2)).ge.6)).OR.
      &       ((iabs(lb(i2)).ge.12).and.(iabs(lb(i1)).ge.6)))THEN
        signd=sigk+s2d
 clin-6/2008
        IF(X1.LE.((SIGNN+sdprod)/SIG)) GO TO 108
 c       if(x1.gt.(signd+signn)/sig)return
        if(x1.gt.(signd+signn+sdprod)/sig)return
 c
 * if kaon production
 clin-6/2008
 c       IF(SIGK/SIG.GE.RANART(NSEED))GO TO 306
        IF((SIGK+sdprod)/SIG.GE.RANART(NSEED))GO TO 306
 c
 * if reabsorption
        go to 1012
        ENDIF
        IDD=iabs(LB(I1)*LB(I2))
 * channels have the same charge as pp 
         IF((IDD.EQ.63).OR.(IDD.EQ.64).OR.(IDD.EQ.48).
      1  OR.(IDD.EQ.49).OR.(IDD.EQ.11*11).OR.(IDD.EQ.10*10).
      2  OR.(IDD.EQ.88).OR.(IDD.EQ.66).
      3  OR.(IDD.EQ.90).OR.(IDD.EQ.70))THEN
         SIGND=X1535+SIGK+s2d
 clin-6/2008
         IF(X1.LE.((SIGNN+sdprod)/SIG)) GO TO 108
 c        IF (X1.GT.(SIGNN+SIGND)/SIG)RETURN
         IF (X1.GT.(SIGNN+SIGND+sdprod)/SIG)RETURN
 c
 * if kaon production
        IF(SIGK/SIGND.GT.RANART(NSEED))GO TO 306
 * if reabsorption
        if(s2d/(x1535+s2d).gt.RANART(NSEED))go to 1012
 * if N*(1535) production
        IF(IDD.EQ.63)N12=17
        IF(IDD.EQ.64)N12=20
        IF(IDD.EQ.48)N12=23
        IF(IDD.EQ.49)N12=24
        IF(IDD.EQ.121)N12=25
        IF(IDD.EQ.100)N12=26
        IF(IDD.EQ.88)N12=29
        IF(IDD.EQ.66)N12=31
        IF(IDD.EQ.90)N12=32
        IF(IDD.EQ.70)N12=35
        GO TO 1011
         ENDIF
 * IN DELTA+N*(1440) and N*(1440)+N*(1440) COLLISIONS, 
 * N*(1535), kaon production and reabsorption are ALLOWED
 * IN N*(1440)+N*(1440) COLLISIONS, ONLY N*(1535) IS ALLOWED
        IF((IDD.EQ.110).OR.(IDD.EQ.77).OR.(IDD.EQ.80))THEN
 clin-6/2008
           IF(X1.LE.((SIGNN+sdprod)/SIG)) GO TO 108
 c       IF(X1.GT.(SIGNN+X1535+SIGK+s2d)/SIG)RETURN
           IF(X1.GT.(SIGNN+X1535+SIGK+s2d+sdprod)/SIG)RETURN
 c
        IF(SIGK/(X1535+SIGK+s2d).GT.RANART(NSEED))GO TO 306
        if(s2d/(x1535+s2d).gt.RANART(NSEED))go to 1012
        IF(IDD.EQ.77)N12=30
        IF((IDD.EQ.77).AND.(RANART(NSEED).LE.0.5))N12=36
        IF(IDD.EQ.80)N12=34
        IF((IDD.EQ.80).AND.(RANART(NSEED).LE.0.5))N12=35
        IF(IDD.EQ.110)N12=27
        IF((IDD.EQ.110).AND.(RANART(NSEED).LE.0.5))N12=28
        GO TO 1011
         ENDIF
        IF((IDD.EQ.54).OR.(IDD.EQ.56))THEN
 * LIKE FOR N+P COLLISION, 
 * IN DELTA+DELTA COLLISIONS BOTH N*(1440) AND N*(1535) CAN BE PRODUCED
         SIG2=(3./4.)*SIGMA(SRT,2,0,1)
         SIGND=2.*(SIG2+X1535)+SIGK+s2d
 clin-6/2008
         IF(X1.LE.((SIGNN+sdprod)/SIG)) GO TO 108
 c        IF(X1.GT.(SIGNN+SIGND)/SIG)RETURN
         IF(X1.GT.(SIGNN+SIGND+sdprod)/SIG)RETURN
 c
        IF(SIGK/SIGND.GT.RANART(NSEED))GO TO 306
        if(s2d/(2.*(sig2+x1535)+s2d).gt.RANART(NSEED))go to 1012
        IF(RANART(NSEED).LT.X1535/(SIG2+X1535))THEN
 * N*(1535) PRODUCTION
        IF(IDD.EQ.54)N12=18
        IF((IDD.EQ.54).AND.(RANART(NSEED).LE.0.5))N12=19
        IF(IDD.EQ.56)N12=21
        IF((IDD.EQ.56).AND.(RANART(NSEED).LE.0.5))N12=22
                ELSE 
 * N*(144) PRODUCTION
        IF(IDD.EQ.54)N12=13
        IF((IDD.EQ.54).AND.(RANART(NSEED).LE.0.5))N12=14
        IF(IDD.EQ.56)N12=15
        IF((IDD.EQ.56).AND.(RANART(NSEED).LE.0.5))N12=16
               ENDIF
        ENDIF
 1011       CONTINUE
        iblock=5
 *PARAMETRIZATION OF THE SHAPE OF THE N*(1440) AND N*(1535) 
 * RESONANCE ACCORDING
 *     TO kitazoe's or J.D.JACKSON'S MASS FORMULA AND BREIT WIGNER
 *     FORMULA FOR N* RESORANCE
 *     DETERMINE DELTA MASS VIA REJECTION METHOD.
           DMAX = SRT - AVMASS-0.005
           DMIN = 1.078
           IF((n12.ge.13).and.(n12.le.16))then
 * N*(1440) production
           IF(DMAX.LT.1.44) THEN
           FM=FNS(DMAX,SRT,0.)
           ELSE
 
 clin-10/25/02 get rid of argument usage mismatch in FNS():
              xdmass=1.44
 c          FM=FNS(1.44,SRT,1.)
           FM=FNS(xdmass,SRT,1.)
 clin-10/25/02-end
 
           ENDIF
           IF(FM.EQ.0.)FM=1.E-09
           NTRY2=0
 11        DM=RANART(NSEED)*(DMAX-DMIN)+DMIN
           NTRY2=NTRY2+1
           IF((RANART(NSEED).GT.FNS(DM,SRT,1.)/FM).AND.
      1    (NTRY2.LE.10)) GO TO 11
 
 clin-2/26/03 limit the N* mass below a certain value 
 c     (here taken as its central value + 2* B-W fullwidth):
           if(dm.gt.2.14) goto 11
 
               GO TO 13
               ENDIF
                     IF((n12.ge.17).AND.(N12.LE.36))then
 * N*(1535) production
           IF(DMAX.LT.1.535) THEN
           FM=FD5(DMAX,SRT,0.)
           ELSE
 
 clin-10/25/02 get rid of argument usage mismatch in FNS():
              xdmass=1.535
 c          FM=FD5(1.535,SRT,1.)
           FM=FD5(xdmass,SRT,1.)
 clin-10/25/02-end
 
           ENDIF
           IF(FM.EQ.0.)FM=1.E-09
           NTRY1=0
 12        DM = RANART(NSEED) * (DMAX-DMIN) + DMIN
           NTRY1=NTRY1+1
           IF((RANART(NSEED) .GT. FD5(DM,SRT,1.)/FM).AND.
      1    (NTRY1.LE.10)) GOTO 12
 
 clin-2/26/03 limit the N* mass below a certain value 
 c     (here taken as its central value + 2* B-W fullwidth):
           if(dm.gt.1.84) goto 12
 
              ENDIF
 13       CONTINUE
 *-------------------------------------------------------
 * RELABLE BARYON I1 AND I2
 *13 D(++)+D(-)--> N*(+)(14)+n
           IF(N12.EQ.13)THEN
           IF(RANART(NSEED).LE.0.5)THEN
           LB(I2)=11
           E(I2)=DM
          LB(I1)=2
          E(I1)=AMN
           ELSE
           LB(I1)=11
           E(I1)=DM
          LB(I2)=2
          E(I2)=AMN
           ENDIF
          go to 200
           ENDIF
 *14 D(++)+D(-)--> N*(0)(14)+P
           IF(N12.EQ.14)THEN
           IF(RANART(NSEED).LE.0.5)THEN
           LB(I2)=10
           E(I2)=DM
          LB(I1)=1
          E(I1)=AMP
           ELSE
           LB(I1)=10
           E(I1)=DM
          LB(I2)=1
          E(I2)=AMP
           ENDIF
          go to 200
           ENDIF
 *15 D(+)+D(0)--> N*(+)(14)+n
           IF(N12.EQ.15)THEN
           IF(RANART(NSEED).LE.0.5)THEN
           LB(I2)=11
           E(I2)=DM
          LB(I1)=2
          E(I1)=AMN
           ELSE
           LB(I1)=11
           E(I1)=DM
          LB(I2)=2
          E(I2)=AMN
           ENDIF
          go to 200
           ENDIF
 *16 D(+)+D(0)--> N*(0)(14)+P
           IF(N12.EQ.16)THEN
           IF(RANART(NSEED).LE.0.5)THEN
           LB(I2)=10
           E(I2)=DM
          LB(I1)=1
          E(I1)=AMP
           ELSE
           LB(I1)=10
           E(I1)=DM
          LB(I2)=1
          E(I2)=AMP
           ENDIF
          go to 200
           ENDIF
 *17 D(++)+D(0)--> N*(+)(14)+P
           IF(N12.EQ.17)THEN
           LB(I2)=13
           E(I2)=DM
          LB(I1)=1
          E(I1)=AMP
          go to 200
           ENDIF
 *18 D(++)+D(-)--> N*(0)(15)+P
           IF(N12.EQ.18)THEN
           IF(RANART(NSEED).LE.0.5)THEN
           LB(I2)=12
           E(I2)=DM
          LB(I1)=1
          E(I1)=AMP
           ELSE
           LB(I1)=12
           E(I1)=DM
          LB(I2)=1
          E(I2)=AMP
           ENDIF
          go to 200
           ENDIF
 *19 D(++)+D(-)--> N*(+)(15)+N
           IF(N12.EQ.19)THEN
           IF(RANART(NSEED).LE.0.5)THEN
           LB(I2)=13
           E(I2)=DM
          LB(I1)=2
          E(I1)=AMN
           ELSE
           LB(I1)=13
           E(I1)=DM
          LB(I2)=2
          E(I2)=AMN
           ENDIF
          go to 200
           ENDIF
 *20 D(+)+D(+)--> N*(+)(15)+P
           IF(N12.EQ.20)THEN
           IF(RANART(NSEED).LE.0.5)THEN
           LB(I2)=13
           E(I2)=DM
          LB(I1)=1
          E(I1)=AMP
           ELSE
           LB(I1)=13
           E(I1)=DM
          LB(I2)=1
          E(I2)=AMP
           ENDIF
          go to 200
           ENDIF
 *21 D(+)+D(0)--> N*(+)(15)+N
           IF(N12.EQ.21)THEN
           IF(RANART(NSEED).LE.0.5)THEN
           LB(I2)=13
           E(I2)=DM
          LB(I1)=2
          E(I1)=AMN
           ELSE
           LB(I1)=13
           E(I1)=DM
          LB(I2)=2
          E(I2)=AMN
           ENDIF
          go to 200
           ENDIF
 *22 D(+)+D(0)--> N*(0)(15)+P
           IF(N12.EQ.22)THEN
           IF(RANART(NSEED).LE.0.5)THEN
           LB(I2)=12
           E(I2)=DM
          LB(I1)=1
          E(I1)=AMP
           ELSE
           LB(I1)=12
           E(I1)=DM
          LB(I2)=1
          E(I2)=AMP
           ENDIF
          go to 200
           ENDIF
 *23 D(+)+D(-)--> N*(0)(15)+N
           IF(N12.EQ.23)THEN
           IF(RANART(NSEED).LE.0.5)THEN
           LB(I2)=12
           E(I2)=DM
          LB(I1)=2
          E(I1)=AMN
           ELSE
           LB(I1)=12
           E(I1)=DM
          LB(I2)=2
          E(I2)=AMN
           ENDIF
          go to 200
           ENDIF
 *24 D(0)+D(0)--> N*(0)(15)+N
           IF(N12.EQ.24)THEN
           LB(I2)=12
           E(I2)=DM
          LB(I1)=2
          E(I1)=AMN
          go to 200
           ENDIF
 *25 N*(+)+N*(+)--> N*(0)(15)+P
           IF(N12.EQ.25)THEN
           LB(I2)=12
           E(I2)=DM
          LB(I1)=1
          E(I1)=AMP
          go to 200
           ENDIF
 *26 N*(0)+N*(0)--> N*(0)(15)+N
           IF(N12.EQ.26)THEN
           LB(I2)=12
           E(I2)=DM
          LB(I1)=2
          E(I1)=AMN
          go to 200
           ENDIF
 *27 N*(+)+N*(0)--> N*(+)(15)+N
           IF(N12.EQ.27)THEN
           IF(RANART(NSEED).LE.0.5)THEN
           LB(I2)=13
           E(I2)=DM
          LB(I1)=2
          E(I1)=AMN
           ELSE
           LB(I1)=13
           E(I1)=DM
          LB(I2)=2
          E(I2)=AMN
           ENDIF
          go to 200
           ENDIF
 *28 N*(+)+N*(0)--> N*(0)(15)+P
           IF(N12.EQ.28)THEN
           IF(RANART(NSEED).LE.0.5)THEN
           LB(I2)=12
           E(I2)=DM
          LB(I1)=1
          E(I1)=AMP
           ELSE
           LB(I1)=12
           E(I1)=DM
          LB(I2)=1
          E(I2)=AMP
           ENDIF
          go to 200
           ENDIF
 *27 N*(+)+N*(0)--> N*(+)(15)+N
           IF(N12.EQ.27)THEN
           IF(RANART(NSEED).LE.0.5)THEN
           LB(I2)=13
           E(I2)=DM
          LB(I1)=2
          E(I1)=AMN
           ELSE
           LB(I1)=13
           E(I1)=DM
          LB(I2)=2
          E(I2)=AMN
           ENDIF
          go to 200
           ENDIF
 *29 N*(+)+D(+)--> N*(+)(15)+P
           IF(N12.EQ.29)THEN
           IF(RANART(NSEED).LE.0.5)THEN
           LB(I2)=13
           E(I2)=DM
          LB(I1)=1
          E(I1)=AMP
           ELSE
           LB(I1)=13
           E(I1)=DM
          LB(I2)=1
          E(I2)=AMP
           ENDIF
          go to 200
           ENDIF
 *30 N*(+)+D(0)--> N*(+)(15)+N
           IF(N12.EQ.30)THEN
           IF(RANART(NSEED).LE.0.5)THEN
           LB(I2)=13
           E(I2)=DM
          LB(I1)=2
          E(I1)=AMN
           ELSE
           LB(I1)=13
           E(I1)=DM
          LB(I2)=2
          E(I2)=AMN
           ENDIF
          go to 200
           ENDIF
 *31 N*(+)+D(-)--> N*(0)(15)+N
           IF(N12.EQ.31)THEN
           IF(RANART(NSEED).LE.0.5)THEN
           LB(I2)=12
           E(I2)=DM
          LB(I1)=2
          E(I1)=AMN
           ELSE
           LB(I1)=12
           E(I1)=DM
          LB(I2)=2
          E(I2)=AMN
           ENDIF
          go to 200
           ENDIF
 *32 N*(0)+D(++)--> N*(+)(15)+P
           IF(N12.EQ.32)THEN
           IF(RANART(NSEED).LE.0.5)THEN
           LB(I2)=13
           E(I2)=DM
          LB(I1)=1
          E(I1)=AMP
           ELSE
           LB(I1)=13
           E(I1)=DM
          LB(I2)=1
          E(I2)=AMP
           ENDIF
          go to 200
           ENDIF
 *33 N*(0)+D(+)--> N*(+)(15)+N
           IF(N12.EQ.33)THEN
           IF(RANART(NSEED).LE.0.5)THEN
           LB(I2)=13
           E(I2)=DM
          LB(I1)=2
          E(I1)=AMN
           ELSE
           LB(I1)=13
           E(I1)=DM
          LB(I2)=2
          E(I2)=AMN
           ENDIF
          go to 200
           ENDIF
 *34 N*(0)+D(+)--> N*(0)(15)+P
           IF(N12.EQ.34)THEN
           IF(RANART(NSEED).LE.0.5)THEN
           LB(I2)=12
           E(I2)=DM
          LB(I1)=1
          E(I1)=AMP
           ELSE
           LB(I1)=12
           E(I1)=DM
          LB(I2)=1
          E(I2)=AMP
           ENDIF
          go to 200
           ENDIF
 *35 N*(0)+D(0)--> N*(0)(15)+N
           IF(N12.EQ.35)THEN
           IF(RANART(NSEED).LE.0.5)THEN
           LB(I2)=12
           E(I2)=DM
          LB(I1)=2
          E(I1)=AMN
           ELSE
           LB(I1)=12
           E(I1)=DM
          LB(I2)=2
          E(I2)=AMN
           ENDIF
          go to 200
           ENDIF
 *36 N*(+)+D(0)--> N*(0)(15)+P
           IF(N12.EQ.36)THEN
           IF(RANART(NSEED).LE.0.5)THEN
           LB(I2)=12
           E(I2)=DM
          LB(I1)=1
          E(I1)=AMP
           ELSE
           LB(I1)=12
           E(I1)=DM
          LB(I2)=1
          E(I2)=AMP
           ENDIF
          go to 200
           ENDIF
 1012         continue
          iblock=55
          lb1=lb(i1)
          lb2=lb(i2)
          ich=iabs(lb1*lb2)
 *-------------------------------------------------------
 * RELABLE BARYON I1 AND I2 in the reabsorption processes
 *37 D(++)+D(-)--> n+p
           IF(ich.EQ.9*6)THEN
           IF(RANART(NSEED).LE.0.5)THEN
           LB(I2)=1
           E(I2)=amp
          LB(I1)=2
          E(I1)=AMN
           ELSE
           LB(I1)=1
           E(I1)=amp
          LB(I2)=2
          E(I2)=AMN
           ENDIF
          go to 200
           ENDIF
 *38 D(+)+D(0)--> n+p
           IF(ich.EQ.8*7)THEN
           IF(RANART(NSEED).LE.0.5)THEN
           LB(I2)=1
           E(I2)=amp
          LB(I1)=2
          E(I1)=AMN
           ELSE
           LB(I1)=1
           E(I1)=amp
          LB(I2)=2
          E(I2)=AMN
           ENDIF
          go to 200
           ENDIF
 *39 D(++)+D(0)--> p+p
           IF(ich.EQ.9*7)THEN
           LB(I2)=1
           E(I2)=amp
          LB(I1)=1
          E(I1)=AMP
          go to 200
           ENDIF
 *40 D(+)+D(+)--> p+p
           IF(ich.EQ.8*8)THEN
           LB(I2)=1
           E(I2)=amp
          LB(I1)=1
          E(I1)=AMP
           go to 200
           ENDIF
 *41 D(+)+D(-)--> n+n
           IF(ich.EQ.8*6)THEN
           LB(I2)=2
           E(I2)=amn
          LB(I1)=2
          E(I1)=AMN
           go to 200
           ENDIF
 *42 D(0)+D(0)--> n+n
           IF(ich.EQ.6*6)THEN
           LB(I2)=2
           E(I2)=amn
          LB(I1)=2
          E(I1)=AMN
          go to 200
           ENDIF
 *43 N*(+)+N*(+)--> p+p
           IF(ich.EQ.11*11.or.ich.eq.13*13.or.ich.eq.11*13)THEN
           LB(I2)=1
           E(I2)=amp
          LB(I1)=1
          E(I1)=AMP
          go to 200
           ENDIF
 *44 N*(0)(1440)+N*(0)--> n+n
           IF(ich.EQ.10*10.or.ich.eq.12*12.or.ich.eq.10*12)THEN
           LB(I2)=2
           E(I2)=amn
          LB(I1)=2
          E(I1)=AMN
          go to 200
           ENDIF
 *45 N*(+)+N*(0)--> n+p
           IF(ich.EQ.10*11.or.ich.eq.12*13.or.ich.
      &    eq.10*13.or.ich.eq.11*12)THEN
           IF(RANART(NSEED).LE.0.5)THEN
           LB(I2)=1
           E(I2)=amp
          LB(I1)=2
          E(I1)=AMN
           ELSE
           LB(I1)=1
           E(I1)=amp
          LB(I2)=2
          E(I2)=AMN
           ENDIF
          go to 200
           ENDIF
 *46 N*(+)+D(+)--> p+p
           IF(ich.eq.11*8.or.ich.eq.13*8)THEN
           LB(I2)=1
           E(I2)=amp
          LB(I1)=1
          E(I1)=AMP
           go to 200
           ENDIF
 *47 N*(+)+D(0)--> n+p
           IF(ich.EQ.11*7.or.ich.eq.13*7)THEN
           IF(RANART(NSEED).LE.0.5)THEN
           LB(I2)=1
           E(I2)=amp
          LB(I1)=2
          E(I1)=AMN
           ELSE
           LB(I1)=1
           E(I1)=amp
          LB(I2)=2
          E(I2)=AMN
           ENDIF
          go to 200
           ENDIF
 *48 N*(+)+D(-)--> n+n
           IF(ich.EQ.11*6.or.ich.eq.13*6)THEN
           LB(I2)=2
           E(I2)=amn
          LB(I1)=2
          E(I1)=AMN
           go to 200
           ENDIF
 *49 N*(0)+D(++)--> p+p
           IF(ich.EQ.10*9.or.ich.eq.12*9)THEN
           LB(I2)=1
           E(I2)=amp
          LB(I1)=1
          E(I1)=AMP
          go to 200
           ENDIF
 *50 N*(0)+D(0)--> n+n
           IF(ich.EQ.10*7.or.ich.eq.12*7)THEN
           LB(I2)=2
           E(I2)=amn
          LB(I1)=2
          E(I1)=AMN
           go to 200
           ENDIF
 *51 N*(0)+D(+)--> n+p
           IF(ich.EQ.10*8.or.ich.eq.12*8)THEN
           IF(RANART(NSEED).LE.0.5)THEN
           LB(I2)=2
           E(I2)=amn
          LB(I1)=1
          E(I1)=AMP
           ELSE
           LB(I1)=2
           E(I1)=amn
          LB(I2)=1
          E(I2)=AMP
           ENDIF
          go to 200
           ENDIF
          lb(i1)=1
          e(i1)=amp
          lb(i2)=2
          e(i2)=amn
 * CALCULATE THE MAGNITUDE OF THE FINAL MOMENTUM THROUGH
 * ENERGY CONSERVATION
 * resonance production or absorption in resonance+resonance collisions is
 * assumed to have the same pt distribution as pp
 200       EM1=E(I1)
           EM2=E(I2)
           PR2   = (SRT**2 - EM1**2 - EM2**2)**2
      1                - 4.0 * (EM1*EM2)**2
           IF(PR2.LE.0.)PR2=1.e-09
           PR=SQRT(PR2)/(2.*SRT)
              if(srt.le.2.14)C1= 1.0 - 2.0 * RANART(NSEED)
          if(srt.gt.2.14.and.srt.le.2.4)c1=ang(srt,iseed)       
          if(srt.gt.2.4)then
 
 clin-10/25/02 get rid of argument usage mismatch in PTR():
              xptr=0.33*pr
 c         cc1=ptr(0.33*pr,iseed)
          cc1=ptr(xptr,iseed)
 clin-10/25/02-end
 
 clin-9/2012: check argument in sqrt():
          scheck=pr**2-cc1**2
          if(scheck.lt.0) then
             write(99,*) 'scheck7: ', scheck
             scheck=0.
          endif
          c1=sqrt(scheck)/pr
 c         c1=sqrt(pr**2-cc1**2)/pr
 
          endif
           T1   = 2.0 * PI * RANART(NSEED)
        if(ianti.eq.1 .and. lb(i1).ge.1 .and. lb(i2).ge.1)then
          lb(i1) = -lb(i1)
          lb(i2) = -lb(i2)
        endif
          ENDIF
 *COM: SET THE NEW MOMENTUM COORDINATES
 
 clin-9/2012: check argument in sqrt():
  107     scheck=1.0 - C1**2
          if(scheck.lt.0) then
             write(99,*) 'scheck8: ', scheck
             scheck=0.
          endif
          S1=SQRT(scheck)
 c107   S1   = SQRT( 1.0 - C1**2 )
 
 clin-9/2012: check argument in sqrt():
       scheck=1.0 - C2**2
       if(scheck.lt.0) then
          write(99,*) 'scheck9: ', scheck
          scheck=0.
       endif
       S2=SQRT(scheck)
 c      S2  =  SQRT( 1.0 - C2**2 )
 
       CT1  = COS(T1)
       ST1  = SIN(T1)
       CT2  = COS(T2)
       ST2  = SIN(T2)
       PZ   = PR * ( C1*C2 - S1*S2*CT1 )
       SS   = C2 * S1 * CT1  +  S2 * C1
       PX   = PR * ( SS*CT2 - S1*ST1*ST2 )
       PY   = PR * ( SS*ST2 + S1*ST1*CT2 )
       RETURN
 * FOR THE DD-->KAON+X PROCESS, FIND MOMENTUM OF THE FINAL PARTICLES IN 
 * THE NUCLEUS-NUCLEUS CMS.
 306     CONTINUE
 csp11/21/01 phi production
               if(XSK5/sigK.gt.RANART(NSEED))then
               pz1=p(3,i1)
               pz2=p(3,i2)
                 LB(I1) = 1 + int(2 * RANART(NSEED))
                 LB(I2) = 1 + int(2 * RANART(NSEED))
               nnn=nnn+1
                 LPION(NNN,IRUN)=29
                 EPION(NNN,IRUN)=APHI
                 iblock = 222
               GO TO 208
                ENDIF
               iblock=10
                 if(ianti .eq. 1)iblock=-10
               pz1=p(3,i1)
               pz2=p(3,i2)
 * DETERMINE THE CHARGE STATES OF PARTICLES IN THE FINAL STATE
               nnn=nnn+1
                 LPION(NNN,IRUN)=23
                 EPION(NNN,IRUN)=Aka
               if(srt.le.2.63)then
 * only lambda production is possible
 * (1.1)P+P-->p+L+kaon+
               ic=1
                 LB(I1) = 1 + int(2 * RANART(NSEED))
               LB(I2)=14
               GO TO 208
                 ENDIF
        if(srt.le.2.74.and.srt.gt.2.63)then
 * both Lambda and sigma production are possible
               if(XSK1/(XSK1+XSK2).gt.RANART(NSEED))then
 * lambda production
               ic=1
                 LB(I1) = 1 + int(2 * RANART(NSEED))
               LB(I2)=14
               else
 * sigma production
                 LB(I1) = 1 + int(2 * RANART(NSEED))
                 LB(I2) = 15 + int(3 * RANART(NSEED))
               ic=2
               endif
               GO TO 208
        endif
        if(srt.le.2.77.and.srt.gt.2.74)then
 * then pp-->Delta lamda kaon can happen
               if(xsk1/(xsk1+xsk2+xsk3).gt.RANART(NSEED))then
 * * (1.1)P+P-->p+L+kaon+
               ic=1
                 LB(I1) = 1 + int(2 * RANART(NSEED))
               LB(I2)=14
               go to 208
               else
               if(xsk2/(xsk2+xsk3).gt.RANART(NSEED))then
 * pp-->psk
               ic=2
                 LB(I1) = 1 + int(2 * RANART(NSEED))
                 LB(I2) = 15 + int(3 * RANART(NSEED))
               else
 * pp-->D+l+k        
               ic=3
                 LB(I1) = 6 + int(4 * RANART(NSEED))
               lb(i2)=14
               endif
               GO TO 208
               endif
        endif
        if(srt.gt.2.77)then
 * all four channels are possible
               if(xsk1/(xsk1+xsk2+xsk3+xsk4).gt.RANART(NSEED))then
 * p lambda k production
               ic=1
                 LB(I1) = 1 + int(2 * RANART(NSEED))
               LB(I2)=14
               go to 208
        else
           if(xsk3/(xsk2+xsk3+xsk4).gt.RANART(NSEED))then
 * delta l K production
               ic=3
                 LB(I1) = 6 + int(4 * RANART(NSEED))
               lb(i2)=14
               go to 208
           else
               if(xsk2/(xsk2+xsk4).gt.RANART(NSEED))then
 * n sigma k production
                 LB(I1) = 1 + int(2 * RANART(NSEED))
                 LB(I2) = 15 + int(3 * RANART(NSEED))
               ic=2
               else
 * D sigma K
               ic=4
                 LB(I1) = 6 + int(4 * RANART(NSEED))
                 LB(I2) = 15 + int(3 * RANART(NSEED))
               endif
               go to 208
           endif
        endif
        endif
 208             continue
          if(ianti.eq.1 .and. lb(i1).ge.1 .and. lb(i2).ge.1)then
           lb(i1) = - lb(i1)
           lb(i2) = - lb(i2)
           if(LPION(NNN,IRUN) .eq. 23)LPION(NNN,IRUN)=21
          endif
        lbi1=lb(i1)
        lbi2=lb(i2)
 * KEEP ALL COORDINATES OF PARTICLE 2 FOR POSSIBLE PHASE SPACE CHANGE
            NTRY1=0
 129        CALL BBKAON(ic,SRT,PX3,PY3,PZ3,DM3,PX4,PY4,PZ4,DM4,
      &  PPX,PPY,PPZ,icou1)
        NTRY1=NTRY1+1
        if((icou1.lt.0).AND.(NTRY1.LE.20))GO TO 129
 c       if(icou1.lt.0)return
 * ROTATE THE MOMENTA OF PARTICLES IN THE CMS OF P1+P2
        CALL ROTATE(PX,PY,PZ,PX3,PY3,PZ3)
        CALL ROTATE(PX,PY,PZ,PX4,PY4,PZ4)
        CALL ROTATE(PX,PY,PZ,PPX,PPY,PPZ)
 * FIND THE MOMENTUM OF PARTICLES IN THE FINAL STATE IN THE NUCLEUS-
 * NUCLEUS CMS. FRAME 
 * (1) for the necleon/delta
 *             LORENTZ-TRANSFORMATION INTO LAB FRAME FOR DELTA1
               E1CM    = SQRT (dm3**2 + PX3**2 + PY3**2 + PZ3**2)
               P1BETA  = PX3*BETAX + PY3*BETAY + PZ3*BETAZ
               TRANSF  = GAMMA * ( GAMMA * P1BETA / (GAMMA + 1) + E1CM )
               Pt1i1 = BETAX * TRANSF + PX3
               Pt2i1 = BETAY * TRANSF + PY3
               Pt3i1 = BETAZ * TRANSF + PZ3
              Eti1   = DM3
 * (2) for the lambda/sigma
                 E2CM    = SQRT (dm4**2 + PX4**2 + PY4**2 + PZ4**2)
                 P2BETA  = PX4*BETAX+PY4*BETAY+PZ4*BETAZ
                 TRANSF  = GAMMA * (GAMMA*P2BETA / (GAMMA + 1.) + E2CM)
                 Pt1I2 = BETAX * TRANSF + PX4
                 Pt2I2 = BETAY * TRANSF + PY4
                 Pt3I2 = BETAZ * TRANSF + PZ4
               EtI2   = DM4
 * GET the kaon'S MOMENTUM AND COORDINATES IN NUCLEUS-NUCLEUS CMS. FRAME
                 EPCM=SQRT(aka**2+PPX**2+PPY**2+PPZ**2)
                 PPBETA=PPX*BETAX+PPY*BETAY+PPZ*BETAZ
                 TRANSF=GAMMA*(GAMMA*PPBETA/(GAMMA+1.)+EPCM)
                 PPION(1,NNN,IRUN)=BETAX*TRANSF+PPX
                 PPION(2,NNN,IRUN)=BETAY*TRANSF+PPY
                 PPION(3,NNN,IRUN)=BETAZ*TRANSF+PPZ
 clin-5/2008:
                 dppion(nnn,irun)=dpertp(i1)*dpertp(i2)
 clin-5/2008:
 c2007        X01 = 1.0 - 2.0 * RANART(NSEED)
 c            Y01 = 1.0 - 2.0 * RANART(NSEED)
 c            Z01 = 1.0 - 2.0 * RANART(NSEED)
 c        IF ((X01*X01+Y01*Y01+Z01*Z01) .GT. 1.0) GOTO 2007
 c                RPION(1,NNN,IRUN)=R(1,I1)+0.5*x01
 c                RPION(2,NNN,IRUN)=R(2,I1)+0.5*y01
 c                RPION(3,NNN,IRUN)=R(3,I1)+0.5*z01
                     RPION(1,NNN,IRUN)=R(1,I1)
                     RPION(2,NNN,IRUN)=R(2,I1)
                     RPION(3,NNN,IRUN)=R(3,I1)
 c
 * assign the nucleon/delta and lambda/sigma to i1 or i2 to keep the 
 * leadng particle behaviour
 C              if((pt1i1*px1+pt2i1*py1+pt3i1*pz1).gt.0)then
               p(1,i1)=pt1i1
               p(2,i1)=pt2i1
               p(3,i1)=pt3i1
               e(i1)=eti1
               lb(i1)=lbi1
               p(1,i2)=pt1i2
               p(2,i2)=pt2i2
               p(3,i2)=pt3i2
               e(i2)=eti2
               lb(i2)=lbi2
                 PX1     = P(1,I1)
                 PY1     = P(2,I1)
                 PZ1     = P(3,I1)
               EM1       = E(I1)
                 ID(I1)  = 2
                 ID(I2)  = 2
                 ID1     = ID(I1)
         LB1=LB(I1)
         LB2=LB(I2)
         AM1=EM1
        am2=em2
         E1= SQRT( EM1**2 + PX1**2 + PY1**2 + PZ1**2 )
        RETURN
 
 clin-6/2008 D+D->Deuteron+pi:
 *     FIND MOMENTUM OF THE FINAL PARTICLES IN THE NUCLEUS-NUCLEUS CMS.
  108   CONTINUE
            if(idpert.eq.1.and.ipert1.eq.1.and.npertd.ge.1) then
 c     For idpert=1: we produce npertd pert deuterons:
               ndloop=npertd
            elseif(idpert.eq.2.and.npertd.ge.1) then
 c     For idpert=2: we first save information for npertd pert deuterons;
 c     at the last ndloop we create the regular deuteron+pi 
 c     and those pert deuterons:
               ndloop=npertd+1
            else
 c     Just create the regular deuteron+pi:
               ndloop=1
            endif
 c
            dprob1=sdprod/sig/float(npertd)
            do idloop=1,ndloop
               CALL bbdangle(pxd,pyd,pzd,nt,ipert1,ianti,idloop,pfinal,
      1 dprob1,lbm)
               CALL ROTATE(PX,PY,PZ,PXd,PYd,PZd)
 *     LORENTZ-TRANSFORMATION OF THE MOMENTUM OF PARTICLES IN THE FINAL STATE 
 *     FROM THE NN CMS FRAME INTO THE GLOBAL CMS FRAME:
 *     For the Deuteron:
               xmass=xmd
               E1dCM=SQRT(xmass**2+PXd**2+PYd**2+PZd**2)
               P1dBETA=PXd*BETAX+PYd*BETAY+PZd*BETAZ
               TRANSF=GAMMA*(GAMMA*P1dBETA/(GAMMA+1.)+E1dCM)
               pxi1=BETAX*TRANSF+PXd
               pyi1=BETAY*TRANSF+PYd
               pzi1=BETAZ*TRANSF+PZd
               if(ianti.eq.0)then
                  lbd=42
               else
                  lbd=-42
               endif
               if(idpert.eq.1.and.ipert1.eq.1.and.npertd.ge.1) then
 cccc  Perturbative production for idpert=1:
                  nnn=nnn+1
                  PPION(1,NNN,IRUN)=pxi1
                  PPION(2,NNN,IRUN)=pyi1
                  PPION(3,NNN,IRUN)=pzi1
                  EPION(NNN,IRUN)=xmd
                  LPION(NNN,IRUN)=lbd
                  RPION(1,NNN,IRUN)=R(1,I1)
                  RPION(2,NNN,IRUN)=R(2,I1)
                  RPION(3,NNN,IRUN)=R(3,I1)
 clin-6/2008 assign the perturbative probability:
                  dppion(NNN,IRUN)=sdprod/sig/float(npertd)
               elseif(idpert.eq.2.and.idloop.le.npertd) then
 clin-6/2008 For idpert=2, we produce NPERTD perturbative (anti)deuterons 
 c     only when a regular (anti)deuteron+pi is produced in NN collisions.
 c     First save the info for the perturbative deuterons:
                  ppd(1,idloop)=pxi1
                  ppd(2,idloop)=pyi1
                  ppd(3,idloop)=pzi1
                  lbpd(idloop)=lbd
               else
 cccc  Regular production:
 c     For the regular pion: do LORENTZ-TRANSFORMATION:
                  E(i1)=xmm
                  E2piCM=SQRT(xmm**2+PXd**2+PYd**2+PZd**2)
                  P2piBETA=-PXd*BETAX-PYd*BETAY-PZd*BETAZ
                  TRANSF=GAMMA*(GAMMA*P2piBETA/(GAMMA+1.)+E2piCM)
                  pxi2=BETAX*TRANSF-PXd
                  pyi2=BETAY*TRANSF-PYd
                  pzi2=BETAZ*TRANSF-PZd
                  p(1,i1)=pxi2
                  p(2,i1)=pyi2
                  p(3,i1)=pzi2
 c     Remove regular pion to check the equivalence 
 c     between the perturbative and regular deuteron results:
 c                 E(i1)=0.
 c
                  LB(I1)=lbm
                  PX1=P(1,I1)
                  PY1=P(2,I1)
                  PZ1=P(3,I1)
                  EM1=E(I1)
                  ID(I1)=2
                  ID1=ID(I1)
                  E1=SQRT(EM1**2+PX1**2+PY1**2+PZ1**2)
                  lb1=lb(i1)
 c     For the regular deuteron:
                  p(1,i2)=pxi1
                  p(2,i2)=pyi1
                  p(3,i2)=pzi1
                  lb(i2)=lbd
                  lb2=lb(i2)
                  E(i2)=xmd
                  EtI2=E(I2)
                  ID(I2)=2
 c     For idpert=2: create the perturbative deuterons:
                  if(idpert.eq.2.and.idloop.eq.ndloop) then
                     do ipertd=1,npertd
                        nnn=nnn+1
                        PPION(1,NNN,IRUN)=ppd(1,ipertd)
                        PPION(2,NNN,IRUN)=ppd(2,ipertd)
                        PPION(3,NNN,IRUN)=ppd(3,ipertd)
                        EPION(NNN,IRUN)=xmd
                        LPION(NNN,IRUN)=lbpd(ipertd)
                        RPION(1,NNN,IRUN)=R(1,I1)
                        RPION(2,NNN,IRUN)=R(2,I1)
                        RPION(3,NNN,IRUN)=R(3,I1)
 clin-6/2008 assign the perturbative probability:
                        dppion(NNN,IRUN)=1./float(npertd)
                     enddo
                  endif
               endif
            enddo
            IBLOCK=501
            return
 clin-6/2008 D+D->Deuteron+pi over
 
         END
 **********************************
 **********************************
 *                                                                      *
       SUBROUTINE INIT(MINNUM,MAXNUM,NUM,RADIUS,X0,Z0,P0,
      &                GAMMA,ISEED,MASS,IOPT)
 *                                                                      *
 *       PURPOSE:     PROVIDING INITIAL CONDITIONS FOR PHASE-SPACE      *
 *                    DISTRIBUTION OF TESTPARTICLES                     *
 *       VARIABLES:   (ALL INPUT)                                       *
 *         MINNUM  - FIRST TESTPARTICLE TREATED IN ONE RUN    (INTEGER) *
 *         MAXNUM  - LAST TESTPARTICLE TREATED IN ONE RUN     (INTEGER) *
 *         NUM     - NUMBER OF TESTPARTICLES PER NUCLEON      (INTEGER) *
 *         RADIUS  - RADIUS OF NUCLEUS "FM"                      (REAL) *
 *         X0,Z0   - DISPLACEMENT OF CENTER OF NUCLEUS IN X,Z-          *
 *                   DIRECTION "FM"                              (REAL) *
 *         P0      - MOMENTUM-BOOST IN C.M. FRAME "GEV/C"        (REAL) *
 *         GAMMA   - RELATIVISTIC GAMMA-FACTOR                   (REAL) *
 *         ISEED   - SEED FOR RANDOM-NUMBER GENERATOR         (INTEGER) *
 *         MASS    - TOTAL MASS OF THE SYSTEM                 (INTEGER) *
 *         IOPT    - OPTION FOR DIFFERENT OCCUPATION OF MOMENTUM        *
 *                   SPACE                                    (INTEGER) *
 *                                                                      *
 **********************************
       PARAMETER     (MAXSTR=150001,  AMU   = 0.9383)
       PARAMETER     (MAXX   =   20,  MAXZ  =    24)
       PARAMETER     (PI=3.1415926)
 *
       REAL              PTOT(3)
       COMMON  /AA/      R(3,MAXSTR)
 cc      SAVE /AA/
       COMMON  /BB/      P(3,MAXSTR)
 cc      SAVE /BB/
       COMMON  /CC/      E(MAXSTR)
 cc      SAVE /CC/
       COMMON  /DD/      RHO(-MAXX:MAXX,-MAXX:MAXX,-MAXZ:MAXZ),
      &                     RHOP(-MAXX:MAXX,-MAXX:MAXX,-MAXZ:MAXZ),
      &                     RHON(-MAXX:MAXX,-MAXX:MAXX,-MAXZ:MAXZ)
 cc      SAVE /DD/
       COMMON  /EE/      ID(MAXSTR),LB(MAXSTR)
 cc      SAVE /EE/
       common  /ss/      inout(20)
 cc      SAVE /ss/
       COMMON/RNDF77/NSEED
 cc      SAVE /RNDF77/
       SAVE   
 *----------------------------------------------------------------------
 *     PREPARATION FOR LORENTZ-TRANSFORMATIONS
 *
       IF (P0 .NE. 0.) THEN
         SIGN = P0 / ABS(P0)
       ELSE
         SIGN = 0.
       END IF
 
 clin-9/2012: check argument in sqrt():
       scheck=GAMMA**2-1.
       if(scheck.lt.0) then
          write(99,*) 'scheck10: ', scheck
          scheck=0.
       endif
       BETA=SIGN*SQRT(scheck)/GAMMA
 c      BETA = SIGN * SQRT(GAMMA**2-1.)/GAMMA
 
 *-----------------------------------------------------------------------
 *     TARGET-ID = 1 AND PROJECTILE-ID = -1
 *
       IF (MINNUM .EQ. 1) THEN
         IDNUM = 1
       ELSE
         IDNUM = -1
       END IF
 *-----------------------------------------------------------------------
 *     IDENTIFICATION OF TESTPARTICLES AND ASSIGMENT OF RESTMASS
 *
 *     LOOP OVER ALL PARALLEL RUNS:
       DO 400 IRUN = 1,NUM
         DO 100 I = MINNUM+(IRUN-1)*MASS,MAXNUM+(IRUN-1)*MASS
           ID(I) = IDNUM
           E(I)  = AMU
   100   CONTINUE
 *-----------------------------------------------------------------------
 *       OCCUPATION OF COORDINATE-SPACE
 *
         DO 300 I = MINNUM+(IRUN-1)*MASS,MAXNUM+(IRUN-1)*MASS
   200     CONTINUE
             X = 1.0 - 2.0 * RANART(NSEED)
             Y = 1.0 - 2.0 * RANART(NSEED)
             Z = 1.0 - 2.0 * RANART(NSEED)
           IF ((X*X+Y*Y+Z*Z) .GT. 1.0) GOTO 200
           R(1,I) = X * RADIUS
           R(2,I) = Y * RADIUS
           R(3,I) = Z * RADIUS
   300   CONTINUE
   400 CONTINUE
 *=======================================================================
       IF (IOPT .NE. 3) THEN
 *-----
 *     OPTION 1: USE WOODS-SAXON PARAMETRIZATION FOR DENSITY AND
 *-----          CALCULATE LOCAL FERMI-MOMENTUM
 *
         RHOW0  = 0.168
         DO 1000 IRUN = 1,NUM
           DO 600 I = MINNUM+(IRUN-1)*MASS,MAXNUM+(IRUN-1)*MASS
   500       CONTINUE
               PX = 1.0 - 2.0 * RANART(NSEED)
               PY = 1.0 - 2.0 * RANART(NSEED)
               PZ = 1.0 - 2.0 * RANART(NSEED)
             IF (PX*PX+PY*PY+PZ*PZ .GT. 1.0) GOTO 500
             RDIST  = SQRT( R(1,I)**2 + R(2,I)**2 + R(3,I)**2 )
             RHOWS  = RHOW0 / (  1.0 + EXP( (RDIST-RADIUS) / 0.55 )  )
             PFERMI = 0.197 * (1.5 * PI*PI * RHOWS)**(1./3.)
 *-----
 *     OPTION 2: NUCLEAR MATTER CASE
             IF(IOPT.EQ.2) PFERMI=0.27
            if(iopt.eq.4) pfermi=0.
 *-----
             P(1,I) = PFERMI * PX
             P(2,I) = PFERMI * PY
             P(3,I) = PFERMI * PZ
   600     CONTINUE
 *
 *         SET TOTAL MOMENTUM TO 0 IN REST FRAME AND BOOST
 *
           DO 700 IDIR = 1,3
             PTOT(IDIR) = 0.0
   700     CONTINUE
           NPART = 0
           DO 900 I = MINNUM+(IRUN-1)*MASS,MAXNUM+(IRUN-1)*MASS
             NPART = NPART + 1
             DO 800 IDIR = 1,3
               PTOT(IDIR) = PTOT(IDIR) + P(IDIR,I)
   800       CONTINUE
   900     CONTINUE
           DO 950 I = MINNUM+(IRUN-1)*MASS,MAXNUM+(IRUN-1)*MASS
             DO 925 IDIR = 1,3
               P(IDIR,I) = P(IDIR,I) - PTOT(IDIR) / FLOAT(NPART)
   925       CONTINUE
 *           BOOST
             IF ((IOPT .EQ. 1).or.(iopt.eq.2)) THEN
               EPART = SQRT(P(1,I)**2+P(2,I)**2+P(3,I)**2+AMU**2)
               P(3,I) = GAMMA*(P(3,I) + BETA*EPART)
             ELSE
               P(3,I) = P(3,I) + P0
             END IF
   950     CONTINUE
  1000   CONTINUE
 *-----
       ELSE
 *-----
 *     OPTION 3: GIVE ALL NUCLEONS JUST A Z-MOMENTUM ACCORDING TO
 *               THE BOOST OF THE NUCLEI
 *
         DO 1200 IRUN = 1,NUM
           DO 1100 I = MINNUM+(IRUN-1)*MASS,MAXNUM+(IRUN-1)*MASS
             P(1,I) = 0.0
             P(2,I) = 0.0
             P(3,I) = P0
  1100     CONTINUE
  1200   CONTINUE
 *-----
       END IF
 *=======================================================================
 *     PUT PARTICLES IN THEIR POSITION IN COORDINATE-SPACE
 *     (SHIFT AND RELATIVISTIC CONTRACTION)
 *
       DO 1400 IRUN = 1,NUM
         DO 1300 I = MINNUM+(IRUN-1)*MASS,MAXNUM+(IRUN-1)*MASS
           R(1,I) = R(1,I) + X0
 * two nuclei in touch after contraction
           R(3,I) = (R(3,I)+Z0)/ GAMMA 
 * two nuclei in touch before contraction
 c          R(3,I) = R(3,I) / GAMMA + Z0
  1300   CONTINUE
  1400 CONTINUE
 *
       RETURN
       END
 **********************************
 *                                                                      *
       SUBROUTINE DENS(IPOT,MASS,NUM,NESC)
 *                                                                      *
 *       PURPOSE:     CALCULATION OF LOCAL BARYON, MESON AND ENERGY     * 
 *                    DENSITY FROM SPATIAL DISTRIBUTION OF TESTPARTICLES*
 *                                                                      *
 *       VARIABLES (ALL INPUT, ALL INTEGER)                             *
 *         MASS    -  MASS NUMBER OF THE SYSTEM                         *
 *         NUM     -  NUMBER OF TESTPARTICLES PER NUCLEON               *
 *                                                                      *
 *         NESC    -  NUMBER OF ESCAPED PARTICLES      (INTEGER,OUTPUT) *
 *                                                                      *
 **********************************
       PARAMETER     (MAXSTR= 150001,MAXR=1)
       PARAMETER     (MAXX   =    20,  MAXZ  =    24)
 *
       dimension pxl(-maxx:maxx,-maxx:maxx,-maxz:maxz),
      1          pyl(-maxx:maxx,-maxx:maxx,-maxz:maxz),
      2          pzl(-maxx:maxx,-maxx:maxx,-maxz:maxz)
       COMMON  /AA/      R(3,MAXSTR)
 cc      SAVE /AA/
       COMMON  /BB/      P(3,MAXSTR)
 cc      SAVE /BB/
       COMMON  /CC/      E(MAXSTR)
 cc      SAVE /CC/
       COMMON  /DD/      RHO(-MAXX:MAXX,-MAXX:MAXX,-MAXZ:MAXZ),
      &                     RHOP(-MAXX:MAXX,-MAXX:MAXX,-MAXZ:MAXZ),
      &                     RHON(-MAXX:MAXX,-MAXX:MAXX,-MAXZ:MAXZ)
 cc      SAVE /DD/
       COMMON  /DDpi/    piRHO(-MAXX:MAXX,-MAXX:MAXX,-MAXZ:MAXZ)
 cc      SAVE /DDpi/
       COMMON  /EE/      ID(MAXSTR),LB(MAXSTR)
 cc      SAVE /EE/
       common  /ss/  inout(20)
 cc      SAVE /ss/
       COMMON  /RR/  MASSR(0:MAXR)
 cc      SAVE /RR/
       common  /tt/  PEL(-maxx:maxx,-maxx:maxx,-maxz:maxz)
      &,rxy(-maxx:maxx,-maxx:maxx,-maxz:maxz)
 cc      SAVE /tt/
       common  /bbb/ bxx(-maxx:maxx,-maxx:maxx,-maxz:maxz),
      &byy(-maxx:maxx,-maxx:maxx,-maxz:maxz),
      &bzz(-maxx:maxx,-maxx:maxx,-maxz:maxz)
 *
       real zet(-45:45)
       SAVE   
       data zet /
      4     1.,0.,0.,0.,0.,
      3     1.,0.,0.,0.,0.,0.,0.,0.,0.,0.,
      2     -1.,0.,0.,0.,0.,0.,0.,0.,0.,0.,
      1     0.,0.,0.,-1.,0.,1.,0.,-1.,0.,-1.,
      s     0.,-2.,-1.,0.,1.,0.,0.,0.,0.,-1.,
      e     0.,
      s     1.,0.,-1.,0.,1.,-1.,0.,1.,2.,0.,
      1     1.,0.,1.,0.,-1.,0.,1.,0.,0.,0.,
      2     -1.,0.,1.,0.,-1.,0.,1.,0.,0.,1.,
      3     0.,0.,0.,0.,0.,0.,0.,0.,0.,-1.,
      4     0.,0.,0.,0.,-1./
 
       DO 300 IZ = -MAXZ,MAXZ
         DO 200 IY = -MAXX,MAXX
           DO 100 IX = -MAXX,MAXX
             RHO(IX,IY,IZ) = 0.0
             RHOn(IX,IY,IZ) = 0.0
             RHOp(IX,IY,IZ) = 0.0
             piRHO(IX,IY,IZ) = 0.0
            pxl(ix,iy,iz) = 0.0
            pyl(ix,iy,iz) = 0.0
            pzl(ix,iy,iz) = 0.0
            pel(ix,iy,iz) = 0.0
            bxx(ix,iy,iz) = 0.0
            byy(ix,iy,iz) = 0.0
            bzz(ix,iy,iz) = 0.0
   100     CONTINUE
   200   CONTINUE
   300 CONTINUE
 *
       NESC  = 0
       BIG   = 1.0 / ( 3.0 * FLOAT(NUM) )
       SMALL = 1.0 / ( 9.0 * FLOAT(NUM) )
 *
       MSUM=0
       DO 400 IRUN = 1,NUM
       MSUM=MSUM+MASSR(IRUN-1)
       DO 400 J=1,MASSr(irun)
       I=J+MSUM
         IX = NINT( R(1,I) )
         IY = NINT( R(2,I) )
         IZ = NINT( R(3,I) )
         IF( IX .LE. -MAXX .OR. IX .GE. MAXX .OR.
      &      IY .LE. -MAXX .OR. IY .GE. MAXX .OR.
      &      IZ .LE. -MAXZ .OR. IZ .GE. MAXZ )    THEN
           NESC = NESC + 1
         ELSE
 c
 csp01/04/02 include baryon density
           if(j.gt.mass)go to 30
 c         if( (lb(i).eq.1.or.lb(i).eq.2) .or.
 c    &    (lb(i).ge.6.and.lb(i).le.17) )then                       
 * (1) baryon density
           RHO(IX,  IY,  IZ  ) = RHO(IX,  IY,  IZ  ) + BIG
           RHO(IX+1,IY,  IZ  ) = RHO(IX+1,IY,  IZ  ) + SMALL
           RHO(IX-1,IY,  IZ  ) = RHO(IX-1,IY,  IZ  ) + SMALL
           RHO(IX,  IY+1,IZ  ) = RHO(IX,  IY+1,IZ  ) + SMALL
           RHO(IX,  IY-1,IZ  ) = RHO(IX,  IY-1,IZ  ) + SMALL
           RHO(IX,  IY,  IZ+1) = RHO(IX,  IY,  IZ+1) + SMALL
           RHO(IX,  IY,  IZ-1) = RHO(IX,  IY,  IZ-1) + SMALL
 * (2) CALCULATE THE PROTON DENSITY
          IF(ZET(LB(I)).NE.0)THEN
           RHOP(IX,  IY,  IZ  ) = RHOP(IX,  IY,  IZ  ) + BIG
           RHOP(IX+1,IY,  IZ  ) = RHOP(IX+1,IY,  IZ  ) + SMALL
           RHOP(IX-1,IY,  IZ  ) = RHOP(IX-1,IY,  IZ  ) + SMALL
           RHOP(IX,  IY+1,IZ  ) = RHOP(IX,  IY+1,IZ  ) + SMALL
           RHOP(IX,  IY-1,IZ  ) = RHOP(IX,  IY-1,IZ  ) + SMALL
           RHOP(IX,  IY,  IZ+1) = RHOP(IX,  IY,  IZ+1) + SMALL
           RHOP(IX,  IY,  IZ-1) = RHOP(IX,  IY,  IZ-1) + SMALL
          go to 40
          ENDIF
 * (3) CALCULATE THE NEUTRON DENSITY
          IF(ZET(LB(I)).EQ.0)THEN
           RHON(IX,  IY,  IZ  ) = RHON(IX,  IY,  IZ  ) + BIG
           RHON(IX+1,IY,  IZ  ) = RHON(IX+1,IY,  IZ  ) + SMALL
           RHON(IX-1,IY,  IZ  ) = RHON(IX-1,IY,  IZ  ) + SMALL
           RHON(IX,  IY+1,IZ  ) = RHON(IX,  IY+1,IZ  ) + SMALL
           RHON(IX,  IY-1,IZ  ) = RHON(IX,  IY-1,IZ  ) + SMALL
           RHON(IX,  IY,  IZ+1) = RHON(IX,  IY,  IZ+1) + SMALL
           RHON(IX,  IY,  IZ-1) = RHON(IX,  IY,  IZ-1) + SMALL
          go to 40
           END IF
 c           else    !! sp01/04/02
 * (4) meson density       
 30              piRHO(IX,  IY,  IZ  ) = piRHO(IX,  IY,  IZ  ) + BIG
           piRHO(IX+1,IY,  IZ  ) = piRHO(IX+1,IY,  IZ  ) + SMALL
           piRHO(IX-1,IY,  IZ  ) = piRHO(IX-1,IY,  IZ  ) + SMALL
           piRHO(IX,  IY+1,IZ  ) = piRHO(IX,  IY+1,IZ  ) + SMALL
           piRHO(IX,  IY-1,IZ  ) = piRHO(IX,  IY-1,IZ  ) + SMALL
           piRHO(IX,  IY,  IZ+1) = piRHO(IX,  IY,  IZ+1) + SMALL
           piRHO(IX,  IY,  IZ-1) = piRHO(IX,  IY,  IZ-1) + SMALL
 c           endif    !! sp01/04/02
 * to calculate the Gamma factor in each cell
 *(1) PX
 40       pxl(ix,iy,iz)=pxl(ix,iy,iz)+p(1,I)*BIG
        pxl(ix+1,iy,iz)=pxl(ix+1,iy,iz)+p(1,I)*SMALL
        pxl(ix-1,iy,iz)=pxl(ix-1,iy,iz)+p(1,I)*SMALL
        pxl(ix,iy+1,iz)=pxl(ix,iy+1,iz)+p(1,I)*SMALL
        pxl(ix,iy-1,iz)=pxl(ix,iy-1,iz)+p(1,I)*SMALL
        pxl(ix,iy,iz+1)=pxl(ix,iy,iz+1)+p(1,I)*SMALL
        pxl(ix,iy,iz-1)=pxl(ix,iy,iz-1)+p(1,I)*SMALL
 *(2) PY
        pYl(ix,iy,iz)=pYl(ix,iy,iz)+p(2,I)*BIG
        pYl(ix+1,iy,iz)=pYl(ix+1,iy,iz)+p(2,I)*SMALL
        pYl(ix-1,iy,iz)=pYl(ix-1,iy,iz)+p(2,I)*SMALL
        pYl(ix,iy+1,iz)=pYl(ix,iy+1,iz)+p(2,I)*SMALL
        pYl(ix,iy-1,iz)=pYl(ix,iy-1,iz)+p(2,I)*SMALL
        pYl(ix,iy,iz+1)=pYl(ix,iy,iz+1)+p(2,I)*SMALL
        pYl(ix,iy,iz-1)=pYl(ix,iy,iz-1)+p(2,I)*SMALL
 * (3) PZ
        pZl(ix,iy,iz)=pZl(ix,iy,iz)+p(3,I)*BIG
        pZl(ix+1,iy,iz)=pZl(ix+1,iy,iz)+p(3,I)*SMALL
        pZl(ix-1,iy,iz)=pZl(ix-1,iy,iz)+p(3,I)*SMALL
        pZl(ix,iy+1,iz)=pZl(ix,iy+1,iz)+p(3,I)*SMALL
        pZl(ix,iy-1,iz)=pZl(ix,iy-1,iz)+p(3,I)*SMALL
        pZl(ix,iy,iz+1)=pZl(ix,iy,iz+1)+p(3,I)*SMALL
        pZl(ix,iy,iz-1)=pZl(ix,iy,iz-1)+p(3,I)*SMALL
 * (4) ENERGY
        pel(ix,iy,iz)=pel(ix,iy,iz)
      1     +sqrt(e(I)**2+p(1,i)**2+p(2,I)**2+p(3,I)**2)*BIG
        pel(ix+1,iy,iz)=pel(ix+1,iy,iz)
      1     +sqrt(e(I)**2+p(1,i)**2+p(2,I)**2+p(3,I)**2)*SMALL
        pel(ix-1,iy,iz)=pel(ix-1,iy,iz)
      1     +sqrt(e(I)**2+p(1,i)**2+p(2,I)**2+p(3,I)**2)*SMALL
        pel(ix,iy+1,iz)=pel(ix,iy+1,iz)
      1     +sqrt(e(I)**2+p(1,i)**2+p(2,I)**2+p(3,I)**2)*SMALL
        pel(ix,iy-1,iz)=pel(ix,iy-1,iz)
      1     +sqrt(e(I)**2+p(1,i)**2+p(2,I)**2+p(3,I)**2)*SMALL
        pel(ix,iy,iz+1)=pel(ix,iy,iz+1)
      1     +sqrt(e(I)**2+p(1,i)**2+p(2,I)**2+p(3,I)**2)*SMALL
        pel(ix,iy,iz-1)=pel(ix,iy,iz-1)
      1     +sqrt(e(I)**2+p(1,i)**2+p(2,I)**2+p(3,I)**2)*SMALL
         END IF
   400 CONTINUE
 *
       DO 301 IZ = -MAXZ,MAXZ
         DO 201 IY = -MAXX,MAXX
           DO 101 IX = -MAXX,MAXX
       IF((RHO(IX,IY,IZ).EQ.0).OR.(PEL(IX,IY,IZ).EQ.0))
      1GO TO 101
       SMASS2=PEL(IX,IY,IZ)**2-PXL(IX,IY,IZ)**2
      1-PYL(IX,IY,IZ)**2-PZL(IX,IY,IZ)**2
        IF(SMASS2.LE.0)SMASS2=1.E-06
        SMASS=SQRT(SMASS2)
            IF(SMASS.EQ.0.)SMASS=1.e-06
            GAMMA=PEL(IX,IY,IZ)/SMASS
            if(gamma.eq.0)go to 101
        bxx(ix,iy,iz)=pxl(ix,iy,iz)/pel(ix,iy,iz)                  
        byy(ix,iy,iz)=pyl(ix,iy,iz)/pel(ix,iy,iz)       
        bzz(ix,iy,iz)=pzl(ix,iy,iz)/pel(ix,iy,iz)                  
             RHO(IX,IY,IZ) = RHO(IX,IY,IZ)/GAMMA
             RHOn(IX,IY,IZ) = RHOn(IX,IY,IZ)/GAMMA
             RHOp(IX,IY,IZ) = RHOp(IX,IY,IZ)/GAMMA
             piRHO(IX,IY,IZ) = piRHO(IX,IY,IZ)/GAMMA
             pEL(IX,IY,IZ) = pEL(IX,IY,IZ)/(GAMMA**2)
            rho0=0.163
            IF(IPOT.EQ.0)THEN
            U=0
            GO TO 70
            ENDIF
            IF(IPOT.EQ.1.or.ipot.eq.6)THEN
            A=-0.1236
            B=0.0704
            S=2
            GO TO 60
            ENDIF
            IF(IPOT.EQ.2.or.ipot.eq.7)THEN
            A=-0.218
            B=0.164
            S=4./3.
            ENDIF
            IF(IPOT.EQ.3)THEN
            a=-0.3581
            b=0.3048
            S=1.167
            GO TO 60
            ENDIF
            IF(IPOT.EQ.4)THEN
            denr=rho(ix,iy,iz)/rho0         
            b=0.3048
            S=1.167
            if(denr.le.4.or.denr.gt.7)then
            a=-0.3581
            else
            a=-b*denr**(1./6.)-2.*0.036/3.*denr**(-0.333)
            endif
            GO TO 60
            ENDIF
 60           U = 0.5*A*RHO(IX,IY,IZ)**2/RHO0 
      1        + B/(1+S) * (RHO(IX,IY,IZ)/RHO0)**S*RHO(IX,IY,IZ)  
 70           PEL(IX,IY,IZ)=PEL(IX,IY,IZ)+U
   101     CONTINUE
   201   CONTINUE
   301 CONTINUE
       RETURN
       END
 
 **********************************
 *                                                                      *
       SUBROUTINE GRADU(IOPT,IX,IY,IZ,GRADX,GRADY,GRADZ)
 *                                                                      *
 *       PURPOSE:     DETERMINE GRAD(U(RHO(X,Y,Z)))                     *
 *       VARIABLES:                                                     *
 *         IOPT                - METHOD FOR EVALUATING THE GRADIENT     *
 *                                                      (INTEGER,INPUT) *
 *         IX, IY, IZ          - COORDINATES OF POINT   (INTEGER,INPUT) *
 *         GRADX, GRADY, GRADZ - GRADIENT OF U            (REAL,OUTPUT) *
 *                                                                      *
 **********************************
       PARAMETER         (MAXX =    20,  MAXZ =   24)
       PARAMETER         (RHO0 = 0.167)
 *
       COMMON  /DD/      RHO(-MAXX:MAXX,-MAXX:MAXX,-MAXZ:MAXZ),
      &                  RHOP(-MAXX:MAXX,-MAXX:MAXX,-MAXZ:MAXZ),
      &                  RHON(-MAXX:MAXX,-MAXX:MAXX,-MAXZ:MAXZ)
 cc      SAVE /DD/
       common  /ss/      inout(20)
 cc      SAVE /ss/
       common  /tt/  PEL(-maxx:maxx,-maxx:maxx,-maxz:maxz)
      &,rxy(-maxx:maxx,-maxx:maxx,-maxz:maxz)
 cc      SAVE /tt/
       SAVE   
 *
       RXPLUS   = RHO(IX+1,IY,  IZ  ) / RHO0
       RXMINS   = RHO(IX-1,IY,  IZ  ) / RHO0
       RYPLUS   = RHO(IX,  IY+1,IZ  ) / RHO0
       RYMINS   = RHO(IX,  IY-1,IZ  ) / RHO0
       RZPLUS   = RHO(IX,  IY,  IZ+1) / RHO0
       RZMINS   = RHO(IX,  IY,  IZ-1) / RHO0
       den0     = RHO(IX,  IY,  IZ) / RHO0
       ene0     = pel(IX,  IY,  IZ) 
 *-----------------------------------------------------------------------
       GOTO (1,2,3,4,5) IOPT
        if(iopt.eq.6)go to 6
        if(iopt.eq.7)go to 7
 *
     1 CONTINUE
 *       POTENTIAL USED IN 1) (STIFF):
 *       U = -.124 * RHO/RHO0 + .0705 (RHO/RHO0)**2 GEV
 *
            GRADX  = -0.062 * (RXPLUS - RXMINS) + 0.03525 * (RXPLUS**2 -
      &                                                      RXMINS**2)
            GRADY  = -0.062 * (RYPLUS - RYMINS) + 0.03525 * (RYPLUS**2 -
      &                                                      RYMINS**2)
            GRADZ  = -0.062 * (RZPLUS - RZMINS) + 0.03525 * (RZPLUS**2 -
      &                                                      RZMINS**2)
            RETURN
 *
     2 CONTINUE
 *       POTENTIAL USED IN 2):
 *       U = -.218 * RHO/RHO0 + .164 (RHO/RHO0)**(4/3) GEV
 *
            EXPNT = 1.3333333
            GRADX = -0.109 * (RXPLUS - RXMINS) 
      &     + 0.082 * (RXPLUS**EXPNT-RXMINS**EXPNT)
            GRADY = -0.109 * (RYPLUS - RYMINS) 
      &     + 0.082 * (RYPLUS**EXPNT-RYMINS**EXPNT)
            GRADZ = -0.109 * (RZPLUS - RZMINS) 
      &     + 0.082 * (RZPLUS**EXPNT-RZMINS**EXPNT)
            RETURN
 *
     3 CONTINUE
 *       POTENTIAL USED IN 3) (SOFT):
 *       U = -.356 * RHO/RHO0 + .303 * (RHO/RHO0)**(7/6)  GEV
 *
            EXPNT = 1.1666667
           acoef = 0.178
            GRADX = -acoef * (RXPLUS - RXMINS) 
      &     + 0.1515 * (RXPLUS**EXPNT-RXMINS**EXPNT)
            GRADY = -acoef * (RYPLUS - RYMINS) 
      &     + 0.1515 * (RYPLUS**EXPNT-RYMINS**EXPNT)
            GRADZ = -acoef * (RZPLUS - RZMINS) 
      &     + 0.1515 * (RZPLUS**EXPNT-RZMINS**EXPNT)
                  RETURN
 *
 *
     4   CONTINUE
 *       POTENTIAL USED IN 4) (super-soft in the mixed phase of 4 < rho/rho <7):
 *       U1 = -.356 * RHO/RHO0 + .303 * (RHO/RHO0)**(7/6)  GEV
 *       normal phase, soft eos of iopt=3
 *       U2 = -.02 * (RHO/RHO0)**(2/3) -0.0253 * (RHO/RHO0)**(7/6)  GEV
 *
        eh=4.
        eqgp=7.
            acoef=0.178
            EXPNT = 1.1666667
        denr=rho(ix,iy,iz)/rho0
        if(denr.le.eh.or.denr.ge.eqgp)then
            GRADX = -acoef * (RXPLUS - RXMINS) 
      &     + 0.1515 * (RXPLUS**EXPNT-RXMINS**EXPNT)
            GRADY = -acoef * (RYPLUS - RYMINS) 
      &     + 0.1515 * (RYPLUS**EXPNT-RYMINS**EXPNT)
            GRADZ = -acoef * (RZPLUS - RZMINS) 
      &     + 0.1515 * (RZPLUS**EXPNT-RZMINS**EXPNT)
        else
           acoef1=0.178
           acoef2=0.0
           expnt2=2./3.
            GRADX =-acoef1* (RXPLUS**EXPNT-RXMINS**EXPNT)
      &                 -acoef2* (RXPLUS**expnt2 - RXMINS**expnt2) 
            GRADy =-acoef1* (RyPLUS**EXPNT-RyMINS**EXPNT)
      &                 -acoef2* (RyPLUS**expnt2 - RyMINS**expnt2) 
            GRADz =-acoef1* (RzPLUS**EXPNT-RzMINS**EXPNT)
      &                 -acoef2* (RzPLUS**expnt2 - RzMINS**expnt2) 
        endif
        return
 *     
     5   CONTINUE
 *       POTENTIAL USED IN 5) (SUPER STIFF):
 *       U = -.10322 * RHO/RHO0 + .04956 * (RHO/RHO0)**(2.77)  GEV
 *
            EXPNT = 2.77
            GRADX = -0.0516 * (RXPLUS - RXMINS) 
      &     + 0.02498 * (RXPLUS**EXPNT-RXMINS**EXPNT)
            GRADY = -0.0516 * (RYPLUS - RYMINS) 
      &     + 0.02498 * (RYPLUS**EXPNT-RYMINS**EXPNT)
            GRADZ = -0.0516 * (RZPLUS - RZMINS) 
      &     + 0.02498 * (RZPLUS**EXPNT-RZMINS**EXPNT)
            RETURN
 *
     6 CONTINUE
 *       POTENTIAL USED IN 6) (STIFF-qgp):
 *       U = -.124 * RHO/RHO0 + .0705 (RHO/RHO0)**2 GEV
 *
        if(ene0.le.0.5)then
            GRADX  = -0.062 * (RXPLUS - RXMINS) + 0.03525 * (RXPLUS**2 -
      &                                                      RXMINS**2)
            GRADY  = -0.062 * (RYPLUS - RYMINS) + 0.03525 * (RYPLUS**2 -
      &                                                      RYMINS**2)
            GRADZ  = -0.062 * (RZPLUS - RZMINS) + 0.03525 * (RZPLUS**2 -
      &                                                      RZMINS**2)
            RETURN
        endif
        if(ene0.gt.0.5.and.ene0.le.1.5)then
 *       U=c1-ef*rho/rho0**2/3
        ef=36./1000.
            GRADX  = -0.5*ef* (RXPLUS**0.67-RXMINS**0.67)
            GRADy  = -0.5*ef* (RyPLUS**0.67-RyMINS**0.67)
            GRADz  = -0.5*ef* (RzPLUS**0.67-RzMINS**0.67)
            RETURN
        endif
        if(ene0.gt.1.5)then
 * U=800*(rho/rho0)**1/3.-Ef*(rho/rho0)**2/3.-c2
        ef=36./1000.
        cf0=0.8
         GRADX  =0.5*cf0*(rxplus**0.333-rxmins**0.333) 
      &         -0.5*ef* (RXPLUS**0.67-RXMINS**0.67)
         GRADy  =0.5*cf0*(ryplus**0.333-rymins**0.333) 
      &         -0.5*ef* (RyPLUS**0.67-RyMINS**0.67)
         GRADz  =0.5*cf0*(rzplus**0.333-rzmins**0.333) 
      &         -0.5*ef* (RzPLUS**0.67-RzMINS**0.67)
            RETURN
        endif
 *
     7 CONTINUE
 *       POTENTIAL USED IN 7) (Soft-qgp):
        if(den0.le.4.5)then
 *       POTENTIAL USED is the same as IN 3) (SOFT):
 *       U = -.356 * RHO/RHO0 + .303 * (RHO/RHO0)**(7/6)  GEV
 *
            EXPNT = 1.1666667
           acoef = 0.178
            GRADX = -acoef * (RXPLUS - RXMINS) 
      &     + 0.1515 * (RXPLUS**EXPNT-RXMINS**EXPNT)
            GRADY = -acoef * (RYPLUS - RYMINS) 
      &     + 0.1515 * (RYPLUS**EXPNT-RYMINS**EXPNT)
            GRADZ = -acoef * (RZPLUS - RZMINS) 
      &     + 0.1515 * (RZPLUS**EXPNT-RZMINS**EXPNT)
        return
        endif
        if(den0.gt.4.5.and.den0.le.5.1)then
 *       U=c1-ef*rho/rho0**2/3
        ef=36./1000.
            GRADX  = -0.5*ef* (RXPLUS**0.67-RXMINS**0.67)
            GRADy  = -0.5*ef* (RyPLUS**0.67-RyMINS**0.67)
            GRADz  = -0.5*ef* (RzPLUS**0.67-RzMINS**0.67)
            RETURN
        endif
        if(den0.gt.5.1)then
 * U=800*(rho/rho0)**1/3.-Ef*(rho/rho0)**2/3.-c2
        ef=36./1000.
        cf0=0.8
         GRADX  =0.5*cf0*(rxplus**0.333-rxmins**0.333) 
      &         -0.5*ef* (RXPLUS**0.67-RXMINS**0.67)
         GRADy  =0.5*cf0*(ryplus**0.333-rymins**0.333) 
      &         -0.5*ef* (RyPLUS**0.67-RyMINS**0.67)
         GRADz  =0.5*cf0*(rzplus**0.333-rzmins**0.333) 
      &         -0.5*ef* (RzPLUS**0.67-RzMINS**0.67)
            RETURN
        endif
         END
 **********************************
 *                                                                      *
       SUBROUTINE GRADUK(IX,IY,IZ,GRADXk,GRADYk,GRADZk)
 *                                                                      *
 *       PURPOSE:     DETERMINE the baryon density gradient for         *
 *                    proporgating kaons in a mean field caused by      *
 *                    surrounding baryons                               * 
 *       VARIABLES:                                                     *
 *         IX, IY, IZ          - COORDINATES OF POINT   (INTEGER,INPUT) *
 *         GRADXk, GRADYk, GRADZk                       (REAL,OUTPUT)   *
 *                                                                      *
 **********************************
       PARAMETER         (MAXX =    20,  MAXZ =   24)
       PARAMETER         (RHO0 = 0.168)
 *
       COMMON  /DD/      RHO(-MAXX:MAXX,-MAXX:MAXX,-MAXZ:MAXZ),
      &                  RHOP(-MAXX:MAXX,-MAXX:MAXX,-MAXZ:MAXZ),
      &                  RHON(-MAXX:MAXX,-MAXX:MAXX,-MAXZ:MAXZ)
 cc      SAVE /DD/
       common  /ss/      inout(20)
 cc      SAVE /ss/
       SAVE   
 *
       RXPLUS   = RHO(IX+1,IY,  IZ  ) 
       RXMINS   = RHO(IX-1,IY,  IZ  ) 
       RYPLUS   = RHO(IX,  IY+1,IZ  ) 
       RYMINS   = RHO(IX,  IY-1,IZ  ) 
       RZPLUS   = RHO(IX,  IY,  IZ+1) 
       RZMINS   = RHO(IX,  IY,  IZ-1) 
            GRADXk  = (RXPLUS - RXMINS)/2. 
            GRADYk  = (RYPLUS - RYMINS)/2.
            GRADZk  = (RZPLUS - RZMINS)/2.
            RETURN
            END
 *-----------------------------------------------------------------------
       SUBROUTINE GRADUP(IX,IY,IZ,GRADXP,GRADYP,GRADZP)
 *                                                                      *
 *       PURPOSE:     DETERMINE THE GRADIENT OF THE PROTON DENSITY      *
 *       VARIABLES:                                                     *
 *                                                                           *
 *         IX, IY, IZ          - COORDINATES OF POINT   (INTEGER,INPUT) *
 *         GRADXP, GRADYP, GRADZP - GRADIENT OF THE PROTON              *
 *                                  DENSITY(REAL,OUTPUT)                *
 *                                                                      *
 **********************************
       PARAMETER         (MAXX =    20,  MAXZ =   24)
       PARAMETER         (RHO0 = 0.168)
 *
       COMMON  /DD/      RHO(-MAXX:MAXX,-MAXX:MAXX,-MAXZ:MAXZ),
      &                     RHOP(-MAXX:MAXX,-MAXX:MAXX,-MAXZ:MAXZ),
      &                     RHON(-MAXX:MAXX,-MAXX:MAXX,-MAXZ:MAXZ)
 cc      SAVE /DD/
       common  /ss/      inout(20)
 cc      SAVE /ss/
       SAVE   
 *
       RXPLUS   = RHOP(IX+1,IY,  IZ  ) / RHO0
       RXMINS   = RHOP(IX-1,IY,  IZ  ) / RHO0
       RYPLUS   = RHOP(IX,  IY+1,IZ  ) / RHO0
       RYMINS   = RHOP(IX,  IY-1,IZ  ) / RHO0
       RZPLUS   = RHOP(IX,  IY,  IZ+1) / RHO0
       RZMINS   = RHOP(IX,  IY,  IZ-1) / RHO0
 *-----------------------------------------------------------------------
 *
            GRADXP  = (RXPLUS - RXMINS)/2. 
            GRADYP  = (RYPLUS - RYMINS)/2.
            GRADZP  = (RZPLUS - RZMINS)/2.
            RETURN
       END
 *-----------------------------------------------------------------------
       SUBROUTINE GRADUN(IX,IY,IZ,GRADXN,GRADYN,GRADZN)
 *                                                                      *
 *       PURPOSE:     DETERMINE THE GRADIENT OF THE NEUTRON DENSITY     *
 *       VARIABLES:                                                     *
 *                                                                           *
 *         IX, IY, IZ          - COORDINATES OF POINT   (INTEGER,INPUT) *
 *         GRADXN, GRADYN, GRADZN - GRADIENT OF THE NEUTRON             *
 *                                  DENSITY(REAL,OUTPUT)                *
 *                                                                      *
 **********************************
       PARAMETER         (MAXX =    20,  MAXZ =   24)
       PARAMETER         (RHO0 = 0.168)
 *
       COMMON  /DD/      RHO(-MAXX:MAXX,-MAXX:MAXX,-MAXZ:MAXZ),
      &                     RHOP(-MAXX:MAXX,-MAXX:MAXX,-MAXZ:MAXZ),
      &                     RHON(-MAXX:MAXX,-MAXX:MAXX,-MAXZ:MAXZ)
 cc      SAVE /DD/
       common  /ss/      inout(20)
 cc      SAVE /ss/
       SAVE   
 *
       RXPLUS   = RHON(IX+1,IY,  IZ  ) / RHO0
       RXMINS   = RHON(IX-1,IY,  IZ  ) / RHO0
       RYPLUS   = RHON(IX,  IY+1,IZ  ) / RHO0
       RYMINS   = RHON(IX,  IY-1,IZ  ) / RHO0
       RZPLUS   = RHON(IX,  IY,  IZ+1) / RHO0
       RZMINS   = RHON(IX,  IY,  IZ-1) / RHO0
 *-----------------------------------------------------------------------
 *
            GRADXN  = (RXPLUS - RXMINS)/2. 
            GRADYN  = (RYPLUS - RYMINS)/2.
            GRADZN  = (RZPLUS - RZMINS)/2.
            RETURN
       END
 
 *-----------------------------------------------------------------------------
 *FUNCTION FDE(DMASS) GIVES DELTA MASS DISTRIBUTION BY USING OF
 *KITAZOE'S FORMULA
         REAL FUNCTION FDE(DMASS,SRT,CON)
       SAVE   
         AMN=0.938869
         AVPI=0.13803333
         AM0=1.232
         FD=4.*(AM0**2)*WIDTH(DMASS)/((DMASS**2-1.232**2)**2
      1  +AM0**2*WIDTH(DMASS)**2)
         IF(CON.EQ.1.)THEN
         P11=(SRT**2+DMASS**2-AMN**2)**2
      1  /(4.*SRT**2)-DMASS**2
        if(p11.le.0)p11=1.E-06
        p1=sqrt(p11)
         ELSE
         DMASS=AMN+AVPI
         P11=(SRT**2+DMASS**2-AMN**2)**2
      1  /(4.*SRT**2)-DMASS**2
        if(p11.le.0)p11=1.E-06
        p1=sqrt(p11)
         ENDIF
         FDE=FD*P1*DMASS
         RETURN
         END
 *-------------------------------------------------------------
 *FUNCTION FDE(DMASS) GIVES N*(1535) MASS DISTRIBUTION BY USING OF
 *KITAZOE'S FORMULA
         REAL FUNCTION FD5(DMASS,SRT,CON)
       SAVE   
         AMN=0.938869
         AVPI=0.13803333
         AM0=1.535
         FD=4.*(AM0**2)*W1535(DMASS)/((DMASS**2-1.535**2)**2
      1  +AM0**2*W1535(DMASS)**2)
         IF(CON.EQ.1.)THEN
 
 clin-9/2012: check argument in sqrt():
            scheck=(SRT**2+DMASS**2-AMN**2)**2/(4.*SRT**2)-DMASS**2
            if(scheck.lt.0) then
               write(99,*) 'scheck11: ', scheck
               scheck=0.
            endif
            P1=SQRT(scheck)
 c           P1=SQRT((SRT**2+DMASS**2-AMN**2)**2
 c     1          /(4.*SRT**2)-DMASS**2)
 
         ELSE
         DMASS=AMN+AVPI
 
 clin-9/2012: check argument in sqrt():
         scheck=(SRT**2+DMASS**2-AMN**2)**2/(4.*SRT**2)-DMASS**2
         if(scheck.lt.0) then
            write(99,*) 'scheck12: ', scheck
            scheck=0.
         endif
         P1=SQRT(scheck)
 c        P1=SQRT((SRT**2+DMASS**2-AMN**2)**2
 c     1  /(4.*SRT**2)-DMASS**2)
 
         ENDIF
         FD5=FD*P1*DMASS
         RETURN
         END
 *--------------------------------------------------------------------------
 *FUNCTION FNS(DMASS) GIVES N* MASS DISTRIBUTION 
 c     BY USING OF BREIT-WIGNER FORMULA
         REAL FUNCTION FNS(DMASS,SRT,CON)
       SAVE   
         WIDTH=0.2
         AMN=0.938869
         AVPI=0.13803333
         AN0=1.43
         FN=4.*(AN0**2)*WIDTH/((DMASS**2-1.44**2)**2+AN0**2*WIDTH**2)
         IF(CON.EQ.1.)THEN
 
 clin-9/2012: check argument in sqrt():
            scheck=(SRT**2+DMASS**2-AMN**2)**2/(4.*SRT**2)-DMASS**2
            if(scheck.lt.0) then
               write(99,*) 'scheck13: ', scheck
               scheck=0.
            endif
            P1=SQRT(scheck)
 c        P1=SQRT((SRT**2+DMASS**2-AMN**2)**2
 c     1  /(4.*SRT**2)-DMASS**2)
 
         ELSE
         DMASS=AMN+AVPI
 clin-9/2012: check argument in sqrt():
         scheck=(SRT**2+DMASS**2-AMN**2)**2/(4.*SRT**2)-DMASS**2
         if(scheck.lt.0) then
            write(99,*) 'scheck14: ', scheck
            scheck=0.
         endif
         P1=SQRT(scheck)
 c        P1=SQRT((SRT**2+DMASS**2-AMN**2)**2
 c     1  /(4.*SRT**2)-DMASS**2)
 
         ENDIF
         FNS=FN*P1*DMASS
         RETURN
         END
 *-----------------------------------------------------------------------------
 *-----------------------------------------------------------------------------
 * PURPOSE:1. SORT N*(1440) and N*(1535) 2-body DECAY PRODUCTS
 *         2. DETERMINE THE MOMENTUM AND COORDINATES OF NUCLEON AND PION
 *            AFTER THE DELTA OR N* DECAYING
 * DATE   : JAN. 24,1990, MODIFIED ON MAY 17, 1994 TO INCLUDE ETA 
         SUBROUTINE DECAY(IRUN,I,NNN,ISEED,wid,nt)
         PARAMETER (MAXSTR=150001,MAXR=1,
      1  AMN=0.939457,ETAM=0.5475,AMP=0.93828,AP1=0.13496,
      2  AP2=0.13957,AM0=1.232,PI=3.1415926)
         COMMON /AA/ R(3,MAXSTR)
 cc      SAVE /AA/
         COMMON /BB/ P(3,MAXSTR)
 cc      SAVE /BB/
         COMMON /CC/ E(MAXSTR)
 cc      SAVE /CC/
         COMMON /EE/ ID(MAXSTR),LB(MAXSTR)
 cc      SAVE /EE/
         COMMON   /RUN/NUM
 cc      SAVE /RUN/
         COMMON   /PA/RPION(3,MAXSTR,MAXR)
 cc      SAVE /PA/
         COMMON   /PB/PPION(3,MAXSTR,MAXR)
 cc      SAVE /PB/
         COMMON   /PC/EPION(MAXSTR,MAXR)
 cc      SAVE /PC/
         COMMON   /PD/LPION(MAXSTR,MAXR)
 cc      SAVE /PD/
         COMMON /INPUT2/ ILAB, MANYB, NTMAX, ICOLL, INSYS, IPOT, MODE, 
      &       IMOMEN, NFREQ, ICFLOW, ICRHO, ICOU, KPOTEN, KMUL
 cc      SAVE /INPUT2/
       COMMON/RNDF77/NSEED
       COMMON /dpert/dpertt(MAXSTR,MAXR),dpertp(MAXSTR),dplast(MAXSTR),
      1     dpdcy(MAXSTR),dpdpi(MAXSTR,MAXR),dpt(MAXSTR, MAXR),
      2     dpp1(MAXSTR,MAXR),dppion(MAXSTR,MAXR)
 cc      SAVE /RNDF77/
       SAVE   
         lbanti=LB(I)
 c
         DM=E(I)
 *1. FOR N*+(1440) DECAY
         IF(iabs(LB(I)).EQ.11)THEN
            X3=RANART(NSEED)
            IF(X3.GT.(1./3.))THEN
               LB(I)=2
               NLAB=2
               LPION(NNN,IRUN)=5
               EPION(NNN,IRUN)=AP2
            ELSE
               LB(I)=1
               NLAB=1
               LPION(NNN,IRUN)=4
               EPION(NNN,IRUN)=AP1
            ENDIF
 *2. FOR N*0(1440) DECAY
         ELSEIF(iabs(LB(I)).EQ.10)THEN
            X4=RANART(NSEED)
            IF(X4.GT.(1./3.))THEN
               LB(I)=1
               NLAB=1
               LPION(NNN,IRUN)=3
               EPION(NNN,IRUN)=AP2
            ELSE
               LB(I)=2
               NALB=2
               LPION(NNN,IRUN)=4
               EPION(NNN,IRUN)=AP1
            ENDIF
 * N*(1535) CAN DECAY TO A PION OR AN ETA IF DM > 1.49 GeV
 *3 N*(0)(1535) DECAY
         ELSEIF(iabs(LB(I)).EQ.12)THEN
            CTRL=0.65
            IF(DM.lE.1.49)ctrl=-1.
            X5=RANART(NSEED)
            IF(X5.GE.ctrl)THEN
 * DECAY TO PION+NUCLEON
               X6=RANART(NSEED)
               IF(X6.GT.(1./3.))THEN
                  LB(I)=1
                  NLAB=1
                  LPION(NNN,IRUN)=3
                  EPION(NNN,IRUN)=AP2
               ELSE
                  LB(I)=2
                  NALB=2
                  LPION(NNN,IRUN)=4
                  EPION(NNN,IRUN)=AP1
               ENDIF
            ELSE
 * DECAY TO ETA+NEUTRON
               LB(I)=2
               NLAB=2
               LPION(NNN,IRUN)=0
               EPION(NNN,IRUN)=ETAM
            ENDIF
 *4. FOR N*+(1535) DECAY
         ELSEIF(iabs(LB(I)).EQ.13)THEN
            CTRL=0.65
            IF(DM.lE.1.49)ctrl=-1.
            X5=RANART(NSEED)
            IF(X5.GE.ctrl)THEN
 * DECAY TO PION+NUCLEON
               X8=RANART(NSEED)
               IF(X8.GT.(1./3.))THEN
                  LB(I)=2
                  NLAB=2
                  LPION(NNN,IRUN)=5
                  EPION(NNN,IRUN)=AP2
               ELSE
                  LB(I)=1
                  NLAB=1
                  LPION(NNN,IRUN)=4
                  EPION(NNN,IRUN)=AP1
               ENDIF
            ELSE
 * DECAY TO ETA+NUCLEON
               LB(I)=1
               NLAB=1
               LPION(NNN,IRUN)=0
               EPION(NNN,IRUN)=ETAM
            ENDIF
         ENDIF
 c
         CALL DKINE(IRUN,I,NNN,NLAB,ISEED,wid,nt)
 c
 c     anti-particle ID for anti-N* decays:
         if(lbanti.lt.0) then
            lbi=LB(I)
            if(lbi.eq.1.or.lbi.eq.2) then
               lbi=-lbi
            elseif(lbi.eq.3) then
               lbi=5
            elseif(lbi.eq.5) then
               lbi=3
            endif
            LB(I)=lbi
 c
            lbi=LPION(NNN,IRUN)
            if(lbi.eq.3) then
               lbi=5
            elseif(lbi.eq.5) then
               lbi=3
            elseif(lbi.eq.1.or.lbi.eq.2) then
               lbi=-lbi
            endif
            LPION(NNN,IRUN)=lbi
         endif
 c
         if(nt.eq.ntmax) then
 c     at the last timestep, assign rho or eta (decay daughter) 
 c     to lb(i1) only (not to lpion) in order to decay them again:
            lbm=LPION(NNN,IRUN)
            if(lbm.eq.0.or.lbm.eq.25
      1          .or.lbm.eq.26.or.lbm.eq.27) then
 c     switch rho or eta with baryon, positions are the same (no change needed):
               lbsave=lbm
               xmsave=EPION(NNN,IRUN)
               pxsave=PPION(1,NNN,IRUN)
               pysave=PPION(2,NNN,IRUN)
               pzsave=PPION(3,NNN,IRUN)
 clin-5/2008:
               dpsave=dppion(NNN,IRUN)
               LPION(NNN,IRUN)=LB(I)
               EPION(NNN,IRUN)=E(I)
               PPION(1,NNN,IRUN)=P(1,I)
               PPION(2,NNN,IRUN)=P(2,I)
               PPION(3,NNN,IRUN)=P(3,I)
 clin-5/2008:
               dppion(NNN,IRUN)=dpertp(I)
               LB(I)=lbsave
               E(I)=xmsave
               P(1,I)=pxsave
               P(2,I)=pysave
               P(3,I)=pzsave
 clin-5/2008:
               dpertp(I)=dpsave
            endif
         endif
 
        RETURN
        END
 
 *-------------------------------------------------------------------
 *-------------------------------------------------------------------
 * PURPOSE:
 *         CALCULATE THE MOMENTUM OF NUCLEON AND PION (OR ETA) 
 *         IN THE LAB. FRAME AFTER DELTA OR N* DECAY
 * DATE   : JAN. 24,1990, MODIFIED ON MAY 17, 1994 TO INCLUDE ETA PRODUCTION
         SUBROUTINE DKINE(IRUN,I,NNN,NLAB,ISEED,wid,nt)
         PARAMETER (hbarc=0.19733)
         PARAMETER (MAXSTR=150001,MAXR=1,
      1  AMN=0.939457,AMP=0.93828,ETAM=0.5475,
      2  AP1=0.13496,AP2=0.13957,AM0=1.232,PI=3.1415926)
         COMMON /AA/ R(3,MAXSTR)
 cc      SAVE /AA/
         COMMON /BB/ P(3,MAXSTR)
 cc      SAVE /BB/
         COMMON /CC/ E(MAXSTR)
 cc      SAVE /CC/
         COMMON /EE/ ID(MAXSTR),LB(MAXSTR)
 cc      SAVE /EE/
         COMMON   /RUN/NUM
 cc      SAVE /RUN/
         COMMON   /PA/RPION(3,MAXSTR,MAXR)
 cc      SAVE /PA/
         COMMON   /PB/PPION(3,MAXSTR,MAXR)
 cc      SAVE /PB/
         COMMON   /PC/EPION(MAXSTR,MAXR)
 cc      SAVE /PC/
         COMMON   /PD/LPION(MAXSTR,MAXR)
 cc      SAVE /PD/
       common/leadng/lb1,px1,py1,pz1,em1,e1,xfnl,yfnl,zfnl,tfnl,
      1 px1n,py1n,pz1n,dp1n
 cc      SAVE /leadng/
         COMMON/tdecay/tfdcy(MAXSTR),tfdpi(MAXSTR,MAXR),tft(MAXSTR)
 cc      SAVE /tdecay/
         COMMON /INPUT2/ ILAB, MANYB, NTMAX, ICOLL, INSYS, IPOT, MODE, 
      &       IMOMEN, NFREQ, ICFLOW, ICRHO, ICOU, KPOTEN, KMUL
 cc      SAVE /INPUT2/
       COMMON/RNDF77/NSEED
 cc      SAVE /RNDF77/
       COMMON /dpert/dpertt(MAXSTR,MAXR),dpertp(MAXSTR),dplast(MAXSTR),
      1     dpdcy(MAXSTR),dpdpi(MAXSTR,MAXR),dpt(MAXSTR, MAXR),
      2     dpp1(MAXSTR,MAXR),dppion(MAXSTR,MAXR)
         EXTERNAL IARFLV, INVFLV
       SAVE   
 * READ IN THE COORDINATES OF DELTA OR N* UNDERGOING DECAY
         PX=P(1,I)
         PY=P(2,I)
         PZ=P(3,I)
         RX=R(1,I)
         RY=R(2,I)
         RZ=R(3,I)
         DM=E(I)
         EDELTA=SQRT(DM**2+PX**2+PY**2+PZ**2)
         PM=EPION(NNN,IRUN)
         AM=AMP
         IF(NLAB.EQ.2)AM=AMN
 * FIND OUT THE MOMENTUM AND ENERGY OF PION AND NUCLEON IN DELTA REST FRAME
 * THE MAGNITUDE OF MOMENTUM IS DETERMINED BY ENERGY CONSERVATION ,THE FORMULA
 * CAN BE FOUND ON PAGE 716,W BAUER P.R.C40,1989
 * THE DIRECTION OF THE MOMENTUM IS ASSUMED ISOTROPIC. NOTE THAT P(PION)=-P(N)
         Q2=((DM**2-AM**2+PM**2)/(2.*DM))**2-PM**2
         IF(Q2.LE.0.)Q2=1.e-09
         Q=SQRT(Q2)
 11      QX=1.-2.*RANART(NSEED)
         QY=1.-2.*RANART(NSEED)
         QZ=1.-2.*RANART(NSEED)
         QS=QX**2+QY**2+QZ**2
         IF(QS.GT.1.) GO TO 11
         PXP=Q*QX/SQRT(QS)
         PYP=Q*QY/SQRT(QS)
         PZP=Q*QZ/SQRT(QS)
         EP=SQRT(Q**2+PM**2)
         PXN=-PXP
         PYN=-PYP
         PZN=-PZP
         EN=SQRT(Q**2+AM**2)
 * TRANSFORM INTO THE LAB. FRAME. THE GENERAL LORENTZ TRANSFORMATION CAN
 * BE FOUND ON PAGE 34 OF R. HAGEDORN " RELATIVISTIC KINEMATICS"
         GD=EDELTA/DM
         FGD=GD/(1.+GD)
         BDX=PX/EDELTA
         BDY=PY/EDELTA
         BDZ=PZ/EDELTA
         BPP=BDX*PXP+BDY*PYP+BDZ*PZP
         BPN=BDX*PXN+BDY*PYN+BDZ*PZN
         P(1,I)=PXN+BDX*GD*(FGD*BPN+EN)
         P(2,I)=PYN+BDY*GD*(FGD*BPN+EN)
         P(3,I)=PZN+BDZ*GD*(FGD*BPN+EN)
         E(I)=AM
 * WE ASSUME THAT THE SPACIAL COORDINATE OF THE NUCLEON
 * IS THAT OF THE DELTA
         PPION(1,NNN,IRUN)=PXP+BDX*GD*(FGD*BPP+EP)
         PPION(2,NNN,IRUN)=PYP+BDY*GD*(FGD*BPP+EP)
         PPION(3,NNN,IRUN)=PZP+BDZ*GD*(FGD*BPP+EP)
 clin-5/2008:
         dppion(NNN,IRUN)=dpertp(I)
 * WE ASSUME THE PION OR ETA COMING FROM DELTA DECAY IS LOCATED ON THE SPHERE
 * OF RADIUS 0.5FM AROUND DELTA, THIS POINT NEED TO BE CHECKED 
 * AND OTHER CRIERTION MAY BE TRIED
 clin-2/20/03 no additional smearing for position of decay daughters:
 c200         X0 = 1.0 - 2.0 * RANART(NSEED)
 c            Y0 = 1.0 - 2.0 * RANART(NSEED)
 c            Z0 = 1.0 - 2.0 * RANART(NSEED)
 c        IF ((X0*X0+Y0*Y0+Z0*Z0) .GT. 1.0) GOTO 200
 c        RPION(1,NNN,IRUN)=R(1,I)+0.5*x0
 c        RPION(2,NNN,IRUN)=R(2,I)+0.5*y0
 c        RPION(3,NNN,IRUN)=R(3,I)+0.5*z0
         RPION(1,NNN,IRUN)=R(1,I)
         RPION(2,NNN,IRUN)=R(2,I)
         RPION(3,NNN,IRUN)=R(3,I)
 c
         devio=SQRT(EPION(NNN,IRUN)**2+PPION(1,NNN,IRUN)**2
      1       +PPION(2,NNN,IRUN)**2+PPION(3,NNN,IRUN)**2)
      2       +SQRT(E(I)**2+P(1,I)**2+P(2,I)**2+P(3,I)**2)-e1
 c        if(abs(devio).gt.0.02) write(93,*) 'decay(): nt=',nt,devio,lb1
 
 c     add decay time to daughter's formation time at the last timestep:
         if(nt.eq.ntmax) then
            tau0=hbarc/wid
            taudcy=tau0*(-1.)*alog(1.-RANART(NSEED))
 c     lorentz boost:
            taudcy=taudcy*e1/em1
            tfnl=tfnl+taudcy
            xfnl=xfnl+px1/e1*taudcy
            yfnl=yfnl+py1/e1*taudcy
            zfnl=zfnl+pz1/e1*taudcy
            R(1,I)=xfnl
            R(2,I)=yfnl
            R(3,I)=zfnl
            tfdcy(I)=tfnl
            RPION(1,NNN,IRUN)=xfnl
            RPION(2,NNN,IRUN)=yfnl
            RPION(3,NNN,IRUN)=zfnl
            tfdpi(NNN,IRUN)=tfnl
         endif
 
 cms 200    format(a30,2(1x,e10.4))
 cms 210    format(i6,5(1x,f8.3))
 cms 220    format(a2,i5,5(1x,f8.3))
 
         RETURN
         END
 
 *-----------------------------------------------------------------------------
 *-----------------------------------------------------------------------------
 * PURPOSE:1. N*-->N+PION+PION  DECAY PRODUCTS
 *         2. DETERMINE THE MOMENTUM AND COORDINATES OF NUCLEON AND PION
 *            AFTER THE DELTA OR N* DECAYING
 * DATE   : NOV.7,1994
 *----------------------------------------------------------------------------
         SUBROUTINE DECAY2(IRUN,I,NNN,ISEED,wid,nt)
         PARAMETER (MAXSTR=150001,MAXR=1,
      1  AMN=0.939457,ETAM=0.5475,AMP=0.93828,AP1=0.13496,
      2  AP2=0.13957,AM0=1.232,PI=3.1415926)
         COMMON /AA/ R(3,MAXSTR)
 cc      SAVE /AA/
         COMMON /BB/ P(3,MAXSTR)
 cc      SAVE /BB/
         COMMON /CC/ E(MAXSTR)
 cc      SAVE /CC/
         COMMON /EE/ ID(MAXSTR),LB(MAXSTR)
 cc      SAVE /EE/
         COMMON   /RUN/NUM
 cc      SAVE /RUN/
         COMMON   /PA/RPION(3,MAXSTR,MAXR)
 cc      SAVE /PA/
         COMMON   /PB/PPION(3,MAXSTR,MAXR)
 cc      SAVE /PB/
         COMMON   /PC/EPION(MAXSTR,MAXR)
 cc      SAVE /PC/
         COMMON   /PD/LPION(MAXSTR,MAXR)
 cc      SAVE /PD/
       COMMON/RNDF77/NSEED
 cc      SAVE /RNDF77/
       SAVE   
 
         lbanti=LB(I)
 c
         DM=E(I)
 * DETERMINE THE DECAY PRODUCTS
 * FOR N*+(1440) DECAY
         IF(iabs(LB(I)).EQ.11)THEN
            X3=RANART(NSEED)
            IF(X3.LT.(1./3))THEN
               LB(I)=2
               NLAB=2
               LPION(NNN,IRUN)=5
               EPION(NNN,IRUN)=AP2
               LPION(NNN+1,IRUN)=4
               EPION(NNN+1,IRUN)=AP1
            ELSEIF(X3.LT.2./3.AND.X3.GT.1./3.)THEN
               LB(I)=1
               NLAB=1
               LPION(NNN,IRUN)=5
               EPION(NNN,IRUN)=AP2
               LPION(NNN+1,IRUN)=3
               EPION(NNN+1,IRUN)=AP2
            ELSE
               LB(I)=1
               NLAB=1
               LPION(NNN,IRUN)=4
               EPION(NNN,IRUN)=AP1
               LPION(NNN+1,IRUN)=4
               EPION(NNN+1,IRUN)=AP1
            ENDIF
 * FOR N*0(1440) DECAY
         ELSEIF(iabs(LB(I)).EQ.10)THEN
            X3=RANART(NSEED)
            IF(X3.LT.(1./3))THEN
               LB(I)=2
               NLAB=2
               LPION(NNN,IRUN)=4
               EPION(NNN,IRUN)=AP1
               LPION(NNN+1,IRUN)=4
               EPION(NNN+1,IRUN)=AP1
            ELSEIF(X3.LT.2./3.AND.X3.GT.1./3.)THEN
               LB(I)=1
               NLAB=1
               LPION(NNN,IRUN)=3
               EPION(NNN,IRUN)=AP2
               LPION(NNN+1,IRUN)=4
               EPION(NNN+1,IRUN)=AP1
            ELSE
               LB(I)=2
               NLAB=2
               LPION(NNN,IRUN)=5
               EPION(NNN,IRUN)=AP2
               LPION(NNN+1,IRUN)=3
               EPION(NNN+1,IRUN)=AP2
            ENDIF
         ENDIF
 
         CALL DKINE2(IRUN,I,NNN,NLAB,ISEED,wid,nt)
 c
 c     anti-particle ID for anti-N* decays:
         if(lbanti.lt.0) then
            lbi=LB(I)
            if(lbi.eq.1.or.lbi.eq.2) then
               lbi=-lbi
            elseif(lbi.eq.3) then
               lbi=5
            elseif(lbi.eq.5) then
               lbi=3
            endif
            LB(I)=lbi
 c
            lbi=LPION(NNN,IRUN)
            if(lbi.eq.3) then
               lbi=5
            elseif(lbi.eq.5) then
               lbi=3
            elseif(lbi.eq.1.or.lbi.eq.2) then
               lbi=-lbi
            endif
            LPION(NNN,IRUN)=lbi
 c
            lbi=LPION(NNN+1,IRUN)
            if(lbi.eq.3) then
               lbi=5
            elseif(lbi.eq.5) then
               lbi=3
            elseif(lbi.eq.1.or.lbi.eq.2) then
               lbi=-lbi
            endif
            LPION(NNN+1,IRUN)=lbi
         endif
 c
        RETURN
        END
 *-------------------------------------------------------------------
 *--------------------------------------------------------------------------
 *         CALCULATE THE MOMENTUM OF NUCLEON AND PION (OR ETA) 
 *         IN THE LAB. FRAME AFTER DELTA OR N* DECAY
 * DATE   : JAN. 24,1990, MODIFIED ON MAY 17, 1994 TO INCLUDE ETA PRODUCTION
 *--------------------------------------------------------------------------
         SUBROUTINE DKINE2(IRUN,I,NNN,NLAB,ISEED,wid,nt)
         PARAMETER (hbarc=0.19733)
         PARAMETER (MAXSTR=150001,MAXR=1,
      1  AMN=0.939457,AMP=0.93828,ETAM=0.5475,
      2  AP1=0.13496,AP2=0.13957,AM0=1.232,PI=3.1415926)
         COMMON /AA/ R(3,MAXSTR)
 cc      SAVE /AA/
         COMMON /BB/ P(3,MAXSTR)
 cc      SAVE /BB/
         COMMON /CC/ E(MAXSTR)
 cc      SAVE /CC/
         COMMON /EE/ ID(MAXSTR),LB(MAXSTR)
 cc      SAVE /EE/
         COMMON   /RUN/NUM
 cc      SAVE /RUN/
         COMMON   /PA/RPION(3,MAXSTR,MAXR)
 cc      SAVE /PA/
         COMMON   /PB/PPION(3,MAXSTR,MAXR)
 cc      SAVE /PB/
         COMMON   /PC/EPION(MAXSTR,MAXR)
 cc      SAVE /PC/
         COMMON   /PD/LPION(MAXSTR,MAXR)
 cc      SAVE /PD/
       common/leadng/lb1,px1,py1,pz1,em1,e1,xfnl,yfnl,zfnl,tfnl,
      1 px1n,py1n,pz1n,dp1n
 cc      SAVE /leadng/
         COMMON/tdecay/tfdcy(MAXSTR),tfdpi(MAXSTR,MAXR),tft(MAXSTR)
 cc      SAVE /tdecay/
         COMMON /INPUT2/ ILAB, MANYB, NTMAX, ICOLL, INSYS, IPOT, MODE, 
      &       IMOMEN, NFREQ, ICFLOW, ICRHO, ICOU, KPOTEN, KMUL
 cc      SAVE /INPUT2/
         EXTERNAL IARFLV, INVFLV
       COMMON/RNDF77/NSEED
 cc      SAVE /RNDF77/
       COMMON /dpert/dpertt(MAXSTR,MAXR),dpertp(MAXSTR),dplast(MAXSTR),
      1     dpdcy(MAXSTR),dpdpi(MAXSTR,MAXR),dpt(MAXSTR, MAXR),
      2     dpp1(MAXSTR,MAXR),dppion(MAXSTR,MAXR)
       SAVE   
 
 * READ IN THE COORDINATES OF THE N*(1440) UNDERGOING DECAY
         PX=P(1,I)
         PY=P(2,I)
         PZ=P(3,I)
         RX=R(1,I)
         RY=R(2,I)
         RZ=R(3,I)
         DM=E(I)
         EDELTA=SQRT(DM**2+PX**2+PY**2+PZ**2)
         PM1=EPION(NNN,IRUN)
         PM2=EPION(NNN+1,IRUN)
         AM=AMN
        IF(NLAB.EQ.1)AM=AMP
 * THE MAXIMUM MOMENTUM OF THE NUCLEON FROM THE DECAY OF A N*
        PMAX2=(DM**2-(AM+PM1+PM2)**2)*(DM**2-(AM-PM1-PM2)**2)/4/DM**2
 
 clin-9/2012: check argument in sqrt():
        scheck=PMAX2
        if(scheck.lt.0) then
           write(99,*) 'scheck15: ', scheck
           scheck=0.
        endif
        PMAX=SQRT(scheck)
 c       PMAX=SQRT(PMAX2)
 
 * GENERATE THE MOMENTUM OF THE NUCLEON IN THE N* REST FRAME
        CSS=1.-2.*RANART(NSEED)
        SSS=SQRT(1-CSS**2)
        FAI=2*PI*RANART(NSEED)
        PX0=PMAX*SSS*COS(FAI)
        PY0=PMAX*SSS*SIN(FAI)
        PZ0=PMAX*CSS
        EP0=SQRT(PX0**2+PY0**2+PZ0**2+AM**2)
 clin-5/23/01 bug: P0 for pion0 is equal to PMAX, leaving pion+ and pion- 
 c     without no relative momentum, thus producing them with equal momenta, 
 * BETA AND GAMMA OF THE CMS OF PION+-PION-
        BETAX=-PX0/(DM-EP0)
        BETAY=-PY0/(DM-EP0)
        BETAZ=-PZ0/(DM-EP0)
 
 clin-9/2012: check argument in sqrt():
        scheck=1-BETAX**2-BETAY**2-BETAZ**2
        if(scheck.le.0) then
           write(99,*) 'scheck16: ', scheck
           stop
        endif
        GD1=1./SQRT(scheck)
 c       GD1=1./SQRT(1-BETAX**2-BETAY**2-BETAZ**2)
 
        FGD1=GD1/(1+GD1)
 * GENERATE THE MOMENTA OF PIONS IN THE CMS OF PION+PION-
         Q2=((DM-EP0)/(2.*GD1))**2-PM1**2
         IF(Q2.LE.0.)Q2=1.E-09
         Q=SQRT(Q2)
 11      QX=1.-2.*RANART(NSEED)
         QY=1.-2.*RANART(NSEED)
         QZ=1.-2.*RANART(NSEED)
         QS=QX**2+QY**2+QZ**2
         IF(QS.GT.1.) GO TO 11
         PXP=Q*QX/SQRT(QS)
         PYP=Q*QY/SQRT(QS)
         PZP=Q*QZ/SQRT(QS)
         EP=SQRT(Q**2+PM1**2)
         PXN=-PXP
         PYN=-PYP
         PZN=-PZP
         EN=SQRT(Q**2+PM2**2)
 * TRANSFORM THE MOMENTA OF PION+PION- INTO THE N* REST FRAME
         BPP1=BETAX*PXP+BETAY*PYP+BETAZ*PZP
         BPN1=BETAX*PXN+BETAY*PYN+BETAZ*PZN
 * FOR PION-
         P1M=PXN+BETAX*GD1*(FGD1*BPN1+EN)
         P2M=PYN+BETAY*GD1*(FGD1*BPN1+EN)
         P3M=PZN+BETAZ*GD1*(FGD1*BPN1+EN)
        EPN=SQRT(P1M**2+P2M**2+P3M**2+PM2**2)
 * FOR PION+
         P1P=PXP+BETAX*GD1*(FGD1*BPP1+EP)
         P2P=PYP+BETAY*GD1*(FGD1*BPP1+EP)
         P3P=PZP+BETAZ*GD1*(FGD1*BPP1+EP)
        EPP=SQRT(P1P**2+P2P**2+P3P**2+PM1**2)
 * TRANSFORM MOMENTA OF THE THREE PIONS INTO THE 
 * THE NUCLEUS-NUCLEUS CENTER OF MASS  FRAME. 
 * THE GENERAL LORENTZ TRANSFORMATION CAN
 * BE FOUND ON PAGE 34 OF R. HAGEDORN " RELATIVISTIC KINEMATICS"
         GD=EDELTA/DM
         FGD=GD/(1.+GD)
         BDX=PX/EDELTA
         BDY=PY/EDELTA
         BDZ=PZ/EDELTA
        BP0=BDX*PX0+BDY*PY0+BDZ*PZ0
         BPP=BDX*P1P+BDY*P2P+BDZ*P3P
         BPN=BDX*P1M+BDY*P2M+BDZ*P3M
 * FOR THE NUCLEON
         P(1,I)=PX0+BDX*GD*(FGD*BP0+EP0)
         P(2,I)=PY0+BDY*GD*(FGD*BP0+EP0)
         P(3,I)=PZ0+BDZ*GD*(FGD*BP0+EP0)
        E(I)=am
        ID(I)=0
        enucl=sqrt(p(1,i)**2+p(2,i)**2+p(3,i)**2+e(i)**2)
 * WE ASSUME THAT THE SPACIAL COORDINATE OF THE PION0
 * IS in a sphere of radius 0.5 fm around N*
 * FOR PION+
         PPION(1,NNN,IRUN)=P1P+BDX*GD*(FGD*BPP+EPP)
         PPION(2,NNN,IRUN)=P2P+BDY*GD*(FGD*BPP+EPP)
         PPION(3,NNN,IRUN)=P3P+BDZ*GD*(FGD*BPP+EPP)
        epion1=sqrt(ppion(1,nnn,irun)**2
      &  +ppion(2,nnn,irun)**2+ppion(3,nnn,irun)**2
      &  +epion(nnn,irun)**2)
 clin-2/20/03 no additional smearing for position of decay daughters:
 c200         X0 = 1.0 - 2.0 * RANART(NSEED)
 c            Y0 = 1.0 - 2.0 * RANART(NSEED)
 c            Z0 = 1.0 - 2.0 * RANART(NSEED)
 c        IF ((X0*X0+Y0*Y0+Z0*Z0) .GT. 1.0) GOTO 200
 c        RPION(1,NNN,IRUN)=R(1,I)+0.5*x0
 c        RPION(2,NNN,IRUN)=R(2,I)+0.5*y0
 c        RPION(3,NNN,IRUN)=R(3,I)+0.5*z0
         RPION(1,NNN,IRUN)=R(1,I)
         RPION(2,NNN,IRUN)=R(2,I)
         RPION(3,NNN,IRUN)=R(3,I)
 * FOR PION-
         PPION(1,NNN+1,IRUN)=P1M+BDX*GD*(FGD*BPN+EPN)
         PPION(2,NNN+1,IRUN)=P2M+BDY*GD*(FGD*BPN+EPN)
         PPION(3,NNN+1,IRUN)=P3M+BDZ*GD*(FGD*BPN+EPN)
 clin-5/2008:
         dppion(NNN,IRUN)=dpertp(I)
         dppion(NNN+1,IRUN)=dpertp(I)
 c
        epion2=sqrt(ppion(1,nnn+1,irun)**2
      &  +ppion(2,nnn+1,irun)**2+ppion(3,nnn+1,irun)**2
      &  +epion(nnn+1,irun)**2)
 clin-2/20/03 no additional smearing for position of decay daughters:
 c300         X0 = 1.0 - 2.0 * RANART(NSEED)
 c            Y0 = 1.0 - 2.0 * RANART(NSEED)
 c            Z0 = 1.0 - 2.0 * RANART(NSEED)
 c        IF ((X0*X0+Y0*Y0+Z0*Z0) .GT. 1.0) GOTO 300
 c        RPION(1,NNN+1,IRUN)=R(1,I)+0.5*x0
 c        RPION(2,NNN+1,IRUN)=R(2,I)+0.5*y0
 c        RPION(3,NNN+1,IRUN)=R(3,I)+0.5*z0
         RPION(1,NNN+1,IRUN)=R(1,I)
         RPION(2,NNN+1,IRUN)=R(2,I)
         RPION(3,NNN+1,IRUN)=R(3,I)
 c
 * check energy conservation in the decay
 c       efinal=enucl+epion1+epion2
 c       DEEE=(EDELTA-EFINAL)/EDELTA
 c       IF(ABS(DEEE).GE.1.E-03)write(6,*)1,edelta,efinal
 
         devio=SQRT(EPION(NNN,IRUN)**2+PPION(1,NNN,IRUN)**2
      1       +PPION(2,NNN,IRUN)**2+PPION(3,NNN,IRUN)**2)
      2       +SQRT(E(I)**2+P(1,I)**2+P(2,I)**2+P(3,I)**2)
      3       +SQRT(EPION(NNN+1,IRUN)**2+PPION(1,NNN+1,IRUN)**2
      4       +PPION(2,NNN+1,IRUN)**2+PPION(3,NNN+1,IRUN)**2)-e1
 c        if(abs(devio).gt.0.02) write(93,*) 'decay2(): nt=',nt,devio,lb1
 
 c     add decay time to daughter's formation time at the last timestep:
         if(nt.eq.ntmax) then
            tau0=hbarc/wid
            taudcy=tau0*(-1.)*alog(1.-RANART(NSEED))
 c     lorentz boost:
            taudcy=taudcy*e1/em1
            tfnl=tfnl+taudcy
            xfnl=xfnl+px1/e1*taudcy
            yfnl=yfnl+py1/e1*taudcy
            zfnl=zfnl+pz1/e1*taudcy
            R(1,I)=xfnl
            R(2,I)=yfnl
            R(3,I)=zfnl
            tfdcy(I)=tfnl
            RPION(1,NNN,IRUN)=xfnl
            RPION(2,NNN,IRUN)=yfnl
            RPION(3,NNN,IRUN)=zfnl
            tfdpi(NNN,IRUN)=tfnl
            RPION(1,NNN+1,IRUN)=xfnl
            RPION(2,NNN+1,IRUN)=yfnl
            RPION(3,NNN+1,IRUN)=zfnl
            tfdpi(NNN+1,IRUN)=tfnl
         endif
 
 cms 200    format(a30,2(1x,e10.4))
 cms 210    format(i6,5(1x,f8.3))
 cms 220    format(a2,i5,5(1x,f8.3))
 
         RETURN
         END
 *---------------------------------------------------------------------------
 *---------------------------------------------------------------------------
 * PURPOSE : CALCULATE THE MASS AND MOMENTUM OF BARYON RESONANCE 
 *           AFTER PION OR ETA BEING ABSORBED BY A NUCLEON
 * NOTE    : 
 *           
 * DATE    : JAN.29,1990
         SUBROUTINE DRESON(I1,I2)
         PARAMETER (MAXSTR=150001,MAXR=1,
      1  AMN=0.939457,AMP=0.93828,
      2  AP1=0.13496,AP2=0.13957,AM0=1.232,PI=3.1415926)
 clin-9/2012: improve precision for argument in sqrt():
         double precision e10,e20,scheck,p1,p2,p3
         COMMON /AA/ R(3,MAXSTR)
 cc      SAVE /AA/
         COMMON /BB/ P(3,MAXSTR)
 cc      SAVE /BB/
         COMMON /CC/ E(MAXSTR)
 cc      SAVE /CC/
         COMMON /EE/ ID(MAXSTR),LB(MAXSTR)
 cc      SAVE /EE/
         COMMON   /RUN/NUM
 cc      SAVE /RUN/
         COMMON   /PA/RPION(3,MAXSTR,MAXR)
 cc      SAVE /PA/
         COMMON   /PB/PPION(3,MAXSTR,MAXR)
 cc      SAVE /PB/
         COMMON   /PC/EPION(MAXSTR,MAXR)
 cc      SAVE /PC/
         COMMON   /PD/LPION(MAXSTR,MAXR)
 cc      SAVE /PD/
       SAVE   
 * 1. DETERMINE THE MOMENTUM COMPONENT OF DELTA/N* IN THE LAB. FRAME
 clin-9/2012: improve precision for argument in sqrt():
 c        E10=SQRT(E(I1)**2+P(1,I1)**2+P(2,I1)**2+P(3,I1)**2)
 c        E20=SQRT(E(I2)**2+P(1,I2)**2+P(2,I2)**2+P(3,I2)**2)
         E10=dSQRT(dble(E(I1))**2+dble(P(1,I1))**2
      1     +dble(P(2,I1))**2+dble(P(3,I1))**2)
         E20=dSQRT(dble(E(I2))**2+dble(P(1,I2))**2
      1       +dble(P(2,I2))**2+dble(P(3,I2))**2)
         p1=dble(P(1,I1))+dble(P(1,I2))
         p2=dble(P(2,I1))+dble(P(2,I2))
         p3=dble(P(3,I1))+dble(P(3,I2))
 
         IF(iabs(LB(I2)) .EQ. 1 .OR. iabs(LB(I2)) .EQ. 2 .OR.
      &     (iabs(LB(I2)) .GE. 6 .AND. iabs(LB(I2)) .LE. 17)) THEN
         E(I1)=0.
         I=I2
         ELSE
         E(I2)=0.
         I=I1
         ENDIF
         P(1,I)=P(1,I1)+P(1,I2)
         P(2,I)=P(2,I1)+P(2,I2)
         P(3,I)=P(3,I1)+P(3,I2)
 * 2. DETERMINE THE MASS OF DELTA/N* BY USING THE REACTION KINEMATICS
 
 clin-9/2012: check argument in sqrt():
         scheck=(E10+E20)**2-p1**2-p2**2-p3**2
         if(scheck.lt.0) then
            write(99,*) 'scheck17: ', scheck
            write(99,*) 'scheck17', scheck,E10,E20,P(1,I),P(2,I),P(3,I)
            write(99,*) 'scheck17-1',E(I1),P(1,I1),P(2,I1),P(3,I1)
            write(99,*) 'scheck17-2',E(I2),P(1,I2),P(2,I2),P(3,I2)
            scheck=0.d0
         endif
         DM=SQRT(sngl(scheck))
 c        DM=SQRT((E10+E20)**2-P(1,I)**2-P(2,I)**2-P(3,I)**2)
 
         E(I)=DM
         RETURN
         END
 *---------------------------------------------------------------------------
 * PURPOSE : CALCULATE THE MASS AND MOMENTUM OF RHO RESONANCE 
 *           AFTER PION + PION COLLISION
 * DATE    : NOV. 30,1994
         SUBROUTINE RHORES(I1,I2)
         PARAMETER (MAXSTR=150001,MAXR=1,
      1  AMN=0.939457,AMP=0.93828,
      2  AP1=0.13496,AP2=0.13957,AM0=1.232,PI=3.1415926)
 clin-9/2012: improve precision for argument in sqrt():
         double precision e10,e20,scheck,p1,p2,p3
         COMMON /AA/ R(3,MAXSTR)
 cc      SAVE /AA/
         COMMON /BB/ P(3,MAXSTR)
 cc      SAVE /BB/
         COMMON /CC/ E(MAXSTR)
 cc      SAVE /CC/
         COMMON /EE/ ID(MAXSTR),LB(MAXSTR)
 cc      SAVE /EE/
         COMMON   /RUN/NUM
 cc      SAVE /RUN/
         COMMON   /PA/RPION(3,MAXSTR,MAXR)
 cc      SAVE /PA/
         COMMON   /PB/PPION(3,MAXSTR,MAXR)
 cc      SAVE /PB/
         COMMON   /PC/EPION(MAXSTR,MAXR)
 cc      SAVE /PC/
         COMMON   /PD/LPION(MAXSTR,MAXR)
 cc      SAVE /PD/
       SAVE   
 * 1. DETERMINE THE MOMENTUM COMPONENT OF THE RHO IN THE CMS OF NN FRAME
 *    WE LET I1 TO BE THE RHO AND ABSORB I2
 clin-9/2012: improve precision for argument in sqrt():
 c        E10=SQRT(E(I1)**2+P(1,I1)**2+P(2,I1)**2+P(3,I1)**2)
 c        E20=SQRT(E(I2)**2+P(1,I2)**2+P(2,I2)**2+P(3,I2)**2)
         E10=dSQRT(dble(E(I1))**2+dble(P(1,I1))**2
      1     +dble(P(2,I1))**2+dble(P(3,I1))**2)
         E20=dSQRT(dble(E(I2))**2+dble(P(1,I2))**2
      1       +dble(P(2,I2))**2+dble(P(3,I2))**2)
         p1=dble(P(1,I1))+dble(P(1,I2))
         p2=dble(P(2,I1))+dble(P(2,I2))
         p3=dble(P(3,I1))+dble(P(3,I2))
 
         P(1,I1)=P(1,I1)+P(1,I2)
         P(2,I1)=P(2,I1)+P(2,I2)
         P(3,I1)=P(3,I1)+P(3,I2)
 * 2. DETERMINE THE MASS OF THE RHO BY USING THE REACTION KINEMATICS
 
 clin-9/2012: check argument in sqrt():
         scheck=(E10+E20)**2-p1**2-p2**2-p3**2
         if(scheck.lt.0) then
            write(99,*) 'scheck18: ', scheck
            scheck=0.d0
         endif
         DM=SQRT(sngl(scheck))
 c        DM=SQRT((E10+E20)**2-P(1,I1)**2-P(2,I1)**2-P(3,I1)**2)
 
         E(I1)=DM
        E(I2)=0
         RETURN
         END
 *---------------------------------------------------------------------------
 * PURPOSE : CALCULATE THE PION+NUCLEON CROSS SECTION ACCORDING TO THE
 *           BREIT-WIGNER FORMULA/(p*)**2
 * VARIABLE : LA = 1 FOR DELTA RESONANCE
 *            LA = 0 FOR N*(1440) RESONANCE
 *            LA = 2 FRO N*(1535) RESONANCE
 * DATE    : JAN.29,1990
         REAL FUNCTION XNPI(I1,I2,LA,XMAX)
         PARAMETER (MAXSTR=150001,MAXR=1,
      1  AMN=0.939457,AMP=0.93828,
      2  AP1=0.13496,AP2=0.13957,AM0=1.232,PI=3.1415926)
 clin-9/2012: improve precision for argument in sqrt():
         double precision e10,e20,scheck,p1,p2,p3
         COMMON /AA/ R(3,MAXSTR)
 cc      SAVE /AA/
         COMMON /BB/ P(3,MAXSTR)
 cc      SAVE /BB/
         COMMON /CC/ E(MAXSTR)
 cc      SAVE /CC/
         COMMON /EE/ ID(MAXSTR),LB(MAXSTR)
 cc      SAVE /EE/
         COMMON   /RUN/NUM
 cc      SAVE /RUN/
         COMMON   /PA/RPION(3,MAXSTR,MAXR)
 cc      SAVE /PA/
         COMMON   /PB/PPION(3,MAXSTR,MAXR)
 cc      SAVE /PB/
         COMMON   /PC/EPION(MAXSTR,MAXR)
 cc      SAVE /PC/
         COMMON   /PD/LPION(MAXSTR,MAXR)
 cc      SAVE /PD/
       SAVE   
         AVMASS=0.5*(AMN+AMP)
         AVPI=(2.*AP2+AP1)/3.
 * 1. DETERMINE THE MOMENTUM COMPONENT OF DELTA IN THE LAB. FRAME
 clin-9/2012: improve precision for argument in sqrt():
 c        E10=SQRT(E(I1)**2+P(1,I1)**2+P(2,I1)**2+P(3,I1)**2)
 c        E20=SQRT(E(I2)**2+P(1,I2)**2+P(2,I2)**2+P(3,I2)**2)
         E10=dSQRT(dble(E(I1))**2+dble(P(1,I1))**2
      1     +dble(P(2,I1))**2+dble(P(3,I1))**2)
         E20=dSQRT(dble(E(I2))**2+dble(P(1,I2))**2
      1       +dble(P(2,I2))**2+dble(P(3,I2))**2)
 c        P1=P(1,I1)+P(1,I2)
 c        P2=P(2,I1)+P(2,I2)
 c        P3=P(3,I1)+P(3,I2)
         p1=dble(P(1,I1))+dble(P(1,I2))
         p2=dble(P(2,I1))+dble(P(2,I2))
         p3=dble(P(3,I1))+dble(P(3,I2))
 
 * 2. DETERMINE THE MASS OF DELTA BY USING OF THE REACTION KINEMATICS
 
 clin-9/2012: check argument in sqrt():
         scheck=(E10+E20)**2-p1**2-p2**2-p3**2
         if(scheck.lt.0) then
            write(99,*) 'scheck19: ', scheck
            scheck=0.d0
         endif
         DM=SQRT(sngl(scheck))
 c        DM=SQRT((E10+E20)**2-P1**2-P2**2-P3**2)
 
         IF(DM.LE.1.1) THEN
         XNPI=1.e-09
         RETURN
         ENDIF
 * 3. DETERMINE THE PION+NUCLEON CROSS SECTION ACCORDING TO THE
 *    BREIT-WIGNER FORMULA IN UNIT OF FM**2
         IF(LA.EQ.1)THEN
         GAM=WIDTH(DM)
         F1=0.25*GAM**2/(0.25*GAM**2+(DM-1.232)**2)
         PDELT2=0.051622
         GO TO 10
        ENDIF
        IF(LA.EQ.0)THEN
         GAM=W1440(DM)
         F1=0.25*GAM**2/(0.25*GAM**2+(DM-1.440)**2)
         PDELT2=0.157897
        GO TO 10
         ENDIF
        IF(LA.EQ.2)THEN
         GAM=W1535(DM)
         F1=0.25*GAM**2/(0.25*GAM**2+(DM-1.535)**2)
         PDELT2=0.2181
         ENDIF
 10      PSTAR2=((DM**2-AVMASS**2+AVPI**2)/(2.*DM))**2-AVPI**2
         IF(PSTAR2.LE.0.)THEN
         XNPI=1.e-09
         ELSE
 * give the cross section in unit of fm**2
         XNPI=F1*(PDELT2/PSTAR2)*XMAX/10.
         ENDIF
         RETURN
         END
 *------------------------------------------------------------------------------
 *****************************************
         REAL FUNCTION SIGMA(SRT,ID,IOI,IOF)
 *PURPOSE : THIS IS THE PROGRAM TO CALCULATE THE ISOSPIN DECOMPOSED CROSS
 *       SECTION BY USING OF B.J.VerWEST AND R.A.ARNDT'S PARAMETERIZATION
 *REFERENCE: PHYS. REV. C25(1982)1979
 *QUANTITIES: IOI -- INITIAL ISOSPIN OF THE TWO NUCLEON SYSTEM
 *            IOF -- FINAL   ISOSPIN -------------------------
 *            ID -- =1 FOR DELTA RESORANCE
 *                  =2 FOR N*    RESORANCE
 *DATE : MAY 15,1990
 *****************************************
         PARAMETER (AMU=0.9383,AMP=0.1384,PI=3.1415926,HC=0.19733)
       SAVE   
         IF(ID.EQ.1)THEN
         AMASS0=1.22
         T0 =0.12
         ELSE
         AMASS0=1.43
         T0 =0.2
         ENDIF
         IF((IOI.EQ.1).AND.(IOF.EQ.1))THEN
         ALFA=3.772
         BETA=1.262
         AM0=1.188
         T=0.09902
         ENDIF
         IF((IOI.EQ.1).AND.(IOF.EQ.0))THEN
         ALFA=15.28
         BETA=0.
         AM0=1.245
         T=0.1374
         ENDIF
         IF((IOI.EQ.0).AND.(IOF.EQ.1))THEN
         ALFA=146.3
         BETA=0.
         AM0=1.472
         T=0.02649
         ENDIF
         ZPLUS=(SRT-AMU-AMASS0)*2./T0
         ZMINUS=(AMU+AMP-AMASS0)*2./T0
         deln=ATAN(ZPLUS)-ATAN(ZMINUS)
        if(deln.eq.0)deln=1.E-06
         AMASS=AMASS0+(T0/4.)*ALOG((1.+ZPLUS**2)/(1.+ZMINUS**2))
      1  /deln
         S=SRT**2
         P2=S/4.-AMU**2
         S0=(AMU+AM0)**2
         P02=S0/4.-AMU**2
         P0=SQRT(P02)
         PR2=(S-(AMU-AMASS)**2)*(S-(AMU+AMASS)**2)/(4.*S)
         IF(PR2.GT.1.E-06)THEN
         PR=SQRT(PR2)
         ELSE
         PR=0.
         SIGMA=1.E-06
         RETURN
         ENDIF
         SS=AMASS**2
         Q2=(SS-(AMU-AMP)**2)*(SS-(AMU+AMP)**2)/(4.*SS)
         IF(Q2.GT.1.E-06)THEN
         Q=SQRT(Q2)
         ELSE
         Q=0.
         SIGMA=1.E-06
         RETURN
         ENDIF
         SS0=AM0**2
         Q02=(SS0-(AMU-AMP)**2)*(SS0-(AMU+AMP)**2)/(4.*SS0)
 
 clin-9/2012: check argument in sqrt():
         scheck=Q02
         if(scheck.lt.0) then
            write(99,*) 'scheck20: ', scheck
            scheck=0.
         endif
         Q0=SQRT(scheck)
 c        Q0=SQRT(Q02)
 
         SIGMA=PI*(HC)**2/(2.*P2)*ALFA*(PR/P0)**BETA*AM0**2*T**2
      1  *(Q/Q0)**3/((SS-AM0**2)**2+AM0**2*T**2)
         SIGMA=SIGMA*10.
        IF(SIGMA.EQ.0)SIGMA=1.E-06
         RETURN
         END
 
 *****************************
         REAL FUNCTION DENOM(SRT,CON)
 * NOTE: CON=1 FOR DELTA RESONANCE, CON=2 FOR N*(1440) RESONANCE
 *       con=-1 for N*(1535)
 * PURPOSE : CALCULATE THE INTEGRAL IN THE DETAILED BALANCE
 *
 * DATE : NOV. 15, 1991
 *******************************
         PARAMETER (AP1=0.13496,
      1  AP2=0.13957,PI=3.1415926,AVMASS=0.9383)
       SAVE   
         AVPI=(AP1+2.*AP2)/3.
         AM0=1.232
         AMN=AVMASS
         AMP=AVPI
         AMAX=SRT-AVMASS
         AMIN=AVMASS+AVPI
         NMAX=200
         DMASS=(AMAX-AMIN)/FLOAT(NMAX)
         SUM=0.
         DO 10 I=1,NMAX+1
         DM=AMIN+FLOAT(I-1)*DMASS
         IF(CON.EQ.1.)THEN
         Q2=((DM**2-AMN**2+AMP**2)/(2.*DM))**2-AMP**2
            IF(Q2.GT.0.)THEN
            Q=SQRT(Q2)
            ELSE
            Q=1.E-06
            ENDIF
         TQ=0.47*(Q**3)/(AMP**2*(1.+0.6*(Q/AMP)**2))
         ELSE if(con.eq.2)then
         TQ=0.2
         AM0=1.44
        else if(con.eq.-1.)then
        tq=0.1
        am0=1.535
         ENDIF
         A1=4.*TQ*AM0**2/(AM0**2*TQ**2+(DM**2-AM0**2)**2)
         S=SRT**2
         P0=(S+DM**2-AMN**2)**2/(4.*S)-DM**2
         IF(P0.LE.0.)THEN
         P1=1.E-06
         ELSE
         P1=SQRT(P0)
         ENDIF
         F=DM*A1*P1
         IF((I.EQ.1).OR.(I.EQ.(NMAX+1)))THEN
         SUM=SUM+F*0.5
         ELSE
         SUM=SUM+F
         ENDIF
 10      CONTINUE
         DENOM=SUM*DMASS/(2.*PI)
         RETURN
         END
 **********************************
 * subroutine : ang.FOR
 * PURPOSE : Calculate the angular distribution of Delta production process 
 * DATE    : Nov. 19, 1992
 * REFERENCE: G. WOLF ET. AL., NUCL. PHYS. A517 (1990) 615
 * Note: this function applies when srt is larger than 2.14 GeV,
 * for less energetic reactions, we assume the angular distribution
 * is isotropic.
 ***********************************
        real function ang(srt,iseed)
       COMMON/RNDF77/NSEED
 cc      SAVE /RNDF77/
       SAVE   
 c        if(srt.le.2.14)then
 c       b1s=0.5
 c       b2s=0.
 c      endif
       if((srt.gt.2.14).and.(srt.le.2.4))then
        b1s=29.03-23.75*srt+4.865*srt**2
          b2s=-30.33+25.53*srt-5.301*srt**2
       endif
       if(srt.gt.2.4)then
        b1s=0.06
          b2s=0.4
       endif
         x=RANART(NSEED)
        p=b1s/b2s
        q=(2.*x-1.)*(b1s+b2s)/b2s
        IF((-q/2.+sqrt((q/2.)**2+(p/3.)**3)).GE.0.)THEN
        ang1=(-q/2.+sqrt((q/2.)**2+(p/3.)**3))**(1./3.)
        ELSE
        ang1=-(q/2.-sqrt((q/2.)**2+(p/3.)**3))**(1./3.)
        ENDIF
        IF((-q/2.-sqrt((q/2.)**2+(p/3.)**3).GE.0.))THEN
        ang2=(-q/2.-sqrt((q/2.)**2+(p/3.)**3))**(1./3.)
        ELSE
        ang2=-(q/2.+sqrt((q/2.)**2+(p/3.)**3))**(1./3.)
        ENDIF
        ANG=ANG1+ANG2
        return
        end
 *--------------------------------------------------------------------------
 *****subprogram * kaon production from pi+B collisions *******************
       real function PNLKA(srt)
       SAVE   
 * units: fm**2
 ***********************************C
       ala=1.116
       aka=0.498
       ana=0.939
       t1=ala+aka      
       if(srt.le.t1) THEN
       Pnlka=0
       Else
       IF(SRT.LT.1.7)sbbk=(0.9/0.091)*(SRT-T1)
       IF(SRT.GE.1.7)sbbk=0.09/(SRT-1.6)
       Pnlka=0.25*sbbk
 * give the cross section in units of fm**2
        pnlka=pnlka/10.
       endif     
       return
       end
 *-------------------------------------------------------------------------
 *****subprogram * kaon production from pi+B collisions *******************
       real function PNSKA(srt)
       SAVE   
 ***********************************
        if(srt.gt.3.0)then
        pnska=0
        return
        endif
       ala=1.116
       aka=0.498
       ana=0.939
       asa=1.197
       t1=asa+aka      
       if(srt.le.t1) THEN
       Pnska=0
        return
       Endif
       IF(SRT.LT.1.9)SBB1=(0.7/0.218)*(SRT-T1)
       IF(SRT.GE.1.9)SBB1=0.14/(SRT-1.7)
       sbb2=0.
        if(srt.gT.1.682)sbb2=0.5*(1.-0.75*(srt-1.682))
        pnska=0.25*(sbb1+sbb2)
 * give the cross section in fm**2
        pnska=pnska/10.
       return
       end
 
 ********************************
 *
 *       Kaon momentum distribution in baryon-baryon-->N lamda K process
 *
 *       NOTE: dsima/dp is prototional to (1-p/p_max)(p/p_max)^2
 *              we use rejection method to generate kaon momentum
 *
 *       Variables: Fkaon = F(p)/F_max
 *                 srt   = cms energy of the colliding pair, 
 *                          used to calculate the P_max
 *       Date: Feb. 8, 1994
 *
 *       Reference: C. M. Ko et al.  
 ******************************** 
        Real function fkaon(p,pmax)
       SAVE   
        fmax=0.148
        if(pmax.eq.0.)pmax=0.000001
        fkaon=(1.-p/pmax)*(p/pmax)**2
        if(fkaon.gt.fmax)fkaon=fmax
        fkaon=fkaon/fmax
        return
        end
 
 *************************
 * cross section for N*(1535) production in ND OR NN* collisions
 * VARIABLES:
 * LB1,LB2 ARE THE LABLES OF THE TWO COLLIDING PARTICLES
 * SRT IS THE CMS ENERGY
 * X1535 IS THE N*(1535) PRODUCTION CROSS SECTION
 * NOTE THAT THE N*(1535) PRODUCTION CROSS SECTION IS 2 TIMES THE ETA 
 * PRODUCTION CROSS SECTION
 * DATE: MAY 18, 1994
 * ***********************
        Subroutine M1535(LB1,LB2,SRT,X1535)
       SAVE   
        S0=2.424
        x1535=0.
        IF(SRT.LE.S0)RETURN
        SIGMA=2.*0.102*(SRT-S0)/(0.058+(SRT-S0)**2)
 * I N*(1535) PRODUCTION IN NUCLEON-DELTA COLLISIONS
 *(1) nD(++)->pN*(+)(1535), pD(-)->nN*(0)(1535),pD(+)-->N*(+)p
 cbz11/25/98
 c       IF((LB1*LB2.EQ.18).OR.(LB1*LB2.EQ.6).
 c     1  or.(lb1*lb2).eq.8)then
        IF((LB1*LB2.EQ.18.AND.(LB1.EQ.2.OR.LB2.EQ.2)).OR.
      &     (LB1*LB2.EQ.6.AND.(LB1.EQ.1.OR.LB2.EQ.1)).or.
      &     (lb1*lb2.eq.8.AND.(LB1.EQ.1.OR.LB2.EQ.1)))then
 cbz11/25/98end
        X1535=SIGMA
        return
        ENDIF
 *(2) pD(0)->pN*(0)(1535),pD(0)->nN*(+)(1535)
        IF(LB1*LB2.EQ.7)THEN
        X1535=3.*SIGMA
        RETURN
        ENDIF 
 * II N*(1535) PRODUCTION IN N*(1440)+NUCLEON REACTIONS
 *(3) N*(+)(1440)p->N*(0+)(1535)p, N*(0)(1440)n->N*(0)(1535)
 cbz11/25/98
 c       IF((LB1*LB2.EQ.11).OR.(LB1*LB2.EQ.20))THEN
        IF((LB1*LB2.EQ.11).OR.
      &     (LB1*LB2.EQ.20.AND.(LB1.EQ.2.OR.LB2.EQ.2)))THEN
 cbz11/25/98end
        X1535=SIGMA
        RETURN
        ENDIF
 *(4) N*(0)(1440)p->N*(0+) or N*(+)(1440)n->N*(0+)(1535)
 cbz11/25/98
 c       IF((LB1*LB2.EQ.10).OR.(LB1*LB2.EQ.22))X1535=3.*SIGMA
        IF((LB1*LB2.EQ.10.AND.(LB1.EQ.1.OR.LB2.EQ.1)).OR.
      &     (LB1*LB2.EQ.22.AND.(LB1.EQ.2.OR.LB2.EQ.2)))
      &     X1535=3.*SIGMA
 cbz11/25/98end
        RETURN
        END
 *************************
 * cross section for N*(1535) production in NN collisions
 * VARIABLES:
 * LB1,LB2 ARE THE LABLES OF THE TWO COLLIDING PARTICLES
 * SRT IS THE CMS ENERGY
 * X1535 IS THE N*(1535) PRODUCTION CROSS SECTION
 * NOTE THAT THE N*(1535) PRODUCTION CROSS SECTION IS 2 TIMES THE ETA 
 * PRODUCTION CROSS SECTION
 * DATE: MAY 18, 1994
 * ***********************
        Subroutine N1535(LB1,LB2,SRT,X1535)
       SAVE   
        S0=2.424
        x1535=0.
        IF(SRT.LE.S0)RETURN
        SIGMA=2.*0.102*(SRT-S0)/(0.058+(SRT-S0)**2)
 * I N*(1535) PRODUCTION IN NUCLEON-NUCLEON COLLISIONS
 *(1) pp->pN*(+)(1535), nn->nN*(0)(1535)
 cbdbg11/25/98
 c       IF((LB1*LB2.EQ.1).OR.(LB1*LB2.EQ.4))then
        IF((LB1*LB2.EQ.1).OR.
      &     (LB1.EQ.2.AND.LB2.EQ.2))then
 cbz11/25/98end
        X1535=SIGMA
        return
        endif
 *(2) pn->pN*(0)(1535),pn->nN*(+)(1535)
        IF(LB1*LB2.EQ.2)then
        X1535=3.*SIGMA
        return
        endif 
 * III N*(1535) PRODUCTION IN DELTA+DELTA REACTIONS
 * (5) D(++)+D(0), D(+)+D(+),D(+)+D(-),D(0)+D(0)
 cbz11/25/98
 c       IF((LB1*LB2.EQ.63).OR.(LB1*LB2.EQ.64).OR.(LB1*LB2.EQ.48).
 c     1  OR.(LB1*LB2.EQ.49))then
        IF((LB1*LB2.EQ.63.AND.(LB1.EQ.7.OR.LB2.EQ.7)).OR.
      &     (LB1*LB2.EQ.64.AND.(LB1.EQ.8.OR.LB2.EQ.8)).OR.
      &     (LB1*LB2.EQ.48.AND.(LB1.EQ.6.OR.LB2.EQ.6)).OR.
      &     (LB1*LB2.EQ.49.AND.(LB1.EQ.7.OR.LB2.EQ.7)))then
 cbz11/25/98end
        X1535=SIGMA
        return
        endif
 * (6) D(++)+D(-),D(+)+D(0)
 cbz11/25/98
 c       IF((LB1*LB2.EQ.54).OR.(LB1*LB2.EQ.56))then
        IF((LB1*LB2.EQ.54.AND.(LB1.EQ.6.OR.LB2.EQ.6)).OR.
      &     (LB1*LB2.EQ.56.AND.(LB1.EQ.7.OR.LB2.EQ.7)))then
 cbz11/25/98end
        X1535=3.*SIGMA
        return
        endif
 * IV N*(1535) PRODUCTION IN N*(1440)+N*(1440) REACTIONS
 cbz11/25/98
 c       IF((LB1*LB2.EQ.100).OR.(LB1*LB2.EQ.11*11))X1535=SIGMA
        IF((LB1.EQ.10.AND.LB2.EQ.10).OR.
      &     (LB1.EQ.11.AND.LB2.EQ.11))X1535=SIGMA
 c       IF(LB1*LB2.EQ.110)X1535=3.*SIGMA
        IF(LB1*LB2.EQ.110.AND.(LB1.EQ.10.OR.LB2.EQ.10))X1535=3.*SIGMA
 cbdbg11/25/98end
        RETURN
        END
 ************************************       
 * FUNCTION WA1(DMASS) GIVES THE A1 DECAY WIDTH
 
         subroutine WIDA1(DMASS,rhomp,wa1,iseed)
       SAVE   
 c
         PIMASS=0.137265
         coupa = 14.8
 c
        RHOMAX = DMASS-PIMASS-0.02
        IF(RHOMAX.LE.0)then
          rhomp=0.
 c   !! no decay
          wa1=-10.
         endif
         icount = 0
 711       rhomp=RHOMAS(RHOMAX,ISEED)
       icount=icount+1
       if(dmass.le.(pimass+rhomp)) then
        if(icount.le.100) then
         goto 711
        else
          rhomp=0.
 c   !! no decay
          wa1=-10.
         return
        endif
       endif
       qqp2=(dmass**2-(rhomp+pimass)**2)*(dmass**2-(rhomp-pimass)**2)
       qqp=sqrt(qqp2)/(2.0*dmass)
       epi=sqrt(pimass**2+qqp**2)
       erho=sqrt(rhomp**2+qqp**2)
       epirho=2.0*(epi*erho+qqp**2)**2+rhomp**2*epi**2
       wa1=coupa**2*qqp*epirho/(24.0*3.1416*dmass**2)
        return
        end
 ************************************       
 * FUNCTION W1535(DMASS) GIVES THE N*(1535) DECAY WIDTH 
 c     FOR A GIVEN N*(1535) MASS
 * HERE THE FORMULA GIVEN BY KITAZOE IS USED
         REAL FUNCTION W1535(DMASS)
       SAVE   
         AVMASS=0.938868
         PIMASS=0.137265
            AUX = 0.25*(DMASS**2-AVMASS**2-PIMASS**2)**2
      &           -(AVMASS*PIMASS)**2
             IF (AUX .GT. 0.) THEN
               QAVAIL = SQRT(AUX / DMASS**2)
             ELSE
               QAVAIL = 1.E-06
             END IF
             W1535 = 0.15* QAVAIL/0.467
 c       W1535=0.15
         RETURN
         END
 ************************************       
 * FUNCTION W1440(DMASS) GIVES THE N*(1440) DECAY WIDTH 
 c     FOR A GIVEN N*(1535) MASS
 * HERE THE FORMULA GIVEN BY KITAZOE IS USED
         REAL FUNCTION W1440(DMASS)
       SAVE   
         AVMASS=0.938868
         PIMASS=0.137265
            AUX = 0.25*(DMASS**2-AVMASS**2-PIMASS**2)**2
      &           -(AVMASS*PIMASS)**2
             IF (AUX .GT. 0.) THEN
               QAVAIL = SQRT(AUX)/DMASS
             ELSE
               QAVAIL = 1.E-06
             END IF
 c              w1440=0.2 
            W1440 = 0.2* (QAVAIL/0.397)**3
         RETURN
         END
 ****************
 * PURPOSE : CALCULATE THE PION(ETA)+NUCLEON CROSS SECTION 
 *           ACCORDING TO THE BREIT-WIGNER FORMULA, 
 *           NOTE THAT N*(1535) IS S_11
 * VARIABLE : LA = 1 FOR PI+N
 *            LA = 0 FOR ETA+N
 * DATE    : MAY 16, 1994
 ****************
         REAL FUNCTION XN1535(I1,I2,LA)
         PARAMETER (MAXSTR=150001,MAXR=1,
      1  AMN=0.939457,AMP=0.93828,ETAM=0.5475,
      2  AP1=0.13496,AP2=0.13957,AM0=1.232,PI=3.1415926)
 clin-9/2012: improve precision for argument in sqrt():
         double precision e10,e20,scheck,p1,p2,p3
         COMMON /AA/ R(3,MAXSTR)
 cc      SAVE /AA/
         COMMON /BB/ P(3,MAXSTR)
 cc      SAVE /BB/
         COMMON /CC/ E(MAXSTR)
 cc      SAVE /CC/
         COMMON /EE/ ID(MAXSTR),LB(MAXSTR)
 cc      SAVE /EE/
         COMMON   /RUN/NUM
 cc      SAVE /RUN/
         COMMON   /PA/RPION(3,MAXSTR,MAXR)
 cc      SAVE /PA/
         COMMON   /PB/PPION(3,MAXSTR,MAXR)
 cc      SAVE /PB/
         COMMON   /PC/EPION(MAXSTR,MAXR)
 cc      SAVE /PC/
         COMMON   /PD/LPION(MAXSTR,MAXR)
 cc      SAVE /PD/
       SAVE   
         AVMASS=0.5*(AMN+AMP)
         AVPI=(2.*AP2+AP1)/3.
 * 1. DETERMINE THE MOMENTUM COMPONENT OF N*(1535) IN THE LAB. FRAME
 clin-9/2012: improve precision for argument in sqrt():
 c        E10=SQRT(E(I1)**2+P(1,I1)**2+P(2,I1)**2+P(3,I1)**2)
 c        E20=SQRT(E(I2)**2+P(1,I2)**2+P(2,I2)**2+P(3,I2)**2)
         E10=dSQRT(dble(E(I1))**2+dble(P(1,I1))**2
      1     +dble(P(2,I1))**2+dble(P(3,I1))**2)
         E20=dSQRT(dble(E(I2))**2+dble(P(1,I2))**2
      1       +dble(P(2,I2))**2+dble(P(3,I2))**2)
 c        P1=P(1,I1)+P(1,I2)
 c        P2=P(2,I1)+P(2,I2)
 c        P3=P(3,I1)+P(3,I2)
         p1=dble(P(1,I1))+dble(P(1,I2))
         p2=dble(P(2,I1))+dble(P(2,I2))
         p3=dble(P(3,I1))+dble(P(3,I2))
 
 * 2. DETERMINE THE MASS OF DELTA BY USING OF THE REACTION KINEMATICS
 
 clin-9/2012: check argument in sqrt():
         scheck=(E10+E20)**2-p1**2-p2**2-p3**2
         if(scheck.lt.0) then
            write(99,*) 'scheck21: ', scheck
            scheck=0.d0
         endif
         DM=SQRT(sngl(scheck))
 c        DM=SQRT((E10+E20)**2-P1**2-P2**2-P3**2)
 
         IF(DM.LE.1.1) THEN
         XN1535=1.E-06
         RETURN
         ENDIF
 * 3. DETERMINE THE PION(ETA)+NUCLEON->N*(1535) CROSS SECTION ACCORDING TO THE
 *    BREIT-WIGNER FORMULA IN UNIT OF FM**2
         GAM=W1535(DM)
        GAM0=0.15
         F1=0.25*GAM0**2/(0.25*GAM**2+(DM-1.535)**2)
         IF(LA.EQ.1)THEN
        XMAX=11.3
         ELSE
        XMAX=74.
         ENDIF
         XN1535=F1*XMAX/10.
         RETURN
         END
 ***************************8
 *FUNCTION FDE(DMASS) GIVES DELTA MASS DISTRIBUTION BY USING OF
 *KITAZOE'S FORMULA
         REAL FUNCTION FDELTA(DMASS)
       SAVE   
         AMN=0.938869
         AVPI=0.13803333
         AM0=1.232
         FD=0.25*WIDTH(DMASS)**2/((DMASS-1.232)**2
      1  +0.25*WIDTH(DMASS)**2)
         FDELTA=FD
         RETURN
         END
 * FUNCTION WIDTH(DMASS) GIVES THE DELTA DECAY WIDTH FOR A GIVEN DELTA MASS
 * HERE THE FORMULA GIVEN BY KITAZOE IS USED
         REAL FUNCTION WIDTH(DMASS)
       SAVE   
         AVMASS=0.938868
         PIMASS=0.137265
            AUX = 0.25*(DMASS**2-AVMASS**2-PIMASS**2)**2
      &           -(AVMASS*PIMASS)**2
             IF (AUX .GT. 0.) THEN
               QAVAIL = SQRT(AUX / DMASS**2)
             ELSE
               QAVAIL = 1.E-06
             END IF
             WIDTH = 0.47 * QAVAIL**3 /
      &              (PIMASS**2 * (1.+0.6*(QAVAIL/PIMASS)**2))
 c       width=0.115
         RETURN
         END
 ************************************       
         SUBROUTINE ddp2(SRT,ISEED,PX,PY,PZ,DM1,PNX,
      &  PNY,PNZ,DM2,PPX,PPY,PPZ,icou1)
 * PURPOSE : CALCULATE MOMENTUM OF PARTICLES IN THE FINAL SATAT FROM
 * THE PROCESS N+N--->D1+D2+PION
 *       DATE : July 25, 1994
 * Generate the masses and momentum for particles in the NN-->DDpi process
 * for a given center of mass energy srt, the momenta are given in the center
 * of mass of the NN
 *****************************************
         COMMON/TABLE/ xarray(0:1000),earray(0:1000)
 cc      SAVE /TABLE/
       COMMON/RNDF77/NSEED
 cc      SAVE /RNDF77/
       SAVE   
        icou1=0
        pi=3.1415926
         AMN=938.925/1000.
         AMP=137.265/1000.
 * (1) GENGRATE THE MASS OF DELTA1 AND DELTA2 USING
        srt1=srt-amp-0.02
        ntrym=0
 8       call Rmasdd(srt1,1.232,1.232,1.08,
      &  1.08,ISEED,1,dm1,dm2)
        ntrym=ntrym+1
 * CONSTANTS FOR GENERATING THE LONGITUDINAL MOMENTUM 
 * FOR ONE OF THE RESONANCES
        V=0.43
        W=-0.84
 * (2) Generate the transverse momentum
 *     OF DELTA1
 * (2.1) estimate the maximum transverse momentum
        PTMAX2=(SRT**2-(DM1+DM2+AMP)**2)*
      1  (SRT**2-(DM1-AMP-DM2)**2)/4./SRT**2
        if(ptmax2.le.0)go to 8
        PTMAX=SQRT(PTMAX2)*1./3.
 7       PT=PTR(PTMAX,ISEED)       
 * (3.1) THE MAXIMUM LONGITUDINAL MOMENTUM IS
        PZMAX2=(SRT**2-(DM1+DM2+AMP)**2)*
      1  (SRT**2-(DM1-AMP-DM2)**2)/4./SRT**2-PT**2
        IF((PZMAX2.LT.0.).and.ntrym.le.100)then 
        go to 7
        else
        pzmax2=1.E-09
        endif
        PZMAX=SQRT(PZMAX2)
        XMAX=2.*PZMAX/SRT
 * (3.2) THE GENERATED X IS
 * THE DSTRIBUTION HAS A MAXIMUM AT X0=-V/(2*w), f(X0)=1.056
        ntryx=0
        fmax00=1.056
        x00=0.26
        if(abs(xmax).gt.0.26)then
        f00=fmax00
        else
        f00=1.+v*abs(xmax)+w*xmax**2
        endif
 9       X=XMAX*(1.-2.*RANART(NSEED))
        ntryx=ntryx+1
        xratio=(1.+V*ABS(X)+W*X**2)/f00       
 clin-8/17/00       IF(xratio.LT.RANART(NSEED).and.ntryx.le.50)GO TO 9       
        IF(xratio.LT.RANART(NSEED).and.ntryx.le.50)GO TO 9       
 * (3.5) THE PZ IS
        PZ=0.5*SRT*X
 * The x and y components of the deltA1
        fai=2.*pi*RANART(NSEED)
        Px=pt*cos(fai)
        Py=pt*sin(fai)
 * find the momentum of delta2 and pion
 * the energy of the delta1
        ek=sqrt(dm1**2+PT**2+Pz**2)
 * (1) Generate the momentum of the delta2 in the cms of delta2 and pion
 *     the energy of the cms of DP
         eln=srt-ek
        IF(ELN.lE.0)then
        icou1=-1
        return
        endif
 * beta and gamma of the cms of delta2+pion
        bx=-Px/eln
        by=-Py/eln
        bz=-Pz/eln
 
 clin-9/2012: check argument in sqrt():
        scheck=1.-bx**2-by**2-bz**2
        if(scheck.le.0) then
           write(99,*) 'scheck22: ', scheck
           stop
        endif
        ga=1./sqrt(scheck)
 c       ga=1./sqrt(1.-bx**2-by**2-bz**2)
 
 * the momentum of delta2 and pion in their cms frame
        elnc=eln/ga 
        pn2=((elnc**2+dm2**2-amp**2)/(2.*elnc))**2-dm2**2
        if(pn2.le.0)then
        icou1=-1
        return
        endif
        pn=sqrt(pn2)
 
 clin-10/25/02 get rid of argument usage mismatch in PTR():
         xptr=0.33*PN
 c       PNT=PTR(0.33*PN,ISEED)
        PNT=PTR(xptr,ISEED)
 clin-10/25/02-end
 
        fain=2.*pi*RANART(NSEED)
        pnx=pnT*cos(fain)
        pny=pnT*sin(fain)
        SIG=1
        IF(X.GT.0)SIG=-1
 
 clin-9/2012: check argument in sqrt():
        scheck=pn**2-PNT**2
        if(scheck.lt.0) then
           write(99,*) 'scheck23: ', scheck
           scheck=0.
        endif
        pnz=SIG*SQRT(scheck)
 c       pnz=SIG*SQRT(pn**2-PNT**2)
 
        en=sqrt(dm2**2+pnx**2+pny**2+pnz**2)
 * (2) the momentum for the pion
        ppx=-pnx
        ppy=-pny
        ppz=-pnz
        ep=sqrt(amp**2+ppx**2+ppy**2+ppz**2)
 * (3) for the delta2, LORENTZ-TRANSFORMATION INTO nn cms FRAME
         PBETA  = PnX*BX + PnY*By+ PnZ*Bz
               TRANS0  = GA * ( GA * PBETA / (GA + 1.) + En )
               Pnx = BX * TRANS0 + PnX
               Pny = BY * TRANS0 + PnY
               Pnz = BZ * TRANS0 + PnZ
 * (4) for the pion, LORENTZ-TRANSFORMATION INTO nn cms FRAME
              if(ep.eq.0.)ep=1.E-09
               PBETA  = PPX*BX + PPY*By+ PPZ*Bz
               TRANS0  = GA * ( GA * PBETA / (GA + 1.) + EP )
               PPx = BX * TRANS0 + PPX
               PPy = BY * TRANS0 + PPY
               PPz = BZ * TRANS0 + PPZ
        return
        end
 ****************************************
         SUBROUTINE ddrho(SRT,ISEED,PX,PY,PZ,DM1,PNX,
      &  PNY,PNZ,DM2,PPX,PPY,PPZ,amp,icou1)
 * PURPOSE : CALCULATE MOMENTUM OF PARTICLES IN THE FINAL SATAT FROM
 * THE PROCESS N+N--->D1+D2+rho
 *       DATE : Nov.5, 1994
 * Generate the masses and momentum for particles in the NN-->DDrho process
 * for a given center of mass energy srt, the momenta are given in the center
 * of mass of the NN
 *****************************************
         COMMON/TABLE/ xarray(0:1000),earray(0:1000)
 cc      SAVE /TABLE/
       COMMON/RNDF77/NSEED
 cc      SAVE /RNDF77/
       SAVE   
        icou1=0
        pi=3.1415926
         AMN=938.925/1000.
         AMP=770./1000.
 * (1) GENGRATE THE MASS OF DELTA1 AND DELTA2 USING
        srt1=srt-amp-0.02
        ntrym=0
 8       call Rmasdd(srt1,1.232,1.232,1.08,
      &  1.08,ISEED,1,dm1,dm2)
        ntrym=ntrym+1
 * GENERATE THE MASS FOR THE RHO
        RHOMAX = SRT-DM1-DM2-0.02
        IF(RHOMAX.LE.0.and.ntrym.le.20)go to 8
        AMP=RHOMAS(RHOMAX,ISEED)
 * CONSTANTS FOR GENERATING THE LONGITUDINAL MOMENTUM 
 * FOR ONE OF THE RESONANCES
        V=0.43
        W=-0.84
 * (2) Generate the transverse momentum
 *     OF DELTA1
 * (2.1) estimate the maximum transverse momentum
        PTMAX2=(SRT**2-(DM1+DM2+AMP)**2)*
      1  (SRT**2-(DM1-AMP-DM2)**2)/4./SRT**2
 
 clin-9/2012: check argument in sqrt():
        scheck=PTMAX2
        if(scheck.lt.0) then
           write(99,*) 'scheck24: ', scheck
           scheck=0.
        endif
        PTMAX=SQRT(scheck)*1./3.
 c       PTMAX=SQRT(PTMAX2)*1./3.
 
 7       PT=PTR(PTMAX,ISEED)
 * (3) GENGRATE THE LONGITUDINAL MOMENTUM FOR DM1
 *     USING THE GIVEN DISTRIBUTION
 * (3.1) THE MAXIMUM LONGITUDINAL MOMENTUM IS
        PZMAX2=(SRT**2-(DM1+DM2+AMP)**2)*
      1  (SRT**2-(DM1-AMP-DM2)**2)/4./SRT**2-PT**2
        IF((PZMAX2.LT.0.).and.ntrym.le.100)then 
        go to 7
        else
        pzmax2=1.E-06
        endif
        PZMAX=SQRT(PZMAX2)
        XMAX=2.*PZMAX/SRT
 * (3.2) THE GENERATED X IS
 * THE DSTRIBUTION HAS A MAXIMUM AT X0=-V/(2*w), f(X0)=1.056
        ntryx=0
        fmax00=1.056
        x00=0.26
        if(abs(xmax).gt.0.26)then
        f00=fmax00
        else
        f00=1.+v*abs(xmax)+w*xmax**2
        endif
 9       X=XMAX*(1.-2.*RANART(NSEED))
        ntryx=ntryx+1
        xratio=(1.+V*ABS(X)+W*X**2)/f00       
 clin-8/17/00       IF(xratio.LT.RANART(NSEED).and.ntryx.le.50)GO TO 9       
        IF(xratio.LT.RANART(NSEED).and.ntryx.le.50)GO TO 9       
 * (3.5) THE PZ IS
        PZ=0.5*SRT*X
 * The x and y components of the delta1
        fai=2.*pi*RANART(NSEED)
        Px=pt*cos(fai)
        Py=pt*sin(fai)
 * find the momentum of delta2 and rho
 * the energy of the delta1
        ek=sqrt(dm1**2+PT**2+Pz**2)
 * (1) Generate the momentum of the delta2 in the cms of delta2 and rho
 *     the energy of the cms of Drho
         eln=srt-ek
        IF(ELN.lE.0)then
        icou1=-1
        return
        endif
 * beta and gamma of the cms of delta2 and rho
        bx=-Px/eln
        by=-Py/eln
        bz=-Pz/eln
 
 clin-9/2012: check argument in sqrt():
        scheck=1.-bx**2-by**2-bz**2
        if(scheck.le.0) then
           write(99,*) 'scheck25: ', scheck
           stop
        endif
        ga=1./sqrt(scheck)
 c       ga=1./sqrt(1.-bx**2-by**2-bz**2)
 
        elnc=eln/ga
        pn2=((elnc**2+dm2**2-amp**2)/(2.*elnc))**2-dm2**2
        if(pn2.le.0)then
        icou1=-1
        return
        endif
        pn=sqrt(pn2)
 
 clin-10/25/02 get rid of argument usage mismatch in PTR():
         xptr=0.33*PN
 c       PNT=PTR(0.33*PN,ISEED)
        PNT=PTR(xptr,ISEED)
 clin-10/25/02-end
 
        fain=2.*pi*RANART(NSEED)
        pnx=pnT*cos(fain)
        pny=pnT*sin(fain)
        SIG=1
        IF(X.GT.0)SIG=-1
 
 clin-9/2012: check argument in sqrt():
        scheck=pn**2-PNT**2
        if(scheck.lt.0) then
           write(99,*) 'scheck26: ', scheck
           scheck=0.
        endif
        pnz=SIG*SQRT(scheck)
 c       pnz=SIG*SQRT(pn**2-PNT**2)
 
        en=sqrt(dm2**2+pnx**2+pny**2+pnz**2)
 * (2) the momentum for the rho
        ppx=-pnx
        ppy=-pny
        ppz=-pnz
        ep=sqrt(amp**2+ppx**2+ppy**2+ppz**2)
 * (3) for the delta2, LORENTZ-TRANSFORMATION INTO nn cms FRAME
         PBETA  = PnX*BX + PnY*By+ PnZ*Bz
               TRANS0  = GA * ( GA * PBETA / (GA + 1.) + En )
               Pnx = BX * TRANS0 + PnX
               Pny = BY * TRANS0 + PnY
               Pnz = BZ * TRANS0 + PnZ
 * (4) for the rho, LORENTZ-TRANSFORMATION INTO nn cms FRAME
              if(ep.eq.0.)ep=1.e-09
               PBETA  = PPX*BX + PPY*By+ PPZ*Bz
               TRANS0  = GA * ( GA * PBETA / (GA + 1.) + EP )
               PPx = BX * TRANS0 + PPX
               PPy = BY * TRANS0 + PPY
               PPz = BZ * TRANS0 + PPZ
        return
        end
 ****************************************
         SUBROUTINE pprho(SRT,ISEED,PX,PY,PZ,DM1,PNX,
      &  PNY,PNZ,DM2,PPX,PPY,PPZ,amp,icou1)
 * PURPOSE : CALCULATE MOMENTUM OF PARTICLES IN THE FINAL SATAT FROM
 * THE PROCESS N+N--->N1+N2+rho
 *       DATE : Nov.5, 1994
 * Generate the masses and momentum for particles in the NN--> process
 * for a given center of mass energy srt, the momenta are given in the center
 * of mass of the NN
 *****************************************
         COMMON/TABLE/ xarray(0:1000),earray(0:1000)
 cc      SAVE /TABLE/
       COMMON/RNDF77/NSEED
 cc      SAVE /RNDF77/
       SAVE   
         ntrym=0
        icou1=0
        pi=3.1415926
         AMN=938.925/1000.
 *        AMP=770./1000.
        DM1=amn
        DM2=amn
 * GENERATE THE MASS FOR THE RHO
        RHOMAX=SRT-DM1-DM2-0.02
        IF(RHOMAX.LE.0)THEN
        ICOU=-1
        RETURN
        ENDIF
        AMP=RHOMAS(RHOMAX,ISEED)
 * CONSTANTS FOR GENERATING THE LONGITUDINAL MOMENTUM 
 * FOR ONE OF THE nucleons
        V=0.43
        W=-0.84
 * (2) Generate the transverse momentum
 *     OF p1
 * (2.1) estimate the maximum transverse momentum
        PTMAX2=(SRT**2-(DM1+DM2+AMP)**2)*
      1  (SRT**2-(DM1-AMP-DM2)**2)/4./SRT**2
 
 clin-9/2012: check argument in sqrt():
        scheck=PTMAX2
        if(scheck.lt.0) then
           write(99,*) 'scheck27: ', scheck
           scheck=0.
        endif
        PTMAX=SQRT(scheck)*1./3.
 c       PTMAX=SQRT(PTMAX2)*1./3.
 
 7       PT=PTR(PTMAX,ISEED)
 * (3) GENGRATE THE LONGITUDINAL MOMENTUM FOR DM1
 *     USING THE GIVEN DISTRIBUTION
 * (3.1) THE MAXIMUM LONGITUDINAL MOMENTUM IS
        PZMAX2=(SRT**2-(DM1+DM2+AMP)**2)*
      1  (SRT**2-(DM1-AMP-DM2)**2)/4./SRT**2-PT**2
        NTRYM=NTRYM+1
        IF((PZMAX2.LT.0.).and.ntrym.le.100)then 
        go to 7
        else
        pzmax2=1.E-06
        endif
        PZMAX=SQRT(PZMAX2)
        XMAX=2.*PZMAX/SRT
 * (3.2) THE GENERATED X IS
 * THE DSTRIBUTION HAS A MAXIMUM AT X0=-V/(2*w), f(X0)=1.056
        ntryx=0
        fmax00=1.056
        x00=0.26
        if(abs(xmax).gt.0.26)then
        f00=fmax00
        else
        f00=1.+v*abs(xmax)+w*xmax**2
        endif
 9       X=XMAX*(1.-2.*RANART(NSEED))
        ntryx=ntryx+1
        xratio=(1.+V*ABS(X)+W*X**2)/f00       
 clin-8/17/00       IF(xratio.LT.RANART(NSEED).and.ntryx.le.50)GO TO 9       
        IF(xratio.LT.RANART(NSEED).and.ntryx.le.50)GO TO 9       
 * (3.5) THE PZ IS
        PZ=0.5*SRT*X
 * The x and y components of the delta1
        fai=2.*pi*RANART(NSEED)
        Px=pt*cos(fai)
        Py=pt*sin(fai)
 * find the momentum of delta2 and rho
 * the energy of the delta1
        ek=sqrt(dm1**2+PT**2+Pz**2)
 * (1) Generate the momentum of the delta2 in the cms of delta2 and rho
 *     the energy of the cms of Drho
         eln=srt-ek
        IF(ELN.lE.0)then
        icou1=-1
        return
        endif
 * beta and gamma of the cms of the two partciles
        bx=-Px/eln
        by=-Py/eln
        bz=-Pz/eln
 
 clin-9/2012: check argument in sqrt():
        scheck=1.-bx**2-by**2-bz**2
        if(scheck.le.0) then
           write(99,*) 'scheck28: ', scheck
           stop
        endif
        ga=1./sqrt(scheck)
 c       ga=1./sqrt(1.-bx**2-by**2-bz**2)
 
         elnc=eln/ga
        pn2=((elnc**2+dm2**2-amp**2)/(2.*elnc))**2-dm2**2
        if(pn2.le.0)then
        icou1=-1
        return
        endif
        pn=sqrt(pn2)
 
 clin-10/25/02 get rid of argument usage mismatch in PTR():
         xptr=0.33*PN
 c       PNT=PTR(0.33*PN,ISEED)
        PNT=PTR(xptr,ISEED)
 clin-10/25/02-end
 
        fain=2.*pi*RANART(NSEED)
        pnx=pnT*cos(fain)
        pny=pnT*sin(fain)
        SIG=1
        IF(X.GT.0)SIG=-1
 
 clin-9/2012: check argument in sqrt():
        scheck=pn**2-PNT**2
        if(scheck.lt.0) then
           write(99,*) 'scheck29: ', scheck
           scheck=0.
        endif
        pnz=SIG*SQRT(scheck)
 c       pnz=SIG*SQRT(pn**2-PNT**2)
 
        en=sqrt(dm2**2+pnx**2+pny**2+pnz**2)
 * (2) the momentum for the rho
        ppx=-pnx
        ppy=-pny
        ppz=-pnz
        ep=sqrt(amp**2+ppx**2+ppy**2+ppz**2)
 * (3) for the delta2, LORENTZ-TRANSFORMATION INTO nn cms FRAME
         PBETA  = PnX*BX + PnY*By+ PnZ*Bz
               TRANS0  = GA * ( GA * PBETA / (GA + 1.) + En )
               Pnx = BX * TRANS0 + PnX
               Pny = BY * TRANS0 + PnY
               Pnz = BZ * TRANS0 + PnZ
 * (4) for the rho, LORENTZ-TRANSFORMATION INTO nn cms FRAME
              if(ep.eq.0.)ep=1.e-09
               PBETA  = PPX*BX + PPY*By+ PPZ*Bz
               TRANS0  = GA * ( GA * PBETA / (GA + 1.) + EP )
               PPx = BX * TRANS0 + PPX
               PPy = BY * TRANS0 + PPY
               PPz = BZ * TRANS0 + PPZ
        return
        end
 ***************************8
 ****************************************
         SUBROUTINE ppomga(SRT,ISEED,PX,PY,PZ,DM1,PNX,
      &  PNY,PNZ,DM2,PPX,PPY,PPZ,icou1)
 * PURPOSE : CALCULATE MOMENTUM OF PARTICLES IN THE FINAL SATAT FROM
 * THE PROCESS N+N--->N1+N2+OMEGA
 *       DATE : Nov.5, 1994
 * Generate the masses and momentum for particles in the NN--> process
 * for a given center of mass energy srt, the momenta are given in the center
 * of mass of the NN
 *****************************************
         COMMON/TABLE/ xarray(0:1000),earray(0:1000)
 cc      SAVE /TABLE/
       COMMON/RNDF77/NSEED
 cc      SAVE /RNDF77/
       SAVE   
         ntrym=0
        icou1=0
        pi=3.1415926
         AMN=938.925/1000.
         AMP=782./1000.
        DM1=amn
        DM2=amn
 * CONSTANTS FOR GENERATING THE LONGITUDINAL MOMENTUM 
 * FOR ONE OF THE nucleons
        V=0.43
        W=-0.84
 * (2) Generate the transverse momentum
 *     OF p1
 * (2.1) estimate the maximum transverse momentum
        PTMAX2=(SRT**2-(DM1+DM2+AMP)**2)*
      1  (SRT**2-(DM1-AMP-DM2)**2)/4./SRT**2
 
 clin-9/2012: check argument in sqrt():
        scheck=PTMAX2
        if(scheck.lt.0) then
           write(99,*) 'scheck30: ', scheck
           scheck=0.
        endif
        PTMAX=SQRT(scheck)*1./3.
 c       PTMAX=SQRT(PTMAX2)*1./3.
 
 7       PT=PTR(PTMAX,ISEED)
 * (3) GENGRATE THE LONGITUDINAL MOMENTUM FOR DM1
 *     USING THE GIVEN DISTRIBUTION
 * (3.1) THE MAXIMUM LONGITUDINAL MOMENTUM IS
        PZMAX2=(SRT**2-(DM1+DM2+AMP)**2)*
      1  (SRT**2-(DM1-AMP-DM2)**2)/4./SRT**2-PT**2
        NTRYM=NTRYM+1
        IF((PZMAX2.LT.0.).and.ntrym.le.100)then 
        go to 7
        else
        pzmax2=1.E-09
        endif
        PZMAX=SQRT(PZMAX2)
        XMAX=2.*PZMAX/SRT
 * (3.2) THE GENERATED X IS
 * THE DSTRIBUTION HAS A MAXIMUM AT X0=-V/(2*w), f(X0)=1.056
        ntryx=0
        fmax00=1.056
        x00=0.26
        if(abs(xmax).gt.0.26)then
        f00=fmax00
        else
        f00=1.+v*abs(xmax)+w*xmax**2
        endif
 9       X=XMAX*(1.-2.*RANART(NSEED))
        ntryx=ntryx+1
        xratio=(1.+V*ABS(X)+W*X**2)/f00       
 clin-8/17/00       IF(xratio.LT.RANART(NSEED).and.ntryx.le.50)GO TO 9       
        IF(xratio.LT.RANART(NSEED).and.ntryx.le.50)GO TO 9       
 * (3.5) THE PZ IS
        PZ=0.5*SRT*X
 * The x and y components of the delta1
        fai=2.*pi*RANART(NSEED)
        Px=pt*cos(fai)
        Py=pt*sin(fai)
 * find the momentum of delta2 and rho
 * the energy of the delta1
        ek=sqrt(dm1**2+PT**2+Pz**2)
 * (1) Generate the momentum of the delta2 in the cms of delta2 and rho
 *     the energy of the cms of Drho
         eln=srt-ek
        IF(ELN.lE.0)then
        icou1=-1
        return
        endif
        bx=-Px/eln
        by=-Py/eln
        bz=-Pz/eln
 
 clin-9/2012: check argument in sqrt():
        scheck=1.-bx**2-by**2-bz**2
        if(scheck.le.0) then
           write(99,*) 'scheck31: ', scheck
           stop
        endif
        ga=1./sqrt(scheck)
 c       ga=1./sqrt(1.-bx**2-by**2-bz**2)
 
        elnc=eln/ga
        pn2=((elnc**2+dm2**2-amp**2)/(2.*elnc))**2-dm2**2
        if(pn2.le.0)then
        icou1=-1
        return
        endif
        pn=sqrt(pn2)
 
 clin-10/25/02 get rid of argument usage mismatch in PTR():
         xptr=0.33*PN
 c       PNT=PTR(0.33*PN,ISEED)
        PNT=PTR(xptr,ISEED)
 clin-10/25/02-end
 
        fain=2.*pi*RANART(NSEED)
        pnx=pnT*cos(fain)
        pny=pnT*sin(fain)
        SIG=1
        IF(X.GT.0)SIG=-1
 
 clin-9/2012: check argument in sqrt():
        scheck=pn**2-PNT**2
        if(scheck.lt.0) then
           write(99,*) 'scheck32: ', scheck
           scheck=0.
        endif
        pnz=SIG*SQRT(scheck)
 c       pnz=SIG*SQRT(pn**2-PNT**2)
 
        en=sqrt(dm2**2+pnx**2+pny**2+pnz**2)
 * (2) the momentum for the rho
        ppx=-pnx
        ppy=-pny
        ppz=-pnz
        ep=sqrt(amp**2+ppx**2+ppy**2+ppz**2)
 * (3) for the delta2, LORENTZ-TRANSFORMATION INTO nn cms FRAME
         PBETA  = PnX*BX + PnY*By+ PnZ*Bz
               TRANS0  = GA * ( GA * PBETA / (GA + 1.) + En )
               Pnx = BX * TRANS0 + PnX
               Pny = BY * TRANS0 + PnY
               Pnz = BZ * TRANS0 + PnZ
 * (4) for the rho, LORENTZ-TRANSFORMATION INTO nn cms FRAME
              if(ep.eq.0.)ep=1.E-09
               PBETA  = PPX*BX + PPY*By+ PPZ*Bz
               TRANS0  = GA * ( GA * PBETA / (GA + 1.) + EP )
               PPx = BX * TRANS0 + PPX
               PPy = BY * TRANS0 + PPY
               PPz = BZ * TRANS0 + PPZ
        return
        end
 ***************************8
 ***************************8
 *   DELTA MASS GENERATOR
        REAL FUNCTION RMASS(DMAX,ISEED)
       COMMON/RNDF77/NSEED
 cc      SAVE /RNDF77/
       SAVE   
 * THE MINIMUM MASS FOR DELTA
           DMIN = 1.078
 * Delta(1232) production
           IF(DMAX.LT.1.232) THEN
           FM=FDELTA(DMAX)
           ELSE
           FM=1.
           ENDIF
           IF(FM.EQ.0.)FM=1.E-06
           NTRY1=0
 10        DM = RANART(NSEED) * (DMAX-DMIN) + DMIN
           NTRY1=NTRY1+1
           IF((RANART(NSEED) .GT. FDELTA(DM)/FM).AND.
      1    (NTRY1.LE.10)) GOTO 10
 clin-2/26/03 sometimes Delta mass can reach very high values (e.g. 15.GeV),
 c     thus violating the thresh of the collision which produces it 
 c     and leads to large violation of energy conservation. 
 c     To limit the above, limit the Delta mass below a certain value 
 c     (here taken as its central value + 2* B-W fullwidth):
           if(dm.gt.1.47) goto 10
 
        RMASS=DM
        RETURN
        END
 
 *------------------------------------------------------------------
 * THE Breit Wigner FORMULA
         REAL FUNCTION FRHO(DMASS)
       SAVE   
         AM0=0.77
        WID=0.153
         FD=0.25*wid**2/((DMASS-AM0)**2+0.25*WID**2)
         FRHO=FD
         RETURN
         END
 ***************************8
 *   RHO MASS GENERATOR
        REAL FUNCTION RHOMAS(DMAX,ISEED)
       COMMON/RNDF77/NSEED
 cc      SAVE /RNDF77/
       SAVE   
 * THE MINIMUM MASS FOR DELTA
           DMIN = 0.28
 * RHO(770) production
           IF(DMAX.LT.0.77) THEN
           FM=FRHO(DMAX)
           ELSE
           FM=1.
           ENDIF
           IF(FM.EQ.0.)FM=1.E-06
           NTRY1=0
 10        DM = RANART(NSEED) * (DMAX-DMIN) + DMIN
           NTRY1=NTRY1+1
           IF((RANART(NSEED) .GT. FRHO(DM)/FM).AND.
      1    (NTRY1.LE.10)) GOTO 10
 clin-2/26/03 limit the rho mass below a certain value
 c     (here taken as its central value + 2* B-W fullwidth):
           if(dm.gt.1.07) goto 10
 
        RHOMAS=DM
        RETURN
        END
 ******************************************
 * for pp-->pp+2pi
 c      real*4 function X2pi(srt)
       real function X2pi(srt)
 *  This function contains the experimental 
 c     total pp-pp+pi(+)pi(-) Xsections    *
 *  srt    = DSQRT(s) in GeV                                                  *
 *  xsec   = production cross section in mb                                   *
 *  earray = EXPerimental table with proton momentum in GeV/c                 *
 *  xarray = EXPerimental table with cross sections in mb (curve to guide eye)*
 *                                                                            *
 ******************************************
 c      real*4   xarray(15), earray(15)
       real   xarray(15), earray(15)
       SAVE   
       data earray /2.23,2.81,3.67,4.0,4.95,5.52,5.97,6.04,
      &6.6,6.9,7.87,8.11,10.01,16.0,19./
       data xarray /1.22,2.51,2.67,2.95,2.96,2.84,2.8,3.2,
      &2.7,3.0,2.54,2.46,2.4,1.66,1.5/
 
            pmass=0.9383 
 * 1.Calculate p(lab)  from srt [GeV]
 *   Formula used:   DSQRT(s) = 2 m DSQRT(E_kin/(2m) + 1)
 c      ekin = 2.*pmass*((srt/(2.*pmass))**2 - 1.)
        x2pi=0.000001
        if(srt.le.2.2)return
       plab=sqrt(((srt**2-2.*pmass**2)/(2.*pmass))**2-pmass**2)
       if (plab .lt. earray(1)) then
         x2pi = xarray(1)
         return
       end if
 *
 * 2.Interpolate double logarithmically to find sigma(srt)
 *
       do 1001 ie = 1,15
         if (earray(ie) .eq. plab) then
           x2pi= xarray(ie)
           return
         else if (earray(ie) .gt. plab) then
           ymin = alog(xarray(ie-1))
           ymax = alog(xarray(ie))
           xmin = alog(earray(ie-1))
           xmax = alog(earray(ie))
           X2pi = exp(ymin + (alog(plab)-xmin)*(ymax-ymin)
      &    /(xmax-xmin) )
           return
         end if
  1001 continue
       return
         END
 ******************************************
 * for pp-->pn+pi(+)pi(+)pi(-)
 c      real*4 function X3pi(srt)
       real function X3pi(srt)
 *  This function contains the experimental pp->pp+3pi cross sections          *
 *  srt    = DSQRT(s) in GeV                                                   *
 *  xsec   = production cross section in mb                                    *
 *  earray = EXPerimental table with proton energies in MeV                    *
 *  xarray = EXPerimental table with cross sections in mb (curve to guide eye) *
 *                                                                             *
 ******************************************
 c      real*4   xarray(12), earray(12)
       real   xarray(12), earray(12)
       SAVE   
       data xarray /0.02,0.4,1.15,1.60,2.19,2.85,2.30,
      &3.10,2.47,2.60,2.40,1.70/
       data earray /2.23,2.81,3.67,4.00,4.95,5.52,5.97,
      &6.04,6.60,6.90,10.01,19./
 
            pmass=0.9383 
 * 1.Calculate p(lab)  from srt [GeV]
 *   Formula used:   DSQRT(s) = 2 m DSQRT(E_kin/(2m) + 1)
 c      ekin = 2.*pmass*((srt/(2.*pmass))**2 - 1.)
        x3pi=1.E-06
        if(srt.le.2.3)return
       plab=sqrt(((srt**2-2.*pmass**2)/(2.*pmass))**2-pmass**2)
       if (plab .lt. earray(1)) then
         x3pi = xarray(1)
         return
       end if
 *
 * 2.Interpolate double logarithmically to find sigma(srt)
 *
       do 1001 ie = 1,12
         if (earray(ie) .eq. plab) then
           x3pi= xarray(ie)
           return
         else if (earray(ie) .gt. plab) then
           ymin = alog(xarray(ie-1))
           ymax = alog(xarray(ie))
           xmin = alog(earray(ie-1))
           xmax = alog(earray(ie))
           X3pi= exp(ymin + (alog(plab)-xmin)*(ymax-ymin)
      &                                            /(xmax-xmin) )
           return
         end if
  1001 continue
       return
         END
 ******************************************
 ******************************************
 * for pp-->pp+pi(+)pi(-)pi(0)
 c      real*4 function X33pi(srt)
       real function X33pi(srt)
 *  This function contains the experimental pp->pp+3pi cross sections          *
 *  srt    = DSQRT(s) in GeV                                                   *
 *  xsec   = production cross section in mb                                    *
 *  earray = EXPerimental table with proton energies in MeV                    *
 *  xarray = EXPerimental table with cross sections in mb (curve to guide eye) *
 *                                                                             *
 ******************************************
 c      real*4   xarray(12), earray(12)
       real   xarray(12), earray(12)
       SAVE   
       data xarray /0.02,0.22,0.74,1.10,1.76,1.84,2.20,
      &2.40,2.15,2.60,2.30,1.70/
       data earray /2.23,2.81,3.67,4.00,4.95,5.52,5.97,
      &6.04,6.60,6.90,10.01,19./
 
            pmass=0.9383 
        x33pi=1.E-06
        if(srt.le.2.3)return
 * 1.Calculate p(lab)  from srt [GeV]
 *   Formula used:   DSQRT(s) = 2 m DSQRT(E_kin/(2m) + 1)
 c      ekin = 2.*pmass*((srt/(2.*pmass))**2 - 1.)
       plab=sqrt(((srt**2-2.*pmass**2)/(2.*pmass))**2-pmass**2)
       if (plab .lt. earray(1)) then
         x33pi = xarray(1)
         return
       end if
 *
 * 2.Interpolate double logarithmically to find sigma(srt)
 *
       do 1001 ie = 1,12
         if (earray(ie) .eq. plab) then
           x33pi= xarray(ie)
           return
         else if (earray(ie) .gt. plab) then
           ymin = alog(xarray(ie-1))
           ymax = alog(xarray(ie))
           xmin = alog(earray(ie-1))
           xmax = alog(earray(ie))
           x33pi= exp(ymin + (alog(plab)-xmin)*(ymax-ymin)
      &    /(xmax-xmin))
           return
         end if
  1001   continue
         return
         END
 ******************************************
 c       REAL*4 FUNCTION X4pi(SRT)
       REAL FUNCTION X4pi(SRT)
       SAVE   
 *       CROSS SECTION FOR NN-->DD+rho PROCESS
 * *****************************
        akp=0.498
        ak0=0.498
        ana=0.94
        ada=1.232
        al=1.1157
        as=1.1197
        pmass=0.9383
        ES=SRT
        IF(ES.LE.4)THEN
        X4pi=0.
        ELSE
 * cross section for two resonance pp-->DD+DN*+N*N*
        xpp2pi=4.*x2pi(es)
 * cross section for pp-->pp+spi
        xpp3pi=3.*(x3pi(es)+x33pi(es))
 * cross section for pp-->pD+ and nD++
        pps1=sigma(es,1,1,0)+0.5*sigma(es,1,1,1)
        pps2=1.5*sigma(es,1,1,1)
        ppsngl=pps1+pps2+s1535(es)
 * CROSS SECTION FOR KAON PRODUCTION from the four channels
 * for NLK channel
        xk1=0
        xk2=0
        xk3=0
        xk4=0
        t1nlk=ana+al+akp
        t2nlk=ana+al-akp
        if(es.le.t1nlk)go to 333
        pmnlk2=(es**2-t1nlk**2)*(es**2-t2nlk**2)/(4.*es**2)
        pmnlk=sqrt(pmnlk2)
        xk1=pplpk(es)
 * for DLK channel
        t1dlk=ada+al+akp
        t2dlk=ada+al-akp
        if(es.le.t1dlk)go to 333
        pmdlk2=(es**2-t1dlk**2)*(es**2-t2dlk**2)/(4.*es**2)
        pmdlk=sqrt(pmdlk2)
        xk3=pplpk(es)
 * for NSK channel
        t1nsk=ana+as+akp
        t2nsk=ana+as-akp
        if(es.le.t1nsk)go to 333
        pmnsk2=(es**2-t1nsk**2)*(es**2-t2nsk**2)/(4.*es**2)
        pmnsk=sqrt(pmnsk2)
        xk2=ppk1(es)+ppk0(es)
 * for DSK channel
        t1DSk=aDa+aS+akp
        t2DSk=aDa+aS-akp
        if(es.le.t1dsk)go to 333
        pmDSk2=(es**2-t1DSk**2)*(es**2-t2DSk**2)/(4.*es**2)
        pmDSk=sqrt(pmDSk2)
        xk4=ppk1(es)+ppk0(es)
 * THE TOTAL KAON+ AND KAON0 PRODUCTION CROSS SECTION IS THEN
 333       XKAON=3.*(xk1+xk2+xk3+xk4)
 * cross section for pp-->DD+rho
        x4pi=pp1(es)-ppsngl-xpp2pi-xpp3pi-XKAON
        if(x4pi.le.0)x4pi=1.E-06
        ENDIF
        RETURN
        END
 ******************************************
 * for pp-->inelastic
 c      real*4 function pp1(srt)
       real function pp1(srt)
       SAVE   
 *  srt    = DSQRT(s) in GeV                                                   *
 *  xsec   = production cross section in mb                                    *
 *  earray = EXPerimental table with proton energies in MeV                    *
 *  xarray = EXPerimental table with cross sections in mb (curve to guide eye) *
 *                                                                             *
 ******************************************
            pmass=0.9383 
        PP1=0.
 * 1.Calculate p(lab)  from srt [GeV]
 *   Formula used:   DSQRT(s) = 2 m DSQRT(E_kin/(2m) + 1)
 c      ekin = 2.*pmass*((srt/(2.*pmass))**2 - 1.)
       plab2=((srt**2-2.*pmass**2)/(2.*pmass))**2-pmass**2
        IF(PLAB2.LE.0)RETURN
       plab=sqrt(PLAB2)
        pmin=0.968
        pmax=2080
       if ((plab .lt. pmin).or.(plab.gt.pmax)) then
         pp1 = 0.
         return
       end if
 c* fit parameters
        a=30.9
        b=-28.9
        c=0.192
        d=-0.835
        an=-2.46
         pp1 = a+b*(plab**an)+c*(alog(plab))**2
        if(pp1.le.0)pp1=0.0
         return
         END
 ******************************************
 * for pp-->elastic
 c      real*4 function pp2(srt)
       real function pp2(srt)
       SAVE   
 *  srt    = DSQRT(s) in GeV                                                   *
 *  xsec   = production cross section in mb                                    *
 *  earray = EXPerimental table with proton energies in MeV                    *
 *  xarray = EXPerimental table with cross sections in mb (curve to guide eye) *
 *                                                                             *
 ******************************************
            pmass=0.9383 
 * 1.Calculate p(lab)  from srt [GeV]
 *   Formula used:   DSQRT(s) = 2 m DSQRT(E_kin/(2m) + 1)
 c      ekin = 2.*pmass*((srt/(2.*pmass))**2 - 1.)
 
 clin-9/2012: check argument in sqrt():
        scheck=((srt**2-2.*pmass**2)/(2.*pmass))**2-pmass**2
        if(scheck.lt.0) then
           write(99,*) 'scheck33: ', scheck
           scheck=0.
        endif
        plab=sqrt(scheck)
 c      plab=sqrt(((srt**2-2.*pmass**2)/(2.*pmass))**2-pmass**2)
 
        pmin=2.
        pmax=2050
        if(plab.gt.pmax)then
        pp2=8.
        return
        endif
         if(plab .lt. pmin)then
         pp2 = 25.
         return
         end if
 c* fit parameters
        a=11.2
        b=25.5
        c=0.151
        d=-1.62
        an=-1.12
         pp2 = a+b*(plab**an)+c*(alog(plab))**2+d*alog(plab)
        if(pp2.le.0)pp2=0
         return
         END
 
 ******************************************
 * for pp-->total
 c      real*4 function ppt(srt)
       real function ppt(srt)
       SAVE   
 *  srt    = DSQRT(s) in GeV                                                   *
 *  xsec   = production cross section in mb                                    *
 *  earray = EXPerimental table with proton energies in MeV                    *
 *  xarray = EXPerimental table with cross sections in mb (curve to guide eye) *
 *                                                                             *
 ******************************************
            pmass=0.9383 
 * 1.Calculate p(lab)  from srt [GeV]
 *   Formula used:   DSQRT(s) = 2 m DSQRT(E_kin/(2m) + 1)
 c      ekin = 2.*pmass*((srt/(2.*pmass))**2 - 1.)
 
 clin-9/2012: check argument in sqrt():
        scheck=((srt**2-2.*pmass**2)/(2.*pmass))**2-pmass**2
        if(scheck.lt.0) then
           write(99,*) 'scheck34: ', scheck
           scheck=0.
        endif
        plab=sqrt(scheck)
 c      plab=sqrt(((srt**2-2.*pmass**2)/(2.*pmass))**2-pmass**2)
 
        pmin=3. 
        pmax=2100
       if ((plab .lt. pmin).or.(plab.gt.pmax)) then
         ppt = 55.
         return
       end if
 c* fit parameters
        a=45.6
        b=219.0
        c=0.410
        d=-3.41
        an=-4.23
         ppt = a+b*(plab**an)+c*(alog(plab))**2+d*alog(plab)
        if(ppt.le.0)ppt=0.0
         return
         END
 
 *************************
 * cross section for N*(1535) production in PP collisions
 * VARIABLES:
 * LB1,LB2 ARE THE LABLES OF THE TWO COLLIDING PARTICLES
 * SRT IS THE CMS ENERGY
 * X1535 IS THE N*(1535) PRODUCTION CROSS SECTION
 * NOTE THAT THE N*(1535) PRODUCTION CROSS SECTION IS 2 TIMES THE ETA 
 * PRODUCTION CROSS SECTION
 * DATE: Aug. 1 , 1994
 * ********************************
        real function s1535(SRT)
       SAVE   
        S0=2.424
        s1535=0.
        IF(SRT.LE.S0)RETURN
        S1535=2.*0.102*(SRT-S0)/(0.058+(SRT-S0)**2)
        return
        end
 ****************************************
 * generate a table for pt distribution for
        subroutine tablem
 * THE PROCESS N+N--->N+N+PION
 *       DATE : July 11, 1994
 *****************************************
         COMMON/TABLE/ xarray(0:1000),earray(0:1000)
 cc      SAVE /TABLE/
       SAVE   
        ptmax=2.01
        anorm=ptdis(ptmax)
        do 10 L=0,200
        x=0.01*float(L+1)
        rr=ptdis(x)/anorm
        earray(l)=rr
        xarray(l)=x
 10       continue
        RETURN
        end
 *********************************
        real function ptdis(x)
       SAVE   
 * NUCLEON TRANSVERSE MOMENTUM DISTRIBUTION AT HIGH ENERGIES
 * DATE: Aug. 11, 1994
 *********************************
        b=3.78
        c=0.47
        d=3.60
 c       b=b*3
 c       d=d*3
        ptdis=1./(2.*b)*(1.-exp(-b*x**2))-c/d*x*exp(-d*x)
      1     -c/D**2*(exp(-d*x)-1.)
        return
        end
 *****************************
        subroutine ppxS(lb1,lb2,srt,ppsig,spprho,ipp)
 * purpose: this subroutine gives the cross section for pion+pion 
 *          elastic collision
 * variables: 
 *       input: lb1,lb2 and srt are the labels and srt for I1 and I2
 *       output: ppsig: pp xsection
 *               ipp: label for the pion+pion channel
 *               Ipp=0 NOTHING HAPPEND 
 *                  1 for Pi(+)+PI(+) DIRECT
 *                   2     PI(+)+PI(0) FORMING RHO(+)
 *                  3     PI(+)+PI(-) FORMING RHO(0)
 *                   4     PI(0)+PI(O) DIRECT
 *                  5     PI(0)+PI(-) FORMING RHO(-)
 *                  6     PI(-)+PI(-) DIRECT
 * reference: G.F. Bertsch, Phys. Rev. D37 (1988) 1202.
 * date : Aug 29, 1994
 *****************************
        parameter (amp=0.14,pi=3.1415926)
       SAVE   
        PPSIG=0.0
 
 cbzdbg10/15/99
         spprho=0.0
 cbzdbg10/15/99 end
 
        IPP=0
        IF(SRT.LE.0.3)RETURN
        q=sqrt((srt/2)**2-amp**2)
        esigma=5.8*amp
        tsigma=2.06*q
        erho=0.77
        trho=0.095*q*(q/amp/(1.+(q/erho)**2))**2
        esi=esigma-srt
        if(esi.eq.0)then
        d00=pi/2.
        go to 10
        endif
        d00=atan(tsigma/2./esi)
 10       erh=erho-srt
        if(erh.eq.0.)then
        d11=pi/2.
        go to 20
        endif
        d11=atan(trho/2./erh)
 20       d20=-0.12*q/amp
        s0=8.*pi*sin(d00)**2/q**2
        s1=8*pi*3*sin(d11)**2/q**2
        s2=8*pi*5*sin(d20)**2/q**2
 c    !! GeV^-2 to mb
         s0=s0*0.197**2*10.
         s1=s1*0.197**2*10.
         s2=s2*0.197**2*10.
 C       ppXS=s0/9.+s1/3.+s2*0.56
 C       if(ppxs.le.0)ppxs=0.00001
        spprho=s1/2.
 * (1) PI(+)+PI(+)
        IF(LB1.EQ.5.AND.LB2.EQ.5)THEN
        IPP=1
        PPSIG=S2
        RETURN
        ENDIF
 * (2) PI(+)+PI(0)
        IF((LB1.EQ.5.AND.LB2.EQ.4).OR.(LB1.EQ.4.AND.LB2.EQ.5))THEN
        IPP=2
        PPSIG=S2/2.+S1/2.
        RETURN
        ENDIF
 * (3) PI(+)+PI(-)
        IF((LB1.EQ.5.AND.LB2.EQ.3).OR.(LB1.EQ.3.AND.LB2.EQ.5))THEN
        IPP=3
        PPSIG=S2/6.+S1/2.+S0/3.
        RETURN
        ENDIF
 * (4) PI(0)+PI(0)
        IF(LB1.EQ.4.AND.LB2.EQ.4)THEN
        IPP=4
        PPSIG=2*S2/3.+S0/3.
        RETURN
        ENDIF
 * (5) PI(0)+PI(-)
        IF((LB1.EQ.4.AND.LB2.EQ.3).OR.(LB1.EQ.3.AND.LB2.EQ.4))THEN
        IPP=5
        PPSIG=S2/2.+S1/2.
        RETURN
        ENDIF
 * (6) PI(-)+PI(-)
        IF(LB1.EQ.3.AND.LB2.EQ.3)THEN
        IPP=6
        PPSIG=S2
        ENDIF
        return
        end
 **********************************
 * elementary kaon production cross sections
 *  from the CERN data book
 *  date: Sept.2, 1994
 *  for pp-->pLK+
 c      real*4 function pplpk(srt)
       real function pplpk(srt)
       SAVE   
 *  srt    = DSQRT(s) in GeV                                                   *
 *  xsec   = production cross section in mb                                    *
 *  earray = EXPerimental table with proton energies in MeV                    *
 *  xarray = EXPerimental table with cross sections in mb (curve to guide eye) *
 *                                                                             *
 ******************************************
            pmass=0.9383 
 * 1.Calculate p(lab)  from srt [GeV]
 *   Formula used:   DSQRT(s) = 2 m DSQRT(E_kin/(2m) + 1)
 *   find the center of mass energy corresponding to the given pm as
 *   if Lambda+N+K are produced
        pplpk=0.
 
 clin-9/2012: check argument in sqrt():
        scheck=((srt**2-2.*pmass**2)/(2.*pmass))**2-pmass**2
        if(scheck.lt.0) then
           write(99,*) 'scheck35: ', scheck
           scheck=0.
        endif
        plab=sqrt(scheck)
 c        plab=sqrt(((srt**2-2.*pmass**2)/(2.*pmass))**2-pmass**2)
 
        pmin=2.82
        pmax=25.0
        if(plab.gt.pmax)then
        pplpk=0.036
        return
        endif
         if(plab .lt. pmin)then
         pplpk = 0.
         return
         end if
 c* fit parameters
        a=0.0654
        b=-3.16
        c=-0.0029
        an=-4.14
         pplpk = a+b*(plab**an)+c*(alog(plab))**2
        if(pplpk.le.0)pplpk=0
         return
         END
 
 ******************************************
 * for pp-->pSigma+K0
 c      real*4 function ppk0(srt)
       real function ppk0(srt)
 *  srt    = DSQRT(s) in GeV                                                   *
 *  xsec   = production cross section in mb                                    *
 *                                                                             *
 ******************************************
 c      real*4   xarray(7), earray(7)
       real   xarray(7), earray(7)
       SAVE   
       data xarray /0.030,0.025,0.025,0.026,0.02,0.014,0.06/
       data earray /3.67,4.95,5.52,6.05,6.92,7.87,10./
 
            pmass=0.9383 
 * 1.Calculate p(lab)  from srt [GeV]
 *   Formula used:   DSQRT(s) = 2 m DSQRT(E_kin/(2m) + 1)
 c      ekin = 2.*pmass*((srt/(2.*pmass))**2 - 1.)
        ppk0=0
        if(srt.le.2.63)return
        if(srt.gt.4.54)then
        ppk0=0.037
        return
        endif
         plab=sqrt(((srt**2-2.*pmass**2)/(2.*pmass))**2-pmass**2)
         if (plab .lt. earray(1)) then
         ppk0 = xarray(1)
         return
       end if
 *
 * 2.Interpolate double logarithmically to find sigma(srt)
 *
       do 1001 ie = 1,7
         if (earray(ie) .eq. plab) then
           ppk0 = xarray(ie)
           go to 10
         else if (earray(ie) .gt. plab) then
           ymin = alog(xarray(ie-1))
           ymax = alog(xarray(ie))
           xmin = alog(earray(ie-1))
           xmax = alog(earray(ie))
           ppk0 = exp(ymin + (alog(plab)-xmin)*(ymax-ymin)
      &/(xmax-xmin) )
           go to 10
         end if
  1001 continue
 10       continue
       return
         END
 ******************************************
 * for pp-->pSigma0K+
 c      real*4 function ppk1(srt)
       real function ppk1(srt)
 *  srt    = DSQRT(s) in GeV                                                   *
 *  xsec   = production cross section in mb                                    *
 *                                                                             *
 ******************************************
 c      real*4   xarray(7), earray(7)
       real   xarray(7), earray(7)
       SAVE   
       data xarray /0.013,0.025,0.016,0.012,0.017,0.029,0.025/
       data earray /3.67,4.95,5.52,5.97,6.05,6.92,7.87/
 
            pmass=0.9383 
 * 1.Calculate p(lab)  from srt [GeV]
 *   Formula used:   DSQRT(s) = 2 m DSQRT(E_kin/(2m) + 1)
 c      ekin = 2.*pmass*((srt/(2.*pmass))**2 - 1.)
        ppk1=0.
        if(srt.le.2.63)return
        if(srt.gt.4.08)then
        ppk1=0.025
        return
        endif
         plab=sqrt(((srt**2-2.*pmass**2)/(2.*pmass))**2-pmass**2)
         if (plab .lt. earray(1)) then
         ppk1 =xarray(1)
         return
       end if
 *
 * 2.Interpolate double logarithmically to find sigma(srt)
 *
       do 1001 ie = 1,7
         if (earray(ie) .eq. plab) then
           ppk1 = xarray(ie)
           go to 10
         else if (earray(ie) .gt. plab) then
           ymin = alog(xarray(ie-1))
           ymax = alog(xarray(ie))
           xmin = alog(earray(ie-1))
           xmax = alog(earray(ie))
           ppk1 = exp(ymin + (alog(plab)-xmin)*(ymax-ymin)
      &/(xmax-xmin) )
           go to 10
         end if
  1001 continue
 10       continue
       return
         END
 **********************************
 *                                                                      *
 *                                                                      *
       SUBROUTINE CRPN(PX,PY,PZ,SRT,I1,I2,
      & IBLOCK,xkaon0,xkaon,Xphi,xphin)
 *     PURPOSE:                                                         *
 *           DEALING WITH PION+N-->L/S+KAON PROCESS AND PION PRODUCTION *
 *     NOTE   :                                                         *
 *          
 *     QUANTITIES:                                                 *
 *           PX,PY,PZ - MOMENTUM COORDINATES OF ONE PARTICLE IN CM FRAME*
 *           SRT      - SQRT OF S                                       *
 *           IBLOCK   - THE INFORMATION BACK                            *
 *                     7  PION+N-->L/S+KAON
 *           iblock   - 77 pion+N-->Delta+pion
 *           iblock   - 78 pion+N-->Delta+RHO
 *           iblock   - 79 pion+N-->Delta+OMEGA
 *           iblock   - 222 pion+N-->Phi 
 **********************************
         PARAMETER (MAXSTR=150001,MAXR=1,AMN=0.939457,
      1  AMP=0.93828,AP1=0.13496,APHI=1.020,
      2  AP2=0.13957,AM0=1.232,PI=3.1415926,CUTOFF=1.8966,AVMASS=0.9383)
         PARAMETER      (AKA=0.498,ALA=1.1157,ASA=1.1974)
         parameter     (MX=4,MY=4,MZ=8,MPX=4,MPY=4,mpz=10,mpzp=10)
         COMMON /AA/ R(3,MAXSTR)
 cc      SAVE /AA/
         COMMON /BB/ P(3,MAXSTR)
 cc      SAVE /BB/
         COMMON /CC/ E(MAXSTR)
 cc      SAVE /CC/
         COMMON /EE/ ID(MAXSTR),LB(MAXSTR)
 cc      SAVE /EE/
         common/input1/ MASSPR,MASSTA,ISEED,IAVOID,DT
 cc      SAVE /input1/
       COMMON/RNDF77/NSEED
 cc      SAVE /RNDF77/
       SAVE   
 
       PX0=PX
       PY0=PY
       PZ0=PZ
       iblock=1
       x1=RANART(NSEED)
       ianti=0
       if(lb(i1).lt.0 .or. lb(i2).lt.0) ianti=1
       if(xkaon0/(xkaon+Xphi).ge.x1)then
 * kaon production
 *-----------------------------------------------------------------------
         IBLOCK=7
         if(ianti .eq. 1)iblock=-7
         NTAG=0
 * RELABLE PARTICLES FOR THE PROCESS PION+n-->LAMBDA K OR SIGMA k
 * DECIDE LAMBDA OR SIGMA PRODUCTION, AND TO CALCULATE THE NEW
 * MOMENTA FOR PARTICLES IN THE FINAL STATE.
        KAONC=0
        IF(PNLKA(SRT)/(PNLKA(SRT)
      &       +PNSKA(SRT)).GT.RANART(NSEED))KAONC=1
        IF(E(I1).LE.0.2)THEN
            LB(I1)=23
            E(I1)=AKA
            IF(KAONC.EQ.1)THEN
               LB(I2)=14
               E(I2)=ALA
            ELSE
               LB(I2) = 15 + int(3 * RANART(NSEED))
               E(I2)=ASA       
            ENDIF
            if(ianti .eq. 1)then
               lb(i1) = 21
               lb(i2) = -lb(i2)
            endif
        ELSE
            LB(I2)=23
            E(I2)=AKA
            IF(KAONC.EQ.1)THEN
               LB(I1)=14
               E(I1)=ALA
            ELSE
               LB(I1) = 15 + int(3 * RANART(NSEED))
               E(I1)=ASA       
            ENDIF
            if(ianti .eq. 1)then
               lb(i2) = 21
               lb(i1) = -lb(i1)
            endif
        ENDIF
         EM1=E(I1)
         EM2=E(I2)
         go to 50
 * to gererate the momentum for the kaon and L/S
       elseif(Xphi/(xkaon+Xphi).ge.x1)then
           iblock=222
          if(xphin/Xphi .ge. RANART(NSEED))then
           LB(I1)= 1+int(2*RANART(NSEED))
            E(I1)=AMN
          else
           LB(I1)= 6+int(4*RANART(NSEED))
            E(I1)=AM0
          endif
 c  !! at present only baryon
          if(ianti .eq. 1)lb(i1)=-lb(i1)
           LB(I2)= 29
            E(I2)=APHI
         EM1=E(I1)
         EM2=E(I2)
        go to 50
          else
 * CHECK WHAT KIND OF PION PRODUCTION PROCESS HAS HAPPENED
        IF(RANART(NSEED).LE.TWOPI(SRT)/
      &  (TWOPI(SRT)+THREPI(SRT)+FOURPI(SRT)))THEN
        iblock=77
        ELSE 
         IF(THREPI(SRT)/(THREPI(SRT)+FOURPI(SRT)).
      &  GT.RANART(NSEED))THEN
        IBLOCK=78
        ELSE
        IBLOCK=79
        ENDIF
        endif
        ntag=0
 * pion production (Delta+pion/rho/omega in the final state)
 * generate the mass of the delta resonance
        X2=RANART(NSEED)
 * relable the particles
        if(iblock.eq.77)then
 * GENERATE THE DELTA MASS
        dmax=srt-ap1-0.02
        dm=rmass(dmax,iseed)
 * pion+baryon-->pion+delta
 * Relable particles, I1 is assigned to the Delta and I2 is assigned to the
 * meson
 *(1) for pi(+)+p-->D(+)+P(+) OR D(++)+p(0)
        if( ((lb(i1).eq.1.and.lb(i2).eq.5).
      &  or.(lb(i1).eq.5.and.lb(i2).eq.1))
      &       .OR. ((lb(i1).eq.-1.and.lb(i2).eq.3).
      &  or.(lb(i1).eq.3.and.lb(i2).eq.-1)) )then
               if(iabs(lb(i1)).eq.1)then
         ii = i1
        IF(X2.LE.0.5)THEN
        lb(i1)=8
        e(i1)=dm
        lb(i2)=5
        e(i2)=ap1
        go to 40
        ELSE
        lb(i1)=9
        e(i1)=dm
        lb(i2)=4
         ipi = 4
        e(i2)=ap1
        go to 40
        endif
               else
         ii = i2
        IF(X2.LE.0.5)THEN
        lb(i2)=8
        e(i2)=dm
        lb(i1)=5
        e(i1)=ap1
        go to 40
        ELSE
        lb(i2)=9
        e(i2)=dm
        lb(i1)=4
        e(i1)=ap1
        go to 40
        endif
               endif
        endif
 *(2) for pi(-)+p-->D(0)+P(0) OR D(+)+p(-),or D(-)+p(+)
        if( ((lb(i1).eq.1.and.lb(i2).eq.3).
      &  or.(lb(i1).eq.3.and.lb(i2).eq.1))
      &        .OR. ((lb(i1).eq.-1.and.lb(i2).eq.5).
      &  or.(lb(i1).eq.5.and.lb(i2).eq.-1)) )then
               if(iabs(lb(i1)).eq.1)then
         ii = i1
        IF(X2.LE.0.33)THEN
        lb(i1)=6
        e(i1)=dm
        lb(i2)=5
        e(i2)=ap1
        go to 40
        ENDIF
        if(X2.gt.0.33.and.X2.le.0.67)then
        lb(i1)=7
        e(i1)=dm
        lb(i2)=4
        e(i2)=ap1
        go to 40
        endif
        if(X2.gt.0.67)then
        lb(i1)=8
        e(i1)=dm
        lb(i2)=3
        e(i2)=ap1
        go to 40
        endif
               else
         ii = i2
        IF(X2.LE.0.33)THEN
        lb(i2)=6
        e(i2)=dm
        lb(i1)=5
        e(i1)=ap1
        go to 40
        ENDIF
        if(X2.gt.0.33.and.X2.le.0.67)then
        lb(i2)=7
        e(i2)=dm
        lb(i1)=4
        e(i1)=ap1
        go to 40
        endif
        if(X2.gt.0.67)then
        lb(i2)=8
        e(i2)=dm
        lb(i1)=3
        e(i1)=ap1
        go to 40
        endif
               endif
        endif
 *(3) for pi(+)+n-->D(+)+Pi(0) OR D(++)+p(-) or D(0)+pi(+)
        if( ((lb(i1).eq.2.and.lb(i2).eq.5).
      &   or.(lb(i1).eq.5.and.lb(i2).eq.2))
      & .OR. ((lb(i1).eq.-2.and.lb(i2).eq.3).
      &   or.(lb(i1).eq.3.and.lb(i2).eq.-2)) )then
               if(iabs(lb(i1)).eq.2)then
         ii = i1
        IF(X2.LE.0.33)THEN
        lb(i1)=8
        e(i1)=dm
        lb(i2)=4
        e(i2)=ap1
        go to 40
        ENDIF
        if(X2.gt.0.33.and.X2.le.0.67)then
        lb(i1)=7
        e(i1)=dm
        lb(i2)=5
        e(i2)=ap1
        go to 40
        endif
        if(X2.gt.0.67)then
        lb(i1)=9
        e(i1)=dm
        lb(i2)=3
        e(i2)=ap1
        go to 40
        endif
               else
         ii = i2
        IF(X2.LE.0.33)THEN
        lb(i2)=8
        e(i2)=dm
        lb(i1)=4
        e(i1)=ap1
        go to 40
        ENDIF
        if(X2.gt.0.33.and.X2.le.0.67)then
        lb(i2)=7
        e(i2)=dm
        lb(i1)=5
        e(i1)=ap1
        go to 40
        endif
        if(X2.gt.0.67)then
        lb(i2)=9
        e(i2)=dm
        lb(i1)=3
        e(i1)=ap1
        go to 40
        endif
               endif
        endif
 *(4) for pi(0)+p-->D(+)+Pi(0) OR D(++)+p(-) or D(0)+pi(+)
        if((iabs(lb(i1)).eq.1.and.lb(i2).eq.4).
      &  or.(lb(i1).eq.4.and.iabs(lb(i2)).eq.1))then
               if(iabs(lb(i1)).eq.1)then
         ii = i1
        IF(X2.LE.0.33)THEN
        lb(i1)=8
        e(i1)=dm
        lb(i2)=4
        e(i2)=ap1
        go to 40
        ENDIF
        if(X2.gt.0.33.and.X2.le.0.67)then
        lb(i1)=7
        e(i1)=dm
        lb(i2)=5
        e(i2)=ap1
        go to 40
        endif
        if(X2.gt.0.67)then
        lb(i1)=9
        e(i1)=dm
        lb(i2)=3
        e(i2)=ap1
        go to 40
        endif
               else
         ii = i2
        IF(X2.LE.0.33)THEN
        lb(i2)=8
        e(i2)=dm
        lb(i1)=4
        e(i1)=ap1
        go to 40
        ENDIF
        if(X2.gt.0.33.and.X2.le.0.67)then
        lb(i2)=7
        e(i2)=dm
        lb(i1)=5
        e(i1)=ap1
        go to 40
        endif
        if(X2.gt.0.67)then
        lb(i2)=9
        e(i2)=dm
        lb(i1)=3
        e(i1)=ap1
        go to 40
        endif
               endif
        endif 
 *(5) for pi(-)+n-->D(-)+P(0) OR D(0)+p(-)
        if( ((lb(i1).eq.2.and.lb(i2).eq.3).
      &  or.(lb(i1).eq.3.and.lb(i2).eq.2))
      &         .OR. ((lb(i1).eq.-2.and.lb(i2).eq.5).
      &  or.(lb(i1).eq.5.and.lb(i2).eq.-2)) )then
               if(iabs(lb(i1)).eq.2)then
         ii = i1
        IF(X2.LE.0.5)THEN
        lb(i1)=6
        e(i1)=dm
        lb(i2)=4
        e(i2)=ap1
        go to 40
        ELSE
        lb(i1)=7
        e(i1)=dm
        lb(i2)=3
        e(i2)=ap1
        go to 40
        endif
               else
         ii = i2
        IF(X2.LE.0.5)THEN
        lb(i2)=6
        e(i2)=dm
        lb(i1)=4
        e(i1)=ap1
        go to 40
        ELSE
        lb(i2)=7
        e(i2)=dm
        lb(i1)=3
        e(i1)=ap1
        go to 40
        endif
               endif
        ENDIF
 *(6) for pi(0)+n-->D(0)+P(0), D(-)+p(+) or D(+)+p(-)
        if((iabs(lb(i1)).eq.2.and.lb(i2).eq.4).
      &  or.(lb(i1).eq.4.and.iabs(lb(i2)).eq.2))then
               if(iabs(lb(i1)).eq.2)then
         ii = i1
        IF(X2.LE.0.33)THEN
        lb(i1)=7
        e(i1)=dm
        lb(i2)=4
        e(i2)=ap1
        go to 40
        Endif
        IF(X2.LE.0.67.AND.X2.GT.0.33)THEN       
        lb(i1)=6
        e(i1)=dm
        lb(i2)=5
        e(i2)=ap1
        go to 40
        endif
        IF(X2.GT.0.67)THEN
        LB(I1)=8
        E(I1)=DM
        LB(I2)=3
        E(I2)=AP1
        GO TO 40
        ENDIF
               else
         ii = i2
        IF(X2.LE.0.33)THEN
        lb(i2)=7
        e(i2)=dm
        lb(i1)=4
        e(i1)=ap1
        go to 40
        ENDIF
        IF(X2.LE.0.67.AND.X2.GT.0.33)THEN       
        lb(i2)=6
        e(i2)=dm
        lb(i1)=5
        e(i1)=ap1
        go to 40
        endif
        IF(X2.GT.0.67)THEN
        LB(I2)=8
        E(I2)=DM
        LB(I1)=3
        E(I1)=AP1
        GO TO 40
        ENDIF
               endif
        endif
                      ENDIF
        if(iblock.eq.78)then
        call Rmasdd(srt,1.232,0.77,1.08,
      &  0.28,ISEED,4,dm,ameson)
        arho=AMESON
 * pion+baryon-->Rho+delta
 *(1) for pi(+)+p-->D(+)+rho(+) OR D(++)+rho(0)
        if( ((lb(i1).eq.1.and.lb(i2).eq.5).
      &  or.(lb(i1).eq.5.and.lb(i2).eq.1))
      &        .OR. ((lb(i1).eq.-1.and.lb(i2).eq.3).
      &  or.(lb(i1).eq.3.and.lb(i2).eq.-1)) )then
               if(iabs(lb(i1)).eq.1)then
         ii = i1
        IF(X2.LE.0.5)THEN
        lb(i1)=8
        e(i1)=dm
        lb(i2)=27
        e(i2)=arho
        go to 40
        ELSE
        lb(i1)=9
        e(i1)=dm
        lb(i2)=26
        e(i2)=arho
        go to 40
        endif
               else
         ii = i2
        IF(X2.LE.0.5)THEN
        lb(i2)=8
        e(i2)=dm
        lb(i1)=27
        e(i1)=arho
        go to 40
        ELSE
        lb(i2)=9
        e(i2)=dm
        lb(i1)=26
        e(i1)=arho
        go to 40
        endif
               endif
        endif
 *(2) for pi(-)+p-->D(+)+rho(-) OR D(0)+rho(0) or D(-)+rho(+)
        if( ((lb(i1).eq.1.and.lb(i2).eq.3).
      &  or.(lb(i1).eq.3.and.lb(i2).eq.1))
      &        .OR. ((lb(i1).eq.-1.and.lb(i2).eq.5).
      &  or.(lb(i1).eq.5.and.lb(i2).eq.-1)) )then
               if(iabs(lb(i1)).eq.1)then
         ii = i1
        IF(X2.LE.0.33)THEN
        lb(i1)=6
        e(i1)=dm
        lb(i2)=27
        e(i2)=arho
        go to 40
        ENDIF
        if(X2.gt.0.33.and.X2.le.0.67)then
        lb(i1)=7
        e(i1)=dm
        lb(i2)=26
        e(i2)=arho
        go to 40
        endif
        if(X2.gt.0.67)then
        lb(i1)=8
        e(i1)=dm
        lb(i2)=25
        e(i2)=arho
        go to 40
        endif
               else
         ii = i2
        IF(X2.LE.0.33)THEN
        lb(i2)=6
        e(i2)=dm
        lb(i1)=27
        e(i1)=arho
        go to 40
        ENDIF
        if(X2.gt.0.33.and.X2.le.0.67)then
        lb(i2)=7
        e(i2)=dm
        lb(i1)=26
        e(i1)=arho
        go to 40
        endif
        if(X2.gt.0.67)then
        lb(i2)=8
        e(i2)=dm
        lb(i1)=25
        e(i1)=arho
        go to 40
        endif
               endif
        endif
 *(3) for pi(+)+n-->D(+)+rho(0) OR D(++)+rho(-) or D(0)+rho(+)
        if( ((lb(i1).eq.2.and.lb(i2).eq.5).
      &  or.(lb(i1).eq.5.and.lb(i2).eq.2))
      &       .OR.((lb(i1).eq.-2.and.lb(i2).eq.3).
      &  or.(lb(i1).eq.3.and.lb(i2).eq.-2)) )then
               if(iabs(lb(i1)).eq.2)then
         ii = i1
        IF(X2.LE.0.33)THEN
        lb(i1)=8
        e(i1)=dm
        lb(i2)=26
        e(i2)=arho
        go to 40
        ENDIF
        if(X2.gt.0.33.and.X2.le.0.67)then
        lb(i1)=7
        e(i1)=dm
        lb(i2)=27
        e(i2)=arho
        go to 40
        endif
        if(X2.gt.0.67)then
        lb(i1)=9
        e(i1)=dm
        lb(i2)=25
        e(i2)=arho
        go to 40
        endif
               else
         ii = i2
        IF(X2.LE.0.33)THEN
        lb(i2)=8
        e(i2)=dm
        lb(i1)=26
        e(i1)=arho
        go to 40
        ENDIF
        if(X2.gt.0.33.and.X2.le.0.67)then
        lb(i2)=7
        e(i2)=dm
        lb(i1)=27
        e(i1)=arho
        go to 40
        endif
        if(X2.gt.0.67)then
        lb(i2)=9
        e(i2)=dm
        lb(i1)=25
        e(i1)=arho
        go to 40
        endif
               endif
        endif
 *(4) for pi(0)+p-->D(+)+rho(0) OR D(++)+rho(-) or D(0)+rho(+)
        if((iabs(lb(i1)).eq.1.and.lb(i2).eq.4).
      &  or.(lb(i1).eq.4.and.iabs(lb(i2)).eq.1))then
               if(iabs(lb(i1)).eq.1)then
         ii = i1
        IF(X2.LE.0.33)THEN
        lb(i1)=7
        e(i1)=dm
        lb(i2)=27
        e(i2)=arho
        go to 40
        ENDIF
        if(X2.gt.0.33.and.X2.le.0.67)then
        lb(i1)=8
        e(i1)=dm
        lb(i2)=26
        e(i2)=arho
        go to 40
        endif
        if(X2.gt.0.67)then
        lb(i1)=9
        e(i1)=dm
        lb(i2)=25
        e(i2)=arho
        go to 40
        endif
               else
         ii = i2
        IF(X2.LE.0.33)THEN
        lb(i2)=7
        e(i2)=dm
        lb(i1)=27
        e(i1)=arho
        go to 40
        ENDIF
        if(X2.gt.0.33.and.X2.le.0.67)then
        lb(i2)=8
        e(i2)=dm
        lb(i1)=26
        e(i1)=arho
        go to 40
        endif
        if(X2.gt.0.67)then
        lb(i2)=9
        e(i2)=dm
        lb(i1)=25
        e(i1)=arho
        go to 40
        endif
               endif
        endif 
 *(5) for pi(-)+n-->D(-)+rho(0) OR D(0)+rho(-)
        if( ((lb(i1).eq.2.and.lb(i2).eq.3).
      &  or.(lb(i1).eq.3.and.lb(i2).eq.2))
      &        .OR. ((lb(i1).eq.-2.and.lb(i2).eq.5).
      &  or.(lb(i1).eq.5.and.lb(i2).eq.-2)) )then
               if(iabs(lb(i1)).eq.2)then
         ii = i1
        IF(X2.LE.0.5)THEN
        lb(i1)=6
        e(i1)=dm
        lb(i2)=26
        e(i2)=arho
        go to 40
        ELSE
        lb(i1)=7
        e(i1)=dm
        lb(i2)=25
        e(i2)=arho
        go to 40
        endif
               else
         ii = i2
        IF(X2.LE.0.5)THEN
        lb(i2)=6
        e(i2)=dm
        lb(i1)=26
        e(i1)=arho
        go to 40
        ELSE
        lb(i2)=7
        e(i2)=dm
        lb(i1)=25
        e(i1)=arho
        go to 40
        endif
               endif
        ENDIF
 *(6) for pi(0)+n-->D(0)+rho(0), D(-)+rho(+) and D(+)+rho(-)
        if((iabs(lb(i1)).eq.2.and.lb(i2).eq.4).
      &  or.(lb(i1).eq.4.and.iabs(lb(i2)).eq.2))then
               if(iabs(lb(i1)).eq.2)then
         ii = i1
        IF(X2.LE.0.33)THEN
        lb(i1)=7
        e(i1)=dm
        lb(i2)=26
        e(i2)=arho
        go to 40
        endif
        if(x2.gt.0.33.and.x2.le.0.67)then       
        lb(i1)=6
        e(i1)=dm
        lb(i2)=27
        e(i2)=arho
        go to 40
        endif
        if(x2.gt.0.67)then
        lb(i1)=8
        e(i1)=dm
        lb(i2)=25
        e(i2)=arho
        endif
               else
         ii = i2
        IF(X2.LE.0.33)THEN
        lb(i2)=7
        e(i2)=dm
        lb(i1)=26
        e(i1)=arho
        go to 40
        endif
        if(x2.le.0.67.and.x2.gt.0.33)then       
        lb(i2)=6
        e(i2)=dm
        lb(i1)=27
        e(i1)=arho
        go to 40
        endif
        if(x2.gt.0.67)then
        lb(i2)=8
        e(i2)=dm
        lb(i1)=25
        e(i1)=arho
        endif
               endif
        endif
                      Endif
        if(iblock.eq.79)then
        aomega=0.782
 * GENERATE THE DELTA MASS
        dmax=srt-0.782-0.02
        dm=rmass(dmax,iseed)
 * pion+baryon-->omega+delta
 *(1) for pi(+)+p-->D(++)+omega(0)
        if( ((lb(i1).eq.1.and.lb(i2).eq.5).
      &  or.(lb(i1).eq.5.and.lb(i2).eq.1))
      &  .OR.((lb(i1).eq.-1.and.lb(i2).eq.3).
      &  or.(lb(i1).eq.3.and.lb(i2).eq.-1)) )then
               if(iabs(lb(i1)).eq.1)then
         ii = i1
        lb(i1)=9
        e(i1)=dm
        lb(i2)=28
        e(i2)=aomega
        go to 40
               else
         ii = i2
        lb(i2)=9
        e(i2)=dm
        lb(i1)=28
        e(i1)=aomega
        go to 40
               endif
        endif
 *(2) for pi(-)+p-->D(0)+omega(0) 
        if( ((lb(i1).eq.1.and.lb(i2).eq.3).
      &  or.(lb(i1).eq.3.and.lb(i2).eq.1))
      &        .OR. ((lb(i1).eq.-1.and.lb(i2).eq.5).
      &  or.(lb(i1).eq.5.and.lb(i2).eq.-1)) )then
               if(iabs(lb(i1)).eq.1)then
         ii = i1
        lb(i1)=7
        e(i1)=dm
        lb(i2)=28
        e(i2)=aomega
        go to 40
               else
         ii = i2
        lb(i2)=7
        e(i2)=dm
        lb(i1)=28
        e(i1)=aomega
        go to 40
               endif
        endif
 *(3) for pi(+)+n-->D(+)+omega(0) 
        if( ((lb(i1).eq.2.and.lb(i2).eq.5).
      &  or.(lb(i1).eq.5.and.lb(i2).eq.2))
      &       .OR. ((lb(i1).eq.-2.and.lb(i2).eq.3).
      &  or.(lb(i1).eq.3.and.lb(i2).eq.-2)) )then
               if(iabs(lb(i1)).eq.2)then
         ii = i1
        lb(i1)=8
        e(i1)=dm
        lb(i2)=28
        e(i2)=aomega
        go to 40
               else
         ii = i2
        lb(i2)=8
        e(i2)=dm
        lb(i1)=28
        e(i1)=aomega
        go to 40
               endif
        endif
 *(4) for pi(0)+p-->D(+)+omega(0) 
        if((iabs(lb(i1)).eq.1.and.lb(i2).eq.4).
      &  or.(lb(i1).eq.4.and.iabs(lb(i2)).eq.1))then
               if(iabs(lb(i1)).eq.1)then
         ii = i1
        lb(i1)=8
        e(i1)=dm
        lb(i2)=28
        e(i2)=aomega
        go to 40
               else
         ii = i2
        lb(i2)=8
        e(i2)=dm
        lb(i1)=28
        e(i1)=aomega
        go to 40
               endif
        endif 
 *(5) for pi(-)+n-->D(-)+omega(0) 
        if( ((lb(i1).eq.2.and.lb(i2).eq.3).
      &  or.(lb(i1).eq.3.and.lb(i2).eq.2))
      &        .OR. ((lb(i1).eq.-2.and.lb(i2).eq.5).
      &  or.(lb(i1).eq.5.and.lb(i2).eq.-2)) )then
               if(iabs(lb(i1)).eq.2)then
         ii = i1
        lb(i1)=6
        e(i1)=dm
        lb(i2)=28
        e(i2)=aomega
        go to 40
               ELSE
         ii = i2
        lb(i2)=6
        e(i2)=dm
        lb(i1)=28
        e(i1)=aomega
               endif
        ENDIF
 *(6) for pi(0)+n-->D(0)+omega(0) 
        if((iabs(lb(i1)).eq.2.and.lb(i2).eq.4).
      &  or.(lb(i1).eq.4.and.iabs(lb(i2)).eq.2))then
               if(iabs(lb(i1)).eq.2)then
         ii = i1
        lb(i1)=7
        e(i1)=dm
        lb(i2)=28
        e(i2)=aomega
        go to 40
               else
         ii = i2
        lb(i2)=7
        e(i2)=dm
        lb(i1)=26
        e(i1)=arho
        go to 40
               endif
        endif
                      Endif
 40       em1=e(i1)
        em2=e(i2)
        if(ianti.eq.1 .and. lb(i1).ge.1 .and. lb(i2).ge.1)then
          lb(ii) = -lb(ii)
            jj = i2
           if(ii .eq. i2)jj = i1
          if(iblock .eq. 77)then
           if(lb(jj).eq.3)then
            lb(jj) = 5
           elseif(lb(jj).eq.5)then
            lb(jj) = 3
           endif
          elseif(iblock .eq. 78)then
           if(lb(jj).eq.25)then
            lb(jj) = 27
           elseif(lb(jj).eq.27)then
            lb(jj) = 25
           endif
          endif
        endif
            endif
 *-----------------------------------------------------------------------
 * CALCULATE THE MAGNITUDE OF THE FINAL MOMENTUM THROUGH
 * ENERGY CONSERVATION
 50          PR2   = (SRT**2 - EM1**2 - EM2**2)**2
      1                - 4.0 * (EM1*EM2)**2
           IF(PR2.LE.0.)PR2=0.00000001
           PR=SQRT(PR2)/(2.*SRT)
 * here we use the same transverse momentum distribution as for
 * pp collisions, it might be necessary to use a different distribution
 
 clin-10/25/02 get rid of argument usage mismatch in PTR():
           xptr=0.33*pr
 c         cc1=ptr(0.33*pr,iseed)
          cc1=ptr(xptr,iseed)
 clin-10/25/02-end
 
 clin-9/2012: check argument in sqrt():
          scheck=pr**2-cc1**2
          if(scheck.lt.0) then
             write(99,*) 'scheck36: ', scheck
             scheck=0.
          endif
          c1=sqrt(scheck)/pr
 c         c1=sqrt(pr**2-cc1**2)/pr
 
 *          C1   = 1.0 - 2.0 * RANART(NSEED)
           T1   = 2.0 * PI * RANART(NSEED)
       S1   = SQRT( 1.0 - C1**2 )
       CT1  = COS(T1)
       ST1  = SIN(T1)
 * THE MOMENTUM IN THE CMS IN THE FINAL STATE
       PZ   = PR * C1
       PX   = PR * S1*CT1 
       PY   = PR * S1*ST1
 * ROTATE IT 
        CALL ROTATE(PX0,PY0,PZ0,PX,PY,PZ) 
       RETURN
       END
 **********************************
 *                                                                      *
 *                                                                      *
       SUBROUTINE CREN(PX,PY,PZ,SRT,I1,I2,IBLOCK)
 *     PURPOSE:                                                         *
 *             DEALING WITH ETA+N-->L/S+KAON PROCESS                   *
 *     NOTE   :                                                         *
 *          
 *     QUANTITIES:                                                 *
 *           PX,PY,PZ - MOMENTUM COORDINATES OF ONE PARTICLE IN CM FRAME*
 *           SRT      - SQRT OF S                                       *
 *           IBLOCK   - THE INFORMATION BACK                            *
 *                     7  ETA+N-->L/S+KAON
 **********************************
         PARAMETER (MAXSTR=150001,MAXR=1,AMN=0.939457,
      1  AMP=0.93828,AP1=0.13496,
      2  AP2=0.13957,AM0=1.232,PI=3.1415926,CUTOFF=1.8966,AVMASS=0.9383)
         PARAMETER      (AKA=0.498,ALA=1.1157,ASA=1.1974)
         parameter     (MX=4,MY=4,MZ=8,MPX=4,MPY=4,mpz=10,mpzp=10)
         COMMON /AA/ R(3,MAXSTR)
 cc      SAVE /AA/
         COMMON /BB/ P(3,MAXSTR)
 cc      SAVE /BB/
         COMMON /CC/ E(MAXSTR)
 cc      SAVE /CC/
         COMMON /EE/ ID(MAXSTR),LB(MAXSTR)
 cc      SAVE /EE/
         common/input1/ MASSPR,MASSTA,ISEED,IAVOID,DT
 cc      SAVE /input1/
       COMMON/RNDF77/NSEED
 cc      SAVE /RNDF77/
       SAVE   
 
        PX0=PX
        PY0=PY
        PZ0=PZ
         NTAG=0
         IBLOCK=7
         ianti=0
         if(lb(i1).lt.0 .or. lb(i2).lt.0)then
           ianti=1
           iblock=-7
         endif
 * RELABLE PARTICLES FOR THE PROCESS eta+n-->LAMBDA K OR SIGMA k
 * DECIDE LAMBDA OR SIGMA PRODUCTION, AND TO CALCULATE THE NEW
 * MOMENTA FOR PARTICLES IN THE FINAL STATE.
        KAONC=0
        IF(PNLKA(SRT)/(PNLKA(SRT)
      & +PNSKA(SRT)).GT.RANART(NSEED))KAONC=1
        IF(E(I1).LE.0.6)THEN
        LB(I1)=23
        E(I1)=AKA
         IF(KAONC.EQ.1)THEN
        LB(I2)=14
        E(I2)=ALA
         ELSE
         LB(I2) = 15 + int(3 * RANART(NSEED))
        E(I2)=ASA       
         ENDIF
           if(ianti .eq. 1)then
             lb(i1)=21
             lb(i2)=-lb(i2)
           endif
        ELSE
        LB(I2)=23
        E(I2)=AKA
         IF(KAONC.EQ.1)THEN
        LB(I1)=14
        E(I1)=ALA
         ELSE
          LB(I1) = 15 + int(3 * RANART(NSEED))
        E(I1)=ASA       
         ENDIF
           if(ianti .eq. 1)then
             lb(i2)=21
             lb(i1)=-lb(i1)
           endif
        ENDIF
         EM1=E(I1)
         EM2=E(I2)
 *-----------------------------------------------------------------------
 * CALCULATE THE MAGNITUDE OF THE FINAL MOMENTUM THROUGH
 * ENERGY CONSERVATION
         PR2   = (SRT**2 - EM1**2 - EM2**2)**2
      1                - 4.0 * (EM1*EM2)**2
           IF(PR2.LE.0.)PR2=1.e-09
           PR=SQRT(PR2)/(2.*SRT)
           C1   = 1.0 - 2.0 * RANART(NSEED)
           T1   = 2.0 * PI * RANART(NSEED)
       S1   = SQRT( 1.0 - C1**2 )
       CT1  = COS(T1)
       ST1  = SIN(T1)
 * THE MOMENTUM IN THE CMS IN THE FINAL STATE
       PZ   = PR * C1
       PX   = PR * S1*CT1 
       PY   = PR * S1*ST1
 * FOR THE ISOTROPIC DISTRIBUTION THERE IS NO NEED TO ROTATE
       RETURN
       END
 **********************************
 *                                                                      *
 *                                                                      *
 c      SUBROUTINE Crdir(PX,PY,PZ,SRT,I1,I2)
       SUBROUTINE Crdir(PX,PY,PZ,SRT,I1,I2,IBLOCK)
 *     PURPOSE:                                                         *
 *             DEALING WITH pion+N-->pion+N PROCESS                   *
 *     NOTE   :                                                         *
 *          
 *     QUANTITIES:                                                 *
 *           PX,PY,PZ - MOMENTUM COORDINATES OF ONE PARTICLE IN CM FRAME*
 *           SRT      - SQRT OF S                                       *
 *           IBLOCK   - THE INFORMATION BACK                            *
 *                    
 **********************************
         PARAMETER (MAXSTR=150001,MAXR=1,AMN=0.939457,
      1  AMP=0.93828,AP1=0.13496,
      2  AP2=0.13957,AM0=1.232,PI=3.1415926,CUTOFF=1.8966,AVMASS=0.9383)
         PARAMETER      (AKA=0.498,ALA=1.1157,ASA=1.1974)
         parameter     (MX=4,MY=4,MZ=8,MPX=4,MPY=4,mpz=10,mpzp=10)
         COMMON /AA/ R(3,MAXSTR)
 cc      SAVE /AA/
         COMMON /BB/ P(3,MAXSTR)
 cc      SAVE /BB/
         COMMON /CC/ E(MAXSTR)
 cc      SAVE /CC/
         COMMON /EE/ ID(MAXSTR),LB(MAXSTR)
 cc      SAVE /EE/
         common/input1/ MASSPR,MASSTA,ISEED,IAVOID,DT
 cc      SAVE /input1/
       COMMON/RNDF77/NSEED
 cc      SAVE /RNDF77/
       SAVE   
 
        PX0=PX
        PY0=PY
        PZ0=PZ
         IBLOCK=999
         NTAG=0
         EM1=E(I1)
         EM2=E(I2)
 *-----------------------------------------------------------------------
 * CALCULATE THE MAGNITUDE OF THE FINAL MOMENTUM THROUGH
 * ENERGY CONSERVATION
         PR2   = (SRT**2 - EM1**2 - EM2**2)**2
      1                - 4.0 * (EM1*EM2)**2
           IF(PR2.LE.0.)PR2=1.e-09
           PR=SQRT(PR2)/(2.*SRT)
 
 clin-10/25/02 get rid of argument usage mismatch in PTR():
           xptr=0.33*pr
 c         cc1=ptr(0.33*pr,iseed)
          cc1=ptr(xptr,iseed)
 clin-10/25/02-end
 
 clin-9/2012: check argument in sqrt():
          scheck=pr**2-cc1**2
          if(scheck.lt.0) then
             write(99,*) 'scheck37: ', scheck
             scheck=0.
          endif
          c1=sqrt(scheck)/pr
 c         c1=sqrt(pr**2-cc1**2)/pr
 
            T1   = 2.0 * PI * RANART(NSEED)
       S1   = SQRT( 1.0 - C1**2 )
       CT1  = COS(T1)
       ST1  = SIN(T1)
 * THE MOMENTUM IN THE CMS IN THE FINAL STATE
       PZ   = PR * C1
       PX   = PR * S1*CT1 
       PY   = PR * S1*ST1
 * ROTATE the momentum
       call rotate(px0,py0,pz0,px,py,pz)
       RETURN
       END
 **********************************
 *                                                                      *
 *                                                                      *
       SUBROUTINE CRPD(PX,PY,PZ,SRT,I1,I2,
      & IBLOCK,xkaon0,xkaon,Xphi,xphin)
 *     PURPOSE:                                                         *
 *     DEALING WITH PION+D(N*)-->PION +N OR 
 *                                             L/S+KAON PROCESS         *
 *     NOTE   :                                                         *
 *          
 *     QUANTITIES:                                                 *
 *           PX,PY,PZ - MOMENTUM COORDINATES OF ONE PARTICLE IN CM FRAME*
 *           SRT      - SQRT OF S                                       *
 *           IBLOCK   - THE INFORMATION BACK                            *
 *                     7  PION+D(N*)-->L/S+KAON
 *           iblock   - 80 pion+D(N*)-->pion+N
 *           iblock   - 81 RHO+D(N*)-->PION+N
 *           iblock   - 82 OMEGA+D(N*)-->PION+N
 *                     222  PION+D --> PHI
 **********************************
         PARAMETER (MAXSTR=150001,MAXR=1,AMN=0.939457,
      1  AMP=0.93828,AP1=0.13496,APHI=1.020,
      2  AP2=0.13957,AM0=1.232,PI=3.1415926,CUTOFF=1.8966,AVMASS=0.9383)
         PARAMETER      (AKA=0.498,ALA=1.1157,ASA=1.1974)
         parameter     (MX=4,MY=4,MZ=8,MPX=4,MPY=4,mpz=10,mpzp=10)
         COMMON /AA/ R(3,MAXSTR)
 cc      SAVE /AA/
         COMMON /BB/ P(3,MAXSTR)
 cc      SAVE /BB/
         COMMON /CC/ E(MAXSTR)
 cc      SAVE /CC/
         COMMON /EE/ ID(MAXSTR),LB(MAXSTR)
 cc      SAVE /EE/
         common/input1/ MASSPR,MASSTA,ISEED,IAVOID,DT
 cc      SAVE /input1/
       COMMON/RNDF77/NSEED
 cc      SAVE /RNDF77/
       SAVE   
 
        PX0=PX
        PY0=PY
        PZ0=PZ
         IBLOCK=1
        x1=RANART(NSEED)
         ianti=0
         if(lb(i1).lt.0 .or. lb(i2).lt.0)ianti=1
        if(xkaon0/(xkaon+Xphi).ge.x1)then
 * kaon production
 *-----------------------------------------------------------------------
         IBLOCK=7
         if(ianti .eq. 1)iblock=-7
         NTAG=0
 * RELABLE PARTICLES FOR THE PROCESS PION+n-->LAMBDA K OR SIGMA k
 * DECIDE LAMBDA OR SIGMA PRODUCTION, AND TO CALCULATE THE NEW
 * MOMENTA FOR PARTICLES IN THE FINAL STATE.
        KAONC=0
        IF(PNLKA(SRT)/(PNLKA(SRT)
      &       +PNSKA(SRT)).GT.RANART(NSEED))KAONC=1
 clin-8/17/00     & +PNSKA(SRT)).GT.RANART(NSEED))KAONC=1
        IF(E(I1).LE.0.2)THEN
            LB(I1)=23
            E(I1)=AKA
            IF(KAONC.EQ.1)THEN
               LB(I2)=14
               E(I2)=ALA
            ELSE
               LB(I2) = 15 + int(3 * RANART(NSEED))
               E(I2)=ASA       
            ENDIF
            if(ianti .eq. 1)then
               lb(i1)=21
               lb(i2)=-lb(i2)
            endif
        ELSE
            LB(I2)=23
            E(I2)=AKA
            IF(KAONC.EQ.1)THEN
               LB(I1)=14
               E(I1)=ALA
            ELSE
               LB(I1) = 15 + int(3 * RANART(NSEED))
               E(I1)=ASA       
            ENDIF
            if(ianti .eq. 1)then
               lb(i2)=21
               lb(i1)=-lb(i1)
            endif
        ENDIF
         EM1=E(I1)
         EM2=E(I2)
        go to 50
 * to gererate the momentum for the kaon and L/S
 c
 c* Phi production
        elseif(Xphi/(xkaon+Xphi).ge.x1)then
           iblock=222
          if(xphin/Xphi .ge. RANART(NSEED))then
           LB(I1)= 1+int(2*RANART(NSEED))
            E(I1)=AMN
          else
           LB(I1)= 6+int(4*RANART(NSEED))
            E(I1)=AM0
          endif
 c   !! at present only baryon
           if(ianti .eq. 1)lb(i1)=-lb(i1)
           LB(I2)= 29
            E(I2)=APHI
         EM1=E(I1)
         EM2=E(I2)
        go to 50
          else
 * PION REABSORPTION HAS HAPPENED
        X2=RANART(NSEED)
        IBLOCK=80
        ntag=0
 * Relable particles, I1 is assigned to the nucleon
 * and I2 is assigned to the pion
 * for the reverse of the following process
 *(1) for D(+)+P(+)-->p+pion(+)
         if( ((lb(i1).eq.8.and.lb(i2).eq.5).
      &       or.(lb(i1).eq.5.and.lb(i2).eq.8))
      &       .OR.((lb(i1).eq.-8.and.lb(i2).eq.3).
      &       or.(lb(i1).eq.3.and.lb(i2).eq.-8)) )then
            if(iabs(lb(i1)).eq.8)then
               ii = i1
               lb(i1)=1
               e(i1)=amn
               lb(i2)=5
               e(i2)=ap1
               go to 40
            else
               ii = i2
               lb(i2)=1
               e(i2)=amn
               lb(i1)=5
               e(i1)=ap1
               go to 40
            endif
        endif
 c
 *(2) for D(0)+P(0)-->n+pi(0) or p+pi(-) 
        if((iabs(lb(i1)).eq.7.and.lb(i2).eq.4).
      &  or.(lb(i1).eq.4.and.iabs(lb(i2)).eq.7))then
               if(iabs(lb(i1)).eq.7)then
         ii = i1
        IF(X2.LE.0.5)THEN
        lb(i1)=2
        e(i1)=amn
        lb(i2)=4
        e(i2)=ap1
        go to 40
        Else
        lb(i1)=1
        e(i1)=amn
        lb(i2)=3
        e(i2)=ap1
        go to 40
        endif
               else
         ii = i2
        IF(X2.LE.0.5)THEN
        lb(i2)=2
        e(i2)=amn
        lb(i1)=4
        e(i1)=ap1
        go to 40
        Else
        lb(i2)=1
        e(i2)=amn
        lb(i1)=3
        e(i1)=ap1
        go to 40
        endif
               endif
        endif
 *(3) for D(+)+Pi(0)-->pi(+)+n or pi(0)+p 
        if((iabs(lb(i1)).eq.8.and.lb(i2).eq.4).
      &  or.(lb(i1).eq.4.and.iabs(lb(i2)).eq.8))then
               if(iabs(lb(i1)).eq.8)then
         ii = i1
        IF(X2.LE.0.5)THEN
        lb(i1)=2
        e(i1)=amn
        lb(i2)=5
        e(i2)=ap1
        go to 40
        Else
        lb(i1)=1
        e(i1)=amn
        lb(i2)=4
        e(i2)=ap1
        go to 40
        endif
               else
         ii = i2
        IF(X2.LE.0.5)THEN
        lb(i2)=2
        e(i2)=amn
        lb(i1)=5
        e(i1)=ap1
        go to 40
        Else
        lb(i2)=1
        e(i2)=amn
        lb(i1)=4
        e(i1)=ap1
        go to 40
        endif
               endif
        endif
 *(4) for D(-)+Pi(0)-->n+pi(-) 
        if((iabs(lb(i1)).eq.6.and.lb(i2).eq.4).
      &  or.(lb(i1).eq.4.and.iabs(lb(i2)).eq.6))then
               if(iabs(lb(i1)).eq.6)then
         ii = i1
        lb(i1)=2
        e(i1)=amn
        lb(i2)=3
        e(i2)=ap1
        go to 40
        else
         ii = i2
        lb(i2)=2
        e(i2)=amn
        lb(i1)=3
        e(i1)=ap1
        go to 40
        ENDIF
        endif
 *(5) for D(+)+Pi(-)-->pi(0)+n or pi(-)+p
        if( ((lb(i1).eq.8.and.lb(i2).eq.3).
      &  or.(lb(i1).eq.3.and.lb(i2).eq.8))
      &        .OR.((lb(i1).eq.-8.and.lb(i2).eq.5).
      &  or.(lb(i1).eq.5.and.lb(i2).eq.-8)) )then
               if(iabs(lb(i1)).eq.8)then
         ii = i1
         IF(X2.LE.0.5)THEN
        lb(i1)=2
        e(i1)=amn
        lb(i2)=4
        e(i2)=ap1
        go to 40
        ELSE
        lb(i1)=1
        e(i1)=amn
        lb(i2)=3
        e(i2)=ap1
        go to 40
        endif
               else
         ii = i2
         IF(X2.LE.0.5)THEN
        lb(i2)=2
        e(i2)=amn
        lb(i1)=4
        e(i1)=ap1
        go to 40
        ELSE
        lb(i2)=1
        e(i2)=amn
        lb(i1)=3
        e(i1)=ap1
        go to 40
        endif
               endif
        ENDIF
 *(6) D(0)+P(+)-->n+pi(+) or p+pi(0)
        if( ((lb(i1).eq.7.and.lb(i2).eq.5).
      &  or.(lb(i1).eq.5.and.lb(i2).eq.7))
      &        .OR.((lb(i1).eq.-7.and.lb(i2).eq.3).
      &  or.(lb(i1).eq.3.and.lb(i2).eq.-7)) )then
               if(iabs(lb(i1)).eq.7)then
         ii = i1
          IF(X2.LE.0.5)THEN
        lb(i1)=2
        e(i1)=amn
        lb(i2)=5
        e(i2)=ap1
        go to 40
        else
        lb(i1)=1
        e(i1)=amn
        lb(i2)=4
        e(i2)=ap1
        go to 40
        endif
               else
         ii = i2
          IF(X2.LE.0.5)THEN
        lb(i2)=2
        e(i2)=amn
        lb(i1)=5
        e(i1)=ap1
        go to 40
        Else
        lb(i2)=1
        e(i2)=amn
        lb(i1)=4
        e(i1)=ap1
        go to 40
        endif
               endif
        ENDIF
 *(7) for D(0)+Pi(-)-->n+pi(-) 
        if( ((lb(i1).eq.7.and.lb(i2).eq.3).
      &  or.(lb(i1).eq.3.and.lb(i2).eq.7))
      &        .OR.((lb(i1).eq.-7.and.lb(i2).eq.5).
      &  or.(lb(i1).eq.5.and.lb(i2).eq.-7)) )then
               if(iabs(lb(i1)).eq.7)then
         ii = i1
        lb(i1)=2
        e(i1)=amn
        lb(i2)=3
        e(i2)=ap1
        go to 40
        else
         ii = i2
        lb(i2)=2
        e(i2)=amn
        lb(i1)=3
        e(i1)=ap1
        go to 40
        ENDIF
        endif
 *(8) D(-)+P(+)-->n+pi(0) or p+pi(-)
        if( ((lb(i1).eq.6.and.lb(i2).eq.5)
      &      .or.(lb(i1).eq.5.and.lb(i2).eq.6))
      &   .OR.((lb(i1).eq.-6.and.lb(i2).eq.3).
      &      or.(lb(i1).eq.3.and.lb(i2).eq.-6)) )then
               if(iabs(lb(i1)).eq.6)then
          ii = i1
        IF(X2.LE.0.5)THEN
        lb(i1)=2
        e(i1)=amn
        lb(i2)=4
        e(i2)=ap1
        go to 40
        else
        lb(i1)=1
        e(i1)=amn
        lb(i2)=3
        e(i2)=ap1
        go to 40
        endif
               else
          ii = i2
        IF(X2.LE.0.5)THEN
        lb(i2)=2
        e(i2)=amn
        lb(i1)=4
        e(i1)=ap1
        go to 40
        Else
        lb(i2)=1
        e(i2)=amn
        lb(i1)=3
        e(i1)=ap1
        go to 40
        endif
               endif
        ENDIF
 c
 *(9) D(++)+P(-)-->n+pi(+) or p+pi(0)
        if( ((lb(i1).eq.9.and.lb(i2).eq.3)
      &   .or.(lb(i1).eq.3.and.lb(i2).eq.9))
      &       .OR. ((lb(i1).eq.-9.and.lb(i2).eq.5)
      &   .or.(lb(i1).eq.5.and.lb(i2).eq.-9)) )then
               if(iabs(lb(i1)).eq.9)then
         ii = i1
        IF(X2.LE.0.5)THEN
        lb(i1)=2
        e(i1)=amn
        lb(i2)=5
        e(i2)=ap1
        go to 40
        else
        lb(i1)=1
        e(i1)=amn
        lb(i2)=4
        e(i2)=ap1
        go to 40
        endif
               else
         ii = i2
        IF(X2.LE.0.5)THEN
        lb(i2)=2
        e(i2)=amn
        lb(i1)=5
        e(i1)=ap1
        go to 40
        Else
        lb(i2)=1
        e(i2)=amn
        lb(i1)=4
        e(i1)=ap1
        go to 40
        endif
               endif
        ENDIF
 *(10) for D(++)+Pi(0)-->p+pi(+) 
        if((iabs(lb(i1)).eq.9.and.lb(i2).eq.4)
      &    .or.(lb(i1).eq.4.and.iabs(lb(i2)).eq.9))then
            if(iabs(lb(i1)).eq.9)then
         ii = i1
        lb(i1)=1
        e(i1)=amn
        lb(i2)=5
        e(i2)=ap1
        go to 40
        else
         ii = i2
        lb(i2)=1
        e(i2)=amn
        lb(i1)=5
        e(i1)=ap1
        go to 40
        ENDIF
        endif
 *(11) for N*(1440)(+)or N*(1535)(+)+P(+)-->p+pion(+)
        if( ((lb(i1).eq.11.and.lb(i2).eq.5).
      &  or.(lb(i1).eq.5.and.lb(i2).eq.11).
      &  or.(lb(i1).eq.13.and.lb(i2).eq.5).
      &  or.(lb(i1).eq.5.and.lb(i2).eq.13))
      &        .OR.((lb(i1).eq.-11.and.lb(i2).eq.3).
      &  or.(lb(i1).eq.3.and.lb(i2).eq.-11).
      &  or.(lb(i1).eq.-13.and.lb(i2).eq.3).
      &  or.(lb(i1).eq.3.and.lb(i2).eq.-13)) )then
               if(iabs(lb(i1)).eq.11.or.iabs(lb(i1)).eq.13)then
         ii = i1
        lb(i1)=1
        e(i1)=amn
        lb(i2)=5
        e(i2)=ap1
        go to 40
        else
         ii = i2
        lb(i2)=1
        e(i2)=amn
        lb(i1)=5
        e(i1)=ap1
        go to 40
               endif
        endif
 *(12) for N*(1440) or N*(1535)(0)+P(0)-->n+pi(0) or p+pi(-) 
        if((iabs(lb(i1)).eq.10.and.lb(i2).eq.4).
      &  or.(lb(i1).eq.4.and.iabs(lb(i2)).eq.10).
      &  or.(lb(i1).eq.4.and.iabs(lb(i2)).eq.12).
      &  or.(lb(i2).eq.4.and.iabs(lb(i1)).eq.12))then
               if(iabs(lb(i1)).eq.10.or.iabs(lb(i1)).eq.12)then
         ii = i1
        IF(X2.LE.0.5)THEN
        lb(i1)=2
        e(i1)=amn
        lb(i2)=4
        e(i2)=ap1
        go to 40
        Else
        lb(i1)=1
        e(i1)=amn
        lb(i2)=3
        e(i2)=ap1
        go to 40
        endif
               else
         ii = i2
        IF(X2.LE.0.5)THEN
        lb(i2)=2
        e(i2)=amn
        lb(i1)=4
        e(i1)=ap1
        go to 40
        Else
        lb(i2)=1
        e(i2)=amn
        lb(i1)=3
        e(i1)=ap1
        go to 40
        endif
               endif
        endif
 *(13) for N*(1440) or N*(1535)(+)+Pi(0)-->pi(+)+n or pi(0)+p 
        if((iabs(lb(i1)).eq.11.and.lb(i2).eq.4).
      &  or.(lb(i1).eq.4.and.iabs(lb(i2)).eq.11).
      &  or.(lb(i1).eq.4.and.iabs(lb(i2)).eq.13).
      &  or.(lb(i2).eq.4.and.iabs(lb(i1)).eq.13))then
               if(iabs(lb(i1)).eq.11.or.iabs(lb(i1)).eq.13)then
         ii = i1
        IF(X2.LE.0.5)THEN
        lb(i1)=2
        e(i1)=amn
        lb(i2)=5
        e(i2)=ap1
        go to 40
        Else
        lb(i1)=1
        e(i1)=amn
        lb(i2)=4
        e(i2)=ap1
        go to 40
        endif
               else
         ii = i2
        IF(X2.LE.0.5)THEN
        lb(i2)=2
        e(i2)=amn
        lb(i1)=5
        e(i1)=ap1
        go to 40
        Else
        lb(i2)=1
        e(i2)=amn
        lb(i1)=4
        e(i1)=ap1
        go to 40
        endif
               endif
        endif
 *(14) for N*(1440) or N*(1535)(+)+Pi(-)-->pi(0)+n or pi(-)+p
        if( ((lb(i1).eq.11.and.lb(i2).eq.3).
      &  or.(lb(i1).eq.3.and.lb(i2).eq.11).
      &  or.(lb(i1).eq.3.and.lb(i2).eq.13).
      &  or.(lb(i2).eq.3.and.lb(i1).eq.13))
      &        .OR.((lb(i1).eq.-11.and.lb(i2).eq.5).
      &  or.(lb(i1).eq.5.and.lb(i2).eq.-11).
      &  or.(lb(i1).eq.5.and.lb(i2).eq.-13).
      &  or.(lb(i2).eq.5.and.lb(i1).eq.-13)) )then
        if(iabs(lb(i1)).eq.11.or.iabs(lb(i1)).eq.13)then
         ii = i1
          IF(X2.LE.0.5)THEN
        lb(i1)=2
        e(i1)=amn
        lb(i2)=4
        e(i2)=ap1
        go to 40
        ELSE
        lb(i1)=1
        e(i1)=amn
        lb(i2)=3
        e(i2)=ap1
        go to 40
        endif
               else
         ii = i2
          IF(X2.LE.0.5)THEN
        lb(i2)=2
        e(i2)=amn
        lb(i1)=4
        e(i1)=ap1
        go to 40
        ELSE
        lb(i2)=1
        e(i2)=amn
        lb(i1)=3
        e(i1)=ap1
        go to 40
        endif
               endif
        ENDIF
 *(15) N*(1440) or N*(1535)(0)+P(+)-->n+pi(+) or p+pi(0)
        if( ((lb(i1).eq.10.and.lb(i2).eq.5).
      &  or.(lb(i1).eq.5.and.lb(i2).eq.10).
      &  or.(lb(i1).eq.12.and.lb(i2).eq.5).
      &  or.(lb(i1).eq.5.and.lb(i2).eq.12))
      &        .OR.((lb(i1).eq.-10.and.lb(i2).eq.3).
      &  or.(lb(i1).eq.3.and.lb(i2).eq.-10).
      &  or.(lb(i1).eq.-12.and.lb(i2).eq.3).
      &  or.(lb(i1).eq.3.and.lb(i2).eq.-12)) )then
        if(iabs(lb(i1)).eq.10.or.iabs(lb(i1)).eq.12)then
         ii = i1
         IF(X2.LE.0.5)THEN
        lb(i1)=2
        e(i1)=amn
        lb(i2)=5
        e(i2)=ap1
        go to 40
        else
        lb(i1)=1
        e(i1)=amn
        lb(i2)=4
        e(i2)=ap1
        go to 40
        endif
               else
         ii = i2
         IF(X2.LE.0.5)THEN
        lb(i2)=2
        e(i2)=amn
        lb(i1)=5
        e(i1)=ap1
        go to 40
        Else
        lb(i2)=1
        e(i2)=amn
        lb(i1)=4
        e(i1)=ap1
        go to 40
        endif
               endif
        ENDIF
 *(16) for N*(1440) or N*(1535) (0)+Pi(-)-->n+pi(-) 
        if( ((lb(i1).eq.10.and.lb(i2).eq.3).
      &  or.(lb(i1).eq.3.and.lb(i2).eq.10).
      &  or.(lb(i1).eq.3.and.lb(i2).eq.12).
      &  or.(lb(i1).eq.12.and.lb(i2).eq.3))
      &        .OR.((lb(i1).eq.-10.and.lb(i2).eq.5).
      &  or.(lb(i1).eq.5.and.lb(i2).eq.-10).
      &  or.(lb(i1).eq.5.and.lb(i2).eq.-12).
      &  or.(lb(i1).eq.-12.and.lb(i2).eq.5)) )then
            if(iabs(lb(i1)).eq.10.or.iabs(lb(i1)).eq.12)then
         ii = i1
        lb(i1)=2
        e(i1)=amn
        lb(i2)=3
        e(i2)=ap1
        go to 40
        else
         ii = i2
        lb(i2)=2
        e(i2)=amn
        lb(i1)=3
        e(i1)=ap1
        go to 40
        ENDIF
        endif
 40       em1=e(i1)
        em2=e(i2)
        if(ianti.eq.1 .and.  lb(i1).ge.1 .and. lb(i2).ge.1)then
          lb(ii) = -lb(ii)
            jj = i2
           if(ii .eq. i2)jj = i1
           if(lb(jj).eq.3)then
            lb(jj) = 5
           elseif(lb(jj).eq.5)then
            lb(jj) = 3
           endif
          endif
           endif
 *-----------------------------------------------------------------------
 * CALCULATE THE MAGNITUDE OF THE FINAL MOMENTUM THROUGH
 * ENERGY CONSERVATION
 50          PR2   = (SRT**2 - EM1**2 - EM2**2)**2
      1                - 4.0 * (EM1*EM2)**2
           IF(PR2.LE.0.)PR2=1.E-09
           PR=SQRT(PR2)/(2.*SRT)
 
 clin-10/25/02 get rid of argument usage mismatch in PTR():
           xptr=0.33*pr
 c         cc1=ptr(0.33*pr,iseed)
          cc1=ptr(xptr,iseed)
 clin-10/25/02-end
 
 clin-9/2012: check argument in sqrt():
          scheck=pr**2-cc1**2
          if(scheck.lt.0) then
             write(99,*) 'scheck38: ', scheck
             scheck=0.
          endif
          c1=sqrt(scheck)/pr
 c         c1=sqrt(pr**2-cc1**2)/pr
 
 c         C1   = 1.0 - 2.0 * RANART(NSEED)
           T1   = 2.0 * PI * RANART(NSEED)
       S1   = SQRT( 1.0 - C1**2 )
       CT1  = COS(T1)
       ST1  = SIN(T1)
       PZ   = PR * C1
       PX   = PR * S1*CT1 
       PY   = PR * S1*ST1 
 * rotate the momentum
        call rotate(px0,py0,pz0,px,py,pz)
       RETURN
       END
 **********************************
 *                                                                      *
 *                                                                      *
       SUBROUTINE CRRD(PX,PY,PZ,SRT,I1,I2,
      & IBLOCK,xkaon0,xkaon,Xphi,xphin)
 *     PURPOSE:                                                         *
 *     DEALING WITH rho(omega)+N or D(N*)-->PION +N OR 
 *                                             L/S+KAON PROCESS         *
 *     NOTE   :                                                         *
 *          
 *     QUANTITIES:                                                 *
 *           PX,PY,PZ - MOMENTUM COORDINATES OF ONE PARTICLE IN CM FRAME*
 *           SRT      - SQRT OF S                                       *
 *           IBLOCK   - THE INFORMATION BACK                            *
 *                     7  rho(omega)+N or D(N*)-->L/S+KAON
 *           iblock   - 80 pion+D(N*)-->pion+N
 *           iblock   - 81 RHO+D(N*)-->PION+N
 *           iblock   - 82 OMEGA+D(N*)-->PION+N
 *           iblock   - 222 pion+N-->Phi 
 **********************************
         PARAMETER (MAXSTR=150001,MAXR=1,AMN=0.939457,
      1  AMP=0.93828,AP1=0.13496,
      2  AP2=0.13957,AM0=1.232,PI=3.1415926,CUTOFF=1.8966,AVMASS=0.9383)
         PARAMETER     (AKA=0.498,ALA=1.1157,ASA=1.1974,APHI=1.02)
         parameter     (MX=4,MY=4,MZ=8,MPX=4,MPY=4,mpz=10,mpzp=10)
         COMMON /AA/ R(3,MAXSTR)
 cc      SAVE /AA/
         COMMON /BB/ P(3,MAXSTR)
 cc      SAVE /BB/
         COMMON /CC/ E(MAXSTR)
 cc      SAVE /CC/
         COMMON /EE/ ID(MAXSTR),LB(MAXSTR)
 cc      SAVE /EE/
         common/input1/ MASSPR,MASSTA,ISEED,IAVOID,DT
 cc      SAVE /input1/
       COMMON/RNDF77/NSEED
 cc      SAVE /RNDF77/
       SAVE   
 
        PX0=PX
        PY0=PY
        PZ0=PZ
        IBLOCK=1
        ianti=0
        if(lb(i1).lt.0 .or. lb(i2).lt.0) ianti=1
        x1=RANART(NSEED)
        if(xkaon0/(xkaon+Xphi).ge.x1)then
 * kaon production
 *-----------------------------------------------------------------------
         IBLOCK=7
         if(ianti .eq. 1)iblock=-7
         NTAG=0
 * RELABLE PARTICLES FOR THE PROCESS PION+n-->LAMBDA K OR SIGMA k
 * DECIDE LAMBDA OR SIGMA PRODUCTION, AND TO CALCULATE THE NEW
 * MOMENTA FOR PARTICLES IN THE FINAL STATE.
        KAONC=0
        IF(PNLKA(SRT)/(PNLKA(SRT)
      & +PNSKA(SRT)).GT.RANART(NSEED))KAONC=1
 clin-8/17/00     & +PNSKA(SRT)).GT.RANART(NSEED))KAONC=1
        IF(E(I1).LE.0.92)THEN
        LB(I1)=23
        E(I1)=AKA
               IF(KAONC.EQ.1)THEN
        LB(I2)=14
        E(I2)=ALA
               ELSE
         LB(I2) = 15 + int(3 * RANART(NSEED))
        E(I2)=ASA       
               ENDIF
          if(ianti .eq. 1)then
           lb(i1) = 21
           lb(i2) = -lb(i2)
          endif
        ELSE
        LB(I2)=23
        E(I2)=AKA
               IF(KAONC.EQ.1)THEN
        LB(I1)=14
        E(I1)=ALA
               ELSE
          LB(I1) = 15 + int(3 * RANART(NSEED))
        E(I1)=ASA       
               ENDIF
          if(ianti .eq. 1)then
           lb(i2) = 21
           lb(i1) = -lb(i1)
          endif
        ENDIF
         EM1=E(I1)
         EM2=E(I2)
        go to 50
 * to gererate the momentum for the kaon and L/S
 c
 c* Phi production
        elseif(Xphi/(xkaon+Xphi).ge.x1)then
           iblock=222
          if(xphin/Xphi .ge. RANART(NSEED))then
           LB(I1)= 1+int(2*RANART(NSEED))
            E(I1)=AMN
          else
           LB(I1)= 6+int(4*RANART(NSEED))
            E(I1)=AM0
          endif
 c   !! at present only baryon
          if(ianti .eq. 1)lb(i1)=-lb(i1)
           LB(I2)= 29
            E(I2)=APHI
         EM1=E(I1)
         EM2=E(I2)
        go to 50
          else
 * rho(omega) REABSORPTION HAS HAPPENED
        X2=RANART(NSEED)
        IBLOCK=81
        ntag=0
        if(lb(i1).eq.28.or.lb(i2).eq.28)go to 60
 * we treat Rho reabsorption in the following 
 * Relable particles, I1 is assigned to the Delta 
 * and I2 is assigned to the meson
 * for the reverse of the following process
 *(1) for D(+)+rho(+)-->p+pion(+)
        if( ((lb(i1).eq.8.and.lb(i2).eq.27).
      &  or.(lb(i1).eq.27.and.lb(i2).eq.8))
      &        .OR. ((lb(i1).eq.-8.and.lb(i2).eq.25).
      &  or.(lb(i1).eq.25.and.lb(i2).eq.-8)) )then
               if(iabs(lb(i1)).eq.8)then
         ii = i1
        lb(i1)=1
        e(i1)=amn
        lb(i2)=5
        e(i2)=ap1
        go to 40
        else
         ii = i2
        lb(i2)=1
        e(i2)=amn
        lb(i1)=5
        e(i1)=ap1
        go to 40
               endif
        endif
 *(2) for D(0)+rho(0)-->n+pi(0) or p+pi(-) 
        if((iabs(lb(i1)).eq.7.and.lb(i2).eq.26).
      &  or.(lb(i1).eq.26.and.iabs(lb(i2)).eq.7))then
               if(iabs(lb(i1)).eq.7)then
         ii = i1
        IF(X2.LE.0.5)THEN
        lb(i1)=2
        e(i1)=amn
        lb(i2)=4
        e(i2)=ap1
        go to 40
        Else
        lb(i1)=1
        e(i1)=amn
        lb(i2)=3
        e(i2)=ap1
        go to 40
        endif
               else
         ii = i2
        IF(X2.LE.0.5)THEN
        lb(i2)=2
        e(i2)=amn
        lb(i1)=4
        e(i1)=ap1
        go to 40
        Else
        lb(i2)=1
        e(i2)=amn
        lb(i1)=3
        e(i1)=ap1
        go to 40
        endif
               endif
        endif
 *(3) for D(+)+rho(0)-->pi(+)+n or pi(0)+p 
        if((iabs(lb(i1)).eq.8.and.lb(i2).eq.26).
      &  or.(lb(i1).eq.26.and.iabs(lb(i2)).eq.8))then
               if(iabs(lb(i1)).eq.8)then
         ii = i1
        IF(X2.LE.0.5)THEN
        lb(i1)=2
        e(i1)=amn
        lb(i2)=5
        e(i2)=ap1
        go to 40
        Else
        lb(i1)=1
        e(i1)=amn
        lb(i2)=4
        e(i2)=ap1
        go to 40
        endif
               else
         ii = i2
        IF(X2.LE.0.5)THEN
        lb(i2)=2
        e(i2)=amn
        lb(i1)=5
        e(i1)=ap1
        go to 40
        Else
        lb(i2)=1
        e(i2)=amn
        lb(i1)=4
        e(i1)=ap1
        go to 40
        endif
               endif
        endif
 *(4) for D(-)+rho(0)-->n+pi(-) 
        if((iabs(lb(i1)).eq.6.and.lb(i2).eq.26).
      &  or.(lb(i1).eq.26.and.iabs(lb(i2)).eq.6))then
               if(iabs(lb(i1)).eq.6)then
         ii = i1
        lb(i1)=2
        e(i1)=amn
        lb(i2)=3
        e(i2)=ap1
        go to 40
        else
         ii = i2
        lb(i2)=2
        e(i2)=amn
        lb(i1)=3
        e(i1)=ap1
        go to 40
        ENDIF
        endif
 *(5) for D(+)+rho(-)-->pi(0)+n or pi(-)+p
        if( ((lb(i1).eq.8.and.lb(i2).eq.25).
      &  or.(lb(i1).eq.25.and.lb(i2).eq.8))
      &        .OR. ((lb(i1).eq.-8.and.lb(i2).eq.27).
      &  or.(lb(i1).eq.27.and.lb(i2).eq.-8)) )then
               if(iabs(lb(i1)).eq.8)then
         ii = i1
        IF(X2.LE.0.5)THEN
        lb(i1)=2
        e(i1)=amn
        lb(i2)=4
        e(i2)=ap1
        go to 40
        ELSE
        lb(i1)=1
        e(i1)=amn
        lb(i2)=3
        e(i2)=ap1
        go to 40
        endif
               else
         ii = i2
        IF(X2.LE.0.5)THEN
        lb(i2)=2
        e(i2)=amn
        lb(i1)=4
        e(i1)=ap1
        go to 40
        ELSE
        lb(i2)=1
        e(i2)=amn
        lb(i1)=3
        e(i1)=ap1
        go to 40
        endif
               endif
        ENDIF
 *(6) D(0)+rho(+)-->n+pi(+) or p+pi(0)
        if( ((lb(i1).eq.7.and.lb(i2).eq.27).
      &  or.(lb(i1).eq.27.and.lb(i2).eq.7))
      &       .OR.((lb(i1).eq.-7.and.lb(i2).eq.25).
      &  or.(lb(i1).eq.25.and.lb(i2).eq.-7)) )then
               if(iabs(lb(i1)).eq.7)then
         ii = i1
        IF(X2.LE.0.5)THEN
        lb(i1)=2
        e(i1)=amn
        lb(i2)=5
        e(i2)=ap1
        go to 40
        else
        lb(i1)=1
        e(i1)=amn
        lb(i2)=4
        e(i2)=ap1
        go to 40
        endif
               else
         ii = i2
        IF(X2.LE.0.5)THEN
        lb(i2)=2
        e(i2)=amn
        lb(i1)=5
        e(i1)=ap1
        go to 40
        Else
        lb(i2)=1
        e(i2)=amn
        lb(i1)=4
        e(i1)=ap1
        go to 40
        endif
               endif
        ENDIF
 *(7) for D(0)+rho(-)-->n+pi(-) 
        if( ((lb(i1).eq.7.and.lb(i2).eq.25).
      &  or.(lb(i1).eq.25.and.lb(i2).eq.7))
      &       .OR.((lb(i1).eq.-7.and.lb(i2).eq.27).
      &  or.(lb(i1).eq.27.and.lb(i2).eq.-7)) )then
               if(iabs(lb(i1)).eq.7)then
         ii = i1
        lb(i1)=2
        e(i1)=amn
        lb(i2)=3
        e(i2)=ap1
        go to 40
        else
         ii = i2
        lb(i2)=2
        e(i2)=amn
        lb(i1)=3
        e(i1)=ap1
        go to 40
        ENDIF
        endif
 *(8) D(-)+rho(+)-->n+pi(0) or p+pi(-)
        if( ((lb(i1).eq.6.and.lb(i2).eq.27).
      &  or.(lb(i1).eq.27.and.lb(i2).eq.6))
      &        .OR. ((lb(i1).eq.-6.and.lb(i2).eq.25).
      &  or.(lb(i1).eq.25.and.lb(i2).eq.-6)) )then
               if(iabs(lb(i1)).eq.6)then
         ii = i1
        IF(X2.LE.0.5)THEN
        lb(i1)=2
        e(i1)=amn
        lb(i2)=4
        e(i2)=ap1
        go to 40
        else
        lb(i1)=1
        e(i1)=amn
        lb(i2)=3
        e(i2)=ap1
        go to 40
        endif
               else
         ii = i2
        IF(X2.LE.0.5)THEN
        lb(i2)=2
        e(i2)=amn
        lb(i1)=4
        e(i1)=ap1
        go to 40
        Else
        lb(i2)=1
        e(i2)=amn
        lb(i1)=3
        e(i1)=ap1
        go to 40
        endif
               endif
        ENDIF
 *(9) D(++)+rho(-)-->n+pi(+) or p+pi(0)
        if( ((lb(i1).eq.9.and.lb(i2).eq.25).
      &  or.(lb(i1).eq.25.and.lb(i2).eq.9))
      &        .OR.((lb(i1).eq.-9.and.lb(i2).eq.27).
      &  or.(lb(i1).eq.27.and.lb(i2).eq.-9)) )then
               if(iabs(lb(i1)).eq.9)then
         ii = i1
        IF(X2.LE.0.5)THEN
        lb(i1)=2
        e(i1)=amn
        lb(i2)=5
        e(i2)=ap1
        go to 40
        else
        lb(i1)=1
        e(i1)=amn
        lb(i2)=4
        e(i2)=ap1
        go to 40
        endif
               else
         ii = i2
        IF(X2.LE.0.5)THEN
        lb(i2)=2
        e(i2)=amn
        lb(i1)=5
        e(i1)=ap1
        go to 40
        Else
        lb(i2)=1
        e(i2)=amn
        lb(i1)=4
        e(i1)=ap1
        go to 40
        endif
               endif
        ENDIF
 *(10) for D(++)+rho(0)-->p+pi(+) 
        if((iabs(lb(i1)).eq.9.and.lb(i2).eq.26).
      &  or.(lb(i1).eq.26.and.iabs(lb(i2)).eq.9))then
               if(iabs(lb(i1)).eq.9)then
         ii = i1
        lb(i1)=1
        e(i1)=amn
        lb(i2)=5
        e(i2)=ap1
        go to 40
        else
         ii = i2
        lb(i2)=1
        e(i2)=amn
        lb(i1)=5
        e(i1)=ap1
        go to 40
        ENDIF
        endif
 *(11) for N*(1440)(+)or N*(1535)(+)+rho(+)-->p+pion(+)
        if( ((lb(i1).eq.11.and.lb(i2).eq.27).
      &  or.(lb(i1).eq.27.and.lb(i2).eq.11).
      &  or.(lb(i1).eq.13.and.lb(i2).eq.27).
      &  or.(lb(i1).eq.27.and.lb(i2).eq.13))
      &        .OR. ((lb(i1).eq.-11.and.lb(i2).eq.25).
      &  or.(lb(i1).eq.25.and.lb(i2).eq.-11).
      &  or.(lb(i1).eq.-13.and.lb(i2).eq.25).
      &  or.(lb(i1).eq.25.and.lb(i2).eq.-13)) )then
               if(iabs(lb(i1)).eq.11.or.iabs(lb(i1)).eq.13)then
         ii = i1
        lb(i1)=1
        e(i1)=amn
        lb(i2)=5
        e(i2)=ap1
        go to 40
        else
         ii = i2
        lb(i2)=1
        e(i2)=amn
        lb(i1)=5
        e(i1)=ap1
        go to 40
               endif
        endif
 *(12) for N*(1440) or N*(1535)(0)+rho(0)-->n+pi(0) or p+pi(-) 
        if((iabs(lb(i1)).eq.10.and.lb(i2).eq.26).
      &  or.(lb(i1).eq.26.and.iabs(lb(i2)).eq.10).
      &  or.(lb(i1).eq.26.and.iabs(lb(i2)).eq.12).
      &  or.(lb(i2).eq.26.and.iabs(lb(i1)).eq.12))then
               if(iabs(lb(i1)).eq.10.or.iabs(lb(i1)).eq.12)then
         ii = i1
        IF(X2.LE.0.5)THEN
        lb(i1)=2
        e(i1)=amn
        lb(i2)=4
        e(i2)=ap1
        go to 40
        Else
        lb(i1)=1
        e(i1)=amn
        lb(i2)=3
        e(i2)=ap1
        go to 40
        endif
               else
         ii = i2
        IF(X2.LE.0.5)THEN
        lb(i2)=2
        e(i2)=amn
        lb(i1)=4
        e(i1)=ap1
        go to 40
        Else
        lb(i2)=1
        e(i2)=amn
        lb(i1)=3
        e(i1)=ap1
        go to 40
        endif
               endif
        endif
 *(13) for N*(1440) or N*(1535)(+)+rho(0)-->pi(+)+n or pi(0)+p 
        if((iabs(lb(i1)).eq.11.and.lb(i2).eq.26).
      &  or.(lb(i1).eq.26.and.iabs(lb(i2)).eq.11).
      &  or.(lb(i1).eq.26.and.iabs(lb(i2)).eq.13).
      &  or.(lb(i2).eq.26.and.iabs(lb(i1)).eq.13))then
               if(iabs(lb(i1)).eq.11.or.iabs(lb(i1)).eq.13)then
         ii = i1
        IF(X2.LE.0.5)THEN
        lb(i1)=2
        e(i1)=amn
        lb(i2)=5
        e(i2)=ap1
        go to 40
        Else
        lb(i1)=1
        e(i1)=amn
        lb(i2)=4
        e(i2)=ap1
        go to 40
        endif
               else
         ii = i2
        IF(X2.LE.0.5)THEN
        lb(i2)=2
        e(i2)=amn
        lb(i1)=5
        e(i1)=ap1
        go to 40
        Else
        lb(i2)=1
        e(i2)=amn
        lb(i1)=4
        e(i1)=ap1
        go to 40
        endif
               endif
        endif
 *(14) for N*(1440) or N*(1535)(+)+rho(-)-->pi(0)+n or pi(-)+p
        if( ((lb(i1).eq.11.and.lb(i2).eq.25).
      &  or.(lb(i1).eq.25.and.lb(i2).eq.11).
      &  or.(lb(i1).eq.25.and.lb(i2).eq.13).
      &  or.(lb(i2).eq.25.and.lb(i1).eq.13))
      &        .OR.((lb(i1).eq.-11.and.lb(i2).eq.27).
      &  or.(lb(i1).eq.27.and.lb(i2).eq.-11).
      &  or.(lb(i1).eq.27.and.lb(i2).eq.-13).
      &  or.(lb(i2).eq.27.and.lb(i1).eq.-13)) )then
        if(iabs(lb(i1)).eq.11.or.iabs(lb(i1)).eq.13)then
         ii = i1
        IF(X2.LE.0.5)THEN
        lb(i1)=2
        e(i1)=amn
        lb(i2)=4
        e(i2)=ap1
        go to 40
        ELSE
        lb(i1)=1
        e(i1)=amn
        lb(i2)=3
        e(i2)=ap1
        go to 40
        endif
               else
         ii = i2
        IF(X2.LE.0.5)THEN
        lb(i2)=2
        e(i2)=amn
        lb(i1)=4
        e(i1)=ap1
        go to 40
        ELSE
        lb(i2)=1
        e(i2)=amn
        lb(i1)=3
        e(i1)=ap1
        go to 40
        endif
               endif
        ENDIF
 *(15) N*(1440) or N*(1535)(0)+rho(+)-->n+pi(+) or p+pi(0)
        if( ((lb(i1).eq.10.and.lb(i2).eq.27).
      &  or.(lb(i1).eq.27.and.lb(i2).eq.10).
      &  or.(lb(i1).eq.12.and.lb(i2).eq.27).
      &  or.(lb(i1).eq.27.and.lb(i2).eq.12))
      &         .OR.((lb(i1).eq.-10.and.lb(i2).eq.25).
      &  or.(lb(i1).eq.25.and.lb(i2).eq.-10).
      &  or.(lb(i1).eq.-12.and.lb(i2).eq.25).
      &  or.(lb(i1).eq.25.and.lb(i2).eq.-12)) )then
        if(iabs(lb(i1)).eq.10.or.iabs(lb(i1)).eq.12)then
         ii = i1
        IF(X2.LE.0.5)THEN
        lb(i1)=2
        e(i1)=amn
        lb(i2)=5
        e(i2)=ap1
        go to 40
        else
        lb(i1)=1
        e(i1)=amn
        lb(i2)=4
        e(i2)=ap1
        go to 40
        endif
               else
         ii = i2
        IF(X2.LE.0.5)THEN
        lb(i2)=2
        e(i2)=amn
        lb(i1)=5
        e(i1)=ap1
        go to 40
        Else
        lb(i2)=1
        e(i2)=amn
        lb(i1)=4
        e(i1)=ap1
        go to 40
        endif
               endif
        ENDIF
 *(16) for N*(1440) or N*(1535) (0)+rho(-)-->n+pi(-) 
        if( ((lb(i1).eq.10.and.lb(i2).eq.25).
      &  or.(lb(i1).eq.25.and.lb(i2).eq.10).
      &  or.(lb(i1).eq.25.and.lb(i2).eq.12).
      &  or.(lb(i1).eq.12.and.lb(i2).eq.25))
      &       .OR. ((lb(i1).eq.-10.and.lb(i2).eq.27).
      &  or.(lb(i1).eq.27.and.lb(i2).eq.-10).
      &  or.(lb(i1).eq.27.and.lb(i2).eq.-12).
      &  or.(lb(i1).eq.-12.and.lb(i2).eq.27)) )then
        if(iabs(lb(i1)).eq.10.or.iabs(lb(i1)).eq.12)then
         ii = i1
        lb(i1)=2
        e(i1)=amn
        lb(i2)=3
        e(i2)=ap1
        go to 40
        else
         ii = i2
        lb(i2)=2
        e(i2)=amn
        lb(i1)=3
        e(i1)=ap1
        go to 40
        ENDIF
        endif
 60       IBLOCK=82
 * FOR OMEGA REABSORPTION
 * Relable particles, I1 is assigned to the Delta 
 * and I2 is assigned to the meson
 * for the reverse of the following process
 *(1) for D(0)+OMEGA(0)-->n+pi(0) or p+pi(-) 
        if((iabs(lb(i1)).eq.7.and.lb(i2).eq.28).
      &  or.(lb(i1).eq.28.and.iabs(lb(i2)).eq.7))then
               if(iabs(lb(i1)).eq.7)then
         ii = i1
        IF(X2.LE.0.5)THEN
        lb(i1)=2
        e(i1)=amn
        lb(i2)=4
        e(i2)=ap1
        go to 40
        Else
        lb(i1)=1
        e(i1)=amn
        lb(i2)=3
        e(i2)=ap1
        go to 40
        endif
               else
         ii = i2
        IF(X2.LE.0.5)THEN
        lb(i2)=2
        e(i2)=amn
        lb(i1)=4
        e(i1)=ap1
        go to 40
        Else
        lb(i2)=1
        e(i2)=amn
        lb(i1)=3
        e(i1)=ap1
        go to 40
        endif
               endif
        endif
 *(2) for D(+)+OMEGA(0)-->pi(+)+n or pi(0)+p 
        if((iabs(lb(i1)).eq.8.and.lb(i2).eq.28).
      &  or.(lb(i1).eq.28.and.iabs(lb(i2)).eq.8))then
               if(iabs(lb(i1)).eq.8)then
         ii = i1
        IF(X2.LE.0.5)THEN
        lb(i1)=2
        e(i1)=amn
        lb(i2)=5
        e(i2)=ap1
        go to 40
        Else
        lb(i1)=1
        e(i1)=amn
        lb(i2)=4
        e(i2)=ap1
        go to 40
        endif
               else
         ii = i2
        IF(X2.LE.0.5)THEN
        lb(i2)=2
        e(i2)=amn
        lb(i1)=5
        e(i1)=ap1
        go to 40
        Else
        lb(i2)=1
        e(i2)=amn
        lb(i1)=4
        e(i1)=ap1
        go to 40
        endif
               endif
        endif
 *(3) for D(-)+OMEGA(0)-->n+pi(-) 
        if((iabs(lb(i1)).eq.6.and.lb(i2).eq.28).
      &  or.(lb(i1).eq.28.and.iabs(lb(i2)).eq.6))then
               if(iabs(lb(i1)).eq.6)then
         ii = i1
        lb(i1)=2
        e(i1)=amn
        lb(i2)=3
        e(i2)=ap1
        go to 40
        else
         ii = i2
        lb(i2)=2
        e(i2)=amn
        lb(i1)=3
        e(i1)=ap1
        go to 40
        ENDIF
        endif
 *(4) for D(++)+OMEGA(0)-->p+pi(+) 
        if((iabs(lb(i1)).eq.9.and.lb(i2).eq.28).
      &  or.(lb(i1).eq.28.and.iabs(lb(i2)).eq.9))then
               if(iabs(lb(i1)).eq.9)then
         ii = i1
        lb(i1)=1
        e(i1)=amn
        lb(i2)=5
        e(i2)=ap1
        go to 40
        else
         ii = i2
        lb(i2)=1
        e(i2)=amn
        lb(i1)=5
        e(i1)=ap1
        go to 40
        ENDIF
        endif
 *(5) for N*(1440) or N*(1535)(0)+omega(0)-->n+pi(0) or p+pi(-) 
        if((iabs(lb(i1)).eq.10.and.lb(i2).eq.28).
      &  or.(lb(i1).eq.28.and.iabs(lb(i2)).eq.10).
      &  or.(lb(i1).eq.28.and.iabs(lb(i2)).eq.12).
      &  or.(lb(i2).eq.28.and.iabs(lb(i1)).eq.12))then
               if(iabs(lb(i1)).eq.10.or.iabs(lb(i1)).eq.12)then
         ii = i1
        IF(X2.LE.0.5)THEN
        lb(i1)=2
        e(i1)=amn
        lb(i2)=4
        e(i2)=ap1
        go to 40
        Else
        lb(i1)=1
        e(i1)=amn
        lb(i2)=3
        e(i2)=ap1
        go to 40
        endif
               else
         ii = i2
        IF(X2.LE.0.5)THEN
        lb(i2)=2
        e(i2)=amn
        lb(i1)=4
        e(i1)=ap1
        go to 40
        Else
        lb(i2)=1
        e(i2)=amn
        lb(i1)=3
        e(i1)=ap1
        go to 40
        endif
               endif
        endif
 *(6) for N*(1440) or N*(1535)(+)+omega(0)-->pi(+)+n or pi(0)+p 
        if((iabs(lb(i1)).eq.11.and.lb(i2).eq.28).
      &  or.(lb(i1).eq.28.and.iabs(lb(i2)).eq.11).
      &  or.(lb(i1).eq.28.and.iabs(lb(i2)).eq.13).
      &  or.(lb(i2).eq.28.and.iabs(lb(i1)).eq.13))then
               if(iabs(lb(i1)).eq.11.or.iabs(lb(i1)).eq.13)then
         ii = i1
        IF(X2.LE.0.5)THEN
        lb(i1)=2
        e(i1)=amn
        lb(i2)=5
        e(i2)=ap1
        go to 40
        Else
        lb(i1)=1
        e(i1)=amn
        lb(i2)=4
        e(i2)=ap1
        go to 40
        endif
               else
         ii = i2
        IF(X2.LE.0.5)THEN
        lb(i2)=2
        e(i2)=amn
        lb(i1)=5
        e(i1)=ap1
        go to 40
        Else
        lb(i2)=1
        e(i2)=amn
        lb(i1)=4
        e(i1)=ap1
        go to 40
        endif
               endif
        endif
 40       em1=e(i1)
        em2=e(i2)
        if(ianti.eq.1 .and. lb(i1).ge.1 .and. lb(i2).ge.1)then
          lb(ii) = -lb(ii)
            jj = i2
           if(ii .eq. i2)jj = i1
           if(lb(jj).eq.3)then
            lb(jj) = 5
           elseif(lb(jj).eq.5)then
            lb(jj) = 3
           endif
          endif
        endif
 *-----------------------------------------------------------------------
 * CALCULATE THE MAGNITUDE OF THE FINAL MOMENTUM THROUGH
 * ENERGY CONSERVATION
 50          PR2   = (SRT**2 - EM1**2 - EM2**2)**2
      1                - 4.0 * (EM1*EM2)**2
           IF(PR2.LE.0.)PR2=1.E-09
           PR=SQRT(PR2)/(2.*SRT)
 *          C1   = 1.0 - 2.0 * RANART(NSEED)
 
 clin-10/25/02 get rid of argument usage mismatch in PTR():
           xptr=0.33*pr
 c         cc1=ptr(0.33*pr,iseed)
          cc1=ptr(xptr,iseed)
 clin-10/25/02-end
 
 clin-9/2012: check argument in sqrt():
          scheck=pr**2-cc1**2
          if(scheck.lt.0) then
             write(99,*) 'scheck39: ', scheck
             scheck=0.
          endif
          c1=sqrt(scheck)/pr
 c         c1=sqrt(pr**2-cc1**2)/pr
 
           T1   = 2.0 * PI * RANART(NSEED)
       S1   = SQRT( 1.0 - C1**2 )
       CT1  = COS(T1)
       ST1  = SIN(T1)
       PZ   = PR * C1
       PX   = PR * S1*CT1 
       PY   = PR * S1*ST1 
 * ROTATE THE MOMENTUM
        CALL ROTATE(PX0,PY0,PZ0,PX,PY,PZ)
       RETURN
       END
 **********************************
 * sp 03/19/01                                                          *
 *                                                                      *
         SUBROUTINE Crlaba(PX,PY,PZ,SRT,brel,brsgm,
      &                        I1,I2,nt,IBLOCK,nchrg,icase)
 *     PURPOSE:                                                         *
 *            DEALING WITH   K+ + N(D,N*)-bar <-->  La(Si)-bar + pi     *
 *     NOTE   :                                                         *
 *                                                                      *
 *     QUANTITIES:                                                 *
 *           PX,PY,PZ - MOMENTUM COORDINATES OF ONE PARTICLE IN CM FRAME*
 *           SRT      - SQRT OF S                                       *
 *           IBLOCK   - THE INFORMATION BACK                            *
 *                     8-> elastic scatt                               *
 *                     100-> K+ + N-bar -> Sigma-bar + PI
 *                     102-> PI + Sigma(Lambda)-bar -> K+ + N-bar
 **********************************
         PARAMETER (MAXSTR=150001, MAXR=1, AMN=0.939457,
      1  AMP=0.93828,AP1=0.13496,
      2  AP2=0.13957,AM0=1.232,PI=3.1415926,CUTOFF=1.8966,AVMASS=0.9383)
         PARAMETER  (AKA=0.498,ALA=1.1157,ASA=1.1974)
         PARAMETER  (ETAM=0.5475, AOMEGA=0.782, ARHO=0.77)
         COMMON /AA/ R(3,MAXSTR)
 cc      SAVE /AA/
         COMMON /BB/ P(3,MAXSTR)
 cc      SAVE /BB/
         COMMON /CC/ E(MAXSTR)
 cc      SAVE /CC/
         COMMON /EE/ ID(MAXSTR),LB(MAXSTR)
 cc      SAVE /EE/
         common/input1/ MASSPR,MASSTA,ISEED,IAVOID,DT
 cc      SAVE /input1/
       COMMON/RNDF77/NSEED
 cc      SAVE /RNDF77/
       SAVE   
 c
       PX0=PX
       PY0=PY
       PZ0=PZ
 c
       if(icase .eq. 3)then
          rrr=RANART(NSEED)
          if(rrr.lt.brel) then
 c            !! elastic scat.  (avoid in reverse process)
             IBLOCK=8
         else 
             IBLOCK=100
             if(rrr.lt.(brel+brsgm)) then
 c*    K+ + N-bar -> Sigma-bar + PI
                LB(i1) = -15 - int(3 * RANART(NSEED))
 
                e(i1)=asa
             else
 c*    K+ + N-bar -> Lambda-bar + PI
                LB(i1)= -14  
                e(i1)=ala
             endif
             LB(i2) = 3 + int(3 * RANART(NSEED))
             e(i2)=0.138
         endif
       endif
 c
 c
       if(icase .eq. 4)then
          rrr=RANART(NSEED)
          if(rrr.lt.brel) then
 c            !! elastic scat.
             IBLOCK=8
          else    
             IBLOCK=102
 c    PI + Sigma(Lambda)-bar -> K+ + N-bar
 c         ! K+
             LB(i1) = 23
             LB(i2) = -1 - int(2 * RANART(NSEED))
             if(nchrg.eq.-2) LB(i2) = -6
             if(nchrg.eq. 1) LB(i2) = -9
             e(i1) = aka
             e(i2) = 0.938
             if(nchrg.eq.-2.or.nchrg.eq.1) e(i2)=1.232
          endif
       endif
 c
       EM1=E(I1)
       EM2=E(I2)
 * CALCULATE THE MAGNITUDE OF THE FINAL MOMENTUM THROUGH
 * ENERGY CONSERVATION
       PR2   = (SRT**2 - EM1**2 - EM2**2)**2
      1     - 4.0 * (EM1*EM2)**2
       IF(PR2.LE.0.)PR2=1.e-09
       PR=SQRT(PR2)/(2.*SRT)
       C1   = 1.0 - 2.0 * RANART(NSEED)
       T1   = 2.0 * PI * RANART(NSEED)
       S1   = SQRT( 1.0 - C1**2 )
       CT1  = COS(T1)
       ST1  = SIN(T1)
       PZ   = PR * C1
       PX   = PR * S1*CT1 
       PY   = PR * S1*ST1
 * ROTATE IT 
       CALL ROTATE(PX0,PY0,PZ0,PX,PY,PZ) 
       RETURN
       END
 **********************************
 *                                                                      *
 *                                                                      *
       SUBROUTINE Crkn(PX,PY,PZ,SRT,I1,I2,IBLOCK)
 *     PURPOSE:                                                         *
 *             DEALING WITH kaON+N/pi-->KAON +N/pi elastic PROCESS      *
 *     NOTE   :                                                         *
 *          
 *     QUANTITIES:                                                 *
 *           PX,PY,PZ - MOMENTUM COORDINATES OF ONE PARTICLE IN CM FRAME*
 *           SRT      - SQRT OF S                                       *
 *           IBLOCK   - THE INFORMATION BACK                            *
 *                     8-> PION+N-->L/S+KAON
 **********************************
         PARAMETER (MAXSTR=150001,MAXR=1,AMN=0.939457,
      1  AMP=0.93828,AP1=0.13496,
      2  AP2=0.13957,AM0=1.232,PI=3.1415926,CUTOFF=1.8966,AVMASS=0.9383)
         PARAMETER      (AKA=0.498,ALA=1.1157,ASA=1.1974)
         parameter     (MX=4,MY=4,MZ=8,MPX=4,MPY=4,mpz=10,mpzp=10)
         COMMON /AA/ R(3,MAXSTR)
 cc      SAVE /AA/
         COMMON /BB/ P(3,MAXSTR)
 cc      SAVE /BB/
         COMMON /CC/ E(MAXSTR)
 cc      SAVE /CC/
         COMMON /EE/ ID(MAXSTR),LB(MAXSTR)
 cc      SAVE /EE/
         common/input1/ MASSPR,MASSTA,ISEED,IAVOID,DT
 cc      SAVE /input1/
       COMMON/RNDF77/NSEED
 cc      SAVE /RNDF77/
       SAVE   
 
        PX0=PX
        PY0=PY
        PZ0=PZ
 *-----------------------------------------------------------------------
         IBLOCK=8
         NTAG=0
         EM1=E(I1)
         EM2=E(I2)
 *-----------------------------------------------------------------------
 * CALCULATE THE MAGNITUDE OF THE FINAL MOMENTUM THROUGH
 * ENERGY CONSERVATION
           PR2   = (SRT**2 - EM1**2 - EM2**2)**2
      1                - 4.0 * (EM1*EM2)**2
           IF(PR2.LE.0.)PR2=1.e-09
           PR=SQRT(PR2)/(2.*SRT)
           C1   = 1.0 - 2.0 * RANART(NSEED)
           T1   = 2.0 * PI * RANART(NSEED)
       S1   = SQRT( 1.0 - C1**2 )
       CT1  = COS(T1)
       ST1  = SIN(T1)
       PZ   = PR * C1
       PX   = PR * S1*CT1 
       PY   = PR * S1*ST1
       RETURN
       END
 **********************************
 *                                                                      *
 *                                                                      *
       SUBROUTINE Crppba(PX,PY,PZ,SRT,I1,I2,IBLOCK)
 *     PURPOSE:                                                         *
 
 clin-8/29/00*             DEALING WITH anti-nucleon annihilation with 
 *             DEALING WITH anti-baryon annihilation with 
 
 *             nucleons or baryon resonances
 *             Determine:                                               *
 *             (1) no. of pions in the final state
 *             (2) relable particles in the final state
 *             (3) new momenta of final state particles                 *
 *                  
 *     QUANTITIES:                                                      *
 *           PX,PY,PZ - MOMENTUM COORDINATES OF ONE PARTICLE IN CM FRAME*
 *           SRT      - SQRT OF S                                       *
 *           IBLOCK   - INFORMATION about the reaction channel          *
 *                
 *           iblock   - 1902 annihilation-->pion(+)+pion(-)   (2 pion)
 *           iblock   - 1903 annihilation-->pion(+)+rho(-)    (3 pion)
 *           iblock   - 1904 annihilation-->rho(+)+rho(-)     (4 pion)
 *           iblock   - 1905 annihilation-->rho(0)+omega      (5 pion)
 *           iblock   - 1906 annihilation-->omega+omega       (6 pion)
 *       charge conservation is enforced in relabling particles 
 *       in the final state (note: at the momentum we don't check the
 *       initial charges while dealing with annihilation, since some
 *       annihilation channels between antinucleons and nucleons (baryon
 *       resonances) might be forbiden by charge conservation, this effect
 *       should be small, but keep it in mind.
 **********************************
         PARAMETER (MAXSTR=150001,MAXR=1,AMN=0.939457,
      1  AMP=0.93828,AP1=0.13496,AMRHO=0.769,AMOMGA=0.782,
      2  AP2=0.13957,AM0=1.232,PI=3.1415926,CUTOFF=1.8966,AVMASS=0.9383)
         PARAMETER      (AKA=0.498,ALA=1.1157,ASA=1.1974)
         parameter     (MX=4,MY=4,MZ=8,MPX=4,MPY=4,mpz=10,mpzp=10)
         COMMON /AA/ R(3,MAXSTR)
 cc      SAVE /AA/
         COMMON /BB/ P(3,MAXSTR)
 cc      SAVE /BB/
         COMMON /CC/ E(MAXSTR)
 cc      SAVE /CC/
         COMMON /EE/ ID(MAXSTR),LB(MAXSTR)
 cc      SAVE /EE/
         common/input1/ MASSPR,MASSTA,ISEED,IAVOID,DT
 cc      SAVE /input1/
       COMMON/RNDF77/NSEED
 cc      SAVE /RNDF77/
       SAVE   
 
        PX0=PX
        PY0=PY
        PZ0=PZ
 * determine the no. of pions in the final state using a 
 * statistical model
        call pbarfs(srt,npion,iseed)
 * find the masses of the final state particles before calculate 
 * their momenta, and relable them. The masses of rho and omega 
 * will be generated according to the Breit Wigner formula       (NOTE!!!
 * NOT DONE YET, AT THE MOMENT LET US USE FIXED RHO AND OMEGA MAEES)
 cbali2/22/99
 * Here we generate two stes of integer random numbers (3,4,5)
 * one or both of them are used directly as the lables of pions
 * similarly, 22+nchrg1 and 22+nchrg2 are used directly 
 * to label rhos  
        nchrg1=3+int(3*RANART(NSEED))
        nchrg2=3+int(3*RANART(NSEED))
 * the corresponding masses of pions
       pmass1=ap1
        pmass2=ap1
        if(nchrg1.eq.3.or.nchrg1.eq.5)pmass1=ap2
        if(nchrg2.eq.3.or.nchrg2.eq.5)pmass2=ap2
 * (1) for 2 pion production
        IF(NPION.EQ.2)THEN 
        IBLOCK=1902
 * randomly generate the charges of final state particles,
        LB(I1)=nchrg1
        E(I1)=pmass1
        LB(I2)=nchrg2
        E(I2)=pmass2
 * TO CALCULATE THE FINAL MOMENTA
        GO TO 50
        ENDIF
 * (2) FOR 3 PION PRODUCTION
        IF(NPION.EQ.3)THEN 
        IBLOCK=1903
        LB(I1)=nchrg1
        E(I1)=pmass1
        LB(I2)=22+nchrg2
             E(I2)=AMRHO
        GO TO 50
        ENDIF
 * (3) FOR 4 PION PRODUCTION
 * we allow both rho+rho and pi+omega with 50-50% probability
         IF(NPION.EQ.4)THEN 
        IBLOCK=1904
 * determine rho+rho or pi+omega
        if(RANART(NSEED).ge.0.5)then
 * rho+rho  
        LB(I1)=22+nchrg1
        E(I1)=AMRHO
        LB(I2)=22+nchrg2
             E(I2)=AMRHO
        else
 * pion+omega
        LB(I1)=nchrg1
        E(I1)=pmass1
        LB(I2)=28
             E(I2)=AMOMGA
        endif
        GO TO 50
        ENDIF
 * (4) FOR 5 PION PRODUCTION
         IF(NPION.EQ.5)THEN 
        IBLOCK=1905
 * RHO AND OMEGA
         LB(I1)=22+nchrg1
        E(I1)=AMRHO
        LB(I2)=28
        E(I2)=AMOMGA
        GO TO 50
        ENDIF
 * (5) FOR 6 PION PRODUCTION
          IF(NPION.EQ.6)THEN 
        IBLOCK=1906
 * OMEGA AND OMEGA
         LB(I1)=28
        E(I1)=AMOMGA
        LB(I2)=28
           E(I2)=AMOMGA
        ENDIF
 cbali2/22/99
 50    EM1=E(I1)
       EM2=E(I2)
 *-----------------------------------------------------------------------
 * CALCULATE THE MAGNITUDE OF THE FINAL MOMENTUM THROUGH
 * ENERGY CONSERVATION
           PR2   = (SRT**2 - EM1**2 - EM2**2)**2
      1                - 4.0 * (EM1*EM2)**2
           IF(PR2.LE.0.)PR2=1.E-08
           PR=SQRT(PR2)/(2.*SRT)
 * WE ASSUME AN ISOTROPIC ANGULAR DISTRIBUTION IN THE CMS 
           C1   = 1.0 - 2.0 * RANART(NSEED)
           T1   = 2.0 * PI * RANART(NSEED)
       S1   = SQRT( 1.0 - C1**2 )
       CT1  = COS(T1)
       ST1  = SIN(T1)
 * THE MOMENTUM IN THE CMS IN THE FINAL STATE
       PZ   = PR * C1
       PX   = PR * S1*CT1 
       PY   = PR * S1*ST1
 * ROTATE IT 
        CALL ROTATE(PX0,PY0,PZ0,PX,PY,PZ) 
       RETURN
       END
 cbali2/7/99end
 cbali3/5/99
 **********************************
 *     PURPOSE:                                                         *
 *     assign final states for K+K- --> light mesons
 *
       SUBROUTINE crkkpi(I1,I2,XSK1, XSK2, XSK3, XSK4,
      &             XSK5, XSK6, XSK7, XSK8, XSK9, XSK10, XSK11, SIGK,
      &             IBLOCK,lbp1,lbp2,emm1,emm2)
 *
 *     QUANTITIES:                                                     *
 *           IBLOCK   - INFORMATION about the reaction channel          *
 *                
 *             iblock   - 1907
 **********************************
         PARAMETER (MAXSTR=150001,MAXR=1,AMN=0.939457,
      1  AMP=0.93828,AP1=0.13496,AMRHO=0.769,AMOMGA=0.782,
      &  AMETA = 0.5473,
      2  AP2=0.13957,AM0=1.232,PI=3.1415926,CUTOFF=1.8966,AVMASS=0.9383)
         PARAMETER      (AKA=0.498,ALA=1.1157,ASA=1.1974)
         parameter     (MX=4,MY=4,MZ=8,MPX=4,MPY=4,mpz=10,mpzp=10)
         COMMON /AA/ R(3,MAXSTR)
 cc      SAVE /AA/
         COMMON /BB/ P(3,MAXSTR)
 cc      SAVE /BB/
         COMMON /CC/ E(MAXSTR)
 cc      SAVE /CC/
         COMMON /EE/ ID(MAXSTR),LB(MAXSTR)
 cc      SAVE /EE/
         common/input1/ MASSPR,MASSTA,ISEED,IAVOID,DT
 cc      SAVE /input1/
       COMMON/RNDF77/NSEED
 cc      SAVE /RNDF77/
       SAVE   
 
        IBLOCK=1907
         X1 = RANART(NSEED) * SIGK
         XSK2 = XSK1 + XSK2
         XSK3 = XSK2 + XSK3
         XSK4 = XSK3 + XSK4
         XSK5 = XSK4 + XSK5
         XSK6 = XSK5 + XSK6
         XSK7 = XSK6 + XSK7
         XSK8 = XSK7 + XSK8
         XSK9 = XSK8 + XSK9
         XSK10 = XSK9 + XSK10
         IF (X1 .LE. XSK1) THEN
            LB(I1) = 3 + int(3 * RANART(NSEED))
            LB(I2) = 3 + int(3 * RANART(NSEED))
            E(I1) = AP2
            E(I2) = AP2
            GOTO 100
         ELSE IF (X1 .LE. XSK2) THEN
            LB(I1) = 3 + int(3 * RANART(NSEED))
            LB(I2) = 25 + int(3 * RANART(NSEED))
            E(I1) = AP2
            E(I2) = AMRHO
            GOTO 100
         ELSE IF (X1 .LE. XSK3) THEN
            LB(I1) = 3 + int(3 * RANART(NSEED))
            LB(I2) = 28
            E(I1) = AP2
            E(I2) = AMOMGA
            GOTO 100
         ELSE IF (X1 .LE. XSK4) THEN
            LB(I1) = 3 + int(3 * RANART(NSEED))
            LB(I2) = 0
            E(I1) = AP2
            E(I2) = AMETA
            GOTO 100
         ELSE IF (X1 .LE. XSK5) THEN
            LB(I1) = 25 + int(3 * RANART(NSEED))
            LB(I2) = 25 + int(3 * RANART(NSEED))
            E(I1) = AMRHO
            E(I2) = AMRHO
            GOTO 100
         ELSE IF (X1 .LE. XSK6) THEN
            LB(I1) = 25 + int(3 * RANART(NSEED))
            LB(I2) = 28
            E(I1) = AMRHO
            E(I2) = AMOMGA
            GOTO 100
         ELSE IF (X1 .LE. XSK7) THEN
            LB(I1) = 25 + int(3 * RANART(NSEED))
            LB(I2) = 0
            E(I1) = AMRHO
            E(I2) = AMETA
            GOTO 100
         ELSE IF (X1 .LE. XSK8) THEN
            LB(I1) = 28
            LB(I2) = 28
            E(I1) = AMOMGA
            E(I2) = AMOMGA
            GOTO 100
         ELSE IF (X1 .LE. XSK9) THEN
            LB(I1) = 28
            LB(I2) = 0
            E(I1) = AMOMGA
            E(I2) = AMETA
            GOTO 100
         ELSE IF (X1 .LE. XSK10) THEN
            LB(I1) = 0
            LB(I2) = 0
            E(I1) = AMETA
            E(I2) = AMETA
         ELSE
           iblock = 222
           call rhores(i1,i2)
 c     !! phi
           lb(i1) = 29
 c          return
           e(i2)=0.
         END IF
 
  100    CONTINUE
         lbp1=lb(i1)
         lbp2=lb(i2)
         emm1=e(i1)
         emm2=e(i2)
 
       RETURN
       END
 **********************************
 *     PURPOSE:                                                         *
 *             DEALING WITH K+Y -> piN scattering
 *
       SUBROUTINE Crkhyp(PX,PY,PZ,SRT,I1,I2,
      &     XKY1, XKY2, XKY3, XKY4, XKY5,
      &     XKY6, XKY7, XKY8, XKY9, XKY10, XKY11, XKY12, XKY13,
      &     XKY14, XKY15, XKY16, XKY17, SIGK, IKMP,
      &     IBLOCK)
 *
 *             Determine:                                               *
 *             (1) relable particles in the final state                 *
 *             (2) new momenta of final state particles                 *
 *                                                                        *
 *     QUANTITIES:                                                    *
 *           PX,PY,PZ - MOMENTUM COORDINATES OF ONE PARTICLE IN CM FRAME*
 *           SRT      - SQRT OF S                                       *
 *           IBLOCK   - INFORMATION about the reaction channel          *
 *                                                                     *
 *             iblock   - 1908                                          *
 *             iblock   - 222   !! phi                                  *
 **********************************
         PARAMETER (MAXSTR=150001,MAXR=1,AMN=0.939457,
      1  AMP=0.93828,AP1=0.13496,AMRHO=0.769,AMOMGA=0.782,APHI=1.02,
      2  AP2=0.13957,AM0=1.232,PI=3.1415926,CUTOFF=1.8966,AVMASS=0.9383)
           parameter (pimass=0.140, AMETA = 0.5473, aka=0.498,
      &     aml=1.116,ams=1.193, AM1440 = 1.44, AM1535 = 1.535)
         parameter     (MX=4,MY=4,MZ=8,MPX=4,MPY=4,mpz=10,mpzp=10)
         COMMON /AA/ R(3,MAXSTR)
 cc      SAVE /AA/
         COMMON /BB/ P(3,MAXSTR)
 cc      SAVE /BB/
         COMMON /CC/ E(MAXSTR)
 cc      SAVE /CC/
         COMMON /EE/ ID(MAXSTR),LB(MAXSTR)
 cc      SAVE /EE/
         common/input1/ MASSPR,MASSTA,ISEED,IAVOID,DT
 cc      SAVE /input1/
       COMMON/RNDF77/NSEED
 cc      SAVE /RNDF77/
       SAVE   
 
        PX0=PX
        PY0=PY
        PZ0=PZ
        IBLOCK=1908
 c
         X1 = RANART(NSEED) * SIGK
         XKY2 = XKY1 + XKY2
         XKY3 = XKY2 + XKY3
         XKY4 = XKY3 + XKY4
         XKY5 = XKY4 + XKY5
         XKY6 = XKY5 + XKY6
         XKY7 = XKY6 + XKY7
         XKY8 = XKY7 + XKY8
         XKY9 = XKY8 + XKY9
         XKY10 = XKY9 + XKY10
         XKY11 = XKY10 + XKY11
         XKY12 = XKY11 + XKY12
         XKY13 = XKY12 + XKY13
         XKY14 = XKY13 + XKY14
         XKY15 = XKY14 + XKY15
         XKY16 = XKY15 + XKY16
         IF (X1 .LE. XKY1) THEN
            LB(I1) = 3 + int(3 * RANART(NSEED))
            LB(I2) = 1 + int(2 * RANART(NSEED))
            E(I1) = PIMASS
            E(I2) = AMP
            GOTO 100
         ELSE IF (X1 .LE. XKY2) THEN
            LB(I1) = 3 + int(3 * RANART(NSEED))
            LB(I2) = 6 + int(4 * RANART(NSEED))
            E(I1) = PIMASS
            E(I2) = AM0
            GOTO 100
         ELSE IF (X1 .LE. XKY3) THEN
            LB(I1) = 3 + int(3 * RANART(NSEED))
            LB(I2) = 10 + int(2 * RANART(NSEED))
            E(I1) = PIMASS
            E(I2) = AM1440
            GOTO 100
         ELSE IF (X1 .LE. XKY4) THEN
            LB(I1) = 3 + int(3 * RANART(NSEED))
            LB(I2) = 12 + int(2 * RANART(NSEED))
            E(I1) = PIMASS
            E(I2) = AM1535
            GOTO 100
         ELSE IF (X1 .LE. XKY5) THEN
            LB(I1) = 25 + int(3 * RANART(NSEED))
            LB(I2) = 1 + int(2 * RANART(NSEED))
            E(I1) = AMRHO
            E(I2) = AMP
            GOTO 100
         ELSE IF (X1 .LE. XKY6) THEN
            LB(I1) = 25 + int(3 * RANART(NSEED))
            LB(I2) = 6 + int(4 * RANART(NSEED))
            E(I1) = AMRHO
            E(I2) = AM0
            GOTO 100
         ELSE IF (X1 .LE. XKY7) THEN
            LB(I1) = 25 + int(3 * RANART(NSEED))
            LB(I2) = 10 + int(2 * RANART(NSEED))
            E(I1) = AMRHO
            E(I2) = AM1440
            GOTO 100
         ELSE IF (X1 .LE. XKY8) THEN
            LB(I1) = 25 + int(3 * RANART(NSEED))
            LB(I2) = 12 + int(2 * RANART(NSEED))
            E(I1) = AMRHO
            E(I2) = AM1535
            GOTO 100
         ELSE IF (X1 .LE. XKY9) THEN
            LB(I1) = 28
            LB(I2) = 1 + int(2 * RANART(NSEED))
            E(I1) = AMOMGA
            E(I2) = AMP
            GOTO 100
         ELSE IF (X1 .LE. XKY10) THEN
            LB(I1) = 28
            LB(I2) = 6 + int(4 * RANART(NSEED))
            E(I1) = AMOMGA
            E(I2) = AM0
            GOTO 100
         ELSE IF (X1 .LE. XKY11) THEN
            LB(I1) = 28
            LB(I2) = 10 + int(2 * RANART(NSEED))
            E(I1) = AMOMGA
            E(I2) = AM1440
            GOTO 100
         ELSE IF (X1 .LE. XKY12) THEN
            LB(I1) = 28
            LB(I2) = 12 + int(2 * RANART(NSEED))
            E(I1) = AMOMGA
            E(I2) = AM1535
            GOTO 100
         ELSE IF (X1 .LE. XKY13) THEN
            LB(I1) = 0
            LB(I2) = 1 + int(2 * RANART(NSEED))
            E(I1) = AMETA
            E(I2) = AMP
            GOTO 100
         ELSE IF (X1 .LE. XKY14) THEN
            LB(I1) = 0
            LB(I2) = 6 + int(4 * RANART(NSEED))
            E(I1) = AMETA
            E(I2) = AM0
            GOTO 100
         ELSE IF (X1 .LE. XKY15) THEN
            LB(I1) = 0
            LB(I2) = 10 + int(2 * RANART(NSEED))
            E(I1) = AMETA
            E(I2) = AM1440
            GOTO 100
         ELSE IF (X1 .LE. XKY16) THEN
            LB(I1) = 0
            LB(I2) = 12 + int(2 * RANART(NSEED))
            E(I1) = AMETA
            E(I2) = AM1535
            GOTO 100
         ELSE
            LB(I1) = 29
            LB(I2) = 1 + int(2 * RANART(NSEED))
            E(I1) = APHI
            E(I2) = AMN
           IBLOCK=222
            GOTO 100
         END IF
 
  100    CONTINUE
          if(IKMP .eq. -1) LB(I2) = -LB(I2)
 
       EM1=E(I1)
       EM2=E(I2)
 *-----------------------------------------------------------------------
 * CALCULATE THE MAGNITUDE OF THE FINAL MOMENTUM THROUGH
 * ENERGY CONSERVATION
           PR2   = (SRT**2 - EM1**2 - EM2**2)**2
      1                - 4.0 * (EM1*EM2)**2
           IF(PR2.LE.0.)PR2=1.E-08
           PR=SQRT(PR2)/(2.*SRT)
 * WE ASSUME AN ISOTROPIC ANGULAR DISTRIBUTION IN THE CMS 
           C1   = 1.0 - 2.0 * RANART(NSEED)
           T1   = 2.0 * PI * RANART(NSEED)
       S1   = SQRT( 1.0 - C1**2 )
       CT1  = COS(T1)
       ST1  = SIN(T1)
 * THE MOMENTUM IN THE CMS IN THE FINAL STATE
       PZ   = PR * C1
       PX   = PR * S1*CT1 
       PY   = PR * S1*ST1
 * ROTATE IT 
        CALL ROTATE(PX0,PY0,PZ0,PX,PY,PZ) 
       RETURN
       END
 **********************************
 *                                                                      *
 *                                                                      *
       SUBROUTINE CRLAN(PX,PY,PZ,SRT,I1,I2,IBLOCK)
 *     PURPOSE:                                                         *
 *      DEALING WITH La/Si-bar + N --> K+ + pi PROCESS                  *
 *                   La/Si + N-bar --> K- + pi                          *
 *     NOTE   :                                                         *
 *
 *     QUANTITIES:                                                      *
 *           PX,PY,PZ - MOMENTUM COORDINATES OF ONE PARTICLE IN CM FRAME*
 *           SRT      - SQRT OF S                                       *
 *           IBLOCK   - THE INFORMATION BACK                            *
 *                      71
 **********************************
         PARAMETER (MAXSTR=150001,MAXR=1,AMN=0.939457,
      1  AMP=0.93828,AP1=0.13496,
      2  AP2=0.13957,AM0=1.232,PI=3.1415926,CUTOFF=1.8966,AVMASS=0.9383)
         PARAMETER      (AKA=0.498,ALA=1.1157,ASA=1.1974)
         parameter     (MX=4,MY=4,MZ=8,MPX=4,MPY=4,mpz=10,mpzp=10)
         COMMON /AA/ R(3,MAXSTR)
 cc      SAVE /AA/
         COMMON /BB/ P(3,MAXSTR)
 cc      SAVE /BB/
         COMMON /CC/ E(MAXSTR)
 cc      SAVE /CC/
         COMMON /EE/ ID(MAXSTR),LB(MAXSTR)
 cc      SAVE /EE/
         common/input1/ MASSPR,MASSTA,ISEED,IAVOID,DT
 cc      SAVE /input1/
       COMMON/RNDF77/NSEED
 cc      SAVE /RNDF77/
       SAVE   
 
         PX0=PX
         PY0=PY                                                          
         PZ0=PZ
         IBLOCK=71
         NTAG=0
        if( (lb(i1).ge.14.and.lb(i1).le.17) .OR.
      &     (lb(i2).ge.14.and.lb(i2).le.17) )then
         LB(I1)=21
        else
         LB(I1)=23
        endif
         LB(I2)= 3 + int(3 * RANART(NSEED))
         E(I1)=AKA
         E(I2)=0.138
         EM1=E(I1)
         EM2=E(I2)
 *-----------------------------------------------------------------------
 * CALCULATE THE MAGNITUDE OF THE FINAL MOMENTUM THROUGH
 * ENERGY CONSERVATION
         PR2   = (SRT**2 - EM1**2 - EM2**2)**2
      1                - 4.0 * (EM1*EM2)**2
           IF(PR2.LE.0.)PR2=1.e-09
           PR=SQRT(PR2)/(2.*SRT)
           C1   = 1.0 - 2.0 * RANART(NSEED)
           T1   = 2.0 * PI * RANART(NSEED)
       S1   = SQRT( 1.0 - C1**2 )
       CT1  = COS(T1)
       ST1  = SIN(T1)
 * THE MOMENTUM IN THE CMS IN THE FINAL STATE
       PZ   = PR * C1
       PX   = PR * S1*CT1
       PY   = PR * S1*ST1
 * FOR THE ISOTROPIC DISTRIBUTION THERE IS NO NEED TO ROTATE
       RETURN
       END
 csp11/03/01 end
 ********************************** 
 **********************************
 *                                                                      *
 *                                                                      *
         SUBROUTINE Crkpla(PX,PY,PZ,EC,SRT,spika,
      &                  emm1,emm2,lbp1,lbp2,I1,I2,icase,srhoks)
  
 *     PURPOSE:                                                         *
 *     DEALING WITH  K+ + Pi ---> La/Si-bar + B, phi+K, phi+K* OR  K* *
 *                   K- + Pi ---> La/Si + B-bar  OR   K*-bar          *
  
 *     NOTE   :                                                         *
 *
 *     QUANTITIES:                                                      *
 *           PX,PY,PZ - MOMENTUM COORDINATES OF ONE PARTICLE IN CM FRAME*
 *           SRT      - SQRT OF S                                       *
 *           IBLOCK   - THE INFORMATION BACK                            *
 *                      71
 **********************************
         PARAMETER (MAXSTR=150001,MAXR=1,AMN=0.939457,
      1  AMP=0.93828,AP1=0.13496,AP2=0.13957,AMRHO=0.769,AMOMGA=0.782,
      2  AM0=1.232,PI=3.1415926,CUTOFF=1.8966,AVMASS=0.9383)
         PARAMETER (AKA=0.498,AKS=0.895,ALA=1.1157,ASA=1.1974
      1 ,APHI=1.02)
         PARAMETER (AM1440 = 1.44, AM1535 = 1.535)
         parameter     (MX=4,MY=4,MZ=8,MPX=4,MPY=4,mpz=10,mpzp=10)
         COMMON /AA/ R(3,MAXSTR)
 cc      SAVE /AA/
         COMMON /BB/ P(3,MAXSTR)
 cc      SAVE /BB/
         COMMON /CC/ E(MAXSTR)
 cc      SAVE /CC/
         COMMON /EE/ ID(MAXSTR),LB(MAXSTR)
 cc      SAVE /EE/
         common/input1/ MASSPR,MASSTA,ISEED,IAVOID,DT
 cc      SAVE /input1/
       COMMON/RNDF77/NSEED
 cc      SAVE /RNDF77/
       SAVE   
 
           emm1=0.
           emm2=0.
           lbp1=0
           lbp2=0
            XKP0 = spika
            XKP1 = 0.
            XKP2 = 0.
            XKP3 = 0.
            XKP4 = 0.
            XKP5 = 0.
            XKP6 = 0.
            XKP7 = 0.
            XKP8 = 0.
            XKP9 = 0.
            XKP10 = 0.
            sigm = 15.
 c         if(lb(i1).eq.21.or.lb(i2).eq.21)sigm=10.
         pdd = (srt**2-(aka+ap1)**2)*(srt**2-(aka-ap1)**2)
 c
          if(srt .lt. (ala+amn))go to 70
         XKP1 = sigm*(4./3.)*(srt**2-(ala+amn)**2)*
      &           (srt**2-(ala-amn)**2)/pdd
          if(srt .gt. (ala+am0))then
         XKP2 = sigm*(16./3.)*(srt**2-(ala+am0)**2)*
      &           (srt**2-(ala-am0)**2)/pdd
          endif
          if(srt .gt. (ala+am1440))then
         XKP3 = sigm*(4./3.)*(srt**2-(ala+am1440)**2)*
      &           (srt**2-(ala-am1440)**2)/pdd
          endif
          if(srt .gt. (ala+am1535))then
         XKP4 = sigm*(4./3.)*(srt**2-(ala+am1535)**2)*
      &           (srt**2-(ala-am1535)**2)/pdd
          endif
 c
          if(srt .gt. (asa+amn))then
         XKP5 = sigm*4.*(srt**2-(asa+amn)**2)*
      &           (srt**2-(asa-amn)**2)/pdd
          endif
          if(srt .gt. (asa+am0))then
         XKP6 = sigm*16.*(srt**2-(asa+am0)**2)*
      &           (srt**2-(asa-am0)**2)/pdd
          endif
          if(srt .gt. (asa+am1440))then
         XKP7 = sigm*4.*(srt**2-(asa+am1440)**2)*
      &           (srt**2-(asa-am1440)**2)/pdd
          endif
          if(srt .gt. (asa+am1535))then
         XKP8 = sigm*4.*(srt**2-(asa+am1535)**2)*
      &           (srt**2-(asa-am1535)**2)/pdd
          endif
 70     continue
           sig1 = 195.639
           sig2 = 372.378
        if(srt .gt. aphi+aka)then
         pff = sqrt((srt**2-(aphi+aka)**2)*(srt**2-(aphi-aka)**2))
 
 clin-9/2012: check argument in sqrt():
         scheck=pdd
         if(scheck.le.0) then
            write(99,*) 'scheck40: ', scheck
            stop
         endif
         
          XKP9 = sig1*pff/sqrt(pdd)*1./32./pi/srt**2
         if(srt .gt. aphi+aks)then
         pff = sqrt((srt**2-(aphi+aks)**2)*(srt**2-(aphi-aks)**2))
 
 clin-9/2012: check argument in sqrt():
         scheck=pdd
         if(scheck.le.0) then
            write(99,*) 'scheck41: ', scheck
            stop
         endif
 
          XKP10 = sig2*pff/sqrt(pdd)*3./32./pi/srt**2
        endif
         endif
 
 clin-8/15/02 K pi -> K* (rho omega), from detailed balance, 
 c neglect rho and omega mass difference for now:
         sigpik=0.
         if(srt.gt.(amrho+aks)) then
            sigpik=srhoks*9.
      1          *(srt**2-(0.77-aks)**2)*(srt**2-(0.77+aks)**2)/4
      2          /srt**2/(px**2+py**2+pz**2)
            if(srt.gt.(amomga+aks)) sigpik=sigpik*12./9.
         endif
 
 c
          sigkp = XKP0 + XKP1 + XKP2 + XKP3 + XKP4
      &         + XKP5 + XKP6 + XKP7 + XKP8 + XKP9 + XKP10 +sigpik
            icase = 0 
          DSkn=SQRT(sigkp/PI/10.)
         dsknr=dskn+0.1
         CALL DISTCE(I1,I2,dsknr,DSkn,DT,EC,SRT,IC,
      1  PX,PY,PZ)
         IF(IC.EQ.-1)return
 c
         randu = RANART(NSEED)*sigkp
         XKP1 = XKP0 + XKP1
         XKP2 = XKP1 + XKP2
         XKP3 = XKP2 + XKP3
         XKP4 = XKP3 + XKP4
         XKP5 = XKP4 + XKP5
         XKP6 = XKP5 + XKP6
         XKP7 = XKP6 + XKP7
         XKP8 = XKP7 + XKP8
         XKP9 = XKP8 + XKP9
 
         XKP10 = XKP9 + XKP10
 c
 c   !! K* formation
          if(randu .le. XKP0)then
            icase = 1
             return
          else
 * La/Si-bar + B formation
            icase = 2
          if( randu .le. XKP1 )then
              lbp1 = -14
              lbp2 = 1 + int(2*RANART(NSEED))
              emm1 = ala
              emm2 = amn
              go to 60
          elseif( randu .le. XKP2 )then
              lbp1 = -14
              lbp2 = 6 + int(4*RANART(NSEED))
              emm1 = ala
              emm2 = am0
              go to 60
          elseif( randu .le. XKP3 )then
              lbp1 = -14
              lbp2 = 10 + int(2*RANART(NSEED))
              emm1 = ala
              emm2 = am1440
              go to 60
          elseif( randu .le. XKP4 )then
              lbp1 = -14
              lbp2 = 12 + int(2*RANART(NSEED))
              emm1 = ala
              emm2 = am1535
              go to 60
          elseif( randu .le. XKP5 )then
              lbp1 = -15 - int(3*RANART(NSEED))
              lbp2 = 1 + int(2*RANART(NSEED))
              emm1 = asa
              emm2 = amn
              go to 60
          elseif( randu .le. XKP6 )then
              lbp1 = -15 - int(3*RANART(NSEED))
              lbp2 = 6 + int(4*RANART(NSEED))
              emm1 = asa
              emm2 = am0
              go to 60
           elseif( randu .lt. XKP7 )then
              lbp1 = -15 - int(3*RANART(NSEED))
              lbp2 = 10 + int(2*RANART(NSEED))
              emm1 = asa
              emm2 = am1440
              go to 60
           elseif( randu .lt. XKP8 )then
              lbp1 = -15 - int(3*RANART(NSEED))
              lbp2 = 12 + int(2*RANART(NSEED))
              emm1 = asa
              emm2 = am1535
              go to 60
           elseif( randu .lt. XKP9 )then
 c       !! phi +K  formation (iblock=224)
             icase = 3
              lbp1 = 29
              lbp2 = 23
              emm1 = aphi
              emm2 = aka
            if(lb(i1).eq.21.or.lb(i2).eq.21)then
 c         !! phi +K-bar  formation (iblock=124)
              lbp2 = 21
              icase = -3
            endif
              go to 60
           elseif( randu .lt. XKP10 )then
 c       !! phi +K* formation (iblock=226)
             icase = 4
              lbp1 = 29
              lbp2 = 30
              emm1 = aphi
              emm2 = aks
            if(lb(i1).eq.21.or.lb(i2).eq.21)then
              lbp2 = -30
              icase = -4
            endif
            go to 60
 
           else
 c       !! (rho,omega) +K* formation (iblock=88)
             icase=5
             lbp1=25+int(3*RANART(NSEED))
             lbp2=30
             emm1=amrho
             emm2=aks
             if(srt.gt.(amomga+aks).and.RANART(NSEED).lt.0.25) then
                lbp1=28
                emm1=amomga
             endif
             if(lb(i1).eq.21.or.lb(i2).eq.21)then
                lbp2=-30
                icase=-5
             endif
 
           endif
           endif
 c
 60       if( icase.eq.2 .and. (lb(i1).eq.21.or.lb(i2).eq.21) )then
             lbp1 = -lbp1
             lbp2 = -lbp2
          endif
         PX0=PX
         PY0=PY
         PZ0=PZ
 *-----------------------------------------------------------------------       
 * CALCULATE THE MAGNITUDE OF THE FINAL MOMENTUM THROUGH
 * ENERGY CONSERVATION
            PR2   = (SRT**2 - EMM1**2 - EMM2**2)**2
      1                - 4.0 * (EMM1*EMM2)**2
           IF(PR2.LE.0.)PR2=1.e-09
           PR=SQRT(PR2)/(2.*SRT)
           C1   = 1.0 - 2.0 * RANART(NSEED)
           T1   = 2.0 * PI * RANART(NSEED)
       S1   = SQRT( 1.0 - C1**2 )
       CT1  = COS(T1)
       ST1  = SIN(T1)
 * THE MOMENTUM IN THE CMS IN THE FINAL STATE
       PZ   = PR * C1
       PX   = PR * S1*CT1
       PY   = PR * S1*ST1
 * FOR THE ISOTROPIC DISTRIBUTION THERE IS NO NEED TO ROTATE
       RETURN
       END
 **********************************       
 *                                                                      *
 *                                                                      *
         SUBROUTINE Crkphi(PX,PY,PZ,EC,SRT,IBLOCK,
      &                  emm1,emm2,lbp1,lbp2,I1,I2,ikk,icase,rrkk,prkk)
  
 *     PURPOSE:                                                         *
 *     DEALING WITH   KKbar, KK*bar, KbarK*, K*K*bar --> Phi + pi(rho,omega)
 *     and KKbar --> (pi eta) (pi eta), (rho omega) (rho omega)
 *     and KK*bar or Kbar K* --> (pi eta) (rho omega)
 *
 *     NOTE   :                                                         *
 *
 *     QUANTITIES:                                                      *
 *           PX,PY,PZ - MOMENTUM COORDINATES OF ONE PARTICLE IN CM FRAME*
 *           SRT      - SQRT OF S                                       *
 *           IBLOCK   - THE INFORMATION BACK                            *
 *                      222
 **********************************
         PARAMETER (MAXSTR=150001,MAXR=1,AMN=0.939457,
      1  AMP=0.93828,AP1=0.13496,AP2=0.13957,APHI=1.02,
      2  AM0=1.232,AMNS=1.52,PI=3.1415926,CUTOFF=1.8966,AVMASS=0.9383)
         PARAMETER      (AKA=0.498,ALA=1.1157,ASA=1.1974,ACAS=1.3213)
         PARAMETER      (AKS=0.895,AOMEGA=0.7819, ARHO=0.77)
         parameter     (MX=4,MY=4,MZ=8,MPX=4,MPY=4,mpz=10,mpzp=10)
         COMMON /AA/ R(3,MAXSTR)
 cc      SAVE /AA/
         COMMON /BB/ P(3,MAXSTR)
 cc      SAVE /BB/
         COMMON /CC/ E(MAXSTR)
 cc      SAVE /CC/
         COMMON /EE/ ID(MAXSTR),LB(MAXSTR)
 cc      SAVE /EE/
         common/input1/ MASSPR,MASSTA,ISEED,IAVOID,DT
 cc      SAVE /input1/
       COMMON/RNDF77/NSEED
 cc      SAVE /RNDF77/
       SAVE   
 
         lb1 = lb(i1) 
         lb2 = lb(i2) 
         icase = 0
 
 c        if(srt .lt. aphi+ap1)return
 cc        if(srt .lt. aphi+ap1) then
         if(srt .lt. (aphi+ap1)) then
            sig1 = 0.
            sig2 = 0.
            sig3 = 0.
         else
 c
          if((lb1.eq.23.and.lb2.eq.21).or.(lb2.eq.23.and.lb1.eq.21))then
             dnr =  4.
             ikk = 2
           elseif((lb1.eq.21.and.lb2.eq.30).or.(lb2.eq.21.and.lb1.eq.30)
      & .or.(lb1.eq.23.and.lb2.eq.-30).or.(lb2.eq.23.and.lb1.eq.-30))then
              dnr = 12.
              ikk = 1
           else
              dnr = 36.
              ikk = 0
           endif
               
           sig1 = 0.
           sig2 = 0.
           sig3 = 0.
           srri = E(i1)+E(i2)
           srr1 = aphi+ap1
           srr2 = aphi+aomega
           srr3 = aphi+arho
 c
           pii = (srt**2-(e(i1)+e(i2))**2)*(srt**2-(e(i1)-e(i2))**2)
           srrt = srt - amax1(srri,srr1)
 cc   to avoid divergent/negative values at small srrt:
 c          if(srrt .lt. 0.3)then
           if(srrt .lt. 0.3 .and. srrt .gt. 0.01)then
           sig = 1.69/(srrt**0.141 - 0.407)
          else
           sig = 3.74 + 0.008*srrt**1.9
          endif                 
           sig1=sig*(9./dnr)*(srt**2-(aphi+ap1)**2)*
      &           (srt**2-(aphi-ap1)**2)/pii
           if(srt .gt. aphi+aomega)then
           srrt = srt - amax1(srri,srr2)
 cc         if(srrt .lt. 0.3)then
           if(srrt .lt. 0.3 .and. srrt .gt. 0.01)then
           sig = 1.69/(srrt**0.141 - 0.407)
          else
           sig = 3.74 + 0.008*srrt**1.9
          endif                 
           sig2=sig*(9./dnr)*(srt**2-(aphi+aomega)**2)*
      &           (srt**2-(aphi-aomega)**2)/pii
            endif
          if(srt .gt. aphi+arho)then
           srrt = srt - amax1(srri,srr3)
 cc         if(srrt .lt. 0.3)then
           if(srrt .lt. 0.3 .and. srrt .gt. 0.01)then
           sig = 1.69/(srrt**0.141 - 0.407)
          else
           sig = 3.74 + 0.008*srrt**1.9
          endif                 
           sig3=sig*(27./dnr)*(srt**2-(aphi+arho)**2)*
      &           (srt**2-(aphi-arho)**2)/pii
          endif                 
 c         sig1 = amin1(20.,sig1)
 c         sig2 = amin1(20.,sig2)
 c         sig3 = amin1(20.,sig3)
         endif
 
         rrkk0=rrkk
         prkk0=prkk
         SIGM=0.
         if((lb1.eq.23.and.lb2.eq.21).or.(lb2.eq.23.and.lb1.eq.21))then
            CALL XKKANN(SRT, XSK1, XSK2, XSK3, XSK4, XSK5,
      &          XSK6, XSK7, XSK8, XSK9, XSK10, XSK11, SIGM, rrkk0)
         elseif((lb1.eq.21.and.lb2.eq.30).or.(lb2.eq.21.and.lb1.eq.30)
      & .or.(lb1.eq.23.and.lb2.eq.-30).or.(lb2.eq.23.and.lb1.eq.-30))then
            CALL XKKSAN(i1,i2,SRT,SIGKS1,SIGKS2,SIGKS3,SIGKS4,SIGM,prkk0)
         else
         endif
 c
 c         sigks = sig1 + sig2 + sig3
         sigm0=sigm
         sigks = sig1 + sig2 + sig3 + SIGM
         DSkn=SQRT(sigks/PI/10.)
         dsknr=dskn+0.1
         CALL DISTCE(I1,I2,dsknr,DSkn,DT,EC,SRT,IC,
      1  PX,PY,PZ)
         IF(IC.EQ.-1)return
         icase = 1
         ranx = RANART(NSEED) 
 
         lbp1 = 29
         emm1 = aphi
         if(ranx .le. sig1/sigks)then 
            lbp2 = 3 + int(3*RANART(NSEED))
            emm2 = ap1
         elseif(ranx .le. (sig1+sig2)/sigks)then
            lbp2 = 28
            emm2 = aomega
         elseif(ranx .le. (sig1+sig2+sig3)/sigks)then
            lbp2 = 25 + int(3*RANART(NSEED))
            emm2 = arho
         else
            if((lb1.eq.23.and.lb2.eq.21)
      &          .or.(lb2.eq.23.and.lb1.eq.21))then
               CALL crkkpi(I1,I2,XSK1, XSK2, XSK3, XSK4,
      &             XSK5, XSK6, XSK7, XSK8, XSK9, XSK10, XSK11, SIGM0,
      &             IBLOCK,lbp1,lbp2,emm1,emm2)
            elseif((lb1.eq.21.and.lb2.eq.30)
      &             .or.(lb2.eq.21.and.lb1.eq.30)
      &             .or.(lb1.eq.23.and.lb2.eq.-30)
      &             .or.(lb2.eq.23.and.lb1.eq.-30))then
               CALL crkspi(I1,I2,SIGKS1, SIGKS2, SIGKS3, SIGKS4,
      &             SIGM0,IBLOCK,lbp1,lbp2,emm1,emm2)
            else
            endif
         endif
 *
         PX0=PX
         PY0=PY
         PZ0=PZ
 *-----------------------------------------------------------------------
 * CALCULATE THE MAGNITUDE OF THE FINAL MOMENTUM THROUGH
 * ENERGY CONSERVATION
            PR2   = (SRT**2 - EMM1**2 - EMM2**2)**2
      1                - 4.0 * (EMM1*EMM2)**2
           IF(PR2.LE.0.)PR2=1.e-09
           PR=SQRT(PR2)/(2.*SRT)
           C1   = 1.0 - 2.0 * RANART(NSEED)
           T1   = 2.0 * PI * RANART(NSEED)
       S1   = SQRT( 1.0 - C1**2 )
       CT1  = COS(T1)
       ST1  = SIN(T1)
 * THE MOMENTUM IN THE CMS IN THE FINAL STATE
       PZ   = PR * C1
       PX   = PR * S1*CT1
       PY   = PR * S1*ST1
 * FOR THE ISOTROPIC DISTRIBUTION THERE IS NO NEED TO ROTATE
       RETURN
       END
 csp11/21/01 end
 **********************************
 *                                                                      *
 *                                                                      *
         SUBROUTINE Crksph(PX,PY,PZ,EC,SRT,
      &     emm1,emm2,lbp1,lbp2,I1,I2,ikkg,ikkl,iblock,
      &     icase,srhoks)
  
 *     PURPOSE:                                                         *
 *     DEALING WITH   K + rho(omega) or K* + pi(rho,omega) 
 *                    --> Phi + K(K*), pi + K* or pi + K, and elastic 
 *     NOTE   :                                                         *
 *
 *     QUANTITIES:                                                      *
 *           PX,PY,PZ - MOMENTUM COORDINATES OF ONE PARTICLE IN CM FRAME*
 *           SRT      - SQRT OF S                                       *
 *           IBLOCK   - THE INFORMATION BACK                            *
 *                      222
 *                      223 --> phi + pi(rho,omega)
 *                      224 --> phi + K <-> K + pi(rho,omega)
 *                      225 --> phi + K <-> K* + pi(rho,omega)
 *                      226 --> phi + K* <-> K + pi(rho,omega)
 *                      227 --> phi + K* <-> K* + pi(rho,omega)
 **********************************
         PARAMETER (MAXSTR=150001,MAXR=1,AMN=0.939457,
      1  AMP=0.93828,AP1=0.13496,AP2=0.13957,APHI=1.02,
      2  AM0=1.232,AMNS=1.52,PI=3.1415926,CUTOFF=1.8966,AVMASS=0.9383)
         PARAMETER      (AKA=0.498,ALA=1.1157,ASA=1.1974,ACAS=1.3213)
         PARAMETER      (AKS=0.895,AOMEGA=0.7819, ARHO=0.77)
         parameter     (MX=4,MY=4,MZ=8,MPX=4,MPY=4,mpz=10,mpzp=10)
         COMMON /AA/ R(3,MAXSTR)
 cc      SAVE /AA/
         COMMON /BB/ P(3,MAXSTR)
 cc      SAVE /BB/
         COMMON /CC/ E(MAXSTR)
 cc      SAVE /CC/
         COMMON /EE/ ID(MAXSTR),LB(MAXSTR)
 cc      SAVE /EE/
         common/input1/ MASSPR,MASSTA,ISEED,IAVOID,DT
 cc      SAVE /input1/
       COMMON/RNDF77/NSEED
 cc      SAVE /RNDF77/
       SAVE   
 
         lb1 = lb(i1) 
         lb2 = lb(i2) 
         icase = 0
         sigela=10.
         sigkm=0.
 c     K(K*) + rho(omega) -> pi K*(K)
         if((lb1.ge.25.and.lb1.le.28).or.(lb2.ge.25.and.lb2.le.28)) then
            if(iabs(lb1).eq.30.or.iabs(lb2).eq.30) then
               sigkm=srhoks
 clin-2/26/03 check whether (rho K) is above the (pi K*) thresh:
            elseif((lb1.eq.23.or.lb1.eq.21.or.lb2.eq.23.or.lb2.eq.21)
      1             .and.srt.gt.(ap2+aks)) then
               sigkm=srhoks
            endif
         endif
 
 c        if(srt .lt. aphi+aka)return
         if(srt .lt. (aphi+aka)) then
            sig11=0.
            sig22=0.
         else
 
 c K*-bar +pi --> phi + (K,K*)-bar
          if( (iabs(lb1).eq.30.and.(lb2.ge.3.and.lb2.le.5)) .or.
      &       (iabs(lb2).eq.30.and.(lb1.ge.3.and.lb1.le.5)) )then
               dnr =  18.
               ikkl = 0
               IBLOCK = 225
 c               sig1 = 15.0  
 c               sig2 = 30.0  
 clin-2/06/03 these large values reduces to ~10 mb for sig11 or sig22
 c     due to the factors of ~1/(32*pi*s)~1/200:
                sig1 = 2047.042  
                sig2 = 1496.692
 c K(-bar)+rho --> phi + (K,K*)-bar
        elseif((lb1.eq.23.or.lb1.eq.21.and.(lb2.ge.25.and.lb2.le.27)).or.
      &      (lb2.eq.23.or.lb2.eq.21.and.(lb1.ge.25.and.lb1.le.27)) )then
               dnr =  18.
               ikkl = 1
               IBLOCK = 224
 c               sig1 = 3.5  
 c               sig2 = 9.0  
                sig1 = 526.702
                sig2 = 1313.960
 c K*(-bar) +rho
          elseif( (iabs(lb1).eq.30.and.(lb2.ge.25.and.lb2.le.27)) .or.
      &           (iabs(lb2).eq.30.and.(lb1.ge.25.and.lb1.le.27)) )then
               dnr =  54.
               ikkl = 0
               IBLOCK = 225
 c               sig1 = 3.5  
 c               sig2 = 9.0  
                sig1 = 1371.257
                sig2 = 6999.840
 c K(-bar) + omega
          elseif( ((lb1.eq.23.or.lb1.eq.21) .and. lb2.eq.28).or.
      &           ((lb2.eq.23.or.lb2.eq.21) .and. lb1.eq.28) )then
               dnr = 6.
               ikkl = 1
               IBLOCK = 224
 c               sig1 = 3.5  
 c               sig2 = 6.5  
                sig1 = 355.429
                sig2 = 440.558
 c K*(-bar) +omega
           else
               dnr = 18.
               ikkl = 0
               IBLOCK = 225
 c               sig1 = 3.5  
 c               sig2 = 15.0  
                sig1 = 482.292
                sig2 = 1698.903
           endif
 
             sig11 = 0.
             sig22 = 0.
 c         sig11=sig1*(6./dnr)*(srt**2-(aphi+aka)**2)*
 c    &           (srt**2-(aphi-aka)**2)/(srt**2-(e(i1)+e(i2))**2)/
 c    &           (srt**2-(e(i1)-e(i2))**2)
 
 clin-9/2012: check argument in sqrt():
             scheck=(srt**2-(e(i1)+e(i2))**2)*(srt**2-(e(i1)-e(i2))**2)
             if(scheck.le.0) then
                write(99,*) 'scheck42: ', scheck
                stop
             endif
             pii=sqrt(scheck)
 c        pii = sqrt((srt**2-(e(i1)+e(i2))**2)*(srt**2-(e(i1)-e(i2))**2))
 
 clin-9/2012: check argument in sqrt():
             scheck=(srt**2-(aphi+aka)**2)*(srt**2-(aphi-aka)**2)
             if(scheck.lt.0) then
                write(99,*) 'scheck43: ', scheck
                scheck=0.
             endif
         pff = sqrt(scheck)
 c        pff = sqrt((srt**2-(aphi+aka)**2)*(srt**2-(aphi-aka)**2))
 
           sig11 = sig1*pff/pii*6./dnr/32./pi/srt**2
 c
           if(srt .gt. aphi+aks)then
 c         sig22=sig2*(18./dnr)*(srt**2-(aphi+aks)**2)*
 c    &           (srt**2-(aphi-aks)**2)/(srt**2-(e(i1)+e(i2))**2)/
 c    &           (srt**2-(e(i1)-e(i2))**2)
         pff = sqrt((srt**2-(aphi+aks)**2)*(srt**2-(aphi-aks)**2))
           sig22 = sig2*pff/pii*18./dnr/32./pi/srt**2
            endif
 c         sig11 = amin1(20.,sig11)
 c         sig22 = amin1(20.,sig22)
 c
         endif
 
 c         sigks = sig11 + sig22
          sigks=sig11+sig22+sigela+sigkm
 c
         DSkn=SQRT(sigks/PI/10.)
         dsknr=dskn+0.1
         CALL DISTCE(I1,I2,dsknr,DSkn,DT,EC,SRT,IC,
      1  PX,PY,PZ)
         IF(IC.EQ.-1)return
         icase = 1
         ranx = RANART(NSEED) 
 
          if(ranx .le. (sigela/sigks))then 
             lbp1=lb1
             emm1=e(i1)
             lbp2=lb2
             emm2=e(i2)
             iblock=111
          elseif(ranx .le. ((sigela+sigkm)/sigks))then 
             lbp1=3+int(3*RANART(NSEED))
             emm1=0.14
             if(lb1.eq.23.or.lb2.eq.23) then
                lbp2=30
                emm2=aks
             elseif(lb1.eq.21.or.lb2.eq.21) then
                lbp2=-30
                emm2=aks
             elseif(lb1.eq.30.or.lb2.eq.30) then
                lbp2=23
                emm2=aka
             else
                lbp2=21
                emm2=aka
             endif
             iblock=112
          elseif(ranx .le. ((sigela+sigkm+sig11)/sigks))then 
             lbp2 = 23
             emm2 = aka
             ikkg = 1
             if(lb1.eq.21.or.lb2.eq.21.or.lb1.eq.-30.or.lb2.eq.-30)then
                lbp2=21
                iblock=iblock-100
             endif
             lbp1 = 29
             emm1 = aphi
          else
             lbp2 = 30
             emm2 = aks
             ikkg = 0
             IBLOCK=IBLOCK+2
             if(lb1.eq.21.or.lb2.eq.21.or.lb1.eq.-30.or.lb2.eq.-30)then
                lbp2=-30
                iblock=iblock-100
             endif
             lbp1 = 29
             emm1 = aphi
          endif
 *
         PX0=PX
         PY0=PY
         PZ0=PZ
 *-----------------------------------------------------------------------
 * CALCULATE THE MAGNITUDE OF THE FINAL MOMENTUM THROUGH
 * ENERGY CONSERVATION
            PR2   = (SRT**2 - EMM1**2 - EMM2**2)**2
      1                - 4.0 * (EMM1*EMM2)**2
           IF(PR2.LE.0.)PR2=1.e-09
           PR=SQRT(PR2)/(2.*SRT)
           C1   = 1.0 - 2.0 * RANART(NSEED)
           T1   = 2.0 * PI * RANART(NSEED)
       S1   = SQRT( 1.0 - C1**2 )
       CT1  = COS(T1)
       ST1  = SIN(T1)
 * THE MOMENTUM IN THE CMS IN THE FINAL STATE
       PZ   = PR * C1
       PX   = PR * S1*CT1
       PY   = PR * S1*ST1
 * FOR THE ISOTROPIC DISTRIBUTION THERE IS NO NEED TO ROTATE
       RETURN
       END
 csp11/21/01 end
 **********************************
 ********************************** 
         SUBROUTINE bbkaon(ic,SRT,PX,PY,PZ,ana,PlX,
      &  PlY,PlZ,ala,pkX,PkY,PkZ,icou1)
 * purpose: generate the momenta for kaon,lambda/sigma and nucleon/delta
 *          in the BB-->nlk process
 * date: Sept. 9, 1994
 c
         common/input1/ MASSPR,MASSTA,ISEED,IAVOID,DT
 cc      SAVE /input1/
       COMMON/RNDF77/NSEED
 cc      SAVE /RNDF77/
       SAVE   
 
        PI=3.1415962
        icou1=0
        aka=0.498
         ala=1.116
        if(ic.eq.2.or.ic.eq.4)ala=1.197
        ana=0.939
 * generate the mass of the delta
        if(ic.gt.2)then
        dmax=srt-aka-ala-0.02
         DM1=RMASS(DMAX,ISEED)
        ana=dm1
        endif
        t1=aka+ana+ala
        t2=ana+ala-aka
        if(srt.le.t1)then
        icou1=-1
        return
        endif
        pmax=sqrt((srt**2-t1**2)*(srt**2-t2**2))/(2.*srt)
        if(pmax.eq.0.)pmax=1.e-09
 * (1) Generate the momentum of the kaon according to the distribution Fkaon
 *     and assume that the angular distribution is isotropic       
 *     in the cms of the colliding pair
        ntry=0
 1       pk=pmax*RANART(NSEED)
        ntry=ntry+1
        prob=fkaon(pk,pmax)
        if((prob.lt.RANART(NSEED)).and.(ntry.le.40))go to 1
        cs=1.-2.*RANART(NSEED)
        ss=sqrt(1.-cs**2)
        fai=2.*3.14*RANART(NSEED)
        pkx=pk*ss*cos(fai)
        pky=pk*ss*sin(fai)
        pkz=pk*cs
 * the energy of the kaon
        ek=sqrt(aka**2+pk**2)
 * (2) Generate the momentum of the nucleon/delta in the cms of N/delta 
 *     and lamda/sigma 
 *  the energy of the cms of NL
         eln=srt-ek
        if(eln.le.0)then
        icou1=-1
        return
        endif
 * beta and gamma of the cms of L/S+N
        bx=-pkx/eln
        by=-pky/eln
        bz=-pkz/eln
 
 clin-9/2012: check argument in sqrt():
        scheck=1.-bx**2-by**2-bz**2
        if(scheck.le.0) then
           write(99,*) 'scheck44: ', scheck
           stop
        endif
        ga=1./sqrt(scheck)
 c       ga=1./sqrt(1.-bx**2-by**2-bz**2)
 
         elnc=eln/ga
        pn2=((elnc**2+ana**2-ala**2)/(2.*elnc))**2-ana**2
        if(pn2.le.0.)pn2=1.e-09
        pn=sqrt(pn2)
        csn=1.-2.*RANART(NSEED)
        ssn=sqrt(1.-csn**2)
        fain=2.*3.14*RANART(NSEED)
        px=pn*ssn*cos(fain)
        py=pn*ssn*sin(fain)
        pz=pn*csn
        en=sqrt(ana**2+pn2)
 * the momentum of the lambda/sigma in the n-l cms frame is
        plx=-px
        ply=-py
        plz=-pz
 * (3) LORENTZ-TRANSFORMATION INTO nn cms FRAME for the neutron/delta
         PBETA  = PX*BX + PY*By+ PZ*Bz
               TRANS0  = GA * ( GA * PBETA / (GA + 1.) + En )
               Px = BX * TRANS0 + PX
               Py = BY * TRANS0 + PY
               Pz = BZ * TRANS0 + PZ
 * (4) Lorentz-transformation for the lambda/sigma
        el=sqrt(ala**2+plx**2+ply**2+plz**2)
         PBETA  = PlX*BX + PlY*By+ PlZ*Bz
               TRANS0  = GA * ( GA * PBETA / (GA + 1.) + El )
               Plx = BX * TRANS0 + PlX
               Ply = BY * TRANS0 + PlY
               Plz = BZ * TRANS0 + PlZ
              return
              end
 ******************************************
 * for pion+pion-->K+K-
 c      real*4 function pipik(srt)
       real function pipik(srt)
 *  srt    = DSQRT(s) in GeV                                                   *
 *  xsec   = production cross section in mb                                    *
 *  NOTE: DEVIDE THE CROSS SECTION TO OBTAIN K+ PRODUCTION                     *
 ******************************************
 c      real*4   xarray(5), earray(5)
       real   xarray(5), earray(5)
       SAVE   
       data xarray /0.001, 0.7,1.5,1.7,2.0/
       data earray /1.,1.2,1.6,2.0,2.4/
 
            pmass=0.9383 
 * 1.Calculate p(lab)  from srt [GeV]
 *   Formula used:   DSQRT(s) = 2 m DSQRT(E_kin/(2m) + 1)
 c      ekin = 2.*pmass*((srt/(2.*pmass))**2 - 1.)
        pipik=0.
        if(srt.le.1.)return
        if(srt.gt.2.4)then
            pipik=2.0/2.
            return
        endif
         if (srt .lt. earray(1)) then
            pipik =xarray(1)/2.
            return
         end if
 *
 * 2.Interpolate double logarithmically to find sigma(srt)
 *
       do 1001 ie = 1,5
         if (earray(ie) .eq. srt) then
           pipik = xarray(ie)
           go to 10
         else if (earray(ie) .gt. srt) then
           ymin = alog(xarray(ie-1))
           ymax = alog(xarray(ie))
           xmin = alog(earray(ie-1))
           xmax = alog(earray(ie))
           pipik = exp(ymin + (alog(srt)-xmin)*(ymax-ymin)
      &/(xmax-xmin) )
           go to 10
         end if
  1001 continue
 10       PIPIK=PIPIK/2.
        continue
       return
         END
 **********************************
 * TOTAL PION-P INELASTIC CROSS SECTION 
 *  from the CERN data book
 *  date: Sept.2, 1994
 *  for pion++p-->Delta+pion
 c      real*4 function pionpp(srt)
       real function pionpp(srt)
       SAVE   
 *  srt    = DSQRT(s) in GeV                                                   *
 *  xsec   = production cross section in fm**2                                 *
 *  earray = EXPerimental table with proton energies in MeV                    *
 *  xarray = EXPerimental table with cross sections in mb (curve to guide eye) *
 *                                                                             *
 ******************************************
            pmass=0.14 
        pmass1=0.938
        PIONPP=0.00001
        IF(SRT.LE.1.22)RETURN
 * 1.Calculate p(lab)  from srt [GeV]
 *   Formula used:   DSQRT(s) = 2 m DSQRT(E_kin/(2m) + 1)
 c      ekin = 2.*pmass*((srt/(2.*pmass))**2 - 1.)
         plab=sqrt(((srt**2-pmass**2-pmass1**2)/(2.*pmass1))**2-pmass**2)
        pmin=0.3
        pmax=25.0
        if(plab.gt.pmax)then
        pionpp=20./10.
        return
        endif
         if(plab .lt. pmin)then
         pionpp = 0.
         return
         end if
 c* fit parameters
        a=24.3
        b=-12.3
        c=0.324
        an=-1.91
        d=-2.44
         pionpp = a+b*(plab**an)+c*(alog(plab))**2+d*alog(plab)
        if(pionpp.le.0)pionpp=0
        pionpp=pionpp/10.
         return
         END
 **********************************
 * elementary cross sections
 *  from the CERN data book
 *  date: Sept.2, 1994
 *  for pion-+p-->INELASTIC
 c      real*4 function pipp1(srt)
       real function pipp1(srt)
       SAVE   
 *  srt    = DSQRT(s) in GeV                                                   *
 *  xsec   = production cross section in fm**2                                 *
 *  earray = EXPerimental table with proton energies in MeV                    *
 *  xarray = EXPerimental table with cross sections in mb (curve to guide eye) *
 *  UNITS: FM**2
 ******************************************
            pmass=0.14 
        pmass1=0.938
        PIPP1=0.0001
        IF(SRT.LE.1.22)RETURN
 * 1.Calculate p(lab)  from srt [GeV]
 *   Formula used:   DSQRT(s) = 2 m DSQRT(E_kin/(2m) + 1)
 c      ekin = 2.*pmass*((srt/(2.*pmass))**2 - 1.)
         plab=sqrt(((srt**2-pmass**2-pmass1**2)/(2.*pmass1))**2-pmass**2)
        pmin=0.3
        pmax=25.0
        if(plab.gt.pmax)then
        pipp1=20./10.
        return
        endif
         if(plab .lt. pmin)then
         pipp1 = 0.
         return
         end if
 c* fit parameters
        a=26.6
        b=-7.18
        c=0.327
        an=-1.86
        d=-2.81
         pipp1 = a+b*(plab**an)+c*(alog(plab))**2+d*alog(plab)
        if(pipp1.le.0)pipp1=0
        PIPP1=PIPP1/10.
         return
         END
 * *****************************
 c       real*4 function xrho(srt)
       real function xrho(srt)
       SAVE   
 *       xsection for pp-->pp+rho
 * *****************************
        pmass=0.9383
        rmass=0.77
        trho=0.151
        xrho=0.000000001
        if(srt.le.2.67)return
        ESMIN=2.*0.9383+rmass-trho/2.
        ES=srt
 * the cross section for tho0 production is
        xrho0=0.24*(es-esmin)/(1.4+(es-esmin)**2)
        xrho=3.*Xrho0
        return
        end
 * *****************************
 c       real*4 function omega(srt)
       real function omega(srt)
       SAVE   
 *       xsection for pp-->pp+omega
 * *****************************
        pmass=0.9383
        omass=0.782
        tomega=0.0084
        omega=0.00000001
        if(srt.le.2.68)return
        ESMIN=2.*0.9383+omass-tomega/2.
        es=srt
        omega=0.36*(es-esmin)/(1.25+(es-esmin)**2)
        return
        end
 ******************************************
 * for ppi(+)-->DELTA+pi
 c      real*4 function TWOPI(srt)
       real function TWOPI(srt)
 *  This function contains the experimental pi+p-->DELTA+PION cross sections   *
 *  srt    = DSQRT(s) in GeV                                                   *
 *  xsec   = production cross section in mb                                    *
 *  earray = EXPerimental table with proton energies in MeV                    *
 *  xarray = EXPerimental table with cross sections in mb (curve to guide eye) *
 *                                                                             *
 ******************************************
 c      real*4   xarray(19), earray(19)
       real   xarray(19), earray(19)
       SAVE   
       data xarray /0.300E-05,0.187E+01,0.110E+02,0.149E+02,0.935E+01,
      &0.765E+01,0.462E+01,0.345E+01,0.241E+01,0.185E+01,0.165E+01,
      &0.150E+01,0.132E+01,0.117E+01,0.116E+01,0.100E+01,0.856E+00,
      &0.745E+00,0.300E-05/
       data earray /0.122E+01, 0.147E+01, 0.172E+01, 0.197E+01,
      &0.222E+01, 0.247E+01, 0.272E+01, 0.297E+01, 0.322E+01,
      &0.347E+01, 0.372E+01, 0.397E+01, 0.422E+01, 0.447E+01,
      &0.472E+01, 0.497E+01, 0.522E+01, 0.547E+01, 0.572E+01/
 
            pmass=0.14 
        pmass1=0.938
        TWOPI=0.000001
        if(srt.le.1.22)return
 * 1.Calculate p(lab)  from srt [GeV]
 *   Formula used:   DSQRT(s) = 2 m DSQRT(E_kin/(2m) + 1)
         plab=SRT
       if (plab .lt. earray(1)) then
         TWOPI= 0.00001
         return
       end if
 *
 * 2.Interpolate double logarithmically to find sigma(srt)
 *
       do 1001 ie = 1,19
         if (earray(ie) .eq. plab) then
           TWOPI= xarray(ie)
           return
         else if (earray(ie) .gt. plab) then
           ymin = alog(xarray(ie-1))
           ymax = alog(xarray(ie))
           xmin = alog(earray(ie-1))
           xmax = alog(earray(ie))
           TWOPI= exp(ymin + (alog(plab)-xmin)*(ymax-ymin)
      &    /(xmax-xmin) )
           return
         end if
  1001   continue
       return
         END
 ******************************************
 ******************************************
 * for ppi(+)-->DELTA+RHO
 c      real*4 function THREPI(srt)
       real function THREPI(srt)
 *  This function contains the experimental pi+p-->DELTA + rho cross sections  *
 *  srt    = DSQRT(s) in GeV                                                   *
 *  xsec   = production cross section in mb                                    *
 *  earray = EXPerimental table with proton energies in MeV                    *
 *  xarray = EXPerimental table with cross sections in mb (curve to guide eye) *
 *                                                                             *
 ******************************************
 c      real*4   xarray(15), earray(15)
       real   xarray(15), earray(15)
       SAVE   
       data xarray /8.0000000E-06,6.1999999E-05,1.881940,5.025690,    
      &11.80154,13.92114,15.07308,11.79571,11.53772,10.01197,9.792673,    
      &9.465264,8.970490,7.944254,6.886320/    
       data earray /0.122E+01, 0.147E+01, 0.172E+01, 0.197E+01,
      &0.222E+01, 0.247E+01, 0.272E+01, 0.297E+01, 0.322E+01,
      &0.347E+01, 0.372E+01, 0.397E+01, 0.422E+01, 0.447E+01,
      &0.472E+01/
 
            pmass=0.14 
        pmass1=0.938
        THREPI=0.000001
        if(srt.le.1.36)return
 * 1.Calculate p(lab)  from srt [GeV]
 *   Formula used:   DSQRT(s) = 2 m DSQRT(E_kin/(2m) + 1)
         plab=SRT
       if (plab .lt. earray(1)) then
         THREPI = 0.00001
         return
       end if
 *
 * 2.Interpolate double logarithmically to find sigma(srt)
 *
       do 1001 ie = 1,15
         if (earray(ie) .eq. plab) then
           THREPI= xarray(ie)
           return
         else if (earray(ie) .gt. plab) then
           ymin = alog(xarray(ie-1))
           ymax = alog(xarray(ie))
           xmin = alog(earray(ie-1))
           xmax = alog(earray(ie))
           THREPI = exp(ymin + (alog(plab)-xmin)*(ymax-ymin)
      &    /(xmax-xmin) )
           return
         end if
  1001   continue
       return
         END
 ******************************************
 ******************************************
 * for ppi(+)-->DELTA+omega
 c      real*4 function FOURPI(srt)
       real function FOURPI(srt)
 *  This function contains the experimental pi+p-->DELTA+PION cross sections   *
 *  srt    = DSQRT(s) in GeV                                                   *
 *  xsec   = production cross section in mb                                    *
 *  earray = EXPerimental table with proton energies in MeV                    *
 *  xarray = EXPerimental table with cross sections in mb (curve to guide eye) *
 *                                                                             *
 ******************************************
 c      real*4   xarray(10), earray(10)
       real   xarray(10), earray(10)
       SAVE   
       data xarray /0.0001,1.986597,6.411932,7.636956,    
      &9.598362,9.889740,10.24317,10.80138,11.86988,12.83925/    
       data earray /2.468,2.718,2.968,0.322E+01,
      &0.347E+01, 0.372E+01, 0.397E+01, 0.422E+01, 0.447E+01,
      &0.472E+01/
 
            pmass=0.14 
        pmass1=0.938
        FOURPI=0.000001
        if(srt.le.1.52)return
 * 1.Calculate p(lab)  from srt [GeV]
 *   Formula used:   DSQRT(s) = 2 m DSQRT(E_kin/(2m) + 1)
         plab=SRT
       if (plab .lt. earray(1)) then
         FOURPI= 0.00001
         return
       end if
 *
 * 2.Interpolate double logarithmically to find sigma(srt)
 *
       do 1001 ie = 1,10
         if (earray(ie) .eq. plab) then
           FOURPI= xarray(ie)
           return
         else if (earray(ie) .gt. plab) then
           ymin = alog(xarray(ie-1))
           ymax = alog(xarray(ie))
           xmin = alog(earray(ie-1))
           xmax = alog(earray(ie))
           FOURPI= exp(ymin + (alog(plab)-xmin)*(ymax-ymin)
      &    /(xmax-xmin) )
           return
         end if
  1001   continue
       return
         END
 ******************************************
 ******************************************
 * for pion (rho or omega)+baryon resonance collisions
 c      real*4 function reab(i1,i2,srt,ictrl)
       real function reab(i1,i2,srt,ictrl)
 *  This function calculates the cross section for 
 *  pi+Delta(N*)-->N+PION process                                              *
 *  srt    = DSQRT(s) in GeV                                                   *
 *  reab   = cross section in fm**2                                            *
 *  ictrl=1,2,3 for pion, rho and omega+D(N*)    
 ****************************************
       PARAMETER (MAXSTR=150001,MAXR=1,PI=3.1415926)
       parameter      (MX=4,MY=4,MZ=8,MPX=4,MPY=4,mpz=10,mpzp=10)
       PARAMETER      (AKA=0.498,ALA=1.1157,ASA=1.1974)
       parameter      (amn=0.938,ap1=0.14,arho=0.77,aomega=0.782)
        parameter       (maxx=20,maxz=24)
       COMMON   /AA/  R(3,MAXSTR)
 cc      SAVE /AA/
       COMMON   /BB/  P(3,MAXSTR)
 cc      SAVE /BB/
       COMMON   /CC/  E(MAXSTR)
 cc      SAVE /CC/
       COMMON  /DD/      RHO(-MAXX:MAXX,-MAXX:MAXX,-MAXZ:MAXZ),
      &                     RHOP(-MAXX:MAXX,-MAXX:MAXX,-MAXZ:MAXZ),
      &                     RHON(-MAXX:MAXX,-MAXX:MAXX,-MAXZ:MAXZ)
 cc      SAVE /DD/
       COMMON  /EE/      ID(MAXSTR),LB(MAXSTR)
 cc      SAVE /EE/
       SAVE   
        LB1=LB(I1)
        LB2=LB(I2)
        reab=0
        if(ictrl.eq.1.and.srt.le.(amn+2.*ap1+0.02))return
        if(ictrl.eq.3.and.srt.le.(amn+ap1+aomega+0.02))return
        pin2=((srt**2+ap1**2-amn**2)/(2.*srt))**2-ap1**2
        if(pin2.le.0)return
 * for pion+D(N*)-->pion+N
        if(ictrl.eq.1)then
        if(e(i1).gt.1)then 
        ed=e(i1)       
        else
        ed=e(i2)
        endif       
        pout2=((srt**2+ap1**2-ed**2)/(2.*srt))**2-ap1**2
        if(pout2.le.0)return
        xpro=twopi(srt)/10.
        factor=1/3.
        if( ((lb1.eq.8.and.lb2.eq.5).or.
      &    (lb1.eq.5.and.lb2.eq.8))
      &        .OR.((lb1.eq.-8.and.lb2.eq.3).or.
      &    (lb1.eq.3.and.lb2.eq.-8)) )factor=1/4.
        if((iabs(lb1).ge.10.and.iabs(lb1).le.13).
      &  or.(iabs(lb2).ge.10.and.iabs(lb2).le.13))factor=1.
        reab=factor*pin2/pout2*xpro
        return
        endif
 * for rho reabsorption
        if(ictrl.eq.2)then
        if(lb(i2).ge.25)then 
        ed=e(i1)
        arho1=e(i2)       
        else
        ed=e(i2)
        arho1=e(i1)
        endif       
        if(srt.le.(amn+ap1+arho1+0.02))return
        pout2=((srt**2+arho1**2-ed**2)/(2.*srt))**2-arho1**2
        if(pout2.le.0)return
        xpro=threpi(srt)/10.
        factor=1/3.
        if( ((lb1.eq.8.and.lb2.eq.27).or.
      &       (lb1.eq.27.and.lb2.eq.8))
      & .OR. ((lb1.eq.-8.and.lb2.eq.25).or.
      &       (lb1.eq.25.and.lb2.eq.-8)) )factor=1/4.
        if((iabs(lb1).ge.10.and.iabs(lb1).le.13).
      &  or.(iabs(lb2).ge.10.and.iabs(lb2).le.13))factor=1.
        reab=factor*pin2/pout2*xpro
        return
        endif
 * for omega reabsorption
        if(ictrl.eq.3)then
        if(e(i1).gt.1)ed=e(i1)       
        if(e(i2).gt.1)ed=e(i2)       
        pout2=((srt**2+aomega**2-ed**2)/(2.*srt))**2-aomega**2
        if(pout2.le.0)return
        xpro=fourpi(srt)/10.
        factor=1/6.
        if((iabs(lb1).ge.10.and.iabs(lb1).le.13).
      &  or.(iabs(lb2).ge.10.and.iabs(lb2).le.13))factor=1./3.
        reab=factor*pin2/pout2*xpro
        endif
       return
         END
 ******************************************
 * for the reabsorption of two resonances
 * This function calculates the cross section for 
 * DD-->NN, N*N*-->NN and DN*-->NN
 c      real*4 function reab2d(i1,i2,srt)
       real function reab2d(i1,i2,srt)
 *  srt    = DSQRT(s) in GeV                                                   *
 *  reab   = cross section in mb
 ****************************************
       PARAMETER      (MAXSTR=150001,MAXR=1,PI=3.1415926)
       parameter      (MX=4,MY=4,MZ=8,MPX=4,MPY=4,mpz=10,mpzp=10)
       PARAMETER      (AKA=0.498,ALA=1.1157,ASA=1.1974)
       parameter      (amn=0.938,ap1=0.14,arho=0.77,aomega=0.782)
        parameter       (maxx=20,maxz=24)
       COMMON   /AA/  R(3,MAXSTR)
 cc      SAVE /AA/
       COMMON   /BB/  P(3,MAXSTR)
 cc      SAVE /BB/
       COMMON   /CC/  E(MAXSTR)
 cc      SAVE /CC/
       COMMON  /DD/      RHO(-MAXX:MAXX,-MAXX:MAXX,-MAXZ:MAXZ),
      &                     RHOP(-MAXX:MAXX,-MAXX:MAXX,-MAXZ:MAXZ),
      &                     RHON(-MAXX:MAXX,-MAXX:MAXX,-MAXZ:MAXZ)
 cc      SAVE /DD/
       COMMON  /EE/      ID(MAXSTR),LB(MAXSTR)
 cc      SAVE /EE/
       SAVE   
        reab2d=0
        LB1=iabs(LB(I1))
        LB2=iabs(LB(I2))
        ed1=e(i1)       
        ed2=e(i2)       
        pin2=(srt/2.)**2-amn**2
        pout2=((srt**2+ed1**2-ed2**2)/(2.*srt))**2-ed1**2
        if(pout2.le.0)return
        xpro=x2pi(srt)
        factor=1/4.
        if((lb1.ge.10.and.lb1.le.13).and.
      &    (lb2.ge.10.and.lb2.le.13))factor=1.
        if((lb1.ge.6.and.lb1.le.9).and.
      &    (lb2.gt.10.and.lb2.le.13))factor=1/2.
        if((lb2.ge.6.and.lb2.le.9).and.
      &    (lb1.gt.10.and.lb1.le.13))factor=1/2.
        reab2d=factor*pin2/pout2*xpro
        return
        end
 ***************************************
       SUBROUTINE rotate(PX0,PY0,PZ0,px,py,pz)
       SAVE   
 * purpose: rotate the momentum of a particle in the CMS of p1+p2 such that 
 * the x' y' and z' in the cms of p1+p2 is the same as the fixed x y and z
 * quantities:
 *            px0,py0 and pz0 are the cms momentum of the incoming colliding
 *            particles
 *            px, py and pz are the cms momentum of any one of the particles 
 *            after the collision to be rotated
 ***************************************
 * the momentum, polar and azimuthal angles of the incoming momentm
       PR0  = SQRT( PX0**2 + PY0**2 + PZ0**2 )
       IF(PR0.EQ.0)PR0=0.00000001
       C2  = PZ0 / PR0
       IF(PX0 .EQ. 0.0 .AND. PY0 .EQ. 0.0) THEN
         T2 = 0.0
       ELSE
         T2=ATAN2(PY0,PX0)
       END IF
 
 clin-9/2012: check argument in sqrt():
       scheck=1.0 - C2**2
       if(scheck.lt.0) then
          write(99,*) 'scheck45: ', scheck
          scheck=0.
       endif
       S2=sqrt(scheck)
 c      S2  =  SQRT( 1.0 - C2**2 )
 
       CT2  = COS(T2)
       ST2  = SIN(T2)
 * the momentum, polar and azimuthal angles of the momentum to be rotated
       PR=SQRT(PX**2+PY**2+PZ**2)
       IF(PR.EQ.0)PR=0.0000001
       C1=PZ/PR
       IF(PX.EQ.0.AND.PY.EQ.0)THEN
       T1=0.
       ELSE
       T1=ATAN2(PY,PX)
       ENDIF
 
 clin-9/2012: check argument in sqrt():
       scheck=1.0 - C1**2
       if(scheck.lt.0) then
          write(99,*) 'scheck46: ', scheck
          scheck=0.
       endif
       S1=sqrt(scheck)
 c      S1   = SQRT( 1.0 - C1**2 )
 
       CT1  = COS(T1)
       ST1  = SIN(T1)
       SS   = C2 * S1 * CT1  +  S2 * C1
 * THE MOMENTUM AFTER ROTATION
       PX   = PR * ( SS*CT2 - S1*ST1*ST2 )
       PY   = PR * ( SS*ST2 + S1*ST1*CT2 )
       PZ   = PR * ( C1*C2 - S1*S2*CT1 )
       RETURN
       END
 ******************************************
 c      real*4 function Xpp(srt)
       real function Xpp(srt)
 *  This function contains the experimental total n-p cross sections           *
 *  srt    = DSQRT(s) in GeV                                                   *
 *  xsec   = production cross section in mb                                    *
 *  earray = EXPerimental table with proton energies in MeV                    *
 *  xarray = EXPerimental table with cross sections in mb (curve to guide eye) *
 *  WITH A CUTOFF AT 55MB                                                      *
 ******************************************
 c      real*4   xarray(14), earray(14)
       real   xarray(14), earray(14)
       SAVE   
       data earray /20.,30.,40.,60.,80.,100.,
      &170.,250.,310.,
      &350.,460.,560.,660.,800./
       data xarray /150.,90.,80.6,48.0,36.6,
      &31.6,25.9,24.0,23.1,
      &24.0,28.3,33.6,41.5,47/
 
        xpp=0.
        pmass=0.9383 
 * 1.Calculate E_kin(lab) [MeV] from srt [GeV]
 *   Formula used:   DSQRT(s) = 2 m DSQRT(E_kin/(2m) + 1)
       ekin = 2000.*pmass*((srt/(2.*pmass))**2 - 1.)
       if (ekin .lt. earray(1)) then
         xpp = xarray(1)
        IF(XPP.GT.55)XPP=55
         return
       end if
        IF(EKIN.GT.EARRAY(14))THEN
        XPP=XARRAY(14)
        RETURN
        ENDIF
 *
 *
 * 2.Interpolate double logarithmically to find sigma(srt)
 *
       do 1001 ie = 1,14
         if (earray(ie) .eq. ekin) then
           xPP= xarray(ie)
        if(xpp.gt.55)xpp=55.
           return
        endif
         if (earray(ie) .gt. ekin) then
           ymin = alog(xarray(ie-1))
           ymax = alog(xarray(ie))
           xmin = alog(earray(ie-1))
           xmax = alog(earray(ie))
           XPP = exp(ymin + (alog(ekin)-xmin)
      &          *(ymax-ymin)/(xmax-xmin) )
        IF(XPP.GT.55)XPP=55.
        go to 50
         end if
  1001 continue
 50       continue
         return
         END
 ******************************************
       real function Xnp(srt)
 *  This function contains the experimental total n-p cross sections           *
 *  srt    = DSQRT(s) in GeV                                                   *
 *  xsec   = production cross section in mb                                    *
 *  earray = EXPerimental table with proton energies in MeV                    *
 *  xarray = EXPerimental table with cross sections in mb (curve to guide eye) *
 *  WITH  A CUTOFF AT 55MB                                                *
 ******************************************
 c      real*4   xarray(11), earray(11)
       real   xarray(11), earray(11)
       SAVE   
       data   earray /20.,30.,40.,60.,90.,135.0,200.,
      &300.,400.,600.,800./
       data  xarray / 410.,270.,214.5,130.,78.,53.5,
      &41.6,35.9,34.2,34.3,34.9/
 
        xnp=0.
        pmass=0.9383
 * 1.Calculate E_kin(lab) [MeV] from srt [GeV]
 *   Formula used:   DSQRT(s) = 2 m DSQRT(E_kin/(2m) + 1)
       ekin = 2000.*pmass*((srt/(2.*pmass))**2 - 1.)
       if (ekin .lt. earray(1)) then
         xnp = xarray(1)
        IF(XNP.GT.55)XNP=55
         return
       end if
        IF(EKIN.GT.EARRAY(11))THEN
        XNP=XARRAY(11)
        RETURN
        ENDIF
 *
 *Interpolate double logarithmically to find sigma(srt)
 *
       do 1001 ie = 1,11
         if (earray(ie) .eq. ekin) then
           xNP = xarray(ie)
          if(xnp.gt.55)xnp=55.
           return
        endif
         if (earray(ie) .gt. ekin) then
           ymin = alog(xarray(ie-1))
           ymax = alog(xarray(ie))
           xmin = alog(earray(ie-1))
           xmax = alog(earray(ie))
           xNP = exp(ymin + (alog(ekin)-xmin)
      &          *(ymax-ymin)/(xmax-xmin) )
        IF(XNP.GT.55)XNP=55
        go to 50
         end if
  1001 continue
 50       continue
         return
         END
 *******************************
        function ptr(ptmax,iseed)
 * (2) Generate the transverse momentum
 *     OF nucleons
 *******************************
         COMMON/TABLE/ xarray(0:1000),earray(0:1000)
 cc      SAVE /TABLE/
       COMMON/RNDF77/NSEED
 cc      SAVE /RNDF77/
       SAVE   
        ptr=0.
        if(ptmax.le.1.e-02)then
        ptr=ptmax
        return
        endif
        if(ptmax.gt.2.01)ptmax=2.01
        tryial=ptdis(ptmax)/ptdis(2.01)
        XT=RANART(NSEED)*tryial
 * look up the table and
 *Interpolate double logarithmically to find pt
         do 50 ie = 1,200
         if (earray(ie) .eq. xT) then
           ptr = xarray(ie)
        return
        end if
           if(xarray(ie-1).le.0.00001)go to 50
           if(xarray(ie).le.0.00001)go to 50
           if(earray(ie-1).le.0.00001)go to 50
           if(earray(ie).le.0.00001)go to 50
         if (earray(ie) .gt. xT) then
           ymin = alog(xarray(ie-1))
           ymax = alog(xarray(ie))
           xmin = alog(earray(ie-1))
           xmax = alog(earray(ie))
           ptr= exp(ymin + (alog(xT)-xmin)*(ymax-ymin)
      &    /(xmax-xmin) )
        if(ptr.gt.ptmax)ptr=ptmax
        return
        endif
 50      continue
        return
        end
 
 **********************************
 **********************************
 *                                                                      *
 *                                                                      *
       SUBROUTINE XND(px,py,pz,srt,I1,I2,xinel,
      &               sigk,xsk1,xsk2,xsk3,xsk4,xsk5)
 *     PURPOSE:                                                         *
 *             calculate NUCLEON-BARYON RESONANCE inelatic Xsection     *
 *     NOTE   :                                                         *
 *     QUANTITIES:                                                 *
 *                      CHANNELS. M12 IS THE REVERSAL CHANNEL OF N12    *
 *                      N12,                                            *
 *                      M12=1 FOR p+n-->delta(+)+ n                     *
 *                          2     p+n-->delta(0)+ p                     *
 *                          3     p+p-->delta(++)+n                     *
 *                          4     p+p-->delta(+)+p                      *
 *                          5     n+n-->delta(0)+n                      *
 *                          6     n+n-->delta(-)+p                      *
 *                          7     n+p-->N*(0)(1440)+p                   *
 *                          8     n+p-->N*(+)(1440)+n                   *
 *                        9     p+p-->N*(+)(1535)+p                     *
 *                        10    n+n-->N*(0)(1535)+n                     *
 *                         11    n+p-->N*(+)(1535)+n                     *
 *                        12    n+p-->N*(0)(1535)+p
 *                        13    D(++)+D(-)-->N*(+)(1440)+n
 *                         14    D(++)+D(-)-->N*(0)(1440)+p
 *                        15    D(+)+D(0)--->N*(+)(1440)+n
 *                        16    D(+)+D(0)--->N*(0)(1440)+p
 *                        17    D(++)+D(0)-->N*(+)(1535)+p
 *                        18    D(++)+D(-)-->N*(0)(1535)+p
 *                        19    D(++)+D(-)-->N*(+)(1535)+n
 *                        20    D(+)+D(+)-->N*(+)(1535)+p
 *                        21    D(+)+D(0)-->N*(+)(1535)+n
 *                        22    D(+)+D(0)-->N*(0)(1535)+p
 *                        23    D(+)+D(-)-->N*(0)(1535)+n
 *                        24    D(0)+D(0)-->N*(0)(1535)+n
 *                          25    N*(+)(14)+N*(+)(14)-->N*(+)(15)+p
 *                          26    N*(0)(14)+N*(0)(14)-->N*(0)(15)+n
 *                          27    N*(+)(14)+N*(0)(14)-->N*(+)(15)+n
 *                        28    N*(+)(14)+N*(0)(14)-->N*(0)(15)+p
 *                        29    N*(+)(14)+D+-->N*(+)(15)+p
 *                        30    N*(+)(14)+D0-->N*(+)(15)+n
 *                        31    N*(+)(14)+D(-)-->N*(0)(1535)+n
 *                        32    N*(0)(14)+D++--->N*(+)(15)+p
 *                        33    N*(0)(14)+D+--->N*(+)(15)+n
 *                        34    N*(0)(14)+D+--->N*(0)(15)+p
 *                        35    N*(0)(14)+D0-->N*(0)(15)+n
 *                        36    N*(+)(14)+D0--->N*(0)(15)+p
 *                            and more
 ***********************************
         PARAMETER (MAXSTR=150001,MAXR=1,AMN=0.939457,
      1  AMP=0.93828,AP1=0.13496,AKA=0.498,APHI=1.020,
      2  AP2=0.13957,AM0=1.232,PI=3.1415926,CUTOFF=1.8966,AVMASS=0.9383)
         parameter     (MX=4,MY=4,MZ=8,MPX=4,MPY=4,mpz=10,mpzp=10)
         COMMON /AA/ R(3,MAXSTR)
 cc      SAVE /AA/
         COMMON /BB/ P(3,MAXSTR)
 cc      SAVE /BB/
         COMMON /CC/ E(MAXSTR)
 cc      SAVE /CC/
         COMMON /EE/ ID(MAXSTR),LB(MAXSTR)
 cc      SAVE /EE/
         common /ff/f(-mx:mx,-my:my,-mz:mz,-mpx:mpx,-mpy:mpy,-mpz:mpzp)
 cc      SAVE /ff/
         common /gg/ dx,dy,dz,dpx,dpy,dpz
 cc      SAVE /gg/
         COMMON /INPUT/ NSTAR,NDIRCT,DIR
 cc      SAVE /INPUT/
         COMMON /NN/NNN
 cc      SAVE /NN/
         COMMON /BG/BETAX,BETAY,BETAZ,GAMMA
 cc      SAVE /BG/
         COMMON   /RUN/NUM
 cc      SAVE /RUN/
         COMMON   /PA/RPION(3,MAXSTR,MAXR)
 cc      SAVE /PA/
         COMMON   /PB/PPION(3,MAXSTR,MAXR)
 cc      SAVE /PB/
         COMMON   /PC/EPION(MAXSTR,MAXR)
 cc      SAVE /PC/
         COMMON   /PD/LPION(MAXSTR,MAXR)
 cc      SAVE /PD/
         common/input1/ MASSPR,MASSTA,ISEED,IAVOID,DT
 cc      SAVE /input1/
       SAVE   
 
 *-----------------------------------------------------------------------
        xinel=0.
        sigk=0
        xsk1=0
        xsk2=0
        xsk3=0
        xsk4=0
        xsk5=0
         EM1=E(I1)
         EM2=E(I2)
       PR  = SQRT( PX**2 + PY**2 + PZ**2 )
 *     CAN HAPPEN ANY MORE ==> RETURN (2.04 = 2*AVMASS + PI-MASS+0.02)
         IF (SRT .LT. 2.04) RETURN
 * Resonance absorption or Delta + N-->N*(1440), N*(1535)
 * COM: TEST FOR DELTA OR N* ABSORPTION
 *      IN THE PROCESS DELTA+N-->NN, N*+N-->NN
         PRF=SQRT(0.25*SRT**2-AVMASS**2)
         IF(EM1.GT.1.)THEN
         DELTAM=EM1
         ELSE
         DELTAM=EM2
         ENDIF
         RENOM=DELTAM*PRF**2/DENOM(SRT,1.)/PR
         RENOMN=DELTAM*PRF**2/DENOM(SRT,2.)/PR
         RENOM1=DELTAM*PRF**2/DENOM(SRT,-1.)/PR
 * avoid the inelastic collisions between n+delta- -->N+N 
 *       and p+delta++ -->N+N due to charge conservation,
 *       but they can scatter to produce kaons 
        if((iabs(lb(i1)).eq.2).and.(iabs(lb(i2)).eq.6)) renom=0.
        if((iabs(lb(i2)).eq.2).and.(iabs(lb(i1)).eq.6)) renom=0.
        if((iabs(lb(i1)).eq.1).and.(iabs(lb(i2)).eq.9)) renom=0.
        if((iabs(lb(i2)).eq.1).and.(iabs(lb(i1)).eq.9)) renom=0.
        Call M1535(iabs(lb(i1)),iabs(lb(i2)),srt,x1535)
         X1440=(3./4.)*SIGMA(SRT,2,0,1)
 * CROSS SECTION FOR KAON PRODUCTION from the four channels
 * for NLK channel
        akp=0.498
        ak0=0.498
        ana=0.94
        ada=1.232
        al=1.1157
        as=1.1197
        xsk1=0
        xsk2=0
        xsk3=0
        xsk4=0
 c      !! phi production
        xsk5=0
        t1nlk=ana+al+akp
        if(srt.le.t1nlk)go to 222
        XSK1=1.5*PPLPK(SRT)
 * for DLK channel
        t1dlk=ada+al+akp
        t2dlk=ada+al-akp
        if(srt.le.t1dlk)go to 222
        es=srt
        pmdlk2=(es**2-t1dlk**2)*(es**2-t2dlk**2)/(4.*es**2)
        pmdlk=sqrt(pmdlk2)
        XSK3=1.5*PPLPK(srt)
 * for NSK channel
        t1nsk=ana+as+akp
        t2nsk=ana+as-akp
        if(srt.le.t1nsk)go to 222
        pmnsk2=(es**2-t1nsk**2)*(es**2-t2nsk**2)/(4.*es**2)
        pmnsk=sqrt(pmnsk2)
        XSK2=1.5*(PPK1(srt)+PPK0(srt))
 * for DSK channel
        t1DSk=aDa+aS+akp
        t2DSk=aDa+aS-akp
        if(srt.le.t1dsk)go to 222
        pmDSk2=(es**2-t1DSk**2)*(es**2-t2DSk**2)/(4.*es**2)
        pmDSk=sqrt(pmDSk2)
        XSK4=1.5*(PPK1(srt)+PPK0(srt))
 csp11/21/01
 c phi production
        if(srt.le.(2.*amn+aphi))go to 222
 c  !! mb put the correct form
          xsk5 = 0.0001
 csp11/21/01 end
 
 * THE TOTAL KAON+ PRODUCTION CROSS SECTION IS THEN
 222       SIGK=XSK1+XSK2+XSK3+XSK4
 
 cbz3/7/99 neutralk
         XSK1 = 2.0 * XSK1
         XSK2 = 2.0 * XSK2
         XSK3 = 2.0 * XSK3
         XSK4 = 2.0 * XSK4
         SIGK = 2.0 * SIGK + xsk5
 cbz3/7/99 neutralk end
 
 * avoid the inelastic collisions between n+delta- -->N+N 
 *       and p+delta++ -->N+N due to charge conservation,
 *       but they can scatter to produce kaons 
        if(((iabs(lb(i1)).eq.2).and.(iabs(lb(i2)).eq.6)).OR. 
      &         ((iabs(lb(i2)).eq.2).and.(iabs(lb(i1)).eq.6)).OR.
      &         ((iabs(lb(i1)).eq.1).and.(iabs(lb(i2)).eq.9)).OR.
      &         ((iabs(lb(i2)).eq.1).and.(iabs(lb(i1)).eq.9)))THEN
        xinel=sigk
        return
        ENDIF
 * WE DETERMINE THE REACTION CHANNELS IN THE FOLLOWING
 * FOR n+delta(++)-->p+p or n+delta(++)-->n+N*(+)(1440),n+N*(+)(1535)
 * REABSORPTION OR N*(1535) PRODUCTION LIKE IN P+P OR N*(1440) LIKE PN, 
         IF(LB(I1)*LB(I2).EQ.18.AND.
      &    (iabs(LB(I1)).EQ.2.OR.iabs(LB(I2)).EQ.2))then
         SIGND=SIGMA(SRT,1,1,0)+0.5*SIGMA(SRT,1,1,1)
         SIGDN=0.25*SIGND*RENOM
         xinel=SIGDN+X1440+X1535+SIGK
        RETURN
        endif
 * FOR p+delta(-)-->n+n or p+delta(-)-->n+N*(0)(1440),n+N*(0)(1535)
 * REABSORPTION OR N*(1535) PRODUCTION LIKE IN P+P OR N*(1440) LIKE PN, 
         IF(LB(I1)*LB(I2).EQ.6.AND.
      &    (iabs(LB(I1)).EQ.1.OR.iabs(LB(I2)).EQ.1))THEN
         SIGND=SIGMA(SRT,1,1,0)+0.5*SIGMA(SRT,1,1,1)
         SIGDN=0.25*SIGND*RENOM
         xinel=SIGDN+X1440+X1535+SIGK
        RETURN
        endif
 * FOR p+delta(+)-->p+p, N*(+)(144)+p, N*(+)(1535)+p
 cbz11/25/98
         IF(LB(I1)*LB(I2).EQ.8.AND.
      &    (iabs(LB(I1)).EQ.1.OR.iabs(LB(I2)).EQ.1))THEN
         SIGND=1.5*SIGMA(SRT,1,1,1)
         SIGDN=0.25*SIGND*RENOM
         xinel=SIGDN+x1440+x1535+SIGK
        RETURN
        endif
 * FOR n+delta(0)-->n+n, N*(0)(144)+n, N*(0)(1535)+n
         IF(LB(I1)*LB(I2).EQ.14.AND.
      &   (iabs(LB(I1)).EQ.2.AND.iabs(LB(I2)).EQ.2))THEN
         SIGND=1.5*SIGMA(SRT,1,1,1)
         SIGDN=0.25*SIGND*RENOM
         xinel=SIGDN+x1440+x1535+SIGK
        RETURN
        endif
 * FOR n+delta(+)-->n+p, N*(+)(1440)+n,N*(0)(1440)+p,
 *                       N*(+)(1535)+n,N*(0)(1535)+p
         IF(LB(I1)*LB(I2).EQ.16.AND.
      &     (iabs(LB(I1)).EQ.2.OR.iabs(LB(I2)).EQ.2))THEN
         SIGND=0.5*SIGMA(SRT,1,1,1)+0.25*SIGMA(SRT,1,1,0)
         SIGDN=0.5*SIGND*RENOM
         xinel=SIGDN+2.*x1440+2.*x1535+SIGK
        RETURN
        endif
 * FOR p+delta(0)-->n+p, N*(+)(1440)+n,N*(0)(1440)+p,
 *                       N*(+)(1535)+n,N*(0)(1535)+p
         IF(LB(I1)*LB(I2).EQ.7)THEN
         SIGND=0.5*SIGMA(SRT,1,1,1)+0.25*SIGMA(SRT,1,1,0)
         SIGDN=0.5*SIGND*RENOM
         xinel=SIGDN+2.*x1440+2.*x1535+SIGK
        RETURN
        endif
 * FOR p+N*(0)(14)-->p+n, N*(+)(1535)+n,N*(0)(1535)+p
 * OR  P+N*(0)(14)-->D(+)+N, D(0)+P, 
         IF(LB(I1)*LB(I2).EQ.10.AND.
      &   (iabs(LB(I1)).EQ.1.OR.iabs(LB(I2)).EQ.1))then
         SIGND=(3./4.)*SIGMA(SRT,2,0,1)
         SIGDN=SIGND*RENOMN
         xinel=SIGDN+X1535+SIGK
        RETURN
        endif
 * FOR n+N*(+)-->p+n, N*(+)(1535)+n,N*(0)(1535)+p
         IF(LB(I1)*LB(I2).EQ.22.AND.
      &   (iabs(LB(I1)).EQ.2.OR.iabs(LB(I2)).EQ.2))then
         SIGND=(3./4.)*SIGMA(SRT,2,0,1)
         SIGDN=SIGND*RENOMN
         xinel=SIGDN+X1535+SIGK
        RETURN
        endif
 * FOR N*(1535)+N-->N+N COLLISIONS
         IF((iabs(LB(I1)).EQ.12).OR.(iabs(LB(I1)).EQ.13).OR.
      1  (iabs(LB(I2)).EQ.12).OR.(iabs(LB(I2)).EQ.13))THEN
         SIGND=X1535
         SIGDN=SIGND*RENOM1
         xinel=SIGDN+SIGK
        RETURN
        endif
         RETURN
        end
 **********************************
 *                                                                      *
 *                                                                      *
       SUBROUTINE XDDIN(PX,PY,PZ,SRT,I1,I2,
      &XINEL,SIGK,XSK1,XSK2,XSK3,XSK4,XSK5)
 *     PURPOSE:                                                         *
 *             DEALING WITH BARYON RESONANCE-BARYON RESONANCE COLLISIONS*
 *     NOTE   :                                                         *
 *           VALID ONLY FOR BARYON-BARYON-DISTANCES LESS THAN 1.32 FM   *
 *           (1.32 = 2 * HARD-CORE-RADIUS [HRC] )                       *
 *     QUANTITIES:                                                 *
 *           PX,PY,PZ - MOMENTUM COORDINATES OF ONE PARTICLE IN CM FRAME*
 *           SRT      - SQRT OF S                                       *
 *           NSTAR =1 INCLUDING N* RESORANCE,ELSE NOT                   *
 *           NDIRCT=1 INCLUDING DIRECT PION PRODUCTION PROCESS         *
 *           IBLOCK   - THE INFORMATION BACK                            *
 *                      0-> COLLISION CANNOT HAPPEN                     *
 *                      1-> N-N ELASTIC COLLISION                       *
 *                      2-> N+N->N+DELTA,OR N+N->N+N* REACTION          *
 *                      3-> N+DELTA->N+N OR N+N*->N+N REACTION          *
 *                      4-> N+N->N+N+PION,DIRTCT PROCESS                *
 *                     5-> DELTA(N*)+DELTA(N*)   TOTAL   COLLISIONS    *
 *           N12       - IS USED TO SPECIFY BARYON-BARYON REACTION      *
 *                      CHANNELS. M12 IS THE REVERSAL CHANNEL OF N12    *
 *                      N12,                                            *
 *                      M12=1 FOR p+n-->delta(+)+ n                     *
 *                          2     p+n-->delta(0)+ p                     *
 *                          3     p+p-->delta(++)+n                     *
 *                          4     p+p-->delta(+)+p                      *
 *                          5     n+n-->delta(0)+n                      *
 *                          6     n+n-->delta(-)+p                      *
 *                          7     n+p-->N*(0)(1440)+p                   *
 *                          8     n+p-->N*(+)(1440)+n                   *
 *                        9     p+p-->N*(+)(1535)+p                     *
 *                        10    n+n-->N*(0)(1535)+n                     *
 *                         11    n+p-->N*(+)(1535)+n                     *
 *                        12    n+p-->N*(0)(1535)+p
 *                        13    D(++)+D(-)-->N*(+)(1440)+n
 *                         14    D(++)+D(-)-->N*(0)(1440)+p
 *                        15    D(+)+D(0)--->N*(+)(1440)+n
 *                        16    D(+)+D(0)--->N*(0)(1440)+p
 *                        17    D(++)+D(0)-->N*(+)(1535)+p
 *                        18    D(++)+D(-)-->N*(0)(1535)+p
 *                        19    D(++)+D(-)-->N*(+)(1535)+n
 *                        20    D(+)+D(+)-->N*(+)(1535)+p
 *                        21    D(+)+D(0)-->N*(+)(1535)+n
 *                        22    D(+)+D(0)-->N*(0)(1535)+p
 *                        23    D(+)+D(-)-->N*(0)(1535)+n
 *                        24    D(0)+D(0)-->N*(0)(1535)+n
 *                          25    N*(+)(14)+N*(+)(14)-->N*(+)(15)+p
 *                          26    N*(0)(14)+N*(0)(14)-->N*(0)(15)+n
 *                          27    N*(+)(14)+N*(0)(14)-->N*(+)(15)+n
 *                        28    N*(+)(14)+N*(0)(14)-->N*(0)(15)+p
 *                        29    N*(+)(14)+D+-->N*(+)(15)+p
 *                        30    N*(+)(14)+D0-->N*(+)(15)+n
 *                        31    N*(+)(14)+D(-)-->N*(0)(1535)+n
 *                        32    N*(0)(14)+D++--->N*(+)(15)+p
 *                        33    N*(0)(14)+D+--->N*(+)(15)+n
 *                        34    N*(0)(14)+D+--->N*(0)(15)+p
 *                        35    N*(0)(14)+D0-->N*(0)(15)+n
 *                        36    N*(+)(14)+D0--->N*(0)(15)+p
 *                        +++
 *               AND MORE CHANNELS AS LISTED IN THE NOTE BOOK      
 *
 * NOTE ABOUT N*(1440) RESORANCE:                                       *
 *     As it has been discussed in VerWest's paper,I= 1 (initial isospin)
 *     channel can all be attributed to delta resorance while I= 0      *
 *     channel can all be  attribured to N* resorance.Only in n+p       *
 *     one can have I=0 channel so is the N*(1440) resorance            *
 * REFERENCES:    J. CUGNON ET AL., NUCL. PHYS. A352, 505 (1981)        *
 *                    Y. KITAZOE ET AL., PHYS. LETT. 166B, 35 (1986)    *
 *                    B. VerWest el al., PHYS. PRV. C25 (1982)1979      *
 *                    Gy. Wolf  et al, Nucl Phys A517 (1990) 615        *
 *                    CUTOFF = 2 * AVMASS + 20 MEV                      *
 *                                                                      *
 *       for N*(1535) we use the parameterization by Gy. Wolf et al     *
 *       Nucl phys A552 (1993) 349, added May 18, 1994                  *
 **********************************
         PARAMETER (MAXSTR=150001,MAXR=1,AMN=0.939457,
      1  AMP=0.93828,AP1=0.13496,AKA=0.498,APHI=1.020,
      2  AP2=0.13957,AM0=1.232,PI=3.1415926,CUTOFF=1.8966,AVMASS=0.9383)
         parameter     (MX=4,MY=4,MZ=8,MPX=4,MPY=4,mpz=10,mpzp=10)
         COMMON /AA/ R(3,MAXSTR)
 cc      SAVE /AA/
         COMMON /BB/ P(3,MAXSTR)
 cc      SAVE /BB/
         COMMON /CC/ E(MAXSTR)
 cc      SAVE /CC/
         COMMON /EE/ ID(MAXSTR),LB(MAXSTR)
 cc      SAVE /EE/
         common /ff/f(-mx:mx,-my:my,-mz:mz,-mpx:mpx,-mpy:mpy,-mpz:mpzp)
 cc      SAVE /ff/
         common /gg/ dx,dy,dz,dpx,dpy,dpz
 cc      SAVE /gg/
         COMMON /INPUT/ NSTAR,NDIRCT,DIR
 cc      SAVE /INPUT/
         COMMON /NN/NNN
 cc      SAVE /NN/
         COMMON /BG/BETAX,BETAY,BETAZ,GAMMA
 cc      SAVE /BG/
         COMMON   /RUN/NUM
 cc      SAVE /RUN/
         COMMON   /PA/RPION(3,MAXSTR,MAXR)
 cc      SAVE /PA/
         COMMON   /PB/PPION(3,MAXSTR,MAXR)
 cc      SAVE /PB/
         COMMON   /PC/EPION(MAXSTR,MAXR)
 cc      SAVE /PC/
         COMMON   /PD/LPION(MAXSTR,MAXR)
 cc      SAVE /PD/
         common/input1/ MASSPR,MASSTA,ISEED,IAVOID,DT
 cc      SAVE /input1/
       SAVE   
 *-----------------------------------------------------------------------
        XINEL=0
        SIGK=0
        XSK1=0
        XSK2=0
        XSK3=0
        XSK4=0
        XSK5=0
         EM1=E(I1)
         EM2=E(I2)
       PR  = SQRT( PX**2 + PY**2 + PZ**2 )
 *     IF THERE WERE 2 N*(1535) AND THEY DIDN'T SCATT. ELAST., 
 *     ALLOW THEM TO PRODUCE KAONS. NO OTHER INELASTIC CHANNELS
 *     ARE KNOWN
 C       if((lb(i1).ge.12).and.(lb(i2).ge.12))return
 *     ALL the inelastic collisions between N*(1535) and Delta as well
 *     as N*(1440) TO PRODUCE KAONS, NO OTHER CHANNELS ARE KNOWN
 C       if((lb(i1).ge.12).and.(lb(i2).ge.3))return
 C       if((lb(i2).ge.12).and.(lb(i1).ge.3))return
 *     calculate the N*(1535) production cross section in I1+I2 collisions
        call N1535(iabs(lb(i1)),iabs(lb(i2)),srt,X1535)
 c
 * for Delta+Delta-->N*(1440 OR 1535)+N AND N*(1440)+N*(1440)-->N*(1535)+X 
 *     AND DELTA+N*(1440)-->N*(1535)+X
 * WE ASSUME THEY HAVE THE SAME CROSS SECTIONS as CORRESPONDING N+N COLLISION):
 * FOR D++D0, D+D+,D+D-,D0D0,N*+N*+,N*0N*0,N*(+)D+,N*(+)D(-),N*(0)D(0)
 * N*(1535) production, kaon production and reabsorption through 
 * D(N*)+D(N*)-->NN are ALLOWED.
 * CROSS SECTION FOR KAON PRODUCTION from the four channels are
 * for NLK channel
        akp=0.498
        ak0=0.498
        ana=0.94
        ada=1.232
        al=1.1157
        as=1.1197
        xsk1=0
        xsk2=0
        xsk3=0
        xsk4=0
        t1nlk=ana+al+akp
        if(srt.le.t1nlk)go to 222
        XSK1=1.5*PPLPK(SRT)
 * for DLK channel
        t1dlk=ada+al+akp
        t2dlk=ada+al-akp
        if(srt.le.t1dlk)go to 222
        es=srt
        pmdlk2=(es**2-t1dlk**2)*(es**2-t2dlk**2)/(4.*es**2)
        pmdlk=sqrt(pmdlk2)
        XSK3=1.5*PPLPK(srt)
 * for NSK channel
        t1nsk=ana+as+akp
        t2nsk=ana+as-akp
        if(srt.le.t1nsk)go to 222
        pmnsk2=(es**2-t1nsk**2)*(es**2-t2nsk**2)/(4.*es**2)
        pmnsk=sqrt(pmnsk2)
        XSK2=1.5*(PPK1(srt)+PPK0(srt))
 * for DSK channel
        t1DSk=aDa+aS+akp
        t2DSk=aDa+aS-akp
        if(srt.le.t1dsk)go to 222
        pmDSk2=(es**2-t1DSk**2)*(es**2-t2DSk**2)/(4.*es**2)
        pmDSk=sqrt(pmDSk2)
        XSK4=1.5*(PPK1(srt)+PPK0(srt))
 csp11/21/01
 c phi production
        if(srt.le.(2.*amn+aphi))go to 222
 c  !! mb put the correct form
          xsk5 = 0.0001
 csp11/21/01 end
 * THE TOTAL KAON+ PRODUCTION CROSS SECTION IS THEN
 222       SIGK=XSK1+XSK2+XSK3+XSK4
 
 cbz3/7/99 neutralk
         XSK1 = 2.0 * XSK1
         XSK2 = 2.0 * XSK2
         XSK3 = 2.0 * XSK3
         XSK4 = 2.0 * XSK4
         SIGK = 2.0 * SIGK + xsk5
 cbz3/7/99 neutralk end
 
         IDD=iabs(LB(I1)*LB(I2))
 * The reabsorption cross section for the process
 * D(N*)D(N*)-->NN is
        s2d=reab2d(i1,i2,srt)
 
 cbz3/16/99 pion
         S2D = 0.
 cbz3/16/99 pion end
 
 *(1) N*(1535)+D(N*(1440)) reactions
 *    we allow kaon production and reabsorption only
        if(((iabs(lb(i1)).ge.12).and.(iabs(lb(i2)).ge.12)).OR.
      &       ((iabs(lb(i1)).ge.12).and.(iabs(lb(i2)).ge.6)).OR.
      &       ((iabs(lb(i2)).ge.12).and.(iabs(lb(i1)).ge.6)))THEN
        XINEL=sigk+s2d
        RETURN
        ENDIF
 * channels have the same charge as pp 
         IF((IDD.EQ.63).OR.(IDD.EQ.64).OR.(IDD.EQ.48).
      1  OR.(IDD.EQ.49).OR.(IDD.EQ.11*11).OR.(IDD.EQ.10*10).
      2  OR.(IDD.EQ.88).OR.(IDD.EQ.66).
      3  OR.(IDD.EQ.90).OR.(IDD.EQ.70))THEN
         XINEL=X1535+SIGK+s2d
        RETURN
         ENDIF
 * IN DELTA+N*(1440) and N*(1440)+N*(1440) COLLISIONS, 
 * N*(1535), kaon production and reabsorption are ALLOWED
 * IN N*(1440)+N*(1440) COLLISIONS, ONLY N*(1535) IS ALLOWED
        IF((IDD.EQ.110).OR.(IDD.EQ.77).OR.(IDD.EQ.80))THEN
        XINEL=X1535+SIGK+s2d
        RETURN
        ENDIF       
        IF((IDD.EQ.54).OR.(IDD.EQ.56))THEN
 * LIKE FOR N+P COLLISION, 
 * IN DELTA+DELTA COLLISIONS BOTH N*(1440) AND N*(1535) CAN BE PRODUCED
         SIG2=(3./4.)*SIGMA(SRT,2,0,1)
         XINEL=2.*(SIG2+X1535)+SIGK+s2d
        RETURN
        ENDIF
        RETURN
        END
 ******************************************
       real function dirct1(srt)
 *  This function contains the experimental, direct pion(+) + p cross sections *
 *  srt    = DSQRT(s) in GeV                                                   *
 *  dirct1  = cross section in fm**2                                     *
 *  earray = EXPerimental table with the srt            
 *  xarray = EXPerimental table with cross sections in mb (curve to guide eye) *
 ******************************************
 c      real*4   xarray(122), earray(122)
       real   xarray(122), earray(122)
       SAVE   
       data   earray /
      &1.568300,1.578300,1.588300,1.598300,1.608300,1.618300,1.628300,    
      &1.638300,1.648300,1.658300,1.668300,1.678300,1.688300,1.698300,    
      &1.708300,1.718300,1.728300,1.738300,1.748300,1.758300,1.768300,    
      &1.778300,1.788300,1.798300,1.808300,1.818300,1.828300,1.838300,    
      &1.848300,1.858300,1.868300,1.878300,1.888300,1.898300,1.908300,    
      &1.918300,1.928300,1.938300,1.948300,1.958300,1.968300,1.978300,    
      &1.988300,1.998300,2.008300,2.018300,2.028300,2.038300,2.048300,    
      &2.058300,2.068300,2.078300,2.088300,2.098300,2.108300,2.118300,    
      &2.128300,2.138300,2.148300,2.158300,2.168300,2.178300,2.188300,    
      &2.198300,2.208300,2.218300,2.228300,2.238300,2.248300,2.258300,    
      &2.268300,2.278300,2.288300,2.298300,2.308300,2.318300,2.328300,    
      &2.338300,2.348300,2.358300,2.368300,2.378300,2.388300,2.398300,    
      &2.408300,2.418300,2.428300,2.438300,2.448300,2.458300,2.468300,    
      &2.478300,2.488300,2.498300,2.508300,2.518300,2.528300,2.538300,    
      &2.548300,2.558300,2.568300,2.578300,2.588300,2.598300,2.608300,    
      &2.618300,2.628300,2.638300,2.648300,2.658300,2.668300,2.678300,
      &2.688300,2.698300,2.708300,2.718300,2.728300,2.738300,2.748300,    
      &2.758300,2.768300,2.778300/
       data xarray/
      &1.7764091E-02,0.5643668,0.8150568,1.045565,2.133695,3.327922,
      &4.206488,3.471242,4.486876,5.542213,6.800052,7.192446,6.829848,    
      &6.580306,6.868410,8.527946,10.15720,9.716511,9.298335,8.901310,    
      &10.31213,10.52185,11.17630,11.61639,12.05577,12.71596,13.46036,    
      &14.22060,14.65449,14.94775,14.93310,15.32907,16.56481,16.29422,    
      &15.18548,14.12658,13.72544,13.24488,13.31003,14.42680,12.84423,    
      &12.49025,12.14858,11.81870,11.18993,11.35816,11.09447,10.83873,    
      &10.61592,10.53754,9.425521,8.195912,9.661075,9.696192,9.200142,    
      &8.953734,8.715461,8.484999,8.320765,8.255512,8.190969,8.127125,    
      &8.079508,8.073004,8.010611,7.948909,7.887895,7.761005,7.626290,    
      &7.494696,7.366132,7.530178,8.392097,9.046881,8.962544,8.879403,    
      &8.797427,8.716601,8.636904,8.558312,8.404368,8.328978,8.254617,    
      &8.181265,8.108907,8.037527,7.967100,7.897617,7.829057,7.761405,    
      &7.694647,7.628764,7.563742,7.499570,7.387562,7.273281,7.161334,    
      &6.973375,6.529592,6.280323,6.293136,6.305725,6.318097,6.330258,    
      &6.342214,6.353968,6.365528,6.376895,6.388079,6.399081,6.409906,    
      &6.420560,6.431045,6.441367,6.451529,6.461533,6.471386,6.481091,    
      &6.490650,6.476413,6.297259,6.097826/
 
       dirct1=0.
       if (srt .lt. earray(1)) then
         dirct1 = 0.00001
         return
       end if
       if (srt .gt. earray(122)) then
         dirct1 = xarray(122)
        dirct1=dirct1/10.
         return
       end if
 *
 *Interpolate double logarithmically to find xdirct2(srt)
 *
       do 1001 ie = 1,122
         if (earray(ie) .eq. srt) then
           dirct1= xarray(ie)
          dirct1=dirct1/10.
           return
        endif
         if (earray(ie) .gt. srt) then
           ymin = alog(xarray(ie-1))
           ymax = alog(xarray(ie))
           xmin = alog(earray(ie-1))
           xmax = alog(earray(ie))
           dirct1= exp(ymin + (alog(srt)-xmin)
      &          *(ymax-ymin)/(xmax-xmin) )
        dirct1=dirct1/10.
        go to 50
         end if
  1001 continue
 50       continue
         return
         END
 *******************************
 ******************************************
       real function dirct2(srt)
 *  This function contains the experimental, direct pion(-) + p cross sections *
 *  srt    = DSQRT(s) in GeV                                                   *
 *  dirct2 = cross section in fm**2
 *  earray = EXPerimental table with the srt            
 *  xarray = EXPerimental table with cross sections in mb (curve to guide eye) *
 ******************************************
 c      real*4   xarray(122), earray(122)
       real   xarray(122), earray(122)
       SAVE   
       data   earray /
      &1.568300,1.578300,1.588300,1.598300,1.608300,1.618300,1.628300,    
      &1.638300,1.648300,1.658300,1.668300,1.678300,1.688300,1.698300,    
      &1.708300,1.718300,1.728300,1.738300,1.748300,1.758300,1.768300,    
      &1.778300,1.788300,1.798300,1.808300,1.818300,1.828300,1.838300,    
      &1.848300,1.858300,1.868300,1.878300,1.888300,1.898300,1.908300,    
      &1.918300,1.928300,1.938300,1.948300,1.958300,1.968300,1.978300,    
      &1.988300,1.998300,2.008300,2.018300,2.028300,2.038300,2.048300,    
      &2.058300,2.068300,2.078300,2.088300,2.098300,2.108300,2.118300,    
      &2.128300,2.138300,2.148300,2.158300,2.168300,2.178300,2.188300,    
      &2.198300,2.208300,2.218300,2.228300,2.238300,2.248300,2.258300,    
      &2.268300,2.278300,2.288300,2.298300,2.308300,2.318300,2.328300,    
      &2.338300,2.348300,2.358300,2.368300,2.378300,2.388300,2.398300,    
      &2.408300,2.418300,2.428300,2.438300,2.448300,2.458300,2.468300,    
      &2.478300,2.488300,2.498300,2.508300,2.518300,2.528300,2.538300,    
      &2.548300,2.558300,2.568300,2.578300,2.588300,2.598300,2.608300,    
      &2.618300,2.628300,2.638300,2.648300,2.658300,2.668300,2.678300,
      &2.688300,2.698300,2.708300,2.718300,2.728300,2.738300,2.748300,    
      &2.758300,2.768300,2.778300/
       data xarray/0.5773182,1.404156,2.578629,3.832013,4.906011,
      &9.076963,13.10492,10.65975,15.31156,19.77611,19.92874,18.68979,    
      &19.80114,18.39536,14.34269,13.35353,13.58822,14.57031,10.24686,    
      &11.23386,9.764803,10.35652,10.53539,10.07524,9.582198,9.596469,    
      &9.818489,9.012848,9.378012,9.529244,9.529698,8.835624,6.671396,    
      &8.797758,8.133437,7.866227,7.823946,7.808504,7.791755,7.502062,    
      &7.417275,7.592349,7.752028,7.910585,8.068122,8.224736,8.075289,    
      &7.895902,7.721359,7.551512,7.386224,7.225343,7.068739,6.916284,    
      &6.767842,6.623294,6.482520,6.345404,6.211833,7.339510,7.531462,    
      &7.724824,7.919620,7.848021,7.639856,7.571083,7.508881,7.447474,    
      &7.386855,7.327011,7.164454,7.001266,6.842526,6.688094,6.537823,    
      &6.391583,6.249249,6.110689,5.975790,5.894200,5.959503,6.024602,    
      &6.089505,6.154224,6.218760,6.283128,6.347331,6.297411,6.120248,    
      &5.948606,6.494864,6.357106,6.222824,6.091910,5.964267,5.839795,    
      &5.718402,5.599994,5.499146,5.451325,5.404156,5.357625,5.311721,    
      &5.266435,5.301964,5.343963,5.385833,5.427577,5.469200,5.510702,    
      &5.552088,5.593359,5.634520,5.675570,5.716515,5.757356,5.798093,    
      &5.838732,5.879272,5.919717,5.960068,5.980941/
 
       dirct2=0.
       if (srt .lt. earray(1)) then
         dirct2 = 0.00001
         return
       end if
       if (srt .gt. earray(122)) then
         dirct2 = xarray(122)
        dirct2=dirct2/10.
         return
       end if
 *
 *Interpolate double logarithmically to find xdirct2(srt)
 *
       do 1001 ie = 1,122
         if (earray(ie) .eq. srt) then
           dirct2= xarray(ie)
          dirct2=dirct2/10.
           return
        endif
         if (earray(ie) .gt. srt) then
           ymin = alog(xarray(ie-1))
           ymax = alog(xarray(ie))
           xmin = alog(earray(ie-1))
           xmax = alog(earray(ie))
           dirct2= exp(ymin + (alog(srt)-xmin)
      &          *(ymax-ymin)/(xmax-xmin) )
        dirct2=dirct2/10.
        go to 50
         end if
  1001 continue
 50       continue
         return
         END
 *******************************
 ******************************
 * this program calculates the elastic cross section for rho+nucleon
 * through higher resonances
 c       real*4 function ErhoN(em1,em2,lb1,lb2,srt)
        real function ErhoN(em1,em2,lb1,lb2,srt)
 * date : Dec. 19, 1994
 * ****************************
 c       implicit real*4 (a-h,o-z)
       dimension   arrayj(19),arrayl(19),arraym(19),
      &arrayw(19),arrayb(19)
       SAVE   
       data arrayj /0.5,1.5,0.5,0.5,2.5,2.5,1.5,0.5,1.5,3.5,
      &1.5,0.5,1.5,0.5,2.5,0.5,1.5,2.5,3.5/
       data arrayl/1,2,0,0,2,3,2,1,1,3,
      &1,0,2,0,3,1,1,2,3/
       data arraym /1.44,1.52,1.535,1.65,1.675,1.68,1.70,1.71,
      &1.72,1.99,1.60,1.62,1.70,1.90,1.905,1.910,
      &1.86,1.93,1.95/
       data arrayw/0.2,0.125,0.15,0.15,0.155,0.125,0.1,0.11,
      &0.2,0.29,0.25,0.16,0.28,0.15,0.3,0.22,0.25,
      &0.25,0.24/
       data arrayb/0.15,0.20,0.05,0.175,0.025,0.125,0.1,0.20,
      &0.53,0.34,0.05,0.07,0.15,0.45,0.45,0.058,
      &0.08,0.12,0.08/
 
 * the minimum energy for pion+delta collision
        pi=3.1415926
        xs=0
 * include contribution from each resonance
        do 1001 ir=1,19
 cbz11/25/98
        IF(IR.LE.8)THEN
 c       if(lb1*lb2.eq.27.OR.LB1*LB2.EQ.25*2)branch=0.
 c       if(lb1*lb2.eq.26.OR.LB1*LB2.EQ.26*2)branch=1./3.
 c       if(lb1*lb2.eq.27*2.OR.LB1*LB2.EQ.25)branch=2./3.
 c       ELSE
 c       if(lb1*lb2.eq.27.OR.LB1*LB2.EQ.25*2)branch=1.
 c       if(lb1*lb2.eq.26.OR.LB1*LB2.EQ.26*2)branch=2./3.
 c       if(lb1*lb2.eq.27*2.OR.LB1*LB2.EQ.25)branch=1./3.
 c       ENDIF
        if( ((lb1*lb2.eq.27.AND.(LB1.EQ.1.OR.LB2.EQ.1)).OR.
      &     (LB1*LB2.EQ.25*2.AND.(LB1.EQ.2.OR.LB2.EQ.2)))
      &       .OR.((lb1*lb2.eq.-25.AND.(LB1.EQ.-1.OR.LB2.EQ.-1)).OR.
      &     (LB1*LB2.EQ.-27*2.AND.(LB1.EQ.-2.OR.LB2.EQ.-2))) )
      &     branch=0.
         if((iabs(lb1*lb2).eq.26.AND.(iabs(LB1).EQ.1.OR.iabs(LB2).EQ.1))
      &   .OR.(iabs(LB1*LB2).EQ.26*2
      &   .AND.(iabs(LB1).EQ.2.OR.iabs(LB2).EQ.2)))
      &     branch=1./3.
        if( ((lb1*lb2.eq.27*2.AND.(LB1.EQ.2.OR.LB2.EQ.2)).OR.
      &     (LB1*LB2.EQ.25.AND.(LB1.EQ.1.OR.LB2.EQ.1)))
      &  .OR.((lb1*lb2.eq.-25*2.AND.(LB1.EQ.-2.OR.LB2.EQ.-2)).OR.
      &     (LB1*LB2.EQ.-27.AND.(LB1.EQ.-1.OR.LB2.EQ.-1))) )
      &     branch=2./3.
        ELSE
        if( ((lb1*lb2.eq.27.AND.(LB1.EQ.1.OR.LB2.EQ.1)).OR.
      &     (LB1*LB2.EQ.25*2.AND.(LB1.EQ.2.OR.LB2.EQ.2)))
      &       .OR.((lb1*lb2.eq.-25.AND.(LB1.EQ.-1.OR.LB2.EQ.-1)).OR.
      &     (LB1*LB2.EQ.-27*2.AND.(LB1.EQ.-2.OR.LB2.EQ.-2))) )
      &     branch=1.
         if((iabs(lb1*lb2).eq.26.AND.(iabs(LB1).EQ.1.OR.iabs(LB2).EQ.1))
      &   .OR.(iabs(LB1*LB2).EQ.26*2
      &   .AND.(iabs(LB1).EQ.2.OR.iabs(LB2).EQ.2)))
      &     branch=2./3.
        if( ((lb1*lb2.eq.27*2.AND.(LB1.EQ.2.OR.LB2.EQ.2)).OR.
      &     (LB1*LB2.EQ.25.AND.(LB1.EQ.1.OR.LB2.EQ.1)))
      &  .OR.((lb1*lb2.eq.-25*2.AND.(LB1.EQ.-2.OR.LB2.EQ.-2)).OR.
      &     (LB1*LB2.EQ.-27.AND.(LB1.EQ.-1.OR.LB2.EQ.-1))) )
      &     branch=1./3.
        ENDIF
 cbz11/25/98end
        xs0=fdR(arraym(ir),arrayj(ir),arrayl(ir),
      &arrayw(ir),arrayb(ir),srt,EM1,EM2)
        xs=xs+1.3*pi*branch*xs0*(0.1973)**2
  1001 continue
        Erhon=xs
        return
        end
 ***************************8
 *FUNCTION FDE(DMASS) GIVES DELTA MASS DISTRIBUTION BY USING OF
 *KITAZOE'S FORMULA
 c        REAL*4 FUNCTION FDR(DMASS,aj,al,width,widb0,srt,em1,em2)
       REAL FUNCTION FDR(DMASS,aj,al,width,widb0,srt,em1,em2)
       SAVE   
         AMd=em1
         AmP=em2
            Ak02= 0.25*(DMASS**2-amd**2-amp**2)**2
      &           -(Amp*amd)**2
             IF (ak02 .GT. 0.) THEN
               Q0 = SQRT(ak02/DMASS)
             ELSE
               Q0= 0.0
              fdR=0
            return
             END IF
            Ak2= 0.25*(srt**2-amd**2-amp**2)**2
      &           -(Amp*amd)**2
             IF (ak2 .GT. 0.) THEN
               Q = SQRT(ak2/DMASS)
             ELSE
               Q= 0.00
              fdR=0
              return
             END IF
        b=widb0*1.2*dmass/srt*(q/q0)**(2.*al+1)
      &  /(1.+0.2*(q/q0)**(2*al))
         FDR=(2.*aj+1)*WIDTH**2*b/((srt-dmass)**2
      1  +0.25*WIDTH**2)/(6.*q**2)
         RETURN
         END
 ******************************
 * this program calculates the elastic cross section for pion+delta
 * through higher resonances
 c       REAL*4 FUNCTION DIRCT3(SRT)
       REAL FUNCTION DIRCT3(SRT)
 * date : Dec. 19, 1994
 * ****************************
 c     implicit real*4 (a-h,o-z)
       dimension   arrayj(17),arrayl(17),arraym(17),
      &arrayw(17),arrayb(17)
       SAVE   
       data arrayj /1.5,0.5,2.5,2.5,1.5,0.5,1.5,3.5,
      &1.5,0.5,1.5,0.5,2.5,0.5,1.5,2.5,3.5/
       data arrayl/2,0,2,3,2,1,1,3,
      &1,0,2,0,3,1,1,2,3/
       data arraym /1.52,1.65,1.675,1.68,1.70,1.71,
      &1.72,1.99,1.60,1.62,1.70,1.90,1.905,1.910,
      &1.86,1.93,1.95/
       data arrayw/0.125,0.15,0.155,0.125,0.1,0.11,
      &0.2,0.29,0.25,0.16,0.28,0.15,0.3,0.22,0.25,
      &0.25,0.24/
       data arrayb/0.55,0.6,0.375,0.6,0.1,0.15,
      &0.15,0.05,0.35,0.3,0.15,0.1,0.1,0.22,
      &0.2,0.09,0.4/
 
 * the minimum energy for pion+delta collision
        pi=3.1415926
        amn=0.938
        amp=0.138
        xs=0
 * include contribution from each resonance
        branch=1./3.
        do 1001 ir=1,17
        if(ir.gt.8)branch=2./3.
        xs0=fd1(arraym(ir),arrayj(ir),arrayl(ir),
      &arrayw(ir),arrayb(ir),srt)
        xs=xs+1.3*pi*branch*xs0*(0.1973)**2
  1001   continue
        DIRCT3=XS
        RETURN
        end
 ***************************8
 *FUNCTION FDE(DMASS) GIVES DELTA MASS DISTRIBUTION BY USING OF
 *KITAZOE'S FORMULA
 c        REAL*4 FUNCTION FD1(DMASS,aj,al,width,widb0,srt)
       REAL FUNCTION FD1(DMASS,aj,al,width,widb0,srt)
       SAVE   
         AMN=0.938
         AmP=0.138
        amd=amn
            Ak02= 0.25*(DMASS**2-amd**2-amp**2)**2
      &           -(Amp*amd)**2
             IF (ak02 .GT. 0.) THEN
               Q0 = SQRT(ak02/DMASS)
             ELSE
               Q0= 0.0
              fd1=0
            return
             END IF
            Ak2= 0.25*(srt**2-amd**2-amp**2)**2
      &           -(Amp*amd)**2
             IF (ak2 .GT. 0.) THEN
               Q = SQRT(ak2/DMASS)
             ELSE
               Q= 0.00
              fd1=0
              return
             END IF
        b=widb0*1.2*dmass/srt*(q/q0)**(2.*al+1)
      &  /(1.+0.2*(q/q0)**(2*al))
         FD1=(2.*aj+1)*WIDTH**2*b/((srt-dmass)**2
      1  +0.25*WIDTH**2)/(2.*q**2)
         RETURN
         END
 ******************************
 * this program calculates the elastic cross section for pion+delta
 * through higher resonances
 c       REAL*4 FUNCTION DPION(EM1,EM2,LB1,LB2,SRT)
       REAL FUNCTION DPION(EM1,EM2,LB1,LB2,SRT)
 * date : Dec. 19, 1994
 * ****************************
 c     implicit real*4 (a-h,o-z)
       dimension   arrayj(19),arrayl(19),arraym(19),
      &arrayw(19),arrayb(19)
       SAVE   
       data arrayj /0.5,1.5,0.5,0.5,2.5,2.5,1.5,0.5,1.5,3.5,
      &1.5,0.5,1.5,0.5,2.5,0.5,1.5,2.5,3.5/
       data arrayl/1,2,0,0,2,3,2,1,1,3,
      &1,0,2,0,3,1,1,2,3/
       data arraym /1.44,1.52,1.535,1.65,1.675,1.68,1.70,1.71,
      &1.72,1.99,1.60,1.62,1.70,1.90,1.905,1.910,
      &1.86,1.93,1.95/
       data arrayw/0.2,0.125,0.15,0.15,0.155,0.125,0.1,0.11,
      &0.2,0.29,0.25,0.16,0.28,0.15,0.3,0.22,0.25,
      &0.25,0.24/
       data arrayb/0.15,0.25,0.,0.05,0.575,0.125,0.379,0.10,
      &0.10,0.062,0.45,0.60,0.6984,0.05,0.25,0.089,
      &0.19,0.2,0.13/
 
 * the minimum energy for pion+delta collision
        pi=3.1415926
        amn=0.94
        amp=0.14
        xs=0
 * include contribution from each resonance
        do 1001 ir=1,19
        BRANCH=0.
 cbz11/25/98
        if(ir.LE.8)THEN
 c       IF(LB1*LB2.EQ.5*7.OR.LB1*LB2.EQ.3*8)branch=1./6.
 c       IF(LB1*LB2.EQ.4*7.OR.LB1*LB2.EQ.4*8)branch=1./3.
 c       IF(LB1*LB2.EQ.5*6.OR.LB1*LB2.EQ.3*9)branch=1./2.
 c       ELSE
 c       IF(LB1*LB2.EQ.5*8.OR.LB1*LB2.EQ.5*6)branch=2./5.
 c       IF(LB1*LB2.EQ.3*9.OR.LB1*LB2.EQ.3*7)branch=2./5.
 c       IF(LB1*LB2.EQ.5*7.OR.LB1*LB2.EQ.3*8)branch=8./15.
 c       IF(LB1*LB2.EQ.4*7.OR.LB1*LB2.EQ.4*8)branch=1./15.
 c       IF(LB1*LB2.EQ.4*9.OR.LB1*LB2.EQ.4*6)branch=3./5.
 c       ENDIF
        IF( ((LB1*LB2.EQ.5*7.AND.(LB1.EQ.5.OR.LB2.EQ.5)).OR.
      &     (LB1*LB2.EQ.3*8.AND.(LB1.EQ.3.OR.LB2.EQ.3)))
      &       .OR.((LB1*LB2.EQ.-3*7.AND.(LB1.EQ.3.OR.LB2.EQ.3)).OR.
      &     (LB1*LB2.EQ.-5*8.AND.(LB1.EQ.5.OR.LB2.EQ.5))) )
      &     branch=1./6.
        IF((iabs(LB1*LB2).EQ.4*7.AND.(LB1.EQ.4.OR.LB2.EQ.4)).OR.
      &     (iabs(LB1*LB2).EQ.4*8.AND.(LB1.EQ.4.OR.LB2.EQ.4)))
      &     branch=1./3.
        IF( ((LB1*LB2.EQ.5*6.AND.(LB1.EQ.5.OR.LB2.EQ.5)).OR.
      &     (LB1*LB2.EQ.3*9.AND.(LB1.EQ.3.OR.LB2.EQ.3)))
      &       .OR.((LB1*LB2.EQ.-3*6.AND.(LB1.EQ.3.OR.LB2.EQ.3)).OR.
      &     (LB1*LB2.EQ.-5*9.AND.(LB1.EQ.5.OR.LB2.EQ.5))) )
      &     branch=1./2.
        ELSE
        IF( ((LB1*LB2.EQ.5*8.AND.(LB1.EQ.5.OR.LB2.EQ.5)).OR.
      &     (LB1*LB2.EQ.5*6.AND.(LB1.EQ.5.OR.LB2.EQ.5)))
      &        .OR.((LB1*LB2.EQ.-3*8.AND.(LB1.EQ.3.OR.LB2.EQ.3)).OR.
      &     (LB1*LB2.EQ.-3*6.AND.(LB1.EQ.3.OR.LB2.EQ.3))) )
      &     branch=2./5.
        IF( ((LB1*LB2.EQ.3*9.AND.(LB1.EQ.3.OR.LB2.EQ.3)).OR.
      &     (LB1*LB2.EQ.3*7.AND.(LB1.EQ.3.OR.LB2.EQ.3)))
      &        .OR. ((LB1*LB2.EQ.-5*9.AND.(LB1.EQ.5.OR.LB2.EQ.5)).OR.
      &     (LB1*LB2.EQ.-5*7.AND.(LB1.EQ.5.OR.LB2.EQ.5))) )
      &     branch=2./5.
        IF( ((LB1*LB2.EQ.5*7.AND.(LB1.EQ.5.OR.LB2.EQ.5)).OR.
      &     (LB1*LB2.EQ.3*8.AND.(LB1.EQ.3.OR.LB2.EQ.3)))
      &        .OR.((LB1*LB2.EQ.-3*7.AND.(LB1.EQ.3.OR.LB2.EQ.3)).OR.
      &     (LB1*LB2.EQ.-5*8.AND.(LB1.EQ.5.OR.LB2.EQ.5))) )
      &     branch=8./15.
        IF((iabs(LB1*LB2).EQ.4*7.AND.(LB1.EQ.4.OR.LB2.EQ.4)).OR.
      &     (iabs(LB1*LB2).EQ.4*8.AND.(LB1.EQ.4.OR.LB2.EQ.4)))
      &     branch=1./15.
        IF((iabs(LB1*LB2).EQ.4*9.AND.(LB1.EQ.4.OR.LB2.EQ.4)).OR.
      &     (iabs(LB1*LB2).EQ.4*6.AND.(LB1.EQ.4.OR.LB2.EQ.4)))
      &     branch=3./5.
        ENDIF
 cbz11/25/98end
        xs0=fd2(arraym(ir),arrayj(ir),arrayl(ir),
      &arrayw(ir),arrayb(ir),EM1,EM2,srt)
        xs=xs+1.3*pi*branch*xs0*(0.1973)**2
  1001   continue
        DPION=XS
        RETURN
        end
 ***************************8
 *FUNCTION FDE(DMASS) GIVES DELTA MASS DISTRIBUTION BY USING OF
 *KITAZOE'S FORMULA
 c        REAL*4 FUNCTION FD2(DMASS,aj,al,width,widb0,EM1,EM2,srt)
       REAL FUNCTION FD2(DMASS,aj,al,width,widb0,EM1,EM2,srt)
       SAVE   
         AmP=EM1
        amd=EM2
            Ak02= 0.25*(DMASS**2-amd**2-amp**2)**2
      &           -(Amp*amd)**2
             IF (ak02 .GT. 0.) THEN
               Q0 = SQRT(ak02/DMASS)
             ELSE
               Q0= 0.0
              fd2=0
            return
             END IF
            Ak2= 0.25*(srt**2-amd**2-amp**2)**2
      &           -(Amp*amd)**2
             IF (ak2 .GT. 0.) THEN
               Q = SQRT(ak2/DMASS)
             ELSE
               Q= 0.00
              fd2=0
              return
             END IF
        b=widb0*1.2*dmass/srt*(q/q0)**(2.*al+1)
      &  /(1.+0.2*(q/q0)**(2*al))
         FD2=(2.*aj+1)*WIDTH**2*b/((srt-dmass)**2
      1  +0.25*WIDTH**2)/(4.*q**2)
         RETURN
         END
 ***************************8
 *   MASS GENERATOR for two resonances simultaneously
        subroutine Rmasdd(srt,am10,am20,
      &dmin1,dmin2,ISEED,ic,dm1,dm2)
       COMMON/RNDF77/NSEED
 cc      SAVE /RNDF77/
       SAVE   
        amn=0.94
        amp=0.14
 * the maximum mass for resonance 1
          dmax1=srt-dmin2
 * generate the mass for the first resonance
  5        NTRY1=0
          ntry2=0
          ntry=0
          ictrl=0
 10        DM1 = RANART(NSEED) * (DMAX1-DMIN1) + DMIN1
           NTRY1=NTRY1+1
 * the maximum mass for resonance 2 
          if(ictrl.eq.0)dmax2=srt-dm1
 * generate the mass for the second resonance
 20         dm2=RANART(NSEED)*(dmax2-dmin2)+dmin2
           NTRY2=NTRY2+1
 * check the energy-momentum conservation with two masses
 * q2 in the following is q**2*4*srt**2
          q2=((srt**2-dm1**2-dm2**2)**2-4.*dm1**2*dm2**2)
          if(q2.le.0)then
          dmax2=dm2-0.01
 c         dmax1=dm1-0.01
          ictrl=1
          go to 20
          endif
 * determine the weight of the mass pair         
           IF(DMAX1.LT.am10) THEN
           if(ic.eq.1)FM1=Fmassd(DMAX1)
           if(ic.eq.2)FM1=Fmassn(DMAX1)
           if(ic.eq.3)FM1=Fmassd(DMAX1)
           if(ic.eq.4)FM1=Fmassd(DMAX1)
           ELSE
           if(ic.eq.1)FM1=Fmassd(am10)
           if(ic.eq.2)FM1=Fmassn(am10)
           if(ic.eq.3)FM1=Fmassd(am10)
           if(ic.eq.4)FM1=Fmassd(am10)
           ENDIF
           IF(DMAX2.LT.am20) THEN
           if(ic.eq.1)FM2=Fmassd(DMAX2)
           if(ic.eq.2)FM2=Fmassn(DMAX2)
           if(ic.eq.3)FM2=Fmassn(DMAX2)
           if(ic.eq.4)FM2=Fmassr(DMAX2)
           ELSE
           if(ic.eq.1)FM2=Fmassd(am20)
           if(ic.eq.2)FM2=Fmassn(am20)
           if(ic.eq.3)FM2=Fmassn(am20)
           if(ic.eq.4)FM2=Fmassr(am20)
           ENDIF
           IF(FM1.EQ.0.)FM1=1.e-04
           IF(FM2.EQ.0.)FM2=1.e-04
          prob0=fm1*fm2
           if(ic.eq.1)prob=Fmassd(dm1)*fmassd(dm2)
           if(ic.eq.2)prob=Fmassn(dm1)*fmassn(dm2)
           if(ic.eq.3)prob=Fmassd(dm1)*fmassn(dm2)
           if(ic.eq.4)prob=Fmassd(dm1)*fmassr(dm2)
          if(prob.le.1.e-06)prob=1.e-06
          fff=prob/prob0
          ntry=ntry+1 
           IF(RANART(NSEED).GT.fff.AND.
      1    NTRY.LE.20) GO TO 10
 
 clin-2/26/03 limit the mass of (rho,Delta,N*1440) below a certain value
 c     (here taken as its central value + 2* B-W fullwidth):
           if((abs(am10-0.77).le.0.01.and.dm1.gt.1.07)
      1         .or.(abs(am10-1.232).le.0.01.and.dm1.gt.1.47)
      2         .or.(abs(am10-1.44).le.0.01.and.dm1.gt.2.14)) goto 5
           if((abs(am20-0.77).le.0.01.and.dm2.gt.1.07)
      1         .or.(abs(am20-1.232).le.0.01.and.dm2.gt.1.47)
      2         .or.(abs(am20-1.44).le.0.01.and.dm2.gt.2.14)) goto 5
 
        RETURN
        END
 *FUNCTION Fmassd(DMASS) GIVES the delta MASS DISTRIBUTION 
         REAL FUNCTION Fmassd(DMASS)
       SAVE   
         AM0=1.232
         Fmassd=am0*WIDTH(DMASS)/((DMASS**2-am0**2)**2
      1  +am0**2*WIDTH(DMASS)**2)
         RETURN
         END
 *FUNCTION Fmassn(DMASS) GIVES the N* MASS DISTRIBUTION 
         REAL FUNCTION Fmassn(DMASS)
       SAVE   
         AM0=1.44
         Fmassn=am0*W1440(DMASS)/((DMASS**2-am0**2)**2
      1  +am0**2*W1440(DMASS)**2)
         RETURN
         END
 *FUNCTION Fmassr(DMASS) GIVES the rho MASS DISTRIBUTION 
         REAL FUNCTION Fmassr(DMASS)
       SAVE   
         AM0=0.77
        wid=0.153
         Fmassr=am0*Wid/((DMASS**2-am0**2)**2
      1  +am0**2*Wid**2)
         RETURN
         END
 **********************************
 * PURPOSE : flow analysis  
 * DATE : Feb. 1, 1995
 ***********************************
        subroutine flow(nt)
 c       IMPLICIT REAL*4 (A-H,O-Z)
        PARAMETER ( PI=3.1415926,APion=0.13957,aka=0.498)
         PARAMETER   (MAXSTR=150001,MAXR=1,AMU= 0.9383,etaM=0.5475)
        DIMENSION ypion(-80:80),ypr(-80:80),ykaon(-80:80)
        dimension pxpion(-80:80),pxpro(-80:80),pxkaon(-80:80)
 *----------------------------------------------------------------------*
       COMMON  /AA/      R(3,MAXSTR)
 cc      SAVE /AA/
       COMMON  /BB/      P(3,MAXSTR)
 cc      SAVE /BB/
       COMMON  /CC/      E(MAXSTR)
 cc      SAVE /CC/
       COMMON  /EE/      ID(MAXSTR),LB(MAXSTR)
 cc      SAVE /EE/
       COMMON  /RR/      MASSR(0:MAXR)
 cc      SAVE /RR/
       COMMON  /RUN/     NUM
 cc      SAVE /RUN/
       common/input1/ MASSPR,MASSTA,ISEED,IAVOID,DT
 cc      SAVE /input1/
       SAVE   
 *----------------------------------------------------------------------*
        ycut1=-2.6
        ycut2=2.6
        DY=0.2
        LY=NINT((YCUT2-YCUT1)/DY)
 ***********************************
 C initialize the transverse momentum counters 
        do 11 kk=-80,80
        pxpion(kk)=0
        pxpro(kk)=0
        pxkaon(kk)=0
 11       continue
        DO 701 J=-LY,LY
        ypion(j)=0
        ykaon(j)=0
        ypr(j)=0
   701   CONTINUE
        nkaon=0
        npr=0
        npion=0
           IS=0
           DO 20 NRUN=1,NUM
           IS=IS+MASSR(NRUN-1)
           DO 20 J=1,MASSR(NRUN)
           I=J+IS
 * for protons go to 200 to calculate its rapidity and transvese momentum
 * distributions
        e00=sqrt(P(1,I)**2+P(2,i)**2+P(3,i)**2+e(I)**2)
        y00=0.5*alog((e00+p(3,i))/(e00-p(3,i)))
        if(abs(y00).ge.ycut2)go to 20
        iy=nint(y00/DY)
        if(abs(iy).ge.80)go to 20
        if(e(i).eq.0)go to 20
        if(lb(i).ge.25)go to 20
        if((lb(i).le.5).and.(lb(i).ge.3))go to 50
        if(lb(i).eq.1.or.lb(i).eq.2)go to 200
 cbz3/10/99
 c       if(lb(i).ge.6.and.lb(i).le.15)go to 200
        if(lb(i).ge.6.and.lb(i).le.17)go to 200
 cbz3/10/99 end
        if(lb(i).eq.23)go to 400
        go to 20
 * calculate rapidity and transverse momentum distribution for pions
 50       npion=npion+1
 * (2) rapidity distribution in the cms frame
         ypion(iy)=ypion(iy)+1
        pxpion(iy)=pxpion(iy)+p(1,i)/e(I)
        go TO 20
 * calculate rapidity and transverse energy distribution for baryons
 200      npr=npr+1  
                 pxpro(iy)=pxpro(iy)+p(1,I)/E(I)
                  ypr(iy)=ypr(iy)+1.
         go to 20
 400     nkaon=nkaon+1  
                  ykaon(iy)=ykaon(iy)+1.
                 pxkaon(iy)=pxkaon(iy)+p(1,i)/E(i)
 20      CONTINUE
 C PRINT OUT NUCLEON'S TRANSVERSE MOMENTUM distribution
 c       write(1041,*)Nt
 c       write(1042,*)Nt
 c       write(1043,*)Nt
 c       write(1090,*)Nt
 c       write(1091,*)Nt
 c       write(1092,*)Nt
        do 3 npt=-10,10
        IF(ypr(npt).eq.0) go to 101
        pxpro(NPT)=-Pxpro(NPT)/ypr(NPT)
        DNUC=Pxpro(NPT)/SQRT(ypr(NPT))
 c       WRITE(1041,*)NPT*DY,Pxpro(NPT),DNUC
 c print pion's transverse momentum distribution
 101       IF(ypion(npt).eq.0) go to 102
        pxpion(NPT)=-pxpion(NPT)/ypion(NPT)
        DNUCp=pxpion(NPT)/SQRT(ypion(NPT))
 c       WRITE(1042,*)NPT*DY,Pxpion(NPT),DNUCp
 c kaons
 102       IF(ykaon(npt).eq.0) go to 3
        pxkaon(NPT)=-pxkaon(NPT)/ykaon(NPT)
        DNUCk=pxkaon(NPT)/SQRT(ykaon(NPT))
 c       WRITE(1043,*)NPT*DY,Pxkaon(NPT),DNUCk
 3       CONTINUE
 ********************************
 * OUTPUT PION AND PROTON RAPIDITY DISTRIBUTIONS
        DO 1001 M=-LY,LY
 * PROTONS
        DYPR=0
        IF(YPR(M).NE.0)DYPR=SQRT(YPR(M))/FLOAT(NRUN)/DY
        YPR(M)=YPR(M)/FLOAT(NRUN)/DY
 c       WRITE(1090,'(E11.3,2X,E11.3,2X,E11.3)')m*DY,YPR(M),DYPR
 * PIONS
        DYPION=0
        IF(YPION(M).NE.0)DYPION=SQRT(YPION(M))/FLOAT(NRUN)/DY
        YPION(M)=YPION(M)/FLOAT(NRUN)/DY
 c       WRITE(1091,'(E11.3,2X,E11.3,2X,E11.3)')m*DY,YPION(M),DYPION
 * KAONS
        DYKAON=0
        IF(YKAON(M).NE.0)DYKAON=SQRT(YKAON(M))/FLOAT(NRUN)/DY
        YKAON(M)=YKAON(M)/FLOAT(NRUN)/DY
 c       WRITE(1092,'(E11.3,2X,E11.3,2X,E11.3)')m*DY,YKAON(M),DYKAON
  1001 CONTINUE
        return
        end
 cbali1/16/99
 ********************************************
 * Purpose: pp_bar annihilation cross section as a functon of their cms energy
 c      real*4 function xppbar(srt)
       real function xppbar(srt)
 *  srt    = DSQRT(s) in GeV                                                   *
 *  xppbar = pp_bar annihilation cross section in mb                           *
 *                                                    
 *  Reference: G.J. Wang, R. Bellwied, C. Pruneau and G. Welke
 *             Proc. of the 14th Winter Workshop on Nuclear Dynamics, 
 *             Snowbird, Utah 31, Eds. W. Bauer and H.G. Ritter 
 *             (Plenum Publishing, 1998)                             *
 *
 ******************************************
        Parameter (pmass=0.9383,xmax=400.)
       SAVE   
 * Note:
 * (1) we introduce a new parameter xmax=400 mb:
 *     the maximum annihilation xsection 
 * there are shadowing effects in pp_bar annihilation, with this parameter
 * we can probably look at these effects  
 * (2) Calculate p(lab) from srt [GeV], since the formular in the 
 * reference applies only to the case of a p_bar on a proton at rest
 * Formula used: srt**2=2.*pmass*(pmass+sqrt(pmass**2+plab**2))
        xppbar=1.e-06
        plab2=(srt**2/(2.*pmass)-pmass)**2-pmass**2
        if(plab2.gt.0)then
            plab=sqrt(plab2)
        xppbar=67./(plab**0.7)
        if(xppbar.gt.xmax)xppbar=xmax
        endif
          return
       END
 cbali1/16/99 end
 **********************************
 cbali2/6/99
 ********************************************
 * Purpose: To generate randomly the no. of pions in the final 
 *          state of pp_bar annihilation according to a statistical 
 *          model by using of the rejection method.  
 cbz2/25/99
 c      real*4 function pbarfs(srt,npion,iseed)
       subroutine pbarfs(srt,npion,iseed)
 cbz2/25/99end
 * Quantities: 
 *  srt: DSQRT(s) in GeV                                                    *
 *  npion: No. of pions produced in the annihilation of ppbar at srt        *
 *  nmax=6, cutoff of the maximum no. of n the code can handle     
 *                                             
 *  Reference: C.M. Ko and R. Yuan, Phys. Lett. B192 (1987) 31      *
 *
 ******************************************
        parameter (pimass=0.140,pi=3.1415926) 
        Dimension factor(6),pnpi(6) 
       COMMON/RNDF77/NSEED
 cc      SAVE /RNDF77/
       SAVE   
 C the factorial coefficients in the pion no. distribution 
 * from n=2 to 6 calculated use the formula in the reference
        factor(2)=1.
        factor(3)=1.17e-01
        factor(4)=3.27e-03
        factor(5)=3.58e-05
        factor(6)=1.93e-07
        ene=(srt/pimass)**3/(6.*pi**2)
 c the relative probability from n=2 to 6
        do 1001 n=2,6 
            pnpi(n)=ene**n*factor(n)
  1001   continue
 c find the maximum of the probabilities, I checked a 
 c Fortan manual: max() returns the maximum value of 
 c the same type as in the argument list
        pmax=max(pnpi(2),pnpi(3),pnpi(4),pnpi(5),pnpi(6))
 c randomly generate n between 2 and 6
        ntry=0
  10    npion=2+int(5*RANART(NSEED))
 clin-4/2008 check bounds:
        if(npion.gt.6) goto 10
        thisp=pnpi(npion)/pmax  
        ntry=ntry+1 
 c decide whether to take this npion according to the distribution
 c using rejection method.
        if((thisp.lt.RANART(NSEED)).and.(ntry.le.20)) go to 10
 c now take the last generated npion and return
        return
        END
 **********************************
 cbali2/6/99 end
 cbz3/9/99 kkbar
 cbali3/5/99
 ******************************************
 * purpose: Xsection for K+ K- to pi+ pi-
 c      real*4 function xkkpi(srt)
 *  srt    = DSQRT(s) in GeV                                  *
 *  xkkpi   = xsection in mb obtained from
 *           the detailed balance                             *
 * ******************************************
 c          parameter (pimass=0.140,aka=0.498)
 c       xkkpi=1.e-08 
 c       ppi2=(srt/2)**2-pimass**2
 c       pk2=(srt/2)**2-aka**2
 c       if(ppi2.le.0.or.pk2.le.0)return
 cbz3/9/99 kkbar
 c       xkkpi=ppi2/pk2*pipik(srt)
 c       xkkpi=9.0 / 4.0 * ppi2/pk2*pipik(srt)
 c        xkkpi = 2.0 * xkkpi
 cbz3/9/99 kkbar end
 
 cbz3/9/99 kkbar
 c       end
 c       return
 c        END
 cbz3/9/99 kkbar end
 
 cbali3/5/99 end
 cbz3/9/99 kkbar end
 
 cbz3/9/99 kkbar
 *****************************
 * purpose: Xsection for K+ K- to pi+ pi-
       SUBROUTINE XKKANN(SRT, XSK1, XSK2, XSK3, XSK4, XSK5,
      &     XSK6, XSK7, XSK8, XSK9, XSK10, XSK11, SIGK, rrkk)
 *  srt    = DSQRT(s) in GeV                                       *
 *  xsk1   = annihilation into pi pi                               *
 *  xsk2   = annihilation into pi rho (shifted to XKKSAN)         *
 *  xsk3   = annihilation into pi omega (shifted to XKKSAN)       *
 *  xsk4   = annihilation into pi eta                              *
 *  xsk5   = annihilation into rho rho                             *
 *  xsk6   = annihilation into rho omega                           *
 *  xsk7   = annihilation into rho eta (shifted to XKKSAN)        *
 *  xsk8   = annihilation into omega omega                         *
 *  xsk9   = annihilation into omega eta (shifted to XKKSAN)      *
 *  xsk10  = annihilation into eta eta                             *
 *  sigk   = xsection in mb obtained from                          *
 *           the detailed balance                                  *
 * ***************************
       PARAMETER  (MAXSTR=150001, MAXX=20,  MAXZ=24)
           PARAMETER (AKA=0.498, PIMASS=0.140, RHOM = 0.770, 
      &     OMEGAM = 0.7819, ETAM = 0.5473, APHI=1.02)
       COMMON  /AA/ R(3,MAXSTR)
 cc      SAVE /AA/
       COMMON /BB/  P(3,MAXSTR)
 cc      SAVE /BB/
       COMMON /EE/ ID(MAXSTR),LB(MAXSTR)
 cc      SAVE /EE/
       COMMON  /DD/      RHO(-MAXX:MAXX,-MAXX:MAXX,-MAXZ:MAXZ),
      &                     RHOP(-MAXX:MAXX,-MAXX:MAXX,-MAXZ:MAXZ),
      &                     RHON(-MAXX:MAXX,-MAXX:MAXX,-MAXZ:MAXZ)
 cc      SAVE /DD/
       SAVE   
 
         S = SRT ** 2
        SIGK = 1.E-08
         XSK1 = 0.0
         XSK2 = 0.0
         XSK3 = 0.0
         XSK4 = 0.0
         XSK5 = 0.0
         XSK6 = 0.0
         XSK7 = 0.0
         XSK8 = 0.0
         XSK9 = 0.0
         XSK10 = 0.0
         XSK11 = 0.0
 
         XPION0 = PIPIK(SRT)
 c.....take into account both K+ and K0
         XPION0 = 2.0 * XPION0
         PI2 = S * (S - 4.0 * AKA ** 2)
          if(PI2 .le. 0.0)return
 
         XM1 = PIMASS
         XM2 = PIMASS
         PF2 = (S - (XM1 + XM2) ** 2) * (S - (XM1 - XM2) ** 2)
         IF (PF2 .GT. 0.0) THEN
            XSK1 = 9.0 / 4.0 * PF2 / PI2 * XPION0
         END IF
 
 clin-8/28/00 (pi eta) eta -> K+K- is assumed the same as pi pi -> K+K-:
         XM1 = PIMASS
         XM2 = ETAM
         PF2 = (S - (XM1 + XM2) ** 2) * (S - (XM1 - XM2) ** 2)
         IF (PF2 .GT. 0.0) THEN
            XSK4 = 3.0 / 4.0 * PF2 / PI2 * XPION0
         END IF
 
         XM1 = ETAM
         XM2 = ETAM
         PF2 = (S - (XM1 + XM2) ** 2) * (S - (XM1 - XM2) ** 2)
         IF (PF2 .GT. 0.0) THEN
            XSK10 = 1.0 / 4.0 * PF2 / PI2 * XPION0
         END IF
 
         XPION0 = rrkk
 
 clin-11/07/00: (pi eta) (rho omega) -> K* Kbar (or K*bar K) instead to K Kbar:
 c        XM1 = PIMASS
 c        XM2 = RHOM
 c        PF2 = (S - (XM1 + XM2) ** 2) * (S - (XM1 - XM2) ** 2)
 c        IF (PF2 .GT. 0.0) THEN
 c           XSK2 = 27.0 / 4.0 * PF2 / PI2 * XPION0
 c        END IF
 
 c        XM1 = PIMASS
 c        XM2 = OMEGAM
 c        PF2 = (S - (XM1 + XM2) ** 2) * (S - (XM1 - XM2) ** 2)
 c        IF (PF2 .GT. 0.0) THEN
 c           XSK3 = 9.0 / 4.0 * PF2 / PI2 * XPION0
 c        END IF
 
         XM1 = RHOM
         XM2 = RHOM
         PF2 = (S - (XM1 + XM2) ** 2) * (S - (XM1 - XM2) ** 2)
         IF (PF2 .GT. 0.0) THEN
            XSK5 = 81.0 / 4.0 * PF2 / PI2 * XPION0
         END IF
 
         XM1 = RHOM
         XM2 = OMEGAM
         PF2 = (S - (XM1 + XM2) ** 2) * (S - (XM1 - XM2) ** 2)
         IF (PF2 .GT. 0.0) THEN
            XSK6 = 27.0 / 4.0 * PF2 / PI2 * XPION0
         END IF
 
 c        XM1 = RHOM
 c        XM2 = ETAM
 c        PF2 = (S - (XM1 + XM2) ** 2) * (S - (XM1 - XM2) ** 2)
 c        IF (PF2 .GT. 0.0) THEN
 c           XSK7 = 9.0 / 4.0 * PF2 / PI2 * XPION0
 c        END IF
 
         XM1 = OMEGAM
         XM2 = OMEGAM
         PF2 = (S - (XM1 + XM2) ** 2) * (S - (XM1 - XM2) ** 2)
         IF (PF2 .GT. 0.0) THEN
            XSK8 = 9.0 / 4.0 * PF2 / PI2 * XPION0
         END IF
 
 c        XM1 = OMEGAM
 c        XM2 = ETAM
 c        PF2 = (S - (XM1 + XM2) ** 2) * (S - (XM1 - XM2) ** 2)
 c        IF (PF2 .GT. 0.0) THEN
 c           XSK9 = 3.0 / 4.0 * PF2 / PI2 * XPION0
 c        END IF
 
 c* K+ + K- --> phi
           fwdp = 1.68*(aphi**2-4.*aka**2)**1.5/6./aphi/aphi     
 
 clin-9/2012: check argument in sqrt():
           scheck=srt**2-4.0*aka**2
           if(scheck.le.0) then
              write(99,*) 'scheck47: ', scheck
              stop
           endif
           pkaon=0.5*sqrt(scheck)
 c          pkaon=0.5*sqrt(srt**2-4.0*aka**2)
 
           XSK11 = 30.*3.14159*0.1973**2*(aphi*fwdp)**2/
      &             ((srt**2-aphi**2)**2+(aphi*fwdp)**2)/pkaon**2
 c
         SIGK = XSK1 + XSK2 + XSK3 + XSK4 + XSK5 + 
      &     XSK6 + XSK7 + XSK8 + XSK9 + XSK10 + XSK11
 
        RETURN
         END
 cbz3/9/99 kkbar end
 
 *****************************
 * purpose: Xsection for Phi + B 
        SUBROUTINE XphiB(LB1, LB2, EM1, EM2, SRT,
      &                  XSK1, XSK2, XSK3, XSK4, XSK5, SIGP)
 c
 * ***************************
         PARAMETER (MAXSTR=150001,MAXR=1,AMN=0.939457,
      1  AMP=0.93828,AP1=0.13496,AP2=0.13957,AM0=1.232,PI=3.1415926)
           PARAMETER (AKA=0.498, ALA = 1.1157, PIMASS=0.140, APHI=1.02)
         parameter (arho=0.77)
       SAVE   
 
        SIGP = 1.E-08
         XSK1 = 0.0
         XSK2 = 0.0
         XSK3 = 0.0
         XSK4 = 0.0
         XSK5 = 0.0
         XSK6 = 0.0
           srrt = srt - (em1+em2)
 
 c* phi + N(D) -> elastic scattering
 c            XSK1 = 0.56  !! mb
 c  !! mb  (photo-production xsecn used)
             XSK1 = 8.00
 c
 c* phi + N(D) -> pi + N
         IF (srt  .GT. (ap1+amn)) THEN
              XSK2 = 0.0235*srrt**(-0.519) 
         END IF
 c
 c* phi + N(D) -> pi + D
         IF (srt  .GT. (ap1+am0)) THEN
             if(srrt .lt. 0.7)then
              XSK3 = 0.0119*srrt**(-0.534)
             else
              XSK3 = 0.0130*srrt**(-0.304)
             endif      
         END IF
 c
 c* phi + N(D) -> rho + N
         IF (srt  .GT. (arho+amn)) THEN
            if(srrt .lt. 0.7)then
              XSK4 = 0.0166*srrt**(-0.786)
             else
              XSK4 = 0.0189*srrt**(-0.277)
             endif
         END IF
 c
 c* phi + N(D) -> rho + D   (same as pi + D)
         IF (srt  .GT. (arho+am0)) THEN
             if(srrt .lt. 0.7)then
              XSK5 = 0.0119*srrt**(-0.534)
             else
              XSK5 = 0.0130*srrt**(-0.304)
             endif      
         END IF
 c
 c* phi + N -> K+ + La
        IF( (lb1.ge.1.and.lb1.le.2) .or. (lb2.ge.1.and.lb2.le.2) )THEN
         IF (srt  .GT. (aka+ala)) THEN
            XSK6 = 1.715/((srrt+3.508)**2-12.138)  
         END IF
        END IF
         SIGP = XSK1 + XSK2 + XSK3 + XSK4 + XSK5 + XSK6
        RETURN
         END
 c
 **********************************
 *
         SUBROUTINE CRPHIB(PX,PY,PZ,SRT,I1,I2,
      &     XSK1, XSK2, XSK3, XSK4, XSK5, SIGP, IBLOCK)
 *
 *     PURPOSE:                                                         *
 *             DEALING WITH PHI + N(D) --> pi+N(D), rho+N(D),  K+ + La
 *     QUANTITIES:                                                      *
 *           PX,PY,PZ - MOMENTUM COORDINATES OF ONE PARTICLE IN CM FRAME*
 *           SRT      - SQRT OF S                                       *
 *           IBLOCK   - INFORMATION about the reaction channel          *
 *                
 *             iblock   - 20  elastic
 *             iblock   - 221  K+ formation
 *             iblock   - 223  others
 **********************************
         PARAMETER (MAXSTR=150001,MAXR=1,AMN=0.939457,
      1  AMP=0.93828,AP1=0.13496,AMRHO=0.769,AMOMGA=0.782,
      2  AP2=0.13957,AM0=1.232,PI=3.1415926,CUTOFF=1.8966,AVMASS=0.9383)
         PARAMETER      (AKA=0.498,ALA=1.1157,ASA=1.1974,ARHO=0.77)
         parameter     (MX=4,MY=4,MZ=8,MPX=4,MPY=4,mpz=10,mpzp=10)
         COMMON /AA/ R(3,MAXSTR)
 cc      SAVE /AA/
         COMMON /BB/ P(3,MAXSTR)
 cc      SAVE /BB/
         COMMON /CC/ E(MAXSTR)
 cc      SAVE /CC/
         COMMON /EE/ ID(MAXSTR),LB(MAXSTR)
 cc      SAVE /EE/
         common/input1/ MASSPR,MASSTA,ISEED,IAVOID,DT
 cc      SAVE /input1/
       COMMON/RNDF77/NSEED
 cc      SAVE /RNDF77/
       SAVE   
 c
        PX0=PX
        PY0=PY
        PZ0=PZ
        IBLOCK=223
 c
         X1 = RANART(NSEED) * SIGP
         XSK2 = XSK1 + XSK2
         XSK3 = XSK2 + XSK3
         XSK4 = XSK3 + XSK4
         XSK5 = XSK4 + XSK5
 c
 c  !! elastic scatt.
         IF (X1 .LE. XSK1) THEN
            iblock=20
            GOTO 100
         ELSE IF (X1 .LE. XSK2) THEN
            LB(I1) = 3 + int(3 * RANART(NSEED))
            LB(I2) = 1 + int(2 * RANART(NSEED))
            E(I1) = AP1
            E(I2) = AMN
            GOTO 100
         ELSE IF (X1 .LE. XSK3) THEN
            LB(I1) = 3 + int(3 * RANART(NSEED))
            LB(I2) = 6 + int(4 * RANART(NSEED))
            E(I1) = AP1
            E(I2) = AM0
            GOTO 100
         ELSE IF (X1 .LE. XSK4) THEN
            LB(I1) = 25 + int(3 * RANART(NSEED))
            LB(I2) = 1 + int(2 * RANART(NSEED))
            E(I1) = ARHO
            E(I2) = AMN
            GOTO 100
         ELSE IF (X1 .LE. XSK5) THEN
            LB(I1) = 25 + int(3 * RANART(NSEED))
            LB(I2) = 6 + int(4 * RANART(NSEED))
            E(I1) = ARHO
            E(I2) = AM0
            GOTO 100
         ELSE 
            LB(I1) = 23
            LB(I2) = 14
            E(I1) = AKA
            E(I2) = ALA
           IBLOCK=221
          ENDIF
  100    CONTINUE
       EM1=E(I1)
       EM2=E(I2)
 *-----------------------------------------------------------------------
 * CALCULATE THE MAGNITUDE OF THE FINAL MOMENTUM THROUGH
 * ENERGY CONSERVATION
           PR2   = (SRT**2 - EM1**2 - EM2**2)**2
      1                - 4.0 * (EM1*EM2)**2
           IF(PR2.LE.0.)PR2=1.E-08
           PR=SQRT(PR2)/(2.*SRT)
 * WE ASSUME AN ISOTROPIC ANGULAR DISTRIBUTION IN THE CMS 
           C1   = 1.0 - 2.0 * RANART(NSEED)
           T1   = 2.0 * PI * RANART(NSEED)
       S1   = SQRT( 1.0 - C1**2 )
       CT1  = COS(T1)
       ST1  = SIN(T1)
 * THE MOMENTUM IN THE CMS IN THE FINAL STATE
       PZ   = PR * C1
       PX   = PR * S1*CT1 
       PY   = PR * S1*ST1
 * ROTATE IT 
        CALL ROTATE(PX0,PY0,PZ0,PX,PY,PZ) 
       RETURN
       END
 c
 *****************************
 * purpose: Xsection for Phi + B 
 c!! in fm^2
       SUBROUTINE pibphi(srt,lb1,lb2,em1,em2,Xphi,xphin) 
 c
 *      phi + N(D) <- pi + N
 *      phi + N(D) <- pi + D
 *      phi + N(D) <- rho + N
 *      phi + N(D) <- rho + D   (same as pi + D)
 c
 * ***************************
         PARAMETER (MAXSTR=150001,MAXR=1,AMN=0.939457,
      1  AMP=0.93828,AP1=0.13496,AP2=0.13957,AM0=1.232,PI=3.1415926)
           PARAMETER (AKA=0.498, ALA = 1.1157, PIMASS=0.140, APHI=1.02)
         parameter (arho=0.77)
       SAVE   
 
        Xphi = 0.0
        xphin = 0.0
        xphid = 0.0
 c
        if( (lb1.ge.3.and.lb1.le.5) .or.
      &     (lb2.ge.3.and.lb2.le.5) )then
 c
        if( (iabs(lb1).ge.1.and.iabs(lb1).le.2) .or.
      &     (iabs(lb2).ge.1.and.iabs(lb2).le.2) )then
 c* phi + N <- pi + N
         IF (srt  .GT. (aphi+amn)) THEN
              srrt = srt - (aphi+amn)
              sig = 0.0235*srrt**(-0.519) 
           xphin=sig*1.*(srt**2-(aphi+amn)**2)*
      &           (srt**2-(aphi-amn)**2)/(srt**2-(em1+em2)**2)/
      &           (srt**2-(em1-em2)**2)
         END IF
 c* phi + D <- pi + N
         IF (srt  .GT. (aphi+am0)) THEN
              srrt = srt - (aphi+am0)
              sig = 0.0235*srrt**(-0.519) 
           xphid=sig*4.*(srt**2-(aphi+am0)**2)*
      &           (srt**2-(aphi-am0)**2)/(srt**2-(em1+em2)**2)/
      &           (srt**2-(em1-em2)**2)
         END IF
        else
 c* phi + N <- pi + D
         IF (srt  .GT. (aphi+amn)) THEN
              srrt = srt - (aphi+amn)
             if(srrt .lt. 0.7)then
              sig = 0.0119*srrt**(-0.534)
             else
              sig = 0.0130*srrt**(-0.304)
             endif      
           xphin=sig*(1./4.)*(srt**2-(aphi+amn)**2)*
      &           (srt**2-(aphi-amn)**2)/(srt**2-(em1+em2)**2)/
      &           (srt**2-(em1-em2)**2)
         END IF
 c* phi + D <- pi + D
         IF (srt  .GT. (aphi+am0)) THEN
              srrt = srt - (aphi+am0)
              if(srrt .lt. 0.7)then
              sig = 0.0119*srrt**(-0.534)
             else
              sig = 0.0130*srrt**(-0.304)
             endif      
           xphid=sig*1.*(srt**2-(aphi+am0)**2)*
      &           (srt**2-(aphi-am0)**2)/(srt**2-(em1+em2)**2)/
      &           (srt**2-(em1-em2)**2)
         END IF
        endif
 c
 c
 C** for rho + N(D) colln
 c
        else
 c
        if( (iabs(lb1).ge.1.and.iabs(lb1).le.2) .or.
      &     (iabs(lb2).ge.1.and.iabs(lb2).le.2) )then
 c
 c* phi + N <- rho + N
         IF (srt  .GT. (aphi+amn)) THEN
              srrt = srt - (aphi+amn)
            if(srrt .lt. 0.7)then
              sig = 0.0166*srrt**(-0.786)
             else
              sig = 0.0189*srrt**(-0.277)
             endif
           xphin=sig*(1./3.)*(srt**2-(aphi+amn)**2)*
      &           (srt**2-(aphi-amn)**2)/(srt**2-(em1+em2)**2)/
      &           (srt**2-(em1-em2)**2)
         END IF
 c* phi + D <- rho + N
         IF (srt  .GT. (aphi+am0)) THEN
              srrt = srt - (aphi+am0)
            if(srrt .lt. 0.7)then
              sig = 0.0166*srrt**(-0.786)
             else
              sig = 0.0189*srrt**(-0.277)
             endif
           xphid=sig*(4./3.)*(srt**2-(aphi+am0)**2)*
      &           (srt**2-(aphi-am0)**2)/(srt**2-(em1+em2)**2)/
      &           (srt**2-(em1-em2)**2)
         END IF
        else
 c* phi + N <- rho + D  (same as pi+D->phi+N)
         IF (srt  .GT. (aphi+amn)) THEN
              srrt = srt - (aphi+amn)
             if(srrt .lt. 0.7)then
              sig = 0.0119*srrt**(-0.534)
             else
              sig = 0.0130*srrt**(-0.304)
             endif      
           xphin=sig*(1./12.)*(srt**2-(aphi+amn)**2)*
      &           (srt**2-(aphi-amn)**2)/(srt**2-(em1+em2)**2)/
      &           (srt**2-(em1-em2)**2)
         END IF
 c* phi + D <- rho + D  (same as pi+D->phi+D)
         IF (srt  .GT. (aphi+am0)) THEN
              srrt = srt - (aphi+am0)
              if(srrt .lt. 0.7)then
              sig = 0.0119*srrt**(-0.534)
             else
              sig = 0.0130*srrt**(-0.304)
             endif      
           xphid=sig*(1./3.)*(srt**2-(aphi+am0)**2)*
      &           (srt**2-(aphi-am0)**2)/(srt**2-(em1+em2)**2)/
      &           (srt**2-(em1-em2)**2)
         END IF
        endif
         END IF
 c   !! in fm^2
          xphin = xphin/10.
 c   !! in fm^2
          xphid = xphid/10.
          Xphi = xphin + xphid
 
        RETURN
         END
 c
 *****************************
 * purpose: Xsection for phi +M to K+K etc
       SUBROUTINE PHIMES(I1, I2, SRT, XSK1, XSK2, XSK3, XSK4, XSK5,
      1     XSK6, XSK7, SIGPHI)
 
 *     QUANTITIES:                                                      *
 *           PX,PY,PZ - MOMENTUM COORDINATES OF ONE PARTICLE IN CM FRAME*
 *           SRT      - SQRT OF S                                       *
 *           IBLOCK   - THE INFORMATION BACK                            *
 *                      223 --> phi destruction
 *                      20 -->  elastic
 **********************************
         PARAMETER (MAXSTR=150001,MAXR=1,AMN=0.939457,
      1  AMP=0.93828,AP1=0.13496,
      2  AP2=0.13957,AM0=1.232,PI=3.1415926,CUTOFF=1.8966,AVMASS=0.9383)
         PARAMETER  (AKA=0.498, AKS=0.895, AOMEGA=0.7819,
      3               ARHO=0.77, APHI=1.02)
         parameter     (MX=4,MY=4,MZ=8,MPX=4,MPY=4,mpz=10,mpzp=10)
         PARAMETER  (MAXX=20,  MAXZ=24)
         COMMON /AA/ R(3,MAXSTR)
 cc      SAVE /AA/
         COMMON /BB/ P(3,MAXSTR)
 cc      SAVE /BB/
         COMMON /CC/ E(MAXSTR)
 cc      SAVE /CC/
       COMMON  /DD/      RHO(-MAXX:MAXX,-MAXX:MAXX,-MAXZ:MAXZ),
      &                     RHOP(-MAXX:MAXX,-MAXX:MAXX,-MAXZ:MAXZ),
      &                     RHON(-MAXX:MAXX,-MAXX:MAXX,-MAXZ:MAXZ)
 cc      SAVE /DD/
         COMMON /EE/ ID(MAXSTR),LB(MAXSTR)
 cc      SAVE /EE/
       SAVE   
 
         S = SRT ** 2
        SIGPHI = 1.E-08
         XSK1 = 0.0
         XSK2 = 0.0
         XSK3 = 0.0
         XSK4 = 0.0
         XSK5 = 0.0
         XSK6 = 0.0
         XSK7 = 0.0
          em1 = E(i1)
          em2 = E(i2)
          LB1 = LB(i1)
          LB2 = LB(i2)
          akap = aka
 c******
 c
 c   !! mb, elastic
          XSK1 = 5.0
          
 clin-9/2012: check argument in sqrt():
          scheck=(S-(em1+em2)**2)*(S-(em1-em2)**2)
          if(scheck.le.0) then
             write(99,*) 'scheck48: ', scheck
             stop
          endif
          pii=sqrt(scheck)
 c           pii = sqrt((S-(em1+em2)**2)*(S-(em1-em2)**2))
 
 * phi + K(-bar) channel
        if( lb1.eq.23.or.lb2.eq.23 .or. lb1.eq.21.or.lb2.eq.21 )then
           if(srt .gt. (ap1+akap))then
 c             XSK2 = 2.5  
            pff = sqrt((S-(ap1+akap)**2)*(S-(ap1-akap)**2))
            XSK2 = 195.639*pff/pii/32./pi/S 
           endif
           if(srt .gt. (arho+akap))then
 c              XSK3 = 3.5  
            pff = sqrt((S-(arho+akap)**2)*(S-(arho-akap)**2))
            XSK3 = 526.702*pff/pii/32./pi/S 
           endif
           if(srt .gt. (aomega+akap))then
 c               XSK4 = 3.5 
            pff = sqrt((S-(aomega+akap)**2)*(S-(aomega-akap)**2))
            XSK4 = 355.429*pff/pii/32./pi/S 
           endif
           if(srt .gt. (ap1+aks))then
 c           XSK5 = 15.0  
            pff = sqrt((S-(ap1+aks)**2)*(S-(ap1-aks)**2))
            XSK5 = 2047.042*pff/pii/32./pi/S 
           endif
           if(srt .gt. (arho+aks))then
 c            XSK6 = 3.5 
            pff = sqrt((S-(arho+aks)**2)*(S-(arho-aks)**2))
            XSK6 = 1371.257*pff/pii/32./pi/S 
           endif
           if(srt .gt. (aomega+aks))then
 c            XSK7 = 3.5 
            pff = sqrt((S-(aomega+aks)**2)*(S-(aomega-aks)**2))
            XSK7 = 482.292*pff/pii/32./pi/S 
           endif
 c
        elseif( iabs(lb1).eq.30.or.iabs(lb2).eq.30 )then
 * phi + K*(-bar) channel
 c
           if(srt .gt. (ap1+akap))then
 c             XSK2 = 3.5  
            pff = sqrt((S-(ap1+akap)**2)*(S-(ap1-akap)**2))
            XSK2 = 372.378*pff/pii/32./pi/S 
           endif
           if(srt .gt. (arho+akap))then
 c              XSK3 = 9.0  
            pff = sqrt((S-(arho+akap)**2)*(S-(arho-akap)**2))
            XSK3 = 1313.960*pff/pii/32./pi/S 
           endif
           if(srt .gt. (aomega+akap))then
 c               XSK4 = 6.5 
            pff = sqrt((S-(aomega+akap)**2)*(S-(aomega-akap)**2))
            XSK4 = 440.558*pff/pii/32./pi/S 
           endif
           if(srt .gt. (ap1+aks))then
 c           XSK5 = 30.0 !wrong  
            pff = sqrt((S-(ap1+aks)**2)*(S-(ap1-aks)**2))
            XSK5 = 1496.692*pff/pii/32./pi/S 
           endif
           if(srt .gt. (arho+aks))then
 c            XSK6 = 9.0 
            pff = sqrt((S-(arho+aks)**2)*(S-(arho-aks)**2))
            XSK6 = 6999.840*pff/pii/32./pi/S 
           endif
           if(srt .gt. (aomega+aks))then
 c            XSK7 = 15.0 
            pff = sqrt((S-(aomega+aks)**2)*(S-(aomega-aks)**2))
            XSK7 = 1698.903*pff/pii/32./pi/S 
           endif
        else
 c
 * phi + rho(pi,omega) channel
 c
            srr1 = em1+em2
          if(srt .gt. (akap+akap))then
           srrt = srt - srr1
 cc          if(srrt .lt. 0.3)then
           if(srrt .lt. 0.3 .and. srrt .gt. 0.01)then
           XSK2 = 1.69/(srrt**0.141 - 0.407)
           else
           XSK2 = 3.74 + 0.008*srrt**1.9
           endif                 
          endif
          if(srt .gt. (akap+aks))then
           srr2 = akap+aks
           srr = amax1(srr1,srr2)
           srrt = srt - srr
 cc          if(srrt .lt. 0.3)then
           if(srrt .lt. 0.3 .and. srrt .gt. 0.01)then
           XSK3 = 1.69/(srrt**0.141 - 0.407)
           else
           XSK3 = 3.74 + 0.008*srrt**1.9
           endif
          endif
          if(srt .gt. (aks+aks))then
           srr2 = aks+aks
           srr = amax1(srr1,srr2)
           srrt = srt - srr
 cc          if(srrt .lt. 0.3)then
           if(srrt .lt. 0.3 .and. srrt .gt. 0.01)then
           XSK4 = 1.69/(srrt**0.141 - 0.407)
           else
           XSK4 = 3.74 + 0.008*srrt**1.9
           endif
          endif
 c          xsk2 = amin1(20.,xsk2)
 c          xsk3 = amin1(20.,xsk3)
 c          xsk4 = amin1(20.,xsk4)
       endif
 
         SIGPHI = XSK1 + XSK2 + XSK3 + XSK4 + XSK5 + XSK6 + XSK7
 
        RETURN
        END
 
 **********************************
 *     PURPOSE:                                                         *
 *             DEALING WITH phi+M  scatt.
 *
        SUBROUTINE CRPHIM(PX,PY,PZ,SRT,I1,I2,
      &  XSK1, XSK2, XSK3, XSK4, XSK5, XSK6, SIGPHI, IKKG, IKKL, IBLOCK)
 *
 *     QUANTITIES:                                                      *
 *           PX,PY,PZ - MOMENTUM COORDINATES OF ONE PARTICLE IN CM FRAME*
 *           SRT      - SQRT OF S                                       *
 *           IBLOCK   - THE INFORMATION BACK                            *
 *                      20 -->  elastic
 *                      223 --> phi + pi(rho,omega)
 *                      224 --> phi + K -> K + pi(rho,omega)
 *                      225 --> phi + K -> K* + pi(rho,omega)
 *                      226 --> phi + K* -> K + pi(rho,omega)
 *                      227 --> phi + K* -> K* + pi(rho,omega)
 **********************************
         PARAMETER (MAXSTR=150001,MAXR=1,AMN=0.939457,
      1  AMP=0.93828,AP1=0.13496,ARHO=0.77,AOMEGA=0.7819,
      2  AP2=0.13957,AM0=1.232,PI=3.1415926,CUTOFF=1.8966,AVMASS=0.9383)
         PARAMETER    (AKA=0.498,AKS=0.895)
         parameter   (MX=4,MY=4,MZ=8,MPX=4,MPY=4,mpz=10,mpzp=10)
         COMMON /AA/ R(3,MAXSTR)
 cc      SAVE /AA/
         COMMON /BB/ P(3,MAXSTR)
 cc      SAVE /BB/
         COMMON /CC/ E(MAXSTR)
 cc      SAVE /CC/
         COMMON /EE/ ID(MAXSTR),LB(MAXSTR)
 cc      SAVE /EE/
         common/input1/ MASSPR,MASSTA,ISEED,IAVOID,DT
 cc      SAVE /input1/
       COMMON/RNDF77/NSEED
 cc      SAVE /RNDF77/
       SAVE   
 c
        PX0=PX
        PY0=PY
        PZ0=PZ
          LB1 = LB(i1)
          LB2 = LB(i2)
 
         X1 = RANART(NSEED) * SIGPHI
         XSK2 = XSK1 + XSK2
         XSK3 = XSK2 + XSK3
         XSK4 = XSK3 + XSK4
         XSK5 = XSK4 + XSK5
         XSK6 = XSK5 + XSK6
         IF (X1 .LE. XSK1) THEN
 c        !! elastic scatt
            IBLOCK=20
            GOTO 100
         ELSE
 c
 *phi + (K,K*)-bar
        if( lb1.eq.23.or.lb1.eq.21.or.iabs(lb1).eq.30 .OR.
      &     lb2.eq.23.or.lb2.eq.21.or.iabs(lb2).eq.30 )then
 c
              if(lb1.eq.23.or.lb2.eq.23)then
                IKKL=1
                IBLOCK=224
                iad1 = 23
                iad2 = 30
               elseif(lb1.eq.30.or.lb2.eq.30)then
                IKKL=0
                IBLOCK=226
                iad1 = 23
                iad2 = 30
              elseif(lb1.eq.21.or.lb2.eq.21)then
                IKKL=1
                IBLOCK=124
                iad1 = 21
                iad2 = -30
 c         !! -30
              else
                IKKL=0
                IBLOCK=126
                iad1 = 21
                iad2 = -30
               endif
          IF (X1 .LE. XSK2) THEN
            LB(I1) = 3 + int(3 * RANART(NSEED))
            LB(I2) = iad1
            E(I1) = AP1
            E(I2) = AKA
            IKKG = 1
            GOTO 100
         ELSE IF (X1 .LE. XSK3) THEN
            LB(I1) = 25 + int(3 * RANART(NSEED))
            LB(I2) = iad1
            E(I1) = ARHO
            E(I2) = AKA
            IKKG = 1
            GOTO 100
         ELSE IF (X1 .LE. XSK4) THEN
            LB(I1) = 28
            LB(I2) = iad1
            E(I1) = AOMEGA
            E(I2) = AKA
            IKKG = 1
            GOTO 100
         ELSE IF (X1 .LE. XSK5) THEN
            LB(I1) = 3 + int(3 * RANART(NSEED))
            LB(I2) = iad2
            E(I1) = AP1
            E(I2) = AKS
            IKKG = 0
            IBLOCK=IBLOCK+1
            GOTO 100
         ELSE IF (X1 .LE. XSK6) THEN
            LB(I1) = 25 + int(3 * RANART(NSEED))
            LB(I2) = iad2
            E(I1) = ARHO
            E(I2) = AKS
            IKKG = 0
            IBLOCK=IBLOCK+1
            GOTO 100
         ELSE 
            LB(I1) = 28
            LB(I2) = iad2
            E(I1) = AOMEGA
            E(I2) = AKS
            IKKG = 0
            IBLOCK=IBLOCK+1
            GOTO 100
          ENDIF
        else
 c      !! phi destruction via (pi,rho,omega)
           IBLOCK=223
 *phi + pi(rho,omega)
          IF (X1 .LE. XSK2) THEN
            LB(I1) = 23
            LB(I2) = 21
            E(I1) = AKA
            E(I2) = AKA
            IKKG = 2
            IKKL = 0
            GOTO 100
         ELSE IF (X1 .LE. XSK3) THEN
            LB(I1) = 23
 c           LB(I2) = 30
            LB(I2) = -30
 clin-2/10/03 currently take XSK3 to be the sum of KK*bar & KbarK*:
            if(RANART(NSEED).le.0.5) then
               LB(I1) = 21
               LB(I2) = 30
            endif
               
            E(I1) = AKA
            E(I2) = AKS
            IKKG = 1
            IKKL = 0
            GOTO 100
         ELSE IF (X1 .LE. XSK4) THEN
            LB(I1) = 30
 c           LB(I2) = 30
            LB(I2) = -30
            E(I1) = AKS
            E(I2) = AKS
            IKKG = 0
            IKKL = 0
            GOTO 100
          ENDIF
        endif
          ENDIF
 *
 100    CONTINUE
        EM1=E(I1)
        EM2=E(I2)
 
 *-----------------------------------------------------------------------
 * CALCULATE THE MAGNITUDE OF THE FINAL MOMENTUM THROUGH
 * ENERGY CONSERVATION
           PR2   = (SRT**2 - EM1**2 - EM2**2)**2
      1                - 4.0 * (EM1*EM2)**2
           IF(PR2.LE.0.)PR2=1.E-08
           PR=SQRT(PR2)/(2.*SRT)
 * WE ASSUME AN ISOTROPIC ANGULAR DISTRIBUTION IN THE CMS 
           C1   = 1.0 - 2.0 * RANART(NSEED)
           T1   = 2.0 * PI * RANART(NSEED)
       S1   = SQRT( 1.0 - C1**2 )
       CT1  = COS(T1)
       ST1  = SIN(T1)
 * THE MOMENTUM IN THE CMS IN THE FINAL STATE
       PZ   = PR * C1
       PX   = PR * S1*CT1 
       PY   = PR * S1*ST1
 * ROTATE IT 
        CALL ROTATE(PX0,PY0,PZ0,PX,PY,PZ) 
       RETURN
       END
 **********************************
 **********************************
 cbz3/9/99 khyperon
 *************************************
 * purpose: Xsection for K+Y ->  piN                                       *
 *          Xsection for K+Y-bar ->  piN-bar   !! sp03/29/01               *
 *
         SUBROUTINE XKHYPE(I1, I2, SRT, XKY1, XKY2, XKY3, XKY4, XKY5,
      &     XKY6, XKY7, XKY8, XKY9, XKY10, XKY11, XKY12, XKY13,
      &     XKY14, XKY15, XKY16, XKY17, SIGK)
 c      subroutine xkhype(i1, i2, srt, sigk)
 *  srt    = DSQRT(s) in GeV                                               *
 *  xkkpi   = xsection in mb obtained from                                 *
 *           the detailed balance                                          *
 * ***********************************
         PARAMETER (MAXSTR=150001,MAXR=1,AMN=0.939457,
      1  AMP=0.93828,AP1=0.13496,AMRHO=0.769,AMOMGA=0.782,APHI=1.02,
      2  AP2=0.13957,AM0=1.232,PI=3.1415926,CUTOFF=1.8966,AVMASS=0.9383)
           parameter (pimass=0.140, AMETA = 0.5473, aka=0.498,
      &     aml=1.116,ams=1.193, AM1440 = 1.44, AM1535 = 1.535)
         COMMON  /EE/ID(MAXSTR), LB(MAXSTR)
 cc      SAVE /EE/
       SAVE   
 
         S = SRT ** 2
        SIGK=1.E-08 
         XKY1 = 0.0
         XKY2 = 0.0
         XKY3 = 0.0
         XKY4 = 0.0
         XKY5 = 0.0
         XKY6 = 0.0
         XKY7 = 0.0
         XKY8 = 0.0
         XKY9 = 0.0
         XKY10 = 0.0
         XKY11 = 0.0
         XKY12 = 0.0
         XKY13 = 0.0
         XKY14 = 0.0
         XKY15 = 0.0
         XKY16 = 0.0
         XKY17 = 0.0
 
         LB1 = LB(I1)
         LB2 = LB(I2)
         IF (iabs(LB1) .EQ. 14 .OR. iabs(LB2) .EQ. 14) THEN
            XKAON0 = PNLKA(SRT)
            XKAON0 = 2.0 * XKAON0
            PI2 = (S - (AML + AKA) ** 2) * (S - (AML - AKA) ** 2)
         ELSE
            XKAON0 = PNSKA(SRT)
            XKAON0 = 2.0 * XKAON0
            PI2 = (S - (AMS + AKA) ** 2) * (S - (AMS - AKA) ** 2)
         END IF
           if(PI2 .le. 0.0)return
 
         XM1 = PIMASS
         XM2 = AMP
         PF2 = (S - (XM1 + XM2) ** 2) * (S - (XM1 - XM2) ** 2)
         IF (PF2 .GT. 0.0) THEN
            XKY1 = 3.0 * PF2 / PI2 * XKAON0
         END IF
         
         XM1 = PIMASS
         XM2 = AM0
         PF2 = (S - (XM1 + XM2) ** 2) * (S - (XM1 - XM2) ** 2)
         IF (PF2 .GT. 0.0) THEN
            XKY2 = 12.0 * PF2 / PI2 * XKAON0
         END IF
         
         XM1 = PIMASS
         XM2 = AM1440
         PF2 = (S - (XM1 + XM2) ** 2) * (S - (XM1 - XM2) ** 2)
         IF (PF2 .GT. 0.0) THEN
            XKY3 = 3.0 * PF2 / PI2 * XKAON0
         END IF
         
         XM1 = PIMASS
         XM2 = AM1535
         PF2 = (S - (XM1 + XM2) ** 2) * (S - (XM1 - XM2) ** 2)
         IF (PF2 .GT. 0.0) THEN
            XKY4 = 3.0 * PF2 / PI2 * XKAON0
         END IF
         
         XM1 = AMRHO
         XM2 = AMP
         PF2 = (S - (XM1 + XM2) ** 2) * (S - (XM1 - XM2) ** 2)
         IF (PF2 .GT. 0.0) THEN
            XKY5 = 9.0 * PF2 / PI2 * XKAON0
         END IF
         
         XM1 = AMRHO
         XM2 = AM0
         PF2 = (S - (XM1 + XM2) ** 2) * (S - (XM1 - XM2) ** 2)
         IF (PF2 .GT. 0.0) THEN
            XKY6 = 36.0 * PF2 / PI2 * XKAON0
         END IF
         
         XM1 = AMRHO
         XM2 = AM1440
         PF2 = (S - (XM1 + XM2) ** 2) * (S - (XM1 - XM2) ** 2)
         IF (PF2 .GT. 0.0) THEN
            XKY7 = 9.0 * PF2 / PI2 * XKAON0
         END IF
         
         XM1 = AMRHO
         XM2 = AM1535
         PF2 = (S - (XM1 + XM2) ** 2) * (S - (XM1 - XM2) ** 2)
         IF (PF2 .GT. 0.0) THEN
            XKY8 = 9.0 * PF2 / PI2 * XKAON0
         END IF
         
         XM1 = AMOMGA
         XM2 = AMP
         PF2 = (S - (XM1 + XM2) ** 2) * (S - (XM1 - XM2) ** 2)
         IF (PF2 .GT. 0.0) THEN
            XKY9 = 3.0 * PF2 / PI2 * XKAON0
         END IF
         
         XM1 = AMOMGA
         XM2 = AM0
         PF2 = (S - (XM1 + XM2) ** 2) * (S - (XM1 - XM2) ** 2)
         IF (PF2 .GT. 0.0) THEN
            XKY10 = 12.0 * PF2 / PI2 * XKAON0
         END IF
         
         XM1 = AMOMGA
         XM2 = AM1440
         PF2 = (S - (XM1 + XM2) ** 2) * (S - (XM1 - XM2) ** 2)
         IF (PF2 .GT. 0.0) THEN
            XKY11 = 3.0 * PF2 / PI2 * XKAON0
         END IF
         
         XM1 = AMOMGA
         XM2 = AM1535
         PF2 = (S - (XM1 + XM2) ** 2) * (S - (XM1 - XM2) ** 2)
         IF (PF2 .GT. 0.0) THEN
            XKY12 = 3.0 * PF2 / PI2 * XKAON0
         END IF
         
         XM1 = AMETA
         XM2 = AMP
         PF2 = (S - (XM1 + XM2) ** 2) * (S - (XM1 - XM2) ** 2)
         IF (PF2 .GT. 0.0) THEN
            XKY13 = 1.0 * PF2 / PI2 * XKAON0
         END IF
         
         XM1 = AMETA
         XM2 = AM0
         PF2 = (S - (XM1 + XM2) ** 2) * (S - (XM1 - XM2) ** 2)
         IF (PF2 .GT. 0.0) THEN
            XKY14 = 4.0 * PF2 / PI2 * XKAON0
         END IF
         
         XM1 = AMETA
         XM2 = AM1440
         PF2 = (S - (XM1 + XM2) ** 2) * (S - (XM1 - XM2) ** 2)
         IF (PF2 .GT. 0.0) THEN
            XKY15 = 1.0 * PF2 / PI2 * XKAON0
         END IF
         
         XM1 = AMETA
         XM2 = AM1535
         PF2 = (S - (XM1 + XM2) ** 2) * (S - (XM1 - XM2) ** 2)
         IF (PF2 .GT. 0.0) THEN
            XKY16 = 1.0 * PF2 / PI2 * XKAON0
         END IF
 
 csp11/21/01  K+ + La --> phi + N 
         if(lb1.eq.14 .or. lb2.eq.14)then
          if(srt .gt. (aphi+amn))then
            srrt = srt - (aphi+amn)
            sig = 1.715/((srrt+3.508)**2-12.138)
          XM1 = AMN
          XM2 = APHI
          PF2 = (S - (XM1 + XM2) ** 2) * (S - (XM1 - XM2) ** 2)
 c     ! fm^-1
          XKY17 = 3.0 * PF2 / PI2 * SIG/10.
         endif
        endif
 csp11/21/01  end 
 c
 
        IF ((iabs(LB1) .GE. 15 .AND. iabs(LB1) .LE. 17) .OR. 
      &     (iabs(LB2) .GE. 15 .AND. iabs(LB2) .LE. 17)) THEN
            DDF = 3.0
            XKY1 = XKY1 / DDF
            XKY2 = XKY2 / DDF
            XKY3 = XKY3 / DDF
            XKY4 = XKY4 / DDF
            XKY5 = XKY5 / DDF
            XKY6 = XKY6 / DDF
            XKY7 = XKY7 / DDF
            XKY8 = XKY8 / DDF
            XKY9 = XKY9 / DDF
            XKY10 = XKY10/ DDF
            XKY11 = XKY11 / DDF
            XKY12 = XKY12 / DDF
            XKY13 = XKY13 / DDF
            XKY14 = XKY14 / DDF
            XKY15 = XKY15 / DDF
            XKY16 = XKY16 / DDF
         END IF
         
         SIGK = XKY1 + XKY2 + XKY3 + XKY4 +
      &       XKY5 + XKY6 + XKY7 + XKY8 +
      &       XKY9 + XKY10 + XKY11 + XKY12 +
      &       XKY13 + XKY14 + XKY15 + XKY16 + XKY17
 
        RETURN
        END
 
 C*******************************  
       BLOCK DATA PPBDAT 
     
       parameter (AMP=0.93828,AMN=0.939457,
      1     AM0=1.232,AM1440 = 1.44, AM1535 = 1.535)
 
 c     to give default values to parameters for BbarB production from mesons
       COMMON/ppbmas/niso(15),nstate,ppbm(15,2),thresh(15),weight(15)
 cc      SAVE /ppbmas/
       common/ppb1/ene,factr2(6),fsum,ppinnb,s,wtot
 cc      SAVE /ppb1/
       common/ppmm/pprr,ppee,pppe,rpre,xopoe,rree
 cc      SAVE /ppmm/
       SAVE   
 c     thresh(i) gives the mass thresh for final channel i:
       DATA thresh/1.87656,1.877737,1.878914,2.17028,
      1     2.171457,2.37828,2.379457,2.464,2.47328,2.474457,
      2     2.672,2.767,2.88,2.975,3.07/
 c     ppbm(i,j=1,2) gives masses for the two final baryons of channel i,
 c     with j=1 for the lighter baryon:
       DATA (ppbm(i,1),i=1,15)/amp,amp,amn,amp,amn,amp,amn,
      1     am0,amp,amn,am0,am0,am1440,am1440,am1535/
       DATA (ppbm(i,2),i=1,15)/amp,amn,amn,am0,am0,am1440,am1440,
      1     am0,am1535,am1535,am1440,am1535,am1440,am1535,am1535/
 c     factr2(i) gives weights for producing i pions from ppbar annihilation:
       DATA factr2/0,1,1.17e-01,3.27e-03,3.58e-05,1.93e-07/
 c     niso(i) gives the degeneracy factor for final channel i:
       DATA niso/1,2,1,16,16,4,4,64,4,4,32,32,4,8,4/
 
       END   
 
 
 *****************************************
 * get the number of BbarB states available for mm collisions of energy srt 
       subroutine getnst(srt)
 *  srt    = DSQRT(s) in GeV                                                   *
 *****************************************
       parameter (pimass=0.140,pi=3.1415926)
       COMMON/ppbmas/niso(15),nstate,ppbm(15,2),thresh(15),weight(15)
 cc      SAVE /ppbmas/
       common/ppb1/ene,factr2(6),fsum,ppinnb,s,wtot
 cc      SAVE /ppb1/
       common/ppmm/pprr,ppee,pppe,rpre,xopoe,rree
 cc      SAVE /ppmm/
       SAVE   
 
       s=srt**2
       nstate=0
       wtot=0.
       if(srt.le.thresh(1)) return
       do 1001 i=1,15
          weight(i)=0.
          if(srt.gt.thresh(i)) nstate=i
  1001 continue
       do 1002 i=1,nstate
          pf2=(s-(ppbm(i,1)+ppbm(i,2))**2)
      1        *(s-(ppbm(i,1)-ppbm(i,2))**2)/4/s
          weight(i)=pf2*niso(i)
          wtot=wtot+weight(i)
  1002 continue
       ene=(srt/pimass)**3/(6.*pi**2)
       fsum=factr2(2)+factr2(3)*ene+factr2(4)*ene**2
      1     +factr2(5)*ene**3+factr2(6)*ene**4
 
       return
       END
 
 *****************************************
 * for pion+pion-->Bbar B                                                      *
 c      real*4 function ppbbar(srt)
       real function ppbbar(srt)
 *****************************************
       parameter (pimass=0.140,arho=0.77,aomega=0.782)
       common/ppb1/ene,factr2(6),fsum,ppinnb,s,wtot
 cc      SAVE /ppb1/
       common/ppmm/pprr,ppee,pppe,rpre,xopoe,rree
 cc      SAVE /ppmm/
       SAVE   
 
       sppb2p=xppbar(srt)*factr2(2)/fsum
       pi2=(s-4*pimass**2)/4
       ppbbar=4./9.*sppb2p/pi2*wtot
 
       return
       END
 
 *****************************************
 * for pion+rho-->Bbar B                                                      *
 c      real*4 function prbbar(srt)
       real function prbbar(srt)
 *****************************************
       parameter (pimass=0.140,arho=0.77,aomega=0.782)
       common/ppb1/ene,factr2(6),fsum,ppinnb,s,wtot
 cc      SAVE /ppb1/
       common/ppmm/pprr,ppee,pppe,rpre,xopoe,rree
 cc      SAVE /ppmm/
       SAVE   
 
       sppb3p=xppbar(srt)*factr2(3)*ene/fsum
       pi2=(s-(pimass+arho)**2)*(s-(pimass-arho)**2)/4/s
       prbbar=4./27.*sppb3p/pi2*wtot
 
       return
       END
 
 *****************************************
 * for rho+rho-->Bbar B                                                      *
 c      real*4 function rrbbar(srt)
       real function rrbbar(srt)
 *****************************************
       parameter (pimass=0.140,arho=0.77,aomega=0.782)
       common/ppb1/ene,factr2(6),fsum,ppinnb,s,wtot
 cc      SAVE /ppb1/
       common/ppmm/pprr,ppee,pppe,rpre,xopoe,rree
 cc      SAVE /ppmm/
       SAVE   
 
       sppb4p=xppbar(srt)*factr2(4)*ene**2/fsum
       pi2=(s-4*arho**2)/4
       rrbbar=4./81.*(sppb4p/2)/pi2*wtot
 
       return
       END
 
 *****************************************
 * for pi+omega-->Bbar B                                                      *
 c      real*4 function pobbar(srt)
       real function pobbar(srt)
 *****************************************
       parameter (pimass=0.140,arho=0.77,aomega=0.782)
       common/ppb1/ene,factr2(6),fsum,ppinnb,s,wtot
 cc      SAVE /ppb1/
       common/ppmm/pprr,ppee,pppe,rpre,xopoe,rree
 cc      SAVE /ppmm/
       SAVE   
 
       sppb4p=xppbar(srt)*factr2(4)*ene**2/fsum
       pi2=(s-(pimass+aomega)**2)*(s-(pimass-aomega)**2)/4/s
       pobbar=4./9.*(sppb4p/2)/pi2*wtot
 
       return
       END
 
 *****************************************
 * for rho+omega-->Bbar B                                                      *
 c      real*4 function robbar(srt)
       real function robbar(srt)
 *****************************************
       parameter (pimass=0.140,arho=0.77,aomega=0.782)
       common/ppb1/ene,factr2(6),fsum,ppinnb,s,wtot
 cc      SAVE /ppb1/
       common/ppmm/pprr,ppee,pppe,rpre,xopoe,rree
 cc      SAVE /ppmm/
       SAVE   
 
       sppb5p=xppbar(srt)*factr2(5)*ene**3/fsum
       pi2=(s-(arho+aomega)**2)*(s-(arho-aomega)**2)/4/s
       robbar=4./27.*sppb5p/pi2*wtot
 
       return
       END
 
 *****************************************
 * for omega+omega-->Bbar B                                                    *
 c      real*4 function oobbar(srt)
       real function oobbar(srt)
 *****************************************
       parameter (pimass=0.140,arho=0.77,aomega=0.782)
       common/ppb1/ene,factr2(6),fsum,ppinnb,s,wtot
 cc      SAVE /ppb1/
       common/ppmm/pprr,ppee,pppe,rpre,xopoe,rree
 cc      SAVE /ppmm/
       SAVE   
 
       sppb6p=xppbar(srt)*factr2(6)*ene**4/fsum
       pi2=(s-4*aomega**2)/4
       oobbar=4./9.*sppb6p/pi2*wtot
 
       return
       END
 
 *****************************************
 * Generate final states for mm-->Bbar B                                       *
       SUBROUTINE bbarfs(lbb1,lbb2,ei1,ei2,iblock,iseed)
 *****************************************
       COMMON/ppbmas/niso(15),nstate,ppbm(15,2),thresh(15),weight(15)
 cc      SAVE /ppbmas/
       common/ppb1/ene,factr2(6),fsum,ppinnb,s,wtot
 cc      SAVE /ppb1/
       common/ppmm/pprr,ppee,pppe,rpre,xopoe,rree
 cc      SAVE /ppmm/
       COMMON/RNDF77/NSEED
 cc      SAVE /RNDF77/
       SAVE   
 
 c     determine which final BbarB channel occurs:
       rd=RANART(NSEED)
       wsum=0.
       do 1001 i=1,nstate
          wsum=wsum+weight(i)
          if(rd.le.(wsum/wtot)) then
             ifs=i
             ei1=ppbm(i,1)
             ei2=ppbm(i,2)
             goto 10
          endif
  1001 continue
  10   continue
 
 c1    pbar p
       if(ifs.eq.1) then
          iblock=1801
          lbb1=-1
          lbb2=1
       elseif(ifs.eq.2) then
 c2    pbar n
          if(RANART(NSEED).le.0.5) then
             iblock=18021
             lbb1=-1
             lbb2=2
 c2    nbar p
          else
             iblock=18022
             lbb1=1
             lbb2=-2
          endif
 c3    nbar n
       elseif(ifs.eq.3) then
          iblock=1803
          lbb1=-2
          lbb2=2
 c4&5  (pbar nbar) Delta, (p n) anti-Delta
       elseif(ifs.eq.4.or.ifs.eq.5) then
          rd=RANART(NSEED)
          if(rd.le.0.5) then
 c     (pbar nbar) Delta
             if(ifs.eq.4) then
                iblock=18041
                lbb1=-1
             else
                iblock=18051
                lbb1=-2
             endif
             rd2=RANART(NSEED)
             if(rd2.le.0.25) then
                lbb2=6
             elseif(rd2.le.0.5) then
                lbb2=7
             elseif(rd2.le.0.75) then
                lbb2=8
             else
                lbb2=9
             endif
          else
 c     (p n) anti-Delta
             if(ifs.eq.4) then
                iblock=18042
                lbb1=1
             else
                iblock=18052
                lbb1=2
             endif
             rd2=RANART(NSEED)
             if(rd2.le.0.25) then
                lbb2=-6
             elseif(rd2.le.0.5) then
                lbb2=-7
             elseif(rd2.le.0.75) then
                lbb2=-8
             else
                lbb2=-9
             endif
          endif
 c6&7  (pbar nbar) N*(1440), (p n) anti-N*(1440)
       elseif(ifs.eq.6.or.ifs.eq.7) then
          rd=RANART(NSEED)
          if(rd.le.0.5) then
 c     (pbar nbar) N*(1440)
             if(ifs.eq.6) then
                iblock=18061
                lbb1=-1
             else
                iblock=18071
                lbb1=-2
             endif
             rd2=RANART(NSEED)
             if(rd2.le.0.5) then
                lbb2=10
             else
                lbb2=11
             endif
          else
 c     (p n) anti-N*(1440)
             if(ifs.eq.6) then
                iblock=18062
                lbb1=1
             else
                iblock=18072
                lbb1=2
             endif
             rd2=RANART(NSEED)
             if(rd2.le.0.5) then
                lbb2=-10
             else
                lbb2=-11
             endif
          endif
 c8    Delta anti-Delta
       elseif(ifs.eq.8) then
          iblock=1808
          rd1=RANART(NSEED)
          if(rd1.le.0.25) then
             lbb1=6
          elseif(rd1.le.0.5) then
             lbb1=7
          elseif(rd1.le.0.75) then
             lbb1=8
          else
             lbb1=9
          endif
          rd2=RANART(NSEED)
          if(rd2.le.0.25) then
             lbb2=-6
          elseif(rd2.le.0.5) then
             lbb2=-7
          elseif(rd2.le.0.75) then
             lbb2=-8
          else
             lbb2=-9
          endif
 c9&10 (pbar nbar) N*(1535), (p n) anti-N*(1535)
       elseif(ifs.eq.9.or.ifs.eq.10) then
          rd=RANART(NSEED)
          if(rd.le.0.5) then
 c     (pbar nbar) N*(1440)
             if(ifs.eq.9) then
                iblock=18091
                lbb1=-1
             else
                iblock=18101
                lbb1=-2
             endif
             rd2=RANART(NSEED)
             if(rd2.le.0.5) then
                lbb2=12
             else
                lbb2=13
             endif
          else
 c     (p n) anti-N*(1535)
             if(ifs.eq.9) then
                iblock=18092
                lbb1=1
             else
                iblock=18102
                lbb1=2
             endif
             rd2=RANART(NSEED)
             if(rd2.le.0.5) then
                lbb2=-12
             else
                lbb2=-13
             endif
          endif
 c11&12 anti-Delta N*, Delta anti-N*
       elseif(ifs.eq.11.or.ifs.eq.12) then
          rd=RANART(NSEED)
          if(rd.le.0.5) then
 c     anti-Delta N*
             rd1=RANART(NSEED)
             if(rd1.le.0.25) then
                lbb1=-6
             elseif(rd1.le.0.5) then
                lbb1=-7
             elseif(rd1.le.0.75) then
                lbb1=-8
             else
                lbb1=-9
             endif
             if(ifs.eq.11) then
                iblock=18111
                rd2=RANART(NSEED)
                if(rd2.le.0.5) then
                   lbb2=10
                else
                   lbb2=11
                endif
             else
                iblock=18121
                rd2=RANART(NSEED)
                if(rd2.le.0.5) then
                   lbb2=12
                else
                   lbb2=13
                endif
             endif
          else
 c     Delta anti-N*
             rd1=RANART(NSEED)
             if(rd1.le.0.25) then
                lbb1=6
             elseif(rd1.le.0.5) then
                lbb1=7
             elseif(rd1.le.0.75) then
                lbb1=8
             else
                lbb1=9
             endif
             if(ifs.eq.11) then
                iblock=18112
                rd2=RANART(NSEED)
                if(rd2.le.0.5) then
                   lbb2=-10
                else
                   lbb2=-11
                endif
             else
                iblock=18122
                rd2=RANART(NSEED)
                if(rd2.le.0.5) then
                   lbb2=-12
                else
                   lbb2=-13
                endif
             endif
          endif
 c13   N*(1440) anti-N*(1440)
       elseif(ifs.eq.13) then
          iblock=1813
          rd1=RANART(NSEED)
          if(rd1.le.0.5) then
             lbb1=10
          else
             lbb1=11
          endif
          rd2=RANART(NSEED)
          if(rd2.le.0.5) then
             lbb2=-10
          else
             lbb2=-11
          endif
 c14   anti-N*(1440) N*(1535), N*(1440) anti-N*(1535)
       elseif(ifs.eq.14) then
          rd=RANART(NSEED)
          if(rd.le.0.5) then
 c     anti-N*(1440) N*(1535)
             iblock=18141
             rd1=RANART(NSEED)
             if(rd1.le.0.5) then
                lbb1=-10
             else
                lbb1=-11
             endif
             rd2=RANART(NSEED)
             if(rd2.le.0.5) then
                lbb2=12
             else
                lbb2=13
             endif
          else
 c     N*(1440) anti-N*(1535)
             iblock=18142
             rd1=RANART(NSEED)
             if(rd1.le.0.5) then
                lbb1=10
             else
                lbb1=11
             endif
             rd2=RANART(NSEED)
             if(rd2.le.0.5) then
                lbb2=-12
             else
                lbb2=-13
             endif
          endif
 c15   N*(1535) anti-N*(1535)
       elseif(ifs.eq.15) then
          iblock=1815
          rd1=RANART(NSEED)
          if(rd1.le.0.5) then
             lbb1=12
          else
             lbb1=13
          endif
          rd2=RANART(NSEED)
          if(rd2.le.0.5) then
             lbb2=-12
          else
             lbb2=-13
          endif
       else
       endif
 
       RETURN
       END
 
 *****************************************
 * for pi pi <-> rho rho cross sections
         SUBROUTINE spprr(lb1,lb2,srt)
         parameter (arho=0.77)
       common/ppb1/ene,factr2(6),fsum,ppinnb,s,wtot
 cc      SAVE /ppb1/
       common/ppmm/pprr,ppee,pppe,rpre,xopoe,rree
 cc      SAVE /ppmm/
       SAVE   
 
         pprr=0.
         if((lb1.ge.3.and.lb1.le.5).and.(lb2.ge.3.and.lb2.le.5)) then
 c     for now, rho mass taken to be the central value in these two processes
            if(srt.gt.(2*arho)) pprr=ptor(srt)
         elseif((lb1.ge.25.and.lb1.le.27).and.(lb2.ge.25.and.lb2.le.27)) 
      1          then
            pprr=rtop(srt)
         endif
 c
         return
         END
 
 *****************************************
 * for pi pi -> rho rho, determined from detailed balance
       real function ptor(srt)
 *****************************************
       parameter (pimass=0.140,arho=0.77)
       common/ppb1/ene,factr2(6),fsum,ppinnb,s,wtot
 cc      SAVE /ppb1/
       common/ppmm/pprr,ppee,pppe,rpre,xopoe,rree
 cc      SAVE /ppmm/
       SAVE   
 
       s2=srt**2
       ptor=9*(s2-4*arho**2)/(s2-4*pimass**2)*rtop(srt)
 
       return
       END
 
 *****************************************
 * for rho rho -> pi pi, assumed a constant cross section (in mb)
       real function rtop(srt)
 *****************************************
       rtop=5.
       return
       END
 
 *****************************************
 * for pi pi <-> rho rho final states
       SUBROUTINE pi2ro2(i1,i2,lbb1,lbb2,ei1,ei2,iblock,iseed)
       PARAMETER (MAXSTR=150001)
       PARAMETER (AP1=0.13496,AP2=0.13957)
       COMMON /EE/ ID(MAXSTR),LB(MAXSTR)
 cc      SAVE /EE/
       common/ppb1/ene,factr2(6),fsum,ppinnb,s,wtot
 cc      SAVE /ppb1/
       common/ppmm/pprr,ppee,pppe,rpre,xopoe,rree
 cc      SAVE /ppmm/
       COMMON/RNDF77/NSEED
 cc      SAVE /RNDF77/
       SAVE   
 
       if((lb(i1).ge.3.and.lb(i1).le.5)
      1     .and.(lb(i2).ge.3.and.lb(i2).le.5)) then
          iblock=1850
          ei1=0.77
          ei2=0.77
 c     for now, we don't check isospin states(allowing pi+pi+ & pi0pi0 -> 2rho)
 c     thus the cross sections used are considered as the isospin-averaged ones.
          lbb1=25+int(3*RANART(NSEED))
          lbb2=25+int(3*RANART(NSEED))
       elseif((lb(i1).ge.25.and.lb(i1).le.27)
      1     .and.(lb(i2).ge.25.and.lb(i2).le.27)) then
          iblock=1851
          lbb1=3+int(3*RANART(NSEED))
          lbb2=3+int(3*RANART(NSEED))
          ei1=ap2
          ei2=ap2
          if(lbb1.eq.4) ei1=ap1
          if(lbb2.eq.4) ei2=ap1
       endif
 
       return
       END
 
 *****************************************
 * for pi pi <-> eta eta cross sections
         SUBROUTINE sppee(lb1,lb2,srt)
         parameter (ETAM=0.5475)
       common/ppb1/ene,factr2(6),fsum,ppinnb,s,wtot
 cc      SAVE /ppb1/
       common/ppmm/pprr,ppee,pppe,rpre,xopoe,rree
 cc      SAVE /ppmm/
       SAVE   
 
         ppee=0.
         if((lb1.ge.3.and.lb1.le.5).and.(lb2.ge.3.and.lb2.le.5)) then
            if(srt.gt.(2*ETAM)) ppee=ptoe(srt)
         elseif(lb1.eq.0.and.lb2.eq.0) then
            ppee=etop(srt)
         endif
 
         return
         END
 
 *****************************************
 * for pi pi -> eta eta, determined from detailed balance, spin-isospin averaged
       real function ptoe(srt)
 *****************************************
       parameter (pimass=0.140,ETAM=0.5475)
       common/ppb1/ene,factr2(6),fsum,ppinnb,s,wtot
 cc      SAVE /ppb1/
       common/ppmm/pprr,ppee,pppe,rpre,xopoe,rree
 cc      SAVE /ppmm/
       SAVE   
 
       s2=srt**2
       ptoe=1./9.*(s2-4*etam**2)/(s2-4*pimass**2)*etop(srt)
 
       return
       END
 *****************************************
 * for eta eta -> pi pi, assumed a constant cross section (in mb)
       real function etop(srt)
 *****************************************
 
 c     eta equilibration:
 c     most important channel is found to be pi pi <-> pi eta, then
 c     rho pi <-> rho eta.
       etop=5.
       return
       END
 
 *****************************************
 * for pi pi <-> eta eta final states
       SUBROUTINE pi2et2(i1,i2,lbb1,lbb2,ei1,ei2,iblock,iseed)
       PARAMETER (MAXSTR=150001)
       PARAMETER (AP1=0.13496,AP2=0.13957,ETAM=0.5475)
       COMMON /EE/ ID(MAXSTR),LB(MAXSTR)
 cc      SAVE /EE/
       common/ppb1/ene,factr2(6),fsum,ppinnb,s,wtot
 cc      SAVE /ppb1/
       common/ppmm/pprr,ppee,pppe,rpre,xopoe,rree
 cc      SAVE /ppmm/
       COMMON/RNDF77/NSEED
 cc      SAVE /RNDF77/
       SAVE   
 
       if((lb(i1).ge.3.and.lb(i1).le.5)
      1     .and.(lb(i2).ge.3.and.lb(i2).le.5)) then
          iblock=1860
          ei1=etam
          ei2=etam
 c     for now, we don't check isospin states(allowing pi+pi+ & pi0pi0 -> 2rho)
 c     thus the cross sections used are considered as the isospin-averaged ones.
          lbb1=0
          lbb2=0
       elseif(lb(i1).eq.0.and.lb(i2).eq.0) then
          iblock=1861
          lbb1=3+int(3*RANART(NSEED))
          lbb2=3+int(3*RANART(NSEED))
          ei1=ap2
          ei2=ap2
          if(lbb1.eq.4) ei1=ap1
          if(lbb2.eq.4) ei2=ap1
       endif
 
       return
       END
 
 *****************************************
 * for pi pi <-> pi eta cross sections
         SUBROUTINE spppe(lb1,lb2,srt)
         parameter (pimass=0.140,ETAM=0.5475)
       common/ppb1/ene,factr2(6),fsum,ppinnb,s,wtot
 cc      SAVE /ppb1/
       common/ppmm/pprr,ppee,pppe,rpre,xopoe,rree
 cc      SAVE /ppmm/
       SAVE   
 
         pppe=0.
         if((lb1.ge.3.and.lb1.le.5).and.(lb2.ge.3.and.lb2.le.5)) then
            if(srt.gt.(ETAM+pimass)) pppe=pptope(srt)
         elseif((lb1.ge.3.and.lb1.le.5).and.lb2.eq.0) then
            pppe=petopp(srt)
         elseif((lb2.ge.3.and.lb2.le.5).and.lb1.eq.0) then
            pppe=petopp(srt)
         endif
 
         return
         END
 
 *****************************************
 * for pi pi -> pi eta, determined from detailed balance, spin-isospin averaged
       real function pptope(srt)
 *****************************************
       parameter (pimass=0.140,ETAM=0.5475)
       common/ppb1/ene,factr2(6),fsum,ppinnb,s,wtot
 cc      SAVE /ppb1/
       common/ppmm/pprr,ppee,pppe,rpre,xopoe,rree
 cc      SAVE /ppmm/
       SAVE   
 
       s2=srt**2
       pf2=(s2-(pimass+ETAM)**2)*(s2-(pimass-ETAM)**2)/2/sqrt(s2)
       pi2=(s2-4*pimass**2)*s2/2/sqrt(s2)
       pptope=1./3.*pf2/pi2*petopp(srt)
 
       return
       END
 *****************************************
 * for pi eta -> pi pi, assumed a constant cross section (in mb)
       real function petopp(srt)
 *****************************************
 
 c     eta equilibration:
       petopp=5.
       return
       END
 
 *****************************************
 * for pi pi <-> pi eta final states
       SUBROUTINE pi3eta(i1,i2,lbb1,lbb2,ei1,ei2,iblock,iseed)
       PARAMETER (MAXSTR=150001)
       PARAMETER (AP1=0.13496,AP2=0.13957,ETAM=0.5475)
       COMMON /EE/ ID(MAXSTR),LB(MAXSTR)
 cc      SAVE /EE/
       common/ppb1/ene,factr2(6),fsum,ppinnb,s,wtot
 cc      SAVE /ppb1/
       common/ppmm/pprr,ppee,pppe,rpre,xopoe,rree
 cc      SAVE /ppmm/
       COMMON/RNDF77/NSEED
 cc      SAVE /RNDF77/
       SAVE   
 
       if((lb(i1).ge.3.and.lb(i1).le.5)
      1     .and.(lb(i2).ge.3.and.lb(i2).le.5)) then
          iblock=1870
          ei1=ap2
          ei2=etam
 c     for now, we don't check isospin states(allowing pi+pi+ & pi0pi0 -> 2rho)
 c     thus the cross sections used are considered as the isospin-averaged ones.
          lbb1=3+int(3*RANART(NSEED))
          if(lbb1.eq.4) ei1=ap1
          lbb2=0
       elseif((lb(i1).ge.3.and.lb(i1).le.5.and.lb(i2).eq.0).or.
      1        (lb(i2).ge.3.and.lb(i2).le.5.and.lb(i1).eq.0)) then
          iblock=1871
          lbb1=3+int(3*RANART(NSEED))
          lbb2=3+int(3*RANART(NSEED))
          ei1=ap2
          ei2=ap2
          if(lbb1.eq.4) ei1=ap1
          if(lbb2.eq.4) ei2=ap1
       endif
 
       return
       END
 
 *****************************************
 * for rho pi <-> rho eta cross sections
         SUBROUTINE srpre(lb1,lb2,srt)
         parameter (pimass=0.140,ETAM=0.5475,arho=0.77)
         common/ppb1/ene,factr2(6),fsum,ppinnb,s,wtot
 cc      SAVE /ppb1/
         common/ppmm/pprr,ppee,pppe,rpre,xopoe,rree
 cc      SAVE /ppmm/
       SAVE   
 
         rpre=0.
         if(lb1.ge.25.and.lb1.le.27.and.lb2.ge.3.and.lb2.le.5) then
            if(srt.gt.(ETAM+arho)) rpre=rptore(srt)
         elseif(lb2.ge.25.and.lb2.le.27.and.lb1.ge.3.and.lb1.le.5) then
            if(srt.gt.(ETAM+arho)) rpre=rptore(srt)
         elseif(lb1.ge.25.and.lb1.le.27.and.lb2.eq.0) then
            if(srt.gt.(pimass+arho)) rpre=retorp(srt)
         elseif(lb2.ge.25.and.lb2.le.27.and.lb1.eq.0) then
            if(srt.gt.(pimass+arho)) rpre=retorp(srt)
         endif
 
         return
         END
 
 *****************************************
 * for rho pi->rho eta, determined from detailed balance, spin-isospin averaged
       real function rptore(srt)
 *****************************************
       parameter (pimass=0.140,ETAM=0.5475,arho=0.77)
       common/ppb1/ene,factr2(6),fsum,ppinnb,s,wtot
 cc      SAVE /ppb1/
       common/ppmm/pprr,ppee,pppe,rpre,xopoe,rree
 cc      SAVE /ppmm/
       SAVE   
 
       s2=srt**2
       pf2=(s2-(arho+ETAM)**2)*(s2-(arho-ETAM)**2)/2/sqrt(s2)
       pi2=(s2-(arho+pimass)**2)*(s2-(arho-pimass)**2)/2/sqrt(s2)
       rptore=1./3.*pf2/pi2*retorp(srt)
 
       return
       END
 *****************************************
 * for rho eta -> rho pi, assumed a constant cross section (in mb)
       real function retorp(srt)
 *****************************************
 
 c     eta equilibration:
       retorp=5.
       return
       END
 
 *****************************************
 * for rho pi <-> rho eta final states
       SUBROUTINE rpiret(i1,i2,lbb1,lbb2,ei1,ei2,iblock,iseed)
       PARAMETER (MAXSTR=150001)
       PARAMETER (AP1=0.13496,AP2=0.13957,ETAM=0.5475,arho=0.77)
       COMMON /EE/ ID(MAXSTR),LB(MAXSTR)
 cc      SAVE /EE/
       common/ppb1/ene,factr2(6),fsum,ppinnb,s,wtot
 cc      SAVE /ppb1/
       common/ppmm/pprr,ppee,pppe,rpre,xopoe,rree
 cc      SAVE /ppmm/
       COMMON/RNDF77/NSEED
 cc      SAVE /RNDF77/
       SAVE   
 
       if((lb(i1).ge.25.and.lb(i1).le.27
      1     .and.lb(i2).ge.3.and.lb(i2).le.5).or.
      2     (lb(i1).ge.3.and.lb(i1).le.5
      3     .and.lb(i2).ge.25.and.lb(i2).le.27)) then
          iblock=1880
          ei1=arho
          ei2=etam
 c     for now, we don't check isospin states(allowing pi+pi+ & pi0pi0 -> 2rho)
 c     thus the cross sections used are considered as the isospin-averaged ones.
          lbb1=25+int(3*RANART(NSEED))
          lbb2=0
       elseif((lb(i1).ge.25.and.lb(i1).le.27.and.lb(i2).eq.0).or.
      1        (lb(i2).ge.25.and.lb(i2).le.27.and.lb(i1).eq.0)) then
          iblock=1881
          lbb1=25+int(3*RANART(NSEED))
          lbb2=3+int(3*RANART(NSEED))
          ei1=arho
          ei2=ap2
          if(lbb2.eq.4) ei2=ap1
       endif
 
       return
       END
 
 *****************************************
 * for omega pi <-> omega eta cross sections
         SUBROUTINE sopoe(lb1,lb2,srt)
         parameter (ETAM=0.5475,aomega=0.782)
       common/ppb1/ene,factr2(6),fsum,ppinnb,s,wtot
 cc      SAVE /ppb1/
       common/ppmm/pprr,ppee,pppe,rpre,xopoe,rree
 cc      SAVE /ppmm/
       SAVE   
 
         xopoe=0.
         if((lb1.eq.28.and.lb2.ge.3.and.lb2.le.5).or.
      1       (lb2.eq.28.and.lb1.ge.3.and.lb1.le.5)) then
            if(srt.gt.(aomega+ETAM)) xopoe=xop2oe(srt)
         elseif((lb1.eq.28.and.lb2.eq.0).or.
      1          (lb1.eq.0.and.lb2.eq.28)) then
            if(srt.gt.(aomega+ETAM)) xopoe=xoe2op(srt)
         endif
 
         return
         END
 
 *****************************************
 * for omega pi -> omega eta, 
 c     determined from detailed balance, spin-isospin averaged
       real function xop2oe(srt)
 *****************************************
       parameter (pimass=0.140,ETAM=0.5475,aomega=0.782)
       common/ppb1/ene,factr2(6),fsum,ppinnb,s,wtot
 cc      SAVE /ppb1/
       common/ppmm/pprr,ppee,pppe,rpre,xopoe,rree
 cc      SAVE /ppmm/
       SAVE   
 
       s2=srt**2
       pf2=(s2-(aomega+ETAM)**2)*(s2-(aomega-ETAM)**2)/2/sqrt(s2)
       pi2=(s2-(aomega+pimass)**2)*(s2-(aomega-pimass)**2)/2/sqrt(s2)
       xop2oe=1./3.*pf2/pi2*xoe2op(srt)
 
       return
       END
 *****************************************
 * for omega eta -> omega pi, assumed a constant cross section (in mb)
       real function xoe2op(srt)
 *****************************************
 
 c     eta equilibration:
       xoe2op=5.
       return
       END
 
 *****************************************
 * for omega pi <-> omega eta final states
       SUBROUTINE opioet(i1,i2,lbb1,lbb2,ei1,ei2,iblock,iseed)
       PARAMETER (MAXSTR=150001)
       PARAMETER (AP1=0.13496,AP2=0.13957,ETAM=0.5475,aomega=0.782)
       COMMON /EE/ ID(MAXSTR),LB(MAXSTR)
 cc      SAVE /EE/
       common/ppb1/ene,factr2(6),fsum,ppinnb,s,wtot
 cc      SAVE /ppb1/
       common/ppmm/pprr,ppee,pppe,rpre,xopoe,rree
 cc      SAVE /ppmm/
       COMMON/RNDF77/NSEED
 cc      SAVE /RNDF77/
       SAVE   
 
       if((lb(i1).ge.3.and.lb(i1).le.5.and.lb(i2).eq.28).or.
      1     (lb(i2).ge.3.and.lb(i2).le.5.and.lb(i1).eq.28)) then
          iblock=1890
          ei1=aomega
          ei2=etam
 c     for now, we don't check isospin states(allowing pi+pi+ & pi0pi0 -> 2rho)
 c     thus the cross sections used are considered as the isospin-averaged ones.
          lbb1=28
          lbb2=0
       elseif((lb(i1).eq.28.and.lb(i2).eq.0).or.
      1        (lb(i1).eq.0.and.lb(i2).eq.28)) then
          iblock=1891
          lbb1=28
          lbb2=3+int(3*RANART(NSEED))
          ei1=aomega
          ei2=ap2
          if(lbb2.eq.4) ei2=ap1
       endif
 
       return
       END
 
 *****************************************
 * for rho rho <-> eta eta cross sections
         SUBROUTINE srree(lb1,lb2,srt)
         parameter (ETAM=0.5475,arho=0.77)
       common/ppb1/ene,factr2(6),fsum,ppinnb,s,wtot
 cc      SAVE /ppb1/
       common/ppmm/pprr,ppee,pppe,rpre,xopoe,rree
 cc      SAVE /ppmm/
       SAVE   
 
         rree=0.
         if(lb1.ge.25.and.lb1.le.27.and.
      1       lb2.ge.25.and.lb2.le.27) then
            if(srt.gt.(2*ETAM)) rree=rrtoee(srt)
         elseif(lb1.eq.0.and.lb2.eq.0) then
            if(srt.gt.(2*arho)) rree=eetorr(srt)
         endif
 
         return
         END
 
 *****************************************
 * for eta eta -> rho rho
 c     determined from detailed balance, spin-isospin averaged
       real function eetorr(srt)
 *****************************************
       parameter (ETAM=0.5475,arho=0.77)
       common/ppb1/ene,factr2(6),fsum,ppinnb,s,wtot
 cc      SAVE /ppb1/
       common/ppmm/pprr,ppee,pppe,rpre,xopoe,rree
 cc      SAVE /ppmm/
       SAVE   
 
       s2=srt**2
       eetorr=81.*(s2-4*arho**2)/(s2-4*etam**2)*rrtoee(srt)
 
       return
       END
 *****************************************
 * for rho rho -> eta eta, assumed a constant cross section (in mb)
       real function rrtoee(srt)
 *****************************************
 
 c     eta equilibration:
       rrtoee=5.
       return
       END
 
 *****************************************
 * for rho rho <-> eta eta final states
       SUBROUTINE ro2et2(i1,i2,lbb1,lbb2,ei1,ei2,iblock,iseed)
       PARAMETER (MAXSTR=150001)
       parameter (ETAM=0.5475,arho=0.77)
       COMMON /EE/ ID(MAXSTR),LB(MAXSTR)
 cc      SAVE /EE/
       common/ppb1/ene,factr2(6),fsum,ppinnb,s,wtot
 cc      SAVE /ppb1/
       common/ppmm/pprr,ppee,pppe,rpre,xopoe,rree
 cc      SAVE /ppmm/
       COMMON/RNDF77/NSEED
 cc      SAVE /RNDF77/
       SAVE   
 
       if(lb(i1).ge.25.and.lb(i1).le.27.and.
      1     lb(i2).ge.25.and.lb(i2).le.27) then
          iblock=1895
          ei1=etam
          ei2=etam
 c     for now, we don't check isospin states(allowing pi+pi+ & pi0pi0 -> 2rho)
 c     thus the cross sections used are considered as the isospin-averaged ones.
          lbb1=0
          lbb2=0
       elseif(lb(i1).eq.0.and.lb(i2).eq.0) then
          iblock=1896
          lbb1=25+int(3*RANART(NSEED))
          lbb2=25+int(3*RANART(NSEED))
          ei1=arho
          ei2=arho
       endif
 
       return
       END
 
 *****************************
 * purpose: Xsection for K* Kbar or K*bar K to pi(eta) rho(omega)
       SUBROUTINE XKKSAN(i1,i2,SRT,SIGKS1,SIGKS2,SIGKS3,SIGKS4,SIGK,prkk)
 *  srt    = DSQRT(s) in GeV                                       *
 *  sigk   = xsection in mb obtained from                          *
 *           the detailed balance                                  *
 * ***************************
           PARAMETER (AKA=0.498, PIMASS=0.140, RHOM = 0.770,aks=0.895,
      & OMEGAM = 0.7819, ETAM = 0.5473)
       PARAMETER (MAXSTR=150001)
       COMMON  /CC/      E(MAXSTR)
 cc      SAVE /CC/
       SAVE   
 
         S = SRT ** 2
        SIGKS1 = 1.E-08
        SIGKS2 = 1.E-08
        SIGKS3 = 1.E-08
        SIGKS4 = 1.E-08
 
         XPION0 = prkk
 clin note that prkk is for pi (rho omega) -> K* Kbar (AND!) K*bar K:
         XPION0 = XPION0/2
 
 cc
 c        PI2 = (S - (aks + AKA) ** 2) * (S - (aks - AKA) ** 2)
         PI2 = (S - (e(i1) + e(i2)) ** 2) * (S - (e(i1) - e(i2)) ** 2)
         SIGK = 1.E-08
         if(PI2 .le. 0.0) return
 
         XM1 = PIMASS
         XM2 = RHOM
         PF2 = (S - (XM1 + XM2) ** 2) * (S - (XM1 - XM2) ** 2)
         IF (PI2 .GT. 0.0 .AND. PF2 .GT. 0.0) THEN
            SIGKS1 = 27.0 / 4.0 * PF2 / PI2 * XPION0
         END IF
 
         XM1 = PIMASS
         XM2 = OMEGAM
         PF2 = (S - (XM1 + XM2) ** 2) * (S - (XM1 - XM2) ** 2)
         IF (PI2 .GT. 0.0 .AND. PF2 .GT. 0.0) THEN
            SIGKS2 = 9.0 / 4.0 * PF2 / PI2 * XPION0
         END IF
 
         XM1 = RHOM
         XM2 = ETAM
         PF2 = (S - (XM1 + XM2) ** 2) * (S - (XM1 - XM2) ** 2)
         IF (PF2 .GT. 0.0) THEN
            SIGKS3 = 9.0 / 4.0 * PF2 / PI2 * XPION0
         END IF
 
         XM1 = OMEGAM
         XM2 = ETAM
         PF2 = (S - (XM1 + XM2) ** 2) * (S - (XM1 - XM2) ** 2)
         IF (PF2 .GT. 0.0) THEN
            SIGKS4 = 3.0 / 4.0 * PF2 / PI2 * XPION0
         END IF
 
         SIGK=SIGKS1+SIGKS2+SIGKS3+SIGKS4
 
        RETURN
         END
 
 **********************************
 *     PURPOSE:                                                         *
 *     assign final states for KK*bar or K*Kbar --> light mesons
 *
 c      SUBROUTINE Crkspi(PX,PY,PZ,SRT,I1,I2,IBLOCK)
       SUBROUTINE crkspi(I1,I2,XSK1, XSK2, XSK3, XSK4, SIGK,
      & IBLOCK,lbp1,lbp2,emm1,emm2)
 *             iblock   - 466
 **********************************
         PARAMETER (MAXSTR=150001,MAXR=1)
           PARAMETER (AP1=0.13496,AP2=0.13957,RHOM = 0.770,PI=3.1415926)
         PARAMETER (AETA=0.548,AMOMGA=0.782)
         parameter (MX=4,MY=4,MZ=8,MPX=4,MPY=4,mpz=10,mpzp=10)
         COMMON /AA/ R(3,MAXSTR)
 cc      SAVE /AA/
         COMMON /BB/ P(3,MAXSTR)
 cc      SAVE /BB/
         COMMON /CC/ E(MAXSTR)
 cc      SAVE /CC/
         COMMON /EE/ ID(MAXSTR),LB(MAXSTR)
 cc      SAVE /EE/
         common/input1/ MASSPR,MASSTA,ISEED,IAVOID,DT
 cc      SAVE /input1/
       COMMON/RNDF77/NSEED
 cc      SAVE /RNDF77/
       SAVE   
 
        IBLOCK=466
 * charges of final state mesons:
 
         X1 = RANART(NSEED) * SIGK
         XSK2 = XSK1 + XSK2
         XSK3 = XSK2 + XSK3
         XSK4 = XSK3 + XSK4
         IF (X1 .LE. XSK1) THEN
            LB(I1) = 3 + int(3 * RANART(NSEED))
            LB(I2) = 25 + int(3 * RANART(NSEED))
            E(I1) = AP2
            E(I2) = rhom
         ELSE IF (X1 .LE. XSK2) THEN
            LB(I1) = 3 + int(3 * RANART(NSEED))
            LB(I2) = 28
            E(I1) = AP2
            E(I2) = AMOMGA
         ELSE IF (X1 .LE. XSK3) THEN
            LB(I1) = 0
            LB(I2) = 25 + int(3 * RANART(NSEED))
            E(I1) = AETA
            E(I2) = rhom
         ELSE
            LB(I1) = 0
            LB(I2) = 28
            E(I1) = AETA
            E(I2) = AMOMGA
         ENDIF
 
         if(lb(i1).eq.4) E(I1) = AP1
         lbp1=lb(i1)
         lbp2=lb(i2)
         emm1=e(i1)
         emm2=e(i2)
 
       RETURN
       END
 
 *---------------------------------------------------------------------------
 * PURPOSE : CALCULATE THE MASS AND MOMENTUM OF K* RESONANCE 
 *           AFTER PION + KAON COLLISION
 *clin only here the K* mass may be different from aks=0.895
         SUBROUTINE KSRESO(I1,I2)
         PARAMETER (MAXSTR=150001,MAXR=1,
      1  AMN=0.939457,AMP=0.93828,
      2  AP1=0.13496,AP2=0.13957,AM0=1.232,PI=3.1415926)
 clin-9/2012: improve precision for argument in sqrt():
         double precision e10,e20,scheck,p1,p2,p3
         COMMON /AA/ R(3,MAXSTR)
 cc      SAVE /AA/
         COMMON /BB/ P(3,MAXSTR)
 cc      SAVE /BB/
         COMMON /CC/ E(MAXSTR)
 cc      SAVE /CC/
         COMMON /EE/ ID(MAXSTR),LB(MAXSTR)
 cc      SAVE /EE/
         COMMON   /RUN/NUM
 cc      SAVE /RUN/
         COMMON   /PA/RPION(3,MAXSTR,MAXR)
 cc      SAVE /PA/
         COMMON   /PB/PPION(3,MAXSTR,MAXR)
 cc      SAVE /PB/
         COMMON   /PC/EPION(MAXSTR,MAXR)
 cc      SAVE /PC/
         COMMON   /PD/LPION(MAXSTR,MAXR)
 cc      SAVE /PD/
       SAVE   
 * 1. DETERMINE THE MOMENTUM COMPONENT OF THE K* IN THE CMS OF PI-K FRAME
 *    WE LET I1 TO BE THE K* AND ABSORB I2
 
 clin-9/2012: improve precision for argument in sqrt():
 c        E10=SQRT(E(I1)**2+P(1,I1)**2+P(2,I1)**2+P(3,I1)**2)
 c        E20=SQRT(E(I2)**2+P(1,I2)**2+P(2,I2)**2+P(3,I2)**2)
         E10=dSQRT(dble(E(I1))**2+dble(P(1,I1))**2
      1     +dble(P(2,I1))**2+dble(P(3,I1))**2)
         E20=dSQRT(dble(E(I2))**2+dble(P(1,I2))**2
      1       +dble(P(2,I2))**2+dble(P(3,I2))**2)
         p1=dble(P(1,I1))+dble(P(1,I2))
         p2=dble(P(2,I1))+dble(P(2,I2))
         p3=dble(P(3,I1))+dble(P(3,I2))
 
         IF(LB(I2) .EQ. 21 .OR. LB(I2) .EQ. 23) THEN
         E(I1)=0.
         I=I2
         ELSE
         E(I2)=0.
         I=I1
         ENDIF
         if(LB(I).eq.23) then
            LB(I)=30
         else if(LB(I).eq.21) then
            LB(I)=-30
         endif
         P(1,I)=P(1,I1)+P(1,I2)
         P(2,I)=P(2,I1)+P(2,I2)
         P(3,I)=P(3,I1)+P(3,I2)
 * 2. DETERMINE THE MASS OF K* BY USING THE REACTION KINEMATICS
 
 clin-9/2012: check argument in sqrt():
         scheck=(E10+E20)**2-p1**2-p2**2-p3**2
         if(scheck.lt.0) then
            write(99,*) 'scheck49: ',scheck
            write(99,*) 'scheck49',scheck,E10,E20,P(1,I),P(2,I),P(3,I)
            write(99,*) 'scheck49-1',E(I1),P(1,I1),P(2,I1),P(3,I1)
            write(99,*) 'scheck49-2',E(I2),P(1,I2),P(2,I2),P(3,I2)
         endif
         DM=sqrt(sngl(scheck))
 c        DM=SQRT((E10+E20)**2-P(1,I)**2-P(2,I)**2-P(3,I)**2)
 
         E(I)=DM
         RETURN
         END
 
 c--------------------------------------------------------
 *************************************
 *                                                                         *
       SUBROUTINE pertur(PX,PY,PZ,SRT,IRUN,I1,I2,nt,kp,icont)
 *                                                                         *
 *       PURPOSE:   TO PRODUCE CASCADE AND OMEGA PERTURBATIVELY            *
 c sp 01/03/01
 *                   40 cascade-
 *                  -40 cascade-(bar)
 *                   41 cascade0
 *                  -41 cascade0(bar)
 *                   45 Omega baryon
 *                  -45 Omega baryon(bar)
 *                   44 Di-Omega
 **********************************
       PARAMETER      (MAXSTR=150001,MAXR=1,PI=3.1415926)
       parameter      (MX=4,MY=4,MZ=8,MPX=4,MPY=4,mpz=10,mpzp=10)
       PARAMETER (AMN=0.939457,AMP=0.93828,AP1=0.13496,AP2=0.13957)
       PARAMETER      (AKA=0.498,ALA=1.1157,ASA=1.1974,aks=0.895)
       PARAMETER      (ACAS=1.3213,AOME=1.6724,AMRHO=0.769,AMOMGA=0.782)
       PARAMETER      (AETA=0.548,ADIOMG=3.2288)
       parameter            (maxx=20,maxz=24)
       COMMON   /AA/  R(3,MAXSTR)
 cc      SAVE /AA/
       COMMON   /BB/  P(3,MAXSTR)
 cc      SAVE /BB/
       COMMON   /CC/  E(MAXSTR)
 cc      SAVE /CC/
       COMMON   /EE/  ID(MAXSTR),LB(MAXSTR)
 cc      SAVE /EE/
       COMMON   /HH/  PROPER(MAXSTR)
 cc      SAVE /HH/
       common /ff/f(-mx:mx,-my:my,-mz:mz,-mpx:mpx,-mpy:mpy,-mpz:mpzp)
 cc      SAVE /ff/
       common   /gg/  dx,dy,dz,dpx,dpy,dpz
 cc      SAVE /gg/
       COMMON   /INPUT/ NSTAR,NDIRCT,DIR
 cc      SAVE /INPUT/
       COMMON   /NN/NNN
 cc      SAVE /NN/
       COMMON   /PA/RPION(3,MAXSTR,MAXR)
 cc      SAVE /PA/
       COMMON   /PB/PPION(3,MAXSTR,MAXR)
 cc      SAVE /PB/
       COMMON   /PC/EPION(MAXSTR,MAXR)
 cc      SAVE /PC/
       COMMON   /PD/LPION(MAXSTR,MAXR)
 cc      SAVE /PD/
       COMMON   /PE/PROPI(MAXSTR,MAXR)
 cc      SAVE /PE/
       COMMON   /RR/  MASSR(0:MAXR)
 cc      SAVE /RR/
       COMMON   /BG/BETAX,BETAY,BETAZ,GAMMA
 cc      SAVE /BG/
       common/input1/ MASSPR,MASSTA,ISEED,IAVOID,DT
 cc      SAVE /input1/
 c     perturbative method is disabled:
 c      common /imulst/ iperts
 c
       COMMON/RNDF77/NSEED
 cc      SAVE /RNDF77/
       COMMON /dpert/dpertt(MAXSTR,MAXR),dpertp(MAXSTR),dplast(MAXSTR),
      1     dpdcy(MAXSTR),dpdpi(MAXSTR,MAXR),dpt(MAXSTR, MAXR),
      2     dpp1(MAXSTR,MAXR),dppion(MAXSTR,MAXR)
       SAVE   
 
       px0 = px
       py0 = py
       pz0 = pz
       LB1 = LB(I1)
       EM1 = E(I1)
       X1  = R(1,I1)
       Y1  = R(2,I1)
       Z1  = R(3,I1)
       prob1 = PROPER(I1)
 c     
       LB2 = LB(I2)
       EM2 = E(I2)
       X2  = R(1,I2)
       Y2  = R(2,I2)
       Z2  = R(3,I2)
       prob2 = PROPER(I2)
 c
 c                 !! flag for real 2-body process (1/0=no/yes)
       icont = 1
 c                !! flag for elastic scatt only (-1=no)
       icsbel = -1
 
 * K-/K*0bar + La/Si --> cascade + pi
 * K+/K*0 + La/Si (bar) --> cascade-bar + pi
        if( (lb1.eq.21.or.lb1.eq.23.or.iabs(lb1).eq.30) .and.
      &     (iabs(lb2).ge.14.and.iabs(lb2).le.17) )go to 60
        if( (lb2.eq.21.or.lb2.eq.23.or.iabs(lb2).eq.30) .and.
      &     (iabs(lb1).ge.14.and.iabs(lb1).le.17) )go to 60
 * K-/K*0bar + cascade --> omega + pi
 * K+/K*0 + cascade-bar --> omega-bar + pi
         if( (lb1.eq.21.or.lb1.eq.23.or.iabs(lb1).eq.30) .and.
      &      (iabs(lb2).eq.40.or.iabs(lb2).eq.41) )go to 70
         if( (lb2.eq.21.or.lb2.eq.23.or.iabs(lb2).eq.30) .and.
      &      (iabs(lb1).eq.40.or.iabs(lb1).eq.41) )go to 70
 c
 c annhilation of cascade,cascade-bar, omega,omega-bar
 c
 * K- + La/Si <-- cascade + pi(eta,rho,omega)
 * K+ + La/Si(bar) <-- cascade-bar + pi(eta,rho,omega)
        if( (((lb1.ge.3.and.lb1.le.5).or.lb1.eq.0) 
      &        .and.(iabs(lb2).eq.40.or.iabs(lb2).eq.41))
      & .OR. (((lb2.ge.3.and.lb2.le.5).or.lb2.eq.0) 
      &        .and.(iabs(lb1).eq.40.or.iabs(lb1).eq.41)) )go to 90
 * K- + cascade <-- omega + pi
 * K+ + cascade-bar <-- omega-bar + pi
 c         if( (lb1.eq.0.and.iabs(lb2).eq.45)
 c    &    .OR. (lb2.eq.0.and.iabs(lb1).eq.45) ) go to 110
        if( ((lb1.ge.3.and.lb1.le.5).and.iabs(lb2).eq.45)
      & .OR.((lb2.ge.3.and.lb2.le.5).and.iabs(lb1).eq.45) )go to 110
 c
 
 c----------------------------------------------------
 *  for process:  K-bar + L(S) --> Ca + pi 
 *
 60         if(iabs(lb1).ge.14 .and. iabs(lb1).le.17)then 
              asap = e(i1)
              akap = e(i2)
              idp = i1
            else
              asap = e(i2)
              akap = e(i1)
              idp = i2
            endif
           app = 0.138
          if(srt .lt. (acas+app))return
           srrt = srt - (acas+app) + (amn+akap)
           pkaon = sqrt(((srrt**2-(amn**2+akap**2))/2./amn)**2 - akap**2)
           sigca = 1.5*( akNPsg(pkaon)+akNPsg(pkaon) )
 clin pii & pff should be each divided by (4*srt**2), 
 c     but these two factors cancel out in the ratio pii/pff:
           pii = sqrt((srt**2-(amn+akap)**2)*(srt**2-(amn-akap)**2))
           pff = sqrt((srt**2-(asap+app)**2)*(srt**2-(asap-app)**2))
          cmat = sigca*pii/pff
          sigpi = cmat*
      &            sqrt((srt**2-(acas+app)**2)*(srt**2-(acas-app)**2))/
      &            sqrt((srt**2-(asap+akap)**2)*(srt**2-(asap-akap)**2))
 c 
          sigeta = 0.
         if(srt .gt. (acas+aeta))then
            srrt = srt - (acas+aeta) + (amn+akap)
          pkaon = sqrt(((srrt**2-(amn**2+akap**2))/2./amn)**2 - akap**2)
             sigca = 1.5*( akNPsg(pkaon)+akNPsg(pkaon) )
          cmat = sigca*pii/pff
          sigeta = cmat*
      &            sqrt((srt**2-(acas+aeta)**2)*(srt**2-(acas-aeta)**2))/
      &            sqrt((srt**2-(asap+akap)**2)*(srt**2-(asap-akap)**2))
         endif
 c
          sigca = sigpi + sigeta
          sigpe = 0.
 clin-2/25/03 disable the perturb option:
 c        if(iperts .eq. 1) sigpe = 40.   !! perturbative xsecn
            sig = amax1(sigpe,sigca)     
          ds = sqrt(sig/31.4)
          dsr = ds + 0.1
          ec = (em1+em2+0.02)**2
          call distce(i1,i2,dsr,ds,dt,ec,srt,ic,px,py,pz)
            if(ic .eq. -1)return
           brpp = sigca/sig
 c
 c else particle production
           if( (lb1.ge.14.and.lb1.le.17) .or.
      &          (lb2.ge.14.and.lb2.le.17) )then
 c   !! cascade- or cascde0
             lbpp1 = 40 + int(2*RANART(NSEED))
           else
 * elseif(lb1 .eq. -14 .or. lb2 .eq. -14)
 c     !! cascade-bar- or cascde0 -bar
             lbpp1 = -40 - int(2*RANART(NSEED))
           endif
               empp1 = acas
            if(RANART(NSEED) .lt. sigpi/sigca)then
 c    !! pion
             lbpp2 = 3 + int(3*RANART(NSEED))
             empp2 = 0.138
            else
 c    !! eta
             lbpp2 = 0
             empp2 = aeta
            endif        
 c* check real process of cascade(bar) and pion formation
           if(RANART(NSEED) .lt. brpp)then
 c       !! real process flag
             icont = 0
             lb(i1) = lbpp1
             e(i1) = empp1
 c  !! cascade formed with prob Gam
             proper(i1) = brpp
             lb(i2) = lbpp2
             e(i2) = empp2
 c         !! pion/eta formed with prob 1.
             proper(i2) = 1.
            endif
 c else only cascade(bar) formed perturbatively
              go to 700
             
 c----------------------------------------------------
 *  for process:  Cas(bar) + K_bar(K) --> Om(bar) + pi  !! eta
 *
 70         if(iabs(lb1).eq.40 .or. iabs(lb1).eq.41)then 
              acap = e(i1)
              akap = e(i2)
              idp = i1
            else
              acap = e(i2)
              akap = e(i1)
              idp = i2
            endif
            app = 0.138
 *         ames = aeta
 c  !! only pion
            ames = 0.138
          if(srt .lt. (aome+ames))return 
           srrt = srt - (aome+ames) + (amn+akap)
          pkaon = sqrt(((srrt**2-(amn**2+akap**2))/2./amn)**2 - akap**2)
 c use K(bar) + Ca --> Om + eta  xsecn same as  K(bar) + N --> Si + Pi
 *  as Omega have no resonances
 c** using same matrix elements as K-bar + N -> Si + pi
          sigomm = 1.5*( akNPsg(pkaon)+akNPsg(pkaon) )
          cmat = sigomm*
      &          sqrt((srt**2-(amn+akap)**2)*(srt**2-(amn-akap)**2))/
      &          sqrt((srt**2-(asa+app)**2)*(srt**2-(asa-app)**2))
         sigom = cmat*
      &           sqrt((srt**2-(aome+ames)**2)*(srt**2-(aome-ames)**2))/
      &           sqrt((srt**2-(acap+akap)**2)*(srt**2-(acap-akap)**2))
           sigpe = 0.
 clin-2/25/03 disable the perturb option:
 c         if(iperts .eq. 1) sigpe = 40.   !! perturbative xsecn
           sig = amax1(sigpe,sigom)     
          ds = sqrt(sig/31.4)
          dsr = ds + 0.1
          ec = (em1+em2+0.02)**2
          call distce(i1,i2,dsr,ds,dt,ec,srt,ic,px,py,pz)
            if(ic .eq. -1)return
            brpp = sigom/sig
 c
 c else particle production
            if( (lb1.ge.40.and.lb1.le.41) .or.
      &           (lb2.ge.40.and.lb2.le.41) )then
 c    !! omega
             lbpp1 = 45
            else
 * elseif(lb1 .eq. -40 .or. lb2 .eq. -40)
 c    !! omega-bar
             lbpp1 = -45
            endif
            empp1 = aome
 *           lbpp2 = 0    !! eta
 c    !! pion
            lbpp2 = 3 + int(3*RANART(NSEED))
            empp2 = ames
 c
 c* check real process of omega(bar) and pion formation
            xrand=RANART(NSEED)
          if(xrand .lt. (proper(idp)*brpp))then
 c       !! real process flag
             icont = 0
             lb(i1) = lbpp1
             e(i1) = empp1
 c  !! P_Om = P_Cas*Gam
             proper(i1) = proper(idp)*brpp
             lb(i2) = lbpp2
             e(i2) = empp2
 c   !! pion formed with prob 1.
             proper(i2) = 1.
           elseif(xrand.lt.brpp) then
 c else omega(bar) formed perturbatively and cascade destroyed
              e(idp) = 0.
           endif
              go to 700
             
 c-----------------------------------------------------------
 *  for process:  Ca + pi/eta --> K-bar + L(S)
 *
 90         if(iabs(lb1).eq.40 .or. iabs(lb1).eq.41)then 
              acap = e(i1)
              app = e(i2)
              idp = i1
              idn = i2
            else
              acap = e(i2)
              app = e(i1)
              idp = i2
              idn = i1
            endif
 c            akal = (aka+aks)/2.  !! average of K and K* taken
 c  !! using K only
             akal = aka
 c
          alas = ala
        if(srt .le. (alas+aka))return
            srrt = srt - (acap+app) + (amn+aka)
          pkaon = sqrt(((srrt**2-(amn**2+aka**2))/2./amn)**2 - aka**2)
 c** using same matrix elements as K-bar + N -> La/Si + pi
          sigca = 1.5*( akNPsg(pkaon)+akNPsg(pkaon) )
          cmat = sigca*
      &          sqrt((srt**2-(amn+aka)**2)*(srt**2-(amn-aka)**2))/
      &          sqrt((srt**2-(alas+0.138)**2)*(srt**2-(alas-0.138)**2))
          sigca = cmat*
      &            sqrt((srt**2-(acap+app)**2)*(srt**2-(acap-app)**2))/
      &            sqrt((srt**2-(alas+aka)**2)*(srt**2-(alas-aka)**2))
 c    !! pi
             dfr = 1./3.
 c       !! eta
            if(lb(idn).eq.0)dfr = 1.
         sigcal = sigca*dfr*(srt**2-(alas+aka)**2)*
      &           (srt**2-(alas-aka)**2)/(srt**2-(acap+app)**2)/
      &           (srt**2-(acap-app)**2)
 c
           alas = ASA
        if(srt .le. (alas+aka))then
          sigcas = 0.
        else
            srrt = srt - (acap+app) + (amn+aka)
         pkaon = sqrt(((srrt**2-(amn**2+aka**2))/2./amn)**2 - aka**2)
 c use K(bar) + La/Si --> Ca + Pi  xsecn same as  K(bar) + N --> Si + Pi
 c** using same matrix elements as K-bar + N -> La/Si + pi
           sigca = 1.5*( akNPsg(pkaon)+akNPsg(pkaon) )
          cmat = sigca*
      &          sqrt((srt**2-(amn+aka)**2)*(srt**2-(amn-aka)**2))/
      &          sqrt((srt**2-(alas+0.138)**2)*(srt**2-(alas-0.138)**2))
          sigca = cmat*
      &            sqrt((srt**2-(acap+app)**2)*(srt**2-(acap-app)**2))/
      &            sqrt((srt**2-(alas+aka)**2)*(srt**2-(alas-aka)**2))
 c    !! pi
             dfr = 1.
 c    !! eta
            if(lb(idn).eq.0)dfr = 3.
         sigcas = sigca*dfr*(srt**2-(alas+aka)**2)*
      &           (srt**2-(alas-aka)**2)/(srt**2-(acap+app)**2)/
      &           (srt**2-(acap-app)**2)
        endif
 c
          sig = sigcal + sigcas
          brpp = 1.                                                   
          ds = sqrt(sig/31.4)
          dsr = ds + 0.1
          ec = (em1+em2+0.02)**2
          call distce(i1,i2,dsr,ds,dt,ec,srt,ic,px,py,pz)
 c
 clin-2/25/03: checking elastic scatt after failure of inelastic scatt gives 
 c     conditional probability (in general incorrect), tell Pal to correct:
        if(ic .eq. -1)then
 c check for elastic scatt, no particle annhilation
 c  !! elastic cross section of 20 mb
          ds = sqrt(20.0/31.4)
          dsr = ds + 0.1
          call distce(i1,i2,dsr,ds,dt,ec,srt,icsbel,px,py,pz)
            if(icsbel .eq. -1)return
             empp1 = EM1
             empp2 = EM2
              go to 700
        endif
 c
 c else pert. produced cascade(bar) is annhilated OR real process
 c
 * DECIDE LAMBDA OR SIGMA PRODUCTION
 c
        IF(sigcal/sig .GT. RANART(NSEED))THEN  
           if(lb1.eq.40.or.lb1.eq.41.or.lb2.eq.40.or.lb2.eq.41)then
           lbpp1 = 21
            lbpp2 = 14
           else
            lbpp1 = 23
            lbpp2 = -14
           endif
          alas = ala
        ELSE
           if(lb1.eq.40.or.lb1.eq.41.or.lb2.eq.40.or.lb2.eq.41)then
            lbpp1 = 21
             lbpp2 = 15 + int(3 * RANART(NSEED))
           else
             lbpp1 = 23
             lbpp2 = -15 - int(3 * RANART(NSEED))
           endif
          alas = ASA       
         ENDIF
              empp1 = aka  
              empp2 = alas 
 c
 c check for real process for L/S(bar) and K(bar) formation
           if(RANART(NSEED) .lt. proper(idp))then
 * real process
 c       !! real process flag
             icont = 0
             lb(i1) = lbpp1
             e(i1) = empp1
 c   !! K(bar) formed with prob 1.
             proper(i1) = 1.
             lb(i2) = lbpp2
             e(i2) = empp2
 c   !! L/S(bar) formed with prob 1.
             proper(i2) = 1.
              go to 700
            else
 c else only cascade(bar) annhilation & go out
             e(idp) = 0.
            endif
           return
 c
 c----------------------------------------------------
 *  for process:  Om(bar) + pi --> Cas(bar) + K_bar(K)
 *
 110         if(lb1 .eq. 45 .or. lb1 .eq. -45)then 
              aomp = e(i1)
              app = e(i2)
              idp = i1
              idn = i2
            else
              aomp = e(i2)
              app = e(i1)
              idp = i2
              idn = i1
            endif
 c            akal = (aka+aks)/2.  !! average of K and K* taken 
 c  !! using K only
             akal = aka
        if(srt .le. (acas+aka))return
            srrt = srt - (aome+app) + (amn+aka)
          pkaon = sqrt(((srrt**2-(amn**2+aka**2))/2./amn)**2 - aka**2)
 c use K(bar) + Ca --> Om + eta  xsecn same as  K(bar) + N --> Si + Pi
 c** using same matrix elements as K-bar + N -> La/Si + pi
            sigca = 1.5*( akNPsg(pkaon)+akNPsg(pkaon) )
          cmat = sigca*
      &          sqrt((srt**2-(amn+aka)**2)*(srt**2-(amn-aka)**2))/
      &          sqrt((srt**2-(asa+0.138)**2)*(srt**2-(asa-0.138)**2))
          sigom = cmat*
      &            sqrt((srt**2-(aomp+app)**2)*(srt**2-(aomp-app)**2))/
      &            sqrt((srt**2-(acas+aka)**2)*(srt**2-(acas-aka)**2))
 c            dfr = 2.    !! eta
 c    !! pion
            dfr = 2./3.
         sigom = sigom*dfr*(srt**2-(acas+aka)**2)*
      &           (srt**2-(acas-aka)**2)/(srt**2-(aomp+app)**2)/
      &           (srt**2-(aomp-app)**2)
 c                                                                         
          brpp = 1.
          ds = sqrt(sigom/31.4)
          dsr = ds + 0.1
          ec = (em1+em2+0.02)**2
          call distce(i1,i2,dsr,ds,dt,ec,srt,ic,px,py,pz)
 c
 clin-2/25/03: checking elastic scatt after failure of inelastic scatt gives 
 c     conditional probability (in general incorrect), tell Pal to correct:
        if(ic .eq. -1)then
 c check for elastic scatt, no particle annhilation
 c  !! elastic cross section of 20 mb
          ds = sqrt(20.0/31.4)
          dsr = ds + 0.1
          call distce(i1,i2,dsr,ds,dt,ec,srt,icsbel,px,py,pz)
            if(icsbel .eq. -1)return
             empp1 = EM1
             empp2 = EM2
              go to 700
        endif
 c
 c else pert. produced omega(bar) annhilated  OR real process
 c annhilate only pert. omega, rest from hijing go out WITHOUT annhil.
            if(lb1.eq.45 .or. lb2.eq.45)then
 c  !! Ca
              lbpp1 = 40 + int(2*RANART(NSEED))
 c   !! K-
              lbpp2 = 21
             else
 * elseif(lb1 .eq. -45 .or. lb2 .eq. -45)
 c    !! Ca-bar
             lbpp1 = -40 - int(2*RANART(NSEED))
 c      !! K+
             lbpp2 = 23
            endif
              empp1 = acas
              empp2 = aka  
 c
 c check for real process for Cas(bar) and K(bar) formation
           if(RANART(NSEED) .lt. proper(idp))then
 c       !! real process flag
             icont = 0
             lb(i1) = lbpp1
             e(i1) = empp1
 c   !! P_Cas(bar) = P_Om(bar)
             proper(i1) = proper(idp)
             lb(i2) = lbpp2
             e(i2) = empp2
 c   !! K(bar) formed with prob 1.
             proper(i2) = 1.
 c
            else
 c else Cascade(bar)  produced and Omega(bar) annhilated
             e(idp) = 0.
            endif
 c   !! for produced particles
              go to 700
 c
 c-----------------------------------------------------------
 700    continue
 * CALCULATE THE MAGNITUDE OF THE FINAL MOMENTUM THROUGH
 * ENERGY CONSERVATION
           PR2   = (SRT**2 - EMpp1**2 - EMpp2**2)**2
      &                - 4.0 * (EMpp1*EMpp2)**2
           IF(PR2.LE.0.)PR2=0.00000001
           PR=SQRT(PR2)/(2.*SRT)
 * using isotropic
       C1   = 1.0 - 2.0 * RANART(NSEED)
       T1   = 2.0 * PI * RANART(NSEED)
       S1   = SQRT( 1.0 - C1**2 )
       CT1  = COS(T1)
       ST1  = SIN(T1)
 * THE MOMENTUM IN THE CMS IN THE FINAL STATE
       PZ   = PR * C1
       PX   = PR * S1*CT1 
       PY   = PR * S1*ST1
 * ROTATE IT 
        CALL ROTATE(PX0,PY0,PZ0,PX,PY,PZ) 
        if(icont .eq. 0)return
 c
 * LORENTZ-TRANSFORMATION INTO CMS FRAME
               E1CM    = SQRT (EMpp1**2 + PX**2 + PY**2 + PZ**2)
               P1BETA  = PX*BETAX + PY*BETAY + PZ*BETAZ
               TRANSF  = GAMMA * ( GAMMA * P1BETA / (GAMMA + 1) + E1CM )
               Ppt11 = BETAX * TRANSF + PX
               Ppt12 = BETAY * TRANSF + PY
               Ppt13 = BETAZ * TRANSF + PZ
 c
 cc** for elastic scattering update the momentum of pertb particles
          if(icsbel .ne. -1)then
 c            if(EMpp1 .gt. 0.9)then
               p(1,i1) = Ppt11
               p(2,i1) = Ppt12
               p(3,i1) = Ppt13
 c            else
               E2CM    = SQRT (EMpp2**2 + PX**2 + PY**2 + PZ**2)
               TRANSF  = GAMMA * ( -GAMMA * P1BETA / (GAMMA + 1) + E2CM )
               Ppt21 = BETAX * TRANSF - PX
               Ppt22 = BETAY * TRANSF - PY
               Ppt23 = BETAZ * TRANSF - PZ
               p(1,i2) = Ppt21
               p(2,i2) = Ppt22
               p(3,i2) = Ppt23
 c            endif
              return
           endif
 clin-5/2008:
 c2008        X01 = 1.0 - 2.0 * RANART(NSEED)
 c            Y01 = 1.0 - 2.0 * RANART(NSEED)
 c            Z01 = 1.0 - 2.0 * RANART(NSEED)
 c        IF ((X01*X01+Y01*Y01+Z01*Z01) .GT. 1.0) GOTO 2008
 c                Xpt=X1+0.5*x01
 c                Ypt=Y1+0.5*y01
 c                Zpt=Z1+0.5*z01
                 Xpt=X1
                 Ypt=Y1
                 Zpt=Z1
 c
 c
 c          if(lbpp1 .eq. 45)then
 c           write(*,*)'II lb1,lb2,lbpp1,empp1,proper(idp),brpp'
 c           write(*,*)lb1,lb2,lbpp1,empp1,proper(idp),brpp
 c          endif
 c
                NNN=NNN+1
                PROPI(NNN,IRUN)= proper(idp)*brpp
                LPION(NNN,IRUN)= lbpp1
                EPION(NNN,IRUN)= empp1
                 RPION(1,NNN,IRUN)=Xpt
                 RPION(2,NNN,IRUN)=Ypt
                 RPION(3,NNN,IRUN)=Zpt
                PPION(1,NNN,IRUN)=Ppt11
                PPION(2,NNN,IRUN)=Ppt12
                PPION(3,NNN,IRUN)=Ppt13
 clin-5/2008:
                dppion(nnn,irun)=dpertp(i1)*dpertp(i2)
             RETURN
             END
 **********************************
 *  sp 12/08/00                                                         *
       SUBROUTINE Crhb(PX,PY,PZ,SRT,I1,I2,IBLOCK)
 *     PURPOSE:                                                         *
 *        DEALING WITH hyperon+N(D,N*)->hyp+N(D,N*) elastic PROCESS     *
 *     NOTE   :                                                         *
 *          
 *     QUANTITIES:                                                 *
 *           PX,PY,PZ - MOMENTUM COORDINATES OF ONE PARTICLE IN CM FRAME*
 *           SRT      - SQRT OF S                                       *
 *           IBLOCK   - THE INFORMATION BACK                            *
 *                     144-> hyp+N(D,N*)->hyp+N(D,N*)
 **********************************
         PARAMETER (MAXSTR=150001,MAXR=1,AMN=0.939457,
      1  AMP=0.93828,AP1=0.13496,
      2  AP2=0.13957,AM0=1.232,PI=3.1415926,CUTOFF=1.8966,AVMASS=0.9383)
         PARAMETER      (AKA=0.498,ALA=1.1157,ASA=1.1974)
         parameter     (MX=4,MY=4,MZ=8,MPX=4,MPY=4,mpz=10,mpzp=10)
         COMMON /AA/ R(3,MAXSTR)
 cc      SAVE /AA/
         COMMON /BB/ P(3,MAXSTR)
 cc      SAVE /BB/
         COMMON /CC/ E(MAXSTR)
 cc      SAVE /CC/
         COMMON /EE/ ID(MAXSTR),LB(MAXSTR)
 cc      SAVE /EE/
         common/input1/ MASSPR,MASSTA,ISEED,IAVOID,DT
 cc      SAVE /input1/
       COMMON/RNDF77/NSEED
 cc      SAVE /RNDF77/
       SAVE   
 
        PX0=PX
        PY0=PY
        PZ0=PZ
 *-----------------------------------------------------------------------
         IBLOCK=144
         NTAG=0
         EM1=E(I1)
         EM2=E(I2)
 *-----------------------------------------------------------------------
 * CALCULATE THE MAGNITUDE OF THE FINAL MOMENTUM THROUGH
 * ENERGY CONSERVATION
           PR2   = (SRT**2 - EM1**2 - EM2**2)**2
      1                - 4.0 * (EM1*EM2)**2
           IF(PR2.LE.0.)PR2=1.e-09
           PR=SQRT(PR2)/(2.*SRT)
           C1   = 1.0 - 2.0 * RANART(NSEED)
           T1   = 2.0 * PI * RANART(NSEED)
       S1   = SQRT( 1.0 - C1**2 )
       CT1  = COS(T1)
       ST1  = SIN(T1)
       PZ   = PR * C1
       PX   = PR * S1*CT1 
       PY   = PR * S1*ST1
       RETURN
       END
 ****************************************
 c sp 04/05/01
 * Purpose: lambda-baryon elastic xsection as a functon of their cms energy
          subroutine lambar(i1,i2,srt,siglab)
 *  srt    = DSQRT(s) in GeV                                               *
 *  siglab = lambda-nuclar elastic cross section in mb 
 *         = 12 + 0.43/p_lab**3.3 (mb)  
 *                                                    
 * (2) Calculate p(lab) from srt [GeV], since the formular in the 
 * reference applies only to the case of a p_bar on a proton at rest
 * Formula used: srt**2=2.*pmass*(pmass+sqrt(pmass**2+plab**2))
 *****************************
         PARAMETER (MAXSTR=150001)
         COMMON /AA/ R(3,MAXSTR)
 cc      SAVE /AA/
         COMMON /BB/ P(3,MAXSTR)
 cc      SAVE /BB/
         COMMON /CC/ E(MAXSTR)
 cc      SAVE /CC/
         COMMON /EE/ ID(MAXSTR),LB(MAXSTR)
 cc      SAVE /EE/
       SAVE   
 
           siglab=1.e-06
         if( iabs(lb(i1)).ge.14.and.iabs(lb(i1)).le.17 )then
           eml = e(i1)
           emb = e(i2)
          else
           eml = e(i2)
           emb = e(i1)
         endif
        pthr = srt**2-eml**2-emb**2
         if(pthr .gt. 0.)then
        plab2=(pthr/2./emb)**2-eml**2
        if(plab2.gt.0)then
          plab=sqrt(plab2)
          siglab=12. + 0.43/(plab**3.3)
        if(siglab.gt.200.)siglab=200.
        endif
        endif
          return
       END
 C------------------------------------------------------------------
 clin-7/26/03 improve speed
 ***************************************
             SUBROUTINE distc0(drmax,deltr0,DT,
      1     Ifirst,PX1CM,PY1CM,PZ1CM,
      2     x1,y1,z1,px1,py1,pz1,em1,x2,y2,z2,px2,py2,pz2,em2)
 * PURPOSE : CHECK IF THE COLLISION BETWEEN TWO PARTICLES CAN HAPPEN
 *           BY CHECKING
 *                      (2) IF PARTICLE WILL PASS EACH OTHER WITHIN
 *           TWO HARD CORE RADIUS.
 *                      (3) IF PARTICLES WILL GET CLOSER.
 * VARIABLES :
 *           Ifirst=1 COLLISION may HAPPENED
 *           Ifirst=-1 COLLISION CAN NOT HAPPEN
 *****************************************
             COMMON   /BG/  BETAX,BETAY,BETAZ,GAMMA
 cc      SAVE /BG/
       SAVE   
             Ifirst=-1
             E1=SQRT(EM1**2+PX1**2+PY1**2+PZ1**2)
 *NOW PARTICLES ARE CLOSE ENOUGH TO EACH OTHER !
             E2     = SQRT ( EM2**2 + PX2**2 + PY2**2 + PZ2**2 )
 *NOW THERE IS ENOUGH ENERGY AVAILABLE !
 *LORENTZ-TRANSFORMATION IN I1-I2-C.M. SYSTEM
 * BETAX, BETAY, BETAZ AND GAMMA HAVE BEEN GIVEN IN THE SUBROUTINE CMS
 *TRANSFORMATION OF MOMENTA (PX1CM = - PX2CM)
               P1BETA = PX1*BETAX + PY1*BETAY + PZ1 * BETAZ
               TRANSF = GAMMA * ( GAMMA * P1BETA / (GAMMA + 1) - E1 )
               PRCM   = SQRT (PX1CM**2 + PY1CM**2 + PZ1CM**2)
               IF (PRCM .LE. 0.00001) return
 *TRANSFORMATION OF SPATIAL DISTANCE
               DRBETA = BETAX*(X1-X2) + BETAY*(Y1-Y2) + BETAZ*(Z1-Z2)
               TRANSF = GAMMA * GAMMA * DRBETA / (GAMMA + 1)
               DXCM   = BETAX * TRANSF + X1 - X2
               DYCM   = BETAY * TRANSF + Y1 - Y2
               DZCM   = BETAZ * TRANSF + Z1 - Z2
 *DETERMINING IF THIS IS THE POINT OF CLOSEST APPROACH
               DRCM   = SQRT (DXCM**2  + DYCM**2  + DZCM**2 )
               DZZ    = (PX1CM*DXCM + PY1CM*DYCM + PZ1CM*DZCM) / PRCM
               if ((drcm**2 - dzz**2) .le. 0.) then
                 BBB = 0.
               else
                 BBB    = SQRT (DRCM**2 - DZZ**2)
               end if
 *WILL PARTICLE PASS EACH OTHER WITHIN 2 * HARD CORE RADIUS ?
               IF (BBB .GT. drmax) return
               RELVEL = PRCM * (1.0/E1 + 1.0/E2)
               DDD    = RELVEL * DT * 0.5
 *WILL PARTICLES GET CLOSER ?
               IF (ABS(DDD) .LT. ABS(DZZ)) return
               Ifirst=1
               RETURN
               END
 *---------------------------------------------------------------------------
 c
 clin-8/2008 B+B->Deuteron+Meson cross section in mb:
       subroutine sbbdm(srt,sdprod,ianti,lbm,xmm,pfinal)
       PARAMETER (xmd=1.8756,AP1=0.13496,AP2=0.13957,
      1     xmrho=0.770,xmomega=0.782,xmeta=0.548,srt0=2.012)
       common/leadng/lb1,px1,py1,pz1,em1,e1,xfnl,yfnl,zfnl,tfnl,
      1     px1n,py1n,pz1n,dp1n
       common /dpi/em2,lb2
       common /para8/ idpert,npertd,idxsec
       COMMON/RNDF77/NSEED
       SAVE   
 c
       sdprod=0.
       sbbdpi=0.
       sbbdrho=0.
       sbbdomega=0.
       sbbdeta=0.
       if(srt.le.(em1+em2)) return
 c
       ilb1=iabs(lb1)
       ilb2=iabs(lb2)
 ctest off check Xsec using fixed mass for resonances:
 c      if(ilb1.ge.6.and.ilb1.le.9) then
 c         em1=1.232
 c      elseif(ilb1.ge.10.and.ilb1.le.11) then
 c         em1=1.44
 c      elseif(ilb1.ge.12.and.ilb1.le.13) then
 c         em1=1.535
 c      endif
 c      if(ilb2.ge.6.and.ilb2.le.9) then
 c         em2=1.232
 c      elseif(ilb2.ge.10.and.ilb2.le.11) then
 c         em2=1.44
 c      elseif(ilb2.ge.12.and.ilb2.le.13) then
 c         em2=1.535
 c      endif
 c
       s=srt**2
 
 clin-9/2012: check argument in sqrt():
       scheck=(s-(em1+em2)**2)*(s-(em1-em2)**2)
       if(scheck.le.0) then
          write(99,*) 'scheck50: ', scheck
          stop
       endif
       pinitial=sqrt(scheck)/2./srt
 c      pinitial=sqrt((s-(em1+em2)**2)*(s-(em1-em2)**2))/2./srt
 
       fs=fnndpi(s)
 c     Determine isospin and spin factors for the ratio between 
 c     BB->Deuteron+Meson and Deuteron+Meson->BB cross sections:
       if(idxsec.eq.1.or.idxsec.eq.2) then
 c     Assume B+B -> d+Meson has the same cross sections as N+N -> d+pi:
       else
 c     Assume d+Meson -> B+B has the same cross sections as d+pi -> N+N, 
 c     then determine B+B -> d+Meson cross sections:
          if(ilb1.ge.1.and.ilb1.le.2.and.
      1        ilb2.ge.1.and.ilb2.le.2) then
             pifactor=9./8.
          elseif((ilb1.ge.1.and.ilb1.le.2.and.
      1           ilb2.ge.6.and.ilb2.le.9).or.
      2           (ilb2.ge.1.and.ilb2.le.2.and.
      1           ilb1.ge.6.and.ilb1.le.9)) then
             pifactor=9./64.
          elseif((ilb1.ge.1.and.ilb1.le.2.and.
      1           ilb2.ge.10.and.ilb2.le.13).or.
      2           (ilb2.ge.1.and.ilb2.le.2.and.
      1           ilb1.ge.10.and.ilb1.le.13)) then
             pifactor=9./16.
          elseif(ilb1.ge.6.and.ilb1.le.9.and.
      1           ilb2.ge.6.and.ilb2.le.9) then
             pifactor=9./128.
          elseif((ilb1.ge.6.and.ilb1.le.9.and.
      1           ilb2.ge.10.and.ilb2.le.13).or.
      2           (ilb2.ge.6.and.ilb2.le.9.and.
      1           ilb1.ge.10.and.ilb1.le.13)) then
             pifactor=9./64.
          elseif((ilb1.ge.10.and.ilb1.le.11.and.
      1           ilb2.ge.10.and.ilb2.le.11).or.
      2           (ilb2.ge.12.and.ilb2.le.13.and.
      1           ilb1.ge.12.and.ilb1.le.13)) then
             pifactor=9./8.
          elseif((ilb1.ge.10.and.ilb1.le.11.and.
      1           ilb2.ge.12.and.ilb2.le.13).or.
      2           (ilb2.ge.10.and.ilb2.le.11.and.
      1           ilb1.ge.12.and.ilb1.le.13)) then
             pifactor=9./16.
          endif
       endif
 c     d pi: DETERMINE THE CHARGE STATES OF PARTICLES IN THE FINAL STATE
 *     (1) FOR P+P->Deuteron+pi+:
       IF((ilb1*ilb2).EQ.1)THEN
          lbm=5
          if(ianti.eq.1) lbm=3
          xmm=ap2
 *     (2)FOR N+N->Deuteron+pi-:
       ELSEIF(ilb1.EQ.2.AND.ilb2.EQ.2)THEN
          lbm=3
          if(ianti.eq.1) lbm=5
          xmm=ap2
 *     (3)FOR N+P->Deuteron+pi0:
       ELSEIF((ilb1*ilb2).EQ.2)THEN
          lbm=4
          xmm=ap1
       ELSE
 c     For baryon resonances, use isospin-averaged cross sections:
          lbm=3+int(3 * RANART(NSEED))
          if(lbm.eq.4) then
             xmm=ap1
          else
             xmm=ap2
          endif
       ENDIF
 c
       if(srt.ge.(xmd+xmm)) then
          pfinal=sqrt((s-(xmd+xmm)**2)*(s-(xmd-xmm)**2))/2./srt
          if((ilb1.eq.1.and.ilb2.eq.1).or.
      1        (ilb1.eq.2.and.ilb2.eq.2)) then
 c     for pp or nn initial states:
             sbbdpi=fs*pfinal/pinitial/4.
          elseif((ilb1.eq.1.and.ilb2.eq.2).or.
      1           (ilb1.eq.2.and.ilb2.eq.1)) then
 c     factor of 1/2 for pn or np initial states:
             sbbdpi=fs*pfinal/pinitial/4./2.
          else
 c     for other BB initial states (spin- and isospin averaged):
             if(idxsec.eq.1) then
 c     1: assume the same |matrix element|**2/s (after averaging over initial 
 c     spins and isospins) for B+B -> deuteron+meson at the same sqrt(s);
                sbbdpi=fs*pfinal/pinitial*3./16.
             elseif(idxsec.eq.2.or.idxsec.eq.4) then
                threshold=amax1(xmd+xmm,em1+em2)
                snew=(srt-threshold+srt0)**2
                if(idxsec.eq.2) then
 c     2: assume the same |matrix element|**2/s for B+B -> deuteron+meson 
 c     at the same sqrt(s)-threshold:
                   sbbdpi=fnndpi(snew)*pfinal/pinitial*3./16.
                elseif(idxsec.eq.4) then
 c     4: assume the same |matrix element|**2/s for B+B <- deuteron+meson 
 c     at the same sqrt(s)-threshold:
                   sbbdpi=fnndpi(snew)*pfinal/pinitial/6.*pifactor
                endif
             elseif(idxsec.eq.3) then
 c     3: assume the same |matrix element|**2/s for B+B <- deuteron+meson 
 c     at the same sqrt(s):
                sbbdpi=fs*pfinal/pinitial/6.*pifactor
             endif
 c
          endif
       endif
 c     
 *     d rho: DETERMINE THE CROSS SECTION TO THIS FINAL STATE:
       if(srt.gt.(xmd+xmrho)) then
          pfinal=sqrt((s-(xmd+xmrho)**2)*(s-(xmd-xmrho)**2))/2./srt
          if(idxsec.eq.1) then
             sbbdrho=fs*pfinal/pinitial*3./16.
          elseif(idxsec.eq.2.or.idxsec.eq.4) then
             threshold=amax1(xmd+xmrho,em1+em2)
             snew=(srt-threshold+srt0)**2
             if(idxsec.eq.2) then
                sbbdrho=fnndpi(snew)*pfinal/pinitial*3./16.
             elseif(idxsec.eq.4) then
 c     The spin- and isospin-averaged factor is 3-times larger for rho:
                sbbdrho=fnndpi(snew)*pfinal/pinitial/6.*(pifactor*3.)
             endif
          elseif(idxsec.eq.3) then
             sbbdrho=fs*pfinal/pinitial/6.*(pifactor*3.)
          endif
       endif
 c
 *     d omega: DETERMINE THE CROSS SECTION TO THIS FINAL STATE:
       if(srt.gt.(xmd+xmomega)) then
          pfinal=sqrt((s-(xmd+xmomega)**2)*(s-(xmd-xmomega)**2))/2./srt
          if(idxsec.eq.1) then
             sbbdomega=fs*pfinal/pinitial*3./16.
          elseif(idxsec.eq.2.or.idxsec.eq.4) then
             threshold=amax1(xmd+xmomega,em1+em2)
             snew=(srt-threshold+srt0)**2
             if(idxsec.eq.2) then
                sbbdomega=fnndpi(snew)*pfinal/pinitial*3./16.
             elseif(idxsec.eq.4) then
                sbbdomega=fnndpi(snew)*pfinal/pinitial/6.*pifactor
             endif
          elseif(idxsec.eq.3) then
             sbbdomega=fs*pfinal/pinitial/6.*pifactor
          endif
       endif
 c
 *     d eta: DETERMINE THE CROSS SECTION TO THIS FINAL STATE:
       if(srt.gt.(xmd+xmeta)) then
          pfinal=sqrt((s-(xmd+xmeta)**2)*(s-(xmd-xmeta)**2))/2./srt
          if(idxsec.eq.1) then
             sbbdeta=fs*pfinal/pinitial*3./16.
          elseif(idxsec.eq.2.or.idxsec.eq.4) then
             threshold=amax1(xmd+xmeta,em1+em2)
             snew=(srt-threshold+srt0)**2
             if(idxsec.eq.2) then
                sbbdeta=fnndpi(snew)*pfinal/pinitial*3./16.
             elseif(idxsec.eq.4) then
                sbbdeta=fnndpi(snew)*pfinal/pinitial/6.*(pifactor/3.)
             endif
          elseif(idxsec.eq.3) then
             sbbdeta=fs*pfinal/pinitial/6.*(pifactor/3.)
          endif
       endif
 c
       sdprod=sbbdpi+sbbdrho+sbbdomega+sbbdeta
 ctest off
 c      write(99,111) srt,sbbdpi,sbbdrho,sbbdomega,sbbdeta,sdprod
 c 111  format(6(f8.2,1x))
 c
       if(sdprod.le.0) return
 c
 c     choose final state and assign masses here:
       x1=RANART(NSEED)
       if(x1.le.sbbdpi/sdprod) then
 c     use the above-determined lbm and xmm.
       elseif(x1.le.(sbbdpi+sbbdrho)/sdprod) then
          lbm=25+int(3*RANART(NSEED))
          xmm=xmrho
       elseif(x1.le.(sbbdpi+sbbdrho+sbbdomega)/sdprod) then
          lbm=28
          xmm=xmomega
       else
          lbm=0
          xmm=xmeta
       endif
 c
       return
       end
 c
 c     Generate angular distribution of Deuteron in the CMS frame:
       subroutine bbdangle(pxd,pyd,pzd,nt,ipert1,ianti,idloop,pfinal,
      1 dprob1,lbm)
       PARAMETER (PI=3.1415926)
       common/leadng/lb1,px1,py1,pz1,em1,e1,xfnl,yfnl,zfnl,tfnl,
      1     px1n,py1n,pz1n,dp1n
       common /dpi/em2,lb2
       COMMON/RNDF77/NSEED
       common /para8/ idpert,npertd,idxsec
       COMMON /AREVT/ IAEVT, IARUN, MISS
       SAVE   
 c     take isotropic distribution for now:
       C1=1.0-2.0*RANART(NSEED)
       T1=2.0*PI*RANART(NSEED)
       S1=SQRT(1.0-C1**2)
       CT1=COS(T1)
       ST1=SIN(T1)
 * THE MOMENTUM IN THE CMS IN THE FINAL STATE
       PZd=pfinal*C1
       PXd=pfinal*S1*CT1 
       PYd=pfinal*S1*ST1
 clin-5/2008 track the number of produced deuterons:
       if(idpert.eq.1.and.npertd.ge.1) then
          dprob=dprob1
       elseif(idpert.eq.2.and.npertd.ge.1) then
          dprob=1./float(npertd)
       endif
       if(ianti.eq.0) then
          if(idpert.eq.0.or.(idpert.eq.1.and.ipert1.eq.0).or.
      1        (idpert.eq.2.and.idloop.eq.(npertd+1))) then
             write (91,*) lb1,' *',lb2,' ->d+',lbm,' (regular d prodn) 
      1 @evt#',iaevt,' @nt=',nt
          elseif((idpert.eq.1.or.idpert.eq.2).and.idloop.eq.npertd) then
             write (91,*) lb1,' *',lb2,' ->d+',lbm,' (pert d prodn) 
      1 @evt#',iaevt,' @nt=',nt,' @prob=',dprob
          endif
       else
          if(idpert.eq.0.or.(idpert.eq.1.and.ipert1.eq.0).or.
      1        (idpert.eq.2.and.idloop.eq.(npertd+1))) then
             write (91,*) lb1,' *',lb2,' ->d+',lbm,' (regular dbar prodn) 
      1 @evt#',iaevt,' @nt=',nt
          elseif((idpert.eq.1.or.idpert.eq.2).and.idloop.eq.npertd) then
             write (91,*) lb1,' *',lb2,' ->d+',lbm,' (pert dbar prodn) 
      1 @evt#',iaevt,' @nt=',nt,' @prob=',dprob
          endif
       endif
 c
       return
       end
 c
 c     Deuteron+Meson->B+B cross section (in mb)
       subroutine sdmbb(SRT,sdm,ianti)
       PARAMETER (AMN=0.939457,AMP=0.93828,
      1     AM0=1.232,AM1440=1.44,AM1535=1.535,srt0=2.012)
       common/leadng/lb1,px1,py1,pz1,em1,e1,xfnl,yfnl,zfnl,tfnl,
      1     px1n,py1n,pz1n,dp1n
       common /dpi/em2,lb2
       common /dpifsl/lbnn1,lbnn2,lbnd1,lbnd2,lbns1,lbns2,lbnp1,lbnp2,
      1     lbdd1,lbdd2,lbds1,lbds2,lbdp1,lbdp2,lbss1,lbss2,
      2     lbsp1,lbsp2,lbpp1,lbpp2
       common /dpifsm/xmnn1,xmnn2,xmnd1,xmnd2,xmns1,xmns2,xmnp1,xmnp2,
      1     xmdd1,xmdd2,xmds1,xmds2,xmdp1,xmdp2,xmss1,xmss2,
      2     xmsp1,xmsp2,xmpp1,xmpp2
       common /dpisig/sdmel,sdmnn,sdmnd,sdmns,sdmnp,sdmdd,sdmds,sdmdp,
      1     sdmss,sdmsp,sdmpp
       common /para8/ idpert,npertd,idxsec
       COMMON/RNDF77/NSEED
       SAVE   
 c
       sdm=0.
       sdmel=0.
       sdmnn=0.
       sdmnd=0.
       sdmns=0.
       sdmnp=0.
       sdmdd=0.
       sdmds=0.
       sdmdp=0.
       sdmss=0.
       sdmsp=0.
       sdmpp=0.
 ctest off check Xsec using fixed mass for resonances:
 c      if(lb1.ge.25.and.lb1.le.27) then
 c         em1=0.776
 c      elseif(lb1.eq.28) then
 c         em1=0.783
 c      elseif(lb1.eq.0) then
 c         em1=0.548
 c      endif
 c      if(lb2.ge.25.and.lb2.le.27) then
 c         em2=0.776
 c      elseif(lb2.eq.28) then
 c         em2=0.783
 c      elseif(lb2.eq.0) then
 c         em2=0.548
 c      endif
 c
       if(srt.le.(em1+em2)) return
       s=srt**2
       pinitial=sqrt((s-(em1+em2)**2)*(s-(em1-em2)**2))/2./srt
       fs=fnndpi(s)
 c     Determine isospin and spin factors for the ratio between 
 c     Deuteron+Meson->BB and BB->Deuteron+Meson cross sections:
       if(idxsec.eq.1.or.idxsec.eq.2) then
 c     Assume B+B -> d+Meson has the same cross sections as N+N -> d+pi, 
 c     then determine d+Meson -> B+B cross sections:
          if((lb1.ge.3.and.lb1.le.5).or.
      1        (lb2.ge.3.and.lb2.le.5)) then
             xnnfactor=8./9.
          elseif((lb1.ge.25.and.lb1.le.27).or.
      1           (lb2.ge.25.and.lb2.le.27)) then
             xnnfactor=8./27.
          elseif(lb1.eq.28.or.lb2.eq.28) then
             xnnfactor=8./9.
          elseif(lb1.eq.0.or.lb2.eq.0) then
             xnnfactor=8./3.
          endif
       else
 c     Assume d+Meson -> B+B has the same cross sections as d+pi -> N+N:
       endif
 clin-9/2008 For elastic collisions:
       if(idxsec.eq.1.or.idxsec.eq.3) then
 c     1/3: assume the same |matrix element|**2/s (after averaging over initial 
 c     spins and isospins) for d+Meson elastic at the same sqrt(s);
          sdmel=fdpiel(s)
       elseif(idxsec.eq.2.or.idxsec.eq.4) then
 c     2/4: assume the same |matrix element|**2/s (after averaging over initial 
 c     spins and isospins) for d+Meson elastic at the same sqrt(s)-threshold:
          threshold=em1+em2
          snew=(srt-threshold+srt0)**2
          sdmel=fdpiel(snew)
       endif
 c
 *     NN: DETERMINE THE CHARGE STATES OF PARTICLESIN THE FINAL STATE
       IF(((lb1.eq.5.or.lb2.eq.5.or.lb1.eq.27.or.lb2.eq.27)
      1     .and.ianti.eq.0).or.
      2     ((lb1.eq.3.or.lb2.eq.3.or.lb1.eq.25.or.lb2.eq.25)
      3     .and.ianti.eq.1))THEN
 *     (1) FOR Deuteron+(pi+,rho+) -> P+P or DeuteronBar+(pi-,rho-)-> PBar+PBar:
          lbnn1=1
          lbnn2=1
          xmnn1=amp
          xmnn2=amp
       ELSEIF(lb1.eq.3.or.lb2.eq.3.or.lb1.eq.26.or.lb2.eq.26
      1        .or.lb1.eq.28.or.lb2.eq.28.or.lb1.eq.0.or.lb2.eq.0)THEN
 *     (2) FOR Deuteron+(pi0,rho0,omega,eta) -> N+P 
 *     or DeuteronBar+(pi0,rho0,omega,eta) ->NBar+PBar:
          lbnn1=2
          lbnn2=1
          xmnn1=amn
          xmnn2=amp
       ELSE
 *     (3) FOR Deuteron+(pi-,rho-) -> N+N or DeuteronBar+(pi+,rho+)-> NBar+NBar:
          lbnn1=2
          lbnn2=2
          xmnn1=amn
          xmnn2=amn
       ENDIF
       if(srt.gt.(xmnn1+xmnn2)) then
          pfinal=sqrt((s-(xmnn1+xmnn2)**2)*(s-(xmnn1-xmnn2)**2))/2./srt
          if(idxsec.eq.1) then
 c     1: assume the same |matrix element|**2/s (after averaging over initial 
 c     spins and isospins) for B+B -> deuteron+meson at the same sqrt(s);
             sdmnn=fs*pfinal/pinitial*3./16.*xnnfactor
          elseif(idxsec.eq.2.or.idxsec.eq.4) then
             threshold=amax1(xmnn1+xmnn2,em1+em2)
             snew=(srt-threshold+srt0)**2
             if(idxsec.eq.2) then
 c     2: assume the same |matrix element|**2/s for B+B -> deuteron+meson 
 c     at the same sqrt(s)-threshold:
                sdmnn=fnndpi(snew)*pfinal/pinitial*3./16.*xnnfactor
             elseif(idxsec.eq.4) then
 c     4: assume the same |matrix element|**2/s for B+B <- deuteron+meson 
 c     at the same sqrt(s)-threshold:
                sdmnn=fnndpi(snew)*pfinal/pinitial/6.
             endif
          elseif(idxsec.eq.3) then
 c     3: assume the same |matrix element|**2/s for B+B <- deuteron+meson 
 c     at the same sqrt(s):
             sdmnn=fs*pfinal/pinitial/6.
          endif
       endif
 c     
 *     ND: DETERMINE THE CHARGE STATES OF PARTICLES IN THE FINAL STATE
       lbnd1=1+int(2*RANART(NSEED))
       lbnd2=6+int(4*RANART(NSEED))
       if(lbnd1.eq.1) then
          xmnd1=amp
       elseif(lbnd1.eq.2) then
          xmnd1=amn
       endif
       xmnd2=am0
       if(srt.gt.(xmnd1+xmnd2)) then
          pfinal=sqrt((s-(xmnd1+xmnd2)**2)*(s-(xmnd1-xmnd2)**2))/2./srt
          if(idxsec.eq.1) then
 c     The spin- and isospin-averaged factor is 8-times larger for ND:
             sdmnd=fs*pfinal/pinitial*3./16.*(xnnfactor*8.)
          elseif(idxsec.eq.2.or.idxsec.eq.4) then
             threshold=amax1(xmnd1+xmnd2,em1+em2)
             snew=(srt-threshold+srt0)**2
             if(idxsec.eq.2) then
                sdmnd=fnndpi(snew)*pfinal/pinitial*3./16.*(xnnfactor*8.)
             elseif(idxsec.eq.4) then
                sdmnd=fnndpi(snew)*pfinal/pinitial/6.
             endif
          elseif(idxsec.eq.3) then
             sdmnd=fs*pfinal/pinitial/6.
          endif
       endif
 c
 *     NS: DETERMINE THE CHARGE STATES OF PARTICLES IN THE FINAL STATE
       lbns1=1+int(2*RANART(NSEED))
       lbns2=10+int(2*RANART(NSEED))
       if(lbns1.eq.1) then
          xmns1=amp
       elseif(lbns1.eq.2) then
          xmns1=amn
       endif
       xmns2=am1440
       if(srt.gt.(xmns1+xmns2)) then
          pfinal=sqrt((s-(xmns1+xmns2)**2)*(s-(xmns1-xmns2)**2))/2./srt
          if(idxsec.eq.1) then
             sdmns=fs*pfinal/pinitial*3./16.*(xnnfactor*2.)
          elseif(idxsec.eq.2.or.idxsec.eq.4) then
             threshold=amax1(xmns1+xmns2,em1+em2)
             snew=(srt-threshold+srt0)**2
             if(idxsec.eq.2) then
                sdmns=fnndpi(snew)*pfinal/pinitial*3./16.*(xnnfactor*2.)
             elseif(idxsec.eq.4) then
                sdmns=fnndpi(snew)*pfinal/pinitial/6.
             endif
          elseif(idxsec.eq.3) then
             sdmns=fs*pfinal/pinitial/6.
          endif
       endif
 c
 *     NP: DETERMINE THE CHARGE STATES OF PARTICLES IN THE FINAL STATE
       lbnp1=1+int(2*RANART(NSEED))
       lbnp2=12+int(2*RANART(NSEED))
       if(lbnp1.eq.1) then
          xmnp1=amp
       elseif(lbnp1.eq.2) then
          xmnp1=amn
       endif
       xmnp2=am1535
       if(srt.gt.(xmnp1+xmnp2)) then
          pfinal=sqrt((s-(xmnp1+xmnp2)**2)*(s-(xmnp1-xmnp2)**2))/2./srt
          if(idxsec.eq.1) then
             sdmnp=fs*pfinal/pinitial*3./16.*(xnnfactor*2.)
          elseif(idxsec.eq.2.or.idxsec.eq.4) then
             threshold=amax1(xmnp1+xmnp2,em1+em2)
             snew=(srt-threshold+srt0)**2
             if(idxsec.eq.2) then
                sdmnp=fnndpi(snew)*pfinal/pinitial*3./16.*(xnnfactor*2.)
             elseif(idxsec.eq.4) then
                sdmnp=fnndpi(snew)*pfinal/pinitial/6.
             endif
          elseif(idxsec.eq.3) then
             sdmnp=fs*pfinal/pinitial/6.
          endif
       endif
 c
 *     DD: DETERMINE THE CHARGE STATES OF PARTICLES IN THE FINAL STATE
       lbdd1=6+int(4*RANART(NSEED))
       lbdd2=6+int(4*RANART(NSEED))
       xmdd1=am0
       xmdd2=am0
       if(srt.gt.(xmdd1+xmdd2)) then
          pfinal=sqrt((s-(xmdd1+xmdd2)**2)*(s-(xmdd1-xmdd2)**2))/2./srt
          if(idxsec.eq.1) then
             sdmdd=fs*pfinal/pinitial*3./16.*(xnnfactor*16.)
          elseif(idxsec.eq.2.or.idxsec.eq.4) then
             threshold=amax1(xmdd1+xmdd2,em1+em2)
             snew=(srt-threshold+srt0)**2
             if(idxsec.eq.2) then
                sdmdd=fnndpi(snew)*pfinal/pinitial*3./16.*(xnnfactor*16.)
             elseif(idxsec.eq.4) then
                sdmdd=fnndpi(snew)*pfinal/pinitial/6.
             endif
          elseif(idxsec.eq.3) then
             sdmdd=fs*pfinal/pinitial/6.
          endif
       endif
 c
 *     DS: DETERMINE THE CHARGE STATES OF PARTICLES IN THE FINAL STATE
       lbds1=6+int(4*RANART(NSEED))
       lbds2=10+int(2*RANART(NSEED))
       xmds1=am0
       xmds2=am1440
       if(srt.gt.(xmds1+xmds2)) then
          pfinal=sqrt((s-(xmds1+xmds2)**2)*(s-(xmds1-xmds2)**2))/2./srt
          if(idxsec.eq.1) then
             sdmds=fs*pfinal/pinitial*3./16.*(xnnfactor*8.)
          elseif(idxsec.eq.2.or.idxsec.eq.4) then
             threshold=amax1(xmds1+xmds2,em1+em2)
             snew=(srt-threshold+srt0)**2
             if(idxsec.eq.2) then
                sdmds=fnndpi(snew)*pfinal/pinitial*3./16.*(xnnfactor*8.)
             elseif(idxsec.eq.4) then
                sdmds=fnndpi(snew)*pfinal/pinitial/6.
             endif
          elseif(idxsec.eq.3) then
             sdmds=fs*pfinal/pinitial/6.
          endif
       endif
 c
 *     DP: DETERMINE THE CHARGE STATES OF PARTICLES IN THE FINAL STATE
       lbdp1=6+int(4*RANART(NSEED))
       lbdp2=12+int(2*RANART(NSEED))
       xmdp1=am0
       xmdp2=am1535
       if(srt.gt.(xmdp1+xmdp2)) then
          pfinal=sqrt((s-(xmdp1+xmdp2)**2)*(s-(xmdp1-xmdp2)**2))/2./srt
          if(idxsec.eq.1) then
             sdmdp=fs*pfinal/pinitial*3./16.*(xnnfactor*8.)
          elseif(idxsec.eq.2.or.idxsec.eq.4) then
             threshold=amax1(xmdp1+xmdp2,em1+em2)
             snew=(srt-threshold+srt0)**2
             if(idxsec.eq.2) then
                sdmdp=fnndpi(snew)*pfinal/pinitial*3./16.*(xnnfactor*8.)
             elseif(idxsec.eq.4) then
                sdmdp=fnndpi(snew)*pfinal/pinitial/6.
             endif
          elseif(idxsec.eq.3) then
             sdmdp=fs*pfinal/pinitial/6.
          endif
       endif
 c
 *     SS: DETERMINE THE CHARGE STATES OF PARTICLES IN THE FINAL STATE
       lbss1=10+int(2*RANART(NSEED))
       lbss2=10+int(2*RANART(NSEED))
       xmss1=am1440
       xmss2=am1440
       if(srt.gt.(xmss1+xmss2)) then
          pfinal=sqrt((s-(xmss1+xmss2)**2)*(s-(xmss1-xmss2)**2))/2./srt
          if(idxsec.eq.1) then
             sdmss=fs*pfinal/pinitial*3./16.*xnnfactor
          elseif(idxsec.eq.2.or.idxsec.eq.4) then
             threshold=amax1(xmss1+xmss2,em1+em2)
             snew=(srt-threshold+srt0)**2
             if(idxsec.eq.2) then
                sdmss=fnndpi(snew)*pfinal/pinitial*3./16.*xnnfactor
             elseif(idxsec.eq.4) then
                sdmss=fnndpi(snew)*pfinal/pinitial/6.
             endif
          elseif(idxsec.eq.3) then
             sdmns=fs*pfinal/pinitial/6.
          endif
       endif
 c
 *     SP: DETERMINE THE CHARGE STATES OF PARTICLES IN THE FINAL STATE
       lbsp1=10+int(2*RANART(NSEED))
       lbsp2=12+int(2*RANART(NSEED))
       xmsp1=am1440
       xmsp2=am1535
       if(srt.gt.(xmsp1+xmsp2)) then
          pfinal=sqrt((s-(xmsp1+xmsp2)**2)*(s-(xmsp1-xmsp2)**2))/2./srt
          if(idxsec.eq.1) then
             sdmsp=fs*pfinal/pinitial*3./16.*(xnnfactor*2.)
          elseif(idxsec.eq.2.or.idxsec.eq.4) then
             threshold=amax1(xmsp1+xmsp2,em1+em2)
             snew=(srt-threshold+srt0)**2
             if(idxsec.eq.2) then
                sdmsp=fnndpi(snew)*pfinal/pinitial*3./16.*(xnnfactor*2.)
             elseif(idxsec.eq.4) then
                sdmsp=fnndpi(snew)*pfinal/pinitial/6.
             endif
          elseif(idxsec.eq.3) then
             sdmsp=fs*pfinal/pinitial/6.
          endif
       endif
 c
 *     PP: DETERMINE THE CHARGE STATES OF PARTICLES IN THE FINAL STATE
       lbpp1=12+int(2*RANART(NSEED))
       lbpp2=12+int(2*RANART(NSEED))
       xmpp1=am1535
       xmpp2=am1535
       if(srt.gt.(xmpp1+xmpp2)) then
          pfinal=sqrt((s-(xmpp1+xmpp2)**2)*(s-(xmpp1-xmpp2)**2))/2./srt
          if(idxsec.eq.1) then
             sdmpp=fs*pfinal/pinitial*3./16.*xnnfactor
          elseif(idxsec.eq.2.or.idxsec.eq.4) then
             threshold=amax1(xmpp1+xmpp2,em1+em2)
             snew=(srt-threshold+srt0)**2
             if(idxsec.eq.2) then
                sdmpp=fnndpi(snew)*pfinal/pinitial*3./16.*xnnfactor
             elseif(idxsec.eq.4) then
                sdmpp=fnndpi(snew)*pfinal/pinitial/6.
             endif
          elseif(idxsec.eq.3) then
             sdmpp=fs*pfinal/pinitial/6.
          endif
       endif
 c
       sdm=sdmel+sdmnn+sdmnd+sdmns+sdmnp+sdmdd+sdmds+sdmdp
      1     +sdmss+sdmsp+sdmpp
       if(ianti.eq.1) then
          lbnn1=-lbnn1
          lbnn2=-lbnn2
          lbnd1=-lbnd1
          lbnd2=-lbnd2
          lbns1=-lbns1
          lbns2=-lbns2
          lbnp1=-lbnp1
          lbnp2=-lbnp2
          lbdd1=-lbdd1
          lbdd2=-lbdd2
          lbds1=-lbds1
          lbds2=-lbds2
          lbdp1=-lbdp1
          lbdp2=-lbdp2
          lbss1=-lbss1
          lbss2=-lbss2
          lbsp1=-lbsp1
          lbsp2=-lbsp2
          lbpp1=-lbpp1
          lbpp2=-lbpp2
       endif
 ctest off
 c      write(98,100) srt,sdmnn,sdmnd,sdmns,sdmnp,sdmdd,sdmds,sdmdp,
 c     1     sdmss,sdmsp,sdmpp,sdm
 c 100  format(f5.2,11(1x,f5.1))
 c
       return
       end
 c
 clin-9/2008 Deuteron+Meson ->B+B and elastic collisions
       SUBROUTINE crdmbb(PX,PY,PZ,SRT,I1,I2,IBLOCK,
      1     NTAG,sig,NT,ianti)
       PARAMETER (MAXSTR=150001,MAXR=1)
       COMMON /AA/R(3,MAXSTR)
       COMMON /BB/ P(3,MAXSTR)
       COMMON /BG/BETAX,BETAY,BETAZ,GAMMA
       COMMON /CC/ E(MAXSTR)
       COMMON /EE/ ID(MAXSTR),LB(MAXSTR)
       COMMON /AREVT/ IAEVT, IARUN, MISS
       common/leadng/lb1,px1,py1,pz1,em1,e1,xfnl,yfnl,zfnl,tfnl,
      1     px1n,py1n,pz1n,dp1n
       common /dpi/em2,lb2
       common /para8/ idpert,npertd,idxsec
       COMMON /dpert/dpertt(MAXSTR,MAXR),dpertp(MAXSTR),dplast(MAXSTR),
      1     dpdcy(MAXSTR),dpdpi(MAXSTR,MAXR),dpt(MAXSTR, MAXR),
      2     dpp1(MAXSTR,MAXR),dppion(MAXSTR,MAXR)
       common /dpifsl/lbnn1,lbnn2,lbnd1,lbnd2,lbns1,lbns2,lbnp1,lbnp2,
      1     lbdd1,lbdd2,lbds1,lbds2,lbdp1,lbdp2,lbss1,lbss2,
      2     lbsp1,lbsp2,lbpp1,lbpp2
       common /dpifsm/xmnn1,xmnn2,xmnd1,xmnd2,xmns1,xmns2,xmnp1,xmnp2,
      1     xmdd1,xmdd2,xmds1,xmds2,xmdp1,xmdp2,xmss1,xmss2,
      2     xmsp1,xmsp2,xmpp1,xmpp2
       common /dpisig/sdmel,sdmnn,sdmnd,sdmns,sdmnp,sdmdd,sdmds,sdmdp,
      1     sdmss,sdmsp,sdmpp
       COMMON/RNDF77/NSEED
       SAVE   
 *-----------------------------------------------------------------------
       IBLOCK=0
       NTAG=0
       EM1=E(I1)
       EM2=E(I2)
       s=srt**2
       if(sig.le.0) return
 c
       if(iabs(lb1).eq.42) then
          ideut=i1
          lbm=lb2
          idm=i2
       else
          ideut=i2
          lbm=lb1
          idm=i1
       endif
 cccc  Elastic collision or destruction of perturbatively-produced deuterons:
       if((idpert.eq.1.or.idpert.eq.2).and.dpertp(ideut).ne.1.) then
 c     choose reaction channels:
          x1=RANART(NSEED)
          if(x1.le.sdmel/sig)then
 c     Elastic collisions:
             if(ianti.eq.0) then
                write(91,*) '  d+',lbm,' (pert d M elastic) @nt=',nt
      1              ,' @prob=',dpertp(ideut)
             else
                write(91,*) '  d+',lbm,' (pert dbar M elastic) @nt=',nt
      1              ,' @prob=',dpertp(ideut)
             endif
 
 clin-9/2012: check argument in sqrt():
             scheck=(s-(em1+em2)**2)*(s-(em1-em2)**2)
             if(scheck.lt.0) then
                write(99,*) 'scheck51: ', scheck
                scheck=0.
             endif
             pfinal=sqrt(scheck)/2./srt
 c            pfinal=sqrt((s-(em1+em2)**2)*(s-(em1-em2)**2))/2./srt
 
             CALL dmelangle(pxn,pyn,pzn,pfinal)
             CALL ROTATE(PX,PY,PZ,Pxn,Pyn,Pzn)
             EdCM=SQRT(E(ideut)**2+Pxn**2+Pyn**2+Pzn**2)
             PdBETA=Pxn*BETAX+Pyn*BETAY+Pzn*BETAZ
             TRANSF=GAMMA*(GAMMA*PdBETA/(GAMMA+1.)+EdCM)
             Pt1d=BETAX*TRANSF+Pxn
             Pt2d=BETAY*TRANSF+Pyn
             Pt3d=BETAZ*TRANSF+Pzn
             p(1,ideut)=pt1d
             p(2,ideut)=pt2d
             p(3,ideut)=pt3d
             IBLOCK=504
             PX1=P(1,I1)
             PY1=P(2,I1)
             PZ1=P(3,I1)
             ID(I1)=2
             ID(I2)=2
 c     Change the position of the perturbative deuteron to that of 
 c     the meson to avoid consecutive collisions between them:
             R(1,ideut)=R(1,idm)
             R(2,ideut)=R(2,idm)
             R(3,ideut)=R(3,idm)
          else
 c     Destruction of deuterons:
             if(ianti.eq.0) then
                write(91,*) '  d+',lbm,' ->BB (pert d destrn) @nt=',nt
      1              ,' @prob=',dpertp(ideut)
             else
                write(91,*) '  d+',lbm,' ->BB (pert dbar destrn) @nt=',nt
      1              ,' @prob=',dpertp(ideut)
             endif
             e(ideut)=0.
             IBLOCK=502
          endif
          return
       endif
 c
 cccc  Destruction of regularly-produced deuterons:
       IBLOCK=502
 c     choose final state and assign masses here:
       x1=RANART(NSEED)
       if(x1.le.sdmnn/sig)then
          lbb1=lbnn1
          lbb2=lbnn2
          xmb1=xmnn1
          xmb2=xmnn2
       elseif(x1.le.(sdmnn+sdmnd)/sig)then
          lbb1=lbnd1
          lbb2=lbnd2
          xmb1=xmnd1
          xmb2=xmnd2
       elseif(x1.le.(sdmnn+sdmnd+sdmns)/sig)then
          lbb1=lbns1
          lbb2=lbns2
          xmb1=xmns1
          xmb2=xmns2
       elseif(x1.le.(sdmnn+sdmnd+sdmns+sdmnp)/sig)then
          lbb1=lbnp1
          lbb2=lbnp2
          xmb1=xmnp1
          xmb2=xmnp2
       elseif(x1.le.(sdmnn+sdmnd+sdmns+sdmnp+sdmdd)/sig)then
          lbb1=lbdd1
          lbb2=lbdd2
          xmb1=xmdd1
          xmb2=xmdd2
       elseif(x1.le.(sdmnn+sdmnd+sdmns+sdmnp+sdmdd+sdmds)/sig)then
          lbb1=lbds1
          lbb2=lbds2
          xmb1=xmds1
          xmb2=xmds2
       elseif(x1.le.(sdmnn+sdmnd+sdmns+sdmnp+sdmdd+sdmds+sdmdp)/sig)then
          lbb1=lbdp1
          lbb2=lbdp2
          xmb1=xmdp1
          xmb2=xmdp2
       elseif(x1.le.(sdmnn+sdmnd+sdmns+sdmnp+sdmdd+sdmds+sdmdp
      1        +sdmss)/sig)then
          lbb1=lbss1
          lbb2=lbss2
          xmb1=xmss1
          xmb2=xmss2
       elseif(x1.le.(sdmnn+sdmnd+sdmns+sdmnp+sdmdd+sdmds+sdmdp
      1        +sdmss+sdmsp)/sig)then
          lbb1=lbsp1
          lbb2=lbsp2
          xmb1=xmsp1
          xmb2=xmsp2
       elseif(x1.le.(sdmnn+sdmnd+sdmns+sdmnp+sdmdd+sdmds+sdmdp
      1        +sdmss+sdmsp+sdmpp)/sig)then
          lbb1=lbpp1
          lbb2=lbpp2
          xmb1=xmpp1
          xmb2=xmpp2
       else
 c     Elastic collision:
          lbb1=lb1
          lbb2=lb2
          xmb1=em1
          xmb2=em2
          IBLOCK=504
       endif
       LB(I1)=lbb1
       E(i1)=xmb1
       LB(I2)=lbb2
       E(I2)=xmb2
       lb1=lb(i1)
       lb2=lb(i2)
 
 clin-9/2012: check argument in sqrt():
       scheck=(s-(xmb1+xmb2)**2)*(s-(xmb1-xmb2)**2)
       if(scheck.lt.0) then
          write(99,*) 'scheck52: ', scheck
          scheck=0.
       endif
       pfinal=sqrt(scheck)/2./srt
 c      pfinal=sqrt((s-(xmb1+xmb2)**2)*(s-(xmb1-xmb2)**2))/2./srt
 
       if(iblock.eq.502) then
          CALL dmangle(pxn,pyn,pzn,nt,ianti,pfinal,lbm)
       elseif(iblock.eq.504) then
          if(ianti.eq.0) then
             write (91,*) ' d+',lbm,' (regular d M elastic) @evt#',
      1           iaevt,' @nt=',nt,' lb1,2=',lb1,lb2
          else
             write (91,*) ' d+',lbm,' (regular dbar M elastic) @evt#',
      1           iaevt,' @nt=',nt,' lb1,2=',lb1,lb2
          endif
          CALL dmelangle(pxn,pyn,pzn,pfinal)
       else
          print *, 'Wrong iblock number in crdmbb()'
          stop
       endif
 *     ROTATE THE MOMENTA OF PARTICLES IN THE CMS OF P1+P2
 c     (This is not needed for isotropic distributions)
       CALL ROTATE(PX,PY,PZ,Pxn,Pyn,Pzn)
 *     LORENTZ-TRANSFORMATION OF THE MOMENTUM OF PARTICLES IN THE FINAL STATE 
 *     FROM THE NUCLEUS-NUCLEUS CMS. FRAME INTO LAB FRAME:
 *     For the 1st baryon:
       E1CM=SQRT(E(I1)**2+Pxn**2+Pyn**2+Pzn**2)
       P1BETA=Pxn*BETAX+Pyn*BETAY+Pzn*BETAZ
       TRANSF=GAMMA*(GAMMA*P1BETA/(GAMMA+1.)+E1CM)
       Pt1i1=BETAX*TRANSF+Pxn
       Pt2i1=BETAY*TRANSF+Pyn
       Pt3i1=BETAZ*TRANSF+Pzn
 c
       p(1,i1)=pt1i1
       p(2,i1)=pt2i1
       p(3,i1)=pt3i1
 *     For the 2nd baryon:
       E2CM=SQRT(E(I2)**2+Pxn**2+Pyn**2+Pzn**2)
       P2BETA=-Pxn*BETAX-Pyn*BETAY-Pzn*BETAZ
       TRANSF=GAMMA*(GAMMA*P2BETA/(GAMMA+1.)+E2CM)
       Pt1I2=BETAX*TRANSF-Pxn
       Pt2I2=BETAY*TRANSF-Pyn
       Pt3I2=BETAZ*TRANSF-Pzn
 c     
       p(1,i2)=pt1i2
       p(2,i2)=pt2i2
       p(3,i2)=pt3i2
 c
       PX1=P(1,I1)
       PY1=P(2,I1)
       PZ1=P(3,I1)
       EM1=E(I1)
       EM2=E(I2)
       ID(I1)=2
       ID(I2)=2
       RETURN
       END
 c
 c     Generate angular distribution of BB from d+meson in the CMS frame:
       subroutine dmangle(pxn,pyn,pzn,nt,ianti,pfinal,lbm)
       PARAMETER (PI=3.1415926)
       common/leadng/lb1,px1,py1,pz1,em1,e1,xfnl,yfnl,zfnl,tfnl,
      1     px1n,py1n,pz1n,dp1n
       common /dpi/em2,lb2
       COMMON /AREVT/ IAEVT, IARUN, MISS
       COMMON/RNDF77/NSEED
       SAVE   
 c     take isotropic distribution for now:
       C1=1.0-2.0*RANART(NSEED)
       T1=2.0*PI*RANART(NSEED)
       S1=SQRT(1.0-C1**2)
       CT1=COS(T1)
       ST1=SIN(T1)
 * THE MOMENTUM IN THE CMS IN THE FINAL STATE
       Pzn=pfinal*C1
       Pxn=pfinal*S1*CT1 
       Pyn=pfinal*S1*ST1
 clin-5/2008 track the number of regularly-destructed deuterons:
       if(ianti.eq.0) then
          write (91,*) ' d+',lbm,' ->BB (regular d destrn) @evt#',
      1        iaevt,' @nt=',nt,' lb1,2=',lb1,lb2
       else
          write (91,*) ' d+',lbm,' ->BB (regular dbar destrn) @evt#',
      1        iaevt,' @nt=',nt,' lb1,2=',lb1,lb2
       endif
 c
       return
       end
 c
 c     Angular distribution of d+meson elastic collisions in the CMS frame:
       subroutine dmelangle(pxn,pyn,pzn,pfinal)
       PARAMETER (PI=3.1415926)
       COMMON/RNDF77/NSEED
       SAVE   
 c     take isotropic distribution for now:
       C1=1.0-2.0*RANART(NSEED)
       T1=2.0*PI*RANART(NSEED)
       S1=SQRT(1.0-C1**2)
       CT1=COS(T1)
       ST1=SIN(T1)
 * THE MOMENTUM IN THE CMS IN THE FINAL STATE
       Pzn=pfinal*C1
       Pxn=pfinal*S1*CT1 
       Pyn=pfinal*S1*ST1
       return
       end
 c
 clin-9/2008 Deuteron+Baryon elastic cross section (in mb)
       subroutine sdbelastic(SRT,sdb)
       PARAMETER (srt0=2.012)
       common/leadng/lb1,px1,py1,pz1,em1,e1,xfnl,yfnl,zfnl,tfnl,
      1     px1n,py1n,pz1n,dp1n
       common /dpi/em2,lb2
       common /para8/ idpert,npertd,idxsec
       SAVE   
 c
       sdb=0.
       sdbel=0.
       if(srt.le.(em1+em2)) return
       s=srt**2
 c     For elastic collisions:
       if(idxsec.eq.1.or.idxsec.eq.3) then
 c     1/3: assume the same |matrix element|**2/s (after averaging over initial 
 c     spins and isospins) for d+Baryon elastic at the same sqrt(s);
          sdbel=fdbel(s)
       elseif(idxsec.eq.2.or.idxsec.eq.4) then
 c     2/4: assume the same |matrix element|**2/s (after averaging over initial 
 c     spins and isospins) for d+Baryon elastic at the same sqrt(s)-threshold:
          threshold=em1+em2
          snew=(srt-threshold+srt0)**2
          sdbel=fdbel(snew)
       endif
       sdb=sdbel
       return
       end
 clin-9/2008 Deuteron+Baryon elastic collisions
       SUBROUTINE crdbel(PX,PY,PZ,SRT,I1,I2,IBLOCK,
      1     NTAG,sig,NT,ianti)
       PARAMETER (MAXSTR=150001,MAXR=1)
       COMMON /AA/R(3,MAXSTR)
       COMMON /BB/ P(3,MAXSTR)
       COMMON /BG/BETAX,BETAY,BETAZ,GAMMA
       COMMON /CC/ E(MAXSTR)
       COMMON /EE/ ID(MAXSTR),LB(MAXSTR)
       COMMON /AREVT/ IAEVT, IARUN, MISS
       common/leadng/lb1,px1,py1,pz1,em1,e1,xfnl,yfnl,zfnl,tfnl,
      1     px1n,py1n,pz1n,dp1n
       common /dpi/em2,lb2
       common /para8/ idpert,npertd,idxsec
       COMMON /dpert/dpertt(MAXSTR,MAXR),dpertp(MAXSTR),dplast(MAXSTR),
      1     dpdcy(MAXSTR),dpdpi(MAXSTR,MAXR),dpt(MAXSTR, MAXR),
      2     dpp1(MAXSTR,MAXR),dppion(MAXSTR,MAXR)
       SAVE   
 *-----------------------------------------------------------------------
       IBLOCK=0
       NTAG=0
       EM1=E(I1)
       EM2=E(I2)
       s=srt**2
       if(sig.le.0) return
       IBLOCK=503
 c
       if(iabs(lb1).eq.42) then
          ideut=i1
          lbb=lb2
          idb=i2
       else
          ideut=i2
          lbb=lb1
          idb=i1
       endif
 cccc  Elastic collision of perturbatively-produced deuterons:
       if((idpert.eq.1.or.idpert.eq.2).and.dpertp(ideut).ne.1.) then
          if(ianti.eq.0) then
             write(91,*) '  d+',lbb,' (pert d B elastic) @nt=',nt
      1           ,' @prob=',dpertp(ideut),p(1,idb),p(2,idb)
      2           ,p(1,ideut),p(2,ideut)
          else
             write(91,*) '  d+',lbb,' (pert dbar Bbar elastic) @nt=',nt
      1           ,' @prob=',dpertp(ideut),p(1,idb),p(2,idb)
      2           ,p(1,ideut),p(2,ideut)
          endif
 
 clin-9/2012: check argument in sqrt():
          scheck=(s-(em1+em2)**2)*(s-(em1-em2)**2)
          if(scheck.lt.0) then
             write(99,*) 'scheck53: ', scheck
             scheck=0.
          endif
          pfinal=sqrt(scheck)/2./srt
 c         pfinal=sqrt((s-(em1+em2)**2)*(s-(em1-em2)**2))/2./srt
 
          CALL dbelangle(pxn,pyn,pzn,pfinal)
          CALL ROTATE(PX,PY,PZ,Pxn,Pyn,Pzn)
          EdCM=SQRT(E(ideut)**2+Pxn**2+Pyn**2+Pzn**2)
          PdBETA=Pxn*BETAX+Pyn*BETAY+Pzn*BETAZ
          TRANSF=GAMMA*(GAMMA*PdBETA/(GAMMA+1.)+EdCM)
          Pt1d=BETAX*TRANSF+Pxn
          Pt2d=BETAY*TRANSF+Pyn
          Pt3d=BETAZ*TRANSF+Pzn
          p(1,ideut)=pt1d
          p(2,ideut)=pt2d
          p(3,ideut)=pt3d
          PX1=P(1,I1)
          PY1=P(2,I1)
          PZ1=P(3,I1)
          ID(I1)=2
          ID(I2)=2
 c     Change the position of the perturbative deuteron to that of 
 c     the baryon to avoid consecutive collisions between them:
          R(1,ideut)=R(1,idb)
          R(2,ideut)=R(2,idb)
          R(3,ideut)=R(3,idb)
          return
       endif
 c
 c     Elastic collision of regularly-produced deuterons:
       if(ianti.eq.0) then
          write (91,*) ' d+',lbb,' (regular d B elastic) @evt#',
      1        iaevt,' @nt=',nt,' lb1,2=',lb1,lb2
       else
          write (91,*) ' d+',lbb,' (regular dbar Bbar elastic) @evt#',
      1        iaevt,' @nt=',nt,' lb1,2=',lb1,lb2
       endif
 clin-9/2012: check argument in sqrt():
       scheck=(s-(em1+em2)**2)*(s-(em1-em2)**2)
       if(scheck.lt.0) then
          write(99,*) 'scheck54: ', scheck
          scheck=0.
       endif
       pfinal=sqrt(scheck)/2./srt
 c      pfinal=sqrt((s-(em1+em2)**2)*(s-(em1-em2)**2))/2./srt
 
       CALL dbelangle(pxn,pyn,pzn,pfinal)
 *     ROTATE THE MOMENTA OF PARTICLES IN THE CMS OF P1+P2
 c     (This is not needed for isotropic distributions)
       CALL ROTATE(PX,PY,PZ,Pxn,Pyn,Pzn)
 *     LORENTZ-TRANSFORMATION OF THE MOMENTUM OF PARTICLES IN THE FINAL STATE 
 *     FROM THE NUCLEUS-NUCLEUS CMS. FRAME INTO LAB FRAME:
 *     For the 1st baryon:
       E1CM=SQRT(E(I1)**2+Pxn**2+Pyn**2+Pzn**2)
       P1BETA=Pxn*BETAX+Pyn*BETAY+Pzn*BETAZ
       TRANSF=GAMMA*(GAMMA*P1BETA/(GAMMA+1.)+E1CM)
       Pt1i1=BETAX*TRANSF+Pxn
       Pt2i1=BETAY*TRANSF+Pyn
       Pt3i1=BETAZ*TRANSF+Pzn
 c
       p(1,i1)=pt1i1
       p(2,i1)=pt2i1
       p(3,i1)=pt3i1
 *     For the 2nd baryon:
       E2CM=SQRT(E(I2)**2+Pxn**2+Pyn**2+Pzn**2)
       P2BETA=-Pxn*BETAX-Pyn*BETAY-Pzn*BETAZ
       TRANSF=GAMMA*(GAMMA*P2BETA/(GAMMA+1.)+E2CM)
       Pt1I2=BETAX*TRANSF-Pxn
       Pt2I2=BETAY*TRANSF-Pyn
       Pt3I2=BETAZ*TRANSF-Pzn
 c     
       p(1,i2)=pt1i2
       p(2,i2)=pt2i2
       p(3,i2)=pt3i2
 c
       PX1=P(1,I1)
       PY1=P(2,I1)
       PZ1=P(3,I1)
       EM1=E(I1)
       EM2=E(I2)
       ID(I1)=2
       ID(I2)=2
       RETURN
       END
 c
 c     Part of the cross section function of NN->Deuteron+Pi (in mb):
       function fnndpi(s)
       parameter(srt0=2.012)
       if(s.le.srt0**2) then
          fnndpi=0.
       else
          fnndpi=26.*exp(-(s-4.65)**2/0.1)+4.*exp(-(s-4.65)**2/2.)
      1        +0.28*exp(-(s-6.)**2/10.)
       endif
       return
       end
 c
 c     Angular distribution of d+baryon elastic collisions in the CMS frame:
       subroutine dbelangle(pxn,pyn,pzn,pfinal)
       PARAMETER (PI=3.1415926)
       COMMON/RNDF77/NSEED
       SAVE   
 c     take isotropic distribution for now:
       C1=1.0-2.0*RANART(NSEED)
       T1=2.0*PI*RANART(NSEED)
       S1=SQRT(1.0-C1**2)
       CT1=COS(T1)
       ST1=SIN(T1)
 * THE MOMENTUM IN THE CMS IN THE FINAL STATE
       Pzn=pfinal*C1
       Pxn=pfinal*S1*CT1 
       Pyn=pfinal*S1*ST1
       return
       end
 c
 c     Cross section of Deuteron+Pi elastic (in mb):
       function fdpiel(s)
       parameter(srt0=2.012)
       if(s.le.srt0**2) then
          fdpiel=0.
       else
          fdpiel=63.*exp(-(s-4.67)**2/0.15)+15.*exp(-(s-6.25)**2/0.3)
       endif
       return
       end
 c
 c     Cross section of Deuteron+N elastic (in mb):
       function fdbel(s)
       parameter(srt0=2.012)
       if(s.le.srt0**2) then
          fdbel=0.
       else
          fdbel=2500.*exp(-(s-7.93)**2/0.003)
      1        +300.*exp(-(s-7.93)**2/0.1)+10.
       endif
       return
       end