hijhrd.f

Go to the documentation of this file. Or view the newest version in sPHENIX GitHub for file hijhrd.f

C
C
C
  SUBROUTINE hijhrd(JP,JT,JOUT,JFLG,IOPJET0)
C
C IOPTJET=1, ALL JET WILL FORM SINGLE STRING SYSTEM
C   0, ONLY Q-QBAR JET FORM SINGLE STRING SYSTEM
C*******Perform jets production and fragmentation when JP JT *******
C     scatter. JOUT-> number of hard scatterings precede this one  *
C     for the the same pair(JP,JT). JFLG->a flag to show whether   *
C     jets can be produced (with valence quark=1,gluon=2, q-qbar=3)*
C     or not(0). Information of jets are in  COMMON/ATTJET and     *
C     /MINJET. ABS(NFP(JP,6)) is the total number jets produced by *
C    JP. If NFP(JP,6)<0 JP can not produce jet anymore.            *
C*******************************************************************
  dimension ip(100,2),ipq(50),ipb(50),it(100,2),itq(50),itb(50)
  common/hijcrdn/yp(3,300),yt(3,300)
  SAVE  /hijcrdn/
  common/hiparnt/hipr1(100),ihpr2(50),hint1(100),ihnt2(50)
  SAVE  /hiparnt/
        common/hijdat/hidat0(10,10),hidat(10)
  SAVE  /hijdat/
  common/histrng/nfp(300,15),pp(300,15),nft(300,15),pt(300,15)
  SAVE  /histrng/
  common/hijjet1/npj(300),kfpj(300,500),pjpx(300,500),
     &                pjpy(300,500),pjpz(300,500),pjpe(300,500),
     &                pjpm(300,500),ntj(300),kftj(300,500),
     &                pjtx(300,500),pjty(300,500),pjtz(300,500),
     &                pjte(300,500),pjtm(300,500)
  SAVE  /hijjet1/
  common/hijjet2/nsg,njsg(900),iasg(900,3),k1sg(900,100),
     &    k2sg(900,100),pxsg(900,100),pysg(900,100),
     &    pzsg(900,100),pesg(900,100),pmsg(900,100)
  SAVE  /hijjet2/

C+++BAC
C
C COMMON/HIJJET4/NDR,IADR(900,2),KFDR(900),PDR(900,5)
C SAVE  /HIJJET4/
C
  common/hijjet4/ndr,iadr(900,2),kfdr(900),pdr(900,5), vdr(900,5)
  SAVE  /hijjet4/

C---BAC

  common/ranseed/nseed
  SAVE  /ranseed/
C************************************ HIJING common block
        common/lujets/n,k(9000,5),p(9000,5),v(9000,5)
  SAVE  /lujets/
        common/ludat1/mstu(200),paru(200),mstj(200),parj(200)
  SAVE  /ludat1/
        common/pyhisubs/msel,msub(200),kfin(2,-40:40),ckin(200)
  SAVE  /pyhisubs/
        common/pyhipars/mstp(200),parp(200),msti(200),pari(200)
  SAVE  /pyhipars/
        common/pyhiint1/mint(400),vint(400)
  SAVE  /pyhiint1/
        common/pyhiint2/iset(200),kfpr(200,2),coef(200,20),icol(40,4,2)
  SAVE  /pyhiint2/
        common/pyhiint5/ngen(0:200,3),xsec(0:200,3)
  SAVE  /pyhiint5/
        common/hipyint/mint4,mint5,atco(200,20),atxs(0:200)
  SAVE  /hipyint/
C*********************************** LU common block
  mxjt=500
C   SIZE OF COMMON BLOCK FOR # OF PARTON PER STRING
  mxsg=900
C   SIZE OF COMMON BLOCK FOR # OF SINGLE STRINGS
  mxsj=100
C   SIZE OF COMMON BLOCK FOR # OF PARTON PER SINGLE
C   STRING
  jflg=0
  ihnt2(11)=jp
  ihnt2(12)=jt
C
  iopjet=iopjet0
  IF(iopjet.EQ.1.AND.(nfp(jp,6).NE.0.OR.nft(jt,6).NE.0))
     &                   iopjet=0
  IF(jp.GT.ihnt2(1) .OR. jt.GT.ihnt2(3)) RETURN
  IF(nfp(jp,6).LT.0 .OR. nft(jt,6).LT.0) RETURN
C   ******** JP or JT can not produce jet anymore
C
  IF(jout.EQ.0) THEN
    epp=pp(jp,4)+pp(jp,3)
    epm=pp(jp,4)-pp(jp,3)
    etp=pt(jt,4)+pt(jt,3)
    etm=pt(jt,4)-pt(jt,3)
    IF(epp.LT.0.0) go to 1000
    IF(epm.LT.0.0) go to 1000
    IF(etp.LT.0.0) go to 1000
    IF(etm.LT.0.0) go to 1000
    IF(epp/(epm+0.01).LE.etp/(etm+0.01)) RETURN
  ENDIF
C   ********for the first hard scattering of (JP,JT)
C     have collision only when Ycm(JP)>Ycm(JT)

  ecut1=hipr1(1)+hipr1(8)+pp(jp,14)+pp(jp,15)
  ecut2=hipr1(1)+hipr1(8)+pt(jt,14)+pt(jt,15)
  IF(pp(jp,4).LE.ecut1) THEN
    nfp(jp,6)=-abs(nfp(jp,6))
    RETURN
  ENDIF
  IF(pt(jt,4).LE.ecut2) THEN
    nft(jt,6)=-abs(nft(jt,6))
    RETURN
  ENDIF
C   *********must have enough energy to produce jets

  miss=0
  misp=0
  mist=0
C
  IF(nfp(jp,10).EQ.0 .AND. nft(jt,10).EQ.0) THEN
    mint(44)=mint4
    mint(45)=mint5
    xsec(0,1)=atxs(0)
    xsec(11,1)=atxs(11)
    xsec(12,1)=atxs(12)
    xsec(28,1)=atxs(28)
    DO 120 i=1,20
    coef(11,i)=atco(11,i)
    coef(12,i)=atco(12,i)
    coef(28,i)=atco(28,i)
120   CONTINUE
  ELSE
    isub11=0
    isub12=0
    isub28=0
    IF(xsec(11,1).NE.0) isub11=1
    IF(xsec(12,1).NE.0) isub12=1
    IF(xsec(28,1).NE.0) isub28=1    
    mint(44)=mint4-isub11-isub12-isub28
    mint(45)=mint5-isub11-isub12-isub28
    xsec(0,1)=atxs(0)-atxs(11)-atxs(12)-atxs(28)
    xsec(11,1)=0.0
    xsec(12,1)=0.0
    xsec(28,1)=0.0  
    DO 110 i=1,20
    coef(11,i)=0.0
    coef(12,i)=0.0
    coef(28,i)=0.0
110   CONTINUE
  ENDIF   
C ********Scatter the valence quarks only once per NN 
C       collision,
C   afterwards only gluon can have hard scattering.
 155  CALL pyhithia
  jj=mint(31)
  IF(jj.NE.1) go to 155
C   *********one hard collision at a time
  IF(k(7,2).EQ.-k(8,2)) THEN
    qmass2=(p(7,4)+p(8,4))**2-(p(7,1)+p(8,1))**2
     &      -(p(7,2)+p(8,2))**2-(p(7,3)+p(8,3))**2
    qm=ulmass(k(7,2))
    IF(qmass2.LT.(2.0*qm+hipr1(1))**2) go to 155
  ENDIF
C   ********q-qbar jets must has minimum mass HIPR1(1)
  pxp=pp(jp,1)-p(3,1)
  pyp=pp(jp,2)-p(3,2)
  pzp=pp(jp,3)-p(3,3)
  pep=pp(jp,4)-p(3,4)
  pxt=pt(jt,1)-p(4,1)
  pyt=pt(jt,2)-p(4,2)
  pzt=pt(jt,3)-p(4,3)
  pet=pt(jt,4)-p(4,4)

  IF(pep.LE.ecut1) THEN
    misp=misp+1
    IF(misp.LT.50) go to 155
    nfp(jp,6)=-abs(nfp(jp,6))
    RETURN
  ENDIF
  IF(pet.LE.ecut2) THEN
    mist=mist+1
    IF(mist.LT.50) go to 155
    nft(jt,6)=-abs(nft(jt,6))
    RETURN
  ENDIF
C   ******** if the remain energy<ECUT the proj or targ
C      can not produce jet anymore

  wp=pep+pzp+pet+pzt
  wm=pep-pzp+pet-pzt
  IF(wp.LT.0.0 .OR. wm.LT.0.0) THEN
    miss=miss+1
    IF(miss.LT.50) go to 155
    RETURN
  ENDIF
C   ********the total W+, W- must be positive
  sw=wp*wm
  ampx=sqrt((ecut1-hipr1(8))**2+pxp**2+pyp**2+0.01)
  amtx=sqrt((ecut2-hipr1(8))**2+pxt**2+pyt**2+0.01)
  sxx=(ampx+amtx)**2
  IF(sw.LT.sxx.OR.vint(43).LT.hipr1(1)) THEN
    miss=miss+1
    IF(miss.LT.50) go to 155
    RETURN
  ENDIF  
C   ********the proj and targ remnants must have at least
C     a CM energy that can produce two strings
C     with minimum mass HIPR1(1)(see HIJSFT HIJFRG)
C
  hint1(41)=p(7,1)
  hint1(42)=p(7,2)
  hint1(43)=p(7,3)
  hint1(44)=p(7,4)
  hint1(45)=p(7,5)
  hint1(46)=sqrt(p(7,1)**2+p(7,2)**2)
  hint1(51)=p(8,1)
  hint1(52)=p(8,2)
  hint1(53)=p(8,3)
  hint1(54)=p(8,4)
  hint1(55)=p(8,5)
  hint1(56)=sqrt(p(8,1)**2+p(8,2)**2) 
  ihnt2(14)=k(7,2)
  ihnt2(15)=k(8,2)
C
  pinirad=(1.0-exp(-2.0*(vint(47)-hidat(1))))
     &    /(1.0+exp(-2.0*(vint(47)-hidat(1))))
  i_inirad=0
  IF(atl_ran(nseed).LE.pinirad) i_inirad=1
  IF(k(7,2).EQ.-k(8,2)) go to 190
  IF(k(7,2).EQ.21.AND.k(8,2).EQ.21.AND.iopjet.EQ.1) go to 190
C*******************************************************************
C gluon  jets are going to be connectd with
C the final leading string of quark-aintquark
C*******************************************************************
  jflg=2
  jpp=0
  lpq=0
  lpb=0
  jtt=0
  ltq=0
  ltb=0
  is7=0
  is8=0
        hint1(47)=0.0
        hint1(48)=0.0
        hint1(49)=0.0
        hint1(50)=0.0
        hint1(67)=0.0
        hint1(68)=0.0
        hint1(69)=0.0
        hint1(70)=0.0
  DO 180 i=9,n
     IF(k(i,3).EQ.1 .OR. k(i,3).EQ.2.OR.
     &                   abs(k(i,2)).GT.30) go to 180
C************************************************************
           IF(k(i,3).EQ.7) THEN
              hint1(47)=hint1(47)+p(i,1)
              hint1(48)=hint1(48)+p(i,2)
              hint1(49)=hint1(49)+p(i,3)
              hint1(50)=hint1(50)+p(i,4)
           ENDIF
           IF(k(i,3).EQ.8) THEN
              hint1(67)=hint1(67)+p(i,1)
              hint1(68)=hint1(68)+p(i,2)
              hint1(69)=hint1(69)+p(i,3)
              hint1(70)=hint1(70)+p(i,4)
           ENDIF
C************************modifcation made on Apr 10. 1996*****
     IF(k(i,2).GT.21.AND.k(i,2).LE.30) THEN
        ndr=ndr+1
        iadr(ndr,1)=jp
        iadr(ndr,2)=jt
        kfdr(ndr)=k(i,2)
        pdr(ndr,1)=p(i,1)
        pdr(ndr,2)=p(i,2)
        pdr(ndr,3)=p(i,3)
        pdr(ndr,4)=p(i,4)
        pdr(ndr,5)=p(i,5)

        vdr(ndr,1)=v(i,1)
        vdr(ndr,2)=v(i,2)
        vdr(ndr,3)=v(i,3)
        vdr(ndr,4)=v(i,4)

C************************************************************
        go to 180
C************************correction made on Oct. 14,1994*****
     ENDIF
     IF(k(i,3).EQ.7.OR.k(i,3).EQ.3) THEN
        IF(k(i,3).EQ.7.AND.k(i,2).NE.21.AND.k(i,2).EQ.k(7,2)
     &               .AND.is7.EQ.0) THEN
     pp(jp,10)=p(i,1)
     pp(jp,11)=p(i,2)
     pp(jp,12)=p(i,3)
     pzp=pzp+p(i,3)
     pep=pep+p(i,4)
     nfp(jp,10)=1
     is7=1
     go to 180
        ENDIF
        IF(k(i,3).EQ.3.AND.(k(i,2).NE.21.OR.
     &                               i_inirad.EQ.0)) THEN
     pxp=pxp+p(i,1)
     pyp=pyp+p(i,2)
     pzp=pzp+p(i,3)
     pep=pep+p(i,4)
     go to 180 
        ENDIF
        jpp=jpp+1
        ip(jpp,1)=i
        ip(jpp,2)=0
        IF(k(i,2).NE.21) THEN
     IF(k(i,2).GT.0) THEN
        lpq=lpq+1
        ipq(lpq)=jpp
        ip(jpp,2)=lpq
     ELSE IF(k(i,2).LT.0) THEN
        lpb=lpb+1
        ipb(lpb)=jpp
        ip(jpp,2)=-lpb
     ENDIF
        ENDIF
     ELSE IF(k(i,3).EQ.8.OR.k(i,3).EQ.4) THEN
        IF(k(i,3).EQ.8.AND.k(i,2).NE.21.AND.k(i,2).EQ.k(8,2)
     &        .AND.is8.EQ.0) THEN
     pt(jt,10)=p(i,1)
     pt(jt,11)=p(i,2)
     pt(jt,12)=p(i,3)
     pzt=pzt+p(i,3)
     pet=pet+p(i,4)
     nft(jt,10)=1
     is8=1
     go to 180
        ENDIF     
        IF(k(i,3).EQ.4.AND.(k(i,2).NE.21.OR.
     &                             i_inirad.EQ.0)) THEN
     pxt=pxt+p(i,1)
     pyt=pyt+p(i,2)
     pzt=pzt+p(i,3)
     pet=pet+p(i,4)
     go to 180
        ENDIF
        jtt=jtt+1
        it(jtt,1)=i
        it(jtt,2)=0
        IF(k(i,2).NE.21) THEN
     IF(k(i,2).GT.0) THEN
        ltq=ltq+1
        itq(ltq)=jtt
        it(jtt,2)=ltq
     ELSE IF(k(i,2).LT.0) THEN
        ltb=ltb+1
        itb(ltb)=jtt
        it(jtt,2)=-ltb
     ENDIF
        ENDIF
     ENDIF
 180  CONTINUE
c
c
  IF(lpq.NE.lpb .OR. ltq.NE.ltb) THEN
    miss=miss+1
    IF(miss.LE.50) go to 155
    WRITE(6,*) ' Q -QBAR NOT MATCHED IN HIJHRD'
    jflg=0
    RETURN
  ENDIF
C****The following will rearrange the partons so that a quark is***
C****allways followed by an anti-quark ****************************

  j=0
181 j=j+1
  IF(j.GT.jpp) go to 182
  IF(ip(j,2).EQ.0) THEN
    go to 181
  ELSE IF(ip(j,2).NE.0) THEN
    lp=abs(ip(j,2))
    ip1=ip(j,1)
    ip2=ip(j,2)
    ip(j,1)=ip(ipq(lp),1)
    ip(j,2)=ip(ipq(lp),2)
    ip(ipq(lp),1)=ip1
    ip(ipq(lp),2)=ip2
    IF(ip2.GT.0) THEN
      ipq(ip2)=ipq(lp)
    ELSE IF(ip2.LT.0) THEN
      ipb(-ip2)=ipq(lp)
    ENDIF
C   ********replace J with a quark
    ip1=ip(j+1,1)
    ip2=ip(j+1,2)
    ip(j+1,1)=ip(ipb(lp),1)
    ip(j+1,2)=ip(ipb(lp),2)
    ip(ipb(lp),1)=ip1
    ip(ipb(lp),2)=ip2
    IF(ip2.GT.0) THEN
      ipq(ip2)=ipb(lp)
    ELSE IF(ip2.LT.0) THEN
      ipb(-ip2)=ipb(lp)
    ENDIF
C   ******** replace J+1 with anti-quark
    j=j+1
    go to 181
  ENDIF

182 j=0
183 j=j+1
  IF(j.GT.jtt) go to 184
  IF(it(j,2).EQ.0) THEN
    go to 183
  ELSE IF(it(j,2).NE.0) THEN
    lt=abs(it(j,2))
    it1=it(j,1)
    it2=it(j,2)
    it(j,1)=it(itq(lt),1)
    it(j,2)=it(itq(lt),2)
    it(itq(lt),1)=it1
    it(itq(lt),2)=it2
    IF(it2.GT.0) THEN
      itq(it2)=itq(lt)
    ELSE IF(it2.LT.0) THEN
      itb(-it2)=itq(lt)
    ENDIF
C   ********replace J with a quark
    it1=it(j+1,1)
    it2=it(j+1,2)
    it(j+1,1)=it(itb(lt),1)
    it(j+1,2)=it(itb(lt),2)
    it(itb(lt),1)=it1
    it(itb(lt),2)=it2
    IF(it2.GT.0) THEN
      itq(it2)=itb(lt)
    ELSE IF(it2.LT.0) THEN
      itb(-it2)=itb(lt)
    ENDIF
C   ******** replace J+1 with anti-quark
    j=j+1
    go to 183

  ENDIF

184 CONTINUE
  IF(npj(jp)+jpp.GT.mxjt.OR.ntj(jt)+jtt.GT.mxjt) THEN
    jflg=0
    WRITE(6,*) 'number of partons per string exceeds'
    WRITE(6,*) 'the common block size'
    RETURN
  ENDIF
C     ********check the bounds of common blocks
  DO 186 j=1,jpp
    kfpj(jp,npj(jp)+j)=k(ip(j,1),2)
    pjpx(jp,npj(jp)+j)=p(ip(j,1),1)
    pjpy(jp,npj(jp)+j)=p(ip(j,1),2)
    pjpz(jp,npj(jp)+j)=p(ip(j,1),3)
    pjpe(jp,npj(jp)+j)=p(ip(j,1),4)
    pjpm(jp,npj(jp)+j)=p(ip(j,1),5)
186 CONTINUE
  npj(jp)=npj(jp)+jpp
  DO 188 j=1,jtt
    kftj(jt,ntj(jt)+j)=k(it(j,1),2)
    pjtx(jt,ntj(jt)+j)=p(it(j,1),1)
    pjty(jt,ntj(jt)+j)=p(it(j,1),2)
    pjtz(jt,ntj(jt)+j)=p(it(j,1),3)
    pjte(jt,ntj(jt)+j)=p(it(j,1),4)
    pjtm(jt,ntj(jt)+j)=p(it(j,1),5)
188 CONTINUE
  ntj(jt)=ntj(jt)+jtt
  go to 900
C*****************************************************************
CThis is the case of a quark-antiquark jet it will fragment alone
C****************************************************************
190 jflg=3
  IF(k(7,2).NE.21.AND.k(8,2).NE.21.AND.
     &                   k(7,2)*k(8,2).GT.0) go to 155
  jpp=0
  lpq=0
  lpb=0
        DO 200 i=9,n
     IF(k(i,3).EQ.1.OR.k(i,3).EQ.2.OR.
     &                  abs(k(i,2)).GT.30) go to 200
    IF(k(i,2).GT.21.AND.k(i,2).LE.30) THEN
      ndr=ndr+1
      iadr(ndr,1)=jp
      iadr(ndr,2)=jt
      kfdr(ndr)=k(i,2)
      pdr(ndr,1)=p(i,1)
      pdr(ndr,2)=p(i,2)
      pdr(ndr,3)=p(i,3)
      pdr(ndr,4)=p(i,4)
      pdr(ndr,5)=p(i,5)

      vdr(ndr,1)=v(i,1)
      vdr(ndr,2)=v(i,2)
      vdr(ndr,3)=v(i,3)
      vdr(ndr,4)=v(i,4)

C************************************************************
      go to 200
C************************correction made on Oct. 14,1994*****
    ENDIF
    IF(k(i,3).EQ.3.AND.(k(i,2).NE.21.OR.
     &                              i_inirad.EQ.0)) THEN
      pxp=pxp+p(i,1)
      pyp=pyp+p(i,2)
      pzp=pzp+p(i,3)
      pep=pep+p(i,4)
      go to 200
    ENDIF
    IF(k(i,3).EQ.4.AND.(k(i,2).NE.21.OR.
     &                                i_inirad.EQ.0)) THEN
      pxt=pxt+p(i,1)
      pyt=pyt+p(i,2)
      pzt=pzt+p(i,3)
      pet=pet+p(i,4)
      go to 200
    ENDIF
    jpp=jpp+1
    ip(jpp,1)=i
    ip(jpp,2)=0
    IF(k(i,2).NE.21) THEN
      IF(k(i,2).GT.0) THEN
        lpq=lpq+1
        ipq(lpq)=jpp
        ip(jpp,2)=lpq
      ELSE IF(k(i,2).LT.0) THEN
        lpb=lpb+1
        ipb(lpb)=jpp
        ip(jpp,2)=-lpb
      ENDIF
    ENDIF
200 CONTINUE
  IF(lpq.NE.lpb) THEN
     miss=miss+1
     IF(miss.LE.50) go to 155
     WRITE(6,*) lpq,lpb, 'Q-QBAR NOT CONSERVED OR NOT MATCHED'
     jflg=0
     RETURN
  ENDIF

C**** The following will rearrange the partons so that a quark is***
C**** allways followed by an anti-quark ****************************
  j=0
220 j=j+1
  IF(j.GT.jpp) go to 222
  IF(ip(j,2).EQ.0) go to 220
    lp=abs(ip(j,2))
    ip1=ip(j,1)
    ip2=ip(j,2)
    ip(j,1)=ip(ipq(lp),1)
    ip(j,2)=ip(ipq(lp),2)
    ip(ipq(lp),1)=ip1
    ip(ipq(lp),2)=ip2
    IF(ip2.GT.0) THEN
      ipq(ip2)=ipq(lp)
    ELSE IF(ip2.LT.0) THEN
      ipb(-ip2)=ipq(lp)
    ENDIF
    ipq(lp)=j
C   ********replace J with a quark
    ip1=ip(j+1,1)
    ip2=ip(j+1,2)
    ip(j+1,1)=ip(ipb(lp),1)
    ip(j+1,2)=ip(ipb(lp),2)
    ip(ipb(lp),1)=ip1
    ip(ipb(lp),2)=ip2
    IF(ip2.GT.0) THEN
      ipq(ip2)=ipb(lp)
    ELSE IF(ip2.LT.0) THEN
      ipb(-ip2)=ipb(lp)
    ENDIF
C   ******** replace J+1 with an anti-quark
    ipb(lp)=j+1
    j=j+1
    go to 220

222 CONTINUE
  IF(lpq.GE.1) THEN
    DO 240 l0=2,lpq
      ip1=ip(2*l0-3,1)
      ip2=ip(2*l0-3,2)
      ip(2*l0-3,1)=ip(ipq(l0),1)
      ip(2*l0-3,2)=ip(ipq(l0),2)
      ip(ipq(l0),1)=ip1
      ip(ipq(l0),2)=ip2
      IF(ip2.GT.0) THEN
        ipq(ip2)=ipq(l0)
      ELSE IF(ip2.LT.0) THEN
        ipb(-ip2)=ipq(l0)
      ENDIF
      ipq(l0)=2*l0-3
C
      ip1=ip(2*l0-2,1)
      ip2=ip(2*l0-2,2)
      ip(2*l0-2,1)=ip(ipb(l0),1)
      ip(2*l0-2,2)=ip(ipb(l0),2)
      ip(ipb(l0),1)=ip1
      ip(ipb(l0),2)=ip2
      IF(ip2.GT.0) THEN
        ipq(ip2)=ipb(l0)
      ELSE IF(ip2.LT.0) THEN
        ipb(-ip2)=ipb(l0)
      ENDIF
      ipb(l0)=2*l0-2
240   CONTINUE
C   ********move all the qqbar pair to the front of 
C       the list, except the first pair
    ip1=ip(2*lpq-1,1)
    ip2=ip(2*lpq-1,2)
    ip(2*lpq-1,1)=ip(ipq(1),1)
    ip(2*lpq-1,2)=ip(ipq(1),2)
    ip(ipq(1),1)=ip1
    ip(ipq(1),2)=ip2
    IF(ip2.GT.0) THEN
      ipq(ip2)=ipq(1)
    ELSE IF(ip2.LT.0) THEN
      ipb(-ip2)=ipq(1)
    ENDIF
    ipq(1)=2*lpq-1
C   ********move the first quark to the beginning of
C       the last string system
    ip1=ip(jpp,1)
    ip2=ip(jpp,2)
    ip(jpp,1)=ip(ipb(1),1)
    ip(jpp,2)=ip(ipb(1),2)
    ip(ipb(1),1)=ip1
    ip(ipb(1),2)=ip2
    IF(ip2.GT.0) THEN
      ipq(ip2)=ipb(1)
    ELSE IF(ip2.LT.0) THEN
      ipb(-ip2)=ipb(1)
    ENDIF
    ipb(1)=jpp
C   ********move the first anti-quark to the end of the 
C     last string system
  ENDIF
  IF(nsg.GE.mxsg) THEN
     jflg=0
     WRITE(6,*) 'number of jets forming single strings exceeds'
     WRITE(6,*) 'the common block size'
     RETURN
  ENDIF
  IF(jpp.GT.mxsj) THEN
     jflg=0
     WRITE(6,*) 'number of partons per single jet system'
     WRITE(6,*) 'exceeds the common block size'
     RETURN
  ENDIF
C   ********check the bounds of common block size
  nsg=nsg+1
  njsg(nsg)=jpp
  iasg(nsg,1)=jp
  iasg(nsg,2)=jt
  iasg(nsg,3)=0
  DO 300 i=1,jpp
    k1sg(nsg,i)=2
    k2sg(nsg,i)=k(ip(i,1),2)
    IF(k2sg(nsg,i).LT.0) k1sg(nsg,i)=1
    pxsg(nsg,i)=p(ip(i,1),1)
    pysg(nsg,i)=p(ip(i,1),2)
    pzsg(nsg,i)=p(ip(i,1),3)
    pesg(nsg,i)=p(ip(i,1),4)
    pmsg(nsg,i)=p(ip(i,1),5)
300 CONTINUE
  k1sg(nsg,1)=2
  k1sg(nsg,jpp)=1
C******* reset the energy-momentum of incoming particles ********
900 pp(jp,1)=pxp
  pp(jp,2)=pyp
  pp(jp,3)=pzp
  pp(jp,4)=pep
  pp(jp,5)=0.0
  pt(jt,1)=pxt
  pt(jt,2)=pyt
  pt(jt,3)=pzt
  pt(jt,4)=pet
  pt(jt,5)=0.0

  nfp(jp,6)=nfp(jp,6)+1
  nft(jt,6)=nft(jt,6)+1
  RETURN
C
1000  jflg=-1
  IF(ihpr2(10).EQ.0) RETURN
  WRITE(6,*) 'Fatal HIJHRD error'
  WRITE(6,*) jp, ' proj E+,E-',epp,epm,' status',nfp(jp,5)
  WRITE(6,*) jt, ' targ E+,E_',etp,etm,' status',nft(jt,5)
  RETURN
  END