hijing/src/hijhrd.f

0001 C
0002 C
0003 C
0004         SUBROUTINE HIJHRD(JP,JT,JOUT,JFLG,IOPJET0)
0005 C
0006 C       IOPTJET=1, ALL JET WILL FORM SINGLE STRING SYSTEM
0007 C               0, ONLY Q-QBAR JET FORM SINGLE STRING SYSTEM
0008 C*******Perform jets production and fragmentation when JP JT *******
0009 C     scatter. JOUT-> number of hard scatterings precede this one  *
0010 C     for the the same pair(JP,JT). JFLG->a flag to show whether   *
0011 C     jets can be produced (with valence quark=1,gluon=2, q-qbar=3)*
0012 C     or not(0). Information of jets are in  COMMON/ATTJET and     *
0013 C     /MINJET. ABS(NFP(JP,6)) is the total number jets produced by *
0014 C    JP. If NFP(JP,6)<0 JP can not produce jet anymore.            *
0015 C*******************************************************************
0016         DIMENSION IP(100,2),IPQ(50),IPB(50),IT(100,2),ITQ(50),ITB(50)
0017         COMMON/HIJCRDN/YP(3,300),YT(3,300)
0018         SAVE  /HIJCRDN/
0019         COMMON/HIPARNT/HIPR1(100),IHPR2(50),HINT1(100),IHNT2(50)
0020         SAVE  /HIPARNT/
0021         COMMON/HIJDAT/HIDAT0(10,10),HIDAT(10)
0022         SAVE  /HIJDAT/
0023         COMMON/HISTRNG/NFP(300,15),PP(300,15),NFT(300,15),PT(300,15)
0024         SAVE  /HISTRNG/
0025         COMMON/HIJJET1/NPJ(300),KFPJ(300,500),PJPX(300,500),
0026      &                PJPY(300,500),PJPZ(300,500),PJPE(300,500),
0027      &                PJPM(300,500),NTJ(300),KFTJ(300,500),
0028      &                PJTX(300,500),PJTY(300,500),PJTZ(300,500),
0029      &                PJTE(300,500),PJTM(300,500)
0030         SAVE  /HIJJET1/
0031         COMMON/HIJJET2/NSG,NJSG(900),IASG(900,3),K1SG(900,100),
0032      &          K2SG(900,100),PXSG(900,100),PYSG(900,100),
0033      &          PZSG(900,100),PESG(900,100),PMSG(900,100)
0034         SAVE  /HIJJET2/
0035
0036 C+++BAC
0037 C
0038 C       COMMON/HIJJET4/NDR,IADR(900,2),KFDR(900),PDR(900,5)
0039 C       SAVE  /HIJJET4/
0040 C
0041         COMMON/HIJJET4/NDR,IADR(900,2),KFDR(900),PDR(900,5), VDR(900,5)
0042         SAVE  /HIJJET4/
0043
0044 C---BAC
0045
0046         COMMON/RANSEED/NSEED
0047         SAVE  /RANSEED/
0048 C************************************ HIJING common block
0049         COMMON/LUJETS/N,K(9000,5),P(9000,5),V(9000,5)
0050         SAVE  /LUJETS/
0051         COMMON/LUDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
0052         SAVE  /LUDAT1/
0053         COMMON/PYHISUBS/MSEL,MSUB(200),KFIN(2,-40:40),CKIN(200)
0054         SAVE  /PYHISUBS/
0055         COMMON/PYHIPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
0056         SAVE  /PYHIPARS/
0057         COMMON/PYHIINT1/MINT(400),VINT(400)
0058         SAVE  /PYHIINT1/
0059         COMMON/PYHIINT2/ISET(200),KFPR(200,2),COEF(200,20),ICOL(40,4,2)
0060         SAVE  /PYHIINT2/
0061         COMMON/PYHIINT5/NGEN(0:200,3),XSEC(0:200,3)
0062         SAVE  /PYHIINT5/
0063         COMMON/HIPYINT/MINT4,MINT5,ATCO(200,20),ATXS(0:200)
0064         SAVE  /HIPYINT/
0065 C*********************************** LU common block
0066         MXJT=500
0067 C               SIZE OF COMMON BLOCK FOR # OF PARTON PER STRING
0068         MXSG=900
0069 C               SIZE OF COMMON BLOCK FOR # OF SINGLE STRINGS
0070         MXSJ=100
0071 C               SIZE OF COMMON BLOCK FOR # OF PARTON PER SINGLE
0072 C               STRING
0073         JFLG=0
0074         IHNT2(11)=JP
0075         IHNT2(12)=JT
0076 C
0077         IOPJET=IOPJET0
0078         IF(IOPJET.EQ.1.AND.(NFP(JP,6).NE.0.OR.NFT(JT,6).NE.0))
0079      &                   IOPJET=0
0080         IF(JP.GT.IHNT2(1) .OR. JT.GT.IHNT2(3)) RETURN
0081         IF(NFP(JP,6).LT.0 .OR. NFT(JT,6).LT.0) RETURN
0082 C               ******** JP or JT can not produce jet anymore
0083 C
0084         IF(JOUT.EQ.0) THEN
0085                 EPP=PP(JP,4)+PP(JP,3)
0086                 EPM=PP(JP,4)-PP(JP,3)
0087                 ETP=PT(JT,4)+PT(JT,3)
0088                 ETM=PT(JT,4)-PT(JT,3)
0089                 IF(EPP.LT.0.0) GO TO 1000
0090                 IF(EPM.LT.0.0) GO TO 1000
0091                 IF(ETP.LT.0.0) GO TO 1000
0092                 IF(ETM.LT.0.0) GO TO 1000
0093                 IF(EPP/(EPM+0.01).LE.ETP/(ETM+0.01)) RETURN
0094         ENDIF
0095 C               ********for the first hard scattering of (JP,JT)
0096 C                       have collision only when Ycm(JP)>Ycm(JT)
0097
0098         ECUT1=HIPR1(1)+HIPR1(8)+PP(JP,14)+PP(JP,15)
0099         ECUT2=HIPR1(1)+HIPR1(8)+PT(JT,14)+PT(JT,15)
0100         IF(PP(JP,4).LE.ECUT1) THEN
0101                 NFP(JP,6)=-ABS(NFP(JP,6))
0102                 RETURN
0103         ENDIF
0104         IF(PT(JT,4).LE.ECUT2) THEN
0105                 NFT(JT,6)=-ABS(NFT(JT,6))
0106                 RETURN
0107         ENDIF
0108 C               *********must have enough energy to produce jets
0109
0110         MISS=0
0111         MISP=0
0112         MIST=0
0113 C
0114         IF(NFP(JP,10).EQ.0 .AND. NFT(JT,10).EQ.0) THEN
0115                 MINT(44)=MINT4
0116                 MINT(45)=MINT5
0117                 XSEC(0,1)=ATXS(0)
0118                 XSEC(11,1)=ATXS(11)
0119                 XSEC(12,1)=ATXS(12)
0120                 XSEC(28,1)=ATXS(28)
0121                 DO 120 I=1,20
0122                 COEF(11,I)=ATCO(11,I)
0123                 COEF(12,I)=ATCO(12,I)
0124                 COEF(28,I)=ATCO(28,I)
0125 120             CONTINUE
0126         ELSE
0127                 ISUB11=0
0128                 ISUB12=0
0129                 ISUB28=0
0130                 IF(XSEC(11,1).NE.0) ISUB11=1
0131                 IF(XSEC(12,1).NE.0) ISUB12=1
0132                 IF(XSEC(28,1).NE.0) ISUB28=1
0133                 MINT(44)=MINT4-ISUB11-ISUB12-ISUB28
0134                 MINT(45)=MINT5-ISUB11-ISUB12-ISUB28
0135                 XSEC(0,1)=ATXS(0)-ATXS(11)-ATXS(12)-ATXS(28)
0136                 XSEC(11,1)=0.0
0137                 XSEC(12,1)=0.0
0138                 XSEC(28,1)=0.0
0139                 DO 110 I=1,20
0140                 COEF(11,I)=0.0
0141                 COEF(12,I)=0.0
0142                 COEF(28,I)=0.0
0143 110             CONTINUE
0144         ENDIF
0145 C       ********Scatter the valence quarks only once per NN
0146 C       collision,
0147 C               afterwards only gluon can have hard scattering.
0148  155    CALL PYHITHIA
0149         JJ=MINT(31)
0150         IF(JJ.NE.1) GO TO 155
0151 C               *********one hard collision at a time
0152         IF(K(7,2).EQ.-K(8,2)) THEN
0153                 QMASS2=(P(7,4)+P(8,4))**2-(P(7,1)+P(8,1))**2
0154      &                  -(P(7,2)+P(8,2))**2-(P(7,3)+P(8,3))**2
0155                 QM=ULMASS(K(7,2))
0156                 IF(QMASS2.LT.(2.0*QM+HIPR1(1))**2) GO TO 155
0157         ENDIF
0158 C               ********q-qbar jets must has minimum mass HIPR1(1)
0159         PXP=PP(JP,1)-P(3,1)
0160         PYP=PP(JP,2)-P(3,2)
0161         PZP=PP(JP,3)-P(3,3)
0162         PEP=PP(JP,4)-P(3,4)
0163         PXT=PT(JT,1)-P(4,1)
0164         PYT=PT(JT,2)-P(4,2)
0165         PZT=PT(JT,3)-P(4,3)
0166         PET=PT(JT,4)-P(4,4)
0167
0168         IF(PEP.LE.ECUT1) THEN
0169                 MISP=MISP+1
0170                 IF(MISP.LT.50) GO TO 155
0171                 NFP(JP,6)=-ABS(NFP(JP,6))
0172                 RETURN
0173         ENDIF
0174         IF(PET.LE.ECUT2) THEN
0175                 MIST=MIST+1
0176                 IF(MIST.LT.50) GO TO 155
0177                 NFT(JT,6)=-ABS(NFT(JT,6))
0178                 RETURN
0179         ENDIF
0180 C               ******** if the remain energy<ECUT the proj or targ
0181 C                        can not produce jet anymore
0182
0183         WP=PEP+PZP+PET+PZT
0184         WM=PEP-PZP+PET-PZT
0185         IF(WP.LT.0.0 .OR. WM.LT.0.0) THEN
0186                 MISS=MISS+1
0187                 IF(MISS.LT.50) GO TO 155
0188                 RETURN
0189         ENDIF
0190 C               ********the total W+, W- must be positive
0191         SW=WP*WM
0192         AMPX=SQRT((ECUT1-HIPR1(8))**2+PXP**2+PYP**2+0.01)
0193         AMTX=SQRT((ECUT2-HIPR1(8))**2+PXT**2+PYT**2+0.01)
0194         SXX=(AMPX+AMTX)**2
0195         IF(SW.LT.SXX.OR.VINT(43).LT.HIPR1(1)) THEN
0196                 MISS=MISS+1
0197                 IF(MISS.LT.50) GO TO 155
0198                 RETURN
0199         ENDIF
0200 C               ********the proj and targ remnants must have at least
0201 C                       a CM energy that can produce two strings
0202 C                       with minimum mass HIPR1(1)(see HIJSFT HIJFRG)
0203 C
0204         HINT1(41)=P(7,1)
0205         HINT1(42)=P(7,2)
0206         HINT1(43)=P(7,3)
0207         HINT1(44)=P(7,4)
0208         HINT1(45)=P(7,5)
0209         HINT1(46)=SQRT(P(7,1)**2+P(7,2)**2)
0210         HINT1(51)=P(8,1)
0211         HINT1(52)=P(8,2)
0212         HINT1(53)=P(8,3)
0213         HINT1(54)=P(8,4)
0214         HINT1(55)=P(8,5)
0215         HINT1(56)=SQRT(P(8,1)**2+P(8,2)**2)
0216         IHNT2(14)=K(7,2)
0217         IHNT2(15)=K(8,2)
0218 C
0219         PINIRAD=(1.0-EXP(-2.0*(VINT(47)-HIDAT(1))))
0220      &          /(1.0+EXP(-2.0*(VINT(47)-HIDAT(1))))
0221         I_INIRAD=0
0222         IF(ATL_RAN(NSEED).LE.PINIRAD) I_INIRAD=1
0223         IF(K(7,2).EQ.-K(8,2)) GO TO 190
0224         IF(K(7,2).EQ.21.AND.K(8,2).EQ.21.AND.IOPJET.EQ.1) GO TO 190
0225 C*******************************************************************
0226 C       gluon  jets are going to be connectd with
0227 C       the final leading string of quark-aintquark
0228 C*******************************************************************
0229         JFLG=2
0230         JPP=0
0231         LPQ=0
0232         LPB=0
0233         JTT=0
0234         LTQ=0
0235         LTB=0
0236         IS7=0
0237         IS8=0
0238         HINT1(47)=0.0
0239         HINT1(48)=0.0
0240         HINT1(49)=0.0
0241         HINT1(50)=0.0
0242         HINT1(67)=0.0
0243         HINT1(68)=0.0
0244         HINT1(69)=0.0
0245         HINT1(70)=0.0
0246         DO 180 I=9,N
0247            IF(K(I,3).EQ.1 .OR. K(I,3).EQ.2.OR.
0248      &                   ABS(K(I,2)).GT.30) GO TO 180
0249 C************************************************************
0250            IF(K(I,3).EQ.7) THEN
0251               HINT1(47)=HINT1(47)+P(I,1)
0252               HINT1(48)=HINT1(48)+P(I,2)
0253               HINT1(49)=HINT1(49)+P(I,3)
0254               HINT1(50)=HINT1(50)+P(I,4)
0255            ENDIF
0256            IF(K(I,3).EQ.8) THEN
0257               HINT1(67)=HINT1(67)+P(I,1)
0258               HINT1(68)=HINT1(68)+P(I,2)
0259               HINT1(69)=HINT1(69)+P(I,3)
0260               HINT1(70)=HINT1(70)+P(I,4)
0261            ENDIF
0262 C************************modifcation made on Apr 10. 1996*****
0263            IF(K(I,2).GT.21.AND.K(I,2).LE.30) THEN
0264               NDR=NDR+1
0265               IADR(NDR,1)=JP
0266               IADR(NDR,2)=JT
0267               KFDR(NDR)=K(I,2)
0268               PDR(NDR,1)=P(I,1)
0269               PDR(NDR,2)=P(I,2)
0270               PDR(NDR,3)=P(I,3)
0271               PDR(NDR,4)=P(I,4)
0272               PDR(NDR,5)=P(I,5)
0273
0274               VDR(NDR,1)=V(I,1)
0275               VDR(NDR,2)=V(I,2)
0276               VDR(NDR,3)=V(I,3)
0277               VDR(NDR,4)=V(I,4)
0278
0279 C************************************************************
0280               GO TO 180
0281 C************************correction made on Oct. 14,1994*****
0282            ENDIF
0283            IF(K(I,3).EQ.7.OR.K(I,3).EQ.3) THEN
0284               IF(K(I,3).EQ.7.AND.K(I,2).NE.21.AND.K(I,2).EQ.K(7,2)
0285      &               .AND.IS7.EQ.0) THEN
0286                  PP(JP,10)=P(I,1)
0287                  PP(JP,11)=P(I,2)
0288                  PP(JP,12)=P(I,3)
0289                  PZP=PZP+P(I,3)
0290                  PEP=PEP+P(I,4)
0291                  NFP(JP,10)=1
0292                  IS7=1
0293                  GO TO 180
0294               ENDIF
0295               IF(K(I,3).EQ.3.AND.(K(I,2).NE.21.OR.
0296      &                               I_INIRAD.EQ.0)) THEN
0297                  PXP=PXP+P(I,1)
0298                  PYP=PYP+P(I,2)
0299                  PZP=PZP+P(I,3)
0300                  PEP=PEP+P(I,4)
0301                  GO TO 180
0302               ENDIF
0303               JPP=JPP+1
0304               IP(JPP,1)=I
0305               IP(JPP,2)=0
0306               IF(K(I,2).NE.21) THEN
0307                  IF(K(I,2).GT.0) THEN
0308                     LPQ=LPQ+1
0309                     IPQ(LPQ)=JPP
0310                     IP(JPP,2)=LPQ
0311                  ELSE IF(K(I,2).LT.0) THEN
0312                     LPB=LPB+1
0313                     IPB(LPB)=JPP
0314                     IP(JPP,2)=-LPB
0315                  ENDIF
0316               ENDIF
0317            ELSE IF(K(I,3).EQ.8.OR.K(I,3).EQ.4) THEN
0318               IF(K(I,3).EQ.8.AND.K(I,2).NE.21.AND.K(I,2).EQ.K(8,2)
0319      &                          .AND.IS8.EQ.0) THEN
0320                  PT(JT,10)=P(I,1)
0321                  PT(JT,11)=P(I,2)
0322                  PT(JT,12)=P(I,3)
0323                  PZT=PZT+P(I,3)
0324                  PET=PET+P(I,4)
0325                  NFT(JT,10)=1
0326                  IS8=1
0327                  GO TO 180
0328               ENDIF
0329               IF(K(I,3).EQ.4.AND.(K(I,2).NE.21.OR.
0330      &                             I_INIRAD.EQ.0)) THEN
0331                  PXT=PXT+P(I,1)
0332                  PYT=PYT+P(I,2)
0333                  PZT=PZT+P(I,3)
0334                  PET=PET+P(I,4)
0335                  GO TO 180
0336               ENDIF
0337               JTT=JTT+1
0338               IT(JTT,1)=I
0339               IT(JTT,2)=0
0340               IF(K(I,2).NE.21) THEN
0341                  IF(K(I,2).GT.0) THEN
0342                     LTQ=LTQ+1
0343                     ITQ(LTQ)=JTT
0344                     IT(JTT,2)=LTQ
0345                  ELSE IF(K(I,2).LT.0) THEN
0346                     LTB=LTB+1
0347                     ITB(LTB)=JTT
0348                     IT(JTT,2)=-LTB
0349                  ENDIF
0350               ENDIF
0351            ENDIF
0352  180    CONTINUE
0353 c
0354 c
0355         IF(LPQ.NE.LPB .OR. LTQ.NE.LTB) THEN
0356                 MISS=MISS+1
0357                 IF(MISS.LE.50) GO TO 155
0358                 WRITE(6,*) ' Q -QBAR NOT MATCHED IN HIJHRD'
0359                 JFLG=0
0360                 RETURN
0361         ENDIF
0362 C****The following will rearrange the partons so that a quark is***
0363 C****allways followed by an anti-quark ****************************
0364
0365         J=0
0366 181     J=J+1
0367         IF(J.GT.JPP) GO TO 182
0368         IF(IP(J,2).EQ.0) THEN
0369                 GO TO 181
0370         ELSE IF(IP(J,2).NE.0) THEN
0371                 LP=ABS(IP(J,2))
0372                 IP1=IP(J,1)
0373                 IP2=IP(J,2)
0374                 IP(J,1)=IP(IPQ(LP),1)
0375                 IP(J,2)=IP(IPQ(LP),2)
0376                 IP(IPQ(LP),1)=IP1
0377                 IP(IPQ(LP),2)=IP2
0378                 IF(IP2.GT.0) THEN
0379                         IPQ(IP2)=IPQ(LP)
0380                 ELSE IF(IP2.LT.0) THEN
0381                         IPB(-IP2)=IPQ(LP)
0382                 ENDIF
0383 C               ********replace J with a quark
0384                 IP1=IP(J+1,1)
0385                 IP2=IP(J+1,2)
0386                 IP(J+1,1)=IP(IPB(LP),1)
0387                 IP(J+1,2)=IP(IPB(LP),2)
0388                 IP(IPB(LP),1)=IP1
0389                 IP(IPB(LP),2)=IP2
0390                 IF(IP2.GT.0) THEN
0391                         IPQ(IP2)=IPB(LP)
0392                 ELSE IF(IP2.LT.0) THEN
0393                         IPB(-IP2)=IPB(LP)
0394                 ENDIF
0395 C               ******** replace J+1 with anti-quark
0396                 J=J+1
0397                 GO TO 181
0398         ENDIF
0399
0400 182     J=0
0401 183     J=J+1
0402         IF(J.GT.JTT) GO TO 184
0403         IF(IT(J,2).EQ.0) THEN
0404                 GO TO 183
0405         ELSE IF(IT(J,2).NE.0) THEN
0406                 LT=ABS(IT(J,2))
0407                 IT1=IT(J,1)
0408                 IT2=IT(J,2)
0409                 IT(J,1)=IT(ITQ(LT),1)
0410                 IT(J,2)=IT(ITQ(LT),2)
0411                 IT(ITQ(LT),1)=IT1
0412                 IT(ITQ(LT),2)=IT2
0413                 IF(IT2.GT.0) THEN
0414                         ITQ(IT2)=ITQ(LT)
0415                 ELSE IF(IT2.LT.0) THEN
0416                         ITB(-IT2)=ITQ(LT)
0417                 ENDIF
0418 C               ********replace J with a quark
0419                 IT1=IT(J+1,1)
0420                 IT2=IT(J+1,2)
0421                 IT(J+1,1)=IT(ITB(LT),1)
0422                 IT(J+1,2)=IT(ITB(LT),2)
0423                 IT(ITB(LT),1)=IT1
0424                 IT(ITB(LT),2)=IT2
0425                 IF(IT2.GT.0) THEN
0426                         ITQ(IT2)=ITB(LT)
0427                 ELSE IF(IT2.LT.0) THEN
0428                         ITB(-IT2)=ITB(LT)
0429                 ENDIF
0430 C               ******** replace J+1 with anti-quark
0431                 J=J+1
0432                 GO TO 183
0433
0434         ENDIF
0435
0436 184     CONTINUE
0437         IF(NPJ(JP)+JPP.GT.MXJT.OR.NTJ(JT)+JTT.GT.MXJT) THEN
0438                 JFLG=0
0439                 WRITE(6,*) 'number of partons per string exceeds'
0440                 WRITE(6,*) 'the common block size'
0441                 RETURN
0442         ENDIF
0443 C                       ********check the bounds of common blocks
0444         DO 186 J=1,JPP
0445                 KFPJ(JP,NPJ(JP)+J)=K(IP(J,1),2)
0446                 PJPX(JP,NPJ(JP)+J)=P(IP(J,1),1)
0447                 PJPY(JP,NPJ(JP)+J)=P(IP(J,1),2)
0448                 PJPZ(JP,NPJ(JP)+J)=P(IP(J,1),3)
0449                 PJPE(JP,NPJ(JP)+J)=P(IP(J,1),4)
0450                 PJPM(JP,NPJ(JP)+J)=P(IP(J,1),5)
0451 186     CONTINUE
0452         NPJ(JP)=NPJ(JP)+JPP
0453         DO 188 J=1,JTT
0454                 KFTJ(JT,NTJ(JT)+J)=K(IT(J,1),2)
0455                 PJTX(JT,NTJ(JT)+J)=P(IT(J,1),1)
0456                 PJTY(JT,NTJ(JT)+J)=P(IT(J,1),2)
0457                 PJTZ(JT,NTJ(JT)+J)=P(IT(J,1),3)
0458                 PJTE(JT,NTJ(JT)+J)=P(IT(J,1),4)
0459                 PJTM(JT,NTJ(JT)+J)=P(IT(J,1),5)
0460 188     CONTINUE
0461         NTJ(JT)=NTJ(JT)+JTT
0462         GO TO 900
0463 C*****************************************************************
0464 CThis is the case of a quark-antiquark jet it will fragment alone
0465 C****************************************************************
0466 190     JFLG=3
0467         IF(K(7,2).NE.21.AND.K(8,2).NE.21.AND.
0468      &                   K(7,2)*K(8,2).GT.0) GO TO 155
0469         JPP=0
0470         LPQ=0
0471         LPB=0
0472         DO 200 I=9,N
0473            IF(K(I,3).EQ.1.OR.K(I,3).EQ.2.OR.
0474      &                  ABS(K(I,2)).GT.30) GO TO 200
0475                 IF(K(I,2).GT.21.AND.K(I,2).LE.30) THEN
0476                         NDR=NDR+1
0477                         IADR(NDR,1)=JP
0478                         IADR(NDR,2)=JT
0479                         KFDR(NDR)=K(I,2)
0480                         PDR(NDR,1)=P(I,1)
0481                         PDR(NDR,2)=P(I,2)
0482                         PDR(NDR,3)=P(I,3)
0483                         PDR(NDR,4)=P(I,4)
0484                         PDR(NDR,5)=P(I,5)
0485
0486                         VDR(NDR,1)=V(I,1)
0487                         VDR(NDR,2)=V(I,2)
0488                         VDR(NDR,3)=V(I,3)
0489                         VDR(NDR,4)=V(I,4)
0490
0491 C************************************************************
0492                         GO TO 200
0493 C************************correction made on Oct. 14,1994*****
0494                 ENDIF
0495                 IF(K(I,3).EQ.3.AND.(K(I,2).NE.21.OR.
0496      &                              I_INIRAD.EQ.0)) THEN
0497                         PXP=PXP+P(I,1)
0498                         PYP=PYP+P(I,2)
0499                         PZP=PZP+P(I,3)
0500                         PEP=PEP+P(I,4)
0501                         GO TO 200
0502                 ENDIF
0503                 IF(K(I,3).EQ.4.AND.(K(I,2).NE.21.OR.
0504      &                                I_INIRAD.EQ.0)) THEN
0505                         PXT=PXT+P(I,1)
0506                         PYT=PYT+P(I,2)
0507                         PZT=PZT+P(I,3)
0508                         PET=PET+P(I,4)
0509                         GO TO 200
0510                 ENDIF
0511                 JPP=JPP+1
0512                 IP(JPP,1)=I
0513                 IP(JPP,2)=0
0514                 IF(K(I,2).NE.21) THEN
0515                         IF(K(I,2).GT.0) THEN
0516                                 LPQ=LPQ+1
0517                                 IPQ(LPQ)=JPP
0518                                 IP(JPP,2)=LPQ
0519                         ELSE IF(K(I,2).LT.0) THEN
0520                                 LPB=LPB+1
0521                                 IPB(LPB)=JPP
0522                                 IP(JPP,2)=-LPB
0523                         ENDIF
0524                 ENDIF
0525 200     CONTINUE
0526         IF(LPQ.NE.LPB) THEN
0527            MISS=MISS+1
0528            IF(MISS.LE.50) GO TO 155
0529            WRITE(6,*) LPQ,LPB, 'Q-QBAR NOT CONSERVED OR NOT MATCHED'
0530            JFLG=0
0531            RETURN
0532         ENDIF
0533
0534 C**** The following will rearrange the partons so that a quark is***
0535 C**** allways followed by an anti-quark ****************************
0536         J=0
0537 220     J=J+1
0538         IF(J.GT.JPP) GO TO 222
0539         IF(IP(J,2).EQ.0) GO TO 220
0540                 LP=ABS(IP(J,2))
0541                 IP1=IP(J,1)
0542                 IP2=IP(J,2)
0543                 IP(J,1)=IP(IPQ(LP),1)
0544                 IP(J,2)=IP(IPQ(LP),2)
0545                 IP(IPQ(LP),1)=IP1
0546                 IP(IPQ(LP),2)=IP2
0547                 IF(IP2.GT.0) THEN
0548                         IPQ(IP2)=IPQ(LP)
0549                 ELSE IF(IP2.LT.0) THEN
0550                         IPB(-IP2)=IPQ(LP)
0551                 ENDIF
0552                 IPQ(LP)=J
0553 C               ********replace J with a quark
0554                 IP1=IP(J+1,1)
0555                 IP2=IP(J+1,2)
0556                 IP(J+1,1)=IP(IPB(LP),1)
0557                 IP(J+1,2)=IP(IPB(LP),2)
0558                 IP(IPB(LP),1)=IP1
0559                 IP(IPB(LP),2)=IP2
0560                 IF(IP2.GT.0) THEN
0561                         IPQ(IP2)=IPB(LP)
0562                 ELSE IF(IP2.LT.0) THEN
0563                         IPB(-IP2)=IPB(LP)
0564                 ENDIF
0565 C               ******** replace J+1 with an anti-quark
0566                 IPB(LP)=J+1
0567                 J=J+1
0568                 GO TO 220
0569
0570 222     CONTINUE
0571         IF(LPQ.GE.1) THEN
0572                 DO 240 L0=2,LPQ
0573                         IP1=IP(2*L0-3,1)
0574                         IP2=IP(2*L0-3,2)
0575                         IP(2*L0-3,1)=IP(IPQ(L0),1)
0576                         IP(2*L0-3,2)=IP(IPQ(L0),2)
0577                         IP(IPQ(L0),1)=IP1
0578                         IP(IPQ(L0),2)=IP2
0579                         IF(IP2.GT.0) THEN
0580                                 IPQ(IP2)=IPQ(L0)
0581                         ELSE IF(IP2.LT.0) THEN
0582                                 IPB(-IP2)=IPQ(L0)
0583                         ENDIF
0584                         IPQ(L0)=2*L0-3
0585 C
0586                         IP1=IP(2*L0-2,1)
0587                         IP2=IP(2*L0-2,2)
0588                         IP(2*L0-2,1)=IP(IPB(L0),1)
0589                         IP(2*L0-2,2)=IP(IPB(L0),2)
0590                         IP(IPB(L0),1)=IP1
0591                         IP(IPB(L0),2)=IP2
0592                         IF(IP2.GT.0) THEN
0593                                 IPQ(IP2)=IPB(L0)
0594                         ELSE IF(IP2.LT.0) THEN
0595                                 IPB(-IP2)=IPB(L0)
0596                         ENDIF
0597                         IPB(L0)=2*L0-2
0598 240             CONTINUE
0599 C               ********move all the qqbar pair to the front of
0600 C                               the list, except the first pair
0601                 IP1=IP(2*LPQ-1,1)
0602                 IP2=IP(2*LPQ-1,2)
0603                 IP(2*LPQ-1,1)=IP(IPQ(1),1)
0604                 IP(2*LPQ-1,2)=IP(IPQ(1),2)
0605                 IP(IPQ(1),1)=IP1
0606                 IP(IPQ(1),2)=IP2
0607                 IF(IP2.GT.0) THEN
0608                         IPQ(IP2)=IPQ(1)
0609                 ELSE IF(IP2.LT.0) THEN
0610                         IPB(-IP2)=IPQ(1)
0611                 ENDIF
0612                 IPQ(1)=2*LPQ-1
0613 C               ********move the first quark to the beginning of
0614 C                               the last string system
0615                 IP1=IP(JPP,1)
0616                 IP2=IP(JPP,2)
0617                 IP(JPP,1)=IP(IPB(1),1)
0618                 IP(JPP,2)=IP(IPB(1),2)
0619                 IP(IPB(1),1)=IP1
0620                 IP(IPB(1),2)=IP2
0621                 IF(IP2.GT.0) THEN
0622                         IPQ(IP2)=IPB(1)
0623                 ELSE IF(IP2.LT.0) THEN
0624                         IPB(-IP2)=IPB(1)
0625                 ENDIF
0626                 IPB(1)=JPP
0627 C               ********move the first anti-quark to the end of the
0628 C                       last string system
0629         ENDIF
0630         IF(NSG.GE.MXSG) THEN
0631            JFLG=0
0632            WRITE(6,*) 'number of jets forming single strings exceeds'
0633            WRITE(6,*) 'the common block size'
0634            RETURN
0635         ENDIF
0636         IF(JPP.GT.MXSJ) THEN
0637            JFLG=0
0638            WRITE(6,*) 'number of partons per single jet system'
0639            WRITE(6,*) 'exceeds the common block size'
0640            RETURN
0641         ENDIF
0642 C               ********check the bounds of common block size
0643         NSG=NSG+1
0644         NJSG(NSG)=JPP
0645         IASG(NSG,1)=JP
0646         IASG(NSG,2)=JT
0647         IASG(NSG,3)=0
0648         DO 300 I=1,JPP
0649                 K1SG(NSG,I)=2
0650                 K2SG(NSG,I)=K(IP(I,1),2)
0651                 IF(K2SG(NSG,I).LT.0) K1SG(NSG,I)=1
0652                 PXSG(NSG,I)=P(IP(I,1),1)
0653                 PYSG(NSG,I)=P(IP(I,1),2)
0654                 PZSG(NSG,I)=P(IP(I,1),3)
0655                 PESG(NSG,I)=P(IP(I,1),4)
0656                 PMSG(NSG,I)=P(IP(I,1),5)
0657 300     CONTINUE
0658         K1SG(NSG,1)=2
0659         K1SG(NSG,JPP)=1
0660 C******* reset the energy-momentum of incoming particles ********
0661 900     PP(JP,1)=PXP
0662         PP(JP,2)=PYP
0663         PP(JP,3)=PZP
0664         PP(JP,4)=PEP
0665         PP(JP,5)=0.0
0666         PT(JT,1)=PXT
0667         PT(JT,2)=PYT
0668         PT(JT,3)=PZT
0669         PT(JT,4)=PET
0670         PT(JT,5)=0.0
0671
0672         NFP(JP,6)=NFP(JP,6)+1
0673         NFT(JT,6)=NFT(JT,6)+1
0674         RETURN
0675 C
0676 1000    JFLG=-1
0677         IF(IHPR2(10).EQ.0) RETURN
0678         WRITE(6,*) 'Fatal HIJHRD error'
0679         WRITE(6,*) JP, ' proj E+,E-',EPP,EPM,' status',NFP(JP,5)
0680         WRITE(6,*) JT, ' targ E+,E_',ETP,ETM,' status',NFT(JT,5)
0681         RETURN
0682         END