]> git.uio.no Git - u/mrichter/AliRoot.git/blame - HIJING/hijing1_36/hijhrd.F
git://git.uio.no / u / mrichter / AliRoot.git / blame
? search:
summary | shortlog | log | commit | commitdiff | tree
blob | blame (incremental) | history | HEAD
Extra header added to the list
[u/mrichter/AliRoot.git] / HIJING / hijing1_36 / hijhrd.F
CommitLineData
e74335a4 1* $Id$
2C
3C
4C
5 SUBROUTINE HIJHRD(JP,JT,JOUT,JFLG,IOPJET0)
6C
7C IOPTJET=1, ALL JET WILL FORM SINGLE STRING SYSTEM
8C 0, ONLY Q-QBAR JET FORM SINGLE STRING SYSTEM
9C*******Perform jets production and fragmentation when JP JT *******
10C scatter. JOUT-> number of hard scatterings precede this one *
11C for the the same pair(JP,JT). JFLG->a flag to show whether *
12C jets can be produced (with valence quark=1,gluon=2, q-qbar=3)*
13C or not(0). Information of jets are in COMMON/ATTJET and *
14C /MINJET. ABS(NFP(JP,6)) is the total number jets produced by *
15C JP. If NFP(JP,6)<0 JP can not produce jet anymore. *
16C*******************************************************************
17 DIMENSION IP(100,2),IPQ(50),IPB(50),IT(100,2),ITQ(50),ITB(50)
bc676b8e 18#define BLANKET_SAVE
e74335a4 19#include "hijcrdn.inc"
20#include "hiparnt.inc"
21#include "hijdat.inc"
22#include "histrng.inc"
23#include "hijjet1.inc"
24#include "hijjet2.inc"
25#include "hijjet4.inc"
26C************************************ HIJING common block
27#include "lujets_hijing.inc"
28#include "ludat1_hijing.inc"
29#include "pysubs_hijing.inc"
30#include "pypars_hijing.inc"
31#include "pyint1_hijing.inc"
32#include "pyint2_hijing.inc"
33#include "pyint5_hijing.inc"
34#include "hipyint.inc"
35 SAVE
36C*********************************** LU common block
37 MXJT=500
38C SIZE OF COMMON BLOCK FOR # OF PARTON PER STRING
39 MXSG=900
40C SIZE OF COMMON BLOCK FOR # OF SINGLE STRINGS
41 MXSJ=100
42C SIZE OF COMMON BLOCK FOR # OF PARTON PER SINGLE
43C STRING
44 JFLG=0
45 IHNT2(11)=JP
46 IHNT2(12)=JT
47C
48 IOPJET=IOPJET0
49 IF(IOPJET.EQ.1.AND.(NFP(JP,6).NE.0.OR.NFT(JT,6).NE.0))
50 & IOPJET=0
51 IF(JP.GT.IHNT2(1) .OR. JT.GT.IHNT2(3)) RETURN
52 IF(NFP(JP,6).LT.0 .OR. NFT(JT,6).LT.0) RETURN
53C ******** JP or JT can not produce jet anymore
54C
55 IF(JOUT.EQ.0) THEN
56 EPP=PP(JP,4)+PP(JP,3)
57 EPM=PP(JP,4)-PP(JP,3)
58 ETP=PT(JT,4)+PT(JT,3)
59 ETM=PT(JT,4)-PT(JT,3)
60 IF(EPP.LT.0.0) GO TO 1000
61 IF(EPM.LT.0.0) GO TO 1000
62 IF(ETP.LT.0.0) GO TO 1000
63 IF(ETM.LT.0.0) GO TO 1000
64 IF(EPP/(EPM+0.01).LE.ETP/(ETM+0.01)) RETURN
65 ENDIF
66C ********for the first hard scattering of (JP,JT)
67C have collision only when Ycm(JP)>Ycm(JT)
68
69 ECUT1=HIPR1(1)+HIPR1(8)+PP(JP,14)+PP(JP,15)
70 ECUT2=HIPR1(1)+HIPR1(8)+PT(JT,14)+PT(JT,15)
71 IF(PP(JP,4).LE.ECUT1) THEN
72 NFP(JP,6)=-ABS(NFP(JP,6))
73 RETURN
74 ENDIF
75 IF(PT(JT,4).LE.ECUT2) THEN
76 NFT(JT,6)=-ABS(NFT(JT,6))
77 RETURN
78 ENDIF
79C *********must have enough energy to produce jets
80
81 MISS=0
82 MISP=0
83 MIST=0
84C
85 IF(NFP(JP,10).EQ.0 .AND. NFT(JT,10).EQ.0) THEN
86 MINT(44)=MINT4
87 MINT(45)=MINT5
88 XSEC(0,1)=ATXS(0)
89 XSEC(11,1)=ATXS(11)
90 XSEC(12,1)=ATXS(12)
91 XSEC(28,1)=ATXS(28)
92 DO 120 I=1,20
93 COEF(11,I)=ATCO(11,I)
94 COEF(12,I)=ATCO(12,I)
95 COEF(28,I)=ATCO(28,I)
96120 CONTINUE
97 ELSE
98 ISUB11=0
99 ISUB12=0
100 ISUB28=0
101 IF(XSEC(11,1).NE.0) ISUB11=1
102 IF(XSEC(12,1).NE.0) ISUB12=1
103 IF(XSEC(28,1).NE.0) ISUB28=1
104 MINT(44)=MINT4-ISUB11-ISUB12-ISUB28
105 MINT(45)=MINT5-ISUB11-ISUB12-ISUB28
106 XSEC(0,1)=ATXS(0)-ATXS(11)-ATXS(12)-ATXS(28)
107 XSEC(11,1)=0.0
108 XSEC(12,1)=0.0
109 XSEC(28,1)=0.0
110 DO 110 I=1,20
111 COEF(11,I)=0.0
112 COEF(12,I)=0.0
113 COEF(28,I)=0.0
114110 CONTINUE
115 ENDIF
116C ********Scatter the valence quarks only once per NN
117C collision,
118C afterwards only gluon can have hard scattering.
119 155 CALL PYTHIA_HIJING
120 JJ=MINT(31)
121 IF(JJ.NE.1) GO TO 155
122C *********one hard collision at a time
123 IF(K(7,2).EQ.-K(8,2)) THEN
124 QMASS2=(P(7,4)+P(8,4))**2-(P(7,1)+P(8,1))**2
125 & -(P(7,2)+P(8,2))**2-(P(7,3)+P(8,3))**2
126 QM=ULMASS_HIJING(K(7,2))
127 IF(QMASS2.LT.(2.0*QM+HIPR1(1))**2) GO TO 155
128 ENDIF
129C ********q-qbar jets must has minimum mass HIPR1(1)
130 PXP=PP(JP,1)-P(3,1)
131 PYP=PP(JP,2)-P(3,2)
132 PZP=PP(JP,3)-P(3,3)
133 PEP=PP(JP,4)-P(3,4)
134 PXT=PT(JT,1)-P(4,1)
135 PYT=PT(JT,2)-P(4,2)
136 PZT=PT(JT,3)-P(4,3)
137 PET=PT(JT,4)-P(4,4)
138
139 IF(PEP.LE.ECUT1) THEN
140 MISP=MISP+1
141 IF(MISP.LT.50) GO TO 155
142 NFP(JP,6)=-ABS(NFP(JP,6))
143 RETURN
144 ENDIF
145 IF(PET.LE.ECUT2) THEN
146 MIST=MIST+1
147 IF(MIST.LT.50) GO TO 155
148 NFT(JT,6)=-ABS(NFT(JT,6))
149 RETURN
150 ENDIF
151C ******** if the remain energy<ECUT the proj or targ
152C can not produce jet anymore
153
154 WP=PEP+PZP+PET+PZT
155 WM=PEP-PZP+PET-PZT
156 IF(WP.LT.0.0 .OR. WM.LT.0.0) THEN
157 MISS=MISS+1
158 IF(MISS.LT.50) GO TO 155
159 RETURN
160 ENDIF
161C ********the total W+, W- must be positive
162 SW=WP*WM
163 AMPX=SQRT((ECUT1-HIPR1(8))**2+PXP**2+PYP**2+0.01)
164 AMTX=SQRT((ECUT2-HIPR1(8))**2+PXT**2+PYT**2+0.01)
165 SXX=(AMPX+AMTX)**2
166 IF(SW.LT.SXX.OR.VINT(43).LT.HIPR1(1)) THEN
167 MISS=MISS+1
168 IF(MISS.LT.50) GO TO 155
169 RETURN
170 ENDIF
171C ********the proj and targ remnants must have at least
172C a CM energy that can produce two strings
173C with minimum mass HIPR1(1)(see HIJSFT HIJFRG)
174C
175 HINT1(41)=P(7,1)
176 HINT1(42)=P(7,2)
177 HINT1(43)=P(7,3)
178 HINT1(44)=P(7,4)
179 HINT1(45)=P(7,5)
180 HINT1(46)=SQRT(P(7,1)**2+P(7,2)**2)
181 HINT1(51)=P(8,1)
182 HINT1(52)=P(8,2)
183 HINT1(53)=P(8,3)
184 HINT1(54)=P(8,4)
185 HINT1(55)=P(8,5)
186 HINT1(56)=SQRT(P(8,1)**2+P(8,2)**2)
187 IHNT2(14)=K(7,2)
188 IHNT2(15)=K(8,2)
189C
190 PINIRAD=(1.0-EXP(-2.0*(VINT(47)-HIDAT(1))))
191 & /(1.0+EXP(-2.0*(VINT(47)-HIDAT(1))))
192 I_INIRAD=0
193 IF(RLU_HIJING(0).LE.PINIRAD) I_INIRAD=1
194 IF(K(7,2).EQ.-K(8,2)) GO TO 190
195 IF(K(7,2).EQ.21.AND.K(8,2).EQ.21.AND.IOPJET.EQ.1) GO TO 190
196C*******************************************************************
197C gluon jets are going to be connectd with
198C the final leading string of quark-aintquark
199C*******************************************************************
200 JFLG=2
201 JPP=0
202 LPQ=0
203 LPB=0
204 JTT=0
205 LTQ=0
206 LTB=0
207 IS7=0
208 IS8=0
209 HINT1(47)=0.0
210 HINT1(48)=0.0
211 HINT1(49)=0.0
212 HINT1(50)=0.0
213 HINT1(67)=0.0
214 HINT1(68)=0.0
215 HINT1(69)=0.0
216 HINT1(70)=0.0
217 DO 180 I=9,N
218 IF(K(I,3).EQ.1 .OR. K(I,3).EQ.2.OR.
219 & ABS(K(I,2)).GT.30) GO TO 180
220C************************************************************
221 IF(K(I,3).EQ.7) THEN
222 HINT1(47)=HINT1(47)+P(I,1)
223 HINT1(48)=HINT1(48)+P(I,2)
224 HINT1(49)=HINT1(49)+P(I,3)
225 HINT1(50)=HINT1(50)+P(I,4)
226 ENDIF
227 IF(K(I,3).EQ.8) THEN
228 HINT1(67)=HINT1(67)+P(I,1)
229 HINT1(68)=HINT1(68)+P(I,2)
230 HINT1(69)=HINT1(69)+P(I,3)
231 HINT1(70)=HINT1(70)+P(I,4)
232 ENDIF
233C************************modifcation made on Apr 10. 1996*****
234 IF(K(I,2).GT.21.AND.K(I,2).LE.30) THEN
235 NDR=NDR+1
236 IADR(NDR,1)=JP
237 IADR(NDR,2)=JT
238 KFDR(NDR)=K(I,2)
239 PDR(NDR,1)=P(I,1)
240 PDR(NDR,2)=P(I,2)
241 PDR(NDR,3)=P(I,3)
242 PDR(NDR,4)=P(I,4)
243 PDR(NDR,5)=P(I,5)
244C************************************************************
245 GO TO 180
246C************************correction made on Oct. 14,1994*****
247 ENDIF
248 IF(K(I,3).EQ.7.OR.K(I,3).EQ.3) THEN
249 IF(K(I,3).EQ.7.AND.K(I,2).NE.21.AND.K(I,2).EQ.K(7,2)
250 & .AND.IS7.EQ.0) THEN
251 PP(JP,10)=P(I,1)
252 PP(JP,11)=P(I,2)
253 PP(JP,12)=P(I,3)
254 PZP=PZP+P(I,3)
255 PEP=PEP+P(I,4)
256 NFP(JP,10)=1
257 IS7=1
258 GO TO 180
259 ENDIF
260 IF(K(I,3).EQ.3.AND.(K(I,2).NE.21.OR.
261 & I_INIRAD.EQ.0)) THEN
262 PXP=PXP+P(I,1)
263 PYP=PYP+P(I,2)
264 PZP=PZP+P(I,3)
265 PEP=PEP+P(I,4)
266 GO TO 180
267 ENDIF
268 JPP=JPP+1
269 IP(JPP,1)=I
270 IP(JPP,2)=0
271 IF(K(I,2).NE.21) THEN
272 IF(K(I,2).GT.0) THEN
273 LPQ=LPQ+1
274 IPQ(LPQ)=JPP
275 IP(JPP,2)=LPQ
276 ELSE IF(K(I,2).LT.0) THEN
277 LPB=LPB+1
278 IPB(LPB)=JPP
279 IP(JPP,2)=-LPB
280 ENDIF
281 ENDIF
282 ELSE IF(K(I,3).EQ.8.OR.K(I,3).EQ.4) THEN
283 IF(K(I,3).EQ.8.AND.K(I,2).NE.21.AND.K(I,2).EQ.K(8,2)
284 & .AND.IS8.EQ.0) THEN
285 PT(JT,10)=P(I,1)
286 PT(JT,11)=P(I,2)
287 PT(JT,12)=P(I,3)
288 PZT=PZT+P(I,3)
289 PET=PET+P(I,4)
290 NFT(JT,10)=1
291 IS8=1
292 GO TO 180
293 ENDIF
294 IF(K(I,3).EQ.4.AND.(K(I,2).NE.21.OR.
295 & I_INIRAD.EQ.0)) THEN
296 PXT=PXT+P(I,1)
297 PYT=PYT+P(I,2)
298 PZT=PZT+P(I,3)
299 PET=PET+P(I,4)
300 GO TO 180
301 ENDIF
302 JTT=JTT+1
303 IT(JTT,1)=I
304 IT(JTT,2)=0
305 IF(K(I,2).NE.21) THEN
306 IF(K(I,2).GT.0) THEN
307 LTQ=LTQ+1
308 ITQ(LTQ)=JTT
309 IT(JTT,2)=LTQ
310 ELSE IF(K(I,2).LT.0) THEN
311 LTB=LTB+1
312 ITB(LTB)=JTT
313 IT(JTT,2)=-LTB
314 ENDIF
315 ENDIF
316 ENDIF
317 180 CONTINUE
318c
319c
320 IF(LPQ.NE.LPB .OR. LTQ.NE.LTB) THEN
321 MISS=MISS+1
322 IF(MISS.LE.50) GO TO 155
323 WRITE(6,*) ' Q -QBAR NOT MATCHED IN HIJHRD'
324 JFLG=0
325 RETURN
326 ENDIF
327C****The following will rearrange the partons so that a quark is***
328C****allways followed by an anti-quark ****************************
329
330 J=0
331181 J=J+1
332 IF(J.GT.JPP) GO TO 182
333 IF(IP(J,2).EQ.0) THEN
334 GO TO 181
335 ELSE IF(IP(J,2).NE.0) THEN
336 LP=ABS(IP(J,2))
337 IP1=IP(J,1)
338 IP2=IP(J,2)
339 IP(J,1)=IP(IPQ(LP),1)
340 IP(J,2)=IP(IPQ(LP),2)
341 IP(IPQ(LP),1)=IP1
342 IP(IPQ(LP),2)=IP2
343 IF(IP2.GT.0) THEN
344 IPQ(IP2)=IPQ(LP)
345 ELSE IF(IP2.LT.0) THEN
346 IPB(-IP2)=IPQ(LP)
347 ENDIF
348C ********replace J with a quark
349 IP1=IP(J+1,1)
350 IP2=IP(J+1,2)
351 IP(J+1,1)=IP(IPB(LP),1)
352 IP(J+1,2)=IP(IPB(LP),2)
353 IP(IPB(LP),1)=IP1
354 IP(IPB(LP),2)=IP2
355 IF(IP2.GT.0) THEN
356 IPQ(IP2)=IPB(LP)
357 ELSE IF(IP2.LT.0) THEN
358 IPB(-IP2)=IPB(LP)
359 ENDIF
360C ******** replace J+1 with anti-quark
361 J=J+1
362 GO TO 181
363 ENDIF
364
365182 J=0
366183 J=J+1
367 IF(J.GT.JTT) GO TO 184
368 IF(IT(J,2).EQ.0) THEN
369 GO TO 183
370 ELSE IF(IT(J,2).NE.0) THEN
371 LT=ABS(IT(J,2))
372 IT1=IT(J,1)
373 IT2=IT(J,2)
374 IT(J,1)=IT(ITQ(LT),1)
375 IT(J,2)=IT(ITQ(LT),2)
376 IT(ITQ(LT),1)=IT1
377 IT(ITQ(LT),2)=IT2
378 IF(IT2.GT.0) THEN
379 ITQ(IT2)=ITQ(LT)
380 ELSE IF(IT2.LT.0) THEN
381 ITB(-IT2)=ITQ(LT)
382 ENDIF
383C ********replace J with a quark
384 IT1=IT(J+1,1)
385 IT2=IT(J+1,2)
386 IT(J+1,1)=IT(ITB(LT),1)
387 IT(J+1,2)=IT(ITB(LT),2)
388 IT(ITB(LT),1)=IT1
389 IT(ITB(LT),2)=IT2
390 IF(IT2.GT.0) THEN
391 ITQ(IT2)=ITB(LT)
392 ELSE IF(IT2.LT.0) THEN
393 ITB(-IT2)=ITB(LT)
394 ENDIF
395C ******** replace J+1 with anti-quark
396 J=J+1
397 GO TO 183
398
399 ENDIF
400
401184 CONTINUE
402 IF(NPJ(JP)+JPP.GT.MXJT.OR.NTJ(JT)+JTT.GT.MXJT) THEN
403 JFLG=0
404 WRITE(6,*) 'number of partons per string exceeds'
405 WRITE(6,*) 'the common block size'
406 RETURN
407 ENDIF
408C ********check the bounds of common blocks
409 DO 186 J=1,JPP
410 KFPJ(JP,NPJ(JP)+J)=K(IP(J,1),2)
411 PJPX(JP,NPJ(JP)+J)=P(IP(J,1),1)
412 PJPY(JP,NPJ(JP)+J)=P(IP(J,1),2)
413 PJPZ(JP,NPJ(JP)+J)=P(IP(J,1),3)
414 PJPE(JP,NPJ(JP)+J)=P(IP(J,1),4)
415 PJPM(JP,NPJ(JP)+J)=P(IP(J,1),5)
416186 CONTINUE
417 NPJ(JP)=NPJ(JP)+JPP
418 DO 188 J=1,JTT
419 KFTJ(JT,NTJ(JT)+J)=K(IT(J,1),2)
420 PJTX(JT,NTJ(JT)+J)=P(IT(J,1),1)
421 PJTY(JT,NTJ(JT)+J)=P(IT(J,1),2)
422 PJTZ(JT,NTJ(JT)+J)=P(IT(J,1),3)
423 PJTE(JT,NTJ(JT)+J)=P(IT(J,1),4)
424 PJTM(JT,NTJ(JT)+J)=P(IT(J,1),5)
425188 CONTINUE
426 NTJ(JT)=NTJ(JT)+JTT
427 GO TO 900
428C*****************************************************************
429CThis is the case of a quark-antiquark jet it will fragment alone
430C****************************************************************
431190 JFLG=3
432 IF(K(7,2).NE.21.AND.K(8,2).NE.21.AND.
433 & K(7,2)*K(8,2).GT.0) GO TO 155
434 JPP=0
435 LPQ=0
436 LPB=0
437 DO 200 I=9,N
438 IF(K(I,3).EQ.1.OR.K(I,3).EQ.2.OR.
439 & ABS(K(I,2)).GT.30) GO TO 200
440 IF(K(I,2).GT.21.AND.K(I,2).LE.30) THEN
441 NDR=NDR+1
442 IADR(NDR,1)=JP
443 IADR(NDR,2)=JT
444 KFDR(NDR)=K(I,2)
445 PDR(NDR,1)=P(I,1)
446 PDR(NDR,2)=P(I,2)
447 PDR(NDR,3)=P(I,3)
448 PDR(NDR,4)=P(I,4)
449 PDR(NDR,5)=P(I,5)
450C************************************************************
451 GO TO 200
452C************************correction made on Oct. 14,1994*****
453 ENDIF
454 IF(K(I,3).EQ.3.AND.(K(I,2).NE.21.OR.
455 & I_INIRAD.EQ.0)) THEN
456 PXP=PXP+P(I,1)
457 PYP=PYP+P(I,2)
458 PZP=PZP+P(I,3)
459 PEP=PEP+P(I,4)
460 GO TO 200
461 ENDIF
462 IF(K(I,3).EQ.4.AND.(K(I,2).NE.21.OR.
463 & I_INIRAD.EQ.0)) THEN
464 PXT=PXT+P(I,1)
465 PYT=PYT+P(I,2)
466 PZT=PZT+P(I,3)
467 PET=PET+P(I,4)
468 GO TO 200
469 ENDIF
470 JPP=JPP+1
471 IP(JPP,1)=I
472 IP(JPP,2)=0
473 IF(K(I,2).NE.21) THEN
474 IF(K(I,2).GT.0) THEN
475 LPQ=LPQ+1
476 IPQ(LPQ)=JPP
477 IP(JPP,2)=LPQ
478 ELSE IF(K(I,2).LT.0) THEN
479 LPB=LPB+1
480 IPB(LPB)=JPP
481 IP(JPP,2)=-LPB
482 ENDIF
483 ENDIF
484200 CONTINUE
485 IF(LPQ.NE.LPB) THEN
486 MISS=MISS+1
487 IF(MISS.LE.50) GO TO 155
488 WRITE(6,*) LPQ,LPB, 'Q-QBAR NOT CONSERVED OR NOT MATCHED'
489 JFLG=0
490 RETURN
491 ENDIF
492
493C**** The following will rearrange the partons so that a quark is***
494C**** allways followed by an anti-quark ****************************
495 J=0
496220 J=J+1
497 IF(J.GT.JPP) GO TO 222
498 IF(IP(J,2).EQ.0) GO TO 220
499 LP=ABS(IP(J,2))
500 IP1=IP(J,1)
501 IP2=IP(J,2)
502 IP(J,1)=IP(IPQ(LP),1)
503 IP(J,2)=IP(IPQ(LP),2)
504 IP(IPQ(LP),1)=IP1
505 IP(IPQ(LP),2)=IP2
506 IF(IP2.GT.0) THEN
507 IPQ(IP2)=IPQ(LP)
508 ELSE IF(IP2.LT.0) THEN
509 IPB(-IP2)=IPQ(LP)
510 ENDIF
511 IPQ(LP)=J
512C ********replace J with a quark
513 IP1=IP(J+1,1)
514 IP2=IP(J+1,2)
515 IP(J+1,1)=IP(IPB(LP),1)
516 IP(J+1,2)=IP(IPB(LP),2)
517 IP(IPB(LP),1)=IP1
518 IP(IPB(LP),2)=IP2
519 IF(IP2.GT.0) THEN
520 IPQ(IP2)=IPB(LP)
521 ELSE IF(IP2.LT.0) THEN
522 IPB(-IP2)=IPB(LP)
523 ENDIF
524C ******** replace J+1 with an anti-quark
525 IPB(LP)=J+1
526 J=J+1
527 GO TO 220
528
529222 CONTINUE
530 IF(LPQ.GE.1) THEN
531 DO 240 L0=2,LPQ
532 IP1=IP(2*L0-3,1)
533 IP2=IP(2*L0-3,2)
534 IP(2*L0-3,1)=IP(IPQ(L0),1)
535 IP(2*L0-3,2)=IP(IPQ(L0),2)
536 IP(IPQ(L0),1)=IP1
537 IP(IPQ(L0),2)=IP2
538 IF(IP2.GT.0) THEN
539 IPQ(IP2)=IPQ(L0)
540 ELSE IF(IP2.LT.0) THEN
541 IPB(-IP2)=IPQ(L0)
542 ENDIF
543 IPQ(L0)=2*L0-3
544C
545 IP1=IP(2*L0-2,1)
546 IP2=IP(2*L0-2,2)
547 IP(2*L0-2,1)=IP(IPB(L0),1)
548 IP(2*L0-2,2)=IP(IPB(L0),2)
549 IP(IPB(L0),1)=IP1
550 IP(IPB(L0),2)=IP2
551 IF(IP2.GT.0) THEN
552 IPQ(IP2)=IPB(L0)
553 ELSE IF(IP2.LT.0) THEN
554 IPB(-IP2)=IPB(L0)
555 ENDIF
556 IPB(L0)=2*L0-2
557240 CONTINUE
558C ********move all the qqbar pair to the front of
559C the list, except the first pair
560 IP1=IP(2*LPQ-1,1)
561 IP2=IP(2*LPQ-1,2)
562 IP(2*LPQ-1,1)=IP(IPQ(1),1)
563 IP(2*LPQ-1,2)=IP(IPQ(1),2)
564 IP(IPQ(1),1)=IP1
565 IP(IPQ(1),2)=IP2
566 IF(IP2.GT.0) THEN
567 IPQ(IP2)=IPQ(1)
568 ELSE IF(IP2.LT.0) THEN
569 IPB(-IP2)=IPQ(1)
570 ENDIF
571 IPQ(1)=2*LPQ-1
572C ********move the first quark to the beginning of
573C the last string system
574 IP1=IP(JPP,1)
575 IP2=IP(JPP,2)
576 IP(JPP,1)=IP(IPB(1),1)
577 IP(JPP,2)=IP(IPB(1),2)
578 IP(IPB(1),1)=IP1
579 IP(IPB(1),2)=IP2
580 IF(IP2.GT.0) THEN
581 IPQ(IP2)=IPB(1)
582 ELSE IF(IP2.LT.0) THEN
583 IPB(-IP2)=IPB(1)
584 ENDIF
585 IPB(1)=JPP
586C ********move the first anti-quark to the end of the
587C last string system
588 ENDIF
589 IF(NSG.GE.MXSG) THEN
590 JFLG=0
591 WRITE(6,*) 'number of jets forming single strings exceeds'
592 WRITE(6,*) 'the common block size'
593 RETURN
594 ENDIF
595 IF(JPP.GT.MXSJ) THEN
596 JFLG=0
597 WRITE(6,*) 'number of partons per single jet system'
598 WRITE(6,*) 'exceeds the common block size'
599 RETURN
600 ENDIF
601C ********check the bounds of common block size
602 NSG=NSG+1
603 NJSG(NSG)=JPP
604 IASG(NSG,1)=JP
605 IASG(NSG,2)=JT
606 IASG(NSG,3)=0
607 DO 300 I=1,JPP
608 K1SG(NSG,I)=2
609 K2SG(NSG,I)=K(IP(I,1),2)
610 IF(K2SG(NSG,I).LT.0) K1SG(NSG,I)=1
611 PXSG(NSG,I)=P(IP(I,1),1)
612 PYSG(NSG,I)=P(IP(I,1),2)
613 PZSG(NSG,I)=P(IP(I,1),3)
614 PESG(NSG,I)=P(IP(I,1),4)
615 PMSG(NSG,I)=P(IP(I,1),5)
616300 CONTINUE
617 K1SG(NSG,1)=2
618 K1SG(NSG,JPP)=1
619C******* reset the energy-momentum of incoming particles ********
620900 PP(JP,1)=PXP
621 PP(JP,2)=PYP
622 PP(JP,3)=PZP
623 PP(JP,4)=PEP
624 PP(JP,5)=0.0
625 PT(JT,1)=PXT
626 PT(JT,2)=PYT
627 PT(JT,3)=PZT
628 PT(JT,4)=PET
629 PT(JT,5)=0.0
630
631 NFP(JP,6)=NFP(JP,6)+1
632 NFT(JT,6)=NFT(JT,6)+1
633 RETURN
634C
6351000 JFLG=-1
636 IF(IHPR2(10).EQ.0) RETURN
637 WRITE(6,*) 'Fatal HIJHRD error'
638 WRITE(6,*) JP, ' proj E+,E-',EPP,EPM,' status',NFP(JP,5)
639 WRITE(6,*) JT, ' targ E+,E_',ETP,ETM,' status',NFT(JT,5)
640 RETURN
641 END