| 0119ef9a |
1 | c.................... hijing1.383_ampt.f |
| 2 | c Version 1.383 |
| 3 | c The variables isng in HIJSFT and JL in ATTRAD were not initialized. |
| 4 | c The version initialize them. (as found by Fernando Marroquim) |
| 5 | c |
| 6 | c |
| 7 | c |
| 8 | c Version 1.382 |
| 9 | c Nuclear distribution for deuteron is taken as the Hulthen wave |
| 10 | c function as provided by Brian Cole (Columbia) |
| 11 | clin used my own implementation of impact parameter |
| 12 | clin & proton-neutron distance within a deuteron. |
| 13 | c |
| 14 | c |
| 15 | c Version 1.381 |
| 16 | c |
| 17 | c The parameters for Wood-Saxon distribution for deuteron are |
| 18 | c constrained to give the right rms ratius 2.116 fm |
| 19 | c (R=0.0, D=0.5882) |
| 20 | c |
| 21 | c |
| 22 | c Version 1.38 |
| 23 | c |
| 24 | c The following common block is added to record the number of elastic |
| 25 | c (NELT, NELP) and inelastic (NINT, NINP) participants |
| 26 | c |
| 27 | c COMMON/HJGLBR/NELT,NINT,NELP,NINP |
| 28 | c SAVE /HJGLBR/ |
| 29 | c |
| 30 | c Version 1.37 |
| 31 | c |
| 32 | c A bug in the quenching subroutine is corrected. When calculating the |
| 33 | c distance between two wounded nucleons, the displacement of the |
| 34 | c impact parameter was not inculded. This bug was discovered by |
| 35 | c Dr. V.Uzhinskii JINR, Dubna, Russia |
| 36 | c |
| 37 | c |
| 38 | C Version 1.36 |
| 39 | c |
| 40 | c Modification Oct. 8, 1998. In hijing, log(ran(nseed)) occasionally |
| 41 | c causes overfloat. It is modified to log(max(ran(nseed),1.0e-20)). |
| 42 | c |
| 43 | c |
| 44 | C Nothing important has been changed here. A few 'garbage' has been |
| 45 | C cleaned up here, like common block HJJET3 for the sea quark strings |
| 46 | C which were originally created to implement the DPM scheme which |
| 47 | C later was abadoned in the final version. The lines which operate |
| 48 | C on these data are also deleted in the program. |
| 49 | C |
| 50 | C |
| 51 | C Version 1.35 |
| 52 | C There are some changes in the program: subroutine HARDJET is now |
| 53 | C consolidated with HIJHRD. HARDJET is used to re-initiate PYTHIA |
| 54 | C for the triggered hard processes. Now that is done altogether |
| 55 | C with other normal hard processes in modified JETINI. In the new |
| 56 | C version one calls JETINI every time one calls HIJHRD. In the new |
| 57 | C version the effect of the isospin of the nucleon on hard processes, |
| 58 | C especially direct photons is correctly considered. |
| 59 | C For A+A collisions, one has to initilize pythia |
| 60 | C separately for each type of collisions, pp, pn,np and nn, |
| 61 | C or hp and hn for hA collisions. In JETINI we use the following |
| 62 | C catalogue for different types of collisions: |
| 63 | C h+h: h+h (itype=1) |
| 64 | C h+A: h+p (itype=1), h+n (itype=2) |
| 65 | C A+h: p+h (itype=1), n+h (itype=2) |
| 66 | C A+A: p+p (itype=1), p+n (itype=2), n+p (itype=3), n+n (itype=4) |
| 67 | C***************************************************************** |
| 68 | c |
| 69 | C |
| 70 | C Version 1.34 |
| 71 | C Last modification on January 5, 1998. Two mistakes are corrected in |
| 72 | C function G. A Mistake in the subroutine Parton is also corrected. |
| 73 | C (These are pointed out by Ysushi Nara). |
| 74 | C |
| 75 | C |
| 76 | C Last modifcation on April 10, 1996. To conduct final |
| 77 | C state radiation, PYTHIA reorganize the two scattered |
| 78 | C partons and their final momenta will be a little |
| 79 | C different. The summed total momenta of the partons |
| 80 | C from the final state radiation are stored in HINT1(26-29) |
| 81 | C and HINT1(36-39) which are little different from |
| 82 | C HINT1(21-24) and HINT1(41-44). |
| 83 | C |
| 84 | C Version 1.33 |
| 85 | C |
| 86 | C Last modfication on September 11, 1995. When HIJING and |
| 87 | C PYTHIA are initialized, the shadowing is evaluated at |
| 88 | C b=0 which is the maximum. This will cause overestimate |
| 89 | C of shadowing for peripheral interactions. To correct this |
| 90 | C problem, shadowing is set to zero when initializing. Then |
| 91 | C use these maximum cross section without shadowing as a |
| 92 | C normalization of the Monte Carlo. This however increase |
| 93 | C the computing time. IHNT2(16) is used to indicate whether |
| 94 | C the sturcture function is called for (IHNT2(16)=1) initialization |
| 95 | C or for (IHNT2(16)=0)normal collisions simulation |
| 96 | C |
| 97 | C Last modification on Aagust 28, 1994. Two bugs associate |
| 98 | C with the impact parameter dependence of the shadowing is |
| 99 | C corrected. |
| 100 | C |
| 101 | C |
| 102 | c Last modification on October 14, 1994. One bug is corrected |
| 103 | c in the direct photon production option in subroutine |
| 104 | C HIJHRD.( this problem was reported by Jim Carroll and Mike Beddo). |
| 105 | C Another bug associated with keeping the decay history |
| 106 | C in the particle information is also corrected.(this problem |
| 107 | C was reported by Matt Bloomer) |
| 108 | C |
| 109 | C |
| 110 | C Last modification on July 15, 1994. The option to trig on |
| 111 | C heavy quark production (charm IHPR2(18)=0 or beauty IHPR2(18)=1) |
| 112 | C is added. To do this, set IHPR2(3)=3. For inclusive production, |
| 113 | C one should reset HIPR1(10)=0.0. One can also trig larger pt |
| 114 | C QQbar production by giving HIPR1(10) a nonvanishing value. |
| 115 | C The mass of the heavy quark in the calculation of the cross |
| 116 | C section (HINT1(59)--HINT1(65)) is given by HIPR1(7) (the |
| 117 | C default is the charm mass D=1.5). We also include a separate |
| 118 | C K-factor for heavy quark and direct photon production by |
| 119 | C HIPR1(23)(D=2.0). |
| 120 | C |
| 121 | C Last modification on May 24, 1994. The option to |
| 122 | C retain the information of all particles including those |
| 123 | C who have decayed is IHPR(21)=1 (default=0). KATT(I,3) is |
| 124 | C added to contain the line number of the parent particle |
| 125 | C of the current line which is produced via a decay. |
| 126 | C KATT(I,4) is the status number of the particle: 11=particle |
| 127 | C which has decayed; 1=finally produced particle. |
| 128 | C |
| 129 | C |
| 130 | C Last modification on May 24, 1994( in HIJSFT when valence quark |
| 131 | C is quenched, the following error is corrected. 1.2*IHNT2(1) --> |
| 132 | C 1.2*IHNT2(1)**0.333333, 1.2*IHNT2(3) -->1.2*IHNT(3)**0.333333) |
| 133 | C |
| 134 | C |
| 135 | C Last modification on March 16, 1994 (heavy flavor production |
| 136 | C processes MSUB(81)=1 MSUB(82)=1 have been switched on, |
| 137 | C charm production is the default, B-quark option is |
| 138 | C IHPR2(18), when it is switched on, charm quark is |
| 139 | C automatically off) |
| 140 | C |
| 141 | C |
| 142 | C Last modification on March 23, 1994 (an error is corrected |
| 143 | C in the impact parameter dependence of the jet cross section) |
| 144 | C |
| 145 | C Last modification Oct. 1993 to comply with non-vax |
| 146 | C machines' compiler |
| 147 | C |
| 148 | C********************************************* |
| 149 | C LAST MODIFICATION April 5, 1991 |
| 150 | CQUARK DISTRIBUTIOIN (1-X)**A/(X**2+C**2/S)**B |
| 151 | C(A=HIPR1(44),B=HIPR1(46),C=HIPR1(45)) |
| 152 | C STRING FLIP, VENUS OPTION IHPR2(15)=1,IN WHICH ONE CAN HAVE ONE AND |
| 153 | C TWO COLOR CHANGES, (1-W)**2,W*(1-W),W*(1-W),AND W*2, W=HIPR1(18), |
| 154 | C AMONG PT DISTRIBUTION OF SEA QUARKS IS CONTROLLED BY HIPR1(42) |
| 155 | C |
| 156 | C gluon jets can form a single string system |
| 157 | C |
| 158 | C initial state radiation is included |
| 159 | C |
| 160 | C all QCD subprocesses are included |
| 161 | c |
| 162 | c direct particles production is included(currently only direct |
| 163 | C photon) |
| 164 | c |
| 165 | C Effect of high P_T trigger bias on multiple jets distribution |
| 166 | c |
| 167 | C****************************************************************** |
| 168 | C HIJING.10 * |
| 169 | C Heavy Ion Jet INteraction Generator * |
| 170 | C by * |
| 171 | C X. N. Wang and M. Gyulassy * |
| 172 | C Lawrence Berkeley Laboratory * |
| 173 | C * |
| 174 | C****************************************************************** |
| 175 | C |
| 176 | C****************************************************************** |
| 177 | C NFP(K,1),NFP(K,2)=flavor of q and di-q, NFP(K,3)=present ID of * |
| 178 | C proj, NFP(K,4) original ID of proj. NFP(K,5)=colli status(0=no,* |
| 179 | C 1=elastic,2=the diffrac one in single-diffrac,3= excited string.* |
| 180 | C |NFP(K,6)| is the total # of jet production, if NFP(K,6)<0 it * |
| 181 | C can not produce jet anymore. NFP(K,10)=valence quarks scattering* |
| 182 | C (0=has not been,1=is going to be, -1=has already been scattered * |
| 183 | C NFP(k,11) total number of interactions this proj has suffered * |
| 184 | C PP(K,1)=PX,PP(K,2)=PY,PP(K,3)=PZ,PP(K,4)=E,PP(K,5)=M(invariant * |
| 185 | C mass), PP(K,6,7),PP(K,8,9)=transverse momentum of quark and * |
| 186 | C diquark,PP(K,10)=PT of the hard scattering between the valence * |
| 187 | C quarks; PP(K,14,15)=the mass of quark,diquark. * |
| 188 | C****************************************************************** |
| 189 | C |
| 190 | C**************************************************************** |
| 191 | C |
| 192 | C SUBROUTINE HIJING |
| 193 | C |
| 194 | C**************************************************************** |
| 195 | SUBROUTINE HIJING(FRAME,BMIN0,BMAX0) |
| 196 | |
| 197 | cgsfs Added following for consistency with AMPT call |
| 198 | double precision BMIN0, BMAX0 |
| 199 | |
| 200 | cbz1/25/99 |
| 201 | PARAMETER (MAXPTN=400001) |
| 202 | clin-4/20/01 PARAMETER (MAXSTR = 1600) |
| 203 | PARAMETER (MAXSTR=150001) |
| 204 | cbz1/25/99end |
| 205 | clin-4/26/01: |
| 206 | PARAMETER (MAXIDL=4001) |
| 207 | |
| 208 | cbz1/31/99 |
| 209 | DOUBLE PRECISION GX0, GY0, GZ0, FT0, PX0, PY0, PZ0, E0, XMASS0 |
| 210 | DOUBLE PRECISION GX5, GY5, GZ5, FT5, PX5, PY5, PZ5, E5, XMASS5 |
| 211 | DOUBLE PRECISION ATAUI, ZT1, ZT2, ZT3 |
| 212 | DOUBLE PRECISION xnprod,etprod,xnfrz,etfrz, |
| 213 | & dnprod,detpro,dnfrz,detfrz |
| 214 | |
| 215 | cbz1/31/99end |
| 216 | |
| 217 | CHARACTER FRAME*8 |
| 218 | DIMENSION SCIP(300,300),RNIP(300,300),SJIP(300,300),JTP(3), |
| 219 | & IPCOL(90000),ITCOL(90000) |
| 220 | COMMON/HPARNT/HIPR1(100),IHPR2(50),HINT1(100),IHNT2(50) |
| 221 | cc SAVE /HPARNT/ |
| 222 | C |
| 223 | COMMON/hjcrdn/YP(3,300),YT(3,300) |
| 224 | cc SAVE /hjcrdn/ |
| 225 | clin-7/16/03 NINT is a intrinsic fortran function, rename it to NINTHJ |
| 226 | c COMMON/HJGLBR/NELT,NINT,NELP,NINP |
| 227 | COMMON/HJGLBR/NELT,NINTHJ,NELP,NINP |
| 228 | cc SAVE /HJGLBR/ |
| 229 | COMMON/HMAIN1/EATT,JATT,NATT,NT,NP,N0,N01,N10,N11 |
| 230 | cc SAVE /HMAIN1/ |
| 231 | clin-4/26/01 |
| 232 | c COMMON/HMAIN2/KATT(130000,4),PATT(130000,4) |
| 233 | COMMON/HMAIN2/KATT(MAXSTR,4),PATT(MAXSTR,4) |
| 234 | cc SAVE /HMAIN2/ |
| 235 | COMMON/HSTRNG/NFP(300,15),PP(300,15),NFT(300,15),PT(300,15) |
| 236 | cc SAVE /HSTRNG/ |
| 237 | COMMON/HJJET1/NPJ(300),KFPJ(300,500),PJPX(300,500), |
| 238 | & PJPY(300,500),PJPZ(300,500),PJPE(300,500), |
| 239 | & PJPM(300,500),NTJ(300),KFTJ(300,500), |
| 240 | & PJTX(300,500),PJTY(300,500),PJTZ(300,500), |
| 241 | & PJTE(300,500),PJTM(300,500) |
| 242 | cc SAVE /HJJET1/ |
| 243 | clin-4/2008 |
| 244 | c COMMON/HJJET2/NSG,NJSG(900),IASG(900,3),K1SG(900,100), |
| 245 | c & K2SG(900,100),PXSG(900,100),PYSG(900,100), |
| 246 | c & PZSG(900,100),PESG(900,100),PMSG(900,100) |
| 247 | COMMON/HJJET2/NSG,NJSG(MAXSTR),IASG(MAXSTR,3),K1SG(MAXSTR,100), |
| 248 | & K2SG(MAXSTR,100),PXSG(MAXSTR,100),PYSG(MAXSTR,100), |
| 249 | & PZSG(MAXSTR,100),PESG(MAXSTR,100),PMSG(MAXSTR,100) |
| 250 | cc SAVE /HJJET2/ |
| 251 | COMMON/HJJET4/NDR,IADR(MAXSTR,2),KFDR(MAXSTR),PDR(MAXSTR,5) |
| 252 | clin-4/2008: |
| 253 | c common/xydr/rtdr(900,2) |
| 254 | common/xydr/rtdr(MAXSTR,2) |
| 255 | cc SAVE /HJJET4/ |
| 256 | COMMON/RNDF77/NSEED |
| 257 | cc SAVE /RNDF77/ |
| 258 | C |
| 259 | COMMON/LUJETSA/N,K(9000,5),P(9000,5),V(9000,5) |
| 260 | cc SAVE /LUJETSA/ |
| 261 | COMMON/LUDAT1A/MSTU(200),PARU(200),MSTJ(200),PARJ(200) |
| 262 | cc SAVE /LUDAT1A/ |
| 263 | |
| 264 | clin-9/29/03 changed name in order to distinguish from /prec2/ |
| 265 | COMMON /ARPRC/ ITYPAR(MAXSTR), |
| 266 | & GXAR(MAXSTR), GYAR(MAXSTR), GZAR(MAXSTR), FTAR(MAXSTR), |
| 267 | & PXAR(MAXSTR), PYAR(MAXSTR), PZAR(MAXSTR), PEAR(MAXSTR), |
| 268 | & XMAR(MAXSTR) |
| 269 | ccbz11/11/98 |
| 270 | c COMMON /ARPRC/ ITYP(MAXSTR), |
| 271 | c & GX(MAXSTR), GY(MAXSTR), GZ(MAXSTR), FT(MAXSTR), |
| 272 | c & PX(MAXSTR), PY(MAXSTR), PZ(MAXSTR), EE(MAXSTR), |
| 273 | c & XM(MAXSTR) |
| 274 | cc SAVE /ARPRC/ |
| 275 | ccbz11/11/98end |
| 276 | |
| 277 | cbz1/25/99 |
| 278 | COMMON /PARA1/ MUL |
| 279 | cc SAVE /PARA1/ |
| 280 | COMMON /prec1/GX0(MAXPTN),GY0(MAXPTN),GZ0(MAXPTN),FT0(MAXPTN), |
| 281 | & PX0(MAXPTN), PY0(MAXPTN), PZ0(MAXPTN), E0(MAXPTN), |
| 282 | & XMASS0(MAXPTN), ITYP0(MAXPTN) |
| 283 | cc SAVE /prec1/ |
| 284 | COMMON /prec2/GX5(MAXPTN),GY5(MAXPTN),GZ5(MAXPTN),FT5(MAXPTN), |
| 285 | & PX5(MAXPTN), PY5(MAXPTN), PZ5(MAXPTN), E5(MAXPTN), |
| 286 | & XMASS5(MAXPTN), ITYP5(MAXPTN) |
| 287 | cc SAVE /prec2/ |
| 288 | COMMON /ilist7/ LSTRG0(MAXPTN), LPART0(MAXPTN) |
| 289 | cc SAVE /ilist7/ |
| 290 | COMMON /ilist8/ LSTRG1(MAXPTN), LPART1(MAXPTN) |
| 291 | cc SAVE /ilist8/ |
| 292 | COMMON /SREC1/ NSP, NST, NSI |
| 293 | cc SAVE /SREC1/ |
| 294 | COMMON /SREC2/ATAUI(MAXSTR),ZT1(MAXSTR),ZT2(MAXSTR),ZT3(MAXSTR) |
| 295 | cc SAVE /SREC2/ |
| 296 | cbz1/25/99end |
| 297 | |
| 298 | clin-2/25/00 |
| 299 | COMMON /frzout/ xnprod(30),etprod(30),xnfrz(30),etfrz(30), |
| 300 | & dnprod(30),detpro(30),dnfrz(30),detfrz(30) |
| 301 | cc SAVE /frzout/ |
| 302 | clin-4/11/01 soft: |
| 303 | common/anim/nevent,isoft,isflag,izpc |
| 304 | cc SAVE /anim/ |
| 305 | clin-4/25/01 soft3: |
| 306 | DOUBLE PRECISION PXSGS,PYSGS,PZSGS,PESGS,PMSGS, |
| 307 | 1 GXSGS,GYSGS,GZSGS,FTSGS |
| 308 | COMMON/SOFT/PXSGS(MAXSTR,3),PYSGS(MAXSTR,3),PZSGS(MAXSTR,3), |
| 309 | & PESGS(MAXSTR,3),PMSGS(MAXSTR,3),GXSGS(MAXSTR,3), |
| 310 | & GYSGS(MAXSTR,3),GZSGS(MAXSTR,3),FTSGS(MAXSTR,3), |
| 311 | & K1SGS(MAXSTR,3),K2SGS(MAXSTR,3),NJSGS(MAXSTR) |
| 312 | cc SAVE /SOFT/ |
| 313 | clin-4/26/01 lepton and photon info: |
| 314 | COMMON /NOPREC/ NNOZPC, ITYPN(MAXIDL), |
| 315 | & GXN(MAXIDL), GYN(MAXIDL), GZN(MAXIDL), FTN(MAXIDL), |
| 316 | & PXN(MAXIDL), PYN(MAXIDL), PZN(MAXIDL), EEN(MAXIDL), |
| 317 | & XMN(MAXIDL) |
| 318 | cc SAVE /NOPREC/ |
| 319 | clin-6/22/01: |
| 320 | common /lastt/itimeh,bimp |
| 321 | cc SAVE /lastt/ |
| 322 | COMMON /AREVT/ IAEVT, IARUN, MISS |
| 323 | common/phidcy/iphidcy,pttrig,ntrig,maxmiss |
| 324 | cwei DOUBLE PRECISION PATT |
| 325 | SAVE |
| 326 | |
| 327 | cgsfs WRITE(*,*) "IN Hijing, FRAME=",FRAME |
| 328 | cgsfs WRITE(*,*) "IN Hijing, BMIN=",BMIN0 |
| 329 | cgsfs WRITE(*,*) "IN Hijing, BMAX=",BMAX0 |
| 330 | |
| 331 | BMAX=MIN(BMAX0,HIPR1(34)+HIPR1(35)) |
| 332 | BMIN=MIN(BMIN0,BMAX) |
| 333 | IF(IHNT2(1).LE.1 .AND. IHNT2(3).LE.1) THEN |
| 334 | BMIN=0.0 |
| 335 | BMAX=2.5*SQRT(HIPR1(31)*0.1/HIPR1(40)) |
| 336 | ENDIF |
| 337 | C ********HIPR1(31) is in mb =0.1fm**2 |
| 338 | C*******THE FOLLOWING IS TO SELECT THE COORDINATIONS OF NUCLEONS |
| 339 | C BOTH IN PROJECTILE AND TARGET NUCLEAR( in fm) |
| 340 | C |
| 341 | cgsfs WRITE(*,*) "IN Hijing, Modified BMIN=",BMIN |
| 342 | cgsfs WRITE(*,*) "IN Hijing, Modified BMAX=",BMAX |
| 343 | YP(1,1)=0.0 |
| 344 | YP(2,1)=0.0 |
| 345 | YP(3,1)=0.0 |
| 346 | IF(IHNT2(1).LE.1) GO TO 14 |
| 347 | DO 10 KP=1,IHNT2(1) |
| 348 | 5 R=HIRND(1) |
| 349 | X=RANART(NSEED) |
| 350 | CX=2.0*X-1.0 |
| 351 | SX=SQRT(1.0-CX*CX) |
| 352 | C ********choose theta from uniform cos(theta) distr |
| 353 | PHI=RANART(NSEED)*2.0*HIPR1(40) |
| 354 | C ********choose phi form uniform phi distr 0 to 2*pi |
| 355 | YP(1,KP)=R*SX*COS(PHI) |
| 356 | YP(2,KP)=R*SX*SIN(PHI) |
| 357 | YP(3,KP)=R*CX |
| 358 | IF(HIPR1(29).EQ.0.0) GO TO 10 |
| 359 | DO 8 KP2=1,KP-1 |
| 360 | DNBP1=(YP(1,KP)-YP(1,KP2))**2 |
| 361 | DNBP2=(YP(2,KP)-YP(2,KP2))**2 |
| 362 | DNBP3=(YP(3,KP)-YP(3,KP2))**2 |
| 363 | DNBP=DNBP1+DNBP2+DNBP3 |
| 364 | IF(DNBP.LT.HIPR1(29)*HIPR1(29)) GO TO 5 |
| 365 | C ********two neighbors cannot be closer than |
| 366 | C HIPR1(29) |
| 367 | 8 CONTINUE |
| 368 | 10 CONTINUE |
| 369 | |
| 370 | clin-1/27/03 Hulthen wavefn for deuteron borrowed from hijing1.382.f, |
| 371 | c but modified [divide by 2, & x(p)=-x(n)]: |
| 372 | c (Note: hijing1.383.f has corrected this bug in hijing1.382.f) |
| 373 | if(IHNT2(1).EQ.2) then |
| 374 | rnd1=max(RANART(NSEED),1.0e-20) |
| 375 | rnd2=max(RANART(NSEED),1.0e-20) |
| 376 | rnd3=max(RANART(NSEED),1.0e-20) |
| 377 | R=-(log(rnd1)*4.38/2.0+log(rnd2)*0.85/2.0 |
| 378 | & +4.38*0.85*log(rnd3)/(4.38+0.85)) |
| 379 | X=RANART(NSEED) |
| 380 | CX=2.0*X-1.0 |
| 381 | SX=SQRT(1.0-CX*CX) |
| 382 | PHI=RANART(NSEED)*2.0*HIPR1(40) |
| 383 | c R above is the relative distance between p & n in a deuteron: |
| 384 | R=R/2. |
| 385 | YP(1,1)=R*SX*COS(PHI) |
| 386 | YP(2,1)=R*SX*SIN(PHI) |
| 387 | YP(3,1)=R*CX |
| 388 | c p & n has opposite coordinates in the deuteron frame: |
| 389 | YP(1,2)=-YP(1,1) |
| 390 | YP(2,2)=-YP(2,1) |
| 391 | YP(3,2)=-YP(3,1) |
| 392 | endif |
| 393 | |
| 394 | DO 12 I=1,IHNT2(1)-1 |
| 395 | DO 12 J=I+1,IHNT2(1) |
| 396 | IF(YP(3,I).GT.YP(3,J)) GO TO 12 |
| 397 | Y1=YP(1,I) |
| 398 | Y2=YP(2,I) |
| 399 | Y3=YP(3,I) |
| 400 | YP(1,I)=YP(1,J) |
| 401 | YP(2,I)=YP(2,J) |
| 402 | YP(3,I)=YP(3,J) |
| 403 | YP(1,J)=Y1 |
| 404 | YP(2,J)=Y2 |
| 405 | YP(3,J)=Y3 |
| 406 | 12 CONTINUE |
| 407 | C |
| 408 | C****************************** |
| 409 | 14 YT(1,1)=0.0 |
| 410 | YT(2,1)=0.0 |
| 411 | YT(3,1)=0.0 |
| 412 | IF(IHNT2(3).LE.1) GO TO 24 |
| 413 | DO 20 KT=1,IHNT2(3) |
| 414 | 15 R=HIRND(2) |
| 415 | X=RANART(NSEED) |
| 416 | CX=2.0*X-1.0 |
| 417 | SX=SQRT(1.0-CX*CX) |
| 418 | C ********choose theta from uniform cos(theta) distr |
| 419 | PHI=RANART(NSEED)*2.0*HIPR1(40) |
| 420 | C ********chose phi form uniform phi distr 0 to 2*pi |
| 421 | YT(1,KT)=R*SX*COS(PHI) |
| 422 | YT(2,KT)=R*SX*SIN(PHI) |
| 423 | YT(3,KT)=R*CX |
| 424 | IF(HIPR1(29).EQ.0.0) GO TO 20 |
| 425 | DO 18 KT2=1,KT-1 |
| 426 | DNBT1=(YT(1,KT)-YT(1,KT2))**2 |
| 427 | DNBT2=(YT(2,KT)-YT(2,KT2))**2 |
| 428 | DNBT3=(YT(3,KT)-YT(3,KT2))**2 |
| 429 | DNBT=DNBT1+DNBT2+DNBT3 |
| 430 | IF(DNBT.LT.HIPR1(29)*HIPR1(29)) GO TO 15 |
| 431 | C ********two neighbors cannot be closer than |
| 432 | C HIPR1(29) |
| 433 | 18 CONTINUE |
| 434 | 20 CONTINUE |
| 435 | c |
| 436 | clin-1/27/03 Hulthen wavefn for deuteron borrowed from hijing1.382.f, |
| 437 | c but modified [divide by 2, & x(p)=-x(n)]: |
| 438 | if(IHNT2(3).EQ.2) then |
| 439 | rnd1=max(RANART(NSEED),1.0e-20) |
| 440 | rnd2=max(RANART(NSEED),1.0e-20) |
| 441 | rnd3=max(RANART(NSEED),1.0e-20) |
| 442 | R=-(log(rnd1)*4.38/2.0+log(rnd2)*0.85/2.0 |
| 443 | & +4.38*0.85*log(rnd3)/(4.38+0.85)) |
| 444 | X=RANART(NSEED) |
| 445 | CX=2.0*X-1.0 |
| 446 | SX=SQRT(1.0-CX*CX) |
| 447 | PHI=RANART(NSEED)*2.0*HIPR1(40) |
| 448 | R=R/2. |
| 449 | YT(1,1)=R*SX*COS(PHI) |
| 450 | YT(2,1)=R*SX*SIN(PHI) |
| 451 | YT(3,1)=R*CX |
| 452 | YT(1,2)=-YT(1,1) |
| 453 | YT(2,2)=-YT(2,1) |
| 454 | YT(3,2)=-YT(3,1) |
| 455 | endif |
| 456 | c |
| 457 | DO 22 I=1,IHNT2(3)-1 |
| 458 | DO 22 J=I+1,IHNT2(3) |
| 459 | IF(YT(3,I).LT.YT(3,J)) GO TO 22 |
| 460 | Y1=YT(1,I) |
| 461 | Y2=YT(2,I) |
| 462 | Y3=YT(3,I) |
| 463 | YT(1,I)=YT(1,J) |
| 464 | YT(2,I)=YT(2,J) |
| 465 | YT(3,I)=YT(3,J) |
| 466 | YT(1,J)=Y1 |
| 467 | YT(2,J)=Y2 |
| 468 | YT(3,J)=Y3 |
| 469 | 22 CONTINUE |
| 470 | |
| 471 | C******************** |
| 472 | 24 MISS=-1 |
| 473 | 50 MISS=MISS+1 |
| 474 | |
| 475 | clin-6/2009 ctest on |
| 476 | c IF(MISS.GT.50) THEN |
| 477 | IF(MISS.GT.maxmiss) THEN |
| 478 | WRITE(6,*) 'infinite loop happened in HIJING' |
| 479 | STOP |
| 480 | ENDIF |
| 481 | |
| 482 | clin-4/30/01: |
| 483 | itest=0 |
| 484 | |
| 485 | NATT=0 |
| 486 | JATT=0 |
| 487 | EATT=0.0 |
| 488 | CALL HIJINI |
| 489 | NLOP=0 |
| 490 | C ********Initialize for a new event |
| 491 | 60 NT=0 |
| 492 | NP=0 |
| 493 | N0=0 |
| 494 | N01=0 |
| 495 | N10=0 |
| 496 | N11=0 |
| 497 | NELT=0 |
| 498 | NINTHJ=0 |
| 499 | NELP=0 |
| 500 | NINP=0 |
| 501 | NSG=0 |
| 502 | NCOLT=0 |
| 503 | |
| 504 | C**** BB IS THE ABSOLUTE VALUE OF IMPACT PARAMETER,BB**2 IS |
| 505 | C RANDOMLY GENERATED AND ITS ORIENTATION IS RANDOMLY SET |
| 506 | C BY THE ANGLE PHI FOR EACH COLLISION.****************** |
| 507 | C |
| 508 | BB=SQRT(BMIN**2+RANART(NSEED)*(BMAX**2-BMIN**2)) |
| 509 | cbz6/28/99 flow1 |
| 48beeea0 |
510 | c PHI=2.0*HIPR1(40)*RANART(NSEED) |
| 511 | PHI=0. |
| 0119ef9a |
512 | cbz6/28/99 flow1 end |
| 513 | BBX=BB*COS(PHI) |
| 514 | BBY=BB*SIN(PHI) |
| 515 | HINT1(19)=BB |
| 516 | HINT1(20)=PHI |
| 517 | C |
| 518 | DO 70 JP=1,IHNT2(1) |
| 519 | DO 70 JT=1,IHNT2(3) |
| 520 | SCIP(JP,JT)=-1.0 |
| 521 | B2=(YP(1,JP)+BBX-YT(1,JT))**2+(YP(2,JP)+BBY-YT(2,JT))**2 |
| 522 | R2=B2*HIPR1(40)/HIPR1(31)/0.1 |
| 523 | C ********mb=0.1*fm, YP is in fm,HIPR1(31) is in mb |
| 524 | RRB1=MIN((YP(1,JP)**2+YP(2,JP)**2) |
| 525 | & /1.2**2/REAL(IHNT2(1))**0.6666667,1.0) |
| 526 | RRB2=MIN((YT(1,JT)**2+YT(2,JT)**2) |
| 527 | & /1.2**2/REAL(IHNT2(3))**0.6666667,1.0) |
| 528 | APHX1=HIPR1(6)*4.0/3.0*(IHNT2(1)**0.3333333-1.0) |
| 529 | & *SQRT(1.0-RRB1) |
| 530 | APHX2=HIPR1(6)*4.0/3.0*(IHNT2(3)**0.3333333-1.0) |
| 531 | & *SQRT(1.0-RRB2) |
| 532 | HINT1(18)=HINT1(14)-APHX1*HINT1(15) |
| 533 | & -APHX2*HINT1(16)+APHX1*APHX2*HINT1(17) |
| 534 | IF(IHPR2(14).EQ.0.OR. |
| 535 | & (IHNT2(1).EQ.1.AND.IHNT2(3).EQ.1)) THEN |
| 536 | GS=1.0-EXP(-(HIPR1(30)+HINT1(18))*ROMG(R2)/HIPR1(31)) |
| 537 | RANTOT=RANART(NSEED) |
| 538 | IF(RANTOT.GT.GS) GO TO 70 |
| 539 | GO TO 65 |
| 540 | ENDIF |
| 541 | GSTOT0=2.0*(1.0-EXP(-(HIPR1(30)+HINT1(18)) |
| 542 | & /HIPR1(31)/2.0*ROMG(0.0))) |
| 543 | R2=R2/GSTOT0 |
| 544 | GS=1.0-EXP(-(HIPR1(30)+HINT1(18))/HIPR1(31)*ROMG(R2)) |
| 545 | GSTOT=2.0*(1.0-SQRT(1.0-GS)) |
| 546 | RANTOT=RANART(NSEED)*GSTOT0 |
| 547 | IF(RANTOT.GT.GSTOT) GO TO 70 |
| 548 | IF(RANTOT.GT.GS) THEN |
| 549 | CALL HIJCSC(JP,JT) |
| 550 | GO TO 70 |
| 551 | C ********perform elastic collisions |
| 552 | ENDIF |
| 553 | 65 SCIP(JP,JT)=R2 |
| 554 | RNIP(JP,JT)=RANTOT |
| 555 | SJIP(JP,JT)=HINT1(18) |
| 556 | NCOLT=NCOLT+1 |
| 557 | IPCOL(NCOLT)=JP |
| 558 | ITCOL(NCOLT)=JT |
| 559 | 70 CONTINUE |
| 560 | C ********total number interactions proj and targ has |
| 561 | C suffered |
| 562 | |
| 563 | clin-5/22/01 write impact parameter: |
| 564 | bimp=bb |
| 565 | c write(6,*) '#impact parameter,nlop,ncolt=',bimp,nlop,ncolt |
| 566 | |
| 567 | IF(NCOLT.EQ.0) THEN |
| 568 | NLOP=NLOP+1 |
| 569 | IF(NLOP.LE.20.OR. |
| 570 | & (IHNT2(1).EQ.1.AND.IHNT2(3).EQ.1)) GO TO 60 |
| 571 | RETURN |
| 572 | ENDIF |
| 573 | C ********At large impact parameter, there maybe no |
| 574 | C interaction at all. For NN collision |
| 575 | C repeat the event until interaction happens |
| 576 | C |
| 577 | IF(IHPR2(3).NE.0) THEN |
| 578 | NHARD=1+INT(RANART(NSEED)*(NCOLT-1)+0.5) |
| 579 | NHARD=MIN(NHARD,NCOLT) |
| 580 | JPHARD=IPCOL(NHARD) |
| 581 | JTHARD=ITCOL(NHARD) |
| 582 | clin-6/2009 ctest off: |
| 583 | c write(99,*) IAEVT,NHARD,NCOLT,JPHARD,JTHARD |
| 584 | ENDIF |
| 585 | C |
| 586 | IF(IHPR2(9).EQ.1) THEN |
| 587 | NMINI=1+INT(RANART(NSEED)*(NCOLT-1)+0.5) |
| 588 | NMINI=MIN(NMINI,NCOLT) |
| 589 | JPMINI=IPCOL(NMINI) |
| 590 | JTMINI=ITCOL(NMINI) |
| 591 | ENDIF |
| 592 | C ********Specifying the location of the hard and |
| 593 | C minijet if they are enforced by user |
| 594 | C |
| 595 | DO 200 JP=1,IHNT2(1) |
| 596 | DO 200 JT=1,IHNT2(3) |
| 597 | IF(SCIP(JP,JT).EQ.-1.0) GO TO 200 |
| 598 | NFP(JP,11)=NFP(JP,11)+1 |
| 599 | NFT(JT,11)=NFT(JT,11)+1 |
| 600 | IF(NFP(JP,5).LE.1 .AND. NFT(JT,5).GT.1) THEN |
| 601 | NP=NP+1 |
| 602 | N01=N01+1 |
| 603 | ELSE IF(NFP(JP,5).GT.1 .AND. NFT(JT,5).LE.1) THEN |
| 604 | NT=NT+1 |
| 605 | N10=N10+1 |
| 606 | ELSE IF(NFP(JP,5).LE.1 .AND. NFT(JT,5).LE.1) THEN |
| 607 | NP=NP+1 |
| 608 | NT=NT+1 |
| 609 | N0=N0+1 |
| 610 | ELSE IF(NFP(JP,5).GT.1 .AND. NFT(JT,5).GT.1) THEN |
| 611 | N11=N11+1 |
| 612 | ENDIF |
| 613 | JOUT=0 |
| 614 | NFP(JP,10)=0 |
| 615 | NFT(JT,10)=0 |
| 616 | C***************************************************************** |
| 617 | IF(IHPR2(8).EQ.0 .AND. IHPR2(3).EQ.0) GO TO 160 |
| 618 | C ********When IHPR2(8)=0 no jets are produced |
| 619 | IF(NFP(JP,6).LT.0 .OR. NFT(JT,6).LT.0) GO TO 160 |
| 620 | C ********jets can not be produced for (JP,JT) |
| 621 | C because not enough energy avaible for |
| 622 | C JP or JT |
| 623 | R2=SCIP(JP,JT) |
| 624 | HINT1(18)=SJIP(JP,JT) |
| 625 | TT=ROMG(R2)*HINT1(18)/HIPR1(31) |
| 626 | TTS=HIPR1(30)*ROMG(R2)/HIPR1(31) |
| 627 | NJET=0 |
| 628 | |
| 629 | IF(IHPR2(3).NE.0 .AND. JP.EQ.JPHARD .AND. JT.EQ.JTHARD) THEN |
| 630 | CALL JETINI(JP,JT,1) |
| 631 | CALL HIJHRD(JP,JT,0,JFLG,0) |
| 632 | HINT1(26)=HINT1(47) |
| 633 | HINT1(27)=HINT1(48) |
| 634 | HINT1(28)=HINT1(49) |
| 635 | HINT1(29)=HINT1(50) |
| 636 | HINT1(36)=HINT1(67) |
| 637 | HINT1(37)=HINT1(68) |
| 638 | HINT1(38)=HINT1(69) |
| 639 | HINT1(39)=HINT1(70) |
| 640 | C |
| 641 | IF(ABS(HINT1(46)).GT.HIPR1(11).AND.JFLG.EQ.2) NFP(JP,7)=1 |
| 642 | IF(ABS(HINT1(56)).GT.HIPR1(11).AND.JFLG.EQ.2) NFT(JT,7)=1 |
| 643 | IF(MAX(ABS(HINT1(46)),ABS(HINT1(56))).GT.HIPR1(11).AND. |
| 644 | & JFLG.GE.3) IASG(NSG,3)=1 |
| 645 | IHNT2(9)=IHNT2(14) |
| 646 | IHNT2(10)=IHNT2(15) |
| 647 | DO 105 I05=1,5 |
| 648 | HINT1(20+I05)=HINT1(40+I05) |
| 649 | HINT1(30+I05)=HINT1(50+I05) |
| 650 | 105 CONTINUE |
| 651 | clin-6/2009 ctest off: |
| 652 | c write(99,*) jp,jt,IHPR2(3),HIPR1(10),njet, |
| 653 | c 1 ihnt2(9),hint1(21),hint1(22),hint1(23), |
| 654 | c 2 ihnt2(10),hint1(31),hint1(32),hint1(33) |
| 655 | c write(99,*) ' ' |
| 656 | JOUT=1 |
| 657 | IF(IHPR2(8).EQ.0) GO TO 160 |
| 658 | RRB1=MIN((YP(1,JP)**2+YP(2,JP)**2)/1.2**2 |
| 659 | & /REAL(IHNT2(1))**0.6666667,1.0) |
| 660 | RRB2=MIN((YT(1,JT)**2+YT(2,JT)**2)/1.2**2 |
| 661 | & /REAL(IHNT2(3))**0.6666667,1.0) |
| 662 | APHX1=HIPR1(6)*4.0/3.0*(IHNT2(1)**0.3333333-1.0) |
| 663 | & *SQRT(1.0-RRB1) |
| 664 | APHX2=HIPR1(6)*4.0/3.0*(IHNT2(3)**0.3333333-1.0) |
| 665 | & *SQRT(1.0-RRB2) |
| 666 | HINT1(65)=HINT1(61)-APHX1*HINT1(62) |
| 667 | & -APHX2*HINT1(63)+APHX1*APHX2*HINT1(64) |
| 668 | TTRIG=ROMG(R2)*HINT1(65)/HIPR1(31) |
| 669 | NJET=-1 |
| 670 | C ********subtract the trigger jet from total number |
| 671 | C of jet production to be done since it has |
| 672 | C already been produced here |
| 673 | XR1=-ALOG(EXP(-TTRIG)+RANART(NSEED)*(1.0-EXP(-TTRIG))) |
| 674 | 106 NJET=NJET+1 |
| 675 | XR1=XR1-ALOG(max(RANART(NSEED),1.0e-20)) |
| 676 | IF(XR1.LT.TTRIG) GO TO 106 |
| 677 | XR=0.0 |
| 678 | 107 NJET=NJET+1 |
| 679 | XR=XR-ALOG(max(RANART(NSEED),1.0e-20)) |
| 680 | IF(XR.LT.TT-TTRIG) GO TO 107 |
| 681 | NJET=NJET-1 |
| 682 | GO TO 112 |
| 683 | ENDIF |
| 684 | C ********create a hard interaction with specified P_T |
| 685 | c when IHPR2(3)>0 |
| 686 | IF(IHPR2(9).EQ.1.AND.JP.EQ.JPMINI.AND.JT.EQ.JTMINI) GO TO 110 |
| 687 | C ********create at least one pair of mini jets |
| 688 | C when IHPR2(9)=1 |
| 689 | C |
| 690 | IF(IHPR2(8).GT.0 .AND.RNIP(JP,JT).LT.EXP(-TT)* |
| 691 | & (1.0-EXP(-TTS))) GO TO 160 |
| 692 | C ********this is the probability for no jet production |
| 693 | 110 XR=-ALOG(EXP(-TT)+RANART(NSEED)*(1.0-EXP(-TT))) |
| 694 | 111 NJET=NJET+1 |
| 695 | XR=XR-ALOG(max(RANART(NSEED),1.0e-20)) |
| 696 | IF(XR.LT.TT) GO TO 111 |
| 697 | 112 NJET=MIN(NJET,IHPR2(8)) |
| 698 | IF(IHPR2(8).LT.0) NJET=ABS(IHPR2(8)) |
| 699 | C ******** Determine number of mini jet production |
| 700 | C |
| 701 | DO 150 ijet=1,NJET |
| 702 | CALL JETINI(JP,JT,0) |
| 703 | CALL HIJHRD(JP,JT,JOUT,JFLG,1) |
| 704 | C ********JFLG=1 jets valence quarks, JFLG=2 with |
| 705 | C gluon jet, JFLG=3 with q-qbar prod for |
| 706 | C (JP,JT). If JFLG=0 jets can not be produced |
| 707 | C this time. If JFLG=-1, error occured abandon |
| 708 | C this event. JOUT is the total hard scat for |
| 709 | C (JP,JT) up to now. |
| 710 | IF(JFLG.EQ.0) GO TO 160 |
| 711 | IF(JFLG.LT.0) THEN |
| 712 | IF(IHPR2(10).NE.0) WRITE(6,*) 'error occured in HIJHRD' |
| 713 | GO TO 50 |
| 714 | ENDIF |
| 715 | JOUT=JOUT+1 |
| 716 | IF(ABS(HINT1(46)).GT.HIPR1(11).AND.JFLG.EQ.2) NFP(JP,7)=1 |
| 717 | IF(ABS(HINT1(56)).GT.HIPR1(11).AND.JFLG.EQ.2) NFT(JT,7)=1 |
| 718 | IF(MAX(ABS(HINT1(46)),ABS(HINT1(56))).GT.HIPR1(11).AND. |
| 719 | & JFLG.GE.3) IASG(NSG,3)=1 |
| 720 | C ******** jet with PT>HIPR1(11) will be quenched |
| 721 | 150 CONTINUE |
| 722 | 160 CONTINUE |
| 723 | |
| 724 | CALL HIJSFT(JP,JT,JOUT,IERROR) |
| 725 | IF(IERROR.NE.0) THEN |
| 726 | IF(IHPR2(10).NE.0) WRITE(6,*) 'error occured in HIJSFT' |
| 727 | GO TO 50 |
| 728 | ENDIF |
| 729 | C |
| 730 | C ********conduct soft scattering between JP and JT |
| 731 | JATT=JATT+JOUT |
| 732 | 200 CONTINUE |
| 733 | c |
| 734 | c************************** |
| 735 | c |
| 736 | clin-6/2009 write out initial minijet information: |
| 737 | call minijet_out(BB) |
| 738 | if(pttrig.gt.0.and.ntrig.eq.0) goto 50 |
| 739 | clin-6/2009 write out initial transverse positions of initial nucleons: |
| 740 | c write(94,*) IAEVT,MISS,IHNT2(1),IHNT2(3) |
| 741 | DO 201 JP=1,IHNT2(1) |
| 742 | clin-6/2009: |
| 743 | c write(94,203) YP(1,JP)+0.5*BB, YP(2,JP), JP, NFP(JP,5) |
| 744 | IF(NFP(JP,5).GT.2) THEN |
| 745 | NINP=NINP+1 |
| 746 | ELSE IF(NFP(JP,5).EQ.2.OR.NFP(JP,5).EQ.1) THEN |
| 747 | NELP=NELP+1 |
| 748 | ENDIF |
| 749 | 201 continue |
| 750 | DO 202 JT=1,IHNT2(3) |
| 751 | clin-6/2009 target nucleon # has a minus sign for distinction from projectile: |
| 752 | c write(94,203) YT(1,JT)-0.5*BB, YT(2,JT), -JT, NFT(JT,5) |
| 753 | IF(NFT(JT,5).GT.2) THEN |
| 754 | NINTHJ=NINTHJ+1 |
| 755 | ELSE IF(NFT(JT,5).EQ.2.OR.NFT(JT,5).EQ.1) THEN |
| 756 | NELT=NELT+1 |
| 757 | ENDIF |
| 758 | 202 continue |
| 759 | 203 format(f10.3,1x,f10.3,2(1x,I5)) |
| 760 | c |
| 761 | c******************************* |
| 762 | |
| 763 | |
| 764 | C********perform jet quenching for jets with PT>HIPR1(11)********** |
| 765 | |
| 766 | IF((IHPR2(8).NE.0.OR.IHPR2(3).NE.0).AND.IHPR2(4).GT.0.AND. |
| 767 | & IHNT2(1).GT.1.AND.IHNT2(3).GT.1) THEN |
| 768 | DO 271 I=1,IHNT2(1) |
| 769 | IF(NFP(I,7).EQ.1) CALL QUENCH(I,1) |
| 770 | 271 CONTINUE |
| 771 | DO 272 I=1,IHNT2(3) |
| 772 | IF(NFT(I,7).EQ.1) CALL QUENCH(I,2) |
| 773 | 272 CONTINUE |
| 774 | DO 273 ISG=1,NSG |
| 775 | IF(IASG(ISG,3).EQ.1) CALL QUENCH(ISG,3) |
| 776 | 273 CONTINUE |
| 777 | ENDIF |
| 778 | |
| 779 | clin*****4/09/01-soft1, default way of treating strings: |
| 780 | if(isoft.eq.1) then |
| 781 | clin-4/16/01 allow fragmentation: |
| 782 | isflag=1 |
| 783 | |
| 784 | cbz1/25/99 |
| 785 | c.....transfer data from HIJING to ZPC |
| 786 | NSP = IHNT2(1) |
| 787 | NST = IHNT2(3) |
| 788 | NSI = NSG |
| 789 | ISTR = 0 |
| 790 | NPAR = 0 |
| 791 | DO 1008 I = 1, IHNT2(1) |
| 792 | ISTR = ISTR + 1 |
| 793 | DO 1007 J = 1, NPJ(I) |
| 794 | cbz1/27/99 |
| 795 | c.....for now only consider gluon cascade |
| 796 | IF (KFPJ(I, J) .EQ. 21) THEN |
| 797 | cbz1/27/99end |
| 798 | |
| 799 | NPAR = NPAR + 1 |
| 800 | LSTRG0(NPAR) = ISTR |
| 801 | LPART0(NPAR) = J |
| 802 | ITYP0(NPAR) = KFPJ(I, J) |
| 803 | cbz6/28/99 flow1 |
| 804 | clin-7/20/01 add dble or sngl to make precisions consistent |
| 805 | c GX0(NPAR) = YP(1, I) |
| 806 | GX0(NPAR) = dble(YP(1, I) + 0.5 * BB) |
| 807 | cbz6/28/99 flow1 end |
| 808 | GY0(NPAR) = dble(YP(2, I)) |
| 809 | GZ0(NPAR) = 0d0 |
| 810 | FT0(NPAR) = 0d0 |
| 811 | PX0(NPAR) = dble(PJPX(I, J)) |
| 812 | PY0(NPAR) = dble(PJPY(I, J)) |
| 813 | PZ0(NPAR) = dble(PJPZ(I, J)) |
| 814 | XMASS0(NPAR) = dble(PJPM(I, J)) |
| 815 | c E0(NPAR) = dble(PJPE(I, J)) |
| 816 | E0(NPAR) = dsqrt(PX0(NPAR)**2+PY0(NPAR)**2 |
| 817 | 1 +PZ0(NPAR)**2+XMASS0(NPAR)**2) |
| 818 | clin-7/20/01-end |
| 819 | |
| 820 | cbz1/27/99 |
| 821 | c.....end gluon selection |
| 822 | END IF |
| 823 | cbz1/27/99end |
| 824 | 1007 CONTINUE |
| 825 | 1008 CONTINUE |
| 826 | DO 1010 I = 1, IHNT2(3) |
| 827 | ISTR = ISTR + 1 |
| 828 | DO 1009 J = 1, NTJ(I) |
| 829 | cbz1/27/99 |
| 830 | c.....for now only consider gluon cascade |
| 831 | IF (KFTJ(I, J) .EQ. 21) THEN |
| 832 | cbz1/27/99end |
| 833 | NPAR = NPAR + 1 |
| 834 | LSTRG0(NPAR) = ISTR |
| 835 | LPART0(NPAR) = J |
| 836 | ITYP0(NPAR) = KFTJ(I, J) |
| 837 | cbz6/28/99 flow1 |
| 838 | clin-7/20/01 add dble or sngl to make precisions consistent |
| 839 | c GX0(NPAR) = YT(1, I) |
| 840 | GX0(NPAR) = dble(YT(1, I) - 0.5 * BB) |
| 841 | cbz6/28/99 flow1 end |
| 842 | GY0(NPAR) = dble(YT(2, I)) |
| 843 | GZ0(NPAR) = 0d0 |
| 844 | FT0(NPAR) = 0d0 |
| 845 | PX0(NPAR) = dble(PJTX(I, J)) |
| 846 | PY0(NPAR) = dble(PJTY(I, J)) |
| 847 | PZ0(NPAR) = dble(PJTZ(I, J)) |
| 848 | XMASS0(NPAR) = dble(PJTM(I, J)) |
| 849 | c E0(NPAR) = dble(PJTE(I, J)) |
| 850 | E0(NPAR) = dsqrt(PX0(NPAR)**2+PY0(NPAR)**2 |
| 851 | 1 +PZ0(NPAR)**2+XMASS0(NPAR)**2) |
| 852 | |
| 853 | cbz1/27/99 |
| 854 | c.....end gluon selection |
| 855 | END IF |
| 856 | cbz1/27/99end |
| 857 | 1009 CONTINUE |
| 858 | 1010 CONTINUE |
| 859 | DO 1012 I = 1, NSG |
| 860 | ISTR = ISTR + 1 |
| 861 | DO 1011 J = 1, NJSG(I) |
| 862 | cbz1/27/99 |
| 863 | c.....for now only consider gluon cascade |
| 864 | IF (K2SG(I, J) .EQ. 21) THEN |
| 865 | cbz1/27/99end |
| 866 | NPAR = NPAR + 1 |
| 867 | LSTRG0(NPAR) = ISTR |
| 868 | LPART0(NPAR) = J |
| 869 | ITYP0(NPAR) = K2SG(I, J) |
| 870 | clin-7/20/01 add dble or sngl to make precisions consistent: |
| 871 | GX0(NPAR) = 0.5d0 * |
| 872 | 1 dble(YP(1, IASG(I, 1)) + YT(1, IASG(I, 2))) |
| 873 | GY0(NPAR) = 0.5d0 * |
| 874 | 2 dble(YP(2, IASG(I, 1)) + YT(2, IASG(I, 2))) |
| 875 | GZ0(NPAR) = 0d0 |
| 876 | FT0(NPAR) = 0d0 |
| 877 | PX0(NPAR) = dble(PXSG(I, J)) |
| 878 | PY0(NPAR) = dble(PYSG(I, J)) |
| 879 | PZ0(NPAR) = dble(PZSG(I, J)) |
| 880 | XMASS0(NPAR) = dble(PMSG(I, J)) |
| 881 | c E0(NPAR) = dble(PESG(I, J)) |
| 882 | E0(NPAR) = dsqrt(PX0(NPAR)**2+PY0(NPAR)**2 |
| 883 | 1 +PZ0(NPAR)**2+XMASS0(NPAR)**2) |
| 884 | cbz1/27/99 |
| 885 | c.....end gluon selection |
| 886 | END IF |
| 887 | cbz1/27/99end |
| 888 | 1011 CONTINUE |
| 889 | 1012 CONTINUE |
| 890 | MUL = NPAR |
| 891 | |
| 892 | cbz2/4/99 |
| 893 | CALL HJANA1 |
| 894 | cbz2/4/99end |
| 895 | |
| 896 | clin-6/2009: |
| 897 | if(ioscar.eq.3) WRITE (95, *) IAEVT, mul |
| 898 | c.....call ZPC for parton cascade |
| 899 | CALL ZPCMN |
| 900 | |
| 901 | c write out parton and wounded nucleon information to ana/zpc1.mom: |
| 902 | clin-6/2009: |
| 903 | c WRITE (14, 395) ITEST, MUL, bimp, NELP,NINP,NELT,NINTHJ |
| 904 | c WRITE (14, 395) IAEVT, MISS, MUL, bimp, NELP,NINP,NELT,NINTHJ |
| 905 | DO 1013 I = 1, MUL |
| 906 | cc WRITE (14, 411) PX5(I), PY5(I), PZ5(I), ITYP5(I), |
| 907 | c & XMASS5(I), E5(I) |
| 908 | if(dmax1(abs(GX5(I)),abs(GY5(I)),abs(GZ5(I)),abs(FT5(I))) |
| 909 | 1 .lt.9999) then |
| 910 | c write(14,210) ITYP5(I), PX5(I), PY5(I), PZ5(I), XMASS5(I), |
| 911 | c 1 GX5(I), GY5(I), GZ5(I), FT5(I) |
| 912 | else |
| 913 | c change format for large numbers: |
| 914 | c write(14,211) ITYP5(I), PX5(I), PY5(I), PZ5(I), XMASS5(I), |
| 915 | c 1 GX5(I), GY5(I), GZ5(I), FT5(I) |
| 916 | endif |
| 917 | |
| 918 | 1013 CONTINUE |
| 919 | 210 format(I6,2(1x,f8.3),1x,f10.3,1x,f6.3,4(1x,f8.2)) |
| 920 | 211 format(I6,2(1x,f8.3),1x,f10.3,1x,f6.3,4(1x,e8.2)) |
| 921 | 395 format(3I8,f10.4,4I5) |
| 922 | |
| 923 | clin-4/09/01: |
| 924 | itest=itest+1 |
| 925 | c 411 FORMAT(1X, 3F10.3, I6, 2F10.3) |
| 926 | cbz3/19/99 end |
| 927 | |
| 928 | clin-5/2009 ctest off: |
| 929 | c call frztm(1,1) |
| 930 | |
| 931 | c.....transfer data back from ZPC to HIJING |
| 932 | DO 1014 I = 1, MUL |
| 933 | IF (LSTRG1(I) .LE. NSP) THEN |
| 934 | NSTRG = LSTRG1(I) |
| 935 | NPART = LPART1(I) |
| 936 | KFPJ(NSTRG, NPART) = ITYP5(I) |
| 937 | clin-7/20/01 add dble or sngl to make precisions consistent |
| 938 | PJPX(NSTRG, NPART) = sngl(PX5(I)) |
| 939 | PJPY(NSTRG, NPART) = sngl(PY5(I)) |
| 940 | PJPZ(NSTRG, NPART) = sngl(PZ5(I)) |
| 941 | PJPE(NSTRG, NPART) = sngl(E5(I)) |
| 942 | PJPM(NSTRG, NPART) = sngl(XMASS5(I)) |
| 943 | ELSE IF (LSTRG1(I) .LE. NSP + NST) THEN |
| 944 | NSTRG = LSTRG1(I) - NSP |
| 945 | NPART = LPART1(I) |
| 946 | KFTJ(NSTRG, NPART) = ITYP5(I) |
| 947 | PJTX(NSTRG, NPART) = sngl(PX5(I)) |
| 948 | PJTY(NSTRG, NPART) = sngl(PY5(I)) |
| 949 | PJTZ(NSTRG, NPART) = sngl(PZ5(I)) |
| 950 | PJTE(NSTRG, NPART) = sngl(E5(I)) |
| 951 | PJTM(NSTRG, NPART) = sngl(XMASS5(I)) |
| 952 | ELSE |
| 953 | NSTRG = LSTRG1(I) - NSP - NST |
| 954 | NPART = LPART1(I) |
| 955 | K2SG(NSTRG, NPART) = ITYP5(I) |
| 956 | PXSG(NSTRG, NPART) = sngl(PX5(I)) |
| 957 | PYSG(NSTRG, NPART) = sngl(PY5(I)) |
| 958 | PZSG(NSTRG, NPART) = sngl(PZ5(I)) |
| 959 | PESG(NSTRG, NPART) = sngl(E5(I)) |
| 960 | PMSG(NSTRG, NPART) = sngl(XMASS5(I)) |
| 961 | END IF |
| 962 | 1014 CONTINUE |
| 963 | cbz1/25/99end |
| 964 | |
| 965 | cbz2/4/99 |
| 966 | CALL HJANA2 |
| 967 | cbz2/4/99end |
| 968 | |
| 969 | clin*****4/09/01-soft2, put q+dq+X in strings into ZPC: |
| 970 | elseif(isoft.eq.2) then |
| 971 | NSP = IHNT2(1) |
| 972 | NST = IHNT2(3) |
| 973 | clin-4/27/01: |
| 974 | NSI = NSG |
| 975 | NPAR=0 |
| 976 | ISTR=0 |
| 977 | C |
| 978 | clin No fragmentation to hadrons, only on parton level, |
| 979 | c and transfer minijet and string data from HIJING to ZPC: |
| 980 | MSTJ(1)=0 |
| 981 | clin-4/12/01 forbid soft radiation before ZPC to avoid small-mass strings, |
| 982 | c and forbid jet order reversal before ZPC to avoid unphysical flavors: |
| 983 | IHPR2(1)=0 |
| 984 | isflag=0 |
| 985 | |
| 986 | IF(IHPR2(20).NE.0) THEN |
| 987 | DO 320 NTP=1,2 |
| 988 | DO 310 jjtp=1,IHNT2(2*NTP-1) |
| 989 | ISTR = ISTR + 1 |
| 990 | c change: do gluon kink only once: either here or in fragmentation. |
| 991 | CALL HIJFRG(jjtp,NTP,IERROR) |
| 992 | c call lulist(1) |
| 993 | if(NTP.eq.1) then |
| 994 | c 354 continue |
| 995 | NPJ(jjtp)=MAX0(N-2,0) |
| 996 | |
| 997 | clin-4/12/01: NPJ(jjtp)=MAX0(ipartn-2,0) |
| 998 | else |
| 999 | c 355 continue |
| 1000 | NTJ(jjtp)=MAX0(N-2,0) |
| 1001 | clin-4/12/01: NTJ(jjtp)=MAX0(ipartn-2,0) |
| 1002 | endif |
| 1003 | |
| 1004 | do 300 ii=1,N |
| 1005 | NPAR = NPAR + 1 |
| 1006 | LSTRG0(NPAR) = ISTR |
| 1007 | LPART0(NPAR) = II |
| 1008 | ITYP0(NPAR) = K(II,2) |
| 1009 | GZ0(NPAR) = 0d0 |
| 1010 | FT0(NPAR) = 0d0 |
| 1011 | clin-7/20/01 add dble or sngl to make precisions consistent |
| 1012 | PX0(NPAR) = dble(P(II,1)) |
| 1013 | PY0(NPAR) = dble(P(II,2)) |
| 1014 | PZ0(NPAR) = dble(P(II,3)) |
| 1015 | XMASS0(NPAR) = dble(P(II,5)) |
| 1016 | c E0(NPAR) = dble(P(II,4)) |
| 1017 | E0(NPAR) = dsqrt(PX0(NPAR)**2+PY0(NPAR)**2 |
| 1018 | 1 +PZ0(NPAR)**2+XMASS0(NPAR)**2) |
| 1019 | IF (NTP .EQ. 1) THEN |
| 1020 | clin-7/20/01 add dble or sngl to make precisions consistent |
| 1021 | GX0(NPAR) = dble(YP(1, jjtp)+0.5 * BB) |
| 1022 | GY0(NPAR) = dble(YP(2, jjtp)) |
| 1023 | IITYP=ITYP0(NPAR) |
| 1024 | nstrg=LSTRG0(NPAR) |
| 1025 | if(IITYP.eq.2112.or.IITYP.eq.2212) then |
| 1026 | elseif((IITYP.eq.1.or.IITYP.eq.2).and. |
| 1027 | 1 (II.eq.1.or.II.eq.N)) then |
| 1028 | PP(nstrg,6)=sngl(PX0(NPAR)) |
| 1029 | PP(nstrg,7)=sngl(PY0(NPAR)) |
| 1030 | PP(nstrg,14)=sngl(XMASS0(NPAR)) |
| 1031 | elseif((IITYP.eq.1103.or.IITYP.eq.2101 |
| 1032 | 1 .or.IITYP.eq.2103.or.IITYP.eq.2203. |
| 1033 | 2 .or.IITYP.eq.3101.or.IITYP.eq.3103. |
| 1034 | 3 .or.IITYP.eq.3201.or.IITYP.eq.3203.or.IITYP.eq.3303) |
| 1035 | 4 .and.(II.eq.1.or.II.eq.N)) then |
| 1036 | PP(nstrg,8)=sngl(PX0(NPAR)) |
| 1037 | PP(nstrg,9)=sngl(PY0(NPAR)) |
| 1038 | PP(nstrg,15)=sngl(XMASS0(NPAR)) |
| 1039 | else |
| 1040 | NPART = LPART0(NPAR)-1 |
| 1041 | KFPJ(NSTRG, NPART) = ITYP0(NPAR) |
| 1042 | PJPX(NSTRG, NPART) = sngl(PX0(NPAR)) |
| 1043 | PJPY(NSTRG, NPART) = sngl(PY0(NPAR)) |
| 1044 | PJPZ(NSTRG, NPART) = sngl(PZ0(NPAR)) |
| 1045 | PJPE(NSTRG, NPART) = sngl(E0(NPAR)) |
| 1046 | PJPM(NSTRG, NPART) = sngl(XMASS0(NPAR)) |
| 1047 | endif |
| 1048 | ELSE |
| 1049 | GX0(NPAR) = dble(YT(1, jjtp)-0.5 * BB) |
| 1050 | GY0(NPAR) = dble(YT(2, jjtp)) |
| 1051 | IITYP=ITYP0(NPAR) |
| 1052 | nstrg=LSTRG0(NPAR)-NSP |
| 1053 | if(IITYP.eq.2112.or.IITYP.eq.2212) then |
| 1054 | elseif((IITYP.eq.1.or.IITYP.eq.2).and. |
| 1055 | 1 (II.eq.1.or.II.eq.N)) then |
| 1056 | PT(nstrg,6)=sngl(PX0(NPAR)) |
| 1057 | PT(nstrg,7)=sngl(PY0(NPAR)) |
| 1058 | PT(nstrg,14)=sngl(XMASS0(NPAR)) |
| 1059 | elseif((IITYP.eq.1103.or.IITYP.eq.2101 |
| 1060 | 1 .or.IITYP.eq.2103.or.IITYP.eq.2203. |
| 1061 | 2 .or.IITYP.eq.3101.or.IITYP.eq.3103. |
| 1062 | 3 .or.IITYP.eq.3201.or.IITYP.eq.3203.or.IITYP.eq.3303) |
| 1063 | 4 .and.(II.eq.1.or.II.eq.N)) then |
| 1064 | PT(nstrg,8)=sngl(PX0(NPAR)) |
| 1065 | PT(nstrg,9)=sngl(PY0(NPAR)) |
| 1066 | PT(nstrg,15)=sngl(XMASS0(NPAR)) |
| 1067 | else |
| 1068 | NPART = LPART0(NPAR)-1 |
| 1069 | KFTJ(NSTRG, NPART) = ITYP0(NPAR) |
| 1070 | PJTX(NSTRG, NPART) = sngl(PX0(NPAR)) |
| 1071 | PJTY(NSTRG, NPART) = sngl(PY0(NPAR)) |
| 1072 | PJTZ(NSTRG, NPART) = sngl(PZ0(NPAR)) |
| 1073 | PJTE(NSTRG, NPART) = sngl(E0(NPAR)) |
| 1074 | PJTM(NSTRG, NPART) = sngl(XMASS0(NPAR)) |
| 1075 | endif |
| 1076 | END IF |
| 1077 | 300 continue |
| 1078 | 310 continue |
| 1079 | 320 continue |
| 1080 | DO 330 ISG=1,NSG |
| 1081 | ISTR = ISTR + 1 |
| 1082 | CALL HIJFRG(ISG,3,IERROR) |
| 1083 | c call lulist(2) |
| 1084 | c |
| 1085 | NJSG(ISG)=N |
| 1086 | c |
| 1087 | do 1001 ii=1,N |
| 1088 | NPAR = NPAR + 1 |
| 1089 | LSTRG0(NPAR) = ISTR |
| 1090 | LPART0(NPAR) = II |
| 1091 | ITYP0(NPAR) = K(II,2) |
| 1092 | GX0(NPAR)=0.5d0* |
| 1093 | 1 dble(YP(1,IASG(ISG,1))+YT(1,IASG(ISG,2))) |
| 1094 | GY0(NPAR)=0.5d0* |
| 1095 | 2 dble(YP(2,IASG(ISG,1))+YT(2,IASG(ISG,2))) |
| 1096 | GZ0(NPAR) = 0d0 |
| 1097 | FT0(NPAR) = 0d0 |
| 1098 | PX0(NPAR) = dble(P(II,1)) |
| 1099 | PY0(NPAR) = dble(P(II,2)) |
| 1100 | PZ0(NPAR) = dble(P(II,3)) |
| 1101 | XMASS0(NPAR) = dble(P(II,5)) |
| 1102 | c E0(NPAR) = dble(P(II,4)) |
| 1103 | E0(NPAR) = dsqrt(PX0(NPAR)**2+PY0(NPAR)**2 |
| 1104 | 1 +PZ0(NPAR)**2+XMASS0(NPAR)**2) |
| 1105 | 1001 continue |
| 1106 | 330 continue |
| 1107 | endif |
| 1108 | |
| 1109 | MUL = NPAR |
| 1110 | cbz2/4/99 |
| 1111 | CALL HJANA1 |
| 1112 | cbz2/4/99end |
| 1113 | clin-6/2009: |
| 1114 | if(ioscar.eq.3) WRITE (95, *) IAEVT, mul |
| 1115 | c.....call ZPC for parton cascade |
| 1116 | CALL ZPCMN |
| 1117 | cbz3/19/99 |
| 1118 | clin-6/2009: |
| 1119 | c WRITE (14, 395) ITEST, MUL, bimp, NELP,NINP,NELT,NINTHJ |
| 1120 | WRITE (14, 395) IAEVT, MISS, MUL, bimp, NELP,NINP,NELT,NINTHJ |
| 1121 | itest=itest+1 |
| 1122 | |
| 1123 | DO 1015 I = 1, MUL |
| 1124 | c WRITE (14, 311) PX5(I), PY5(I), PZ5(I), ITYP5(I), |
| 1125 | c & XMASS5(I), E5(I) |
| 1126 | WRITE (14, 312) PX5(I), PY5(I), PZ5(I), ITYP5(I), |
| 1127 | & XMASS5(I), E5(I),LSTRG1(I), LPART1(I) |
| 1128 | 1015 CONTINUE |
| 1129 | c 311 FORMAT(1X, 3F10.4, I6, 2F10.4) |
| 1130 | 312 FORMAT(1X, 3F10.3, I6, 2F10.3,1X,I6,1X,I3) |
| 1131 | cbz3/19/99 end |
| 1132 | |
| 1133 | clin-5/2009 ctest off: |
| 1134 | c call frztm(1,1) |
| 1135 | |
| 1136 | clin-4/13/01 initialize four momenta and invariant mass of strings after ZPC: |
| 1137 | do 1004 nmom=1,5 |
| 1138 | do 1002 nstrg=1,nsp |
| 1139 | PP(nstrg,nmom)=0. |
| 1140 | 1002 continue |
| 1141 | do 1003 nstrg=1,nst |
| 1142 | PT(nstrg,nmom)=0. |
| 1143 | 1003 continue |
| 1144 | 1004 continue |
| 1145 | clin-4/13/01-end |
| 1146 | |
| 1147 | DO 1005 I = 1, MUL |
| 1148 | IITYP=ITYP5(I) |
| 1149 | IF (LSTRG1(I) .LE. NSP) THEN |
| 1150 | NSTRG = LSTRG1(I) |
| 1151 | c nucleons without interactions: |
| 1152 | if(IITYP.eq.2112.or.IITYP.eq.2212) then |
| 1153 | clin-7/20/01 add dble or sngl to make precisions consistent |
| 1154 | PP(nstrg,1)=sngl(PX5(I)) |
| 1155 | PP(nstrg,2)=sngl(PY5(I)) |
| 1156 | PP(nstrg,3)=sngl(PZ5(I)) |
| 1157 | PP(nstrg,4)=sngl(E5(I)) |
| 1158 | PP(nstrg,5)=sngl(XMASS5(I)) |
| 1159 | c valence quark: |
| 1160 | elseif((IITYP.eq.1.or.IITYP.eq.2).and. |
| 1161 | 1 (LPART1(I).eq.1.or.LPART1(I).eq.(NPJ(NSTRG)+2))) then |
| 1162 | PP(nstrg,6)=sngl(PX5(I)) |
| 1163 | PP(nstrg,7)=sngl(PY5(I)) |
| 1164 | PP(nstrg,14)=sngl(XMASS5(I)) |
| 1165 | PP(nstrg,1)=PP(nstrg,1)+sngl(PX5(I)) |
| 1166 | PP(nstrg,2)=PP(nstrg,2)+sngl(PY5(I)) |
| 1167 | PP(nstrg,3)=PP(nstrg,3)+sngl(PZ5(I)) |
| 1168 | PP(nstrg,4)=PP(nstrg,4)+sngl(E5(I)) |
| 1169 | PP(nstrg,5)=sqrt(PP(nstrg,4)**2-PP(nstrg,1)**2 |
| 1170 | 1 -PP(nstrg,2)**2-PP(nstrg,3)**2) |
| 1171 | c diquark: |
| 1172 | elseif((IITYP.eq.1103.or.IITYP.eq.2101 |
| 1173 | 1 .or.IITYP.eq.2103.or.IITYP.eq.2203. |
| 1174 | 2 .or.IITYP.eq.3101.or.IITYP.eq.3103. |
| 1175 | 3 .or.IITYP.eq.3201.or.IITYP.eq.3203.or.IITYP.eq.3303) |
| 1176 | 4 .and.(LPART1(I).eq.1.or.LPART1(I).eq.(NPJ(NSTRG)+2))) then |
| 1177 | PP(nstrg,8)=sngl(PX5(I)) |
| 1178 | PP(nstrg,9)=sngl(PY5(I)) |
| 1179 | PP(nstrg,15)=sngl(XMASS5(I)) |
| 1180 | PP(nstrg,1)=PP(nstrg,1)+sngl(PX5(I)) |
| 1181 | PP(nstrg,2)=PP(nstrg,2)+sngl(PY5(I)) |
| 1182 | PP(nstrg,3)=PP(nstrg,3)+sngl(PZ5(I)) |
| 1183 | PP(nstrg,4)=PP(nstrg,4)+sngl(E5(I)) |
| 1184 | PP(nstrg,5)=sqrt(PP(nstrg,4)**2-PP(nstrg,1)**2 |
| 1185 | 1 -PP(nstrg,2)**2-PP(nstrg,3)**2) |
| 1186 | c partons in projectile or target strings: |
| 1187 | else |
| 1188 | NPART = LPART1(I)-1 |
| 1189 | KFPJ(NSTRG, NPART) = ITYP5(I) |
| 1190 | PJPX(NSTRG, NPART) = sngl(PX5(I)) |
| 1191 | PJPY(NSTRG, NPART) = sngl(PY5(I)) |
| 1192 | PJPZ(NSTRG, NPART) = sngl(PZ5(I)) |
| 1193 | PJPE(NSTRG, NPART) = sngl(E5(I)) |
| 1194 | PJPM(NSTRG, NPART) = sngl(XMASS5(I)) |
| 1195 | endif |
| 1196 | ELSE IF (LSTRG1(I) .LE. NSP + NST) THEN |
| 1197 | NSTRG = LSTRG1(I) - NSP |
| 1198 | if(IITYP.eq.2112.or.IITYP.eq.2212) then |
| 1199 | PT(nstrg,1)=sngl(PX5(I)) |
| 1200 | PT(nstrg,2)=sngl(PY5(I)) |
| 1201 | PT(nstrg,3)=sngl(PZ5(I)) |
| 1202 | PT(nstrg,4)=sngl(E5(I)) |
| 1203 | PT(nstrg,5)=sngl(XMASS5(I)) |
| 1204 | elseif((IITYP.eq.1.or.IITYP.eq.2).and. |
| 1205 | 1 (LPART1(I).eq.1.or.LPART1(I).eq.(NTJ(NSTRG)+2))) then |
| 1206 | PT(nstrg,6)=sngl(PX5(I)) |
| 1207 | PT(nstrg,7)=sngl(PY5(I)) |
| 1208 | PT(nstrg,14)=sngl(XMASS5(I)) |
| 1209 | PT(nstrg,1)=PT(nstrg,1)+sngl(PX5(I)) |
| 1210 | PT(nstrg,2)=PT(nstrg,2)+sngl(PY5(I)) |
| 1211 | PT(nstrg,3)=PT(nstrg,3)+sngl(PZ5(I)) |
| 1212 | PT(nstrg,4)=PT(nstrg,4)+sngl(E5(I)) |
| 1213 | PT(nstrg,5)=sqrt(PT(nstrg,4)**2-PT(nstrg,1)**2 |
| 1214 | 1 -PT(nstrg,2)**2-PT(nstrg,3)**2) |
| 1215 | elseif((IITYP.eq.1103.or.IITYP.eq.2101 |
| 1216 | 1 .or.IITYP.eq.2103.or.IITYP.eq.2203. |
| 1217 | 2 .or.IITYP.eq.3101.or.IITYP.eq.3103. |
| 1218 | 3 .or.IITYP.eq.3201.or.IITYP.eq.3203.or.IITYP.eq.3303) |
| 1219 | 4 .and.(LPART1(I).eq.1.or.LPART1(I).eq.(NTJ(NSTRG)+2))) then |
| 1220 | PT(nstrg,8)=sngl(PX5(I)) |
| 1221 | PT(nstrg,9)=sngl(PY5(I)) |
| 1222 | PT(nstrg,15)=sngl(XMASS5(I)) |
| 1223 | PT(nstrg,1)=PT(nstrg,1)+sngl(PX5(I)) |
| 1224 | PT(nstrg,2)=PT(nstrg,2)+sngl(PY5(I)) |
| 1225 | PT(nstrg,3)=PT(nstrg,3)+sngl(PZ5(I)) |
| 1226 | PT(nstrg,4)=PT(nstrg,4)+sngl(E5(I)) |
| 1227 | PT(nstrg,5)=sqrt(PT(nstrg,4)**2-PT(nstrg,1)**2 |
| 1228 | 1 -PT(nstrg,2)**2-PT(nstrg,3)**2) |
| 1229 | else |
| 1230 | NPART = LPART1(I)-1 |
| 1231 | KFTJ(NSTRG, NPART) = ITYP5(I) |
| 1232 | PJTX(NSTRG, NPART) = sngl(PX5(I)) |
| 1233 | PJTY(NSTRG, NPART) = sngl(PY5(I)) |
| 1234 | PJTZ(NSTRG, NPART) = sngl(PZ5(I)) |
| 1235 | PJTE(NSTRG, NPART) = sngl(E5(I)) |
| 1236 | PJTM(NSTRG, NPART) = sngl(XMASS5(I)) |
| 1237 | endif |
| 1238 | ELSE |
| 1239 | NSTRG = LSTRG1(I) - NSP - NST |
| 1240 | NPART = LPART1(I) |
| 1241 | K2SG(NSTRG, NPART) = ITYP5(I) |
| 1242 | PXSG(NSTRG, NPART) = sngl(PX5(I)) |
| 1243 | PYSG(NSTRG, NPART) = sngl(PY5(I)) |
| 1244 | PZSG(NSTRG, NPART) = sngl(PZ5(I)) |
| 1245 | PESG(NSTRG, NPART) = sngl(E5(I)) |
| 1246 | PMSG(NSTRG, NPART) = sngl(XMASS5(I)) |
| 1247 | END IF |
| 1248 | 1005 CONTINUE |
| 1249 | cbz1/25/99end |
| 1250 | |
| 1251 | clin-4/09/01 turn on fragmentation with soft radiation |
| 1252 | c and jet order reversal to form hadrons after ZPC: |
| 1253 | MSTJ(1)=1 |
| 1254 | IHPR2(1)=1 |
| 1255 | isflag=1 |
| 1256 | clin-4/13/01 allow small mass strings (D=1.5GeV): |
| 1257 | HIPR1(1)=0.94 |
| 1258 | |
| 1259 | cbz2/4/99 |
| 1260 | CALL HJANA2 |
| 1261 | cbz2/4/99end |
| 1262 | |
| 1263 | clin-4/19/01-soft3, fragment strings, then convert hadrons to partons |
| 1264 | c and input to ZPC: |
| 1265 | elseif(isoft.eq.3.or.isoft.eq.4.or.isoft.eq.5) then |
| 1266 | clin-4/24/01 normal fragmentation first: |
| 1267 | isflag=0 |
| 1268 | |
| 1269 | IF(IHPR2(20).NE.0) THEN |
| 1270 | DO 560 ISG=1,NSG |
| 1271 | CALL HIJFRG(ISG,3,IERROR) |
| 1272 | C |
| 1273 | nsbst=1 |
| 1274 | IDSTR=92 |
| 1275 | IF(IHPR2(21).EQ.0) THEN |
| 1276 | CALL LUEDIT(2) |
| 1277 | ELSE |
| 1278 | 551 nsbst=nsbst+1 |
| 1279 | IF(K(nsbst,2).LT.91.OR.K(nsbst,2).GT.93) GO TO 551 |
| 1280 | IDSTR=K(nsbst,2) |
| 1281 | nsbst=nsbst+1 |
| 1282 | ENDIF |
| 1283 | |
| 1284 | IF(FRAME.EQ.'LAB') THEN |
| 1285 | CALL HBOOST |
| 1286 | ENDIF |
| 1287 | C ******** boost back to lab frame(if it was in) |
| 1288 | C |
| 1289 | nsbstR=0 |
| 1290 | DO 560 I=nsbst,N |
| 1291 | IF(K(I,2).EQ.IDSTR) THEN |
| 1292 | nsbstR=nsbstR+1 |
| 1293 | GO TO 560 |
| 1294 | ENDIF |
| 1295 | K(I,4)=nsbstR |
| 1296 | NATT=NATT+1 |
| 1297 | KATT(NATT,1)=K(I,2) |
| 1298 | KATT(NATT,2)=20 |
| 1299 | KATT(NATT,4)=K(I,1) |
| 1300 | c from Yasushi, to avoid violation of array limits: |
| 1301 | c IF(K(I,3).EQ.0 .OR. K(K(I,3),2).EQ.IDSTR) THEN |
| 1302 | clin-4/2008 to avoid out-of-bound error in K(): |
| 1303 | c IF(K(I,3).EQ.0 .OR. |
| 1304 | c 1 (K(I,3).ne.0.and.K(K(I,3),2).EQ.IDSTR)) THEN |
| 1305 | c KATT(NATT,3)=0 |
| 1306 | IF(K(I,3).EQ.0) THEN |
| 1307 | KATT(NATT,3)=0 |
| 1308 | ELSEIF(K(I,3).ne.0.and.K(K(I,3),2).EQ.IDSTR) THEN |
| 1309 | KATT(NATT,3)=0 |
| 1310 | clin-4/2008-end |
| 1311 | ELSE |
| 1312 | KATT(NATT,3)=NATT-I+K(I,3)+nsbstR-K(K(I,3),4) |
| 1313 | ENDIF |
| 1314 | |
| 1315 | C ****** identify the mother particle |
| 1316 | PATT(NATT,1)=P(I,1) |
| 1317 | PATT(NATT,2)=P(I,2) |
| 1318 | PATT(NATT,3)=P(I,3) |
| 1319 | PATT(NATT,4)=P(I,4) |
| 1320 | EATT=EATT+P(I,4) |
| 1321 | GXAR(NATT) = 0.5 * (YP(1, IASG(ISG, 1)) + |
| 1322 | & YT(1, IASG(ISG, 2))) |
| 1323 | GYAR(NATT) = 0.5 * (YP(2, IASG(ISG, 1)) + |
| 1324 | & YT(2, IASG(ISG, 2))) |
| 1325 | GZAR(NATT) = 0. |
| 1326 | FTAR(NATT) = 0. |
| 1327 | ITYPAR(NATT) = K(I, 2) |
| 1328 | PXAR(NATT) = P(I, 1) |
| 1329 | PYAR(NATT) = P(I, 2) |
| 1330 | PZAR(NATT) = P(I, 3) |
| 1331 | PEAR(NATT) = P(I, 4) |
| 1332 | XMAR(NATT) = P(I, 5) |
| 1333 | cbz11/11/98end |
| 1334 | |
| 1335 | 560 CONTINUE |
| 1336 | C ********Fragment the q-qbar jets systems ***** |
| 1337 | C |
| 1338 | JTP(1)=IHNT2(1) |
| 1339 | JTP(2)=IHNT2(3) |
| 1340 | DO 600 NTP=1,2 |
| 1341 | DO 600 jjtp=1,JTP(NTP) |
| 1342 | CALL HIJFRG(jjtp,NTP,IERROR) |
| 1343 | C |
| 1344 | nsbst=1 |
| 1345 | IDSTR=92 |
| 1346 | IF(IHPR2(21).EQ.0) THEN |
| 1347 | CALL LUEDIT(2) |
| 1348 | ELSE |
| 1349 | 581 nsbst=nsbst+1 |
| 1350 | IF(K(nsbst,2).LT.91.OR.K(nsbst,2).GT.93) GO TO 581 |
| 1351 | IDSTR=K(nsbst,2) |
| 1352 | nsbst=nsbst+1 |
| 1353 | ENDIF |
| 1354 | IF(FRAME.EQ.'LAB') THEN |
| 1355 | CALL HBOOST |
| 1356 | ENDIF |
| 1357 | C ******** boost back to lab frame(if it was in) |
| 1358 | C |
| 1359 | NFTP=NFP(jjtp,5) |
| 1360 | IF(NTP.EQ.2) NFTP=10+NFT(jjtp,5) |
| 1361 | nsbstR=0 |
| 1362 | DO 590 I=nsbst,N |
| 1363 | IF(K(I,2).EQ.IDSTR) THEN |
| 1364 | nsbstR=nsbstR+1 |
| 1365 | GO TO 590 |
| 1366 | ENDIF |
| 1367 | K(I,4)=nsbstR |
| 1368 | NATT=NATT+1 |
| 1369 | KATT(NATT,1)=K(I,2) |
| 1370 | KATT(NATT,2)=NFTP |
| 1371 | KATT(NATT,4)=K(I,1) |
| 1372 | c IF(K(I,3).EQ.0 .OR. K(K(I,3),2).EQ.IDSTR) THEN |
| 1373 | clin-4/2008 |
| 1374 | c IF(K(I,3).EQ.0 .OR. |
| 1375 | c 1 (K(I,3).ne.0.and.K(K(I,3),2).EQ.IDSTR)) THEN |
| 1376 | c KATT(NATT,3)=0 |
| 1377 | IF(K(I,3).EQ.0) THEN |
| 1378 | KATT(NATT,3)=0 |
| 1379 | ELSEIF(K(I,3).ne.0.and.K(K(I,3),2).EQ.IDSTR) THEN |
| 1380 | KATT(NATT,3)=0 |
| 1381 | clin-4/2008-end |
| 1382 | ELSE |
| 1383 | KATT(NATT,3)=NATT-I+K(I,3)+nsbstR-K(K(I,3),4) |
| 1384 | ENDIF |
| 1385 | |
| 1386 | C ****** identify the mother particle |
| 1387 | PATT(NATT,1)=P(I,1) |
| 1388 | PATT(NATT,2)=P(I,2) |
| 1389 | PATT(NATT,3)=P(I,3) |
| 1390 | PATT(NATT,4)=P(I,4) |
| 1391 | EATT=EATT+P(I,4) |
| 1392 | IF (NTP .EQ. 1) THEN |
| 1393 | GXAR(NATT) = YP(1, jjtp)+0.5 * BB |
| 1394 | GYAR(NATT) = YP(2, jjtp) |
| 1395 | ELSE |
| 1396 | GXAR(NATT) = YT(1, jjtp)-0.5 * BB |
| 1397 | GYAR(NATT) = YT(2, jjtp) |
| 1398 | END IF |
| 1399 | GZAR(NATT) = 0. |
| 1400 | FTAR(NATT) = 0. |
| 1401 | ITYPAR(NATT) = K(I, 2) |
| 1402 | PXAR(NATT) = P(I, 1) |
| 1403 | PYAR(NATT) = P(I, 2) |
| 1404 | PZAR(NATT) = P(I, 3) |
| 1405 | PEAR(NATT) = P(I, 4) |
| 1406 | XMAR(NATT) = P(I, 5) |
| 1407 | cbz11/11/98end |
| 1408 | |
| 1409 | 590 CONTINUE |
| 1410 | 600 CONTINUE |
| 1411 | C ********Fragment the q-qq related string systems |
| 1412 | ENDIF |
| 1413 | clin-4/2008 check for zero NDR value: |
| 1414 | if(NDR.ge.1) then |
| 1415 | c |
| 1416 | DO 650 I=1,NDR |
| 1417 | NATT=NATT+1 |
| 1418 | KATT(NATT,1)=KFDR(I) |
| 1419 | KATT(NATT,2)=40 |
| 1420 | KATT(NATT,3)=0 |
| 1421 | PATT(NATT,1)=PDR(I,1) |
| 1422 | PATT(NATT,2)=PDR(I,2) |
| 1423 | PATT(NATT,3)=PDR(I,3) |
| 1424 | PATT(NATT,4)=PDR(I,4) |
| 1425 | EATT=EATT+PDR(I,4) |
| 1426 | clin-11/11/03 set direct photons positions and time at formation: |
| 1427 | GXAR(NATT) = rtdr(I,1) |
| 1428 | GYAR(NATT) = rtdr(I,2) |
| 1429 | GZAR(NATT) = 0. |
| 1430 | FTAR(NATT) = 0. |
| 1431 | ITYPAR(NATT) =KATT(NATT,1) |
| 1432 | PXAR(NATT) = PATT(NATT,1) |
| 1433 | PYAR(NATT) = PATT(NATT,2) |
| 1434 | PZAR(NATT) = PATT(NATT,3) |
| 1435 | PEAR(NATT) = PATT(NATT,4) |
| 1436 | XMAR(NATT) = PDR(I,5) |
| 1437 | 650 CONTINUE |
| 1438 | clin-4/2008: |
| 1439 | endif |
| 1440 | clin-6/2009 ctest on: |
| 1441 | call embedHighPt |
| 1442 | c |
| 1443 | CALL HJANA1 |
| 1444 | |
| 1445 | clin-4/19/01 convert hadrons to partons for ZPC (with GX0 given): |
| 1446 | call htop |
| 1447 | |
| 1448 | clin-7/03/01 move up, used in zpstrg (otherwise not set and incorrect): |
| 1449 | nsp=0 |
| 1450 | nst=0 |
| 1451 | nsg=natt |
| 1452 | NSI=NSG |
| 1453 | clin-7/03/01-end |
| 1454 | |
| 1455 | clin-6/2009: |
| 1456 | if(ioscar.eq.3) WRITE (95, *) IAEVT, mul |
| 1457 | c.....call ZPC for parton cascade |
| 1458 | CALL ZPCMN |
| 1459 | clin-6/2009: |
| 1460 | c WRITE (14, 395) ITEST, MUL, bimp, NELP,NINP,NELT,NINTHJ |
| 1461 | WRITE (14, 395) IAEVT, MISS, MUL, bimp, NELP,NINP,NELT,NINTHJ |
| 1462 | itest=itest+1 |
| 1463 | |
| 1464 | DO 1016 I = 1, MUL |
| 1465 | c WRITE (14, 511) PX5(I), PY5(I), PZ5(I), ITYP5(I), |
| 1466 | c & XMASS5(I), E5(I) |
| 1467 | WRITE (14, 512) ITYP5(I), PX5(I), PY5(I), PZ5(I), |
| 1468 | & XMASS5(I), LSTRG1(I), LPART1(I), FT5(I) |
| 1469 | |
| 1470 | 1016 CONTINUE |
| 1471 | c 511 FORMAT(1X, 3F10.4, I6, 2F10.4) |
| 1472 | 512 FORMAT(I6,4(1X,F10.3),1X,I6,1X,I3,1X,F10.3) |
| 1473 | c 513 FORMAT(1X, 4F10.4) |
| 1474 | |
| 1475 | clin-5/2009 ctest off: |
| 1476 | c call frztm(1,1) |
| 1477 | |
| 1478 | clin save data after ZPC for fragmentation purpose: |
| 1479 | c.....transfer data back from ZPC to HIJING |
| 1480 | DO 1018 I = 1, MAXSTR |
| 1481 | DO 1017 J = 1, 3 |
| 1482 | K1SGS(I, J) = 0 |
| 1483 | K2SGS(I, J) = 0 |
| 1484 | PXSGS(I, J) = 0d0 |
| 1485 | PYSGS(I, J) = 0d0 |
| 1486 | PZSGS(I, J) = 0d0 |
| 1487 | PESGS(I, J) = 0d0 |
| 1488 | PMSGS(I, J) = 0d0 |
| 1489 | GXSGS(I, J) = 0d0 |
| 1490 | GYSGS(I, J) = 0d0 |
| 1491 | GZSGS(I, J) = 0d0 |
| 1492 | FTSGS(I, J) = 0d0 |
| 1493 | 1017 CONTINUE |
| 1494 | 1018 CONTINUE |
| 1495 | DO 1019 I = 1, MUL |
| 1496 | IITYP=ITYP5(I) |
| 1497 | NSTRG = LSTRG1(I) |
| 1498 | NPART = LPART1(I) |
| 1499 | K2SGS(NSTRG, NPART) = ITYP5(I) |
| 1500 | PXSGS(NSTRG, NPART) = PX5(I) |
| 1501 | PYSGS(NSTRG, NPART) = PY5(I) |
| 1502 | PZSGS(NSTRG, NPART) = PZ5(I) |
| 1503 | PMSGS(NSTRG, NPART) = XMASS5(I) |
| 1504 | clin-7/20/01 E5(I) does no include the finite parton mass XMASS5(I), |
| 1505 | c so define it anew: |
| 1506 | c PESGS(NSTRG, NPART) = E5(I) |
| 1507 | c if(abs(PZ5(i)/E5(i)).gt.0.9999999d0) |
| 1508 | c 1 write(91,*) 'a',PX5(i),PY5(i),XMASS5(i),PZ5(i),E5(i) |
| 1509 | E5(I)=dsqrt(PX5(I)**2+PY5(I)**2+PZ5(I)**2+XMASS5(I)**2) |
| 1510 | PESGS(NSTRG, NPART) = E5(I) |
| 1511 | c if(abs(PZ5(i)/E5(i)).gt.0.9999999d0) |
| 1512 | c 1 write(91,*) 'b: new E5(I)=',E5(i) |
| 1513 | clin-7/20/01-end |
| 1514 | GXSGS(NSTRG, NPART) = GX5(I) |
| 1515 | GYSGS(NSTRG, NPART) = GY5(I) |
| 1516 | GZSGS(NSTRG, NPART) = GZ5(I) |
| 1517 | FTSGS(NSTRG, NPART) = FT5(I) |
| 1518 | 1019 CONTINUE |
| 1519 | CALL HJANA2 |
| 1520 | |
| 1521 | clin-4/19/01-end |
| 1522 | |
| 1523 | endif |
| 1524 | clin-4/09/01-end |
| 1525 | |
| 1526 | C |
| 1527 | C**************fragment all the string systems in the following***** |
| 1528 | C |
| 1529 | C********nsbst is where particle information starts |
| 1530 | C********nsbstR+1 is the number of strings in fragmentation |
| 1531 | C********the number of strings before a line is stored in K(I,4) |
| 1532 | C********IDSTR is id number of the string system (91,92 or 93) |
| 1533 | C |
| 1534 | clin-4/30/01 convert partons to hadrons after ZPC: |
| 1535 | if(isoft.eq.3.or.isoft.eq.4.or.isoft.eq.5) then |
| 1536 | NATT=0 |
| 1537 | EATT=0. |
| 1538 | call ptoh |
| 1539 | do 1006 I=1,nnozpc |
| 1540 | NATT=NATT+1 |
| 1541 | KATT(NATT,1)=ITYPN(I) |
| 1542 | PATT(NATT,1)=PXN(I) |
| 1543 | PATT(NATT,2)=PYN(I) |
| 1544 | PATT(NATT,3)=PZN(I) |
| 1545 | PATT(NATT,4)=EEN(I) |
| 1546 | EATT=EATT+EEN(I) |
| 1547 | GXAR(NATT)=GXN(I) |
| 1548 | GYAR(NATT)=GYN(I) |
| 1549 | GZAR(NATT)=GZN(I) |
| 1550 | FTAR(NATT)=FTN(I) |
| 1551 | ITYPAR(NATT)=ITYPN(I) |
| 1552 | PXAR(NATT)=PXN(I) |
| 1553 | PYAR(NATT)=PYN(I) |
| 1554 | PZAR(NATT)=PZN(I) |
| 1555 | PEAR(NATT)=EEN(I) |
| 1556 | XMAR(NATT)=XMN(I) |
| 1557 | 1006 continue |
| 1558 | goto 565 |
| 1559 | endif |
| 1560 | clin-4/30/01-end |
| 1561 | IF(IHPR2(20).NE.0) THEN |
| 1562 | DO 360 ISG=1,NSG |
| 1563 | CALL HIJFRG(ISG,3,IERROR) |
| 1564 | IF(MSTU(24).NE.0 .OR.IERROR.GT.0) THEN |
| 1565 | MSTU(24)=0 |
| 1566 | MSTU(28)=0 |
| 1567 | IF(IHPR2(10).NE.0) THEN |
| 1568 | c call lulist(2) |
| 1569 | WRITE(6,*) 'error occured ISG, repeat the event' |
| 1570 | write(6,*) ISG |
| 1571 | |
| 1572 | ENDIF |
| 1573 | GO TO 50 |
| 1574 | ENDIF |
| 1575 | C ********Check errors |
| 1576 | C |
| 1577 | nsbst=1 |
| 1578 | IDSTR=92 |
| 1579 | IF(IHPR2(21).EQ.0) THEN |
| 1580 | CALL LUEDIT(2) |
| 1581 | ELSE |
| 1582 | 351 nsbst=nsbst+1 |
| 1583 | IF(K(nsbst,2).LT.91.OR.K(nsbst,2).GT.93) GO TO 351 |
| 1584 | IDSTR=K(nsbst,2) |
| 1585 | nsbst=nsbst+1 |
| 1586 | ENDIF |
| 1587 | C |
| 1588 | IF(FRAME.EQ.'LAB') THEN |
| 1589 | CALL HBOOST |
| 1590 | ENDIF |
| 1591 | C ******** boost back to lab frame(if it was in) |
| 1592 | C |
| 1593 | nsbstR=0 |
| 1594 | DO 360 I=nsbst,N |
| 1595 | IF(K(I,2).EQ.IDSTR) THEN |
| 1596 | nsbstR=nsbstR+1 |
| 1597 | GO TO 360 |
| 1598 | ENDIF |
| 1599 | K(I,4)=nsbstR |
| 1600 | NATT=NATT+1 |
| 1601 | KATT(NATT,1)=K(I,2) |
| 1602 | KATT(NATT,2)=20 |
| 1603 | KATT(NATT,4)=K(I,1) |
| 1604 | c IF(K(I,3).EQ.0 .OR. K(K(I,3),2).EQ.IDSTR) THEN |
| 1605 | clin-4/2008: |
| 1606 | c IF(K(I,3).EQ.0 .OR. |
| 1607 | c 1 (K(I,3).ne.0.and.K(K(I,3),2).EQ.IDSTR)) THEN |
| 1608 | c KATT(NATT,3)=0 |
| 1609 | IF(K(I,3).EQ.0) THEN |
| 1610 | KATT(NATT,3)=0 |
| 1611 | ELSEIF(K(I,3).ne.0.and.K(K(I,3),2).EQ.IDSTR) THEN |
| 1612 | KATT(NATT,3)=0 |
| 1613 | clin-4/2008-end |
| 1614 | ELSE |
| 1615 | KATT(NATT,3)=NATT-I+K(I,3)+nsbstR-K(K(I,3),4) |
| 1616 | ENDIF |
| 1617 | |
| 1618 | C ****** identify the mother particle |
| 1619 | PATT(NATT,1)=P(I,1) |
| 1620 | PATT(NATT,2)=P(I,2) |
| 1621 | PATT(NATT,3)=P(I,3) |
| 1622 | PATT(NATT,4)=P(I,4) |
| 1623 | EATT=EATT+P(I,4) |
| 1624 | |
| 1625 | cbz11/11/98 |
| 1626 | cbz1/25/99 |
| 1627 | c GXAR(NATT) = 0.5 * (YP(1, IASG(ISG, 1)) + |
| 1628 | c & YT(1, IASG(ISG, 2))) |
| 1629 | c GYAR(NATT) = 0.5 * (YP(2, IASG(ISG, 1)) + |
| 1630 | c & YT(2, IASG(ISG, 2))) |
| 1631 | LSG = NSP + NST + ISG |
| 1632 | GXAR(NATT) = sngl(ZT1(LSG)) |
| 1633 | GYAR(NATT) = sngl(ZT2(LSG)) |
| 1634 | GZAR(NATT) = sngl(ZT3(LSG)) |
| 1635 | FTAR(NATT) = sngl(ATAUI(LSG)) |
| 1636 | cbz1/25/99end |
| 1637 | ITYPAR(NATT) = K(I, 2) |
| 1638 | PXAR(NATT) = P(I, 1) |
| 1639 | PYAR(NATT) = P(I, 2) |
| 1640 | PZAR(NATT) = P(I, 3) |
| 1641 | PEAR(NATT) = P(I, 4) |
| 1642 | XMAR(NATT) = P(I, 5) |
| 1643 | cbz11/11/98end |
| 1644 | |
| 1645 | 360 CONTINUE |
| 1646 | C ********Fragment the q-qbar jets systems ***** |
| 1647 | C |
| 1648 | JTP(1)=IHNT2(1) |
| 1649 | JTP(2)=IHNT2(3) |
| 1650 | DO 400 NTP=1,2 |
| 1651 | DO 400 jjtp=1,JTP(NTP) |
| 1652 | CALL HIJFRG(jjtp,NTP,IERROR) |
| 1653 | IF(MSTU(24).NE.0 .OR. IERROR.GT.0) THEN |
| 1654 | MSTU(24)=0 |
| 1655 | MSTU(28)=0 |
| 1656 | IF(IHPR2(10).NE.0) THEN |
| 1657 | c call lulist(2) |
| 1658 | WRITE(6,*) 'error occured P&T, repeat the event' |
| 1659 | WRITE(6,*) NTP,jjtp |
| 1660 | clin-6/2009 when this happens, the event will be repeated, |
| 1661 | c and another record for the same event number will be written into |
| 1662 | c zpc.dat, zpc.res, minijet-initial-beforePropagation.dat, |
| 1663 | c parton-initial-afterPropagation.dat, parton-after-coalescence.dat, |
| 1664 | c and parton-collisionsHistory.dat. |
| 1665 | ENDIF |
| 1666 | GO TO 50 |
| 1667 | ENDIF |
| 1668 | C ********check errors |
| 1669 | C |
| 1670 | nsbst=1 |
| 1671 | IDSTR=92 |
| 1672 | IF(IHPR2(21).EQ.0) THEN |
| 1673 | CALL LUEDIT(2) |
| 1674 | ELSE |
| 1675 | 381 nsbst=nsbst+1 |
| 1676 | IF(K(nsbst,2).LT.91.OR.K(nsbst,2).GT.93) GO TO 381 |
| 1677 | IDSTR=K(nsbst,2) |
| 1678 | nsbst=nsbst+1 |
| 1679 | ENDIF |
| 1680 | IF(FRAME.EQ.'LAB') THEN |
| 1681 | CALL HBOOST |
| 1682 | ENDIF |
| 1683 | C ******** boost back to lab frame(if it was in) |
| 1684 | C |
| 1685 | NFTP=NFP(jjtp,5) |
| 1686 | IF(NTP.EQ.2) NFTP=10+NFT(jjtp,5) |
| 1687 | nsbstR=0 |
| 1688 | DO 390 I=nsbst,N |
| 1689 | IF(K(I,2).EQ.IDSTR) THEN |
| 1690 | nsbstR=nsbstR+1 |
| 1691 | GO TO 390 |
| 1692 | ENDIF |
| 1693 | K(I,4)=nsbstR |
| 1694 | NATT=NATT+1 |
| 1695 | KATT(NATT,1)=K(I,2) |
| 1696 | KATT(NATT,2)=NFTP |
| 1697 | KATT(NATT,4)=K(I,1) |
| 1698 | c IF(K(I,3).EQ.0 .OR. K(K(I,3),2).EQ.IDSTR) THEN |
| 1699 | clin-4/2008: |
| 1700 | c IF(K(I,3).EQ.0 .OR. |
| 1701 | c 1 (K(I,3).ne.0.and.K(K(I,3),2).EQ.IDSTR)) THEN |
| 1702 | c KATT(NATT,3)=0 |
| 1703 | IF(K(I,3).EQ.0) THEN |
| 1704 | KATT(NATT,3)=0 |
| 1705 | ELSEIF(K(I,3).ne.0.and.K(K(I,3),2).EQ.IDSTR) THEN |
| 1706 | KATT(NATT,3)=0 |
| 1707 | clin-4/2008-end |
| 1708 | ELSE |
| 1709 | KATT(NATT,3)=NATT-I+K(I,3)+nsbstR-K(K(I,3),4) |
| 1710 | ENDIF |
| 1711 | C ****** identify the mother particle |
| 1712 | PATT(NATT,1)=P(I,1) |
| 1713 | PATT(NATT,2)=P(I,2) |
| 1714 | PATT(NATT,3)=P(I,3) |
| 1715 | PATT(NATT,4)=P(I,4) |
| 1716 | EATT=EATT+P(I,4) |
| 1717 | cbz11/11/98 |
| 1718 | cbz1/25/99 |
| 1719 | c IF (NTP .EQ. 1) THEN |
| 1720 | c GXAR(NATT) = YP(1, jjtp) |
| 1721 | c ELSE |
| 1722 | c GXAR(NATT) = YT(1, jjtp) |
| 1723 | c END IF |
| 1724 | c IF (NTP .EQ. 1) THEN |
| 1725 | c GYAR(NATT) = YP(2, jjtp) |
| 1726 | c ELSE |
| 1727 | c GYAR(NATT) = YT(2, jjtp) |
| 1728 | c END IF |
| 1729 | IF (NTP .EQ. 1) THEN |
| 1730 | LSG = jjtp |
| 1731 | ELSE |
| 1732 | LSG = jjtp + NSP |
| 1733 | END IF |
| 1734 | GXAR(NATT) = sngl(ZT1(LSG)) |
| 1735 | GYAR(NATT) = sngl(ZT2(LSG)) |
| 1736 | GZAR(NATT) = sngl(ZT3(LSG)) |
| 1737 | FTAR(NATT) = sngl(ATAUI(LSG)) |
| 1738 | cbz1/25/99end |
| 1739 | ITYPAR(NATT) = K(I, 2) |
| 1740 | PXAR(NATT) = P(I, 1) |
| 1741 | PYAR(NATT) = P(I, 2) |
| 1742 | PZAR(NATT) = P(I, 3) |
| 1743 | PEAR(NATT) = P(I, 4) |
| 1744 | XMAR(NATT) = P(I, 5) |
| 1745 | cbz11/11/98end |
| 1746 | |
| 1747 | 390 CONTINUE |
| 1748 | 400 CONTINUE |
| 1749 | C ********Fragment the q-qq related string systems |
| 1750 | ENDIF |
| 1751 | |
| 1752 | DO 450 I=1,NDR |
| 1753 | NATT=NATT+1 |
| 1754 | KATT(NATT,1)=KFDR(I) |
| 1755 | KATT(NATT,2)=40 |
| 1756 | KATT(NATT,3)=0 |
| 1757 | PATT(NATT,1)=PDR(I,1) |
| 1758 | PATT(NATT,2)=PDR(I,2) |
| 1759 | PATT(NATT,3)=PDR(I,3) |
| 1760 | PATT(NATT,4)=PDR(I,4) |
| 1761 | EATT=EATT+PDR(I,4) |
| 1762 | clin-11/11/03 set direct photons positions and time at formation: |
| 1763 | GXAR(NATT) = rtdr(I,1) |
| 1764 | GYAR(NATT) = rtdr(I,2) |
| 1765 | GZAR(NATT) = 0. |
| 1766 | FTAR(NATT) = 0. |
| 1767 | ITYPAR(NATT) =KATT(NATT,1) |
| 1768 | PXAR(NATT) = PATT(NATT,1) |
| 1769 | PYAR(NATT) = PATT(NATT,2) |
| 1770 | PZAR(NATT) = PATT(NATT,3) |
| 1771 | PEAR(NATT) = PATT(NATT,4) |
| 1772 | XMAR(NATT) = PDR(I,5) |
| 1773 | 450 CONTINUE |
| 1774 | |
| 1775 | C ********store the direct-produced particles |
| 1776 | C |
| 1777 | |
| 1778 | clin-4/19/01 soft3: |
| 1779 | 565 continue |
| 1780 | |
| 1781 | DENGY=EATT/(IHNT2(1)*HINT1(6)+IHNT2(3)*HINT1(7))-1.0 |
| 1782 | IF(ABS(DENGY).GT.HIPR1(43).AND.IHPR2(20).NE.0 |
| 1783 | & .AND.IHPR2(21).EQ.0) THEN |
| 1784 | IF(IHPR2(10).NE.0) |
| 1785 | & WRITE(6,*) 'Energy not conserved, repeat the event' |
| 1786 | c call lulist(1) |
| 1787 | write(6,*) 'violated:EATT,NATT,B=',EATT,NATT,bimp |
| 1788 | GO TO 50 |
| 1789 | ENDIF |
| 1790 | c write(6,*) 'satisfied:EATT,NATT,B=',EATT,NATT,bimp |
| 1791 | c write(6,*) ' ' |
| 1792 | |
| 1793 | RETURN |
| 1794 | END |
| 1795 | C |
| 1796 | C |
| 1797 | C |
| 1798 | SUBROUTINE HIJSET(EFRM,FRAME,PROJ,TARG,IAP,IZP,IAT,IZT) |
| 1799 | CHARACTER FRAME*4,PROJ*4,TARG*4,EFRAME*4 |
| 1800 | DOUBLE PRECISION DD1,DD2,DD3,DD4 |
| 1801 | COMMON/HSTRNG/NFP(300,15),PP(300,15),NFT(300,15),PT(300,15) |
| 1802 | cc SAVE /HSTRNG/ |
| 1803 | COMMON/hjcrdn/YP(3,300),YT(3,300) |
| 1804 | cc SAVE /hjcrdn/ |
| 1805 | COMMON/HPARNT/HIPR1(100),IHPR2(50),HINT1(100),IHNT2(50) |
| 1806 | cc SAVE /HPARNT/ |
| 1807 | COMMON/HIJDAT/HIDAT0(10,10),HIDAT(10) |
| 1808 | cc SAVE /HIJDAT/ |
| 1809 | COMMON/LUDAT1A/MSTU(200),PARU(200),MSTJ(200),PARJ(200) |
| 1810 | cc SAVE /LUDAT1A/ |
| 1811 | EXTERNAL FNKICK,FNKC2,FNSTRU,FNSTRM,FNSTRS |
| 1812 | SAVE |
| 1813 | |
| 1814 | CALL TITLE |
| 1815 | IHNT2(1)=IAP |
| 1816 | IHNT2(2)=IZP |
| 1817 | IHNT2(3)=IAT |
| 1818 | IHNT2(4)=IZT |
| 1819 | IHNT2(5)=0 |
| 1820 | IHNT2(6)=0 |
| 1821 | C |
| 1822 | HINT1(8)=MAX(ULMASS(2112),ULMASS(2212)) |
| 1823 | HINT1(9)=HINT1(8) |
| 1824 | C |
| 1825 | IF(PROJ.NE.'A') THEN |
| 1826 | IF(PROJ.EQ.'P') THEN |
| 1827 | IHNT2(5)=2212 |
| 1828 | ELSE IF(PROJ.EQ.'PBAR') THEN |
| 1829 | IHNT2(5)=-2212 |
| 1830 | ELSE IF(PROJ.EQ.'PI+') THEN |
| 1831 | IHNT2(5)=211 |
| 1832 | ELSE IF(PROJ.EQ.'PI-') THEN |
| 1833 | IHNT2(5)=-211 |
| 1834 | ELSE IF(PROJ.EQ.'K+') THEN |
| 1835 | IHNT2(5)=321 |
| 1836 | ELSE IF(PROJ.EQ.'K-') THEN |
| 1837 | IHNT2(5)=-321 |
| 1838 | ELSE IF(PROJ.EQ.'N') THEN |
| 1839 | IHNT2(5)=2112 |
| 1840 | ELSE IF(PROJ.EQ.'NBAR') THEN |
| 1841 | IHNT2(5)=-2112 |
| 1842 | ELSE |
| 1843 | WRITE(6,*) PROJ, 'wrong or unavailable proj name' |
| 1844 | STOP |
| 1845 | ENDIF |
| 1846 | HINT1(8)=ULMASS(IHNT2(5)) |
| 1847 | ENDIF |
| 1848 | IF(TARG.NE.'A') THEN |
| 1849 | IF(TARG.EQ.'P') THEN |
| 1850 | IHNT2(6)=2212 |
| 1851 | ELSE IF(TARG.EQ.'PBAR') THEN |
| 1852 | IHNT2(6)=-2212 |
| 1853 | ELSE IF(TARG.EQ.'PI+') THEN |
| 1854 | IHNT2(6)=211 |
| 1855 | ELSE IF(TARG.EQ.'PI-') THEN |
| 1856 | IHNT2(6)=-211 |
| 1857 | ELSE IF(TARG.EQ.'K+') THEN |
| 1858 | IHNT2(6)=321 |
| 1859 | ELSE IF(TARG.EQ.'K-') THEN |
| 1860 | IHNT2(6)=-321 |
| 1861 | ELSE IF(TARG.EQ.'N') THEN |
| 1862 | IHNT2(6)=2112 |
| 1863 | ELSE IF(TARG.EQ.'NBAR') THEN |
| 1864 | IHNT2(6)=-2112 |
| 1865 | ELSE |
| 1866 | WRITE(6,*) TARG,'wrong or unavailable targ name' |
| 1867 | STOP |
| 1868 | ENDIF |
| 1869 | HINT1(9)=ULMASS(IHNT2(6)) |
| 1870 | ENDIF |
| 1871 | |
| 1872 | C...Switch off decay of pi0, K0S, Lambda, Sigma+-, Xi0-, Omega-. |
| 1873 | IF(IHPR2(12).GT.0) THEN |
| 1874 | CALL LUGIVE('MDCY(C221,1)=0') |
| 1875 | clin-11/07/00 no K* decays: |
| 1876 | CALL LUGIVE('MDCY(C313,1)=0') |
| 1877 | CALL LUGIVE('MDCY(C-313,1)=0') |
| 1878 | CALL LUGIVE('MDCY(C323,1)=0') |
| 1879 | CALL LUGIVE('MDCY(C-323,1)=0') |
| 1880 | clin-1/04/01 no K0 and K0bar decays so K0L and K0S do not appear, |
| 1881 | c this way the K/Kbar difference is accounted for exactly: |
| 1882 | CALL LUGIVE('MDCY(C311,1)=0') |
| 1883 | CALL LUGIVE('MDCY(C-311,1)=0') |
| 1884 | clin-11/08/00 no Delta decays: |
| 1885 | CALL LUGIVE('MDCY(C1114,1)=0') |
| 1886 | CALL LUGIVE('MDCY(C2114,1)=0') |
| 1887 | CALL LUGIVE('MDCY(C2214,1)=0') |
| 1888 | CALL LUGIVE('MDCY(C2224,1)=0') |
| 1889 | CALL LUGIVE('MDCY(C-1114,1)=0') |
| 1890 | CALL LUGIVE('MDCY(C-2114,1)=0') |
| 1891 | CALL LUGIVE('MDCY(C-2214,1)=0') |
| 1892 | CALL LUGIVE('MDCY(C-2224,1)=0') |
| 1893 | clin-11/07/00-end |
| 1894 | cbz12/4/98 |
| 1895 | CALL LUGIVE('MDCY(C213,1)=0') |
| 1896 | CALL LUGIVE('MDCY(C-213,1)=0') |
| 1897 | CALL LUGIVE('MDCY(C113,1)=0') |
| 1898 | CALL LUGIVE('MDCY(C223,1)=0') |
| 1899 | CALL LUGIVE('MDCY(C333,1)=0') |
| 1900 | cbz12/4/98end |
| 1901 | CALL LUGIVE('MDCY(C111,1)=0') |
| 1902 | CALL LUGIVE('MDCY(C310,1)=0') |
| 1903 | CALL LUGIVE('MDCY(C411,1)=0;MDCY(C-411,1)=0') |
| 1904 | CALL LUGIVE('MDCY(C421,1)=0;MDCY(C-421,1)=0') |
| 1905 | CALL LUGIVE('MDCY(C431,1)=0;MDCY(C-431,1)=0') |
| 1906 | CALL LUGIVE('MDCY(C511,1)=0;MDCY(C-511,1)=0') |
| 1907 | CALL LUGIVE('MDCY(C521,1)=0;MDCY(C-521,1)=0') |
| 1908 | CALL LUGIVE('MDCY(C531,1)=0;MDCY(C-531,1)=0') |
| 1909 | CALL LUGIVE('MDCY(C3122,1)=0;MDCY(C-3122,1)=0') |
| 1910 | CALL LUGIVE('MDCY(C3112,1)=0;MDCY(C-3112,1)=0') |
| 1911 | CALL LUGIVE('MDCY(C3212,1)=0;MDCY(C-3212,1)=0') |
| 1912 | CALL LUGIVE('MDCY(C3222,1)=0;MDCY(C-3222,1)=0') |
| 1913 | CALL LUGIVE('MDCY(C3312,1)=0;MDCY(C-3312,1)=0') |
| 1914 | CALL LUGIVE('MDCY(C3322,1)=0;MDCY(C-3322,1)=0') |
| 1915 | CALL LUGIVE('MDCY(C3334,1)=0;MDCY(C-3334,1)=0') |
| 1916 | ENDIF |
| 1917 | MSTU(12)=0 |
| 1918 | MSTU(21)=1 |
| 1919 | IF(IHPR2(10).EQ.0) THEN |
| 1920 | MSTU(22)=0 |
| 1921 | MSTU(25)=0 |
| 1922 | MSTU(26)=0 |
| 1923 | ENDIF |
| 1924 | |
| 1925 | clin parj(41) and (42) are a, b parameters in Lund, read from input.ampt: |
| 1926 | c PARJ(41)=HIPR1(3) |
| 1927 | c PARJ(42)=HIPR1(4) |
| 1928 | c PARJ(41)=2.2 |
| 1929 | c PARJ(42)=0.5 |
| 1930 | |
| 1931 | clin 2 popcorn parameters read from input.ampt: |
| 1932 | c IHPR2(11) = 3 |
| 1933 | c PARJ(5) = 0.5 |
| 1934 | MSTJ(12)=IHPR2(11) |
| 1935 | |
| 1936 | clin parj(21) gives the mean gaussian width for hadron Pt: |
| 1937 | PARJ(21)=HIPR1(2) |
| 1938 | clin parj(2) is gamma_s=P(s)/P(u), kappa propto 1/b/(2+a) assumed. |
| 1939 | rkp=HIPR1(4)*(2+HIPR1(3))/PARJ(42)/(2+PARJ(41)) |
| 1940 | PARJ(2)=PARJ(2)**(1./rkp) |
| 1941 | PARJ(21)=PARJ(21)*sqrt(rkp) |
| 1942 | clin-10/31/00 update when string tension is changed: |
| 1943 | HIPR1(2)=PARJ(21) |
| 1944 | |
| 1945 | C ******** set up for jetset |
| 1946 | IF(FRAME.EQ.'LAB') THEN |
| 1947 | DD1=dble(EFRM) |
| 1948 | DD2=dble(HINT1(8)) |
| 1949 | DD3=dble(HINT1(9)) |
| 1950 | HINT1(1)=SQRT(HINT1(8)**2+2.0*HINT1(9)*EFRM+HINT1(9)**2) |
| 1951 | DD4=DSQRT(DD1**2-DD2**2)/(DD1+DD3) |
| 1952 | HINT1(2)=sngl(DD4) |
| 1953 | HINT1(3)=0.5*sngl(DLOG((1.D0+DD4)/(1.D0-DD4))) |
| 1954 | DD4=DSQRT(DD1**2-DD2**2)/DD1 |
| 1955 | HINT1(4)=0.5*sngl(DLOG((1.D0+DD4)/(1.D0-DD4))) |
| 1956 | HINT1(5)=0.0 |
| 1957 | HINT1(6)=EFRM |
| 1958 | HINT1(7)=HINT1(9) |
| 1959 | ELSE IF(FRAME.EQ.'CMS') THEN |
| 1960 | HINT1(1)=EFRM |
| 1961 | HINT1(2)=0.0 |
| 1962 | HINT1(3)=0.0 |
| 1963 | DD1=dble(HINT1(1)) |
| 1964 | DD2=dble(HINT1(8)) |
| 1965 | DD3=dble(HINT1(9)) |
| 1966 | DD4=DSQRT(1.D0-4.D0*DD2**2/DD1**2) |
| 1967 | HINT1(4)=0.5*sngl(DLOG((1.D0+DD4)/(1.D0-DD4))) |
| 1968 | DD4=DSQRT(1.D0-4.D0*DD3**2/DD1**2) |
| 1969 | HINT1(5)=-0.5*sngl(DLOG((1.D0+DD4)/(1.D0-DD4))) |
| 1970 | HINT1(6)=HINT1(1)/2.0 |
| 1971 | HINT1(7)=HINT1(1)/2.0 |
| 1972 | ENDIF |
| 1973 | C ********define Lorentz transform to lab frame |
| 1974 | c |
| 1975 | C ********calculate the cross sections involved with |
| 1976 | C nucleon collisions. |
| 1977 | IF(IHNT2(1).GT.1) THEN |
| 1978 | CALL HIJWDS(IHNT2(1),1,RMAX) |
| 1979 | HIPR1(34)=RMAX |
| 1980 | C ********set up Wood-Sax distr for proj. |
| 1981 | ENDIF |
| 1982 | IF(IHNT2(3).GT.1) THEN |
| 1983 | CALL HIJWDS(IHNT2(3),2,RMAX) |
| 1984 | HIPR1(35)=RMAX |
| 1985 | C ********set up Wood-Sax distr for targ. |
| 1986 | ENDIF |
| 1987 | C |
| 1988 | C |
| 1989 | I=0 |
| 1990 | 20 I=I+1 |
| 1991 | IF(I.EQ.10) GO TO 30 |
| 1992 | IF(HIDAT0(10,I).LE.HINT1(1)) GO TO 20 |
| 1993 | 30 IF(I.EQ.1) I=2 |
| 1994 | DO 40 J=1,9 |
| 1995 | HIDAT(J)=HIDAT0(J,I-1)+(HIDAT0(J,I)-HIDAT0(J,I-1)) |
| 1996 | & *(HINT1(1)-HIDAT0(10,I-1))/(HIDAT0(10,I)-HIDAT0(10,I-1)) |
| 1997 | 40 CONTINUE |
| 1998 | HIPR1(31)=HIDAT(5) |
| 1999 | HIPR1(30)=2.0*HIDAT(5) |
| 2000 | C |
| 2001 | C |
| 2002 | CALL HIJCRS |
| 2003 | C |
| 2004 | IF(IHPR2(5).NE.0) THEN |
| 2005 | CALL HIFUN(3,0.0,36.0,FNKICK) |
| 2006 | C ********booking for generating pt**2 for pt kick |
| 2007 | ENDIF |
| 2008 | CALL HIFUN(7,0.0,6.0,FNKC2) |
| 2009 | CALL HIFUN(4,0.0,1.0,FNSTRU) |
| 2010 | CALL HIFUN(5,0.0,1.0,FNSTRM) |
| 2011 | CALL HIFUN(6,0.0,1.0,FNSTRS) |
| 2012 | C ********booking for x distribution of valence quarks |
| 2013 | EFRAME='Ecm' |
| 2014 | IF(FRAME.EQ.'LAB') EFRAME='Elab' |
| 2015 | WRITE(6,100) EFRAME,EFRM,PROJ,IHNT2(1),IHNT2(2), |
| 2016 | & TARG,IHNT2(3),IHNT2(4) |
| 2017 | 100 FORMAT( |
| 2018 | & 10X,'**************************************************'/ |
| 2019 | & 10X,'*',48X,'*'/ |
| 7a129c8c |
2020 | & 10X,'* HIJING for AMPT initialized at *'/ |
| 0119ef9a |
2021 | & 10X,'*',13X,A4,'= ',F10.2,' GeV/n',13X,'*'/ |
| 2022 | & 10X,'*',48X,'*'/ |
| 2023 | & 10X,'*',8X,'for ', |
| 2024 | & A4,'(',I3,',',I3,')',' + ',A4,'(',I3,',',I3,')',7X,'*'/ |
| 2025 | & 10X,'**************************************************') |
| 2026 | RETURN |
| 2027 | END |
| 2028 | C |
| 2029 | C |
| 2030 | C |
| 2031 | FUNCTION FNKICK(X) |
| 2032 | COMMON/HPARNT/HIPR1(100),IHPR2(50),HINT1(100),IHNT2(50) |
| 2033 | cc SAVE /HPARNT/ |
| 2034 | SAVE |
| 2035 | FNKICK=1.0/(X+HIPR1(19)**2)/(X+HIPR1(20)**2) |
| 2036 | & /(1+EXP((SQRT(X)-HIPR1(20))/0.4)) |
| 2037 | RETURN |
| 2038 | END |
| 2039 | C |
| 2040 | C |
| 2041 | FUNCTION FNKC2(X) |
| 2042 | COMMON/HPARNT/HIPR1(100),IHPR2(50),HINT1(100),IHNT2(50) |
| 2043 | cc SAVE /HPARNT/ |
| 2044 | SAVE |
| 2045 | FNKC2=X*EXP(-2.0*X/HIPR1(42)) |
| 2046 | RETURN |
| 2047 | END |
| 2048 | C |
| 2049 | C |
| 2050 | C |
| 2051 | FUNCTION FNSTRU(X) |
| 2052 | COMMON/HPARNT/HIPR1(100),IHPR2(50),HINT1(100),IHNT2(50) |
| 2053 | cc SAVE /HPARNT/ |
| 2054 | SAVE |
| 2055 | FNSTRU=(1.0-X)**HIPR1(44)/ |
| 2056 | & (X**2+HIPR1(45)**2/HINT1(1)**2)**HIPR1(46) |
| 2057 | RETURN |
| 2058 | END |
| 2059 | C |
| 2060 | C |
| 2061 | C |
| 2062 | FUNCTION FNSTRM(X) |
| 2063 | COMMON/HPARNT/HIPR1(100),IHPR2(50),HINT1(100),IHNT2(50) |
| 2064 | cc SAVE /HPARNT/ |
| 2065 | SAVE |
| 2066 | FNSTRM=1.0/((1.0-X)**2+HIPR1(45)**2/HINT1(1)**2)**HIPR1(46) |
| 2067 | & /(X**2+HIPR1(45)**2/HINT1(1)**2)**HIPR1(46) |
| 2068 | RETURN |
| 2069 | END |
| 2070 | C |
| 2071 | C |
| 2072 | FUNCTION FNSTRS(X) |
| 2073 | COMMON/HPARNT/HIPR1(100),IHPR2(50),HINT1(100),IHNT2(50) |
| 2074 | cc SAVE /HPARNT/ |
| 2075 | SAVE |
| 2076 | FNSTRS=(1.0-X)**HIPR1(47)/ |
| 2077 | & (X**2+HIPR1(45)**2/HINT1(1)**2)**HIPR1(48) |
| 2078 | RETURN |
| 2079 | END |
| 2080 | C |
| 2081 | C |
| 2082 | C |
| 2083 | C |
| 2084 | SUBROUTINE HBOOST |
| 2085 | IMPLICIT DOUBLE PRECISION(D) |
| 2086 | COMMON/LUJETSA/N,K(9000,5),P(9000,5),V(9000,5) |
| 2087 | cc SAVE /LUJETSA/ |
| 2088 | COMMON/LUDAT1A/MSTU(200),PARU(200),MSTJ(200),PARJ(200) |
| 2089 | cc SAVE /LUDAT1A/ |
| 2090 | COMMON/HPARNT/HIPR1(100),IHPR2(50),HINT1(100),IHNT2(50) |
| 2091 | cc SAVE /HPARNT/ |
| 2092 | SAVE |
| 2093 | DO 100 I=1,N |
| 2094 | DBETA=dble(P(I,3)/P(I,4)) |
| 2095 | IF(ABS(DBETA).GE.1.D0) THEN |
| 2096 | DB=dble(HINT1(2)) |
| 2097 | IF(DB.GT.0.99999999D0) THEN |
| 2098 | C ********Rescale boost vector if too close to unity. |
| 2099 | WRITE(6,*) '(HIBOOT:) boost vector too large' |
| 2100 | DB=0.99999999D0 |
| 2101 | ENDIF |
| 2102 | DGA=1D0/SQRT(1D0-DB**2) |
| 2103 | DP3=dble(P(I,3)) |
| 2104 | DP4=dble(P(I,4)) |
| 2105 | P(I,3)=sngl((DP3+DB*DP4)*DGA) |
| 2106 | P(I,4)=sngl((DP4+DB*DP3)*DGA) |
| 2107 | GO TO 100 |
| 2108 | ENDIF |
| 2109 | Y=0.5*sngl(DLOG((1.D0+DBETA)/(1.D0-DBETA))) |
| 2110 | AMT=SQRT(P(I,1)**2+P(I,2)**2+P(I,5)**2) |
| 2111 | P(I,3)=AMT*SINH(Y+HINT1(3)) |
| 2112 | P(I,4)=AMT*COSH(Y+HINT1(3)) |
| 2113 | 100 CONTINUE |
| 2114 | RETURN |
| 2115 | END |
| 2116 | C |
| 2117 | C |
| 2118 | C |
| 2119 | C |
| 2120 | SUBROUTINE QUENCH(JPJT,NTP) |
| 2121 | PARAMETER (MAXSTR=150001) |
| 2122 | DIMENSION RDP(300),LQP(300),RDT(300),LQT(300) |
| 2123 | COMMON/hjcrdn/YP(3,300),YT(3,300) |
| 2124 | cc SAVE /hjcrdn/ |
| 2125 | COMMON/HPARNT/HIPR1(100),IHPR2(50),HINT1(100),IHNT2(50) |
| 2126 | cc SAVE /HPARNT/ |
| 2127 | C |
| 2128 | COMMON/HJJET1/NPJ(300),KFPJ(300,500),PJPX(300,500), |
| 2129 | & PJPY(300,500),PJPZ(300,500),PJPE(300,500), |
| 2130 | & PJPM(300,500),NTJ(300),KFTJ(300,500), |
| 2131 | & PJTX(300,500),PJTY(300,500),PJTZ(300,500), |
| 2132 | & PJTE(300,500),PJTM(300,500) |
| 2133 | cc SAVE /HJJET1/ |
| 2134 | COMMON/HJJET2/NSG,NJSG(MAXSTR),IASG(MAXSTR,3),K1SG(MAXSTR,100), |
| 2135 | & K2SG(MAXSTR,100),PXSG(MAXSTR,100),PYSG(MAXSTR,100), |
| 2136 | & PZSG(MAXSTR,100),PESG(MAXSTR,100),PMSG(MAXSTR,100) |
| 2137 | cc SAVE /HJJET2/ |
| 2138 | COMMON/HSTRNG/NFP(300,15),PP(300,15),NFT(300,15),PT(300,15) |
| 2139 | cc SAVE /HSTRNG/ |
| 2140 | COMMON/RNDF77/NSEED |
| 2141 | cc SAVE /RNDF77/ |
| 2142 | SAVE |
| 2143 | C |
| 2144 | c Uzhi: |
| 2145 | BB=HINT1(19) |
| 2146 | PHI=HINT1(20) |
| 2147 | BBX=BB*COS(PHI) |
| 2148 | BBY=BB*SIN(PHI) |
| 2149 | c |
| 2150 | IF(NTP.EQ.2) GO TO 400 |
| 2151 | IF(NTP.EQ.3) GO TO 2000 |
| 2152 | C******************************************************* |
| 2153 | C Jet interaction for proj jet in the direction PHIP |
| 2154 | C****************************************************** |
| 2155 | C |
| 2156 | IF(NFP(JPJT,7).NE.1) RETURN |
| 2157 | |
| 2158 | JP=JPJT |
| 2159 | DO 290 I=1,NPJ(JP) |
| 2160 | PTJET0=SQRT(PJPX(JP,I)**2+PJPY(JP,I)**2) |
| 2161 | IF(PTJET0.LE.HIPR1(11)) GO TO 290 |
| 2162 | PTOT=SQRT(PTJET0*PTJET0+PJPZ(JP,I)**2) |
| 2163 | IF(PTOT.LT.HIPR1(8)) GO TO 290 |
| 2164 | PHIP=ULANGL(PJPX(JP,I),PJPY(JP,I)) |
| 2165 | C******* find the wounded proj which can interact with jet*** |
| 2166 | KP=0 |
| 2167 | DO 100 I2=1,IHNT2(1) |
| 2168 | IF(NFP(I2,5).NE.3 .OR. I2.EQ.JP) GO TO 100 |
| 2169 | DX=YP(1,I2)-YP(1,JP) |
| 2170 | DY=YP(2,I2)-YP(2,JP) |
| 2171 | PHI=ULANGL(DX,DY) |
| 2172 | DPHI=ABS(PHI-PHIP) |
| 2173 | c Uzhi: |
| 2174 | IF(DPHI.GE.HIPR1(40)) DPHI=2.*HIPR1(40)-DPHI |
| 2175 | IF(DPHI.GE.HIPR1(40)/2.0) GO TO 100 |
| 2176 | RD0=SQRT(DX*DX+DY*DY) |
| 2177 | IF(RD0*SIN(DPHI).GT.HIPR1(12)) GO TO 100 |
| 2178 | KP=KP+1 |
| 2179 | LQP(KP)=I2 |
| 2180 | RDP(KP)=COS(DPHI)*RD0 |
| 2181 | 100 CONTINUE |
| 2182 | C******* rearrange according decending rd************ |
| 2183 | DO 110 I2=1,KP-1 |
| 2184 | DO 110 J2=I2+1,KP |
| 2185 | IF(RDP(I2).LT.RDP(J2)) GO TO 110 |
| 2186 | RD=RDP(I2) |
| 2187 | LQ=LQP(I2) |
| 2188 | RDP(I2)=RDP(J2) |
| 2189 | LQP(I2)=LQP(J2) |
| 2190 | RDP(J2)=RD |
| 2191 | LQP(J2)=LQ |
| 2192 | 110 CONTINUE |
| 2193 | C****** find wounded targ which can interact with jet******** |
| 2194 | KT=0 |
| 2195 | DO 120 I2=1,IHNT2(3) |
| 2196 | IF(NFT(I2,5).NE.3) GO TO 120 |
| 2197 | DX=YT(1,I2)-YP(1,JP)-BBX |
| 2198 | DY=YT(2,I2)-YP(2,JP)-BBY |
| 2199 | PHI=ULANGL(DX,DY) |
| 2200 | DPHI=ABS(PHI-PHIP) |
| 2201 | c Uzhi: |
| 2202 | IF(DPHI.GE.HIPR1(40)) DPHI=2.*HIPR1(40)-DPHI |
| 2203 | IF(DPHI.GT.HIPR1(40)/2.0) GO TO 120 |
| 2204 | RD0=SQRT(DX*DX+DY*DY) |
| 2205 | IF(RD0*SIN(DPHI).GT.HIPR1(12)) GO TO 120 |
| 2206 | KT=KT+1 |
| 2207 | LQT(KT)=I2 |
| 2208 | RDT(KT)=COS(DPHI)*RD0 |
| 2209 | 120 CONTINUE |
| 2210 | C******* rearrange according decending rd************ |
| 2211 | DO 130 I2=1,KT-1 |
| 2212 | DO 130 J2=I2+1,KT |
| 2213 | IF(RDT(I2).LT.RDT(J2)) GO TO 130 |
| 2214 | RD=RDT(I2) |
| 2215 | LQ=LQT(I2) |
| 2216 | RDT(I2)=RDT(J2) |
| 2217 | LQT(I2)=LQT(J2) |
| 2218 | RDT(J2)=RD |
| 2219 | LQT(J2)=LQ |
| 2220 | 130 CONTINUE |
| 2221 | |
| 2222 | MP=0 |
| 2223 | MT=0 |
| 2224 | R0=0.0 |
| 2225 | NQ=0 |
| 2226 | DP=0.0 |
| 2227 | PTOT=SQRT(PJPX(JP,I)**2+PJPY(JP,I)**2+PJPZ(JP,I)**2) |
| 2228 | V1=PJPX(JP,I)/PTOT |
| 2229 | V2=PJPY(JP,I)/PTOT |
| 2230 | V3=PJPZ(JP,I)/PTOT |
| 2231 | |
| 2232 | 200 RN=RANART(NSEED) |
| 2233 | 210 IF(MT.GE.KT .AND. MP.GE.KP) GO TO 290 |
| 2234 | IF(MT.GE.KT) GO TO 220 |
| 2235 | IF(MP.GE.KP) GO TO 240 |
| 2236 | IF(RDP(MP+1).GT.RDT(MT+1)) GO TO 240 |
| 2237 | 220 MP=MP+1 |
| 2238 | DRR=RDP(MP)-R0 |
| 2239 | IF(RN.GE.1.0-EXP(-DRR/HIPR1(13))) GO TO 210 |
| 2240 | DP=DRR*HIPR1(14) |
| 2241 | IF(KFPJ(JP,I).NE.21) DP=0.5*DP |
| 2242 | C ********string tension of quark jet is 0.5 of gluon's |
| 2243 | IF(DP.LE.0.2) GO TO 210 |
| 2244 | IF(PTOT.LE.0.4) GO TO 290 |
| 2245 | IF(PTOT.LE.DP) DP=PTOT-0.2 |
| 2246 | DE=DP |
| 2247 | |
| 2248 | IF(KFPJ(JP,I).NE.21) THEN |
| 2249 | PRSHU=PP(LQP(MP),1)**2+PP(LQP(MP),2)**2 |
| 2250 | & +PP(LQP(MP),3)**2 |
| 2251 | DE=SQRT(PJPM(JP,I)**2+PTOT**2) |
| 2252 | & -SQRT(PJPM(JP,I)**2+(PTOT-DP)**2) |
| 2253 | ERSHU=(PP(LQP(MP),4)+DE-DP)**2 |
| 2254 | AMSHU=ERSHU-PRSHU |
| 2255 | IF(AMSHU.LT.HIPR1(1)*HIPR1(1)) GO TO 210 |
| 2256 | PP(LQP(MP),4)=SQRT(ERSHU) |
| 2257 | PP(LQP(MP),5)=SQRT(AMSHU) |
| 2258 | ENDIF |
| 2259 | C ********reshuffle the energy when jet has mass |
| 2260 | R0=RDP(MP) |
| 2261 | DP1=DP*V1 |
| 2262 | DP2=DP*V2 |
| 2263 | DP3=DP*V3 |
| 2264 | C ********momentum and energy transfer from jet |
| 2265 | |
| 2266 | NPJ(LQP(MP))=NPJ(LQP(MP))+1 |
| 2267 | KFPJ(LQP(MP),NPJ(LQP(MP)))=21 |
| 2268 | PJPX(LQP(MP),NPJ(LQP(MP)))=DP1 |
| 2269 | PJPY(LQP(MP),NPJ(LQP(MP)))=DP2 |
| 2270 | PJPZ(LQP(MP),NPJ(LQP(MP)))=DP3 |
| 2271 | PJPE(LQP(MP),NPJ(LQP(MP)))=DP |
| 2272 | PJPM(LQP(MP),NPJ(LQP(MP)))=0.0 |
| 2273 | GO TO 260 |
| 2274 | |
| 2275 | 240 MT=MT+1 |
| 2276 | DRR=RDT(MT)-R0 |
| 2277 | IF(RN.GE.1.0-EXP(-DRR/HIPR1(13))) GO TO 210 |
| 2278 | DP=DRR*HIPR1(14) |
| 2279 | IF(DP.LE.0.2) GO TO 210 |
| 2280 | IF(PTOT.LE.0.4) GO TO 290 |
| 2281 | IF(PTOT.LE.DP) DP=PTOT-0.2 |
| 2282 | DE=DP |
| 2283 | |
| 2284 | IF(KFPJ(JP,I).NE.21) THEN |
| 2285 | PRSHU=PT(LQT(MT),1)**2+PT(LQT(MT),2)**2 |
| 2286 | & +PT(LQT(MT),3)**2 |
| 2287 | DE=SQRT(PJPM(JP,I)**2+PTOT**2) |
| 2288 | & -SQRT(PJPM(JP,I)**2+(PTOT-DP)**2) |
| 2289 | ERSHU=(PT(LQT(MT),4)+DE-DP)**2 |
| 2290 | AMSHU=ERSHU-PRSHU |
| 2291 | IF(AMSHU.LT.HIPR1(1)*HIPR1(1)) GO TO 210 |
| 2292 | PT(LQT(MT),4)=SQRT(ERSHU) |
| 2293 | PT(LQT(MT),5)=SQRT(AMSHU) |
| 2294 | ENDIF |
| 2295 | C ********reshuffle the energy when jet has mass |
| 2296 | |
| 2297 | R0=RDT(MT) |
| 2298 | DP1=DP*V1 |
| 2299 | DP2=DP*V2 |
| 2300 | DP3=DP*V3 |
| 2301 | C ********momentum and energy transfer from jet |
| 2302 | NTJ(LQT(MT))=NTJ(LQT(MT))+1 |
| 2303 | KFTJ(LQT(MT),NTJ(LQT(MT)))=21 |
| 2304 | PJTX(LQT(MT),NTJ(LQT(MT)))=DP1 |
| 2305 | PJTY(LQT(MT),NTJ(LQT(MT)))=DP2 |
| 2306 | PJTZ(LQT(MT),NTJ(LQT(MT)))=DP3 |
| 2307 | PJTE(LQT(MT),NTJ(LQT(MT)))=DP |
| 2308 | PJTM(LQT(MT),NTJ(LQT(MT)))=0.0 |
| 2309 | |
| 2310 | 260 PJPX(JP,I)=(PTOT-DP)*V1 |
| 2311 | PJPY(JP,I)=(PTOT-DP)*V2 |
| 2312 | PJPZ(JP,I)=(PTOT-DP)*V3 |
| 2313 | PJPE(JP,I)=PJPE(JP,I)-DE |
| 2314 | |
| 2315 | PTOT=PTOT-DP |
| 2316 | NQ=NQ+1 |
| 2317 | GO TO 200 |
| 2318 | 290 CONTINUE |
| 2319 | |
| 2320 | RETURN |
| 2321 | |
| 2322 | C******************************************************* |
| 2323 | C Jet interaction for target jet in the direction PHIT |
| 2324 | C****************************************************** |
| 2325 | C |
| 2326 | C******* find the wounded proj which can interact with jet*** |
| 2327 | |
| 2328 | 400 IF(NFT(JPJT,7).NE.1) RETURN |
| 2329 | JT=JPJT |
| 2330 | DO 690 I=1,NTJ(JT) |
| 2331 | PTJET0=SQRT(PJTX(JT,I)**2+PJTY(JT,I)**2) |
| 2332 | IF(PTJET0.LE.HIPR1(11)) GO TO 690 |
| 2333 | PTOT=SQRT(PTJET0*PTJET0+PJTZ(JT,I)**2) |
| 2334 | IF(PTOT.LT.HIPR1(8)) GO TO 690 |
| 2335 | PHIT=ULANGL(PJTX(JT,I),PJTY(JT,I)) |
| 2336 | KP=0 |
| 2337 | DO 500 I2=1,IHNT2(1) |
| 2338 | IF(NFP(I2,5).NE.3) GO TO 500 |
| 2339 | DX=YP(1,I2)+BBX-YT(1,JT) |
| 2340 | DY=YP(2,I2)+BBY-YT(2,JT) |
| 2341 | PHI=ULANGL(DX,DY) |
| 2342 | DPHI=ABS(PHI-PHIT) |
| 2343 | c Uzhi: |
| 2344 | IF(DPHI.GE.HIPR1(40)) DPHI=2.*HIPR1(40)-DPHI |
| 2345 | IF(DPHI.GT.HIPR1(40)/2.0) GO TO 500 |
| 2346 | RD0=SQRT(DX*DX+DY*DY) |
| 2347 | IF(RD0*SIN(DPHI).GT.HIPR1(12)) GO TO 500 |
| 2348 | KP=KP+1 |
| 2349 | LQP(KP)=I2 |
| 2350 | RDP(KP)=COS(DPHI)*RD0 |
| 2351 | 500 CONTINUE |
| 2352 | C******* rearrange according to decending rd************ |
| 2353 | DO 510 I2=1,KP-1 |
| 2354 | DO 510 J2=I2+1,KP |
| 2355 | IF(RDP(I2).LT.RDP(J2)) GO TO 510 |
| 2356 | RD=RDP(I2) |
| 2357 | LQ=LQP(I2) |
| 2358 | RDP(I2)=RDP(J2) |
| 2359 | LQP(I2)=LQP(J2) |
| 2360 | RDP(J2)=RD |
| 2361 | LQP(J2)=LQ |
| 2362 | 510 CONTINUE |
| 2363 | C****** find wounded targ which can interact with jet******** |
| 2364 | KT=0 |
| 2365 | DO 520 I2=1,IHNT2(3) |
| 2366 | IF(NFT(I2,5).NE.3 .OR. I2.EQ.JT) GO TO 520 |
| 2367 | DX=YT(1,I2)-YT(1,JT) |
| 2368 | DY=YT(2,I2)-YT(2,JT) |
| 2369 | PHI=ULANGL(DX,DY) |
| 2370 | DPHI=ABS(PHI-PHIT) |
| 2371 | c Uzhi: |
| 2372 | IF(DPHI.GE.HIPR1(40)) DPHI=2.*HIPR1(40)-DPHI |
| 2373 | IF(DPHI.GT.HIPR1(40)/2.0) GO TO 520 |
| 2374 | RD0=SQRT(DX*DX+DY*DY) |
| 2375 | IF(RD0*SIN(DPHI).GT.HIPR1(12)) GO TO 520 |
| 2376 | KT=KT+1 |
| 2377 | LQT(KT)=I2 |
| 2378 | RDT(KT)=COS(DPHI)*RD0 |
| 2379 | 520 CONTINUE |
| 2380 | C******* rearrange according to decending rd************ |
| 2381 | DO 530 I2=1,KT-1 |
| 2382 | DO 530 J2=I2+1,KT |
| 2383 | IF(RDT(I2).LT.RDT(J2)) GO TO 530 |
| 2384 | RD=RDT(I2) |
| 2385 | LQ=LQT(I2) |
| 2386 | RDT(I2)=RDT(J2) |
| 2387 | LQT(I2)=LQT(J2) |
| 2388 | RDT(J2)=RD |
| 2389 | LQT(J2)=LQ |
| 2390 | 530 CONTINUE |
| 2391 | |
| 2392 | MP=0 |
| 2393 | MT=0 |
| 2394 | NQ=0 |
| 2395 | DP=0.0 |
| 2396 | R0=0.0 |
| 2397 | PTOT=SQRT(PJTX(JT,I)**2+PJTY(JT,I)**2+PJTZ(JT,I)**2) |
| 2398 | V1=PJTX(JT,I)/PTOT |
| 2399 | V2=PJTY(JT,I)/PTOT |
| 2400 | V3=PJTZ(JT,I)/PTOT |
| 2401 | |
| 2402 | 600 RN=RANART(NSEED) |
| 2403 | 610 IF(MT.GE.KT .AND. MP.GE.KP) GO TO 690 |
| 2404 | IF(MT.GE.KT) GO TO 620 |
| 2405 | IF(MP.GE.KP) GO TO 640 |
| 2406 | IF(RDP(MP+1).GT.RDT(MT+1)) GO TO 640 |
| 2407 | 620 MP=MP+1 |
| 2408 | DRR=RDP(MP)-R0 |
| 2409 | IF(RN.GE.1.0-EXP(-DRR/HIPR1(13))) GO TO 610 |
| 2410 | DP=DRR*HIPR1(14) |
| 2411 | IF(KFTJ(JT,I).NE.21) DP=0.5*DP |
| 2412 | C ********string tension of quark jet is 0.5 of gluon's |
| 2413 | IF(DP.LE.0.2) GO TO 610 |
| 2414 | IF(PTOT.LE.0.4) GO TO 690 |
| 2415 | IF(PTOT.LE.DP) DP=PTOT-0.2 |
| 2416 | DE=DP |
| 2417 | C |
| 2418 | IF(KFTJ(JT,I).NE.21) THEN |
| 2419 | PRSHU=PP(LQP(MP),1)**2+PP(LQP(MP),2)**2 |
| 2420 | & +PP(LQP(MP),3)**2 |
| 2421 | DE=SQRT(PJTM(JT,I)**2+PTOT**2) |
| 2422 | & -SQRT(PJTM(JT,I)**2+(PTOT-DP)**2) |
| 2423 | ERSHU=(PP(LQP(MP),4)+DE-DP)**2 |
| 2424 | AMSHU=ERSHU-PRSHU |
| 2425 | IF(AMSHU.LT.HIPR1(1)*HIPR1(1)) GO TO 610 |
| 2426 | PP(LQP(MP),4)=SQRT(ERSHU) |
| 2427 | PP(LQP(MP),5)=SQRT(AMSHU) |
| 2428 | ENDIF |
| 2429 | C ********reshuffle the energy when jet has mass |
| 2430 | C |
| 2431 | R0=RDP(MP) |
| 2432 | DP1=DP*V1 |
| 2433 | DP2=DP*V2 |
| 2434 | DP3=DP*V3 |
| 2435 | C ********momentum and energy transfer from jet |
| 2436 | NPJ(LQP(MP))=NPJ(LQP(MP))+1 |
| 2437 | KFPJ(LQP(MP),NPJ(LQP(MP)))=21 |
| 2438 | PJPX(LQP(MP),NPJ(LQP(MP)))=DP1 |
| 2439 | PJPY(LQP(MP),NPJ(LQP(MP)))=DP2 |
| 2440 | PJPZ(LQP(MP),NPJ(LQP(MP)))=DP3 |
| 2441 | PJPE(LQP(MP),NPJ(LQP(MP)))=DP |
| 2442 | PJPM(LQP(MP),NPJ(LQP(MP)))=0.0 |
| 2443 | |
| 2444 | GO TO 660 |
| 2445 | |
| 2446 | 640 MT=MT+1 |
| 2447 | DRR=RDT(MT)-R0 |
| 2448 | IF(RN.GE.1.0-EXP(-DRR/HIPR1(13))) GO TO 610 |
| 2449 | DP=DRR*HIPR1(14) |
| 2450 | IF(DP.LE.0.2) GO TO 610 |
| 2451 | IF(PTOT.LE.0.4) GO TO 690 |
| 2452 | IF(PTOT.LE.DP) DP=PTOT-0.2 |
| 2453 | DE=DP |
| 2454 | |
| 2455 | IF(KFTJ(JT,I).NE.21) THEN |
| 2456 | PRSHU=PT(LQT(MT),1)**2+PT(LQT(MT),2)**2 |
| 2457 | & +PT(LQT(MT),3)**2 |
| 2458 | DE=SQRT(PJTM(JT,I)**2+PTOT**2) |
| 2459 | & -SQRT(PJTM(JT,I)**2+(PTOT-DP)**2) |
| 2460 | ERSHU=(PT(LQT(MT),4)+DE-DP)**2 |
| 2461 | AMSHU=ERSHU-PRSHU |
| 2462 | IF(AMSHU.LT.HIPR1(1)*HIPR1(1)) GO TO 610 |
| 2463 | PT(LQT(MT),4)=SQRT(ERSHU) |
| 2464 | PT(LQT(MT),5)=SQRT(AMSHU) |
| 2465 | ENDIF |
| 2466 | C ********reshuffle the energy when jet has mass |
| 2467 | |
| 2468 | R0=RDT(MT) |
| 2469 | DP1=DP*V1 |
| 2470 | DP2=DP*V2 |
| 2471 | DP3=DP*V3 |
| 2472 | C ********momentum and energy transfer from jet |
| 2473 | NTJ(LQT(MT))=NTJ(LQT(MT))+1 |
| 2474 | KFTJ(LQT(MT),NTJ(LQT(MT)))=21 |
| 2475 | PJTX(LQT(MT),NTJ(LQT(MT)))=DP1 |
| 2476 | PJTY(LQT(MT),NTJ(LQT(MT)))=DP2 |
| 2477 | PJTZ(LQT(MT),NTJ(LQT(MT)))=DP3 |
| 2478 | PJTE(LQT(MT),NTJ(LQT(MT)))=DP |
| 2479 | PJTM(LQT(MT),NTJ(LQT(MT)))=0.0 |
| 2480 | |
| 2481 | 660 PJTX(JT,I)=(PTOT-DP)*V1 |
| 2482 | PJTY(JT,I)=(PTOT-DP)*V2 |
| 2483 | PJTZ(JT,I)=(PTOT-DP)*V3 |
| 2484 | PJTE(JT,I)=PJTE(JT,I)-DE |
| 2485 | |
| 2486 | PTOT=PTOT-DP |
| 2487 | NQ=NQ+1 |
| 2488 | GO TO 600 |
| 2489 | 690 CONTINUE |
| 2490 | RETURN |
| 2491 | C******************************************************** |
| 2492 | C Q-QBAR jet interaction |
| 2493 | C******************************************************** |
| 2494 | 2000 ISG=JPJT |
| 2495 | IF(IASG(ISG,3).NE.1) RETURN |
| 2496 | C |
| 2497 | JP=IASG(ISG,1) |
| 2498 | JT=IASG(ISG,2) |
| 2499 | XJ=(YP(1,JP)+BBX+YT(1,JT))/2.0 |
| 2500 | YJ=(YP(2,JP)+BBY+YT(2,JT))/2.0 |
| 2501 | DO 2690 I=1,NJSG(ISG) |
| 2502 | PTJET0=SQRT(PXSG(ISG,I)**2+PYSG(ISG,I)**2) |
| 2503 | IF(PTJET0.LE.HIPR1(11).OR.PESG(ISG,I).LT.HIPR1(1)) |
| 2504 | & GO TO 2690 |
| 2505 | PTOT=SQRT(PTJET0*PTJET0+PZSG(ISG,I)**2) |
| 2506 | IF(PTOT.LT.MAX(HIPR1(1),HIPR1(8))) GO TO 2690 |
| 2507 | PHIQ=ULANGL(PXSG(ISG,I),PYSG(ISG,I)) |
| 2508 | KP=0 |
| 2509 | DO 2500 I2=1,IHNT2(1) |
| 2510 | IF(NFP(I2,5).NE.3.OR.I2.EQ.JP) GO TO 2500 |
| 2511 | DX=YP(1,I2)+BBX-XJ |
| 2512 | DY=YP(2,I2)+BBY-YJ |
| 2513 | PHI=ULANGL(DX,DY) |
| 2514 | DPHI=ABS(PHI-PHIQ) |
| 2515 | c Uzhi: |
| 2516 | IF(DPHI.GE.HIPR1(40)) DPHI=2.*HIPR1(40)-DPHI |
| 2517 | IF(DPHI.GT.HIPR1(40)/2.0) GO TO 2500 |
| 2518 | RD0=SQRT(DX*DX+DY*DY) |
| 2519 | IF(RD0*SIN(DPHI).GT.HIPR1(12)) GO TO 2500 |
| 2520 | KP=KP+1 |
| 2521 | LQP(KP)=I2 |
| 2522 | RDP(KP)=COS(DPHI)*RD0 |
| 2523 | 2500 CONTINUE |
| 2524 | C******* rearrange according to decending rd************ |
| 2525 | DO 2510 I2=1,KP-1 |
| 2526 | DO 2510 J2=I2+1,KP |
| 2527 | IF(RDP(I2).LT.RDP(J2)) GO TO 2510 |
| 2528 | RD=RDP(I2) |
| 2529 | LQ=LQP(I2) |
| 2530 | RDP(I2)=RDP(J2) |
| 2531 | LQP(I2)=LQP(J2) |
| 2532 | RDP(J2)=RD |
| 2533 | LQP(J2)=LQ |
| 2534 | 2510 CONTINUE |
| 2535 | C****** find wounded targ which can interact with jet******** |
| 2536 | KT=0 |
| 2537 | DO 2520 I2=1,IHNT2(3) |
| 2538 | IF(NFT(I2,5).NE.3 .OR. I2.EQ.JT) GO TO 2520 |
| 2539 | DX=YT(1,I2)-XJ |
| 2540 | DY=YT(2,I2)-YJ |
| 2541 | PHI=ULANGL(DX,DY) |
| 2542 | DPHI=ABS(PHI-PHIQ) |
| 2543 | c Uzhi: |
| 2544 | IF(DPHI.GE.HIPR1(40)) DPHI=2.*HIPR1(40)-DPHI |
| 2545 | IF(DPHI.GT.HIPR1(40)/2.0) GO TO 2520 |
| 2546 | RD0=SQRT(DX*DX+DY*DY) |
| 2547 | IF(RD0*SIN(DPHI).GT.HIPR1(12)) GO TO 2520 |
| 2548 | KT=KT+1 |
| 2549 | LQT(KT)=I2 |
| 2550 | RDT(KT)=COS(DPHI)*RD0 |
| 2551 | 2520 CONTINUE |
| 2552 | C******* rearrange according to decending rd************ |
| 2553 | DO 2530 I2=1,KT-1 |
| 2554 | DO 2530 J2=I2+1,KT |
| 2555 | IF(RDT(I2).LT.RDT(J2)) GO TO 2530 |
| 2556 | RD=RDT(I2) |
| 2557 | LQ=LQT(I2) |
| 2558 | RDT(I2)=RDT(J2) |
| 2559 | LQT(I2)=LQT(J2) |
| 2560 | RDT(J2)=RD |
| 2561 | LQT(J2)=LQ |
| 2562 | 2530 CONTINUE |
| 2563 | |
| 2564 | MP=0 |
| 2565 | MT=0 |
| 2566 | NQ=0 |
| 2567 | DP=0.0 |
| 2568 | R0=0.0 |
| 2569 | PTOT=SQRT(PXSG(ISG,I)**2+PYSG(ISG,I)**2 |
| 2570 | & +PZSG(ISG,I)**2) |
| 2571 | V1=PXSG(ISG,I)/PTOT |
| 2572 | V2=PYSG(ISG,I)/PTOT |
| 2573 | V3=PZSG(ISG,I)/PTOT |
| 2574 | |
| 2575 | 2600 RN=RANART(NSEED) |
| 2576 | 2610 IF(MT.GE.KT .AND. MP.GE.KP) GO TO 2690 |
| 2577 | IF(MT.GE.KT) GO TO 2620 |
| 2578 | IF(MP.GE.KP) GO TO 2640 |
| 2579 | IF(RDP(MP+1).GT.RDT(MT+1)) GO TO 2640 |
| 2580 | 2620 MP=MP+1 |
| 2581 | DRR=RDP(MP)-R0 |
| 2582 | IF(RN.GE.1.0-EXP(-DRR/HIPR1(13))) GO TO 2610 |
| 2583 | DP=DRR*HIPR1(14)/2.0 |
| 2584 | IF(DP.LE.0.2) GO TO 2610 |
| 2585 | IF(PTOT.LE.0.4) GO TO 2690 |
| 2586 | IF(PTOT.LE.DP) DP=PTOT-0.2 |
| 2587 | DE=DP |
| 2588 | C |
| 2589 | IF(K2SG(ISG,I).NE.21) THEN |
| 2590 | IF(PTOT.LT.DP+HIPR1(1)) GO TO 2690 |
| 2591 | PRSHU=PP(LQP(MP),1)**2+PP(LQP(MP),2)**2 |
| 2592 | & +PP(LQP(MP),3)**2 |
| 2593 | DE=SQRT(PMSG(ISG,I)**2+PTOT**2) |
| 2594 | & -SQRT(PMSG(ISG,I)**2+(PTOT-DP)**2) |
| 2595 | ERSHU=(PP(LQP(MP),4)+DE-DP)**2 |
| 2596 | AMSHU=ERSHU-PRSHU |
| 2597 | IF(AMSHU.LT.HIPR1(1)*HIPR1(1)) GO TO 2610 |
| 2598 | PP(LQP(MP),4)=SQRT(ERSHU) |
| 2599 | PP(LQP(MP),5)=SQRT(AMSHU) |
| 2600 | ENDIF |
| 2601 | C ********reshuffle the energy when jet has mass |
| 2602 | C |
| 2603 | R0=RDP(MP) |
| 2604 | DP1=DP*V1 |
| 2605 | DP2=DP*V2 |
| 2606 | DP3=DP*V3 |
| 2607 | C ********momentum and energy transfer from jet |
| 2608 | NPJ(LQP(MP))=NPJ(LQP(MP))+1 |
| 2609 | KFPJ(LQP(MP),NPJ(LQP(MP)))=21 |
| 2610 | PJPX(LQP(MP),NPJ(LQP(MP)))=DP1 |
| 2611 | PJPY(LQP(MP),NPJ(LQP(MP)))=DP2 |
| 2612 | PJPZ(LQP(MP),NPJ(LQP(MP)))=DP3 |
| 2613 | PJPE(LQP(MP),NPJ(LQP(MP)))=DP |
| 2614 | PJPM(LQP(MP),NPJ(LQP(MP)))=0.0 |
| 2615 | |
| 2616 | GO TO 2660 |
| 2617 | |
| 2618 | 2640 MT=MT+1 |
| 2619 | DRR=RDT(MT)-R0 |
| 2620 | IF(RN.GE.1.0-EXP(-DRR/HIPR1(13))) GO TO 2610 |
| 2621 | DP=DRR*HIPR1(14) |
| 2622 | IF(DP.LE.0.2) GO TO 2610 |
| 2623 | IF(PTOT.LE.0.4) GO TO 2690 |
| 2624 | IF(PTOT.LE.DP) DP=PTOT-0.2 |
| 2625 | DE=DP |
| 2626 | |
| 2627 | IF(K2SG(ISG,I).NE.21) THEN |
| 2628 | IF(PTOT.LT.DP+HIPR1(1)) GO TO 2690 |
| 2629 | PRSHU=PT(LQT(MT),1)**2+PT(LQT(MT),2)**2 |
| 2630 | & +PT(LQT(MT),3)**2 |
| 2631 | DE=SQRT(PMSG(ISG,I)**2+PTOT**2) |
| 2632 | & -SQRT(PMSG(ISG,I)**2+(PTOT-DP)**2) |
| 2633 | ERSHU=(PT(LQT(MT),4)+DE-DP)**2 |
| 2634 | AMSHU=ERSHU-PRSHU |
| 2635 | IF(AMSHU.LT.HIPR1(1)*HIPR1(1)) GO TO 2610 |
| 2636 | PT(LQT(MT),4)=SQRT(ERSHU) |
| 2637 | PT(LQT(MT),5)=SQRT(AMSHU) |
| 2638 | ENDIF |
| 2639 | C ********reshuffle the energy when jet has mass |
| 2640 | |
| 2641 | R0=RDT(MT) |
| 2642 | DP1=DP*V1 |
| 2643 | DP2=DP*V2 |
| 2644 | DP3=DP*V3 |
| 2645 | C ********momentum and energy transfer from jet |
| 2646 | NTJ(LQT(MT))=NTJ(LQT(MT))+1 |
| 2647 | KFTJ(LQT(MT),NTJ(LQT(MT)))=21 |
| 2648 | PJTX(LQT(MT),NTJ(LQT(MT)))=DP1 |
| 2649 | PJTY(LQT(MT),NTJ(LQT(MT)))=DP2 |
| 2650 | PJTZ(LQT(MT),NTJ(LQT(MT)))=DP3 |
| 2651 | PJTE(LQT(MT),NTJ(LQT(MT)))=DP |
| 2652 | PJTM(LQT(MT),NTJ(LQT(MT)))=0.0 |
| 2653 | |
| 2654 | 2660 PXSG(ISG,I)=(PTOT-DP)*V1 |
| 2655 | PYSG(ISG,I)=(PTOT-DP)*V2 |
| 2656 | PZSG(ISG,I)=(PTOT-DP)*V3 |
| 2657 | PESG(ISG,I)=PESG(ISG,I)-DE |
| 2658 | |
| 2659 | PTOT=PTOT-DP |
| 2660 | NQ=NQ+1 |
| 2661 | GO TO 2600 |
| 2662 | 2690 CONTINUE |
| 2663 | RETURN |
| 2664 | END |
| 2665 | |
| 2666 | C |
| 2667 | C |
| 2668 | C |
| 2669 | C |
| 2670 | SUBROUTINE HIJFRG(JTP,NTP,IERROR) |
| 2671 | C NTP=1, fragment proj string, NTP=2, targ string, |
| 2672 | C NTP=3, independent |
| 2673 | C strings from jets. JTP is the line number of the string |
| 2674 | C*******Fragment all leadng strings of proj and targ************** |
| 2675 | C IHNT2(1)=atomic #, IHNT2(2)=proton #(=-1 if anti-proton) * |
| 2676 | C****************************************************************** |
| 2677 | PARAMETER (MAXSTR=150001) |
| 2678 | COMMON/HPARNT/HIPR1(100),IHPR2(50),HINT1(100),IHNT2(50) |
| 2679 | cc SAVE /HPARNT/ |
| 2680 | COMMON/HIJDAT/HIDAT0(10,10),HIDAT(10) |
| 2681 | cc SAVE /HIJDAT/ |
| 2682 | COMMON/HSTRNG/NFP(300,15),PP(300,15),NFT(300,15),PT(300,15) |
| 2683 | cc SAVE /HSTRNG/ |
| 2684 | COMMON/HJJET1/NPJ(300),KFPJ(300,500),PJPX(300,500), |
| 2685 | & PJPY(300,500),PJPZ(300,500),PJPE(300,500), |
| 2686 | & PJPM(300,500),NTJ(300),KFTJ(300,500), |
| 2687 | & PJTX(300,500),PJTY(300,500),PJTZ(300,500), |
| 2688 | & PJTE(300,500),PJTM(300,500) |
| 2689 | cc SAVE /HJJET1/ |
| 2690 | COMMON/HJJET2/NSG,NJSG(MAXSTR),IASG(MAXSTR,3),K1SG(MAXSTR,100), |
| 2691 | & K2SG(MAXSTR,100),PXSG(MAXSTR,100),PYSG(MAXSTR,100), |
| 2692 | & PZSG(MAXSTR,100),PESG(MAXSTR,100),PMSG(MAXSTR,100) |
| 2693 | cc SAVE /HJJET2/ |
| 2694 | C |
| 2695 | COMMON/LUJETSA/N,K(9000,5),P(9000,5),V(9000,5) |
| 2696 | cc SAVE /LUJETSA/ |
| 2697 | COMMON/LUDAT1A/MSTU(200),PARU(200),MSTJ(200),PARJ(200) |
| 2698 | cc SAVE /LUDAT1A/ |
| 2699 | COMMON/RNDF77/NSEED |
| 2700 | cc SAVE /RNDF77/ |
| 2701 | clin-4/11/01 soft: |
| 2702 | common/anim/nevent,isoft,isflag,izpc |
| 2703 | cc SAVE /anim/ |
| 2704 | SAVE |
| 2705 | |
| 2706 | cbz3/12/99 |
| 2707 | c.....set up fragmentation function according to the number of collisions |
| 2708 | c.....a wounded nucleon has suffered |
| 2709 | c IF (NTP .EQ. 1) THEN |
| 2710 | c NCOLL = NFP(JTP, 11) |
| 2711 | c ELSE IF (NTP .EQ. 2) THEN |
| 2712 | c NCOLL = NFT(JTP, 11) |
| 2713 | c ELSE IF (NTP .EQ. 3) THEN |
| 2714 | c NCOLL = (NFP(IASG(JTP,1), 11) + NFT(IASG(JTP,2), 11)) / 2 |
| 2715 | c END IF |
| 2716 | c IF (NCOLL .LE. 1) THEN |
| 2717 | c PARJ(5) = 0.5 |
| 2718 | c ELSE IF (NCOLL .EQ. 2) THEN |
| 2719 | c PARJ(5) = 0.75 |
| 2720 | c ELSE IF (NCOLL .EQ. 3) THEN |
| 2721 | c PARJ(5) = 1.17 |
| 2722 | c ELSE IF (NCOLL .EQ. 4) THEN |
| 2723 | c PARJ(5) = 2.0 |
| 2724 | c ELSE IF (NCOLL .EQ. 5) THEN |
| 2725 | c PARJ(5) = 4.5 |
| 2726 | c ELSE IF (NCOLL .GE. 6) THEN |
| 2727 | c PARJ(5) = 49.5 |
| 2728 | c END IF |
| 2729 | c PARJ(5) = 0.5 |
| 2730 | cbz3/12/99 end |
| 2731 | |
| 2732 | IERROR=0 |
| 2733 | CALL LUEDIT(0) |
| 2734 | N=0 |
| 2735 | C ********initialize the document lines |
| 2736 | IF(NTP.EQ.3) THEN |
| 2737 | ISG=JTP |
| 2738 | N=NJSG(ISG) |
| 2739 | DO 100 I=1,NJSG(ISG) |
| 2740 | K(I,1)=K1SG(ISG,I) |
| 2741 | K(I,2)=K2SG(ISG,I) |
| 2742 | P(I,1)=PXSG(ISG,I) |
| 2743 | P(I,2)=PYSG(ISG,I) |
| 2744 | P(I,3)=PZSG(ISG,I) |
| 2745 | P(I,4)=PESG(ISG,I) |
| 2746 | P(I,5)=PMSG(ISG,I) |
| 2747 | 100 CONTINUE |
| 2748 | |
| 2749 | C IF(IHPR2(1).GT.0) CALL ATTRAD(IERROR) |
| 2750 | c IF(IERROR.NE.0) RETURN |
| 2751 | C CALL LULIST(1) |
| 2752 | if(isoft.ne.2.or.isflag.ne.0) CALL LUEXEC |
| 2753 | RETURN |
| 2754 | ENDIF |
| 2755 | C |
| 2756 | IF(NTP.EQ.2) GO TO 200 |
| 2757 | IF(JTP.GT.IHNT2(1)) RETURN |
| 2758 | IF(NFP(JTP,5).NE.3.AND.NFP(JTP,3).NE.0 |
| 2759 | & .AND.NPJ(JTP).EQ.0.AND.NFP(JTP,10).EQ.0) GO TO 1000 |
| 2760 | IF(NFP(JTP,15).EQ.-1) THEN |
| 2761 | KF1=NFP(JTP,2) |
| 2762 | KF2=NFP(JTP,1) |
| 2763 | PQ21=PP(JTP,6) |
| 2764 | PQ22=PP(JTP,7) |
| 2765 | PQ11=PP(JTP,8) |
| 2766 | PQ12=PP(JTP,9) |
| 2767 | AM1=PP(JTP,15) |
| 2768 | AM2=PP(JTP,14) |
| 2769 | ELSE |
| 2770 | KF1=NFP(JTP,1) |
| 2771 | KF2=NFP(JTP,2) |
| 2772 | PQ21=PP(JTP,8) |
| 2773 | PQ22=PP(JTP,9) |
| 2774 | PQ11=PP(JTP,6) |
| 2775 | PQ12=PP(JTP,7) |
| 2776 | AM1=PP(JTP,14) |
| 2777 | AM2=PP(JTP,15) |
| 2778 | ENDIF |
| 2779 | |
| 2780 | C ********for NFP(JTP,15)=-1 NFP(JTP,1) IS IN -Z DIRECTION |
| 2781 | PB1=PQ11+PQ21 |
| 2782 | PB2=PQ12+PQ22 |
| 2783 | PB3=PP(JTP,3) |
| 2784 | PECM=PP(JTP,5) |
| 2785 | BTZ=PB3/PP(JTP,4) |
| 2786 | IF((ABS(PB1-PP(JTP,1)).GT.0.01.OR. |
| 2787 | & ABS(PB2-PP(JTP,2)).GT.0.01).AND.IHPR2(10).NE.0) |
| 2788 | & WRITE(6,*) ' Pt of Q and QQ do not sum to the total',jtp |
| 2789 | & ,ntp,pq11,pq21,pb1,'*',pq12,pq22,pb2,'*',pp(JTP,1),pp(JTP,2) |
| 2790 | GO TO 300 |
| 2791 | |
| 2792 | 200 IF(JTP.GT.IHNT2(3)) RETURN |
| 2793 | IF(NFT(JTP,5).NE.3.AND.NFT(JTP,3).NE.0 |
| 2794 | & .AND.NTJ(JTP).EQ.0.AND.NFT(JTP,10).EQ.0) GO TO 1200 |
| 2795 | IF(NFT(JTP,15).EQ.1) THEN |
| 2796 | KF1=NFT(JTP,1) |
| 2797 | KF2=NFT(JTP,2) |
| 2798 | PQ11=PT(JTP,6) |
| 2799 | PQ12=PT(JTP,7) |
| 2800 | PQ21=PT(JTP,8) |
| 2801 | PQ22=PT(JTP,9) |
| 2802 | AM1=PT(JTP,14) |
| 2803 | AM2=PT(JTP,15) |
| 2804 | ELSE |
| 2805 | KF1=NFT(JTP,2) |
| 2806 | KF2=NFT(JTP,1) |
| 2807 | PQ11=PT(JTP,8) |
| 2808 | PQ12=PT(JTP,9) |
| 2809 | PQ21=PT(JTP,6) |
| 2810 | PQ22=PT(JTP,7) |
| 2811 | AM1=PT(JTP,15) |
| 2812 | AM2=PT(JTP,14) |
| 2813 | ENDIF |
| 2814 | C ********for NFT(JTP,15)=1 NFT(JTP,1) IS IN +Z DIRECTION |
| 2815 | PB1=PQ11+PQ21 |
| 2816 | PB2=PQ12+PQ22 |
| 2817 | PB3=PT(JTP,3) |
| 2818 | PECM=PT(JTP,5) |
| 2819 | BTZ=PB3/PT(JTP,4) |
| 2820 | |
| 2821 | IF((ABS(PB1-PT(JTP,1)).GT.0.01.OR. |
| 2822 | & ABS(PB2-PT(JTP,2)).GT.0.01).AND.IHPR2(10).NE.0) |
| 2823 | & WRITE(6,*) ' Pt of Q and QQ do not sum to the total',jtp |
| 2824 | & ,ntp,pq11,pq21,pb1,'*',pq12,pq22,pb2,'*',pt(JTP,1),pt(JTP,2) |
| 2825 | 300 IF(PECM.LT.HIPR1(1)) THEN |
| 2826 | IERROR=1 |
| 2827 | IF(IHPR2(10).EQ.0) RETURN |
| 2828 | WRITE(6,*) ' ECM=',PECM,' energy of the string is too small' |
| 2829 | clin: |
| 2830 | write (6,*) 'JTP,NTP,pq=',JTP,NTP,pq11,pq12,pq21,pq22 |
| 2831 | RETURN |
| 2832 | ENDIF |
| 2833 | AMT=PECM**2+PB1**2+PB2**2 |
| 2834 | AMT1=AM1**2+PQ11**2+PQ12**2 |
| 2835 | AMT2=AM2**2+PQ21**2+PQ22**2 |
| 2836 | PZCM=SQRT(ABS(AMT**2+AMT1**2+AMT2**2-2.0*AMT*AMT1 |
| 2837 | & -2.0*AMT*AMT2-2.0*AMT1*AMT2))/2.0/SQRT(AMT) |
| 2838 | C *******PZ of end-partons in c.m. frame of the string |
| 2839 | K(1,1)=2 |
| 2840 | K(1,2)=KF1 |
| 2841 | P(1,1)=PQ11 |
| 2842 | P(1,2)=PQ12 |
| 2843 | P(1,3)=PZCM |
| 2844 | P(1,4)=SQRT(AMT1+PZCM**2) |
| 2845 | P(1,5)=AM1 |
| 2846 | K(2,1)=1 |
| 2847 | K(2,2)=KF2 |
| 2848 | P(2,1)=PQ21 |
| 2849 | P(2,2)=PQ22 |
| 2850 | P(2,3)=-PZCM |
| 2851 | P(2,4)=SQRT(AMT2+PZCM**2) |
| 2852 | P(2,5)=AM2 |
| 2853 | N=2 |
| 2854 | C***** |
| 2855 | CALL HIROBO(0.0,0.0,0.0,0.0,BTZ) |
| 2856 | JETOT=0 |
| 2857 | IF((PQ21**2+PQ22**2).GT.(PQ11**2+PQ12**2)) THEN |
| 2858 | PMAX1=P(2,1) |
| 2859 | PMAX2=P(2,2) |
| 2860 | PMAX3=P(2,3) |
| 2861 | ELSE |
| 2862 | PMAX1=P(1,1) |
| 2863 | PMAX2=P(1,2) |
| 2864 | PMAX3=P(1,3) |
| 2865 | ENDIF |
| 2866 | IF(NTP.EQ.1) THEN |
| 2867 | PP(JTP,10)=PMAX1 |
| 2868 | PP(JTP,11)=PMAX2 |
| 2869 | PP(JTP,12)=PMAX3 |
| 2870 | ELSE IF(NTP.EQ.2) THEN |
| 2871 | PT(JTP,10)=PMAX1 |
| 2872 | PT(JTP,11)=PMAX2 |
| 2873 | PT(JTP,12)=PMAX3 |
| 2874 | ENDIF |
| 2875 | C*******************attach produced jets to the leadng partons**** |
| 2876 | IF(NTP.EQ.1.AND.NPJ(JTP).NE.0) THEN |
| 2877 | JETOT=NPJ(JTP) |
| 2878 | C IF(NPJ(JTP).GE.2) CALL HIJSRT(JTP,1) |
| 2879 | C ********sort jets in order of y |
| 2880 | IEX=0 |
| 2881 | IF((ABS(KF1).GT.1000.AND.KF1.LT.0) |
| 2882 | & .OR.(ABS(KF1).LT.1000.AND.KF1.GT.0)) IEX=1 |
| 2883 | DO 520 I=N,2,-1 |
| 2884 | DO 520 J=1,5 |
| 2885 | II=NPJ(JTP)+I |
| 2886 | K(II,J)=K(I,J) |
| 2887 | P(II,J)=P(I,J) |
| 2888 | V(II,J)=V(I,J) |
| 2889 | 520 CONTINUE |
| 2890 | |
| 2891 | DO 540 I=1,NPJ(JTP) |
| 2892 | DO 542 J=1,5 |
| 2893 | K(I+1,J)=0 |
| 2894 | V(I+1,J)=0 |
| 2895 | 542 CONTINUE |
| 2896 | I0=I |
| 2897 | clin-4/12/01: IF(IEX.EQ.1) I0=NPJ(JTP)-I+1 |
| 2898 | IF(IEX.EQ.1.and.(isoft.ne.2.or.isflag.ne.0)) |
| 2899 | 1 I0=NPJ(JTP)-I+1 |
| 2900 | C ********reverse the order of jets |
| 2901 | KK1=KFPJ(JTP,I0) |
| 2902 | K(I+1,1)=2 |
| 2903 | K(I+1,2)=KK1 |
| 2904 | IF(KK1.NE.21 .AND. KK1.NE.0) K(I+1,1)= |
| 2905 | & 1+(ABS(KK1)+(2*IEX-1)*KK1)/2/ABS(KK1) |
| 2906 | P(I+1,1)=PJPX(JTP,I0) |
| 2907 | P(I+1,2)=PJPY(JTP,I0) |
| 2908 | P(I+1,3)=PJPZ(JTP,I0) |
| 2909 | P(I+1,4)=PJPE(JTP,I0) |
| 2910 | P(I+1,5)=PJPM(JTP,I0) |
| 2911 | 540 CONTINUE |
| 2912 | N=N+NPJ(JTP) |
| 2913 | ELSE IF(NTP.EQ.2.AND.NTJ(JTP).NE.0) THEN |
| 2914 | JETOT=NTJ(JTP) |
| 2915 | c IF(NTJ(JTP).GE.2) CALL HIJSRT(JTP,2) |
| 2916 | C ********sort jets in order of y |
| 2917 | IEX=1 |
| 2918 | IF((ABS(KF2).GT.1000.AND.KF2.LT.0) |
| 2919 | & .OR.(ABS(KF2).LT.1000.AND.KF2.GT.0)) IEX=0 |
| 2920 | DO 560 I=N,2,-1 |
| 2921 | DO 560 J=1,5 |
| 2922 | II=NTJ(JTP)+I |
| 2923 | K(II,J)=K(I,J) |
| 2924 | P(II,J)=P(I,J) |
| 2925 | V(II,J)=V(I,J) |
| 2926 | 560 CONTINUE |
| 2927 | DO 580 I=1,NTJ(JTP) |
| 2928 | DO 582 J=1,5 |
| 2929 | K(I+1,J)=0 |
| 2930 | V(I+1,J)=0 |
| 2931 | 582 CONTINUE |
| 2932 | I0=I |
| 2933 | clin-4/12/01: IF(IEX.EQ.1) I0=NTJ(JTP)-I+1 |
| 2934 | IF(IEX.EQ.1.and.(isoft.ne.2.or.isflag.ne.0)) |
| 2935 | 1 I0=NTJ(JTP)-I+1 |
| 2936 | C ********reverse the order of jets |
| 2937 | KK1=KFTJ(JTP,I0) |
| 2938 | K(I+1,1)=2 |
| 2939 | K(I+1,2)=KK1 |
| 2940 | IF(KK1.NE.21 .AND. KK1.NE.0) K(I+1,1)= |
| 2941 | & 1+(ABS(KK1)+(2*IEX-1)*KK1)/2/ABS(KK1) |
| 2942 | P(I+1,1)=PJTX(JTP,I0) |
| 2943 | P(I+1,2)=PJTY(JTP,I0) |
| 2944 | P(I+1,3)=PJTZ(JTP,I0) |
| 2945 | P(I+1,4)=PJTE(JTP,I0) |
| 2946 | P(I+1,5)=PJTM(JTP,I0) |
| 2947 | 580 CONTINUE |
| 2948 | N=N+NTJ(JTP) |
| 2949 | ENDIF |
| 2950 | IF(IHPR2(1).GT.0.AND.RANART(NSEED).LE.HIDAT(3)) THEN |
| 2951 | HDAT20=HIDAT(2) |
| 2952 | HPR150=HIPR1(5) |
| 2953 | IF(IHPR2(8).EQ.0.AND.IHPR2(3).EQ.0.AND.IHPR2(9).EQ.0) |
| 2954 | & HIDAT(2)=2.0 |
| 2955 | IF(HINT1(1).GE.1000.0.AND.JETOT.EQ.0)THEN |
| 2956 | HIDAT(2)=3.0 |
| 2957 | HIPR1(5)=5.0 |
| 2958 | ENDIF |
| 2959 | CALL ATTRAD(IERROR) |
| 2960 | HIDAT(2)=HDAT20 |
| 2961 | HIPR1(5)=HPR150 |
| 2962 | ELSE IF(JETOT.EQ.0.AND.IHPR2(1).GT.0.AND. |
| 2963 | & HINT1(1).GE.1000.0.AND. |
| 2964 | & RANART(NSEED).LE.0.8) THEN |
| 2965 | HDAT20=HIDAT(2) |
| 2966 | HPR150=HIPR1(5) |
| 2967 | HIDAT(2)=3.0 |
| 2968 | HIPR1(5)=5.0 |
| 2969 | IF(IHPR2(8).EQ.0.AND.IHPR2(3).EQ.0.AND.IHPR2(9).EQ.0) |
| 2970 | & HIDAT(2)=2.0 |
| 2971 | CALL ATTRAD(IERROR) |
| 2972 | HIDAT(2)=HDAT20 |
| 2973 | HIPR1(5)=HPR150 |
| 2974 | ENDIF |
| 2975 | IF(IERROR.NE.0) RETURN |
| 2976 | C ******** conduct soft radiations |
| 2977 | C**************************** |
| 2978 | C |
| 2979 | C |
| 2980 | clin-4/11/01 soft: |
| 2981 | c CALL LUEXEC |
| 2982 | if(isoft.ne.2.or.isflag.ne.0) CALL LUEXEC |
| 2983 | |
| 2984 | RETURN |
| 2985 | |
| 2986 | 1000 N=1 |
| 2987 | K(1,1)=1 |
| 2988 | K(1,2)=NFP(JTP,3) |
| 2989 | DO 1100 JJ=1,5 |
| 2990 | P(1,JJ)=PP(JTP,JJ) |
| 2991 | 1100 CONTINUE |
| 2992 | C ********proj remain as a nucleon or delta |
| 2993 | clin-4/11/01 soft: |
| 2994 | c CALL LUEXEC |
| 2995 | if(isoft.ne.2.or.isflag.ne.0) CALL LUEXEC |
| 2996 | |
| 2997 | C call lulist(1) |
| 2998 | RETURN |
| 2999 | C |
| 3000 | 1200 N=1 |
| 3001 | K(1,1)=1 |
| 3002 | K(1,2)=NFT(JTP,3) |
| 3003 | DO 1300 JJ=1,5 |
| 3004 | P(1,JJ)=PT(JTP,JJ) |
| 3005 | 1300 CONTINUE |
| 3006 | C ********targ remain as a nucleon or delta |
| 3007 | clin-4/11/01 soft: |
| 3008 | c CALL LUEXEC |
| 3009 | if(isoft.ne.2.or.isflag.ne.0) CALL LUEXEC |
| 3010 | |
| 3011 | C call lulist(1) |
| 3012 | RETURN |
| 3013 | END |
| 3014 | C |
| 3015 | C |
| 3016 | C |
| 3017 | C |
| 3018 | C**************************************************************** |
| 3019 | C conduct soft radiation according to dipole approxiamtion |
| 3020 | C**************************************************************** |
| 3021 | SUBROUTINE ATTRAD(IERROR) |
| 3022 | C |
| 3023 | COMMON/HPARNT/HIPR1(100),IHPR2(50),HINT1(100),IHNT2(50) |
| 3024 | cc SAVE /HPARNT/ |
| 3025 | COMMON/HIJDAT/HIDAT0(10,10),HIDAT(10) |
| 3026 | cc SAVE /HIJDAT/ |
| 3027 | COMMON/LUJETSA/N,K(9000,5),P(9000,5),V(9000,5) |
| 3028 | cc SAVE /LUJETSA/ |
| 3029 | COMMON/RNDF77/NSEED |
| 3030 | cc SAVE /RNDF77/ |
| 3031 | SAVE |
| 3032 | IERROR=0 |
| 3033 | |
| 3034 | C.....S INVARIANT MASS-SQUARED BETWEEN PARTONS I AND I+1...... |
| 3035 | C.....SM IS THE LARGEST MASS-SQUARED.... |
| 3036 | |
| 3037 | 40 SM=0. |
| 3038 | JL=1 |
| 3039 | DO 30 I=1,N-1 |
| 3040 | S=2.*(P(I,4)*P(I+1,4)-P(I,1)*P(I+1,1)-P(I,2)*P(I+1,2) |
| 3041 | & -P(I,3)*P(I+1,3))+P(I,5)**2+P(I+1,5)**2 |
| 3042 | IF(S.LT.0.) S=0. |
| 3043 | WP=SQRT(S)-1.5*(P(I,5)+P(I+1,5)) |
| 3044 | IF(WP.GT.SM) THEN |
| 3045 | PBT1=P(I,1)+P(I+1,1) |
| 3046 | PBT2=P(I,2)+P(I+1,2) |
| 3047 | PBT3=P(I,3)+P(I+1,3) |
| 3048 | PBT4=P(I,4)+P(I+1,4) |
| 3049 | BTT=(PBT1**2+PBT2**2+PBT3**2)/PBT4**2 |
| 3050 | IF(BTT.GE.1.0-1.0E-10) GO TO 30 |
| 3051 | IF((I.NE.1.OR.I.NE.N-1).AND. |
| 3052 | & (K(I,2).NE.21.AND.K(I+1,2).NE.21)) GO TO 30 |
| 3053 | JL=I |
| 3054 | SM=WP |
| 3055 | ENDIF |
| 3056 | 30 CONTINUE |
| 3057 | S=(SM+1.5*(P(JL,5)+P(JL+1,5)))**2 |
| 3058 | IF(SM.LT.HIPR1(5)) GOTO 2 |
| 3059 | |
| 3060 | C.....MAKE PLACE FOR ONE GLUON..... |
| 3061 | IF(JL+1.EQ.N) GOTO 190 |
| 3062 | DO 160 J=N,JL+2,-1 |
| 3063 | K(J+1,1)=K(J,1) |
| 3064 | K(J+1,2)=K(J,2) |
| 3065 | DO 150 M=1,5 |
| 3066 | 150 P(J+1,M)=P(J,M) |
| 3067 | 160 CONTINUE |
| 3068 | 190 N=N+1 |
| 3069 | |
| 3070 | C.....BOOST TO REST SYSTEM FOR PARTICLES JL AND JL+1..... |
| 3071 | P1=P(JL,1)+P(JL+1,1) |
| 3072 | P2=P(JL,2)+P(JL+1,2) |
| 3073 | P3=P(JL,3)+P(JL+1,3) |
| 3074 | P4=P(JL,4)+P(JL+1,4) |
| 3075 | BEX=-P1/P4 |
| 3076 | BEY=-P2/P4 |
| 3077 | BEZ=-P3/P4 |
| 3078 | IMIN=JL |
| 3079 | IMAX=JL+1 |
| 3080 | CALL ATROBO(0.,0.,BEX,BEY,BEZ,IMIN,IMAX,IERROR) |
| 3081 | IF(IERROR.NE.0) RETURN |
| 3082 | C.....ROTATE TO Z-AXIS.... |
| 3083 | CTH=P(JL,3)/SQRT(P(JL,4)**2-P(JL,5)**2) |
| 3084 | IF(ABS(CTH).GT.1.0) CTH=MAX(-1.,MIN(1.,CTH)) |
| 3085 | THETA=ACOS(CTH) |
| 3086 | PHI=ULANGL(P(JL,1),P(JL,2)) |
| 3087 | CALL ATROBO(0.,-PHI,0.,0.,0.,IMIN,IMAX,IERROR) |
| 3088 | CALL ATROBO(-THETA,0.,0.,0.,0.,IMIN,IMAX,IERROR) |
| 3089 | |
| 3090 | C.....CREATE ONE GLUON AND ORIENTATE..... |
| 3091 | |
| 3092 | 1 CALL AR3JET(S,X1,X3,JL) |
| 3093 | CALL ARORIE(S,X1,X3,JL) |
| 3094 | IF(HIDAT(2).GT.0.0) THEN |
| 3095 | PTG1=SQRT(P(JL,1)**2+P(JL,2)**2) |
| 3096 | PTG2=SQRT(P(JL+1,1)**2+P(JL+1,2)**2) |
| 3097 | PTG3=SQRT(P(JL+2,1)**2+P(JL+2,2)**2) |
| 3098 | PTG=MAX(PTG1,PTG2,PTG3) |
| 3099 | IF(PTG.GT.HIDAT(2)) THEN |
| 3100 | FMFACT=EXP(-(PTG**2-HIDAT(2)**2)/HIPR1(2)**2) |
| 3101 | IF(RANART(NSEED).GT.FMFACT) GO TO 1 |
| 3102 | ENDIF |
| 3103 | ENDIF |
| 3104 | C.....ROTATE AND BOOST BACK..... |
| 3105 | IMIN=JL |
| 3106 | IMAX=JL+2 |
| 3107 | CALL ATROBO(THETA,PHI,-BEX,-BEY,-BEZ,IMIN,IMAX,IERROR) |
| 3108 | IF(IERROR.NE.0) RETURN |
| 3109 | C.....ENUMERATE THE GLUONS..... |
| 3110 | K(JL+2,1)=K(JL+1,1) |
| 3111 | K(JL+2,2)=K(JL+1,2) |
| 3112 | K(JL+2,3)=K(JL+1,3) |
| 3113 | K(JL+2,4)=K(JL+1,4) |
| 3114 | K(JL+2,5)=K(JL+1,5) |
| 3115 | P(JL+2,5)=P(JL+1,5) |
| 3116 | K(JL+1,1)=2 |
| 3117 | K(JL+1,2)=21 |
| 3118 | K(JL+1,3)=0 |
| 3119 | K(JL+1,4)=0 |
| 3120 | K(JL+1,5)=0 |
| 3121 | P(JL+1,5)=0. |
| 3122 | C----THETA FUNCTION DAMPING OF THE EMITTED GLUONS. FOR HADRON-HADRON. |
| 3123 | C----R0=VFR(2) |
| 3124 | C IF(VFR(2).GT.0.) THEN |
| 3125 | C PTG=SQRT(P(JL+1,1)**2+P(JL+1,2)**2) |
| 3126 | C PTGMAX=WSTRI/2. |
| 3127 | C DOPT=SQRT((4.*PAR(71)*VFR(2))/WSTRI) |
| 3128 | C PTOPT=(DOPT*WSTRI)/(2.*VFR(2)) |
| 3129 | C IF(PTG.GT.PTOPT) IORDER=IORDER-1 |
| 3130 | C IF(PTG.GT.PTOPT) GOTO 1 |
| 3131 | C ENDIF |
| 3132 | C----- |
| 3133 | IF(SM.GE.HIPR1(5)) GOTO 40 |
| 3134 | |
| 3135 | 2 K(1,1)=2 |
| 3136 | K(1,3)=0 |
| 3137 | K(1,4)=0 |
| 3138 | K(1,5)=0 |
| 3139 | K(N,1)=1 |
| 3140 | K(N,3)=0 |
| 3141 | K(N,4)=0 |
| 3142 | K(N,5)=0 |
| 3143 | |
| 3144 | RETURN |
| 3145 | END |
| 3146 | |
| 3147 | |
| 3148 | SUBROUTINE AR3JET(S,X1,X3,JL) |
| 3149 | C |
| 3150 | COMMON/HPARNT/HIPR1(100),IHPR2(50),HINT1(100),IHNT2(50) |
| 3151 | cc SAVE /HPARNT/ |
| 3152 | COMMON/LUJETSA/N,K(9000,5),P(9000,5),V(9000,5) |
| 3153 | cc SAVE /LUJETSA/ |
| 3154 | COMMON/RNDF77/NSEED |
| 3155 | cc SAVE /RNDF77/ |
| 3156 | SAVE |
| 3157 | C |
| 3158 | C=1./3. |
| 3159 | IF(K(JL,2).NE.21 .AND. K(JL+1,2).NE.21) C=8./27. |
| 3160 | EXP1=3 |
| 3161 | EXP3=3 |
| 3162 | IF(K(JL,2).NE.21) EXP1=2 |
| 3163 | IF(K(JL+1,2).NE.21) EXP3=2 |
| 3164 | A=0.24**2/S |
| 3165 | YMA=ALOG(.5/SQRT(A)+SQRT(.25/A-1)) |
| 3166 | D=4.*C*YMA |
| 3167 | SM1=P(JL,5)**2/S |
| 3168 | SM3=P(JL+1,5)**2/S |
| 3169 | XT2M=(1.-2.*SQRT(SM1)+SM1-SM3)*(1.-2.*SQRT(SM3)-SM1+SM3) |
| 3170 | XT2M=MIN(.25,XT2M) |
| 3171 | NTRY=0 |
| 3172 | 1 IF(NTRY.EQ.5000) THEN |
| 3173 | X1=.5*(2.*SQRT(SM1)+1.+SM1-SM3) |
| 3174 | X3=.5*(2.*SQRT(SM3)+1.-SM1+SM3) |
| 3175 | RETURN |
| 3176 | ENDIF |
| 3177 | NTRY=NTRY+1 |
| 3178 | |
| 3179 | XT2=A*(XT2M/A)**(RANART(NSEED)**(1./D)) |
| 3180 | |
| 3181 | YMAX=ALOG(.5/SQRT(XT2)+SQRT(.25/XT2-1.)) |
| 3182 | Y=(2.*RANART(NSEED)-1.)*YMAX |
| 3183 | X1=1.-SQRT(XT2)*EXP(Y) |
| 3184 | X3=1.-SQRT(XT2)*EXP(-Y) |
| 3185 | X2=2.-X1-X3 |
| 3186 | NEG=0 |
| 3187 | IF(K(JL,2).NE.21 .OR. K(JL+1,2).NE.21) THEN |
| 3188 | IF((1.-X1)*(1.-X2)*(1.-X3)-X2*SM1*(1.-X1)-X2*SM3*(1.-X3). |
| 3189 | & LE.0..OR.X1.LE.2.*SQRT(SM1)-SM1+SM3.OR.X3.LE.2.*SQRT(SM3) |
| 3190 | & -SM3+SM1) NEG=1 |
| 3191 | X1=X1+SM1-SM3 |
| 3192 | X3=X3-SM1+SM3 |
| 3193 | ENDIF |
| 3194 | IF(NEG.EQ.1) GOTO 1 |
| 3195 | |
| 3196 | FG=2.*YMAX*C*(X1**EXP1+X3**EXP3)/D |
| 3197 | XT2M=XT2 |
| 3198 | IF(FG.LT.RANART(NSEED)) GOTO 1 |
| 3199 | |
| 3200 | RETURN |
| 3201 | END |
| 3202 | C************************************************************* |
| 3203 | |
| 3204 | |
| 3205 | SUBROUTINE ARORIE(S,X1,X3,JL) |
| 3206 | C |
| 3207 | COMMON/HPARNT/HIPR1(100),IHPR2(50),HINT1(100),IHNT2(50) |
| 3208 | cc SAVE /HPARNT/ |
| 3209 | COMMON/LUJETSA/N,K(9000,5),P(9000,5),V(9000,5) |
| 3210 | cc SAVE /LUJETSA/ |
| 3211 | COMMON/RNDF77/NSEED |
| 3212 | cc SAVE /RNDF77/ |
| 3213 | SAVE |
| 3214 | C |
| 3215 | W=SQRT(S) |
| 3216 | X2=2.-X1-X3 |
| 3217 | E1=.5*X1*W |
| 3218 | E3=.5*X3*W |
| 3219 | P1=SQRT(E1**2-P(JL,5)**2) |
| 3220 | P3=SQRT(E3**2-P(JL+1,5)**2) |
| 3221 | CBET=1. |
| 3222 | IF(P1.GT.0..AND.P3.GT.0.) CBET=(P(JL,5)**2 |
| 3223 | & +P(JL+1,5)**2+2.*E1*E3-S*(1.-X2))/(2.*P1*P3) |
| 3224 | IF(ABS(CBET).GT.1.0) CBET=MAX(-1.,MIN(1.,CBET)) |
| 3225 | BET=ACOS(CBET) |
| 3226 | |
| 3227 | C.....MINIMIZE PT1-SQUARED PLUS PT3-SQUARED..... |
| 3228 | IF(P1.GE.P3) THEN |
| 3229 | PSI=.5*ULANGL(P1**2+P3**2*COS(2.*BET),-P3**2*SIN(2.*BET)) |
| 3230 | PT1=P1*SIN(PSI) |
| 3231 | PZ1=P1*COS(PSI) |
| 3232 | PT3=P3*SIN(PSI+BET) |
| 3233 | PZ3=P3*COS(PSI+BET) |
| 3234 | ELSE IF(P3.GT.P1) THEN |
| 3235 | PSI=.5*ULANGL(P3**2+P1**2*COS(2.*BET),-P1**2*SIN(2.*BET)) |
| 3236 | PT1=P1*SIN(BET+PSI) |
| 3237 | PZ1=-P1*COS(BET+PSI) |
| 3238 | PT3=P3*SIN(PSI) |
| 3239 | PZ3=-P3*COS(PSI) |
| 3240 | ENDIF |
| 3241 | |
| 3242 | DEL=2.0*HIPR1(40)*RANART(NSEED) |
| 3243 | P(JL,4)=E1 |
| 3244 | P(JL,1)=PT1*SIN(DEL) |
| 3245 | P(JL,2)=-PT1*COS(DEL) |
| 3246 | P(JL,3)=PZ1 |
| 3247 | P(JL+2,4)=E3 |
| 3248 | P(JL+2,1)=PT3*SIN(DEL) |
| 3249 | P(JL+2,2)=-PT3*COS(DEL) |
| 3250 | P(JL+2,3)=PZ3 |
| 3251 | P(JL+1,4)=W-E1-E3 |
| 3252 | P(JL+1,1)=-P(JL,1)-P(JL+2,1) |
| 3253 | P(JL+1,2)=-P(JL,2)-P(JL+2,2) |
| 3254 | P(JL+1,3)=-P(JL,3)-P(JL+2,3) |
| 3255 | RETURN |
| 3256 | END |
| 3257 | |
| 3258 | |
| 3259 | C |
| 3260 | C******************************************************************* |
| 3261 | C make boost and rotation to entries from IMIN to IMAX |
| 3262 | C******************************************************************* |
| 3263 | SUBROUTINE ATROBO(THE,PHI,BEX,BEY,BEZ,IMIN,IMAX,IERROR) |
| 3264 | COMMON/LUJETSA/N,K(9000,5),P(9000,5),V(9000,5) |
| 3265 | cc SAVE /LUJETSA/ |
| 3266 | DIMENSION ROT(3,3),PV(3) |
| 3267 | DOUBLE PRECISION DP(4),DBEX,DBEY,DBEZ,DGA,DGA2,DBEP,DGABEP |
| 3268 | SAVE |
| 3269 | IERROR=0 |
| 3270 | |
| 3271 | IF(IMIN.LE.0 .OR. IMAX.GT.N .OR. IMIN.GT.IMAX) RETURN |
| 3272 | |
| 3273 | IF(THE**2+PHI**2.GT.1E-20) THEN |
| 3274 | C...ROTATE (TYPICALLY FROM Z AXIS TO DIRECTION THETA,PHI) |
| 3275 | ROT(1,1)=COS(THE)*COS(PHI) |
| 3276 | ROT(1,2)=-SIN(PHI) |
| 3277 | ROT(1,3)=SIN(THE)*COS(PHI) |
| 3278 | ROT(2,1)=COS(THE)*SIN(PHI) |
| 3279 | ROT(2,2)=COS(PHI) |
| 3280 | ROT(2,3)=SIN(THE)*SIN(PHI) |
| 3281 | ROT(3,1)=-SIN(THE) |
| 3282 | ROT(3,2)=0. |
| 3283 | ROT(3,3)=COS(THE) |
| 3284 | DO 120 I=IMIN,IMAX |
| 3285 | C************** IF(MOD(K(I,1)/10000,10).GE.6) GOTO 120 |
| 3286 | DO 100 J=1,3 |
| 3287 | 100 PV(J)=P(I,J) |
| 3288 | DO 110 J=1,3 |
| 3289 | 110 P(I,J)=ROT(J,1)*PV(1)+ROT(J,2)*PV(2) |
| 3290 | & +ROT(J,3)*PV(3) |
| 3291 | 120 CONTINUE |
| 3292 | ENDIF |
| 3293 | |
| 3294 | IF(BEX**2+BEY**2+BEZ**2.GT.1E-20) THEN |
| 3295 | C...LORENTZ BOOST (TYPICALLY FROM REST TO MOMENTUM/ENERGY=BETA) |
| 3296 | DBEX=dble(BEX) |
| 3297 | DBEY=dble(BEY) |
| 3298 | DBEZ=dble(BEZ) |
| 3299 | DGA2=1D0-DBEX**2-DBEY**2-DBEZ**2 |
| 3300 | IF(DGA2.LE.0D0) THEN |
| 3301 | IERROR=1 |
| 3302 | RETURN |
| 3303 | ENDIF |
| 3304 | DGA=1D0/DSQRT(DGA2) |
| 3305 | DO 140 I=IMIN,IMAX |
| 3306 | C************* IF(MOD(K(I,1)/10000,10).GE.6) GOTO 140 |
| 3307 | DO 130 J=1,4 |
| 3308 | 130 DP(J)=dble(P(I,J)) |
| 3309 | DBEP=DBEX*DP(1)+DBEY*DP(2)+DBEZ*DP(3) |
| 3310 | DGABEP=DGA*(DGA*DBEP/(1D0+DGA)+DP(4)) |
| 3311 | P(I,1)=sngl(DP(1)+DGABEP*DBEX) |
| 3312 | P(I,2)=sngl(DP(2)+DGABEP*DBEY) |
| 3313 | P(I,3)=sngl(DP(3)+DGABEP*DBEZ) |
| 3314 | P(I,4)=sngl(DGA*(DP(4)+DBEP)) |
| 3315 | 140 CONTINUE |
| 3316 | ENDIF |
| 3317 | |
| 3318 | RETURN |
| 3319 | END |
| 3320 | C |
| 3321 | C |
| 3322 | C |
| 3323 | SUBROUTINE HIJHRD(JP,JT,JOUT,JFLG,IOPJT0) |
| 3324 | C |
| 3325 | C IOPTJET=1, ALL JET WILL FORM SINGLE STRING SYSTEM |
| 3326 | C 0, ONLY Q-QBAR JET FORM SINGLE STRING SYSTEM |
| 3327 | C*******Perform jets production and fragmentation when JP JT ******* |
| 3328 | C scatter. JOUT-> number of hard scatterings precede this one * |
| 3329 | C for the the same pair(JP,JT). JFLG->a flag to show whether * |
| 3330 | C jets can be produced (with valence quark=1,gluon=2, q-qbar=3)* |
| 3331 | C or not(0). Information of jets are in COMMON/ATTJET and * |
| 3332 | C /MINJET. ABS(NFP(JP,6)) is the total number jets produced by * |
| 3333 | C JP. If NFP(JP,6)<0 JP can not produce jet anymore. * |
| 3334 | C******************************************************************* |
| 3335 | PARAMETER (MAXSTR=150001) |
| 3336 | DIMENSION IP(100,2),IPQ(50),IPB(50),IT(100,2),ITQ(50),ITB(50) |
| 3337 | COMMON/hjcrdn/YP(3,300),YT(3,300) |
| 3338 | cc SAVE /hjcrdn/ |
| 3339 | COMMON/HPARNT/HIPR1(100),IHPR2(50),HINT1(100),IHNT2(50) |
| 3340 | cc SAVE /HPARNT/ |
| 3341 | COMMON/HIJDAT/HIDAT0(10,10),HIDAT(10) |
| 3342 | cc SAVE /HIJDAT/ |
| 3343 | COMMON/HSTRNG/NFP(300,15),PP(300,15),NFT(300,15),PT(300,15) |
| 3344 | cc SAVE /HSTRNG/ |
| 3345 | COMMON/HJJET1/NPJ(300),KFPJ(300,500),PJPX(300,500), |
| 3346 | & PJPY(300,500),PJPZ(300,500),PJPE(300,500), |
| 3347 | & PJPM(300,500),NTJ(300),KFTJ(300,500), |
| 3348 | & PJTX(300,500),PJTY(300,500),PJTZ(300,500), |
| 3349 | & PJTE(300,500),PJTM(300,500) |
| 3350 | cc SAVE /HJJET1/ |
| 3351 | COMMON/HJJET2/NSG,NJSG(MAXSTR),IASG(MAXSTR,3),K1SG(MAXSTR,100), |
| 3352 | & K2SG(MAXSTR,100),PXSG(MAXSTR,100),PYSG(MAXSTR,100), |
| 3353 | & PZSG(MAXSTR,100),PESG(MAXSTR,100),PMSG(MAXSTR,100) |
| 3354 | cc SAVE /HJJET2/ |
| 3355 | c COMMON/HJJET4/NDR,IADR(900,2),KFDR(900),PDR(900,5) |
| 3356 | COMMON/HJJET4/NDR,IADR(MAXSTR,2),KFDR(MAXSTR),PDR(MAXSTR,5) |
| 3357 | common/xydr/rtdr(MAXSTR,2) |
| 3358 | cc SAVE /HJJET4/ |
| 3359 | COMMON/RNDF77/NSEED |
| 3360 | cc SAVE /RNDF77/ |
| 3361 | C************************************ HIJING common block |
| 3362 | COMMON/LUJETSA/N,K(9000,5),P(9000,5),V(9000,5) |
| 3363 | cc SAVE /LUJETSA/ |
| 3364 | COMMON/LUDAT1A/MSTU(200),PARU(200),MSTJ(200),PARJ(200) |
| 3365 | cc SAVE /LUDAT1A/ |
| 3366 | COMMON/PYSUBSA/MSEL,MSUB(200),KFIN(2,-40:40),CKIN(200) |
| 3367 | cc SAVE /PYSUBSA/ |
| 3368 | COMMON/PYPARSA/MSTP(200),PARP(200),MSTI(200),PARI(200) |
| 3369 | cc SAVE /PYPARSA/ |
| 3370 | COMMON/PYINT1A/MINT(400),VINT(400) |
| 3371 | cc SAVE /PYINT1A/ |
| 3372 | COMMON/PYINT2A/ISET(200),KFPR(200,2),COEF(200,20),ICOL(40,4,2) |
| 3373 | cc SAVE /PYINT2A/ |
| 3374 | COMMON/PYINT5A/NGEN(0:200,3),XSEC(0:200,3) |
| 3375 | cc SAVE /PYINT5A/ |
| 3376 | COMMON/HPINT/MINT4,MINT5,ATCO(200,20),ATXS(0:200) |
| 3377 | cc SAVE /HPINT/ |
| 3378 | SAVE |
| 3379 | C*********************************** LU common block |
| 3380 | MXJT=500 |
| 3381 | C SIZE OF COMMON BLOCK FOR # OF PARTON PER STRING |
| 3382 | MXSG=900 |
| 3383 | C SIZE OF COMMON BLOCK FOR # OF SINGLE STRINGS |
| 3384 | MXSJ=100 |
| 3385 | C SIZE OF COMMON BLOCK FOR # OF PARTON PER SINGLE |
| 3386 | C STRING |
| 3387 | JFLG=0 |
| 3388 | IHNT2(11)=JP |
| 3389 | IHNT2(12)=JT |
| 3390 | C |
| 3391 | IOPJET=IOPJT0 |
| 3392 | IF(IOPJET.EQ.1.AND.(NFP(JP,6).NE.0.OR.NFT(JT,6).NE.0)) |
| 3393 | & IOPJET=0 |
| 3394 | IF(JP.GT.IHNT2(1) .OR. JT.GT.IHNT2(3)) RETURN |
| 3395 | IF(NFP(JP,6).LT.0 .OR. NFT(JT,6).LT.0) RETURN |
| 3396 | C ******** JP or JT can not produce jet anymore |
| 3397 | C |
| 3398 | IF(JOUT.EQ.0) THEN |
| 3399 | EPP=PP(JP,4)+PP(JP,3) |
| 3400 | EPM=PP(JP,4)-PP(JP,3) |
| 3401 | ETP=PT(JT,4)+PT(JT,3) |
| 3402 | ETM=PT(JT,4)-PT(JT,3) |
| 3403 | IF(EPP.LT.0.0) GO TO 1000 |
| 3404 | IF(EPM.LT.0.0) GO TO 1000 |
| 3405 | IF(ETP.LT.0.0) GO TO 1000 |
| 3406 | IF(ETM.LT.0.0) GO TO 1000 |
| 3407 | IF(EPP/(EPM+0.01).LE.ETP/(ETM+0.01)) RETURN |
| 3408 | ENDIF |
| 3409 | C ********for the first hard scattering of (JP,JT) |
| 3410 | C have collision only when Ycm(JP)>Ycm(JT) |
| 3411 | |
| 3412 | ECUT1=HIPR1(1)+HIPR1(8)+PP(JP,14)+PP(JP,15) |
| 3413 | ECUT2=HIPR1(1)+HIPR1(8)+PT(JT,14)+PT(JT,15) |
| 3414 | IF(PP(JP,4).LE.ECUT1) THEN |
| 3415 | NFP(JP,6)=-ABS(NFP(JP,6)) |
| 3416 | RETURN |
| 3417 | ENDIF |
| 3418 | IF(PT(JT,4).LE.ECUT2) THEN |
| 3419 | NFT(JT,6)=-ABS(NFT(JT,6)) |
| 3420 | RETURN |
| 3421 | ENDIF |
| 3422 | C *********must have enough energy to produce jets |
| 3423 | |
| 3424 | MISS=0 |
| 3425 | MISP=0 |
| 3426 | MIST=0 |
| 3427 | C |
| 3428 | IF(NFP(JP,10).EQ.0 .AND. NFT(JT,10).EQ.0) THEN |
| 3429 | MINT(44)=MINT4 |
| 3430 | MINT(45)=MINT5 |
| 3431 | XSEC(0,1)=ATXS(0) |
| 3432 | XSEC(11,1)=ATXS(11) |
| 3433 | XSEC(12,1)=ATXS(12) |
| 3434 | XSEC(28,1)=ATXS(28) |
| 3435 | DO 120 I=1,20 |
| 3436 | COEF(11,I)=ATCO(11,I) |
| 3437 | COEF(12,I)=ATCO(12,I) |
| 3438 | COEF(28,I)=ATCO(28,I) |
| 3439 | 120 CONTINUE |
| 3440 | ELSE |
| 3441 | ISUB11=0 |
| 3442 | ISUB12=0 |
| 3443 | ISUB28=0 |
| 3444 | IF(XSEC(11,1).NE.0) ISUB11=1 |
| 3445 | IF(XSEC(12,1).NE.0) ISUB12=1 |
| 3446 | IF(XSEC(28,1).NE.0) ISUB28=1 |
| 3447 | MINT(44)=MINT4-ISUB11-ISUB12-ISUB28 |
| 3448 | MINT(45)=MINT5-ISUB11-ISUB12-ISUB28 |
| 3449 | XSEC(0,1)=ATXS(0)-ATXS(11)-ATXS(12)-ATXS(28) |
| 3450 | XSEC(11,1)=0.0 |
| 3451 | XSEC(12,1)=0.0 |
| 3452 | XSEC(28,1)=0.0 |
| 3453 | DO 110 I=1,20 |
| 3454 | COEF(11,I)=0.0 |
| 3455 | COEF(12,I)=0.0 |
| 3456 | COEF(28,I)=0.0 |
| 3457 | 110 CONTINUE |
| 3458 | ENDIF |
| 3459 | C ********Scatter the valence quarks only once per NN |
| 3460 | C collision, |
| 3461 | C afterwards only gluon can have hard scattering. |
| 440e3d40 |
3462 | 155 CALL PYTHIAA |
| 0119ef9a |
3463 | JJ=MINT(31) |
| 3464 | IF(JJ.NE.1) GO TO 155 |
| 3465 | C *********one hard collision at a time |
| 3466 | IF(K(7,2).EQ.-K(8,2)) THEN |
| 3467 | QMASS2=(P(7,4)+P(8,4))**2-(P(7,1)+P(8,1))**2 |
| 3468 | & -(P(7,2)+P(8,2))**2-(P(7,3)+P(8,3))**2 |
| 3469 | QM=ULMASS(K(7,2)) |
| 3470 | IF(QMASS2.LT.(2.0*QM+HIPR1(1))**2) GO TO 155 |
| 3471 | ENDIF |
| 3472 | C ********q-qbar jets must has minimum mass HIPR1(1) |
| 3473 | PXP=PP(JP,1)-P(3,1) |
| 3474 | PYP=PP(JP,2)-P(3,2) |
| 3475 | PZP=PP(JP,3)-P(3,3) |
| 3476 | PEP=PP(JP,4)-P(3,4) |
| 3477 | PXT=PT(JT,1)-P(4,1) |
| 3478 | PYT=PT(JT,2)-P(4,2) |
| 3479 | PZT=PT(JT,3)-P(4,3) |
| 3480 | PET=PT(JT,4)-P(4,4) |
| 3481 | |
| 3482 | IF(PEP.LE.ECUT1) THEN |
| 3483 | MISP=MISP+1 |
| 3484 | IF(MISP.LT.50) GO TO 155 |
| 3485 | NFP(JP,6)=-ABS(NFP(JP,6)) |
| 3486 | RETURN |
| 3487 | ENDIF |
| 3488 | IF(PET.LE.ECUT2) THEN |
| 3489 | MIST=MIST+1 |
| 3490 | IF(MIST.LT.50) GO TO 155 |
| 3491 | NFT(JT,6)=-ABS(NFT(JT,6)) |
| 3492 | RETURN |
| 3493 | ENDIF |
| 3494 | C ******** if the remain energy<ECUT the proj or targ |
| 3495 | C can not produce jet anymore |
| 3496 | |
| 3497 | WP=PEP+PZP+PET+PZT |
| 3498 | WM=PEP-PZP+PET-PZT |
| 3499 | IF(WP.LT.0.0 .OR. WM.LT.0.0) THEN |
| 3500 | MISS=MISS+1 |
| 3501 | clin-6/2009 Let user set the limit when selecting high-Pt events |
| 3502 | c because more attempts may be needed: |
| 3503 | c IF(MISS.LT.50) GO TO 155 |
| 3504 | if(pttrig.gt.0) then |
| 3505 | if(MISS.LT.maxmiss) then |
| 3506 | write(6,*) 'Failed to generate minijet Pt>',pttrig,'GeV' |
| 3507 | GO TO 155 |
| 3508 | endif |
| 3509 | else |
| 3510 | IF(MISS.LT.50) GO TO 155 |
| 3511 | endif |
| 3512 | |
| 3513 | RETURN |
| 3514 | ENDIF |
| 3515 | C ********the total W+, W- must be positive |
| 3516 | SW=WP*WM |
| 3517 | AMPX=SQRT((ECUT1-HIPR1(8))**2+PXP**2+PYP**2+0.01) |
| 3518 | AMTX=SQRT((ECUT2-HIPR1(8))**2+PXT**2+PYT**2+0.01) |
| 3519 | SXX=(AMPX+AMTX)**2 |
| 3520 | IF(SW.LT.SXX.OR.VINT(43).LT.HIPR1(1)) THEN |
| 3521 | MISS=MISS+1 |
| 3522 | clin-6/2009 ctest on |
| 3523 | c IF(MISS.LT.50) GO TO 155 |
| 3524 | IF(MISS.GT.maxmiss) GO TO 155 |
| 3525 | RETURN |
| 3526 | ENDIF |
| 3527 | C ********the proj and targ remnants must have at least |
| 3528 | C a CM energy that can produce two strings |
| 3529 | C with minimum mass HIPR1(1)(see HIJSFT HIJFRG) |
| 3530 | C |
| 3531 | HINT1(41)=P(7,1) |
| 3532 | HINT1(42)=P(7,2) |
| 3533 | HINT1(43)=P(7,3) |
| 3534 | HINT1(44)=P(7,4) |
| 3535 | HINT1(45)=P(7,5) |
| 3536 | HINT1(46)=SQRT(P(7,1)**2+P(7,2)**2) |
| 3537 | HINT1(51)=P(8,1) |
| 3538 | HINT1(52)=P(8,2) |
| 3539 | HINT1(53)=P(8,3) |
| 3540 | HINT1(54)=P(8,4) |
| 3541 | HINT1(55)=P(8,5) |
| 3542 | HINT1(56)=SQRT(P(8,1)**2+P(8,2)**2) |
| 3543 | IHNT2(14)=K(7,2) |
| 3544 | IHNT2(15)=K(8,2) |
| 3545 | C |
| 3546 | PINIRD=(1.0-EXP(-2.0*(VINT(47)-HIDAT(1)))) |
| 3547 | & /(1.0+EXP(-2.0*(VINT(47)-HIDAT(1)))) |
| 3548 | IINIRD=0 |
| 3549 | IF(RANART(NSEED).LE.PINIRD) IINIRD=1 |
| 3550 | IF(K(7,2).EQ.-K(8,2)) GO TO 190 |
| 3551 | IF(K(7,2).EQ.21.AND.K(8,2).EQ.21.AND.IOPJET.EQ.1) GO TO 190 |
| 3552 | C******************************************************************* |
| 3553 | C gluon jets are going to be connectd with |
| 3554 | C the final leadng string of quark-aintquark |
| 3555 | C******************************************************************* |
| 3556 | JFLG=2 |
| 3557 | JPP=0 |
| 3558 | LPQ=0 |
| 3559 | LPB=0 |
| 3560 | JTT=0 |
| 3561 | LTQ=0 |
| 3562 | LTB=0 |
| 3563 | IS7=0 |
| 3564 | IS8=0 |
| 3565 | HINT1(47)=0.0 |
| 3566 | HINT1(48)=0.0 |
| 3567 | HINT1(49)=0.0 |
| 3568 | HINT1(50)=0.0 |
| 3569 | HINT1(67)=0.0 |
| 3570 | HINT1(68)=0.0 |
| 3571 | HINT1(69)=0.0 |
| 3572 | HINT1(70)=0.0 |
| 3573 | DO 180 I=9,N |
| 3574 | IF(K(I,3).EQ.1 .OR. K(I,3).EQ.2.OR. |
| 3575 | & ABS(K(I,2)).GT.30) GO TO 180 |
| 3576 | C************************************************************ |
| 3577 | IF(K(I,3).EQ.7) THEN |
| 3578 | HINT1(47)=HINT1(47)+P(I,1) |
| 3579 | HINT1(48)=HINT1(48)+P(I,2) |
| 3580 | HINT1(49)=HINT1(49)+P(I,3) |
| 3581 | HINT1(50)=HINT1(50)+P(I,4) |
| 3582 | ENDIF |
| 3583 | IF(K(I,3).EQ.8) THEN |
| 3584 | HINT1(67)=HINT1(67)+P(I,1) |
| 3585 | HINT1(68)=HINT1(68)+P(I,2) |
| 3586 | HINT1(69)=HINT1(69)+P(I,3) |
| 3587 | HINT1(70)=HINT1(70)+P(I,4) |
| 3588 | ENDIF |
| 3589 | C************************modifcation made on Apr 10. 1996***** |
| 3590 | IF(K(I,2).GT.21.AND.K(I,2).LE.30) THEN |
| 3591 | NDR=NDR+1 |
| 3592 | IADR(NDR,1)=JP |
| 3593 | IADR(NDR,2)=JT |
| 3594 | KFDR(NDR)=K(I,2) |
| 3595 | PDR(NDR,1)=P(I,1) |
| 3596 | PDR(NDR,2)=P(I,2) |
| 3597 | PDR(NDR,3)=P(I,3) |
| 3598 | PDR(NDR,4)=P(I,4) |
| 3599 | PDR(NDR,5)=P(I,5) |
| 3600 | rtdr(NDR,1)=0.5*(YP(1,JP)+YT(1,JT)) |
| 3601 | rtdr(NDR,2)=0.5*(YP(2,JP)+YT(2,JT)) |
| 3602 | C************************************************************ |
| 3603 | GO TO 180 |
| 3604 | C************************correction made on Oct. 14,1994***** |
| 3605 | ENDIF |
| 3606 | IF(K(I,3).EQ.7.OR.K(I,3).EQ.3) THEN |
| 3607 | IF(K(I,3).EQ.7.AND.K(I,2).NE.21.AND.K(I,2).EQ.K(7,2) |
| 3608 | & .AND.IS7.EQ.0) THEN |
| 3609 | PP(JP,10)=P(I,1) |
| 3610 | PP(JP,11)=P(I,2) |
| 3611 | PP(JP,12)=P(I,3) |
| 3612 | PZP=PZP+P(I,3) |
| 3613 | PEP=PEP+P(I,4) |
| 3614 | NFP(JP,10)=1 |
| 3615 | IS7=1 |
| 3616 | GO TO 180 |
| 3617 | ENDIF |
| 3618 | IF(K(I,3).EQ.3.AND.(K(I,2).NE.21.OR. |
| 3619 | & IINIRD.EQ.0)) THEN |
| 3620 | PXP=PXP+P(I,1) |
| 3621 | PYP=PYP+P(I,2) |
| 3622 | PZP=PZP+P(I,3) |
| 3623 | PEP=PEP+P(I,4) |
| 3624 | GO TO 180 |
| 3625 | ENDIF |
| 3626 | JPP=JPP+1 |
| 3627 | IP(JPP,1)=I |
| 3628 | IP(JPP,2)=0 |
| 3629 | IF(K(I,2).NE.21) THEN |
| 3630 | IF(K(I,2).GT.0) THEN |
| 3631 | LPQ=LPQ+1 |
| 3632 | IPQ(LPQ)=JPP |
| 3633 | IP(JPP,2)=LPQ |
| 3634 | ELSE IF(K(I,2).LT.0) THEN |
| 3635 | LPB=LPB+1 |
| 3636 | IPB(LPB)=JPP |
| 3637 | IP(JPP,2)=-LPB |
| 3638 | ENDIF |
| 3639 | ENDIF |
| 3640 | ELSE IF(K(I,3).EQ.8.OR.K(I,3).EQ.4) THEN |
| 3641 | IF(K(I,3).EQ.8.AND.K(I,2).NE.21.AND.K(I,2).EQ.K(8,2) |
| 3642 | & .AND.IS8.EQ.0) THEN |
| 3643 | PT(JT,10)=P(I,1) |
| 3644 | PT(JT,11)=P(I,2) |
| 3645 | PT(JT,12)=P(I,3) |
| 3646 | PZT=PZT+P(I,3) |
| 3647 | PET=PET+P(I,4) |
| 3648 | NFT(JT,10)=1 |
| 3649 | IS8=1 |
| 3650 | GO TO 180 |
| 3651 | ENDIF |
| 3652 | IF(K(I,3).EQ.4.AND.(K(I,2).NE.21.OR. |
| 3653 | & IINIRD.EQ.0)) THEN |
| 3654 | PXT=PXT+P(I,1) |
| 3655 | PYT=PYT+P(I,2) |
| 3656 | PZT=PZT+P(I,3) |
| 3657 | PET=PET+P(I,4) |
| 3658 | GO TO 180 |
| 3659 | ENDIF |
| 3660 | JTT=JTT+1 |
| 3661 | IT(JTT,1)=I |
| 3662 | IT(JTT,2)=0 |
| 3663 | IF(K(I,2).NE.21) THEN |
| 3664 | IF(K(I,2).GT.0) THEN |
| 3665 | LTQ=LTQ+1 |
| 3666 | ITQ(LTQ)=JTT |
| 3667 | IT(JTT,2)=LTQ |
| 3668 | ELSE IF(K(I,2).LT.0) THEN |
| 3669 | LTB=LTB+1 |
| 3670 | ITB(LTB)=JTT |
| 3671 | IT(JTT,2)=-LTB |
| 3672 | ENDIF |
| 3673 | ENDIF |
| 3674 | ENDIF |
| 3675 | 180 CONTINUE |
| 3676 | c |
| 3677 | c |
| 3678 | IF(LPQ.NE.LPB .OR. LTQ.NE.LTB) THEN |
| 3679 | MISS=MISS+1 |
| 3680 | clin-6/2009 ctest on |
| 3681 | c IF(MISS.LE.50) GO TO 155 |
| 3682 | IF(MISS.LE.maxmiss) GO TO 155 |
| 3683 | WRITE(6,*) ' Q -QBAR NOT MATCHED IN HIJHRD' |
| 3684 | JFLG=0 |
| 3685 | RETURN |
| 3686 | ENDIF |
| 3687 | C****The following will rearrange the partons so that a quark is*** |
| 3688 | C****allways followed by an anti-quark **************************** |
| 3689 | |
| 3690 | J=0 |
| 3691 | 181 J=J+1 |
| 3692 | IF(J.GT.JPP) GO TO 182 |
| 3693 | IF(IP(J,2).EQ.0) THEN |
| 3694 | GO TO 181 |
| 3695 | ELSE IF(IP(J,2).NE.0) THEN |
| 3696 | LP=ABS(IP(J,2)) |
| 3697 | IP1=IP(J,1) |
| 3698 | IP2=IP(J,2) |
| 3699 | IP(J,1)=IP(IPQ(LP),1) |
| 3700 | IP(J,2)=IP(IPQ(LP),2) |
| 3701 | IP(IPQ(LP),1)=IP1 |
| 3702 | IP(IPQ(LP),2)=IP2 |
| 3703 | IF(IP2.GT.0) THEN |
| 3704 | IPQ(IP2)=IPQ(LP) |
| 3705 | ELSE IF(IP2.LT.0) THEN |
| 3706 | IPB(-IP2)=IPQ(LP) |
| 3707 | ENDIF |
| 3708 | C ********replace J with a quark |
| 3709 | IP1=IP(J+1,1) |
| 3710 | IP2=IP(J+1,2) |
| 3711 | IP(J+1,1)=IP(IPB(LP),1) |
| 3712 | IP(J+1,2)=IP(IPB(LP),2) |
| 3713 | IP(IPB(LP),1)=IP1 |
| 3714 | IP(IPB(LP),2)=IP2 |
| 3715 | IF(IP2.GT.0) THEN |
| 3716 | IPQ(IP2)=IPB(LP) |
| 3717 | ELSE IF(IP2.LT.0) THEN |
| 3718 | IPB(-IP2)=IPB(LP) |
| 3719 | ENDIF |
| 3720 | C ******** replace J+1 with anti-quark |
| 3721 | J=J+1 |
| 3722 | GO TO 181 |
| 3723 | ENDIF |
| 3724 | |
| 3725 | 182 J=0 |
| 3726 | 183 J=J+1 |
| 3727 | IF(J.GT.JTT) GO TO 184 |
| 3728 | IF(IT(J,2).EQ.0) THEN |
| 3729 | GO TO 183 |
| 3730 | ELSE IF(IT(J,2).NE.0) THEN |
| 3731 | LT=ABS(IT(J,2)) |
| 3732 | IT1=IT(J,1) |
| 3733 | IT2=IT(J,2) |
| 3734 | IT(J,1)=IT(ITQ(LT),1) |
| 3735 | IT(J,2)=IT(ITQ(LT),2) |
| 3736 | IT(ITQ(LT),1)=IT1 |
| 3737 | IT(ITQ(LT),2)=IT2 |
| 3738 | IF(IT2.GT.0) THEN |
| 3739 | ITQ(IT2)=ITQ(LT) |
| 3740 | ELSE IF(IT2.LT.0) THEN |
| 3741 | ITB(-IT2)=ITQ(LT) |
| 3742 | ENDIF |
| 3743 | C ********replace J with a quark |
| 3744 | IT1=IT(J+1,1) |
| 3745 | IT2=IT(J+1,2) |
| 3746 | IT(J+1,1)=IT(ITB(LT),1) |
| 3747 | IT(J+1,2)=IT(ITB(LT),2) |
| 3748 | IT(ITB(LT),1)=IT1 |
| 3749 | IT(ITB(LT),2)=IT2 |
| 3750 | IF(IT2.GT.0) THEN |
| 3751 | ITQ(IT2)=ITB(LT) |
| 3752 | ELSE IF(IT2.LT.0) THEN |
| 3753 | ITB(-IT2)=ITB(LT) |
| 3754 | ENDIF |
| 3755 | C ******** replace J+1 with anti-quark |
| 3756 | J=J+1 |
| 3757 | GO TO 183 |
| 3758 | |
| 3759 | ENDIF |
| 3760 | |
| 3761 | 184 CONTINUE |
| 3762 | IF(NPJ(JP)+JPP.GT.MXJT.OR.NTJ(JT)+JTT.GT.MXJT) THEN |
| 3763 | JFLG=0 |
| 3764 | WRITE(6,*) 'number of partons per string exceeds' |
| 3765 | WRITE(6,*) 'the common block size' |
| 3766 | RETURN |
| 3767 | ENDIF |
| 3768 | C ********check the bounds of common blocks |
| 3769 | DO 186 J=1,JPP |
| 3770 | KFPJ(JP,NPJ(JP)+J)=K(IP(J,1),2) |
| 3771 | PJPX(JP,NPJ(JP)+J)=P(IP(J,1),1) |
| 3772 | PJPY(JP,NPJ(JP)+J)=P(IP(J,1),2) |
| 3773 | PJPZ(JP,NPJ(JP)+J)=P(IP(J,1),3) |
| 3774 | PJPE(JP,NPJ(JP)+J)=P(IP(J,1),4) |
| 3775 | PJPM(JP,NPJ(JP)+J)=P(IP(J,1),5) |
| 3776 | 186 CONTINUE |
| 3777 | NPJ(JP)=NPJ(JP)+JPP |
| 3778 | DO 188 J=1,JTT |
| 3779 | KFTJ(JT,NTJ(JT)+J)=K(IT(J,1),2) |
| 3780 | PJTX(JT,NTJ(JT)+J)=P(IT(J,1),1) |
| 3781 | PJTY(JT,NTJ(JT)+J)=P(IT(J,1),2) |
| 3782 | PJTZ(JT,NTJ(JT)+J)=P(IT(J,1),3) |
| 3783 | PJTE(JT,NTJ(JT)+J)=P(IT(J,1),4) |
| 3784 | PJTM(JT,NTJ(JT)+J)=P(IT(J,1),5) |
| 3785 | 188 CONTINUE |
| 3786 | NTJ(JT)=NTJ(JT)+JTT |
| 3787 | GO TO 900 |
| 3788 | C***************************************************************** |
| 3789 | CThis is the case of a quark-antiquark jet it will fragment alone |
| 3790 | C**************************************************************** |
| 3791 | 190 JFLG=3 |
| 3792 | IF(K(7,2).NE.21.AND.K(8,2).NE.21.AND. |
| 3793 | & K(7,2)*K(8,2).GT.0) GO TO 155 |
| 3794 | JPP=0 |
| 3795 | LPQ=0 |
| 3796 | LPB=0 |
| 3797 | DO 200 I=9,N |
| 3798 | IF(K(I,3).EQ.1.OR.K(I,3).EQ.2.OR. |
| 3799 | & ABS(K(I,2)).GT.30) GO TO 200 |
| 3800 | IF(K(I,2).GT.21.AND.K(I,2).LE.30) THEN |
| 3801 | NDR=NDR+1 |
| 3802 | IADR(NDR,1)=JP |
| 3803 | IADR(NDR,2)=JT |
| 3804 | KFDR(NDR)=K(I,2) |
| 3805 | PDR(NDR,1)=P(I,1) |
| 3806 | PDR(NDR,2)=P(I,2) |
| 3807 | PDR(NDR,3)=P(I,3) |
| 3808 | PDR(NDR,4)=P(I,4) |
| 3809 | PDR(NDR,5)=P(I,5) |
| 3810 | rtdr(NDR,1)=0.5*(YP(1,JP)+YT(1,JT)) |
| 3811 | rtdr(NDR,2)=0.5*(YP(2,JP)+YT(2,JT)) |
| 3812 | C************************************************************ |
| 3813 | GO TO 200 |
| 3814 | C************************correction made on Oct. 14,1994***** |
| 3815 | ENDIF |
| 3816 | IF(K(I,3).EQ.3.AND.(K(I,2).NE.21.OR. |
| 3817 | & IINIRD.EQ.0)) THEN |
| 3818 | PXP=PXP+P(I,1) |
| 3819 | PYP=PYP+P(I,2) |
| 3820 | PZP=PZP+P(I,3) |
| 3821 | PEP=PEP+P(I,4) |
| 3822 | GO TO 200 |
| 3823 | ENDIF |
| 3824 | IF(K(I,3).EQ.4.AND.(K(I,2).NE.21.OR. |
| 3825 | & IINIRD.EQ.0)) THEN |
| 3826 | PXT=PXT+P(I,1) |
| 3827 | PYT=PYT+P(I,2) |
| 3828 | PZT=PZT+P(I,3) |
| 3829 | PET=PET+P(I,4) |
| 3830 | GO TO 200 |
| 3831 | ENDIF |
| 3832 | JPP=JPP+1 |
| 3833 | IP(JPP,1)=I |
| 3834 | IP(JPP,2)=0 |
| 3835 | IF(K(I,2).NE.21) THEN |
| 3836 | IF(K(I,2).GT.0) THEN |
| 3837 | LPQ=LPQ+1 |
| 3838 | IPQ(LPQ)=JPP |
| 3839 | IP(JPP,2)=LPQ |
| 3840 | ELSE IF(K(I,2).LT.0) THEN |
| 3841 | LPB=LPB+1 |
| 3842 | IPB(LPB)=JPP |
| 3843 | IP(JPP,2)=-LPB |
| 3844 | ENDIF |
| 3845 | ENDIF |
| 3846 | 200 CONTINUE |
| 3847 | IF(LPQ.NE.LPB) THEN |
| 3848 | MISS=MISS+1 |
| 3849 | clin-6/2009 ctest on |
| 3850 | c IF(MISS.LE.50) GO TO 155 |
| 3851 | IF(MISS.LE.maxmiss) GO TO 155 |
| 3852 | WRITE(6,*) LPQ,LPB, 'Q-QBAR NOT CONSERVED OR NOT MATCHED' |
| 3853 | JFLG=0 |
| 3854 | RETURN |
| 3855 | ENDIF |
| 3856 | |
| 3857 | C**** The following will rearrange the partons so that a quark is*** |
| 3858 | C**** allways followed by an anti-quark **************************** |
| 3859 | J=0 |
| 3860 | 220 J=J+1 |
| 3861 | IF(J.GT.JPP) GO TO 222 |
| 3862 | IF(IP(J,2).EQ.0) GO TO 220 |
| 3863 | LP=ABS(IP(J,2)) |
| 3864 | IP1=IP(J,1) |
| 3865 | IP2=IP(J,2) |
| 3866 | IP(J,1)=IP(IPQ(LP),1) |
| 3867 | IP(J,2)=IP(IPQ(LP),2) |
| 3868 | IP(IPQ(LP),1)=IP1 |
| 3869 | IP(IPQ(LP),2)=IP2 |
| 3870 | IF(IP2.GT.0) THEN |
| 3871 | IPQ(IP2)=IPQ(LP) |
| 3872 | ELSE IF(IP2.LT.0) THEN |
| 3873 | IPB(-IP2)=IPQ(LP) |
| 3874 | ENDIF |
| 3875 | IPQ(LP)=J |
| 3876 | C ********replace J with a quark |
| 3877 | IP1=IP(J+1,1) |
| 3878 | IP2=IP(J+1,2) |
| 3879 | IP(J+1,1)=IP(IPB(LP),1) |
| 3880 | IP(J+1,2)=IP(IPB(LP),2) |
| 3881 | IP(IPB(LP),1)=IP1 |
| 3882 | IP(IPB(LP),2)=IP2 |
| 3883 | IF(IP2.GT.0) THEN |
| 3884 | IPQ(IP2)=IPB(LP) |
| 3885 | ELSE IF(IP2.LT.0) THEN |
| 3886 | IPB(-IP2)=IPB(LP) |
| 3887 | ENDIF |
| 3888 | C ******** replace J+1 with an anti-quark |
| 3889 | IPB(LP)=J+1 |
| 3890 | J=J+1 |
| 3891 | GO TO 220 |
| 3892 | |
| 3893 | 222 CONTINUE |
| 3894 | IF(LPQ.GE.1) THEN |
| 3895 | DO 240 L0=2,LPQ |
| 3896 | IP1=IP(2*L0-3,1) |
| 3897 | IP2=IP(2*L0-3,2) |
| 3898 | IP(2*L0-3,1)=IP(IPQ(L0),1) |
| 3899 | IP(2*L0-3,2)=IP(IPQ(L0),2) |
| 3900 | IP(IPQ(L0),1)=IP1 |
| 3901 | IP(IPQ(L0),2)=IP2 |
| 3902 | IF(IP2.GT.0) THEN |
| 3903 | IPQ(IP2)=IPQ(L0) |
| 3904 | ELSE IF(IP2.LT.0) THEN |
| 3905 | IPB(-IP2)=IPQ(L0) |
| 3906 | ENDIF |
| 3907 | IPQ(L0)=2*L0-3 |
| 3908 | C |
| 3909 | IP1=IP(2*L0-2,1) |
| 3910 | IP2=IP(2*L0-2,2) |
| 3911 | IP(2*L0-2,1)=IP(IPB(L0),1) |
| 3912 | IP(2*L0-2,2)=IP(IPB(L0),2) |
| 3913 | IP(IPB(L0),1)=IP1 |
| 3914 | IP(IPB(L0),2)=IP2 |
| 3915 | IF(IP2.GT.0) THEN |
| 3916 | IPQ(IP2)=IPB(L0) |
| 3917 | ELSE IF(IP2.LT.0) THEN |
| 3918 | IPB(-IP2)=IPB(L0) |
| 3919 | ENDIF |
| 3920 | IPB(L0)=2*L0-2 |
| 3921 | 240 CONTINUE |
| 3922 | C ********move all the qqbar pair to the front of |
| 3923 | C the list, except the first pair |
| 3924 | IP1=IP(2*LPQ-1,1) |
| 3925 | IP2=IP(2*LPQ-1,2) |
| 3926 | IP(2*LPQ-1,1)=IP(IPQ(1),1) |
| 3927 | IP(2*LPQ-1,2)=IP(IPQ(1),2) |
| 3928 | IP(IPQ(1),1)=IP1 |
| 3929 | IP(IPQ(1),2)=IP2 |
| 3930 | IF(IP2.GT.0) THEN |
| 3931 | IPQ(IP2)=IPQ(1) |
| 3932 | ELSE IF(IP2.LT.0) THEN |
| 3933 | IPB(-IP2)=IPQ(1) |
| 3934 | ENDIF |
| 3935 | IPQ(1)=2*LPQ-1 |
| 3936 | C ********move the first quark to the beginning of |
| 3937 | C the last string system |
| 3938 | IP1=IP(JPP,1) |
| 3939 | IP2=IP(JPP,2) |
| 3940 | IP(JPP,1)=IP(IPB(1),1) |
| 3941 | IP(JPP,2)=IP(IPB(1),2) |
| 3942 | IP(IPB(1),1)=IP1 |
| 3943 | IP(IPB(1),2)=IP2 |
| 3944 | IF(IP2.GT.0) THEN |
| 3945 | IPQ(IP2)=IPB(1) |
| 3946 | ELSE IF(IP2.LT.0) THEN |
| 3947 | IPB(-IP2)=IPB(1) |
| 3948 | ENDIF |
| 3949 | IPB(1)=JPP |
| 3950 | C ********move the first anti-quark to the end of the |
| 3951 | C last string system |
| 3952 | ENDIF |
| 3953 | IF(NSG.GE.MXSG) THEN |
| 3954 | JFLG=0 |
| 3955 | WRITE(6,*) 'number of jets forming single strings exceeds' |
| 3956 | WRITE(6,*) 'the common block size' |
| 3957 | RETURN |
| 3958 | ENDIF |
| 3959 | IF(JPP.GT.MXSJ) THEN |
| 3960 | JFLG=0 |
| 3961 | WRITE(6,*) 'number of partons per single jet system' |
| 3962 | WRITE(6,*) 'exceeds the common block size' |
| 3963 | RETURN |
| 3964 | ENDIF |
| 3965 | C ********check the bounds of common block size |
| 3966 | NSG=NSG+1 |
| 3967 | NJSG(NSG)=JPP |
| 3968 | IASG(NSG,1)=JP |
| 3969 | IASG(NSG,2)=JT |
| 3970 | IASG(NSG,3)=0 |
| 3971 | DO 300 I=1,JPP |
| 3972 | K1SG(NSG,I)=2 |
| 3973 | K2SG(NSG,I)=K(IP(I,1),2) |
| 3974 | IF(K2SG(NSG,I).LT.0) K1SG(NSG,I)=1 |
| 3975 | PXSG(NSG,I)=P(IP(I,1),1) |
| 3976 | PYSG(NSG,I)=P(IP(I,1),2) |
| 3977 | PZSG(NSG,I)=P(IP(I,1),3) |
| 3978 | PESG(NSG,I)=P(IP(I,1),4) |
| 3979 | PMSG(NSG,I)=P(IP(I,1),5) |
| 3980 | 300 CONTINUE |
| 3981 | K1SG(NSG,1)=2 |
| 3982 | K1SG(NSG,JPP)=1 |
| 3983 | C******* reset the energy-momentum of incoming particles ******** |
| 3984 | 900 PP(JP,1)=PXP |
| 3985 | PP(JP,2)=PYP |
| 3986 | PP(JP,3)=PZP |
| 3987 | PP(JP,4)=PEP |
| 3988 | PP(JP,5)=0.0 |
| 3989 | PT(JT,1)=PXT |
| 3990 | PT(JT,2)=PYT |
| 3991 | PT(JT,3)=PZT |
| 3992 | PT(JT,4)=PET |
| 3993 | PT(JT,5)=0.0 |
| 3994 | |
| 3995 | NFP(JP,6)=NFP(JP,6)+1 |
| 3996 | NFT(JT,6)=NFT(JT,6)+1 |
| 3997 | RETURN |
| 3998 | C |
| 3999 | 1000 JFLG=-1 |
| 4000 | IF(IHPR2(10).EQ.0) RETURN |
| 4001 | WRITE(6,*) 'Fatal HIJHRD error' |
| 4002 | WRITE(6,*) JP, ' proj E+,E-',EPP,EPM,' status',NFP(JP,5) |
| 4003 | WRITE(6,*) JT, ' targ E+,E_',ETP,ETM,' status',NFT(JT,5) |
| 4004 | RETURN |
| 4005 | END |
| 4006 | C |
| 4007 | C |
| 4008 | C |
| 4009 | C |
| 4010 | C |
| 4011 | SUBROUTINE JETINI(JP,JT,itrig) |
| 4012 | C*******Initialize PYTHIA for jet production********************** |
| 4013 | C itrig=0: for normal processes |
| 4014 | C itrig=1: for triggered processes |
| 4015 | C JP: sequence number of the projectile |
| 4016 | C JT: sequence number of the target |
| 4017 | C For A+A collisions, one has to initilize pythia |
| 4018 | C separately for each type of collisions, pp, pn,np and nn, |
| 4019 | C or hp and hn for hA collisions. In this subroutine we use the following |
| 4020 | C catalogue for different type of collisions: |
| 4021 | C h+h: h+h (itype=1) |
| 4022 | C h+A: h+p (itype=1), h+n (itype=2) |
| 4023 | C A+h: p+h (itype=1), n+h (itype=2) |
| 4024 | C A+A: p+p (itype=1), p+n (itype=2), n+p (itype=3), n+n (itype=4) |
| 4025 | C***************************************************************** |
| 4026 | CHARACTER BEAM*16,TARG*16 |
| 4027 | DIMENSION XSEC0(8,0:200),COEF0(8,200,20),INI(8), |
| 4028 | & MINT44(8),MINT45(8) |
| 4029 | COMMON/hjcrdn/YP(3,300),YT(3,300) |
| 4030 | cc SAVE /hjcrdn/ |
| 4031 | COMMON/HPARNT/HIPR1(100),IHPR2(50),HINT1(100),IHNT2(50) |
| 4032 | cc SAVE /HPARNT/ |
| 4033 | COMMON/HSTRNG/NFP(300,15),PP(300,15),NFT(300,15),PT(300,15) |
| 4034 | cc SAVE /HSTRNG/ |
| 4035 | COMMON/HPINT/MINT4,MINT5,ATCO(200,20),ATXS(0:200) |
| 4036 | cc SAVE /HPINT/ |
| 4037 | C |
| 4038 | COMMON/LUDAT1A/MSTU(200),PARU(200),MSTJ(200),PARJ(200) |
| 4039 | cc SAVE /LUDAT1A/ |
| 4040 | COMMON/LUDAT3A/MDCY(500,3),MDME(2000,2),BRAT(2000),KFDP(2000,5) |
| 4041 | cc SAVE /LUDAT3A/ |
| 4042 | COMMON/PYSUBSA/MSEL,MSUB(200),KFIN(2,-40:40),CKIN(200) |
| 4043 | cc SAVE /PYSUBSA/ |
| 4044 | COMMON/PYPARSA/MSTP(200),PARP(200),MSTI(200),PARI(200) |
| 4045 | cc SAVE /PYPARSA/ |
| 4046 | COMMON/PYINT1A/MINT(400),VINT(400) |
| 4047 | cc SAVE /PYINT1A/ |
| 4048 | COMMON/PYINT2A/ISET(200),KFPR(200,2),COEF(200,20),ICOL(40,4,2) |
| 4049 | cc SAVE /PYINT2A/ |
| 4050 | COMMON/PYINT5A/NGEN(0:200,3),XSEC(0:200,3) |
| 4051 | cc SAVE /PYINT5A/ |
| 4052 | SAVE |
| 4053 | clin DATA INI/8*0/ilast/-1/ |
| 4054 | DATA INI/8*0/,ilast/-1/ |
| 4055 | C |
| 4056 | IHNT2(11)=JP |
| 4057 | IHNT2(12)=JT |
| 4058 | IF(IHNT2(5).NE.0 .AND. IHNT2(6).NE.0) THEN |
| 4059 | itype=1 |
| 4060 | ELSE IF(IHNT2(5).NE.0 .AND. IHNT2(6).EQ.0) THEN |
| 4061 | itype=1 |
| 4062 | IF(NFT(JT,4).EQ.2112) itype=2 |
| 4063 | ELSE IF(IHNT2(5).EQ.0 .AND. IHNT2(6).NE.0) THEN |
| 4064 | itype=1 |
| 4065 | IF(NFP(JP,4).EQ.2112) itype=2 |
| 4066 | ELSE |
| 4067 | IF(NFP(JP,4).EQ.2212 .AND. NFT(JT,4).EQ.2212) THEN |
| 4068 | itype=1 |
| 4069 | ELSE IF(NFP(JP,4).EQ.2212 .AND. NFT(JT,4).EQ.2112) THEN |
| 4070 | itype=2 |
| 4071 | ELSE IF(NFP(JP,4).EQ.2112 .AND. NFT(JT,4).EQ.2212) THEN |
| 4072 | itype=3 |
| 4073 | ELSE |
| 4074 | itype=4 |
| 4075 | ENDIF |
| 4076 | ENDIF |
| 4077 | c |
| 4078 | IF(itrig.NE.0) GO TO 160 |
| 4079 | IF(itrig.EQ.ilast) GO TO 150 |
| 4080 | MSTP(2)=2 |
| 4081 | c ********second order running alpha_strong |
| 4082 | MSTP(33)=1 |
| 4083 | PARP(31)=HIPR1(17) |
| 4084 | C ********inclusion of K factor |
| 4085 | MSTP(51)=3 |
| 4086 | C ********Duke-Owens set 1 structure functions |
| 4087 | MSTP(61)=1 |
| 4088 | C ********INITIAL STATE RADIATION |
| 4089 | MSTP(71)=1 |
| 4090 | C ********FINAL STATE RADIATION |
| 4091 | IF(IHPR2(2).EQ.0.OR.IHPR2(2).EQ.2) MSTP(61)=0 |
| 4092 | IF(IHPR2(2).EQ.0.OR.IHPR2(2).EQ.1) MSTP(71)=0 |
| 4093 | c |
| 4094 | MSTP(81)=0 |
| 4095 | C ******** NO MULTIPLE INTERACTION |
| 4096 | MSTP(82)=1 |
| 4097 | C *******STRUCTURE OF MUTLIPLE INTERACTION |
| 4098 | MSTP(111)=0 |
| 4099 | C ********frag off(have to be done by local call) |
| 4100 | IF(IHPR2(10).EQ.0) MSTP(122)=0 |
| 4101 | C ********No printout of initialization information |
| 4102 | PARP(81)=HIPR1(8) |
| 4103 | CKIN(5)=HIPR1(8) |
| 4104 | CKIN(3)=HIPR1(8) |
| 4105 | CKIN(4)=HIPR1(9) |
| 4106 | IF(HIPR1(9).LE.HIPR1(8)) CKIN(4)=-1.0 |
| 4107 | CKIN(9)=-10.0 |
| 4108 | CKIN(10)=10.0 |
| 4109 | MSEL=0 |
| 4110 | DO 100 ISUB=1,200 |
| 4111 | MSUB(ISUB)=0 |
| 4112 | 100 CONTINUE |
| 4113 | MSUB(11)=1 |
| 4114 | MSUB(12)=1 |
| 4115 | MSUB(13)=1 |
| 4116 | MSUB(28)=1 |
| 4117 | MSUB(53)=1 |
| 4118 | MSUB(68)=1 |
| 4119 | MSUB(81)=1 |
| 4120 | MSUB(82)=1 |
| 4121 | DO 110 J=1,MIN(8,MDCY(21,3)) |
| 4122 | 110 MDME(MDCY(21,2)+J-1,1)=0 |
| 4123 | ISEL=4 |
| 4124 | IF(HINT1(1).GE.20.0 .and. IHPR2(18).EQ.1) ISEL=5 |
| 4125 | MDME(MDCY(21,2)+ISEL-1,1)=1 |
| 4126 | C ********QCD subprocesses |
| 4127 | MSUB(14)=1 |
| 4128 | MSUB(18)=1 |
| 4129 | MSUB(29)=1 |
| 4130 | C ******* direct photon production |
| 4131 | 150 IF(INI(itype).NE.0) GO TO 800 |
| 4132 | GO TO 400 |
| 4133 | C |
| 4134 | C *****triggered subprocesses, jet, photon, heavy quark and DY |
| 4135 | C |
| 4136 | 160 itype=4+itype |
| 4137 | IF(itrig.EQ.ilast) GO TO 260 |
| 4138 | PARP(81)=ABS(HIPR1(10))-0.25 |
| 4139 | CKIN(5)=ABS(HIPR1(10))-0.25 |
| 4140 | CKIN(3)=ABS(HIPR1(10))-0.25 |
| 4141 | CKIN(4)=ABS(HIPR1(10))+0.25 |
| 4142 | IF(HIPR1(10).LT.HIPR1(8)) CKIN(4)=-1.0 |
| 4143 | c |
| 4144 | MSEL=0 |
| 4145 | DO 101 ISUB=1,200 |
| 4146 | MSUB(ISUB)=0 |
| 4147 | 101 CONTINUE |
| 4148 | IF(IHPR2(3).EQ.1) THEN |
| 4149 | MSUB(11)=1 |
| 4150 | MSUB(12)=1 |
| 4151 | MSUB(13)=1 |
| 4152 | MSUB(28)=1 |
| 4153 | MSUB(53)=1 |
| 4154 | MSUB(68)=1 |
| 4155 | MSUB(81)=1 |
| 4156 | MSUB(82)=1 |
| 4157 | MSUB(14)=1 |
| 4158 | MSUB(18)=1 |
| 4159 | MSUB(29)=1 |
| 4160 | DO 102 J=1,MIN(8,MDCY(21,3)) |
| 4161 | 102 MDME(MDCY(21,2)+J-1,1)=0 |
| 4162 | ISEL=4 |
| 4163 | IF(HINT1(1).GE.20.0 .and. IHPR2(18).EQ.1) ISEL=5 |
| 4164 | MDME(MDCY(21,2)+ISEL-1,1)=1 |
| 4165 | C ********QCD subprocesses |
| 4166 | ELSE IF(IHPR2(3).EQ.2) THEN |
| 4167 | MSUB(14)=1 |
| 4168 | MSUB(18)=1 |
| 4169 | MSUB(29)=1 |
| 4170 | C ********Direct photon production |
| 4171 | c q+qbar->g+gamma,q+qbar->gamma+gamma, q+g->q+gamma |
| 4172 | ELSE IF(IHPR2(3).EQ.3) THEN |
| 4173 | CKIN(3)=MAX(0.0,HIPR1(10)) |
| 4174 | CKIN(5)=HIPR1(8) |
| 4175 | PARP(81)=HIPR1(8) |
| 4176 | MSUB(81)=1 |
| 4177 | MSUB(82)=1 |
| 4178 | DO 105 J=1,MIN(8,MDCY(21,3)) |
| 4179 | 105 MDME(MDCY(21,2)+J-1,1)=0 |
| 4180 | ISEL=4 |
| 4181 | IF(HINT1(1).GE.20.0 .and. IHPR2(18).EQ.1) ISEL=5 |
| 4182 | MDME(MDCY(21,2)+ISEL-1,1)=1 |
| 4183 | C **********Heavy quark production |
| 4184 | ENDIF |
| 4185 | 260 IF(INI(itype).NE.0) GO TO 800 |
| 4186 | C |
| 4187 | C |
| 4188 | 400 INI(itype)=1 |
| 4189 | IF(IHPR2(10).EQ.0) MSTP(122)=0 |
| 4190 | IF(NFP(JP,4).EQ.2212) THEN |
| 4191 | BEAM='P' |
| 4192 | ELSE IF(NFP(JP,4).EQ.-2212) THEN |
| 4193 | BEAM='P~' |
| 4194 | ELSE IF(NFP(JP,4).EQ.2112) THEN |
| 4195 | BEAM='N' |
| 4196 | ELSE IF(NFP(JP,4).EQ.-2112) THEN |
| 4197 | BEAM='N~' |
| 4198 | ELSE IF(NFP(JP,4).EQ.211) THEN |
| 4199 | BEAM='PI+' |
| 4200 | ELSE IF(NFP(JP,4).EQ.-211) THEN |
| 4201 | BEAM='PI-' |
| 4202 | ELSE IF(NFP(JP,4).EQ.321) THEN |
| 4203 | BEAM='PI+' |
| 4204 | ELSE IF(NFP(JP,4).EQ.-321) THEN |
| 4205 | BEAM='PI-' |
| 4206 | ELSE |
| 4207 | WRITE(6,*) 'unavailable beam type', NFP(JP,4) |
| 4208 | ENDIF |
| 4209 | IF(NFT(JT,4).EQ.2212) THEN |
| 4210 | TARG='P' |
| 4211 | ELSE IF(NFT(JT,4).EQ.-2212) THEN |
| 4212 | TARG='P~' |
| 4213 | ELSE IF(NFT(JT,4).EQ.2112) THEN |
| 4214 | TARG='N' |
| 4215 | ELSE IF(NFT(JT,4).EQ.-2112) THEN |
| 4216 | TARG='N~' |
| 4217 | ELSE IF(NFT(JT,4).EQ.211) THEN |
| 4218 | TARG='PI+' |
| 4219 | ELSE IF(NFT(JT,4).EQ.-211) THEN |
| 4220 | TARG='PI-' |
| 4221 | ELSE IF(NFT(JT,4).EQ.321) THEN |
| 4222 | TARG='PI+' |
| 4223 | ELSE IF(NFT(JT,4).EQ.-321) THEN |
| 4224 | TARG='PI-' |
| 4225 | ELSE |
| 4226 | WRITE(6,*) 'unavailable target type', NFT(JT,4) |
| 4227 | ENDIF |
| 4228 | C |
| 4229 | IHNT2(16)=1 |
| 4230 | C ******************indicate for initialization use when |
| 4231 | C structure functions are called in PYTHIA |
| 4232 | C |
| ce320da8 |
4233 | CALL PYINITA('CMS',BEAM,TARG,HINT1(1)) |
| 0119ef9a |
4234 | MINT4=MINT(44) |
| 4235 | MINT5=MINT(45) |
| 4236 | MINT44(itype)=MINT(44) |
| 4237 | MINT45(itype)=MINT(45) |
| 4238 | ATXS(0)=XSEC(0,1) |
| 4239 | XSEC0(itype,0)=XSEC(0,1) |
| 4240 | DO 500 I=1,200 |
| 4241 | ATXS(I)=XSEC(I,1) |
| 4242 | XSEC0(itype,I)=XSEC(I,1) |
| 4243 | DO 500 J=1,20 |
| 4244 | ATCO(I,J)=COEF(I,J) |
| 4245 | COEF0(itype,I,J)=COEF(I,J) |
| 4246 | 500 CONTINUE |
| 4247 | C |
| 4248 | IHNT2(16)=0 |
| 4249 | C |
| 4250 | RETURN |
| 4251 | C ********Store the initialization information for |
| 4252 | C late use |
| 4253 | C |
| 4254 | C |
| 4255 | 800 MINT(44)=MINT44(itype) |
| 4256 | MINT(45)=MINT45(itype) |
| 4257 | MINT4=MINT(44) |
| 4258 | MINT5=MINT(45) |
| 4259 | XSEC(0,1)=XSEC0(itype,0) |
| 4260 | ATXS(0)=XSEC(0,1) |
| 4261 | DO 900 I=1,200 |
| 4262 | XSEC(I,1)=XSEC0(itype,I) |
| 4263 | ATXS(I)=XSEC(I,1) |
| 4264 | DO 900 J=1,20 |
| 4265 | COEF(I,J)=COEF0(itype,I,J) |
| 4266 | ATCO(I,J)=COEF(I,J) |
| 4267 | 900 CONTINUE |
| 4268 | ilast=itrig |
| 4269 | MINT(11)=NFP(JP,4) |
| 4270 | MINT(12)=NFT(JT,4) |
| 4271 | RETURN |
| 4272 | END |
| 4273 | C |
| 4274 | C |
| 4275 | C |
| 4276 | SUBROUTINE HIJINI |
| 4277 | PARAMETER (MAXSTR=150001) |
| 4278 | COMMON/HPARNT/HIPR1(100),IHPR2(50),HINT1(100),IHNT2(50) |
| 4279 | cc SAVE /HPARNT/ |
| 4280 | COMMON/HSTRNG/NFP(300,15),PP(300,15),NFT(300,15),PT(300,15) |
| 4281 | cc SAVE /HSTRNG/ |
| 4282 | COMMON/HJJET1/NPJ(300),KFPJ(300,500),PJPX(300,500), |
| 4283 | & PJPY(300,500),PJPZ(300,500),PJPE(300,500), |
| 4284 | & PJPM(300,500),NTJ(300),KFTJ(300,500), |
| 4285 | & PJTX(300,500),PJTY(300,500),PJTZ(300,500), |
| 4286 | & PJTE(300,500),PJTM(300,500) |
| 4287 | cc SAVE /HJJET1/ |
| 4288 | COMMON/HJJET2/NSG,NJSG(MAXSTR),IASG(MAXSTR,3),K1SG(MAXSTR,100), |
| 4289 | & K2SG(MAXSTR,100),PXSG(MAXSTR,100),PYSG(MAXSTR,100), |
| 4290 | & PZSG(MAXSTR,100),PESG(MAXSTR,100),PMSG(MAXSTR,100) |
| 4291 | cc SAVE /HJJET2/ |
| 4292 | c COMMON/HJJET4/NDR,IADR(900,2),KFDR(900),PDR(900,5) |
| 4293 | COMMON/HJJET4/NDR,IADR(MAXSTR,2),KFDR(MAXSTR),PDR(MAXSTR,5) |
| 4294 | cc SAVE /HJJET4/ |
| 4295 | COMMON/RNDF77/NSEED |
| 4296 | cc SAVE /RNDF77/ |
| 4297 | SAVE |
| 4298 | C****************Reset the momentum of initial particles************ |
| 4299 | C and assign flavors to the proj and targ string * |
| 4300 | C******************************************************************* |
| 4301 | NSG=0 |
| 4302 | NDR=0 |
| 4303 | IPP=2212 |
| 4304 | IPT=2212 |
| 4305 | IF(IHNT2(5).NE.0) IPP=IHNT2(5) |
| 4306 | IF(IHNT2(6).NE.0) IPT=IHNT2(6) |
| 4307 | C ********in case the proj or targ is a hadron. |
| 4308 | C |
| 4309 | DO 100 I=1,IHNT2(1) |
| 4310 | PP(I,1)=0.0 |
| 4311 | PP(I,2)=0.0 |
| 4312 | PP(I,3)=SQRT(HINT1(1)**2/4.0-HINT1(8)**2) |
| 4313 | PP(I,4)=HINT1(1)/2 |
| 4314 | PP(I,5)=HINT1(8) |
| 4315 | PP(I,6)=0.0 |
| 4316 | PP(I,7)=0.0 |
| 4317 | PP(I,8)=0.0 |
| 4318 | PP(I,9)=0.0 |
| 4319 | PP(I,10)=0.0 |
| 4320 | cbzdbg2/22/99 |
| 4321 | ctest OFF |
| 4322 | PP(I, 11) = 0.0 |
| 4323 | PP(I, 12) = 0.0 |
| 4324 | cbzdbg2/22/99end |
| 4325 | NFP(I,3)=IPP |
| 4326 | NFP(I,4)=IPP |
| 4327 | NFP(I,5)=0 |
| 4328 | NFP(I,6)=0 |
| 4329 | NFP(I,7)=0 |
| 4330 | NFP(I,8)=0 |
| 4331 | NFP(I,9)=0 |
| 4332 | NFP(I,10)=0 |
| 4333 | NFP(I,11)=0 |
| 4334 | NPJ(I)=0 |
| 4335 | IF(I.GT.ABS(IHNT2(2))) NFP(I,3)=2112 |
| 4336 | CALL ATTFLV(NFP(I,3),IDQ,IDQQ) |
| 4337 | NFP(I,1)=IDQ |
| 4338 | NFP(I,2)=IDQQ |
| 4339 | NFP(I,15)=-1 |
| 4340 | IF(ABS(IDQ).GT.1000.OR.(ABS(IDQ*IDQQ).LT.100.AND. |
| 4341 | & RANART(NSEED).LT.0.5)) NFP(I,15)=1 |
| 4342 | PP(I,14)=ULMASS(IDQ) |
| 4343 | PP(I,15)=ULMASS(IDQQ) |
| 4344 | 100 CONTINUE |
| 4345 | C |
| 4346 | DO 200 I=1,IHNT2(3) |
| 4347 | PT(I,1)=0.0 |
| 4348 | PT(I,2)=0.0 |
| 4349 | PT(I,3)=-SQRT(HINT1(1)**2/4.0-HINT1(9)**2) |
| 4350 | PT(I,4)=HINT1(1)/2.0 |
| 4351 | PT(I,5)=HINT1(9) |
| 4352 | PT(I,6)=0.0 |
| 4353 | PT(I,7)=0.0 |
| 4354 | PT(I,8)=0.0 |
| 4355 | PT(I,9)=0.0 |
| 4356 | PT(I,10)=0.0 |
| 4357 | ctest OFF |
| 4358 | cbzdbg2/22/99 |
| 4359 | PT(I, 11) = 0.0 |
| 4360 | PT(I, 12) = 0.0 |
| 4361 | cbzdbg2/22/99end |
| 4362 | NFT(I,3)=IPT |
| 4363 | NFT(I,4)=IPT |
| 4364 | NFT(I,5)=0 |
| 4365 | NFT(I,6)=0 |
| 4366 | NFT(I,7)=0 |
| 4367 | NFT(I,8)=0 |
| 4368 | NFT(I,9)=0 |
| 4369 | NFT(I,10)=0 |
| 4370 | NFT(I,11)=0 |
| 4371 | NTJ(I)=0 |
| 4372 | IF(I.GT.ABS(IHNT2(4))) NFT(I,3)=2112 |
| 4373 | CALL ATTFLV(NFT(I,3),IDQ,IDQQ) |
| 4374 | NFT(I,1)=IDQ |
| 4375 | NFT(I,2)=IDQQ |
| 4376 | NFT(I,15)=1 |
| 4377 | IF(ABS(IDQ).GT.1000.OR.(ABS(IDQ*IDQQ).LT.100.AND. |
| 4378 | & RANART(NSEED).LT.0.5)) NFT(I,15)=-1 |
| 4379 | PT(I,14)=ULMASS(IDQ) |
| 4380 | PT(I,15)=ULMASS(IDQQ) |
| 4381 | 200 CONTINUE |
| 4382 | RETURN |
| 4383 | END |
| 4384 | C |
| 4385 | C |
| 4386 | C |
| 4387 | SUBROUTINE ATTFLV(ID,IDQ,IDQQ) |
| 4388 | COMMON/RNDF77/NSEED |
| 4389 | cc SAVE /RNDF77/ |
| 4390 | SAVE |
| 4391 | C |
| 4392 | IF(ABS(ID).LT.100) THEN |
| 4393 | NSIGN=1 |
| 4394 | IDQ=ID/100 |
| 4395 | IDQQ=-ID/10+IDQ*10 |
| 4396 | IF(ABS(IDQ).EQ.3) NSIGN=-1 |
| 4397 | IDQ=NSIGN*IDQ |
| 4398 | IDQQ=NSIGN*IDQQ |
| 4399 | IF(IDQ.LT.0) THEN |
| 4400 | ID0=IDQ |
| 4401 | IDQ=IDQQ |
| 4402 | IDQQ=ID0 |
| 4403 | ENDIF |
| 4404 | RETURN |
| 4405 | ENDIF |
| 4406 | C ********return ID of quark(IDQ) and anti-quark(IDQQ) |
| 4407 | C for pions and kaons |
| 4408 | c |
| 4409 | C Return LU ID for quarks and diquarks for proton(ID=2212) |
| 4410 | C anti-proton(ID=-2212) and nuetron(ID=2112) |
| 4411 | C LU ID for d=1,u=2, (ud)0=2101, (ud)1=2103, |
| 4412 | C (dd)1=1103,(uu)1=2203. |
| 4413 | C Use SU(6) weight proton=1/3d(uu)1 + 1/6u(ud)1 + 1/2u(ud)0 |
| 4414 | C nurtron=1/3u(dd)1 + 1/6d(ud)1 + 1/2d(ud)0 |
| 4415 | C |
| 4416 | IDQ=2 |
| 4417 | IF(ABS(ID).EQ.2112) IDQ=1 |
| 4418 | IDQQ=2101 |
| 4419 | X=RANART(NSEED) |
| 4420 | IF(X.LE.0.5) GO TO 30 |
| 4421 | IF(X.GT.0.666667) GO TO 10 |
| 4422 | IDQQ=2103 |
| 4423 | GO TO 30 |
| 4424 | 10 IDQ=1 |
| 4425 | IDQQ=2203 |
| 4426 | IF(ABS(ID).EQ.2112) THEN |
| 4427 | IDQ=2 |
| 4428 | IDQQ=1103 |
| 4429 | ENDIF |
| 4430 | 30 IF(ID.LT.0) THEN |
| 4431 | ID00=IDQQ |
| 4432 | IDQQ=-IDQ |
| 4433 | IDQ=-ID00 |
| 4434 | ENDIF |
| 4435 | RETURN |
| 4436 | END |
| 4437 | C |
| 4438 | C******************************************************************* |
| 4439 | C This subroutine performs elastic scatterings and possible |
| 4440 | C elastic cascading within their own nuclei |
| 4441 | c******************************************************************* |
| 4442 | SUBROUTINE HIJCSC(JP,JT) |
| 4443 | DIMENSION PSC1(5),PSC2(5) |
| 4444 | COMMON/hjcrdn/YP(3,300),YT(3,300) |
| 4445 | cc SAVE /hjcrdn/ |
| 4446 | COMMON/HPARNT/HIPR1(100),IHPR2(50),HINT1(100),IHNT2(50) |
| 4447 | cc SAVE /HPARNT/ |
| 4448 | COMMON/RNDF77/NSEED |
| 4449 | cc SAVE /RNDF77/ |
| 4450 | COMMON/HSTRNG/NFP(300,15),PP(300,15),NFT(300,15),PT(300,15) |
| 4451 | cc SAVE /HSTRNG/ |
| 4452 | SAVE |
| 4453 | IF(JP.EQ.0 .OR. JT.EQ.0) GO TO 25 |
| 4454 | DO 10 I=1,5 |
| 4455 | PSC1(I)=PP(JP,I) |
| 4456 | PSC2(I)=PT(JT,I) |
| 4457 | 10 CONTINUE |
| 4458 | CALL HIJELS(PSC1,PSC2) |
| 4459 | DPP1=PSC1(1)-PP(JP,1) |
| 4460 | DPP2=PSC1(2)-PP(JP,2) |
| 4461 | DPT1=PSC2(1)-PT(JT,1) |
| 4462 | DPT2=PSC2(2)-PT(JT,2) |
| 4463 | PP(JP,6)=PP(JP,6)+DPP1/2.0 |
| 4464 | PP(JP,7)=PP(JP,7)+DPP2/2.0 |
| 4465 | PP(JP,8)=PP(JP,8)+DPP1/2.0 |
| 4466 | PP(JP,9)=PP(JP,9)+DPP2/2.0 |
| 4467 | PT(JT,6)=PT(JT,6)+DPT1/2.0 |
| 4468 | PT(JT,7)=PT(JT,7)+DPT2/2.0 |
| 4469 | PT(JT,8)=PT(JT,8)+DPT1/2.0 |
| 4470 | PT(JT,9)=PT(JT,9)+DPT2/2.0 |
| 4471 | DO 20 I=1,4 |
| 4472 | PP(JP,I)=PSC1(I) |
| 4473 | PT(JT,I)=PSC2(I) |
| 4474 | 20 CONTINUE |
| 4475 | NFP(JP,5)=MAX(1,NFP(JP,5)) |
| 4476 | NFT(JT,5)=MAX(1,NFT(JT,5)) |
| 4477 | C ********Perform elastic scattering between JP and JT |
| 4478 | RETURN |
| 4479 | C ********The following is for possible elastic cascade |
| 4480 | c |
| 4481 | 25 IF(JP.EQ.0) GO TO 45 |
| 4482 | PABS=SQRT(PP(JP,1)**2+PP(JP,2)**2+PP(JP,3)**2) |
| 4483 | BX=PP(JP,1)/PABS |
| 4484 | BY=PP(JP,2)/PABS |
| 4485 | BZ=PP(JP,3)/PABS |
| 4486 | DO 40 I=1,IHNT2(1) |
| 4487 | IF(I.EQ.JP) GO TO 40 |
| 4488 | DX=YP(1,I)-YP(1,JP) |
| 4489 | DY=YP(2,I)-YP(2,JP) |
| 4490 | DZ=YP(3,I)-YP(3,JP) |
| 4491 | DIS=DX*BX+DY*BY+DZ*BZ |
| 4492 | IF(DIS.LE.0) GO TO 40 |
| 4493 | BB=DX**2+DY**2+DZ**2-DIS**2 |
| 4494 | R2=BB*HIPR1(40)/HIPR1(31)/0.1 |
| 4495 | C ********mb=0.1*fm, YP is in fm,HIPR1(31) is in mb |
| 4496 | GS=1.0-EXP(-(HIPR1(30)+HINT1(11))/HIPR1(31)/2.0 |
| 4497 | & *ROMG(R2))**2 |
| 4498 | GS0=1.0-EXP(-(HIPR1(30)+HINT1(11))/HIPR1(31)/2.0 |
| 4499 | & *ROMG(0.0))**2 |
| 4500 | IF(RANART(NSEED).GT.GS/GS0) GO TO 40 |
| 4501 | DO 30 K=1,5 |
| 4502 | PSC1(K)=PP(JP,K) |
| 4503 | PSC2(K)=PP(I,K) |
| 4504 | 30 CONTINUE |
| 4505 | CALL HIJELS(PSC1,PSC2) |
| 4506 | DPP1=PSC1(1)-PP(JP,1) |
| 4507 | DPP2=PSC1(2)-PP(JP,2) |
| 4508 | DPT1=PSC2(1)-PP(I,1) |
| 4509 | DPT2=PSC2(2)-PP(I,2) |
| 4510 | PP(JP,6)=PP(JP,6)+DPP1/2.0 |
| 4511 | PP(JP,7)=PP(JP,7)+DPP2/2.0 |
| 4512 | PP(JP,8)=PP(JP,8)+DPP1/2.0 |
| 4513 | PP(JP,9)=PP(JP,9)+DPP2/2.0 |
| 4514 | PP(I,6)=PP(I,6)+DPT1/2.0 |
| 4515 | PP(I,7)=PP(I,7)+DPT2/2.0 |
| 4516 | PP(I,8)=PP(I,8)+DPT1/2.0 |
| 4517 | PP(I,9)=PP(I,9)+DPT2/2.0 |
| 4518 | DO 35 K=1,5 |
| 4519 | PP(JP,K)=PSC1(K) |
| 4520 | PP(I,K)=PSC2(K) |
| 4521 | 35 CONTINUE |
| 4522 | NFP(I,5)=MAX(1,NFP(I,5)) |
| 4523 | GO TO 45 |
| 4524 | 40 CONTINUE |
| 4525 | 45 IF(JT.EQ.0) GO TO 80 |
| 4526 | clin 50 PABS=SQRT(PT(JT,1)**2+PT(JT,2)**2+PT(JT,3)**2) |
| 4527 | PABS=SQRT(PT(JT,1)**2+PT(JT,2)**2+PT(JT,3)**2) |
| 4528 | BX=PT(JT,1)/PABS |
| 4529 | BY=PT(JT,2)/PABS |
| 4530 | BZ=PT(JT,3)/PABS |
| 4531 | DO 70 I=1,IHNT2(3) |
| 4532 | IF(I.EQ.JT) GO TO 70 |
| 4533 | DX=YT(1,I)-YT(1,JT) |
| 4534 | DY=YT(2,I)-YT(2,JT) |
| 4535 | DZ=YT(3,I)-YT(3,JT) |
| 4536 | DIS=DX*BX+DY*BY+DZ*BZ |
| 4537 | IF(DIS.LE.0) GO TO 70 |
| 4538 | BB=DX**2+DY**2+DZ**2-DIS**2 |
| 4539 | R2=BB*HIPR1(40)/HIPR1(31)/0.1 |
| 4540 | C ********mb=0.1*fm, YP is in fm,HIPR1(31) is in mb |
| 4541 | GS=(1.0-EXP(-(HIPR1(30)+HINT1(11))/HIPR1(31)/2.0 |
| 4542 | & *ROMG(R2)))**2 |
| 4543 | GS0=(1.0-EXP(-(HIPR1(30)+HINT1(11))/HIPR1(31)/2.0 |
| 4544 | & *ROMG(0.0)))**2 |
| 4545 | IF(RANART(NSEED).GT.GS/GS0) GO TO 70 |
| 4546 | DO 60 K=1,5 |
| 4547 | PSC1(K)=PT(JT,K) |
| 4548 | PSC2(K)=PT(I,K) |
| 4549 | 60 CONTINUE |
| 4550 | CALL HIJELS(PSC1,PSC2) |
| 4551 | DPP1=PSC1(1)-PT(JT,1) |
| 4552 | DPP2=PSC1(2)-PT(JT,2) |
| 4553 | DPT1=PSC2(1)-PT(I,1) |
| 4554 | DPT2=PSC2(2)-PT(I,2) |
| 4555 | PT(JT,6)=PT(JT,6)+DPP1/2.0 |
| 4556 | PT(JT,7)=PT(JT,7)+DPP2/2.0 |
| 4557 | PT(JT,8)=PT(JT,8)+DPP1/2.0 |
| 4558 | PT(JT,9)=PT(JT,9)+DPP2/2.0 |
| 4559 | PT(I,6)=PT(I,6)+DPT1/2.0 |
| 4560 | PT(I,7)=PT(I,7)+DPT2/2.0 |
| 4561 | PT(I,8)=PT(I,8)+DPT1/2.0 |
| 4562 | PT(I,9)=PT(I,9)+DPT2/2.0 |
| 4563 | DO 65 K=1,5 |
| 4564 | PT(JT,K)=PSC1(K) |
| 4565 | PT(I,K)=PSC2(K) |
| 4566 | 65 CONTINUE |
| 4567 | NFT(I,5)=MAX(1,NFT(I,5)) |
| 4568 | GO TO 80 |
| 4569 | 70 CONTINUE |
| 4570 | 80 RETURN |
| 4571 | END |
| 4572 | C |
| 4573 | C |
| 4574 | C******************************************************************* |
| 4575 | CThis subroutine performs elastic scattering between two nucleons |
| 4576 | C |
| 4577 | C******************************************************************* |
| 4578 | SUBROUTINE HIJELS(PSC1,PSC2) |
| 4579 | IMPLICIT DOUBLE PRECISION(D) |
| 4580 | DIMENSION PSC1(5),PSC2(5) |
| 4581 | COMMON/HPARNT/HIPR1(100),IHPR2(50),HINT1(100),IHNT2(50) |
| 4582 | cc SAVE /HPARNT/ |
| 4583 | COMMON/RNDF77/NSEED |
| 4584 | cc SAVE /RNDF77/ |
| 4585 | SAVE |
| 4586 | C |
| 4587 | CC=1.0-HINT1(12)/HINT1(13) |
| 4588 | RR=(1.0-CC)*HINT1(13)/HINT1(12)/(1.0-HIPR1(33))-1.0 |
| 4589 | BB=0.5*(3.0+RR+SQRT(9.0+10.0*RR+RR**2)) |
| 4590 | EP=SQRT((PSC1(1)-PSC2(1))**2+(PSC1(2)-PSC2(2))**2 |
| 4591 | & +(PSC1(3)-PSC2(3))**2) |
| 4592 | IF(EP.LE.0.1) RETURN |
| 4593 | ELS0=98.0/EP+52.0*(1.0+RR)**2 |
| 4594 | PCM1=PSC1(1)+PSC2(1) |
| 4595 | PCM2=PSC1(2)+PSC2(2) |
| 4596 | PCM3=PSC1(3)+PSC2(3) |
| 4597 | ECM=PSC1(4)+PSC2(4) |
| 4598 | AM1=PSC1(5)**2 |
| 4599 | AM2=PSC2(5)**2 |
| 4600 | AMM=ECM**2-PCM1**2-PCM2**2-PCM3**2 |
| 4601 | IF(AMM.LE.PSC1(5)+PSC2(5)) RETURN |
| 4602 | C ********elastic scattering only when approaching |
| 4603 | C to each other |
| 4604 | PMAX=(AMM**2+AM1**2+AM2**2-2.0*AMM*AM1-2.0*AMM*AM2 |
| 4605 | & -2.0*AM1*AM2)/4.0/AMM |
| 4606 | PMAX=ABS(PMAX) |
| 4607 | 20 TT=RANART(NSEED)*MIN(PMAX,1.5) |
| 4608 | ELS=98.0*EXP(-2.8*TT)/EP |
| 4609 | & +52.0*EXP(-9.2*TT)*(1.0+RR*EXP(-4.6*(BB-1.0)*TT))**2 |
| 4610 | IF(RANART(NSEED).GT.ELS/ELS0) GO TO 20 |
| 4611 | PHI=2.0*HIPR1(40)*RANART(NSEED) |
| 4612 | C |
| 4613 | DBX=dble(PCM1/ECM) |
| 4614 | DBY=dble(PCM2/ECM) |
| 4615 | DBZ=dble(PCM3/ECM) |
| 4616 | DB=dSQRT(DBX**2+DBY**2+DBZ**2) |
| 4617 | IF(DB.GT.0.99999999D0) THEN |
| 4618 | DBX=DBX*(0.99999999D0/DB) |
| 4619 | DBY=DBY*(0.99999999D0/DB) |
| 4620 | DBZ=DBZ*(0.99999999D0/DB) |
| 4621 | DB=0.99999999D0 |
| 4622 | WRITE(6,*) ' (HIJELS) boost vector too large' |
| 4623 | C ********Rescale boost vector if too close to unity. |
| 4624 | ENDIF |
| 4625 | DGA=1D0/SQRT(1D0-DB**2) |
| 4626 | C |
| 4627 | DP1=dble(SQRT(TT)*SIN(PHI)) |
| 4628 | DP2=dble(SQRT(TT)*COS(PHI)) |
| 4629 | DP3=dble(SQRT(PMAX-TT)) |
| 4630 | DP4=dble(SQRT(PMAX+AM1)) |
| 4631 | DBP=DBX*DP1+DBY*DP2+DBZ*DP3 |
| 4632 | DGABP=DGA*(DGA*DBP/(1D0+DGA)+DP4) |
| 4633 | PSC1(1)=sngl(DP1+DGABP*DBX) |
| 4634 | PSC1(2)=sngl(DP2+DGABP*DBY) |
| 4635 | PSC1(3)=sngl(DP3+DGABP*DBZ) |
| 4636 | PSC1(4)=sngl(DGA*(DP4+DBP)) |
| 4637 | C |
| 4638 | DP1=-dble(SQRT(TT)*SIN(PHI)) |
| 4639 | DP2=-dble(SQRT(TT)*COS(PHI)) |
| 4640 | DP3=-dble(SQRT(PMAX-TT)) |
| 4641 | DP4=dble(SQRT(PMAX+AM2)) |
| 4642 | DBP=DBX*DP1+DBY*DP2+DBZ*DP3 |
| 4643 | DGABP=DGA*(DGA*DBP/(1D0+DGA)+DP4) |
| 4644 | PSC2(1)=sngl(DP1+DGABP*DBX) |
| 4645 | PSC2(2)=sngl(DP2+DGABP*DBY) |
| 4646 | PSC2(3)=sngl(DP3+DGABP*DBZ) |
| 4647 | PSC2(4)=sngl(DGA*(DP4+DBP)) |
| 4648 | RETURN |
| 4649 | END |
| 4650 | C |
| 4651 | C |
| 4652 | C******************************************************************* |
| 4653 | C * |
| 4654 | C Subroutine HIJSFT * |
| 4655 | C * |
| 4656 | C Scatter two excited strings, JP from proj and JT from target * |
| 4657 | C******************************************************************* |
| 4658 | SUBROUTINE HIJSFT(JP,JT,JOUT,IERROR) |
| 4659 | PARAMETER (MAXSTR=150001) |
| 4660 | COMMON/hjcrdn/YP(3,300),YT(3,300) |
| 4661 | cc SAVE /hjcrdn/ |
| 4662 | COMMON/HPARNT/HIPR1(100),IHPR2(50),HINT1(100),IHNT2(50) |
| 4663 | cc SAVE /HPARNT/ |
| 4664 | COMMON/HIJDAT/HIDAT0(10,10),HIDAT(10) |
| 4665 | cc SAVE /HIJDAT/ |
| 4666 | COMMON/RNDF77/NSEED |
| 4667 | cc SAVE /RNDF77/ |
| 4668 | COMMON/HJJET1/NPJ(300),KFPJ(300,500),PJPX(300,500), |
| 4669 | & PJPY(300,500),PJPZ(300,500),PJPE(300,500), |
| 4670 | & PJPM(300,500),NTJ(300),KFTJ(300,500), |
| 4671 | & PJTX(300,500),PJTY(300,500),PJTZ(300,500), |
| 4672 | & PJTE(300,500),PJTM(300,500) |
| 4673 | cc SAVE /HJJET1/ |
| 4674 | clin-4/25/01 |
| 4675 | c COMMON/HJJET2/NSG,NJSG(900),IASG(900,3),K1SG(900,100), |
| 4676 | c & K2SG(900,100),PXSG(900,100),PYSG(900,100), |
| 4677 | c & PZSG(900,100),PESG(900,100),PMSG(900,100) |
| 4678 | cc SAVE /HJJET2/ |
| 4679 | COMMON/HSTRNG/NFP(300,15),PP(300,15),NFT(300,15),PT(300,15) |
| 4680 | cc SAVE /HSTRNG/ |
| 4681 | COMMON/DPMCM1/JJP,JJT,AMP,AMT,APX0,ATX0,AMPN,AMTN,AMP0,AMT0, |
| 4682 | & NFDP,NFDT,WP,WM,SW,XREMP,XREMT,DPKC1,DPKC2,PP11,PP12, |
| 4683 | & PT11,PT12,PTP2,PTT2 |
| 4684 | cc SAVE /DPMCM1/ |
| 4685 | COMMON/DPMCM2/NDPM,KDPM(20,2),PDPM1(20,5),PDPM2(20,5) |
| 4686 | cc SAVE /DPMCM2/ |
| 4687 | SAVE |
| 4688 | C******************************************************************* |
| 4689 | C JOUT-> the number |
| 4690 | C of hard scatterings preceding this soft collision. |
| 4691 | C IHNT2(13)-> 1= |
| 4692 | C double diffrac 2=single diffrac, 3=non-single diffrac. |
| 4693 | C******************************************************************* |
| 4694 | IERROR=0 |
| 4695 | JJP=JP |
| 4696 | JJT=JT |
| 4697 | NDPM=0 |
| 4698 | c IOPMAIN=0 |
| 4699 | IF(JP.GT.IHNT2(1) .OR. JT.GT.IHNT2(3)) RETURN |
| 4700 | |
| 4701 | EPP=PP(JP,4)+PP(JP,3) |
| 4702 | EPM=PP(JP,4)-PP(JP,3) |
| 4703 | ETP=PT(JT,4)+PT(JT,3) |
| 4704 | ETM=PT(JT,4)-PT(JT,3) |
| 4705 | |
| 4706 | WP=EPP+ETP |
| 4707 | WM=EPM+ETM |
| 4708 | SW=WP*WM |
| 4709 | C ********total W+,W- and center-of-mass energy |
| 4710 | |
| 4711 | IF(WP.LT.0.0 .OR. WM.LT.0.0) GO TO 1000 |
| 4712 | |
| 4713 | IF(JOUT.EQ.0) THEN |
| 4714 | IF(EPP.LT.0.0) GO TO 1000 |
| 4715 | IF(EPM.LT.0.0) GO TO 1000 |
| 4716 | IF(ETP.LT.0.0) GO TO 1000 |
| 4717 | IF(ETM.LT.0.0) GO TO 1000 |
| 4718 | IF(EPP/(EPM+0.01).LE.ETP/(ETM+0.01)) RETURN |
| 4719 | ENDIF |
| 4720 | C ********For strings which does not follow a jet-prod, |
| 4721 | C scatter only if Ycm(JP)>Ycm(JT). When jets |
| 4722 | C are produced just before this collision |
| 4723 | C this requirement has already be enforced |
| 4724 | C (see SUBROUTINE HIJHRD) |
| 4725 | IHNT2(11)=JP |
| 4726 | IHNT2(12)=JT |
| 4727 | C |
| 4728 | C |
| 4729 | C |
| 4730 | MISS=0 |
| 4731 | PKC1=0.0 |
| 4732 | PKC2=0.0 |
| 4733 | PKC11=0.0 |
| 4734 | PKC12=0.0 |
| 4735 | PKC21=0.0 |
| 4736 | PKC22=0.0 |
| 4737 | DPKC11=0.0 |
| 4738 | DPKC12=0.0 |
| 4739 | DPKC21=0.0 |
| 4740 | DPKC22=0.0 |
| 4741 | IF(NFP(JP,10).EQ.1.OR.NFT(JT,10).EQ.1) THEN |
| 4742 | IF(NFP(JP,10).EQ.1) THEN |
| 4743 | PHI1=ULANGL(PP(JP,10),PP(JP,11)) |
| 4744 | PPJET=SQRT(PP(JP,10)**2+PP(JP,11)**2) |
| 4745 | PKC1=PPJET |
| 4746 | PKC11=PP(JP,10) |
| 4747 | PKC12=PP(JP,11) |
| 4748 | ENDIF |
| 4749 | IF(NFT(JT,10).EQ.1) THEN |
| 4750 | PHI2=ULANGL(PT(JT,10),PT(JT,11)) |
| 4751 | PTJET=SQRT(PT(JT,10)**2+PT(JT,11)**2) |
| 4752 | PKC2=PTJET |
| 4753 | PKC21=PT(JT,10) |
| 4754 | PKC22=PT(JT,11) |
| 4755 | ENDIF |
| 4756 | IF(IHPR2(4).GT.0.AND.IHNT2(1).GT.1.AND.IHNT2(3).GT.1) THEN |
| 4757 | IF(NFP(JP,10).EQ.0) THEN |
| 4758 | PHI=-PHI2 |
| 4759 | ELSE IF(NFT(JT,10).EQ.0) THEN |
| 4760 | PHI=PHI1 |
| 4761 | ELSE |
| 4762 | PHI=(PHI1+PHI2-HIPR1(40))/2.0 |
| 4763 | ENDIF |
| 4764 | BX=HINT1(19)*COS(HINT1(20)) |
| 4765 | BY=HINT1(19)*SIN(HINT1(20)) |
| 4766 | XP0=YP(1,JP) |
| 4767 | YP0=YP(2,JP) |
| 4768 | XT0=YT(1,JT)+BX |
| 4769 | YT0=YT(2,JT)+BY |
| 4770 | R1=MAX(1.2*IHNT2(1)**0.3333333, |
| 4771 | & SQRT(XP0**2+YP0**2)) |
| 4772 | R2=MAX(1.2*IHNT2(3)**0.3333333, |
| 4773 | & SQRT((XT0-BX)**2+(YT0-BY)**2)) |
| 4774 | IF(ABS(COS(PHI)).LT.1.0E-5) THEN |
| 4775 | DD1=R1 |
| 4776 | DD2=R1 |
| 4777 | DD3=ABS(BY+SQRT(R2**2-(XP0-BX)**2)-YP0) |
| 4778 | DD4=ABS(BY-SQRT(R2**2-(XP0-BX)**2)-YP0) |
| 4779 | GO TO 5 |
| 4780 | ENDIF |
| 4781 | BB=2.0*SIN(PHI)*(COS(PHI)*YP0-SIN(PHI)*XP0) |
| 4782 | CC=(YP0**2-R1**2)*COS(PHI)**2+XP0*SIN(PHI)*( |
| 4783 | & XP0*SIN(PHI)-2.0*YP0*COS(PHI)) |
| 4784 | DD=BB**2-4.0*CC |
| 4785 | IF(DD.LT.0.0) GO TO 10 |
| 4786 | XX1=(-BB+SQRT(DD))/2.0 |
| 4787 | XX2=(-BB-SQRT(DD))/2.0 |
| 4788 | DD1=ABS((XX1-XP0)/COS(PHI)) |
| 4789 | DD2=ABS((XX2-XP0)/COS(PHI)) |
| 4790 | C |
| 4791 | BB=2.0*SIN(PHI)*(COS(PHI)*(YT0-BY)-SIN(PHI)*XT0)-2.0*BX |
| 4792 | CC=(BX**2+(YT0-BY)**2-R2**2)*COS(PHI)**2+XT0*SIN(PHI) |
| 4793 | & *(XT0*SIN(PHI)-2.0*COS(PHI)*(YT0-BY)) |
| 4794 | & -2.0*BX*SIN(PHI)*(COS(PHI)*(YT0-BY)-SIN(PHI)*XT0) |
| 4795 | DD=BB**2-4.0*CC |
| 4796 | IF(DD.LT.0.0) GO TO 10 |
| 4797 | XX1=(-BB+SQRT(DD))/2.0 |
| 4798 | XX2=(-BB-SQRT(DD))/2.0 |
| 4799 | DD3=ABS((XX1-XT0)/COS(PHI)) |
| 4800 | DD4=ABS((XX2-XT0)/COS(PHI)) |
| 4801 | C |
| 4802 | 5 DD1=MIN(DD1,DD3) |
| 4803 | DD2=MIN(DD2,DD4) |
| 4804 | IF(DD1.LT.HIPR1(13)) DD1=0.0 |
| 4805 | IF(DD2.LT.HIPR1(13)) DD2=0.0 |
| 4806 | IF(NFP(JP,10).EQ.1.AND.PPJET.GT.HIPR1(11)) THEN |
| 4807 | DP1=DD1*HIPR1(14)/2.0 |
| 4808 | DP1=MIN(DP1,PPJET-HIPR1(11)) |
| 4809 | PKC1=PPJET-DP1 |
| 4810 | DPX1=COS(PHI1)*DP1 |
| 4811 | DPY1=SIN(PHI1)*DP1 |
| 4812 | PKC11=PP(JP,10)-DPX1 |
| 4813 | PKC12=PP(JP,11)-DPY1 |
| 4814 | IF(DP1.GT.0.0) THEN |
| 4815 | CTHEP=PP(JP,12)/SQRT(PP(JP,12)**2+PPJET**2) |
| 4816 | DPZ1=DP1*CTHEP/SQRT(1.0-CTHEP**2) |
| 4817 | DPE1=SQRT(DPX1**2+DPY1**2+DPZ1**2) |
| 4818 | EPPPRM=PP(JP,4)+PP(JP,3)-DPE1-DPZ1 |
| 4819 | EPMPRM=PP(JP,4)-PP(JP,3)-DPE1+DPZ1 |
| 4820 | IF(EPPPRM.LE.0.0.OR.EPMPRM.LE.0.0) GO TO 15 |
| 4821 | EPP=EPPPRM |
| 4822 | EPM=EPMPRM |
| 4823 | PP(JP,10)=PKC11 |
| 4824 | PP(JP,11)=PKC12 |
| 4825 | NPJ(JP)=NPJ(JP)+1 |
| 4826 | KFPJ(JP,NPJ(JP))=21 |
| 4827 | PJPX(JP,NPJ(JP))=DPX1 |
| 4828 | PJPY(JP,NPJ(JP))=DPY1 |
| 4829 | PJPZ(JP,NPJ(JP))=DPZ1 |
| 4830 | PJPE(JP,NPJ(JP))=DPE1 |
| 4831 | PJPM(JP,NPJ(JP))=0.0 |
| 4832 | PP(JP,3)=PP(JP,3)-DPZ1 |
| 4833 | PP(JP,4)=PP(JP,4)-DPE1 |
| 4834 | ENDIF |
| 4835 | ENDIF |
| 4836 | 15 IF(NFT(JT,10).EQ.1.AND.PTJET.GT.HIPR1(11)) THEN |
| 4837 | DP2=DD2*HIPR1(14)/2.0 |
| 4838 | DP2=MIN(DP2,PTJET-HIPR1(11)) |
| 4839 | PKC2=PTJET-DP2 |
| 4840 | DPX2=COS(PHI2)*DP2 |
| 4841 | DPY2=SIN(PHI2)*DP2 |
| 4842 | PKC21=PT(JT,10)-DPX2 |
| 4843 | PKC22=PT(JT,11)-DPY2 |
| 4844 | IF(DP2.GT.0.0) THEN |
| 4845 | CTHET=PT(JT,12)/SQRT(PT(JT,12)**2+PTJET**2) |
| 4846 | DPZ2=DP2*CTHET/SQRT(1.0-CTHET**2) |
| 4847 | DPE2=SQRT(DPX2**2+DPY2**2+DPZ2**2) |
| 4848 | ETPPRM=PT(JT,4)+PT(JT,3)-DPE2-DPZ2 |
| 4849 | ETMPRM=PT(JT,4)-PT(JT,3)-DPE2+DPZ2 |
| 4850 | IF(ETPPRM.LE.0.0.OR.ETMPRM.LE.0.0) GO TO 16 |
| 4851 | ETP=ETPPRM |
| 4852 | ETM=ETMPRM |
| 4853 | PT(JT,10)=PKC21 |
| 4854 | PT(JT,11)=PKC22 |
| 4855 | NTJ(JT)=NTJ(JT)+1 |
| 4856 | KFTJ(JT,NTJ(JT))=21 |
| 4857 | PJTX(JT,NTJ(JT))=DPX2 |
| 4858 | PJTY(JT,NTJ(JT))=DPY2 |
| 4859 | PJTZ(JT,NTJ(JT))=DPZ2 |
| 4860 | PJTE(JT,NTJ(JT))=DPE2 |
| 4861 | PJTM(JT,NTJ(JT))=0.0 |
| 4862 | PT(JT,3)=PT(JT,3)-DPZ2 |
| 4863 | PT(JT,4)=PT(JT,4)-DPE2 |
| 4864 | ENDIF |
| 4865 | ENDIF |
| 4866 | 16 DPKC11=-(PP(JP,10)-PKC11)/2.0 |
| 4867 | DPKC12=-(PP(JP,11)-PKC12)/2.0 |
| 4868 | DPKC21=-(PT(JT,10)-PKC21)/2.0 |
| 4869 | DPKC22=-(PT(JT,11)-PKC22)/2.0 |
| 4870 | WP=EPP+ETP |
| 4871 | WM=EPM+ETM |
| 4872 | SW=WP*WM |
| 4873 | ENDIF |
| 4874 | ENDIF |
| 4875 | C ********If jet is quenched the pt from valence quark |
| 4876 | C hard scattering has to reduced by d*kapa |
| 4877 | C |
| 4878 | C |
| 4879 | 10 PTP02=PP(JP,1)**2+PP(JP,2)**2 |
| 4880 | PTT02=PT(JT,1)**2+PT(JT,2)**2 |
| 4881 | C |
| 4882 | AMQ=MAX(PP(JP,14)+PP(JP,15),PT(JT,14)+PT(JT,15)) |
| 4883 | AMX=HIPR1(1)+AMQ |
| 4884 | C ********consider mass cut-off for strings which |
| 4885 | C must also include quark's mass |
| 4886 | AMP0=AMX |
| 4887 | DPM0=AMX |
| 4888 | NFDP=0 |
| 4889 | IF(NFP(JP,5).LE.2.AND.NFP(JP,3).NE.0) THEN |
| 4890 | AMP0=ULMASS(NFP(JP,3)) |
| 4891 | NFDP=NFP(JP,3)+2*NFP(JP,3)/ABS(NFP(JP,3)) |
| 4892 | DPM0=ULMASS(NFDP) |
| 4893 | IF(DPM0.LE.0.0) THEN |
| 4894 | NFDP=NFDP-2*NFDP/ABS(NFDP) |
| 4895 | DPM0=ULMASS(NFDP) |
| 4896 | ENDIF |
| 4897 | ENDIF |
| 4898 | AMT0=AMX |
| 4899 | DTM0=AMX |
| 4900 | NFDT=0 |
| 4901 | IF(NFT(JT,5).LE.2.AND.NFT(JT,3).NE.0) THEN |
| 4902 | AMT0=ULMASS(NFT(JT,3)) |
| 4903 | NFDT=NFT(JT,3)+2*NFT(JT,3)/ABS(NFT(JT,3)) |
| 4904 | DTM0=ULMASS(NFDT) |
| 4905 | IF(DTM0.LE.0.0) THEN |
| 4906 | NFDT=NFDT-2*NFDT/ABS(NFDT) |
| 4907 | DTM0=ULMASS(NFDT) |
| 4908 | ENDIF |
| 4909 | ENDIF |
| 4910 | C |
| 4911 | AMPN=SQRT(AMP0**2+PTP02) |
| 4912 | AMTN=SQRT(AMT0**2+PTT02) |
| 4913 | SNN=(AMPN+AMTN)**2+0.001 |
| 4914 | C |
| 4915 | IF(SW.LT.SNN+0.001) GO TO 4000 |
| 4916 | C ********Scatter only if SW>SNN |
| 4917 | C*****give some PT kick to the two exited strings****************** |
| 4918 | clin 20 SWPTN=4.0*(MAX(AMP0,AMT0)**2+MAX(PTP02,PTT02)) |
| 4919 | SWPTN=4.0*(MAX(AMP0,AMT0)**2+MAX(PTP02,PTT02)) |
| 4920 | SWPTD=4.0*(MAX(DPM0,DTM0)**2+MAX(PTP02,PTT02)) |
| 4921 | SWPTX=4.0*(AMX**2+MAX(PTP02,PTT02)) |
| 4922 | IF(SW.LE.SWPTN) THEN |
| 4923 | PKCMX=0.0 |
| 4924 | ELSE IF(SW.GT.SWPTN .AND. SW.LE.SWPTD |
| 4925 | & .AND.NPJ(JP).EQ.0.AND.NTJ(JT).EQ.0) THEN |
| 4926 | PKCMX=SQRT(SW/4.0-MAX(AMP0,AMT0)**2) |
| 4927 | & -SQRT(MAX(PTP02,PTT02)) |
| 4928 | ELSE IF(SW.GT.SWPTD .AND. SW.LE.SWPTX |
| 4929 | & .AND.NPJ(JP).EQ.0.AND.NTJ(JT).EQ.0) THEN |
| 4930 | PKCMX=SQRT(SW/4.0-MAX(DPM0,DTM0)**2) |
| 4931 | & -SQRT(MAX(PTP02,PTT02)) |
| 4932 | ELSE IF(SW.GT.SWPTX) THEN |
| 4933 | PKCMX=SQRT(SW/4.0-AMX**2)-SQRT(MAX(PTP02,PTT02)) |
| 4934 | ENDIF |
| 4935 | C ********maximun PT kick |
| 4936 | C********************************************************* |
| 4937 | C |
| 4938 | IF(NFP(JP,10).EQ.1.OR.NFT(JT,10).EQ.1) THEN |
| 4939 | IF(PKC1.GT.PKCMX) THEN |
| 4940 | PKC1=PKCMX |
| 4941 | PKC11=PKC1*COS(PHI1) |
| 4942 | PKC12=PKC1*SIN(PHI1) |
| 4943 | DPKC11=-(PP(JP,10)-PKC11)/2.0 |
| 4944 | DPKC12=-(PP(JP,11)-PKC12)/2.0 |
| 4945 | ENDIF |
| 4946 | IF(PKC2.GT.PKCMX) THEN |
| 4947 | PKC2=PKCMX |
| 4948 | PKC21=PKC2*COS(PHI2) |
| 4949 | PKC22=PKC2*SIN(PHI2) |
| 4950 | DPKC21=-(PT(JT,10)-PKC21)/2.0 |
| 4951 | DPKC22=-(PT(JT,11)-PKC22)/2.0 |
| 4952 | ENDIF |
| 4953 | DPKC1=DPKC11+DPKC21 |
| 4954 | DPKC2=DPKC12+DPKC22 |
| 4955 | NFP(JP,10)=-NFP(JP,10) |
| 4956 | NFT(JT,10)=-NFT(JT,10) |
| 4957 | GO TO 40 |
| 4958 | ENDIF |
| 4959 | C ********If the valence quarks had a hard-collision |
| 4960 | C the pt kick is the pt from hard-collision. |
| 4961 | isng=0 |
| 4962 | IF(IHPR2(13).NE.0 .AND. RANART(NSEED).LE.HIDAT(4)) isng=1 |
| 4963 | IF((NFP(JP,5).EQ.3 .OR.NFT(JT,5).EQ.3).OR. |
| 4964 | & (NPJ(JP).NE.0.OR.NFP(JP,10).NE.0).OR. |
| 4965 | & (NTJ(JT).NE.0.OR.NFT(JT,10).NE.0)) isng=0 |
| 4966 | C |
| 4967 | C ********decite whether to have single-diffractive |
| 4968 | IF(IHPR2(5).EQ.0) THEN |
| 4969 | PKC=HIPR1(2)*SQRT(-ALOG(1.0-RANART(NSEED) |
| 4970 | & *(1.0-EXP(-PKCMX**2/HIPR1(2)**2)))) |
| 4971 | GO TO 30 |
| 4972 | ENDIF |
| 4973 | |
| 4974 | clin-10/28/02 get rid of argument usage mismatch in HIRND2(): |
| 4975 | c PKC=HIRND2(3,0.0,PKCMX**2) |
| 4976 | xminhi=0.0 |
| 4977 | xmaxhi=PKCMX**2 |
| 4978 | PKC=HIRND2(3,xminhi,xmaxhi) |
| 4979 | |
| 4980 | PKC=SQRT(PKC) |
| 4981 | IF(PKC.GT.HIPR1(20)) |
| 4982 | & PKC=HIPR1(2)*SQRT(-ALOG(EXP(-HIPR1(20)**2/HIPR1(2)**2) |
| 4983 | & -RANART(NSEED)*(EXP(-HIPR1(20)**2/HIPR1(2)**2)- |
| 4984 | & EXP(-PKCMX**2/HIPR1(2)**2)))) |
| 4985 | C |
| 4986 | IF(isng.EQ.1) PKC=0.65*SQRT( |
| 4987 | & -ALOG(1.0-RANART(NSEED)*(1.0-EXP(-PKCMX**2/0.65**2)))) |
| 4988 | C ********select PT kick |
| 4989 | 30 PHI0=2.0*HIPR1(40)*RANART(NSEED) |
| 4990 | PKC11=PKC*SIN(PHI0) |
| 4991 | PKC12=PKC*COS(PHI0) |
| 4992 | PKC21=-PKC11 |
| 4993 | PKC22=-PKC12 |
| 4994 | DPKC1=0.0 |
| 4995 | DPKC2=0.0 |
| 4996 | 40 PP11=PP(JP,1)+PKC11-DPKC1 |
| 4997 | PP12=PP(JP,2)+PKC12-DPKC2 |
| 4998 | PT11=PT(JT,1)+PKC21-DPKC1 |
| 4999 | PT12=PT(JT,2)+PKC22-DPKC2 |
| 5000 | PTP2=PP11**2+PP12**2 |
| 5001 | PTT2=PT11**2+PT12**2 |
| 5002 | C |
| 5003 | AMPN=SQRT(AMP0**2+PTP2) |
| 5004 | AMTN=SQRT(AMT0**2+PTT2) |
| 5005 | SNN=(AMPN+AMTN)**2+0.001 |
| 5006 | C*************************************** |
| 5007 | WP=EPP+ETP |
| 5008 | WM=EPM+ETM |
| 5009 | SW=WP*WM |
| 5010 | C**************************************** |
| 5011 | IF(SW.LT.SNN) THEN |
| 5012 | MISS=MISS+1 |
| 5013 | IF(MISS.LE.100) then |
| 5014 | PKC=0.0 |
| 5015 | GO TO 30 |
| 5016 | ENDIF |
| 5017 | IF(IHPR2(10).NE.0) |
| 5018 | & WRITE(6,*) 'Error occured in Pt kick section of HIJSFT' |
| 5019 | GO TO 4000 |
| 5020 | ENDIF |
| 5021 | C****************************************************************** |
| 5022 | AMPD=SQRT(DPM0**2+PTP2) |
| 5023 | AMTD=SQRT(DTM0**2+PTT2) |
| 5024 | |
| 5025 | AMPX=SQRT(AMX**2+PTP2) |
| 5026 | AMTX=SQRT(AMX**2+PTT2) |
| 5027 | |
| 5028 | DPN=AMPN**2/SW |
| 5029 | DTN=AMTN**2/SW |
| 5030 | DPD=AMPD**2/SW |
| 5031 | DTD=AMTD**2/SW |
| 5032 | DPX=AMPX**2/SW |
| 5033 | DTX=AMTX**2/SW |
| 5034 | C |
| 5035 | SPNTD=(AMPN+AMTD)**2 |
| 5036 | SPNTX=(AMPN+AMTX)**2 |
| 5037 | C ********CM energy if proj=N,targ=N* |
| 5038 | SPDTN=(AMPD+AMTN)**2 |
| 5039 | SPXTN=(AMPX+AMTN)**2 |
| 5040 | C ********CM energy if proj=N*,targ=N |
| 5041 | SPDTX=(AMPD+AMTX)**2 |
| 5042 | SPXTD=(AMPX+AMTD)**2 |
| 5043 | SDD=(AMPD+AMTD)**2 |
| 5044 | SXX=(AMPX+AMTX)**2 |
| 5045 | |
| 5046 | C |
| 5047 | C |
| 5048 | C ********CM energy if proj=delta, targ=delta |
| 5049 | C****************There are many different cases********** |
| 5050 | c IF(IHPR2(15).EQ.1) GO TO 500 |
| 5051 | C |
| 5052 | C ********to have DPM type soft interactions |
| 5053 | C |
| 5054 | clin 45 CONTINUE |
| 5055 | IF(SW.GT.SXX+0.001) THEN |
| 5056 | IF(isng.EQ.0) THEN |
| 5057 | D1=DPX |
| 5058 | D2=DTX |
| 5059 | NFP3=0 |
| 5060 | NFT3=0 |
| 5061 | GO TO 400 |
| 5062 | ELSE |
| 5063 | c**** 5/30/1998 this is identical to the above statement. Added to |
| 5064 | c**** avoid questional branching to block. |
| 5065 | IF((NFP(JP,5).EQ.3 .AND.NFT(JT,5).EQ.3).OR. |
| 5066 | & (NPJ(JP).NE.0.OR.NFP(JP,10).NE.0).OR. |
| 5067 | & (NTJ(JT).NE.0.OR.NFT(JT,10).NE.0)) THEN |
| 5068 | D1=DPX |
| 5069 | D2=DTX |
| 5070 | NFP3=0 |
| 5071 | NFT3=0 |
| 5072 | GO TO 400 |
| 5073 | ENDIF |
| 5074 | C ********do not allow excited strings to have |
| 5075 | C single-diffr |
| 5076 | IF(RANART(NSEED).GT.0.5.OR.(NFT(JT,5).GT.2.OR. |
| 5077 | & NTJ(JT).NE.0.OR.NFT(JT,10).NE.0)) THEN |
| 5078 | D1=DPN |
| 5079 | D2=DTX |
| 5080 | NFP3=NFP(JP,3) |
| 5081 | NFT3=0 |
| 5082 | GO TO 220 |
| 5083 | ELSE |
| 5084 | D1=DPX |
| 5085 | D2=DTN |
| 5086 | NFP3=0 |
| 5087 | NFT3=NFT(JT,3) |
| 5088 | GO TO 240 |
| 5089 | ENDIF |
| 5090 | C ********have single diffractive collision |
| 5091 | ENDIF |
| 5092 | ELSE IF(SW.GT.MAX(SPDTX,SPXTD)+0.001 .AND. |
| 5093 | & SW.LE.SXX+0.001) THEN |
| 5094 | IF(((NPJ(JP).EQ.0.AND.NTJ(JT).EQ.0.AND. |
| 5095 | & RANART(NSEED).GT.0.5).OR.(NPJ(JP).EQ.0 |
| 5096 | & .AND.NTJ(JT).NE.0)).AND.NFP(JP,5).LE.2) THEN |
| 5097 | D1=DPD |
| 5098 | D2=DTX |
| 5099 | NFP3=NFDP |
| 5100 | NFT3=0 |
| 5101 | GO TO 220 |
| 5102 | ELSE IF(NTJ(JT).EQ.0.AND.NFT(JT,5).LE.2) THEN |
| 5103 | D1=DPX |
| 5104 | D2=DTD |
| 5105 | NFP3=0 |
| 5106 | NFT3=NFDT |
| 5107 | GO TO 240 |
| 5108 | ENDIF |
| 5109 | GO TO 4000 |
| 5110 | ELSE IF(SW.GT.MIN(SPDTX,SPXTD)+0.001.AND. |
| 5111 | & SW.LE.MAX(SPDTX,SPXTD)+0.001) THEN |
| 5112 | IF(SPDTX.LE.SPXTD.AND.NPJ(JP).EQ.0 |
| 5113 | & .AND.NFP(JP,5).LE.2) THEN |
| 5114 | D1=DPD |
| 5115 | D2=DTX |
| 5116 | NFP3=NFDP |
| 5117 | NFT3=0 |
| 5118 | GO TO 220 |
| 5119 | ELSE IF(SPDTX.GT.SPXTD.AND.NTJ(JT).EQ.0 |
| 5120 | & .AND.NFT(JT,5).LE.2) THEN |
| 5121 | D1=DPX |
| 5122 | D2=DTD |
| 5123 | NFP3=0 |
| 5124 | NFT3=NFDT |
| 5125 | GO TO 240 |
| 5126 | ENDIF |
| 5127 | c*** 5/30/1998 added to avoid questional branching to another block |
| 5128 | c*** this is identical to the statement following the next ELSE IF |
| 5129 | IF(((NPJ(JP).EQ.0.AND.NTJ(JT).EQ.0 |
| 5130 | & .AND.RANART(NSEED).GT.0.5).OR.(NPJ(JP).EQ.0 |
| 5131 | & .AND.NTJ(JT).NE.0)).AND.NFP(JP,5).LE.2) THEN |
| 5132 | D1=DPN |
| 5133 | D2=DTX |
| 5134 | NFP3=NFP(JP,3) |
| 5135 | NFT3=0 |
| 5136 | GO TO 220 |
| 5137 | ELSE IF(NTJ(JT).EQ.0.AND.NFT(JT,5).LE.2) THEN |
| 5138 | D1=DPX |
| 5139 | D2=DTN |
| 5140 | NFP3=0 |
| 5141 | NFT3=NFT(JT,3) |
| 5142 | GO TO 240 |
| 5143 | ENDIF |
| 5144 | GO TO 4000 |
| 5145 | ELSE IF(SW.GT.MAX(SPNTX,SPXTN)+0.001 .AND. |
| 5146 | & SW.LE.MIN(SPDTX,SPXTD)+0.001) THEN |
| 5147 | IF(((NPJ(JP).EQ.0.AND.NTJ(JT).EQ.0 |
| 5148 | & .AND.RANART(NSEED).GT.0.5).OR.(NPJ(JP).EQ.0 |
| 5149 | & .AND.NTJ(JT).NE.0)).AND.NFP(JP,5).LE.2) THEN |
| 5150 | D1=DPN |
| 5151 | D2=DTX |
| 5152 | NFP3=NFP(JP,3) |
| 5153 | NFT3=0 |
| 5154 | GO TO 220 |
| 5155 | ELSE IF(NTJ(JT).EQ.0.AND.NFT(JT,5).LE.2) THEN |
| 5156 | D1=DPX |
| 5157 | D2=DTN |
| 5158 | NFP3=0 |
| 5159 | NFT3=NFT(JT,3) |
| 5160 | GO TO 240 |
| 5161 | ENDIF |
| 5162 | GO TO 4000 |
| 5163 | ELSE IF(SW.GT.MIN(SPNTX,SPXTN)+0.001 .AND. |
| 5164 | & SW.LE.MAX(SPNTX,SPXTN)+0.001) THEN |
| 5165 | IF(SPNTX.LE.SPXTN.AND.NPJ(JP).EQ.0 |
| 5166 | & .AND.NFP(JP,5).LE.2) THEN |
| 5167 | D1=DPN |
| 5168 | D2=DTX |
| 5169 | NFP3=NFP(JP,3) |
| 5170 | NFT3=0 |
| 5171 | GO TO 220 |
| 5172 | ELSEIF(SPNTX.GT.SPXTN.AND.NTJ(JT).EQ.0 |
| 5173 | & .AND.NFT(JT,5).LE.2) THEN |
| 5174 | D1=DPX |
| 5175 | D2=DTN |
| 5176 | NFP3=0 |
| 5177 | NFT3=NFT(JT,3) |
| 5178 | GO TO 240 |
| 5179 | ENDIF |
| 5180 | GO TO 4000 |
| 5181 | ELSE IF(SW.LE.MIN(SPNTX,SPXTN)+0.001 .AND. |
| 5182 | & (NPJ(JP).NE.0 .OR.NTJ(JT).NE.0)) THEN |
| 5183 | GO TO 4000 |
| 5184 | ELSE IF(SW.LE.MIN(SPNTX,SPXTN)+0.001 .AND. |
| 5185 | & NFP(JP,5).GT.2.AND.NFT(JT,5).GT.2) THEN |
| 5186 | GO TO 4000 |
| 5187 | ELSE IF(SW.GT.SDD+0.001.AND.SW.LE. |
| 5188 | & MIN(SPNTX,SPXTN)+0.001) THEN |
| 5189 | D1=DPD |
| 5190 | D2=DTD |
| 5191 | NFP3=NFDP |
| 5192 | NFT3=NFDT |
| 5193 | GO TO 100 |
| 5194 | ELSE IF(SW.GT.MAX(SPNTD,SPDTN)+0.001 |
| 5195 | & .AND. SW.LE.SDD+0.001) THEN |
| 5196 | IF(RANART(NSEED).GT.0.5) THEN |
| 5197 | D1=DPD |
| 5198 | D2=DTN |
| 5199 | NFP3=NFDP |
| 5200 | NFT3=NFT(JT,3) |
| 5201 | GO TO 100 |
| 5202 | ELSE |
| 5203 | D1=DPN |
| 5204 | D2=DTD |
| 5205 | NFP3=NFP(JP,3) |
| 5206 | NFT3=NFDT |
| 5207 | GO TO 100 |
| 5208 | ENDIF |
| 5209 | ELSE IF(SW.GT.MIN(SPNTD,SPDTN)+0.001 |
| 5210 | & .AND. SW.LE.MAX(SPNTD,SPDTN)+0.001) THEN |
| 5211 | IF(SPNTD.GT.SPDTN) THEN |
| 5212 | D1=DPD |
| 5213 | D2=DTN |
| 5214 | NFP3=NFDP |
| 5215 | NFT3=NFT(JT,3) |
| 5216 | GO TO 100 |
| 5217 | ELSE |
| 5218 | D1=DPN |
| 5219 | D2=DTD |
| 5220 | NFP3=NFP(JP,3) |
| 5221 | NFT3=NFDT |
| 5222 | GO TO 100 |
| 5223 | ENDIF |
| 5224 | ELSE IF(SW.LE.MIN(SPNTD,SPDTN)+0.001) THEN |
| 5225 | D1=DPN |
| 5226 | D2=DTN |
| 5227 | NFP3=NFP(JP,3) |
| 5228 | NFT3=NFT(JT,3) |
| 5229 | GO TO 100 |
| 5230 | ENDIF |
| 5231 | WRITE(6,*) ' Error in HIJSFT: There is no path to here' |
| 5232 | RETURN |
| 5233 | C |
| 5234 | C*************** elastic scattering *************** |
| 5235 | C this is like elastic, both proj and targ mass |
| 5236 | C must be fixed |
| 5237 | C*************************************************** |
| 5238 | 100 NFP5=MAX(2,NFP(JP,5)) |
| 5239 | NFT5=MAX(2,NFT(JT,5)) |
| 5240 | BB1=1.0+D1-D2 |
| 5241 | BB2=1.0+D2-D1 |
| 5242 | IF(BB1**2.LT.4.0*D1 .OR. BB2**2.LT.4.0*D2) THEN |
| 5243 | MISS=MISS+1 |
| 5244 | IF(MISS.GT.100.OR.PKC.EQ.0.0) GO TO 3000 |
| 5245 | PKC=PKC*0.5 |
| 5246 | GO TO 30 |
| 5247 | ENDIF |
| 5248 | IF(RANART(NSEED).LT.0.5) THEN |
| 5249 | X1=(BB1-SQRT(BB1**2-4.0*D1))/2.0 |
| 5250 | X2=(BB2-SQRT(BB2**2-4.0*D2))/2.0 |
| 5251 | ELSE |
| 5252 | X1=(BB1+SQRT(BB1**2-4.0*D1))/2.0 |
| 5253 | X2=(BB2+SQRT(BB2**2-4.0*D2))/2.0 |
| 5254 | ENDIF |
| 5255 | IHNT2(13)=2 |
| 5256 | GO TO 600 |
| 5257 | C |
| 5258 | C********** Single diffractive *********************** |
| 5259 | C either proj or targ's mass is fixed |
| 5260 | C***************************************************** |
| 5261 | 220 NFP5=MAX(2,NFP(JP,5)) |
| 5262 | NFT5=3 |
| 5263 | IF(NFP3.EQ.0) NFP5=3 |
| 5264 | BB2=1.0+D2-D1 |
| 5265 | IF(BB2**2.LT.4.0*D2) THEN |
| 5266 | MISS=MISS+1 |
| 5267 | IF(MISS.GT.100.OR.PKC.EQ.0.0) GO TO 3000 |
| 5268 | PKC=PKC*0.5 |
| 5269 | GO TO 30 |
| 5270 | ENDIF |
| 5271 | XMIN=(BB2-SQRT(BB2**2-4.0*D2))/2.0 |
| 5272 | XMAX=(BB2+SQRT(BB2**2-4.0*D2))/2.0 |
| 5273 | MISS4=0 |
| 5274 | 222 X2=HIRND2(6,XMIN,XMAX) |
| 5275 | X1=D1/(1.0-X2) |
| 5276 | IF(X2*(1.0-X1).LT.(D2+1.E-4/SW)) THEN |
| 5277 | MISS4=MISS4+1 |
| 5278 | IF(MISS4.LE.1000) GO TO 222 |
| 5279 | GO TO 5000 |
| 5280 | ENDIF |
| 5281 | IHNT2(13)=2 |
| 5282 | GO TO 600 |
| 5283 | C ********Fix proj mass********* |
| 5284 | 240 NFP5=3 |
| 5285 | NFT5=MAX(2,NFT(JT,5)) |
| 5286 | IF(NFT3.EQ.0) NFT5=3 |
| 5287 | BB1=1.0+D1-D2 |
| 5288 | IF(BB1**2.LT.4.0*D1) THEN |
| 5289 | MISS=MISS+1 |
| 5290 | IF(MISS.GT.100.OR.PKC.EQ.0.0) GO TO 3000 |
| 5291 | PKC=PKC*0.5 |
| 5292 | GO TO 30 |
| 5293 | ENDIF |
| 5294 | XMIN=(BB1-SQRT(BB1**2-4.0*D1))/2.0 |
| 5295 | XMAX=(BB1+SQRT(BB1**2-4.0*D1))/2.0 |
| 5296 | MISS4=0 |
| 5297 | 242 X1=HIRND2(6,XMIN,XMAX) |
| 5298 | X2=D2/(1.0-X1) |
| 5299 | IF(X1*(1.0-X2).LT.(D1+1.E-4/SW)) THEN |
| 5300 | MISS4=MISS4+1 |
| 5301 | IF(MISS4.LE.1000) GO TO 242 |
| 5302 | GO TO 5000 |
| 5303 | ENDIF |
| 5304 | IHNT2(13)=2 |
| 5305 | GO TO 600 |
| 5306 | C ********Fix targ mass********* |
| 5307 | C |
| 5308 | C*************non-single diffractive********************** |
| 5309 | C both proj and targ may not be fixed in mass |
| 5310 | C********************************************************* |
| 5311 | C |
| 5312 | 400 NFP5=3 |
| 5313 | NFT5=3 |
| 5314 | BB1=1.0+D1-D2 |
| 5315 | BB2=1.0+D2-D1 |
| 5316 | IF(BB1**2.LT.4.0*D1 .OR. BB2**2.LT.4.0*D2) THEN |
| 5317 | MISS=MISS+1 |
| 5318 | IF(MISS.GT.100.OR.PKC.EQ.0.0) GO TO 3000 |
| 5319 | PKC=PKC*0.5 |
| 5320 | GO TO 30 |
| 5321 | ENDIF |
| 5322 | XMIN1=(BB1-SQRT(BB1**2-4.0*D1))/2.0 |
| 5323 | XMAX1=(BB1+SQRT(BB1**2-4.0*D1))/2.0 |
| 5324 | XMIN2=(BB2-SQRT(BB2**2-4.0*D2))/2.0 |
| 5325 | XMAX2=(BB2+SQRT(BB2**2-4.0*D2))/2.0 |
| 5326 | MISS4=0 |
| 5327 | 410 X1=HIRND2(4,XMIN1,XMAX1) |
| 5328 | X2=HIRND2(4,XMIN2,XMAX2) |
| 5329 | IF(NFP(JP,5).EQ.3.OR.NFT(JT,5).EQ.3) THEN |
| 5330 | X1=HIRND2(6,XMIN1,XMAX1) |
| 5331 | X2=HIRND2(6,XMIN2,XMAX2) |
| 5332 | ENDIF |
| 5333 | C ******** |
| 5334 | IF(ABS(NFP(JP,1)*NFP(JP,2)).GT.1000000.OR. |
| 5335 | & ABS(NFP(JP,1)*NFP(JP,2)).LT.100) THEN |
| 5336 | X1=HIRND2(5,XMIN1,XMAX1) |
| 5337 | ENDIF |
| 5338 | IF(ABS(NFT(JT,1)*NFT(JT,2)).GT.1000000.OR. |
| 5339 | & ABS(NFT(JT,1)*NFT(JT,2)).LT.100) THEN |
| 5340 | X2=HIRND2(5,XMIN2,XMAX2) |
| 5341 | ENDIF |
| 5342 | c IF(IOPMAIN.EQ.3) X1=HIRND2(6,XMIN1,XMAX1) |
| 5343 | c IF(IOPMAIN.EQ.2) X2=HIRND2(6,XMIN2,XMAX2) |
| 5344 | C ********For q-qbar or (qq)-(qq)bar system use symetric |
| 5345 | C distribution, for q-(qq) or qbar-(qq)bar use |
| 5346 | C unsymetrical distribution |
| 5347 | C |
| 5348 | IF(ABS(NFP(JP,1)*NFP(JP,2)).GT.1000000) X1=1.0-X1 |
| 5349 | XXP=X1*(1.0-X2) |
| 5350 | XXT=X2*(1.0-X1) |
| 5351 | IF(XXP.LT.(D1+1.E-4/SW) .OR. XXT.LT.(D2+1.E-4/SW)) THEN |
| 5352 | MISS4=MISS4+1 |
| 5353 | IF(MISS4.LE.1000) GO TO 410 |
| 5354 | GO TO 5000 |
| 5355 | ENDIF |
| 5356 | IHNT2(13)=3 |
| 5357 | C*************************************************** |
| 5358 | C*************************************************** |
| 5359 | 600 CONTINUE |
| 5360 | IF(X1*(1.0-X2).LT.(AMPN**2-1.E-4)/SW.OR. |
| 5361 | & X2*(1.0-X1).LT.(AMTN**2-1.E-4)/SW) THEN |
| 5362 | MISS=MISS+1 |
| 5363 | IF(MISS.GT.100.OR.PKC.EQ.0.0) GO TO 2000 |
| 5364 | PKC=0.0 |
| 5365 | GO TO 30 |
| 5366 | ENDIF |
| 5367 | C |
| 5368 | EPP=(1.0-X2)*WP |
| 5369 | EPM=X1*WM |
| 5370 | ETP=X2*WP |
| 5371 | ETM=(1.0-X1)*WM |
| 5372 | PP(JP,3)=(EPP-EPM)/2.0 |
| 5373 | PP(JP,4)=(EPP+EPM)/2.0 |
| 5374 | IF(EPP*EPM-PTP2.LT.0.0) GO TO 6000 |
| 5375 | PP(JP,5)=SQRT(EPP*EPM-PTP2) |
| 5376 | NFP(JP,3)=NFP3 |
| 5377 | NFP(JP,5)=NFP5 |
| 5378 | |
| 5379 | PT(JT,3)=(ETP-ETM)/2.0 |
| 5380 | PT(JT,4)=(ETP+ETM)/2.0 |
| 5381 | IF(ETP*ETM-PTT2.LT.0.0) GO TO 6000 |
| 5382 | PT(JT,5)=SQRT(ETP*ETM-PTT2) |
| 5383 | NFT(JT,3)=NFT3 |
| 5384 | NFT(JT,5)=NFT5 |
| 5385 | C*****recoil PT from hard-inter is shared by two end-partons |
| 5386 | C so that pt=p1+p2 |
| 5387 | PP(JP,1)=PP11-PKC11 |
| 5388 | PP(JP,2)=PP12-PKC12 |
| 5389 | |
| 5390 | KCDIP=1 |
| 5391 | KCDIT=1 |
| 5392 | IF(ABS(NFP(JP,1)*NFP(JP,2)).GT.1000000.OR. |
| 5393 | & ABS(NFP(JP,1)*NFP(JP,2)).LT.100) THEN |
| 5394 | KCDIP=0 |
| 5395 | ENDIF |
| 5396 | IF(ABS(NFT(JT,1)*NFT(JT,2)).GT.1000000.OR. |
| 5397 | & ABS(NFT(JT,1)*NFT(JT,2)).LT.100) THEN |
| 5398 | KCDIT=0 |
| 5399 | ENDIF |
| 5400 | IF((KCDIP.EQ.0.AND.RANART(NSEED).LT.0.5) |
| 5401 | & .OR.(KCDIP.NE.0.AND.RANART(NSEED) |
| 5402 | & .LT.0.5/(1.0+(PKC11**2+PKC12**2)/HIPR1(22)**2))) THEN |
| 5403 | PP(JP,6)=(PP(JP,1)-PP(JP,6)-PP(JP,8)-DPKC1)/2.0+PP(JP,6) |
| 5404 | PP(JP,7)=(PP(JP,2)-PP(JP,7)-PP(JP,9)-DPKC2)/2.0+PP(JP,7) |
| 5405 | PP(JP,8)=(PP(JP,1)-PP(JP,6)-PP(JP,8)-DPKC1)/2.0 |
| 5406 | & +PP(JP,8)+PKC11 |
| 5407 | PP(JP,9)=(PP(JP,2)-PP(JP,7)-PP(JP,9)-DPKC2)/2.0 |
| 5408 | & +PP(JP,9)+PKC12 |
| 5409 | ELSE |
| 5410 | PP(JP,8)=(PP(JP,1)-PP(JP,6)-PP(JP,8)-DPKC1)/2.0+PP(JP,8) |
| 5411 | PP(JP,9)=(PP(JP,2)-PP(JP,7)-PP(JP,9)-DPKC2)/2.0+PP(JP,9) |
| 5412 | PP(JP,6)=(PP(JP,1)-PP(JP,6)-PP(JP,8)-DPKC1)/2.0 |
| 5413 | & +PP(JP,6)+PKC11 |
| 5414 | PP(JP,7)=(PP(JP,2)-PP(JP,7)-PP(JP,9)-DPKC2)/2.0 |
| 5415 | & +PP(JP,7)+PKC12 |
| 5416 | ENDIF |
| 5417 | PP(JP,1)=PP(JP,6)+PP(JP,8) |
| 5418 | PP(JP,2)=PP(JP,7)+PP(JP,9) |
| 5419 | C ********pt kick for proj |
| 5420 | PT(JT,1)=PT11-PKC21 |
| 5421 | PT(JT,2)=PT12-PKC22 |
| 5422 | IF((KCDIT.EQ.0.AND.RANART(NSEED).LT.0.5) |
| 5423 | & .OR.(KCDIT.NE.0.AND.RANART(NSEED) |
| 5424 | & .LT.0.5/(1.0+(PKC21**2+PKC22**2)/HIPR1(22)**2))) THEN |
| 5425 | PT(JT,6)=(PT(JT,1)-PT(JT,6)-PT(JT,8)-DPKC1)/2.0+PT(JT,6) |
| 5426 | PT(JT,7)=(PT(JT,2)-PT(JT,7)-PT(JT,9)-DPKC2)/2.0+PT(JT,7) |
| 5427 | PT(JT,8)=(PT(JT,1)-PT(JT,6)-PT(JT,8)-DPKC1)/2.0 |
| 5428 | & +PT(JT,8)+PKC21 |
| 5429 | PT(JT,9)=(PT(JT,2)-PT(JT,7)-PT(JT,9)-DPKC2)/2.0 |
| 5430 | & +PT(JT,9)+PKC22 |
| 5431 | ELSE |
| 5432 | PT(JT,8)=(PT(JT,1)-PT(JT,6)-PT(JT,8)-DPKC1)/2.0+PT(JT,8) |
| 5433 | PT(JT,9)=(PT(JT,2)-PT(JT,7)-PT(JT,9)-DPKC2)/2.0+PT(JT,9) |
| 5434 | PT(JT,6)=(PT(JT,1)-PT(JT,6)-PT(JT,8)-DPKC1)/2.0 |
| 5435 | & +PT(JT,6)+PKC21 |
| 5436 | PT(JT,7)=(PT(JT,2)-PT(JT,7)-PT(JT,9)-DPKC2)/2.0 |
| 5437 | & +PT(JT,7)+PKC22 |
| 5438 | ENDIF |
| 5439 | PT(JT,1)=PT(JT,6)+PT(JT,8) |
| 5440 | PT(JT,2)=PT(JT,7)+PT(JT,9) |
| 5441 | C ********pt kick for targ |
| 5442 | |
| 5443 | IF(NPJ(JP).NE.0) NFP(JP,5)=3 |
| 5444 | IF(NTJ(JT).NE.0) NFT(JT,5)=3 |
| 5445 | C ********jets must be connected to string |
| 5446 | IF(EPP/(EPM+0.0001).LT.ETP/(ETM+0.0001).AND. |
| 5447 | & ABS(NFP(JP,1)*NFP(JP,2)).LT.1000000)THEN |
| 5448 | DO 620 JSB=1,15 |
| 5449 | PSB=PP(JP,JSB) |
| 5450 | PP(JP,JSB)=PT(JT,JSB) |
| 5451 | PT(JT,JSB)=PSB |
| 5452 | NSB=NFP(JP,JSB) |
| 5453 | NFP(JP,JSB)=NFT(JT,JSB) |
| 5454 | NFT(JT,JSB)=NSB |
| 5455 | 620 CONTINUE |
| 5456 | C ********when Ycm(JP)<Ycm(JT) after the collision |
| 5457 | C exchange the positions of the two |
| 5458 | ENDIF |
| 5459 | C |
| 5460 | RETURN |
| 5461 | C************************************************** |
| 5462 | C************************************************** |
| 5463 | 1000 IERROR=1 |
| 5464 | IF(IHPR2(10).EQ.0) RETURN |
| 5465 | WRITE(6,*) ' Fatal HIJSFT start error,abandon this event' |
| 5466 | WRITE(6,*) ' PROJ E+,E-,W+',EPP,EPM,WP |
| 5467 | WRITE(6,*) ' TARG E+,E-,W-',ETP,ETM,WM |
| 5468 | WRITE(6,*) ' W+*W-, (APN+ATN)^2',SW,SNN |
| 5469 | RETURN |
| 5470 | 2000 IERROR=0 |
| 5471 | IF(IHPR2(10).EQ.0) RETURN |
| 5472 | WRITE(6,*) ' (2)energy partition fail,' |
| 5473 | WRITE(6,*) ' HIJSFT not performed, but continue' |
| 5474 | WRITE(6,*) ' MP1,MPN',X1*(1.0-X2)*SW,AMPN**2 |
| 5475 | WRITE(6,*) ' MT2,MTN',X2*(1.0-X1)*SW,AMTN**2 |
| 5476 | RETURN |
| 5477 | 3000 IERROR=0 |
| 5478 | IF(IHPR2(10).EQ.0) RETURN |
| 5479 | WRITE(6,*) ' (3)something is wrong with the pt kick, ' |
| 5480 | WRITE(6,*) ' HIJSFT not performed, but continue' |
| 5481 | WRITE(6,*) ' D1=',D1,' D2=',D2,' SW=',SW |
| 5482 | WRITE(6,*) ' HISTORY NFP5=',NFP(JP,5),' NFT5=',NFT(JT,5) |
| 5483 | WRITE(6,*) ' THIS COLLISON NFP5=',NFP5, ' NFT5=',NFT5 |
| 5484 | WRITE(6,*) ' # OF JET IN PROJ',NPJ(JP),' IN TARG',NTJ(JT) |
| 5485 | RETURN |
| 5486 | 4000 IERROR=0 |
| 5487 | IF(IHPR2(10).EQ.0) RETURN |
| 5488 | WRITE(6,*) ' (4)unable to choose process, but not harmful' |
| 5489 | WRITE(6,*) ' HIJSFT not performed, but continue' |
| 5490 | WRITE(6,*) ' PTP=',SQRT(PTP2),' PTT=',SQRT(PTT2),' SW=',SW |
| 5491 | WRITE(6,*) ' AMCUT=',AMX,' JP=',JP,' JT=',JT |
| 5492 | WRITE(6,*) ' HISTORY NFP5=',NFP(JP,5),' NFT5=',NFT(JT,5) |
| 5493 | RETURN |
| 5494 | 5000 IERROR=0 |
| 5495 | IF(IHPR2(10).EQ.0) RETURN |
| 5496 | WRITE(6,*) ' energy partition failed(5),for limited try' |
| 5497 | WRITE(6,*) ' HIJSFT not performed, but continue' |
| 5498 | WRITE(6,*) ' NFP5=',NFP5,' NFT5=',NFT5 |
| 5499 | WRITE(6,*) ' D1',D1,' X1(1-X2)',X1*(1.0-X2) |
| 5500 | WRITE(6,*) ' D2',D2,' X2(1-X1)',X2*(1.0-X1) |
| 5501 | RETURN |
| 5502 | 6000 PKC=0.0 |
| 5503 | MISS=MISS+1 |
| 5504 | IF(MISS.LT.100) GO TO 30 |
| 5505 | IERROR=1 |
| 5506 | IF(IHPR2(10).EQ.0) RETURN |
| 5507 | WRITE(6,*) ' ERROR OCCURED, HIJSFT NOT PERFORMED' |
| 5508 | WRITE(6,*) ' Abort this event' |
| 5509 | WRITE(6,*) 'MTP,PTP2',EPP*EPM,PTP2,' MTT,PTT2',ETP*ETM,PTT2 |
| 5510 | RETURN |
| 5511 | END |
| 5512 | C |
| 5513 | C |
| 5514 | C |
| 5515 | C ******************************************************** |
| 5516 | C ************************ WOOD-SAX |
| 5517 | SUBROUTINE HIJWDS(IA,IDH,XHIGH) |
| 5518 | C SETS UP HISTOGRAM IDH WITH RADII FOR |
| 5519 | C NUCLEUS IA DISTRIBUTED ACCORDING TO THREE PARAM WOOD SAXON |
| 5520 | COMMON/HPARNT/HIPR1(100),IHPR2(50),HINT1(100),IHNT2(50) |
| 5521 | cc SAVE /HPARNT/ |
| 5522 | COMMON/WOOD/R,D,FNORM,W |
| 5523 | cc SAVE /WOOD/ |
| 5524 | c DIMENSION IAA(20),RR(20),DD(20),WW(20),RMS(20) |
| 5525 | DIMENSION IAA(20),RR(20),DD(20),WW(20) |
| 5526 | EXTERNAL RWDSAX,WDSAX |
| 5527 | SAVE |
| 5528 | C |
| 5529 | C PARAMETERS OF SPECIAL NUCLEI FROM ATOMIC DATA AND NUC DATA TABLES |
| 5530 | C VOL 14, 5-6 1974 |
| 5531 | DATA IAA/2,4,12,16,27,32,40,56,63,93,184,197,208,7*0./ |
| 5532 | DATA RR/0.01,.964,2.355,2.608,2.84,3.458,3.766,3.971,4.214, |
| 5533 | 1 4.87,6.51,6.38,6.624,7*0./ |
| 5534 | DATA DD/0.5882,.322,.522,.513,.569,.61,.586,.5935,.586,.573, |
| 5535 | 1 .535,.535,.549,7*0./ |
| 5536 | DATA WW/0.0,.517,-0.149,-0.051,0.,-0.208,-0.161,13*0./ |
| 5537 | c DATA RMS/2.11,1.71,2.46,2.73,3.05,3.247,3.482,3.737,3.925,4.31, |
| 5538 | c 1 5.42,5.33,5.521,7*0./ |
| 5539 | C |
| 5540 | A=IA |
| 5541 | C |
| 5542 | C ********SET WOOD-SAX PARAMS FIRST AS IN DATE ET AL |
| 5543 | D=0.54 |
| 5544 | C ********D IS WOOD SAX DIFFUSE PARAM IN FM |
| 5545 | R=1.19*A**(1./3.) - 1.61*A**(-1./3.) |
| 5546 | C ********R IS RADIUS PARAM |
| 5547 | W=0. |
| 5548 | C ********W IS The third of three WOOD-SAX PARAM |
| 5549 | C |
| 5550 | C ********CHECK TABLE FOR SPECIAL CASES |
| 5551 | DO 10 I=1,13 |
| 5552 | IF (IA.EQ.IAA(I)) THEN |
| 5553 | R=RR(I) |
| 5554 | D=DD(I) |
| 5555 | W=WW(I) |
| 5556 | clin RS not used RS=RMS(I) |
| 5557 | END IF |
| 5558 | 10 CONTINUE |
| 5559 | C ********FNORM is the normalize factor |
| 5560 | FNORM=1.0 |
| 5561 | XLOW=0. |
| 5562 | XHIGH=R+ 12.*D |
| 5563 | IF (W.LT.-0.01) THEN |
| 5564 | IF (XHIGH.GT.R/SQRT(ABS(W))) XHIGH=R/SQRT(ABS(W)) |
| 5565 | END IF |
| 5566 | FGAUS=GAUSS1(RWDSAX,XLOW,XHIGH,0.001) |
| 5567 | FNORM=1./FGAUS |
| 5568 | C |
| 5569 | IF (IDH.EQ.1) THEN |
| 5570 | HINT1(72)=R |
| 5571 | HINT1(73)=D |
| 5572 | HINT1(74)=W |
| 5573 | HINT1(75)=FNORM/4.0/HIPR1(40) |
| 5574 | ELSE IF (IDH.EQ.2) THEN |
| 5575 | HINT1(76)=R |
| 5576 | HINT1(77)=D |
| 5577 | HINT1(78)=W |
| 5578 | HINT1(79)=FNORM/4.0/HIPR1(40) |
| 5579 | ENDIF |
| 5580 | C |
| 5581 | C NOW SET UP HBOOK FUNCTIONS IDH FOR R**2*RHO(R) |
| 5582 | C THESE HISTOGRAMS ARE USED TO GENERATE RANDOM RADII |
| 5583 | CALL HIFUN(IDH,XLOW,XHIGH,RWDSAX) |
| 5584 | RETURN |
| 5585 | END |
| 5586 | C |
| 5587 | C |
| 5588 | FUNCTION WDSAX(X) |
| 5589 | C ********THREE PARAMETER WOOD SAXON |
| 5590 | COMMON/WOOD/R,D,FNORM,W |
| 5591 | cc SAVE /WOOD/ |
| 5592 | SAVE |
| 5593 | WDSAX=FNORM*(1.+W*(X/R)**2)/(1+EXP((X-R)/D)) |
| 5594 | IF (W.LT.0.) THEN |
| 5595 | IF (X.GE.R/SQRT(ABS(W))) WDSAX=0. |
| 5596 | ENDIF |
| 5597 | RETURN |
| 5598 | END |
| 5599 | C |
| 5600 | C |
| 5601 | FUNCTION RWDSAX(X) |
| 5602 | SAVE |
| 5603 | RWDSAX=X*X*WDSAX(X) |
| 5604 | RETURN |
| 5605 | END |
| 5606 | C |
| 5607 | C |
| 5608 | C |
| 5609 | C |
| 5610 | C The next three subroutines are for Monte Carlo generation |
| 5611 | C according to a given function FHB. One calls first HIFUN |
| 5612 | C with assigned channel number I, low and up limits. Then to |
| 5613 | C generate the distribution one can call HIRND(I) which gives |
| 5614 | C you a random number generated according to the given function. |
| 5615 | C |
| 5616 | SUBROUTINE HIFUN(I,XMIN,XMAX,FHB) |
| 5617 | COMMON/HIJHB/RR(10,201),XX(10,201) |
| 5618 | cc SAVE /HIJHB/ |
| 5619 | EXTERNAL FHB |
| 5620 | SAVE |
| 5621 | FNORM=GAUSS1(FHB,XMIN,XMAX,0.001) |
| 5622 | DO 100 J=1,201 |
| 5623 | XX(I,J)=XMIN+(XMAX-XMIN)*(J-1)/200.0 |
| 5624 | XDD=XX(I,J) |
| 5625 | RR(I,J)=GAUSS1(FHB,XMIN,XDD,0.001)/FNORM |
| 5626 | 100 CONTINUE |
| 5627 | RETURN |
| 5628 | END |
| 5629 | C |
| 5630 | C |
| 5631 | C |
| 5632 | FUNCTION HIRND(I) |
| 5633 | COMMON/HIJHB/RR(10,201),XX(10,201) |
| 5634 | cc SAVE /HIJHB/ |
| 5635 | COMMON/RNDF77/NSEED |
| 5636 | cc SAVE /RNDF77/ |
| 5637 | SAVE |
| 5638 | RX=RANART(NSEED) |
| 5639 | JL=0 |
| 5640 | JU=202 |
| 5641 | 10 IF(JU-JL.GT.1) THEN |
| 5642 | JM=(JU+JL)/2 |
| 5643 | IF((RR(I,201).GT.RR(I,1)).EQV.(RX.GT.RR(I,JM))) THEN |
| 5644 | JL=JM |
| 5645 | ELSE |
| 5646 | JU=JM |
| 5647 | ENDIF |
| 5648 | GO TO 10 |
| 5649 | ENDIF |
| 5650 | J=JL |
| 5651 | IF(J.LT.1) J=1 |
| 5652 | IF(J.GE.201) J=200 |
| 5653 | HIRND=(XX(I,J)+XX(I,J+1))/2.0 |
| 5654 | RETURN |
| 5655 | END |
| 5656 | C |
| 5657 | C |
| 5658 | C |
| 5659 | C |
| 5660 | C This generate random number between XMIN and XMAX |
| 5661 | FUNCTION HIRND2(I,XMIN,XMAX) |
| 5662 | COMMON/HIJHB/RR(10,201),XX(10,201) |
| 5663 | cc SAVE /HIJHB/ |
| 5664 | COMMON/RNDF77/NSEED |
| 5665 | cc SAVE /RNDF77/ |
| 5666 | SAVE |
| 5667 | IF(XMIN.LT.XX(I,1)) XMIN=XX(I,1) |
| 5668 | IF(XMAX.GT.XX(I,201)) XMAX=XX(I,201) |
| 5669 | JMIN=1+int(200*(XMIN-XX(I,1))/(XX(I,201)-XX(I,1))) |
| 5670 | JMAX=1+int(200*(XMAX-XX(I,1))/(XX(I,201)-XX(I,1))) |
| 5671 | RX=RR(I,JMIN)+(RR(I,JMAX)-RR(I,JMIN))*RANART(NSEED) |
| 5672 | JL=0 |
| 5673 | JU=202 |
| 5674 | 10 IF(JU-JL.GT.1) THEN |
| 5675 | JM=(JU+JL)/2 |
| 5676 | IF((RR(I,201).GT.RR(I,1)).EQV.(RX.GT.RR(I,JM))) THEN |
| 5677 | JL=JM |
| 5678 | ELSE |
| 5679 | JU=JM |
| 5680 | ENDIF |
| 5681 | GO TO 10 |
| 5682 | ENDIF |
| 5683 | J=JL |
| 5684 | IF(J.LT.1) J=1 |
| 5685 | IF(J.GE.201) J=200 |
| 5686 | HIRND2=(XX(I,J)+XX(I,J+1))/2.0 |
| 5687 | RETURN |
| 5688 | END |
| 5689 | C |
| 5690 | C |
| 5691 | C |
| 5692 | C |
| 5693 | SUBROUTINE HIJCRS |
| 5694 | C THIS IS TO CALCULATE THE CROSS SECTIONS OF JET PRODUCTION AND |
| 5695 | C THE TOTAL INELASTIC CROSS SECTIONS. |
| 5696 | COMMON/HPARNT/HIPR1(100),IHPR2(50),HINT1(100),IHNT2(50) |
| 5697 | cc SAVE /HPARNT/ |
| 5698 | COMMON/NJET/N,ipcrs |
| 5699 | cc SAVE /NJET/ |
| 5700 | EXTERNAL FHIN,FTOT,FNJET,FTOTJT,FTOTRG |
| 5701 | SAVE |
| 5702 | IF(HINT1(1).GE.10.0) CALL CRSJET |
| 5703 | C ********calculate jet cross section(in mb) |
| 5704 | C |
| 5705 | APHX1=HIPR1(6)*(IHNT2(1)**0.3333333-1.0) |
| 5706 | APHX2=HIPR1(6)*(IHNT2(3)**0.3333333-1.0) |
| 5707 | HINT1(11)=HINT1(14)-APHX1*HINT1(15) |
| 5708 | & -APHX2*HINT1(16)+APHX1*APHX2*HINT1(17) |
| 5709 | HINT1(10)=GAUSS1(FTOTJT,0.0,20.0,0.01) |
| 5710 | HINT1(12)=GAUSS1(FHIN,0.0,20.0,0.01) |
| 5711 | HINT1(13)=GAUSS1(FTOT,0.0,20.0,0.01) |
| 5712 | HINT1(60)=HINT1(61)-APHX1*HINT1(62) |
| 5713 | & -APHX2*HINT1(63)+APHX1*APHX2*HINT1(64) |
| 5714 | HINT1(59)=GAUSS1(FTOTRG,0.0,20.0,0.01) |
| 5715 | IF(HINT1(59).EQ.0.0) HINT1(59)=HINT1(60) |
| 5716 | IF(HINT1(1).GE.10.0) Then |
| 5717 | DO 20 I=0,20 |
| 5718 | N=I |
| 5719 | HINT1(80+I)=GAUSS1(FNJET,0.0,20.0,0.01)/HINT1(12) |
| 5720 | 20 CONTINUE |
| 5721 | ENDIF |
| 5722 | HINT1(10)=HINT1(10)*HIPR1(31) |
| 5723 | HINT1(12)=HINT1(12)*HIPR1(31) |
| 5724 | HINT1(13)=HINT1(13)*HIPR1(31) |
| 5725 | HINT1(59)=HINT1(59)*HIPR1(31) |
| 5726 | C ********Total and Inel cross section are calculated |
| 5727 | C by Gaussian integration. |
| 5728 | IF(IHPR2(13).NE.0) THEN |
| 5729 | HIPR1(33)=1.36*(1.0+36.0/HINT1(1)**2) |
| 5730 | & *ALOG(0.6+0.1*HINT1(1)**2) |
| 5731 | HIPR1(33)=HIPR1(33)/HINT1(12) |
| 5732 | ENDIF |
| 5733 | C ********Parametrized cross section for single |
| 5734 | C diffractive reaction(Goulianos) |
| 5735 | RETURN |
| 5736 | END |
| 5737 | C |
| 5738 | C |
| 5739 | C |
| 5740 | C |
| 5741 | FUNCTION FTOT(X) |
| 5742 | COMMON/HPARNT/HIPR1(100),IHPR2(50),HINT1(100),IHNT2(50) |
| 5743 | cc SAVE /HPARNT/ |
| 5744 | SAVE |
| 5745 | OMG=OMG0(X)*(HIPR1(30)+HINT1(11))/HIPR1(31)/2.0 |
| 5746 | FTOT=2.0*(1.0-EXP(-OMG)) |
| 5747 | RETURN |
| 5748 | END |
| 5749 | C |
| 5750 | C |
| 5751 | C |
| 5752 | FUNCTION FHIN(X) |
| 5753 | COMMON/HPARNT/HIPR1(100),IHPR2(50),HINT1(100),IHNT2(50) |
| 5754 | cc SAVE /HPARNT/ |
| 5755 | SAVE |
| 5756 | OMG=OMG0(X)*(HIPR1(30)+HINT1(11))/HIPR1(31)/2.0 |
| 5757 | FHIN=1.0-EXP(-2.0*OMG) |
| 5758 | RETURN |
| 5759 | END |
| 5760 | C |
| 5761 | C |
| 5762 | C |
| 5763 | FUNCTION FTOTJT(X) |
| 5764 | COMMON/HPARNT/HIPR1(100),IHPR2(50),HINT1(100),IHNT2(50) |
| 5765 | cc SAVE /HPARNT/ |
| 5766 | SAVE |
| 5767 | OMG=OMG0(X)*HINT1(11)/HIPR1(31)/2.0 |
| 5768 | FTOTJT=1.0-EXP(-2.0*OMG) |
| 5769 | RETURN |
| 5770 | END |
| 5771 | C |
| 5772 | C |
| 5773 | C |
| 5774 | FUNCTION FTOTRG(X) |
| 5775 | COMMON/HPARNT/HIPR1(100),IHPR2(50),HINT1(100),IHNT2(50) |
| 5776 | cc SAVE /HPARNT/ |
| 5777 | SAVE |
| 5778 | OMG=OMG0(X)*HINT1(60)/HIPR1(31)/2.0 |
| 5779 | FTOTRG=1.0-EXP(-2.0*OMG) |
| 5780 | RETURN |
| 5781 | END |
| 5782 | C |
| 5783 | C |
| 5784 | C |
| 5785 | C |
| 5786 | FUNCTION FNJET(X) |
| 5787 | COMMON/HPARNT/HIPR1(100),IHPR2(50),HINT1(100),IHNT2(50) |
| 5788 | cc SAVE /HPARNT/ |
| 5789 | COMMON/NJET/N,ipcrs |
| 5790 | cc SAVE /NJET/ |
| 5791 | SAVE |
| 5792 | OMG1=OMG0(X)*HINT1(11)/HIPR1(31) |
| 5793 | C0=EXP(N*ALOG(OMG1)-SGMIN(N+1)) |
| 5794 | IF(N.EQ.0) C0=1.0-EXP(-2.0*OMG0(X)*HIPR1(30)/HIPR1(31)/2.0) |
| 5795 | FNJET=C0*EXP(-OMG1) |
| 5796 | RETURN |
| 5797 | END |
| 5798 | C |
| 5799 | C |
| 5800 | C |
| 5801 | C |
| 5802 | C |
| 5803 | FUNCTION SGMIN(N) |
| 5804 | SAVE |
| 5805 | GA=0. |
| 5806 | IF(N.LE.2) GO TO 20 |
| 5807 | DO 10 I=1,N-1 |
| 5808 | Z=I |
| 5809 | GA=GA+ALOG(Z) |
| 5810 | 10 CONTINUE |
| 5811 | 20 SGMIN=GA |
| 5812 | RETURN |
| 5813 | END |
| 5814 | C |
| 5815 | C |
| 5816 | C |
| 5817 | FUNCTION OMG0(X) |
| 5818 | COMMON/HPARNT/HIPR1(100),IHPR2(50),HINT1(100),IHNT2(50) |
| 5819 | cc SAVE /HPARNT/ |
| 5820 | COMMON /BESEL/X4 |
| 5821 | cc SAVE /BESEL/ |
| 5822 | EXTERNAL BK |
| 5823 | SAVE |
| 5824 | X4=HIPR1(32)*SQRT(X) |
| 5825 | OMG0=HIPR1(32)**2*GAUSS2(BK,X4,X4+20.0,0.01)/96.0 |
| 5826 | RETURN |
| 5827 | END |
| 5828 | C |
| 5829 | C |
| 5830 | C |
| 5831 | FUNCTION ROMG(X) |
| 5832 | C ********This gives the eikonal function from a table |
| 5833 | C calculated in the first call |
| 5834 | DIMENSION FR(0:1000) |
| 5835 | clin-10/29/02 unsaved FR causes wrong values for ROMG with f77 compiler: |
| 5836 | cc SAVE FR |
| 5837 | SAVE |
| 5838 | DATA I0/0/ |
| 5839 | |
| 5840 | IF(I0.NE.0) GO TO 100 |
| 5841 | DO 50 I=1,1001 |
| 5842 | XR=(I-1)*0.01 |
| 5843 | FR(I-1)=OMG0(XR) |
| 5844 | 50 CONTINUE |
| 5845 | 100 I0=1 |
| 5846 | IF(X.GE.10.0) THEN |
| 5847 | ROMG=0.0 |
| 5848 | RETURN |
| 5849 | ENDIF |
| 5850 | IX=INT(X*100) |
| 5851 | ROMG=(FR(IX)*((IX+1)*0.01-X)+FR(IX+1)*(X-IX*0.01))/0.01 |
| 5852 | RETURN |
| 5853 | END |
| 5854 | C |
| 5855 | C |
| 5856 | C |
| 5857 | FUNCTION BK(X) |
| 5858 | COMMON /BESEL/X4 |
| 5859 | cc SAVE /BESEL/ |
| 5860 | SAVE |
| 5861 | BK=EXP(-X)*(X**2-X4**2)**2.50/15.0 |
| 5862 | RETURN |
| 5863 | END |
| 5864 | C |
| 5865 | C |
| 5866 | C THIS PROGRAM IS TO CALCULATE THE JET CROSS SECTION |
| 5867 | C THE INTEGRATION IS DONE BY USING VEGAS |
| 5868 | C |
| 5869 | SUBROUTINE CRSJET |
| 5870 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) |
| 5871 | REAL HIPR1(100),HINT1(100) |
| 5872 | COMMON/HPARNT/HIPR1,IHPR2(50),HINT1,IHNT2(50) |
| 5873 | cc SAVE /HPARNT/ |
| 5874 | COMMON/NJET/N,ipcrs |
| 5875 | cc SAVE /NJET/ |
| 5876 | COMMON/BVEG1/XL(10),XU(10),ACC,NDIM,NCALL,ITMX,NPRN |
| 5877 | cc SAVE /BVEG1/ |
| 5878 | COMMON/BVEG2/XI(50,10),SI,SI2,SWGT,SCHI,NDO,IT |
| 5879 | cc SAVE /BVEG2/ |
| 5880 | COMMON/BVEG3/F,TI,TSI |
| 5881 | cc SAVE /BVEG3/ |
| 5882 | COMMON/SEDVAX/NUM1 |
| 5883 | cc SAVE /SEDVAX/ |
| 5884 | EXTERNAL FJET,FJETRG |
| 5885 | SAVE |
| 5886 | C |
| 5887 | c************************ |
| 5888 | c NCALL give the number of inner-iteration, ITMX |
| 5889 | C gives the limit of out-iteration. Nprn is an option |
| 5890 | C ( 1: print the integration process. 0: do not print) |
| 5891 | C |
| 5892 | NDIM=3 |
| 5893 | ipcrs=0 |
| 5894 | CALL VEGAS(FJET,AVGI,SD,CHI2A) |
| 5895 | HINT1(14)=sngl(AVGI)/2.5682 |
| 5896 | IF(IHPR2(6).EQ.1 .AND. IHNT2(1).GT.1) THEN |
| 5897 | ipcrs=1 |
| 5898 | CALL VEGAS(FJET,AVGI,SD,CHI2A) |
| 5899 | HINT1(15)=sngl(AVGI)/2.5682 |
| 5900 | ENDIF |
| 5901 | IF(IHPR2(6).EQ.1 .AND. IHNT2(3).GT.1) THEN |
| 5902 | ipcrs=2 |
| 5903 | CALL VEGAS(FJET,AVGI,SD,CHI2A) |
| 5904 | HINT1(16)=sngl(AVGI)/2.5682 |
| 5905 | ENDIF |
| 5906 | IF(IHPR2(6).EQ.1.AND.IHNT2(1).GT.1.AND.IHNT2(3).GT.1) THEN |
| 5907 | ipcrs=3 |
| 5908 | CALL VEGAS(FJET,AVGI,SD,CHI2A) |
| 5909 | HINT1(17)=sngl(AVGI)/2.5682 |
| 5910 | ENDIF |
| 5911 | C ********Total inclusive jet cross section(Pt>P0) |
| 5912 | C |
| 5913 | IF(IHPR2(3).NE.0) THEN |
| 5914 | ipcrs=0 |
| 5915 | CALL VEGAS(FJETRG,AVGI,SD,CHI2A) |
| 5916 | HINT1(61)=sngl(AVGI)/2.5682 |
| 5917 | IF(IHPR2(6).EQ.1 .AND. IHNT2(1).GT.1) THEN |
| 5918 | ipcrs=1 |
| 5919 | CALL VEGAS(FJETRG,AVGI,SD,CHI2A) |
| 5920 | HINT1(62)=sngl(AVGI)/2.5682 |
| 5921 | ENDIF |
| 5922 | IF(IHPR2(6).EQ.1 .AND. IHNT2(3).GT.1) THEN |
| 5923 | ipcrs=2 |
| 5924 | CALL VEGAS(FJETRG,AVGI,SD,CHI2A) |
| 5925 | HINT1(63)=sngl(AVGI)/2.5682 |
| 5926 | ENDIF |
| 5927 | IF(IHPR2(6).EQ.1.AND.IHNT2(1).GT.1.AND.IHNT2(3).GT.1) THEN |
| 5928 | ipcrs=3 |
| 5929 | CALL VEGAS(FJETRG,AVGI,SD,CHI2A) |
| 5930 | HINT1(64)=sngl(AVGI)/2.5682 |
| 5931 | ENDIF |
| 5932 | ENDIF |
| 5933 | C ********cross section of trigger jet |
| 5934 | C |
| 5935 | RETURN |
| 5936 | END |
| 5937 | C |
| 5938 | C |
| 5939 | C |
| 5940 | FUNCTION FJET(X,WGT) |
| 5941 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) |
| 5942 | REAL HIPR1(100),HINT1(100) |
| 5943 | COMMON/HPARNT/HIPR1,IHPR2(50),HINT1,IHNT2(50) |
| 5944 | cc SAVE /HPARNT/ |
| 5945 | DIMENSION X(10) |
| 5946 | SAVE |
| 5947 | WGT=WGT |
| 5948 | PT2=dble(HINT1(1)**2/4.0-HIPR1(8)**2)*X(1)+dble(HIPR1(8))**2 |
| 5949 | XT=2.0d0*DSQRT(PT2)/dble(HINT1(1)) |
| 5950 | YMX1=DLOG(1.0d0/XT+DSQRT(1.0d0/XT**2-1.0d0)) |
| 5951 | Y1=2.0d0*YMX1*X(2)-YMX1 |
| 5952 | YMX2=DLOG(2.0d0/XT-DEXP(Y1)) |
| 5953 | YMN2=DLOG(2.0d0/XT-DEXP(-Y1)) |
| 5954 | Y2=(YMX2+YMN2)*X(3)-YMN2 |
| 5955 | FJET=2.0d0*YMX1*(YMX2+YMN2)*dble(HINT1(1)**2/4.0-HIPR1(8)**2) |
| 5956 | & *G(Y1,Y2,PT2)/2.0d0 |
| 5957 | RETURN |
| 5958 | END |
| 5959 | C |
| 5960 | C |
| 5961 | C |
| 5962 | FUNCTION FJETRG(X,WGT) |
| 5963 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) |
| 5964 | REAL HIPR1(100),HINT1(100),PTMAX,PTMIN |
| 5965 | COMMON/HPARNT/HIPR1,IHPR2(50),HINT1,IHNT2(50) |
| 5966 | cc SAVE /HPARNT/ |
| 5967 | DIMENSION X(10) |
| 5968 | SAVE |
| 5969 | WGT=WGT |
| 5970 | PTMIN=ABS(HIPR1(10))-0.25 |
| 5971 | PTMIN=MAX(PTMIN,HIPR1(8)) |
| 5972 | AM2=0.D0 |
| 5973 | IF(IHPR2(3).EQ.3) THEN |
| 5974 | AM2=dble(HIPR1(7)**2) |
| 5975 | PTMIN=MAX(0.0,HIPR1(10)) |
| 5976 | ENDIF |
| 5977 | PTMAX=ABS(HIPR1(10))+0.25 |
| 5978 | IF(HIPR1(10).LE.0.0) PTMAX=HINT1(1)/2.0-sngl(AM2) |
| 5979 | IF(PTMAX.LE.PTMIN) PTMAX=PTMIN+0.25 |
| 5980 | PT2=dble(PTMAX**2-PTMIN**2)*X(1)+dble(PTMIN)**2 |
| 5981 | AMT2=PT2+AM2 |
| 5982 | XT=2.0d0*DSQRT(AMT2)/dble(HINT1(1)) |
| 5983 | YMX1=DLOG(1.0d0/XT+DSQRT(1.0d0/XT**2-1.0d0)) |
| 5984 | Y1=2.0d0*YMX1*X(2)-YMX1 |
| 5985 | YMX2=DLOG(2.0d0/XT-DEXP(Y1)) |
| 5986 | YMN2=DLOG(2.0d0/XT-DEXP(-Y1)) |
| 5987 | Y2=(YMX2+YMN2)*X(3)-YMN2 |
| 5988 | IF(IHPR2(3).EQ.3) THEN |
| 5989 | GTRIG=2.0d0*GHVQ(Y1,Y2,AMT2) |
| 5990 | ELSE IF(IHPR2(3).EQ.2) THEN |
| 5991 | GTRIG=2.0d0*GPHOTN(Y1,Y2,PT2) |
| 5992 | ELSE |
| 5993 | GTRIG=G(Y1,Y2,PT2) |
| 5994 | ENDIF |
| 5995 | FJETRG=2.0d0*YMX1*(YMX2+YMN2)*dble(PTMAX**2-PTMIN**2) |
| 5996 | & *GTRIG/2.0d0 |
| 5997 | RETURN |
| 5998 | END |
| 5999 | C |
| 6000 | C |
| 6001 | C |
| 6002 | FUNCTION GHVQ(Y1,Y2,AMT2) |
| 6003 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) |
| 6004 | REAL HIPR1(100),HINT1(100) |
| 6005 | COMMON/HPARNT/HIPR1,IHPR2(50),HINT1,IHNT2(50) |
| 6006 | cc SAVE /HPARNT/ |
| 6007 | DIMENSION F(2,7) |
| 6008 | SAVE |
| 6009 | XT=2.0d0*DSQRT(AMT2)/dble(HINT1(1)) |
| 6010 | X1=0.5d0*XT*(DEXP(Y1)+DEXP(Y2)) |
| 6011 | X2=0.5d0*XT*(DEXP(-Y1)+DEXP(-Y2)) |
| 6012 | SS=X1*X2*dble(HINT1(1))**2 |
| 6013 | AF=4.0d0 |
| 6014 | IF(IHPR2(18).NE.0) AF=5.0d0 |
| 6015 | DLAM=dble(HIPR1(15)) |
| 6016 | APH=12.0d0*3.1415926d0/(33.d0-2.d0*AF)/DLOG(AMT2/DLAM**2) |
| 6017 | C |
| 6018 | CALL PARTON(F,X1,X2,AMT2) |
| 6019 | C |
| 6020 | Gqq=4.d0*(DCOSH(Y1-Y2)+dble(HIPR1(7))**2/AMT2) |
| 6021 | & /(1.D0+DCOSH(Y1-Y2)) |
| 6022 | & /9.d0*(F(1,1)*F(2,2)+F(1,2)*F(2,1)+F(1,3)*F(2,4) |
| 6023 | & +F(1,4)*F(2,3)+F(1,5)*F(2,6)+F(1,6)*F(2,5)) |
| 6024 | Ggg=(8.D0*DCOSH(Y1-Y2)-1.D0) |
| 6025 | & *(DCOSH(Y1-Y2)+2.d0*dble(HIPR1(7))**2 |
| 6026 | & /AMT2-2.d0*dble(HIPR1(7))**4/AMT2**2)/(1.d0+DCOSH(Y1-Y2)) |
| 6027 | & /24.d0*F(1,7)*F(2,7) |
| 6028 | C |
| 6029 | GHVQ=(Gqq+Ggg)*dble(HIPR1(23))*3.14159d0*APH**2/SS**2 |
| 6030 | RETURN |
| 6031 | END |
| 6032 | C |
| 6033 | C |
| 6034 | C |
| 6035 | FUNCTION GPHOTN(Y1,Y2,PT2) |
| 6036 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) |
| 6037 | REAL HIPR1(100),HINT1(100) |
| 6038 | COMMON/HPARNT/HIPR1,IHPR2(50),HINT1,IHNT2(50) |
| 6039 | cc SAVE /HPARNT/ |
| 6040 | DIMENSION F(2,7) |
| 6041 | SAVE |
| 6042 | XT=2.d0*DSQRT(PT2)/dble(HINT1(1)) |
| 6043 | X1=0.5d0*XT*(DEXP(Y1)+DEXP(Y2)) |
| 6044 | X2=0.5d0*XT*(DEXP(-Y1)+DEXP(-Y2)) |
| 6045 | Z=DSQRT(1.D0-XT**2/X1/X2) |
| 6046 | SS=X1*X2*dble(HINT1(1))**2 |
| 6047 | T=-(1.d0-Z)/2.d0 |
| 6048 | U=-(1.d0+Z)/2.d0 |
| 6049 | AF=3.d0 |
| 6050 | DLAM=dble(HIPR1(15)) |
| 6051 | APH=12.d0*3.1415926d0/(33.d0-2.d0*AF)/DLOG(PT2/DLAM**2) |
| 6052 | APHEM=1.d0/137.d0 |
| 6053 | C |
| 6054 | CALL PARTON(F,X1,X2,PT2) |
| 6055 | C |
| 6056 | G11=-(U**2+1.d0)/U/3.d0*F(1,7)*(4.d0*F(2,1)+4.d0*F(2,2) |
| 6057 | & +F(2,3)+F(2,4)+F(2,5)+F(2,6))/9.d0 |
| 6058 | G12=-(T**2+1.d0)/T/3.d0*F(2,7)*(4.d0*F(1,1)+4.d0*F(1,2) |
| 6059 | & +F(1,3)+F(1,4)+F(1,5)+F(1,6))/9.d0 |
| 6060 | G2=8.d0*(U**2+T**2)/U/T/9.d0*(4.d0*F(1,1)*F(2,2) |
| 6061 | & +4.d0*F(1,2)*F(2,1)+F(1,3)*F(2,4)+F(1,4)*F(2,3) |
| 6062 | & +F(1,5)*F(2,6)+F(1,6)*F(2,5))/9.d0 |
| 6063 | C |
| 6064 | GPHOTN=(G11+G12+G2)*dble(HIPR1(23))*3.14159d0*APH*APHEM/SS**2 |
| 6065 | RETURN |
| 6066 | END |
| 6067 | C |
| 6068 | C |
| 6069 | C |
| 6070 | C |
| 6071 | FUNCTION G(Y1,Y2,PT2) |
| 6072 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) |
| 6073 | REAL HIPR1(100),HINT1(100) |
| 6074 | COMMON/HPARNT/HIPR1,IHPR2(50),HINT1,IHNT2(50) |
| 6075 | cc SAVE /HPARNT/ |
| 6076 | DIMENSION F(2,7) |
| 6077 | SAVE |
| 6078 | XT=2.d0*DSQRT(PT2)/dble(HINT1(1)) |
| 6079 | X1=0.5d0*XT*(DEXP(Y1)+DEXP(Y2)) |
| 6080 | X2=0.5d0*XT*(DEXP(-Y1)+DEXP(-Y2)) |
| 6081 | Z=DSQRT(1.D0-XT**2/X1/X2) |
| 6082 | SS=X1*X2*dble(HINT1(1))**2 |
| 6083 | T=-(1.d0-Z)/2.d0 |
| 6084 | U=-(1.d0+Z)/2.d0 |
| 6085 | AF=3.d0 |
| 6086 | DLAM=dble(HIPR1(15)) |
| 6087 | APH=12.d0*3.1415926d0/(33.d0-2.d0*AF)/DLOG(PT2/DLAM**2) |
| 6088 | C |
| 6089 | CALL PARTON(F,X1,X2,PT2) |
| 6090 | C |
| 6091 | G11=( (F(1,1)+F(1,2))*(F(2,3)+F(2,4)+F(2,5)+F(2,6)) |
| 6092 | & +(F(1,3)+F(1,4))*(F(2,5)+F(2,6)) )*SUBCR1(T,U) |
| 6093 | C |
| 6094 | G12=( (F(2,1)+F(2,2))*(F(1,3)+F(1,4)+F(1,5)+F(1,6)) |
| 6095 | & +(F(2,3)+F(2,4))*(F(1,5)+F(1,6)) )*SUBCR1(U,T) |
| 6096 | C |
| 6097 | 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) |
| 6098 | & +F(1,5)*F(2,5)+F(1,6)*F(2,6))*(SUBCR1(U,T) |
| 6099 | & +SUBCR1(T,U)-8.D0/T/U/27.D0) |
| 6100 | C |
| 6101 | G2=(AF-1)*(F(1,1)*F(2,2)+F(2,1)*F(1,2)+F(1,3)*F(2,4) |
| 6102 | & +F(2,3)*F(1,4)+F(1,5)*F(2,6)+F(2,5)*F(1,6))*SUBCR2(T,U) |
| 6103 | C |
| 6104 | G31=(F(1,1)*F(2,2)+F(1,3)*F(2,4)+F(1,5)*F(2,6))*SUBCR3(T,U) |
| 6105 | G32=(F(2,1)*F(1,2)+F(2,3)*F(1,4)+F(2,5)*F(1,6))*SUBCR3(U,T) |
| 6106 | C |
| 6107 | 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)+ |
| 6108 | 1 F(1,5)*F(2,6)+F(2,5)*F(1,6))*SUBCR4(T,U) |
| 6109 | C |
| 6110 | G5=AF*F(1,7)*F(2,7)*SUBCR5(T,U) |
| 6111 | C |
| 6112 | G61=F(1,7)*(F(2,1)+F(2,2)+F(2,3)+F(2,4)+F(2,5) |
| 6113 | & +F(2,6))*SUBCR6(T,U) |
| 6114 | G62=F(2,7)*(F(1,1)+F(1,2)+F(1,3)+F(1,4)+F(1,5) |
| 6115 | & +F(1,6))*SUBCR6(U,T) |
| 6116 | C |
| 6117 | G7=F(1,7)*F(2,7)*SUBCR7(T,U) |
| 6118 | C |
| 6119 | G=(G11+G12+G13+G2+G31+G32+G4+G5+G61+G62+G7)*dble(HIPR1(17))* |
| 6120 | 1 3.14159D0*APH**2/SS**2 |
| 6121 | RETURN |
| 6122 | END |
| 6123 | C |
| 6124 | C |
| 6125 | C |
| 6126 | FUNCTION SUBCR1(T,U) |
| 6127 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) |
| 6128 | SUBCR1=4.D0/9.D0*(1.D0+U**2)/T**2 |
| 6129 | RETURN |
| 6130 | END |
| 6131 | C |
| 6132 | C |
| 6133 | FUNCTION SUBCR2(T,U) |
| 6134 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) |
| 6135 | SUBCR2=4.D0/9.D0*(T**2+U**2) |
| 6136 | RETURN |
| 6137 | END |
| 6138 | C |
| 6139 | C |
| 6140 | FUNCTION SUBCR3(T,U) |
| 6141 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) |
| 6142 | SUBCR3=4.D0/9.D0*(T**2+U**2+(1.D0+U**2)/T**2 |
| 6143 | 1 -2.D0*U**2/3.D0/T) |
| 6144 | RETURN |
| 6145 | END |
| 6146 | C |
| 6147 | C |
| 6148 | FUNCTION SUBCR4(T,U) |
| 6149 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) |
| 6150 | SUBCR4=8.D0/3.D0*(T**2+U**2)*(4.D0/9.D0/T/U-1.D0) |
| 6151 | RETURN |
| 6152 | END |
| 6153 | C |
| 6154 | C |
| 6155 | C |
| 6156 | FUNCTION SUBCR5(T,U) |
| 6157 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) |
| 6158 | SUBCR5=3.D0/8.D0*(T**2+U**2)*(4.D0/9.D0/T/U-1.D0) |
| 6159 | RETURN |
| 6160 | END |
| 6161 | C |
| 6162 | C |
| 6163 | FUNCTION SUBCR6(T,U) |
| 6164 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) |
| 6165 | SUBCR6=(1.D0+U**2)*(1.D0/T**2-4.D0/U/9.D0) |
| 6166 | RETURN |
| 6167 | END |
| 6168 | C |
| 6169 | C |
| 6170 | FUNCTION SUBCR7(T,U) |
| 6171 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) |
| 6172 | SUBCR7=9.D0/2.D0*(3.D0-T*U-U/T**2-T/U**2) |
| 6173 | RETURN |
| 6174 | END |
| 6175 | C |
| 6176 | C |
| 6177 | C |
| 6178 | SUBROUTINE PARTON(F,X1,X2,QQ) |
| 6179 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) |
| 6180 | REAL HIPR1(100),HINT1(100) |
| 6181 | COMMON/HPARNT/HIPR1,IHPR2(50),HINT1,IHNT2(50) |
| 6182 | cc SAVE /HPARNT/ |
| 6183 | COMMON/NJET/N,ipcrs |
| 6184 | cc SAVE /NJET/ |
| 6185 | DIMENSION F(2,7) |
| 6186 | SAVE |
| 6187 | DLAM=dble(HIPR1(15)) |
| 6188 | Q0=dble(HIPR1(16)) |
| 6189 | S=DLOG(DLOG(QQ/DLAM**2)/DLOG(Q0**2/DLAM**2)) |
| 6190 | IF(IHPR2(7).EQ.2) GO TO 200 |
| 6191 | C******************************************************* |
| 6192 | AT1=0.419d0+0.004d0*S-0.007d0*S**2 |
| 6193 | AT2=3.460d0+0.724d0*S-0.066d0*S**2 |
| 6194 | GMUD=4.40d0-4.86d0*S+1.33d0*S**2 |
| 6195 | AT3=0.763d0-0.237d0*S+0.026d0*S**2 |
| 6196 | AT4=4.00d0+0.627d0*S-0.019d0*S**2 |
| 6197 | GMD=-0.421d0*S+0.033d0*S**2 |
| 6198 | C******************************************************* |
| 6199 | CAS=1.265d0-1.132d0*S+0.293d0*S**2 |
| 6200 | AS=-0.372d0*S-0.029d0*S**2 |
| 6201 | BS=8.05d0+1.59d0*S-0.153d0*S**2 |
| 6202 | APHS=6.31d0*S-0.273d0*S**2 |
| 6203 | BTAS=-10.5d0*S-3.17d0*S**2 |
| 6204 | GMS=14.7d0*S+9.80d0*S**2 |
| 6205 | C******************************************************** |
| 6206 | C CAC=0.135*S-0.075*S**2 |
| 6207 | C AC=-0.036-0.222*S-0.058*S**2 |
| 6208 | C BC=6.35+3.26*S-0.909*S**2 |
| 6209 | C APHC=-3.03*S+1.50*S**2 |
| 6210 | C BTAC=17.4*S-11.3*S**2 |
| 6211 | C GMC=-17.9*S+15.6*S**2 |
| 6212 | C*********************************************************** |
| 6213 | CAG=1.56d0-1.71d0*S+0.638d0*S**2 |
| 6214 | AG=-0.949d0*S+0.325d0*S**2 |
| 6215 | BG=6.0d0+1.44d0*S-1.05d0*S**2 |
| 6216 | APHG=9.0d0-7.19d0*S+0.255d0*S**2 |
| 6217 | BTAG=-16.5d0*S+10.9d0*S**2 |
| 6218 | GMG=15.3d0*S-10.1d0*S**2 |
| 6219 | GO TO 300 |
| 6220 | C******************************************************** |
| 6221 | 200 AT1=0.374d0+0.014d0*S |
| 6222 | AT2=3.33d0+0.753d0*S-0.076d0*S**2 |
| 6223 | GMUD=6.03d0-6.22d0*S+1.56d0*S**2 |
| 6224 | AT3=0.761d0-0.232d0*S+0.023d0*S**2 |
| 6225 | AT4=3.83d0+0.627d0*S-0.019d0*S**2 |
| 6226 | GMD=-0.418d0*S+0.036d0*S**2 |
| 6227 | C************************************ |
| 6228 | CAS=1.67d0-1.92d0*S+0.582d0*S**2 |
| 6229 | AS=-0.273d0*S-0.164d0*S**2 |
| 6230 | BS=9.15d0+0.530d0*S-0.763d0*S**2 |
| 6231 | APHS=15.7d0*S-2.83d0*S**2 |
| 6232 | BTAS=-101.0d0*S+44.7d0*S**2 |
| 6233 | GMS=223.0d0*S-117.0d0*S**2 |
| 6234 | C********************************* |
| 6235 | C CAC=0.067*S-0.031*S**2 |
| 6236 | C AC=-0.120-0.233*S-0.023*S**2 |
| 6237 | C BC=3.51+3.66*S-0.453*S**2 |
| 6238 | C APHC=-0.474*S+0.358*S**2 |
| 6239 | C BTAC=9.50*S-5.43*S**2 |
| 6240 | C GMC=-16.6*S+15.5*S**2 |
| 6241 | C********************************** |
| 6242 | CAG=0.879d0-0.971d0*S+0.434d0*S**2 |
| 6243 | AG=-1.16d0*S+0.476d0*S**2 |
| 6244 | BG=4.0d0+1.23d0*S-0.254d0*S**2 |
| 6245 | APHG=9.0d0-5.64d0*S-0.817d0*S**2 |
| 6246 | BTAG=-7.54d0*S+5.50d0*S**2 |
| 6247 | GMG=-0.596d0*S+1.26d0*S**2 |
| 6248 | C********************************* |
| 6249 | 300 B12=DEXP(GMRE(AT1)+GMRE(AT2+1.D0)-GMRE(AT1+AT2+1.D0)) |
| 6250 | B34=DEXP(GMRE(AT3)+GMRE(AT4+1.D0)-GMRE(AT3+AT4+1.D0)) |
| 6251 | CNUD=3.D0/B12/(1.D0+GMUD*AT1/(AT1+AT2+1.D0)) |
| 6252 | CND=1.D0/B34/(1.D0+GMD*AT3/(AT3+AT4+1.D0)) |
| 6253 | C******************************************************** |
| 6254 | C FUD=X*(U+D) |
| 6255 | C FS=X*2(UBAR+DBAR+SBAR) AND UBAR=DBAR=SBAR |
| 6256 | C******************************************************* |
| 6257 | FUD1=CNUD*X1**AT1*(1.D0-X1)**AT2*(1.D0+GMUD*X1) |
| 6258 | FS1=CAS*X1**AS*(1.D0-X1)**BS*(1.D0+APHS*X1 |
| 6259 | & +BTAS*X1**2+GMS*X1**3) |
| 6260 | F(1,3)=CND*X1**AT3*(1.D0-X1)**AT4*(1.D0+GMD*X1)+FS1/6.D0 |
| 6261 | F(1,1)=FUD1-F(1,3)+FS1/3.D0 |
| 6262 | F(1,2)=FS1/6.D0 |
| 6263 | F(1,4)=FS1/6.D0 |
| 6264 | F(1,5)=FS1/6.D0 |
| 6265 | F(1,6)=FS1/6.D0 |
| 6266 | F(1,7)=CAG*X1**AG*(1.D0-X1)**BG*(1.D0+APHG*X1 |
| 6267 | & +BTAG*X1**2+GMG*X1**3) |
| 6268 | C |
| 6269 | FUD2=CNUD*X2**AT1*(1.D0-X2)**AT2*(1.D0+GMUD*X2) |
| 6270 | FS2=CAS*X2**AS*(1.D0-X2)**BS*(1.D0+APHS*X2 |
| 6271 | & +BTAS*X2**2+GMS*X2**3) |
| 6272 | F(2,3)=CND*X2**AT3*(1.D0-X2)**AT4*(1.D0+GMD*X2)+FS2/6.D0 |
| 6273 | F(2,1)=FUD2-F(2,3)+FS2/3.D0 |
| 6274 | F(2,2)=FS2/6.D0 |
| 6275 | F(2,4)=FS2/6.D0 |
| 6276 | F(2,5)=FS2/6.D0 |
| 6277 | F(2,6)=FS2/6.D0 |
| 6278 | F(2,7)=CAG*X2**AG*(1.D0-X2)**BG*(1.D0+APHG*X2 |
| 6279 | & +BTAG*X2**2+GMG*X2**3) |
| 6280 | C***********Nuclear effect on the structure function**************** |
| 6281 | C |
| 6282 | IF(IHPR2(6).EQ.1 .AND. IHNT2(1).GT.1) THEN |
| 6283 | AAX=1.193d0*dble(ALOG(FLOAT(IHNT2(1)))**0.16666666) |
| 6284 | RRX=AAX*(X1**3-1.2d0*X1**2+0.21d0*X1)+1.d0 |
| 6285 | & +dble(1.079*(FLOAT(IHNT2(1))**0.33333333-1.0)) |
| 6286 | & /dble(ALOG(float(IHNT2(1))+1.0))*DSQRT(X1) |
| 6287 | & *DEXP(-X1**2/0.01d0) |
| 6288 | c & /DLOG(IHNT2(1)+1.0D0)*(DSQRT(X1)*DEXP(-X1**2/0.01) |
| 6289 | IF(ipcrs.EQ.1 .OR.ipcrs.EQ.3) RRX=DEXP(-X1**2/0.01d0) |
| 6290 | DO 400 I=1,7 |
| 6291 | F(1,I)=RRX*F(1,I) |
| 6292 | 400 CONTINUE |
| 6293 | ENDIF |
| 6294 | IF(IHPR2(6).EQ.1 .AND. IHNT2(3).GT.1) THEN |
| 6295 | AAX=1.193d0*dble(ALOG(FLOAT(IHNT2(3)))**0.16666666) |
| 6296 | RRX=AAX*(X2**3-1.2d0*X2**2+0.21d0*X2)+1.d0 |
| 6297 | & +dble(1.079*(FLOAT(IHNT2(3))**0.33333-1.0)) |
| 6298 | & /dble(ALOG(float(IHNT2(3))+1.0))*DSQRT(X2) |
| 6299 | & *DEXP(-X2**2/0.01d0) |
| 6300 | c & /DLOG(IHNT2(3)+1.0D0)*DSQRT(X2)*DEXP(-X2**2/0.01) |
| 6301 | IF(ipcrs.EQ.2 .OR. ipcrs.EQ.3) RRX=DEXP(-X2**2/0.01d0) |
| 6302 | DO 500 I=1,7 |
| 6303 | F(2,I)=RRX*F(2,I) |
| 6304 | 500 CONTINUE |
| 6305 | ENDIF |
| 6306 | c |
| 6307 | RETURN |
| 6308 | END |
| 6309 | C |
| 6310 | C |
| 6311 | C |
| 6312 | FUNCTION GMRE(X) |
| 6313 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) |
| 6314 | SAVE |
| 6315 | Z=X |
| 6316 | IF(X.GT.3.0D0) GO TO 10 |
| 6317 | Z=X+3.D0 |
| 6318 | 10 GMRE=0.5D0*DLOG(2.D0*3.14159265D0/Z)+Z*DLOG(Z)-Z+DLOG(1.D0 |
| 6319 | 1 +1.D0/12.D0/Z+1.D0/288.D0/Z**2-139.D0/51840.D0/Z**3 |
| 6320 | 1 -571.D0/2488320.D0/Z**4) |
| 6321 | IF(Z.EQ.X) GO TO 20 |
| 6322 | GMRE=GMRE-DLOG(Z-1.D0)-DLOG(Z-2.D0)-DLOG(Z-3.D0) |
| 6323 | 20 CONTINUE |
| 6324 | RETURN |
| 6325 | END |
| 6326 | c |
| 6327 | C |
| 6328 | C |
| 6329 | C*************************************************************** |
| 6330 | |
| 6331 | BLOCK DATA HIDATA |
| 6332 | PARAMETER (MAXSTR=150001) |
| 6333 | DOUBLE PRECISION XL(10),XU(10),ACC |
| 6334 | COMMON/BVEG1/XL,XU,ACC,NDIM,NCALL,ITMX,NPRN |
| 6335 | cc SAVE /BVEG1/ |
| 6336 | COMMON/SEDVAX/NUM1 |
| 6337 | cc SAVE /SEDVAX/ |
| 6338 | COMMON/HPARNT/HIPR1(100),IHPR2(50),HINT1(100),IHNT2(50) |
| 6339 | cc SAVE /HPARNT/ |
| 6340 | COMMON/HMAIN1/EATT,JATT,NATT,NT,NP,N0,N01,N10,N11 |
| 6341 | cc SAVE /HMAIN1/ |
| 6342 | COMMON/HMAIN2/KATT(MAXSTR,4),PATT(MAXSTR,4) |
| 6343 | cc SAVE /HMAIN2/ |
| 6344 | COMMON/HSTRNG/NFP(300,15),PP(300,15),NFT(300,15),PT(300,15) |
| 6345 | cc SAVE /HSTRNG/ |
| 6346 | COMMON/hjcrdn/YP(3,300),YT(3,300) |
| 6347 | cc SAVE /hjcrdn/ |
| 6348 | COMMON/HJJET1/NPJ(300),KFPJ(300,500),PJPX(300,500), |
| 6349 | & PJPY(300,500),PJPZ(300,500),PJPE(300,500), |
| 6350 | & PJPM(300,500),NTJ(300),KFTJ(300,500), |
| 6351 | & PJTX(300,500),PJTY(300,500),PJTZ(300,500), |
| 6352 | & PJTE(300,500),PJTM(300,500) |
| 6353 | cc SAVE /HJJET1/ |
| 6354 | COMMON/HJJET2/NSG,NJSG(MAXSTR),IASG(MAXSTR,3),K1SG(MAXSTR,100), |
| 6355 | & K2SG(MAXSTR,100),PXSG(MAXSTR,100),PYSG(MAXSTR,100), |
| 6356 | & PZSG(MAXSTR,100),PESG(MAXSTR,100),PMSG(MAXSTR,100) |
| 6357 | cc SAVE /HJJET2/ |
| 6358 | COMMON/HIJDAT/HIDAT0(10,10),HIDAT(10) |
| 6359 | cc SAVE /HIJDAT/ |
| 6360 | COMMON/HPINT/MINT4,MINT5,ATCO(200,20),ATXS(0:200) |
| 6361 | cc SAVE /HPINT/ |
| 6362 | cwei DOUBLE PRECISION PATT |
| 6363 | SAVE |
| 6364 | DATA NUM1/30123984/,XL/10*0.D0/,XU/10*1.D0/ |
| 6365 | DATA NCALL/1000/,ITMX/100/,ACC/0.01/,NPRN/0/ |
| 6366 | C...give all the switchs and parameters the default values |
| 6367 | clin-4/2008 input.ampt provides NSEED for AMPT: |
| 6368 | c DATA NSEED/74769375/ |
| 6369 | DATA HIPR1/ |
| 6370 | & 1.5, 0.35, 0.5, 0.9, 2.0, 0.1, 1.5, 2.0, -1.0, -2.25, |
| 6371 | & 2.0, 0.5, 1.0, 2.0, 0.2, 2.0, 2.5, 0.3, 0.1, 1.4, |
| 6372 | & 1.6, 1.0, 2.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.4, 57.0, |
| 6373 | & 28.5, 3.9, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, |
| 6374 | & 3.14159, |
| 6375 | & 0.0, 0.4, 0.1, 1.5, 0.1, 0.25, 0.0, 0.5, 0.0, 0.0, |
| 6376 | & 50*0.0/ |
| 6377 | |
| 6378 | DATA IHPR2/ |
| 6379 | & 1, 3, 0, 1, 1, 1, 1, 10, 0, 0, |
| 6380 | & 1, 1, 1, 1, 0, 0, 1, 0, 0, 1, |
| 6381 | & 30*0/ |
| 6382 | |
| 6383 | DATA HINT1/100*0/ |
| 6384 | DATA IHNT2/50*0/ |
| 6385 | |
| 6386 | C...initialize all the data common blocks |
| 6387 | DATA NATT/0/,EATT/0.0/,JATT/0/,NT/0/,NP/0/, |
| 6388 | 1 N0/0/,N01/0/,N10/0/,N11/0/ |
| 6389 | clin-4/26/01 |
| 6390 | c DATA KATT/520000*0/PATT/520000*0.0/ |
| 6391 | DATA KATT/600004*0/,PATT/600004*0.0/ |
| 6392 | |
| 6393 | DATA NFP/4500*0/,PP/4500*0.0/,NFT/4500*0/,PT/4500*0.0/ |
| 6394 | |
| 6395 | DATA YP/900*0.0/,YT/900*0.0/ |
| 6396 | |
| 6397 | DATA NPJ/300*0/,KFPJ/150000*0/,PJPX/150000*0.0/,PJPY/150000*0.0/ |
| 6398 | & ,PJPZ/150000*0.0/,PJPE/150000*0.0/,PJPM/150000*0.0/ |
| 6399 | DATA NTJ/300*0/,KFTJ/150000*0/,PJTX/150000*0.0/,PJTY/150000*0.0/ |
| 6400 | & ,PJTZ/150000*0.0/,PJTE/150000*0.0/,PJTM/150000*0.0/ |
| 6401 | |
| 6402 | clin-4/2008 |
| 6403 | c DATA NSG/0/,NJSG/900*0/,IASG/2700*0/,K1SG/90000*0/,K2SG/90000*0/ |
| 6404 | c & ,PXSG/90000*0.0/,PYSG/90000*0.0/,PZSG/90000*0.0/ |
| 6405 | c & ,PESG/90000*0.0/,PMSG/90000*0.0/ |
| 6406 | DATA NSG/0/,NJSG/150001*0/,IASG/450003*0/, |
| 6407 | & K1SG/15000100*0/,K2SG/15000100*0/, |
| 6408 | & PXSG/15000100*0.0/,PYSG/15000100*0.0/,PZSG/15000100*0.0/, |
| 6409 | & PESG/15000100*0.0/,PMSG/15000100*0.0/ |
| 6410 | DATA MINT4/0/,MINT5/0/,ATCO/4000*0.0/,ATXS/201*0.0/ |
| 6411 | DATA (HIDAT0(1,I),I=1,10)/0.0,0.0,0.0,0.0,0.0,0.0,2.25, |
| 6412 | & 2.5,4.0,4.1/ |
| 6413 | DATA (HIDAT0(2,I),I=1,10)/2.0,3.0,5.0,6.0,7.0,8.0,8.0,10.0, |
| 6414 | & 10.0,10.0/ |
| 6415 | DATA (HIDAT0(3,I),I=1,10)/1.0,0.8,0.8,0.7,0.45,0.215, |
| 6416 | & 0.21,0.19,0.19,0.19/ |
| 6417 | DATA (HIDAT0(4,I),I=1,10)/0.35,0.35,0.3,0.3,0.3,0.3, |
| 6418 | & 0.5,0.6,0.6,0.6/ |
| 6419 | DATA (HIDAT0(5,I),I=1,10)/23.8,24.0,26.0,26.2,27.0,28.5,28.5, |
| 6420 | & 28.5,28.5,28.5/ |
| 6421 | DATA ((HIDAT0(J,I),I=1,10),J=6,9)/40*0.0/ |
| 6422 | DATA (HIDAT0(10,I),I=1,10)/5.0,20.0,53.0,62.0,100.0,200.0, |
| 6423 | & 546.0,900.0,1800.0,4000.0/ |
| 6424 | DATA HIDAT/10*0.0/ |
| 6425 | END |
| 6426 | C******************************************************************* |
| 6427 | C |
| 6428 | C |
| 6429 | C |
| 6430 | C |
| 6431 | C******************************************************************* |
| 6432 | C SUBROUTINE PERFORMS N-DIMENSIONAL MONTE CARLO INTEG'N |
| 6433 | C - BY G.P. LEPAGE SEPT 1976/(REV)APR 1978 |
| 6434 | C******************************************************************* |
| 6435 | C |
| 6436 | SUBROUTINE VEGAS(FXN,AVGI,SD,CHI2A) |
| 6437 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) |
| 6438 | COMMON/BVEG1/XL(10),XU(10),ACC,NDIM,NCALL,ITMX,NPRN |
| 6439 | cc SAVE /BVEG1/ |
| 6440 | COMMON/BVEG2/XI(50,10),SI,SI2,SWGT,SCHI,NDO,IT |
| 6441 | cc SAVE /BVEG2/ |
| 6442 | COMMON/BVEG3/F,TI,TSI |
| 6443 | cc SAVE /BVEG3/ |
| 6444 | EXTERNAL FXN |
| 6445 | DIMENSION D(50,10),DI(50,10),XIN(50),R(50),DX(10),DT(10),X(10) |
| 6446 | 1 ,KG(10),IA(10) |
| 6447 | c REAL*4 QRAN(10) |
| 6448 | REAL QRAN(10) |
| 6449 | SAVE |
| 6450 | DATA NDMX/50/,ALPH/1.5D0/,ONE/1.D0/,MDS/-1/ |
| 6451 | C |
| 6452 | NDO=1 |
| 6453 | DO 1 J=1,NDIM |
| 6454 | 1 XI(1,J)=ONE |
| 6455 | C |
| 6456 | ENTRY VEGAS1(FXN,AVGI,SD,CHI2A) |
| 6457 | C - INITIALIZES CUMMULATIVE VARIABLES, BUT NOT GRID |
| 6458 | IT=0 |
| 6459 | SI=0.d0 |
| 6460 | SI2=SI |
| 6461 | SWGT=SI |
| 6462 | SCHI=SI |
| 6463 | C |
| 6464 | ENTRY VEGAS2(FXN,AVGI,SD,CHI2A) |
| 6465 | C - NO INITIALIZATION |
| 6466 | ND=NDMX |
| 6467 | NG=1 |
| 6468 | IF(MDS.EQ.0) GO TO 2 |
| 6469 | NG=int((real(NCALL)/2.)**(1./real(NDIM))) |
| 6470 | MDS=1 |
| 6471 | IF((2*NG-NDMX).LT.0) GO TO 2 |
| 6472 | MDS=-1 |
| 6473 | NPG=NG/NDMX+1 |
| 6474 | ND=NG/NPG |
| 6475 | NG=NPG*ND |
| 6476 | 2 K=NG**NDIM |
| 6477 | NPG=NCALL/K |
| 6478 | IF(NPG.LT.2) NPG=2 |
| 6479 | CALLS=NPG*K |
| 6480 | DXG=ONE/NG |
| 6481 | DV2G=(CALLS*DXG**NDIM)**2/NPG/NPG/(NPG-ONE) |
| 6482 | XND=ND |
| 6483 | NDM=ND-1 |
| 6484 | DXG=DXG*XND |
| 6485 | XJAC=ONE/CALLS |
| 6486 | DO 3 J=1,NDIM |
| 6487 | c***this is the line 50 |
| 6488 | DX(J)=XU(J)-XL(J) |
| 6489 | 3 XJAC=XJAC*DX(J) |
| 6490 | C |
| 6491 | C REBIN PRESERVING BIN DENSITY |
| 6492 | C |
| 6493 | IF(ND.EQ.NDO) GO TO 8 |
| 6494 | RC=NDO/XND |
| 6495 | DO 7 J=1,NDIM |
| 6496 | K=0 |
| 6497 | XN=0.d0 |
| 6498 | DR=XN |
| 6499 | I=K |
| 6500 | 4 K=K+1 |
| 6501 | DR=DR+ONE |
| 6502 | XO=XN |
| 6503 | XN=XI(K,J) |
| 6504 | 5 IF(RC.GT.DR) GO TO 4 |
| 6505 | I=I+1 |
| 6506 | DR=DR-RC |
| 6507 | XIN(I)=XN-(XN-XO)*DR |
| 6508 | IF(I.LT.NDM) GO TO 5 |
| 6509 | DO 6 I=1,NDM |
| 6510 | 6 XI(I,J)=XIN(I) |
| 6511 | 7 XI(ND,J)=ONE |
| 6512 | NDO=ND |
| 6513 | C |
| 6514 | 8 CONTINUE |
| 6515 | c IF(NPRN.NE.0) WRITE(16,200) NDIM,CALLS,IT,ITMX,ACC,MDS,ND |
| 6516 | c 1 ,(XL(J),XU(J),J=1,NDIM) |
| 6517 | C |
| 6518 | ENTRY VEGAS3(FXN,AVGI,SD,CHI2A) |
| 6519 | C - MAIN INTEGRATION LOOP |
| 6520 | 9 IT=IT+1 |
| 6521 | TI=0.d0 |
| 6522 | TSI=TI |
| 6523 | DO 10 J=1,NDIM |
| 6524 | KG(J)=1 |
| 6525 | DO 10 I=1,ND |
| 6526 | D(I,J)=TI |
| 6527 | 10 DI(I,J)=TI |
| 6528 | C |
| 6529 | 11 FB=0.d0 |
| 6530 | F2B=FB |
| 6531 | K=0 |
| 6532 | 12 K=K+1 |
| 6533 | CALL ARAN9(QRAN,NDIM) |
| 6534 | WGT=XJAC |
| 6535 | DO 15 J=1,NDIM |
| 6536 | XN=dble(float(KG(J))-QRAN(J))*DXG+ONE |
| 6537 | c*****this is the line 100 |
| 6538 | IA(J)=int(XN) |
| 6539 | IF(IA(J).GT.1) GO TO 13 |
| 6540 | XO=XI(IA(J),J) |
| 6541 | RC=(XN-IA(J))*XO |
| 6542 | GO TO 14 |
| 6543 | 13 XO=XI(IA(J),J)-XI(IA(J)-1,J) |
| 6544 | RC=XI(IA(J)-1,J)+(XN-IA(J))*XO |
| 6545 | 14 X(J)=XL(J)+RC*DX(J) |
| 6546 | WGT=WGT*XO*XND |
| 6547 | 15 CONTINUE |
| 6548 | C |
| 6549 | F=WGT |
| 6550 | F=F*FXN(X,WGT) |
| 6551 | F2=F*F |
| 6552 | FB=FB+F |
| 6553 | F2B=F2B+F2 |
| 6554 | DO 16 J=1,NDIM |
| 6555 | DI(IA(J),J)=DI(IA(J),J)+F |
| 6556 | 16 IF(MDS.GE.0) D(IA(J),J)=D(IA(J),J)+F2 |
| 6557 | IF(K.LT.NPG) GO TO 12 |
| 6558 | C |
| 6559 | F2B=DSQRT(F2B*NPG) |
| 6560 | F2B=(F2B-FB)*(F2B+FB) |
| 6561 | TI=TI+FB |
| 6562 | TSI=TSI+F2B |
| 6563 | IF(MDS.GE.0) GO TO 18 |
| 6564 | DO 17 J=1,NDIM |
| 6565 | 17 D(IA(J),J)=D(IA(J),J)+F2B |
| 6566 | 18 K=NDIM |
| 6567 | 19 KG(K)=MOD(KG(K),NG)+1 |
| 6568 | IF(KG(K).NE.1) GO TO 11 |
| 6569 | K=K-1 |
| 6570 | IF(K.GT.0) GO TO 19 |
| 6571 | C |
| 6572 | C FINAL RESULTS FOR THIS ITERATION |
| 6573 | C |
| 6574 | TSI=TSI*DV2G |
| 6575 | TI2=TI*TI |
| 6576 | WGT=TI2/(TSI+1.0d-37) |
| 6577 | SI=SI+TI*WGT |
| 6578 | SI2=SI2+TI2 |
| 6579 | SWGT=SWGT+WGT |
| 6580 | SWGT=SWGT+1.0D-37 |
| 6581 | SI2=SI2+1.0D-37 |
| 6582 | SCHI=SCHI+TI2*WGT |
| 6583 | AVGI=SI/SWGT |
| 6584 | SD=SWGT*IT/SI2 |
| 6585 | CHI2A=SD*(SCHI/SWGT-AVGI*AVGI)/dble(float(IT)-.999) |
| 6586 | SD=DSQRT(ONE/SD) |
| 6587 | C****this is the line 150 |
| 6588 | IF(NPRN.EQ.0) GO TO 21 |
| 6589 | TSI=DSQRT(TSI) |
| 6590 | c WRITE(16,201) IT,TI,TSI,AVGI,SD,CHI2A |
| 6591 | c IF(NPRN.GE.0) GO TO 21 |
| 6592 | c DO 20 J=1,NDIM |
| 6593 | c20 WRITE(16,202) J,(XI(I,J),DI(I,J),D(I,J),I=1,ND) |
| 6594 | C |
| 6595 | C REFINE GRID |
| 6596 | C |
| 6597 | 21 DO 23 J=1,NDIM |
| 6598 | XO=D(1,J) |
| 6599 | XN=D(2,J) |
| 6600 | D(1,J)=(XO+XN)/2.d0 |
| 6601 | DT(J)=D(1,J) |
| 6602 | DO 22 I=2,NDM |
| 6603 | D(I,J)=XO+XN |
| 6604 | XO=XN |
| 6605 | XN=D(I+1,J) |
| 6606 | D(I,J)=(D(I,J)+XN)/3.d0 |
| 6607 | 22 DT(J)=DT(J)+D(I,J) |
| 6608 | D(ND,J)=(XN+XO)/2.d0 |
| 6609 | 23 DT(J)=DT(J)+D(ND,J) |
| 6610 | C |
| 6611 | DO 28 J=1,NDIM |
| 6612 | RC=0.d0 |
| 6613 | DO 24 I=1,ND |
| 6614 | R(I)=0.d0 |
| 6615 | IF (DT(J).GE.1.0D18) THEN |
| 6616 | WRITE(6,*) '************** A SINGULARITY >1.0D18' |
| 6617 | C WRITE(5,1111) |
| 6618 | C1111 FORMAT(1X,'**************IMPORTANT NOTICE***************') |
| 6619 | C WRITE(5,1112) |
| 6620 | C1112 FORMAT(1X,'THE INTEGRAND GIVES RISE A SINGULARITY >1.0D18') |
| 6621 | C WRITE(5,1113) |
| 6622 | C1113 FORMAT(1X,'PLEASE CHECK THE INTEGRAND AND THE LIMITS') |
| 6623 | C WRITE(5,1114) |
| 6624 | C1114 FORMAT(1X,'**************END NOTICE*************') |
| 6625 | END IF |
| 6626 | IF(D(I,J).LE.1.0D-18) GO TO 24 |
| 6627 | XO=DT(J)/D(I,J) |
| 6628 | R(I)=((XO-ONE)/XO/DLOG(XO))**ALPH |
| 6629 | 24 RC=RC+R(I) |
| 6630 | RC=RC/XND |
| 6631 | K=0 |
| 6632 | XN=0.d0 |
| 6633 | DR=XN |
| 6634 | I=K |
| 6635 | 25 K=K+1 |
| 6636 | DR=DR+R(K) |
| 6637 | XO=XN |
| 6638 | c****this is the line 200 |
| 6639 | XN=XI(K,J) |
| 6640 | 26 IF(RC.GT.DR) GO TO 25 |
| 6641 | I=I+1 |
| 6642 | DR=DR-RC |
| 6643 | XIN(I)=XN-(XN-XO)*DR/(R(K)+1.0d-30) |
| 6644 | IF(I.LT.NDM) GO TO 26 |
| 6645 | DO 27 I=1,NDM |
| 6646 | 27 XI(I,J)=XIN(I) |
| 6647 | 28 XI(ND,J)=ONE |
| 6648 | C |
| 6649 | IF(IT.LT.ITMX.AND.ACC*DABS(AVGI).LT.SD) GO TO 9 |
| 6650 | c200 FORMAT('0INPUT PARAMETERS FOR VEGAS: NDIM=',I3,' NCALL=',F8.0 |
| 6651 | c 1 /28X,' IT=',I5,' ITMX=',I5/28X,' ACC=',G9.3 |
| 6652 | c 2 /28X,' MDS=',I3,' ND=',I4/28X,' (XL,XU)=', |
| 6653 | c 3 (T40,'( ',G12.6,' , ',G12.6,' )')) |
| 6654 | c201 FORMAT(///' INTEGRATION BY VEGAS' / '0ITERATION NO.',I3, |
| 6655 | c 1 ': INTEGRAL =',G14.8/21X,'STD DEV =',G10.4 / |
| 6656 | c 2 ' ACCUMULATED RESULTS: INTEGRAL =',G14.8 / |
| 6657 | c 3 24X,'STD DEV =',G10.4 / 24X,'CHI**2 PER IT''N =',G10.4) |
| 6658 | c202 FORMAT('0DATA FOR AXIS',I2 / ' ',6X,'X',7X,' DELT I ', |
| 6659 | c 1 2X,' CONV''CE ',11X,'X',7X,' DELT I ',2X,' CONV''CE ' |
| 6660 | c 2 ,11X,'X',7X,' DELT I ',2X,' CONV''CE ' / |
| 6661 | c 2 (' ',3G12.4,5X,3G12.4,5X,3G12.4)) |
| 6662 | RETURN |
| 6663 | END |
| 6664 | C |
| 6665 | C |
| 6666 | SUBROUTINE ARAN9(QRAN,NDIM) |
| 6667 | DIMENSION QRAN(10) |
| 6668 | COMMON/SEDVAX/NUM1 |
| 6669 | SAVE |
| 6670 | DO 1 I=1,NDIM |
| 6671 | 1 QRAN(I)=RANART(NUM1) |
| 6672 | RETURN |
| 6673 | END |
| 6674 | |
| 6675 | C |
| 6676 | C |
| 6677 | C*********GAUSSIAN ONE-DIMENSIONAL INTEGRATION PROGRAM************* |
| 6678 | C |
| 6679 | FUNCTION GAUSS1(F,A,B,EPS) |
| 6680 | EXTERNAL F |
| 6681 | DIMENSION W(12),X(12) |
| 6682 | SAVE |
| 6683 | DATA CONST/1.0E-12/ |
| 6684 | DATA W/0.1012285,.2223810,.3137067,.3623838,.0271525, |
| 6685 | & .0622535,0.0951585,.1246290,.1495960,.1691565, |
| 6686 | & .1826034,.1894506/ |
| 6687 | DATA X/0.9602899,.7966665,.5255324,.1834346,.9894009, |
| 6688 | & .9445750,0.8656312,.7554044,.6178762,.4580168, |
| 6689 | & .2816036,.0950125/ |
| 6690 | |
| 6691 | DELTA=CONST*ABS(A-B) |
| 6692 | GAUSS1=0.0 |
| 6693 | AA=A |
| 6694 | 5 Y=B-AA |
| 6695 | IF(ABS(Y).LE.DELTA) RETURN |
| 6696 | 2 BB=AA+Y |
| 6697 | C1=0.5*(AA+BB) |
| 6698 | C2=C1-AA |
| 6699 | S8=0.0 |
| 6700 | S16=0.0 |
| 6701 | DO 1 I=1,4 |
| 6702 | U=X(I)*C2 |
| 6703 | 1 S8=S8+W(I)*(F(C1+U)+F(C1-U)) |
| 6704 | DO 3 I=5,12 |
| 6705 | U=X(I)*C2 |
| 6706 | 3 S16=S16+W(I)*(F(C1+U)+F(C1-U)) |
| 6707 | S8=S8*C2 |
| 6708 | S16=S16*C2 |
| 6709 | IF(ABS(S16-S8).GT.EPS*(1.+ABS(S16))) GOTO 4 |
| 6710 | GAUSS1=GAUSS1+S16 |
| 6711 | AA=BB |
| 6712 | GOTO 5 |
| 6713 | 4 Y=0.5*Y |
| 6714 | IF(ABS(Y).GT.DELTA) GOTO 2 |
| 6715 | WRITE(6,7) |
| 6716 | GAUSS1=0.0 |
| 6717 | RETURN |
| 6718 | 7 FORMAT(1X,'GAUSS1....TOO HIGH ACURACY REQUIRED') |
| 6719 | END |
| 6720 | C |
| 6721 | C |
| 6722 | C |
| 6723 | FUNCTION GAUSS2(F,A,B,EPS) |
| 6724 | EXTERNAL F |
| 6725 | DIMENSION W(12),X(12) |
| 6726 | SAVE |
| 6727 | DATA CONST/1.0E-12/ |
| 6728 | DATA W/0.1012285,.2223810,.3137067,.3623838,.0271525, |
| 6729 | & .0622535,0.0951585,.1246290,.1495960,.1691565, |
| 6730 | & .1826034,.1894506/ |
| 6731 | DATA X/0.9602899,.7966665,.5255324,.1834346,.9894009, |
| 6732 | & .9445750,0.8656312,.7554044,.6178762,.4580168, |
| 6733 | & .2816036,.0950125/ |
| 6734 | |
| 6735 | DELTA=CONST*ABS(A-B) |
| 6736 | GAUSS2=0.0 |
| 6737 | AA=A |
| 6738 | 5 Y=B-AA |
| 6739 | IF(ABS(Y).LE.DELTA) RETURN |
| 6740 | 2 BB=AA+Y |
| 6741 | C1=0.5*(AA+BB) |
| 6742 | C2=C1-AA |
| 6743 | S8=0.0 |
| 6744 | S16=0.0 |
| 6745 | DO 1 I=1,4 |
| 6746 | U=X(I)*C2 |
| 6747 | 1 S8=S8+W(I)*(F(C1+U)+F(C1-U)) |
| 6748 | DO 3 I=5,12 |
| 6749 | U=X(I)*C2 |
| 6750 | 3 S16=S16+W(I)*(F(C1+U)+F(C1-U)) |
| 6751 | S8=S8*C2 |
| 6752 | S16=S16*C2 |
| 6753 | IF(ABS(S16-S8).GT.EPS*(1.+ABS(S16))) GOTO 4 |
| 6754 | GAUSS2=GAUSS2+S16 |
| 6755 | AA=BB |
| 6756 | GOTO 5 |
| 6757 | 4 Y=0.5*Y |
| 6758 | IF(ABS(Y).GT.DELTA) GOTO 2 |
| 6759 | WRITE(6,7) |
| 6760 | GAUSS2=0.0 |
| 6761 | RETURN |
| 6762 | 7 FORMAT(1X,'GAUSS2....TOO HIGH ACURACY REQUIRED') |
| 6763 | END |
| 6764 | C |
| 6765 | C |
| 6766 | C |
| 6767 | C |
| 6768 | C |
| 6769 | SUBROUTINE TITLE |
| 6770 | |
| 6771 | COMMON/RNDF77/NSEED |
| 6772 | cc SAVE /RNDF77/ |
| 6773 | SAVE |
| 6774 | |
| 6775 | WRITE(6,200) |
| 6776 | clin-8/15/02 f77: |
| 6777 | c200 FORMAT(//10X, |
| 6778 | c & '**************************************************'/10X, |
| 6779 | c & '* | \ _______ / ------/ *'/10X, |
| 6780 | c & '* ----- ------ |_____| /_/ / *'/10X, |
| 6781 | c & '* ||\ / |_____| / / \ *'/10X, |
| 6782 | c & '* /| \ /_/ /_______ /_ / \_ *'/10X, |
| 6783 | c & '* / | / / / / / | ------- *'/10X, |
| 6784 | c & '* | / /\ / / | / | *'/10X, |
| 6785 | c & '* | / / \ / / \_| / ------- *'/10X, |
| 6786 | 200 FORMAT(//10X, |
| 6787 | & '**************************************************'/10X, |
| 6788 | & '* | | _______ / ------/ *'/10X, |
| 6789 | & '* ----- ------ |_____| /_/ / *'/10X, |
| 6790 | & '* ||| / |_____| / / | *'/10X, |
| 6791 | & '* /| | /_/ /_______ /_ / | *'/10X, |
| 6792 | & '* / | / / / / / | ------- *'/10X, |
| 6793 | & '* | / /| / / | / | *'/10X, |
| 6794 | & '* | / / | / / _| / ------- *'/10X, |
| 6795 | & '* *'/10X, |
| 6796 | & '**************************************************'/10X, |
| 7a129c8c |
6797 | & ' HIJING (for AMPT) '/10X, |
| 0119ef9a |
6798 | & ' Heavy Ion Jet INteraction Generator '/10X, |
| 6799 | & ' by '/10X, |
| 6800 | & ' X. N. Wang and M. Gyulassy '/10X, |
| 6801 | & ' Lawrence Berkeley Laboratory '//) |
| 6802 | RETURN |
| 6803 | END |
| 6804 | |
git://git.uio.no / u / mrichter / AliRoot.git / blame