HIJING/hijing1_36/hijhrd.F

   1 * $Id$
   2 C
   3 C
   4 C
   5         SUBROUTINE HIJHRD(JP,JT,JOUT,JFLG,IOPJET0)
   6 C
   7 C       IOPTJET=1, ALL JET WILL FORM SINGLE STRING SYSTEM
   8 C               0, ONLY Q-QBAR JET FORM SINGLE STRING SYSTEM
   9 C*******Perform jets production and fragmentation when JP JT *******
  10 C     scatter. JOUT-> number of hard scatterings precede this one  *
  11 C     for the the same pair(JP,JT). JFLG->a flag to show whether   *
  12 C     jets can be produced (with valence quark=1,gluon=2, q-qbar=3)*
  13 C     or not(0). Information of jets are in  COMMON/ATTJET and     *
  14 C     /MINJET. ABS(NFP(JP,6)) is the total number jets produced by *
  15 C    JP. If NFP(JP,6)<0 JP can not produce jet anymore.            *
  16 C*******************************************************************
  17         DIMENSION IP(100,2),IPQ(50),IPB(50),IT(100,2),ITQ(50),ITB(50)
  18 #define BLANKET_SAVE
  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"
  26 C************************************ 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
  36 C*********************************** LU common block
  37         MXJT=500
  38 C               SIZE OF COMMON BLOCK FOR # OF PARTON PER STRING
  39         MXSG=900
  40 C               SIZE OF COMMON BLOCK FOR # OF SINGLE STRINGS
  41         MXSJ=100
  42 C               SIZE OF COMMON BLOCK FOR # OF PARTON PER SINGLE
  43 C               STRING
  44         JFLG=0
  45         IHNT2(11)=JP
  46         IHNT2(12)=JT
  47 C
  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
  53 C               ******** JP or JT can not produce jet anymore
  54 C
  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
  66 C               ********for the first hard scattering of (JP,JT)
  67 C                       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
  79 C               *********must have enough energy to produce jets
  80
  81         MISS=0
  82         MISP=0
  83         MIST=0
  84 C
  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)
  96 120             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
 114 110             CONTINUE
 115         ENDIF
 116 C       ********Scatter the valence quarks only once per NN
 117 C       collision,
 118 C               afterwards only gluon can have hard scattering.
 119  155    CALL PYTHIA_HIJING
 120         JJ=MINT(31)
 121         IF(JJ.NE.1) GO TO 155
 122 C               *********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
 129 C               ********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
 151 C               ******** if the remain energy<ECUT the proj or targ
 152 C                        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
 161 C               ********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
 171 C               ********the proj and targ remnants must have at least
 172 C                       a CM energy that can produce two strings
 173 C                       with minimum mass HIPR1(1)(see HIJSFT HIJFRG)
 174 C
 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)
 189 C
 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
 196 C*******************************************************************
 197 C       gluon  jets are going to be connectd with
 198 C       the final leading string of quark-aintquark
 199 C*******************************************************************
 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
 220 C************************************************************
 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
 233 C************************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)
 244 C************************************************************
 245               GO TO 180
 246 C************************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
 318 c
 319 c
 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
 327 C****The following will rearrange the partons so that a quark is***
 328 C****allways followed by an anti-quark ****************************
 329
 330         J=0
 331 181     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
 348 C               ********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
 360 C               ******** replace J+1 with anti-quark
 361                 J=J+1
 362                 GO TO 181
 363         ENDIF
 364
 365 182     J=0
 366 183     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
 383 C               ********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
 395 C               ******** replace J+1 with anti-quark
 396                 J=J+1
 397                 GO TO 183
 398
 399         ENDIF
 400
 401 184     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
 408 C                       ********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)
 416 186     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)
 425 188     CONTINUE
 426         NTJ(JT)=NTJ(JT)+JTT
 427         GO TO 900
 428 C*****************************************************************
 429 CThis is the case of a quark-antiquark jet it will fragment alone
 430 C****************************************************************
 431 190     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)
 450 C************************************************************
 451                         GO TO 200
 452 C************************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
 484 200     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
 493 C**** The following will rearrange the partons so that a quark is***
 494 C**** allways followed by an anti-quark ****************************
 495         J=0
 496 220     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
 512 C               ********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
 524 C               ******** replace J+1 with an anti-quark
 525                 IPB(LP)=J+1
 526                 J=J+1
 527                 GO TO 220
 528
 529 222     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
 544 C
 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
 557 240             CONTINUE
 558 C               ********move all the qqbar pair to the front of
 559 C                               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
 572 C               ********move the first quark to the beginning of
 573 C                               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
 586 C               ********move the first anti-quark to the end of the
 587 C                       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
 601 C               ********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)
 616 300     CONTINUE
 617         K1SG(NSG,1)=2
 618         K1SG(NSG,JPP)=1
 619 C******* reset the energy-momentum of incoming particles ********
 620 900     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
 634 C
 635 1000    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