Filling of empty histogams corrected, Disp2 is not part of Disp any more - corrected

[u/mrichter/AliRoot.git] / TAmpt / AMPT / hipyset1.35.f

c.................... 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*********************************************************************  
    
cms
cms   gsfs 8/2009 Renamed common block PYINT4A due to conflict with something in CMSSW
cms 
      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/LUJETSA/N,K(9000,5),P(9000,5),V(9000,5)
      SAVE /LUJETSA/ 
      COMMON/LUDAT1A/MSTU(200),PARU(200),MSTJ(200),PARJ(200) 
      SAVE /LUDAT1A/ 
      COMMON/LUDAT2A/KCHG(500,3),PMAS(500,4),PARF(2000),VCKM(4,4)    
      SAVE /LUDAT2A/ 
    
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 LUJETSA 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 LUGIVE(CHIN)   
    
C...Purpose: to set values of commonblock variables.    
      COMMON/LUJETSA/N,K(9000,5),P(9000,5),V(9000,5)
      SAVE /LUJETSA/ 
      COMMON/LUDAT1A/MSTU(200),PARU(200),MSTJ(200),PARJ(200) 
      SAVE /LUDAT1A/ 
      COMMON/LUDAT2A/KCHG(500,3),PMAS(500,4),PARF(2000),VCKM(4,4)    
      SAVE /LUDAT2A/ 
      COMMON/LUDAT3A/MDCY(500,3),MDME(2000,2),BRAT(2000),KFDP(2000,5)    
      SAVE /LUDAT3A/ 
      COMMON/LUDAT4A/CHAF(500)   
      CHARACTER CHAF*8  
      SAVE /LUDAT4A/ 
      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/LUJETSA/N,K(9000,5),P(9000,5),V(9000,5)
      SAVE /LUJETSA/ 
      COMMON/LUDAT1A/MSTU(200),PARU(200),MSTJ(200),PARJ(200) 
      SAVE /LUDAT1A/ 
      COMMON/LUDAT2A/KCHG(500,3),PMAS(500,4),PARF(2000),VCKM(4,4)    
      SAVE /LUDAT2A/ 
      COMMON/LUDAT3A/MDCY(500,3),MDME(2000,2),BRAT(2000),KFDP(2000,5)    
      SAVE /LUDAT3A/ 
      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  
clin-4/2008 break up compound IF statements:
c        IF(MSTJ(21).GE.1.AND.MDCY(KC,1).GE.1.AND.(MSTJ(51).LE.0.OR.MBE. 
c     &  EQ.2.OR.PMAS(KC,2).GE.PARJ(91).OR.IABS(K(IP,2)).EQ.311))    
c     &  CALL LUDECY(IP) 
         if(MSTJ(21).GE.1.AND.MDCY(KC,1).GE.1) then
            if(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) 
         endif
c    
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) 
clin-8/19/02 avoid actual argument in common blocks of LUSHOW:
c          CALL LUSHOW(IP1,-3,P(IP,5))   
          pip5=P(IP,5)
          CALL LUSHOW(IP1,-3,pip5)   
          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) then
           CALL LUSTRF(IP)  
        endif
        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 LUJETSA 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 LUJETSA')   
      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')  
c      IF(MCONS.EQ.1.AND.PDEV.GT.PARU(11)) then
c         CALL LUERRM(15,   
c     &'(LUEXEC:) four-momentum was not conserved')  
c         write(6,*) 'PS1,2=',PS(1,1),PS(1,2),PS(1,3),PS(1,4),
c     1        '*',PS(2,1),PS(2,2),PS(2,3),PS(2,4)
c      endif

      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/LUJETSA/N,K(9000,5),P(9000,5),V(9000,5)
      SAVE /LUJETSA/ 
      COMMON/LUDAT1A/MSTU(200),PARU(200),MSTJ(200),PARJ(200) 
      SAVE /LUDAT1A/ 
      COMMON/LUDAT2A/KCHG(500,3),PMAS(500,4),PARF(2000),VCKM(4,4)    
      SAVE /LUDAT2A/ 
      COMMON/LUDAT3A/MDCY(500,3),MDME(2000,2),BRAT(2000),KFDP(2000,5)    
      SAVE /LUDAT3A/ 
      DIMENSION DPS(5),DPC(5),UE(3) 
    
      ic1=0
      ic2=0
      kci=0
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 LUJETSA') 
          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 thresh.  
      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)=dble(P(I,J))
        MSTJ(93)=1  
        DPS(5)=dble(ULMASS(K(I,2)))
      ELSEIF(K(I,1).EQ.2) THEN  
        DO 160 J=1,4    
  160   DPS(J)=DPS(J)+dble(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)+dble(P(I,J))
        MSTJ(93)=1  
        DPS(5)=DPS(5)+dble(ULMASS(K(I,2)))
        PD=sngl(SQRT(MAX(0D0,DPS(4)**2
     1       -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=sngl(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)=sngl(DPC(1))
      P(N+1,2)=sngl(DPC(2))  
      P(N+1,3)=sngl(DPC(3))  
      P(N+1,4)=sngl(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.02d0*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=sngl(DPC(4))*P(I,4)-sngl(DPC(1))*P(I,1)
     1     -sngl(DPC(2))*P(I,2)-sngl(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)*sngl(DPC(J))-HK2*P(IR,J)  
      P(IR,J)=(1.+HK2)*P(IR,J)-HK1*sngl(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)=0d0
      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)+dble(ULMASS(K(I,2)))
      ENDIF 
      DO 340 J=1,4  
  340 DPS(J)=DPS(J)+dble(P(I,J))

clin-4/12/01:
c     np: # of partons, KFN: number of quarks and diquarks, 
c     KC=0 for color singlet system, -1 for quarks and anti-diquarks, 
c     1 for quarks and anti-diquarks, and 2 for gluons:
      IF(K(I,1).EQ.1) THEN  
clin-4/12/01     end of color singlet system.
        IF(NP.NE.1.AND.(KFN.EQ.1.OR.KFN.GE.3.OR.KQS.NE.0)) CALL 
     &  LUERRM(2,'(LUPREP:) unphysical flavour combination')    

clin-4/16/01: 'jet system' should be defined as np.ne.2:
c        IF(NP.NE.1.AND.DPS(4)**2-DPS(1)**2-DPS(2)**2-DPS(3)**2.LT.  
c     &  (0.9*PARJ(32)+DPS(5))**2) CALL LUERRM(3,    
c     &  '(LUPREP:) too small mass in jet system')   
        IF(NP.NE.2.AND.DPS(4)**2-DPS(1)**2-DPS(2)**2-DPS(3)**2.LT.  
     &  (0.9d0*dble(PARJ(32))+DPS(5))**2) then 
           CALL LUERRM(3,    
     &  '(LUPREP:) too small mass in jet system')   
           write (6,*) 'DPS(1-5),KI1-5=',DPS(1),DPS(2),DPS(3),DPS(4),
     1 DPS(5),'*',K(I,1),K(I,2),K(I,3),K(I,4),K(I,5)
        endif

        NP=0    
        KFN=0   
        KQS=0   
        DO 350 J=1,5    
  350   DPS(J)=0d0
      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/LUJETSA/N,K(9000,5),P(9000,5),V(9000,5)
      SAVE /LUJETSA/ 
      COMMON/LUDAT1A/MSTU(200),PARU(200),MSTJ(200),PARJ(200) 
      SAVE /LUDAT1A/ 
      COMMON/LUDAT2A/KCHG(500,3),PMAS(500,4),PARF(2000),VCKM(4,4)    
      SAVE /LUDAT2A/ 
      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)   

      ir=0
      in3=0
      jr=0
      prev=0
    
C...Reset counters. Identify parton system. 
      MSTJ(91)=0    
      NSAV=N    
      NP=0  
      KQSUM=0   
      DO 100 J=1,5  
  100 DPS(J)=0d0 
      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 LUJETSA')   
        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)+dble(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)+dble(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)=dble(0.5*P(IS1,J))
      IF(IS.EQ.1) DP(1,J)=dble(P(IS1,J))
      DP(2,J)=dble(0.5*P(IS2,J))
  250 IF(IS.EQ.NS) DP(2,J)=-dble(PJU(IU,J))
      IF(IS.EQ.NS) DP(2,4)=dble(
     1     SQRT(PJU(IU,1)**2+PJU(IU,2)**2+PJU(IU,3)**2))
      IF(IS.EQ.NS) DP(2,5)=0d0   
      DP(3,5)=DFOUR(1,1)    
      DP(4,5)=DFOUR(2,2)    
      DHKC=DFOUR(1,2)   
      IF(DP(3,5)+2d0*DHKC+DP(4,5).LE.0d0) 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.5d0*((DP(4,5)+DHKC)/DHKS-1d0) 
      DHK2=0.5d0*((DP(3,5)+DHKC)/DHKS-1d0) 
      IN1=N+NR+4*IS-3   
      P(IN1,5)=sngl(SQRT(DP(3,5)+2d0*DHKC+DP(4,5)))
      DO 260 J=1,4  
      P(IN1,J)=sngl((1d0+DHK1)*DP(1,J)-DHK2*DP(2,J))
  260 P(IN1+1,J)=sngl((1d0+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)=dble(P(IN(4),J))
      DP(2,J)=dble(P(IN(4)+1,J))
      DP(3,J)=0d0    
  300 DP(4,J)=0d0    
      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)=1d0    
      IF(DP(5,1)**2.GT.DP(5,2)**2+DP(5,3)**2) DP(3,3)=1d0    
      IF(DP(5,2)**2.LE.DP(5,1)**2+DP(5,3)**2) DP(4,2)=1d0    
      IF(DP(5,2)**2.GT.DP(5,1)**2+DP(5,3)**2) DP(4,3)=1d0    
      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)=sngl(DP(3,J))
  310 P(IN(6)+1,J)=sngl(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 LUJETSA')   
        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)=dble(P(IN(1),J))
        DP(2,J)=dble(P(IN(2),J))
        DP(3,J)=0d0  
  370   DP(4,J)=0d0  
        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)=1d0  
        IF(DP(5,1)**2.GT.DP(5,2)**2+DP(5,3)**2) DP(3,3)=1d0  
        IF(DP(5,2)**2.LE.DP(5,1)**2+DP(5,3)**2) DP(4,2)=1d0  
        IF(DP(5,2)**2.GT.DP(5,1)**2+DP(5,3)**2) DP(4,3)=1d0  
        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)=sngl(DP(3,J))
  380   P(IN(3)+1,J)=sngl(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)=0d0 
      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)=dble(FOUR(I,I))
      DHM(2)=dble(2.*FOUR(I,IN(1)))   
      DHM(3)=dble(2.*FOUR(I,IN(2)))  
      DHM(4)=dble(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=dble(2.*FOUR(IN1,IN2))
      DHG(1)=DHG(1)+dble(P(IN1+2,1)*P(IN2+2,1))*DHC   
      IF(IN1.EQ.IN(1)) DHG(2)=DHG(2)-dble(P(IN2+2,1))*DHC 
      IF(IN2.EQ.IN(2)) DHG(3)=DHG(3)+dble(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)*(dble(GAM(3))-DHG(1))-DHM(2)*DHG(3)-DHG(4)* 
     &(dble(P(I,5))**2-DHM(1))+DHG(2)*DHM(3)  
      DHS3=DHM(2)*(dble(GAM(3))-DHG(1))
     1     -DHG(2)*(dble(P(I,5))**2-DHM(1)) 
      P(IN(2)+2,4)=0.5*sngl(SQRT(MAX(0D0,DHS2**2-4d0*DHS1*DHS3))
     &     /ABS(DHS1)-DHS2/DHS1)
      IF(DHM(2)+DHM(4)*dble(P(IN(2)+2,4)).LE.0d0) GOTO 270 
      P(IN(1)+2,4)=(P(I,5)**2-sngl(DHM(1))-sngl(DHM(3))*P(IN(2)+2,4))/  
     &(sngl(DHM(2))+sngl(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)=dble(P(IS1,J))
      IF(IABS(K(IS1,2)).EQ.21) DP(1,J)=0.5d0*DP(1,J)  
      IF(IS1.EQ.MJU(1)) DP(1,J)=dble(PJS(1,J)-PJS(3,J))
      DP(2,J)=dble(P(IS2,J))
      IF(IABS(K(IS2,2)).EQ.21) DP(2,J)=0.5d0*DP(2,J)  
  530 IF(IS2.EQ.MJU(2)) DP(2,J)=dble(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.d0*DHKC+DP(4,5).LE.0.d0) 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.5d0*((DP(4,5)+DHKC)/DHKS-1.d0) 
      DHK2=0.5d0*((DP(3,5)+DHKC)/DHKS-1.d0) 
      IN1=N+NR+4*IS-3   
      P(IN1,5)=SQRT(sngl(DP(3,5)+2.d0*DHKC+DP(4,5)))
      DO 540 J=1,4  
      P(IN1,J)=sngl((1.d0+DHK1)*DP(1,J)-DHK2*DP(2,J))
  540 P(IN1+1,J)=sngl((1.d0+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)=dble(P(IN1,J))
        DP(2,J)=dble(P(IN1+1,J))
        DP(3,J)=0.d0
  610   DP(4,J)=0.d0
        DP(1,4)=DSQRT(DP(1,1)**2+DP(1,2)**2+DP(1,3)**2)  
        DP(2,4)=DSQRT(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.d0
        IF(DP(5,1)**2.GT.DP(5,2)**2+DP(5,3)**2) DP(3,3)=1.d0
        IF(DP(5,2)**2.LE.DP(5,1)**2+DP(5,3)**2) DP(4,2)=1.d0
        IF(DP(5,2)**2.GT.DP(5,1)**2+DP(5,3)**2) DP(4,3)=1.d0
        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)=sngl(DP(3,J))
  620   P(IN3+1,J)=sngl(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 LUJETSA')   
        IF(MSTU(21).GE.1) RETURN    
      ENDIF 
      JT=int(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)=dble(P(IN(1),J))
        DP(2,J)=dble(P(IN(2),J))
        DP(3,J)=0.d0
  720   DP(4,J)=0.d0
        DP(1,4)=DSQRT(DP(1,1)**2+DP(1,2)**2+DP(1,3)**2)  
        DP(2,4)=DSQRT(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.d0
        IF(DP(5,1)**2.GT.DP(5,2)**2+DP(5,3)**2) DP(3,3)=1.d0
        IF(DP(5,2)**2.LE.DP(5,1)**2+DP(5,3)**2) DP(4,2)=1.d0
        IF(DP(5,2)**2.GT.DP(5,1)**2+DP(5,3)**2) DP(4,3)=1.d0
        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)=sngl(DP(3,J))
  730   P(IN(3)+1,J)=sngl(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.d0
      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)=dble(FOUR(I,I))
      DHM(2)=dble(2.*FOUR(I,IN(1)))  
      DHM(3)=dble(2.*FOUR(I,IN(2)))
      DHM(4)=dble(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=dble(2.*FOUR(IN1,IN2))
      DHG(1)=DHG(1)+dble(P(IN1+2,JT)*P(IN2+2,JT))*DHC 
      IF(IN1.EQ.IN(1)) DHG(2)=DHG(2)-dble(float(JS)*P(IN2+2,JT))*DHC 
      IF(IN2.EQ.IN(2)) DHG(3)=DHG(3)+dble(float(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)*(dble(GAM(3))-DHG(1))-DHM(JT+1)*DHG(JR+1)-DHG(4)*   
     &(dble(P(I,5))**2-DHM(1))+DHG(JT+1)*DHM(JR+1)    
      DHS3=DHM(JT+1)*(dble(GAM(3))-DHG(1))-DHG(JT+1)
     &     *(dble(P(I,5))**2-DHM(1))   
      P(IN(JR)+2,4)=0.5*sngl((SQRT(MAX(0D0,DHS2**2-4.d0*DHS1*DHS3)))
     &/ABS(DHS1)-DHS2/DHS1)
      IF(DHM(JT+1)+DHM(4)*dble(P(IN(JR)+2,4)).LE.0.d0) GOTO 550 
      P(IN(JT)+2,4)=(P(I,5)**2-sngl(DHM(1))-sngl(DHM(JR+1))
     &     *P(IN(JR)+2,4))/(sngl(DHM(JT+1))+sngl(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=dble(FOUR(IN(3*JQ+1),IN(3*JQ+2)))
      DHR1=dble(FOUR(N+NRS,IN(3*JQ+2)))/DHC12
      DHR2=dble(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*(sngl(DHR1)*(FA+FB)*P(IN(3*JQ+1),J)+  
     &sngl(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)=sngl(DPS(J))
  840 V(NSAV,J)=V(IP,J) 
      P(NSAV,5)=SQRT(sngl(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/LUJETSA/N,K(9000,5),P(9000,5),V(9000,5)
      SAVE /LUJETSA/ 
      COMMON/LUDAT1A/MSTU(200),PARU(200),MSTJ(200),PARJ(200) 
      SAVE /LUDAT1A/ 
      COMMON/LUDAT2A/KCHG(500,3),PMAS(500,4),PARF(2000),VCKM(4,4)    
      SAVE /LUDAT2A/ 
      DIMENSION DPS(5),PSI(4),NFI(3),NFL(3),IFET(3),KFLF(3),    
     &KFLO(2),PXO(2),PYO(2),WO(2)   

      pw=0.
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.d0
      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)+dble(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 LUJETSA')   
        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+int((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)=sngl(DPS(J))
  500 V(NSAV,J)=V(IP,J) 
      P(NSAV,5)=SQRT(sngl(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/LUJETSA/N,K(9000,5),P(9000,5),V(9000,5)
      SAVE /LUJETSA/ 
      COMMON/LUDAT1A/MSTU(200),PARU(200),MSTJ(200),PARJ(200) 
      SAVE /LUDAT1A/ 
      COMMON/LUDAT2A/KCHG(500,3),PMAS(500,4),PARF(2000),VCKM(4,4)    
      SAVE /LUDAT2A/ 
      COMMON/LUDAT3A/MDCY(500,3),MDME(2000,2),BRAT(2000),KFDP(2000,5)    
      SAVE /LUDAT3A/ 
      DIMENSION VDCY(4),KFLO(4),KFL1(4),PV(10,5),RORD(10),UE(3),BE(3),  
     &WTCOR(10) 
clin-2/18/03 for resonance decay in hadron cascade:
      common/resdcy/NSAV,iksdcy
      SAVE /resdcy/
      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. 

      idc=0
      pqt=0.
      hatu=0.
      hmp1=0.
      im=0
      kfam=0
      wtmax=0.
      pmes=0.
      pmst=0.
      wt=0.
      pmr=0.

      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. 
clin  110 NOPE=0    
      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=int(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/LUDAT1A/MSTU(200),PARU(200),MSTJ(200),PARJ(200) 
      SAVE /LUDAT1A/ 
      COMMON/LUDAT2A/KCHG(500,3),PMAS(500,4),PARF(2000),VCKM(4,4)    
      SAVE /LUDAT2A/ 
    
      par3m=0.
      par4m=0.
      pardm=0.
      pars0=0.
      pars1=0.
      pars2=0.
      parsm=0.
      kmul=0
      ktab3=0

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/LUDAT1A/MSTU(200),PARU(200),MSTJ(200),PARJ(200) 
      SAVE /LUDAT1A/ 
    
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/LUDAT1A/MSTU(200),PARU(200),MSTJ(200),PARJ(200) 
      SAVE /LUDAT1A/ 
    
      zdiv=0.
      fint=0.
      zdivc=0.

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/LUJETSA/N,K(9000,5),P(9000,5),V(9000,5)
      SAVE /LUJETSA/ 
      COMMON/LUDAT1A/MSTU(200),PARU(200),MSTJ(200),PARJ(200) 
      SAVE /LUDAT1A/ 
      COMMON/LUDAT2A/KCHG(500,3),PMAS(500,4),PARF(2000),VCKM(4,4)    
      SAVE /LUDAT2A/ 
      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)   

      npa=0
      kflm=0
      pem=0.
      pmed=0.
      fbre=0.
      pm2=0.
      ped=0.
      zm=0.
      pa1s=0.
      pa2s=0.
      pa3s=0.
      pts=0.
      pzm=0.
      pmls=0.
      pt=0.
      hazip=0.
      hazic=0.
    
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 LUJETSA')   
        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 LUJETSA')   
        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)=dble(COS(THE)*COS(PHI)*P(I,1)-SIN(PHI)*P(I,2)+ 
     &  SIN(THE)*COS(PHI)*P(I,3))
        DP(2)=dble(COS(THE)*SIN(PHI)*P(I,1)+COS(PHI)*P(I,2)+ 
     &  SIN(THE)*SIN(PHI)*P(I,3))
        DP(3)=dble(-SIN(THE)*P(I,1)+COS(THE)*P(I,3))
        DP(4)=dble(P(I,4))
        DBP=dble(BEX)*DP(1)+dble(BEY)*DP(2)+dble(BEZ)*DP(3)   
        DGABP=dble(GA)*(dble(GA)*DBP/(1D0+dble(GA))+DP(4))    
        P(I,1)=sngl(DP(1)+DGABP*dble(BEX))
        P(I,2)=sngl(DP(2)+DGABP*dble(BEY))
        P(I,3)=sngl(DP(3)+DGABP*dble(BEZ))
  350   P(I,4)=GA*sngl(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)=dble(P(IM,J))
        DPT(2,J)=dble(P(IAU,J))  
  360   DPT(3,J)=dble(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)=DSQRT(DPT(4,1)**2+DPT(4,2)**2+DPT(4,3)**2)  
        DPT(5,4)=DSQRT(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=sngl((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 LUJETSA')   
        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/LUJETSA/N,K(9000,5),P(9000,5),V(9000,5)
      SAVE /LUJETSA/ 
      COMMON/LUDAT1A/MSTU(200),PARU(200),MSTJ(200),PARJ(200) 
      SAVE /LUDAT1A/ 
      DIMENSION DPS(4),KFBE(9),NBE(0:9),BEI(100)    
      DATA KFBE/211,-211,111,321,-321,130,310,221,331/  
    
      pmhq=0.
      qdel=0.
      nbin=0
      beex=0.
      bert=0.

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.d0
      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)+dble(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 LUJETSA')   
        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=int(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/LUDAT1A/MSTU(200),PARU(200),MSTJ(200),PARJ(200) 
      SAVE /LUDAT1A/ 
      COMMON/LUDAT2A/KCHG(500,3),PMAS(500,4),PARF(2000),VCKM(4,4)    
      SAVE /LUDAT2A/ 

      pmspl=0.
    
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/LUDAT1A/MSTU(200),PARU(200),MSTJ(200),PARJ(200) 
      SAVE /LUDAT1A/ 
      COMMON/LUDAT2A/KCHG(500,3),PMAS(500,4),PARF(2000),VCKM(4,4)    
      SAVE /LUDAT2A/ 
      COMMON/LUDAT4A/CHAF(500)   
      CHARACTER CHAF*8  
      SAVE /LUDAT4A/ 
      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/LUDAT2A/KCHG(500,3),PMAS(500,4),PARF(2000),VCKM(4,4)    
      SAVE /LUDAT2A/ 
    
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/LUDAT2A/KCHG(500,3),PMAS(500,4),PARF(2000),VCKM(4,4)    
      SAVE /LUDAT2A/ 
    
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/LUJETSA/N,K(9000,5),P(9000,5),V(9000,5)
      SAVE /LUJETSA/ 
      COMMON/LUDAT1A/MSTU(200),PARU(200),MSTJ(200),PARJ(200) 
      SAVE /LUDAT1A/ 
      CHARACTER CHMESS*(*)  

      write (6,*) 'merr,chmess=',merr,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/LUDAT1A/MSTU(200),PARU(200),MSTJ(200),PARJ(200) 
      SAVE /LUDAT1A/ 
      COMMON/LUDAT2A/KCHG(500,3),PMAS(500,4),PARF(2000),VCKM(4,4)    
      SAVE /LUDAT2A/ 
    
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/LUDAT1A/MSTU(200),PARU(200),MSTJ(200),PARJ(200) 
      SAVE /LUDAT1A/ 
    
      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*********************************************************************  
c$$$    
c$$$      FUNCTION RLU(IDUM)    
c$$$    
c$$$C...Purpose: to generate random numbers uniformly distributed between   
c$$$C...0 and 1, excluding the endpoints.   
c$$$      COMMON/LUDATRA/MRLU(6),RRLU(100)   
c$$$      SAVE /LUDATRA/ 
c$$$      EQUIVALENCE (MRLU1,MRLU(1)),(MRLU2,MRLU(2)),(MRLU3,MRLU(3)),  
c$$$     &(MRLU4,MRLU(4)),(MRLU5,MRLU(5)),(MRLU6,MRLU(6)),  
c$$$     &(RRLU98,RRLU(98)),(RRLU99,RRLU(99)),(RRLU00,RRLU(100))    
c$$$    
c$$$C...Initialize generation from given seed.  
c$$$      IDUM=IDUM
c$$$      IF(MRLU2.EQ.0) THEN   
c$$$        IJ=MOD(MRLU1/30082,31329)   
c$$$        KL=MOD(MRLU1,30082) 
c$$$        I=MOD(IJ/177,177)+2 
c$$$        J=MOD(IJ,177)+2 
c$$$        K=MOD(KL/169,178)+1 
c$$$        L=MOD(KL,169)   
c$$$        DO 110 II=1,97  
c$$$        S=0.    
c$$$        T=0.5   
c$$$        DO 100 JJ=1,24  
c$$$        M=MOD(MOD(I*J,179)*K,179)   
c$$$        I=J 
c$$$        J=K 
c$$$        K=M 
c$$$        L=MOD(53*L+1,169)   
c$$$        IF(MOD(L*M,64).GE.32) S=S+T 
c$$$  100   T=0.5*T 
c$$$  110   RRLU(II)=S  
c$$$        TWOM24=1.   
c$$$        DO 120 I24=1,24 
c$$$  120   TWOM24=0.5*TWOM24   
c$$$        RRLU98=362436.*TWOM24   
c$$$        RRLU99=7654321.*TWOM24  
c$$$        RRLU00=16777213.*TWOM24 
c$$$        MRLU2=1 
c$$$        MRLU3=0 
c$$$        MRLU4=97    
c$$$        MRLU5=33    
c$$$      ENDIF 
c$$$    
c$$$C...Generate next random number.    
c$$$  130 RUNI=RRLU(MRLU4)-RRLU(MRLU5)  
c$$$      IF(RUNI.LT.0.) RUNI=RUNI+1.   
c$$$      RRLU(MRLU4)=RUNI  
c$$$      MRLU4=MRLU4-1 
c$$$      IF(MRLU4.EQ.0) MRLU4=97   
c$$$      MRLU5=MRLU5-1 
c$$$      IF(MRLU5.EQ.0) MRLU5=97   
c$$$      RRLU98=RRLU98-RRLU99  
c$$$      IF(RRLU98.LT.0.) RRLU98=RRLU98+RRLU00 
c$$$      RUNI=RUNI-RRLU98  
c$$$      IF(RUNI.LT.0.) RUNI=RUNI+1.   
c$$$      IF(RUNI.LE.0.OR.RUNI.GE.1.) GOTO 130  
c$$$    
c$$$C...Update counters. Random number to output.   
c$$$      MRLU3=MRLU3+1 
c$$$      IF(MRLU3.EQ.1000000000) THEN  
c$$$        MRLU2=MRLU2+1   
c$$$        MRLU3=0 
c$$$      ENDIF 
c$$$      RLU=RUNI  
c$$$    
c$$$      RETURN    
c$$$      END   
    
C*********************************************************************  
    
      SUBROUTINE LUROBO(THE,PHI,BEX,BEY,BEZ)    
    
C...Purpose: to perform rotations and boosts.   
      IMPLICIT DOUBLE PRECISION(D)  
      COMMON/LUJETSA/N,K(9000,5),P(9000,5),V(9000,5)
      SAVE /LUJETSA/ 
      COMMON/LUDAT1A/MSTU(200),PARU(200),MSTJ(200),PARJ(200) 
      SAVE /LUDAT1A/ 
      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=dble(BEX)
      DBY=dble(BEY)
      DBZ=dble(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 LUJETSA 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)=dble(P(I,J))
  140   DV(J)=dble(V(I,J))
        DBP=DBX*DP(1)+DBY*DP(2)+DBZ*DP(3)   
        DGABP=DGA*(DGA*DBP/(1D0+DGA)+DP(4)) 
        P(I,1)=sngl(DP(1)+DGABP*DBX)
        P(I,2)=sngl(DP(2)+DGABP*DBY) 
        P(I,3)=sngl(DP(3)+DGABP*DBZ) 
        P(I,4)=sngl(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)=sngl(DV(1)+DGABV*DBX) 
        V(I,2)=sngl(DV(2)+DGABV*DBY) 
        V(I,3)=sngl(DV(3)+DGABV*DBZ) 
        V(I,4)=sngl(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/LUJETSA/N,K(9000,5),P(9000,5),V(9000,5)
      SAVE /LUJETSA/ 
      COMMON/LUDAT1A/MSTU(200),PARU(200),MSTJ(200),PARJ(200) 
      SAVE /LUDAT1A/ 
      DIMENSION ROT(3,3),PR(3),VR(3),DP(4),DV(4)    
    
      DV(1)=DV(1)
      VR(1)=VR(1)
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=dble(BEX)
      DBY=dble(BEY) 
      DBZ=dble(BEZ)  
    
C...Check range of rotation/boost.  
      IF(IMIN.GT.MSTU(4).OR.IMAX.GT.MSTU(4)) THEN   
        CALL LUERRM(11,'(LUROBO:) range outside LUJETSA 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)=dble(P(I,J))
        DBP=DBX*DP(1)+DBY*DP(2)+DBZ*DP(3)   
        DGABP=DGA*(DGA*DBP/(1D0+DGA)+DP(4)) 
        P(I,1)=sngl(DP(1)+DGABP*DBX)
        P(I,2)=sngl(DP(2)+DGABP*DBY) 
        P(I,3)=sngl(DP(3)+DGABP*DBZ) 
        P(I,4)=sngl(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/LUJETSA/N,K(9000,5),P(9000,5),V(9000,5)
      SAVE /LUJETSA/ 
      COMMON/LUDAT1A/MSTU(200),PARU(200),MSTJ(200),PARJ(200) 
      SAVE /LUDAT1A/ 
      COMMON/LUDAT2A/KCHG(500,3),PMAS(500,4),PARF(2000),VCKM(4,4)    
      SAVE /LUDAT2A/ 
      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 LUJETSA commonblock.   
      ELSEIF(MEDIT.EQ.21) THEN  
        IF(2*N.GE.MSTU(4)) THEN 
          CALL LUERRM(11,'(LUEDIT:) no more memory left in LUJETSA') 
          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 LUJETSA 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 LUJETSA 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=int(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=int(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/LUJETSA/N,K(9000,5),P(9000,5),V(9000,5)
      SAVE /LUJETSA/ 
      COMMON/LUDAT1A/MSTU(200),PARU(200),MSTJ(200),PARJ(200) 
      SAVE /LUDAT1A/ 
      COMMON/LUDAT2A/KCHG(500,3),PMAS(500,4),PARF(2000),VCKM(4,4)    
      SAVE /LUDAT2A/ 
      COMMON/LUDAT3A/MDCY(500,3),MDME(2000,2),BRAT(2000),KFDP(2000,5)    
      SAVE /LUDAT3A/ 
      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/'(())',' ','()','!!','<>','==','(==)'/    
    
      CHMO(1)=CHMO(1)
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).   
clin 1000 FORMAT(///20X,'The Lund Monte Carlo - JETSET version ',I1,'.',I1/ 
clin     &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*********************************************************************  
    
      FUNCTION PLU(I,J) 
    
C...Purpose: to provide various real-valued event related data. 
      COMMON/LUJETSA/N,K(9000,5),P(9000,5),V(9000,5)
      SAVE /LUJETSA/ 
      COMMON/LUDAT1A/MSTU(200),PARU(200),MSTJ(200),PARJ(200) 
      SAVE /LUDAT1A/ 
      COMMON/LUDAT2A/KCHG(500,3),PMAS(500,4),PARF(2000),VCKM(4,4)    
      SAVE /LUDAT2A/ 
      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*********************************************************************  
    
      BLOCK DATA LUDATA 
    
C...Purpose: to give default values to parameters and particle and  
C...decay data. 
      COMMON/LUDAT1A/MSTU(200),PARU(200),MSTJ(200),PARJ(200) 
      SAVE /LUDAT1A/ 
      COMMON/LUDAT2A/KCHG(500,3),PMAS(500,4),PARF(2000),VCKM(4,4)    
      SAVE /LUDAT2A/ 
      COMMON/LUDAT3A/MDCY(500,3),MDME(2000,2),BRAT(2000),KFDP(2000,5)    
      SAVE /LUDAT3A/ 
      COMMON/LUDAT4A/CHAF(500)   
      CHARACTER CHAF*8  
      SAVE /LUDAT4A/ 
      COMMON/LUDATRA/MRLU(6),RRLU(100)   
      SAVE /LUDATRA/ 
    
C...LUDAT1A, 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...LUDAT2A, 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...LUDAT3A, 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...LUDAT4A, 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...LUDATRA, with initial values for the random number generator.    
      DATA MRLU/19780503,0,0,97,33,0/   
    
      END   
      SUBROUTINE PYINITA(FRAME,BEAM,TARGET,WIN)  
    
C...Initializes the generation procedure; finds maxima of the   
C...differential cross-sections to be used for weighting.   
      COMMON/LUDAT1A/MSTU(200),PARU(200),MSTJ(200),PARJ(200) 
      SAVE /LUDAT1A/ 
      COMMON/LUDAT2A/KCHG(500,3),PMAS(500,4),PARF(2000),VCKM(4,4)    
      SAVE /LUDAT2A/ 
      COMMON/LUDAT3A/MDCY(500,3),MDME(2000,2),BRAT(2000),KFDP(2000,5)    
      SAVE /LUDAT3A/ 
      COMMON/LUDAT4A/CHAF(500)   
      CHARACTER CHAF*8  
      SAVE /LUDAT4A/ 
      COMMON/PYSUBSA/MSEL,MSUB(200),KFIN(2,-40:40),CKIN(200) 
      SAVE /PYSUBSA/ 
      COMMON/PYPARSA/MSTP(200),PARP(200),MSTI(200),PARI(200) 
      SAVE /PYPARSA/ 
      COMMON/PYINT1A/MINT(400),VINT(400) 
      SAVE /PYINT1A/ 
      COMMON/PYINT2A/ISET(200),KFPR(200,2),COEF(200,20),ICOL(40,4,2) 
      SAVE /PYINT2A/ 
      COMMON/PYINT5A/NGEN(0:200,3),XSEC(0:200,3) 
      SAVE /PYINT5A/ 
      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'/   

      CHMO(1)=CHMO(1)
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 PYINKIA(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 PYINREA   
    
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 PYXTOTA 
    
C...Maxima of differential cross-sections.  
      IF(MSTP(121).LE.0) CALL PYMAXIA    
    
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 PYMULTA(1) 
C      IF(MSTP(122).GE.1) WRITE(MSTU(11),1600)  
    
C...Formats for initialization information. 
clin 1000 FORMAT(///20X,'The Lund Monte Carlo - PYTHIA version ',I1,'.',I1/ 
clin     &20X,'**  Last date of change:  ',I2,1X,A3,1X,I4,'  **'/)  
clin 1100 FORMAT('1',18('*'),1X,'PYINITA: initialization of PYTHIA ',    
clin     &'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.')  
clin 1600 FORMAT(/1X,22('*'),1X,'PYINITA: initialization completed',1X,  
clin     &22('*'))  
    
      RETURN    
      END   
    
C*********************************************************************  
    
      SUBROUTINE PYTHIAA 
    
C...Administers the generation of a high-pt event via calls to a number 
C...of subroutines; also computes cross-sections.   
      COMMON/LUJETSA/N,K(9000,5),P(9000,5),V(9000,5)
      SAVE /LUJETSA/ 
      COMMON/LUDAT1A/MSTU(200),PARU(200),MSTJ(200),PARJ(200) 
      SAVE /LUDAT1A/ 
      COMMON/LUDAT2A/KCHG(500,3),PMAS(500,4),PARF(2000),VCKM(4,4)    
      SAVE /LUDAT2A/ 
      COMMON/PYSUBSA/MSEL,MSUB(200),KFIN(2,-40:40),CKIN(200) 
      SAVE /PYSUBSA/ 
      COMMON/PYPARSA/MSTP(200),PARP(200),MSTI(200),PARI(200) 
      SAVE /PYPARSA/ 
      COMMON/PYINT1A/MINT(400),VINT(400) 
      SAVE /PYINT1A/ 
      COMMON/PYINT2A/ISET(200),KFPR(200,2),COEF(200,20),ICOL(40,4,2) 
      SAVE /PYINT2A/ 
      COMMON/PYINT5A/NGEN(0:200,3),XSEC(0:200,3) 
      SAVE /PYINT5A/ 
    
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 LUJETSA 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 PYRANDA   
      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 PYSCATA 
        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 PYSSPAA(IPU1,IPU2)  
        NSAV1=N 
    
C...Multiple interactions.  
        IF(MSTP(81).GE.1.AND.MINT(43).EQ.4.AND.ISUB.NE.95)  
     &  CALL PYMULTA(6)  
        MINT(1)=ISUB    
        NSAV2=N 
    
C...Hadron remnants and primordial kT.  
        CALL PYREMNA(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 PYRESDA    
    
      ELSE  
C...Diffractive and elastic scattering. 
        CALL PYDIFFA 
        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 PYFRAMA(MSTP(124))    
    
      RETURN    
      END   
    
C*********************************************************************  
    
      SUBROUTINE PYINKIA(CHFRAM,CHBEAM,CHTARG,WIN)   
    
C...Identifies the two incoming particles and sets up kinematics,   
C...including rotations and boosts to/from CM frame.    
      COMMON/LUJETSA/N,K(9000,5),P(9000,5),V(9000,5)
      SAVE /LUJETSA/ 
      COMMON/LUDAT1A/MSTU(200),PARU(200),MSTJ(200),PARJ(200) 
      SAVE /LUDAT1A/ 
      COMMON/PYSUBSA/MSEL,MSUB(200),KFIN(2,-40:40),CKIN(200) 
      SAVE /PYSUBSA/ 
      COMMON/PYPARSA/MSTP(200),PARP(200),MSTI(200),PARI(200) 
      SAVE /PYPARSA/ 
      COMMON/PYINT1A/MINT(400),VINT(400) 
      SAVE /PYINT1A/ 
      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)=sngl((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!')  
clin 1200 FORMAT(/1X,78('=')/1X,'I',76X,'I'/1X,'I',A76,'I') 
c 1300 FORMAT(1X,'I',18X,'at',1X,F10.3,1X,'GeV center-of-mass energy',   
c     &19X,'I'/1X,'I',76X,'I'/1X,78('='))    
c 1400 FORMAT(1X,'I',22X,'at',1X,F10.3,1X,'GeV/c lab-momentum',22X,'I')  
c 1500 FORMAT(1X,'I',76X,'I'/1X,'I',11X,'corresponding to',1X,F10.3,1X,  
c     &'GeV center-of-mass energy',12X,'I'/1X,'I',76X,'I'/1X,78('='))    
c 1600 FORMAT(1X,'I',76X,'I'/1X,'I',24X,'px (GeV/c)',3X,'py (GeV/c)',3X, 
c     &'pz (GeV/c)',16X,'I') 
clin 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 PYINREA 
    
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/LUDAT1A/MSTU(200),PARU(200),MSTJ(200),PARJ(200) 
      SAVE /LUDAT1A/ 
      COMMON/LUDAT2A/KCHG(500,3),PMAS(500,4),PARF(2000),VCKM(4,4)    
      SAVE /LUDAT2A/ 
      COMMON/LUDAT3A/MDCY(500,3),MDME(2000,2),BRAT(2000),KFDP(2000,5)    
      SAVE /LUDAT3A/ 
      COMMON/PYSUBSA/MSEL,MSUB(200),KFIN(2,-40:40),CKIN(200) 
      SAVE /PYSUBSA/ 
      COMMON/PYPARSA/MSTP(200),PARP(200),MSTI(200),PARI(200) 
      SAVE /PYPARSA/ 
      COMMON/PYINT1A/MINT(400),VINT(400) 
      SAVE /PYINT1A/ 
      COMMON/PYINT2A/ISET(200),KFPR(200,2),COEF(200,20),ICOL(40,4,2) 
      SAVE /PYINT2A/ 
      COMMON/PYINT4AA/WIDP(21:40,0:40),WIDE(21:40,0:40),WIDS(21:40,3) 
      SAVE /PYINT4AA/ 
      COMMON/PYINT6A/PROC(0:200) 
      CHARACTER PROC*28 
      SAVE /PYINT6A/ 
      DIMENSION WDTP(0:40),WDTE(0:40,0:5)   
    
      kc=0

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 PYWIDTA(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 PYWIDTA(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 PYWIDTA(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 PYWIDTA(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 PYWIDTA(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 PYWIDTA(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 PYXTOTA 
    
C...Parametrizes total, double diffractive, single diffractive and  
C...elastic cross-sections for different energies and beams.    
      COMMON/LUDAT1A/MSTU(200),PARU(200),MSTJ(200),PARJ(200) 
      SAVE /LUDAT1A/ 
      COMMON/PYPARSA/MSTP(200),PARP(200),MSTI(200),PARI(200) 
      SAVE /PYPARSA/ 
      COMMON/PYINT1A/MINT(400),VINT(400) 
      SAVE /PYINT1A/ 
      COMMON/PYINT5A/NGEN(0:200,3),XSEC(0:200,3) 
      SAVE /PYINT5A/ 
      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 PYMAXIA 
    
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/LUDAT1A/MSTU(200),PARU(200),MSTJ(200),PARJ(200) 
      SAVE /LUDAT1A/ 
      COMMON/LUDAT2A/KCHG(500,3),PMAS(500,4),PARF(2000),VCKM(4,4)    
      SAVE /LUDAT2A/ 
      COMMON/PYSUBSA/MSEL,MSUB(200),KFIN(2,-40:40),CKIN(200) 
      SAVE /PYSUBSA/ 
      COMMON/PYPARSA/MSTP(200),PARP(200),MSTI(200),PARI(200) 
      SAVE /PYPARSA/ 
      COMMON/PYINT1A/MINT(400),VINT(400) 
      SAVE /PYINT1A/ 
      COMMON/PYINT2A/ISET(200),KFPR(200,2),COEF(200,20),ICOL(40,4,2) 
      SAVE /PYINT2A/ 
      COMMON/PYINT3A/XSFX(2,-40:40),ISIG(1000,3),SIGH(1000)  
      SAVE /PYINT3A/ 
      COMMON/PYINT4AA/WIDP(21:40,0:40),WIDE(21:40,0:40),WIDS(21:40,3) 
      SAVE /PYINT4AA/ 
      COMMON/PYINT5A/NGEN(0:200,3),XSEC(0:200,3) 
      SAVE /PYINT5A/ 
      COMMON/PYINT6A/PROC(0:200) 
      CHARACTER PROC*28 
      SAVE /PYINT6A/ 
      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 '/   

      taur1=0.
      gamr1=0.
      taur2=0.
      gamr2=0.
      atau3=0.
      atau4=0.
      atau5=0.
      atau6=0.
      ioff=0
      vvar=0.
      vdel=0.
      vmar=0.

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 PYKLIMA(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 PYKMAPA(1,MTAU,0.5) 
        IF(ISTSB.EQ.3.OR.ISTSB.EQ.4) CALL PYKLIMA(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 PYKMAPA(4,MTAUP,0.5)    
      ENDIF 
      IF(MOD(ITRY-1,NPTS(3)*NPTS(4)).EQ.0) CALL PYKLIMA(2)   
      IF(MOD(ITRY-1,NPTS(4)).EQ.0) THEN 
        MYST=1+MOD((ITRY-1)/NPTS(4),NPTS(3))    
        CALL PYKMAPA(2,MYST,0.5) 
        CALL PYKLIMA(3)  
      ENDIF 
      IF(ISTSB.EQ.2.OR.ISTSB.EQ.4) THEN 
        MCTH=1+MOD(ITRY-1,NPTS(4))  
        CALL PYKMAPA(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 PYKLIMA(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 PYSIGHA(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 PYSIGHA(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 PYKMAPA(1,MTAU,VTAU)    
        IF(ISTSB.EQ.3.OR.ISTSB.EQ.4) CALL PYKLIMA(4) 
      ENDIF 
      IF(IVAR.LE.2.AND.(ISTSB.EQ.3.OR.ISTSB.EQ.4)) THEN 
        IF(IVAR.EQ.2) VTAUP=VNEW    
        CALL PYKMAPA(4,MTAUP,VTAUP)  
      ENDIF 
      IF(IVAR.LE.2) CALL PYKLIMA(2)  
      IF(IVAR.LE.3) THEN    
        IF(IVAR.EQ.3) VYST=VNEW 
        CALL PYKMAPA(2,MYST,VYST)    
        CALL PYKLIMA(3)  
      ENDIF 
      IF(ISTSB.EQ.2.OR.ISTSB.EQ.4) THEN 
        IF(IVAR.EQ.4) VCTH=VNEW 
        CALL PYKMAPA(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 PYSIGHA(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,'PYMAXIA: 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/LUDAT1A/MSTU(200),PARU(200),MSTJ(200),PARJ(200) 
      SAVE /LUDAT1A/ 
      COMMON/PYPARSA/MSTP(200),PARP(200),MSTI(200),PARI(200) 
      SAVE /PYPARSA/ 
      COMMON/PYINT1A/MINT(400),VINT(400) 
      SAVE /PYINT1A/ 
      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 PYRANDA 
    
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/LUDAT1A/MSTU(200),PARU(200),MSTJ(200),PARJ(200) 
      SAVE /LUDAT1A/ 
      COMMON/LUDAT2A/KCHG(500,3),PMAS(500,4),PARF(2000),VCKM(4,4)    
      SAVE /LUDAT2A/ 
      COMMON/PYSUBSA/MSEL,MSUB(200),KFIN(2,-40:40),CKIN(200) 
      SAVE /PYSUBSA/ 
      COMMON/PYPARSA/MSTP(200),PARP(200),MSTI(200),PARI(200) 
      SAVE /PYPARSA/ 
      COMMON/PYINT1A/MINT(400),VINT(400) 
      SAVE /PYINT1A/ 
      COMMON/PYINT2A/ISET(200),KFPR(200,2),COEF(200,20),ICOL(40,4,2) 
      SAVE /PYINT2A/ 
      COMMON/PYINT3A/XSFX(2,-40:40),ISIG(1000,3),SIGH(1000)  
      SAVE /PYINT3A/ 
      COMMON/PYINT4AA/WIDP(21:40,0:40),WIDE(21:40,0:40),WIDS(21:40,3) 
      SAVE /PYINT4AA/ 
      COMMON/PYINT5A/NGEN(0:200,3),XSEC(0:200,3) 
      SAVE /PYINT5A/ 
    
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 PYMULTA(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 PYKLIMA(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 PYKMAPA(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 PYKLIMA(4)    
          IF(MINT(51).NE.0) GOTO 100    
          RTAUP=RLU(0)  
          MTAUP=1   
          IF(RTAUP.GT.COEF(ISUB,15)) MTAUP=2    
          CALL PYKMAPA(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 PYKLIMA(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 PYKMAPA(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 PYKLIMA(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 PYKMAPA(3,MCTH,RLU(0))    
        ENDIF   
    
C...Low-pT or multiple interactions (first semihard interaction).   
      ELSEIF(ISET(ISUB).EQ.5) THEN  
        CALL PYMULTA(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 PYKLIMA(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 PYKCUTA(MCUT)   
        IF(MCUT.NE.0) GOTO 100  
      ENDIF 
    
C...Calculate differential cross-section for different subprocesses.    
      CALL PYSIGHA(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 PYMULTA(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 PYMULTA(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 PYSPLIA(MINT(11),21,KFL1,KFLDUM)    
        CALL PYSPLIA(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)   
clin 1200 FORMAT(1X,'Warning: maximum violated by',1P,E11.3,1X, 
c     &'in event',1X,I7) 
c 1300 FORMAT(1X,'XSEC(',I1,',1) increased to',1P,E11.3) 
c 1400 FORMAT(1X,'XSEC(',I2,',1) increased to',1P,E11.3) 
clin 1500 FORMAT(1X,'XSEC(',I3,',1) increased to',1P,E11.3) 
    
      RETURN    
      END   
    
C*********************************************************************  
    
      SUBROUTINE PYSCATA 
    
C...Finds outgoing flavours and event type; sets up the kinematics  
C...and colour flow of the hard scattering. 
      COMMON/LUJETSA/N,K(9000,5),P(9000,5),V(9000,5)
      SAVE /LUJETSA/ 
      COMMON/LUDAT1A/MSTU(200),PARU(200),MSTJ(200),PARJ(200) 
      SAVE /LUDAT1A/ 
      COMMON/LUDAT2A/KCHG(500,3),PMAS(500,4),PARF(2000),VCKM(4,4)    
      SAVE /LUDAT2A/ 
      COMMON/LUDAT3A/MDCY(500,3),MDME(2000,2),BRAT(2000),KFDP(2000,5)    
      SAVE /LUDAT3A/ 
      COMMON/PYSUBSA/MSEL,MSUB(200),KFIN(2,-40:40),CKIN(200) 
      SAVE /PYSUBSA/ 
      COMMON/PYPARSA/MSTP(200),PARP(200),MSTI(200),PARI(200) 
      SAVE /PYPARSA/ 
      COMMON/PYINT1A/MINT(400),VINT(400) 
      SAVE /PYINT1A/ 
      COMMON/PYINT2A/ISET(200),KFPR(200,2),COEF(200,20),ICOL(40,4,2) 
      SAVE /PYINT2A/ 
      COMMON/PYINT3A/XSFX(2,-40:40),ISIG(1000,3),SIGH(1000)  
      SAVE /PYINT3A/ 
      COMMON/PYINT4AA/WIDP(21:40,0:40),WIDE(21:40,0:40),WIDS(21:40,3) 
      SAVE /PYINT4AA/ 
      COMMON/PYINT5A/NGEN(0:200,3),XSEC(0:200,3) 
      SAVE /PYINT5A/ 
      DIMENSION WDTP(0:40),WDTE(0:40,0:5),PMQ(2),Z(2),CTHE(2),PHI(2)    

      kflq=0
      phir=0.
    
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 PYWIDTA(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 PYSSPAA(IPU1,IPU2)  
    
C...Generates spacelike parton showers. 
      IMPLICIT DOUBLE PRECISION(D)  
      COMMON/LUJETSA/N,K(9000,5),P(9000,5),V(9000,5)
      SAVE /LUJETSA/ 
      COMMON/LUDAT1A/MSTU(200),PARU(200),MSTJ(200),PARJ(200) 
      SAVE /LUDAT1A/ 
      COMMON/LUDAT2A/KCHG(500,3),PMAS(500,4),PARF(2000),VCKM(4,4)    
      SAVE /LUDAT2A/ 
      COMMON/PYSUBSA/MSEL,MSUB(200),KFIN(2,-40:40),CKIN(200) 
      SAVE /PYSUBSA/ 
      COMMON/PYPARSA/MSTP(200),PARP(200),MSTI(200),PARI(200) 
      SAVE /PYPARSA/ 
      COMMON/PYINT1A/MINT(400),VINT(400) 
      SAVE /PYINT1A/ 
      COMMON/PYINT2A/ISET(200),KFPR(200,2),COEF(200,20),ICOL(40,4,2) 
      SAVE /PYINT2A/ 
      COMMON/PYINT3A/XSFX(2,-40:40),ISIG(1000,3),SIGH(1000)  
      SAVE /PYINT3A/ 
      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)   
    
      tevb=0.
      kfla=0
      z=0.
      the2t=0.
      ipo=0
      dmsma=0.
      dpt2=0.

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=dble(VINT(44))
      IF(ISET(ISUB).EQ.3.OR.ISET(ISUB).EQ.4) DSH=dble(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)=dble(Q2B)
        DPLCM=DSQRT((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)=sngl(DPLCM)*(-1)**(JR+1)   
        P(I,4)=sngl((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)=dble(Q2B)
        DPC(1)=dble(P(IS(1),4))
        DPC(2)=dble(P(IS(2),4))
        DPC(3)=dble(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.d0*  
     &  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)=sngl((DSHZ-DSH-dble(P(IT,5))**2)/DSHR)
          P(IT,3)=SQRT(P(IT,4)**2-P(IT,5)**2)   
          IF(MSTP(63).EQ.1) THEN    
            Q2TIM=sngl(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=sngl(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=dble(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.5d0*DPD(1)*DPD(2)
     &       +0.5d0*DPD(3)*
     &  DPD(4)-DQ2(JR)*(DQ2(JT)+DQ2(3)+DMS))/(4.d0*DSH*DPC(3)**2) 
        IF(DPT2.LT.0.d0) GOTO 100 
        DPB(1)=(0.5d0*DPD(2)-DPC(JR)*(DSHZ+DQ2(JR)-DQ2(JT)-DMS)/  
     &  DSHR)/DPC(3)-DPC(3) 
        P(IT,1)=SQRT(SNGL(DPT2))    
        P(IT,3)=sngl(DPB(1))*(-1)**(JT+1) 
        P(IT,4)=sngl((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)=dble(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)=dble(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,'(PYSSPAS:) no more memory left in LUJETSA')   
        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 PYMULTA(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/LUJETSA/N,K(9000,5),P(9000,5),V(9000,5)
      SAVE /LUJETSA/ 
      COMMON/LUDAT1A/MSTU(200),PARU(200),MSTJ(200),PARJ(200) 
      SAVE /LUDAT1A/ 
      COMMON/LUDAT2A/KCHG(500,3),PMAS(500,4),PARF(2000),VCKM(4,4)    
      SAVE /LUDAT2A/ 
      COMMON/PYSUBSA/MSEL,MSUB(200),KFIN(2,-40:40),CKIN(200) 
      SAVE /PYSUBSA/ 
      COMMON/PYPARSA/MSTP(200),PARP(200),MSTI(200),PARI(200) 
      SAVE /PYPARSA/ 
      COMMON/PYINT1A/MINT(400),VINT(400) 
      SAVE /PYINT1A/ 
      COMMON/PYINT2A/ISET(200),KFPR(200,2),COEF(200,20),ICOL(40,4,2) 
      SAVE /PYINT2A/ 
      COMMON/PYINT3A/XSFX(2,-40:40),ISIG(1000,3),SIGH(1000)  
      SAVE /PYINT3A/ 
      COMMON/PYINT5A/NGEN(0:200,3),XSEC(0:200,3) 
      SAVE /PYINT5A/ 
      DIMENSION NMUL(20),SIGM(20),KSTR(500,2)   
      SAVE XT2,XT2FAC,XC2,XTS,IRBIN,RBIN,NMUL,SIGM  
    
      xf=0.
      yf=0.
      deltab=0.
      ist1=0
      ist2=0
      istm=0

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 PYKLIMA(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 PYKMAPA(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 PYSIGHA(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 PYKLIMA(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 PYKMAPA(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 PYKLIMA(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 PYKMAPA(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 PYSIGHA(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,'(PYMULTA:) no more memory left in LUJETSA') 
          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,'****** PYMULTA: 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 PYREMNA(IPU1,IPU2)  
    
C...Adds on target remnants (one or two from each side) and 
C...includes primordial kT. 
      COMMON/HPARNT/HIPR1(100),IHPR2(50),HINT1(100),IHNT2(50)
      SAVE /HPARNT/
      COMMON/HSTRNG/NFP(300,15),PPHI(300,15),NFT(300,15),PTHI(300,15)
      SAVE /HSTRNG/
C...COMMON BLOCK FROM HIJING
      COMMON/LUJETSA/N,K(9000,5),P(9000,5),V(9000,5)
      SAVE /LUJETSA/ 
      COMMON/LUDAT1A/MSTU(200),PARU(200),MSTJ(200),PARJ(200) 
      SAVE /LUDAT1A/ 
      COMMON/LUDAT2A/KCHG(500,3),PMAS(500,4),PARF(2000),VCKM(4,4)    
      SAVE /LUDAT2A/ 
      COMMON/PYPARSA/MSTP(200),PARP(200),MSTI(200),PARI(200) 
      SAVE /PYPARSA/ 
      COMMON/PYINT1A/MINT(400),VINT(400) 
      SAVE /PYINT1A/ 
      DIMENSION KFLCH(2),KFLSP(2),CHI(2),PMS(6),IS(2),ROBO(5)   
    
      iq=0
      ipu=0
      shs=0.
      jpt=0
      peh=0.
      pzh=0.
      pei=0.
      pzi=0.
      pz=0.
      
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
        ssw2=(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(ssw2.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 iint=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.ssw2/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 PYSPLIA(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 PYRESDA
    
C...Allows resonances to decay (including parton showers for hadronic   
C...channels).  
      IMPLICIT DOUBLE PRECISION(D)  
      COMMON/LUJETSA/N,K(9000,5),P(9000,5),V(9000,5)
      SAVE /LUJETSA/ 
      COMMON/LUDAT1A/MSTU(200),PARU(200),MSTJ(200),PARJ(200) 
      SAVE /LUDAT1A/ 
      COMMON/LUDAT2A/KCHG(500,3),PMAS(500,4),PARF(2000),VCKM(4,4)    
      SAVE /LUDAT2A/ 
      COMMON/LUDAT3A/MDCY(500,3),MDME(2000,2),BRAT(2000),KFDP(2000,5)    
      SAVE /LUDAT3A/ 
      COMMON/PYSUBSA/MSEL,MSUB(200),KFIN(2,-40:40),CKIN(200) 
      SAVE /PYSUBSA/ 
      COMMON/PYPARSA/MSTP(200),PARP(200),MSTI(200),PARI(200) 
      SAVE /PYPARSA/ 
      COMMON/PYINT1A/MINT(400),VINT(400) 
      SAVE /PYINT1A/ 
      COMMON/PYINT2A/ISET(200),KFPR(200,2),COEF(200,20),ICOL(40,4,2) 
      SAVE /PYINT2A/ 
      COMMON/PYINT4AA/WIDP(21:40,0:40),WIDE(21:40,0:40),WIDS(21:40,3) 
      SAVE /PYINT4AA/ 
      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.d0*D34*D56+DT*(3.d0*DT+4.d0*DU)
     &     +DT**2*(DT*DU/(D34*D56)-  
     &2.d0*(1.d0/D34+1.d0/D56)*(DT+DU)+2.d0*(D34/D56+D56/D34))
      DJGK(DT,DU)=8.d0*(D34+D56)**2-8.d0*(D34+D56)*(DT+DU)-6.d0*DT*DU-    
     &2.d0*DT*DU*(DT*DU/(D34*D56)-2.d0*(1.d0/D34+1.d0/D56)*(DT+DU)+ 
     &2.d0*(D34/D56+D56/D34)) 
    
      i12=0
      wt=0.
      wtmax=0.

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 PYWIDTA(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.    
clin-8/19/02 avoid actual argument in common blocks of LU2ENT:
      pid5=P(ID,5)
      IF(KDCY(JT).EQ.1) THEN    
c        CALL LU2ENT(-(N+1),KFL1(JT),KFL2(JT),P(ID,5))   
        CALL LU2ENT(-(N+1),KFL1(JT),KFL2(JT),pid5)   
      ELSE  
c        CALL LU2ENT(N+1,KFL1(JT),KFL2(JT),P(ID,5))  
        CALL LU2ENT(N+1,KFL1(JT),KFL2(JT),pid5)  
      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=dble(P(IREF(IP,IORD),5)**2)
        D56=dble(P(IREF(IP,3-IORD),5)**2)
        DT=dble(PKK(1,3)+PKK(1,4))+D34    
        DU=dble(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.*sngl(D34*D56)*(COUP(5,3)**2+COUP(5,4)**2)*(CAWZ**2*  
     &       sngl(DIGK(DT,DU))+CBWZ**2*sngl(DIGK(DU,DT))
     &       +CAWZ*CBWZ*sngl(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=dble(P(IREF(IP,IORD),5)**2)
        D56=dble(P(IREF(IP,3-IORD),5)**2)
        DT=dble(PKK(1,3)+PKK(1,4))+D34    
        DU=dble(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.*sngl(D34*D56)*(CAWW**2*sngl(DIGK(DT,DU))
     &       +CBWW**2*sngl(DIGK(DU,DT))-CAWW*CBWW*sngl(DJGK(DT,DU))
     &       +CCWW**2*sngl(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 
clin-8/19/02 avoid actual argument in common blocks of LUSHOW:
c      IF(MSTP(71).GE.1.AND.KDCY(JT).EQ.1) CALL LUSHOW(NSD(JT)+1,    
c     &NSD(JT)+2,P(ID,5))    
      pid5=P(ID,5)
      IF(MSTP(71).GE.1.AND.KDCY(JT).EQ.1) CALL LUSHOW(NSD(JT)+1,    
     &NSD(JT)+2,pid5)    
    
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 PYDIFFA 
    
C...Handles diffractive and elastic scattering. 
      COMMON/LUJETSA/N,K(9000,5),P(9000,5),V(9000,5)
      SAVE /LUJETSA/ 
      COMMON/LUDAT1A/MSTU(200),PARU(200),MSTJ(200),PARJ(200) 
      SAVE /LUDAT1A/ 
      COMMON/PYPARSA/MSTP(200),PARP(200),MSTI(200),PARI(200) 
      SAVE /PYPARSA/ 
      COMMON/PYINT1A/MINT(400),VINT(400) 
      SAVE /PYINT1A/ 
    
      chi=0.

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 PYSPLIA(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 PYSPLIA(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 PYFRAMA(IFRAME) 
    
C...Performs transformations between different coordinate frames.   
      COMMON/LUDAT1A/MSTU(200),PARU(200),MSTJ(200),PARJ(200) 
      SAVE /LUDAT1A/ 
      COMMON/PYPARSA/MSTP(200),PARP(200),MSTI(200),PARI(200) 
      SAVE /PYPARSA/ 
      COMMON/PYINT1A/MINT(400),VINT(400) 
      SAVE /PYINT1A/ 
    
      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 PYFRAMA.',1X,   
     &'No transformation performed.'/1X,'IFRAME =',1X,I5,'; MINT(6) =', 
     &1X,I5)    
    
      RETURN    
      END   
    
C*********************************************************************  
    
      SUBROUTINE PYWIDTA(KFLR,RMAS,WDTP,WDTE)    
    
C...Calculates full and partial widths of resonances.   
      COMMON/LUDAT1A/MSTU(200),PARU(200),MSTJ(200),PARJ(200) 
      SAVE /LUDAT1A/ 
      COMMON/LUDAT2A/KCHG(500,3),PMAS(500,4),PARF(2000),VCKM(4,4)    
      SAVE /LUDAT2A/ 
      COMMON/LUDAT3A/MDCY(500,3),MDME(2000,2),BRAT(2000),KFDP(2000,5)    
      SAVE /LUDAT3A/ 
      COMMON/PYPARSA/MSTP(200),PARP(200),MSTI(200),PARI(200) 
      SAVE /PYPARSA/ 
      COMMON/PYINT1A/MINT(400),VINT(400) 
      SAVE /PYINT1A/ 
      COMMON/PYINT4AA/WIDP(21:40,0:40),WIDE(21:40,0:40),WIDS(21:40,3) 
      SAVE /PYINT4AA/ 
      DIMENSION WDTP(0:40),WDTE(0:40,0:5)   

      wid2=0.
      ai=0.
      ggi=0.
      gzi=0.
      zzi=0.
      ggf=0.
      gzf=0.
      zzf=0.
      ej=0.
      vj=0.
      gzpi=0.
      zzpi=0.
      zpzpi=0.
      gzpf=0.
      zzpf=0.
      zpzpf=0.
    
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) 
clin-4/2008 modified a la pythia6115.f to avoid undefined values (GGF,GZF,ZZF):
c          VINT(111)=VINT(111)+GGF*WID2  
c          VINT(112)=VINT(112)+GZF*WID2  
c          VINT(114)=VINT(114)+ZZF*WID2  
          IF(MINT(61).EQ.2) THEN    
             VINT(111)=VINT(111)+GGF*WID2  
             VINT(112)=VINT(112)+GZF*WID2  
             VINT(114)=VINT(114)+ZZF*WID2  
          ENDIF
clin-4/2008-end
        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    
clin-4/2008 modified above a la pythia6115.f to avoid undefined variable API:
c          APF=SIGN(1.,EF+0.1)   
c          VPF=API-4.*EF*XW  
          IF(I.LE.10) THEN
             VPF=PARU(127-2*MOD(I,2))
             APF=PARU(128-2*MOD(I,2))
          ELSEIF(I.LE.12) THEN
             VPF=PARJ(186-2*MOD(I,2))
             APF=PARJ(187-2*MOD(I,2))
          ELSE
             VPF=PARJ(194-2*MOD(I,2))
             APF=PARJ(195-2*MOD(I,2))
          ENDIF
clin-4/2008-end
          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) 
clin-4/2008:
c          VINT(111)=VINT(111)+GGF   
c          VINT(112)=VINT(112)+GZF   
c          VINT(113)=VINT(113)+GZPF  
c          VINT(114)=VINT(114)+ZZF   
c          VINT(115)=VINT(115)+ZZPF  
c          VINT(116)=VINT(116)+ZPZPF 
          IF(MINT(61).EQ.2) THEN    
             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
clin-4/2008-end
        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 PYKLIMA(ILIM)   
    
C...Checks generated variables against pre-set kinematical limits;  
C...also calculates limits on variables used in generation. 
      COMMON/LUDAT1A/MSTU(200),PARU(200),MSTJ(200),PARJ(200) 
      SAVE /LUDAT1A/ 
      COMMON/LUDAT2A/KCHG(500,3),PMAS(500,4),PARF(2000),VCKM(4,4)    
      SAVE /LUDAT2A/ 
      COMMON/LUDAT3A/MDCY(500,3),MDME(2000,2),BRAT(2000),KFDP(2000,5)    
      SAVE /LUDAT3A/ 
      COMMON/PYPARSA/MSTP(200),PARP(200),MSTI(200),PARI(200) 
      SAVE /PYPARSA/ 
      COMMON/PYSUBSA/MSEL,MSUB(200),KFIN(2,-40:40),CKIN(200) 
      SAVE /PYSUBSA/ 
      COMMON/PYINT1A/MINT(400),VINT(400) 
      SAVE /PYINT1A/ 
      COMMON/PYINT2A/ISET(200),KFPR(200,2),COEF(200,20),ICOL(40,4,2) 
      SAVE /PYINT2A/ 

      tau=0.
      rm3=0.
      rm4=0.
      be34=0.
      st2eff=0.
    
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 PYKMAPA(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/LUDAT2A/KCHG(500,3),PMAS(500,4),PARF(2000),VCKM(4,4)    
      SAVE /LUDAT2A/ 
      COMMON/PYINT1A/MINT(400),VINT(400) 
      SAVE /PYINT1A/ 
      COMMON/PYINT2A/ISET(200),KFPR(200,2),COEF(200,20),ICOL(40,4,2) 
      SAVE /PYINT2A/ 
    
      taure=0.
      gamre=0.
      cth=0.

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 PYSIGHA(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/LUDAT1A/MSTU(200),PARU(200),MSTJ(200),PARJ(200) 
      SAVE /LUDAT1A/ 
      COMMON/LUDAT2A/KCHG(500,3),PMAS(500,4),PARF(2000),VCKM(4,4)    
      SAVE /LUDAT2A/ 
      COMMON/LUDAT3A/MDCY(500,3),MDME(2000,2),BRAT(2000),KFDP(2000,5)    
      SAVE /LUDAT3A/ 
      COMMON/PYSUBSA/MSEL,MSUB(200),KFIN(2,-40:40),CKIN(200) 
      SAVE /PYSUBSA/ 
      COMMON/PYPARSA/MSTP(200),PARP(200),MSTI(200),PARI(200) 
      SAVE /PYPARSA/ 
      COMMON/PYINT1A/MINT(400),VINT(400) 
      SAVE /PYINT1A/ 
      COMMON/PYINT2A/ISET(200),KFPR(200,2),COEF(200,20),ICOL(40,4,2) 
      SAVE /PYINT2A/ 
      COMMON/PYINT3A/XSFX(2,-40:40),ISIG(1000,3),SIGH(1000)  
      SAVE /PYINT3A/ 
      COMMON/PYINT4AA/WIDP(21:40,0:40),WIDE(21:40,0:40),WIDS(21:40,3) 
      SAVE /PYINT4AA/ 
      COMMON/PYINT5A/NGEN(0:200,3),XSEC(0:200,3) 
      SAVE /PYINT5A/ 
      DIMENSION X(2),XPQ(-6:6),KFAC(2,-40:40),WDTP(0:40),WDTE(0:40,0:5) 
    
      as=0.
      faca=0.
      min1=0.
      max1=0.
      min2=0.
      max2=0.
      mina=0.
      maxa=0.
      sqmz=0.
      gmmz=0.
      sqmw=0.
      gmmw=0.
      sqmh=0.
      gmmh=0.
      sqmzp=0.
      gmmzp=0.
      sqmhc=0.
      gmmhc=0.
      sqmr=0.
      gmmr=0.
      aem=0.
      xw=0.
      comfac=0.

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 
clin-4/2008 modified a la pythia6115.f to avoid invalid MDCY subcript#1,
c     also break up compound IF statements:
c      IF((ISET(ISUB).EQ.1.OR.ISET(ISUB).EQ.3).AND.  
c     &MDCY(KFPR(ISUB,1),1).EQ.1) THEN   
c        IF(KFPR(ISUB,1).EQ.25.OR.KFPR(ISUB,1).EQ.37) THEN   
c          COMFAC=COMFAC*0.5*ACTH0   
c        ELSE    
c          COMFAC=COMFAC*0.125*(3.*ACTH0+CTNMAX**3-CTNMIN**3+    
c     &    CTPMAX**3-CTPMIN**3)  
c        ENDIF   
      IF(ISET(ISUB).EQ.1.OR.ISET(ISUB).EQ.3) THEN
         if(MDCY(LUCOMP(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
         endif
c
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 PYWIDTA(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 PYWIDTA(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 PYWIDTA(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 PYWIDTA(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 PYWIDTA(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 PYWIDTA(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 PYWIDTA(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 PYWIDTA(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 PYWIDTA(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=PYI3AA(BESTU,EPSH,1)-PYI3AA(BESTU,EPSS,1)-   
     &  PYI3AA(BESTU,EPSU,1)    
        W3STUI=PYI3AA(BESTU,EPSH,2)-PYI3AA(BESTU,EPSS,2)-   
     &  PYI3AA(BESTU,EPSU,2)    
        W3SUTR=PYI3AA(BESUT,EPSH,1)-PYI3AA(BESUT,EPSS,1)-   
     &  PYI3AA(BESUT,EPST,1)    
        W3SUTI=PYI3AA(BESUT,EPSH,2)-PYI3AA(BESUT,EPSS,2)-   
     &  PYI3AA(BESUT,EPST,2)    
        W3TSUR=PYI3AA(BETSU,EPSH,1)-PYI3AA(BETSU,EPST,1)-   
     &  PYI3AA(BETSU,EPSU,1)    
        W3TSUI=PYI3AA(BETSU,EPSH,2)-PYI3AA(BETSU,EPST,2)-   
     &  PYI3AA(BETSU,EPSU,2)    
        W3TUSR=PYI3AA(BETUS,EPSH,1)-PYI3AA(BETUS,EPST,1)-   
     &  PYI3AA(BETUS,EPSS,1)    
        W3TUSI=PYI3AA(BETUS,EPSH,2)-PYI3AA(BETUS,EPST,2)-   
     &  PYI3AA(BETUS,EPSS,2)    
        W3USTR=PYI3AA(BEUST,EPSH,1)-PYI3AA(BEUST,EPSU,1)-   
     &  PYI3AA(BEUST,EPST,1)    
        W3USTI=PYI3AA(BEUST,EPSH,2)-PYI3AA(BEUST,EPSU,2)-   
     &  PYI3AA(BEUST,EPST,2)    
        W3UTSR=PYI3AA(BEUTS,EPSH,1)-PYI3AA(BEUTS,EPSU,1)-   
     &  PYI3AA(BEUTS,EPSS,1)    
        W3UTSI=PYI3AA(BEUTS,EPSH,2)-PYI3AA(BEUTS,EPSU,2)-   
     &  PYI3AA(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)*(PYI3AA(BESUT,EPSS,1)+    
     &    PYI3AA(BESUT,EPST,1))-0.25*EPSU*(1.-0.5*EPSS)*    
     &    (PYI3AA(BESTU,EPSS,1)+PYI3AA(BESTU,EPSU,1))+  
     &    0.25*(-2.*(TH2+UH2)/SH2+4.*EPSS+EPST+EPSU+0.5*EPST*EPSU)* 
     &    (PYI3AA(BETSU,EPST,1)+PYI3AA(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)*(PYI3AA(BESUT,EPSS,2)+    
     &    PYI3AA(BESUT,EPST,2))-0.25*EPSU*(1.-0.5*EPSS)*    
     &    (PYI3AA(BESTU,EPSS,2)+PYI3AA(BESTU,EPSU,2))+  
     &    0.25*(-2.*(TH2+UH2)/SH2+4.*EPSS+EPST+EPSU+0.5*EPST*EPSU)* 
     &    (PYI3AA(BETSU,EPST,2)+PYI3AA(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)*(PYI3AA(BETUS,EPST,1)+    
     &    PYI3AA(BETUS,EPSS,1))-0.25*EPSU*(1.-0.5*EPST)*    
     &    (PYI3AA(BETSU,EPST,1)+PYI3AA(BETSU,EPSU,1))+  
     &    0.25*(-2.*(SH2+UH2)/TH2+4.*EPST+EPSS+EPSU+0.5*EPSS*EPSU)* 
     &    (PYI3AA(BESTU,EPSS,1)+PYI3AA(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)*(PYI3AA(BETUS,EPST,2)+    
     &    PYI3AA(BETUS,EPSS,2))-0.25*EPSU*(1.-0.5*EPST)*    
     &    (PYI3AA(BETSU,EPST,2)+PYI3AA(BETSU,EPSU,2))+  
     &    0.25*(-2.*(SH2+UH2)/TH2+4.*EPST+EPSS+EPSU+0.5*EPSS*EPSU)* 
     &    (PYI3AA(BESTU,EPSS,2)+PYI3AA(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)*(PYI3AA(BEUST,EPSU,1)+    
     &    PYI3AA(BEUST,EPST,1))-0.25*EPSS*(1.-0.5*EPSU)*    
     &    (PYI3AA(BEUTS,EPSU,1)+PYI3AA(BEUTS,EPSS,1))+  
     &    0.25*(-2.*(TH2+SH2)/UH2+4.*EPSU+EPST+EPSS+0.5*EPST*EPSS)* 
     &    (PYI3AA(BETUS,EPST,1)+PYI3AA(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)*(PYI3AA(BEUST,EPSU,2)+    
     &    PYI3AA(BEUST,EPST,2))-0.25*EPSS*(1.-0.5*EPSU)*    
     &    (PYI3AA(BEUTS,EPSU,2)+PYI3AA(BEUTS,EPSS,2))+  
     &    0.25*(-2.*(TH2+SH2)/UH2+4.*EPSU+EPST+EPSS+0.5*EPST*EPSS)* 
     &    (PYI3AA(BETUS,EPST,2)+PYI3AA(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)* 
     &    (PYI3AA(BESUT,EPSS,1)+PYI3AA(BESUT,EPST,1))+  
     &    0.25*(EPST+0.5*EPSS*EPSU)*(PYI3AA(BESTU,EPSS,1)+  
     &    PYI3AA(BESTU,EPSU,1))+0.25*(EPSS+0.5*EPST*EPSU)*  
     &    (PYI3AA(BETSU,EPST,1)+PYI3AA(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)*    
     &    (PYI3AA(BESUT,EPSS,2)+PYI3AA(BESUT,EPST,2))+  
     &    0.25*(EPST+0.5*EPSS*EPSU)*(PYI3AA(BESTU,EPSS,2)+  
     &    PYI3AA(BESTU,EPSU,2))+0.25*(EPSS+0.5*EPST*EPSU)*  
     &    (PYI3AA(BETSU,EPST,2)+PYI3AA(BETSU,EPSU,2))   
          A2STUR=-1.+0.125*EPSS*EPST*(PYI3AA(BESUT,EPSS,1)+ 
     &    PYI3AA(BESUT,EPST,1))+0.125*EPSS*EPSU*(PYI3AA(BESTU,EPSS,1)+  
     &    PYI3AA(BESTU,EPSU,1))+0.125*EPST*EPSU*(PYI3AA(BETSU,EPST,1)+  
     &    PYI3AA(BETSU,EPSU,1)) 
          A2STUI=0.125*EPSS*EPST*(PYI3AA(BESUT,EPSS,2)+ 
     &    PYI3AA(BESUT,EPST,2))+0.125*EPSS*EPSU*(PYI3AA(BESTU,EPSS,2)+  
     &    PYI3AA(BESTU,EPSU,2))+0.125*EPST*EPSU*(PYI3AA(BETSU,EPST,2)+  
     &    PYI3AA(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 PYWIDTA(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 PYWIDTA(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 PYWIDTA(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/HPARNT/HIPR1(100),IHPR2(50),HINT1(100),IHNT2(50)
      SAVE /HPARNT/
      COMMON/hjcrdn/YP(3,300),YT(3,300)
      SAVE /hjcrdn/
C                        ********COMMON BLOCK FROM HIJING
      COMMON/LUDAT1A/MSTU(200),PARU(200),MSTJ(200),PARJ(200) 
      SAVE /LUDAT1A/ 
      COMMON/LUDAT2A/KCHG(500,3),PMAS(500,4),PARF(2000),VCKM(4,4)    
      SAVE /LUDAT2A/ 
      COMMON/PYPARSA/MSTP(200),PARP(200),MSTI(200),PARI(200) 
      SAVE /PYPARSA/ 
      COMMON/PYINT1A/MINT(400),VINT(400) 
      SAVE /PYINT1A/ 
      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 
clin-10/25/02 get rid of argument usage mismatch in PYGAMMA():
c      EULBT(X,Y)=PYGAMMA(X)*PYGAMMA(Y)/PYGAMMA(X+Y)
    
      vx=0.
      bbr2=0.

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 (thresh 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 (thresh 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   

clin-10/25/02 evaluate EULBT(TS(1),TS(2)+1.):
c          XQ(KFL)=X**TS(1)*(1.-X)**TS(2)*(1.+TS(3)*X)/(EULBT(TS(1),    
c     &    TS(2)+1.)*(1.+TS(3)*TS(1)/(TS(1)+TS(2)+1.)))  
           eulbt1=PYGAMMA(TS(1))*PYGAMMA(TS(2)+1.)/
     &     PYGAMMA(TS(1)+TS(2)+1.)
           XQ(KFL)=X**TS(1)*(1.-X)**TS(2)*(1.+TS(3)*X)/(EULBT1
     &          *(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   

clin-10/25/02 get rid of argument usage mismatch in PYGAMMA():
c          XQ(KFL)=X**TS(1)*(1.-X)**TS(2)/EULBT(TS(1),TS(2)+1.) 
           eulbt2=PYGAMMA(TS(1))
     &     *PYGAMMA(TS(2)+1.)/PYGAMMA(TS(1)+TS(2)+1.)
           XQ(KFL)=X**TS(1)*(1.-X)**TS(2)/EULBT2
        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/
     1              ATNM**0.66666
              ELSEIF(JBT.EQ.2) THEN
               BBR2=(YT(1,IHNT2(12))**2+YT(2,IHNT2(12))**2)/1.44/
     1              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))
     1           *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                                function 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 PYSPLIA(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=int(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 PYGAMMA(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)    
clin      DATA B/-0.577191652,0.988205891,-0.897056937,0.918206857, 
clin     &-0.756704078,0.482199394,-0.193527818,0.035868343/    
      DATA B/-0.57719165,0.98820589,-0.89705694,0.91820686, 
     &-0.75670408,0.48219939,-0.19352782,0.03586834/    
    
      NX=INT(X) 
      DX=X-NX   
    
      PYGAMMA=1. 
      DO 100 I=1,8  
  100 PYGAMMA=PYGAMMA+B(I)*DX**I  
      IF(X.LT.1.) THEN  
        PYGAMMA=PYGAMMA/X 
      ELSE  
        DO 110 IX=1,NX-1    
  110   PYGAMMA=(X-IX)*PYGAMMA    
      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/LUDAT1A/MSTU(200),PARU(200),MSTJ(200),PARJ(200) 
      SAVE /LUDAT1A/ 
    
      ASINH(X)=LOG(X+SQRT(X**2+1.)) 
      ACOSH(X)=LOG(X+SQRT(X**2-1.)) 
    
      pyw1au=0.

      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/LUDAT1A/MSTU(200),PARU(200),MSTJ(200),PARJ(200) 
      SAVE /LUDAT1A/ 
    
      ASINH(X)=LOG(X+SQRT(X**2+1.)) 
      ACOSH(X)=LOG(X+SQRT(X**2-1.)) 
    
      pyw2au=0.

      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 PYI3AA(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/LUDAT1A/MSTU(200),PARU(200),MSTJ(200),PARJ(200) 
      SAVE /LUDAT1A/ 
    
      pyi3au=0.
      ga=0.

      IF(EPS.LT.1.) GA=0.5*(1.+SQRT(1.-EPS))    
    
      IF(EPS.LT.0.) THEN    
        F3RE=PYSPEA((GA-1.)/(GA+BE-1.),0.,1)-PYSPEA(GA/(GA+BE-1.),0.,1)+    
     &  PYSPEA((BE-GA)/BE,0.,1)-PYSPEA((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=PYSPEA((GA-1.)/(GA+BE-1.),0.,1)-PYSPEA(GA/(GA+BE-1.),0.,1)+    
     &  PYSPEA(GA/(GA-BE),0.,1)-PYSPEA((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=PYSPEA(RCTHE,RSTHE,1)+PYSPEA(RCTHE,-RSTHE,1)-  
     &  PYSPEA(RCPHI,RSPHI,1)-PYSPEA(RCPHI,-RSPHI,1)+   
     &  (PHI-THE)*(PHI+THE-PARU(1)) 
        F3IM=PYSPEA(RCTHE,RSTHE,2)+PYSPEA(RCTHE,-RSTHE,2)-  
     &  PYSPEA(RCPHI,RSPHI,2)-PYSPEA(RCPHI,-RSPHI,2)    
      ENDIF 
    
      IF(IREIM.EQ.1) PYI3AA=2./(2.*BE-1.)*F3RE  
      IF(IREIM.EQ.2) PYI3AA=2./(2.*BE-1.)*F3IM  
    
      RETURN    
      END   
    
C***********************************************************************    
    
      FUNCTION PYSPEA(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/LUDAT1A/MSTU(200),PARU(200),MSTJ(200),PARJ(200) 
      SAVE /LUDAT1A/ 
      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/    
    
      pyspea=0.

      XRE=XREIN 
      XIM=XIMIN 
      IF(ABS(1.-XRE).LT.1.E-6.AND.ABS(XIM).LT.1.E-6) THEN   
        IF(IREIM.EQ.1) PYSPEA=PARU(1)**2/6. 
        IF(IREIM.EQ.2) PYSPEA=0.    
        RETURN  
      ENDIF 
    
      XMOD=SQRT(XRE**2+XIM**2)  
      IF(XMOD.LT.1.E-6) THEN    
        IF(IREIM.EQ.1) PYSPEA=0.    
        IF(IREIM.EQ.2) PYSPEA=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) PYSPEA=SP0RE+SGN*SPRE  
      IF(IREIM.EQ.2) PYSPEA=SP0IM+SGN*SPIM  
    
      RETURN    
      END   
    
C*********************************************************************  
    
      BLOCK DATA PYDATA 
    
C...Give sensible default values to all status codes and parameters.    
      COMMON/PYSUBSA/MSEL,MSUB(200),KFIN(2,-40:40),CKIN(200) 
      SAVE /PYSUBSA/ 
      COMMON/PYPARSA/MSTP(200),PARP(200),MSTI(200),PARI(200) 
      SAVE /PYPARSA/ 
      COMMON/PYINT1A/MINT(400),VINT(400) 
      SAVE /PYINT1A/ 
      COMMON/PYINT2A/ISET(200),KFPR(200,2),COEF(200,20),ICOL(40,4,2) 
      SAVE /PYINT2A/ 
      COMMON/PYINT3A/XSFX(2,-40:40),ISIG(1000,3),SIGH(1000)  
      SAVE /PYINT3A/ 
      COMMON/PYINT4AA/WIDP(21:40,0:40),WIDE(21:40,0:40),WIDS(21:40,3) 
      SAVE /PYINT4AA/ 
      COMMON/PYINT5A/NGEN(0:200,3),XSEC(0:200,3) 
      SAVE /PYINT5A/ 
      COMMON/PYINT6A/PROC(0:200) 
      CHARACTER PROC*28 
      SAVE /PYINT6A/ 
    
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 PYKCUTA(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/PYPARSA/MSTP(200),PARP(200),MSTI(200),PARI(200) 
      SAVE /PYPARSA/ 
    
      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/LUDAT1A/MSTU(200),PARU(200),MSTJ(200),PARJ(200) 
      SAVE /LUDAT1A/ 
      COMMON/LUDAT2A/KCHG(500,3),PMAS(500,4),PARF(2000),VCKM(4,4)    
      SAVE /LUDAT2A/ 
      COMMON/PYPARSA/MSTP(200),PARP(200),MSTI(200),PARI(200) 
      SAVE /PYPARSA/ 
      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/  
    
      KF=KF
      HEADER=HEADER
      CHDFLM(1)=CHDFLM(1)
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