hipyset1.35.f

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

C
C
C
C     Modified for HIJING program
c
c    modification July 22, 1997  In pyremnn put an upper limit
c     on the total pt kick the parton can accumulate via multiple
C     scattering. Set the upper limit to be the sqrt(s)/2,
c     this is fix cronin bug for Pb+Pb events at SPS energy.
c
C
C Last modification Oct. 1993 to comply with non-vax
C machines' compiler 
C
C
      SUBROUTINE lu1ent(IP,KF,PE,THE,PHI)   
    
C...Purpose: to store one parton/particle in commonblock LUJETS.    
      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/ludat2/kchg(500,3),pmas(500,4),parf(2000),vckm(4,4)    
      SAVE /ludat2/ 
    
C...Standard checks.    
      mstu(28)=0    
      IF(mstu(12).GE.1) CALL lulist(0)  
      ipa=max(1,iabs(ip))   
      IF(ipa.GT.mstu(4)) CALL luerrm(21,    
     &'(LU1ENT:) writing outside LUJETS memory')    
      kc=lucomp(kf) 
      IF(kc.EQ.0) CALL luerrm(12,'(LU1ENT:) unknown flavour code')  
    
C...Find mass. Reset K, P and V vectors.    
      pm=0. 
      IF(mstu(10).EQ.1) pm=p(ipa,5) 
      IF(mstu(10).GE.2) pm=ulmass(kf)   
      DO 100 j=1,5  
      k(ipa,j)=0    
      p(ipa,j)=0.   
  100 v(ipa,j)=0.   
    
C...Store parton/particle in K and P vectors.   
      k(ipa,1)=1    
      IF(ip.LT.0) k(ipa,1)=2    
      k(ipa,2)=kf   
      p(ipa,5)=pm   
      p(ipa,4)=max(pe,pm)   
      pa=sqrt(p(ipa,4)**2-p(ipa,5)**2)  
      p(ipa,1)=pa*sin(the)*cos(phi) 
      p(ipa,2)=pa*sin(the)*sin(phi) 
      p(ipa,3)=pa*cos(the)  
    
C...Set N. Optionally fragment/decay.   
      n=ipa 
      IF(ip.EQ.0) CALL luexec   
    
      RETURN    
      END   
    
C*********************************************************************  
    
      SUBROUTINE lu2ent(IP,KF1,KF2,PECM)    
    
C...Purpose: to store two partons/particles in their CM frame,  
C...with the first along the +z axis.   
      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/ludat2/kchg(500,3),pmas(500,4),parf(2000),vckm(4,4)    
      SAVE /ludat2/ 
    
C...Standard checks.    
      mstu(28)=0    
      IF(mstu(12).GE.1) CALL lulist(0)  
      ipa=max(1,iabs(ip))   
      IF(ipa.GT.mstu(4)-1) CALL luerrm(21,  
     &'(LU2ENT:) writing outside LUJETS memory')    
      kc1=lucomp(kf1)   
      kc2=lucomp(kf2)   
      IF(kc1.EQ.0.OR.kc2.EQ.0) CALL luerrm(12,  
     &'(LU2ENT:) unknown flavour code') 
    
C...Find masses. Reset K, P and V vectors.  
      pm1=0.    
      IF(mstu(10).EQ.1) pm1=p(ipa,5)    
      IF(mstu(10).GE.2) pm1=ulmass(kf1) 
      pm2=0.    
      IF(mstu(10).EQ.1) pm2=p(ipa+1,5)  
      IF(mstu(10).GE.2) pm2=ulmass(kf2) 
      DO 100 i=ipa,ipa+1    
      DO 100 j=1,5  
      k(i,j)=0  
      p(i,j)=0. 
  100 v(i,j)=0. 
    
C...Check flavours. 
      kq1=kchg(kc1,2)*isign(1,kf1)  
      kq2=kchg(kc2,2)*isign(1,kf2)  
      IF(kq1+kq2.NE.0.AND.kq1+kq2.NE.4) CALL luerrm(2,  
     &'(LU2ENT:) unphysical flavour combination')   
      k(ipa,2)=kf1  
      k(ipa+1,2)=kf2    
    
C...Store partons/particles in K vectors for normal case.   
      IF(ip.GE.0) THEN  
        k(ipa,1)=1  
        IF(kq1.NE.0.AND.kq2.NE.0) k(ipa,1)=2    
        k(ipa+1,1)=1    
    
C...Store partons in K vectors for parton shower evolution. 
      ELSE  
        IF(kq1.EQ.0.OR.kq2.EQ.0) CALL luerrm(2, 
     &  '(LU2ENT:) requested flavours can not develop parton shower')   
        k(ipa,1)=3  
        k(ipa+1,1)=3    
        k(ipa,4)=mstu(5)*(ipa+1)    
        k(ipa,5)=k(ipa,4)   
        k(ipa+1,4)=mstu(5)*ipa  
        k(ipa+1,5)=k(ipa+1,4)   
      ENDIF 
    
C...Check kinematics and store partons/particles in P vectors.  
      IF(pecm.LE.pm1+pm2) CALL luerrm(13,   
     &'(LU2ENT:) energy smaller than sum of masses')    
      pa=sqrt(max(0.,(pecm**2-pm1**2-pm2**2)**2-(2.*pm1*pm2)**2))/  
     &(2.*pecm) 
      p(ipa,3)=pa   
      p(ipa,4)=sqrt(pm1**2+pa**2)   
      p(ipa,5)=pm1  
      p(ipa+1,3)=-pa    
      p(ipa+1,4)=sqrt(pm2**2+pa**2) 
      p(ipa+1,5)=pm2    
    
C...Set N. Optionally fragment/decay.   
      n=ipa+1   
      IF(ip.EQ.0) CALL luexec   
    
      RETURN    
      END   
    
C*********************************************************************  
    
      SUBROUTINE lu3ent(IP,KF1,KF2,KF3,PECM,X1,X3)  
    
C...Purpose: to store three partons or particles in their CM frame, 
C...with the first along the +z axis and the third in the (x,z) 
C...plane with x > 0.   
      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/ludat2/kchg(500,3),pmas(500,4),parf(2000),vckm(4,4)    
      SAVE /ludat2/ 
    
C...Standard checks.    
      mstu(28)=0    
      IF(mstu(12).GE.1) CALL lulist(0)  
      ipa=max(1,iabs(ip))   
      IF(ipa.GT.mstu(4)-2) CALL luerrm(21,  
     &'(LU3ENT:) writing outside LUJETS memory')    
      kc1=lucomp(kf1)   
      kc2=lucomp(kf2)   
      kc3=lucomp(kf3)   
      IF(kc1.EQ.0.OR.kc2.EQ.0.OR.kc3.EQ.0) CALL luerrm(12,  
     &'(LU3ENT:) unknown flavour code') 
    
C...Find masses. Reset K, P and V vectors.  
      pm1=0.    
      IF(mstu(10).EQ.1) pm1=p(ipa,5)    
      IF(mstu(10).GE.2) pm1=ulmass(kf1) 
      pm2=0.    
      IF(mstu(10).EQ.1) pm2=p(ipa+1,5)  
      IF(mstu(10).GE.2) pm2=ulmass(kf2) 
      pm3=0.    
      IF(mstu(10).EQ.1) pm3=p(ipa+2,5)  
      IF(mstu(10).GE.2) pm3=ulmass(kf3) 
      DO 100 i=ipa,ipa+2    
      DO 100 j=1,5  
      k(i,j)=0  
      p(i,j)=0. 
  100 v(i,j)=0. 
    
C...Check flavours. 
      kq1=kchg(kc1,2)*isign(1,kf1)  
      kq2=kchg(kc2,2)*isign(1,kf2)  
      kq3=kchg(kc3,2)*isign(1,kf3)  
      IF(kq1.EQ.0.AND.kq2.EQ.0.AND.kq3.EQ.0) THEN   
      ELSEIF(kq1.NE.0.AND.kq2.EQ.2.AND.(kq1+kq3.EQ.0.OR.kq1+kq3.EQ.4))  
     &THEN  
      ELSE  
        CALL luerrm(2,'(LU3ENT:) unphysical flavour combination')   
      ENDIF 
      k(ipa,2)=kf1  
      k(ipa+1,2)=kf2    
      k(ipa+2,2)=kf3    
    
C...Store partons/particles in K vectors for normal case.   
      IF(ip.GE.0) THEN  
        k(ipa,1)=1  
        IF(kq1.NE.0.AND.(kq2.NE.0.OR.kq3.NE.0)) k(ipa,1)=2  
        k(ipa+1,1)=1    
        IF(kq2.NE.0.AND.kq3.NE.0) k(ipa+1,1)=2  
        k(ipa+2,1)=1    
    
C...Store partons in K vectors for parton shower evolution. 
      ELSE  
        IF(kq1.EQ.0.OR.kq2.EQ.0.OR.kq3.EQ.0) CALL luerrm(2, 
     &  '(LU3ENT:) requested flavours can not develop parton shower')   
        k(ipa,1)=3  
        k(ipa+1,1)=3    
        k(ipa+2,1)=3    
        kcs=4   
        IF(kq1.EQ.-1) kcs=5 
        k(ipa,kcs)=mstu(5)*(ipa+1)  
        k(ipa,9-kcs)=mstu(5)*(ipa+2)    
        k(ipa+1,kcs)=mstu(5)*(ipa+2)    
        k(ipa+1,9-kcs)=mstu(5)*ipa  
        k(ipa+2,kcs)=mstu(5)*ipa    
        k(ipa+2,9-kcs)=mstu(5)*(ipa+1)  
      ENDIF 
    
C...Check kinematics.   
      mkerr=0   
      IF(0.5*x1*pecm.LE.pm1.OR.0.5*(2.-x1-x3)*pecm.LE.pm2.OR.   
     &0.5*x3*pecm.LE.pm3) mkerr=1   
      pa1=sqrt(max(0.,(0.5*x1*pecm)**2-pm1**2)) 
      pa2=sqrt(max(0.,(0.5*(2.-x1-x3)*pecm)**2-pm2**2)) 
      pa3=sqrt(max(0.,(0.5*x3*pecm)**2-pm3**2)) 
      cthe2=(pa3**2-pa1**2-pa2**2)/(2.*pa1*pa2) 
      cthe3=(pa2**2-pa1**2-pa3**2)/(2.*pa1*pa3) 
      IF(abs(cthe2).GE.1.001.OR.abs(cthe3).GE.1.001) mkerr=1    
      cthe3=max(-1.,min(1.,cthe3))  
      IF(mkerr.NE.0) CALL luerrm(13,    
     &'(LU3ENT:) unphysical kinematical variable setup')    
    
C...Store partons/particles in P vectors.   
      p(ipa,3)=pa1  
      p(ipa,4)=sqrt(pa1**2+pm1**2)  
      p(ipa,5)=pm1  
      p(ipa+2,1)=pa3*sqrt(1.-cthe3**2)  
      p(ipa+2,3)=pa3*cthe3  
      p(ipa+2,4)=sqrt(pa3**2+pm3**2)    
      p(ipa+2,5)=pm3    
      p(ipa+1,1)=-p(ipa+2,1)    
      p(ipa+1,3)=-p(ipa,3)-p(ipa+2,3)   
      p(ipa+1,4)=sqrt(p(ipa+1,1)**2+p(ipa+1,3)**2+pm2**2)   
      p(ipa+1,5)=pm2    
    
C...Set N. Optionally fragment/decay.   
      n=ipa+2   
      IF(ip.EQ.0) CALL luexec   
    
      RETURN    
      END   
    
C*********************************************************************  
    
      SUBROUTINE lu4ent(IP,KF1,KF2,KF3,KF4,PECM,X1,X2,X4,X12,X14)   
    
C...Purpose: to store four partons or particles in their CM frame, with 
C...the first along the +z axis, the last in the xz plane with x > 0    
C...and the second having y < 0 and y > 0 with equal probability.   
      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/ludat2/kchg(500,3),pmas(500,4),parf(2000),vckm(4,4)    
      SAVE /ludat2/ 
    
C...Standard checks.    
      mstu(28)=0    
      IF(mstu(12).GE.1) CALL lulist(0)  
      ipa=max(1,iabs(ip))   
      IF(ipa.GT.mstu(4)-3) CALL luerrm(21,  
     &'(LU4ENT:) writing outside LUJETS momory')    
      kc1=lucomp(kf1)   
      kc2=lucomp(kf2)   
      kc3=lucomp(kf3)   
      kc4=lucomp(kf4)   
      IF(kc1.EQ.0.OR.kc2.EQ.0.OR.kc3.EQ.0.OR.kc4.EQ.0) CALL luerrm(12,  
     &'(LU4ENT:) unknown flavour code') 
    
C...Find masses. Reset K, P and V vectors.  
      pm1=0.    
      IF(mstu(10).EQ.1) pm1=p(ipa,5)    
      IF(mstu(10).GE.2) pm1=ulmass(kf1) 
      pm2=0.    
      IF(mstu(10).EQ.1) pm2=p(ipa+1,5)  
      IF(mstu(10).GE.2) pm2=ulmass(kf2) 
      pm3=0.    
      IF(mstu(10).EQ.1) pm3=p(ipa+2,5)  
      IF(mstu(10).GE.2) pm3=ulmass(kf3) 
      pm4=0.    
      IF(mstu(10).EQ.1) pm4=p(ipa+3,5)  
      IF(mstu(10).GE.2) pm4=ulmass(kf4) 
      DO 100 i=ipa,ipa+3    
      DO 100 j=1,5  
      k(i,j)=0  
      p(i,j)=0. 
  100 v(i,j)=0. 
    
C...Check flavours. 
      kq1=kchg(kc1,2)*isign(1,kf1)  
      kq2=kchg(kc2,2)*isign(1,kf2)  
      kq3=kchg(kc3,2)*isign(1,kf3)  
      kq4=kchg(kc4,2)*isign(1,kf4)  
      IF(kq1.EQ.0.AND.kq2.EQ.0.AND.kq3.EQ.0.AND.kq4.EQ.0) THEN  
      ELSEIF(kq1.NE.0.AND.kq2.EQ.2.AND.kq3.EQ.2.AND.(kq1+kq4.EQ.0.OR.   
     &kq1+kq4.EQ.4)) THEN   
      ELSEIF(kq1.NE.0.AND.kq1+kq2.EQ.0.AND.kq3.NE.0.AND.kq3+kq4.EQ.0.)  
     &THEN  
      ELSE  
        CALL luerrm(2,'(LU4ENT:) unphysical flavour combination')   
      ENDIF 
      k(ipa,2)=kf1  
      k(ipa+1,2)=kf2    
      k(ipa+2,2)=kf3    
      k(ipa+3,2)=kf4    
    
C...Store partons/particles in K vectors for normal case.   
      IF(ip.GE.0) THEN  
        k(ipa,1)=1  
        IF(kq1.NE.0.AND.(kq2.NE.0.OR.kq3.NE.0.OR.kq4.NE.0)) k(ipa,1)=2  
        k(ipa+1,1)=1    
        IF(kq2.NE.0.AND.kq1+kq2.NE.0.AND.(kq3.NE.0.OR.kq4.NE.0))    
     &  k(ipa+1,1)=2    
        k(ipa+2,1)=1    
        IF(kq3.NE.0.AND.kq4.NE.0) k(ipa+2,1)=2  
        k(ipa+3,1)=1    
    
C...Store partons for parton shower evolution from q-g-g-qbar or    
C...g-g-g-g event.  
      ELSEIF(kq1+kq2.NE.0) THEN 
        IF(kq1.EQ.0.OR.kq2.EQ.0.OR.kq3.EQ.0.OR.kq4.EQ.0) CALL luerrm(2, 
     &  '(LU4ENT:) requested flavours can not develop parton shower')   
        k(ipa,1)=3  
        k(ipa+1,1)=3    
        k(ipa+2,1)=3    
        k(ipa+3,1)=3    
        kcs=4   
        IF(kq1.EQ.-1) kcs=5 
        k(ipa,kcs)=mstu(5)*(ipa+1)  
        k(ipa,9-kcs)=mstu(5)*(ipa+3)    
        k(ipa+1,kcs)=mstu(5)*(ipa+2)    
        k(ipa+1,9-kcs)=mstu(5)*ipa  
        k(ipa+2,kcs)=mstu(5)*(ipa+3)    
        k(ipa+2,9-kcs)=mstu(5)*(ipa+1)  
        k(ipa+3,kcs)=mstu(5)*ipa    
        k(ipa+3,9-kcs)=mstu(5)*(ipa+2)  
    
C...Store partons for parton shower evolution from q-qbar-q-qbar event. 
      ELSE  
        IF(kq1.EQ.0.OR.kq2.EQ.0.OR.kq3.EQ.0.OR.kq4.EQ.0) CALL luerrm(2, 
     &  '(LU4ENT:) requested flavours can not develop parton shower')   
        k(ipa,1)=3  
        k(ipa+1,1)=3    
        k(ipa+2,1)=3    
        k(ipa+3,1)=3    
        k(ipa,4)=mstu(5)*(ipa+1)    
        k(ipa,5)=k(ipa,4)   
        k(ipa+1,4)=mstu(5)*ipa  
        k(ipa+1,5)=k(ipa+1,4)   
        k(ipa+2,4)=mstu(5)*(ipa+3)  
        k(ipa+2,5)=k(ipa+2,4)   
        k(ipa+3,4)=mstu(5)*(ipa+2)  
        k(ipa+3,5)=k(ipa+3,4)   
      ENDIF 
    
C...Check kinematics.   
      mkerr=0   
      IF(0.5*x1*pecm.LE.pm1.OR.0.5*x2*pecm.LE.pm2.OR.0.5*(2.-x1-x2-x4)* 
     &pecm.LE.pm3.OR.0.5*x4*pecm.LE.pm4) mkerr=1    
      pa1=sqrt(max(0.,(0.5*x1*pecm)**2-pm1**2)) 
      pa2=sqrt(max(0.,(0.5*x2*pecm)**2-pm2**2)) 
      pa3=sqrt(max(0.,(0.5*(2.-x1-x2-x4)*pecm)**2-pm3**2))  
      pa4=sqrt(max(0.,(0.5*x4*pecm)**2-pm4**2)) 
      x24=x1+x2+x4-1.-x12-x14+(pm3**2-pm1**2-pm2**2-pm4**2)/pecm**2 
      cthe4=(x1*x4-2.*x14)*pecm**2/(4.*pa1*pa4) 
      IF(abs(cthe4).GE.1.002) mkerr=1   
      cthe4=max(-1.,min(1.,cthe4))  
      sthe4=sqrt(1.-cthe4**2)   
      cthe2=(x1*x2-2.*x12)*pecm**2/(4.*pa1*pa2) 
      IF(abs(cthe2).GE.1.002) mkerr=1   
      cthe2=max(-1.,min(1.,cthe2))  
      sthe2=sqrt(1.-cthe2**2)   
      cphi2=((x2*x4-2.*x24)*pecm**2-4.*pa2*cthe2*pa4*cthe4)/    
     &(4.*pa2*sthe2*pa4*sthe4)  
      IF(abs(cphi2).GE.1.05) mkerr=1    
      cphi2=max(-1.,min(1.,cphi2))  
      IF(mkerr.EQ.1) CALL luerrm(13,    
     &'(LU4ENT:) unphysical kinematical variable setup')    
    
C...Store partons/particles in P vectors.   
      p(ipa,3)=pa1  
      p(ipa,4)=sqrt(pa1**2+pm1**2)  
      p(ipa,5)=pm1  
      p(ipa+3,1)=pa4*sthe4  
      p(ipa+3,3)=pa4*cthe4  
      p(ipa+3,4)=sqrt(pa4**2+pm4**2)    
      p(ipa+3,5)=pm4    
      p(ipa+1,1)=pa2*sthe2*cphi2    
      p(ipa+1,2)=pa2*sthe2*sqrt(1.-cphi2**2)*(-1.)**int(rlu(0)+0.5) 
      p(ipa+1,3)=pa2*cthe2  
      p(ipa+1,4)=sqrt(pa2**2+pm2**2)    
      p(ipa+1,5)=pm2    
      p(ipa+2,1)=-p(ipa+1,1)-p(ipa+3,1) 
      p(ipa+2,2)=-p(ipa+1,2)    
      p(ipa+2,3)=-p(ipa,3)-p(ipa+1,3)-p(ipa+3,3)    
      p(ipa+2,4)=sqrt(p(ipa+2,1)**2+p(ipa+2,2)**2+p(ipa+2,3)**2+pm3**2) 
      p(ipa+2,5)=pm3    
    
C...Set N. Optionally fragment/decay.   
      n=ipa+3   
      IF(ip.EQ.0) CALL luexec   
    
      RETURN    
      END   
    
C*********************************************************************  
    
      SUBROUTINE lujoin(NJOIN,IJOIN)    
    
C...Purpose: to connect a sequence of partons with colour flow indices, 
C...as required for subsequent shower evolution (or other operations).  
      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/ludat2/kchg(500,3),pmas(500,4),parf(2000),vckm(4,4)    
      SAVE /ludat2/ 
      dimension ijoin(*)    
    
C...Check that partons are of right types to be connected.  
      IF(njoin.LT.2) goto 120   
      kqsum=0   
      DO 100 ijn=1,njoin    
      i=ijoin(ijn)  
      IF(i.LE.0.OR.i.GT.n) goto 120 
      IF(k(i,1).LT.1.OR.k(i,1).GT.3) goto 120   
      kc=lucomp(k(i,2)) 
      IF(kc.EQ.0) goto 120  
      kq=kchg(kc,2)*isign(1,k(i,2)) 
      IF(kq.EQ.0) goto 120  
      IF(ijn.NE.1.AND.ijn.NE.njoin.AND.kq.NE.2) goto 120    
      IF(kq.NE.2) kqsum=kqsum+kq    
  100 IF(ijn.EQ.1) kqs=kq   
      IF(kqsum.NE.0) goto 120   
    
C...Connect the partons sequentially (closing for gluon loop).  
      kcs=(9-kqs)/2 
      IF(kqs.EQ.2) kcs=int(4.5+rlu(0))  
      DO 110 ijn=1,njoin    
      i=ijoin(ijn)  
      k(i,1)=3  
      IF(ijn.NE.1) ip=ijoin(ijn-1)  
      IF(ijn.EQ.1) ip=ijoin(njoin)  
      IF(ijn.NE.njoin) in=ijoin(ijn+1)  
      IF(ijn.EQ.njoin) in=ijoin(1)  
      k(i,kcs)=mstu(5)*in   
      k(i,9-kcs)=mstu(5)*ip 
      IF(ijn.EQ.1.AND.kqs.NE.2) k(i,9-kcs)=0    
  110 IF(ijn.EQ.njoin.AND.kqs.NE.2) k(i,kcs)=0  
    
C...Error exit: no action taken.    
      RETURN    
  120 CALL luerrm(12,   
     &'(LUJOIN:) given entries can not be joined by one string')    
    
      RETURN    
      END   
    
C*********************************************************************  
    
      SUBROUTINE lugive(CHIN)   
    
C...Purpose: to set values of commonblock variables.    
      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/ludat2/kchg(500,3),pmas(500,4),parf(2000),vckm(4,4)    
      SAVE /ludat2/ 
      common/ludat3/mdcy(500,3),mdme(2000,2),brat(2000),kfdp(2000,5)    
      SAVE /ludat3/ 
      common/ludat4/chaf(500)   
      CHARACTER chaf*8  
      SAVE /ludat4/ 
      CHARACTER chin*(*),chfix*104,chbit*104,chold*8,chnew*8,   
     &chnam*4,chvar(17)*4,chalp(2)*26,chind*8,chini*10,chinr*16 
      DATA chvar/'N','K','P','V','MSTU','PARU','MSTJ','PARJ','KCHG',    
     &'PMAS','PARF','VCKM','MDCY','MDME','BRAT','KFDP','CHAF'/  
      DATA chalp/'abcdefghijklmnopqrstuvwxyz',  
     &'ABCDEFGHIJKLMNOPQRSTUVWXYZ'/ 
    
C...Length of character variable. Subdivide it into instructions.   
      IF(mstu(12).GE.1) CALL lulist(0)  
      chbit=chin//' '   
      lbit=101  
  100 lbit=lbit-1   
      IF(chbit(lbit:lbit).EQ.' ') goto 100  
      ltot=0    
      DO 110 lcom=1,lbit    
      IF(chbit(lcom:lcom).EQ.' ') goto 110  
      ltot=ltot+1   
      chfix(ltot:ltot)=chbit(lcom:lcom) 
  110 CONTINUE  
      llow=0    
  120 lhig=llow+1   
  130 lhig=lhig+1   
      IF(lhig.LE.ltot.AND.chfix(lhig:lhig).NE.';') goto 130 
      lbit=lhig-llow-1  
      chbit(1:lbit)=chfix(llow+1:lhig-1)    
    
C...Identify commonblock variable.  
      lnam=1    
  140 lnam=lnam+1   
      IF(chbit(lnam:lnam).NE.'('.AND.chbit(lnam:lnam).NE.'='.AND.   
     &lnam.LE.4) goto 140   
      chnam=chbit(1:lnam-1)//' '    
      DO 150 lcom=1,lnam-1  
      DO 150 lalp=1,26  
  150 IF(chnam(lcom:lcom).EQ.chalp(1)(lalp:lalp)) chnam(lcom:lcom)= 
     &chalp(2)(lalp:lalp)   
      ivar=0    
      DO 160 iv=1,17    
  160 IF(chnam.EQ.chvar(iv)) ivar=iv    
      IF(ivar.EQ.0) THEN    
        CALL luerrm(18,'(LUGIVE:) do not recognize variable '//chnam)   
        llow=lhig   
        IF(llow.LT.ltot) goto 120   
        RETURN  
      ENDIF 
    
C...Identify any indices.   
      i=0   
      j=0   
      IF(chbit(lnam:lnam).EQ.'(') THEN  
        lind=lnam   
  170   lind=lind+1 
        IF(chbit(lind:lind).NE.')'.AND.chbit(lind:lind).NE.',') goto 170    
        chind=' '   
        IF((chbit(lnam+1:lnam+1).EQ.'C'.OR.chbit(lnam+1:lnam+1).EQ.'c').    
     &  and.(ivar.EQ.9.OR.ivar.EQ.10.OR.ivar.EQ.13.OR.ivar.EQ.17)) THEN 
          chind(lnam-lind+11:8)=chbit(lnam+2:lind-1)    
          READ(chind,'(I8)') i1 
          i=lucomp(i1)  
        ELSE    
          chind(lnam-lind+10:8)=chbit(lnam+1:lind-1)    
          READ(chind,'(I8)') i  
        ENDIF   
        lnam=lind   
        IF(chbit(lnam:lnam).EQ.')') lnam=lnam+1 
      ENDIF 
      IF(chbit(lnam:lnam).EQ.',') THEN  
        lind=lnam   
  180   lind=lind+1 
        IF(chbit(lind:lind).NE.')'.AND.chbit(lind:lind).NE.',') goto 180    
        chind=' '   
        chind(lnam-lind+10:8)=chbit(lnam+1:lind-1)  
        READ(chind,'(I8)') j    
        lnam=lind+1 
      ENDIF 
    
C...Check that indices allowed and save old value.  
      ierr=1    
      IF(chbit(lnam:lnam).NE.'=') goto 190  
      IF(ivar.EQ.1) THEN    
        IF(i.NE.0.OR.j.NE.0) goto 190   
        iold=n  
      ELSEIF(ivar.EQ.2) THEN    
        IF(i.LT.1.OR.i.GT.mstu(4).OR.j.LT.1.OR.j.GT.5) goto 190 
        iold=k(i,j) 
      ELSEIF(ivar.EQ.3) THEN    
        IF(i.LT.1.OR.i.GT.mstu(4).OR.j.LT.1.OR.j.GT.5) goto 190 
        rold=p(i,j) 
      ELSEIF(ivar.EQ.4) THEN    
        IF(i.LT.1.OR.i.GT.mstu(4).OR.j.LT.1.OR.j.GT.5) goto 190 
        rold=v(i,j) 
      ELSEIF(ivar.EQ.5) THEN    
        IF(i.LT.1.OR.i.GT.200.OR.j.NE.0) goto 190   
        iold=mstu(i)    
      ELSEIF(ivar.EQ.6) THEN    
        IF(i.LT.1.OR.i.GT.200.OR.j.NE.0) goto 190   
        rold=paru(i)    
      ELSEIF(ivar.EQ.7) THEN    
        IF(i.LT.1.OR.i.GT.200.OR.j.NE.0) goto 190   
        iold=mstj(i)    
      ELSEIF(ivar.EQ.8) THEN    
        IF(i.LT.1.OR.i.GT.200.OR.j.NE.0) goto 190   
        rold=parj(i)    
      ELSEIF(ivar.EQ.9) THEN    
        IF(i.LT.1.OR.i.GT.mstu(6).OR.j.LT.1.OR.j.GT.3) goto 190 
        iold=kchg(i,j)  
      ELSEIF(ivar.EQ.10) THEN   
        IF(i.LT.1.OR.i.GT.mstu(6).OR.j.LT.1.OR.j.GT.4) goto 190 
        rold=pmas(i,j)  
      ELSEIF(ivar.EQ.11) THEN   
        IF(i.LT.1.OR.i.GT.2000.OR.j.NE.0) goto 190  
        rold=parf(i)    
      ELSEIF(ivar.EQ.12) THEN   
        IF(i.LT.1.OR.i.GT.4.OR.j.LT.1.OR.j.GT.4) goto 190   
        rold=vckm(i,j)  
      ELSEIF(ivar.EQ.13) THEN   
        IF(i.LT.1.OR.i.GT.mstu(6).OR.j.LT.1.OR.j.GT.3) goto 190 
        iold=mdcy(i,j)  
      ELSEIF(ivar.EQ.14) THEN   
        IF(i.LT.1.OR.i.GT.mstu(7).OR.j.LT.1.OR.j.GT.2) goto 190 
        iold=mdme(i,j)  
      ELSEIF(ivar.EQ.15) THEN   
        IF(i.LT.1.OR.i.GT.mstu(7).OR.j.NE.0) goto 190   
        rold=brat(i)    
      ELSEIF(ivar.EQ.16) THEN   
        IF(i.LT.1.OR.i.GT.mstu(7).OR.j.LT.1.OR.j.GT.5) goto 190 
        iold=kfdp(i,j)  
      ELSEIF(ivar.EQ.17) THEN   
        IF(i.LT.1.OR.i.GT.mstu(6).OR.j.NE.0) goto 190   
        chold=chaf(i)   
      ENDIF 
      ierr=0    
  190 IF(ierr.EQ.1) THEN    
        CALL luerrm(18,'(LUGIVE:) unallowed indices for '// 
     &  chbit(1:lnam-1))    
        llow=lhig   
        IF(llow.LT.ltot) goto 120   
        RETURN  
      ENDIF 
    
C...Print current value of variable. Loop back. 
      IF(lnam.GE.lbit) THEN 
        chbit(lnam:14)=' '  
        chbit(15:60)=' has the value                                '   
        IF(ivar.EQ.1.OR.ivar.EQ.2.OR.ivar.EQ.5.OR.ivar.EQ.7.OR. 
     &  ivar.EQ.9.OR.ivar.EQ.13.OR.ivar.EQ.14.OR.ivar.EQ.16) THEN   
          WRITE(chbit(51:60),'(I10)') iold  
        ELSEIF(ivar.NE.17) THEN 
          WRITE(chbit(47:60),'(F14.5)') rold    
        ELSE    
          chbit(53:60)=chold    
        ENDIF   
        IF(mstu(13).GE.1) WRITE(mstu(11),1000) chbit(1:60)  
        llow=lhig   
        IF(llow.LT.ltot) goto 120   
        RETURN  
      ENDIF 
    
C...Read in new variable value. 
      IF(ivar.EQ.1.OR.ivar.EQ.2.OR.ivar.EQ.5.OR.ivar.EQ.7.OR.   
     &ivar.EQ.9.OR.ivar.EQ.13.OR.ivar.EQ.14.OR.ivar.EQ.16) THEN 
        chini=' '   
        chini(lnam-lbit+11:10)=chbit(lnam+1:lbit)   
        READ(chini,'(I10)') inew    
      ELSEIF(ivar.NE.17) THEN   
        chinr=' '   
        chinr(lnam-lbit+17:16)=chbit(lnam+1:lbit)   
        READ(chinr,'(F16.2)') rnew  
      ELSE  
        chnew=chbit(lnam+1:lbit)//' '   
      ENDIF 
    
C...Store new variable value.   
      IF(ivar.EQ.1) THEN    
        n=inew  
      ELSEIF(ivar.EQ.2) THEN    
        k(i,j)=inew 
      ELSEIF(ivar.EQ.3) THEN    
        p(i,j)=rnew 
      ELSEIF(ivar.EQ.4) THEN    
        v(i,j)=rnew 
      ELSEIF(ivar.EQ.5) THEN    
        mstu(i)=inew    
      ELSEIF(ivar.EQ.6) THEN    
        paru(i)=rnew    
      ELSEIF(ivar.EQ.7) THEN    
        mstj(i)=inew    
      ELSEIF(ivar.EQ.8) THEN    
        parj(i)=rnew    
      ELSEIF(ivar.EQ.9) THEN    
        kchg(i,j)=inew  
      ELSEIF(ivar.EQ.10) THEN   
        pmas(i,j)=rnew  
      ELSEIF(ivar.EQ.11) THEN   
        parf(i)=rnew    
      ELSEIF(ivar.EQ.12) THEN   
        vckm(i,j)=rnew  
      ELSEIF(ivar.EQ.13) THEN   
        mdcy(i,j)=inew  
      ELSEIF(ivar.EQ.14) THEN   
        mdme(i,j)=inew  
      ELSEIF(ivar.EQ.15) THEN   
        brat(i)=rnew    
      ELSEIF(ivar.EQ.16) THEN   
        kfdp(i,j)=inew  
      ELSEIF(ivar.EQ.17) THEN   
        chaf(i)=chnew   
      ENDIF 
    
C...Write old and new value. Loop back. 
      chbit(lnam:14)=' '    
      chbit(15:60)=' changed from                to               ' 
      IF(ivar.EQ.1.OR.ivar.EQ.2.OR.ivar.EQ.5.OR.ivar.EQ.7.OR.   
     &ivar.EQ.9.OR.ivar.EQ.13.OR.ivar.EQ.14.OR.ivar.EQ.16) THEN 
        WRITE(chbit(33:42),'(I10)') iold    
        WRITE(chbit(51:60),'(I10)') inew    
      ELSEIF(ivar.NE.17) THEN   
        WRITE(chbit(29:42),'(F14.5)') rold  
        WRITE(chbit(47:60),'(F14.5)') rnew  
      ELSE  
        chbit(35:42)=chold  
        chbit(53:60)=chnew  
      ENDIF 
      IF(mstu(13).GE.1) WRITE(mstu(11),1000) chbit(1:60)    
      llow=lhig 
      IF(llow.LT.ltot) goto 120 
    
C...Format statement for output on unit MSTU(11) (by default 6).    
 1000 FORMAT(5x,a60)    
    
      RETURN    
      END   
    
C*********************************************************************  
    
      SUBROUTINE luexec 
    
C...Purpose: to administrate the fragmentation and decay chain. 
      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/ludat2/kchg(500,3),pmas(500,4),parf(2000),vckm(4,4)    
      SAVE /ludat2/ 
      common/ludat3/mdcy(500,3),mdme(2000,2),brat(2000),kfdp(2000,5)    
      SAVE /ludat3/ 
      dimension ps(2,6) 
    
C...Initialize and reset.   
      mstu(24)=0    
      IF(mstu(12).GE.1) CALL lulist(0)  
      mstu(31)=mstu(31)+1   
      mstu(1)=0 
      mstu(2)=0 
      mstu(3)=0 
      mcons=1   
    
C...Sum up momentum, energy and charge for starting entries.    
      nsav=n    
      DO 100 i=1,2  
      DO 100 j=1,6  
  100 ps(i,j)=0.    
      DO 120 i=1,n  
      IF(k(i,1).LE.0.OR.k(i,1).GT.10) goto 120  
      DO 110 j=1,4  
  110 ps(1,j)=ps(1,j)+p(i,j)    
      ps(1,6)=ps(1,6)+luchge(k(i,2))    
  120 CONTINUE  
      paru(21)=ps(1,4)  
    
C...Prepare system for subsequent fragmentation/decay.  
      CALL luprep(0)    
    
C...Loop through jet fragmentation and particle decays. 
      mbe=0 
  130 mbe=mbe+1 
      ip=0  
  140 ip=ip+1   
      kc=0  
      IF(k(ip,1).GT.0.AND.k(ip,1).LE.10) kc=lucomp(k(ip,2)) 
      IF(kc.EQ.0) THEN  
    
C...Particle decay if unstable and allowed. Save long-lived particle    
C...decays until second pass after Bose-Einstein effects.   
      ELSEIF(kchg(kc,2).EQ.0) THEN  
        IF(mstj(21).GE.1.AND.mdcy(kc,1).GE.1.AND.(mstj(51).LE.0.OR.mbe. 
     &  eq.2.OR.pmas(kc,2).GE.parj(91).OR.iabs(k(ip,2)).EQ.311))    
     &  CALL ludecy(ip) 
    
C...Decay products may develop a shower.    
        IF(mstj(92).GT.0) THEN  
          ip1=mstj(92)  
          qmax=sqrt(max(0.,(p(ip1,4)+p(ip1+1,4))**2-(p(ip1,1)+p(ip1+1,  
     &    1))**2-(p(ip1,2)+p(ip1+1,2))**2-(p(ip1,3)+p(ip1+1,3))**2))    
          CALL lushow(ip1,ip1+1,qmax)   
          CALL luprep(ip1)  
          mstj(92)=0    
        ELSEIF(mstj(92).LT.0) THEN  
          ip1=-mstj(92) 
          CALL lushow(ip1,-3,p(ip,5))   
          CALL luprep(ip1)  
          mstj(92)=0    
        ENDIF   
    
C...Jet fragmentation: string or independent fragmentation. 
      ELSEIF(k(ip,1).EQ.1.OR.k(ip,1).EQ.2) THEN 
        mfrag=mstj(1)   
        IF(mfrag.GE.1.AND.k(ip,1).EQ.1) mfrag=2 
        IF(mstj(21).GE.2.AND.k(ip,1).EQ.2.AND.n.GT.ip) THEN 
          IF(k(ip+1,1).EQ.1.AND.k(ip+1,3).EQ.k(ip,3).AND.   
     &    k(ip,3).GT.0.AND.k(ip,3).LT.ip) THEN  
            IF(kchg(lucomp(k(k(ip,3),2)),2).EQ.0) mfrag=min(1,mfrag)    
          ENDIF 
        ENDIF   
        IF(mfrag.EQ.1) CALL lustrf(ip)  
        IF(mfrag.EQ.2) CALL luindf(ip)  
        IF(mfrag.EQ.2.AND.k(ip,1).EQ.1) mcons=0 
        IF(mfrag.EQ.2.AND.(mstj(3).LE.0.OR.mod(mstj(3),5).EQ.0)) mcons=0    
      ENDIF 
    
C...Loop back if enough space left in LUJETS and no error abort.    
      IF(mstu(24).NE.0.AND.mstu(21).GE.2) THEN  
      ELSEIF(ip.LT.n.AND.n.LT.mstu(4)-20-mstu(32)) THEN 
        goto 140    
      ELSEIF(ip.LT.n) THEN  
        CALL luerrm(11,'(LUEXEC:) no more memory left in LUJETS')   
      ENDIF 
    
C...Include simple Bose-Einstein effect parametrization if desired. 
      IF(mbe.EQ.1.AND.mstj(51).GE.1) THEN   
        CALL luboei(nsav)   
        goto 130    
      ENDIF 
    
C...Check that momentum, energy and charge were conserved.  
      DO 160 i=1,n  
      IF(k(i,1).LE.0.OR.k(i,1).GT.10) goto 160  
      DO 150 j=1,4  
  150 ps(2,j)=ps(2,j)+p(i,j)    
      ps(2,6)=ps(2,6)+luchge(k(i,2))    
  160 CONTINUE  
      pdev=(abs(ps(2,1)-ps(1,1))+abs(ps(2,2)-ps(1,2))+abs(ps(2,3)-  
     &ps(1,3))+abs(ps(2,4)-ps(1,4)))/(1.+abs(ps(2,4))+abs(ps(1,4))) 
      IF(mcons.EQ.1.AND.pdev.GT.paru(11)) CALL luerrm(15,   
     &'(LUEXEC:) four-momentum was not conserved')  
      IF(mcons.EQ.1.AND.abs(ps(2,6)-ps(1,6)).GT.0.1) CALL luerrm(15,    
     &'(LUEXEC:) charge was not conserved') 
    
      RETURN    
      END   
    
C*********************************************************************  
    
      SUBROUTINE luprep(IP) 
    
C...Purpose: to rearrange partons along strings, to allow small systems 
C...to collapse into one or two particles and to check flavours.    
      IMPLICIT DOUBLE PRECISION(d)  
      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/ludat2/kchg(500,3),pmas(500,4),parf(2000),vckm(4,4)    
      SAVE /ludat2/ 
      common/ludat3/mdcy(500,3),mdme(2000,2),brat(2000),kfdp(2000,5)    
      SAVE /ludat3/ 
      dimension dps(5),dpc(5),ue(3) 
    
C...Rearrange parton shower product listing along strings: begin loop.  
      i1=n  
      DO 130 mqgst=1,2  
      DO 120 i=max(1,ip),n  
      IF(k(i,1).NE.3) goto 120  
      kc=lucomp(k(i,2)) 
      IF(kc.EQ.0) goto 120  
      kq=kchg(kc,2) 
      IF(kq.EQ.0.OR.(mqgst.EQ.1.AND.kq.EQ.2)) goto 120  
    
C...Pick up loose string end.   
      kcs=4 
      IF(kq*isign(1,k(i,2)).LT.0) kcs=5 
      ia=i  
      nstp=0    
  100 nstp=nstp+1   
      IF(nstp.GT.4*n) THEN  
        CALL luerrm(14,'(LUPREP:) caught in infinite loop') 
        RETURN  
      ENDIF 
    
C...Copy undecayed parton.  
      IF(k(ia,1).EQ.3) THEN 
        IF(i1.GE.mstu(4)-mstu(32)-5) THEN   
          CALL luerrm(11,'(LUPREP:) no more memory left in LUJETS') 
          RETURN    
        ENDIF   
        i1=i1+1 
        k(i1,1)=2   
        IF(nstp.GE.2.AND.iabs(k(ia,2)).NE.21) k(i1,1)=1 
        k(i1,2)=k(ia,2) 
        k(i1,3)=ia  
        k(i1,4)=0   
        k(i1,5)=0   
        DO 110 j=1,5    
        p(i1,j)=p(ia,j) 
  110   v(i1,j)=v(ia,j) 
        k(ia,1)=k(ia,1)+10  
        IF(k(i1,1).EQ.1) goto 120   
      ENDIF 
    
C...Go to next parton in colour space.  
      ib=ia 
      IF(mod(k(ib,kcs)/mstu(5)**2,2).EQ.0.AND.mod(k(ib,kcs),mstu(5)).   
     &ne.0) THEN    
        ia=mod(k(ib,kcs),mstu(5))   
        k(ib,kcs)=k(ib,kcs)+mstu(5)**2  
        mrev=0  
      ELSE  
        IF(k(ib,kcs).GE.2*mstu(5)**2.OR.mod(k(ib,kcs)/mstu(5),mstu(5)). 
     &  eq.0) kcs=9-kcs 
        ia=mod(k(ib,kcs)/mstu(5),mstu(5))   
        k(ib,kcs)=k(ib,kcs)+2*mstu(5)**2    
        mrev=1  
      ENDIF 
      IF(ia.LE.0.OR.ia.GT.n) THEN   
        CALL luerrm(12,'(LUPREP:) colour rearrangement failed') 
        RETURN  
      ENDIF 
      IF(mod(k(ia,4)/mstu(5),mstu(5)).EQ.ib.OR.mod(k(ia,5)/mstu(5), 
     &mstu(5)).EQ.ib) THEN  
        IF(mrev.EQ.1) kcs=9-kcs 
        IF(mod(k(ia,kcs)/mstu(5),mstu(5)).NE.ib) kcs=9-kcs  
        k(ia,kcs)=k(ia,kcs)+2*mstu(5)**2    
      ELSE  
        IF(mrev.EQ.0) kcs=9-kcs 
        IF(mod(k(ia,kcs),mstu(5)).NE.ib) kcs=9-kcs  
        k(ia,kcs)=k(ia,kcs)+mstu(5)**2  
      ENDIF 
      IF(ia.NE.i) goto 100  
      k(i1,1)=1 
  120 CONTINUE  
  130 CONTINUE  
      n=i1  
    
C...Find lowest-mass colour singlet jet system, OK if above threshold.  
      IF(mstj(14).LE.0) goto 320    
      ns=n  
  140 nsin=n-ns 
      pdm=1.+parj(32)   
      ic=0  
      DO 190 i=max(1,ip),ns 
      IF(k(i,1).NE.1.AND.k(i,1).NE.2) THEN  
      ELSEIF(k(i,1).EQ.2.AND.ic.EQ.0) THEN  
        nsin=nsin+1 
        ic=i    
        DO 150 j=1,4    
  150   dps(j)=p(i,j)   
        mstj(93)=1  
        dps(5)=ulmass(k(i,2))   
      ELSEIF(k(i,1).EQ.2) THEN  
        DO 160 j=1,4    
  160   dps(j)=dps(j)+p(i,j)    
      ELSEIF(ic.NE.0.AND.kchg(lucomp(k(i,2)),2).NE.0) THEN  
        DO 170 j=1,4    
  170   dps(j)=dps(j)+p(i,j)    
        mstj(93)=1  
        dps(5)=dps(5)+ulmass(k(i,2))    
        pd=sqrt(max(0d0,dps(4)**2-dps(1)**2-dps(2)**2-dps(3)**2))-dps(5)    
        IF(pd.LT.pdm) THEN  
          pdm=pd    
          DO 180 j=1,5  
  180     dpc(j)=dps(j) 
          ic1=ic    
          ic2=i 
        ENDIF   
        ic=0    
      ELSE  
        nsin=nsin+1 
      ENDIF 
  190 CONTINUE  
      IF(pdm.GE.parj(32)) goto 320  
    
C...Fill small-mass system as cluster.  
      nsav=n    
      pecm=sqrt(max(0d0,dpc(4)**2-dpc(1)**2-dpc(2)**2-dpc(3)**2))   
      k(n+1,1)=11   
      k(n+1,2)=91   
      k(n+1,3)=ic1  
      k(n+1,4)=n+2  
      k(n+1,5)=n+3  
      p(n+1,1)=dpc(1)   
      p(n+1,2)=dpc(2)   
      p(n+1,3)=dpc(3)   
      p(n+1,4)=dpc(4)   
      p(n+1,5)=pecm 
    
C...Form two particles from flavours of lowest-mass system, if feasible.    
      k(n+2,1)=1    
      k(n+3,1)=1    
      IF(mstu(16).NE.2) THEN    
        k(n+2,3)=n+1    
        k(n+3,3)=n+1    
      ELSE  
        k(n+2,3)=ic1    
        k(n+3,3)=ic2    
      ENDIF 
      k(n+2,4)=0    
      k(n+3,4)=0    
      k(n+2,5)=0    
      k(n+3,5)=0    
      IF(iabs(k(ic1,2)).NE.21) THEN 
        kc1=lucomp(k(ic1,2))    
        kc2=lucomp(k(ic2,2))    
        IF(kc1.EQ.0.OR.kc2.EQ.0) goto 320   
        kq1=kchg(kc1,2)*isign(1,k(ic1,2))   
        kq2=kchg(kc2,2)*isign(1,k(ic2,2))   
        IF(kq1+kq2.NE.0) goto 320   
  200   CALL lukfdi(k(ic1,2),0,kfln,k(n+2,2))   
        CALL lukfdi(k(ic2,2),-kfln,kfldmp,k(n+3,2)) 
        IF(k(n+2,2).EQ.0.OR.k(n+3,2).EQ.0) goto 200 
      ELSE  
        IF(iabs(k(ic2,2)).NE.21) goto 320   
  210   CALL lukfdi(1+int((2.+parj(2))*rlu(0)),0,kfln,kfdmp)    
        CALL lukfdi(kfln,0,kflm,k(n+2,2))   
        CALL lukfdi(-kfln,-kflm,kfldmp,k(n+3,2))    
        IF(k(n+2,2).EQ.0.OR.k(n+3,2).EQ.0) goto 210 
      ENDIF 
      p(n+2,5)=ulmass(k(n+2,2)) 
      p(n+3,5)=ulmass(k(n+3,2)) 
      IF(p(n+2,5)+p(n+3,5)+parj(64).GE.pecm.AND.nsin.EQ.1) goto 320 
      IF(p(n+2,5)+p(n+3,5)+parj(64).GE.pecm) goto 260   
    
C...Perform two-particle decay of jet system, if possible.  
      IF(pecm.GE.0.02*dpc(4)) THEN  
        pa=sqrt((pecm**2-(p(n+2,5)+p(n+3,5))**2)*(pecm**2-  
     &  (p(n+2,5)-p(n+3,5))**2))/(2.*pecm)  
        ue(3)=2.*rlu(0)-1.  
        phi=paru(2)*rlu(0)  
        ue(1)=sqrt(1.-ue(3)**2)*cos(phi)    
        ue(2)=sqrt(1.-ue(3)**2)*sin(phi)    
        DO 220 j=1,3    
        p(n+2,j)=pa*ue(j)   
  220   p(n+3,j)=-pa*ue(j)  
        p(n+2,4)=sqrt(pa**2+p(n+2,5)**2)    
        p(n+3,4)=sqrt(pa**2+p(n+3,5)**2)    
        CALL ludbrb(n+2,n+3,0.,0.,dpc(1)/dpc(4),dpc(2)/dpc(4),  
     &  dpc(3)/dpc(4))  
      ELSE  
        np=0    
        DO 230 i=ic1,ic2    
  230   IF(k(i,1).EQ.1.OR.k(i,1).EQ.2) np=np+1  
        ha=p(ic1,4)*p(ic2,4)-p(ic1,1)*p(ic2,1)-p(ic1,2)*p(ic2,2)-   
     &  p(ic1,3)*p(ic2,3)   
        IF(np.GE.3.OR.ha.LE.1.25*p(ic1,5)*p(ic2,5)) goto 260    
        hd1=0.5*(p(n+2,5)**2-p(ic1,5)**2)   
        hd2=0.5*(p(n+3,5)**2-p(ic2,5)**2)   
        hr=sqrt(max(0.,((ha-hd1-hd2)**2-(p(n+2,5)*p(n+3,5))**2)/    
     &  (ha**2-(p(ic1,5)*p(ic2,5))**2)))-1. 
        hc=p(ic1,5)**2+2.*ha+p(ic2,5)**2    
        hk1=((p(ic2,5)**2+ha)*hr+hd1-hd2)/hc    
        hk2=((p(ic1,5)**2+ha)*hr+hd2-hd1)/hc    
        DO 240 j=1,4    
        p(n+2,j)=(1.+hk1)*p(ic1,j)-hk2*p(ic2,j) 
  240   p(n+3,j)=(1.+hk2)*p(ic2,j)-hk1*p(ic1,j) 
      ENDIF 
      DO 250 j=1,4  
      v(n+1,j)=v(ic1,j) 
      v(n+2,j)=v(ic1,j) 
  250 v(n+3,j)=v(ic2,j) 
      v(n+1,5)=0.   
      v(n+2,5)=0.   
      v(n+3,5)=0.   
      n=n+3 
      goto 300  
    
C...Else form one particle from the flavours available, if possible.    
  260 k(n+1,5)=n+2  
      IF(iabs(k(ic1,2)).GT.100.AND.iabs(k(ic2,2)).GT.100) THEN  
        goto 320    
      ELSEIF(iabs(k(ic1,2)).NE.21) THEN 
        CALL lukfdi(k(ic1,2),k(ic2,2),kfldmp,k(n+2,2))  
      ELSE  
        kfln=1+int((2.+parj(2))*rlu(0)) 
        CALL lukfdi(kfln,-kfln,kfldmp,k(n+2,2)) 
      ENDIF 
      IF(k(n+2,2).EQ.0) goto 260    
      p(n+2,5)=ulmass(k(n+2,2)) 
    
C...Find parton/particle which combines to largest extra mass.  
      ir=0  
      ha=0. 
      DO 280 mcomb=1,3  
      IF(ir.NE.0) goto 280  
      DO 270 i=max(1,ip),n  
      IF(k(i,1).LE.0.OR.k(i,1).GT.10.OR.(i.GE.ic1.AND.i.LE.ic2. 
     &and.k(i,1).GE.1.AND.k(i,1).LE.2)) goto 270    
      IF(mcomb.EQ.1) kci=lucomp(k(i,2)) 
      IF(mcomb.EQ.1.AND.kci.EQ.0) goto 270  
      IF(mcomb.EQ.1.AND.kchg(kci,2).EQ.0.AND.i.LE.ns) goto 270  
      IF(mcomb.EQ.2.AND.iabs(k(i,2)).GT.10.AND.iabs(k(i,2)).LE.100) 
     &goto 270  
      hcr=dpc(4)*p(i,4)-dpc(1)*p(i,1)-dpc(2)*p(i,2)-dpc(3)*p(i,3)   
      IF(hcr.GT.ha) THEN    
        ir=i    
        ha=hcr  
      ENDIF 
  270 CONTINUE  
  280 CONTINUE  
    
C...Shuffle energy and momentum to put new particle on mass shell.  
      hb=pecm**2+ha 
      hc=p(n+2,5)**2+ha 
      hd=p(ir,5)**2+ha
C******************CHANGES BY HIJING************  
      hk2=0.0
      IF(ha**2-(pecm*p(ir,5))**2.EQ.0.0.OR.hb+hd.EQ.0.0) go to 285
C******************
      hk2=0.5*(hb*sqrt(((hb+hc)**2-4.*(hb+hd)*p(n+2,5)**2)/ 
     &(ha**2-(pecm*p(ir,5))**2))-(hb+hc))/(hb+hd)   
  285 hk1=(0.5*(p(n+2,5)**2-pecm**2)+hd*hk2)/hb 
      DO 290 j=1,4  
      p(n+2,j)=(1.+hk1)*dpc(j)-hk2*p(ir,j)  
      p(ir,j)=(1.+hk2)*p(ir,j)-hk1*dpc(j)   
      v(n+1,j)=v(ic1,j) 
  290 v(n+2,j)=v(ic1,j) 
      v(n+1,5)=0.   
      v(n+2,5)=0.   
      n=n+2 
    
C...Mark collapsed system and store daughter pointers. Iterate. 
  300 DO 310 i=ic1,ic2  
      IF((k(i,1).EQ.1.OR.k(i,1).EQ.2).AND.kchg(lucomp(k(i,2)),2).NE.0)  
     &THEN  
        k(i,1)=k(i,1)+10    
        IF(mstu(16).NE.2) THEN  
          k(i,4)=nsav+1 
          k(i,5)=nsav+1 
        ELSE    
          k(i,4)=nsav+2 
          k(i,5)=n  
        ENDIF   
      ENDIF 
  310 CONTINUE  
      IF(n.LT.mstu(4)-mstu(32)-5) goto 140  
    
C...Check flavours and invariant masses in parton systems.  
  320 np=0  
      kfn=0 
      kqs=0 
      DO 330 j=1,5  
  330 dps(j)=0. 
      DO 360 i=max(1,ip),n  
      IF(k(i,1).LE.0.OR.k(i,1).GT.10) goto 360  
      kc=lucomp(k(i,2)) 
      IF(kc.EQ.0) goto 360  
      kq=kchg(kc,2)*isign(1,k(i,2)) 
      IF(kq.EQ.0) goto 360  
      np=np+1   
      IF(kq.NE.2) THEN  
        kfn=kfn+1   
        kqs=kqs+kq  
        mstj(93)=1  
        dps(5)=dps(5)+ulmass(k(i,2))    
      ENDIF 
      DO 340 j=1,4  
  340 dps(j)=dps(j)+p(i,j)  
      IF(k(i,1).EQ.1) THEN  
        IF(np.NE.1.AND.(kfn.EQ.1.OR.kfn.GE.3.OR.kqs.NE.0)) CALL 
     &  luerrm(2,'(LUPREP:) unphysical flavour combination')    
        IF(np.NE.1.AND.dps(4)**2-dps(1)**2-dps(2)**2-dps(3)**2.LT.  
     &  (0.9*parj(32)+dps(5))**2) CALL luerrm(3,    
     &  '(LUPREP:) too small mass in jet system')   
        np=0    
        kfn=0   
        kqs=0   
        DO 350 j=1,5    
  350   dps(j)=0.   
      ENDIF 
  360 CONTINUE  
    
      RETURN    
      END   
    
C*********************************************************************  
    
      SUBROUTINE lustrf(IP) 
C...Purpose: to handle the fragmentation of an arbitrary colour singlet 
C...jet system according to the Lund string fragmentation model.    
      IMPLICIT DOUBLE PRECISION(d)  
      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/ludat2/kchg(500,3),pmas(500,4),parf(2000),vckm(4,4)    
      SAVE /ludat2/ 
      dimension dps(5),kfl(3),pmq(3),px(3),py(3),gam(3),ie(2),pr(2),    
     &in(9),dhm(4),dhg(4),dp(5,5),irank(2),mju(4),iju(3),pju(5,5),  
     &tju(5),kfjh(2),njs(2),kfjs(2),pjs(4,5)    
    
C...Function: four-product of two vectors.  
      four(i,j)=p(i,4)*p(j,4)-p(i,1)*p(j,1)-p(i,2)*p(j,2)-p(i,3)*p(j,3) 
      dfour(i,j)=dp(i,4)*dp(j,4)-dp(i,1)*dp(j,1)-dp(i,2)*dp(j,2)-   
     &dp(i,3)*dp(j,3)   
    
C...Reset counters. Identify parton system. 
      mstj(91)=0    
      nsav=n    
      np=0  
      kqsum=0   
      DO 100 j=1,5  
  100 dps(j)=0. 
      mju(1)=0  
      mju(2)=0  
      i=ip-1    
  110 i=i+1 
      IF(i.GT.min(n,mstu(4)-mstu(32))) THEN 
        CALL luerrm(12,'(LUSTRF:) failed to reconstruct jet system')    
        IF(mstu(21).GE.1) RETURN    
      ENDIF 
      IF(k(i,1).NE.1.AND.k(i,1).NE.2.AND.k(i,1).NE.41) goto 110 
      kc=lucomp(k(i,2)) 
      IF(kc.EQ.0) goto 110  
      kq=kchg(kc,2)*isign(1,k(i,2)) 
      IF(kq.EQ.0) goto 110  
      IF(n+5*np+11.GT.mstu(4)-mstu(32)-5) THEN  
        CALL luerrm(11,'(LUSTRF:) no more memory left in LUJETS')   
        IF(mstu(21).GE.1) RETURN    
      ENDIF 
    
C...Take copy of partons to be considered. Check flavour sum.   
      np=np+1   
      DO 120 j=1,5  
      k(n+np,j)=k(i,j)  
      p(n+np,j)=p(i,j)  
  120 dps(j)=dps(j)+p(i,j)  
      k(n+np,3)=i   
      IF(p(n+np,4)**2.LT.p(n+np,1)**2+p(n+np,2)**2+p(n+np,3)**2) THEN   
        p(n+np,4)=sqrt(p(n+np,1)**2+p(n+np,2)**2+p(n+np,3)**2+  
     &  p(n+np,5)**2)   
        dps(4)=dps(4)+max(0.,p(n+np,4)-p(i,4))  
      ENDIF 
      IF(kq.NE.2) kqsum=kqsum+kq    
      IF(k(i,1).EQ.41) THEN 
        kqsum=kqsum+2*kq    
        IF(kqsum.EQ.kq) mju(1)=n+np 
        IF(kqsum.NE.kq) mju(2)=n+np 
      ENDIF 
      IF(k(i,1).EQ.2.OR.k(i,1).EQ.41) goto 110  
      IF(kqsum.NE.0) THEN   
        CALL luerrm(12,'(LUSTRF:) unphysical flavour combination')  
        IF(mstu(21).GE.1) RETURN    
      ENDIF 
    
C...Boost copied system to CM frame (for better numerical precision).   
      CALL ludbrb(n+1,n+np,0.,0.,-dps(1)/dps(4),-dps(2)/dps(4), 
     &-dps(3)/dps(4))   
    
C...Search for very nearby partons that may be recombined.  
      ntryr=0   
      paru12=paru(12)   
      paru13=paru(13)   
      mju(3)=mju(1) 
      mju(4)=mju(2) 
      nr=np 
  130 IF(nr.GE.3) THEN  
        pdrmin=2.*paru12    
        DO 140 i=n+1,n+nr   
        IF(i.EQ.n+nr.AND.iabs(k(n+1,2)).NE.21) goto 140 
        i1=i+1  
        IF(i.EQ.n+nr) i1=n+1    
        IF(k(i,1).EQ.41.OR.k(i1,1).EQ.41) goto 140  
        IF(mju(1).NE.0.AND.i1.LT.mju(1).AND.iabs(k(i1,2)).NE.21)    
     &  goto 140    
        IF(mju(2).NE.0.AND.i.GT.mju(2).AND.iabs(k(i,2)).NE.21) goto 140 
        pap=sqrt((p(i,1)**2+p(i,2)**2+p(i,3)**2)*(p(i1,1)**2+   
     &  p(i1,2)**2+p(i1,3)**2)) 
        pvp=p(i,1)*p(i1,1)+p(i,2)*p(i1,2)+p(i,3)*p(i1,3)    
        pdr=4.*(pap-pvp)**2/(paru13**2*pap+2.*(pap-pvp))    
        IF(pdr.LT.pdrmin) THEN  
          ir=i  
          pdrmin=pdr    
        ENDIF   
  140   CONTINUE    
    
C...Recombine very nearby partons to avoid machine precision problems.  
        IF(pdrmin.LT.paru12.AND.ir.EQ.n+nr) THEN    
          DO 150 j=1,4  
  150     p(n+1,j)=p(n+1,j)+p(n+nr,j)   
          p(n+1,5)=sqrt(max(0.,p(n+1,4)**2-p(n+1,1)**2-p(n+1,2)**2- 
     &    p(n+1,3)**2)) 
          nr=nr-1   
          goto 130  
        ELSEIF(pdrmin.LT.paru12) THEN   
          DO 160 j=1,4  
  160     p(ir,j)=p(ir,j)+p(ir+1,j) 
          p(ir,5)=sqrt(max(0.,p(ir,4)**2-p(ir,1)**2-p(ir,2)**2- 
     &    p(ir,3)**2))  
          DO 170 i=ir+1,n+nr-1  
          k(i,2)=k(i+1,2)   
          DO 170 j=1,5  
  170     p(i,j)=p(i+1,j)   
          IF(ir.EQ.n+nr-1) k(ir,2)=k(n+nr,2)    
          nr=nr-1   
          IF(mju(1).GT.ir) mju(1)=mju(1)-1  
          IF(mju(2).GT.ir) mju(2)=mju(2)-1  
          goto 130  
        ENDIF   
      ENDIF 
      ntryr=ntryr+1 
    
C...Reset particle counter. Skip ahead if no junctions are present; 
C...this is usually the case!   
      nrs=max(5*nr+11,np)   
      ntry=0    
  180 ntry=ntry+1   
      IF(ntry.GT.100.AND.ntryr.LE.4) THEN   
        paru12=4.*paru12    
        paru13=2.*paru13    
        goto 130    
      ELSEIF(ntry.GT.100) THEN  
        CALL luerrm(14,'(LUSTRF:) caught in infinite loop') 
        IF(mstu(21).GE.1) RETURN    
      ENDIF 
      i=n+nrs   
      IF(mju(1).EQ.0.AND.mju(2).EQ.0) goto 500  
      DO 490 jt=1,2 
      njs(jt)=0 
      IF(mju(jt).EQ.0) goto 490 
      js=3-2*jt 
    
C...Find and sum up momentum on three sides of junction. Check flavours.    
      DO 190 iu=1,3 
      iju(iu)=0 
      DO 190 j=1,5  
  190 pju(iu,j)=0.  
      iu=0  
      DO 200 i1=n+1+(jt-1)*(nr-1),n+nr+(jt-1)*(1-nr),js 
      IF(k(i1,2).NE.21.AND.iu.LE.2) THEN    
        iu=iu+1 
        iju(iu)=i1  
      ENDIF 
      DO 200 j=1,4  
  200 pju(iu,j)=pju(iu,j)+p(i1,j)   
      DO 210 iu=1,3 
  210 pju(iu,5)=sqrt(pju(iu,1)**2+pju(iu,2)**2+pju(iu,3)**2)    
      IF(k(iju(3),2)/100.NE.10*k(iju(1),2)+k(iju(2),2).AND. 
     &k(iju(3),2)/100.NE.10*k(iju(2),2)+k(iju(1),2)) THEN   
        CALL luerrm(12,'(LUSTRF:) unphysical flavour combination')  
        IF(mstu(21).GE.1) RETURN    
      ENDIF 
    
C...Calculate (approximate) boost to rest frame of junction.    
      t12=(pju(1,1)*pju(2,1)+pju(1,2)*pju(2,2)+pju(1,3)*pju(2,3))/  
     &(pju(1,5)*pju(2,5))   
      t13=(pju(1,1)*pju(3,1)+pju(1,2)*pju(3,2)+pju(1,3)*pju(3,3))/  
     &(pju(1,5)*pju(3,5))   
      t23=(pju(2,1)*pju(3,1)+pju(2,2)*pju(3,2)+pju(2,3)*pju(3,3))/  
     &(pju(2,5)*pju(3,5))   
      t11=sqrt((2./3.)*(1.-t12)*(1.-t13)/(1.-t23))  
      t22=sqrt((2./3.)*(1.-t12)*(1.-t23)/(1.-t13))  
      tsq=sqrt((2.*t11*t22+t12-1.)*(1.+t12))    
      t1f=(tsq-t22*(1.+t12))/(1.-t12**2)    
      t2f=(tsq-t11*(1.+t12))/(1.-t12**2)    
      DO 220 j=1,3  
  220 tju(j)=-(t1f*pju(1,j)/pju(1,5)+t2f*pju(2,j)/pju(2,5)) 
      tju(4)=sqrt(1.+tju(1)**2+tju(2)**2+tju(3)**2) 
      DO 230 iu=1,3 
  230 pju(iu,5)=tju(4)*pju(iu,4)-tju(1)*pju(iu,1)-tju(2)*pju(iu,2)- 
     &tju(3)*pju(iu,3)  
    
C...Put junction at rest if motion could give inconsistencies.  
      IF(pju(1,5)+pju(2,5).GT.pju(1,4)+pju(2,4)) THEN   
        DO 240 j=1,3    
  240   tju(j)=0.   
        tju(4)=1.   
        pju(1,5)=pju(1,4)   
        pju(2,5)=pju(2,4)   
        pju(3,5)=pju(3,4)   
      ENDIF 
    
C...Start preparing for fragmentation of two strings from junction. 
      ista=i    
      DO 470 iu=1,2 
      ns=iju(iu+1)-iju(iu)  
    
C...Junction strings: find longitudinal string directions.  
      DO 260 is=1,ns    
      is1=iju(iu)+is-1  
      is2=iju(iu)+is    
      DO 250 j=1,5  
      dp(1,j)=0.5*p(is1,j)  
      IF(is.EQ.1) dp(1,j)=p(is1,j)  
      dp(2,j)=0.5*p(is2,j)  
  250 IF(is.EQ.ns) dp(2,j)=-pju(iu,j)   
      IF(is.EQ.ns) dp(2,4)=sqrt(pju(iu,1)**2+pju(iu,2)**2+pju(iu,3)**2) 
      IF(is.EQ.ns) dp(2,5)=0.   
      dp(3,5)=dfour(1,1)    
      dp(4,5)=dfour(2,2)    
      dhkc=dfour(1,2)   
      IF(dp(3,5)+2.*dhkc+dp(4,5).LE.0.) THEN    
        dp(1,4)=sqrt(dp(1,1)**2+dp(1,2)**2+dp(1,3)**2)  
        dp(2,4)=sqrt(dp(2,1)**2+dp(2,2)**2+dp(2,3)**2)  
        dp(3,5)=0d0 
        dp(4,5)=0d0 
        dhkc=dfour(1,2) 
      ENDIF 
      dhks=sqrt(dhkc**2-dp(3,5)*dp(4,5))    
      dhk1=0.5*((dp(4,5)+dhkc)/dhks-1.) 
      dhk2=0.5*((dp(3,5)+dhkc)/dhks-1.) 
      in1=n+nr+4*is-3   
      p(in1,5)=sqrt(dp(3,5)+2.*dhkc+dp(4,5))    
      DO 260 j=1,4  
      p(in1,j)=(1.+dhk1)*dp(1,j)-dhk2*dp(2,j)   
  260 p(in1+1,j)=(1.+dhk2)*dp(2,j)-dhk1*dp(1,j) 
    
C...Junction strings: initialize flavour, momentum and starting pos.    
      isav=i    
  270 ntry=ntry+1   
      IF(ntry.GT.100.AND.ntryr.LE.4) THEN   
        paru12=4.*paru12    
        paru13=2.*paru13    
        goto 130    
      ELSEIF(ntry.GT.100) THEN  
        CALL luerrm(14,'(LUSTRF:) caught in infinite loop') 
        IF(mstu(21).GE.1) RETURN    
      ENDIF 
      i=isav    
      irankj=0  
      ie(1)=k(n+1+(jt/2)*(np-1),3)  
      in(4)=n+nr+1  
      in(5)=in(4)+1 
      in(6)=n+nr+4*ns+1 
      DO 280 jq=1,2 
      DO 280 in1=n+nr+2+jq,n+nr+4*ns-2+jq,4 
      p(in1,1)=2-jq 
      p(in1,2)=jq-1 
  280 p(in1,3)=1.   
      kfl(1)=k(iju(iu),2)   
      px(1)=0.  
      py(1)=0.  
      gam(1)=0. 
      DO 290 j=1,5  
  290 pju(iu+3,j)=0.    
    
C...Junction strings: find initial transverse directions.   
      DO 300 j=1,4  
      dp(1,j)=p(in(4),j)    
      dp(2,j)=p(in(4)+1,j)  
      dp(3,j)=0.    
  300 dp(4,j)=0.    
      dp(1,4)=sqrt(dp(1,1)**2+dp(1,2)**2+dp(1,3)**2)    
      dp(2,4)=sqrt(dp(2,1)**2+dp(2,2)**2+dp(2,3)**2)    
      dp(5,1)=dp(1,1)/dp(1,4)-dp(2,1)/dp(2,4)   
      dp(5,2)=dp(1,2)/dp(1,4)-dp(2,2)/dp(2,4)   
      dp(5,3)=dp(1,3)/dp(1,4)-dp(2,3)/dp(2,4)   
      IF(dp(5,1)**2.LE.dp(5,2)**2+dp(5,3)**2) dp(3,1)=1.    
      IF(dp(5,1)**2.GT.dp(5,2)**2+dp(5,3)**2) dp(3,3)=1.    
      IF(dp(5,2)**2.LE.dp(5,1)**2+dp(5,3)**2) dp(4,2)=1.    
      IF(dp(5,2)**2.GT.dp(5,1)**2+dp(5,3)**2) dp(4,3)=1.    
      dhc12=dfour(1,2)  
      dhcx1=dfour(3,1)/dhc12    
      dhcx2=dfour(3,2)/dhc12    
      dhcxx=1d0/sqrt(1d0+2d0*dhcx1*dhcx2*dhc12) 
      dhcy1=dfour(4,1)/dhc12    
      dhcy2=dfour(4,2)/dhc12    
      dhcyx=dhcxx*(dhcx1*dhcy2+dhcx2*dhcy1)*dhc12   
      dhcyy=1d0/sqrt(1d0+2d0*dhcy1*dhcy2*dhc12-dhcyx**2)    
      DO 310 j=1,4  
      dp(3,j)=dhcxx*(dp(3,j)-dhcx2*dp(1,j)-dhcx1*dp(2,j))   
      p(in(6),j)=dp(3,j)    
  310 p(in(6)+1,j)=dhcyy*(dp(4,j)-dhcy2*dp(1,j)-dhcy1*dp(2,j)-  
     &dhcyx*dp(3,j))    
    
C...Junction strings: produce new particle, origin. 
  320 i=i+1 
      IF(2*i-nsav.GE.mstu(4)-mstu(32)-5) THEN   
        CALL luerrm(11,'(LUSTRF:) no more memory left in LUJETS')   
        IF(mstu(21).GE.1) RETURN    
      ENDIF 
      irankj=irankj+1   
      k(i,1)=1  
      k(i,3)=ie(1)  
      k(i,4)=0  
      k(i,5)=0  
    
C...Junction strings: generate flavour, hadron, pT, z and Gamma.    
  330 CALL lukfdi(kfl(1),0,kfl(3),k(i,2))   
      IF(k(i,2).EQ.0) goto 270  
      IF(mstj(12).GE.3.AND.irankj.EQ.1.AND.iabs(kfl(1)).LE.10.AND.  
     &iabs(kfl(3)).GT.10) THEN  
        IF(rlu(0).GT.parj(19)) goto 330 
      ENDIF 
      p(i,5)=ulmass(k(i,2)) 
      CALL luptdi(kfl(1),px(3),py(3))   
      pr(1)=p(i,5)**2+(px(1)+px(3))**2+(py(1)+py(3))**2 
      CALL luzdis(kfl(1),kfl(3),pr(1),z)    
      gam(3)=(1.-z)*(gam(1)+pr(1)/z)    
      DO 340 j=1,3  
  340 in(j)=in(3+j) 
    
C...Junction strings: stepping within or from 'low' string region easy. 
      IF(in(1)+1.EQ.in(2).AND.z*p(in(1)+2,3)*p(in(2)+2,3)*  
     &p(in(1),5)**2.GE.pr(1)) THEN  
        p(in(1)+2,4)=z*p(in(1)+2,3) 
        p(in(2)+2,4)=pr(1)/(p(in(1)+2,4)*p(in(1),5)**2) 
        DO 350 j=1,4    
  350   p(i,j)=(px(1)+px(3))*p(in(3),j)+(py(1)+py(3))*p(in(3)+1,j)  
        goto 420    
      ELSEIF(in(1)+1.EQ.in(2)) THEN 
        p(in(2)+2,4)=p(in(2)+2,3)   
        p(in(2)+2,1)=1. 
        in(2)=in(2)+4   
        IF(in(2).GT.n+nr+4*ns) goto 270 
        IF(four(in(1),in(2)).LE.1e-2) THEN  
          p(in(1)+2,4)=p(in(1)+2,3) 
          p(in(1)+2,1)=0.   
          in(1)=in(1)+4 
        ENDIF   
      ENDIF 
    
C...Junction strings: find new transverse directions.   
  360 IF(in(1).GT.n+nr+4*ns.OR.in(2).GT.n+nr+4*ns.OR.   
     &in(1).GT.in(2)) goto 270  
      IF(in(1).NE.in(4).OR.in(2).NE.in(5)) THEN 
        DO 370 j=1,4    
        dp(1,j)=p(in(1),j)  
        dp(2,j)=p(in(2),j)  
        dp(3,j)=0.  
  370   dp(4,j)=0.  
        dp(1,4)=sqrt(dp(1,1)**2+dp(1,2)**2+dp(1,3)**2)  
        dp(2,4)=sqrt(dp(2,1)**2+dp(2,2)**2+dp(2,3)**2)  
        dhc12=dfour(1,2)    
        IF(dhc12.LE.1e-2) THEN  
          p(in(1)+2,4)=p(in(1)+2,3) 
          p(in(1)+2,1)=0.   
          in(1)=in(1)+4 
          goto 360  
        ENDIF   
        in(3)=n+nr+4*ns+5   
        dp(5,1)=dp(1,1)/dp(1,4)-dp(2,1)/dp(2,4) 
        dp(5,2)=dp(1,2)/dp(1,4)-dp(2,2)/dp(2,4) 
        dp(5,3)=dp(1,3)/dp(1,4)-dp(2,3)/dp(2,4) 
        IF(dp(5,1)**2.LE.dp(5,2)**2+dp(5,3)**2) dp(3,1)=1.  
        IF(dp(5,1)**2.GT.dp(5,2)**2+dp(5,3)**2) dp(3,3)=1.  
        IF(dp(5,2)**2.LE.dp(5,1)**2+dp(5,3)**2) dp(4,2)=1.  
        IF(dp(5,2)**2.GT.dp(5,1)**2+dp(5,3)**2) dp(4,3)=1.  
        dhcx1=dfour(3,1)/dhc12  
        dhcx2=dfour(3,2)/dhc12  
        dhcxx=1d0/sqrt(1d0+2d0*dhcx1*dhcx2*dhc12)   
        dhcy1=dfour(4,1)/dhc12  
        dhcy2=dfour(4,2)/dhc12  
        dhcyx=dhcxx*(dhcx1*dhcy2+dhcx2*dhcy1)*dhc12 
        dhcyy=1d0/sqrt(1d0+2d0*dhcy1*dhcy2*dhc12-dhcyx**2)  
        DO 380 j=1,4    
        dp(3,j)=dhcxx*(dp(3,j)-dhcx2*dp(1,j)-dhcx1*dp(2,j)) 
        p(in(3),j)=dp(3,j)  
  380   p(in(3)+1,j)=dhcyy*(dp(4,j)-dhcy2*dp(1,j)-dhcy1*dp(2,j)-    
     &  dhcyx*dp(3,j))  
C...Express pT with respect to new axes, if sensible.   
        pxp=-(px(3)*four(in(6),in(3))+py(3)*four(in(6)+1,in(3)))    
        pyp=-(px(3)*four(in(6),in(3)+1)+py(3)*four(in(6)+1,in(3)+1))    
        IF(abs(pxp**2+pyp**2-px(3)**2-py(3)**2).LT.0.01) THEN   
          px(3)=pxp 
          py(3)=pyp 
        ENDIF   
      ENDIF 
    
C...Junction strings: sum up known four-momentum, coefficients for m2.  
      DO 400 j=1,4  
      dhg(j)=0. 
      p(i,j)=px(1)*p(in(6),j)+py(1)*p(in(6)+1,j)+px(3)*p(in(3),j)+  
     &py(3)*p(in(3)+1,j)    
      DO 390 in1=in(4),in(1)-4,4    
  390 p(i,j)=p(i,j)+p(in1+2,3)*p(in1,j) 
      DO 400 in2=in(5),in(2)-4,4    
  400 p(i,j)=p(i,j)+p(in2+2,3)*p(in2,j) 
      dhm(1)=four(i,i)  
      dhm(2)=2.*four(i,in(1))   
      dhm(3)=2.*four(i,in(2))   
      dhm(4)=2.*four(in(1),in(2))   
    
C...Junction strings: find coefficients for Gamma expression.   
      DO 410 in2=in(1)+1,in(2),4    
      DO 410 in1=in(1),in2-1,4  
      dhc=2.*four(in1,in2)  
      dhg(1)=dhg(1)+p(in1+2,1)*p(in2+2,1)*dhc   
      IF(in1.EQ.in(1)) dhg(2)=dhg(2)-p(in2+2,1)*dhc 
      IF(in2.EQ.in(2)) dhg(3)=dhg(3)+p(in1+2,1)*dhc 
  410 IF(in1.EQ.in(1).AND.in2.EQ.in(2)) dhg(4)=dhg(4)-dhc   
    
C...Junction strings: solve (m2, Gamma) equation system for energies.   
      dhs1=dhm(3)*dhg(4)-dhm(4)*dhg(3)  
      IF(abs(dhs1).LT.1e-4) goto 270    
      dhs2=dhm(4)*(gam(3)-dhg(1))-dhm(2)*dhg(3)-dhg(4)* 
     &(p(i,5)**2-dhm(1))+dhg(2)*dhm(3)  
      dhs3=dhm(2)*(gam(3)-dhg(1))-dhg(2)*(p(i,5)**2-dhm(1)) 
      p(in(2)+2,4)=0.5*(sqrt(max(0d0,dhs2**2-4.*dhs1*dhs3))/abs(dhs1)-  
     &dhs2/dhs1)    
      IF(dhm(2)+dhm(4)*p(in(2)+2,4).LE.0.) goto 270 
      p(in(1)+2,4)=(p(i,5)**2-dhm(1)-dhm(3)*p(in(2)+2,4))/  
     &(dhm(2)+dhm(4)*p(in(2)+2,4))  
    
C...Junction strings: step to new region if necessary.  
      IF(p(in(2)+2,4).GT.p(in(2)+2,3)) THEN 
        p(in(2)+2,4)=p(in(2)+2,3)   
        p(in(2)+2,1)=1. 
        in(2)=in(2)+4   
        IF(in(2).GT.n+nr+4*ns) goto 270 
        IF(four(in(1),in(2)).LE.1e-2) THEN  
          p(in(1)+2,4)=p(in(1)+2,3) 
          p(in(1)+2,1)=0.   
          in(1)=in(1)+4 
        ENDIF   
        goto 360    
      ELSEIF(p(in(1)+2,4).GT.p(in(1)+2,3)) THEN 
        p(in(1)+2,4)=p(in(1)+2,3)   
        p(in(1)+2,1)=0. 
        in(1)=in(1)+js  
        goto 710    
      ENDIF 
    
C...Junction strings: particle four-momentum, remainder, loop back. 
  420 DO 430 j=1,4  
      p(i,j)=p(i,j)+p(in(1)+2,4)*p(in(1),j)+p(in(2)+2,4)*p(in(2),j) 
  430 pju(iu+3,j)=pju(iu+3,j)+p(i,j)    
      IF(p(i,4).LE.0.) goto 270 
      pju(iu+3,5)=tju(4)*pju(iu+3,4)-tju(1)*pju(iu+3,1)-    
     &tju(2)*pju(iu+3,2)-tju(3)*pju(iu+3,3) 
      IF(pju(iu+3,5).LT.pju(iu,5)) THEN 
        kfl(1)=-kfl(3)  
        px(1)=-px(3)    
        py(1)=-py(3)    
        gam(1)=gam(3)   
        IF(in(3).NE.in(6)) THEN 
          DO 440 j=1,4  
          p(in(6),j)=p(in(3),j) 
  440     p(in(6)+1,j)=p(in(3)+1,j) 
        ENDIF   
        DO 450 jq=1,2   
        in(3+jq)=in(jq) 
        p(in(jq)+2,3)=p(in(jq)+2,3)-p(in(jq)+2,4)   
  450   p(in(jq)+2,1)=p(in(jq)+2,1)-(3-2*jq)*p(in(jq)+2,4)  
        goto 320    
      ENDIF 
    
C...Junction strings: save quantities left after each string.   
      IF(iabs(kfl(1)).GT.10) goto 270   
      i=i-1 
      kfjh(iu)=kfl(1)   
      DO 460 j=1,4  
  460 pju(iu+3,j)=pju(iu+3,j)-p(i+1,j)  
  470 CONTINUE  
    
C...Junction strings: put together to new effective string endpoint.    
      njs(jt)=i-ista    
      kfjs(jt)=k(k(mju(jt+2),3),2)  
      kfls=2*int(rlu(0)+3.*parj(4)/(1.+3.*parj(4)))+1   
      IF(kfjh(1).EQ.kfjh(2)) kfls=3 
      IF(ista.NE.i) kfjs(jt)=isign(1000*max(iabs(kfjh(1)),  
     &iabs(kfjh(2)))+100*min(iabs(kfjh(1)),iabs(kfjh(2)))+  
     &kfls,kfjh(1)) 
      DO 480 j=1,4  
      pjs(jt,j)=pju(1,j)+pju(2,j)+p(mju(jt),j)  
  480 pjs(jt+2,j)=pju(4,j)+pju(5,j) 
      pjs(jt,5)=sqrt(max(0.,pjs(jt,4)**2-pjs(jt,1)**2-pjs(jt,2)**2- 
     &pjs(jt,3)**2))    
  490 CONTINUE  
    
C...Open versus closed strings. Choose breakup region for latter.   
  500 IF(mju(1).NE.0.AND.mju(2).NE.0) THEN  
        ns=mju(2)-mju(1)    
        nb=mju(1)-n 
      ELSEIF(mju(1).NE.0) THEN  
        ns=n+nr-mju(1)  
        nb=mju(1)-n 
      ELSEIF(mju(2).NE.0) THEN  
        ns=mju(2)-n 
        nb=1    
      ELSEIF(iabs(k(n+1,2)).NE.21) THEN 
        ns=nr-1 
        nb=1    
      ELSE  
        ns=nr+1 
        w2sum=0.    
        DO 510 is=1,nr  
        p(n+nr+is,1)=0.5*four(n+is,n+is+1-nr*(is/nr))   
  510   w2sum=w2sum+p(n+nr+is,1)    
        w2ran=rlu(0)*w2sum  
        nb=0    
  520   nb=nb+1 
        w2sum=w2sum-p(n+nr+nb,1)    
        IF(w2sum.GT.w2ran.AND.nb.LT.nr) goto 520    
      ENDIF 
    
C...Find longitudinal string directions (i.e. lightlike four-vectors).  
      DO 540 is=1,ns    
      is1=n+is+nb-1-nr*((is+nb-2)/nr)   
      is2=n+is+nb-nr*((is+nb-1)/nr) 
      DO 530 j=1,5  
      dp(1,j)=p(is1,j)  
      IF(iabs(k(is1,2)).EQ.21) dp(1,j)=0.5*dp(1,j)  
      IF(is1.EQ.mju(1)) dp(1,j)=pjs(1,j)-pjs(3,j)   
      dp(2,j)=p(is2,j)  
      IF(iabs(k(is2,2)).EQ.21) dp(2,j)=0.5*dp(2,j)  
  530 IF(is2.EQ.mju(2)) dp(2,j)=pjs(2,j)-pjs(4,j)   
      dp(3,5)=dfour(1,1)    
      dp(4,5)=dfour(2,2)    
      dhkc=dfour(1,2)   
      IF(dp(3,5)+2.*dhkc+dp(4,5).LE.0.) THEN    
        dp(3,5)=dp(1,5)**2  
        dp(4,5)=dp(2,5)**2  
        dp(1,4)=sqrt(dp(1,1)**2+dp(1,2)**2+dp(1,3)**2+dp(1,5)**2)   
        dp(2,4)=sqrt(dp(2,1)**2+dp(2,2)**2+dp(2,3)**2+dp(2,5)**2)   
        dhkc=dfour(1,2) 
      ENDIF 
      dhks=sqrt(dhkc**2-dp(3,5)*dp(4,5))    
      dhk1=0.5*((dp(4,5)+dhkc)/dhks-1.) 
      dhk2=0.5*((dp(3,5)+dhkc)/dhks-1.) 
      in1=n+nr+4*is-3   
      p(in1,5)=sqrt(dp(3,5)+2.*dhkc+dp(4,5))    
      DO 540 j=1,4  
      p(in1,j)=(1.+dhk1)*dp(1,j)-dhk2*dp(2,j)   
  540 p(in1+1,j)=(1.+dhk2)*dp(2,j)-dhk1*dp(1,j) 
    
C...Begin initialization: sum up energy, set starting position. 
      isav=i    
  550 ntry=ntry+1   
      IF(ntry.GT.100.AND.ntryr.LE.4) THEN   
        paru12=4.*paru12    
        paru13=2.*paru13    
        goto 130    
      ELSEIF(ntry.GT.100) THEN  
        CALL luerrm(14,'(LUSTRF:) caught in infinite loop') 
        IF(mstu(21).GE.1) RETURN    
      ENDIF 
      i=isav    
      DO 560 j=1,4  
      p(n+nrs,j)=0. 
      DO 560 is=1,nr    
  560 p(n+nrs,j)=p(n+nrs,j)+p(n+is,j)   
      DO 570 jt=1,2 
      irank(jt)=0   
      IF(mju(jt).NE.0) irank(jt)=njs(jt)    
      IF(ns.GT.nr) irank(jt)=1  
      ie(jt)=k(n+1+(jt/2)*(np-1),3) 
      in(3*jt+1)=n+nr+1+4*(jt/2)*(ns-1) 
      in(3*jt+2)=in(3*jt+1)+1   
      in(3*jt+3)=n+nr+4*ns+2*jt-1   
      DO 570 in1=n+nr+2+jt,n+nr+4*ns-2+jt,4 
      p(in1,1)=2-jt 
      p(in1,2)=jt-1 
  570 p(in1,3)=1.   
    
C...Initialize flavour and pT variables for open string.    
      IF(ns.LT.nr) THEN 
        px(1)=0.    
        py(1)=0.    
        IF(ns.EQ.1.AND.mju(1)+mju(2).EQ.0) CALL luptdi(0,px(1),py(1))   
        px(2)=-px(1)    
        py(2)=-py(1)    
        DO 580 jt=1,2   
        kfl(jt)=k(ie(jt),2) 
        IF(mju(jt).NE.0) kfl(jt)=kfjs(jt)   
        mstj(93)=1  
        pmq(jt)=ulmass(kfl(jt)) 
  580   gam(jt)=0.  
    
C...Closed string: random initial breakup flavour, pT and vertex.   
      ELSE  
        kfl(3)=int(1.+(2.+parj(2))*rlu(0))*(-1)**int(rlu(0)+0.5)    
        CALL lukfdi(kfl(3),0,kfl(1),kdump)  
        kfl(2)=-kfl(1)  
        IF(iabs(kfl(1)).GT.10.AND.rlu(0).GT.0.5) THEN   
          kfl(2)=-(kfl(1)+isign(10000,kfl(1)))  
        ELSEIF(iabs(kfl(1)).GT.10) THEN 
          kfl(1)=-(kfl(2)+isign(10000,kfl(2)))  
        ENDIF   
        CALL luptdi(kfl(1),px(1),py(1)) 
        px(2)=-px(1)    
        py(2)=-py(1)    
        pr3=min(25.,0.1*p(n+nr+1,5)**2) 
  590   CALL luzdis(kfl(1),kfl(2),pr3,z)    
        zr=pr3/(z*p(n+nr+1,5)**2)   
        IF(zr.GE.1.) goto 590   
        DO 600 jt=1,2   
        mstj(93)=1  
        pmq(jt)=ulmass(kfl(jt)) 
        gam(jt)=pr3*(1.-z)/z    
        in1=n+nr+3+4*(jt/2)*(ns-1)  
        p(in1,jt)=1.-z  
        p(in1,3-jt)=jt-1    
        p(in1,3)=(2-jt)*(1.-z)+(jt-1)*z 
        p(in1+1,jt)=zr  
        p(in1+1,3-jt)=2-jt  
  600   p(in1+1,3)=(2-jt)*(1.-zr)+(jt-1)*zr 
      ENDIF 
    
C...Find initial transverse directions (i.e. spacelike four-vectors).   
      DO 640 jt=1,2 
      IF(jt.EQ.1.OR.ns.EQ.nr-1) THEN    
        in1=in(3*jt+1)  
        in3=in(3*jt+3)  
        DO 610 j=1,4    
        dp(1,j)=p(in1,j)    
        dp(2,j)=p(in1+1,j)  
        dp(3,j)=0.  
  610   dp(4,j)=0.  
        dp(1,4)=sqrt(dp(1,1)**2+dp(1,2)**2+dp(1,3)**2)  
        dp(2,4)=sqrt(dp(2,1)**2+dp(2,2)**2+dp(2,3)**2)  
        dp(5,1)=dp(1,1)/dp(1,4)-dp(2,1)/dp(2,4) 
        dp(5,2)=dp(1,2)/dp(1,4)-dp(2,2)/dp(2,4) 
        dp(5,3)=dp(1,3)/dp(1,4)-dp(2,3)/dp(2,4) 
        IF(dp(5,1)**2.LE.dp(5,2)**2+dp(5,3)**2) dp(3,1)=1.  
        IF(dp(5,1)**2.GT.dp(5,2)**2+dp(5,3)**2) dp(3,3)=1.  
        IF(dp(5,2)**2.LE.dp(5,1)**2+dp(5,3)**2) dp(4,2)=1.  
        IF(dp(5,2)**2.GT.dp(5,1)**2+dp(5,3)**2) dp(4,3)=1.  
        dhc12=dfour(1,2)    
        dhcx1=dfour(3,1)/dhc12  
        dhcx2=dfour(3,2)/dhc12  
        dhcxx=1d0/sqrt(1d0+2d0*dhcx1*dhcx2*dhc12)   
        dhcy1=dfour(4,1)/dhc12  
        dhcy2=dfour(4,2)/dhc12  
        dhcyx=dhcxx*(dhcx1*dhcy2+dhcx2*dhcy1)*dhc12 
        dhcyy=1d0/sqrt(1d0+2d0*dhcy1*dhcy2*dhc12-dhcyx**2)  
        DO 620 j=1,4    
        dp(3,j)=dhcxx*(dp(3,j)-dhcx2*dp(1,j)-dhcx1*dp(2,j)) 
        p(in3,j)=dp(3,j)    
  620   p(in3+1,j)=dhcyy*(dp(4,j)-dhcy2*dp(1,j)-dhcy1*dp(2,j)-  
     &  dhcyx*dp(3,j))  
      ELSE  
        DO 630 j=1,4    
        p(in3+2,j)=p(in3,j) 
  630   p(in3+3,j)=p(in3+1,j)   
      ENDIF 
  640 CONTINUE  
    
C...Remove energy used up in junction string fragmentation. 
      IF(mju(1)+mju(2).GT.0) THEN   
        DO 660 jt=1,2   
        IF(njs(jt).EQ.0) goto 660   
        DO 650 j=1,4    
  650   p(n+nrs,j)=p(n+nrs,j)-pjs(jt+2,j)   
  660   CONTINUE    
      ENDIF 
    
C...Produce new particle: side, origin. 
  670 i=i+1 
      IF(2*i-nsav.GE.mstu(4)-mstu(32)-5) THEN   
        CALL luerrm(11,'(LUSTRF:) no more memory left in LUJETS')   
        IF(mstu(21).GE.1) RETURN    
      ENDIF 
      jt=1.5+rlu(0) 
      IF(iabs(kfl(3-jt)).GT.10) jt=3-jt 
      jr=3-jt   
      js=3-2*jt 
      irank(jt)=irank(jt)+1 
      k(i,1)=1  
      k(i,3)=ie(jt) 
      k(i,4)=0  
      k(i,5)=0  
    
C...Generate flavour, hadron and pT.    
  680 CALL lukfdi(kfl(jt),0,kfl(3),k(i,2))  
      IF(k(i,2).EQ.0) goto 550  
      IF(mstj(12).GE.3.AND.irank(jt).EQ.1.AND.iabs(kfl(jt)).LE.10.AND.  
     &iabs(kfl(3)).GT.10) THEN  
        IF(rlu(0).GT.parj(19)) goto 680 
      ENDIF 
      p(i,5)=ulmass(k(i,2)) 
      CALL luptdi(kfl(jt),px(3),py(3))  
      pr(jt)=p(i,5)**2+(px(jt)+px(3))**2+(py(jt)+py(3))**2  
    
C...Final hadrons for small invariant mass. 
      mstj(93)=1    
      pmq(3)=ulmass(kfl(3)) 
      wmin=parj(32+mstj(11))+pmq(1)+pmq(2)+parj(36)*pmq(3)  
      IF(iabs(kfl(jt)).GT.10.AND.iabs(kfl(3)).GT.10) wmin=  
     &wmin-0.5*parj(36)*pmq(3)  
      wrem2=four(n+nrs,n+nrs)   
      IF(wrem2.LT.0.10) goto 550    
      IF(wrem2.LT.max(wmin*(1.+(2.*rlu(0)-1.)*parj(37)),    
     &parj(32)+pmq(1)+pmq(2))**2) goto 810  
    
C...Choose z, which gives Gamma. Shift z for heavy flavours.    
      CALL luzdis(kfl(jt),kfl(3),pr(jt),z)  
      kfl1a=iabs(kfl(1))    
      kfl2a=iabs(kfl(2))    
      IF(max(mod(kfl1a,10),mod(kfl1a/1000,10),mod(kfl2a,10),    
     &mod(kfl2a/1000,10)).GE.4) THEN    
        pr(jr)=(pmq(jr)+pmq(3))**2+(px(jr)-px(3))**2+(py(jr)-py(3))**2  
        pw12=sqrt(max(0.,(wrem2-pr(1)-pr(2))**2-4.*pr(1)*pr(2)))    
        z=(wrem2+pr(jt)-pr(jr)+pw12*(2.*z-1.))/(2.*wrem2)   
        pr(jr)=(pmq(jr)+parj(32+mstj(11)))**2+(px(jr)-px(3))**2+    
     &  (py(jr)-py(3))**2   
        IF((1.-z)*(wrem2-pr(jt)/z).LT.pr(jr)) goto 810  
      ENDIF 
      gam(3)=(1.-z)*(gam(jt)+pr(jt)/z)  
      DO 690 j=1,3  
  690 in(j)=in(3*jt+j)  
    
C...Stepping within or from 'low' string region easy.   
      IF(in(1)+1.EQ.in(2).AND.z*p(in(1)+2,3)*p(in(2)+2,3)*  
     &p(in(1),5)**2.GE.pr(jt)) THEN 
        p(in(jt)+2,4)=z*p(in(jt)+2,3)   
        p(in(jr)+2,4)=pr(jt)/(p(in(jt)+2,4)*p(in(1),5)**2)  
        DO 700 j=1,4    
  700   p(i,j)=(px(jt)+px(3))*p(in(3),j)+(py(jt)+py(3))*p(in(3)+1,j)    
        goto 770    
      ELSEIF(in(1)+1.EQ.in(2)) THEN 
        p(in(jr)+2,4)=p(in(jr)+2,3) 
        p(in(jr)+2,jt)=1.   
        in(jr)=in(jr)+4*js  
        IF(js*in(jr).GT.js*in(4*jr)) goto 550   
        IF(four(in(1),in(2)).LE.1e-2) THEN  
          p(in(jt)+2,4)=p(in(jt)+2,3)   
          p(in(jt)+2,jt)=0. 
          in(jt)=in(jt)+4*js    
        ENDIF   
      ENDIF 
    
C...Find new transverse directions (i.e. spacelike string vectors). 
  710 IF(js*in(1).GT.js*in(3*jr+1).OR.js*in(2).GT.js*in(3*jr+2).OR. 
     &in(1).GT.in(2)) goto 550  
      IF(in(1).NE.in(3*jt+1).OR.in(2).NE.in(3*jt+2)) THEN   
        DO 720 j=1,4    
        dp(1,j)=p(in(1),j)  
        dp(2,j)=p(in(2),j)  
        dp(3,j)=0.  
  720   dp(4,j)=0.  
        dp(1,4)=sqrt(dp(1,1)**2+dp(1,2)**2+dp(1,3)**2)  
        dp(2,4)=sqrt(dp(2,1)**2+dp(2,2)**2+dp(2,3)**2)  
        dhc12=dfour(1,2)    
        IF(dhc12.LE.1e-2) THEN  
          p(in(jt)+2,4)=p(in(jt)+2,3)   
          p(in(jt)+2,jt)=0. 
          in(jt)=in(jt)+4*js    
          goto 710  
        ENDIF   
        in(3)=n+nr+4*ns+5   
        dp(5,1)=dp(1,1)/dp(1,4)-dp(2,1)/dp(2,4) 
        dp(5,2)=dp(1,2)/dp(1,4)-dp(2,2)/dp(2,4) 
        dp(5,3)=dp(1,3)/dp(1,4)-dp(2,3)/dp(2,4) 
        IF(dp(5,1)**2.LE.dp(5,2)**2+dp(5,3)**2) dp(3,1)=1.  
        IF(dp(5,1)**2.GT.dp(5,2)**2+dp(5,3)**2) dp(3,3)=1.  
        IF(dp(5,2)**2.LE.dp(5,1)**2+dp(5,3)**2) dp(4,2)=1.  
        IF(dp(5,2)**2.GT.dp(5,1)**2+dp(5,3)**2) dp(4,3)=1.  
        dhcx1=dfour(3,1)/dhc12  
        dhcx2=dfour(3,2)/dhc12  
        dhcxx=1d0/sqrt(1d0+2d0*dhcx1*dhcx2*dhc12)   
        dhcy1=dfour(4,1)/dhc12  
        dhcy2=dfour(4,2)/dhc12  
        dhcyx=dhcxx*(dhcx1*dhcy2+dhcx2*dhcy1)*dhc12 
        dhcyy=1d0/sqrt(1d0+2d0*dhcy1*dhcy2*dhc12-dhcyx**2)  
        DO 730 j=1,4    
        dp(3,j)=dhcxx*(dp(3,j)-dhcx2*dp(1,j)-dhcx1*dp(2,j)) 
        p(in(3),j)=dp(3,j)  
  730   p(in(3)+1,j)=dhcyy*(dp(4,j)-dhcy2*dp(1,j)-dhcy1*dp(2,j)-    
     &  dhcyx*dp(3,j))  
C...Express pT with respect to new axes, if sensible.   
        pxp=-(px(3)*four(in(3*jt+3),in(3))+py(3)*   
     &  four(in(3*jt+3)+1,in(3)))   
        pyp=-(px(3)*four(in(3*jt+3),in(3)+1)+py(3)* 
     &  four(in(3*jt+3)+1,in(3)+1)) 
        IF(abs(pxp**2+pyp**2-px(3)**2-py(3)**2).LT.0.01) THEN   
          px(3)=pxp 
          py(3)=pyp 
        ENDIF   
      ENDIF 
    
C...Sum up known four-momentum. Gives coefficients for m2 expression.   
      DO 750 j=1,4  
      dhg(j)=0. 
      p(i,j)=px(jt)*p(in(3*jt+3),j)+py(jt)*p(in(3*jt+3)+1,j)+   
     &px(3)*p(in(3),j)+py(3)*p(in(3)+1,j)   
      DO 740 in1=in(3*jt+1),in(1)-4*js,4*js 
  740 p(i,j)=p(i,j)+p(in1+2,3)*p(in1,j) 
      DO 750 in2=in(3*jt+2),in(2)-4*js,4*js 
  750 p(i,j)=p(i,j)+p(in2+2,3)*p(in2,j) 
      dhm(1)=four(i,i)  
      dhm(2)=2.*four(i,in(1))   
      dhm(3)=2.*four(i,in(2))   
      dhm(4)=2.*four(in(1),in(2))   
    
C...Find coefficients for Gamma expression. 
      DO 760 in2=in(1)+1,in(2),4    
      DO 760 in1=in(1),in2-1,4  
      dhc=2.*four(in1,in2)  
      dhg(1)=dhg(1)+p(in1+2,jt)*p(in2+2,jt)*dhc 
      IF(in1.EQ.in(1)) dhg(2)=dhg(2)-js*p(in2+2,jt)*dhc 
      IF(in2.EQ.in(2)) dhg(3)=dhg(3)+js*p(in1+2,jt)*dhc 
  760 IF(in1.EQ.in(1).AND.in2.EQ.in(2)) dhg(4)=dhg(4)-dhc   
    
C...Solve (m2, Gamma) equation system for energies taken.   
      dhs1=dhm(jr+1)*dhg(4)-dhm(4)*dhg(jr+1)    
      IF(abs(dhs1).LT.1e-4) goto 550    
      dhs2=dhm(4)*(gam(3)-dhg(1))-dhm(jt+1)*dhg(jr+1)-dhg(4)*   
     &(p(i,5)**2-dhm(1))+dhg(jt+1)*dhm(jr+1)    
      dhs3=dhm(jt+1)*(gam(3)-dhg(1))-dhg(jt+1)*(p(i,5)**2-dhm(1))   
      p(in(jr)+2,4)=0.5*(sqrt(max(0d0,dhs2**2-4.*dhs1*dhs3))/abs(dhs1)- 
     &dhs2/dhs1)    
      IF(dhm(jt+1)+dhm(4)*p(in(jr)+2,4).LE.0.) goto 550 
      p(in(jt)+2,4)=(p(i,5)**2-dhm(1)-dhm(jr+1)*p(in(jr)+2,4))/ 
     &(dhm(jt+1)+dhm(4)*p(in(jr)+2,4))  
    
C...Step to new region if necessary.    
      IF(p(in(jr)+2,4).GT.p(in(jr)+2,3)) THEN   
        p(in(jr)+2,4)=p(in(jr)+2,3) 
        p(in(jr)+2,jt)=1.   
        in(jr)=in(jr)+4*js  
        IF(js*in(jr).GT.js*in(4*jr)) goto 550   
        IF(four(in(1),in(2)).LE.1e-2) THEN  
          p(in(jt)+2,4)=p(in(jt)+2,3)   
          p(in(jt)+2,jt)=0. 
          in(jt)=in(jt)+4*js    
        ENDIF   
        goto 710    
      ELSEIF(p(in(jt)+2,4).GT.p(in(jt)+2,3)) THEN   
        p(in(jt)+2,4)=p(in(jt)+2,3) 
        p(in(jt)+2,jt)=0.   
        in(jt)=in(jt)+4*js  
        goto 710    
      ENDIF 
    
C...Four-momentum of particle. Remaining quantities. Loop back. 
  770 DO 780 j=1,4  
      p(i,j)=p(i,j)+p(in(1)+2,4)*p(in(1),j)+p(in(2)+2,4)*p(in(2),j) 
  780 p(n+nrs,j)=p(n+nrs,j)-p(i,j)  
      IF(p(i,4).LE.0.) goto 550 
      kfl(jt)=-kfl(3)   
      pmq(jt)=pmq(3)    
      px(jt)=-px(3) 
      py(jt)=-py(3) 
      gam(jt)=gam(3)    
      IF(in(3).NE.in(3*jt+3)) THEN  
        DO 790 j=1,4    
        p(in(3*jt+3),j)=p(in(3),j)  
  790   p(in(3*jt+3)+1,j)=p(in(3)+1,j)  
      ENDIF 
      DO 800 jq=1,2 
      in(3*jt+jq)=in(jq)    
      p(in(jq)+2,3)=p(in(jq)+2,3)-p(in(jq)+2,4) 
  800 p(in(jq)+2,jt)=p(in(jq)+2,jt)-js*(3-2*jq)*p(in(jq)+2,4)   
      goto 670  
    
C...Final hadron: side, flavour, hadron, mass.  
  810 i=i+1 
      k(i,1)=1  
      k(i,3)=ie(jr) 
      k(i,4)=0  
      k(i,5)=0  
      CALL lukfdi(kfl(jr),-kfl(3),kfldmp,k(i,2))    
      IF(k(i,2).EQ.0) goto 550  
      p(i,5)=ulmass(k(i,2)) 
      pr(jr)=p(i,5)**2+(px(jr)-px(3))**2+(py(jr)-py(3))**2  
    
C...Final two hadrons: find common setup of four-vectors.   
      jq=1  
      IF(p(in(4)+2,3)*p(in(5)+2,3)*four(in(4),in(5)).LT.p(in(7),3)* 
     &p(in(8),3)*four(in(7),in(8))) jq=2    
      dhc12=four(in(3*jq+1),in(3*jq+2)) 
      dhr1=four(n+nrs,in(3*jq+2))/dhc12 
      dhr2=four(n+nrs,in(3*jq+1))/dhc12 
      IF(in(4).NE.in(7).OR.in(5).NE.in(8)) THEN 
        px(3-jq)=-four(n+nrs,in(3*jq+3))-px(jq) 
        py(3-jq)=-four(n+nrs,in(3*jq+3)+1)-py(jq)   
        pr(3-jq)=p(i+(jt+jq-3)**2-1,5)**2+(px(3-jq)+(2*jq-3)*js*    
     &  px(3))**2+(py(3-jq)+(2*jq-3)*js*py(3))**2   
      ENDIF 
    
C...Solve kinematics for final two hadrons, if possible.    
      wrem2=wrem2+(px(1)+px(2))**2+(py(1)+py(2))**2 
      fd=(sqrt(pr(1))+sqrt(pr(2)))/sqrt(wrem2)  
      IF(mju(1)+mju(2).NE.0.AND.i.EQ.isav+2.AND.fd.GE.1.) goto 180  
      IF(fd.GE.1.) goto 550 
      fa=wrem2+pr(jt)-pr(jr)    
      IF(mstj(11).EQ.2) prev=0.5*fd**parj(37+mstj(11))  
      IF(mstj(11).NE.2) prev=0.5*exp(max(-100.,log(fd)* 
     &parj(37+mstj(11))*(pr(1)+pr(2))**2))  
      fb=sign(sqrt(max(0.,fa**2-4.*wrem2*pr(jt))),js*(rlu(0)-prev)) 
      kfl1a=iabs(kfl(1))    
      kfl2a=iabs(kfl(2))    
      IF(max(mod(kfl1a,10),mod(kfl1a/1000,10),mod(kfl2a,10),    
     &mod(kfl2a/1000,10)).GE.6) fb=sign(sqrt(max(0.,fa**2-  
     &4.*wrem2*pr(jt))),float(js))  
      DO 820 j=1,4  
      p(i-1,j)=(px(jt)+px(3))*p(in(3*jq+3),j)+(py(jt)+py(3))*   
     &p(in(3*jq+3)+1,j)+0.5*(dhr1*(fa+fb)*p(in(3*jq+1),j)+  
     &dhr2*(fa-fb)*p(in(3*jq+2),j))/wrem2   
  820 p(i,j)=p(n+nrs,j)-p(i-1,j)    
    
C...Mark jets as fragmented and give daughter pointers. 
      n=i-nrs+1 
      DO 830 i=nsav+1,nsav+np   
      im=k(i,3) 
      k(im,1)=k(im,1)+10    
      IF(mstu(16).NE.2) THEN    
        k(im,4)=nsav+1  
        k(im,5)=nsav+1  
      ELSE  
        k(im,4)=nsav+2  
        k(im,5)=n   
      ENDIF 
  830 CONTINUE  
    
C...Document string system. Move up particles.  
      nsav=nsav+1   
      k(nsav,1)=11  
      k(nsav,2)=92  
      k(nsav,3)=ip  
      k(nsav,4)=nsav+1  
      k(nsav,5)=n   
      DO 840 j=1,4  
      p(nsav,j)=dps(j)  
  840 v(nsav,j)=v(ip,j) 
      p(nsav,5)=sqrt(max(0d0,dps(4)**2-dps(1)**2-dps(2)**2-dps(3)**2))  
      v(nsav,5)=0.  
      DO 850 i=nsav+1,n 
      DO 850 j=1,5  
      k(i,j)=k(i+nrs-1,j)   
      p(i,j)=p(i+nrs-1,j)   
  850 v(i,j)=0. 
    
C...Order particles in rank along the chain. Update mother pointer. 
      DO 860 i=nsav+1,n 
      DO 860 j=1,5  
      k(i-nsav+n,j)=k(i,j)  
  860 p(i-nsav+n,j)=p(i,j)  
      i1=nsav   
      DO 880 i=n+1,2*n-nsav 
      IF(k(i,3).NE.ie(1)) goto 880  
      i1=i1+1   
      DO 870 j=1,5  
      k(i1,j)=k(i,j)    
  870 p(i1,j)=p(i,j)    
      IF(mstu(16).NE.2) k(i1,3)=nsav    
  880 CONTINUE  
      DO 900 i=2*n-nsav,n+1,-1  
      IF(k(i,3).EQ.ie(1)) goto 900  
      i1=i1+1   
      DO 890 j=1,5  
      k(i1,j)=k(i,j)    
  890 p(i1,j)=p(i,j)    
      IF(mstu(16).NE.2) k(i1,3)=nsav    
  900 CONTINUE  
    
C...Boost back particle system. Set production vertices.    
      CALL ludbrb(nsav+1,n,0.,0.,dps(1)/dps(4),dps(2)/dps(4),   
     &dps(3)/dps(4))    
      DO 910 i=nsav+1,n 
      DO 910 j=1,4  
  910 v(i,j)=v(ip,j)    
    
      RETURN    
      END   
    
C*********************************************************************  
    
      SUBROUTINE luindf(IP) 
    
C...Purpose: to handle the fragmentation of a jet system (or a single   
C...jet) according to independent fragmentation models. 
      IMPLICIT DOUBLE PRECISION(d)  
      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/ludat2/kchg(500,3),pmas(500,4),parf(2000),vckm(4,4)    
      SAVE /ludat2/ 
      dimension dps(5),psi(4),nfi(3),nfl(3),ifet(3),kflf(3),    
     &kflo(2),pxo(2),pyo(2),wo(2)   
    
C...Reset counters. Identify parton system and take copy. Check flavour.    
      nsav=n    
      njet=0    
      kqsum=0   
      DO 100 j=1,5  
  100 dps(j)=0. 
      i=ip-1    
  110 i=i+1 
      IF(i.GT.min(n,mstu(4)-mstu(32))) THEN 
        CALL luerrm(12,'(LUINDF:) failed to reconstruct jet system')    
        IF(mstu(21).GE.1) RETURN    
      ENDIF 
      IF(k(i,1).NE.1.AND.k(i,1).NE.2) goto 110  
      kc=lucomp(k(i,2)) 
      IF(kc.EQ.0) goto 110  
      kq=kchg(kc,2)*isign(1,k(i,2)) 
      IF(kq.EQ.0) goto 110  
      njet=njet+1   
      IF(kq.NE.2) kqsum=kqsum+kq    
      DO 120 j=1,5  
      k(nsav+njet,j)=k(i,j) 
      p(nsav+njet,j)=p(i,j) 
  120 dps(j)=dps(j)+p(i,j)  
      k(nsav+njet,3)=i  
      IF(k(i,1).EQ.2.OR.(mstj(3).LE.5.AND.n.GT.i.AND.   
     &k(i+1,1).EQ.2)) goto 110  
      IF(njet.NE.1.AND.kqsum.NE.0) THEN 
        CALL luerrm(12,'(LUINDF:) unphysical flavour combination')  
        IF(mstu(21).GE.1) RETURN    
      ENDIF 
    
C...Boost copied system to CM frame. Find CM energy and sum flavours.   
      IF(njet.NE.1) CALL ludbrb(nsav+1,nsav+njet,0.,0.,-dps(1)/dps(4),  
     &-dps(2)/dps(4),-dps(3)/dps(4))    
      pecm=0.   
      DO 130 j=1,3  
  130 nfi(j)=0  
      DO 140 i=nsav+1,nsav+njet 
      pecm=pecm+p(i,4)  
      kfa=iabs(k(i,2))  
      IF(kfa.LE.3) THEN 
        nfi(kfa)=nfi(kfa)+isign(1,k(i,2))   
      ELSEIF(kfa.GT.1000) THEN  
        kfla=mod(kfa/1000,10)   
        kflb=mod(kfa/100,10)    
        IF(kfla.LE.3) nfi(kfla)=nfi(kfla)+isign(1,k(i,2))   
        IF(kflb.LE.3) nfi(kflb)=nfi(kflb)+isign(1,k(i,2))   
      ENDIF 
  140 CONTINUE  
    
C...Loop over attempts made. Reset counters.    
      ntry=0    
  150 ntry=ntry+1   
      n=nsav+njet   
      IF(ntry.GT.200) THEN  
        CALL luerrm(14,'(LUINDF:) caught in infinite loop') 
        IF(mstu(21).GE.1) RETURN    
      ENDIF 
      DO 160 j=1,3  
      nfl(j)=nfi(j) 
      ifet(j)=0 
  160 kflf(j)=0 
    
C...Loop over jets to be fragmented.    
      DO 230 ip1=nsav+1,nsav+njet   
      mstj(91)=0    
      nsav1=n   
    
C...Initial flavour and momentum values. Jet along +z axis. 
      kflh=iabs(k(ip1,2))   
      IF(kflh.GT.10) kflh=mod(kflh/1000,10) 
      kflo(2)=0 
      wf=p(ip1,4)+sqrt(p(ip1,1)**2+p(ip1,2)**2+p(ip1,3)**2) 
    
C...Initial values for quark or diquark jet.    
  170 IF(iabs(k(ip1,2)).NE.21) THEN 
        nstr=1  
        kflo(1)=k(ip1,2)    
        CALL luptdi(0,pxo(1),pyo(1))    
        wo(1)=wf    
    
C...Initial values for gluon treated like random quark jet. 
      ELSEIF(mstj(2).LE.2) THEN 
        nstr=1  
        IF(mstj(2).EQ.2) mstj(91)=1 
        kflo(1)=int(1.+(2.+parj(2))*rlu(0))*(-1)**int(rlu(0)+0.5)   
        CALL luptdi(0,pxo(1),pyo(1))    
        wo(1)=wf    
    
C...Initial values for gluon treated like quark-antiquark jet pair, 
C...sharing energy according to Altarelli-Parisi splitting function.    
      ELSE  
        nstr=2  
        IF(mstj(2).EQ.4) mstj(91)=1 
        kflo(1)=int(1.+(2.+parj(2))*rlu(0))*(-1)**int(rlu(0)+0.5)   
        kflo(2)=-kflo(1)    
        CALL luptdi(0,pxo(1),pyo(1))    
        pxo(2)=-pxo(1)  
        pyo(2)=-pyo(1)  
        wo(1)=wf*rlu(0)**(1./3.)    
        wo(2)=wf-wo(1)  
      ENDIF 
    
C...Initial values for rank, flavour, pT and W+.    
      DO 220 istr=1,nstr    
  180 i=n   
      irank=0   
      kfl1=kflo(istr)   
      px1=pxo(istr) 
      py1=pyo(istr) 
      w=wo(istr)    
    
C...New hadron. Generate flavour and hadron species.    
  190 i=i+1 
      IF(i.GE.mstu(4)-mstu(32)-njet-5) THEN 
        CALL luerrm(11,'(LUINDF:) no more memory left in LUJETS')   
        IF(mstu(21).GE.1) RETURN    
      ENDIF 
      irank=irank+1 
      k(i,1)=1  
      k(i,3)=ip1    
      k(i,4)=0  
      k(i,5)=0  
  200 CALL lukfdi(kfl1,0,kfl2,k(i,2))   
      IF(k(i,2).EQ.0) goto 180  
      IF(mstj(12).GE.3.AND.irank.EQ.1.AND.iabs(kfl1).LE.10.AND. 
     &iabs(kfl2).GT.10) THEN    
        IF(rlu(0).GT.parj(19)) goto 200 
      ENDIF 
    
C...Find hadron mass. Generate four-momentum.   
      p(i,5)=ulmass(k(i,2)) 
      CALL luptdi(kfl1,px2,py2) 
      p(i,1)=px1+px2    
      p(i,2)=py1+py2    
      pr=p(i,5)**2+p(i,1)**2+p(i,2)**2  
      CALL luzdis(kfl1,kfl2,pr,z)   
      p(i,3)=0.5*(z*w-pr/(z*w)) 
      p(i,4)=0.5*(z*w+pr/(z*w)) 
      IF(mstj(3).GE.1.AND.irank.EQ.1.AND.kflh.GE.4.AND. 
     &p(i,3).LE.0.001) THEN 
        IF(w.GE.p(i,5)+0.5*parj(32)) goto 180   
        p(i,3)=0.0001   
        p(i,4)=sqrt(pr) 
        z=p(i,4)/w  
      ENDIF 
    
C...Remaining flavour and momentum. 
      kfl1=-kfl2    
      px1=-px2  
      py1=-py2  
      w=(1.-z)*w    
      DO 210 j=1,5  
  210 v(i,j)=0. 
    
C...Check if pL acceptable. Go back for new hadron if enough energy.    
      IF(mstj(3).GE.0.AND.p(i,3).LT.0.) i=i-1   
      IF(w.GT.parj(31)) goto 190    
  220 n=i   
      IF(mod(mstj(3),5).EQ.4.AND.n.EQ.nsav1) wf=wf+0.1*parj(32) 
      IF(mod(mstj(3),5).EQ.4.AND.n.EQ.nsav1) goto 170   
    
C...Rotate jet to new direction.    
      the=ulangl(p(ip1,3),sqrt(p(ip1,1)**2+p(ip1,2)**2))    
      phi=ulangl(p(ip1,1),p(ip1,2)) 
      CALL ludbrb(nsav1+1,n,the,phi,0d0,0d0,0d0)    
      k(k(ip1,3),4)=nsav1+1 
      k(k(ip1,3),5)=n   
    
C...End of jet generation loop. Skip conservation in some cases.    
  230 CONTINUE  
      IF(njet.EQ.1.OR.mstj(3).LE.0) goto 470    
      IF(mod(mstj(3),5).NE.0.AND.n-nsav-njet.LT.2) goto 150 
    
C...Subtract off produced hadron flavours, finished if zero.    
      DO 240 i=nsav+njet+1,n    
      kfa=iabs(k(i,2))  
      kfla=mod(kfa/1000,10) 
      kflb=mod(kfa/100,10)  
      kflc=mod(kfa/10,10)   
      IF(kfla.EQ.0) THEN    
        IF(kflb.LE.3) nfl(kflb)=nfl(kflb)-isign(1,k(i,2))*(-1)**kflb    
        IF(kflc.LE.3) nfl(kflc)=nfl(kflc)+isign(1,k(i,2))*(-1)**kflb    
      ELSE  
        IF(kfla.LE.3) nfl(kfla)=nfl(kfla)-isign(1,k(i,2))   
        IF(kflb.LE.3) nfl(kflb)=nfl(kflb)-isign(1,k(i,2))   
        IF(kflc.LE.3) nfl(kflc)=nfl(kflc)-isign(1,k(i,2))   
      ENDIF 
  240 CONTINUE  
      nreq=(iabs(nfl(1))+iabs(nfl(2))+iabs(nfl(3))-iabs(nfl(1)+ 
     &nfl(2)+nfl(3)))/2+iabs(nfl(1)+nfl(2)+nfl(3))/3    
      IF(nreq.EQ.0) goto 320    
    
C...Take away flavour of low-momentum particles until enough freedom.   
      nrem=0    
  250 irem=0    
      p2min=pecm**2 
      DO 260 i=nsav+njet+1,n    
      p2=p(i,1)**2+p(i,2)**2+p(i,3)**2  
      IF(k(i,1).EQ.1.AND.p2.LT.p2min) irem=i    
  260 IF(k(i,1).EQ.1.AND.p2.LT.p2min) p2min=p2  
      IF(irem.EQ.0) goto 150    
      k(irem,1)=7   
      kfa=iabs(k(irem,2))   
      kfla=mod(kfa/1000,10) 
      kflb=mod(kfa/100,10)  
      kflc=mod(kfa/10,10)   
      IF(kfla.GE.4.OR.kflb.GE.4) k(irem,1)=8    
      IF(k(irem,1).EQ.8) goto 250   
      IF(kfla.EQ.0) THEN    
        isgn=isign(1,k(irem,2))*(-1)**kflb  
        IF(kflb.LE.3) nfl(kflb)=nfl(kflb)+isgn  
        IF(kflc.LE.3) nfl(kflc)=nfl(kflc)-isgn  
      ELSE  
        IF(kfla.LE.3) nfl(kfla)=nfl(kfla)+isign(1,k(irem,2))    
        IF(kflb.LE.3) nfl(kflb)=nfl(kflb)+isign(1,k(irem,2))    
        IF(kflc.LE.3) nfl(kflc)=nfl(kflc)+isign(1,k(irem,2))    
      ENDIF 
      nrem=nrem+1   
      nreq=(iabs(nfl(1))+iabs(nfl(2))+iabs(nfl(3))-iabs(nfl(1)+ 
     &nfl(2)+nfl(3)))/2+iabs(nfl(1)+nfl(2)+nfl(3))/3    
      IF(nreq.GT.nrem) goto 250 
      DO 270 i=nsav+njet+1,n    
  270 IF(k(i,1).EQ.8) k(i,1)=1  
    
C...Find combination of existing and new flavours for hadron.   
  280 nfet=2    
      IF(nfl(1)+nfl(2)+nfl(3).NE.0) nfet=3  
      IF(nreq.LT.nrem) nfet=1   
      IF(iabs(nfl(1))+iabs(nfl(2))+iabs(nfl(3)).EQ.0) nfet=0    
      DO 290 j=1,nfet   
      ifet(j)=1+(iabs(nfl(1))+iabs(nfl(2))+iabs(nfl(3)))*rlu(0) 
      kflf(j)=isign(1,nfl(1))   
      IF(ifet(j).GT.iabs(nfl(1))) kflf(j)=isign(2,nfl(2))   
  290 IF(ifet(j).GT.iabs(nfl(1))+iabs(nfl(2))) kflf(j)=isign(3,nfl(3))  
      IF(nfet.EQ.2.AND.(ifet(1).EQ.ifet(2).OR.kflf(1)*kflf(2).GT.0))    
     &goto 280  
      IF(nfet.EQ.3.AND.(ifet(1).EQ.ifet(2).OR.ifet(1).EQ.ifet(3).OR.    
     &ifet(2).EQ.ifet(3).OR.kflf(1)*kflf(2).LT.0.OR.kflf(1)*kflf(3).    
     &lt.0.OR.kflf(1)*(nfl(1)+nfl(2)+nfl(3)).LT.0)) goto 280    
      IF(nfet.EQ.0) kflf(1)=1+int((2.+parj(2))*rlu(0))  
      IF(nfet.EQ.0) kflf(2)=-kflf(1)    
      IF(nfet.EQ.1) kflf(2)=isign(1+int((2.+parj(2))*rlu(0)),-kflf(1))  
      IF(nfet.LE.2) kflf(3)=0   
      IF(kflf(3).NE.0) THEN 
        kflfc=isign(1000*max(iabs(kflf(1)),iabs(kflf(3)))+  
     &  100*min(iabs(kflf(1)),iabs(kflf(3)))+1,kflf(1)) 
        IF(kflf(1).EQ.kflf(3).OR.(1.+3.*parj(4))*rlu(0).GT.1.)  
     &  kflfc=kflfc+isign(2,kflfc)  
      ELSE  
        kflfc=kflf(1)   
      ENDIF 
      CALL lukfdi(kflfc,kflf(2),kfldmp,kf)  
      IF(kf.EQ.0) goto 280  
      DO 300 j=1,max(2,nfet)    
  300 nfl(iabs(kflf(j)))=nfl(iabs(kflf(j)))-isign(1,kflf(j))    
    
C...Store hadron at random among free positions.    
      npos=min(1+int(rlu(0)*nrem),nrem) 
      DO 310 i=nsav+njet+1,n    
      IF(k(i,1).EQ.7) npos=npos-1   
      IF(k(i,1).EQ.1.OR.npos.NE.0) goto 310 
      k(i,1)=1  
      k(i,2)=kf 
      p(i,5)=ulmass(k(i,2)) 
      p(i,4)=sqrt(p(i,1)**2+p(i,2)**2+p(i,3)**2+p(i,5)**2)  
  310 CONTINUE  
      nrem=nrem-1   
      nreq=(iabs(nfl(1))+iabs(nfl(2))+iabs(nfl(3))-iabs(nfl(1)+ 
     &nfl(2)+nfl(3)))/2+iabs(nfl(1)+nfl(2)+nfl(3))/3    
      IF(nrem.GT.0) goto 280    
    
C...Compensate for missing momentum in global scheme (3 options).   
  320 IF(mod(mstj(3),5).NE.0.AND.mod(mstj(3),5).NE.4) THEN  
        DO 330 j=1,3    
        psi(j)=0.   
        DO 330 i=nsav+njet+1,n  
  330   psi(j)=psi(j)+p(i,j)    
        psi(4)=psi(1)**2+psi(2)**2+psi(3)**2    
        pws=0.  
        DO 340 i=nsav+njet+1,n  
        IF(mod(mstj(3),5).EQ.1) pws=pws+p(i,4)  
        IF(mod(mstj(3),5).EQ.2) pws=pws+sqrt(p(i,5)**2+(psi(1)*p(i,1)+  
     &  psi(2)*p(i,2)+psi(3)*p(i,3))**2/psi(4)) 
  340   IF(mod(mstj(3),5).EQ.3) pws=pws+1.  
        DO 360 i=nsav+njet+1,n  
        IF(mod(mstj(3),5).EQ.1) pw=p(i,4)   
        IF(mod(mstj(3),5).EQ.2) pw=sqrt(p(i,5)**2+(psi(1)*p(i,1)+   
     &  psi(2)*p(i,2)+psi(3)*p(i,3))**2/psi(4)) 
        IF(mod(mstj(3),5).EQ.3) pw=1.   
        DO 350 j=1,3    
  350   p(i,j)=p(i,j)-psi(j)*pw/pws 
  360   p(i,4)=sqrt(p(i,1)**2+p(i,2)**2+p(i,3)**2+p(i,5)**2)    
    
C...Compensate for missing momentum withing each jet separately.    
      ELSEIF(mod(mstj(3),5).EQ.4) THEN  
        DO 370 i=n+1,n+njet 
        k(i,1)=0    
        DO 370 j=1,5    
  370   p(i,j)=0.   
        DO 390 i=nsav+njet+1,n  
        ir1=k(i,3)  
        ir2=n+ir1-nsav  
        k(ir2,1)=k(ir2,1)+1 
        pls=(p(i,1)*p(ir1,1)+p(i,2)*p(ir1,2)+p(i,3)*p(ir1,3))/  
     &  (p(ir1,1)**2+p(ir1,2)**2+p(ir1,3)**2)   
        DO 380 j=1,3    
  380   p(ir2,j)=p(ir2,j)+p(i,j)-pls*p(ir1,j)   
        p(ir2,4)=p(ir2,4)+p(i,4)    
  390   p(ir2,5)=p(ir2,5)+pls   
        pss=0.  
        DO 400 i=n+1,n+njet 
  400   IF(k(i,1).NE.0) pss=pss+p(i,4)/(pecm*(0.8*p(i,5)+0.2))  
        DO 420 i=nsav+njet+1,n  
        ir1=k(i,3)  
        ir2=n+ir1-nsav  
        pls=(p(i,1)*p(ir1,1)+p(i,2)*p(ir1,2)+p(i,3)*p(ir1,3))/  
     &  (p(ir1,1)**2+p(ir1,2)**2+p(ir1,3)**2)   
        DO 410 j=1,3    
  410   p(i,j)=p(i,j)-p(ir2,j)/k(ir2,1)+(1./(p(ir2,5)*pss)-1.)*pls* 
     &  p(ir1,j)    
  420   p(i,4)=sqrt(p(i,1)**2+p(i,2)**2+p(i,3)**2+p(i,5)**2)    
      ENDIF 
    
C...Scale momenta for energy conservation.  
      IF(mod(mstj(3),5).NE.0) THEN  
        pms=0.  
        pes=0.  
        pqs=0.  
        DO 430 i=nsav+njet+1,n  
        pms=pms+p(i,5)  
        pes=pes+p(i,4)  
  430   pqs=pqs+p(i,5)**2/p(i,4)    
        IF(pms.GE.pecm) goto 150    
        neco=0  
  440   neco=neco+1 
        pfac=(pecm-pqs)/(pes-pqs)   
        pes=0.  
        pqs=0.  
        DO 460 i=nsav+njet+1,n  
        DO 450 j=1,3    
  450   p(i,j)=pfac*p(i,j)  
        p(i,4)=sqrt(p(i,1)**2+p(i,2)**2+p(i,3)**2+p(i,5)**2)    
        pes=pes+p(i,4)  
  460   pqs=pqs+p(i,5)**2/p(i,4)    
        IF(neco.LT.10.AND.abs(pecm-pes).GT.2e-6*pecm) goto 440  
      ENDIF 
    
C...Origin of produced particles and parton daughter pointers.  
  470 DO 480 i=nsav+njet+1,n    
      IF(mstu(16).NE.2) k(i,3)=nsav+1   
  480 IF(mstu(16).EQ.2) k(i,3)=k(k(i,3),3)  
      DO 490 i=nsav+1,nsav+njet 
      i1=k(i,3) 
      k(i1,1)=k(i1,1)+10    
      IF(mstu(16).NE.2) THEN    
        k(i1,4)=nsav+1  
        k(i1,5)=nsav+1  
      ELSE  
        k(i1,4)=k(i1,4)-njet+1  
        k(i1,5)=k(i1,5)-njet+1  
        IF(k(i1,5).LT.k(i1,4)) THEN 
          k(i1,4)=0 
          k(i1,5)=0 
        ENDIF   
      ENDIF 
  490 CONTINUE  
    
C...Document independent fragmentation system. Remove copy of jets. 
      nsav=nsav+1   
      k(nsav,1)=11  
      k(nsav,2)=93  
      k(nsav,3)=ip  
      k(nsav,4)=nsav+1  
      k(nsav,5)=n-njet+1    
      DO 500 j=1,4  
      p(nsav,j)=dps(j)  
  500 v(nsav,j)=v(ip,j) 
      p(nsav,5)=sqrt(max(0d0,dps(4)**2-dps(1)**2-dps(2)**2-dps(3)**2))  
      v(nsav,5)=0.  
      DO 510 i=nsav+njet,n  
      DO 510 j=1,5  
      k(i-njet+1,j)=k(i,j)  
      p(i-njet+1,j)=p(i,j)  
  510 v(i-njet+1,j)=v(i,j)  
      n=n-njet+1    
    
C...Boost back particle system. Set production vertices.    
      IF(njet.NE.1) CALL ludbrb(nsav+1,n,0.,0.,dps(1)/dps(4),   
     &dps(2)/dps(4),dps(3)/dps(4))  
      DO 520 i=nsav+1,n 
      DO 520 j=1,4  
  520 v(i,j)=v(ip,j)    
    
      RETURN    
      END   
    
C*********************************************************************  
    
      SUBROUTINE ludecy(IP) 
    
C...Purpose: to handle the decay of unstable particles. 
      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/ludat2/kchg(500,3),pmas(500,4),parf(2000),vckm(4,4)    
      SAVE /ludat2/ 
      common/ludat3/mdcy(500,3),mdme(2000,2),brat(2000),kfdp(2000,5)    
      SAVE /ludat3/ 
      dimension vdcy(4),kflo(4),kfl1(4),pv(10,5),rord(10),ue(3),be(3),  
     &wtcor(10) 
      DATA wtcor/2.,5.,15.,60.,250.,1500.,1.2e4,1.2e5,150.,16./ 
    
C...Functions: momentum in two-particle decays, four-product and    
C...matrix element times phase space in weak decays.    
      pawt(a,b,c)=sqrt((a**2-(b+c)**2)*(a**2-(b-c)**2))/(2.*a)  
      four(i,j)=p(i,4)*p(j,4)-p(i,1)*p(j,1)-p(i,2)*p(j,2)-p(i,3)*p(j,3) 
      hmeps(ha)=((1.-hrq-ha)**2+3.*ha*(1.+hrq-ha))* 
     &sqrt((1.-hrq-ha)**2-4.*hrq*ha)    
    
C...Initial values. 
      ntry=0    
      nsav=n    
      kfa=iabs(k(ip,2)) 
      kfs=isign(1,k(ip,2))  
      kc=lucomp(kfa)    
      mstj(92)=0    
    
C...Choose lifetime and determine decay vertex. 
      IF(k(ip,1).EQ.5) THEN 
        v(ip,5)=0.  
      ELSEIF(k(ip,1).NE.4) THEN 
        v(ip,5)=-pmas(kc,4)*log(rlu(0)) 
      ENDIF 
      DO 100 j=1,4  
  100 vdcy(j)=v(ip,j)+v(ip,5)*p(ip,j)/p(ip,5)   
    
C...Determine whether decay allowed or not. 
      mout=0    
      IF(mstj(22).EQ.2) THEN    
        IF(pmas(kc,4).GT.parj(71)) mout=1   
      ELSEIF(mstj(22).EQ.3) THEN    
        IF(vdcy(1)**2+vdcy(2)**2+vdcy(3)**2.GT.parj(72)**2) mout=1  
      ELSEIF(mstj(22).EQ.4) THEN    
        IF(vdcy(1)**2+vdcy(2)**2.GT.parj(73)**2) mout=1 
        IF(abs(vdcy(3)).GT.parj(74)) mout=1 
      ENDIF 
      IF(mout.EQ.1.AND.k(ip,1).NE.5) THEN   
        k(ip,1)=4   
        RETURN  
      ENDIF 
    
C...Check existence of decay channels. Particle/antiparticle rules. 
      kca=kc    
      IF(mdcy(kc,2).GT.0) THEN  
        mdmdcy=mdme(mdcy(kc,2),2)   
        IF(mdmdcy.GT.80.AND.mdmdcy.LE.90) kca=mdmdcy    
      ENDIF 
      IF(mdcy(kca,2).LE.0.OR.mdcy(kca,3).LE.0) THEN 
        CALL luerrm(9,'(LUDECY:) no decay channel defined') 
        RETURN  
      ENDIF 
      IF(mod(kfa/1000,10).EQ.0.AND.(kca.EQ.85.OR.kca.EQ.87)) kfs=-kfs   
      IF(kchg(kc,3).EQ.0) THEN  
        kfsp=1  
        kfsn=0  
        IF(rlu(0).GT.0.5) kfs=-kfs  
      ELSEIF(kfs.GT.0) THEN 
        kfsp=1  
        kfsn=0  
      ELSE  
        kfsp=0  
        kfsn=1  
      ENDIF 
    
C...Sum branching ratios of allowed decay channels. 
  110 nope=0    
      brsu=0.   
      DO 120 idl=mdcy(kca,2),mdcy(kca,2)+mdcy(kca,3)-1  
      IF(mdme(idl,1).NE.1.AND.kfsp*mdme(idl,1).NE.2.AND.    
     &kfsn*mdme(idl,1).NE.3) goto 120   
      IF(mdme(idl,2).GT.100) goto 120   
      nope=nope+1   
      brsu=brsu+brat(idl)   
  120 CONTINUE  
      IF(nope.EQ.0) THEN    
        CALL luerrm(2,'(LUDECY:) all decay channels closed by user')    
        RETURN  
      ENDIF 
    
C...Select decay channel among allowed ones.    
  130 rbr=brsu*rlu(0)   
      idl=mdcy(kca,2)-1 
  140 idl=idl+1 
      IF(mdme(idl,1).NE.1.AND.kfsp*mdme(idl,1).NE.2.AND.    
     &kfsn*mdme(idl,1).NE.3) THEN   
        IF(idl.LT.mdcy(kca,2)+mdcy(kca,3)-1) goto 140   
      ELSEIF(mdme(idl,2).GT.100) THEN   
        IF(idl.LT.mdcy(kca,2)+mdcy(kca,3)-1) goto 140   
      ELSE  
        idc=idl 
        rbr=rbr-brat(idl)   
        IF(idl.LT.mdcy(kca,2)+mdcy(kca,3)-1.AND.rbr.GT.0.) goto 140 
      ENDIF 
    
C...Start readout of decay channel: matrix element, reset counters. 
      mmat=mdme(idc,2)  
  150 ntry=ntry+1   
      IF(ntry.GT.1000) THEN 
        CALL luerrm(14,'(LUDECY:) caught in infinite loop') 
        IF(mstu(21).GE.1) RETURN    
      ENDIF 
      i=n   
      np=0  
      nq=0  
      mbst=0    
      IF(mmat.GE.11.AND.mmat.NE.46.AND.p(ip,4).GT.20.*p(ip,5)) mbst=1   
      DO 160 j=1,4  
      pv(1,j)=0.    
  160 IF(mbst.EQ.0) pv(1,j)=p(ip,j) 
      IF(mbst.EQ.1) pv(1,4)=p(ip,5) 
      pv(1,5)=p(ip,5)   
      ps=0. 
      psq=0.    
      mrem=0    
    
C...Read out decay products. Convert to standard flavour code.  
      jtmax=5   
      IF(mdme(idc+1,2).EQ.101) jtmax=10 
      DO 170 jt=1,jtmax 
      IF(jt.LE.5) kp=kfdp(idc,jt)   
      IF(jt.GE.6) kp=kfdp(idc+1,jt-5)   
      IF(kp.EQ.0) goto 170  
      kpa=iabs(kp)  
      kcp=lucomp(kpa)   
      IF(kchg(kcp,3).EQ.0.AND.kpa.NE.81.AND.kpa.NE.82) THEN 
        kfp=kp  
      ELSEIF(kpa.NE.81.AND.kpa.NE.82) THEN  
        kfp=kfs*kp  
      ELSEIF(kpa.EQ.81.AND.mod(kfa/1000,10).EQ.0) THEN  
        kfp=-kfs*mod(kfa/10,10) 
      ELSEIF(kpa.EQ.81.AND.mod(kfa/100,10).GE.mod(kfa/10,10)) THEN  
        kfp=kfs*(100*mod(kfa/10,100)+3) 
      ELSEIF(kpa.EQ.81) THEN    
        kfp=kfs*(1000*mod(kfa/10,10)+100*mod(kfa/100,10)+1) 
      ELSEIF(kp.EQ.82) THEN 
        CALL lukfdi(-kfs*int(1.+(2.+parj(2))*rlu(0)),0,kfp,kdump)   
        IF(kfp.EQ.0) goto 150   
        mstj(93)=1  
        IF(pv(1,5).LT.parj(32)+2.*ulmass(kfp)) goto 150 
      ELSEIF(kp.EQ.-82) THEN    
        kfp=-kfp    
        IF(iabs(kfp).GT.10) kfp=kfp+isign(10000,kfp)    
      ENDIF 
      IF(kpa.EQ.81.OR.kpa.EQ.82) kcp=lucomp(kfp)    
    
C...Add decay product to event record or to quark flavour list. 
      kfpa=iabs(kfp)    
      kqp=kchg(kcp,2)   
      IF(mmat.GE.11.AND.mmat.LE.30.AND.kqp.NE.0) THEN   
        nq=nq+1 
        kflo(nq)=kfp    
        mstj(93)=2  
        psq=psq+ulmass(kflo(nq))    
      ELSEIF(mmat.GE.42.AND.mmat.LE.43.AND.np.EQ.3.AND.mod(nq,2).EQ.1)  
     &THEN  
        nq=nq-1 
        ps=ps-p(i,5)    
        k(i,1)=1    
        kfi=k(i,2)  
        CALL lukfdi(kfp,kfi,kfldmp,k(i,2))  
        IF(k(i,2).EQ.0) goto 150    
        mstj(93)=1  
        p(i,5)=ulmass(k(i,2))   
        ps=ps+p(i,5)    
      ELSE  
        i=i+1   
        np=np+1 
        IF(mmat.NE.33.AND.kqp.NE.0) nq=nq+1 
        IF(mmat.EQ.33.AND.kqp.NE.0.AND.kqp.NE.2) nq=nq+1    
        k(i,1)=1+mod(nq,2)  
        IF(mmat.EQ.4.AND.jt.LE.2.AND.kfp.EQ.21) k(i,1)=2    
        IF(mmat.EQ.4.AND.jt.EQ.3) k(i,1)=1  
        k(i,2)=kfp  
        k(i,3)=ip   
        k(i,4)=0    
        k(i,5)=0    
        p(i,5)=ulmass(kfp)  
        IF(mmat.EQ.45.AND.kfpa.EQ.89) p(i,5)=parj(32)   
        ps=ps+p(i,5)    
      ENDIF 
  170 CONTINUE  
    
C...Choose decay multiplicity in phase space model. 
  180 IF(mmat.GE.11.AND.mmat.LE.30) THEN    
        psp=ps  
        cnde=parj(61)*log(max((pv(1,5)-ps-psq)/parj(62),1.1))   
        IF(mmat.EQ.12) cnde=cnde+parj(63)   
  190   ntry=ntry+1 
        IF(ntry.GT.1000) THEN   
          CALL luerrm(14,'(LUDECY:) caught in infinite loop')   
          IF(mstu(21).GE.1) RETURN  
        ENDIF   
        IF(mmat.LE.20) THEN 
          gauss=sqrt(-2.*cnde*log(max(1e-10,rlu(0))))*  
     &    sin(paru(2)*rlu(0))   
          nd=0.5+0.5*np+0.25*nq+cnde+gauss  
          IF(nd.LT.np+nq/2.OR.nd.LT.2.OR.nd.GT.10) goto 190 
          IF(mmat.EQ.13.AND.nd.EQ.2) goto 190   
          IF(mmat.EQ.14.AND.nd.LE.3) goto 190   
          IF(mmat.EQ.15.AND.nd.LE.4) goto 190   
        ELSE    
          nd=mmat-20    
        ENDIF   
    
C...Form hadrons from flavour content.  
        DO 200 jt=1,4   
  200   kfl1(jt)=kflo(jt)   
        IF(nd.EQ.np+nq/2) goto 220  
        DO 210 i=n+np+1,n+nd-nq/2   
        jt=1+int((nq-1)*rlu(0)) 
        CALL lukfdi(kfl1(jt),0,kfl2,k(i,2)) 
        IF(k(i,2).EQ.0) goto 190    
  210   kfl1(jt)=-kfl2  
  220   jt=2    
        jt2=3   
        jt3=4   
        IF(nq.EQ.4.AND.rlu(0).LT.parj(66)) jt=4 
        IF(jt.EQ.4.AND.isign(1,kfl1(1)*(10-iabs(kfl1(1))))* 
     &  isign(1,kfl1(jt)*(10-iabs(kfl1(jt)))).GT.0) jt=3    
        IF(jt.EQ.3) jt2=2   
        IF(jt.EQ.4) jt3=2   
        CALL lukfdi(kfl1(1),kfl1(jt),kfldmp,k(n+nd-nq/2+1,2))   
        IF(k(n+nd-nq/2+1,2).EQ.0) goto 190  
        IF(nq.EQ.4) CALL lukfdi(kfl1(jt2),kfl1(jt3),kfldmp,k(n+nd,2))   
        IF(nq.EQ.4.AND.k(n+nd,2).EQ.0) goto 190 
    
C...Check that sum of decay product masses not too large.   
        ps=psp  
        DO 230 i=n+np+1,n+nd    
        k(i,1)=1    
        k(i,3)=ip   
        k(i,4)=0    
        k(i,5)=0    
        p(i,5)=ulmass(k(i,2))   
  230   ps=ps+p(i,5)    
        IF(ps+parj(64).GT.pv(1,5)) goto 190 
    
C...Rescale energy to subtract off spectator quark mass.    
      ELSEIF((mmat.EQ.31.OR.mmat.EQ.33.OR.mmat.EQ.44.OR.mmat.EQ.45).    
     &and.np.GE.3) THEN 
        ps=ps-p(n+np,5) 
        pqt=(p(n+np,5)+parj(65))/pv(1,5)    
        DO 240 j=1,5    
        p(n+np,j)=pqt*pv(1,j)   
  240   pv(1,j)=(1.-pqt)*pv(1,j)    
        IF(ps+parj(64).GT.pv(1,5)) goto 150 
        nd=np-1 
        mrem=1  
    
C...Phase space factors imposed in W decay. 
      ELSEIF(mmat.EQ.46) THEN   
        mstj(93)=1  
        psmc=ulmass(k(n+1,2))   
        mstj(93)=1  
        psmc=psmc+ulmass(k(n+2,2))  
        IF(max(ps,psmc)+parj(32).GT.pv(1,5)) goto 130   
        hr1=(p(n+1,5)/pv(1,5))**2   
        hr2=(p(n+2,5)/pv(1,5))**2   
        IF((1.-hr1-hr2)*(2.+hr1+hr2)*sqrt((1.-hr1-hr2)**2-4.*hr1*hr2).  
     &  lt.2.*rlu(0)) goto 130  
        nd=np   
    
C...Fully specified final state: check mass broadening effects. 
      ELSE  
        IF(np.GE.2.AND.ps+parj(64).GT.pv(1,5)) goto 150 
        nd=np   
      ENDIF 
    
C...Select W mass in decay Q -> W + q, without W propagator.    
      IF(mmat.EQ.45.AND.mstj(25).LE.0) THEN 
        hlq=(parj(32)/pv(1,5))**2   
        huq=(1.-(p(n+2,5)+parj(64))/pv(1,5))**2 
        hrq=(p(n+2,5)/pv(1,5))**2   
  250   hw=hlq+rlu(0)*(huq-hlq) 
        IF(hmeps(hw).LT.rlu(0)) goto 250    
        p(n+1,5)=pv(1,5)*sqrt(hw)   
    
C...Ditto, including W propagator. Divide mass range into three regions.    
      ELSEIF(mmat.EQ.45) THEN   
        hqw=(pv(1,5)/pmas(24,1))**2 
        hlw=(parj(32)/pmas(24,1))**2    
        huw=((pv(1,5)-p(n+2,5)-parj(64))/pmas(24,1))**2 
        hrq=(p(n+2,5)/pv(1,5))**2   
        hg=pmas(24,2)/pmas(24,1)    
        hatl=atan((hlw-1.)/hg)  
        hm=min(1.,huw-0.001)    
        hmv1=hmeps(hm/hqw)/((hm-1.)**2+hg**2)   
  260   hm=hm-hg    
        hmv2=hmeps(hm/hqw)/((hm-1.)**2+hg**2)   
        hsav1=hmeps(hm/hqw) 
        hsav2=1./((hm-1.)**2+hg**2) 
        IF(hmv2.GT.hmv1.AND.hm-hg.GT.hlw) THEN  
          hmv1=hmv2 
          goto 260  
        ENDIF   
        hmv=min(2.*hmv1,hmeps(hm/hqw)/hg**2)    
        hm1=1.-sqrt(1./hmv-hg**2)   
        IF(hm1.GT.hlw.AND.hm1.LT.hm) THEN   
          hm=hm1    
        ELSEIF(hmv2.LE.hmv1) THEN   
          hm=max(hlw,hm-min(0.1,1.-hm)) 
        ENDIF   
        hatm=atan((hm-1.)/hg)   
        hwt1=(hatm-hatl)/hg 
        hwt2=hmv*(min(1.,huw)-hm)   
        hwt3=0. 
        IF(huw.GT.1.) THEN  
          hatu=atan((huw-1.)/hg)    
          hmp1=hmeps(1./hqw)    
          hwt3=hmp1*hatu/hg 
        ENDIF   
    
C...Select mass region and W mass there. Accept according to weight.    
  270   hreg=rlu(0)*(hwt1+hwt2+hwt3)    
        IF(hreg.LE.hwt1) THEN   
          hw=1.+hg*tan(hatl+rlu(0)*(hatm-hatl)) 
          hacc=hmeps(hw/hqw)    
        ELSEIF(hreg.LE.hwt1+hwt2) THEN  
          hw=hm+rlu(0)*(min(1.,huw)-hm) 
          hacc=hmeps(hw/hqw)/((hw-1.)**2+hg**2)/hmv 
        ELSE    
          hw=1.+hg*tan(rlu(0)*hatu) 
          hacc=hmeps(hw/hqw)/hmp1   
        ENDIF   
        IF(hacc.LT.rlu(0)) goto 270 
        p(n+1,5)=pmas(24,1)*sqrt(hw)    
      ENDIF 
    
C...Determine position of grandmother, number of sisters, Q -> W sign.  
      nm=0  
      msgn=0    
      IF(mmat.EQ.3.OR.mmat.EQ.46) THEN  
        im=k(ip,3)  
        IF(im.LT.0.OR.im.GE.ip) im=0    
        IF(im.NE.0) kfam=iabs(k(im,2))  
        IF(im.NE.0.AND.mmat.EQ.3) THEN  
          DO 280 il=max(ip-2,im+1),min(ip+2,n)  
  280     IF(k(il,3).EQ.im) nm=nm+1 
          IF(nm.NE.2.OR.kfam.LE.100.OR.mod(kfam,10).NE.1.OR.    
     &    mod(kfam/1000,10).NE.0) nm=0  
        ELSEIF(im.NE.0.AND.mmat.EQ.46) THEN 
          msgn=isign(1,k(im,2)*k(ip,2)) 
          IF(kfam.GT.100.AND.mod(kfam/1000,10).EQ.0) msgn=  
     &    msgn*(-1)**mod(kfam/100,10)   
        ENDIF   
      ENDIF 
    
C...Kinematics of one-particle decays.  
      IF(nd.EQ.1) THEN  
        DO 290 j=1,4    
  290   p(n+1,j)=p(ip,j)    
        goto 510    
      ENDIF 
    
C...Calculate maximum weight ND-particle decay. 
      pv(nd,5)=p(n+nd,5)    
      IF(nd.GE.3) THEN  
        wtmax=1./wtcor(nd-2)    
        pmax=pv(1,5)-ps+p(n+nd,5)   
        pmin=0. 
        DO 300 il=nd-1,1,-1 
        pmax=pmax+p(n+il,5) 
        pmin=pmin+p(n+il+1,5)   
  300   wtmax=wtmax*pawt(pmax,pmin,p(n+il,5))   
      ENDIF 
    
C...Find virtual gamma mass in Dalitz decay.    
  310 IF(nd.EQ.2) THEN  
      ELSEIF(mmat.EQ.2) THEN    
        pmes=4.*pmas(11,1)**2   
        pmrho2=pmas(131,1)**2   
        pgrho2=pmas(131,2)**2   
  320   pmst=pmes*(p(ip,5)**2/pmes)**rlu(0) 
        wt=(1+0.5*pmes/pmst)*sqrt(max(0.,1.-pmes/pmst))*    
     &  (1.-pmst/p(ip,5)**2)**3*(1.+pgrho2/pmrho2)/ 
     &  ((1.-pmst/pmrho2)**2+pgrho2/pmrho2) 
        IF(wt.LT.rlu(0)) goto 320   
        pv(2,5)=max(2.00001*pmas(11,1),sqrt(pmst))  
    
C...M-generator gives weight. If rejected, try again.   
      ELSE  
  330   rord(1)=1.  
        DO 350 il1=2,nd-1   
        rsav=rlu(0) 
        DO 340 il2=il1-1,1,-1   
        IF(rsav.LE.rord(il2)) goto 350  
  340   rord(il2+1)=rord(il2)   
  350   rord(il2+1)=rsav    
        rord(nd)=0. 
        wt=1.   
        DO 360 il=nd-1,1,-1 
        pv(il,5)=pv(il+1,5)+p(n+il,5)+(rord(il)-rord(il+1))*(pv(1,5)-ps)    
  360   wt=wt*pawt(pv(il,5),pv(il+1,5),p(n+il,5))   
        IF(wt.LT.rlu(0)*wtmax) goto 330 
      ENDIF 
    
C...Perform two-particle decays in respective CM frame. 
  370 DO 390 il=1,nd-1  
      pa=pawt(pv(il,5),pv(il+1,5),p(n+il,5))    
      ue(3)=2.*rlu(0)-1.    
      phi=paru(2)*rlu(0)    
      ue(1)=sqrt(1.-ue(3)**2)*cos(phi)  
      ue(2)=sqrt(1.-ue(3)**2)*sin(phi)  
      DO 380 j=1,3  
      p(n+il,j)=pa*ue(j)    
  380 pv(il+1,j)=-pa*ue(j)  
      p(n+il,4)=sqrt(pa**2+p(n+il,5)**2)    
  390 pv(il+1,4)=sqrt(pa**2+pv(il+1,5)**2)  
    
C...Lorentz transform decay products to lab frame.  
      DO 400 j=1,4  
  400 p(n+nd,j)=pv(nd,j)    
      DO 430 il=nd-1,1,-1   
      DO 410 j=1,3  
  410 be(j)=pv(il,j)/pv(il,4)   
      ga=pv(il,4)/pv(il,5)  
      DO 430 i=n+il,n+nd    
      bep=be(1)*p(i,1)+be(2)*p(i,2)+be(3)*p(i,3)    
      DO 420 j=1,3  
  420 p(i,j)=p(i,j)+ga*(ga*bep/(1.+ga)+p(i,4))*be(j)    
  430 p(i,4)=ga*(p(i,4)+bep)    
    
C...Matrix elements for omega and phi decays.   
      IF(mmat.EQ.1) THEN    
        wt=(p(n+1,5)*p(n+2,5)*p(n+3,5))**2-(p(n+1,5)*four(n+2,n+3))**2  
     &  -(p(n+2,5)*four(n+1,n+3))**2-(p(n+3,5)*four(n+1,n+2))**2    
     &  +2.*four(n+1,n+2)*four(n+1,n+3)*four(n+2,n+3)   
        IF(max(wt*wtcor(9)/p(ip,5)**6,0.001).LT.rlu(0)) goto 310    
    
C...Matrix elements for pi0 or eta Dalitz decay to gamma e+ e-. 
      ELSEIF(mmat.EQ.2) THEN    
        four12=four(n+1,n+2)    
        four13=four(n+1,n+3)    
        four23=0.5*pmst-0.25*pmes   
        wt=(pmst-0.5*pmes)*(four12**2+four13**2)+   
     &  pmes*(four12*four13+four12**2+four13**2)    
        IF(wt.LT.rlu(0)*0.25*pmst*(p(ip,5)**2-pmst)**2) goto 370    
    
C...Matrix element for S0 -> S1 + V1 -> S1 + S2 + S3 (S scalar, 
C...V vector), of form cos**2(theta02) in V1 rest frame.    
      ELSEIF(mmat.EQ.3.AND.nm.EQ.2) THEN    
        IF((p(ip,5)**2*four(im,n+1)-four(ip,im)*four(ip,n+1))**2.LE.    
     &  rlu(0)*(four(ip,im)**2-(p(ip,5)*p(im,5))**2)*(four(ip,n+1)**2-  
     &  (p(ip,5)*p(n+1,5))**2)) goto 370    
    
C...Matrix element for "onium" -> g + g + g or gamma + g + g.   
      ELSEIF(mmat.EQ.4) THEN    
        hx1=2.*four(ip,n+1)/p(ip,5)**2  
        hx2=2.*four(ip,n+2)/p(ip,5)**2  
        hx3=2.*four(ip,n+3)/p(ip,5)**2  
        wt=((1.-hx1)/(hx2*hx3))**2+((1.-hx2)/(hx1*hx3))**2+ 
     &  ((1.-hx3)/(hx1*hx2))**2 
        IF(wt.LT.2.*rlu(0)) goto 310    
        IF(k(ip+1,2).EQ.22.AND.(1.-hx1)*p(ip,5)**2.LT.4.*parj(32)**2)   
     &  goto 310    
    
C...Effective matrix element for nu spectrum in tau -> nu + hadrons.    
      ELSEIF(mmat.EQ.41) THEN   
        hx1=2.*four(ip,n+1)/p(ip,5)**2  
        IF(8.*hx1*(3.-2.*hx1)/9..LT.rlu(0)) goto 310    
    
C...Matrix elements for weak decays (only semileptonic for c and b) 
      ELSEIF(mmat.GE.42.AND.mmat.LE.44.AND.nd.EQ.3) THEN    
        IF(mbst.EQ.0) wt=four(ip,n+1)*four(n+2,n+3) 
        IF(mbst.EQ.1) wt=p(ip,5)*p(n+1,4)*four(n+2,n+3) 
        IF(wt.LT.rlu(0)*p(ip,5)*pv(1,5)**3/wtcor(10)) goto 310  
      ELSEIF(mmat.GE.42.AND.mmat.LE.44) THEN    
        DO 440 j=1,4    
        p(n+np+1,j)=0.  
        DO 440 is=n+3,n+np  
  440   p(n+np+1,j)=p(n+np+1,j)+p(is,j) 
        IF(mbst.EQ.0) wt=four(ip,n+1)*four(n+2,n+np+1)  
        IF(mbst.EQ.1) wt=p(ip,5)*p(n+1,4)*four(n+2,n+np+1)  
        IF(wt.LT.rlu(0)*p(ip,5)*pv(1,5)**3/wtcor(10)) goto 310  
    
C...Angular distribution in W decay.    
      ELSEIF(mmat.EQ.46.AND.msgn.NE.0) THEN 
        IF(msgn.GT.0) wt=four(im,n+1)*four(n+2,ip+1)    
        IF(msgn.LT.0) wt=four(im,n+2)*four(n+1,ip+1)    
        IF(wt.LT.rlu(0)*p(im,5)**4/wtcor(10)) goto 370  
      ENDIF 
    
C...Scale back energy and reattach spectator.   
      IF(mrem.EQ.1) THEN    
        DO 450 j=1,5    
  450   pv(1,j)=pv(1,j)/(1.-pqt)    
        nd=nd+1 
        mrem=0  
      ENDIF 
    
C...Low invariant mass for system with spectator quark gives particle,  
C...not two jets. Readjust momenta accordingly. 
      IF((mmat.EQ.31.OR.mmat.EQ.45).AND.nd.EQ.3) THEN   
        mstj(93)=1  
        pm2=ulmass(k(n+2,2))    
        mstj(93)=1  
        pm3=ulmass(k(n+3,2))    
        IF(p(n+2,5)**2+p(n+3,5)**2+2.*four(n+2,n+3).GE. 
     &  (parj(32)+pm2+pm3)**2) goto 510 
        k(n+2,1)=1  
        kftemp=k(n+2,2) 
        CALL lukfdi(kftemp,k(n+3,2),kfldmp,k(n+2,2))    
        IF(k(n+2,2).EQ.0) goto 150  
        p(n+2,5)=ulmass(k(n+2,2))   
        ps=p(n+1,5)+p(n+2,5)    
        pv(2,5)=p(n+2,5)    
        mmat=0  
        nd=2    
        goto 370    
      ELSEIF(mmat.EQ.44) THEN   
        mstj(93)=1  
        pm3=ulmass(k(n+3,2))    
        mstj(93)=1  
        pm4=ulmass(k(n+4,2))    
        IF(p(n+3,5)**2+p(n+4,5)**2+2.*four(n+3,n+4).GE. 
     &  (parj(32)+pm3+pm4)**2) goto 480 
        k(n+3,1)=1  
        kftemp=k(n+3,2) 
        CALL lukfdi(kftemp,k(n+4,2),kfldmp,k(n+3,2))    
        IF(k(n+3,2).EQ.0) goto 150  
        p(n+3,5)=ulmass(k(n+3,2))   
        DO 460 j=1,3    
  460   p(n+3,j)=p(n+3,j)+p(n+4,j)  
        p(n+3,4)=sqrt(p(n+3,1)**2+p(n+3,2)**2+p(n+3,3)**2+p(n+3,5)**2)  
        ha=p(n+1,4)**2-p(n+2,4)**2  
        hb=ha-(p(n+1,5)**2-p(n+2,5)**2) 
        hc=(p(n+1,1)-p(n+2,1))**2+(p(n+1,2)-p(n+2,2))**2+   
     &  (p(n+1,3)-p(n+2,3))**2  
        hd=(pv(1,4)-p(n+3,4))**2    
        he=ha**2-2.*hd*(p(n+1,4)**2+p(n+2,4)**2)+hd**2  
        hf=hd*hc-hb**2  
        hg=hd*hc-ha*hb  
        hh=(sqrt(hg**2+he*hf)-hg)/(2.*hf)   
        DO 470 j=1,3    
        pcor=hh*(p(n+1,j)-p(n+2,j)) 
        p(n+1,j)=p(n+1,j)+pcor  
  470   p(n+2,j)=p(n+2,j)-pcor  
        p(n+1,4)=sqrt(p(n+1,1)**2+p(n+1,2)**2+p(n+1,3)**2+p(n+1,5)**2)  
        p(n+2,4)=sqrt(p(n+2,1)**2+p(n+2,2)**2+p(n+2,3)**2+p(n+2,5)**2)  
        nd=nd-1 
      ENDIF 
    
C...Check invariant mass of W jets. May give one particle or start over.    
  480 IF(mmat.GE.42.AND.mmat.LE.44.AND.iabs(k(n+1,2)).LT.10) THEN   
        pmr=sqrt(max(0.,p(n+1,5)**2+p(n+2,5)**2+2.*four(n+1,n+2)))  
        mstj(93)=1  
        pm1=ulmass(k(n+1,2))    
        mstj(93)=1  
        pm2=ulmass(k(n+2,2))    
        IF(pmr.GT.parj(32)+pm1+pm2) goto 490    
        kfldum=int(1.5+rlu(0))  
        CALL lukfdi(k(n+1,2),-isign(kfldum,k(n+1,2)),kfldmp,kf1)    
        CALL lukfdi(k(n+2,2),-isign(kfldum,k(n+2,2)),kfldmp,kf2)    
        IF(kf1.EQ.0.OR.kf2.EQ.0) goto 150   
        psm=ulmass(kf1)+ulmass(kf2) 
        IF(mmat.EQ.42.AND.pmr.GT.parj(64)+psm) goto 490 
        IF(mmat.GE.43.AND.pmr.GT.0.2*parj(32)+psm) goto 490 
        IF(nd.EQ.4.OR.kfa.EQ.15) goto 150   
        k(n+1,1)=1  
        kftemp=k(n+1,2) 
        CALL lukfdi(kftemp,k(n+2,2),kfldmp,k(n+1,2))    
        IF(k(n+1,2).EQ.0) goto 150  
        p(n+1,5)=ulmass(k(n+1,2))   
        k(n+2,2)=k(n+3,2)   
        p(n+2,5)=p(n+3,5)   
        ps=p(n+1,5)+p(n+2,5)    
        pv(2,5)=p(n+3,5)    
        mmat=0  
        nd=2    
        goto 370    
      ENDIF 
    
C...Phase space decay of partons from W decay.  
  490 IF(mmat.EQ.42.AND.iabs(k(n+1,2)).LT.10) THEN  
        kflo(1)=k(n+1,2)    
        kflo(2)=k(n+2,2)    
        k(n+1,1)=k(n+3,1)   
        k(n+1,2)=k(n+3,2)   
        DO 500 j=1,5    
        pv(1,j)=p(n+1,j)+p(n+2,j)   
  500   p(n+1,j)=p(n+3,j)   
        pv(1,5)=pmr 
        n=n+1   
        np=0    
        nq=2    
        ps=0.   
        mstj(93)=2  
        psq=ulmass(kflo(1)) 
        mstj(93)=2  
        psq=psq+ulmass(kflo(2)) 
        mmat=11 
        goto 180    
      ENDIF 
    
C...Boost back for rapidly moving particle. 
  510 n=n+nd    
      IF(mbst.EQ.1) THEN    
        DO 520 j=1,3    
  520   be(j)=p(ip,j)/p(ip,4)   
        ga=p(ip,4)/p(ip,5)  
        DO 540 i=nsav+1,n   
        bep=be(1)*p(i,1)+be(2)*p(i,2)+be(3)*p(i,3)  
        DO 530 j=1,3    
  530   p(i,j)=p(i,j)+ga*(ga*bep/(1.+ga)+p(i,4))*be(j)  
  540   p(i,4)=ga*(p(i,4)+bep)  
      ENDIF 
    
C...Fill in position of decay vertex.   
      DO 560 i=nsav+1,n 
      DO 550 j=1,4  
  550 v(i,j)=vdcy(j)    
  560 v(i,5)=0. 
    
C...Set up for parton shower evolution from jets.   
      IF(mstj(23).GE.1.AND.mmat.EQ.4.AND.k(nsav+1,2).EQ.21) THEN    
        k(nsav+1,1)=3   
        k(nsav+2,1)=3   
        k(nsav+3,1)=3   
        k(nsav+1,4)=mstu(5)*(nsav+2)    
        k(nsav+1,5)=mstu(5)*(nsav+3)    
        k(nsav+2,4)=mstu(5)*(nsav+3)    
        k(nsav+2,5)=mstu(5)*(nsav+1)    
        k(nsav+3,4)=mstu(5)*(nsav+1)    
        k(nsav+3,5)=mstu(5)*(nsav+2)    
        mstj(92)=-(nsav+1)  
      ELSEIF(mstj(23).GE.1.AND.mmat.EQ.4) THEN  
        k(nsav+2,1)=3   
        k(nsav+3,1)=3   
        k(nsav+2,4)=mstu(5)*(nsav+3)    
        k(nsav+2,5)=mstu(5)*(nsav+3)    
        k(nsav+3,4)=mstu(5)*(nsav+2)    
        k(nsav+3,5)=mstu(5)*(nsav+2)    
        mstj(92)=nsav+2 
      ELSEIF(mstj(23).GE.1.AND.(mmat.EQ.32.OR.mmat.EQ.44.OR.mmat.EQ.46).    
     &and.iabs(k(nsav+1,2)).LE.10.AND.iabs(k(nsav+2,2)).LE.10) THEN 
        k(nsav+1,1)=3   
        k(nsav+2,1)=3   
        k(nsav+1,4)=mstu(5)*(nsav+2)    
        k(nsav+1,5)=mstu(5)*(nsav+2)    
        k(nsav+2,4)=mstu(5)*(nsav+1)    
        k(nsav+2,5)=mstu(5)*(nsav+1)    
        mstj(92)=nsav+1 
      ELSEIF(mstj(23).GE.1.AND.mmat.EQ.33.AND.iabs(k(nsav+2,2)).EQ.21)  
     &THEN  
        k(nsav+1,1)=3   
        k(nsav+2,1)=3   
        k(nsav+3,1)=3   
        kcp=lucomp(k(nsav+1,2)) 
        kqp=kchg(kcp,2)*isign(1,k(nsav+1,2))    
        jcon=4  
        IF(kqp.LT.0) jcon=5 
        k(nsav+1,jcon)=mstu(5)*(nsav+2) 
        k(nsav+2,9-jcon)=mstu(5)*(nsav+1)   
        k(nsav+2,jcon)=mstu(5)*(nsav+3) 
        k(nsav+3,9-jcon)=mstu(5)*(nsav+2)   
        mstj(92)=nsav+1 
      ELSEIF(mstj(23).GE.1.AND.mmat.EQ.33) THEN 
        k(nsav+1,1)=3   
        k(nsav+3,1)=3   
        k(nsav+1,4)=mstu(5)*(nsav+3)    
        k(nsav+1,5)=mstu(5)*(nsav+3)    
        k(nsav+3,4)=mstu(5)*(nsav+1)    
        k(nsav+3,5)=mstu(5)*(nsav+1)    
        mstj(92)=nsav+1 
      ENDIF 
    
C...Mark decayed particle.  
      IF(k(ip,1).EQ.5) k(ip,1)=15   
      IF(k(ip,1).LE.10) k(ip,1)=11  
      k(ip,4)=nsav+1    
      k(ip,5)=n 
    
      RETURN    
      END   
    
C*********************************************************************  
    
      SUBROUTINE lukfdi(KFL1,KFL2,KFL3,KF)  
    
C...Purpose: to generate a new flavour pair and combine off a hadron.   
      common/ludat1/mstu(200),paru(200),mstj(200),parj(200) 
      SAVE /ludat1/ 
      common/ludat2/kchg(500,3),pmas(500,4),parf(2000),vckm(4,4)    
      SAVE /ludat2/ 
    
C...Default flavour values. Input consistency checks.   
      kf1a=iabs(kfl1)   
      kf2a=iabs(kfl2)   
      kfl3=0    
      kf=0  
      IF(kf1a.EQ.0) RETURN  
      IF(kf2a.NE.0) THEN    
        IF(kf1a.LE.10.AND.kf2a.LE.10.AND.kfl1*kfl2.GT.0) RETURN 
        IF(kf1a.GT.10.AND.kf2a.GT.10) RETURN    
        IF((kf1a.GT.10.OR.kf2a.GT.10).AND.kfl1*kfl2.LT.0) RETURN    
      ENDIF 
    
C...Check if tabulated flavour probabilities are to be used.    
      IF(mstj(15).EQ.1) THEN    
        ktab1=-1    
        IF(kf1a.GE.1.AND.kf1a.LE.6) ktab1=kf1a  
        kfl1a=mod(kf1a/1000,10) 
        kfl1b=mod(kf1a/100,10)  
        kfl1s=mod(kf1a,10)  
        IF(kfl1a.GE.1.AND.kfl1a.LE.4.AND.kfl1b.GE.1.AND.kfl1b.LE.4) 
     &  ktab1=6+kfl1a*(kfl1a-2)+2*kfl1b+(kfl1s-1)/2 
        IF(kfl1a.GE.1.AND.kfl1a.LE.4.AND.kfl1a.EQ.kfl1b) ktab1=ktab1-1  
        IF(kf1a.GE.1.AND.kf1a.LE.6) kfl1a=kf1a  
        ktab2=0 
        IF(kf2a.NE.0) THEN  
          ktab2=-1  
          IF(kf2a.GE.1.AND.kf2a.LE.6) ktab2=kf2a    
          kfl2a=mod(kf2a/1000,10)   
          kfl2b=mod(kf2a/100,10)    
          kfl2s=mod(kf2a,10)    
          IF(kfl2a.GE.1.AND.kfl2a.LE.4.AND.kfl2b.GE.1.AND.kfl2b.LE.4)   
     &    ktab2=6+kfl2a*(kfl2a-2)+2*kfl2b+(kfl2s-1)/2   
          IF(kfl2a.GE.1.AND.kfl2a.LE.4.AND.kfl2a.EQ.kfl2b) ktab2=ktab2-1    
        ENDIF   
        IF(ktab1.GE.0.AND.ktab2.GE.0) goto 140  
      ENDIF 
    
C...Parameters and breaking diquark parameter combinations. 
  100 par2=parj(2)  
      par3=parj(3)  
      par4=3.*parj(4)   
      IF(mstj(12).GE.2) THEN    
        par3m=sqrt(parj(3)) 
        par4m=1./(3.*sqrt(parj(4))) 
        pardm=parj(7)/(parj(7)+par3m*parj(6))   
        pars0=parj(5)*(2.+(1.+par2*par3m*parj(7))*(1.+par4m))   
        pars1=parj(7)*pars0/(2.*par3m)+parj(5)*(parj(6)*(1.+par4m)+ 
     &  par2*par3m*parj(6)*parj(7)) 
        pars2=parj(5)*2.*parj(6)*parj(7)*(par2*parj(7)+(1.+par4m)/par3m)    
        parsm=max(pars0,pars1,pars2)    
        par4=par4*(1.+parsm)/(1.+parsm/(3.*par4m))  
      ENDIF 
    
C...Choice of whether to generate meson or baryon.  
      mbary=0   
      kfda=0    
      IF(kf1a.LE.10) THEN   
        IF(kf2a.EQ.0.AND.mstj(12).GE.1.AND.(1.+parj(1))*rlu(0).GT.1.)   
     &  mbary=1 
        IF(kf2a.GT.10) mbary=2  
        IF(kf2a.GT.10.AND.kf2a.LE.10000) kfda=kf2a  
      ELSE  
        mbary=2 
        IF(kf1a.LE.10000) kfda=kf1a 
      ENDIF 
    
C...Possibility of process diquark -> meson + new diquark.  
      IF(kfda.NE.0.AND.mstj(12).GE.2) THEN  
        kflda=mod(kfda/1000,10) 
        kfldb=mod(kfda/100,10)  
        kflds=mod(kfda,10)  
        wtdq=pars0  
        IF(max(kflda,kfldb).EQ.3) wtdq=pars1    
        IF(min(kflda,kfldb).EQ.3) wtdq=pars2    
        IF(kflds.EQ.1) wtdq=wtdq/(3.*par4m) 
        IF((1.+wtdq)*rlu(0).GT.1.) mbary=-1 
        IF(mbary.EQ.-1.AND.kf2a.NE.0) RETURN    
      ENDIF 
    
C...Flavour for meson, possibly with new flavour.   
      IF(mbary.LE.0) THEN   
        kfs=isign(1,kfl1)   
        IF(mbary.EQ.0) THEN 
          IF(kf2a.EQ.0) kfl3=isign(1+int((2.+par2)*rlu(0)),-kfl1)   
          kfla=max(kf1a,kf2a+iabs(kfl3))    
          kflb=min(kf1a,kf2a+iabs(kfl3))    
          IF(kfla.NE.kf1a) kfs=-kfs 
    
C...Splitting of diquark into meson plus new diquark.   
        ELSE    
          kfl1a=mod(kf1a/1000,10)   
          kfl1b=mod(kf1a/100,10)    
  110     kfl1d=kfl1a+int(rlu(0)+0.5)*(kfl1b-kfl1a) 
          kfl1e=kfl1a+kfl1b-kfl1d   
          IF((kfl1d.EQ.3.AND.rlu(0).GT.pardm).OR.(kfl1e.EQ.3.AND.   
     &    rlu(0).LT.pardm)) THEN    
            kfl1d=kfl1a+kfl1b-kfl1d 
            kfl1e=kfl1a+kfl1b-kfl1e 
          ENDIF 
          kfl3a=1+int((2.+par2*par3m*parj(7))*rlu(0))   
          IF((kfl1e.NE.kfl3a.AND.rlu(0).GT.(1.+par4m)/max(2.,1.+par4m)).    
     &    or.(kfl1e.EQ.kfl3a.AND.rlu(0).GT.2./max(2.,1.+par4m)))    
     &    goto 110  
          kflds=3   
          IF(kfl1e.NE.kfl3a) kflds=2*int(rlu(0)+1./(1.+par4m))+1    
          kfl3=isign(10000+1000*max(kfl1e,kfl3a)+100*min(kfl1e,kfl3a)+  
     &    kflds,-kfl1)  
          kfla=max(kfl1d,kfl3a) 
          kflb=min(kfl1d,kfl3a) 
          IF(kfla.NE.kfl1d) kfs=-kfs    
        ENDIF   
    
C...Form meson, with spin and flavour mixing for diagonal states.   
        IF(kfla.LE.2) kmul=int(parj(11)+rlu(0)) 
        IF(kfla.EQ.3) kmul=int(parj(12)+rlu(0)) 
        IF(kfla.GE.4) kmul=int(parj(13)+rlu(0)) 
        IF(kmul.EQ.0.AND.parj(14).GT.0.) THEN   
          IF(rlu(0).LT.parj(14)) kmul=2 
        ELSEIF(kmul.EQ.1.AND.parj(15)+parj(16)+parj(17).GT.0.) THEN 
          rmul=rlu(0)   
          IF(rmul.LT.parj(15)) kmul=3   
          IF(kmul.EQ.1.AND.rmul.LT.parj(15)+parj(16)) kmul=4    
          IF(kmul.EQ.1.AND.rmul.LT.parj(15)+parj(16)+parj(17)) kmul=5   
        ENDIF   
        kfls=3  
        IF(kmul.EQ.0.OR.kmul.EQ.3) kfls=1   
        IF(kmul.EQ.5) kfls=5    
        IF(kfla.NE.kflb) THEN   
          kf=(100*kfla+10*kflb+kfls)*kfs*(-1)**kfla 
        ELSE    
          rmix=rlu(0)   
          imix=2*kfla+10*kmul   
          IF(kfla.LE.3) kf=110*(1+int(rmix+parf(imix-1))+   
     &    int(rmix+parf(imix)))+kfls    
          IF(kfla.GE.4) kf=110*kfla+kfls    
        ENDIF   
        IF(kmul.EQ.2.OR.kmul.EQ.3) kf=kf+isign(10000,kf)    
        IF(kmul.EQ.4) kf=kf+isign(20000,kf) 
    
C...Generate diquark flavour.   
      ELSE  
  120   IF(kf1a.LE.10.AND.kf2a.EQ.0) THEN   
          kfla=kf1a 
  130     kflb=1+int((2.+par2*par3)*rlu(0)) 
          kflc=1+int((2.+par2*par3)*rlu(0)) 
          kflds=1   
          IF(kflb.GE.kflc) kflds=3  
          IF(kflds.EQ.1.AND.par4*rlu(0).GT.1.) goto 130 
          IF(kflds.EQ.3.AND.par4.LT.rlu(0)) goto 130    
          kfl3=isign(1000*max(kflb,kflc)+100*min(kflb,kflc)+kflds,kfl1) 
    
C...Take diquark flavour from input.    
        ELSEIF(kf1a.LE.10) THEN 
          kfla=kf1a 
          kflb=mod(kf2a/1000,10)    
          kflc=mod(kf2a/100,10) 
          kflds=mod(kf2a,10)    
    
C...Generate (or take from input) quark to go with diquark. 
        ELSE    
          IF(kf2a.EQ.0) kfl3=isign(1+int((2.+par2)*rlu(0)),kfl1)    
          kfla=kf2a+iabs(kfl3)  
          kflb=mod(kf1a/1000,10)    
          kflc=mod(kf1a/100,10) 
          kflds=mod(kf1a,10)    
        ENDIF   
    
C...SU(6) factors for formation of baryon. Try again if fails.  
        kbary=kflds 
        IF(kflds.EQ.3.AND.kflb.NE.kflc) kbary=5 
        IF(kfla.NE.kflb.AND.kfla.NE.kflc) kbary=kbary+1 
        wt=parf(60+kbary)+parj(18)*parf(70+kbary)   
        IF(mbary.EQ.1.AND.mstj(12).GE.2) THEN   
          wtdq=pars0    
          IF(max(kflb,kflc).EQ.3) wtdq=pars1    
          IF(min(kflb,kflc).EQ.3) wtdq=pars2    
          IF(kflds.EQ.1) wtdq=wtdq/(3.*par4m)   
          IF(kflds.EQ.1) wt=wt*(1.+wtdq)/(1.+parsm/(3.*par4m))  
          IF(kflds.EQ.3) wt=wt*(1.+wtdq)/(1.+parsm) 
        ENDIF   
        IF(kf2a.EQ.0.AND.wt.LT.rlu(0)) goto 120 
    
C...Form baryon. Distinguish Lambda- and Sigmalike baryons. 
        kfld=max(kfla,kflb,kflc)    
        kflf=min(kfla,kflb,kflc)    
        kfle=kfla+kflb+kflc-kfld-kflf   
        kfls=2  
        IF((parf(60+kbary)+parj(18)*parf(70+kbary))*rlu(0).GT.  
     &  parf(60+kbary)) kfls=4  
        kfll=0  
        IF(kfls.EQ.2.AND.kfld.GT.kfle.AND.kfle.GT.kflf) THEN    
          IF(kflds.EQ.1.AND.kfla.EQ.kfld) kfll=1    
          IF(kflds.EQ.1.AND.kfla.NE.kfld) kfll=int(0.25+rlu(0)) 
          IF(kflds.EQ.3.AND.kfla.NE.kfld) kfll=int(0.75+rlu(0)) 
        ENDIF   
        IF(kfll.EQ.0) kf=isign(1000*kfld+100*kfle+10*kflf+kfls,kfl1)    
        IF(kfll.EQ.1) kf=isign(1000*kfld+100*kflf+10*kfle+kfls,kfl1)    
      ENDIF 
      RETURN    
    
C...Use tabulated probabilities to select new flavour and hadron.   
  140 IF(ktab2.EQ.0.AND.mstj(12).LE.0) THEN 
        kt3l=1  
        kt3u=6  
      ELSEIF(ktab2.EQ.0.AND.ktab1.GE.7.AND.mstj(12).LE.1) THEN  
        kt3l=1  
        kt3u=6  
      ELSEIF(ktab2.EQ.0) THEN   
        kt3l=1  
        kt3u=22 
      ELSE  
        kt3l=ktab2  
        kt3u=ktab2  
      ENDIF 
      rfl=0.    
      DO 150 kts=0,2    
      DO 150 kt3=kt3l,kt3u  
      rfl=rfl+parf(120+80*ktab1+25*kts+kt3) 
  150 CONTINUE  
      rfl=rlu(0)*rfl    
      DO 160 kts=0,2    
      ktabs=kts 
      DO 160 kt3=kt3l,kt3u  
      ktab3=kt3 
      rfl=rfl-parf(120+80*ktab1+25*kts+kt3) 
  160 IF(rfl.LE.0.) goto 170    
  170 CONTINUE  
    
C...Reconstruct flavour of produced quark/diquark.  
      IF(ktab3.LE.6) THEN   
        kfl3a=ktab3 
        kfl3b=0 
        kfl3=isign(kfl3a,kfl1*(2*ktab1-13)) 
      ELSE  
        kfl3a=1 
        IF(ktab3.GE.8) kfl3a=2  
        IF(ktab3.GE.11) kfl3a=3 
        IF(ktab3.GE.16) kfl3a=4 
        kfl3b=(ktab3-6-kfl3a*(kfl3a-2))/2   
        kfl3=1000*kfl3a+100*kfl3b+1 
        IF(kfl3a.EQ.kfl3b.OR.ktab3.NE.6+kfl3a*(kfl3a-2)+2*kfl3b) kfl3=  
     &  kfl3+2  
        kfl3=isign(kfl3,kfl1*(13-2*ktab1))  
      ENDIF 
    
C...Reconstruct meson code. 
      IF(kfl3a.EQ.kfl1a.AND.kfl3b.EQ.kfl1b.AND.(kfl3a.LE.3.OR.  
     &kfl3b.NE.0)) THEN 
        rfl=rlu(0)*(parf(143+80*ktab1+25*ktabs)+parf(144+80*ktab1+  
     &  25*ktabs)+parf(145+80*ktab1+25*ktabs))  
        kf=110+2*ktabs+1    
        IF(rfl.GT.parf(143+80*ktab1+25*ktabs)) kf=220+2*ktabs+1 
        IF(rfl.GT.parf(143+80*ktab1+25*ktabs)+parf(144+80*ktab1+    
     &  25*ktabs)) kf=330+2*ktabs+1 
      ELSEIF(ktab1.LE.6.AND.ktab3.LE.6) THEN    
        kfla=max(ktab1,ktab3)   
        kflb=min(ktab1,ktab3)   
        kfs=isign(1,kfl1)   
        IF(kfla.NE.kf1a) kfs=-kfs   
        kf=(100*kfla+10*kflb+2*ktabs+1)*kfs*(-1)**kfla  
      ELSEIF(ktab1.GE.7.AND.ktab3.GE.7) THEN    
        kfs=isign(1,kfl1)   
        IF(kfl1a.EQ.kfl3a) THEN 
          kfla=max(kfl1b,kfl3b) 
          kflb=min(kfl1b,kfl3b) 
          IF(kfla.NE.kfl1b) kfs=-kfs    
        ELSEIF(kfl1a.EQ.kfl3b) THEN 
          kfla=kfl3a    
          kflb=kfl1b    
          kfs=-kfs  
        ELSEIF(kfl1b.EQ.kfl3a) THEN 
          kfla=kfl1a    
          kflb=kfl3b    
        ELSEIF(kfl1b.EQ.kfl3b) THEN 
          kfla=max(kfl1a,kfl3a) 
          kflb=min(kfl1a,kfl3a) 
          IF(kfla.NE.kfl1a) kfs=-kfs    
        ELSE    
          CALL luerrm(2,'(LUKFDI:) no matching flavours for qq -> qq')  
          goto 100  
        ENDIF   
        kf=(100*kfla+10*kflb+2*ktabs+1)*kfs*(-1)**kfla  
    
C...Reconstruct baryon code.    
      ELSE  
        IF(ktab1.GE.7) THEN 
          kfla=kfl3a    
          kflb=kfl1a    
          kflc=kfl1b    
        ELSE    
          kfla=kfl1a    
          kflb=kfl3a    
          kflc=kfl3b    
        ENDIF   
        kfld=max(kfla,kflb,kflc)    
        kflf=min(kfla,kflb,kflc)    
        kfle=kfla+kflb+kflc-kfld-kflf   
        IF(ktabs.EQ.0) kf=isign(1000*kfld+100*kflf+10*kfle+2,kfl1)  
        IF(ktabs.GE.1) kf=isign(1000*kfld+100*kfle+10*kflf+2*ktabs,kfl1)    
      ENDIF 
    
C...Check that constructed flavour code is an allowed one.  
      IF(kfl2.NE.0) kfl3=0  
      kc=lucomp(kf) 
      IF(kc.EQ.0) THEN  
        CALL luerrm(2,'(LUKFDI:) user-defined flavour probabilities '// 
     &  'failed')   
        goto 100    
      ENDIF 
    
      RETURN    
      END   
    
C*********************************************************************  
    
      SUBROUTINE luptdi(KFL,PX,PY)  
    
C...Purpose: to generate transverse momentum according to a Gaussian.   
      common/ludat1/mstu(200),paru(200),mstj(200),parj(200) 
      SAVE /ludat1/ 
    
C...Generate p_T and azimuthal angle, gives p_x and p_y.    
      kfla=iabs(kfl)    
      pt=parj(21)*sqrt(-log(max(1e-10,rlu(0)))) 
      IF(mstj(91).EQ.1) pt=parj(22)*pt  
      IF(kfla.EQ.0.AND.mstj(13).LE.0) pt=0. 
      phi=paru(2)*rlu(0)    
      px=pt*cos(phi)    
      py=pt*sin(phi)    
    
      RETURN    
      END   
    
C*********************************************************************  
    
      SUBROUTINE luzdis(KFL1,KFL2,PR,Z) 
    
C...Purpose: to generate the longitudinal splitting variable z. 
      common/ludat1/mstu(200),paru(200),mstj(200),parj(200) 
      SAVE /ludat1/ 
    
C...Check if heavy flavour fragmentation.   
      kfla=iabs(kfl1)   
      kflb=iabs(kfl2)   
      kflh=kfla 
      IF(kfla.GE.10) kflh=mod(kfla/1000,10) 
    
C...Lund symmetric scaling function: determine parameters of shape. 
      IF(mstj(11).EQ.1.OR.(mstj(11).EQ.3.AND.kflh.LE.3)) THEN   
        fa=parj(41) 
        IF(mstj(91).EQ.1) fa=parj(43)   
        IF(kflb.GE.10) fa=fa+parj(45)   
        fb=parj(42)*pr  
        IF(mstj(91).EQ.1) fb=parj(44)*pr    
        fc=1.   
        IF(kfla.GE.10) fc=fc-parj(45)   
        IF(kflb.GE.10) fc=fc+parj(45)   
        mc=1    
        IF(abs(fc-1.).GT.0.01) mc=2 
    
C...Determine position of maximum. Special cases for a = 0 or a = c.    
        IF(fa.LT.0.02) THEN 
          ma=1  
          zmax=1.   
          IF(fc.GT.fb) zmax=fb/fc   
        ELSEIF(abs(fc-fa).LT.0.01) THEN 
          ma=2  
          zmax=fb/(fb+fc)   
        ELSE    
          ma=3  
          zmax=0.5*(fb+fc-sqrt((fb-fc)**2+4.*fa*fb))/(fc-fa)    
          IF(zmax.GT.0.99.AND.fb.GT.100.) zmax=1.-fa/fb 
        ENDIF   
    
C...Subdivide z range if distribution very peaked near endpoint.    
        mmax=2  
        IF(zmax.LT.0.1) THEN    
          mmax=1    
          zdiv=2.75*zmax    
          IF(mc.EQ.1) THEN  
            fint=1.-log(zdiv)   
          ELSE  
            zdivc=zdiv**(1.-fc) 
            fint=1.+(1.-1./zdivc)/(fc-1.)   
          ENDIF 
        ELSEIF(zmax.GT.0.85.AND.fb.GT.1.) THEN  
          mmax=3    
          fscb=sqrt(4.+(fc/fb)**2)  
          zdiv=fscb-1./zmax-(fc/fb)*log(zmax*0.5*(fscb+fc/fb))  
          IF(ma.GE.2) zdiv=zdiv+(fa/fb)*log(1.-zmax)    
          zdiv=min(zmax,max(0.,zdiv))   
          fint=1.+fb*(1.-zdiv)  
        ENDIF   
    
C...Choice of z, preweighted for peaks at low or high z.    
  100   z=rlu(0)    
        fpre=1. 
        IF(mmax.EQ.1) THEN  
          IF(fint*rlu(0).LE.1.) THEN    
            z=zdiv*z    
          ELSEIF(mc.EQ.1) THEN  
            z=zdiv**z   
            fpre=zdiv/z 
          ELSE  
            z=1./(zdivc+z*(1.-zdivc))**(1./(1.-fc)) 
            fpre=(zdiv/z)**fc   
          ENDIF 
        ELSEIF(mmax.EQ.3) THEN  
          IF(fint*rlu(0).LE.1.) THEN    
            z=zdiv+log(z)/fb    
            fpre=exp(fb*(z-zdiv))   
          ELSE  
            z=zdiv+z*(1.-zdiv)  
          ENDIF 
        ENDIF   
    
C...Weighting according to correct formula. 
        IF(z.LE.fb/(50.+fb).OR.z.GE.1.) goto 100    
        fval=(zmax/z)**fc*exp(fb*(1./zmax-1./z))    
        IF(ma.GE.2) fval=((1.-z)/(1.-zmax))**fa*fval    
        IF(fval.LT.rlu(0)*fpre) goto 100    
    
C...Generate z according to Field-Feynman, SLAC, (1-z)**c OR z**c.  
      ELSE  
        fc=parj(50+max(1,kflh)) 
        IF(mstj(91).EQ.1) fc=parj(59)   
  110   z=rlu(0)    
        IF(fc.GE.0..AND.fc.LE.1.) THEN  
          IF(fc.GT.rlu(0)) z=1.-z**(1./3.)  
        ELSEIF(fc.GT.-1.) THEN  
          IF(-4.*fc*z*(1.-z)**2.LT.rlu(0)*((1.-z)**2-fc*z)**2) goto 110 
        ELSE    
          IF(fc.GT.0.) z=1.-z**(1./fc)  
          IF(fc.LT.0.) z=z**(-1./fc)    
        ENDIF   
      ENDIF 
    
      RETURN    
      END   
    
C*********************************************************************  
    
      SUBROUTINE lushow(IP1,IP2,QMAX)   
    
C...Purpose: to generate timelike parton showers from given partons.    
      IMPLICIT DOUBLE PRECISION(d)  
      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/ludat2/kchg(500,3),pmas(500,4),parf(2000),vckm(4,4)    
      SAVE /ludat2/ 
      dimension pmth(5,40),ps(5),pma(4),pmsd(4),iep(4),ipa(4),  
     &kfla(4),kfld(4),kfl(4),itry(4),isi(4),isl(4),dp(4),dpt(5,4)   
    
C...Initialization of cutoff masses etc.    
      IF(mstj(41).LE.0.OR.(mstj(41).EQ.1.AND.qmax.LE.parj(82)).OR.  
     &qmax.LE.min(parj(82),parj(83)).OR.mstj(41).GE.3) RETURN   
      pmth(1,21)=ulmass(21) 
      pmth(2,21)=sqrt(pmth(1,21)**2+0.25*parj(82)**2)   
      pmth(3,21)=2.*pmth(2,21)  
      pmth(4,21)=pmth(3,21) 
      pmth(5,21)=pmth(3,21) 
      pmth(1,22)=ulmass(22) 
      pmth(2,22)=sqrt(pmth(1,22)**2+0.25*parj(83)**2)   
      pmth(3,22)=2.*pmth(2,22)  
      pmth(4,22)=pmth(3,22) 
      pmth(5,22)=pmth(3,22) 
      pmqth1=parj(82)   
      IF(mstj(41).EQ.2) pmqth1=min(parj(82),parj(83))   
      pmqth2=pmth(2,21) 
      IF(mstj(41).EQ.2) pmqth2=min(pmth(2,21),pmth(2,22))   
      DO 100 if=1,8 
      pmth(1,if)=ulmass(if) 
      pmth(2,if)=sqrt(pmth(1,if)**2+0.25*pmqth1**2) 
      pmth(3,if)=pmth(2,if)+pmqth2  
      pmth(4,if)=sqrt(pmth(1,if)**2+0.25*parj(82)**2)+pmth(2,21)    
  100 pmth(5,if)=sqrt(pmth(1,if)**2+0.25*parj(83)**2)+pmth(2,22)    
      pt2min=max(0.5*parj(82),1.1*parj(81))**2  
      alams=parj(81)**2 
      alfm=log(pt2min/alams)    
    
C...Store positions of shower initiating partons.   
      m3jc=0    
      IF(ip1.GT.0.AND.ip1.LE.min(n,mstu(4)-mstu(32)).AND.ip2.EQ.0) THEN 
        npa=1   
        ipa(1)=ip1  
      ELSEIF(min(ip1,ip2).GT.0.AND.max(ip1,ip2).LE.min(n,mstu(4)-   
     &mstu(32))) THEN   
        npa=2   
        ipa(1)=ip1  
        ipa(2)=ip2  
      ELSEIF(ip1.GT.0.AND.ip1.LE.min(n,mstu(4)-mstu(32)).AND.ip2.LT.0.  
     &and.ip2.GE.-3) THEN   
        npa=iabs(ip2)   
        DO 110 i=1,npa  
  110   ipa(i)=ip1+i-1  
      ELSE  
        CALL luerrm(12, 
     &  '(LUSHOW:) failed to reconstruct showering system') 
        IF(mstu(21).GE.1) RETURN    
      ENDIF 
    
C...Check on phase space available for emission.    
      irej=0    
      DO 120 j=1,5  
  120 ps(j)=0.  
      pm=0. 
      DO 130 i=1,npa    
      kfla(i)=iabs(k(ipa(i),2)) 
      pma(i)=p(ipa(i),5)    
      IF(kfla(i).NE.0.AND.(kfla(i).LE.8.OR.kfla(i).EQ.21))  
     &pma(i)=pmth(3,kfla(i))    
      pm=pm+pma(i)  
      IF(kfla(i).EQ.0.OR.(kfla(i).GT.8.AND.kfla(i).NE.21).OR.   
     &pma(i).GT.qmax) irej=irej+1   
      DO 130 j=1,4  
  130 ps(j)=ps(j)+p(ipa(i),j)   
      IF(irej.EQ.npa) RETURN    
      ps(5)=sqrt(max(0.,ps(4)**2-ps(1)**2-ps(2)**2-ps(3)**2))   
      IF(npa.EQ.1) ps(5)=ps(4)  
      IF(ps(5).LE.pm+pmqth1) RETURN 
      IF(npa.EQ.2.AND.mstj(47).GE.1) THEN   
        IF(kfla(1).GE.1.AND.kfla(1).LE.8.AND.kfla(2).GE.1.AND.  
     &  kfla(2).LE.8) m3jc=1    
        IF(mstj(47).GE.2) m3jc=1    
      ENDIF 
    
C...Define imagined single initiator of shower for parton system.   
      ns=n  
      IF(n.GT.mstu(4)-mstu(32)-5) THEN  
        CALL luerrm(11,'(LUSHOW:) no more memory left in LUJETS')   
        IF(mstu(21).GE.1) RETURN    
      ENDIF 
      IF(npa.GE.2) THEN 
        k(n+1,1)=11 
        k(n+1,2)=21 
        k(n+1,3)=0  
        k(n+1,4)=0  
        k(n+1,5)=0  
        p(n+1,1)=0. 
        p(n+1,2)=0. 
        p(n+1,3)=0. 
        p(n+1,4)=ps(5)  
        p(n+1,5)=ps(5)  
        v(n+1,5)=ps(5)**2   
        n=n+1   
      ENDIF 
    
C...Loop over partons that may branch.  
      nep=npa   
      im=ns 
      IF(npa.EQ.1) im=ns-1  
  140 im=im+1   
      IF(n.GT.ns) THEN  
        IF(im.GT.n) goto 380    
        kflm=iabs(k(im,2))  
        IF(kflm.EQ.0.OR.(kflm.GT.8.AND.kflm.NE.21)) goto 140    
        IF(p(im,5).LT.pmth(2,kflm)) goto 140    
        igm=k(im,3) 
      ELSE  
        igm=-1  
      ENDIF 
      IF(n+nep.GT.mstu(4)-mstu(32)-5) THEN  
        CALL luerrm(11,'(LUSHOW:) no more memory left in LUJETS')   
        IF(mstu(21).GE.1) RETURN    
      ENDIF 
    
C...Position of aunt (sister to branching parton).  
C...Origin and flavour of daughters.    
      iau=0 
      IF(igm.GT.0) THEN 
        IF(k(im-1,3).EQ.igm) iau=im-1   
        IF(n.GE.im+1.AND.k(im+1,3).EQ.igm) iau=im+1 
      ENDIF 
      IF(igm.GE.0) THEN 
        k(im,4)=n+1 
        DO 150 i=1,nep  
  150   k(n+i,3)=im 
      ELSE  
        k(n+1,3)=ipa(1) 
      ENDIF 
      IF(igm.LE.0) THEN 
        DO 160 i=1,nep  
  160   k(n+i,2)=k(ipa(i),2)    
      ELSEIF(kflm.NE.21) THEN   
        k(n+1,2)=k(im,2)    
        k(n+2,2)=k(im,5)    
      ELSEIF(k(im,5).EQ.21) THEN    
        k(n+1,2)=21 
        k(n+2,2)=21 
      ELSE  
        k(n+1,2)=k(im,5)    
        k(n+2,2)=-k(im,5)   
      ENDIF 
    
C...Reset flags on daughers and tries made. 
      DO 170 ip=1,nep   
      k(n+ip,1)=3   
      k(n+ip,4)=0   
      k(n+ip,5)=0   
      kfld(ip)=iabs(k(n+ip,2))  
      itry(ip)=0    
      isl(ip)=0 
      isi(ip)=0 
  170 IF(kfld(ip).GT.0.AND.(kfld(ip).LE.8.OR.kfld(ip).EQ.21)) isi(ip)=1 
      islm=0    
    
C...Maximum virtuality of daughters.    
      IF(igm.LE.0) THEN 
        DO 180 i=1,npa  
        IF(npa.GE.3) p(n+i,4)=(ps(4)*p(ipa(i),4)-ps(1)*p(ipa(i),1)- 
     &  ps(2)*p(ipa(i),2)-ps(3)*p(ipa(i),3))/ps(5)  
        p(n+i,5)=min(qmax,ps(5))    
        IF(npa.GE.3) p(n+i,5)=min(p(n+i,5),p(n+i,4))    
  180   IF(isi(i).EQ.0) p(n+i,5)=p(ipa(i),5)    
      ELSE  
        IF(mstj(43).LE.2) pem=v(im,2)   
        IF(mstj(43).GE.3) pem=p(im,4)   
        p(n+1,5)=min(p(im,5),v(im,1)*pem)   
        p(n+2,5)=min(p(im,5),(1.-v(im,1))*pem)  
        IF(k(n+2,2).EQ.22) p(n+2,5)=pmth(1,22)  
      ENDIF 
      DO 190 i=1,nep    
      pmsd(i)=p(n+i,5)  
      IF(isi(i).EQ.1) THEN  
        IF(p(n+i,5).LE.pmth(3,kfld(i))) p(n+i,5)=pmth(1,kfld(i))    
      ENDIF 
  190 v(n+i,5)=p(n+i,5)**2  
    
C...Choose one of the daughters for evolution.  
  200 inum=0    
      IF(nep.EQ.1) inum=1   
      DO 210 i=1,nep    
  210 IF(inum.EQ.0.AND.isl(i).EQ.1) inum=i  
      DO 220 i=1,nep    
      IF(inum.EQ.0.AND.itry(i).EQ.0.AND.isi(i).EQ.1) THEN   
        IF(p(n+i,5).GE.pmth(2,kfld(i))) inum=i  
      ENDIF 
  220 CONTINUE  
      IF(inum.EQ.0) THEN    
        rmax=0. 
        DO 230 i=1,nep  
        IF(isi(i).EQ.1.AND.pmsd(i).GE.pmqth2) THEN  
          rpm=p(n+i,5)/pmsd(i)  
          IF(rpm.GT.rmax.AND.p(n+i,5).GE.pmth(2,kfld(i))) THEN  
            rmax=rpm    
            inum=i  
          ENDIF 
        ENDIF   
  230   CONTINUE    
      ENDIF 
    
C...Store information on choice of evolving daughter.   
      inum=max(1,inum)  
      iep(1)=n+inum 
      DO 240 i=2,nep    
      iep(i)=iep(i-1)+1 
  240 IF(iep(i).GT.n+nep) iep(i)=n+1    
      DO 250 i=1,nep    
  250 kfl(i)=iabs(k(iep(i),2))  
      itry(inum)=itry(inum)+1   
      IF(itry(inum).GT.200) THEN    
        CALL luerrm(14,'(LUSHOW:) caught in infinite loop') 
        IF(mstu(21).GE.1) RETURN    
      ENDIF 
      z=0.5 
      IF(kfl(1).EQ.0.OR.(kfl(1).GT.8.AND.kfl(1).NE.21)) goto 300    
      IF(p(iep(1),5).LT.pmth(2,kfl(1))) goto 300    
    
C...Calculate allowed z range.  
      IF(nep.EQ.1) THEN 
        pmed=ps(4)  
      ELSEIF(igm.EQ.0.OR.mstj(43).LE.2) THEN    
        pmed=p(im,5)    
      ELSE  
        IF(inum.EQ.1) pmed=v(im,1)*pem  
        IF(inum.EQ.2) pmed=(1.-v(im,1))*pem 
      ENDIF 
      IF(mod(mstj(43),2).EQ.1) THEN 
        zc=pmth(2,21)/pmed  
        zce=pmth(2,22)/pmed 
      ELSE  
        zc=0.5*(1.-sqrt(max(0.,1.-(2.*pmth(2,21)/pmed)**2)))    
        IF(zc.LT.1e-4) zc=(pmth(2,21)/pmed)**2  
        zce=0.5*(1.-sqrt(max(0.,1.-(2.*pmth(2,22)/pmed)**2)))   
        IF(zce.LT.1e-4) zce=(pmth(2,22)/pmed)**2    
      ENDIF 
      zc=min(zc,0.491)  
      zce=min(zce,0.491)    
      IF((mstj(41).EQ.1.AND.zc.GT.0.49).OR.(mstj(41).EQ.2.AND.  
     &min(zc,zce).GT.0.49)) THEN    
        p(iep(1),5)=pmth(1,kfl(1))  
        v(iep(1),5)=p(iep(1),5)**2  
        goto 300    
      ENDIF 
    
C...Integral of Altarelli-Parisi z kernel for QCD.  
      IF(mstj(49).EQ.0.AND.kfl(1).EQ.21) THEN   
        fbr=6.*log((1.-zc)/zc)+mstj(45)*(0.5-zc)    
      ELSEIF(mstj(49).EQ.0) THEN    
        fbr=(8./3.)*log((1.-zc)/zc) 
    
C...Integral of Altarelli-Parisi z kernel for scalar gluon. 
      ELSEIF(mstj(49).EQ.1.AND.kfl(1).EQ.21) THEN   
        fbr=(parj(87)+mstj(45)*parj(88))*(1.-2.*zc) 
      ELSEIF(mstj(49).EQ.1) THEN    
        fbr=(1.-2.*zc)/3.   
        IF(igm.EQ.0.AND.m3jc.EQ.1) fbr=4.*fbr   
    
C...Integral of Altarelli-Parisi z kernel for Abelian vector gluon. 
      ELSEIF(kfl(1).EQ.21) THEN 
        fbr=6.*mstj(45)*(0.5-zc)    
      ELSE  
        fbr=2.*log((1.-zc)/zc)  
      ENDIF 
    
C...Integral of Altarelli-Parisi kernel for photon emission.    
      IF(mstj(41).EQ.2.AND.kfl(1).GE.1.AND.kfl(1).LE.8) 
     &fbre=(kchg(kfl(1),1)/3.)**2*2.*log((1.-zce)/zce)  
    
C...Inner veto algorithm starts. Find maximum mass for evolution.   
  260 pms=v(iep(1),5)   
      IF(igm.GE.0) THEN 
        pm2=0.  
        DO 270 i=2,nep  
        pm=p(iep(i),5)  
        IF(kfl(i).GT.0.AND.(kfl(i).LE.8.OR.kfl(i).EQ.21)) pm=   
     &  pmth(2,kfl(i))  
  270   pm2=pm2+pm  
        pms=min(pms,(p(im,5)-pm2)**2)   
      ENDIF 
    
C...Select mass for daughter in QCD evolution.  
      b0=27./6. 
      DO 280 if=4,mstj(45)  
  280 IF(pms.GT.4.*pmth(2,if)**2) b0=(33.-2.*if)/6. 
      IF(mstj(44).LE.0) THEN    
        pmsqcd=pms*exp(max(-100.,log(rlu(0))*paru(2)/(paru(111)*fbr)))  
      ELSEIF(mstj(44).EQ.1) THEN    
        pmsqcd=4.*alams*(0.25*pms/alams)**(rlu(0)**(b0/fbr))    
      ELSE  
        pmsqcd=pms*rlu(0)**(alfm*b0/fbr)    
      ENDIF 
      IF(zc.GT.0.49.OR.pmsqcd.LE.pmth(4,kfl(1))**2) pmsqcd= 
     &pmth(2,kfl(1))**2 
      v(iep(1),5)=pmsqcd    
      mce=1 
    
C...Select mass for daughter in QED evolution.  
      IF(mstj(41).EQ.2.AND.kfl(1).GE.1.AND.kfl(1).LE.8) THEN    
        pmsqed=pms*exp(max(-100.,log(rlu(0))*paru(2)/(paru(101)*fbre))) 
        IF(zce.GT.0.49.OR.pmsqed.LE.pmth(5,kfl(1))**2) pmsqed=  
     &  pmth(2,kfl(1))**2   
        IF(pmsqed.GT.pmsqcd) THEN   
          v(iep(1),5)=pmsqed    
          mce=2 
        ENDIF   
      ENDIF 
    
C...Check whether daughter mass below cutoff.   
      p(iep(1),5)=sqrt(v(iep(1),5)) 
      IF(p(iep(1),5).LE.pmth(3,kfl(1))) THEN    
        p(iep(1),5)=pmth(1,kfl(1))  
        v(iep(1),5)=p(iep(1),5)**2  
        goto 300    
      ENDIF 
    
C...Select z value of branching: q -> qgamma.   
      IF(mce.EQ.2) THEN 
        z=1.-(1.-zce)*(zce/(1.-zce))**rlu(0)    
        IF(1.+z**2.LT.2.*rlu(0)) goto 260   
        k(iep(1),5)=22  
    
C...Select z value of branching: q -> qg, g -> gg, g -> qqbar.  
      ELSEIF(mstj(49).NE.1.AND.kfl(1).NE.21) THEN   
        z=1.-(1.-zc)*(zc/(1.-zc))**rlu(0)   
        IF(1.+z**2.LT.2.*rlu(0)) goto 260   
        k(iep(1),5)=21  
      ELSEIF(mstj(49).EQ.0.AND.mstj(45)*(0.5-zc).LT.rlu(0)*fbr) THEN    
        z=(1.-zc)*(zc/(1.-zc))**rlu(0)  
        IF(rlu(0).GT.0.5) z=1.-z    
        IF((1.-z*(1.-z))**2.LT.rlu(0)) goto 260 
        k(iep(1),5)=21  
      ELSEIF(mstj(49).NE.1) THEN    
        z=zc+(1.-2.*zc)*rlu(0)  
        IF(z**2+(1.-z)**2.LT.rlu(0)) goto 260   
        kflb=1+int(mstj(45)*rlu(0)) 
        pmq=4.*pmth(2,kflb)**2/v(iep(1),5)  
        IF(pmq.GE.1.) goto 260  
        pmq0=4.*pmth(2,21)**2/v(iep(1),5)   
        IF(mod(mstj(43),2).EQ.0.AND.(1.+0.5*pmq)*sqrt(1.-pmq).LT.   
     &  rlu(0)*(1.+0.5*pmq0)*sqrt(1.-pmq0)) goto 260    
        k(iep(1),5)=kflb    
    
C...Ditto for scalar gluon model.   
      ELSEIF(kfl(1).NE.21) THEN 
        z=1.-sqrt(zc**2+rlu(0)*(1.-2.*zc))  
        k(iep(1),5)=21  
      ELSEIF(rlu(0)*(parj(87)+mstj(45)*parj(88)).LE.parj(87)) THEN  
        z=zc+(1.-2.*zc)*rlu(0)  
        k(iep(1),5)=21  
      ELSE  
        z=zc+(1.-2.*zc)*rlu(0)  
        kflb=1+int(mstj(45)*rlu(0)) 
        pmq=4.*pmth(2,kflb)**2/v(iep(1),5)  
        IF(pmq.GE.1.) goto 260  
        k(iep(1),5)=kflb    
      ENDIF 
      IF(mce.EQ.1.AND.mstj(44).GE.2) THEN   
        IF(z*(1.-z)*v(iep(1),5).LT.pt2min) goto 260 
        IF(alfm/log(v(iep(1),5)*z*(1.-z)/alams).LT.rlu(0)) goto 260 
      ENDIF 
    
C...Check if z consistent with chosen m.    
      IF(kfl(1).EQ.21) THEN 
        kflgd1=iabs(k(iep(1),5))    
        kflgd2=kflgd1   
      ELSE  
        kflgd1=kfl(1)   
        kflgd2=iabs(k(iep(1),5))    
      ENDIF 
      IF(nep.EQ.1) THEN 
        ped=ps(4)   
      ELSEIF(nep.GE.3) THEN 
        ped=p(iep(1),4) 
      ELSEIF(igm.EQ.0.OR.mstj(43).LE.2) THEN    
        ped=0.5*(v(im,5)+v(iep(1),5)-pm2**2)/p(im,5)    
      ELSE  
        IF(iep(1).EQ.n+1) ped=v(im,1)*pem   
        IF(iep(1).EQ.n+2) ped=(1.-v(im,1))*pem  
      ENDIF 
      IF(mod(mstj(43),2).EQ.1) THEN 
        pmqth3=0.5*parj(82) 
        IF(kflgd2.EQ.22) pmqth3=0.5*parj(83)    
        pmq1=(pmth(1,kflgd1)**2+pmqth3**2)/v(iep(1),5)  
        pmq2=(pmth(1,kflgd2)**2+pmqth3**2)/v(iep(1),5)  
        zd=sqrt(max(0.,(1.-v(iep(1),5)/ped**2)*((1.-pmq1-pmq2)**2-  
     &  4.*pmq1*pmq2))) 
        zh=1.+pmq1-pmq2 
      ELSE  
        zd=sqrt(max(0.,1.-v(iep(1),5)/ped**2))  
        zh=1.   
      ENDIF 
      zl=0.5*(zh-zd)    
      zu=0.5*(zh+zd)    
      IF(z.LT.zl.OR.z.GT.zu) goto 260   
      IF(kfl(1).EQ.21) v(iep(1),3)=log(zu*(1.-zl)/max(1e-20,zl* 
     &(1.-zu))) 
      IF(kfl(1).NE.21) v(iep(1),3)=log((1.-zl)/max(1e-10,1.-zu))    
    
C...Three-jet matrix element correction.    
      IF(igm.EQ.0.AND.m3jc.EQ.1) THEN   
        x1=z*(1.+v(iep(1),5)/v(ns+1,5)) 
        x2=1.-v(iep(1),5)/v(ns+1,5) 
        x3=(1.-x1)+(1.-x2)  
        IF(mce.EQ.2) THEN   
          ki1=k(ipa(inum),2)    
          ki2=k(ipa(3-inum),2)  
          qf1=kchg(iabs(ki1),1)*isign(1,ki1)/3. 
          qf2=kchg(iabs(ki2),1)*isign(1,ki2)/3. 
          wshow=qf1**2*(1.-x1)/x3*(1.+(x1/(2.-x2))**2)+ 
     &    qf2**2*(1.-x2)/x3*(1.+(x2/(2.-x1))**2)    
          wme=(qf1*(1.-x1)/x3-qf2*(1.-x2)/x3)**2*(x1**2+x2**2)  
        ELSEIF(mstj(49).NE.1) THEN  
          wshow=1.+(1.-x1)/x3*(x1/(2.-x2))**2+  
     &    (1.-x2)/x3*(x2/(2.-x1))**2    
          wme=x1**2+x2**2   
        ELSE    
          wshow=4.*x3*((1.-x1)/(2.-x2)**2+(1.-x2)/(2.-x1)**2)   
          wme=x3**2 
        ENDIF   
        IF(wme.LT.rlu(0)*wshow) goto 260    
    
C...Impose angular ordering by rejection of nonordered emission.    
      ELSEIF(mce.EQ.1.AND.igm.GT.0.AND.mstj(42).GE.2) THEN  
        maom=1  
        zm=v(im,1)  
        IF(iep(1).EQ.n+2) zm=1.-v(im,1) 
        the2id=z*(1.-z)*(zm*p(im,4))**2/v(iep(1),5) 
        iaom=im 
  290   IF(k(iaom,5).EQ.22) THEN    
          iaom=k(iaom,3)    
          IF(k(iaom,3).LE.ns) maom=0    
          IF(maom.EQ.1) goto 290    
        ENDIF   
        IF(maom.EQ.1) THEN  
          the2im=v(iaom,1)*(1.-v(iaom,1))*p(iaom,4)**2/v(iaom,5)    
          IF(the2id.LT.the2im) goto 260 
        ENDIF   
      ENDIF 
    
C...Impose user-defined maximum angle at first branching.   
      IF(mstj(48).EQ.1) THEN    
        IF(nep.EQ.1.AND.im.EQ.ns) THEN  
          the2id=z*(1.-z)*ps(4)**2/v(iep(1),5)  
          IF(the2id.LT.1./parj(85)**2) goto 260 
        ELSEIF(nep.EQ.2.AND.iep(1).EQ.ns+2) THEN    
          the2id=z*(1.-z)*(0.5*p(im,4))**2/v(iep(1),5)  
          IF(the2id.LT.1./parj(85)**2) goto 260 
        ELSEIF(nep.EQ.2.AND.iep(1).EQ.ns+3) THEN    
          the2id=z*(1.-z)*(0.5*p(im,4))**2/v(iep(1),5)  
          IF(the2id.LT.1./parj(86)**2) goto 260 
        ENDIF   
      ENDIF 
    
C...End of inner veto algorithm. Check if only one leg evolved so far.  
  300 v(iep(1),1)=z 
      isl(1)=0  
      isl(2)=0  
      IF(nep.EQ.1) goto 330 
      IF(nep.EQ.2.AND.p(iep(1),5)+p(iep(2),5).GE.p(im,5)) goto 200  
      DO 310 i=1,nep    
      IF(itry(i).EQ.0.AND.kfld(i).GT.0.AND.(kfld(i).LE.8.OR.kfld(i).EQ. 
     &21)) THEN 
        IF(p(n+i,5).GE.pmth(2,kfld(i))) goto 200    
      ENDIF 
  310 CONTINUE  
    
C...Check if chosen multiplet m1,m2,z1,z2 is physical.  
      IF(nep.EQ.3) THEN 
        pa1s=(p(n+1,4)+p(n+1,5))*(p(n+1,4)-p(n+1,5))    
        pa2s=(p(n+2,4)+p(n+2,5))*(p(n+2,4)-p(n+2,5))    
        pa3s=(p(n+3,4)+p(n+3,5))*(p(n+3,4)-p(n+3,5))    
        pts=0.25*(2.*pa1s*pa2s+2.*pa1s*pa3s+2.*pa2s*pa3s-   
     &  pa1s**2-pa2s**2-pa3s**2)/pa1s   
        IF(pts.LE.0.) goto 200  
      ELSEIF(igm.EQ.0.OR.mstj(43).LE.2.OR.mod(mstj(43),2).EQ.0) THEN    
        DO 320 i1=n+1,n+2   
        kflda=iabs(k(i1,2)) 
        IF(kflda.EQ.0.OR.(kflda.GT.8.AND.kflda.NE.21)) goto 320 
        IF(p(i1,5).LT.pmth(2,kflda)) goto 320   
        IF(kflda.EQ.21) THEN    
          kflgd1=iabs(k(i1,5))  
          kflgd2=kflgd1 
        ELSE    
          kflgd1=kflda  
          kflgd2=iabs(k(i1,5))  
        ENDIF   
        i2=2*n+3-i1 
        IF(igm.EQ.0.OR.mstj(43).LE.2) THEN  
          ped=0.5*(v(im,5)+v(i1,5)-v(i2,5))/p(im,5) 
        ELSE    
          IF(i1.EQ.n+1) zm=v(im,1)  
          IF(i1.EQ.n+2) zm=1.-v(im,1)   
          pml=sqrt((v(im,5)-v(n+1,5)-v(n+2,5))**2-  
     &    4.*v(n+1,5)*v(n+2,5)) 
          ped=pem*(0.5*(v(im,5)-pml+v(i1,5)-v(i2,5))+pml*zm)/v(im,5)    
        ENDIF   
        IF(mod(mstj(43),2).EQ.1) THEN   
          pmqth3=0.5*parj(82)   
          IF(kflgd2.EQ.22) pmqth3=0.5*parj(83)  
          pmq1=(pmth(1,kflgd1)**2+pmqth3**2)/v(i1,5)    
          pmq2=(pmth(1,kflgd2)**2+pmqth3**2)/v(i1,5)    
          zd=sqrt(max(0.,(1.-v(i1,5)/ped**2)*((1.-pmq1-pmq2)**2-    
     &    4.*pmq1*pmq2)))   
          zh=1.+pmq1-pmq2   
        ELSE    
          zd=sqrt(max(0.,1.-v(i1,5)/ped**2))    
          zh=1. 
        ENDIF   
        zl=0.5*(zh-zd)  
        zu=0.5*(zh+zd)  
        IF(i1.EQ.n+1.AND.(v(i1,1).LT.zl.OR.v(i1,1).GT.zu)) isl(1)=1 
        IF(i1.EQ.n+2.AND.(v(i1,1).LT.zl.OR.v(i1,1).GT.zu)) isl(2)=1 
        IF(kflda.EQ.21) v(i1,4)=log(zu*(1.-zl)/max(1e-20,zl*(1.-zu)))   
        IF(kflda.NE.21) v(i1,4)=log((1.-zl)/max(1e-10,1.-zu))   
  320   CONTINUE    
        IF(isl(1).EQ.1.AND.isl(2).EQ.1.AND.islm.NE.0) THEN  
          isl(3-islm)=0 
          islm=3-islm   
        ELSEIF(isl(1).EQ.1.AND.isl(2).EQ.1) THEN    
          zdr1=max(0.,v(n+1,3)/v(n+1,4)-1.) 
          zdr2=max(0.,v(n+2,3)/v(n+2,4)-1.) 
          IF(zdr2.GT.rlu(0)*(zdr1+zdr2)) isl(1)=0   
          IF(isl(1).EQ.1) isl(2)=0  
          IF(isl(1).EQ.0) islm=1    
          IF(isl(2).EQ.0) islm=2    
        ENDIF   
        IF(isl(1).EQ.1.OR.isl(2).EQ.1) goto 200 
      ENDIF 
      IF(igm.GT.0.AND.mod(mstj(43),2).EQ.1.AND.(p(n+1,5).GE.    
     &pmth(2,kfld(1)).OR.p(n+2,5).GE.pmth(2,kfld(2)))) THEN 
        pmq1=v(n+1,5)/v(im,5)   
        pmq2=v(n+2,5)/v(im,5)   
        zd=sqrt(max(0.,(1.-v(im,5)/pem**2)*((1.-pmq1-pmq2)**2-  
     &  4.*pmq1*pmq2))) 
        zh=1.+pmq1-pmq2 
        zl=0.5*(zh-zd)  
        zu=0.5*(zh+zd)  
        IF(v(im,1).LT.zl.OR.v(im,1).GT.zu) goto 200 
      ENDIF 
    
C...Accepted branch. Construct four-momentum for initial partons.   
  330 mazip=0   
      mazic=0   
      IF(nep.EQ.1) THEN 
        p(n+1,1)=0. 
        p(n+1,2)=0. 
        p(n+1,3)=sqrt(max(0.,(p(ipa(1),4)+p(n+1,5))*(p(ipa(1),4)-   
     &  p(n+1,5)))) 
        p(n+1,4)=p(ipa(1),4)    
        v(n+1,2)=p(n+1,4)   
      ELSEIF(igm.EQ.0.AND.nep.EQ.2) THEN    
        ped1=0.5*(v(im,5)+v(n+1,5)-v(n+2,5))/p(im,5)    
        p(n+1,1)=0. 
        p(n+1,2)=0. 
        p(n+1,3)=sqrt(max(0.,(ped1+p(n+1,5))*(ped1-p(n+1,5))))  
        p(n+1,4)=ped1   
        p(n+2,1)=0. 
        p(n+2,2)=0. 
        p(n+2,3)=-p(n+1,3)  
        p(n+2,4)=p(im,5)-ped1   
        v(n+1,2)=p(n+1,4)   
        v(n+2,2)=p(n+2,4)   
      ELSEIF(nep.EQ.3) THEN 
        p(n+1,1)=0. 
        p(n+1,2)=0. 
        p(n+1,3)=sqrt(max(0.,pa1s)) 
        p(n+2,1)=sqrt(pts)  
        p(n+2,2)=0. 
        p(n+2,3)=0.5*(pa3s-pa2s-pa1s)/p(n+1,3)  
        p(n+3,1)=-p(n+2,1)  
        p(n+3,2)=0. 
        p(n+3,3)=-(p(n+1,3)+p(n+2,3))   
        v(n+1,2)=p(n+1,4)   
        v(n+2,2)=p(n+2,4)   
        v(n+3,2)=p(n+3,4)   
    
C...Construct transverse momentum for ordinary branching in shower. 
      ELSE  
        zm=v(im,1)  
        pzm=sqrt(max(0.,(pem+p(im,5))*(pem-p(im,5))))   
        pmls=(v(im,5)-v(n+1,5)-v(n+2,5))**2-4.*v(n+1,5)*v(n+2,5)    
        IF(pzm.LE.0.) THEN  
          pts=0.    
        ELSEIF(mod(mstj(43),2).EQ.1) THEN   
          pts=(pem**2*(zm*(1.-zm)*v(im,5)-(1.-zm)*v(n+1,5)- 
     &    zm*v(n+2,5))-0.25*pmls)/pzm**2    
        ELSE    
          pts=pmls*(zm*(1.-zm)*pem**2/v(im,5)-0.25)/pzm**2  
        ENDIF   
        pt=sqrt(max(0.,pts))    
    
C...Find coefficient of azimuthal asymmetry due to gluon polarization.  
        hazip=0.    
        IF(mstj(49).NE.1.AND.mod(mstj(46),2).EQ.1.AND.k(im,2).EQ.21.    
     &  and.iau.NE.0) THEN  
          IF(k(igm,3).NE.0) mazip=1 
          zau=v(igm,1)  
          IF(iau.EQ.im+1) zau=1.-v(igm,1)   
          IF(mazip.EQ.0) zau=0. 
          IF(k(igm,2).NE.21) THEN   
            hazip=2.*zau/(1.+zau**2)    
          ELSE  
            hazip=(zau/(1.-zau*(1.-zau)))**2    
          ENDIF 
          IF(k(n+1,2).NE.21) THEN   
            hazip=hazip*(-2.*zm*(1.-zm))/(1.-2.*zm*(1.-zm)) 
          ELSE  
            hazip=hazip*(zm*(1.-zm)/(1.-zm*(1.-zm)))**2 
          ENDIF 
        ENDIF   
    
C...Find coefficient of azimuthal asymmetry due to soft gluon   
C...interference.   
        hazic=0.    
        IF(mstj(46).GE.2.AND.(k(n+1,2).EQ.21.OR.k(n+2,2).EQ.21).    
     &  and.iau.NE.0) THEN  
          IF(k(igm,3).NE.0) mazic=n+1   
          IF(k(igm,3).NE.0.AND.k(n+1,2).NE.21) mazic=n+2    
          IF(k(igm,3).NE.0.AND.k(n+1,2).EQ.21.AND.k(n+2,2).EQ.21.AND.   
     &    zm.GT.0.5) mazic=n+2  
          IF(k(iau,2).EQ.22) mazic=0    
          zs=zm 
          IF(mazic.EQ.n+2) zs=1.-zm 
          zgm=v(igm,1)  
          IF(iau.EQ.im-1) zgm=1.-v(igm,1)   
          IF(mazic.EQ.0) zgm=1. 
          hazic=(p(im,5)/p(igm,5))*sqrt((1.-zs)*(1.-zgm)/(zs*zgm))  
          hazic=min(0.95,hazic) 
        ENDIF   
      ENDIF 
    
C...Construct kinematics for ordinary branching in shower.  
  340 IF(nep.EQ.2.AND.igm.GT.0) THEN    
        IF(mod(mstj(43),2).EQ.1) THEN   
          p(n+1,4)=pem*v(im,1)  
        ELSE    
          p(n+1,4)=pem*(0.5*(v(im,5)-sqrt(pmls)+v(n+1,5)-v(n+2,5))+ 
     &    sqrt(pmls)*zm)/v(im,5)    
        ENDIF   
        phi=paru(2)*rlu(0)  
        p(n+1,1)=pt*cos(phi)    
        p(n+1,2)=pt*sin(phi)    
        IF(pzm.GT.0.) THEN  
          p(n+1,3)=0.5*(v(n+2,5)-v(n+1,5)-v(im,5)+2.*pem*p(n+1,4))/pzm  
        ELSE    
          p(n+1,3)=0.   
        ENDIF   
        p(n+2,1)=-p(n+1,1)  
        p(n+2,2)=-p(n+1,2)  
        p(n+2,3)=pzm-p(n+1,3)   
        p(n+2,4)=pem-p(n+1,4)   
        IF(mstj(43).LE.2) THEN  
          v(n+1,2)=(pem*p(n+1,4)-pzm*p(n+1,3))/p(im,5)  
          v(n+2,2)=(pem*p(n+2,4)-pzm*p(n+2,3))/p(im,5)  
        ENDIF   
      ENDIF 
    
C...Rotate and boost daughters. 
      IF(igm.GT.0) THEN 
        IF(mstj(43).LE.2) THEN  
          bex=p(igm,1)/p(igm,4) 
          bey=p(igm,2)/p(igm,4) 
          bez=p(igm,3)/p(igm,4) 
          ga=p(igm,4)/p(igm,5)  
          gabep=ga*(ga*(bex*p(im,1)+bey*p(im,2)+bez*p(im,3))/(1.+ga)-   
     &    p(im,4))  
        ELSE    
          bex=0.    
          bey=0.    
          bez=0.    
          ga=1. 
          gabep=0.  
        ENDIF   
        the=ulangl(p(im,3)+gabep*bez,sqrt((p(im,1)+gabep*bex)**2+   
     &  (p(im,2)+gabep*bey)**2))    
        phi=ulangl(p(im,1)+gabep*bex,p(im,2)+gabep*bey) 
        DO 350 i=n+1,n+2    
        dp(1)=cos(the)*cos(phi)*p(i,1)-sin(phi)*p(i,2)+ 
     &  sin(the)*cos(phi)*p(i,3)    
        dp(2)=cos(the)*sin(phi)*p(i,1)+cos(phi)*p(i,2)+ 
     &  sin(the)*sin(phi)*p(i,3)    
        dp(3)=-sin(the)*p(i,1)+cos(the)*p(i,3)  
        dp(4)=p(i,4)    
        dbp=bex*dp(1)+bey*dp(2)+bez*dp(3)   
        dgabp=ga*(ga*dbp/(1d0+ga)+dp(4))    
        p(i,1)=dp(1)+dgabp*bex  
        p(i,2)=dp(2)+dgabp*bey  
        p(i,3)=dp(3)+dgabp*bez  
  350   p(i,4)=ga*(dp(4)+dbp)   
      ENDIF 
    
C...Weight with azimuthal distribution, if required.    
      IF(mazip.NE.0.OR.mazic.NE.0) THEN 
        DO 360 j=1,3    
        dpt(1,j)=p(im,j)    
        dpt(2,j)=p(iau,j)   
  360   dpt(3,j)=p(n+1,j)   
        dpma=dpt(1,1)*dpt(2,1)+dpt(1,2)*dpt(2,2)+dpt(1,3)*dpt(2,3)  
        dpmd=dpt(1,1)*dpt(3,1)+dpt(1,2)*dpt(3,2)+dpt(1,3)*dpt(3,3)  
        dpmm=dpt(1,1)**2+dpt(1,2)**2+dpt(1,3)**2    
        DO 370 j=1,3    
        dpt(4,j)=dpt(2,j)-dpma*dpt(1,j)/dpmm    
  370   dpt(5,j)=dpt(3,j)-dpmd*dpt(1,j)/dpmm    
        dpt(4,4)=sqrt(dpt(4,1)**2+dpt(4,2)**2+dpt(4,3)**2)  
        dpt(5,4)=sqrt(dpt(5,1)**2+dpt(5,2)**2+dpt(5,3)**2)  
        IF(min(dpt(4,4),dpt(5,4)).GT.0.1*parj(82)) THEN 
          cad=(dpt(4,1)*dpt(5,1)+dpt(4,2)*dpt(5,2)+ 
     &    dpt(4,3)*dpt(5,3))/(dpt(4,4)*dpt(5,4))    
          IF(mazip.NE.0) THEN   
            IF(1.+hazip*(2.*cad**2-1.).LT.rlu(0)*(1.+abs(hazip)))   
     &      goto 340    
          ENDIF 
          IF(mazic.NE.0) THEN   
            IF(mazic.EQ.n+2) cad=-cad   
            IF((1.-hazic)*(1.-hazic*cad)/(1.+hazic**2-2.*hazic*cad).    
     &      lt.rlu(0)) goto 340 
          ENDIF 
        ENDIF   
      ENDIF 
    
C...Continue loop over partons that may branch, until none left.    
      IF(igm.GE.0) k(im,1)=14   
      n=n+nep   
      nep=2 
      IF(n.GT.mstu(4)-mstu(32)-5) THEN  
        CALL luerrm(11,'(LUSHOW:) no more memory left in LUJETS')   
        IF(mstu(21).GE.1) n=ns  
        IF(mstu(21).GE.1) RETURN    
      ENDIF 
      goto 140  
    
C...Set information on imagined shower initiator.   
  380 IF(npa.GE.2) THEN 
        k(ns+1,1)=11    
        k(ns+1,2)=94    
        k(ns+1,3)=ip1   
        IF(ip2.GT.0.AND.ip2.LT.ip1) k(ns+1,3)=ip2   
        k(ns+1,4)=ns+2  
        k(ns+1,5)=ns+1+npa  
        iim=1   
      ELSE  
        iim=0   
      ENDIF 
    
C...Reconstruct string drawing information. 
      DO 390 i=ns+1+iim,n   
      IF(k(i,1).LE.10.AND.k(i,2).EQ.22) THEN    
        k(i,1)=1    
      ELSEIF(k(i,1).LE.10) THEN 
        k(i,4)=mstu(5)*(k(i,4)/mstu(5)) 
        k(i,5)=mstu(5)*(k(i,5)/mstu(5)) 
      ELSEIF(k(mod(k(i,4),mstu(5))+1,2).NE.22) THEN 
        id1=mod(k(i,4),mstu(5)) 
        IF(k(i,2).GE.1.AND.k(i,2).LE.8) id1=mod(k(i,4),mstu(5))+1   
        id2=2*mod(k(i,4),mstu(5))+1-id1 
        k(i,4)=mstu(5)*(k(i,4)/mstu(5))+id1 
        k(i,5)=mstu(5)*(k(i,5)/mstu(5))+id2 
        k(id1,4)=k(id1,4)+mstu(5)*i 
        k(id1,5)=k(id1,5)+mstu(5)*id2   
        k(id2,4)=k(id2,4)+mstu(5)*id1   
        k(id2,5)=k(id2,5)+mstu(5)*i 
      ELSE  
        id1=mod(k(i,4),mstu(5)) 
        id2=id1+1   
        k(i,4)=mstu(5)*(k(i,4)/mstu(5))+id1 
        k(i,5)=mstu(5)*(k(i,5)/mstu(5))+id1 
        k(id1,4)=k(id1,4)+mstu(5)*i 
        k(id1,5)=k(id1,5)+mstu(5)*i 
        k(id2,4)=0  
        k(id2,5)=0  
      ENDIF 
  390 CONTINUE  
    
C...Transformation from CM frame.   
      IF(npa.GE.2) THEN 
        bex=ps(1)/ps(4) 
        bey=ps(2)/ps(4) 
        bez=ps(3)/ps(4) 
        ga=ps(4)/ps(5)  
        gabep=ga*(ga*(bex*p(ipa(1),1)+bey*p(ipa(1),2)+bez*p(ipa(1),3))  
     &  /(1.+ga)-p(ipa(1),4))   
      ELSE  
        bex=0.  
        bey=0.  
        bez=0.  
        gabep=0.    
      ENDIF 
      the=ulangl(p(ipa(1),3)+gabep*bez,sqrt((p(ipa(1),1)    
     &+gabep*bex)**2+(p(ipa(1),2)+gabep*bey)**2))   
      phi=ulangl(p(ipa(1),1)+gabep*bex,p(ipa(1),2)+gabep*bey)   
      IF(npa.EQ.3) THEN 
        chi=ulangl(cos(the)*cos(phi)*(p(ipa(2),1)+gabep*bex)+cos(the)*  
     &  sin(phi)*(p(ipa(2),2)+gabep*bey)-sin(the)*(p(ipa(2),3)+gabep*   
     &  bez),-sin(phi)*(p(ipa(2),1)+gabep*bex)+cos(phi)*(p(ipa(2),2)+   
     &  gabep*bey)) 
        CALL ludbrb(ns+1,n,0.,chi,0d0,0d0,0d0)  
      ENDIF 
      dbex=dble(bex)    
      dbey=dble(bey)    
      dbez=dble(bez)    
      CALL ludbrb(ns+1,n,the,phi,dbex,dbey,dbez)    
    
C...Decay vertex of shower. 
      DO 400 i=ns+1,n   
      DO 400 j=1,5  
  400 v(i,j)=v(ip1,j)   
    
C...Delete trivial shower, else connect initiators. 
      IF(n.EQ.ns+npa+iim) THEN  
        n=ns    
      ELSE  
        DO 410 ip=1,npa 
        k(ipa(ip),1)=14 
        k(ipa(ip),4)=k(ipa(ip),4)+ns+iim+ip 
        k(ipa(ip),5)=k(ipa(ip),5)+ns+iim+ip 
        k(ns+iim+ip,3)=ipa(ip)  
        IF(iim.EQ.1.AND.mstu(16).NE.2) k(ns+iim+ip,3)=ns+1  
        k(ns+iim+ip,4)=mstu(5)*ipa(ip)+k(ns+iim+ip,4)   
  410   k(ns+iim+ip,5)=mstu(5)*ipa(ip)+k(ns+iim+ip,5)   
      ENDIF 
    
      RETURN    
      END   
    
C*********************************************************************  
    
      SUBROUTINE luboei(NSAV)   
    
C...Purpose: to modify event so as to approximately take into account   
C...Bose-Einstein effects according to a simple phenomenological    
C...parametrization.    
      IMPLICIT DOUBLE PRECISION(d)  
      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/ 
      dimension dps(4),kfbe(9),nbe(0:9),bei(100)    
      DATA kfbe/211,-211,111,321,-321,130,310,221,331/  
    
C...Boost event to overall CM frame. Calculate CM energy.   
      IF((mstj(51).NE.1.AND.mstj(51).NE.2).OR.n-nsav.LE.1) RETURN   
      DO 100 j=1,4  
  100 dps(j)=0. 
      DO 120 i=1,n  
      IF(k(i,1).LE.0.OR.k(i,1).GT.10) goto 120  
      DO 110 j=1,4  
  110 dps(j)=dps(j)+p(i,j)  
  120 CONTINUE  
      CALL ludbrb(0,0,0.,0.,-dps(1)/dps(4),-dps(2)/dps(4),  
     &-dps(3)/dps(4))   
      pecm=0.   
      DO 130 i=1,n  
  130 IF(k(i,1).GE.1.AND.k(i,1).LE.10) pecm=pecm+p(i,4) 
    
C...Reserve copy of particles by species at end of record.  
      nbe(0)=n+mstu(3)  
      DO 160 ibe=1,min(9,mstj(51))  
      nbe(ibe)=nbe(ibe-1)   
      DO 150 i=nsav+1,n 
      IF(k(i,2).NE.kfbe(ibe)) goto 150  
      IF(k(i,1).LE.0.OR.k(i,1).GT.10) goto 150  
      IF(nbe(ibe).GE.mstu(4)-mstu(32)-5) THEN   
        CALL luerrm(11,'(LUBOEI:) no more memory left in LUJETS')   
        RETURN  
      ENDIF 
      nbe(ibe)=nbe(ibe)+1   
      k(nbe(ibe),1)=i   
      DO 140 j=1,3  
  140 p(nbe(ibe),j)=0.  
  150 CONTINUE  
  160 CONTINUE  
    
C...Tabulate integral for subsequent momentum shift.    
      DO 210 ibe=1,min(9,mstj(51))  
      IF(ibe.NE.1.AND.ibe.NE.4.AND.ibe.LE.7) goto 180   
      IF(ibe.EQ.1.AND.max(nbe(1)-nbe(0),nbe(2)-nbe(1),nbe(3)-nbe(2)).   
     &le.1) goto 180    
      IF(ibe.EQ.4.AND.max(nbe(4)-nbe(3),nbe(5)-nbe(4),nbe(6)-nbe(5),    
     &nbe(7)-nbe(6)).LE.1) goto 180 
      IF(ibe.GE.8.AND.nbe(ibe)-nbe(ibe-1).LE.1) goto 180    
      IF(ibe.EQ.1) pmhq=2.*ulmass(211)  
      IF(ibe.EQ.4) pmhq=2.*ulmass(321)  
      IF(ibe.EQ.8) pmhq=2.*ulmass(221)  
      IF(ibe.EQ.9) pmhq=2.*ulmass(331)  
      qdel=0.1*min(pmhq,parj(93))   
      IF(mstj(51).EQ.1) THEN    
        nbin=min(100,nint(9.*parj(93)/qdel))    
        beex=exp(0.5*qdel/parj(93)) 
        bert=exp(-qdel/parj(93))    
      ELSE  
        nbin=min(100,nint(3.*parj(93)/qdel))    
      ENDIF 
      DO 170 ibin=1,nbin    
      qbin=qdel*(ibin-0.5)  
      bei(ibin)=qdel*(qbin**2+qdel**2/12.)/sqrt(qbin**2+pmhq**2)    
      IF(mstj(51).EQ.1) THEN    
        beex=beex*bert  
        bei(ibin)=bei(ibin)*beex    
      ELSE  
        bei(ibin)=bei(ibin)*exp(-(qbin/parj(93))**2)    
      ENDIF 
  170 IF(ibin.GE.2) bei(ibin)=bei(ibin)+bei(ibin-1) 
    
C...Loop through particle pairs and find old relative momentum. 
  180 DO 200 i1m=nbe(ibe-1)+1,nbe(ibe)-1    
      i1=k(i1m,1)   
      DO 200 i2m=i1m+1,nbe(ibe) 
      i2=k(i2m,1)   
      q2old=max(0.,(p(i1,4)+p(i2,4))**2-(p(i1,1)+p(i2,1))**2-(p(i1,2)+  
     &p(i2,2))**2-(p(i1,3)+p(i2,3))**2-(p(i1,5)+p(i2,5))**2)    
      qold=sqrt(q2old)  
    
C...Calculate new relative momentum.    
      IF(qold.LT.0.5*qdel) THEN 
        qmov=qold/3.    
      ELSEIF(qold.LT.(nbin-0.1)*qdel) THEN  
        rbin=qold/qdel  
        ibin=rbin   
        rinp=(rbin**3-ibin**3)/(3*ibin*(ibin+1)+1)  
        qmov=(bei(ibin)+rinp*(bei(ibin+1)-bei(ibin)))*  
     &  sqrt(q2old+pmhq**2)/q2old   
      ELSE  
        qmov=bei(nbin)*sqrt(q2old+pmhq**2)/q2old    
      ENDIF 
      q2new=q2old*(qold/(qold+3.*parj(92)*qmov))**(2./3.)   
    
C...Calculate and save shift to be performed on three-momenta.  
      hc1=(p(i1,4)+p(i2,4))**2-(q2old-q2new)    
      hc2=(q2old-q2new)*(p(i1,4)-p(i2,4))**2    
      ha=0.5*(1.-sqrt(hc1*q2new/(hc1*q2old-hc2)))   
      DO 190 j=1,3  
      pd=ha*(p(i2,j)-p(i1,j))   
      p(i1m,j)=p(i1m,j)+pd  
  190 p(i2m,j)=p(i2m,j)-pd  
  200 CONTINUE  
  210 CONTINUE  
    
C...Shift momenta and recalculate energies. 
      DO 230 im=nbe(0)+1,nbe(min(9,mstj(51)))   
      i=k(im,1) 
      DO 220 j=1,3  
  220 p(i,j)=p(i,j)+p(im,j) 
  230 p(i,4)=sqrt(p(i,5)**2+p(i,1)**2+p(i,2)**2+p(i,3)**2)  
    
C...Rescale all momenta for energy conservation.    
      pes=0.    
      pqs=0.    
      DO 240 i=1,n  
      IF(k(i,1).LE.0.OR.k(i,1).GT.10) goto 240  
      pes=pes+p(i,4)    
      pqs=pqs+p(i,5)**2/p(i,4)  
  240 CONTINUE  
      fac=(pecm-pqs)/(pes-pqs)  
      DO 260 i=1,n  
      IF(k(i,1).LE.0.OR.k(i,1).GT.10) goto 260  
      DO 250 j=1,3  
  250 p(i,j)=fac*p(i,j) 
      p(i,4)=sqrt(p(i,5)**2+p(i,1)**2+p(i,2)**2+p(i,3)**2)  
  260 CONTINUE  
    
C...Boost back to correct reference frame.  
      CALL ludbrb(0,0,0.,0.,dps(1)/dps(4),dps(2)/dps(4),dps(3)/dps(4))  
    
      RETURN    
      END   
    
C*********************************************************************  
    
      FUNCTION ulmass(KF)   
    
C...Purpose: to give the mass of a particle/parton. 
      common/ludat1/mstu(200),paru(200),mstj(200),parj(200) 
      SAVE /ludat1/ 
      common/ludat2/kchg(500,3),pmas(500,4),parf(2000),vckm(4,4)    
      SAVE /ludat2/ 
    
C...Reset variables. Compressed code.   
      ulmass=0. 
      kfa=iabs(kf)  
      kc=lucomp(kf) 
      IF(kc.EQ.0) RETURN    
      parf(106)=pmas(6,1)   
      parf(107)=pmas(7,1)   
      parf(108)=pmas(8,1)   
    
C...Guarantee use of constituent masses for internal checks.    
      IF((mstj(93).EQ.1.OR.mstj(93).EQ.2).AND.kfa.LE.10) THEN   
        ulmass=parf(100+kfa)    
        IF(mstj(93).EQ.2) ulmass=max(0.,ulmass-parf(121))   
    
C...Masses that can be read directly off table. 
      ELSEIF(kfa.LE.100.OR.kc.LE.80.OR.kc.GT.100) THEN  
        ulmass=pmas(kc,1)   
    
C...Find constituent partons and their masses.  
      ELSE  
        kfla=mod(kfa/1000,10)   
        kflb=mod(kfa/100,10)    
        kflc=mod(kfa/10,10) 
        kfls=mod(kfa,10)    
        kflr=mod(kfa/10000,10)  
        pma=parf(100+kfla)  
        pmb=parf(100+kflb)  
        pmc=parf(100+kflc)  
    
C...Construct masses for various meson, diquark and baryon cases.   
        IF(kfla.EQ.0.AND.kflr.EQ.0.AND.kfls.LE.3) THEN  
          IF(kfls.EQ.1) pmspl=-3./(pmb*pmc) 
          IF(kfls.GE.3) pmspl=1./(pmb*pmc)  
          ulmass=parf(111)+pmb+pmc+parf(113)*parf(101)**2*pmspl 
        ELSEIF(kfla.EQ.0) THEN  
          kmul=2    
          IF(kfls.EQ.1) kmul=3  
          IF(kflr.EQ.2) kmul=4  
          IF(kfls.EQ.5) kmul=5  
          ulmass=parf(113+kmul)+pmb+pmc 
        ELSEIF(kflc.EQ.0) THEN  
          IF(kfls.EQ.1) pmspl=-3./(pma*pmb) 
          IF(kfls.EQ.3) pmspl=1./(pma*pmb)  
          ulmass=2.*parf(112)/3.+pma+pmb+parf(114)*parf(101)**2*pmspl   
          IF(mstj(93).EQ.1) ulmass=pma+pmb  
          IF(mstj(93).EQ.2) ulmass=max(0.,ulmass-parf(122)- 
     &    2.*parf(112)/3.)  
        ELSE    
          IF(kfls.EQ.2.AND.kfla.EQ.kflb) THEN   
            pmspl=1./(pma*pmb)-2./(pma*pmc)-2./(pmb*pmc)    
          ELSEIF(kfls.EQ.2.AND.kflb.GE.kflc) THEN   
            pmspl=-2./(pma*pmb)-2./(pma*pmc)+1./(pmb*pmc)   
          ELSEIF(kfls.EQ.2) THEN    
            pmspl=-3./(pmb*pmc) 
          ELSE  
            pmspl=1./(pma*pmb)+1./(pma*pmc)+1./(pmb*pmc)    
          ENDIF 
          ulmass=parf(112)+pma+pmb+pmc+parf(114)*parf(101)**2*pmspl 
        ENDIF   
      ENDIF 
    
C...Optional mass broadening according to truncated Breit-Wigner    
C...(either in m or in m^2).    
      IF(mstj(24).GE.1.AND.pmas(kc,2).GT.1e-4) THEN 
        IF(mstj(24).EQ.1.OR.(mstj(24).EQ.2.AND.kfa.GT.100)) THEN    
          ulmass=ulmass+0.5*pmas(kc,2)*tan((2.*rlu(0)-1.)*  
     &    atan(2.*pmas(kc,3)/pmas(kc,2)))   
        ELSE    
          pm0=ulmass    
          pmlow=atan((max(0.,pm0-pmas(kc,3))**2-pm0**2)/    
     &    (pm0*pmas(kc,2))) 
          pmupp=atan((pm0+pmas(kc,3))**2-pm0**2)/(pm0*pmas(kc,2))   
          ulmass=sqrt(max(0.,pm0**2+pm0*pmas(kc,2)*tan(pmlow+   
     &    (pmupp-pmlow)*rlu(0))))   
        ENDIF   
      ENDIF 
      mstj(93)=0    
    
      RETURN    
      END   
    
C*********************************************************************  
    
      SUBROUTINE luname(KF,CHAU)    
    
C...Purpose: to give the particle/parton name as a character string.    
      common/ludat1/mstu(200),paru(200),mstj(200),parj(200) 
      SAVE /ludat1/ 
      common/ludat2/kchg(500,3),pmas(500,4),parf(2000),vckm(4,4)    
      SAVE /ludat2/ 
      common/ludat4/chaf(500)   
      CHARACTER chaf*8  
      SAVE /ludat4/ 
      CHARACTER chau*16 
    
C...Initial values. Charge. Subdivide code. 
      chau=' '  
      kfa=iabs(kf)  
      kc=lucomp(kf) 
      IF(kc.EQ.0) RETURN    
      kq=luchge(kf) 
      kfla=mod(kfa/1000,10) 
      kflb=mod(kfa/100,10)  
      kflc=mod(kfa/10,10)   
      kfls=mod(kfa,10)  
      kflr=mod(kfa/10000,10)    
    
C...Read out root name and spin for simple particle.    
      IF(kfa.LE.100.OR.(kfa.GT.100.AND.kc.GT.100)) THEN 
        chau=chaf(kc)   
        len=0   
        DO 100 lem=1,8  
  100   IF(chau(lem:lem).NE.' ') len=lem    
    
C...Construct root name for diquark. Add on spin.   
      ELSEIF(kflc.EQ.0) THEN    
        chau(1:2)=chaf(kfla)(1:1)//chaf(kflb)(1:1)  
        IF(kfls.EQ.1) chau(3:4)='_0'    
        IF(kfls.EQ.3) chau(3:4)='_1'    
        len=4   
    
C...Construct root name for heavy meson. Add on spin and heavy flavour. 
      ELSEIF(kfla.EQ.0) THEN    
        IF(kflb.EQ.5) chau(1:1)='B' 
        IF(kflb.EQ.6) chau(1:1)='T' 
        IF(kflb.EQ.7) chau(1:1)='L' 
        IF(kflb.EQ.8) chau(1:1)='H' 
        len=1   
        IF(kflr.EQ.0.AND.kfls.EQ.1) THEN    
        ELSEIF(kflr.EQ.0.AND.kfls.EQ.3) THEN    
          chau(2:2)='*' 
          len=2 
        ELSEIF(kflr.EQ.1.AND.kfls.EQ.3) THEN    
          chau(2:3)='_1'    
          len=3 
        ELSEIF(kflr.EQ.1.AND.kfls.EQ.1) THEN    
          chau(2:4)='*_0'   
          len=4 
        ELSEIF(kflr.EQ.2) THEN  
          chau(2:4)='*_1'   
          len=4 
        ELSEIF(kfls.EQ.5) THEN  
          chau(2:4)='*_2'   
          len=4 
        ENDIF   
        IF(kflc.GE.3.AND.kflr.EQ.0.AND.kfls.LE.3) THEN  
          chau(len+1:len+2)='_'//chaf(kflc)(1:1)    
          len=len+2 
        ELSEIF(kflc.GE.3) THEN  
          chau(len+1:len+1)=chaf(kflc)(1:1) 
          len=len+1 
        ENDIF   
    
C...Construct root name and spin for heavy baryon.  
      ELSE  
        IF(kflb.LE.2.AND.kflc.LE.2) THEN    
          chau='Sigma ' 
          IF(kflc.GT.kflb) chau='Lambda'    
          IF(kfls.EQ.4) chau='Sigma*'   
          len=5 
          IF(chau(6:6).NE.' ') len=6    
        ELSEIF(kflb.LE.2.OR.kflc.LE.2) THEN 
          chau='Xi '    
          IF(kfla.GT.kflb.AND.kflb.GT.kflc) chau='Xi''' 
          IF(kfls.EQ.4) chau='Xi*'  
          len=2 
          IF(chau(3:3).NE.' ') len=3    
        ELSE    
          chau='Omega ' 
          IF(kfla.GT.kflb.AND.kflb.GT.kflc) chau='Omega'''  
          IF(kfls.EQ.4) chau='Omega*'   
          len=5 
          IF(chau(6:6).NE.' ') len=6    
        ENDIF   
    
C...Add on heavy flavour content for heavy baryon.  
        chau(len+1:len+2)='_'//chaf(kfla)(1:1)  
        len=len+2   
        IF(kflb.GE.kflc.AND.kflc.GE.4) THEN 
          chau(len+1:len+2)=chaf(kflb)(1:1)//chaf(kflc)(1:1)    
          len=len+2 
        ELSEIF(kflb.GE.kflc.AND.kflb.GE.4) THEN 
          chau(len+1:len+1)=chaf(kflb)(1:1) 
          len=len+1 
        ELSEIF(kflc.GT.kflb.AND.kflb.GE.4) THEN 
          chau(len+1:len+2)=chaf(kflc)(1:1)//chaf(kflb)(1:1)    
          len=len+2 
        ELSEIF(kflc.GT.kflb.AND.kflc.GE.4) THEN 
          chau(len+1:len+1)=chaf(kflc)(1:1) 
          len=len+1 
        ENDIF   
      ENDIF 
    
C...Add on bar sign for antiparticle (where necessary). 
      IF(kf.GT.0.OR.len.EQ.0) THEN  
      ELSEIF(kfa.GT.10.AND.kfa.LE.40.AND.kq.NE.0) THEN  
      ELSEIF(kfa.EQ.89.OR.(kfa.GE.91.AND.kfa.LE.99)) THEN   
      ELSEIF(kfa.GT.100.AND.kfla.EQ.0.AND.kq.NE.0) THEN 
      ELSEIF(mstu(15).LE.1) THEN    
        chau(len+1:len+1)='~'   
        len=len+1   
      ELSE  
        chau(len+1:len+3)='bar' 
        len=len+3   
      ENDIF 
    
C...Add on charge where applicable (conventional cases skipped).    
      IF(kq.EQ.6) chau(len+1:len+2)='++'    
      IF(kq.EQ.-6) chau(len+1:len+2)='--'   
      IF(kq.EQ.3) chau(len+1:len+1)='+' 
      IF(kq.EQ.-3) chau(len+1:len+1)='-'    
      IF(kq.EQ.0.AND.(kfa.LE.22.OR.len.EQ.0)) THEN  
      ELSEIF(kq.EQ.0.AND.(kfa.GE.81.AND.kfa.LE.100)) THEN   
      ELSEIF(kfa.GT.100.AND.kfla.EQ.0.AND.kflb.EQ.kflc.AND. 
     &kflb.NE.1) THEN   
      ELSEIF(kq.EQ.0) THEN  
        chau(len+1:len+1)='0'   
      ENDIF 
    
      RETURN    
      END   
    
C*********************************************************************  
    
      FUNCTION luchge(KF)   
    
C...Purpose: to give three times the charge for a particle/parton.  
      common/ludat2/kchg(500,3),pmas(500,4),parf(2000),vckm(4,4)    
      SAVE /ludat2/ 
    
C...Initial values. Simple case of direct readout.  
      luchge=0  
      kfa=iabs(kf)  
      kc=lucomp(kfa)    
      IF(kc.EQ.0) THEN  
      ELSEIF(kfa.LE.100.OR.kc.LE.80.OR.kc.GT.100) THEN  
        luchge=kchg(kc,1)   
    
C...Construction from quark content for heavy meson, diquark, baryon.   
      ELSEIF(mod(kfa/1000,10).EQ.0) THEN    
        luchge=(kchg(mod(kfa/100,10),1)-kchg(mod(kfa/10,10),1))*    
     &  (-1)**mod(kfa/100,10)   
      ELSEIF(mod(kfa/10,10).EQ.0) THEN  
        luchge=kchg(mod(kfa/1000,10),1)+kchg(mod(kfa/100,10),1) 
      ELSE  
        luchge=kchg(mod(kfa/1000,10),1)+kchg(mod(kfa/100,10),1)+    
     &  kchg(mod(kfa/10,10),1)  
      ENDIF 
    
C...Add on correct sign.    
      luchge=luchge*isign(1,kf) 
    
      RETURN    
      END   
    
C*********************************************************************  
    
      FUNCTION lucomp(KF)   
    
C...Purpose: to compress the standard KF codes for use in mass and decay    
C...arrays; also to check whether a given code actually is defined. 
      common/ludat2/kchg(500,3),pmas(500,4),parf(2000),vckm(4,4)    
      SAVE /ludat2/ 
    
C...Subdivide KF code into constituent pieces.  
      lucomp=0  
      kfa=iabs(kf)  
      kfla=mod(kfa/1000,10) 
      kflb=mod(kfa/100,10)  
      kflc=mod(kfa/10,10)   
      kfls=mod(kfa,10)  
      kflr=mod(kfa/10000,10)    
    
C...Simple cases: direct translation or special codes.  
      IF(kfa.EQ.0.OR.kfa.GE.100000) THEN    
      ELSEIF(kfa.LE.100) THEN   
        lucomp=kfa  
        IF(kf.LT.0.AND.kchg(kfa,3).EQ.0) lucomp=0   
      ELSEIF(kfls.EQ.0) THEN    
        IF(kf.EQ.130) lucomp=221    
        IF(kf.EQ.310) lucomp=222    
        IF(kfa.EQ.210) lucomp=281   
        IF(kfa.EQ.2110) lucomp=282  
        IF(kfa.EQ.2210) lucomp=283  
    
C...Mesons. 
      ELSEIF(kfa-10000*kflr.LT.1000) THEN   
        IF(kflb.EQ.0.OR.kflb.EQ.9.OR.kflc.EQ.0.OR.kflc.EQ.9) THEN   
        ELSEIF(kflb.LT.kflc) THEN   
        ELSEIF(kf.LT.0.AND.kflb.EQ.kflc) THEN   
        ELSEIF(kflb.EQ.kflc) THEN   
          IF(kflr.EQ.0.AND.kfls.EQ.1) THEN  
            lucomp=110+kflb 
          ELSEIF(kflr.EQ.0.AND.kfls.EQ.3) THEN  
            lucomp=130+kflb 
          ELSEIF(kflr.EQ.1.AND.kfls.EQ.3) THEN  
            lucomp=150+kflb 
          ELSEIF(kflr.EQ.1.AND.kfls.EQ.1) THEN  
            lucomp=170+kflb 
          ELSEIF(kflr.EQ.2.AND.kfls.EQ.3) THEN  
            lucomp=190+kflb 
          ELSEIF(kflr.EQ.0.AND.kfls.EQ.5) THEN  
            lucomp=210+kflb 
          ENDIF 
        ELSEIF(kflb.LE.5.AND.kflc.LE.3) THEN    
          IF(kflr.EQ.0.AND.kfls.EQ.1) THEN  
            lucomp=100+((kflb-1)*(kflb-2))/2+kflc   
          ELSEIF(kflr.EQ.0.AND.kfls.EQ.3) THEN  
            lucomp=120+((kflb-1)*(kflb-2))/2+kflc   
          ELSEIF(kflr.EQ.1.AND.kfls.EQ.3) THEN  
            lucomp=140+((kflb-1)*(kflb-2))/2+kflc   
          ELSEIF(kflr.EQ.1.AND.kfls.EQ.1) THEN  
            lucomp=160+((kflb-1)*(kflb-2))/2+kflc   
          ELSEIF(kflr.EQ.2.AND.kfls.EQ.3) THEN  
            lucomp=180+((kflb-1)*(kflb-2))/2+kflc   
          ELSEIF(kflr.EQ.0.AND.kfls.EQ.5) THEN  
            lucomp=200+((kflb-1)*(kflb-2))/2+kflc   
          ENDIF 
        ELSEIF((kfls.EQ.1.AND.kflr.LE.1).OR.(kfls.EQ.3.AND.kflr.LE.2).  
     &  or.(kfls.EQ.5.AND.kflr.EQ.0)) THEN  
          lucomp=80+kflb    
        ENDIF   
    
C...Diquarks.   
      ELSEIF((kflr.EQ.0.OR.kflr.EQ.1).AND.kflc.EQ.0) THEN   
        IF(kfls.NE.1.AND.kfls.NE.3) THEN    
        ELSEIF(kfla.EQ.9.OR.kflb.EQ.0.OR.kflb.EQ.9) THEN    
        ELSEIF(kfla.LT.kflb) THEN   
        ELSEIF(kfls.EQ.1.AND.kfla.EQ.kflb) THEN 
        ELSE    
          lucomp=90 
        ENDIF   
    
C...Spin 1/2 baryons.   
      ELSEIF(kflr.EQ.0.AND.kfls.EQ.2) THEN  
        IF(kfla.EQ.9.OR.kflb.EQ.0.OR.kflb.EQ.9.OR.kflc.EQ.9) THEN   
        ELSEIF(kfla.LE.kflc.OR.kfla.LT.kflb) THEN   
        ELSEIF(kfla.GE.6.OR.kflb.GE.4.OR.kflc.GE.4) THEN    
          lucomp=80+kfla    
        ELSEIF(kflb.LT.kflc) THEN   
          lucomp=300+((kfla+1)*kfla*(kfla-1))/6+(kflc*(kflc-1))/2+kflb  
        ELSE    
          lucomp=330+((kfla+1)*kfla*(kfla-1))/6+(kflb*(kflb-1))/2+kflc  
        ENDIF   
    
C...Spin 3/2 baryons.   
      ELSEIF(kflr.EQ.0.AND.kfls.EQ.4) THEN  
        IF(kfla.EQ.9.OR.kflb.EQ.0.OR.kflb.EQ.9.OR.kflc.EQ.9) THEN   
        ELSEIF(kfla.LT.kflb.OR.kflb.LT.kflc) THEN   
        ELSEIF(kfla.GE.6.OR.kflb.GE.4) THEN 
          lucomp=80+kfla    
        ELSE    
          lucomp=360+((kfla+1)*kfla*(kfla-1))/6+(kflb*(kflb-1))/2+kflc  
        ENDIF   
      ENDIF 
    
      RETURN    
      END   
    
C*********************************************************************  
    
      SUBROUTINE luerrm(MERR,CHMESS)    
    
C...Purpose: to inform user of errors in program execution. 
      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/ 
      CHARACTER chmess*(*)  
    
C...Write first few warnings, then be silent.   
      IF(merr.LE.10) THEN   
        mstu(27)=mstu(27)+1 
        mstu(28)=merr   
        IF(mstu(25).EQ.1.AND.mstu(27).LE.mstu(26)) WRITE(mstu(11),1000) 
     &  merr,mstu(31),chmess    
    
C...Write first few errors, then be silent or stop program. 
      ELSEIF(merr.LE.20) THEN   
        mstu(23)=mstu(23)+1 
        mstu(24)=merr-10    
        IF(mstu(21).GE.1.AND.mstu(23).LE.mstu(22)) WRITE(mstu(11),1100) 
     &  merr-10,mstu(31),chmess 
        IF(mstu(21).GE.2.AND.mstu(23).GT.mstu(22)) THEN 
          WRITE(mstu(11),1100) merr-10,mstu(31),chmess  
          WRITE(mstu(11),1200)  
          IF(merr.NE.17) CALL lulist(2) 
          stop  
        ENDIF   
    
C...Stop program in case of irreparable error.  
      ELSE  
        WRITE(mstu(11),1300) merr-20,mstu(31),chmess    
        stop    
      ENDIF 
    
C...Formats for output. 
 1000 FORMAT(/5x,'Advisory warning type',i2,' given after',i6,  
     &' LUEXEC calls:'/5x,a)    
 1100 FORMAT(/5x,'Error type',i2,' has occured after',i6,   
     &' LUEXEC calls:'/5x,a)    
 1200 FORMAT(5x,'Execution will be stopped after listing of last ', 
     &'event!') 
 1300 FORMAT(/5x,'Fatal error type',i2,' has occured after',i6, 
     &' LUEXEC calls:'/5x,a/5x,'Execution will now be stopped!')    
    
      RETURN    
      END   
    
C*********************************************************************  
    
      FUNCTION ulalps(Q2)   
    
C...Purpose: to give the value of alpha_strong. 
      common/ludat1/mstu(200),paru(200),mstj(200),parj(200) 
      SAVE /ludat1/ 
      common/ludat2/kchg(500,3),pmas(500,4),parf(2000),vckm(4,4)    
      SAVE /ludat2/ 
    
C...Constant alpha_strong trivial.  
      IF(mstu(111).LE.0) THEN   
        ulalps=paru(111)    
        mstu(118)=mstu(112) 
        paru(117)=0.    
        paru(118)=paru(111) 
        RETURN  
      ENDIF 
    
C...Find effective Q2, number of flavours and Lambda.   
      q2eff=q2  
      IF(mstu(115).GE.2) q2eff=max(q2,paru(114))    
      nf=mstu(112)  
      alam2=paru(112)**2    
  100 IF(nf.GT.max(2,mstu(113))) THEN   
        q2thr=paru(113)*pmas(nf,1)**2   
        IF(q2eff.LT.q2thr) THEN 
          nf=nf-1   
          alam2=alam2*(q2thr/alam2)**(2./(33.-2.*nf))   
          goto 100  
        ENDIF   
      ENDIF 
  110 IF(nf.LT.min(8,mstu(114))) THEN   
        q2thr=paru(113)*pmas(nf+1,1)**2 
        IF(q2eff.GT.q2thr) THEN 
          nf=nf+1   
          alam2=alam2*(alam2/q2thr)**(2./(33.-2.*nf))   
          goto 110  
        ENDIF   
      ENDIF 
      IF(mstu(115).EQ.1) q2eff=q2eff+alam2  
      paru(117)=sqrt(alam2) 
    
C...Evaluate first or second order alpha_strong.    
      b0=(33.-2.*nf)/6. 
      algq=log(q2eff/alam2) 
      IF(mstu(111).EQ.1) THEN   
        ulalps=paru(2)/(b0*algq)    
      ELSE  
        b1=(153.-19.*nf)/6. 
        ulalps=paru(2)/(b0*algq)*(1.-b1*log(algq)/(b0**2*algq)) 
      ENDIF 
      mstu(118)=nf  
      paru(118)=ulalps  
    
      RETURN    
      END   
    
C*********************************************************************  
    
      FUNCTION ulangl(X,Y)  
    
C...Purpose: to reconstruct an angle from given x and y coordinates.    
      common/ludat1/mstu(200),paru(200),mstj(200),parj(200) 
      SAVE /ludat1/ 
    
      ulangl=0. 
      r=sqrt(x**2+y**2) 
      IF(r.LT.1e-20) RETURN 
      IF(abs(x)/r.LT.0.8) THEN  
        ulangl=sign(acos(x/r),y)    
      ELSE  
        ulangl=asin(y/r)    
        IF(x.LT.0..AND.ulangl.GE.0.) THEN   
          ulangl=paru(1)-ulangl 
        ELSEIF(x.LT.0.) THEN    
          ulangl=-paru(1)-ulangl    
        ENDIF   
      ENDIF 
    
      RETURN    
      END   
    
C*********************************************************************  
    
      FUNCTION rlu(IDUM)    
    
C...Purpose: to generate random numbers uniformly distributed between   
C...0 and 1, excluding the endpoints.   
      common/ludatr/mrlu(6),rrlu(100)   
      SAVE /ludatr/ 
      equivalence(mrlu1,mrlu(1)),(mrlu2,mrlu(2)),(mrlu3,mrlu(3)),  
     &(mrlu4,mrlu(4)),(mrlu5,mrlu(5)),(mrlu6,mrlu(6)),  
     &(rrlu98,rrlu(98)),(rrlu99,rrlu(99)),(rrlu00,rrlu(100))    
    
C...Initialize generation from given seed.  
      IF(mrlu2.EQ.0) THEN   
        ij=mod(mrlu1/30082,31329)   
        kl=mod(mrlu1,30082) 
        i=mod(ij/177,177)+2 
        j=mod(ij,177)+2 
        k=mod(kl/169,178)+1 
        l=mod(kl,169)   
        DO 110 ii=1,97  
        s=0.    
        t=0.5   
        DO 100 jj=1,24  
        m=mod(mod(i*j,179)*k,179)   
        i=j 
        j=k 
        k=m 
        l=mod(53*l+1,169)   
        IF(mod(l*m,64).GE.32) s=s+t 
  100   t=0.5*t 
  110   rrlu(ii)=s  
        twom24=1.   
        DO 120 i24=1,24 
  120   twom24=0.5*twom24   
        rrlu98=362436.*twom24   
        rrlu99=7654321.*twom24  
        rrlu00=16777213.*twom24 
        mrlu2=1 
        mrlu3=0 
        mrlu4=97    
        mrlu5=33    
      ENDIF 
    
C...Generate next random number.    
  130 runi=rrlu(mrlu4)-rrlu(mrlu5)  
      IF(runi.LT.0.) runi=runi+1.   
      rrlu(mrlu4)=runi  
      mrlu4=mrlu4-1 
      IF(mrlu4.EQ.0) mrlu4=97   
      mrlu5=mrlu5-1 
      IF(mrlu5.EQ.0) mrlu5=97   
      rrlu98=rrlu98-rrlu99  
      IF(rrlu98.LT.0.) rrlu98=rrlu98+rrlu00 
      runi=runi-rrlu98  
      IF(runi.LT.0.) runi=runi+1.   
      IF(runi.LE.0.OR.runi.GE.1.) goto 130  
    
C...Update counters. Random number to output.   
      mrlu3=mrlu3+1 
      IF(mrlu3.EQ.1000000000) THEN  
        mrlu2=mrlu2+1   
        mrlu3=0 
      ENDIF 
      rlu=runi  
    
      RETURN    
      END   
    
C*********************************************************************  
    
      SUBROUTINE rluget(LFN,MOVE)   
    
C...Purpose: to dump the state of the random number generator on a file 
C...for subsequent startup from this state onwards. 
      common/ludatr/mrlu(6),rrlu(100)   
      SAVE /ludatr/ 
      CHARACTER cherr*8 
    
C...Backspace required number of records (or as many as there are). 
      IF(move.LT.0) THEN    
        nbck=min(mrlu(6),-move) 
        DO 100 ibck=1,nbck  
  100   backspace(lfn,err=110,iostat=ierr)  
        mrlu(6)=mrlu(6)-nbck    
      ENDIF 
    
C...Unformatted write on unit LFN.  
      WRITE(lfn,err=110,iostat=ierr) (mrlu(i1),i1=1,5), 
     &(rrlu(i2),i2=1,100)   
      mrlu(6)=mrlu(6)+1 
      RETURN    
    
C...Write error.    
  110 WRITE(cherr,'(I8)') ierr  
      CALL luerrm(18,'(RLUGET:) error when accessing file, IOSTAT ='//  
     &cherr)    
    
      RETURN    
      END   
    
C*********************************************************************  
    
      SUBROUTINE rluset(LFN,MOVE)   
    
C...Purpose: to read a state of the random number generator from a file 
C...for subsequent generation from this state onwards.  
      common/ludatr/mrlu(6),rrlu(100)   
      SAVE /ludatr/ 
      CHARACTER cherr*8 
    
C...Backspace required number of records (or as many as there are). 
      IF(move.LT.0) THEN    
        nbck=min(mrlu(6),-move) 
        DO 100 ibck=1,nbck  
  100   backspace(lfn,err=120,iostat=ierr)  
        mrlu(6)=mrlu(6)-nbck    
      ENDIF 
    
C...Unformatted read from unit LFN. 
      nfor=1+max(0,move)    
      DO 110 ifor=1,nfor    
  110 READ(lfn,err=120,iostat=ierr) (mrlu(i1),i1=1,5),  
     &(rrlu(i2),i2=1,100)   
      mrlu(6)=mrlu(6)+nfor  
      RETURN    
    
C...Write error.    
  120 WRITE(cherr,'(I8)') ierr  
      CALL luerrm(18,'(RLUSET:) error when accessing file, IOSTAT ='//  
     &cherr)    
    
      RETURN    
      END   
    
C*********************************************************************  
    
      SUBROUTINE lurobo(THE,PHI,BEX,BEY,BEZ)    
    
C...Purpose: to perform rotations and boosts.   
      IMPLICIT DOUBLE PRECISION(d)  
      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/ 
      dimension rot(3,3),pr(3),vr(3),dp(4),dv(4)    
    
C...Find range of rotation/boost. Convert boost to double precision.    
      imin=1    
      IF(mstu(1).GT.0) imin=mstu(1) 
      imax=n    
      IF(mstu(2).GT.0) imax=mstu(2) 
      dbx=bex   
      dby=bey   
      dbz=bez   
      goto 100  
    
C...Entry for specific range and double precision boost.    
      entry ludbrb(imi,ima,the,phi,dbex,dbey,dbez)  
      imin=imi  
      IF(imin.LE.0) imin=1  
      imax=ima  
      IF(imax.LE.0) imax=n  
      dbx=dbex  
      dby=dbey  
      dbz=dbez  
    
C...Check range of rotation/boost.  
  100 IF(imin.GT.mstu(4).OR.imax.GT.mstu(4)) THEN   
        CALL luerrm(11,'(LUROBO:) range outside LUJETS memory') 
        RETURN  
      ENDIF 
    
C...Rotate, typically from z axis to direction (theta,phi). 
      IF(the**2+phi**2.GT.1e-20) THEN   
        rot(1,1)=cos(the)*cos(phi)  
        rot(1,2)=-sin(phi)  
        rot(1,3)=sin(the)*cos(phi)  
        rot(2,1)=cos(the)*sin(phi)  
        rot(2,2)=cos(phi)   
        rot(2,3)=sin(the)*sin(phi)  
        rot(3,1)=-sin(the)  
        rot(3,2)=0. 
        rot(3,3)=cos(the)   
        DO 130 i=imin,imax  
        IF(k(i,1).LE.0) goto 130    
        DO 110 j=1,3    
        pr(j)=p(i,j)    
  110   vr(j)=v(i,j)    
        DO 120 j=1,3    
        p(i,j)=rot(j,1)*pr(1)+rot(j,2)*pr(2)+rot(j,3)*pr(3) 
  120   v(i,j)=rot(j,1)*vr(1)+rot(j,2)*vr(2)+rot(j,3)*vr(3) 
  130   CONTINUE    
      ENDIF 
    
C...Boost, typically from rest to momentum/energy=beta. 
      IF(dbx**2+dby**2+dbz**2.GT.1e-20) THEN    
        db=sqrt(dbx**2+dby**2+dbz**2)   
        IF(db.GT.0.99999999d0) THEN 
C...Rescale boost vector if too close to unity. 
          CALL luerrm(3,'(LUROBO:) boost vector too large') 
          dbx=dbx*(0.99999999d0/db) 
          dby=dby*(0.99999999d0/db) 
          dbz=dbz*(0.99999999d0/db) 
          db=0.99999999d0   
        ENDIF   
        dga=1d0/sqrt(1d0-db**2) 
        DO 150 i=imin,imax  
        IF(k(i,1).LE.0) goto 150    
        DO 140 j=1,4    
        dp(j)=p(i,j)    
  140   dv(j)=v(i,j)    
        dbp=dbx*dp(1)+dby*dp(2)+dbz*dp(3)   
        dgabp=dga*(dga*dbp/(1d0+dga)+dp(4)) 
        p(i,1)=dp(1)+dgabp*dbx  
        p(i,2)=dp(2)+dgabp*dby  
        p(i,3)=dp(3)+dgabp*dbz  
        p(i,4)=dga*(dp(4)+dbp)  
        dbv=dbx*dv(1)+dby*dv(2)+dbz*dv(3)   
        dgabv=dga*(dga*dbv/(1d0+dga)+dv(4)) 
        v(i,1)=dv(1)+dgabv*dbx  
        v(i,2)=dv(2)+dgabv*dby  
        v(i,3)=dv(3)+dgabv*dbz  
        v(i,4)=dga*(dv(4)+dbv)  
  150   CONTINUE    
      ENDIF 
    
      RETURN    
      END   
    
C*********************************************************************  
C THIS SUBROUTINE IS ONLY FOR THE USE OF HIJING TO ROTATE OR BOOST
C THE FOUR MOMENTUM ONLY
C*********************************************************************
    
      SUBROUTINE hirobo(THE,PHI,BEX,BEY,BEZ)    
    
C...Purpose: to perform rotations and boosts.   
      IMPLICIT DOUBLE PRECISION(d)  
      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/ 
      dimension rot(3,3),pr(3),vr(3),dp(4),dv(4)    
    
C...Find range of rotation/boost. Convert boost to double precision.    
      imin=1    
      IF(mstu(1).GT.0) imin=mstu(1) 
      imax=n    
      IF(mstu(2).GT.0) imax=mstu(2) 
      dbx=bex   
      dby=bey   
      dbz=bez   
    
C...Check range of rotation/boost.  
      IF(imin.GT.mstu(4).OR.imax.GT.mstu(4)) THEN   
        CALL luerrm(11,'(LUROBO:) range outside LUJETS memory') 
        RETURN  
      ENDIF 
    
C...Rotate, typically from z axis to direction (theta,phi). 
      IF(the**2+phi**2.GT.1e-20) THEN   
        rot(1,1)=cos(the)*cos(phi)  
        rot(1,2)=-sin(phi)  
        rot(1,3)=sin(the)*cos(phi)  
        rot(2,1)=cos(the)*sin(phi)  
        rot(2,2)=cos(phi)   
        rot(2,3)=sin(the)*sin(phi)  
        rot(3,1)=-sin(the)  
        rot(3,2)=0. 
        rot(3,3)=cos(the)   
        DO 130 i=imin,imax  
        IF(k(i,1).LE.0) goto 130    
        DO 110 j=1,3    
  110   pr(j)=p(i,j)   
        DO 120 j=1,3    
  120   p(i,j)=rot(j,1)*pr(1)+rot(j,2)*pr(2)+rot(j,3)*pr(3) 
  130   CONTINUE    
      ENDIF 
    
C...Boost, typically from rest to momentum/energy=beta. 
      IF(dbx**2+dby**2+dbz**2.GT.1e-20) THEN    
        db=sqrt(dbx**2+dby**2+dbz**2)   
        IF(db.GT.0.99999999d0) THEN 
C...Rescale boost vector if too close to unity. 
          CALL luerrm(3,'(LUROBO:) boost vector too large') 
          dbx=dbx*(0.99999999d0/db) 
          dby=dby*(0.99999999d0/db) 
          dbz=dbz*(0.99999999d0/db) 
          db=0.99999999d0   
        ENDIF   
        dga=1d0/sqrt(1d0-db**2) 
        DO 150 i=imin,imax  
        IF(k(i,1).LE.0) goto 150    
        DO 140 j=1,4    
  140   dp(j)=p(i,j)    
        dbp=dbx*dp(1)+dby*dp(2)+dbz*dp(3)   
        dgabp=dga*(dga*dbp/(1d0+dga)+dp(4)) 
        p(i,1)=dp(1)+dgabp*dbx  
        p(i,2)=dp(2)+dgabp*dby  
        p(i,3)=dp(3)+dgabp*dbz  
        p(i,4)=dga*(dp(4)+dbp)  
  150   CONTINUE    
      ENDIF 
    
      RETURN    
      END   
    
C*********************************************************************  
    
      SUBROUTINE luedit(MEDIT)  
    
C...Purpose: to perform global manipulations on the event record,   
C...in particular to exclude unstable or undetectable partons/particles.    
      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/ludat2/kchg(500,3),pmas(500,4),parf(2000),vckm(4,4)    
      SAVE /ludat2/ 
      dimension ns(2),pts(2),pls(2) 
    
C...Remove unwanted partons/particles.  
      IF((medit.GE.0.AND.medit.LE.3).OR.medit.EQ.5) THEN    
        imax=n  
        IF(mstu(2).GT.0) imax=mstu(2)   
        i1=max(1,mstu(1))-1 
        DO 110 i=max(1,mstu(1)),imax    
        IF(k(i,1).EQ.0.OR.k(i,1).GT.20) goto 110    
        IF(medit.EQ.1) THEN 
          IF(k(i,1).GT.10) goto 110 
        ELSEIF(medit.EQ.2) THEN 
          IF(k(i,1).GT.10) goto 110 
          kc=lucomp(k(i,2)) 
          IF(kc.EQ.0.OR.kc.EQ.12.OR.kc.EQ.14.OR.kc.EQ.16.OR.kc.EQ.18)   
     &    goto 110  
        ELSEIF(medit.EQ.3) THEN 
          IF(k(i,1).GT.10) goto 110 
          kc=lucomp(k(i,2)) 
          IF(kc.EQ.0) goto 110  
          IF(kchg(kc,2).EQ.0.AND.luchge(k(i,2)).EQ.0) goto 110  
        ELSEIF(medit.EQ.5) THEN 
          IF(k(i,1).EQ.13.OR.k(i,1).EQ.14) goto 110 
          kc=lucomp(k(i,2)) 
          IF(kc.EQ.0) goto 110  
          IF(k(i,1).GE.11.AND.kchg(kc,2).EQ.0) goto 110 
        ENDIF   
    
C...Pack remaining partons/particles. Origin no longer known.   
        i1=i1+1 
        DO 100 j=1,5    
        k(i1,j)=k(i,j)  
        p(i1,j)=p(i,j)  
  100   v(i1,j)=v(i,j)  
        k(i1,3)=0   
  110   CONTINUE    
        n=i1    
    
C...Selective removal of class of entries. New position of retained.    
      ELSEIF(medit.GE.11.AND.medit.LE.15) THEN  
        i1=0    
        DO 120 i=1,n    
        k(i,3)=mod(k(i,3),mstu(5))  
        IF(medit.EQ.11.AND.k(i,1).LT.0) goto 120    
        IF(medit.EQ.12.AND.k(i,1).EQ.0) goto 120    
        IF(medit.EQ.13.AND.(k(i,1).EQ.11.OR.k(i,1).EQ.12.OR.    
     &  k(i,1).EQ.15).AND.k(i,2).NE.94) goto 120    
        IF(medit.EQ.14.AND.(k(i,1).EQ.13.OR.k(i,1).EQ.14.OR.    
     &  k(i,2).EQ.94)) goto 120 
        IF(medit.EQ.15.AND.k(i,1).GE.21) goto 120   
        i1=i1+1 
        k(i,3)=k(i,3)+mstu(5)*i1    
  120   CONTINUE    
    
C...Find new event history information and replace old. 
        DO 140 i=1,n    
        IF(k(i,1).LE.0.OR.k(i,1).GT.20.OR.k(i,3)/mstu(5).EQ.0) goto 140 
        id=i    
  130   im=mod(k(id,3),mstu(5)) 
        IF(medit.EQ.13.AND.im.GT.0.AND.im.LE.n) THEN    
          IF((k(im,1).EQ.11.OR.k(im,1).EQ.12.OR.k(im,1).EQ.15).AND. 
     &    k(im,2).NE.94) THEN   
            id=im   
            goto 130    
          ENDIF 
        ELSEIF(medit.EQ.14.AND.im.GT.0.AND.im.LE.n) THEN    
          IF(k(im,1).EQ.13.OR.k(im,1).EQ.14.OR.k(im,2).EQ.94) THEN  
            id=im   
            goto 130    
          ENDIF 
        ENDIF   
        k(i,3)=mstu(5)*(k(i,3)/mstu(5)) 
        IF(im.NE.0) k(i,3)=k(i,3)+k(im,3)/mstu(5)   
        IF(k(i,1).NE.3.AND.k(i,1).NE.13.AND.k(i,1).NE.14) THEN  
          IF(k(i,4).GT.0.AND.k(i,4).LE.mstu(4)) k(i,4)= 
     &    k(k(i,4),3)/mstu(5)   
          IF(k(i,5).GT.0.AND.k(i,5).LE.mstu(4)) k(i,5)= 
     &    k(k(i,5),3)/mstu(5)   
        ELSE    
          kcm=mod(k(i,4)/mstu(5),mstu(5))   
          IF(kcm.GT.0.AND.kcm.LE.mstu(4)) kcm=k(kcm,3)/mstu(5)  
          kcd=mod(k(i,4),mstu(5))   
          IF(kcd.GT.0.AND.kcd.LE.mstu(4)) kcd=k(kcd,3)/mstu(5)  
          k(i,4)=mstu(5)**2*(k(i,4)/mstu(5)**2)+mstu(5)*kcm+kcd 
          kcm=mod(k(i,5)/mstu(5),mstu(5))   
          IF(kcm.GT.0.AND.kcm.LE.mstu(4)) kcm=k(kcm,3)/mstu(5)  
          kcd=mod(k(i,5),mstu(5))   
          IF(kcd.GT.0.AND.kcd.LE.mstu(4)) kcd=k(kcd,3)/mstu(5)  
          k(i,5)=mstu(5)**2*(k(i,5)/mstu(5)**2)+mstu(5)*kcm+kcd 
        ENDIF   
  140   CONTINUE    
    
C...Pack remaining entries. 
        i1=0    
        DO 160 i=1,n    
        IF(k(i,3)/mstu(5).EQ.0) goto 160    
        i1=i1+1 
        DO 150 j=1,5    
        k(i1,j)=k(i,j)  
        p(i1,j)=p(i,j)  
  150   v(i1,j)=v(i,j)  
        k(i1,3)=mod(k(i1,3),mstu(5))    
  160   CONTINUE    
        n=i1    
    
C...Save top entries at bottom of LUJETS commonblock.   
      ELSEIF(medit.EQ.21) THEN  
        IF(2*n.GE.mstu(4)) THEN 
          CALL luerrm(11,'(LUEDIT:) no more memory left in LUJETS') 
          RETURN    
        ENDIF   
        DO 170 i=1,n    
        DO 170 j=1,5    
        k(mstu(4)-i,j)=k(i,j)   
        p(mstu(4)-i,j)=p(i,j)   
  170   v(mstu(4)-i,j)=v(i,j)   
        mstu(32)=n  
    
C...Restore bottom entries of commonblock LUJETS to top.    
      ELSEIF(medit.EQ.22) THEN  
        DO 180 i=1,mstu(32) 
        DO 180 j=1,5    
        k(i,j)=k(mstu(4)-i,j)   
        p(i,j)=p(mstu(4)-i,j)   
  180   v(i,j)=v(mstu(4)-i,j)   
        n=mstu(32)  
    
C...Mark primary entries at top of commonblock LUJETS as untreated. 
      ELSEIF(medit.EQ.23) THEN  
        i1=0    
        DO 190 i=1,n    
        kh=k(i,3)   
        IF(kh.GE.1) THEN    
          IF(k(kh,1).GT.20) kh=0    
        ENDIF   
        IF(kh.NE.0) goto 200    
        i1=i1+1 
  190   IF(k(i,1).GT.10.AND.k(i,1).LE.20) k(i,1)=k(i,1)-10  
  200   n=i1    
    
C...Place largest axis along z axis and second largest in xy plane. 
      ELSEIF(medit.EQ.31.OR.medit.EQ.32) THEN   
        CALL ludbrb(1,n+mstu(3),0.,-ulangl(p(mstu(61),1),   
     &  p(mstu(61),2)),0d0,0d0,0d0) 
        CALL ludbrb(1,n+mstu(3),-ulangl(p(mstu(61),3),  
     &  p(mstu(61),1)),0.,0d0,0d0,0d0)  
        CALL ludbrb(1,n+mstu(3),0.,-ulangl(p(mstu(61)+1,1), 
     &  p(mstu(61)+1,2)),0d0,0d0,0d0)   
        IF(medit.EQ.31) RETURN  
    
C...Rotate to put slim jet along +z axis.   
        DO 210 is=1,2   
        ns(is)=0    
        pts(is)=0.  
  210   pls(is)=0.  
        DO 220 i=1,n    
        IF(k(i,1).LE.0.OR.k(i,1).GT.10) goto 220    
        IF(mstu(41).GE.2) THEN  
          kc=lucomp(k(i,2)) 
          IF(kc.EQ.0.OR.kc.EQ.12.OR.kc.EQ.14.OR.kc.EQ.16.OR.    
     &    kc.EQ.18) goto 220    
          IF(mstu(41).GE.3.AND.kchg(kc,2).EQ.0.AND.luchge(k(i,2)).EQ.0) 
     &    goto 220  
        ENDIF   
        is=2.-sign(0.5,p(i,3))  
        ns(is)=ns(is)+1 
        pts(is)=pts(is)+sqrt(p(i,1)**2+p(i,2)**2)   
  220   CONTINUE    
        IF(ns(1)*pts(2)**2.LT.ns(2)*pts(1)**2)  
     &  CALL ludbrb(1,n+mstu(3),paru(1),0.,0d0,0d0,0d0) 
    
C...Rotate to put second largest jet into -z,+x quadrant.   
        DO 230 i=1,n    
        IF(p(i,3).GE.0.) goto 230   
        IF(k(i,1).LE.0.OR.k(i,1).GT.10) goto 230    
        IF(mstu(41).GE.2) THEN  
          kc=lucomp(k(i,2)) 
          IF(kc.EQ.0.OR.kc.EQ.12.OR.kc.EQ.14.OR.kc.EQ.16.OR.    
     &    kc.EQ.18) goto 230    
          IF(mstu(41).GE.3.AND.kchg(kc,2).EQ.0.AND.luchge(k(i,2)).EQ.0) 
     &    goto 230  
        ENDIF   
        is=2.-sign(0.5,p(i,1))  
        pls(is)=pls(is)-p(i,3)  
  230   CONTINUE    
        IF(pls(2).GT.pls(1)) CALL ludbrb(1,n+mstu(3),0.,paru(1),    
     &  0d0,0d0,0d0)    
      ENDIF 
    
      RETURN    
      END   
    
C*********************************************************************  
    
      SUBROUTINE lulist(MLIST)  
    
C...Purpose: to give program heading, or list an event, or particle 
C...data, or current parameter values.  
      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/ludat2/kchg(500,3),pmas(500,4),parf(2000),vckm(4,4)    
      SAVE /ludat2/ 
      common/ludat3/mdcy(500,3),mdme(2000,2),brat(2000),kfdp(2000,5)    
      SAVE /ludat3/ 
      CHARACTER chap*16,chac*16,chan*16,chad(5)*16,chmo(12)*3,chdl(7)*4 
      dimension ps(6)   
      DATA chmo/'Jan','Feb','Mar','Apr','May','Jun','Jul','Aug','Sep',  
     &'Oct','Nov','Dec'/,chdl/'(())',' ','()','!!','<>','==','(==)'/    
    
C...Initialization printout: version number and date of last change.    
C      IF(MLIST.EQ.0.OR.MSTU(12).EQ.1) THEN  
C        WRITE(MSTU(11),1000) MSTU(181),MSTU(182),MSTU(185), 
C     &  CHMO(MSTU(184)),MSTU(183)   
C        MSTU(12)=0  
C        IF(MLIST.EQ.0) RETURN   
C      ENDIF 
    
C...List event data, including additional lines after N.    
      IF(mlist.GE.1.AND.mlist.LE.3) THEN    
        IF(mlist.EQ.1) WRITE(mstu(11),1100) 
        IF(mlist.EQ.2) WRITE(mstu(11),1200) 
        IF(mlist.EQ.3) WRITE(mstu(11),1300) 
        lmx=12  
        IF(mlist.GE.2) lmx=16   
        istr=0  
        imax=n  
        IF(mstu(2).GT.0) imax=mstu(2)   
        DO 120 i=max(1,mstu(1)),max(imax,n+max(0,mstu(3)))  
        IF((i.GT.imax.AND.i.LE.n).OR.k(i,1).LT.0) goto 120  
    
C...Get particle name, pad it and check it is not too long. 
        CALL luname(k(i,2),chap)    
        len=0   
        DO 100 lem=1,16 
  100   IF(chap(lem:lem).NE.' ') len=lem    
        mdl=(k(i,1)+19)/10  
        ldl=0   
        IF(mdl.EQ.2.OR.mdl.GE.8) THEN   
          chac=chap 
          IF(len.GT.lmx) chac(lmx:lmx)='?'  
        ELSE    
          ldl=1 
          IF(mdl.EQ.1.OR.mdl.EQ.7) ldl=2    
          IF(len.EQ.0) THEN 
            chac=chdl(mdl)(1:2*ldl)//' '    
          ELSE  
            chac=chdl(mdl)(1:ldl)//chap(1:min(len,lmx-2*ldl))// 
     &      chdl(mdl)(ldl+1:2*ldl)//' ' 
            IF(len+2*ldl.GT.lmx) chac(lmx:lmx)='?'  
          ENDIF 
        ENDIF   
    
C...Add information on string connection.   
        IF(k(i,1).EQ.1.OR.k(i,1).EQ.2.OR.k(i,1).EQ.11.OR.k(i,1).EQ.12)  
     &  THEN    
          kc=lucomp(k(i,2)) 
          kcc=0 
          IF(kc.NE.0) kcc=kchg(kc,2)    
          IF(kcc.NE.0.AND.istr.EQ.0) THEN   
            istr=1  
            IF(len+2*ldl+3.LE.lmx) chac(lmx-1:lmx-1)='A'    
          ELSEIF(kcc.NE.0.AND.(k(i,1).EQ.2.OR.k(i,1).EQ.12)) THEN   
            IF(len+2*ldl+3.LE.lmx) chac(lmx-1:lmx-1)='I'    
          ELSEIF(kcc.NE.0) THEN 
            istr=0  
            IF(len+2*ldl+3.LE.lmx) chac(lmx-1:lmx-1)='V'    
          ENDIF 
        ENDIF   
    
C...Write data for particle/jet.    
        IF(mlist.EQ.1.AND.abs(p(i,4)).LT.9999.) THEN    
          WRITE(mstu(11),1400) i,chac(1:12),(k(i,j1),j1=1,3),   
     &    (p(i,j2),j2=1,5)  
        ELSEIF(mlist.EQ.1.AND.abs(p(i,4)).LT.99999.) THEN   
          WRITE(mstu(11),1500) i,chac(1:12),(k(i,j1),j1=1,3),   
     &    (p(i,j2),j2=1,5)  
        ELSEIF(mlist.EQ.1) THEN 
          WRITE(mstu(11),1600) i,chac(1:12),(k(i,j1),j1=1,3),   
     &    (p(i,j2),j2=1,5)  
        ELSEIF(mstu(5).EQ.10000.AND.(k(i,1).EQ.3.OR.k(i,1).EQ.13.OR.    
     &  k(i,1).EQ.14)) THEN 
          WRITE(mstu(11),1700) i,chac,(k(i,j1),j1=1,3), 
     &    k(i,4)/100000000,mod(k(i,4)/10000,10000),mod(k(i,4),10000),   
     &    k(i,5)/100000000,mod(k(i,5)/10000,10000),mod(k(i,5),10000),   
     &    (p(i,j2),j2=1,5)  
        ELSE    
          WRITE(mstu(11),1800) i,chac,(k(i,j1),j1=1,5),(p(i,j2),j2=1,5) 
        ENDIF   
        IF(mlist.EQ.3) WRITE(mstu(11),1900) (v(i,j),j=1,5)  
    
C...Insert extra separator lines specified by user. 
        IF(mstu(70).GE.1) THEN  
          isep=0    
          DO 110 j=1,min(10,mstu(70))   
  110     IF(i.EQ.mstu(70+j)) isep=1    
          IF(isep.EQ.1.AND.mlist.EQ.1) WRITE(mstu(11),2000) 
          IF(isep.EQ.1.AND.mlist.GE.2) WRITE(mstu(11),2100) 
        ENDIF   
  120   CONTINUE    
    
C...Sum of charges and momenta. 
        DO 130 j=1,6    
  130   ps(j)=plu(0,j)  
        IF(mlist.EQ.1.AND.abs(ps(4)).LT.9999.) THEN 
          WRITE(mstu(11),2200) ps(6),(ps(j),j=1,5)  
        ELSEIF(mlist.EQ.1.AND.abs(ps(4)).LT.99999.) THEN    
          WRITE(mstu(11),2300) ps(6),(ps(j),j=1,5)  
        ELSEIF(mlist.EQ.1) THEN 
          WRITE(mstu(11),2400) ps(6),(ps(j),j=1,5)  
        ELSE    
          WRITE(mstu(11),2500) ps(6),(ps(j),j=1,5)  
        ENDIF   
    
C...Give simple list of KF codes defined in program.    
      ELSEIF(mlist.EQ.11) THEN  
        WRITE(mstu(11),2600)    
        DO 140 kf=1,40  
        CALL luname(kf,chap)    
        CALL luname(-kf,chan)   
        IF(chap.NE.' '.AND.chan.EQ.' ') WRITE(mstu(11),2700) kf,chap    
  140   IF(chan.NE.' ') WRITE(mstu(11),2700) kf,chap,-kf,chan   
        DO 150 kfls=1,3,2   
        DO 150 kfla=1,8 
        DO 150 kflb=1,kfla-(3-kfls)/2   
        kf=1000*kfla+100*kflb+kfls  
        CALL luname(kf,chap)    
        CALL luname(-kf,chan)   
  150   WRITE(mstu(11),2700) kf,chap,-kf,chan   
        DO 170 kmul=0,5 
        kfls=3  
        IF(kmul.EQ.0.OR.kmul.EQ.3) kfls=1   
        IF(kmul.EQ.5) kfls=5    
        kflr=0  
        IF(kmul.EQ.2.OR.kmul.EQ.3) kflr=1   
        IF(kmul.EQ.4) kflr=2    
        DO 170 kflb=1,8 
        DO 160 kflc=1,kflb-1    
        kf=10000*kflr+100*kflb+10*kflc+kfls 
        CALL luname(kf,chap)    
        CALL luname(-kf,chan)   
  160   WRITE(mstu(11),2700) kf,chap,-kf,chan   
        kf=10000*kflr+110*kflb+kfls 
        CALL luname(kf,chap)    
  170   WRITE(mstu(11),2700) kf,chap    
        kf=130  
        CALL luname(kf,chap)    
        WRITE(mstu(11),2700) kf,chap    
        kf=310  
        CALL luname(kf,chap)    
        WRITE(mstu(11),2700) kf,chap    
        DO 190 kflsp=1,3    
        kfls=2+2*(kflsp/3)  
        DO 190 kfla=1,8 
        DO 190 kflb=1,kfla  
        DO 180 kflc=1,kflb  
        IF(kflsp.EQ.1.AND.(kfla.EQ.kflb.OR.kflb.EQ.kflc)) goto 180  
        IF(kflsp.EQ.2.AND.kfla.EQ.kflc) goto 180    
        IF(kflsp.EQ.1) kf=1000*kfla+100*kflc+10*kflb+kfls   
        IF(kflsp.GE.2) kf=1000*kfla+100*kflb+10*kflc+kfls   
        CALL luname(kf,chap)    
        CALL luname(-kf,chan)   
        WRITE(mstu(11),2700) kf,chap,-kf,chan   
  180   CONTINUE    
  190   CONTINUE    
    
C...List parton/particle data table. Check whether to be listed.    
      ELSEIF(mlist.EQ.12) THEN  
        WRITE(mstu(11),2800)    
        mstj24=mstj(24) 
        mstj(24)=0  
        kfmax=20883 
        IF(mstu(2).NE.0) kfmax=mstu(2)  
        DO 220 kf=max(1,mstu(1)),kfmax  
        kc=lucomp(kf)   
        IF(kc.EQ.0) goto 220    
        IF(mstu(14).EQ.0.AND.kf.GT.100.AND.kc.LE.100) goto 220  
        IF(mstu(14).GT.0.AND.kf.GT.100.AND.max(mod(kf/1000,10), 
     &  mod(kf/100,10)).GT.mstu(14)) goto 220   
    
C...Find particle name and mass. Print information. 
        CALL luname(kf,chap)    
        IF(kf.LE.100.AND.chap.EQ.' '.AND.mdcy(kc,2).EQ.0) goto 220  
        CALL luname(-kf,chan)   
        pm=ulmass(kf)   
        WRITE(mstu(11),2900) kf,kc,chap,chan,kchg(kc,1),kchg(kc,2), 
     &  kchg(kc,3),pm,pmas(kc,2),pmas(kc,3),pmas(kc,4),mdcy(kc,1)   
    
C...Particle decay: channel number, branching ration, matrix element,   
C...decay products. 
        IF(kf.GT.100.AND.kc.LE.100) goto 220    
        DO 210 idc=mdcy(kc,2),mdcy(kc,2)+mdcy(kc,3)-1   
        DO 200 j=1,5    
  200   CALL luname(kfdp(idc,j),chad(j))    
  210   WRITE(mstu(11),3000) idc,mdme(idc,1),mdme(idc,2),brat(idc), 
     &  (chad(j),j=1,5) 
  220   CONTINUE    
        mstj(24)=mstj24 
    
C...List parameter value table. 
      ELSEIF(mlist.EQ.13) THEN  
        WRITE(mstu(11),3100)    
        DO 230 i=1,200  
  230   WRITE(mstu(11),3200) i,mstu(i),paru(i),mstj(i),parj(i),parf(i)  
      ENDIF 
    
C...Format statements for output on unit MSTU(11) (by default 6).   
 1000 FORMAT(///20x,'The Lund Monte Carlo - JETSET version ',i1,'.',i1/ 
     &20x,'**  Last date of change:  ',i2,1x,a3,1x,i4,'  **'/)  
 1100 FORMAT(///28x,'Event listing (summary)'//4x,'I  particle/jet KS', 
     &5x,'KF orig    p_x      p_y      p_z       E        m'/)  
 1200 FORMAT(///28x,'Event listing (standard)'//4x,'I  particle/jet',   
     &'  K(I,1)   K(I,2) K(I,3)     K(I,4)      K(I,5)       P(I,1)',   
     &'       P(I,2)       P(I,3)       P(I,4)       P(I,5)'/)  
 1300 FORMAT(///28x,'Event listing (with vertices)'//4x,'I  particle/j',    
     &'et  K(I,1)   K(I,2) K(I,3)     K(I,4)      K(I,5)       P(I,1)', 
     &'       P(I,2)       P(I,3)       P(I,4)       P(I,5)'/73x,   
     &'V(I,1)       V(I,2)       V(I,3)       V(I,4)       V(I,5)'/)    
 1400 FORMAT(1x,i4,2x,a12,1x,i2,1x,i6,1x,i4,5f9.3)  
 1500 FORMAT(1x,i4,2x,a12,1x,i2,1x,i6,1x,i4,5f9.2)  
 1600 FORMAT(1x,i4,2x,a12,1x,i2,1x,i6,1x,i4,5f9.1)  
 1700 FORMAT(1x,i4,2x,a16,1x,i3,1x,i8,2x,i4,2(3x,i1,2i4),5f13.5)    
 1800 FORMAT(1x,i4,2x,a16,1x,i3,1x,i8,2x,i4,2(3x,i9),5f13.5)    
 1900 FORMAT(66x,5(1x,f12.3))   
 2000 FORMAT(1x,78('='))    
 2100 FORMAT(1x,130('='))   
 2200 FORMAT(19x,'sum:',f6.2,5x,5f9.3)  
 2300 FORMAT(19x,'sum:',f6.2,5x,5f9.2)  
 2400 FORMAT(19x,'sum:',f6.2,5x,5f9.1)  
 2500 FORMAT(19x,'sum charge:',f6.2,3x,'sum momentum and inv. mass:',   
     &5f13.5)   
 2600 FORMAT(///20x,'List of KF codes in program'/) 
 2700 FORMAT(4x,i6,4x,a16,6x,i6,4x,a16) 
 2800 FORMAT(///30x,'Particle/parton data table'//5x,'KF',5x,'KC',4x,   
     &'particle',8x,'antiparticle',6x,'chg  col  anti',8x,'mass',7x,    
     &'width',7x,'w-cut',5x,'lifetime',1x,'decay'/11x,'IDC',1x,'on/off',    
     &1x,'ME',3x,'Br.rat.',4x,'decay products') 
 2900 FORMAT(/1x,i6,3x,i4,4x,a16,a16,3i5,1x,f12.5,2(1x,f11.5),  
     &2x,f12.5,3x,i2)   
 3000 FORMAT(10x,i4,2x,i3,2x,i3,2x,f8.5,4x,5a16)    
 3100 FORMAT(///20x,'Parameter value table'//4x,'I',3x,'MSTU(I)',   
     &8x,'PARU(I)',3x,'MSTJ(I)',8x,'PARJ(I)',8x,'PARF(I)')  
 3200 FORMAT(1x,i4,1x,i9,1x,f14.5,1x,i9,1x,f14.5,1x,f14.5)  
    
      RETURN    
      END   
    
C*********************************************************************  
    
      SUBROUTINE luupda(MUPDA,LFN)  
    
C...Purpose: to facilitate the updating of particle and decay data. 
      common/ludat1/mstu(200),paru(200),mstj(200),parj(200) 
      SAVE /ludat1/ 
      common/ludat2/kchg(500,3),pmas(500,4),parf(2000),vckm(4,4)    
      SAVE /ludat2/ 
      common/ludat3/mdcy(500,3),mdme(2000,2),brat(2000),kfdp(2000,5)    
      SAVE /ludat3/ 
      common/ludat4/chaf(500)   
      CHARACTER chaf*8  
      SAVE /ludat4/ 
      CHARACTER chinl*80,chkc*4,chvar(19)*9,chlin*72,   
     &chblk(20)*72,chold*12,chtmp*12,chnew*12,chcom*12  
      DATA chvar/ 'KCHG(I,1)','KCHG(I,2)','KCHG(I,3)','PMAS(I,1)',  
     &'PMAS(I,2)','PMAS(I,3)','PMAS(I,4)','MDCY(I,1)','MDCY(I,2)',  
     &'MDCY(I,3)','MDME(I,1)','MDME(I,2)','BRAT(I)  ','KFDP(I,1)',  
     &'KFDP(I,2)','KFDP(I,3)','KFDP(I,4)','KFDP(I,5)','CHAF(I)  '/  
    
C...Write information on file for editing.  
      IF(mstu(12).GE.1) CALL lulist(0)  
      IF(mupda.EQ.1) THEN   
        DO 110 kc=1,mstu(6) 
        WRITE(lfn,1000) kc,chaf(kc),(kchg(kc,j1),j1=1,3),   
     &  (pmas(kc,j2),j2=1,4),mdcy(kc,1) 
        DO 100 idc=mdcy(kc,2),mdcy(kc,2)+mdcy(kc,3)-1   
  100   WRITE(lfn,1100) mdme(idc,1),mdme(idc,2),brat(idc),  
     &  (kfdp(idc,j),j=1,5) 
  110   CONTINUE    
    
C...Reset variables and read information from edited file.  
      ELSEIF(mupda.EQ.2) THEN   
        DO 120 i=1,mstu(7)  
        mdme(i,1)=1 
        mdme(i,2)=0 
        brat(i)=0.  
        DO 120 j=1,5    
  120   kfdp(i,j)=0 
        kc=0    
        idc=0   
        ndc=0   
  130   READ(lfn,1200,end=140) chinl    
        IF(chinl(2:5).NE.'    ') THEN   
          chkc=chinl(2:5)   
          IF(kc.NE.0) THEN  
            mdcy(kc,2)=0    
            IF(ndc.NE.0) mdcy(kc,2)=idc+1-ndc   
            mdcy(kc,3)=ndc  
          ENDIF 
          READ(chkc,1300) kc    
          IF(kc.LE.0.OR.kc.GT.mstu(6)) CALL luerrm(27,  
     &    '(LUUPDA:) Read KC code illegal, KC ='//chkc) 
          READ(chinl,1000) kcr,chaf(kc),(kchg(kc,j1),j1=1,3),   
     &    (pmas(kc,j2),j2=1,4),mdcy(kc,1)   
          ndc=0 
        ELSE    
          idc=idc+1 
          ndc=ndc+1 
          IF(idc.GE.mstu(7)) CALL luerrm(27,    
     &    '(LUUPDA:) Decay data arrays full by KC ='//chkc) 
          READ(chinl,1100) mdme(idc,1),mdme(idc,2),brat(idc),   
     &    (kfdp(idc,j),j=1,5)   
        ENDIF   
        goto 130    
  140   mdcy(kc,2)=0    
        IF(ndc.NE.0) mdcy(kc,2)=idc+1-ndc   
        mdcy(kc,3)=ndc  
    
C...Perform possible tests that new information is consistent.  
        mstj24=mstj(24) 
        mstj(24)=0  
        DO 170 kc=1,mstu(6) 
        WRITE(chkc,1300) kc 
        IF(min(pmas(kc,1),pmas(kc,2),pmas(kc,3),pmas(kc,1)-pmas(kc,3),  
     &  pmas(kc,4)).LT.0..OR.mdcy(kc,3).LT.0) CALL luerrm(17,   
     &  '(LUUPDA:) Mass/width/life/(# channels) wrong for KC ='//chkc)  
        brsum=0.    
        DO 160 idc=mdcy(kc,2),mdcy(kc,2)+mdcy(kc,3)-1   
        IF(mdme(idc,2).GT.80) goto 160  
        kq=kchg(kc,1)   
        pms=pmas(kc,1)-pmas(kc,3)-parj(64)  
        merr=0  
        DO 150 j=1,5    
        kp=kfdp(idc,j)  
        IF(kp.EQ.0.OR.kp.EQ.81.OR.iabs(kp).EQ.82) THEN  
        ELSEIF(lucomp(kp).EQ.0) THEN    
          merr=3    
        ELSE    
          kq=kq-luchge(kp)  
          pms=pms-ulmass(kp)    
        ENDIF   
  150   CONTINUE    
        IF(kq.NE.0) merr=max(2,merr)    
        IF(kfdp(idc,2).NE.0.AND.(kc.LE.20.OR.kc.GT.40).AND. 
     &  (kc.LE.80.OR.kc.GT.100).AND.mdme(idc,2).NE.34.AND.  
     &  mdme(idc,2).NE.61.AND.pms.LT.0.) merr=max(1,merr)   
        IF(merr.EQ.3) CALL luerrm(17,   
     &  '(LUUPDA:) Unknown particle code in decay of KC ='//chkc)   
        IF(merr.EQ.2) CALL luerrm(17,   
     &  '(LUUPDA:) Charge not conserved in decay of KC ='//chkc)    
        IF(merr.EQ.1) CALL luerrm(7,    
     &  '(LUUPDA:) Kinematically unallowed decay of KC ='//chkc)    
        brsum=brsum+brat(idc)   
  160   CONTINUE    
        WRITE(chtmp,1500) brsum 
        IF(abs(brsum).GT.0.0005.AND.abs(brsum-1.).GT.0.0005) CALL   
     &  luerrm(7,'(LUUPDA:) Sum of branching ratios is '//chtmp(5:12)// 
     &  ' for KC ='//chkc)  
  170   CONTINUE    
        mstj(24)=mstj24 
    
C...Initialize writing of DATA statements for inclusion in program. 
      ELSEIF(mupda.EQ.3) THEN   
        DO 240 ivar=1,19    
        ndim=mstu(6)    
        IF(ivar.GE.11.AND.ivar.LE.18) ndim=mstu(7)  
        nlin=1  
        chlin=' '   
        chlin(7:35)='DATA ('//chvar(ivar)//',I=   1,    )/' 
        llin=35 
        chold='START'   
    
C...Loop through variables for conversion to characters.    
        DO 220 idim=1,ndim  
        IF(ivar.EQ.1) WRITE(chtmp,1400) kchg(idim,1)    
        IF(ivar.EQ.2) WRITE(chtmp,1400) kchg(idim,2)    
        IF(ivar.EQ.3) WRITE(chtmp,1400) kchg(idim,3)    
        IF(ivar.EQ.4) WRITE(chtmp,1500) pmas(idim,1)    
        IF(ivar.EQ.5) WRITE(chtmp,1500) pmas(idim,2)    
        IF(ivar.EQ.6) WRITE(chtmp,1500) pmas(idim,3)    
        IF(ivar.EQ.7) WRITE(chtmp,1500) pmas(idim,4)    
        IF(ivar.EQ.8) WRITE(chtmp,1400) mdcy(idim,1)    
        IF(ivar.EQ.9) WRITE(chtmp,1400) mdcy(idim,2)    
        IF(ivar.EQ.10) WRITE(chtmp,1400) mdcy(idim,3)   
        IF(ivar.EQ.11) WRITE(chtmp,1400) mdme(idim,1)   
        IF(ivar.EQ.12) WRITE(chtmp,1400) mdme(idim,2)   
        IF(ivar.EQ.13) WRITE(chtmp,1500) brat(idim) 
        IF(ivar.EQ.14) WRITE(chtmp,1400) kfdp(idim,1)   
        IF(ivar.EQ.15) WRITE(chtmp,1400) kfdp(idim,2)   
        IF(ivar.EQ.16) WRITE(chtmp,1400) kfdp(idim,3)   
        IF(ivar.EQ.17) WRITE(chtmp,1400) kfdp(idim,4)   
        IF(ivar.EQ.18) WRITE(chtmp,1400) kfdp(idim,5)   
        IF(ivar.EQ.19) chtmp=chaf(idim) 
    
C...Length of variable, trailing decimal zeros, quotation marks.    
        llow=1  
        lhig=1  
        DO 180 ll=1,12  
        IF(chtmp(13-ll:13-ll).NE.' ') llow=13-ll    
  180   IF(chtmp(ll:ll).NE.' ') lhig=ll 
        chnew=chtmp(llow:lhig)//' ' 
        lnew=1+lhig-llow    
        IF((ivar.GE.4.AND.ivar.LE.7).OR.ivar.EQ.13) THEN    
          lnew=lnew+1   
  190     lnew=lnew-1   
          IF(chnew(lnew:lnew).EQ.'0') goto 190  
          IF(lnew.EQ.1) chnew(1:2)='0.' 
          IF(lnew.EQ.1) lnew=2  
        ELSEIF(ivar.EQ.19) THEN 
          DO 200 ll=lnew,1,-1   
          IF(chnew(ll:ll).EQ.'''') THEN 
            chtmp=chnew 
            chnew=chtmp(1:ll)//''''//chtmp(ll+1:11) 
            lnew=lnew+1 
          ENDIF 
  200     CONTINUE  
          chtmp=chnew   
          chnew(1:lnew+2)=''''//chtmp(1:lnew)//'''' 
          lnew=lnew+2   
        ENDIF   
    
C...Form composite character string, often including repetition counter.    
        IF(chnew.NE.chold) THEN 
          nrpt=1    
          chold=chnew   
          chcom=chnew   
          lcom=lnew 
        ELSE    
          lrpt=lnew+1   
          IF(nrpt.GE.2) lrpt=lnew+3 
          IF(nrpt.GE.10) lrpt=lnew+4    
          IF(nrpt.GE.100) lrpt=lnew+5   
          IF(nrpt.GE.1000) lrpt=lnew+6  
          llin=llin-lrpt    
          nrpt=nrpt+1   
          WRITE(chtmp,1400) nrpt    
          lrpt=1    
          IF(nrpt.GE.10) lrpt=2 
          IF(nrpt.GE.100) lrpt=3    
          IF(nrpt.GE.1000) lrpt=4   
          chcom(1:lrpt+1+lnew)=chtmp(13-lrpt:12)//'*'//chnew(1:lnew)    
          lcom=lrpt+1+lnew  
        ENDIF   
    
C...Add characters to end of line, to new line (after storing old line),    
C...or to new block of lines (after writing old block). 
        IF(llin+lcom.LE.70) THEN    
          chlin(llin+1:llin+lcom+1)=chcom(1:lcom)//','  
          llin=llin+lcom+1  
        ELSEIF(nlin.LE.19) THEN 
          chlin(llin+1:72)=' '  
          chblk(nlin)=chlin 
          nlin=nlin+1   
          chlin(6:6+lcom+1)='&'//chcom(1:lcom)//',' 
          llin=6+lcom+1 
        ELSE    
          chlin(llin:72)='/'//' '   
          chblk(nlin)=chlin 
          WRITE(chtmp,1400) idim-nrpt   
          chblk(1)(30:33)=chtmp(9:12)   
          DO 210 ilin=1,nlin    
  210     WRITE(lfn,1600) chblk(ilin)   
          nlin=1    
          chlin=' ' 
          chlin(7:35+lcom+1)='DATA ('//chvar(ivar)//',I=    ,    )/'//  
     &    chcom(1:lcom)//','    
          WRITE(chtmp,1400) idim-nrpt+1 
          chlin(25:28)=chtmp(9:12)  
          llin=35+lcom+1    
        ENDIF   
  220   CONTINUE    
    
C...Write final block of lines. 
        chlin(llin:72)='/'//' ' 
        chblk(nlin)=chlin   
        WRITE(chtmp,1400) ndim  
        chblk(1)(30:33)=chtmp(9:12) 
        DO 230 ilin=1,nlin  
  230   WRITE(lfn,1600) chblk(ilin) 
  240   CONTINUE    
      ENDIF 
    
C...Formats for reading and writing particle data.  
 1000 FORMAT(1x,i4,2x,a8,3i3,3f12.5,2x,f12.5,i3)    
 1100 FORMAT(5x,2i5,f12.5,5i8)  
 1200 FORMAT(a80)   
 1300 FORMAT(i4)    
 1400 FORMAT(i12)   
 1500 FORMAT(f12.5) 
 1600 FORMAT(a72)   
    
      RETURN    
      END   
    
C*********************************************************************  
    
      FUNCTION klu(I,J) 
    
C...Purpose: to provide various integer-valued event related data.  
      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/ludat2/kchg(500,3),pmas(500,4),parf(2000),vckm(4,4)    
      SAVE /ludat2/ 
    
C...Default value. For I=0 number of entries, number of stable entries  
C...or 3 times total charge.    
      klu=0 
      IF(i.LT.0.OR.i.GT.mstu(4).OR.j.LE.0) THEN 
      ELSEIF(i.EQ.0.AND.j.EQ.1) THEN    
        klu=n   
      ELSEIF(i.EQ.0.AND.(j.EQ.2.OR.j.EQ.6)) THEN    
        DO 100 i1=1,n   
        IF(j.EQ.2.AND.k(i1,1).GE.1.AND.k(i1,1).LE.10) klu=klu+1 
        IF(j.EQ.6.AND.k(i1,1).GE.1.AND.k(i1,1).LE.10) klu=klu+  
     &  luchge(k(i1,2)) 
  100   CONTINUE    
      ELSEIF(i.EQ.0) THEN   
    
C...For I > 0 direct readout of K matrix or charge. 
      ELSEIF(j.LE.5) THEN   
        klu=k(i,j)  
      ELSEIF(j.EQ.6) THEN   
        klu=luchge(k(i,2))  
    
C...Status (existing/fragmented/decayed), parton/hadron separation. 
      ELSEIF(j.LE.8) THEN   
        IF(k(i,1).GE.1.AND.k(i,1).LE.10) klu=1  
        IF(j.EQ.8) klu=klu*k(i,2)   
      ELSEIF(j.LE.12) THEN  
        kfa=iabs(k(i,2))    
        kc=lucomp(kfa)  
        kq=0    
        IF(kc.NE.0) kq=kchg(kc,2)   
        IF(j.EQ.9.AND.kc.NE.0.AND.kq.NE.0) klu=k(i,2)   
        IF(j.EQ.10.AND.kc.NE.0.AND.kq.EQ.0) klu=k(i,2)  
        IF(j.EQ.11) klu=kc  
        IF(j.EQ.12) klu=kq*isign(1,k(i,2))  
    
C...Heaviest flavour in hadron/diquark. 
      ELSEIF(j.EQ.13) THEN  
        kfa=iabs(k(i,2))    
        klu=mod(kfa/100,10)*(-1)**mod(kfa/100,10)   
        IF(kfa.LT.10) klu=kfa   
        IF(mod(kfa/1000,10).NE.0) klu=mod(kfa/1000,10)  
        klu=klu*isign(1,k(i,2)) 
    
C...Particle history: generation, ancestor, rank.   
      ELSEIF(j.LE.16) THEN  
        i2=i    
        i1=i    
  110   klu=klu+1   
        i3=i2   
        i2=i1   
        i1=k(i1,3)  
        IF(i1.GT.0.AND.k(i1,1).GT.0.AND.k(i1,1).LE.20) goto 110 
        IF(j.EQ.15) klu=i2  
        IF(j.EQ.16) THEN    
          klu=0 
          DO 120 i1=i2+1,i3 
  120     IF(k(i1,3).EQ.i2.AND.k(i1,1).GT.0.AND.k(i1,1).LE.20) klu=klu+1    
        ENDIF   
    
C...Particle coming from collapsing jet system or not.  
      ELSEIF(j.EQ.17) THEN  
        i1=i    
  130   klu=klu+1   
        i3=i1   
        i1=k(i1,3)  
        i0=max(1,i1)    
        kc=lucomp(k(i0,2))  
        IF(i1.EQ.0.OR.k(i0,1).LE.0.OR.k(i0,1).GT.20.OR.kc.EQ.0) THEN    
          IF(klu.EQ.1) klu=-1   
          IF(klu.GT.1) klu=0    
          RETURN    
        ENDIF   
        IF(kchg(kc,2).EQ.0) goto 130    
        IF(k(i1,1).NE.12) klu=0 
        IF(k(i1,1).NE.12) RETURN    
        i2=i1   
  140   i2=i2+1 
        IF(i2.LT.n.AND.k(i2,1).NE.11) goto 140  
        k3m=k(i3-1,3)   
        IF(k3m.GE.i1.AND.k3m.LE.i2) klu=0   
        k3p=k(i3+1,3)   
        IF(i3.LT.n.AND.k3p.GE.i1.AND.k3p.LE.i2) klu=0   
    
C...Number of decay products. Colour flow.  
      ELSEIF(j.EQ.18) THEN  
        IF(k(i,1).EQ.11.OR.k(i,1).EQ.12) klu=max(0,k(i,5)-k(i,4)+1) 
        IF(k(i,4).EQ.0.OR.k(i,5).EQ.0) klu=0    
      ELSEIF(j.LE.22) THEN  
        IF(k(i,1).NE.3.AND.k(i,1).NE.13.AND.k(i,1).NE.14) RETURN    
        IF(j.EQ.19) klu=mod(k(i,4)/mstu(5),mstu(5)) 
        IF(j.EQ.20) klu=mod(k(i,5)/mstu(5),mstu(5)) 
        IF(j.EQ.21) klu=mod(k(i,4),mstu(5)) 
        IF(j.EQ.22) klu=mod(k(i,5),mstu(5)) 
      ELSE  
      ENDIF 
    
      RETURN    
      END   
    
C*********************************************************************  
    
      FUNCTION plu(I,J) 
    
C...Purpose: to provide various real-valued event related data. 
      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/ludat2/kchg(500,3),pmas(500,4),parf(2000),vckm(4,4)    
      SAVE /ludat2/ 
      dimension psum(4) 
    
C...Set default value. For I = 0 sum of momenta or charges, 
C...or invariant mass of system.    
      plu=0.    
      IF(i.LT.0.OR.i.GT.mstu(4).OR.j.LE.0) THEN 
      ELSEIF(i.EQ.0.AND.j.LE.4) THEN    
        DO 100 i1=1,n   
  100   IF(k(i1,1).GT.0.AND.k(i1,1).LE.10) plu=plu+p(i1,j)  
      ELSEIF(i.EQ.0.AND.j.EQ.5) THEN    
        DO 110 j1=1,4   
        psum(j1)=0. 
        DO 110 i1=1,n   
  110   IF(k(i1,1).GT.0.AND.k(i1,1).LE.10) psum(j1)=psum(j1)+p(i1,j1)   
        plu=sqrt(max(0.,psum(4)**2-psum(1)**2-psum(2)**2-psum(3)**2))   
      ELSEIF(i.EQ.0.AND.j.EQ.6) THEN    
        DO 120 i1=1,n   
  120   IF(k(i1,1).GT.0.AND.k(i1,1).LE.10) plu=plu+luchge(k(i1,2))/3.   
      ELSEIF(i.EQ.0) THEN   
    
C...Direct readout of P matrix. 
      ELSEIF(j.LE.5) THEN   
        plu=p(i,j)  
    
C...Charge, total momentum, transverse momentum, transverse mass.   
      ELSEIF(j.LE.12) THEN  
        IF(j.EQ.6) plu=luchge(k(i,2))/3.    
        IF(j.EQ.7.OR.j.EQ.8) plu=p(i,1)**2+p(i,2)**2+p(i,3)**2  
        IF(j.EQ.9.OR.j.EQ.10) plu=p(i,1)**2+p(i,2)**2   
        IF(j.EQ.11.OR.j.EQ.12) plu=p(i,5)**2+p(i,1)**2+p(i,2)**2    
        IF(j.EQ.8.OR.j.EQ.10.OR.j.EQ.12) plu=sqrt(plu)  
    
C...Theta and phi angle in radians or degrees.  
      ELSEIF(j.LE.16) THEN  
        IF(j.LE.14) plu=ulangl(p(i,3),sqrt(p(i,1)**2+p(i,2)**2))    
        IF(j.GE.15) plu=ulangl(p(i,1),p(i,2))   
        IF(j.EQ.14.OR.j.EQ.16) plu=plu*180./paru(1) 
    
C...True rapidity, rapidity with pion mass, pseudorapidity. 
      ELSEIF(j.LE.19) THEN  
        pmr=0.  
        IF(j.EQ.17) pmr=p(i,5)  
        IF(j.EQ.18) pmr=ulmass(211) 
        pr=max(1e-20,pmr**2+p(i,1)**2+p(i,2)**2)    
        plu=sign(log(min((sqrt(pr+p(i,3)**2)+abs(p(i,3)))/sqrt(pr), 
     &  1e20)),p(i,3))  
    
C...Energy and momentum fractions (only to be used in CM frame).    
      ELSEIF(j.LE.25) THEN  
        IF(j.EQ.20) plu=2.*sqrt(p(i,1)**2+p(i,2)**2+p(i,3)**2)/paru(21) 
        IF(j.EQ.21) plu=2.*p(i,3)/paru(21)  
        IF(j.EQ.22) plu=2.*sqrt(p(i,1)**2+p(i,2)**2)/paru(21)   
        IF(j.EQ.23) plu=2.*p(i,4)/paru(21)  
        IF(j.EQ.24) plu=(p(i,4)+p(i,3))/paru(21)    
        IF(j.EQ.25) plu=(p(i,4)-p(i,3))/paru(21)    
      ENDIF 
    
      RETURN    
      END   
    
C*********************************************************************  
    
      SUBROUTINE lusphe(SPH,APL)    
    
C...Purpose: to perform sphericity tensor analysis to give sphericity,  
C...aplanarity and the related event axes.  
      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/ludat2/kchg(500,3),pmas(500,4),parf(2000),vckm(4,4)    
      SAVE /ludat2/ 
      dimension sm(3,3),sv(3,3) 
    
C...Calculate matrix to be diagonalized.    
      np=0  
      DO 100 j1=1,3 
      DO 100 j2=j1,3    
  100 sm(j1,j2)=0.  
      ps=0. 
      DO 120 i=1,n  
      IF(k(i,1).LE.0.OR.k(i,1).GT.10) goto 120  
      IF(mstu(41).GE.2) THEN    
        kc=lucomp(k(i,2))   
        IF(kc.EQ.0.OR.kc.EQ.12.OR.kc.EQ.14.OR.kc.EQ.16.OR.  
     &  kc.EQ.18) goto 120  
        IF(mstu(41).GE.3.AND.kchg(kc,2).EQ.0.AND.luchge(k(i,2)).EQ.0)   
     &  goto 120    
      ENDIF 
      np=np+1   
      pa=sqrt(p(i,1)**2+p(i,2)**2+p(i,3)**2)    
      pwt=1.    
      IF(abs(paru(41)-2.).GT.0.001) pwt=max(1e-10,pa)**(paru(41)-2.)    
      DO 110 j1=1,3 
      DO 110 j2=j1,3    
  110 sm(j1,j2)=sm(j1,j2)+pwt*p(i,j1)*p(i,j2)   
      ps=ps+pwt*pa**2   
  120 CONTINUE  
    
C...Very low multiplicities (0 or 1) not considered.    
      IF(np.LE.1) THEN  
        CALL luerrm(8,'(LUSPHE:) too few particles for analysis')   
        sph=-1. 
        apl=-1. 
        RETURN  
      ENDIF 
      DO 130 j1=1,3 
      DO 130 j2=j1,3    
  130 sm(j1,j2)=sm(j1,j2)/ps    
    
C...Find eigenvalues to matrix (third degree equation). 
      sq=(sm(1,1)*sm(2,2)+sm(1,1)*sm(3,3)+sm(2,2)*sm(3,3)-sm(1,2)**2-   
     &sm(1,3)**2-sm(2,3)**2)/3.-1./9.   
      sr=-0.5*(sq+1./9.+sm(1,1)*sm(2,3)**2+sm(2,2)*sm(1,3)**2+sm(3,3)*  
     &sm(1,2)**2-sm(1,1)*sm(2,2)*sm(3,3))+sm(1,2)*sm(1,3)*sm(2,3)+1./27.    
      sp=cos(acos(max(min(sr/sqrt(-sq**3),1.),-1.))/3.) 
      p(n+1,4)=1./3.+sqrt(-sq)*max(2.*sp,sqrt(3.*(1.-sp**2))-sp)    
      p(n+3,4)=1./3.+sqrt(-sq)*min(2.*sp,-sqrt(3.*(1.-sp**2))-sp)   
      p(n+2,4)=1.-p(n+1,4)-p(n+3,4) 
      IF(p(n+2,4).LT.1e-5) THEN 
        CALL luerrm(8,'(LUSPHE:) all particles back-to-back')   
        sph=-1. 
        apl=-1. 
        RETURN  
      ENDIF 
    
C...Find first and last eigenvector by solving equation system. 
      DO 170 i=1,3,2    
      DO 140 j1=1,3 
      sv(j1,j1)=sm(j1,j1)-p(n+i,4)  
      DO 140 j2=j1+1,3  
      sv(j1,j2)=sm(j1,j2)   
  140 sv(j2,j1)=sm(j1,j2)   
      smax=0.   
      DO 150 j1=1,3 
      DO 150 j2=1,3 
      IF(abs(sv(j1,j2)).LE.smax) goto 150   
      ja=j1 
      jb=j2 
      smax=abs(sv(j1,j2))   
  150 CONTINUE  
      smax=0.   
      DO 160 j3=ja+1,ja+2   
      j1=j3-3*((j3-1)/3)    
      rl=sv(j1,jb)/sv(ja,jb)    
      DO 160 j2=1,3 
      sv(j1,j2)=sv(j1,j2)-rl*sv(ja,j2)  
      IF(abs(sv(j1,j2)).LE.smax) goto 160   
      jc=j1 
      smax=abs(sv(j1,j2))   
  160 CONTINUE  
      jb1=jb+1-3*(jb/3) 
      jb2=jb+2-3*((jb+1)/3) 
      p(n+i,jb1)=-sv(jc,jb2)    
      p(n+i,jb2)=sv(jc,jb1) 
      p(n+i,jb)=-(sv(ja,jb1)*p(n+i,jb1)+sv(ja,jb2)*p(n+i,jb2))/ 
     &sv(ja,jb) 
      pa=sqrt(p(n+i,1)**2+p(n+i,2)**2+p(n+i,3)**2)  
      sgn=(-1.)**int(rlu(0)+0.5)    
      DO 170 j=1,3  
  170 p(n+i,j)=sgn*p(n+i,j)/pa  
    
C...Middle axis orthogonal to other two. Fill other codes.  
      sgn=(-1.)**int(rlu(0)+0.5)    
      p(n+2,1)=sgn*(p(n+1,2)*p(n+3,3)-p(n+1,3)*p(n+3,2))    
      p(n+2,2)=sgn*(p(n+1,3)*p(n+3,1)-p(n+1,1)*p(n+3,3))    
      p(n+2,3)=sgn*(p(n+1,1)*p(n+3,2)-p(n+1,2)*p(n+3,1))    
      DO 180 i=1,3  
      k(n+i,1)=31   
      k(n+i,2)=95   
      k(n+i,3)=i    
      k(n+i,4)=0    
      k(n+i,5)=0    
      p(n+i,5)=0.   
      DO 180 j=1,5  
  180 v(i,j)=0. 
    
C...Select storing option. Calculate sphericity and aplanarity. 
      mstu(61)=n+1  
      mstu(62)=np   
      IF(mstu(43).LE.1) mstu(3)=3   
      IF(mstu(43).GE.2) n=n+3   
      sph=1.5*(p(n+2,4)+p(n+3,4))   
      apl=1.5*p(n+3,4)  
    
      RETURN    
      END   
    
C*********************************************************************  
    
      SUBROUTINE luthru(THR,OBL)    
    
C...Purpose: to perform thrust analysis to give thrust, oblateness  
C...and the related event axes. 
      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/ludat2/kchg(500,3),pmas(500,4),parf(2000),vckm(4,4)    
      SAVE /ludat2/ 
      dimension tdi(3),tpr(3)   
    
C...Take copy of particles that are to be considered in thrust analysis.    
      np=0  
      ps=0. 
      DO 100 i=1,n  
      IF(k(i,1).LE.0.OR.k(i,1).GT.10) goto 100  
      IF(mstu(41).GE.2) THEN    
        kc=lucomp(k(i,2))   
        IF(kc.EQ.0.OR.kc.EQ.12.OR.kc.EQ.14.OR.kc.EQ.16.OR.  
     &  kc.EQ.18) goto 100  
        IF(mstu(41).GE.3.AND.kchg(kc,2).EQ.0.AND.luchge(k(i,2)).EQ.0)   
     &  goto 100    
      ENDIF 
      IF(n+np+mstu(44)+15.GE.mstu(4)-mstu(32)-5) THEN   
        CALL luerrm(11,'(LUTHRU:) no more memory left in LUJETS')   
        thr=-2. 
        obl=-2. 
        RETURN  
      ENDIF 
      np=np+1   
      k(n+np,1)=23  
      p(n+np,1)=p(i,1)  
      p(n+np,2)=p(i,2)  
      p(n+np,3)=p(i,3)  
      p(n+np,4)=sqrt(p(i,1)**2+p(i,2)**2+p(i,3)**2) 
      p(n+np,5)=1.  
      IF(abs(paru(42)-1.).GT.0.001) p(n+np,5)=p(n+np,4)**(paru(42)-1.)  
      ps=ps+p(n+np,4)*p(n+np,5) 
  100 CONTINUE  
    
C...Very low multiplicities (0 or 1) not considered.    
      IF(np.LE.1) THEN  
        CALL luerrm(8,'(LUTHRU:) too few particles for analysis')   
        thr=-1. 
        obl=-1. 
        RETURN  
      ENDIF 
    
C...Loop over thrust and major. T axis along z direction in latter case.    
      DO 280 ild=1,2    
      IF(ild.EQ.2) THEN 
        k(n+np+1,1)=31  
        phi=ulangl(p(n+np+1,1),p(n+np+1,2)) 
        CALL ludbrb(n+1,n+np+1,0.,-phi,0d0,0d0,0d0) 
        the=ulangl(p(n+np+1,3),p(n+np+1,1)) 
        CALL ludbrb(n+1,n+np+1,-the,0.,0d0,0d0,0d0) 
      ENDIF 
    
C...Find and order particles with highest p (pT for major). 
      DO 110 ilf=n+np+4,n+np+mstu(44)+4 
  110 p(ilf,4)=0.   
      DO 150 i=n+1,n+np 
      IF(ild.EQ.2) p(i,4)=sqrt(p(i,1)**2+p(i,2)**2) 
      DO 120 ilf=n+np+mstu(44)+3,n+np+4,-1  
      IF(p(i,4).LE.p(ilf,4)) goto 130   
      DO 120 j=1,5  
  120 p(ilf+1,j)=p(ilf,j)   
      ilf=n+np+3    
  130 DO 140 j=1,5  
  140 p(ilf+1,j)=p(i,j) 
  150 CONTINUE  
    
C...Find and order initial axes with highest thrust (major).    
      DO 160 ilg=n+np+mstu(44)+5,n+np+mstu(44)+15   
  160 p(ilg,4)=0.   
      nc=2**(min(mstu(44),np)-1)    
      DO 220 ilc=1,nc   
      DO 170 j=1,3  
  170 tdi(j)=0. 
      DO 180 ilf=1,min(mstu(44),np) 
      sgn=p(n+np+ilf+3,5)   
      IF(2**ilf*((ilc+2**(ilf-1)-1)/2**ilf).GE.ilc) sgn=-sgn    
      DO 180 j=1,4-ild  
  180 tdi(j)=tdi(j)+sgn*p(n+np+ilf+3,j) 
      tds=tdi(1)**2+tdi(2)**2+tdi(3)**2 
      DO 190 ilg=n+np+mstu(44)+min(ilc,10)+4,n+np+mstu(44)+5,-1 
      IF(tds.LE.p(ilg,4)) goto 200  
      DO 190 j=1,4  
  190 p(ilg+1,j)=p(ilg,j)   
      ilg=n+np+mstu(44)+4   
  200 DO 210 j=1,3  
  210 p(ilg+1,j)=tdi(j) 
      p(ilg+1,4)=tds    
  220 CONTINUE  
    
C...Iterate direction of axis until stable maximum. 
      p(n+np+ild,4)=0.  
      ilg=0 
  230 ilg=ilg+1 
      thp=0.    
  240 thps=thp  
      DO 250 j=1,3  
      IF(thp.LE.1e-10) tdi(j)=p(n+np+mstu(44)+4+ilg,j)  
      IF(thp.GT.1e-10) tdi(j)=tpr(j)    
  250 tpr(j)=0. 
      DO 260 i=n+1,n+np 
      sgn=sign(p(i,5),tdi(1)*p(i,1)+tdi(2)*p(i,2)+tdi(3)*p(i,3))    
      DO 260 j=1,4-ild  
  260 tpr(j)=tpr(j)+sgn*p(i,j)  
      thp=sqrt(tpr(1)**2+tpr(2)**2+tpr(3)**2)/ps    
      IF(thp.GE.thps+paru(48)) goto 240 
    
C...Save good axis. Try new initial axis until a number of tries agree. 
      IF(thp.LT.p(n+np+ild,4)-paru(48).AND.ilg.LT.min(10,nc)) goto 230  
      IF(thp.GT.p(n+np+ild,4)+paru(48)) THEN    
        iagr=0  
        sgn=(-1.)**int(rlu(0)+0.5)  
        DO 270 j=1,3    
  270   p(n+np+ild,j)=sgn*tpr(j)/(ps*thp)   
        p(n+np+ild,4)=thp   
        p(n+np+ild,5)=0.    
      ENDIF 
      iagr=iagr+1   
  280 IF(iagr.LT.mstu(45).AND.ilg.LT.min(10,nc)) goto 230   
    
C...Find minor axis and value by orthogonality. 
      sgn=(-1.)**int(rlu(0)+0.5)    
      p(n+np+3,1)=-sgn*p(n+np+2,2)  
      p(n+np+3,2)=sgn*p(n+np+2,1)   
      p(n+np+3,3)=0.    
      thp=0.    
      DO 290 i=n+1,n+np 
  290 thp=thp+p(i,5)*abs(p(n+np+3,1)*p(i,1)+p(n+np+3,2)*p(i,2)) 
      p(n+np+3,4)=thp/ps    
      p(n+np+3,5)=0.    
    
C...Fill axis information. Rotate back to original coordinate system.   
      DO 300 ild=1,3    
      k(n+ild,1)=31 
      k(n+ild,2)=96 
      k(n+ild,3)=ild    
      k(n+ild,4)=0  
      k(n+ild,5)=0  
      DO 300 j=1,5  
      p(n+ild,j)=p(n+np+ild,j)  
  300 v(n+ild,j)=0. 
      CALL ludbrb(n+1,n+3,the,phi,0d0,0d0,0d0)  
    
C...Select storing option. Calculate thurst and oblateness. 
      mstu(61)=n+1  
      mstu(62)=np   
      IF(mstu(43).LE.1) mstu(3)=3   
      IF(mstu(43).GE.2) n=n+3   
      thr=p(n+1,4)  
      obl=p(n+2,4)-p(n+3,4) 
    
      RETURN    
      END   
    
C*********************************************************************  
    
      SUBROUTINE luclus(NJET)   
    
C...Purpose: to subdivide the particle content of an event into 
C...jets/clusters.  
      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/ludat2/kchg(500,3),pmas(500,4),parf(2000),vckm(4,4)    
      SAVE /ludat2/ 
      dimension ps(5)   
      SAVE nsav,np,ps,pss,rinit,npre,nrem   
    
C...Functions: distance measure in pT or (pseudo)mass.  
      r2t(i1,i2)=(p(i1,5)*p(i2,5)-p(i1,1)*p(i2,1)-p(i1,2)*p(i2,2)-  
     &p(i1,3)*p(i2,3))*2.*p(i1,5)*p(i2,5)/(0.0001+p(i1,5)+p(i2,5))**2   
      r2m(i1,i2)=2.*p(i1,4)*p(i2,4)*(1.-(p(i1,1)*p(i2,1)+p(i1,2)*   
     &p(i2,2)+p(i1,3)*p(i2,3))/(p(i1,5)*p(i2,5)))   
    
C...If first time, reset. If reentering, skip preliminaries.    
      IF(mstu(48).LE.0) THEN    
        np=0    
        DO 100 j=1,5    
  100   ps(j)=0.    
        pss=0.  
      ELSE  
        njet=nsav   
        IF(mstu(43).GE.2) n=n-njet  
        DO 110 i=n+1,n+njet 
  110   p(i,5)=sqrt(p(i,1)**2+p(i,2)**2+p(i,3)**2)  
        IF(mstu(46).LE.3) r2acc=paru(44)**2 
        IF(mstu(46).GE.4) r2acc=paru(45)*ps(5)**2   
        nloop=0 
        goto 290    
      ENDIF 
    
C...Find which particles are to be considered in cluster search.    
      DO 140 i=1,n  
      IF(k(i,1).LE.0.OR.k(i,1).GT.10) goto 140  
      IF(mstu(41).GE.2) THEN    
        kc=lucomp(k(i,2))   
        IF(kc.EQ.0.OR.kc.EQ.12.OR.kc.EQ.14.OR.kc.EQ.16.OR.  
     &  kc.EQ.18) goto 140  
        IF(mstu(41).GE.3.AND.kchg(kc,2).EQ.0.AND.luchge(k(i,2)).EQ.0)   
     &  goto 140    
      ENDIF 
      IF(n+2*np.GE.mstu(4)-mstu(32)-5) THEN 
        CALL luerrm(11,'(LUCLUS:) no more memory left in LUJETS')   
        njet=-1 
        RETURN  
      ENDIF 
    
C...Take copy of these particles, with space left for jets later on.    
      np=np+1   
      k(n+np,3)=i   
      DO 120 j=1,5  
  120 p(n+np,j)=p(i,j)  
      IF(mstu(42).EQ.0) p(n+np,5)=0.    
      IF(mstu(42).EQ.1.AND.k(i,2).NE.22) p(n+np,5)=pmas(101,1)  
      p(n+np,4)=sqrt(p(n+np,5)**2+p(i,1)**2+p(i,2)**2+p(i,3)**2)    
      p(n+np,5)=sqrt(p(i,1)**2+p(i,2)**2+p(i,3)**2) 
      DO 130 j=1,4  
  130 ps(j)=ps(j)+p(n+np,j) 
      pss=pss+p(n+np,5) 
  140 CONTINUE  
      DO 150 i=n+1,n+np 
      k(i+np,3)=k(i,3)  
      DO 150 j=1,5  
  150 p(i+np,j)=p(i,j)  
      ps(5)=sqrt(max(0.,ps(4)**2-ps(1)**2-ps(2)**2-ps(3)**2))   
    
C...Very low multiplicities not considered. 
      IF(np.LT.mstu(47)) THEN   
        CALL luerrm(8,'(LUCLUS:) too few particles for analysis')   
        njet=-1 
        RETURN  
      ENDIF 
    
C...Find precluster configuration. If too few jets, make harder cuts.   
      nloop=0   
      IF(mstu(46).LE.3) r2acc=paru(44)**2   
      IF(mstu(46).GE.4) r2acc=paru(45)*ps(5)**2 
      rinit=1.25*paru(43)   
      IF(np.LE.mstu(47)+2) rinit=0. 
  160 rinit=0.8*rinit   
      npre=0    
      nrem=np   
      DO 170 i=n+np+1,n+2*np    
  170 k(i,4)=0  
    
C...Sum up small momentum region. Jet if enough absolute momentum.  
      IF(mstu(46).LE.2) THEN    
        DO 180 j=1,4    
  180   p(n+1,j)=0. 
        DO 200 i=n+np+1,n+2*np  
        IF(p(i,5).GT.2.*rinit) goto 200 
        nrem=nrem-1 
        k(i,4)=1    
        DO 190 j=1,4    
  190   p(n+1,j)=p(n+1,j)+p(i,j)    
  200   CONTINUE    
        p(n+1,5)=sqrt(p(n+1,1)**2+p(n+1,2)**2+p(n+1,3)**2)  
        IF(p(n+1,5).GT.2.*rinit) npre=1 
        IF(rinit.GE.0.2*paru(43).AND.npre+nrem.LT.mstu(47)) goto 160    
      ENDIF 
    
C...Find fastest remaining particle.    
  210 npre=npre+1   
      pmax=0.   
      DO 220 i=n+np+1,n+2*np    
      IF(k(i,4).NE.0.OR.p(i,5).LE.pmax) goto 220    
      imax=i    
      pmax=p(i,5)   
  220 CONTINUE  
      DO 230 j=1,5  
  230 p(n+npre,j)=p(imax,j) 
      nrem=nrem-1   
      k(imax,4)=npre    
    
C...Sum up precluster around it according to pT separation. 
      IF(mstu(46).LE.2) THEN    
        DO 250 i=n+np+1,n+2*np  
        IF(k(i,4).NE.0) goto 250    
        r2=r2t(i,imax)  
        IF(r2.GT.rinit**2) goto 250 
        nrem=nrem-1 
        k(i,4)=npre 
        DO 240 j=1,4    
  240   p(n+npre,j)=p(n+npre,j)+p(i,j)  
  250   CONTINUE    
        p(n+npre,5)=sqrt(p(n+npre,1)**2+p(n+npre,2)**2+p(n+npre,3)**2)  
    
C...Sum up precluster around it according to mass separation.   
      ELSE  
  260   imin=0  
        r2min=rinit**2  
        DO 270 i=n+np+1,n+2*np  
        IF(k(i,4).NE.0) goto 270    
        r2=r2m(i,n+npre)    
        IF(r2.GE.r2min) goto 270    
        imin=i  
        r2min=r2    
  270   CONTINUE    
        IF(imin.NE.0) THEN  
          DO 280 j=1,4  
  280     p(n+npre,j)=p(n+npre,j)+p(imin,j) 
          p(n+npre,5)=sqrt(p(n+npre,1)**2+p(n+npre,2)**2+p(n+npre,3)**2)    
          nrem=nrem-1   
          k(imin,4)=npre    
          goto 260  
        ENDIF   
      ENDIF 
    
C...Check if more preclusters to be found. Start over if too few.   
      IF(rinit.GE.0.2*paru(43).AND.npre+nrem.LT.mstu(47)) goto 160  
      IF(nrem.GT.0) goto 210    
      njet=npre 
    
C...Reassign all particles to nearest jet. Sum up new jet momenta.  
  290 tsav=0.   
      psjt=0.   
  300 IF(mstu(46).LE.1) THEN    
        DO 310 i=n+1,n+njet 
        DO 310 j=1,4    
  310   v(i,j)=0.   
        DO 340 i=n+np+1,n+2*np  
        r2min=pss**2    
        DO 320 ijet=n+1,n+njet  
        IF(p(ijet,5).LT.rinit) goto 320 
        r2=r2t(i,ijet)  
        IF(r2.GE.r2min) goto 320    
        imin=ijet   
        r2min=r2    
  320   CONTINUE    
        k(i,4)=imin-n   
        DO 330 j=1,4    
  330   v(imin,j)=v(imin,j)+p(i,j)  
  340   CONTINUE    
        psjt=0. 
        DO 360 i=n+1,n+njet 
        DO 350 j=1,4    
  350   p(i,j)=v(i,j)   
        p(i,5)=sqrt(p(i,1)**2+p(i,2)**2+p(i,3)**2)  
  360   psjt=psjt+p(i,5)    
      ENDIF 
    
C...Find two closest jets.  
      r2min=2.*r2acc    
      DO 370 itry1=n+1,n+njet-1 
      DO 370 itry2=itry1+1,n+njet   
      IF(mstu(46).LE.2) r2=r2t(itry1,itry2) 
      IF(mstu(46).GE.3) r2=r2m(itry1,itry2) 
      IF(r2.GE.r2min) goto 370  
      imin1=itry1   
      imin2=itry2   
      r2min=r2  
  370 CONTINUE  
    
C...If allowed, join two closest jets and start over.   
      IF(njet.GT.mstu(47).AND.r2min.LT.r2acc) THEN  
        irec=min(imin1,imin2)   
        idel=max(imin1,imin2)   
        DO 380 j=1,4    
  380   p(irec,j)=p(imin1,j)+p(imin2,j) 
        p(irec,5)=sqrt(p(irec,1)**2+p(irec,2)**2+p(irec,3)**2)  
        DO 390 i=idel+1,n+njet  
        DO 390 j=1,5    
  390   p(i-1,j)=p(i,j) 
        IF(mstu(46).GE.2) THEN  
          DO 400 i=n+np+1,n+2*np    
          iori=n+k(i,4) 
          IF(iori.EQ.idel) k(i,4)=irec-n    
  400     IF(iori.GT.idel) k(i,4)=k(i,4)-1  
        ENDIF   
        njet=njet-1 
        goto 290    
    
C...Divide up broad jet if empty cluster in list of final ones. 
      ELSEIF(njet.EQ.mstu(47).AND.mstu(46).LE.1.AND.nloop.LE.2) THEN    
        DO 410 i=n+1,n+njet 
  410   k(i,5)=0    
        DO 420 i=n+np+1,n+2*np  
  420   k(n+k(i,4),5)=k(n+k(i,4),5)+1   
        iemp=0  
        DO 430 i=n+1,n+njet 
  430   IF(k(i,5).EQ.0) iemp=i  
        IF(iemp.NE.0) THEN  
          nloop=nloop+1 
          ispl=0    
          r2max=0.  
          DO 440 i=n+np+1,n+2*np    
          IF(k(n+k(i,4),5).LE.1.OR.p(i,5).LT.rinit) goto 440    
          ijet=n+k(i,4) 
          r2=r2t(i,ijet)    
          IF(r2.LE.r2max) goto 440  
          ispl=i    
          r2max=r2  
  440     CONTINUE  
          IF(ispl.NE.0) THEN    
            ijet=n+k(ispl,4)    
            DO 450 j=1,4    
            p(iemp,j)=p(ispl,j) 
  450       p(ijet,j)=p(ijet,j)-p(ispl,j)   
            p(iemp,5)=p(ispl,5) 
            p(ijet,5)=sqrt(p(ijet,1)**2+p(ijet,2)**2+p(ijet,3)**2)  
            IF(nloop.LE.2) goto 290 
          ENDIF 
        ENDIF   
      ENDIF 
    
C...If generalized thrust has not yet converged, continue iteration.    
      IF(mstu(46).LE.1.AND.nloop.LE.2.AND.psjt/pss.GT.tsav+paru(48))    
     &THEN  
        tsav=psjt/pss   
        goto 300    
      ENDIF 
    
C...Reorder jets according to energy.   
      DO 460 i=n+1,n+njet   
      DO 460 j=1,5  
  460 v(i,j)=p(i,j) 
      DO 490 inew=n+1,n+njet    
      pemax=0.  
      DO 470 itry=n+1,n+njet    
      IF(v(itry,4).LE.pemax) goto 470   
      imax=itry 
      pemax=v(itry,4)   
  470 CONTINUE  
      k(inew,1)=31  
      k(inew,2)=97  
      k(inew,3)=inew-n  
      k(inew,4)=0   
      DO 480 j=1,5  
  480 p(inew,j)=v(imax,j)   
      v(imax,4)=-1. 
  490 k(imax,5)=inew    
    
C...Clean up particle-jet assignments and jet information.  
      DO 500 i=n+np+1,n+2*np    
      iori=k(n+k(i,4),5)    
      k(i,4)=iori-n 
      IF(k(k(i,3),1).NE.3) k(k(i,3),4)=iori-n   
      k(iori,4)=k(iori,4)+1 
  500 CONTINUE  
      iemp=0    
      psjt=0.   
      DO 520 i=n+1,n+njet   
      k(i,5)=0  
      psjt=psjt+p(i,5)  
      p(i,5)=sqrt(max(p(i,4)**2-p(i,5)**2,0.))  
      DO 510 j=1,5  
  510 v(i,j)=0. 
  520 IF(k(i,4).EQ.0) iemp=i    
    
C...Select storing option. Output variables. Check for failure. 
      mstu(61)=n+1  
      mstu(62)=np   
      mstu(63)=npre 
      paru(61)=ps(5)    
      paru(62)=psjt/pss 
      paru(63)=sqrt(r2min)  
      IF(njet.LE.1) paru(63)=0. 
      IF(iemp.NE.0) THEN    
        CALL luerrm(8,'(LUCLUS:) failed to reconstruct as requested')   
        njet=-1 
      ENDIF 
      IF(mstu(43).LE.1) mstu(3)=njet    
      IF(mstu(43).GE.2) n=n+njet    
      nsav=njet 
    
      RETURN    
      END   
    
C*********************************************************************  
    
      SUBROUTINE lucell(NJET)   
    
C...Purpose: to provide a simple way of jet finding in an eta-phi-ET    
C...coordinate frame, as used for calorimeters at hadron colliders. 
      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/ludat2/kchg(500,3),pmas(500,4),parf(2000),vckm(4,4)    
      SAVE /ludat2/ 
    
C...Loop over all particles. Find cell that was hit by given particle.  
      nce2=2*mstu(51)*mstu(52)  
      ptlrat=1./sinh(paru(51))**2   
      np=0  
      nc=n  
      DO 110 i=1,n  
      IF(k(i,1).LE.0.OR.k(i,1).GT.10) goto 110  
      IF(p(i,1)**2+p(i,2)**2.LE.ptlrat*p(i,3)**2) goto 110  
      IF(mstu(41).GE.2) THEN    
        kc=lucomp(k(i,2))   
        IF(kc.EQ.0.OR.kc.EQ.12.OR.kc.EQ.14.OR.kc.EQ.16.OR.  
     &  kc.EQ.18) goto 110  
        IF(mstu(41).GE.3.AND.kchg(kc,2).EQ.0.AND.luchge(k(i,2)).EQ.0)   
     &  goto 110    
      ENDIF 
      np=np+1   
      pt=sqrt(p(i,1)**2+p(i,2)**2)  
      eta=sign(log((sqrt(pt**2+p(i,3)**2)+abs(p(i,3)))/pt),p(i,3))  
      ieta=max(1,min(mstu(51),1+int(mstu(51)*0.5*(eta/paru(51)+1.))))   
      phi=ulangl(p(i,1),p(i,2)) 
      iphi=max(1,min(mstu(52),1+int(mstu(52)*0.5*(phi/paru(1)+1.))))    
      ietph=mstu(52)*ieta+iphi  
    
C...Add to cell already hit, or book new cell.  
      DO 100 ic=n+1,nc  
      IF(ietph.EQ.k(ic,3)) THEN 
        k(ic,4)=k(ic,4)+1   
        p(ic,5)=p(ic,5)+pt  
        goto 110    
      ENDIF 
  100 CONTINUE  
      IF(nc.GE.mstu(4)-mstu(32)-5) THEN 
        CALL luerrm(11,'(LUCELL:) no more memory left in LUJETS')   
        njet=-2 
        RETURN  
      ENDIF 
      nc=nc+1   
      k(nc,3)=ietph 
      k(nc,4)=1 
      k(nc,5)=2 
      p(nc,1)=(paru(51)/mstu(51))*(2*ieta-1-mstu(51))   
      p(nc,2)=(paru(1)/mstu(52))*(2*iphi-1-mstu(52))    
      p(nc,5)=pt    
  110 CONTINUE  
    
C...Smear true bin content by calorimeter resolution.   
      IF(mstu(53).GE.1) THEN    
        DO 130 ic=n+1,nc    
        pei=p(ic,5) 
        IF(mstu(53).EQ.2) pei=p(ic,5)/cosh(p(ic,1)) 
  120   pef=pei+paru(55)*sqrt(-2.*log(max(1e-10,rlu(0)))*pei)*  
     &  cos(paru(2)*rlu(0)) 
        IF(pef.LT.0..OR.pef.GT.paru(56)*pei) goto 120   
        p(ic,5)=pef 
  130   IF(mstu(53).EQ.2) p(ic,5)=pef*cosh(p(ic,1)) 
      ENDIF 
    
C...Find initiator cell: the one with highest pT of not yet used ones.  
      nj=nc 
  140 etmax=0.  
      DO 150 ic=n+1,nc  
      IF(k(ic,5).NE.2) goto 150 
      IF(p(ic,5).LE.etmax) goto 150 
      icmax=ic  
      eta=p(ic,1)   
      phi=p(ic,2)   
      etmax=p(ic,5) 
  150 CONTINUE  
      IF(etmax.LT.paru(52)) goto 210    
      IF(nj.GE.mstu(4)-mstu(32)-5) THEN 
        CALL luerrm(11,'(LUCELL:) no more memory left in LUJETS')   
        njet=-2 
        RETURN  
      ENDIF 
      k(icmax,5)=1  
      nj=nj+1   
      k(nj,4)=0 
      k(nj,5)=1 
      p(nj,1)=eta   
      p(nj,2)=phi   
      p(nj,3)=0.    
      p(nj,4)=0.    
      p(nj,5)=0.    
    
C...Sum up unused cells within required distance of initiator.  
      DO 160 ic=n+1,nc  
      IF(k(ic,5).EQ.0) goto 160 
      IF(abs(p(ic,1)-eta).GT.paru(54)) goto 160 
      dphia=abs(p(ic,2)-phi)    
      IF(dphia.GT.paru(54).AND.dphia.LT.paru(2)-paru(54)) goto 160  
      phic=p(ic,2)  
      IF(dphia.GT.paru(1)) phic=phic+sign(paru(2),phi)  
      IF((p(ic,1)-eta)**2+(phic-phi)**2.GT.paru(54)**2) goto 160    
      k(ic,5)=-k(ic,5)  
      k(nj,4)=k(nj,4)+k(ic,4)   
      p(nj,3)=p(nj,3)+p(ic,5)*p(ic,1)   
      p(nj,4)=p(nj,4)+p(ic,5)*phic  
      p(nj,5)=p(nj,5)+p(ic,5)   
  160 CONTINUE  
    
C...Reject cluster below minimum ET, else accept.   
      IF(p(nj,5).LT.paru(53)) THEN  
        nj=nj-1 
        DO 170 ic=n+1,nc    
  170   IF(k(ic,5).LT.0) k(ic,5)=-k(ic,5)   
      ELSEIF(mstu(54).LE.2) THEN    
        p(nj,3)=p(nj,3)/p(nj,5) 
        p(nj,4)=p(nj,4)/p(nj,5) 
        IF(abs(p(nj,4)).GT.paru(1)) p(nj,4)=p(nj,4)-sign(paru(2),   
     &  p(nj,4))    
        DO 180 ic=n+1,nc    
  180   IF(k(ic,1).LT.0) k(ic,1)=0  
      ELSE  
        DO 190 j=1,4    
  190   p(nj,j)=0.  
        DO 200 ic=n+1,nc    
        IF(k(ic,5).GE.0) goto 200   
        p(nj,1)=p(nj,1)+p(ic,5)*cos(p(ic,2))    
        p(nj,2)=p(nj,2)+p(ic,5)*sin(p(ic,2))    
        p(nj,3)=p(nj,3)+p(ic,5)*sinh(p(ic,1))   
        p(nj,4)=p(nj,4)+p(ic,5)*cosh(p(ic,1))   
        k(ic,5)=0   
  200   CONTINUE    
      ENDIF 
      goto 140  
    
C...Arrange clusters in falling ET sequence.    
  210 DO 230 i=1,nj-nc  
      etmax=0.  
      DO 220 ij=nc+1,nj 
      IF(k(ij,5).EQ.0) goto 220 
      IF(p(ij,5).LT.etmax) goto 220 
      ijmax=ij  
      etmax=p(ij,5) 
  220 CONTINUE  
      k(ijmax,5)=0  
      k(n+i,1)=31   
      k(n+i,2)=98   
      k(n+i,3)=i    
      k(n+i,4)=k(ijmax,4)   
      k(n+i,5)=0    
      DO 230 j=1,5  
      p(n+i,j)=p(ijmax,j)   
  230 v(n+i,j)=0.   
      njet=nj-nc    
    
C...Convert to massless or massive four-vectors.    
      IF(mstu(54).EQ.2) THEN    
        DO 240 i=n+1,n+njet 
        eta=p(i,3)  
        p(i,1)=p(i,5)*cos(p(i,4))   
        p(i,2)=p(i,5)*sin(p(i,4))   
        p(i,3)=p(i,5)*sinh(eta) 
        p(i,4)=p(i,5)*cosh(eta) 
  240   p(i,5)=0.   
      ELSEIF(mstu(54).GE.3) THEN    
        DO 250 i=n+1,n+njet 
  250   p(i,5)=sqrt(max(0.,p(i,4)**2-p(i,1)**2-p(i,2)**2-p(i,3)**2))    
      ENDIF 
    
C...Information about storage.  
      mstu(61)=n+1  
      mstu(62)=np   
      mstu(63)=nc-n 
      IF(mstu(43).LE.1) mstu(3)=njet    
      IF(mstu(43).GE.2) n=n+njet    
    
      RETURN    
      END   
    
C*********************************************************************  
    
      SUBROUTINE lujmas(PMH,PML)    
    
C...Purpose: to determine, approximately, the two jet masses that   
C...minimize the sum m_H|2 + m_L|2, a la Clavelli and Wyler.    
      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/ludat2/kchg(500,3),pmas(500,4),parf(2000),vckm(4,4)    
      SAVE /ludat2/ 
      dimension sm(3,3),sax(3),ps(3,5)  
    
C...Reset.  
      np=0  
      DO 110 j1=1,3 
      DO 100 j2=j1,3    
  100 sm(j1,j2)=0.  
      DO 110 j2=1,4 
  110 ps(j1,j2)=0.  
      pss=0.    
    
C...Take copy of particles that are to be considered in mass analysis.  
      DO 150 i=1,n  
      IF(k(i,1).LE.0.OR.k(i,1).GT.10) goto 150  
      IF(mstu(41).GE.2) THEN    
        kc=lucomp(k(i,2))   
        IF(kc.EQ.0.OR.kc.EQ.12.OR.kc.EQ.14.OR.kc.EQ.16.OR.  
     &  kc.EQ.18) goto 150  
        IF(mstu(41).GE.3.AND.kchg(kc,2).EQ.0.AND.luchge(k(i,2)).EQ.0)   
     &  goto 150    
      ENDIF 
      IF(n+np+1.GE.mstu(4)-mstu(32)-5) THEN 
        CALL luerrm(11,'(LUJMAS:) no more memory left in LUJETS')   
        pmh=-2. 
        pml=-2. 
        RETURN  
      ENDIF 
      np=np+1   
      DO 120 j=1,5  
  120 p(n+np,j)=p(i,j)  
      IF(mstu(42).EQ.0) p(n+np,5)=0.    
      IF(mstu(42).EQ.1.AND.k(i,2).NE.22) p(n+np,5)=pmas(101,1)  
      p(n+np,4)=sqrt(p(n+np,5)**2+p(i,1)**2+p(i,2)**2+p(i,3)**2)    
    
C...Fill information in sphericity tensor and total momentum vector.    
      DO 130 j1=1,3 
      DO 130 j2=j1,3    
  130 sm(j1,j2)=sm(j1,j2)+p(i,j1)*p(i,j2)   
      pss=pss+(p(i,1)**2+p(i,2)**2+p(i,3)**2)   
      DO 140 j=1,4  
  140 ps(3,j)=ps(3,j)+p(n+np,j) 
  150 CONTINUE  
    
C...Very low multiplicities (0 or 1) not considered.    
      IF(np.LE.1) THEN  
        CALL luerrm(8,'(LUJMAS:) too few particles for analysis')   
        pmh=-1. 
        pml=-1. 
        RETURN  
      ENDIF 
      paru(61)=sqrt(max(0.,ps(3,4)**2-ps(3,1)**2-ps(3,2)**2-ps(3,3)**2))    
    
C...Find largest eigenvalue to matrix (third degree equation).  
      DO 160 j1=1,3 
      DO 160 j2=j1,3    
  160 sm(j1,j2)=sm(j1,j2)/pss   
      sq=(sm(1,1)*sm(2,2)+sm(1,1)*sm(3,3)+sm(2,2)*sm(3,3)-sm(1,2)**2-   
     &sm(1,3)**2-sm(2,3)**2)/3.-1./9.   
      sr=-0.5*(sq+1./9.+sm(1,1)*sm(2,3)**2+sm(2,2)*sm(1,3)**2+sm(3,3)*  
     &sm(1,2)**2-sm(1,1)*sm(2,2)*sm(3,3))+sm(1,2)*sm(1,3)*sm(2,3)+1./27.    
      sp=cos(acos(max(min(sr/sqrt(-sq**3),1.),-1.))/3.) 
      sma=1./3.+sqrt(-sq)*max(2.*sp,sqrt(3.*(1.-sp**2))-sp) 
    
C...Find largest eigenvector by solving equation system.    
      DO 170 j1=1,3 
      sm(j1,j1)=sm(j1,j1)-sma   
      DO 170 j2=j1+1,3  
  170 sm(j2,j1)=sm(j1,j2)   
      smax=0.   
      DO 180 j1=1,3 
      DO 180 j2=1,3 
      IF(abs(sm(j1,j2)).LE.smax) goto 180   
      ja=j1 
      jb=j2 
      smax=abs(sm(j1,j2))   
  180 CONTINUE  
      smax=0.   
      DO 190 j3=ja+1,ja+2   
      j1=j3-3*((j3-1)/3)    
      rl=sm(j1,jb)/sm(ja,jb)    
      DO 190 j2=1,3 
      sm(j1,j2)=sm(j1,j2)-rl*sm(ja,j2)  
      IF(abs(sm(j1,j2)).LE.smax) goto 190   
      jc=j1 
      smax=abs(sm(j1,j2))   
  190 CONTINUE  
      jb1=jb+1-3*(jb/3) 
      jb2=jb+2-3*((jb+1)/3) 
      sax(jb1)=-sm(jc,jb2)  
      sax(jb2)=sm(jc,jb1)   
      sax(jb)=-(sm(ja,jb1)*sax(jb1)+sm(ja,jb2)*sax(jb2))/sm(ja,jb)  
    
C...Divide particles into two initial clusters by hemisphere.   
      DO 200 i=n+1,n+np 
      psax=p(i,1)*sax(1)+p(i,2)*sax(2)+p(i,3)*sax(3)    
      is=1  
      IF(psax.LT.0.) is=2   
      k(i,3)=is 
      DO 200 j=1,4  
  200 ps(is,j)=ps(is,j)+p(i,j)  
      pms=(ps(1,4)**2-ps(1,1)**2-ps(1,2)**2-ps(1,3)**2)+    
     &(ps(2,4)**2-ps(2,1)**2-ps(2,2)**2-ps(2,3)**2) 
    
C...Reassign one particle at a time; find maximum decrease of m|2 sum.  
  210 pmd=0.    
      im=0  
      DO 220 j=1,4  
  220 ps(3,j)=ps(1,j)-ps(2,j)   
      DO 230 i=n+1,n+np 
      pps=p(i,4)*ps(3,4)-p(i,1)*ps(3,1)-p(i,2)*ps(3,2)-p(i,3)*ps(3,3)   
      IF(k(i,3).EQ.1) pmdi=2.*(p(i,5)**2-pps)   
      IF(k(i,3).EQ.2) pmdi=2.*(p(i,5)**2+pps)   
      IF(pmdi.LT.pmd) THEN  
        pmd=pmdi    
        im=i    
      ENDIF 
  230 CONTINUE  
    
C...Loop back if significant reduction in sum of m|2.   
      IF(pmd.LT.-paru(48)*pms) THEN 
        pms=pms+pmd 
        is=k(im,3)  
        DO 240 j=1,4    
        ps(is,j)=ps(is,j)-p(im,j)   
  240   ps(3-is,j)=ps(3-is,j)+p(im,j)   
        k(im,3)=3-is    
        goto 210    
      ENDIF 
    
C...Final masses and output.    
      mstu(61)=n+1  
      mstu(62)=np   
      ps(1,5)=sqrt(max(0.,ps(1,4)**2-ps(1,1)**2-ps(1,2)**2-ps(1,3)**2)) 
      ps(2,5)=sqrt(max(0.,ps(2,4)**2-ps(2,1)**2-ps(2,2)**2-ps(2,3)**2)) 
      pmh=max(ps(1,5),ps(2,5))  
      pml=min(ps(1,5),ps(2,5))  
    
      RETURN    
      END   
    
C*********************************************************************  
    
      SUBROUTINE lufowo(H10,H20,H30,H40)    
    
C...Purpose: to calculate the first few Fox-Wolfram moments.    
      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/ludat2/kchg(500,3),pmas(500,4),parf(2000),vckm(4,4)    
      SAVE /ludat2/ 
    
C...Copy momenta for particles and calculate H0.    
      np=0  
      h0=0. 
      hd=0. 
      DO 110 i=1,n  
      IF(k(i,1).LE.0.OR.k(i,1).GT.10) goto 110  
      IF(mstu(41).GE.2) THEN    
        kc=lucomp(k(i,2))   
        IF(kc.EQ.0.OR.kc.EQ.12.OR.kc.EQ.14.OR.kc.EQ.16.OR.  
     &  kc.EQ.18) goto 110  
        IF(mstu(41).GE.3.AND.kchg(kc,2).EQ.0.AND.luchge(k(i,2)).EQ.0)   
     &  goto 110    
      ENDIF 
      IF(n+np.GE.mstu(4)-mstu(32)-5) THEN   
        CALL luerrm(11,'(LUFOWO:) no more memory left in LUJETS')   
        h10=-1. 
        h20=-1. 
        h30=-1. 
        h40=-1. 
        RETURN  
      ENDIF 
      np=np+1   
      DO 100 j=1,3  
  100 p(n+np,j)=p(i,j)  
      p(n+np,4)=sqrt(p(i,1)**2+p(i,2)**2+p(i,3)**2) 
      h0=h0+p(n+np,4)   
      hd=hd+p(n+np,4)**2    
  110 CONTINUE  
      h0=h0**2  
    
C...Very low multiplicities (0 or 1) not considered.    
      IF(np.LE.1) THEN  
        CALL luerrm(8,'(LUFOWO:) too few particles for analysis')   
        h10=-1. 
        h20=-1. 
        h30=-1. 
        h40=-1. 
        RETURN  
      ENDIF 
    
C...Calculate H1 - H4.  
      h10=0.    
      h20=0.    
      h30=0.    
      h40=0.    
      DO 120 i1=n+1,n+np    
      DO 120 i2=i1+1,n+np   
      cthe=(p(i1,1)*p(i2,1)+p(i1,2)*p(i2,2)+p(i1,3)*p(i2,3))/   
     &(p(i1,4)*p(i2,4)) 
      h10=h10+p(i1,4)*p(i2,4)*cthe  
      h20=h20+p(i1,4)*p(i2,4)*(1.5*cthe**2-0.5) 
      h30=h30+p(i1,4)*p(i2,4)*(2.5*cthe**3-1.5*cthe)    
      h40=h40+p(i1,4)*p(i2,4)*(4.375*cthe**4-3.75*cthe**2+0.375)    
  120 CONTINUE  
    
C...Calculate H1/H0 - H4/H0. Output.    
      mstu(61)=n+1  
      mstu(62)=np   
      h10=(hd+2.*h10)/h0    
      h20=(hd+2.*h20)/h0    
      h30=(hd+2.*h30)/h0    
      h40=(hd+2.*h40)/h0    
    
      RETURN    
      END   
    
C*********************************************************************  
    
      SUBROUTINE lutabu(MTABU)  
    
C...Purpose: to evaluate various properties of an event, with   
C...statistics accumulated during the course of the run and 
C...printed at the end. 
      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/ludat2/kchg(500,3),pmas(500,4),parf(2000),vckm(4,4)    
      SAVE /ludat2/ 
      common/ludat3/mdcy(500,3),mdme(2000,2),brat(2000),kfdp(2000,5)    
      SAVE /ludat3/ 
      dimension kfis(100,2),npis(100,0:10),kffs(400),npfs(400,4),   
     &fevfm(10,4),fm1fm(3,10,4),fm2fm(3,10,4),fmoma(4),fmoms(4),    
     &fevee(50),fe1ec(50),fe2ec(50),fe1ea(25),fe2ea(25),    
     &kfdm(8),kfdc(200,0:8),npdc(200)   
      SAVE nevis,nkfis,kfis,npis,nevfs,nprfs,nfifs,nchfs,nkffs, 
     &kffs,npfs,nevfm,nmufm,fm1fm,fm2fm,nevee,fe1ec,fe2ec,fe1ea,    
     &fe2ea,nevdc,nkfdc,nredc,kfdc,npdc 
      CHARACTER chau*16,chis(2)*12,chdc(8)*12   
      DATA nevis/0/,nkfis/0/,nevfs/0/,nprfs/0/,nfifs/0/,nchfs/0/,   
     &nkffs/0/,nevfm/0/,nmufm/0/,fm1fm/120*0./,fm2fm/120*0./,   
     &nevee/0/,fe1ec/50*0./,fe2ec/50*0./,fe1ea/25*0./,fe2ea/25*0./, 
     &nevdc/0/,nkfdc/0/,nredc/0/    
    
C...Reset statistics on initial parton state.   
      IF(mtabu.EQ.10) THEN  
        nevis=0 
        nkfis=0 
    
C...Identify and order flavour content of initial state.    
      ELSEIF(mtabu.EQ.11) THEN  
        nevis=nevis+1   
        kfm1=2*iabs(mstu(161))  
        IF(mstu(161).GT.0) kfm1=kfm1-1  
        kfm2=2*iabs(mstu(162))  
        IF(mstu(162).GT.0) kfm2=kfm2-1  
        kfmn=min(kfm1,kfm2) 
        kfmx=max(kfm1,kfm2) 
        DO 100 i=1,nkfis    
        IF(kfmn.EQ.kfis(i,1).AND.kfmx.EQ.kfis(i,2)) THEN    
          ikfis=-i  
          goto 110  
        ELSEIF(kfmn.LT.kfis(i,1).OR.(kfmn.EQ.kfis(i,1).AND. 
     &  kfmx.LT.kfis(i,2))) THEN    
          ikfis=i   
          goto 110  
        ENDIF   
  100   CONTINUE    
        ikfis=nkfis+1   
  110   IF(ikfis.LT.0) THEN 
          ikfis=-ikfis  
        ELSE    
          IF(nkfis.GE.100) RETURN   
          DO 120 i=nkfis,ikfis,-1   
          kfis(i+1,1)=kfis(i,1) 
          kfis(i+1,2)=kfis(i,2) 
          DO 120 j=0,10 
  120     npis(i+1,j)=npis(i,j) 
          nkfis=nkfis+1 
          kfis(ikfis,1)=kfmn    
          kfis(ikfis,2)=kfmx    
          DO 130 j=0,10 
  130     npis(ikfis,j)=0   
        ENDIF   
        npis(ikfis,0)=npis(ikfis,0)+1   
    
C...Count number of partons in initial state.   
        np=0    
        DO 150 i=1,n    
        IF(k(i,1).LE.0.OR.k(i,1).GT.12) THEN    
        ELSEIF(iabs(k(i,2)).GT.80.AND.iabs(k(i,2)).LE.100) THEN 
        ELSEIF(iabs(k(i,2)).GT.100.AND.mod(iabs(k(i,2))/10,10).NE.0)    
     &  THEN    
        ELSE    
          im=i  
  140     im=k(im,3)    
          IF(im.LE.0.OR.im.GT.n) THEN   
            np=np+1 
          ELSEIF(k(im,1).LE.0.OR.k(im,1).GT.20) THEN    
            np=np+1 
          ELSEIF(iabs(k(im,2)).GT.80.AND.iabs(k(im,2)).LE.100) THEN 
          ELSEIF(iabs(k(im,2)).GT.100.AND.mod(iabs(k(im,2))/10,10).NE.0)    
     &    THEN  
          ELSE  
            goto 140    
          ENDIF 
        ENDIF   
  150   CONTINUE    
        npco=max(np,1)  
        IF(np.GE.6) npco=6  
        IF(np.GE.8) npco=7  
        IF(np.GE.11) npco=8 
        IF(np.GE.16) npco=9 
        IF(np.GE.26) npco=10    
        npis(ikfis,npco)=npis(ikfis,npco)+1 
        mstu(62)=np 
    
C...Write statistics on initial parton state.   
      ELSEIF(mtabu.EQ.12) THEN  
        fac=1./max(1,nevis) 
        WRITE(mstu(11),1000) nevis  
        DO 160 i=1,nkfis    
        kfmn=kfis(i,1)  
        IF(kfmn.EQ.0) kfmn=kfis(i,2)    
        kfm1=(kfmn+1)/2 
        IF(2*kfm1.EQ.kfmn) kfm1=-kfm1   
        CALL luname(kfm1,chau)  
        chis(1)=chau(1:12)  
        IF(chau(13:13).NE.' ') chis(1)(12:12)='?'   
        kfmx=kfis(i,2)  
        IF(kfis(i,1).EQ.0) kfmx=0   
        kfm2=(kfmx+1)/2 
        IF(2*kfm2.EQ.kfmx) kfm2=-kfm2   
        CALL luname(kfm2,chau)  
        chis(2)=chau(1:12)  
        IF(chau(13:13).NE.' ') chis(2)(12:12)='?'   
  160   WRITE(mstu(11),1100) chis(1),chis(2),fac*npis(i,0), 
     &  (npis(i,j)/float(npis(i,0)),j=1,10) 
    
C...Copy statistics on initial parton state into /LUJETS/.  
      ELSEIF(mtabu.EQ.13) THEN  
        fac=1./max(1,nevis) 
        DO 170 i=1,nkfis    
        kfmn=kfis(i,1)  
        IF(kfmn.EQ.0) kfmn=kfis(i,2)    
        kfm1=(kfmn+1)/2 
        IF(2*kfm1.EQ.kfmn) kfm1=-kfm1   
        kfmx=kfis(i,2)  
        IF(kfis(i,1).EQ.0) kfmx=0   
        kfm2=(kfmx+1)/2 
        IF(2*kfm2.EQ.kfmx) kfm2=-kfm2   
        k(i,1)=32   
        k(i,2)=99   
        k(i,3)=kfm1 
        k(i,4)=kfm2 
        k(i,5)=npis(i,0)    
        DO 170 j=1,5    
        p(i,j)=fac*npis(i,j)    
  170   v(i,j)=fac*npis(i,j+5)  
        n=nkfis 
        DO 180 j=1,5    
        k(n+1,j)=0  
        p(n+1,j)=0. 
  180   v(n+1,j)=0. 
        k(n+1,1)=32 
        k(n+1,2)=99 
        k(n+1,5)=nevis  
        mstu(3)=1   
    
C...Reset statistics on number of particles/partons.    
      ELSEIF(mtabu.EQ.20) THEN  
        nevfs=0 
        nprfs=0 
        nfifs=0 
        nchfs=0 
        nkffs=0 
    
C...Identify whether particle/parton is primary or not. 
      ELSEIF(mtabu.EQ.21) THEN  
        nevfs=nevfs+1   
        mstu(62)=0  
        DO 230 i=1,n    
        IF(k(i,1).LE.0.OR.k(i,1).GT.20.OR.k(i,1).EQ.13) goto 230    
        mstu(62)=mstu(62)+1 
        kc=lucomp(k(i,2))   
        mpri=0  
        IF(k(i,3).LE.0.OR.k(i,3).GT.n) THEN 
          mpri=1    
        ELSEIF(k(k(i,3),1).LE.0.OR.k(k(i,3),1).GT.20) THEN  
          mpri=1    
        ELSEIF(kc.EQ.0) THEN    
        ELSEIF(k(k(i,3),1).EQ.13) THEN  
          im=k(k(i,3),3)    
          IF(im.LE.0.OR.im.GT.n) THEN   
            mpri=1  
          ELSEIF(k(im,1).LE.0.OR.k(im,1).GT.20) THEN    
            mpri=1  
          ENDIF 
        ELSEIF(kchg(kc,2).EQ.0) THEN    
          kcm=lucomp(k(k(i,3),2))   
          IF(kcm.NE.0) THEN 
            IF(kchg(kcm,2).NE.0) mpri=1 
          ENDIF 
        ENDIF   
        IF(kc.NE.0.AND.mpri.EQ.1) THEN  
          IF(kchg(kc,2).EQ.0) nprfs=nprfs+1 
        ENDIF   
        IF(k(i,1).LE.10) THEN   
          nfifs=nfifs+1 
          IF(luchge(k(i,2)).NE.0) nchfs=nchfs+1 
        ENDIF   
    
C...Fill statistics on number of particles/partons in event.    
        kfa=iabs(k(i,2))    
        kfs=3-isign(1,k(i,2))-mpri  
        DO 190 ip=1,nkffs   
        IF(kfa.EQ.kffs(ip)) THEN    
          ikffs=-ip 
          goto 200  
        ELSEIF(kfa.LT.kffs(ip)) THEN    
          ikffs=ip  
          goto 200  
        ENDIF   
  190   CONTINUE    
        ikffs=nkffs+1   
  200   IF(ikffs.LT.0) THEN 
          ikffs=-ikffs  
        ELSE    
          IF(nkffs.GE.400) RETURN   
          DO 210 ip=nkffs,ikffs,-1  
          kffs(ip+1)=kffs(ip)   
          DO 210 j=1,4  
  210     npfs(ip+1,j)=npfs(ip,j)   
          nkffs=nkffs+1 
          kffs(ikffs)=kfa   
          DO 220 j=1,4  
  220     npfs(ikffs,j)=0   
        ENDIF   
        npfs(ikffs,kfs)=npfs(ikffs,kfs)+1   
  230   CONTINUE    
    
C...Write statistics on particle/parton composition of events.  
      ELSEIF(mtabu.EQ.22) THEN  
        fac=1./max(1,nevfs) 
        WRITE(mstu(11),1200) nevfs,fac*nprfs,fac*nfifs,fac*nchfs    
        DO 240 i=1,nkffs    
        CALL luname(kffs(i),chau)   
        kc=lucomp(kffs(i))  
        mdcyf=0 
        IF(kc.NE.0) mdcyf=mdcy(kc,1)    
  240   WRITE(mstu(11),1300) kffs(i),chau,mdcyf,(fac*npfs(i,j),j=1,4),  
     &  fac*(npfs(i,1)+npfs(i,2)+npfs(i,3)+npfs(i,4))   
    
C...Copy particle/parton composition information into /LUJETS/. 
      ELSEIF(mtabu.EQ.23) THEN  
        fac=1./max(1,nevfs) 
        DO 260 i=1,nkffs    
        k(i,1)=32   
        k(i,2)=99   
        k(i,3)=kffs(i)  
        k(i,4)=0    
        k(i,5)=npfs(i,1)+npfs(i,2)+npfs(i,3)+npfs(i,4)  
        DO 250 j=1,4    
        p(i,j)=fac*npfs(i,j)    
  250   v(i,j)=0.   
        p(i,5)=fac*k(i,5)   
  260   v(i,5)=0.   
        n=nkffs 
        DO 270 j=1,5    
        k(n+1,j)=0  
        p(n+1,j)=0. 
  270   v(n+1,j)=0. 
        k(n+1,1)=32 
        k(n+1,2)=99 
        k(n+1,5)=nevfs  
        p(n+1,1)=fac*nprfs  
        p(n+1,2)=fac*nfifs  
        p(n+1,3)=fac*nchfs  
        mstu(3)=1   
    
C...Reset factorial moments statistics. 
      ELSEIF(mtabu.EQ.30) THEN  
        nevfm=0 
        nmufm=0 
        DO 280 im=1,3   
        DO 280 ib=1,10  
        DO 280 ip=1,4   
        fm1fm(im,ib,ip)=0.  
  280   fm2fm(im,ib,ip)=0.  
    
C...Find particles to include, with (pion,pseudo)rapidity and azimuth.  
      ELSEIF(mtabu.EQ.31) THEN  
        nevfm=nevfm+1   
        nlow=n+mstu(3)  
        nupp=nlow   
        DO 360 i=1,n    
        IF(k(i,1).LE.0.OR.k(i,1).GT.10) goto 360    
        IF(mstu(41).GE.2) THEN  
          kc=lucomp(k(i,2)) 
          IF(kc.EQ.0.OR.kc.EQ.12.OR.kc.EQ.14.OR.kc.EQ.16.OR.    
     &    kc.EQ.18) goto 360    
          IF(mstu(41).GE.3.AND.kchg(kc,2).EQ.0.AND.luchge(k(i,2)).EQ.0) 
     &    goto 360  
        ENDIF   
        pmr=0.  
        IF(mstu(42).EQ.1.AND.k(i,2).NE.22) pmr=ulmass(211)  
        IF(mstu(42).GE.2) pmr=p(i,5)    
        pr=max(1e-20,pmr**2+p(i,1)**2+p(i,2)**2)    
        yeta=sign(log(min((sqrt(pr+p(i,3)**2)+abs(p(i,3)))/sqrt(pr),    
     &  1e20)),p(i,3))  
        IF(abs(yeta).GT.paru(57)) goto 360  
        phi=ulangl(p(i,1),p(i,2))   
        iyeta=512.*(yeta+paru(57))/(2.*paru(57))    
        iyeta=max(0,min(511,iyeta)) 
        iphi=512.*(phi+paru(1))/paru(2) 
        iphi=max(0,min(511,iphi))   
        iyep=0  
        DO 290 ib=0,9   
  290   iyep=iyep+4**ib*(2*mod(iyeta/2**ib,2)+mod(iphi/2**ib,2))    
    
C...Order particles in (pseudo)rapidity and/or azimuth. 
        IF(nupp.GT.mstu(4)-5-mstu(32)) THEN 
          CALL luerrm(11,'(LUTABU:) no more memory left in LUJETS') 
          RETURN    
        ENDIF   
        nupp=nupp+1 
        IF(nupp.EQ.nlow+1) THEN 
          k(nupp,1)=iyeta   
          k(nupp,2)=iphi    
          k(nupp,3)=iyep    
        ELSE    
          DO 300 i1=nupp-1,nlow+1,-1    
          IF(iyeta.GE.k(i1,1)) goto 310 
  300     k(i1+1,1)=k(i1,1) 
  310     k(i1+1,1)=iyeta   
          DO 320 i1=nupp-1,nlow+1,-1    
          IF(iphi.GE.k(i1,2)) goto 330  
  320     k(i1+1,2)=k(i1,2) 
  330     k(i1+1,2)=iphi    
          DO 340 i1=nupp-1,nlow+1,-1    
          IF(iyep.GE.k(i1,3)) goto 350  
  340     k(i1+1,3)=k(i1,3) 
  350     k(i1+1,3)=iyep    
        ENDIF   
  360   CONTINUE    
        k(nupp+1,1)=2**10   
        k(nupp+1,2)=2**10   
        k(nupp+1,3)=4**10   
    
C...Calculate sum of factorial moments in event.    
        DO 400 im=1,3   
        DO 370 ib=1,10  
        DO 370 ip=1,4   
  370   fevfm(ib,ip)=0. 
        DO 380 ib=1,10  
        IF(im.LE.2) ibin=2**(10-ib) 
        IF(im.EQ.3) ibin=4**(10-ib) 
        iagr=k(nlow+1,im)/ibin  
        nagr=1  
        DO 380 i=nlow+2,nupp+1  
        icut=k(i,im)/ibin   
        IF(icut.EQ.iagr) THEN   
          nagr=nagr+1   
        ELSE    
          IF(nagr.EQ.1) THEN    
          ELSEIF(nagr.EQ.2) THEN    
            fevfm(ib,1)=fevfm(ib,1)+2.  
          ELSEIF(nagr.EQ.3) THEN    
            fevfm(ib,1)=fevfm(ib,1)+6.  
            fevfm(ib,2)=fevfm(ib,2)+6.  
          ELSEIF(nagr.EQ.4) THEN    
            fevfm(ib,1)=fevfm(ib,1)+12. 
            fevfm(ib,2)=fevfm(ib,2)+24. 
            fevfm(ib,3)=fevfm(ib,3)+24. 
          ELSE  
            fevfm(ib,1)=fevfm(ib,1)+nagr*(nagr-1.)  
            fevfm(ib,2)=fevfm(ib,2)+nagr*(nagr-1.)*(nagr-2.)    
            fevfm(ib,3)=fevfm(ib,3)+nagr*(nagr-1.)*(nagr-2.)*(nagr-3.)  
            fevfm(ib,4)=fevfm(ib,4)+nagr*(nagr-1.)*(nagr-2.)*(nagr-3.)* 
     &      (nagr-4.)   
          ENDIF 
          iagr=icut 
          nagr=1    
        ENDIF   
  380   CONTINUE    
    
C...Add results to total statistics.    
        DO 390 ib=10,1,-1   
        DO 390 ip=1,4   
        IF(fevfm(1,ip).LT.0.5) THEN 
          fevfm(ib,ip)=0.   
        ELSEIF(im.LE.2) THEN    
          fevfm(ib,ip)=2**((ib-1)*ip)*fevfm(ib,ip)/fevfm(1,ip)  
        ELSE    
          fevfm(ib,ip)=4**((ib-1)*ip)*fevfm(ib,ip)/fevfm(1,ip)  
        ENDIF   
        fm1fm(im,ib,ip)=fm1fm(im,ib,ip)+fevfm(ib,ip)    
  390   fm2fm(im,ib,ip)=fm2fm(im,ib,ip)+fevfm(ib,ip)**2 
  400   CONTINUE    
        nmufm=nmufm+(nupp-nlow) 
        mstu(62)=nupp-nlow  
    
C...Write accumulated statistics on factorial moments.  
      ELSEIF(mtabu.EQ.32) THEN  
        fac=1./max(1,nevfm) 
        IF(mstu(42).LE.0) WRITE(mstu(11),1400) nevfm,'eta'  
        IF(mstu(42).EQ.1) WRITE(mstu(11),1400) nevfm,'ypi'  
        IF(mstu(42).GE.2) WRITE(mstu(11),1400) nevfm,'y  '  
        DO 420 im=1,3   
        WRITE(mstu(11),1500)    
        DO 420 ib=1,10  
        byeta=2.*paru(57)   
        IF(im.NE.2) byeta=byeta/2**(ib-1)   
        bphi=paru(2)    
        IF(im.NE.1) bphi=bphi/2**(ib-1) 
        IF(im.LE.2) bnave=fac*nmufm/float(2**(ib-1))    
        IF(im.EQ.3) bnave=fac*nmufm/float(4**(ib-1))    
        DO 410 ip=1,4   
        fmoma(ip)=fac*fm1fm(im,ib,ip)   
  410   fmoms(ip)=sqrt(max(0.,fac*(fac*fm2fm(im,ib,ip)-fmoma(ip)**2)))  
  420   WRITE(mstu(11),1600) byeta,bphi,bnave,(fmoma(ip),fmoms(ip), 
     &  ip=1,4) 
    
C...Copy statistics on factorial moments into /LUJETS/. 
      ELSEIF(mtabu.EQ.33) THEN  
        fac=1./max(1,nevfm) 
        DO 430 im=1,3   
        DO 430 ib=1,10  
        i=10*(im-1)+ib  
        k(i,1)=32   
        k(i,2)=99   
        k(i,3)=1    
        IF(im.NE.2) k(i,3)=2**(ib-1)    
        k(i,4)=1    
        IF(im.NE.1) k(i,4)=2**(ib-1)    
        k(i,5)=0    
        p(i,1)=2.*paru(57)/k(i,3)   
        v(i,1)=paru(2)/k(i,4)   
        DO 430 ip=1,4   
        p(i,ip+1)=fac*fm1fm(im,ib,ip)   
  430   v(i,ip+1)=sqrt(max(0.,fac*(fac*fm2fm(im,ib,ip)-p(i,ip+1)**2)))  
        n=30    
        DO 440 j=1,5    
        k(n+1,j)=0  
        p(n+1,j)=0. 
  440   v(n+1,j)=0. 
        k(n+1,1)=32 
        k(n+1,2)=99 
        k(n+1,5)=nevfm  
        mstu(3)=1   
    
C...Reset statistics on Energy-Energy Correlation.  
      ELSEIF(mtabu.EQ.40) THEN  
        nevee=0 
        DO 450 j=1,25   
        fe1ec(j)=0. 
        fe2ec(j)=0. 
        fe1ec(51-j)=0.  
        fe2ec(51-j)=0.  
        fe1ea(j)=0. 
  450   fe2ea(j)=0. 
    
C...Find particles to include, with proper assumed mass.    
      ELSEIF(mtabu.EQ.41) THEN  
        nevee=nevee+1   
        nlow=n+mstu(3)  
        nupp=nlow   
        ecm=0.  
        DO 460 i=1,n    
        IF(k(i,1).LE.0.OR.k(i,1).GT.10) goto 460    
        IF(mstu(41).GE.2) THEN  
          kc=lucomp(k(i,2)) 
          IF(kc.EQ.0.OR.kc.EQ.12.OR.kc.EQ.14.OR.kc.EQ.16.OR.    
     &    kc.EQ.18) goto 460    
          IF(mstu(41).GE.3.AND.kchg(kc,2).EQ.0.AND.luchge(k(i,2)).EQ.0) 
     &    goto 460  
        ENDIF   
        pmr=0.  
        IF(mstu(42).EQ.1.AND.k(i,2).NE.22) pmr=ulmass(211)  
        IF(mstu(42).GE.2) pmr=p(i,5)    
        IF(nupp.GT.mstu(4)-5-mstu(32)) THEN 
          CALL luerrm(11,'(LUTABU:) no more memory left in LUJETS') 
          RETURN    
        ENDIF   
        nupp=nupp+1 
        p(nupp,1)=p(i,1)    
        p(nupp,2)=p(i,2)    
        p(nupp,3)=p(i,3)    
        p(nupp,4)=sqrt(pmr**2+p(i,1)**2+p(i,2)**2+p(i,3)**2)    
        p(nupp,5)=max(1e-10,sqrt(p(i,1)**2+p(i,2)**2+p(i,3)**2))    
        ecm=ecm+p(nupp,4)   
  460   CONTINUE    
        IF(nupp.EQ.nlow) RETURN 
    
C...Analyze Energy-Energy Correlation in event. 
        fac=(2./ecm**2)*50./paru(1) 
        DO 470 j=1,50   
  470   fevee(j)=0. 
        DO 480 i1=nlow+2,nupp   
        DO 480 i2=nlow+1,i1-1   
        cthe=(p(i1,1)*p(i2,1)+p(i1,2)*p(i2,2)+p(i1,3)*p(i2,3))/ 
     &  (p(i1,5)*p(i2,5))   
        the=acos(max(-1.,min(1.,cthe))) 
        ithe=max(1,min(50,1+int(50.*the/paru(1))))  
  480   fevee(ithe)=fevee(ithe)+fac*p(i1,4)*p(i2,4) 
        DO 490 j=1,25   
        fe1ec(j)=fe1ec(j)+fevee(j)  
        fe2ec(j)=fe2ec(j)+fevee(j)**2   
        fe1ec(51-j)=fe1ec(51-j)+fevee(51-j) 
        fe2ec(51-j)=fe2ec(51-j)+fevee(51-j)**2  
        fe1ea(j)=fe1ea(j)+(fevee(51-j)-fevee(j))    
  490   fe2ea(j)=fe2ea(j)+(fevee(51-j)-fevee(j))**2 
        mstu(62)=nupp-nlow  
    
C...Write statistics on Energy-Energy Correlation.  
      ELSEIF(mtabu.EQ.42) THEN  
        fac=1./max(1,nevee) 
        WRITE(mstu(11),1700) nevee  
        DO 500 j=1,25   
        feec1=fac*fe1ec(j)  
        fees1=sqrt(max(0.,fac*(fac*fe2ec(j)-feec1**2))) 
        feec2=fac*fe1ec(51-j)   
        fees2=sqrt(max(0.,fac*(fac*fe2ec(51-j)-feec2**2)))  
        feeca=fac*fe1ea(j)  
        feesa=sqrt(max(0.,fac*(fac*fe2ea(j)-feeca**2))) 
  500   WRITE(mstu(11),1800) 3.6*(j-1),3.6*j,feec1,fees1,feec2,fees2,   
     &  feeca,feesa 
    
C...Copy statistics on Energy-Energy Correlation into /LUJETS/. 
      ELSEIF(mtabu.EQ.43) THEN  
        fac=1./max(1,nevee) 
        DO 510 i=1,25   
        k(i,1)=32   
        k(i,2)=99   
        k(i,3)=0    
        k(i,4)=0    
        k(i,5)=0    
        p(i,1)=fac*fe1ec(i) 
        v(i,1)=sqrt(max(0.,fac*(fac*fe2ec(i)-p(i,1)**2)))   
        p(i,2)=fac*fe1ec(51-i)  
        v(i,2)=sqrt(max(0.,fac*(fac*fe2ec(51-i)-p(i,2)**2)))    
        p(i,3)=fac*fe1ea(i) 
        v(i,3)=sqrt(max(0.,fac*(fac*fe2ea(i)-p(i,3)**2)))   
        p(i,4)=paru(1)*(i-1)/50.    
        p(i,5)=paru(1)*i/50.    
        v(i,4)=3.6*(i-1)    
  510   v(i,5)=3.6*i    
        n=25    
        DO 520 j=1,5    
        k(n+1,j)=0  
        p(n+1,j)=0. 
  520   v(n+1,j)=0. 
        k(n+1,1)=32 
        k(n+1,2)=99 
        k(n+1,5)=nevee  
        mstu(3)=1   
    
C...Reset statistics on decay channels. 
      ELSEIF(mtabu.EQ.50) THEN  
        nevdc=0 
        nkfdc=0 
        nredc=0 
    
C...Identify and order flavour content of final state.  
      ELSEIF(mtabu.EQ.51) THEN  
        nevdc=nevdc+1   
        nds=0   
        DO 550 i=1,n    
        IF(k(i,1).LE.0.OR.k(i,1).GE.6) goto 550 
        nds=nds+1   
        IF(nds.GT.8) THEN   
          nredc=nredc+1 
          RETURN    
        ENDIF   
        kfm=2*iabs(k(i,2))  
        IF(k(i,2).LT.0) kfm=kfm-1   
        DO 530 ids=nds-1,1,-1   
        iin=ids+1   
        IF(kfm.LT.kfdm(ids)) goto 540   
  530   kfdm(ids+1)=kfdm(ids)   
        iin=1   
  540   kfdm(iin)=kfm   
  550   CONTINUE    
    
C...Find whether old or new final state.    
        DO 570 idc=1,nkfdc  
        IF(nds.LT.kfdc(idc,0)) THEN 
          ikfdc=idc 
          goto 580  
        ELSEIF(nds.EQ.kfdc(idc,0)) THEN 
          DO 560 i=1,nds    
          IF(kfdm(i).LT.kfdc(idc,i)) THEN   
            ikfdc=idc   
            goto 580    
          ELSEIF(kfdm(i).GT.kfdc(idc,i)) THEN   
            goto 570    
          ENDIF 
  560     CONTINUE  
          ikfdc=-idc    
          goto 580  
        ENDIF   
  570   CONTINUE    
        ikfdc=nkfdc+1   
  580   IF(ikfdc.LT.0) THEN 
          ikfdc=-ikfdc  
        ELSEIF(nkfdc.GE.200) THEN   
          nredc=nredc+1 
          RETURN    
        ELSE    
          DO 590 idc=nkfdc,ikfdc,-1 
          npdc(idc+1)=npdc(idc) 
          DO 590 i=0,8  
  590     kfdc(idc+1,i)=kfdc(idc,i) 
          nkfdc=nkfdc+1 
          kfdc(ikfdc,0)=nds 
          DO 600 i=1,nds    
  600     kfdc(ikfdc,i)=kfdm(i) 
          npdc(ikfdc)=0 
        ENDIF   
        npdc(ikfdc)=npdc(ikfdc)+1   
    
C...Write statistics on decay channels. 
      ELSEIF(mtabu.EQ.52) THEN  
        fac=1./max(1,nevdc) 
        WRITE(mstu(11),1900) nevdc  
        DO 620 idc=1,nkfdc  
        DO 610 i=1,kfdc(idc,0)  
        kfm=kfdc(idc,i) 
        kf=(kfm+1)/2    
        IF(2*kf.NE.kfm) kf=-kf  
        CALL luname(kf,chau)    
        chdc(i)=chau(1:12)  
  610   IF(chau(13:13).NE.' ') chdc(i)(12:12)='?'   
  620   WRITE(mstu(11),2000) fac*npdc(idc),(chdc(i),i=1,kfdc(idc,0))    
        IF(nredc.NE.0) WRITE(mstu(11),2100) fac*nredc   
    
C...Copy statistics on decay channels into /LUJETS/.    
      ELSEIF(mtabu.EQ.53) THEN  
        fac=1./max(1,nevdc) 
        DO 650 idc=1,nkfdc  
        k(idc,1)=32 
        k(idc,2)=99 
        k(idc,3)=0  
        k(idc,4)=0  
        k(idc,5)=kfdc(idc,0)    
        DO 630 j=1,5    
        p(idc,j)=0. 
  630   v(idc,j)=0. 
        DO 640 i=1,kfdc(idc,0)  
        kfm=kfdc(idc,i) 
        kf=(kfm+1)/2    
        IF(2*kf.NE.kfm) kf=-kf  
        IF(i.LE.5) p(idc,i)=kf  
  640   IF(i.GE.6) v(idc,i-5)=kf    
  650   v(idc,5)=fac*npdc(idc)  
        n=nkfdc 
        DO 660 j=1,5    
        k(n+1,j)=0  
        p(n+1,j)=0. 
  660   v(n+1,j)=0. 
        k(n+1,1)=32 
        k(n+1,2)=99 
        k(n+1,5)=nevdc  
        v(n+1,5)=fac*nredc  
        mstu(3)=1   
      ENDIF 
    
C...Format statements for output on unit MSTU(11) (default 6).  
 1000 FORMAT(///20x,'Event statistics - initial state'/ 
     &20x,'based on an analysis of ',i6,' events'// 
     &3x,'Main flavours after',8x,'Fraction',4x,'Subfractions ',    
     &'according to fragmenting system multiplicity'/   
     &4x,'hard interaction',24x,'1',7x,'2',7x,'3',7x,'4',7x,'5',    
     &6x,'6-7',5x,'8-10',3x,'11-15',3x,'16-25',4x,'>25'/)   
 1100 FORMAT(3x,a12,1x,a12,f10.5,1x,10f8.4) 
 1200 FORMAT(///20x,'Event statistics - final state'/   
     &20x,'based on an analysis of ',i6,' events'// 
     &5x,'Mean primary multiplicity =',f8.3/    
     &5x,'Mean final   multiplicity =',f8.3/    
     &5x,'Mean charged multiplicity =',f8.3//   
     &5x,'Number of particles produced per event (directly and via ',   
     &'decays/branchings)'/ 
     &5x,'KF    Particle/jet  MDCY',8x,'Particles',9x,'Antiparticles',  
     &5x,'Total'/34x,'prim      seco      prim      seco'/) 
 1300 FORMAT(1x,i6,4x,a16,i2,5(1x,f9.4))    
 1400 FORMAT(///20x,'Factorial moments analysis of multiplicity'/   
     &20x,'based on an analysis of ',i6,' events'// 
     &3x,'delta-',a3,' delta-phi     <n>/bin',10x,'<F2>',18x,'<F3>',    
     &18x,'<F4>',18x,'<F5>'/35x,4('     value     error  '))    
 1500 FORMAT(10x)   
 1600 FORMAT(2x,2f10.4,f12.4,4(f12.4,f10.4))    
 1700 FORMAT(///20x,'Energy-Energy Correlation and Asymmetry'/  
     &20x,'based on an analysis of ',i6,' events'// 
     &2x,'theta range',8x,'EEC(theta)',8x,'EEC(180-theta)',7x,  
     &'EECA(theta)'/2x,'in degrees ',3('      value    error')/)    
 1800 FORMAT(2x,f4.1,' - ',f4.1,3(f11.4,f9.4))  
 1900 FORMAT(///20x,'Decay channel analysis - final state'/ 
     &20x,'based on an analysis of ',i6,' events'// 
     &2x,'Probability',10x,'Complete final state'/) 
 2000 FORMAT(2x,f9.5,5x,8(a12,1x))  
 2100 FORMAT(2x,f9.5,5x,'into other channels (more than 8 particles ',  
     &'or table overflow)') 
    
      RETURN    
      END   
    
C*********************************************************************  
    
      SUBROUTINE lueevt(KFL,ECM)    
    
C...Purpose: to handle the generation of an e+e- annihilation jet event.    
      IMPLICIT DOUBLE PRECISION(d)  
      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/ludat2/kchg(500,3),pmas(500,4),parf(2000),vckm(4,4)    
      SAVE /ludat2/ 
    
C...Check input parameters. 
      IF(mstu(12).GE.1) CALL lulist(0)  
      IF(kfl.LT.0.OR.kfl.GT.8) THEN 
        CALL luerrm(16,'(LUEEVT:) called with unknown flavour code')    
        IF(mstu(21).GE.1) RETURN    
      ENDIF 
      IF(kfl.LE.5) ecmmin=parj(127)+2.02*parf(100+max(1,kfl))   
      IF(kfl.GE.6) ecmmin=parj(127)+2.02*pmas(kfl,1)    
      IF(ecm.LT.ecmmin) THEN    
        CALL luerrm(16,'(LUEEVT:) called with too small CM energy') 
        IF(mstu(21).GE.1) RETURN    
      ENDIF 
    
C...Check consistency of MSTJ options set.  
      IF(mstj(109).EQ.2.AND.mstj(110).NE.1) THEN    
        CALL luerrm(6,  
     &  '(LUEEVT:) MSTJ(109) value requires MSTJ(110) = 1') 
        mstj(110)=1 
      ENDIF 
      IF(mstj(109).EQ.2.AND.mstj(111).NE.0) THEN    
        CALL luerrm(6,  
     &  '(LUEEVT:) MSTJ(109) value requires MSTJ(111) = 0') 
        mstj(111)=0 
      ENDIF 
    
C...Initialize alpha_strong and total cross-section.    
      mstu(111)=mstj(108)   
      IF(mstj(108).EQ.2.AND.(mstj(101).EQ.0.OR.mstj(101).EQ.1)) 
     &mstu(111)=1   
      paru(112)=parj(121)   
      IF(mstu(111).EQ.2) paru(112)=parj(122)    
      IF(mstj(116).GT.0.AND.(mstj(116).GE.2.OR.abs(ecm-parj(151)).GE.   
     &parj(139).OR.10*mstj(102)+kfl.NE.mstj(119))) CALL luxtot(kfl,ecm, 
     &xtot) 
      IF(mstj(116).GE.3) mstj(116)=1    
    
C...Add initial e+e- to event record (documentation only).  
      ntry=0    
  100 ntry=ntry+1   
      IF(ntry.GT.100) THEN  
        CALL luerrm(14,'(LUEEVT:) caught in an infinite loop')  
        RETURN  
      ENDIF 
      nc=0  
      IF(mstj(115).GE.2) THEN   
        nc=nc+2 
        CALL lu1ent(nc-1,11,0.5*ecm,0.,0.)  
        k(nc-1,1)=21    
        CALL lu1ent(nc,-11,0.5*ecm,paru(1),0.)  
        k(nc,1)=21  
      ENDIF 
    
C...Radiative photon (in initial state).    
      mk=0  
      ecmc=ecm  
      IF(mstj(107).GE.1.AND.mstj(116).GE.1) CALL luradk(ecm,mk,pak, 
     &thek,phik,alpk)   
      IF(mk.EQ.1) ecmc=sqrt(ecm*(ecm-2.*pak))   
      IF(mstj(115).GE.1.AND.mk.EQ.1) THEN   
        nc=nc+1 
        CALL lu1ent(nc,22,pak,thek,phik)    
        k(nc,3)=min(mstj(115)/2,1)  
      ENDIF 
    
C...Virtual exchange boson (gamma or Z0).   
      IF(mstj(115).GE.3) THEN   
        nc=nc+1 
        kf=22   
        IF(mstj(102).EQ.2) kf=23    
        mstu10=mstu(10) 
        mstu(10)=1  
        p(nc,5)=ecmc    
        CALL lu1ent(nc,kf,ecmc,0.,0.)   
        k(nc,1)=21  
        k(nc,3)=1   
        mstu(10)=mstu10 
      ENDIF 
    
C...Choice of flavour and jet configuration.    
      CALL luxkfl(kfl,ecm,ecmc,kflc)    
      IF(kflc.EQ.0) goto 100    
      CALL luxjet(ecmc,njet,cut)    
      kfln=21   
      IF(njet.EQ.4) CALL lux4jt(njet,cut,kflc,ecmc,kfln,x1,x2,x4,   
     &x12,x14)  
      IF(njet.EQ.3) CALL lux3jt(njet,cut,kflc,ecmc,x1,x3)   
      IF(njet.EQ.2) mstj(120)=1 
    
C...Fill jet configuration and origin.  
      IF(njet.EQ.2.AND.mstj(101).NE.5) CALL lu2ent(nc+1,kflc,-kflc,ecmc)    
      IF(njet.EQ.2.AND.mstj(101).EQ.5) CALL lu2ent(-(nc+1),kflc,-kflc,  
     &ecmc) 
      IF(njet.EQ.3) CALL lu3ent(nc+1,kflc,21,-kflc,ecmc,x1,x3)  
      IF(njet.EQ.4.AND.kfln.EQ.21) CALL lu4ent(nc+1,kflc,kfln,kfln, 
     &-kflc,ecmc,x1,x2,x4,x12,x14)  
      IF(njet.EQ.4.AND.kfln.NE.21) CALL lu4ent(nc+1,kflc,-kfln,kfln,    
     &-kflc,ecmc,x1,x2,x4,x12,x14)  
      DO 110 ip=nc+1,n  
  110 k(ip,3)=k(ip,3)+min(mstj(115)/2,1)+(mstj(115)/3)*(nc-1)   
    
C...Angular orientation according to matrix element.    
      IF(mstj(106).EQ.1) THEN   
        CALL luxdif(nc,njet,kflc,ecmc,chi,the,phi)  
        CALL ludbrb(nc+1,n,0.,chi,0d0,0d0,0d0)  
        CALL ludbrb(nc+1,n,the,phi,0d0,0d0,0d0) 
      ENDIF 
    
C...Rotation and boost from radiative photon.   
      IF(mk.EQ.1) THEN  
        dbek=-pak/(ecm-pak) 
        nmin=nc+1-mstj(115)/3   
        CALL ludbrb(nmin,n,0.,-phik,0d0,0d0,0d0)    
        CALL ludbrb(nmin,n,alpk,0.,dbek*sin(thek),0d0,dbek*cos(thek))   
        CALL ludbrb(nmin,n,0.,phik,0d0,0d0,0d0) 
      ENDIF 
    
C...Generate parton shower. Rearrange along strings and check.  
      IF(mstj(101).EQ.5) THEN   
        CALL lushow(n-1,n,ecmc) 
        mstj14=mstj(14) 
        IF(mstj(105).EQ.-1) mstj(14)=0  
        IF(mstj(105).GE.0) mstu(28)=0   
        CALL luprep(0)  
        mstj(14)=mstj14 
        IF(mstj(105).GE.0.AND.mstu(28).NE.0) goto 100   
      ENDIF 
    
C...Fragmentation/decay generation. Information for LUTABU. 
      IF(mstj(105).EQ.1) CALL luexec    
      mstu(161)=kflc    
      mstu(162)=-kflc   
    
      RETURN    
      END   
    
C*********************************************************************  
    
      SUBROUTINE luxtot(KFL,ECM,XTOT)   
    
C...Purpose: to calculate total cross-section, including initial    
C...state radiation effects.    
      common/ludat1/mstu(200),paru(200),mstj(200),parj(200) 
      SAVE /ludat1/ 
      common/ludat2/kchg(500,3),pmas(500,4),parf(2000),vckm(4,4)    
      SAVE /ludat2/ 
    
C...Status, (optimized) Q^2 scale, alpha_strong.    
      parj(151)=ecm 
      mstj(119)=10*mstj(102)+kfl    
      IF(mstj(111).EQ.0) THEN   
        q2r=ecm**2  
      ELSEIF(mstu(111).EQ.0) THEN   
        parj(168)=min(1.,max(parj(128),exp(-12.*paru(1)/    
     &  ((33.-2.*mstu(112))*paru(111)))))   
        q2r=parj(168)*ecm**2    
      ELSE  
        parj(168)=min(1.,max(parj(128),paru(112)/ecm,   
     &  (2.*paru(112)/ecm)**2)) 
        q2r=parj(168)*ecm**2    
      ENDIF 
      alspi=ulalps(q2r)/paru(1) 
    
C...QCD corrections factor in R.    
      IF(mstj(101).EQ.0.OR.mstj(109).EQ.1) THEN 
        rqcd=1. 
      ELSEIF(iabs(mstj(101)).EQ.1.AND.mstj(109).EQ.0) THEN  
        rqcd=1.+alspi   
      ELSEIF(mstj(109).EQ.0) THEN   
        rqcd=1.+alspi+(1.986-0.115*mstu(118))*alspi**2  
        IF(mstj(111).EQ.1) rqcd=max(1.,rqcd+(33.-2.*mstu(112))/12.* 
     &  log(parj(168))*alspi**2)    
      ELSEIF(iabs(mstj(101)).EQ.1) THEN 
        rqcd=1.+(3./4.)*alspi   
      ELSE  
        rqcd=1.+(3./4.)*alspi-(3./32.+0.519*mstu(118))*alspi**2 
      ENDIF 
    
C...Calculate Z0 width if default value not acceptable. 
      IF(mstj(102).GE.3) THEN   
        rva=3.*(3.+(4.*paru(102)-1.)**2)+6.*rqcd*(2.+(1.-8.*paru(102)/  
     &  3.)**2+(4.*paru(102)/3.-1.)**2) 
        DO 100 kflc=5,6 
        vq=1.   
        IF(mod(mstj(103),2).EQ.1) vq=sqrt(max(0.,1.-(2.*ulmass(kflc)/   
     &  ecm)**2))   
        IF(kflc.EQ.5) vf=4.*paru(102)/3.-1. 
        IF(kflc.EQ.6) vf=1.-8.*paru(102)/3. 
  100   rva=rva+3.*rqcd*(0.5*vq*(3.-vq**2)*vf**2+vq**3) 
        parj(124)=paru(101)*parj(123)*rva/(48.*paru(102)*(1.-paru(102)))    
      ENDIF 
    
C...Calculate propagator and related constants for QFD case.    
      poll=1.-parj(131)*parj(132)   
      IF(mstj(102).GE.2) THEN   
        sff=1./(16.*paru(102)*(1.-paru(102)))   
        sfw=ecm**4/((ecm**2-parj(123)**2)**2+(parj(123)*parj(124))**2)  
        sfi=sfw*(1.-(parj(123)/ecm)**2) 
        ve=4.*paru(102)-1.  
        sf1i=sff*(ve*poll+parj(132)-parj(131))  
        sf1w=sff**2*((ve**2+1.)*poll+2.*ve*(parj(132)-parj(131)))   
        hf1i=sfi*sf1i   
        hf1w=sfw*sf1w   
      ENDIF 
    
C...Loop over different flavours: charge, velocity. 
      rtot=0.   
      rqq=0.    
      rqv=0.    
      rva=0.    
      DO 110 kflc=1,max(mstj(104),kfl)  
      IF(kfl.GT.0.AND.kflc.NE.kfl) goto 110 
      mstj(93)=1    
      pmq=ulmass(kflc)  
      IF(ecm.LT.2.*pmq+parj(127)) goto 110  
      qf=kchg(kflc,1)/3.    
      vq=1. 
      IF(mod(mstj(103),2).EQ.1) vq=sqrt(1.-(2.*pmq/ecm)**2) 
    
C...Calculate R and sum of charges for QED or QFD case. 
      rqq=rqq+3.*qf**2*poll 
      IF(mstj(102).LE.1) THEN   
        rtot=rtot+3.*0.5*vq*(3.-vq**2)*qf**2*poll   
      ELSE  
        vf=sign(1.,qf)-4.*qf*paru(102)  
        rqv=rqv-6.*qf*vf*sf1i   
        rva=rva+3.*(vf**2+1.)*sf1w  
        rtot=rtot+3.*(0.5*vq*(3.-vq**2)*(qf**2*poll-2.*qf*vf*hf1i+  
     &  vf**2*hf1w)+vq**3*hf1w) 
      ENDIF 
  110 CONTINUE  
      rsum=rqq  
      IF(mstj(102).GE.2) rsum=rqq+sfi*rqv+sfw*rva   
    
C...Calculate cross-section, including QCD corrections. 
      parj(141)=rqq 
      parj(142)=rtot    
      parj(143)=rtot*rqcd   
      parj(144)=parj(143)   
      parj(145)=parj(141)*86.8/ecm**2   
      parj(146)=parj(142)*86.8/ecm**2   
      parj(147)=parj(143)*86.8/ecm**2   
      parj(148)=parj(147)   
      parj(157)=rsum*rqcd   
      parj(158)=0.  
      parj(159)=0.  
      xtot=parj(147)    
      IF(mstj(107).LE.0) RETURN 
    
C...Virtual cross-section.  
      xkl=parj(135) 
      xku=min(parj(136),1.-(2.*parj(127)/ecm)**2)   
      ale=2.*log(ecm/ulmass(11))-1. 
      sigv=ale/3.+2.*log(ecm**2/(ulmass(13)*ulmass(15)))/3.-4./3.+  
     &1.526*log(ecm**2/0.932)   
    
C...Soft and hard radiative cross-section in QED case.  
      IF(mstj(102).LE.1) THEN   
        sigv=1.5*ale-0.5+paru(1)**2/3.+2.*sigv  
        sigs=ale*(2.*log(xkl)-log(1.-xkl)-xkl)  
        sigh=ale*(2.*log(xku/xkl)-log((1.-xku)/(1.-xkl))-(xku-xkl)) 
    
C...Soft and hard radiative cross-section in QFD case.  
      ELSE  
        szm=1.-(parj(123)/ecm)**2   
        szw=parj(123)*parj(124)/ecm**2  
        parj(161)=-rqq/rsum 
        parj(162)=-(rqq+rqv+rva)/rsum   
        parj(163)=(rqv*(1.-0.5*szm-sfi)+rva*(1.5-szm-sfw))/rsum 
        parj(164)=(rqv*szw**2*(1.-2.*sfw)+rva*(2.*sfi+szw**2-4.+3.*szm- 
     &  szm**2))/(szw*rsum) 
        sigv=1.5*ale-0.5+paru(1)**2/3.+((2.*rqq+sfi*rqv)/rsum)*sigv+    
     &  (szw*sfw*rqv/rsum)*paru(1)*20./9.   
        sigs=ale*(2.*log(xkl)+parj(161)*log(1.-xkl)+parj(162)*xkl+  
     &  parj(163)*log(((xkl-szm)**2+szw**2)/(szm**2+szw**2))+   
     &  parj(164)*(atan((xkl-szm)/szw)-atan(-szm/szw))) 
        sigh=ale*(2.*log(xku/xkl)+parj(161)*log((1.-xku)/(1.-xkl))+ 
     &  parj(162)*(xku-xkl)+parj(163)*log(((xku-szm)**2+szw**2)/    
     &  ((xkl-szm)**2+szw**2))+parj(164)*(atan((xku-szm)/szw)-  
     &  atan((xkl-szm)/szw)))   
      ENDIF 
    
C...Total cross-section and fraction of hard photon events. 
      parj(160)=sigh/(paru(1)/paru(101)+sigv+sigs+sigh) 
      parj(157)=rsum*(1.+(paru(101)/paru(1))*(sigv+sigs+sigh))*rqcd 
      parj(144)=parj(157)   
      parj(148)=parj(144)*86.8/ecm**2   
      xtot=parj(148)    
    
      RETURN    
      END   
    
C*********************************************************************  
    
      SUBROUTINE luradk(ECM,MK,PAK,THEK,PHIK,ALPK)  
    
C...Purpose: to generate initial state photon radiation.    
      common/ludat1/mstu(200),paru(200),mstj(200),parj(200) 
      SAVE /ludat1/ 
    
C...Function: cumulative hard photon spectrum in QFD case.  
      fxk(xx)=2.*log(xx)+parj(161)*log(1.-xx)+parj(162)*xx+ 
     &parj(163)*log((xx-szm)**2+szw**2)+parj(164)*atan((xx-szm)/szw)    
    
C...Determine whether radiative photon or not.  
      mk=0  
      pak=0.    
      IF(parj(160).LT.rlu(0)) RETURN    
      mk=1  
    
C...Photon energy range. Find photon momentum in QED case.  
      xkl=parj(135) 
      xku=min(parj(136),1.-(2.*parj(127)/ecm)**2)   
      IF(mstj(102).LE.1) THEN   
  100   xk=1./(1.+(1./xkl-1.)*((1./xku-1.)/(1./xkl-1.))**rlu(0))    
        IF(1.+(1.-xk)**2.LT.2.*rlu(0)) goto 100 
    
C...Ditto in QFD case, by numerical inversion of integrated spectrum.   
      ELSE  
        szm=1.-(parj(123)/ecm)**2   
        szw=parj(123)*parj(124)/ecm**2  
        fxkl=fxk(xkl)   
        fxku=fxk(xku)   
        fxkd=1e-4*(fxku-fxkl)   
        fxkr=fxkl+rlu(0)*(fxku-fxkl)    
        nxk=0   
  110   nxk=nxk+1   
        xk=0.5*(xkl+xku)    
        fxkv=fxk(xk)    
        IF(fxkv.GT.fxkr) THEN   
          xku=xk    
          fxku=fxkv 
        ELSE    
          xkl=xk    
          fxkl=fxkv 
        ENDIF   
        IF(nxk.LT.15.AND.fxku-fxkl.GT.fxkd) goto 110    
        xk=xkl+(xku-xkl)*(fxkr-fxkl)/(fxku-fxkl)    
      ENDIF 
      pak=0.5*ecm*xk    
    
C...Photon polar and azimuthal angle.   
      pme=2.*(ulmass(11)/ecm)**2    
  120 cthm=pme*(2./pme)**rlu(0) 
      IF(1.-(xk**2*cthm*(1.-0.5*cthm)+2.*(1.-xk)*pme/max(pme,   
     &cthm*(1.-0.5*cthm)))/(1.+(1.-xk)**2).LT.rlu(0)) goto 120  
      cthe=1.-cthm  
      IF(rlu(0).GT.0.5) cthe=-cthe  
      sthe=sqrt(max(0.,(cthm-pme)*(2.-cthm)))   
      thek=ulangl(cthe,sthe)    
      phik=paru(2)*rlu(0)   
    
C...Rotation angle for hadronic system. 
      sgn=1.    
      IF(0.5*(2.-xk*(1.-cthe))**2/((2.-xk)**2+(xk*cthe)**2).GT. 
     &rlu(0)) sgn=-1.   
      alpk=asin(sgn*sthe*(xk-sgn*(2.*sqrt(1.-xk)-2.+xk)*cthe)/  
     &(2.-xk*(1.-sgn*cthe)))    
    
      RETURN    
      END   
    
C*********************************************************************  
    
      SUBROUTINE luxkfl(KFL,ECM,ECMC,KFLC)  
    
C...Purpose: to select flavour for produced qqbar pair. 
      common/ludat1/mstu(200),paru(200),mstj(200),parj(200) 
      SAVE /ludat1/ 
      common/ludat2/kchg(500,3),pmas(500,4),parf(2000),vckm(4,4)    
      SAVE /ludat2/ 
    
C...Calculate maximum weight in QED or QFD case.    
      IF(mstj(102).LE.1) THEN   
        rfmax=4./9. 
      ELSE  
        poll=1.-parj(131)*parj(132) 
        sff=1./(16.*paru(102)*(1.-paru(102)))   
        sfw=ecmc**4/((ecmc**2-parj(123)**2)**2+(parj(123)*parj(124))**2)    
        sfi=sfw*(1.-(parj(123)/ecmc)**2)    
        ve=4.*paru(102)-1.  
        hf1i=sfi*sff*(ve*poll+parj(132)-parj(131))  
        hf1w=sfw*sff**2*((ve**2+1.)*poll+2.*ve*(parj(132)-parj(131)))   
        rfmax=max(4./9.*poll-4./3.*(1.-8.*paru(102)/3.)*hf1i+   
     &  ((1.-8.*paru(102)/3.)**2+1.)*hf1w,1./9.*poll+2./3.* 
     &  (-1.+4.*paru(102)/3.)*hf1i+((-1.+4.*paru(102)/3.)**2+1.)*hf1w)  
      ENDIF 
    
C...Choose flavour. Gives charge and velocity.  
      ntry=0    
  100 ntry=ntry+1   
      IF(ntry.GT.100) THEN  
        CALL luerrm(14,'(LUXKFL:) caught in an infinite loop')  
        kflc=0  
        RETURN  
      ENDIF 
      kflc=kfl  
      IF(kfl.LE.0) kflc=1+int(mstj(104)*rlu(0)) 
      mstj(93)=1    
      pmq=ulmass(kflc)  
      IF(ecm.LT.2.*pmq+parj(127)) goto 100  
      qf=kchg(kflc,1)/3.    
      vq=1. 
      IF(mod(mstj(103),2).EQ.1) vq=sqrt(max(0.,1.-(2.*pmq/ecmc)**2))    
    
C...Calculate weight in QED or QFD case.    
      IF(mstj(102).LE.1) THEN   
        rf=qf**2    
        rfv=0.5*vq*(3.-vq**2)*qf**2 
      ELSE  
        vf=sign(1.,qf)-4.*qf*paru(102)  
        rf=qf**2*poll-2.*qf*vf*hf1i+(vf**2+1.)*hf1w 
        rfv=0.5*vq*(3.-vq**2)*(qf**2*poll-2.*qf*vf*hf1i+vf**2*hf1w)+    
     &  vq**3*hf1w  
      ENDIF 
    
C...Weighting or new event (radiative photon). Cross-section update.    
      IF(kfl.LE.0.AND.rf.LT.rlu(0)*rfmax) goto 100  
      parj(158)=parj(158)+1.    
      IF(ecmc.LT.2.*pmq+parj(127).OR.rfv.LT.rlu(0)*rf) kflc=0   
      IF(mstj(107).LE.0.AND.kflc.EQ.0) goto 100 
      IF(kflc.NE.0) parj(159)=parj(159)+1.  
      parj(144)=parj(157)*parj(159)/parj(158)   
      parj(148)=parj(144)*86.8/ecm**2   
    
      RETURN    
      END   
    
C*********************************************************************  
    
      SUBROUTINE luxjet(ECM,NJET,CUT)   
    
C...Purpose: to select number of jets in matrix element approach.   
      common/ludat1/mstu(200),paru(200),mstj(200),parj(200) 
      SAVE /ludat1/ 
      dimension zhut(5) 
    
C...Relative three-jet rate in Zhu second order parametrization.    
      DATA zhut/3.0922, 6.2291, 7.4782, 7.8440, 8.2560/ 
    
C...Trivial result for two-jets only, including parton shower.  
      IF(mstj(101).EQ.0.OR.mstj(101).EQ.5) THEN 
        cut=0.  
    
C...QCD and Abelian vector gluon theory: Q^2 for jet rate and R.    
      ELSEIF(mstj(109).EQ.0.OR.mstj(109).EQ.2) THEN 
        cf=4./3.    
        IF(mstj(109).EQ.2) cf=1.    
        IF(mstj(111).EQ.0) THEN 
          q2=ecm**2 
          q2r=ecm**2    
        ELSEIF(mstu(111).EQ.0) THEN 
          parj(169)=min(1.,parj(129))   
          q2=parj(169)*ecm**2   
          parj(168)=min(1.,max(parj(128),exp(-12.*paru(1)/  
     &    ((33.-2.*mstu(112))*paru(111))))) 
          q2r=parj(168)*ecm**2  
        ELSE    
          parj(169)=min(1.,max(parj(129),(2.*paru(112)/ecm)**2))    
          q2=parj(169)*ecm**2   
          parj(168)=min(1.,max(parj(128),paru(112)/ecm, 
     &    (2.*paru(112)/ecm)**2))   
          q2r=parj(168)*ecm**2  
        ENDIF   
    
C...alpha_strong for R and R itself.    
        alspi=(3./4.)*cf*ulalps(q2r)/paru(1)    
        IF(iabs(mstj(101)).EQ.1) THEN   
          rqcd=1.+alspi 
        ELSEIF(mstj(109).EQ.0) THEN 
          rqcd=1.+alspi+(1.986-0.115*mstu(118))*alspi**2    
          IF(mstj(111).EQ.1) rqcd=max(1.,rqcd+(33.-2.*mstu(112))/12.*   
     &    log(parj(168))*alspi**2)  
        ELSE    
          rqcd=1.+alspi-(3./32.+0.519*mstu(118))*(4.*alspi/3.)**2   
        ENDIF   
    
C...alpha_strong for jet rate. Initial value for y cut. 
        alspi=(3./4.)*cf*ulalps(q2)/paru(1) 
        cut=max(0.001,parj(125),(parj(126)/ecm)**2) 
        IF(iabs(mstj(101)).LE.1.OR.(mstj(109).EQ.0.AND.mstj(111).EQ.0)) 
     &  cut=max(cut,exp(-sqrt(0.75/alspi))/2.)  
        IF(mstj(110).EQ.2) cut=max(0.01,min(0.05,cut))  
    
C...Parametrization of first order three-jet cross-section. 
  100   IF(mstj(101).EQ.0.OR.cut.GE.0.25) THEN  
          parj(152)=0.  
        ELSE    
          parj(152)=(2.*alspi/3.)*((3.-6.*cut+2.*log(cut))* 
     &    log(cut/(1.-2.*cut))+(2.5+1.5*cut-6.571)*(1.-3.*cut)+ 
     &    5.833*(1.-3.*cut)**2-3.894*(1.-3.*cut)**3+    
     &    1.342*(1.-3.*cut)**4)/rqcd    
          IF(mstj(109).EQ.2.AND.(mstj(101).EQ.2.OR.mstj(101).LE.-2))    
     &    parj(152)=0.  
        ENDIF   
    
C...Parametrization of second order three-jet cross-section.    
        IF(iabs(mstj(101)).LE.1.OR.mstj(101).EQ.3.OR.mstj(109).EQ.2.OR. 
     &  cut.GE.0.25) THEN   
          parj(153)=0.  
        ELSEIF(mstj(110).LE.1) THEN 
          ct=log(1./cut-2.) 
          parj(153)=alspi**2*ct**2*(2.419+0.5989*ct+0.6782*ct**2-   
     &    0.2661*ct**3+0.01159*ct**4)/rqcd  
    
C...Interpolation in second/first order ratio for Zhu parametrization.  
        ELSEIF(mstj(110).EQ.2) THEN 
          iza=0 
          DO 110 iy=1,5 
  110     IF(abs(cut-0.01*iy).LT.0.0001) iza=iy 
          IF(iza.NE.0) THEN 
            zhurat=zhut(iza)    
          ELSE  
            iz=100.*cut 
            zhurat=zhut(iz)+(100.*cut-iz)*(zhut(iz+1)-zhut(iz)) 
          ENDIF 
          parj(153)=alspi*parj(152)*zhurat  
        ENDIF   
    
C...Shift in second order three-jet cross-section with optimized Q^2.   
        IF(mstj(111).EQ.1.AND.iabs(mstj(101)).GE.2.AND.mstj(101).NE.3.  
     &  and.cut.LT.0.25) parj(153)=parj(153)+(33.-2.*mstu(112))/12.*    
     &  log(parj(169))*alspi*parj(152)  
    
C...Parametrization of second order four-jet cross-section. 
        IF(iabs(mstj(101)).LE.1.OR.cut.GE.0.125) THEN   
          parj(154)=0.  
        ELSE    
          ct=log(1./cut-5.) 
          IF(cut.LE.0.018) THEN 
            xqqgg=6.349-4.330*ct+0.8304*ct**2   
            IF(mstj(109).EQ.2) xqqgg=(4./3.)**2*(3.035-2.091*ct+    
     &      0.4059*ct**2)   
            xqqqq=1.25*(-0.1080+0.01486*ct+0.009364*ct**2)  
            IF(mstj(109).EQ.2) xqqqq=8.*xqqqq   
          ELSE  
            xqqgg=-0.09773+0.2959*ct-0.2764*ct**2+0.08832*ct**3 
            IF(mstj(109).EQ.2) xqqgg=(4./3.)**2*(-0.04079+0.1340*ct-    
     &      0.1326*ct**2+0.04365*ct**3) 
            xqqqq=1.25*(0.003661-0.004888*ct-0.001081*ct**2+0.002093*   
     &      ct**3)  
            IF(mstj(109).EQ.2) xqqqq=8.*xqqqq   
          ENDIF 
          parj(154)=alspi**2*ct**2*(xqqgg+xqqqq)/rqcd   
          parj(155)=xqqqq/(xqqgg+xqqqq) 
        ENDIF   
    
C...If negative three-jet rate, change y' optimization parameter.   
        IF(mstj(111).EQ.1.AND.parj(152)+parj(153).LT.0..AND.    
     &  parj(169).LT.0.99) THEN 
          parj(169)=min(1.,1.2*parj(169))   
          q2=parj(169)*ecm**2   
          alspi=(3./4.)*cf*ulalps(q2)/paru(1)   
          goto 100  
        ENDIF   
    
C...If too high cross-section, use harder cuts, or fail.    
        IF(parj(152)+parj(153)+parj(154).GE.1) THEN 
          IF(mstj(110).EQ.2.AND.cut.GT.0.0499.AND.mstj(111).EQ.1.AND.   
     &    parj(169).LT.0.99) THEN   
            parj(169)=min(1.,1.2*parj(169)) 
            q2=parj(169)*ecm**2 
            alspi=(3./4.)*cf*ulalps(q2)/paru(1) 
            goto 100    
          ELSEIF(mstj(110).EQ.2.AND.cut.GT.0.0499) THEN 
            CALL luerrm(26, 
     &      '(LUXJET:) no allowed y cut value for Zhu parametrization') 
          ENDIF 
          cut=0.26*(4.*cut)**(parj(152)+parj(153)+parj(154))**(-1./3.)  
          IF(mstj(110).EQ.2) cut=max(0.01,min(0.05,cut))    
          goto 100  
        ENDIF   
    
C...Scalar gluon (first order only).    
      ELSE  
        alspi=ulalps(ecm**2)/paru(1)    
        cut=max(0.001,parj(125),(parj(126)/ecm)**2,exp(-3./alspi))  
        parj(152)=0.    
        IF(cut.LT.0.25) parj(152)=(alspi/3.)*((1.-2.*cut)*  
     &  log((1.-2.*cut)/cut)+0.5*(9.*cut**2-1.))    
        parj(153)=0.    
        parj(154)=0.    
      ENDIF 
    
C...Select number of jets.  
      parj(150)=cut 
      IF(mstj(101).EQ.0.OR.mstj(101).EQ.5) THEN 
        njet=2  
      ELSEIF(mstj(101).LE.0) THEN   
        njet=min(4,2-mstj(101)) 
      ELSE  
        rnj=rlu(0)  
        njet=2  
        IF(parj(152)+parj(153)+parj(154).GT.rnj) njet=3 
        IF(parj(154).GT.rnj) njet=4 
      ENDIF 
    
      RETURN    
      END   
    
C*********************************************************************  
    
      SUBROUTINE lux3jt(NJET,CUT,KFL,ECM,X1,X2) 
    
C...Purpose: to select the kinematical variables of three-jet events.   
      common/ludat1/mstu(200),paru(200),mstj(200),parj(200) 
      SAVE /ludat1/ 
      dimension zhup(5,12)  
    
C...Coefficients of Zhu second order parametrization.   
      DATA ((zhup(ic1,ic2),ic2=1,12),ic1=1,5)/  
     &    18.29,    89.56,    4.541,   -52.09,   -109.8,    24.90,  
     &    11.63,    3.683,    17.50, 0.002440,   -1.362,  -0.3537,  
     &    11.42,    6.299,   -22.55,   -8.915,    59.25,   -5.855,  
     &   -32.85,   -1.054,   -16.90, 0.006489,  -0.8156,  0.01095,  
     &    7.847,   -3.964,   -35.83,    1.178,    29.39,   0.2806,  
     &    47.82,   -12.36,   -56.72,  0.04054,  -0.4365,   0.6062,  
     &    5.441,   -56.89,   -50.27,    15.13,    114.3,   -18.19,  
     &    97.05,   -1.890,   -139.9,  0.08153,  -0.4984,   0.9439,  
     &   -17.65,    51.44,   -58.32,    70.95,   -255.7,   -78.99,  
     &    476.9,    29.65,   -239.3,   0.4745,   -1.174,    6.081/  
    
C...Dilogarithm of x for x<0.5 (x>0.5 obtained by analytic trick).  
      dilog(x)=x+x**2/4.+x**3/9.+x**4/16.+x**5/25.+x**6/36.+x**7/49.    
    
C...Event type. Mass effect factors and other common constants. 
      mstj(120)=2   
      mstj(121)=0   
      pmq=ulmass(kfl)   
      qme=(2.*pmq/ecm)**2   
      IF(mstj(109).NE.1) THEN   
        cutl=log(cut)   
        cutd=log(1./cut-2.) 
        IF(mstj(109).EQ.0) THEN 
          cf=4./3.  
          cn=3. 
          tr=2. 
          wtmx=min(20.,37.-6.*cutd) 
          IF(mstj(110).EQ.2) wtmx=2.*(7.5+80.*cut)  
        ELSE    
          cf=1. 
          cn=0. 
          tr=12.    
          wtmx=0.   
        ENDIF   
    
C...Alpha_strong and effects of optimized Q^2 scale. Maximum weight.    
        als2pi=paru(118)/paru(2)    
        wtopt=0.    
        IF(mstj(111).EQ.1) wtopt=(33.-2.*mstu(112))/6.*log(parj(169))*  
     &  als2pi  
        wtmax=max(0.,1.+wtopt+als2pi*wtmx)  
    
C...Choose three-jet events in allowed region.  
  100   njet=3  
  110   y13l=cutl+cutd*rlu(0)   
        y23l=cutl+cutd*rlu(0)   
        y13=exp(y13l)   
        y23=exp(y23l)   
        y12=1.-y13-y23  
        IF(y12.LE.cut) goto 110 
        IF(y13**2+y23**2+2.*y12.LE.2.*rlu(0)) goto 110  
    
C...Second order corrections.   
        IF(mstj(101).EQ.2.AND.mstj(110).LE.1) THEN  
          y12l=log(y12) 
          y13m=log(1.-y13)  
          y23m=log(1.-y23)  
          y12m=log(1.-y12)  
          IF(y13.LE.0.5) y13i=dilog(y13)    
          IF(y13.GE.0.5) y13i=1.644934-y13l*y13m-dilog(1.-y13)  
          IF(y23.LE.0.5) y23i=dilog(y23)    
          IF(y23.GE.0.5) y23i=1.644934-y23l*y23m-dilog(1.-y23)  
          IF(y12.LE.0.5) y12i=dilog(y12)    
          IF(y12.GE.0.5) y12i=1.644934-y12l*y12m-dilog(1.-y12)  
          wt1=(y13**2+y23**2+2.*y12)/(y13*y23)  
          wt2=cf*(-2.*(cutl-y12l)**2-3.*cutl-1.+3.289868+   
     &    2.*(2.*cutl-y12l)*cut/y12)+   
     &    cn*((cutl-y12l)**2-(cutl-y13l)**2-(cutl-y23l)**2-11.*cutl/6.+ 
     &    67./18.+1.644934-(2.*cutl-y12l)*cut/y12+(2.*cutl-y13l)*   
     &    cut/y13+(2.*cutl-y23l)*cut/y23)+  
     &    tr*(2.*cutl/3.-10./9.)+   
     &    cf*(y12/(y12+y13)+y12/(y12+y23)+(y12+y23)/y13+(y12+y13)/y23+  
     &    y13l*(4.*y12**2+2.*y12*y13+4.*y12*y23+y13*y23)/(y12+y23)**2+  
     &    y23l*(4.*y12**2+2.*y12*y23+4.*y12*y13+y13*y23)/(y12+y13)**2)/ 
     &    wt1+  
     &    cn*(y13l*y13/(y12+y23)+y23l*y23/(y12+y13))/wt1+   
     &    (cn-2.*cf)*((y12**2+(y12+y13)**2)*(y12l*y23l-y12l*y12m-y23l*  
     &    y23m+1.644934-y12i-y23i)/(y13*y23)+(y12**2+(y12+y23)**2)* 
     &    (y12l*y13l-y12l*y12m-y13l*y13m+1.644934-y12i-y13i)/   
     &    (y13*y23)+(y13**2+y23**2)/(y13*y23*(y13+y23))-    
     &    2.*y12l*y12**2/(y13+y23)**2-4.*y12l*y12/(y13+y23))/wt1-   
     &    cn*(y13l*y23l-y13l*y13m-y23l*y23m+1.644934-y13i-y23i) 
          IF(1.+wtopt+als2pi*wt2.LE.0.) mstj(121)=1 
          IF(1.+wtopt+als2pi*wt2.LE.wtmax*rlu(0)) goto 110  
          parj(156)=(wtopt+als2pi*wt2)/(1.+wtopt+als2pi*wt2)    
    
        ELSEIF(mstj(101).EQ.2.AND.mstj(110).EQ.2) THEN  
C...Second order corrections; Zhu parametrization of ERT.   
          zx=(y23-y13)**2   
          zy=1.-y12 
          iza=0 
          DO 120 iy=1,5 
  120     IF(abs(cut-0.01*iy).LT.0.0001) iza=iy 
          IF(iza.NE.0) THEN 
            iz=iza  
            wt2=zhup(iz,1)+zhup(iz,2)*zx+zhup(iz,3)*zx**2+(zhup(iz,4)+  
     &      zhup(iz,5)*zx)*zy+(zhup(iz,6)+zhup(iz,7)*zx)*zy**2+ 
     &      (zhup(iz,8)+zhup(iz,9)*zx)*zy**3+zhup(iz,10)/(zx-zy**2)+    
     &      zhup(iz,11)/(1.-zy)+zhup(iz,12)/zy  
          ELSE  
            iz=100.*cut 
            wtl=zhup(iz,1)+zhup(iz,2)*zx+zhup(iz,3)*zx**2+(zhup(iz,4)+  
     &      zhup(iz,5)*zx)*zy+(zhup(iz,6)+zhup(iz,7)*zx)*zy**2+ 
     &      (zhup(iz,8)+zhup(iz,9)*zx)*zy**3+zhup(iz,10)/(zx-zy**2)+    
     &      zhup(iz,11)/(1.-zy)+zhup(iz,12)/zy  
            iz=iz+1 
            wtu=zhup(iz,1)+zhup(iz,2)*zx+zhup(iz,3)*zx**2+(zhup(iz,4)+  
     &      zhup(iz,5)*zx)*zy+(zhup(iz,6)+zhup(iz,7)*zx)*zy**2+ 
     &      (zhup(iz,8)+zhup(iz,9)*zx)*zy**3+zhup(iz,10)/(zx-zy**2)+    
     &      zhup(iz,11)/(1.-zy)+zhup(iz,12)/zy  
            wt2=wtl+(wtu-wtl)*(100.*cut+1.-iz)  
          ENDIF 
          IF(1.+wtopt+2.*als2pi*wt2.LE.0.) mstj(121)=1  
          IF(1.+wtopt+2.*als2pi*wt2.LE.wtmax*rlu(0)) goto 110   
          parj(156)=(wtopt+2.*als2pi*wt2)/(1.+wtopt+2.*als2pi*wt2)  
        ENDIF   
    
C...Impose mass cuts (gives two jets). For fixed jet number new try.    
        x1=1.-y23   
        x2=1.-y13   
        x3=1.-y12   
        IF(4.*y23*y13*y12/x3**2.LE.qme) njet=2  
        IF(mod(mstj(103),4).GE.2.AND.iabs(mstj(101)).LE.1.AND.qme*x3+   
     &  0.5*qme**2+(0.5*qme+0.25*qme**2)*((1.-x2)/(1.-x1)+  
     &  (1.-x1)/(1.-x2)).GT.(x1**2+x2**2)*rlu(0)) njet=2    
        IF(mstj(101).EQ.-1.AND.njet.EQ.2) goto 100  
    
C...Scalar gluon model (first order only, no mass effects). 
      ELSE  
  130   njet=3  
  140   y12=sqrt(4.*cut**2+rlu(0)*((1.-cut)**2-4.*cut**2))  
        IF(log((y12-cut)/cut).LE.rlu(0)*log((1.-2.*cut)/cut)) goto 140  
        yd=sign(2.*cut*((y12-cut)/cut)**rlu(0)-y12,rlu(0)-0.5)  
        x1=1.-0.5*(y12+yd)  
        x2=1.-0.5*(y12-yd)  
        IF(4.*(1.-x1)*(1.-x2)*y12/(1.-y12)**2.LE.qme) njet=2    
        IF(mstj(101).EQ.-1.AND.njet.EQ.2) goto 130  
      ENDIF 
    
      RETURN    
      END   
    
C*********************************************************************  
    
      SUBROUTINE lux4jt(NJET,CUT,KFL,ECM,KFLN,X1,X2,X4,X12,X14) 
    
C...Purpose: to select the kinematical variables of four-jet events.    
      common/ludat1/mstu(200),paru(200),mstj(200),parj(200) 
      SAVE /ludat1/ 
      dimension wta(4),wtb(4),wtc(4),wtd(4),wte(4)  
    
C...Common constants. Colour factors for QCD and Abelian gluon theory.  
      pmq=ulmass(kfl)   
      qme=(2.*pmq/ecm)**2   
      ct=log(1./cut-5.) 
      IF(mstj(109).EQ.0) THEN   
        cf=4./3.    
        cn=3.   
        tr=2.   
      ELSE  
        cf=1.   
        cn=0.   
        tr=12.  
      ENDIF 
    
C...Choice of process (qqbargg or qqbarqqbar).  
  100 njet=4    
      it=1  
      IF(parj(155).GT.rlu(0)) it=2  
      IF(mstj(101).LE.-3) it=-mstj(101)-2   
      IF(it.EQ.1) wtmx=0.7/cut**2   
      IF(it.EQ.1.AND.mstj(109).EQ.2) wtmx=0.6/cut**2    
      IF(it.EQ.2) wtmx=0.1125*cf*tr/cut**2  
      id=1  
    
C...Sample the five kinematical variables (for qqgg preweighted in y34).    
  110 y134=3.*cut+(1.-6.*cut)*rlu(0)    
      y234=3.*cut+(1.-6.*cut)*rlu(0)    
      IF(it.EQ.1) y34=(1.-5.*cut)*exp(-ct*rlu(0))   
      IF(it.EQ.2) y34=cut+(1.-6.*cut)*rlu(0)    
      IF(y34.LE.y134+y234-1..OR.y34.GE.y134*y234) goto 110  
      vt=rlu(0) 
      cp=cos(paru(1)*rlu(0))    
      y14=(y134-y34)*vt 
      y13=y134-y14-y34  
      vb=y34*(1.-y134-y234+y34)/((y134-y34)*(y234-y34)) 
      y24=0.5*(y234-y34)*(1.-4.*sqrt(max(0.,vt*(1.-vt)*vb*(1.-vb)))*    
     &cp-(1.-2.*vt)*(1.-2.*vb)) 
      y23=y234-y34-y24  
      y12=1.-y134-y23-y24   
      IF(min(y12,y13,y14,y23,y24).LE.cut) goto 110  
      y123=y12+y13+y23  
      y124=y12+y14+y24  
    
C...Calculate matrix elements for qqgg or qqqq process. 
      ic=0  
      wttot=0.  
  120 ic=ic+1   
      IF(it.EQ.1) THEN  
        wta(ic)=(y12*y34**2-y13*y24*y34+y14*y23*y34+3.*y12*y23*y34+ 
     &  3.*y12*y14*y34+4.*y12**2*y34-y13*y23*y24+2.*y12*y23*y24-    
     &  y13*y14*y24-2.*y12*y13*y24+2.*y12**2*y24+y14*y23**2+2.*y12* 
     &  y23**2+y14**2*y23+4.*y12*y14*y23+4.*y12**2*y23+2.*y12*y14**2+   
     &  2.*y12*y13*y14+4.*y12**2*y14+2.*y12**2*y13+2.*y12**3)/(2.*y13*  
     &  y134*y234*y24)+(y24*y34+y12*y34+y13*y24-y14*y23+y12*y13)/(y13*  
     &  y134**2)+2.*y23*(1.-y13)/(y13*y134*y24)+y34/(2.*y13*y24)    
        wtb(ic)=(y12*y24*y34+y12*y14*y34-y13*y24**2+y13*y14*y24+2.*y12* 
     &  y14*y24)/(y13*y134*y23*y14)+y12*(1.+y34)*y124/(y134*y234*y14*   
     &  y24)-(2.*y13*y24+y14**2+y13*y23+2.*y12*y13)/(y13*y134*y14)+ 
     &  y12*y123*y124/(2.*y13*y14*y23*y24)  
        wtc(ic)=-(5.*y12*y34**2+2.*y12*y24*y34+2.*y12*y23*y34+2.*y12*   
     &  y14*y34+2.*y12*y13*y34+4.*y12**2*y34-y13*y24**2+y14*y23*y24+    
     &  y13*y23*y24+y13*y14*y24-y12*y14*y24-y13**2*y24-3.*y12*y13*y24-  
     &  y14*y23**2-y14**2*y23+y13*y14*y23-3.*y12*y14*y23-y12*y13*y23)/  
     &  (4.*y134*y234*y34**2)+(3.*y12*y34**2-3.*y13*y24*y34+3.*y12*y24* 
     &  y34+3.*y14*y23*y34-y13*y24**2-y12*y23*y34+6.*y12*y14*y34+2.*y12*    
     &  y13*y34-2.*y12**2*y34+y14*y23*y24-3.*y13*y23*y24-2.*y13*y14*    
     &  y24+4.*y12*y14*y24+2.*y12*y13*y24+3.*y14*y23**2+2.*y14**2*y23+  
     &  2.*y14**2*y12+2.*y12**2*y14+6.*y12*y14*y23-2.*y12*y13**2-   
     &  2.*y12**2*y13)/(4.*y13*y134*y234*y34)   
        wtc(ic)=wtc(ic)+(2.*y12*y34**2-2.*y13*y24*y34+y12*y24*y34+  
     &  4.*y13*y23*y34+4.*y12*y14*y34+2.*y12*y13*y34+2.*y12**2*y34- 
     &  y13*y24**2+3.*y14*y23*y24+4.*y13*y23*y24-2.*y13*y14*y24+    
     &  4.*y12*y14*y24+2.*y12*y13*y24+2.*y14*y23**2+4.*y13*y23**2+  
     &  2.*y13*y14*y23+2.*y12*y14*y23+4.*y12*y13*y23+2.*y12*y14**2+4.*  
     &  y12**2*y13+4.*y12*y13*y14+2.*y12**2*y14)/(4.*y13*y134*y24*y34)- 
     &  (y12*y34**2-2.*y14*y24*y34-2.*y13*y24*y34-y14*y23*y34+y13*y23*  
     &  y34+y12*y14*y34+2.*y12*y13*y34-2.*y14**2*y24-4.*y13*y14*y24-    
     &  4.*y13**2*y24-y14**2*y23-y13**2*y23+y12*y13*y14-y12*y13**2)/    
     &  (2.*y13*y34*y134**2)+(y12*y34**2-4.*y14*y24*y34-2.*y13*y24*y34- 
     &  2.*y14*y23*y34-4.*y13*y23*y34-4.*y12*y14*y34-4.*y12*y13*y34-    
     &  2.*y13*y14*y24+2.*y13**2*y24+2.*y14**2*y23-2.*y13*y14*y23-  
     &  y12*y14**2-6.*y12*y13*y14-y12*y13**2)/(4.*y34**2*y134**2)   
        wttot=wttot+y34*cf*(cf*wta(ic)+(cf-0.5*cn)*wtb(ic)+cn*wtc(ic))/ 
     &  8.  
      ELSE  
        wtd(ic)=(y13*y23*y34+y12*y23*y34-y12**2*y34+y13*y23*y24+2.*y12* 
     &  y23*y24-y14*y23**2+y12*y13*y24+y12*y14*y23+y12*y13*y14)/(y13**2*    
     &  y123**2)-(y12*y34**2-y13*y24*y34+y12*y24*y34-y14*y23*y34-y12*   
     &  y23*y34-y13*y24**2+y14*y23*y24-y13*y23*y24-y13**2*y24+y14*  
     &  y23**2)/(y13**2*y123*y134)+(y13*y14*y12+y34*y14*y12-y34**2*y12+ 
     &  y13*y14*y24+2.*y34*y14*y24-y23*y14**2+y34*y13*y24+y34*y23*y14+  
     &  y34*y13*y23)/(y13**2*y134**2)-(y34*y12**2-y13*y24*y12+y34*y24*  
     &  y12-y23*y14*y12-y34*y14*y12-y13*y24**2+y23*y14*y24-y13*y14*y24- 
     &  y13**2*y24+y23*y14**2)/(y13**2*y134*y123)   
        wte(ic)=(y12*y34*(y23-y24+y14+y13)+y13*y24**2-y14*y23*y24+y13*  
     &  y23*y24+y13*y14*y24+y13**2*y24-y14*y23*(y14+y23+y13))/(y13*y23* 
     &  y123*y134)-y12*(y12*y34-y23*y24-y13*y24-y14*y23-y14*y13)/(y13*  
     &  y23*y123**2)-(y14+y13)*(y24+y23)*y34/(y13*y23*y134*y234)+   
     &  (y12*y34*(y14-y24+y23+y13)+y13*y24**2-y23*y14*y24+y13*y14*y24+  
     &  y13*y23*y24+y13**2*y24-y23*y14*(y14+y23+y13))/(y13*y14*y134*    
     &  y123)-y34*(y34*y12-y14*y24-y13*y24-y23*y14-y23*y13)/(y13*y14*   
     &  y134**2)-(y23+y13)*(y24+y14)*y12/(y13*y14*y123*y124)    
        wttot=wttot+cf*(tr*wtd(ic)+(cf-0.5*cn)*wte(ic))/16. 
      ENDIF 
    
C...Permutations of momenta in matrix element. Weighting.   
  130 IF(ic.EQ.1.OR.ic.EQ.3.OR.id.EQ.2.OR.id.EQ.3) THEN 
        ysav=y13    
        y13=y14 
        y14=ysav    
        ysav=y23    
        y23=y24 
        y24=ysav    
        ysav=y123   
        y123=y124   
        y124=ysav   
      ENDIF 
      IF(ic.EQ.2.OR.ic.EQ.4.OR.id.EQ.3.OR.id.EQ.4) THEN 
        ysav=y13    
        y13=y23 
        y23=ysav    
        ysav=y14    
        y14=y24 
        y24=ysav    
        ysav=y134   
        y134=y234   
        y234=ysav   
      ENDIF 
      IF(ic.LE.3) goto 120  
      IF(id.EQ.1.AND.wttot.LT.rlu(0)*wtmx) goto 110 
      ic=5  
    
C...qqgg events: string configuration and event type.   
      IF(it.EQ.1) THEN  
        IF(mstj(109).EQ.0.AND.id.EQ.1) THEN 
          parj(156)=y34*(2.*(wta(1)+wta(2)+wta(3)+wta(4))+4.*(wtc(1)+   
     &    wtc(2)+wtc(3)+wtc(4)))/(9.*wttot) 
          IF(wta(2)+wta(4)+2.*(wtc(2)+wtc(4)).GT.rlu(0)*(wta(1)+wta(2)+ 
     &    wta(3)+wta(4)+2.*(wtc(1)+wtc(2)+wtc(3)+wtc(4)))) id=2 
          IF(id.EQ.2) goto 130  
        ELSEIF(mstj(109).EQ.2.AND.id.EQ.1) THEN 
          parj(156)=y34*(wta(1)+wta(2)+wta(3)+wta(4))/(8.*wttot)    
          IF(wta(2)+wta(4).GT.rlu(0)*(wta(1)+wta(2)+wta(3)+wta(4))) id=2    
          IF(id.EQ.2) goto 130  
        ENDIF   
        mstj(120)=3 
        IF(mstj(109).EQ.0.AND.0.5*y34*(wtc(1)+wtc(2)+wtc(3)+wtc(4)).GT. 
     &  rlu(0)*wttot) mstj(120)=4   
        kfln=21 
    
C...Mass cuts. Kinematical variables out.   
        IF(y12.LE.cut+qme) njet=2   
        IF(njet.EQ.2) goto 150  
        q12=0.5*(1.-sqrt(1.-qme/y12))   
        x1=1.-(1.-q12)*y234-q12*y134    
        x4=1.-(1.-q12)*y134-q12*y234    
        x2=1.-y124  
        x12=(1.-q12)*y13+q12*y23    
        x14=y12-0.5*qme 
        IF(y134*y234/((1.-x1)*(1.-x4)).LE.rlu(0)) njet=2    
    
C...qqbarqqbar events: string configuration, choose new flavour.    
      ELSE  
        IF(id.EQ.1) THEN    
          wtr=rlu(0)*(wtd(1)+wtd(2)+wtd(3)+wtd(4))  
          IF(wtr.LT.wtd(2)+wtd(3)+wtd(4)) id=2  
          IF(wtr.LT.wtd(3)+wtd(4)) id=3 
          IF(wtr.LT.wtd(4)) id=4    
          IF(id.GE.2) goto 130  
        ENDIF   
        mstj(120)=5 
        parj(156)=cf*tr*(wtd(1)+wtd(2)+wtd(3)+wtd(4))/(16.*wttot)   
  140   kfln=1+int(5.*rlu(0))   
        IF(kfln.NE.kfl.AND.0.2*parj(156).LE.rlu(0)) goto 140    
        IF(kfln.EQ.kfl.AND.1.-0.8*parj(156).LE.rlu(0)) goto 140 
        IF(kfln.GT.mstj(104)) njet=2    
        pmqn=ulmass(kfln)   
        qmen=(2.*pmqn/ecm)**2   
    
C...Mass cuts. Kinematical variables out.   
        IF(y24.LE.cut+qme.OR.y13.LE.1.1*qmen) njet=2    
        IF(njet.EQ.2) goto 150  
        q24=0.5*(1.-sqrt(1.-qme/y24))   
        q13=0.5*(1.-sqrt(1.-qmen/y13))  
        x1=1.-(1.-q24)*y123-q24*y134    
        x4=1.-(1.-q24)*y134-q24*y123    
        x2=1.-(1.-q13)*y234-q13*y124    
        x12=(1.-q24)*((1.-q13)*y14+q13*y34)+q24*((1.-q13)*y12+q13*y23)  
        x14=y24-0.5*qme 
        x34=(1.-q24)*((1.-q13)*y23+q13*y12)+q24*((1.-q13)*y34+q13*y14)  
        IF(pmq**2+pmqn**2+min(x12,x34)*ecm**2.LE.   
     &  (parj(127)+pmq+pmqn)**2) njet=2 
        IF(y123*y134/((1.-x1)*(1.-x4)).LE.rlu(0)) njet=2    
      ENDIF 
  150 IF(mstj(101).LE.-2.AND.njet.EQ.2) goto 100    
    
      RETURN    
      END   
    
C*********************************************************************  
    
      SUBROUTINE luxdif(NC,NJET,KFL,ECM,CHI,THE,PHI)    
    
C...Purpose: to give the angular orientation of events. 
      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/ludat2/kchg(500,3),pmas(500,4),parf(2000),vckm(4,4)    
      SAVE /ludat2/ 
    
C...Charge. Factors depending on polarization for QED case. 
      qf=kchg(kfl,1)/3. 
      poll=1.-parj(131)*parj(132)   
      pold=parj(132)-parj(131)  
      IF(mstj(102).LE.1.OR.mstj(109).EQ.1) THEN 
        hf1=poll    
        hf2=0.  
        hf3=parj(133)**2    
        hf4=0.  
    
C...Factors depending on flavour, energy and polarization for QFD case. 
      ELSE  
        sff=1./(16.*paru(102)*(1.-paru(102)))   
        sfw=ecm**4/((ecm**2-parj(123)**2)**2+(parj(123)*parj(124))**2)  
        sfi=sfw*(1.-(parj(123)/ecm)**2) 
        ae=-1.  
        ve=4.*paru(102)-1.  
        af=sign(1.,qf)  
        vf=af-4.*qf*paru(102)   
        hf1=qf**2*poll-2.*qf*vf*sfi*sff*(ve*poll-ae*pold)+  
     &  (vf**2+af**2)*sfw*sff**2*((ve**2+ae**2)*poll-2.*ve*ae*pold) 
        hf2=-2.*qf*af*sfi*sff*(ae*poll-ve*pold)+2.*vf*af*sfw*sff**2*    
     &  (2.*ve*ae*poll-(ve**2+ae**2)*pold)  
        hf3=parj(133)**2*(qf**2-2.*qf*vf*sfi*sff*ve+(vf**2+af**2)*  
     &  sfw*sff**2*(ve**2-ae**2))   
        hf4=-parj(133)**2*2.*qf*vf*sfw*(parj(123)*parj(124)/ecm**2)*    
     &  sff*ae  
      ENDIF 
    
C...Mass factor. Differential cross-sections for two-jet events.    
      sq2=sqrt(2.)  
      qme=0.    
      IF(mstj(103).GE.4.AND.iabs(mstj(101)).LE.1.AND.mstj(102).LE.1.AND.    
     &mstj(109).NE.1) qme=(2.*ulmass(kfl)/ecm)**2   
      IF(njet.EQ.2) THEN    
        sigu=4.*sqrt(1.-qme)    
        sigl=2.*qme*sqrt(1.-qme)    
        sigt=0. 
        sigi=0. 
        siga=0. 
        sigp=4. 
    
C...Kinematical variables. Reduce four-jet event to three-jet one.  
      ELSE  
        IF(njet.EQ.3) THEN  
          x1=2.*p(nc+1,4)/ecm   
          x2=2.*p(nc+3,4)/ecm   
        ELSE    
          ecmr=p(nc+1,4)+p(nc+4,4)+sqrt((p(nc+2,1)+p(nc+3,1))**2+   
     &    (p(nc+2,2)+p(nc+3,2))**2+(p(nc+2,3)+p(nc+3,3))**2)    
          x1=2.*p(nc+1,4)/ecmr  
          x2=2.*p(nc+4,4)/ecmr  
        ENDIF   
    
C...Differential cross-sections for three-jet (or reduced four-jet).    
        xq=(1.-x1)/(1.-x2)  
        ct12=(x1*x2-2.*x1-2.*x2+2.+qme)/sqrt((x1**2-qme)*(x2**2-qme))   
        st12=sqrt(1.-ct12**2)   
        IF(mstj(109).NE.1) THEN 
          sigu=2.*x1**2+x2**2*(1.+ct12**2)-qme*(3.+ct12**2-x1-x2)-  
     &    qme*x1/xq+0.5*qme*((x2**2-qme)*st12**2-2.*x2)*xq  
          sigl=(x2*st12)**2-qme*(3.-ct12**2-2.5*(x1+x2)+x1*x2+qme)+ 
     &    0.5*qme*(x1**2-x1-qme)/xq+0.5*qme*((x2**2-qme)*ct12**2-x2)*xq 
          sigt=0.5*(x2**2-qme-0.5*qme*(x2**2-qme)/xq)*st12**2   
          sigi=((1.-0.5*qme*xq)*(x2**2-qme)*st12*ct12+qme*(1.-x1-x2+    
     &    0.5*x1*x2+0.5*qme)*st12/ct12)/sq2 
          siga=x2**2*st12/sq2   
          sigp=2.*(x1**2-x2**2*ct12)    
    
C...Differential cross-sect for scalar gluons (no mass or QFD effects). 
        ELSE    
          sigu=2.*(2.-x1-x2)**2-(x2*st12)**2    
          sigl=(x2*st12)**2 
          sigt=0.5*sigl 
          sigi=-(2.-x1-x2)*x2*st12/sq2  
          siga=0.   
          sigp=0.   
        ENDIF   
      ENDIF 
    
C...Upper bounds for differential cross-section.    
      hf1a=abs(hf1) 
      hf2a=abs(hf2) 
      hf3a=abs(hf3) 
      hf4a=abs(hf4) 
      sigmax=(2.*hf1a+hf3a+hf4a)*abs(sigu)+2.*(hf1a+hf3a+hf4a)* 
     &abs(sigl)+2.*(hf1a+2.*hf3a+2.*hf4a)*abs(sigt)+2.*sq2* 
     &(hf1a+2.*hf3a+2.*hf4a)*abs(sigi)+4.*sq2*hf2a*abs(siga)+   
     &2.*hf2a*abs(sigp) 
    
C...Generate angular orientation according to differential cross-sect.  
  100 chi=paru(2)*rlu(0)    
      cthe=2.*rlu(0)-1. 
      phi=paru(2)*rlu(0)    
      cchi=cos(chi) 
      schi=sin(chi) 
      c2chi=cos(2.*chi) 
      s2chi=sin(2.*chi) 
      the=acos(cthe)    
      sthe=sin(the) 
      c2phi=cos(2.*(phi-parj(134))) 
      s2phi=sin(2.*(phi-parj(134))) 
      sig=((1.+cthe**2)*hf1+sthe**2*(c2phi*hf3-s2phi*hf4))*sigu+    
     &2.*(sthe**2*hf1-sthe**2*(c2phi*hf3-s2phi*hf4))*sigl+  
     &2.*(sthe**2*c2chi*hf1+((1.+cthe**2)*c2chi*c2phi-2.*cthe*s2chi*    
     &s2phi)*hf3-((1.+cthe**2)*c2chi*s2phi+2.*cthe*s2chi*c2phi)*hf4)*   
     &sigt-2.*sq2*(2.*sthe*cthe*cchi*hf1-2.*sthe*(cthe*cchi*c2phi-  
     &schi*s2phi)*hf3+2.*sthe*(cthe*cchi*s2phi+schi*c2phi)*hf4)*sigi+   
     &4.*sq2*sthe*cchi*hf2*siga+2.*cthe*hf2*sigp    
      IF(sig.LT.sigmax*rlu(0)) goto 100 
    
      RETURN    
      END   
    
C*********************************************************************  
    
      SUBROUTINE luonia(KFL,ECM)    
    
C...Purpose: to generate Upsilon and toponium decays into three 
C...gluons or two gluons and a photon.  
      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/ludat2/kchg(500,3),pmas(500,4),parf(2000),vckm(4,4)    
      SAVE /ludat2/ 
    
C...Printout. Check input parameters.   
      IF(mstu(12).GE.1) CALL lulist(0)  
      IF(kfl.LT.0.OR.kfl.GT.8) THEN 
        CALL luerrm(16,'(LUONIA:) called with unknown flavour code')    
        IF(mstu(21).GE.1) RETURN    
      ENDIF 
      IF(ecm.LT.parj(127)+2.02*parf(101)) THEN  
        CALL luerrm(16,'(LUONIA:) called with too small CM energy') 
        IF(mstu(21).GE.1) RETURN    
      ENDIF 
    
C...Initial e+e- and onium state (optional).    
      nc=0  
      IF(mstj(115).GE.2) THEN   
        nc=nc+2 
        CALL lu1ent(nc-1,11,0.5*ecm,0.,0.)  
        k(nc-1,1)=21    
        CALL lu1ent(nc,-11,0.5*ecm,paru(1),0.)  
        k(nc,1)=21  
      ENDIF 
      kflc=iabs(kfl)    
      IF(mstj(115).GE.3.AND.kflc.GE.5) THEN 
        nc=nc+1 
        kf=110*kflc+3   
        mstu10=mstu(10) 
        mstu(10)=1  
        p(nc,5)=ecm 
        CALL lu1ent(nc,kf,ecm,0.,0.)    
        k(nc,1)=21  
        k(nc,3)=1   
        mstu(10)=mstu10 
      ENDIF 
    
C...Choose x1 and x2 according to matrix element.   
      ntry=0    
  100 x1=rlu(0) 
      x2=rlu(0) 
      x3=2.-x1-x2   
      IF(x3.GE.1..OR.((1.-x1)/(x2*x3))**2+((1.-x2)/(x1*x3))**2+ 
     &((1.-x3)/(x1*x2))**2.LE.2.*rlu(0)) goto 100   
      ntry=ntry+1   
      njet=3    
      IF(mstj(101).LE.4) CALL lu3ent(nc+1,21,21,21,ecm,x1,x3)   
      IF(mstj(101).GE.5) CALL lu3ent(-(nc+1),21,21,21,ecm,x1,x3)    
    
C...Photon-gluon-gluon events. Small system modifications. Jet origin.  
      mstu(111)=mstj(108)   
      IF(mstj(108).EQ.2.AND.(mstj(101).EQ.0.OR.mstj(101).EQ.1)) 
     &mstu(111)=1   
      paru(112)=parj(121)   
      IF(mstu(111).EQ.2) paru(112)=parj(122)    
      qf=0. 
      IF(kflc.NE.0) qf=kchg(kflc,1)/3.  
      rgam=7.2*qf**2*paru(101)/ulalps(ecm**2)   
      mk=0  
      ecmc=ecm  
      IF(rlu(0).GT.rgam/(1.+rgam)) THEN 
        IF(1.-max(x1,x2,x3).LE.max((parj(126)/ecm)**2,parj(125)))   
     &  njet=2  
        IF(njet.EQ.2.AND.mstj(101).LE.4) CALL lu2ent(nc+1,21,21,ecm)    
        IF(njet.EQ.2.AND.mstj(101).GE.5) CALL lu2ent(-(nc+1),21,21,ecm) 
      ELSE  
        mk=1    
        ecmc=sqrt(1.-x1)*ecm    
        IF(ecmc.LT.2.*parj(127)) goto 100   
        k(nc+1,1)=1 
        k(nc+1,2)=22    
        k(nc+1,4)=0 
        k(nc+1,5)=0 
        IF(mstj(101).GE.5) k(nc+2,4)=mstu(5)*(nc+3) 
        IF(mstj(101).GE.5) k(nc+2,5)=mstu(5)*(nc+3) 
        IF(mstj(101).GE.5) k(nc+3,4)=mstu(5)*(nc+2) 
        IF(mstj(101).GE.5) k(nc+3,5)=mstu(5)*(nc+2) 
        njet=2  
        IF(ecmc.LT.4.*parj(127)) THEN   
          mstu10=mstu(10)   
          mstu(10)=1    
          p(nc+2,5)=ecmc    
          CALL lu1ent(nc+2,83,0.5*(x2+x3)*ecm,paru(1),0.)   
          mstu(10)=mstu10   
          njet=0    
        ENDIF   
      ENDIF 
      DO 110 ip=nc+1,n  
  110 k(ip,3)=k(ip,3)+(mstj(115)/2)+(kflc/5)*(mstj(115)/3)*(nc-1)   
    
C...Differential cross-sections. Upper limit for cross-section. 
      IF(mstj(106).EQ.1) THEN   
        sq2=sqrt(2.)    
        hf1=1.-parj(131)*parj(132)  
        hf3=parj(133)**2    
        ct13=(x1*x3-2.*x1-2.*x3+2.)/(x1*x3) 
        st13=sqrt(1.-ct13**2)   
        sigl=0.5*x3**2*((1.-x2)**2+(1.-x3)**2)*st13**2  
        sigu=(x1*(1.-x1))**2+(x2*(1.-x2))**2+(x3*(1.-x3))**2-sigl   
        sigt=0.5*sigl   
        sigi=(sigl*ct13/st13+0.5*x1*x3*(1.-x2)**2*st13)/sq2 
        sigmax=(2.*hf1+hf3)*abs(sigu)+2.*(hf1+hf3)*abs(sigl)+2.*(hf1+   
     &  2.*hf3)*abs(sigt)+2.*sq2*(hf1+2.*hf3)*abs(sigi) 
    
C...Angular orientation of event.   
  120   chi=paru(2)*rlu(0)  
        cthe=2.*rlu(0)-1.   
        phi=paru(2)*rlu(0)  
        cchi=cos(chi)   
        schi=sin(chi)   
        c2chi=cos(2.*chi)   
        s2chi=sin(2.*chi)   
        the=acos(cthe)  
        sthe=sin(the)   
        c2phi=cos(2.*(phi-parj(134)))   
        s2phi=sin(2.*(phi-parj(134)))   
        sig=((1.+cthe**2)*hf1+sthe**2*c2phi*hf3)*sigu+2.*(sthe**2*hf1-  
     &  sthe**2*c2phi*hf3)*sigl+2.*(sthe**2*c2chi*hf1+((1.+cthe**2)*    
     &  c2chi*c2phi-2.*cthe*s2chi*s2phi)*hf3)*sigt-2.*sq2*(2.*sthe*cthe*    
     &  cchi*hf1-2.*sthe*(cthe*cchi*c2phi-schi*s2phi)*hf3)*sigi 
        IF(sig.LT.sigmax*rlu(0)) goto 120   
        CALL ludbrb(nc+1,n,0.,chi,0d0,0d0,0d0)  
        CALL ludbrb(nc+1,n,the,phi,0d0,0d0,0d0) 
      ENDIF 
    
C...Generate parton shower. Rearrange along strings and check.  
      IF(mstj(101).GE.5.AND.njet.GE.2) THEN 
        CALL lushow(nc+mk+1,-njet,ecmc) 
        mstj14=mstj(14) 
        IF(mstj(105).EQ.-1) mstj(14)=0  
        IF(mstj(105).GE.0) mstu(28)=0   
        CALL luprep(0)  
        mstj(14)=mstj14 
        IF(mstj(105).GE.0.AND.mstu(28).NE.0) goto 100   
      ENDIF 
    
C...Generate fragmentation. Information for LUTABU: 
      IF(mstj(105).EQ.1) CALL luexec    
      mstu(161)=110*kflc+3  
      mstu(162)=0   
    
      RETURN    
      END   
    
C*********************************************************************  
    
      SUBROUTINE luhepc(MCONV)  
    
C...Purpose: to convert JETSET event record contents to or from 
C...the standard event record commonblock.  
      parameter(nmxhep=9000)   
      common/hepevt/nevhep,nhep,isthep(nmxhep),idhep(nmxhep),   
     &jmohep(2,nmxhep),jdahep(2,nmxhep),phep(5,nmxhep),vhep(4,nmxhep)   
      SAVE /hepevt/ 
      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/ludat2/kchg(500,3),pmas(500,4),parf(2000),vckm(4,4)    
      SAVE /ludat2/ 
    
C...Conversion from JETSET to standard, the easy part.  
      IF(mconv.EQ.1) THEN   
        nevhep=0    
        IF(n.GT.nmxhep) CALL luerrm(8,  
     &  '(LUHEPC:) no more space in /HEPEVT/')  
        nhep=min(n,nmxhep)  
        DO 140 i=1,nhep 
        isthep(i)=0 
        IF(k(i,1).GE.1.AND.k(i,1).LE.10) isthep(i)=1    
        IF(k(i,1).GE.11.AND.k(i,1).LE.20) isthep(i)=2   
        IF(k(i,1).GE.21.AND.k(i,1).LE.30) isthep(i)=3   
        IF(k(i,1).GE.31.AND.k(i,1).LE.100) isthep(i)=k(i,1) 
        idhep(i)=k(i,2) 
        jmohep(1,i)=k(i,3)  
        jmohep(2,i)=0   
        IF(k(i,1).NE.3.AND.k(i,1).NE.13.AND.k(i,1).NE.14) THEN  
          jdahep(1,i)=k(i,4)    
          jdahep(2,i)=k(i,5)    
        ELSE    
          jdahep(1,i)=0 
          jdahep(2,i)=0 
        ENDIF   
        DO 100 j=1,5    
  100   phep(j,i)=p(i,j)    
        DO 110 j=1,4    
  110   vhep(j,i)=v(i,j)    
    
C...Fill in missing mother information. 
        IF(k(i,2).GE.91.AND.k(i,2).LE.93) THEN  
          i1=k(i,3)-1   
  120     i1=i1+1   
          IF(i1.GE.i) CALL luerrm(8,    
     &    '(LUHEPC:) translation of inconsistent event history')    
          IF(i1.LT.i.AND.k(i1,1).NE.1.AND.k(i1,1).NE.11) goto 120   
          kc=lucomp(k(i1,2))    
          IF(i1.LT.i.AND.kc.EQ.0) goto 120  
          IF(i1.LT.i.AND.kchg(kc,2).EQ.0) goto 120  
          jmohep(2,i)=i1    
        ELSEIF(k(i,2).EQ.94) THEN   
          njet=2    
          IF(nhep.GE.i+3.AND.k(i+3,3).LE.i) njet=3  
          IF(nhep.GE.i+4.AND.k(i+4,3).LE.i) njet=4  
          jmohep(2,i)=mod(k(i+njet,4)/mstu(5),mstu(5))  
          IF(jmohep(2,i).EQ.jmohep(1,i)) jmohep(2,i)=   
     &    mod(k(i+1,4)/mstu(5),mstu(5)) 
        ENDIF   
    
C...Fill in missing daughter information.   
        IF(k(i,2).EQ.94.AND.mstu(16).NE.2) THEN 
          DO 130 i1=jdahep(1,i),jdahep(2,i) 
          i2=mod(k(i1,4)/mstu(5),mstu(5))   
  130     jdahep(1,i2)=i    
        ENDIF   
        IF(k(i,2).GE.91.AND.k(i,2).LE.94) goto 140  
        i1=jmohep(1,i)  
        IF(i1.LE.0.OR.i1.GT.nhep) goto 140  
        IF(k(i1,1).NE.13.AND.k(i1,1).NE.14) goto 140    
        IF(jdahep(1,i1).EQ.0) THEN  
          jdahep(1,i1)=i    
        ELSE    
          jdahep(2,i1)=i    
        ENDIF   
  140   CONTINUE    
        DO 150 i=1,nhep 
        IF(k(i,1).NE.13.AND.k(i,1).NE.14) goto 150  
        IF(jdahep(2,i).EQ.0) jdahep(2,i)=jdahep(1,i)    
  150   CONTINUE    
    
C...Conversion from standard to JETSET, the easy part.  
      ELSE  
        IF(nhep.GT.mstu(4)) CALL luerrm(8,  
     &  '(LUHEPC:) no more space in /LUJETS/')  
        n=min(nhep,mstu(4)) 
        nkq=0   
        kqsum=0 
        DO 180 i=1,n    
        k(i,1)=0    
        IF(isthep(i).EQ.1) k(i,1)=1 
        IF(isthep(i).EQ.2) k(i,1)=11    
        IF(isthep(i).EQ.3) k(i,1)=21    
        k(i,2)=idhep(i) 
        k(i,3)=jmohep(1,i)  
        k(i,4)=jdahep(1,i)  
        k(i,5)=jdahep(2,i)  
        DO 160 j=1,5    
  160   p(i,j)=phep(j,i)    
        DO 170 j=1,4    
  170   v(i,j)=vhep(j,i)    
        v(i,5)=0.   
        IF(isthep(i).EQ.2.AND.phep(4,i).GT.phep(5,i)) THEN  
          i1=jdahep(1,i)    
          IF(i1.GT.0.AND.i1.LE.nhep) v(i,5)=(vhep(4,i1)-vhep(4,i))* 
     &    phep(5,i)/phep(4,i)   
        ENDIF   
    
C...Fill in missing information on colour connection in jet systems.    
        IF(isthep(i).EQ.1) THEN 
          kc=lucomp(k(i,2)) 
          kq=0  
          IF(kc.NE.0) kq=kchg(kc,2)*isign(1,k(i,2)) 
          IF(kq.NE.0) nkq=nkq+1 
          IF(kq.NE.2) kqsum=kqsum+kq    
          IF(kq.NE.0.AND.kqsum.NE.0) THEN   
            k(i,1)=2    
          ELSEIF(kq.EQ.2.AND.i.LT.n) THEN   
            IF(k(i+1,2).EQ.21) k(i,1)=2 
          ENDIF 
        ENDIF   
  180   CONTINUE    
        IF(nkq.EQ.1.OR.kqsum.NE.0) CALL luerrm(8,   
     &  '(LUHEPC:) input parton configuration not colour singlet')  
      ENDIF 
    
      END   
    
C*********************************************************************  
    
      SUBROUTINE lutest(MTEST)  
    
C...Purpose: to provide a simple program (disguised as subroutine) to   
C...run at installation as a check that the program works as intended.  
      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/ 
      dimension psum(5),pini(6),pfin(6) 
    
C...Loop over events to be generated.   
      IF(mtest.GE.1) CALL lutabu(20)    
      nerr=0    
      DO 170 iev=1,600  
    
C...Reset parameter values. Switch on some nonstandard features.    
      mstj(1)=1 
      mstj(3)=0 
      mstj(11)=1    
      mstj(42)=2    
      mstj(43)=4    
      mstj(44)=2    
      parj(17)=0.1  
      parj(22)=1.5  
      parj(43)=1.   
      parj(54)=-0.05    
      mstj(101)=5   
      mstj(104)=5   
      mstj(105)=0   
      mstj(107)=1   
      IF(iev.EQ.301.OR.iev.EQ.351.OR.iev.EQ.401) mstj(116)=3    
    
C...Ten events each for some single jets configurations.    
      IF(iev.LE.50) THEN    
        ity=(iev+9)/10  
        mstj(3)=-1  
        IF(ity.EQ.3.OR.ity.EQ.4) mstj(11)=2 
        IF(ity.EQ.1) CALL lu1ent(1,1,15.,0.,0.) 
        IF(ity.EQ.2) CALL lu1ent(1,3101,15.,0.,0.)  
        IF(ity.EQ.3) CALL lu1ent(1,-2203,15.,0.,0.) 
        IF(ity.EQ.4) CALL lu1ent(1,-4,30.,0.,0.)    
        IF(ity.EQ.5) CALL lu1ent(1,21,15.,0.,0.)    
    
C...Ten events each for some simple jet systems; string fragmentation.  
      ELSEIF(iev.LE.130) THEN   
        ity=(iev-41)/10 
        IF(ity.EQ.1) CALL lu2ent(1,1,-1,40.)    
        IF(ity.EQ.2) CALL lu2ent(1,4,-4,30.)    
        IF(ity.EQ.3) CALL lu2ent(1,2,2103,100.) 
        IF(ity.EQ.4) CALL lu2ent(1,21,21,40.)   
        IF(ity.EQ.5) CALL lu3ent(1,2101,21,-3203,30.,0.6,0.8)   
        IF(ity.EQ.6) CALL lu3ent(1,5,21,-5,40.,0.9,0.8) 
        IF(ity.EQ.7) CALL lu3ent(1,21,21,21,60.,0.7,0.5)    
        IF(ity.EQ.8) CALL lu4ent(1,2,21,21,-2,40.,0.4,0.64,0.6,0.12,0.2)    
    
C...Seventy events with independent fragmentation and momentum cons.    
      ELSEIF(iev.LE.200) THEN   
        ity=1+(iev-131)/16  
        mstj(2)=1+mod(iev-131,4)    
        mstj(3)=1+mod((iev-131)/4,4)    
        IF(ity.EQ.1) CALL lu2ent(1,4,-5,40.)    
        IF(ity.EQ.2) CALL lu3ent(1,3,21,-3,40.,0.9,0.4) 
        IF(ity.EQ.3) CALL lu4ent(1,2,21,21,-2,40.,0.4,0.64,0.6,0.12,0.2)    
        IF(ity.GE.4) CALL lu4ent(1,2,-3,3,-2,40.,0.4,0.64,0.6,0.12,0.2) 
    
C...A hundred events with random jets (check invariant mass).   
      ELSEIF(iev.LE.300) THEN   
  100   DO 110 j=1,5    
  110   psum(j)=0.  
        njet=2.+6.*rlu(0)   
        DO 120 i=1,njet 
        kfl=21  
        IF(i.EQ.1) kfl=int(1.+4.*rlu(0))    
        IF(i.EQ.njet) kfl=-int(1.+4.*rlu(0))    
        ejet=5.+20.*rlu(0)  
        theta=acos(2.*rlu(0)-1.)    
        phi=6.2832*rlu(0)   
        IF(i.LT.njet) CALL lu1ent(-i,kfl,ejet,theta,phi)    
        IF(i.EQ.njet) CALL lu1ent(i,kfl,ejet,theta,phi) 
        IF(i.EQ.1.OR.i.EQ.njet) psum(5)=psum(5)+ulmass(kfl) 
        DO 120 j=1,4    
  120   psum(j)=psum(j)+p(i,j)  
        IF(psum(4)**2-psum(1)**2-psum(2)**2-psum(3)**2.LT.  
     &  (psum(5)+parj(32))**2) goto 100 
    
C...Fifty e+e- continuum events with matrix elements.   
      ELSEIF(iev.LE.350) THEN   
        mstj(101)=2 
        CALL lueevt(0,40.)  
    
C...Fifty e+e- continuum event with varying shower options. 
      ELSEIF(iev.LE.400) THEN   
        mstj(42)=1+mod(iev,2)   
        mstj(43)=1+mod(iev/2,4) 
        mstj(44)=mod(iev/8,3)   
        CALL lueevt(0,90.)  
    
C...Fifty e+e- continuum events with coherent shower, including top.    
      ELSEIF(iev.LE.450) THEN   
        mstj(104)=6 
        CALL lueevt(0,500.) 
    
C...Fifty Upsilon decays to ggg or gammagg with coherent shower.    
      ELSEIF(iev.LE.500) THEN   
        CALL luonia(5,9.46) 
    
C...One decay each for some heavy mesons.   
      ELSEIF(iev.LE.560) THEN   
        ity=iev-501 
        kfls=2*(ity/20)+1   
        kflb=8-mod(ity/5,4) 
        kflc=kflb-mod(ity,5)    
        CALL lu1ent(1,100*kflb+10*kflc+kfls,0.,0.,0.)   
    
C...One decay each for some heavy baryons.  
      ELSEIF(iev.LE.600) THEN   
        ity=iev-561 
        kfls=2*(ity/20)+2   
        kfla=8-mod(ity/5,4) 
        kflb=kfla-mod(ity,5)    
        kflc=max(1,kflb-1)  
        CALL lu1ent(1,1000*kfla+100*kflb+10*kflc+kfls,0.,0.,0.) 
      ENDIF 
    
C...Generate event. Find total momentum, energy and charge. 
      DO 130 j=1,4  
  130 pini(j)=plu(0,j)  
      pini(6)=plu(0,6)  
      CALL luexec   
      DO 140 j=1,4  
  140 pfin(j)=plu(0,j)  
      pfin(6)=plu(0,6)  
    
C...Check conservation of energy, momentum and charge;  
C...usually exact, but only approximate for single jets.    
      merr=0    
      IF(iev.LE.50) THEN    
        IF((pfin(1)-pini(1))**2+(pfin(2)-pini(2))**2.GE.4.) merr=merr+1 
        epzrem=pini(4)+pini(3)-pfin(4)-pfin(3)  
        IF(epzrem.LT.0..OR.epzrem.GT.2.*parj(31)) merr=merr+1   
        IF(abs(pfin(6)-pini(6)).GT.2.1) merr=merr+1 
      ELSE  
        DO 150 j=1,4    
  150   IF(abs(pfin(j)-pini(j)).GT.0001*pini(4)) merr=merr+1    
        IF(abs(pfin(6)-pini(6)).GT.0.1) merr=merr+1 
      ENDIF 
      IF(merr.NE.0) WRITE(mstu(11),1000) (pini(j),j=1,4),pini(6),   
     &(pfin(j),j=1,4),pfin(6)   
    
C...Check that all KF codes are known ones, and that partons/particles  
C...satisfy energy-momentum-mass relation. Store particle statistics.   
      DO 160 i=1,n  
      IF(k(i,1).GT.20) goto 160 
      IF(lucomp(k(i,2)).EQ.0) THEN  
        WRITE(mstu(11),1100) i  
        merr=merr+1 
      ENDIF 
      pd=p(i,4)**2-p(i,1)**2-p(i,2)**2-p(i,3)**2-p(i,5)**2  
      IF(abs(pd).GT.max(0.1,0.001*p(i,4)**2).OR.p(i,4).LT.0.) THEN  
        WRITE(mstu(11),1200) i  
        merr=merr+1 
      ENDIF 
  160 CONTINUE  
      IF(mtest.GE.1) CALL lutabu(21)    
    
C...List all erroneous events and some normal ones. 
      IF(merr.NE.0.OR.mstu(24).NE.0.OR.mstu(28).NE.0) THEN  
        CALL lulist(2)  
      ELSEIF(mtest.GE.1.AND.mod(iev-5,100).EQ.0) THEN   
        CALL lulist(1)  
      ENDIF 
    
C...Stop execution if too many errors. Endresult of run.    
      IF(merr.NE.0) nerr=nerr+1 
      IF(nerr.GE.10) THEN   
        WRITE(mstu(11),1300) iev    
        stop    
      ENDIF 
  170 CONTINUE  
      IF(mtest.GE.1) CALL lutabu(22)    
      WRITE(mstu(11),1400) nerr 
    
C...Reset commonblock variables changed during run. 
      mstj(2)=3 
      parj(17)=0.   
      parj(22)=1.   
      parj(43)=0.5  
      parj(54)=0.   
      mstj(105)=1   
      mstj(107)=0   
    
C...Format statements for output.   
 1000 FORMAT(/' Momentum, energy and/or charge were not conserved ',    
     &'in following event'/' sum of',9x,'px',11x,'py',11x,'pz',11x, 
     &'E',8x,'charge'/' before',2x,4(1x,f12.5),1x,f8.2/' after',3x, 
     &4(1x,f12.5),1x,f8.2)  
 1100 FORMAT(/5x,'Entry no.',i4,' in following event not known code')   
 1200 FORMAT(/5x,'Entry no.',i4,' in following event has faulty ',  
     &'kinematics') 
 1300 FORMAT(/5x,'Ten errors experienced by event ',i3/ 
     &5x,'Something is seriously wrong! Execution stopped now!')    
 1400 FORMAT(/5x,'Number of erroneous or suspect events in run:',i3/    
     &5x,'(0 fine, 1 acceptable if a single jet, ', 
     &'>=2 something is wrong)')    
    
      RETURN    
      END   
    
C*********************************************************************  
    
      BLOCK DATA ludata 
    
C...Purpose: to give default values to parameters and particle and  
C...decay data. 
      common/ludat1/mstu(200),paru(200),mstj(200),parj(200) 
      SAVE /ludat1/ 
      common/ludat2/kchg(500,3),pmas(500,4),parf(2000),vckm(4,4)    
      SAVE /ludat2/ 
      common/ludat3/mdcy(500,3),mdme(2000,2),brat(2000),kfdp(2000,5)    
      SAVE /ludat3/ 
      common/ludat4/chaf(500)   
      CHARACTER chaf*8  
      SAVE /ludat4/ 
      common/ludatr/mrlu(6),rrlu(100)   
      SAVE /ludatr/ 
    
C...LUDAT1, containing status codes and most parameters.    
      DATA mstu/    
     &    0,    0,    0, 9000,10000,  500, 2000,    0,    0,    2,  
     1    6,    1,    1,    0,    1,    1,    0,    0,    0,    0,  
     2    2,   10,    0,    0,    1,   10,    0,    0,    0,    0,  
     3    0,    0,    0,    0,    0,    0,    0,    0,    0,    0,  
     4    2,    2,    1,    4,    2,    1,    1,    0,    0,    0,  
     5   25,   24,    0,    1,    0,    0,    0,    0,    0,    0,  
     6    0,    0,    0,    0,    0,    0,    0,    0,    0,    0,  
     7  40*0,   
     1    1,    5,    3,    5,    0,    0,    0,    0,    0,    0,  
     2  60*0,   
     8    7,    2, 1989,   11,   25,    0,    0,    0,    0,    0,  
     9    0,    0,    0,    0,    0,    0,    0,    0,    0,    0/  
      DATA paru/    
     & 3.1415927, 6.2831854, 0.1973, 5.068, 0.3894, 2.568,   4*0.,  
     1 0.001, 0.09, 0.01,  0.,   0.,   0.,   0.,   0.,   0.,   0.,  
     2   0.,   0.,   0.,   0.,   0.,   0.,   0.,   0.,   0.,   0.,  
     3   0.,   0.,   0.,   0.,   0.,   0.,   0.,   0.,   0.,   0.,  
     4  2.0,  1.0, 0.25,  2.5, 0.05,   0.,   0., 0.0001, 0.,   0.,  
     5  2.5,  1.5,  7.0,  1.0,  0.5,  2.0,  3.2,   0.,   0.,   0.,  
     6  40*0.,  
     & 0.0072974, 0.230, 0., 0., 0.,   0.,   0.,   0.,   0.,   0.,  
     1 0.20, 0.25,  1.0,  4.0,   0.,   0.,   0.,   0.,   0.,   0.,  
     2  1.0,   0.,   0.,   0.,   0.,   0.,   0.,   0.,   0.,   0.,  
     3  70*0./  
      DATA mstj/    
     &    1,    3,    0,    0,    0,    0,    0,    0,    0,    0,  
     1    1,    2,    0,    1,    0,    0,    0,    0,    0,    0,  
     2    2,    1,    1,    2,    1,    0,    0,    0,    0,    0,  
     3    0,    0,    0,    0,    0,    0,    0,    0,    0,    0,  
     4    1,    2,    4,    2,    5,    0,    1,    0,    0,    0,  
     5    0,    3,    0,    0,    0,    0,    0,    0,    0,    0,  
     6  40*0,   
     &    5,    2,    7,    5,    1,    1,    0,    2,    0,    1,  
     1    0,    0,    0,    0,    1,    1,    0,    0,    0,    0,  
     2  80*0/   
      DATA parj/    
     & 0.10, 0.30, 0.40, 0.05, 0.50, 0.50, 0.50,   0.,   0.,   0.,  
     1 0.50, 0.60, 0.75,   0.,   0.,   0.,   0.,  1.0,  1.0,   0.,  
     2 0.35,  1.0,   0.,   0.,   0.,   0.,   0.,   0.,   0.,   0.,  
     3 0.10,  1.0,  0.8,  1.5,  0.8,  2.0,  0.2,  2.5,  0.6,  2.5,  
     4  0.5,  0.9,  0.5,  0.9,  0.5,   0.,   0.,   0.,   0.,   0.,  
     5 0.77, 0.77, 0.77,   0.,   0.,   0.,   0.,   0.,  1.0,   0.,  
     6  4.5,  0.7,  0., 0.003,  0.5,  0.5,   0.,   0.,   0.,   0.,  
     7  10., 1000., 100., 1000., 0.,   0.,   0.,   0.,   0.,   0.,  
     8  0.4,  1.0,  1.0,   0.,  10.,  10.,   0.,   0.,   0.,   0.,  
     9 0.02,  1.0,  0.2,   0.,   0.,   0.,   0.,   0.,   0.,   0.,  
     &   0.,   0.,   0.,   0.,   0.,   0.,   0.,   0.,   0.,   0.,  
     1   0.,   0.,   0.,   0.,   0.,   0.,   0.,   0.,   0.,   0.,  
     2  1.5,  0.5, 91.2, 2.40, 0.02,  2.0,  1.0, 0.25,0.002,   0.,  
     3   0.,   0.,   0.,   0., 0.01, 0.99,   0.,   0.,  0.2,   0.,  
     4  60*0./  
    
C...LUDAT2, with particle data and flavour treatment parameters.    
      DATA (kchg(i,1),i=   1, 500)/-1,2,-1,2,-1,2,-1,2,2*0,-3,0,-3,0,   
     &-3,0,-3,6*0,3,9*0,3,2*0,3,46*0,2,-1,2,-1,2,3,11*0,3,0,2*3,    
     &0,3,0,3,12*0,3,0,2*3,0,3,0,3,12*0,3,0,2*3,0,3,0,3,12*0,3,0,2*3,0, 
     &3,0,3,12*0,3,0,2*3,0,3,0,3,12*0,3,0,2*3,0,3,0,3,72*0,3,0,3,28*0,  
     &3,2*0,3,8*0,-3,8*0,3,0,-3,0,3,-3,3*0,3,6,0,3,5*0,-3,0,3,-3,0,-3,  
     &4*0,-3,0,3,6,-3,0,3,-3,0,-3,0,3,6,0,3,5*0,-3,0,3,-3,0,-3,114*0/   
      DATA (kchg(i,2),i=   1, 500)/8*1,12*0,2,68*0,-1,410*0/    
      DATA (kchg(i,3),i=   1, 500)/8*1,2*0,8*1,5*0,1,9*0,1,2*0,1,2*0,1, 
     &41*0,1,0,7*1,10*0,9*1,11*0,9*1,11*0,9*1,11*0,9*1,11*0,9*1,    
     &11*0,9*1,71*0,3*1,22*0,1,5*0,1,0,2*1,6*0,1,0,2*1,6*0,2*1,0,5*1,   
     &0,6*1,4*0,6*1,4*0,16*1,4*0,6*1,114*0/ 
      DATA (pmas(i,1),i=   1, 500)/.0099,.0056,.199,1.35,5.,90.,120.,   
     &200.,2*0.,.00051,0.,.1057,0.,1.7841,0.,60.,5*0.,91.2,80.,15., 
     &6*0.,300.,900.,600.,300.,900.,300.,2*0.,5000.,60*0.,.1396,.4977,  
     &.4936,1.8693,1.8645,1.9693,5.2794,5.2776,5.47972,0.,.135,.5488,   
     &.9575,2.9796,9.4,117.99,238.,397.,2*0.,.7669,.8962,.8921, 
     &2.0101,2.0071,2.1127,2*5.3354,5.5068,0.,.77,.782,1.0194,3.0969,   
     &9.4603,118.,238.,397.,2*0.,1.233,2*1.3,2*2.322,2.51,2*5.73,5.97,  
     &0.,1.233,1.17,1.41,3.46,9.875,118.42,238.42,397.42,2*0.,  
     &.983,2*1.429,2*2.272,2.46,2*5.68,5.92,0.,.983,1.,1.4,3.4151,  
     &9.8598,118.4,238.4,397.4,2*0.,1.26,2*1.401,2*2.372,   
     &2.56,2*5.78,6.02,0.,1.26,1.283,1.422,3.5106,9.8919,118.5,238.5,   
     &397.5,2*0.,1.318,2*1.426,2*2.422,2.61,2*5.83,6.07,0.,1.318,1.274, 
     &1.525,3.5563,9.9132,118.45,238.45,397.45,2*0.,2*.4977,    
     &83*0.,1.1156,5*0.,2.2849,0.,2*2.46,6*0.,5.62,0.,2*5.84,6*0.,  
     &.9396,.9383,0.,1.1974,1.1926,1.1894,1.3213,1.3149,0.,2.454,   
     &2.4529,2.4522,2*2.55,2.73,4*0.,3*5.8,2*5.96,6.12,4*0.,1.234,  
     &1.233,1.232,1.231,1.3872,1.3837,1.3828,1.535,1.5318,1.6724,3*2.5, 
     &2*2.63,2.8,4*0.,3*5.81,2*5.97,6.13,114*0./    
      DATA (pmas(i,2),i=   1, 500)/22*0.,2.4,2.3,88*0.,.0002,.001,  
     &6*0.,.149,.0505,.0513,7*0.,.153,.0085,.0044,7*0.,.15,2*.09,2*.06, 
     &.04,3*.1,0.,.15,.335,.08,2*.01,5*0.,.057,2*.287,2*.06,.04,3*.1,   
     &0.,.057,0.,.25,.0135,6*0.,.4,2*.184,2*.06,.04,3*.1,0.,.4,.025,    
     &.055,.0135,6*0.,.11,.115,.099,2*.06,4*.1,0.,.11,.185,.076,.0026,  
     &146*0.,4*.115,.039,2*.036,.0099,.0091,131*0./ 
      DATA (pmas(i,3),i=   1, 500)/22*0.,2*20.,88*0.,.002,.005,6*0.,.4, 
     &2*.2,7*0.,.4,.1,.015,7*0.,.25,2*.01,3*.08,2*.2,.12,0.,.25,.2, 
     &.001,2*.02,5*0.,.05,2*.4,3*.08,2*.2,.12,0.,.05,0.,.35,.05,6*0.,   
     &3*.3,2*.08,.06,2*.2,.12,0.,.3,.05,.025,.001,6*0.,.25,4*.12,4*.2,  
     &0.,.25,.17,.2,.01,146*0.,4*.14,.04,2*.035,2*.05,131*0./   
      DATA (pmas(i,4),i=   1, 500)/12*0.,658650.,0.,.091,68*0.,.1,.43,  
     &15*0.,7803.,0.,3709.,.32,.128,.131,3*.393,84*0.,.004,26*0.,   
     &15540.,26.75,83*0.,78.88,5*0.,.054,0.,2*.13,6*0.,.393,0.,2*.393,  
     &9*0.,44.3,0.,24.,49.1,86.9,6*0.,.13,9*0.,.393,13*0.,24.6,130*0./  
      DATA parf/    
     &  0.5, 0.25,  0.5, 0.25,   1.,  0.5,   0.,   0.,   0.,   0.,  
     1  0.5,   0.,  0.5,   0.,   1.,   1.,   0.,   0.,   0.,   0.,  
     2  0.5,   0.,  0.5,   0.,   1.,   1.,   0.,   0.,   0.,   0.,  
     3  0.5,   0.,  0.5,   0.,   1.,   1.,   0.,   0.,   0.,   0.,  
     4  0.5,   0.,  0.5,   0.,   1.,   1.,   0.,   0.,   0.,   0.,  
     5  0.5,   0.,  0.5,   0.,   1.,   1.,   0.,   0.,   0.,   0.,  
     6 0.75,  0.5,   0., 0.1667, 0.0833, 0.1667, 0., 0., 0.,   0.,  
     7   0.,   0.,   1., 0.3333, 0.6667, 0.3333, 0., 0., 0.,   0.,  
     8   0.,   0.,   0.,   0.,   0.,   0.,   0.,   0.,   0.,   0.,  
     9   0.,   0.,   0.,   0.,   0.,   0.,   0.,   0.,   0.,   0.,  
     & 0.325, 0.325, 0.5, 1.6,  5.0,   0.,   0.,   0.,   0.,   0.,  
     1   0., 0.11, 0.16, 0.048, 0.50, 0.45, 0.55, 0.60,  0.,   0.,  
     2  0.2,  0.1,   0.,   0.,   0.,   0.,   0.,   0.,   0.,   0.,  
     3  1870*0./    
      DATA ((vckm(i,j),j=1,4),i=1,4)/   
     1  0.95150,  0.04847,  0.00003,  0.00000,  
     2  0.04847,  0.94936,  0.00217,  0.00000,  
     3  0.00003,  0.00217,  0.99780,  0.00000,  
     4  0.00000,  0.00000,  0.00000,  1.00000/  
    
C...LUDAT3, with particle decay parameters and data.    
      DATA (mdcy(i,1),i=   1, 500)/14*0,1,0,1,5*0,3*1,6*0,1,4*0,1,2*0,  
     &1,42*0,7*1,12*0,1,0,6*1,0,8*1,2*0,9*1,0,8*1,2*0,9*1,0,8*1,2*0,    
     &9*1,0,8*1,2*0,9*1,0,8*1,2*0,9*1,0,8*1,3*0,1,83*0,1,5*0,1,0,2*1,   
     &6*0,1,0,2*1,9*0,5*1,0,6*1,4*0,6*1,4*0,16*1,4*0,6*1,114*0/ 
      DATA (mdcy(i,2),i=   1, 500)/1,9,17,25,33,41,49,57,2*0,65,69,71,  
     &76,78,118,120,125,2*0,127,136,149,166,186,6*0,203,4*0,219,2*0,    
     &227,42*0,236,237,241,250,252,254,256,11*0,276,277,279,285,406,    
     &574,606,607,608,0,609,611,617,623,624,625,626,627,2*0,628,629,    
     &632,635,638,640,641,642,643,0,644,645,650,658,661,670,685,686,    
     &2*0,687,688,693,698,700,702,703,705,707,0,709,710,713,717,718,    
     &719,721,722,2*0,723,726,728,730,734,738,740,744,748,0,752,755,    
     &759,763,765,767,769,770,2*0,771,773,775,777,779,781,784,786,788,  
     &0,791,793,806,810,812,814,816,817,2*0,818,824,835,846,854,862,    
     &867,875,883,0,888,895,903,905,907,909,911,912,2*0,913,921,83*0,   
     &923,5*0,927,0,1001,1002,6*0,1003,0,1004,1005,9*0,1006,1008,1009,  
     &1012,1013,0,1015,1016,1017,1018,1019,1020,4*0,1021,1022,1023, 
     &1024,1025,1026,4*0,1027,1028,1031,1034,1035,1038,1041,1044,1046,  
     &1048,1052,1053,1054,1055,1057,1059,4*0,1060,1061,1062,1063,1064,  
     &1065,114*0/   
      DATA (mdcy(i,3),i=   1, 500)/8*8,2*0,4,2,5,2,40,2,5,2,2*0,9,13,   
     &17,20,17,6*0,16,4*0,8,2*0,9,42*0,1,4,9,3*2,20,11*0,1,2,6,121,168, 
     &32,3*1,0,2,2*6,5*1,2*0,1,3*3,2,4*1,0,1,5,8,3,9,15,2*1,2*0,1,2*5,  
     &2*2,1,3*2,0,1,3,4,2*1,2,2*1,2*0,3,2*2,2*4,2,3*4,0,3,2*4,3*2,2*1,  
     &2*0,5*2,3,2*2,3,0,2,13,4,3*2,2*1,2*0,6,2*11,2*8,5,2*8,5,0,7,8,    
     &4*2,2*1,2*0,8,2,83*0,4,5*0,74,0,2*1,6*0,1,0,2*1,9*0,2,1,3,1,2,0,  
     &6*1,4*0,6*1,4*0,1,2*3,1,3*3,2*2,4,3*1,2*2,1,4*0,6*1,114*0/    
      DATA (mdme(i,1),i=   1,2000)/6*1,-1,7*1,-1,7*1,-1,7*1,-1,7*1,-1,  
     &7*1,-1,85*1,2*-1,7*1,2*-1,3*1,2*-1,6*1,2*-1,6*1,3*-1,3*1,-1,3*1,  
     &-1,3*1,5*-1,3*1,-1,6*1,2*-1,3*1,-1,11*1,2*-1,6*1,2*-1,3*1,-1,3*1, 
     &-1,4*1,2*-1,2*1,-1,488*1,2*0,1275*1/  
      DATA (mdme(i,2),i=   1,2000)/70*102,42,6*102,2*42,2*0,7*41,2*0,   
     &23*41,6*102,45,28*102,8*32,9*0,16*32,4*0,8*32,4*0,32,4*0,8*32,    
     &8*0,4*32,4*0,6*32,3*0,12,2*42,2*11,9*42,6*45,20*46,7*0,34*42, 
     &86*0,2*25,26,24*42,142*0,25,26,0,10*42,19*0,2*13,3*85,0,2,4*0,2,  
     &8*0,2*32,87,88,3*3,0,2*3,0,2*3,0,3,5*0,3,1,0,3,2*0,2*3,3*0,1,4*0, 
     &12,3*0,4*32,2*4,6*0,5*32,2*4,2*45,87,88,30*0,12,32,0,32,87,88,    
     &41*0,12,0,32,0,32,87,88,40*0,12,0,32,0,32,87,88,88*0,12,0,32,0,   
     &32,87,88,2*0,4*42,8*0,14*42,50*0,10*13,2*84,3*85,14*0,84,5*0,85,  
     &974*0/    
      DATA (brat(i)  ,i=   1, 525)/70*0.,1.,6*0.,2*.177,.108,.225,.003, 
     &.06,.02,.025,.013,2*.004,.007,.014,2*.002,2*.001,.054,.014,.016,  
     &.005,2*.012,5*.006,.002,2*.001,5*.002,6*0.,1.,28*0.,.143,.111,    
     &.143,.111,.143,.085,2*0.,.03,.058,.03,.058,.03,.058,3*0.,.25,.01, 
     &2*0.,.01,.25,4*0.,.24,5*0.,3*.08,3*0.,.01,.08,.82,5*0.,.09,6*0.,  
     &.143,.111,.143,.111,.143,.085,2*0.,.03,.058,.03,.058,.03,.058,    
     &4*0.,1.,5*0.,4*.215,2*0.,2*.07,0.,1.,2*.08,.76,.08,2*.112,.05,    
     &.476,.08,.14,.01,.015,.005,1.,0.,1.,0.,1.,0.,.25,.01,2*0.,.01,    
     &.25,4*0.,.24,5*0.,3*.08,0.,1.,2*.5,.635,.212,.056,.017,.048,.032, 
     &.035,.03,2*.015,.044,2*.022,9*.001,.035,.03,2*.015,.044,2*.022,   
     &9*.001,.028,.017,.066,.02,.008,2*.006,.003,.001,2*.002,.003,.001, 
     &2*.002,.005,.002,.005,.006,.004,.012,2*.005,.008,2*.005,.037, 
     &.004,.067,2*.01,2*.001,3*.002,.003,8*.002,.005,4*.004,.015,.005,  
     &.027,2*.005,.007,.014,.007,.01,.008,.012,.015,11*.002,3*.004, 
     &.002,.004,6*.002,2*.004,.005,.011,.005,.015,.02,2*.01,3*.004, 
     &5*.002,.015,.02,2*.01,3*.004,5*.002,.038,.048,.082,.06,.028,.021, 
     &2*.005,2*.002,.005,.018,.005,.01,.008,.005,3*.004,.001,3*.003,    
     &.001,2*.002,.003,2*.002,2*.001,.002,.001,.002,.001,.005,4*.003,   
     &.001,2*.002,.003,2*.001,.013,.03,.058,.055,3*.003,2*.01,.007, 
     &.019,4*.005,.015,3*.005,8*.002,3*.001,.002,2*.001,.003,16*.001/   
      DATA (brat(i)  ,i= 526, 893)/.019,2*.003,.002,.005,.004,.008, 
     &.003,.006,.003,.01,5*.002,2*.001,2*.002,11*.001,.002,14*.001, 
     &.018,.005,.01,2*.015,.017,4*.015,.017,3*.015,.025,.08,2*.025,.04, 
     &.001,2*.005,.02,.04,2*.06,.04,.01,4*.005,.25,.115,3*1.,.988,.012, 
     &.389,.319,.237,.049,.005,.001,.441,.205,.301,.03,.022,.001,6*1.,  
     &.665,.333,.002,.666,.333,.001,.49,.34,.17,.52,.48,5*1.,.893,.08,  
     &.017,2*.005,.495,.343,3*.043,.019,.013,.001,2*.069,.862,3*.027,   
     &.015,.045,.015,.045,.77,.029,6*.02,5*.05,.115,.015,.5,0.,3*1.,    
     &.28,.14,.313,.157,.11,.28,.14,.313,.157,.11,.667,.333,.667,.333,  
     &1.,.667,.333,.667,.333,2*.5,1.,.333,.334,.333,4*.25,2*1.,.3,.7,   
     &2*1.,.8,2*.1,.667,.333,.667,.333,.6,.3,.067,.033,.6,.3,.067,.033, 
     &2*.5,.6,.3,.067,.033,.6,.3,.067,.033,2*.4,2*.1,.8,2*.1,.52,.26,   
     &2*.11,.62,.31,2*.035,.007,.993,.02,.98,.3,.7,2*1.,2*.5,.667,.333, 
     &.667,.333,.667,.333,.667,.333,2*.35,.3,.667,.333,.667,.333,2*.35, 
     &.3,2*.5,3*.14,.1,.05,4*.08,.028,.027,.028,.027,4*.25,.273,.727,   
     &.35,.65,.3,.7,2*1.,2*.35,.144,.105,.048,.003,.332,.166,.168,.084, 
     &.086,.043,.059,2*.029,2*.002,.332,.166,.168,.084,.086,.043,.059,  
     &2*.029,2*.002,.3,.15,.16,.08,.13,.06,.08,.04,.3,.15,.16,.08,.13,  
     &.06,.08,.04,2*.4,.1,2*.05,.3,.15,.16,.08,.13,.06,.08,.04,.3,.15,  
     &.16,.08,.13,.06,.08,.04,2*.4,.1,2*.05,2*.35,.144,.105,2*.024/ 
      DATA (brat(i)  ,i= 894,2000)/.003,.573,.287,.063,.028,2*.021, 
     &.004,.003,2*.5,.15,.85,.22,.78,.3,.7,2*1.,.217,.124,2*.193,   
     &2*.135,.002,.001,.686,.314,.641,.357,2*.001,.018,2*.005,.003, 
     &.002,2*.006,.018,2*.005,.003,.002,2*.006,.005,.025,.015,.006, 
     &2*.005,.004,.005,5*.004,2*.002,2*.004,.003,.002,2*.003,3*.002,    
     &2*.001,.002,2*.001,2*.002,5*.001,4*.003,2*.005,2*.002,2*.001, 
     &2*.002,2*.001,.255,.057,2*.035,.15,2*.075,.03,2*.015,5*1.,.999,   
     &.001,1.,.516,.483,.001,1.,.995,.005,13*1.,.331,.663,.006,.663,    
     &.331,.006,1.,.88,2*.06,.88,2*.06,.88,2*.06,.667,2*.333,.667,.676, 
     &.234,.085,.005,3*1.,4*.5,7*1.,935*0./ 
      DATA (kfdp(i,1),i=   1, 499)/21,22,23,4*-24,25,21,22,23,4*24,25,  
     &21,22,23,4*-24,25,21,22,23,4*24,25,21,22,23,4*-24,25,21,22,23,    
     &4*24,25,21,22,23,4*-24,25,21,22,23,4*24,25,22,23,-24,25,23,24,    
     &-12,22,23,-24,25,23,24,-12,-14,34*16,22,23,-24,25,23,24,-89,22,   
     &23,-24,25,23,24,1,2,3,4,5,6,7,8,21,1,2,3,4,5,6,7,8,11,13,15,17,   
     &37,1,2,3,4,5,6,7,8,11,12,13,14,15,16,17,18,37,4*-1,4*-3,4*-5, 
     &4*-7,-11,-13,-15,-17,1,2,3,4,5,6,7,8,11,13,15,17,21,2*22,23,24,1, 
     &2,3,4,5,6,7,8,11,12,13,14,15,16,17,18,-1,-3,-5,-7,-11,-13,-15,    
     &-17,1,2,3,4,5,6,11,13,15,82,-11,-13,2*2,-12,-14,-16,2*-2,2*-4,-2, 
     &-4,2*89,2*-89,2*89,4*-1,4*-3,4*-5,4*-7,-11,-13,-15,-17,-13,130,   
     &310,-13,3*211,12,14,16*-11,16*-13,-311,-313,-311,-313,-311,-313,  
     &-311,-313,2*111,2*221,2*331,2*113,2*223,2*333,-311,-313,2*-311,   
     &-313,3*-311,-321,-323,-321,2*211,2*213,-213,113,3*213,3*211,  
     &2*213,2*-311,-313,-321,2*-311,-313,-311,-313,4*-311,-321,-323,    
     &2*-321,3*211,213,2*211,213,5*211,213,4*211,3*213,211,213,321,311, 
     &3,2*2,12*-11,12*-13,-321,-323,-321,-323,-311,-313,-311,-313,-311, 
     &-313,-311,-313,-311,-313,-311,-321,-323,-321,-323,211,213,211,    
     &213,111,221,331,113,223,333,221,331,113,223,113,223,113,223,333,  
     &223,333,321,323,321,323,311,313,-321,-323,3*-321,-323,2*-321, 
     &-323,-321,-311,-313,3*-311,-313,2*-311,-313,-321,-323,3*-321/ 
      DATA (kfdp(i,1),i= 500, 873)/-323,2*-321,-311,2*333,211,213,  
     &2*211,2*213,4*211,10*111,-321,-323,5*-321,-323,2*-321,-311,-313,  
     &4*-311,-313,4*-311,-321,-323,2*-321,-323,-321,-313,-311,-313, 
     &-311,211,213,2*211,213,4*211,111,221,113,223,113,223,2*3,-15, 
     &5*-11,5*-13,221,331,333,221,331,333,211,213,211,213,321,323,321,  
     &323,2212,221,331,333,221,2*2,3*0,3*22,111,211,2*22,2*211,111, 
     &3*22,111,3*21,2*0,211,321,3*311,2*321,421,2*411,2*421,431,511,    
     &521,531,2*211,22,211,2*111,321,130,-213,113,213,211,22,111,11,13, 
     &82,11,13,15,1,2,3,4,21,22,11,12,13,14,15,16,1,2,3,4,5,21,22,2*89, 
     &2*0,223,321,311,323,313,2*311,321,313,323,321,421,2*411,421,433,  
     &521,2*511,521,523,513,223,213,113,-213,313,-313,323,-323,82,21,   
     &663,21,2*0,221,213,113,321,2*311,321,421,411,423,413,411,421,413, 
     &423,431,433,521,511,523,513,511,521,513,523,521,511,531,533,221,  
     &213,-213,211,111,321,130,211,111,321,130,443,82,553,21,663,21,    
     &2*0,113,213,323,2*313,323,423,2*413,423,421,411,433,523,2*513,    
     &523,521,511,533,213,-213,10211,10111,-10211,2*221,213,2*113,-213, 
     &2*321,2*311,313,-313,323,-323,443,82,553,21,663,21,2*0,213,113,   
     &221,223,321,211,321,311,323,313,323,313,321,5*311,321,313,323,    
     &313,323,311,4*321,421,411,423,413,423,413,421,2*411,421,413,423,  
     &413,423,411,2*421,411,433,2*431,521,511,523,513,523,513,521/  
      DATA (kfdp(i,1),i= 874,2000)/2*511,521,513,523,513,523,511,2*521, 
     &511,533,2*531,213,-213,221,223,321,130,111,211,111,2*211,321,130, 
     &221,111,321,130,443,82,553,21,663,21,2*0,111,211,-12,12,-14,14,   
     &211,111,211,111,2212,2*2112,-12,7*-11,7*-13,2*2224,2*2212,2*2214, 
     &2*3122,2*3212,2*3214,5*3222,4*3224,2*3322,3324,2*2224,5*2212, 
     &5*2214,2*2112,2*2114,2*3122,2*3212,2*3214,2*3222,2*3224,4*2,3,    
     &2*2,1,2*2,5*0,2112,-12,3122,2212,2112,2212,3*3122,3*4122,4132,    
     &4232,0,3*5122,5132,5232,0,2112,2212,2*2112,2212,2112,2*2212,3122, 
     &3212,3112,3122,3222,3112,3122,3222,3212,3322,3312,3322,3312,3122, 
     &3322,3312,-12,3*4122,2*4132,2*4232,4332,3*5122,5132,5232,5332,    
     &935*0/    
      DATA (kfdp(i,2),i=   1, 496)/3*1,2,4,6,8,1,3*2,1,3,5,7,2,3*3,2,4, 
     &6,8,3,3*4,1,3,5,7,4,3*5,2,4,6,8,5,3*6,1,3,5,7,6,3*7,2,4,6,8,7,    
     &3*8,1,3,5,7,8,2*11,12,11,12,2*11,2*13,14,13,14,13,11,13,-211, 
     &-213,-211,-213,-211,-213,3*-211,-321,-323,-321,-323,2*-321,   
     &4*-211,-213,-211,-213,-211,-213,-211,-213,-211,-213,6*-211,2*15,  
     &16,15,16,15,18,2*17,18,17,18,17,-1,-2,-3,-4,-5,-6,-7,-8,21,-1,-2, 
     &-3,-4,-5,-6,-7,-8,-11,-13,-15,-17,-37,-1,-2,-3,-4,-5,-6,-7,-8,    
     &-11,-12,-13,-14,-15,-16,-17,-18,-37,2,4,6,8,2,4,6,8,2,4,6,8,2,4,  
     &6,8,12,14,16,18,-1,-2,-3,-4,-5,-6,-7,-8,-11,-13,-15,-17,21,22,    
     &2*23,-24,-1,-2,-3,-4,-5,-6,-7,-8,-11,-12,-13,-14,-15,-16,-17,-18, 
     &2,4,6,8,12,14,16,18,-3,-4,-5,-6,-7,-8,-13,-15,-17,-82,12,14,-1,   
     &-3,11,13,15,1,4,3,4,1,3,5,3,6,4,7,5,2,4,6,8,2,4,6,8,2,4,6,8,2,4,  
     &6,8,12,14,16,18,14,2*0,14,111,211,111,-11,-13,16*12,16*14,2*211,  
     &2*213,2*321,2*323,211,213,211,213,211,213,211,213,211,213,211,    
     &213,2*211,213,7*211,213,211,111,211,111,2*211,-213,213,2*113,223, 
     &2*113,221,321,2*311,321,313,4*211,213,113,213,-213,2*211,213,113, 
     &111,221,331,111,113,223,4*113,223,6*211,213,4*211,-321,-311,3*-1, 
     &12*12,12*14,2*211,2*213,2*111,2*221,2*331,2*113,2*223,333,2*321,  
     &2*323,2*-211,2*-213,6*111,4*221,2*331,3*113,2*223,2*-211,2*-213,  
     &113,111,2*211,213,6*211,321,2*211,213,211,2*111,113,2*223,2*321/  
      DATA (kfdp(i,2),i= 497, 863)/323,321,2*311,313,2*311,111,211, 
     &2*-211,-213,-211,-213,-211,-213,3*-211,5*111,2*113,223,113,223,   
     &2*211,213,5*211,213,3*211,213,2*211,2*111,221,113,223,3*321,323,  
     &2*321,323,311,313,311,313,3*211,2*-211,-213,3*-211,4*111,2*113,   
     &2*-1,16,5*12,5*14,3*211,3*213,2*111,2*113,2*-311,2*-313,-2112,    
     &3*321,323,2*-1,3*0,22,11,22,111,-211,211,11,2*-211,111,113,223,   
     &22,111,3*21,2*0,111,-211,111,22,211,111,22,211,111,22,111,5*22,   
     &2*-211,111,-211,2*111,-321,310,211,111,2*-211,221,22,-11,-13,-82, 
     &-11,-13,-15,-1,-2,-3,-4,2*21,-11,-12,-13,-14,-15,-16,-1,-2,-3,-4, 
     &-5,2*21,5,3,2*0,211,-213,113,-211,111,223,211,111,211,111,223,    
     &211,111,-211,2*111,-211,111,211,111,-321,-311,111,-211,111,211,   
     &-311,311,-321,321,-82,21,22,21,2*0,211,111,211,-211,111,211,111,  
     &211,111,211,111,-211,111,-211,3*111,-211,111,-211,111,211,111,    
     &211,111,-321,-311,3*111,-211,211,-211,111,-321,310,-211,111,-321, 
     &310,22,-82,22,21,22,21,2*0,211,111,-211,111,211,111,211,111,-211, 
     &111,321,311,111,-211,111,211,111,-321,-311,111,-211,211,-211,111, 
     &2*211,111,-211,211,111,211,-321,2*-311,-321,-311,311,-321,321,22, 
     &-82,22,21,22,21,2*0,111,3*211,-311,22,-211,111,-211,111,-211,211, 
     &-213,113,223,221,22,211,111,211,111,2*211,213,113,223,221,22,211, 
     &111,211,111,4*211,-211,111,-211,111,-211,211,-211,211,321,311/    
      DATA (kfdp(i,2),i= 864,2000)/2*111,211,-211,111,-211,111,-211,    
     &211,-211,2*211,111,211,111,4*211,-321,-311,2*111,211,-211,211,    
     &111,211,-321,310,22,-211,111,2*-211,-321,310,221,111,-321,310,22, 
     &-82,22,21,22,21,2*0,111,-211,11,-11,13,-13,-211,111,-211,111, 
     &-211,111,22,11,7*12,7*14,-321,-323,-311,-313,-311,-313,211,213,   
     &211,213,211,213,111,221,331,113,223,111,221,113,223,321,323,321,  
     &-211,-213,111,221,331,113,223,111,221,331,113,223,211,213,211,    
     &213,321,323,321,323,321,323,311,313,311,313,2*-1,-3,-1,2203,  
     &2*3201,2203,2101,2103,5*0,-211,11,22,111,211,22,-211,111,22,-211, 
     &111,211,2*22,0,-211,111,211,2*22,0,2*-211,111,22,111,211,22,211,  
     &2*-211,2*111,-211,2*211,111,211,-211,2*111,211,-321,-211,111,11,  
     &-211,111,211,111,22,111,2*22,-211,111,211,3*22,935*0/ 
      DATA (kfdp(i,3),i=   1, 918)/70*0,14,6*0,2*16,2*0,5*111,310,130,  
     &2*0,2*111,310,130,113,211,223,221,2*113,2*211,2*223,2*221,2*113,  
     &221,113,2*213,-213,123*0,4*3,4*4,1,4,3,2*2,6*81,25*0,-211,3*111,  
     &-311,-313,-311,2*-321,2*-311,111,221,331,113,223,211,111,211,111, 
     &-311,-313,-311,2*-321,2*-311,111,221,331,113,223,211,111,211,111, 
     &20*0,3*111,2*221,331,113,223,3*211,-211,111,-211,111,211,111,211, 
     &-211,111,113,111,223,2*111,-311,4*211,2*111,2*211,111,7*211,  
     &7*111,113,221,2*223,2*-211,-213,4*-211,-213,-211,-213,-211,2*211, 
     &2,2*0,-321,-323,-311,-321,-311,2*-321,-211,-213,2*-211,211,-321,  
     &-323,-311,-321,-311,2*-321,-211,-213,2*-211,211,46*0,3*111,113,   
     &2*221,331,2*223,-311,3*-211,-213,8*111,113,3*211,213,2*111,-211,  
     &3*111,113,111,2*113,221,331,223,111,221,331,113,223,113,2*223,    
     &2*221,3*111,221,113,223,4*211,3*-211,-213,-211,5*111,-321,3*211,  
     &3*111,2*211,2*111,2*-211,-213,3*111,221,113,223,6*111,3*0,221,    
     &331,333,321,311,221,331,333,321,311,19*0,3,5*0,-11,0,2*111,-211,  
     &-11,11,2*221,3*0,111,22*0,111,2*0,22,111,5*0,111,12*0,2*21,11*0,  
     &2*21,2*-6,111*0,-211,2*111,-211,3*111,-211,111,211,15*0,111,6*0,  
     &111,-211,9*0,111,-211,9*0,111,-211,111,-211,4*0,111,-211,111, 
     &-211,4*0,-211,4*0,111,-211,111,-211,4*0,111,-211,111,-211,4*0,    
     &-211,3*0,-211,5*0,111,211,3*0,111,10*0,2*111,211,-211,211,-211/   
      DATA (kfdp(i,3),i= 919,2000)/7*0,2212,3122,3212,3214,2112,2114,   
     &2212,2112,3122,3212,3214,2112,2114,2212,2112,50*0,3*3,1,12*0, 
     &2112,43*0,3322,949*0/ 
      DATA (kfdp(i,4),i=   1,2000)/83*0,3*111,9*0,-211,3*0,111,2*-211,  
     &0,111,0,2*111,113,221,111,-213,-211,211,123*0,13*81,37*0,111, 
     &3*211,111,5*0,-211,111,-211,111,2*0,111,3*211,111,5*0,-211,111,   
     &-211,111,50*0,2*111,2*-211,2*111,-211,211,3*111,211,14*111,221,   
     &113,223,2*111,2*113,223,2*111,-1,4*0,-211,111,-211,211,111,2*0,   
     &2*111,-211,2*0,-211,111,-211,211,111,2*0,2*111,-211,96*0,6*111,   
     &3*-211,-213,4*111,113,6*111,3*-211,3*111,2*-211,2*111,3*-211, 
     &12*111,6*0,-321,-311,3*0,-321,-311,19*0,-3,11*0,-11,280*0,111,    
     &-211,3*0,111,29*0,-211,111,5*0,-211,111,50*0,2101,2103,2*2101,    
     &1006*0/   
      DATA (kfdp(i,5),i=   1,2000)/85*0,111,15*0,111,7*0,111,0,2*111,   
     &175*0,111,-211,111,7*0,2*111,4*0,111,-211,111,7*0,2*111,93*0,111, 
     &-211,111,3*0,111,-211,4*0,111,-211,111,3*0,111,-211,1571*0/   
    
C...LUDAT4, with character strings. 
      DATA (chaf(i)  ,i=   1, 331)/'d','u','s','c','b','t','l','h', 
     &2*' ','e','nu_e','mu','nu_mu','tau','nu_tau','chi','nu_chi',  
     &2*' ','g','gamma','Z','W','H',6*' ','Z''','Z"','W''','H''','H"',  
     &'H',2*' ','R',40*' ','specflav','rndmflav','phasespa','c-hadron', 
     &'b-hadron','t-hadron','l-hadron','h-hadron','Wvirt','diquark',    
     &'cluster','string','indep.','CMshower','SPHEaxis','THRUaxis', 
     &'CLUSjet','CELLjet','table',' ','pi',2*'K',2*'D','D_s',2*'B', 
     &'B_s',' ','pi','eta','eta''','eta_c','eta_b','eta_t','eta_l', 
     &'eta_h',2*' ','rho',2*'K*',2*'D*','D*_s',2*'B*','B*_s',' ','rho', 
     &'omega','phi','J/psi','Upsilon','Theta','Theta_l','Theta_h',  
     &2*' ','b_1',2*'K_1',2*'D_1','D_1s',2*'B_1','B_1s',' ','b_1',  
     &'h_1','h''_1','h_1c','h_1b','h_1t','h_1l','h_1h',2*' ','a_0', 
     &2*'K*_0',2*'D*_0','D*_0s',2*'B*_0','B*_0s',' ','a_0','f_0',   
     &'f''_0','chi_0c','chi_0b','chi_0t','chi_0l','chi_0h',2*' ','a_1', 
     &2*'K*_1',2*'D*_1','D*_1s',2*'B*_1','B*_1s',' ','a_1','f_1',   
     &'f''_1','chi_1c','chi_1b','chi_1t','chi_1l','chi_1h',2*' ','a_2', 
     &2*'K*_2',2*'D*_2','D*_2s',2*'B*_2','B*_2s',' ','a_2','f_2',   
     &'f''_2','chi_2c','chi_2b','chi_2t','chi_2l','chi_2h',2*' ','K_L', 
     &'K_S',58*' ','pi_diffr','n_diffr','p_diffr',22*' ','Lambda',5*' ',    
     &'Lambda_c',' ',2*'Xi_c',6*' ','Lambda_b',' ',2*'Xi_b',6*' '/  
      DATA (chaf(i)  ,i= 332, 500)/'n','p',' ',3*'Sigma',2*'Xi',' ',    
     &3*'Sigma_c',2*'Xi''_c','Omega_c', 
     &4*' ',3*'Sigma_b',2*'Xi''_b','Omega_b',4*' ',4*'Delta',   
     &3*'Sigma*',2*'Xi*','Omega',3*'Sigma*_c',2*'Xi*_c','Omega*_c', 
     &4*' ',3*'Sigma*_b',2*'Xi*_b','Omega*_b',114*' '/  
    
C...LUDATR, with initial values for the random number generator.    
      DATA mrlu/19780503,0,0,97,33,0/   
    
      END   
      SUBROUTINE pyinit(FRAME,BEAM,TARGET,WIN)  
    
C...Initializes the generation procedure; finds maxima of the   
C...differential cross-sections to be used for weighting.   
      common/ludat1/mstu(200),paru(200),mstj(200),parj(200) 
      SAVE /ludat1/ 
      common/ludat2/kchg(500,3),pmas(500,4),parf(2000),vckm(4,4)    
      SAVE /ludat2/ 
      common/ludat3/mdcy(500,3),mdme(2000,2),brat(2000),kfdp(2000,5)    
      SAVE /ludat3/ 
      common/ludat4/chaf(500)   
      CHARACTER chaf*8  
      SAVE /ludat4/ 
      common/pysubs/msel,msub(200),kfin(2,-40:40),ckin(200) 
      SAVE /pysubs/ 
      common/pypars/mstp(200),parp(200),msti(200),pari(200) 
      SAVE /pypars/ 
      common/pyint1/mint(400),vint(400) 
      SAVE /pyint1/ 
      common/pyint2/iset(200),kfpr(200,2),coef(200,20),icol(40,4,2) 
      SAVE /pyint2/ 
      common/pyint5/ngen(0:200,3),xsec(0:200,3) 
      SAVE /pyint5/ 
      CHARACTER*(*) frame,beam,TARGET   
      CHARACTER chfram*8,chbeam*8,chtarg*8,chmo(12)*3,chlh(2)*6 
      DATA chmo/'Jan','Feb','Mar','Apr','May','Jun','Jul','Aug','Sep',  
     &'Oct','Nov','Dec'/, chlh/'lepton','hadron'/   
    
C...Write headers.  
C      IF(MSTP(122).GE.1) WRITE(MSTU(11),1000) MSTP(181),MSTP(182),  
C     &MSTP(185),CHMO(MSTP(184)),MSTP(183)   
      CALL lulist(0)
C      IF(MSTP(122).GE.1) WRITE(MSTU(11),1100)  
    
C...Identify beam and target particles and initialize kinematics.   
      chfram=frame//' ' 
      chbeam=beam//' '  
      chtarg=TARGET//' '    
      CALL pyinki(chfram,chbeam,chtarg,win) 
    
C...Select partonic subprocesses to be included in the simulation.  
      IF(msel.NE.0) THEN    
        DO 100 i=1,200  
  100   msub(i)=0   
      ENDIF 
      IF(mint(43).EQ.1.AND.(msel.EQ.1.OR.msel.EQ.2)) THEN   
C...Lepton+lepton -> gamma/Z0 or W. 
        IF(mint(11)+mint(12).EQ.0) msub(1)=1    
        IF(mint(11)+mint(12).NE.0) msub(2)=1    
      ELSEIF(msel.EQ.1) THEN    
C...High-pT QCD processes:  
        msub(11)=1  
        msub(12)=1  
        msub(13)=1  
        msub(28)=1  
        msub(53)=1  
        msub(68)=1  
        IF(mstp(82).LE.1.AND.ckin(3).LT.parp(81)) msub(95)=1    
        IF(mstp(82).GE.2.AND.ckin(3).LT.parp(82)) msub(95)=1    
      ELSEIF(msel.EQ.2) THEN    
C...All QCD processes:  
        msub(11)=1  
        msub(12)=1  
        msub(13)=1  
        msub(28)=1  
        msub(53)=1  
        msub(68)=1  
        msub(91)=1  
        msub(92)=1  
        msub(93)=1  
        msub(95)=1  
      ELSEIF(msel.GE.4.AND.msel.LE.8) THEN  
C...Heavy quark production. 
        msub(81)=1  
        msub(82)=1  
        DO 110 j=1,min(8,mdcy(21,3))    
  110   mdme(mdcy(21,2)+j-1,1)=0    
        mdme(mdcy(21,2)+msel-1,1)=1 
      ELSEIF(msel.EQ.10) THEN   
C...Prompt photon production:   
        msub(14)=1  
        msub(18)=1  
        msub(29)=1  
      ELSEIF(msel.EQ.11) THEN   
C...Z0/gamma* production:   
        msub(1)=1   
      ELSEIF(msel.EQ.12) THEN   
C...W+/- production:    
        msub(2)=1   
      ELSEIF(msel.EQ.13) THEN   
C...Z0 + jet:   
        msub(15)=1  
        msub(30)=1  
      ELSEIF(msel.EQ.14) THEN   
C...W+/- + jet: 
        msub(16)=1  
        msub(31)=1  
      ELSEIF(msel.EQ.15) THEN   
C...Z0 & W+/- pair production:  
        msub(19)=1  
        msub(20)=1  
        msub(22)=1  
        msub(23)=1  
        msub(25)=1  
      ELSEIF(msel.EQ.16) THEN   
C...H0 production:  
        msub(3)=1   
        msub(5)=1   
        msub(8)=1   
        msub(102)=1 
      ELSEIF(msel.EQ.17) THEN   
C...H0 & Z0 or W+/- pair production:    
        msub(24)=1  
        msub(26)=1  
      ELSEIF(msel.EQ.21) THEN   
C...Z'0 production: 
        msub(141)=1 
      ELSEIF(msel.EQ.22) THEN   
C...H+/- production:    
        msub(142)=1 
      ELSEIF(msel.EQ.23) THEN   
C...R production:   
        msub(143)=1 
      ENDIF 
    
C...Count number of subprocesses on.    
      mint(44)=0    
      DO 120 isub=1,200 
      IF(mint(43).LT.4.AND.isub.GE.91.AND.isub.LE.96.AND.   
     &msub(isub).EQ.1) THEN 
        WRITE(mstu(11),1200) isub,chlh(mint(41)),chlh(mint(42)) 
        stop    
      ELSEIF(msub(isub).EQ.1.AND.iset(isub).EQ.-1) THEN 
        WRITE(mstu(11),1300) isub   
        stop    
      ELSEIF(msub(isub).EQ.1.AND.iset(isub).LE.-2) THEN 
        WRITE(mstu(11),1400) isub   
        stop    
      ELSEIF(msub(isub).EQ.1) THEN  
        mint(44)=mint(44)+1 
      ENDIF 
  120 CONTINUE  
      IF(mint(44).EQ.0) THEN    
        WRITE(mstu(11),1500)    
        stop    
      ENDIF 
      mint(45)=mint(44)-msub(91)-msub(92)-msub(93)-msub(94) 
    
C...Maximum 4 generations; set maximum number of allowed flavours.  
      mstp(1)=min(4,mstp(1))    
      mstu(114)=min(mstu(114),2*mstp(1))    
      mstp(54)=min(mstp(54),2*mstp(1))  
    
C...Sum up Cabibbo-Kobayashi-Maskawa factors for each quark/lepton. 
      DO 140 i=-20,20   
      vint(180+i)=0.    
      ia=iabs(i)    
      IF(ia.GE.1.AND.ia.LE.2*mstp(1)) THEN  
        DO 130 j=1,mstp(1)  
        ib=2*j-1+mod(ia,2)  
        ipm=(5-isign(1,i))/2    
        idc=j+mdcy(ia,2)+2  
  130   IF(mdme(idc,1).EQ.1.OR.mdme(idc,1).EQ.ipm) vint(180+i)= 
     &  vint(180+i)+vckm((ia+1)/2,(ib+1)/2) 
      ELSEIF(ia.GE.11.AND.ia.LE.10+2*mstp(1)) THEN  
        vint(180+i)=1.  
      ENDIF 
  140 CONTINUE  
    
C...Choose Lambda value to use in alpha-strong. 
      mstu(111)=mstp(2) 
      IF(mstp(3).GE.1) THEN 
        alam=parp(1)    
        IF(mstp(51).EQ.1) alam=0.2  
        IF(mstp(51).EQ.2) alam=0.29 
        IF(mstp(51).EQ.3) alam=0.2  
        IF(mstp(51).EQ.4) alam=0.4  
        IF(mstp(51).EQ.11) alam=0.16    
        IF(mstp(51).EQ.12) alam=0.26    
        IF(mstp(51).EQ.13) alam=0.36    
        parp(1)=alam    
        parp(61)=alam   
        paru(112)=alam  
        parj(81)=alam   
      ENDIF 
    
C...Initialize widths and partial widths for resonances.    
      CALL pyinre   
    
C...Reset variables for cross-section calculation.  
      DO 150 i=0,200    
      DO 150 j=1,3  
      ngen(i,j)=0   
  150 xsec(i,j)=0.  
      vint(108)=0.  
    
C...Find parametrized total cross-sections. 
      IF(mint(43).EQ.4) CALL pyxtot 
    
C...Maxima of differential cross-sections.  
      IF(mstp(121).LE.0) CALL pymaxi    
    
C...Initialize possibility of overlayed events. 
      IF(mstp(131).NE.0) CALL pyovly(1) 
    
C...Initialize multiple interactions with variable impact parameter.    
      IF(mint(43).EQ.4.AND.(mint(45).NE.0.OR.mstp(131).NE.0).AND.   
     &mstp(82).GE.2) CALL pymult(1) 
C      IF(MSTP(122).GE.1) WRITE(MSTU(11),1600)  
    
C...Formats for initialization information. 
 1000 FORMAT(///20x,'The Lund Monte Carlo - PYTHIA version ',i1,'.',i1/ 
     &20x,'**  Last date of change:  ',i2,1x,a3,1x,i4,'  **'/)  
 1100 FORMAT('1',18('*'),1x,'PYINIT: initialization of PYTHIA ',    
     &'routines',1x,17('*'))    
 1200 FORMAT(1x,'Error: process number ',i3,' not meaningful for ',a6,  
     &'-',a6,' interactions.'/1x,'Execution stopped!')  
 1300 FORMAT(1x,'Error: requested subprocess',i4,' not implemented.'/   
     &1x,'Execution stopped!')  
 1400 FORMAT(1x,'Error: requested subprocess',i4,' not existing.'/  
     &1x,'Execution stopped!')  
 1500 FORMAT(1x,'Error: no subprocess switched on.'/    
     &1x,'Execution stopped.')  
 1600 FORMAT(/1x,22('*'),1x,'PYINIT: initialization completed',1x,  
     &22('*'))  
    
      RETURN    
      END   
    
C*********************************************************************  
    
      SUBROUTINE pythia 
    
C...Administers the generation of a high-pt event via calls to a number 
C...of subroutines; also computes cross-sections.   
      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/ludat2/kchg(500,3),pmas(500,4),parf(2000),vckm(4,4)    
      SAVE /ludat2/ 
      common/pysubs/msel,msub(200),kfin(2,-40:40),ckin(200) 
      SAVE /pysubs/ 
      common/pypars/mstp(200),parp(200),msti(200),pari(200) 
      SAVE /pypars/ 
      common/pyint1/mint(400),vint(400) 
      SAVE /pyint1/ 
      common/pyint2/iset(200),kfpr(200,2),coef(200,20),icol(40,4,2) 
      SAVE /pyint2/ 
      common/pyint5/ngen(0:200,3),xsec(0:200,3) 
      SAVE /pyint5/ 
    
C...Loop over desired number of overlayed events (normally 1).  
      mint(7)=0 
      mint(8)=0 
      novl=1    
      IF(mstp(131).NE.0) CALL pyovly(2) 
      IF(mstp(131).NE.0) novl=mint(81)  
      mint(83)=0    
      mint(84)=mstp(126)    
      mstu(70)=0    
      DO 190 iovl=1,novl    
      IF(mint(84)+100.GE.mstu(4)) THEN  
        CALL luerrm(11, 
     &  '(PYTHIA:) no more space in LUJETS for overlayed events')   
        IF(mstu(21).GE.1) goto 200  
      ENDIF 
      mint(82)=iovl 
    
C...Generate variables of hard scattering.  
  100 CONTINUE  
      IF(iovl.EQ.1) ngen(0,2)=ngen(0,2)+1   
      mint(31)=0    
      mint(51)=0    
      CALL pyrand   
      isub=mint(1)  
      IF(iovl.EQ.1) THEN    
        ngen(isub,2)=ngen(isub,2)+1 
    
C...Store information on hard interaction.  
        DO 110 j=1,200  
        msti(j)=0   
  110   pari(j)=0.  
        msti(1)=mint(1) 
        msti(2)=mint(2) 
        msti(11)=mint(11)   
        msti(12)=mint(12)   
        msti(15)=mint(15)   
        msti(16)=mint(16)   
        msti(17)=mint(17)   
        msti(18)=mint(18)   
        pari(11)=vint(1)    
        pari(12)=vint(2)    
        IF(isub.NE.95) THEN 
          DO 120 j=13,22    
  120     pari(j)=vint(30+j)    
          pari(33)=vint(41) 
          pari(34)=vint(42) 
          pari(35)=pari(33)-pari(34)    
          pari(36)=vint(21) 
          pari(37)=vint(22) 
          pari(38)=vint(26) 
          pari(41)=vint(23) 
        ENDIF   
      ENDIF 
    
      IF(mstp(111).EQ.-1) goto 160  
      IF(isub.LE.90.OR.isub.GE.95) THEN 
C...Hard scattering (including low-pT): 
C...reconstruct kinematics and colour flow of hard scattering.  
        CALL pyscat 
        IF(mint(51).EQ.1) goto 100  
    
C...Showering of initial state partons (optional).  
        ipu1=mint(84)+1 
        ipu2=mint(84)+2 
        IF(mstp(61).GE.1.AND.mint(43).NE.1.AND.isub.NE.95)  
     &  CALL pysspa(ipu1,ipu2)  
        nsav1=n 
    
C...Multiple interactions.  
        IF(mstp(81).GE.1.AND.mint(43).EQ.4.AND.isub.NE.95)  
     &  CALL pymult(6)  
        mint(1)=isub    
        nsav2=n 
    
C...Hadron remnants and primordial kT.  
        CALL pyremn(ipu1,ipu2)  
        IF(mint(51).EQ.1) goto 100  
        nsav3=n 
    
C...Showering of final state partons (optional).    
        ipu3=mint(84)+3 
        ipu4=mint(84)+4 
        IF(mstp(71).GE.1.AND.isub.NE.95.AND.k(ipu3,1).GT.0.AND. 
     &  k(ipu3,1).LE.10.AND.k(ipu4,1).GT.0.AND.k(ipu4,1).LE.10) THEN    
          qmax=sqrt(parp(71)*vint(52))  
          IF(isub.EQ.5) qmax=sqrt(pmas(23,1)**2)    
          IF(isub.EQ.8) qmax=sqrt(pmas(24,1)**2)    
          CALL lushow(ipu3,ipu4,qmax)   
        ENDIF   
    
C...Sum up transverse and longitudinal momenta. 
        IF(iovl.EQ.1) THEN  
          pari(65)=2.*pari(17)  
          DO 130 i=mstp(126)+1,n    
          IF(k(i,1).LE.0.OR.k(i,1).GT.10) goto 130  
          pt=sqrt(p(i,1)**2+p(i,2)**2)  
          pari(69)=pari(69)+pt  
          IF(i.LE.nsav1.OR.i.GT.nsav3) pari(66)=pari(66)+pt 
          IF(i.GT.nsav1.AND.i.LE.nsav2) pari(68)=pari(68)+pt    
  130     CONTINUE  
          pari(67)=pari(68) 
          pari(71)=vint(151)    
          pari(72)=vint(152)    
          pari(73)=vint(151)    
          pari(74)=vint(152)    
        ENDIF   
    
C...Decay of final state resonances.    
        IF(mstp(41).GE.1.AND.isub.NE.95) CALL pyresd    
    
      ELSE  
C...Diffractive and elastic scattering. 
        CALL pydiff 
        IF(iovl.EQ.1) THEN  
          pari(65)=2.*pari(17)  
          pari(66)=pari(65) 
          pari(69)=pari(65) 
        ENDIF   
      ENDIF 
    
C...Recalculate energies from momenta and masses (if desired).  
      IF(mstp(113).GE.1) THEN   
        DO 140 i=mint(83)+1,n   
  140   IF(k(i,1).GT.0.AND.k(i,1).LE.10) p(i,4)=sqrt(p(i,1)**2+ 
     &  p(i,2)**2+p(i,3)**2+p(i,5)**2)  
      ENDIF 
    
C...Rearrange partons along strings, check invariant mass cuts. 
      mstu(28)=0    
      CALL luprep(mint(84)+1)   
      IF(mstp(112).EQ.1.AND.mstu(28).EQ.3) goto 100 
      IF(mstp(125).EQ.0.OR.mstp(125).EQ.1) THEN 
        DO 150 i=mint(84)+1,n   
        IF(k(i,2).NE.94) goto 150   
        k(i+1,3)=mod(k(i+1,4)/mstu(5),mstu(5))  
        k(i+2,3)=mod(k(i+2,4)/mstu(5),mstu(5))  
  150   CONTINUE    
        CALL luedit(12) 
        CALL luedit(14) 
        IF(mstp(125).EQ.0) CALL luedit(15)  
        IF(mstp(125).EQ.0) mint(4)=0    
      ENDIF 
    
C...Introduce separators between sections in LULIST event listing.  
      IF(iovl.EQ.1.AND.mstp(125).LE.0) THEN 
        mstu(70)=1  
        mstu(71)=n  
      ELSEIF(iovl.EQ.1) THEN    
        mstu(70)=3  
        mstu(71)=2  
        mstu(72)=mint(4)    
        mstu(73)=n  
      ENDIF 
    
C...Perform hadronization (if desired). 
      IF(mstp(111).GE.1) CALL luexec    
      IF(mstp(125).EQ.0.OR.mstp(125).EQ.1) CALL luedit(14)  
    
C...Calculate Monte Carlo estimates of cross-sections.  
  160 IF(iovl.EQ.1) THEN    
        IF(mstp(111).NE.-1) ngen(isub,3)=ngen(isub,3)+1 
        ngen(0,3)=ngen(0,3)+1   
        xsec(0,3)=0.    
        DO 170 i=1,200  
        IF(i.EQ.96) THEN    
          xsec(i,3)=0.  
        ELSEIF(msub(95).EQ.1.AND.(i.EQ.11.OR.i.EQ.12.OR.i.EQ.13.OR. 
     &  i.EQ.28.OR.i.EQ.53.OR.i.EQ.68)) THEN    
          xsec(i,3)=xsec(96,2)*ngen(i,3)/max(1.,float(ngen(96,1))*  
     &    float(ngen(96,2)))    
        ELSEIF(ngen(i,1).EQ.0) THEN 
          xsec(i,3)=0.  
        ELSEIF(ngen(i,2).EQ.0) THEN 
          xsec(i,3)=xsec(i,2)*ngen(0,3)/(float(ngen(i,1))*  
     &    float(ngen(0,2))) 
        ELSE    
          xsec(i,3)=xsec(i,2)*ngen(i,3)/(float(ngen(i,1))*  
     &    float(ngen(i,2))) 
        ENDIF   
  170   xsec(0,3)=xsec(0,3)+xsec(i,3)   
        IF(msub(95).EQ.1) THEN  
          ngens=ngen(91,3)+ngen(92,3)+ngen(93,3)+ngen(94,3)+ngen(95,3)  
          xsecs=xsec(91,3)+xsec(92,3)+xsec(93,3)+xsec(94,3)+xsec(95,3)  
          xmaxs=xsec(95,1)  
          IF(msub(91).EQ.1) xmaxs=xmaxs+xsec(91,1)  
          IF(msub(92).EQ.1) xmaxs=xmaxs+xsec(92,1)  
          IF(msub(93).EQ.1) xmaxs=xmaxs+xsec(93,1)  
          IF(msub(94).EQ.1) xmaxs=xmaxs+xsec(94,1)  
          fac=1.    
          IF(ngens.LT.ngen(0,3)) fac=(xmaxs-xsecs)/(xsec(0,3)-xsecs)    
          xsec(11,3)=fac*xsec(11,3) 
          xsec(12,3)=fac*xsec(12,3) 
          xsec(13,3)=fac*xsec(13,3) 
          xsec(28,3)=fac*xsec(28,3) 
          xsec(53,3)=fac*xsec(53,3) 
          xsec(68,3)=fac*xsec(68,3) 
          xsec(0,3)=xsec(91,3)+xsec(92,3)+xsec(93,3)+xsec(94,3)+    
     &    xsec(95,1)    
        ENDIF   
    
C...Store final information.    
        mint(5)=mint(5)+1   
        msti(3)=mint(3) 
        msti(4)=mint(4) 
        msti(5)=mint(5) 
        msti(6)=mint(6) 
        msti(7)=mint(7) 
        msti(8)=mint(8) 
        msti(13)=mint(13)   
        msti(14)=mint(14)   
        msti(21)=mint(21)   
        msti(22)=mint(22)   
        msti(23)=mint(23)   
        msti(24)=mint(24)   
        msti(25)=mint(25)   
        msti(26)=mint(26)   
        msti(31)=mint(31)   
        pari(1)=xsec(0,3)   
        pari(2)=xsec(0,3)/mint(5)   
        pari(31)=vint(141)  
        pari(32)=vint(142)  
        IF(isub.NE.95.AND.mint(7)*mint(8).NE.0) THEN    
          pari(42)=2.*vint(47)/vint(1)  
          DO 180 is=7,8 
          pari(36+is)=p(mint(is),3)/vint(1) 
          pari(38+is)=p(mint(is),4)/vint(1) 
          i=mint(is)    
          pr=max(1e-20,p(i,5)**2+p(i,1)**2+p(i,2)**2)   
          pari(40+is)=sign(log(min((sqrt(pr+p(i,3)**2)+abs(p(i,3)))/    
     &    sqrt(pr),1e20)),p(i,3))   
          pr=max(1e-20,p(i,1)**2+p(i,2)**2) 
          pari(42+is)=sign(log(min((sqrt(pr+p(i,3)**2)+abs(p(i,3)))/    
     &    sqrt(pr),1e20)),p(i,3))   
          pari(44+is)=p(i,3)/sqrt(p(i,1)**2+p(i,2)**2+p(i,3)**2)    
          pari(46+is)=ulangl(p(i,3),sqrt(p(i,1)**2+p(i,2)**2))  
          pari(48+is)=ulangl(p(i,1),p(i,2)) 
  180     CONTINUE  
        ENDIF   
        pari(61)=vint(148)  
        IF(iset(isub).EQ.1.OR.iset(isub).EQ.3) THEN 
          mstu(161)=mint(21)    
          mstu(162)=0   
        ELSE    
          mstu(161)=mint(21)    
          mstu(162)=mint(22)    
        ENDIF   
      ENDIF 
    
C...Prepare to go to next overlayed event.  
      msti(41)=iovl 
      IF(iovl.GE.2.AND.iovl.LE.10) msti(40+iovl)=isub   
      IF(mstu(70).LT.10) THEN   
        mstu(70)=mstu(70)+1 
        mstu(70+mstu(70))=n 
      ENDIF 
      mint(83)=n    
      mint(84)=n+mstp(126)  
  190 CONTINUE  
    
C...Information on overlayed events.    
      IF(mstp(131).EQ.1.AND.mstp(133).GE.1) THEN    
        pari(91)=vint(132)  
        pari(92)=vint(133)  
        pari(93)=vint(134)  
        IF(mstp(133).EQ.2) pari(93)=pari(93)*xsec(0,3)/vint(131)    
      ENDIF 
    
C...Transform to the desired coordinate frame.  
  200 CALL pyfram(mstp(124))    
    
      RETURN    
      END   
    
C***********************************************************************    
    
      SUBROUTINE pystat(MSTAT)  
    
C...Prints out information about cross-sections, decay widths, branching    
C...ratios, kinematical limits, status codes and parameter values.  
      common/ludat1/mstu(200),paru(200),mstj(200),parj(200) 
      SAVE /ludat1/ 
      common/ludat2/kchg(500,3),pmas(500,4),parf(2000),vckm(4,4)    
      SAVE /ludat2/ 
      common/ludat3/mdcy(500,3),mdme(2000,2),brat(2000),kfdp(2000,5)    
      SAVE /ludat3/ 
      common/pysubs/msel,msub(200),kfin(2,-40:40),ckin(200) 
      SAVE /pysubs/ 
      common/pypars/mstp(200),parp(200),msti(200),pari(200) 
      SAVE /pypars/ 
      common/pyint1/mint(400),vint(400) 
      SAVE /pyint1/ 
      common/pyint4/widp(21:40,0:40),wide(21:40,0:40),wids(21:40,3) 
      SAVE /pyint4/ 
      common/pyint5/ngen(0:200,3),xsec(0:200,3) 
      SAVE /pyint5/ 
      common/pyint6/proc(0:200) 
      CHARACTER proc*28 
      SAVE /pyint6/ 
      CHARACTER chau*16,chpa(-40:40)*12,chin(2)*12, 
     &state(-1:5)*4,chkin(21)*18    
      DATA state/'----','off ','on  ','on/+','on/-','on/1','on/2'/, 
     &chkin/' m_hard (GeV/c^2) ',' p_T_hard (GeV/c) ',  
     &'m_finite (GeV/c^2)','   y*_subsystem   ','     y*_large     ',   
     &'     y*_small     ','    eta*_large    ','    eta*_small    ',   
     &'cos(theta*)_large ','cos(theta*)_small ','       x_1        ',   
     &'       x_2        ','       x_F        ',' cos(theta_hard)  ',   
     &'m''_hard (GeV/c^2) ','       tau        ','        y*        ',  
     &'cos(theta_hard^-) ','cos(theta_hard^+) ','      x_T^2       ',   
     &'       tau''       '/    
    
C...Cross-sections. 
      IF(mstat.LE.1) THEN   
        WRITE(mstu(11),1000)    
        WRITE(mstu(11),1100)    
        WRITE(mstu(11),1200) 0,proc(0),ngen(0,3),ngen(0,1),xsec(0,3)    
        DO 100 i=1,200  
        IF(msub(i).NE.1) goto 100   
        WRITE(mstu(11),1200) i,proc(i),ngen(i,3),ngen(i,1),xsec(i,3)    
  100   CONTINUE    
        WRITE(mstu(11),1300) 1.-float(ngen(0,3))/   
     &  max(1.,float(ngen(0,2)))    
    
C...Decay widths and branching ratios.  
      ELSEIF(mstat.EQ.2) THEN   
        DO 110 kf=-40,40    
        CALL luname(kf,chau)    
  110   chpa(kf)=chau(1:12) 
        WRITE(mstu(11),1400)    
        WRITE(mstu(11),1500)    
C...Off-shell branchings.   
        DO 130 i=1,17   
        kc=i    
        IF(i.GE.9) kc=i+2   
        IF(i.EQ.17) kc=21   
        WRITE(mstu(11),1600) chpa(kc),0.,0.,state(mdcy(kc,1)),0.    
        DO 120 j=1,mdcy(kc,3)   
        idc=j+mdcy(kc,2)-1  
  120   IF(mdme(idc,2).EQ.102) WRITE(mstu(11),1700) chpa(kfdp(idc,1)),  
     &  chpa(kfdp(idc,2)),0.,0.,state(mdme(idc,1)),0.   
  130   CONTINUE    
C...On-shell decays.    
        DO 150 i=1,6    
        kc=i+22 
        IF(i.EQ.4) kc=32    
        IF(i.EQ.5) kc=37    
        IF(i.EQ.6) kc=40    
        IF(wide(kc,0).GT.0.) THEN   
          WRITE(mstu(11),1600) chpa(kc),widp(kc,0),1.,  
     &    state(mdcy(kc,1)),1.  
          DO 140 j=1,mdcy(kc,3) 
          idc=j+mdcy(kc,2)-1    
  140     WRITE(mstu(11),1700) chpa(kfdp(idc,1)),chpa(kfdp(idc,2)), 
     &    widp(kc,j),widp(kc,j)/widp(kc,0),state(mdme(idc,1)),  
     &    wide(kc,j)/wide(kc,0) 
        ELSE    
          WRITE(mstu(11),1600) chpa(kc),widp(kc,0),1.,  
     &    state(mdcy(kc,1)),0.  
        ENDIF   
  150   CONTINUE    
        WRITE(mstu(11),1800)    
    
C...Allowed incoming partons/particles at hard interaction. 
      ELSEIF(mstat.EQ.3) THEN   
        WRITE(mstu(11),1900)    
        CALL luname(mint(11),chau)  
        chin(1)=chau(1:12)  
        CALL luname(mint(12),chau)  
        chin(2)=chau(1:12)  
        WRITE(mstu(11),2000) chin(1),chin(2)    
        DO 160 kf=-40,40    
        CALL luname(kf,chau)    
  160   chpa(kf)=chau(1:12) 
        IF(mint(43).EQ.1) THEN  
          WRITE(mstu(11),2100) chpa(mint(11)),state(kfin(1,mint(11))),  
     &    chpa(mint(12)),state(kfin(2,mint(12)))    
        ELSEIF(mint(43).EQ.2) THEN  
          WRITE(mstu(11),2100) chpa(mint(11)),state(kfin(1,mint(11))),  
     &    chpa(-mstp(54)),state(kfin(2,-mstp(54)))  
          DO 170 i=-mstp(54)+1,-1   
  170     WRITE(mstu(11),2200) chpa(i),state(kfin(2,i)) 
          DO 180 i=1,mstp(54)   
  180     WRITE(mstu(11),2200) chpa(i),state(kfin(2,i)) 
          WRITE(mstu(11),2200) chpa(21),state(kfin(2,21))   
        ELSEIF(mint(43).EQ.3) THEN  
          WRITE(mstu(11),2100) chpa(-mstp(54)),state(kfin(1,-mstp(54))),    
     &    chpa(mint(12)),state(kfin(2,mint(12)))    
          DO 190 i=-mstp(54)+1,-1   
  190     WRITE(mstu(11),2300) chpa(i),state(kfin(1,i)) 
          DO 200 i=1,mstp(54)   
  200     WRITE(mstu(11),2300) chpa(i),state(kfin(1,i)) 
          WRITE(mstu(11),2300) chpa(21),state(kfin(1,21))   
        ELSEIF(mint(43).EQ.4) THEN  
          DO 210 i=-mstp(54),-1 
  210     WRITE(mstu(11),2100) chpa(i),state(kfin(1,i)),chpa(i),    
     &    state(kfin(2,i))  
          DO 220 i=1,mstp(54)   
  220     WRITE(mstu(11),2100) chpa(i),state(kfin(1,i)),chpa(i),    
     &    state(kfin(2,i))  
          WRITE(mstu(11),2100) chpa(21),state(kfin(1,21)),chpa(21), 
     &    state(kfin(2,21)) 
        ENDIF   
        WRITE(mstu(11),2400)    
    
C...User-defined and derived limits on kinematical variables.   
      ELSEIF(mstat.EQ.4) THEN   
        WRITE(mstu(11),2500)    
        WRITE(mstu(11),2600)    
        shrmax=ckin(2)  
        IF(shrmax.LT.0.) shrmax=vint(1) 
        WRITE(mstu(11),2700) ckin(1),chkin(1),shrmax    
        pthmin=max(ckin(3),ckin(5)) 
        pthmax=ckin(4)  
        IF(pthmax.LT.0.) pthmax=0.5*shrmax  
        WRITE(mstu(11),2800) ckin(3),pthmin,chkin(2),pthmax 
        WRITE(mstu(11),2900) chkin(3),ckin(6)   
        DO 230 i=4,14   
  230   WRITE(mstu(11),2700) ckin(2*i-1),chkin(i),ckin(2*i) 
        sprmax=ckin(32) 
        IF(sprmax.LT.0.) sprmax=vint(1) 
        WRITE(mstu(11),2700) ckin(31),chkin(13),sprmax  
        WRITE(mstu(11),3000)    
        WRITE(mstu(11),3100)    
        WRITE(mstu(11),2600)    
        DO 240 i=16,21  
  240   WRITE(mstu(11),2700) vint(i-5),chkin(i),vint(i+15)  
        WRITE(mstu(11),3000)    
    
C...Status codes and parameter values.  
      ELSEIF(mstat.EQ.5) THEN   
        WRITE(mstu(11),3200)    
        WRITE(mstu(11),3300)    
        DO 250 i=1,100  
  250   WRITE(mstu(11),3400) i,mstp(i),parp(i),100+i,mstp(100+i),   
     &  parp(100+i) 
      ENDIF 
    
C...Formats for printouts.  
 1000 FORMAT('1',9('*'),1x,'PYSTAT:  Statistics on Number of ', 
     &'Events and Cross-sections',1x,9('*'))    
 1100 FORMAT(/1x,78('=')/1x,'I',34x,'I',28x,'I',12x,'I'/1x,'I',12x, 
     &'Subprocess',12x,'I',6x,'Number of points',6x,'I',4x,'Sigma',3x,  
     &'I'/1x,'I',34x,'I',28x,'I',12x,'I'/1x,'I',34('-'),'I',28('-'),    
     &'I',4x,'(mb)',4x,'I'/1x,'I',34x,'I',28x,'I',12x,'I'/1x,'I',1x,    
     &'N:o',1x,'Type',25x,'I',4x,'Generated',9x,'Tried',1x,'I',12x, 
     &'I'/1x,'I',34x,'I',28x,'I',12x,'I'/1x,78('=')/1x,'I',34x,'I',28x, 
     &'I',12x,'I')  
 1200 FORMAT(1x,'I',1x,i3,1x,a28,1x,'I',1x,i12,1x,i13,1x,'I',1x,1p, 
     &e10.3,1x,'I') 
 1300 FORMAT(1x,'I',34x,'I',28x,'I',12x,'I'/1x,78('=')//    
     &1x,'********* Fraction of events that fail fragmentation ',   
     &'cuts =',1x,f8.5,' *********'/)   
 1400 FORMAT('1',17('*'),1x,'PYSTAT:  Decay Widths and Branching ', 
     &'Ratios',1x,17('*'))  
 1500 FORMAT(/1x,78('=')/1x,'I',29x,'I',13x,'I',12x,'I',6x,'I',12x,'I'/ 
     &1x,'I',1x,'Branching/Decay Channel',5x,'I',1x,'Width (GeV)',1x,   
     &'I',7x,'B.R.',1x,'I',1x,'Stat',1x,'I',2x,'Eff. B.R.',1x,'I'/1x,   
     &'I',29x,'I',13x,'I',12x,'I',6x,'I',12x,'I'/1x,78('='))    
 1600 FORMAT(1x,'I',29x,'I',13x,'I',12x,'I',6x,'I',12x,'I'/1x,'I',1x,   
     &a12,1x,'->',13x,'I',2x,1p,e10.3,0p,1x,'I',1x,1p,e10.3,0p,1x,'I',  
     &1x,a4,1x,'I',1x,1p,e10.3,0p,1x,'I')   
 1700 FORMAT(1x,'I',1x,a12,1x,'+',1x,a12,1x,'I',2x,1p,e10.3,0p,1x,'I',  
     &1x,1p,e10.3,0p,1x,'I',1x,a4,1x,'I',1x,1p,e10.3,0p,1x,'I') 
 1800 FORMAT(1x,'I',29x,'I',13x,'I',12x,'I',6x,'I',12x,'I'/1x,78('='))  
 1900 FORMAT('1',7('*'),1x,'PYSTAT: Allowed Incoming Partons/', 
     &'Particles at Hard Interaction',1x,7('*'))    
 2000 FORMAT(/1x,78('=')/1x,'I',38x,'I',37x,'I'/1x,'I',1x,  
     &'Beam particle:',1x,a,10x,'I',1x,'Target particle:',1x,a,7x,  
     &'I'/1x,'I',38x,'I',37x,'I'/1x,'I',1x,'Content',9x,'State',16x,    
     &'I',1x,'Content',9x,'State',15x,'I'/1x,'I',38x,'I',37x,'I'/1x,    
     &78('=')/1x,'I',38x,'I',37x,'I')   
 2100 FORMAT(1x,'I',1x,a,5x,a,16x,'I',1x,a,5x,a,15x,'I')    
 2200 FORMAT(1x,'I',38x,'I',1x,a,5x,a,15x,'I')  
 2300 FORMAT(1x,'I',1x,a,5x,a,16x,'I',37x,'I')  
 2400 FORMAT(1x,'I',38x,'I',37x,'I'/1x,78('=')) 
 2500 FORMAT('1',12('*'),1x,'PYSTAT: User-Defined Limits on ',  
     &'Kinematical Variables',1x,12('*'))   
 2600 FORMAT(/1x,78('=')/1x,'I',76x,'I')    
 2700 FORMAT(1x,'I',16x,1p,e10.3,0p,1x,'<',1x,a,1x,'<',1x,1p,e10.3,0p,  
     &16x,'I')  
 2800 FORMAT(1x,'I',3x,1p,e10.3,0p,1x,'(',1p,e10.3,0p,')',1x,'<',1x,a,  
     &1x,'<',1x,1p,e10.3,0p,16x,'I')    
 2900 FORMAT(1x,'I',29x,a,1x,'=',1x,1p,e10.3,0p,16x,'I')    
 3000 FORMAT(1x,'I',76x,'I'/1x,78('=')) 
 3100 FORMAT(////1x,5('*'),1x,'PYSTAT: Derived Limits on Kinematical ', 
     &'Variables Used in Generation',1x,5('*')) 
 3200 FORMAT('1',12('*'),1x,'PYSTAT: Summary of Status Codes and ', 
     &'Parameter Values',1x,12('*'))    
 3300 FORMAT(/3x,'I',4x,'MSTP(I)',9x,'PARP(I)',20x,'I',4x,'MSTP(I)',9x, 
     &'PARP(I)'/)   
 3400 FORMAT(1x,i3,5x,i6,6x,1p,e10.3,0p,18x,i3,5x,i6,6x,1p,e10.3)   
    
      RETURN    
      END   
    
C*********************************************************************  
    
      SUBROUTINE pyinki(CHFRAM,CHBEAM,CHTARG,WIN)   
    
C...Identifies the two incoming particles and sets up kinematics,   
C...including rotations and boosts to/from CM frame.    
      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/pysubs/msel,msub(200),kfin(2,-40:40),ckin(200) 
      SAVE /pysubs/ 
      common/pypars/mstp(200),parp(200),msti(200),pari(200) 
      SAVE /pypars/ 
      common/pyint1/mint(400),vint(400) 
      SAVE /pyint1/ 
      CHARACTER chfram*8,chbeam*8,chtarg*8,chcom(3)*8,chalp(2)*26,  
     &chidnt(3)*8,chtemp*8,chcde(18)*8,chinit*76    
      dimension len(3),kcde(18) 
      DATA chalp/'abcdefghijklmnopqrstuvwxyz',  
     &'ABCDEFGHIJKLMNOPQRSTUVWXYZ'/ 
      DATA chcde/'e-      ','e+      ','nue     ','nue~    ',   
     &'mu-     ','mu+     ','numu    ','numu~   ','tau-    ',   
     &'tau+    ','nutau   ','nutau~  ','pi+     ','pi-     ',   
     &'n       ','n~      ','p       ','p~      '/  
      DATA kcde/11,-11,12,-12,13,-13,14,-14,15,-15,16,-16,  
     &211,-211,2112,-2112,2212,-2212/   
    
C...Convert character variables to lowercase and find their length. 
      chcom(1)=chfram   
      chcom(2)=chbeam   
      chcom(3)=chtarg   
      DO 120 i=1,3  
      len(i)=8  
      DO 100 ll=8,1,-1  
      IF(len(i).EQ.ll.AND.chcom(i)(ll:ll).EQ.' ') len(i)=ll-1   
      DO 100 la=1,26    
  100 IF(chcom(i)(ll:ll).EQ.chalp(2)(la:la)) chcom(i)(ll:ll)=   
     &chalp(1)(la:la)   
      chidnt(i)=chcom(i)    
      DO 110 ll=1,6 
      IF(chidnt(i)(ll:ll+2).EQ.'bar') THEN  
        chtemp=chidnt(i)    
        chidnt(i)=chtemp(1:ll-1)//'~'//chtemp(ll+3:8)//'  ' 
      ENDIF 
  110 CONTINUE  
      DO 120 ll=1,8 
      IF(chidnt(i)(ll:ll).EQ.'_') THEN  
        chtemp=chidnt(i)    
        chidnt(i)=chtemp(1:ll-1)//chtemp(ll+1:8)//' '   
      ENDIF 
  120 CONTINUE  
    
C...Set initial state. Error for unknown codes. Reset variables.    
      n=2   
      DO 140 i=1,2  
      k(i,2)=0  
      DO 130 j=1,18 
  130 IF(chidnt(i+1).EQ.chcde(j)) k(i,2)=kcde(j)    
      p(i,5)=ulmass(k(i,2)) 
      mint(40+i)=1  
      IF(iabs(k(i,2)).GT.100) mint(40+i)=2  
      DO 140 j=1,5  
  140 v(i,j)=0. 
      IF(k(1,2).EQ.0) WRITE(mstu(11),1000) chbeam(1:len(2)) 
      IF(k(2,2).EQ.0) WRITE(mstu(11),1100) chtarg(1:len(3)) 
      IF(k(1,2).EQ.0.OR.k(2,2).EQ.0) stop   
      DO 150 j=6,10 
  150 vint(j)=0.    
      chinit=' '    
    
C...Set up kinematics for events defined in CM frame.   
      IF(chcom(1)(1:2).EQ.'cm') THEN    
        IF(chcom(2)(1:1).NE.'e') THEN   
          loffs=(34-(len(2)+len(3)))/2  
          chinit(loffs+1:76)='PYTHIA will be initialized for a '//  
     &    chcom(2)(1:len(2))//'-'//chcom(3)(1:len(3))//' collider'//' ' 
        ELSE    
          loffs=(33-(len(2)+len(3)))/2  
          chinit(loffs+1:76)='PYTHIA will be initialized for an '// 
     &    chcom(2)(1:len(2))//'-'//chcom(3)(1:len(3))//' collider'//' ' 
        ENDIF   
C        WRITE(MSTU(11),1200) CHINIT 
C        WRITE(MSTU(11),1300) WIN    
        s=win**2    
        p(1,1)=0.   
        p(1,2)=0.   
        p(2,1)=0.   
        p(2,2)=0.   
        p(1,3)=sqrt(((s-p(1,5)**2-p(2,5)**2)**2-(2.*p(1,5)*p(2,5))**2)/ 
     &  (4.*s)) 
        p(2,3)=-p(1,3)  
        p(1,4)=sqrt(p(1,3)**2+p(1,5)**2)    
        p(2,4)=sqrt(p(2,3)**2+p(2,5)**2)    
    
C...Set up kinematics for fixed target events.  
      ELSEIF(chcom(1)(1:3).EQ.'fix') THEN   
        loffs=(29-(len(2)+len(3)))/2    
        chinit(loffs+1:76)='PYTHIA will be initialized for '//  
     &  chcom(2)(1:len(2))//' on '//chcom(3)(1:len(3))//    
     &  ' fixed target'//' '    
C        WRITE(MSTU(11),1200) CHINIT 
C        WRITE(MSTU(11),1400) WIN    
        p(1,1)=0.   
        p(1,2)=0.   
        p(2,1)=0.   
        p(2,2)=0.   
        p(1,3)=win  
        p(1,4)=sqrt(p(1,3)**2+p(1,5)**2)    
        p(2,3)=0.   
        p(2,4)=p(2,5)   
        s=p(1,5)**2+p(2,5)**2+2.*p(2,4)*p(1,4)  
        vint(10)=p(1,3)/(p(1,4)+p(2,4)) 
        CALL lurobo(0.,0.,0.,0.,-vint(10))  
C        WRITE(MSTU(11),1500) SQRT(S)    
    
C...Set up kinematics for events in user-defined frame. 
      ELSEIF(chcom(1)(1:3).EQ.'use') THEN   
        loffs=(13-(len(1)+len(2)))/2    
        chinit(loffs+1:76)='PYTHIA will be initialized for '//  
     &  chcom(2)(1:len(2))//' on '//chcom(3)(1:len(3))//    
     &  'user-specified configuration'//' ' 
C        WRITE(MSTU(11),1200) CHINIT 
C        WRITE(MSTU(11),1600)    
C        WRITE(MSTU(11),1700) CHCOM(2),P(1,1),P(1,2),P(1,3)  
C        WRITE(MSTU(11),1700) CHCOM(3),P(2,1),P(2,2),P(2,3)  
        p(1,4)=sqrt(p(1,1)**2+p(1,2)**2+p(1,3)**2+p(1,5)**2)    
        p(2,4)=sqrt(p(2,1)**2+p(2,2)**2+p(2,3)**2+p(2,5)**2)    
        DO 160 j=1,3    
  160   vint(7+j)=(dble(p(1,j))+dble(p(2,j)))/dble(p(1,4)+p(2,4))   
        CALL lurobo(0.,0.,-vint(8),-vint(9),-vint(10))  
        vint(7)=ulangl(p(1,1),p(1,2))   
        CALL lurobo(0.,-vint(7),0.,0.,0.)   
        vint(6)=ulangl(p(1,3),p(1,1))   
        CALL lurobo(-vint(6),0.,0.,0.,0.)   
        s=p(1,5)**2+p(2,5)**2+2.*(p(1,4)*p(2,4)-p(1,3)*p(2,3))  
C        WRITE(MSTU(11),1500) SQRT(S)    
    
C...Unknown frame. Error for too low CM energy. 
      ELSE  
        WRITE(mstu(11),1800) chfram(1:len(1))   
        stop    
      ENDIF 
      IF(s.LT.parp(2)**2) THEN  
        WRITE(mstu(11),1900) sqrt(s)    
        stop    
      ENDIF 
    
C...Save information on incoming particles. 
      mint(11)=k(1,2)   
      mint(12)=k(2,2)   
      mint(43)=2*mint(41)+mint(42)-2    
      vint(1)=sqrt(s)   
      vint(2)=s 
      vint(3)=p(1,5)    
      vint(4)=p(2,5)    
      vint(5)=p(1,3)    
    
C...Store constants to be used in generation.   
      IF(mstp(82).LE.1) vint(149)=4.*parp(81)**2/s  
      IF(mstp(82).GE.2) vint(149)=4.*parp(82)**2/s  
    
C...Formats for initialization and error information.   
 1000 FORMAT(1x,'Error: unrecognized beam particle ''',a,'''.'/ 
     &1x,'Execution stopped!')  
 1100 FORMAT(1x,'Error: unrecognized target particle ''',a,'''.'/   
     &1x,'Execution stopped!')  
 1200 FORMAT(/1x,78('=')/1x,'I',76x,'I'/1x,'I',a76,'I') 
 1300 FORMAT(1x,'I',18x,'at',1x,f10.3,1x,'GeV center-of-mass energy',   
     &19x,'I'/1x,'I',76x,'I'/1x,78('='))    
 1400 FORMAT(1x,'I',22x,'at',1x,f10.3,1x,'GeV/c lab-momentum',22x,'I')  
 1500 FORMAT(1x,'I',76x,'I'/1x,'I',11x,'corresponding to',1x,f10.3,1x,  
     &'GeV center-of-mass energy',12x,'I'/1x,'I',76x,'I'/1x,78('='))    
 1600 FORMAT(1x,'I',76x,'I'/1x,'I',24x,'px (GeV/c)',3x,'py (GeV/c)',3x, 
     &'pz (GeV/c)',16x,'I') 
 1700 FORMAT(1x,'I',15x,a8,3(2x,f10.3,1x),15x,'I')  
 1800 FORMAT(1x,'Error: unrecognized coordinate frame ''',a,'''.'/  
     &1x,'Execution stopped!')  
 1900 FORMAT(1x,'Error: too low CM energy,',f8.3,' GeV for event ', 
     &'generation.'/1x,'Execution stopped!')    
    
      RETURN    
      END   
    
C*********************************************************************  
    
      SUBROUTINE pyinre 
    
C...Calculates full and effective widths of guage bosons, stores masses 
C...and widths, rescales coefficients to be used for resonance  
C...production generation.  
      common/ludat1/mstu(200),paru(200),mstj(200),parj(200) 
      SAVE /ludat1/ 
      common/ludat2/kchg(500,3),pmas(500,4),parf(2000),vckm(4,4)    
      SAVE /ludat2/ 
      common/ludat3/mdcy(500,3),mdme(2000,2),brat(2000),kfdp(2000,5)    
      SAVE /ludat3/ 
      common/pysubs/msel,msub(200),kfin(2,-40:40),ckin(200) 
      SAVE /pysubs/ 
      common/pypars/mstp(200),parp(200),msti(200),pari(200) 
      SAVE /pypars/ 
      common/pyint1/mint(400),vint(400) 
      SAVE /pyint1/ 
      common/pyint2/iset(200),kfpr(200,2),coef(200,20),icol(40,4,2) 
      SAVE /pyint2/ 
      common/pyint4/widp(21:40,0:40),wide(21:40,0:40),wids(21:40,3) 
      SAVE /pyint4/ 
      common/pyint6/proc(0:200) 
      CHARACTER proc*28 
      SAVE /pyint6/ 
      dimension wdtp(0:40),wdte(0:40,0:5)   
    
C...Calculate full and effective widths of gauge bosons.    
      aem=paru(101) 
      xw=paru(102)  
      DO 100 i=21,40    
      DO 100 j=0,40 
      widp(i,j)=0.  
  100 wide(i,j)=0.  
    
C...W+/-:   
      wmas=pmas(24,1)   
      wfac=aem/(24.*xw)*wmas    
      CALL pywidt(24,wmas,wdtp,wdte)    
      wids(24,1)=((wdte(0,1)+wdte(0,2))*(wdte(0,1)+wdte(0,3))+  
     &(wdte(0,1)+wdte(0,2)+wdte(0,1)+wdte(0,3))*(wdte(0,4)+wdte(0,5))+  
     &2.*wdte(0,4)*wdte(0,5))/wdtp(0)**2    
      wids(24,2)=(wdte(0,1)+wdte(0,2)+wdte(0,4))/wdtp(0)    
      wids(24,3)=(wdte(0,1)+wdte(0,3)+wdte(0,4))/wdtp(0)    
      DO 110 i=0,40 
      widp(24,i)=wfac*wdtp(i)   
  110 wide(24,i)=wfac*wdte(i,0) 
    
C...H+/-:   
      hcmas=pmas(37,1)  
      hcfac=aem/(8.*xw)*(hcmas/wmas)**2*hcmas   
      CALL pywidt(37,hcmas,wdtp,wdte)   
      wids(37,1)=((wdte(0,1)+wdte(0,2))*(wdte(0,1)+wdte(0,3))+  
     &(wdte(0,1)+wdte(0,2)+wdte(0,1)+wdte(0,3))*(wdte(0,4)+wdte(0,5))+  
     &2.*wdte(0,4)*wdte(0,5))/wdtp(0)**2    
      wids(37,2)=(wdte(0,1)+wdte(0,2)+wdte(0,4))/wdtp(0)    
      wids(37,3)=(wdte(0,1)+wdte(0,3)+wdte(0,4))/wdtp(0)    
      DO 120 i=0,40 
      widp(37,i)=hcfac*wdtp(i)  
  120 wide(37,i)=hcfac*wdte(i,0)    
    
C...Z0: 
      zmas=pmas(23,1)   
      zfac=aem/(48.*xw*(1.-xw))*zmas    
      CALL pywidt(23,zmas,wdtp,wdte)    
      wids(23,1)=((wdte(0,1)+wdte(0,2))**2+ 
     &2.*(wdte(0,1)+wdte(0,2))*(wdte(0,4)+wdte(0,5))+   
     &2.*wdte(0,4)*wdte(0,5))/wdtp(0)**2    
      wids(23,2)=(wdte(0,1)+wdte(0,2)+wdte(0,4))/wdtp(0)    
      wids(23,3)=0. 
      DO 130 i=0,40 
      widp(23,i)=zfac*wdtp(i)   
  130 wide(23,i)=zfac*wdte(i,0) 
    
C...H0: 
      hmas=pmas(25,1)   
      hfac=aem/(8.*xw)*(hmas/wmas)**2*hmas  
      CALL pywidt(25,hmas,wdtp,wdte)    
      wids(25,1)=((wdte(0,1)+wdte(0,2))**2+ 
     &2.*(wdte(0,1)+wdte(0,2))*(wdte(0,4)+wdte(0,5))+   
     &2.*wdte(0,4)*wdte(0,5))/wdtp(0)**2    
      wids(25,2)=(wdte(0,1)+wdte(0,2)+wdte(0,4))/wdtp(0)    
      wids(25,3)=0. 
      DO 140 i=0,40 
      widp(25,i)=hfac*wdtp(i)   
  140 wide(25,i)=hfac*wdte(i,0) 
    
C...Z'0:    
      zpmas=pmas(32,1)  
      zpfac=aem/(48.*xw*(1.-xw))*zpmas  
      CALL pywidt(32,zpmas,wdtp,wdte)   
      wids(32,1)=((wdte(0,1)+wdte(0,2)+wdte(0,3))**2+   
     &2.*(wdte(0,1)+wdte(0,2))*(wdte(0,4)+wdte(0,5))+   
     &2.*wdte(0,4)*wdte(0,5))/wdtp(0)**2    
      wids(32,2)=(wdte(0,1)+wdte(0,2)+wdte(0,4))/wdtp(0)    
      wids(32,3)=0. 
      DO 150 i=0,40 
      widp(32,i)=zpfac*wdtp(i)  
  150 wide(32,i)=zpfac*wdte(i,0)    
    
C...R:  
      rmas=pmas(40,1)   
      rfac=0.08*rmas/((mstp(1)-1)*(1.+6.*(1.+ulalps(rmas**2)/paru(1)))) 
      CALL pywidt(40,rmas,wdtp,wdte)    
      wids(40,1)=((wdte(0,1)+wdte(0,2))*(wdte(0,1)+wdte(0,3))+  
     &(wdte(0,1)+wdte(0,2)+wdte(0,1)+wdte(0,3))*(wdte(0,4)+wdte(0,5))+  
     &2.*wdte(0,4)*wdte(0,5))/wdtp(0)**2    
      wids(40,2)=(wdte(0,1)+wdte(0,2)+wdte(0,4))/wdtp(0)    
      wids(40,3)=(wdte(0,1)+wdte(0,3)+wdte(0,4))/wdtp(0)    
      DO 160 i=0,40 
      widp(40,i)=wfac*wdtp(i)   
  160 wide(40,i)=wfac*wdte(i,0) 
    
C...Q:  
      kflqm=1   
      DO 170 i=1,min(8,mdcy(21,3))  
      idc=i+mdcy(21,2)-1    
      IF(mdme(idc,1).LE.0) goto 170 
      kflqm=i   
  170 CONTINUE  
      mint(46)=kflqm    
      kfpr(81,1)=kflqm  
      kfpr(81,2)=kflqm  
      kfpr(82,1)=kflqm  
      kfpr(82,2)=kflqm  
    
C...Set resonance widths and branching ratios in JETSET.    
      DO 180 i=1,6  
      IF(i.LE.3) kc=i+22    
      IF(i.EQ.4) kc=32  
      IF(i.EQ.5) kc=37  
      IF(i.EQ.6) kc=40  
      pmas(kc,2)=widp(kc,0) 
      pmas(kc,3)=min(0.9*pmas(kc,1),10.*pmas(kc,2)) 
      DO 180 j=1,mdcy(kc,3) 
      idc=j+mdcy(kc,2)-1    
      brat(idc)=wide(kc,j)/wide(kc,0)   
  180 CONTINUE  
    
C...Special cases in treatment of gamma*/Z0: redefine process name. 
      IF(mstp(43).EQ.1) THEN    
        proc(1)='f + fb -> gamma*'  
      ELSEIF(mstp(43).EQ.2) THEN    
        proc(1)='f + fb -> Z0'  
      ELSEIF(mstp(43).EQ.3) THEN    
        proc(1)='f + fb -> gamma*/Z0'   
      ENDIF 
    
C...Special cases in treatment of gamma*/Z0/Z'0: redefine process name. 
      IF(mstp(44).EQ.1) THEN    
        proc(141)='f + fb -> gamma*'    
      ELSEIF(mstp(44).EQ.2) THEN    
        proc(141)='f + fb -> Z0'    
      ELSEIF(mstp(44).EQ.3) THEN    
        proc(141)='f + fb -> Z''0'  
      ELSEIF(mstp(44).EQ.4) THEN    
        proc(141)='f + fb -> gamma*/Z0' 
      ELSEIF(mstp(44).EQ.5) THEN    
        proc(141)='f + fb -> gamma*/Z''0'   
      ELSEIF(mstp(44).EQ.6) THEN    
        proc(141)='f + fb -> Z0/Z''0'   
      ELSEIF(mstp(44).EQ.7) THEN    
        proc(141)='f + fb -> gamma*/Z0/Z''0'    
      ENDIF 
    
      RETURN    
      END   
    
C*********************************************************************  
    
      SUBROUTINE pyxtot 
    
C...Parametrizes total, double diffractive, single diffractive and  
C...elastic cross-sections for different energies and beams.    
      common/ludat1/mstu(200),paru(200),mstj(200),parj(200) 
      SAVE /ludat1/ 
      common/pypars/mstp(200),parp(200),msti(200),pari(200) 
      SAVE /pypars/ 
      common/pyint1/mint(400),vint(400) 
      SAVE /pyint1/ 
      common/pyint5/ngen(0:200,3),xsec(0:200,3) 
      SAVE /pyint5/ 
      dimension bcs(5,8),bcb(2,5),bcc(3)    
    
C...The following data lines are coefficients needed in the 
C...Block, Cahn parametrization of total cross-section and nuclear  
C...slope parameter; see below. 
      DATA ((bcs(i,j),j=1,8),i=1,5)/    
     1 41.74, 0.66, 0.0000, 337.,  0.0, 0.0, -39.3, 0.48,   
     2 41.66, 0.60, 0.0000, 306.,  0.0, 0.0, -34.6, 0.51,   
     3 41.36, 0.63, 0.0000, 299.,  7.3, 0.5, -40.4, 0.47,   
     4 41.68, 0.63, 0.0083, 330.,  0.0, 0.0, -39.0, 0.48,   
     5 41.13, 0.59, 0.0074, 278., 10.5, 0.5, -41.2, 0.46/   
      DATA ((bcb(i,j),j=1,5),i=1,2)/    
     1 10.79, -0.049, 0.040, 21.5, 1.23,    
     2  9.92, -0.027, 0.013, 18.9, 1.07/    
      DATA bcc/2.0164346,-0.5590311,0.0376279/  
    
C...Total cross-section and nuclear slope parameter for pp and p-pbar   
      nfit=min(5,max(1,mstp(31)))   
      sigp=bcs(nfit,1)+bcs(nfit,2)*(-0.25*paru(1)**2*   
     &(1.-0.25*bcs(nfit,3)*paru(1)**2)+(1.+0.5*bcs(nfit,3)*paru(1)**2)* 
     &(log(vint(2)/bcs(nfit,4)))**2+bcs(nfit,3)*    
     &(log(vint(2)/bcs(nfit,4)))**4)/   
     &((1.-0.25*bcs(nfit,3)*paru(1)**2)**2+2.*bcs(nfit,3)*  
     &(1.+0.25*bcs(nfit,3)*paru(1)**2)*(log(vint(2)/bcs(nfit,4)))**2+   
     &bcs(nfit,3)**2*(log(vint(2)/bcs(nfit,4)))**4)+bcs(nfit,5)*    
     &vint(2)**(bcs(nfit,6)-1.)*sin(0.5*paru(1)*bcs(nfit,6))    
      sigm=-bcs(nfit,7)*vint(2)**(bcs(nfit,8)-1.)*  
     &cos(0.5*paru(1)*bcs(nfit,8))  
      refp=bcs(nfit,2)*paru(1)*log(vint(2)/bcs(nfit,4))/    
     &((1.-0.25*bcs(nfit,3)*paru(1)**2)**2+2.*bcs(nfit,3)*  
     &(1.+0.25*bcs(nfit,3)*paru(1)**2)+(log(vint(2)/bcs(nfit,4)))**2+   
     &bcs(nfit,3)**2*(log(vint(2)/bcs(nfit,4)))**4)-bcs(nfit,5)*    
     &vint(2)**(bcs(nfit,6)-1.)*cos(0.5*paru(1)*bcs(nfit,6))    
      refm=-bcs(nfit,7)*vint(2)**(bcs(nfit,8)-1.)*  
     &sin(0.5*paru(1)*bcs(nfit,8))  
      sigma=sigp-isign(1,mint(11)*mint(12))*sigm    
      rho=(refp-isign(1,mint(11)*mint(12))*refm)/sigma  
    
C...Nuclear slope parameter B, curvature C: 
      nfit=1    
      IF(mstp(31).GE.4) nfit=2  
      bp=bcb(nfit,1)+bcb(nfit,2)*log(vint(2))+  
     &bcb(nfit,3)*(log(vint(2)))**2 
      bm=bcb(nfit,4)+bcb(nfit,5)*log(vint(2))   
      b=bp-isign(1,mint(11)*mint(12))*sigm/sigp*(bm-bp) 
      vint(121)=b   
      c=-0.5*bcc(2)/bcc(3)*(1.-sqrt(max(0.,1.+4.*bcc(3)/bcc(2)**2*  
     &(1.e-03*vint(1)-bcc(1)))))    
      vint(122)=c   
    
C...Elastic scattering cross-section (fixed by sigma-tot, rho and B).   
      sigel=sigma**2*(1.+rho**2)/(16.*paru(1)*paru(5)*b)    
    
C...Single diffractive scattering cross-section from Goulianos: 
      sigsd=2.*0.68*(1.+36./vint(2))*log(0.6+0.1*vint(2))   
    
C...Double diffractive scattering cross-section (essentially fixed by   
C...sigma-sd and sigma-el). 
      sigdd=sigsd**2/(3.*sigel) 
    
C...Total non-elastic, non-diffractive cross-section.   
      signd=sigma-sigdd-sigsd-sigel 
    
C...Rescale for pions.  
      IF(iabs(mint(11)).EQ.211.AND.iabs(mint(12)).EQ.211) THEN  
        sigma=4./9.*sigma   
        sigdd=4./9.*sigdd   
        sigsd=4./9.*sigsd   
        sigel=4./9.*sigel   
        signd=4./9.*signd   
      ELSEIF(iabs(mint(11)).EQ.211.OR.iabs(mint(12)).EQ.211) THEN   
        sigma=2./3.*sigma   
        sigdd=2./3.*sigdd   
        sigsd=2./3.*sigsd   
        sigel=2./3.*sigel   
        signd=2./3.*signd   
      ENDIF 
    
C...Save cross-sections in common block PYPARA. 
      vint(101)=sigma   
      vint(102)=sigel   
      vint(103)=sigsd   
      vint(104)=sigdd   
      vint(106)=signd   
      xsec(95,1)=signd  
    
      RETURN    
      END   
    
C*********************************************************************  
    
      SUBROUTINE pymaxi 
    
C...Finds optimal set of coefficients for kinematical variable selection    
C...and the maximum of the part of the differential cross-section used  
C...in the event weighting. 
      common/ludat1/mstu(200),paru(200),mstj(200),parj(200) 
      SAVE /ludat1/ 
      common/ludat2/kchg(500,3),pmas(500,4),parf(2000),vckm(4,4)    
      SAVE /ludat2/ 
      common/pysubs/msel,msub(200),kfin(2,-40:40),ckin(200) 
      SAVE /pysubs/ 
      common/pypars/mstp(200),parp(200),msti(200),pari(200) 
      SAVE /pypars/ 
      common/pyint1/mint(400),vint(400) 
      SAVE /pyint1/ 
      common/pyint2/iset(200),kfpr(200,2),coef(200,20),icol(40,4,2) 
      SAVE /pyint2/ 
      common/pyint3/xsfx(2,-40:40),isig(1000,3),sigh(1000)  
      SAVE /pyint3/ 
      common/pyint4/widp(21:40,0:40),wide(21:40,0:40),wids(21:40,3) 
      SAVE /pyint4/ 
      common/pyint5/ngen(0:200,3),xsec(0:200,3) 
      SAVE /pyint5/ 
      common/pyint6/proc(0:200) 
      CHARACTER proc*28 
      SAVE /pyint6/ 
      CHARACTER cvar(4)*4   
      dimension npts(4),mvarpt(200,4),vintpt(200,30),sigspt(200),   
     &narel(6),wtrel(6),wtmat(6,6),coefu(6),iaccmx(4),sigsmx(4),    
     &sigssm(3) 
      DATA cvar/'tau ','tau''','y*  ','cth '/   
    
C...Select subprocess to study: skip cases not applicable.  
      vint(143)=1.  
      vint(144)=1.  
      xsec(0,1)=0.  
      DO 350 isub=1,200 
      IF(isub.GE.91.AND.isub.LE.95) THEN    
        xsec(isub,1)=vint(isub+11)  
        IF(msub(isub).NE.1) goto 350    
        goto 340    
      ELSEIF(isub.EQ.96) THEN   
        IF(mint(43).NE.4) goto 350  
        IF(msub(95).NE.1.AND.mstp(81).LE.0.AND.mstp(131).LE.0) goto 350 
      ELSEIF(isub.EQ.11.OR.isub.EQ.12.OR.isub.EQ.13.OR.isub.EQ.28.OR.   
     &isub.EQ.53.OR.isub.EQ.68) THEN    
        IF(msub(isub).NE.1.OR.msub(95).EQ.1) goto 350   
      ELSE  
        IF(msub(isub).NE.1) goto 350    
      ENDIF 
      mint(1)=isub  
      istsb=iset(isub)  
      IF(isub.EQ.96) istsb=2    
      IF(mstp(122).GE.2) WRITE(mstu(11),1000) isub  
    
C...Find resonances (explicit or implicit in cross-section).    
      mint(72)=0    
      kfr1=0    
      IF(istsb.EQ.1.OR.istsb.EQ.3) THEN 
        kfr1=kfpr(isub,1)   
      ELSEIF(isub.GE.71.AND.isub.LE.77) THEN    
        kfr1=25 
      ENDIF 
      IF(kfr1.NE.0) THEN    
        taur1=pmas(kfr1,1)**2/vint(2)   
        gamr1=pmas(kfr1,1)*pmas(kfr1,2)/vint(2) 
        mint(72)=1  
        mint(73)=kfr1   
        vint(73)=taur1  
        vint(74)=gamr1  
      ENDIF 
      IF(isub.EQ.141) THEN  
        kfr2=23 
        taur2=pmas(kfr2,1)**2/vint(2)   
        gamr2=pmas(kfr2,1)*pmas(kfr2,2)/vint(2) 
        mint(72)=2  
        mint(74)=kfr2   
        vint(75)=taur2  
        vint(76)=gamr2  
      ENDIF 
    
C...Find product masses and minimum pT of process.  
      sqm3=0.   
      sqm4=0.   
      mint(71)=0    
      vint(71)=ckin(3)  
      IF(istsb.EQ.2.OR.istsb.EQ.4) THEN 
        IF(kfpr(isub,1).NE.0) sqm3=pmas(kfpr(isub,1),1)**2  
        IF(kfpr(isub,2).NE.0) sqm4=pmas(kfpr(isub,2),1)**2  
        IF(min(sqm3,sqm4).LT.ckin(6)**2) mint(71)=1 
        IF(mint(71).EQ.1) vint(71)=max(ckin(3),ckin(5)) 
        IF(isub.EQ.96.AND.mstp(82).LE.1) vint(71)=parp(81)  
        IF(isub.EQ.96.AND.mstp(82).GE.2) vint(71)=0.08*parp(82) 
      ENDIF 
      vint(63)=sqm3 
      vint(64)=sqm4 
    
C...Number of points for each variable: tau, tau', y*, cos(theta-hat).  
      npts(1)=2+2*mint(72)  
      IF(mint(43).EQ.1.AND.(istsb.EQ.1.OR.istsb.EQ.2)) npts(1)=1    
      npts(2)=1 
      IF(mint(43).GE.2.AND.(istsb.EQ.3.OR.istsb.EQ.4)) npts(2)=2    
      npts(3)=1 
      IF(mint(43).EQ.4) npts(3)=3   
      npts(4)=1 
      IF(istsb.EQ.2.OR.istsb.EQ.4) npts(4)=5    
      ntry=npts(1)*npts(2)*npts(3)*npts(4)  
    
C...Reset coefficients of cross-section weighting.  
      DO 100 j=1,20 
  100 coef(isub,j)=0.   
      coef(isub,1)=1.   
      coef(isub,7)=0.5  
      coef(isub,8)=0.5  
      coef(isub,10)=1.  
      coef(isub,15)=1.  
      mcth=0    
      mtaup=0   
      cth=0.    
      taup=0.   
      sigsam=0. 
    
C...Find limits and select tau, y*, cos(theta-hat) and tau' values, 
C...in grid of phase space points.  
      CALL pyklim(1)    
      nacc=0    
      DO 120 itry=1,ntry    
      IF(mod(itry-1,npts(2)*npts(3)*npts(4)).EQ.0) THEN 
        mtau=1+(itry-1)/(npts(2)*npts(3)*npts(4))   
        CALL pykmap(1,mtau,0.5) 
        IF(istsb.EQ.3.OR.istsb.EQ.4) CALL pyklim(4) 
      ENDIF 
      IF((istsb.EQ.3.OR.istsb.EQ.4).AND.mod(itry-1,npts(3)*npts(4)).    
     &eq.0) THEN    
        mtaup=1+mod((itry-1)/(npts(3)*npts(4)),npts(2)) 
        CALL pykmap(4,mtaup,0.5)    
      ENDIF 
      IF(mod(itry-1,npts(3)*npts(4)).EQ.0) CALL pyklim(2)   
      IF(mod(itry-1,npts(4)).EQ.0) THEN 
        myst=1+mod((itry-1)/npts(4),npts(3))    
        CALL pykmap(2,myst,0.5) 
        CALL pyklim(3)  
      ENDIF 
      IF(istsb.EQ.2.OR.istsb.EQ.4) THEN 
        mcth=1+mod(itry-1,npts(4))  
        CALL pykmap(3,mcth,0.5) 
      ENDIF 
      IF(isub.EQ.96) vint(25)=vint(21)*(1.-vint(23)**2) 
    
C...Calculate and store cross-section.  
      mint(51)=0    
      CALL pyklim(0)    
      IF(mint(51).EQ.1) goto 120    
      nacc=nacc+1   
      mvarpt(nacc,1)=mtau   
      mvarpt(nacc,2)=mtaup  
      mvarpt(nacc,3)=myst   
      mvarpt(nacc,4)=mcth   
      DO 110 j=1,30 
  110 vintpt(nacc,j)=vint(10+j) 
      CALL pysigh(nchn,sigs)    
      sigspt(nacc)=sigs 
      IF(sigs.GT.sigsam) sigsam=sigs    
      IF(mstp(122).GE.2) WRITE(mstu(11),1100) mtau,mtaup,myst,mcth, 
     &vint(21),vint(22),vint(23),vint(26),sigs  
  120 CONTINUE  
      IF(sigsam.EQ.0.) THEN 
        WRITE(mstu(11),1200) isub   
        stop    
      ENDIF 
    
C...Calculate integrals in tau and y* over maximal phase space limits.  
      taumin=vint(11)   
      taumax=vint(31)   
      atau1=log(taumax/taumin)  
      atau2=(taumax-taumin)/(taumax*taumin) 
      IF(npts(1).GE.3) THEN 
        atau3=log(taumax/taumin*(taumin+taur1)/(taumax+taur1))/taur1    
        atau4=(atan((taumax-taur1)/gamr1)-atan((taumin-taur1)/gamr1))/  
     &  gamr1   
      ENDIF 
      IF(npts(1).GE.5) THEN 
        atau5=log(taumax/taumin*(taumin+taur2)/(taumax+taur2))/taur2    
        atau6=(atan((taumax-taur2)/gamr2)-atan((taumin-taur2)/gamr2))/  
     &  gamr2   
      ENDIF 
      ystmin=0.5*log(taumin)    
      ystmax=-ystmin    
      ayst0=ystmax-ystmin   
      ayst1=0.5*(ystmax-ystmin)**2  
      ayst3=2.*(atan(exp(ystmax))-atan(exp(ystmin)))    
    
C...Reset. Sum up cross-sections in points calculated.  
      DO 230 ivar=1,4   
      IF(npts(ivar).EQ.1) goto 230  
      IF(isub.EQ.96.AND.ivar.EQ.4) goto 230 
      nbin=npts(ivar)   
      DO 130 j1=1,nbin  
      narel(j1)=0   
      wtrel(j1)=0.  
      coefu(j1)=0.  
      DO 130 j2=1,nbin  
  130 wtmat(j1,j2)=0.   
      DO 140 iacc=1,nacc    
      ibin=mvarpt(iacc,ivar)    
      narel(ibin)=narel(ibin)+1 
      wtrel(ibin)=wtrel(ibin)+sigspt(iacc)  
    
C...Sum up tau cross-section pieces in points used. 
      IF(ivar.EQ.1) THEN    
        tau=vintpt(iacc,11) 
        wtmat(ibin,1)=wtmat(ibin,1)+1.  
        wtmat(ibin,2)=wtmat(ibin,2)+(atau1/atau2)/tau   
        IF(nbin.GE.3) THEN  
          wtmat(ibin,3)=wtmat(ibin,3)+(atau1/atau3)/(tau+taur1) 
          wtmat(ibin,4)=wtmat(ibin,4)+(atau1/atau4)*tau/    
     &    ((tau-taur1)**2+gamr1**2) 
        ENDIF   
        IF(nbin.GE.5) THEN  
          wtmat(ibin,5)=wtmat(ibin,5)+(atau1/atau5)/(tau+taur2) 
          wtmat(ibin,6)=wtmat(ibin,6)+(atau1/atau6)*tau/    
     &    ((tau-taur2)**2+gamr2**2) 
        ENDIF   
    
C...Sum up tau' cross-section pieces in points used.    
      ELSEIF(ivar.EQ.2) THEN    
        tau=vintpt(iacc,11) 
        taup=vintpt(iacc,16)    
        taupmn=vintpt(iacc,6)   
        taupmx=vintpt(iacc,26)  
        ataup1=log(taupmx/taupmn)   
        ataup2=((1.-tau/taupmx)**4-(1.-tau/taupmn)**4)/(4.*tau) 
        wtmat(ibin,1)=wtmat(ibin,1)+1.  
        wtmat(ibin,2)=wtmat(ibin,2)+(ataup1/ataup2)*(1.-tau/taup)**3/   
     &  taup    
    
C...Sum up y* and cos(theta-hat) cross-section pieces in points used.   
      ELSEIF(ivar.EQ.3) THEN    
        yst=vintpt(iacc,12) 
        wtmat(ibin,1)=wtmat(ibin,1)+(ayst0/ayst1)*(yst-ystmin)  
        wtmat(ibin,2)=wtmat(ibin,2)+(ayst0/ayst1)*(ystmax-yst)  
        wtmat(ibin,3)=wtmat(ibin,3)+(ayst0/ayst3)/cosh(yst) 
      ELSE  
        rm34=2.*sqm3*sqm4/(vintpt(iacc,11)*vint(2))**2  
        rsqm=1.+rm34    
        cthmax=sqrt(1.-4.*vint(71)**2/(taumax*vint(2))) 
        cthmin=-cthmax  
        IF(cthmax.GT.0.9999) rm34=max(rm34,2.*vint(71)**2/  
     &  (taumax*vint(2)))   
        acth1=cthmax-cthmin 
        acth2=log(max(rm34,rsqm-cthmin)/max(rm34,rsqm-cthmax))  
        acth3=log(max(rm34,rsqm+cthmax)/max(rm34,rsqm+cthmin))  
        acth4=1./max(rm34,rsqm-cthmax)-1./max(rm34,rsqm-cthmin) 
        acth5=1./max(rm34,rsqm+cthmin)-1./max(rm34,rsqm+cthmax) 
        cth=vintpt(iacc,13) 
        wtmat(ibin,1)=wtmat(ibin,1)+1.  
        wtmat(ibin,2)=wtmat(ibin,2)+(acth1/acth2)/max(rm34,rsqm-cth)    
        wtmat(ibin,3)=wtmat(ibin,3)+(acth1/acth3)/max(rm34,rsqm+cth)    
        wtmat(ibin,4)=wtmat(ibin,4)+(acth1/acth4)/max(rm34,rsqm-cth)**2 
        wtmat(ibin,5)=wtmat(ibin,5)+(acth1/acth5)/max(rm34,rsqm+cth)**2 
      ENDIF 
  140 CONTINUE  
    
C...Check that equation system solvable; else trivial way out.  
      IF(mstp(122).GE.2) WRITE(mstu(11),1300) cvar(ivar)    
      msolv=1   
      DO 150 ibin=1,nbin    
      IF(mstp(122).GE.2) WRITE(mstu(11),1400) (wtmat(ibin,ired),    
     &ired=1,nbin),wtrel(ibin)  
  150 IF(narel(ibin).EQ.0) msolv=0  
      IF(msolv.EQ.0) THEN   
        DO 160 ibin=1,nbin  
  160   coefu(ibin)=1.  
    
C...Solve to find relative importance of cross-section pieces.  
      ELSE  
        DO 170 ired=1,nbin-1    
        DO 170 ibin=ired+1,nbin 
        rqt=wtmat(ibin,ired)/wtmat(ired,ired)   
        wtrel(ibin)=wtrel(ibin)-rqt*wtrel(ired) 
        DO 170 icoe=ired,nbin   
  170   wtmat(ibin,icoe)=wtmat(ibin,icoe)-rqt*wtmat(ired,icoe)  
        DO 190 ired=nbin,1,-1   
        DO 180 icoe=ired+1,nbin 
  180   wtrel(ired)=wtrel(ired)-wtmat(ired,icoe)*coefu(icoe)    
  190   coefu(ired)=wtrel(ired)/wtmat(ired,ired)    
      ENDIF 
    
C...Normalize coefficients, with piece shared democratically.   
      coefsu=0. 
      DO 200 ibin=1,nbin    
      coefu(ibin)=max(0.,coefu(ibin))   
  200 coefsu=coefsu+coefu(ibin) 
      IF(ivar.EQ.1) ioff=0  
      IF(ivar.EQ.2) ioff=14 
      IF(ivar.EQ.3) ioff=6  
      IF(ivar.EQ.4) ioff=9  
      IF(coefsu.GT.0.) THEN 
        DO 210 ibin=1,nbin  
  210   coef(isub,ioff+ibin)=parp(121)/nbin+(1.-parp(121))*coefu(ibin)/ 
     &  coefsu  
      ELSE  
        DO 220 ibin=1,nbin  
  220   coef(isub,ioff+ibin)=1./nbin    
      ENDIF 
      IF(mstp(122).GE.2) WRITE(mstu(11),1500) cvar(ivar),   
     &(coef(isub,ioff+ibin),ibin=1,nbin)    
  230 CONTINUE  
    
C...Find two most promising maxima among points previously determined.  
      DO 240 j=1,4  
      iaccmx(j)=0   
  240 sigsmx(j)=0.  
      nmax=0    
      DO 290 iacc=1,nacc    
      DO 250 j=1,30 
  250 vint(10+j)=vintpt(iacc,j) 
      CALL pysigh(nchn,sigs)    
      ieq=0 
      DO 260 imv=1,nmax 
  260 IF(abs(sigs-sigsmx(imv)).LT.1e-4*(sigs+sigsmx(imv))) ieq=imv  
      IF(ieq.EQ.0) THEN 
        DO 270 imv=nmax,1,-1    
        iin=imv+1   
        IF(sigs.LE.sigsmx(imv)) goto 280    
        iaccmx(imv+1)=iaccmx(imv)   
  270   sigsmx(imv+1)=sigsmx(imv)   
        iin=1   
  280   iaccmx(iin)=iacc    
        sigsmx(iin)=sigs    
        IF(nmax.LE.1) nmax=nmax+1   
      ENDIF 
  290 CONTINUE  
    
C...Read out starting position for search.  
      IF(mstp(122).GE.2) WRITE(mstu(11),1600)   
      sigsam=sigsmx(1)  
      DO 330 imax=1,nmax    
      iacc=iaccmx(imax) 
      mtau=mvarpt(iacc,1)   
      mtaup=mvarpt(iacc,2)  
      myst=mvarpt(iacc,3)   
      mcth=mvarpt(iacc,4)   
      vtau=0.5  
      vyst=0.5  
      vcth=0.5  
      vtaup=0.5 
    
C...Starting point and step size in parameter space.    
      DO 320 irpt=1,2   
      DO 310 ivar=1,4   
      IF(npts(ivar).EQ.1) goto 310  
      IF(ivar.EQ.1) vvar=vtau   
      IF(ivar.EQ.2) vvar=vtaup  
      IF(ivar.EQ.3) vvar=vyst   
      IF(ivar.EQ.4) vvar=vcth   
      IF(ivar.EQ.1) mvar=mtau   
      IF(ivar.EQ.2) mvar=mtaup  
      IF(ivar.EQ.3) mvar=myst   
      IF(ivar.EQ.4) mvar=mcth   
      IF(irpt.EQ.1) vdel=0.1    
      IF(irpt.EQ.2) vdel=max(0.01,min(0.05,vvar-0.02,0.98-vvar))    
      IF(irpt.EQ.1) vmar=0.02   
      IF(irpt.EQ.2) vmar=0.002  
      imov0=1   
      IF(irpt.EQ.1.AND.ivar.EQ.1) imov0=0   
      DO 300 imov=imov0,8   
    
C...Define new point in parameter space.    
      IF(imov.EQ.0) THEN    
        inew=2  
        vnew=vvar   
      ELSEIF(imov.EQ.1) THEN    
        inew=3  
        vnew=vvar+vdel  
      ELSEIF(imov.EQ.2) THEN    
        inew=1  
        vnew=vvar-vdel  
      ELSEIF(sigssm(3).GE.max(sigssm(1),sigssm(2)).AND. 
     &vvar+2.*vdel.LT.1.-vmar) THEN 
        vvar=vvar+vdel  
        sigssm(1)=sigssm(2) 
        sigssm(2)=sigssm(3) 
        inew=3  
        vnew=vvar+vdel  
      ELSEIF(sigssm(1).GE.max(sigssm(2),sigssm(3)).AND. 
     &vvar-2.*vdel.GT.vmar) THEN    
        vvar=vvar-vdel  
        sigssm(3)=sigssm(2) 
        sigssm(2)=sigssm(1) 
        inew=1  
        vnew=vvar-vdel  
      ELSEIF(sigssm(3).GE.sigssm(1)) THEN   
        vdel=0.5*vdel   
        vvar=vvar+vdel  
        sigssm(1)=sigssm(2) 
        inew=2  
        vnew=vvar   
      ELSE  
        vdel=0.5*vdel   
        vvar=vvar-vdel  
        sigssm(3)=sigssm(2) 
        inew=2  
        vnew=vvar   
      ENDIF 
    
C...Convert to relevant variables and find derived new limits.  
      IF(ivar.EQ.1) THEN    
        vtau=vnew   
        CALL pykmap(1,mtau,vtau)    
        IF(istsb.EQ.3.OR.istsb.EQ.4) CALL pyklim(4) 
      ENDIF 
      IF(ivar.LE.2.AND.(istsb.EQ.3.OR.istsb.EQ.4)) THEN 
        IF(ivar.EQ.2) vtaup=vnew    
        CALL pykmap(4,mtaup,vtaup)  
      ENDIF 
      IF(ivar.LE.2) CALL pyklim(2)  
      IF(ivar.LE.3) THEN    
        IF(ivar.EQ.3) vyst=vnew 
        CALL pykmap(2,myst,vyst)    
        CALL pyklim(3)  
      ENDIF 
      IF(istsb.EQ.2.OR.istsb.EQ.4) THEN 
        IF(ivar.EQ.4) vcth=vnew 
        CALL pykmap(3,mcth,vcth)    
      ENDIF 
      IF(isub.EQ.96) vint(25)=vint(21)*(1.-vint(23)**2) 
    
C...Evaluate cross-section. Save new maximum. Final maximum.    
      CALL pysigh(nchn,sigs)    
      sigssm(inew)=sigs 
      IF(sigs.GT.sigsam) sigsam=sigs    
      IF(mstp(122).GE.2) WRITE(mstu(11),1700) imax,ivar,mvar,imov,  
     &vnew,vint(21),vint(22),vint(23),vint(26),sigs 
  300 CONTINUE  
  310 CONTINUE  
  320 CONTINUE  
      IF(imax.EQ.1) sigs11=sigsam   
  330 CONTINUE  
      xsec(isub,1)=1.05*sigsam  
  340 IF(isub.NE.96) xsec(0,1)=xsec(0,1)+xsec(isub,1)   
  350 CONTINUE  
    
C...Print summary table.    
      IF(mstp(122).GE.1) THEN   
        WRITE(mstu(11),1800)    
        WRITE(mstu(11),1900)    
        DO 360 isub=1,200   
        IF(msub(isub).NE.1.AND.isub.NE.96) goto 360 
        IF(isub.EQ.96.AND.mint(43).NE.4) goto 360   
        IF(isub.EQ.96.AND.msub(95).NE.1.AND.mstp(81).LE.0) goto 360 
        IF(msub(95).EQ.1.AND.(isub.EQ.11.OR.isub.EQ.12.OR.isub.EQ.13.OR.    
     &  isub.EQ.28.OR.isub.EQ.53.OR.isub.EQ.68)) goto 360   
        WRITE(mstu(11),2000) isub,proc(isub),xsec(isub,1)   
  360   CONTINUE    
        WRITE(mstu(11),2100)    
      ENDIF 
    
C...Format statements for maximization results. 
 1000 FORMAT(/1x,'Coefficient optimization and maximum search for ',    
     &'subprocess no',i4/1x,'Coefficient modes     tau',10x,'y*',9x,    
     &'cth',9x,'tau''',7x,'sigma')  
 1100 FORMAT(1x,4i4,f12.8,f12.6,f12.7,f12.8,1p,e12.4)   
 1200 FORMAT(1x,'Error: requested subprocess ',i3,' has vanishing ',    
     &'cross-section.'/1x,'Execution stopped!')
 1300 FORMAT(1x,'Coefficients of equation system to be solved for ',a4) 
 1400 FORMAT(1x,1p,7e11.3)  
 1500 FORMAT(1x,'Result for ',a4,':',6f9.4) 
 1600 FORMAT(1x,'Maximum search for given coefficients'/2x,'MAX VAR ',  
     &'MOD MOV   VNEW',7x,'tau',7x,'y*',8x,'cth',7x,'tau''',7x,'sigma') 
 1700 FORMAT(1x,4i4,f8.4,f11.7,f9.3,f11.6,f11.7,1p,e12.4)   
 1800 FORMAT(/1x,8('*'),1x,'PYMAXI: summary of differential ',  
     &'cross-section maximum search',1x,8('*')) 
 1900 FORMAT(/11x,58('=')/11x,'I',38x,'I',17x,'I'/11x,'I  ISUB  ',  
     &'Subprocess name',15x,'I  Maximum value  I'/11x,'I',38x,'I',  
     &17x,'I'/11x,58('=')/11x,'I',38x,'I',17x,'I')  
 2000 FORMAT(11x,'I',2x,i3,3x,a28,2x,'I',2x,1p,e12.4,3x,'I')    
 2100 FORMAT(11x,'I',38x,'I',17x,'I'/11x,58('='))   
    
      RETURN    
      END   
    
C*********************************************************************  
    
      SUBROUTINE pyovly(MOVLY)  
    
C...Initializes multiplicity distribution and selects mutliplicity  
C...of overlayed events, i.e. several events occuring at the same   
C...beam crossing.  
      common/ludat1/mstu(200),paru(200),mstj(200),parj(200) 
      SAVE /ludat1/ 
      common/pypars/mstp(200),parp(200),msti(200),pari(200) 
      SAVE /pypars/ 
      common/pyint1/mint(400),vint(400) 
      SAVE /pyint1/ 
      dimension wti(0:100)  
      SAVE imax,wti,wts 
    
C...Sum of allowed cross-sections for overlayed events. 
      IF(movly.EQ.1) THEN   
        vint(131)=vint(106) 
        IF(mstp(132).GE.2) vint(131)=vint(131)+vint(104)    
        IF(mstp(132).GE.3) vint(131)=vint(131)+vint(103)    
        IF(mstp(132).GE.4) vint(131)=vint(131)+vint(102)    
    
C...Initialize multiplicity distribution for unbiased events.   
        IF(mstp(133).EQ.1) THEN 
          xnave=vint(131)*parp(131) 
          IF(xnave.GT.40.) WRITE(mstu(11),1000) xnave   
          wti(0)=exp(-min(50.,xnave))   
          wts=0.    
          wtn=0.    
          DO 100 i=1,100    
          wti(i)=wti(i-1)*xnave/i   
          IF(i-2.5.GT.xnave.AND.wti(i).LT.1e-6) goto 110    
          wts=wts+wti(i)    
          wtn=wtn+wti(i)*i  
  100     imax=i    
  110     vint(132)=xnave   
          vint(133)=wtn/wts 
          vint(134)=wts 
    
C...Initialize mutiplicity distribution for biased events.  
        ELSEIF(mstp(133).EQ.2) THEN 
          xnave=vint(131)*parp(131) 
          IF(xnave.GT.40.) WRITE(mstu(11),1000) xnave   
          wti(1)=exp(-min(50.,xnave))*xnave 
          wts=wti(1)    
          wtn=wti(1)    
          DO 120 i=2,100    
          wti(i)=wti(i-1)*xnave/(i-1)   
          IF(i-2.5.GT.xnave.AND.wti(i).LT.1e-6) goto 130    
          wts=wts+wti(i)    
          wtn=wtn+wti(i)*i  
  120     imax=i    
  130     vint(132)=xnave   
          vint(133)=wtn/wts 
          vint(134)=wts 
        ENDIF   
    
C...Pick multiplicity of overlayed events.  
      ELSE  
        IF(mstp(133).EQ.0) THEN 
          mint(81)=max(1,mstp(134)) 
        ELSE    
          wtr=wts*rlu(0)    
          DO 140 i=1,imax   
          mint(81)=i    
          wtr=wtr-wti(i)    
          IF(wtr.LE.0.) goto 150    
  140     CONTINUE  
  150     CONTINUE  
        ENDIF   
      ENDIF 
    
C...Format statement for error message. 
 1000 FORMAT(1x,'Warning: requested average number of events per bunch',    
     &'crossing too large, ',1p,e12.4)  
    
      RETURN    
      END   
    
C*********************************************************************  
    
      SUBROUTINE pyrand 
    
C...Generates quantities characterizing the high-pT scattering at the   
C...parton level according to the matrix elements. Chooses incoming,    
C...reacting partons, their momentum fractions and one of the possible  
C...subprocesses.   
      common/ludat1/mstu(200),paru(200),mstj(200),parj(200) 
      SAVE /ludat1/ 
      common/ludat2/kchg(500,3),pmas(500,4),parf(2000),vckm(4,4)    
      SAVE /ludat2/ 
      common/pysubs/msel,msub(200),kfin(2,-40:40),ckin(200) 
      SAVE /pysubs/ 
      common/pypars/mstp(200),parp(200),msti(200),pari(200) 
      SAVE /pypars/ 
      common/pyint1/mint(400),vint(400) 
      SAVE /pyint1/ 
      common/pyint2/iset(200),kfpr(200,2),coef(200,20),icol(40,4,2) 
      SAVE /pyint2/ 
      common/pyint3/xsfx(2,-40:40),isig(1000,3),sigh(1000)  
      SAVE /pyint3/ 
      common/pyint4/widp(21:40,0:40),wide(21:40,0:40),wids(21:40,3) 
      SAVE /pyint4/ 
      common/pyint5/ngen(0:200,3),xsec(0:200,3) 
      SAVE /pyint5/ 
    
C...Initial values, specifically for (first) semihard interaction.  
      mint(17)=0    
      mint(18)=0    
      vint(143)=1.  
      vint(144)=1.  
      IF(msub(95).EQ.1.OR.mint(82).GE.2) CALL pymult(2) 
      isub=0    
  100 mint(51)=0    
    
C...Choice of process type - first event of overlay.    
      IF(mint(82).EQ.1.AND.(isub.LE.90.OR.isub.GT.96)) THEN 
        rsub=xsec(0,1)*rlu(0)   
        DO 110 i=1,200  
        IF(msub(i).NE.1) goto 110   
        isub=i  
        rsub=rsub-xsec(i,1) 
        IF(rsub.LE.0.) goto 120 
  110   CONTINUE    
  120   IF(isub.EQ.95) isub=96  
    
C...Choice of inclusive process type - overlayed events.    
      ELSEIF(mint(82).GE.2.AND.isub.EQ.0) THEN  
        rsub=vint(131)*rlu(0)   
        isub=96 
        IF(rsub.GT.vint(106)) isub=93   
        IF(rsub.GT.vint(106)+vint(104)) isub=92 
        IF(rsub.GT.vint(106)+vint(104)+vint(103)) isub=91   
      ENDIF 
      IF(mint(82).EQ.1) ngen(0,1)=ngen(0,1)+1   
      IF(mint(82).EQ.1) ngen(isub,1)=ngen(isub,1)+1 
      mint(1)=isub  
    
C...Find resonances (explicit or implicit in cross-section).    
      mint(72)=0    
      kfr1=0    
      IF(iset(isub).EQ.1.OR.iset(isub).EQ.3) THEN   
        kfr1=kfpr(isub,1)   
      ELSEIF(isub.GE.71.AND.isub.LE.77) THEN    
        kfr1=25 
      ENDIF 
      IF(kfr1.NE.0) THEN    
        taur1=pmas(kfr1,1)**2/vint(2)   
        gamr1=pmas(kfr1,1)*pmas(kfr1,2)/vint(2) 
        mint(72)=1  
        mint(73)=kfr1   
        vint(73)=taur1  
        vint(74)=gamr1  
      ENDIF 
      IF(isub.EQ.141) THEN  
        kfr2=23 
        taur2=pmas(kfr2,1)**2/vint(2)   
        gamr2=pmas(kfr2,1)*pmas(kfr2,2)/vint(2) 
        mint(72)=2  
        mint(74)=kfr2   
        vint(75)=taur2  
        vint(76)=gamr2  
      ENDIF 
    
C...Find product masses and minimum pT of process,  
C...optionally with broadening according to a truncated Breit-Wigner.   
      vint(63)=0.   
      vint(64)=0.   
      mint(71)=0    
      vint(71)=ckin(3)  
      IF(mint(82).GE.2) vint(71)=0. 
      IF(iset(isub).EQ.2.OR.iset(isub).EQ.4) THEN   
        DO 130 i=1,2    
        IF(kfpr(isub,i).EQ.0) THEN  
        ELSEIF(mstp(42).LE.0) THEN  
          vint(62+i)=pmas(kfpr(isub,i),1)**2    
        ELSE    
          vint(62+i)=ulmass(kfpr(isub,i))**2    
        ENDIF   
  130   CONTINUE    
        IF(min(vint(63),vint(64)).LT.ckin(6)**2) mint(71)=1 
        IF(mint(71).EQ.1) vint(71)=max(ckin(3),ckin(5)) 
      ENDIF 
    
      IF(iset(isub).EQ.0) THEN  
C...Double or single diffractive, or elastic scattering:    
C...choose m^2 according to 1/m^2 (diffractive), constant (elastic) 
        is=int(1.5+rlu(0))  
        vint(63)=vint(3)**2 
        vint(64)=vint(4)**2 
        IF(isub.EQ.92.OR.isub.EQ.93) vint(62+is)=parp(111)**2   
        IF(isub.EQ.93) vint(65-is)=parp(111)**2 
        sh=vint(2)  
        sqm1=vint(3)**2 
        sqm2=vint(4)**2 
        sqm3=vint(63)   
        sqm4=vint(64)   
        sqla12=(sh-sqm1-sqm2)**2-4.*sqm1*sqm2   
        sqla34=(sh-sqm3-sqm4)**2-4.*sqm3*sqm4   
        thter1=sqm1+sqm2+sqm3+sqm4-(sqm1-sqm2)*(sqm3-sqm4)/sh-sh    
        thter2=sqrt(max(0.,sqla12))*sqrt(max(0.,sqla34))/sh 
        thl=0.5*(thter1-thter2) 
        thu=0.5*(thter1+thter2) 
        thm=min(max(thl,parp(101)),thu) 
        jtmax=0 
        IF(isub.EQ.92.OR.isub.EQ.93) jtmax=isub-91  
        DO 140 jt=1,jtmax   
        mint(13+3*jt-is*(2*jt-3))=1 
        sqmmin=vint(59+3*jt-is*(2*jt-3))    
        sqmi=vint(8-3*jt+is*(2*jt-3))**2    
        sqmj=vint(3*jt-1-is*(2*jt-3))**2    
        sqmf=vint(68-3*jt+is*(2*jt-3))  
        squa=0.5*sh/sqmi*((1.+(sqmi-sqmj)/sh)*thm+sqmi-sqmf-    
     &  sqmj**2/sh+(sqmi+sqmj)*sqmf/sh+(sqmi-sqmj)**2/sh**2*sqmf)   
        quar=sh/sqmi*(thm*(thm+sh-sqmi-sqmj-sqmf*(1.-(sqmi-sqmj)/sh))+  
     &  sqmi*sqmj-sqmj*sqmf*(1.+(sqmi-sqmj-sqmf)/sh))   
        sqmmax=squa+sqrt(max(0.,squa**2-quar))  
        IF(abs(quar/squa**2).LT.1.e-06) sqmmax=0.5*quar/squa    
        sqmmax=min(sqmmax,(vint(1)-sqrt(sqmf))**2)  
        vint(59+3*jt-is*(2*jt-3))=sqmmin*(sqmmax/sqmmin)**rlu(0)    
  140   CONTINUE    
C...Choose t-hat according to exp(B*t-hat+C*t-hat^2).   
        sqm3=vint(63)   
        sqm4=vint(64)   
        sqla34=(sh-sqm3-sqm4)**2-4.*sqm3*sqm4   
        thter1=sqm1+sqm2+sqm3+sqm4-(sqm1-sqm2)*(sqm3-sqm4)/sh-sh    
        thter2=sqrt(max(0.,sqla12))*sqrt(max(0.,sqla34))/sh 
        thl=0.5*(thter1-thter2) 
        thu=0.5*(thter1+thter2) 
        b=vint(121) 
        c=vint(122) 
        IF(isub.EQ.92.OR.isub.EQ.93) THEN   
          b=0.5*b   
          c=0.5*c   
        ENDIF   
        thm=min(max(thl,parp(101)),thu) 
        expth=0.    
        tharg=b*(thm-thu)   
        IF(tharg.GT.-20.) expth=exp(tharg)  
  150   th=thu+log(expth+(1.-expth)*rlu(0))/b   
        th=max(thm,min(thu,th)) 
        ratlog=min((b+c*(th+thm))*(th-thm),(b+c*(th+thu))*(th-thu)) 
        IF(ratlog.LT.log(rlu(0))) goto 150  
        vint(21)=1. 
        vint(22)=0. 
        vint(23)=min(1.,max(-1.,(2.*th-thter1)/thter2)) 
    
C...Note: in the following, by In is meant the integral over the    
C...quantity multiplying coefficient cn.    
C...Choose tau according to h1(tau)/tau, where  
C...h1(tau) = c0 + I0/I1*c1*1/tau + I0/I2*c2*1/(tau+tau_R) +    
C...I0/I3*c3*tau/((s*tau-m^2)^2+(m*Gamma)^2) +  
C...I0/I4*c4*1/(tau+tau_R') +   
C...I0/I5*c5*tau/((s*tau-m'^2)^2+(m'*Gamma')^2), and    
C...c0 + c1 + c2 + c3 + c4 + c5 = 1 
      ELSEIF(iset(isub).GE.1.AND.iset(isub).LE.4) THEN  
        CALL pyklim(1)  
        IF(mint(51).NE.0) goto 100  
        rtau=rlu(0) 
        mtau=1  
        IF(rtau.GT.coef(isub,1)) mtau=2 
        IF(rtau.GT.coef(isub,1)+coef(isub,2)) mtau=3    
        IF(rtau.GT.coef(isub,1)+coef(isub,2)+coef(isub,3)) mtau=4   
        IF(rtau.GT.coef(isub,1)+coef(isub,2)+coef(isub,3)+coef(isub,4)) 
     &  mtau=5  
        IF(rtau.GT.coef(isub,1)+coef(isub,2)+coef(isub,3)+coef(isub,4)+ 
     &  coef(isub,5)) mtau=6    
        CALL pykmap(1,mtau,rlu(0))  
    
C...2 -> 3, 4 processes:    
C...Choose tau' according to h4(tau,tau')/tau', where   
C...h4(tau,tau') = c0 + I0/I1*c1*(1 - tau/tau')^3/tau', and 
C...c0 + c1 = 1.    
        IF(iset(isub).EQ.3.OR.iset(isub).EQ.4) THEN 
          CALL pyklim(4)    
          IF(mint(51).NE.0) goto 100    
          rtaup=rlu(0)  
          mtaup=1   
          IF(rtaup.GT.coef(isub,15)) mtaup=2    
          CALL pykmap(4,mtaup,rlu(0))   
        ENDIF   
    
C...Choose y* according to h2(y*), where    
C...h2(y*) = I0/I1*c1*(y*-y*min) + I0/I2*c2*(y*max-y*) +    
C...I0/I3*c3*1/cosh(y*), I0 = y*max-y*min, and c1 + c2 + c3 = 1.    
        CALL pyklim(2)  
        IF(mint(51).NE.0) goto 100  
        ryst=rlu(0) 
        myst=1  
        IF(ryst.GT.coef(isub,7)) myst=2 
        IF(ryst.GT.coef(isub,7)+coef(isub,8)) myst=3    
        CALL pykmap(2,myst,rlu(0))  
    
C...2 -> 2 processes:   
C...Choose cos(theta-hat) (cth) according to h3(cth), where 
C...h3(cth) = c0 + I0/I1*c1*1/(A - cth) + I0/I2*c2*1/(A + cth) +    
C...I0/I3*c3*1/(A - cth)^2 + I0/I4*c4*1/(A + cth)^2,    
C...A = 1 + 2*(m3*m4/sh)^2 (= 1 for massless products), 
C...and c0 + c1 + c2 + c3 + c4 = 1. 
        CALL pyklim(3)  
        IF(mint(51).NE.0) goto 100  
        IF(iset(isub).EQ.2.OR.iset(isub).EQ.4) THEN 
          rcth=rlu(0)   
          mcth=1    
          IF(rcth.GT.coef(isub,10)) mcth=2  
          IF(rcth.GT.coef(isub,10)+coef(isub,11)) mcth=3    
          IF(rcth.GT.coef(isub,10)+coef(isub,11)+coef(isub,12)) mcth=4  
          IF(rcth.GT.coef(isub,10)+coef(isub,11)+coef(isub,12)+ 
     &    coef(isub,13)) mcth=5 
          CALL pykmap(3,mcth,rlu(0))    
        ENDIF   
    
C...Low-pT or multiple interactions (first semihard interaction).   
      ELSEIF(iset(isub).EQ.5) THEN  
        CALL pymult(3)  
        isub=mint(1)    
      ENDIF 
    
C...Choose azimuthal angle. 
      vint(24)=paru(2)*rlu(0)   
    
C...Check against user cuts on kinematics at parton level.  
      mint(51)=0    
      IF(isub.LE.90.OR.isub.GT.100) CALL pyklim(0)  
      IF(mint(51).NE.0) goto 100    
      IF(mint(82).EQ.1.AND.mstp(141).GE.1) THEN 
        mcut=0  
        IF(msub(91)+msub(92)+msub(93)+msub(94)+msub(95).EQ.0)   
     &  CALL pykcut(mcut)   
        IF(mcut.NE.0) goto 100  
      ENDIF 
    
C...Calculate differential cross-section for different subprocesses.    
      CALL pysigh(nchn,sigs)    
    
C...Calculations for Monte Carlo estimate of all cross-sections.    
      IF(mint(82).EQ.1.AND.isub.LE.90.OR.isub.GE.96) THEN   
        xsec(isub,2)=xsec(isub,2)+sigs  
      ELSEIF(mint(82).EQ.1) THEN    
        xsec(isub,2)=xsec(isub,2)+xsec(isub,1)  
      ENDIF 
    
C...Multiple interactions: store results of cross-section calculation.  
      IF(mint(43).EQ.4.AND.mstp(82).GE.3) THEN  
        vint(153)=sigs  
        CALL pymult(4)  
      ENDIF 
    
C...Weighting using estimate of maximum of differential cross-section.  
      viol=sigs/xsec(isub,1)    
      IF(viol.LT.rlu(0)) goto 100   
    
C...Check for possible violation of estimated maximum of differential   
C...cross-section used in weighting.    
      IF(mstp(123).LE.0) THEN   
        IF(viol.GT.1.) THEN 
          WRITE(mstu(11),1000) viol,ngen(0,3)+1 
          WRITE(mstu(11),1100) isub,vint(21),vint(22),vint(23),vint(26) 
          stop  
        ENDIF   
      ELSEIF(mstp(123).EQ.1) THEN   
        IF(viol.GT.vint(108)) THEN  
          vint(108)=viol    
C          IF(VIOL.GT.1.) THEN   
C            WRITE(MSTU(11),1200) VIOL,NGEN(0,3)+1   
C            WRITE(MSTU(11),1100) ISUB,VINT(21),VINT(22),VINT(23),   
C     &      VINT(26)    
C          ENDIF 
        ENDIF   
      ELSEIF(viol.GT.vint(108)) THEN    
        vint(108)=viol  
        IF(viol.GT.1.) THEN 
          xdif=xsec(isub,1)*(viol-1.)   
          xsec(isub,1)=xsec(isub,1)+xdif    
          IF(msub(isub).EQ.1.AND.(isub.LE.90.OR.isub.GT.96))    
     &    xsec(0,1)=xsec(0,1)+xdif  
C          WRITE(MSTU(11),1200) VIOL,NGEN(0,3)+1 
C          WRITE(MSTU(11),1100) ISUB,VINT(21),VINT(22),VINT(23),VINT(26) 
C          IF(ISUB.LE.9) THEN    
C            WRITE(MSTU(11),1300) ISUB,XSEC(ISUB,1)  
C          ELSEIF(ISUB.LE.99) THEN   
C            WRITE(MSTU(11),1400) ISUB,XSEC(ISUB,1)  
C          ELSE  
C            WRITE(MSTU(11),1500) ISUB,XSEC(ISUB,1)  
C          ENDIF 
          vint(108)=1.  
        ENDIF   
      ENDIF 
    
C...Multiple interactions: choose impact parameter. 
      vint(148)=1.  
      IF(mint(43).EQ.4.AND.(isub.LE.90.OR.isub.GE.96).AND.mstp(82).GE.3)    
     &THEN  
        CALL pymult(5)  
        IF(vint(150).LT.rlu(0)) goto 100    
      ENDIF 
      IF(mint(82).EQ.1.AND.msub(95).EQ.1) THEN  
        IF(isub.LE.90.OR.isub.GE.95) ngen(95,1)=ngen(95,1)+1    
        IF(isub.LE.90.OR.isub.GE.96) ngen(96,2)=ngen(96,2)+1    
      ENDIF 
      IF(isub.LE.90.OR.isub.GE.96) mint(31)=mint(31)+1  
    
C...Choose flavour of reacting partons (and subprocess).    
      rsigs=sigs*rlu(0) 
      qt2=vint(48)  
      rqqbar=parp(87)*(1.-(qt2/(qt2+(parp(88)*parp(82))**2))**2)    
      IF(isub.NE.95.AND.(isub.NE.96.OR.mstp(82).LE.1.OR.    
     &rlu(0).GT.rqqbar)) THEN   
        DO 190 ichn=1,nchn  
        kfl1=isig(ichn,1)   
        kfl2=isig(ichn,2)   
        mint(2)=isig(ichn,3)    
        rsigs=rsigs-sigh(ichn)  
        IF(rsigs.LE.0.) goto 210    
  190   CONTINUE    
    
C...Multiple interactions: choose qqbar preferentially at small pT. 
      ELSEIF(isub.EQ.96) THEN   
        CALL pyspli(mint(11),21,kfl1,kfldum)    
        CALL pyspli(mint(12),21,kfl2,kfldum)    
        mint(1)=11  
        mint(2)=1   
        IF(kfl1.EQ.kfl2.AND.rlu(0).LT.0.5) mint(2)=2    
    
C...Low-pT: choose string drawing configuration.    
      ELSE  
        kfl1=21 
        kfl2=21 
        rsigs=6.*rlu(0) 
        mint(2)=1   
        IF(rsigs.GT.1.) mint(2)=2   
        IF(rsigs.GT.2.) mint(2)=3   
      ENDIF 
    
C...Reassign QCD process. Partons before initial state radiation.   
  210 IF(mint(2).GT.10) THEN    
        mint(1)=mint(2)/10  
        mint(2)=mod(mint(2),10) 
      ENDIF 
      mint(15)=kfl1 
      mint(16)=kfl2 
      mint(13)=mint(15) 
      mint(14)=mint(16) 
      vint(141)=vint(41)    
      vint(142)=vint(42)    
    
C...Format statements for differential cross-section maximum violations.    
 1000 FORMAT(1x,'Error: maximum violated by',1p,e11.3,1x,   
     &'in event',1x,i7,'.'/1x,'Execution stopped!') 
 1100 FORMAT(1x,'ISUB = ',i3,'; Point of violation:'/1x,'tau =',1p, 
     &e11.3,', y* =',e11.3,', cthe = ',0p,f11.7,', tau'' =',1p,e11.3)   
 1200 FORMAT(1x,'Warning: maximum violated by',1p,e11.3,1x, 
     &'in event',1x,i7) 
 1300 FORMAT(1x,'XSEC(',i1,',1) increased to',1p,e11.3) 
 1400 FORMAT(1x,'XSEC(',i2,',1) increased to',1p,e11.3) 
 1500 FORMAT(1x,'XSEC(',i3,',1) increased to',1p,e11.3) 
    
      RETURN    
      END   
    
C*********************************************************************  
    
      SUBROUTINE pyscat 
    
C...Finds outgoing flavours and event type; sets up the kinematics  
C...and colour flow of the hard scattering. 
      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/ludat2/kchg(500,3),pmas(500,4),parf(2000),vckm(4,4)    
      SAVE /ludat2/ 
      common/ludat3/mdcy(500,3),mdme(2000,2),brat(2000),kfdp(2000,5)    
      SAVE /ludat3/ 
      common/pysubs/msel,msub(200),kfin(2,-40:40),ckin(200) 
      SAVE /pysubs/ 
      common/pypars/mstp(200),parp(200),msti(200),pari(200) 
      SAVE /pypars/ 
      common/pyint1/mint(400),vint(400) 
      SAVE /pyint1/ 
      common/pyint2/iset(200),kfpr(200,2),coef(200,20),icol(40,4,2) 
      SAVE /pyint2/ 
      common/pyint3/xsfx(2,-40:40),isig(1000,3),sigh(1000)  
      SAVE /pyint3/ 
      common/pyint4/widp(21:40,0:40),wide(21:40,0:40),wids(21:40,3) 
      SAVE /pyint4/ 
      common/pyint5/ngen(0:200,3),xsec(0:200,3) 
      SAVE /pyint5/ 
      dimension wdtp(0:40),wdte(0:40,0:5),pmq(2),z(2),cthe(2),phi(2)    
    
C...Choice of subprocess, number of documentation lines.    
      isub=mint(1)  
      idoc=6+iset(isub) 
      IF(isub.EQ.95) idoc=8 
      mint(3)=idoc-6    
      IF(idoc.GE.9) idoc=idoc+2 
      mint(4)=idoc  
      ipu1=mint(84)+1   
      ipu2=mint(84)+2   
      ipu3=mint(84)+3   
      ipu4=mint(84)+4   
      ipu5=mint(84)+5   
      ipu6=mint(84)+6   
    
C...Reset K, P and V vectors. Store incoming particles. 
      DO 100 jt=1,mstp(126)+10  
      i=mint(83)+jt 
      DO 100 j=1,5  
      k(i,j)=0  
      p(i,j)=0. 
  100 v(i,j)=0. 
      DO 110 jt=1,2 
      i=mint(83)+jt 
      k(i,1)=21 
      k(i,2)=mint(10+jt)    
      p(i,1)=0. 
      p(i,2)=0. 
      p(i,5)=vint(2+jt) 
      p(i,3)=vint(5)*(-1)**(jt+1)   
  110 p(i,4)=sqrt(p(i,3)**2+p(i,5)**2)  
      mint(6)=2 
      kfres=0   
    
C...Store incoming partons in their CM-frame.   
      sh=vint(44)   
      shr=sqrt(sh)  
      shp=vint(26)*vint(2)  
      shpr=sqrt(shp)    
      shuser=shr    
      IF(iset(isub).GE.3) shuser=shpr   
      DO 120 jt=1,2 
      i=mint(84)+jt 
      k(i,1)=14 
      k(i,2)=mint(14+jt)    
      k(i,3)=mint(83)+2+jt  
  120 p(i,5)=ulmass(k(i,2)) 
      IF(p(ipu1,5)+p(ipu2,5).GE.shuser) THEN    
        p(ipu1,5)=0.    
        p(ipu2,5)=0.    
      ENDIF 
      p(ipu1,4)=0.5*(shuser+(p(ipu1,5)**2-p(ipu2,5)**2)/shuser) 
      p(ipu1,3)=sqrt(max(0.,p(ipu1,4)**2-p(ipu1,5)**2)) 
      p(ipu2,4)=shuser-p(ipu1,4)    
      p(ipu2,3)=-p(ipu1,3)  
    
C...Copy incoming partons to documentation lines.   
      DO 130 jt=1,2 
      i1=mint(83)+4+jt  
      i2=mint(84)+jt    
      k(i1,1)=21    
      k(i1,2)=k(i2,2)   
      k(i1,3)=i1-2  
      DO 130 j=1,5  
  130 p(i1,j)=p(i2,j)   
    
C...Choose new quark flavour for relevant annihilation graphs.  
      IF(isub.EQ.12.OR.isub.EQ.53) THEN 
        CALL pywidt(21,shr,wdtp,wdte)   
        rkfl=(wdte(0,1)+wdte(0,2)+wdte(0,4))*rlu(0) 
        DO 140 i=1,2*mstp(1)    
        kflq=i  
        rkfl=rkfl-(wdte(i,1)+wdte(i,2)+wdte(i,4))   
        IF(rkfl.LE.0.) goto 150 
  140   CONTINUE    
  150   CONTINUE    
      ENDIF 
    
C...Final state flavours and colour flow: default values.   
      js=1  
      mint(21)=mint(15) 
      mint(22)=mint(16) 
      mint(23)=0    
      mint(24)=0    
      kcc=20    
      kcs=isign(1,mint(15)) 
    
      IF(isub.LE.10) THEN   
      IF(isub.EQ.1) THEN    
C...f + fb -> gamma*/Z0.    
        kfres=23    
    
      ELSEIF(isub.EQ.2) THEN    
C...f + fb' -> W+/- .   
        kch1=kchg(iabs(mint(15)),1)*isign(1,mint(15))   
        kch2=kchg(iabs(mint(16)),1)*isign(1,mint(16))   
        kfres=isign(24,kch1+kch2)   
    
      ELSEIF(isub.EQ.3) THEN    
C...f + fb -> H0.   
        kfres=25    
    
      ELSEIF(isub.EQ.4) THEN    
C...gamma + W+/- -> W+/-.   
    
      ELSEIF(isub.EQ.5) THEN    
C...Z0 + Z0 -> H0.  
        xh=sh/shp   
        mint(21)=mint(15)   
        mint(22)=mint(16)   
        pmq(1)=ulmass(mint(21)) 
        pmq(2)=ulmass(mint(22)) 
  240   jt=int(1.5+rlu(0))  
        zmin=2.*pmq(jt)/shpr    
        zmax=1.-pmq(3-jt)/shpr-(sh-pmq(jt)**2)/(shpr*(shpr-pmq(3-jt)))  
        zmax=min(1.-xh,zmax)    
        z(jt)=zmin+(zmax-zmin)*rlu(0)   
        IF(-1.+(1.+xh)/(1.-z(jt))-xh/(1.-z(jt))**2.LT.  
     &  (1.-xh)**2/(4.*xh)*rlu(0)) goto 240 
        sqc1=1.-4.*pmq(jt)**2/(z(jt)**2*shp)    
        IF(sqc1.LT.1.e-8) goto 240  
        c1=sqrt(sqc1)   
        c2=1.+2.*(pmas(23,1)**2-pmq(jt)**2)/(z(jt)*shp) 
        cthe(jt)=(c2-(c2**2-c1**2)/(c2+(2.*rlu(0)-1.)*c1))/c1   
        cthe(jt)=min(1.,max(-1.,cthe(jt)))  
        z(3-jt)=1.-xh/(1.-z(jt))    
        sqc1=1.-4.*pmq(3-jt)**2/(z(3-jt)**2*shp)    
        IF(sqc1.LT.1.e-8) goto 240  
        c1=sqrt(sqc1)   
        c2=1.+2.*(pmas(23,1)**2-pmq(3-jt)**2)/(z(3-jt)*shp) 
        cthe(3-jt)=(c2-(c2**2-c1**2)/(c2+(2.*rlu(0)-1.)*c1))/c1 
        cthe(3-jt)=min(1.,max(-1.,cthe(3-jt)))  
        phir=paru(2)*rlu(0) 
        cphi=cos(phir)  
        ang=cthe(1)*cthe(2)-sqrt(1.-cthe(1)**2)*sqrt(1.-cthe(2)**2)*cphi    
        z1=2.-z(jt) 
        z2=ang*sqrt(z(jt)**2-4.*pmq(jt)**2/shp) 
        z3=1.-z(jt)-xh+(pmq(1)**2+pmq(2)**2)/shp    
        z(3-jt)=2./(z1**2-z2**2)*(z1*z3+z2*sqrt(z3**2-(z1**2-z2**2)*    
     &  pmq(3-jt)**2/shp))  
        zmin=2.*pmq(3-jt)/shpr  
        zmax=1.-pmq(jt)/shpr-(sh-pmq(3-jt)**2)/(shpr*(shpr-pmq(jt)))    
        zmax=min(1.-xh,zmax)    
        IF(z(3-jt).LT.zmin.OR.z(3-jt).GT.zmax) goto 240 
        kcc=22  
        kfres=25    
    
      ELSEIF(isub.EQ.6) THEN    
C...Z0 + W+/- -> W+/-.  
    
      ELSEIF(isub.EQ.7) THEN    
C...W+ + W- -> Z0.  
    
      ELSEIF(isub.EQ.8) THEN    
C...W+ + W- -> H0.  
        xh=sh/shp   
  250   DO 280 jt=1,2   
        i=mint(14+jt)   
        ia=iabs(i)  
        IF(ia.LE.10) THEN   
          rvckm=vint(180+i)*rlu(0)  
          DO 270 j=1,mstp(1)    
          ib=2*j-1+mod(ia,2)    
          ipm=(5-isign(1,i))/2  
          idc=j+mdcy(ia,2)+2    
          IF(mdme(idc,1).NE.1.AND.mdme(idc,1).NE.ipm) goto 270  
          mint(20+jt)=isign(ib,i)   
          rvckm=rvckm-vckm((ia+1)/2,(ib+1)/2)   
          IF(rvckm.LE.0.) goto 280  
  270     CONTINUE  
        ELSE    
          ib=2*((ia+1)/2)-1+mod(ia,2)   
          mint(20+jt)=isign(ib,i)   
        ENDIF   
  280   pmq(jt)=ulmass(mint(20+jt)) 
        jt=int(1.5+rlu(0))  
        zmin=2.*pmq(jt)/shpr    
        zmax=1.-pmq(3-jt)/shpr-(sh-pmq(jt)**2)/(shpr*(shpr-pmq(3-jt)))  
        zmax=min(1.-xh,zmax)    
        z(jt)=zmin+(zmax-zmin)*rlu(0)   
        IF(-1.+(1.+xh)/(1.-z(jt))-xh/(1.-z(jt))**2.LT.  
     &  (1.-xh)**2/(4.*xh)*rlu(0)) goto 250 
        sqc1=1.-4.*pmq(jt)**2/(z(jt)**2*shp)    
        IF(sqc1.LT.1.e-8) goto 250  
        c1=sqrt(sqc1)   
        c2=1.+2.*(pmas(24,1)**2-pmq(jt)**2)/(z(jt)*shp) 
        cthe(jt)=(c2-(c2**2-c1**2)/(c2+(2.*rlu(0)-1.)*c1))/c1   
        cthe(jt)=min(1.,max(-1.,cthe(jt)))  
        z(3-jt)=1.-xh/(1.-z(jt))    
        sqc1=1.-4.*pmq(3-jt)**2/(z(3-jt)**2*shp)    
        IF(sqc1.LT.1.e-8) goto 250  
        c1=sqrt(sqc1)   
        c2=1.+2.*(pmas(24,1)**2-pmq(3-jt)**2)/(z(3-jt)*shp) 
        cthe(3-jt)=(c2-(c2**2-c1**2)/(c2+(2.*rlu(0)-1.)*c1))/c1 
        cthe(3-jt)=min(1.,max(-1.,cthe(3-jt)))  
        phir=paru(2)*rlu(0) 
        cphi=cos(phir)  
        ang=cthe(1)*cthe(2)-sqrt(1.-cthe(1)**2)*sqrt(1.-cthe(2)**2)*cphi    
        z1=2.-z(jt) 
        z2=ang*sqrt(z(jt)**2-4.*pmq(jt)**2/shp) 
        z3=1.-z(jt)-xh+(pmq(1)**2+pmq(2)**2)/shp    
        z(3-jt)=2./(z1**2-z2**2)*(z1*z3+z2*sqrt(z3**2-(z1**2-z2**2)*    
     &  pmq(3-jt)**2/shp))  
        zmin=2.*pmq(3-jt)/shpr  
        zmax=1.-pmq(jt)/shpr-(sh-pmq(3-jt)**2)/(shpr*(shpr-pmq(jt)))    
        zmax=min(1.-xh,zmax)    
        IF(z(3-jt).LT.zmin.OR.z(3-jt).GT.zmax) goto 250 
        kcc=22  
        kfres=25    
      ENDIF 
    
      ELSEIF(isub.LE.20) THEN   
      IF(isub.EQ.11) THEN   
C...f + f' -> f + f'; th = (p(f)-p(f))**2.  
        kcc=mint(2) 
        IF(mint(15)*mint(16).LT.0) kcc=kcc+2    
    
      ELSEIF(isub.EQ.12) THEN   
C...f + fb -> f' + fb'; th = (p(f)-p(f'))**2.   
        mint(21)=isign(kflq,mint(15))   
        mint(22)=-mint(21)  
        kcc=4   
    
      ELSEIF(isub.EQ.13) THEN   
C...f + fb -> g + g; th arbitrary.  
        mint(21)=21 
        mint(22)=21 
        kcc=mint(2)+4   
    
      ELSEIF(isub.EQ.14) THEN   
C...f + fb -> g + gam; th arbitrary.    
        IF(rlu(0).GT.0.5) js=2  
        mint(20+js)=21  
        mint(23-js)=22  
        kcc=17+js   
    
      ELSEIF(isub.EQ.15) THEN   
C...f + fb -> g + Z0; th arbitrary. 
        IF(rlu(0).GT.0.5) js=2  
        mint(20+js)=21  
        mint(23-js)=23  
        kcc=17+js   
    
      ELSEIF(isub.EQ.16) THEN   
C...f + fb' -> g + W+/-; th = (p(f)-p(W-))**2 or (p(fb')-p(W+))**2. 
        kch1=kchg(iabs(mint(15)),1)*isign(1,mint(15))   
        kch2=kchg(iabs(mint(16)),1)*isign(1,mint(16))   
        IF(mint(15)*(kch1+kch2).LT.0) js=2  
        mint(20+js)=21  
        mint(23-js)=isign(24,kch1+kch2) 
        kcc=17+js   
    
      ELSEIF(isub.EQ.17) THEN   
C...f + fb -> g + H0; th arbitrary. 
        IF(rlu(0).GT.0.5) js=2  
        mint(20+js)=21  
        mint(23-js)=25  
        kcc=17+js   
    
      ELSEIF(isub.EQ.18) THEN   
C...f + fb -> gamma + gamma; th arbitrary.  
        mint(21)=22 
        mint(22)=22 
    
      ELSEIF(isub.EQ.19) THEN   
C...f + fb -> gamma + Z0; th arbitrary. 
        IF(rlu(0).GT.0.5) js=2  
        mint(20+js)=22  
        mint(23-js)=23  
    
      ELSEIF(isub.EQ.20) THEN   
C...f + fb' -> gamma + W+/-; th = (p(f)-p(W-))**2 or (p(fb')-p(W+))**2. 
        kch1=kchg(iabs(mint(15)),1)*isign(1,mint(15))   
        kch2=kchg(iabs(mint(16)),1)*isign(1,mint(16))   
        IF(mint(15)*(kch1+kch2).LT.0) js=2  
        mint(20+js)=22  
        mint(23-js)=isign(24,kch1+kch2) 
      ENDIF 
    
      ELSEIF(isub.LE.30) THEN   
      IF(isub.EQ.21) THEN   
C...f + fb -> gamma + H0; th arbitrary. 
        IF(rlu(0).GT.0.5) js=2  
        mint(20+js)=22  
        mint(23-js)=25  
    
      ELSEIF(isub.EQ.22) THEN   
C...f + fb -> Z0 + Z0; th arbitrary.    
        mint(21)=23 
        mint(22)=23 
    
      ELSEIF(isub.EQ.23) THEN   
C...f + fb' -> Z0 + W+/-; th = (p(f)-p(W-))**2 or (p(fb')-p(W+))**2.    
        kch1=kchg(iabs(mint(15)),1)*isign(1,mint(15))   
        kch2=kchg(iabs(mint(16)),1)*isign(1,mint(16))   
        IF(mint(15)*(kch1+kch2).LT.0) js=2  
        mint(20+js)=23  
        mint(23-js)=isign(24,kch1+kch2) 
    
      ELSEIF(isub.EQ.24) THEN   
C...f + fb -> Z0 + H0; th arbitrary.    
        IF(rlu(0).GT.0.5) js=2  
        mint(20+js)=23  
        mint(23-js)=25  
    
      ELSEIF(isub.EQ.25) THEN   
C...f + fb -> W+ + W-; th = (p(f)-p(W-))**2.    
        mint(21)=-isign(24,mint(15))    
        mint(22)=-mint(21)  
    
      ELSEIF(isub.EQ.26) THEN   
C...f + fb' -> W+/- + H0; th = (p(f)-p(W-))**2 or (p(fb')-p(W+))**2.    
        kch1=kchg(iabs(mint(15)),1)*isign(1,mint(15))   
        kch2=kchg(iabs(mint(16)),1)*isign(1,mint(16))   
        IF(mint(15)*(kch1+kch2).GT.0) js=2  
        mint(20+js)=isign(24,kch1+kch2) 
        mint(23-js)=25  
    
      ELSEIF(isub.EQ.27) THEN   
C...f + fb -> H0 + H0.  
    
      ELSEIF(isub.EQ.28) THEN   
C...f + g -> f + g; th = (p(f)-p(f))**2.    
        kcc=mint(2)+6   
        IF(mint(15).EQ.21) kcc=kcc+2    
        IF(mint(15).NE.21) kcs=isign(1,mint(15))    
        IF(mint(16).NE.21) kcs=isign(1,mint(16))    
    
      ELSEIF(isub.EQ.29) THEN   
C...f + g -> f + gamma; th = (p(f)-p(f))**2.    
        IF(mint(15).EQ.21) js=2 
        mint(23-js)=22  
        kcc=15+js   
        kcs=isign(1,mint(14+js))    
    
      ELSEIF(isub.EQ.30) THEN   
C...f + g -> f + Z0; th = (p(f)-p(f))**2.   
        IF(mint(15).EQ.21) js=2 
        mint(23-js)=23  
        kcc=15+js   
        kcs=isign(1,mint(14+js))    
      ENDIF 
    
      ELSEIF(isub.LE.40) THEN   
      IF(isub.EQ.31) THEN   
C...f + g -> f' + W+/-; th = (p(f)-p(f'))**2; choose flavour f'.    
        IF(mint(15).EQ.21) js=2 
        i=mint(14+js)   
        ia=iabs(i)  
        mint(23-js)=isign(24,kchg(ia,1)*i)  
        rvckm=vint(180+i)*rlu(0)    
        DO 220 j=1,mstp(1)  
        ib=2*j-1+mod(ia,2)  
        ipm=(5-isign(1,i))/2    
        idc=j+mdcy(ia,2)+2  
        IF(mdme(idc,1).NE.1.AND.mdme(idc,1).NE.ipm) goto 220    
        mint(20+js)=isign(ib,i) 
        rvckm=rvckm-vckm((ia+1)/2,(ib+1)/2) 
        IF(rvckm.LE.0.) goto 230    
  220   CONTINUE    
  230   kcc=15+js   
        kcs=isign(1,mint(14+js))    
    
      ELSEIF(isub.EQ.32) THEN   
C...f + g -> f + H0; th = (p(f)-p(f))**2.   
        IF(mint(15).EQ.21) js=2 
        mint(23-js)=25  
        kcc=15+js   
        kcs=isign(1,mint(14+js))    
    
      ELSEIF(isub.EQ.33) THEN   
C...f + gamma -> f + g. 
    
      ELSEIF(isub.EQ.34) THEN   
C...f + gamma -> f + gamma. 
    
      ELSEIF(isub.EQ.35) THEN   
C...f + gamma -> f + Z0.    
    
      ELSEIF(isub.EQ.36) THEN   
C...f + gamma -> f' + W+/-. 
    
      ELSEIF(isub.EQ.37) THEN   
C...f + gamma -> f + H0.    
    
      ELSEIF(isub.EQ.38) THEN   
C...f + Z0 -> f + g.    
    
      ELSEIF(isub.EQ.39) THEN   
C...f + Z0 -> f + gamma.    
    
      ELSEIF(isub.EQ.40) THEN   
C...f + Z0 -> f + Z0.   
      ENDIF 
    
      ELSEIF(isub.LE.50) THEN   
      IF(isub.EQ.41) THEN   
C...f + Z0 -> f' + W+/-.    
    
      ELSEIF(isub.EQ.42) THEN   
C...f + Z0 -> f + H0.   
    
      ELSEIF(isub.EQ.43) THEN   
C...f + W+/- -> f' + g. 
    
      ELSEIF(isub.EQ.44) THEN   
C...f + W+/- -> f' + gamma. 
    
      ELSEIF(isub.EQ.45) THEN   
C...f + W+/- -> f' + Z0.    
    
      ELSEIF(isub.EQ.46) THEN   
C...f + W+/- -> f' + W+/-.  
    
      ELSEIF(isub.EQ.47) THEN   
C...f + W+/- -> f' + H0.    
    
      ELSEIF(isub.EQ.48) THEN   
C...f + H0 -> f + g.    
    
      ELSEIF(isub.EQ.49) THEN   
C...f + H0 -> f + gamma.    
    
      ELSEIF(isub.EQ.50) THEN   
C...f + H0 -> f + Z0.   
      ENDIF 
    
      ELSEIF(isub.LE.60) THEN   
      IF(isub.EQ.51) THEN   
C...f + H0 -> f' + W+/-.    
    
      ELSEIF(isub.EQ.52) THEN   
C...f + H0 -> f + H0.   
    
      ELSEIF(isub.EQ.53) THEN   
C...g + g -> f + fb; th arbitrary.  
        kcs=(-1)**int(1.5+rlu(0))   
        mint(21)=isign(kflq,kcs)    
        mint(22)=-mint(21)  
        kcc=mint(2)+10  
    
      ELSEIF(isub.EQ.54) THEN   
C...g + gamma -> f + fb.    
    
      ELSEIF(isub.EQ.55) THEN   
C...g + Z0 -> f + fb.   
    
      ELSEIF(isub.EQ.56) THEN   
C...g + W+/- -> f + fb'.    
    
      ELSEIF(isub.EQ.57) THEN   
C...g + H0 -> f + fb.   
    
      ELSEIF(isub.EQ.58) THEN   
C...gamma + gamma -> f + fb.    
    
      ELSEIF(isub.EQ.59) THEN   
C...gamma + Z0 -> f + fb.   
    
      ELSEIF(isub.EQ.60) THEN   
C...gamma + W+/- -> f + fb'.    
      ENDIF 
    
      ELSEIF(isub.LE.70) THEN   
      IF(isub.EQ.61) THEN   
C...gamma + H0 -> f + fb.   
    
      ELSEIF(isub.EQ.62) THEN   
C...Z0 + Z0 -> f + fb.  
    
      ELSEIF(isub.EQ.63) THEN   
C...Z0 + W+/- -> f + fb'.   
    
      ELSEIF(isub.EQ.64) THEN   
C...Z0 + H0 -> f + fb.  
    
      ELSEIF(isub.EQ.65) THEN   
C...W+ + W- -> f + fb.  
    
      ELSEIF(isub.EQ.66) THEN   
C...W+/- + H0 -> f + fb'.   
    
      ELSEIF(isub.EQ.67) THEN   
C...H0 + H0 -> f + fb.  
    
      ELSEIF(isub.EQ.68) THEN   
C...g + g -> g + g; th arbitrary.   
        kcc=mint(2)+12  
        kcs=(-1)**int(1.5+rlu(0))   
    
      ELSEIF(isub.EQ.69) THEN   
C...gamma + gamma -> W+ + W-.   
    
      ELSEIF(isub.EQ.70) THEN   
C...gamma + W+/- -> gamma + W+/-    
      ENDIF 
    
      ELSEIF(isub.LE.80) THEN   
      IF(isub.EQ.71.OR.isub.EQ.72) THEN 
C...Z0 + Z0 -> Z0 + Z0; Z0 + Z0 -> W+ + W-. 
        xh=sh/shp   
        mint(21)=mint(15)   
        mint(22)=mint(16)   
        pmq(1)=ulmass(mint(21)) 
        pmq(2)=ulmass(mint(22)) 
  290   jt=int(1.5+rlu(0))  
        zmin=2.*pmq(jt)/shpr    
        zmax=1.-pmq(3-jt)/shpr-(sh-pmq(jt)**2)/(shpr*(shpr-pmq(3-jt)))  
        zmax=min(1.-xh,zmax)    
        z(jt)=zmin+(zmax-zmin)*rlu(0)   
        IF(-1.+(1.+xh)/(1.-z(jt))-xh/(1.-z(jt))**2.LT.  
     &  (1.-xh)**2/(4.*xh)*rlu(0)) goto 290 
        sqc1=1.-4.*pmq(jt)**2/(z(jt)**2*shp)    
        IF(sqc1.LT.1.e-8) goto 290  
        c1=sqrt(sqc1)   
        c2=1.+2.*(pmas(23,1)**2-pmq(jt)**2)/(z(jt)*shp) 
        cthe(jt)=(c2-(c2**2-c1**2)/(c2+(2.*rlu(0)-1.)*c1))/c1   
        cthe(jt)=min(1.,max(-1.,cthe(jt)))  
        z(3-jt)=1.-xh/(1.-z(jt))    
        sqc1=1.-4.*pmq(3-jt)**2/(z(3-jt)**2*shp)    
        IF(sqc1.LT.1.e-8) goto 290  
        c1=sqrt(sqc1)   
        c2=1.+2.*(pmas(23,1)**2-pmq(3-jt)**2)/(z(3-jt)*shp) 
        cthe(3-jt)=(c2-(c2**2-c1**2)/(c2+(2.*rlu(0)-1.)*c1))/c1 
        cthe(3-jt)=min(1.,max(-1.,cthe(3-jt)))  
        phir=paru(2)*rlu(0) 
        cphi=cos(phir)  
        ang=cthe(1)*cthe(2)-sqrt(1.-cthe(1)**2)*sqrt(1.-cthe(2)**2)*cphi    
        z1=2.-z(jt) 
        z2=ang*sqrt(z(jt)**2-4.*pmq(jt)**2/shp) 
        z3=1.-z(jt)-xh+(pmq(1)**2+pmq(2)**2)/shp    
        z(3-jt)=2./(z1**2-z2**2)*(z1*z3+z2*sqrt(z3**2-(z1**2-z2**2)*    
     &  pmq(3-jt)**2/shp))  
        zmin=2.*pmq(3-jt)/shpr  
        zmax=1.-pmq(jt)/shpr-(sh-pmq(3-jt)**2)/(shpr*(shpr-pmq(jt)))    
        zmax=min(1.-xh,zmax)    
        IF(z(3-jt).LT.zmin.OR.z(3-jt).GT.zmax) goto 290 
        kcc=22  
    
      ELSEIF(isub.EQ.73) THEN   
C...Z0 + W+/- -> Z0 + W+/-. 
        xh=sh/shp   
  300   jt=int(1.5+rlu(0))  
        i=mint(14+jt)   
        ia=iabs(i)  
        IF(ia.LE.10) THEN   
          rvckm=vint(180+i)*rlu(0)  
          DO 320 j=1,mstp(1)    
          ib=2*j-1+mod(ia,2)    
          ipm=(5-isign(1,i))/2  
          idc=j+mdcy(ia,2)+2    
          IF(mdme(idc,1).NE.1.AND.mdme(idc,1).NE.ipm) goto 320  
          mint(20+jt)=isign(ib,i)   
          rvckm=rvckm-vckm((ia+1)/2,(ib+1)/2)   
          IF(rvckm.LE.0.) goto 330  
  320     CONTINUE  
        ELSE    
          ib=2*((ia+1)/2)-1+mod(ia,2)   
          mint(20+jt)=isign(ib,i)   
        ENDIF   
  330   pmq(jt)=ulmass(mint(20+jt)) 
        mint(23-jt)=mint(17-jt) 
        pmq(3-jt)=ulmass(mint(23-jt))   
        jt=int(1.5+rlu(0))  
        zmin=2.*pmq(jt)/shpr    
        zmax=1.-pmq(3-jt)/shpr-(sh-pmq(jt)**2)/(shpr*(shpr-pmq(3-jt)))  
        zmax=min(1.-xh,zmax)    
        z(jt)=zmin+(zmax-zmin)*rlu(0)   
        IF(-1.+(1.+xh)/(1.-z(jt))-xh/(1.-z(jt))**2.LT.  
     &  (1.-xh)**2/(4.*xh)*rlu(0)) goto 300 
        sqc1=1.-4.*pmq(jt)**2/(z(jt)**2*shp)    
        IF(sqc1.LT.1.e-8) goto 300  
        c1=sqrt(sqc1)   
        c2=1.+2.*(pmas(23,1)**2-pmq(jt)**2)/(z(jt)*shp) 
        cthe(jt)=(c2-(c2**2-c1**2)/(c2+(2.*rlu(0)-1.)*c1))/c1   
        cthe(jt)=min(1.,max(-1.,cthe(jt)))  
        z(3-jt)=1.-xh/(1.-z(jt))    
        sqc1=1.-4.*pmq(3-jt)**2/(z(3-jt)**2*shp)    
        IF(sqc1.LT.1.e-8) goto 300  
        c1=sqrt(sqc1)   
        c2=1.+2.*(pmas(23,1)**2-pmq(3-jt)**2)/(z(3-jt)*shp) 
        cthe(3-jt)=(c2-(c2**2-c1**2)/(c2+(2.*rlu(0)-1.)*c1))/c1 
        cthe(3-jt)=min(1.,max(-1.,cthe(3-jt)))  
        phir=paru(2)*rlu(0) 
        cphi=cos(phir)  
        ang=cthe(1)*cthe(2)-sqrt(1.-cthe(1)**2)*sqrt(1.-cthe(2)**2)*cphi    
        z1=2.-z(jt) 
        z2=ang*sqrt(z(jt)**2-4.*pmq(jt)**2/shp) 
        z3=1.-z(jt)-xh+(pmq(1)**2+pmq(2)**2)/shp    
        z(3-jt)=2./(z1**2-z2**2)*(z1*z3+z2*sqrt(z3**2-(z1**2-z2**2)*    
     &  pmq(3-jt)**2/shp))  
        zmin=2.*pmq(3-jt)/shpr  
        zmax=1.-pmq(jt)/shpr-(sh-pmq(3-jt)**2)/(shpr*(shpr-pmq(jt)))    
        zmax=min(1.-xh,zmax)    
        IF(z(3-jt).LT.zmin.OR.z(3-jt).GT.zmax) goto 300 
        kcc=22  
    
      ELSEIF(isub.EQ.74) THEN   
C...Z0 + H0 -> Z0 + H0. 
    
      ELSEIF(isub.EQ.75) THEN   
C...W+ + W- -> gamma + gamma.   
    
      ELSEIF(isub.EQ.76.OR.isub.EQ.77) THEN 
C...W+ + W- -> Z0 + Z0; W+ + W- -> W+ + W-. 
        xh=sh/shp   
  340   DO 370 jt=1,2   
        i=mint(14+jt)   
        ia=iabs(i)  
        IF(ia.LE.10) THEN   
          rvckm=vint(180+i)*rlu(0)  
          DO 360 j=1,mstp(1)    
          ib=2*j-1+mod(ia,2)    
          ipm=(5-isign(1,i))/2  
          idc=j+mdcy(ia,2)+2    
          IF(mdme(idc,1).NE.1.AND.mdme(idc,1).NE.ipm) goto 360  
          mint(20+jt)=isign(ib,i)   
          rvckm=rvckm-vckm((ia+1)/2,(ib+1)/2)   
          IF(rvckm.LE.0.) goto 370  
  360     CONTINUE  
        ELSE    
          ib=2*((ia+1)/2)-1+mod(ia,2)   
          mint(20+jt)=isign(ib,i)   
        ENDIF   
  370   pmq(jt)=ulmass(mint(20+jt)) 
        jt=int(1.5+rlu(0))  
        zmin=2.*pmq(jt)/shpr    
        zmax=1.-pmq(3-jt)/shpr-(sh-pmq(jt)**2)/(shpr*(shpr-pmq(3-jt)))  
        zmax=min(1.-xh,zmax)    
        z(jt)=zmin+(zmax-zmin)*rlu(0)   
        IF(-1.+(1.+xh)/(1.-z(jt))-xh/(1.-z(jt))**2.LT.  
     &  (1.-xh)**2/(4.*xh)*rlu(0)) goto 340 
        sqc1=1.-4.*pmq(jt)**2/(z(jt)**2*shp)    
        IF(sqc1.LT.1.e-8) goto 340  
        c1=sqrt(sqc1)   
        c2=1.+2.*(pmas(24,1)**2-pmq(jt)**2)/(z(jt)*shp) 
        cthe(jt)=(c2-(c2**2-c1**2)/(c2+(2.*rlu(0)-1.)*c1))/c1   
        cthe(jt)=min(1.,max(-1.,cthe(jt)))  
        z(3-jt)=1.-xh/(1.-z(jt))    
        sqc1=1.-4.*pmq(3-jt)**2/(z(3-jt)**2*shp)    
        IF(sqc1.LT.1.e-8) goto 340  
        c1=sqrt(sqc1)   
        c2=1.+2.*(pmas(24,1)**2-pmq(3-jt)**2)/(z(3-jt)*shp) 
        cthe(3-jt)=(c2-(c2**2-c1**2)/(c2+(2.*rlu(0)-1.)*c1))/c1 
        cthe(3-jt)=min(1.,max(-1.,cthe(3-jt)))  
        phir=paru(2)*rlu(0) 
        cphi=cos(phir)  
        ang=cthe(1)*cthe(2)-sqrt(1.-cthe(1)**2)*sqrt(1.-cthe(2)**2)*cphi    
        z1=2.-z(jt) 
        z2=ang*sqrt(z(jt)**2-4.*pmq(jt)**2/shp) 
        z3=1.-z(jt)-xh+(pmq(1)**2+pmq(2)**2)/shp    
        z(3-jt)=2./(z1**2-z2**2)*(z1*z3+z2*sqrt(z3**2-(z1**2-z2**2)*    
     &  pmq(3-jt)**2/shp))  
        zmin=2.*pmq(3-jt)/shpr  
        zmax=1.-pmq(jt)/shpr-(sh-pmq(3-jt)**2)/(shpr*(shpr-pmq(jt)))    
        zmax=min(1.-xh,zmax)    
        IF(z(3-jt).LT.zmin.OR.z(3-jt).GT.zmax) goto 340 
        kcc=22  
    
      ELSEIF(isub.EQ.78) THEN   
C...W+/- + H0 -> W+/- + H0. 
    
      ELSEIF(isub.EQ.79) THEN   
C...H0 + H0 -> H0 + H0. 
      ENDIF 
    
      ELSEIF(isub.LE.90) THEN   
      IF(isub.EQ.81) THEN   
C...q + qb -> Q' + Qb'; th = (p(q)-p(q'))**2.   
        mint(21)=isign(mint(46),mint(15))   
        mint(22)=-mint(21)  
        kcc=4   
    
      ELSEIF(isub.EQ.82) THEN   
C...g + g -> Q + Qb; th arbitrary.  
        kcs=(-1)**int(1.5+rlu(0))   
        mint(21)=isign(mint(46),kcs)    
        mint(22)=-mint(21)  
        kcc=mint(2)+10  
      ENDIF 
    
      ELSEIF(isub.LE.100) THEN  
      IF(isub.EQ.95) THEN   
C...Low-pT ( = energyless g + g -> g + g).  
        kcc=mint(2)+12  
        kcs=(-1)**int(1.5+rlu(0))   
    
      ELSEIF(isub.EQ.96) THEN   
C...Multiple interactions (should be reassigned to QCD process).    
      ENDIF 
    
      ELSEIF(isub.LE.110) THEN  
      IF(isub.EQ.101) THEN  
C...g + g -> gamma*/Z0. 
        kcc=21  
        kfres=22    
    
      ELSEIF(isub.EQ.102) THEN  
C...g + g -> H0.    
        kcc=21  
        kfres=25    
      ENDIF 
    
      ELSEIF(isub.LE.120) THEN  
      IF(isub.EQ.111) THEN  
C...f + fb -> g + H0; th arbitrary. 
        IF(rlu(0).GT.0.5) js=2  
        mint(20+js)=21  
        mint(23-js)=25  
        kcc=17+js   
    
      ELSEIF(isub.EQ.112) THEN  
C...f + g -> f + H0; th = (p(f) - p(f))**2. 
        IF(mint(15).EQ.21) js=2 
        mint(23-js)=25  
        kcc=15+js   
        kcs=isign(1,mint(14+js))    
    
      ELSEIF(isub.EQ.113) THEN  
C...g + g -> g + H0; th arbitrary.  
        IF(rlu(0).GT.0.5) js=2  
        mint(23-js)=25  
        kcc=22+js   
        kcs=(-1)**int(1.5+rlu(0))   
    
      ELSEIF(isub.EQ.114) THEN  
C...g + g -> gamma + gamma; th arbitrary.   
        IF(rlu(0).GT.0.5) js=2  
        mint(21)=22 
        mint(22)=22 
        kcc=21  
    
      ELSEIF(isub.EQ.115) THEN  
C...g + g -> gamma + Z0.    
    
      ELSEIF(isub.EQ.116) THEN  
C...g + g -> Z0 + Z0.   
    
      ELSEIF(isub.EQ.117) THEN  
C...g + g -> W+ + W-.   
      ENDIF 
    
      ELSEIF(isub.LE.140) THEN  
      IF(isub.EQ.121) THEN  
C...g + g -> f + fb + H0.   
      ENDIF 
    
      ELSEIF(isub.LE.160) THEN  
      IF(isub.EQ.141) THEN  
C...f + fb -> gamma*/Z0/Z'0.    
        kfres=32    
    
      ELSEIF(isub.EQ.142) THEN  
C...f + fb' -> H+/-.    
        kch1=kchg(iabs(mint(15)),1)*isign(1,mint(15))   
        kch2=kchg(iabs(mint(16)),1)*isign(1,mint(16))   
        kfres=isign(37,kch1+kch2)   
    
      ELSEIF(isub.EQ.143) THEN  
C...f + fb' -> R.   
        kfres=isign(40,mint(15)+mint(16))   
      ENDIF 
    
      ELSE  
      IF(isub.EQ.161) THEN  
C...g + f -> H+/- + f'; th = (p(f)-p(f))**2.    
        IF(mint(16).EQ.21) js=2 
        ia=iabs(mint(17-js))    
        mint(20+js)=isign(37,kchg(ia,1)*mint(17-js))    
        ja=ia+mod(ia,2)-mod(ia+1,2) 
        mint(23-js)=isign(ja,mint(17-js))   
        kcc=18-js   
        IF(mint(15).NE.21) kcs=isign(1,mint(15))    
        IF(mint(16).NE.21) kcs=isign(1,mint(16))    
      ENDIF 
      ENDIF 
    
      IF(idoc.EQ.7) THEN    
C...Resonance not decaying: store colour connection indices.    
        i=mint(83)+7    
        k(ipu3,1)=1 
        k(ipu3,2)=kfres 
        k(ipu3,3)=i 
        p(ipu3,4)=shuser    
        p(ipu3,5)=shuser    
        k(ipu1,4)=ipu2  
        k(ipu1,5)=ipu2  
        k(ipu2,4)=ipu1  
        k(ipu2,5)=ipu1  
        k(i,1)=21   
        k(i,2)=kfres    
        p(i,4)=shuser   
        p(i,5)=shuser   
        n=ipu3  
        mint(21)=kfres  
        mint(22)=0  
    
      ELSEIF(idoc.EQ.8) THEN    
C...2 -> 2 processes: store outgoing partons in their CM-frame. 
        DO 390 jt=1,2   
        i=mint(84)+2+jt 
        k(i,1)=1    
        IF(iabs(mint(20+jt)).LE.10.OR.mint(20+jt).EQ.21) k(i,1)=3   
        k(i,2)=mint(20+jt)  
        k(i,3)=mint(83)+idoc+jt-2   
        IF(iabs(k(i,2)).LE.10.OR.k(i,2).EQ.21) THEN 
          p(i,5)=ulmass(k(i,2)) 
        ELSE    
          p(i,5)=sqrt(vint(63+mod(js+jt,2)))    
        ENDIF   
  390   CONTINUE    
        IF(p(ipu3,5)+p(ipu4,5).GE.shr) THEN 
          kfa1=iabs(mint(21))   
          kfa2=iabs(mint(22))   
          IF((kfa1.GT.3.AND.kfa1.NE.21).OR.(kfa2.GT.3.AND.kfa2.NE.21))  
     &    THEN  
            mint(51)=1  
            RETURN  
          ENDIF 
          p(ipu3,5)=0.  
          p(ipu4,5)=0.  
        ENDIF   
        p(ipu3,4)=0.5*(shr+(p(ipu3,5)**2-p(ipu4,5)**2)/shr) 
        p(ipu3,3)=sqrt(max(0.,p(ipu3,4)**2-p(ipu3,5)**2))   
        p(ipu4,4)=shr-p(ipu3,4) 
        p(ipu4,3)=-p(ipu3,3)    
        n=ipu4  
        mint(7)=mint(83)+7  
        mint(8)=mint(83)+8  
    
C...Rotate outgoing partons using cos(theta)=(th-uh)/lam(sh,sqm3,sqm4). 
        CALL ludbrb(ipu3,ipu4,acos(vint(23)),vint(24),0d0,0d0,0d0)  
    
      ELSEIF(idoc.EQ.9) THEN    
C'''2 -> 3 processes:   
    
      ELSEIF(idoc.EQ.11) THEN   
C...Z0 + Z0 -> H0, W+ + W- -> H0: store Higgs and outgoing partons. 
        phi(1)=paru(2)*rlu(0)   
        phi(2)=phi(1)-phir  
        DO 400 jt=1,2   
        i=mint(84)+2+jt 
        k(i,1)=1    
        IF(iabs(mint(20+jt)).LE.10.OR.mint(20+jt).EQ.21) k(i,1)=3   
        k(i,2)=mint(20+jt)  
        k(i,3)=mint(83)+idoc+jt-2   
        p(i,5)=ulmass(k(i,2))   
        IF(0.5*shpr*z(jt).LE.p(i,5)) p(i,5)=0.  
        pabs=sqrt(max(0.,(0.5*shpr*z(jt))**2-p(i,5)**2))    
        ptabs=pabs*sqrt(max(0.,1.-cthe(jt)**2)) 
        p(i,1)=ptabs*cos(phi(jt))   
        p(i,2)=ptabs*sin(phi(jt))   
        p(i,3)=pabs*cthe(jt)*(-1)**(jt+1)   
        p(i,4)=0.5*shpr*z(jt)   
        izw=mint(83)+6+jt   
        k(izw,1)=21 
        k(izw,2)=23 
        IF(isub.EQ.8) k(izw,2)=isign(24,luchge(mint(14+jt)))    
        k(izw,3)=izw-2  
        p(izw,1)=-p(i,1)    
        p(izw,2)=-p(i,2)    
        p(izw,3)=(0.5*shpr-pabs*cthe(jt))*(-1)**(jt+1)  
        p(izw,4)=0.5*shpr*(1.-z(jt))    
  400   p(izw,5)=-sqrt(max(0.,p(izw,3)**2+ptabs**2-p(izw,4)**2))    
        i=mint(83)+9    
        k(ipu5,1)=1 
        k(ipu5,2)=kfres 
        k(ipu5,3)=i 
        p(ipu5,5)=shr   
        p(ipu5,1)=-p(ipu3,1)-p(ipu4,1)  
        p(ipu5,2)=-p(ipu3,2)-p(ipu4,2)  
        p(ipu5,3)=-p(ipu3,3)-p(ipu4,3)  
        p(ipu5,4)=shpr-p(ipu3,4)-p(ipu4,4)  
        k(i,1)=21   
        k(i,2)=kfres    
        DO 410 j=1,5    
  410   p(i,j)=p(ipu5,j)    
        n=ipu5  
        mint(23)=kfres  
    
      ELSEIF(idoc.EQ.12) THEN   
C...Z0 and W+/- scattering: store bosons and outgoing partons.  
        phi(1)=paru(2)*rlu(0)   
        phi(2)=phi(1)-phir  
        DO 420 jt=1,2   
        i=mint(84)+2+jt 
        k(i,1)=1    
        IF(iabs(mint(20+jt)).LE.10.OR.mint(20+jt).EQ.21) k(i,1)=3   
        k(i,2)=mint(20+jt)  
        k(i,3)=mint(83)+idoc+jt-2   
        p(i,5)=ulmass(k(i,2))   
        IF(0.5*shpr*z(jt).LE.p(i,5)) p(i,5)=0.  
        pabs=sqrt(max(0.,(0.5*shpr*z(jt))**2-p(i,5)**2))    
        ptabs=pabs*sqrt(max(0.,1.-cthe(jt)**2)) 
        p(i,1)=ptabs*cos(phi(jt))   
        p(i,2)=ptabs*sin(phi(jt))   
        p(i,3)=pabs*cthe(jt)*(-1)**(jt+1)   
        p(i,4)=0.5*shpr*z(jt)   
        izw=mint(83)+6+jt   
        k(izw,1)=21 
        IF(mint(14+jt).EQ.mint(20+jt)) THEN 
          k(izw,2)=23   
        ELSE    
          k(izw,2)=isign(24,luchge(mint(14+jt))-luchge(mint(20+jt)))    
        ENDIF   
        k(izw,3)=izw-2  
        p(izw,1)=-p(i,1)    
        p(izw,2)=-p(i,2)    
        p(izw,3)=(0.5*shpr-pabs*cthe(jt))*(-1)**(jt+1)  
        p(izw,4)=0.5*shpr*(1.-z(jt))    
        p(izw,5)=-sqrt(max(0.,p(izw,3)**2+ptabs**2-p(izw,4)**2))    
        ipu=mint(84)+4+jt   
        k(ipu,1)=3  
        k(ipu,2)=kfpr(isub,jt)  
        k(ipu,3)=mint(83)+8+jt  
        IF(iabs(k(ipu,2)).LE.10.OR.k(ipu,2).EQ.21) THEN 
          p(ipu,5)=ulmass(k(ipu,2)) 
        ELSE    
          p(ipu,5)=sqrt(vint(63+mod(js+jt,2)))  
        ENDIF   
        mint(22+jt)=k(izw,2)    
  420   CONTINUE    
        IF(isub.EQ.72) k(mint(84)+4+int(1.5+rlu(0)),2)=-24  
C...Find rotation and boost for hard scattering subsystem.  
        i1=mint(83)+7   
        i2=mint(83)+8   
        bexcm=(p(i1,1)+p(i2,1))/(p(i1,4)+p(i2,4))   
        beycm=(p(i1,2)+p(i2,2))/(p(i1,4)+p(i2,4))   
        bezcm=(p(i1,3)+p(i2,3))/(p(i1,4)+p(i2,4))   
        gamcm=(p(i1,4)+p(i2,4))/shr 
        bepcm=bexcm*p(i1,1)+beycm*p(i1,2)+bezcm*p(i1,3) 
        px=p(i1,1)+gamcm*(gamcm/(1.+gamcm)*bepcm-p(i1,4))*bexcm 
        py=p(i1,2)+gamcm*(gamcm/(1.+gamcm)*bepcm-p(i1,4))*beycm 
        pz=p(i1,3)+gamcm*(gamcm/(1.+gamcm)*bepcm-p(i1,4))*bezcm 
        thecm=ulangl(pz,sqrt(px**2+py**2))  
        phicm=ulangl(px,py) 
C...Store hard scattering subsystem. Rotate and boost it.   
        sqlam=(sh-p(ipu5,5)**2-p(ipu6,5)**2)**2-4.*p(ipu5,5)**2*    
     &  p(ipu6,5)**2    
        pabs=sqrt(max(0.,sqlam/(4.*sh)))    
        cthwz=vint(23)  
        sthwz=sqrt(max(0.,1.-cthwz**2)) 
        phiwz=vint(24)-phicm    
        p(ipu5,1)=pabs*sthwz*cos(phiwz) 
        p(ipu5,2)=pabs*sthwz*sin(phiwz) 
        p(ipu5,3)=pabs*cthwz    
        p(ipu5,4)=sqrt(pabs**2+p(ipu5,5)**2)    
        p(ipu6,1)=-p(ipu5,1)    
        p(ipu6,2)=-p(ipu5,2)    
        p(ipu6,3)=-p(ipu5,3)    
        p(ipu6,4)=sqrt(pabs**2+p(ipu6,5)**2)    
        CALL ludbrb(ipu5,ipu6,thecm,phicm,dble(bexcm),dble(beycm),  
     &  dble(bezcm))    
        DO 430 jt=1,2   
        i1=mint(83)+8+jt    
        i2=mint(84)+4+jt    
        k(i1,1)=21  
        k(i1,2)=k(i2,2) 
        DO 430 j=1,5    
  430   p(i1,j)=p(i2,j) 
        n=ipu6  
        mint(7)=mint(83)+9  
        mint(8)=mint(83)+10 
      ENDIF 
    
      IF(idoc.GE.8) THEN    
C...Store colour connection indices.    
        DO 440 j=1,2    
        jc=j    
        IF(kcs.EQ.-1) jc=3-j    
        IF(icol(kcc,1,jc).NE.0.AND.k(ipu1,1).EQ.14) k(ipu1,j+3)=    
     &  k(ipu1,j+3)+mint(84)+icol(kcc,1,jc) 
        IF(icol(kcc,2,jc).NE.0.AND.k(ipu2,1).EQ.14) k(ipu2,j+3)=    
     &  k(ipu2,j+3)+mint(84)+icol(kcc,2,jc) 
        IF(icol(kcc,3,jc).NE.0.AND.k(ipu3,1).EQ.3) k(ipu3,j+3)= 
     &  mstu(5)*(mint(84)+icol(kcc,3,jc))   
  440   IF(icol(kcc,4,jc).NE.0.AND.k(ipu4,1).EQ.3) k(ipu4,j+3)= 
     &  mstu(5)*(mint(84)+icol(kcc,4,jc))   
    
C...Copy outgoing partons to documentation lines.   
        DO 450 i=1,2    
        i1=mint(83)+idoc-2+i    
        i2=mint(84)+2+i 
        k(i1,1)=21  
        k(i1,2)=k(i2,2) 
        IF(idoc.LE.9) k(i1,3)=0 
        IF(idoc.GE.11) k(i1,3)=mint(83)+2+i 
        DO 450 j=1,5    
  450   p(i1,j)=p(i2,j) 
      ENDIF 
      mint(52)=n    
    
C...Low-pT events: remove gluons used for string drawing purposes.  
      IF(isub.EQ.95) THEN   
        k(ipu3,1)=k(ipu3,1)+10  
        k(ipu4,1)=k(ipu4,1)+10  
        DO 460 j=41,66  
  460   vint(j)=0.  
        DO 470 i=mint(83)+5,mint(83)+8  
        DO 470 j=1,5    
  470   p(i,j)=0.   
      ENDIF 
    
      RETURN    
      END   
    
C*********************************************************************  
    
      SUBROUTINE pysspa(IPU1,IPU2)  
    
C...Generates spacelike parton showers. 
      IMPLICIT DOUBLE PRECISION(d)  
      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/ludat2/kchg(500,3),pmas(500,4),parf(2000),vckm(4,4)    
      SAVE /ludat2/ 
      common/pysubs/msel,msub(200),kfin(2,-40:40),ckin(200) 
      SAVE /pysubs/ 
      common/pypars/mstp(200),parp(200),msti(200),pari(200) 
      SAVE /pypars/ 
      common/pyint1/mint(400),vint(400) 
      SAVE /pyint1/ 
      common/pyint2/iset(200),kfpr(200,2),coef(200,20),icol(40,4,2) 
      SAVE /pyint2/ 
      common/pyint3/xsfx(2,-40:40),isig(1000,3),sigh(1000)  
      SAVE /pyint3/ 
      dimension kfls(4),is(2),xs(2),zs(2),q2s(2),tevs(2),robo(5),   
     &xfs(2,-6:6),xfa(-6:6),xfb(-6:6),xfn(-6:6),wtap(-6:6),wtsf(-6:6),  
     &the2(2),alam(2),dq2(3),dpc(3),dpd(4),dpb(4)   
    
C...Calculate maximum virtuality and check that evolution possible. 
      ipus1=ipu1    
      ipus2=ipu2    
      isub=mint(1)  
      q2e=vint(52)  
      IF(iset(isub).EQ.1) THEN  
        q2e=q2e/parp(67)    
      ELSEIF(iset(isub).EQ.3.OR.iset(isub).EQ.4) THEN   
        q2e=pmas(23,1)**2   
        IF(isub.EQ.8.OR.isub.EQ.76.OR.isub.EQ.77) q2e=pmas(24,1)**2 
      ENDIF 
      tmax=log(parp(67)*parp(63)*q2e/parp(61)**2)   
      IF(parp(67)*q2e.LT.max(parp(62)**2,2.*parp(61)**2).OR.    
     &tmax.LT.0.2) RETURN   
    
C...Common constants and initial values. Save normal Lambda value.  
      xe0=2.*parp(65)/vint(1)   
      alams=paru(111)   
      paru(111)=parp(61)    
      ns=n  
  100 n=ns  
      DO 110 jt=1,2 
      kfls(jt)=mint(14+jt)  
      kfls(jt+2)=kfls(jt)   
      xs(jt)=vint(40+jt)    
      zs(jt)=1. 
      q2s(jt)=parp(67)*q2e  
      tevs(jt)=tmax 
      alam(jt)=parp(61) 
      the2(jt)=100. 
      DO 110 kfl=-6,6   
  110 xfs(jt,kfl)=xsfx(jt,kfl)  
      dsh=vint(44)  
      IF(iset(isub).EQ.3.OR.iset(isub).EQ.4) dsh=vint(26)*vint(2)   
    
C...Pick up leg with highest virtuality.    
  120 n=n+1 
      jt=1  
      IF(n.GT.ns+1.AND.q2s(2).GT.q2s(1)) jt=2   
      kflb=kfls(jt) 
      xb=xs(jt) 
      DO 130 kfl=-6,6   
  130 xfb(kfl)=xfs(jt,kfl)  
      dshr=2d0*sqrt(dsh)    
      dshz=dsh/dble(zs(jt)) 
      xe=max(xe0,xb*(1./(1.-parp(66))-1.))  
      IF(xb+xe.GE.0.999) THEN   
        q2b=0.  
        goto 220    
      ENDIF 
    
C...Maximum Q2 without or with Q2 ordering. Effective Lambda and n_f.   
      IF(mstp(62).LE.1) THEN    
        q2b=0.5*(1./zs(jt)+1.)*q2s(jt)+0.5*(1./zs(jt)-1.)*(q2s(3-jt)-   
     &  sngl(dsh)+sqrt((sngl(dsh)+q2s(1)+q2s(2))**2+8.*q2s(1)*q2s(2)*   
     &  zs(jt)/(1.-zs(jt))))    
        tevb=log(parp(63)*q2b/alam(jt)**2)  
      ELSE  
        q2b=q2s(jt) 
        tevb=tevs(jt)   
      ENDIF 
      alsdum=ulalps(parp(63)*q2b)   
      tevb=tevb+2.*log(alam(jt)/paru(117))  
      tevbsv=tevb   
      alam(jt)=paru(117)    
      b0=(33.-2.*mstu(118))/6.  
    
C...Calculate Altarelli-Parisi and structure function weights.  
      DO 140 kfl=-6,6   
      wtap(kfl)=0.  
  140 wtsf(kfl)=0.  
      IF(kflb.EQ.21) THEN   
        wtapq=16.*(1.-sqrt(xb+xe))/(3.*sqrt(xb))    
        DO 150 kfl=-mstp(54),mstp(54)   
        IF(kfl.EQ.0) wtap(kfl)=6.*log((1.-xb)/xe)   
  150   IF(kfl.NE.0) wtap(kfl)=wtapq    
      ELSE  
        wtap(0)=0.5*xb*(1./(xb+xe)-1.)  
        wtap(kflb)=8.*log((1.-xb)*(xb+xe)/xe)/3.    
      ENDIF 
  160 wtsum=0.  
      IF(kflb.NE.21) xfbo=xfb(kflb) 
      IF(kflb.EQ.21) xfbo=xfb(0)
C***************************************************************
C**********ERROR HAS OCCURED HERE
      IF(xfbo.EQ.0.0) THEN
                WRITE(mstu(11),1000)
                WRITE(mstu(11),1001) kflb,xfb(kflb)
    xfbo=0.00001
      ENDIF
C****************************************************************    
      DO 170 kfl=-mstp(54),mstp(54) 
      wtsf(kfl)=xfb(kfl)/xfbo   
  170 wtsum=wtsum+wtap(kfl)*wtsf(kfl)   
      wtsum=max(0.0001,wtsum)   
    
C...Choose new t: fix alpha_s, alpha_s(Q2), alpha_s(k_T2).  
  180 IF(mstp(64).LE.0) THEN    
        tevb=tevb+log(rlu(0))*paru(2)/(paru(111)*wtsum) 
      ELSEIF(mstp(64).EQ.1) THEN    
        tevb=tevb*exp(max(-100.,log(rlu(0))*b0/wtsum))  
      ELSE  
        tevb=tevb*exp(max(-100.,log(rlu(0))*b0/(5.*wtsum))) 
      ENDIF 
  190 q2ref=alam(jt)**2*exp(tevb)   
      q2b=q2ref/parp(63)    
    
C...Evolution ended or select flavour for branching parton. 
      IF(q2b.LT.parp(62)**2) THEN   
        q2b=0.  
      ELSE  
        wtran=rlu(0)*wtsum  
        kfla=-mstp(54)-1    
  200   kfla=kfla+1 
        wtran=wtran-wtap(kfla)*wtsf(kfla)   
        IF(kfla.LT.mstp(54).AND.wtran.GT.0.) goto 200   
        IF(kfla.EQ.0) kfla=21   
    
C...Choose z value and corrective weight.   
        IF(kflb.EQ.21.AND.kfla.EQ.21) THEN  
          z=1./(1.+((1.-xb)/xb)*(xe/(1.-xb))**rlu(0))   
          wtz=(1.-z*(1.-z))**2  
        ELSEIF(kflb.EQ.21) THEN 
          z=xb/(1.-rlu(0)*(1.-sqrt(xb+xe)))**2  
          wtz=0.5*(1.+(1.-z)**2)*sqrt(z)    
        ELSEIF(kfla.EQ.21) THEN 
          z=xb*(1.+rlu(0)*(1./(xb+xe)-1.))  
          wtz=1.-2.*z*(1.-z)    
        ELSE    
          z=1.-(1.-xb)*(xe/((xb+xe)*(1.-xb)))**rlu(0)   
          wtz=0.5*(1.+z**2) 
        ENDIF   
    
C...Option with resummation of soft gluon emission as effective z shift.    
        IF(mstp(65).GE.1) THEN  
          rsoft=6.  
          IF(kflb.NE.21) rsoft=8./3.    
          z=z*(tevb/tevs(jt))**(rsoft*xe/((xb+xe)*b0))  
          IF(z.LE.xb) goto 180  
        ENDIF   
    
C...Option with alpha_s(k_T2)Q2): demand k_T2 > cutoff, reweight.   
        IF(mstp(64).GE.2) THEN  
          IF((1.-z)*q2b.LT.parp(62)**2) goto 180    
          alprat=tevb/(tevb+log(1.-z))  
          IF(alprat.LT.5.*rlu(0)) goto 180  
          IF(alprat.GT.5.) wtz=wtz*alprat/5.    
        ENDIF   
    
C...Option with angular ordering requirement.   
        IF(mstp(62).GE.3) THEN  
          the2t=(4.*z**2*q2b)/(vint(2)*(1.-z)*xb**2)    
          IF(the2t.GT.the2(jt)) goto 180    
        ENDIF   
    
C...Weighting with new structure functions. 
        CALL pystfu(mint(10+jt),xb,q2ref,xfn,jt)   
        IF(kflb.NE.21) xfbn=xfn(kflb)   
        IF(kflb.EQ.21) xfbn=xfn(0)  
        IF(xfbn.LT.1e-20) THEN  
          IF(kfla.EQ.kflb) THEN 
            tevb=tevbsv 
            wtap(kflb)=0.   
            goto 160    
          ELSEIF(tevbsv-tevb.GT.0.2) THEN   
            tevb=0.5*(tevbsv+tevb)  
            goto 190    
          ELSE  
            xfbn=1e-10  
          ENDIF 
        ENDIF   
        DO 210 kfl=-mstp(54),mstp(54)   
  210   xfb(kfl)=xfn(kfl)   
        xa=xb/z 
        CALL pystfu(mint(10+jt),xa,q2ref,xfa,jt)   
        IF(kfla.NE.21) xfan=xfa(kfla)   
        IF(kfla.EQ.21) xfan=xfa(0)  
        IF(xfan.LT.1e-20) goto 160  
        IF(kfla.NE.21) wtsfa=wtsf(kfla) 
        IF(kfla.EQ.21) wtsfa=wtsf(0)    
        IF(wtz*xfan/xfbn.LT.rlu(0)*wtsfa) goto 160  
      ENDIF 
    
C...Define two hard scatterers in their CM-frame.   
  220 IF(n.EQ.ns+2) THEN    
        dq2(jt)=q2b 
        dplcm=sqrt((dsh+dq2(1)+dq2(2))**2-4d0*dq2(1)*dq2(2))/dshr   
        DO 240 jr=1,2   
        i=ns+jr 
        IF(jr.EQ.1) ipo=ipus1   
        IF(jr.EQ.2) ipo=ipus2   
        DO 230 j=1,5    
        k(i,j)=0    
        p(i,j)=0.   
  230   v(i,j)=0.   
        k(i,1)=14   
        k(i,2)=kfls(jr+2)   
        k(i,4)=ipo  
        k(i,5)=ipo  
        p(i,3)=dplcm*(-1)**(jr+1)   
        p(i,4)=(dsh+dq2(3-jr)-dq2(jr))/dshr 
        p(i,5)=-sqrt(sngl(dq2(jr))) 
        k(ipo,1)=14 
        k(ipo,3)=i  
        k(ipo,4)=mod(k(ipo,4),mstu(5))+mstu(5)*i    
  240   k(ipo,5)=mod(k(ipo,5),mstu(5))+mstu(5)*i    
    
C...Find maximum allowed mass of timelike parton.   
      ELSEIF(n.GT.ns+2) THEN    
        jr=3-jt 
        dq2(3)=q2b  
        dpc(1)=p(is(1),4)   
        dpc(2)=p(is(2),4)   
        dpc(3)=0.5*(abs(p(is(1),3))+abs(p(is(2),3)))    
        dpd(1)=dsh+dq2(jr)+dq2(jt)  
        dpd(2)=dshz+dq2(jr)+dq2(3)  
        dpd(3)=sqrt(dpd(1)**2-4d0*dq2(jr)*dq2(jt))  
        dpd(4)=sqrt(dpd(2)**2-4d0*dq2(jr)*dq2(3))   
        ikin=0  
        IF(q2s(jr).GE.(0.5*parp(62))**2.AND.dpd(1)-dpd(3).GE.   
     &  1d-10*dpd(1)) ikin=1    
        IF(ikin.EQ.0) dmsma=(dq2(jt)/dble(zs(jt))-dq2(3))*(dsh/ 
     &  (dsh+dq2(jt))-dsh/(dshz+dq2(3)))    
        IF(ikin.EQ.1) dmsma=(dpd(1)*dpd(2)-dpd(3)*dpd(4))/(2.*  
     &  dq2(jr))-dq2(jt)-dq2(3) 
    
C...Generate timelike parton shower (if required).  
        it=n    
        DO 250 j=1,5    
        k(it,j)=0   
        p(it,j)=0.  
  250   v(it,j)=0.  
        k(it,1)=3   
        k(it,2)=21  
        IF(kflb.EQ.21.AND.kfls(jt+2).NE.21) k(it,2)=-kfls(jt+2) 
        IF(kflb.NE.21.AND.kfls(jt+2).EQ.21) k(it,2)=kflb    
        p(it,5)=ulmass(k(it,2)) 
        IF(sngl(dmsma).LE.p(it,5)**2) goto 100  
        IF(mstp(63).GE.1) THEN  
          p(it,4)=(dshz-dsh-p(it,5)**2)/dshr    
          p(it,3)=sqrt(p(it,4)**2-p(it,5)**2)   
          IF(mstp(63).EQ.1) THEN    
            q2tim=dmsma 
          ELSEIF(mstp(63).EQ.2) THEN    
            q2tim=min(sngl(dmsma),parp(71)*q2s(jt)) 
          ELSE  
C'''Here remains to introduce angular ordering in first branching.  
            q2tim=dmsma 
          ENDIF 
          CALL lushow(it,0,sqrt(q2tim)) 
          IF(n.GE.it+1) p(it,5)=p(it+1,5)   
        ENDIF   
    
C...Reconstruct kinematics of branching: timelike parton shower.    
        dms=p(it,5)**2  
        IF(ikin.EQ.0) dpt2=(dmsma-dms)*(dshz+dq2(3))/(dsh+dq2(jt))  
        IF(ikin.EQ.1) dpt2=(dmsma-dms)*(0.5*dpd(1)*dpd(2)+0.5*dpd(3)*   
     &  dpd(4)-dq2(jr)*(dq2(jt)+dq2(3)+dms))/(4.*dsh*dpc(3)**2) 
        IF(dpt2.LT.0.) goto 100 
        dpb(1)=(0.5*dpd(2)-dpc(jr)*(dshz+dq2(jr)-dq2(jt)-dms)/  
     &  dshr)/dpc(3)-dpc(3) 
        p(it,1)=sqrt(sngl(dpt2))    
        p(it,3)=dpb(1)*(-1)**(jt+1) 
        p(it,4)=(dshz-dsh-dms)/dshr 
        IF(n.GE.it+1) THEN  
          dpb(1)=sqrt(dpb(1)**2+dpt2)   
          dpb(2)=sqrt(dpb(1)**2+dms)    
          dpb(3)=p(it+1,3)  
          dpb(4)=sqrt(dpb(3)**2+dms)    
          dbez=(dpb(4)*dpb(1)-dpb(3)*dpb(2))/(dpb(4)*dpb(2)-dpb(3)* 
     &    dpb(1))   
          CALL ludbrb(it+1,n,0.,0.,0d0,0d0,dbez)    
          the=ulangl(p(it,3),p(it,1))   
          CALL ludbrb(it+1,n,the,0.,0d0,0d0,0d0)    
        ENDIF   
    
C...Reconstruct kinematics of branching: spacelike parton.  
        DO 260 j=1,5    
        k(n+1,j)=0  
        p(n+1,j)=0. 
  260   v(n+1,j)=0. 
        k(n+1,1)=14 
        k(n+1,2)=kflb   
        p(n+1,1)=p(it,1)    
        p(n+1,3)=p(it,3)+p(is(jt),3)    
        p(n+1,4)=p(it,4)+p(is(jt),4)    
        p(n+1,5)=-sqrt(sngl(dq2(3)))    
    
C...Define colour flow of branching.    
        k(is(jt),3)=n+1 
        k(it,3)=n+1 
        id1=it  
        IF((k(n+1,2).GT.0.AND.k(n+1,2).NE.21.AND.k(id1,2).GT.0.AND. 
     &  k(id1,2).NE.21).OR.(k(n+1,2).LT.0.AND.k(id1,2).EQ.21).OR.   
     &  (k(n+1,2).EQ.21.AND.k(id1,2).EQ.21.AND.rlu(0).GT.0.5).OR.   
     &  (k(n+1,2).EQ.21.AND.k(id1,2).LT.0)) id1=is(jt)  
        id2=it+is(jt)-id1   
        k(n+1,4)=k(n+1,4)+id1   
        k(n+1,5)=k(n+1,5)+id2   
        k(id1,4)=k(id1,4)+mstu(5)*(n+1) 
        k(id1,5)=k(id1,5)+mstu(5)*id2   
        k(id2,4)=k(id2,4)+mstu(5)*id1   
        k(id2,5)=k(id2,5)+mstu(5)*(n+1) 
        n=n+1   
    
C...Boost to new CM-frame.  
        CALL ludbrb(ns+1,n,0.,0.,-dble((p(n,1)+p(is(jr),1))/(p(n,4)+    
     &  p(is(jr),4))),0d0,-dble((p(n,3)+p(is(jr),3))/(p(n,4)+   
     &  p(is(jr),4))))  
        ir=n+(jt-1)*(is(1)-n)   
        CALL ludbrb(ns+1,n,-ulangl(p(ir,3),p(ir,1)),paru(2)*rlu(0), 
     &  0d0,0d0,0d0)    
      ENDIF 
    
C...Save quantities, loop back. 
      is(jt)=n  
      q2s(jt)=q2b   
      dq2(jt)=q2b   
      IF(mstp(62).GE.3) the2(jt)=the2t  
      dsh=dshz  
      IF(q2b.GE.(0.5*parp(62))**2) THEN 
        kfls(jt+2)=kfls(jt) 
        kfls(jt)=kfla   
        xs(jt)=xa   
        zs(jt)=z    
        DO 270 kfl=-6,6 
  270   xfs(jt,kfl)=xfa(kfl)    
        tevs(jt)=tevb   
      ELSE  
        IF(jt.EQ.1) ipu1=n  
        IF(jt.EQ.2) ipu2=n  
      ENDIF 
      IF(n.GT.mstu(4)-mstu(32)-10) THEN 
        CALL luerrm(11,'(PYSSPA:) no more memory left in LUJETS')   
        IF(mstu(21).GE.1) n=ns  
        IF(mstu(21).GE.1) RETURN    
      ENDIF 
      IF(max(q2s(1),q2s(2)).GE.(0.5*parp(62))**2.OR.n.LE.ns+1) goto 120 
    
C...Boost hard scattering partons to frame of shower initiators.    
      DO 280 j=1,3  
  280 robo(j+2)=(p(ns+1,j)+p(ns+2,j))/(p(ns+1,4)+p(ns+2,4)) 
      DO 290 j=1,5  
  290 p(n+2,j)=p(ns+1,j)    
      robot=robo(3)**2+robo(4)**2+robo(5)**2    
      IF(robot.GE.0.999999) THEN    
        robot=1.00001*sqrt(robot)   
        robo(3)=robo(3)/robot   
        robo(4)=robo(4)/robot   
        robo(5)=robo(5)/robot   
      ENDIF 
      CALL ludbrb(n+2,n+2,0.,0.,-dble(robo(3)),-dble(robo(4)),  
     &-dble(robo(5)))   
      robo(2)=ulangl(p(n+2,1),p(n+2,2)) 
      robo(1)=ulangl(p(n+2,3),sqrt(p(n+2,1)**2+p(n+2,2)**2))    
      CALL ludbrb(mint(83)+5,ns,robo(1),robo(2),dble(robo(3)),  
     &dble(robo(4)),dble(robo(5)))  
    
C...Store user information. Reset Lambda value. 
      k(ipu1,3)=mint(83)+3  
      k(ipu2,3)=mint(83)+4  
      DO 300 jt=1,2 
      mint(12+jt)=kfls(jt)  
  300 vint(140+jt)=xs(jt)   
      paru(111)=alams   
 1000 FORMAT(5x,'structure function has a zero point here')
 1001 FORMAT(5x,'xf(x,i=',i5,')=',f10.5)

      RETURN    
      END   
    
C*********************************************************************  
    
      SUBROUTINE pymult(MMUL)   
    
C...Initializes treatment of multiple interactions, selects kinematics  
C...of hardest interaction if low-pT physics included in run, and   
C...generates all non-hardest interactions. 
      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/ludat2/kchg(500,3),pmas(500,4),parf(2000),vckm(4,4)    
      SAVE /ludat2/ 
      common/pysubs/msel,msub(200),kfin(2,-40:40),ckin(200) 
      SAVE /pysubs/ 
      common/pypars/mstp(200),parp(200),msti(200),pari(200) 
      SAVE /pypars/ 
      common/pyint1/mint(400),vint(400) 
      SAVE /pyint1/ 
      common/pyint2/iset(200),kfpr(200,2),coef(200,20),icol(40,4,2) 
      SAVE /pyint2/ 
      common/pyint3/xsfx(2,-40:40),isig(1000,3),sigh(1000)  
      SAVE /pyint3/ 
      common/pyint5/ngen(0:200,3),xsec(0:200,3) 
      SAVE /pyint5/ 
      dimension nmul(20),sigm(20),kstr(500,2)   
      SAVE xt2,xt2fac,xc2,xts,irbin,rbin,nmul,sigm  
    
C...Initialization of multiple interaction treatment.   
      IF(mmul.EQ.1) THEN    
        IF(mstp(122).GE.1) WRITE(mstu(11),1000) mstp(82)    
        isub=96 
        mint(1)=96  
        vint(63)=0. 
        vint(64)=0. 
        vint(143)=1.    
        vint(144)=1.    
    
C...Loop over phase space points: xT2 choice in 20 bins.    
  100   sigsum=0.   
        DO 120 ixt2=1,20    
        nmul(ixt2)=mstp(83) 
        sigm(ixt2)=0.   
        DO 110 itry=1,mstp(83)  
        rsca=0.05*((21-ixt2)-rlu(0))    
        xt2=vint(149)*(1.+vint(149))/(vint(149)+rsca)-vint(149) 
        xt2=max(0.01*vint(149),xt2) 
        vint(25)=xt2    
    
C...Choose tau and y*. Calculate cos(theta-hat).    
        IF(rlu(0).LE.coef(isub,1)) THEN 
          taup=(2.*(1.+sqrt(1.-xt2))/xt2-1.)**rlu(0)    
          tau=xt2*(1.+taup)**2/(4.*taup)    
        ELSE    
          tau=xt2*(1.+tan(rlu(0)*atan(sqrt(1./xt2-1.)))**2) 
        ENDIF   
        vint(21)=tau    
        CALL pyklim(2)  
        ryst=rlu(0) 
        myst=1  
        IF(ryst.GT.coef(isub,7)) myst=2 
        IF(ryst.GT.coef(isub,7)+coef(isub,8)) myst=3    
        CALL pykmap(2,myst,rlu(0))  
        vint(23)=sqrt(max(0.,1.-xt2/tau))*(-1)**int(1.5+rlu(0)) 
    
C...Calculate differential cross-section.   
        vint(71)=0.5*vint(1)*sqrt(xt2)  
        CALL pysigh(nchn,sigs)  
  110   sigm(ixt2)=sigm(ixt2)+sigs  
  120   sigsum=sigsum+sigm(ixt2)    
        sigsum=sigsum/(20.*mstp(83))    
    
C...Reject result if sigma(parton-parton) is smaller than hadronic one. 
        IF(sigsum.LT.1.1*vint(106)) THEN    
          IF(mstp(122).GE.1) WRITE(mstu(11),1100) parp(82),sigsum   
          parp(82)=0.9*parp(82) 
          vint(149)=4.*parp(82)**2/vint(2)  
          goto 100  
        ENDIF   
        IF(mstp(122).GE.1) WRITE(mstu(11),1200) parp(82), sigsum    
    
C...Start iteration to find k factor.   
        yke=sigsum/vint(106)    
        so=0.5  
        xi=0.   
        yi=0.   
        xk=0.5  
        iit=0   
  130   IF(iit.EQ.0) THEN   
          xk=2.*xk  
        ELSEIF(iit.EQ.1) THEN   
          xk=0.5*xk 
        ELSE    
          xk=xi+(yke-yi)*(xf-xi)/(yf-yi)    
        ENDIF   
    
C...Evaluate overlap integrals. 
        IF(mstp(82).EQ.2) THEN  
          sp=0.5*paru(1)*(1.-exp(-xk))  
          sop=sp/paru(1)    
        ELSE    
          IF(mstp(82).EQ.3) deltab=0.02 
          IF(mstp(82).EQ.4) deltab=min(0.01,0.05*parp(84))  
          sp=0. 
          sop=0.    
          b=-0.5*deltab 
  140     b=b+deltab    
          IF(mstp(82).EQ.3) THEN    
            ov=exp(-b**2)/paru(2)   
          ELSE  
            cq2=parp(84)**2 
            ov=((1.-parp(83))**2*exp(-min(100.,b**2))+2.*parp(83)*  
     &      (1.-parp(83))*2./(1.+cq2)*exp(-min(100.,b**2*2./(1.+cq2)))+ 
     &      parp(83)**2/cq2*exp(-min(100.,b**2/cq2)))/paru(2)   
          ENDIF 
          pacc=1.-exp(-min(100.,paru(1)*xk*ov)) 
          sp=sp+paru(2)*b*deltab*pacc   
          sop=sop+paru(2)*b*deltab*ov*pacc  
          IF(b.LT.1..OR.b*pacc.GT.1e-6) goto 140    
        ENDIF   
        yk=paru(1)*xk*so/sp 
    
C...Continue iteration until convergence.   
        IF(yk.LT.yke) THEN  
          xi=xk 
          yi=yk 
          IF(iit.EQ.1) iit=2    
        ELSE    
          xf=xk 
          yf=yk 
          IF(iit.EQ.0) iit=1    
        ENDIF   
        IF(abs(yk-yke).GE.1e-5*yke) goto 130    
    
C...Store some results for subsequent use.  
        vint(145)=sigsum    
        vint(146)=sop/so    
        vint(147)=sop/sp    
    
C...Initialize iteration in xT2 for hardest interaction.    
      ELSEIF(mmul.EQ.2) THEN    
        IF(mstp(82).LE.0) THEN  
        ELSEIF(mstp(82).EQ.1) THEN  
          xt2=1.    
          xt2fac=xsec(96,1)/vint(106)*vint(149)/(1.-vint(149))  
        ELSEIF(mstp(82).EQ.2) THEN  
          xt2=1.    
          xt2fac=vint(146)*xsec(96,1)/vint(106)*vint(149)*(1.+vint(149))    
        ELSE    
          xc2=4.*ckin(3)**2/vint(2) 
          IF(ckin(3).LE.ckin(5).OR.mint(82).GE.2) xc2=0.    
        ENDIF   
    
      ELSEIF(mmul.EQ.3) THEN    
C...Low-pT or multiple interactions (first semihard interaction):   
C...choose xT2 according to dpT2/pT2**2*exp(-(sigma above pT2)/norm)    
C...or (MSTP(82)>=2) dpT2/(pT2+pT0**2)**2*exp(-....).   
        isub=mint(1)    
        IF(mstp(82).LE.0) THEN  
          xt2=0.    
        ELSEIF(mstp(82).EQ.1) THEN  
          xt2=xt2fac*xt2/(xt2fac-xt2*log(rlu(0)))   
        ELSEIF(mstp(82).EQ.2) THEN  
          IF(xt2.LT.1..AND.exp(-xt2fac*xt2/(vint(149)*(xt2+ 
     &    vint(149)))).GT.rlu(0)) xt2=1.    
          IF(xt2.GE.1.) THEN    
            xt2=(1.+vint(149))*xt2fac/(xt2fac-(1.+vint(149))*log(1.-    
     &      rlu(0)*(1.-exp(-xt2fac/(vint(149)*(1.+vint(149)))))))-  
     &      vint(149)   
          ELSE  
            xt2=-xt2fac/log(exp(-xt2fac/(xt2+vint(149)))+rlu(0)*    
     &      (exp(-xt2fac/vint(149))-exp(-xt2fac/(xt2+vint(149)))))- 
     &      vint(149)   
          ENDIF 
          xt2=max(0.01*vint(149),xt2)   
        ELSE    
          xt2=(xc2+vint(149))*(1.+vint(149))/(1.+vint(149)- 
     &    rlu(0)*(1.-xc2))-vint(149)    
          xt2=max(0.01*vint(149),xt2)   
        ENDIF   
        vint(25)=xt2    
    
C...Low-pT: choose xT2, tau, y* and cos(theta-hat) fixed.   
        IF(mstp(82).LE.1.AND.xt2.LT.vint(149)) THEN 
          IF(mint(82).EQ.1) ngen(0,1)=ngen(0,1)-1   
          IF(mint(82).EQ.1) ngen(isub,1)=ngen(isub,1)-1 
          isub=95   
          mint(1)=isub  
          vint(21)=0.01*vint(149)   
          vint(22)=0.   
          vint(23)=0.   
          vint(25)=0.01*vint(149)   
    
        ELSE    
C...Multiple interactions (first semihard interaction). 
C...Choose tau and y*. Calculate cos(theta-hat).    
          IF(rlu(0).LE.coef(isub,1)) THEN   
            taup=(2.*(1.+sqrt(1.-xt2))/xt2-1.)**rlu(0)  
            tau=xt2*(1.+taup)**2/(4.*taup)  
          ELSE  
            tau=xt2*(1.+tan(rlu(0)*atan(sqrt(1./xt2-1.)))**2)   
          ENDIF 
          vint(21)=tau  
          CALL pyklim(2)    
          ryst=rlu(0)   
          myst=1    
          IF(ryst.GT.coef(isub,7)) myst=2   
          IF(ryst.GT.coef(isub,7)+coef(isub,8)) myst=3  
          CALL pykmap(2,myst,rlu(0))    
          vint(23)=sqrt(max(0.,1.-xt2/tau))*(-1)**int(1.5+rlu(0))   
        ENDIF   
        vint(71)=0.5*vint(1)*sqrt(vint(25)) 
    
C...Store results of cross-section calculation. 
      ELSEIF(mmul.EQ.4) THEN    
        isub=mint(1)    
        xts=vint(25)    
        IF(iset(isub).EQ.1) xts=vint(21)    
        IF(iset(isub).EQ.2) xts=(4.*vint(48)+2.*vint(63)+2.*vint(64))/  
     &  vint(2) 
        IF(iset(isub).EQ.3.OR.iset(isub).EQ.4) xts=vint(26) 
        rbin=max(0.000001,min(0.999999,xts*(1.+vint(149))/  
     &  (xts+vint(149))))   
        irbin=int(1.+20.*rbin)  
        IF(isub.EQ.96) nmul(irbin)=nmul(irbin)+1    
        IF(isub.EQ.96) sigm(irbin)=sigm(irbin)+vint(153)    
    
C...Choose impact parameter.    
      ELSEIF(mmul.EQ.5) THEN    
        IF(mstp(82).EQ.3) THEN  
          vint(148)=rlu(0)/(paru(2)*vint(147))  
        ELSE    
          rtype=rlu(0)  
          cq2=parp(84)**2   
          IF(rtype.LT.(1.-parp(83))**2) THEN    
            b2=-log(rlu(0)) 
          ELSEIF(rtype.LT.1.-parp(83)**2) THEN  
            b2=-0.5*(1.+cq2)*log(rlu(0))    
          ELSE  
            b2=-cq2*log(rlu(0)) 
          ENDIF 
          vint(148)=((1.-parp(83))**2*exp(-min(100.,b2))+2.*parp(83)*   
     &    (1.-parp(83))*2./(1.+cq2)*exp(-min(100.,b2*2./(1.+cq2)))+ 
     &    parp(83)**2/cq2*exp(-min(100.,b2/cq2)))/(paru(2)*vint(147))   
        ENDIF   
    
C...Multiple interactions (variable impact parameter) : reject with 
C...probability exp(-overlap*cross-section above pT/normalization). 
        rncor=(irbin-20.*rbin)*nmul(irbin)  
        sigcor=(irbin-20.*rbin)*sigm(irbin) 
        DO 150 ibin=irbin+1,20  
        rncor=rncor+nmul(ibin)  
  150   sigcor=sigcor+sigm(ibin)    
        sigabv=(sigcor/rncor)*vint(149)*(1.-xts)/(xts+vint(149))    
        vint(150)=exp(-min(100.,vint(146)*vint(148)*sigabv/vint(106)))  
    
C...Generate additional multiple semihard interactions. 
      ELSEIF(mmul.EQ.6) THEN    
    
C...Reconstruct strings in hard scattering. 
        isub=mint(1)    
        nmax=mint(84)+4 
        IF(iset(isub).EQ.1) nmax=mint(84)+2 
        nstr=0  
        DO 170 i=mint(84)+1,nmax    
        kcs=kchg(lucomp(k(i,2)),2)*isign(1,k(i,2))  
        IF(kcs.EQ.0) goto 170   
        DO 160 j=1,4    
        IF(kcs.EQ.1.AND.(j.EQ.2.OR.j.EQ.4)) goto 160    
        IF(kcs.EQ.-1.AND.(j.EQ.1.OR.j.EQ.3)) goto 160   
        IF(j.LE.2) THEN 
          ist=mod(k(i,j+3)/mstu(5),mstu(5)) 
        ELSE    
          ist=mod(k(i,j+1),mstu(5)) 
        ENDIF   
        IF(ist.LT.mint(84).OR.ist.GT.i) goto 160    
        IF(kchg(lucomp(k(ist,2)),2).EQ.0) goto 160  
        nstr=nstr+1 
        IF(j.EQ.1.OR.j.EQ.4) THEN   
          kstr(nstr,1)=i    
          kstr(nstr,2)=ist  
        ELSE    
          kstr(nstr,1)=ist  
          kstr(nstr,2)=i    
        ENDIF   
  160   CONTINUE    
  170   CONTINUE    
    
C...Set up starting values for iteration in xT2.    
        xt2=vint(25)    
        IF(iset(isub).EQ.1) xt2=vint(21)    
        IF(iset(isub).EQ.2) xt2=(4.*vint(48)+2.*vint(63)+2.*vint(64))/  
     &  vint(2) 
        IF(iset(isub).EQ.3.OR.iset(isub).EQ.4) xt2=vint(26) 
        isub=96 
        mint(1)=96  
        IF(mstp(82).LE.1) THEN  
          xt2fac=xsec(isub,1)*vint(149)/((1.-vint(149))*vint(106))  
        ELSE    
          xt2fac=vint(146)*vint(148)*xsec(isub,1)/vint(106)*    
     &    vint(149)*(1.+vint(149))  
        ENDIF   
        vint(63)=0. 
        vint(64)=0. 
        vint(151)=0.    
        vint(152)=0.    
        vint(143)=1.-vint(141)  
        vint(144)=1.-vint(142)  
    
C...Iterate downwards in xT2.   
  180   IF(mstp(82).LE.1) THEN  
          xt2=xt2fac*xt2/(xt2fac-xt2*log(rlu(0)))   
          IF(xt2.LT.vint(149)) goto 220 
        ELSE    
          IF(xt2.LE.0.01*vint(149)) goto 220    
          xt2=xt2fac*(xt2+vint(149))/(xt2fac-(xt2+vint(149))*   
     &    log(rlu(0)))-vint(149)    
          IF(xt2.LE.0.) goto 220    
          xt2=max(0.01*vint(149),xt2)   
        ENDIF   
        vint(25)=xt2    
    
C...Choose tau and y*. Calculate cos(theta-hat).    
        IF(rlu(0).LE.coef(isub,1)) THEN 
          taup=(2.*(1.+sqrt(1.-xt2))/xt2-1.)**rlu(0)    
          tau=xt2*(1.+taup)**2/(4.*taup)    
        ELSE    
          tau=xt2*(1.+tan(rlu(0)*atan(sqrt(1./xt2-1.)))**2) 
        ENDIF   
        vint(21)=tau    
        CALL pyklim(2)  
        ryst=rlu(0) 
        myst=1  
        IF(ryst.GT.coef(isub,7)) myst=2 
        IF(ryst.GT.coef(isub,7)+coef(isub,8)) myst=3    
        CALL pykmap(2,myst,rlu(0))  
        vint(23)=sqrt(max(0.,1.-xt2/tau))*(-1)**int(1.5+rlu(0)) 
    
C...Check that x not used up. Accept or reject kinematical variables.   
        x1m=sqrt(tau)*exp(vint(22)) 
        x2m=sqrt(tau)*exp(-vint(22))    
        IF(vint(143)-x1m.LT.0.01.OR.vint(144)-x2m.LT.0.01) goto 180 
        vint(71)=0.5*vint(1)*sqrt(xt2)  
        CALL pysigh(nchn,sigs)  
        IF(sigs.LT.xsec(isub,1)*rlu(0)) goto 180    
    
C...Reset K, P and V vectors. Select some variables.    
        DO 190 i=n+1,n+2    
        DO 190 j=1,5    
        k(i,j)=0    
        p(i,j)=0.   
  190   v(i,j)=0.   
        rflav=rlu(0)    
        pt=0.5*vint(1)*sqrt(xt2)    
        phi=paru(2)*rlu(0)  
        cth=vint(23)    
    
C...Add first parton to event record.   
        k(n+1,1)=3  
        k(n+1,2)=21 
        IF(rflav.GE.max(parp(85),parp(86))) k(n+1,2)=   
     &  1+int((2.+parj(2))*rlu(0))  
        p(n+1,1)=pt*cos(phi)    
        p(n+1,2)=pt*sin(phi)    
        p(n+1,3)=0.25*vint(1)*(vint(41)*(1.+cth)-vint(42)*(1.-cth)) 
        p(n+1,4)=0.25*vint(1)*(vint(41)*(1.+cth)+vint(42)*(1.-cth)) 
        p(n+1,5)=0. 
    
C...Add second parton to event record.  
        k(n+2,1)=3  
        k(n+2,2)=21 
        IF(k(n+1,2).NE.21) k(n+2,2)=-k(n+1,2)   
        p(n+2,1)=-p(n+1,1)  
        p(n+2,2)=-p(n+1,2)  
        p(n+2,3)=0.25*vint(1)*(vint(41)*(1.-cth)-vint(42)*(1.+cth)) 
        p(n+2,4)=0.25*vint(1)*(vint(41)*(1.-cth)+vint(42)*(1.+cth)) 
        p(n+2,5)=0. 
    
        IF(rflav.LT.parp(85).AND.nstr.GE.1) THEN    
C....Choose relevant string pieces to place gluons on.  
          DO 210 i=n+1,n+2  
          dmin=1e8  
          DO 200 istr=1,nstr    
          i1=kstr(istr,1)   
          i2=kstr(istr,2)   
          dist=(p(i,4)*p(i1,4)-p(i,1)*p(i1,1)-p(i,2)*p(i1,2)-   
     &    p(i,3)*p(i1,3))*(p(i,4)*p(i2,4)-p(i,1)*p(i2,1)-   
     &    p(i,2)*p(i2,2)-p(i,3)*p(i2,3))/max(1.,p(i1,4)*p(i2,4)-    
     &    p(i1,1)*p(i2,1)-p(i1,2)*p(i2,2)-p(i1,3)*p(i2,3))  
          IF(istr.EQ.1.OR.dist.LT.dmin) THEN    
            dmin=dist   
            ist1=i1 
            ist2=i2 
            istm=istr   
          ENDIF 
  200     CONTINUE  
    
C....Colour flow adjustments, new string pieces.    
          IF(k(ist1,4)/mstu(5).EQ.ist2) k(ist1,4)=mstu(5)*i+    
     &    mod(k(ist1,4),mstu(5))    
          IF(mod(k(ist1,5),mstu(5)).EQ.ist2) k(ist1,5)= 
     &    mstu(5)*(k(ist1,5)/mstu(5))+i 
          k(i,5)=mstu(5)*ist1   
          k(i,4)=mstu(5)*ist2   
          IF(k(ist2,5)/mstu(5).EQ.ist1) k(ist2,5)=mstu(5)*i+    
     &    mod(k(ist2,5),mstu(5))    
          IF(mod(k(ist2,4),mstu(5)).EQ.ist1) k(ist2,4)= 
     &    mstu(5)*(k(ist2,4)/mstu(5))+i 
          kstr(istm,2)=i    
          kstr(nstr+1,1)=i  
          kstr(nstr+1,2)=ist2   
  210     nstr=nstr+1   
    
C...String drawing and colour flow for gluon loop.  
        ELSEIF(k(n+1,2).EQ.21) THEN 
          k(n+1,4)=mstu(5)*(n+2)    
          k(n+1,5)=mstu(5)*(n+2)    
          k(n+2,4)=mstu(5)*(n+1)    
          k(n+2,5)=mstu(5)*(n+1)    
          kstr(nstr+1,1)=n+1    
          kstr(nstr+1,2)=n+2    
          kstr(nstr+2,1)=n+2    
          kstr(nstr+2,2)=n+1    
          nstr=nstr+2   
    
C...String drawing and colour flow for q-qbar pair. 
        ELSE    
          k(n+1,4)=mstu(5)*(n+2)    
          k(n+2,5)=mstu(5)*(n+1)    
          kstr(nstr+1,1)=n+1    
          kstr(nstr+1,2)=n+2    
          nstr=nstr+1   
        ENDIF   
    
C...Update remaining energy; iterate.   
        n=n+2   
        IF(n.GT.mstu(4)-mstu(32)-10) THEN   
          CALL luerrm(11,'(PYMULT:) no more memory left in LUJETS') 
          IF(mstu(21).GE.1) RETURN  
        ENDIF   
        mint(31)=mint(31)+1 
        vint(151)=vint(151)+vint(41)    
        vint(152)=vint(152)+vint(42)    
        vint(143)=vint(143)-vint(41)    
        vint(144)=vint(144)-vint(42)    
        IF(mint(31).LT.240) goto 180    
  220   CONTINUE    
      ENDIF 
    
C...Format statements for printout. 
 1000 FORMAT(/1x,'****** PYMULT: initialization of multiple inter', 
     &'actions for MSTP(82) =',i2,' ******')    
 1100 FORMAT(8x,'pT0 =',f5.2,' GeV gives sigma(parton-parton) =',1p,    
     &e9.2,' mb: rejected') 
 1200 FORMAT(8x,'pT0 =',f5.2,' GeV gives sigma(parton-parton) =',1p,    
     &e9.2,' mb: accepted') 
    
      RETURN    
      END   
    
C*********************************************************************  
    
      SUBROUTINE pyremn(IPU1,IPU2)  
    
C...Adds on target remnants (one or two from each side) and 
C...includes primordial kT. 
      common/hiparnt/hipr1(100),ihpr2(50),hint1(100),ihnt2(50)
      SAVE  /hiparnt/
      common/histrng/nfp(300,15),pphi(300,15),nft(300,15),pthi(300,15)
      SAVE  /histrng/
C...COMMON BLOCK FROM HIJING
      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/ludat2/kchg(500,3),pmas(500,4),parf(2000),vckm(4,4)    
      SAVE /ludat2/ 
      common/pypars/mstp(200),parp(200),msti(200),pari(200) 
      SAVE /pypars/ 
      common/pyint1/mint(400),vint(400) 
      SAVE /pyint1/ 
      dimension kflch(2),kflsp(2),chi(2),pms(6),is(2),robo(5)   
    
C...Special case for lepton-lepton interaction. 
      IF(mint(43).EQ.1) THEN    
        DO 100 jt=1,2   
        i=mint(83)+jt+2 
        k(i,1)=21   
        k(i,2)=k(i-2,2) 
        k(i,3)=i-2  
        DO 100 j=1,5    
  100   p(i,j)=p(i-2,j) 
      ENDIF 
    
C...Find event type, set pointers.  
      IF(ipu1.EQ.0.AND.ipu2.EQ.0) RETURN    
      isub=mint(1)  
      ilep=0    
      IF(ipu1.EQ.0) ilep=1  
      IF(ipu2.EQ.0) ilep=2  
      IF(isub.EQ.95) ilep=-1    
      IF(ilep.EQ.1) iq=mint(84)+1   
      IF(ilep.EQ.2) iq=mint(84)+2   
      ip=max(ipu1,ipu2) 
      ilepr=mint(83)+5-ilep 
      ns=n  
    
C...Define initial partons, including primordial kT.    
  110 DO 130 jt=1,2 
      i=mint(83)+jt+2   
      IF(jt.EQ.1) ipu=ipu1  
      IF(jt.EQ.2) ipu=ipu2  
      k(i,1)=21 
      k(i,3)=i-2    
      IF(isub.EQ.95) THEN   
        k(i,2)=21   
        shs=0.  
      ELSEIF(mint(40+jt).EQ.1.AND.ipu.NE.0) THEN    
        k(i,2)=k(ipu,2) 
        p(i,5)=p(ipu,5) 
        p(i,1)=0.   
        p(i,2)=0.   
        pms(jt)=p(i,5)**2   
      ELSEIF(ipu.NE.0) THEN 
        k(i,2)=k(ipu,2) 
        p(i,5)=p(ipu,5) 
C...No primordial kT or chosen according to truncated Gaussian or   
C...exponential.
C
c     X.N. Wang (7.22.97)
c
        rpt1=0.0
        rpt2=0.0
        ss_w2=(pphi(ihnt2(11),4)+pthi(ihnt2(12),4))**2
     &       -(pphi(ihnt2(11),1)+pthi(ihnt2(12),1))**2
     &       -(pphi(ihnt2(11),2)+pthi(ihnt2(12),2))**2
     &       -(pphi(ihnt2(11),3)+pthi(ihnt2(12),3))**2
C
C********this is s of the current NN collision
        IF(ss_w2.LE.4.0*parp(93)**2) goto 1211
c
        IF(ihpr2(5).LE.0) THEN
120      IF(mstp(91).LE.0) THEN
               pt=0. 
             ELSEIF(mstp(91).EQ.1) THEN
               pt=parp(91)*sqrt(-log(rlu(0)))
             ELSE    
               rpt1=rlu(0)   
               rpt2=rlu(0)   
               pt=-parp(92)*log(rpt1*rpt2)   
             ENDIF   
             IF(pt.GT.parp(93)) goto 120 
       phi=paru(2)*rlu(0)  
       rpt1=pt*cos(phi)  
       rpt2=pt*sin(phi)
  ELSE IF(ihpr2(5).EQ.1) THEN
       IF(jt.EQ.1) jpt=nfp(ihnt2(11),11)
       IF(jt.EQ.2) jpt=nft(ihnt2(12),11)
1205       ptgs=parp(91)*sqrt(-log(rlu(0)))
       IF(ptgs.GT.parp(93)) go to 1205
       phi=2.0*hipr1(40)*rlu(0)
       rpt1=ptgs*cos(phi)
       rpt2=ptgs*sin(phi)
       DO 1210 i_int=1,jpt-1
    pkcsq=parp(91)*sqrt(-log(rlu(0)))
    phi=2.0*hipr1(40)*rlu(0)
    rpt1=rpt1+pkcsq*cos(phi)
    rpt2=rpt2+pkcsq*sin(phi)
1210       CONTINUE
             IF(rpt1**2+rpt2**2.GE.ss_w2/4.0) go to 1205
  ENDIF
C     X.N. Wang
C     ********When initial interaction among soft partons is
C       assumed the primordial pt comes from the sum of
C       pt of JPT-1 number of initial interaction, JPT
C       is the number of interaction including present
C       one that nucleon hassuffered 
1211    p(i,1)=rpt1
  p(i,2)=rpt2  
        pms(jt)=p(i,5)**2+p(i,1)**2+p(i,2)**2   
      ELSE  
        k(i,2)=k(iq,2)  
        q2=vint(52) 
        p(i,5)=-sqrt(q2)    
        pms(jt)=-q2 
        shs=(1.-vint(43-jt))*q2/vint(43-jt)+vint(5-jt)**2   
      ENDIF 
  130 CONTINUE  
    
C...Kinematics construction for initial partons.    
      i1=mint(83)+3 
      i2=mint(83)+4 
      IF(ilep.EQ.0) shs=vint(141)*vint(142)*vint(2)+    
     &(p(i1,1)+p(i2,1))**2+(p(i1,2)+p(i2,2))**2 
      shr=sqrt(max(0.,shs)) 
      IF(ilep.EQ.0) THEN    
        IF((shs-pms(1)-pms(2))**2-4.*pms(1)*pms(2).LE.0.) goto 110  
        p(i1,4)=0.5*(shr+(pms(1)-pms(2))/shr)   
        p(i1,3)=sqrt(max(0.,p(i1,4)**2-pms(1))) 
        p(i2,4)=shr-p(i1,4) 
        p(i2,3)=-p(i1,3)    
      ELSEIF(ilep.EQ.1) THEN    
        p(i1,4)=p(iq,4) 
        p(i1,3)=p(iq,3) 
        p(i2,4)=p(ip,4) 
        p(i2,3)=p(ip,3) 
      ELSEIF(ilep.EQ.2) THEN    
        p(i1,4)=p(ip,4) 
        p(i1,3)=p(ip,3) 
        p(i2,4)=p(iq,4) 
        p(i2,3)=p(iq,3) 
      ENDIF 
      IF(mint(43).EQ.1) RETURN  
    
C...Transform partons to overall CM-frame (not for leptoproduction).    
      IF(ilep.EQ.0) THEN    
        robo(3)=(p(i1,1)+p(i2,1))/shr   
        robo(4)=(p(i1,2)+p(i2,2))/shr   
        CALL ludbrb(i1,i2,0.,0.,-dble(robo(3)),-dble(robo(4)),0d0)  
        robo(2)=ulangl(p(i1,1),p(i1,2)) 
        CALL ludbrb(i1,i2,0.,-robo(2),0d0,0d0,0d0)  
        robo(1)=ulangl(p(i1,3),p(i1,1)) 
        CALL ludbrb(i1,i2,-robo(1),0.,0d0,0d0,0d0)  
        nmax=max(mint(52),ipu1,ipu2)    
        CALL ludbrb(i1,nmax,robo(1),robo(2),dble(robo(3)),dble(robo(4)),    
     &  0d0)    
        robo(5)=max(-0.999999,min(0.999999,(vint(141)-vint(142))/   
     &  (vint(141)+vint(142)))) 
        CALL ludbrb(i1,nmax,0.,0.,0d0,0d0,dble(robo(5)))    
      ENDIF 
    
C...Check invariant mass of remnant system: 
C...hadronic events or leptoproduction. 
      IF(ilep.LE.0) THEN    
        IF(mstp(81).LE.0.OR.mstp(82).LE.0.OR.isub.EQ.95) THEN   
          vint(151)=0.  
          vint(152)=0.  
        ENDIF   
        peh=p(i1,4)+p(i2,4)+0.5*vint(1)*(vint(151)+vint(152))   
        pzh=p(i1,3)+p(i2,3)+0.5*vint(1)*(vint(151)-vint(152))   
        shh=(vint(1)-peh)**2-(p(i1,1)+p(i2,1))**2-(p(i1,2)+p(i2,2))**2- 
     &  pzh**2  
        pmmin=p(mint(83)+1,5)+p(mint(83)+2,5)+ulmass(k(i1,2))+  
     &  ulmass(k(i2,2)) 
        IF(shr.GE.vint(1).OR.shh.LE.(pmmin+parp(111))**2) THEN  
          mint(51)=1    
          RETURN    
        ENDIF   
        shr=sqrt(shh+(p(i1,1)+p(i2,1))**2+(p(i1,2)+p(i2,2))**2) 
      ELSE  
        pei=p(iq,4)+p(ip,4) 
        pzi=p(iq,3)+p(ip,3) 
        pms(ilep)=max(0.,pei**2-pzi**2) 
        pmmin=p(ilepr-2,5)+ulmass(k(ilepr,2))+sqrt(pms(ilep))   
        IF(shr.LE.pmmin+parp(111)) THEN 
          mint(51)=1    
          RETURN    
        ENDIF   
      ENDIF 
    
C...Subdivide remnant if necessary, store first parton. 
  140 i=ns  
      DO 190 jt=1,2 
      IF(jt.EQ.ilep) goto 190   
      IF(jt.EQ.1) ipu=ipu1  
      IF(jt.EQ.2) ipu=ipu2  
      CALL pyspli(mint(10+jt),mint(12+jt),kflch(jt),kflsp(jt))  
      i=i+1 
      is(jt)=i  
      DO 150 j=1,5  
      k(i,j)=0  
      p(i,j)=0. 
  150 v(i,j)=0. 
      k(i,1)=3  
      k(i,2)=kflsp(jt)  
      k(i,3)=mint(83)+jt    
      p(i,5)=ulmass(k(i,2)) 
    
C...First parton colour connections and transverse mass.    
      kfls=(3-kchg(lucomp(kflsp(jt)),2)*isign(1,kflsp(jt)))/2   
      k(i,kfls+3)=ipu   
      k(ipu,6-kfls)=mod(k(ipu,6-kfls),mstu(5))+mstu(5)*i    
      IF(kflch(jt).EQ.0) THEN   
        p(i,1)=-p(mint(83)+jt+2,1)  
        p(i,2)=-p(mint(83)+jt+2,2)  
        pms(jt)=p(i,5)**2+p(i,1)**2+p(i,2)**2   
    
C...When extra remnant parton or hadron: find relative pT, store.   
      ELSE  
        CALL luptdi(1,p(i,1),p(i,2))    
        pms(jt+2)=p(i,5)**2+p(i,1)**2+p(i,2)**2 
        i=i+1   
        DO 160 j=1,5    
        k(i,j)=0    
        p(i,j)=0.   
  160   v(i,j)=0.   
        k(i,1)=1    
        k(i,2)=kflch(jt)    
        k(i,3)=mint(83)+jt  
        p(i,5)=ulmass(k(i,2))   
        p(i,1)=-p(mint(83)+jt+2,1)-p(i-1,1) 
        p(i,2)=-p(mint(83)+jt+2,2)-p(i-1,2) 
        pms(jt+4)=p(i,5)**2+p(i,1)**2+p(i,2)**2 
C...Relative distribution of energy for particle into two jets. 
        imb=1   
        IF(mod(mint(10+jt)/1000,10).NE.0) imb=2 
        IF(iabs(kflch(jt)).LE.10.OR.kflch(jt).EQ.21) THEN   
          chik=parp(92+2*imb)   
          IF(mstp(92).LE.1) THEN    
            IF(imb.EQ.1) chi(jt)=rlu(0) 
            IF(imb.EQ.2) chi(jt)=1.-sqrt(rlu(0))    
          ELSEIF(mstp(92).EQ.2) THEN    
            chi(jt)=1.-rlu(0)**(1./(1.+chik))   
          ELSEIF(mstp(92).EQ.3) THEN    
            cut=2.*0.3/vint(1)  
  170       chi(jt)=rlu(0)**2   
            IF((chi(jt)**2/(chi(jt)**2+cut**2))**0.25*(1.-chi(jt))**chik    
     &      .LT.rlu(0)) goto 170    
          ELSE  
            cut=2.*0.3/vint(1)  
            cutr=(1.+sqrt(1.+cut**2))/cut   
  180       chir=cut*cutr**rlu(0)   
            chi(jt)=(chir**2-cut**2)/(2.*chir)  
            IF((1.-chi(jt))**chik.LT.rlu(0)) goto 180   
          ENDIF 
C...Relative distribution of energy for particle into jet plus particle.    
        ELSE    
          IF(mstp(92).LE.1) THEN    
            IF(imb.EQ.1) chi(jt)=rlu(0) 
            IF(imb.EQ.2) chi(jt)=1.-sqrt(rlu(0))    
          ELSE  
            chi(jt)=1.-rlu(0)**(1./(1.+parp(93+2*imb))) 
          ENDIF 
          IF(mod(kflch(jt)/1000,10).NE.0) chi(jt)=1.-chi(jt)    
        ENDIF   
        pms(jt)=pms(jt+4)/chi(jt)+pms(jt+2)/(1.-chi(jt))    
        kfls=kchg(lucomp(kflch(jt)),2)*isign(1,kflch(jt))   
        IF(kfls.NE.0) THEN  
          k(i,1)=3  
          kfls=(3-kfls)/2   
          k(i,kfls+3)=ipu   
          k(ipu,6-kfls)=mod(k(ipu,6-kfls),mstu(5))+mstu(5)*i    
        ENDIF   
      ENDIF 
  190 CONTINUE  
      IF(shr.LE.sqrt(pms(1))+sqrt(pms(2))) goto 140 
      n=i   
    
C...Reconstruct kinematics of remnants. 
      DO 200 jt=1,2 
      IF(jt.EQ.ilep) goto 200   
      pe=0.5*(shr+(pms(jt)-pms(3-jt))/shr)  
      pz=sqrt(pe**2-pms(jt))    
      IF(kflch(jt).EQ.0) THEN   
        p(is(jt),4)=pe  
        p(is(jt),3)=pz*(-1)**(jt-1) 
      ELSE  
        pw1=chi(jt)*(pe+pz) 
        p(is(jt)+1,4)=0.5*(pw1+pms(jt+4)/pw1)   
        p(is(jt)+1,3)=0.5*(pw1-pms(jt+4)/pw1)*(-1)**(jt-1)  
        p(is(jt),4)=pe-p(is(jt)+1,4)    
        p(is(jt),3)=pz*(-1)**(jt-1)-p(is(jt)+1,3)   
      ENDIF 
  200 CONTINUE  
    
C...Hadronic events: boost remnants to correct longitudinal frame.  
      IF(ilep.LE.0) THEN    
        CALL ludbrb(ns+1,n,0.,0.,0d0,0d0,-dble(pzh/(vint(1)-peh)))  
C...Leptoproduction events: boost colliding subsystem.  
      ELSE  
        nmax=max(ip,mint(52))   
        pef=shr-pe  
        pzf=pz*(-1)**(ilep-1)   
        pt2=p(ilepr,1)**2+p(ilepr,2)**2 
        phipt=ulangl(p(ilepr,1),p(ilepr,2)) 
        CALL ludbrb(mint(84)+1,nmax,0.,-phipt,0d0,0d0,0d0)  
        rqp=p(iq,3)*(pt2+pei**2)-p(iq,4)*pei*pzi    
        sinth=p(iq,4)*sqrt(pt2*(pt2+pei**2)/(rqp**2+pt2*    
     &  p(iq,4)**2*pzi**2))*sign(1.,-rqp)   
        CALL ludbrb(mint(84)+1,nmax,asin(sinth),0.,0d0,0d0,0d0) 
        betax=(-pei*pzi*sinth+sqrt(pt2*(pt2+pei**2-(pzi*sinth)**2)))/   
     &  (pt2+pei**2)    
        CALL ludbrb(mint(84)+1,nmax,0.,0.,dble(betax),0d0,0d0)  
        CALL ludbrb(mint(84)+1,nmax,0.,phipt,0d0,0d0,0d0)   
        pem=p(iq,4)+p(ip,4) 
        pzm=p(iq,3)+p(ip,3) 
        betaz=(-pem*pzm+pzf*sqrt(pzf**2+pem**2-pzm**2))/(pzf**2+pem**2) 
        CALL ludbrb(mint(84)+1,nmax,0.,0.,0d0,0d0,dble(betaz))  
        CALL ludbrb(i1,i2,asin(sinth),0.,dble(betax),0d0,0d0)   
        CALL ludbrb(i1,i2,0.,phipt,0d0,0d0,dble(betaz)) 
      ENDIF 
    
      RETURN    
      END   
    
C*********************************************************************  
    
      SUBROUTINE pyresd 
    
C...Allows resonances to decay (including parton showers for hadronic   
C...channels).  
      IMPLICIT DOUBLE PRECISION(d)  
      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/ludat2/kchg(500,3),pmas(500,4),parf(2000),vckm(4,4)    
      SAVE /ludat2/ 
      common/ludat3/mdcy(500,3),mdme(2000,2),brat(2000),kfdp(2000,5)    
      SAVE /ludat3/ 
      common/pysubs/msel,msub(200),kfin(2,-40:40),ckin(200) 
      SAVE /pysubs/ 
      common/pypars/mstp(200),parp(200),msti(200),pari(200) 
      SAVE /pypars/ 
      common/pyint1/mint(400),vint(400) 
      SAVE /pyint1/ 
      common/pyint2/iset(200),kfpr(200,2),coef(200,20),icol(40,4,2) 
      SAVE /pyint2/ 
      common/pyint4/widp(21:40,0:40),wide(21:40,0:40),wids(21:40,3) 
      SAVE /pyint4/ 
      dimension iref(10,6),kdcy(2),kfl1(2),kfl2(2),nsd(2),ilin(6),  
     &coup(6,4),pk(6,4),pkk(6,6),cthe(2),phi(2),wdtp(0:40), 
     &wdte(0:40,0:5)    
      COMPLEX fgk,ha(6,6),hc(6,6)   
    
C...The F, Xi and Xj functions of Gunion and Kunszt 
C...(Phys. Rev. D33, 665, plus errata from the authors).    
      fgk(i1,i2,i3,i4,i5,i6)=4.*ha(i1,i3)*hc(i2,i6)*(ha(i1,i5)* 
     &hc(i1,i4)+ha(i3,i5)*hc(i3,i4))    
      digk(dt,du)=-4.*d34*d56+dt*(3.*dt+4.*du)+dt**2*(dt*du/(d34*d56)-  
     &2.*(1./d34+1./d56)*(dt+du)+2.*(d34/d56+d56/d34))  
      djgk(dt,du)=8.*(d34+d56)**2-8.*(d34+d56)*(dt+du)-6.*dt*du-    
     &2.*dt*du*(dt*du/(d34*d56)-2.*(1./d34+1./d56)*(dt+du)+ 
     &2.*(d34/d56+d56/d34)) 
    
C...Define initial two objects, initialize loop.    
      isub=mint(1)  
      sh=vint(44)   
      iref(1,5)=0   
      iref(1,6)=0   
      IF(iset(isub).EQ.1.OR.iset(isub).EQ.3) THEN   
        iref(1,1)=mint(84)+2+iset(isub) 
        iref(1,2)=0 
        iref(1,3)=mint(83)+6+iset(isub) 
        iref(1,4)=0 
      ELSEIF(iset(isub).EQ.2.OR.iset(isub).EQ.4) THEN   
        iref(1,1)=mint(84)+1+iset(isub) 
        iref(1,2)=mint(84)+2+iset(isub) 
        iref(1,3)=mint(83)+5+iset(isub) 
        iref(1,4)=mint(83)+6+iset(isub) 
      ENDIF 
      np=1  
      ip=0  
  100 ip=ip+1   
      ninh=0    
    
C...Loop over one/two resonances; reset decay rates.    
      jtmax=2   
      IF(ip.EQ.1.AND.(iset(isub).EQ.1.OR.iset(isub).EQ.3)) jtmax=1  
      DO 140 jt=1,jtmax 
      kdcy(jt)=0    
      kfl1(jt)=0    
      kfl2(jt)=0    
      nsd(jt)=iref(ip,jt)   
      id=iref(ip,jt)    
      IF(id.EQ.0) goto 140  
      kfa=iabs(k(id,2)) 
      IF(kfa.LT.23.OR.kfa.GT.40) goto 140   
      IF(mdcy(kfa,1).NE.0) THEN 
        IF(isub.EQ.1.OR.isub.EQ.141) mint(61)=1 
        CALL pywidt(kfa,p(id,5),wdtp,wdte)  
        IF(kchg(kfa,3).EQ.0) THEN   
          ipm=2 
        ELSE    
          ipm=(5+isign(1,k(id,2)))/2    
        ENDIF   
        IF(jtmax.EQ.1.OR.iabs(k(iref(ip,1),2)).NE.iabs(k(iref(ip,2),2)))    
     &  THEN    
          i12=4 
        ELSE    
          IF(jt.EQ.1) i12=int(4.5+rlu(0))   
          i12=9-i12 
        ENDIF   
        rkfl=(wdte(0,1)+wdte(0,ipm)+wdte(0,i12))*rlu(0) 
        DO 120 i=1,mdcy(kfa,3)  
        idc=i+mdcy(kfa,2)-1 
        kfl1(jt)=kfdp(idc,1)*isign(1,k(id,2))   
        kfl2(jt)=kfdp(idc,2)*isign(1,k(id,2))   
        rkfl=rkfl-(wdte(i,1)+wdte(i,ipm)+wdte(i,i12))   
        IF(rkfl.LE.0.) goto 130 
  120   CONTINUE    
  130   CONTINUE    
      ENDIF 
    
C...Summarize result on decay channel chosen.   
      IF((kfa.EQ.23.OR.kfa.EQ.24).AND.kfl1(jt).EQ.0) ninh=ninh+1    
      IF(kfl1(jt).EQ.0) goto 140    
      kdcy(jt)=2    
      IF(iabs(kfl1(jt)).LE.10.OR.kfl1(jt).EQ.21) kdcy(jt)=1 
      IF((iabs(kfl1(jt)).GE.23.AND.iabs(kfl1(jt)).LE.25).OR.    
     &(iabs(kfl1(jt)).EQ.37)) kdcy(jt)=3    
      nsd(jt)=n 
    
C...Fill decay products, prepared for parton showers for quarks.    
      IF(kdcy(jt).EQ.1) THEN    
        CALL lu2ent(-(n+1),kfl1(jt),kfl2(jt),p(id,5))   
      ELSE  
        CALL lu2ent(n+1,kfl1(jt),kfl2(jt),p(id,5))  
      ENDIF 
      IF(jtmax.EQ.1) THEN   
        cthe(jt)=vint(13)+(vint(33)-vint(13)+vint(34)-vint(14))*rlu(0)  
        IF(cthe(jt).GT.vint(33)) cthe(jt)=cthe(jt)+vint(14)-vint(33)    
        phi(jt)=vint(24)    
      ELSE  
        cthe(jt)=2.*rlu(0)-1.   
        phi(jt)=paru(2)*rlu(0)  
      ENDIF 
  140 CONTINUE  
      IF(mint(3).EQ.1.AND.ip.EQ.1) THEN 
        mint(25)=kfl1(1)    
        mint(26)=kfl2(1)    
      ENDIF 
      IF(jtmax.EQ.1.AND.kdcy(1).EQ.0) goto 530  
      IF(jtmax.EQ.2.AND.kdcy(1).EQ.0.AND.kdcy(2).EQ.0) goto 530 
      IF(mstp(45).LE.0.OR.iref(ip,2).EQ.0.OR.ninh.GE.1) goto 500    
      IF(k(iref(1,1),2).EQ.25.AND.ip.EQ.1) goto 500 
      IF(k(iref(1,1),2).EQ.25.AND.kdcy(1)*kdcy(2).EQ.0) goto 500    
    
C...Order incoming partons and outgoing resonances. 
      ilin(1)=mint(84)+1    
      IF(k(mint(84)+1,2).GT.0) ilin(1)=mint(84)+2   
      IF(k(ilin(1),2).EQ.21) ilin(1)=2*mint(84)+3-ilin(1)   
      ilin(2)=2*mint(84)+3-ilin(1)  
      imin=1    
      IF(iref(ip,5).EQ.25) imin=3   
      imax=2    
      iord=1    
      IF(k(iref(ip,1),2).EQ.23) iord=2  
      IF(k(iref(ip,1),2).EQ.24.AND.k(iref(ip,2),2).EQ.-24) iord=2   
      IF(iabs(k(iref(ip,iord),2)).EQ.25) iord=3-iord    
      IF(kdcy(iord).EQ.0) iord=3-iord   
    
C...Order decay products of resonances. 
      DO 390 jt=iord,3-iord,3-2*iord    
      IF(kdcy(jt).EQ.0) THEN    
        ilin(imax+1)=nsd(jt)    
        imax=imax+1 
      ELSEIF(k(nsd(jt)+1,2).GT.0) THEN  
        ilin(imax+1)=n+2*jt-1   
        ilin(imax+2)=n+2*jt 
        imax=imax+2 
        k(n+2*jt-1,2)=k(nsd(jt)+1,2)    
        k(n+2*jt,2)=k(nsd(jt)+2,2)  
      ELSE  
        ilin(imax+1)=n+2*jt 
        ilin(imax+2)=n+2*jt-1   
        imax=imax+2 
        k(n+2*jt-1,2)=k(nsd(jt)+1,2)    
        k(n+2*jt,2)=k(nsd(jt)+2,2)  
      ENDIF 
  390 CONTINUE  
    
C...Find charge, isospin, left- and righthanded couplings.  
      xw=paru(102)  
      DO 410 i=imin,imax    
      DO 400 j=1,4  
  400 coup(i,j)=0.  
      kfa=iabs(k(ilin(i),2))    
      IF(kfa.GT.20) goto 410    
      coup(i,1)=luchge(kfa)/3.  
      coup(i,2)=(-1)**mod(kfa,2)    
      coup(i,4)=-2.*coup(i,1)*xw    
      coup(i,3)=coup(i,2)+coup(i,4) 
  410 CONTINUE  
      sqmz=pmas(23,1)**2    
      gzmz=pmas(23,1)*pmas(23,2)    
      sqmw=pmas(24,1)**2    
      gzmw=pmas(24,1)*pmas(24,2)    
      sqmzp=pmas(32,1)**2   
      gzmzp=pmas(32,1)*pmas(32,2)   
    
C...Select random angles; construct massless four-vectors.  
  420 DO 430 i=n+1,n+4  
      k(i,1)=1  
      DO 430 j=1,5  
  430 p(i,j)=0. 
      DO 440 jt=1,jtmax 
      IF(kdcy(jt).EQ.0) goto 440    
      id=iref(ip,jt)    
      p(n+2*jt-1,3)=0.5*p(id,5) 
      p(n+2*jt-1,4)=0.5*p(id,5) 
      p(n+2*jt,3)=-0.5*p(id,5)  
      p(n+2*jt,4)=0.5*p(id,5)   
      cthe(jt)=2.*rlu(0)-1. 
      phi(jt)=paru(2)*rlu(0)    
      CALL ludbrb(n+2*jt-1,n+2*jt,acos(cthe(jt)),phi(jt),   
     &dble(p(id,1)/p(id,4)),dble(p(id,2)/p(id,4)),dble(p(id,3)/p(id,4)))    
  440 CONTINUE  
    
C...Store incoming and outgoing momenta, with random rotation to    
C...avoid accidental zeroes in HA expressions.  
      DO 450 i=1,imax   
      k(n+4+i,1)=1  
      p(n+4+i,4)=sqrt(p(ilin(i),1)**2+p(ilin(i),2)**2+p(ilin(i),3)**2+  
     &p(ilin(i),5)**2)  
      p(n+4+i,5)=p(ilin(i),5)   
      DO 450 j=1,3  
  450 p(n+4+i,j)=p(ilin(i),j)   
      therr=acos(2.*rlu(0)-1.)  
      phirr=paru(2)*rlu(0)  
      CALL ludbrb(n+5,n+4+imax,therr,phirr,0d0,0d0,0d0) 
      DO 460 i=1,imax   
      DO 460 j=1,4  
  460 pk(i,j)=p(n+4+i,j)    
    
C...Calculate internal products.    
      IF(isub.EQ.22.OR.isub.EQ.23.OR.isub.EQ.25) THEN   
        DO 470 i1=imin,imax-1   
        DO 470 i2=i1+1,imax 
        ha(i1,i2)=sqrt((pk(i1,4)-pk(i1,3))*(pk(i2,4)+pk(i2,3))/ 
     &  (1e-20+pk(i1,1)**2+pk(i1,2)**2))*cmplx(pk(i1,1),pk(i1,2))-  
     &  sqrt((pk(i1,4)+pk(i1,3))*(pk(i2,4)-pk(i2,3))/   
     &  (1e-20+pk(i2,1)**2+pk(i2,2)**2))*cmplx(pk(i2,1),pk(i2,2))   
        hc(i1,i2)=conjg(ha(i1,i2))  
        IF(i1.LE.2) ha(i1,i2)=cmplx(0.,1.)*ha(i1,i2)    
        IF(i1.LE.2) hc(i1,i2)=cmplx(0.,1.)*hc(i1,i2)    
        ha(i2,i1)=-ha(i1,i2)    
  470   hc(i2,i1)=-hc(i1,i2)    
      ENDIF 
      DO 480 i=1,2  
      DO 480 j=1,4  
  480 pk(i,j)=-pk(i,j)  
      DO 490 i1=imin,imax-1 
      DO 490 i2=i1+1,imax   
      pkk(i1,i2)=2.*(pk(i1,4)*pk(i2,4)-pk(i1,1)*pk(i2,1)-   
     &pk(i1,2)*pk(i2,2)-pk(i1,3)*pk(i2,3))  
  490 pkk(i2,i1)=pkk(i1,i2) 
    
      IF(iref(ip,5).EQ.25) THEN 
C...Angular weight for H0 -> Z0 + Z0 or W+ + W- -> 4 quarks/leptons 
        wt=16.*pkk(3,5)*pkk(4,6)    
        IF(ip.EQ.1) wtmax=sh**2 
        IF(ip.GE.2) wtmax=p(iref(ip,6),5)**4    
    
      ELSEIF(isub.EQ.1) THEN    
        IF(kfa.NE.37) THEN  
C...Angular weight for gamma*/Z0 -> 2 quarks/leptons    
          ei=kchg(iabs(mint(15)),1)/3.  
          ai=sign(1.,ei+0.1)    
          vi=ai-4.*ei*xw    
          ef=kchg(kfa,1)/3. 
          af=sign(1.,ef+0.1)    
          vf=af-4.*ef*xw    
          gg=1. 
          gz=1./(8.*xw*(1.-xw))*sh*(sh-sqmz)/((sh-sqmz)**2+gzmz**2) 
          zz=1./(16.*xw*(1.-xw))**2*sh**2/((sh-sqmz)**2+gzmz**2)    
          IF(mstp(43).EQ.1) THEN    
C...Only gamma* production included 
            gz=0.   
            zz=0.   
          ELSEIF(mstp(43).EQ.2) THEN    
C...Only Z0 production included 
            gg=0.   
            gz=0.   
          ENDIF 
          asym=2.*(ei*ai*gz*ef*af+4.*vi*ai*zz*vf*af)/(ei**2*gg*ef**2+   
     &    ei*vi*gz*ef*vf+(vi**2+ai**2)*zz*(vf**2+af**2))    
          wt=1.+asym*cthe(jt)+cthe(jt)**2   
          wtmax=2.+abs(asym)    
        ELSE    
C...Angular weight for gamma*/Z0 -> H+ + H- 
          wt=1.-cthe(jt)**2 
          wtmax=1.  
        ENDIF   
    
      ELSEIF(isub.EQ.2) THEN    
C...Angular weight for W+/- -> 2 quarks/leptons 
        wt=(1.+cthe(jt))**2 
        wtmax=4.    
    
      ELSEIF(isub.EQ.15.OR.isub.EQ.19) THEN 
C...Angular weight for f + fb -> gluon/gamma + Z0 ->    
C...-> gluon/gamma + 2 quarks/leptons   
        wt=((coup(1,3)*coup(3,3))**2+(coup(1,4)*coup(3,4))**2)* 
     &  (pkk(1,3)**2+pkk(2,4)**2)+((coup(1,3)*coup(3,4))**2+    
     &  (coup(1,4)*coup(3,3))**2)*(pkk(1,4)**2+pkk(2,3)**2) 
        wtmax=(coup(1,3)**2+coup(1,4)**2)*(coup(3,3)**2+coup(3,4)**2)*  
     &  ((pkk(1,3)+pkk(1,4))**2+(pkk(2,3)+pkk(2,4))**2) 
    
      ELSEIF(isub.EQ.16.OR.isub.EQ.20) THEN 
C...Angular weight for f + fb' -> gluon/gamma + W+/- -> 
C...-> gluon/gamma + 2 quarks/leptons   
        wt=pkk(1,3)**2+pkk(2,4)**2  
        wtmax=(pkk(1,3)+pkk(1,4))**2+(pkk(2,3)+pkk(2,4))**2 
    
      ELSEIF(isub.EQ.22) THEN   
C...Angular weight for f + fb -> Z0 + Z0 -> 4 quarks/leptons    
        s34=p(iref(ip,iord),5)**2   
        s56=p(iref(ip,3-iord),5)**2 
        ti=pkk(1,3)+pkk(1,4)+s34    
        ui=pkk(1,5)+pkk(1,6)+s56    
        wt=coup(1,3)**4*((coup(3,3)*coup(5,3)*abs(fgk(1,2,3,4,5,6)/ 
     &  ti+fgk(1,2,5,6,3,4)/ui))**2+(coup(3,4)*coup(5,3)*abs(   
     &  fgk(1,2,4,3,5,6)/ti+fgk(1,2,5,6,4,3)/ui))**2+(coup(3,3)*    
     &  coup(5,4)*abs(fgk(1,2,3,4,6,5)/ti+fgk(1,2,6,5,3,4)/ui))**2+ 
     &  (coup(3,4)*coup(5,4)*abs(fgk(1,2,4,3,6,5)/ti+fgk(1,2,6,5,4,3)/  
     &  ui))**2)+coup(1,4)**4*((coup(3,3)*coup(5,3)*abs(    
     &  fgk(2,1,5,6,3,4)/ti+fgk(2,1,3,4,5,6)/ui))**2+(coup(3,4)*    
     &  coup(5,3)*abs(fgk(2,1,6,5,3,4)/ti+fgk(2,1,3,4,6,5)/ui))**2+ 
     &  (coup(3,3)*coup(5,4)*abs(fgk(2,1,5,6,4,3)/ti+fgk(2,1,4,3,5,6)/  
     &  ui))**2+(coup(3,4)*coup(5,4)*abs(fgk(2,1,6,5,4,3)/ti+   
     &  fgk(2,1,4,3,6,5)/ui))**2)   
        wtmax=4.*s34*s56*(coup(1,3)**4+coup(1,4)**4)*(coup(3,3)**2+ 
     &  coup(3,4)**2)*(coup(5,3)**2+coup(5,4)**2)*4.*(ti/ui+ui/ti+  
     &  2.*sh*(s34+s56)/(ti*ui)-s34*s56*(1./ti**2+1./ui**2))    
    
      ELSEIF(isub.EQ.23) THEN   
C...Angular weight for f + fb' -> Z0 + W +/- -> 4 quarks/leptons    
        d34=p(iref(ip,iord),5)**2   
        d56=p(iref(ip,3-iord),5)**2 
        dt=pkk(1,3)+pkk(1,4)+d34    
        du=pkk(1,5)+pkk(1,6)+d56    
        cawz=coup(2,3)/sngl(dt)-2.*(1.-xw)*coup(1,2)/(sh-sqmw)  
        cbwz=coup(1,3)/sngl(du)+2.*(1.-xw)*coup(1,2)/(sh-sqmw)  
        wt=coup(5,3)**2*abs(cawz*fgk(1,2,3,4,5,6)+cbwz* 
     &  fgk(1,2,5,6,3,4))**2+coup(5,4)**2*abs(cawz* 
     &  fgk(1,2,3,4,6,5)+cbwz*fgk(1,2,6,5,3,4))**2  
        wtmax=4.*d34*d56*(coup(5,3)**2+coup(5,4)**2)*(cawz**2*  
     &  digk(dt,du)+cbwz**2*digk(du,dt)+cawz*cbwz*djgk(dt,du))  
    
      ELSEIF(isub.EQ.24) THEN   
C...Angular weight for f + fb -> Z0 + H0 -> 2 quarks/leptons + H0   
        wt=((coup(1,3)*coup(3,3))**2+(coup(1,4)*coup(3,4))**2)* 
     &  pkk(1,3)*pkk(2,4)+((coup(1,3)*coup(3,4))**2+(coup(1,4)* 
     &  coup(3,3))**2)*pkk(1,4)*pkk(2,3)    
        wtmax=(coup(1,3)**2+coup(1,4)**2)*(coup(3,3)**2+coup(3,4)**2)*  
     &  (pkk(1,3)+pkk(1,4))*(pkk(2,3)+pkk(2,4)) 
    
      ELSEIF(isub.EQ.25) THEN   
C...Angular weight for f + fb -> W+ + W- -> 4 quarks/leptons    
        d34=p(iref(ip,iord),5)**2   
        d56=p(iref(ip,3-iord),5)**2 
        dt=pkk(1,3)+pkk(1,4)+d34    
        du=pkk(1,5)+pkk(1,6)+d56    
        cdww=(coup(1,3)*sqmz/(sh-sqmz)+coup(1,2))/sh    
        caww=cdww+0.5*(coup(1,2)+1.)/sngl(dt)   
        cbww=cdww+0.5*(coup(1,2)-1.)/sngl(du)   
        ccww=coup(1,4)*sqmz/(sh-sqmz)/sh    
        wt=abs(caww*fgk(1,2,3,4,5,6)-cbww*fgk(1,2,5,6,3,4))**2+ 
     &  ccww**2*abs(fgk(2,1,5,6,3,4)-fgk(2,1,3,4,5,6))**2   
        wtmax=4.*d34*d56*(caww**2*digk(dt,du)+cbww**2*digk(du,dt)-caww* 
     &  cbww*djgk(dt,du)+ccww**2*(digk(dt,du)+digk(du,dt)-djgk(dt,du))) 
    
      ELSEIF(isub.EQ.26) THEN   
C...Angular weight for f + fb' -> W+/- + H0 -> 2 quarks/leptons + H0    
        wt=pkk(1,3)*pkk(2,4)    
        wtmax=(pkk(1,3)+pkk(1,4))*(pkk(2,3)+pkk(2,4))   
    
      ELSEIF(isub.EQ.30) THEN   
C...Angular weight for f + g -> f + Z0 -> f + 2 quarks/leptons  
        IF(k(ilin(1),2).GT.0) wt=((coup(1,3)*coup(3,3))**2+ 
     &  (coup(1,4)*coup(3,4))**2)*(pkk(1,4)**2+pkk(3,5)**2)+    
     &  ((coup(1,3)*coup(3,4))**2+(coup(1,4)*coup(3,3))**2)*    
     &  (pkk(1,3)**2+pkk(4,5)**2)   
        IF(k(ilin(1),2).LT.0) wt=((coup(1,3)*coup(3,3))**2+ 
     &  (coup(1,4)*coup(3,4))**2)*(pkk(1,3)**2+pkk(4,5)**2)+    
     &  ((coup(1,3)*coup(3,4))**2+(coup(1,4)*coup(3,3))**2)*    
     &  (pkk(1,4)**2+pkk(3,5)**2)   
        wtmax=(coup(1,3)**2+coup(1,4)**2)*(coup(3,3)**2+coup(3,4)**2)*  
     &  ((pkk(1,3)+pkk(1,4))**2+(pkk(3,5)+pkk(4,5))**2) 
    
      ELSEIF(isub.EQ.31) THEN   
C...Angular weight for f + g -> f' + W+/- -> f' + 2 quarks/leptons  
        IF(k(ilin(1),2).GT.0) wt=pkk(1,4)**2+pkk(3,5)**2    
        IF(k(ilin(1),2).LT.0) wt=pkk(1,3)**2+pkk(4,5)**2    
        wtmax=(pkk(1,3)+pkk(1,4))**2+(pkk(3,5)+pkk(4,5))**2 
    
      ELSEIF(isub.EQ.141) THEN  
C...Angular weight for gamma*/Z0/Z'0 -> 2 quarks/leptons    
        ei=kchg(iabs(mint(15)),1)/3.    
        ai=sign(1.,ei+0.1)  
        vi=ai-4.*ei*xw  
        api=sign(1.,ei+0.1) 
        vpi=api-4.*ei*xw    
        ef=kchg(kfa,1)/3.   
        af=sign(1.,ef+0.1)  
        vf=af-4.*ef*xw  
        apf=sign(1.,ef+0.1) 
        vpf=apf-4.*ef*xw    
        gg=1.   
        gz=1./(8.*xw*(1.-xw))*sh*(sh-sqmz)/((sh-sqmz)**2+gzmz**2)   
        gzp=1./(8.*xw*(1.-xw))*sh*(sh-sqmzp)/((sh-sqmzp)**2+gzmzp**2)   
        zz=1./(16.*xw*(1.-xw))**2*sh**2/((sh-sqmz)**2+gzmz**2)  
        zzp=2./(16.*xw*(1.-xw))**2* 
     &  sh**2*((sh-sqmz)*(sh-sqmzp)+gzmz*gzmzp)/    
     &  (((sh-sqmz)**2+gzmz**2)*((sh-sqmzp)**2+gzmzp**2))   
        zpzp=1./(16.*xw*(1.-xw))**2*sh**2/((sh-sqmzp)**2+gzmzp**2)  
        IF(mstp(44).EQ.1) THEN  
C...Only gamma* production included 
          gz=0. 
          gzp=0.    
          zz=0. 
          zzp=0.    
          zpzp=0.   
        ELSEIF(mstp(44).EQ.2) THEN  
C...Only Z0 production included 
          gg=0. 
          gz=0. 
          gzp=0.    
          zzp=0.    
          zpzp=0.   
        ELSEIF(mstp(44).EQ.3) THEN  
C...Only Z'0 production included    
          gg=0. 
          gz=0. 
          gzp=0.    
          zz=0. 
          zzp=0.    
        ELSEIF(mstp(44).EQ.4) THEN  
C...Only gamma*/Z0 production included  
          gzp=0.    
          zzp=0.    
          zpzp=0.   
        ELSEIF(mstp(44).EQ.5) THEN  
C...Only gamma*/Z'0 production included 
          gz=0. 
          zz=0. 
          zzp=0.    
        ELSEIF(mstp(44).EQ.6) THEN  
C...Only Z0/Z'0 production included 
          gg=0. 
          gz=0. 
          gzp=0.    
        ENDIF   
        asym=2.*(ei*ai*gz*ef*af+ei*api*gzp*ef*apf+4.*vi*ai*zz*vf*af+    
     &  (vi*api+vpi*ai)*zzp*(vf*apf+vpf*af)+4.*vpi*api*zpzp*vpf*apf)/   
     &  (ei**2*gg*ef**2+ei*vi*gz*ef*vf+ei*vpi*gzp*ef*vpf+   
     &  (vi**2+ai**2)*zz*(vf**2+af**2)+(vi*vpi+ai*api)*zzp* 
     &  (vf*vpf+af*apf)+(vpi**2+api**2)*zpzp*(vpf**2+apf**2))   
        wt=1.+asym*cthe(jt)+cthe(jt)**2 
        wtmax=2.+abs(asym)  
    
      ELSE  
        wt=1.   
        wtmax=1.    
      ENDIF 
C...Obtain correct angular distribution by rejection techniques.    
      IF(wt.LT.rlu(0)*wtmax) goto 420   
    
C...Construct massive four-vectors using angles chosen. Mark decayed    
C...resonances, add documentation lines. Shower evolution.  
  500 DO 520 jt=1,jtmax 
      IF(kdcy(jt).EQ.0) goto 520    
      id=iref(ip,jt)    
      CALL ludbrb(nsd(jt)+1,nsd(jt)+2,acos(cthe(jt)),phi(jt),   
     &dble(p(id,1)/p(id,4)),dble(p(id,2)/p(id,4)),dble(p(id,3)/p(id,4)))    
      k(id,1)=k(id,1)+10    
      k(id,4)=nsd(jt)+1 
      k(id,5)=nsd(jt)+2 
      idoc=mint(83)+mint(4) 
      DO 510 i=nsd(jt)+1,nsd(jt)+2  
      mint(4)=mint(4)+1 
      i1=mint(83)+mint(4)   
      k(i,3)=i1 
      k(i1,1)=21    
      k(i1,2)=k(i,2)    
      k(i1,3)=iref(ip,jt+2) 
      DO 510 j=1,5  
  510 p(i1,j)=p(i,j)    
      IF(jtmax.EQ.1) THEN   
        mint(7)=mint(83)+6+2*iset(isub) 
        mint(8)=mint(83)+7+2*iset(isub) 
      ENDIF 
      IF(mstp(71).GE.1.AND.kdcy(jt).EQ.1) CALL lushow(nsd(jt)+1,    
     &nsd(jt)+2,p(id,5))    
    
C...Check if new resonances were produced, loop back if needed. 
      IF(kdcy(jt).NE.3) goto 520    
      np=np+1   
      iref(np,1)=nsd(jt)+1  
      iref(np,2)=nsd(jt)+2  
      iref(np,3)=idoc+1 
      iref(np,4)=idoc+2 
      iref(np,5)=k(iref(ip,jt),2)   
      iref(np,6)=iref(ip,jt)    
  520 CONTINUE  
  530 IF(ip.LT.np) goto 100 
    
      RETURN    
      END   
    
C*********************************************************************  
    
      SUBROUTINE pydiff 
    
C...Handles diffractive and elastic scattering. 
      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/pypars/mstp(200),parp(200),msti(200),pari(200) 
      SAVE /pypars/ 
      common/pyint1/mint(400),vint(400) 
      SAVE /pyint1/ 
    
C...Reset K, P and V vectors. Store incoming particles. 
      DO 100 jt=1,mstp(126)+10  
      i=mint(83)+jt 
      DO 100 j=1,5  
      k(i,j)=0  
      p(i,j)=0. 
  100 v(i,j)=0. 
      n=mint(84)    
      mint(3)=0 
      mint(21)=0    
      mint(22)=0    
      mint(23)=0    
      mint(24)=0    
      mint(4)=4 
      DO 110 jt=1,2 
      i=mint(83)+jt 
      k(i,1)=21 
      k(i,2)=mint(10+jt)    
      p(i,5)=vint(2+jt) 
      p(i,3)=vint(5)*(-1)**(jt+1)   
  110 p(i,4)=sqrt(p(i,3)**2+p(i,5)**2)  
      mint(6)=2 
    
C...Subprocess; kinematics. 
      isub=mint(1)  
      sqlam=(vint(2)-vint(63)-vint(64))**2-4.*vint(63)*vint(64) 
      pz=sqrt(sqlam)/(2.*vint(1))   
      DO 150 jt=1,2 
      i=mint(83)+jt 
      pe=(vint(2)+vint(62+jt)-vint(65-jt))/(2.*vint(1)) 
    
C...Elastically scattered particle. 
      IF(mint(16+jt).LE.0) THEN 
        n=n+1   
        k(n,1)=1    
        k(n,2)=k(i,2)   
        k(n,3)=i+2  
        p(n,3)=pz*(-1)**(jt+1)  
        p(n,4)=pe   
        p(n,5)=p(i,5)   
    
C...Diffracted particle: valence quark kicked out.  
      ELSEIF(mstp(101).EQ.1) THEN   
        n=n+2   
        k(n-1,1)=2  
        k(n,1)=1    
        k(n-1,3)=i+2    
        k(n,3)=i+2  
        CALL pyspli(k(i,2),21,k(n,2),k(n-1,2))  
        p(n-1,5)=ulmass(k(n-1,2))   
        p(n,5)=ulmass(k(n,2))   
        sqlam=(vint(62+jt)-p(n-1,5)**2-p(n,5)**2)**2-   
     &  4.*p(n-1,5)**2*p(n,5)**2    
        p(n-1,3)=(pe*sqrt(sqlam)+pz*(vint(62+jt)+p(n-1,5)**2-   
     &  p(n,5)**2))/(2.*vint(62+jt))*(-1)**(jt+1)   
        p(n-1,4)=sqrt(p(n-1,3)**2+p(n-1,5)**2)  
        p(n,3)=pz*(-1)**(jt+1)-p(n-1,3) 
        p(n,4)=sqrt(p(n,3)**2+p(n,5)**2)    
    
C...Diffracted particle: gluon kicked out.  
      ELSE  
        n=n+3   
        k(n-2,1)=2  
        k(n-1,1)=2  
        k(n,1)=1    
        k(n-2,3)=i+2    
        k(n-1,3)=i+2    
        k(n,3)=i+2  
        CALL pyspli(k(i,2),21,k(n,2),k(n-2,2))  
        k(n-1,2)=21 
        p(n-2,5)=ulmass(k(n-2,2))   
        p(n-1,5)=0. 
        p(n,5)=ulmass(k(n,2))   
C...Energy distribution for particle into two jets. 
  120   imb=1   
        IF(mod(k(i,2)/1000,10).NE.0) imb=2  
        chik=parp(92+2*imb) 
        IF(mstp(92).LE.1) THEN  
          IF(imb.EQ.1) chi=rlu(0)   
          IF(imb.EQ.2) chi=1.-sqrt(rlu(0))  
        ELSEIF(mstp(92).EQ.2) THEN  
          chi=1.-rlu(0)**(1./(1.+chik)) 
        ELSEIF(mstp(92).EQ.3) THEN  
          cut=2.*0.3/vint(1)    
  130     chi=rlu(0)**2 
          IF((chi**2/(chi**2+cut**2))**0.25*(1.-chi)**chik.LT.  
     &    rlu(0)) goto 130  
        ELSE    
          cut=2.*0.3/vint(1)    
          cutr=(1.+sqrt(1.+cut**2))/cut 
  140     chir=cut*cutr**rlu(0) 
          chi=(chir**2-cut**2)/(2.*chir)    
          IF((1.-chi)**chik.LT.rlu(0)) goto 140 
        ENDIF   
        IF(chi.LT.p(n,5)**2/vint(62+jt).OR.chi.GT.1.-p(n-2,5)**2/   
     &  vint(62+jt)) goto 120   
        sqm=p(n-2,5)**2/(1.-chi)+p(n,5)**2/chi  
        IF((sqrt(sqm)+parj(32))**2.GE.vint(62+jt)) goto 120 
        pzi=(pe*(vint(62+jt)-sqm)+pz*(vint(62+jt)+sqm))/    
     &  (2.*vint(62+jt))    
        pei=sqrt(pzi**2+sqm)    
        pqqp=(1.-chi)*(pei+pzi) 
        p(n-2,3)=0.5*(pqqp-p(n-2,5)**2/pqqp)*(-1)**(jt+1)   
        p(n-2,4)=sqrt(p(n-2,3)**2+p(n-2,5)**2)  
        p(n-1,3)=(pz-pzi)*(-1)**(jt+1)  
        p(n-1,4)=abs(p(n-1,3))  
        p(n,3)=pzi*(-1)**(jt+1)-p(n-2,3)    
        p(n,4)=sqrt(p(n,3)**2+p(n,5)**2)    
      ENDIF 
    
C...Documentation lines.    
      k(i+2,1)=21   
      IF(mint(16+jt).EQ.0) k(i+2,2)=mint(10+jt) 
      IF(mint(16+jt).NE.0) k(i+2,2)=10*(mint(10+jt)/10) 
      k(i+2,3)=i    
      p(i+2,3)=pz*(-1)**(jt+1)  
      p(i+2,4)=pe   
      p(i+2,5)=sqrt(vint(62+jt))    
  150 CONTINUE  
    
C...Rotate outgoing partons/particles using cos(theta). 
      CALL ludbrb(mint(83)+3,n,acos(vint(23)),vint(24),0d0,0d0,0d0) 
    
      RETURN    
      END   
    
C*********************************************************************  
    
      SUBROUTINE pyfram(IFRAME) 
    
C...Performs transformations between different coordinate frames.   
      common/ludat1/mstu(200),paru(200),mstj(200),parj(200) 
      SAVE /ludat1/ 
      common/pypars/mstp(200),parp(200),msti(200),pari(200) 
      SAVE /pypars/ 
      common/pyint1/mint(400),vint(400) 
      SAVE /pyint1/ 
    
      IF(iframe.LT.1.OR.iframe.GT.2) THEN   
        WRITE(mstu(11),1000) iframe,mint(6) 
        RETURN  
      ENDIF 
      IF(iframe.EQ.mint(6)) RETURN  
    
      IF(mint(6).EQ.1) THEN 
C...Transform from fixed target or user specified frame to  
C...CM-frame of incoming particles. 
        CALL lurobo(0.,0.,-vint(8),-vint(9),-vint(10))  
        CALL lurobo(0.,-vint(7),0.,0.,0.)   
        CALL lurobo(-vint(6),0.,0.,0.,0.)   
        mint(6)=2   
    
      ELSE  
C...Transform from particle CM-frame to fixed target or user specified  
C...frame.  
        CALL lurobo(vint(6),vint(7),vint(8),vint(9),vint(10))   
        mint(6)=1   
      ENDIF 
      msti(6)=mint(6)   
    
 1000 FORMAT(1x,'Error: illegal values in subroutine PYFRAM.',1x,   
     &'No transformation performed.'/1x,'IFRAME =',1x,i5,'; MINT(6) =', 
     &1x,i5)    
    
      RETURN    
      END   
    
C*********************************************************************  
    
      SUBROUTINE pywidt(KFLR,RMAS,WDTP,WDTE)    
    
C...Calculates full and partial widths of resonances.   
      common/ludat1/mstu(200),paru(200),mstj(200),parj(200) 
      SAVE /ludat1/ 
      common/ludat2/kchg(500,3),pmas(500,4),parf(2000),vckm(4,4)    
      SAVE /ludat2/ 
      common/ludat3/mdcy(500,3),mdme(2000,2),brat(2000),kfdp(2000,5)    
      SAVE /ludat3/ 
      common/pypars/mstp(200),parp(200),msti(200),pari(200) 
      SAVE /pypars/ 
      common/pyint1/mint(400),vint(400) 
      SAVE /pyint1/ 
      common/pyint4/widp(21:40,0:40),wide(21:40,0:40),wids(21:40,3) 
      SAVE /pyint4/ 
      dimension wdtp(0:40),wdte(0:40,0:5)   
    
C...Some common constants.  
      kfla=iabs(kflr)   
      sqm=rmas**2   
      as=ulalps(sqm)    
      aem=paru(101) 
      xw=paru(102)  
      radc=1.+as/paru(1)    
    
C...Reset width information.    
      DO 100 i=0,40 
      wdtp(i)=0.    
      DO 100 j=0,5  
  100 wdte(i,j)=0.  
    
      IF(kfla.EQ.21) THEN   
C...QCD:    
        DO 110 i=1,mdcy(21,3)   
        idc=i+mdcy(21,2)-1  
        rm1=(pmas(iabs(kfdp(idc,1)),1)/rmas)**2 
        rm2=(pmas(iabs(kfdp(idc,2)),1)/rmas)**2 
        IF(sqrt(rm1)+sqrt(rm2).GT.1..OR.mdme(idc,1).LT.0) goto 110  
        IF(i.LE.8) THEN 
C...QCD -> q + qb   
          wdtp(i)=(1.+2.*rm1)*sqrt(max(0.,1.-4.*rm1))   
          wid2=1.   
        ENDIF   
        wdtp(0)=wdtp(0)+wdtp(i) 
        IF(mdme(idc,1).GT.0) THEN   
          wdte(i,mdme(idc,1))=wdtp(i)*wid2  
          wdte(0,mdme(idc,1))=wdte(0,mdme(idc,1))+wdte(i,mdme(idc,1))   
          wdte(i,0)=wdte(i,mdme(idc,1)) 
          wdte(0,0)=wdte(0,0)+wdte(i,0) 
        ENDIF   
  110   CONTINUE    
    
      ELSEIF(kfla.EQ.23) THEN   
C...Z0: 
        IF(mint(61).EQ.1) THEN  
          ei=kchg(iabs(mint(15)),1)/3.  
          ai=sign(1.,ei)    
          vi=ai-4.*ei*xw    
          sqmz=pmas(23,1)**2    
          gzmz=pmas(23,2)*pmas(23,1)    
          ggi=ei**2 
          gzi=ei*vi/(8.*xw*(1.-xw))*sqm*(sqm-sqmz)/ 
     &    ((sqm-sqmz)**2+gzmz**2)   
          zzi=(vi**2+ai**2)/(16.*xw*(1.-xw))**2*sqm**2/ 
     &    ((sqm-sqmz)**2+gzmz**2)   
          IF(mstp(43).EQ.1) THEN    
C...Only gamma* production included 
            gzi=0.  
            zzi=0.  
          ELSEIF(mstp(43).EQ.2) THEN    
C...Only Z0 production included 
            ggi=0.  
            gzi=0.  
          ENDIF 
        ELSEIF(mint(61).EQ.2) THEN  
          vint(111)=0.  
          vint(112)=0.  
          vint(114)=0.  
        ENDIF   
        DO 120 i=1,mdcy(23,3)   
        idc=i+mdcy(23,2)-1  
        rm1=(pmas(iabs(kfdp(idc,1)),1)/rmas)**2 
        rm2=(pmas(iabs(kfdp(idc,2)),1)/rmas)**2 
        IF(sqrt(rm1)+sqrt(rm2).GT.1..OR.mdme(idc,1).LT.0) goto 120  
        IF(i.LE.8) THEN 
C...Z0 -> q + qb    
          ef=kchg(i,1)/3.   
          af=sign(1.,ef+0.1)    
          vf=af-4.*ef*xw    
          IF(mint(61).EQ.0) THEN    
            wdtp(i)=3.*(vf**2*(1.+2.*rm1)+af**2*(1.-4.*rm1))*   
     &      sqrt(max(0.,1.-4.*rm1))*radc    
          ELSEIF(mint(61).EQ.1) THEN    
            wdtp(i)=3.*((ggi*ef**2+gzi*ef*vf+zzi*vf**2)*    
     &      (1.+2.*rm1)+zzi*af**2*(1.-4.*rm1))* 
     &      sqrt(max(0.,1.-4.*rm1))*radc    
          ELSEIF(mint(61).EQ.2) THEN    
            ggf=3.*ef**2*(1.+2.*rm1)*sqrt(max(0.,1.-4.*rm1))*radc   
            gzf=3.*ef*vf*(1.+2.*rm1)*sqrt(max(0.,1.-4.*rm1))*radc   
            zzf=3.*(vf**2*(1.+2.*rm1)+af**2*(1.-4.*rm1))*   
     &      sqrt(max(0.,1.-4.*rm1))*radc    
          ENDIF 
          wid2=1.   
        ELSEIF(i.LE.16) THEN    
C...Z0 -> l+ + l-, nu + nub 
          ef=kchg(i+2,1)/3. 
          af=sign(1.,ef+0.1)    
          vf=af-4.*ef*xw    
          wdtp(i)=(vf**2*(1.+2.*rm1)+af**2*(1.-4.*rm1))*    
     &    sqrt(max(0.,1.-4.*rm1))   
          IF(mint(61).EQ.0) THEN    
            wdtp(i)=(vf**2*(1.+2.*rm1)+af**2*(1.-4.*rm1))*  
     &      sqrt(max(0.,1.-4.*rm1)) 
          ELSEIF(mint(61).EQ.1) THEN    
            wdtp(i)=((ggi*ef**2+gzi*ef*vf+zzi*vf**2)*   
     &      (1.+2.*rm1)+zzi*af**2*(1.-4.*rm1))* 
     &      sqrt(max(0.,1.-4.*rm1)) 
          ELSEIF(mint(61).EQ.2) THEN    
            ggf=ef**2*(1.+2.*rm1)*sqrt(max(0.,1.-4.*rm1))   
            gzf=ef*vf*(1.+2.*rm1)*sqrt(max(0.,1.-4.*rm1))   
            zzf=(vf**2*(1.+2.*rm1)+af**2*(1.-4.*rm1))*  
     &      sqrt(max(0.,1.-4.*rm1)) 
          ENDIF 
          wid2=1.   
        ELSE    
C...Z0 -> H+ + H-   
          cf=2.*(1.-2.*xw)  
          IF(mint(61).EQ.0) THEN    
            wdtp(i)=0.25*cf**2*(1.-4.*rm1)*sqrt(max(0.,1.-4.*rm1))  
          ELSEIF(mint(61).EQ.1) THEN    
            wdtp(i)=0.25*(ggi+gzi*cf+zzi*cf**2)*(1.-4.*rm1)*    
     &      sqrt(max(0.,1.-4.*rm1)) 
          ELSEIF(mint(61).EQ.2) THEN    
            ggf=0.25*(1.-4.*rm1)*sqrt(max(0.,1.-4.*rm1))    
            gzf=0.25*cf*(1.-4.*rm1)*sqrt(max(0.,1.-4.*rm1)) 
            zzf=0.25*cf**2*(1.-4.*rm1)*sqrt(max(0.,1.-4.*rm1))  
          ENDIF 
          wid2=wids(37,1)   
        ENDIF   
        wdtp(0)=wdtp(0)+wdtp(i) 
        IF(mdme(idc,1).GT.0) THEN   
          wdte(i,mdme(idc,1))=wdtp(i)*wid2  
          wdte(0,mdme(idc,1))=wdte(0,mdme(idc,1))+wdte(i,mdme(idc,1))   
          wdte(i,0)=wdte(i,mdme(idc,1)) 
          wdte(0,0)=wdte(0,0)+wdte(i,0) 
          vint(111)=vint(111)+ggf*wid2  
          vint(112)=vint(112)+gzf*wid2  
          vint(114)=vint(114)+zzf*wid2  
        ENDIF   
  120   CONTINUE    
        IF(mstp(43).EQ.1) THEN  
C...Only gamma* production included 
          vint(112)=0.  
          vint(114)=0.  
        ELSEIF(mstp(43).EQ.2) THEN  
C...Only Z0 production included 
          vint(111)=0.  
          vint(112)=0.  
        ENDIF   
    
      ELSEIF(kfla.EQ.24) THEN   
C...W+/-:   
        DO 130 i=1,mdcy(24,3)   
        idc=i+mdcy(24,2)-1  
        rm1=(pmas(iabs(kfdp(idc,1)),1)/rmas)**2 
        rm2=(pmas(iabs(kfdp(idc,2)),1)/rmas)**2 
        IF(sqrt(rm1)+sqrt(rm2).GT.1..OR.mdme(idc,1).LT.0) goto 130  
        IF(i.LE.16) THEN    
C...W+/- -> q + qb' 
          wdtp(i)=3.*(2.-rm1-rm2-(rm1-rm2)**2)* 
     &    sqrt(max(0.,(1.-rm1-rm2)**2-4.*rm1*rm2))* 
     &    vckm((i-1)/4+1,mod(i-1,4)+1)*radc 
          wid2=1.   
        ELSE    
C...W+/- -> l+/- + nu   
          wdtp(i)=(2.-rm1-rm2-(rm1-rm2)**2)*    
     &    sqrt(max(0.,(1.-rm1-rm2)**2-4.*rm1*rm2))  
          wid2=1.   
        ENDIF   
        wdtp(0)=wdtp(0)+wdtp(i) 
        IF(mdme(idc,1).GT.0) THEN   
          wdte(i,mdme(idc,1))=wdtp(i)*wid2  
          wdte(0,mdme(idc,1))=wdte(0,mdme(idc,1))+wdte(i,mdme(idc,1))   
          wdte(i,0)=wdte(i,mdme(idc,1)) 
          wdte(0,0)=wdte(0,0)+wdte(i,0) 
        ENDIF   
  130   CONTINUE    
    
      ELSEIF(kfla.EQ.25) THEN   
C...H0: 
        DO 170 i=1,mdcy(25,3)   
        idc=i+mdcy(25,2)-1  
        rm1=(pmas(iabs(kfdp(idc,1)),1)/rmas)**2 
        rm2=(pmas(iabs(kfdp(idc,2)),1)/rmas)**2 
        IF(sqrt(rm1)+sqrt(rm2).GT.1..OR.mdme(idc,1).LT.0) goto 170  
        IF(i.LE.8) THEN 
C...H0 -> q + qb    
          wdtp(i)=3.*rm1*(1.-4.*rm1)*sqrt(max(0.,1.-4.*rm1))*radc   
          wid2=1.   
        ELSEIF(i.LE.12) THEN    
C...H0 -> l+ + l-   
          wdtp(i)=rm1*(1.-4.*rm1)*sqrt(max(0.,1.-4.*rm1))   
          wid2=1.   
        ELSEIF(i.EQ.13) THEN    
C...H0 -> g + g; quark loop contribution only   
          etare=0.  
          etaim=0.  
          DO 140 j=1,2*mstp(1)  
          eps=(2.*pmas(j,1)/rmas)**2    
          IF(eps.LE.1.) THEN    
            IF(eps.GT.1.e-4) THEN   
              root=sqrt(1.-eps) 
              rln=log((1.+root)/(1.-root))  
            ELSE    
              rln=log(4./eps-2.)    
            ENDIF   
            phire=0.25*(rln**2-paru(1)**2)  
            phiim=0.5*paru(1)*rln   
          ELSE  
            phire=-(asin(1./sqrt(eps)))**2  
            phiim=0.    
          ENDIF 
          etare=etare+0.5*eps*(1.+(eps-1.)*phire)   
          etaim=etaim+0.5*eps*(eps-1.)*phiim    
  140     CONTINUE  
          eta2=etare**2+etaim**2    
          wdtp(i)=(as/paru(1))**2*eta2  
          wid2=1.   
        ELSEIF(i.EQ.14) THEN    
C...H0 -> gamma + gamma; quark, charged lepton and W loop contributions 
          etare=0.  
          etaim=0.  
          DO 150 j=1,3*mstp(1)+1    
          IF(j.LE.2*mstp(1)) THEN   
            ej=kchg(j,1)/3. 
            eps=(2.*pmas(j,1)/rmas)**2  
          ELSEIF(j.LE.3*mstp(1)) THEN   
            jl=2*(j-2*mstp(1))-1    
            ej=kchg(10+jl,1)/3. 
            eps=(2.*pmas(10+jl,1)/rmas)**2  
          ELSE  
            eps=(2.*pmas(24,1)/rmas)**2 
          ENDIF 
          IF(eps.LE.1.) THEN    
            IF(eps.GT.1.e-4) THEN   
              root=sqrt(1.-eps) 
              rln=log((1.+root)/(1.-root))  
            ELSE    
              rln=log(4./eps-2.)    
            ENDIF   
            phire=0.25*(rln**2-paru(1)**2)  
            phiim=0.5*paru(1)*rln   
          ELSE  
            phire=-(asin(1./sqrt(eps)))**2  
            phiim=0.    
          ENDIF 
          IF(j.LE.2*mstp(1)) THEN   
            etare=etare+0.5*3.*ej**2*eps*(1.+(eps-1.)*phire)    
            etaim=etaim+0.5*3.*ej**2*eps*(eps-1.)*phiim 
          ELSEIF(j.LE.3*mstp(1)) THEN   
            etare=etare+0.5*ej**2*eps*(1.+(eps-1.)*phire)   
            etaim=etaim+0.5*ej**2*eps*(eps-1.)*phiim    
          ELSE  
            etare=etare-0.5-0.75*eps*(1.+(eps-2.)*phire)    
            etaim=etaim+0.75*eps*(eps-2.)*phiim 
          ENDIF 
  150     CONTINUE  
          eta2=etare**2+etaim**2    
          wdtp(i)=(aem/paru(1))**2*0.5*eta2 
          wid2=1.   
        ELSEIF(i.EQ.15) THEN    
C...H0 -> gamma + Z0; quark, charged lepton and W loop contributions    
          etare=0.  
          etaim=0.  
          DO 160 j=1,3*mstp(1)+1    
          IF(j.LE.2*mstp(1)) THEN   
            ej=kchg(j,1)/3. 
            aj=sign(1.,ej+0.1)  
            vj=aj-4.*ej*xw  
            eps=(2.*pmas(j,1)/rmas)**2  
            epsp=(2.*pmas(j,1)/pmas(23,1))**2   
          ELSEIF(j.LE.3*mstp(1)) THEN   
            jl=2*(j-2*mstp(1))-1    
            ej=kchg(10+jl,1)/3. 
            aj=sign(1.,ej+0.1)  
            vj=ai-4.*ej*xw  
            eps=(2.*pmas(10+jl,1)/rmas)**2  
            epsp=(2.*pmas(10+jl,1)/pmas(23,1))**2   
          ELSE  
            eps=(2.*pmas(24,1)/rmas)**2 
            epsp=(2.*pmas(24,1)/pmas(23,1))**2  
          ENDIF 
          IF(eps.LE.1.) THEN    
            root=sqrt(1.-eps)   
            IF(eps.GT.1.e-4) THEN   
              rln=log((1.+root)/(1.-root))  
            ELSE    
              rln=log(4./eps-2.)    
            ENDIF   
            phire=0.25*(rln**2-paru(1)**2)  
            phiim=0.5*paru(1)*rln   
            psire=-(1.+0.5*root*rln)    
            psiim=0.5*paru(1)*root  
          ELSE  
            phire=-(asin(1./sqrt(eps)))**2  
            phiim=0.    
            psire=-(1.+sqrt(eps-1.)*asin(1./sqrt(eps))) 
            psiim=0.    
          ENDIF 
          IF(epsp.LE.1.) THEN   
            root=sqrt(1.-epsp)  
            IF(epsp.GT.1.e-4) THEN  
              rln=log((1.+root)/(1.-root))  
            ELSE    
              rln=log(4./epsp-2.)   
            ENDIF   
            phirep=0.25*(rln**2-paru(1)**2) 
            phiimp=0.5*paru(1)*rln  
            psirep=-(1.+0.5*root*rln)   
            psiimp=0.5*paru(1)*root 
          ELSE  
            phirep=-(asin(1./sqrt(epsp)))**2    
            phiimp=0.   
            psirep=-(1.+sqrt(epsp-1.)*asin(1./sqrt(epsp)))  
            psiimp=0.   
          ENDIF 
          fxyre=eps*epsp/(8.*(eps-epsp))*(1.-eps*epsp/(eps-epsp)*(phire-    
     &    phirep)+2.*eps/(eps-epsp)*(psire-psirep)) 
          fxyim=eps*epsp/(8.*(eps-epsp))*(-eps*epsp/(eps-epsp)*(phiim-  
     &    phiimp)+2.*eps/(eps-epsp)*(psiim-psiimp)) 
          f1re=eps*epsp/(2.*(eps-epsp))*(phire-phirep)  
          f1im=eps*epsp/(2.*(eps-epsp))*(phiim-phiimp)  
          IF(j.LE.2*mstp(1)) THEN   
            etare=etare-3.*ej*vj*(fxyre-0.25*f1re)  
            etaim=etaim-3.*ej*vj*(fxyim-0.25*f1im)  
          ELSEIF(j.LE.3*mstp(1)) THEN   
            etare=etare-ej*vj*(fxyre-0.25*f1re) 
            etaim=etaim-ej*vj*(fxyim-0.25*f1im) 
          ELSE  
            etare=etare-sqrt(1.-xw)*(((1.+2./eps)*xw/sqrt(1.-xw)-   
     &      (5.+2./eps))*fxyre+(3.-xw/sqrt(1.-xw))*f1re)    
            etaim=etaim-sqrt(1.-xw)*(((1.+2./eps)*xw/sqrt(1.-xw)-   
     &      (5.+2./eps))*fxyim+(3.-xw/sqrt(1.-xw))*f1im)    
          ENDIF 
  160     CONTINUE  
          eta2=etare**2+etaim**2    
          wdtp(i)=(aem/paru(1))**2*(1.-(pmas(23,1)/rmas)**2)**3/xw*eta2 
          wid2=wids(23,2)   
        ELSE    
C...H0 -> Z0 + Z0, W+ + W-  
          wdtp(i)=(1.-4.*rm1+12.*rm1**2)*sqrt(max(0.,1.-4.*rm1))/   
     &    (2.*(18-i))   
          wid2=wids(7+i,1)  
        ENDIF   
        wdtp(0)=wdtp(0)+wdtp(i) 
        IF(mdme(idc,1).GT.0) THEN   
          wdte(i,mdme(idc,1))=wdtp(i)*wid2  
          wdte(0,mdme(idc,1))=wdte(0,mdme(idc,1))+wdte(i,mdme(idc,1))   
          wdte(i,0)=wdte(i,mdme(idc,1)) 
          wdte(0,0)=wdte(0,0)+wdte(i,0) 
        ENDIF   
  170   CONTINUE    
    
      ELSEIF(kfla.EQ.32) THEN   
C...Z'0:    
        IF(mint(61).EQ.1) THEN  
          ei=kchg(iabs(mint(15)),1)/3.  
          ai=sign(1.,ei)    
          vi=ai-4.*ei*xw    
          sqmz=pmas(23,1)**2    
          gzmz=pmas(23,2)*pmas(23,1)    
          api=sign(1.,ei)   
          vpi=api-4.*ei*xw  
          sqmzp=pmas(32,1)**2   
          gzpmzp=pmas(32,2)*pmas(32,1)  
          ggi=ei**2 
          gzi=ei*vi/(8.*xw*(1.-xw))*sqm*(sqm-sqmz)/ 
     &    ((sqm-sqmz)**2+gzmz**2)   
          gzpi=ei*vpi/(8.*xw*(1.-xw))*sqm*(sqm-sqmzp)/  
     &    ((sqm-sqmzp)**2+gzpmzp**2)    
          zzi=(vi**2+ai**2)/(16.*xw*(1.-xw))**2*sqm**2/ 
     &    ((sqm-sqmz)**2+gzmz**2)   
          zzpi=2.*(vi*vpi+ai*api)/(16.*xw*(1.-xw))**2*  
     &    sqm**2*((sqm-sqmz)*(sqm-sqmzp)+gzmz*gzpmzp)/  
     &    (((sqm-sqmz)**2+gzmz**2)*((sqm-sqmzp)**2+gzpmzp**2))  
          zpzpi=(vpi**2+api**2)/(16.*xw*(1.-xw))**2*sqm**2/ 
     &    ((sqm-sqmzp)**2+gzpmzp**2)    
          IF(mstp(44).EQ.1) THEN    
C...Only gamma* production included 
            gzi=0.  
            gzpi=0. 
            zzi=0.  
            zzpi=0. 
            zpzpi=0.    
          ELSEIF(mstp(44).EQ.2) THEN    
C...Only Z0 production included 
            ggi=0.  
            gzi=0.  
            gzpi=0. 
            zzpi=0. 
            zpzpi=0.    
          ELSEIF(mstp(44).EQ.3) THEN    
C...Only Z'0 production included    
            ggi=0.  
            gzi=0.  
            gzpi=0. 
            zzi=0.  
            zzpi=0. 
          ELSEIF(mstp(44).EQ.4) THEN    
C...Only gamma*/Z0 production included  
            gzpi=0. 
            zzpi=0. 
            zpzpi=0.    
          ELSEIF(mstp(44).EQ.5) THEN    
C...Only gamma*/Z'0 production included 
            gzi=0.  
            zzi=0.  
            zzpi=0. 
          ELSEIF(mstp(44).EQ.6) THEN    
C...Only Z0/Z'0 production included 
            ggi=0.  
            gzi=0.  
            gzpi=0. 
          ENDIF 
        ELSEIF(mint(61).EQ.2) THEN  
          vint(111)=0.  
          vint(112)=0.  
          vint(113)=0.  
          vint(114)=0.  
          vint(115)=0.  
          vint(116)=0.  
        ENDIF   
        DO 180 i=1,mdcy(32,3)   
        idc=i+mdcy(32,2)-1  
        rm1=(pmas(iabs(kfdp(idc,1)),1)/rmas)**2 
        rm2=(pmas(iabs(kfdp(idc,2)),1)/rmas)**2 
        IF(sqrt(rm1)+sqrt(rm2).GT.1..OR.mdme(idc,1).LT.0) goto 180  
        IF(i.LE.8) THEN 
C...Z'0 -> q + qb   
          ef=kchg(i,1)/3.   
          af=sign(1.,ef+0.1)    
          vf=af-4.*ef*xw    
          apf=sign(1.,ef+0.1)   
          vpf=apf-4.*ef*xw  
          IF(mint(61).EQ.0) THEN    
            wdtp(i)=3.*(vpf**2*(1.+2.*rm1)+apf**2*(1.-4.*rm1))* 
     &      sqrt(max(0.,1.-4.*rm1))*radc    
          ELSEIF(mint(61).EQ.1) THEN    
            wdtp(i)=3.*((ggi*ef**2+gzi*ef*vf+gzpi*ef*vpf+zzi*vf**2+ 
     &      zzpi*vf*vpf+zpzpi*vpf**2)*(1.+2.*rm1)+(zzi*af**2+   
     &      zzpi*af*apf+zpzpi*apf**2)*(1.-4.*rm1))* 
     &      sqrt(max(0.,1.-4.*rm1))*radc    
          ELSEIF(mint(61).EQ.2) THEN    
            ggf=3.*ef**2*(1.+2.*rm1)*sqrt(max(0.,1.-4.*rm1))*radc   
            gzf=3.*ef*vf*(1.+2.*rm1)*sqrt(max(0.,1.-4.*rm1))*radc   
            gzpf=3.*ef*vpf*(1.+2.*rm1)*sqrt(max(0.,1.-4.*rm1))*radc 
            zzf=3.*(vf**2*(1.+2.*rm1)+af**2*(1.-4.*rm1))*   
     &      sqrt(max(0.,1.-4.*rm1))*radc    
            zzpf=3.*(vf*vpf*(1.+2.*rm1)+af*apf*(1.-4.*rm1))*    
     &      sqrt(max(0.,1.-4.*rm1))*radc    
            zpzpf=3.*(vpf**2*(1.+2.*rm1)+apf**2*(1.-4.*rm1))*   
     &      sqrt(max(0.,1.-4.*rm1))*radc    
          ENDIF 
          wid2=1.   
        ELSE    
C...Z'0 -> l+ + l-, nu + nub    
          ef=kchg(i+2,1)/3. 
          af=sign(1.,ef+0.1)    
          vf=af-4.*ef*xw    
          apf=sign(1.,ef+0.1)   
          vpf=api-4.*ef*xw  
          IF(mint(61).EQ.0) THEN    
            wdtp(i)=(vpf**2*(1.+2.*rm1)+apf**2*(1.-4.*rm1))*    
     &      sqrt(max(0.,1.-4.*rm1)) 
          ELSEIF(mint(61).EQ.1) THEN    
            wdtp(i)=((ggi*ef**2+gzi*ef*vf+gzpi*ef*vpf+zzi*vf**2+    
     &      zzpi*vf*vpf+zpzpi*vpf**2)*(1.+2.*rm1)+(zzi*af**2+   
     &      zzpi*af*apf+zpzpi*apf**2)*(1.-4.*rm1))* 
     &      sqrt(max(0.,1.-4.*rm1)) 
          ELSEIF(mint(61).EQ.2) THEN    
            ggf=ef**2*(1.+2.*rm1)*sqrt(max(0.,1.-4.*rm1))   
            gzf=ef*vf*(1.+2.*rm1)*sqrt(max(0.,1.-4.*rm1))   
            gzpf=ef*vpf*(1.+2.*rm1)*sqrt(max(0.,1.-4.*rm1)) 
            zzf=(vf**2*(1.+2.*rm1)+af**2*(1.-4.*rm1))*  
     &      sqrt(max(0.,1.-4.*rm1)) 
            zzpf=(vf*vpf*(1.+2.*rm1)+af*apf*(1.-4.*rm1))*   
     &      sqrt(max(0.,1.-4.*rm1)) 
            zpzpf=(vpf**2*(1.+2.*rm1)+apf**2*(1.-4.*rm1))*  
     &      sqrt(max(0.,1.-4.*rm1)) 
          ENDIF 
          wid2=1.   
        ENDIF   
        wdtp(0)=wdtp(0)+wdtp(i) 
        IF(mdme(idc,1).GT.0) THEN   
          wdte(i,mdme(idc,1))=wdtp(i)*wid2  
          wdte(0,mdme(idc,1))=wdte(0,mdme(idc,1))+wdte(i,mdme(idc,1))   
          wdte(i,0)=wdte(i,mdme(idc,1)) 
          wdte(0,0)=wdte(0,0)+wdte(i,0) 
          vint(111)=vint(111)+ggf   
          vint(112)=vint(112)+gzf   
          vint(113)=vint(113)+gzpf  
          vint(114)=vint(114)+zzf   
          vint(115)=vint(115)+zzpf  
          vint(116)=vint(116)+zpzpf 
        ENDIF   
  180   CONTINUE    
        IF(mstp(44).EQ.1) THEN  
C...Only gamma* production included 
          vint(112)=0.  
          vint(113)=0.  
          vint(114)=0.  
          vint(115)=0.  
          vint(116)=0.  
        ELSEIF(mstp(44).EQ.2) THEN  
C...Only Z0 production included 
          vint(111)=0.  
          vint(112)=0.  
          vint(113)=0.  
          vint(115)=0.  
          vint(116)=0.  
        ELSEIF(mstp(44).EQ.3) THEN  
C...Only Z'0 production included    
          vint(111)=0.  
          vint(112)=0.  
          vint(113)=0.  
          vint(114)=0.  
          vint(115)=0.  
        ELSEIF(mstp(44).EQ.4) THEN  
C...Only gamma*/Z0 production included  
          vint(113)=0.  
          vint(115)=0.  
          vint(116)=0.  
        ELSEIF(mstp(44).EQ.5) THEN  
C...Only gamma*/Z'0 production included 
          vint(112)=0.  
          vint(114)=0.  
          vint(115)=0.  
        ELSEIF(mstp(44).EQ.6) THEN  
C...Only Z0/Z'0 production included 
          vint(111)=0.  
          vint(112)=0.  
          vint(113)=0.  
        ENDIF   
    
      ELSEIF(kfla.EQ.37) THEN   
C...H+/-:   
        DO 190 i=1,mdcy(37,3)   
        idc=i+mdcy(37,2)-1  
        rm1=(pmas(iabs(kfdp(idc,1)),1)/rmas)**2 
        rm2=(pmas(iabs(kfdp(idc,2)),1)/rmas)**2 
        IF(sqrt(rm1)+sqrt(rm2).GT.1..OR.mdme(idc,1).LT.0) goto 190  
        IF(i.LE.4) THEN 
C...H+/- -> q + qb' 
          wdtp(i)=3.*((rm1*paru(121)+rm2/paru(121))*    
     &    (1.-rm1-rm2)-4.*rm1*rm2)* 
     &    sqrt(max(0.,(1.-rm1-rm2)**2-4.*rm1*rm2))*radc 
          wid2=1.   
        ELSE    
C...H+/- -> l+/- + nu   
          wdtp(i)=((rm1*paru(121)+rm2/paru(121))*   
     &    (1.-rm1-rm2)-4.*rm1*rm2)* 
     &    sqrt(max(0.,(1.-rm1-rm2)**2-4.*rm1*rm2))  
          wid2=1.   
        ENDIF   
        wdtp(0)=wdtp(0)+wdtp(i) 
        IF(mdme(idc,1).GT.0) THEN   
          wdte(i,mdme(idc,1))=wdtp(i)*wid2  
          wdte(0,mdme(idc,1))=wdte(0,mdme(idc,1))+wdte(i,mdme(idc,1))   
          wdte(i,0)=wdte(i,mdme(idc,1)) 
          wdte(0,0)=wdte(0,0)+wdte(i,0) 
        ENDIF   
  190   CONTINUE    
    
      ELSEIF(kfla.EQ.40) THEN   
C...R:  
        DO 200 i=1,mdcy(40,3)   
        idc=i+mdcy(40,2)-1  
        rm1=(pmas(iabs(kfdp(idc,1)),1)/rmas)**2 
        rm2=(pmas(iabs(kfdp(idc,2)),1)/rmas)**2 
        IF(sqrt(rm1)+sqrt(rm2).GT.1..OR.mdme(idc,1).LT.0) goto 200  
        IF(i.LE.4) THEN 
C...R -> q + qb'    
          wdtp(i)=3.*radc   
          wid2=1.   
        ELSE    
C...R -> l+ + l'-   
          wdtp(i)=1.    
          wid2=1.   
        ENDIF   
        wdtp(0)=wdtp(0)+wdtp(i) 
        IF(mdme(idc,1).GT.0) THEN   
          wdte(i,mdme(idc,1))=wdtp(i)*wid2  
          wdte(0,mdme(idc,1))=wdte(0,mdme(idc,1))+wdte(i,mdme(idc,1))   
          wdte(i,0)=wdte(i,mdme(idc,1)) 
          wdte(0,0)=wdte(0,0)+wdte(i,0) 
        ENDIF   
  200   CONTINUE    
    
      ENDIF 
      mint(61)=0    
    
      RETURN    
      END   
    
C***********************************************************************    
    
      SUBROUTINE pyklim(ILIM)   
    
C...Checks generated variables against pre-set kinematical limits;  
C...also calculates limits on variables used in generation. 
      common/ludat1/mstu(200),paru(200),mstj(200),parj(200) 
      SAVE /ludat1/ 
      common/ludat2/kchg(500,3),pmas(500,4),parf(2000),vckm(4,4)    
      SAVE /ludat2/ 
      common/ludat3/mdcy(500,3),mdme(2000,2),brat(2000),kfdp(2000,5)    
      SAVE /ludat3/ 
      common/pypars/mstp(200),parp(200),msti(200),pari(200) 
      SAVE /pypars/ 
      common/pysubs/msel,msub(200),kfin(2,-40:40),ckin(200) 
      SAVE /pysubs/ 
      common/pyint1/mint(400),vint(400) 
      SAVE /pyint1/ 
      common/pyint2/iset(200),kfpr(200,2),coef(200,20),icol(40,4,2) 
      SAVE /pyint2/ 
    
C...Common kinematical expressions. 
      isub=mint(1)  
      IF(isub.EQ.96) goto 110   
      sqm3=vint(63) 
      sqm4=vint(64) 
      IF(ilim.NE.1) THEN    
        tau=vint(21)    
        rm3=sqm3/(tau*vint(2))  
        rm4=sqm4/(tau*vint(2))  
        be34=sqrt((1.-rm3-rm4)**2-4.*rm3*rm4)   
      ENDIF 
      pthmin=ckin(3)    
      IF(min(sqm3,sqm4).LT.ckin(6)**2) pthmin=max(ckin(3),ckin(5))  
    
      IF(ilim.EQ.0) THEN    
C...Check generated values of tau, y*, cos(theta-hat), and tau' against 
C...pre-set kinematical limits. 
        yst=vint(22)    
        cth=vint(23)    
        taup=vint(26)   
        IF(iset(isub).LE.2) THEN    
          x1=sqrt(tau)*exp(yst) 
          x2=sqrt(tau)*exp(-yst)    
        ELSE    
          x1=sqrt(taup)*exp(yst)    
          x2=sqrt(taup)*exp(-yst)   
        ENDIF   
        xf=x1-x2    
        IF(tau*vint(2).LT.ckin(1)**2) mint(51)=1    
        IF(ckin(2).GE.0..AND.tau*vint(2).GT.ckin(2)**2) mint(51)=1  
        IF(x1.LT.ckin(21).OR.x1.GT.ckin(22)) mint(51)=1 
        IF(x2.LT.ckin(23).OR.x2.GT.ckin(24)) mint(51)=1 
        IF(xf.LT.ckin(25).OR.xf.GT.ckin(26)) mint(51)=1 
        IF(yst.LT.ckin(7).OR.yst.GT.ckin(8)) mint(51)=1 
        IF(iset(isub).EQ.2.OR.iset(isub).EQ.4) THEN 
          pth=0.5*be34*sqrt(tau*vint(2)*(1.-cth**2))    
          y3=yst+0.5*log((1.+rm3-rm4+be34*cth)/(1.+rm3-rm4-be34*cth))   
          y4=yst+0.5*log((1.+rm4-rm3-be34*cth)/(1.+rm4-rm3+be34*cth))   
          ylarge=max(y3,y4) 
          ysmall=min(y3,y4) 
          etalar=10.    
          etasma=-10.   
          sth=sqrt(1.-cth**2)   
          IF(sth.LT.1.e-6) goto 100 
          expet3=((1.+rm3-rm4)*sinh(yst)+be34*cosh(yst)*cth+    
     &    sqrt(((1.+rm3-rm4)*cosh(yst)+be34*sinh(yst)*cth)**2-4.*rm3))/ 
     &    (be34*sth)    
          expet4=((1.-rm3+rm4)*sinh(yst)-be34*cosh(yst)*cth+    
     &    sqrt(((1.-rm3+rm4)*cosh(yst)-be34*sinh(yst)*cth)**2-4.*rm4))/ 
     &    (be34*sth)    
          eta3=log(min(1.e10,max(1.e-10,expet3)))   
          eta4=log(min(1.e10,max(1.e-10,expet4)))   
          etalar=max(eta3,eta4) 
          etasma=min(eta3,eta4) 
  100     cts3=((1.+rm3-rm4)*sinh(yst)+be34*cosh(yst)*cth)/ 
     &    sqrt(((1.+rm3-rm4)*cosh(yst)+be34*sinh(yst)*cth)**2-4.*rm3)   
          cts4=((1.-rm3+rm4)*sinh(yst)-be34*cosh(yst)*cth)/ 
     &    sqrt(((1.-rm3+rm4)*cosh(yst)-be34*sinh(yst)*cth)**2-4.*rm4)   
          ctslar=max(cts3,cts4) 
          ctssma=min(cts3,cts4) 
          IF(pth.LT.pthmin) mint(51)=1  
          IF(ckin(4).GE.0..AND.pth.GT.ckin(4)) mint(51)=1   
          IF(ylarge.LT.ckin(9).OR.ylarge.GT.ckin(10)) mint(51)=1    
          IF(ysmall.LT.ckin(11).OR.ysmall.GT.ckin(12)) mint(51)=1   
          IF(etalar.LT.ckin(13).OR.etalar.GT.ckin(14)) mint(51)=1   
          IF(etasma.LT.ckin(15).OR.etasma.GT.ckin(16)) mint(51)=1   
          IF(ctslar.LT.ckin(17).OR.ctslar.GT.ckin(18)) mint(51)=1   
          IF(ctssma.LT.ckin(19).OR.ctssma.GT.ckin(20)) mint(51)=1   
          IF(cth.LT.ckin(27).OR.cth.GT.ckin(28)) mint(51)=1 
        ENDIF   
        IF(iset(isub).EQ.3.OR.iset(isub).EQ.4) THEN 
          IF(taup*vint(2).LT.ckin(31)**2) mint(51)=1    
          IF(ckin(32).GE.0..AND.taup*vint(2).GT.ckin(32)**2) mint(51)=1 
        ENDIF   
    
      ELSEIF(ilim.EQ.1) THEN    
C...Calculate limits on tau 
C...0) due to definition    
        taumn0=0.   
        taumx0=1.   
C...1) due to limits on subsystem mass  
        taumn1=ckin(1)**2/vint(2)   
        taumx1=1.   
        IF(ckin(2).GE.0.) taumx1=ckin(2)**2/vint(2) 
C...2) due to limits on pT-hat (and non-overlapping rapidity intervals) 
        tm3=sqrt(sqm3+pthmin**2)    
        tm4=sqrt(sqm4+pthmin**2)    
        ydcosh=1.   
        IF(ckin(9).GT.ckin(12)) ydcosh=cosh(ckin(9)-ckin(12))   
        taumn2=(tm3**2+2.*tm3*tm4*ydcosh+tm4**2)/vint(2)    
        taumx2=1.   
C...3) due to limits on pT-hat and cos(theta-hat)   
        cth2mn=min(ckin(27)**2,ckin(28)**2) 
        cth2mx=max(ckin(27)**2,ckin(28)**2) 
        taumn3=0.   
        IF(ckin(27)*ckin(28).GT.0.) taumn3= 
     &  (sqrt(sqm3+pthmin**2/(1.-cth2mn))+  
     &  sqrt(sqm4+pthmin**2/(1.-cth2mn)))**2/vint(2)    
        taumx3=1.   
        IF(ckin(4).GE.0..AND.cth2mx.LT.1.) taumx3=  
     &  (sqrt(sqm3+ckin(4)**2/(1.-cth2mx))+ 
     &  sqrt(sqm4+ckin(4)**2/(1.-cth2mx)))**2/vint(2)   
C...4) due to limits on x1 and x2   
        taumn4=ckin(21)*ckin(23)    
        taumx4=ckin(22)*ckin(24)    
C...5) due to limits on xF  
        taumn5=0.   
        taumx5=max(1.-ckin(25),1.+ckin(26)) 
        vint(11)=max(taumn0,taumn1,taumn2,taumn3,taumn4,taumn5) 
        vint(31)=min(taumx0,taumx1,taumx2,taumx3,taumx4,taumx5) 
        IF(mint(43).EQ.1.AND.(iset(isub).EQ.1.OR.iset(isub).EQ.2)) THEN 
          vint(11)=0.99999  
          vint(31)=1.00001  
        ENDIF   
        IF(vint(31).LE.vint(11)) mint(51)=1 
    
      ELSEIF(ilim.EQ.2) THEN    
C...Calculate limits on y*  
        IF(iset(isub).EQ.3.OR.iset(isub).EQ.4) tau=vint(26) 
        taurt=sqrt(tau) 
C...0) due to kinematics    
        ystmn0=log(taurt)   
        ystmx0=-ystmn0  
C...1) due to explicit limits   
        ystmn1=ckin(7)  
        ystmx1=ckin(8)  
C...2) due to limits on x1  
        ystmn2=log(max(tau,ckin(21))/taurt) 
        ystmx2=log(max(tau,ckin(22))/taurt) 
C...3) due to limits on x2  
        ystmn3=-log(max(tau,ckin(24))/taurt)    
        ystmx3=-log(max(tau,ckin(23))/taurt)    
C...4) due to limits on xF  
        yepmn4=0.5*abs(ckin(25))/taurt  
        ystmn4=sign(log(sqrt(1.+yepmn4**2)+yepmn4),ckin(25))    
        yepmx4=0.5*abs(ckin(26))/taurt  
        ystmx4=sign(log(sqrt(1.+yepmx4**2)+yepmx4),ckin(26))    
C...5) due to simultaneous limits on y-large and y-small    
        yepsmn=(rm3-rm4)*sinh(ckin(9)-ckin(11)) 
        yepsmx=(rm3-rm4)*sinh(ckin(10)-ckin(12))    
        ydifmn=abs(log(sqrt(1.+yepsmn**2)-yepsmn))  
        ydifmx=abs(log(sqrt(1.+yepsmx**2)-yepsmx))  
        ystmn5=0.5*(ckin(9)+ckin(11)-ydifmn)    
        ystmx5=0.5*(ckin(10)+ckin(12)+ydifmx)   
C...6) due to simultaneous limits on cos(theta-hat) and y-large or  
C...   y-small  
        cthlim=sqrt(1.-4.*pthmin**2/(be34*tau*vint(2))) 
        rzmn=be34*max(ckin(27),-cthlim) 
        rzmx=be34*min(ckin(28),cthlim)  
        yex3mx=(1.+rm3-rm4+rzmx)/max(1e-10,1.+rm3-rm4-rzmx) 
        yex4mx=(1.+rm4-rm3-rzmn)/max(1e-10,1.+rm4-rm3+rzmn) 
        yex3mn=max(1e-10,1.+rm3-rm4+rzmn)/(1.+rm3-rm4-rzmn) 
        yex4mn=max(1e-10,1.+rm4-rm3-rzmx)/(1.+rm4-rm3+rzmx) 
        ystmn6=ckin(9)-0.5*log(max(yex3mx,yex4mx))  
        ystmx6=ckin(12)-0.5*log(min(yex3mn,yex4mn)) 
        vint(12)=max(ystmn0,ystmn1,ystmn2,ystmn3,ystmn4,ystmn5,ystmn6)  
        vint(32)=min(ystmx0,ystmx1,ystmx2,ystmx3,ystmx4,ystmx5,ystmx6)  
        IF(mint(43).EQ.1) THEN  
          vint(12)=-0.00001 
          vint(32)=0.00001  
        ELSEIF(mint(43).EQ.2) THEN  
          vint(12)=0.99999*ystmx0   
          vint(32)=1.00001*ystmx0   
        ELSEIF(mint(43).EQ.3) THEN  
          vint(12)=-1.00001*ystmx0  
          vint(32)=-0.99999*ystmx0  
        ENDIF   
        IF(vint(32).LE.vint(12)) mint(51)=1 
    
      ELSEIF(ilim.EQ.3) THEN    
C...Calculate limits on cos(theta-hat)  
        yst=vint(22)    
C...0) due to definition    
        ctnmn0=-1.  
        ctnmx0=0.   
        ctpmn0=0.   
        ctpmx0=1.   
C...1) due to explicit limits   
        ctnmn1=min(0.,ckin(27)) 
        ctnmx1=min(0.,ckin(28)) 
        ctpmn1=max(0.,ckin(27)) 
        ctpmx1=max(0.,ckin(28)) 
C...2) due to limits on pT-hat  
        ctnmn2=-sqrt(1.-4.*pthmin**2/(be34**2*tau*vint(2))) 
        ctpmx2=-ctnmn2  
        ctnmx2=0.   
        ctpmn2=0.   
        IF(ckin(4).GE.0.) THEN  
          ctnmx2=-sqrt(max(0.,1.-4.*ckin(4)**2/(be34**2*tau*vint(2))))  
          ctpmn2=-ctnmx2    
        ENDIF   
C...3) due to limits on y-large and y-small 
        ctnmn3=min(0.,max((1.+rm3-rm4)/be34*tanh(ckin(11)-yst), 
     &  -(1.-rm3+rm4)/be34*tanh(ckin(10)-yst))) 
        ctnmx3=min(0.,(1.+rm3-rm4)/be34*tanh(ckin(12)-yst), 
     &  -(1.-rm3+rm4)/be34*tanh(ckin(9)-yst))   
        ctpmn3=max(0.,(1.+rm3-rm4)/be34*tanh(ckin(9)-yst),  
     &  -(1.-rm3+rm4)/be34*tanh(ckin(12)-yst))  
        ctpmx3=max(0.,min((1.+rm3-rm4)/be34*tanh(ckin(10)-yst), 
     &  -(1.-rm3+rm4)/be34*tanh(ckin(11)-yst))) 
        vint(13)=max(ctnmn0,ctnmn1,ctnmn2,ctnmn3)   
        vint(33)=min(ctnmx0,ctnmx1,ctnmx2,ctnmx3)   
        vint(14)=max(ctpmn0,ctpmn1,ctpmn2,ctpmn3)   
        vint(34)=min(ctpmx0,ctpmx1,ctpmx2,ctpmx3)   
        IF(vint(33).LE.vint(13).AND.vint(34).LE.vint(14)) mint(51)=1    
    
      ELSEIF(ilim.EQ.4) THEN    
C...Calculate limits on tau'    
C...0) due to kinematics    
        tapmn0=tau  
        tapmx0=1.   
C...1) due to explicit limits   
        tapmn1=ckin(31)**2/vint(2)  
        tapmx1=1.   
        IF(ckin(32).GE.0.) tapmx1=ckin(32)**2/vint(2)   
        vint(16)=max(tapmn0,tapmn1) 
        vint(36)=min(tapmx0,tapmx1) 
        IF(mint(43).EQ.1) THEN  
          vint(16)=0.99999  
          vint(36)=1.00001  
        ENDIF   
        IF(vint(36).LE.vint(16)) mint(51)=1 
    
      ENDIF 
      RETURN    
    
C...Special case for low-pT and multiple interactions:  
C...effective kinematical limits for tau, y*, cos(theta-hat).   
  110 IF(ilim.EQ.0) THEN    
      ELSEIF(ilim.EQ.1) THEN    
        IF(mstp(82).LE.1) vint(11)=4.*parp(81)**2/vint(2)   
        IF(mstp(82).GE.2) vint(11)=parp(82)**2/vint(2)  
        vint(31)=1. 
      ELSEIF(ilim.EQ.2) THEN    
        vint(12)=0.5*log(vint(21))  
        vint(32)=-vint(12)  
      ELSEIF(ilim.EQ.3) THEN    
        IF(mstp(82).LE.1) st2eff=4.*parp(81)**2/(vint(21)*vint(2))  
        IF(mstp(82).GE.2) st2eff=0.01*parp(82)**2/(vint(21)*vint(2))    
        vint(13)=-sqrt(max(0.,1.-st2eff))   
        vint(33)=0. 
        vint(14)=0. 
        vint(34)=-vint(13)  
      ENDIF 
    
      RETURN    
      END   
    
C*********************************************************************  
    
      SUBROUTINE pykmap(IVAR,MVAR,VVAR) 
    
C...Maps a uniform distribution into a distribution of a kinematical    
C...variable according to one of the possibilities allowed. It is   
C...assumed that kinematical limits have been set by a PYKLIM call. 
      common/ludat2/kchg(500,3),pmas(500,4),parf(2000),vckm(4,4)    
      SAVE /ludat2/ 
      common/pyint1/mint(400),vint(400) 
      SAVE /pyint1/ 
      common/pyint2/iset(200),kfpr(200,2),coef(200,20),icol(40,4,2) 
      SAVE /pyint2/ 
    
C...Convert VVAR to tau variable.   
      isub=mint(1)  
      IF(ivar.EQ.1) THEN    
        taumin=vint(11) 
        taumax=vint(31) 
        IF(mvar.EQ.3.OR.mvar.EQ.4) THEN 
          taure=vint(73)    
          gamre=vint(74)    
        ELSEIF(mvar.EQ.5.OR.mvar.EQ.6) THEN 
          taure=vint(75)    
          gamre=vint(76)    
        ENDIF   
        IF(mint(43).EQ.1.AND.(iset(isub).EQ.1.OR.iset(isub).EQ.2)) THEN 
          tau=1.    
        ELSEIF(mvar.EQ.1) THEN  
          tau=taumin*(taumax/taumin)**vvar  
        ELSEIF(mvar.EQ.2) THEN  
          tau=taumax*taumin/(taumin+(taumax-taumin)*vvar)   
        ELSEIF(mvar.EQ.3.OR.mvar.EQ.5) THEN 
          ratgen=(taure+taumax)/(taure+taumin)*taumin/taumax    
          tau=taure*taumin/((taure+taumin)*ratgen**vvar-taumin) 
        ELSE    
          aupp=atan((taumax-taure)/gamre)   
          alow=atan((taumin-taure)/gamre)   
          tau=taure+gamre*tan(alow+(aupp-alow)*vvar)    
        ENDIF   
        vint(21)=min(taumax,max(taumin,tau))    
    
C...Convert VVAR to y* variable.    
      ELSEIF(ivar.EQ.2) THEN    
        ystmin=vint(12) 
        ystmax=vint(32) 
        IF(mint(43).EQ.1) THEN  
          yst=0.    
        ELSEIF(mint(43).EQ.2) THEN  
          IF(iset(isub).LE.2) yst=-0.5*log(vint(21))    
          IF(iset(isub).GE.3) yst=-0.5*log(vint(26))    
        ELSEIF(mint(43).EQ.3) THEN  
          IF(iset(isub).LE.2) yst=0.5*log(vint(21)) 
          IF(iset(isub).GE.3) yst=0.5*log(vint(26)) 
        ELSEIF(mvar.EQ.1) THEN  
          yst=ystmin+(ystmax-ystmin)*sqrt(vvar) 
        ELSEIF(mvar.EQ.2) THEN  
          yst=ystmax-(ystmax-ystmin)*sqrt(1.-vvar)  
        ELSE    
          aupp=atan(exp(ystmax))    
          alow=atan(exp(ystmin))    
          yst=log(tan(alow+(aupp-alow)*vvar))   
        ENDIF   
        vint(22)=min(ystmax,max(ystmin,yst))    
    
C...Convert VVAR to cos(theta-hat) variable.    
      ELSEIF(ivar.EQ.3) THEN    
        rm34=2.*vint(63)*vint(64)/(vint(21)*vint(2))**2 
        rsqm=1.+rm34    
        IF(2.*vint(71)**2/(vint(21)*vint(2)).LT.0.0001) rm34=max(rm34,  
     &  2.*vint(71)**2/(vint(21)*vint(2)))  
        ctnmin=vint(13) 
        ctnmax=vint(33) 
        ctpmin=vint(14) 
        ctpmax=vint(34) 
        IF(mvar.EQ.1) THEN  
          aneg=ctnmax-ctnmin    
          apos=ctpmax-ctpmin    
          IF(aneg.GT.0..AND.vvar*(aneg+apos).LE.aneg) THEN  
            vctn=vvar*(aneg+apos)/aneg  
            cth=ctnmin+(ctnmax-ctnmin)*vctn 
          ELSE  
            vctp=(vvar*(aneg+apos)-aneg)/apos   
            cth=ctpmin+(ctpmax-ctpmin)*vctp 
          ENDIF 
        ELSEIF(mvar.EQ.2) THEN  
          rmnmin=max(rm34,rsqm-ctnmin)  
          rmnmax=max(rm34,rsqm-ctnmax)  
          rmpmin=max(rm34,rsqm-ctpmin)  
          rmpmax=max(rm34,rsqm-ctpmax)  
          aneg=log(rmnmin/rmnmax)   
          apos=log(rmpmin/rmpmax)   
          IF(aneg.GT.0..AND.vvar*(aneg+apos).LE.aneg) THEN  
            vctn=vvar*(aneg+apos)/aneg  
            cth=rsqm-rmnmin*(rmnmax/rmnmin)**vctn   
          ELSE  
            vctp=(vvar*(aneg+apos)-aneg)/apos   
            cth=rsqm-rmpmin*(rmpmax/rmpmin)**vctp   
          ENDIF 
        ELSEIF(mvar.EQ.3) THEN  
          rmnmin=max(rm34,rsqm+ctnmin)  
          rmnmax=max(rm34,rsqm+ctnmax)  
          rmpmin=max(rm34,rsqm+ctpmin)  
          rmpmax=max(rm34,rsqm+ctpmax)  
          aneg=log(rmnmax/rmnmin)   
          apos=log(rmpmax/rmpmin)   
          IF(aneg.GT.0..AND.vvar*(aneg+apos).LE.aneg) THEN  
            vctn=vvar*(aneg+apos)/aneg  
            cth=rmnmin*(rmnmax/rmnmin)**vctn-rsqm   
          ELSE  
            vctp=(vvar*(aneg+apos)-aneg)/apos   
            cth=rmpmin*(rmpmax/rmpmin)**vctp-rsqm   
          ENDIF 
        ELSEIF(mvar.EQ.4) THEN  
          rmnmin=max(rm34,rsqm-ctnmin)  
          rmnmax=max(rm34,rsqm-ctnmax)  
          rmpmin=max(rm34,rsqm-ctpmin)  
          rmpmax=max(rm34,rsqm-ctpmax)  
          aneg=1./rmnmax-1./rmnmin  
          apos=1./rmpmax-1./rmpmin  
          IF(aneg.GT.0..AND.vvar*(aneg+apos).LE.aneg) THEN  
            vctn=vvar*(aneg+apos)/aneg  
            cth=rsqm-1./(1./rmnmin+aneg*vctn)   
          ELSE  
            vctp=(vvar*(aneg+apos)-aneg)/apos   
            cth=rsqm-1./(1./rmpmin+apos*vctp)   
          ENDIF 
        ELSEIF(mvar.EQ.5) THEN  
          rmnmin=max(rm34,rsqm+ctnmin)  
          rmnmax=max(rm34,rsqm+ctnmax)  
          rmpmin=max(rm34,rsqm+ctpmin)  
          rmpmax=max(rm34,rsqm+ctpmax)  
          aneg=1./rmnmin-1./rmnmax  
          apos=1./rmpmin-1./rmpmax  
          IF(aneg.GT.0..AND.vvar*(aneg+apos).LE.aneg) THEN  
            vctn=vvar*(aneg+apos)/aneg  
            cth=1./(1./rmnmin-aneg*vctn)-rsqm   
          ELSE  
            vctp=(vvar*(aneg+apos)-aneg)/apos   
            cth=1./(1./rmpmin-apos*vctp)-rsqm   
          ENDIF 
        ENDIF   
        IF(cth.LT.0.) cth=min(ctnmax,max(ctnmin,cth))   
        IF(cth.GT.0.) cth=min(ctpmax,max(ctpmin,cth))   
        vint(23)=cth    
    
C...Convert VVAR to tau' variable.  
      ELSEIF(ivar.EQ.4) THEN    
        tau=vint(11)    
        taupmn=vint(16) 
        taupmx=vint(36) 
        IF(mint(43).EQ.1) THEN  
          taup=1.   
        ELSEIF(mvar.EQ.1) THEN  
          taup=taupmn*(taupmx/taupmn)**vvar 
        ELSE    
          aupp=(1.-tau/taupmx)**4   
          alow=(1.-tau/taupmn)**4   
          taup=tau/(1.-(alow+(aupp-alow)*vvar)**0.25)   
        ENDIF   
        vint(26)=min(taupmx,max(taupmn,taup))   
      ENDIF 
    
      RETURN    
      END   
    
C***********************************************************************    
    
      SUBROUTINE pysigh(NCHN,SIGS)  
    
C...Differential matrix elements for all included subprocesses. 
C...Note that what is coded is (disregarding the COMFAC factor) 
C...1) for 2 -> 1 processes: s-hat/pi*d(sigma-hat), where,  
C...when d(sigma-hat) is given in the zero-width limit, the delta   
C...function in tau is replaced by a Breit-Wigner:  
C...1/pi*(s*m_res*Gamma_res)/((s*tau-m_res^2)^2+(m_res*Gamma_res)^2);   
C...2) for 2 -> 2 processes: (s-hat)**2/pi*d(sigma-hat)/d(t-hat);   
C...i.e., dimensionless quantities. COMFAC contains the factor  
C...pi/s and the conversion factor from GeV^-2 to mb.   
      common/ludat1/mstu(200),paru(200),mstj(200),parj(200) 
      SAVE /ludat1/ 
      common/ludat2/kchg(500,3),pmas(500,4),parf(2000),vckm(4,4)    
      SAVE /ludat2/ 
      common/ludat3/mdcy(500,3),mdme(2000,2),brat(2000),kfdp(2000,5)    
      SAVE /ludat3/ 
      common/pysubs/msel,msub(200),kfin(2,-40:40),ckin(200) 
      SAVE /pysubs/ 
      common/pypars/mstp(200),parp(200),msti(200),pari(200) 
      SAVE /pypars/ 
      common/pyint1/mint(400),vint(400) 
      SAVE /pyint1/ 
      common/pyint2/iset(200),kfpr(200,2),coef(200,20),icol(40,4,2) 
      SAVE /pyint2/ 
      common/pyint3/xsfx(2,-40:40),isig(1000,3),sigh(1000)  
      SAVE /pyint3/ 
      common/pyint4/widp(21:40,0:40),wide(21:40,0:40),wids(21:40,3) 
      SAVE /pyint4/ 
      common/pyint5/ngen(0:200,3),xsec(0:200,3) 
      SAVE /pyint5/ 
      dimension x(2),xpq(-6:6),kfac(2,-40:40),wdtp(0:40),wdte(0:40,0:5) 
    
C...Reset number of channels and cross-section. 
      nchn=0    
      sigs=0.   
    
C...Read kinematical variables and limits.  
      isub=mint(1)  
      taumin=vint(11)   
      ystmin=vint(12)   
      ctnmin=vint(13)   
      ctpmin=vint(14)   
      xt2min=vint(15)   
      taupmn=vint(16)   
      tau=vint(21)  
      yst=vint(22)  
      cth=vint(23)  
      xt2=vint(25)  
      taup=vint(26) 
      taumax=vint(31)   
      ystmax=vint(32)   
      ctnmax=vint(33)   
      ctpmax=vint(34)   
      xt2max=vint(35)   
      taupmx=vint(36)   
    
C...Derive kinematical quantities.  
      IF(iset(isub).LE.2.OR.iset(isub).EQ.5) THEN   
        x(1)=sqrt(tau)*exp(yst) 
        x(2)=sqrt(tau)*exp(-yst)    
      ELSE  
        x(1)=sqrt(taup)*exp(yst)    
        x(2)=sqrt(taup)*exp(-yst)   
      ENDIF 
      IF(mint(43).EQ.4.AND.iset(isub).GE.1.AND. 
     &(x(1).GT.0.999.OR.x(2).GT.0.999)) RETURN  
      sh=tau*vint(2)    
      sqm3=vint(63) 
      sqm4=vint(64) 
      rm3=sqm3/sh   
      rm4=sqm4/sh   
      be34=sqrt((1.-rm3-rm4)**2-4.*rm3*rm4) 
      rpts=4.*vint(71)**2/sh    
      be34l=sqrt(max(0.,(1.-rm3-rm4)**2-4.*rm3*rm4-rpts))   
      rm34=2.*rm3*rm4   
      rsqm=1.+rm34  
      rthm=(4.*rm3*rm4+rpts)/(1.-rm3-rm4+be34l) 
      th=-0.5*sh*max(rthm,1.-rm3-rm4-be34*cth)  
      uh=-0.5*sh*max(rthm,1.-rm3-rm4+be34*cth)  
      sqpth=0.25*sh*be34**2*(1.-cth**2) 
      sh2=sh**2 
      th2=th**2 
      uh2=uh**2 
    
C...Choice of Q2 scale. 
      IF(iset(isub).EQ.1.OR.iset(isub).EQ.3) THEN   
        q2=sh   
      ELSEIF(mod(iset(isub),2).EQ.0.OR.iset(isub).EQ.5) THEN    
        IF(mstp(32).EQ.1) THEN  
          q2=2.*sh*th*uh/(sh**2+th**2+uh**2)    
        ELSEIF(mstp(32).EQ.2) THEN  
          q2=sqpth+0.5*(sqm3+sqm4)  
        ELSEIF(mstp(32).EQ.3) THEN  
          q2=min(-th,-uh)   
        ELSEIF(mstp(32).EQ.4) THEN  
          q2=sh 
        ENDIF   
        IF(iset(isub).EQ.5.AND.mstp(82).GE.2) q2=q2+parp(82)**2 
      ENDIF 
    
C...Store derived kinematical quantities.   
      vint(41)=x(1) 
      vint(42)=x(2) 
      vint(44)=sh   
      vint(43)=sqrt(sh) 
      vint(45)=th   
      vint(46)=uh   
      vint(48)=sqpth    
      vint(47)=sqrt(sqpth)  
      vint(50)=taup*vint(2) 
      vint(49)=sqrt(max(0.,vint(50)))   
      vint(52)=q2   
      vint(51)=sqrt(q2) 
    
C...Calculate parton structure functions.   
      IF(iset(isub).LE.0) goto 145  
      IF(mint(43).GE.2) THEN    
        q2sf=q2 
        IF(iset(isub).EQ.3.OR.iset(isub).EQ.4) THEN 
          q2sf=pmas(23,1)**2    
          IF(isub.EQ.8.OR.isub.EQ.76.OR.isub.EQ.77) q2sf=pmas(24,1)**2  
        ENDIF   
        DO 100 i=3-mint(41),mint(42)    
        xsf=x(i)    
        IF(iset(isub).EQ.5) xsf=x(i)/vint(142+i)    
        CALL pystfu(mint(10+i),xsf,q2sf,xpq,i)    
        DO 100 kfl=-6,6 
  100   xsfx(i,kfl)=xpq(kfl)
      ENDIF 
    
C...Calculate alpha_strong and K-factor.    
      IF(mstp(33).NE.3) as=ulalps(q2)   
      fack=1.   
      faca=1.   
      IF(mstp(33).EQ.1) THEN    
        fack=parp(31)   
      ELSEIF(mstp(33).EQ.2) THEN    
        fack=parp(31)   
        faca=parp(32)/parp(31)  
      ELSEIF(mstp(33).EQ.3) THEN    
        q2as=parp(33)*q2    
        IF(iset(isub).EQ.5.AND.mstp(82).GE.2) q2as=q2as+    
     &  paru(112)*parp(82)  
        as=ulalps(q2as) 
      ENDIF 
      radc=1.+as/paru(1)    
    
C...Set flags for allowed reacting partons/leptons. 
      DO 130 i=1,2  
      DO 110 j=-40,40   
  110 kfac(i,j)=0   
      IF(mint(40+i).EQ.1) THEN  
        kfac(i,mint(10+i))=1    
      ELSE  
        DO 120 j=-40,40 
        kfac(i,j)=kfin(i,j) 
        IF(abs(j).GT.mstp(54).AND.j.NE.21) kfac(i,j)=0  
        IF(abs(j).LE.6) THEN    
          IF(xsfx(i,j).LT.1.e-10) kfac(i,j)=0   
        ELSEIF(j.EQ.21) THEN    
          IF(xsfx(i,0).LT.1.e-10) kfac(i,21)=0  
        ENDIF   
  120   CONTINUE    
      ENDIF 
  130 CONTINUE  
    
C...Lower and upper limit for flavour loops.    
      min1=0    
      max1=0    
      min2=0    
      max2=0    
      DO 140 j=-20,20   
      IF(kfac(1,-j).EQ.1) min1=-j   
      IF(kfac(1,j).EQ.1) max1=j 
      IF(kfac(2,-j).EQ.1) min2=-j   
      IF(kfac(2,j).EQ.1) max2=j 
  140 CONTINUE  
      mina=min(min1,min2)   
      maxa=max(max1,max2)   
    
C...Common conversion factors (including Jacobian) for subprocesses.    
      sqmz=pmas(23,1)**2    
      gmmz=pmas(23,1)*pmas(23,2)    
      sqmw=pmas(24,1)**2    
      gmmw=pmas(24,1)*pmas(24,2)    
      sqmh=pmas(25,1)**2    
      gmmh=pmas(25,1)*pmas(25,2)    
      sqmzp=pmas(32,1)**2   
      gmmzp=pmas(32,1)*pmas(32,2)   
      sqmhc=pmas(37,1)**2   
      gmmhc=pmas(37,1)*pmas(37,2)   
      sqmr=pmas(40,1)**2    
      gmmr=pmas(40,1)*pmas(40,2)    
      aem=paru(101) 
      xw=paru(102)  
    
C...Phase space integral in tau and y*. 
      comfac=paru(1)*paru(5)/vint(2)    
      IF(mint(43).EQ.4) comfac=comfac*fack  
      IF((mint(43).GE.2.OR.iset(isub).EQ.3.OR.iset(isub).EQ.4).AND. 
     &iset(isub).NE.5) THEN 
        atau0=log(taumax/taumin)    
        atau1=(taumax-taumin)/(taumax*taumin)   
        h1=coef(isub,1)+(atau0/atau1)*coef(isub,2)/tau  
        IF(mint(72).GE.1) THEN  
          taur1=vint(73)    
          gamr1=vint(74)    
          atau2=log(taumax/taumin*(taumin+taur1)/(taumax+taur1))/taur1  
          atau3=(atan((taumax-taur1)/gamr1)-atan((taumin-taur1)/gamr1))/    
     &    gamr1 
          h1=h1+(atau0/atau2)*coef(isub,3)/(tau+taur1)+ 
     &    (atau0/atau3)*coef(isub,4)*tau/((tau-taur1)**2+gamr1**2)  
        ENDIF   
        IF(mint(72).EQ.2) THEN  
          taur2=vint(75)    
          gamr2=vint(76)    
          atau4=log(taumax/taumin*(taumin+taur2)/(taumax+taur2))/taur2  
          atau5=(atan((taumax-taur2)/gamr2)-atan((taumin-taur2)/gamr2))/    
     &    gamr2 
          h1=h1+(atau0/atau4)*coef(isub,5)/(tau+taur2)+ 
     &    (atau0/atau5)*coef(isub,6)*tau/((tau-taur2)**2+gamr2**2)  
        ENDIF   
        comfac=comfac*atau0/(tau*h1)    
      ENDIF 
      IF(mint(43).EQ.4.AND.iset(isub).NE.5) THEN    
        ayst0=ystmax-ystmin 
        ayst1=0.5*(ystmax-ystmin)**2    
        ayst2=ayst1 
        ayst3=2.*(atan(exp(ystmax))-atan(exp(ystmin)))  
        h2=(ayst0/ayst1)*coef(isub,7)*(yst-ystmin)+(ayst0/ayst2)*   
     &  coef(isub,8)*(ystmax-yst)+(ayst0/ayst3)*coef(isub,9)/cosh(yst)  
        comfac=comfac*ayst0/h2  
      ENDIF 
    
C...2 -> 1 processes: reduction in angular part of phase space integral 
C...for case of decaying resonance. 
      acth0=ctnmax-ctnmin+ctpmax-ctpmin 
      IF((iset(isub).EQ.1.OR.iset(isub).EQ.3).AND.  
     &mdcy(kfpr(isub,1),1).EQ.1) THEN   
        IF(kfpr(isub,1).EQ.25.OR.kfpr(isub,1).EQ.37) THEN   
          comfac=comfac*0.5*acth0   
        ELSE    
          comfac=comfac*0.125*(3.*acth0+ctnmax**3-ctnmin**3+    
     &    ctpmax**3-ctpmin**3)  
        ENDIF   
    
C...2 -> 2 processes: angular part of phase space integral. 
      ELSEIF(iset(isub).EQ.2.OR.iset(isub).EQ.4) THEN   
        acth1=log((max(rm34,rsqm-ctnmin)*max(rm34,rsqm-ctpmin))/    
     &  (max(rm34,rsqm-ctnmax)*max(rm34,rsqm-ctpmax)))  
        acth2=log((max(rm34,rsqm+ctnmax)*max(rm34,rsqm+ctpmax))/    
     &  (max(rm34,rsqm+ctnmin)*max(rm34,rsqm+ctpmin)))  
        acth3=1./max(rm34,rsqm-ctnmax)-1./max(rm34,rsqm-ctnmin)+    
     &  1./max(rm34,rsqm-ctpmax)-1./max(rm34,rsqm-ctpmin)   
        acth4=1./max(rm34,rsqm+ctnmin)-1./max(rm34,rsqm+ctnmax)+    
     &  1./max(rm34,rsqm+ctpmin)-1./max(rm34,rsqm+ctpmax)   
        h3=coef(isub,10)+   
     &  (acth0/acth1)*coef(isub,11)/max(rm34,rsqm-cth)+ 
     &  (acth0/acth2)*coef(isub,12)/max(rm34,rsqm+cth)+ 
     &  (acth0/acth3)*coef(isub,13)/max(rm34,rsqm-cth)**2+  
     &  (acth0/acth4)*coef(isub,14)/max(rm34,rsqm+cth)**2   
        comfac=comfac*acth0*0.5*be34/h3 
      ENDIF 
    
C...2 -> 3, 4 processes: phace space integral in tau'.  
      IF(mint(43).GE.2.AND.(iset(isub).EQ.3.OR.iset(isub).EQ.4)) THEN   
        ataup0=log(taupmx/taupmn)   
        ataup1=((1.-tau/taupmx)**4-(1.-tau/taupmn)**4)/(4.*tau) 
        h4=coef(isub,15)+   
     &  ataup0/ataup1*coef(isub,16)/taup*(1.-tau/taup)**3   
        IF(1.-tau/taup.GT.1.e-4) THEN   
          fzw=(1.+tau/taup)*log(taup/tau)-2.*(1.-tau/taup)  
        ELSE    
          fzw=1./6.*(1.-tau/taup)**3*tau/taup   
        ENDIF   
        comfac=comfac*ataup0*fzw/h4 
      ENDIF 
    
C...Phase space integral for low-pT and multiple interactions.  
      IF(iset(isub).EQ.5) THEN  
        comfac=paru(1)*paru(5)*fack*0.5*vint(2)/sh2 
        atau0=log(2.*(1.+sqrt(1.-xt2))/xt2-1.)  
        atau1=2.*atan(1./xt2-1.)/sqrt(xt2)  
        h1=coef(isub,1)+(atau0/atau1)*coef(isub,2)/sqrt(tau)    
        comfac=comfac*atau0/h1  
        ayst0=ystmax-ystmin 
        ayst1=0.5*(ystmax-ystmin)**2    
        ayst3=2.*(atan(exp(ystmax))-atan(exp(ystmin)))  
        h2=(ayst0/ayst1)*coef(isub,7)*(yst-ystmin)+(ayst0/ayst1)*   
     &  coef(isub,8)*(ystmax-yst)+(ayst0/ayst3)*coef(isub,9)/cosh(yst)  
        comfac=comfac*ayst0/h2  
        IF(mstp(82).LE.1) comfac=comfac*xt2**2*(1./vint(149)-1.)    
C...For MSTP(82)>=2 an additional factor (xT2/(xT2+VINT(149))**2 is 
C...introduced to make cross-section finite for xT2 -> 0.   
        IF(mstp(82).GE.2) comfac=comfac*xt2**2/(vint(149)*  
     &  (1.+vint(149))) 
      ENDIF 
    
C...A: 2 -> 1, tree diagrams.   
    
  145 IF(isub.LE.10) THEN   
      IF(isub.EQ.1) THEN    
C...f + fb -> gamma*/Z0.    
        mint(61)=2  
        CALL pywidt(23,sqrt(sh),wdtp,wdte)  
        facz=comfac*aem**2*4./3.    
        DO 150 i=mina,maxa  
        IF(i.EQ.0.OR.kfac(1,i)*kfac(2,-i).EQ.0) goto 150    
        ei=kchg(iabs(i),1)/3.   
        ai=sign(1.,ei)  
        vi=ai-4.*ei*xw  
        facf=1. 
        IF(iabs(i).LE.10) facf=faca/3.  
        nchn=nchn+1 
        isig(nchn,1)=i  
        isig(nchn,2)=-i 
        isig(nchn,3)=1  
        sigh(nchn)=facf*facz*(ei**2*vint(111)+ei*vi/(8.*xw*(1.-xw))*    
     &  sh*(sh-sqmz)/((sh-sqmz)**2+gmmz**2)*vint(112)+(vi**2+ai**2)/    
     &  (16.*xw*(1.-xw))**2*sh2/((sh-sqmz)**2+gmmz**2)*vint(114))   
  150   CONTINUE    
    
      ELSEIF(isub.EQ.2) THEN    
C...f + fb' -> W+/-.    
        CALL pywidt(24,sqrt(sh),wdtp,wdte)  
        facw=comfac*(aem/xw)**2*1./24*sh2/((sh-sqmw)**2+gmmw**2)    
        DO 170 i=min1,max1  
        IF(i.EQ.0.OR.kfac(1,i).EQ.0) goto 170   
        ia=iabs(i)  
        DO 160 j=min2,max2  
        IF(j.EQ.0.OR.kfac(2,j).EQ.0) goto 160   
        ja=iabs(j)  
        IF(i*j.GT.0.OR.mod(ia+ja,2).EQ.0) goto 160  
        IF((ia.LE.10.AND.ja.GT.10).OR.(ia.GT.10.AND.ja.LE.10)) goto 160 
        kchw=(kchg(ia,1)*isign(1,i)+kchg(ja,1)*isign(1,j))/3    
        facf=1. 
        IF(ia.LE.10) facf=vckm((ia+1)/2,(ja+1)/2)*faca/3.   
        nchn=nchn+1 
        isig(nchn,1)=i  
        isig(nchn,2)=j  
        isig(nchn,3)=1  
        sigh(nchn)=facf*facw*(wdte(0,1)+wdte(0,(5-kchw)/2)+wdte(0,4))   
  160   CONTINUE    
  170   CONTINUE    
    
      ELSEIF(isub.EQ.3) THEN    
C...f + fb -> H0.   
        CALL pywidt(25,sqrt(sh),wdtp,wdte)  
        fach=comfac*(aem/xw)**2*1./48.*(sh/sqmw)**2*    
     &  sh2/((sh-sqmh)**2+gmmh**2)*(wdte(0,1)+wdte(0,2)+wdte(0,4))  
        DO 180 i=mina,maxa  
        IF(i.EQ.0.OR.kfac(1,i)*kfac(2,-i).EQ.0) goto 180    
        rmq=pmas(iabs(i),1)**2/sh   
        nchn=nchn+1 
        isig(nchn,1)=i  
        isig(nchn,2)=-i 
        isig(nchn,3)=1  
        sigh(nchn)=fach*rmq*sqrt(max(0.,1.-4.*rmq)) 
  180   CONTINUE    
    
      ELSEIF(isub.EQ.4) THEN    
C...gamma + W+/- -> W+/-.   
    
      ELSEIF(isub.EQ.5) THEN    
C...Z0 + Z0 -> H0.  
        CALL pywidt(25,sqrt(sh),wdtp,wdte)  
        fach=comfac*1./(128.*paru(1)**2*16.*(1.-xw)**3)*(aem/xw)**4*    
     &  (sh/sqmw)**2*sh2/((sh-sqmh)**2+gmmh**2)*    
     &  (wdte(0,1)+wdte(0,2)+wdte(0,4)) 
        DO 200 i=min1,max1  
        IF(i.EQ.0.OR.kfac(1,i).EQ.0) goto 200   
        DO 190 j=min2,max2  
        IF(j.EQ.0.OR.kfac(2,j).EQ.0) goto 190   
        ei=kchg(iabs(i),1)/3.   
        ai=sign(1.,ei)  
        vi=ai-4.*ei*xw  
        ej=kchg(iabs(j),1)/3.   
        aj=sign(1.,ej)  
        vj=aj-4.*ej*xw  
        nchn=nchn+1 
        isig(nchn,1)=i  
        isig(nchn,2)=j  
        isig(nchn,3)=1  
        sigh(nchn)=fach*(vi**2+ai**2)*(vj**2+aj**2) 
  190   CONTINUE    
  200   CONTINUE    
    
      ELSEIF(isub.EQ.6) THEN    
C...Z0 + W+/- -> W+/-.  
    
      ELSEIF(isub.EQ.7) THEN    
C...W+ + W- -> Z0.  
    
      ELSEIF(isub.EQ.8) THEN    
C...W+ + W- -> H0.  
        CALL pywidt(25,sqrt(sh),wdtp,wdte)  
        fach=comfac*1./(128*paru(1)**2)*(aem/xw)**4*(sh/sqmw)**2*   
     &  sh2/((sh-sqmh)**2+gmmh**2)*(wdte(0,1)+wdte(0,2)+wdte(0,4))  
        DO 220 i=min1,max1  
        IF(i.EQ.0.OR.kfac(1,i).EQ.0) goto 220   
        ei=sign(1.,float(i))*kchg(iabs(i),1)    
        DO 210 j=min2,max2  
        IF(j.EQ.0.OR.kfac(2,j).EQ.0) goto 210   
        ej=sign(1.,float(j))*kchg(iabs(j),1)    
        IF(ei*ej.GT.0.) goto 210    
        nchn=nchn+1 
        isig(nchn,1)=i  
        isig(nchn,2)=j  
        isig(nchn,3)=1  
        sigh(nchn)=fach*vint(180+i)*vint(180+j) 
  210   CONTINUE    
  220   CONTINUE    
      ENDIF 
    
C...B: 2 -> 2, tree diagrams.   
    
      ELSEIF(isub.LE.20) THEN   
      IF(isub.EQ.11) THEN   
C...f + f' -> f + f'.   
        facqq1=comfac*as**2*4./9.*(sh2+uh2)/th2 
        facqqb=comfac*as**2*4./9.*((sh2+uh2)/th2*faca-  
     &  mstp(34)*2./3.*uh2/(sh*th)) 
        facqq2=comfac*as**2*4./9.*((sh2+th2)/uh2-   
     &  mstp(34)*2./3.*sh2/(th*uh)) 
        DO 240 i=min1,max1  
        IF(i.EQ.0.OR.kfac(1,i).EQ.0) goto 240   
        DO 230 j=min2,max2  
        IF(j.EQ.0.OR.kfac(2,j).EQ.0) goto 230   
        nchn=nchn+1 
        isig(nchn,1)=i  
        isig(nchn,2)=j  
        isig(nchn,3)=1  
        sigh(nchn)=facqq1   
        IF(i.EQ.-j) sigh(nchn)=facqqb   
        IF(i.EQ.j) THEN 
          sigh(nchn)=0.5*sigh(nchn) 
          nchn=nchn+1   
          isig(nchn,1)=i    
          isig(nchn,2)=j    
          isig(nchn,3)=2    
          sigh(nchn)=0.5*facqq2 
        ENDIF   
  230   CONTINUE    
  240   CONTINUE    
    
      ELSEIF(isub.EQ.12) THEN   
C...f + fb -> f' + fb' (q + qb -> q' + qb' only).   
        CALL pywidt(21,sqrt(sh),wdtp,wdte)  
        facqqb=comfac*as**2*4./9.*(th2+uh2)/sh2*(wdte(0,1)+wdte(0,2)+   
     &  wdte(0,3)+wdte(0,4))    
        DO 250 i=mina,maxa  
        IF(i.EQ.0.OR.kfac(1,i)*kfac(2,-i).EQ.0) goto 250    
        nchn=nchn+1 
        isig(nchn,1)=i  
        isig(nchn,2)=-i 
        isig(nchn,3)=1  
        sigh(nchn)=facqqb   
  250   CONTINUE    
    
      ELSEIF(isub.EQ.13) THEN   
C...f + fb -> g + g (q + qb -> g + g only). 
        facgg1=comfac*as**2*32./27.*(uh/th-(2.+mstp(34)*1./4.)*uh2/sh2) 
        facgg2=comfac*as**2*32./27.*(th/uh-(2.+mstp(34)*1./4.)*th2/sh2) 
        DO 260 i=mina,maxa  
        IF(i.EQ.0.OR.kfac(1,i)*kfac(2,-i).EQ.0) goto 260    
        nchn=nchn+1 
        isig(nchn,1)=i  
        isig(nchn,2)=-i 
        isig(nchn,3)=1  
        sigh(nchn)=0.5*facgg1   
        nchn=nchn+1 
        isig(nchn,1)=i  
        isig(nchn,2)=-i 
        isig(nchn,3)=2  
        sigh(nchn)=0.5*facgg2   
  260   CONTINUE    
    
      ELSEIF(isub.EQ.14) THEN   
C...f + fb -> g + gamma (q + qb -> g + gamma only). 
        facgg=comfac*as*aem*8./9.*(th2+uh2)/(th*uh) 
        DO 270 i=mina,maxa  
        IF(i.EQ.0.OR.kfac(1,i)*kfac(2,-i).EQ.0) goto 270    
        ei=kchg(iabs(i),1)/3.   
        nchn=nchn+1 
        isig(nchn,1)=i  
        isig(nchn,2)=-i 
        isig(nchn,3)=1  
        sigh(nchn)=facgg*ei**2  
  270   CONTINUE    
    
      ELSEIF(isub.EQ.15) THEN   
C...f + fb -> g + Z0 (q + qb -> g + Z0 only).   
        faczg=comfac*as*aem/(xw*(1.-xw))*1./18.*    
     &  (th2+uh2+2.*sqm4*sh)/(th*uh)    
        faczg=faczg*wids(23,2)  
        DO 280 i=mina,maxa  
        IF(i.EQ.0.OR.kfac(1,i)*kfac(2,-i).EQ.0) goto 280    
        ei=kchg(iabs(i),1)/3.   
        ai=sign(1.,ei)  
        vi=ai-4.*ei*xw  
        nchn=nchn+1 
        isig(nchn,1)=i  
        isig(nchn,2)=-i 
        isig(nchn,3)=1  
        sigh(nchn)=faczg*(vi**2+ai**2)  
  280   CONTINUE    
    
      ELSEIF(isub.EQ.16) THEN   
C...f + fb' -> g + W+/- (q + qb' -> g + W+/- only). 
        facwg=comfac*as*aem/xw*2./9.*(th2+uh2+2.*sqm4*sh)/(th*uh)   
        DO 300 i=min1,max1  
        IF(i.EQ.0.OR.kfac(1,i).EQ.0) goto 300   
        ia=iabs(i)  
        DO 290 j=min2,max2  
        IF(j.EQ.0.OR.kfac(2,j).EQ.0) goto 290   
        ja=iabs(j)  
        IF(i*j.GT.0.OR.mod(ia+ja,2).EQ.0) goto 290  
        kchw=(kchg(ia,1)*isign(1,i)+kchg(ja,1)*isign(1,j))/3    
        fckm=1. 
        IF(mint(43).EQ.4) fckm=vckm((ia+1)/2,(ja+1)/2)  
        nchn=nchn+1 
        isig(nchn,1)=i  
        isig(nchn,2)=j  
        isig(nchn,3)=1  
        sigh(nchn)=facwg*fckm*wids(24,(5-kchw)/2)   
  290   CONTINUE    
  300   CONTINUE    
    
      ELSEIF(isub.EQ.17) THEN   
C...f + fb -> g + H0 (q + qb -> g + H0 only).   
    
      ELSEIF(isub.EQ.18) THEN   
C...f + fb -> gamma + gamma.    
        facgg=comfac*faca*aem**2*1./3.*(th2+uh2)/(th*uh)    
        DO 310 i=mina,maxa  
        IF(i.EQ.0.OR.kfac(1,i)*kfac(2,-i).EQ.0) goto 310    
        ei=kchg(iabs(i),1)/3.   
        nchn=nchn+1 
        isig(nchn,1)=i  
        isig(nchn,2)=-i 
        isig(nchn,3)=1  
        sigh(nchn)=facgg*ei**4  
  310   CONTINUE    
    
      ELSEIF(isub.EQ.19) THEN   
C...f + fb -> gamma + Z0.   
        facgz=comfac*faca*aem**2/(xw*(1.-xw))*1./24.*   
     &  (th2+uh2+2.*sqm4*sh)/(th*uh)    
        facgz=facgz*wids(23,2)  
        DO 320 i=mina,maxa  
        IF(i.EQ.0.OR.kfac(1,i)*kfac(2,-i).EQ.0) goto 320    
        ei=kchg(iabs(i),1)/3.   
        ai=sign(1.,ei)  
        vi=ai-4.*ei*xw  
        nchn=nchn+1 
        isig(nchn,1)=i  
        isig(nchn,2)=-i 
        isig(nchn,3)=1  
        sigh(nchn)=facgz*ei**2*(vi**2+ai**2)    
  320   CONTINUE    
    
      ELSEIF(isub.EQ.20) THEN   
C...f + fb' -> gamma + W+/-.    
        facgw=comfac*faca*aem**2/xw*1./6.*  
     &  ((2.*uh-th)/(3.*(sh-sqm4)))**2*(th2+uh2+2.*sqm4*sh)/(th*uh) 
        DO 340 i=min1,max1  
        IF(i.EQ.0.OR.kfac(1,i).EQ.0) goto 340   
        ia=iabs(i)  
        DO 330 j=min2,max2  
        IF(j.EQ.0.OR.kfac(2,j).EQ.0) goto 330   
        ja=iabs(j)  
        IF(i*j.GT.0.OR.mod(ia+ja,2).EQ.0) goto 330  
        kchw=(kchg(ia,1)*isign(1,i)+kchg(ja,1)*isign(1,j))/3    
        fckm=1. 
        IF(mint(43).EQ.4) fckm=vckm((ia+1)/2,(ja+1)/2)  
        nchn=nchn+1 
        isig(nchn,1)=i  
        isig(nchn,2)=j  
        isig(nchn,3)=1  
        sigh(nchn)=facgw*fckm*wids(24,(5-kchw)/2)   
  330   CONTINUE    
  340   CONTINUE    
      ENDIF 
    
      ELSEIF(isub.LE.30) THEN   
      IF(isub.EQ.21) THEN   
C...f + fb -> gamma + H0.   
    
      ELSEIF(isub.EQ.22) THEN   
C...f + fb -> Z0 + Z0.  
        faczz=comfac*faca*(aem/(xw*(1.-xw)))**2*1./768.*    
     &  (uh/th+th/uh+2.*(sqm3+sqm4)*sh/(th*uh)- 
     &  sqm3*sqm4*(1./th2+1./uh2))  
        faczz=faczz*wids(23,1)  
        DO 350 i=mina,maxa  
        IF(i.EQ.0.OR.kfac(1,i)*kfac(2,-i).EQ.0) goto 350    
        ei=kchg(iabs(i),1)/3.   
        ai=sign(1.,ei)  
        vi=ai-4.*ei*xw  
        nchn=nchn+1 
        isig(nchn,1)=i  
        isig(nchn,2)=-i 
        isig(nchn,3)=1  
        sigh(nchn)=faczz*(vi**4+6.*vi**2*ai**2+ai**4)   
  350   CONTINUE    
    
      ELSEIF(isub.EQ.23) THEN   
C...f + fb' -> Z0 + W+/-.   
        faczw=comfac*faca*(aem/xw)**2*1./6. 
        faczw=faczw*wids(23,2)  
        thuh=max(th*uh-sqm3*sqm4,sh*ckin(3)**2) 
        DO 370 i=min1,max1  
        IF(i.EQ.0.OR.kfac(1,i).EQ.0) goto 370   
        ia=iabs(i)  
        DO 360 j=min2,max2  
        IF(j.EQ.0.OR.kfac(2,j).EQ.0) goto 360   
        ja=iabs(j)  
        IF(i*j.GT.0.OR.mod(ia+ja,2).EQ.0) goto 360  
        kchw=(kchg(ia,1)*isign(1,i)+kchg(ja,1)*isign(1,j))/3    
        ei=kchg(ia,1)/3.    
        ai=sign(1.,ei)  
        vi=ai-4.*ei*xw  
        ej=kchg(ja,1)/3.    
        aj=sign(1.,ej)  
        vj=aj-4.*ej*xw  
        IF(vi+ai.GT.0) THEN 
          visav=vi  
          aisav=ai  
          vi=vj 
          ai=aj 
          vj=visav  
          aj=aisav  
        ENDIF   
        fckm=1. 
        IF(mint(43).EQ.4) fckm=vckm((ia+1)/2,(ja+1)/2)  
        nchn=nchn+1 
        isig(nchn,1)=i  
        isig(nchn,2)=j  
        isig(nchn,3)=1  
        sigh(nchn)=faczw*fckm*(1./(sh-sqmw)**2* 
     &  ((9.-8.*xw)/4.*thuh+(8.*xw-6.)/4.*sh*(sqm3+sqm4))+  
     &  (thuh-sh*(sqm3+sqm4))/(2.*(sh-sqmw))*((vj+aj)/th-(vi+ai)/uh)+   
     &  thuh/(16.*(1.-xw))*((vj+aj)**2/th2+(vi+ai)**2/uh2)+ 
     &  sh*(sqm3+sqm4)/(8.*(1.-xw))*(vi+ai)*(vj+aj)/(th*uh))*   
     &  wids(24,(5-kchw)/2) 
  360   CONTINUE    
  370   CONTINUE    
    
      ELSEIF(isub.EQ.24) THEN   
C...f + fb -> Z0 + H0.  
        thuh=max(th*uh-sqm3*sqm4,sh*ckin(3)**2) 
        fachz=comfac*faca*(aem/(xw*(1.-xw)))**2*1./96.* 
     &  (thuh+2.*sh*sqmz)/(sh-sqmz)**2  
        fachz=fachz*wids(23,2)*wids(25,2)   
        DO 380 i=mina,maxa  
        IF(i.EQ.0.OR.kfac(1,i)*kfac(2,-i).EQ.0) goto 380    
        ei=kchg(iabs(i),1)/3.   
        ai=sign(1.,ei)  
        vi=ai-4.*ei*xw  
        nchn=nchn+1 
        isig(nchn,1)=i  
        isig(nchn,2)=-i 
        isig(nchn,3)=1  
        sigh(nchn)=fachz*(vi**2+ai**2)  
  380   CONTINUE    
    
      ELSEIF(isub.EQ.25) THEN   
C...f + fb -> W+ + W-.  
        facww=comfac*faca*(aem/xw)**2*1./12.    
        facww=facww*wids(24,1)  
        thuh=max(th*uh-sqm3*sqm4,sh*ckin(3)**2) 
        DO 390 i=mina,maxa  
        IF(i.EQ.0.OR.kfac(1,i)*kfac(2,-i).EQ.0) goto 390    
        ei=kchg(iabs(i),1)/3.   
        ai=sign(1.,ei)  
        vi=ai-4.*ei*xw  
        dsigww=thuh/sh2*(3.-(sh-3.*(sqm3+sqm4))/(sh-sqmz)*  
     &  (vi+ai)/(2.*ai*(1.-xw))+(sh/(sh-sqmz))**2*  
     &  (1.-2.*(sqm3+sqm4)/sh+12.*sqm3*sqm4/sh2)*(vi**2+ai**2)/ 
     &  (8.*(1.-xw)**2))-2.*sqmz/(sh-sqmz)*(vi+ai)/ai+  
     &  sqmz*sh/(sh-sqmz)**2*(1.-2.*(sqm3+sqm4)/sh)*(vi**2+ai**2)/  
     &  (2.*(1.-xw))    
        IF(kchg(iabs(i),1).LT.0) THEN   
          dsigww=dsigww+2.*(1.+sqmz/(sh-sqmz)*(vi+ai)/(2.*ai))* 
     &    (thuh/(sh*th)-(sqm3+sqm4)/th)+thuh/th2    
        ELSE    
          dsigww=dsigww+2.*(1.+sqmz/(sh-sqmz)*(vi+ai)/(2.*ai))* 
     &    (thuh/(sh*uh)-(sqm3+sqm4)/uh)+thuh/uh2    
        ENDIF   
        nchn=nchn+1 
        isig(nchn,1)=i  
        isig(nchn,2)=-i 
        isig(nchn,3)=1  
        sigh(nchn)=facww*dsigww 
  390   CONTINUE    
    
      ELSEIF(isub.EQ.26) THEN   
C...f + fb' -> W+/- + H0.   
        thuh=max(th*uh-sqm3*sqm4,sh*ckin(3)**2) 
        fachw=comfac*faca*(aem/xw)**2*1./24.*(thuh+2.*sh*sqmw)/ 
     &  (sh-sqmw)**2    
        fachw=fachw*wids(25,2)  
        DO 410 i=min1,max1  
        IF(i.EQ.0.OR.kfac(1,i).EQ.0) goto 410   
        ia=iabs(i)  
        DO 400 j=min2,max2  
        IF(j.EQ.0.OR.kfac(1,j).EQ.0) goto 400   
        ja=iabs(j)  
        IF(i*j.GT.0.OR.mod(ia+ja,2).EQ.0) goto 400  
        kchw=(kchg(ia,1)*isign(1,i)+kchg(ja,1)*isign(1,j))/3    
        fckm=1. 
        IF(mint(43).EQ.4) fckm=vckm((ia+1)/2,(ja+1)/2)  
        nchn=nchn+1 
        isig(nchn,1)=i  
        isig(nchn,2)=j  
        isig(nchn,3)=1  
        sigh(nchn)=fachw*fckm*wids(24,(5-kchw)/2)   
  400   CONTINUE    
  410   CONTINUE    
    
      ELSEIF(isub.EQ.27) THEN   
C...f + fb -> H0 + H0.  
    
      ELSEIF(isub.EQ.28) THEN   
C...f + g -> f + g (q + g -> q + g only).   
        facqg1=comfac*as**2*4./9.*((2.+mstp(34)*1./4.)*uh2/th2-uh/sh)*  
     &  faca    
        facqg2=comfac*as**2*4./9.*((2.+mstp(34)*1./4.)*sh2/th2-sh/uh)   
        DO 430 i=mina,maxa  
        IF(i.EQ.0) goto 430 
        DO 420 isde=1,2 
        IF(isde.EQ.1.AND.kfac(1,i)*kfac(2,21).EQ.0) goto 420    
        IF(isde.EQ.2.AND.kfac(1,21)*kfac(2,i).EQ.0) goto 420    
        nchn=nchn+1 
        isig(nchn,isde)=i   
        isig(nchn,3-isde)=21    
        isig(nchn,3)=1  
        sigh(nchn)=facqg1   
        nchn=nchn+1 
        isig(nchn,isde)=i   
        isig(nchn,3-isde)=21    
        isig(nchn,3)=2  
        sigh(nchn)=facqg2   
  420   CONTINUE    
  430   CONTINUE    
    
      ELSEIF(isub.EQ.29) THEN   
C...f + g -> f + gamma (q + g -> q + gamma only).   
        fgq=comfac*faca*as*aem*1./3.*(sh2+uh2)/(-sh*uh) 
        DO 450 i=mina,maxa  
        IF(i.EQ.0) goto 450 
        ei=kchg(iabs(i),1)/3.   
        facgq=fgq*ei**2 
        DO 440 isde=1,2 
        IF(isde.EQ.1.AND.kfac(1,i)*kfac(2,21).EQ.0) goto 440    
        IF(isde.EQ.2.AND.kfac(1,21)*kfac(2,i).EQ.0) goto 440    
        nchn=nchn+1 
        isig(nchn,isde)=i   
        isig(nchn,3-isde)=21    
        isig(nchn,3)=1  
        sigh(nchn)=facgq    
  440   CONTINUE    
  450   CONTINUE    
    
      ELSEIF(isub.EQ.30) THEN   
C...f + g -> f + Z0 (q + g -> q + Z0 only). 
        fzq=comfac*faca*as*aem/(xw*(1.-xw))*1./48.* 
     &  (sh2+uh2+2.*sqm4*th)/(-sh*uh)   
        fzq=fzq*wids(23,2)  
        DO 470 i=mina,maxa  
        IF(i.EQ.0) goto 470 
        ei=kchg(iabs(i),1)/3.   
        ai=sign(1.,ei)  
        vi=ai-4.*ei*xw  
        faczq=fzq*(vi**2+ai**2) 
        DO 460 isde=1,2 
        IF(isde.EQ.1.AND.kfac(1,i)*kfac(2,21).EQ.0) goto 460    
        IF(isde.EQ.2.AND.kfac(1,21)*kfac(2,i).EQ.0) goto 460    
        nchn=nchn+1 
        isig(nchn,isde)=i   
        isig(nchn,3-isde)=21    
        isig(nchn,3)=1  
        sigh(nchn)=faczq    
  460   CONTINUE    
  470   CONTINUE    
      ENDIF 
    
      ELSEIF(isub.LE.40) THEN   
      IF(isub.EQ.31) THEN   
C...f + g -> f' + W+/- (q + g -> q' + W+/- only).   
        facwq=comfac*faca*as*aem/xw*1./12.* 
     &  (sh2+uh2+2.*sqm4*th)/(-sh*uh)   
        DO 490 i=mina,maxa  
        IF(i.EQ.0) goto 490 
        ia=iabs(i)  
        kchw=isign(1,kchg(ia,1)*isign(1,i)) 
        DO 480 isde=1,2 
        IF(isde.EQ.1.AND.kfac(1,i)*kfac(2,21).EQ.0) goto 480    
        IF(isde.EQ.2.AND.kfac(1,21)*kfac(2,i).EQ.0) goto 480    
        nchn=nchn+1 
        isig(nchn,isde)=i   
        isig(nchn,3-isde)=21    
        isig(nchn,3)=1  
        sigh(nchn)=facwq*vint(180+i)*wids(24,(5-kchw)/2)    
  480   CONTINUE    
  490   CONTINUE    
    
      ELSEIF(isub.EQ.32) THEN   
C...f + g -> f + H0 (q + g -> q + H0 only). 
    
      ELSEIF(isub.EQ.33) THEN   
C...f + gamma -> f + g (q + gamma -> q + g only).   
    
      ELSEIF(isub.EQ.34) THEN   
C...f + gamma -> f + gamma. 
    
      ELSEIF(isub.EQ.35) THEN   
C...f + gamma -> f + Z0.    
    
      ELSEIF(isub.EQ.36) THEN   
C...f + gamma -> f' + W+/-. 
    
      ELSEIF(isub.EQ.37) THEN   
C...f + gamma -> f + H0.    
    
      ELSEIF(isub.EQ.38) THEN   
C...f + Z0 -> f + g (q + Z0 -> q + g only). 
    
      ELSEIF(isub.EQ.39) THEN   
C...f + Z0 -> f + gamma.    
    
      ELSEIF(isub.EQ.40) THEN   
C...f + Z0 -> f + Z0.   
      ENDIF 
    
      ELSEIF(isub.LE.50) THEN   
      IF(isub.EQ.41) THEN   
C...f + Z0 -> f' + W+/-.    
    
      ELSEIF(isub.EQ.42) THEN   
C...f + Z0 -> f + H0.   
    
      ELSEIF(isub.EQ.43) THEN   
C...f + W+/- -> f' + g (q + W+/- -> q' + g only).   
    
      ELSEIF(isub.EQ.44) THEN   
C...f + W+/- -> f' + gamma. 
    
      ELSEIF(isub.EQ.45) THEN   
C...f + W+/- -> f' + Z0.    
    
      ELSEIF(isub.EQ.46) THEN   
C...f + W+/- -> f' + W+/-.  
    
      ELSEIF(isub.EQ.47) THEN   
C...f + W+/- -> f' + H0.    
    
      ELSEIF(isub.EQ.48) THEN   
C...f + H0 -> f + g (q + H0 -> q + g only). 
    
      ELSEIF(isub.EQ.49) THEN   
C...f + H0 -> f + gamma.    
    
      ELSEIF(isub.EQ.50) THEN   
C...f + H0 -> f + Z0.   
      ENDIF 
    
      ELSEIF(isub.LE.60) THEN   
      IF(isub.EQ.51) THEN   
C...f + H0 -> f' + W+/-.    
    
      ELSEIF(isub.EQ.52) THEN   
C...f + H0 -> f + H0.   
    
      ELSEIF(isub.EQ.53) THEN   
C...g + g -> f + fb (g + g -> q + qb only). 
        CALL pywidt(21,sqrt(sh),wdtp,wdte)  
        facqq1=comfac*as**2*1./6.*(uh/th-(2.+mstp(34)*1./4.)*uh2/sh2)*  
     &  (wdte(0,1)+wdte(0,2)+wdte(0,3)+wdte(0,4))*faca  
        facqq2=comfac*as**2*1./6.*(th/uh-(2.+mstp(34)*1./4.)*th2/sh2)*  
     &  (wdte(0,1)+wdte(0,2)+wdte(0,3)+wdte(0,4))*faca  
        IF(kfac(1,21)*kfac(2,21).EQ.0) goto 500 
        nchn=nchn+1 
        isig(nchn,1)=21 
        isig(nchn,2)=21 
        isig(nchn,3)=1  
        sigh(nchn)=facqq1   
        nchn=nchn+1 
        isig(nchn,1)=21 
        isig(nchn,2)=21 
        isig(nchn,3)=2  
        sigh(nchn)=facqq2   
  500   CONTINUE    
    
      ELSEIF(isub.EQ.54) THEN   
C...g + gamma -> f + fb (g + gamma -> q + qb only). 
    
      ELSEIF(isub.EQ.55) THEN   
C...g + gamma -> f + fb (g + gamma -> q + qb only). 
    
      ELSEIF(isub.EQ.56) THEN   
C...g + gamma -> f + fb (g + gamma -> q + qb only). 
    
      ELSEIF(isub.EQ.57) THEN   
C...g + gamma -> f + fb (g + gamma -> q + qb only). 
    
      ELSEIF(isub.EQ.58) THEN   
C...gamma + gamma -> f + fb.    
    
      ELSEIF(isub.EQ.59) THEN   
C...gamma + Z0 -> f + fb.   
    
      ELSEIF(isub.EQ.60) THEN   
C...gamma + W+/- -> f + fb'.    
      ENDIF 
    
      ELSEIF(isub.LE.70) THEN   
      IF(isub.EQ.61) THEN   
C...gamma + H0 -> f + fb.   
    
      ELSEIF(isub.EQ.62) THEN   
C...Z0 + Z0 -> f + fb.  
    
      ELSEIF(isub.EQ.63) THEN   
C...Z0 + W+/- -> f + fb'.   
    
      ELSEIF(isub.EQ.64) THEN   
C...Z0 + H0 -> f + fb.  
    
      ELSEIF(isub.EQ.65) THEN   
C...W+ + W- -> f + fb.  
    
      ELSEIF(isub.EQ.66) THEN   
C...W+/- + H0 -> f + fb'.   
    
      ELSEIF(isub.EQ.67) THEN   
C...H0 + H0 -> f + fb.  
    
      ELSEIF(isub.EQ.68) THEN   
C...g + g -> g + g. 
        facgg1=comfac*as**2*9./4.*(sh2/th2+2.*sh/th+3.+2.*th/sh+    
     &  th2/sh2)*faca   
        facgg2=comfac*as**2*9./4.*(uh2/sh2+2.*uh/sh+3.+2.*sh/uh+    
     &  sh2/uh2)*faca   
        facgg3=comfac*as**2*9./4.*(th2/uh2+2.*th/uh+3+2.*uh/th+uh2/th2) 
        IF(kfac(1,21)*kfac(2,21).EQ.0) goto 510 
        nchn=nchn+1 
        isig(nchn,1)=21 
        isig(nchn,2)=21 
        isig(nchn,3)=1  
        sigh(nchn)=0.5*facgg1   
        nchn=nchn+1 
        isig(nchn,1)=21 
        isig(nchn,2)=21 
        isig(nchn,3)=2  
        sigh(nchn)=0.5*facgg2   
        nchn=nchn+1 
        isig(nchn,1)=21 
        isig(nchn,2)=21 
        isig(nchn,3)=3  
        sigh(nchn)=0.5*facgg3   
  510   CONTINUE    
    
      ELSEIF(isub.EQ.69) THEN   
C...gamma + gamma -> W+ + W-.   
    
      ELSEIF(isub.EQ.70) THEN   
C...gamma + W+/- -> gamma + W+/-.   
      ENDIF 
    
      ELSEIF(isub.LE.80) THEN   
      IF(isub.EQ.71) THEN   
C...Z0 + Z0 -> Z0 + Z0. 
        be2=1.-4.*sqmz/sh   
        th=-0.5*sh*be2*(1.-cth) 
        uh=-0.5*sh*be2*(1.+cth) 
        shang=1./(1.-xw)*sqmw/sqmz*(1.+be2)**2  
        ashre=(sh-sqmh)/((sh-sqmh)**2+gmmh**2)*shang    
        ashim=-gmmh/((sh-sqmh)**2+gmmh**2)*shang    
        thang=1./(1.-xw)*sqmw/sqmz*(be2-cth)**2 
        athre=(th-sqmh)/((th-sqmh)**2+gmmh**2)*thang    
        athim=-gmmh/((th-sqmh)**2+gmmh**2)*thang    
        uhang=1./(1.-xw)*sqmw/sqmz*(be2+cth)**2 
        auhre=(uh-sqmh)/((uh-sqmh)**2+gmmh**2)*uhang    
        auhim=-gmmh/((uh-sqmh)**2+gmmh**2)*uhang    
        fach=0.5*comfac*1./(4096.*paru(1)**2*16.*(1.-xw)**2)*   
     &  (aem/xw)**4*(sh/sqmw)**2*((ashre+athre+auhre)**2+   
     &  (ashim+athim+auhim)**2)*sqmz/sqmw   
        DO 530 i=min1,max1  
        IF(i.EQ.0.OR.kfac(1,i).EQ.0) goto 530   
        ei=kchg(iabs(i),1)/3.   
        ai=sign(1.,ei)  
        vi=ai-4.*ei*xw  
        avi=ai**2+vi**2 
        DO 520 j=min2,max2  
        IF(j.EQ.0.OR.kfac(2,j).EQ.0) goto 520   
        ej=kchg(iabs(j),1)/3.   
        aj=sign(1.,ej)  
        vj=aj-4.*ej*xw  
        avj=aj**2+vj**2 
        nchn=nchn+1 
        isig(nchn,1)=i  
        isig(nchn,2)=j  
        isig(nchn,3)=1  
        sigh(nchn)=fach*avi*avj 
  520   CONTINUE    
  530   CONTINUE    
    
      ELSEIF(isub.EQ.72) THEN   
C...Z0 + Z0 -> W+ + W-. 
        be2=sqrt((1.-4.*sqmw/sh)*(1.-4.*sqmz/sh))   
        cth2=cth**2 
        th=-0.5*sh*(1.-2.*(sqmw+sqmz)/sh-be2*cth)   
        uh=-0.5*sh*(1.-2.*(sqmw+sqmz)/sh+be2*cth)   
        shang=4.*sqrt(sqmw/(sqmz*(1.-xw)))*(1.-2.*sqmw/sh)* 
     &  (1.-2.*sqmz/sh) 
        ashre=(sh-sqmh)/((sh-sqmh)**2+gmmh**2)*shang    
        ashim=-gmmh/((sh-sqmh)**2+gmmh**2)*shang    
        atwre=(1.-xw)/sqmz*sh/(th-sqmw)*((cth-be2)**2*(3./2.+be2/2.*cth-    
     &  (sqmw+sqmz)/sh+(sqmw-sqmz)**2/(sh*sqmw))+4.*((sqmw+sqmz)/sh*    
     &  (1.-3.*cth2)+8.*sqmw*sqmz/sh2*(2.*cth2-1.)+ 
     &  4.*(sqmw**2+sqmz**2)/sh2*cth2+2.*(sqmw+sqmz)/sh*be2*cth))   
        atwim=0.    
        auwre=(1.-xw)/sqmz*sh/(uh-sqmw)*((cth+be2)**2*(3./2.-be2/2.*cth-    
     &  (sqmw+sqmz)/sh+(sqmw-sqmz)**2/(sh*sqmw))+4.*((sqmw+sqmz)/sh*    
     &  (1.-3.*cth2)+8.*sqmw*sqmz/sh2*(2.*cth2-1.)+ 
     &  4.*(sqmw**2+sqmz**2)/sh2*cth2-2.*(sqmw+sqmz)/sh*be2*cth))   
        auwim=0.    
        a4re=2.*(1.-xw)/sqmz*(3.-cth2-4.*(sqmw+sqmz)/sh)    
        a4im=0. 
        fach=comfac*1./(4096.*paru(1)**2*16.*(1.-xw)**2)*(aem/xw)**4*   
     &  (sh/sqmw)**2*((ashre+atwre+auwre+a4re)**2+  
     &  (ashim+atwim+auwim+a4im)**2)*sqmz/sqmw  
        DO 550 i=min1,max1  
        IF(i.EQ.0.OR.kfac(1,i).EQ.0) goto 550   
        ei=kchg(iabs(i),1)/3.   
        ai=sign(1.,ei)  
        vi=ai-4.*ei*xw  
        avi=ai**2+vi**2 
        DO 540 j=min2,max2  
        IF(j.EQ.0.OR.kfac(2,j).EQ.0) goto 540   
        ej=kchg(iabs(j),1)/3.   
        aj=sign(1.,ej)  
        vj=aj-4.*ej*xw  
        avj=aj**2+vj**2 
        nchn=nchn+1 
        isig(nchn,1)=i  
        isig(nchn,2)=j  
        isig(nchn,3)=1  
        sigh(nchn)=fach*avi*avj 
  540   CONTINUE    
  550   CONTINUE    
    
      ELSEIF(isub.EQ.73) THEN   
C...Z0 + W+/- -> Z0 + W+/-. 
        be2=1.-2.*(sqmz+sqmw)/sh+((sqmz-sqmw)/sh)**2    
        ep1=1.+(sqmz-sqmw)/sh   
        ep2=1.-(sqmz-sqmw)/sh   
        th=-0.5*sh*be2*(1.-cth) 
        uh=(sqmz-sqmw)**2/sh-0.5*sh*be2*(1.+cth)    
        thang=sqrt(sqmw/(sqmz*(1.-xw)))*(be2-ep1*cth)*(be2-ep2*cth) 
        athre=(th-sqmh)/((th-sqmh)**2+gmmh**2)*thang    
        athim=-gmmh/((th-sqmh)**2+gmmh**2)*thang    
        aswre=(1.-xw)/sqmz*sh/(sh-sqmw)*(-be2*(ep1+ep2)**4*cth+ 
     &  1./4.*(be2+ep1*ep2)**2*((ep1-ep2)**2-4.*be2*cth)+   
     &  2.*be2*(be2+ep1*ep2)*(ep1+ep2)**2*cth-  
     &  1./16.*sh/sqmw*(ep1**2-ep2**2)**2*(be2+ep1*ep2)**2) 
        aswim=0.    
        auwre=(1.-xw)/sqmz*sh/(uh-sqmw)*(-be2*(ep2+ep1*cth)*    
     &  (ep1+ep2*cth)*(be2+ep1*ep2)+be2*(ep2+ep1*cth)*  
     &  (be2+ep1*ep2*cth)*(2.*ep2-ep2*cth+ep1)-be2*(ep2+ep1*cth)**2*    
     &  (be2-ep2**2*cth)-1./8.*(be2+ep1*ep2*cth)**2*((ep1+ep2)**2+  
     &  2.*be2*(1.-cth))+1./32.*sh/sqmw*(be2+ep1*ep2*cth)**2*   
     &  (ep1**2-ep2**2)**2-be2*(ep1+ep2*cth)*(ep2+ep1*cth)* 
     &  (be2+ep1*ep2)+be2*(ep1+ep2*cth)*(be2+ep1*ep2*cth)*  
     &  (2.*ep1-ep1*cth+ep2)-be2*(ep1+ep2*cth)**2*(be2-ep1**2*cth)- 
     &  1./8.*(be2+ep1*ep2*cth)**2*((ep1+ep2)**2+2.*be2*(1.-cth))+  
     &  1./32.*sh/sqmw*(be2+ep1*ep2*cth)**2*(ep1**2-ep2**2)**2) 
        auwim=0.    
        a4re=(1.-xw)/sqmz*(ep1**2*ep2**2*(cth**2-1.)-   
     &  2.*be2*(ep1**2+ep2**2+ep1*ep2)*cth-2.*be2*ep1*ep2)  
        a4im=0. 
        fach=comfac*1./(4096.*paru(1)**2*4.*(1.-xw))*(aem/xw)**4*   
     &  (sh/sqmw)**2*((athre+aswre+auwre+a4re)**2+  
     &  (athim+aswim+auwim+a4im)**2)*sqrt(sqmz/sqmw)    
        DO 570 i=min1,max1  
        IF(i.EQ.0.OR.kfac(1,i).EQ.0) goto 570   
        ei=kchg(iabs(i),1)/3.   
        ai=sign(1.,ei)  
        vi=ai-4.*ei*xw  
        avi=ai**2+vi**2 
        DO 560 j=min2,max2  
        IF(j.EQ.0.OR.kfac(2,j).EQ.0) goto 560   
        ej=kchg(iabs(j),1)/3.   
        aj=sign(1.,ej)  
        vj=ai-4.*ej*xw  
        avj=aj**2+vj**2 
        nchn=nchn+1 
        isig(nchn,1)=i  
        isig(nchn,2)=j  
        isig(nchn,3)=1  
        sigh(nchn)=fach*(avi*vint(180+j)+vint(180+i)*avj)   
  560   CONTINUE    
  570   CONTINUE    
    
      ELSEIF(isub.EQ.75) THEN   
C...W+ + W- -> gamma + gamma.   
    
      ELSEIF(isub.EQ.76) THEN   
C...W+ + W- -> Z0 + Z0. 
        be2=sqrt((1.-4.*sqmw/sh)*(1.-4.*sqmz/sh))   
        cth2=cth**2 
        th=-0.5*sh*(1.-2.*(sqmw+sqmz)/sh-be2*cth)   
        uh=-0.5*sh*(1.-2.*(sqmw+sqmz)/sh+be2*cth)   
        shang=4.*sqrt(sqmw/(sqmz*(1.-xw)))*(1.-2.*sqmw/sh)* 
     &  (1.-2.*sqmz/sh) 
        ashre=(sh-sqmh)/((sh-sqmh)**2+gmmh**2)*shang    
        ashim=-gmmh/((sh-sqmh)**2+gmmh**2)*shang    
        atwre=(1.-xw)/sqmz*sh/(th-sqmw)*((cth-be2)**2*(3./2.+be2/2.*cth-    
     &  (sqmw+sqmz)/sh+(sqmw-sqmz)**2/(sh*sqmw))+4.*((sqmw+sqmz)/sh*    
     &  (1.-3.*cth2)+8.*sqmw*sqmz/sh2*(2.*cth2-1.)+ 
     &  4.*(sqmw**2+sqmz**2)/sh2*cth2+2.*(sqmw+sqmz)/sh*be2*cth))   
        atwim=0.    
        auwre=(1.-xw)/sqmz*sh/(uh-sqmw)*((cth+be2)**2*(3./2.-be2/2.*cth-    
     &  (sqmw+sqmz)/sh+(sqmw-sqmz)**2/(sh*sqmw))+4.*((sqmw+sqmz)/sh*    
     &  (1.-3.*cth2)+8.*sqmw*sqmz/sh2*(2.*cth2-1.)+ 
     &  4.*(sqmw**2+sqmz**2)/sh2*cth2-2.*(sqmw+sqmz)/sh*be2*cth))   
        auwim=0.    
        a4re=2.*(1.-xw)/sqmz*(3.-cth2-4.*(sqmw+sqmz)/sh)    
        a4im=0. 
        fach=0.5*comfac*1./(4096.*paru(1)**2)*(aem/xw)**4*(sh/sqmw)**2* 
     &  ((ashre+atwre+auwre+a4re)**2+(ashim+atwim+auwim+a4im)**2)   
        DO 590 i=min1,max1  
        IF(i.EQ.0.OR.kfac(1,i).EQ.0) goto 590   
        ei=sign(1.,float(i))*kchg(iabs(i),1)    
        DO 580 j=min2,max2  
        IF(j.EQ.0.OR.kfac(2,j).EQ.0) goto 580   
        ej=sign(1.,float(j))*kchg(iabs(j),1)    
        IF(ei*ej.GT.0.) goto 580    
        nchn=nchn+1 
        isig(nchn,1)=i  
        isig(nchn,2)=j  
        isig(nchn,3)=1  
        sigh(nchn)=fach*vint(180+i)*vint(180+j) 
  580   CONTINUE    
  590   CONTINUE    
    
      ELSEIF(isub.EQ.77) THEN   
C...W+/- + W+/- -> W+/- + W+/-. 
        be2=1.-4.*sqmw/sh   
        be4=be2**2  
        cth2=cth**2 
        cth3=cth**3 
        th=-0.5*sh*be2*(1.-cth) 
        uh=-0.5*sh*be2*(1.+cth) 
        shang=(1.+be2)**2   
        ashre=(sh-sqmh)/((sh-sqmh)**2+gmmh**2)*shang    
        ashim=-gmmh/((sh-sqmh)**2+gmmh**2)*shang    
        thang=(be2-cth)**2  
        athre=(th-sqmh)/((th-sqmh)**2+gmmh**2)*thang    
        athim=-gmmh/((th-sqmh)**2+gmmh**2)*thang    
        sgzang=1./sqmw*be2*(3.-be2)**2*cth  
        asgre=xw*sgzang 
        asgim=0.    
        aszre=(1.-xw)*sh/(sh-sqmz)*sgzang   
        aszim=0.    
        tgzang=1./sqmw*(be2*(4.-2.*be2+be4)+be2*(4.-10.*be2+be4)*cth+   
     &  (2.-11.*be2+10.*be4)*cth2+be2*cth3) 
        atgre=0.5*xw*sh/th*tgzang   
        atgim=0.    
        atzre=0.5*(1.-xw)*sh/(th-sqmz)*tgzang   
        atzim=0.    
        a4re=1./sqmw*(1.+2.*be2-6.*be2*cth-cth2)    
        a4im=0. 
        fach=comfac*1./(4096.*paru(1)**2)*(aem/xw)**4*(sh/sqmw)**2* 
     &  ((ashre+athre+asgre+aszre+atgre+atzre+a4re)**2+ 
     &  (ashim+athim+asgim+aszim+atgim+atzim+a4im)**2)  
        DO 610 i=min1,max1  
        IF(i.EQ.0.OR.kfac(1,i).EQ.0) goto 610   
        ei=sign(1.,float(i))*kchg(iabs(i),1)    
        DO 600 j=min2,max2  
        IF(j.EQ.0.OR.kfac(2,j).EQ.0) goto 600   
        ej=sign(1.,float(j))*kchg(iabs(j),1)    
        IF(ei*ej.GT.0.) goto 600    
        nchn=nchn+1 
        isig(nchn,1)=i  
        isig(nchn,2)=j  
        isig(nchn,3)=1  
        sigh(nchn)=fach*vint(180+i)*vint(180+j) 
  600   CONTINUE    
  610   CONTINUE    
    
      ELSEIF(isub.EQ.78) THEN   
C...W+/- + H0 -> W+/- + H0. 
    
      ELSEIF(isub.EQ.79) THEN   
C...H0 + H0 -> H0 + H0. 
    
      ENDIF 
    
C...C: 2 -> 2, tree diagrams with masses.   
    
      ELSEIF(isub.LE.90) THEN   
      IF(isub.EQ.81) THEN   
C...q + qb -> Q + QB.   
        facqqb=comfac*as**2*4./9.*(((th-sqm3)**2+   
     &  (uh-sqm3)**2)/sh2+2.*sqm3/sh)   
        IF(mstp(35).GE.1) THEN  
          IF(mstp(35).EQ.1) THEN    
            alssg=parp(35)  
          ELSE  
            mst115=mstu(115)    
            mstu(115)=mstp(36)  
            q2bn=sqrt(sqm3*((sqrt(sh)-2.*sqrt(sqm3))**2+parp(36)**2))   
            alssg=ulalps(q2bn)  
            mstu(115)=mst115    
          ENDIF 
          xrepu=paru(1)*alssg/(6.*sqrt(max(1e-20,1.-4.*sqm3/sh)))   
          frepu=xrepu/(exp(min(100.,xrepu))-1.) 
          pari(81)=frepu    
          facqqb=facqqb*frepu   
        ENDIF   
        DO 620 i=mina,maxa  
        IF(i.EQ.0.OR.kfac(1,i)*kfac(2,-i).EQ.0) goto 620    
        nchn=nchn+1 
        isig(nchn,1)=i  
        isig(nchn,2)=-i 
        isig(nchn,3)=1  
        sigh(nchn)=facqqb   
  620   CONTINUE    
    
      ELSEIF(isub.EQ.82) THEN   
C...g + g -> Q + QB.    
        facqq1=comfac*faca*as**2*1./6.*((uh-sqm3)/(th-sqm3)-    
     &  2.*(uh-sqm3)**2/sh2+4.*sqm3/sh*(th*uh-sqm3**2)/(th-sqm3)**2)    
        facqq2=comfac*faca*as**2*1./6.*((th-sqm3)/(uh-sqm3)-    
     &  2.*(th-sqm3)**2/sh2+4.*sqm3/sh*(th*uh-sqm3**2)/(uh-sqm3)**2)    
        IF(mstp(35).GE.1) THEN  
          IF(mstp(35).EQ.1) THEN    
            alssg=parp(35)  
          ELSE  
            mst115=mstu(115)    
            mstu(115)=mstp(36)  
            q2bn=sqrt(sqm3*((sqrt(sh)-2.*sqrt(sqm3))**2+parp(36)**2))   
            alssg=ulalps(q2bn)  
            mstu(115)=mst115    
          ENDIF 
          xattr=4.*paru(1)*alssg/(3.*sqrt(max(1e-20,1.-4.*sqm3/sh)))    
          fattr=xattr/(1.-exp(-min(100.,xattr)))    
          xrepu=paru(1)*alssg/(6.*sqrt(max(1e-20,1.-4.*sqm3/sh)))   
          frepu=xrepu/(exp(min(100.,xrepu))-1.) 
          fatre=(2.*fattr+5.*frepu)/7.  
          pari(81)=fatre    
          facqq1=facqq1*fatre   
          facqq2=facqq2*fatre   
        ENDIF   
        IF(kfac(1,21)*kfac(2,21).EQ.0) goto 630 
        nchn=nchn+1 
        isig(nchn,1)=21 
        isig(nchn,2)=21 
        isig(nchn,3)=1  
        sigh(nchn)=facqq1   
        nchn=nchn+1 
        isig(nchn,1)=21 
        isig(nchn,2)=21 
        isig(nchn,3)=2  
        sigh(nchn)=facqq2   
  630   CONTINUE    
    
      ENDIF 
    
C...D: Mimimum bias processes.  
    
      ELSEIF(isub.LE.100) THEN  
      IF(isub.EQ.91) THEN   
C...Elastic scattering. 
        sigs=xsec(isub,1)   
    
      ELSEIF(isub.EQ.92) THEN   
C...Single diffractive scattering.  
        sigs=xsec(isub,1)   
    
      ELSEIF(isub.EQ.93) THEN   
C...Double diffractive scattering.  
        sigs=xsec(isub,1)   
    
      ELSEIF(isub.EQ.94) THEN   
C...Central diffractive scattering. 
        sigs=xsec(isub,1)   
    
      ELSEIF(isub.EQ.95) THEN   
C...Low-pT scattering.  
        sigs=xsec(isub,1)   
    
      ELSEIF(isub.EQ.96) THEN   
C...Multiple interactions: sum of QCD processes.    
        CALL pywidt(21,sqrt(sh),wdtp,wdte)  
    
C...q + q' -> q + q'.   
        facqq1=comfac*as**2*4./9.*(sh2+uh2)/th2 
        facqqb=comfac*as**2*4./9.*((sh2+uh2)/th2*faca-  
     &  mstp(34)*2./3.*uh2/(sh*th)) 
        facqq2=comfac*as**2*4./9.*((sh2+th2)/uh2-   
     &  mstp(34)*2./3.*sh2/(th*uh)) 
        DO 650 i=-3,3   
        IF(i.EQ.0) goto 650 
        DO 640 j=-3,3   
        IF(j.EQ.0) goto 640 
        nchn=nchn+1 
        isig(nchn,1)=i  
        isig(nchn,2)=j  
        isig(nchn,3)=111    
        sigh(nchn)=facqq1   
        IF(i.EQ.-j) sigh(nchn)=facqqb   
        IF(i.EQ.j) THEN 
          sigh(nchn)=0.5*sigh(nchn) 
          nchn=nchn+1   
          isig(nchn,1)=i    
          isig(nchn,2)=j    
          isig(nchn,3)=112  
          sigh(nchn)=0.5*facqq2 
        ENDIF   
  640   CONTINUE    
  650   CONTINUE    
    
C...q + qb -> q' + qb' or g + g.    
        facqqb=comfac*as**2*4./9.*(th2+uh2)/sh2*(wdte(0,1)+wdte(0,2)+   
     &  wdte(0,3)+wdte(0,4))    
        facgg1=comfac*as**2*32./27.*(uh/th-(2.+mstp(34)*1./4.)*uh2/sh2) 
        facgg2=comfac*as**2*32./27.*(th/uh-(2.+mstp(34)*1./4.)*th2/sh2) 
        DO 660 i=-3,3   
        IF(i.EQ.0) goto 660 
        nchn=nchn+1 
        isig(nchn,1)=i  
        isig(nchn,2)=-i 
        isig(nchn,3)=121    
        sigh(nchn)=facqqb   
        nchn=nchn+1 
        isig(nchn,1)=i  
        isig(nchn,2)=-i 
        isig(nchn,3)=131    
        sigh(nchn)=0.5*facgg1   
        nchn=nchn+1 
        isig(nchn,1)=i  
        isig(nchn,2)=-i 
        isig(nchn,3)=132    
        sigh(nchn)=0.5*facgg2   
  660   CONTINUE    
    
C...q + g -> q + g. 
        facqg1=comfac*as**2*4./9.*((2.+mstp(34)*1./4.)*uh2/th2-uh/sh)*  
     &  faca    
        facqg2=comfac*as**2*4./9.*((2.+mstp(34)*1./4.)*sh2/th2-sh/uh)   
        DO 680 i=-3,3   
        IF(i.EQ.0) goto 680 
        DO 670 isde=1,2 
        nchn=nchn+1 
        isig(nchn,isde)=i   
        isig(nchn,3-isde)=21    
        isig(nchn,3)=281    
        sigh(nchn)=facqg1   
        nchn=nchn+1 
        isig(nchn,isde)=i   
        isig(nchn,3-isde)=21    
        isig(nchn,3)=282    
        sigh(nchn)=facqg2   
  670   CONTINUE    
  680   CONTINUE    
    
C...g + g -> q + qb or g + g.   
        facqq1=comfac*as**2*1./6.*(uh/th-(2.+mstp(34)*1./4.)*uh2/sh2)*  
     &  (wdte(0,1)+wdte(0,2)+wdte(0,3)+wdte(0,4))*faca  
        facqq2=comfac*as**2*1./6.*(th/uh-(2.+mstp(34)*1./4.)*th2/sh2)*  
     &  (wdte(0,1)+wdte(0,2)+wdte(0,3)+wdte(0,4))*faca  
        facgg1=comfac*as**2*9./4.*(sh2/th2+2.*sh/th+3.+2.*th/sh+    
     &  th2/sh2)*faca   
        facgg2=comfac*as**2*9./4.*(uh2/sh2+2.*uh/sh+3.+2.*sh/uh+    
     &  sh2/uh2)*faca   
        facgg3=comfac*as**2*9./4.*(th2/uh2+2.*th/uh+3+2.*uh/th+uh2/th2) 
        nchn=nchn+1 
        isig(nchn,1)=21 
        isig(nchn,2)=21 
        isig(nchn,3)=531    
        sigh(nchn)=facqq1   
        nchn=nchn+1 
        isig(nchn,1)=21 
        isig(nchn,2)=21 
        isig(nchn,3)=532    
        sigh(nchn)=facqq2   
        nchn=nchn+1 
        isig(nchn,1)=21 
        isig(nchn,2)=21 
        isig(nchn,3)=681    
        sigh(nchn)=0.5*facgg1   
        nchn=nchn+1 
        isig(nchn,1)=21 
        isig(nchn,2)=21 
        isig(nchn,3)=682    
        sigh(nchn)=0.5*facgg2   
        nchn=nchn+1 
        isig(nchn,1)=21 
        isig(nchn,2)=21 
        isig(nchn,3)=683    
        sigh(nchn)=0.5*facgg3   
      ENDIF 
    
C...E: 2 -> 1, loop diagrams.   
    
      ELSEIF(isub.LE.110) THEN  
      IF(isub.EQ.101) THEN  
C...g + g -> gamma*/Z0. 
    
      ELSEIF(isub.EQ.102) THEN  
C...g + g -> H0.    
        CALL pywidt(25,sqrt(sh),wdtp,wdte)  
        etare=0.    
        etaim=0.    
        DO 690 i=1,2*mstp(1)    
        eps=4.*pmas(i,1)**2/sh  
        IF(eps.LE.1.) THEN  
          IF(eps.GT.1.e-4) THEN 
            root=sqrt(1.-eps)   
            rln=log((1.+root)/(1.-root))    
          ELSE  
            rln=log(4./eps-2.)  
          ENDIF 
          phire=0.25*(rln**2-paru(1)**2)    
          phiim=0.5*paru(1)*rln 
        ELSE    
          phire=-(asin(1./sqrt(eps)))**2    
          phiim=0.  
        ENDIF   
        etare=etare+0.5*eps*(1.+(eps-1.)*phire) 
        etaim=etaim+0.5*eps*(eps-1.)*phiim  
  690   CONTINUE    
        eta2=etare**2+etaim**2  
        fach=comfac*faca*(as/paru(1)*aem/xw)**2*1./512.*    
     &  (sh/sqmw)**2*eta2*sh2/((sh-sqmh)**2+gmmh**2)*   
     &  (wdte(0,1)+wdte(0,2)+wdte(0,4)) 
        IF(kfac(1,21)*kfac(2,21).EQ.0) goto 700 
        nchn=nchn+1 
        isig(nchn,1)=21 
        isig(nchn,2)=21 
        isig(nchn,3)=1  
        sigh(nchn)=fach 
  700   CONTINUE    
    
      ENDIF 
    
C...F: 2 -> 2, box diagrams.    
    
      ELSEIF(isub.LE.120) THEN  
      IF(isub.EQ.111) THEN  
C...f + fb -> g + H0 (q + qb -> g + H0 only).   
        a5stur=0.   
        a5stui=0.   
        DO 710 i=1,2*mstp(1)    
        sqmq=pmas(i,1)**2   
        epss=4.*sqmq/sh 
        epsh=4.*sqmq/sqmh   
        a5stur=a5stur+sqmq/sqmh*(4.+4.*sh/(th+uh)*(pyw1au(epss,1)-  
     &  pyw1au(epsh,1))+(1.-4.*sqmq/(th+uh))*(pyw2au(epss,1)-   
     &  pyw2au(epsh,1)))    
        a5stui=a5stui+sqmq/sqmh*(4.*sh/(th+uh)*(pyw1au(epss,2)- 
     &  pyw1au(epsh,2))+(1.-4.*sqmq/(th+uh))*(pyw2au(epss,2)-   
     &  pyw2au(epsh,2)))    
  710   CONTINUE    
        facgh=comfac*faca/(144.*paru(1)**2)*aem/xw*as**3*sqmh/sqmw* 
     &  sqmh/sh*(uh**2+th**2)/(uh+th)**2*(a5stur**2+a5stui**2)  
        facgh=facgh*wids(25,2)  
        DO 720 i=mina,maxa  
        IF(i.EQ.0.OR.kfac(1,i)*kfac(2,-i).EQ.0) goto 720    
        nchn=nchn+1 
        isig(nchn,1)=i  
        isig(nchn,2)=-i 
        isig(nchn,3)=1  
        sigh(nchn)=facgh    
  720   CONTINUE    
    
      ELSEIF(isub.EQ.112) THEN  
C...f + g -> f + H0 (q + g -> q + H0 only). 
        a5tsur=0.   
        a5tsui=0.   
        DO 730 i=1,2*mstp(1)    
        sqmq=pmas(i,1)**2   
        epst=4.*sqmq/th 
        epsh=4.*sqmq/sqmh   
        a5tsur=a5tsur+sqmq/sqmh*(4.+4.*th/(sh+uh)*(pyw1au(epst,1)-  
     &  pyw1au(epsh,1))+(1.-4.*sqmq/(sh+uh))*(pyw2au(epst,1)-   
     &  pyw2au(epsh,1)))    
        a5tsui=a5tsui+sqmq/sqmh*(4.*th/(sh+uh)*(pyw1au(epst,2)- 
     &  pyw1au(epsh,2))+(1.-4.*sqmq/(sh+uh))*(pyw2au(epst,2)-   
     &  pyw2au(epsh,2)))    
  730   CONTINUE    
        facqh=comfac*faca/(384.*paru(1)**2)*aem/xw*as**3*sqmh/sqmw* 
     &  sqmh/(-th)*(uh**2+sh**2)/(uh+sh)**2*(a5tsur**2+a5tsui**2)   
        facqh=facqh*wids(25,2)  
        DO 750 i=mina,maxa  
        IF(i.EQ.0) goto 750 
        DO 740 isde=1,2 
        IF(isde.EQ.1.AND.kfac(1,i)*kfac(2,21).EQ.0) goto 740    
        IF(isde.EQ.2.AND.kfac(1,21)*kfac(2,i).EQ.0) goto 740    
        nchn=nchn+1 
        isig(nchn,isde)=i   
        isig(nchn,3-isde)=21    
        isig(nchn,3)=1  
        sigh(nchn)=facqh    
  740   CONTINUE    
  750   CONTINUE    
    
      ELSEIF(isub.EQ.113) THEN  
C...g + g -> g + H0.    
        a2stur=0.   
        a2stui=0.   
        a2ustr=0.   
        a2usti=0.   
        a2tusr=0.   
        a2tusi=0.   
        a4stur=0.   
        a4stui=0.   
        DO 760 i=6,2*mstp(1)    
C'''Only t-quarks yet included  
        sqmq=pmas(i,1)**2   
        epss=4.*sqmq/sh 
        epst=4.*sqmq/th 
        epsu=4.*sqmq/uh 
        epsh=4.*sqmq/sqmh   
        IF(epsh.LT.1.e-6) goto 760  
        bestu=0.5*(1.+sqrt(1.+epss*th/uh))  
        beust=0.5*(1.+sqrt(1.+epsu*sh/th))  
        betus=0.5*(1.+sqrt(1.+epst*uh/sh))  
        beuts=bestu 
        betsu=beust 
        besut=betus 
        w3stur=pyi3au(bestu,epsh,1)-pyi3au(bestu,epss,1)-   
     &  pyi3au(bestu,epsu,1)    
        w3stui=pyi3au(bestu,epsh,2)-pyi3au(bestu,epss,2)-   
     &  pyi3au(bestu,epsu,2)    
        w3sutr=pyi3au(besut,epsh,1)-pyi3au(besut,epss,1)-   
     &  pyi3au(besut,epst,1)    
        w3suti=pyi3au(besut,epsh,2)-pyi3au(besut,epss,2)-   
     &  pyi3au(besut,epst,2)    
        w3tsur=pyi3au(betsu,epsh,1)-pyi3au(betsu,epst,1)-   
     &  pyi3au(betsu,epsu,1)    
        w3tsui=pyi3au(betsu,epsh,2)-pyi3au(betsu,epst,2)-   
     &  pyi3au(betsu,epsu,2)    
        w3tusr=pyi3au(betus,epsh,1)-pyi3au(betus,epst,1)-   
     &  pyi3au(betus,epss,1)    
        w3tusi=pyi3au(betus,epsh,2)-pyi3au(betus,epst,2)-   
     &  pyi3au(betus,epss,2)    
        w3ustr=pyi3au(beust,epsh,1)-pyi3au(beust,epsu,1)-   
     &  pyi3au(beust,epst,1)    
        w3usti=pyi3au(beust,epsh,2)-pyi3au(beust,epsu,2)-   
     &  pyi3au(beust,epst,2)    
        w3utsr=pyi3au(beuts,epsh,1)-pyi3au(beuts,epsu,1)-   
     &  pyi3au(beuts,epss,1)    
        w3utsi=pyi3au(beuts,epsh,2)-pyi3au(beuts,epsu,2)-   
     &  pyi3au(beuts,epss,2)    
        b2stur=sqmq/sqmh**2*(sh*(uh-sh)/(sh+uh)+2.*th*uh*(uh+2.*sh)/    
     &  (sh+uh)**2*(pyw1au(epst,1)-pyw1au(epsh,1))+(sqmq-sh/4.)*    
     &  (0.5*pyw2au(epss,1)+0.5*pyw2au(epsh,1)-pyw2au(epst,1)+w3stur)+  
     &  sh**2*(2.*sqmq/(sh+uh)**2-0.5/(sh+uh))*(pyw2au(epst,1)- 
     &  pyw2au(epsh,1))+0.5*th*uh/sh*(pyw2au(epsh,1)-2.*pyw2au(epst,1))+    
     &  0.125*(sh-12.*sqmq-4.*th*uh/sh)*w3tsur) 
        b2stui=sqmq/sqmh**2*(2.*th*uh*(uh+2.*sh)/(sh+uh)**2*    
     &  (pyw1au(epst,2)-pyw1au(epsh,2))+(sqmq-sh/4.)*   
     &  (0.5*pyw2au(epss,2)+0.5*pyw2au(epsh,2)-pyw2au(epst,2)+w3stui)+  
     &  sh**2*(2.*sqmq/(sh+uh)**2-0.5/(sh+uh))*(pyw2au(epst,2)- 
     &  pyw2au(epsh,2))+0.5*th*uh/sh*(pyw2au(epsh,2)-2.*pyw2au(epst,2))+    
     &  0.125*(sh-12.*sqmq-4.*th*uh/sh)*w3tsui) 
        b2sutr=sqmq/sqmh**2*(sh*(th-sh)/(sh+th)+2.*uh*th*(th+2.*sh)/    
     &  (sh+th)**2*(pyw1au(epsu,1)-pyw1au(epsh,1))+(sqmq-sh/4.)*    
     &  (0.5*pyw2au(epss,1)+0.5*pyw2au(epsh,1)-pyw2au(epsu,1)+w3sutr)+  
     &  sh**2*(2.*sqmq/(sh+th)**2-0.5/(sh+th))*(pyw2au(epsu,1)- 
     &  pyw2au(epsh,1))+0.5*uh*th/sh*(pyw2au(epsh,1)-2.*pyw2au(epsu,1))+    
     &  0.125*(sh-12.*sqmq-4.*uh*th/sh)*w3ustr) 
        b2suti=sqmq/sqmh**2*(2.*uh*th*(th+2.*sh)/(sh+th)**2*    
     &  (pyw1au(epsu,2)-pyw1au(epsh,2))+(sqmq-sh/4.)*   
     &  (0.5*pyw2au(epss,2)+0.5*pyw2au(epsh,2)-pyw2au(epsu,2)+w3suti)+  
     &  sh**2*(2.*sqmq/(sh+th)**2-0.5/(sh+th))*(pyw2au(epsu,2)- 
     &  pyw2au(epsh,2))+0.5*uh*th/sh*(pyw2au(epsh,2)-2.*pyw2au(epsu,2))+    
     &  0.125*(sh-12.*sqmq-4.*uh*th/sh)*w3usti) 
        b2tsur=sqmq/sqmh**2*(th*(uh-th)/(th+uh)+2.*sh*uh*(uh+2.*th)/    
     &  (th+uh)**2*(pyw1au(epss,1)-pyw1au(epsh,1))+(sqmq-th/4.)*    
     &  (0.5*pyw2au(epst,1)+0.5*pyw2au(epsh,1)-pyw2au(epss,1)+w3tsur)+  
     &  th**2*(2.*sqmq/(th+uh)**2-0.5/(th+uh))*(pyw2au(epss,1)- 
     &  pyw2au(epsh,1))+0.5*sh*uh/th*(pyw2au(epsh,1)-2.*pyw2au(epss,1))+    
     &  0.125*(th-12.*sqmq-4.*sh*uh/th)*w3stur) 
        b2tsui=sqmq/sqmh**2*(2.*sh*uh*(uh+2.*th)/(th+uh)**2*    
     &  (pyw1au(epss,2)-pyw1au(epsh,2))+(sqmq-th/4.)*   
     &  (0.5*pyw2au(epst,2)+0.5*pyw2au(epsh,2)-pyw2au(epss,2)+w3tsui)+  
     &  th**2*(2.*sqmq/(th+uh)**2-0.5/(th+uh))*(pyw2au(epss,2)- 
     &  pyw2au(epsh,2))+0.5*sh*uh/th*(pyw2au(epsh,2)-2.*pyw2au(epss,2))+    
     &  0.125*(th-12.*sqmq-4.*sh*uh/th)*w3stui) 
        b2tusr=sqmq/sqmh**2*(th*(sh-th)/(th+sh)+2.*uh*sh*(sh+2.*th)/    
     &  (th+sh)**2*(pyw1au(epsu,1)-pyw1au(epsh,1))+(sqmq-th/4.)*    
     &  (0.5*pyw2au(epst,1)+0.5*pyw2au(epsh,1)-pyw2au(epsu,1)+w3tusr)+  
     &  th**2*(2.*sqmq/(th+sh)**2-0.5/(th+sh))*(pyw2au(epsu,1)- 
     &  pyw2au(epsh,1))+0.5*uh*sh/th*(pyw2au(epsh,1)-2.*pyw2au(epsu,1))+    
     &  0.125*(th-12.*sqmq-4.*uh*sh/th)*w3utsr) 
        b2tusi=sqmq/sqmh**2*(2.*uh*sh*(sh+2.*th)/(th+sh)**2*    
     &  (pyw1au(epsu,2)-pyw1au(epsh,2))+(sqmq-th/4.)*   
     &  (0.5*pyw2au(epst,2)+0.5*pyw2au(epsh,2)-pyw2au(epsu,2)+w3tusi)+  
     &  th**2*(2.*sqmq/(th+sh)**2-0.5/(th+sh))*(pyw2au(epsu,2)- 
     &  pyw2au(epsh,2))+0.5*uh*sh/th*(pyw2au(epsh,2)-2.*pyw2au(epsu,2))+    
     &  0.125*(th-12.*sqmq-4.*uh*sh/th)*w3utsi) 
        b2ustr=sqmq/sqmh**2*(uh*(th-uh)/(uh+th)+2.*sh*th*(th+2.*uh)/    
     &  (uh+th)**2*(pyw1au(epss,1)-pyw1au(epsh,1))+(sqmq-uh/4.)*    
     &  (0.5*pyw2au(epsu,1)+0.5*pyw2au(epsh,1)-pyw2au(epss,1)+w3ustr)+  
     &  uh**2*(2.*sqmq/(uh+th)**2-0.5/(uh+th))*(pyw2au(epss,1)- 
     &  pyw2au(epsh,1))+0.5*sh*th/uh*(pyw2au(epsh,1)-2.*pyw2au(epss,1))+    
     &  0.125*(uh-12.*sqmq-4.*sh*th/uh)*w3sutr) 
        b2usti=sqmq/sqmh**2*(2.*sh*th*(th+2.*uh)/(uh+th)**2*    
     &  (pyw1au(epss,2)-pyw1au(epsh,2))+(sqmq-uh/4.)*   
     &  (0.5*pyw2au(epsu,2)+0.5*pyw2au(epsh,2)-pyw2au(epss,2)+w3usti)+  
     &  uh**2*(2.*sqmq/(uh+th)**2-0.5/(uh+th))*(pyw2au(epss,2)- 
     &  pyw2au(epsh,2))+0.5*sh*th/uh*(pyw2au(epsh,2)-2.*pyw2au(epss,2))+    
     &  0.125*(uh-12.*sqmq-4.*sh*th/uh)*w3suti) 
        b2utsr=sqmq/sqmh**2*(uh*(sh-uh)/(uh+sh)+2.*th*sh*(sh+2.*uh)/    
     &  (uh+sh)**2*(pyw1au(epst,1)-pyw1au(epsh,1))+(sqmq-uh/4.)*    
     &  (0.5*pyw2au(epsu,1)+0.5*pyw2au(epsh,1)-pyw2au(epst,1)+w3utsr)+  
     &  uh**2*(2.*sqmq/(uh+sh)**2-0.5/(uh+sh))*(pyw2au(epst,1)- 
     &  pyw2au(epsh,1))+0.5*th*sh/uh*(pyw2au(epsh,1)-2.*pyw2au(epst,1))+    
     &  0.125*(uh-12.*sqmq-4.*th*sh/uh)*w3tusr) 
        b2utsi=sqmq/sqmh**2*(2.*th*sh*(sh+2.*uh)/(uh+sh)**2*    
     &  (pyw1au(epst,2)-pyw1au(epsh,2))+(sqmq-uh/4.)*   
     &  (0.5*pyw2au(epsu,2)+0.5*pyw2au(epsh,2)-pyw2au(epst,2)+w3utsi)+  
     &  uh**2*(2.*sqmq/(uh+sh)**2-0.5/(uh+sh))*(pyw2au(epst,2)- 
     &  pyw2au(epsh,2))+0.5*th*sh/uh*(pyw2au(epsh,2)-2.*pyw2au(epst,2))+    
     &  0.125*(uh-12.*sqmq-4.*th*sh/uh)*w3tusi) 
        b4stur=sqmq/sqmh*(-2./3.+(sqmq/sqmh-1./4.)*(pyw2au(epss,1)- 
     &  pyw2au(epsh,1)+w3stur)) 
        b4stui=sqmq/sqmh*(sqmq/sqmh-1./4.)*(pyw2au(epss,2)- 
     &  pyw2au(epsh,2)+w3stui)  
        b4tusr=sqmq/sqmh*(-2./3.+(sqmq/sqmh-1./4.)*(pyw2au(epst,1)- 
     &  pyw2au(epsh,1)+w3tusr)) 
        b4tusi=sqmq/sqmh*(sqmq/sqmh-1./4.)*(pyw2au(epst,2)- 
     &  pyw2au(epsh,2)+w3tusi)  
        b4ustr=sqmq/sqmh*(-2./3.+(sqmq/sqmh-1./4.)*(pyw2au(epsu,1)- 
     &  pyw2au(epsh,1)+w3ustr)) 
        b4usti=sqmq/sqmh*(sqmq/sqmh-1./4.)*(pyw2au(epsu,2)- 
     &  pyw2au(epsh,2)+w3usti)  
        a2stur=a2stur+b2stur+b2sutr 
        a2stui=a2stui+b2stui+b2suti 
        a2ustr=a2ustr+b2ustr+b2utsr 
        a2usti=a2usti+b2usti+b2utsi 
        a2tusr=a2tusr+b2tusr+b2tsur 
        a2tusi=a2tusi+b2tusi+b2tsui 
        a4stur=a4stur+b4stur+b4ustr+b4tusr  
        a4stui=a4stui+b4stui+b4usti+b4tusi  
  760   CONTINUE    
        facgh=comfac*faca*3./(128.*paru(1)**2)*aem/xw*as**3*    
     &  sqmh/sqmw*sqmh**3/(sh*th*uh)*(a2stur**2+a2stui**2+a2ustr**2+    
     &  a2usti**2+a2tusr**2+a2tusi**2+a4stur**2+a4stui**2)  
        facgh=facgh*wids(25,2)  
        IF(kfac(1,21)*kfac(2,21).EQ.0) goto 770 
        nchn=nchn+1 
        isig(nchn,1)=21 
        isig(nchn,2)=21 
        isig(nchn,3)=1  
        sigh(nchn)=facgh    
  770   CONTINUE    
    
      ELSEIF(isub.EQ.114) THEN  
C...g + g -> gamma + gamma. 
        asre=0. 
        asim=0. 
        DO 780 i=1,2*mstp(1)    
        ei=kchg(iabs(i),1)/3.   
        sqmq=pmas(i,1)**2   
        epss=4.*sqmq/sh 
        epst=4.*sqmq/th 
        epsu=4.*sqmq/uh 
        IF(epss+abs(epst)+abs(epsu).LT.3.e-6) THEN  
          a0stur=1.+(th-uh)/sh*log(th/uh)+0.5*(th2+uh2)/sh2*    
     &    (log(th/uh)**2+paru(1)**2)    
          a0stui=0. 
          a0tsur=1.+(sh-uh)/th*log(-sh/uh)+0.5*(sh2+uh2)/th2*   
     &    log(-sh/uh)**2    
          a0tsui=-paru(1)*((sh-uh)/th+(sh2+uh2)/th2*log(-sh/uh))    
          a0utsr=1.+(th-sh)/uh*log(-th/sh)+0.5*(th2+sh2)/uh2*   
     &    log(-th/sh)**2    
          a0utsi=paru(1)*((th-sh)/uh+(th2+sh2)/uh2*log(-th/sh)) 
          a1stur=-1.    
          a1stui=0. 
          a2stur=-1.    
          a2stui=0. 
        ELSE    
          bestu=0.5*(1.+sqrt(1.+epss*th/uh))    
          beust=0.5*(1.+sqrt(1.+epsu*sh/th))    
          betus=0.5*(1.+sqrt(1.+epst*uh/sh))    
          beuts=bestu   
          betsu=beust   
          besut=betus   
          a0stur=1.+(1.+2.*th/sh)*pyw1au(epst,1)+(1.+2.*uh/sh)* 
     &    pyw1au(epsu,1)+0.5*((th2+uh2)/sh2-epss)*(pyw2au(epst,1)+  
     &    pyw2au(epsu,1))-0.25*epst*(1.-0.5*epss)*(pyi3au(besut,epss,1)+    
     &    pyi3au(besut,epst,1))-0.25*epsu*(1.-0.5*epss)*    
     &    (pyi3au(bestu,epss,1)+pyi3au(bestu,epsu,1))+  
     &    0.25*(-2.*(th2+uh2)/sh2+4.*epss+epst+epsu+0.5*epst*epsu)* 
     &    (pyi3au(betsu,epst,1)+pyi3au(betsu,epsu,1))   
          a0stui=(1.+2.*th/sh)*pyw1au(epst,2)+(1.+2.*uh/sh)*    
     &    pyw1au(epsu,2)+0.5*((th2+uh2)/sh2-epss)*(pyw2au(epst,2)+  
     &    pyw2au(epsu,2))-0.25*epst*(1.-0.5*epss)*(pyi3au(besut,epss,2)+    
     &    pyi3au(besut,epst,2))-0.25*epsu*(1.-0.5*epss)*    
     &    (pyi3au(bestu,epss,2)+pyi3au(bestu,epsu,2))+  
     &    0.25*(-2.*(th2+uh2)/sh2+4.*epss+epst+epsu+0.5*epst*epsu)* 
     &    (pyi3au(betsu,epst,2)+pyi3au(betsu,epsu,2))   
          a0tsur=1.+(1.+2.*sh/th)*pyw1au(epss,1)+(1.+2.*uh/th)* 
     &    pyw1au(epsu,1)+0.5*((sh2+uh2)/th2-epst)*(pyw2au(epss,1)+  
     &    pyw2au(epsu,1))-0.25*epss*(1.-0.5*epst)*(pyi3au(betus,epst,1)+    
     &    pyi3au(betus,epss,1))-0.25*epsu*(1.-0.5*epst)*    
     &    (pyi3au(betsu,epst,1)+pyi3au(betsu,epsu,1))+  
     &    0.25*(-2.*(sh2+uh2)/th2+4.*epst+epss+epsu+0.5*epss*epsu)* 
     &    (pyi3au(bestu,epss,1)+pyi3au(bestu,epsu,1))   
          a0tsui=(1.+2.*sh/th)*pyw1au(epss,2)+(1.+2.*uh/th)*    
     &    pyw1au(epsu,2)+0.5*((sh2+uh2)/th2-epst)*(pyw2au(epss,2)+  
     &    pyw2au(epsu,2))-0.25*epss*(1.-0.5*epst)*(pyi3au(betus,epst,2)+    
     &    pyi3au(betus,epss,2))-0.25*epsu*(1.-0.5*epst)*    
     &    (pyi3au(betsu,epst,2)+pyi3au(betsu,epsu,2))+  
     &    0.25*(-2.*(sh2+uh2)/th2+4.*epst+epss+epsu+0.5*epss*epsu)* 
     &    (pyi3au(bestu,epss,2)+pyi3au(bestu,epsu,2))   
          a0utsr=1.+(1.+2.*th/uh)*pyw1au(epst,1)+(1.+2.*sh/uh)* 
     &    pyw1au(epss,1)+0.5*((th2+sh2)/uh2-epsu)*(pyw2au(epst,1)+  
     &    pyw2au(epss,1))-0.25*epst*(1.-0.5*epsu)*(pyi3au(beust,epsu,1)+    
     &    pyi3au(beust,epst,1))-0.25*epss*(1.-0.5*epsu)*    
     &    (pyi3au(beuts,epsu,1)+pyi3au(beuts,epss,1))+  
     &    0.25*(-2.*(th2+sh2)/uh2+4.*epsu+epst+epss+0.5*epst*epss)* 
     &    (pyi3au(betus,epst,1)+pyi3au(betus,epss,1))   
          a0utsi=(1.+2.*th/uh)*pyw1au(epst,2)+(1.+2.*sh/uh)*    
     &    pyw1au(epss,2)+0.5*((th2+sh2)/uh2-epsu)*(pyw2au(epst,2)+  
     &    pyw2au(epss,2))-0.25*epst*(1.-0.5*epsu)*(pyi3au(beust,epsu,2)+    
     &    pyi3au(beust,epst,2))-0.25*epss*(1.-0.5*epsu)*    
     &    (pyi3au(beuts,epsu,2)+pyi3au(beuts,epss,2))+  
     &    0.25*(-2.*(th2+sh2)/uh2+4.*epsu+epst+epss+0.5*epst*epss)* 
     &    (pyi3au(betus,epst,2)+pyi3au(betus,epss,2))   
          a1stur=-1.-0.25*(epss+epst+epsu)*(pyw2au(epss,1)+ 
     &    pyw2au(epst,1)+pyw2au(epsu,1))+0.25*(epsu+0.5*epss*epst)* 
     &    (pyi3au(besut,epss,1)+pyi3au(besut,epst,1))+  
     &    0.25*(epst+0.5*epss*epsu)*(pyi3au(bestu,epss,1)+  
     &    pyi3au(bestu,epsu,1))+0.25*(epss+0.5*epst*epsu)*  
     &    (pyi3au(betsu,epst,1)+pyi3au(betsu,epsu,1))   
          a1stui=-0.25*(epss+epst+epsu)*(pyw2au(epss,2)+pyw2au(epst,2)+ 
     &    pyw2au(epsu,2))+0.25*(epsu+0.5*epss*epst)*    
     &    (pyi3au(besut,epss,2)+pyi3au(besut,epst,2))+  
     &    0.25*(epst+0.5*epss*epsu)*(pyi3au(bestu,epss,2)+  
     &    pyi3au(bestu,epsu,2))+0.25*(epss+0.5*epst*epsu)*  
     &    (pyi3au(betsu,epst,2)+pyi3au(betsu,epsu,2))   
          a2stur=-1.+0.125*epss*epst*(pyi3au(besut,epss,1)+ 
     &    pyi3au(besut,epst,1))+0.125*epss*epsu*(pyi3au(bestu,epss,1)+  
     &    pyi3au(bestu,epsu,1))+0.125*epst*epsu*(pyi3au(betsu,epst,1)+  
     &    pyi3au(betsu,epsu,1)) 
          a2stui=0.125*epss*epst*(pyi3au(besut,epss,2)+ 
     &    pyi3au(besut,epst,2))+0.125*epss*epsu*(pyi3au(bestu,epss,2)+  
     &    pyi3au(bestu,epsu,2))+0.125*epst*epsu*(pyi3au(betsu,epst,2)+  
     &    pyi3au(betsu,epsu,2)) 
        ENDIF   
        asre=asre+ei**2*(a0stur+a0tsur+a0utsr+4.*a1stur+a2stur) 
        asim=asim+ei**2*(a0stui+a0tsui+a0utsi+4.*a1stui+a2stui) 
  780   CONTINUE    
        facgg=comfac*faca/(8.*paru(1)**2)*as**2*aem**2*(asre**2+asim**2)    
        IF(kfac(1,21)*kfac(2,21).EQ.0) goto 790 
        nchn=nchn+1 
        isig(nchn,1)=21 
        isig(nchn,2)=21 
        isig(nchn,3)=1  
        sigh(nchn)=facgg    
  790   CONTINUE    
    
      ELSEIF(isub.EQ.115) THEN  
C...g + g -> gamma + Z0.    
    
      ELSEIF(isub.EQ.116) THEN  
C...g + g -> Z0 + Z0.   
    
      ELSEIF(isub.EQ.117) THEN  
C...g + g -> W+ + W-.   
    
      ENDIF 
    
C...G: 2 -> 3, tree diagrams.   
    
      ELSEIF(isub.LE.140) THEN  
      IF(isub.EQ.121) THEN  
C...g + g -> f + fb + H0.   
    
      ENDIF 
    
C...H: 2 -> 1, tree diagrams, non-standard model processes. 
    
      ELSEIF(isub.LE.160) THEN  
      IF(isub.EQ.141) THEN  
C...f + fb -> gamma*/Z0/Z'0.    
        mint(61)=2  
        CALL pywidt(32,sqrt(sh),wdtp,wdte)  
        faczp=comfac*aem**2*4./9.   
        DO 800 i=mina,maxa  
        IF(i.EQ.0.OR.kfac(1,i)*kfac(2,-i).EQ.0) goto 800    
        ei=kchg(iabs(i),1)/3.   
        ai=sign(1.,ei)  
        vi=ai-4.*ei*xw  
        api=sign(1.,ei) 
        vpi=api-4.*ei*xw    
        nchn=nchn+1 
        isig(nchn,1)=i  
        isig(nchn,2)=-i 
        isig(nchn,3)=1  
        sigh(nchn)=faczp*(ei**2*vint(111)+ei*vi/(8.*xw*(1.-xw))*    
     &  sh*(sh-sqmz)/((sh-sqmz)**2+gmmz**2)*vint(112)+ei*vpi/(8.*xw*    
     &  (1.-xw))*sh*(sh-sqmzp)/((sh-sqmzp)**2+gmmzp**2)*vint(113)+  
     &  (vi**2+ai**2)/(16.*xw*(1.-xw))**2*sh2/((sh-sqmz)**2+gmmz**2)*   
     &  vint(114)+2.*(vi*vpi+ai*api)/(16.*xw*(1.-xw))**2*sh2*   
     &  ((sh-sqmz)*(sh-sqmzp)+gmmz*gmmzp)/(((sh-sqmz)**2+gmmz**2)*  
     &  ((sh-sqmzp)**2+gmmzp**2))*vint(115)+(vpi**2+api**2)/    
     &  (16.*xw*(1.-xw))**2*sh2/((sh-sqmzp)**2+gmmzp**2)*vint(116)) 
  800   CONTINUE    
    
      ELSEIF(isub.EQ.142) THEN  
C...f + fb' -> H+/-.    
        CALL pywidt(37,sqrt(sh),wdtp,wdte)  
        fhc=comfac*(aem/xw)**2*1./48.*(sh/sqmw)**2*sh2/ 
     &  ((sh-sqmhc)**2+gmmhc**2)    
C'''No construction yet for leptons 
        DO 840 i=1,mstp(54)/2   
        il=2*i-1    
        iu=2*i  
        rmql=pmas(il,1)**2/sh   
        rmqu=pmas(iu,1)**2/sh   
        fachc=fhc*((rmql*paru(121)+rmqu/paru(121))*(1.-rmql-rmqu)-  
     &  4.*rmql*rmqu)/sqrt(max(0.,(1.-rmql-rmqu)**2-4.*rmql*rmqu))  
        IF(kfac(1,il)*kfac(2,-iu).EQ.0) goto 810    
        kchhc=(kchg(il,1)-kchg(iu,1))/3 
        nchn=nchn+1 
        isig(nchn,1)=il 
        isig(nchn,2)=-iu    
        isig(nchn,3)=1  
        sigh(nchn)=fachc*(wdte(0,1)+wdte(0,(5-kchhc)/2)+wdte(0,4))  
  810   IF(kfac(1,-il)*kfac(2,iu).EQ.0) goto 820    
        kchhc=(-kchg(il,1)+kchg(iu,1))/3    
        nchn=nchn+1 
        isig(nchn,1)=-il    
        isig(nchn,2)=iu 
        isig(nchn,3)=1  
        sigh(nchn)=fachc*(wdte(0,1)+wdte(0,(5-kchhc)/2)+wdte(0,4))  
  820   IF(kfac(1,iu)*kfac(2,-il).EQ.0) goto 830    
        kchhc=(kchg(iu,1)-kchg(il,1))/3 
        nchn=nchn+1 
        isig(nchn,1)=iu 
        isig(nchn,2)=-il    
        isig(nchn,3)=1  
        sigh(nchn)=fachc*(wdte(0,1)+wdte(0,(5-kchhc)/2)+wdte(0,4))  
  830   IF(kfac(1,-iu)*kfac(2,il).EQ.0) goto 840    
        kchhc=(-kchg(iu,1)+kchg(il,1))/3    
        nchn=nchn+1 
        isig(nchn,1)=-iu    
        isig(nchn,2)=il 
        isig(nchn,3)=1  
        sigh(nchn)=fachc*(wdte(0,1)+wdte(0,(5-kchhc)/2)+wdte(0,4))  
  840   CONTINUE    
    
      ELSEIF(isub.EQ.143) THEN  
C...f + fb -> R.    
        CALL pywidt(40,sqrt(sh),wdtp,wdte)  
        facr=comfac*(aem/xw)**2*1./9.*sh2/((sh-sqmr)**2+gmmr**2)    
        DO 860 i=min1,max1  
        IF(i.EQ.0.OR.kfac(1,i).EQ.0) goto 860   
        ia=iabs(i)  
        DO 850 j=min2,max2  
        IF(j.EQ.0.OR.kfac(2,j).EQ.0) goto 850   
        ja=iabs(j)  
        IF(i*j.GT.0.OR.iabs(ia-ja).NE.2) goto 850   
        nchn=nchn+1 
        isig(nchn,1)=i  
        isig(nchn,2)=j  
        isig(nchn,3)=1  
        sigh(nchn)=facr*(wdte(0,1)+wdte(0,(10-(i+j))/4)+wdte(0,4))  
  850   CONTINUE    
  860   CONTINUE    
    
      ENDIF 
    
C...I: 2 -> 2, tree diagrams, non-standard model processes. 
    
      ELSE  
      IF(isub.EQ.161) THEN  
C...f + g -> f' + H+/- (q + g -> q' + H+/- only).   
        fhcq=comfac*faca*as*aem/xw*1./24    
        DO 900 i=1,mstp(54) 
        iu=i+mod(i,2)   
        sqmq=pmas(iu,1)**2  
        fachcq=fhcq/paru(121)*sqmq/sqmw*(sh/(sqmq-uh)+  
     &  2.*sqmq*(sqmhc-uh)/(sqmq-uh)**2+(sqmq-uh)/sh+   
     &  2.*sqmq/(sqmq-uh)+2.*(sqmhc-uh)/(sqmq-uh)*(sqmhc-sqmq-sh)/sh)   
        IF(kfac(1,-i)*kfac(2,21).EQ.0) goto 870 
        kchhc=isign(1,-kchg(i,1))   
        nchn=nchn+1 
        isig(nchn,1)=-i 
        isig(nchn,2)=21 
        isig(nchn,3)=1  
        sigh(nchn)=fachcq*(wdte(0,1)+wdte(0,(5-kchhc)/2)+wdte(0,4)) 
  870   IF(kfac(1,i)*kfac(2,21).EQ.0) goto 880  
        kchhc=isign(1,kchg(i,1))    
        nchn=nchn+1 
        isig(nchn,1)=i  
        isig(nchn,2)=21 
        isig(nchn,3)=1  
        sigh(nchn)=fachcq*(wdte(0,1)+wdte(0,(5-kchhc)/2)+wdte(0,4)) 
  880   IF(kfac(1,21)*kfac(2,-i).EQ.0) goto 890 
        kchhc=isign(1,-kchg(i,1))   
        nchn=nchn+1 
        isig(nchn,1)=21 
        isig(nchn,2)=-i 
        isig(nchn,3)=1  
        sigh(nchn)=fachcq*(wdte(0,1)+wdte(0,(5-kchhc)/2)+wdte(0,4)) 
  890   IF(kfac(1,21)*kfac(2,i).EQ.0) goto 900  
        kchhc=isign(1,kchg(i,1))    
        nchn=nchn+1 
        isig(nchn,1)=21 
        isig(nchn,2)=i  
        isig(nchn,3)=1  
        sigh(nchn)=fachcq*(wdte(0,1)+wdte(0,(5-kchhc)/2)+wdte(0,4)) 
  900   CONTINUE    
    
      ENDIF 
      ENDIF 
    
C...Multiply with structure functions.  
      IF(isub.LE.90.OR.isub.GE.96) THEN 
        DO 910 ichn=1,nchn  
        IF(mint(41).EQ.2) THEN  
          kfl1=isig(ichn,1) 
          IF(kfl1.EQ.21) kfl1=0 
          sigh(ichn)=sigh(ichn)*xsfx(1,kfl1)    
        ENDIF   
        IF(mint(42).EQ.2) THEN  
          kfl2=isig(ichn,2) 
          IF(kfl2.EQ.21) kfl2=0 
          sigh(ichn)=sigh(ichn)*xsfx(2,kfl2)    
        ENDIF   
  910   sigs=sigs+sigh(ichn)    
      ENDIF 
    
      RETURN    
      END   
    
C*********************************************************************  
    
      SUBROUTINE pystfu(KF,X,Q2,XPQ,JBT)    
    
C     *******JBT specifies beam or target of the particle
C...Gives proton and pi+ parton structure functions according to a few  
C...different parametrizations. Note that what is coded is x times the  
C...probability distribution, i.e. xq(x,Q2) etc.    
      common/hiparnt/hipr1(100),ihpr2(50),hint1(100),ihnt2(50)
      SAVE  /hiparnt/
      common/hijcrdn/yp(3,300),yt(3,300)
      SAVE  /hijcrdn/
C     ********COMMON BLOCK FROM HIJING
      common/ludat1/mstu(200),paru(200),mstj(200),parj(200) 
      SAVE /ludat1/ 
      common/ludat2/kchg(500,3),pmas(500,4),parf(2000),vckm(4,4)    
      SAVE /ludat2/ 
      common/pypars/mstp(200),parp(200),msti(200),pari(200) 
      SAVE /pypars/ 
      common/pyint1/mint(400),vint(400) 
      SAVE /pyint1/ 
      dimension xpq(-6:6),xq(6),tx(6),tt(6),ts(6),nehlq(8,2),   
     &cehlq(6,6,2,8,2),cdo(3,6,5,2),cow(3,5,4,2)    
    
C...The following data lines are coefficients needed in the 
C...Eichten, Hinchliffe, Lane, Quigg proton structure function  
C...parametrizations, see below.    
C...Powers of 1-x in different cases.   
      DATA nehlq/3,4,7,5,7,7,7,7,3,4,7,6,7,7,7,7/   
C...Expansion coefficients for up valence quark distribution.   
      DATA (((cehlq(ix,it,nx,1,1),ix=1,6),it=1,6),nx=1,2)/  
     1 7.677e-01,-2.087e-01,-3.303e-01,-2.517e-02,-1.570e-02,-1.000e-04,    
     2-5.326e-01,-2.661e-01, 3.201e-01, 1.192e-01, 2.434e-02, 7.620e-03,    
     3 2.162e-01, 1.881e-01,-8.375e-02,-6.515e-02,-1.743e-02,-5.040e-03,    
     4-9.211e-02,-9.952e-02, 1.373e-02, 2.506e-02, 8.770e-03, 2.550e-03,    
     5 3.670e-02, 4.409e-02, 9.600e-04,-7.960e-03,-3.420e-03,-1.050e-03,    
     6-1.549e-02,-2.026e-02,-3.060e-03, 2.220e-03, 1.240e-03, 4.100e-04,    
     1 2.395e-01, 2.905e-01, 9.778e-02, 2.149e-02, 3.440e-03, 5.000e-04,    
     2 1.751e-02,-6.090e-03,-2.687e-02,-1.916e-02,-7.970e-03,-2.750e-03,    
     3-5.760e-03,-5.040e-03, 1.080e-03, 2.490e-03, 1.530e-03, 7.500e-04,    
     4 1.740e-03, 1.960e-03, 3.000e-04,-3.400e-04,-2.900e-04,-1.800e-04,    
     5-5.300e-04,-6.400e-04,-1.700e-04, 4.000e-05, 6.000e-05, 4.000e-05,    
     6 1.700e-04, 2.200e-04, 8.000e-05, 1.000e-05,-1.000e-05,-1.000e-05/    
      DATA (((cehlq(ix,it,nx,1,2),ix=1,6),it=1,6),nx=1,2)/  
     1 7.237e-01,-2.189e-01,-2.995e-01,-1.909e-02,-1.477e-02, 2.500e-04,    
     2-5.314e-01,-2.425e-01, 3.283e-01, 1.119e-01, 2.223e-02, 7.070e-03,    
     3 2.289e-01, 1.890e-01,-9.859e-02,-6.900e-02,-1.747e-02,-5.080e-03,    
     4-1.041e-01,-1.084e-01, 2.108e-02, 2.975e-02, 9.830e-03, 2.830e-03,    
     5 4.394e-02, 5.116e-02,-1.410e-03,-1.055e-02,-4.230e-03,-1.270e-03,    
     6-1.991e-02,-2.539e-02,-2.780e-03, 3.430e-03, 1.720e-03, 5.500e-04,    
     1 2.410e-01, 2.884e-01, 9.369e-02, 1.900e-02, 2.530e-03, 2.400e-04,    
     2 1.765e-02,-9.220e-03,-3.037e-02,-2.085e-02,-8.440e-03,-2.810e-03,    
     3-6.450e-03,-5.260e-03, 1.720e-03, 3.110e-03, 1.830e-03, 8.700e-04,    
     4 2.120e-03, 2.320e-03, 2.600e-04,-4.900e-04,-3.900e-04,-2.300e-04,    
     5-6.900e-04,-8.200e-04,-2.000e-04, 7.000e-05, 9.000e-05, 6.000e-05,    
     6 2.400e-04, 3.100e-04, 1.100e-04, 0.000e+00,-2.000e-05,-2.000e-05/    
C...Expansion coefficients for down valence quark distribution. 
      DATA (((cehlq(ix,it,nx,2,1),ix=1,6),it=1,6),nx=1,2)/  
     1 3.813e-01,-8.090e-02,-1.634e-01,-2.185e-02,-8.430e-03,-6.200e-04,    
     2-2.948e-01,-1.435e-01, 1.665e-01, 6.638e-02, 1.473e-02, 4.080e-03,    
     3 1.252e-01, 1.042e-01,-4.722e-02,-3.683e-02,-1.038e-02,-2.860e-03,    
     4-5.478e-02,-5.678e-02, 8.900e-03, 1.484e-02, 5.340e-03, 1.520e-03,    
     5 2.220e-02, 2.567e-02,-3.000e-05,-4.970e-03,-2.160e-03,-6.500e-04,    
     6-9.530e-03,-1.204e-02,-1.510e-03, 1.510e-03, 8.300e-04, 2.700e-04,    
     1 1.261e-01, 1.354e-01, 3.958e-02, 8.240e-03, 1.660e-03, 4.500e-04,    
     2 3.890e-03,-1.159e-02,-1.625e-02,-9.610e-03,-3.710e-03,-1.260e-03,    
     3-1.910e-03,-5.600e-04, 1.590e-03, 1.590e-03, 8.400e-04, 3.900e-04,    
     4 6.400e-04, 4.900e-04,-1.500e-04,-2.900e-04,-1.800e-04,-1.000e-04,    
     5-2.000e-04,-1.900e-04, 0.000e+00, 6.000e-05, 4.000e-05, 3.000e-05,    
     6 7.000e-05, 8.000e-05, 2.000e-05,-1.000e-05,-1.000e-05,-1.000e-05/    
      DATA (((cehlq(ix,it,nx,2,2),ix=1,6),it=1,6),nx=1,2)/  
     1 3.578e-01,-8.622e-02,-1.480e-01,-1.840e-02,-7.820e-03,-4.500e-04,    
     2-2.925e-01,-1.304e-01, 1.696e-01, 6.243e-02, 1.353e-02, 3.750e-03,    
     3 1.318e-01, 1.041e-01,-5.486e-02,-3.872e-02,-1.038e-02,-2.850e-03,    
     4-6.162e-02,-6.143e-02, 1.303e-02, 1.740e-02, 5.940e-03, 1.670e-03,    
     5 2.643e-02, 2.957e-02,-1.490e-03,-6.450e-03,-2.630e-03,-7.700e-04,    
     6-1.218e-02,-1.497e-02,-1.260e-03, 2.240e-03, 1.120e-03, 3.500e-04,    
     1 1.263e-01, 1.334e-01, 3.732e-02, 7.070e-03, 1.260e-03, 3.400e-04,    
     2 3.660e-03,-1.357e-02,-1.795e-02,-1.031e-02,-3.880e-03,-1.280e-03,    
     3-2.100e-03,-3.600e-04, 2.050e-03, 1.920e-03, 9.800e-04, 4.400e-04,    
     4 7.700e-04, 5.400e-04,-2.400e-04,-3.900e-04,-2.400e-04,-1.300e-04,    
     5-2.600e-04,-2.300e-04, 2.000e-05, 9.000e-05, 6.000e-05, 4.000e-05,    
     6 9.000e-05, 1.000e-04, 2.000e-05,-2.000e-05,-2.000e-05,-1.000e-05/    
C...Expansion coefficients for up and down sea quark distributions. 
      DATA (((cehlq(ix,it,nx,3,1),ix=1,6),it=1,6),nx=1,2)/  
     1 6.870e-02,-6.861e-02, 2.973e-02,-5.400e-03, 3.780e-03,-9.700e-04,    
     2-1.802e-02, 1.400e-04, 6.490e-03,-8.540e-03, 1.220e-03,-1.750e-03,    
     3-4.650e-03, 1.480e-03,-5.930e-03, 6.000e-04,-1.030e-03,-8.000e-05,    
     4 6.440e-03, 2.570e-03, 2.830e-03, 1.150e-03, 7.100e-04, 3.300e-04,    
     5-3.930e-03,-2.540e-03,-1.160e-03,-7.700e-04,-3.600e-04,-1.900e-04,    
     6 2.340e-03, 1.930e-03, 5.300e-04, 3.700e-04, 1.600e-04, 9.000e-05,    
     1 1.014e+00,-1.106e+00, 3.374e-01,-7.444e-02, 8.850e-03,-8.700e-04,    
     2 9.233e-01,-1.285e+00, 4.475e-01,-9.786e-02, 1.419e-02,-1.120e-03,    
     3 4.888e-02,-1.271e-01, 8.606e-02,-2.608e-02, 4.780e-03,-6.000e-04,    
     4-2.691e-02, 4.887e-02,-1.771e-02, 1.620e-03, 2.500e-04,-6.000e-05,    
     5 7.040e-03,-1.113e-02, 1.590e-03, 7.000e-04,-2.000e-04, 0.000e+00,    
     6-1.710e-03, 2.290e-03, 3.800e-04,-3.500e-04, 4.000e-05, 1.000e-05/    
      DATA (((cehlq(ix,it,nx,3,2),ix=1,6),it=1,6),nx=1,2)/  
     1 1.008e-01,-7.100e-02, 1.973e-02,-5.710e-03, 2.930e-03,-9.900e-04,    
     2-5.271e-02,-1.823e-02, 1.792e-02,-6.580e-03, 1.750e-03,-1.550e-03,    
     3 1.220e-02, 1.763e-02,-8.690e-03,-8.800e-04,-1.160e-03,-2.100e-04,    
     4-1.190e-03,-7.180e-03, 2.360e-03, 1.890e-03, 7.700e-04, 4.100e-04,    
     5-9.100e-04, 2.040e-03,-3.100e-04,-1.050e-03,-4.000e-04,-2.400e-04,    
     6 1.190e-03,-1.700e-04,-2.000e-04, 4.200e-04, 1.700e-04, 1.000e-04,    
     1 1.081e+00,-1.189e+00, 3.868e-01,-8.617e-02, 1.115e-02,-1.180e-03,    
     2 9.917e-01,-1.396e+00, 4.998e-01,-1.159e-01, 1.674e-02,-1.720e-03,    
     3 5.099e-02,-1.338e-01, 9.173e-02,-2.885e-02, 5.890e-03,-6.500e-04,    
     4-3.178e-02, 5.703e-02,-2.070e-02, 2.440e-03, 1.100e-04,-9.000e-05,    
     5 8.970e-03,-1.392e-02, 2.050e-03, 6.500e-04,-2.300e-04, 2.000e-05,    
     6-2.340e-03, 3.010e-03, 5.000e-04,-3.900e-04, 6.000e-05, 1.000e-05/    
C...Expansion coefficients for gluon distribution.  
      DATA (((cehlq(ix,it,nx,4,1),ix=1,6),it=1,6),nx=1,2)/  
     1 9.482e-01,-9.578e-01, 1.009e-01,-1.051e-01, 3.456e-02,-3.054e-02,    
     2-9.627e-01, 5.379e-01, 3.368e-01,-9.525e-02, 1.488e-02,-2.051e-02,    
     3 4.300e-01,-8.306e-02,-3.372e-01, 4.902e-02,-9.160e-03, 1.041e-02,    
     4-1.925e-01,-1.790e-02, 2.183e-01, 7.490e-03, 4.140e-03,-1.860e-03,    
     5 8.183e-02, 1.926e-02,-1.072e-01,-1.944e-02,-2.770e-03,-5.200e-04,    
     6-3.884e-02,-1.234e-02, 5.410e-02, 1.879e-02, 3.350e-03, 1.040e-03,    
     1 2.948e+01,-3.902e+01, 1.464e+01,-3.335e+00, 5.054e-01,-5.915e-02,    
     2 2.559e+01,-3.955e+01, 1.661e+01,-4.299e+00, 6.904e-01,-8.243e-02,    
     3-1.663e+00, 1.176e+00, 1.118e+00,-7.099e-01, 1.948e-01,-2.404e-02,    
     4-2.168e-01, 8.170e-01,-7.169e-01, 1.851e-01,-1.924e-02,-3.250e-03,    
     5 2.088e-01,-4.355e-01, 2.239e-01,-2.446e-02,-3.620e-03, 1.910e-03,    
     6-9.097e-02, 1.601e-01,-5.681e-02,-2.500e-03, 2.580e-03,-4.700e-04/    
      DATA (((cehlq(ix,it,nx,4,2),ix=1,6),it=1,6),nx=1,2)/  
     1 2.367e+00, 4.453e-01, 3.660e-01, 9.467e-02, 1.341e-01, 1.661e-02,    
     2-3.170e+00,-1.795e+00, 3.313e-02,-2.874e-01,-9.827e-02,-7.119e-02,    
     3 1.823e+00, 1.457e+00,-2.465e-01, 3.739e-02, 6.090e-03, 1.814e-02,    
     4-1.033e+00,-9.827e-01, 2.136e-01, 1.169e-01, 5.001e-02, 1.684e-02,    
     5 5.133e-01, 5.259e-01,-1.173e-01,-1.139e-01,-4.988e-02,-2.021e-02,    
     6-2.881e-01,-3.145e-01, 5.667e-02, 9.161e-02, 4.568e-02, 1.951e-02,    
     1 3.036e+01,-4.062e+01, 1.578e+01,-3.699e+00, 6.020e-01,-7.031e-02,    
     2 2.700e+01,-4.167e+01, 1.770e+01,-4.804e+00, 7.862e-01,-1.060e-01,    
     3-1.909e+00, 1.357e+00, 1.127e+00,-7.181e-01, 2.232e-01,-2.481e-02,    
     4-2.488e-01, 9.781e-01,-8.127e-01, 2.094e-01,-2.997e-02,-4.710e-03,    
     5 2.506e-01,-5.427e-01, 2.672e-01,-3.103e-02,-1.800e-03, 2.870e-03,    
     6-1.128e-01, 2.087e-01,-6.972e-02,-2.480e-03, 2.630e-03,-8.400e-04/    
C...Expansion coefficients for strange sea quark distribution.  
      DATA (((cehlq(ix,it,nx,5,1),ix=1,6),it=1,6),nx=1,2)/  
     1 4.968e-02,-4.173e-02, 2.102e-02,-3.270e-03, 3.240e-03,-6.700e-04,    
     2-6.150e-03,-1.294e-02, 6.740e-03,-6.890e-03, 9.000e-04,-1.510e-03,    
     3-8.580e-03, 5.050e-03,-4.900e-03,-1.600e-04,-9.400e-04,-1.500e-04,    
     4 7.840e-03, 1.510e-03, 2.220e-03, 1.400e-03, 7.000e-04, 3.500e-04,    
     5-4.410e-03,-2.220e-03,-8.900e-04,-8.500e-04,-3.600e-04,-2.000e-04,    
     6 2.520e-03, 1.840e-03, 4.100e-04, 3.900e-04, 1.600e-04, 9.000e-05,    
     1 9.235e-01,-1.085e+00, 3.464e-01,-7.210e-02, 9.140e-03,-9.100e-04,    
     2 9.315e-01,-1.274e+00, 4.512e-01,-9.775e-02, 1.380e-02,-1.310e-03,    
     3 4.739e-02,-1.296e-01, 8.482e-02,-2.642e-02, 4.760e-03,-5.700e-04,    
     4-2.653e-02, 4.953e-02,-1.735e-02, 1.750e-03, 2.800e-04,-6.000e-05,    
     5 6.940e-03,-1.132e-02, 1.480e-03, 6.500e-04,-2.100e-04, 0.000e+00,    
     6-1.680e-03, 2.340e-03, 4.200e-04,-3.400e-04, 5.000e-05, 1.000e-05/    
      DATA (((cehlq(ix,it,nx,5,2),ix=1,6),it=1,6),nx=1,2)/  
     1 6.478e-02,-4.537e-02, 1.643e-02,-3.490e-03, 2.710e-03,-6.700e-04,    
     2-2.223e-02,-2.126e-02, 1.247e-02,-6.290e-03, 1.120e-03,-1.440e-03,    
     3-1.340e-03, 1.362e-02,-6.130e-03,-7.900e-04,-9.000e-04,-2.000e-04,    
     4 5.080e-03,-3.610e-03, 1.700e-03, 1.830e-03, 6.800e-04, 4.000e-04,    
     5-3.580e-03, 6.000e-05,-2.600e-04,-1.050e-03,-3.800e-04,-2.300e-04,    
     6 2.420e-03, 9.300e-04,-1.000e-04, 4.500e-04, 1.700e-04, 1.100e-04,    
     1 9.868e-01,-1.171e+00, 3.940e-01,-8.459e-02, 1.124e-02,-1.250e-03,    
     2 1.001e+00,-1.383e+00, 5.044e-01,-1.152e-01, 1.658e-02,-1.830e-03,    
     3 4.928e-02,-1.368e-01, 9.021e-02,-2.935e-02, 5.800e-03,-6.600e-04,    
     4-3.133e-02, 5.785e-02,-2.023e-02, 2.630e-03, 1.600e-04,-8.000e-05,    
     5 8.840e-03,-1.416e-02, 1.900e-03, 5.800e-04,-2.500e-04, 1.000e-05,    
     6-2.300e-03, 3.080e-03, 5.500e-04,-3.700e-04, 7.000e-05, 1.000e-05/    
C...Expansion coefficients for charm sea quark distribution.    
      DATA (((cehlq(ix,it,nx,6,1),ix=1,6),it=1,6),nx=1,2)/  
     1 9.270e-03,-1.817e-02, 9.590e-03,-6.390e-03, 1.690e-03,-1.540e-03,    
     2 5.710e-03,-1.188e-02, 6.090e-03,-4.650e-03, 1.240e-03,-1.310e-03,    
     3-3.960e-03, 7.100e-03,-3.590e-03, 1.840e-03,-3.900e-04, 3.400e-04,    
     4 1.120e-03,-1.960e-03, 1.120e-03,-4.800e-04, 1.000e-04,-4.000e-05,    
     5 4.000e-05,-3.000e-05,-1.800e-04, 9.000e-05,-5.000e-05,-2.000e-05,    
     6-4.200e-04, 7.300e-04,-1.600e-04, 5.000e-05, 5.000e-05, 5.000e-05,    
     1 8.098e-01,-1.042e+00, 3.398e-01,-6.824e-02, 8.760e-03,-9.000e-04,    
     2 8.961e-01,-1.217e+00, 4.339e-01,-9.287e-02, 1.304e-02,-1.290e-03,    
     3 3.058e-02,-1.040e-01, 7.604e-02,-2.415e-02, 4.600e-03,-5.000e-04,    
     4-2.451e-02, 4.432e-02,-1.651e-02, 1.430e-03, 1.200e-04,-1.000e-04,    
     5 1.122e-02,-1.457e-02, 2.680e-03, 5.800e-04,-1.200e-04, 3.000e-05,    
     6-7.730e-03, 7.330e-03,-7.600e-04,-2.400e-04, 1.000e-05, 0.000e+00/    
      DATA (((cehlq(ix,it,nx,6,2),ix=1,6),it=1,6),nx=1,2)/  
     1 9.980e-03,-1.945e-02, 1.055e-02,-6.870e-03, 1.860e-03,-1.560e-03,    
     2 5.700e-03,-1.203e-02, 6.250e-03,-4.860e-03, 1.310e-03,-1.370e-03,    
     3-4.490e-03, 7.990e-03,-4.170e-03, 2.050e-03,-4.400e-04, 3.300e-04,    
     4 1.470e-03,-2.480e-03, 1.460e-03,-5.700e-04, 1.200e-04,-1.000e-05,    
     5-9.000e-05, 1.500e-04,-3.200e-04, 1.200e-04,-6.000e-05,-4.000e-05,    
     6-4.200e-04, 7.600e-04,-1.400e-04, 4.000e-05, 7.000e-05, 5.000e-05,    
     1 8.698e-01,-1.131e+00, 3.836e-01,-8.111e-02, 1.048e-02,-1.300e-03,    
     2 9.626e-01,-1.321e+00, 4.854e-01,-1.091e-01, 1.583e-02,-1.700e-03,    
     3 3.057e-02,-1.088e-01, 8.022e-02,-2.676e-02, 5.590e-03,-5.600e-04,    
     4-2.845e-02, 5.164e-02,-1.918e-02, 2.210e-03,-4.000e-05,-1.500e-04,    
     5 1.311e-02,-1.751e-02, 3.310e-03, 5.100e-04,-1.200e-04, 5.000e-05,    
     6-8.590e-03, 8.380e-03,-9.200e-04,-2.600e-04, 1.000e-05,-1.000e-05/    
C...Expansion coefficients for bottom sea quark distribution.   
      DATA (((cehlq(ix,it,nx,7,1),ix=1,6),it=1,6),nx=1,2)/  
     1 9.010e-03,-1.401e-02, 7.150e-03,-4.130e-03, 1.260e-03,-1.040e-03,    
     2 6.280e-03,-9.320e-03, 4.780e-03,-2.890e-03, 9.100e-04,-8.200e-04,    
     3-2.930e-03, 4.090e-03,-1.890e-03, 7.600e-04,-2.300e-04, 1.400e-04,    
     4 3.900e-04,-1.200e-03, 4.400e-04,-2.500e-04, 2.000e-05,-2.000e-05,    
     5 2.600e-04, 1.400e-04,-8.000e-05, 1.000e-04, 1.000e-05, 1.000e-05,    
     6-2.600e-04, 3.200e-04, 1.000e-05,-1.000e-05, 1.000e-05,-1.000e-05,    
     1 8.029e-01,-1.075e+00, 3.792e-01,-7.843e-02, 1.007e-02,-1.090e-03,    
     2 7.903e-01,-1.099e+00, 4.153e-01,-9.301e-02, 1.317e-02,-1.410e-03,    
     3-1.704e-02,-1.130e-02, 2.882e-02,-1.341e-02, 3.040e-03,-3.600e-04,    
     4-7.200e-04, 7.230e-03,-5.160e-03, 1.080e-03,-5.000e-05,-4.000e-05,    
     5 3.050e-03,-4.610e-03, 1.660e-03,-1.300e-04,-1.000e-05, 1.000e-05,    
     6-4.360e-03, 5.230e-03,-1.610e-03, 2.000e-04,-2.000e-05, 0.000e+00/    
      DATA (((cehlq(ix,it,nx,7,2),ix=1,6),it=1,6),nx=1,2)/  
     1 8.980e-03,-1.459e-02, 7.510e-03,-4.410e-03, 1.310e-03,-1.070e-03,    
     2 5.970e-03,-9.440e-03, 4.800e-03,-3.020e-03, 9.100e-04,-8.500e-04,    
     3-3.050e-03, 4.440e-03,-2.100e-03, 8.500e-04,-2.400e-04, 1.400e-04,    
     4 5.300e-04,-1.300e-03, 5.600e-04,-2.700e-04, 3.000e-05,-2.000e-05,    
     5 2.000e-04, 1.400e-04,-1.100e-04, 1.000e-04, 0.000e+00, 0.000e+00,    
     6-2.600e-04, 3.200e-04, 0.000e+00,-3.000e-05, 1.000e-05,-1.000e-05,    
     1 8.672e-01,-1.174e+00, 4.265e-01,-9.252e-02, 1.244e-02,-1.460e-03,    
     2 8.500e-01,-1.194e+00, 4.630e-01,-1.083e-01, 1.614e-02,-1.830e-03,    
     3-2.241e-02,-5.630e-03, 2.815e-02,-1.425e-02, 3.520e-03,-4.300e-04,    
     4-7.300e-04, 8.030e-03,-5.780e-03, 1.380e-03,-1.300e-04,-4.000e-05,    
     5 3.460e-03,-5.380e-03, 1.960e-03,-2.100e-04, 1.000e-05, 1.000e-05,    
     6-4.850e-03, 5.950e-03,-1.890e-03, 2.600e-04,-3.000e-05, 0.000e+00/    
C...Expansion coefficients for top sea quark distribution.  
      DATA (((cehlq(ix,it,nx,8,1),ix=1,6),it=1,6),nx=1,2)/  
     1 4.410e-03,-7.480e-03, 3.770e-03,-2.580e-03, 7.300e-04,-7.100e-04,    
     2 3.840e-03,-6.050e-03, 3.030e-03,-2.030e-03, 5.800e-04,-5.900e-04,    
     3-8.800e-04, 1.660e-03,-7.500e-04, 4.700e-04,-1.000e-04, 1.000e-04,    
     4-8.000e-05,-1.500e-04, 1.200e-04,-9.000e-05, 3.000e-05, 0.000e+00,    
     5 1.300e-04,-2.200e-04,-2.000e-05,-2.000e-05,-2.000e-05,-2.000e-05,    
     6-7.000e-05, 1.900e-04,-4.000e-05, 2.000e-05, 0.000e+00, 0.000e+00,    
     1 6.623e-01,-9.248e-01, 3.519e-01,-7.930e-02, 1.110e-02,-1.180e-03,    
     2 6.380e-01,-9.062e-01, 3.582e-01,-8.479e-02, 1.265e-02,-1.390e-03,    
     3-2.581e-02, 2.125e-02, 4.190e-03,-4.980e-03, 1.490e-03,-2.100e-04,    
     4 7.100e-04, 5.300e-04,-1.270e-03, 3.900e-04,-5.000e-05,-1.000e-05,    
     5 3.850e-03,-5.060e-03, 1.860e-03,-3.500e-04, 4.000e-05, 0.000e+00,    
     6-3.530e-03, 4.460e-03,-1.500e-03, 2.700e-04,-3.000e-05, 0.000e+00/    
      DATA (((cehlq(ix,it,nx,8,2),ix=1,6),it=1,6),nx=1,2)/  
     1 4.260e-03,-7.530e-03, 3.830e-03,-2.680e-03, 7.600e-04,-7.300e-04,    
     2 3.640e-03,-6.050e-03, 3.030e-03,-2.090e-03, 5.900e-04,-6.000e-04,    
     3-9.200e-04, 1.710e-03,-8.200e-04, 5.000e-04,-1.200e-04, 1.000e-04,    
     4-5.000e-05,-1.600e-04, 1.300e-04,-9.000e-05, 3.000e-05, 0.000e+00,    
     5 1.300e-04,-2.100e-04,-1.000e-05,-2.000e-05,-2.000e-05,-1.000e-05,    
     6-8.000e-05, 1.800e-04,-5.000e-05, 2.000e-05, 0.000e+00, 0.000e+00,    
     1 7.146e-01,-1.007e+00, 3.932e-01,-9.246e-02, 1.366e-02,-1.540e-03,    
     2 6.856e-01,-9.828e-01, 3.977e-01,-9.795e-02, 1.540e-02,-1.790e-03,    
     3-3.053e-02, 2.758e-02, 2.150e-03,-4.880e-03, 1.640e-03,-2.500e-04,    
     4 9.200e-04, 4.200e-04,-1.340e-03, 4.600e-04,-8.000e-05,-1.000e-05,    
     5 4.230e-03,-5.660e-03, 2.140e-03,-4.300e-04, 6.000e-05, 0.000e+00,    
     6-3.890e-03, 5.000e-03,-1.740e-03, 3.300e-04,-4.000e-05, 0.000e+00/    
    
C...The following data lines are coefficients needed in the 
C...Duke, Owens proton structure function parametrizations, see below.  
C...Expansion coefficients for (up+down) valence quark distribution.    
      DATA ((cdo(ip,is,1,1),is=1,6),ip=1,3)/    
     1 4.190e-01, 3.460e+00, 4.400e+00, 0.000e+00, 0.000e+00, 0.000e+00,    
     2 4.000e-03, 7.240e-01,-4.860e+00, 0.000e+00, 0.000e+00, 0.000e+00,    
     3-7.000e-03,-6.600e-02, 1.330e+00, 0.000e+00, 0.000e+00, 0.000e+00/    
      DATA ((cdo(ip,is,1,2),is=1,6),ip=1,3)/    
     1 3.740e-01, 3.330e+00, 6.030e+00, 0.000e+00, 0.000e+00, 0.000e+00,    
     2 1.400e-02, 7.530e-01,-6.220e+00, 0.000e+00, 0.000e+00, 0.000e+00,    
     3 0.000e+00,-7.600e-02, 1.560e+00, 0.000e+00, 0.000e+00, 0.000e+00/    
C...Expansion coefficients for down valence quark distribution. 
      DATA ((cdo(ip,is,2,1),is=1,6),ip=1,3)/    
     1 7.630e-01, 4.000e+00, 0.000e+00, 0.000e+00, 0.000e+00, 0.000e+00,    
     2-2.370e-01, 6.270e-01,-4.210e-01, 0.000e+00, 0.000e+00, 0.000e+00,    
     3 2.600e-02,-1.900e-02, 3.300e-02, 0.000e+00, 0.000e+00, 0.000e+00/    
      DATA ((cdo(ip,is,2,2),is=1,6),ip=1,3)/    
     1 7.610e-01, 3.830e+00, 0.000e+00, 0.000e+00, 0.000e+00, 0.000e+00,    
     2-2.320e-01, 6.270e-01,-4.180e-01, 0.000e+00, 0.000e+00, 0.000e+00,    
     3 2.300e-02,-1.900e-02, 3.600e-02, 0.000e+00, 0.000e+00, 0.000e+00/    
C...Expansion coefficients for (up+down+strange) sea quark distribution.    
      DATA ((cdo(ip,is,3,1),is=1,6),ip=1,3)/    
     1 1.265e+00, 0.000e+00, 8.050e+00, 0.000e+00, 0.000e+00, 0.000e+00,    
     2-1.132e+00,-3.720e-01, 1.590e+00, 6.310e+00,-1.050e+01, 1.470e+01,    
     3 2.930e-01,-2.900e-02,-1.530e-01,-2.730e-01,-3.170e+00, 9.800e+00/    
      DATA ((cdo(ip,is,3,2),is=1,6),ip=1,3)/    
     1 1.670e+00, 0.000e+00, 9.150e+00, 0.000e+00, 0.000e+00, 0.000e+00,    
     2-1.920e+00,-2.730e-01, 5.300e-01, 1.570e+01,-1.010e+02, 2.230e+02,    
     3 5.820e-01,-1.640e-01,-7.630e-01,-2.830e+00, 4.470e+01,-1.170e+02/    
C...Expansion coefficients for charm sea quark distribution.    
      DATA ((cdo(ip,is,4,1),is=1,6),ip=1,3)/    
     1 0.000e+00,-3.600e-02, 6.350e+00, 0.000e+00, 0.000e+00, 0.000e+00,    
     2 1.350e-01,-2.220e-01, 3.260e+00,-3.030e+00, 1.740e+01,-1.790e+01,    
     3-7.500e-02,-5.800e-02,-9.090e-01, 1.500e+00,-1.130e+01, 1.560e+01/    
       DATA ((cdo(ip,is,4,2),is=1,6),ip=1,3)/   
     1 0.000e+00,-1.200e-01, 3.510e+00, 0.000e+00, 0.000e+00, 0.000e+00,    
     2 6.700e-02,-2.330e-01, 3.660e+00,-4.740e-01, 9.500e+00,-1.660e+01,    
     3-3.100e-02,-2.300e-02,-4.530e-01, 3.580e-01,-5.430e+00, 1.550e+01/    
C...Expansion coefficients for gluon distribution.  
      DATA ((cdo(ip,is,5,1),is=1,6),ip=1,3)/    
     1 1.560e+00, 0.000e+00, 6.000e+00, 9.000e+00, 0.000e+00, 0.000e+00,    
     2-1.710e+00,-9.490e-01, 1.440e+00,-7.190e+00,-1.650e+01, 1.530e+01,    
     3 6.380e-01, 3.250e-01,-1.050e+00, 2.550e-01, 1.090e+01,-1.010e+01/    
      DATA ((cdo(ip,is,5,2),is=1,6),ip=1,3)/    
     1 8.790e-01, 0.000e+00, 4.000e+00, 9.000e+00, 0.000e+00, 0.000e+00,    
     2-9.710e-01,-1.160e+00, 1.230e+00,-5.640e+00,-7.540e+00,-5.960e-01,    
     3 4.340e-01, 4.760e-01,-2.540e-01,-8.170e-01, 5.500e+00, 1.260e-01/    
    
C...The following data lines are coefficients needed in the 
C...Owens pion structure function parametrizations, see below.  
C...Expansion coefficients for up and down valence quark distributions. 
      DATA ((cow(ip,is,1,1),is=1,5),ip=1,3)/    
     1  4.0000e-01,  7.0000e-01,  0.0000e+00,  0.0000e+00,  0.0000e+00, 
     2 -6.2120e-02,  6.4780e-01,  0.0000e+00,  0.0000e+00,  0.0000e+00, 
     3 -7.1090e-03,  1.3350e-02,  0.0000e+00,  0.0000e+00,  0.0000e+00/ 
      DATA ((cow(ip,is,1,2),is=1,5),ip=1,3)/    
     1  4.0000e-01,  6.2800e-01,  0.0000e+00,  0.0000e+00,  0.0000e+00, 
     2 -5.9090e-02,  6.4360e-01,  0.0000e+00,  0.0000e+00,  0.0000e+00, 
     3 -6.5240e-03,  1.4510e-02,  0.0000e+00,  0.0000e+00,  0.0000e+00/ 
C...Expansion coefficients for gluon distribution.  
      DATA ((cow(ip,is,2,1),is=1,5),ip=1,3)/    
     1  8.8800e-01,  0.0000e+00,  3.1100e+00,  6.0000e+00,  0.0000e+00, 
     2 -1.8020e+00, -1.5760e+00, -1.3170e-01,  2.8010e+00, -1.7280e+01, 
     3  1.8120e+00,  1.2000e+00,  5.0680e-01, -1.2160e+01,  2.0490e+01/ 
      DATA ((cow(ip,is,2,2),is=1,5),ip=1,3)/    
     1  7.9400e-01,  0.0000e+00,  2.8900e+00,  6.0000e+00,  0.0000e+00, 
     2 -9.1440e-01, -1.2370e+00,  5.9660e-01, -3.6710e+00, -8.1910e+00, 
     3  5.9660e-01,  6.5820e-01, -2.5500e-01, -2.3040e+00,  7.7580e+00/ 
C...Expansion coefficients for (up+down+strange) quark sea distribution.    
      DATA ((cow(ip,is,3,1),is=1,5),ip=1,3)/    
     1  9.0000e-01,  0.0000e+00,  5.0000e+00,  0.0000e+00,  0.0000e+00, 
     2 -2.4280e-01, -2.1200e-01,  8.6730e-01,  1.2660e+00,  2.3820e+00, 
     3  1.3860e-01,  3.6710e-03,  4.7470e-02, -2.2150e+00,  3.4820e-01/ 
      DATA ((cow(ip,is,3,2),is=1,5),ip=1,3)/    
     1  9.0000e-01,  0.0000e+00,  5.0000e+00,  0.0000e+00,  0.0000e+00, 
     2 -1.4170e-01, -1.6970e-01, -2.4740e+00, -2.5340e+00,  5.6210e-01, 
     3 -1.7400e-01, -9.6230e-02,  1.5750e+00,  1.3780e+00, -2.7010e-01/ 
C...Expansion coefficients for charm quark sea distribution.    
      DATA ((cow(ip,is,4,1),is=1,5),ip=1,3)/    
     1  0.0000e+00, -2.2120e-02,  2.8940e+00,  0.0000e+00,  0.0000e+00, 
     2  7.9280e-02, -3.7850e-01,  9.4330e+00,  5.2480e+00,  8.3880e+00, 
     3 -6.1340e-02, -1.0880e-01, -1.0852e+01, -7.1870e+00, -1.1610e+01/ 
      DATA ((cow(ip,is,4,2),is=1,5),ip=1,3)/    
     1  0.0000e+00, -8.8200e-02,  1.9240e+00,  0.0000e+00,  0.0000e+00, 
     2  6.2290e-02, -2.8920e-01,  2.4240e-01, -4.4630e+00, -8.3670e-01, 
     3 -4.0990e-02, -1.0820e-01,  2.0360e+00,  5.2090e+00, -4.8400e-02/ 
    
C...Euler's beta function, requires ordinary Gamma function 
      eulbet(x,y)=pygamm(x)*pygamm(y)/pygamm(x+y)   
    
C...Reset structure functions, check x and hadron flavour.  
      alam=0.   
      DO 100 kfl=-6,6   
  100 xpq(kfl)=0.   
      IF(x.LT.0..OR.x.GT.1.) THEN   
        WRITE(mstu(11),1000) x  
        RETURN  
      ENDIF 
      kfa=iabs(kf)  
      IF(kfa.NE.211.AND.kfa.NE.2212.AND.kfa.NE.2112) THEN   
        WRITE(mstu(11),1100) kf 
        RETURN  
      ENDIF 
    
C...Call user-supplied structure function. Select proton/neutron/pion.  
      IF(mstp(51).EQ.0.OR.mstp(52).GE.2) THEN   
        kfe=kfa 
        IF(kfa.EQ.2112) kfe=2212    
        CALL pystfe(kfe,x,q2,xpq)   
        goto 230    
      ENDIF 
      IF(kfa.EQ.211) goto 200   
    
      IF(mstp(51).EQ.1.OR.mstp(51).EQ.2) THEN   
C...Proton structure functions from Eichten, Hinchliffe, Lane, Quigg.   
C...Allowed variable range: 5 GeV2 < Q2 < 1E8 GeV2; 1E-4 < x < 1    
    
C...Determine set, Lamdba and x and t expansion variables.  
        nset=mstp(51)   
        IF(nset.EQ.1) alam=0.2  
        IF(nset.EQ.2) alam=0.29 
        tmin=log(5./alam**2)    
        tmax=log(1e8/alam**2)   
        IF(mstp(52).EQ.0) THEN  
          t=tmin    
        ELSE    
          t=log(q2/alam**2) 
        ENDIF   
        vt=max(-1.,min(1.,(2.*t-tmax-tmin)/(tmax-tmin)))    
        nx=1    
        IF(x.LE.0.1) nx=2   
        IF(nx.EQ.1) vx=(2.*x-1.1)/0.9   
        IF(nx.EQ.2) vx=max(-1.,(2.*log(x)+11.51293)/6.90776)    
        cxs=1.  
        IF(x.LT.1e-4.AND.abs(parp(51)-1.).GT.0.01) cxs= 
     &  (1e-4/x)**(parp(51)-1.) 
    
C...Chebyshev polynomials for x and t expansion.    
        tx(1)=1.    
        tx(2)=vx    
        tx(3)=2.*vx**2-1.   
        tx(4)=4.*vx**3-3.*vx    
        tx(5)=8.*vx**4-8.*vx**2+1.  
        tx(6)=16.*vx**5-20.*vx**3+5.*vx 
        tt(1)=1.    
        tt(2)=vt    
        tt(3)=2.*vt**2-1.   
        tt(4)=4.*vt**3-3.*vt    
        tt(5)=8.*vt**4-8.*vt**2+1.  
        tt(6)=16.*vt**5-20.*vt**3+5.*vt 
    
C...Calculate structure functions.  
        DO 120 kfl=1,6  
        xqsum=0.    
        DO 110 it=1,6   
        DO 110 ix=1,6   
  110   xqsum=xqsum+cehlq(ix,it,nx,kfl,nset)*tx(ix)*tt(it)  
  120   xq(kfl)=xqsum*(1.-x)**nehlq(kfl,nset)*cxs   
    
C...Put into output array.  
        xpq(0)=xq(4)    
        xpq(1)=xq(2)+xq(3)  
        xpq(2)=xq(1)+xq(3)  
        xpq(3)=xq(5)    
        xpq(4)=xq(6)    
        xpq(-1)=xq(3)   
        xpq(-2)=xq(3)   
        xpq(-3)=xq(5)   
        xpq(-4)=xq(6)   
    
C...Special expansion for bottom (threshold effects).   
        IF(mstp(54).GE.5) THEN  
          IF(nset.EQ.1) tmin=8.1905 
          IF(nset.EQ.2) tmin=7.4474 
          IF(t.LE.tmin) goto 140    
          vt=max(-1.,min(1.,(2.*t-tmax-tmin)/(tmax-tmin)))  
          tt(1)=1.  
          tt(2)=vt  
          tt(3)=2.*vt**2-1. 
          tt(4)=4.*vt**3-3.*vt  
          tt(5)=8.*vt**4-8.*vt**2+1.    
          tt(6)=16.*vt**5-20.*vt**3+5.*vt   
          xqsum=0.  
          DO 130 it=1,6 
          DO 130 ix=1,6 
  130     xqsum=xqsum+cehlq(ix,it,nx,7,nset)*tx(ix)*tt(it)  
          xpq(5)=xqsum*(1.-x)**nehlq(7,nset)    
          xpq(-5)=xpq(5)    
  140     CONTINUE  
        ENDIF   
    
C...Special expansion for top (threshold effects).  
        IF(mstp(54).GE.6) THEN  
          IF(nset.EQ.1) tmin=11.5528    
          IF(nset.EQ.2) tmin=10.8097    
          tmin=tmin+2.*log(pmas(6,1)/30.)   
          tmax=tmax+2.*log(pmas(6,1)/30.)   
          IF(t.LE.tmin) goto 160    
          vt=max(-1.,min(1.,(2.*t-tmax-tmin)/(tmax-tmin)))  
          tt(1)=1.  
          tt(2)=vt  
          tt(3)=2.*vt**2-1. 
          tt(4)=4.*vt**3-3.*vt  
          tt(5)=8.*vt**4-8.*vt**2+1.    
          tt(6)=16.*vt**5-20.*vt**3+5.*vt   
          xqsum=0.  
          DO 150 it=1,6 
          DO 150 ix=1,6 
  150     xqsum=xqsum+cehlq(ix,it,nx,8,nset)*tx(ix)*tt(it)  
          xpq(6)=xqsum*(1.-x)**nehlq(8,nset)    
          xpq(-6)=xpq(6)    
  160     CONTINUE  
        ENDIF   
    
      ELSEIF(mstp(51).EQ.3.OR.mstp(51).EQ.4) THEN   
C...Proton structure functions from Duke, Owens.    
C...Allowed variable range: 4 GeV2 < Q2 < approx 1E6 GeV2.  
    
C...Determine set, Lambda and s expansion parameter.    
        nset=mstp(51)-2 
        IF(nset.EQ.1) alam=0.2  
        IF(nset.EQ.2) alam=0.4  
        IF(mstp(52).LE.0) THEN  
          sd=0. 
        ELSE    
          sd=log(log(max(q2,4.)/alam**2)/log(4./alam**2))   
        ENDIF   
    
C...Calculate structure functions.  
        DO 180 kfl=1,5  
        DO 170 is=1,6   
  170   ts(is)=cdo(1,is,kfl,nset)+cdo(2,is,kfl,nset)*sd+    
     &  cdo(3,is,kfl,nset)*sd**2    
        IF(kfl.LE.2) THEN   
          xq(kfl)=x**ts(1)*(1.-x)**ts(2)*(1.+ts(3)*x)/(eulbet(ts(1),    
     &    ts(2)+1.)*(1.+ts(3)*ts(1)/(ts(1)+ts(2)+1.)))  
        ELSE    
          xq(kfl)=ts(1)*x**ts(2)*(1.-x)**ts(3)*(1.+ts(4)*x+ts(5)*x**2+  
     &    ts(6)*x**3)   
        ENDIF   
  180   CONTINUE    
    
C...Put into output arrays. 
        xpq(0)=xq(5)    
        xpq(1)=xq(2)+xq(3)/6.   
        xpq(2)=3.*xq(1)-xq(2)+xq(3)/6.  
        xpq(3)=xq(3)/6. 
        xpq(4)=xq(4)    
        xpq(-1)=xq(3)/6.    
        xpq(-2)=xq(3)/6.    
        xpq(-3)=xq(3)/6.    
        xpq(-4)=xq(4)   
    
C...Proton structure functions from Diemoz, Ferroni, Longo, Martinelli. 
C...These are accessed via PYSTFE since the files needed may not always 
C...available.  
      ELSEIF(mstp(51).GE.11.AND.mstp(51).LE.13) THEN    
        CALL pystfe(2212,x,q2,xpq)  
    
C...Unknown proton parametrization. 
      ELSE  
        WRITE(mstu(11),1200) mstp(51)   
      ENDIF 
      goto 230  
    
  200 IF((mstp(51).GE.1.AND.mstp(51).LE.4).OR.  
     &(mstp(51).GE.11.AND.mstp(51).LE.13)) THEN 
C...Pion structure functions from Owens.    
C...Allowed variable range: 4 GeV2 < Q2 < approx 2000 GeV2. 
    
C...Determine set, Lambda and s expansion variable. 
        nset=1  
        IF(mstp(51).EQ.2.OR.mstp(51).EQ.4.OR.mstp(51).EQ.13) nset=2 
        IF(nset.EQ.1) alam=0.2  
        IF(nset.EQ.2) alam=0.4  
        IF(mstp(52).LE.0) THEN  
          sd=0. 
        ELSE    
          sd=log(log(max(q2,4.)/alam**2)/log(4./alam**2))   
        ENDIF   
    
C...Calculate structure functions.  
        DO 220 kfl=1,4  
        DO 210 is=1,5   
  210   ts(is)=cow(1,is,kfl,nset)+cow(2,is,kfl,nset)*sd+    
     &  cow(3,is,kfl,nset)*sd**2    
        IF(kfl.EQ.1) THEN   
          xq(kfl)=x**ts(1)*(1.-x)**ts(2)/eulbet(ts(1),ts(2)+1.) 
        ELSE    
          xq(kfl)=ts(1)*x**ts(2)*(1.-x)**ts(3)*(1.+ts(4)*x+ts(5)*x**2)  
        ENDIF   
  220   CONTINUE    
    
C...Put into output arrays. 
        xpq(0)=xq(2)    
        xpq(1)=xq(3)/6. 
        xpq(2)=xq(1)+xq(3)/6.   
        xpq(3)=xq(3)/6. 
        xpq(4)=xq(4)    
        xpq(-1)=xq(1)+xq(3)/6.  
        xpq(-2)=xq(3)/6.    
        xpq(-3)=xq(3)/6.    
        xpq(-4)=xq(4)   
    
C...Unknown pion parametrization.   
      ELSE  
        WRITE(mstu(11),1200) mstp(51)   
      ENDIF 
    
C...Isospin conjugation for neutron, charge conjugation for antipart.   
  230 IF(kfa.EQ.2112) THEN  
        xps=xpq(1)  
        xpq(1)=xpq(2)   
        xpq(2)=xps  
        xps=xpq(-1) 
        xpq(-1)=xpq(-2) 
        xpq(-2)=xps 
      ENDIF 
      IF(kf.LT.0) THEN  
        DO 240 kfl=1,4  
        xps=xpq(kfl)    
        xpq(kfl)=xpq(-kfl)  
  240   xpq(-kfl)=xps   
      ENDIF 
    
C...Check positivity and reset above maximum allowed flavour.   
      DO 250 kfl=-6,6   
      xpq(kfl)=max(0.,xpq(kfl)) 
  250 IF(iabs(kfl).GT.mstp(54)) xpq(kfl)=0. 

C...consider nuclear effect on the structure function
        IF((jbt.NE.1.AND.jbt.NE.2).OR.ihpr2(6).EQ.0
     &                  .OR.ihnt2(16).EQ.1) go to 400
        atnm=ihnt2(2*jbt-1)
        IF(atnm.LE.1.0) go to 400
        IF(jbt.EQ.1) THEN
    bbr2=(yp(1,ihnt2(11))**2+yp(2,ihnt2(11))**2)/1.44/atnm**0.66666
        ELSEIF(jbt.EQ.2) THEN
    bbr2=(yt(1,ihnt2(12))**2+yt(2,ihnt2(12))**2)/1.44/atnm**0.66666
        ENDIF
        bbr2=min(1.0,bbr2)
  abx=(atnm**0.33333333-1.0)
        apx=hipr1(6)*4.0/3.0*abx*sqrt(1.0-bbr2)
        aax=1.192*alog(atnm)**0.1666666
        rrx=aax*(x**3-1.2*x**2+0.21*x)+1.0
     &    -(apx-1.079*abx*sqrt(x)/alog(atnm+1.0))*exp(-x**2.0/0.01)
        DO 300 kfl=-6,6
    xpq(kfl)=xpq(kfl)*rrx
300     CONTINUE
C     ********consider the nuclear effect on the structure
C       fucntion which also depends on the impact
C       parameter of the nuclear reaction

400     CONTINUE    
C...Formats for error printouts.    
 1000 FORMAT(' Error: x value outside physical range, x =',1p,e12.3)    
 1100 FORMAT(' Error: illegal particle code for structure function,',   
     &' KF =',i5)   
 1200 FORMAT(' Error: bad value of parameter MSTP(51) in PYSTFU,',  
     &' MSTP(51) =',i5) 
    
      RETURN    
      END   
    
C*********************************************************************  
    
      SUBROUTINE pyspli(KF,KFLIN,KFLCH,KFLSP)   
    
C...In case of a hadron remnant which is more complicated than just a   
C...quark or a diquark, split it into two (partons or hadron + parton). 
      dimension kfl(3)  
    
C...Preliminaries. Parton composition.  
      kfa=iabs(kf)  
      kfs=isign(1,kf)   
      kfl(1)=mod(kfa/1000,10)   
      kfl(2)=mod(kfa/100,10)    
      kfl(3)=mod(kfa/10,10) 
      kflr=kflin*kfs    
      kflch=0   
    
C...Subdivide meson.    
      IF(kfl(1).EQ.0) THEN  
        kfl(2)=kfl(2)*(-1)**kfl(2)  
        kfl(3)=-kfl(3)*(-1)**iabs(kfl(2))   
        IF(kflr.EQ.kfl(2)) THEN 
          kflsp=kfl(3)  
        ELSEIF(kflr.EQ.kfl(3)) THEN 
          kflsp=kfl(2)  
        ELSEIF(iabs(kflr).EQ.21.AND.rlu(0).GT.0.5) THEN 
          kflsp=kfl(2)  
          kflch=kfl(3)  
        ELSEIF(iabs(kflr).EQ.21) THEN   
          kflsp=kfl(3)  
          kflch=kfl(2)  
        ELSEIF(kflr*kfl(2).GT.0) THEN   
          CALL lukfdi(-kflr,kfl(2),kfdump,kflch)    
          kflsp=kfl(3)  
        ELSE    
          CALL lukfdi(-kflr,kfl(3),kfdump,kflch)    
          kflsp=kfl(2)  
        ENDIF   
    
C...Subdivide baryon.   
      ELSE  
        nagr=0  
        DO 100 j=1,3    
  100   IF(kflr.EQ.kfl(j)) nagr=nagr+1  
        IF(nagr.GE.1) THEN  
          ragr=0.00001+(nagr-0.00002)*rlu(0)    
          iagr=0    
          DO 110 j=1,3  
          IF(kflr.EQ.kfl(j)) ragr=ragr-1.   
  110     IF(iagr.EQ.0.AND.ragr.LE.0.) iagr=j   
        ELSE    
          iagr=1.00001+2.99998*rlu(0)   
        ENDIF   
        id1=1   
        IF(iagr.EQ.1) id1=2 
        IF(iagr.EQ.1.AND.kfl(3).GT.kfl(2)) id1=3    
        id2=6-iagr-id1  
        ksp=3   
        IF(mod(kfa,10).EQ.2.AND.kfl(1).EQ.kfl(2)) THEN  
          IF(iagr.NE.3.AND.rlu(0).GT.0.25) ksp=1    
        ELSEIF(mod(kfa,10).EQ.2.AND.kfl(2).GE.kfl(3)) THEN  
          IF(iagr.NE.1.AND.rlu(0).GT.0.25) ksp=1    
        ELSEIF(mod(kfa,10).EQ.2) THEN   
          IF(iagr.EQ.1) ksp=1   
          IF(iagr.NE.1.AND.rlu(0).GT.0.75) ksp=1    
        ENDIF   
        kflsp=1000*kfl(id1)+100*kfl(id2)+ksp    
        IF(kflin.EQ.21) THEN    
          kflch=kfl(iagr)   
        ELSEIF(nagr.EQ.0.AND.kflr.GT.0) THEN    
          CALL lukfdi(-kflr,kfl(iagr),kfdump,kflch) 
        ELSEIF(nagr.EQ.0) THEN  
          CALL lukfdi(10000+kflsp,-kflr,kfdump,kflch)   
          kflsp=kfl(iagr)   
        ENDIF   
      ENDIF 
    
C...Add on correct sign for result. 
      kflch=kflch*kfs   
      kflsp=kflsp*kfs   
    
      RETURN    
      END   
    
C*********************************************************************  
    
      FUNCTION pygamm(X)    
    
C...Gives ordinary Gamma function Gamma(x) for positive, real arguments;    
C...see M. Abramowitz, I. A. Stegun: Handbook of Mathematical Functions 
C...(Dover, 1965) 6.1.36.   
      dimension b(8)    
      DATA b/-0.577191652,0.988205891,-0.897056937,0.918206857, 
     &-0.756704078,0.482199394,-0.193527818,0.035868343/    
    
      nx=int(x) 
      dx=x-nx   
    
      pygamm=1. 
      DO 100 i=1,8  
  100 pygamm=pygamm+b(i)*dx**i  
      IF(x.LT.1.) THEN  
        pygamm=pygamm/x 
      ELSE  
        DO 110 ix=1,nx-1    
  110   pygamm=(x-ix)*pygamm    
      ENDIF 
    
      RETURN    
      END   
    
C***********************************************************************    
    
      FUNCTION pyw1au(EPS,IREIM)    
    
C...Calculates real and imaginary parts of the auxiliary function W1;   
C...see R. K. Ellis, I. Hinchliffe, M. Soldate and J. J. van der Bij,   
C...FERMILAB-Pub-87/100-T, LBL-23504, June, 1987    
      common/ludat1/mstu(200),paru(200),mstj(200),parj(200) 
      SAVE /ludat1/ 
    
      asinh(x)=log(x+sqrt(x**2+1.)) 
      acosh(x)=log(x+sqrt(x**2-1.)) 
    
      IF(eps.LT.0.) THEN    
        w1re=2.*sqrt(1.-eps)*asinh(sqrt(-1./eps))   
        w1im=0. 
      ELSEIF(eps.LT.1.) THEN    
        w1re=2.*sqrt(1.-eps)*acosh(sqrt(1./eps))    
        w1im=-paru(1)*sqrt(1.-eps)  
      ELSE  
        w1re=2.*sqrt(eps-1.)*asin(sqrt(1./eps)) 
        w1im=0. 
      ENDIF 
    
      IF(ireim.EQ.1) pyw1au=w1re    
      IF(ireim.EQ.2) pyw1au=w1im    
    
      RETURN    
      END   
    
C***********************************************************************    
    
      FUNCTION pyw2au(EPS,IREIM)    
    
C...Calculates real and imaginary parts of the auxiliary function W2;   
C...see R. K. Ellis, I. Hinchliffe, M. Soldate and J. J. van der Bij,   
C...FERMILAB-Pub-87/100-T, LBL-23504, June, 1987    
      common/ludat1/mstu(200),paru(200),mstj(200),parj(200) 
      SAVE /ludat1/ 
    
      asinh(x)=log(x+sqrt(x**2+1.)) 
      acosh(x)=log(x+sqrt(x**2-1.)) 
    
      IF(eps.LT.0.) THEN    
        w2re=4.*(asinh(sqrt(-1./eps)))**2   
        w2im=0. 
      ELSEIF(eps.LT.1.) THEN    
        w2re=4.*(acosh(sqrt(1./eps)))**2-paru(1)**2 
        w2im=-4.*paru(1)*acosh(sqrt(1./eps))    
      ELSE  
        w2re=-4.*(asin(sqrt(1./eps)))**2    
        w2im=0. 
      ENDIF 
    
      IF(ireim.EQ.1) pyw2au=w2re    
      IF(ireim.EQ.2) pyw2au=w2im    
    
      RETURN    
      END   
    
C***********************************************************************    
    
      FUNCTION pyi3au(BE,EPS,IREIM) 
    
C...Calculates real and imaginary parts of the auxiliary function I3;   
C...see R. K. Ellis, I. Hinchliffe, M. Soldate and J. J. van der Bij,   
C...FERMILAB-Pub-87/100-T, LBL-23504, June, 1987    
      common/ludat1/mstu(200),paru(200),mstj(200),parj(200) 
      SAVE /ludat1/ 
    
      IF(eps.LT.1.) ga=0.5*(1.+sqrt(1.-eps))    
    
      IF(eps.LT.0.) THEN    
        f3re=pyspen((ga-1.)/(ga+be-1.),0.,1)-pyspen(ga/(ga+be-1.),0.,1)+    
     &  pyspen((be-ga)/be,0.,1)-pyspen((be-ga)/(be-1.),0.,1)+   
     &  (log(be)**2-log(be-1.)**2)/2.+log(ga)*log((ga+be-1.)/be)+   
     &  log(ga-1.)*log((be-1.)/(ga+be-1.))  
        f3im=0. 
      ELSEIF(eps.LT.1.) THEN    
        f3re=pyspen((ga-1.)/(ga+be-1.),0.,1)-pyspen(ga/(ga+be-1.),0.,1)+    
     &  pyspen(ga/(ga-be),0.,1)-pyspen((ga-1.)/(ga-be),0.,1)+   
     &  log(ga/(1.-ga))*log((ga+be-1.)/(be-ga)) 
        f3im=-paru(1)*log((ga+be-1.)/(be-ga))   
      ELSE  
        rsq=eps/(eps-1.+(2.*be-1.)**2)  
        rcthe=rsq*(1.-2.*be/eps)    
        rsthe=sqrt(rsq-rcthe**2)    
        rcphi=rsq*(1.+2.*(be-1.)/eps)   
        rsphi=sqrt(rsq-rcphi**2)    
        r=sqrt(rsq) 
        the=acos(rcthe/r)   
        phi=acos(rcphi/r)   
        f3re=pyspen(rcthe,rsthe,1)+pyspen(rcthe,-rsthe,1)-  
     &  pyspen(rcphi,rsphi,1)-pyspen(rcphi,-rsphi,1)+   
     &  (phi-the)*(phi+the-paru(1)) 
        f3im=pyspen(rcthe,rsthe,2)+pyspen(rcthe,-rsthe,2)-  
     &  pyspen(rcphi,rsphi,2)-pyspen(rcphi,-rsphi,2)    
      ENDIF 
    
      IF(ireim.EQ.1) pyi3au=2./(2.*be-1.)*f3re  
      IF(ireim.EQ.2) pyi3au=2./(2.*be-1.)*f3im  
    
      RETURN    
      END   
    
C***********************************************************************    
    
      FUNCTION pyspen(XREIN,XIMIN,IREIM)    
    
C...Calculates real and imaginary part of Spence function; see  
C...G. 't Hooft and M. Veltman, Nucl. Phys. B153 (1979) 365.    
      common/ludat1/mstu(200),paru(200),mstj(200),parj(200) 
      SAVE /ludat1/ 
      dimension b(0:14) 
    
      DATA b/   
     & 1.000000e+00,        -5.000000e-01,         1.666667e-01,    
     & 0.000000e+00,        -3.333333e-02,         0.000000e+00,    
     & 2.380952e-02,         0.000000e+00,        -3.333333e-02,    
     & 0.000000e+00,         7.575757e-02,         0.000000e+00,    
     &-2.531135e-01,         0.000000e+00,         1.166667e+00/    
    
      xre=xrein 
      xim=ximin 
      IF(abs(1.-xre).LT.1.e-6.AND.abs(xim).LT.1.e-6) THEN   
        IF(ireim.EQ.1) pyspen=paru(1)**2/6. 
        IF(ireim.EQ.2) pyspen=0.    
        RETURN  
      ENDIF 
    
      xmod=sqrt(xre**2+xim**2)  
      IF(xmod.LT.1.e-6) THEN    
        IF(ireim.EQ.1) pyspen=0.    
        IF(ireim.EQ.2) pyspen=0.    
        RETURN  
      ENDIF 
    
      xarg=sign(acos(xre/xmod),xim) 
      sp0re=0.  
      sp0im=0.  
      sgn=1.    
      IF(xmod.GT.1.) THEN   
        algxre=log(xmod)    
        algxim=xarg-sign(paru(1),xarg)  
        sp0re=-paru(1)**2/6.-(algxre**2-algxim**2)/2.   
        sp0im=-algxre*algxim    
        sgn=-1. 
        xmod=1./xmod    
        xarg=-xarg  
        xre=xmod*cos(xarg)  
        xim=xmod*sin(xarg)  
      ENDIF 
      IF(xre.GT.0.5) THEN   
        algxre=log(xmod)    
        algxim=xarg 
        xre=1.-xre  
        xim=-xim    
        xmod=sqrt(xre**2+xim**2)    
        xarg=sign(acos(xre/xmod),xim)   
        algyre=log(xmod)    
        algyim=xarg 
        sp0re=sp0re+sgn*(paru(1)**2/6.-(algxre*algyre-algxim*algyim))   
        sp0im=sp0im-sgn*(algxre*algyim+algxim*algyre)   
        sgn=-sgn    
      ENDIF 
    
      xre=1.-xre    
      xim=-xim  
      xmod=sqrt(xre**2+xim**2)  
      xarg=sign(acos(xre/xmod),xim) 
      zre=-log(xmod)    
      zim=-xarg 
    
      spre=0.   
      spim=0.   
      savere=1. 
      saveim=0. 
      DO 100 i=0,14 
      termre=(savere*zre-saveim*zim)/float(i+1) 
      termim=(savere*zim+saveim*zre)/float(i+1) 
      savere=termre 
      saveim=termim 
      spre=spre+b(i)*termre 
  100 spim=spim+b(i)*termim 
    
      IF(ireim.EQ.1) pyspen=sp0re+sgn*spre  
      IF(ireim.EQ.2) pyspen=sp0im+sgn*spim  
    
      RETURN    
      END   
    
*********************************************************************** 
    
      SUBROUTINE pytest(MTEST)  
    
C...Purpose: to provide a simple program (disguised as a subroutine) to 
C...run at installation as a check that the program works as intended.  
      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/ludat2/kchg(500,3),pmas(500,4),parf(2000),vckm(4,4)    
      SAVE /ludat2/ 
      common/ludat3/mdcy(500,3),mdme(2000,2),brat(2000),kfdp(2000,5)    
      SAVE /ludat3/ 
      common/pysubs/msel,msub(200),kfin(2,-40:40),ckin(200) 
      SAVE /pysubs/ 
      common/pypars/mstp(200),parp(200),msti(200),pari(200) 
      SAVE /pypars/ 
    
C...Common initial values. Loop over initiating conditions. 
      mstp(122)=1   
      IF(mtest.LE.0) mstp(122)=0    
      mdcy(lucomp(111),1)=0 
      nerr=0    
      DO 130 iproc=1,7  
    
C...Reset process type, kinematics cuts, and the flags used.    
      msel=0    
      DO 100 isub=1,200 
  100 msub(isub)=0  
      ckin(1)=2.    
      ckin(3)=0.    
      mstp(2)=1 
      mstp(33)=0    
      mstp(81)=1    
      mstp(82)=1    
      mstp(111)=1   
      mstp(131)=0   
      mstp(133)=0   
      parp(131)=0.01    
    
C...Prompt photon production at fixed target.   
      IF(iproc.EQ.1) THEN   
        pzsum=300.  
        pesum=sqrt(pzsum**2+ulmass(211)**2)+ulmass(2212)    
        pqsum=2.    
        msel=10 
        ckin(3)=5.  
        CALL pyinit('FIXT','pi+','p',pzsum) 
    
C...QCD processes at ISR energies.  
      ELSEIF(iproc.EQ.2) THEN   
        pesum=63.   
        pzsum=0.    
        pqsum=2.    
        msel=1  
        ckin(3)=5.  
        CALL pyinit('CMS','p','p',pesum)    
    
C...W production + multiple interactions at CERN Collider.  
      ELSEIF(iproc.EQ.3) THEN   
        pesum=630.  
        pzsum=0.    
        pqsum=0.    
        msel=12 
        ckin(1)=20. 
        mstp(82)=4  
        mstp(2)=2   
        mstp(33)=3  
        CALL pyinit('CMS','p','pbar',pesum) 
    
C...W/Z gauge boson pairs + overlayed events at the Tevatron.   
      ELSEIF(iproc.EQ.4) THEN   
        pesum=1800. 
        pzsum=0.    
        pqsum=0.    
        msub(22)=1  
        msub(23)=1  
        msub(25)=1  
        ckin(1)=200.    
        mstp(111)=0 
        mstp(131)=1 
        mstp(133)=2 
        parp(131)=0.04  
        CALL pyinit('CMS','p','pbar',pesum) 
    
C...Higgs production at LHC.    
      ELSEIF(iproc.EQ.5) THEN   
        pesum=17000.    
        pzsum=0.    
        pqsum=0.    
        msel=16 
        pmas(25,1)=300. 
        ckin(1)=200.    
        mstp(81)=0  
        mstp(111)=0 
        CALL pyinit('CMS','p','pbar',pesum) 
    
C...Z' production at SSC.   
      ELSEIF(iproc.EQ.6) THEN   
        pesum=40000.    
        pzsum=0.    
        pqsum=0.    
        msel=21 
        pmas(32,1)=600. 
        ckin(1)=400.    
        mstp(81)=0  
        mstp(111)=0 
        CALL pyinit('CMS','p','pbar',pesum) 
    
C...W pair production at 1 TeV e+e- collider.   
      ELSEIF(iproc.EQ.7) THEN   
        pesum=1000. 
        pzsum=0.    
        pqsum=0.    
        msub(25)=1  
        CALL pyinit('CMS','e+','e-',pesum)  
      ENDIF 
    
C...Generate 20 events of each required type.   
      DO 120 iev=1,20   
      CALL pythia   
      pesumm=pesum  
      IF(iproc.EQ.4) pesumm=msti(41)*pesum  
    
C...Check conservation of energy/momentum/flavour.  
      merr=0    
      deve=abs(plu(0,4)-pesumm)+abs(plu(0,3)-pzsum) 
      devt=abs(plu(0,1))+abs(plu(0,2))  
      devq=abs(plu(0,6)-pqsum)  
      IF(deve.GT.1e-3*pesum.OR.devt.GT.max(0.01,1e-5*pesum).OR. 
     &devq.GT.0.1) merr=1   
      IF(merr.NE.0) WRITE(mstu(11),1000) iproc,iev  
    
C...Check that all KF codes are known ones, and that partons/particles  
C...satisfy energy-momentum-mass relation.  
      DO 110 i=1,n  
      IF(k(i,1).GT.20) goto 110 
      IF(lucomp(k(i,2)).EQ.0) THEN  
        WRITE(mstu(11),1100) i  
        merr=merr+1 
      ENDIF 
      pd=p(i,4)**2-p(i,1)**2-p(i,2)**2-p(i,3)**2-p(i,5)**2* 
     &sign(1.,p(i,5))   
      IF(abs(pd).GT.max(0.1,0.002*p(i,4)**2,0.002*p(i,5)**2).OR.    
     &(p(i,5).GE.0..AND.p(i,4).LT.0.)) THEN 
        WRITE(mstu(11),1200) i  
        merr=merr+1 
      ENDIF 
  110 CONTINUE  
    
C...Listing of erronoeus events, and first event of each type.  
      IF(merr.GE.1) nerr=nerr+1 
      IF(nerr.GE.10) THEN   
        WRITE(mstu(11),1300)    
        CALL lulist(1)  
        stop    
      ENDIF 
      IF(mtest.GE.1.AND.(merr.GE.1.OR.iev.EQ.1)) THEN   
        IF(merr.GE.1) WRITE(mstu(11),1400)  
        CALL lulist(1)  
      ENDIF 
  120 CONTINUE  
    
C...List statistics for each process type.  
      IF(mtest.GE.1) CALL pystat(1) 
  130 CONTINUE  
    
C...Summarize result of run.    
      IF(nerr.EQ.0) WRITE(mstu(11),1500)    
      IF(nerr.GT.0) WRITE(mstu(11),1600) nerr   
      RETURN    
    
C...Formats for information.    
 1000 FORMAT(/5x,'Energy/momentum/flavour nonconservation for process', 
     &i2,', event',i4)  
 1100 FORMAT(/5x,'Entry no.',i4,' in following event not known code')   
 1200 FORMAT(/5x,'Entry no.',i4,' in following event has faulty ',  
     &'kinematics') 
 1300 FORMAT(/5x,'This is the tenth error experienced! Something is ',  
     &'wrong.'/5x,'Execution will be stopped after listing of event.')  
 1400 FORMAT(5x,'Faulty event follows:')    
 1500 FORMAT(//5x,'End result of run: no errors detected.') 
 1600 FORMAT(//5x,'End result of run:',i2,' errors detected.'/  
     &5x,'This should not have happened!')  
      END   
    
C*********************************************************************  
    
      BLOCK DATA pydata 
    
C...Give sensible default values to all status codes and parameters.    
      common/pysubs/msel,msub(200),kfin(2,-40:40),ckin(200) 
      SAVE /pysubs/ 
      common/pypars/mstp(200),parp(200),msti(200),pari(200) 
      SAVE /pypars/ 
      common/pyint1/mint(400),vint(400) 
      SAVE /pyint1/ 
      common/pyint2/iset(200),kfpr(200,2),coef(200,20),icol(40,4,2) 
      SAVE /pyint2/ 
      common/pyint3/xsfx(2,-40:40),isig(1000,3),sigh(1000)  
      SAVE /pyint3/ 
      common/pyint4/widp(21:40,0:40),wide(21:40,0:40),wids(21:40,3) 
      SAVE /pyint4/ 
      common/pyint5/ngen(0:200,3),xsec(0:200,3) 
      SAVE /pyint5/ 
      common/pyint6/proc(0:200) 
      CHARACTER proc*28 
      SAVE /pyint6/ 
    
C...Default values for allowed processes and kinematics constraints.    
      DATA msel/1/  
      DATA msub/200*0/  
      DATA ((kfin(i,j),j=-40,40),i=1,2)/40*1,0,80*1,0,40*1/ 
      DATA ckin/    
     &   2.0, -1.0,  0.0, -1.0,  1.0,  1.0, -10.,  10., -10.,  10., 
     1  -10.,  10., -10.,  10., -10.,  10., -1.0,  1.0, -1.0,  1.0, 
     2   0.0,  1.0,  0.0,  1.0, -1.0,  1.0, -1.0,  1.0,   0.,   0., 
     3   2.0, -1.0,   0.,   0.,   0.,   0.,   0.,   0.,   0.,   0., 
     4   160*0./    
    
C...Default values for main switches and parameters. Reset information. 
      DATA (mstp(i),i=1,100)/   
     &     3,    1,    2,    0,    0,    0,    0,    0,    0,    0, 
     1     0,    0,    0,    0,    0,    0,    0,    0,    0,    0, 
     2     0,    0,    0,    0,    0,    0,    0,    0,    0,    0, 
     3     1,    2,    0,    0,    0,    2,    0,    0,    0,    0, 
     4     1,    0,    3,    7,    1,    0,    0,    0,    0,    0, 
     5     1,    1,   20,    6,    0,    0,    0,    0,    0,    0, 
     6     1,    2,    2,    2,    1,    0,    0,    0,    0,    0, 
     7     1,    0,    0,    0,    0,    0,    0,    0,    0,    0, 
     8     1,    1,  100,    0,    0,    0,    0,    0,    0,    0, 
     9     1,    4,    0,    0,    0,    0,    0,    0,    0,    0/ 
      DATA (mstp(i),i=101,200)/ 
     &     1,    0,    0,    0,    0,    0,    0,    0,    0,    0, 
     1     1,    1,    1,    0,    0,    0,    0,    0,    0,    0, 
     2     0,    1,    2,    1,    1,   20,    0,    0,    0,    0, 
     3     0,    4,    0,    1,    0,    0,    0,    0,    0,    0, 
     4     0,    0,    0,    0,    0,    0,    0,    0,    0,    0, 
     5     0,    0,    0,    0,    0,    0,    0,    0,    0,    0, 
     6     0,    0,    0,    0,    0,    0,    0,    0,    0,    0, 
     7     0,    0,    0,    0,    0,    0,    0,    0,    0,    0, 
     8     5,    3, 1989,   11,   24,    0,    0,    0,    0,    0, 
     9     0,    0,    0,    0,    0,    0,    0,    0,    0,    0/ 
      DATA (parp(i),i=1,100)/   
     &  0.25,  10.,   0.,   0.,   0.,   0.,   0.,   0.,   0.,   0., 
     1    0.,   0.,   0.,   0.,   0.,   0.,   0.,   0.,   0.,   0., 
     2    0.,   0.,   0.,   0.,   0.,   0.,   0.,   0.,   0.,   0., 
     3   1.5,  2.0, 0.075,  0.,  0.2,   0.,   0.,   0.,   0.,   0., 
     4    0.,   0.,   0.,   0.,   0.,   0.,   0.,   0.,   0.,   0., 
     5   1.0, 2.26, 1.e4, 1.e-4,  0.,   0.,   0.,   0.,   0.,   0., 
     6  0.25,  1.0, 0.25,  1.0,  2.0, 1.e-3, 4.0,   0.,   0.,   0., 
     7   4.0,   0.,   0.,   0.,   0.,   0.,   0.,   0.,   0.,   0., 
     8   1.6, 1.85,  0.5,  0.2, 0.33, 0.66,  0.7,  0.5,   0.,   0., 
     9  0.44, 0.44,  2.0,  1.0,   0.,  3.0,  1.0, 0.75,   0.,   0./ 
      DATA (parp(i),i=101,200)/ 
     & -0.02,   0.,   0.,   0.,   0.,   0.,   0.,   0.,   0.,   0., 
     1   2.0,   0.,   0.,   0.,   0.,   0.,   0.,   0.,   0.,   0., 
     2   0.4,   0.,   0.,   0.,   0.,   0.,   0.,   0.,   0.,   0., 
     3  0.01,   0.,   0.,   0.,   0.,   0.,   0.,   0.,   0.,   0., 
     4    0.,   0.,   0.,   0.,   0.,   0.,   0.,   0.,   0.,   0., 
     5    0.,   0.,   0.,   0.,   0.,   0.,   0.,   0.,   0.,   0., 
     6    0.,   0.,   0.,   0.,   0.,   0.,   0.,   0.,   0.,   0., 
     7    0.,   0.,   0.,   0.,   0.,   0.,   0.,   0.,   0.,   0., 
     8    0.,   0.,   0.,   0.,   0.,   0.,   0.,   0.,   0.,   0., 
     9    0.,   0.,   0.,   0.,   0.,   0.,   0.,   0.,   0.,   0./ 
      DATA msti/200*0/  
      DATA pari/200*0./ 
      DATA mint/400*0/  
      DATA vint/400*0./ 
    
C...Constants for the generation of the various processes.  
      DATA (iset(i),i=1,100)/   
     &    1,    1,    1,   -1,    3,   -1,   -1,    3,   -2,   -2,  
     1    2,    2,    2,    2,    2,    2,   -1,    2,    2,    2,  
     2   -1,    2,    2,    2,    2,    2,   -1,    2,    2,    2,  
     3    2,   -1,   -1,   -1,   -1,   -1,   -1,   -1,   -1,   -1,  
     4   -1,   -1,   -1,   -1,   -1,   -1,   -1,   -1,   -1,   -1,  
     5   -1,   -1,    2,   -1,   -1,   -1,   -1,   -1,   -1,   -1,  
     6   -1,   -1,   -1,   -1,   -1,   -1,   -1,    2,   -1,   -1,  
     7    4,    4,    4,   -1,   -1,    4,    4,   -1,   -1,   -2,  
     8    2,    2,   -2,   -2,   -2,   -2,   -2,   -2,   -2,   -2,  
     9    0,    0,    0,   -1,    0,    5,   -2,   -2,   -2,   -2/  
      DATA (iset(i),i=101,200)/ 
     &   -1,    1,   -2,   -2,   -2,   -2,   -2,   -2,   -2,   -2,  
     1    2,    2,    2,    2,   -1,   -1,   -1,   -2,   -2,   -2,  
     2   -1,   -2,   -2,   -2,   -2,   -2,   -2,   -2,   -2,   -2,  
     3   -2,   -2,   -2,   -2,   -2,   -2,   -2,   -2,   -2,   -2,  
     4    1,    1,    1,   -2,   -2,   -2,   -2,   -2,   -2,   -2,  
     5   -2,   -2,   -2,   -2,   -2,   -2,   -2,   -2,   -2,   -2,  
     6    2,   -2,   -2,   -2,   -2,   -2,   -2,   -2,   -2,   -2,  
     7   -2,   -2,   -2,   -2,   -2,   -2,   -2,   -2,   -2,   -2,  
     8   -2,   -2,   -2,   -2,   -2,   -2,   -2,   -2,   -2,   -2,  
     9   -2,   -2,   -2,   -2,   -2,   -2,   -2,   -2,   -2,   -2/  
      DATA ((kfpr(i,j),j=1,2),i=1,50)/  
     &   23,    0,   24,    0,   25,    0,   24,    0,   25,    0,  
     &   24,    0,   23,    0,   25,    0,    0,    0,    0,    0,  
     1    0,    0,    0,    0,   21,   21,   21,   22,   21,   23,  
     1   21,   24,   21,   25,   22,   22,   22,   23,   22,   24,  
     2   22,   25,   23,   23,   23,   24,   23,   25,   24,   24,  
     2   24,   25,   25,   25,    0,   21,    0,   22,    0,   23,  
     3    0,   24,    0,   25,    0,   21,    0,   22,    0,   23,  
     3    0,   24,    0,   25,    0,   21,    0,   22,    0,   23,  
     4    0,   24,    0,   25,    0,   21,    0,   22,    0,   23,  
     4    0,   24,    0,   25,    0,   21,    0,   22,    0,   23/  
      DATA ((kfpr(i,j),j=1,2),i=51,100)/    
     5    0,   24,    0,   25,    0,    0,    0,    0,    0,    0,  
     5    0,    0,    0,    0,    0,    0,    0,    0,    0,    0,  
     6    0,    0,    0,    0,    0,    0,    0,    0,    0,    0,  
     6    0,    0,    0,    0,   21,   21,   24,   24,   22,   24,  
     7   23,   23,   24,   24,   23,   24,   23,   25,   22,   22,  
     7   23,   23,   24,   24,   24,   25,   25,   25,    0,    0,  
     8    0,    0,    0,    0,    0,    0,    0,    0,    0,    0,  
     8    0,    0,    0,    0,    0,    0,    0,    0,    0,    0,  
     9    0,    0,    0,    0,    0,    0,    0,    0,    0,    0,  
     9    0,    0,    0,    0,    0,    0,    0,    0,    0,    0/  
      DATA ((kfpr(i,j),j=1,2),i=101,150)/   
     &   23,    0,   25,    0,    0,    0,    0,    0,    0,    0,  
     &    0,    0,    0,    0,    0,    0,    0,    0,    0,    0,  
     1   21,   25,    0,   25,   21,   25,   22,   22,   22,   23,  
     1   23,   23,   24,   24,    0,    0,    0,    0,    0,    0,  
     2    0,    0,    0,    0,    0,    0,    0,    0,    0,    0,  
     2    0,    0,    0,    0,    0,    0,    0,    0,    0,    0,  
     3    0,    0,    0,    0,    0,    0,    0,    0,    0,    0,  
     3    0,    0,    0,    0,    0,    0,    0,    0,    0,    0,  
     4   32,    0,   37,    0,   40,    0,    0,    0,    0,    0,  
     4    0,    0,    0,    0,    0,    0,    0,    0,    0,    0/  
      DATA ((kfpr(i,j),j=1,2),i=151,200)/   
     5    0,    0,    0,    0,    0,    0,    0,    0,    0,    0,  
     5    0,    0,    0,    0,    0,    0,    0,    0,    0,    0,  
     6    0,   37,    0,    0,    0,    0,    0,    0,    0,    0,  
     6    0,    0,    0,    0,    0,    0,    0,    0,    0,    0,  
     7    0,    0,    0,    0,    0,    0,    0,    0,    0,    0,  
     7    0,    0,    0,    0,    0,    0,    0,    0,    0,    0,  
     8    0,    0,    0,    0,    0,    0,    0,    0,    0,    0,  
     8    0,    0,    0,    0,    0,    0,    0,    0,    0,    0,  
     9    0,    0,    0,    0,    0,    0,    0,    0,    0,    0,  
     9    0,    0,    0,    0,    0,    0,    0,    0,    0,    0/  
      DATA coef/4000*0./    
      DATA (((icol(i,j,k),k=1,2),j=1,4),i=1,40)/    
     1 4,0,3,0,2,0,1,0,3,0,4,0,1,0,2,0,2,0,0,1,4,0,0,3,3,0,0,4,1,0,0,2, 
     2 3,0,0,4,1,4,3,2,4,0,0,3,4,2,1,3,2,0,4,1,4,0,2,3,4,0,3,4,2,0,1,2, 
     3 3,2,1,0,1,4,3,0,4,3,3,0,2,1,1,0,3,2,1,4,1,0,0,2,2,4,3,1,2,0,0,1, 
     4 3,2,1,4,1,4,3,2,4,2,1,3,4,2,1,3,3,4,4,3,1,2,2,1,2,0,3,1,2,0,0,0, 
     5 4,2,1,0,0,0,1,0,3,0,0,3,1,2,0,0,4,0,0,4,0,0,1,2,2,0,0,1,4,4,3,3, 
     6 2,2,1,1,4,4,3,3,3,3,4,4,1,1,2,2,3,2,1,3,1,2,0,0,4,2,1,4,0,0,1,2, 
     7 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0, 
     8 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0, 
     9 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0, 
     & 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0/ 
    
C...Character constants: name of processes. 
      DATA proc(0)/                    'All included subprocesses   '/  
      DATA (proc(i),i=1,20)/    
     1'f + fb -> gamma*/Z0         ',  'f + fb'' -> W+/-             ', 
     2'f + fb -> H0                ',  'gamma + W+/- -> W+/-        ',  
     3'Z0 + Z0 -> H0               ',  'Z0 + W+/- -> W+/-           ',  
     4'                            ',  'W+ + W- -> H0               ',  
     5'                            ',  '                            ',  
     6'f + f'' -> f + f''            ','f + fb -> f'' + fb''          ',    
     7'f + fb -> g + g             ',  'f + fb -> g + gamma         ',  
     8'f + fb -> g + Z0            ',  'f + fb'' -> g + W+/-         ', 
     9'f + fb -> g + H0            ',  'f + fb -> gamma + gamma     ',  
     &'f + fb -> gamma + Z0        ',  'f + fb'' -> gamma + W+/-     '/ 
      DATA (proc(i),i=21,40)/   
     1'f + fb -> gamma + H0        ',  'f + fb -> Z0 + Z0           ',  
     2'f + fb'' -> Z0 + W+/-        ', 'f + fb -> Z0 + H0           ',  
     3'f + fb -> W+ + W-           ',  'f + fb'' -> W+/- + H0        ', 
     4'f + fb -> H0 + H0           ',  'f + g -> f + g              ',  
     5'f + g -> f + gamma          ',  'f + g -> f + Z0             ',  
     6'f + g -> f'' + W+/-          ', 'f + g -> f + H0             ',  
     7'f + gamma -> f + g          ',  'f + gamma -> f + gamma      ',  
     8'f + gamma -> f + Z0         ',  'f + gamma -> f'' + W+/-      ', 
     9'f + gamma -> f + H0         ',  'f + Z0 -> f + g             ',  
     &'f + Z0 -> f + gamma         ',  'f + Z0 -> f + Z0            '/  
      DATA (proc(i),i=41,60)/   
     1'f + Z0 -> f'' + W+/-         ', 'f + Z0 -> f + H0            ',  
     2'f + W+/- -> f'' + g          ', 'f + W+/- -> f'' + gamma      ', 
     3'f + W+/- -> f'' + Z0         ', 'f + W+/- -> f'' + W+/-       ', 
     4'f + W+/- -> f'' + H0         ', 'f + H0 -> f + g             ',  
     5'f + H0 -> f + gamma         ',  'f + H0 -> f + Z0            ',  
     6'f + H0 -> f'' + W+/-         ', 'f + H0 -> f + H0            ',  
     7'g + g -> f + fb             ',  'g + gamma -> f + fb         ',  
     8'g + Z0 -> f + fb            ',  'g + W+/- -> f + fb''         ', 
     9'g + H0 -> f + fb            ',  'gamma + gamma -> f + fb     ',  
     &'gamma + Z0 -> f + fb        ',  'gamma + W+/- -> f + fb''     '/ 
      DATA (proc(i),i=61,80)/   
     1'gamma + H0 -> f + fb        ',  'Z0 + Z0 -> f + fb           ',  
     2'Z0 + W+/- -> f + fb''        ', 'Z0 + H0 -> f + fb           ',  
     3'W+ + W- -> f + fb           ',  'W+/- + H0 -> f + fb''        ', 
     4'H0 + H0 -> f + fb           ',  'g + g -> g + g              ',  
     5'gamma + gamma -> W+ + W-    ',  'gamma + W+/- -> gamma + W+/-',  
     6'Z0 + Z0 -> Z0 + Z0          ',  'Z0 + Z0 -> W+ + W-          ',  
     7'Z0 + W+/- -> Z0 + W+/-      ',  'Z0 + Z0 -> Z0 + H0          ',  
     8'W+ + W- -> gamma + gamma    ',  'W+ + W- -> Z0 + Z0          ',  
     9'W+/- + W+/- -> W+/- + W+/-  ',  'W+/- + H0 -> W+/- + H0      ',  
     &'H0 + H0 -> H0 + H0          ',  '                            '/  
      DATA (proc(i),i=81,100)/  
     1'q + qb -> Q + QB, massive   ',  'g + g -> Q + QB, massive    ',  
     2'                            ',  '                            ',  
     3'                            ',  '                            ',  
     4'                            ',  '                            ',  
     5'                            ',  '                            ',  
     6'Elastic scattering          ',  'Single diffractive          ',  
     7'Double diffractive          ',  'Central diffractive         ',  
     8'Low-pT scattering           ',  'Semihard QCD 2 -> 2         ',  
     9'                            ',  '                            ',  
     &'                            ',  '                            '/  
      DATA (proc(i),i=101,120)/ 
     1'g + g -> gamma*/Z0          ',  'g + g -> H0                 ',  
     2'                            ',  '                            ',  
     3'                            ',  '                            ',  
     4'                            ',  '                            ',  
     5'                            ',  '                            ',  
     6'f + fb -> g + H0            ',  'q + g -> q + H0             ',  
     7'g + g -> g + H0             ',  'g + g -> gamma + gamma      ',  
     8'g + g -> gamma + Z0         ',  'g + g -> Z0 + Z0            ',  
     9'g + g -> W+ + W-            ',  '                            ',  
     &'                            ',  '                            '/  
      DATA (proc(i),i=121,140)/ 
     1'g + g -> f + fb + H0        ',  '                            ',  
     2'                            ',  '                            ',  
     3'                            ',  '                            ',  
     4'                            ',  '                            ',  
     5'                            ',  '                            ',  
     6'                            ',  '                            ',  
     7'                            ',  '                            ',  
     8'                            ',  '                            ',  
     9'                            ',  '                            ',  
     &'                            ',  '                            '/  
      DATA (proc(i),i=141,160)/ 
     1'f + fb -> gamma*/Z0/Z''0     ', 'f + fb'' -> H+/-             ', 
     2'f + fb -> R                 ',  '                            ',  
     3'                            ',  '                            ',  
     4'                            ',  '                            ',  
     5'                            ',  '                            ',  
     6'                            ',  '                            ',  
     7'                            ',  '                            ',  
     8'                            ',  '                            ',  
     9'                            ',  '                            ',  
     &'                            ',  '                            '/  
      DATA (proc(i),i=161,180)/ 
     1'f + g -> f'' + H+/-          ', '                            ',  
     2'                            ',  '                            ',  
     3'                            ',  '                            ',  
     4'                            ',  '                            ',  
     5'                            ',  '                            ',  
     6'                            ',  '                            ',  
     7'                            ',  '                            ',  
     8'                            ',  '                            ',  
     9'                            ',  '                            ',  
     &'                            ',  '                            '/  
      DATA (proc(i),i=181,200)/     20*'                            '/  
    
      END   
    
C*********************************************************************  
    
      SUBROUTINE pykcut(MCUT)   
    
C...Dummy routine, which the user can replace in order to make cuts on  
C...the kinematics on the parton level before the matrix elements are   
C...evaluated and the event is generated. The cross-section estimates   
C...will automatically take these cuts into account, so the given   
C...values are for the allowed phase space region only. MCUT=0 means    
C...that the event has passed the cuts, MCUT=1 that it has failed.  
      common/pypars/mstp(200),parp(200),msti(200),pari(200) 
      SAVE /pypars/ 
    
      mcut=0    
    
      RETURN    
      END   
    
C*********************************************************************  
    
      SUBROUTINE pystfe(KF,X,Q2,XPQ)    
    
C...This is a dummy routine, where the user can introduce an interface  
C...to his own external structure function parametrization. 
C...Arguments in:   
C...KF : 2212 for p, 211 for pi+; isospin conjugation for n and charge  
C...    conjugation for pbar, nbar or pi- is performed by PYSTFU.   
C...X : x value.    
C...Q2 : Q^2 value. 
C...Arguments out:  
C...XPQ(-6:6) : x * f(x,Q2), with index according to KF code,   
C...    except that gluon is placed in 0. Thus XPQ(0) = xg, 
C...    XPQ(1) = xd, XPQ(-1) = xdbar, XPQ(2) = xu, XPQ(-2) = xubar, 
C...    XPQ(3) = xs, XPQ(-3) = xsbar, XPQ(4) = xc, XPQ(-4) = xcbar, 
C...    XPQ(5) = xb, XPQ(-5) = xbbar, XPQ(6) = xt, XPQ(-6) = xtbar. 
C...    
C...One such interface, to the Diemos, Ferroni, Longo, Martinelli   
C...proton structure functions, already comes with the package. What    
C...the user needs here is external files with the three routines   
C...FXG160, FXG260 and FXG360 of the authors above, plus the    
C...interpolation routine FINT, which is part of the CERN library   
C...KERNLIB package. To avoid problems with unresolved external 
C...references, the external calls are commented in the current 
C...version. To enable this option, remove the C* at the beginning  
C...of the relevant lines.  
C...    
C...Alternatively, the routine can be used as an interface to the   
C...structure function evolution program of Tung. This can be achieved  
C...by removing C* at the beginning of some of the lines below. 
      common/ludat1/mstu(200),paru(200),mstj(200),parj(200) 
      SAVE /ludat1/ 
      common/ludat2/kchg(500,3),pmas(500,4),parf(2000),vckm(4,4)    
      SAVE /ludat2/ 
      common/pypars/mstp(200),parp(200),msti(200),pari(200) 
      SAVE /pypars/ 
      dimension xpq(-6:6),xfdflm(9) 
      CHARACTER chdflm(9)*5,header*40   
      DATA chdflm/'UPVAL','DOVAL','GLUON','QBAR ','UBAR ','SBAR ',  
     &'CBAR ','BBAR ','TBAR '/  
      DATA header/'Tung evolution package has been invoked'/    
      DATA init/0/  
    
C...Proton structure functions from Diemoz, Ferroni, Longo, Martinelli. 
C...Allowed variable range 10 GeV2 < Q2 < 1E8 GeV2, 5E-5 < x < .95. 
      IF(mstp(51).GE.11.AND.mstp(51).LE.13.AND.mstp(52).LE.1) THEN  
        xdflm=max(0.51e-4,x)    
        q2dflm=max(10.,min(1e8,q2)) 
        IF(mstp(52).EQ.0) q2dflm=10.    
        DO 100 j=1,9    
        IF(mstp(52).EQ.1.AND.j.EQ.9) THEN   
          q2dflm=q2dflm*(40./pmas(6,1))**2  
          q2dflm=max(10.,min(1e8,q2))   
        ENDIF   
        xfdflm(j)=0.    
C...Remove C* on following three lines to enable the DFLM options.  
C*      IF(MSTP(51).EQ.11) CALL FXG160(XDFLM,Q2DFLM,CHDFLM(J),XFDFLM(J))    
C*      IF(MSTP(51).EQ.12) CALL FXG260(XDFLM,Q2DFLM,CHDFLM(J),XFDFLM(J))    
C*      IF(MSTP(51).EQ.13) CALL FXG360(XDFLM,Q2DFLM,CHDFLM(J),XFDFLM(J))    
  100   CONTINUE    
        IF(x.LT.0.51e-4.AND.abs(parp(51)-1.).GT.0.01) THEN  
          cxs=(0.51e-4/x)**(parp(51)-1.)    
          DO 110 j=1,7  
  110     xfdflm(j)=xfdflm(j)*cxs   
        ENDIF   
        xpq(0)=xfdflm(3)    
        xpq(1)=xfdflm(2)+xfdflm(5)  
        xpq(2)=xfdflm(1)+xfdflm(5)  
        xpq(3)=xfdflm(6)    
        xpq(4)=xfdflm(7)    
        xpq(5)=xfdflm(8)    
        xpq(6)=xfdflm(9)    
        xpq(-1)=xfdflm(5)   
        xpq(-2)=xfdflm(5)   
        xpq(-3)=xfdflm(6)   
        xpq(-4)=xfdflm(7)   
        xpq(-5)=xfdflm(8)   
        xpq(-6)=xfdflm(9)   
    
C...Proton structure function evolution from Wu-Ki Tung: parton 
C...distribution functions incorporating heavy quark mass effects.  
C...Allowed variable range: PARP(52) < Q < PARP(53); PARP(54) < x < 1.  
      ELSE  
        IF(init.EQ.0) THEN  
          i1=0  
          IF(mstp(52).EQ.4) i1=1    
          ihdrn=1   
          nu=mstp(53)   
          i2=mstp(51)   
          IF(mstp(51).GE.11) i2=mstp(51)-3  
          i3=0  
          IF(mstp(52).EQ.3) i3=1    
    
C...Convert to Lambda in CWZ scheme (approximately linear relation).    
          alam=0.75*parp(1) 
          tpms=pmas(6,1)    
          qini=parp(52) 
          qmax=parp(53) 
          xmin=parp(54) 
    
C...Initialize evolution (perform calculation or read results from  
C...file).  
C...Remove C* on following two lines to enable Tung initialization. 
C*        CALL PDFSET(I1,IHDRN,ALAM,TPMS,QINI,QMAX,XMIN,NU,HEADER,  
C*   &    I2,I3,IRET,IRR)   
          init=1    
        ENDIF   
    
C...Put into output array.  
        q=sqrt(q2)  
        DO 200 i=-6,6   
        fixq=0. 
C...Remove C* on following line to enable structure function call.  
C*      FIXQ=MAX(0.,PDF(10,1,I,X,Q,IR)) 
  200   xpq(i)=x*fixq   
    
C...Change order of u and d quarks from Tung to PYTHIA convention.  
        xps=xpq(1)  
        xpq(1)=xpq(2)   
        xpq(2)=xps  
        xps=xpq(-1) 
        xpq(-1)=xpq(-2) 
        xpq(-2)=xps 
      ENDIF 
    
      RETURN    
      END