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