Analysis Software
Documentation for sPHENIX simulation software
 All Classes Namespaces Files Functions Variables Typedefs Enumerations Enumerator Friends Macros Groups Pages
hijhrd.f
Go to the documentation of this file. Or view the newest version in sPHENIX GitHub for file hijhrd.f
1 C
2 C
3 C
4  SUBROUTINE hijhrd(JP,JT,JOUT,JFLG,IOPJET0)
5 C
6 C IOPTJET=1, ALL JET WILL FORM SINGLE STRING SYSTEM
7 C 0, ONLY Q-QBAR JET FORM SINGLE STRING SYSTEM
8 C*******Perform jets production and fragmentation when JP JT *******
9 C scatter. JOUT-> number of hard scatterings precede this one *
10 C for the the same pair(JP,JT). JFLG->a flag to show whether *
11 C jets can be produced (with valence quark=1,gluon=2, q-qbar=3)*
12 C or not(0). Information of jets are in COMMON/ATTJET and *
13 C /MINJET. ABS(NFP(JP,6)) is the total number jets produced by *
14 C JP. If NFP(JP,6)<0 JP can not produce jet anymore. *
15 C*******************************************************************
16  dimension ip(100,2),ipq(50),ipb(50),it(100,2),itq(50),itb(50)
17  common/hijcrdn/yp(3,300),yt(3,300)
18  SAVE /hijcrdn/
19  common/hiparnt/hipr1(100),ihpr2(50),hint1(100),ihnt2(50)
20  SAVE /hiparnt/
21  common/hijdat/hidat0(10,10),hidat(10)
22  SAVE /hijdat/
23  common/histrng/nfp(300,15),pp(300,15),nft(300,15),pt(300,15)
24  SAVE /histrng/
25  common/hijjet1/npj(300),kfpj(300,500),pjpx(300,500),
26  & pjpy(300,500),pjpz(300,500),pjpe(300,500),
27  & pjpm(300,500),ntj(300),kftj(300,500),
28  & pjtx(300,500),pjty(300,500),pjtz(300,500),
29  & pjte(300,500),pjtm(300,500)
30  SAVE /hijjet1/
31  common/hijjet2/nsg,njsg(900),iasg(900,3),k1sg(900,100),
32  & k2sg(900,100),pxsg(900,100),pysg(900,100),
33  & pzsg(900,100),pesg(900,100),pmsg(900,100)
34  SAVE /hijjet2/
35 
36 C+++BAC
37 C
38 C COMMON/HIJJET4/NDR,IADR(900,2),KFDR(900),PDR(900,5)
39 C SAVE /HIJJET4/
40 C
41  common/hijjet4/ndr,iadr(900,2),kfdr(900),pdr(900,5), vdr(900,5)
42  SAVE /hijjet4/
43 
44 C---BAC
45 
46  common/ranseed/nseed
47  SAVE /ranseed/
48 C************************************ HIJING common block
49  common/lujets/n,k(9000,5),p(9000,5),v(9000,5)
50  SAVE /lujets/
51  common/ludat1/mstu(200),paru(200),mstj(200),parj(200)
52  SAVE /ludat1/
53  common/pyhisubs/msel,msub(200),kfin(2,-40:40),ckin(200)
54  SAVE /pyhisubs/
55  common/pyhipars/mstp(200),parp(200),msti(200),pari(200)
56  SAVE /pyhipars/
57  common/pyhiint1/mint(400),vint(400)
58  SAVE /pyhiint1/
59  common/pyhiint2/iset(200),kfpr(200,2),coef(200,20),icol(40,4,2)
60  SAVE /pyhiint2/
61  common/pyhiint5/ngen(0:200,3),xsec(0:200,3)
62  SAVE /pyhiint5/
63  common/hipyint/mint4,mint5,atco(200,20),atxs(0:200)
64  SAVE /hipyint/
65 C*********************************** LU common block
66  mxjt=500
67 C SIZE OF COMMON BLOCK FOR # OF PARTON PER STRING
68  mxsg=900
69 C SIZE OF COMMON BLOCK FOR # OF SINGLE STRINGS
70  mxsj=100
71 C SIZE OF COMMON BLOCK FOR # OF PARTON PER SINGLE
72 C STRING
73  jflg=0
74  ihnt2(11)=jp
75  ihnt2(12)=jt
76 C
77  iopjet=iopjet0
78  IF(iopjet.EQ.1.AND.(nfp(jp,6).NE.0.OR.nft(jt,6).NE.0))
79  & iopjet=0
80  IF(jp.GT.ihnt2(1) .OR. jt.GT.ihnt2(3)) RETURN
81  IF(nfp(jp,6).LT.0 .OR. nft(jt,6).LT.0) RETURN
82 C ******** JP or JT can not produce jet anymore
83 C
84  IF(jout.EQ.0) THEN
85  epp=pp(jp,4)+pp(jp,3)
86  epm=pp(jp,4)-pp(jp,3)
87  etp=pt(jt,4)+pt(jt,3)
88  etm=pt(jt,4)-pt(jt,3)
89  IF(epp.LT.0.0) go to 1000
90  IF(epm.LT.0.0) go to 1000
91  IF(etp.LT.0.0) go to 1000
92  IF(etm.LT.0.0) go to 1000
93  IF(epp/(epm+0.01).LE.etp/(etm+0.01)) RETURN
94  ENDIF
95 C ********for the first hard scattering of (JP,JT)
96 C have collision only when Ycm(JP)>Ycm(JT)
97 
98  ecut1=hipr1(1)+hipr1(8)+pp(jp,14)+pp(jp,15)
99  ecut2=hipr1(1)+hipr1(8)+pt(jt,14)+pt(jt,15)
100  IF(pp(jp,4).LE.ecut1) THEN
101  nfp(jp,6)=-abs(nfp(jp,6))
102  RETURN
103  ENDIF
104  IF(pt(jt,4).LE.ecut2) THEN
105  nft(jt,6)=-abs(nft(jt,6))
106  RETURN
107  ENDIF
108 C *********must have enough energy to produce jets
109 
110  miss=0
111  misp=0
112  mist=0
113 C
114  IF(nfp(jp,10).EQ.0 .AND. nft(jt,10).EQ.0) THEN
115  mint(44)=mint4
116  mint(45)=mint5
117  xsec(0,1)=atxs(0)
118  xsec(11,1)=atxs(11)
119  xsec(12,1)=atxs(12)
120  xsec(28,1)=atxs(28)
121  DO 120 i=1,20
122  coef(11,i)=atco(11,i)
123  coef(12,i)=atco(12,i)
124  coef(28,i)=atco(28,i)
125 120 CONTINUE
126  ELSE
127  isub11=0
128  isub12=0
129  isub28=0
130  IF(xsec(11,1).NE.0) isub11=1
131  IF(xsec(12,1).NE.0) isub12=1
132  IF(xsec(28,1).NE.0) isub28=1
133  mint(44)=mint4-isub11-isub12-isub28
134  mint(45)=mint5-isub11-isub12-isub28
135  xsec(0,1)=atxs(0)-atxs(11)-atxs(12)-atxs(28)
136  xsec(11,1)=0.0
137  xsec(12,1)=0.0
138  xsec(28,1)=0.0
139  DO 110 i=1,20
140  coef(11,i)=0.0
141  coef(12,i)=0.0
142  coef(28,i)=0.0
143 110 CONTINUE
144  ENDIF
145 C ********Scatter the valence quarks only once per NN
146 C collision,
147 C afterwards only gluon can have hard scattering.
148  155 CALL pyhithia
149  jj=mint(31)
150  IF(jj.NE.1) go to 155
151 C *********one hard collision at a time
152  IF(k(7,2).EQ.-k(8,2)) THEN
153  qmass2=(p(7,4)+p(8,4))**2-(p(7,1)+p(8,1))**2
154  & -(p(7,2)+p(8,2))**2-(p(7,3)+p(8,3))**2
155  qm=ulmass(k(7,2))
156  IF(qmass2.LT.(2.0*qm+hipr1(1))**2) go to 155
157  ENDIF
158 C ********q-qbar jets must has minimum mass HIPR1(1)
159  pxp=pp(jp,1)-p(3,1)
160  pyp=pp(jp,2)-p(3,2)
161  pzp=pp(jp,3)-p(3,3)
162  pep=pp(jp,4)-p(3,4)
163  pxt=pt(jt,1)-p(4,1)
164  pyt=pt(jt,2)-p(4,2)
165  pzt=pt(jt,3)-p(4,3)
166  pet=pt(jt,4)-p(4,4)
167 
168  IF(pep.LE.ecut1) THEN
169  misp=misp+1
170  IF(misp.LT.50) go to 155
171  nfp(jp,6)=-abs(nfp(jp,6))
172  RETURN
173  ENDIF
174  IF(pet.LE.ecut2) THEN
175  mist=mist+1
176  IF(mist.LT.50) go to 155
177  nft(jt,6)=-abs(nft(jt,6))
178  RETURN
179  ENDIF
180 C ******** if the remain energy<ECUT the proj or targ
181 C can not produce jet anymore
182 
183  wp=pep+pzp+pet+pzt
184  wm=pep-pzp+pet-pzt
185  IF(wp.LT.0.0 .OR. wm.LT.0.0) THEN
186  miss=miss+1
187  IF(miss.LT.50) go to 155
188  RETURN
189  ENDIF
190 C ********the total W+, W- must be positive
191  sw=wp*wm
192  ampx=sqrt((ecut1-hipr1(8))**2+pxp**2+pyp**2+0.01)
193  amtx=sqrt((ecut2-hipr1(8))**2+pxt**2+pyt**2+0.01)
194  sxx=(ampx+amtx)**2
195  IF(sw.LT.sxx.OR.vint(43).LT.hipr1(1)) THEN
196  miss=miss+1
197  IF(miss.LT.50) go to 155
198  RETURN
199  ENDIF
200 C ********the proj and targ remnants must have at least
201 C a CM energy that can produce two strings
202 C with minimum mass HIPR1(1)(see HIJSFT HIJFRG)
203 C
204  hint1(41)=p(7,1)
205  hint1(42)=p(7,2)
206  hint1(43)=p(7,3)
207  hint1(44)=p(7,4)
208  hint1(45)=p(7,5)
209  hint1(46)=sqrt(p(7,1)**2+p(7,2)**2)
210  hint1(51)=p(8,1)
211  hint1(52)=p(8,2)
212  hint1(53)=p(8,3)
213  hint1(54)=p(8,4)
214  hint1(55)=p(8,5)
215  hint1(56)=sqrt(p(8,1)**2+p(8,2)**2)
216  ihnt2(14)=k(7,2)
217  ihnt2(15)=k(8,2)
218 C
219  pinirad=(1.0-exp(-2.0*(vint(47)-hidat(1))))
220  & /(1.0+exp(-2.0*(vint(47)-hidat(1))))
221  i_inirad=0
222  IF(atl_ran(nseed).LE.pinirad) i_inirad=1
223  IF(k(7,2).EQ.-k(8,2)) go to 190
224  IF(k(7,2).EQ.21.AND.k(8,2).EQ.21.AND.iopjet.EQ.1) go to 190
225 C*******************************************************************
226 C gluon jets are going to be connectd with
227 C the final leading string of quark-aintquark
228 C*******************************************************************
229  jflg=2
230  jpp=0
231  lpq=0
232  lpb=0
233  jtt=0
234  ltq=0
235  ltb=0
236  is7=0
237  is8=0
238  hint1(47)=0.0
239  hint1(48)=0.0
240  hint1(49)=0.0
241  hint1(50)=0.0
242  hint1(67)=0.0
243  hint1(68)=0.0
244  hint1(69)=0.0
245  hint1(70)=0.0
246  DO 180 i=9,n
247  IF(k(i,3).EQ.1 .OR. k(i,3).EQ.2.OR.
248  & abs(k(i,2)).GT.30) go to 180
249 C************************************************************
250  IF(k(i,3).EQ.7) THEN
251  hint1(47)=hint1(47)+p(i,1)
252  hint1(48)=hint1(48)+p(i,2)
253  hint1(49)=hint1(49)+p(i,3)
254  hint1(50)=hint1(50)+p(i,4)
255  ENDIF
256  IF(k(i,3).EQ.8) THEN
257  hint1(67)=hint1(67)+p(i,1)
258  hint1(68)=hint1(68)+p(i,2)
259  hint1(69)=hint1(69)+p(i,3)
260  hint1(70)=hint1(70)+p(i,4)
261  ENDIF
262 C************************modifcation made on Apr 10. 1996*****
263  IF(k(i,2).GT.21.AND.k(i,2).LE.30) THEN
264  ndr=ndr+1
265  iadr(ndr,1)=jp
266  iadr(ndr,2)=jt
267  kfdr(ndr)=k(i,2)
268  pdr(ndr,1)=p(i,1)
269  pdr(ndr,2)=p(i,2)
270  pdr(ndr,3)=p(i,3)
271  pdr(ndr,4)=p(i,4)
272  pdr(ndr,5)=p(i,5)
273 
274  vdr(ndr,1)=v(i,1)
275  vdr(ndr,2)=v(i,2)
276  vdr(ndr,3)=v(i,3)
277  vdr(ndr,4)=v(i,4)
278 
279 C************************************************************
280  go to 180
281 C************************correction made on Oct. 14,1994*****
282  ENDIF
283  IF(k(i,3).EQ.7.OR.k(i,3).EQ.3) THEN
284  IF(k(i,3).EQ.7.AND.k(i,2).NE.21.AND.k(i,2).EQ.k(7,2)
285  & .AND.is7.EQ.0) THEN
286  pp(jp,10)=p(i,1)
287  pp(jp,11)=p(i,2)
288  pp(jp,12)=p(i,3)
289  pzp=pzp+p(i,3)
290  pep=pep+p(i,4)
291  nfp(jp,10)=1
292  is7=1
293  go to 180
294  ENDIF
295  IF(k(i,3).EQ.3.AND.(k(i,2).NE.21.OR.
296  & i_inirad.EQ.0)) THEN
297  pxp=pxp+p(i,1)
298  pyp=pyp+p(i,2)
299  pzp=pzp+p(i,3)
300  pep=pep+p(i,4)
301  go to 180
302  ENDIF
303  jpp=jpp+1
304  ip(jpp,1)=i
305  ip(jpp,2)=0
306  IF(k(i,2).NE.21) THEN
307  IF(k(i,2).GT.0) THEN
308  lpq=lpq+1
309  ipq(lpq)=jpp
310  ip(jpp,2)=lpq
311  ELSE IF(k(i,2).LT.0) THEN
312  lpb=lpb+1
313  ipb(lpb)=jpp
314  ip(jpp,2)=-lpb
315  ENDIF
316  ENDIF
317  ELSE IF(k(i,3).EQ.8.OR.k(i,3).EQ.4) THEN
318  IF(k(i,3).EQ.8.AND.k(i,2).NE.21.AND.k(i,2).EQ.k(8,2)
319  & .AND.is8.EQ.0) THEN
320  pt(jt,10)=p(i,1)
321  pt(jt,11)=p(i,2)
322  pt(jt,12)=p(i,3)
323  pzt=pzt+p(i,3)
324  pet=pet+p(i,4)
325  nft(jt,10)=1
326  is8=1
327  go to 180
328  ENDIF
329  IF(k(i,3).EQ.4.AND.(k(i,2).NE.21.OR.
330  & i_inirad.EQ.0)) THEN
331  pxt=pxt+p(i,1)
332  pyt=pyt+p(i,2)
333  pzt=pzt+p(i,3)
334  pet=pet+p(i,4)
335  go to 180
336  ENDIF
337  jtt=jtt+1
338  it(jtt,1)=i
339  it(jtt,2)=0
340  IF(k(i,2).NE.21) THEN
341  IF(k(i,2).GT.0) THEN
342  ltq=ltq+1
343  itq(ltq)=jtt
344  it(jtt,2)=ltq
345  ELSE IF(k(i,2).LT.0) THEN
346  ltb=ltb+1
347  itb(ltb)=jtt
348  it(jtt,2)=-ltb
349  ENDIF
350  ENDIF
351  ENDIF
352  180 CONTINUE
353 c
354 c
355  IF(lpq.NE.lpb .OR. ltq.NE.ltb) THEN
356  miss=miss+1
357  IF(miss.LE.50) go to 155
358  WRITE(6,*) ' Q -QBAR NOT MATCHED IN HIJHRD'
359  jflg=0
360  RETURN
361  ENDIF
362 C****The following will rearrange the partons so that a quark is***
363 C****allways followed by an anti-quark ****************************
364 
365  j=0
366 181 j=j+1
367  IF(j.GT.jpp) go to 182
368  IF(ip(j,2).EQ.0) THEN
369  go to 181
370  ELSE IF(ip(j,2).NE.0) THEN
371  lp=abs(ip(j,2))
372  ip1=ip(j,1)
373  ip2=ip(j,2)
374  ip(j,1)=ip(ipq(lp),1)
375  ip(j,2)=ip(ipq(lp),2)
376  ip(ipq(lp),1)=ip1
377  ip(ipq(lp),2)=ip2
378  IF(ip2.GT.0) THEN
379  ipq(ip2)=ipq(lp)
380  ELSE IF(ip2.LT.0) THEN
381  ipb(-ip2)=ipq(lp)
382  ENDIF
383 C ********replace J with a quark
384  ip1=ip(j+1,1)
385  ip2=ip(j+1,2)
386  ip(j+1,1)=ip(ipb(lp),1)
387  ip(j+1,2)=ip(ipb(lp),2)
388  ip(ipb(lp),1)=ip1
389  ip(ipb(lp),2)=ip2
390  IF(ip2.GT.0) THEN
391  ipq(ip2)=ipb(lp)
392  ELSE IF(ip2.LT.0) THEN
393  ipb(-ip2)=ipb(lp)
394  ENDIF
395 C ******** replace J+1 with anti-quark
396  j=j+1
397  go to 181
398  ENDIF
399 
400 182 j=0
401 183 j=j+1
402  IF(j.GT.jtt) go to 184
403  IF(it(j,2).EQ.0) THEN
404  go to 183
405  ELSE IF(it(j,2).NE.0) THEN
406  lt=abs(it(j,2))
407  it1=it(j,1)
408  it2=it(j,2)
409  it(j,1)=it(itq(lt),1)
410  it(j,2)=it(itq(lt),2)
411  it(itq(lt),1)=it1
412  it(itq(lt),2)=it2
413  IF(it2.GT.0) THEN
414  itq(it2)=itq(lt)
415  ELSE IF(it2.LT.0) THEN
416  itb(-it2)=itq(lt)
417  ENDIF
418 C ********replace J with a quark
419  it1=it(j+1,1)
420  it2=it(j+1,2)
421  it(j+1,1)=it(itb(lt),1)
422  it(j+1,2)=it(itb(lt),2)
423  it(itb(lt),1)=it1
424  it(itb(lt),2)=it2
425  IF(it2.GT.0) THEN
426  itq(it2)=itb(lt)
427  ELSE IF(it2.LT.0) THEN
428  itb(-it2)=itb(lt)
429  ENDIF
430 C ******** replace J+1 with anti-quark
431  j=j+1
432  go to 183
433 
434  ENDIF
435 
436 184 CONTINUE
437  IF(npj(jp)+jpp.GT.mxjt.OR.ntj(jt)+jtt.GT.mxjt) THEN
438  jflg=0
439  WRITE(6,*) 'number of partons per string exceeds'
440  WRITE(6,*) 'the common block size'
441  RETURN
442  ENDIF
443 C ********check the bounds of common blocks
444  DO 186 j=1,jpp
445  kfpj(jp,npj(jp)+j)=k(ip(j,1),2)
446  pjpx(jp,npj(jp)+j)=p(ip(j,1),1)
447  pjpy(jp,npj(jp)+j)=p(ip(j,1),2)
448  pjpz(jp,npj(jp)+j)=p(ip(j,1),3)
449  pjpe(jp,npj(jp)+j)=p(ip(j,1),4)
450  pjpm(jp,npj(jp)+j)=p(ip(j,1),5)
451 186 CONTINUE
452  npj(jp)=npj(jp)+jpp
453  DO 188 j=1,jtt
454  kftj(jt,ntj(jt)+j)=k(it(j,1),2)
455  pjtx(jt,ntj(jt)+j)=p(it(j,1),1)
456  pjty(jt,ntj(jt)+j)=p(it(j,1),2)
457  pjtz(jt,ntj(jt)+j)=p(it(j,1),3)
458  pjte(jt,ntj(jt)+j)=p(it(j,1),4)
459  pjtm(jt,ntj(jt)+j)=p(it(j,1),5)
460 188 CONTINUE
461  ntj(jt)=ntj(jt)+jtt
462  go to 900
463 C*****************************************************************
464 CThis is the case of a quark-antiquark jet it will fragment alone
465 C****************************************************************
466 190 jflg=3
467  IF(k(7,2).NE.21.AND.k(8,2).NE.21.AND.
468  & k(7,2)*k(8,2).GT.0) go to 155
469  jpp=0
470  lpq=0
471  lpb=0
472  DO 200 i=9,n
473  IF(k(i,3).EQ.1.OR.k(i,3).EQ.2.OR.
474  & abs(k(i,2)).GT.30) go to 200
475  IF(k(i,2).GT.21.AND.k(i,2).LE.30) THEN
476  ndr=ndr+1
477  iadr(ndr,1)=jp
478  iadr(ndr,2)=jt
479  kfdr(ndr)=k(i,2)
480  pdr(ndr,1)=p(i,1)
481  pdr(ndr,2)=p(i,2)
482  pdr(ndr,3)=p(i,3)
483  pdr(ndr,4)=p(i,4)
484  pdr(ndr,5)=p(i,5)
485 
486  vdr(ndr,1)=v(i,1)
487  vdr(ndr,2)=v(i,2)
488  vdr(ndr,3)=v(i,3)
489  vdr(ndr,4)=v(i,4)
490 
491 C************************************************************
492  go to 200
493 C************************correction made on Oct. 14,1994*****
494  ENDIF
495  IF(k(i,3).EQ.3.AND.(k(i,2).NE.21.OR.
496  & i_inirad.EQ.0)) THEN
497  pxp=pxp+p(i,1)
498  pyp=pyp+p(i,2)
499  pzp=pzp+p(i,3)
500  pep=pep+p(i,4)
501  go to 200
502  ENDIF
503  IF(k(i,3).EQ.4.AND.(k(i,2).NE.21.OR.
504  & i_inirad.EQ.0)) THEN
505  pxt=pxt+p(i,1)
506  pyt=pyt+p(i,2)
507  pzt=pzt+p(i,3)
508  pet=pet+p(i,4)
509  go to 200
510  ENDIF
511  jpp=jpp+1
512  ip(jpp,1)=i
513  ip(jpp,2)=0
514  IF(k(i,2).NE.21) THEN
515  IF(k(i,2).GT.0) THEN
516  lpq=lpq+1
517  ipq(lpq)=jpp
518  ip(jpp,2)=lpq
519  ELSE IF(k(i,2).LT.0) THEN
520  lpb=lpb+1
521  ipb(lpb)=jpp
522  ip(jpp,2)=-lpb
523  ENDIF
524  ENDIF
525 200 CONTINUE
526  IF(lpq.NE.lpb) THEN
527  miss=miss+1
528  IF(miss.LE.50) go to 155
529  WRITE(6,*) lpq,lpb, 'Q-QBAR NOT CONSERVED OR NOT MATCHED'
530  jflg=0
531  RETURN
532  ENDIF
533 
534 C**** The following will rearrange the partons so that a quark is***
535 C**** allways followed by an anti-quark ****************************
536  j=0
537 220 j=j+1
538  IF(j.GT.jpp) go to 222
539  IF(ip(j,2).EQ.0) go to 220
540  lp=abs(ip(j,2))
541  ip1=ip(j,1)
542  ip2=ip(j,2)
543  ip(j,1)=ip(ipq(lp),1)
544  ip(j,2)=ip(ipq(lp),2)
545  ip(ipq(lp),1)=ip1
546  ip(ipq(lp),2)=ip2
547  IF(ip2.GT.0) THEN
548  ipq(ip2)=ipq(lp)
549  ELSE IF(ip2.LT.0) THEN
550  ipb(-ip2)=ipq(lp)
551  ENDIF
552  ipq(lp)=j
553 C ********replace J with a quark
554  ip1=ip(j+1,1)
555  ip2=ip(j+1,2)
556  ip(j+1,1)=ip(ipb(lp),1)
557  ip(j+1,2)=ip(ipb(lp),2)
558  ip(ipb(lp),1)=ip1
559  ip(ipb(lp),2)=ip2
560  IF(ip2.GT.0) THEN
561  ipq(ip2)=ipb(lp)
562  ELSE IF(ip2.LT.0) THEN
563  ipb(-ip2)=ipb(lp)
564  ENDIF
565 C ******** replace J+1 with an anti-quark
566  ipb(lp)=j+1
567  j=j+1
568  go to 220
569 
570 222 CONTINUE
571  IF(lpq.GE.1) THEN
572  DO 240 l0=2,lpq
573  ip1=ip(2*l0-3,1)
574  ip2=ip(2*l0-3,2)
575  ip(2*l0-3,1)=ip(ipq(l0),1)
576  ip(2*l0-3,2)=ip(ipq(l0),2)
577  ip(ipq(l0),1)=ip1
578  ip(ipq(l0),2)=ip2
579  IF(ip2.GT.0) THEN
580  ipq(ip2)=ipq(l0)
581  ELSE IF(ip2.LT.0) THEN
582  ipb(-ip2)=ipq(l0)
583  ENDIF
584  ipq(l0)=2*l0-3
585 C
586  ip1=ip(2*l0-2,1)
587  ip2=ip(2*l0-2,2)
588  ip(2*l0-2,1)=ip(ipb(l0),1)
589  ip(2*l0-2,2)=ip(ipb(l0),2)
590  ip(ipb(l0),1)=ip1
591  ip(ipb(l0),2)=ip2
592  IF(ip2.GT.0) THEN
593  ipq(ip2)=ipb(l0)
594  ELSE IF(ip2.LT.0) THEN
595  ipb(-ip2)=ipb(l0)
596  ENDIF
597  ipb(l0)=2*l0-2
598 240 CONTINUE
599 C ********move all the qqbar pair to the front of
600 C the list, except the first pair
601  ip1=ip(2*lpq-1,1)
602  ip2=ip(2*lpq-1,2)
603  ip(2*lpq-1,1)=ip(ipq(1),1)
604  ip(2*lpq-1,2)=ip(ipq(1),2)
605  ip(ipq(1),1)=ip1
606  ip(ipq(1),2)=ip2
607  IF(ip2.GT.0) THEN
608  ipq(ip2)=ipq(1)
609  ELSE IF(ip2.LT.0) THEN
610  ipb(-ip2)=ipq(1)
611  ENDIF
612  ipq(1)=2*lpq-1
613 C ********move the first quark to the beginning of
614 C the last string system
615  ip1=ip(jpp,1)
616  ip2=ip(jpp,2)
617  ip(jpp,1)=ip(ipb(1),1)
618  ip(jpp,2)=ip(ipb(1),2)
619  ip(ipb(1),1)=ip1
620  ip(ipb(1),2)=ip2
621  IF(ip2.GT.0) THEN
622  ipq(ip2)=ipb(1)
623  ELSE IF(ip2.LT.0) THEN
624  ipb(-ip2)=ipb(1)
625  ENDIF
626  ipb(1)=jpp
627 C ********move the first anti-quark to the end of the
628 C last string system
629  ENDIF
630  IF(nsg.GE.mxsg) THEN
631  jflg=0
632  WRITE(6,*) 'number of jets forming single strings exceeds'
633  WRITE(6,*) 'the common block size'
634  RETURN
635  ENDIF
636  IF(jpp.GT.mxsj) THEN
637  jflg=0
638  WRITE(6,*) 'number of partons per single jet system'
639  WRITE(6,*) 'exceeds the common block size'
640  RETURN
641  ENDIF
642 C ********check the bounds of common block size
643  nsg=nsg+1
644  njsg(nsg)=jpp
645  iasg(nsg,1)=jp
646  iasg(nsg,2)=jt
647  iasg(nsg,3)=0
648  DO 300 i=1,jpp
649  k1sg(nsg,i)=2
650  k2sg(nsg,i)=k(ip(i,1),2)
651  IF(k2sg(nsg,i).LT.0) k1sg(nsg,i)=1
652  pxsg(nsg,i)=p(ip(i,1),1)
653  pysg(nsg,i)=p(ip(i,1),2)
654  pzsg(nsg,i)=p(ip(i,1),3)
655  pesg(nsg,i)=p(ip(i,1),4)
656  pmsg(nsg,i)=p(ip(i,1),5)
657 300 CONTINUE
658  k1sg(nsg,1)=2
659  k1sg(nsg,jpp)=1
660 C******* reset the energy-momentum of incoming particles ********
661 900 pp(jp,1)=pxp
662  pp(jp,2)=pyp
663  pp(jp,3)=pzp
664  pp(jp,4)=pep
665  pp(jp,5)=0.0
666  pt(jt,1)=pxt
667  pt(jt,2)=pyt
668  pt(jt,3)=pzt
669  pt(jt,4)=pet
670  pt(jt,5)=0.0
671 
672  nfp(jp,6)=nfp(jp,6)+1
673  nft(jt,6)=nft(jt,6)+1
674  RETURN
675 C
676 1000 jflg=-1
677  IF(ihpr2(10).EQ.0) RETURN
678  WRITE(6,*) 'Fatal HIJHRD error'
679  WRITE(6,*) jp, ' proj E+,E-',epp,epm,' status',nfp(jp,5)
680  WRITE(6,*) jt, ' targ E+,E_',etp,etm,' status',nft(jt,5)
681  RETURN
682  END