AMPTInterface/src/hijing1.383_ampt.f

0001 c.................... hijing1.383_ampt.f
0002 c     Version 1.383
0003 c     The variables isng in HIJSFT and JL in ATTRAD were not initialized.
0004 c     The version initialize them. (as found by Fernando Marroquim)
0005 c
0006 c
0007 c
0008 c     Version 1.382
0009 c     Nuclear distribution for deuteron is taken as the Hulthen wave
0010 c     function as provided by Brian Cole (Columbia)
0011 clin     used my own implementation of impact parameter
0012 clin     & proton-neutron distance within a deuteron.
0013 c
0014 c
0015 c     Version 1.381
0016 c
0017 c     The parameters for Wood-Saxon distribution for deuteron are
0018 c     constrained to give the right rms ratius 2.116 fm
0019 c     (R=0.0, D=0.5882)
0020 c
0021 c
0022 c     Version 1.38
0023 c
0024 c     The following common block is added to record the number of elastic
0025 c     (NELT, NELP) and inelastic (NINT, NINP) participants
0026 c
0027 c        COMMON/HJGLBR/NELT,NINT,NELP,NINP
0028 c        SAVE /HJGLBR/
0029 c
0030 c     Version 1.37
0031 c
0032 c     A bug in the quenching subroutine is corrected. When calculating the
0033 c     distance between two wounded nucleons, the displacement of the
0034 c     impact parameter was not inculded. This bug was discovered by
0035 c     Dr. V.Uzhinskii JINR, Dubna, Russia
0036 c
0037 c
0038 C     Version 1.36
0039 c
0040 c     Modification Oct. 8, 1998. In hijing, log(ran(nseed)) occasionally
0041 c     causes overfloat. It is modified to log(max(ran(nseed),1.0e-20)).
0042 c
0043 c
0044 C     Nothing important has been changed here. A few 'garbage' has been
0045 C     cleaned up here, like common block HJJET3 for the sea quark strings
0046 C     which were originally created to implement the DPM scheme which
0047 C     later was abadoned in the final version. The lines which operate
0048 C     on these data are also deleted in the program.
0049 C
0050 C
0051 C     Version 1.35
0052 C     There are some changes in the program: subroutine HARDJET is now
0053 C     consolidated with HIJHRD. HARDJET is used to re-initiate PYTHIA
0054 C     for the triggered hard processes. Now that is done  altogether
0055 C     with other normal hard processes in modified JETINI. In the new
0056 C     version one calls JETINI every time one calls HIJHRD. In the new
0057 C     version the effect of the isospin of the nucleon on hard processes,
0058 C     especially direct photons is correctly considered.
0059 C     For A+A collisions, one has to initilize pythia
0060 C     separately for each type of collisions, pp, pn,np and nn,
0061 C     or hp and hn for hA collisions. In JETINI we use the following
0062 C     catalogue for different types of collisions:
0063 C     h+h: h+h (itype=1)
0064 C     h+A: h+p (itype=1), h+n (itype=2)
0065 C     A+h: p+h (itype=1), n+h (itype=2)
0066 C     A+A: p+p (itype=1), p+n (itype=2), n+p (itype=3), n+n (itype=4)
0067 C*****************************************************************
0068 c
0069 C
0070 C     Version 1.34
0071 C     Last modification on January 5, 1998. Two mistakes are corrected in
0072 C     function G. A Mistake in the subroutine Parton is also corrected.
0073 C     (These are pointed out by Ysushi Nara).
0074 C
0075 C
0076 C       Last modifcation on April 10, 1996. To conduct final
0077 C       state radiation, PYTHIA reorganize the two scattered
0078 C       partons and their final momenta will be a little
0079 C       different. The summed total momenta of the partons
0080 C       from the final state radiation are stored in HINT1(26-29)
0081 C       and HINT1(36-39) which are little different from
0082 C       HINT1(21-24) and HINT1(41-44).
0083 C
0084 C       Version 1.33
0085 C
0086 C       Last modfication  on September 11, 1995. When HIJING and
0087 C       PYTHIA are initialized, the shadowing is evaluated at
0088 C       b=0 which is the maximum. This will cause overestimate
0089 C       of shadowing for peripheral interactions. To correct this
0090 C       problem, shadowing is set to zero when initializing. Then
0091 C       use these maximum  cross section without shadowing as a
0092 C       normalization of the Monte Carlo. This however increase
0093 C       the computing time. IHNT2(16) is used to indicate whether
0094 C       the sturcture function is called for (IHNT2(16)=1) initialization
0095 C       or for (IHNT2(16)=0)normal collisions simulation
0096 C
0097 C       Last modification on Aagust 28, 1994. Two bugs associate
0098 C       with the impact parameter dependence of the shadowing is
0099 C       corrected.
0100 C
0101 C
0102 c       Last modification on October 14, 1994. One bug is corrected
0103 c       in the direct photon production option in subroutine
0104 C       HIJHRD.( this problem was reported by Jim Carroll and Mike Beddo).
0105 C       Another bug associated with keeping the decay history
0106 C       in the particle information is also corrected.(this problem
0107 C       was reported by Matt Bloomer)
0108 C
0109 C
0110 C       Last modification on July 15, 1994. The option to trig on
0111 C       heavy quark production (charm IHPR2(18)=0 or beauty IHPR2(18)=1)
0112 C       is added. To do this, set IHPR2(3)=3. For inclusive production,
0113 C       one should reset HIPR1(10)=0.0. One can also trig larger pt
0114 C       QQbar production by giving HIPR1(10) a nonvanishing value.
0115 C       The mass of the heavy quark in the calculation of the cross
0116 C       section (HINT1(59)--HINT1(65)) is given by HIPR1(7) (the
0117 C       default is the charm mass D=1.5). We also include a separate
0118 C       K-factor for heavy quark and direct photon production by
0119 C       HIPR1(23)(D=2.0).
0120 C
0121 C       Last modification on May 24, 1994.  The option to
0122 C       retain the information of all particles including those
0123 C       who have decayed is IHPR(21)=1 (default=0). KATT(I,3) is
0124 C       added to contain the line number of the parent particle
0125 C       of the current line which is produced via a decay.
0126 C       KATT(I,4) is the status number of the particle: 11=particle
0127 C       which has decayed; 1=finally produced particle.
0128 C
0129 C
0130 C       Last modification on May 24, 1994( in HIJSFT when valence quark
0131 C       is quenched, the following error is corrected. 1.2*IHNT2(1) -->
0132 C       1.2*IHNT2(1)**0.333333, 1.2*IHNT2(3) -->1.2*IHNT(3)**0.333333)
0133 C
0134 C
0135 C       Last modification on March 16, 1994 (heavy flavor production
0136 C       processes MSUB(81)=1 MSUB(82)=1 have been switched on,
0137 C       charm production is the default, B-quark option is
0138 C       IHPR2(18), when it is switched on, charm quark is
0139 C       automatically off)
0140 C
0141 C
0142 C       Last modification on March 23, 1994 (an error is corrected
0143 C       in the impact parameter dependence of the jet cross section)
0144 C
0145 C       Last modification Oct. 1993 to comply with non-vax
0146 C       machines' compiler
0147 C
0148 C*********************************************
0149 C       LAST MODIFICATION April 5, 1991
0150 CQUARK DISTRIBUTIOIN (1-X)**A/(X**2+C**2/S)**B
0151 C(A=HIPR1(44),B=HIPR1(46),C=HIPR1(45))
0152 C STRING FLIP, VENUS OPTION IHPR2(15)=1,IN WHICH ONE CAN HAVE ONE AND
0153 C TWO COLOR CHANGES, (1-W)**2,W*(1-W),W*(1-W),AND W*2, W=HIPR1(18),
0154 C AMONG PT DISTRIBUTION OF SEA QUARKS IS CONTROLLED BY HIPR1(42)
0155 C
0156 C       gluon jets can form a single string system
0157 C
0158 C       initial state radiation is included
0159 C
0160 C       all QCD subprocesses are included
0161 c
0162 c       direct particles production is included(currently only direct
0163 C               photon)
0164 c
0165 C       Effect of high P_T trigger bias on multiple jets distribution
0166 c
0167 C******************************************************************
0168 C                               HIJING.10                         *
0169 C                 Heavy Ion Jet INteraction Generator             *
0170 C                                  by                             *
0171 C                  X. N. Wang      and   M. Gyulassy              *
0172 C                     Lawrence Berkeley Laboratory                *
0173 C                                                                 *
0174 C******************************************************************
0175 C
0176 C******************************************************************
0177 C NFP(K,1),NFP(K,2)=flavor of q and di-q, NFP(K,3)=present ID of  *
0178 C proj, NFP(K,4) original ID of proj.  NFP(K,5)=colli status(0=no,*
0179 C 1=elastic,2=the diffrac one in single-diffrac,3= excited string.*
0180 C |NFP(K,6)| is the total # of jet production, if NFP(K,6)<0 it   *
0181 C can not produce jet anymore. NFP(K,10)=valence quarks scattering*
0182 C (0=has not been,1=is going to be, -1=has already been scattered *
0183 C NFP(k,11) total number of interactions this proj has suffered   *
0184 C PP(K,1)=PX,PP(K,2)=PY,PP(K,3)=PZ,PP(K,4)=E,PP(K,5)=M(invariant  *
0185 C mass), PP(K,6,7),PP(K,8,9)=transverse momentum of quark and     *
0186 C diquark,PP(K,10)=PT of the hard scattering between the valence  *
0187 C quarks; PP(K,14,15)=the mass of quark,diquark.                  *
0188 C******************************************************************
0189 C
0190 C****************************************************************
0191 C
0192 C       SUBROUTINE HIJING
0193 C
0194 C****************************************************************
0195         SUBROUTINE HIJING(FRAME,BMIN0,BMAX0)
0196
0197 cbz1/25/99
0198         PARAMETER (MAXPTN=400001)
0199 clin-4/20/01        PARAMETER (MAXSTR = 1600)
0200         PARAMETER (MAXSTR=150001)
0201 cbz1/25/99end
0202 clin-4/26/01:
0203         PARAMETER (MAXIDL=4001)
0204
0205 cbz1/31/99
0206         DOUBLE PRECISION  GX0, GY0, GZ0, FT0, PX0, PY0, PZ0, E0, XMASS0
0207         DOUBLE PRECISION  GX5, GY5, GZ5, FT5, PX5, PY5, PZ5, E5, XMASS5
0208         DOUBLE PRECISION  ATAUI, ZT1, ZT2, ZT3
0209         DOUBLE PRECISION  xnprod,etprod,xnfrz,etfrz,
0210      & dnprod,detpro,dnfrz,detfrz
0211
0212 cbz1/31/99end
0213
0214         CHARACTER FRAME*8
0215         DIMENSION SCIP(300,300),RNIP(300,300),SJIP(300,300),JTP(3),
0216      &                        IPCOL(90000),ITCOL(90000)
0217         COMMON/HPARNT/HIPR1(100),IHPR2(50),HINT1(100),IHNT2(50)
0218 cc      SAVE /HPARNT/
0219 C
0220         COMMON/hjcrdn/YP(3,300),YT(3,300)
0221 cc      SAVE /hjcrdn/
0222 clin-7/16/03 NINT is a intrinsic fortran function, rename it to NINTHJ
0223 c        COMMON/HJGLBR/NELT,NINT,NELP,NINP
0224         COMMON/HJGLBR/NELT,NINTHJ,NELP,NINP
0225 cc      SAVE /HJGLBR/
0226         COMMON/HMAIN1/EATT,JATT,NATT,NT,NP,N0,N01,N10,N11
0227 cc      SAVE /HMAIN1/
0228 clin-4/26/01
0229 c        COMMON/HMAIN2/KATT(130000,4),PATT(130000,4)
0230         COMMON/HMAIN2/KATT(MAXSTR,4),PATT(MAXSTR,4)
0231 cc      SAVE /HMAIN2/
0232         COMMON/HSTRNG/NFP(300,15),PP(300,15),NFT(300,15),PT(300,15)
0233 cc      SAVE /HSTRNG/
0234         COMMON/HJJET1/NPJ(300),KFPJ(300,500),PJPX(300,500),
0235      &                PJPY(300,500),PJPZ(300,500),PJPE(300,500),
0236      &                PJPM(300,500),NTJ(300),KFTJ(300,500),
0237      &                PJTX(300,500),PJTY(300,500),PJTZ(300,500),
0238      &                PJTE(300,500),PJTM(300,500)
0239 cc      SAVE /HJJET1/
0240 clin-4/2008
0241 c        COMMON/HJJET2/NSG,NJSG(900),IASG(900,3),K1SG(900,100),
0242 c     &       K2SG(900,100),PXSG(900,100),PYSG(900,100),
0243 c     &       PZSG(900,100),PESG(900,100),PMSG(900,100)
0244         COMMON/HJJET2/NSG,NJSG(MAXSTR),IASG(MAXSTR,3),K1SG(MAXSTR,100),
0245      &       K2SG(MAXSTR,100),PXSG(MAXSTR,100),PYSG(MAXSTR,100),
0246      &       PZSG(MAXSTR,100),PESG(MAXSTR,100),PMSG(MAXSTR,100)
0247 cc      SAVE /HJJET2/
0248         COMMON/HJJET4/NDR,IADR(MAXSTR,2),KFDR(MAXSTR),PDR(MAXSTR,5)
0249 clin-4/2008:
0250 c        common/xydr/rtdr(900,2)
0251         common/xydr/rtdr(MAXSTR,2)
0252 cc      SAVE /HJJET4/
0253       COMMON/RNDF77/NSEED
0254 cc      SAVE /RNDF77/
0255 C
0256         COMMON/LUJETS/N,K(9000,5),P(9000,5),V(9000,5)
0257 cc      SAVE /LUJETS/
0258         COMMON/LUDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
0259 cc      SAVE /LUDAT1/
0260
0261 clin-9/29/03 changed name in order to distinguish from /prec2/
0262         COMMON /ARPRC/ ITYPAR(MAXSTR),
0263      &       GXAR(MAXSTR), GYAR(MAXSTR), GZAR(MAXSTR), FTAR(MAXSTR),
0264      &       PXAR(MAXSTR), PYAR(MAXSTR), PZAR(MAXSTR), PEAR(MAXSTR),
0265      &       XMAR(MAXSTR)
0266 ccbz11/11/98
0267 c        COMMON /ARPRC/ ITYP(MAXSTR),
0268 c     &     GX(MAXSTR), GY(MAXSTR), GZ(MAXSTR), FT(MAXSTR),
0269 c     &     PX(MAXSTR), PY(MAXSTR), PZ(MAXSTR), EE(MAXSTR),
0270 c     &     XM(MAXSTR)
0271 cc      SAVE /ARPRC/
0272 ccbz11/11/98end
0273
0274 cbz1/25/99
0275         COMMON /PARA1/ MUL
0276 cc      SAVE /PARA1/
0277         COMMON /prec1/GX0(MAXPTN),GY0(MAXPTN),GZ0(MAXPTN),FT0(MAXPTN),
0278      &     PX0(MAXPTN), PY0(MAXPTN), PZ0(MAXPTN), E0(MAXPTN),
0279      &     XMASS0(MAXPTN), ITYP0(MAXPTN)
0280 cc      SAVE /prec1/
0281         COMMON /prec2/GX5(MAXPTN),GY5(MAXPTN),GZ5(MAXPTN),FT5(MAXPTN),
0282      &       PX5(MAXPTN), PY5(MAXPTN), PZ5(MAXPTN), E5(MAXPTN),
0283      &       XMASS5(MAXPTN), ITYP5(MAXPTN)
0284 cc      SAVE /prec2/
0285         COMMON /ilist7/ LSTRG0(MAXPTN), LPART0(MAXPTN)
0286 cc      SAVE /ilist7/
0287         COMMON /ilist8/ LSTRG1(MAXPTN), LPART1(MAXPTN)
0288 cc      SAVE /ilist8/
0289         COMMON /SREC1/ NSP, NST, NSI
0290 cc      SAVE /SREC1/
0291         COMMON /SREC2/ATAUI(MAXSTR),ZT1(MAXSTR),ZT2(MAXSTR),ZT3(MAXSTR)
0292 cc      SAVE /SREC2/
0293 cbz1/25/99end
0294
0295 clin-2/25/00
0296         COMMON /frzout/ xnprod(30),etprod(30),xnfrz(30),etfrz(30),
0297      & dnprod(30),detpro(30),dnfrz(30),detfrz(30)
0298 cc      SAVE /frzout/
0299 clin-4/11/01 soft:
0300       common/anim/nevent,isoft,isflag,izpc
0301 cc      SAVE /anim/
0302 clin-4/25/01 soft3:
0303       DOUBLE PRECISION PXSGS,PYSGS,PZSGS,PESGS,PMSGS,
0304      1     GXSGS,GYSGS,GZSGS,FTSGS
0305       COMMON/SOFT/PXSGS(MAXSTR,3),PYSGS(MAXSTR,3),PZSGS(MAXSTR,3),
0306      &     PESGS(MAXSTR,3),PMSGS(MAXSTR,3),GXSGS(MAXSTR,3),
0307      &     GYSGS(MAXSTR,3),GZSGS(MAXSTR,3),FTSGS(MAXSTR,3),
0308      &     K1SGS(MAXSTR,3),K2SGS(MAXSTR,3),NJSGS(MAXSTR)
0309 cc      SAVE /SOFT/
0310 clin-4/26/01 lepton and photon info:
0311         COMMON /NOPREC/ NNOZPC, ITYPN(MAXIDL),
0312      &       GXN(MAXIDL), GYN(MAXIDL), GZN(MAXIDL), FTN(MAXIDL),
0313      &       PXN(MAXIDL), PYN(MAXIDL), PZN(MAXIDL), EEN(MAXIDL),
0314      &       XMN(MAXIDL)
0315 cc      SAVE /NOPREC/
0316 clin-6/22/01:
0317         common /lastt/itimeh,bimp
0318 cc      SAVE /lastt/
0319         COMMON /AREVT/ IAEVT, IARUN, MISS
0320         common/phidcy/iphidcy,pttrig,ntrig,maxmiss,ipi0dcy
0321 clin-7/2011 ioscar value is needed:
0322         common /para7/ ioscar,nsmbbbar,nsmmeson
0323 clin-2/2012 allow random orientation of reaction plane:
0324         common /phiHJ/iphirp,phiRP
0325         SAVE
0326
0327 ctuos-Need this line for correct b range-06/2015
0328       DOUBLE PRECISION BMIN0,BMAX0
0329
0330         BMAX=MIN(BMAX0,HIPR1(34)+HIPR1(35))
0331         BMIN=MIN(BMIN0,BMAX)
0332         IF(IHNT2(1).LE.1 .AND. IHNT2(3).LE.1) THEN
0333                 BMIN=0.0
0334                 BMAX=2.5*SQRT(HIPR1(31)*0.1/HIPR1(40))
0335         ENDIF
0336 C                        ********HIPR1(31) is in mb =0.1fm**2
0337 C*******THE FOLLOWING IS TO SELECT THE COORDINATIONS OF NUCLEONS
0338 C       BOTH IN PROJECTILE AND TARGET NUCLEAR( in fm)
0339 C
0340         YP(1,1)=0.0
0341         YP(2,1)=0.0
0342         YP(3,1)=0.0
0343         IF(IHNT2(1).LE.1) GO TO 14
0344         DO 10 KP=1,IHNT2(1)
0345 5        R=HIRND(1)
0346         X=RANART(NSEED)
0347         CX=2.0*X-1.0
0348         SX=SQRT(1.0-CX*CX)
0349 C                ********choose theta from uniform cos(theta) distr
0350         PHI=RANART(NSEED)*2.0*HIPR1(40)
0351 C                ********choose phi form uniform phi distr 0 to 2*pi
0352         YP(1,KP)=R*SX*COS(PHI)
0353         YP(2,KP)=R*SX*SIN(PHI)
0354         YP(3,KP)=R*CX
0355         IF(HIPR1(29).EQ.0.0) GO TO 10
0356         DO 8  KP2=1,KP-1
0357                 DNBP1=(YP(1,KP)-YP(1,KP2))**2
0358                 DNBP2=(YP(2,KP)-YP(2,KP2))**2
0359                 DNBP3=(YP(3,KP)-YP(3,KP2))**2
0360                 DNBP=DNBP1+DNBP2+DNBP3
0361                 IF(DNBP.LT.HIPR1(29)*HIPR1(29)) GO TO 5
0362 C                        ********two neighbors cannot be closer than
0363 C                                HIPR1(29)
0364 8        CONTINUE
0365 10        CONTINUE
0366
0367 clin-1/27/03 Hulthen wavefn for deuteron borrowed from hijing1.382.f,
0368 c     but modified [divide by 2, & x(p)=-x(n)]:
0369 c     (Note: hijing1.383.f has corrected this bug in hijing1.382.f)
0370         if(IHNT2(1).EQ.2) then
0371            rnd1=max(RANART(NSEED),1.0e-20)
0372            rnd2=max(RANART(NSEED),1.0e-20)
0373            rnd3=max(RANART(NSEED),1.0e-20)
0374            R=-(log(rnd1)*4.38/2.0+log(rnd2)*0.85/2.0
0375      &          +4.38*0.85*log(rnd3)/(4.38+0.85))
0376            X=RANART(NSEED)
0377            CX=2.0*X-1.0
0378            SX=SQRT(1.0-CX*CX)
0379            PHI=RANART(NSEED)*2.0*HIPR1(40)
0380 c     R above is the relative distance between p & n in a deuteron:
0381            R=R/2.
0382            YP(1,1)=R*SX*COS(PHI)
0383            YP(2,1)=R*SX*SIN(PHI)
0384            YP(3,1)=R*CX
0385 c     p & n has opposite coordinates in the deuteron frame:
0386            YP(1,2)=-YP(1,1)
0387            YP(2,2)=-YP(2,1)
0388            YP(3,2)=-YP(3,1)
0389         endif
0390
0391         DO 12 I=1,IHNT2(1)-1
0392         DO 12 J=I+1,IHNT2(1)
0393         IF(YP(3,I).GT.YP(3,J)) GO TO 12
0394         Y1=YP(1,I)
0395         Y2=YP(2,I)
0396         Y3=YP(3,I)
0397         YP(1,I)=YP(1,J)
0398         YP(2,I)=YP(2,J)
0399         YP(3,I)=YP(3,J)
0400         YP(1,J)=Y1
0401         YP(2,J)=Y2
0402         YP(3,J)=Y3
0403 12        CONTINUE
0404 C
0405 C******************************
0406 14        YT(1,1)=0.0
0407         YT(2,1)=0.0
0408         YT(3,1)=0.0
0409         IF(IHNT2(3).LE.1) GO TO 24
0410         DO 20 KT=1,IHNT2(3)
0411 15        R=HIRND(2)
0412         X=RANART(NSEED)
0413         CX=2.0*X-1.0
0414         SX=SQRT(1.0-CX*CX)
0415 C                ********choose theta from uniform cos(theta) distr
0416         PHI=RANART(NSEED)*2.0*HIPR1(40)
0417 C                ********chose phi form uniform phi distr 0 to 2*pi
0418         YT(1,KT)=R*SX*COS(PHI)
0419         YT(2,KT)=R*SX*SIN(PHI)
0420         YT(3,KT)=R*CX
0421         IF(HIPR1(29).EQ.0.0) GO TO 20
0422         DO 18  KT2=1,KT-1
0423                 DNBT1=(YT(1,KT)-YT(1,KT2))**2
0424                 DNBT2=(YT(2,KT)-YT(2,KT2))**2
0425                 DNBT3=(YT(3,KT)-YT(3,KT2))**2
0426                 DNBT=DNBT1+DNBT2+DNBT3
0427                 IF(DNBT.LT.HIPR1(29)*HIPR1(29)) GO TO 15
0428 C                        ********two neighbors cannot be closer than
0429 C                                HIPR1(29)
0430 18        CONTINUE
0431 20        CONTINUE
0432 c
0433 clin-1/27/03 Hulthen wavefn for deuteron borrowed from hijing1.382.f,
0434 c     but modified [divide by 2, & x(p)=-x(n)]:
0435         if(IHNT2(3).EQ.2) then
0436            rnd1=max(RANART(NSEED),1.0e-20)
0437            rnd2=max(RANART(NSEED),1.0e-20)
0438            rnd3=max(RANART(NSEED),1.0e-20)
0439            R=-(log(rnd1)*4.38/2.0+log(rnd2)*0.85/2.0
0440      &          +4.38*0.85*log(rnd3)/(4.38+0.85))
0441            X=RANART(NSEED)
0442            CX=2.0*X-1.0
0443            SX=SQRT(1.0-CX*CX)
0444            PHI=RANART(NSEED)*2.0*HIPR1(40)
0445            R=R/2.
0446            YT(1,1)=R*SX*COS(PHI)
0447            YT(2,1)=R*SX*SIN(PHI)
0448            YT(3,1)=R*CX
0449            YT(1,2)=-YT(1,1)
0450            YT(2,2)=-YT(2,1)
0451            YT(3,2)=-YT(3,1)
0452         endif
0453 c
0454         DO 22 I=1,IHNT2(3)-1
0455         DO 22 J=I+1,IHNT2(3)
0456         IF(YT(3,I).LT.YT(3,J)) GO TO 22
0457         Y1=YT(1,I)
0458         Y2=YT(2,I)
0459         Y3=YT(3,I)
0460         YT(1,I)=YT(1,J)
0461         YT(2,I)=YT(2,J)
0462         YT(3,I)=YT(3,J)
0463         YT(1,J)=Y1
0464         YT(2,J)=Y2
0465         YT(3,J)=Y3
0466 22        CONTINUE
0467
0468 C********************
0469 24        MISS=-1
0470 50        MISS=MISS+1
0471
0472 clin-6/2009
0473 c        IF(MISS.GT.50) THEN
0474         IF(MISS.GT.maxmiss) THEN
0475            WRITE(6,*) 'infinite loop happened in  HIJING'
0476            STOP
0477         ENDIF
0478
0479 clin-4/30/01:
0480         itest=0
0481
0482         NATT=0
0483         JATT=0
0484         EATT=0.0
0485         CALL HIJINI
0486         NLOP=0
0487 C                        ********Initialize for a new event
0488 60        NT=0
0489         NP=0
0490         N0=0
0491         N01=0
0492         N10=0
0493         N11=0
0494         NELT=0
0495         NINTHJ=0
0496         NELP=0
0497         NINP=0
0498         NSG=0
0499         NCOLT=0
0500
0501 C****        BB IS THE ABSOLUTE VALUE OF IMPACT PARAMETER,BB**2 IS
0502 C       RANDOMLY GENERATED AND ITS ORIENTATION IS RANDOMLY SET
0503 C       BY THE ANGLE PHI  FOR EACH COLLISION.******************
0504 C
0505         BB=SQRT(BMIN**2+RANART(NSEED)*(BMAX**2-BMIN**2))
0506 cbz6/28/99 flow1
0507 clin-2/2012:
0508         PHI=0.
0509         if(iphirp.eq.1) PHI=2.0*HIPR1(40)*RANART(NSEED)
0510         phiRP=phi
0511 cbz6/28/99 flow1 end
0512         BBX=BB*COS(PHI)
0513         BBY=BB*SIN(PHI)
0514         HINT1(19)=BB
0515         HINT1(20)=PHI
0516 C
0517         DO 70 JP=1,IHNT2(1)
0518         DO 70 JT=1,IHNT2(3)
0519            SCIP(JP,JT)=-1.0
0520            B2=(YP(1,JP)+BBX-YT(1,JT))**2+(YP(2,JP)+BBY-YT(2,JT))**2
0521            R2=B2*HIPR1(40)/HIPR1(31)/0.1
0522 C                ********mb=0.1*fm, YP is in fm,HIPR1(31) is in mb
0523            RRB1=MIN((YP(1,JP)**2+YP(2,JP)**2)
0524      &          /1.2**2/REAL(IHNT2(1))**0.6666667,1.0)
0525            RRB2=MIN((YT(1,JT)**2+YT(2,JT)**2)
0526      &          /1.2**2/REAL(IHNT2(3))**0.6666667,1.0)
0527            APHX1=HIPR1(6)*4.0/3.0*(IHNT2(1)**0.3333333-1.0)
0528      &           *SQRT(1.0-RRB1)
0529            APHX2=HIPR1(6)*4.0/3.0*(IHNT2(3)**0.3333333-1.0)
0530      &           *SQRT(1.0-RRB2)
0531            HINT1(18)=HINT1(14)-APHX1*HINT1(15)
0532      &                        -APHX2*HINT1(16)+APHX1*APHX2*HINT1(17)
0533            IF(IHPR2(14).EQ.0.OR.
0534      &          (IHNT2(1).EQ.1.AND.IHNT2(3).EQ.1)) THEN
0535               GS=1.0-EXP(-(HIPR1(30)+HINT1(18))*ROMG(R2)/HIPR1(31))
0536               RANTOT=RANART(NSEED)
0537               IF(RANTOT.GT.GS) GO TO 70
0538               GO TO 65
0539            ENDIF
0540            GSTOT0=2.0*(1.0-EXP(-(HIPR1(30)+HINT1(18))
0541      &             /HIPR1(31)/2.0*ROMG(0.0)))
0542            R2=R2/GSTOT0
0543            GS=1.0-EXP(-(HIPR1(30)+HINT1(18))/HIPR1(31)*ROMG(R2))
0544            GSTOT=2.0*(1.0-SQRT(1.0-GS))
0545            RANTOT=RANART(NSEED)*GSTOT0
0546            IF(RANTOT.GT.GSTOT) GO TO 70
0547            IF(RANTOT.GT.GS) THEN
0548               CALL HIJCSC(JP,JT)
0549               GO TO 70
0550 C                        ********perform elastic collisions
0551            ENDIF
0552  65           SCIP(JP,JT)=R2
0553            RNIP(JP,JT)=RANTOT
0554            SJIP(JP,JT)=HINT1(18)
0555            NCOLT=NCOLT+1
0556            IPCOL(NCOLT)=JP
0557            ITCOL(NCOLT)=JT
0558 70        CONTINUE
0559 C                ********total number interactions proj and targ has
0560 C                                suffered
0561
0562 clin-5/22/01 write impact parameter:
0563         bimp=bb
0564         write(6,*) '#impact parameter,nlop,ncolt=',bimp,nlop,ncolt
0565
0566         IF(NCOLT.EQ.0) THEN
0567            NLOP=NLOP+1
0568            IF(NLOP.LE.20.OR.
0569      &           (IHNT2(1).EQ.1.AND.IHNT2(3).EQ.1)) GO TO 60
0570            RETURN
0571         ENDIF
0572 C               ********At large impact parameter, there maybe no
0573 C                       interaction at all. For NN collision
0574 C                       repeat the event until interaction happens
0575 C
0576         IF(IHPR2(3).NE.0) THEN
0577            NHARD=1+INT(RANART(NSEED)*(NCOLT-1)+0.5)
0578            NHARD=MIN(NHARD,NCOLT)
0579            JPHARD=IPCOL(NHARD)
0580            JTHARD=ITCOL(NHARD)
0581 clin-6/2009 ctest off:
0582 c           write(99,*) IAEVT,NHARD,NCOLT,JPHARD,JTHARD
0583         ENDIF
0584 C
0585         IF(IHPR2(9).EQ.1) THEN
0586                 NMINI=1+INT(RANART(NSEED)*(NCOLT-1)+0.5)
0587                 NMINI=MIN(NMINI,NCOLT)
0588                 JPMINI=IPCOL(NMINI)
0589                 JTMINI=ITCOL(NMINI)
0590         ENDIF
0591 C                ********Specifying the location of the hard and
0592 C                        minijet if they are enforced by user
0593 C
0594         DO 200 JP=1,IHNT2(1)
0595         DO 200 JT=1,IHNT2(3)
0596         IF(SCIP(JP,JT).EQ.-1.0) GO TO 200
0597                 NFP(JP,11)=NFP(JP,11)+1
0598                 NFT(JT,11)=NFT(JT,11)+1
0599         IF(NFP(JP,5).LE.1 .AND. NFT(JT,5).GT.1) THEN
0600                 NP=NP+1
0601                 N01=N01+1
0602         ELSE IF(NFP(JP,5).GT.1 .AND. NFT(JT,5).LE.1) THEN
0603                 NT=NT+1
0604                 N10=N10+1
0605         ELSE IF(NFP(JP,5).LE.1 .AND. NFT(JT,5).LE.1) THEN
0606                 NP=NP+1
0607                 NT=NT+1
0608                 N0=N0+1
0609         ELSE IF(NFP(JP,5).GT.1 .AND. NFT(JT,5).GT.1) THEN
0610                 N11=N11+1
0611         ENDIF
0612         JOUT=0
0613         NFP(JP,10)=0
0614         NFT(JT,10)=0
0615 C*****************************************************************
0616         IF(IHPR2(8).EQ.0 .AND. IHPR2(3).EQ.0) GO TO 160
0617 C                ********When IHPR2(8)=0 no jets are produced
0618         IF(NFP(JP,6).LT.0 .OR. NFT(JT,6).LT.0) GO TO 160
0619 C                ********jets can not be produced for (JP,JT)
0620 C                        because not enough energy avaible for
0621 C                                JP or JT
0622         R2=SCIP(JP,JT)
0623         HINT1(18)=SJIP(JP,JT)
0624         TT=ROMG(R2)*HINT1(18)/HIPR1(31)
0625         TTS=HIPR1(30)*ROMG(R2)/HIPR1(31)
0626         NJET=0
0627
0628         IF(IHPR2(3).NE.0 .AND. JP.EQ.JPHARD .AND. JT.EQ.JTHARD) THEN
0629            CALL JETINI(JP,JT,1)
0630            CALL HIJHRD(JP,JT,0,JFLG,0)
0631            HINT1(26)=HINT1(47)
0632            HINT1(27)=HINT1(48)
0633            HINT1(28)=HINT1(49)
0634            HINT1(29)=HINT1(50)
0635            HINT1(36)=HINT1(67)
0636            HINT1(37)=HINT1(68)
0637            HINT1(38)=HINT1(69)
0638            HINT1(39)=HINT1(70)
0639 C
0640            IF(ABS(HINT1(46)).GT.HIPR1(11).AND.JFLG.EQ.2) NFP(JP,7)=1
0641            IF(ABS(HINT1(56)).GT.HIPR1(11).AND.JFLG.EQ.2) NFT(JT,7)=1
0642            IF(MAX(ABS(HINT1(46)),ABS(HINT1(56))).GT.HIPR1(11).AND.
0643      &                                JFLG.GE.3) IASG(NSG,3)=1
0644            IHNT2(9)=IHNT2(14)
0645            IHNT2(10)=IHNT2(15)
0646            DO 105 I05=1,5
0647               HINT1(20+I05)=HINT1(40+I05)
0648               HINT1(30+I05)=HINT1(50+I05)
0649  105           CONTINUE
0650 clin-6/2009 ctest off:
0651 c           write(99,*) jp,jt,IHPR2(3),HIPR1(10),njet,
0652 c     1          ihnt2(9),hint1(21),hint1(22),hint1(23),
0653 c     2          ihnt2(10),hint1(31),hint1(32),hint1(33)
0654 c           write(99,*) ' '
0655            JOUT=1
0656            IF(IHPR2(8).EQ.0) GO TO 160
0657            RRB1=MIN((YP(1,JP)**2+YP(2,JP)**2)/1.2**2
0658      &                /REAL(IHNT2(1))**0.6666667,1.0)
0659            RRB2=MIN((YT(1,JT)**2+YT(2,JT)**2)/1.2**2
0660      &                /REAL(IHNT2(3))**0.6666667,1.0)
0661            APHX1=HIPR1(6)*4.0/3.0*(IHNT2(1)**0.3333333-1.0)
0662      &           *SQRT(1.0-RRB1)
0663            APHX2=HIPR1(6)*4.0/3.0*(IHNT2(3)**0.3333333-1.0)
0664      &           *SQRT(1.0-RRB2)
0665            HINT1(65)=HINT1(61)-APHX1*HINT1(62)
0666      &                        -APHX2*HINT1(63)+APHX1*APHX2*HINT1(64)
0667            TTRIG=ROMG(R2)*HINT1(65)/HIPR1(31)
0668            NJET=-1
0669 C                ********subtract the trigger jet from total number
0670 C                        of jet production  to be done since it has
0671 C                                already been produced here
0672            XR1=-ALOG(EXP(-TTRIG)+RANART(NSEED)*(1.0-EXP(-TTRIG)))
0673  106           NJET=NJET+1
0674            XR1=XR1-ALOG(max(RANART(NSEED),1.0e-20))
0675            IF(XR1.LT.TTRIG) GO TO 106
0676            XR=0.0
0677  107           NJET=NJET+1
0678            XR=XR-ALOG(max(RANART(NSEED),1.0e-20))
0679            IF(XR.LT.TT-TTRIG) GO TO 107
0680            NJET=NJET-1
0681            GO TO 112
0682         ENDIF
0683 C                ********create a hard interaction with specified P_T
0684 c                                 when IHPR2(3)>0
0685         IF(IHPR2(9).EQ.1.AND.JP.EQ.JPMINI.AND.JT.EQ.JTMINI) GO TO 110
0686 C                ********create at least one pair of mini jets
0687 C                        when IHPR2(9)=1
0688 C
0689 clin-4/15/2010 changed .LT. to .LE. to avoid problem when two sides are equal;
0690 c     this problem may lead to a jet production when there should be none and
0691 c     crash the run; crashes at low energies were reported by P. Bhaduri.
0692 c        IF(IHPR2(8).GT.0 .AND.RNIP(JP,JT).LT.EXP(-TT)*
0693 c     &                (1.0-EXP(-TTS))) GO TO 160
0694         IF(IHPR2(8).GT.0 .AND.RNIP(JP,JT).LE.EXP(-TT)*
0695      &                 (1.0-EXP(-TTS))) GO TO 160
0696 c
0697 C                ********this is the probability for no jet production
0698 110        XR=-ALOG(EXP(-TT)+RANART(NSEED)*(1.0-EXP(-TT)))
0699 111        NJET=NJET+1
0700         XR=XR-ALOG(max(RANART(NSEED),1.0e-20))
0701         IF(XR.LT.TT) GO TO 111
0702 112        NJET=MIN(NJET,IHPR2(8))
0703         IF(IHPR2(8).LT.0)  NJET=ABS(IHPR2(8))
0704 C                ******** Determine number of mini jet production
0705 C
0706         DO 150 ijet=1,NJET
0707            CALL JETINI(JP,JT,0)
0708            CALL HIJHRD(JP,JT,JOUT,JFLG,1)
0709 C                ********JFLG=1 jets valence quarks, JFLG=2 with
0710 C                        gluon jet, JFLG=3 with q-qbar prod for
0711 C                        (JP,JT). If JFLG=0 jets can not be produced
0712 C                        this time. If JFLG=-1, error occured abandon
0713 C                        this event. JOUT is the total hard scat for
0714 C                        (JP,JT) up to now.
0715            IF(JFLG.EQ.0) GO TO 160
0716            IF(JFLG.LT.0) THEN
0717               IF(IHPR2(10).NE.0) WRITE(6,*) 'error occured in HIJHRD'
0718               GO TO 50
0719            ENDIF
0720            JOUT=JOUT+1
0721            IF(ABS(HINT1(46)).GT.HIPR1(11).AND.JFLG.EQ.2) NFP(JP,7)=1
0722            IF(ABS(HINT1(56)).GT.HIPR1(11).AND.JFLG.EQ.2) NFT(JT,7)=1
0723            IF(MAX(ABS(HINT1(46)),ABS(HINT1(56))).GT.HIPR1(11).AND.
0724      &                        JFLG.GE.3) IASG(NSG,3)=1
0725 C                ******** jet with PT>HIPR1(11) will be quenched
0726  150        CONTINUE
0727  160        CONTINUE
0728
0729         CALL HIJSFT(JP,JT,JOUT,IERROR)
0730         IF(IERROR.NE.0) THEN
0731            IF(IHPR2(10).NE.0) WRITE(6,*) 'error occured in HIJSFT'
0732            GO TO 50
0733         ENDIF
0734 C
0735 C                ********conduct soft scattering between JP and JT
0736         JATT=JATT+JOUT
0737 200        CONTINUE
0738 c
0739 c**************************
0740 c
0741 clin-6/2009 write out initial minijet information:
0742 clin-2/2012:
0743 c           call minijet_out(BB)
0744            call minijet_out(BB,phiRP)
0745            if(pttrig.gt.0.and.ntrig.eq.0) goto 50
0746 clin-4/2012
0747 clin-6/2009 write out initial transverse positions of initial nucleons:
0748 c           write(94,*) IAEVT,MISS,IHNT2(1),IHNT2(3)
0749         DO 201 JP=1,IHNT2(1)
0750 clin-6/2009:
0751 c           write(94,203) YP(1,JP)+0.5*BB, YP(2,JP), JP, NFP(JP,5)
0752 clin-2/2012:
0753 c       write(94,203) YP(1,JP)+0.5*BB, YP(2,JP), JP, NFP(JP,5),yp(3,jp)
0754 clin-4/2012:
0755 c           write(94,203) YP(1,JP)+0.5*BB*cos(phiRP),
0756 c     1 YP(2,JP)+0.5*BB*sin(phiRP), JP, NFP(JP,5),yp(3,jp)
0757            IF(NFP(JP,5).GT.2) THEN
0758               NINP=NINP+1
0759            ELSE IF(NFP(JP,5).EQ.2.OR.NFP(JP,5).EQ.1) THEN
0760               NELP=NELP+1
0761            ENDIF
0762  201    continue
0763         DO 202 JT=1,IHNT2(3)
0764 clin-6/2009 target nucleon # has a minus sign for distinction from projectile:
0765 c           write(94,203) YT(1,JT)-0.5*BB, YT(2,JT), -JT, NFT(JT,5)
0766 clin-2/2012:
0767 c       write(94,203) YT(1,JT)-0.5*BB, YT(2,JT), -JT, NFT(JT,5),yt(3,jt)
0768 clin-4/2012:
0769 c           write(94,203) YT(1,JT)-0.5*BB*cos(phiRP),
0770 c     1 YT(2,JT)-0.5*BB*sin(phiRP), -JT, NFT(JT,5),yt(3,jt)
0771            IF(NFT(JT,5).GT.2) THEN
0772               NINTHJ=NINTHJ+1
0773            ELSE IF(NFT(JT,5).EQ.2.OR.NFT(JT,5).EQ.1) THEN
0774               NELT=NELT+1
0775            ENDIF
0776  202    continue
0777 c 203    format(f10.3,1x,f10.3,2(1x,I5))
0778 c 203    format(f10.3,1x,f10.3,2(1x,I5),1x,f10.3)
0779 c
0780 c*******************************
0781
0782
0783 C********perform jet quenching for jets with PT>HIPR1(11)**********
0784
0785         IF((IHPR2(8).NE.0.OR.IHPR2(3).NE.0).AND.IHPR2(4).GT.0.AND.
0786      &                        IHNT2(1).GT.1.AND.IHNT2(3).GT.1) THEN
0787                 DO 271 I=1,IHNT2(1)
0788                         IF(NFP(I,7).EQ.1) CALL QUENCH(I,1)
0789 271                CONTINUE
0790                 DO 272 I=1,IHNT2(3)
0791                         IF(NFT(I,7).EQ.1) CALL QUENCH(I,2)
0792 272                CONTINUE
0793                 DO 273 ISG=1,NSG
0794                         IF(IASG(ISG,3).EQ.1) CALL QUENCH(ISG,3)
0795 273                CONTINUE
0796         ENDIF
0797
0798 clin*****4/09/01-soft1, default way of treating strings:
0799         if(isoft.eq.1) then
0800 clin-4/16/01 allow fragmentation:
0801            isflag=1
0802
0803 cbz1/25/99
0804 c.....transfer data from HIJING to ZPC
0805         NSP = IHNT2(1)
0806         NST = IHNT2(3)
0807         NSI = NSG
0808         ISTR = 0
0809         NPAR = 0
0810         DO 1008 I = 1, IHNT2(1)
0811            ISTR = ISTR + 1
0812            DO 1007 J = 1, NPJ(I)
0813 cbz1/27/99
0814 c.....for now only consider gluon cascade
0815               IF (KFPJ(I, J) .EQ. 21) THEN
0816 cbz1/27/99end
0817
0818               NPAR = NPAR + 1
0819               LSTRG0(NPAR) = ISTR
0820               LPART0(NPAR) = J
0821               ITYP0(NPAR) = KFPJ(I, J)
0822 cbz6/28/99 flow1
0823 clin-7/20/01 add dble or sngl to make precisions consistent
0824 c              GX0(NPAR) = YP(1, I)
0825 clin-2/2012:
0826 c              GX0(NPAR) = dble(YP(1, I) + 0.5 * BB)
0827               GX0(NPAR) = dble(YP(1, I)+0.5*BB*cos(phiRP))
0828 cbz6/28/99 flow1 end
0829 c              GY0(NPAR) = dble(YP(2, I))
0830               GY0(NPAR) = dble(YP(2, I)+0.5*BB*sin(phiRP))
0831               GZ0(NPAR) = 0d0
0832               FT0(NPAR) = 0d0
0833               PX0(NPAR) = dble(PJPX(I, J))
0834               PY0(NPAR) = dble(PJPY(I, J))
0835               PZ0(NPAR) = dble(PJPZ(I, J))
0836               XMASS0(NPAR) = dble(PJPM(I, J))
0837 c              E0(NPAR) = dble(PJPE(I, J))
0838               E0(NPAR) = dsqrt(PX0(NPAR)**2+PY0(NPAR)**2
0839      1             +PZ0(NPAR)**2+XMASS0(NPAR)**2)
0840 clin-7/20/01-end
0841
0842 cbz1/27/99
0843 c.....end gluon selection
0844               END IF
0845 cbz1/27/99end
0846  1007      CONTINUE
0847  1008   CONTINUE
0848         DO 1010 I = 1, IHNT2(3)
0849            ISTR = ISTR + 1
0850            DO 1009 J = 1, NTJ(I)
0851 cbz1/27/99
0852 c.....for now only consider gluon cascade
0853               IF (KFTJ(I, J) .EQ. 21) THEN
0854 cbz1/27/99end
0855               NPAR = NPAR + 1
0856               LSTRG0(NPAR) = ISTR
0857               LPART0(NPAR) = J
0858               ITYP0(NPAR) = KFTJ(I, J)
0859 cbz6/28/99 flow1
0860 clin-7/20/01 add dble or sngl to make precisions consistent
0861 c              GX0(NPAR) = YT(1, I)
0862 clin-2/2012:
0863 c              GX0(NPAR) = dble(YT(1, I) - 0.5 * BB)
0864               GX0(NPAR) = dble(YT(1, I)-0.5*BB*cos(phiRP))
0865 cbz6/28/99 flow1 end
0866 c              GY0(NPAR) = dble(YT(2, I))
0867               GY0(NPAR) = dble(YT(2, I)-0.5*BB*sin(phiRP))
0868               GZ0(NPAR) = 0d0
0869               FT0(NPAR) = 0d0
0870               PX0(NPAR) = dble(PJTX(I, J))
0871               PY0(NPAR) = dble(PJTY(I, J))
0872               PZ0(NPAR) = dble(PJTZ(I, J))
0873               XMASS0(NPAR) = dble(PJTM(I, J))
0874 c              E0(NPAR) = dble(PJTE(I, J))
0875               E0(NPAR) = dsqrt(PX0(NPAR)**2+PY0(NPAR)**2
0876      1             +PZ0(NPAR)**2+XMASS0(NPAR)**2)
0877
0878 cbz1/27/99
0879 c.....end gluon selection
0880               END IF
0881 cbz1/27/99end
0882  1009      CONTINUE
0883  1010   CONTINUE
0884         DO 1012 I = 1, NSG
0885            ISTR = ISTR + 1
0886            DO 1011 J = 1, NJSG(I)
0887 cbz1/27/99
0888 c.....for now only consider gluon cascade
0889               IF (K2SG(I, J) .EQ. 21) THEN
0890 cbz1/27/99end
0891               NPAR = NPAR + 1
0892               LSTRG0(NPAR) = ISTR
0893               LPART0(NPAR) = J
0894               ITYP0(NPAR) = K2SG(I, J)
0895 clin-7/20/01 add dble or sngl to make precisions consistent:
0896               GX0(NPAR) = 0.5d0 *
0897      1             dble(YP(1, IASG(I, 1)) + YT(1, IASG(I, 2)))
0898               GY0(NPAR) = 0.5d0 *
0899      2             dble(YP(2, IASG(I, 1)) + YT(2, IASG(I, 2)))
0900               GZ0(NPAR) = 0d0
0901               FT0(NPAR) = 0d0
0902               PX0(NPAR) = dble(PXSG(I, J))
0903               PY0(NPAR) = dble(PYSG(I, J))
0904               PZ0(NPAR) = dble(PZSG(I, J))
0905               XMASS0(NPAR) = dble(PMSG(I, J))
0906 c              E0(NPAR) = dble(PESG(I, J))
0907               E0(NPAR) = dsqrt(PX0(NPAR)**2+PY0(NPAR)**2
0908      1             +PZ0(NPAR)**2+XMASS0(NPAR)**2)
0909 cbz1/27/99
0910 c.....end gluon selection
0911               END IF
0912 cbz1/27/99end
0913  1011      CONTINUE
0914  1012   CONTINUE
0915         MUL = NPAR
0916
0917 cbz2/4/99
0918         CALL HJANA1
0919 cbz2/4/99end
0920
0921 clin-6/2009:
0922         if(ioscar.eq.3) WRITE (95, *) IAEVT, mul
0923 c.....call ZPC for parton cascade
0924         CALL ZPCMN
0925
0926 c     write out parton and wounded nucleon information to ana/zpc1.mom:
0927 clin-6/2009:
0928 c        WRITE (14, 395) ITEST, MUL, bimp, NELP,NINP,NELT,NINTHJ
0929         WRITE (14, 395) IAEVT, MISS, MUL, bimp, NELP,NINP,NELT,NINTHJ
0930         DO 1013 I = 1, MUL
0931 cc           WRITE (14, 411) PX5(I), PY5(I), PZ5(I), ITYP5(I),
0932 c     &        XMASS5(I), E5(I)
0933            if(dmax1(abs(GX5(I)),abs(GY5(I)),abs(GZ5(I)),abs(FT5(I)))
0934      1          .lt.9999) then
0935               write(14,210) ITYP5(I), PX5(I), PY5(I), PZ5(I), XMASS5(I),
0936      1             GX5(I), GY5(I), GZ5(I), FT5(I)
0937            else
0938 c     change format for large numbers:
0939               write(14,211) ITYP5(I), PX5(I), PY5(I), PZ5(I), XMASS5(I),
0940      1             GX5(I), GY5(I), GZ5(I), FT5(I)
0941            endif
0942
0943  1013   CONTINUE
0944  210    format(I6,2(1x,f8.3),1x,f10.3,1x,f6.3,4(1x,f8.2))
0945  211    format(I6,2(1x,f8.3),1x,f10.3,1x,f6.3,4(1x,e8.2))
0946  395    format(3I8,f10.4,4I5)
0947
0948 clin-4/09/01:
0949         itest=itest+1
0950 c 411    FORMAT(1X, 3F10.3, I6, 2F10.3)
0951 cbz3/19/99 end
0952
0953 clin-5/2009 ctest off:
0954 c        call frztm(1,1)
0955
0956 c.....transfer data back from ZPC to HIJING
0957         DO 1014 I = 1, MUL
0958            IF (LSTRG1(I) .LE. NSP) THEN
0959               NSTRG = LSTRG1(I)
0960               NPART = LPART1(I)
0961               KFPJ(NSTRG, NPART) = ITYP5(I)
0962 clin-7/20/01 add dble or sngl to make precisions consistent
0963               PJPX(NSTRG, NPART) = sngl(PX5(I))
0964               PJPY(NSTRG, NPART) = sngl(PY5(I))
0965               PJPZ(NSTRG, NPART) = sngl(PZ5(I))
0966               PJPE(NSTRG, NPART) = sngl(E5(I))
0967               PJPM(NSTRG, NPART) = sngl(XMASS5(I))
0968            ELSE IF (LSTRG1(I) .LE. NSP + NST) THEN
0969               NSTRG = LSTRG1(I) - NSP
0970               NPART = LPART1(I)
0971               KFTJ(NSTRG, NPART) = ITYP5(I)
0972               PJTX(NSTRG, NPART) = sngl(PX5(I))
0973               PJTY(NSTRG, NPART) = sngl(PY5(I))
0974               PJTZ(NSTRG, NPART) = sngl(PZ5(I))
0975               PJTE(NSTRG, NPART) = sngl(E5(I))
0976               PJTM(NSTRG, NPART) = sngl(XMASS5(I))
0977            ELSE
0978               NSTRG = LSTRG1(I) - NSP - NST
0979               NPART = LPART1(I)
0980               K2SG(NSTRG, NPART) = ITYP5(I)
0981               PXSG(NSTRG, NPART) = sngl(PX5(I))
0982               PYSG(NSTRG, NPART) = sngl(PY5(I))
0983               PZSG(NSTRG, NPART) = sngl(PZ5(I))
0984               PESG(NSTRG, NPART) = sngl(E5(I))
0985               PMSG(NSTRG, NPART) = sngl(XMASS5(I))
0986            END IF
0987  1014   CONTINUE
0988 cbz1/25/99end
0989
0990 cbz2/4/99
0991         CALL HJANA2
0992 cbz2/4/99end
0993
0994 clin*****4/09/01-soft2, put q+dq+X in strings into ZPC:
0995         elseif(isoft.eq.2) then
0996         NSP = IHNT2(1)
0997         NST = IHNT2(3)
0998 clin-4/27/01:
0999         NSI = NSG
1000         NPAR=0
1001         ISTR=0
1002 C
1003 clin  No fragmentation to hadrons, only on parton level,
1004 c     and transfer minijet and string data from HIJING to ZPC:
1005         MSTJ(1)=0
1006 clin-4/12/01 forbid soft radiation before ZPC to avoid small-mass strings,
1007 c     and forbid jet order reversal before ZPC to avoid unphysical flavors:
1008         IHPR2(1)=0
1009         isflag=0
1010
1011         IF(IHPR2(20).NE.0) THEN
1012            DO 320 NTP=1,2
1013               DO 310 jjtp=1,IHNT2(2*NTP-1)
1014                  ISTR = ISTR + 1
1015 c change: do gluon kink only once: either here or in fragmentation.
1016                  CALL HIJFRG(jjtp,NTP,IERROR)
1017 c                 call lulist(1)
1018                  if(NTP.eq.1) then
1019 c 354                continue
1020                     NPJ(jjtp)=MAX0(N-2,0)
1021
1022 clin-4/12/01:                    NPJ(jjtp)=MAX0(ipartn-2,0)
1023                  else
1024 c 355                continue
1025                     NTJ(jjtp)=MAX0(N-2,0)
1026 clin-4/12/01:                    NTJ(jjtp)=MAX0(ipartn-2,0)
1027                  endif
1028
1029                  do 300 ii=1,N
1030                  NPAR = NPAR + 1
1031                  LSTRG0(NPAR) = ISTR
1032                  LPART0(NPAR) = II
1033                  ITYP0(NPAR) = K(II,2)
1034                  GZ0(NPAR) = 0d0
1035                  FT0(NPAR) = 0d0
1036 clin-7/20/01 add dble or sngl to make precisions consistent
1037                  PX0(NPAR) = dble(P(II,1))
1038                  PY0(NPAR) = dble(P(II,2))
1039                  PZ0(NPAR) = dble(P(II,3))
1040                  XMASS0(NPAR) = dble(P(II,5))
1041 c                 E0(NPAR) = dble(P(II,4))
1042                  E0(NPAR) = dsqrt(PX0(NPAR)**2+PY0(NPAR)**2
1043      1                +PZ0(NPAR)**2+XMASS0(NPAR)**2)
1044                  IF (NTP .EQ. 1) THEN
1045 clin-7/20/01 add dble or sngl to make precisions consistent
1046 clin-2/2012:
1047 c                    GX0(NPAR) = dble(YP(1, jjtp)+0.5 * BB)
1048 c                    GY0(NPAR) = dble(YP(2, jjtp))
1049                     GX0(NPAR) = dble(YP(1, jjtp)+0.5*BB*cos(phiRP))
1050                     GY0(NPAR) = dble(YP(2, jjtp)+0.5*BB*sin(phiRP))
1051
1052                     IITYP=ITYP0(NPAR)
1053                     nstrg=LSTRG0(NPAR)
1054                     if(IITYP.eq.2112.or.IITYP.eq.2212) then
1055                     elseif((IITYP.eq.1.or.IITYP.eq.2).and.
1056      1 (II.eq.1.or.II.eq.N)) then
1057                        PP(nstrg,6)=sngl(PX0(NPAR))
1058                        PP(nstrg,7)=sngl(PY0(NPAR))
1059                        PP(nstrg,14)=sngl(XMASS0(NPAR))
1060                     elseif((IITYP.eq.1103.or.IITYP.eq.2101
1061      1 .or.IITYP.eq.2103.or.IITYP.eq.2203.
1062      2 .or.IITYP.eq.3101.or.IITYP.eq.3103.
1063      3 .or.IITYP.eq.3201.or.IITYP.eq.3203.or.IITYP.eq.3303)
1064      4 .and.(II.eq.1.or.II.eq.N)) then
1065                        PP(nstrg,8)=sngl(PX0(NPAR))
1066                        PP(nstrg,9)=sngl(PY0(NPAR))
1067                        PP(nstrg,15)=sngl(XMASS0(NPAR))
1068                     else
1069                        NPART = LPART0(NPAR)-1
1070                        KFPJ(NSTRG, NPART) = ITYP0(NPAR)
1071                        PJPX(NSTRG, NPART) = sngl(PX0(NPAR))
1072                        PJPY(NSTRG, NPART) = sngl(PY0(NPAR))
1073                        PJPZ(NSTRG, NPART) = sngl(PZ0(NPAR))
1074                        PJPE(NSTRG, NPART) = sngl(E0(NPAR))
1075                        PJPM(NSTRG, NPART) = sngl(XMASS0(NPAR))
1076                     endif
1077                  ELSE
1078 clin-2/2012:
1079 c                    GX0(NPAR) = dble(YT(1, jjtp)-0.5 * BB)
1080 c                    GY0(NPAR) = dble(YT(2, jjtp))
1081                     GX0(NPAR) = dble(YT(1, jjtp)-0.5*BB*cos(phiRP))
1082                     GY0(NPAR) = dble(YT(2, jjtp)-0.5*BB*sin(phiRP))
1083                     IITYP=ITYP0(NPAR)
1084                     nstrg=LSTRG0(NPAR)-NSP
1085                     if(IITYP.eq.2112.or.IITYP.eq.2212) then
1086                     elseif((IITYP.eq.1.or.IITYP.eq.2).and.
1087      1 (II.eq.1.or.II.eq.N)) then
1088                        PT(nstrg,6)=sngl(PX0(NPAR))
1089                        PT(nstrg,7)=sngl(PY0(NPAR))
1090                        PT(nstrg,14)=sngl(XMASS0(NPAR))
1091                     elseif((IITYP.eq.1103.or.IITYP.eq.2101
1092      1 .or.IITYP.eq.2103.or.IITYP.eq.2203.
1093      2 .or.IITYP.eq.3101.or.IITYP.eq.3103.
1094      3 .or.IITYP.eq.3201.or.IITYP.eq.3203.or.IITYP.eq.3303)
1095      4 .and.(II.eq.1.or.II.eq.N)) then
1096                        PT(nstrg,8)=sngl(PX0(NPAR))
1097                        PT(nstrg,9)=sngl(PY0(NPAR))
1098                        PT(nstrg,15)=sngl(XMASS0(NPAR))
1099                     else
1100                        NPART = LPART0(NPAR)-1
1101                        KFTJ(NSTRG, NPART) = ITYP0(NPAR)
1102                        PJTX(NSTRG, NPART) = sngl(PX0(NPAR))
1103                        PJTY(NSTRG, NPART) = sngl(PY0(NPAR))
1104                        PJTZ(NSTRG, NPART) = sngl(PZ0(NPAR))
1105                        PJTE(NSTRG, NPART) = sngl(E0(NPAR))
1106                        PJTM(NSTRG, NPART) = sngl(XMASS0(NPAR))
1107                     endif
1108                  END IF
1109  300          continue
1110  310          continue
1111  320       continue
1112            DO 330 ISG=1,NSG
1113               ISTR = ISTR + 1
1114               CALL HIJFRG(ISG,3,IERROR)
1115 c              call lulist(2)
1116 c
1117               NJSG(ISG)=N
1118 c
1119               do 1001 ii=1,N
1120                  NPAR = NPAR + 1
1121                  LSTRG0(NPAR) = ISTR
1122                  LPART0(NPAR) = II
1123                  ITYP0(NPAR) = K(II,2)
1124                  GX0(NPAR)=0.5d0*
1125      1                dble(YP(1,IASG(ISG,1))+YT(1,IASG(ISG,2)))
1126                  GY0(NPAR)=0.5d0*
1127      2                dble(YP(2,IASG(ISG,1))+YT(2,IASG(ISG,2)))
1128                  GZ0(NPAR) = 0d0
1129                  FT0(NPAR) = 0d0
1130                  PX0(NPAR) = dble(P(II,1))
1131                  PY0(NPAR) = dble(P(II,2))
1132                  PZ0(NPAR) = dble(P(II,3))
1133                  XMASS0(NPAR) = dble(P(II,5))
1134 c                 E0(NPAR) = dble(P(II,4))
1135                  E0(NPAR) = dsqrt(PX0(NPAR)**2+PY0(NPAR)**2
1136      1                +PZ0(NPAR)**2+XMASS0(NPAR)**2)
1137  1001         continue
1138  330       continue
1139         endif
1140
1141         MUL = NPAR
1142 cbz2/4/99
1143         CALL HJANA1
1144 cbz2/4/99end
1145 clin-6/2009:
1146         if(ioscar.eq.3) WRITE (95, *) IAEVT, mul
1147 c.....call ZPC for parton cascade
1148         CALL ZPCMN
1149 cbz3/19/99
1150 clin-6/2009:
1151 c        WRITE (14, 395) ITEST, MUL, bimp, NELP,NINP,NELT,NINTHJ
1152         WRITE (14, 395) IAEVT, MISS, MUL, bimp, NELP,NINP,NELT,NINTHJ
1153         itest=itest+1
1154
1155         DO 1015 I = 1, MUL
1156 c           WRITE (14, 311) PX5(I), PY5(I), PZ5(I), ITYP5(I),
1157 c     &        XMASS5(I), E5(I)
1158 clin-4/2012 write parton freeze-out position in zpc.dat for this test scenario:
1159 c           WRITE (14, 312) PX5(I), PY5(I), PZ5(I), ITYP5(I),
1160 c     &        XMASS5(I), E5(I),LSTRG1(I), LPART1(I)
1161            if(dmax1(abs(GX5(I)),abs(GY5(I)),abs(GZ5(I)),abs(FT5(I)))
1162      1          .lt.9999) then
1163               write(14,210) ITYP5(I), PX5(I), PY5(I), PZ5(I), XMASS5(I),
1164      1             GX5(I), GY5(I), GZ5(I), FT5(I)
1165            else
1166               write(14,211) ITYP5(I), PX5(I), PY5(I), PZ5(I), XMASS5(I),
1167      1             GX5(I), GY5(I), GZ5(I), FT5(I)
1168            endif
1169 c
1170  1015   CONTINUE
1171 c 311    FORMAT(1X, 3F10.4, I6, 2F10.4)
1172 c 312    FORMAT(1X, 3F10.3, I6, 2F10.3,1X,I6,1X,I3)
1173 cbz3/19/99 end
1174
1175 clin-5/2009 ctest off:
1176 c        call frztm(1,1)
1177
1178 clin-4/13/01 initialize four momenta and invariant mass of strings after ZPC:
1179         do 1004 nmom=1,5
1180            do 1002 nstrg=1,nsp
1181               PP(nstrg,nmom)=0.
1182  1002      continue
1183            do 1003 nstrg=1,nst
1184               PT(nstrg,nmom)=0.
1185  1003      continue
1186  1004   continue
1187 clin-4/13/01-end
1188
1189         DO 1005 I = 1, MUL
1190            IITYP=ITYP5(I)
1191            IF (LSTRG1(I) .LE. NSP) THEN
1192               NSTRG = LSTRG1(I)
1193 c     nucleons without interactions:
1194               if(IITYP.eq.2112.or.IITYP.eq.2212) then
1195 clin-7/20/01 add dble or sngl to make precisions consistent
1196                  PP(nstrg,1)=sngl(PX5(I))
1197                  PP(nstrg,2)=sngl(PY5(I))
1198                  PP(nstrg,3)=sngl(PZ5(I))
1199                  PP(nstrg,4)=sngl(E5(I))
1200                  PP(nstrg,5)=sngl(XMASS5(I))
1201 c     valence quark:
1202               elseif((IITYP.eq.1.or.IITYP.eq.2).and.
1203      1 (LPART1(I).eq.1.or.LPART1(I).eq.(NPJ(NSTRG)+2))) then
1204                  PP(nstrg,6)=sngl(PX5(I))
1205                  PP(nstrg,7)=sngl(PY5(I))
1206                  PP(nstrg,14)=sngl(XMASS5(I))
1207                  PP(nstrg,1)=PP(nstrg,1)+sngl(PX5(I))
1208                  PP(nstrg,2)=PP(nstrg,2)+sngl(PY5(I))
1209                  PP(nstrg,3)=PP(nstrg,3)+sngl(PZ5(I))
1210                  PP(nstrg,4)=PP(nstrg,4)+sngl(E5(I))
1211                  PP(nstrg,5)=sqrt(PP(nstrg,4)**2-PP(nstrg,1)**2
1212      1                -PP(nstrg,2)**2-PP(nstrg,3)**2)
1213 c     diquark:
1214               elseif((IITYP.eq.1103.or.IITYP.eq.2101
1215      1 .or.IITYP.eq.2103.or.IITYP.eq.2203.
1216      2 .or.IITYP.eq.3101.or.IITYP.eq.3103.
1217      3 .or.IITYP.eq.3201.or.IITYP.eq.3203.or.IITYP.eq.3303)
1218      4 .and.(LPART1(I).eq.1.or.LPART1(I).eq.(NPJ(NSTRG)+2))) then
1219                  PP(nstrg,8)=sngl(PX5(I))
1220                  PP(nstrg,9)=sngl(PY5(I))
1221                  PP(nstrg,15)=sngl(XMASS5(I))
1222                  PP(nstrg,1)=PP(nstrg,1)+sngl(PX5(I))
1223                  PP(nstrg,2)=PP(nstrg,2)+sngl(PY5(I))
1224                  PP(nstrg,3)=PP(nstrg,3)+sngl(PZ5(I))
1225                  PP(nstrg,4)=PP(nstrg,4)+sngl(E5(I))
1226                  PP(nstrg,5)=sqrt(PP(nstrg,4)**2-PP(nstrg,1)**2
1227      1                -PP(nstrg,2)**2-PP(nstrg,3)**2)
1228 c     partons in projectile or target strings:
1229               else
1230                  NPART = LPART1(I)-1
1231                  KFPJ(NSTRG, NPART) = ITYP5(I)
1232                  PJPX(NSTRG, NPART) = sngl(PX5(I))
1233                  PJPY(NSTRG, NPART) = sngl(PY5(I))
1234                  PJPZ(NSTRG, NPART) = sngl(PZ5(I))
1235                  PJPE(NSTRG, NPART) = sngl(E5(I))
1236                  PJPM(NSTRG, NPART) = sngl(XMASS5(I))
1237               endif
1238            ELSE IF (LSTRG1(I) .LE. NSP + NST) THEN
1239               NSTRG = LSTRG1(I) - NSP
1240               if(IITYP.eq.2112.or.IITYP.eq.2212) then
1241                  PT(nstrg,1)=sngl(PX5(I))
1242                  PT(nstrg,2)=sngl(PY5(I))
1243                  PT(nstrg,3)=sngl(PZ5(I))
1244                  PT(nstrg,4)=sngl(E5(I))
1245                  PT(nstrg,5)=sngl(XMASS5(I))
1246               elseif((IITYP.eq.1.or.IITYP.eq.2).and.
1247      1 (LPART1(I).eq.1.or.LPART1(I).eq.(NTJ(NSTRG)+2))) then
1248                  PT(nstrg,6)=sngl(PX5(I))
1249                  PT(nstrg,7)=sngl(PY5(I))
1250                  PT(nstrg,14)=sngl(XMASS5(I))
1251                  PT(nstrg,1)=PT(nstrg,1)+sngl(PX5(I))
1252                  PT(nstrg,2)=PT(nstrg,2)+sngl(PY5(I))
1253                  PT(nstrg,3)=PT(nstrg,3)+sngl(PZ5(I))
1254                  PT(nstrg,4)=PT(nstrg,4)+sngl(E5(I))
1255                  PT(nstrg,5)=sqrt(PT(nstrg,4)**2-PT(nstrg,1)**2
1256      1                -PT(nstrg,2)**2-PT(nstrg,3)**2)
1257               elseif((IITYP.eq.1103.or.IITYP.eq.2101
1258      1 .or.IITYP.eq.2103.or.IITYP.eq.2203.
1259      2 .or.IITYP.eq.3101.or.IITYP.eq.3103.
1260      3 .or.IITYP.eq.3201.or.IITYP.eq.3203.or.IITYP.eq.3303)
1261      4 .and.(LPART1(I).eq.1.or.LPART1(I).eq.(NTJ(NSTRG)+2))) then
1262                  PT(nstrg,8)=sngl(PX5(I))
1263                  PT(nstrg,9)=sngl(PY5(I))
1264                  PT(nstrg,15)=sngl(XMASS5(I))
1265                  PT(nstrg,1)=PT(nstrg,1)+sngl(PX5(I))
1266                  PT(nstrg,2)=PT(nstrg,2)+sngl(PY5(I))
1267                  PT(nstrg,3)=PT(nstrg,3)+sngl(PZ5(I))
1268                  PT(nstrg,4)=PT(nstrg,4)+sngl(E5(I))
1269                  PT(nstrg,5)=sqrt(PT(nstrg,4)**2-PT(nstrg,1)**2
1270      1                -PT(nstrg,2)**2-PT(nstrg,3)**2)
1271               else
1272                  NPART = LPART1(I)-1
1273                  KFTJ(NSTRG, NPART) = ITYP5(I)
1274                  PJTX(NSTRG, NPART) = sngl(PX5(I))
1275                  PJTY(NSTRG, NPART) = sngl(PY5(I))
1276                  PJTZ(NSTRG, NPART) = sngl(PZ5(I))
1277                  PJTE(NSTRG, NPART) = sngl(E5(I))
1278                  PJTM(NSTRG, NPART) = sngl(XMASS5(I))
1279               endif
1280            ELSE
1281               NSTRG = LSTRG1(I) - NSP - NST
1282               NPART = LPART1(I)
1283               K2SG(NSTRG, NPART) = ITYP5(I)
1284               PXSG(NSTRG, NPART) = sngl(PX5(I))
1285               PYSG(NSTRG, NPART) = sngl(PY5(I))
1286               PZSG(NSTRG, NPART) = sngl(PZ5(I))
1287               PESG(NSTRG, NPART) = sngl(E5(I))
1288               PMSG(NSTRG, NPART) = sngl(XMASS5(I))
1289            END IF
1290  1005   CONTINUE
1291 cbz1/25/99end
1292
1293 clin-4/09/01  turn on fragmentation with soft radiation
1294 c     and jet order reversal to form hadrons after ZPC:
1295         MSTJ(1)=1
1296         IHPR2(1)=1
1297         isflag=1
1298 clin-4/13/01 allow small mass strings (D=1.5GeV):
1299         HIPR1(1)=0.94
1300
1301 cbz2/4/99
1302         CALL HJANA2
1303 cbz2/4/99end
1304
1305 clin-4/19/01-soft3, fragment strings, then convert hadrons to partons
1306 c     and input to ZPC:
1307         elseif(isoft.eq.3.or.isoft.eq.4.or.isoft.eq.5) then
1308 clin-4/24/01 normal fragmentation first:
1309         isflag=0
1310
1311         IF(IHPR2(20).NE.0) THEN
1312            DO 560 ISG=1,NSG
1313                 CALL HIJFRG(ISG,3,IERROR)
1314 C
1315                 nsbst=1
1316                 IDSTR=92
1317                 IF(IHPR2(21).EQ.0) THEN
1318                    CALL LUEDIT(2)
1319                 ELSE
1320  551                   nsbst=nsbst+1
1321                    IF(K(nsbst,2).LT.91.OR.K(nsbst,2).GT.93) GO TO  551
1322                    IDSTR=K(nsbst,2)
1323                    nsbst=nsbst+1
1324                 ENDIF
1325
1326                 IF(FRAME.EQ.'LAB') THEN
1327                         CALL HBOOST
1328                 ENDIF
1329 C                ******** boost back to lab frame(if it was in)
1330 C
1331                 nsbstR=0
1332                 DO 560 I=nsbst,N
1333                    IF(K(I,2).EQ.IDSTR) THEN
1334                       nsbstR=nsbstR+1
1335                       GO TO 560
1336                    ENDIF
1337                    K(I,4)=nsbstR
1338                    NATT=NATT+1
1339                    KATT(NATT,1)=K(I,2)
1340                    KATT(NATT,2)=20
1341                    KATT(NATT,4)=K(I,1)
1342 c     from Yasushi, to avoid violation of array limits:
1343 c                   IF(K(I,3).EQ.0 .OR. K(K(I,3),2).EQ.IDSTR) THEN
1344 clin-4/2008 to avoid out-of-bound error in K():
1345 c                   IF(K(I,3).EQ.0 .OR.
1346 c     1 (K(I,3).ne.0.and.K(K(I,3),2).EQ.IDSTR)) THEN
1347 c                      KATT(NATT,3)=0
1348                    IF(K(I,3).EQ.0) THEN
1349                       KATT(NATT,3)=0
1350                    ELSEIF(K(I,3).ne.0.and.K(K(I,3),2).EQ.IDSTR) THEN
1351                       KATT(NATT,3)=0
1352 clin-4/2008-end
1353                    ELSE
1354                       KATT(NATT,3)=NATT-I+K(I,3)+nsbstR-K(K(I,3),4)
1355                    ENDIF
1356
1357 C       ****** identify the mother particle
1358                    PATT(NATT,1)=P(I,1)
1359                    PATT(NATT,2)=P(I,2)
1360                    PATT(NATT,3)=P(I,3)
1361                    PATT(NATT,4)=P(I,4)
1362                    EATT=EATT+P(I,4)
1363                    GXAR(NATT) = 0.5 * (YP(1, IASG(ISG, 1)) +
1364      &                YT(1, IASG(ISG, 2)))
1365                    GYAR(NATT) = 0.5 * (YP(2, IASG(ISG, 1)) +
1366      &                YT(2, IASG(ISG, 2)))
1367                    GZAR(NATT) = 0.
1368                    FTAR(NATT) = 0.
1369                    ITYPAR(NATT) = K(I, 2)
1370                    PXAR(NATT) = P(I, 1)
1371                    PYAR(NATT) = P(I, 2)
1372                    PZAR(NATT) = P(I, 3)
1373                    PEAR(NATT) = P(I, 4)
1374                    XMAR(NATT) = P(I, 5)
1375 cbz11/11/98end
1376
1377  560            CONTINUE
1378 C                ********Fragment the q-qbar jets systems *****
1379 C
1380            JTP(1)=IHNT2(1)
1381            JTP(2)=IHNT2(3)
1382            DO 600 NTP=1,2
1383            DO 600 jjtp=1,JTP(NTP)
1384                 CALL HIJFRG(jjtp,NTP,IERROR)
1385 C
1386                 nsbst=1
1387                 IDSTR=92
1388                 IF(IHPR2(21).EQ.0) THEN
1389                    CALL LUEDIT(2)
1390                 ELSE
1391  581                   nsbst=nsbst+1
1392                    IF(K(nsbst,2).LT.91.OR.K(nsbst,2).GT.93) GO TO  581
1393                    IDSTR=K(nsbst,2)
1394                    nsbst=nsbst+1
1395                 ENDIF
1396                 IF(FRAME.EQ.'LAB') THEN
1397                         CALL HBOOST
1398                 ENDIF
1399 C                ******** boost back to lab frame(if it was in)
1400 C
1401                 NFTP=NFP(jjtp,5)
1402                 IF(NTP.EQ.2) NFTP=10+NFT(jjtp,5)
1403                 nsbstR=0
1404                 DO 590 I=nsbst,N
1405                    IF(K(I,2).EQ.IDSTR) THEN
1406                       nsbstR=nsbstR+1
1407                       GO TO 590
1408                    ENDIF
1409                    K(I,4)=nsbstR
1410                    NATT=NATT+1
1411                    KATT(NATT,1)=K(I,2)
1412                    KATT(NATT,2)=NFTP
1413                    KATT(NATT,4)=K(I,1)
1414 c                   IF(K(I,3).EQ.0 .OR. K(K(I,3),2).EQ.IDSTR) THEN
1415 clin-4/2008
1416 c                   IF(K(I,3).EQ.0 .OR.
1417 c     1 (K(I,3).ne.0.and.K(K(I,3),2).EQ.IDSTR)) THEN
1418 c                      KATT(NATT,3)=0
1419                    IF(K(I,3).EQ.0) THEN
1420                       KATT(NATT,3)=0
1421                    ELSEIF(K(I,3).ne.0.and.K(K(I,3),2).EQ.IDSTR) THEN
1422                       KATT(NATT,3)=0
1423 clin-4/2008-end
1424                    ELSE
1425                       KATT(NATT,3)=NATT-I+K(I,3)+nsbstR-K(K(I,3),4)
1426                    ENDIF
1427
1428 C       ****** identify the mother particle
1429                    PATT(NATT,1)=P(I,1)
1430                    PATT(NATT,2)=P(I,2)
1431                    PATT(NATT,3)=P(I,3)
1432                    PATT(NATT,4)=P(I,4)
1433                    EATT=EATT+P(I,4)
1434                    IF (NTP .EQ. 1) THEN
1435 clin-2/2012:
1436 c                      GXAR(NATT) = YP(1, jjtp)+0.5 * BB
1437 c                      GYAR(NATT) = YP(2, jjtp)
1438                       GXAR(NATT) = YP(1, jjtp)+0.5*BB*cos(phiRP)
1439                       GYAR(NATT) = YP(2, jjtp)+0.5*BB*sin(phiRP)
1440
1441                    ELSE
1442 clin-2/2012:
1443 c                      GXAR(NATT) = YT(1, jjtp)-0.5 * BB
1444 c                      GYAR(NATT) = YT(2, jjtp)
1445                       GXAR(NATT) = YT(1, jjtp)-0.5*BB*cos(phiRP)
1446                       GYAR(NATT) = YT(2, jjtp)-0.5*BB*sin(phiRP)
1447                    END IF
1448                    GZAR(NATT) = 0.
1449                    FTAR(NATT) = 0.
1450                    ITYPAR(NATT) = K(I, 2)
1451                    PXAR(NATT) = P(I, 1)
1452                    PYAR(NATT) = P(I, 2)
1453                    PZAR(NATT) = P(I, 3)
1454                    PEAR(NATT) = P(I, 4)
1455                    XMAR(NATT) = P(I, 5)
1456 cbz11/11/98end
1457
1458  590                CONTINUE
1459  600           CONTINUE
1460 C     ********Fragment the q-qq related string systems
1461         ENDIF
1462 clin-4/2008 check for zero NDR value:
1463         if(NDR.ge.1) then
1464 c
1465         DO 650 I=1,NDR
1466                 NATT=NATT+1
1467                 KATT(NATT,1)=KFDR(I)
1468                 KATT(NATT,2)=40
1469                 KATT(NATT,3)=0
1470                 PATT(NATT,1)=PDR(I,1)
1471                 PATT(NATT,2)=PDR(I,2)
1472                 PATT(NATT,3)=PDR(I,3)
1473                 PATT(NATT,4)=PDR(I,4)
1474                 EATT=EATT+PDR(I,4)
1475 clin-11/11/03     set direct photons positions and time at formation:
1476                 GXAR(NATT) = rtdr(I,1)
1477                 GYAR(NATT) = rtdr(I,2)
1478                 GZAR(NATT) = 0.
1479                 FTAR(NATT) = 0.
1480                 ITYPAR(NATT) =KATT(NATT,1)
1481                 PXAR(NATT) = PATT(NATT,1)
1482                 PYAR(NATT) = PATT(NATT,2)
1483                 PZAR(NATT) = PATT(NATT,3)
1484                 PEAR(NATT) = PATT(NATT,4)
1485                 XMAR(NATT) = PDR(I,5)
1486  650        CONTINUE
1487 clin-4/2008:
1488          endif
1489 clin-6/2009
1490          call embedHighPt
1491 c
1492         CALL HJANA1
1493
1494 clin-4/19/01 convert hadrons to partons for ZPC (with GX0 given):
1495         call htop
1496
1497 clin-7/03/01 move up, used in zpstrg (otherwise not set and incorrect):
1498         nsp=0
1499         nst=0
1500         nsg=natt
1501         NSI=NSG
1502 clin-7/03/01-end
1503
1504 clin-6/2009:
1505         if(ioscar.eq.3) WRITE (95, *) IAEVT, mul
1506
1507 c.....call ZPC for parton cascade
1508         CALL ZPCMN
1509 clin-6/2009:
1510 c        WRITE (14, 395) ITEST, MUL, bimp, NELP,NINP,NELT,NINTHJ
1511         WRITE (14, 395) IAEVT, MISS, MUL, bimp, NELP,NINP,NELT,NINTHJ
1512         itest=itest+1
1513
1514         DO 1016 I = 1, MUL
1515 c           WRITE (14, 511) PX5(I), PY5(I), PZ5(I), ITYP5(I),
1516 c     &        XMASS5(I), E5(I)
1517 clin-4/2012 write parton freeze-out position in zpc.dat
1518 c     for string melting version:
1519 c           WRITE (14, 512) ITYP5(I), PX5(I), PY5(I), PZ5(I),
1520 c     &        XMASS5(I), LSTRG1(I), LPART1(I), FT5(I)
1521            if(dmax1(abs(GX5(I)),abs(GY5(I)),abs(GZ5(I)),abs(FT5(I)))
1522      1          .lt.9999) then
1523               write(14,210) ITYP5(I), PX5(I), PY5(I), PZ5(I), XMASS5(I),
1524      1             GX5(I), GY5(I), GZ5(I), FT5(I)
1525            else
1526               write(14,211) ITYP5(I), PX5(I), PY5(I), PZ5(I), XMASS5(I),
1527      1             GX5(I), GY5(I), GZ5(I), FT5(I)
1528            endif
1529 c
1530  1016   CONTINUE
1531 c 511    FORMAT(1X, 3F10.4, I6, 2F10.4)
1532 c 512    FORMAT(I6,4(1X,F10.3),1X,I6,1X,I3,1X,F10.3)
1533 c 513    FORMAT(1X, 4F10.4)
1534
1535 clin-5/2009 ctest off:
1536 c        call frztm(1,1)
1537
1538 clin  save data after ZPC for fragmentation purpose:
1539 c.....transfer data back from ZPC to HIJING
1540         DO 1018 I = 1, MAXSTR
1541            DO 1017 J = 1, 3
1542               K1SGS(I, J) = 0
1543               K2SGS(I, J) = 0
1544               PXSGS(I, J) = 0d0
1545               PYSGS(I, J) = 0d0
1546               PZSGS(I, J) = 0d0
1547               PESGS(I, J) = 0d0
1548               PMSGS(I, J) = 0d0
1549               GXSGS(I, J) = 0d0
1550               GYSGS(I, J) = 0d0
1551               GZSGS(I, J) = 0d0
1552               FTSGS(I, J) = 0d0
1553  1017      CONTINUE
1554  1018   CONTINUE
1555         DO 1019 I = 1, MUL
1556            IITYP=ITYP5(I)
1557            NSTRG = LSTRG1(I)
1558            NPART = LPART1(I)
1559            K2SGS(NSTRG, NPART) = ITYP5(I)
1560            PXSGS(NSTRG, NPART) = PX5(I)
1561            PYSGS(NSTRG, NPART) = PY5(I)
1562            PZSGS(NSTRG, NPART) = PZ5(I)
1563            PMSGS(NSTRG, NPART) = XMASS5(I)
1564 clin-7/20/01 E5(I) does no include the finite parton mass XMASS5(I),
1565 c     so define it anew:
1566 c           PESGS(NSTRG, NPART) = E5(I)
1567 c           if(abs(PZ5(i)/E5(i)).gt.0.9999999d0)
1568 c     1          write(91,*) 'a',PX5(i),PY5(i),XMASS5(i),PZ5(i),E5(i)
1569            E5(I)=dsqrt(PX5(I)**2+PY5(I)**2+PZ5(I)**2+XMASS5(I)**2)
1570            PESGS(NSTRG, NPART) = E5(I)
1571 c           if(abs(PZ5(i)/E5(i)).gt.0.9999999d0)
1572 c     1          write(91,*) 'b: new E5(I)=',E5(i)
1573 clin-7/20/01-end
1574            GXSGS(NSTRG, NPART) = GX5(I)
1575            GYSGS(NSTRG, NPART) = GY5(I)
1576            GZSGS(NSTRG, NPART) = GZ5(I)
1577            FTSGS(NSTRG, NPART) = FT5(I)
1578  1019   CONTINUE
1579         CALL HJANA2
1580
1581 clin-4/19/01-end
1582
1583         endif
1584 clin-4/09/01-end
1585
1586 C
1587 C**************fragment all the string systems in the following*****
1588 C
1589 C********nsbst is where particle information starts
1590 C********nsbstR+1 is the number of strings in fragmentation
1591 C********the number of strings before a line is stored in K(I,4)
1592 C********IDSTR is id number of the string system (91,92 or 93)
1593 C
1594 clin-4/30/01 convert partons to hadrons after ZPC:
1595         if(isoft.eq.3.or.isoft.eq.4.or.isoft.eq.5) then
1596            NATT=0
1597            EATT=0.
1598            call ptoh
1599            do 1006 I=1,nnozpc
1600               NATT=NATT+1
1601               KATT(NATT,1)=ITYPN(I)
1602               PATT(NATT,1)=PXN(I)
1603               PATT(NATT,2)=PYN(I)
1604               PATT(NATT,3)=PZN(I)
1605               PATT(NATT,4)=EEN(I)
1606               EATT=EATT+EEN(I)
1607               GXAR(NATT)=GXN(I)
1608               GYAR(NATT)=GYN(I)
1609               GZAR(NATT)=GZN(I)
1610               FTAR(NATT)=FTN(I)
1611               ITYPAR(NATT)=ITYPN(I)
1612               PXAR(NATT)=PXN(I)
1613               PYAR(NATT)=PYN(I)
1614               PZAR(NATT)=PZN(I)
1615               PEAR(NATT)=EEN(I)
1616               XMAR(NATT)=XMN(I)
1617  1006      continue
1618            goto 565
1619         endif
1620 clin-4/30/01-end
1621         IF(IHPR2(20).NE.0) THEN
1622            DO 360 ISG=1,NSG
1623                 CALL HIJFRG(ISG,3,IERROR)
1624                 IF(MSTU(24).NE.0 .OR.IERROR.GT.0) THEN
1625                    MSTU(24)=0
1626                    MSTU(28)=0
1627                    IF(IHPR2(10).NE.0) THEN
1628 c                      call lulist(2)
1629                       WRITE(6,*) 'error occured ISG, repeat the event'
1630                   write(6,*) ISG
1631
1632                    ENDIF
1633                    GO TO 50
1634                 ENDIF
1635 C                        ********Check errors
1636 C
1637                 nsbst=1
1638                 IDSTR=92
1639                 IF(IHPR2(21).EQ.0) THEN
1640                    CALL LUEDIT(2)
1641                 ELSE
1642 351                   nsbst=nsbst+1
1643                    IF(K(nsbst,2).LT.91.OR.K(nsbst,2).GT.93) GO TO  351
1644                    IDSTR=K(nsbst,2)
1645                    nsbst=nsbst+1
1646                 ENDIF
1647 C
1648                 IF(FRAME.EQ.'LAB') THEN
1649                         CALL HBOOST
1650                 ENDIF
1651 C                ******** boost back to lab frame(if it was in)
1652 C
1653                 nsbstR=0
1654                 DO 360 I=nsbst,N
1655                    IF(K(I,2).EQ.IDSTR) THEN
1656                       nsbstR=nsbstR+1
1657                       GO TO 360
1658                    ENDIF
1659                    K(I,4)=nsbstR
1660                    NATT=NATT+1
1661                    KATT(NATT,1)=K(I,2)
1662                    KATT(NATT,2)=20
1663                    KATT(NATT,4)=K(I,1)
1664 c                   IF(K(I,3).EQ.0 .OR. K(K(I,3),2).EQ.IDSTR) THEN
1665 clin-4/2008:
1666 c                   IF(K(I,3).EQ.0 .OR.
1667 c     1 (K(I,3).ne.0.and.K(K(I,3),2).EQ.IDSTR)) THEN
1668 c                      KATT(NATT,3)=0
1669                    IF(K(I,3).EQ.0) THEN
1670                       KATT(NATT,3)=0
1671                    ELSEIF(K(I,3).ne.0.and.K(K(I,3),2).EQ.IDSTR) THEN
1672                       KATT(NATT,3)=0
1673 clin-4/2008-end
1674                    ELSE
1675                       KATT(NATT,3)=NATT-I+K(I,3)+nsbstR-K(K(I,3),4)
1676                    ENDIF
1677
1678 C       ****** identify the mother particle
1679                    PATT(NATT,1)=P(I,1)
1680                    PATT(NATT,2)=P(I,2)
1681                    PATT(NATT,3)=P(I,3)
1682                    PATT(NATT,4)=P(I,4)
1683                    EATT=EATT+P(I,4)
1684
1685 cbz11/11/98
1686 cbz1/25/99
1687 c                   GXAR(NATT) = 0.5 * (YP(1, IASG(ISG, 1)) +
1688 c     &                YT(1, IASG(ISG, 2)))
1689 c                   GYAR(NATT) = 0.5 * (YP(2, IASG(ISG, 1)) +
1690 c     &                YT(2, IASG(ISG, 2)))
1691                    LSG = NSP + NST + ISG
1692                    GXAR(NATT) = sngl(ZT1(LSG))
1693                    GYAR(NATT) = sngl(ZT2(LSG))
1694                    GZAR(NATT) = sngl(ZT3(LSG))
1695                    FTAR(NATT) = sngl(ATAUI(LSG))
1696 cbz1/25/99end
1697                    ITYPAR(NATT) = K(I, 2)
1698                    PXAR(NATT) = P(I, 1)
1699                    PYAR(NATT) = P(I, 2)
1700                    PZAR(NATT) = P(I, 3)
1701                    PEAR(NATT) = P(I, 4)
1702                    XMAR(NATT) = P(I, 5)
1703 cbz11/11/98end
1704
1705 360           CONTINUE
1706 C                ********Fragment the q-qbar jets systems *****
1707 C
1708            JTP(1)=IHNT2(1)
1709            JTP(2)=IHNT2(3)
1710            DO 400 NTP=1,2
1711            DO 400 jjtp=1,JTP(NTP)
1712                 CALL HIJFRG(jjtp,NTP,IERROR)
1713                 IF(MSTU(24).NE.0 .OR. IERROR.GT.0) THEN
1714                    MSTU(24)=0
1715                    MSTU(28)=0
1716                    IF(IHPR2(10).NE.0) THEN
1717 c                  call lulist(2)
1718                   WRITE(6,*) 'error occured P&T, repeat the event'
1719                   WRITE(6,*) NTP,jjtp
1720 clin-6/2009 when this happens, the event will be repeated,
1721 c     and another record for the same event number will be written into
1722 c     zpc.dat, zpc.res, minijet-initial-beforePropagation.dat,
1723 c     parton-initial-afterPropagation.dat, parton-after-coalescence.dat,
1724 c     and parton-collisionsHistory.dat.
1725                    ENDIF
1726                    GO TO 50
1727                 ENDIF
1728 C                        ********check errors
1729 C
1730                 nsbst=1
1731                 IDSTR=92
1732                 IF(IHPR2(21).EQ.0) THEN
1733                    CALL LUEDIT(2)
1734                 ELSE
1735 381                   nsbst=nsbst+1
1736                    IF(K(nsbst,2).LT.91.OR.K(nsbst,2).GT.93) GO TO  381
1737                    IDSTR=K(nsbst,2)
1738                    nsbst=nsbst+1
1739                 ENDIF
1740                 IF(FRAME.EQ.'LAB') THEN
1741                         CALL HBOOST
1742                 ENDIF
1743 C                ******** boost back to lab frame(if it was in)
1744 C
1745                 NFTP=NFP(jjtp,5)
1746                 IF(NTP.EQ.2) NFTP=10+NFT(jjtp,5)
1747                 nsbstR=0
1748                 DO 390 I=nsbst,N
1749                    IF(K(I,2).EQ.IDSTR) THEN
1750                       nsbstR=nsbstR+1
1751                       GO TO 390
1752                    ENDIF
1753                    K(I,4)=nsbstR
1754                    NATT=NATT+1
1755                    KATT(NATT,1)=K(I,2)
1756                    KATT(NATT,2)=NFTP
1757                    KATT(NATT,4)=K(I,1)
1758 c                   IF(K(I,3).EQ.0 .OR. K(K(I,3),2).EQ.IDSTR) THEN
1759 clin-4/2008:
1760 c                   IF(K(I,3).EQ.0 .OR.
1761 c     1 (K(I,3).ne.0.and.K(K(I,3),2).EQ.IDSTR)) THEN
1762 c                      KATT(NATT,3)=0
1763                    IF(K(I,3).EQ.0) THEN
1764                       KATT(NATT,3)=0
1765                    ELSEIF(K(I,3).ne.0.and.K(K(I,3),2).EQ.IDSTR) THEN
1766                       KATT(NATT,3)=0
1767 clin-4/2008-end
1768                    ELSE
1769                       KATT(NATT,3)=NATT-I+K(I,3)+nsbstR-K(K(I,3),4)
1770                    ENDIF
1771 C       ****** identify the mother particle
1772                    PATT(NATT,1)=P(I,1)
1773                    PATT(NATT,2)=P(I,2)
1774                    PATT(NATT,3)=P(I,3)
1775                    PATT(NATT,4)=P(I,4)
1776                    EATT=EATT+P(I,4)
1777 cbz11/11/98
1778 cbz1/25/99
1779 c                   IF (NTP .EQ. 1) THEN
1780 c                      GXAR(NATT) = YP(1, jjtp)
1781 c                   ELSE
1782 c                      GXAR(NATT) = YT(1, jjtp)
1783 c                   END IF
1784 c                   IF (NTP .EQ. 1) THEN
1785 c                      GYAR(NATT) = YP(2, jjtp)
1786 c                   ELSE
1787 c                      GYAR(NATT) = YT(2, jjtp)
1788 c                   END IF
1789                    IF (NTP .EQ. 1) THEN
1790                       LSG = jjtp
1791                    ELSE
1792                       LSG = jjtp + NSP
1793                    END IF
1794                    GXAR(NATT) = sngl(ZT1(LSG))
1795                    GYAR(NATT) = sngl(ZT2(LSG))
1796                    GZAR(NATT) = sngl(ZT3(LSG))
1797                    FTAR(NATT) = sngl(ATAUI(LSG))
1798 cbz1/25/99end
1799                    ITYPAR(NATT) = K(I, 2)
1800                    PXAR(NATT) = P(I, 1)
1801                    PYAR(NATT) = P(I, 2)
1802                    PZAR(NATT) = P(I, 3)
1803                    PEAR(NATT) = P(I, 4)
1804                    XMAR(NATT) = P(I, 5)
1805 cbz11/11/98end
1806
1807 390                CONTINUE
1808 400           CONTINUE
1809 C     ********Fragment the q-qq related string systems
1810         ENDIF
1811
1812         DO 450 I=1,NDR
1813            NATT=NATT+1
1814            KATT(NATT,1)=KFDR(I)
1815            KATT(NATT,2)=40
1816            KATT(NATT,3)=0
1817            PATT(NATT,1)=PDR(I,1)
1818            PATT(NATT,2)=PDR(I,2)
1819            PATT(NATT,3)=PDR(I,3)
1820            PATT(NATT,4)=PDR(I,4)
1821            EATT=EATT+PDR(I,4)
1822 clin-11/11/03     set direct photons positions and time at formation:
1823            GXAR(NATT) = rtdr(I,1)
1824            GYAR(NATT) = rtdr(I,2)
1825            GZAR(NATT) = 0.
1826            FTAR(NATT) = 0.
1827            ITYPAR(NATT) =KATT(NATT,1)
1828            PXAR(NATT) = PATT(NATT,1)
1829            PYAR(NATT) = PATT(NATT,2)
1830            PZAR(NATT) = PATT(NATT,3)
1831            PEAR(NATT) = PATT(NATT,4)
1832            XMAR(NATT) = PDR(I,5)
1833  450    CONTINUE
1834
1835 C                        ********store the direct-produced particles
1836 C
1837
1838 clin-4/19/01 soft3:
1839  565    continue
1840
1841         DENGY=EATT/(IHNT2(1)*HINT1(6)+IHNT2(3)*HINT1(7))-1.0
1842         IF(ABS(DENGY).GT.HIPR1(43).AND.IHPR2(20).NE.0
1843      &     .AND.IHPR2(21).EQ.0) THEN
1844          IF(IHPR2(10).NE.0)
1845      &        WRITE(6,*) 'Energy not conserved, repeat the event'
1846 c                call lulist(1)
1847          write(6,*) 'violated:EATT(GeV),NATT,B(fm)=',EATT,NATT,bimp
1848          GO TO 50
1849         ENDIF
1850         write(6,*) 'satisfied:EATT(GeV),NATT,B(fm)=',EATT,NATT,bimp
1851         write(6,*) ' '
1852 c
1853 clin-4/2012 write out initial transverse positions of initial nucleons:
1854         write(94,*) IAEVT,MISS,IHNT2(1),IHNT2(3),bimp
1855         DO JP=1,IHNT2(1)
1856 clin-12/2012 write out present and original flavor code of nucleons:
1857 c           write(94,243) YP(1,JP)+0.5*BB*cos(phiRP),
1858 c     1 YP(2,JP)+0.5*BB*sin(phiRP), JP, NFP(JP,5),yp(3,jp)
1859            write(94,243) YP(1,JP)+0.5*BB*cos(phiRP),
1860      1 YP(2,JP)+0.5*BB*sin(phiRP),JP, NFP(JP,5),yp(3,jp),
1861      2 NFP(JP,3),NFP(JP,4)
1862         ENDDO
1863         DO JT=1,IHNT2(3)
1864 c target nucleon # has a minus sign for distinction from projectile:
1865 clin-12/2012 write out present and original flavor code of nucleons:
1866 c           write(94,243) YT(1,JT)-0.5*BB*cos(phiRP),
1867 c     1 YT(2,JT)-0.5*BB*sin(phiRP), -JT, NFT(JT,5),yt(3,jt)
1868            write(94,243) YT(1,JT)-0.5*BB*cos(phiRP),
1869      1 YT(2,JT)-0.5*BB*sin(phiRP), -JT, NFT(JT,5),yt(3,jt),
1870      2 NFT(JT,3),NFT(JT,4)
1871         ENDDO
1872 clin-12/2012 write out present and original flavor code of nucleons:
1873 c 243    format(f10.3,1x,f10.3,2(1x,I5),1x,f10.3)
1874  243    format(f10.3,1x,f10.3,2(1x,I5),1x,f10.3,2(1x,I5))
1875 clin-4/2012-end
1876
1877         RETURN
1878         END
1879 C
1880 C
1881 C
1882         SUBROUTINE HIJSET(EFRM,FRAME,PROJ,TARG,IAP,IZP,IAT,IZT)
1883         CHARACTER FRAME*4,PROJ*4,TARG*4,EFRAME*4
1884         DOUBLE PRECISION  DD1,DD2,DD3,DD4
1885         COMMON/HSTRNG/NFP(300,15),PP(300,15),NFT(300,15),PT(300,15)
1886 cc      SAVE /HSTRNG/
1887         COMMON/hjcrdn/YP(3,300),YT(3,300)
1888 cc      SAVE /hjcrdn/
1889         COMMON/HPARNT/HIPR1(100),IHPR2(50),HINT1(100),IHNT2(50)
1890 cc      SAVE /HPARNT/
1891         COMMON/HIJDAT/HIDAT0(10,10),HIDAT(10)
1892 cc      SAVE /HIJDAT/
1893         COMMON/LUDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
1894 cc      SAVE /LUDAT1/
1895         EXTERNAL FNKICK,FNKC2,FNSTRU,FNSTRM,FNSTRS
1896         SAVE
1897
1898         CALL TITLE
1899         IHNT2(1)=IAP
1900         IHNT2(2)=IZP
1901         IHNT2(3)=IAT
1902         IHNT2(4)=IZT
1903         IHNT2(5)=0
1904         IHNT2(6)=0
1905 C
1906         HINT1(8)=MAX(ULMASS(2112),ULMASS(2212))
1907         HINT1(9)=HINT1(8)
1908 C
1909         IF(PROJ.NE.'A') THEN
1910                 IF(PROJ.EQ.'P') THEN
1911                     IHNT2(5)=2212
1912                 ELSE IF(PROJ.EQ.'PBAR') THEN
1913                     IHNT2(5)=-2212
1914                 ELSE IF(PROJ.EQ.'PI+') THEN
1915                     IHNT2(5)=211
1916                 ELSE IF(PROJ.EQ.'PI-') THEN
1917                     IHNT2(5)=-211
1918                 ELSE IF(PROJ.EQ.'K+') THEN
1919                     IHNT2(5)=321
1920                 ELSE IF(PROJ.EQ.'K-') THEN
1921                     IHNT2(5)=-321
1922                 ELSE IF(PROJ.EQ.'N') THEN
1923                     IHNT2(5)=2112
1924                 ELSE IF(PROJ.EQ.'NBAR') THEN
1925                     IHNT2(5)=-2112
1926                 ELSE
1927                     WRITE(6,*) PROJ, 'wrong or unavailable proj name'
1928                     STOP
1929                 ENDIF
1930                 HINT1(8)=ULMASS(IHNT2(5))
1931         ENDIF
1932         IF(TARG.NE.'A') THEN
1933                 IF(TARG.EQ.'P') THEN
1934                     IHNT2(6)=2212
1935                 ELSE IF(TARG.EQ.'PBAR') THEN
1936                     IHNT2(6)=-2212
1937                 ELSE IF(TARG.EQ.'PI+') THEN
1938                     IHNT2(6)=211
1939                 ELSE IF(TARG.EQ.'PI-') THEN
1940                     IHNT2(6)=-211
1941                 ELSE IF(TARG.EQ.'K+') THEN
1942                     IHNT2(6)=321
1943                 ELSE IF(TARG.EQ.'K-') THEN
1944                     IHNT2(6)=-321
1945                 ELSE IF(TARG.EQ.'N') THEN
1946                     IHNT2(6)=2112
1947                 ELSE IF(TARG.EQ.'NBAR') THEN
1948                     IHNT2(6)=-2112
1949                 ELSE
1950                     WRITE(6,*) TARG,'wrong or unavailable targ name'
1951                     STOP
1952                 ENDIF
1953                 HINT1(9)=ULMASS(IHNT2(6))
1954         ENDIF
1955
1956 C...Switch off decay of pi0, K0S, Lambda, Sigma+-, Xi0-, Omega-.
1957         IF(IHPR2(12).GT.0) THEN
1958         CALL LUGIVE('MDCY(C221,1)=0')
1959 clin-11/07/00 no K* decays:
1960         CALL LUGIVE('MDCY(C313,1)=0')
1961         CALL LUGIVE('MDCY(C-313,1)=0')
1962         CALL LUGIVE('MDCY(C323,1)=0')
1963         CALL LUGIVE('MDCY(C-323,1)=0')
1964 clin-1/04/01 no K0 and K0bar decays so K0L and K0S do not appear,
1965 c     this way the K/Kbar difference is accounted for exactly:
1966         CALL LUGIVE('MDCY(C311,1)=0')
1967         CALL LUGIVE('MDCY(C-311,1)=0')
1968 clin-11/08/00 no Delta decays:
1969         CALL LUGIVE('MDCY(C1114,1)=0')
1970         CALL LUGIVE('MDCY(C2114,1)=0')
1971         CALL LUGIVE('MDCY(C2214,1)=0')
1972         CALL LUGIVE('MDCY(C2224,1)=0')
1973         CALL LUGIVE('MDCY(C-1114,1)=0')
1974         CALL LUGIVE('MDCY(C-2114,1)=0')
1975         CALL LUGIVE('MDCY(C-2214,1)=0')
1976         CALL LUGIVE('MDCY(C-2224,1)=0')
1977 clin-11/07/00-end
1978 cbz12/4/98
1979         CALL LUGIVE('MDCY(C213,1)=0')
1980         CALL LUGIVE('MDCY(C-213,1)=0')
1981         CALL LUGIVE('MDCY(C113,1)=0')
1982         CALL LUGIVE('MDCY(C223,1)=0')
1983         CALL LUGIVE('MDCY(C333,1)=0')
1984 cbz12/4/98end
1985         CALL LUGIVE('MDCY(C111,1)=0')
1986         CALL LUGIVE('MDCY(C310,1)=0')
1987         CALL LUGIVE('MDCY(C411,1)=0;MDCY(C-411,1)=0')
1988         CALL LUGIVE('MDCY(C421,1)=0;MDCY(C-421,1)=0')
1989         CALL LUGIVE('MDCY(C431,1)=0;MDCY(C-431,1)=0')
1990         CALL LUGIVE('MDCY(C511,1)=0;MDCY(C-511,1)=0')
1991         CALL LUGIVE('MDCY(C521,1)=0;MDCY(C-521,1)=0')
1992         CALL LUGIVE('MDCY(C531,1)=0;MDCY(C-531,1)=0')
1993         CALL LUGIVE('MDCY(C3122,1)=0;MDCY(C-3122,1)=0')
1994         CALL LUGIVE('MDCY(C3112,1)=0;MDCY(C-3112,1)=0')
1995         CALL LUGIVE('MDCY(C3212,1)=0;MDCY(C-3212,1)=0')
1996         CALL LUGIVE('MDCY(C3222,1)=0;MDCY(C-3222,1)=0')
1997         CALL LUGIVE('MDCY(C3312,1)=0;MDCY(C-3312,1)=0')
1998         CALL LUGIVE('MDCY(C3322,1)=0;MDCY(C-3322,1)=0')
1999         CALL LUGIVE('MDCY(C3334,1)=0;MDCY(C-3334,1)=0')
2000 clin-7/2011-no HQ(charm or bottom) decays in order to get net-HQ conservation:
2001         CALL LUGIVE('MDCY(C441,1)=0')
2002         CALL LUGIVE('MDCY(C443,1)=0')
2003         CALL LUGIVE('MDCY(C413,1)=0;MDCY(C-413,1)=0')
2004         CALL LUGIVE('MDCY(C423,1)=0;MDCY(C-423,1)=0')
2005         CALL LUGIVE('MDCY(C433,1)=0;MDCY(C-433,1)=0')
2006         CALL LUGIVE('MDCY(C4112,1)=0;MDCY(C-4112,1)=0')
2007         CALL LUGIVE('MDCY(C4114,1)=0;MDCY(C-4114,1)=0')
2008         CALL LUGIVE('MDCY(C4122,1)=0;MDCY(C-4122,1)=0')
2009         CALL LUGIVE('MDCY(C4212,1)=0;MDCY(C-4212,1)=0')
2010         CALL LUGIVE('MDCY(C4214,1)=0;MDCY(C-4214,1)=0')
2011         CALL LUGIVE('MDCY(C4222,1)=0;MDCY(C-4222,1)=0')
2012         CALL LUGIVE('MDCY(C4224,1)=0;MDCY(C-4224,1)=0')
2013         CALL LUGIVE('MDCY(C4132,1)=0;MDCY(C-4132,1)=0')
2014         CALL LUGIVE('MDCY(C4312,1)=0;MDCY(C-4312,1)=0')
2015         CALL LUGIVE('MDCY(C4314,1)=0;MDCY(C-4314,1)=0')
2016         CALL LUGIVE('MDCY(C4232,1)=0;MDCY(C-4232,1)=0')
2017         CALL LUGIVE('MDCY(C4322,1)=0;MDCY(C-4322,1)=0')
2018         CALL LUGIVE('MDCY(C4324,1)=0;MDCY(C-4324,1)=0')
2019         CALL LUGIVE('MDCY(C4332,1)=0;MDCY(C-4332,1)=0')
2020         CALL LUGIVE('MDCY(C4334,1)=0;MDCY(C-4334,1)=0')
2021         CALL LUGIVE('MDCY(C551,1)=0')
2022         CALL LUGIVE('MDCY(C553,1)=0')
2023         CALL LUGIVE('MDCY(C513,1)=0;MDCY(C-513,1)=0')
2024         CALL LUGIVE('MDCY(C523,1)=0;MDCY(C-523,1)=0')
2025         CALL LUGIVE('MDCY(C533,1)=0;MDCY(C-533,1)=0')
2026         CALL LUGIVE('MDCY(C5112,1)=0;MDCY(C-5112,1)=0')
2027         CALL LUGIVE('MDCY(C5114,1)=0;MDCY(C-5114,1)=0')
2028         CALL LUGIVE('MDCY(C5122,1)=0;MDCY(C-5122,1)=0')
2029         CALL LUGIVE('MDCY(C5212,1)=0;MDCY(C-5212,1)=0')
2030         CALL LUGIVE('MDCY(C5214,1)=0;MDCY(C-5214,1)=0')
2031         CALL LUGIVE('MDCY(C5222,1)=0;MDCY(C-5222,1)=0')
2032         CALL LUGIVE('MDCY(C5224,1)=0;MDCY(C-5224,1)=0')
2033 clin-7/2011-end
2034         ENDIF
2035         MSTU(12)=0
2036         MSTU(21)=1
2037         IF(IHPR2(10).EQ.0) THEN
2038                 MSTU(22)=0
2039                 MSTU(25)=0
2040                 MSTU(26)=0
2041         ENDIF
2042
2043 clin    parj(41) and (42) are a, b parameters in Lund, read from input.ampt:
2044 c        PARJ(41)=HIPR1(3)
2045 c        PARJ(42)=HIPR1(4)
2046 c        PARJ(41)=2.2
2047 c        PARJ(42)=0.5
2048
2049 clin  2 popcorn parameters read from input.ampt:
2050 c        IHPR2(11) = 3
2051 c        PARJ(5) = 0.5
2052         MSTJ(12)=IHPR2(11)
2053
2054 clin  parj(21) gives the mean gaussian width for hadron Pt:
2055         PARJ(21)=HIPR1(2)
2056 clin  parj(2) is gamma_s=P(s)/P(u), kappa propto 1/b/(2+a) assumed.
2057         rkp=HIPR1(4)*(2+HIPR1(3))/PARJ(42)/(2+PARJ(41))
2058         PARJ(2)=PARJ(2)**(1./rkp)
2059         PARJ(21)=PARJ(21)*sqrt(rkp)
2060 clin-10/31/00 update when string tension is changed:
2061         HIPR1(2)=PARJ(21)
2062
2063 clin-8/2013 test on: set upper limit for gamma_s=P(s)/P(u) to 0.4
2064 c     (to limit strangeness enhancement when string tension is strongly
2065 c     increased due to using a very low value of parameter b in Lund
2066 c     symmetric splitting function as done in arXiv:1403.6321):
2067         PARJ(2)=min(PARJ(2),0.4)
2068
2069 C                        ******** set up for jetset
2070         IF(FRAME.EQ.'LAB') THEN
2071            DD1=dble(EFRM)
2072            DD2=dble(HINT1(8))
2073            DD3=dble(HINT1(9))
2074            HINT1(1)=SQRT(HINT1(8)**2+2.0*HINT1(9)*EFRM+HINT1(9)**2)
2075            DD4=DSQRT(DD1**2-DD2**2)/(DD1+DD3)
2076            HINT1(2)=sngl(DD4)
2077            HINT1(3)=0.5*sngl(DLOG((1.D0+DD4)/(1.D0-DD4)))
2078            DD4=DSQRT(DD1**2-DD2**2)/DD1
2079            HINT1(4)=0.5*sngl(DLOG((1.D0+DD4)/(1.D0-DD4)))
2080            HINT1(5)=0.0
2081            HINT1(6)=EFRM
2082            HINT1(7)=HINT1(9)
2083         ELSE IF(FRAME.EQ.'CMS') THEN
2084            HINT1(1)=EFRM
2085            HINT1(2)=0.0
2086            HINT1(3)=0.0
2087            DD1=dble(HINT1(1))
2088            DD2=dble(HINT1(8))
2089            DD3=dble(HINT1(9))
2090            DD4=DSQRT(1.D0-4.D0*DD2**2/DD1**2)
2091            HINT1(4)=0.5*sngl(DLOG((1.D0+DD4)/(1.D0-DD4)))
2092            DD4=DSQRT(1.D0-4.D0*DD3**2/DD1**2)
2093            HINT1(5)=-0.5*sngl(DLOG((1.D0+DD4)/(1.D0-DD4)))
2094            HINT1(6)=HINT1(1)/2.0
2095            HINT1(7)=HINT1(1)/2.0
2096         ENDIF
2097 C                ********define Lorentz transform to lab frame
2098 c
2099 C                ********calculate the cross sections involved with
2100 C                        nucleon collisions.
2101         IF(IHNT2(1).GT.1) THEN
2102                 CALL HIJWDS(IHNT2(1),1,RMAX)
2103                 HIPR1(34)=RMAX
2104 C                        ********set up Wood-Sax distr for proj.
2105         ENDIF
2106         IF(IHNT2(3).GT.1) THEN
2107                 CALL HIJWDS(IHNT2(3),2,RMAX)
2108                 HIPR1(35)=RMAX
2109 C                        ********set up Wood-Sax distr for  targ.
2110         ENDIF
2111 C
2112 C
2113         I=0
2114 20        I=I+1
2115         IF(I.EQ.10) GO TO 30
2116         IF(HIDAT0(10,I).LE.HINT1(1)) GO TO 20
2117 30        IF(I.EQ.1) I=2
2118         DO 40 J=1,9
2119            HIDAT(J)=HIDAT0(J,I-1)+(HIDAT0(J,I)-HIDAT0(J,I-1))
2120      &          *(HINT1(1)-HIDAT0(10,I-1))/(HIDAT0(10,I)-HIDAT0(10,I-1))
2121 40        CONTINUE
2122         HIPR1(31)=HIDAT(5)
2123         HIPR1(30)=2.0*HIDAT(5)
2124 C
2125 C
2126         CALL HIJCRS
2127 C
2128         IF(IHPR2(5).NE.0) THEN
2129                 CALL HIFUN(3,0.0,36.0,FNKICK)
2130 C                ********booking for generating pt**2 for pt kick
2131         ENDIF
2132         CALL HIFUN(7,0.0,6.0,FNKC2)
2133         CALL HIFUN(4,0.0,1.0,FNSTRU)
2134         CALL HIFUN(5,0.0,1.0,FNSTRM)
2135         CALL HIFUN(6,0.0,1.0,FNSTRS)
2136 C                ********booking for x distribution of valence quarks
2137         EFRAME='Ecm'
2138         IF(FRAME.EQ.'LAB') EFRAME='Elab'
2139         WRITE(6,100) EFRAME,EFRM,PROJ,IHNT2(1),IHNT2(2),
2140      &               TARG,IHNT2(3),IHNT2(4)
2141 100        FORMAT(
2142      &        10X,'**************************************************'/
2143      &        10X,'*',48X,'*'/
2144      &        10X,'*         HIJING has been initialized at         *'/
2145      &        10X,'*',13X,A4,'= ',F10.2,' GeV/n',13X,'*'/
2146      &        10X,'*',48X,'*'/
2147      &        10X,'*',8X,'for ',
2148      &        A4,'(',I3,',',I3,')',' + ',A4,'(',I3,',',I3,')',7X,'*'/
2149      &        10X,'**************************************************')
2150         RETURN
2151         END
2152 C
2153 C
2154 C
2155         FUNCTION FNKICK(X)
2156         COMMON/HPARNT/HIPR1(100),IHPR2(50),HINT1(100),IHNT2(50)
2157 cc      SAVE /HPARNT/
2158         SAVE
2159         FNKICK=1.0/(X+HIPR1(19)**2)/(X+HIPR1(20)**2)
2160      &                /(1+EXP((SQRT(X)-HIPR1(20))/0.4))
2161         RETURN
2162         END
2163 C
2164 C
2165         FUNCTION FNKC2(X)
2166         COMMON/HPARNT/HIPR1(100),IHPR2(50),HINT1(100),IHNT2(50)
2167 cc      SAVE /HPARNT/
2168         SAVE
2169         FNKC2=X*EXP(-2.0*X/HIPR1(42))
2170         RETURN
2171         END
2172 C
2173 C
2174 C
2175         FUNCTION FNSTRU(X)
2176         COMMON/HPARNT/HIPR1(100),IHPR2(50),HINT1(100),IHNT2(50)
2177 cc      SAVE /HPARNT/
2178         SAVE
2179         FNSTRU=(1.0-X)**HIPR1(44)/
2180      &                (X**2+HIPR1(45)**2/HINT1(1)**2)**HIPR1(46)
2181         RETURN
2182         END
2183 C
2184 C
2185 C
2186         FUNCTION FNSTRM(X)
2187         COMMON/HPARNT/HIPR1(100),IHPR2(50),HINT1(100),IHNT2(50)
2188 cc      SAVE /HPARNT/
2189         SAVE
2190         FNSTRM=1.0/((1.0-X)**2+HIPR1(45)**2/HINT1(1)**2)**HIPR1(46)
2191      &          /(X**2+HIPR1(45)**2/HINT1(1)**2)**HIPR1(46)
2192         RETURN
2193         END
2194 C
2195 C
2196         FUNCTION FNSTRS(X)
2197         COMMON/HPARNT/HIPR1(100),IHPR2(50),HINT1(100),IHNT2(50)
2198 cc      SAVE /HPARNT/
2199         SAVE
2200         FNSTRS=(1.0-X)**HIPR1(47)/
2201      &                (X**2+HIPR1(45)**2/HINT1(1)**2)**HIPR1(48)
2202         RETURN
2203         END
2204 C
2205 C
2206 C
2207 C
2208         SUBROUTINE HBOOST
2209               IMPLICIT DOUBLE PRECISION(D)
2210               COMMON/LUJETS/N,K(9000,5),P(9000,5),V(9000,5)
2211 cc      SAVE /LUJETS/
2212               COMMON/LUDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
2213 cc      SAVE /LUDAT1/
2214         COMMON/HPARNT/HIPR1(100),IHPR2(50),HINT1(100),IHNT2(50)
2215 cc      SAVE /HPARNT/
2216         SAVE
2217         DO 100 I=1,N
2218            DBETA=dble(P(I,3)/P(I,4))
2219            IF(ABS(DBETA).GE.1.D0) THEN
2220               DB=dble(HINT1(2))
2221               IF(DB.GT.0.99999999D0) THEN
2222 C                ********Rescale boost vector if too close to unity.
2223                  WRITE(6,*) '(HIBOOT:) boost vector too large'
2224                  DB=0.99999999D0
2225               ENDIF
2226               DGA=1D0/SQRT(1D0-DB**2)
2227               DP3=dble(P(I,3))
2228               DP4=dble(P(I,4))
2229               P(I,3)=sngl((DP3+DB*DP4)*DGA)
2230               P(I,4)=sngl((DP4+DB*DP3)*DGA)
2231               GO TO 100
2232            ENDIF
2233            Y=0.5*sngl(DLOG((1.D0+DBETA)/(1.D0-DBETA)))
2234            AMT=SQRT(P(I,1)**2+P(I,2)**2+P(I,5)**2)
2235            P(I,3)=AMT*SINH(Y+HINT1(3))
2236            P(I,4)=AMT*COSH(Y+HINT1(3))
2237 100        CONTINUE
2238         RETURN
2239         END
2240 C
2241 C
2242 C
2243 C
2244         SUBROUTINE QUENCH(JPJT,NTP)
2245         PARAMETER (MAXSTR=150001)
2246         DIMENSION RDP(300),LQP(300),RDT(300),LQT(300)
2247         COMMON/hjcrdn/YP(3,300),YT(3,300)
2248 cc      SAVE /hjcrdn/
2249         COMMON/HPARNT/HIPR1(100),IHPR2(50),HINT1(100),IHNT2(50)
2250 cc      SAVE /HPARNT/
2251 C
2252         COMMON/HJJET1/NPJ(300),KFPJ(300,500),PJPX(300,500),
2253      &                PJPY(300,500),PJPZ(300,500),PJPE(300,500),
2254      &                PJPM(300,500),NTJ(300),KFTJ(300,500),
2255      &                PJTX(300,500),PJTY(300,500),PJTZ(300,500),
2256      &                PJTE(300,500),PJTM(300,500)
2257 cc      SAVE /HJJET1/
2258         COMMON/HJJET2/NSG,NJSG(MAXSTR),IASG(MAXSTR,3),K1SG(MAXSTR,100),
2259      &       K2SG(MAXSTR,100),PXSG(MAXSTR,100),PYSG(MAXSTR,100),
2260      &       PZSG(MAXSTR,100),PESG(MAXSTR,100),PMSG(MAXSTR,100)
2261 cc      SAVE /HJJET2/
2262         COMMON/HSTRNG/NFP(300,15),PP(300,15),NFT(300,15),PT(300,15)
2263 cc      SAVE /HSTRNG/
2264       COMMON/RNDF77/NSEED
2265 cc      SAVE /RNDF77/
2266         SAVE
2267 C
2268 c     Uzhi:
2269         BB=HINT1(19)
2270         PHI=HINT1(20)
2271         BBX=BB*COS(PHI)
2272         BBY=BB*SIN(PHI)
2273 c
2274         IF(NTP.EQ.2) GO TO 400
2275         IF(NTP.EQ.3) GO TO 2000
2276 C*******************************************************
2277 C Jet interaction for proj jet in the direction PHIP
2278 C******************************************************
2279 C
2280         IF(NFP(JPJT,7).NE.1) RETURN
2281
2282         JP=JPJT
2283         DO 290 I=1,NPJ(JP)
2284            PTJET0=SQRT(PJPX(JP,I)**2+PJPY(JP,I)**2)
2285            IF(PTJET0.LE.HIPR1(11)) GO TO 290
2286            PTOT=SQRT(PTJET0*PTJET0+PJPZ(JP,I)**2)
2287            IF(PTOT.LT.HIPR1(8)) GO TO 290
2288            PHIP=ULANGL(PJPX(JP,I),PJPY(JP,I))
2289 C******* find the wounded proj which can interact with jet***
2290            KP=0
2291            DO 100 I2=1,IHNT2(1)
2292               IF(NFP(I2,5).NE.3 .OR. I2.EQ.JP) GO TO 100
2293               DX=YP(1,I2)-YP(1,JP)
2294               DY=YP(2,I2)-YP(2,JP)
2295               PHI=ULANGL(DX,DY)
2296               DPHI=ABS(PHI-PHIP)
2297 c     Uzhi:
2298               IF(DPHI.GE.HIPR1(40)) DPHI=2.*HIPR1(40)-DPHI
2299               IF(DPHI.GE.HIPR1(40)/2.0) GO TO 100
2300               RD0=SQRT(DX*DX+DY*DY)
2301               IF(RD0*SIN(DPHI).GT.HIPR1(12)) GO TO 100
2302               KP=KP+1
2303               LQP(KP)=I2
2304               RDP(KP)=COS(DPHI)*RD0
2305  100           CONTINUE
2306 C*******        rearrange according decending rd************
2307            DO 110 I2=1,KP-1
2308               DO 110 J2=I2+1,KP
2309                  IF(RDP(I2).LT.RDP(J2)) GO TO 110
2310                  RD=RDP(I2)
2311                  LQ=LQP(I2)
2312                  RDP(I2)=RDP(J2)
2313                  LQP(I2)=LQP(J2)
2314                  RDP(J2)=RD
2315                  LQP(J2)=LQ
2316  110              CONTINUE
2317 C****** find wounded targ which can interact with jet********
2318               KT=0
2319               DO 120 I2=1,IHNT2(3)
2320                  IF(NFT(I2,5).NE.3) GO TO 120
2321                  DX=YT(1,I2)-YP(1,JP)-BBX
2322                  DY=YT(2,I2)-YP(2,JP)-BBY
2323                  PHI=ULANGL(DX,DY)
2324                  DPHI=ABS(PHI-PHIP)
2325 c     Uzhi:
2326                  IF(DPHI.GE.HIPR1(40)) DPHI=2.*HIPR1(40)-DPHI
2327                  IF(DPHI.GT.HIPR1(40)/2.0) GO TO 120
2328                  RD0=SQRT(DX*DX+DY*DY)
2329                  IF(RD0*SIN(DPHI).GT.HIPR1(12)) GO TO 120
2330                  KT=KT+1
2331                  LQT(KT)=I2
2332                  RDT(KT)=COS(DPHI)*RD0
2333  120              CONTINUE
2334 C*******        rearrange according decending rd************
2335               DO 130 I2=1,KT-1
2336                  DO 130 J2=I2+1,KT
2337                     IF(RDT(I2).LT.RDT(J2)) GO TO 130
2338                     RD=RDT(I2)
2339                     LQ=LQT(I2)
2340                     RDT(I2)=RDT(J2)
2341                     LQT(I2)=LQT(J2)
2342                     RDT(J2)=RD
2343                     LQT(J2)=LQ
2344  130                 CONTINUE
2345
2346                  MP=0
2347                  MT=0
2348                  R0=0.0
2349                  NQ=0
2350                  DP=0.0
2351                  PTOT=SQRT(PJPX(JP,I)**2+PJPY(JP,I)**2+PJPZ(JP,I)**2)
2352                  V1=PJPX(JP,I)/PTOT
2353                  V2=PJPY(JP,I)/PTOT
2354                  V3=PJPZ(JP,I)/PTOT
2355
2356  200                 RN=RANART(NSEED)
2357  210                 IF(MT.GE.KT .AND. MP.GE.KP) GO TO 290
2358                  IF(MT.GE.KT) GO TO 220
2359                  IF(MP.GE.KP) GO TO 240
2360                  IF(RDP(MP+1).GT.RDT(MT+1)) GO TO 240
2361  220                 MP=MP+1
2362                  DRR=RDP(MP)-R0
2363                  IF(RN.GE.1.0-EXP(-DRR/HIPR1(13))) GO TO 210
2364                  DP=DRR*HIPR1(14)
2365                  IF(KFPJ(JP,I).NE.21) DP=0.5*DP
2366 C        ********string tension of quark jet is 0.5 of gluon's
2367                  IF(DP.LE.0.2) GO TO 210
2368                  IF(PTOT.LE.0.4) GO TO 290
2369                  IF(PTOT.LE.DP) DP=PTOT-0.2
2370                  DE=DP
2371
2372                  IF(KFPJ(JP,I).NE.21) THEN
2373                     PRSHU=PP(LQP(MP),1)**2+PP(LQP(MP),2)**2
2374      &                   +PP(LQP(MP),3)**2
2375                     DE=SQRT(PJPM(JP,I)**2+PTOT**2)
2376      &                        -SQRT(PJPM(JP,I)**2+(PTOT-DP)**2)
2377                     ERSHU=(PP(LQP(MP),4)+DE-DP)**2
2378                     AMSHU=ERSHU-PRSHU
2379                     IF(AMSHU.LT.HIPR1(1)*HIPR1(1)) GO TO 210
2380                     PP(LQP(MP),4)=SQRT(ERSHU)
2381                     PP(LQP(MP),5)=SQRT(AMSHU)
2382                  ENDIF
2383 C                ********reshuffle the energy when jet has mass
2384                  R0=RDP(MP)
2385                  DP1=DP*V1
2386                  DP2=DP*V2
2387                  DP3=DP*V3
2388 C                ********momentum and energy transfer from jet
2389
2390                  NPJ(LQP(MP))=NPJ(LQP(MP))+1
2391                  KFPJ(LQP(MP),NPJ(LQP(MP)))=21
2392                  PJPX(LQP(MP),NPJ(LQP(MP)))=DP1
2393                  PJPY(LQP(MP),NPJ(LQP(MP)))=DP2
2394                  PJPZ(LQP(MP),NPJ(LQP(MP)))=DP3
2395                  PJPE(LQP(MP),NPJ(LQP(MP)))=DP
2396                  PJPM(LQP(MP),NPJ(LQP(MP)))=0.0
2397                  GO TO 260
2398
2399  240                 MT=MT+1
2400                  DRR=RDT(MT)-R0
2401                  IF(RN.GE.1.0-EXP(-DRR/HIPR1(13))) GO TO 210
2402                  DP=DRR*HIPR1(14)
2403                  IF(DP.LE.0.2) GO TO 210
2404                  IF(PTOT.LE.0.4) GO TO 290
2405                  IF(PTOT.LE.DP) DP=PTOT-0.2
2406                  DE=DP
2407
2408                  IF(KFPJ(JP,I).NE.21) THEN
2409                     PRSHU=PT(LQT(MT),1)**2+PT(LQT(MT),2)**2
2410      &                   +PT(LQT(MT),3)**2
2411                     DE=SQRT(PJPM(JP,I)**2+PTOT**2)
2412      &                        -SQRT(PJPM(JP,I)**2+(PTOT-DP)**2)
2413                     ERSHU=(PT(LQT(MT),4)+DE-DP)**2
2414                     AMSHU=ERSHU-PRSHU
2415                     IF(AMSHU.LT.HIPR1(1)*HIPR1(1)) GO TO 210
2416                     PT(LQT(MT),4)=SQRT(ERSHU)
2417                     PT(LQT(MT),5)=SQRT(AMSHU)
2418                  ENDIF
2419 C                ********reshuffle the energy when jet has mass
2420
2421                  R0=RDT(MT)
2422                  DP1=DP*V1
2423                  DP2=DP*V2
2424                  DP3=DP*V3
2425 C                ********momentum and energy transfer from jet
2426                  NTJ(LQT(MT))=NTJ(LQT(MT))+1
2427                  KFTJ(LQT(MT),NTJ(LQT(MT)))=21
2428                  PJTX(LQT(MT),NTJ(LQT(MT)))=DP1
2429                  PJTY(LQT(MT),NTJ(LQT(MT)))=DP2
2430                  PJTZ(LQT(MT),NTJ(LQT(MT)))=DP3
2431                  PJTE(LQT(MT),NTJ(LQT(MT)))=DP
2432                  PJTM(LQT(MT),NTJ(LQT(MT)))=0.0
2433
2434  260                 PJPX(JP,I)=(PTOT-DP)*V1
2435                  PJPY(JP,I)=(PTOT-DP)*V2
2436                  PJPZ(JP,I)=(PTOT-DP)*V3
2437                  PJPE(JP,I)=PJPE(JP,I)-DE
2438
2439                  PTOT=PTOT-DP
2440                  NQ=NQ+1
2441                  GO TO 200
2442  290              CONTINUE
2443
2444               RETURN
2445
2446 C*******************************************************
2447 C Jet interaction for target jet in the direction PHIT
2448 C******************************************************
2449 C
2450 C******* find the wounded proj which can interact with jet***
2451
2452  400              IF(NFT(JPJT,7).NE.1) RETURN
2453               JT=JPJT
2454               DO 690 I=1,NTJ(JT)
2455                  PTJET0=SQRT(PJTX(JT,I)**2+PJTY(JT,I)**2)
2456                  IF(PTJET0.LE.HIPR1(11)) GO TO 690
2457                  PTOT=SQRT(PTJET0*PTJET0+PJTZ(JT,I)**2)
2458                  IF(PTOT.LT.HIPR1(8)) GO TO 690
2459                  PHIT=ULANGL(PJTX(JT,I),PJTY(JT,I))
2460                  KP=0
2461                  DO 500 I2=1,IHNT2(1)
2462                     IF(NFP(I2,5).NE.3) GO TO 500
2463                     DX=YP(1,I2)+BBX-YT(1,JT)
2464                     DY=YP(2,I2)+BBY-YT(2,JT)
2465                     PHI=ULANGL(DX,DY)
2466                     DPHI=ABS(PHI-PHIT)
2467 c     Uzhi:
2468                     IF(DPHI.GE.HIPR1(40)) DPHI=2.*HIPR1(40)-DPHI
2469                     IF(DPHI.GT.HIPR1(40)/2.0) GO TO 500
2470                     RD0=SQRT(DX*DX+DY*DY)
2471                     IF(RD0*SIN(DPHI).GT.HIPR1(12)) GO TO 500
2472                     KP=KP+1
2473                     LQP(KP)=I2
2474                     RDP(KP)=COS(DPHI)*RD0
2475  500                 CONTINUE
2476 C*******        rearrange according to decending rd************
2477                  DO 510 I2=1,KP-1
2478                     DO 510 J2=I2+1,KP
2479                        IF(RDP(I2).LT.RDP(J2)) GO TO 510
2480                        RD=RDP(I2)
2481                        LQ=LQP(I2)
2482                        RDP(I2)=RDP(J2)
2483                        LQP(I2)=LQP(J2)
2484                        RDP(J2)=RD
2485                        LQP(J2)=LQ
2486  510                    CONTINUE
2487 C****** find wounded targ which can interact with jet********
2488                     KT=0
2489                     DO 520 I2=1,IHNT2(3)
2490                        IF(NFT(I2,5).NE.3 .OR. I2.EQ.JT) GO TO 520
2491                        DX=YT(1,I2)-YT(1,JT)
2492                        DY=YT(2,I2)-YT(2,JT)
2493                        PHI=ULANGL(DX,DY)
2494                        DPHI=ABS(PHI-PHIT)
2495 c     Uzhi:
2496                        IF(DPHI.GE.HIPR1(40)) DPHI=2.*HIPR1(40)-DPHI
2497                        IF(DPHI.GT.HIPR1(40)/2.0) GO TO 520
2498                        RD0=SQRT(DX*DX+DY*DY)
2499                        IF(RD0*SIN(DPHI).GT.HIPR1(12)) GO TO 520
2500                        KT=KT+1
2501                        LQT(KT)=I2
2502                        RDT(KT)=COS(DPHI)*RD0
2503  520                    CONTINUE
2504 C*******        rearrange according to decending rd************
2505                     DO 530 I2=1,KT-1
2506                        DO 530 J2=I2+1,KT
2507                           IF(RDT(I2).LT.RDT(J2)) GO TO 530
2508                           RD=RDT(I2)
2509                           LQ=LQT(I2)
2510                           RDT(I2)=RDT(J2)
2511                           LQT(I2)=LQT(J2)
2512                           RDT(J2)=RD
2513                           LQT(J2)=LQ
2514  530                       CONTINUE
2515
2516                        MP=0
2517                        MT=0
2518                        NQ=0
2519                        DP=0.0
2520                        R0=0.0
2521                 PTOT=SQRT(PJTX(JT,I)**2+PJTY(JT,I)**2+PJTZ(JT,I)**2)
2522                 V1=PJTX(JT,I)/PTOT
2523                 V2=PJTY(JT,I)/PTOT
2524                 V3=PJTZ(JT,I)/PTOT
2525
2526  600                RN=RANART(NSEED)
2527  610                IF(MT.GE.KT .AND. MP.GE.KP) GO TO 690
2528                 IF(MT.GE.KT) GO TO 620
2529                 IF(MP.GE.KP) GO TO 640
2530                 IF(RDP(MP+1).GT.RDT(MT+1)) GO TO 640
2531 620                MP=MP+1
2532                 DRR=RDP(MP)-R0
2533                 IF(RN.GE.1.0-EXP(-DRR/HIPR1(13))) GO TO 610
2534                 DP=DRR*HIPR1(14)
2535                 IF(KFTJ(JT,I).NE.21) DP=0.5*DP
2536 C        ********string tension of quark jet is 0.5 of gluon's
2537                 IF(DP.LE.0.2) GO TO 610
2538                 IF(PTOT.LE.0.4) GO TO 690
2539                 IF(PTOT.LE.DP) DP=PTOT-0.2
2540                 DE=DP
2541 C
2542                 IF(KFTJ(JT,I).NE.21) THEN
2543                    PRSHU=PP(LQP(MP),1)**2+PP(LQP(MP),2)**2
2544      &                   +PP(LQP(MP),3)**2
2545                    DE=SQRT(PJTM(JT,I)**2+PTOT**2)
2546      &                     -SQRT(PJTM(JT,I)**2+(PTOT-DP)**2)
2547                    ERSHU=(PP(LQP(MP),4)+DE-DP)**2
2548                    AMSHU=ERSHU-PRSHU
2549                    IF(AMSHU.LT.HIPR1(1)*HIPR1(1)) GO TO 610
2550                    PP(LQP(MP),4)=SQRT(ERSHU)
2551                    PP(LQP(MP),5)=SQRT(AMSHU)
2552                 ENDIF
2553 C                ********reshuffle the energy when jet has mass
2554 C
2555                 R0=RDP(MP)
2556                 DP1=DP*V1
2557                 DP2=DP*V2
2558                 DP3=DP*V3
2559 C                ********momentum and energy transfer from jet
2560                 NPJ(LQP(MP))=NPJ(LQP(MP))+1
2561                 KFPJ(LQP(MP),NPJ(LQP(MP)))=21
2562                 PJPX(LQP(MP),NPJ(LQP(MP)))=DP1
2563                 PJPY(LQP(MP),NPJ(LQP(MP)))=DP2
2564                 PJPZ(LQP(MP),NPJ(LQP(MP)))=DP3
2565                 PJPE(LQP(MP),NPJ(LQP(MP)))=DP
2566                 PJPM(LQP(MP),NPJ(LQP(MP)))=0.0
2567
2568                 GO TO 660
2569
2570 640                MT=MT+1
2571                 DRR=RDT(MT)-R0
2572                 IF(RN.GE.1.0-EXP(-DRR/HIPR1(13))) GO TO 610
2573                 DP=DRR*HIPR1(14)
2574                 IF(DP.LE.0.2) GO TO 610
2575                 IF(PTOT.LE.0.4) GO TO 690
2576                 IF(PTOT.LE.DP) DP=PTOT-0.2
2577                 DE=DP
2578
2579                 IF(KFTJ(JT,I).NE.21) THEN
2580                    PRSHU=PT(LQT(MT),1)**2+PT(LQT(MT),2)**2
2581      &                   +PT(LQT(MT),3)**2
2582                    DE=SQRT(PJTM(JT,I)**2+PTOT**2)
2583      &                     -SQRT(PJTM(JT,I)**2+(PTOT-DP)**2)
2584                    ERSHU=(PT(LQT(MT),4)+DE-DP)**2
2585                    AMSHU=ERSHU-PRSHU
2586                    IF(AMSHU.LT.HIPR1(1)*HIPR1(1)) GO TO 610
2587                    PT(LQT(MT),4)=SQRT(ERSHU)
2588                    PT(LQT(MT),5)=SQRT(AMSHU)
2589                 ENDIF
2590 C                ********reshuffle the energy when jet has mass
2591
2592                 R0=RDT(MT)
2593                 DP1=DP*V1
2594                 DP2=DP*V2
2595                 DP3=DP*V3
2596 C                ********momentum and energy transfer from jet
2597                 NTJ(LQT(MT))=NTJ(LQT(MT))+1
2598                 KFTJ(LQT(MT),NTJ(LQT(MT)))=21
2599                 PJTX(LQT(MT),NTJ(LQT(MT)))=DP1
2600                 PJTY(LQT(MT),NTJ(LQT(MT)))=DP2
2601                 PJTZ(LQT(MT),NTJ(LQT(MT)))=DP3
2602                 PJTE(LQT(MT),NTJ(LQT(MT)))=DP
2603                 PJTM(LQT(MT),NTJ(LQT(MT)))=0.0
2604
2605 660                PJTX(JT,I)=(PTOT-DP)*V1
2606                 PJTY(JT,I)=(PTOT-DP)*V2
2607                 PJTZ(JT,I)=(PTOT-DP)*V3
2608                 PJTE(JT,I)=PJTE(JT,I)-DE
2609
2610                 PTOT=PTOT-DP
2611                 NQ=NQ+1
2612                 GO TO 600
2613 690        CONTINUE
2614         RETURN
2615 C********************************************************
2616 C        Q-QBAR jet interaction
2617 C********************************************************
2618 2000        ISG=JPJT
2619         IF(IASG(ISG,3).NE.1) RETURN
2620 C
2621         JP=IASG(ISG,1)
2622         JT=IASG(ISG,2)
2623         XJ=(YP(1,JP)+BBX+YT(1,JT))/2.0
2624         YJ=(YP(2,JP)+BBY+YT(2,JT))/2.0
2625         DO 2690 I=1,NJSG(ISG)
2626            PTJET0=SQRT(PXSG(ISG,I)**2+PYSG(ISG,I)**2)
2627            IF(PTJET0.LE.HIPR1(11).OR.PESG(ISG,I).LT.HIPR1(1))
2628      &            GO TO 2690
2629            PTOT=SQRT(PTJET0*PTJET0+PZSG(ISG,I)**2)
2630            IF(PTOT.LT.MAX(HIPR1(1),HIPR1(8))) GO TO 2690
2631            PHIQ=ULANGL(PXSG(ISG,I),PYSG(ISG,I))
2632            KP=0
2633            DO 2500 I2=1,IHNT2(1)
2634               IF(NFP(I2,5).NE.3.OR.I2.EQ.JP) GO TO 2500
2635               DX=YP(1,I2)+BBX-XJ
2636               DY=YP(2,I2)+BBY-YJ
2637               PHI=ULANGL(DX,DY)
2638               DPHI=ABS(PHI-PHIQ)
2639 c     Uzhi:
2640               IF(DPHI.GE.HIPR1(40)) DPHI=2.*HIPR1(40)-DPHI
2641               IF(DPHI.GT.HIPR1(40)/2.0) GO TO 2500
2642               RD0=SQRT(DX*DX+DY*DY)
2643               IF(RD0*SIN(DPHI).GT.HIPR1(12)) GO TO 2500
2644               KP=KP+1
2645               LQP(KP)=I2
2646               RDP(KP)=COS(DPHI)*RD0
2647  2500           CONTINUE
2648 C*******        rearrange according to decending rd************
2649            DO 2510 I2=1,KP-1
2650               DO 2510 J2=I2+1,KP
2651                  IF(RDP(I2).LT.RDP(J2)) GO TO 2510
2652                  RD=RDP(I2)
2653                  LQ=LQP(I2)
2654                  RDP(I2)=RDP(J2)
2655                  LQP(I2)=LQP(J2)
2656                  RDP(J2)=RD
2657                  LQP(J2)=LQ
2658  2510              CONTINUE
2659 C****** find wounded targ which can interact with jet********
2660               KT=0
2661               DO 2520 I2=1,IHNT2(3)
2662                  IF(NFT(I2,5).NE.3 .OR. I2.EQ.JT) GO TO 2520
2663                  DX=YT(1,I2)-XJ
2664                  DY=YT(2,I2)-YJ
2665                  PHI=ULANGL(DX,DY)
2666                  DPHI=ABS(PHI-PHIQ)
2667 c     Uzhi:
2668                  IF(DPHI.GE.HIPR1(40)) DPHI=2.*HIPR1(40)-DPHI
2669                  IF(DPHI.GT.HIPR1(40)/2.0) GO TO 2520
2670                  RD0=SQRT(DX*DX+DY*DY)
2671                  IF(RD0*SIN(DPHI).GT.HIPR1(12)) GO TO 2520
2672                  KT=KT+1
2673                  LQT(KT)=I2
2674                  RDT(KT)=COS(DPHI)*RD0
2675  2520              CONTINUE
2676 C*******        rearrange according to decending rd************
2677               DO 2530 I2=1,KT-1
2678                  DO 2530 J2=I2+1,KT
2679                     IF(RDT(I2).LT.RDT(J2)) GO TO 2530
2680                     RD=RDT(I2)
2681                     LQ=LQT(I2)
2682                     RDT(I2)=RDT(J2)
2683                     LQT(I2)=LQT(J2)
2684                     RDT(J2)=RD
2685                     LQT(J2)=LQ
2686  2530                 CONTINUE
2687
2688                  MP=0
2689                  MT=0
2690                  NQ=0
2691                  DP=0.0
2692                  R0=0.0
2693                  PTOT=SQRT(PXSG(ISG,I)**2+PYSG(ISG,I)**2
2694      &                +PZSG(ISG,I)**2)
2695                  V1=PXSG(ISG,I)/PTOT
2696                  V2=PYSG(ISG,I)/PTOT
2697                  V3=PZSG(ISG,I)/PTOT
2698
2699  2600                 RN=RANART(NSEED)
2700  2610                 IF(MT.GE.KT .AND. MP.GE.KP) GO TO 2690
2701                  IF(MT.GE.KT) GO TO 2620
2702                  IF(MP.GE.KP) GO TO 2640
2703                  IF(RDP(MP+1).GT.RDT(MT+1)) GO TO 2640
2704  2620                 MP=MP+1
2705                  DRR=RDP(MP)-R0
2706                  IF(RN.GE.1.0-EXP(-DRR/HIPR1(13))) GO TO 2610
2707                  DP=DRR*HIPR1(14)/2.0
2708                  IF(DP.LE.0.2) GO TO 2610
2709                  IF(PTOT.LE.0.4) GO TO 2690
2710                  IF(PTOT.LE.DP) DP=PTOT-0.2
2711                  DE=DP
2712 C
2713                  IF(K2SG(ISG,I).NE.21) THEN
2714                     IF(PTOT.LT.DP+HIPR1(1)) GO TO 2690
2715                     PRSHU=PP(LQP(MP),1)**2+PP(LQP(MP),2)**2
2716      &                    +PP(LQP(MP),3)**2
2717                     DE=SQRT(PMSG(ISG,I)**2+PTOT**2)
2718      &                       -SQRT(PMSG(ISG,I)**2+(PTOT-DP)**2)
2719                     ERSHU=(PP(LQP(MP),4)+DE-DP)**2
2720                     AMSHU=ERSHU-PRSHU
2721                     IF(AMSHU.LT.HIPR1(1)*HIPR1(1)) GO TO 2610
2722                     PP(LQP(MP),4)=SQRT(ERSHU)
2723                     PP(LQP(MP),5)=SQRT(AMSHU)
2724                  ENDIF
2725 C                ********reshuffle the energy when jet has mass
2726 C
2727                  R0=RDP(MP)
2728                  DP1=DP*V1
2729                  DP2=DP*V2
2730                  DP3=DP*V3
2731 C                ********momentum and energy transfer from jet
2732                  NPJ(LQP(MP))=NPJ(LQP(MP))+1
2733                  KFPJ(LQP(MP),NPJ(LQP(MP)))=21
2734                  PJPX(LQP(MP),NPJ(LQP(MP)))=DP1
2735                  PJPY(LQP(MP),NPJ(LQP(MP)))=DP2
2736                  PJPZ(LQP(MP),NPJ(LQP(MP)))=DP3
2737                  PJPE(LQP(MP),NPJ(LQP(MP)))=DP
2738                  PJPM(LQP(MP),NPJ(LQP(MP)))=0.0
2739
2740                  GO TO 2660
2741
2742  2640                 MT=MT+1
2743                  DRR=RDT(MT)-R0
2744                  IF(RN.GE.1.0-EXP(-DRR/HIPR1(13))) GO TO 2610
2745                  DP=DRR*HIPR1(14)
2746                  IF(DP.LE.0.2) GO TO 2610
2747                  IF(PTOT.LE.0.4) GO TO 2690
2748                  IF(PTOT.LE.DP) DP=PTOT-0.2
2749                  DE=DP
2750
2751                  IF(K2SG(ISG,I).NE.21) THEN
2752                     IF(PTOT.LT.DP+HIPR1(1)) GO TO 2690
2753                     PRSHU=PT(LQT(MT),1)**2+PT(LQT(MT),2)**2
2754      &                    +PT(LQT(MT),3)**2
2755                     DE=SQRT(PMSG(ISG,I)**2+PTOT**2)
2756      &                       -SQRT(PMSG(ISG,I)**2+(PTOT-DP)**2)
2757                     ERSHU=(PT(LQT(MT),4)+DE-DP)**2
2758                     AMSHU=ERSHU-PRSHU
2759                     IF(AMSHU.LT.HIPR1(1)*HIPR1(1)) GO TO 2610
2760                     PT(LQT(MT),4)=SQRT(ERSHU)
2761                     PT(LQT(MT),5)=SQRT(AMSHU)
2762                  ENDIF
2763 C               ********reshuffle the energy when jet has mass
2764
2765                  R0=RDT(MT)
2766                  DP1=DP*V1
2767                  DP2=DP*V2
2768                  DP3=DP*V3
2769 C                ********momentum and energy transfer from jet
2770                  NTJ(LQT(MT))=NTJ(LQT(MT))+1
2771                  KFTJ(LQT(MT),NTJ(LQT(MT)))=21
2772                  PJTX(LQT(MT),NTJ(LQT(MT)))=DP1
2773                  PJTY(LQT(MT),NTJ(LQT(MT)))=DP2
2774                  PJTZ(LQT(MT),NTJ(LQT(MT)))=DP3
2775                  PJTE(LQT(MT),NTJ(LQT(MT)))=DP
2776                  PJTM(LQT(MT),NTJ(LQT(MT)))=0.0
2777
2778  2660                 PXSG(ISG,I)=(PTOT-DP)*V1
2779                  PYSG(ISG,I)=(PTOT-DP)*V2
2780                  PZSG(ISG,I)=(PTOT-DP)*V3
2781                  PESG(ISG,I)=PESG(ISG,I)-DE
2782
2783                  PTOT=PTOT-DP
2784                  NQ=NQ+1
2785                  GO TO 2600
2786  2690        CONTINUE
2787         RETURN
2788         END
2789
2790 C
2791 C
2792 C
2793 C
2794         SUBROUTINE HIJFRG(JTP,NTP,IERROR)
2795 C        NTP=1, fragment proj string, NTP=2, targ string,
2796 C       NTP=3, independent
2797 C        strings from jets.  JTP is the line number of the string
2798 C*******Fragment all leadng strings of proj and targ**************
2799 C        IHNT2(1)=atomic #, IHNT2(2)=proton #(=-1 if anti-proton)  *
2800 C******************************************************************
2801         PARAMETER (MAXSTR=150001)
2802         COMMON/HPARNT/HIPR1(100),IHPR2(50),HINT1(100),IHNT2(50)
2803 cc      SAVE /HPARNT/
2804         COMMON/HIJDAT/HIDAT0(10,10),HIDAT(10)
2805 cc      SAVE /HIJDAT/
2806         COMMON/HSTRNG/NFP(300,15),PP(300,15),NFT(300,15),PT(300,15)
2807 cc      SAVE /HSTRNG/
2808         COMMON/HJJET1/NPJ(300),KFPJ(300,500),PJPX(300,500),
2809      &                PJPY(300,500),PJPZ(300,500),PJPE(300,500),
2810      &                PJPM(300,500),NTJ(300),KFTJ(300,500),
2811      &                PJTX(300,500),PJTY(300,500),PJTZ(300,500),
2812      &                PJTE(300,500),PJTM(300,500)
2813 cc      SAVE /HJJET1/
2814         COMMON/HJJET2/NSG,NJSG(MAXSTR),IASG(MAXSTR,3),K1SG(MAXSTR,100),
2815      &       K2SG(MAXSTR,100),PXSG(MAXSTR,100),PYSG(MAXSTR,100),
2816      &       PZSG(MAXSTR,100),PESG(MAXSTR,100),PMSG(MAXSTR,100)
2817 cc      SAVE /HJJET2/
2818 C
2819         COMMON/LUJETS/N,K(9000,5),P(9000,5),V(9000,5)
2820 cc      SAVE /LUJETS/
2821         COMMON/LUDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
2822 cc      SAVE /LUDAT1/
2823       COMMON/RNDF77/NSEED
2824 cc      SAVE /RNDF77/
2825 clin-4/11/01 soft:
2826       common/anim/nevent,isoft,isflag,izpc
2827 cc      SAVE /anim/
2828         SAVE
2829
2830 cbz3/12/99
2831 c.....set up fragmentation function according to the number of collisions
2832 c.....a wounded nucleon has suffered
2833 c        IF (NTP .EQ. 1) THEN
2834 c           NCOLL = NFP(JTP, 11)
2835 c        ELSE IF (NTP .EQ. 2) THEN
2836 c           NCOLL = NFT(JTP, 11)
2837 c        ELSE IF (NTP .EQ. 3) THEN
2838 c           NCOLL = (NFP(IASG(JTP,1), 11) + NFT(IASG(JTP,2), 11)) / 2
2839 c        END IF
2840 c        IF (NCOLL .LE. 1) THEN
2841 c           PARJ(5) = 0.5
2842 c        ELSE IF (NCOLL .EQ. 2) THEN
2843 c           PARJ(5) = 0.75
2844 c        ELSE IF (NCOLL .EQ. 3) THEN
2845 c           PARJ(5) = 1.17
2846 c        ELSE IF (NCOLL .EQ. 4) THEN
2847 c           PARJ(5) = 2.0
2848 c        ELSE IF (NCOLL .EQ. 5) THEN
2849 c           PARJ(5) = 4.5
2850 c        ELSE IF (NCOLL .GE. 6) THEN
2851 c           PARJ(5) = 49.5
2852 c        END IF
2853 c        PARJ(5) = 0.5
2854 cbz3/12/99 end
2855
2856         IERROR=0
2857         CALL LUEDIT(0)
2858         N=0
2859 C                        ********initialize the document lines
2860         IF(NTP.EQ.3) THEN
2861                 ISG=JTP
2862                 N=NJSG(ISG)
2863                 DO 100 I=1,NJSG(ISG)
2864                    K(I,1)=K1SG(ISG,I)
2865                    K(I,2)=K2SG(ISG,I)
2866                    P(I,1)=PXSG(ISG,I)
2867                    P(I,2)=PYSG(ISG,I)
2868                    P(I,3)=PZSG(ISG,I)
2869                    P(I,4)=PESG(ISG,I)
2870                    P(I,5)=PMSG(ISG,I)
2871  100            CONTINUE
2872
2873 C                IF(IHPR2(1).GT.0) CALL ATTRAD(IERROR)
2874 c                IF(IERROR.NE.0) RETURN
2875 C                CALL LULIST(1)
2876                 if(isoft.ne.2.or.isflag.ne.0) CALL LUEXEC
2877              RETURN
2878         ENDIF
2879 C
2880         IF(NTP.EQ.2) GO TO 200
2881         IF(JTP.GT.IHNT2(1))   RETURN
2882         IF(NFP(JTP,5).NE.3.AND.NFP(JTP,3).NE.0
2883      &            .AND.NPJ(JTP).EQ.0.AND.NFP(JTP,10).EQ.0) GO TO 1000
2884         IF(NFP(JTP,15).EQ.-1) THEN
2885                 KF1=NFP(JTP,2)
2886                 KF2=NFP(JTP,1)
2887                 PQ21=PP(JTP,6)
2888                 PQ22=PP(JTP,7)
2889                 PQ11=PP(JTP,8)
2890                 PQ12=PP(JTP,9)
2891                 AM1=PP(JTP,15)
2892                 AM2=PP(JTP,14)
2893         ELSE
2894                 KF1=NFP(JTP,1)
2895                 KF2=NFP(JTP,2)
2896                 PQ21=PP(JTP,8)
2897                 PQ22=PP(JTP,9)
2898                 PQ11=PP(JTP,6)
2899                 PQ12=PP(JTP,7)
2900                 AM1=PP(JTP,14)
2901                 AM2=PP(JTP,15)
2902         ENDIF
2903
2904 C        ********for NFP(JTP,15)=-1 NFP(JTP,1) IS IN -Z DIRECTION
2905         PB1=PQ11+PQ21
2906         PB2=PQ12+PQ22
2907         PB3=PP(JTP,3)
2908         PECM=PP(JTP,5)
2909         BTZ=PB3/PP(JTP,4)
2910         IF((ABS(PB1-PP(JTP,1)).GT.0.01.OR.
2911      &     ABS(PB2-PP(JTP,2)).GT.0.01).AND.IHPR2(10).NE.0)
2912      &     WRITE(6,*) '  Pt of Q and QQ do not sum to the total',jtp
2913      &     ,ntp,pq11,pq21,pb1,'*',pq12,pq22,pb2,'*',pp(JTP,1),pp(JTP,2)
2914         GO TO 300
2915
2916 200        IF(JTP.GT.IHNT2(3))  RETURN
2917         IF(NFT(JTP,5).NE.3.AND.NFT(JTP,3).NE.0
2918      &           .AND.NTJ(JTP).EQ.0.AND.NFT(JTP,10).EQ.0) GO TO 1200
2919         IF(NFT(JTP,15).EQ.1) THEN
2920                 KF1=NFT(JTP,1)
2921                 KF2=NFT(JTP,2)
2922                 PQ11=PT(JTP,6)
2923                 PQ12=PT(JTP,7)
2924                 PQ21=PT(JTP,8)
2925                 PQ22=PT(JTP,9)
2926                 AM1=PT(JTP,14)
2927                 AM2=PT(JTP,15)
2928         ELSE
2929                 KF1=NFT(JTP,2)
2930                 KF2=NFT(JTP,1)
2931                 PQ11=PT(JTP,8)
2932                 PQ12=PT(JTP,9)
2933                 PQ21=PT(JTP,6)
2934                 PQ22=PT(JTP,7)
2935                 AM1=PT(JTP,15)
2936                 AM2=PT(JTP,14)
2937         ENDIF
2938 C        ********for NFT(JTP,15)=1 NFT(JTP,1) IS IN +Z DIRECTION
2939         PB1=PQ11+PQ21
2940         PB2=PQ12+PQ22
2941         PB3=PT(JTP,3)
2942         PECM=PT(JTP,5)
2943         BTZ=PB3/PT(JTP,4)
2944
2945         IF((ABS(PB1-PT(JTP,1)).GT.0.01.OR.
2946      &     ABS(PB2-PT(JTP,2)).GT.0.01).AND.IHPR2(10).NE.0)
2947      &     WRITE(6,*) '  Pt of Q and QQ do not sum to the total',jtp
2948      &     ,ntp,pq11,pq21,pb1,'*',pq12,pq22,pb2,'*',pt(JTP,1),pt(JTP,2)
2949 300        IF(PECM.LT.HIPR1(1)) THEN
2950            IERROR=1
2951            IF(IHPR2(10).EQ.0) RETURN
2952            WRITE(6,*) ' ECM=',PECM,' energy of the string is too small'
2953 clin:
2954            write (6,*) 'JTP,NTP,pq=',JTP,NTP,pq11,pq12,pq21,pq22
2955            RETURN
2956         ENDIF
2957         AMT=PECM**2+PB1**2+PB2**2
2958         AMT1=AM1**2+PQ11**2+PQ12**2
2959         AMT2=AM2**2+PQ21**2+PQ22**2
2960         PZCM=SQRT(ABS(AMT**2+AMT1**2+AMT2**2-2.0*AMT*AMT1
2961      &       -2.0*AMT*AMT2-2.0*AMT1*AMT2))/2.0/SQRT(AMT)
2962 C                *******PZ of end-partons in c.m. frame of the string
2963         K(1,1)=2
2964         K(1,2)=KF1
2965         P(1,1)=PQ11
2966         P(1,2)=PQ12
2967         P(1,3)=PZCM
2968         P(1,4)=SQRT(AMT1+PZCM**2)
2969         P(1,5)=AM1
2970         K(2,1)=1
2971         K(2,2)=KF2
2972         P(2,1)=PQ21
2973         P(2,2)=PQ22
2974         P(2,3)=-PZCM
2975         P(2,4)=SQRT(AMT2+PZCM**2)
2976         P(2,5)=AM2
2977         N=2
2978 C*****
2979         CALL HIROBO(0.0,0.0,0.0,0.0,BTZ)
2980         JETOT=0
2981         IF((PQ21**2+PQ22**2).GT.(PQ11**2+PQ12**2)) THEN
2982                 PMAX1=P(2,1)
2983                 PMAX2=P(2,2)
2984                 PMAX3=P(2,3)
2985         ELSE
2986                 PMAX1=P(1,1)
2987                 PMAX2=P(1,2)
2988                 PMAX3=P(1,3)
2989         ENDIF
2990         IF(NTP.EQ.1) THEN
2991                 PP(JTP,10)=PMAX1
2992                 PP(JTP,11)=PMAX2
2993                 PP(JTP,12)=PMAX3
2994         ELSE IF(NTP.EQ.2) THEN
2995                 PT(JTP,10)=PMAX1
2996                 PT(JTP,11)=PMAX2
2997                 PT(JTP,12)=PMAX3
2998         ENDIF
2999 C*******************attach produced jets to the leadng partons****
3000         IF(NTP.EQ.1.AND.NPJ(JTP).NE.0) THEN
3001                 JETOT=NPJ(JTP)
3002 C                IF(NPJ(JTP).GE.2) CALL HIJSRT(JTP,1)
3003 C                        ********sort jets in order of y
3004                 IEX=0
3005                 IF((ABS(KF1).GT.1000.AND.KF1.LT.0)
3006      &                        .OR.(ABS(KF1).LT.1000.AND.KF1.GT.0)) IEX=1
3007                 DO 520 I=N,2,-1
3008                 DO 520 J=1,5
3009                         II=NPJ(JTP)+I
3010                         K(II,J)=K(I,J)
3011                         P(II,J)=P(I,J)
3012                         V(II,J)=V(I,J)
3013 520                CONTINUE
3014
3015                 DO 540 I=1,NPJ(JTP)
3016                         DO 542 J=1,5
3017                                 K(I+1,J)=0
3018                                 V(I+1,J)=0
3019 542                        CONTINUE
3020                         I0=I
3021 clin-4/12/01:                        IF(IEX.EQ.1) I0=NPJ(JTP)-I+1
3022                         IF(IEX.EQ.1.and.(isoft.ne.2.or.isflag.ne.0))
3023      1 I0=NPJ(JTP)-I+1
3024 C                                ********reverse the order of jets
3025                         KK1=KFPJ(JTP,I0)
3026                         K(I+1,1)=2
3027                         K(I+1,2)=KK1
3028                         IF(KK1.NE.21 .AND. KK1.NE.0)  K(I+1,1)=
3029      &                          1+(ABS(KK1)+(2*IEX-1)*KK1)/2/ABS(KK1)
3030                         P(I+1,1)=PJPX(JTP,I0)
3031                         P(I+1,2)=PJPY(JTP,I0)
3032                         P(I+1,3)=PJPZ(JTP,I0)
3033                         P(I+1,4)=PJPE(JTP,I0)
3034                         P(I+1,5)=PJPM(JTP,I0)
3035 540                CONTINUE
3036                 N=N+NPJ(JTP)
3037         ELSE IF(NTP.EQ.2.AND.NTJ(JTP).NE.0) THEN
3038                 JETOT=NTJ(JTP)
3039 c                IF(NTJ(JTP).GE.2)  CALL HIJSRT(JTP,2)
3040 C                        ********sort jets in order of y
3041                 IEX=1
3042                 IF((ABS(KF2).GT.1000.AND.KF2.LT.0)
3043      &                        .OR.(ABS(KF2).LT.1000.AND.KF2.GT.0)) IEX=0
3044                 DO 560 I=N,2,-1
3045                 DO 560 J=1,5
3046                         II=NTJ(JTP)+I
3047                         K(II,J)=K(I,J)
3048                         P(II,J)=P(I,J)
3049                         V(II,J)=V(I,J)
3050 560                CONTINUE
3051                 DO 580 I=1,NTJ(JTP)
3052                         DO 582 J=1,5
3053                                 K(I+1,J)=0
3054                                 V(I+1,J)=0
3055 582                        CONTINUE
3056                         I0=I
3057 clin-4/12/01:                        IF(IEX.EQ.1) I0=NTJ(JTP)-I+1
3058                         IF(IEX.EQ.1.and.(isoft.ne.2.or.isflag.ne.0))
3059      1 I0=NTJ(JTP)-I+1
3060 C                                ********reverse the order of jets
3061                         KK1=KFTJ(JTP,I0)
3062                         K(I+1,1)=2
3063                         K(I+1,2)=KK1
3064                         IF(KK1.NE.21 .AND. KK1.NE.0) K(I+1,1)=
3065      &                           1+(ABS(KK1)+(2*IEX-1)*KK1)/2/ABS(KK1)
3066                         P(I+1,1)=PJTX(JTP,I0)
3067                         P(I+1,2)=PJTY(JTP,I0)
3068                         P(I+1,3)=PJTZ(JTP,I0)
3069                         P(I+1,4)=PJTE(JTP,I0)
3070                         P(I+1,5)=PJTM(JTP,I0)
3071 580                CONTINUE
3072                 N=N+NTJ(JTP)
3073         ENDIF
3074         IF(IHPR2(1).GT.0.AND.RANART(NSEED).LE.HIDAT(3)) THEN
3075              HDAT20=HIDAT(2)
3076              HPR150=HIPR1(5)
3077              IF(IHPR2(8).EQ.0.AND.IHPR2(3).EQ.0.AND.IHPR2(9).EQ.0)
3078      &                        HIDAT(2)=2.0
3079              IF(HINT1(1).GE.1000.0.AND.JETOT.EQ.0)THEN
3080                 HIDAT(2)=3.0
3081                 HIPR1(5)=5.0
3082              ENDIF
3083              CALL ATTRAD(IERROR)
3084              HIDAT(2)=HDAT20
3085              HIPR1(5)=HPR150
3086         ELSE IF(JETOT.EQ.0.AND.IHPR2(1).GT.0.AND.
3087      &                       HINT1(1).GE.1000.0.AND.
3088      &                RANART(NSEED).LE.0.8) THEN
3089                 HDAT20=HIDAT(2)
3090                 HPR150=HIPR1(5)
3091                 HIDAT(2)=3.0
3092                 HIPR1(5)=5.0
3093              IF(IHPR2(8).EQ.0.AND.IHPR2(3).EQ.0.AND.IHPR2(9).EQ.0)
3094      &                        HIDAT(2)=2.0
3095                 CALL ATTRAD(IERROR)
3096                 HIDAT(2)=HDAT20
3097                 HIPR1(5)=HPR150
3098         ENDIF
3099         IF(IERROR.NE.0) RETURN
3100 C                ******** conduct soft radiations
3101 C****************************
3102 C
3103 C
3104 clin-4/11/01 soft:
3105 c        CALL LUEXEC
3106         if(isoft.ne.2.or.isflag.ne.0) CALL LUEXEC
3107
3108         RETURN
3109
3110 1000        N=1
3111         K(1,1)=1
3112                K(1,2)=NFP(JTP,3)
3113         DO 1100 JJ=1,5
3114                        P(1,JJ)=PP(JTP,JJ)
3115 1100                CONTINUE
3116 C                        ********proj remain as a nucleon or delta
3117 clin-4/11/01 soft:
3118 c        CALL LUEXEC
3119         if(isoft.ne.2.or.isflag.ne.0) CALL LUEXEC
3120
3121 C        call lulist(1)
3122         RETURN
3123 C
3124 1200        N=1
3125         K(1,1)=1
3126         K(1,2)=NFT(JTP,3)
3127         DO 1300 JJ=1,5
3128                 P(1,JJ)=PT(JTP,JJ)
3129 1300        CONTINUE
3130 C                        ********targ remain as a nucleon or delta
3131 clin-4/11/01 soft:
3132 c        CALL LUEXEC
3133         if(isoft.ne.2.or.isflag.ne.0) CALL LUEXEC
3134
3135 C        call lulist(1)
3136         RETURN
3137         END
3138 C
3139 C
3140 C
3141 C
3142 C****************************************************************
3143 C        conduct soft radiation according to dipole approxiamtion
3144 C****************************************************************
3145         SUBROUTINE ATTRAD(IERROR)
3146 C
3147         COMMON/HPARNT/HIPR1(100),IHPR2(50),HINT1(100),IHNT2(50)
3148 cc      SAVE /HPARNT/
3149         COMMON/HIJDAT/HIDAT0(10,10),HIDAT(10)
3150 cc      SAVE /HIJDAT/
3151         COMMON/LUJETS/N,K(9000,5),P(9000,5),V(9000,5)
3152 cc      SAVE /LUJETS/
3153       COMMON/RNDF77/NSEED
3154 cc      SAVE /RNDF77/
3155         SAVE
3156         IERROR=0
3157
3158 C.....S INVARIANT MASS-SQUARED BETWEEN PARTONS I AND I+1......
3159 C.....SM IS THE LARGEST MASS-SQUARED....
3160
3161 40        SM=0.
3162         JL=1
3163         DO 30 I=1,N-1
3164            S=2.*(P(I,4)*P(I+1,4)-P(I,1)*P(I+1,1)-P(I,2)*P(I+1,2)
3165      &                -P(I,3)*P(I+1,3))+P(I,5)**2+P(I+1,5)**2
3166            IF(S.LT.0.) S=0.
3167            WP=SQRT(S)-1.5*(P(I,5)+P(I+1,5))
3168            IF(WP.GT.SM) THEN
3169               PBT1=P(I,1)+P(I+1,1)
3170               PBT2=P(I,2)+P(I+1,2)
3171               PBT3=P(I,3)+P(I+1,3)
3172               PBT4=P(I,4)+P(I+1,4)
3173               BTT=(PBT1**2+PBT2**2+PBT3**2)/PBT4**2
3174               IF(BTT.GE.1.0-1.0E-10) GO TO 30
3175               IF((I.NE.1.OR.I.NE.N-1).AND.
3176      &             (K(I,2).NE.21.AND.K(I+1,2).NE.21)) GO TO 30
3177               JL=I
3178               SM=WP
3179            ENDIF
3180 30        CONTINUE
3181         S=(SM+1.5*(P(JL,5)+P(JL+1,5)))**2
3182               IF(SM.LT.HIPR1(5)) GOTO 2
3183
3184 C.....MAKE PLACE FOR ONE GLUON.....
3185               IF(JL+1.EQ.N) GOTO 190
3186               DO 160 J=N,JL+2,-1
3187                       K(J+1,1)=K(J,1)
3188                 K(J+1,2)=K(J,2)
3189                       DO 150 M=1,5
3190 150                           P(J+1,M)=P(J,M)
3191 160                   CONTINUE
3192 190           N=N+1
3193
3194 C.....BOOST TO REST SYSTEM FOR PARTICLES JL AND JL+1.....
3195               P1=P(JL,1)+P(JL+1,1)
3196               P2=P(JL,2)+P(JL+1,2)
3197               P3=P(JL,3)+P(JL+1,3)
3198               P4=P(JL,4)+P(JL+1,4)
3199               BEX=-P1/P4
3200               BEY=-P2/P4
3201               BEZ=-P3/P4
3202         IMIN=JL
3203         IMAX=JL+1
3204               CALL ATROBO(0.,0.,BEX,BEY,BEZ,IMIN,IMAX,IERROR)
3205         IF(IERROR.NE.0) RETURN
3206 C.....ROTATE TO Z-AXIS....
3207               CTH=P(JL,3)/SQRT(P(JL,4)**2-P(JL,5)**2)
3208               IF(ABS(CTH).GT.1.0)  CTH=MAX(-1.,MIN(1.,CTH))
3209               THETA=ACOS(CTH)
3210               PHI=ULANGL(P(JL,1),P(JL,2))
3211               CALL ATROBO(0.,-PHI,0.,0.,0.,IMIN,IMAX,IERROR)
3212               CALL ATROBO(-THETA,0.,0.,0.,0.,IMIN,IMAX,IERROR)
3213
3214 C.....CREATE ONE GLUON AND ORIENTATE.....
3215
3216 1        CALL AR3JET(S,X1,X3,JL)
3217               CALL ARORIE(S,X1,X3,JL)
3218         IF(HIDAT(2).GT.0.0) THEN
3219                  PTG1=SQRT(P(JL,1)**2+P(JL,2)**2)
3220                  PTG2=SQRT(P(JL+1,1)**2+P(JL+1,2)**2)
3221                  PTG3=SQRT(P(JL+2,1)**2+P(JL+2,2)**2)
3222            PTG=MAX(PTG1,PTG2,PTG3)
3223            IF(PTG.GT.HIDAT(2)) THEN
3224               FMFACT=EXP(-(PTG**2-HIDAT(2)**2)/HIPR1(2)**2)
3225               IF(RANART(NSEED).GT.FMFACT) GO TO 1
3226            ENDIF
3227         ENDIF
3228 C.....ROTATE AND BOOST BACK.....
3229         IMIN=JL
3230         IMAX=JL+2
3231               CALL ATROBO(THETA,PHI,-BEX,-BEY,-BEZ,IMIN,IMAX,IERROR)
3232         IF(IERROR.NE.0) RETURN
3233 C.....ENUMERATE THE GLUONS.....
3234               K(JL+2,1)=K(JL+1,1)
3235         K(JL+2,2)=K(JL+1,2)
3236         K(JL+2,3)=K(JL+1,3)
3237         K(JL+2,4)=K(JL+1,4)
3238         K(JL+2,5)=K(JL+1,5)
3239               P(JL+2,5)=P(JL+1,5)
3240               K(JL+1,1)=2
3241         K(JL+1,2)=21
3242         K(JL+1,3)=0
3243         K(JL+1,4)=0
3244         K(JL+1,5)=0
3245               P(JL+1,5)=0.
3246 C----THETA FUNCTION DAMPING OF THE EMITTED GLUONS. FOR HADRON-HADRON.
3247 C----R0=VFR(2)
3248 C              IF(VFR(2).GT.0.) THEN
3249 C              PTG=SQRT(P(JL+1,1)**2+P(JL+1,2)**2)
3250 C              PTGMAX=WSTRI/2.
3251 C              DOPT=SQRT((4.*PAR(71)*VFR(2))/WSTRI)
3252 C              PTOPT=(DOPT*WSTRI)/(2.*VFR(2))
3253 C              IF(PTG.GT.PTOPT) IORDER=IORDER-1
3254 C              IF(PTG.GT.PTOPT) GOTO 1
3255 C              ENDIF
3256 C-----
3257              IF(SM.GE.HIPR1(5)) GOTO 40
3258
3259 2              K(1,1)=2
3260         K(1,3)=0
3261         K(1,4)=0
3262         K(1,5)=0
3263               K(N,1)=1
3264         K(N,3)=0
3265         K(N,4)=0
3266         K(N,5)=0
3267
3268               RETURN
3269               END
3270
3271
3272         SUBROUTINE AR3JET(S,X1,X3,JL)
3273 C
3274         COMMON/HPARNT/HIPR1(100),IHPR2(50),HINT1(100),IHNT2(50)
3275 cc      SAVE /HPARNT/
3276         COMMON/LUJETS/N,K(9000,5),P(9000,5),V(9000,5)
3277 cc      SAVE /LUJETS/
3278       COMMON/RNDF77/NSEED
3279 cc      SAVE /RNDF77/
3280         SAVE
3281 C
3282         C=1./3.
3283               IF(K(JL,2).NE.21 .AND. K(JL+1,2).NE.21) C=8./27.
3284               EXP1=3
3285               EXP3=3
3286               IF(K(JL,2).NE.21) EXP1=2
3287               IF(K(JL+1,2).NE.21) EXP3=2
3288               A=0.24**2/S
3289               YMA=ALOG(.5/SQRT(A)+SQRT(.25/A-1))
3290               D=4.*C*YMA
3291               SM1=P(JL,5)**2/S
3292               SM3=P(JL+1,5)**2/S
3293               XT2M=(1.-2.*SQRT(SM1)+SM1-SM3)*(1.-2.*SQRT(SM3)-SM1+SM3)
3294               XT2M=MIN(.25,XT2M)
3295               NTRY=0
3296 1             IF(NTRY.EQ.5000) THEN
3297                 X1=.5*(2.*SQRT(SM1)+1.+SM1-SM3)
3298                 X3=.5*(2.*SQRT(SM3)+1.-SM1+SM3)
3299                 RETURN
3300               ENDIF
3301               NTRY=NTRY+1
3302
3303               XT2=A*(XT2M/A)**(RANART(NSEED)**(1./D))
3304
3305               YMAX=ALOG(.5/SQRT(XT2)+SQRT(.25/XT2-1.))
3306               Y=(2.*RANART(NSEED)-1.)*YMAX
3307               X1=1.-SQRT(XT2)*EXP(Y)
3308               X3=1.-SQRT(XT2)*EXP(-Y)
3309               X2=2.-X1-X3
3310               NEG=0
3311               IF(K(JL,2).NE.21 .OR. K(JL+1,2).NE.21) THEN
3312         IF((1.-X1)*(1.-X2)*(1.-X3)-X2*SM1*(1.-X1)-X2*SM3*(1.-X3).
3313      &  LE.0..OR.X1.LE.2.*SQRT(SM1)-SM1+SM3.OR.X3.LE.2.*SQRT(SM3)
3314      &  -SM3+SM1) NEG=1
3315         X1=X1+SM1-SM3
3316         X3=X3-SM1+SM3
3317              ENDIF
3318               IF(NEG.EQ.1) GOTO 1
3319
3320               FG=2.*YMAX*C*(X1**EXP1+X3**EXP3)/D
3321               XT2M=XT2
3322               IF(FG.LT.RANART(NSEED)) GOTO 1
3323
3324               RETURN
3325               END
3326 C*************************************************************
3327
3328
3329         SUBROUTINE ARORIE(S,X1,X3,JL)
3330 C
3331         COMMON/HPARNT/HIPR1(100),IHPR2(50),HINT1(100),IHNT2(50)
3332 cc      SAVE /HPARNT/
3333         COMMON/LUJETS/N,K(9000,5),P(9000,5),V(9000,5)
3334 cc      SAVE /LUJETS/
3335       COMMON/RNDF77/NSEED
3336 cc      SAVE /RNDF77/
3337         SAVE
3338 C
3339              W=SQRT(S)
3340              X2=2.-X1-X3
3341              E1=.5*X1*W
3342              E3=.5*X3*W
3343              P1=SQRT(E1**2-P(JL,5)**2)
3344         P3=SQRT(E3**2-P(JL+1,5)**2)
3345         CBET=1.
3346         IF(P1.GT.0..AND.P3.GT.0.) CBET=(P(JL,5)**2
3347      &           +P(JL+1,5)**2+2.*E1*E3-S*(1.-X2))/(2.*P1*P3)
3348               IF(ABS(CBET).GT.1.0) CBET=MAX(-1.,MIN(1.,CBET))
3349               BET=ACOS(CBET)
3350
3351 C.....MINIMIZE PT1-SQUARED PLUS PT3-SQUARED.....
3352               IF(P1.GE.P3) THEN
3353            PSI=.5*ULANGL(P1**2+P3**2*COS(2.*BET),-P3**2*SIN(2.*BET))
3354            PT1=P1*SIN(PSI)
3355            PZ1=P1*COS(PSI)
3356            PT3=P3*SIN(PSI+BET)
3357            PZ3=P3*COS(PSI+BET)
3358               ELSE IF(P3.GT.P1) THEN
3359            PSI=.5*ULANGL(P3**2+P1**2*COS(2.*BET),-P1**2*SIN(2.*BET))
3360            PT1=P1*SIN(BET+PSI)
3361            PZ1=-P1*COS(BET+PSI)
3362            PT3=P3*SIN(PSI)
3363            PZ3=-P3*COS(PSI)
3364               ENDIF
3365
3366               DEL=2.0*HIPR1(40)*RANART(NSEED)
3367               P(JL,4)=E1
3368               P(JL,1)=PT1*SIN(DEL)
3369               P(JL,2)=-PT1*COS(DEL)
3370               P(JL,3)=PZ1
3371               P(JL+2,4)=E3
3372               P(JL+2,1)=PT3*SIN(DEL)
3373               P(JL+2,2)=-PT3*COS(DEL)
3374               P(JL+2,3)=PZ3
3375               P(JL+1,4)=W-E1-E3
3376               P(JL+1,1)=-P(JL,1)-P(JL+2,1)
3377               P(JL+1,2)=-P(JL,2)-P(JL+2,2)
3378               P(JL+1,3)=-P(JL,3)-P(JL+2,3)
3379               RETURN
3380               END
3381
3382
3383 C
3384 C*******************************************************************
3385 C        make  boost and rotation to entries from IMIN to IMAX
3386 C*******************************************************************
3387         SUBROUTINE ATROBO(THE,PHI,BEX,BEY,BEZ,IMIN,IMAX,IERROR)
3388         COMMON/LUJETS/N,K(9000,5),P(9000,5),V(9000,5)
3389 cc      SAVE /LUJETS/
3390         DIMENSION ROT(3,3),PV(3)
3391         DOUBLE PRECISION DP(4),DBEX,DBEY,DBEZ,DGA,DGA2,DBEP,DGABEP
3392         SAVE
3393         IERROR=0
3394
3395               IF(IMIN.LE.0 .OR. IMAX.GT.N .OR. IMIN.GT.IMAX) RETURN
3396
3397               IF(THE**2+PHI**2.GT.1E-20) THEN
3398 C...ROTATE (TYPICALLY FROM Z AXIS TO DIRECTION THETA,PHI)
3399            ROT(1,1)=COS(THE)*COS(PHI)
3400            ROT(1,2)=-SIN(PHI)
3401            ROT(1,3)=SIN(THE)*COS(PHI)
3402            ROT(2,1)=COS(THE)*SIN(PHI)
3403            ROT(2,2)=COS(PHI)
3404            ROT(2,3)=SIN(THE)*SIN(PHI)
3405            ROT(3,1)=-SIN(THE)
3406            ROT(3,2)=0.
3407            ROT(3,3)=COS(THE)
3408            DO 120 I=IMIN,IMAX
3409 C**************           IF(MOD(K(I,1)/10000,10).GE.6) GOTO 120
3410               DO 100 J=1,3
3411  100                 PV(J)=P(I,J)
3412                  DO 110 J=1,3
3413  110                    P(I,J)=ROT(J,1)*PV(1)+ROT(J,2)*PV(2)
3414      &                     +ROT(J,3)*PV(3)
3415  120                 CONTINUE
3416         ENDIF
3417
3418               IF(BEX**2+BEY**2+BEZ**2.GT.1E-20) THEN
3419 C...LORENTZ BOOST (TYPICALLY FROM REST TO MOMENTUM/ENERGY=BETA)
3420                 DBEX=dble(BEX)
3421                 DBEY=dble(BEY)
3422                 DBEZ=dble(BEZ)
3423                 DGA2=1D0-DBEX**2-DBEY**2-DBEZ**2
3424                 IF(DGA2.LE.0D0) THEN
3425                         IERROR=1
3426                         RETURN
3427                 ENDIF
3428                 DGA=1D0/DSQRT(DGA2)
3429                 DO 140 I=IMIN,IMAX
3430 C*************           IF(MOD(K(I,1)/10000,10).GE.6) GOTO 140
3431                    DO 130 J=1,4
3432  130                  DP(J)=dble(P(I,J))
3433                    DBEP=DBEX*DP(1)+DBEY*DP(2)+DBEZ*DP(3)
3434                    DGABEP=DGA*(DGA*DBEP/(1D0+DGA)+DP(4))
3435                    P(I,1)=sngl(DP(1)+DGABEP*DBEX)
3436                    P(I,2)=sngl(DP(2)+DGABEP*DBEY)
3437                    P(I,3)=sngl(DP(3)+DGABEP*DBEZ)
3438                    P(I,4)=sngl(DGA*(DP(4)+DBEP))
3439 140                   CONTINUE
3440               ENDIF
3441
3442               RETURN
3443               END
3444 C
3445 C
3446 C
3447         SUBROUTINE HIJHRD(JP,JT,JOUT,JFLG,IOPJT0)
3448 C
3449 C        IOPTJET=1, ALL JET WILL FORM SINGLE STRING SYSTEM
3450 C                0, ONLY Q-QBAR JET FORM SINGLE STRING SYSTEM
3451 C*******Perform jets production and fragmentation when JP JT *******
3452 C     scatter. JOUT-> number of hard scatterings precede this one  *
3453 C     for the the same pair(JP,JT). JFLG->a flag to show whether   *
3454 C     jets can be produced (with valence quark=1,gluon=2, q-qbar=3)*
3455 C     or not(0). Information of jets are in  COMMON/ATTJET and     *
3456 C     /MINJET. ABS(NFP(JP,6)) is the total number jets produced by *
3457 C    JP. If NFP(JP,6)<0 JP can not produce jet anymore.                   *
3458 C*******************************************************************
3459         PARAMETER (MAXSTR=150001)
3460         DIMENSION IP(100,2),IPQ(50),IPB(50),IT(100,2),ITQ(50),ITB(50)
3461         COMMON/hjcrdn/YP(3,300),YT(3,300)
3462 cc      SAVE /hjcrdn/
3463         COMMON/HPARNT/HIPR1(100),IHPR2(50),HINT1(100),IHNT2(50)
3464 cc      SAVE /HPARNT/
3465         COMMON/HIJDAT/HIDAT0(10,10),HIDAT(10)
3466 cc      SAVE /HIJDAT/
3467         COMMON/HSTRNG/NFP(300,15),PP(300,15),NFT(300,15),PT(300,15)
3468 cc      SAVE /HSTRNG/
3469         COMMON/HJJET1/NPJ(300),KFPJ(300,500),PJPX(300,500),
3470      &                PJPY(300,500),PJPZ(300,500),PJPE(300,500),
3471      &                PJPM(300,500),NTJ(300),KFTJ(300,500),
3472      &                PJTX(300,500),PJTY(300,500),PJTZ(300,500),
3473      &                PJTE(300,500),PJTM(300,500)
3474 cc      SAVE /HJJET1/
3475         COMMON/HJJET2/NSG,NJSG(MAXSTR),IASG(MAXSTR,3),K1SG(MAXSTR,100),
3476      &       K2SG(MAXSTR,100),PXSG(MAXSTR,100),PYSG(MAXSTR,100),
3477      &       PZSG(MAXSTR,100),PESG(MAXSTR,100),PMSG(MAXSTR,100)
3478 cc      SAVE /HJJET2/
3479 c        COMMON/HJJET4/NDR,IADR(900,2),KFDR(900),PDR(900,5)
3480         COMMON/HJJET4/NDR,IADR(MAXSTR,2),KFDR(MAXSTR),PDR(MAXSTR,5)
3481         common/xydr/rtdr(MAXSTR,2)
3482 cc      SAVE /HJJET4/
3483       COMMON/RNDF77/NSEED
3484 cc      SAVE /RNDF77/
3485 C************************************ HIJING common block
3486         COMMON/LUJETS/N,K(9000,5),P(9000,5),V(9000,5)
3487 cc      SAVE /LUJETS/
3488         COMMON/LUDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
3489 cc      SAVE /LUDAT1/
3490         COMMON/PYSUBS/MSEL,MSUB(200),KFIN(2,-40:40),CKIN(200)
3491 cc      SAVE /PYSUBS/
3492         COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
3493 cc      SAVE /PYPARS/
3494         COMMON/PYINT1/MINT(400),VINT(400)
3495 cc      SAVE /PYINT1/
3496         COMMON/PYINT2/ISET(200),KFPR(200,2),COEF(200,20),ICOL(40,4,2)
3497 cc      SAVE /PYINT2/
3498         COMMON/PYINT5/NGEN(0:200,3),XSEC(0:200,3)
3499 cc      SAVE /PYINT5/
3500         COMMON/HPINT/MINT4,MINT5,ATCO(200,20),ATXS(0:200)
3501 cc      SAVE /HPINT/
3502 clin-2/2012 correction:
3503         common/phidcy/iphidcy,pttrig,ntrig,maxmiss,ipi0dcy
3504         SAVE
3505 C*********************************** LU common block
3506         MXJT=500
3507 C                SIZE OF COMMON BLOCK FOR # OF PARTON PER STRING
3508         MXSG=900
3509 C                SIZE OF COMMON BLOCK FOR # OF SINGLE STRINGS
3510         MXSJ=100
3511 C                SIZE OF COMMON BLOCK FOR # OF PARTON PER SINGLE
3512 C                STRING
3513         JFLG=0
3514         IHNT2(11)=JP
3515         IHNT2(12)=JT
3516 C
3517         IOPJET=IOPJT0
3518         IF(IOPJET.EQ.1.AND.(NFP(JP,6).NE.0.OR.NFT(JT,6).NE.0))
3519      &                   IOPJET=0
3520         IF(JP.GT.IHNT2(1) .OR. JT.GT.IHNT2(3)) RETURN
3521         IF(NFP(JP,6).LT.0 .OR. NFT(JT,6).LT.0) RETURN
3522 C                ******** JP or JT can not produce jet anymore
3523 C
3524         IF(JOUT.EQ.0) THEN
3525                 EPP=PP(JP,4)+PP(JP,3)
3526                 EPM=PP(JP,4)-PP(JP,3)
3527                 ETP=PT(JT,4)+PT(JT,3)
3528                 ETM=PT(JT,4)-PT(JT,3)
3529                 IF(EPP.LT.0.0) GO TO 1000
3530                 IF(EPM.LT.0.0) GO TO 1000
3531                 IF(ETP.LT.0.0) GO TO 1000
3532                 IF(ETM.LT.0.0) GO TO 1000
3533                 IF(EPP/(EPM+0.01).LE.ETP/(ETM+0.01)) RETURN
3534         ENDIF
3535 C                ********for the first hard scattering of (JP,JT)
3536 C                        have collision only when Ycm(JP)>Ycm(JT)
3537
3538         ECUT1=HIPR1(1)+HIPR1(8)+PP(JP,14)+PP(JP,15)
3539         ECUT2=HIPR1(1)+HIPR1(8)+PT(JT,14)+PT(JT,15)
3540         IF(PP(JP,4).LE.ECUT1) THEN
3541                 NFP(JP,6)=-ABS(NFP(JP,6))
3542                 RETURN
3543         ENDIF
3544         IF(PT(JT,4).LE.ECUT2) THEN
3545                 NFT(JT,6)=-ABS(NFT(JT,6))
3546                 RETURN
3547         ENDIF
3548 C                *********must have enough energy to produce jets
3549
3550         MISS=0
3551         MISP=0
3552         MIST=0
3553 C
3554         IF(NFP(JP,10).EQ.0 .AND. NFT(JT,10).EQ.0) THEN
3555                 MINT(44)=MINT4
3556                 MINT(45)=MINT5
3557                 XSEC(0,1)=ATXS(0)
3558                 XSEC(11,1)=ATXS(11)
3559                 XSEC(12,1)=ATXS(12)
3560                 XSEC(28,1)=ATXS(28)
3561                 DO 120 I=1,20
3562                 COEF(11,I)=ATCO(11,I)
3563                 COEF(12,I)=ATCO(12,I)
3564                 COEF(28,I)=ATCO(28,I)
3565 120                CONTINUE
3566         ELSE
3567                 ISUB11=0
3568                 ISUB12=0
3569                 ISUB28=0
3570                 IF(XSEC(11,1).NE.0) ISUB11=1
3571                 IF(XSEC(12,1).NE.0) ISUB12=1
3572                 IF(XSEC(28,1).NE.0) ISUB28=1
3573                 MINT(44)=MINT4-ISUB11-ISUB12-ISUB28
3574                 MINT(45)=MINT5-ISUB11-ISUB12-ISUB28
3575                 XSEC(0,1)=ATXS(0)-ATXS(11)-ATXS(12)-ATXS(28)
3576                 XSEC(11,1)=0.0
3577                 XSEC(12,1)=0.0
3578                 XSEC(28,1)=0.0
3579                 DO 110 I=1,20
3580                 COEF(11,I)=0.0
3581                 COEF(12,I)=0.0
3582                 COEF(28,I)=0.0
3583 110                CONTINUE
3584         ENDIF
3585 C        ********Scatter the valence quarks only once per NN
3586 C       collision,
3587 C                afterwards only gluon can have hard scattering.
3588  155        CALL PYTHIA
3589         JJ=MINT(31)
3590         IF(JJ.NE.1) GO TO 155
3591 C                *********one hard collision at a time
3592         IF(K(7,2).EQ.-K(8,2)) THEN
3593                 QMASS2=(P(7,4)+P(8,4))**2-(P(7,1)+P(8,1))**2
3594      &                        -(P(7,2)+P(8,2))**2-(P(7,3)+P(8,3))**2
3595                 QM=ULMASS(K(7,2))
3596                 IF(QMASS2.LT.(2.0*QM+HIPR1(1))**2) GO TO 155
3597         ENDIF
3598 C                ********q-qbar jets must has minimum mass HIPR1(1)
3599         PXP=PP(JP,1)-P(3,1)
3600         PYP=PP(JP,2)-P(3,2)
3601         PZP=PP(JP,3)-P(3,3)
3602         PEP=PP(JP,4)-P(3,4)
3603         PXT=PT(JT,1)-P(4,1)
3604         PYT=PT(JT,2)-P(4,2)
3605         PZT=PT(JT,3)-P(4,3)
3606         PET=PT(JT,4)-P(4,4)
3607
3608         IF(PEP.LE.ECUT1) THEN
3609                 MISP=MISP+1
3610                 IF(MISP.LT.50) GO TO 155
3611                 NFP(JP,6)=-ABS(NFP(JP,6))
3612                 RETURN
3613         ENDIF
3614         IF(PET.LE.ECUT2) THEN
3615                 MIST=MIST+1
3616                 IF(MIST.LT.50) GO TO 155
3617                 NFT(JT,6)=-ABS(NFT(JT,6))
3618                 RETURN
3619         ENDIF
3620 C                ******** if the remain energy<ECUT the proj or targ
3621 C                         can not produce jet anymore
3622
3623         WP=PEP+PZP+PET+PZT
3624         WM=PEP-PZP+PET-PZT
3625         IF(WP.LT.0.0 .OR. WM.LT.0.0) THEN
3626                 MISS=MISS+1
3627 clin-6/2009 Let user set the limit when selecting high-Pt events
3628 c     because more attempts may be needed:
3629 c                IF(MISS.LT.50) GO TO 155
3630                 if(pttrig.gt.0) then
3631                    if(MISS.LT.maxmiss) then
3632                 write(6,*) 'Failed to generate minijet Pt>',pttrig,'GeV'
3633                       GO TO 155
3634                    endif
3635                 else
3636                    IF(MISS.LT.50) GO TO 155
3637                 endif
3638
3639                 RETURN
3640         ENDIF
3641 C                ********the total W+, W- must be positive
3642         SW=WP*WM
3643         AMPX=SQRT((ECUT1-HIPR1(8))**2+PXP**2+PYP**2+0.01)
3644         AMTX=SQRT((ECUT2-HIPR1(8))**2+PXT**2+PYT**2+0.01)
3645         SXX=(AMPX+AMTX)**2
3646         IF(SW.LT.SXX.OR.VINT(43).LT.HIPR1(1)) THEN
3647                 MISS=MISS+1
3648 clin-6/2009
3649 c                IF(MISS.LT.50) GO TO 155
3650                 IF(MISS.GT.maxmiss) GO TO 155
3651                 RETURN
3652         ENDIF
3653 C                ********the proj and targ remnants must have at least
3654 C                        a CM energy that can produce two strings
3655 C                        with minimum mass HIPR1(1)(see HIJSFT HIJFRG)
3656 C
3657         HINT1(41)=P(7,1)
3658         HINT1(42)=P(7,2)
3659         HINT1(43)=P(7,3)
3660         HINT1(44)=P(7,4)
3661         HINT1(45)=P(7,5)
3662         HINT1(46)=SQRT(P(7,1)**2+P(7,2)**2)
3663         HINT1(51)=P(8,1)
3664         HINT1(52)=P(8,2)
3665         HINT1(53)=P(8,3)
3666         HINT1(54)=P(8,4)
3667         HINT1(55)=P(8,5)
3668         HINT1(56)=SQRT(P(8,1)**2+P(8,2)**2)
3669         IHNT2(14)=K(7,2)
3670         IHNT2(15)=K(8,2)
3671 C
3672         PINIRD=(1.0-EXP(-2.0*(VINT(47)-HIDAT(1))))
3673      &                /(1.0+EXP(-2.0*(VINT(47)-HIDAT(1))))
3674         IINIRD=0
3675         IF(RANART(NSEED).LE.PINIRD) IINIRD=1
3676         IF(K(7,2).EQ.-K(8,2)) GO TO 190
3677         IF(K(7,2).EQ.21.AND.K(8,2).EQ.21.AND.IOPJET.EQ.1) GO TO 190
3678 C*******************************************************************
3679 C        gluon  jets are going to be connectd with
3680 C        the final leadng string of quark-aintquark
3681 C*******************************************************************
3682         JFLG=2
3683         JPP=0
3684         LPQ=0
3685         LPB=0
3686         JTT=0
3687         LTQ=0
3688         LTB=0
3689         IS7=0
3690         IS8=0
3691         HINT1(47)=0.0
3692         HINT1(48)=0.0
3693         HINT1(49)=0.0
3694         HINT1(50)=0.0
3695         HINT1(67)=0.0
3696         HINT1(68)=0.0
3697         HINT1(69)=0.0
3698         HINT1(70)=0.0
3699         DO 180 I=9,N
3700            IF(K(I,3).EQ.1 .OR. K(I,3).EQ.2.OR.
3701      &                   ABS(K(I,2)).GT.30) GO TO 180
3702 C************************************************************
3703            IF(K(I,3).EQ.7) THEN
3704               HINT1(47)=HINT1(47)+P(I,1)
3705               HINT1(48)=HINT1(48)+P(I,2)
3706               HINT1(49)=HINT1(49)+P(I,3)
3707               HINT1(50)=HINT1(50)+P(I,4)
3708            ENDIF
3709            IF(K(I,3).EQ.8) THEN
3710               HINT1(67)=HINT1(67)+P(I,1)
3711               HINT1(68)=HINT1(68)+P(I,2)
3712               HINT1(69)=HINT1(69)+P(I,3)
3713               HINT1(70)=HINT1(70)+P(I,4)
3714            ENDIF
3715 C************************modifcation made on Apr 10. 1996*****
3716            IF(K(I,2).GT.21.AND.K(I,2).LE.30) THEN
3717               NDR=NDR+1
3718               IADR(NDR,1)=JP
3719               IADR(NDR,2)=JT
3720               KFDR(NDR)=K(I,2)
3721               PDR(NDR,1)=P(I,1)
3722               PDR(NDR,2)=P(I,2)
3723               PDR(NDR,3)=P(I,3)
3724               PDR(NDR,4)=P(I,4)
3725               PDR(NDR,5)=P(I,5)
3726               rtdr(NDR,1)=0.5*(YP(1,JP)+YT(1,JT))
3727               rtdr(NDR,2)=0.5*(YP(2,JP)+YT(2,JT))
3728 C************************************************************
3729               GO TO 180
3730 C************************correction made on Oct. 14,1994*****
3731            ENDIF
3732            IF(K(I,3).EQ.7.OR.K(I,3).EQ.3) THEN
3733               IF(K(I,3).EQ.7.AND.K(I,2).NE.21.AND.K(I,2).EQ.K(7,2)
3734      &                     .AND.IS7.EQ.0) THEN
3735                  PP(JP,10)=P(I,1)
3736                  PP(JP,11)=P(I,2)
3737                  PP(JP,12)=P(I,3)
3738                  PZP=PZP+P(I,3)
3739                  PEP=PEP+P(I,4)
3740                  NFP(JP,10)=1
3741                  IS7=1
3742                  GO TO 180
3743               ENDIF
3744               IF(K(I,3).EQ.3.AND.(K(I,2).NE.21.OR.
3745      &                               IINIRD.EQ.0)) THEN
3746                  PXP=PXP+P(I,1)
3747                  PYP=PYP+P(I,2)
3748                  PZP=PZP+P(I,3)
3749                  PEP=PEP+P(I,4)
3750                  GO TO 180
3751               ENDIF
3752               JPP=JPP+1
3753               IP(JPP,1)=I
3754               IP(JPP,2)=0
3755               IF(K(I,2).NE.21) THEN
3756                  IF(K(I,2).GT.0) THEN
3757                     LPQ=LPQ+1
3758                     IPQ(LPQ)=JPP
3759                     IP(JPP,2)=LPQ
3760                  ELSE IF(K(I,2).LT.0) THEN
3761                     LPB=LPB+1
3762                     IPB(LPB)=JPP
3763                     IP(JPP,2)=-LPB
3764                  ENDIF
3765               ENDIF
3766            ELSE IF(K(I,3).EQ.8.OR.K(I,3).EQ.4) THEN
3767               IF(K(I,3).EQ.8.AND.K(I,2).NE.21.AND.K(I,2).EQ.K(8,2)
3768      &                                .AND.IS8.EQ.0) THEN
3769                  PT(JT,10)=P(I,1)
3770                  PT(JT,11)=P(I,2)
3771                  PT(JT,12)=P(I,3)
3772                  PZT=PZT+P(I,3)
3773                  PET=PET+P(I,4)
3774                  NFT(JT,10)=1
3775                  IS8=1
3776                  GO TO 180
3777               ENDIF
3778               IF(K(I,3).EQ.4.AND.(K(I,2).NE.21.OR.
3779      &                             IINIRD.EQ.0)) THEN
3780                  PXT=PXT+P(I,1)
3781                  PYT=PYT+P(I,2)
3782                  PZT=PZT+P(I,3)
3783                  PET=PET+P(I,4)
3784                  GO TO 180
3785               ENDIF
3786               JTT=JTT+1
3787               IT(JTT,1)=I
3788               IT(JTT,2)=0
3789               IF(K(I,2).NE.21) THEN
3790                  IF(K(I,2).GT.0) THEN
3791                     LTQ=LTQ+1
3792                     ITQ(LTQ)=JTT
3793                     IT(JTT,2)=LTQ
3794                  ELSE IF(K(I,2).LT.0) THEN
3795                     LTB=LTB+1
3796                     ITB(LTB)=JTT
3797                     IT(JTT,2)=-LTB
3798                  ENDIF
3799               ENDIF
3800            ENDIF
3801  180        CONTINUE
3802 c
3803 c
3804         IF(LPQ.NE.LPB .OR. LTQ.NE.LTB) THEN
3805                 MISS=MISS+1
3806 clin-6/2009
3807 c                IF(MISS.LE.50) GO TO 155
3808                 IF(MISS.LE.maxmiss) GO TO 155
3809                 WRITE(6,*) ' Q -QBAR NOT MATCHED IN HIJHRD'
3810                 JFLG=0
3811                 RETURN
3812         ENDIF
3813 C****The following will rearrange the partons so that a quark is***
3814 C****allways followed by an anti-quark ****************************
3815
3816         J=0
3817 181        J=J+1
3818         IF(J.GT.JPP) GO TO 182
3819         IF(IP(J,2).EQ.0) THEN
3820                 GO TO 181
3821         ELSE IF(IP(J,2).NE.0) THEN
3822                 LP=ABS(IP(J,2))
3823                 IP1=IP(J,1)
3824                 IP2=IP(J,2)
3825                 IP(J,1)=IP(IPQ(LP),1)
3826                 IP(J,2)=IP(IPQ(LP),2)
3827                 IP(IPQ(LP),1)=IP1
3828                 IP(IPQ(LP),2)=IP2
3829                 IF(IP2.GT.0) THEN
3830                         IPQ(IP2)=IPQ(LP)
3831                 ELSE IF(IP2.LT.0) THEN
3832                         IPB(-IP2)=IPQ(LP)
3833                 ENDIF
3834 C                ********replace J with a quark
3835                 IP1=IP(J+1,1)
3836                 IP2=IP(J+1,2)
3837                 IP(J+1,1)=IP(IPB(LP),1)
3838                 IP(J+1,2)=IP(IPB(LP),2)
3839                 IP(IPB(LP),1)=IP1
3840                 IP(IPB(LP),2)=IP2
3841                 IF(IP2.GT.0) THEN
3842                         IPQ(IP2)=IPB(LP)
3843                 ELSE IF(IP2.LT.0) THEN
3844                         IPB(-IP2)=IPB(LP)
3845                 ENDIF
3846 C                ******** replace J+1 with anti-quark
3847                 J=J+1
3848                 GO TO 181
3849         ENDIF
3850
3851 182        J=0
3852 183        J=J+1
3853         IF(J.GT.JTT) GO TO 184
3854         IF(IT(J,2).EQ.0) THEN
3855                 GO TO 183
3856         ELSE IF(IT(J,2).NE.0) THEN
3857                 LT=ABS(IT(J,2))
3858                 IT1=IT(J,1)
3859                 IT2=IT(J,2)
3860                 IT(J,1)=IT(ITQ(LT),1)
3861                 IT(J,2)=IT(ITQ(LT),2)
3862                 IT(ITQ(LT),1)=IT1
3863                 IT(ITQ(LT),2)=IT2
3864                 IF(IT2.GT.0) THEN
3865                         ITQ(IT2)=ITQ(LT)
3866                 ELSE IF(IT2.LT.0) THEN
3867                         ITB(-IT2)=ITQ(LT)
3868                 ENDIF
3869 C                ********replace J with a quark
3870                 IT1=IT(J+1,1)
3871                 IT2=IT(J+1,2)
3872                 IT(J+1,1)=IT(ITB(LT),1)
3873                 IT(J+1,2)=IT(ITB(LT),2)
3874                 IT(ITB(LT),1)=IT1
3875                 IT(ITB(LT),2)=IT2
3876                 IF(IT2.GT.0) THEN
3877                         ITQ(IT2)=ITB(LT)
3878                 ELSE IF(IT2.LT.0) THEN
3879                         ITB(-IT2)=ITB(LT)
3880                 ENDIF
3881 C                ******** replace J+1 with anti-quark
3882                 J=J+1
3883                 GO TO 183
3884
3885         ENDIF
3886
3887 184        CONTINUE
3888         IF(NPJ(JP)+JPP.GT.MXJT.OR.NTJ(JT)+JTT.GT.MXJT) THEN
3889                 JFLG=0
3890                 WRITE(6,*) 'number of partons per string exceeds'
3891                 WRITE(6,*) 'the common block size'
3892                 RETURN
3893         ENDIF
3894 C                        ********check the bounds of common blocks
3895         DO 186 J=1,JPP
3896                 KFPJ(JP,NPJ(JP)+J)=K(IP(J,1),2)
3897                 PJPX(JP,NPJ(JP)+J)=P(IP(J,1),1)
3898                 PJPY(JP,NPJ(JP)+J)=P(IP(J,1),2)
3899                 PJPZ(JP,NPJ(JP)+J)=P(IP(J,1),3)
3900                 PJPE(JP,NPJ(JP)+J)=P(IP(J,1),4)
3901                 PJPM(JP,NPJ(JP)+J)=P(IP(J,1),5)
3902 186        CONTINUE
3903         NPJ(JP)=NPJ(JP)+JPP
3904         DO 188 J=1,JTT
3905                 KFTJ(JT,NTJ(JT)+J)=K(IT(J,1),2)
3906                 PJTX(JT,NTJ(JT)+J)=P(IT(J,1),1)
3907                 PJTY(JT,NTJ(JT)+J)=P(IT(J,1),2)
3908                 PJTZ(JT,NTJ(JT)+J)=P(IT(J,1),3)
3909                 PJTE(JT,NTJ(JT)+J)=P(IT(J,1),4)
3910                 PJTM(JT,NTJ(JT)+J)=P(IT(J,1),5)
3911 188        CONTINUE
3912         NTJ(JT)=NTJ(JT)+JTT
3913         GO TO 900
3914 C*****************************************************************
3915 CThis is the case of a quark-antiquark jet it will fragment alone
3916 C****************************************************************
3917 190        JFLG=3
3918         IF(K(7,2).NE.21.AND.K(8,2).NE.21.AND.
3919      &                   K(7,2)*K(8,2).GT.0) GO TO 155
3920         JPP=0
3921         LPQ=0
3922         LPB=0
3923         DO 200 I=9,N
3924            IF(K(I,3).EQ.1.OR.K(I,3).EQ.2.OR.
3925      &                  ABS(K(I,2)).GT.30) GO TO 200
3926                 IF(K(I,2).GT.21.AND.K(I,2).LE.30) THEN
3927                         NDR=NDR+1
3928                         IADR(NDR,1)=JP
3929                         IADR(NDR,2)=JT
3930                         KFDR(NDR)=K(I,2)
3931                         PDR(NDR,1)=P(I,1)
3932                         PDR(NDR,2)=P(I,2)
3933                         PDR(NDR,3)=P(I,3)
3934                         PDR(NDR,4)=P(I,4)
3935                         PDR(NDR,5)=P(I,5)
3936                         rtdr(NDR,1)=0.5*(YP(1,JP)+YT(1,JT))
3937                         rtdr(NDR,2)=0.5*(YP(2,JP)+YT(2,JT))
3938 C************************************************************
3939                         GO TO 200
3940 C************************correction made on Oct. 14,1994*****
3941                 ENDIF
3942                 IF(K(I,3).EQ.3.AND.(K(I,2).NE.21.OR.
3943      &                              IINIRD.EQ.0)) THEN
3944                         PXP=PXP+P(I,1)
3945                         PYP=PYP+P(I,2)
3946                         PZP=PZP+P(I,3)
3947                         PEP=PEP+P(I,4)
3948                         GO TO 200
3949                 ENDIF
3950                 IF(K(I,3).EQ.4.AND.(K(I,2).NE.21.OR.
3951      &                                IINIRD.EQ.0)) THEN
3952                         PXT=PXT+P(I,1)
3953                         PYT=PYT+P(I,2)
3954                         PZT=PZT+P(I,3)
3955                         PET=PET+P(I,4)
3956                         GO TO 200
3957                 ENDIF
3958                 JPP=JPP+1
3959                 IP(JPP,1)=I
3960                 IP(JPP,2)=0
3961                 IF(K(I,2).NE.21) THEN
3962                         IF(K(I,2).GT.0) THEN
3963                                 LPQ=LPQ+1
3964                                 IPQ(LPQ)=JPP
3965                                 IP(JPP,2)=LPQ
3966                         ELSE IF(K(I,2).LT.0) THEN
3967                                 LPB=LPB+1
3968                                 IPB(LPB)=JPP
3969                                 IP(JPP,2)=-LPB
3970                         ENDIF
3971                 ENDIF
3972 200        CONTINUE
3973         IF(LPQ.NE.LPB) THEN
3974            MISS=MISS+1
3975 clin-6/2009
3976 c           IF(MISS.LE.50) GO TO 155
3977            IF(MISS.LE.maxmiss) GO TO 155
3978            WRITE(6,*) LPQ,LPB, 'Q-QBAR NOT CONSERVED OR NOT MATCHED'
3979            JFLG=0
3980            RETURN
3981         ENDIF
3982
3983 C**** The following will rearrange the partons so that a quark is***
3984 C**** allways followed by an anti-quark ****************************
3985         J=0
3986 220        J=J+1
3987         IF(J.GT.JPP) GO TO 222
3988         IF(IP(J,2).EQ.0) GO TO 220
3989                 LP=ABS(IP(J,2))
3990                 IP1=IP(J,1)
3991                 IP2=IP(J,2)
3992                 IP(J,1)=IP(IPQ(LP),1)
3993                 IP(J,2)=IP(IPQ(LP),2)
3994                 IP(IPQ(LP),1)=IP1
3995                 IP(IPQ(LP),2)=IP2
3996                 IF(IP2.GT.0) THEN
3997                         IPQ(IP2)=IPQ(LP)
3998                 ELSE IF(IP2.LT.0) THEN
3999                         IPB(-IP2)=IPQ(LP)
4000                 ENDIF
4001                 IPQ(LP)=J
4002 C                ********replace J with a quark
4003                 IP1=IP(J+1,1)
4004                 IP2=IP(J+1,2)
4005                 IP(J+1,1)=IP(IPB(LP),1)
4006                 IP(J+1,2)=IP(IPB(LP),2)
4007                 IP(IPB(LP),1)=IP1
4008                 IP(IPB(LP),2)=IP2
4009                 IF(IP2.GT.0) THEN
4010                         IPQ(IP2)=IPB(LP)
4011                 ELSE IF(IP2.LT.0) THEN
4012                         IPB(-IP2)=IPB(LP)
4013                 ENDIF
4014 C                ******** replace J+1 with an anti-quark
4015                 IPB(LP)=J+1
4016                 J=J+1
4017                 GO TO 220
4018
4019 222        CONTINUE
4020         IF(LPQ.GE.1) THEN
4021                 DO 240 L0=2,LPQ
4022                         IP1=IP(2*L0-3,1)
4023                         IP2=IP(2*L0-3,2)
4024                         IP(2*L0-3,1)=IP(IPQ(L0),1)
4025                         IP(2*L0-3,2)=IP(IPQ(L0),2)
4026                         IP(IPQ(L0),1)=IP1
4027                         IP(IPQ(L0),2)=IP2
4028                         IF(IP2.GT.0) THEN
4029                                 IPQ(IP2)=IPQ(L0)
4030                         ELSE IF(IP2.LT.0) THEN
4031                                 IPB(-IP2)=IPQ(L0)
4032                         ENDIF
4033                         IPQ(L0)=2*L0-3
4034 C
4035                         IP1=IP(2*L0-2,1)
4036                         IP2=IP(2*L0-2,2)
4037                         IP(2*L0-2,1)=IP(IPB(L0),1)
4038                         IP(2*L0-2,2)=IP(IPB(L0),2)
4039                         IP(IPB(L0),1)=IP1
4040                         IP(IPB(L0),2)=IP2
4041                         IF(IP2.GT.0) THEN
4042                                 IPQ(IP2)=IPB(L0)
4043                         ELSE IF(IP2.LT.0) THEN
4044                                 IPB(-IP2)=IPB(L0)
4045                         ENDIF
4046                         IPB(L0)=2*L0-2
4047 240                CONTINUE
4048 C                ********move all the qqbar pair to the front of
4049 C                                the list, except the first pair
4050                 IP1=IP(2*LPQ-1,1)
4051                 IP2=IP(2*LPQ-1,2)
4052                 IP(2*LPQ-1,1)=IP(IPQ(1),1)
4053                 IP(2*LPQ-1,2)=IP(IPQ(1),2)
4054                 IP(IPQ(1),1)=IP1
4055                 IP(IPQ(1),2)=IP2
4056                 IF(IP2.GT.0) THEN
4057                         IPQ(IP2)=IPQ(1)
4058                 ELSE IF(IP2.LT.0) THEN
4059                         IPB(-IP2)=IPQ(1)
4060                 ENDIF
4061                 IPQ(1)=2*LPQ-1
4062 C                ********move the first quark to the beginning of
4063 C                                the last string system
4064                 IP1=IP(JPP,1)
4065                 IP2=IP(JPP,2)
4066                 IP(JPP,1)=IP(IPB(1),1)
4067                 IP(JPP,2)=IP(IPB(1),2)
4068                 IP(IPB(1),1)=IP1
4069                 IP(IPB(1),2)=IP2
4070                 IF(IP2.GT.0) THEN
4071                         IPQ(IP2)=IPB(1)
4072                 ELSE IF(IP2.LT.0) THEN
4073                         IPB(-IP2)=IPB(1)
4074                 ENDIF
4075                 IPB(1)=JPP
4076 C                ********move the first anti-quark to the end of the
4077 C                        last string system
4078         ENDIF
4079         IF(NSG.GE.MXSG) THEN
4080            JFLG=0
4081            WRITE(6,*) 'number of jets forming single strings exceeds'
4082            WRITE(6,*) 'the common block size'
4083            RETURN
4084         ENDIF
4085         IF(JPP.GT.MXSJ) THEN
4086            JFLG=0
4087            WRITE(6,*) 'number of partons per single jet system'
4088            WRITE(6,*) 'exceeds the common block size'
4089            RETURN
4090         ENDIF
4091 C                ********check the bounds of common block size
4092         NSG=NSG+1
4093         NJSG(NSG)=JPP
4094         IASG(NSG,1)=JP
4095         IASG(NSG,2)=JT
4096         IASG(NSG,3)=0
4097         DO 300 I=1,JPP
4098                 K1SG(NSG,I)=2
4099                 K2SG(NSG,I)=K(IP(I,1),2)
4100                 IF(K2SG(NSG,I).LT.0) K1SG(NSG,I)=1
4101                 PXSG(NSG,I)=P(IP(I,1),1)
4102                 PYSG(NSG,I)=P(IP(I,1),2)
4103                 PZSG(NSG,I)=P(IP(I,1),3)
4104                 PESG(NSG,I)=P(IP(I,1),4)
4105                 PMSG(NSG,I)=P(IP(I,1),5)
4106 300        CONTINUE
4107         K1SG(NSG,1)=2
4108         K1SG(NSG,JPP)=1
4109 C******* reset the energy-momentum of incoming particles ********
4110 900        PP(JP,1)=PXP
4111         PP(JP,2)=PYP
4112         PP(JP,3)=PZP
4113         PP(JP,4)=PEP
4114         PP(JP,5)=0.0
4115         PT(JT,1)=PXT
4116         PT(JT,2)=PYT
4117         PT(JT,3)=PZT
4118         PT(JT,4)=PET
4119         PT(JT,5)=0.0
4120
4121         NFP(JP,6)=NFP(JP,6)+1
4122         NFT(JT,6)=NFT(JT,6)+1
4123         RETURN
4124 C
4125 1000        JFLG=-1
4126         IF(IHPR2(10).EQ.0) RETURN
4127         WRITE(6,*) 'Fatal HIJHRD error'
4128         WRITE(6,*) JP, ' proj E+,E-',EPP,EPM,' status',NFP(JP,5)
4129         WRITE(6,*) JT, ' targ E+,E_',ETP,ETM,' status',NFT(JT,5)
4130         RETURN
4131         END
4132 C
4133 C
4134 C
4135 C
4136 C
4137         SUBROUTINE JETINI(JP,JT,itrig)
4138 C*******Initialize PYTHIA for jet production**********************
4139 C        itrig=0: for normal processes
4140 C        itrig=1: for triggered processes
4141 C       JP: sequence number of the projectile
4142 C       JT: sequence number of the target
4143 C     For A+A collisions, one has to initilize pythia
4144 C     separately for each type of collisions, pp, pn,np and nn,
4145 C     or hp and hn for hA collisions. In this subroutine we use the following
4146 C     catalogue for different type of collisions:
4147 C     h+h: h+h (itype=1)
4148 C     h+A: h+p (itype=1), h+n (itype=2)
4149 C     A+h: p+h (itype=1), n+h (itype=2)
4150 C     A+A: p+p (itype=1), p+n (itype=2), n+p (itype=3), n+n (itype=4)
4151 C*****************************************************************
4152         CHARACTER BEAM*16,TARG*16
4153         DIMENSION XSEC0(8,0:200),COEF0(8,200,20),INI(8),
4154      &                MINT44(8),MINT45(8)
4155         COMMON/hjcrdn/YP(3,300),YT(3,300)
4156 cc      SAVE /hjcrdn/
4157         COMMON/HPARNT/HIPR1(100),IHPR2(50),HINT1(100),IHNT2(50)
4158 cc      SAVE /HPARNT/
4159         COMMON/HSTRNG/NFP(300,15),PP(300,15),NFT(300,15),PT(300,15)
4160 cc      SAVE /HSTRNG/
4161         COMMON/HPINT/MINT4,MINT5,ATCO(200,20),ATXS(0:200)
4162 cc      SAVE /HPINT/
4163 C
4164         COMMON/LUDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
4165 cc      SAVE /LUDAT1/
4166         COMMON/LUDAT3/MDCY(500,3),MDME(2000,2),BRAT(2000),KFDP(2000,5)
4167 cc      SAVE /LUDAT3/
4168         COMMON/PYSUBS/MSEL,MSUB(200),KFIN(2,-40:40),CKIN(200)
4169 cc      SAVE /PYSUBS/
4170         COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
4171 cc      SAVE /PYPARS/
4172         COMMON/PYINT1/MINT(400),VINT(400)
4173 cc      SAVE /PYINT1/
4174         COMMON/PYINT2/ISET(200),KFPR(200,2),COEF(200,20),ICOL(40,4,2)
4175 cc      SAVE /PYINT2/
4176         COMMON/PYINT5/NGEN(0:200,3),XSEC(0:200,3)
4177 cc      SAVE /PYINT5/
4178         SAVE
4179 clin        DATA INI/8*0/ilast/-1/
4180         DATA INI/8*0/,ilast/-1/
4181 C
4182         IHNT2(11)=JP
4183         IHNT2(12)=JT
4184         IF(IHNT2(5).NE.0 .AND. IHNT2(6).NE.0) THEN
4185            itype=1
4186         ELSE IF(IHNT2(5).NE.0 .AND. IHNT2(6).EQ.0) THEN
4187            itype=1
4188            IF(NFT(JT,4).EQ.2112) itype=2
4189         ELSE IF(IHNT2(5).EQ.0 .AND. IHNT2(6).NE.0) THEN
4190            itype=1
4191            IF(NFP(JP,4).EQ.2112) itype=2
4192         ELSE
4193            IF(NFP(JP,4).EQ.2212 .AND. NFT(JT,4).EQ.2212) THEN
4194               itype=1
4195            ELSE IF(NFP(JP,4).EQ.2212 .AND. NFT(JT,4).EQ.2112) THEN
4196               itype=2
4197            ELSE IF(NFP(JP,4).EQ.2112 .AND. NFT(JT,4).EQ.2212) THEN
4198               itype=3
4199            ELSE
4200               itype=4
4201            ENDIF
4202         ENDIF
4203
4204 clin-12/2012 correct NN differential cross section in HIJING:
4205 c        write(94,*) 'In JETINI: ',jp,jt,NFP(JP,4),NFT(JT,4),itype
4206
4207 c
4208         IF(itrig.NE.0) GO TO 160
4209         IF(itrig.EQ.ilast) GO TO 150
4210         MSTP(2)=2
4211 c                        ********second order running alpha_strong
4212         MSTP(33)=1
4213         PARP(31)=HIPR1(17)
4214 C                        ********inclusion of K factor
4215         MSTP(51)=3
4216 C                        ********Duke-Owens set 1 structure functions
4217         MSTP(61)=1
4218 C                        ********INITIAL STATE RADIATION
4219         MSTP(71)=1
4220 C                        ********FINAL STATE RADIATION
4221         IF(IHPR2(2).EQ.0.OR.IHPR2(2).EQ.2) MSTP(61)=0
4222         IF(IHPR2(2).EQ.0.OR.IHPR2(2).EQ.1) MSTP(71)=0
4223 c
4224         MSTP(81)=0
4225 C                        ******** NO MULTIPLE INTERACTION
4226         MSTP(82)=1
4227 C                        *******STRUCTURE OF MUTLIPLE INTERACTION
4228         MSTP(111)=0
4229 C                ********frag off(have to be done by local call)
4230         IF(IHPR2(10).EQ.0) MSTP(122)=0
4231 C                ********No printout of initialization information
4232         PARP(81)=HIPR1(8)
4233         CKIN(5)=HIPR1(8)
4234         CKIN(3)=HIPR1(8)
4235         CKIN(4)=HIPR1(9)
4236         IF(HIPR1(9).LE.HIPR1(8)) CKIN(4)=-1.0
4237         CKIN(9)=-10.0
4238         CKIN(10)=10.0
4239         MSEL=0
4240         DO 100 ISUB=1,200
4241            MSUB(ISUB)=0
4242  100    CONTINUE
4243         MSUB(11)=1
4244         MSUB(12)=1
4245         MSUB(13)=1
4246         MSUB(28)=1
4247         MSUB(53)=1
4248         MSUB(68)=1
4249         MSUB(81)=1
4250         MSUB(82)=1
4251         DO 110 J=1,MIN(8,MDCY(21,3))
4252  110    MDME(MDCY(21,2)+J-1,1)=0
4253         ISEL=4
4254         IF(HINT1(1).GE.20.0 .and. IHPR2(18).EQ.1) ISEL=5
4255         MDME(MDCY(21,2)+ISEL-1,1)=1
4256 C                        ********QCD subprocesses
4257         MSUB(14)=1
4258         MSUB(18)=1
4259         MSUB(29)=1
4260 C                       ******* direct photon production
4261  150    IF(INI(itype).NE.0) GO TO 800
4262         GO TO 400
4263 C
4264 C        *****triggered subprocesses, jet, photon, heavy quark and DY
4265 C
4266  160    itype=4+itype
4267         IF(itrig.EQ.ilast) GO TO 260
4268         PARP(81)=ABS(HIPR1(10))-0.25
4269         CKIN(5)=ABS(HIPR1(10))-0.25
4270         CKIN(3)=ABS(HIPR1(10))-0.25
4271         CKIN(4)=ABS(HIPR1(10))+0.25
4272         IF(HIPR1(10).LT.HIPR1(8)) CKIN(4)=-1.0
4273 c
4274         MSEL=0
4275         DO 101 ISUB=1,200
4276            MSUB(ISUB)=0
4277  101    CONTINUE
4278         IF(IHPR2(3).EQ.1) THEN
4279            MSUB(11)=1
4280            MSUB(12)=1
4281            MSUB(13)=1
4282            MSUB(28)=1
4283            MSUB(53)=1
4284            MSUB(68)=1
4285            MSUB(81)=1
4286            MSUB(82)=1
4287            MSUB(14)=1
4288            MSUB(18)=1
4289            MSUB(29)=1
4290            DO 102 J=1,MIN(8,MDCY(21,3))
4291  102           MDME(MDCY(21,2)+J-1,1)=0
4292            ISEL=4
4293            IF(HINT1(1).GE.20.0 .and. IHPR2(18).EQ.1) ISEL=5
4294            MDME(MDCY(21,2)+ISEL-1,1)=1
4295 C                        ********QCD subprocesses
4296         ELSE IF(IHPR2(3).EQ.2) THEN
4297            MSUB(14)=1
4298            MSUB(18)=1
4299            MSUB(29)=1
4300 C                ********Direct photon production
4301 c                q+qbar->g+gamma,q+qbar->gamma+gamma, q+g->q+gamma
4302         ELSE IF(IHPR2(3).EQ.3) THEN
4303            CKIN(3)=MAX(0.0,HIPR1(10))
4304            CKIN(5)=HIPR1(8)
4305            PARP(81)=HIPR1(8)
4306            MSUB(81)=1
4307            MSUB(82)=1
4308            DO 105 J=1,MIN(8,MDCY(21,3))
4309  105           MDME(MDCY(21,2)+J-1,1)=0
4310            ISEL=4
4311            IF(HINT1(1).GE.20.0 .and. IHPR2(18).EQ.1) ISEL=5
4312            MDME(MDCY(21,2)+ISEL-1,1)=1
4313 C             **********Heavy quark production
4314         ENDIF
4315 260        IF(INI(itype).NE.0) GO TO 800
4316 C
4317 C
4318 400        INI(itype)=1
4319         IF(IHPR2(10).EQ.0) MSTP(122)=0
4320         IF(NFP(JP,4).EQ.2212) THEN
4321                 BEAM='P'
4322         ELSE IF(NFP(JP,4).EQ.-2212) THEN
4323                 BEAM='P~'
4324         ELSE IF(NFP(JP,4).EQ.2112) THEN
4325                 BEAM='N'
4326         ELSE IF(NFP(JP,4).EQ.-2112) THEN
4327                 BEAM='N~'
4328         ELSE IF(NFP(JP,4).EQ.211) THEN
4329                 BEAM='PI+'
4330         ELSE IF(NFP(JP,4).EQ.-211) THEN
4331                 BEAM='PI-'
4332         ELSE IF(NFP(JP,4).EQ.321) THEN
4333                 BEAM='PI+'
4334         ELSE IF(NFP(JP,4).EQ.-321) THEN
4335                 BEAM='PI-'
4336         ELSE
4337                 WRITE(6,*) 'unavailable beam type', NFP(JP,4)
4338         ENDIF
4339         IF(NFT(JT,4).EQ.2212) THEN
4340                 TARG='P'
4341         ELSE IF(NFT(JT,4).EQ.-2212) THEN
4342                 TARG='P~'
4343         ELSE IF(NFT(JT,4).EQ.2112) THEN
4344                 TARG='N'
4345         ELSE IF(NFT(JT,4).EQ.-2112) THEN
4346                 TARG='N~'
4347         ELSE IF(NFT(JT,4).EQ.211) THEN
4348                 TARG='PI+'
4349         ELSE IF(NFT(JT,4).EQ.-211) THEN
4350                 TARG='PI-'
4351         ELSE IF(NFT(JT,4).EQ.321) THEN
4352                 TARG='PI+'
4353         ELSE IF(NFT(JT,4).EQ.-321) THEN
4354                 TARG='PI-'
4355         ELSE
4356                 WRITE(6,*) 'unavailable target type', NFT(JT,4)
4357         ENDIF
4358 C
4359         IHNT2(16)=1
4360 C       ******************indicate for initialization use when
4361 C                         structure functions are called in PYTHIA
4362 C
4363         CALL PYINIT('CMS',BEAM,TARG,HINT1(1))
4364         MINT4=MINT(44)
4365         MINT5=MINT(45)
4366         MINT44(itype)=MINT(44)
4367         MINT45(itype)=MINT(45)
4368         ATXS(0)=XSEC(0,1)
4369         XSEC0(itype,0)=XSEC(0,1)
4370         DO 500 I=1,200
4371                 ATXS(I)=XSEC(I,1)
4372                 XSEC0(itype,I)=XSEC(I,1)
4373                 DO 500 J=1,20
4374                         ATCO(I,J)=COEF(I,J)
4375                         COEF0(itype,I,J)=COEF(I,J)
4376 500        CONTINUE
4377 C
4378         IHNT2(16)=0
4379 C
4380         RETURN
4381 C                ********Store the initialization information for
4382 C                                late use
4383 C
4384 C
4385 800        MINT(44)=MINT44(itype)
4386         MINT(45)=MINT45(itype)
4387         MINT4=MINT(44)
4388         MINT5=MINT(45)
4389         XSEC(0,1)=XSEC0(itype,0)
4390         ATXS(0)=XSEC(0,1)
4391         DO 900 I=1,200
4392                 XSEC(I,1)=XSEC0(itype,I)
4393                 ATXS(I)=XSEC(I,1)
4394         DO 900 J=1,20
4395                 COEF(I,J)=COEF0(itype,I,J)
4396                 ATCO(I,J)=COEF(I,J)
4397 900        CONTINUE
4398         ilast=itrig
4399         MINT(11)=NFP(JP,4)
4400         MINT(12)=NFT(JT,4)
4401         RETURN
4402         END
4403 C
4404 C
4405 C
4406         SUBROUTINE HIJINI
4407         PARAMETER (MAXSTR=150001)
4408         COMMON/HPARNT/HIPR1(100),IHPR2(50),HINT1(100),IHNT2(50)
4409 cc      SAVE /HPARNT/
4410         COMMON/HSTRNG/NFP(300,15),PP(300,15),NFT(300,15),PT(300,15)
4411 cc      SAVE /HSTRNG/
4412         COMMON/HJJET1/NPJ(300),KFPJ(300,500),PJPX(300,500),
4413      &                PJPY(300,500),PJPZ(300,500),PJPE(300,500),
4414      &                PJPM(300,500),NTJ(300),KFTJ(300,500),
4415      &                PJTX(300,500),PJTY(300,500),PJTZ(300,500),
4416      &                PJTE(300,500),PJTM(300,500)
4417 cc      SAVE /HJJET1/
4418         COMMON/HJJET2/NSG,NJSG(MAXSTR),IASG(MAXSTR,3),K1SG(MAXSTR,100),
4419      &       K2SG(MAXSTR,100),PXSG(MAXSTR,100),PYSG(MAXSTR,100),
4420      &       PZSG(MAXSTR,100),PESG(MAXSTR,100),PMSG(MAXSTR,100)
4421 cc      SAVE /HJJET2/
4422 c        COMMON/HJJET4/NDR,IADR(900,2),KFDR(900),PDR(900,5)
4423         COMMON/HJJET4/NDR,IADR(MAXSTR,2),KFDR(MAXSTR),PDR(MAXSTR,5)
4424 cc      SAVE /HJJET4/
4425       COMMON/RNDF77/NSEED
4426 cc      SAVE /RNDF77/
4427         SAVE
4428 C****************Reset the momentum of initial particles************
4429 C             and assign flavors to the proj and targ string       *
4430 C*******************************************************************
4431         NSG=0
4432         NDR=0
4433         IPP=2212
4434         IPT=2212
4435         IF(IHNT2(5).NE.0) IPP=IHNT2(5)
4436         IF(IHNT2(6).NE.0) IPT=IHNT2(6)
4437 C                ********in case the proj or targ is a hadron.
4438 C
4439         DO 100 I=1,IHNT2(1)
4440         PP(I,1)=0.0
4441         PP(I,2)=0.0
4442         PP(I,3)=SQRT(HINT1(1)**2/4.0-HINT1(8)**2)
4443         PP(I,4)=HINT1(1)/2
4444         PP(I,5)=HINT1(8)
4445         PP(I,6)=0.0
4446         PP(I,7)=0.0
4447         PP(I,8)=0.0
4448         PP(I,9)=0.0
4449         PP(I,10)=0.0
4450 cbzdbg2/22/99
4451 ctest OFF
4452         PP(I, 11) = 0.0
4453         PP(I, 12) = 0.0
4454 cbzdbg2/22/99end
4455         NFP(I,3)=IPP
4456         NFP(I,4)=IPP
4457         NFP(I,5)=0
4458         NFP(I,6)=0
4459         NFP(I,7)=0
4460         NFP(I,8)=0
4461         NFP(I,9)=0
4462         NFP(I,10)=0
4463         NFP(I,11)=0
4464         NPJ(I)=0
4465         IF(I.GT.ABS(IHNT2(2))) NFP(I,3)=2112
4466
4467 clin-12/2012 correct NN differential cross section in HIJING:
4468         IF(I.GT.ABS(IHNT2(2))) NFP(I,4)=2112
4469
4470         CALL ATTFLV(NFP(I,3),IDQ,IDQQ)
4471         NFP(I,1)=IDQ
4472         NFP(I,2)=IDQQ
4473         NFP(I,15)=-1
4474         IF(ABS(IDQ).GT.1000.OR.(ABS(IDQ*IDQQ).LT.100.AND.
4475      &                RANART(NSEED).LT.0.5)) NFP(I,15)=1
4476         PP(I,14)=ULMASS(IDQ)
4477         PP(I,15)=ULMASS(IDQQ)
4478 100        CONTINUE
4479 C
4480         DO 200 I=1,IHNT2(3)
4481         PT(I,1)=0.0
4482         PT(I,2)=0.0
4483         PT(I,3)=-SQRT(HINT1(1)**2/4.0-HINT1(9)**2)
4484         PT(I,4)=HINT1(1)/2.0
4485         PT(I,5)=HINT1(9)
4486         PT(I,6)=0.0
4487         PT(I,7)=0.0
4488         PT(I,8)=0.0
4489         PT(I,9)=0.0
4490         PT(I,10)=0.0
4491 ctest OFF
4492 cbzdbg2/22/99
4493         PT(I, 11) = 0.0
4494         PT(I, 12) = 0.0
4495 cbzdbg2/22/99end
4496         NFT(I,3)=IPT
4497         NFT(I,4)=IPT
4498         NFT(I,5)=0
4499         NFT(I,6)=0
4500         NFT(I,7)=0
4501         NFT(I,8)=0
4502         NFT(I,9)=0
4503         NFT(I,10)=0
4504         NFT(I,11)=0
4505         NTJ(I)=0
4506         IF(I.GT.ABS(IHNT2(4))) NFT(I,3)=2112
4507
4508 clin-12/2012 correct NN differential cross section in HIJING:
4509         IF(I.GT.ABS(IHNT2(4))) NFT(I,4)=2112
4510
4511         CALL ATTFLV(NFT(I,3),IDQ,IDQQ)
4512         NFT(I,1)=IDQ
4513         NFT(I,2)=IDQQ
4514         NFT(I,15)=1
4515         IF(ABS(IDQ).GT.1000.OR.(ABS(IDQ*IDQQ).LT.100.AND.
4516      &       RANART(NSEED).LT.0.5)) NFT(I,15)=-1
4517         PT(I,14)=ULMASS(IDQ)
4518         PT(I,15)=ULMASS(IDQQ)
4519 200        CONTINUE
4520         RETURN
4521         END
4522 C
4523 C
4524 C
4525         SUBROUTINE ATTFLV(ID,IDQ,IDQQ)
4526       COMMON/RNDF77/NSEED
4527 cc      SAVE /RNDF77/
4528         SAVE
4529 C
4530         IF(ABS(ID).LT.100) THEN
4531                 NSIGN=1
4532                 IDQ=ID/100
4533                 IDQQ=-ID/10+IDQ*10
4534                 IF(ABS(IDQ).EQ.3) NSIGN=-1
4535                 IDQ=NSIGN*IDQ
4536                 IDQQ=NSIGN*IDQQ
4537                 IF(IDQ.LT.0) THEN
4538                         ID0=IDQ
4539                         IDQ=IDQQ
4540                         IDQQ=ID0
4541                 ENDIF
4542                 RETURN
4543         ENDIF
4544 C                ********return ID of quark(IDQ) and anti-quark(IDQQ)
4545 C                        for pions and kaons
4546 c
4547 C        Return LU ID for quarks and diquarks for proton(ID=2212)
4548 C        anti-proton(ID=-2212) and nuetron(ID=2112)
4549 C        LU ID for d=1,u=2, (ud)0=2101, (ud)1=2103,
4550 C       (dd)1=1103,(uu)1=2203.
4551 C        Use SU(6)  weight  proton=1/3d(uu)1 + 1/6u(ud)1 + 1/2u(ud)0
4552 C                          nurtron=1/3u(dd)1 + 1/6d(ud)1 + 1/2d(ud)0
4553 C
4554         IDQ=2
4555         IF(ABS(ID).EQ.2112) IDQ=1
4556         IDQQ=2101
4557         X=RANART(NSEED)
4558         IF(X.LE.0.5) GO TO 30
4559         IF(X.GT.0.666667) GO TO 10
4560         IDQQ=2103
4561         GO TO 30
4562 10        IDQ=1
4563         IDQQ=2203
4564         IF(ABS(ID).EQ.2112) THEN
4565                 IDQ=2
4566                 IDQQ=1103
4567         ENDIF
4568 30        IF(ID.LT.0) THEN
4569                 ID00=IDQQ
4570                 IDQQ=-IDQ
4571                 IDQ=-ID00
4572         ENDIF
4573         RETURN
4574         END
4575 C
4576 C*******************************************************************
4577 C        This subroutine performs elastic scatterings and possible
4578 C        elastic cascading within their own nuclei
4579 c*******************************************************************
4580         SUBROUTINE HIJCSC(JP,JT)
4581         DIMENSION PSC1(5),PSC2(5)
4582         COMMON/hjcrdn/YP(3,300),YT(3,300)
4583 cc      SAVE /hjcrdn/
4584         COMMON/HPARNT/HIPR1(100),IHPR2(50),HINT1(100),IHNT2(50)
4585 cc      SAVE /HPARNT/
4586       COMMON/RNDF77/NSEED
4587 cc      SAVE /RNDF77/
4588         COMMON/HSTRNG/NFP(300,15),PP(300,15),NFT(300,15),PT(300,15)
4589 cc      SAVE /HSTRNG/
4590         SAVE
4591         IF(JP.EQ.0 .OR. JT.EQ.0) GO TO 25
4592         DO 10 I=1,5
4593         PSC1(I)=PP(JP,I)
4594         PSC2(I)=PT(JT,I)
4595 10        CONTINUE
4596         CALL HIJELS(PSC1,PSC2)
4597         DPP1=PSC1(1)-PP(JP,1)
4598         DPP2=PSC1(2)-PP(JP,2)
4599         DPT1=PSC2(1)-PT(JT,1)
4600         DPT2=PSC2(2)-PT(JT,2)
4601         PP(JP,6)=PP(JP,6)+DPP1/2.0
4602         PP(JP,7)=PP(JP,7)+DPP2/2.0
4603         PP(JP,8)=PP(JP,8)+DPP1/2.0
4604         PP(JP,9)=PP(JP,9)+DPP2/2.0
4605         PT(JT,6)=PT(JT,6)+DPT1/2.0
4606         PT(JT,7)=PT(JT,7)+DPT2/2.0
4607         PT(JT,8)=PT(JT,8)+DPT1/2.0
4608         PT(JT,9)=PT(JT,9)+DPT2/2.0
4609         DO 20 I=1,4
4610         PP(JP,I)=PSC1(I)
4611         PT(JT,I)=PSC2(I)
4612 20        CONTINUE
4613         NFP(JP,5)=MAX(1,NFP(JP,5))
4614         NFT(JT,5)=MAX(1,NFT(JT,5))
4615 C                ********Perform elastic scattering between JP and JT
4616         RETURN
4617 C                ********The following is for possible elastic cascade
4618 c
4619 25        IF(JP.EQ.0) GO TO 45
4620         PABS=SQRT(PP(JP,1)**2+PP(JP,2)**2+PP(JP,3)**2)
4621         BX=PP(JP,1)/PABS
4622         BY=PP(JP,2)/PABS
4623         BZ=PP(JP,3)/PABS
4624         DO 40 I=1,IHNT2(1)
4625                 IF(I.EQ.JP) GO TO 40
4626                 DX=YP(1,I)-YP(1,JP)
4627                 DY=YP(2,I)-YP(2,JP)
4628                 DZ=YP(3,I)-YP(3,JP)
4629                 DIS=DX*BX+DY*BY+DZ*BZ
4630                 IF(DIS.LE.0) GO TO 40
4631                 BB=DX**2+DY**2+DZ**2-DIS**2
4632                 R2=BB*HIPR1(40)/HIPR1(31)/0.1
4633 C                ********mb=0.1*fm, YP is in fm,HIPR1(31) is in mb
4634                 GS=1.0-EXP(-(HIPR1(30)+HINT1(11))/HIPR1(31)/2.0
4635      &                        *ROMG(R2))**2
4636                 GS0=1.0-EXP(-(HIPR1(30)+HINT1(11))/HIPR1(31)/2.0
4637      &                        *ROMG(0.0))**2
4638                 IF(RANART(NSEED).GT.GS/GS0) GO TO 40
4639                 DO 30 K=1,5
4640                         PSC1(K)=PP(JP,K)
4641                         PSC2(K)=PP(I,K)
4642 30                CONTINUE
4643                 CALL HIJELS(PSC1,PSC2)
4644                 DPP1=PSC1(1)-PP(JP,1)
4645                 DPP2=PSC1(2)-PP(JP,2)
4646                 DPT1=PSC2(1)-PP(I,1)
4647                 DPT2=PSC2(2)-PP(I,2)
4648                 PP(JP,6)=PP(JP,6)+DPP1/2.0
4649                 PP(JP,7)=PP(JP,7)+DPP2/2.0
4650                 PP(JP,8)=PP(JP,8)+DPP1/2.0
4651                 PP(JP,9)=PP(JP,9)+DPP2/2.0
4652                 PP(I,6)=PP(I,6)+DPT1/2.0
4653                 PP(I,7)=PP(I,7)+DPT2/2.0
4654                 PP(I,8)=PP(I,8)+DPT1/2.0
4655                 PP(I,9)=PP(I,9)+DPT2/2.0
4656                 DO 35 K=1,5
4657                         PP(JP,K)=PSC1(K)
4658                         PP(I,K)=PSC2(K)
4659 35                CONTINUE
4660                 NFP(I,5)=MAX(1,NFP(I,5))
4661                 GO TO 45
4662 40        CONTINUE
4663 45        IF(JT.EQ.0) GO TO 80
4664 clin 50        PABS=SQRT(PT(JT,1)**2+PT(JT,2)**2+PT(JT,3)**2)
4665         PABS=SQRT(PT(JT,1)**2+PT(JT,2)**2+PT(JT,3)**2)
4666         BX=PT(JT,1)/PABS
4667         BY=PT(JT,2)/PABS
4668         BZ=PT(JT,3)/PABS
4669         DO 70 I=1,IHNT2(3)
4670                 IF(I.EQ.JT) GO TO 70
4671                 DX=YT(1,I)-YT(1,JT)
4672                 DY=YT(2,I)-YT(2,JT)
4673                 DZ=YT(3,I)-YT(3,JT)
4674                 DIS=DX*BX+DY*BY+DZ*BZ
4675                 IF(DIS.LE.0) GO TO 70
4676                 BB=DX**2+DY**2+DZ**2-DIS**2
4677                 R2=BB*HIPR1(40)/HIPR1(31)/0.1
4678 C                ********mb=0.1*fm, YP is in fm,HIPR1(31) is in mb
4679                 GS=(1.0-EXP(-(HIPR1(30)+HINT1(11))/HIPR1(31)/2.0
4680      &                        *ROMG(R2)))**2
4681                 GS0=(1.0-EXP(-(HIPR1(30)+HINT1(11))/HIPR1(31)/2.0
4682      &                        *ROMG(0.0)))**2
4683                 IF(RANART(NSEED).GT.GS/GS0) GO TO 70
4684                 DO 60 K=1,5
4685                         PSC1(K)=PT(JT,K)
4686                         PSC2(K)=PT(I,K)
4687 60                CONTINUE
4688                 CALL HIJELS(PSC1,PSC2)
4689                 DPP1=PSC1(1)-PT(JT,1)
4690                 DPP2=PSC1(2)-PT(JT,2)
4691                 DPT1=PSC2(1)-PT(I,1)
4692                 DPT2=PSC2(2)-PT(I,2)
4693                 PT(JT,6)=PT(JT,6)+DPP1/2.0
4694                 PT(JT,7)=PT(JT,7)+DPP2/2.0
4695                 PT(JT,8)=PT(JT,8)+DPP1/2.0
4696                 PT(JT,9)=PT(JT,9)+DPP2/2.0
4697                 PT(I,6)=PT(I,6)+DPT1/2.0
4698                 PT(I,7)=PT(I,7)+DPT2/2.0
4699                 PT(I,8)=PT(I,8)+DPT1/2.0
4700                 PT(I,9)=PT(I,9)+DPT2/2.0
4701                 DO 65 K=1,5
4702                         PT(JT,K)=PSC1(K)
4703                         PT(I,K)=PSC2(K)
4704 65                CONTINUE
4705                 NFT(I,5)=MAX(1,NFT(I,5))
4706                 GO TO 80
4707 70        CONTINUE
4708 80        RETURN
4709         END
4710 C
4711 C
4712 C*******************************************************************
4713 CThis subroutine performs elastic scattering between two nucleons
4714 C
4715 C*******************************************************************
4716         SUBROUTINE HIJELS(PSC1,PSC2)
4717         IMPLICIT DOUBLE PRECISION(D)
4718         DIMENSION PSC1(5),PSC2(5)
4719         COMMON/HPARNT/HIPR1(100),IHPR2(50),HINT1(100),IHNT2(50)
4720 cc      SAVE /HPARNT/
4721       COMMON/RNDF77/NSEED
4722 cc      SAVE /RNDF77/
4723         SAVE
4724 C
4725         CC=1.0-HINT1(12)/HINT1(13)
4726         RR=(1.0-CC)*HINT1(13)/HINT1(12)/(1.0-HIPR1(33))-1.0
4727         BB=0.5*(3.0+RR+SQRT(9.0+10.0*RR+RR**2))
4728         EP=SQRT((PSC1(1)-PSC2(1))**2+(PSC1(2)-PSC2(2))**2
4729      &                +(PSC1(3)-PSC2(3))**2)
4730         IF(EP.LE.0.1) RETURN
4731         ELS0=98.0/EP+52.0*(1.0+RR)**2
4732         PCM1=PSC1(1)+PSC2(1)
4733         PCM2=PSC1(2)+PSC2(2)
4734         PCM3=PSC1(3)+PSC2(3)
4735         ECM=PSC1(4)+PSC2(4)
4736         AM1=PSC1(5)**2
4737         AM2=PSC2(5)**2
4738         AMM=ECM**2-PCM1**2-PCM2**2-PCM3**2
4739         IF(AMM.LE.PSC1(5)+PSC2(5)) RETURN
4740 C                ********elastic scattering only when approaching
4741 C                                to each other
4742         PMAX=(AMM**2+AM1**2+AM2**2-2.0*AMM*AM1-2.0*AMM*AM2
4743      &                        -2.0*AM1*AM2)/4.0/AMM
4744         PMAX=ABS(PMAX)
4745 20        TT=RANART(NSEED)*MIN(PMAX,1.5)
4746         ELS=98.0*EXP(-2.8*TT)/EP
4747      &         +52.0*EXP(-9.2*TT)*(1.0+RR*EXP(-4.6*(BB-1.0)*TT))**2
4748         IF(RANART(NSEED).GT.ELS/ELS0) GO TO 20
4749         PHI=2.0*HIPR1(40)*RANART(NSEED)
4750 C
4751         DBX=dble(PCM1/ECM)
4752         DBY=dble(PCM2/ECM)
4753         DBZ=dble(PCM3/ECM)
4754         DB=dSQRT(DBX**2+DBY**2+DBZ**2)
4755         IF(DB.GT.0.99999999D0) THEN
4756           DBX=DBX*(0.99999999D0/DB)
4757           DBY=DBY*(0.99999999D0/DB)
4758           DBZ=DBZ*(0.99999999D0/DB)
4759           DB=0.99999999D0
4760           WRITE(6,*) ' (HIJELS) boost vector too large'
4761 C                ********Rescale boost vector if too close to unity.
4762         ENDIF
4763         DGA=1D0/SQRT(1D0-DB**2)
4764 C
4765         DP1=dble(SQRT(TT)*SIN(PHI))
4766         DP2=dble(SQRT(TT)*COS(PHI))
4767         DP3=dble(SQRT(PMAX-TT))
4768         DP4=dble(SQRT(PMAX+AM1))
4769         DBP=DBX*DP1+DBY*DP2+DBZ*DP3
4770         DGABP=DGA*(DGA*DBP/(1D0+DGA)+DP4)
4771         PSC1(1)=sngl(DP1+DGABP*DBX)
4772         PSC1(2)=sngl(DP2+DGABP*DBY)
4773         PSC1(3)=sngl(DP3+DGABP*DBZ)
4774         PSC1(4)=sngl(DGA*(DP4+DBP))
4775 C
4776         DP1=-dble(SQRT(TT)*SIN(PHI))
4777         DP2=-dble(SQRT(TT)*COS(PHI))
4778         DP3=-dble(SQRT(PMAX-TT))
4779         DP4=dble(SQRT(PMAX+AM2))
4780         DBP=DBX*DP1+DBY*DP2+DBZ*DP3
4781         DGABP=DGA*(DGA*DBP/(1D0+DGA)+DP4)
4782         PSC2(1)=sngl(DP1+DGABP*DBX)
4783         PSC2(2)=sngl(DP2+DGABP*DBY)
4784         PSC2(3)=sngl(DP3+DGABP*DBZ)
4785         PSC2(4)=sngl(DGA*(DP4+DBP))
4786         RETURN
4787         END
4788 C
4789 C
4790 C*******************************************************************
4791 C                                                                      *
4792 C                Subroutine HIJSFT                                   *
4793 C                                                                   *
4794 C  Scatter two excited strings, JP from proj and JT from target    *
4795 C*******************************************************************
4796         SUBROUTINE HIJSFT(JP,JT,JOUT,IERROR)
4797         PARAMETER (MAXSTR=150001)
4798         COMMON/hjcrdn/YP(3,300),YT(3,300)
4799 cc      SAVE /hjcrdn/
4800         COMMON/HPARNT/HIPR1(100),IHPR2(50),HINT1(100),IHNT2(50)
4801 cc      SAVE /HPARNT/
4802         COMMON/HIJDAT/HIDAT0(10,10),HIDAT(10)
4803 cc      SAVE /HIJDAT/
4804       COMMON/RNDF77/NSEED
4805 cc      SAVE /RNDF77/
4806         COMMON/HJJET1/NPJ(300),KFPJ(300,500),PJPX(300,500),
4807      &               PJPY(300,500),PJPZ(300,500),PJPE(300,500),
4808      &               PJPM(300,500),NTJ(300),KFTJ(300,500),
4809      &               PJTX(300,500),PJTY(300,500),PJTZ(300,500),
4810      &               PJTE(300,500),PJTM(300,500)
4811 cc      SAVE /HJJET1/
4812 clin-4/25/01
4813 c        COMMON/HJJET2/NSG,NJSG(900),IASG(900,3),K1SG(900,100),
4814 c     &                K2SG(900,100),PXSG(900,100),PYSG(900,100),
4815 c     &                PZSG(900,100),PESG(900,100),PMSG(900,100)
4816 cc      SAVE /HJJET2/
4817         COMMON/HSTRNG/NFP(300,15),PP(300,15),NFT(300,15),PT(300,15)
4818 cc      SAVE /HSTRNG/
4819         COMMON/DPMCM1/JJP,JJT,AMP,AMT,APX0,ATX0,AMPN,AMTN,AMP0,AMT0,
4820      &       NFDP,NFDT,WP,WM,SW,XREMP,XREMT,DPKC1,DPKC2,PP11,PP12,
4821      &       PT11,PT12,PTP2,PTT2
4822 cc      SAVE /DPMCM1/
4823         COMMON/DPMCM2/NDPM,KDPM(20,2),PDPM1(20,5),PDPM2(20,5)
4824 cc      SAVE /DPMCM2/
4825         SAVE
4826 C*******************************************************************
4827 C        JOUT-> the number
4828 C        of hard scatterings preceding this soft collision.
4829 C       IHNT2(13)-> 1=
4830 C        double diffrac 2=single diffrac, 3=non-single diffrac.
4831 C*******************************************************************
4832         IERROR=0
4833         JJP=JP
4834         JJT=JT
4835         NDPM=0
4836 c        IOPMAIN=0
4837         IF(JP.GT.IHNT2(1) .OR. JT.GT.IHNT2(3)) RETURN
4838
4839         EPP=PP(JP,4)+PP(JP,3)
4840         EPM=PP(JP,4)-PP(JP,3)
4841         ETP=PT(JT,4)+PT(JT,3)
4842         ETM=PT(JT,4)-PT(JT,3)
4843
4844         WP=EPP+ETP
4845         WM=EPM+ETM
4846         SW=WP*WM
4847 C                ********total W+,W- and center-of-mass energy
4848
4849         IF(WP.LT.0.0 .OR. WM.LT.0.0) GO TO 1000
4850
4851         IF(JOUT.EQ.0) THEN
4852                 IF(EPP.LT.0.0) GO TO 1000
4853                 IF(EPM.LT.0.0) GO TO 1000
4854                 IF(ETP.LT.0.0) GO TO 1000
4855                 IF(ETM.LT.0.0) GO TO 1000
4856                 IF(EPP/(EPM+0.01).LE.ETP/(ETM+0.01)) RETURN
4857         ENDIF
4858 C                ********For strings which does not follow a jet-prod,
4859 C                        scatter only if Ycm(JP)>Ycm(JT). When jets
4860 C                        are produced just before this collision
4861 C                        this requirement has already be enforced
4862 C                        (see SUBROUTINE HIJHRD)
4863         IHNT2(11)=JP
4864         IHNT2(12)=JT
4865 C
4866 C
4867 C
4868         MISS=0
4869         PKC1=0.0
4870         PKC2=0.0
4871         PKC11=0.0
4872         PKC12=0.0
4873         PKC21=0.0
4874         PKC22=0.0
4875         DPKC11=0.0
4876         DPKC12=0.0
4877         DPKC21=0.0
4878         DPKC22=0.0
4879         IF(NFP(JP,10).EQ.1.OR.NFT(JT,10).EQ.1) THEN
4880            IF(NFP(JP,10).EQ.1) THEN
4881               PHI1=ULANGL(PP(JP,10),PP(JP,11))
4882               PPJET=SQRT(PP(JP,10)**2+PP(JP,11)**2)
4883               PKC1=PPJET
4884               PKC11=PP(JP,10)
4885               PKC12=PP(JP,11)
4886            ENDIF
4887            IF(NFT(JT,10).EQ.1) THEN
4888               PHI2=ULANGL(PT(JT,10),PT(JT,11))
4889               PTJET=SQRT(PT(JT,10)**2+PT(JT,11)**2)
4890               PKC2=PTJET
4891               PKC21=PT(JT,10)
4892               PKC22=PT(JT,11)
4893            ENDIF
4894            IF(IHPR2(4).GT.0.AND.IHNT2(1).GT.1.AND.IHNT2(3).GT.1) THEN
4895               IF(NFP(JP,10).EQ.0) THEN
4896                  PHI=-PHI2
4897               ELSE IF(NFT(JT,10).EQ.0) THEN
4898                  PHI=PHI1
4899               ELSE
4900                  PHI=(PHI1+PHI2-HIPR1(40))/2.0
4901               ENDIF
4902               BX=HINT1(19)*COS(HINT1(20))
4903               BY=HINT1(19)*SIN(HINT1(20))
4904               XP0=YP(1,JP)
4905               YP0=YP(2,JP)
4906               XT0=YT(1,JT)+BX
4907               YT0=YT(2,JT)+BY
4908               R1=MAX(1.2*IHNT2(1)**0.3333333,
4909      &               SQRT(XP0**2+YP0**2))
4910               R2=MAX(1.2*IHNT2(3)**0.3333333,
4911      &               SQRT((XT0-BX)**2+(YT0-BY)**2))
4912               IF(ABS(COS(PHI)).LT.1.0E-5) THEN
4913                  DD1=R1
4914                  DD2=R1
4915                  DD3=ABS(BY+SQRT(R2**2-(XP0-BX)**2)-YP0)
4916                  DD4=ABS(BY-SQRT(R2**2-(XP0-BX)**2)-YP0)
4917                  GO TO 5
4918               ENDIF
4919               BB=2.0*SIN(PHI)*(COS(PHI)*YP0-SIN(PHI)*XP0)
4920               CC=(YP0**2-R1**2)*COS(PHI)**2+XP0*SIN(PHI)*(
4921      &                                XP0*SIN(PHI)-2.0*YP0*COS(PHI))
4922               DD=BB**2-4.0*CC
4923               IF(DD.LT.0.0) GO TO 10
4924               XX1=(-BB+SQRT(DD))/2.0
4925               XX2=(-BB-SQRT(DD))/2.0
4926               DD1=ABS((XX1-XP0)/COS(PHI))
4927               DD2=ABS((XX2-XP0)/COS(PHI))
4928 C
4929               BB=2.0*SIN(PHI)*(COS(PHI)*(YT0-BY)-SIN(PHI)*XT0)-2.0*BX
4930               CC=(BX**2+(YT0-BY)**2-R2**2)*COS(PHI)**2+XT0*SIN(PHI)
4931      &           *(XT0*SIN(PHI)-2.0*COS(PHI)*(YT0-BY))
4932      &                 -2.0*BX*SIN(PHI)*(COS(PHI)*(YT0-BY)-SIN(PHI)*XT0)
4933               DD=BB**2-4.0*CC
4934               IF(DD.LT.0.0) GO TO 10
4935               XX1=(-BB+SQRT(DD))/2.0
4936               XX2=(-BB-SQRT(DD))/2.0
4937               DD3=ABS((XX1-XT0)/COS(PHI))
4938               DD4=ABS((XX2-XT0)/COS(PHI))
4939 C
4940  5              DD1=MIN(DD1,DD3)
4941               DD2=MIN(DD2,DD4)
4942               IF(DD1.LT.HIPR1(13)) DD1=0.0
4943               IF(DD2.LT.HIPR1(13)) DD2=0.0
4944               IF(NFP(JP,10).EQ.1.AND.PPJET.GT.HIPR1(11)) THEN
4945                  DP1=DD1*HIPR1(14)/2.0
4946                  DP1=MIN(DP1,PPJET-HIPR1(11))
4947                  PKC1=PPJET-DP1
4948                  DPX1=COS(PHI1)*DP1
4949                  DPY1=SIN(PHI1)*DP1
4950                  PKC11=PP(JP,10)-DPX1
4951                  PKC12=PP(JP,11)-DPY1
4952                  IF(DP1.GT.0.0) THEN
4953                     CTHEP=PP(JP,12)/SQRT(PP(JP,12)**2+PPJET**2)
4954                     DPZ1=DP1*CTHEP/SQRT(1.0-CTHEP**2)
4955                     DPE1=SQRT(DPX1**2+DPY1**2+DPZ1**2)
4956                     EPPPRM=PP(JP,4)+PP(JP,3)-DPE1-DPZ1
4957                     EPMPRM=PP(JP,4)-PP(JP,3)-DPE1+DPZ1
4958                     IF(EPPPRM.LE.0.0.OR.EPMPRM.LE.0.0) GO TO 15
4959                     EPP=EPPPRM
4960                     EPM=EPMPRM
4961                     PP(JP,10)=PKC11
4962                     PP(JP,11)=PKC12
4963                     NPJ(JP)=NPJ(JP)+1
4964                     KFPJ(JP,NPJ(JP))=21
4965                     PJPX(JP,NPJ(JP))=DPX1
4966                     PJPY(JP,NPJ(JP))=DPY1
4967                     PJPZ(JP,NPJ(JP))=DPZ1
4968                     PJPE(JP,NPJ(JP))=DPE1
4969                     PJPM(JP,NPJ(JP))=0.0
4970                     PP(JP,3)=PP(JP,3)-DPZ1
4971                     PP(JP,4)=PP(JP,4)-DPE1
4972                  ENDIF
4973               ENDIF
4974  15              IF(NFT(JT,10).EQ.1.AND.PTJET.GT.HIPR1(11)) THEN
4975                  DP2=DD2*HIPR1(14)/2.0
4976                  DP2=MIN(DP2,PTJET-HIPR1(11))
4977                  PKC2=PTJET-DP2
4978                  DPX2=COS(PHI2)*DP2
4979                  DPY2=SIN(PHI2)*DP2
4980                  PKC21=PT(JT,10)-DPX2
4981                  PKC22=PT(JT,11)-DPY2
4982                  IF(DP2.GT.0.0) THEN
4983                     CTHET=PT(JT,12)/SQRT(PT(JT,12)**2+PTJET**2)
4984                     DPZ2=DP2*CTHET/SQRT(1.0-CTHET**2)
4985                     DPE2=SQRT(DPX2**2+DPY2**2+DPZ2**2)
4986                     ETPPRM=PT(JT,4)+PT(JT,3)-DPE2-DPZ2
4987                     ETMPRM=PT(JT,4)-PT(JT,3)-DPE2+DPZ2
4988                     IF(ETPPRM.LE.0.0.OR.ETMPRM.LE.0.0) GO TO 16
4989                     ETP=ETPPRM
4990                     ETM=ETMPRM
4991                     PT(JT,10)=PKC21
4992                     PT(JT,11)=PKC22
4993                     NTJ(JT)=NTJ(JT)+1
4994                     KFTJ(JT,NTJ(JT))=21
4995                     PJTX(JT,NTJ(JT))=DPX2
4996                     PJTY(JT,NTJ(JT))=DPY2
4997                     PJTZ(JT,NTJ(JT))=DPZ2
4998                     PJTE(JT,NTJ(JT))=DPE2
4999                     PJTM(JT,NTJ(JT))=0.0
5000                     PT(JT,3)=PT(JT,3)-DPZ2
5001                     PT(JT,4)=PT(JT,4)-DPE2
5002                  ENDIF
5003               ENDIF
5004  16              DPKC11=-(PP(JP,10)-PKC11)/2.0
5005               DPKC12=-(PP(JP,11)-PKC12)/2.0
5006               DPKC21=-(PT(JT,10)-PKC21)/2.0
5007               DPKC22=-(PT(JT,11)-PKC22)/2.0
5008               WP=EPP+ETP
5009               WM=EPM+ETM
5010               SW=WP*WM
5011            ENDIF
5012         ENDIF
5013 C                ********If jet is quenched the pt from valence quark
5014 C                        hard scattering has to reduced by d*kapa
5015 C
5016 C
5017 10        PTP02=PP(JP,1)**2+PP(JP,2)**2
5018         PTT02=PT(JT,1)**2+PT(JT,2)**2
5019 C
5020         AMQ=MAX(PP(JP,14)+PP(JP,15),PT(JT,14)+PT(JT,15))
5021         AMX=HIPR1(1)+AMQ
5022 C                ********consider mass cut-off for strings which
5023 C                        must also include quark's mass
5024         AMP0=AMX
5025         DPM0=AMX
5026         NFDP=0
5027         IF(NFP(JP,5).LE.2.AND.NFP(JP,3).NE.0) THEN
5028                 AMP0=ULMASS(NFP(JP,3))
5029                 NFDP=NFP(JP,3)+2*NFP(JP,3)/ABS(NFP(JP,3))
5030                 DPM0=ULMASS(NFDP)
5031                 IF(DPM0.LE.0.0) THEN
5032                         NFDP=NFDP-2*NFDP/ABS(NFDP)
5033                         DPM0=ULMASS(NFDP)
5034                 ENDIF
5035         ENDIF
5036         AMT0=AMX
5037         DTM0=AMX
5038         NFDT=0
5039         IF(NFT(JT,5).LE.2.AND.NFT(JT,3).NE.0) THEN
5040                 AMT0=ULMASS(NFT(JT,3))
5041                 NFDT=NFT(JT,3)+2*NFT(JT,3)/ABS(NFT(JT,3))
5042                 DTM0=ULMASS(NFDT)
5043                 IF(DTM0.LE.0.0) THEN
5044                         NFDT=NFDT-2*NFDT/ABS(NFDT)
5045                         DTM0=ULMASS(NFDT)
5046                 ENDIF
5047         ENDIF
5048 C
5049         AMPN=SQRT(AMP0**2+PTP02)
5050         AMTN=SQRT(AMT0**2+PTT02)
5051         SNN=(AMPN+AMTN)**2+0.001
5052 C
5053         IF(SW.LT.SNN+0.001) GO TO 4000
5054 C                ********Scatter only if SW>SNN
5055 C*****give some PT kick to the two exited strings******************
5056 clin 20        SWPTN=4.0*(MAX(AMP0,AMT0)**2+MAX(PTP02,PTT02))
5057         SWPTN=4.0*(MAX(AMP0,AMT0)**2+MAX(PTP02,PTT02))
5058         SWPTD=4.0*(MAX(DPM0,DTM0)**2+MAX(PTP02,PTT02))
5059         SWPTX=4.0*(AMX**2+MAX(PTP02,PTT02))
5060         IF(SW.LE.SWPTN) THEN
5061                 PKCMX=0.0
5062         ELSE IF(SW.GT.SWPTN .AND. SW.LE.SWPTD
5063      &                .AND.NPJ(JP).EQ.0.AND.NTJ(JT).EQ.0) THEN
5064            PKCMX=SQRT(SW/4.0-MAX(AMP0,AMT0)**2)
5065      &           -SQRT(MAX(PTP02,PTT02))
5066         ELSE IF(SW.GT.SWPTD .AND. SW.LE.SWPTX
5067      &                .AND.NPJ(JP).EQ.0.AND.NTJ(JT).EQ.0) THEN
5068            PKCMX=SQRT(SW/4.0-MAX(DPM0,DTM0)**2)
5069      &           -SQRT(MAX(PTP02,PTT02))
5070         ELSE IF(SW.GT.SWPTX) THEN
5071            PKCMX=SQRT(SW/4.0-AMX**2)-SQRT(MAX(PTP02,PTT02))
5072         ENDIF
5073 C                ********maximun PT kick
5074 C*********************************************************
5075 C
5076         IF(NFP(JP,10).EQ.1.OR.NFT(JT,10).EQ.1) THEN
5077                 IF(PKC1.GT.PKCMX) THEN
5078                         PKC1=PKCMX
5079                         PKC11=PKC1*COS(PHI1)
5080                         PKC12=PKC1*SIN(PHI1)
5081                         DPKC11=-(PP(JP,10)-PKC11)/2.0
5082                         DPKC12=-(PP(JP,11)-PKC12)/2.0
5083                 ENDIF
5084                 IF(PKC2.GT.PKCMX) THEN
5085                         PKC2=PKCMX
5086                         PKC21=PKC2*COS(PHI2)
5087                         PKC22=PKC2*SIN(PHI2)
5088                         DPKC21=-(PT(JT,10)-PKC21)/2.0
5089                         DPKC22=-(PT(JT,11)-PKC22)/2.0
5090                 ENDIF
5091                 DPKC1=DPKC11+DPKC21
5092                 DPKC2=DPKC12+DPKC22
5093                 NFP(JP,10)=-NFP(JP,10)
5094                 NFT(JT,10)=-NFT(JT,10)
5095                 GO TO 40
5096         ENDIF
5097 C                ********If the valence quarks had a hard-collision
5098 C                        the pt kick is the pt from hard-collision.
5099         isng=0
5100         IF(IHPR2(13).NE.0 .AND. RANART(NSEED).LE.HIDAT(4)) isng=1
5101         IF((NFP(JP,5).EQ.3 .OR.NFT(JT,5).EQ.3).OR.
5102      &                (NPJ(JP).NE.0.OR.NFP(JP,10).NE.0).OR.
5103      &                (NTJ(JT).NE.0.OR.NFT(JT,10).NE.0)) isng=0
5104 C
5105 C               ********decite whether to have single-diffractive
5106         IF(IHPR2(5).EQ.0) THEN
5107                 PKC=HIPR1(2)*SQRT(-ALOG(1.0-RANART(NSEED)
5108      &                        *(1.0-EXP(-PKCMX**2/HIPR1(2)**2))))
5109                 GO TO 30
5110         ENDIF
5111
5112 clin-10/28/02 get rid of argument usage mismatch in HIRND2():
5113 c        PKC=HIRND2(3,0.0,PKCMX**2)
5114         xminhi=0.0
5115         xmaxhi=PKCMX**2
5116         PKC=HIRND2(3,xminhi,xmaxhi)
5117
5118         PKC=SQRT(PKC)
5119         IF(PKC.GT.HIPR1(20))
5120      &           PKC=HIPR1(2)*SQRT(-ALOG(EXP(-HIPR1(20)**2/HIPR1(2)**2)
5121      &               -RANART(NSEED)*(EXP(-HIPR1(20)**2/HIPR1(2)**2)-
5122      &               EXP(-PKCMX**2/HIPR1(2)**2))))
5123 C
5124         IF(isng.EQ.1) PKC=0.65*SQRT(
5125      &       -ALOG(1.0-RANART(NSEED)*(1.0-EXP(-PKCMX**2/0.65**2))))
5126 C                        ********select PT kick
5127 30        PHI0=2.0*HIPR1(40)*RANART(NSEED)
5128         PKC11=PKC*SIN(PHI0)
5129         PKC12=PKC*COS(PHI0)
5130         PKC21=-PKC11
5131         PKC22=-PKC12
5132         DPKC1=0.0
5133         DPKC2=0.0
5134 40        PP11=PP(JP,1)+PKC11-DPKC1
5135         PP12=PP(JP,2)+PKC12-DPKC2
5136         PT11=PT(JT,1)+PKC21-DPKC1
5137         PT12=PT(JT,2)+PKC22-DPKC2
5138         PTP2=PP11**2+PP12**2
5139         PTT2=PT11**2+PT12**2
5140 C
5141         AMPN=SQRT(AMP0**2+PTP2)
5142         AMTN=SQRT(AMT0**2+PTT2)
5143         SNN=(AMPN+AMTN)**2+0.001
5144 C***************************************
5145         WP=EPP+ETP
5146         WM=EPM+ETM
5147         SW=WP*WM
5148 C****************************************
5149         IF(SW.LT.SNN) THEN
5150            MISS=MISS+1
5151            IF(MISS.LE.100) then
5152               PKC=0.0
5153               GO TO 30
5154            ENDIF
5155            IF(IHPR2(10).NE.0)
5156      &          WRITE(6,*) 'Error occured in Pt kick section of HIJSFT'
5157            GO TO 4000
5158         ENDIF
5159 C******************************************************************
5160         AMPD=SQRT(DPM0**2+PTP2)
5161         AMTD=SQRT(DTM0**2+PTT2)
5162
5163         AMPX=SQRT(AMX**2+PTP2)
5164         AMTX=SQRT(AMX**2+PTT2)
5165
5166         DPN=AMPN**2/SW
5167         DTN=AMTN**2/SW
5168         DPD=AMPD**2/SW
5169         DTD=AMTD**2/SW
5170         DPX=AMPX**2/SW
5171         DTX=AMTX**2/SW
5172 C
5173         SPNTD=(AMPN+AMTD)**2
5174         SPNTX=(AMPN+AMTX)**2
5175 C                        ********CM energy if proj=N,targ=N*
5176         SPDTN=(AMPD+AMTN)**2
5177         SPXTN=(AMPX+AMTN)**2
5178 C                        ********CM energy if proj=N*,targ=N
5179         SPDTX=(AMPD+AMTX)**2
5180         SPXTD=(AMPX+AMTD)**2
5181         SDD=(AMPD+AMTD)**2
5182         SXX=(AMPX+AMTX)**2
5183
5184 C
5185 C
5186 C                ********CM energy if proj=delta, targ=delta
5187 C****************There are many different cases**********
5188 c        IF(IHPR2(15).EQ.1) GO TO 500
5189 C
5190 C                ********to have DPM type soft interactions
5191 C
5192 clin 45        CONTINUE
5193         IF(SW.GT.SXX+0.001) THEN
5194            IF(isng.EQ.0) THEN
5195                D1=DPX
5196               D2=DTX
5197               NFP3=0
5198               NFT3=0
5199               GO TO 400
5200            ELSE
5201 c**** 5/30/1998 this is identical to the above statement. Added to
5202 c**** avoid questional branching to block.
5203               IF((NFP(JP,5).EQ.3 .AND.NFT(JT,5).EQ.3).OR.
5204      &                 (NPJ(JP).NE.0.OR.NFP(JP,10).NE.0).OR.
5205      &                 (NTJ(JT).NE.0.OR.NFT(JT,10).NE.0)) THEN
5206                  D1=DPX
5207                  D2=DTX
5208                  NFP3=0
5209                  NFT3=0
5210                  GO TO 400
5211               ENDIF
5212 C                ********do not allow excited strings to have
5213 C                        single-diffr
5214               IF(RANART(NSEED).GT.0.5.OR.(NFT(JT,5).GT.2.OR.
5215      &                      NTJ(JT).NE.0.OR.NFT(JT,10).NE.0)) THEN
5216                  D1=DPN
5217                  D2=DTX
5218                  NFP3=NFP(JP,3)
5219                  NFT3=0
5220                  GO TO 220
5221               ELSE
5222                  D1=DPX
5223                  D2=DTN
5224                  NFP3=0
5225                  NFT3=NFT(JT,3)
5226                  GO TO 240
5227               ENDIF
5228 C                ********have single diffractive collision
5229            ENDIF
5230         ELSE IF(SW.GT.MAX(SPDTX,SPXTD)+0.001 .AND.
5231      &                                SW.LE.SXX+0.001) THEN
5232            IF(((NPJ(JP).EQ.0.AND.NTJ(JT).EQ.0.AND.
5233      &         RANART(NSEED).GT.0.5).OR.(NPJ(JP).EQ.0
5234      &         .AND.NTJ(JT).NE.0)).AND.NFP(JP,5).LE.2) THEN
5235               D1=DPD
5236               D2=DTX
5237               NFP3=NFDP
5238               NFT3=0
5239               GO TO 220
5240            ELSE IF(NTJ(JT).EQ.0.AND.NFT(JT,5).LE.2) THEN
5241               D1=DPX
5242               D2=DTD
5243               NFP3=0
5244               NFT3=NFDT
5245               GO TO 240
5246            ENDIF
5247            GO TO 4000
5248         ELSE IF(SW.GT.MIN(SPDTX,SPXTD)+0.001.AND.
5249      &                        SW.LE.MAX(SPDTX,SPXTD)+0.001) THEN
5250            IF(SPDTX.LE.SPXTD.AND.NPJ(JP).EQ.0
5251      &                       .AND.NFP(JP,5).LE.2) THEN
5252               D1=DPD
5253               D2=DTX
5254               NFP3=NFDP
5255               NFT3=0
5256               GO TO 220
5257            ELSE IF(SPDTX.GT.SPXTD.AND.NTJ(JT).EQ.0
5258      &                       .AND.NFT(JT,5).LE.2) THEN
5259               D1=DPX
5260               D2=DTD
5261               NFP3=0
5262               NFT3=NFDT
5263               GO TO 240
5264            ENDIF
5265 c*** 5/30/1998 added to avoid questional branching to another block
5266 c*** this is identical to the statement following the next ELSE IF
5267            IF(((NPJ(JP).EQ.0.AND.NTJ(JT).EQ.0
5268      &       .AND.RANART(NSEED).GT.0.5).OR.(NPJ(JP).EQ.0
5269      &        .AND.NTJ(JT).NE.0)).AND.NFP(JP,5).LE.2) THEN
5270               D1=DPN
5271               D2=DTX
5272               NFP3=NFP(JP,3)
5273               NFT3=0
5274               GO TO 220
5275            ELSE IF(NTJ(JT).EQ.0.AND.NFT(JT,5).LE.2) THEN
5276               D1=DPX
5277               D2=DTN
5278               NFP3=0
5279               NFT3=NFT(JT,3)
5280               GO TO 240
5281            ENDIF
5282            GO TO 4000
5283         ELSE IF(SW.GT.MAX(SPNTX,SPXTN)+0.001 .AND.
5284      &                        SW.LE.MIN(SPDTX,SPXTD)+0.001) THEN
5285            IF(((NPJ(JP).EQ.0.AND.NTJ(JT).EQ.0
5286      &       .AND.RANART(NSEED).GT.0.5).OR.(NPJ(JP).EQ.0
5287      &        .AND.NTJ(JT).NE.0)).AND.NFP(JP,5).LE.2) THEN
5288               D1=DPN
5289               D2=DTX
5290               NFP3=NFP(JP,3)
5291               NFT3=0
5292               GO TO 220
5293            ELSE IF(NTJ(JT).EQ.0.AND.NFT(JT,5).LE.2) THEN
5294               D1=DPX
5295               D2=DTN
5296               NFP3=0
5297               NFT3=NFT(JT,3)
5298               GO TO 240
5299            ENDIF
5300            GO TO 4000
5301         ELSE IF(SW.GT.MIN(SPNTX,SPXTN)+0.001 .AND.
5302      &                        SW.LE.MAX(SPNTX,SPXTN)+0.001) THEN
5303            IF(SPNTX.LE.SPXTN.AND.NPJ(JP).EQ.0
5304      &                           .AND.NFP(JP,5).LE.2) THEN
5305               D1=DPN
5306               D2=DTX
5307               NFP3=NFP(JP,3)
5308               NFT3=0
5309               GO TO 220
5310            ELSEIF(SPNTX.GT.SPXTN.AND.NTJ(JT).EQ.0
5311      &                           .AND.NFT(JT,5).LE.2) THEN
5312               D1=DPX
5313               D2=DTN
5314               NFP3=0
5315               NFT3=NFT(JT,3)
5316               GO TO 240
5317            ENDIF
5318            GO TO 4000
5319         ELSE IF(SW.LE.MIN(SPNTX,SPXTN)+0.001 .AND.
5320      &                        (NPJ(JP).NE.0 .OR.NTJ(JT).NE.0)) THEN
5321            GO TO 4000
5322         ELSE IF(SW.LE.MIN(SPNTX,SPXTN)+0.001 .AND.
5323      &                NFP(JP,5).GT.2.AND.NFT(JT,5).GT.2) THEN
5324            GO TO 4000
5325         ELSE IF(SW.GT.SDD+0.001.AND.SW.LE.
5326      &                     MIN(SPNTX,SPXTN)+0.001) THEN
5327            D1=DPD
5328            D2=DTD
5329            NFP3=NFDP
5330            NFT3=NFDT
5331            GO TO 100
5332         ELSE IF(SW.GT.MAX(SPNTD,SPDTN)+0.001
5333      &                      .AND. SW.LE.SDD+0.001) THEN
5334            IF(RANART(NSEED).GT.0.5) THEN
5335               D1=DPD
5336               D2=DTN
5337               NFP3=NFDP
5338               NFT3=NFT(JT,3)
5339               GO TO 100
5340            ELSE
5341               D1=DPN
5342               D2=DTD
5343               NFP3=NFP(JP,3)
5344               NFT3=NFDT
5345               GO TO 100
5346            ENDIF
5347         ELSE IF(SW.GT.MIN(SPNTD,SPDTN)+0.001
5348      &                .AND. SW.LE.MAX(SPNTD,SPDTN)+0.001) THEN
5349            IF(SPNTD.GT.SPDTN) THEN
5350               D1=DPD
5351               D2=DTN
5352               NFP3=NFDP
5353               NFT3=NFT(JT,3)
5354               GO TO 100
5355            ELSE
5356               D1=DPN
5357               D2=DTD
5358               NFP3=NFP(JP,3)
5359               NFT3=NFDT
5360               GO TO 100
5361            ENDIF
5362         ELSE IF(SW.LE.MIN(SPNTD,SPDTN)+0.001) THEN
5363            D1=DPN
5364            D2=DTN
5365            NFP3=NFP(JP,3)
5366            NFT3=NFT(JT,3)
5367            GO TO 100
5368         ENDIF
5369         WRITE(6,*) ' Error in HIJSFT: There is no path to here'
5370         RETURN
5371 C
5372 C***************  elastic scattering ***************
5373 C        this is like elastic, both proj and targ mass
5374 C        must be fixed
5375 C***************************************************
5376 100        NFP5=MAX(2,NFP(JP,5))
5377         NFT5=MAX(2,NFT(JT,5))
5378         BB1=1.0+D1-D2
5379         BB2=1.0+D2-D1
5380         IF(BB1**2.LT.4.0*D1 .OR. BB2**2.LT.4.0*D2) THEN
5381                 MISS=MISS+1
5382                 IF(MISS.GT.100.OR.PKC.EQ.0.0) GO TO 3000
5383                 PKC=PKC*0.5
5384                 GO TO 30
5385         ENDIF
5386         IF(RANART(NSEED).LT.0.5) THEN
5387                 X1=(BB1-SQRT(BB1**2-4.0*D1))/2.0
5388                 X2=(BB2-SQRT(BB2**2-4.0*D2))/2.0
5389         ELSE
5390                 X1=(BB1+SQRT(BB1**2-4.0*D1))/2.0
5391                 X2=(BB2+SQRT(BB2**2-4.0*D2))/2.0
5392         ENDIF
5393         IHNT2(13)=2
5394         GO TO 600
5395 C
5396 C********** Single diffractive ***********************
5397 C either proj or targ's mass is fixed
5398 C*****************************************************
5399 220        NFP5=MAX(2,NFP(JP,5))
5400         NFT5=3
5401         IF(NFP3.EQ.0) NFP5=3
5402         BB2=1.0+D2-D1
5403         IF(BB2**2.LT.4.0*D2) THEN
5404                 MISS=MISS+1
5405                 IF(MISS.GT.100.OR.PKC.EQ.0.0) GO TO 3000
5406                 PKC=PKC*0.5
5407                 GO TO 30
5408         ENDIF
5409         XMIN=(BB2-SQRT(BB2**2-4.0*D2))/2.0
5410         XMAX=(BB2+SQRT(BB2**2-4.0*D2))/2.0
5411         MISS4=0
5412 222        X2=HIRND2(6,XMIN,XMAX)
5413         X1=D1/(1.0-X2)
5414         IF(X2*(1.0-X1).LT.(D2+1.E-4/SW)) THEN
5415                 MISS4=MISS4+1
5416                 IF(MISS4.LE.1000) GO TO 222
5417                 GO TO 5000
5418         ENDIF
5419         IHNT2(13)=2
5420         GO TO 600
5421 C                        ********Fix proj mass*********
5422 240        NFP5=3
5423         NFT5=MAX(2,NFT(JT,5))
5424         IF(NFT3.EQ.0) NFT5=3
5425         BB1=1.0+D1-D2
5426         IF(BB1**2.LT.4.0*D1) THEN
5427                 MISS=MISS+1
5428                 IF(MISS.GT.100.OR.PKC.EQ.0.0) GO TO 3000
5429                 PKC=PKC*0.5
5430                 GO TO 30
5431         ENDIF
5432         XMIN=(BB1-SQRT(BB1**2-4.0*D1))/2.0
5433         XMAX=(BB1+SQRT(BB1**2-4.0*D1))/2.0
5434         MISS4=0
5435 242        X1=HIRND2(6,XMIN,XMAX)
5436         X2=D2/(1.0-X1)
5437         IF(X1*(1.0-X2).LT.(D1+1.E-4/SW)) THEN
5438                 MISS4=MISS4+1
5439                 IF(MISS4.LE.1000) GO TO 242
5440                 GO TO 5000
5441         ENDIF
5442         IHNT2(13)=2
5443         GO TO 600
5444 C                        ********Fix targ mass*********
5445 C
5446 C*************non-single diffractive**********************
5447 C        both proj and targ may not be fixed in mass
5448 C*********************************************************
5449 C
5450 400        NFP5=3
5451         NFT5=3
5452         BB1=1.0+D1-D2
5453         BB2=1.0+D2-D1
5454         IF(BB1**2.LT.4.0*D1 .OR. BB2**2.LT.4.0*D2) THEN
5455                 MISS=MISS+1
5456                 IF(MISS.GT.100.OR.PKC.EQ.0.0) GO TO 3000
5457                 PKC=PKC*0.5
5458                 GO TO 30
5459         ENDIF
5460         XMIN1=(BB1-SQRT(BB1**2-4.0*D1))/2.0
5461         XMAX1=(BB1+SQRT(BB1**2-4.0*D1))/2.0
5462         XMIN2=(BB2-SQRT(BB2**2-4.0*D2))/2.0
5463         XMAX2=(BB2+SQRT(BB2**2-4.0*D2))/2.0
5464         MISS4=0
5465 410        X1=HIRND2(4,XMIN1,XMAX1)
5466         X2=HIRND2(4,XMIN2,XMAX2)
5467         IF(NFP(JP,5).EQ.3.OR.NFT(JT,5).EQ.3) THEN
5468                 X1=HIRND2(6,XMIN1,XMAX1)
5469                 X2=HIRND2(6,XMIN2,XMAX2)
5470         ENDIF
5471 C                        ********
5472         IF(ABS(NFP(JP,1)*NFP(JP,2)).GT.1000000.OR.
5473      &                        ABS(NFP(JP,1)*NFP(JP,2)).LT.100) THEN
5474                 X1=HIRND2(5,XMIN1,XMAX1)
5475         ENDIF
5476         IF(ABS(NFT(JT,1)*NFT(JT,2)).GT.1000000.OR.
5477      &                        ABS(NFT(JT,1)*NFT(JT,2)).LT.100) THEN
5478                 X2=HIRND2(5,XMIN2,XMAX2)
5479         ENDIF
5480 c        IF(IOPMAIN.EQ.3) X1=HIRND2(6,XMIN1,XMAX1)
5481 c        IF(IOPMAIN.EQ.2) X2=HIRND2(6,XMIN2,XMAX2)
5482 C        ********For q-qbar or (qq)-(qq)bar system use symetric
5483 C                distribution, for q-(qq) or qbar-(qq)bar use
5484 C                unsymetrical distribution
5485 C
5486         IF(ABS(NFP(JP,1)*NFP(JP,2)).GT.1000000) X1=1.0-X1
5487         XXP=X1*(1.0-X2)
5488         XXT=X2*(1.0-X1)
5489         IF(XXP.LT.(D1+1.E-4/SW) .OR. XXT.LT.(D2+1.E-4/SW)) THEN
5490                 MISS4=MISS4+1
5491                 IF(MISS4.LE.1000) GO TO 410
5492                 GO TO 5000
5493         ENDIF
5494         IHNT2(13)=3
5495 C***************************************************
5496 C***************************************************
5497 600        CONTINUE
5498         IF(X1*(1.0-X2).LT.(AMPN**2-1.E-4)/SW.OR.
5499      &                        X2*(1.0-X1).LT.(AMTN**2-1.E-4)/SW) THEN
5500                 MISS=MISS+1
5501                 IF(MISS.GT.100.OR.PKC.EQ.0.0) GO TO 2000
5502                 PKC=0.0
5503                 GO TO 30
5504         ENDIF
5505 C
5506         EPP=(1.0-X2)*WP
5507         EPM=X1*WM
5508         ETP=X2*WP
5509         ETM=(1.0-X1)*WM
5510         PP(JP,3)=(EPP-EPM)/2.0
5511         PP(JP,4)=(EPP+EPM)/2.0
5512         IF(EPP*EPM-PTP2.LT.0.0) GO TO 6000
5513         PP(JP,5)=SQRT(EPP*EPM-PTP2)
5514         NFP(JP,3)=NFP3
5515         NFP(JP,5)=NFP5
5516
5517         PT(JT,3)=(ETP-ETM)/2.0
5518         PT(JT,4)=(ETP+ETM)/2.0
5519         IF(ETP*ETM-PTT2.LT.0.0) GO TO 6000
5520         PT(JT,5)=SQRT(ETP*ETM-PTT2)
5521         NFT(JT,3)=NFT3
5522         NFT(JT,5)=NFT5
5523 C*****recoil PT from hard-inter is shared by two end-partons
5524 C       so that pt=p1+p2
5525         PP(JP,1)=PP11-PKC11
5526         PP(JP,2)=PP12-PKC12
5527
5528         KCDIP=1
5529         KCDIT=1
5530         IF(ABS(NFP(JP,1)*NFP(JP,2)).GT.1000000.OR.
5531      &                        ABS(NFP(JP,1)*NFP(JP,2)).LT.100) THEN
5532                 KCDIP=0
5533         ENDIF
5534         IF(ABS(NFT(JT,1)*NFT(JT,2)).GT.1000000.OR.
5535      &                        ABS(NFT(JT,1)*NFT(JT,2)).LT.100) THEN
5536                 KCDIT=0
5537         ENDIF
5538         IF((KCDIP.EQ.0.AND.RANART(NSEED).LT.0.5)
5539      &     .OR.(KCDIP.NE.0.AND.RANART(NSEED)
5540      &     .LT.0.5/(1.0+(PKC11**2+PKC12**2)/HIPR1(22)**2))) THEN
5541            PP(JP,6)=(PP(JP,1)-PP(JP,6)-PP(JP,8)-DPKC1)/2.0+PP(JP,6)
5542            PP(JP,7)=(PP(JP,2)-PP(JP,7)-PP(JP,9)-DPKC2)/2.0+PP(JP,7)
5543            PP(JP,8)=(PP(JP,1)-PP(JP,6)-PP(JP,8)-DPKC1)/2.0
5544      &              +PP(JP,8)+PKC11
5545            PP(JP,9)=(PP(JP,2)-PP(JP,7)-PP(JP,9)-DPKC2)/2.0
5546      &              +PP(JP,9)+PKC12
5547         ELSE
5548            PP(JP,8)=(PP(JP,1)-PP(JP,6)-PP(JP,8)-DPKC1)/2.0+PP(JP,8)
5549            PP(JP,9)=(PP(JP,2)-PP(JP,7)-PP(JP,9)-DPKC2)/2.0+PP(JP,9)
5550            PP(JP,6)=(PP(JP,1)-PP(JP,6)-PP(JP,8)-DPKC1)/2.0
5551      &              +PP(JP,6)+PKC11
5552            PP(JP,7)=(PP(JP,2)-PP(JP,7)-PP(JP,9)-DPKC2)/2.0
5553      &              +PP(JP,7)+PKC12
5554         ENDIF
5555         PP(JP,1)=PP(JP,6)+PP(JP,8)
5556         PP(JP,2)=PP(JP,7)+PP(JP,9)
5557 C                                ********pt kick for proj
5558         PT(JT,1)=PT11-PKC21
5559         PT(JT,2)=PT12-PKC22
5560         IF((KCDIT.EQ.0.AND.RANART(NSEED).LT.0.5)
5561      &     .OR.(KCDIT.NE.0.AND.RANART(NSEED)
5562      &     .LT.0.5/(1.0+(PKC21**2+PKC22**2)/HIPR1(22)**2))) THEN
5563            PT(JT,6)=(PT(JT,1)-PT(JT,6)-PT(JT,8)-DPKC1)/2.0+PT(JT,6)
5564            PT(JT,7)=(PT(JT,2)-PT(JT,7)-PT(JT,9)-DPKC2)/2.0+PT(JT,7)
5565            PT(JT,8)=(PT(JT,1)-PT(JT,6)-PT(JT,8)-DPKC1)/2.0
5566      &              +PT(JT,8)+PKC21
5567            PT(JT,9)=(PT(JT,2)-PT(JT,7)-PT(JT,9)-DPKC2)/2.0
5568      &              +PT(JT,9)+PKC22
5569         ELSE
5570            PT(JT,8)=(PT(JT,1)-PT(JT,6)-PT(JT,8)-DPKC1)/2.0+PT(JT,8)
5571            PT(JT,9)=(PT(JT,2)-PT(JT,7)-PT(JT,9)-DPKC2)/2.0+PT(JT,9)
5572            PT(JT,6)=(PT(JT,1)-PT(JT,6)-PT(JT,8)-DPKC1)/2.0
5573      &              +PT(JT,6)+PKC21
5574            PT(JT,7)=(PT(JT,2)-PT(JT,7)-PT(JT,9)-DPKC2)/2.0
5575      &              +PT(JT,7)+PKC22
5576         ENDIF
5577         PT(JT,1)=PT(JT,6)+PT(JT,8)
5578         PT(JT,2)=PT(JT,7)+PT(JT,9)
5579 C                        ********pt kick for targ
5580
5581         IF(NPJ(JP).NE.0) NFP(JP,5)=3
5582         IF(NTJ(JT).NE.0) NFT(JT,5)=3
5583 C                        ********jets must be connected to string
5584         IF(EPP/(EPM+0.0001).LT.ETP/(ETM+0.0001).AND.
5585      &                        ABS(NFP(JP,1)*NFP(JP,2)).LT.1000000)THEN
5586                 DO 620 JSB=1,15
5587                 PSB=PP(JP,JSB)
5588                 PP(JP,JSB)=PT(JT,JSB)
5589                 PT(JT,JSB)=PSB
5590                 NSB=NFP(JP,JSB)
5591                 NFP(JP,JSB)=NFT(JT,JSB)
5592                 NFT(JT,JSB)=NSB
5593 620                CONTINUE
5594 C                ********when Ycm(JP)<Ycm(JT) after the collision
5595 C                        exchange the positions of the two
5596         ENDIF
5597 C
5598         RETURN
5599 C**************************************************
5600 C**************************************************
5601 1000        IERROR=1
5602         IF(IHPR2(10).EQ.0) RETURN
5603         WRITE(6,*) '     Fatal HIJSFT start error,abandon this event'
5604         WRITE(6,*) '     PROJ E+,E-,W+',EPP,EPM,WP
5605         WRITE(6,*) '     TARG E+,E-,W-',ETP,ETM,WM
5606         WRITE(6,*) '     W+*W-, (APN+ATN)^2',SW,SNN
5607         RETURN
5608 2000        IERROR=0
5609         IF(IHPR2(10).EQ.0) RETURN
5610         WRITE(6,*) '     (2)energy partition fail,'
5611         WRITE(6,*) '     HIJSFT not performed, but continue'
5612         WRITE(6,*) '     MP1,MPN',X1*(1.0-X2)*SW,AMPN**2
5613         WRITE(6,*) '     MT2,MTN',X2*(1.0-X1)*SW,AMTN**2
5614         RETURN
5615 3000        IERROR=0
5616         IF(IHPR2(10).EQ.0) RETURN
5617         WRITE(6,*) '     (3)something is wrong with the pt kick, '
5618         WRITE(6,*) '     HIJSFT not performed, but continue'
5619         WRITE(6,*) '     D1=',D1,' D2=',D2,' SW=',SW
5620         WRITE(6,*) '     HISTORY NFP5=',NFP(JP,5),' NFT5=',NFT(JT,5)
5621         WRITE(6,*) '     THIS COLLISON NFP5=',NFP5, ' NFT5=',NFT5
5622         WRITE(6,*) '     # OF JET IN PROJ',NPJ(JP),' IN TARG',NTJ(JT)
5623         RETURN
5624 4000        IERROR=0
5625         IF(IHPR2(10).EQ.0) RETURN
5626         WRITE(6,*) '     (4)unable to choose process, but not harmful'
5627         WRITE(6,*) '     HIJSFT not performed, but continue'
5628         WRITE(6,*) '     PTP=',SQRT(PTP2),' PTT=',SQRT(PTT2),' SW=',SW
5629         WRITE(6,*) '     AMCUT=',AMX,' JP=',JP,' JT=',JT
5630         WRITE(6,*) '     HISTORY NFP5=',NFP(JP,5),' NFT5=',NFT(JT,5)
5631         RETURN
5632 5000        IERROR=0
5633         IF(IHPR2(10).EQ.0) RETURN
5634         WRITE(6,*) '     energy partition failed(5),for limited try'
5635         WRITE(6,*) '     HIJSFT not performed, but continue'
5636         WRITE(6,*) '     NFP5=',NFP5,' NFT5=',NFT5
5637         WRITE(6,*) '     D1',D1,' X1(1-X2)',X1*(1.0-X2)
5638         WRITE(6,*) '     D2',D2,' X2(1-X1)',X2*(1.0-X1)
5639         RETURN
5640 6000        PKC=0.0
5641         MISS=MISS+1
5642         IF(MISS.LT.100) GO TO 30
5643         IERROR=1
5644         IF(IHPR2(10).EQ.0) RETURN
5645         WRITE(6,*) ' ERROR OCCURED, HIJSFT NOT PERFORMED'
5646         WRITE(6,*) ' Abort this event'
5647         WRITE(6,*) 'MTP,PTP2',EPP*EPM,PTP2,'  MTT,PTT2',ETP*ETM,PTT2
5648         RETURN
5649         END
5650 C
5651 C
5652 C
5653 C ********************************************************
5654 C ************************              WOOD-SAX
5655         SUBROUTINE HIJWDS(IA,IDH,XHIGH)
5656 C     SETS UP HISTOGRAM IDH WITH RADII FOR
5657 C     NUCLEUS IA DISTRIBUTED ACCORDING TO THREE PARAM WOOD SAXON
5658         COMMON/HPARNT/HIPR1(100),IHPR2(50),HINT1(100),IHNT2(50)
5659 cc      SAVE /HPARNT/
5660         COMMON/WOOD/R,D,FNORM,W
5661 cc      SAVE /WOOD/
5662 c        DIMENSION IAA(20),RR(20),DD(20),WW(20),RMS(20)
5663         DIMENSION IAA(20),RR(20),DD(20),WW(20)
5664         EXTERNAL RWDSAX,WDSAX
5665         SAVE
5666 C
5667 C   PARAMETERS OF SPECIAL NUCLEI FROM ATOMIC DATA AND NUC DATA TABLES
5668 C     VOL 14, 5-6 1974
5669         DATA IAA/2,4,12,16,27,32,40,56,63,93,184,197,208,7*0./
5670         DATA RR/0.01,.964,2.355,2.608,2.84,3.458,3.766,3.971,4.214,
5671      1        4.87,6.51,6.38,6.624,7*0./
5672         DATA DD/0.5882,.322,.522,.513,.569,.61,.586,.5935,.586,.573,
5673      1        .535,.535,.549,7*0./
5674         DATA WW/0.0,.517,-0.149,-0.051,0.,-0.208,-0.161,13*0./
5675 c        DATA RMS/2.11,1.71,2.46,2.73,3.05,3.247,3.482,3.737,3.925,4.31,
5676 c     1        5.42,5.33,5.521,7*0./
5677 C
5678               A=IA
5679 C
5680 C                 ********SET WOOD-SAX PARAMS FIRST  AS IN DATE ET AL
5681               D=0.54
5682 C                        ********D IS WOOD SAX DIFFUSE PARAM IN FM
5683         R=1.19*A**(1./3.) - 1.61*A**(-1./3.)
5684 C                         ********R IS RADIUS PARAM
5685         W=0.
5686 C                 ********W IS The third of three WOOD-SAX PARAM
5687 C
5688 C                      ********CHECK TABLE FOR SPECIAL CASES
5689         DO 10 I=1,13
5690                 IF (IA.EQ.IAA(I)) THEN
5691                         R=RR(I)
5692                              D=DD(I)
5693                               W=WW(I)
5694 clin RS not used                              RS=RMS(I)
5695                       END IF
5696 10            CONTINUE
5697 C                             ********FNORM is the normalize factor
5698               FNORM=1.0
5699               XLOW=0.
5700               XHIGH=R+ 12.*D
5701               IF (W.LT.-0.01)  THEN
5702                       IF (XHIGH.GT.R/SQRT(ABS(W))) XHIGH=R/SQRT(ABS(W))
5703               END IF
5704               FGAUS=GAUSS1(RWDSAX,XLOW,XHIGH,0.001)
5705               FNORM=1./FGAUS
5706 C
5707         IF (IDH.EQ.1) THEN
5708            HINT1(72)=R
5709            HINT1(73)=D
5710            HINT1(74)=W
5711            HINT1(75)=FNORM/4.0/HIPR1(40)
5712         ELSE IF (IDH.EQ.2) THEN
5713            HINT1(76)=R
5714            HINT1(77)=D
5715            HINT1(78)=W
5716            HINT1(79)=FNORM/4.0/HIPR1(40)
5717         ENDIF
5718 C
5719 C             NOW SET UP HBOOK FUNCTIONS IDH FOR  R**2*RHO(R)
5720 C             THESE HISTOGRAMS ARE USED TO GENERATE RANDOM RADII
5721               CALL HIFUN(IDH,XLOW,XHIGH,RWDSAX)
5722               RETURN
5723               END
5724 C
5725 C
5726         FUNCTION WDSAX(X)
5727 C                             ********THREE PARAMETER WOOD SAXON
5728               COMMON/WOOD/R,D,FNORM,W
5729 cc      SAVE /WOOD/
5730         SAVE
5731               WDSAX=FNORM*(1.+W*(X/R)**2)/(1+EXP((X-R)/D))
5732                IF (W.LT.0.) THEN
5733                        IF (X.GE.R/SQRT(ABS(W))) WDSAX=0.
5734                ENDIF
5735               RETURN
5736               END
5737 C
5738 C
5739         FUNCTION RWDSAX(X)
5740         SAVE
5741               RWDSAX=X*X*WDSAX(X)
5742               RETURN
5743               END
5744 C
5745 C
5746 C
5747 C
5748 C The next three subroutines are for Monte Carlo generation
5749 C according to a given function FHB. One calls first HIFUN
5750 C with assigned channel number I, low and up limits. Then to
5751 C generate the distribution one can call HIRND(I) which gives
5752 C you a random number generated according to the given function.
5753 C
5754         SUBROUTINE HIFUN(I,XMIN,XMAX,FHB)
5755         COMMON/HIJHB/RR(10,201),XX(10,201)
5756 cc      SAVE /HIJHB/
5757         EXTERNAL FHB
5758         SAVE
5759         FNORM=GAUSS1(FHB,XMIN,XMAX,0.001)
5760         DO 100 J=1,201
5761                 XX(I,J)=XMIN+(XMAX-XMIN)*(J-1)/200.0
5762                 XDD=XX(I,J)
5763                 RR(I,J)=GAUSS1(FHB,XMIN,XDD,0.001)/FNORM
5764 100        CONTINUE
5765         RETURN
5766         END
5767 C
5768 C
5769 C
5770         FUNCTION HIRND(I)
5771         COMMON/HIJHB/RR(10,201),XX(10,201)
5772 cc      SAVE /HIJHB/
5773       COMMON/RNDF77/NSEED
5774 cc      SAVE /RNDF77/
5775         SAVE
5776         RX=RANART(NSEED)
5777         JL=0
5778         JU=202
5779 10        IF(JU-JL.GT.1) THEN
5780            JM=(JU+JL)/2
5781            IF((RR(I,201).GT.RR(I,1)).EQV.(RX.GT.RR(I,JM))) THEN
5782               JL=JM
5783            ELSE
5784               JU=JM
5785            ENDIF
5786         GO TO 10
5787         ENDIF
5788         J=JL
5789         IF(J.LT.1) J=1
5790         IF(J.GE.201) J=200
5791         HIRND=(XX(I,J)+XX(I,J+1))/2.0
5792         RETURN
5793         END
5794 C
5795 C
5796 C
5797 C
5798 C        This generate random number between XMIN and XMAX
5799         FUNCTION HIRND2(I,XMIN,XMAX)
5800         COMMON/HIJHB/RR(10,201),XX(10,201)
5801 cc      SAVE /HIJHB/
5802       COMMON/RNDF77/NSEED
5803 cc      SAVE /RNDF77/
5804         SAVE
5805         IF(XMIN.LT.XX(I,1)) XMIN=XX(I,1)
5806         IF(XMAX.GT.XX(I,201)) XMAX=XX(I,201)
5807         JMIN=1+int(200*(XMIN-XX(I,1))/(XX(I,201)-XX(I,1)))
5808         JMAX=1+int(200*(XMAX-XX(I,1))/(XX(I,201)-XX(I,1)))
5809         RX=RR(I,JMIN)+(RR(I,JMAX)-RR(I,JMIN))*RANART(NSEED)
5810         JL=0
5811         JU=202
5812 10        IF(JU-JL.GT.1) THEN
5813            JM=(JU+JL)/2
5814            IF((RR(I,201).GT.RR(I,1)).EQV.(RX.GT.RR(I,JM))) THEN
5815               JL=JM
5816            ELSE
5817               JU=JM
5818            ENDIF
5819         GO TO 10
5820         ENDIF
5821         J=JL
5822         IF(J.LT.1) J=1
5823         IF(J.GE.201) J=200
5824         HIRND2=(XX(I,J)+XX(I,J+1))/2.0
5825         RETURN
5826         END
5827 C
5828 C
5829 C
5830 C
5831         SUBROUTINE HIJCRS
5832 C        THIS IS TO CALCULATE THE CROSS SECTIONS OF JET PRODUCTION AND
5833 C        THE TOTAL INELASTIC CROSS SECTIONS.
5834         COMMON/HPARNT/HIPR1(100),IHPR2(50),HINT1(100),IHNT2(50)
5835 cc      SAVE /HPARNT/
5836         COMMON/NJET/N,ipcrs
5837 cc      SAVE /NJET/
5838         EXTERNAL FHIN,FTOT,FNJET,FTOTJT,FTOTRG
5839         SAVE
5840         IF(HINT1(1).GE.10.0) CALL CRSJET
5841 C                        ********calculate jet cross section(in mb)
5842 C
5843 clin-7/2009 these are related to nuclear shadowing:
5844         APHX1=HIPR1(6)*(IHNT2(1)**0.3333333-1.0)
5845         APHX2=HIPR1(6)*(IHNT2(3)**0.3333333-1.0)
5846         HINT1(11)=HINT1(14)-APHX1*HINT1(15)
5847      &                        -APHX2*HINT1(16)+APHX1*APHX2*HINT1(17)
5848         HINT1(10)=GAUSS1(FTOTJT,0.0,20.0,0.01)
5849         HINT1(12)=GAUSS1(FHIN,0.0,20.0,0.01)
5850         HINT1(13)=GAUSS1(FTOT,0.0,20.0,0.01)
5851         HINT1(60)=HINT1(61)-APHX1*HINT1(62)
5852      &                        -APHX2*HINT1(63)+APHX1*APHX2*HINT1(64)
5853         HINT1(59)=GAUSS1(FTOTRG,0.0,20.0,0.01)
5854         IF(HINT1(59).EQ.0.0) HINT1(59)=HINT1(60)
5855         IF(HINT1(1).GE.10.0) Then
5856            DO 20 I=0,20
5857               N=I
5858               HINT1(80+I)=GAUSS1(FNJET,0.0,20.0,0.01)/HINT1(12)
5859  20           CONTINUE
5860         ENDIF
5861         HINT1(10)=HINT1(10)*HIPR1(31)
5862         HINT1(12)=HINT1(12)*HIPR1(31)
5863         HINT1(13)=HINT1(13)*HIPR1(31)
5864         HINT1(59)=HINT1(59)*HIPR1(31)
5865 C                ********Total and Inel cross section are calculated
5866 C                        by Gaussian integration.
5867         IF(IHPR2(13).NE.0) THEN
5868         HIPR1(33)=1.36*(1.0+36.0/HINT1(1)**2)
5869      &             *ALOG(0.6+0.1*HINT1(1)**2)
5870         HIPR1(33)=HIPR1(33)/HINT1(12)
5871         ENDIF
5872 C                ********Parametrized cross section for single
5873 C                        diffractive reaction(Goulianos)
5874         RETURN
5875         END
5876 C
5877 C
5878 C
5879 C
5880         FUNCTION FTOT(X)
5881         COMMON/HPARNT/HIPR1(100),IHPR2(50),HINT1(100),IHNT2(50)
5882 cc      SAVE /HPARNT/
5883         SAVE
5884         OMG=OMG0(X)*(HIPR1(30)+HINT1(11))/HIPR1(31)/2.0
5885         FTOT=2.0*(1.0-EXP(-OMG))
5886         RETURN
5887         END
5888 C
5889 C
5890 C
5891         FUNCTION FHIN(X)
5892         COMMON/HPARNT/HIPR1(100),IHPR2(50),HINT1(100),IHNT2(50)
5893 cc      SAVE /HPARNT/
5894         SAVE
5895         OMG=OMG0(X)*(HIPR1(30)+HINT1(11))/HIPR1(31)/2.0
5896         FHIN=1.0-EXP(-2.0*OMG)
5897         RETURN
5898         END
5899 C
5900 C
5901 C
5902         FUNCTION FTOTJT(X)
5903         COMMON/HPARNT/HIPR1(100),IHPR2(50),HINT1(100),IHNT2(50)
5904 cc      SAVE /HPARNT/
5905         SAVE
5906         OMG=OMG0(X)*HINT1(11)/HIPR1(31)/2.0
5907         FTOTJT=1.0-EXP(-2.0*OMG)
5908         RETURN
5909         END
5910 C
5911 C
5912 C
5913         FUNCTION FTOTRG(X)
5914         COMMON/HPARNT/HIPR1(100),IHPR2(50),HINT1(100),IHNT2(50)
5915 cc      SAVE /HPARNT/
5916         SAVE
5917         OMG=OMG0(X)*HINT1(60)/HIPR1(31)/2.0
5918         FTOTRG=1.0-EXP(-2.0*OMG)
5919         RETURN
5920         END
5921 C
5922 C
5923 C
5924 C
5925         FUNCTION FNJET(X)
5926         COMMON/HPARNT/HIPR1(100),IHPR2(50),HINT1(100),IHNT2(50)
5927 cc      SAVE /HPARNT/
5928         COMMON/NJET/N,ipcrs
5929 cc      SAVE /NJET/
5930         SAVE
5931         OMG1=OMG0(X)*HINT1(11)/HIPR1(31)
5932         C0=EXP(N*ALOG(OMG1)-SGMIN(N+1))
5933         IF(N.EQ.0) C0=1.0-EXP(-2.0*OMG0(X)*HIPR1(30)/HIPR1(31)/2.0)
5934         FNJET=C0*EXP(-OMG1)
5935         RETURN
5936         END
5937 C
5938 C
5939 C
5940 C
5941 C
5942         FUNCTION SGMIN(N)
5943         SAVE
5944         GA=0.
5945         IF(N.LE.2) GO TO 20
5946         DO 10 I=1,N-1
5947         Z=I
5948         GA=GA+ALOG(Z)
5949 10      CONTINUE
5950 20      SGMIN=GA
5951         RETURN
5952         END
5953 C
5954 C
5955 C
5956         FUNCTION OMG0(X)
5957         COMMON/HPARNT/HIPR1(100),IHPR2(50),HINT1(100),IHNT2(50)
5958 cc      SAVE /HPARNT/
5959         COMMON /BESEL/X4
5960 cc      SAVE /BESEL/
5961         EXTERNAL BK
5962         SAVE
5963         X4=HIPR1(32)*SQRT(X)
5964         OMG0=HIPR1(32)**2*GAUSS2(BK,X4,X4+20.0,0.01)/96.0
5965         RETURN
5966         END
5967 C
5968 C
5969 C
5970         FUNCTION ROMG(X)
5971 C                ********This gives the eikonal function from a table
5972 C                        calculated in the first call
5973         DIMENSION FR(0:1000)
5974 clin-10/29/02 unsaved FR causes wrong values for ROMG with f77 compiler:
5975 cc        SAVE FR
5976         SAVE
5977         DATA I0/0/
5978
5979         IF(I0.NE.0) GO TO 100
5980         DO 50 I=1,1001
5981         XR=(I-1)*0.01
5982         FR(I-1)=OMG0(XR)
5983 50        CONTINUE
5984 100        I0=1
5985         IF(X.GE.10.0) THEN
5986                 ROMG=0.0
5987                 RETURN
5988         ENDIF
5989         IX=INT(X*100)
5990         ROMG=(FR(IX)*((IX+1)*0.01-X)+FR(IX+1)*(X-IX*0.01))/0.01
5991         RETURN
5992         END
5993 C
5994 C
5995 C
5996         FUNCTION BK(X)
5997         COMMON /BESEL/X4
5998 cc      SAVE /BESEL/
5999         SAVE
6000         BK=EXP(-X)*(X**2-X4**2)**2.50/15.0
6001         RETURN
6002         END
6003 C
6004 C
6005 C        THIS PROGRAM IS TO CALCULATE THE JET CROSS SECTION
6006 C        THE INTEGRATION IS DONE BY USING VEGAS
6007 C
6008         SUBROUTINE CRSJET
6009         IMPLICIT DOUBLE PRECISION (A-H,O-Z)
6010         REAL HIPR1(100),HINT1(100)
6011         COMMON/HPARNT/HIPR1,IHPR2(50),HINT1,IHNT2(50)
6012 cc      SAVE /HPARNT/
6013         COMMON/NJET/N,ipcrs
6014 cc      SAVE /NJET/
6015         COMMON/BVEG1/XL(10),XU(10),ACC,NDIM,NCALL,ITMX,NPRN
6016 cc      SAVE /BVEG1/
6017         COMMON/BVEG2/XI(50,10),SI,SI2,SWGT,SCHI,NDO,IT
6018 cc      SAVE /BVEG2/
6019         COMMON/BVEG3/F,TI,TSI
6020 cc      SAVE /BVEG3/
6021         COMMON/SEDVAX/NUM1
6022 cc      SAVE /SEDVAX/
6023         EXTERNAL FJET,FJETRG
6024         SAVE
6025 C
6026 c************************
6027 c        NCALL give the number of inner-iteration, ITMX
6028 C       gives the limit of out-iteration. Nprn is an option
6029 C       ( 1: print the integration process. 0: do not print)
6030 C
6031         NDIM=3
6032         ipcrs=0
6033         CALL VEGAS(FJET,AVGI,SD,CHI2A)
6034         HINT1(14)=sngl(AVGI)/2.5682
6035         IF(IHPR2(6).EQ.1 .AND. IHNT2(1).GT.1) THEN
6036                 ipcrs=1
6037                 CALL VEGAS(FJET,AVGI,SD,CHI2A)
6038                 HINT1(15)=sngl(AVGI)/2.5682
6039         ENDIF
6040         IF(IHPR2(6).EQ.1 .AND. IHNT2(3).GT.1) THEN
6041                 ipcrs=2
6042                 CALL VEGAS(FJET,AVGI,SD,CHI2A)
6043                 HINT1(16)=sngl(AVGI)/2.5682
6044         ENDIF
6045         IF(IHPR2(6).EQ.1.AND.IHNT2(1).GT.1.AND.IHNT2(3).GT.1) THEN
6046                 ipcrs=3
6047                 CALL VEGAS(FJET,AVGI,SD,CHI2A)
6048                 HINT1(17)=sngl(AVGI)/2.5682
6049         ENDIF
6050 C                ********Total inclusive jet cross section(Pt>P0)
6051 C
6052         IF(IHPR2(3).NE.0) THEN
6053            ipcrs=0
6054            CALL VEGAS(FJETRG,AVGI,SD,CHI2A)
6055            HINT1(61)=sngl(AVGI)/2.5682
6056            IF(IHPR2(6).EQ.1 .AND. IHNT2(1).GT.1) THEN
6057               ipcrs=1
6058               CALL VEGAS(FJETRG,AVGI,SD,CHI2A)
6059               HINT1(62)=sngl(AVGI)/2.5682
6060            ENDIF
6061            IF(IHPR2(6).EQ.1 .AND. IHNT2(3).GT.1) THEN
6062               ipcrs=2
6063               CALL VEGAS(FJETRG,AVGI,SD,CHI2A)
6064               HINT1(63)=sngl(AVGI)/2.5682
6065            ENDIF
6066            IF(IHPR2(6).EQ.1.AND.IHNT2(1).GT.1.AND.IHNT2(3).GT.1) THEN
6067               ipcrs=3
6068               CALL VEGAS(FJETRG,AVGI,SD,CHI2A)
6069               HINT1(64)=sngl(AVGI)/2.5682
6070            ENDIF
6071         ENDIF
6072 C                        ********cross section of trigger jet
6073 C
6074         RETURN
6075         END
6076 C
6077 C
6078 C
6079         FUNCTION FJET(X,WGT)
6080         IMPLICIT DOUBLE PRECISION (A-H,O-Z)
6081         REAL HIPR1(100),HINT1(100)
6082         COMMON/HPARNT/HIPR1,IHPR2(50),HINT1,IHNT2(50)
6083 cc      SAVE /HPARNT/
6084         DIMENSION X(10)
6085         SAVE
6086         PT2=dble(HINT1(1)**2/4.0-HIPR1(8)**2)*X(1)+dble(HIPR1(8))**2
6087         XT=2.0d0*DSQRT(PT2)/dble(HINT1(1))
6088         YMX1=DLOG(1.0d0/XT+DSQRT(1.0d0/XT**2-1.0d0))
6089         Y1=2.0d0*YMX1*X(2)-YMX1
6090         YMX2=DLOG(2.0d0/XT-DEXP(Y1))
6091         YMN2=DLOG(2.0d0/XT-DEXP(-Y1))
6092         Y2=(YMX2+YMN2)*X(3)-YMN2
6093         FJET=2.0d0*YMX1*(YMX2+YMN2)*dble(HINT1(1)**2/4.0-HIPR1(8)**2)
6094      &                *G(Y1,Y2,PT2)/2.0d0
6095         RETURN
6096         END
6097 C
6098 C
6099 C
6100         FUNCTION FJETRG(X,WGT)
6101         IMPLICIT DOUBLE PRECISION (A-H,O-Z)
6102         REAL HIPR1(100),HINT1(100),PTMAX,PTMIN
6103         COMMON/HPARNT/HIPR1,IHPR2(50),HINT1,IHNT2(50)
6104 cc      SAVE /HPARNT/
6105         DIMENSION X(10)
6106         SAVE
6107         PTMIN=ABS(HIPR1(10))-0.25
6108         PTMIN=MAX(PTMIN,HIPR1(8))
6109         AM2=0.D0
6110         IF(IHPR2(3).EQ.3) THEN
6111            AM2=dble(HIPR1(7)**2)
6112            PTMIN=MAX(0.0,HIPR1(10))
6113         ENDIF
6114         PTMAX=ABS(HIPR1(10))+0.25
6115         IF(HIPR1(10).LE.0.0) PTMAX=HINT1(1)/2.0-sngl(AM2)
6116         IF(PTMAX.LE.PTMIN) PTMAX=PTMIN+0.25
6117         PT2=dble(PTMAX**2-PTMIN**2)*X(1)+dble(PTMIN)**2
6118         AMT2=PT2+AM2
6119         XT=2.0d0*DSQRT(AMT2)/dble(HINT1(1))
6120         YMX1=DLOG(1.0d0/XT+DSQRT(1.0d0/XT**2-1.0d0))
6121         Y1=2.0d0*YMX1*X(2)-YMX1
6122         YMX2=DLOG(2.0d0/XT-DEXP(Y1))
6123         YMN2=DLOG(2.0d0/XT-DEXP(-Y1))
6124         Y2=(YMX2+YMN2)*X(3)-YMN2
6125         IF(IHPR2(3).EQ.3) THEN
6126            GTRIG=2.0d0*GHVQ(Y1,Y2,AMT2)
6127         ELSE IF(IHPR2(3).EQ.2) THEN
6128            GTRIG=2.0d0*GPHOTN(Y1,Y2,PT2)
6129         ELSE
6130            GTRIG=G(Y1,Y2,PT2)
6131         ENDIF
6132         FJETRG=2.0d0*YMX1*(YMX2+YMN2)*dble(PTMAX**2-PTMIN**2)
6133      &                *GTRIG/2.0d0
6134         RETURN
6135         END
6136 C
6137 C
6138 C
6139         FUNCTION GHVQ(Y1,Y2,AMT2)
6140         IMPLICIT DOUBLE PRECISION  (A-H,O-Z)
6141         REAL HIPR1(100),HINT1(100)
6142         COMMON/HPARNT/HIPR1,IHPR2(50),HINT1,IHNT2(50)
6143 cc      SAVE /HPARNT/
6144         DIMENSION F(2,7)
6145         SAVE
6146         XT=2.0d0*DSQRT(AMT2)/dble(HINT1(1))
6147         X1=0.5d0*XT*(DEXP(Y1)+DEXP(Y2))
6148         X2=0.5d0*XT*(DEXP(-Y1)+DEXP(-Y2))
6149         SS=X1*X2*dble(HINT1(1))**2
6150         AF=4.0d0
6151         IF(IHPR2(18).NE.0) AF=5.0d0
6152         DLAM=dble(HIPR1(15))
6153         APH=12.0d0*3.1415926d0/(33.d0-2.d0*AF)/DLOG(AMT2/DLAM**2)
6154 C
6155         CALL PARTON(F,X1,X2,AMT2)
6156 C
6157         Gqq=4.d0*(DCOSH(Y1-Y2)+dble(HIPR1(7))**2/AMT2)
6158      &       /(1.D0+DCOSH(Y1-Y2))
6159      &       /9.d0*(F(1,1)*F(2,2)+F(1,2)*F(2,1)+F(1,3)*F(2,4)
6160      &       +F(1,4)*F(2,3)+F(1,5)*F(2,6)+F(1,6)*F(2,5))
6161         Ggg=(8.D0*DCOSH(Y1-Y2)-1.D0)
6162      &       *(DCOSH(Y1-Y2)+2.d0*dble(HIPR1(7))**2
6163      &       /AMT2-2.d0*dble(HIPR1(7))**4/AMT2**2)/(1.d0+DCOSH(Y1-Y2))
6164      &       /24.d0*F(1,7)*F(2,7)
6165 C
6166         GHVQ=(Gqq+Ggg)*dble(HIPR1(23))*3.14159d0*APH**2/SS**2
6167         RETURN
6168         END
6169 C
6170 C
6171 C
6172         FUNCTION GPHOTN(Y1,Y2,PT2)
6173         IMPLICIT DOUBLE PRECISION  (A-H,O-Z)
6174         REAL HIPR1(100),HINT1(100)
6175         COMMON/HPARNT/HIPR1,IHPR2(50),HINT1,IHNT2(50)
6176 cc      SAVE /HPARNT/
6177         DIMENSION F(2,7)
6178         SAVE
6179         XT=2.d0*DSQRT(PT2)/dble(HINT1(1))
6180         X1=0.5d0*XT*(DEXP(Y1)+DEXP(Y2))
6181         X2=0.5d0*XT*(DEXP(-Y1)+DEXP(-Y2))
6182         Z=DSQRT(1.D0-XT**2/X1/X2)
6183         SS=X1*X2*dble(HINT1(1))**2
6184         T=-(1.d0-Z)/2.d0
6185         U=-(1.d0+Z)/2.d0
6186         AF=3.d0
6187         DLAM=dble(HIPR1(15))
6188         APH=12.d0*3.1415926d0/(33.d0-2.d0*AF)/DLOG(PT2/DLAM**2)
6189         APHEM=1.d0/137.d0
6190 C
6191         CALL PARTON(F,X1,X2,PT2)
6192 C
6193         G11=-(U**2+1.d0)/U/3.d0*F(1,7)*(4.d0*F(2,1)+4.d0*F(2,2)
6194      &      +F(2,3)+F(2,4)+F(2,5)+F(2,6))/9.d0
6195         G12=-(T**2+1.d0)/T/3.d0*F(2,7)*(4.d0*F(1,1)+4.d0*F(1,2)
6196      &      +F(1,3)+F(1,4)+F(1,5)+F(1,6))/9.d0
6197         G2=8.d0*(U**2+T**2)/U/T/9.d0*(4.d0*F(1,1)*F(2,2)
6198      &     +4.d0*F(1,2)*F(2,1)+F(1,3)*F(2,4)+F(1,4)*F(2,3)
6199      &     +F(1,5)*F(2,6)+F(1,6)*F(2,5))/9.d0
6200 C
6201         GPHOTN=(G11+G12+G2)*dble(HIPR1(23))*3.14159d0*APH*APHEM/SS**2
6202         RETURN
6203         END
6204 C
6205 C
6206 C
6207 C
6208         FUNCTION G(Y1,Y2,PT2)
6209         IMPLICIT DOUBLE PRECISION  (A-H,O-Z)
6210         REAL HIPR1(100),HINT1(100)
6211         COMMON/HPARNT/HIPR1,IHPR2(50),HINT1,IHNT2(50)
6212 cc      SAVE /HPARNT/
6213         DIMENSION F(2,7)
6214         SAVE
6215         XT=2.d0*DSQRT(PT2)/dble(HINT1(1))
6216         X1=0.5d0*XT*(DEXP(Y1)+DEXP(Y2))
6217         X2=0.5d0*XT*(DEXP(-Y1)+DEXP(-Y2))
6218         Z=DSQRT(1.D0-XT**2/X1/X2)
6219         SS=X1*X2*dble(HINT1(1))**2
6220         T=-(1.d0-Z)/2.d0
6221         U=-(1.d0+Z)/2.d0
6222         AF=3.d0
6223         DLAM=dble(HIPR1(15))
6224         APH=12.d0*3.1415926d0/(33.d0-2.d0*AF)/DLOG(PT2/DLAM**2)
6225 C
6226         CALL PARTON(F,X1,X2,PT2)
6227 C
6228         G11=( (F(1,1)+F(1,2))*(F(2,3)+F(2,4)+F(2,5)+F(2,6))
6229      &      +(F(1,3)+F(1,4))*(F(2,5)+F(2,6)) )*SUBCR1(T,U)
6230 C
6231         G12=( (F(2,1)+F(2,2))*(F(1,3)+F(1,4)+F(1,5)+F(1,6))
6232      &      +(F(2,3)+F(2,4))*(F(1,5)+F(1,6)) )*SUBCR1(U,T)
6233 C
6234         G13=(F(1,1)*F(2,1)+F(1,2)*F(2,2)+F(1,3)*F(2,3)+F(1,4)*F(2,4)
6235      &      +F(1,5)*F(2,5)+F(1,6)*F(2,6))*(SUBCR1(U,T)
6236      &      +SUBCR1(T,U)-8.D0/T/U/27.D0)
6237 C
6238         G2=(AF-1)*(F(1,1)*F(2,2)+F(2,1)*F(1,2)+F(1,3)*F(2,4)
6239      &     +F(2,3)*F(1,4)+F(1,5)*F(2,6)+F(2,5)*F(1,6))*SUBCR2(T,U)
6240 C
6241         G31=(F(1,1)*F(2,2)+F(1,3)*F(2,4)+F(1,5)*F(2,6))*SUBCR3(T,U)
6242         G32=(F(2,1)*F(1,2)+F(2,3)*F(1,4)+F(2,5)*F(1,6))*SUBCR3(U,T)
6243 C
6244         G4=(F(1,1)*F(2,2)+F(2,1)*F(1,2)+F(1,3)*F(2,4)+F(2,3)*F(1,4)+
6245      1        F(1,5)*F(2,6)+F(2,5)*F(1,6))*SUBCR4(T,U)
6246 C
6247         G5=AF*F(1,7)*F(2,7)*SUBCR5(T,U)
6248 C
6249         G61=F(1,7)*(F(2,1)+F(2,2)+F(2,3)+F(2,4)+F(2,5)
6250      &      +F(2,6))*SUBCR6(T,U)
6251         G62=F(2,7)*(F(1,1)+F(1,2)+F(1,3)+F(1,4)+F(1,5)
6252      &      +F(1,6))*SUBCR6(U,T)
6253 C
6254         G7=F(1,7)*F(2,7)*SUBCR7(T,U)
6255 C
6256         G=(G11+G12+G13+G2+G31+G32+G4+G5+G61+G62+G7)*dble(HIPR1(17))*
6257      1        3.14159D0*APH**2/SS**2
6258         RETURN
6259         END
6260 C
6261 C
6262 C
6263         FUNCTION SUBCR1(T,U)
6264         IMPLICIT DOUBLE PRECISION (A-H,O-Z)
6265         SUBCR1=4.D0/9.D0*(1.D0+U**2)/T**2
6266         RETURN
6267         END
6268 C
6269 C
6270         FUNCTION SUBCR2(T,U)
6271         IMPLICIT DOUBLE PRECISION (A-H,O-Z)
6272         SUBCR2=4.D0/9.D0*(T**2+U**2)
6273         RETURN
6274         END
6275 C
6276 C
6277         FUNCTION SUBCR3(T,U)
6278         IMPLICIT DOUBLE PRECISION (A-H,O-Z)
6279         SUBCR3=4.D0/9.D0*(T**2+U**2+(1.D0+U**2)/T**2
6280      1        -2.D0*U**2/3.D0/T)
6281         RETURN
6282         END
6283 C
6284 C
6285         FUNCTION SUBCR4(T,U)
6286         IMPLICIT DOUBLE PRECISION (A-H,O-Z)
6287         SUBCR4=8.D0/3.D0*(T**2+U**2)*(4.D0/9.D0/T/U-1.D0)
6288         RETURN
6289         END
6290 C
6291 C
6292 C
6293         FUNCTION SUBCR5(T,U)
6294         IMPLICIT DOUBLE PRECISION (A-H,O-Z)
6295         SUBCR5=3.D0/8.D0*(T**2+U**2)*(4.D0/9.D0/T/U-1.D0)
6296         RETURN
6297         END
6298 C
6299 C
6300         FUNCTION SUBCR6(T,U)
6301         IMPLICIT DOUBLE PRECISION (A-H,O-Z)
6302         SUBCR6=(1.D0+U**2)*(1.D0/T**2-4.D0/U/9.D0)
6303         RETURN
6304         END
6305 C
6306 C
6307         FUNCTION SUBCR7(T,U)
6308         IMPLICIT DOUBLE PRECISION (A-H,O-Z)
6309         SUBCR7=9.D0/2.D0*(3.D0-T*U-U/T**2-T/U**2)
6310         RETURN
6311         END
6312 C
6313 C
6314 C
6315         SUBROUTINE PARTON(F,X1,X2,QQ)
6316         IMPLICIT DOUBLE PRECISION (A-H,O-Z)
6317         REAL HIPR1(100),HINT1(100)
6318         COMMON/HPARNT/HIPR1,IHPR2(50),HINT1,IHNT2(50)
6319 cc      SAVE /HPARNT/
6320         COMMON/NJET/N,ipcrs
6321 cc      SAVE /NJET/
6322 clin-7/2009:
6323         common/cmsflag/dshadow,ishadow
6324         DIMENSION F(2,7)
6325         SAVE
6326         DLAM=dble(HIPR1(15))
6327         Q0=dble(HIPR1(16))
6328         S=DLOG(DLOG(QQ/DLAM**2)/DLOG(Q0**2/DLAM**2))
6329         IF(IHPR2(7).EQ.2) GO TO 200
6330 C*******************************************************
6331         AT1=0.419d0+0.004d0*S-0.007d0*S**2
6332         AT2=3.460d0+0.724d0*S-0.066d0*S**2
6333         GMUD=4.40d0-4.86d0*S+1.33d0*S**2
6334         AT3=0.763d0-0.237d0*S+0.026d0*S**2
6335         AT4=4.00d0+0.627d0*S-0.019d0*S**2
6336         GMD=-0.421d0*S+0.033d0*S**2
6337 C*******************************************************
6338         CAS=1.265d0-1.132d0*S+0.293d0*S**2
6339         AS=-0.372d0*S-0.029d0*S**2
6340         BS=8.05d0+1.59d0*S-0.153d0*S**2
6341         APHS=6.31d0*S-0.273d0*S**2
6342         BTAS=-10.5d0*S-3.17d0*S**2
6343         GMS=14.7d0*S+9.80d0*S**2
6344 C********************************************************
6345 C        CAC=0.135*S-0.075*S**2
6346 C        AC=-0.036-0.222*S-0.058*S**2
6347 C        BC=6.35+3.26*S-0.909*S**2
6348 C        APHC=-3.03*S+1.50*S**2
6349 C        BTAC=17.4*S-11.3*S**2
6350 C        GMC=-17.9*S+15.6*S**2
6351 C***********************************************************
6352         CAG=1.56d0-1.71d0*S+0.638d0*S**2
6353         AG=-0.949d0*S+0.325d0*S**2
6354         BG=6.0d0+1.44d0*S-1.05d0*S**2
6355         APHG=9.0d0-7.19d0*S+0.255d0*S**2
6356         BTAG=-16.5d0*S+10.9d0*S**2
6357         GMG=15.3d0*S-10.1d0*S**2
6358         GO TO 300
6359 C********************************************************
6360 200        AT1=0.374d0+0.014d0*S
6361         AT2=3.33d0+0.753d0*S-0.076d0*S**2
6362         GMUD=6.03d0-6.22d0*S+1.56d0*S**2
6363         AT3=0.761d0-0.232d0*S+0.023d0*S**2
6364         AT4=3.83d0+0.627d0*S-0.019d0*S**2
6365         GMD=-0.418d0*S+0.036d0*S**2
6366 C************************************
6367         CAS=1.67d0-1.92d0*S+0.582d0*S**2
6368         AS=-0.273d0*S-0.164d0*S**2
6369         BS=9.15d0+0.530d0*S-0.763d0*S**2
6370         APHS=15.7d0*S-2.83d0*S**2
6371         BTAS=-101.0d0*S+44.7d0*S**2
6372         GMS=223.0d0*S-117.0d0*S**2
6373 C*********************************
6374 C        CAC=0.067*S-0.031*S**2
6375 C        AC=-0.120-0.233*S-0.023*S**2
6376 C        BC=3.51+3.66*S-0.453*S**2
6377 C        APHC=-0.474*S+0.358*S**2
6378 C        BTAC=9.50*S-5.43*S**2
6379 C        GMC=-16.6*S+15.5*S**2
6380 C**********************************
6381         CAG=0.879d0-0.971d0*S+0.434d0*S**2
6382         AG=-1.16d0*S+0.476d0*S**2
6383         BG=4.0d0+1.23d0*S-0.254d0*S**2
6384         APHG=9.0d0-5.64d0*S-0.817d0*S**2
6385         BTAG=-7.54d0*S+5.50d0*S**2
6386         GMG=-0.596d0*S+1.26d0*S**2
6387 C*********************************
6388 300        B12=DEXP(GMRE(AT1)+GMRE(AT2+1.D0)-GMRE(AT1+AT2+1.D0))
6389         B34=DEXP(GMRE(AT3)+GMRE(AT4+1.D0)-GMRE(AT3+AT4+1.D0))
6390         CNUD=3.D0/B12/(1.D0+GMUD*AT1/(AT1+AT2+1.D0))
6391         CND=1.D0/B34/(1.D0+GMD*AT3/(AT3+AT4+1.D0))
6392 C********************************************************
6393 C        FUD=X*(U+D)
6394 C        FS=X*2(UBAR+DBAR+SBAR)  AND UBAR=DBAR=SBAR
6395 C*******************************************************
6396         FUD1=CNUD*X1**AT1*(1.D0-X1)**AT2*(1.D0+GMUD*X1)
6397         FS1=CAS*X1**AS*(1.D0-X1)**BS*(1.D0+APHS*X1
6398      &      +BTAS*X1**2+GMS*X1**3)
6399         F(1,3)=CND*X1**AT3*(1.D0-X1)**AT4*(1.D0+GMD*X1)+FS1/6.D0
6400         F(1,1)=FUD1-F(1,3)+FS1/3.D0
6401         F(1,2)=FS1/6.D0
6402         F(1,4)=FS1/6.D0
6403         F(1,5)=FS1/6.D0
6404         F(1,6)=FS1/6.D0
6405         F(1,7)=CAG*X1**AG*(1.D0-X1)**BG*(1.D0+APHG*X1
6406      &         +BTAG*X1**2+GMG*X1**3)
6407 C
6408         FUD2=CNUD*X2**AT1*(1.D0-X2)**AT2*(1.D0+GMUD*X2)
6409         FS2=CAS*X2**AS*(1.D0-X2)**BS*(1.D0+APHS*X2
6410      &      +BTAS*X2**2+GMS*X2**3)
6411         F(2,3)=CND*X2**AT3*(1.D0-X2)**AT4*(1.D0+GMD*X2)+FS2/6.D0
6412         F(2,1)=FUD2-F(2,3)+FS2/3.D0
6413         F(2,2)=FS2/6.D0
6414         F(2,4)=FS2/6.D0
6415         F(2,5)=FS2/6.D0
6416         F(2,6)=FS2/6.D0
6417         F(2,7)=CAG*X2**AG*(1.D0-X2)**BG*(1.D0+APHG*X2
6418      &         +BTAG*X2**2+GMG*X2**3)
6419 C***********Nuclear effect on the structure function****************
6420 C
6421         IF(IHPR2(6).EQ.1 .AND. IHNT2(1).GT.1) THEN
6422            AAX=1.193d0*dble(ALOG(FLOAT(IHNT2(1)))**0.16666666)
6423            RRX=AAX*(X1**3-1.2d0*X1**2+0.21d0*X1)+1.d0
6424      &               +dble(1.079*(FLOAT(IHNT2(1))**0.33333333-1.0))
6425      &          /dble(ALOG(float(IHNT2(1))+1.0))*DSQRT(X1)
6426      &          *DEXP(-X1**2/0.01d0)
6427 c     &          /DLOG(IHNT2(1)+1.0D0)*(DSQRT(X1)*DEXP(-X1**2/0.01)
6428 clin-7/2009 enable users to modify nuclear shadowing:
6429            if(ishadow.eq.1) RRX=1.d0+dshadow*(RRX-1.d0)
6430            IF(ipcrs.EQ.1 .OR.ipcrs.EQ.3) RRX=DEXP(-X1**2/0.01d0)
6431 clin-7/2009:
6432            if((ipcrs.EQ.1.OR.ipcrs.EQ.3).and.ishadow.eq.1)
6433      1          RRX=DEXP(-X1**2/0.01d0)*dshadow
6434            DO 400 I=1,7
6435               F(1,I)=RRX*F(1,I)
6436  400           CONTINUE
6437         ENDIF
6438         IF(IHPR2(6).EQ.1 .AND. IHNT2(3).GT.1) THEN
6439            AAX=1.193d0*dble(ALOG(FLOAT(IHNT2(3)))**0.16666666)
6440            RRX=AAX*(X2**3-1.2d0*X2**2+0.21d0*X2)+1.d0
6441      &               +dble(1.079*(FLOAT(IHNT2(3))**0.33333-1.0))
6442      &          /dble(ALOG(float(IHNT2(3))+1.0))*DSQRT(X2)
6443      &          *DEXP(-X2**2/0.01d0)
6444 c     &         /DLOG(IHNT2(3)+1.0D0)*DSQRT(X2)*DEXP(-X2**2/0.01)
6445 clin-7/2009:
6446            if(ishadow.eq.1) RRX=1.d0+dshadow*(RRX-1.d0)
6447            IF(ipcrs.EQ.2 .OR. ipcrs.EQ.3) RRX=DEXP(-X2**2/0.01d0)
6448 clin-7/2009:
6449            if((ipcrs.EQ.2.OR.ipcrs.EQ.3).and.ishadow.eq.1)
6450      1          RRX=DEXP(-X2**2/0.01d0)*dshadow
6451            DO 500 I=1,7
6452               F(2,I)=RRX*F(2,I)
6453  500           CONTINUE
6454         ENDIF
6455 c
6456         RETURN
6457         END
6458 C
6459 C
6460 C
6461         FUNCTION GMRE(X)
6462         IMPLICIT DOUBLE PRECISION (A-H,O-Z)
6463         SAVE
6464         Z=X
6465         IF(X.GT.3.0D0) GO TO 10
6466         Z=X+3.D0
6467 10      GMRE=0.5D0*DLOG(2.D0*3.14159265D0/Z)+Z*DLOG(Z)-Z+DLOG(1.D0
6468      1        +1.D0/12.D0/Z+1.D0/288.D0/Z**2-139.D0/51840.D0/Z**3
6469      1        -571.D0/2488320.D0/Z**4)
6470         IF(Z.EQ.X) GO TO 20
6471         GMRE=GMRE-DLOG(Z-1.D0)-DLOG(Z-2.D0)-DLOG(Z-3.D0)
6472 20      CONTINUE
6473         RETURN
6474         END
6475 c
6476 C
6477 C
6478 C***************************************************************
6479
6480         BLOCK DATA HIDATA
6481         PARAMETER (MAXSTR=150001)
6482         DOUBLE PRECISION  XL(10),XU(10),ACC
6483         COMMON/BVEG1/XL,XU,ACC,NDIM,NCALL,ITMX,NPRN
6484 cc      SAVE /BVEG1/
6485         COMMON/SEDVAX/NUM1
6486 cc      SAVE /SEDVAX/
6487         COMMON/HPARNT/HIPR1(100),IHPR2(50),HINT1(100),IHNT2(50)
6488 cc      SAVE /HPARNT/
6489         COMMON/HMAIN1/EATT,JATT,NATT,NT,NP,N0,N01,N10,N11
6490 cc      SAVE /HMAIN1/
6491         COMMON/HMAIN2/KATT(MAXSTR,4),PATT(MAXSTR,4)
6492 cc      SAVE /HMAIN2/
6493         COMMON/HSTRNG/NFP(300,15),PP(300,15),NFT(300,15),PT(300,15)
6494 cc      SAVE /HSTRNG/
6495         COMMON/hjcrdn/YP(3,300),YT(3,300)
6496 cc      SAVE /hjcrdn/
6497         COMMON/HJJET1/NPJ(300),KFPJ(300,500),PJPX(300,500),
6498      &               PJPY(300,500),PJPZ(300,500),PJPE(300,500),
6499      &               PJPM(300,500),NTJ(300),KFTJ(300,500),
6500      &               PJTX(300,500),PJTY(300,500),PJTZ(300,500),
6501      &               PJTE(300,500),PJTM(300,500)
6502 cc      SAVE /HJJET1/
6503         COMMON/HJJET2/NSG,NJSG(MAXSTR),IASG(MAXSTR,3),K1SG(MAXSTR,100),
6504      &       K2SG(MAXSTR,100),PXSG(MAXSTR,100),PYSG(MAXSTR,100),
6505      &       PZSG(MAXSTR,100),PESG(MAXSTR,100),PMSG(MAXSTR,100)
6506 cc      SAVE /HJJET2/
6507         COMMON/HIJDAT/HIDAT0(10,10),HIDAT(10)
6508 cc      SAVE /HIJDAT/
6509         COMMON/HPINT/MINT4,MINT5,ATCO(200,20),ATXS(0:200)
6510 cc      SAVE /HPINT/
6511         SAVE
6512         DATA NUM1/30123984/,XL/10*0.D0/,XU/10*1.D0/
6513         DATA NCALL/1000/,ITMX/100/,ACC/0.01/,NPRN/0/
6514 C...give all the switchs and parameters the default values
6515 clin-4/2008 input.ampt provides NSEED for AMPT:
6516 c        DATA NSEED/74769375/
6517         DATA HIPR1/
6518      &       1.5,  0.35, 0.5,  0.9,  2.0,  0.1,  1.5,  2.0, -1.0, -2.25,
6519      &       2.0,  0.5,  1.0,  2.0,  0.2,  2.0,  2.5,  0.3,  0.1,  1.4,
6520      &       1.6,  1.0,  2.0,  0.0,  0.0,  0.0,  0.0,  0.0,  0.4,  57.0,
6521      &       28.5, 3.9,  0.0,  0.0,  0.0,  0.0,  0.0,  0.0,  0.0,
6522      &       3.14159,
6523      &       0.0,  0.4,  0.1,  1.5,  0.1, 0.25, 0.0,  0.5,  0.0,  0.0,
6524      &       50*0.0/
6525
6526         DATA IHPR2/
6527      &       1,    3,    0,    1,    1,    1,    1,    10,    0,    0,
6528      &       1,    1,    1,    1,    0,    0,    1,     0,    0,    1,
6529      &        30*0/
6530
6531         DATA HINT1/100*0/
6532         DATA IHNT2/50*0/
6533
6534 C...initialize all the data common blocks
6535         DATA NATT/0/,EATT/0.0/,JATT/0/,NT/0/,NP/0/,
6536      1 N0/0/,N01/0/,N10/0/,N11/0/
6537 clin-4/26/01
6538 c        DATA KATT/520000*0/PATT/520000*0.0/
6539         DATA KATT/600004*0/,PATT/600004*0.0/
6540
6541         DATA NFP/4500*0/,PP/4500*0.0/,NFT/4500*0/,PT/4500*0.0/
6542
6543         DATA YP/900*0.0/,YT/900*0.0/
6544
6545         DATA NPJ/300*0/,KFPJ/150000*0/,PJPX/150000*0.0/,PJPY/150000*0.0/
6546      &        ,PJPZ/150000*0.0/,PJPE/150000*0.0/,PJPM/150000*0.0/
6547         DATA NTJ/300*0/,KFTJ/150000*0/,PJTX/150000*0.0/,PJTY/150000*0.0/
6548      &        ,PJTZ/150000*0.0/,PJTE/150000*0.0/,PJTM/150000*0.0/
6549
6550 clin-4/2008
6551 c        DATA NSG/0/,NJSG/900*0/,IASG/2700*0/,K1SG/90000*0/,K2SG/90000*0/
6552 c     &       ,PXSG/90000*0.0/,PYSG/90000*0.0/,PZSG/90000*0.0/
6553 c     &       ,PESG/90000*0.0/,PMSG/90000*0.0/
6554         DATA NSG/0/,NJSG/150001*0/,IASG/450003*0/,
6555      &       K1SG/15000100*0/,K2SG/15000100*0/,
6556      &       PXSG/15000100*0.0/,PYSG/15000100*0.0/,PZSG/15000100*0.0/,
6557      &       PESG/15000100*0.0/,PMSG/15000100*0.0/
6558         DATA MINT4/0/,MINT5/0/,ATCO/4000*0.0/,ATXS/201*0.0/
6559         DATA (HIDAT0(1,I),I=1,10)/0.0,0.0,0.0,0.0,0.0,0.0,2.25,
6560      &          2.5,4.0,4.1/
6561         DATA (HIDAT0(2,I),I=1,10)/2.0,3.0,5.0,6.0,7.0,8.0,8.0,10.0,
6562      &                10.0,10.0/
6563         DATA (HIDAT0(3,I),I=1,10)/1.0,0.8,0.8,0.7,0.45,0.215,
6564      &          0.21,0.19,0.19,0.19/
6565         DATA (HIDAT0(4,I),I=1,10)/0.35,0.35,0.3,0.3,0.3,0.3,
6566      &          0.5,0.6,0.6,0.6/
6567         DATA (HIDAT0(5,I),I=1,10)/23.8,24.0,26.0,26.2,27.0,28.5,28.5,
6568      &                28.5,28.5,28.5/
6569         DATA ((HIDAT0(J,I),I=1,10),J=6,9)/40*0.0/
6570         DATA (HIDAT0(10,I),I=1,10)/5.0,20.0,53.0,62.0,100.0,200.0,
6571      &          546.0,900.0,1800.0,4000.0/
6572         DATA HIDAT/10*0.0/
6573         END
6574 C*******************************************************************
6575 C
6576 C
6577 C
6578 C
6579 C*******************************************************************
6580 C   SUBROUTINE PERFORMS N-DIMENSIONAL MONTE CARLO INTEG'N
6581 C      - BY G.P. LEPAGE   SEPT 1976/(REV)APR 1978
6582 C*******************************************************************
6583 C
6584       SUBROUTINE VEGAS(FXN,AVGI,SD,CHI2A)
6585       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
6586       COMMON/BVEG1/XL(10),XU(10),ACC,NDIM,NCALL,ITMX,NPRN
6587 cc      SAVE /BVEG1/
6588       COMMON/BVEG2/XI(50,10),SI,SI2,SWGT,SCHI,NDO,IT
6589 cc      SAVE /BVEG2/
6590       COMMON/BVEG3/F,TI,TSI
6591 cc      SAVE /BVEG3/
6592       EXTERNAL FXN
6593       DIMENSION D(50,10),DI(50,10),XIN(50),R(50),DX(10),DT(10),X(10)
6594      1   ,KG(10),IA(10)
6595 c      REAL*4 QRAN(10)
6596       REAL QRAN(10)
6597       SAVE
6598       DATA NDMX/50/,ALPH/1.5D0/,ONE/1.D0/,MDS/-1/
6599 C
6600       NDO=1
6601       DO 1 J=1,NDIM
6602 1     XI(1,J)=ONE
6603 C
6604       ENTRY VEGAS1(FXN,AVGI,SD,CHI2A)
6605 C         - INITIALIZES CUMMULATIVE VARIABLES, BUT NOT GRID
6606       IT=0
6607       SI=0.d0
6608       SI2=SI
6609       SWGT=SI
6610       SCHI=SI
6611 C
6612       ENTRY VEGAS2(FXN,AVGI,SD,CHI2A)
6613 C         - NO INITIALIZATION
6614       ND=NDMX
6615       NG=1
6616       IF(MDS.EQ.0) GO TO 2
6617       NG=int((real(NCALL)/2.)**(1./real(NDIM)))
6618       MDS=1
6619       IF((2*NG-NDMX).LT.0) GO TO 2
6620       MDS=-1
6621       NPG=NG/NDMX+1
6622       ND=NG/NPG
6623       NG=NPG*ND
6624 2     K=NG**NDIM
6625       NPG=NCALL/K
6626       IF(NPG.LT.2) NPG=2
6627       CALLS=NPG*K
6628       DXG=ONE/NG
6629       DV2G=(CALLS*DXG**NDIM)**2/NPG/NPG/(NPG-ONE)
6630       XND=ND
6631       NDM=ND-1
6632       DXG=DXG*XND
6633       XJAC=ONE/CALLS
6634       DO 3 J=1,NDIM
6635 c***this is the line 50
6636       DX(J)=XU(J)-XL(J)
6637 3     XJAC=XJAC*DX(J)
6638 C
6639 C   REBIN PRESERVING BIN DENSITY
6640 C
6641       IF(ND.EQ.NDO) GO TO 8
6642       RC=NDO/XND
6643       DO 7 J=1,NDIM
6644       K=0
6645       XN=0.d0
6646       DR=XN
6647       I=K
6648 4     K=K+1
6649       DR=DR+ONE
6650       XO=XN
6651       XN=XI(K,J)
6652 5     IF(RC.GT.DR) GO TO 4
6653       I=I+1
6654       DR=DR-RC
6655       XIN(I)=XN-(XN-XO)*DR
6656       IF(I.LT.NDM) GO TO 5
6657       DO 6 I=1,NDM
6658 6     XI(I,J)=XIN(I)
6659 7     XI(ND,J)=ONE
6660       NDO=ND
6661 C
6662 8     CONTINUE
6663 c      IF(NPRN.NE.0) WRITE(16,200) NDIM,CALLS,IT,ITMX,ACC,MDS,ND
6664 c     1                           ,(XL(J),XU(J),J=1,NDIM)
6665 C
6666       ENTRY VEGAS3(FXN,AVGI,SD,CHI2A)
6667 C         - MAIN INTEGRATION LOOP
6668 9     IT=IT+1
6669       TI=0.d0
6670       TSI=TI
6671       DO 10 J=1,NDIM
6672       KG(J)=1
6673       DO 10 I=1,ND
6674       D(I,J)=TI
6675 10    DI(I,J)=TI
6676 C
6677 11    FB=0.d0
6678       F2B=FB
6679       K=0
6680 12    K=K+1
6681       CALL ARAN9(QRAN,NDIM)
6682       WGT=XJAC
6683       DO 15 J=1,NDIM
6684       XN=dble(float(KG(J))-QRAN(J))*DXG+ONE
6685 c*****this is the line 100
6686       IA(J)=int(XN)
6687       IF(IA(J).GT.1) GO TO 13
6688       XO=XI(IA(J),J)
6689       RC=(XN-IA(J))*XO
6690       GO TO 14
6691 13    XO=XI(IA(J),J)-XI(IA(J)-1,J)
6692       RC=XI(IA(J)-1,J)+(XN-IA(J))*XO
6693 14    X(J)=XL(J)+RC*DX(J)
6694       WGT=WGT*XO*XND
6695 15    CONTINUE
6696 C
6697       F=WGT
6698       F=F*FXN(X,WGT)
6699       F2=F*F
6700       FB=FB+F
6701       F2B=F2B+F2
6702       DO 16 J=1,NDIM
6703       DI(IA(J),J)=DI(IA(J),J)+F
6704 16    IF(MDS.GE.0) D(IA(J),J)=D(IA(J),J)+F2
6705       IF(K.LT.NPG) GO TO 12
6706 C
6707       F2B=DSQRT(F2B*NPG)
6708       F2B=(F2B-FB)*(F2B+FB)
6709       TI=TI+FB
6710       TSI=TSI+F2B
6711       IF(MDS.GE.0) GO TO 18
6712       DO 17 J=1,NDIM
6713 17    D(IA(J),J)=D(IA(J),J)+F2B
6714 18    K=NDIM
6715 19    KG(K)=MOD(KG(K),NG)+1
6716       IF(KG(K).NE.1) GO TO 11
6717       K=K-1
6718       IF(K.GT.0) GO TO 19
6719 C
6720 C   FINAL RESULTS FOR THIS ITERATION
6721 C
6722       TSI=TSI*DV2G
6723       TI2=TI*TI
6724       WGT=TI2/(TSI+1.0d-37)
6725       SI=SI+TI*WGT
6726       SI2=SI2+TI2
6727       SWGT=SWGT+WGT
6728       SWGT=SWGT+1.0D-37
6729       SI2=SI2+1.0D-37
6730       SCHI=SCHI+TI2*WGT
6731       AVGI=SI/SWGT
6732       SD=SWGT*IT/SI2
6733       CHI2A=SD*(SCHI/SWGT-AVGI*AVGI)/dble(float(IT)-.999)
6734       SD=DSQRT(ONE/SD)
6735 C****this is the line 150
6736       IF(NPRN.EQ.0) GO TO 21
6737       TSI=DSQRT(TSI)
6738 c      WRITE(16,201) IT,TI,TSI,AVGI,SD,CHI2A
6739 c      IF(NPRN.GE.0) GO TO 21
6740 c      DO 20 J=1,NDIM
6741 c20    WRITE(16,202) J,(XI(I,J),DI(I,J),D(I,J),I=1,ND)
6742 C
6743 C   REFINE GRID
6744 C
6745 21    DO 23 J=1,NDIM
6746       XO=D(1,J)
6747       XN=D(2,J)
6748       D(1,J)=(XO+XN)/2.d0
6749       DT(J)=D(1,J)
6750       DO 22 I=2,NDM
6751       D(I,J)=XO+XN
6752       XO=XN
6753       XN=D(I+1,J)
6754       D(I,J)=(D(I,J)+XN)/3.d0
6755 22    DT(J)=DT(J)+D(I,J)
6756       D(ND,J)=(XN+XO)/2.d0
6757 23    DT(J)=DT(J)+D(ND,J)
6758 C
6759       DO 28 J=1,NDIM
6760       RC=0.d0
6761       DO 24 I=1,ND
6762       R(I)=0.d0
6763       IF (DT(J).GE.1.0D18) THEN
6764        WRITE(6,*) '************** A SINGULARITY >1.0D18'
6765 C      WRITE(5,1111)
6766 C1111  FORMAT(1X,'**************IMPORTANT NOTICE***************')
6767 C      WRITE(5,1112)
6768 C1112  FORMAT(1X,'THE INTEGRAND GIVES RISE A SINGULARITY >1.0D18')
6769 C      WRITE(5,1113)
6770 C1113  FORMAT(1X,'PLEASE CHECK THE INTEGRAND AND THE LIMITS')
6771 C      WRITE(5,1114)
6772 C1114  FORMAT(1X,'**************END NOTICE*************')
6773       END IF
6774       IF(D(I,J).LE.1.0D-18) GO TO 24
6775       XO=DT(J)/D(I,J)
6776       R(I)=((XO-ONE)/XO/DLOG(XO))**ALPH
6777 24    RC=RC+R(I)
6778       RC=RC/XND
6779       K=0
6780       XN=0.d0
6781       DR=XN
6782       I=K
6783 25    K=K+1
6784       DR=DR+R(K)
6785       XO=XN
6786 c****this is the line 200
6787       XN=XI(K,J)
6788 26    IF(RC.GT.DR) GO TO 25
6789       I=I+1
6790       DR=DR-RC
6791       XIN(I)=XN-(XN-XO)*DR/(R(K)+1.0d-30)
6792       IF(I.LT.NDM) GO TO 26
6793       DO 27 I=1,NDM
6794 27    XI(I,J)=XIN(I)
6795 28    XI(ND,J)=ONE
6796 C
6797       IF(IT.LT.ITMX.AND.ACC*DABS(AVGI).LT.SD) GO TO 9
6798 c200   FORMAT('0INPUT PARAMETERS FOR VEGAS:  NDIM=',I3,'  NCALL=',F8.0
6799 c     1    /28X,'  IT=',I5,'  ITMX=',I5/28X,'  ACC=',G9.3
6800 c     2    /28X,'  MDS=',I3,'   ND=',I4/28X,'  (XL,XU)=',
6801 c     3    (T40,'( ',G12.6,' , ',G12.6,' )'))
6802 c201   FORMAT(///' INTEGRATION BY VEGAS' / '0ITERATION NO.',I3,
6803 c     1    ':   INTEGRAL =',G14.8/21X,'STD DEV  =',G10.4 /
6804 c     2    ' ACCUMULATED RESULTS:   INTEGRAL =',G14.8 /
6805 c     3    24X,'STD DEV  =',G10.4 / 24X,'CHI**2 PER IT''N =',G10.4)
6806 c202   FORMAT('0DATA FOR AXIS',I2 / ' ',6X,'X',7X,'  DELT I  ',
6807 c     1    2X,' CONV''CE  ',11X,'X',7X,'  DELT I  ',2X,' CONV''CE  '
6808 c     2   ,11X,'X',7X,'  DELT I  ',2X,' CONV''CE  ' /
6809 c     2    (' ',3G12.4,5X,3G12.4,5X,3G12.4))
6810       RETURN
6811       END
6812 C
6813 C
6814       SUBROUTINE ARAN9(QRAN,NDIM)
6815       DIMENSION QRAN(10)
6816       COMMON/SEDVAX/NUM1
6817       SAVE
6818       DO 1 I=1,NDIM
6819     1 QRAN(I)=RANART(NUM1)
6820       RETURN
6821       END
6822
6823 C
6824 C
6825 C*********GAUSSIAN ONE-DIMENSIONAL INTEGRATION PROGRAM*************
6826 C
6827         FUNCTION GAUSS1(F,A,B,EPS)
6828         EXTERNAL F
6829         DIMENSION W(12),X(12)
6830         SAVE
6831         DATA CONST/1.0E-12/
6832         DATA W/0.1012285,.2223810,.3137067,.3623838,.0271525,
6833      &         .0622535,0.0951585,.1246290,.1495960,.1691565,
6834      &         .1826034,.1894506/
6835         DATA X/0.9602899,.7966665,.5255324,.1834346,.9894009,
6836      &         .9445750,0.8656312,.7554044,.6178762,.4580168,
6837      &         .2816036,.0950125/
6838
6839         DELTA=CONST*ABS(A-B)
6840         GAUSS1=0.0
6841         AA=A
6842 5        Y=B-AA
6843         IF(ABS(Y).LE.DELTA) RETURN
6844 2        BB=AA+Y
6845         C1=0.5*(AA+BB)
6846         C2=C1-AA
6847         S8=0.0
6848         S16=0.0
6849         DO 1 I=1,4
6850         U=X(I)*C2
6851 1        S8=S8+W(I)*(F(C1+U)+F(C1-U))
6852         DO 3 I=5,12
6853         U=X(I)*C2
6854 3        S16=S16+W(I)*(F(C1+U)+F(C1-U))
6855         S8=S8*C2
6856         S16=S16*C2
6857         IF(ABS(S16-S8).GT.EPS*(1.+ABS(S16))) GOTO 4
6858         GAUSS1=GAUSS1+S16
6859         AA=BB
6860         GOTO 5
6861 4        Y=0.5*Y
6862         IF(ABS(Y).GT.DELTA) GOTO 2
6863         WRITE(6,7)
6864         GAUSS1=0.0
6865         RETURN
6866 7        FORMAT(1X,'GAUSS1....TOO HIGH ACURACY REQUIRED')
6867         END
6868 C
6869 C
6870 C
6871         FUNCTION GAUSS2(F,A,B,EPS)
6872         EXTERNAL F
6873         DIMENSION W(12),X(12)
6874         SAVE
6875         DATA CONST/1.0E-12/
6876         DATA W/0.1012285,.2223810,.3137067,.3623838,.0271525,
6877      &         .0622535,0.0951585,.1246290,.1495960,.1691565,
6878      &         .1826034,.1894506/
6879         DATA X/0.9602899,.7966665,.5255324,.1834346,.9894009,
6880      &         .9445750,0.8656312,.7554044,.6178762,.4580168,
6881      &         .2816036,.0950125/
6882
6883         DELTA=CONST*ABS(A-B)
6884         GAUSS2=0.0
6885         AA=A
6886 5        Y=B-AA
6887         IF(ABS(Y).LE.DELTA) RETURN
6888 2        BB=AA+Y
6889         C1=0.5*(AA+BB)
6890         C2=C1-AA
6891         S8=0.0
6892         S16=0.0
6893         DO 1 I=1,4
6894         U=X(I)*C2
6895 1        S8=S8+W(I)*(F(C1+U)+F(C1-U))
6896         DO 3 I=5,12
6897         U=X(I)*C2
6898 3        S16=S16+W(I)*(F(C1+U)+F(C1-U))
6899         S8=S8*C2
6900         S16=S16*C2
6901         IF(ABS(S16-S8).GT.EPS*(1.+ABS(S16))) GOTO 4
6902         GAUSS2=GAUSS2+S16
6903         AA=BB
6904         GOTO 5
6905 4        Y=0.5*Y
6906         IF(ABS(Y).GT.DELTA) GOTO 2
6907         WRITE(6,7)
6908         GAUSS2=0.0
6909         RETURN
6910 7        FORMAT(1X,'GAUSS2....TOO HIGH ACURACY REQUIRED')
6911         END
6912 C
6913 C
6914 C
6915 C
6916 C
6917         SUBROUTINE TITLE
6918
6919       COMMON/RNDF77/NSEED
6920 cc      SAVE /RNDF77/
6921         SAVE
6922
6923         WRITE(6,200)
6924 clin-8/15/02 f77:
6925 c200        FORMAT(//10X,
6926 c     &        '**************************************************'/10X,
6927 c     &  '*     |      \       _______      /  ------/     *'/10X,
6928 c     &        '*   ----- ------     |_____|     /_/     /       *'/10X,
6929 c     &        '*    ||\    /        |_____|      /    / \       *'/10X,
6930 c     &        '*    /| \  /_/       /_______    /_  /    \_     *'/10X,
6931 c     &        '*   / |     / /     /  /  / |        -------     *'/10X,
6932 c     &        '*     |    / /\       /  /  |     /     |        *'/10X,
6933 c     &        '*     |   / /  \     /  / \_|    /   -------     *'/10X,
6934 200        FORMAT(//10X,
6935      &        '**************************************************'/10X,
6936      &  '*     |      |       _______      /  ------/     *'/10X,
6937      &        '*   ----- ------     |_____|     /_/     /       *'/10X,
6938      &        '*    |||    /        |_____|      /    / |       *'/10X,
6939      &        '*    /| |  /_/       /_______    /_  /    |      *'/10X,
6940      &        '*   / |     / /     /  /  / |        -------     *'/10X,
6941      &        '*     |    / /|       /  /  |     /     |        *'/10X,
6942      &        '*     |   / /  |     /  /  _|    /   -------     *'/10X,
6943      &        '*                                                *'/10X,
6944      &        '**************************************************'/10X,
6945      &        '                      HIJING                      '/10X,
6946      &        '       Heavy Ion Jet INteraction Generator        '/10X,
6947      &        '                        by                        '/10X,
6948      &  '            X. N. Wang  and  M. Gyulassy           '/10X,
6949      &  '             Lawrence Berkeley Laboratory           '//)
6950         RETURN
6951         END
6952