Adding TAmpt (Constantin)
authorhristov <hristov@f7af4fe6-9843-0410-8265-dc069ae4e863>
Thu, 4 Nov 2010 15:16:40 +0000 (15:16 +0000)
committerhristov <hristov@f7af4fe6-9843-0410-8265-dc069ae4e863>
Thu, 4 Nov 2010 15:16:40 +0000 (15:16 +0000)
33 files changed:
Makefile
TAmpt/AMPT/AliAmptRndm.cxx [new file with mode: 0644]
TAmpt/AMPT/AliAmptRndm.h [new file with mode: 0644]
TAmpt/AMPT/ampt.f [new file with mode: 0644]
TAmpt/AMPT/amptset.f [new file with mode: 0644]
TAmpt/AMPT/amptsetdef.f [new file with mode: 0644]
TAmpt/AMPT/amptsub.f [new file with mode: 0644]
TAmpt/AMPT/art1f.f [new file with mode: 0644]
TAmpt/AMPT/hijing1.383_ampt.f [new file with mode: 0644]
TAmpt/AMPT/hipyset1.35.f [new file with mode: 0644]
TAmpt/AMPT/linana.f [new file with mode: 0644]
TAmpt/AMPT/profile.f [new file with mode: 0644]
TAmpt/AMPT/readme.txt [new file with mode: 0644]
TAmpt/AMPT/zpc.f [new file with mode: 0644]
TAmpt/Acommon.h [new file with mode: 0644]
TAmpt/AliGenAmpt.cxx [new file with mode: 0644]
TAmpt/AliGenAmpt.h [new file with mode: 0644]
TAmpt/TAmpt.cxx [new file with mode: 0644]
TAmpt/TAmpt.h [new file with mode: 0644]
TAmpt/TAmptLinkDef.h [new file with mode: 0644]
TAmpt/amptLinkDef.h [new file with mode: 0644]
TAmpt/libTAmpt.pkg [new file with mode: 0644]
TAmpt/libampt.pkg [new file with mode: 0644]
TAmpt/macros/createAmptMC.C [new file with mode: 0644]
TAmpt/macros/fastGenAmpt.C [new file with mode: 0644]
TAmpt/macros/genAmptAOD.C [new file with mode: 0644]
TAmpt/macros/rootlogon.C [new file with mode: 0644]
TAmpt/macros/sim/Config.C [new file with mode: 0644]
TAmpt/macros/sim/rec.C [new file with mode: 0644]
TAmpt/macros/sim/recraw/rec.C [new file with mode: 0644]
TAmpt/macros/sim/runtest.sh [new file with mode: 0755]
TAmpt/macros/sim/sim.C [new file with mode: 0644]
build/module.dep

index d13b50e..33f27bb 100644 (file)
--- a/Makefile
+++ b/Makefile
@@ -134,6 +134,7 @@ ALIROOTMODULES := STEER PHOS TRD TPC ZDC MUON PMD FMD TOF ITS \
 ALIROOTMODULES += TUHKMgen
 ALIROOTMODULES += EPOS
 ALIROOTMODULES += PYTHIA8
+ALIROOTMODULES += TAmpt
 
 ifneq ($(shell $(ROOTCONFIG) --has-opengl), no)
 ALIROOTMODULES += EVE
diff --git a/TAmpt/AMPT/AliAmptRndm.cxx b/TAmpt/AMPT/AliAmptRndm.cxx
new file mode 100644 (file)
index 0000000..87f3ed5
--- /dev/null
@@ -0,0 +1,82 @@
+/**************************************************************************
+ * Copyright(c) 1998-1999, ALICE Experiment at CERN, All rights reserved. *
+ *                                                                        *
+ * Author: The ALICE Off-line Project.                                    *
+ * Contributors are mentioned in the code where appropriate.              *
+ *                                                                        *
+ * Permission to use, copy, modify and distribute this software and its   *
+ * documentation strictly for non-commercial purposes is hereby granted   *
+ * without fee, provided that the above copyright notice appears in all   *
+ * copies and that both the copyright notice and this permission notice   *
+ * appear in the supporting documentation. The authors make no claims     *
+ * about the suitability of this software for any purpose. It is          *
+ * provided "as is" without express or implied warranty.                  *
+ **************************************************************************/
+
+/* $Id$ */
+
+#include <TRandom.h>
+
+#include "AliAmptRndm.h"
+
+TRandom * AliAmptRndm::fgAmptRandom=0;
+
+ClassImp(AliAmptRndm)
+
+//_______________________________________________________________________
+void AliAmptRndm::SetAmptRandom(TRandom *ran) {
+  //
+  // Sets the pointer to an existing random numbers generator
+  //
+  if(ran) fgAmptRandom=ran;
+  else fgAmptRandom=gRandom;
+}
+
+//_______________________________________________________________________
+TRandom * AliAmptRndm::GetAmptRandom() {
+  //
+  // Retrieves the pointer to the random numbers generator
+  //
+  return fgAmptRandom;
+}
+
+//_______________________________________________________________________
+# define rluget_ampt rluget_ampt_
+# define rluset_ampt rluset_ampt_
+# define rlu_ampt    rlu_ampt_
+# define ranart      ranart_
+# define ran1        ran1_
+# define rlu         rlu_
+
+extern "C" {
+  void rluget_ampt(Int_t & /*lfn*/, Int_t & /*move*/)
+  {printf("Dummy version of rluget_ampt reached\n");}
+
+  void rluset_ampt(Int_t & /*lfn*/, Int_t & /*move*/)
+  {printf("Dummy version of rluset_ampt reached\n");}
+
+  Float_t rlu_ampt(Int_t & /*idum*/) 
+  {
+    // Wrapper to FINCTION RLU_AMPT from AMPT
+    // Uses static method to retrieve the pointer to the (C++) generator
+      Double_t r;
+      do r=AliAmptRndm::GetAmptRandom()->Rndm(); 
+      while(0 >= r || r >= 1);
+      return (Float_t)r;
+  }
+
+  Float_t ranart(Int_t &idum) 
+  {
+    return rlu_ampt(idum);
+  }
+
+  Float_t ran1(Int_t &idum) 
+  {
+    return rlu_ampt(idum);
+  }
+
+  Float_t rlu(Int_t &idum) 
+  {
+    return rlu_ampt(idum);
+  }
+}
diff --git a/TAmpt/AMPT/AliAmptRndm.h b/TAmpt/AMPT/AliAmptRndm.h
new file mode 100644 (file)
index 0000000..17c53ec
--- /dev/null
@@ -0,0 +1,33 @@
+#ifndef ALIAMPTRNDM_H
+#define ALIAMPTRNDM_H
+/* Copyright(c) 1998-1999, ALICE Experiment at CERN, All rights reserved. *
+ * See cxx source for full Copyright notice                               */
+
+/* $Id$ */
+
+#include <Rtypes.h>
+#include <TError.h>
+
+class TRandom;
+
+class AliAmptRndm {
+ public:
+  AliAmptRndm() {}
+  virtual ~AliAmptRndm() {
+    fgAmptRandom=0;
+  }
+  
+  static void SetAmptRandom(TRandom *ran=0);
+  static TRandom * GetAmptRandom();
+
+private:
+  AliAmptRndm(const AliAmptRndm &Ampt);
+  AliAmptRndm &operator=(const AliAmptRndm &rhs);
+
+  static TRandom * fgAmptRandom; //! pointer to the random number generator
+
+  ClassDef(AliAmptRndm,0)  //Random Number generator wrapper (non persistent)
+};
+
+#endif 
+
diff --git a/TAmpt/AMPT/ampt.f b/TAmpt/AMPT/ampt.f
new file mode 100644 (file)
index 0000000..b076884
--- /dev/null
@@ -0,0 +1,97 @@
+c.....driver program for A Multi-Phase Transport model
+      SUBROUTINE AMPT(FRAME0,BMIN,BMAX)
+c
+      double precision xmp, xmu, alpha, rscut2, cutof2
+      double precision smearp,smearh,dpcoal,drcoal,ecritl
+cgsfs added following line to match C++ call
+      double precision BMIN, BMAX
+      integer K
+c     CHARACTER*(*) FRAME0
+c     CHARACTER FRAME0*8
+      CHARACTER*(*) FRAME0
+      CHARACTER FRAME*8
+cgsfs  added to match specification in AMPTSET
+      character*25 amptvn
+
+
+      COMMON/HMAIN1/EATT,JATT,NATT,NT,NP,N0,N01,N10,N11
+      COMMON /HPARNT/HIPR1(100), IHPR2(50), HINT1(100), IHNT2(50)
+      COMMON/LUDAT1A/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
+      COMMON /ARPRNT/ ARPAR1(100), IAPAR2(50), ARINT1(100), IAINT2(50)
+      COMMON /AROUT/ IOUT
+      COMMON /AREVT/ IAEVT, IARUN, MISS
+      COMMON /smearz/smearp,smearh
+      COMMON/RNDF77/NSEED
+      common/anim/nevent,isoft,isflag,izpc
+c     parton coalescence radii in case of string melting:
+      common /coal/dpcoal,drcoal,ecritl
+      common/snn/efrm,npart1,npart2
+c     initialization value for parton cascade:
+      common /para2/ xmp, xmu, alpha, rscut2, cutof2
+      common /para7/ ioscar,nsmbbbar,nsmmeson
+      common /para8/ idpert,npertd,idxsec
+      common /rndm3/ iseedp
+c     initialization value for hadron cascade:
+      COMMON /RUN/ NUM
+      common/input1/ MASSPR,MASSTA,ISEED,IAVOID,DT
+      COMMON /INPUT2/ ILAB, MANYB, NTMAX, ICOLL, INSYS, IPOT, MODE, 
+     &   IMOMEN, NFREQ, ICFLOW, ICRHO, ICOU, KPOTEN, KMUL
+      common/oscar1/iap,izp,iat,izt
+      common/oscar2/FRAME,amptvn
+      common/resdcy/NSAV,iksdcy
+clin-6/2009:
+c      common/phidcy/iphidcy
+      common/phidcy/iphidcy,pttrig,ntrig,maxmiss
+      common/embed/iembed,pxqembd,pyqembd,xembd,yembd
+
+      EXTERNAL HIDATA, PYDATA, LUDATA, ARDATA, PPBDAT, zpcbdt
+      SAVE   
+c****************
+
+      FRAME=FRAME0
+      imiss=0
+cgsfs This line should not be here, but the value needs to be set for ARINI2
+cgsfs      K=K+1
+      K=1
+
+ 100  CALL HIJING(FRAME, BMIN, BMAX)
+      IAINT2(1) = NATT             
+
+
+c     evaluate Npart (from primary NN collisions) for both proj and targ:
+      call getnp
+c     switch for final parton fragmentation:
+      IF (IHPR2(20) .EQ. 0) GOTO 2000
+c     In the unlikely case of no interaction (even after loop of 20 in HIJING),
+c     still repeat the event to get an interaction 
+c     (this may have an additional "trigger" effect):
+      if(NATT.eq.0) then
+         imiss=imiss+1
+         if(imiss.le.20) then
+            write(6,*) 'repeated event: natt=0,j,imiss=',j,imiss
+            goto 100
+         else
+            write(6,*) 'missed event: natt=0,j=',j
+            goto 2000
+         endif
+      endif
+c.....ART initialization and run
+      CALL ARINI
+      CALL ARINI2(K)
+      CALL ARTAN1
+      CALL HJANA3
+      CALL ARTMN
+      CALL HJANA4
+      CALL ARTAN2
+
+ 2000 CONTINUE
+c
+c       CALL ARTOUT(NEVNT)
+clin-5/2009 ctest off:
+c       call flowh0(NEVNT,2)
+c       call flowp(2)
+c       call iniflw(NEVNT,2)
+c       call frztm(NEVNT,2)
+c
+      RETURN
+      END
diff --git a/TAmpt/AMPT/amptset.f b/TAmpt/AMPT/amptset.f
new file mode 100644 (file)
index 0000000..a6b310f
--- /dev/null
@@ -0,0 +1,99 @@
+      SUBROUTINE AMPTSET(EFRM0,FRAME0,PROJ0,TARG0,IAP0,IZP0,IAT0,IZT0)
+c
+cgsfs added following line to match C++ call
+      double precision EFRM0
+      double precision xmp, xmu, alpha, rscut2, cutof2
+      double precision smearp,smearh,dpcoal,drcoal,ecritl
+      CHARACTER*(*) FRAME0,PROJ0,TARG0
+      CHARACTER FRAME*8,PROJ*8,TARG*8
+      character*25 amptvn
+      COMMON/HMAIN1/EATT,JATT,NATT,NT,NP,N0,N01,N10,N11
+      COMMON /HPARNT/HIPR1(100), IHPR2(50), HINT1(100), IHNT2(50)
+      COMMON/LUDAT1A/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
+      COMMON /ARPRNT/ ARPAR1(100), IAPAR2(50), ARINT1(100), IAINT2(50)
+      COMMON /AROUT/ IOUT
+      COMMON /AREVT/ IAEVT, IARUN, MISS
+      COMMON /smearz/smearp,smearh
+      COMMON/RNDF77/NSEED
+      common/anim/nevent,isoft,isflag,izpc
+c     parton coalescence radii in case of string melting:
+      common /coal/dpcoal,drcoal,ecritl
+      common/snn/efrm,npart1,npart2
+c     initialization value for parton cascade:
+      common /para2/ xmp, xmu, alpha, rscut2, cutof2
+      common /para7/ ioscar,nsmbbbar,nsmmeson
+      common /para8/ idpert,npertd,idxsec
+      common /rndm3/ iseedp
+c     initialization value for hadron cascade:
+      COMMON /RUN/ NUM
+      common/input1/ MASSPR,MASSTA,ISEED,IAVOID,DT
+      COMMON /INPUT2/ ILAB, MANYB, NTMAX, ICOLL, INSYS, IPOT, MODE, 
+     &   IMOMEN, NFREQ, ICFLOW, ICRHO, ICOU, KPOTEN, KMUL
+      common/oscar1/iap,izp,iat,izt
+      common/oscar2/FRAME,amptvn
+      common/resdcy/NSAV,iksdcy
+clin-6/2009:
+c      common/phidcy/iphidcy
+      common/phidcy/iphidcy,pttrig,ntrig,maxmiss
+      common/embed/iembed,pxqembd,pyqembd,xembd,yembd
+      common/popcorn/ipop
+
+      EXTERNAL HIDATA, PYDATA, LUDATA, ARDATA, PPBDAT, zpcbdt
+      SAVE   
+c****************
+      EFRM=EFRM0
+      FRAME=FRAME0
+      PROJ=PROJ0
+      TARG=TARG0
+      IAP=IAP0
+      IZP=IZP0
+      IAT=IAT0
+      IZT=IZT0
+
+      if(ipop.eq.1) IHPR2(11)=3
+
+clin-6/2009 ctest off turn on jet triggering:
+c      IHPR2(3)=1
+c     Trigger Pt of high-pt jets in HIJING:
+c      HIPR1(10)=7.
+c
+
+      if(isoft.eq.1) then
+         amptvn = '1.25 (Default)'
+      elseif(isoft.eq.4) then
+         amptvn = '2.25 (StringMelting)'
+      else
+         amptvn = 'Test-Only'
+      endif
+
+      WRITE(*,50) amptvn
+ 50   FORMAT(' '/
+     &11X,'##################################################'/1X,
+     &10X,'#      AMPT (A Multi-Phase Transport) model      #'/1X,
+     &10X,'#               Version ',a20,             '     #'/1X,
+     &10X,'#                06/25/2009                      #'/1X,
+     &10X,'##################################################'/1X,
+     &10X,' ')
+
+c     an odd number is needed for the random number generator:
+      if(mod(NSEED,2).eq.0) NSEED=NSEED+1
+c     9/26/03 random number generator for f77 compiler:
+      CALL SRAND(NSEED)
+c
+c.....turn on warning messages in nohup.out when an event is repeated:
+      IHPR2(10) = 1
+c     string formation time:
+      ARPAR1(1) = 0.7
+c     smearp is the smearing halfwidth on parton z0, 
+c     set to 0 for now to avoid overflow in eta.
+c     smearh is the smearing halfwidth on string production point z0.
+      smearp=0d0
+      IAmax=max(iap,iat)
+      smearh=1.2d0*IAmax**0.3333d0/(dble(EFRM)/2/0.938d0)
+cgsfs Restored this call which was missing
+      CALL HIJSET(EFRM, FRAME, PROJ, TARG, IAP, IZP, IAT, IZT)
+      CALL ARTSET
+      CALL INIZPC
+
+      RETURN
+      END
diff --git a/TAmpt/AMPT/amptsetdef.f b/TAmpt/AMPT/amptsetdef.f
new file mode 100644 (file)
index 0000000..a31a5ce
--- /dev/null
@@ -0,0 +1,192 @@
+      SUBROUTINE AMPTSETDEF
+c
+cgsfs added following line to match C++ call
+      double precision xmp, xmu, alpha, rscut2, cutof2
+      double precision smearp,smearh,dpcoal,drcoal,ecritl
+      character*25 amptvn
+      COMMON/HMAIN1/EATT,JATT,NATT,NT,NP,N0,N01,N10,N11
+      COMMON /HPARNT/HIPR1(100), IHPR2(50), HINT1(100), IHNT2(50)
+      COMMON/LUDAT1A/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
+      COMMON /ARPRNT/ ARPAR1(100), IAPAR2(50), ARINT1(100), IAINT2(50)
+      COMMON /AROUT/ IOUT
+      COMMON /AREVT/ IAEVT, IARUN, MISS
+      COMMON /smearz/smearp,smearh
+      COMMON/RNDF77/NSEED
+      common/anim/nevent,isoft,isflag,izpc
+c     parton coalescence radii in case of string melting:
+      common /coal/dpcoal,drcoal,ecritl
+      common/snn/efrm,npart1,npart2
+c     initialization value for parton cascade:
+      common /para2/ xmp, xmu, alpha, rscut2, cutof2
+      common /para7/ ioscar,nsmbbbar,nsmmeson
+      common /para8/ idpert,npertd,idxsec
+      common /rndm3/ iseedp
+c     initialization value for hadron cascade:
+      COMMON /RUN/ NUM
+      common/input1/ MASSPR,MASSTA,ISEED,IAVOID,DT
+      COMMON /INPUT2/ ILAB, MANYB, NTMAX, ICOLL, INSYS, IPOT, MODE, 
+     &   IMOMEN, NFREQ, ICFLOW, ICRHO, ICOU, KPOTEN, KMUL
+      common/oscar1/iap,izp,iat,izt
+      common/oscar2/FRAME,amptvn
+      common/resdcy/NSAV,iksdcy
+clin-6/2009:
+c      common/phidcy/iphidcy
+      common/phidcy/iphidcy,pttrig,ntrig,maxmiss
+      common/embed/iembed,pxqembd,pyqembd,xembd,yembd
+      common/popcorn/ipop
+
+      EXTERNAL HIDATA, PYDATA, LUDATA, ARDATA, PPBDAT, zpcbdt
+      SAVE   
+c****************
+
+c     flag to select default AMPT or string melting:
+      isoft    = 1             ! ISOFT (D=1): select Default AMPT or String Melting(see below)
+c     read initialization value for hadron cascade:
+      NTMAX    = 150           ! NTMAX: number of timesteps (D=150), see below
+      DT       = 0.2           ! DT: timestep in fm (hadron cascade time= DT*NTMAX) (D=0.2)
+c     parj(41) and (42) are a and b parameters in Lund string fragmentation:
+      PARJ(41) = 2.2           ! PARJ(41): parameter a in Lund symmetric splitting function
+      PARJ(42) = 0.5           ! PARJ(42): parameter b in Lund symmetric splitting function
+c     IHPR2(11)=3 (or 2) allows the popcorn mechanism in PYTHIA and 
+c     increase the net-baryon stopping in rapidity (value HIJING is 1):
+      ipop      = 1            ! (D=1,yes;0,no) flag for popcorn mechanism(netbaryon stopping)
+c     PARJ(5) controls the fraction of BMBbar vs BBbar in popcorn:
+      PARJ(5)   = 1.0          ! PARJ(5) to control BMBbar vs BBbar in popcorn (D=1.0)
+c     shadowing flag in HIJING:
+      IHPR2(6)  = 1            ! shadowing flag (Default=1,yes; 0,no)
+c     quenching flag in HIJING:
+      IHPR2(4)  = 0            ! quenching flag (D=0,no; 1,yes)
+c     quenching rate when quenching flag is on (=1.0 GeV/fm):
+      HIPR1(14) = 2.0          ! quenching parameter -dE/dx (GeV/fm) in case quenching flag=1
+c     Minimum pt of hard or semihard scatterings in HIJING: D=2.0 GeV. 
+      HIPR1(8) = 2.0           ! p0 cutoff in HIJING for minijet productions (D=2.0)
+c     read initialization value for parton cascade:
+      xmu      = 3.2264d0      ! parton screening mass in fm^(-1) (D=3.2264d0), see below
+      izpc     = 0             ! IZPC: (D=0 forward-angle parton scatterings; 100,isotropic)
+      alpha    = 0.47140452d0  ! alpha in parton cascade
+c     quark coalescence radii in momentum and space for string melting:
+      dpcoal   = 1d6           ! dpcoal in GeV
+      drcoal   = 1d6           ! drcoal in fm
+c     flag: read in HIJING random # seed at runtime(1) or from input.ampt(D=0):
+      ihjsed   = 0             ! ihjsed: take HIJING seed from below (D=0)or at runtime(11)
+c     2 seeds for random number generators in HIJING/hadron cascade and ZPC:
+      nseed    = 53153511      ! random seed for HIJING
+      iseedp   = 8             ! random seed for parton cascade
+      iksdcy   = 0             ! flag for Ks0 weak decays (D=0,no; 1,yes)
+      iphidcy  = 1             ! flag for phi decays at end of hadron cascade (D=1,yes; 0,no)
+c     flag for OSCAR output for final partons and hadrons:
+      ioscar   = 0             ! optional OSCAR output (D=0,no; 1,yes; 2&3,more parton info)
+clin-5/2008     flag for perturbative treatment of deuterons:
+      idpert   = 0             ! flag for perturbative deuteron calculation (D=0,no; 1or2,yes)
+      npertd   = 1             ! integer factor for perturbative deuterons(>=1 & <=10000)
+      idxsec   = 1             ! choice of cross section assumptions for deuteron reactions
+clin-6/2009 To select events that have at least 1 high-Pt minijet parton:
+      pttrig   = -7.           ! Pt in GeV: generate events with >=1 minijet above this value
+      maxmiss  = 1000          ! maxmiss (D=1000): maximum # of tries to repeat a HIJING event
+      IHPR2(2) = 3             ! flag to turn off initial and final state radiation (D=3)
+      IHPR2(5) = 1             ! flag to turn off Kt kick (D=1)
+clin-6/2009 To embed a back-to-back q/qbar pair into each event:
+      iembed   = 0             ! flag to turn on quark pair embedding (D=0,no; 1to4:yes)
+      pxqembd  = 7.             ! Initial Px and Py values (GeV) of the embedded quark (u or d)
+      pyqembd  = 0.
+      xembd    = 0.             ! Initial x & y values (fm) of the embedded back-to-back q/qbar
+      yembd    = 0.
+      nsembd   = 1              ! nsembd(D=0), psembd (in GeV),tmaxembd (in radian).
+      psembd   = 5.
+      tmaxembd = 0.
+clin-7/2009 Allow modification of nuclear shadowing:
+      ishadow  = 0             ! Flag to enable users to modify shadowing (D=0,no; 1,yes)
+      dshadow  = 1.d0          ! Factor used to modify nuclear shadowing
+c
+      RETURN
+      END
+
+c$$$%%%%%%%%%% Further explanations:
+c$$$ISOFT:  1 Default, 
+c$$$        4 String Melting.
+c$$$PARJ(41) & (42): 2.2 & 0.5/GeV^2 used for heavy ion (Au+Au, Pb+Pb) collisions,
+c$$$        while the HIJING values (0.5 & 0.9/GeV^2) describe well 
+c$$$        Nch in pp collisions and are used for d-Au collisions.
+c$$$NTMAX:     number of time-steps for hadron cascade. 
+c$$$   Use a large value (e.g. 1000) for HBT studies in heavy ion collisions.
+c$$$   Using NTMAX=3 effectively turns off hadronic cascade.
+c$$$parton screening mass (in 1/fm): its square is inversely proportional to 
+c$$$   the parton cross section. Use D=3.2264d0 for 3mb cross section, 
+c$$$   and 2.2814d0 for 6mb. Using 1d4 effectively turns off parton cascade.
+c$$$ihjsed: if =11, take HIJING random seed at runtime so that 
+c$$$   every run may be automatically different (see file 'exec').
+c$$$iksdcy: flag for Ks0 weak decays for comparison with data.
+c$$$iphidcy: flag for phi meson decays at the end of hadron cascade for comparison 
+c$$$   with data; default is yes; use 0 to turn off these decays. 
+c$$$   Note: phi meson decay during hadron cascade is always enabled.
+c$$$ioscar:    0 Dafault,
+c$$$   1 Write output in the OSCAR format,
+c$$$   2 Write out the complete parton information 
+c$$$           (ana/parton-initial-afterPropagation.dat)
+c$$$           right after string melting (before parton cascade),
+c$$$   3 Write out several more files on parton information (see readme).
+c$$$idpert:    flag for perturbative deuteron and antideuteron calculations 
+c$$$   with results in ana/ampt_pert.dat:
+c$$$   0 No perturbative calculations,
+c$$$   1 Trigger a production of NPERTD perturbative deuterons 
+c$$$           in each NN collision,   
+c$$$   2 Trigger a production of NPERTD perturbative deuterons only in 
+c$$$           an NN collision where a conventional deuteron is produced.
+c$$$   Note: conventional deuteron calculations are always performed
+c$$$           with results in ana/ampt.dat.
+c$$$NPERTD:    number of perturbative deuterons produced in each triggered collision;
+c$$$   setting it to 0 turns off perturbative deuteron productions.
+c$$$idxsec: choose a cross section model for deuteron inelastic/elastic collisions:
+c$$$   1: same |matrix element|**2/s (after averaging over initial spins 
+c$$$           and isospins) for B+B -> deuteron+meson at the same sqrt(s);
+c$$$   2: same |matrix element|**2/s for B+B -> deuteron+meson 
+c$$$           at the same sqrt(s)-threshold;
+c$$$   3: same |matrix element|**2/s for deuteron+meson -> B+B 
+c$$$           at the same sqrt(s);
+c$$$   4: same |matrix element|**2/s for deuteron+meson -> B+B 
+c$$$           at the same sqrt(s)-threshold;
+c$$$   1 or 3 also chooses the same cross section for deuteron+meson or baryon
+c$$$           elastic collision at the same sqrt(s);
+c$$$   2 or 4 also chooses the same cross section for deuteron+meson or baryon
+c$$$           elastic collision at the same sqrt(s)-threshold.
+c$$$%%%%%%%%%% For jet studies:
+c$$$pttrig:    generate events with at least 1 initial minijet parton above this Pt 
+c$$$   value, otherwise repeat HIJING event until reaching maxmiss tries;
+c$$$   use a negative value to disable this requirement and get normal events.
+c$$$maxmiss: maximum number of tries for the repetition of a HIJING event to obtain
+c$$$   a minijet above the Pt value of pttrig; increase maxmiss if some events
+c$$$   fail to generate at least 1 initial minijet parton above pttrig. 
+c$$$   it is safer to set a large value for high pttrig and/or large b value
+c$$$   and/or smaller colliding nuclei.
+c$$$IHPR2(2): flag to turn off initial and final state radiation: 
+c$$$   0 both radiation off, 1 only final off, 2 only initial off, 3 both on.
+c$$$IHPR2(5): flag to turn off Pt kick due to soft interactions: 0 off, 1 on.
+c$$$   Setting both IHPR2(2) and IHPR2(5) to zero makes it more likely to 
+c$$$   have two high-Pt minijet partons that are close to back-to-back.
+c$$$%%%%%%%%%% To embed a back-to-back light q/qbar jet pair 
+c$$$%%%%%%%%%%  and a given number of soft pions along each jet into each event:
+c$$$iembed: flag to turn on quark pair embedding: 
+c$$$        1: on with fixed position(xembd,pembd) and Pt(pxqembd,pyqembd);
+c$$$        2: on with fixed position(xembd,pembd) and random azimuthal angle
+c$$$         with Pt-magnitude given by sqrt(pxqembd^2+pyqembd^2); 
+c$$$        3: on with random position and fixed Pt(pxqembd,pyqembd);
+c$$$        4: on with random position and random random azimuthal angle
+c$$$         with Pt-magnitude given by sqrt(pxqembd^2+pyqembd^2); 
+c$$$    for iembed=3 or 4: need a position file "embed-jet-xy.txt";
+c$$$   Other integers: off.
+c$$$pxqembd, pyqembd: sqrt(pxqembd^2+pyqembd^2) > 70MeV/c is required;
+c$$$   the embedded quark and antiquark have pz=0.
+c$$$xembd, yembd: the embedded quark and antiquark jets have z=0 initially. Note: 
+c$$$   the x-axis is defined as the direction along the impact parameter.
+c$$$nsembd:    number of soft pions to be embedded with each high-Pt parton
+c$$$   in the embedded jet pair.
+c$$$psembd: Momentum of each embedded soft pion in GeV.
+c$$$tmaxembd: maximum angle(rad) of embedded soft pions relative to high-Pt parton.
+c$$$%%%%%%%%%% User modification of nuclear shadowing:
+c$$$ishadow: set to 1 to enable users to adjust nuclear shadowing
+c$$$   provided the shadowing flag IHPR2(6) is turned on; default value is 0. 
+c$$$dshadow: valid when ishadow=1; this parameter modifies the HIJING shadowing
+c$$$   parameterization Ra(x,r)==1+fa(x,r) via Ra(x,r)==1+fa(x,r)*dshadow,  
+c$$$   so the value of 0.d0 turns off shadowing 
+c$$$   and the value of 1.d0 uses the default HIJING shadowing;  
+c$$$   currently limited to 0.d0<=dshadow<=1.d0 to make sure Ra(x,r)>0.
diff --git a/TAmpt/AMPT/amptsub.f b/TAmpt/AMPT/amptsub.f
new file mode 100644 (file)
index 0000000..0538830
--- /dev/null
@@ -0,0 +1,4842 @@
+c....................amptsub.f
+c.....this file contains 4 sections:
+c.....1. ART subroutines;
+c.....2. ART functions;
+c.....3. ART block data;
+c.....4. subprocesses borrowed from other codes.
+c.....5. the previous artana.f
+c.....6. the previous zpcsub.f
+c.....7. subroutine getnp
+c.....Note that Parts1-4 are the previous artsub.f
+c
+c=======================================================================
+c.....subroutine to set up ART parameters and analysis files
+c.....before looping different events
+cms
+cms   dlw & gsfs 8/2009 commented out lots of output files
+cms
+      SUBROUTINE ARTSET
+c
+      PARAMETER (AMU= 0.9383)
+      double precision dpcoal,drcoal,ecritl
+      INTEGER ZTA, ZPR
+      common  /gg/      dx,dy,dz,dpx,dpy,dpz
+clin-10/03/03 
+c     "SAVE   " (without argument) is used for most subroutines and functions,
+c     this is important for the success when using "f77" to compile:
+cc      SAVE /gg/
+      common  /zz/      zta,zpr
+cc      SAVE /zz/
+      COMMON  /RUN/     NUM
+cc      SAVE /RUN/
+      common/input1/ MASSPR,MASSTA,ISEED,IAVOID,DT
+cc      SAVE /input1/
+      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/
+      common /imulst/ iperts
+cc      SAVE /imulst/
+      common /coal/dpcoal,drcoal,ecritl
+      common/anim/nevent,isoft,isflag,izpc
+      common /para7/ ioscar,nsmbbbar,nsmmeson
+      SAVE   
+clin-10/03/03  ecritl: local energy density below which a parton 
+c     will freeze out (in GeV/fm^3), for improvements on string melting, 
+c     not used in this version of AMPT:
+clin-4/2008
+c      data ecritl/1.d0/
+      ecritl=1.d0
+c
+c     combine ART initialization into ampt.ini:
+c     (Note that the following values are relics from the old ART structure)
+c.....input parameter file
+c      OPEN(13, FILE = 'art1.ini', STATUS = 'UNKNOWN')
+c      READ (13, *) MASSTA, ZTA
+      MASSTA=1
+      ZTA=1
+c      write(12,*) massta, zta, ' massta, zta'
+c      READ (13, *) MASSPR, ZPR
+      MASSPR=1
+      ZPR=1
+c      write(12,*) masspr, zpr, ' masspr, zpr'
+c      READ (13, *) PLAB, IPLAB
+      PLAB=14.6 
+      IPLAB=2
+c      write(12,*) plab, iplab, ' plab, iplab'
+      if(iplab.eq.2)then
+         elab=sqrt(plab**2+amu**2)-amu
+      else
+         elab=plab
+      endif
+      elab=elab*1000.
+c      READ (13, *) ZEROPT
+      ZEROPT=0.
+c      write(12,*) zeropt, ' zeropt'
+clin-10/03/03 ISEED was used as a seed for random number inside ART, 
+c     not used in AMPT:
+      ISEED=700721
+c     0/1: (Normal or Perturbative) multistrange partice production.
+c     Perturbative option is disabled for now:
+      iperts=0
+c      READ (13, *) MANYB, B0, BI, BM
+c     2/04/00 MANYB MUST BE SET TO 1 !
+c     in order to skip impact parameter setting by ART, then B0 has no effect.
+      MANYB=1
+      B0=1
+      BI=0
+      BM=0
+c      write(12,*) manyb, b0, bi, bm, ' manyb, b0, bi, bm'
+c      READ (13, *) ISEED
+c      write(12,*) iseed, ' iseed'
+c      READ (13, *) DT
+c      write(12,*) dt, ' dt'
+c      READ (13, *) NTMAX
+c      write(12,*) ntmax, ' ntmax'
+c      READ (13, *) ICOLL
+      ICOLL=-1
+c      write(12,*) icoll, ' icoll'
+c      READ (13, *) NUM
+c     2/11/03 run events without test particles for now:
+      NUM=1
+c      write(12,*) num, ' num'
+c      READ (13, *) INSYS
+      INSYS=1
+c      write(12,*) insys, ' insys'
+c      READ (13, *) IPOT
+      IPOT=3
+c      write(12,*) ipot, ' ipot'
+c      READ (13, *) MODE
+      MODE=0
+      IF(ICOLL.EQ.-1)IPOT=0
+c      write(12,*) mode, ' mode'
+c      READ (13, *) DX, DY, DZ
+      DX=2.73
+      DY=2.73
+      DZ=2.73
+c      write(12,*) dx,dy,dz,' dx,dy,dz'
+c      READ (13, *) DPX, DPY, DPZ
+      DPX=0.6
+      DPY=0.6
+      DPZ=0.6
+c      write(12,*) dpx,dpy,dpz,' dpx,dpy,dpz'
+c      READ (13, *) IAVOID
+      IAVOID=1
+c      write(12,*) iavoid, ' iavoid'
+c      READ (13, *) IMOMEN
+      IMOMEN=1
+c      write(12,*) imomen, ' imomen'
+      if(icoll.eq.-1)imomen=3
+c      READ (13, *) NFREQ
+      NFREQ=10
+c      write(12,*) nfreq, ' nfreq'
+c      READ (13, *) ICFLOW
+      ICFLOW=0
+c      write(12,*) ICFLOW, ' ICFLOW'
+c      READ (13, *) ICRHO
+      ICRHO=0
+c      write(12,*) ICRHO, ' ICRHO'
+c      READ (13, *) ICOU
+      ICOU=0
+c      write(12,*)icou, ' icou'
+* kaon potential control parameter
+* KMUL IS A MULTIPLIER TO THE STANDARD K-N SCATTERING LENGTH
+c      READ (13, *) KPOTEN, KMUL
+      KPOTEN=0
+      KMUL=1
+c      write(12,*)kpoten,kmul, ' kpoten, kmul'
+* mean field control parameter FOR BARYONS
+* no mean filed is used for baryons if their 
+* local density is higher than dencut. 
+c      READ (13, *) DENCUT
+      DENCUT=15
+c      write(12,*)dencut, ' dencut'
+* test reactions in a box of side-length cycbox
+* input cycbox
+c      READ (13, *) CYCBOX
+      CYCBOX=0
+c      write(12,*) cycbox, ' cycbox'
+c
+clin-5b/2008
+c      if(ioscar.eq.2) then
+      if(ioscar.eq.2.or.ioscar.eq.3) then
+cms      OPEN (92,FILE='ana/parton-initial-afterPropagation.dat',
+cms  1        STATUS = 'UNKNOWN')
+      endif
+      if(ioscar.eq.3) then
+clin-6/2009 write out full parton collision history:
+cms      OPEN (95,FILE='ana/parton-collisionsHistory.dat',
+cms  1        STATUS='UNKNOWN')
+clin-6/2009 write out initial minijet information:
+cms      OPEN (96,FILE='ana/minijet-initial-beforePropagation.dat',
+cms  1        STATUS='UNKNOWN')
+clin-6/2009 write out parton info after coalescence:
+         if(isoft.eq.4.or.isoft.eq.5) then
+cms         OPEN (85,FILE='ana/parton-after-coalescence.dat',
+cms  1           STATUS='UNKNOWN')
+         endif
+      endif
+clin-6/2009 write out initial transverse positions of initial nucleons:
+cms   OPEN (94,FILE='ana/npart-xy.dat',STATUS='UNKNOWN')
+
+      RETURN
+      END
+
+c-----------------------------------------------------------------------
+
+c.....subroutine to initialize cascade.
+
+      SUBROUTINE ARINI
+
+c.....before invoking ARINI:
+c.....IAPAR2(1), IAINT2(1) must be set.
+      COMMON /ARPRNT/ ARPAR1(100), IAPAR2(50), ARINT1(100), IAINT2(50)
+cc      SAVE /ARPRNT/
+      SAVE   
+
+ctest off for resonance (phi, K*) studies:
+c      OPEN (89, FILE = 'ana/decay_rec.dat', STATUS = 'UNKNOWN')
+
+      IFLG = IAPAR2(1)
+      GOTO (200, 200, 300) IFLG
+
+c.....error choice of initialization
+      PRINT *, 'IAPAR2(1) must be 1, 2, or 3'
+      STOP
+
+c.....to use default initial conditions generated by the cascade,
+c.....or to read in initial conditions.
+ 200  RETURN
+
+c.....to generate formation time and the position at formation time from 
+c.....read-in initial conditions with an averaged formation proper time.
+ 300  CALL ARINI1
+c.....ordering the particle label according to increasing order of 
+c.....formation time.
+      CALL ARTORD
+      RETURN
+
+      END
+
+c-----------------------------------------------------------------------
+
+c.....subroutine to generate formation time and position at formation time
+c.....from read-in initial conditions with an averaged formation proper 
+c.....time.
+
+      SUBROUTINE ARINI1
+
+c.....before invoking ARINI1:
+c.....ARPAR1(1), IAINT2(1) must be set:
+      PARAMETER (MAXSTR=150001)
+      double precision  smearp,smearh
+
+      COMMON /ARPRNT/ ARPAR1(100), IAPAR2(50), ARINT1(100), IAINT2(50)
+cc      SAVE /ARPRNT/
+      COMMON /ARPRC/ ITYPAR(MAXSTR),
+     &     GXAR(MAXSTR), GYAR(MAXSTR), GZAR(MAXSTR), FTAR(MAXSTR),
+     &     PXAR(MAXSTR), PYAR(MAXSTR), PZAR(MAXSTR), PEAR(MAXSTR),
+     &     XMAR(MAXSTR)
+cc      SAVE /ARPRC/
+      COMMON /smearz/smearp,smearh
+cc      SAVE /smearz/
+      common/input1/ MASSPR,MASSTA,ISEED,IAVOID,DT
+cc      SAVE /input1/
+      common/anim/nevent,isoft,isflag,izpc
+cc      SAVE /anim/
+      common /nzpc/nattzp
+cc      SAVE /nzpc/
+      COMMON/HPARNT/HIPR1(100),IHPR2(50),HINT1(100),IHNT2(50)
+cc      SAVE /HPARNT/
+      COMMON/RNDF77/NSEED
+cc      SAVE /RNDF77/
+      common /para8/ idpert,npertd,idxsec
+      SAVE   
+clin-5/2008 for perturbatively-produced hadrons (currently only deuterons):
+cms   OPEN (91, FILE = 'ana/deuteron_processes.dat', 
+cms  1     STATUS = 'UNKNOWN')
+      if(idpert.eq.1.or.idpert.eq.2) then
+cms      OPEN (90, FILE = 'ana/ampt_pert.dat', STATUS = 'UNKNOWN')
+      endif
+c.....generate formation time and position at formation time.
+      TAU0 = ARPAR1(1)
+      NP = IAINT2(1)
+clin-7/10/01     initial positions already given for hadrons 
+c     formed from partons inside ZPC (from string melting):
+      if(isoft.eq.3.or.isoft.eq.4.or.isoft.eq.5) then
+         if(NP.le.nattzp) return
+         do 1001 I = nattzp+1, NP
+            IF (ABS(PZAR(I)) .GE. PEAR(I)) THEN
+               PRINT *, ' IN ARINI1'
+               PRINT *, 'ABS(PZ) .GE. EE for particle ', I
+               PRINT *, ' FLAV = ', ITYPAR(I), ' PX = ', PXAR(I), 
+     &              ' PY = ', PYAR(I)
+               PRINT *, ' PZ = ', PZAR(I), ' EE = ', PEAR(I)
+               PRINT *, ' XM = ', XMAR(I)
+               RAP = 1000000.0
+               GOTO 50
+            END IF
+            RAP = 0.5 * LOG((PEAR(I) + PZAR(I)) / (PEAR(I) - PZAR(I)))
+ 50         CONTINUE
+            VX = PXAR(I) / PEAR(I)
+            VY = PYAR(I) / PEAR(I)
+            FTAR(I) = TAU0 * COSH(RAP)
+            GXAR(I) = GXAR(I) + VX * FTAR(I)
+            GYAR(I) = GYAR(I) + VY * FTAR(I)
+            GZAR(I) = TAU0 * SINH(RAP)
+clin-5/2009 No formation time for spectator projectile or target nucleons:
+            if(PXAR(I).eq.0.and.PYAR(I).eq.0
+     1           .and.(PEAR(I)*2/HINT1(1)).gt.0.99
+     2           .and.(ITYPAR(I).eq.2112.or.ITYPAR(I).eq.2212)) then
+               TAUI=1.E-20
+               FTAR(I)=TAUI*COSH(RAP)
+               GZAR(I)=TAUI*SINH(RAP)
+            endif
+ 1001    continue
+clin-7/10/01-end
+clin-3/2009 cleanup of program flow:
+      else
+         DO 1002 I = 1, NP
+            IF (ABS(PZAR(I)) .GE. PEAR(I)) THEN
+               PRINT *, ' IN ARINI1'
+               PRINT *, 'ABS(PZ) .GE. EE for particle ', I
+               PRINT *, ' FLAV = ', ITYPAR(I), ' PX = ', PXAR(I), 
+     &              ' PY = ', PYAR(I)
+               PRINT *, ' PZ = ', PZAR(I), ' EE = ', PEAR(I)
+               PRINT *, ' XM = ', XMAR(I)
+               RAP = 1000000.0
+               GOTO 100
+c               STOP
+            END IF
+            RAP = 0.5 * LOG((PEAR(I) + PZAR(I)) / (PEAR(I) - PZAR(I)))
+ 100        CONTINUE
+            VX = PXAR(I) / PEAR(I)
+            VY = PYAR(I) / PEAR(I)
+c.....give initial formation time shift
+            TAUI = FTAR(I) + TAU0
+            FTAR(I) = TAUI * COSH(RAP)
+            GXAR(I) = GXAR(I) + VX * TAU0 * COSH(RAP)
+            GYAR(I) = GYAR(I) + VY * TAU0 * COSH(RAP)
+c     4/25/03: hadron z-position upon formation determined the same way as x,y:
+            GZAR(I) = TAUI * SINH(RAP)
+c     the old prescription:
+c            GZAR(I) = GZAR(I) + TAU0 * SINH(RAP)
+            zsmear=sngl(smearh)*(2.*RANART(NSEED)-1.)
+            GZAR(I)=GZAR(I)+zsmear
+cbz1/28/99end
+c     10/05/01 no formation time for spectator projectile or target nucleons:
+            if(PXAR(I).eq.0.and.PYAR(I).eq.0
+     1           .and.(PEAR(I)*2/HINT1(1)).gt.0.99
+     2           .and.(ITYPAR(I).eq.2112.or.ITYPAR(I).eq.2212)) then
+clin-5/2008:
+c               TAUI=0.00001
+               TAUI=1.E-20
+               FTAR(I)=TAUI*COSH(RAP)
+               GZAR(I)=TAUI*SINH(RAP)+zsmear
+            endif
+ 1002    CONTINUE
+clin-3/2009 cleanup of program flow:
+      endif
+
+clin-3/2009 Add initial hadrons before the hadron cascade starts:
+      call addhad
+
+      RETURN
+      END
+
+c-----------------------------------------------------------------------
+
+c.....subroutine to order particle labels according to increasing 
+c.....formation time
+
+      SUBROUTINE ARTORD
+
+c.....before invoking ARTORD:
+c.....IAINT2(1) must be set:
+      PARAMETER (MAXSTR=150001,MAXR=1)
+      COMMON /ARPRNT/ ARPAR1(100), IAPAR2(50), ARINT1(100), IAINT2(50)
+cc      SAVE /ARPRNT/
+      COMMON /ARPRC/ ITYPAR(MAXSTR),
+     &     GXAR(MAXSTR), GYAR(MAXSTR), GZAR(MAXSTR), FTAR(MAXSTR),
+     &     PXAR(MAXSTR), PYAR(MAXSTR), PZAR(MAXSTR), PEAR(MAXSTR),
+     &     XMAR(MAXSTR)
+cc      SAVE /ARPRC/
+clin-3/2009 Take care of particle weights when user inserts initial hadrons:
+      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)
+      DIMENSION dptemp(MAXSTR)
+c
+      DIMENSION ITYP0(MAXSTR), 
+     &   GX0(MAXSTR), GY0(MAXSTR), GZ0(MAXSTR), FT0(MAXSTR),
+     &   PX0(MAXSTR), PY0(MAXSTR), PZ0(MAXSTR), EE0(MAXSTR),
+     &   XM0(MAXSTR)
+      DIMENSION INDX(MAXSTR)
+      EXTERNAL ARINDX
+      SAVE   
+c
+      NPAR = 0
+      NP = IAINT2(1)
+      DO 1001 I = 1, NP
+         ITYP0(I) = ITYPAR(I)
+         GX0(I) = GXAR(I)
+         GY0(I) = GYAR(I)
+         GZ0(I) = GZAR(I)
+         FT0(I) = FTAR(I)
+         PX0(I) = PXAR(I)
+         PY0(I) = PYAR(I)
+         PZ0(I) = PZAR(I)
+         EE0(I) = PEAR(I)
+         XM0(I) = XMAR(I)
+clin-3/2009:
+         dptemp(I) = dpertp(I)
+ 1001 CONTINUE
+      CALL ARINDX(MAXSTR, NP, FT0, INDX)
+      DO 1002 I = 1, NP
+cbz12/3/98
+c         IF (ITYP0(INDX(I)) .EQ. 211) THEN
+c         IF (ITYP0(INDX(I)) .EQ. 211 .OR. ITYP0(INDX(I)) .EQ. 321) THEN
+c         IF (ITYP0(INDX(I)) .EQ. 211 .OR. ITYP0(INDX(I)) .EQ. 2212 .OR.
+c     &      ITYP0(INDX(I)) .EQ. 2112 .OR. ITYP0(INDX(I)) .EQ. -211 .OR.
+c     &      ITYP0(INDX(I)) .EQ. 111) THEN
+c         IF (ITYP0(INDX(I)) .EQ. 211 .OR. ITYP0(INDX(I)) .EQ. 2212 .OR.
+c     &      ITYP0(INDX(I)) .EQ. 2112) THEN
+         NPAR = NPAR + 1
+c         ITYPAR(I) = ITYP0(INDX(I))
+c         GXAR(I) = GX0(INDX(I))
+c         GYAR(I) = GY0(INDX(I))
+c         GZAR(I) = GZ0(INDX(I))
+c         FTAR(I) = FT0(INDX(I))
+c         PXAR(I) = PX0(INDX(I))
+c         PYAR(I) = PY0(INDX(I))
+c         PZAR(I) = PZ0(INDX(I))
+c         PEAR(I) = EE0(INDX(I))
+c         XMAR(I) = XM0(INDX(I))
+         ITYPAR(NPAR) = ITYP0(INDX(I))
+         GXAR(NPAR) = GX0(INDX(I))
+         GYAR(NPAR) = GY0(INDX(I))
+         GZAR(NPAR) = GZ0(INDX(I))
+         FTAR(NPAR) = FT0(INDX(I))
+         PXAR(NPAR) = PX0(INDX(I))
+         PYAR(NPAR) = PY0(INDX(I))
+         PZAR(NPAR) = PZ0(INDX(I))
+         PEAR(NPAR) = EE0(INDX(I))
+         XMAR(NPAR) = XM0(INDX(I))
+clin-3/2009:
+         dpertp(NPAR)=dptemp(INDX(I))
+c         END IF
+cbz12/3/98end
+ 1002 CONTINUE
+      IAINT2(1) = NPAR
+c
+      RETURN
+      END
+
+c-----------------------------------------------------------------------
+
+c.....subroutine to copy individually generated particle record into
+c.....particle record for many test particle runs.
+
+      SUBROUTINE ARINI2(K)
+
+      PARAMETER (MAXSTR=150001,MAXR=1)
+      COMMON /ARPRNT/ ARPAR1(100), IAPAR2(50), ARINT1(100), IAINT2(50)
+cc      SAVE /ARPRNT/
+      COMMON /ARPRC/ ITYPAR(MAXSTR),
+     &     GXAR(MAXSTR), GYAR(MAXSTR), GZAR(MAXSTR), FTAR(MAXSTR),
+     &     PXAR(MAXSTR), PYAR(MAXSTR), PZAR(MAXSTR), PEAR(MAXSTR),
+     &     XMAR(MAXSTR)
+cc      SAVE /ARPRC/
+      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/
+      COMMON/tdecay/tfdcy(MAXSTR),tfdpi(MAXSTR,MAXR),tft(MAXSTR)
+cc      SAVE /tdecay/
+      common/input1/ MASSPR,MASSTA,ISEED,IAVOID,DT
+cc      SAVE /input1/
+      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   
+
+      MULTI1(K) = IAINT2(1)
+      DO 1001 I = 1, MULTI1(K)
+         ITYP1(I, K) = ITYPAR(I)
+         GX1(I, K) = GXAR(I)
+         GY1(I, K) = GYAR(I)
+         GZ1(I, K) = GZAR(I)
+         FT1(I, K) = FTAR(I)
+         PX1(I, K) = PXAR(I)
+         PY1(I, K) = PYAR(I)
+         PZ1(I, K) = PZAR(I)
+         EE1(I, K) = PEAR(I)
+         XM1(I, K) = XMAR(I)
+clin-3/2009 hadron weights are initialized in addhad():
+clin-5/2008 all hadrons not perturbatively-produced have the weight of 1:
+c         dpp1(I,K)=1.
+         dpp1(I,K)=dpertp(I)
+ 1001 CONTINUE
+
+c     initialize final time of each particle to ntmax*dt except for 
+c     decay daughters, which have values given by tfdcy() and >(ntmax*dt):
+      do 1002 ip=1,MAXSTR
+         tfdcy(ip)=NTMAX*DT
+         tft(ip)=NTMAX*DT
+ 1002 continue
+c
+      do 1004 irun=1,MAXR
+         do 1003 ip=1,MAXSTR
+            tfdpi(ip,irun)=NTMAX*DT
+ 1003    continue
+ 1004 continue
+
+      RETURN
+      END
+
+c=======================================================================
+
+c.....function to convert PDG flavor code into ART flavor code.
+
+      FUNCTION IARFLV(IPDG)
+
+      common/input1/ MASSPR,MASSTA,ISEED,IAVOID,DT
+cc      SAVE /input1/
+      COMMON/RNDF77/NSEED
+cc      SAVE /RNDF77/
+      SAVE   
+
+c.....anti-Delta-
+      IF (IPDG .EQ. -1114) THEN
+         IARFLV = -6
+         RETURN
+      END IF
+
+c.....anti-Delta0
+      IF (IPDG .EQ. -2114) THEN
+         IARFLV = -7
+         RETURN
+      END IF
+
+c.....anti-Delta+
+      IF (IPDG .EQ. -2214) THEN
+         IARFLV = -8
+         RETURN
+      END IF
+
+c.....anti-Delta++
+      IF (IPDG .EQ. -2224) THEN
+         IARFLV = -9
+         RETURN
+      END IF
+
+cbzdbg2/23/99
+c.....anti-proton
+      IF (IPDG .EQ. -2212) THEN
+         IARFLV = -1
+         RETURN
+      END IF
+
+c.....anti-neutron
+      IF (IPDG .EQ. -2112) THEN
+         IARFLV = -2
+         RETURN
+      END IF
+cbzdbg2/23/99end
+
+c.....eta
+      IF (IPDG .EQ. 221) THEN
+         IARFLV = 0
+         RETURN
+      END IF
+
+c.....proton
+      IF (IPDG .EQ. 2212) THEN
+         IARFLV = 1
+         RETURN
+      END IF
+
+c.....neutron
+      IF (IPDG .EQ. 2112) THEN
+         IARFLV = 2
+         RETURN
+      END IF
+
+c.....pi-
+      IF (IPDG .EQ. -211) THEN
+         IARFLV = 3
+         RETURN
+      END IF
+
+c.....pi0
+      IF (IPDG .EQ. 111) THEN
+         IARFLV = 4
+         RETURN
+      END IF
+
+c.....pi+
+      IF (IPDG .EQ. 211) THEN
+         IARFLV = 5
+         RETURN
+      END IF
+
+c.....Delta-
+      IF (IPDG .EQ. 1114) THEN
+         IARFLV = 6
+         RETURN
+      END IF
+
+c.....Delta0
+      IF (IPDG .EQ. 2114) THEN
+         IARFLV = 7
+         RETURN
+      END IF
+
+c.....Delta+
+      IF (IPDG .EQ. 2214) THEN
+         IARFLV = 8
+         RETURN
+      END IF
+
+c.....Delta++
+      IF (IPDG .EQ. 2224) THEN
+         IARFLV = 9
+         RETURN
+      END IF
+
+c.....Lambda
+      IF (IPDG .EQ. 3122) THEN
+         IARFLV = 14
+         RETURN
+      END IF
+
+c.....Lambda-bar
+      IF (IPDG .EQ. -3122) THEN
+         IARFLV = -14
+         RETURN
+      END IF
+
+c.....Sigma-
+      IF (IPDG .EQ. 3112) THEN
+         IARFLV = 15
+         RETURN
+      END IF
+
+c.....Sigma-bar
+      IF (IPDG .EQ. -3112) THEN
+         IARFLV = -15
+         RETURN
+      END IF 
+
+c.....Sigma0
+      IF (IPDG .EQ. 3212) THEN
+         IARFLV = 16
+         RETURN
+      END IF
+
+c.....Sigma0-bar
+      IF (IPDG .EQ. -3212) THEN
+         IARFLV = -16
+         RETURN
+      END IF 
+
+c.....Sigma+
+      IF (IPDG .EQ. 3222) THEN
+         IARFLV = 17
+         RETURN
+      END IF
+
+c.....Sigma+ -bar
+      IF (IPDG .EQ. -3222) THEN
+         IARFLV = -17
+         RETURN
+      END IF 
+
+c.....K-
+      IF (IPDG .EQ. -321) THEN
+         IARFLV = 21
+         RETURN
+      END IF
+
+c.....K+
+      IF (IPDG .EQ. 321) THEN
+         IARFLV = 23
+         RETURN
+      END IF
+
+c.....temporary entry for K0
+      IF (IPDG .EQ. 311) THEN
+         IARFLV = 23
+         RETURN
+      END IF
+
+c.....temporary entry for K0bar
+      IF (IPDG .EQ. -311) THEN
+         IARFLV = 21
+         RETURN
+      END IF
+
+c.....temporary entry for K0S and K0L
+      IF (IPDG .EQ. 310 .OR. IPDG .EQ. 130) THEN
+         R = RANART(NSEED)
+         IF (R .GT. 0.5) THEN
+            IARFLV = 23
+         ELSE
+            IARFLV = 21
+         END IF
+         RETURN
+      END IF
+
+c.....rho-
+      IF (IPDG .EQ. -213) THEN
+         IARFLV = 25
+         RETURN
+      END IF
+
+c.....rho0
+      IF (IPDG .EQ. 113) THEN
+         IARFLV = 26
+         RETURN
+      END IF
+
+c.....rho+
+      IF (IPDG .EQ. 213) THEN
+         IARFLV = 27
+         RETURN
+      END IF
+
+c.....omega
+      IF (IPDG .EQ. 223) THEN
+         IARFLV = 28
+         RETURN
+      END IF
+
+c.....phi
+      IF (IPDG .EQ. 333) THEN
+         IARFLV = 29
+         RETURN
+      END IF
+
+c.....K*+
+      IF (IPDG .EQ. 323) THEN
+         IARFLV = 30
+         RETURN
+      END IF
+c.....K*-
+      IF (IPDG .EQ. -323) THEN
+         IARFLV = -30
+         RETURN
+      END IF
+c.....temporary entry for K*0
+      IF (IPDG .EQ. 313) THEN
+         IARFLV = 30
+         RETURN
+      END IF
+c.....temporary entry for K*0bar
+      IF (IPDG .EQ. -313) THEN
+         IARFLV = -30
+         RETURN
+      END IF
+
+c...... eta-prime
+      IF (IPDG .EQ. 331) THEN
+         IARFLV = 31
+         RETURN
+      END IF
+c...... a1
+c     IF (IPDG .EQ. 777) THEN
+c        IARFLV = 32
+c        RETURN
+c     END IF
+                                
+c... cascade-
+      IF (IPDG .EQ. 3312) THEN
+         IARFLV = 40
+         RETURN
+      END IF
+c... cascade+ (bar)
+      IF (IPDG .EQ. -3312) THEN
+         IARFLV = -40
+         RETURN
+      END IF
+c... cascade0
+      IF (IPDG .EQ. 3322) THEN
+         IARFLV = 41
+         RETURN
+      END IF
+c... cascade0 -bar
+      IF (IPDG .EQ. -3322) THEN
+         IARFLV = -41
+         RETURN
+      END IF
+c... Omega-
+      IF (IPDG .EQ. 3334) THEN
+         IARFLV = 45
+         RETURN
+      END IF 
+
+c... Omega+ (bar)
+      IF (IPDG .EQ. -3334) THEN
+         IARFLV = -45
+         RETURN
+      END IF
+
+c... Di-Omega
+      IF (IPDG .EQ. 6666) THEN
+         IARFLV = 44
+         RETURN
+      END IF
+c sp06/05/01 end    
+
+clin-3/2009 keep the same ID numbers in case there are initial deuterons:
+      IF (IPDG .EQ. 42 .or. IPDG .EQ. -42) THEN
+         IARFLV = IPDG
+         RETURN
+      END IF
+
+c.....other
+      IARFLV = IPDG + 10000
+
+      RETURN
+      END
+
+c-----------------------------------------------------------------------
+
+c.....function to convert ART flavor code into PDG flavor code.
+
+      FUNCTION INVFLV(IART)
+
+      common/input1/ MASSPR,MASSTA,ISEED,IAVOID,DT
+cc      SAVE /input1/
+      COMMON/RNDF77/NSEED
+cc      SAVE /RNDF77/
+      SAVE   
+
+c.....anti-Delta-
+      IF (IART .EQ. -6) THEN
+         INVFLV = -1114
+         RETURN
+      END IF
+
+c.....anti-Delta0
+      IF (IART .EQ. -7) THEN
+         INVFLV = -2114
+         RETURN
+      END IF
+
+c.....anti-Delta+
+      IF (IART .EQ. -8) THEN
+         INVFLV = -2214
+         RETURN
+      END IF
+
+c.....anti-Delta++
+      IF (IART .EQ. -9) THEN
+         INVFLV = -2224
+         RETURN
+      END IF
+
+cbzdbg2/23/99
+c.....anti-proton
+      IF (IART .EQ. -1) THEN
+         INVFLV = -2212
+         RETURN
+      END IF
+
+c.....anti-neutron
+      IF (IART .EQ. -2) THEN
+         INVFLV = -2112
+         RETURN
+      END IF
+cbzdbg2/23/99end
+
+c.....eta
+      IF (IART .EQ. 0) THEN
+         INVFLV = 221
+         RETURN
+      END IF
+
+c.....proton
+      IF (IART .EQ. 1) THEN
+         INVFLV = 2212
+         RETURN
+      END IF
+
+c.....neutron
+      IF (IART .EQ. 2) THEN
+         INVFLV = 2112
+         RETURN
+      END IF
+
+c.....pi-
+      IF (IART .EQ. 3) THEN
+         INVFLV = -211
+         RETURN
+      END IF
+
+c.....pi0
+      IF (IART .EQ. 4) THEN
+         INVFLV = 111
+         RETURN
+      END IF
+
+c.....pi+
+      IF (IART .EQ. 5) THEN
+         INVFLV = 211
+         RETURN
+      END IF
+
+c.....Delta-
+      IF (IART .EQ. 6) THEN
+         INVFLV = 1114
+         RETURN
+      END IF
+
+c.....Delta0
+      IF (IART .EQ. 7) THEN
+         INVFLV = 2114
+         RETURN
+      END IF
+
+c.....Delta+
+      IF (IART .EQ. 8) THEN
+         INVFLV = 2214
+         RETURN
+      END IF
+
+c.....Delta++
+      IF (IART .EQ. 9) THEN
+         INVFLV = 2224
+         RETURN
+      END IF
+
+cc.....N*(1440), N*(1535) temporary entry
+c      IF (IART .GE. 10 .AND. IART .LE.13) THEN
+c         INVFLV = 0
+c         RETURN
+c      END IF
+
+c.....Lambda
+      IF (IART .EQ. 14) THEN
+         INVFLV = 3122
+         RETURN
+      END IF
+c.....Lambda-bar
+      IF (IART .EQ. -14) THEN
+         INVFLV = -3122
+         RETURN
+      END IF 
+
+cbz3/12/99
+c.....temporary entry for Sigma's
+c      IF (IART .EQ. 15) THEN
+c         R = RANART(NSEED)
+c         IF (R .GT. 2. / 3.) THEN
+c            INVFLV = 3112
+c         ELSE IF (R .GT. 1./ 3. .AND. R .LE. 2. / 3.) THEN
+c            INVFLV = 3212
+c         ELSE
+c            INVFLV = 3222
+c         END IF
+c         RETURN
+c      END IF
+
+c.....Sigma-
+      IF (IART .EQ. 15) THEN
+         INVFLV = 3112
+         RETURN
+      END IF
+
+c.....Sigma- bar
+      IF (IART .EQ. -15) THEN
+         INVFLV = -3112
+         RETURN
+      END IF 
+
+c.....Sigma0
+      IF (IART .EQ. 16) THEN
+         INVFLV = 3212
+         RETURN
+      END IF
+
+c.....Sigma0 -bar
+      IF (IART .EQ. -16) THEN
+         INVFLV = -3212
+         RETURN
+      END IF
+
+c.....Sigma+
+      IF (IART .EQ. 17) THEN
+         INVFLV = 3222
+         RETURN
+      END IF
+
+c.....Sigma+ -bar
+      IF (IART .EQ. -17) THEN
+         INVFLV = -3222
+         RETURN
+      END IF 
+
+clin-2/23/03 K0S and K0L are generated at the last timestep:
+c.....temporary entry for K- and K0bar
+      IF (IART .EQ. 21) THEN
+c         R = RANART(NSEED)
+c         IF (R .GT. 0.5) THEN
+            INVFLV = -321
+c         ELSE
+c            INVFLV = -311
+c            R = RANART(NSEED)
+c            IF (R .GT. 0.5) THEN
+c               INVFLV = 310
+c            ELSE
+c               INVFLV = 130
+c            END IF
+c         END IF
+         RETURN
+      END IF
+
+c.....temporary entry for K+ and K0
+      IF (IART .EQ. 23) THEN
+c         R = RANART(NSEED)
+c         IF (R .GT. 0.5) THEN
+            INVFLV = 321
+c         ELSE
+c            INVFLV = 311
+c            R = RANART(NSEED)
+c            IF (R .GT. 0.5) THEN
+c               INVFLV = 310
+c            ELSE
+c               INVFLV = 130
+c            END IF
+c         END IF
+         RETURN
+      END IF
+
+c.....K0Long:
+      IF (IART .EQ. 22) THEN
+         INVFLV = 130
+         RETURN
+      ENDIF
+c.....K0Short:
+      IF (IART .EQ. 24) THEN
+         INVFLV = 310
+         RETURN
+      ENDIF
+
+c.....rho-
+      IF (IART .EQ. 25) THEN
+         INVFLV = -213
+         RETURN
+      END IF
+
+c.....rho0
+      IF (IART .EQ. 26) THEN
+         INVFLV = 113
+         RETURN
+      END IF
+
+c.....rho+
+      IF (IART .EQ. 27) THEN
+         INVFLV = 213
+         RETURN
+      END IF
+
+c.....omega
+      IF (IART .EQ. 28) THEN
+         INVFLV = 223
+         RETURN
+      END IF
+
+c.....phi
+      IF (IART .EQ. 29) THEN
+         INVFLV = 333
+         RETURN
+      END IF
+
+c.....temporary entry for K*+ and K*0
+      IF (IART .EQ. 30) THEN
+         INVFLV = 323
+         IF (RANART(NSEED).GT.0.5) INVFLV = 313
+         RETURN
+      END IF
+
+c.....temporary entry for K*- and K*0bar
+      IF (IART .EQ. -30) THEN
+         INVFLV = -323
+         IF (RANART(NSEED).GT.0.5) INVFLV = -313
+         RETURN
+      END IF
+
+c... eta-prime (bar)
+      IF (IART .EQ. 31) THEN
+         INVFLV = 331
+         RETURN
+      END IF
+c... a1
+      IF (IART .EQ. 32) THEN
+         INVFLV = 777
+         RETURN
+      END IF
+c... cascade-
+      IF (IART .EQ. 40) THEN
+         INVFLV = 3312
+         RETURN
+      END IF                   
+
+c... cascade+ (bar)
+      IF (IART .EQ. -40) THEN
+         INVFLV = -3312
+         RETURN
+      END IF
+c... cascade0
+      IF (IART .EQ. 41) THEN
+         INVFLV = 3322
+         RETURN
+      END IF
+c... cascade0 -bar
+      IF (IART .EQ. -41) THEN
+         INVFLV = -3322
+         RETURN
+      END IF
+c... Omega-
+      IF (IART .EQ. 45) THEN
+         INVFLV = 3334
+         RETURN
+      END IF
+
+c... Omega+ (bar)
+      IF (IART .EQ. -45) THEN
+         INVFLV = -3334
+         RETURN
+      END IF
+
+c... Di-Omega
+      IF (IART .EQ. 44) THEN
+         INVFLV = 6666
+         RETURN
+      END IF
+c sp 12/19/00 end           
+
+clin-5/2008 deuteron ID numbers in ART and ampt.dat:
+      IF (IART .EQ. 42) THEN
+         INVFLV = 1000000000+10020
+         RETURN
+      ELSEIF (IART .EQ. -42) THEN         
+         INVFLV = -1000000000-10020
+         RETURN
+      END IF
+c
+c.....other
+      INVFLV = IART - 10000
+
+      RETURN
+      END
+
+c=======================================================================
+
+      BLOCK DATA ARDATA
+
+      COMMON /ARPRNT/ ARPAR1(100), IAPAR2(50), ARINT1(100), IAINT2(50)
+cc      SAVE /ARPRNT/
+      SAVE   
+      DATA ARPAR1/1.19, 99 * 0.0/
+      DATA IAPAR2/3, 49 * 0/
+      DATA ARINT1/100 * 0.0/
+      DATA IAINT2/50 * 0/
+
+      END
+
+c=======================================================================
+
+c.....Routine borrowed from ZPC.
+c.....double precision  is modified to real*4.
+
+cbz1/29/99
+c      subroutine index1(n, m, arrin, indx)
+      subroutine arindx(n, m, arrin, indx)
+cbz1/29/99end
+c     indexes the first m elements of ARRIN of length n, i.e., outputs INDX
+c     such that ARRIN(INDEX(J)) is in ascending order for J=1,...,m
+
+c      implicit real*4 (a-h, o-z)
+
+      dimension arrin(n), indx(n)
+      SAVE   
+      do 1001 j = 1, m
+         indx(j) = j
+ 1001 continue
+      l = m / 2 + 1
+      ir = m
+ 10   continue
+      if (l .gt. 1) then
+         l = l - 1
+         indxt = indx(l)
+         q = arrin(indxt)
+      else
+         indxt = indx(ir)
+         q = arrin(indxt)
+         indx(ir) = indx(1)
+         ir = ir - 1
+         if (ir .eq. 1) then
+            indx(1) = indxt
+            return
+         end if
+      end if
+      i = l
+      j = l + l
+ 20   if (j .le. ir) then
+         if (j .lt. ir) then
+            if (arrin(indx(j)) .lt. arrin(indx(j + 1))) j = j + 1
+         end if
+         if (q .lt. arrin(indx(j))) then
+            indx(i) = indx(j)
+            i = j
+            j = j + j
+         else
+            j = ir + 1
+         end if
+      goto 20
+      end if
+      indx(i) = indxt
+      goto 10
+
+      end
+
+c-----------------------------------------------------------------------
+
+c.....extracted from G. Song's ART expasion including K- interactions
+c.....file `NEWKAON.FOR'
+
+c     5/01/03 send iblock value into art1f.f, necessary for resonance studies:
+c        subroutine newka(icase,irun,iseed,dt,nt,ictrl,i1,i2,
+c     &                                   srt,pcx,pcy,pcz)
+        subroutine newka(icase,irun,iseed,dt,nt,ictrl,i1,i2,
+     &                                   srt,pcx,pcy,pcz,iblock)
+      PARAMETER      (MAXSTR=150001,MAXR=1)
+      PARAMETER      (AKA=0.498)
+      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   /BG/BETAX,BETAY,BETAZ,GAMMA
+cc      SAVE /BG/
+      COMMON   /NN/NNN
+cc      SAVE /NN/
+      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   
+c
+        logical lb1bn, lb2bn,lb1mn,lb2mn
+cbz3/7/99 neutralk
+c        logical lb1bn1, lb2bayon1, lb1bn0, lb2bn0
+        logical lb1bn1, lb2bn1, lb1bn0, lb2bn0
+cbz3/7/99 neutralk end
+        logical lb1mn0, lb2mn0, lb1mn1, lb2mn1
+        logical lb1mn2, lb2mn2
+        icase=-1
+c        icase: flag for the type of reaction that is going to happen.
+c        icase=-1,  no desired reaction, return to main program.
+c              1,  NN,ND,DD
+c              2,  PI+N, PI+D
+c              3,  K(-) absorption.
+        nchrg=-100
+c        nchrg: Net charges of the two incoming particles.
+        ictrl = 1
+        lb1=lb(i1)
+        lb2=lb(i2)
+        em1=e(i1)
+        em2=e(i2)
+        lb1bn=lb1.eq.1.or.lb1.eq.2.or.(lb1.gt.5.and.lb1.le.13)
+        lb2bn=lb2.eq.1.or.lb2.eq.2.or.(lb2.gt.5.and.lb2.le.13)
+        lb1bn0=lb1.eq.2.or.lb1.eq.7.or.lb1.eq.10.or.lb1.eq.12
+        lb2bn0=lb2.eq.2.or.lb2.eq.7.or.lb2.eq.10.or.lb2.eq.12
+        lb1bn1=lb1.eq.1.or.lb1.eq.8.or.lb1.eq.11.or.lb1.eq.13
+        lb2bn1=lb2.eq.1.or.lb2.eq.8.or.lb2.eq.11.or.lb2.eq.13
+        lb1mn=em1.lt.0.2.or.lb1.eq.0.or.(lb1.ge.25.and.lb1.le.29)
+        lb2mn=em2.lt.0.2.or.lb2.eq.0.or.(lb2.ge.25.and.lb2.le.29)
+        lb1mn0=lb1.eq.0.or.lb1.eq.4.or.lb1.eq.26.or.
+     &                        lb1.eq.28.or.lb1.eq.29
+        lb2mn0=lb2.eq.0.or.lb2.eq.4.or.lb2.eq.26.or.
+     &                        lb2.eq.28.or.lb2.eq.29
+        lb1mn1= lb1.eq.5.or.lb1.eq.27
+        lb2mn1= lb2.eq.5.or.lb2.eq.27
+        lb1mn2=lb1.eq.3.or.lb1.eq.25
+        lb2mn2=lb2.eq.3.or.lb2.eq.25
+
+c        1. consider N+N, N+Resonance, R + R reactions
+        if(lb1bn.and.lb2bn) then
+c     NN,ND,DD:
+           icase=1
+c     total cross section
+           sig=40.
+           if(lb1.eq.9.and.lb2.eq.9) then
+                nchrg=4
+           endif   
+           if((lb1bn1.and.lb2.eq.9)
+     &        .or.(lb2bn1.and.lb1.eq.9))then
+                nchrg=3
+           endif
+           if((lb1bn0.and.lb2.eq.9)
+     &        .or.(lb2bn0.and.lb1.eq.9)
+     &        .or.(lb1bn1.and.lb2bn1)) then
+                   nchrg=2
+           endif
+           if((lb1bn1.and.lb2bn0).or.(lb1.eq.6.and.lb2.eq.9)
+     &        .or.(lb2bn1.and.lb1bn0)
+     &        .or.(lb2.eq.6.and.lb1.eq.9))then
+                   nchrg=1
+           endif
+           if((lb1bn0.and.lb2bn0).or.(lb1bn1.and.lb2.eq.6)
+     &              .or.(lb2bn1.and.lb1.eq.6)) then
+                   nchrg=0
+           endif
+           if((lb1bn0.and.lb2.eq.6)
+     &        .or.(lb2bn0.and.lb1.eq.6))then
+                nchrg=-1
+           endif
+           if(lb1.eq.6.and.lb2.eq.6) then
+                nchrg=-2
+           endif
+c     brsig = x2kaon_no_isospin(srt)
+           if(nchrg.ge.-1.and.nchrg.le.2) then
+c     K,Kbar prduction x sect.
+                   brsig = x2kaon(srt)
+           else
+                   brsig=0.0
+c                if(nchrg.eq.-2.or.nchrg.eq.3) then
+c                   brsig = x2kaon(srt+0.938-1.232)
+c                else
+c     nchrg=4
+c                   brsig = x2kaon(srt+2.*(0.938-1.232))
+c                endif
+           endif
+
+cbz3/7/99 neutralk
+           BRSIG = 2.0 * BRSIG
+cbz3/7/99 neutralk end
+
+        endif
+
+c        2. consider PI(meson:eta,omega,rho,phi) + N(N*,D)
+        if((lb1bn.and.lb2mn).OR.(lb2bn.and.lb1mn)) then
+c     PN,PD
+          icase=2
+          sig=20.
+          sigma0 = piNsg0(srt)
+          brsig=0.0
+          if((lb1bn1.and.lb2mn0)
+     &       .or.(lb2bn1.and.lb1mn0).
+     & or.(lb1bn0.and.lb2mn1).or.(lb2bn0.and.lb1mn1).
+     & or.(lb1.eq.9.and.lb2mn2).or.(lb2.eq.9.and.lb1mn2))then
+                nchrg=1
+cbz3/2/99/song
+c                if(lb1bn1.or.lb2bn1) brsig=2.0*sigma0
+c                if(lb1bn0.or.lb2bn0) brsig=0.5*sigma0
+                if(lb1bn1.or.lb2bn1) brsig=0.5*sigma0
+                if(lb1bn0.or.lb2bn0) brsig=2.0*sigma0
+cbz3/2/99/song end
+c                if(lb1.eq.9.or.lb2.eq.9) brsig=1.5*sigma0
+          endif
+          if( (lb1bn0.and.lb2mn0 )
+     &       .or.(lb2bn0.and.lb1mn0)
+     &  .or.(lb1bn1.and.lb2mn2).or.(lb2bn1.and.lb1mn2)
+     &  .or.(lb1.eq.6.and.lb2mn1).or.(lb2.eq.6.and.lb1mn1)) then
+                nchrg=0
+                if(lb1bn1.or.lb2bn1) then
+cbz3/2/99/song
+c                  brsig=1.5*sigma0
+                  brsig=3.0*sigma0
+cbz3/2/99/song end
+cbz3/11/99/song
+c                  ratiok = 1./3.
+                  ratiok = 2./3.
+cbz3/11/99/song end
+
+c                  ratiok: the ratio of channels: ->nK+k- vs. -> pK0K-
+                endif
+                if(lb1bn0.or.lb2bn0) then
+                  brsig=2.5*sigma0
+cbz3/2/99/song
+c                  ratiok = 0.8
+                  ratiok = 0.2
+cbz3/2/99/song end
+                endif
+c                if(lb1.eq.6.or.lb2.eq.6) then
+c     lb=6 : D-
+c                  brsig=1.5*sigma0
+c                  ratiok = 0.5
+c                endif
+          endif
+          if( (lb1bn0.and.lb2mn2)
+     &       .or.(lb2bn0.and.lb1mn2)
+     & .or.(lb1.eq.6.and.lb2mn0).or.(lb2.eq.6.and.lb1mn0)) then
+                nchrg=-1
+                if(lb1bn0.or.lb2bn0) brsig=sigma0
+c                if(lb1.eq.6.or.lb2.eq.6) brsig=sigma0
+          endif
+c          if((lb1.eq.6.and.lb2mn2).or.(lb2.eq.6.and.lb1mn2))then
+c                nchrg=-2
+c          endif
+c          if((lb1bn1.and.lb2mn1).or.(lb2bn1.and.lb1mn1)
+c    &           .or.(lb1.eq.9.and.lb2mn0).or.(lb2.eq.9.and.lb1mn0)) then
+c                nchrg=2
+c          endif
+
+cbz3/11/99 neutralk
+          if((lb1.eq.6.and.lb2mn2)
+     &       .or.(lb2.eq.6.and.lb1mn2))then
+                nchrg=-2
+          endif
+cbz3/11/99 neutralk
+cbz3/8/99 neutralk
+          if((lb1bn1.and.lb2mn1)
+     &       .or.(lb2bn1.and.lb1mn1)
+     & .or.(lb1.eq.9.and.lb2mn0).or.(lb2.eq.9.and.lb1mn0)) then
+                nchrg=2
+          endif
+cbz3/8/99 neutralk end
+
+cbz3/7/99 neutralk
+          IF (NCHRG .GE. -2 .AND. NCHRG .LE. 2) THEN
+             BRSIG = 3.0 * SIGMA0
+          END IF
+cbz3/7/99 neutralk end
+
+        endif
+
+c        3. consider K- + N(N*,D) absorption.
+c        if((lb1bn.and.lb2.eq.21).OR.(lb2bn.and.lb1.eq.21)) then
+        if( (lb1bn.and.(lb2.eq.21.or.lb2.eq.-30)).OR.
+     &     (lb2bn.and.(lb1.eq.21.or.lb1.eq.-30)) )then 
+c          bmass=em1+em2-aka
+          bmass=0.938
+          if(srt.le.(bmass+aka)) then
+cbz3/2/99
+c                write(100,*)'--lb1,lb2,em1,em2,srt',lb1,lb2,em1,em2,srt
+cbz3/2/99end
+                pkaon=0.
+          else
+            pkaon=sqrt(((srt**2-(aka**2+bmass**2))/2./bmass)**2-aka**2)
+          endif
+          sig=0.
+          if(lb1.eq.1.or.lb2.eq.1.or.lb1.eq.8.or.lb2.eq.8.or.
+     &    lb1.eq.11.or.lb2.eq.11.or.lb1.eq.13.or.lb2.eq.13) then
+c          K- + (D+,N*+)p ->
+              nchrg=0
+              sigela=akPel(pkaon)
+              sigsgm=3.*akPsgm(pkaon)
+              sig=sigela+sigsgm+akPlam(pkaon)
+          endif
+          if(lb1.eq.2.or.lb2.eq.2.or.lb1.eq.7.or.lb2.eq.7.or.
+     &    lb1.eq.10.or.lb2.eq.10.or.lb1.eq.12.or.lb2.eq.12) then
+c          K- + (D0, N*0)n ->
+              nchrg=-1
+              sigela=akNel(pkaon)
+              sigsgm=2.*akNsgm(pkaon)
+              sig=sigela+sigsgm+akNlam(pkaon)
+          endif
+          if(lb1.eq.6.or.lb2.eq.6) then
+c     K- + D-
+              nchrg=-2
+              sigela=akNel(pkaon)
+              sigsgm=akNsgm(pkaon)
+              sig=sigela+sigsgm
+          endif
+          if(lb1.eq.9.or.lb2.eq.9) then
+c     K- + D++
+              nchrg=1
+              sigela=akPel(pkaon)
+              sigsgm=2.*akPsgm(pkaon)
+              sig=sigela+sigsgm+akPlam(pkaon)
+          endif
+
+cbz3/8/99 neutralk
+          sigela = 0.5 * (AKPEL(PKAON) + AKNEL(PKAON))
+          SIGSGM = 1.5 * AKPSGM(PKAON) + AKNSGM(PKAON)
+          SIG = sigela + SIGSGM + AKPLAM(PKAON)
+cbz3/8/99 neutralk end
+
+          if(sig.gt.1.e-7) then
+c     K(-) + N reactions
+              icase=3
+              brel=sigela/sig
+              brsgm=sigsgm/sig
+c              branch_lambda=akNlam(pkaon)/sig
+              brsig = sig
+          endif
+        endif
+
+c        4. meson + hyperon -> K- + N
+c        if(((lb1.ge.14.and.lb1.le.17).and.lb2mn).OR.
+c     &     ((lb2.ge.14.and.lb2.le.17).and.lb1mn)) then
+        if(((lb1.ge.14.and.lb1.le.17).and.(lb2.ge.3.and.lb2.le.5)).OR.
+     &     ((lb2.ge.14.and.lb2.le.17).and.(lb1.ge.3.and.lb1.le.5)))then
+c        first classify the reactions due to total charge.
+           nchrg=-100
+           if((lb1.eq.15.and.(lb2.eq.3.or.lb2.eq.25)).OR.
+     &              (lb2.eq.15.and.(lb1.eq.3.or.lb1.eq.25))) then
+                nchrg=-2
+c     D-
+                  bmass=1.232
+           endif
+           if((lb1.eq.15.and.lb2mn0).or.(lb2.eq.15.and.lb1mn0).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     n
+                 bmass=0.938
+           endif
+           if((lb1.eq.15.and.(lb2.eq.5.or.lb2.eq.27)).OR.
+     &              (lb2.eq.15.and.(lb1.eq.5.or.lb1.eq.27)).or.
+     &        (lb1.eq.17.and.(lb2.eq.3.or.lb2.eq.25)).OR.
+     &              (lb2.eq.17.and.(lb1.eq.3.or.lb1.eq.25)).or.
+     &       ((lb1.eq.14.or.lb1.eq.16).and.lb2mn0).OR.
+     &       ((lb2.eq.14.or.lb2.eq.16).and.lb1mn0)) then
+                nchrg=0
+c     p
+                 bmass=0.938
+           endif
+           if((lb1.eq.17.and.lb2mn0).or.(lb2.eq.17.and.lb1mn0).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     D++
+                 bmass=1.232
+           endif
+           sig = 0.
+           if(nchrg.ne.-100.and.srt.gt.(aka+bmass)) then
+c     PI+sigma or PI + Lambda => Kbar + N reactions
+             icase=4
+c             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 + 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 + 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)
+
+cbz3/8/99 neutralk
+                SIGMA0 = 1.5 * AKPSGM(PKAON) + AKNSGM(PKAON)
+cbz3/8/99 neutralk end
+
+             endif
+             sig=(srt**2-(aka+bmass)**2)*(srt**2-(aka-bmass)**2)/
+     &         (srt**2-(em1+em2)**2)/(srt**2-(em1-em2)**2)*sigma0
+cbz3/8/99 neutralk
+c     if(nchrg.eq.-2.or.nchrg.eq.1) sig=2.*sig K-D++, K-D-
+c     K0barD++, K-D-
+             if(nchrg.eq.-2.or.nchrg.eq.2) sig=2.*sig
+
+cbz3/8/99 neutralk end
+
+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
+
+cbz3/8/99 neutralk
+             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
+cbz3/8/99 neutralk end
+             brsig = sig
+             if(sig.lt.1.e-7) sig = 1.e-7
+           endif
+csp05/07/01
+* comment icase=4 statement below if only inelastic
+c     PI+L/Si => Kbar + N  OR ELASTIC SCATTERING
+           icase=4
+           brsig = sig
+c     elastic xsecn of 10mb
+           sigela = 10.
+           sig = sig + sigela
+           brel = sigela/sig
+cc          brsig = sig
+csp05/07/01 end   
+        endif
+c
+c        if(em2.lt.0.2.and.em1.lt.0.2) then
+c     PI + PI 
+c             icase=5
+c     assumed PI PI total x section.
+c              sig=50.
+c     Mk + Mkbar
+c              s0=aka+aka
+c              brsig = 0.
+c              if(srt.gt.s0) brsig = 2.7*(1.-s0**2/srt**2)**0.76
+c              x section for PIPI->KKbar   PRC43 (1991) 1881
+c        endif
+        if(icase.eq.-1) then
+           ictrl = -1
+           return
+        endif
+        px1cm=pcx
+        py1cm=pcy
+        pz1cm=pcz
+        ds=sqrt(sig/31.4)
+        dsr=ds+0.1
+        ec=(em1+em2+0.02)**2
+c        ec=3.59709
+c        if((e(i1).ge.1.).and.(e(i2).ge.1.)) ec = 4.75
+
+        call distce(i1,i2,dsr,ds,dt,ec,srt,ic,px1cm,py1cm,pz1cm)
+        if(ic.eq.-1) then
+c     no anti-kaon production
+           ictrl = -1
+c           in=in+1
+c           write(60,*)'--------------distance-----',in
+           return
+        endif
+
+clin-10/24/02 set to 0: ik,ik0-3,il,im,im3-4,in,inpion,ipipi, 
+c     sgsum,sgsum1,sgsum3:
+        ik=0
+        ik0=0
+        ik1=0
+        ik2=0
+        ik3=0
+        il=0
+        im=0
+        im3=0
+        im4=0
+        in=0
+        inpion=0
+        ipipi=0
+        sgsum=0.
+        sgsum1=0.
+        sgsum3=0.
+        if(icase.eq.1) then
+           ik=ik+1
+           if(srt.gt.2.8639) then
+                ik0=ik0+1
+                if(em1.lt.1.0.and.em2.lt.1.0) then
+                        ik1=ik1+1
+                        sgsum1=sgsum1+brsig
+c                        ratio_1=sgsum1/ik1/40.
+                endif
+                if(em1.gt.1.0.and.em2.gt.1.0) then
+                        ik3=ik3+1
+                        sgsum3=sgsum3+brsig
+c                        ratio_3=sgsum3/ik3/40.
+                endif
+                if(em1.gt.1.0.and.em2.lt.1.0) ik2=ik2+1
+                if(em1.lt.1.0.and.em2.gt.1.0) ik2=ik2+1
+                sgsum=sgsum+brsig
+c                ratio=sgsum/ik0/40.
+           endif
+        endif
+        if(icase.eq.2) inpion=inpion+1
+        if(icase.eq.5) ipipi=ipipi+1
+c        write(62,*)'ik1,ik2,ik3',ik1,ik2,ik3,ratio_1,ratio_3,ratio
+c        write(62,*)'inpion,ipipi',inpion,ipipi
+        if(RANART(NSEED).gt.(brsig/sig)) then
+c     no anti-kaon production
+           ictrl = -1
+           return
+        endif
+        il=il+1
+c        kaons could be created now.
+        if(icase.eq.1) then
+          in=in+1
+c          write(60,*)'------in,s2kaon,sig=',in,brsig,sig,lb1,lb2
+          call nnkaon(irun,iseed,
+     &          ictrl,i1,i2,iblock,srt,pcx,pcy,pcz,nchrg)
+        endif
+        if(icase.eq.2) then
+          im=im+1
+c          call npik(irun,iseed,dt,nt,ictrl,i1,i2,srt,
+c     &              pcx,pcy,pcz,nchrg,ratiok)
+          call npik(irun,iseed,dt,nt,ictrl,i1,i2,srt,
+     &              pcx,pcy,pcz,nchrg,ratiok,iblock)
+        endif
+c
+        if(icase.eq.3) then
+          im3=im3+1
+c          write(63,*)'im3,lb1,lb2,pkaon',im3,lb1,lb2,pkaon
+c          write(63,*)'sig,el,sigma',sig,brel,brsgm
+c          write(63,*)'srt,pcx,pcy,pcz,em1,em2',srt,pcx,pcy,pcz,em1,em2
+          call kaonN(brel,brsgm,irun,iseed,dt,nt,ictrl,
+     &                i1,i2,iblock,srt,pcx,pcy,pcz,nchrg)
+c         this subroutine format is diff. since three final states are possible
+        endif
+c
+
+        if(icase.eq.4) then
+          im4=im4+1
+c          write(64,*)'im4,sigma0,branch,sig=',im4,sigma0,brsig,sig
+c          write(64,*)'lb1,lb2,em1,em2,pkaon=',lb1,lb2,em1,em2,pkaon
+
+csp06/07/01
+      if(RANART(NSEED).lt.brel) then
+         ielstc = 1
+      else
+         ielstc = 0
+      endif                  
+c          call Pihypn(ielstc,irun,iseed,dt,nt,ictrl,i1,i2,srt,
+c     &                   pcx,pcy,pcz,nchrg)
+          call Pihypn(ielstc,irun,iseed,dt,nt,ictrl,i1,i2,srt,
+     &                   pcx,pcy,pcz,nchrg,iblock)
+
+csp06/07/01 end
+        endif
+c        if(icase.eq.5) then
+c          im5=im5+1
+c          write(65,*)'---im5,s2kaon,sig=',im5,brsig,sig
+c          call pipikaon(irun,iseed,dt,nt,ictrl,i1,i2,srt,pcx,pcy,pcz)
+c        endif
+cbz3/2/99
+c        write(101,*)lb1,lb2,lb(i1),lb(i2)
+c        write(101,*)em1,em2,e(i1),e(i2),srt
+cbz3/2/99end
+
+        return
+        end
+
+******************************************
+* for pp-->pp + kaon + anti-kaon
+c      real*4 function X2kaon(srt)
+      real function X2kaon(srt)
+      SAVE   
+*  This function contains the experimental total pp->pp+K(+)K(-) Xsections    *
+*  srt    = DSQRT(s) in GeV                                                   *
+*  xsec   = production cross section in mb                                    *
+*                                                                             *
+******************************************
+c     minimum c.m.s. energy to create 2 kaon. = 2*(mp+mk)        
+        smin = 2.8639
+        x2kaon=0.0000001
+        if(srt.lt.smin)return
+        sigma1 = 2.8
+        sigma2 = 7.7
+        sigma3 = 3.9
+        x = srt**2/smin**2 + 0.0000001
+        f1 = (1.+1./sqrt(x))*alog(x) - 4.*(1.-1./sqrt(x))
+        f2 = 1. - (1./sqrt(x))*(1.+alog(sqrt(x)))
+        f3 = ((x-1.)/x**2)**3.5
+        x2kaon = (1.-1./x)**3*(sigma1*f1 + sigma2*f2) + sigma3*f3
+        return
+        END
+
+        real function piNsg0(srt)
+      SAVE   
+* cross section in mb for PI- + P -> P + K0 + K-
+c     Mn + 2* Mk
+        srt0 = 0.938 + 2.*0.498
+        if(srt.lt.srt0) then
+           piNsg0 = 0.0
+           return
+        endif
+        ratio = srt0**2/srt**2
+        piNsg0=1.121*(1.-ratio)**1.86*ratio**2
+        return
+        end
+
+        real function akNel(pkaon)
+      SAVE   
+*cross section in mb for K- + N reactions.
+c        the following data come from PRC 41 (1701)
+c        sigma1: K(-) + neutron elastic
+        if(pkaon.lt.0.5.or. pkaon.ge.4.0) sigma1=0.
+        if(pkaon.ge.0.5.and.pkaon.lt.1.0) sigma1=20.*pkaon**2.74
+        if(pkaon.ge.1.0.and.pkaon.lt.4.0) sigma1=20.*pkaon**(-1.8)
+        akNel=sigma1
+        return
+        end
+
+        real function akPel(pkaon)
+      SAVE   
+*cross section in mb for K- + N reactions.
+c        the following data come from PRC 41 (1701)
+c        sigma2: K(-) + proton elastic
+        if(pkaon.lt.0.25.or. pkaon.ge.4.0) sigma2=0.
+        if(pkaon.ge.0.25.and.pkaon.lt.4.0) sigma2=13.*pkaon**(-0.9)
+        akPel=sigma2
+        return
+        end
+
+        real function akNsgm(pkaon)
+      SAVE   
+*cross section in mb for K- + N reactions.
+c        sigma2: x section for K- + n -> sigma0 + PI-
+        if(pkaon.lt.0.5.or. pkaon.ge.6.0) sigma2=0.
+        if(pkaon.ge.0.5.and.pkaon.lt.1.0) sigma2=1.2*pkaon**(-1.3)
+        if(pkaon.ge.1.0.and.pkaon.lt.6.0) sigma2=1.2*pkaon**(-2.3)
+        akNsgm=sigma2
+        return
+        end
+
+        real function akPsgm(pkaon)
+      SAVE   
+*cross section in mb for K- + N reactions.
+c        sigma1: x section for K- + p -> sigma0 + PI0
+        if(pkaon.lt.0.2.or. pkaon.ge.1.5) sigma1=0.
+        if(pkaon.ge.0.2.and.pkaon.lt.1.5) sigma1=0.6*pkaon**(-1.8)
+        akPsgm=sigma1
+        return
+        end
+
+        real function akPlam(pkaon)
+      SAVE   
+*cross section in mb for K- + N reactions.
+c        sigma: x section for K- + p -> lambda + PI0
+        p=pkaon
+        if(pkaon.lt.0.2.or. pkaon.ge.10.0) sigma=0.
+        if(pkaon.ge.0.2.and.pkaon.lt.0.9) sigma=50.*p**2-67.*p+24.
+        if(pkaon.ge.0.9.and.pkaon.lt.10.0) sigma=3.0*pkaon**(-2.6)
+        akPlam=sigma
+        return
+        end
+
+        real function akNlam(pkaon)
+      SAVE   
+*cross section in mb for K- + N reactions.
+        akNlam=akPlam(pkaon)
+        return
+        end
+
+* GQ Li parametrization (without resonance)
+        real function akNPsg(pkaon)
+      SAVE   
+*cross section in mb for K- + N reactions.
+c       sigma1: x section for K- + p/n -> sigma0 + PI0
+         if(pkaon.le.0.345)then
+           sigma1=0.624*pkaon**(-1.83)
+         else
+           sigma1=0.7*pkaon**(-2.09)
+         endif
+        akNPsg=sigma1
+        return
+        end   
+
+c-----------------------------------------------------------------------
+
+c.....extracted from G. Song's ART expasion including K- interactions
+c.....file `NEWNNK.FOR'
+
+        subroutine nnkaon(irun,iseed,ictrl,i1,i2,iblock,
+     &                                   srt,pcx,pcy,pcz,nchrg)
+c        <pt>=0.27+0.037*log(srt) was changed to 0.632 + ... on Aug. 14, 1997
+c     CANCELED also alpha=1 changed to alpha=3 to decrease the leadng effect.
+      PARAMETER      (MAXSTR=150001,MAXR=1)
+      PARAMETER      (AKA=0.498)
+      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   /BG/BETAX,BETAY,BETAZ,GAMMA
+cc      SAVE /BG/
+      COMMON   /NN/NNN
+cc      SAVE /NN/
+      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/
+      dimension px(4),py(4),pz(4)
+      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   
+c      dm1=e(i1)
+c      dm2=e(i2)
+      dm3=0.938
+      dm4=0.938
+c     10/24/02 initialize n to 0:
+      n=0
+
+cbz3/11/99 neutralk
+c        if(nchrg.eq.-2.or.nchrg.ge.3) dm3=1.232
+c        if(nchrg.eq.4) dm4=1.232
+        if(nchrg.le.-1.or.nchrg.ge.3) dm3=1.232
+        if(nchrg.eq.-2.or.nchrg.eq.4) dm4=1.232
+cbz3/11/99 neutralk end
+          iblock = 0 
+        call fstate(iseed,srt,dm3,dm4,px,py,pz,iflag)
+        if(iflag.lt.0) then
+c           write(60,*)'------------final state fail-------',n
+c     no anti-kaon production
+           ictrl = -1
+           n=n+1
+           return
+        endif
+        iblock = 12
+* Rotate the momenta of particles in the cms of I1 & I2
+* px(1), py(1), pz(1): momentum of I1
+* px(2), py(2), pz(2): momentum of I2
+* px(3), py(3), pz(3): momentum of anti-kaon
+* px(4), py(4), pz(4): momentum of kaon
+
+
+c     10/28/02 get rid of argument usage mismatch in rotate():
+        pxrota=px(1)
+        pyrota=py(1)
+        pzrota=pz(1)
+c        call rotate(pcx,pcy,pcz,px(1),py(1),pz(1))
+        call rotate(pcx,pcy,pcz,pxrota,pyrota,pzrota)
+        px(1)=pxrota
+        py(1)=pyrota
+        pz(1)=pzrota
+c
+        pxrota=px(2)
+        pyrota=py(2)
+        pzrota=pz(2)
+c        call rotate(pcx,pcy,pcz,px(2),py(2),pz(2))
+        call rotate(pcx,pcy,pcz,pxrota,pyrota,pzrota)
+        px(2)=pxrota
+        py(2)=pyrota
+        pz(2)=pzrota
+c
+        pxrota=px(3)
+        pyrota=py(3)
+        pzrota=pz(3)
+c        call rotate(pcx,pcy,pcz,px(3),py(3),pz(3))
+        call rotate(pcx,pcy,pcz,pxrota,pyrota,pzrota)
+        px(3)=pxrota
+        py(3)=pyrota
+        pz(3)=pzrota
+c
+        pxrota=px(4)
+        pyrota=py(4)
+        pzrota=pz(4)
+c        call rotate(pcx,pcy,pcz,px(4),py(4),pz(4))
+        call rotate(pcx,pcy,pcz,pxrota,pyrota,pzrota)
+        px(4)=pxrota
+        py(4)=pyrota
+        pz(4)=pzrota
+
+        nnn=nnn+2
+c     K+
+        lpion(nnn,irun)=23
+        if(nchrg.eq.-1.or.nchrg.eq.-2) then
+c        To keep charge conservation. D-n->nnK0K-, D-D- -> nD-K0K-
+
+cbz3/7/99 neutralk
+c           lpion(nnn,irun)=24 ! K0
+cbz3/7/99 neutralk end
+
+        endif
+c     aka: rest mass of K
+        epion(nnn,irun)=aka
+c     K-
+        lpion(nnn-1,irun)=21
+c     aka: rest mass of K
+        epion(nnn-1,irun)=aka
+* Find the momenta of particles in the final state in the nucleus_nucleus
+* cms frame.   Lorentz transformation into lab frame.
+        e1cm   = sqrt(dm3**2 + px(1)**2 + py(1)**2 + pz(1)**2)
+        p1beta = px(1)*betax + py(1)*betay + pz(1)*betaz
+        transf = gamma * ( gamma*p1beta / (gamma+1) + e1cm)
+        pt1i1 = betax*transf + px(1)
+        pt2i1 = betay*transf + py(1)
+        pt3i1 = betaz*transf + pz(1)
+        eti1  = dm3
+c        lb1   = lb(i1)
+        lb1   = 2
+        if(nchrg.ge.-2.and.nchrg.le.1) lb1=2
+
+cbz3/7/99 neutralk
+        if (nchrg .eq. -2 .or. nchrg .eq. -1) then
+           lb1 = 6
+        end if
+cbz3/7/99 neutralk end
+
+cbz3/11/99 neutralk
+c        if(nchrg.eq.2.or.nchrg.eq.3) lb1=1
+c        if(nchrg.eq.4) lb1=9
+        if(nchrg.eq.1.or.nchrg.eq.2) lb1=1
+        if(nchrg.eq.3.or.nchrg.eq.4) lb1=9
+cbz3/11/99 neutralk end
+
+* For second nulceon, same
+        e2cm   = sqrt(dm4**2 + px(2)**2 + py(2)**2 + pz(2)**2)
+        p2beta = px(2)*betax + py(2)*betay + pz(2)*betaz
+        transf = gamma * ( gamma*p2beta / (gamma+1) + e2cm)
+        pt1i2 = betax*transf + px(2)
+        pt2i2 = betay*transf + py(2)
+        pt3i2 = betaz*transf + pz(2)
+        eti2  = dm4
+c        lb2   = lb(i2)
+        lb2   = 2
+
+cbz3/11/99 neutralk
+c        if(nchrg.eq.-1.or.nchrg.eq.0) lb2=2
+c        if(nchrg.eq. 2.or.nchrg.eq.1) lb2=1
+c        if(nchrg.eq. 4.or.nchrg.eq.3) lb2=9
+c        if(nchrg.eq.-2) lb2=6
+        if(nchrg.ge.-1.or.nchrg.le.1) lb2=2
+        if(nchrg.eq. 2.or.nchrg.eq.3) lb2=1
+        if(nchrg.eq. 4) lb2=9
+        if(nchrg.eq.-2) lb2=6
+cbz3/11/99 neutralk end
+
+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
+
+c                px1 = p(1,i1)
+c                py1 = p(2,i1)
+c                pz1 = p(3,i1)
+c                em1 = e(i1)
+c                id(i1) = 2
+c                id(i2) = 2
+c                id1 = id(i1)
+c                iblock = 101  ! K(+)K(-) production
+* Get anti-kaons' momenta and coordinates in nucleus-nucleus cms. frame.
+        epcmk = sqrt(epion(nnn-1,irun)**2 + px(3)**2+py(3)**2+pz(3)**2)
+        betak = px(3)*betax + py(3)*betay + pz(3)*betaz
+        transf= gamma*(gamma*betak/(gamma+1.) + epcmk)
+        ppion(1,nnn-1,irun)=betax*transf + px(3)
+        ppion(2,nnn-1,irun)=betay*transf + py(3)
+        ppion(3,nnn-1,irun)=betaz*transf + pz(3)
+        rpion(1,nnn-1,irun)=r(1,i1)
+        rpion(2,nnn-1,irun)=r(2,i1)
+        rpion(3,nnn-1,irun)=r(3,i1)
+clin-5/2008:
+        dppion(nnn-1,irun)=dpertp(i1)*dpertp(i2)
+* Same thing for kaon **************************************
+        epcmak = sqrt(epion(nnn,irun)**2 + px(4)**2 +py(4)**2+pz(4)**2)
+        betaak = px(4)*betax + py(4)*betay + pz(4)*betaz
+        transf= gamma*(gamma*betaak/(gamma+1.) + epcmak)
+        ppion(1,nnn,irun)=betax*transf + px(4)
+        ppion(2,nnn,irun)=betay*transf + py(4)
+        ppion(3,nnn,irun)=betaz*transf + pz(4)
+        rpion(1,nnn,irun)=r(1,i2)
+        rpion(2,nnn,irun)=r(2,i2)
+        rpion(3,nnn,irun)=r(3,i2)
+clin-5/2008:
+        dppion(nnn,irun)=dpertp(i1)*dpertp(i2)
+        return
+        end
+
+        subroutine lorntz(ilo,b,pi,pj)
+c       It uses to perform Lorentz (or inverse Lorentz) transformation
+        dimension pi(4),pj(4),b(3)
+      SAVE   
+c       dimension db(3)
+        bb=b(1)*b(1)+b(2)*b(2)+b(3)*b(3)
+        deno3=sqrt(1.-bb)
+        if(deno3.eq.0.)deno3=1.e-10
+        gam=1./deno3
+        ga=gam*gam/(gam+1.)
+        if(ilo.eq.1) goto 100
+c       Lorentz transformation
+        pib=pi(1)*b(1)+pi(2)*b(2)+pi(3)*b(3)
+        pjb=pj(1)*b(1)+pj(2)*b(2)+pj(3)*b(3)
+c       drb=drd(1)*b(1)+drd(2)*b(2)+drd(3)*b(3)
+c       drdb=db(1)*b(1)+db(2)*b(2)+db(3)*b(3)
+        do 1001 i=1,3
+           pi(i)=pi(i)+b(i)*(ga*pib-gam*pi(4))
+           pj(i)=pj(i)+b(i)*(ga*pjb-gam*pj(4))
+c       drd(i)=drd(i)+b(i)*ga*drb
+c       db(i)=db(i)+b(i)*ga*drdb
+ 1001   continue
+        pi(4)=gam*(pi(4)-pib)
+        pj(4)=gam*(pj(4)-pjb)
+        return
+100     continue
+c       inverse Lorentz transformation
+        pib=pi(1)*b(1)+pi(2)*b(2)+pi(3)*b(3)
+        pjb=pj(1)*b(1)+pj(2)*b(2)+pj(3)*b(3)
+        do 1002 i=1,3
+           pi(i)=pi(i)+b(i)*(ga*pib+gam*pi(4))
+           pj(i)=pj(i)+b(i)*(ga*pjb+gam*pj(4))
+ 1002   continue
+        pi(4)=gam*(pi(4)+pib)
+        pj(4)=gam*(pj(4)+pjb)
+        return
+        end
+        
+        subroutine fstate(iseed,srt,dm3,dm4,px,py,pz,iflag)
+*        function: decide final momentum for N,N,K(+),and K(-)        
+        dimension px(4), py(4), pz(4), pe(4)
+        COMMON/RNDF77/NSEED
+cc      SAVE /RNDF77/
+        SAVE   
+
+        iseed=iseed
+        iflag=-1
+c        iflag=-1: fail to find momenta
+c             = 1: success
+        pio=3.1415926
+        aka=0.498
+c        v=0.43
+c        w=-0.84
+c        b=3.78
+c        c=0.47
+c        d=3.60
+c        fmax=1.056
+c        gmax=1.+c
+
+        icount=0
+        ekmax=(srt-dm3-dm4)/2.
+        if(ekmax.le.aka) return
+        pkmax=sqrt(ekmax**2-aka**2)
+
+        if(dm3.le.0.0.or.dm4.le.0.0) then
+           write(1,*)'error: minus mass!!!'
+           return
+        endif
+
+c        after we have the momenta for both nucleus, we sample the
+c        transverse momentum for K-. 
+c        dsigma/dpt**2 = exp(-4.145*pt**2) obtained by fitting data on
+c        page 72, fig 23i.
+50        continue
+        icount=icount+1
+        if(icount.gt.10) return
+        ptkmi2=-1./4.145*alog(RANART(NSEED))
+        ptkm=sqrt(ptkmi2)
+3        v1=RANART(NSEED)
+        v2=RANART(NSEED)
+        rsq=v1**2+v2**2
+        if(rsq.ge.1.0.or.rsq.le.0.) goto 3
+        fac=sqrt(-2.*alog(rsq)/rsq)
+        guass=v1*fac
+        if(guass.ge.5.) goto 3
+        xstar=guass/5.
+        pzkm=pkmax*xstar
+        ekm=sqrt(aka**2+pzkm**2+ptkm**2)
+        if(RANART(NSEED).gt.aka/ekm) goto 50
+        bbb=RANART(NSEED)
+        px(3)=ptkm*cos(2.*pio*bbb)
+        py(3)=ptkm*sin(2.*pio*bbb)
+        if(RANART(NSEED).gt.0.5) pzkm=-1.*pzkm
+        pz(3)=pzkm
+        pe(3)=ekm
+150        ptkpl2=-1./3.68*alog(RANART(NSEED))
+        ptkp=sqrt(ptkpl2)
+13        v1=RANART(NSEED)
+        v2=RANART(NSEED)
+        rsq=v1**2+v2**2
+        if(rsq.ge.1.0.or.rsq.le.0.) goto 13
+        fac=sqrt(-2.*alog(rsq)/rsq)
+        guass=v1*fac
+        if(guass.ge.3.25) goto 13
+        xstar=guass/3.25
+        pzkp=pkmax*xstar
+        ekp=sqrt(aka**2+pzkp**2+ptkp**2)
+        if(RANART(NSEED).gt.aka/ekp) goto 150
+        bbb=RANART(NSEED)
+        px(4)=ptkp*cos(2.*pio*bbb)
+        py(4)=ptkp*sin(2.*pio*bbb)
+        if(RANART(NSEED).gt.0.5) pzkp=-1.*pzkp
+        pz(4)=pzkp
+        pe(4)=ekp
+
+        resten=srt-pe(3)-pe(4)
+        restpz=-pz(3)-pz(4)
+c     resample
+        if(resten.le.abs(restpz)) goto 50
+        restms=sqrt(resten**2-restpz**2)
+c     resample 
+        if(restms.lt.(dm3+dm4)) goto 50
+        ptp2=-1./2.76*alog(RANART(NSEED))
+        ptp=sqrt(ptp2)
+        bbb=RANART(NSEED)
+        px(2)=ptp*cos(2.*pio*bbb)
+        py(2)=ptp*sin(2.*pio*bbb)
+        px(1)=-1.*(px(4)+px(3)+px(2))
+        py(1)=-1.*(py(4)+py(3)+py(2))
+c     transverse mass for K-
+        rmt3=sqrt(dm3**2+px(1)**2+py(1)**2)
+c     transverse mass for K+
+        rmt4=sqrt(dm4**2+px(2)**2+py(2)**2)
+        if(restms.lt.(rmt3+rmt4)) goto 50
+c        else: sampling success!
+        pzcms=sqrt((restms**2-(rmt3+rmt4)**2)*
+     &             (restms**2-(rmt3-rmt4)**2))/2./restms
+        if(RANART(NSEED).gt.0.5) then
+           pz(1)=pzcms
+           pz(2)=-pzcms
+        else
+           pz(1)=-pzcms
+           pz(2)=pzcms
+        endif
+        beta=restpz/resten        
+        gama=1./sqrt(1.-beta**2)
+        pz(1)=pz(1)*gama + beta*gama*sqrt(rmt3**2+pz(1)**2)
+        pz(2)=pz(2)*gama + beta*gama*sqrt(rmt4**2+pz(2)**2)
+        pe(1)=sqrt(rmt3**2+pz(1)**2)
+        pe(2)=sqrt(rmt4**2+pz(2)**2)
+
+        iflag=1
+        return
+        end
+
+c-----------------------------------------------------------------------
+
+c.....extracted from G. Song's ART expasion including K- interactions
+c.....file `NPIK.FOR'
+
+****************************************
+c        subroutine npik(irun,iseed,dt,nt,ictrl,i1,i2,srt,
+c     &                  pcx,pcy,pcz,nchrg,ratiok)
+        subroutine npik(irun,iseed,dt,nt,ictrl,i1,i2,srt,
+     &                  pcx,pcy,pcz,nchrg,ratiok,iblock)
+*
+* Process: PI + N -> K(-) + ANYTHING
+* 1.  PI- + P -> P + K0 + K-
+* 2.  PI+ + N -> P + K+ + K- 
+* 3.  PI0 + P -> P + K+ + K-
+* 4.  PI0 + N -> P + K0 + K-
+* 5.  PI0 + N -> N + K+ + K-
+* 6.  PI- + P -> N + K+ + K-
+* 7.  PI- + N -> N + K0 + K-
+* NOTE: the mass of K is assumed to be same as K0. ie. 0.498 NOT 0.494
+****************************************
+      PARAMETER      (MAXSTR=150001,MAXR=1,PI=3.1415926)
+      PARAMETER      (AKA=0.498)
+      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   /BG/BETAX,BETAY,BETAZ,GAMMA
+cc      SAVE /BG/
+      COMMON   /NN/NNN
+cc      SAVE /NN/
+      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/
+      dimension bb(3),p1(4),p2(4),p3(4),px(4),py(4),pz(4)
+      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   
+        iseed=iseed
+        dt=dt
+        nchrg=nchrg
+        nt=nt
+        ratiok=ratiok
+        px(1)=px(1)
+        py(1)=py(1)
+        pz(1)=pz(1)
+        px1cm=pcx
+        py1cm=pcy
+        pz1cm=pcz
+        ictrl = 1
+        lb1=lb(i1)
+        lb2=lb(i2)
+        k1=i1
+        k2=i2
+c        k1 must be bayron. k2 be meson. If not, exchange.
+        if(lb2.eq.1.or.lb2.eq.2.or.(lb2.ge.6.and.lb2.le.13)) then
+            k1=i2
+            k2=i1
+        endif
+cbz3/8/99 neutralk
+cbz10/12/99
+c        LB(I1) = 1 + 2 * RANART(NSEED)
+c        LB(I2) = 23
+        LB(k1) = 1 + int(2*RANART(NSEED))
+        LB(k2) = 23
+c       pkmax=sqrt((srt**2-(aka+0.938+aka)**2)*(srt**2-(aka+0.938-aka)**2))
+c     &           /2./srt
+        pkmax=sqrt((srt**2-(aka+0.938+aka)**2)
+     &           *(srt**2-(aka+0.938-aka)**2))/2./srt
+        pk = RANART(NSEED)*pkmax
+c-----------------------------------------------------
+        css=1.-2.*RANART(NSEED)
+        sss=sqrt(1.-css**2)
+        fai=2*3.1415926*RANART(NSEED)
+        p3(1)=pk*sss*cos(fai)
+        p3(2)=pk*sss*sin(fai)
+        p3(3)=pk*css
+        eip = srt - sqrt(aka**2 + pk**2)
+        rmnp=sqrt(eip**2-pk**2)
+        do 1001 i= 1, 3
+           bb(i) = -1.*p3(i)/eip
+ 1001   continue
+c        bb: velocity of the other two particles as a whole.
+        pznp=sqrt((rmnp**2-(aka+0.938)**2)
+     c  *(rmnp**2-(0.938-aka)**2))/2./rmnp    
+c-----------------------------------------------------
+        css=1.-2.*RANART(NSEED)
+        sss=sqrt(1.-css**2)
+        fai=2*3.1415926*RANART(NSEED)
+        p1(1)=pznp*sss*cos(fai)
+        p1(2)=pznp*sss*sin(fai)
+        p1(3)=pznp*css
+        p1(4)=sqrt(0.938**2+pznp**2)
+        p2(4)=sqrt(aka**2+pznp**2)
+        do 1002 i=1,3
+           p2(i)=-1.*p1(i)
+ 1002   continue
+c        p1,p2: the momenta of the two particles in their cms
+c        p1: momentum of N or P
+c        p2: momentum of anti_kaon
+c        p3: momentum of K0 or K+
+        ilo=1
+c        write(61,*)'--------p1,p2',p1,p2
+c        write(61,*)'--------bb',bb
+        call lorntz(ilo,bb,p1,p2)
+c******* Checking *************
+c        pxsum = p1(1)+p2(1)+p3(1)
+c        pysum = p1(2)+p2(2)+p3(2)
+c        pzsum = p1(3)+p2(3)+p3(3)
+c        pesum = p1(4)+p2(4)+sqrt(p3(1)**2+p3(2)**2+p3(3)**2+aka**2)-srt
+c        write(61,*)'---p1,pxsum',p1,pxsum
+c        write(61,*)'---p2,pysum',p2,pysum
+c        write(61,*)'---p3,pzsum',p3,pzsum
+c        write(61,*)'---pesum',pesum
+c***********************************
+
+* Rotate the momenta of particles in the cms of I1 & I2
+* px(1), py(1), pz(1): momentum of I1
+* px(2), py(2), pz(2): momentum of I2
+* px(3), py(3), pz(3): momentum of anti-kaon
+
+c     10/28/02 get rid of argument usage mismatch in rotate():
+        pxrota=p1(1)
+        pyrota=p1(2)
+        pzrota=p1(3)
+c        call rotate(pcx,pcy,pcz,p1(1),p1(2),p1(3))
+        call rotate(pcx,pcy,pcz,pxrota,pyrota,pzrota)
+        p1(1)=pxrota
+        p1(2)=pyrota
+        p1(3)=pzrota
+c
+        pxrota=p2(1)
+        pyrota=p2(2)
+        pzrota=p2(3)
+c        call rotate(pcx,pcy,pcz,p2(1),p2(2),p2(3))
+        call rotate(pcx,pcy,pcz,pxrota,pyrota,pzrota)
+        p2(1)=pxrota
+        p2(2)=pyrota
+        p2(3)=pzrota
+c
+        pxrota=p3(1)
+        pyrota=p3(2)
+        pzrota=p3(3)
+c        call rotate(pcx,pcy,pcz,p3(1),p3(2),p3(3))
+        call rotate(pcx,pcy,pcz,pxrota,pyrota,pzrota)
+        p3(1)=pxrota
+        p3(2)=pyrota
+        p3(3)=pzrota
+
+        nnn=nnn+1
+c     K(-)
+        lpion(nnn,irun)=21
+c     aka: rest mass of K
+        epion(nnn,irun)=aka
+* Find the momenta of particles in the final state in the nucleus_nucleus
+* cms frame.   Lorentz transformation into lab frame.
+        e1cm   = sqrt(0.938**2 + p1(1)**2 + p1(2)**2 + p1(3)**2)
+        p1beta = p1(1)*betax + p1(2)*betay + p1(3)*betaz
+        transf = gamma * ( gamma*p1beta / (gamma+1) + e1cm)
+        pt1i1 = betax*transf + p1(1)
+        pt2i1 = betay*transf + p1(2)
+        pt3i1 = betaz*transf + p1(3)
+        eti1  = 0.938
+        lb1   = lb(k1)
+         
+* For second nulceon, same
+        e2cm   = sqrt(aka**2 + p3(1)**2 + p3(2)**2 + p3(3)**2)
+        p2beta = p3(1)*betax + p3(2)*betay + p3(3)*betaz
+        transf = gamma * ( gamma*p2beta / (gamma+1) + e2cm)
+        pt1i2 = betax*transf + p3(1)
+        pt2i2 = betay*transf + p3(2)
+        pt3i2 = betaz*transf + p3(3)
+        eti2  = aka
+        lb2   = lb(k2)
+
+c        if((pt1i1*px1+pt2i1*py1+pt3i1*pz1).gt.0.)then
+*       k1 stand for nucleon, k2 stand for kaon. lpion stand for Kbar.
+                p(1,k1)=pt1i1
+                p(2,k1)=pt2i1
+                p(3,k1)=pt3i1
+                e(k1)=eti1
+                lb(k1)=lb1
+                p(1,k2)=pt1i2
+                p(2,k2)=pt2i2
+                p(3,k2)=pt3i2
+                e(k2)=eti2
+                lb(k2)=lb2
+
+c                px1 = p(1,i1)
+c                py1 = p(2,i1)
+c                pz1 = p(3,i1)
+c                em1 = e(i1)
+c                id(i1) = 2
+c                id(i2) = 2
+c                id1 = id(i1)
+c     K(+)K(-) production
+                iblock = 101
+* Get Kaons' momenta and coordinates in nucleus-nucleus cms. frame.
+c  p2:  momentum of anti-kaon.
+c        epcmk = sqrt(epion(nnn,irun)**2 + p2(1)**2 + p2(2)**2 + p2(3)**2)
+        epcmk = sqrt(epion(nnn,irun)**2 + p2(1)**2+p2(2)**2+p2(3)**2)
+        betak = p2(1)*betax + p2(2)*betay + p2(3)*betaz
+        transf= gamma*(gamma*betak/(gamma+1.) + epcmk)
+        ppion(1,nnn,irun)=betax*transf + p2(1)
+        ppion(2,nnn,irun)=betay*transf + p2(2)
+        ppion(3,nnn,irun)=betaz*transf + p2(3)
+clin-5/2008:
+        dppion(nnn,irun)=dpertp(i1)*dpertp(i2)
+cbz3/2/99
+c        write(400,*)'2 ', ppion(1,nnn,irun), ppion(2,nnn,irun),
+c     &                    ppion(3,nnn,irun), dt*nt, srt
+cbz3/2/99end
+c        write(420,*)ppion(1,nnn,irun), ppion(2,nnn,irun),
+c     &                    ppion(3,nnn,irun), dt*nt, srt
+        k=i2
+        if(lb(i1).eq.1.or.lb(i1).eq.2) k=i1
+        rpion(1,nnn,irun)=r(1,k)
+        rpion(2,nnn,irun)=r(2,k)
+        rpion(3,nnn,irun)=r(3,k)
+        return
+        end
+
+c-----------------------------------------------------------------------
+
+c.....extracted from G. Song's ART expasion including K- interactions
+c.....file `PIHYPN.FOR'
+
+******************************************
+        subroutine pihypn(ielstc,irun,iseed,dt,nt,ictrl,i1,i2,
+     &     srt,pcx,pcy,pcz,nchrg,iblock)
+*
+* Process: PI + sigma(or Lambda) -> Kbar + N
+* NOTE: the mass of K is assumed to be same as K0. ie. 0.498 NOT 0.494
+******************************************
+
+c NOTE: for PI + Hyperon: the produced kaons have mass 0.498
+      PARAMETER      (MAXSTR=150001,MAXR=1,PI=3.1415926)
+      PARAMETER      (AKA=0.498)
+      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   /BG/BETAX,BETAY,BETAZ,GAMMA
+cc      SAVE /BG/
+      COMMON   /NN/NNN
+cc      SAVE /NN/
+      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/
+      dimension p1(4),p2(4)
+      COMMON/RNDF77/NSEED
+cc      SAVE /RNDF77/
+      SAVE   
+        irun=irun
+        iseed=iseed
+        nt=nt
+        dt=dt
+        px1cm=pcx
+        py1cm=pcy
+        pz1cm=pcz
+        ictrl = 1
+csp06/07/01
+        if(ielstc .eq. 1) then
+*    L/Si + meson -> L/Si + meson
+             k1=i1
+             k2=i2
+           dm3=e(k1)
+           dm4=e(k2)
+           iblock = 10
+        else
+           iblock = 12
+csp06/07/01 end  
+c        PI + Sigma(or Lambda) -> Kbar + N
+        k1=i1
+        k2=i2
+c        k1 must be bayron! So if I1 is PI, exchange k1 & k2.
+        if(lb(i1).lt.14.or.lb(i1).gt.17) then
+           k1=i2
+           k2=i1
+        endif
+cbz3/8/99 neutralk
+        LB(K1) = 1 + int(2*RANART(NSEED))
+        if(nchrg.eq.-2) lb(k1)=6
+c     if(nchrg.eq.-1) lb(k1)=2
+c     if(nchrg.eq. 0) lb(k1)=1
+c     if(nchrg.eq. 1) lb(k1)=9
+        IF (NCHRG .EQ. 2) LB(K1) = 9
+cbz3/8/99 neutralk end
+
+c     K-
+        lb(k2)=21
+        dm3=0.938
+        if(nchrg.eq.-2.or.nchrg.eq.1) dm3=1.232
+        dm4=aka
+c        dm3,dm4: the mass of final state particles.
+         endif
+    
+********Now, antikaon will be created.
+c        call antikaon_fstate(iseed,srt,dm1,dm2,dm3,dm4,px,py,pz,icou1)
+c        pkmax: the maximum momentum of anti-kaon
+        pkmax=sqrt((srt**2-(dm3+dm4)**2)*(srt**2-(dm3-dm4)**2))
+     &         /2./srt
+        pk=pkmax
+c-----------------------------------------------------
+        css=1.-2.*RANART(NSEED)
+        sss=sqrt(1.-css**2)
+        fai=2*3.1415926*RANART(NSEED)
+        p1(1)=pk*sss*cos(fai)
+        p1(2)=pk*sss*sin(fai)
+        p1(3)=pk*css
+        do 1001 i=1,3
+           p2(i)=-1.*p1(i)
+ 1001   continue
+c        p1,p2: the momenta of the two particles in their cms
+c        p1: momentum of kaon
+c        p2: momentum of Kbar
+
+* Rotate the momenta of particles in the cms of I1 & I2
+clin-10/28/02 get rid of argument usage mismatch in rotate():
+        pxrota=p1(1)
+        pyrota=p1(2)
+        pzrota=p1(3)
+c        call rotate(pcx,pcy,pcz,p1(1),p1(2),p1(3))
+        call rotate(pcx,pcy,pcz,pxrota,pyrota,pzrota)
+        p1(1)=pxrota
+        p1(2)=pyrota
+        p1(3)=pzrota
+c
+        pxrota=p2(1)
+        pyrota=p2(2)
+        pzrota=p2(3)
+c        call rotate(pcx,pcy,pcz,p2(1),p2(2),p2(3))
+        call rotate(pcx,pcy,pcz,pxrota,pyrota,pzrota)
+        p2(1)=pxrota
+        p2(2)=pyrota
+        p2(3)=pzrota
+clin-10/28/02-end
+
+* Find the momenta of particles in the final state in the nucleus_nucleus
+* cms frame.   Lorentz transformation into lab frame.
+        e1cm   = sqrt(dm3**2 + p1(1)**2 + p1(2)**2 + p1(3)**2)
+        p1beta = p1(1)*betax + p1(2)*betay + p1(3)*betaz
+        transf = gamma * ( gamma*p1beta / (gamma+1) + e1cm)
+        pt1i1 = betax*transf + p1(1)
+        pt2i1 = betay*transf + p1(2)
+        pt3i1 = betaz*transf + p1(3)
+        eti1  = dm3
+        lb1   = lb(k1)
+         
+* For second kaon, same
+        e2cm   = sqrt(dm4**2 + p2(1)**2 + p2(2)**2 + p2(3)**2)
+        p2beta = p2(1)*betax + p2(2)*betay + p2(3)*betaz
+        transf = gamma * ( gamma*p2beta / (gamma+1) + e2cm)
+        pt1i2 = betax*transf + p2(1)
+        pt2i2 = betay*transf + p2(2)
+        pt3i2 = betaz*transf + p2(3)
+cbz3/2/99
+c        write(400,*)'3 ', pt1i2, pt2i2, pt3i2, dt*nt, srt
+cbz3/2/99end
+c        write(430,*)pt1i2, pt2i2, pt3i2, dt*nt, srt
+        eti2  = dm4
+        lb2   = lb(k2)
+
+c        if((pt1i1*px1+pt2i1*py1+pt3i1*pz1).gt.0.)then
+c        k1=i1
+c        k2=i2
+*       k1 stand for nucleon, k2 stand for kaon.
+                p(1,k1)=pt1i1
+                p(2,k1)=pt2i1
+                p(3,k1)=pt3i1
+                e(k1)=eti1
+                lb(k1)=lb1
+                p(1,k2)=pt1i2
+                p(2,k2)=pt2i2
+                p(3,k2)=pt3i2
+                e(k2)=eti2
+                lb(k2)=lb2
+
+cc                iblock = 101  ! K(+)K(-) production
+* Get Kaons' momenta and coordinates in nucleus-nucleus cms. frame.
+        return
+        end
+
+c-----------------------------------------------------------------------
+
+c.....extracted from G. Song's ART expasion including K- interactions
+c.....file `KAONN.FOR'
+
+****************************************
+        subroutine kaonN(brel,brsgm,irun,iseed,dt,nt,
+     &     ictrl,i1,i2,iblock,srt,pcx,pcy,pcz,nchrg)
+*
+* Process: PI + sigma(or Lambda) <- Kbar + N
+* NOTE: the mass of K is assumed to be same as K0. ie. 0.498 NOT 0.494
+****************************************
+      PARAMETER      (MAXSTR=150001,MAXR=1,PI=3.1415926)
+      PARAMETER      (AKA=0.498,ALA=1.1157,ASA=1.1974)
+      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   /BG/BETAX,BETAY,BETAZ,GAMMA
+cc      SAVE /BG/
+      COMMON   /NN/NNN
+cc      SAVE /NN/
+      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/
+      dimension p1(4),p2(4)
+      COMMON/RNDF77/NSEED
+cc      SAVE /RNDF77/
+      SAVE   
+        dt=dt
+        irun=irun
+        iseed=iseed
+        nchrg=nchrg
+        nt=nt
+        px1cm=pcx
+        py1cm=pcy
+        pz1cm=pcz
+        ictrl = 1
+c        ratio: used for isospin decision.
+        k1=i1
+        k2=i2
+c        k1 must be bayron! So if I1 is Kaon, exchange k1 & k2.
+        if(e(i1).lt.0.5.and.e(i1).gt.0.01) then
+           k1=i2
+           k2=i1
+        endif
+*** note: for print out only *******************************
+c     record kaon's mass
+        eee=e(k2)
+*** end **************
+        rrr=RANART(NSEED)
+        if(rrr.lt.brel) then
+c       Kbar + N -> Kbar + N
+           lb1=lb(k1)
+           lb2=lb(k2)
+           em1=e(k1)
+           em2=e(k2)
+           iblock = 10
+        else 
+           iblock = 12
+        if(rrr.lt.(brel+brsgm)) then
+c        nchrg: Net charges of the two incoming particles.
+c           Kbar + N -> Sigma + PI
+           em1=asa
+           em2=0.138
+
+cbz3/8/99 neutralk
+           LB1 = 15 + int(3*RANART(NSEED))
+           LB2 = 3 + int(3*RANART(NSEED))
+        else
+c           Kbar + N -> Lambda + PI
+           em1=ala
+           em2=0.138
+c     LAmbda
+           lb1=14
+cbz3/8/99 neutralk
+           LB2 = 3 + int(3*RANART(NSEED))
+c           if(nchrg.eq.1)  lb2=5  ! K- + D++ -> Lambda + PI+
+c           if(nchrg.eq.0)  lb2=4  ! K- + p(D+,N*+) -> Lambda + PI0
+c          if(nchrg.eq.-1) lb2=3 ! K- + n(D,N*) -> Lambda + PI-
+cbz3/8/99 neutralk
+
+        endif
+        endif
+        lb(k1)=lb1
+        lb(k2)=lb2
+    
+********Now, antikaon will be created.
+c        call antikaon_fstate(iseed,srt,dm1,dm2,dm3,dm4,px,py,pz,icou1)
+c        pkmax: the maximum momentum of anti-kaon
+c        write(63,*)'srt,em1,em2',srt,em1,em2
+c        write(63,*)'-srt,em1,em2',srt,em1,em2
+        pkmax=sqrt((srt**2-(em1+em2)**2)*(srt**2-(em1-em2)**2))
+     &         /2./srt
+        pk=pkmax
+c-----------------------------------------------------
+        css=1.-2.*RANART(NSEED)
+        sss=sqrt(1.-css**2)
+        fai=2*3.1415926*RANART(NSEED)
+        p1(1)=pk*sss*cos(fai)
+        p1(2)=pk*sss*sin(fai)
+        p1(3)=pk*css
+        do 1001 i=1,3
+           p2(i)=-1.*p1(i)
+ 1001   continue
+c        p1,p2: the momenta of the two particles in their cms
+c        p1: momentum of kaon
+c        p2: momentum of Kbar
+
+* Rotate the momenta of particles in the cms of I1 & I2
+
+clin-10/28/02 get rid of argument usage mismatch in rotate():
+        pxrota=p1(1)
+        pyrota=p1(2)
+        pzrota=p1(3)
+c        call rotate(pcx,pcy,pcz,p1(1),p1(2),p1(3))
+        call rotate(pcx,pcy,pcz,pxrota,pyrota,pzrota)
+        p1(1)=pxrota
+        p1(2)=pyrota
+        p1(3)=pzrota
+c
+        pxrota=p2(1)
+        pyrota=p2(2)
+        pzrota=p2(3)
+c        call rotate(pcx,pcy,pcz,p2(1),p2(2),p2(3))
+        call rotate(pcx,pcy,pcz,pxrota,pyrota,pzrota)
+        p2(1)=pxrota
+        p2(2)=pyrota
+        p2(3)=pzrota
+clin-10/28/02-end
+
+* Find the momenta of particles in the final state in the nucleus_nucleus
+* cms frame.   Lorentz transformation into lab frame.
+        e1cm   = sqrt(em1**2 + p1(1)**2 + p1(2)**2 + p1(3)**2)
+        p1beta = p1(1)*betax + p1(2)*betay + p1(3)*betaz
+        transf = gamma * ( gamma*p1beta / (gamma+1) + e1cm)
+        pt1i1 = betax*transf + p1(1)
+        pt2i1 = betay*transf + p1(2)
+        pt3i1 = betaz*transf + p1(3)
+        eti1  = em1
+         
+* For second kaon, same
+        e2cm   = sqrt(em2**2 + p2(1)**2 + p2(2)**2 + p2(3)**2)
+        p2beta = p2(1)*betax + p2(2)*betay + p2(3)*betaz
+        transf = gamma * ( gamma*p2beta / (gamma+1) + e2cm)
+        pt1i2 = betax*transf + p2(1)
+        pt2i2 = betay*transf + p2(2)
+        pt3i2 = betaz*transf + p2(3)
+        eti2  = em2
+
+c        if((pt1i1*px1+pt2i1*py1+pt3i1*pz1).gt.0.)then
+c        k1=i1
+c        k2=i2
+*       k1 stand for bayron, k2 stand for meson.
+                p(1,k1)=pt1i1
+                p(2,k1)=pt2i1
+                p(3,k1)=pt3i1
+                e(k1)=eti1
+                p(1,k2)=pt1i2
+                p(2,k2)=pt2i2
+                p(3,k2)=pt3i2
+                e(k2)=eti2
+
+cc                iblock = 101  ! K(+)K(-) production
+* Get Kaons' momenta and coordinates in nucleus-nucleus cms. frame.
+        return
+        end
+
+c=======================================================================
+
+clin Below is the previous artana.f:
+c=======================================================================
+
+c.....analysis subroutine before the hadronic space-time evolution
+
+      SUBROUTINE ARTAN1
+      PARAMETER (MAXSTR=150001, MAXR=1)
+c.....y cut for mt spectrum
+cbz3/17/99
+c      PARAMETER (YMT1 = -0.4, YMT2 = 0.4)
+      PARAMETER (YMT1 = -1.0, YMT2 = 1.0)
+cbz3/17/99 end
+c.....bin width for mt spectrum and y spectrum
+clin-9/26/03 no symmetrization in y (or eta) for ana/*.dat:
+c      PARAMETER (BMT = 0.05, BY = 0.2)
+      PARAMETER (BMT = 0.05, BY = 0.4)
+      COMMON /RUN/ NUM
+cc      SAVE /RUN/
+      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)
+cbz3/17/99
+c     &     dm1k0s(50), DMT1LA(50), DMT1LB(50)
+cc      SAVE /ARPRC1/
+      COMMON /ARANA1/
+     &     dy1ntb(50), dy1ntp(50), DY1HM(50), 
+     &     DY1KP(50), DY1KM(50), DY1K0S(50),
+     &     DY1LA(50), DY1LB(50), DY1PHI(50),
+     &     dm1pip(50), dm1pim(50), DMT1PR(50),
+     &     DMT1PB(50), DMT1KP(50), dm1km(50),
+     &     dm1k0s(50), DMT1LA(50), DMT1LB(50),
+     &     dy1msn(50), DY1PIP(50), DY1PIM(50), 
+     &     DY1PI0(50), DY1PR(50), DY1PB(50)
+     &     ,DY1NEG(50), DY1CH(50), DE1NEG(50), DE1CH(50)
+cc      SAVE /ARANA1/
+      SAVE   
+
+cbz3/17/99 end
+      DO 1002 J = 1, NUM
+         DO 1001 I = 1, MULTI1(J)
+            ITYP = ITYP1(I, J)
+            PX = PX1(I, J)
+            PY = PY1(I, J)
+            PZ = PZ1(I, J)
+            EE = EE1(I, J)
+            XM = XM1(I, J)
+c     2/24/03 leptons and photons:
+            if(xm.lt.0.01) goto 200
+            ptot = sqrt(PX ** 2 + PY ** 2 + pz ** 2)
+            eta = 0.5*alog((Ptot+pz+1e-5)/(ptot-pz+1e-5))
+
+            XMT = SQRT(PX ** 2 + PY ** 2 + XM ** 2)
+            IF (ABS(PZ) .GE. EE) THEN
+               PRINT *, 'IN ARTAN1'
+               PRINT *, 'PARTICLE ', I, ' RUN ', J, 'PREC ERR'
+cbzdbg2/16/99
+               PRINT *, ' FLAV = ', ITYP, ' PX = ', PX, ' PY = ', PY
+cbzdbg2/16/99
+cbzdbg2/15/99
+               PRINT *, ' PZ = ', PZ, ' EE = ', EE
+cbzdbg2/16/99
+               PRINT *, ' XM = ', XM
+cbzdbg2/16/99end
+               GOTO 200
+c               STOP
+cbzdbg2/15/99end
+            END IF
+            DXMT = XMT - XM
+            Y = 0.5 * LOG((EE + PZ) / (EE - PZ))
+c.....rapidity cut for the rapidity distribution
+            IF (ABS(Y) .GE. 10.0) GOTO 100
+clin-9/26/03 no symmetrization in y (or eta) for ana/*.dat:
+c            IY = 1 + int(ABS(Y) / BY)
+c            Ieta = 1 + int(ABS(eta) / BY)
+            IF (ABS(eta) .GE. 10.0) GOTO 100
+            IY = 1 + int((Y+10.) / BY)
+            Ieta = 1 + int((eta+10.) / BY)
+
+            IF (ITYP .LT. -1000) THEN
+               dy1ntb(IY) = dy1ntb(IY) - 1.0
+            END IF
+            IF (ITYP .GT. 1000) THEN
+               dy1ntb(IY) = dy1ntb(IY) + 1.0
+            END IF
+            IF (ITYP .EQ. -2212) THEN
+               dy1ntp(IY) = dy1ntp(IY) - 1.0
+            END IF
+            IF (ITYP .EQ. 2212) THEN
+               dy1ntp(IY) = dy1ntp(IY) + 1.0
+            END IF
+c            IF (ITYP .EQ. -211 .OR. ITYP .EQ. -321 .OR.
+c     &         ITYP .EQ. -2212) THEN
+            IF (ITYP .EQ. -2112) THEN
+               DY1HM(IY) = DY1HM(IY) + 1.0
+            END IF
+c
+            IF (LUCHGE(ITYP).ne.0) THEN
+               DY1CH(IY) = DY1CH(IY) + 1.0
+               DE1CH(Ieta) = DE1CH(Ieta) + 1.0
+               IF (LUCHGE(ITYP).lt.0) THEN
+                  DY1NEG(IY) = DY1NEG(IY) + 1.0
+                  DE1NEG(Ieta) = DE1NEG(Ieta) + 1.0
+               endif
+            END IF
+
+cbz3/17/99
+            IF ((ITYP .GE. 100 .AND. ITYP .LT. 1000) .OR. 
+     &         (ITYP .GT. -1000 .AND. ITYP .LE. -100)) THEN
+               dy1msn(IY) = dy1msn(IY) + 1.0
+            END IF
+            IF (ITYP .EQ. 211) THEN
+               DY1PIP(IY) = DY1PIP(IY) + 1.0
+            END IF
+            IF (ITYP .EQ. -211) THEN
+               DY1PIM(IY) = DY1PIM(IY) + 1.0
+            END IF
+            IF (ITYP .EQ. 111) THEN
+               DY1PI0(IY) = DY1PI0(IY) + 1.0
+            END IF
+            IF (ITYP .EQ. 2212) THEN
+               DY1PR(IY) = DY1PR(IY) + 1.0
+            END IF
+            IF (ITYP .EQ. -2212) THEN
+               DY1PB(IY) = DY1PB(IY) + 1.0
+            END IF
+cbz3/17/99 end
+            IF (ITYP .EQ. 321) THEN
+               DY1KP(IY) = DY1KP(IY) + 1.0
+            END IF
+            IF (ITYP .EQ. -321) THEN
+               DY1KM(IY) = DY1KM(IY) + 1.0
+            END IF
+clin-4/24/03 evaluate K0L instead of K0S, since sometimes we may decay K0S:
+c            IF (ITYP .EQ. 310) THEN
+            IF (ITYP .EQ. 130) THEN
+               DY1K0S(IY) = DY1K0S(IY) + 1.0
+            END IF
+            IF (ITYP .EQ. 3122) THEN
+               DY1LA(IY) = DY1LA(IY) + 1.0
+            END IF
+            IF (ITYP .EQ. -3122) THEN
+               DY1LB(IY) = DY1LB(IY) + 1.0
+            END IF
+            IF (ITYP .EQ. 333) THEN
+               DY1PHI(IY) = DY1PHI(IY) + 1.0
+            END IF
+
+c.....insert rapidity cut for mt spectrum here
+ 100        IF (Y .LT. YMT1 .OR. Y .GT. YMT2) GOTO 200
+            IF (DXMT .GE. 50.0 * BMT .OR. DXMT .EQ. 0) GOTO 200
+            IMT = 1 + int(DXMT / BMT)
+            IF (ITYP .EQ. 211) THEN
+               dm1pip(IMT) = dm1pip(IMT) + 1.0 / XMT
+            END IF
+            IF (ITYP .EQ. -211) THEN
+               dm1pim(IMT) = dm1pim(IMT) + 
+     &            1.0 / XMT
+            END IF
+            IF (ITYP .EQ. 2212) THEN
+               DMT1PR(IMT) = DMT1PR(IMT) + 1.0 / XMT
+            END IF
+            IF (ITYP .EQ. -2212) THEN
+               DMT1PB(IMT) = DMT1PB(IMT) + 1.0 / XMT
+            END IF
+            IF (ITYP .EQ. 321) THEN
+               DMT1KP(IMT) = DMT1KP(IMT) + 1.0 / XMT
+            END IF
+            IF (ITYP .EQ. -321) THEN
+               dm1km(IMT) = dm1km(IMT) + 1.0 / XMT
+            END IF
+clin-4/24/03:
+c            IF (ITYP .EQ. 310) THEN
+            IF (ITYP .EQ. 130) THEN
+               dm1k0s(IMT) = dm1k0s(IMT) + 1.0 / XMT
+            END IF
+            IF (ITYP .EQ. 3122) THEN
+               DMT1LA(IMT) = DMT1LA(IMT) + 1.0 / XMT
+            END IF
+            IF (ITYP .EQ. -3122) THEN
+               DMT1LB(IMT) = DMT1LB(IMT) + 1.0 / XMT
+            END IF
+
+ 200        CONTINUE
+ 1001    CONTINUE
+ 1002 CONTINUE
+
+      RETURN
+      END
+
+c-----------------------------------------------------------------------
+
+c.....analysis subroutine after the hadronic space-time evolution
+
+      SUBROUTINE ARTAN2
+
+      PARAMETER (MAXSTR=150001, MAXR=1)
+c.....y cut for mt spectrum
+cbz3/17/99
+c      PARAMETER (YMT1 = -0.4, YMT2 = 0.4)
+      PARAMETER (YMT1 = -1.0, YMT2 = 1.0)
+cbz3/17/99 end
+c.....bin width for mt spectrum and y spectrum
+c      PARAMETER (BMT = 0.05, BY = 0.2)
+      PARAMETER (BMT = 0.05, BY = 0.4)
+      COMMON /RUN/ NUM
+cc      SAVE /RUN/
+      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)
+cbz3/17/99
+c     &     dm2k0s(50), DMT2LA(50), DMT2LB(50)
+cc      SAVE /ARPRC1/
+      COMMON /ARANA2/
+     &     dy2ntb(50), dy2ntp(50), DY2HM(50), 
+     &     DY2KP(50), DY2KM(50), DY2K0S(50),
+     &     DY2LA(50), DY2LB(50), DY2PHI(50),
+     &     dm2pip(50), dm2pim(50), DMT2PR(50),
+     &     DMT2PB(50), DMT2KP(50), dm2km(50),
+     &     dm2k0s(50), DMT2LA(50), DMT2LB(50),
+     &     dy2msn(50), DY2PIP(50), DY2PIM(50), 
+     &     DY2PI0(50), DY2PR(50), DY2PB(50)
+     &     ,DY2NEG(50), DY2CH(50), DE2NEG(50), DE2CH(50)
+cbz3/17/99 end
+cc      SAVE /ARANA2/
+      SAVE   
+
+      DO 1002 J = 1, NUM
+         DO 1001 I = 1, MULTI1(J)
+            ITYP = ITYP1(I, J)
+            PX = PX1(I, J)
+            PY = PY1(I, J)
+            PZ = PZ1(I, J)
+            EE = EE1(I, J)
+            XM = XM1(I, J)
+            XMT = SQRT(PX ** 2 + PY ** 2 + XM ** 2)
+c     2/24/03 leptons and photons:
+            if(xm.lt.0.01) goto 200
+            ptot = sqrt(PX ** 2 + PY ** 2 + pz ** 2)
+            eta = 0.5*alog((Ptot+pz+1e-5)/(ptot-pz+1e-5))
+
+            IF (ABS(PZ) .GE. EE) THEN
+               PRINT *, 'IN ARTAN2'
+               PRINT *, 'PARTICLE ', I, ' RUN ', J, 'PREC ERR'
+cbzdbg2/16/99
+               PRINT *, ' FLAV = ', ITYP, ' PX = ', PX, ' PY = ', PY
+cbzdbg2/16/99
+cbzdbg2/15/99
+               PRINT *, ' PZ = ', PZ, ' EE = ', EE
+cbzdbg2/16/99
+               PRINT *, ' XM = ', XM
+cbzdbg2/16/99end
+               GOTO 200
+c               STOP
+cbzdbg2/15/99end
+            END IF
+            DXMT = XMT - XM
+            Y = 0.5 * LOG((EE + PZ) / (EE - PZ))
+c.....rapidity cut for the rapidity distribution
+            IF (ABS(Y) .GE. 10.0) GOTO 100
+c            IY = 1 + int(ABS(Y) / BY)
+c            Ieta = 1 + int(ABS(eta) / BY)
+            IF (ABS(eta) .GE. 10.0) GOTO 100
+            IY = 1 + int((Y+10.) / BY)
+            Ieta = 1 + int((eta+10.) / BY)
+
+            IF (ITYP .LT. -1000) THEN
+               dy2ntb(IY) = dy2ntb(IY) - 1.0
+            END IF
+            IF (ITYP .GT. 1000) THEN
+               dy2ntb(IY) = dy2ntb(IY) + 1.0
+            END IF
+            IF (ITYP .EQ. -2212) THEN
+               dy2ntp(IY) = dy2ntp(IY) - 1.0
+            END IF
+            IF (ITYP .EQ. 2212) THEN
+               dy2ntp(IY) = dy2ntp(IY) + 1.0
+            END IF
+            IF (ITYP .EQ. -2112) THEN
+               DY2HM(IY) = DY2HM(IY) + 1.0
+            END IF
+
+            IF (LUCHGE(ITYP).ne.0) THEN
+               DY2CH(IY) = DY2CH(IY) + 1.0
+               DE2CH(Ieta) = DE2CH(Ieta) + 1.0
+               IF (LUCHGE(ITYP).lt.0) THEN
+                  DY2NEG(IY) = DY2NEG(IY) + 1.0
+                  DE2NEG(Ieta) = DE2NEG(Ieta) + 1.0
+               endif
+            END IF
+
+cbz3/17/99
+            IF ((ITYP .GE. 100 .AND. ITYP .LT. 1000) .OR. 
+     &         (ITYP .GT. -1000 .AND. ITYP .LE. -100)) THEN
+               dy2msn(IY) = dy2msn(IY) + 1.0
+            END IF
+            IF (ITYP .EQ. 211) THEN
+               DY2PIP(IY) = DY2PIP(IY) + 1.0
+            END IF
+            IF (ITYP .EQ. -211) THEN
+               DY2PIM(IY) = DY2PIM(IY) + 1.0
+            END IF
+            IF (ITYP .EQ. 111) THEN
+               DY2PI0(IY) = DY2PI0(IY) + 1.0
+            END IF
+            IF (ITYP .EQ. 2212) THEN
+               DY2PR(IY) = DY2PR(IY) + 1.0
+            END IF
+            IF (ITYP .EQ. -2212) THEN
+               DY2PB(IY) = DY2PB(IY) + 1.0
+            END IF
+cbz3/17/99 end
+            IF (ITYP .EQ. 321) THEN
+               DY2KP(IY) = DY2KP(IY) + 1.0
+            END IF
+            IF (ITYP .EQ. -321) THEN
+               DY2KM(IY) = DY2KM(IY) + 1.0
+            END IF
+clin-4/24/03:
+c            IF (ITYP .EQ. 310) THEN
+            IF (ITYP .EQ. 130) THEN
+               DY2K0S(IY) = DY2K0S(IY) + 1.0
+            END IF
+            IF (ITYP .EQ. 3122) THEN
+               DY2LA(IY) = DY2LA(IY) + 1.0
+            END IF
+            IF (ITYP .EQ. -3122) THEN
+               DY2LB(IY) = DY2LB(IY) + 1.0
+            END IF
+            IF (ITYP .EQ. 333) THEN
+               DY2PHI(IY) = DY2PHI(IY) + 1.0
+            END IF
+
+c.....insert rapidity cut for mt spectrum here
+ 100        IF (Y .LT. YMT1 .OR. Y .GT. YMT2) GOTO 200
+            IF (DXMT .GE. 50.0 * BMT .OR. DXMT .EQ. 0) GOTO 200
+            IMT = 1 + int(DXMT / BMT)
+            IF (ITYP .EQ. 211) THEN
+               dm2pip(IMT) = dm2pip(IMT) + 1.0 / XMT
+            END IF
+            IF (ITYP .EQ. -211) THEN
+               dm2pim(IMT) = dm2pim(IMT) + 
+     &            1.0 / XMT
+            END IF
+            IF (ITYP .EQ. 2212) THEN
+               DMT2PR(IMT) = DMT2PR(IMT) + 1.0 / XMT
+            END IF
+            IF (ITYP .EQ. -2212) THEN
+               DMT2PB(IMT) = DMT2PB(IMT) + 1.0 / XMT
+            END IF
+            IF (ITYP .EQ. 321) THEN
+               DMT2KP(IMT) = DMT2KP(IMT) + 1.0 / XMT
+            END IF
+            IF (ITYP .EQ. -321) THEN
+               dm2km(IMT) = dm2km(IMT) + 1.0 / XMT
+            END IF
+clin-4/24/03:
+c            IF (ITYP .EQ. 310) THEN
+            IF (ITYP .EQ. 130) THEN
+               dm2k0s(IMT) = dm2k0s(IMT) + 1.0 / XMT
+            END IF
+            IF (ITYP .EQ. 3122) THEN
+               DMT2LA(IMT) = DMT2LA(IMT) + 1.0 / XMT
+            END IF
+            IF (ITYP .EQ. -3122) THEN
+               DMT2LB(IMT) = DMT2LB(IMT) + 1.0 / XMT
+            END IF
+
+ 200        CONTINUE
+ 1001    CONTINUE
+ 1002 CONTINUE
+
+      RETURN
+      END
+
+c-----------------------------------------------------------------------
+
+c.....output analysis results at the end of the simulation
+
+      SUBROUTINE ARTOUT(NEVNT)
+
+      PARAMETER (MAXSTR=150001, MAXR=1)
+c.....y cut for mt spectrum
+cbz3/17/99
+c      PARAMETER (YMT1 = -0.4, YMT2 = 0.4)
+      PARAMETER (YMT1 = -1.0, YMT2 = 1.0)
+cbz3/17/99 end
+c.....bin width for mt spectrum and y spectrum
+c      PARAMETER (BMT = 0.05, BY = 0.2)
+      PARAMETER (BMT = 0.05, BY = 0.4)
+      COMMON /RUN/ NUM
+cc      SAVE /RUN/
+      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)
+cbz3/17/99
+c     &     dm1k0s(50), DMT1LA(50), DMT1LB(50)
+cc      SAVE /ARPRC1/
+      COMMON /ARANA1/
+     &     dy1ntb(50), dy1ntp(50), DY1HM(50), 
+     &     DY1KP(50), DY1KM(50), DY1K0S(50),
+     &     DY1LA(50), DY1LB(50), DY1PHI(50),
+     &     dm1pip(50), dm1pim(50), DMT1PR(50),
+     &     DMT1PB(50), DMT1KP(50), dm1km(50),
+     &     dm1k0s(50), DMT1LA(50), DMT1LB(50),
+     &     dy1msn(50), DY1PIP(50), DY1PIM(50), 
+     &     DY1PI0(50), DY1PR(50), DY1PB(50)
+     &     ,DY1NEG(50), DY1CH(50), DE1NEG(50), DE1CH(50)
+cbz3/17/99 end
+cc      SAVE /ARANA1/
+cbz3/17/99
+c     &     dm2k0s(50), DMT2LA(50), DMT2LB(50)
+      COMMON /ARANA2/
+     &     dy2ntb(50), dy2ntp(50), DY2HM(50), 
+     &     DY2KP(50), DY2KM(50), DY2K0S(50),
+     &     DY2LA(50), DY2LB(50), DY2PHI(50),
+     &     dm2pip(50), dm2pim(50), DMT2PR(50),
+     &     DMT2PB(50), DMT2KP(50), dm2km(50),
+     &     dm2k0s(50), DMT2LA(50), DMT2LB(50),
+     &     dy2msn(50), DY2PIP(50), DY2PIM(50), 
+     &     DY2PI0(50), DY2PR(50), DY2PB(50)
+     &     ,DY2NEG(50), DY2CH(50), DE2NEG(50), DE2CH(50)
+cc      SAVE /ARANA2/
+      SAVE   
+cbz3/17/99 end
+cms   OPEN (30, FILE = 'ana/dndy_netb.dat', STATUS = 'UNKNOWN')
+cms   OPEN (31, FILE = 'ana/dndy_netp.dat', STATUS = 'UNKNOWN')
+cms   OPEN (32, FILE = 'ana/dndy_nb.dat', STATUS = 'UNKNOWN')
+cms   OPEN (33, FILE = 'ana/dndy_neg.dat', STATUS = 'UNKNOWN')
+cms   OPEN (34, FILE = 'ana/dndy_ch.dat', STATUS = 'UNKNOWN')
+cms   OPEN (35, FILE = 'ana/dnde_neg.dat', STATUS = 'UNKNOWN')
+cms   OPEN (36, FILE = 'ana/dnde_ch.dat', STATUS = 'UNKNOWN')
+cms   OPEN (37, FILE = 'ana/dndy_kp.dat', STATUS = 'UNKNOWN')
+cms   OPEN (38, FILE = 'ana/dndy_km.dat', STATUS = 'UNKNOWN')
+clin-4/24/03
+c      OPEN (39, FILE = 'ana/dndy_k0s.dat', STATUS = 'UNKNOWN')
+cms   OPEN (39, FILE = 'ana/dndy_k0l.dat', STATUS = 'UNKNOWN')
+cms   OPEN (40, FILE = 'ana/dndy_la.dat', STATUS = 'UNKNOWN')
+cms   OPEN (41, FILE = 'ana/dndy_lb.dat', STATUS = 'UNKNOWN')
+cms   OPEN (42, FILE = 'ana/dndy_phi.dat', STATUS = 'UNKNOWN')
+cbz3/17/99
+cms   OPEN (43, FILE = 'ana/dndy_meson.dat', STATUS = 'UNKNOWN')
+cms   OPEN (44, FILE = 'ana/dndy_pip.dat', STATUS = 'UNKNOWN')
+cms   OPEN (45, FILE = 'ana/dndy_pim.dat', STATUS = 'UNKNOWN')
+cms   OPEN (46, FILE = 'ana/dndy_pi0.dat', STATUS = 'UNKNOWN')
+cms   OPEN (47, FILE = 'ana/dndy_pr.dat', STATUS = 'UNKNOWN')
+cms   OPEN (48, FILE = 'ana/dndy_pb.dat', STATUS = 'UNKNOWN')
+cbz3/17/99 end
+
+cms   OPEN (50, FILE = 'ana/dndmtdy_pip.dat', STATUS = 'UNKNOWN')
+cms   OPEN (51, FILE = 'ana/dndmtdy_0_1_pim.dat', STATUS = 'UNKNOWN')
+cms   OPEN (52, FILE = 'ana/dndmtdy_pr.dat', STATUS = 'UNKNOWN')
+cms   OPEN (53, FILE = 'ana/dndmtdy_pb.dat', STATUS = 'UNKNOWN')
+cms   OPEN (54, FILE = 'ana/dndmtdy_kp.dat', STATUS = 'UNKNOWN')
+cms   OPEN (55, FILE = 'ana/dndmtdy_0_5_km.dat', STATUS = 'UNKNOWN')
+cms   OPEN (56, FILE = 'ana/dndmtdy_k0s.dat', STATUS = 'UNKNOWN')
+cms   OPEN (57, FILE = 'ana/dndmtdy_la.dat', STATUS = 'UNKNOWN')
+cms   OPEN (58, FILE = 'ana/dndmtdy_lb.dat', STATUS = 'UNKNOWN')
+clin-9/26/03 no symmetrization in y (or eta) for ana/*.dat:
+c      SCALE1 = 1. / REAL(NEVNT * NUM) / BY / 2.0
+      SCALE1 = 1. / REAL(NEVNT * NUM) / BY
+      SCALE2 = 1. / REAL(NEVNT * NUM) / BMT / (YMT2 - YMT1)
+c
+      DO 1001 I = 1, 50
+         ymid=-10.+BY * (I - 0.5)
+cms      WRITE (30, 333) ymid, SCALE1 * dy1ntb(I)
+cms      WRITE (31, 333) ymid, SCALE1 * dy1ntp(I)
+cms      WRITE (32, 333) ymid, SCALE1 * DY1HM(I)
+cms      WRITE (37, 333) ymid, SCALE1 * DY1KP(I)
+cms      WRITE (38, 333) ymid, SCALE1 * DY1KM(I)
+cms      WRITE (39, 333) ymid, SCALE1 * DY1K0S(I)
+cms      WRITE (40, 333) ymid, SCALE1 * DY1LA(I)
+cms      WRITE (41, 333) ymid, SCALE1 * DY1LB(I)
+cms      WRITE (42, 333) ymid, SCALE1 * DY1PHI(I)
+cms      WRITE (33, 333) ymid, SCALE1 * DY1NEG(I)
+cms      WRITE (34, 333) ymid, SCALE1 * DY1CH(I)
+cms      WRITE (35, 333) ymid, SCALE1 * DE1NEG(I)
+cms      WRITE (36, 333) ymid, SCALE1 * DE1CH(I)
+cms      WRITE (43, 333) ymid, SCALE1 * dy1msn(I)
+cms      WRITE (44, 333) ymid, SCALE1 * DY1PIP(I)
+cms      WRITE (45, 333) ymid, SCALE1 * DY1PIM(I)
+cms      WRITE (46, 333) ymid, SCALE1 * DY1PI0(I)
+cms      WRITE (47, 333) ymid, SCALE1 * DY1PR(I)
+cms      WRITE (48, 333) ymid, SCALE1 * DY1PB(I)
+
+         IF (dm1pip(I) .NE. 0.0) THEN
+cms         WRITE (50, 333) BMT * (I - 0.5), SCALE2 * dm1pip(I)
+         END IF
+         IF (dm1pim(I) .NE. 0.0) THEN
+cms         WRITE (51, 333) BMT * (I - 0.5), SCALE2 * 0.1 * 
+cms  &         dm1pim(I)
+         END IF
+         IF (DMT1PR(I) .NE. 0.0) THEN
+cms         WRITE (52, 333) BMT * (I - 0.5), SCALE2 * DMT1PR(I)
+         END IF
+         IF (DMT1PB(I) .NE. 0.0) THEN
+cms         WRITE (53, 333) BMT * (I - 0.5), SCALE2 * DMT1PB(I)
+         END IF
+         IF (DMT1KP(I) .NE. 0.0) THEN
+cms         WRITE (54, 333) BMT * (I - 0.5), SCALE2 * DMT1KP(I)
+         END IF
+         IF (dm1km(I) .NE. 0.0) THEN
+cms         WRITE (55, 333) BMT * (I - 0.5), SCALE2 * 0.5 *
+cms  &         dm1km(I)
+         END IF
+         IF (dm1k0s(I) .NE. 0.0) THEN
+cms         WRITE (56, 333) BMT * (I - 0.5), SCALE2 * dm1k0s(I)
+         END IF
+         IF (DMT1LA(I) .NE. 0.0) THEN
+cms         WRITE (57, 333) BMT * (I - 0.5), SCALE2 * DMT1LA(I)
+         END IF
+         IF (DMT1LB(I) .NE. 0.0) THEN
+cms         WRITE (58, 333) BMT * (I - 0.5), SCALE2 * DMT1LB(I)
+         END IF
+ 1001 CONTINUE
+c
+      DO 1002 I = 30, 48
+cms      WRITE (I, *) 'after hadron evolution'
+ 1002    CONTINUE
+      DO 1003 I = 50, 58
+cms      WRITE (I, *) 'after hadron evolution'
+ 1003 CONTINUE
+
+      DO 1004 I = 1, 50
+         ymid=-10.+BY * (I - 0.5)
+cms      WRITE (30, 333) ymid, SCALE1 * dy2ntb(I)
+cms      WRITE (31, 333) ymid, SCALE1 * dy2ntp(I)
+cms      WRITE (32, 333) ymid, SCALE1 * DY2HM(I)
+cms      WRITE (37, 333) ymid, SCALE1 * DY2KP(I)
+cms      WRITE (38, 333) ymid, SCALE1 * DY2KM(I)
+cms      WRITE (39, 333) ymid, SCALE1 * DY2K0S(I)
+cms      WRITE (40, 333) ymid, SCALE1 * DY2LA(I)
+cms      WRITE (41, 333) ymid, SCALE1 * DY2LB(I)
+cms      WRITE (42, 333) ymid, SCALE1 * DY2PHI(I)
+cms      WRITE (33, 333) ymid, SCALE1 * DY2NEG(I)
+cms      WRITE (34, 333) ymid, SCALE1 * DY2CH(I)
+cms      WRITE (35, 333) ymid, SCALE1 * DE2NEG(I)
+cms      WRITE (36, 333) ymid, SCALE1 * DE2CH(I)
+cms      WRITE (43, 333) ymid, SCALE1 * dy2msn(I)
+cms      WRITE (44, 333) ymid, SCALE1 * DY2PIP(I)
+cms      WRITE (45, 333) ymid, SCALE1 * DY2PIM(I)
+cms      WRITE (46, 333) ymid, SCALE1 * DY2PI0(I)
+cms      WRITE (47, 333) ymid, SCALE1 * DY2PR(I)
+cms      WRITE (48, 333) ymid, SCALE1 * DY2PB(I)
+c
+         IF (dm2pip(I) .NE. 0.0) THEN
+cms         WRITE (50, 333) BMT * (I - 0.5), SCALE2 * dm2pip(I)
+         END IF
+         IF (dm2pim(I) .NE. 0.0) THEN
+cms         WRITE (51, 333) BMT * (I - 0.5), SCALE2 * 0.1 * 
+cms  &         dm2pim(I)
+         END IF
+         IF (DMT2PR(I) .NE. 0.0) THEN
+cms         WRITE (52, 333) BMT * (I - 0.5), SCALE2 * DMT2PR(I)
+         END IF
+         IF (DMT2PB(I) .NE. 0.0) THEN
+cms         WRITE (53, 333) BMT * (I - 0.5), SCALE2 * DMT2PB(I)
+         END IF
+         IF (DMT2KP(I) .NE. 0.0) THEN
+cms         WRITE (54, 333) BMT * (I - 0.5), SCALE2 * DMT2KP(I)
+         END IF
+         IF (dm2km(I) .NE. 0.0) THEN
+cms         WRITE (55, 333) BMT * (I - 0.5), SCALE2 * 0.5 * 
+cms  &         dm2km(I)
+         END IF
+         IF (dm2k0s(I) .NE. 0.0) THEN
+cms         WRITE (56, 333) BMT * (I - 0.5), SCALE2 * dm2k0s(I)
+         END IF
+         IF (DMT2LA(I) .NE. 0.0) THEN
+cms         WRITE (57, 333) BMT * (I - 0.5), SCALE2 * DMT2LA(I)
+         END IF
+         IF (DMT2LB(I) .NE. 0.0) THEN
+cms         WRITE (58, 333) BMT * (I - 0.5), SCALE2 * DMT2LB(I)
+         END IF
+ 1004 CONTINUE
+cms 333  format(2(f12.5,1x))
+
+      RETURN
+      END
+
+c-----------------------------------------------------------------------
+
+c.....analysis subroutine in HIJING before parton cascade evolution
+      SUBROUTINE HJANA1
+
+      PARAMETER (YMAX = 1.0, YMIN = -1.0)
+      PARAMETER (DMT = 0.05, DY = 0.2)
+      PARAMETER (DR = 0.2)
+      PARAMETER (MAXPTN=400001,MAXSTR=150001)
+      DIMENSION dyp1(50), DMYP1(200), DEYP1(50)
+      DIMENSION dyg1(50), DMYG1(200), DEYG1(50)
+      DIMENSION SNYP1(50), SMYP1(200), SEYP1(50)
+      DIMENSION SNYG1(50), SMYG1(200), SEYG1(50)
+      DIMENSION dnrpj1(50), dnrtg1(50), dnrin1(50),
+     &   dnrtt1(50)
+      DIMENSION dyg1c(50), dmyg1c(50), deyg1c(50)
+      DIMENSION snrpj1(50), snrtg1(50), snrin1(50),
+     &   snrtt1(50)
+      DIMENSION snyg1c(50), smyg1c(50), seyg1c(50)
+      DOUBLE PRECISION  GX0, GY0, GZ0, FT0, PX0, PY0, PZ0, E0, XMASS0
+
+      COMMON /PARA1/ MUL
+cc      SAVE /PARA1/
+      COMMON/HPARNT/HIPR1(100),IHPR2(50),HINT1(100),IHNT2(50)
+cc      SAVE /HPARNT/
+      COMMON/hjcrdn/YP(3,300),YT(3,300)
+cc      SAVE /hjcrdn/
+      COMMON/HJJET1/NPJ(300),KFPJ(300,500),PJPX(300,500),
+     &   PJPY(300,500),PJPZ(300,500),PJPE(300,500),
+     &   PJPM(300,500),NTJ(300),KFTJ(300,500),
+     &   PJTX(300,500),PJTY(300,500),PJTZ(300,500),
+     &   PJTE(300,500),PJTM(300,500)
+cc      SAVE /HJJET1/
+      COMMON/HJJET2/NSG,NJSG(MAXSTR),IASG(MAXSTR,3),K1SG(MAXSTR,100),
+     &   K2SG(MAXSTR,100),PXSG(MAXSTR,100),PYSG(MAXSTR,100),
+     &   PZSG(MAXSTR,100),PESG(MAXSTR,100),PMSG(MAXSTR,100)
+cc      SAVE /HJJET2/
+      COMMON /prec1/GX0(MAXPTN),GY0(MAXPTN),GZ0(MAXPTN),FT0(MAXPTN),
+     &     PX0(MAXPTN), PY0(MAXPTN), PZ0(MAXPTN), E0(MAXPTN),
+     &     XMASS0(MAXPTN), ITYP0(MAXPTN)
+cc      SAVE /prec1/
+      COMMON /AREVT/ IAEVT, IARUN, MISS
+cc      SAVE /AREVT/
+      COMMON /AROUT/ IOUT
+cc      SAVE /AROUT/
+      SAVE   
+      DATA IW/0/
+      IF (isevt .EQ. IAEVT .AND. isrun .EQ. IARUN) THEN
+         DO 1001 I = 1, 200
+            DMYP1(I) = SMYP1(I)
+            DMYG1(I) = SMYG1(I)
+ 1001    CONTINUE
+
+         DO 1002 I = 1, 50
+            dyp1(I) = SNYP1(I)
+            DEYP1(I) = SEYP1(I)
+            dyg1(I) = SNYG1(I)
+            DEYG1(I) = SEYG1(I)
+            dnrpj1(I) = snrpj1(I)
+            dnrtg1(I) = snrtg1(I)
+            dnrin1(I) = snrin1(I)
+            dnrtt1(I) = snrtt1(I)
+            dyg1c(I) = snyg1c(I)
+            dmyg1c(I) = smyg1c(I)
+            deyg1c(I) = seyg1c(I)
+ 1002    CONTINUE
+         nsubp = nsubpS
+         nsubg = nsubgS
+         NISG = NISGS
+      ELSE
+         DO 1003 I = 1, 200
+            SMYP1(I) = DMYP1(I)
+            SMYG1(I) = DMYG1(I)
+ 1003    CONTINUE
+
+         DO 1004 I = 1, 50
+            SNYP1(I) = dyp1(I)
+            SEYP1(I) = DEYP1(I)
+            SNYG1(I) = dyg1(I)
+            SEYG1(I) = DEYG1(I)
+            snrpj1(I) = dnrpj1(I)
+            snrtg1(I) = dnrtg1(I)
+            snrin1(I) = dnrin1(I)
+            snrtt1(I) = dnrtt1(I)
+            snyg1c(I) = dyg1c(I)
+            smyg1c(I) = dmyg1c(I)
+            seyg1c(I) = deyg1c(I)
+ 1004    CONTINUE
+         nsubpS = nsubp
+         nsubgS = nsubg
+         NISGS = NISG
+         isevt = IAEVT
+         isrun = IARUN
+         IW = IW + 1
+      END IF
+c.....analysis
+      DO 1006 I = 1, IHNT2(1)
+         DO 1005 J = 1, NPJ(I)
+            ITYP = KFPJ(I, J)
+            PX = PJPX(I, J)
+            PY = PJPY(I, J)
+            PZ = PJPZ(I, J)
+            PE = PJPE(I, J)
+            PM = PJPM(I, J)
+            IF (ABS(PZ) .GE. PE) THEN
+               PRINT *, ' IN HJANA1, PROJ STR ', I, ' PART ', J
+               PRINT *, ' FLAV = ', ITYP, ' PX = ', PX, ' PY = ', PY
+               PRINT *, ' PZ = ', PZ, ' EE = ', PE
+               PRINT *, ' XM = ', PM
+               GOTO 200
+            END IF
+            RAP = 0.5 * LOG((PE + PZ) / (PE - PZ))
+            XMT = SQRT(PX ** 2 + PY ** 2 + PM ** 2)
+            DXMT = XMT - PM
+            IY = 1 + int(ABS(RAP) / DY)
+            IF (IY .GT. 50) GOTO 100
+            dyp1(IY) = dyp1(IY) + 1.0
+            DEYP1(IY) = DEYP1(IY) + XMT
+            IF (ITYP .EQ. 21) THEN
+               dyg1(IY) = dyg1(IY) + 1.0
+               DEYG1(IY) = DEYG1(IY) + XMT
+            END IF
+ 100        CONTINUE
+            IMT = 1 + int(DXMT / DMT)
+            IF (RAP .GT. YMAX .OR. RAP .LE. YMIN) GOTO 200
+            IF (IMT .GT. 200) GOTO 200
+            DMYP1(IMT) = DMYP1(IMT) + 1.0 / XMT
+            IF (ITYP .EQ. 21) THEN
+               DMYG1(IMT) = DMYG1(IMT) + 1.0 / XMT
+            END IF
+ 200        CONTINUE
+ 1005    CONTINUE
+ 1006 CONTINUE
+
+      DO 1008 I = 1, IHNT2(3)
+         DO 1007 J = 1, NTJ(I)
+            ITYP = KFTJ(I, J)
+            PX = PJTX(I, J)
+            PY = PJTY(I, J)
+            PZ = PJTZ(I, J)
+            PE = PJTE(I, J)
+            PM = PJTM(I, J)
+            IF (ABS(PZ) .GE. PE) THEN
+               PRINT *, ' IN HJANA1, TARG STR ', I, ' PART ', J
+               PRINT *, ' FLAV = ', ITYP, ' PX = ', PX, ' PY = ', PY
+               PRINT *, ' PZ = ', PZ, ' EE = ', PE
+               PRINT *, ' XM = ', PM
+               GOTO 400
+            END IF
+            RAP = 0.5 * LOG((PE + PZ) / (PE - PZ))
+            XMT = SQRT(PX ** 2 + PY ** 2 + PM ** 2)
+            DXMT = XMT - PM
+            IY = 1 + int(ABS(RAP) / DY)
+            IF (IY .GT. 50) GOTO 300
+            dyp1(IY) = dyp1(IY) + 1.0
+            DEYP1(IY) = DEYP1(IY) + XMT
+            IF (ITYP .EQ. 21) THEN
+               dyg1(IY) = dyg1(IY) + 1.0
+               DEYG1(IY) = DEYG1(IY) + XMT
+            END IF
+ 300        CONTINUE
+            IF (RAP .GT. YMAX .OR. RAP .LE. YMIN) GOTO 400
+            IMT = 1 + int(DXMT / DMT)
+            IF (IMT .GT. 200) GOTO 400
+            DMYP1(IMT) = DMYP1(IMT) + 1.0 / XMT
+            IF (ITYP .EQ. 21) THEN
+               DMYG1(IMT) = DMYG1(IMT) + 1.0 / XMT
+            END IF
+ 400        CONTINUE
+ 1007    CONTINUE
+ 1008 CONTINUE
+
+      DO 1010 I = 1, NSG
+         DO 1009 J = 1, NJSG(I)
+            ITYP = K2SG(I, J)
+            PX = PXSG(I, J)
+            PY = PYSG(I, J)
+            PZ = PZSG(I, J)
+            PE = PESG(I, J)
+            PM = PMSG(I, J)
+            IF (ABS(PZ) .GE. PE) THEN
+               PRINT *, ' IN HJANA1, INDP STR ', I, ' PART ', J
+               PRINT *, ' FLAV = ', ITYP, ' PX = ', PX, ' PY = ', PY
+               PRINT *, ' PZ = ', PZ, ' EE = ', PE
+               PRINT *, ' XM = ', PM
+               GOTO 600
+            END IF
+            RAP = 0.5 * LOG((PE + PZ) / (PE - PZ))
+            XMT = SQRT(PX ** 2 + PY ** 2 + PM ** 2)
+            DXMT = XMT - PM
+            IY = 1 + int(ABS(RAP) / DY)
+            IF (IY .GT. 50) GOTO 500
+            dyp1(IY) = dyp1(IY) + 1.0
+            DEYP1(IY) = DEYP1(IY) + XMT
+            IF (ITYP .EQ. 21) THEN
+               dyg1(IY) = dyg1(IY) + 1.0
+               DEYG1(IY) = DEYG1(IY) + XMT
+            END IF
+ 500        CONTINUE
+            IF (RAP .GT. YMAX .OR. RAP .LE. YMIN) GOTO 600
+            IMT = 1 + int(DXMT / DMT)
+            IF (IMT .GT. 200) GOTO 600
+            DMYP1(IMT) = DMYP1(IMT) + 1.0 / XMT
+            IF (ITYP .EQ. 21) THEN
+               DMYG1(IMT) = DMYG1(IMT) + 1.0 / XMT
+            END IF
+ 600        CONTINUE
+ 1009    CONTINUE
+ 1010 CONTINUE
+
+      DO 1011 I = 1, IHNT2(1)
+         YR = SQRT(YP(1, I) ** 2 + YP(2, I) ** 2)
+         IR = 1 + int(YR / DR)
+clin-4/2008 protect against out-of-bound errors:
+c         IF (IR .GT. 50) GOTO 601
+         IF (IR .GT. 50 .or. IR .LT. 1) GOTO 601
+         dnrpj1(IR) = dnrpj1(IR) + 1.0
+         dnrtt1(IR) = dnrtt1(IR) + 1.0
+ 601     CONTINUE
+ 1011 CONTINUE
+
+      DO 1012 I = 1, IHNT2(3)
+         YR = SQRT(YT(1, I) ** 2 + YT(2, I) ** 2)
+         IR = 1 + int(YR / DR)
+         IF (IR .GT. 50 .or. IR .LT. 1) GOTO 602
+         dnrtg1(IR) = dnrtg1(IR) + 1.0
+         dnrtt1(IR) = dnrtt1(IR) + 1.0
+ 602     CONTINUE
+ 1012 CONTINUE
+
+      DO 1013 I = 1, NSG
+         Y1 = 0.5 * (YP(1, IASG(I, 1)) + YT(1, IASG(I, 2)))
+         Y2 = 0.5 * (YP(2, IASG(I, 1)) + YT(2, IASG(I, 2)))
+         YR = SQRT(Y1 ** 2 + Y2 ** 2)
+         IR = 1 + int(YR / DR)
+         IF (IR .GT. 50 .or. IR .LT. 1) GOTO 603
+         dnrin1(IR) = dnrin1(IR) + 1.0
+         dnrtt1(IR) = dnrtt1(IR) + 1.0
+ 603     CONTINUE
+ 1013 CONTINUE
+
+      DO 1014 I = 1, MUL
+         ITYP = ITYP0(I)
+         PX = sngl(PX0(I))
+         PY = sngl(PY0(I))
+         PZ = sngl(PZ0(I))
+         PE = sngl(E0(I))
+         PM = sngl(XMASS0(I))
+         IF (ABS(PZ) .GE. PE) THEN
+            PRINT *, ' IN HJANA1, GLUON ', I
+            PRINT *, ' FLAV = ', ITYP, ' PX = ', PX, ' PY = ', PY
+            PRINT *, ' PZ = ', PZ, ' EE = ', PE
+            PRINT *, ' XM = ', PM
+            GOTO 800
+         END IF
+         RAP = 0.5 * LOG((PE + PZ) / (PE - PZ))
+         XMT = SQRT(PX ** 2 + PY ** 2 + PM ** 2)
+         DXMT = XMT - PM
+         IY = 1 + int(ABS(RAP) / DY)
+         IF (IY .GT. 50) GOTO 700
+         dyg1c(IY) = dyg1c(IY) + 1.0
+         deyg1c(IY) = deyg1c(IY) + XMT
+ 700     CONTINUE
+         IF (RAP .GT. YMAX .OR. RAP .LE. YMIN) GOTO 800
+         IMT = 1 + int(DXMT / DMT)
+         IF (IMT .GT. 50) GOTO 800
+         dmyg1c(IMT) = dmyg1c(IMT) + 1.0 / XMT
+ 800     CONTINUE
+ 1014 CONTINUE
+c.....count number of particles
+      DO 1016 I = 1, IHNT2(1)
+         DO 1015 J = 1, NPJ(I)
+            nsubp = nsubp + 1
+            IF (KFPJ(I, J) .EQ. 21) nsubg = nsubg + 1
+ 1015    CONTINUE
+ 1016 CONTINUE
+
+      DO 1018 I = 1, IHNT2(3)
+         DO 1017 J = 1, NTJ(I)
+            nsubp = nsubp + 1
+            IF (KFTJ(I, J) .EQ. 21) nsubg = nsubg + 1
+ 1017    CONTINUE
+ 1018 CONTINUE
+
+      DO 1020 I = 1, NSG
+         DO 1019 J = 1, NJSG(I)
+            nsubp = nsubp + 1
+            IF (K2SG(I, J) .EQ. 21) nsubg = nsubg + 1
+ 1019    CONTINUE
+ 1020 CONTINUE
+      NISG = NISG + NSG
+      IF (IOUT .EQ. 1) THEN
+cbzdbg2/16/99
+c      PRINT *, ' in HJANA1 '
+c      PRINT *, ' total number of partons = ', nsubp
+c      PRINT *, ' total number of gluons = ', nsubg, MUL
+c      PRINT *, ' number of projectile strings = ', IHNT2(1)
+c      PRINT *, ' number of target strings = ', IHNT2(3)
+c      PRINT *, ' number of independent strings = ', NSG
+      PRINT *, ' in HJANA1 '
+      PRINT *, ' total number of partons = ', nsubp / IW
+      PRINT *, ' total number of gluons = ', nsubg / IW
+c      PRINT *, ' number of projectile strings = ', IHNT2(1)
+c      PRINT *, ' number of target strings = ', IHNT2(3)
+      PRINT *, ' number of independent strings = ', NISG / IW
+cbzdbg2/16/99end
+      END IF
+c
+      RETURN
+      END
+
+c-----------------------------------------------------------------------
+
+c.....analysis subroutine in ZPC after generation of additional initial
+c.....phase space distributions.
+
+      SUBROUTINE HJAN1A
+      PARAMETER (MAXPTN=400001)
+      PARAMETER (DGX = 0.2, DGY = 0.2, DT = 0.2)
+      DIMENSION dgxg1a(50), dgyg1a(50), dtg1a(50)
+      DIMENSION sgxg1a(50), sgyg1a(50), stg1a(50)
+      DOUBLE PRECISION  GX5, GY5, GZ5, FT5, PX5, PY5, PZ5, E5, XMASS5
+      COMMON /PARA1/ MUL
+cc      SAVE /PARA1/
+      COMMON /prec2/GX5(MAXPTN),GY5(MAXPTN),GZ5(MAXPTN),FT5(MAXPTN),
+     &   PX5(MAXPTN), PY5(MAXPTN), PZ5(MAXPTN), E5(MAXPTN),
+     &   XMASS5(MAXPTN), ITYP5(MAXPTN)
+cc      SAVE /prec2/
+      COMMON /AREVT/ IAEVT, IARUN, MISS
+cc      SAVE /AREVT/
+      COMMON /AROUT/ IOUT
+cc      SAVE /AROUT/
+      SAVE   
+      DATA IW/0/
+
+      IF (isevt .EQ. IAEVT .AND. isrun .EQ. IARUN) THEN
+         DO 1001 I = 1, 50
+            dgxg1a(I) = sgxg1a(I)
+            dgyg1a(I) = sgyg1a(I)
+            dtg1a(I) = stg1a(I)
+ 1001    CONTINUE
+      ELSE
+         DO 1002 I = 1, 50
+            sgxg1a(I) = dgxg1a(I)
+            sgyg1a(I) = dgyg1a(I)
+            stg1a(I) = dtg1a(I)
+ 1002    CONTINUE
+         isevt = IAEVT
+         isrun = IARUN
+         IW = IW + 1
+      END IF
+c.....analysis
+      DO 1003 I = 1, MUL
+         IGX = 1 + int(sngl(ABS(GX5(I))) / DGX)
+clin-4/2008 protect against out-of-bound errors:
+c         IF (IGX .GT. 50) GOTO 100
+         IF (IGX .GT. 50 .or. IGX .LT. 1) GOTO 100
+         dgxg1a(IGX) = dgxg1a(IGX) + 1.0
+ 100     CONTINUE
+         IGY = 1 + int(sngl(ABS(GY5(I))) / DGY)
+         IF (IGY .GT. 50 .or. IGY .LT. 1) GOTO 200
+         dgyg1a(IGY) = dgyg1a(IGY) + 1.0
+ 200     CONTINUE
+         IT = 1 + int(sngl(SQRT(FT5(I) ** 2 - GZ5(I) ** 2)) / DT)
+         IF (IT .GT. 50 .or. IT .LT. 1) GOTO 300
+         dtg1a(IT) = dtg1a(IT) + 1.0
+ 300     CONTINUE
+ 1003 CONTINUE
+      CALL HJAN1B
+c
+      RETURN
+      END
+
+c-----------------------------------------------------------------------
+
+c.....analysis subroutine in HJAN1A
+
+      SUBROUTINE HJAN1B
+      PARAMETER (MAXPTN=400001,MAXSTR=150001)
+      PARAMETER (DR = 0.2, DT = 0.2)
+      DIMENSION DNRG1B(50), dtg1b(50)
+      DIMENSION SNRG1B(50), stg1b(50)
+      DOUBLE PRECISION  GX5, GY5, GZ5, FT5, PX5, PY5, PZ5, E5, XMASS5
+      COMMON /PARA1/ MUL
+cc      SAVE /PARA1/
+      COMMON /prec2/GX5(MAXPTN),GY5(MAXPTN),GZ5(MAXPTN),FT5(MAXPTN),
+     &   PX5(MAXPTN), PY5(MAXPTN), PZ5(MAXPTN), E5(MAXPTN),
+     &   XMASS5(MAXPTN), ITYP5(MAXPTN)
+cc      SAVE /prec2/
+      COMMON /ilist8/ LSTRG1(MAXPTN), LPART1(MAXPTN)
+cc      SAVE /ilist8/
+      COMMON /SREC1/ NSP, NST, NSI
+cc      SAVE /SREC1/
+      COMMON/hjcrdn/YP(3,300),YT(3,300)
+cc      SAVE /hjcrdn/
+      COMMON/HJJET2/NSG,NJSG(MAXSTR),IASG(MAXSTR,3),K1SG(MAXSTR,100),
+     &   K2SG(MAXSTR,100),PXSG(MAXSTR,100),PYSG(MAXSTR,100),
+     &   PZSG(MAXSTR,100),PESG(MAXSTR,100),PMSG(MAXSTR,100)
+cc      SAVE /HJJET2/
+      COMMON /AREVT/ IAEVT, IARUN, MISS
+cc      SAVE /AREVT/
+      COMMON /AROUT/ IOUT
+cc      SAVE /AROUT/
+      SAVE   
+      DATA IW/0/
+
+      IF (isevt .EQ. IAEVT .AND. isrun .EQ. IARUN) THEN
+         DO 1001 I = 1, 50
+            DNRG1B(I) = SNRG1B(I)
+            dtg1b(I) = stg1b(I)
+ 1001    CONTINUE
+      ELSE
+         DO 1002 I = 1, 50
+            SNRG1B(I) = DNRG1B(I)
+            stg1b(I) = dtg1b(I)
+ 1002    CONTINUE
+         isevt = IAEVT
+         isrun = IARUN
+         IW = IW + 1
+      END IF
+c.....analysis
+      DO 1003 I = 1, MUL
+         J = LSTRG1(I)
+
+         IF (J .LE. NSP) THEN
+            K = J
+            GX0 = YP(1, J)
+            GY0 = YP(2, J)
+         ELSE IF (J .LE. NSP + NST) THEN
+            K = J - NSP
+            GX0 = YT(1, K)
+            GY0 = YT(2, K)
+         ELSE
+            K = J - NSP - NST
+            GX0 = 0.5 * (YP(1, IASG(K, 1)) + YT(1, IASG(K, 2)))
+            GY0 = 0.5 * (YP(2, IASG(K, 1)) + YT(2, IASG(K, 2)))
+         END IF
+         R0 = SQRT((sngl(GX5(I)) - GX0)**2 + (sngl(GY5(I)) - GY0)**2)
+         IR = 1 + int(R0 / DR)
+         IF (IR .GT. 50 .or. IR .LT. 1) GOTO 100
+         DNRG1B(IR) = DNRG1B(IR) + 1.0
+ 100     CONTINUE
+         TAU7 = SQRT(sngl(FT5(I) ** 2 - GZ5(I) ** 2))
+         IT = 1 + int(TAU7 / DT)
+         IF (IT .GT. 50 .or. IT .LT. 1) GOTO 200
+         dtg1b(IT) = dtg1b(IT) + 1.0
+ 200     CONTINUE
+ 1003 CONTINUE
+c
+      RETURN
+      END
+
+c-----------------------------------------------------------------------
+
+c.....analysis subroutine in HIJING after parton cascade evolution
+      SUBROUTINE HJANA2
+c
+      PARAMETER (YMAX = 1.0, YMIN = -1.0)
+      PARAMETER (DMT = 0.05, DY = 0.2)
+      PARAMETER (DR = 0.2, DT = 0.2)
+      PARAMETER (MAXPTN=400001)
+      PARAMETER (MAXSTR=150001)
+      DOUBLE PRECISION  PXSGS,PYSGS,PZSGS,PESGS,PMSGS,
+     1     GXSGS,GYSGS,GZSGS,FTSGS
+      DIMENSION dyp2(50), DMYP2(200), DEYP2(50)
+      DIMENSION dyg2(50), DMYG2(200), DEYG2(50)
+      DIMENSION SNYP2(50), SMYP2(200), SEYP2(50)
+      DIMENSION SNYG2(50), SMYG2(200), SEYG2(50)
+      DIMENSION dnrpj2(50), dnrtg2(50), dnrin2(50),
+     &   dnrtt2(50)
+      DIMENSION dtpj2(50), dttg2(50), dtin2(50),
+     &   dttot2(50)
+      DIMENSION dyg2c(50), dmyg2c(50), deyg2c(50)
+      DIMENSION snrpj2(50), snrtg2(50), snrin2(50),
+     &   snrtt2(50)
+      DIMENSION stpj2(50), sttg2(50), stin2(50),
+     &   sttot2(50)
+      DIMENSION snyg2c(50), smyg2c(50), seyg2c(50)
+      DOUBLE PRECISION  ATAUI, ZT1, ZT2, ZT3
+      DOUBLE PRECISION  GX5, GY5, GZ5, FT5, PX5, PY5, PZ5, E5, XMASS5
+      COMMON /PARA1/ MUL
+cc      SAVE /PARA1/
+      COMMON/HPARNT/HIPR1(100),IHPR2(50),HINT1(100),IHNT2(50)
+cc      SAVE /HPARNT/
+      COMMON /SREC2/ATAUI(MAXSTR),ZT1(MAXSTR),ZT2(MAXSTR),ZT3(MAXSTR)
+cc      SAVE /SREC2/
+      COMMON/HJJET1/NPJ(300),KFPJ(300,500),PJPX(300,500),
+     &   PJPY(300,500),PJPZ(300,500),PJPE(300,500),
+     &   PJPM(300,500),NTJ(300),KFTJ(300,500),
+     &   PJTX(300,500),PJTY(300,500),PJTZ(300,500),
+     &   PJTE(300,500),PJTM(300,500)
+cc      SAVE /HJJET1/
+      COMMON/HJJET2/NSG,NJSG(MAXSTR),IASG(MAXSTR,3),K1SG(MAXSTR,100),
+     &   K2SG(MAXSTR,100),PXSG(MAXSTR,100),PYSG(MAXSTR,100),
+     &   PZSG(MAXSTR,100),PESG(MAXSTR,100),PMSG(MAXSTR,100)
+cc      SAVE /HJJET2/
+      COMMON /prec2/GX5(MAXPTN),GY5(MAXPTN),GZ5(MAXPTN),FT5(MAXPTN),
+     &   PX5(MAXPTN), PY5(MAXPTN), PZ5(MAXPTN), E5(MAXPTN),
+     &   XMASS5(MAXPTN), ITYP5(MAXPTN)
+cc      SAVE /prec2/
+      COMMON /AREVT/ IAEVT, IARUN, MISS
+cc      SAVE /AREVT/
+      COMMON /AROUT/ IOUT
+cc      SAVE /AROUT/
+      common/anim/nevent,isoft,isflag,izpc
+cc      SAVE /anim/
+      COMMON/SOFT/PXSGS(MAXSTR,3),PYSGS(MAXSTR,3),PZSGS(MAXSTR,3),
+     &     PESGS(MAXSTR,3),PMSGS(MAXSTR,3),GXSGS(MAXSTR,3),
+     &     GYSGS(MAXSTR,3),GZSGS(MAXSTR,3),FTSGS(MAXSTR,3),
+     &     K1SGS(MAXSTR,3),K2SGS(MAXSTR,3),NJSGS(MAXSTR)
+cc      SAVE /SOFT/
+      SAVE   
+      DATA IW/0/
+
+      IF (isevt .EQ. IAEVT .AND. isrun .EQ. IARUN) THEN
+         DO 1001 I = 1, 200
+            DMYP2(I) = SMYP2(I)
+            DMYG2(I) = SMYG2(I)
+ 1001    CONTINUE
+
+         DO 1002 I = 1, 50
+            dyp2(I) = SNYP2(I)
+            DEYP2(I) = SEYP2(I)
+            dyg2(I) = SNYG2(I)
+            DEYG2(I) = SEYG2(I)
+            dnrpj2(I) = snrpj2(I)
+            dnrtg2(I) = snrtg2(I)
+            dnrin2(I) = snrin2(I)
+            dnrtt2(I) = snrtt2(I)
+            dtpj2(I) = stpj2(I)
+            dttg2(I) = sttg2(I)
+            dtin2(I) = stin2(I)
+            dttot2(I) = sttot2(I)
+            dyg2c(I) = snyg2c(I)
+            dmyg2c(I) = smyg2c(I)
+            deyg2c(I) = seyg2c(I)
+ 1002    CONTINUE
+         nsubp = nsubpS
+         nsubg = nsubgS
+         NISG = NISGS
+      ELSE
+         DO 1003 I = 1, 200
+            SMYP2(I) = DMYP2(I)
+            SMYG2(I) = DMYG2(I)
+ 1003    CONTINUE
+
+         DO 1004 I = 1, 50
+            SNYP2(I) = dyp2(I)
+            SEYP2(I) = DEYP2(I)
+            SNYG2(I) = dyg2(I)
+            SEYG2(I) = DEYG2(I)
+            snrpj2(I) = dnrpj2(I)
+            snrtg2(I) = dnrtg2(I)
+            snrin2(I) = dnrin2(I)
+            snrtt2(I) = dnrtt2(I)
+            stpj2(I) = dtpj2(I)
+            sttg2(I) = dttg2(I)
+            stin2(I) = dtin2(I)
+            sttot2(I) = dttot2(I)
+            snyg2c(I) = dyg2c(I)
+            smyg2c(I) = dmyg2c(I)
+            seyg2c(I) = deyg2c(I)
+ 1004    CONTINUE
+         nsubpS = nsubp
+         nsubgS = nsubg
+         NISGS = NISG
+         isevt = IAEVT
+         isrun = IARUN
+         IW = IW + 1
+      END IF
+
+clin-4/28/01:
+      if(isoft.eq.3.or.isoft.eq.4.or.isoft.eq.5) goto 510
+
+c.....analysis
+      DO 1006 I = 1, IHNT2(1)
+         DO 1005 J = 1, NPJ(I)
+            ITYP = KFPJ(I, J)
+            PX = PJPX(I, J)
+            PY = PJPY(I, J)
+            PZ = PJPZ(I, J)
+            PE = PJPE(I, J)
+            PM = PJPM(I, J)
+cbzdbg2/16/99
+c            IF (ABS(PZ) .GE. PE) GOTO 200
+            IF (ABS(PZ) .GE. PE) THEN
+               PRINT *, ' IN HJANA2, PROJ STR ', I, ' PART ', J
+               PRINT *, ' FLAV = ', ITYP, ' PX = ', PX, ' PY = ', PY
+               PRINT *, ' PZ = ', PZ, ' EE = ', PE
+               PRINT *, ' XM = ', PM
+               GOTO 200
+            END IF
+cbzdbg2/16/99end
+            RAP = 0.5 * LOG((PE + PZ) / (PE - PZ))
+            XMT = SQRT(PX ** 2 + PY ** 2 + PM ** 2)
+            DXMT = XMT - PM
+            IY = 1 + int(ABS(RAP) / DY)
+            IF (IY .GT. 50) GOTO 100
+            dyp2(IY) = dyp2(IY) + 1.0
+            DEYP2(IY) = DEYP2(IY) + XMT
+            IF (ITYP .EQ. 21) THEN
+               dyg2(IY) = dyg2(IY) + 1.0
+               DEYG2(IY) = DEYG2(IY) + XMT
+            END IF
+ 100        CONTINUE
+            IF (RAP .GT. YMAX .OR. RAP .LE. YMIN) GOTO 200
+            IMT = 1 + int(DXMT / DMT)
+            IF (IMT .GT. 200) GOTO 200
+            DMYP2(IMT) = DMYP2(IMT) + 1.0 / XMT
+            IF (ITYP .EQ. 21) THEN
+               DMYG2(IMT) = DMYG2(IMT) + 1.0 / XMT
+            END IF
+ 200        CONTINUE
+ 1005    CONTINUE
+ 1006 CONTINUE
+
+      DO 1008 I = 1, IHNT2(3)
+         DO 1007 J = 1, NTJ(I)
+            ITYP = KFTJ(I, J)
+            PX = PJTX(I, J)
+            PY = PJTY(I, J)
+            PZ = PJTZ(I, J)
+            PE = PJTE(I, J)
+            PM = PJTM(I, J)
+cbzdbg2/16/99
+c            IF (ABS(PZ) .GE. PE) GOTO 400
+            IF (ABS(PZ) .GE. PE) THEN
+               PRINT *, ' IN HJANA2, TARG STR ', I, ' PART ', J
+               PRINT *, ' FLAV = ', ITYP, ' PX = ', PX, ' PY = ', PY
+               PRINT *, ' PZ = ', PZ, ' EE = ', PE
+               PRINT *, ' XM = ', PM
+               GOTO 400
+            END IF
+cbzdbg2/16/99end
+            RAP = 0.5 * LOG((PE + PZ) / (PE - PZ))
+            XMT = SQRT(PX ** 2 + PY ** 2 + PM ** 2)
+            DXMT = XMT - PM
+            IY = 1 + int(ABS(RAP) / DY)
+            IF (IY .GT. 50) GOTO 300
+            dyp2(IY) = dyp2(IY) + 1.0
+            DEYP2(IY) = DEYP2(IY) + XMT
+            IF (ITYP .EQ. 21) THEN
+               dyg2(IY) = dyg2(IY) + 1.0
+               DEYG2(IY) = DEYG2(IY) + XMT
+            END IF
+ 300        CONTINUE
+            IF (RAP .GT. YMAX .OR. RAP .LE. YMIN) GOTO 400
+            IMT = 1 + int(DXMT / DMT)
+            IF (IMT .GT. 200) GOTO 400
+            DMYP2(IMT) = DMYP2(IMT) + 1.0 / XMT
+            IF (ITYP .EQ. 21) THEN
+               DMYG2(IMT) = DMYG2(IMT) + 1.0 / XMT
+            END IF
+ 400        CONTINUE
+ 1007    CONTINUE
+ 1008 CONTINUE
+
+clin-4/28/01:
+ 510  continue
+
+      DO 1010 I = 1, NSG
+clin-4/25/01 soft3:
+c         DO J = 1, NJSG(I)
+         NJ=NJSG(I)
+         if(isoft.eq.3.or.isoft.eq.4.or.isoft.eq.5) NJ=NJSGS(I)
+         DO 1009 J = 1, NJ
+clin-4/25/01-end
+
+            ITYP = K2SG(I, J)
+            PX = PXSG(I, J)
+            PY = PYSG(I, J)
+            PZ = PZSG(I, J)
+            PE = PESG(I, J)
+            PM = PMSG(I, J)
+clin-4/25/01 soft3:
+            if(isoft.eq.3.or.isoft.eq.4.or.isoft.eq.5) then
+               ITYP = K2SGS(I, J)
+               PX = sngl(PXSGS(I, J))
+               PY = sngl(PYSGS(I, J))
+               PZ = sngl(PZSGS(I, J))
+               PE = sngl(PESGS(I, J))
+               PM = sngl(PMSGS(I, J))
+            endif
+clin-4/25/01-end
+
+cbzdbg2/16/99
+c            IF (ABS(PZ) .GE. PE) GOTO 600
+            IF (ABS(PZ) .GE. PE) THEN
+               PRINT *, ' IN HJANA2, INDP STR ', I, ' PART ', J
+               PRINT *, ' FLAV = ', ITYP, ' PX = ', PX, ' PY = ', PY
+               PRINT *, ' PZ = ', PZ, ' EE = ', PE
+               PRINT *, ' XM = ', PM
+               GOTO 600
+            END IF
+cbzdbg2/16/99end
+            RAP = 0.5 * LOG((PE + PZ) / (PE - PZ))
+            XMT = SQRT(PX ** 2 + PY ** 2 + PM ** 2)
+            DXMT = XMT - PM
+            IY = 1 + int(ABS(RAP) / DY)
+            IF (IY .GT. 50) GOTO 500
+            dyp2(IY) = dyp2(IY) + 1.0
+            DEYP2(IY) = DEYP2(IY) + XMT
+            IF (ITYP .EQ. 21) THEN
+               dyg2(IY) = dyg2(IY) + 1.0
+               DEYG2(IY) = DEYG2(IY) + XMT
+            END IF
+ 500        CONTINUE
+            IF (RAP .GT. YMAX .OR. RAP .LE. YMIN) GOTO 600
+            IMT = 1 + int(DXMT / DMT)
+            IF (IMT .GT. 200) GOTO 600
+            DMYP2(IMT) = DMYP2(IMT) + 1.0 / XMT
+            IF (ITYP .EQ. 21) THEN
+               DMYG2(IMT) = DMYG2(IMT) + 1.0 / XMT
+            END IF
+ 600        CONTINUE
+ 1009    CONTINUE
+ 1010 CONTINUE
+
+clin-4/28/01:
+      if(isoft.eq.3.or.isoft.eq.4.or.isoft.eq.5) goto 520
+
+      DO 1011 I = 1, IHNT2(1)
+         J = I
+         YR = SQRT(sngl(ZT1(J) ** 2 + ZT2(J) ** 2))
+         IR = 1 + int(YR / DR)
+         IF (IR .GT. 50 .or. IR .LT. 1) GOTO 601
+         dnrpj2(IR) = dnrpj2(IR) + 1.0
+         dnrtt2(IR) = dnrtt2(IR) + 1.0
+ 601     CONTINUE
+         IT = 1 + int(sngl(ATAUI(J)) / DT)
+         IF (IT .GT. 50 .or. IT .LT. 1) GOTO 602
+         dtpj2(IT) = dtpj2(IT) + 1.0
+         dttot2(IT) = dttot2(IT) + 1.0
+ 602     CONTINUE
+ 1011 CONTINUE
+
+      DO 1012 I = 1, IHNT2(3)
+         J = I + IHNT2(1)
+         YR = SQRT(sngl(ZT1(J) ** 2 + ZT2(J) ** 2))
+         IR = 1 + int(YR / DR)
+         IF (IR .GT. 50 .or. IR .LT. 1) GOTO 603
+         dnrtg2(IR) = dnrtg2(IR) + 1.0
+         dnrtt2(IR) = dnrtt2(IR) + 1.0
+ 603     CONTINUE
+         IT = 1 + int(sngl(ATAUI(J)) / DT)
+         IF (IT .GT. 50 .or. IT .LT. 1) GOTO 604
+         dttg2(IT) = dttg2(IT) + 1.0
+         dttot2(IT) = dttot2(IT) + 1.0
+ 604     CONTINUE
+ 1012 CONTINUE
+
+clin-4/28/01:
+ 520  continue
+
+      DO 1013 I = 1, NSG
+         J = I + IHNT2(1) + IHNT2(3)
+clin-4/28/01:
+         if(isoft.eq.3.or.isoft.eq.4.or.isoft.eq.5) J = I
+
+         YR = SQRT(sngl(ZT1(J) ** 2 + ZT2(J) ** 2))
+         IR = 1 + int(YR / DR)
+         IF (IR .GT. 50 .or. IR .LT. 1) GOTO 605
+         dnrin2(IR) = dnrin2(IR) + 1.0
+         dnrtt2(IR) = dnrtt2(IR) + 1.0
+ 605     CONTINUE
+         IT = 1 + int(sngl(ATAUI(J)) / DT)
+         IF (IT .GT. 50 .or. IT .LT. 1) GOTO 606
+         dtin2(IT) = dtin2(IT) + 1.0
+         dttot2(IT) = dttot2(IT) + 1.0
+ 606     CONTINUE
+ 1013 CONTINUE
+
+      DO 1014 I = 1, MUL
+         ITYP = ITYP5(I)
+         PX = sngl(PX5(I))
+         PY = sngl(PY5(I))
+         PZ = sngl(PZ5(I))
+         PE = sngl(E5(I))
+         PM = sngl(XMASS5(I))
+cbzdbg2/16/99
+c            IF (ABS(PZ) .GE. PE) GOTO 800
+         
+         IF (ABS(PZ) .GE. PE) THEN
+            PRINT *, ' IN HJANA2, GLUON ', I
+            PRINT *, ' FLAV = ', ITYP, ' PX = ', PX, ' PY = ', PY
+            PRINT *, ' PZ = ', PZ, ' EE = ', PE
+            PRINT *, ' XM = ', PM
+            GOTO 800
+         END IF
+         
+cbzdbg2/16/99end
+         RAP = 0.5 * LOG((PE + PZ) / (PE - PZ))
+         XMT = SQRT(PX ** 2 + PY ** 2 + PM ** 2)
+         DXMT = XMT - PM
+         IY = 1 + int(ABS(RAP) / DY)
+         IF (IY .GT. 50) GOTO 700
+         dyg2c(IY) = dyg2c(IY) + 1.0
+         deyg2c(IY) = deyg2c(IY) + XMT
+ 700     CONTINUE
+         IF (RAP .GT. YMAX .OR. RAP .LE. YMIN) GOTO 800
+         IMT = 1 + int(DXMT / DMT)
+         IF (IMT .GT. 50) GOTO 800
+         dmyg2c(IMT) = dmyg2c(IMT) + 1.0 / XMT
+ 800     CONTINUE
+ 1014 CONTINUE
+
+clin-4/25/01 soft3:
+      if(isoft.eq.3.or.isoft.eq.4.or.isoft.eq.5) goto 530
+
+c.....count number of particles
+      DO 1016 I = 1, IHNT2(1)
+         DO 1015 J = 1, NPJ(I)
+            nsubp = nsubp + 1
+            IF (KFPJ(I, J) .EQ. 21) nsubg = nsubg + 1
+ 1015    CONTINUE
+ 1016 CONTINUE
+
+      DO 1018 I = 1, IHNT2(3)
+         DO 1017 J = 1, NTJ(I)
+            nsubp = nsubp + 1
+            IF (KFTJ(I, J) .EQ. 21) nsubg = nsubg + 1
+ 1017    CONTINUE
+ 1018 CONTINUE
+
+clin-4/25/01 soft3:
+ 530  continue
+
+      DO 1020 I = 1, NSG
+clin-4/25/01 soft3:
+c         DO J = 1, NJSG(I)
+         NJ=NJSG(I)
+         if(isoft.eq.3.or.isoft.eq.4.or.isoft.eq.5) NJ=NJSGS(I)
+         DO 1019 J = 1, NJ
+clin-4/25/01-end
+
+            nsubp = nsubp + 1
+
+clin-4/25/01
+c            IF (K2SG(I, J) .EQ. 21) nsubg = nsubg + 1
+            if(isoft.eq.3.or.isoft.eq.4.or.isoft.eq.5) then
+               IF(K2SGS(I, J) .EQ. 21) nsubg = nsubg + 1
+            else
+               IF (K2SG(I, J) .EQ. 21) nsubg = nsubg + 1
+            endif
+clin-4/25/01-end
+ 1019    CONTINUE
+ 1020 CONTINUE
+cbzdbg2/16/99
+      NISG = NISG + NSG
+
+      IF (IOUT .EQ. 1) THEN
+cbzdbg2/16/99end
+cbzdbg2/16/99
+c      PRINT *, ' in HJANA2 '
+c      PRINT *, ' total number of partons = ', nsubp
+c      PRINT *, ' total number of gluons = ', nsubg, MUL
+c      PRINT *, ' number of projectile strings = ', IHNT2(1)
+c      PRINT *, ' number of target strings = ', IHNT2(3)
+c      PRINT *, ' number of independent strings = ', NSG
+      PRINT *, ' in HJANA2 '
+      PRINT *, ' total number of partons = ', nsubp / IW
+      PRINT *, ' total number of gluons = ', nsubg / IW
+c      PRINT *, ' number of projectile strings = ', IHNT2(1)
+c      PRINT *, ' number of target strings = ', IHNT2(3)
+      PRINT *, ' number of independent strings = ', NISG / IW
+      END IF
+
+      CALL HJAN2A
+      CALL HJAN2B
+
+      RETURN
+      END
+
+c-----------------------------------------------------------------------
+
+c.....subroutine called by HJANA2
+      SUBROUTINE HJAN2A
+
+      PARAMETER (DGX = 0.2, DGY = 0.2, DT = 0.2)
+      PARAMETER (MAXPTN=400001,MAXSTR=150001)
+      DIMENSION dgxp2a(50), dgyp2a(50), dtp2a(50)
+      DIMENSION dgxg2a(50), dgyg2a(50), dtg2a(50)
+      DIMENSION sgxp2a(50), sgyp2a(50), stp2a(50)
+      DIMENSION sgxg2a(50), sgyg2a(50), stg2a(50)
+      DOUBLE PRECISION  GX5, GY5, GZ5, FT5, PX5, PY5, PZ5, E5, XMASS5
+      COMMON /PARA1/ MUL
+cc      SAVE /PARA1/
+      COMMON /prec2/GX5(MAXPTN),GY5(MAXPTN),GZ5(MAXPTN),FT5(MAXPTN),
+     &   PX5(MAXPTN), PY5(MAXPTN), PZ5(MAXPTN), E5(MAXPTN),
+     &   XMASS5(MAXPTN), ITYP5(MAXPTN)
+cc      SAVE /prec2/
+      COMMON/HPARNT/HIPR1(100),IHPR2(50),HINT1(100),IHNT2(50)
+cc      SAVE /HPARNT/
+      COMMON/hjcrdn/YP(3,300),YT(3,300)
+cc      SAVE /hjcrdn/
+      COMMON/HJJET1/NPJ(300),KFPJ(300,500),PJPX(300,500),
+     &   PJPY(300,500),PJPZ(300,500),PJPE(300,500),
+     &   PJPM(300,500),NTJ(300),KFTJ(300,500),
+     &   PJTX(300,500),PJTY(300,500),PJTZ(300,500),
+     &   PJTE(300,500),PJTM(300,500)
+cc      SAVE /HJJET1/
+      COMMON/HJJET2/NSG,NJSG(MAXSTR),IASG(MAXSTR,3),K1SG(MAXSTR,100),
+     &   K2SG(MAXSTR,100),PXSG(MAXSTR,100),PYSG(MAXSTR,100),
+     &   PZSG(MAXSTR,100),PESG(MAXSTR,100),PMSG(MAXSTR,100)
+cc      SAVE /HJJET2/
+      COMMON /AREVT/ IAEVT, IARUN, MISS
+cc      SAVE /AREVT/
+      COMMON /AROUT/ IOUT
+cc      SAVE /AROUT/
+      SAVE   
+      DATA IW/0/
+
+      IF (isevt .EQ. IAEVT .AND. isrun .EQ. IARUN) THEN
+         DO 1001 I = 1, 50
+            dgxp2a(I) = sgxp2a(I)
+            dgyp2a(I) = sgyp2a(I)
+            dtp2a(I) = stp2a(I)
+            dgxg2a(I) = sgxg2a(I)
+            dgyg2a(I) = sgyg2a(I)
+            dtg2a(I) = stg2a(I)
+ 1001    CONTINUE
+      ELSE
+         DO 1002 I = 1, 50
+            sgxp2a(I) = dgxp2a(I)
+            sgyp2a(I) = dgyp2a(I)
+            stp2a(I) = dtp2a(I)
+            sgxg2a(I) = dgxg2a(I)
+            sgyg2a(I) = dgyg2a(I)
+            stg2a(I) = dtg2a(I)
+ 1002    CONTINUE
+         isevt = IAEVT
+         isrun = IARUN
+         IW = IW + 1
+      END IF
+c.....analysis
+      DO 1004 I = 1, IHNT2(1)
+         DO 1003 J = 1, NPJ(I)
+            IF (KFPJ(I, J) .NE. 21) THEN
+               IGX = 1 + int(ABS(YP(1, I)) / DGX)
+               IF (IGX .GT. 50 .or. IGX .LT. 1) GOTO 100
+               dgxp2a(IGX) = dgxp2a(IGX) + 1.0
+ 100           CONTINUE
+               IGY = 1 + int(ABS(YP(2, I)) / DGY)
+               IF (IGY .GT. 50 .or. IGY .LT. 1) GOTO 200
+               dgyp2a(IGY) = dgyp2a(IGY) + 1.0
+ 200           CONTINUE
+               IT = 1
+               dtp2a(IT) = dtp2a(IT) + 1.0
+            END IF
+ 1003    CONTINUE
+ 1004 CONTINUE
+
+      DO 1006 I = 1, IHNT2(3)
+         DO 1005 J = 1, NTJ(I)
+            IF (KFTJ(I, J) .NE. 21) THEN
+               IGX = 1 + int(ABS(YT(1, I)) / DGX)
+               IF (IGX .GT. 50 .or. IGX .LT. 1) GOTO 300
+               dgxp2a(IGX) = dgxp2a(IGX) + 1.0
+ 300           CONTINUE
+               IGY = 1 + int(ABS(YT(2, I)) / DGY)
+               IF (IGY .GT. 50 .or. IGY .LT. 1) GOTO 400
+               dgyp2a(IGY) = dgyp2a(IGY) + 1.0
+ 400           CONTINUE
+               IT = 1
+               dtp2a(IT) = dtp2a(IT) + 1.0
+            END IF
+ 1005    CONTINUE
+ 1006 CONTINUE
+
+      DO 1008 I = 1, NSG
+         DO 1007 J = 1, NJSG(I)
+            IF (K2SG(I, J) .NE. 21) THEN
+               IGX = 1 + int(ABS(0.5 * 
+     &            (YP(1, IASG(I, 1)) + YT(1, IASG(I, 2)))) / DGX)
+               IF (IGX .GT. 50 .or. IGX .LT. 1) GOTO 500
+               dgxp2a(IGX) = dgxp2a(IGX) + 1.0
+ 500           CONTINUE
+               IGY = 1 + int(ABS(0.5 * 
+     &            (YP(2, IASG(I, 1)) + YT(2, IASG(I, 2)))) / DGY)
+               IF (IGY .GT. 50 .or. IGY .LT. 1) GOTO 600
+               dgyp2a(IGY) = dgyp2a(IGY) + 1.0
+ 600           CONTINUE
+               IT = 1
+               dtp2a(IT) = dtp2a(IT) + 1.0               
+            END IF
+ 1007    CONTINUE
+ 1008 CONTINUE
+
+      DO 1009 I = 1, MUL
+         IGX = 1 + int(ABS(sngl(GX5(I))) / DGX)
+         IF (IGX .GT. 50 .or. IGX .LT. 1) GOTO 700
+         dgxg2a(IGX) = dgxg2a(IGX) + 1.0
+         dgxp2a(IGX) = dgxp2a(IGX) + 1.0
+ 700     CONTINUE
+         IGY = 1 + int(ABS(sngl(GY5(I))) / DGY)
+         IF (IGY .GT. 50 .or. IGY .LT. 1) GOTO 800
+         dgyg2a(IGY) = dgyg2a(IGY) + 1.0
+         dgyp2a(IGY) = dgyp2a(IGY) + 1.0
+ 800     CONTINUE
+         IT = 1 + int(SQRT(sngl(FT5(I) ** 2 - GZ5(I) ** 2)) / DT)
+         IF (IT .GT. 50 .or. IT .LT. 1) GOTO 900
+         dtg2a(IT) = dtg2a(IT) + 1.0
+         dtp2a(IT) = dtp2a(IT) + 1.0
+ 900     CONTINUE
+ 1009 CONTINUE
+c
+      RETURN
+      END
+
+c-----------------------------------------------------------------------
+
+c.....analysis subroutine in HJANA2
+
+      SUBROUTINE HJAN2B
+
+      PARAMETER (MAXPTN=400001)
+      PARAMETER (MAXSTR=150001)
+      PARAMETER (DR = 0.2, DT = 0.2)
+      DIMENSION DNRG2B(50), dtg2b(-24:25)
+      DIMENSION SNRG2B(50), stg2b(-24:25)
+      DOUBLE PRECISION  GX5, GY5, GZ5, FT5, PX5, PY5, PZ5, E5, XMASS5
+      DOUBLE PRECISION  ATAUI, ZT1, ZT2, ZT3
+      COMMON /PARA1/ MUL
+cc      SAVE /PARA1/
+      COMMON /prec2/GX5(MAXPTN),GY5(MAXPTN),GZ5(MAXPTN),FT5(MAXPTN),
+     &   PX5(MAXPTN), PY5(MAXPTN), PZ5(MAXPTN), E5(MAXPTN),
+     &   XMASS5(MAXPTN), ITYP5(MAXPTN)
+cc      SAVE /prec2/
+      COMMON /ilist8/ LSTRG1(MAXPTN), LPART1(MAXPTN)
+cc      SAVE /ilist8/
+      COMMON /SREC1/ NSP, NST, NSI
+cc      SAVE /SREC1/
+      COMMON /SREC2/ATAUI(MAXSTR),ZT1(MAXSTR),ZT2(MAXSTR),ZT3(MAXSTR)
+cc      SAVE /SREC2/
+      COMMON/hjcrdn/YP(3,300),YT(3,300)
+cc      SAVE /hjcrdn/
+      COMMON/HJJET2/NSG,NJSG(MAXSTR),IASG(MAXSTR,3),K1SG(MAXSTR,100),
+     &   K2SG(MAXSTR,100),PXSG(MAXSTR,100),PYSG(MAXSTR,100),
+     &   PZSG(MAXSTR,100),PESG(MAXSTR,100),PMSG(MAXSTR,100)
+cc      SAVE /HJJET2/
+      COMMON /AREVT/ IAEVT, IARUN, MISS
+cc      SAVE /AREVT/
+      COMMON /AROUT/ IOUT
+cc      SAVE /AROUT/
+      SAVE   
+      DATA IW/0/
+
+      IF (isevt .EQ. IAEVT .AND. isrun .EQ. IARUN) THEN
+         DO 1001 I = 1, 50
+            DNRG2B(I) = SNRG2B(I)
+            dtg2b(I - 25) = stg2b(I - 25)
+ 1001    CONTINUE
+      ELSE
+         DO 1002 I = 1, 50
+            SNRG2B(I) = DNRG2B(I)
+            stg2b(I - 25) = dtg2b(I - 25)
+ 1002    CONTINUE
+         isevt = IAEVT
+         isrun = IARUN
+         IW = IW + 1
+      END IF
+c.....analysis
+      DO 1003 I = 1, MUL
+         J = LSTRG1(I)
+         GX0 = sngl(ZT1(J))
+         GY0 = sngl(ZT2(J))
+         R0 = SQRT((sngl(GX5(I)) - GX0)**2 + (sngl(GY5(I)) - GY0)**2)
+         IR = 1 + int(R0 / DR)
+         IF (IR .GT. 50 .or. IR .LT. 1) GOTO 100
+         DNRG2B(IR) = DNRG2B(IR) + 1.0
+ 100     CONTINUE
+         TAU7 = SQRT(sngl(FT5(I) ** 2 - GZ5(I) ** 2))
+         DTAU=TAU7 - sngl(ATAUI(J))
+         IT = 1 + int(DTAU / DT)
+cbzdbg2/21/99
+c         IF (ABS(IT) .GT. 25) GOTO 200
+         IF (IT .GT. 25 .OR. IT .LT. -24) GOTO 200
+cbzdbg2/21/99end
+         dtg2b(IT) = dtg2b(IT) + 1.0
+ 200     CONTINUE
+ 1003 CONTINUE
+c
+      RETURN
+      END
+
+c-----------------------------------------------------------------------
+
+c.....analysis subroutine before ARTMN
+      SUBROUTINE HJANA3
+c
+      PARAMETER (MAXSTR=150001, MAXR=1)
+c.....y cut for mt spectrum
+      PARAMETER (YMIN = -1.0, YMAX = 1.0)
+cbz11/7/99 end
+c.....bin width for mt spectrum and y spectrum
+      PARAMETER (DMT = 0.05, DY = 0.2)
+      DOUBLE PRECISION v2i,eti,xmulti,v2mi,s2mi,xmmult,
+     1     v2bi,s2bi,xbmult
+      DIMENSION dndyh3(50), DMYH3(50), DEYH3(50)
+      COMMON /RUN/ NUM
+cc      SAVE /RUN/
+      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/
+      COMMON /AROUT/ IOUT
+cc      SAVE /AROUT/
+      COMMON/iflow/v2i,eti,xmulti,v2mi,s2mi,xmmult,v2bi,s2bi,xbmult
+cc      SAVE /iflow/
+      SAVE   
+      DATA IW/0/
+
+      IW = IW + 1
+      DO 1002 J = 1, NUM
+         DO 1001 I = 1, MULTI1(J)
+            ITYP = ITYP1(I, J)
+            IF (ITYP .GT. -100 .AND. ITYP .LT. 100) GOTO 200
+            PX = PX1(I, J)
+            PY = PY1(I, J)
+            PZ = PZ1(I, J)
+            EE = EE1(I, J)
+            XM = XM1(I, J)
+            XMT = SQRT(PX ** 2 + PY ** 2 + XM ** 2)
+            IF (ABS(PZ) .GE. EE) THEN
+               PRINT *, 'IN HJANA3'
+               PRINT *, ' PARTICLE ', I, ' RUN ', J, 'PREC ERR'
+               PRINT *, ' FLAV = ', ITYP, ' PX = ', PX, ' PY = ', PY
+               PRINT *, ' PZ = ', PZ, ' EE = ', EE
+               PRINT *, ' XM = ', XM
+               GOTO 200
+            END IF
+            DXMT = XMT - XM
+            Y = 0.5 * LOG((EE + PZ) / (EE - PZ))
+c.....rapidity cut for the rapidity distribution
+c            IY = 1 + int(ABS(Y) / DY)
+            IY = 1 + int((Y+10.) / DY)
+            IF (IY .GT. 50) GOTO 100
+            dndyh3(IY) = dndyh3(IY) + 1.0
+            DEYH3(IY) = DEYH3(IY) + XMT
+ 100        CONTINUE
+c.....insert rapidity cut for mt spectrum here
+            IF (Y. LT. YMIN .OR. Y .GE. YMAX) GOTO 200
+            IMT = 1 + int(DXMT / DMT)
+            IF (IMT .GT. 50) GOTO 200
+            DMYH3(IMT) = DMYH3(IMT) + 1.0 / XMT
+ 200        CONTINUE
+ 1001    CONTINUE
+ 1002 CONTINUE
+c
+      RETURN
+      END
+
+c-----------------------------------------------------------------------
+
+c.....analysis subroutine after ARTMN
+      SUBROUTINE HJANA4
+      PARAMETER (MAXSTR=150001, MAXR=1)
+c.....y cut for mt spectrum
+cbz11/7/99
+c      PARAMETER (YMIN = -0.5, YMAX = 0.5)
+      PARAMETER (YMIN = -1.0, YMAX = 1.0)
+cbz11/7/99 end
+c.....bin width for mt spectrum and y spectrum
+      PARAMETER (DMT = 0.05, DY = 0.2)
+
+      DIMENSION dndyh4(50), DMYH4(50), DEYH4(50)
+      COMMON /RUN/ NUM
+cc      SAVE /RUN/
+      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/
+      COMMON /AROUT/ IOUT
+cc      SAVE /AROUT/
+      COMMON /fflow/ v2f,etf,xmultf,v2fpi,xmulpi
+cc      SAVE /fflow/
+      SAVE   
+      DATA IW/0/
+
+      IW = IW + 1
+      DO 1002 J = 1, NUM
+         DO 1001 I = 1, MULTI1(J)
+            ITYP = ITYP1(I, J)
+            IF (ITYP .GT. -100 .AND. ITYP .LT. 100) GOTO 200
+            PX = PX1(I, J)
+            PY = PY1(I, J)
+            PZ = PZ1(I, J)
+            EE = EE1(I, J)
+            XM = XM1(I, J)
+            XMT = SQRT(PX ** 2 + PY ** 2 + XM ** 2)
+            IF (ABS(PZ) .GE. EE) THEN
+               PRINT *, 'IN HJANA4'
+               PRINT *, ' PARTICLE ', I, ' RUN ', J, 'PREC ERR'
+               PRINT *, ' FLAV = ', ITYP, ' PX = ', PX, ' PY = ', PY
+               PRINT *, ' PZ = ', PZ, ' EE = ', EE
+               PRINT *, ' XM = ', XM
+               GOTO 200
+            END IF
+            DXMT = XMT - XM
+            Y = 0.5 * LOG((EE + PZ) / (EE - PZ))
+c.....rapidity cut for the rapidity distribution
+c            IY = 1 + int(ABS(Y) / DY)
+            IY = 1 + int((Y+10.) / DY)
+            IF (IY .GT. 50) GOTO 100
+            dndyh4(IY) = dndyh4(IY) + 1.0
+            DEYH4(IY) = DEYH4(IY) + XMT
+ 100        CONTINUE
+c.....insert rapidity cut for mt spectrum here
+            IF (Y. LT. YMIN .OR. Y .GE. YMAX) GOTO 200
+            IMT = 1 + int(DXMT / DMT)
+            IF (IMT .GT. 50) GOTO 200
+            DMYH4(IMT) = DMYH4(IMT) + 1.0 / XMT
+ 200        CONTINUE
+ 1001    CONTINUE
+ 1002 CONTINUE
+c
+      RETURN
+      END
+
+c=======================================================================
+
+c.....subroutine to get average values for different strings
+
+      SUBROUTINE zpstrg
+
+      IMPLICIT DOUBLE PRECISION (A-H, O-Z)
+      PARAMETER (MAXPTN=400001)
+      PARAMETER (MAXSTR=150001)
+c      REAL*4 YP, YT, PXSG, PYSG, PZSG, PESG, PMSG, HIPR1, HINT1, BB
+      REAL YP, YT, PXSG, PYSG, PZSG, PESG, PMSG, HIPR1, HINT1, BB
+
+      COMMON /PARA1/ MUL
+cc      SAVE /PARA1/
+      COMMON /prec2/GX5(MAXPTN),GY5(MAXPTN),GZ5(MAXPTN),FT5(MAXPTN),
+     &   PX5(MAXPTN), PY5(MAXPTN), PZ5(MAXPTN), E5(MAXPTN),
+     &   XMASS5(MAXPTN), ITYP5(MAXPTN)
+cc      SAVE /prec2/
+      COMMON /ilist8/ LSTRG1(MAXPTN), LPART1(MAXPTN)
+cc      SAVE /ilist8/
+      COMMON /SREC1/ NSP, NST, NSI
+cc      SAVE /SREC1/
+      COMMON /SREC2/ATAUI(MAXSTR),ZT1(MAXSTR),ZT2(MAXSTR),ZT3(MAXSTR)
+cc      SAVE /SREC2/
+      COMMON/hjcrdn/YP(3,300),YT(3,300)
+cc      SAVE /hjcrdn/
+      COMMON/HJJET2/NSG,NJSG(MAXSTR),IASG(MAXSTR,3),K1SG(MAXSTR,100),
+     &   K2SG(MAXSTR,100),PXSG(MAXSTR,100),PYSG(MAXSTR,100),
+     &   PZSG(MAXSTR,100),PESG(MAXSTR,100),PMSG(MAXSTR,100)
+cc      SAVE /HJJET2/
+cbz6/28/99 flow1
+      COMMON/HPARNT/HIPR1(100),IHPR2(50),HINT1(100),IHNT2(50)
+cc      SAVE /HPARNT/
+cbz6/28/99 flow1 end
+      common/anim/nevent,isoft,isflag,izpc
+cc      SAVE /anim/
+      common/strg/np(maxstr)
+cc      SAVE /strg/
+clin-6/06/02 test local freezeout:
+      common /frzprc/ 
+     &     gxfrz(MAXPTN), gyfrz(MAXPTN), gzfrz(MAXPTN), ftfrz(MAXPTN),
+     &     pxfrz(MAXPTN), pyfrz(MAXPTN), pzfrz(MAXPTN), efrz(MAXPTN),
+     &     xmfrz(MAXPTN), 
+     &     tfrz(302), ifrz(MAXPTN), idfrz(MAXPTN), itlast
+cc      SAVE /frzprc/
+      SAVE   
+
+clin-6/06/02 test local freezeout for string melting,
+c     use space-time values at local freezeout saved in /frzprc/:
+      if(isoft.eq.5) then
+         do 1001 I = 1, MUL
+            ITYP5(i)=idfrz(i)
+            GX5(i)=gxfrz(i)
+            GY5(i)=gyfrz(i)
+            GZ5(i)=gzfrz(i)
+            FT5(i)=ftfrz(i)
+            PX5(i)=pxfrz(i)
+            PY5(i)=pyfrz(i)
+            PZ5(i)=pzfrz(i)
+            E5(i)=efrz(i)
+            XMASS5(i)=xmfrz(i)
+ 1001    continue
+      endif
+clin-6/06/02-end
+
+      DO 1002 I = 1, MAXSTR
+         ATAUI(I) = 0d0
+         ZT1(I) = 0d0
+         ZT2(I) = 0d0
+clin-4/25/03 add zt3(I) to track longitudinal positions of partons/strings:
+         ZT3(I) = 0d0
+         NP(I) = 0
+ 1002 CONTINUE
+      DO 1003 I = 1, MUL
+         ISTRG = LSTRG1(I)
+         TAU7 = SQRT(FT5(I) ** 2 - GZ5(I) ** 2)
+         ATAUI(ISTRG) = ATAUI(ISTRG) + TAU7
+         ZT1(ISTRG) = ZT1(ISTRG) + GX5(I)
+         ZT2(ISTRG) = ZT2(ISTRG) + GY5(I)
+         ZT3(ISTRG) = ZT3(ISTRG) + GZ5(I)
+         NP(ISTRG) = NP(ISTRG) + 1
+ 1003 CONTINUE
+      
+      NSTR = NSP + NST + NSI
+
+clin-7/03/01 correct averaging on transverse coordinates, no shift needed:
+      if(isoft.eq.3.or.isoft.eq.4.or.isoft.eq.5) then
+         DO 1004 I = 1, NSTR
+            IF (NP(I) .NE. 0) THEN
+               ATAUI(I) = ATAUI(I) / NP(I)
+               ZT1(I) = ZT1(I) / NP(I)
+               ZT2(I) = ZT2(I) / NP(I)
+               ZT3(I) = ZT3(I) / NP(I)
+            ENDIF
+ 1004    CONTINUE
+         return
+      endif
+clin-7/03/01-end
+
+      DO 1005 I = 1, NSTR
+         IF (NP(I) .NE. 0) THEN
+            ATAUI(I) = ATAUI(I) / NP(I)
+            ZT1(I) = ZT1(I) / NP(I)
+            ZT2(I) = ZT2(I) / NP(I)
+            ZT3(I) = ZT3(I) / NP(I)
+         ELSE
+            IF (I .LE. NSP) THEN
+               J = I
+               ZT1(I) = dble(YP(1, J))
+               ZT2(I) = dble(YP(2, J))
+               ZT3(I) = 0d0
+            ELSE IF (I .GT. NSP .AND. I .LE. NSP + NST) THEN
+               J = I - NSP
+               ZT1(I) = dble(YT(1, J))
+               ZT2(I) = dble(YT(2, J))
+               ZT3(I) = 0d0
+            ELSE
+               J = I - NSP - NST
+               ZT1(I) = 0.5d0*
+     1              dble((YP(1, IASG(J, 1)) + YT(1, IASG(J, 2))))
+               ZT2(I) = 0.5d0 *
+     1              dble((YP(2, IASG(J, 1)) + YT(2, IASG(J, 2))))
+               ZT3(I) = 0d0
+            END IF
+         END IF
+ 1005 CONTINUE
+
+cbz6/28/99 flow1
+      BB = HINT1(19)
+      DO 1006 I = 1, NSTR
+         IF (NP(I).NE.0) THEN
+            SHIFT=0d0
+         ELSE
+            SHIFT=0.5d0*dble(BB)
+         END IF
+         IF (I .LE. NSP) THEN
+            ZT1(I) = ZT1(I) + SHIFT
+         ELSE IF (I .GT. NSP .AND. I .LE. NSP + NST) THEN
+            ZT1(I) = ZT1(I) - SHIFT
+         END IF
+ 1006 CONTINUE
+cbz6/28/99 flow1 end
+c
+      RETURN
+      END
+
+clin-3/2009
+c     Initialize hadron weights; 
+c     Can add initial hadrons before the hadron cascade starts (but after ZPC).
+      subroutine addhad
+      PARAMETER (MAXSTR=150001,MAXR=1,xmd=1.8756)
+      double precision  smearp,smearh
+      COMMON /ARPRNT/ ARPAR1(100), IAPAR2(50), ARINT1(100), IAINT2(50)
+      COMMON /ARPRC/ ITYPAR(MAXSTR),
+     &     GXAR(MAXSTR), GYAR(MAXSTR), GZAR(MAXSTR), FTAR(MAXSTR),
+     &     PXAR(MAXSTR), PYAR(MAXSTR), PZAR(MAXSTR), PEAR(MAXSTR),
+     &     XMAR(MAXSTR)
+      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 /smearz/smearp,smearh
+      COMMON/RNDF77/NSEED
+      common /para8/ idpert,npertd,idxsec
+      SAVE   
+c     All hadrons at the start of hadron cascade have the weight of 1
+c     except those inserted by the user in this subroutine:
+      np0=IAINT2(1)
+      DO i=1,np0
+         dpertp(I)=1.
+      ENDDO
+c     Specify number, species, weight, initial x,p,m for inserted hadrons here:
+      nadd=0
+      tau0=ARPAR1(1)
+      DO 100 i=np0+1,np0+nadd
+         ITYPAR(I)=42
+         dpertp(I)=1d0/dble(nadd)
+         GXAR(I)=5.*(1.-2.*RANART(NSEED))
+         GYAR(I)=5.*(1.-2.*RANART(NSEED))
+         GZAR(I)=2.*(1.-2.*RANART(NSEED))
+         FTAR(I)=0.
+         PXAR(I)=1.
+         PYAR(I)=0.
+         PZAR(I)=1.
+         XMAR(I)=xmd
+c
+         PEAR(I)=sqrt(PXAR(I)**2+PYAR(I)**2+PZAR(I)**2+XMAR(I)**2)
+         RAP=0.5*alog((PEAR(I)+PZAR(I))/(PEAR(I)-PZAR(I)))
+         VX=PXAR(I)/PEAR(I)
+         VY=PYAR(I)/PEAR(I)
+c.....give initial formation time shift and boost according to rapidity:
+         TAUI=FTAR(I)+TAU0
+         FTAR(I)=TAUI*COSH(RAP)
+         GXAR(I)=GXAR(I)+VX*TAU0*COSH(RAP)
+         GYAR(I)=GYAR(I)+VY*TAU0*COSH(RAP)
+c     Allow the intial z-position to be different from the Bjorken picture:
+         GZAR(I)=TAUI*SINH(RAP)+GZAR(I)
+c         GZAR(I)=TAUI*SINH(RAP)
+         zsmear=sngl(smearh)*(2.*RANART(NSEED)-1.)
+         GZAR(I)=GZAR(I)+zsmear
+ 100  CONTINUE
+      IAINT2(1)=IAINT2(1)+nadd
+c
+      if(nadd.ge.1.and.idpert.ne.1.and.idpert.ne.2) then
+         write(16,*) 'IDPERT must be 1 or 2 to add initial hadrons,
+     1 set NPERTD to 0 if you do not need perturbative deuterons'
+         stop
+      endif
+      if(IAINT2(1).gt.MAXSTR) then
+         write(16,*) 'Too many initial hadrons, array size is exceeded!'
+         stop
+      endif
+c
+      return
+      end
diff --git a/TAmpt/AMPT/art1f.f b/TAmpt/AMPT/art1f.f
new file mode 100644 (file)
index 0000000..f2c06f2
--- /dev/null
@@ -0,0 +1,22539 @@
+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
+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
+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:
+            IF(E(I1).EQ.0.)GO TO 800
+
+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
+            IF (LB(I1) .LT. -45 .OR. LB(I1) .GT. 45) GOTO 800
+            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) 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)
+          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.
+          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) 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
+                call resdec(i1,nt,nnn,wid,idecay)
+                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
+                   wid=7.36e-17
+                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)
+                call resdec(i1,nt,nnn,wid,idecay)
+                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
+
+* negelecting the Pauli blocking at high energies
+ 9000        go to 800
+          ENDIF
+* LOOP OVER ALL PSEUDOPARTICLES 2 IN THE SAME RUN
+* SAVE ALL THE COORDINATES FOR POSSIBLE CHANGE IN THE FOLLOWING COLLISION
+ 1        if(nt.eq.ntmax)go to 800
+          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
+            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)