C-----------------------------------------------------------------------
C                           H E R W I G
C
C            a Monte Carlo event generator for simulating
C        +---------------------------------------------------+
C        | Hadron Emission Reactions With Interfering Gluons |
C        +---------------------------------------------------+
C I.G. Knowles(*), G. Marchesini(+), M.H. Seymour($) and B.R. Webber(#)
C-----------------------------------------------------------------------
C with Minimal Supersymmetric Standard Model Matrix Elements by
C                  S. Moretti(&) and K. Odagiri(^)
C-----------------------------------------------------------------------
C R parity violating Supersymmetric Decays and Matrix Elements by
C                          P. Richardson(#)
C-----------------------------------------------------------------------
C matrix element corrections to top decay and Drell-Yan type processes
C                         by G. Corcella(+)
C-----------------------------------------------------------------------
C Deep Inelastic Scattering and Heavy Flavour Electroproduction by
C                  G. Abbiendi(@) and L. Stanco(%)
C-----------------------------------------------------------------------
C and Jet Photoproduction in Lepton-Hadron Collisions by J. Chyla(~)
C-----------------------------------------------------------------------
C(*)  Department of Physics & Astronomy, University of Edinburgh
C(+)  Dipartimento di Fisica, Universita di Milano
C($)  Department of Physics & Astronomy, University of Manchester
C(#)  Cavendish Laboratory, Cambridge
C(&)  Theory Division, CERN
C(^)  Theory Group, KEK
C(@)  Dipartimento di Fisica, Universita di Bologna
C(%)  Dipartimento di Fisica, Universita di Padova
C(~)  Institute of Physics, Prague
C-----------------------------------------------------------------------
C                  Version 6.202 - 20th February 2001
C-----------------------------------------------------------------------
C Main references:
C
C    G.Corcella, I.G.Knowles, G.Marchesini, S.Moretti, K.Odagiri,
C    P.Richardson, M.H.Seymour and B.R.Webber, hep-ph/0011363
C
C    G.Marchesini,  B.R.Webber,  G.Abbiendi,  I.G.Knowles,  M.H.Seymour,
C    and L.Stanco, Computer Physics Communications 67 (1992) 465.
C-----------------------------------------------------------------------
C Please see the official HERWIG information page:
C    http://hepwww.rl.ac.uk/theory/seymour/herwig/
C-----------------------------------------------------------------------
CDECK  ID>, DECADD.
*CMZ :-        -28/01/92  12.34.44  by  Mike Seymour
*-- Author :    Luca Stanco
C-----------------------------------------------------------------------
      SUBROUTINE DECADD(LOGI)
C-----------------------------------------------------------------------
C     DUMMY SUBROUTINE: DELETE AND SET BDECAY='CLEO'
C     IN MAIN PROGRAM IF YOU USE CLEO DECAY PACKAGE
C-----------------------------------------------------------------------
      LOGICAL LOGI
      WRITE (6,10)
   10 FORMAT(/10X,'DECADD CALLED BUT NOT LINKED')
      STOP
      END
CDECK  ID>, EUDINI.
*CMZ :-        -28/01/92  12.34.44  by  Mike Seymour
*-- Author :    Luca Stanco
C-----------------------------------------------------------------------
      SUBROUTINE EUDINI
C-----------------------------------------------------------------------
C     DUMMY SUBROUTINE: DELETE AND SET BDECAY='EURO'
C     IN MAIN PROGRAM IF YOU USE EURODEC DECAY PACKAGE
C-----------------------------------------------------------------------
      WRITE (6,10)
   10 FORMAT(/10X,'EUDINI CALLED BUT NOT LINKED')
      STOP
      END
CDECK  ID>, FRAGMT.
*CMZ :-        -28/01/92  12.34.44  by  Mike Seymour
*-- Author :    Luca Stanco
C-----------------------------------------------------------------------
      SUBROUTINE FRAGMT(I,J,K)
C-----------------------------------------------------------------------
C     DUMMY SUBROUTINE: DELETE AND SET BDECAY='EURO'
C     IN MAIN PROGRAM IF YOU USE EURODEC DECAY PACKAGE
C-----------------------------------------------------------------------
      INTEGER I,J,K
      WRITE (6,10)
   10 FORMAT(/10X,'FRAGMT CALLED BUT NOT LINKED')
      STOP
      END
CDECK  ID>, HVCBVI.
*CMZ :-        -28/01/92  12.34.44  by  Mike Seymour
*-- Author :    Mike Seymour
C-----------------------------------------------------------------------
      SUBROUTINE HVCBVI
C-----------------------------------------------------------------------
C     DUMMY ROUTINE: DELETE IF YOU LINK TO BARYON NUMBER VIOLATN PACKAGE
C-----------------------------------------------------------------------
      WRITE (6,10)
   10 FORMAT(/10X,'HVCBVI CALLED BUT NOT LINKED')
      STOP
      END
CDECK  ID>, HVHBVI.
*CMZ :-        -28/01/92  12.34.44  by  Mike Seymour
*-- Author :    Mike Seymour
C-----------------------------------------------------------------------
      SUBROUTINE HVHBVI
C-----------------------------------------------------------------------
C     DUMMY ROUTINE: DELETE IF YOU LINK TO BARYON NUMBER VIOLATN PACKAGE
C-----------------------------------------------------------------------
      WRITE (6,10)
   10 FORMAT(/10X,'HERBVI CALLED BUT NOT LINKED')
      STOP
      END
CDECK  ID>, HWBAZF.
*CMZ :-        -26/04/91  11.11.54  by  Bryan Webber
*-- Author :    Ian Knowles
C-----------------------------------------------------------------------
      SUBROUTINE HWBAZF(IPAR,JPAR,VEC1,VEC2,VEC3,VEC)
C-----------------------------------------------------------------------
C     Azimuthal correlation functions for Collins' algorithm,
C     see I.G.Knowles, Comp. Phys. Comm. 58 (90) 271 for notation.
C-----------------------------------------------------------------------
      INCLUDE 'HERWIG62.INC'
      DOUBLE PRECISION Z1,Z2,DOT12,DOT23,DOT31,TR,FN(7),VEC1(2),VEC2(2),
     & VEC3(2),VEC(2)
      INTEGER IPAR,JPAR
      LOGICAL GLUI,GLUJ
      IF (.NOT.AZSPIN) RETURN
      Z1=PPAR(4,JPAR)/PPAR(4,IPAR)
      Z2=1.-Z1
      GLUI=IDPAR(IPAR).EQ.13
      GLUJ=IDPAR(JPAR).EQ.13
      IF (GLUI) THEN
         IF (GLUJ) THEN
C           Branching: g--->gg
            FN(2)=Z2/Z1
            FN(3)=1./FN(2)
            FN(4)=Z1*Z2
            FN(1)=FN(2)+FN(3)+FN(4)
            FN(5)=FN(2)+2.*Z1
            FN(6)=FN(3)+2.*Z2
            FN(7)=FN(4)-2.
         ELSE
C           Branching: g--->qqbar
            FN(1)=(Z1*Z1+Z2*Z2)/2.
            FN(2)=0.
            FN(3)=0.
            FN(4)=-Z1*Z2
            FN(5)=-(2.*Z1-1.)/2.
            FN(6)=-FN(5)
            FN(7)=FN(1)
         ENDIF
      ELSE
         IF (GLUJ) THEN
C           Branching: q--->gq
            FN(1)=(1.+Z2*Z2)/(2.*Z1)
            FN(2)=Z2/Z1
            FN(3)=0.
            FN(4)=0.
            FN(5)=FN(1)
            FN(6)=(1.+Z2)/2.
            FN(7)=-FN(6)
         ELSE
C           Branching: q--->qg
            FN(1)=(1.+Z1*Z1)/(2.*Z2)
            FN(2)=0.
            FN(3)=Z1/Z2
            FN(4)=0.
            FN(5)=(1.+Z1)/2.
            FN(6)=FN(1)
            FN(7)=-FN(5)
         ENDIF
      ENDIF
      DOT12=VEC1(1)*VEC2(1)+VEC1(2)*VEC2(2)
      DOT23=VEC2(1)*VEC3(1)+VEC2(2)*VEC3(2)
      DOT31=VEC3(1)*VEC1(1)+VEC3(2)*VEC1(2)
      TR=1./(FN(1)+FN(2)*DOT23+FN(3)*DOT31+FN(4)*DOT12)
      VEC(1)=((FN(2)+FN(5)*DOT23)*VEC1(1)
     &       +(FN(3)+FN(6)*DOT31)*VEC2(1)
     &       +(FN(4)+FN(7)*DOT12)*VEC3(1))*TR
      VEC(2)=((FN(2)+FN(5)*DOT23)*VEC1(2)
     &       +(FN(3)+FN(6)*DOT31)*VEC2(2)
     &       +(FN(4)+FN(7)*DOT12)*VEC3(2))*TR
      END
CDECK  ID>, HWBCON.
*CMZ :-        -26/04/91  10.18.56  by  Bryan Webber
*-- Author :    Bryan Webber
C-----------------------------------------------------------------------
      SUBROUTINE HWBCON
C-----------------------------------------------------------------------
C     MAKES COLOUR CONNECTIONS BETWEEN JETS
C     MODIFIED 12/10/97 BY BRW FOR SUSY PROCESSES
C-----------------------------------------------------------------------
      INCLUDE 'HERWIG62.INC'
      INTEGER IHEP,IST,ID,JC,KC,JD,JHEP,LHEP,ID2
      IF (IERROR.NE.0) RETURN
      IF(.NOT.RPARTY) THEN
        CALL HWBRCN
        RETURN
      ENDIF
      DO 20 IHEP=1,NHEP
      IST=ISTHEP(IHEP)
C---LOOK FOR PARTONS WITHOUT COLOUR MOTHERS
      IF (IST.LT.145.OR.IST.GT.152) GOTO 20
      IF (JMOHEP(2,IHEP).EQ.0) THEN
C---FIND COLOUR-CONNECTED PARTON
        JC=JMOHEP(1,IHEP)
        IF (IST.NE.152) JC=JMOHEP(1,JC)
        JC =JMOHEP(2,JC)
        IF (JC.EQ.0) CALL HWWARN('HWBCON',51,*20)
C---FIND SPECTATOR WHEN JC IS DECAYED HEAVY QUARK OR SUSY PARTICLE
        IF (ISTHEP(JC).EQ.155) THEN
          IF (IDHEP(JMOHEP(1,JC)).EQ.94) THEN
C---DECAYED BEFORE HADRONIZING
            JHEP=JMOHEP(2,JC)
            IF (JHEP.EQ.0) GO TO 20
            ID=IDHW(JHEP)
            IF (ISTHEP(JHEP).EQ.155) THEN
C---SPECIAL FOR GLUINO DECAYS
              IF (ID.EQ.449) THEN
                ID=IDHW(JC)
C---N.B. WILL NEED MODS WHEN SUSY PARTICLES CAN SHOWER
                IF (ID.EQ.449.OR.ID.EQ.13.OR.
     &             (ID.GE.401.AND.ID.LE.406).OR.
     &             (ID.GE.413.AND.ID.LE.418).OR.
     &             ID.LE.6.OR.(ID.GE.115.AND.ID.LE.120)) THEN
C---LOOK FOR ANTI(S)QUARK OR GLUON
                  DO KC=JDAHEP(1,JHEP),JDAHEP(2,JHEP)
                    ID=IDHW(KC)
                    IF ((ID.GE.  7.AND.ID.LE. 13).OR.
     &                  (ID.GE.407.AND.ID.LE.412).OR.
     &                  (ID.GE.419.AND.ID.LE.424)) GOTO 5
                  ENDDO
                ELSE
C---LOOK FOR (S)QUARK OR GLUON
                  DO KC=JDAHEP(1,JHEP),JDAHEP(2,JHEP)
                    ID=IDHW(KC)
                    IF (ID.LE.  6.OR. ID.EQ. 13.OR.
     &                 (ID.GE.401.AND.ID.LE.406).OR.
     &                 (ID.GE.413.AND.ID.LE.418)) GOTO 5
                  ENDDO
                ENDIF
C---COULDNT FIND ONE
                CALL HWWARN('HWBCON',101,*999)
    5           JC=KC
              ELSE
C--PR MOD 30/6/99 should fix HWCFOR 104 errors
                ID2 = IDHW(IHEP)
                IF(IDHW(JDAHEP(1,JHEP)).EQ.449.AND.
     &             (ID2.LE.6.OR.(ID2.GE.115.AND.ID2.LE.120).OR.
     &             (ID2.GE.401.AND.ID2.LE.406).OR.ID2.EQ.13.OR.
     &             (ID2.GE.413.AND.ID2.LE.418).OR.ID2.EQ.449)) THEN
                  JC = JDAHEP(1,JHEP)
                ELSE
                  JC=JDAHEP(2,JHEP)
                ENDIF
              ENDIF
            ELSEIF (ID.EQ.6.OR.ID.EQ.12.OR.
     &      (ID.GE.209.AND.ID.LE.218).OR.
     &      (ID.GE.401.AND.ID.LE.424).OR.ID.EQ.449) THEN
C Wait for partner heavy quark to decay
C              RETURN
C---N.B. MAY BE A PROBLEM HERE
              GOTO 20
            ELSE
              JMOHEP(2,IHEP)=JHEP
              JDAHEP(2,JHEP)=IHEP
              GOTO 20
            ENDIF
          ELSE
            JC=JMOHEP(2,JC)
          ENDIF
        ENDIF
        JC=JDAHEP(1,JC)
        JD=JDAHEP(2,JC)
C---SEARCH IN CORRESPONDING JET
        IF (JD.LT.JC) JD=JC
        LHEP=0
        DO 10 JHEP=JC,JD
        IF (ISTHEP(JHEP).LT.145.OR.ISTHEP(JHEP).GT.152) GOTO 10
        IF (JDAHEP(2,JHEP).EQ.IHEP) LHEP=JHEP
        IF (JDAHEP(2,JHEP).NE.0) GOTO 10
C---JOIN IHEP AND JHEP
        JMOHEP(2,IHEP)=JHEP
        JDAHEP(2,JHEP)=IHEP
        GOTO 20
   10   CONTINUE
        IF (LHEP.NE.0) THEN
          JMOHEP(2,IHEP)=LHEP
C        ELSE
C---DIDN'T FIND PARTNER OF IHEP YET
C          CALL HWWARN('HWBCON',52,*20)
        ENDIF
      ENDIF
  20  CONTINUE
C---BREAK COLOUR CONNECTIONS WITH PHOTONS
      IHEP=1
  30  IF (IHEP.LE.NHEP) THEN
        IF (IDHW(IHEP).EQ.59 .AND. ISTHEP(IHEP).EQ.149) THEN
C  BRW FIX 13/03/99
          IF (JMOHEP(2,IHEP).NE.0) THEN
            IF (JDAHEP(2,JMOHEP(2,IHEP)).EQ.IHEP)
     &        JDAHEP(2,JMOHEP(2,IHEP))=JDAHEP(2,IHEP)
          ENDIF
C  END FIX
          IF (JDAHEP(2,IHEP).NE.0) THEN
            IF (JMOHEP(2,JDAHEP(2,IHEP)).EQ.IHEP)
     &        JMOHEP(2,JDAHEP(2,IHEP))=JMOHEP(2,IHEP)
          ENDIF
          JMOHEP(2,IHEP)=IHEP
          JDAHEP(2,IHEP)=IHEP
        ENDIF
        IHEP=IHEP+1
        GOTO 30
      ENDIF
  999 END
CDECK  ID>, HWBDED.
*CMZ :-        -22/04/96  13.54.08  by  Mike Seymour
*-- Author :    Mike Seymour
C-----------------------------------------------------------------------
      SUBROUTINE HWBDED(IOPT)
C     FILL MISSING AREA OF DALITZ PLOT WITH 3-JET AND 2-JET+GAMMA EVENTS
C     IF (IOPT.EQ.1) SET UP EVENT RECORD
C     IF (IOPT.EQ.2) CLEAN UP EVENT RECORD AFTER SHOWERING
C
C********MODIFIED 13/11/00 BY BRW TO ALLOW MULTIPLE APPLICATION IN
C*******SAME EVENT (FOR WW AND ZZ) N.B. NO CLEANUP CALLS FOR THESE!
C-----------------------------------------------------------------------
      INCLUDE 'HERWIG62.INC'
      DOUBLE PRECISION HWBVMC,HWRGEN,HWUALF,HWUSQR,X(3),W,WMAX,WSUM,
     & X1MIN,X1MAX,X2MIN,X2MAX,QSCALE,GAMFAC,GLUFAC,R(3,3),CS,SN,M(3),
     & E(3),LAMBDA,A,B,C,PTSQ,EM,P1(5),P2(5),PVRT(4),EPS,MASDEP
      INTEGER ID,ID3,EMIT,NOEMIT,IEVT,IHEP,JHEP,KHEP,ICMF,IOPT,IEDT(3),
     & I,NDEL,LHEP,IP,JP,KP,IDUN
      EXTERNAL HWBVMC,HWRGEN,HWUALF,HWUSQR
      SAVE X,WMAX,P1,P2
      DATA WSUM,WMAX,X1MIN,X1MAX,EMIT,ICMF,IEVT
     & /0.994651,1.84096,0,0.773459,3*0/
      LAMBDA(A,B,C)=(A**2+B**2+C**2-2*A*B-2*B*C-2*C*A)/(4*A)
      IF (IOPT.EQ.1) THEN
C---FIND AN UNTREATED CMF
        IF (IEVT.EQ.NEVHEP+NWGTS) RETURN
        IEVT=0
        ICMF=0
 5      IDUN=ICMF
        DO 10 IHEP=IDUN+1,NHEP
 10       IF (ICMF.EQ.IDUN .AND. ISTHEP(IHEP).EQ.110 .AND.
     &    JDAHEP(2,IHEP).EQ.JDAHEP(1,IHEP)+1) ICMF=IHEP
        IF (ICMF.EQ.IDUN) RETURN
        EM=PHEP(5,ICMF)
        IF (EM.LT.2*HWBVMC(1)) GOTO 5
C---ONLY APPLY THE CORRECTION TO HADRONIC DECAYS
        IF (IDHW(JDAHEP(1,ICMF)).GT.12) GOTO 5
C---GENERATE X1,X2 ACCORDING TO 1/((1-X1)*(1-X2))
 100    CONTINUE
C---CHOOSE X1
        X(1)=1-(1-X1MAX)*((1-X1MIN)/(1-X1MAX))**HWRGEN(0)
C---CHOOSE X2
        X2MIN=MAX(X(1),1-X(1))
        X2MAX=(4*X(1)-3+2*DREAL(  DCMPLX(  X(1)**3+135*(X(1)-1)**3,
     &    3*HWUSQR(3*(128*X(1)**4-368*X(1)**3+405*X(1)**2-216*X(1)+54))*
     &    (X(1)-1)  )**(1./3)  ))/3
        IF (X2MAX.GE.ONE.OR.X2MIN.GE.ONE.OR.X2MAX.LE.X2MIN) GOTO 100
        X(2)=1-(1-X2MAX)*((1-X2MIN)/(1-X2MAX))**HWRGEN(1)
C---CALCULATE WEIGHT
        W=2 * LOG((1-X1MIN)/(1-X1MAX))*LOG((1-X2MIN)/(1-X2MAX)) *
     &    (X(1)**2+X(2)**2)
C---GENERATE UNWEIGHTED (X1,X2) PAIRS (EFFICIENCY IS ~50%)
        IF (WMAX*HWRGEN(2).GT.W) GOTO 100
C---SYMMETRIZE X1,X2
        X(3)=2-X(1)-X(2)
        IF (HWRGEN(5).GT.HALF) THEN
          X(1)=X(2)
          X(2)=2-X(3)-X(1)
        ENDIF
C---CHOOSE WHICH PARTON WILL EMIT
        EMIT=1
        IF (HWRGEN(6).LT.X(1)**2/(X(1)**2+X(2)**2)) EMIT=2
        NOEMIT=3-EMIT
        IHEP=JDAHEP(  EMIT,ICMF)
        JHEP=JDAHEP(NOEMIT,ICMF)
C---PREFACTORS FOR GAMMA AND GLUON CASES
        QSCALE=HWUSQR((1-X(1))*(1-X(2))*(1-X(3)))*EM/X(NOEMIT)
        ID=IDHW(JDAHEP(1,ICMF))
        GAMFAC=ALPFAC*ALPHEM*ICHRG(ID)**2/(18*PIFAC)
        GLUFAC=0
        IF (QSCALE.GT.HWBVMC(13))
     &    GLUFAC=CFFAC/(2*PIFAC)*HWUALF(1,QSCALE)
C---SWITCH OFF PHOTON EMISSION IN W DECAYS (THE M-E DOES NOT FACTORIZE)
        IF (ICHRG(IDHW(ICMF)).NE.0) GAMFAC=0
C---IN FRACTION FAC*WSUM OF EVENTS ADD A GAMMA/GLUON
        IF     (GAMFAC*WSUM .GT. HWRGEN(3)) THEN
          ID3=59
        ELSEIF (GLUFAC*WSUM .GT. HWRGEN(4)) THEN
          ID3=13
        ELSE
          EMIT=0
          GOTO 5
        ENDIF
C---CHECK INFRA-RED CUT-OFF FOR GAMMA/GLUON
        M(EMIT)=PHEP(5,IHEP)+VQCUT
        M(NOEMIT)=PHEP(5,JHEP)+VQCUT
        M(3)=HWBVMC(ID3)
        E(1)=HALF*EM*(X(1)+(M(1)**2-M(2)**2-M(3)**2)/EM**2)
        E(2)=HALF*EM*(X(2)+(M(2)**2-M(3)**2-M(1)**2)/EM**2)
        E(3)=EM-E(1)-E(2)
        PTSQ=-LAMBDA(E(NOEMIT)**2-M(NOEMIT)**2,E(3)**2-M(3)**2,
     &    E(EMIT)**2-M(EMIT)**2)
        IF (PTSQ.LE.ZERO .OR.
     $       E(1).LE.M(1).OR.E(2).LE.M(2).OR.E(3).LE.M(3)) THEN
          EMIT=0
          GOTO 5
        ENDIF
C---CALCULATE MASS-DEPENDENT SUPRESSION
        IF (MOD(IPROC,10).GT.0) THEN
          EPS=(RMASS(ID)/EM)**2
          MASDEP=X(1)**2+X(2)**2
     $         -4*EPS*X(3)-2*EPS*((1-X(2))/(1-X(1))+(1-X(1))/(1-X(2)))
     $         -4*EPS**2*X(3)**2/((1-X(1))*(1-X(2)))
          IF (MASDEP.LT.HWRGEN(7)*(X(1)**2+X(2)**2)) THEN
            EMIT=0
            GOTO 5
          ENDIF
        ENDIF
C---STORE OLD MOMENTA
        CALL HWVEQU(5,PHEP(1,JDAHEP(1,ICMF)),P1)
        CALL HWVEQU(5,PHEP(1,JDAHEP(2,ICMF)),P2)
C---GET THE NON-EMITTING PARTON'S CMF DIRECTION
        CALL HWULOF(PHEP(1,ICMF),PHEP(1,JHEP),PHEP(1,JHEP))
        CALL HWRAZM(ONE,CS,SN)
        CALL HWUROT(PHEP(1,JHEP),CS,SN,R)
        M(EMIT)=PHEP(5,IHEP)
        M(NOEMIT)=PHEP(5,JHEP)
        M(3)=RMASS(ID3)
        KHEP=JDAHEP(2,ICMF)
        LHEP=KHEP+1
        IF (NHEP.GT.KHEP) THEN
C---MOVE UP REST OF EVENT
           DO IP=NHEP,LHEP,-1
              JP=IP+1
              ISTHEP(JP)= ISTHEP(IP)
              IDHW(JP)=IDHW(IP)
              IDHEP(JP)=IDHEP(IP)
              KP=JMOHEP(1,IP)
              IF (KP.GT.KHEP) THEN
                 KP=KP+1
              ELSE
                 IF (JDAHEP(1,KP).EQ.IP) JDAHEP(1,KP)=JP
                 IF (JDAHEP(2,KP).EQ.IP) JDAHEP(2,KP)=JP
              ENDIF
              JMOHEP(1,JP)=KP
              KP=JMOHEP(2,IP)
              IF (KP.GT.KHEP) KP=KP+1
              JMOHEP(2,JP)=KP
              KP=JDAHEP(1,IP)
              IF (KP.GT.KHEP) KP=KP+1
              JDAHEP(1,JP)=KP
              KP=JDAHEP(2,IP)
              IF (KP.GT.KHEP) KP=KP+1
              JDAHEP(2,JP)=KP
              CALL HWVEQU(5,PHEP(1,IP),PHEP(1,JP))
              CALL HWVEQU(4,VHEP(1,IP),VHEP(1,JP))
           ENDDO
        ENDIF
C---REORDER ENTRIES: IHEP=EMITTER, JHEP=NON-EMITTER, KHEP=EMITTED
        NHEP=NHEP+1
        IF (IDHW(IHEP).LT.IDHW(JHEP)) THEN
          IHEP=JDAHEP(1,ICMF)
          JHEP=LHEP
        ELSE
          IHEP=LHEP
          JHEP=JDAHEP(1,ICMF)
        ENDIF
C---SET UP MOMENTA
        PHEP(5,JHEP)=M(NOEMIT)
        PHEP(5,IHEP)=M(EMIT)
        PHEP(5,KHEP)=M(3)
        PHEP(4,JHEP)=HALF*EM*(X(NOEMIT)+
     &                  (M(NOEMIT)**2-M(EMIT)**2-M(3)**2)/EM**2)
        PHEP(4,IHEP)=HALF*EM*(X(EMIT)+
     &                  (M(EMIT)**2-M(NOEMIT)**2-M(3)**2)/EM**2)
        PHEP(4,KHEP)=EM-PHEP(4,IHEP)-PHEP(4,JHEP)
        PHEP(3,JHEP)=HWUSQR(PHEP(4,JHEP)**2-PHEP(5,JHEP)**2)
        PHEP(3,IHEP)=( (PHEP(4,KHEP)**2-PHEP(5,KHEP)**2) -
     &    (PHEP(4,IHEP)**2-PHEP(5,IHEP)**2) -
     &    (PHEP(3,JHEP)**2) )*HALF/PHEP(3,JHEP)
        PHEP(3,KHEP)=-PHEP(3,IHEP)-PHEP(3,JHEP)
        PHEP(2,JHEP)=0
        PHEP(2,IHEP)=0
        PHEP(2,KHEP)=0
        PHEP(1,JHEP)=0
        PHEP(1,IHEP)=HWUSQR(PHEP(4,IHEP)**2-
     &    PHEP(3,IHEP)**2-PHEP(5,IHEP)**2)
        PHEP(1,KHEP)=-PHEP(1,IHEP)
C---ORIENT IN CMF, THEN BOOST TO LAB
        CALL HWUROB(R,PHEP(1,IHEP),PHEP(1,IHEP))
        CALL HWUROB(R,PHEP(1,JHEP),PHEP(1,JHEP))
        CALL HWUROB(R,PHEP(1,KHEP),PHEP(1,KHEP))
        CALL HWULOB(PHEP(1,ICMF),PHEP(1,IHEP),PHEP(1,IHEP))
        CALL HWULOB(PHEP(1,ICMF),PHEP(1,JHEP),PHEP(1,JHEP))
        CALL HWULOB(PHEP(1,ICMF),PHEP(1,KHEP),PHEP(1,KHEP))
C---CALCULATE PRODUCTION VERTICES
        CALL HWVZRO(4,VHEP(1,JHEP))
        CALL HWVSUM(4,PHEP(1,IHEP),PHEP(1,KHEP),PVRT)
        CALL HWUDKL(ID,PVRT,VHEP(1,KHEP))
        CALL HWVEQU(4,VHEP(1,KHEP),VHEP(1,IHEP))
C---REORDER ENTRIES: IHEP=QUARK, JHEP=ANTI-QUARK, KHEP=EMITTED
        IF (IHEP.EQ.LHEP) THEN
          IHEP=JHEP
          JHEP=LHEP
        ENDIF
C---STATUS, ID AND POINTERS
        ISTHEP(JHEP)=114
        IDHW(JHEP)=IDHW(KHEP)
        IDHEP(JHEP)=IDHEP(KHEP)
        IDHW(KHEP)=ID3
        IDHEP(KHEP)=IDPDG(ID3)
        JDAHEP(2,ICMF)=JHEP
        JMOHEP(1,JHEP)=ICMF
        JDAHEP(1,JHEP)=0
C---COLOUR CONNECTIONS AND GLUON POLARIZATION
        JMOHEP(2,JHEP)=IHEP
        JDAHEP(2,IHEP)=JHEP
        IF (ID3.EQ.13) THEN
          JMOHEP(2,IHEP)=KHEP
          JMOHEP(2,KHEP)=JHEP
          JDAHEP(2,JHEP)=KHEP
          JDAHEP(2,KHEP)=IHEP
          GPOLN=((1-X(1))**2+(1-X(2))**2)/(4*(1-X(3)))
          GPOLN=1/(1+GPOLN)
        ELSE
          JMOHEP(2,IHEP)=JHEP
          JMOHEP(2,KHEP)=KHEP
          JDAHEP(2,JHEP)=IHEP
          JDAHEP(2,KHEP)=KHEP
        ENDIF
        IEVT=NEVHEP+NWGTS
        GOTO 5
      ELSEIF (IOPT.EQ.2) THEN
C---MAKE THREE-JET EVENTS FROM THE `DEAD-ZONE' LOOK LIKE TWO-JET EVENTS
        IF (EMIT.EQ.0.OR.IEVT.NE.NEVHEP+NWGTS) THEN
          RETURN
        ELSEIF (EMIT.EQ.1) THEN
          IHEP=JDAHEP(1,JDAHEP(1,ICMF)+1)
          JHEP=JDAHEP(1,JDAHEP(1,ICMF))
        ELSE
          IHEP=JDAHEP(1,JDAHEP(2,ICMF))
          JHEP=JDAHEP(1,JDAHEP(1,ICMF)+1)
          JDAHEP(1,JDAHEP(2,ICMF))=JHEP
          IDHW(JHEP)=IDHW(IHEP)
          IF (ISTHEP(IHEP+1).EQ.100 .AND. ISTHEP(JHEP+1).EQ.100)
     &      CALL HWVEQU(5,PHEP(1,IHEP+1),PHEP(1,JHEP+1))
        ENDIF
        JMOHEP(2,JDAHEP(1,ICMF))=JDAHEP(2,ICMF)
        JDAHEP(2,JDAHEP(1,ICMF))=JDAHEP(2,ICMF)
        JMOHEP(2,JDAHEP(2,ICMF))=JDAHEP(1,ICMF)
        JDAHEP(2,JDAHEP(2,ICMF))=JDAHEP(1,ICMF)
        CALL HWVEQU(5,P1,PHEP(1,JDAHEP(1,ICMF)))
        CALL HWVEQU(5,P2,PHEP(1,JDAHEP(2,ICMF)))
        CALL HWVSUM(4,PHEP(1,IHEP),PHEP(1,JHEP),PHEP(1,JHEP))
        CALL HWUMAS(PHEP(1,JHEP))
        JDAHEP(2,JHEP)=JDAHEP(2,IHEP)
        IEDT(1)=JDAHEP(1,ICMF)+1
        IEDT(2)=IHEP
        IEDT(3)=IHEP+1
        NDEL=3
        IF (ISTHEP(IHEP+1).NE.100) NDEL=2
        CALL HWUEDT(NDEL,IEDT)
        DO 410 I=1,2
          IHEP=JDAHEP(1,JDAHEP(I,ICMF))
          JMOHEP(1,IHEP)=JDAHEP(I,ICMF)
          IF (ISTHEP(IHEP+1).EQ.100) THEN
            JMOHEP(1,IHEP+1)=JMOHEP(1,IHEP)
            JMOHEP(2,IHEP+1)=JMOHEP(2,JMOHEP(1,IHEP))
          ENDIF
          DO 400 JHEP=JDAHEP(1,IHEP),JDAHEP(2,IHEP)
            JMOHEP(1,JHEP)=IHEP
 400      CONTINUE
          CALL HWVZRO(4,VHEP(1,JDAHEP(I,ICMF)))
          CALL HWVZRO(4,VHEP(1,IHEP))
          IF (ISTHEP(IHEP+1).EQ.100) CALL HWVZRO(4,VHEP(1,IHEP+1))
 410    CONTINUE
        EMIT=0
        IEVT=0
      ELSE
        CALL HWWARN('HWBDED',500,*999)
      ENDIF
 999  END
CDECK  ID>, HWBDIS.
*CMZ :-        -17/05/94  09.33.08  by  Mike Seymour
*-- Author :    Mike Seymour
C-----------------------------------------------------------------------
      SUBROUTINE HWBDIS(IOPT)
C-----------------------------------------------------------------------
C     FILL MISSING AREA OF DIS PHASE-SPACE WITH 2+1-JET EVENTS
C     IF (IOPT.EQ.1) SET UP EVENT RECORD
C     IF (IOPT.EQ.2) CLEAN UP EVENT RECORD AFTER SHOWERING
C-----------------------------------------------------------------------
      INCLUDE 'HERWIG62.INC'
      DOUBLE PRECISION HWRGEN,HWBVMC,HWUALF,HWULDO,P1(5),P2(5),P3(5),
     & PCMF(5),L(5),R(3,3),Q,XBJ,RN,XPMIN,XPMAX,XP,ZPMIN,ZPMAX,ZP,FAC,
     & X1,X2,XTSQ,XT,PTSQ,SIN1,SIN2,W1,W2,CFAC,PDFOLD(13),PDFNEW(13),
     & PHI,SCALE,Q1(5),Q2(5),DIR1,DIR2,DIR,PM(5),POLD,PNEW,COMINT,
     & BGFINT,COMWGT,C1,C2,CM,B1,B2,BM,PVRT(4)
      INTEGER IOPT,EMIT,ICMF,IHEP,JHEP,IIN,IOUT,ILEP,IHAD,ID,IDNEW,
     & IEDT(3),NDEL,NTRY,ITEMP
      LOGICAL BGF
      EXTERNAL HWRGEN,HWBVMC,HWUALF,HWULDO
      SAVE BGF,IIN,IOUT,ICMF,ID,Q1,Q2,XP,XBJ
      DATA EMIT,COMINT,BGFINT,COMWGT/0,3.9827,1.2462,0.3/
      DATA C1,C2,CM,B1,B2,BM/0.56,0.20,10,0.667,0.167,3/
      IF (IERROR.NE.0) RETURN
      IF (IOPT.EQ.1) THEN
C---FIND AN UNTREATED CMF
        IF (EMIT.EQ.NEVHEP+NWGTS) RETURN
        ICMF=0
        DO 10 IHEP=1,NHEP
 10       IF (ICMF.EQ.0 .AND. ISTHEP(IHEP).EQ.110 .AND.
     &    JDAHEP(2,IHEP).EQ.JDAHEP(1,IHEP)+1) ICMF=IHEP
        IF (ICMF.EQ.0) RETURN
        IIN=JMOHEP(2,ICMF)
        IOUT=JDAHEP(2,ICMF)
        ILEP=JMOHEP(1,ICMF)
        CALL HWVEQU(5,PHEP(1,IIN),P1)
        CALL HWVEQU(5,PHEP(1,IOUT),P2)
        CALL HWVEQU(5,PHEP(1,ILEP),L)
        IHAD=2
        IF (JDAHEP(1,IHAD).NE.0) IHAD=JDAHEP(1,IHAD)
        ID=IDHW(IIN)
C---STORE OLD MOMENTA
        CALL HWVEQU(5,P1,Q1)
        CALL HWVEQU(5,P2,Q2)
C---BOOST AND ROTATE THE MOMENTA TO THE BREIT FRAME
        CALL HWVDIF(4,P2,P1,PCMF)
        CALL HWUMAS(PCMF)
        CALL HWVEQU(5,PHEP(1,IHAD),PM)
        Q=-PCMF(5)
        XBJ=HALF*Q**2/HWULDO(PM,PCMF)
        CALL HWVSCA(4,HALF/XBJ,PCMF,PCMF)
        CALL HWVSUM(4,PM,PCMF,PCMF)
        CALL HWUMAS(PCMF)
        CALL HWULOF(PCMF,L,L)
        CALL HWULOF(PCMF,PM,PM)
        CALL HWUROT(PM,ONE,ZERO,R)
        CALL HWUROF(R,L,L)
        PHI=ATAN2(L(2),L(1))
        CALL HWUROT(PM,COS(PHI),SIN(PHI),R)
C---CHOOSE THE HADRONIC-PLANE CONFIGURATION, XP,ZP
        IF (HWRGEN(0).LT.COMWGT) THEN
C-----CONSIDER GENERATING A QCD COMPTON EVENT
          BGF=.FALSE.
          P3(5)=RMASS(13)
 100      RN=HWRGEN(1)
          IF (RN.LT.C1) THEN
            ZP=HWRGEN(2)
            XPMAX=MIN(ZP,1-ZP)
            XP=HWRGEN(3)*XPMAX
            FAC=1/C1*2*XPMAX/((1-XP)*(1-ZP))*
     $           (1+(1-XP-ZP+2*XP*ZP)**2+2*(1-XP)*(1-ZP)*XP*ZP)
            IF (HWRGEN(4).LT.HALF) THEN
              ZPMAX=ZP
              ZP=XP
              XP=ZPMAX
            ENDIF
          ELSEIF (RN.LT.C1+C2) THEN
            XPMAX=0.83
            XP=XPMAX*HWRGEN(2)
            ZPMIN=MAX(XP,1-XP)
            ZPMAX=1-2./3.*XP*(1+DREAL( DCMPLX(10-45*XP+18*XP**2,3*SQRT(
     $         3*(9+66*XP-93*XP**2+12*XP**3-8*XP**4+24*XP**5-8*XP**6)))
     $         **(1./3.) * DCMPLX(0.5D0,0.86602540378444D0) ))
            ZP=1-((1-ZPMIN)/(1-ZPMAX))**HWRGEN(4)*(1-ZPMAX)
            FAC=1/C2*XPMAX*LOG((1-ZPMIN)/(1-ZPMAX))/(1-XP)*
     $           (1+(1-XP-ZP+2*XP*ZP)**2+2*(1-XP)*(1-ZP)*XP*ZP)
          ELSE
            ZPMAX=0.85
            ZP=ZPMAX*HWRGEN(2)
            XPMIN=MAX(ZP,1-ZP)
            XPMAX=(1+4*ZP*(1-ZP))/(1+6*ZP*(1-ZP))
            XP=1-((1-XPMIN)/(1-XPMAX))**HWRGEN(4)*(1-XPMAX)
            FAC=1/(1-C1-C2)*ZPMAX*LOG((1-XPMIN)/(1-XPMAX))/(1-ZP)*
     $           (1+(1-XP-ZP+2*XP*ZP)**2+2*(1-XP)*(1-ZP)*XP*ZP)
          ENDIF
          XPMAX=(1+4*ZP*(1-ZP))/(1+6*ZP*(1-ZP))
          ZPMAX=1-2./3.*XP*(1+DREAL( DCMPLX(10-45*XP+18*XP**2,3*SQRT(
     $         3*(9+66*XP-93*XP**2+12*XP**3-8*XP**4+24*XP**5-8*XP**6)))
     $         **(1./3.) * DCMPLX(0.5D0,0.86602540378444D0) ))
          IF (XP.GT.XPMAX.OR.ZP.GT.ZPMAX.OR.CM*HWRGEN(4).GT.FAC)
     $         GOTO 100
        ELSE
C-----CONSIDER GENERATING A BGF EVENT
          BGF=.TRUE.
          P3(5)=P1(5)
          P1(5)=RMASS(13)
 110      RN=HWRGEN(1)
          IF (RN.LT.B1) THEN
            ZP=HWRGEN(2)
            XPMAX=MIN(ZP,1-ZP)
            XP=HWRGEN(3)*XPMAX
            FAC=1/B1*2*XPMAX/(1-ZP)*
     $           ((  XP+ZP-2*XP*ZP)**2+2*(1-XP)*(1-ZP)*XP*ZP
     $           +(1-XP-ZP+2*XP*ZP)**2+2*(1-XP)*(1-ZP)*XP*ZP)
            IF (HWRGEN(4).LT.HALF) XP=1-XP
          ELSEIF (RN.LT.B1+B2) THEN
            XPMAX=0.83
            XP=XPMAX*HWRGEN(2)
            ZPMIN=MAX(XP,1-XP)
            ZPMAX=1-2./3.*XP*(1+DREAL( DCMPLX(10-45*XP+18*XP**2,3*SQRT(
     $         3*(9+66*XP-93*XP**2+12*XP**3-8*XP**4+24*XP**5-8*XP**6)))
     $         **(1./3.) * DCMPLX(0.5D0,0.86602540378444D0) ))
            ZP=1-((1-ZPMIN)/(1-ZPMAX))**HWRGEN(4)*(1-ZPMAX)
            FAC=1/B2*XPMAX*LOG((1-ZPMIN)/(1-ZPMAX))*
     $           ((  XP+ZP-2*XP*ZP)**2+2*(1-XP)*(1-ZP)*XP*ZP
     $           +(1-XP-ZP+2*XP*ZP)**2+2*(1-XP)*(1-ZP)*XP*ZP)
          ELSE
            XPMAX=0.83
            XP=XPMAX*HWRGEN(2)
            ZPMAX=MIN(XP,1-XP)
            ZPMIN=2./3.*XP*(1+DREAL( DCMPLX(10-45*XP+18*XP**2,3*SQRT(
     $         3*(9+66*XP-93*XP**2+12*XP**3-8*XP**4+24*XP**5-8*XP**6)))
     $         **(1./3.) * DCMPLX(0.5D0,0.86602540378444D0) ))
            ZP=(ZPMAX-ZPMIN)*HWRGEN(4)+ZPMIN
            FAC=1/(1-B1-B2)*XPMAX*(ZPMAX-ZPMIN)/(1-ZP)*
     $           ((  XP+ZP-2*XP*ZP)**2+2*(1-XP)*(1-ZP)*XP*ZP
     $           +(1-XP-ZP+2*XP*ZP)**2+2*(1-XP)*(1-ZP)*XP*ZP)
          ENDIF
          ZPMAX=1-2./3.*XP*(1+DREAL( DCMPLX(10-45*XP+18*XP**2,3*SQRT(
     $         3*(9+66*XP-93*XP**2+12*XP**3-8*XP**4+24*XP**5-8*XP**6)))
     $         **(1./3.) * DCMPLX(0.5D0,0.86602540378444D0) ))
          IF (ZP.GT.ZPMAX.OR.ZP.LT.ONE-ZPMAX.OR.BM*HWRGEN(4).GT.FAC)
     $         GOTO 110
        ENDIF
C---CALCULATE THE ADDITIONAL FACTORS IN THE WEIGHT
        IF (BGF) THEN
          IDNEW=13
          CFAC=1./2
          FAC=BGFINT/(1-COMWGT)
        ELSE
          IDNEW=ID
          CFAC=4./3
          FAC=COMINT/COMWGT
        ENDIF
        SCALE=Q*SQRT((1-XP)*(1-ZP)*ZP/XP+1)
        ITEMP=ISTAT
        ISTAT=7
        CALL HWSFUN(XBJ,Q,IDHW(IHAD),NSTRU,PDFOLD,2)
        ISTAT=ITEMP
        IF (PDFOLD(ID).LE.ZERO) CALL HWWARN('HWBDIS',100,*999)
        IF (XP.GT.XBJ) THEN
          CALL HWSFUN(XBJ/XP,SCALE,IDHW(IHAD),NSTRU,PDFNEW,2)
          FAC=CFAC/(2*PIFAC) * HWUALF(1,SCALE) * FAC *
     $         PDFNEW(IDNEW)/PDFOLD(ID)
        ELSE
          FAC=0
        ENDIF
C---FOR PHOTON BEAMS, INCLUDE DIRECT PHOTON COUPLING
        IF (IDHW(IHAD).EQ.59) THEN
          ZPMIN=2./3.*XBJ*(1+DREAL( DCMPLX(10-45*XBJ+18*XBJ**2,3*SQRT(
     $         3*(9+66*XBJ-93*XBJ**2+12*XBJ**3-8*XBJ**4+24*XBJ**5
     $         -8*XBJ**6)))**(1./3.)*DCMPLX(0.5D0,0.86602540378444D0) ))
          ZPMAX=1-ZPMIN
          DIR1=(XBJ**2+(1-XBJ)**2)*(LOG(ZPMAX/ZPMIN)-(ZPMAX-ZPMIN))
          DIR2=4*XBJ*(1-XBJ)*(ZPMAX-ZPMIN)
          DIR=QFCH(MOD(ID-1,6)+1)**2*ALPHEM/(2*PIFAC*PDFOLD(ID))*XBJ
     $         *(DIR1+DIR2)
        ELSE
          DIR=0
        ENDIF
C---DECIDE WHETHER TO MAKE AN EVENT HERE
        IF (HWRGEN(4).GT.FAC+DIR) RETURN
C---FOR DIRECT COUPLING, CHOOSE ZP VALUE
        IF ((FAC+DIR)*HWRGEN(8).GT.FAC) THEN
          IF ((DIR1+DIR2)*HWRGEN(9).LT.DIR1) THEN
            NTRY=0
 120        NTRY=NTRY+2
            ZP=1-(ZPMAX/ZPMIN)**HWRGEN(NTRY+1)*ZPMIN
            IF ((ZPMIN**2+(1-ZPMIN)**2)*HWRGEN(NTRY).GT.ZP**2+(1-ZP)**2)
     $           GOTO 120
          ELSE
            ZP=SQRT((ZPMAX-ZPMIN)*HWRGEN(10)+ZPMIN**2)
          ENDIF
          XP=XBJ
          BGF=.TRUE.
          P3(5)=P2(5)
          P1(5)=0
        ENDIF
        X1=1-   ZP /XP
        X2=1-(1-ZP)/XP
        XTSQ=4*(1-XP)*(1-ZP)*ZP/XP
        XT=SQRT(XTSQ)
        SIN1=XT/SQRT(X1**2+XTSQ)
        SIN2=XT/SQRT(X2**2+XTSQ)
C---CHOOSE THE AZIMUTH BETWEEN THE TWO PLANES
        IF (BGF) THEN
          W1=XP**2*(X1**2+1.5*XTSQ)
        ELSE
          W1=1
        ENDIF
        W2=XP**2*(X2**2+1.5*XTSQ)
        IF (HWRGEN(5)*(W1+W2).GT.W2) THEN
          IF (BGF) THEN
C-----WEIGHTED BY (1+SIN1*COS(PHI))**2
 200        PHI=(2*HWRGEN(6)-1)*PIFAC
            IF (HWRGEN(7)*(1+SIN1)**2.GT.(1+SIN1*COS(PHI))**2) GOTO 200
          ELSE
C-----UNIFORMLY
            PHI=(2*HWRGEN(6)-1)*PIFAC
          ENDIF
        ELSE
C-----WEIGHTED BY (1-SIN2*COS(PHI))**2
 210      PHI=(2*HWRGEN(6)-1)*PIFAC
          IF (HWRGEN(7)*(1+SIN2)**2.GT.(1-SIN2*COS(PHI))**2) GOTO 210
        ENDIF
C---RECONSTRUCT MOMENTA AND BOOST BACK TO LAB
        P1(1)=0
        P1(2)=0
        P1(3)=HALF*Q/XP
        P1(4)=SQRT(P1(3)**2+P1(5)**2)
        PTSQ=((ZP*Q*(P1(4)+P1(3)-Q)-P2(5)**2)*(P1(4)-P1(3)+(1-ZP)*Q)
     $       -P3(5)**2*ZP*Q)/(P1(4)-P1(3)+Q)
C---CHECK INFRARED CUTOFF FOR THIS PARTON TYPE
        IF (PTSQ.LT.MAX(HWBVMC(ID),HWBVMC(IDHW(IOUT)))**2) RETURN
        P2(1)=SQRT(PTSQ)*COS(PHI)
        P2(2)=SQRT(PTSQ)*SIN(PHI)
        P2(3)=-0.5*(ZP*Q-(PTSQ+P2(5)**2)/(ZP*Q))
        P2(4)= 0.5*(ZP*Q+(PTSQ+P2(5)**2)/(ZP*Q))
        P3(1)=P1(1)-P2(1)
        P3(2)=P1(2)-P2(2)
        P3(3)=P1(3)-P2(3)-Q
        P3(4)=P1(4)-P2(4)
        CALL HWUROB(R,P1,P1)
        CALL HWUROB(R,P2,P2)
        CALL HWUROB(R,P3,P3)
        CALL HWULOB(PCMF,P1,P1)
        CALL HWULOB(PCMF,P2,P2)
        CALL HWULOB(PCMF,P3,P3)
C---SPECIAL CASE FOR DIRECT PHOTON - COPY THE EXACT BEAM MOMENTUM
C---SHARE THE MISMATCH EQUALLY BETWEEN THE OUTGOING PARTONS
C---AND PUT THEM BACK ON SHELL
        IF (XP.EQ.XBJ) THEN
          CALL HWVDIF(4,PHEP(1,IHAD),P1,PM)
          CALL HWVSCA(4,HALF,PM,PM)
          CALL HWVSUM(4,PM,P2,P2)
          CALL HWVSUM(4,PM,P3,P3)
          CALL HWUMAS(P2)
          CALL HWUMAS(P3)
          CALL HWVEQU(5,PHEP(1,IHAD),P1)
          CALL HWVSUM(4,P2,P3,PCMF)
          CALL HWUMAS(PCMF)
          POLD=HWULDO(P2,PCMF)**2/PCMF(5)**2-SIGN(P2(5)**2,P2(5))
          PNEW=PCMF(5)**2/4-RMASS(ID)**2
          IF (PCMF(5).LE.ZERO.OR.POLD.LE.ZERO.OR.PNEW.LE.ZERO) RETURN
          CALL HWVSCA(4,SQRT(PNEW/POLD),P2,P2)
          CALL HWVSCA(4,HALF-HWULDO(P2,PCMF)/PCMF(5)**2,PCMF,PM)
          CALL HWVSUM(4,PM,P2,P2)
          CALL HWUMAS(P2)
          CALL HWVDIF(4,PCMF,P2,P3)
          CALL HWUMAS(P3)
        ENDIF
        NHEP=NHEP+1
        CALL HWVEQU(5,P1,PHEP(1,IIN))
        IF (BGF.AND.ID.GT.6.OR..NOT.BGF.AND.ID.LT.7) THEN
          CALL HWVEQU(5,P2,PHEP(1,IOUT))
          CALL HWVEQU(5,P3,PHEP(1,NHEP))
        ELSE
          CALL HWVEQU(5,P3,PHEP(1,IOUT))
          CALL HWVEQU(5,P2,PHEP(1,NHEP))
        ENDIF
        CALL HWVSUM(4,PHEP(1,ILEP),PHEP(1,IIN),PHEP(1,ICMF))
        CALL HWUMAS(PHEP(1,ICMF))
C Decide which quark radiated and assign production vertices
        IF (BGF) THEN
C Boson-Gluon fusion case
          IF (1-ZP.LT.HWRGEN(0)) THEN
C Gluon splitting to quark
            CALL HWVZRO(4,VHEP(1,NHEP-1))
            CALL HWVDIF(4,PHEP(1,NHEP-4),PHEP(1,NHEP),PVRT)
            CALL HWUDKL(ID,PVRT,VHEP(1,NHEP))
            CALL HWVEQU(4,VHEP(1,NHEP),VHEP(1,NHEP-4))
          ELSE
C Gluon splitting to antiquark
            CALL HWVZRO(4,VHEP(1,NHEP))
            CALL HWVDIF(4,PHEP(1,NHEP-4),PHEP(1,NHEP-1),PVRT)
            CALL HWUDKL(ID,PVRT,VHEP(1,NHEP-1))
            CALL HWVEQU(4,VHEP(1,NHEP-1),VHEP(1,NHEP-4))
          ENDIF
        ELSE
C QCD Compton case
          IF (1.LT.HWRGEN(0)*(1+(1-XP-ZP)**2+6*XP*(1-XP)*ZP*(1-ZP)))THEN
C Incoming quark radiated the gluon
            CALL HWVZRO(4,VHEP(1,NHEP-1))
            CALL HWVDIF(4,PHEP(1,NHEP-4),PHEP(1,NHEP),PVRT)
            CALL HWUDKL(ID,PVRT,VHEP(1,NHEP))
            CALL HWVEQU(4,VHEP(1,NHEP),VHEP(1,NHEP-4))
          ELSE
C Outgoing quark radiated the gluon
            CALL HWVZRO(4,VHEP(1,NHEP-4))
            CALL HWVSUM(4,PHEP(1,NHEP-1),PHEP(1,NHEP),PVRT)
            CALL HWUDKL(ID,PVRT,VHEP(1,NHEP))
            CALL HWVEQU(4,VHEP(1,NHEP),VHEP(1,NHEP-1))
          ENDIF
        ENDIF
C---STATUS, ID AND POINTERS
        ISTHEP(NHEP)=114
        IF (BGF) THEN
          IF (XP.EQ.XBJ) THEN
            IDHW(IIN)=59
            IDHEP(IIN)=IDPDG(59)
          ELSE
            IDHW(IIN)=13
            IDHEP(IIN)=IDPDG(13)
          ENDIF
          IF (ID.LT.7) THEN
            IDHW(NHEP)=IDHW(IOUT)
            IDHEP(NHEP)=IDHEP(IOUT)
            IDHW(IOUT)=MOD(ID,6)+6
            IDHEP(IOUT)=IDPDG(IDHW(IOUT))
          ELSE
            IDHW(NHEP)=MOD(ID,6)
            IDHEP(NHEP)=IDPDG(IDHW(NHEP))
          ENDIF
        ELSEIF (ID.LT.7) THEN
          IDHW(NHEP)=13
          IDHEP(NHEP)=IDPDG(13)
        ELSE
          IDHW(NHEP)=IDHW(IOUT)
          IDHEP(NHEP)=IDHEP(IOUT)
          IDHW(IOUT)=13
          IDHEP(IOUT)=IDPDG(13)
        ENDIF
        JDAHEP(2,ICMF)=NHEP
        JMOHEP(1,NHEP)=ICMF
C---COLOUR CONNECTIONS
        IF (XP.EQ.XBJ) THEN
          JMOHEP(2,IIN)=IIN
          JDAHEP(2,IIN)=IIN
          JMOHEP(2,IOUT)=NHEP
          JDAHEP(2,IOUT)=NHEP
          JMOHEP(2,NHEP)=IOUT
          JDAHEP(2,NHEP)=IOUT
        ELSE
          JDAHEP(2,IIN)=NHEP
          JDAHEP(2,NHEP)=IOUT
          JMOHEP(2,IOUT)=NHEP
          JMOHEP(2,NHEP)=IIN
        ENDIF
C---FACTORISATION SCALE
        EMSCA=SCALE
        EMIT=NEVHEP+NWGTS
      ELSEIF (IOPT.EQ.2) THEN
C---MAKE TWO-JET EVENTS LOOK LIKE ONE-JET EVENTS
        IF (EMIT.NE.NEVHEP+NWGTS .OR. XP.EQ.XBJ) RETURN
        IF (.NOT.BGF) THEN
          CALL HWVEQU(5,Q1,PHEP(1,IIN))
          CALL HWVEQU(5,Q2,PHEP(1,IOUT))
          JMOHEP(2,IIN)=IOUT
          JDAHEP(2,IIN)=IOUT
          JMOHEP(2,IOUT)=IIN
          JDAHEP(2,IOUT)=IIN
          JDAHEP(2,ICMF)=IOUT
          IHEP=JDAHEP(1,IOUT)
          JHEP=JDAHEP(1,IOUT+1)
          CALL HWVSUM(4,PHEP(1,IHEP),PHEP(1,JHEP),PHEP(1,IHEP))
          CALL HWUMAS(PHEP(1,IHEP))
          JDAHEP(2,IHEP)=JDAHEP(2,JHEP)
          IEDT(1)=IOUT+1
          IEDT(2)=JHEP
          IEDT(3)=JHEP+1
          NDEL=3
          IF (ISTHEP(JHEP+1).NE.100) NDEL=2
          IHEP=JDAHEP(1,IOUT)
          JMOHEP(1,IHEP)=IOUT
          IF (ISTHEP(IHEP+1).EQ.100) THEN
            JMOHEP(1,IHEP+1)=IOUT
            JMOHEP(2,IHEP+1)=IIN
          ENDIF
          DO 300 JHEP=JDAHEP(1,IHEP),JDAHEP(2,IHEP)
            JMOHEP(1,JHEP)=IHEP
 300      CONTINUE
          IF (IDHW(IOUT).EQ.13) IDHW(IOUT)=IDHW(IOUT+1)
          IDHEP(IOUT)=IDPDG(IDHW(IOUT))
          IDHW(IHEP)=IDHW(IOUT)
          CALL HWUEDT(NDEL,IEDT)
        ELSEIF (ID.LT.7) THEN
          CALL HWVEQU(5,Q1,PHEP(1,IIN))
          CALL HWVEQU(5,Q2,PHEP(1,IOUT+1))
          JMOHEP(2,IIN)=IOUT+1
          JDAHEP(2,IIN)=IOUT+1
          JMOHEP(2,IOUT+1)=IIN
          JDAHEP(2,IOUT+1)=IIN
          JDAHEP(2,ICMF)=IOUT+1
          IHEP=JDAHEP(1,IIN)
          JHEP=JDAHEP(1,IOUT)
          CALL HWVDIF(4,PHEP(1,IHEP),PHEP(1,JHEP),PHEP(1,IHEP))
          CALL HWUMAS(PHEP(1,IHEP))
          CALL HWVDIF(4,PHEP(1,ICMF),PHEP(1,JHEP),PHEP(1,ICMF))
          CALL HWUMAS(PHEP(1,ICMF))
          CALL HWUEMV(JDAHEP(2,JHEP)-JDAHEP(1,JHEP)+1,
     $         JDAHEP(1,JHEP),JDAHEP(2,IHEP))
          JHEP=JDAHEP(1,IOUT)
          JDAHEP(2,IHEP)=JDAHEP(2,JHEP)
          IEDT(1)=IOUT
          IEDT(2)=JHEP
          IEDT(3)=JHEP+1
          NDEL=3
          IF (ISTHEP(JHEP+1).NE.100) NDEL=2
          CALL HWUEDT(NDEL,IEDT)
          IHEP=JDAHEP(1,IIN)
          DO 400 JHEP=JDAHEP(1,IHEP),JDAHEP(2,IHEP)
            JMOHEP(1,JHEP)=IHEP
 400      CONTINUE
          IDHW(IIN)=ID
          IDHEP(IIN)=IDPDG(ID)
          IDHW(IHEP)=ID
        ELSE
          CALL HWVEQU(5,Q1,PHEP(1,IIN))
          CALL HWVEQU(5,Q2,PHEP(1,IOUT))
          JMOHEP(2,IIN)=IOUT
          JDAHEP(2,IIN)=IOUT
          JMOHEP(2,IOUT)=IIN
          JDAHEP(2,IOUT)=IIN
          JDAHEP(2,ICMF)=IOUT
          IHEP=JDAHEP(1,IIN)
          JHEP=JDAHEP(1,IOUT+1)
          CALL HWVDIF(4,PHEP(1,IHEP),PHEP(1,JHEP),PHEP(1,IHEP))
          CALL HWUMAS(PHEP(1,IHEP))
          CALL HWVDIF(4,PHEP(1,ICMF),PHEP(1,JHEP),PHEP(1,ICMF))
          CALL HWUMAS(PHEP(1,ICMF))
          CALL HWUEMV(JDAHEP(2,JHEP)-JDAHEP(1,JHEP)+1,
     $         JDAHEP(1,JHEP),JDAHEP(1,IHEP)-1)
          JHEP=JDAHEP(1,IOUT+1)
          JDAHEP(1,IHEP)=JDAHEP(1,JHEP)
          IEDT(1)=IOUT+1
          IEDT(2)=JHEP
          IEDT(3)=JHEP+1
          NDEL=3
          IF (ISTHEP(JHEP+1).NE.100.OR.JHEP.EQ.NHEP) NDEL=2
          CALL HWUEDT(NDEL,IEDT)
          IHEP=JDAHEP(1,IIN)
          DO 500 JHEP=JDAHEP(1,IHEP),JDAHEP(2,IHEP)
            JMOHEP(1,JHEP)=IHEP
 500      CONTINUE
          IDHW(IIN)=ID
          IDHEP(IIN)=IDPDG(ID)
          IDHW(IHEP)=ID
        ENDIF
        CALL HWVZRO(4,VHEP(1,IIN))
        CALL HWVZRO(4,VHEP(1,JDAHEP(1,IIN)))
        IF (ISTHEP(JDAHEP(1,IIN)+1).EQ.100)
     $       CALL HWVZRO(4,VHEP(1,JDAHEP(1,IIN)+1))
        CALL HWVZRO(4,VHEP(1,IOUT))
        CALL HWVZRO(4,VHEP(1,JDAHEP(1,IOUT)))
        IF (ISTHEP(JDAHEP(1,IOUT)+1).EQ.100)
     $       CALL HWVZRO(4,VHEP(1,JDAHEP(1,IOUT)+1))
        EMIT=0
      ELSE
        CALL HWWARN('HWBDIS',500,*999)
      ENDIF
 999  END
CDECK  ID>, HWBDYP.
*CMZ :-        -26/10/99  17.46.56  by  Mike Seymour
*-- Author :    Gennaro Corcella
C-----------------------------------------------------------------------
      SUBROUTINE HWBDYP(IOPT)
C     MATRIX ELEMENT CORRECTIONS TO DRELL-YAN PROCESSES
C-----------------------------------------------------------------------
      INCLUDE 'HERWIG62.INC'
      DOUBLE PRECISION HWBVMC,HWRGEN,HWUALF,HWUSQR,PMODK,AZ,CZ,
     & T,U,S,EM,TMIN,TMAX,PMOD2,GLUFAC,SMIN,SMAX,SZ,TEST,
     & JAC,M(3),W1,W,PMOD3,SCAPR,CPHI,SPHI,SCALE,XI1,XI2,
     & PDFOLD1(13),PDFOLD2(13),PDFNEW1(13),PDFNEW2(13),ETA1,ETA2,Y,
     & COMWGT1,COMWGT2,WW,COS3,MODP,RN,BETA1,SIN3,R3(3,3),CTH,STH,M1,
     & M2,M3,GAMMA1,R5(3,3),CW,SW,R4(3,3),SCALE1,X1,X2,X3,MM,
     & PHAD1(5),PHAD2(5),P1(5),P2(5),P3(5),P4(5),PF(5),PV(5),PK(5),
     & PR(5),PNE(5),PE(5),PP1(5),PP2(5),PZ(5),PS(5),PD(5),P2N(5),
     & PBOS(5),PLAB(5),PTOT(5),P3N(5),SVNTN
      LOGICAL GLUIN,GP
      INTEGER EMIT,NOEMIT,IHEP,JHEP,KHEP,ICMF,IOPT,CHEP,
     & ID2,ID1,K,ID4,ID5,IDBOS,IHAD1,IHAD2,NTMP
      EXTERNAL HWBVMC,HWRGEN,HWUALF,HWUSQR
      SAVE PS,PF,ICMF,ID4,ID5
      DATA EMIT,NTMP/2*0/
      IF (IOPT.EQ.1) THEN
        EMIT=0
        NTMP=0
C-----CHOOSE WEIGHTS
        COMWGT1=0.1
        COMWGT2=0.55
C---FIND AN UNTREATED CMF
        ICMF=0
        DO 10 IHEP=1,NHEP
 10     IF (ICMF.EQ.0 .AND. ISTHEP(IHEP).EQ.110.AND.
     &         JDAHEP(2,IHEP).EQ.JDAHEP(1,IHEP)+1) ICMF=IHEP
        IF (ICMF.EQ.0) RETURN
        EM=PHEP(5,ICMF)
C-----SET THE VECTOR BOSON RAPIDITY
        Y=HALF*LOG((PHEP(4,ICMF)+PHEP(3,ICMF))/
     &       (PHEP(4,ICMF)-PHEP(3,ICMF)))
C------SET PARTICLE IDENTIES
c------ID1=QUARK, ID2=ANTIQUARK, IDBOS=VECTOR BOSON, ID4-5 BOSON DECAY
        IDBOS=IDHW(ICMF)
        ID1=IDHW(JMOHEP(1,ICMF))
        ID2=IDHW(JMOHEP(2,ICMF))
        ID4=IDHW(JDAHEP(1,ICMF))
        ID5=IDHW(JDAHEP(2,ICMF))
        M1=RMASS(ID1)
        M2=RMASS(ID2)
        M3=RMASS(13)
C---STORE OLD MOMENTA
C------VECTOR BOSON MOMENTUM
        CALL HWVEQU(5,PHEP(1,ICMF),PBOS)
C----QUARK MOMENTUM
        CALL HWVEQU(5,PHEP(1,JMOHEP(1,ICMF)),P1)
C------ANTIQUARK MOMENTUM
        CALL HWVEQU(5,PHEP(1,JMOHEP(2,ICMF)),P2)
C-------VECTOR DECAY (LEPTON) PRODUCT MOMENTA
        CALL HWVEQU(5,PHEP(1,JDAHEP(1,ICMF)),P3)
        CALL HWVEQU(5,PHEP(1,JDAHEP(2,ICMF)),P4)
C------LEPTON MOMENTA IN THE BOSON REST FRAME
        CALL HWULOF(PHEP(1,ICMF),P2,P2N)
        CALL HWULOF(PHEP(1,ICMF),P3,P3N)
C------AZ=AZIMUTHAL ANGLE OF P3N
        AZ=ATAN2(P3N(2),P3N(1))
        CZ=COS(AZ)
        SZ=SIN(AZ)
C------PHI=ANGLE BETWEEN P2N AND P3N
        SCAPR=P2N(1)*P3N(1)+P2N(2)*P3N(2)+P2N(3)*P3N(3)
        PMOD2=SQRT(P2N(1)**2+P2N(2)**2+P2N(3)**2)
        PMOD3=SQRT(P3N(1)**2+P3N(2)**2+P3N(3)**2)
        CPHI=SCAPR/(PMOD3*PMOD2)
        SPHI=SQRT(1-CPHI**2)
C------HADRON MOMENTA
        IHAD1=1
        IHAD2=2
        IF (JDAHEP(1,IHAD1).NE.0) IHAD1=JDAHEP(1,IHAD1)
        IF (JDAHEP(1,IHAD2).NE.0) IHAD2=JDAHEP(1,IHAD2)
        CALL HWVEQU(5,PHEP(1,IHAD1),PHAD1)
        CALL HWVEQU(5,PHEP(1,IHAD2),PHAD2)
        CALL HWVSUM(4,PHAD1,PHAD2,PTOT)
        CALL HWUMAS(PTOT)
C------ Q - QBAR ENERGY FRACTIONS (BORN PROCESS)
        ETA1=P1(4)/PHAD1(4)
        ETA2=P2(4)/PHAD2(4)
C------ PDFs FOR THE BORN PROCESS
        CALL HWSFUN(ETA1,EM,IDHW(IHAD1),NSTRU,PDFOLD1,1)
        CALL HWSFUN(ETA2,EM,IDHW(IHAD2),NSTRU,PDFOLD2,2)
C-------CONSIDER Q(QBAR) IN THE INITIAL STATE
        RN=HWRGEN(9)
        IF (RN.LT.COMWGT1) THEN
C-------NO GLUON IN THE INITIAL STATE
          GLUIN=.FALSE.
C---CHOOSE S ACCORDING TO 1/S**2
          SVNTN=17
          SMIN=HALF*EM**2*(7-SQRT(SVNTN))
          SMAX=PTOT(5)**2
          IF (SMAX.LE.SMIN) RETURN
          S=SMIN*SMAX/(SMIN+HWRGEN(0)*(SMAX-SMIN))
          JAC=S**2*(1/SMIN-1/SMAX)
C---CHOOSE T ACCORDING TO (S-EM**2)/(T*U)=1/T+1/U
          TMAX=-HALF*EM**2*(3-HWUSQR(1+8*EM**2/S))
          TMIN=EM**2-S-TMAX
          IF (TMAX.LE.TMIN) RETURN
          T=TMAX*(TMIN/TMAX)**HWRGEN(1)
          IF (HWRGEN(2).GT.HALF) T=EM**2-S-T
          U=EM**2-S-T
          JAC=JAC*2*T*U/(S-EM**2)*LOG(TMIN/TMAX)
          SCALE=SQRT(U*T/S)
          SCALE1=SQRT(U*T/S+EM**2)
          GLUFAC=0
          IF (SCALE1.GT.HWBVMC(13)) GLUFAC=HWUALF(1,SCALE1)/(2*PIFAC)
C----Q-QBAR ENERGY FRACTIONS FOR Q QBAR-> VG
          XI1=(HALF/PHAD1(4))*EXP(Y)*SQRT(S*(S+T)/(S+U))
          XI2=S/(4*XI1*PHAD1(4)*PHAD2(4))
          IF (XI1.GE.1.OR.XI2.GE.1) RETURN
C-----PDFs WITH AN EMITTED GLUON
          CALL HWSFUN(XI1,SCALE,IDHW(IHAD1),NSTRU,PDFNEW1,1)
          CALL HWSFUN(XI2,SCALE,IDHW(IHAD2),NSTRU,PDFNEW2,2)
C------CALCULATE WEIGHT
          W=JAC*((EM**2-T)**2+(EM**2-U)**2)/(S**2*T*U)
          W1=(GLUFAC/COMWGT1)*W*PDFNEW1(ID1)*PDFNEW2(ID2)/(PDFOLD1(ID1)*
     &         PDFOLD2(ID2))*(CFFAC*ETA1*ETA2/(XI1*XI2))
C-------CHOOSE WHICH PARTON WILL EMIT
          EMIT=1
          IF (HWRGEN(6).LT.(EM**2-U)**2/((EM**2-U)**2+(EM**2-T)**2))
     &         EMIT=2
          NOEMIT=3-EMIT
        ELSE
C--------GLUON IN THE INITIAL STATE
          GLUIN=.TRUE.
C---CHOOSE S ACCORDING TO 1/S**2
          SMIN=EM**2
          SMAX=PTOT(5)**2
          IF (SMAX.LE.SMIN) RETURN
          S=SMIN*SMAX/(SMIN+HWRGEN(0)*(SMAX-SMIN))
          JAC=S**2*(1/SMIN-1/SMAX)
C---CHOOSE T ACCORDING TO 1/T
          TMAX=-HALF*EM**2*(3-HWUSQR(1+8*EM**2/S))
          TMIN=EM**2-S
          IF (TMAX.LE.TMIN) RETURN
          T=TMAX*(TMIN/TMAX)**HWRGEN(1)
          JAC=JAC*T*LOG(TMAX/TMIN)
          U=EM**2-S-T
          SCALE=SQRT(U*T/S)
          SCALE1=SQRT(U*T/S+EM**2)
          GLUFAC=0
          IF (SCALE1.GT.HWBVMC(13)) GLUFAC=HWUALF(1,SCALE1)/(2*PIFAC)
C--------INITIAL STATE GLUON COMING FROM HADRON 1
          IF (RN.LE.COMWGT2) THEN
            GP=.TRUE.
C--------ENERGY FRACTIONS and PDFs
            XI1=(HALF/PHAD1(4))*EXP(Y)*SQRT(S*(S+U)/(S+T))
            XI2=S/(4*XI1*PHAD1(4)*PHAD2(4))
            IF (XI1.GE.1.OR.XI2.GE.1) RETURN
            CALL HWSFUN(XI1,SCALE,IDHW(IHAD1),NSTRU,PDFNEW1,1)
            CALL HWSFUN(XI2,SCALE,IDHW(IHAD2),NSTRU,PDFNEW2,2)
            WW=PDFNEW1(13)*PDFNEW2(ID2)/((COMWGT2-COMWGT1)*
     &           PDFOLD1(ID1)*PDFOLD2(ID2))
          ELSE
C-------INITIAL STATE GLUON COMING FROM HADRON 2
            GP=.FALSE.
C-------ENERGY FRACTIONS AND PDFs
            XI1=(HALF/PHAD1(4))*EXP(Y)*SQRT(S*(S+T)/(S+U))
            XI2=S/(4*XI1*PHAD1(4)*PHAD2(4))
            IF (XI1.GE.1.OR.XI2.GE.1) RETURN
            CALL HWSFUN(XI1,SCALE,IDHW(IHAD1),NSTRU,PDFNEW1,1)
            CALL HWSFUN(XI2,SCALE,IDHW(IHAD2),NSTRU,PDFNEW2,2)
            WW=PDFNEW1(ID1)*PDFNEW2(13)/((1-COMWGT2)*
     &           PDFOLD1(ID1)*PDFOLD2(ID2))
          ENDIF
          W=-HALF*JAC*((EM**2-T)**2+(EM**2-S)**2)/(S**3*T)
C-------CHOOSE WHICH PARTON WILL EMIT
          EMIT=1
          IF (HWRGEN(10).LT.(EM**2-S)**2/((EM**2-S)**2+(EM**2-T)**2))
     &         EMIT=2
          NOEMIT=3-EMIT
C-------FINAL WEIGHT FOR ALL THE CONSIDERED OPTIONS
          W1=GLUFAC*W*WW*ETA1*ETA2/(XI1*XI2)
        ENDIF
C--------ADD ONE MORE GLUON
        IF (W1.GT.HWRGEN(4)) THEN
          NTMP=NEVHEP+NWGTS
        ELSE
          RETURN
        ENDIF
C---------INCLUDE MASSES
        S=S+M1**2+M2**2+M3**2
        IF (.NOT.GLUIN) THEN
          TEST=((S+M1**2-M2**2)*(S+M3**2-EM**2)-2*S*(M1**2+M3**2-T))**2
     $         -((S-M1**2-M2**2)**2-4*M1**2*M2**2)*
     $         ((S-M3**2-EM**2)**2-4*M3**2*EM**2)
        ELSEIF (GP) THEN
          TEST=((S+M3**2-M2**2)*(S+M1**2-EM**2)-2*S*(M3**2+M1**2-T))**2
     $         -((S-M3**2-M2**2)**2-4*M3**2*M2**2)*
     $         ((S-M1**2-EM**2)**2-4*M1**2*EM**2)
        ELSE
          TEST=((S+M3**2-M1**2)*(S+M2**2-EM**2)-2*S*(M3**2+M2**2-T))**2
     $         -((S-M3**2-M1**2)**2-4*M3**2*M1**2)*
     $         ((S-M2**2-EM**2)**2-4*M2**2*EM**2)
        ENDIF
        IF (TEST.GE.0) THEN
          EMIT=0
          RETURN
        ENDIF
        M(1)=M1
        M(2)=M2
        M(3)=M3
C----MOMENTA IN THE V-REST FRAME WITH NON EMITTER ALONG THE Z AXIS
C----V=BOSON,K=GLUON,E=EMITTER,NE=NON-EMITTER
        PV(1)=0
        PV(2)=0
        PV(3)=0
        PV(4)=EM
        PV(5)=EM
        PNE(2)=0
        PNE(1)=0
        IF (.NOT.GLUIN) THEN
          PK(4)=(S-M(3)**2-EM**2)/(2*EM)
          PMODK=SQRT(PK(4)**2-M(3)**2)
          IF (EMIT.EQ.1) THEN
            MM=M(1)
            X1=T
            X2=U
            X3=-1
          ELSE
            MM=M(2)
            X1=U
            X2=T
            X3=+1
          ENDIF
          PNE(4)=(EM**2+MM**2-X1)/(2*EM)
          PNE(3)=X3*SQRT(PNE(4)**2-MM**2)
          COS3=HALF*(X2-MM**2-M(3)**2+2*PNE(4)*PK(4))/(PNE(3)*PMODK)
        ELSE
          PK(4)=(EM**2+M(3)**2-U)/(2*EM)
          PMODK=SQRT(PK(4)**2-M(3)**2)
          IF (EMIT.EQ.1) THEN
            IF (GP) THEN
              MM=M(1)
              X3=+1
            ELSE
              MM=M(2)
              X3=-1
            ENDIF
            PNE(4)=(S-MM**2-EM**2)/(2*EM)
            PNE(3)=X3*SQRT(PNE(4)**2-MM**2)
            COS3=HALF*(T-MM**2-M(3)**2+2*PNE(4)*PK(4))/(PNE(3)*PMODK)
          ELSE
            IF (GP) THEN
              MM=M(2)
              X3=-1
            ELSE
              MM=M(1)
              X3=+1
            ENDIF
            PNE(4)=(EM**2+MM**2-T)/(2*EM)
            PNE(3)=X3*SQRT(PNE(4)**2-MM**2)
            COS3=HALF*(MM**2+M(3)**2-S+2*PNE(4)*PK(4))/(PNE(3)*PMODK)
          ENDIF
        ENDIF
        CALL HWUMAS(PNE)
        SIN3=SQRT(1-COS3**2)
C---------DEFINE A RANDOM ROTATION AROUND THE Z-AXIS
        CALL HWRAZM(PMODK*SIN3,PK(1),PK(2))
        PK(3)=PMODK*COS3
        CALL HWUMAS(PK)
        DO K=1,4
          IF (.NOT.GLUIN) THEN
            PE(K)=PV(K)+PK(K)-PNE(K)
          ELSE
            IF (EMIT.EQ.1) THEN
              PE(K)=PV(K)+PNE(K)-PK(K)
            ELSE
              PE(K)=PNE(K)+PK(K)-PV(K)
            ENDIF
          ENDIF
        ENDDO
        CALL HWUMAS(PE)
c------LEPTON MOMENTA IN THE BOSON REST FRAME, WITH THE DIRECTION
C------TAKEN FROM THE BORN PROCESS
        PS(5)=P3(5)
        PS(4)=(EM**2+P3(5)**2-P4(5)**2)/(2*EM)
        PS(3)=-SQRT(PS(4)**2-P3(5)**2)*CPHI
        PS(2)=SQRT(PS(4)**2-P3(5)**2)*SPHI*SZ
        PS(1)=SQRT(PS(4)**2-P3(5)**2)*SPHI*CZ
        PF(5)=P4(5)
        PF(4)=(EM**2+P4(5)**2-P3(5)**2)/(2*EM)
        PF(3)=-PS(3)
        PF(2)=-PS(2)
        PF(1)=-PS(1)
C----FIND A STATIONARY VECTOR PLAB IN THE LAB FRAME
        IF (.NOT.GLUIN) THEN
          IF (EMIT.EQ.1) THEN
            CALL HWVEQU(5,PE,PP1)
            CALL HWVEQU(5,PNE,PP2)
          ELSE
            CALL HWVEQU(5,PNE,PP1)
            CALL HWVEQU(5,PE,PP2)
          ENDIF
        ELSE
          IF (GP) THEN
            CALL HWVEQU(5,PK,PP1)
            IF (EMIT.EQ.1) THEN
              CALL HWVEQU(5,PE,PP2)
            ELSE
              CALL HWVEQU(5,PNE,PP2)
            ENDIF
          ELSE
            CALL HWVEQU(5,PK,PP2)
            IF (EMIT.EQ.1) THEN
              CALL HWVEQU(5,PE,PP1)
            ELSE
              CALL HWVEQU(5,PNE,PP1)
            ENDIF
          ENDIF
        ENDIF
        CALL HWVSCA(4,1/XI1,PP1,PP1)
        CALL HWVSCA(4,1/XI2,PP2,PP2)
        CALL HWVSUM(4,PP1,PP2,PLAB)
        CALL HWUMAS(PLAB)
C------BOOST TO PLAB REST FRAME
        CALL HWULOF(PLAB,PE,PE)
        CALL HWULOF(PLAB,PNE,PNE)
        CALL HWULOF(PLAB,PK,PK)
        CALL HWULOF(PLAB,PS,PS)
        CALL HWULOF(PLAB,PF,PF)
        CALL HWULOF(PLAB,PV,PV)
C----PUT THE INITIAL PARTON BELONGING TO HADRON 1 ON THE Z-AXIS
        IF (.NOT.GLUIN) THEN
          IF (EMIT.EQ.1) THEN
            CALL HWVEQU(5,PE,PZ)
          ELSE
            CALL HWVEQU(5,PNE,PZ)
          ENDIF
        ELSE
          IF (GP) THEN
            CALL HWVEQU(5,PK,PZ)
          ELSE
            IF (EMIT.EQ.1) THEN
              CALL HWVEQU(5,PE,PZ)
            ELSE
              CALL HWVEQU(5,PNE,PZ)
            ENDIF
          ENDIF
        ENDIF
        MODP=SQRT(PZ(1)**2+PZ(2)**2)
        CTH=PZ(1)/MODP
        STH=PZ(2)/MODP
        CALL HWUROT(PZ,CTH,STH,R3)
C-----ROTATE EVERYTHING BY R3
        CALL HWUROF(R3,PE,PE)
        CALL HWUROF(R3,PNE,PNE)
        CALL HWUROF(R3,PV,PV)
        CALL HWUROF(R3,PK,PK)
        CALL HWUROF(R3,PS,PS)
        CALL HWUROF(R3,PF,PF)
C--REORDER ENTRIES:--IHEP=EMITTER,JHEP=NON-EMITTER,KHEP=EMITTED
        IF (.NOT.GLUIN) THEN
          IHEP=JMOHEP(EMIT,ICMF)
          JHEP=JMOHEP(NOEMIT,ICMF)
        ENDIF
        CHEP=ICMF
        IDHW(CHEP)=15
        IDHEP(CHEP)=IDPDG(15)
        ICMF=ICMF+1
        IDHW(ICMF)=IDBOS
        IDHEP(ICMF)=IDPDG(IDBOS)
C-----NO GLUON IN THE INITIAL STATE: JUST ADD IT AFTER THE VECTOR BOSON
        IF (.NOT.GLUIN) THEN
          KHEP=ICMF+1
          ISTHEP(KHEP)=114
C---STATUS OF EMITTER/NON EMITTER
          ISTHEP(IHEP)=110+EMIT
          ISTHEP(JHEP)=110+NOEMIT
        ELSE
C-----GLUON COMING FROM THE 1ST HADRON
          IF (GP) THEN
            KHEP=CHEP-2
            ISTHEP(KHEP)=111
C----EMIT=1
            IF (EMIT.EQ.1) THEN
              IHEP=KHEP+1
              ISTHEP(IHEP)=112
              JHEP=ICMF+1
              ISTHEP(JHEP)=114
              IDHW(IHEP)=ID2
              IF (ID1.LE.6) THEN
                IDHW(JHEP)=ID1+6
              ELSE
                IDHW(JHEP)=ID1-6
              ENDIF
            ELSE
C-------EMIT=2
              JHEP=KHEP+1
              ISTHEP(JHEP)=112
              IDHW(JHEP)=ID2
              IHEP=ICMF+1
              ISTHEP(IHEP)=114
              IF (ID1.LE.6) THEN
                IDHW(IHEP)=ID1+6
              ELSE
                IDHW(IHEP)=ID1-6
              ENDIF
            ENDIF
          ENDIF
C------GLUON COMING FROM THE HADRON 2
          IF (.NOT.GP) THEN
            KHEP=CHEP-1
            ISTHEP(KHEP)=112
C-------EMIT=1
            IF (EMIT.EQ.1) THEN
              IHEP=KHEP-1
              ISTHEP(IHEP)=111
              IDHW(IHEP)=ID1
              JHEP=ICMF+1
              ISTHEP(JHEP)=114
              IF (ID2.LE.6) THEN
                IDHW(JHEP)=ID2+6
              ELSE
                IDHW(JHEP)=ID2-6
              ENDIF
            ELSE
C-------EMIT=2
              JHEP=KHEP-1
              ISTHEP(JHEP)=111
              IDHW(JHEP)=ID1
              IHEP=ICMF+1
              ISTHEP(IHEP)=114
              IF (ID2.LE.6) THEN
                IDHW(IHEP)=ID2+6
              ELSE
                IDHW(IHEP)=ID2-6
              ENDIF
            ENDIF
          ENDIF
        ENDIF
        IDHEP(IHEP)=IDPDG(IDHW(IHEP))
        IDHEP(JHEP)=IDPDG(IDHW(JHEP))
        ISTHEP(ICMF)=113
        ISTHEP(CHEP)=110
        IDHW(KHEP)=13
        IDHEP(KHEP)=IDPDG(13)
C---------DEFINE MOMENTA IN THE LAB FRAME
        CALL HWVEQU(5,PV,PHEP(1,ICMF))
        CALL HWVEQU(5,PK,PHEP(1,KHEP))
        CALL HWVEQU(5,PNE,PHEP(1,JHEP))
        CALL HWVEQU(5,PE,PHEP(1,IHEP))
        IF (.NOT.GLUIN) THEN
          CALL HWVSUM(4,PHEP(1,IHEP),PHEP(1,JHEP),PHEP(1,CHEP))
        ELSE
          IF (EMIT.EQ.1) THEN
            CALL HWVSUM(4,PHEP(1,IHEP),PHEP(1,KHEP),PHEP(1,CHEP))
          ELSE
            CALL HWVSUM(4,PHEP(1,KHEP),PHEP(1,JHEP),PHEP(1,CHEP))
          ENDIF
        ENDIF
        CALL HWUMAS(PHEP(1,CHEP))
        IF (.NOT.GLUIN) THEN
          JMOHEP(1,JHEP)=CHEP
          JMOHEP(1,IHEP)=CHEP
          JDAHEP(1,JHEP)=CHEP
          JDAHEP(1,IHEP)=CHEP
          JMOHEP(1,KHEP)=CHEP
          JDAHEP(1,KHEP)=0
          JMOHEP(1,ICMF)=CHEP
          JMOHEP(2,ICMF)=ICMF
          JDAHEP(1,ICMF)=0
          JDAHEP(2,ICMF)=ICMF
        ENDIF
        IF (GLUIN) THEN
          JMOHEP(2,ICMF)=ICMF
          JDAHEP(2,ICMF)=ICMF
          JMOHEP(1,KHEP)=CHEP
          JDAHEP(1,KHEP)=CHEP
          JMOHEP(1,IHEP)=CHEP
          JMOHEP(1,JHEP)=CHEP
          IF (EMIT.EQ.1) THEN
            JDAHEP(1,IHEP)=CHEP
            JDAHEP(1,JHEP)=0
          ELSE
            JDAHEP(1,JHEP)=CHEP
            JDAHEP(1,IHEP)=0
          ENDIF
        ENDIF
C---COLOUR CONNECTIONS
        IF (.NOT.GLUIN) THEN
          IF (IDHW(IHEP).LT.IDHW(JHEP)) THEN
            JMOHEP(2,KHEP)=IHEP
            JDAHEP(2,KHEP)=JHEP
            JMOHEP(2,IHEP)=JHEP
            JDAHEP(2,IHEP)=KHEP
            JDAHEP(2,JHEP)=IHEP
            JMOHEP(2,JHEP)=KHEP
          ELSE
            JMOHEP(2,KHEP)=JHEP
            JDAHEP(2,KHEP)=IHEP
            JMOHEP(2,JHEP)=IHEP
            JDAHEP(2,JHEP)=KHEP
            JDAHEP(2,IHEP)=JHEP
            JMOHEP(2,IHEP)=KHEP
          ENDIF
        ENDIF
        IF (GLUIN) THEN
          IF (EMIT.EQ.1) THEN
            IF (IDHEP(IHEP).GT.0) THEN
              JMOHEP(2,IHEP)=JHEP
              JDAHEP(2,IHEP)=KHEP
              JMOHEP(2,JHEP)=KHEP
              JDAHEP(2,JHEP)=IHEP
              JMOHEP(2,KHEP)=IHEP
              JDAHEP(2,KHEP)=JHEP
            ELSE
              JMOHEP(2,IHEP)=KHEP
              JDAHEP(2,IHEP)=JHEP
              JMOHEP(2,JHEP)=IHEP
              JDAHEP(2,JHEP)=KHEP
              JMOHEP(2,KHEP)=JHEP
              JDAHEP(2,KHEP)=IHEP
            ENDIF
          ELSE
            IF (IDHEP(JHEP).GT.0) THEN
              JMOHEP(2,JHEP)=IHEP
              JDAHEP(2,JHEP)=KHEP
              JMOHEP(2,IHEP)=KHEP
              JDAHEP(2,IHEP)=JHEP
              JMOHEP(2,KHEP)=JHEP
              JDAHEP(2,KHEP)=IHEP
            ELSE
              JMOHEP(2,JHEP)=KHEP
              JDAHEP(2,JHEP)=IHEP
              JMOHEP(2,IHEP)=JHEP
              JDAHEP(2,IHEP)=KHEP
              JMOHEP(2,KHEP)=IHEP
              JDAHEP(2,KHEP)=JHEP
            ENDIF
          ENDIF
        ENDIF
        EMSCA=SQRT(EM**2+PHEP(1,ICMF)**2+PHEP(2,ICMF)**2)
C--------SET STATUS AND LEPTON MOMENTA AFTER THE PARTON SHOWER
      ELSEIF (IOPT.EQ.2) THEN
        IF (EMIT.EQ.0.OR.NEVHEP+NWGTS.NE.NTMP) RETURN
        ISTHEP(JDAHEP(1,ICMF))=195
        IDHW(NHEP+1)=ID4
        IDHW(NHEP+2)=ID5
        IDHEP(NHEP+1)=IDPDG(ID4)
        IDHEP(NHEP+2)=IDPDG(ID5)
        ISTHEP(NHEP+1)=113
        ISTHEP(NHEP+2)=114
        CW=PHEP(3,ICMF)/SQRT(PHEP(1,ICMF)**2+PHEP(2,ICMF)**2+
     &       PHEP(3,ICMF)**2)
        SW=SQRT(1-CW**2)
        CALL HWUROT(PHEP(1,ICMF),CW,SW,R4)
        CALL HWUROF(R4,PHEP(1,ICMF),PR)
        PR(4)=PHEP(4,ICMF)
        CALL HWUMAS(PR)
        CALL HWUROF(R4,PS,PS)
        CALL HWUROF(R4,PF,PF)
        CALL HWUMAS(PS)
        CALL HWUMAS(PF)
        CALL HWUROT(PHEP(1,JDAHEP(1,ICMF)),CW,SW,R5)
        CALL HWUROF(R5,PHEP(1,JDAHEP(1,ICMF)),PD)
        PD(4)=PHEP(4,JDAHEP(1,ICMF))
        CALL HWUMAS(PD)
        BETA1=(PR(4)*PR(3)-SQRT(PR(4)**2*PD(3)**2-PR(3)**2*PD(3)**2+
     &       PD(3)**4))/(PD(3)**2+PR(4)**2)
        GAMMA1=1/SQRT(1-BETA1**2)
        PHEP(4,NHEP+1)=GAMMA1*PS(4)-BETA1*GAMMA1*PS(3)
        PHEP(3,NHEP+1)=-BETA1*GAMMA1*PS(4)+GAMMA1*PS(3)
        PHEP(4,NHEP+2)=GAMMA1*PF(4)-BETA1*GAMMA1*PF(3)
        PHEP(3,NHEP+2)=-BETA1*GAMMA1*PF(4)+GAMMA1*PF(3)
        PHEP(1,NHEP+1)=PS(1)
        PHEP(2,NHEP+1)=PS(2)
        PHEP(1,NHEP+2)=PF(1)
        PHEP(2,NHEP+2)=PF(2)
        CALL HWUMAS(PHEP(1,NHEP+1))
        CALL HWUMAS(PHEP(1,NHEP+2))
        CALL HWUROB(R5,PHEP(1,NHEP+1),PHEP(1,NHEP+1))
        CALL HWUROB(R5,PHEP(1,NHEP+2),PHEP(1,NHEP+2))
        JDAHEP(1,JDAHEP(1,ICMF))=NHEP+1
        JDAHEP(2,JDAHEP(1,ICMF))=NHEP+2
        JMOHEP(1,NHEP+1)=JDAHEP(1,ICMF)
        JMOHEP(1,NHEP+2)=JDAHEP(1,ICMF)
        JMOHEP(2,NHEP+1)=NHEP+2
        JDAHEP(2,NHEP+1)=NHEP+2
        JMOHEP(2,NHEP+2)=NHEP+1
        JDAHEP(2,NHEP+2)=NHEP+1
        NHEP=NHEP+2
        EMIT=0
      ENDIF
      END
CDECK  ID>, HWBFIN.
*CMZ :-        -26/04/91  10.18.56  by  Bryan Webber
*-- Author :    Bryan Webber
C-----------------------------------------------------------------------
      SUBROUTINE HWBFIN(IHEP)
C-----------------------------------------------------------------------
C     DELETES INTERNAL LINES FROM SHOWER, MAKES COLOUR CONNECTION INDEX
C     AND COPIES INTO /HEPEVT/ IN COLOUR ORDER.
C-----------------------------------------------------------------------
      INCLUDE 'HERWIG62.INC'
      INTEGER IHEP,ID,IJET,KHEP,IPAR,JPAR,NXPAR,IP,JP
      IF (IERROR.NE.0) RETURN
C---SAVE VIRTUAL PARTON DATA
      NHEP=NHEP+1
      IF(NHEP.GT.NMXHEP) CALL HWWARN('HWBFIN',100,*999)
      ID=IDPAR(2)
      IDHW(NHEP)=ID
      IDHEP(NHEP)=IDPDG(ID)
      ISTHEP(NHEP)=ISTHEP(IHEP)+20
      JMOHEP(1,NHEP)=IHEP
      JMOHEP(2,NHEP)=JMOHEP(1,IHEP)
      JDAHEP(1,IHEP)=NHEP
      JDAHEP(1,NHEP)=0
      JDAHEP(2,NHEP)=0
      CALL HWVEQU(5,PPAR(1,2),PHEP(1,NHEP))
      CALL HWVEQU(4,VPAR(1,2),VHEP(1,NHEP))
C---FINISHED FOR SPECTATOR OR NON-PARTON JETS
      IF (ISTHEP(NHEP).GT.136) RETURN
      IF (ID.GT.13.AND.ID.LT.209 .AND. ID.NE.59) RETURN
      IF (ID.GT.220.AND.ABS(IDPDG(ID)).LT.1000000) RETURN
      IF (ID.GT.424.AND.ID.NE.449) RETURN
      IF (.NOT.TMPAR(2).AND.ID.EQ.59) RETURN
      IDHEP(NHEP)=94
      IJET=NHEP
      IF (NPAR.GT.2) THEN
C---SAVE CONE DATA
        NHEP=NHEP+1
        IF(NHEP.GT.NMXHEP) CALL HWWARN('HWBFIN',101,*999)
        IDHW(NHEP)=IDPAR(1)
        IDHEP(NHEP)=0
        ISTHEP(NHEP)=100
        JMOHEP(1,NHEP)=IHEP
        JMOHEP(2,NHEP)=JCOPAR(1,1)
        JDAHEP(1,NHEP)=0
        JDAHEP(2,NHEP)=0
        CALL HWVEQU(5,PPAR,PHEP(1,NHEP))
        CALL HWVEQU(4,VPAR(1,2),VHEP(1,NHEP))
      ENDIF
      KHEP=NHEP
C---START WITH ANTICOLOUR DAUGHTER OF HARDEST PARTON
      IPAR=2
      JPAR=JCOPAR(4,IPAR)
      NXPAR=NPAR/2
      DO 20 IP=1,NXPAR
      DO 10 JP=1,NXPAR
      IF (JPAR.EQ.0) GOTO 15
      IF (JCOPAR(2,JPAR).EQ.IPAR) THEN
        IPAR=JPAR
        JPAR=JCOPAR(4,IPAR)
      ELSE
        IPAR=JPAR
        JPAR=JCOPAR(1,IPAR)
      ENDIF
   10 CONTINUE
C---COULDN'T FIND COLOUR PARTNER
      CALL HWWARN('HWBFIN',1,*999)
   15 JPAR=JCOPAR(1,IPAR)
      KHEP=KHEP+1
      IF(KHEP.GT.NMXHEP) CALL HWWARN('HWBFIN',102,*999)
      ID=IDPAR(IPAR)
      IF (TMPAR(IPAR)) THEN
        IF (ID.LT.14) THEN
          ISTHEP(KHEP)=139
        ELSEIF (ID.EQ.59) THEN
          ISTHEP(KHEP)=139
        ELSEIF (ID.LT.109) THEN
          ISTHEP(KHEP)=130
        ELSEIF (ID.LT.120) THEN
          ISTHEP(KHEP)=139
        ELSEIF (ABS(IDPDG(ID)).LT.1000000) THEN
          ISTHEP(KHEP)=130
        ELSEIF (ID.LT.425) THEN
          ISTHEP(KHEP)=139
        ELSEIF (ID.EQ.449) THEN
          ISTHEP(KHEP)=139
        ELSE
          ISTHEP(KHEP)=130
        ENDIF
      ELSE
        ISTHEP(KHEP)=ISTHEP(IHEP)+24
      ENDIF
      IDHW(KHEP)=ID
      IDHEP(KHEP)=IDPDG(ID)
      CALL HWVEQU(5,PPAR(1,IPAR),PHEP(1,KHEP))
      CALL HWVEQU(4,VPAR(1,IPAR),VHEP(1,KHEP))
      JMOHEP(1,KHEP)=IJET
      JMOHEP(2,KHEP)=KHEP+1
      JDAHEP(1,KHEP)=0
      JDAHEP(2,KHEP)=KHEP-1
   20 CONTINUE
      JMOHEP(2,KHEP)=0
      JDAHEP(2,NHEP+1)=0
      JDAHEP(1,IJET)=NHEP+1
      JDAHEP(2,IJET)=KHEP
      NHEP=KHEP
  999 END
CDECK  ID>, HWBGEN.
*CMZ :-        -14/10/99  18.04.56  by  Mike Seymour
*-- Author :    Bryan Webber
C-----------------------------------------------------------------------
      SUBROUTINE HWBGEN
C-----------------------------------------------------------------------
C     BRANCHING GENERATOR WITH INTERFERING GLUONS
C     HWBGEN EVOLVES QCD JETS ACCORDING TO THE METHOD OF
C     G.MARCHESINI & B.R.WEBBER, NUCL. PHYS. B238(1984)1
C-----------------------------------------------------------------------
      INCLUDE 'HERWIG62.INC'
      DOUBLE PRECISION HWULDO,HWRGAU,EINHEP,ERTXI,RTXI,XF
      INTEGER NTRY,LASHEP,IHEP,NRHEP,ID,IST,JHEP,KPAR,I,J,IRHEP(NMXJET),
     & IRST(NMXJET),JPR
      LOGICAL HWRLOG
      EXTERNAL HWULDO,HWRGAU
      IF (IERROR.NE.0) RETURN
      IF (IPRO.EQ.80) RETURN
C---CHECK THAT EMSCA IS SET
      IF (EMSCA.LE.ZERO) CALL HWWARN('HWBGEN',200,*999)
      IF (HARDME) THEN
C---FORCE A BRANCH INTO THE `DEAD ZONE' IN E+E-
        JPR=IPROC/10
C**********13/11/00 BRW FIX TO ALLOW ALSO WW AND ZZ
        IF (JPR.EQ.10.OR.JPR.EQ.20.OR.JPR.EQ.25) CALL HWBDED(1)
C**********END FIX
C---FORCE A BRANCH INTO THE `DEAD ZONE' IN DIS
        IF (IPRO.EQ.90) CALL HWBDIS(1)
C---FORCE A BRANCH INTO THE `DEAD ZONE' IN DRELL-YAN PROCESSES
        IF (IPRO.EQ.13.OR.IPRO.EQ.14) CALL HWBDYP(1)
C---FORCE A BRANCH INTO THE `DEAD ZONE' IN TOP DECAYS
        CALL HWBTOP
      ENDIF
C---GENERATE INTRINSIC PT ONCE AND FOR ALL
      DO 5 JNHAD=1,2
        IF (PTRMS.NE.0.) THEN
          PTINT(1,JNHAD)=HWRGAU(1,ZERO,PXRMS)
          PTINT(2,JNHAD)=HWRGAU(2,ZERO,PXRMS)
          PTINT(3,JNHAD)=PTINT(1,JNHAD)**2+PTINT(2,JNHAD)**2
        ELSE
          CALL HWVZRO(3,PTINT(1,JNHAD))
        ENDIF
 5    CONTINUE
      NTRY=0
      LASHEP=NHEP
 10   NTRY=NTRY+1
      IF (NTRY.GT.NETRY) CALL HWWARN('HWBGEN',ISLENT*100,*999)
      NRHEP=0
      NHEP=LASHEP
      FROST=.FALSE.
      DO 100 IHEP=1,LASHEP
      IST=ISTHEP(IHEP)
      IF (IST.GE.111.AND.IST.LE.115) THEN
       NRHEP=NRHEP+1
       IRHEP(NRHEP)=IHEP
       IRST(NRHEP)=IST
       ID=IDHW(IHEP)
       IF (IST.NE.115) THEN
C---FOUND A PARTON TO EVOLVE
        NEVPAR=IHEP
        NPAR=2
        IDPAR(1)=17
        IDPAR(2)=ID
        TMPAR(1)=.TRUE.
        PPAR(2,1)=0.
        PPAR(4,1)=1.
        DO 15 J=1,2
        DO 15 I=1,2
        JMOPAR(I,J)=0
 15     JCOPAR(I,J)=0
C---SET UP EVOLUTION SCALE AND FRAME
        JHEP=JMOHEP(2,IHEP)
        IF (ID.EQ.13) THEN
          IF (HWRLOG(HALF)) JHEP=JDAHEP(2,IHEP)
        ELSEIF (IST.GT.112) THEN
          IF ((ID.GT.6.AND.ID.LT.13).OR.
     &        (ID.GT.214.AND.ID.LT.221)) JHEP=JDAHEP(2,IHEP)
        ELSE
          IF (ID.LT.7.OR.(ID.GT.208.AND.ID.LT.215)) JHEP=JDAHEP(2,IHEP)
        ENDIF
        IF (JHEP.LE.0.OR.JHEP.GT.NHEP) THEN
          CALL HWWARN('HWBGEN',1,*999)
          JHEP=IHEP
        ENDIF
        JCOPAR(1,1)=JHEP
        EINHEP=PHEP(4,IHEP)
        ERTXI=HWULDO(PHEP(1,IHEP),PHEP(1,JHEP))
        IF (ERTXI.LT.ZERO) ERTXI=0.
        IF (IST.LE.112.AND.IHEP.EQ.JHEP) ERTXI=0.
        IF (ISTHEP(JHEP).EQ.155) THEN
          ERTXI=ERTXI/PHEP(5,JHEP)
          RTXI=1.
        ELSE
          ERTXI=SQRT(ERTXI)
          RTXI=ERTXI/EINHEP
        ENDIF
        IF (RTXI.EQ.ZERO) THEN
          XF=1.
          PPAR(1,1)=0.
          PPAR(3,1)=1.
          PPAR(1,2)=EINHEP
          PPAR(2,2)=0.
          PPAR(4,2)=EINHEP
        ELSE
          XF=1./RTXI
          PPAR(1,1)=1.
          PPAR(3,1)=0.
          PPAR(1,2)=ERTXI
          PPAR(2,2)=1.
          PPAR(4,2)=ERTXI
        ENDIF
        IF (PPAR(4,2).LT.PHEP(5,IHEP)) PPAR(4,2)=PHEP(5,IHEP)
C---STORE MASS
        PPAR(5,2)=PHEP(5,IHEP)
        CALL HWVZRO(4,VPAR(1,1))
        CALL HWVZRO(4,VPAR(1,2))
        IF (IST.GT.112) THEN
          TMPAR(2)=.TRUE.
          INHAD=0
          JNHAD=0
          XFACT=0.
        ELSE
          TMPAR(2)=.FALSE.
          JNHAD=IST-110
          INHAD=JNHAD
          IF (JDAHEP(1,JNHAD).NE.0) INHAD=JDAHEP(1,JNHAD)
          XFACT=XF/PHEP(4,INHAD)
          ANOMSC(1,JNHAD)=ZERO
          ANOMSC(2,JNHAD)=ZERO
        ENDIF
C---FOR QUARKS IN A COLOUR SINGLET, ALLOW SOFT MATRIX-ELEMENT CORRECTION
        HARDST=PPAR(4,2)
        IF (SOFTME.AND.IDHW(IHEP).LT.13.AND.
     $       ((JMOHEP(2,JHEP).EQ.IHEP.AND.JDAHEP(2,JHEP).EQ.IHEP).OR.
     $       ISTHEP(JHEP).EQ.155)) HARDST=0
C---CREATE BRANCHES AND COMPUTE ENERGIES
        DO 20 KPAR=2,NMXPAR
        IF (TMPAR(KPAR)) THEN
          CALL HWBRAN(KPAR)
        ELSE
          CALL HWSBRN(KPAR)
        ENDIF
        IF (IERROR.NE.0) RETURN
        IF (FROST) GOTO 100
        IF (KPAR.EQ.NPAR) GOTO 30
 20     CONTINUE
C---COMPUTE MASSES AND 3-MOMENTA
 30     CONTINUE
        CALL HWBMAS
        IF (AZSPIN) CALL HWBSPN
        IF (TMPAR(2)) THEN
           CALL HWBTIM(2,1)
        ELSE
           CALL HWBSPA
        ENDIF
C---ENTER PARTON JET IN /HEPEVT/
        CALL HWBFIN(IHEP)
       ELSE
C---COPY SPECTATOR
        NHEP=NHEP+1
        IF (ID.GT.120.AND.ID.LT.133 .OR. ID.GE.198.AND.ID.LE.201) THEN
          ISTHEP(NHEP)=190
        ELSE
          ISTHEP(NHEP)=152
        ENDIF
        IDHW(NHEP)=ID
        IDHEP(NHEP)=IDPDG(ID)
        JMOHEP(1,NHEP)=IHEP
        JMOHEP(2,NHEP)=0
        JDAHEP(2,NHEP)=0
        JDAHEP(1,IHEP)=NHEP
        CALL HWVEQU(5,PHEP(1,IHEP),PHEP(1,NHEP))
       ENDIF
       ISTHEP(IHEP)=ISTHEP(IHEP)+10
      ENDIF
 100  CONTINUE
      IF (.NOT.FROST) THEN
C---COMBINE JETS
        ISTAT=20
        CALL HWBJCO
      ENDIF
      IF (.NOT.FROST) THEN
C---ATTACH SPECTATORS
        ISTAT=30
        CALL HWSSPC
      ENDIF
      IF (FROST) THEN
C---BAD JET: RESTORE PARTONS AND RE-EVOLVE
         DO 120 I=1,NRHEP
 120     ISTHEP(IRHEP(I))=IRST(I)
         GOTO 10
      ENDIF
C---CONNECT COLOURS
      CALL HWBCON
      ISTAT=40
      LASHEP=NHEP
      IF (HARDME) THEN
C---CLEAN UP IF THERE WAS A BRANCH IN THE `DEAD ZONE' IN E+E-
        IF (IPROC/10.EQ.10) CALL HWBDED(2)
C---CLEAN UP IF THERE WAS A BRANCH IN THE `DEAD ZONE' IN DIS
        IF (IPRO.EQ.90) CALL HWBDIS(2)
C---CLEAN UP IF THERE WAS A BRANCH IN THE `DEAD ZONE' IN DRELL-YAN PROC
        IF (IPRO.EQ.13.OR.IPRO.EQ.14) CALL HWBDYP(2)
      ENDIF
C---IF THE CLEAN-UP OPERATION ADDED ANY PARTONS TO THE EVENT RECORD
C   IT MIGHT NEED RESHOWERING
      IF (NHEP.GT.LASHEP) THEN
        LASHEP=NHEP
        GOTO 10
      ENDIF
 999  END
CDECK  ID>, HWBJCO.
*CMZ :-        -26/04/91  14.25.31  by  Federico Carminati
*-- Author :    Bryan Webber
C-----------------------------------------------------------------------
      SUBROUTINE HWBJCO
C-----------------------------------------------------------------------
C     COMBINES JETS WITH REQUIRED KINEMATICS
C-----------------------------------------------------------------------
      INCLUDE 'HERWIG62.INC'
      DOUBLE PRECISION HWULDO,EPS,PTX,PTY,PF,PTINF,PTCON,CN,CP,SP,PP0,
     & PM0,ET0,DET,ECM,EMJ,EMP,EMS,DMS,ES,DPF,ALF,AL(2),ET(2),PP(2),
     & PT(3),PB(5),PC(5),PQ(5),PR(5),PS(5),RR(3,3),RS(3,3),ETC,
     & PJ(NMXJET),PM(NMXJET),PBR(5),RBR(3,3),DISP(4),PLAB(5)
      INTEGER LJET,IJ1,IST,IP,ICM,IP1,IP2,NP,IHEP,MHEP,JP,KP,LP,KHEP,
     & JHEP,NE,IJT,IEND(2),IJET(NMXJET),IPAR(NMXJET)
      LOGICAL AZCOR,JETRAD,DISPRO,DISLOW
      EXTERNAL HWULDO
      PARAMETER (EPS=1.D-4)
      IF (IERROR.NE.0) RETURN
      AZCOR=AZSOFT.OR.AZSPIN
C---FIRST LOOK FOR SPACELIKE JETS
      LJET=131
  10  IJET(1)=1
  20  IJ1=IJET(1)
      DO 40 IHEP=IJ1,NHEP
      IST=ISTHEP(IHEP)
      IF (IST.EQ.137.OR.IST.EQ.138) IST=133
      IF (IST.EQ.LJET) THEN
C---FOUND AN UNBOOSTED JET - FIND PARTNERS
        IP=JMOHEP(1,IHEP)
        ICM=JMOHEP(1,IP)
        DISPRO=IPRO/10.EQ.9.AND.IDHW(ICM).EQ.15
        DISLOW=DISPRO.AND.JDAHEP(1,ICM).EQ.JDAHEP(2,ICM)-1
        IF (IST.EQ.131) THEN
          IP1=JMOHEP(1,ICM)
          IP2=JMOHEP(2,ICM)
        ELSE
          IP1=JDAHEP(1,ICM)
          IP2=JDAHEP(2,ICM)
        ENDIF
        IF (IP1.NE.IP) CALL HWWARN('HWBJCO',100,*999)
        NP=0
        DO 30 JHEP=IP1,IP2
        NP=NP+1
        IPAR(NP)=JHEP
  30    IJET(NP)=JDAHEP(1,JHEP)
        GOTO 50
      ENDIF
  40  CONTINUE
C---NO MORE JETS?
      IF (LJET.EQ.131) THEN
        LJET=133
        GOTO 10
      ENDIF
      RETURN
  50  IF (LJET.EQ.131) THEN
C---SPACELIKE JETS: FIND SPACELIKE PARTONS
        IF (NP.NE.2) CALL HWWARN('HWBJCO',103,*999)
C---special for DIS: FIND BOOST AND ROTATION FROM LAB TO BREIT FRAME
        IF (DISPRO.AND.BREIT) THEN
          IP=2
          IF (JDAHEP(1,IP).NE.0) IP=JDAHEP(1,IP)
          CALL HWVDIF(4,PHEP(1,JMOHEP(1,ICM)),PHEP(1,JDAHEP(1,ICM)),PB)
          CALL HWUMAS(PB)
C---IF Q**2<10**-2, SOMETHING MUST HAVE ALREADY GONE WRONG
          IF (PB(5)**2.LT.1.D-2) CALL HWWARN('HWBJCO',102,*999)
          CALL HWVSCA(4,PB(5)**2/HWULDO(PHEP(1,IP),PB),PHEP(1,IP),PBR)
          CALL HWVSUM(4,PB,PBR,PBR)
          CALL HWUMAS(PBR)
          CALL HWULOF(PBR,PB,PB)
          CALL HWUROT(PB,ONE,ZERO,RBR)
        ENDIF
        PTX=0.
        PTY=0.
        PF=1.D0
        DO 90 IP=1,2
        MHEP=IJET(IP)
        IF (JDAHEP(1,MHEP).EQ.0) THEN
C---SPECIAL FOR NON-PARTON JETS
          IHEP=MHEP
          GOTO 70
        ELSE
          IST=134+IP
          DO 60 IHEP=MHEP,NHEP
  60      IF (ISTHEP(IHEP).EQ.IST) GOTO 70
C---COULDN'T FIND SPACELIKE PARTON
          CALL HWWARN('HWBJCO',101,*999)
        ENDIF
  70    CALL HWVSCA(3,PF,PHEP(1,IHEP),PS)
        IF (PTINT(3,IP).GT.ZERO) THEN
C---ADD INTRINSIC PT
          PT(1)=PTINT(1,IP)
          PT(2)=PTINT(2,IP)
          PT(3)=0.
          CALL HWUROT(PS, ONE,ZERO,RS)
          CALL HWUROB(RS,PT,PT)
          CALL HWVSUM(3,PS,PT,PS)
        ENDIF
        JP=IJET(IP)+1
        IF (AZCOR.AND.JP.LE.NHEP.AND.IDHW(JP).EQ.17) THEN
C---ALIGN CONE WITH INTERFERING PARTON
          CALL HWUROT(PS, ONE,ZERO,RS)
          CALL HWUROF(RS,PHEP(1,JP),PR)
          PTCON=PR(1)**2+PR(2)**2
          KP=JMOHEP(2,JP)
          IF (KP.EQ.0) THEN
            CALL HWWARN('HWBJCO',1,*999)
            PTINF=0.
          ELSE
            CALL HWVEQU(4,PHEP(1,KP),PB)
            IF (DISPRO.AND.BREIT) THEN
              CALL HWULOF(PBR,PB,PB)
              CALL HWUROF(RBR,PB,PB)
            ENDIF
            PTINF=PB(1)**2+PB(2)**2
            IF (PTINF.LT.EPS) THEN
C---COLLINEAR JETS: ALIGN CONES
              KP=JDAHEP(1,KP)+1
              IF (ISTHEP(KP).EQ.100.AND.ISTHEP(KP-1)/10.EQ.14) THEN
                CALL HWVEQU(4,PHEP(1,KP),PB)
                IF (DISPRO.AND.BREIT) THEN
                  CALL HWULOF(PBR,PB,PB)
                  CALL HWUROF(RBR,PB,PB)
                ENDIF
                PTINF=PB(1)**2+PB(2)**2
              ELSE
                PTINF=0.
              ENDIF
            ENDIF
          ENDIF
          IF (PTCON.NE.ZERO.AND.PTINF.NE.ZERO) THEN
            CN=1./SQRT(PTINF*PTCON)
            CP=CN*(PR(1)*PB(1)+PR(2)*PB(2))
            SP=CN*(PR(1)*PB(2)-PR(2)*PB(1))
          ELSE
            CALL HWRAZM( ONE,CP,SP)
          ENDIF
        ELSE
          CALL HWRAZM( ONE,CP,SP)
        ENDIF
C---ROTATE SO SPACELIKE IS ALONG AXIS (APART FROM INTRINSIC PT)
        CALL HWUROT(PS,CP,SP,RS)
        IHEP=IJET(IP)
        KHEP=JDAHEP(2,IHEP)
        IF (KHEP.LT.IHEP) KHEP=IHEP
        IEND(IP)=KHEP
        DO 80 JHEP=IHEP,KHEP
        CALL HWUROF(RS,PHEP(1,JHEP),PHEP(1,JHEP))
  80    CALL HWUROF(RS,VHEP(1,JHEP),VHEP(1,JHEP))
        PP(IP)=PHEP(4,IHEP)+PF*PHEP(3,IHEP)
        ET(IP)=PHEP(1,IHEP)**2+PHEP(2,IHEP)**2-PHEP(5,IHEP)**2
C---REDEFINE HARD CM
        PTX=PTX+PHEP(1,IHEP)
        PTY=PTY+PHEP(2,IHEP)
  90    PF=-PF
        PHEP(1,ICM)=PTX
        PHEP(2,ICM)=PTY
C---special for DIS: keep lepton momenta fixed
        IF (DISPRO) THEN
          IP1=JMOHEP(1,ICM)
          IP2=JDAHEP(1,ICM)
          IJT=IJET(1)
C---IJT will be used to store lepton momentum transfer
          CALL HWVDIF(4,PHEP(1,IP1),PHEP(1,IP2),PHEP(1,IJT))
          CALL HWUMAS(PHEP(1,IJT))
          IF (IDHEP(IP1).EQ.IDHEP(IP2)) THEN
            IDHW(IJT)=200
          ELSEIF (IDHEP(IP1).LT.IDHEP(IP2)) THEN
            IDHW(IJT)=199
          ELSE
            IDHW(IJT)=198
          ENDIF
          IDHEP(IJT)=IDPDG(IDHW(IJT))
          ISTHEP(IJT)=3
C---calculate boost for struck parton
C   PC is momentum of outgoing parton(s)
          IP2=JDAHEP(2,ICM)
          IF (.NOT.DISLOW) THEN
C---FOR heavy QQbar PQ and PC are old and new QQbar momenta
            CALL HWVSUM(4,PHEP(1,IP2-1),PHEP(1,IP2),PQ)
            CALL HWUMAS(PQ)
            PC(5)=PQ(5)
          ELSE
            PC(5)=PHEP(5,JDAHEP(1,IP2))
          ENDIF
          CALL HWVSUM(2,PHEP(1,IJT),PHEP(1,IJET(2)),PC)
          ET(1)=ET(2)
C---USE BREIT FRAME BOSON MOMENTUM IF NECESSARY
          IF (BREIT) THEN
            ET(2)=ET(1)+PC(5)**2+PHEP(5,IJET(2))**2
            PM0=PHEP(5,IJT)
            PP0=-PM0
          ELSE
            ET(2)=PC(1)**2+PC(2)**2+PC(5)**2
            PP0=PHEP(4,IJT)+PHEP(3,IJT)
            PM0=PHEP(4,IJT)-PHEP(3,IJT)
          ENDIF
          ET0=(PP0*PM0)+ET(1)-ET(2)
          DET=ET0**2-4.*(PP0*PM0)*ET(1)
          IF (DET.LT.ZERO) THEN
            FROST=.TRUE.
            RETURN
          ENDIF
          ALF=(SQRT(DET)-ET0)/(2.*PP0*PP(2))
          PB(1)=0.
          PB(2)=0.
          PB(5)=2.D0
          PB(3)=ALF-(1./ALF)
          PB(4)=ALF+(1./ALF)
          DO 100 IHEP=IJET(2),IEND(2)
          CALL HWULOF(PB,PHEP(1,IHEP),PHEP(1,IHEP))
          CALL HWULF4(PB,VHEP(1,IHEP),VHEP(1,IHEP))
C---BOOST FROM BREIT FRAME IF NECESSARY
          IF (BREIT) THEN
            CALL HWUROB(RBR,PHEP(1,IHEP),PHEP(1,IHEP))
            CALL HWULOB(PBR,PHEP(1,IHEP),PHEP(1,IHEP))
            CALL HWUROB(RBR,VHEP(1,IHEP),VHEP(1,IHEP))
            CALL HWULB4(PBR,VHEP(1,IHEP),VHEP(1,IHEP))
          ENDIF
  100     ISTHEP(IHEP)=ISTHEP(IHEP)+10
          CALL HWVDIF(4,VHEP(1,IPAR(2)),VHEP(1,IJET(2)),DISP)
          DO 110 IHEP=IJET(2),IEND(2)
  110     CALL HWVSUM(4,DISP,VHEP(1,IHEP),VHEP(1,IHEP))
          IF (IEND(2).GT.IJET(2)+1) ISTHEP(IJET(2)+1)=100
          CALL HWVSUM(4,PHEP(1,IJT),PHEP(1,IJET(2)),PC)
          CALL HWVSUM(4,PHEP(1,IP1),PHEP(1,IJET(2)),PHEP(1,ICM))
          CALL HWUMAS(PHEP(1,ICM))
        ELSEIF (IPRO/10.EQ.5) THEN
C Special to preserve photon momentum
           ETC=PTX**2+PTY**2+PHEP(5,ICM)**2
           ET0=ETC+ET(1)-ET(2)
           DET=ET0**2-4.*ETC*ET(1)
           IF (DET.LT.ZERO) THEN
              FROST=.TRUE.
              RETURN
           ENDIF
           ALF=(SQRT(DET)+ET0-2.*ET(1))/(2.*PP(1)*PP(2))
           PB(1)=0.
           PB(2)=0.
           PB(3)=ALF-1./ALF
           PB(4)=ALF+1./ALF
           PB(5)=2.
           IJT=IJET(2)
           DO 120 IHEP=IJT,IEND(2)
           CALL HWULOF(PB,PHEP(1,IHEP),PHEP(1,IHEP))
           CALL HWULF4(PB,VHEP(1,IHEP),VHEP(1,IHEP))
  120      ISTHEP(IHEP)=ISTHEP(IHEP)+10
           CALL HWVDIF(4,VHEP(1,IPAR(2)),VHEP(1,IJT),DISP)
           DO 130 IHEP=IJT,IEND(2)
  130      CALL HWVSUM(4,DISP,VHEP(1,IHEP),VHEP(1,IHEP))
           IF (IEND(2).GT.IJT+1) ISTHEP(IJT+1)=100
           ISTHEP(IJET(1))=ISTHEP(IJET(1))+10
           CALL HWVSUM(2,PHEP(3,IPAR(1)),PHEP(3,IJT),PHEP(3,ICM))
        ELSE
          PHEP(4,ICM)=SQRT(PTX**2+PTY**2+PHEP(3,ICM)**2+PHEP(5,ICM)**2)
C---NOW BOOST TO REQUIRED Q**2 AND X-F
          PP0=PHEP(4,ICM)+PHEP(3,ICM)
          PM0=PHEP(4,ICM)-PHEP(3,ICM)
          ET0=(PP0*PM0)+ET(1)-ET(2)
          DET=ET0**2-4.*(PP0*PM0)*ET(1)
          IF (DET.LT.ZERO) THEN
            FROST=.TRUE.
            RETURN
          ENDIF
          DET=SQRT(DET)+ET0
          AL(1)= 2.*PM0*PP(1)/DET
          AL(2)=(PM0/PP(2))*(1.-2.*ET(1)/DET)
          PB(1)=0.
          PB(2)=0.
          PB(5)=2.
          DO 160 IP=1,2
          PB(3)=AL(IP)-(1./AL(IP))
          PB(4)=AL(IP)+(1./AL(IP))
          IJT=IJET(IP)
          DO 140 IHEP=IJT,IEND(IP)
          CALL HWULOF(PB,PHEP(1,IHEP),PHEP(1,IHEP))
          CALL HWULF4(PB,VHEP(1,IHEP),VHEP(1,IHEP))
  140     ISTHEP(IHEP)=ISTHEP(IHEP)+10
          CALL HWVDIF(4,VHEP(1,IPAR(IP)),VHEP(1,IJT),DISP)
          DO 150 IHEP=IJT,IEND(IP)
  150     CALL HWVSUM(4,DISP,VHEP(1,IHEP),VHEP(1,IHEP))
          IF (IEND(IP).GT.IJT+1) THEN
            ISTHEP(IJT+1)=100
          ELSEIF (IEND(IP).EQ.IJT) THEN
C---NON-PARTON JET
            ISTHEP(IJT)=3
          ENDIF
  160     CONTINUE
        ENDIF
        ISTHEP(ICM)=120
      ELSE
C---TIMELIKE JETS
C---SPECIAL CASE: IF HARD PROCESS IS W/Z DECAY, PERFORM KINEMATIC
C   RECONSTRUCTION IN ITS REST FRAME INSTEAD OF THE LAB FRAME
        IF (IDHW(ICM).GE.198.AND.IDHW(ICM).LE.200.AND.WZRFR) THEN
          CALL HWVEQU(5,PHEP(1,ICM),PLAB)
          CALL HWULOF(PLAB,PHEP(1,ICM),PHEP(1,ICM))
          CALL HWULF4(PLAB,VHEP(1,ICM),VHEP(1,ICM))
          DO 165 IP=1,NP
            CALL HWULOF(PLAB,PHEP(1,IPAR(IP)),PHEP(1,IPAR(IP)))
            CALL HWULF4(PLAB,VHEP(1,IPAR(IP)),VHEP(1,IPAR(IP)))
 165      CONTINUE
        ENDIF
C   special for DIS: preserve outgoing lepton momentum
        IF (DISPRO) THEN
          CALL HWVEQU(5,PHEP(1,IPAR(1)),PHEP(1,IJET(1)))
          ISTHEP(IJET(1))=1
          LP=2
        ELSE
          CALL HWVEQU(5,PHEP(1,ICM),PC)
C--- PQ AND PC ARE OLD AND NEW PARTON CM
          CALL HWVSUM(4,PHEP(1,IPAR(1)),PHEP(1,IPAR(2)),PQ)
          PQ(5)=PHEP(5,ICM)
          IF (NP.GT.2) THEN
            DO 170 KP=3,NP
  170       CALL HWVSUM(4,PHEP(1,IPAR(KP)),PQ,PQ)
          ENDIF
          LP=1
        ENDIF
        IF (.NOT.DISLOW) THEN
C---FIND JET CM MOMENTA
          ECM=PQ(5)
          EMS=0.
          JETRAD=.FALSE.
          DO 180 KP=LP,NP
          EMJ=PHEP(5,IJET(KP))
          EMP=PHEP(5,IPAR(KP))
          JETRAD=JETRAD.OR.EMJ.NE.EMP
          EMS=EMS+EMJ
          PM(KP)= EMJ**2
C---N.B. ROUNDING ERRORS HERE AT HIGH ENERGIES
          PJ(KP)=(HWULDO(PHEP(1,IPAR(KP)),PQ)/ECM)**2-EMP**2
          IF (PJ(KP).LE.ZERO) CALL HWWARN('HWBJCO',104,*999)
  180     CONTINUE
          PF=1.
          IF (JETRAD) THEN
C---JETS DID RADIATE
            IF (EMS.GE.ECM) THEN
              FROST=.TRUE.
              GOTO 240
            ENDIF
            DO 200 NE=1,NETRY
            EMS=-ECM
            DMS=0.
            DO 190 KP=LP,NP
            ES=SQRT(PF*PJ(KP)+PM(KP))
            EMS=EMS+ES
  190       DMS=DMS+PJ(KP)/ES
            DPF=2.*EMS/DMS
            IF (DPF.GT.PF) DPF=0.9*PF
            PF=PF-DPF
  200       IF (ABS(DPF).LT.EPS) GOTO 210
            CALL HWWARN('HWBJCO',105,*999)
          ENDIF
  210     CONTINUE
        ENDIF
C---BOOST PC AND PQ TO BREIT FRAME IF NECESSARY
        IF (DISPRO.AND.BREIT) THEN
          CALL HWULOF(PBR,PC,PC)
          CALL HWUROF(RBR,PC,PC)
          IF (.NOT.DISLOW) THEN
            CALL HWULOF(PBR,PQ,PQ)
            CALL HWUROF(RBR,PQ,PQ)
          ENDIF
        ENDIF
        DO 230 IP=LP,NP
C---FIND CM ROTATION FOR JET IP
        IF (.NOT.DISLOW) THEN
          CALL HWVEQU(4,PHEP(1,IPAR(IP)),PR)
          IF (DISPRO.AND.BREIT) THEN
            CALL HWULOF(PBR,PR,PR)
            CALL HWUROF(RBR,PR,PR)
          ENDIF
          CALL HWULOF(PQ,PR,PR)
          CALL HWUROT(PR, ONE,ZERO,RR)
          PR(1)=0.
          PR(2)=0.
          PR(3)=SQRT(PF*PJ(IP))
          PR(4)=SQRT(PF*PJ(IP)+PM(IP))
          PR(5)=PHEP(5,IJET(IP))
          CALL HWUROB(RR,PR,PR)
          CALL HWULOB(PC,PR,PR)
        ELSE
          CALL HWVEQU(5,PC,PR)
        ENDIF
C---NOW PR IS LAB/BREIT MOMENTUM OF JET IP
        KP=IJET(IP)+1
        IF (AZCOR.AND.KP.LE.NHEP.AND.IDHW(KP).EQ.17) THEN
C---ALIGN CONE WITH INTERFERING PARTON
          CALL HWUROT(PR, ONE,ZERO,RS)
          JP=JMOHEP(2,KP)
          IF (JP.EQ.0) THEN
            CALL HWWARN('HWBJCO',2,*999)
            PTINF=0.
          ELSE
            CALL HWVEQU(4,PHEP(1,JP),PS)
            IF (DISPRO.AND.BREIT) THEN
              CALL HWULOF(PBR,PS,PS)
              CALL HWUROF(RBR,PS,PS)
            ENDIF
            CALL HWUROF(RS,PS,PS)
            PTINF=PS(1)**2+PS(2)**2
            IF (PTINF.LT.EPS) THEN
C---COLLINEAR JETS: ALIGN CONES
              JP=JDAHEP(1,JP)+1
              IF (ISTHEP(JP).EQ.100.AND.ISTHEP(JP-1)/10.EQ.14) THEN
                CALL HWVEQU(4,PHEP(1,JP),PS)
                IF (DISPRO.AND.BREIT) THEN
                  CALL HWULOF(PBR,PS,PS)
                  CALL HWUROF(RBR,PS,PS)
                ENDIF
                CALL HWUROF(RS,PS,PS)
                PTINF=PS(1)**2+PS(2)**2
              ELSE
                PTINF=0.
              ENDIF
            ENDIF
          ENDIF
          CALL HWVEQU(4,PHEP(1,KP),PB)
          IF (DISPRO.AND.BREIT) THEN
            CALL HWULOF(PBR,PB,PB)
            CALL HWUROF(RBR,PB,PB)
          ENDIF
          PTCON=PB(1)**2+PB(2)**2
          IF (PTCON.NE.ZERO.AND.PTINF.NE.ZERO) THEN
            CN=1./SQRT(PTINF*PTCON)
            CP=CN*(PS(1)*PB(1)+PS(2)*PB(2))
            SP=CN*(PS(1)*PB(2)-PS(2)*PB(1))
          ELSE
            CALL HWRAZM( ONE,CP,SP)
          ENDIF
        ELSE
          CALL HWRAZM( ONE,CP,SP)
        ENDIF
        CALL HWUROT(PR,CP,SP,RS)
C---FIND BOOST FOR JET IP
        ALF=(PHEP(3,IJET(IP))+PHEP(4,IJET(IP)))/
     &      (PR(4)+SQRT((PR(4)+PR(5))*(PR(4)-PR(5))))
        PB(1)=0.
        PB(2)=0.
        PB(3)=ALF-(1./ALF)
        PB(4)=ALF+(1./ALF)
        PB(5)=2.
        IHEP=IJET(IP)
        KHEP=JDAHEP(2,IHEP)
        IF (KHEP.LT.IHEP) KHEP=IHEP
        DO 220 JHEP=IHEP,KHEP
        CALL HWULOF(PB,PHEP(1,JHEP),PHEP(1,JHEP))
        CALL HWUROB(RS,PHEP(1,JHEP),PHEP(1,JHEP))
        CALL HWULF4(PB,VHEP(1,JHEP),VHEP(1,JHEP))
        CALL HWUROB(RS,VHEP(1,JHEP),VHEP(1,JHEP))
C---BOOST FROM BREIT FRAME IF NECESSARY
        IF (DISPRO.AND.BREIT) THEN
          CALL HWUROB(RBR,PHEP(1,JHEP),PHEP(1,JHEP))
          CALL HWULOB(PBR,PHEP(1,JHEP),PHEP(1,JHEP))
          CALL HWUROB(RBR,VHEP(1,JHEP),VHEP(1,JHEP))
          CALL HWULB4(PBR,VHEP(1,JHEP),VHEP(1,JHEP))
        ENDIF
        CALL HWVSUM(4,VHEP(1,JHEP),VHEP(1,IPAR(IP)),VHEP(1,JHEP))
  220   ISTHEP(JHEP)=ISTHEP(JHEP)+10
        IF (KHEP.GT.IHEP+1) THEN
          ISTHEP(IHEP+1)=100
        ELSEIF (KHEP.EQ.IHEP) THEN
C---NON-PARTON JET
          ISTHEP(IHEP)=190
        ENDIF
  230   CONTINUE
        IF (ISTHEP(ICM).EQ.110) ISTHEP(ICM)=120
C---SPECIAL CASE: FOR W/Z DECAY BOOST BACK TO THE LAB FRAME
 240    IF (IDHW(ICM).GE.198.AND.IDHW(ICM).LE.200.AND.WZRFR) THEN
          CALL HWULOB(PLAB,PHEP(1,ICM),PHEP(1,ICM))
          CALL HWULB4(PLAB,VHEP(1,ICM),VHEP(1,ICM))
          DO 260 IP=1,NP
            CALL HWULOB(PLAB,PHEP(1,IPAR(IP)),PHEP(1,IPAR(IP)))
            CALL HWULB4(PLAB,VHEP(1,IPAR(IP)),VHEP(1,IPAR(IP)))
            CALL HWULOB(PLAB,PHEP(1,IJET(IP)),PHEP(1,IJET(IP)))
            CALL HWULB4(PLAB,VHEP(1,IJET(IP)),VHEP(1,IJET(IP)))
            IF (JDAHEP(1,IJET(IP)).GT.0) THEN
              IF (JDAHEP(2,IJET(IP)).GT.JDAHEP(1,IJET(IP))) THEN
                CALL HWULOB(PLAB,PHEP(1,IJET(IP)+1),PHEP(1,IJET(IP)+1))
                CALL HWULB4(PLAB,VHEP(1,IJET(IP)+1),VHEP(1,IJET(IP)+1))
              ENDIF
              DO 250 IHEP=JDAHEP(1,IJET(IP)),JDAHEP(2,IJET(IP))
                CALL HWULOB(PLAB,PHEP(1,IHEP),PHEP(1,IHEP))
                CALL HWULB4(PLAB,VHEP(1,IHEP),VHEP(1,IHEP))
 250          CONTINUE
            ENDIF
 260      CONTINUE
        ENDIF
        IF (FROST) RETURN
      ENDIF
      GOTO 20
  999 END
CDECK  ID>, HWBMAS.
*CMZ :-        -26/04/91  11.11.54  by  Bryan Webber
*-- Author :    Bryan Webber
C-----------------------------------------------------------------------
      SUBROUTINE HWBMAS
C-----------------------------------------------------------------------
C     Passes  backwards through a  jet cascade  calculating the masses
C     and magnitudes of the longitudinal and transverse three momenta.
C     Components given relative to direction of parent for a time-like
C     vertex and with respect to z-axis for space-like vertices.
C
C     On input PPAR(1-5,*) contains:
C     (E*sqrt(Xi),Xi,3-mom (if external),E,M-sq (if external))
C
C     On output PPAR(1-5,*) (if TMPAR(*)), containts:
C     (P-trans,Xi or Xilast,P-long,E,M)
C-----------------------------------------------------------------------
      INCLUDE 'HERWIG62.INC'
      DOUBLE PRECISION HWUSQR,EXI,PISQ,PJPK,EJEK,PTSQ,Z,ZMIN,ZMAX,
     $     EMI,EMJ,EMK,C,NQ,HWBVMC,RHO,POLD,PNEW,EOLD,ENEW,A,B
      INTEGER IPAR,JPAR,KPAR,MPAR,I,J,K
      EXTERNAL HWUSQR
      IF (IERROR.NE.0) RETURN
      IF (NPAR.GT.2) THEN
        DO 30 MPAR=NPAR-1,3,-2
         JPAR=MPAR
C Find parent and partner of this branch
         IPAR=JMOPAR(1,JPAR)
         KPAR=JPAR+1
C Determine type of branching
         IF (TMPAR(IPAR)) THEN
C Time-like branching
C           Compute mass of parent
            EXI=PPAR(1,JPAR)*PPAR(1,KPAR)
            PPAR(5,IPAR)=PPAR(5,JPAR)+PPAR(5,KPAR)+2.*EXI
C           Compute three momentum of parent
            PISQ=PPAR(4,IPAR)*PPAR(4,IPAR)-PPAR(5,IPAR)
            PPAR(3,IPAR)=HWUSQR(PISQ)
C---SPECIAL FOR G-->QQBAR: READJUST ANGULAR DISTRIBUTION
            IF (IDPAR(IPAR).EQ.13 .AND. IDPAR(JPAR).LT.13) THEN
              Z=PPAR(4,JPAR)/PPAR(4,IPAR)
              ZMIN=HWBVMC(IDPAR(JPAR))/PPAR(1,JPAR)*Z
              RHO=(Z*(3-Z*(3-2*Z))-ZMIN*(3-ZMIN*(3-2*ZMIN)))
     $             /(2*(1-2*ZMIN)*(1-ZMIN*(1-ZMIN)))
              NQ=PPAR(3,IPAR)*(PPAR(3,IPAR)+PPAR(4,IPAR))
              EMI=PPAR(5,IPAR)
              EMJ=PPAR(5,JPAR)
              EMK=PPAR(5,KPAR)
              ZMIN=MAX((EMI+EMJ-EMK)/(2*(EMI+NQ)),
     $           (EMI+EMJ-EMK-SQRT((EMI-EMJ-EMK)**2-4*EMJ*EMK))/(2*EMI))
              ZMAX=1-MAX((EMI-EMJ+EMK)/(2*(EMI+NQ)),
     $           (EMI-EMJ+EMK-SQRT((EMI-EMJ-EMK)**2-4*EMJ*EMK))/(2*EMI))
              C=2*RMASS(IDPAR(JPAR))**2/EMI
              Z=(4*ZMIN*(1.5*(1+C-ZMIN)+ZMIN**2)*(1-RHO)
     $          +4*ZMAX*(1.5*(1+C-ZMAX)+ZMAX**2)*RHO-2-3*C)/(1+2*C)**1.5
              Z=SQRT(1+2*C)*SINH(LOG(Z+SQRT(Z**2+1))/3)+0.5
              Z=(Z*NQ+(EMI+EMJ-EMK)/2)/(NQ+EMI)
              PPAR(4,JPAR)=Z*PPAR(4,IPAR)
              PPAR(4,KPAR)=PPAR(4,IPAR)-PPAR(4,JPAR)
              PPAR(3,JPAR)=HWUSQR(PPAR(4,JPAR)**2-EMJ)
              PPAR(3,KPAR)=HWUSQR(PPAR(4,KPAR)**2-EMK)
              PPAR(2,JPAR)=EXI/(PPAR(4,JPAR)*PPAR(4,KPAR))
              IF(JDAPAR(2,JPAR).NE.0)PPAR(2,JDAPAR(2,JPAR))=PPAR(2,JPAR)
              IF(JDAPAR(2,KPAR).NE.0)PPAR(2,JDAPAR(2,KPAR))=PPAR(2,JPAR)
C---FIND DESCENDENTS OF THIS SPLITTING AND READJUST THEIR MOMENTA TOO
              DO 20 J=JPAR+2,NPAR-1,2
                I=J
 10             I=JMOPAR(1,I)
                IF (I.GT.IPAR) GOTO 10
                IF (I.EQ.IPAR) THEN
                  I=JMOPAR(1,J)
                  K=J+1
                  POLD=PPAR(3,J)+PPAR(3,K)
                  EOLD=PPAR(4,J)+PPAR(4,K)
                  PNEW=HWUSQR(PPAR(4,I)**2-PPAR(5,I))
                  ENEW=PPAR(4,I)
                  A=(ENEW*EOLD-PNEW*POLD)/PPAR(5,I)
                  B=(PNEW*EOLD-ENEW*POLD)/PPAR(5,I)
                  PPAR(3,J)=A*PPAR(3,J)+B*PPAR(4,J)
                  PPAR(4,J)=(PPAR(4,J)+B*PPAR(3,J))/A
                  PPAR(3,K)=PNEW-PPAR(3,J)
                  PPAR(4,K)=ENEW-PPAR(4,J)
                  PPAR(2,J)=1-(PPAR(3,J)*PPAR(3,K)+PPAR(1,J)*PPAR(1,K))
     $                 /(PPAR(4,J)*PPAR(4,K))
                  IF (JDAPAR(2,J).NE.0) PPAR(2,JDAPAR(2,J))=PPAR(2,J)
                  IF (JDAPAR(2,K).NE.0) PPAR(2,JDAPAR(2,K))=PPAR(2,J)
                ENDIF
 20           CONTINUE
            ENDIF
C           Compute daughter' transverse and longitudinal momenta
            PJPK=PPAR(3,JPAR)*PPAR(3,KPAR)
            EJEK=PPAR(4,JPAR)*PPAR(4,KPAR)-EXI
            PTSQ=(PJPK+EJEK)*(PJPK-EJEK)/PISQ
            PPAR(1,JPAR)=HWUSQR(PTSQ)
            PPAR(3,JPAR)=HWUSQR(PPAR(3,JPAR)*PPAR(3,JPAR)-PTSQ)
            PPAR(1,KPAR)=-PPAR(1,JPAR)
            PPAR(3,KPAR)= PPAR(3,IPAR)-PPAR(3,JPAR)
         ELSE
C Space-like branching
C           Re-arrange such that JPAR is time-like
            IF (TMPAR(KPAR)) THEN
               KPAR=JPAR
               JPAR=JPAR+1
            ENDIF
C           Compute time-like branch
            PTSQ=(2.-PPAR(2,JPAR))*PPAR(1,JPAR)*PPAR(1,JPAR)
     &          -PPAR(5,JPAR)
            PPAR(1,JPAR)=HWUSQR(PTSQ)
            PPAR(3,JPAR)=(1.-PPAR(2,JPAR))*PPAR(4,JPAR)
            PPAR(3,IPAR)=PPAR(3,KPAR)-PPAR(3,JPAR)
            PPAR(5,IPAR)=0.
            PPAR(1,KPAR)=0.
         ENDIF
C Reset Xi to Xilast
         PPAR(2,KPAR)=PPAR(2,IPAR)
 30    CONTINUE
      ENDIF
      DO 40 IPAR=2,NPAR
 40   PPAR(5,IPAR)=HWUSQR(PPAR(5,IPAR))
      PPAR(1,2)=0.
      PPAR(2,2)=0.
      END
CDECK  ID>, HWBRAN.
*CMZ :-        -14/10/99  18.04.56  by  Mike Seymour
*-- Author :    Bryan Webber & Mike Seymour
C-----------------------------------------------------------------------
      SUBROUTINE HWBRAN(KPAR)
C-----------------------------------------------------------------------
C     BRANCHES TIMELIKE PARTON KPAR INTO TWO, PUTS PRODUCTS
C     INTO NPAR+1 AND NPAR+2, AND INCREASES NPAR BY TWO
C-----------------------------------------------------------------------
      INCLUDE 'HERWIG62.INC'
      DOUBLE PRECISION HWBVMC,HWRGEN,HWUALF,HWUTAB,HWRUNI,HWULDO,PMOM,
     & QNOW,QLST,QKTHR,RN,QQBAR,DQQ,QGTHR,SNOW,QSUD,ZMIN,ZMAX,ZRAT,WMIN,
     & QLAM,Z1,Z2,ETEST,ZTEST,ENOW,XI,XIPREV,EPREV,QMAX,QGAM,SLST,SFNL,
     & TARG,ALF,BETA0(3:6),BETAP(3:6),SQRK(4:6,5),REJFAC,Z,X1,X2,OTHXI,
     & OTHZ,X3,FF,AW,XCUT,CC,JJ,HWUSQR
      INTEGER HWRINT,KPAR,ID,JD,IS,NTRY,N,ID1,ID2,MPAR,ISUD(13),IHEP,
     & JHEP,M,NF,NN,IREJ,NREJ,ITOP
      EXTERNAL HWBVMC,HWRGEN,HWUALF,HWUTAB,HWRUNI,HWULDO,HWRINT,HWUSQR
      SAVE BETA0,BETAP,SQRK
      DATA ISUD,BETA0/2,2,3,4,5,6,2,2,3,4,5,6,1,4*ZERO/
      IF (IERROR.NE.0) RETURN
C---SET SQRK(M,N) TO THE PROBABILITY THAT A GLUON WILL NOT PRODUCE A
C   QUARK-ANTIQUARK PAIR BETWEEN SCALES RMASS(M) AND 2*HWBVMC(N)
      IF (SUDORD.NE.1.AND.BETA0(3).EQ.ZERO) THEN
        DO 100 M=3,6
          BETA0(M)=(11.*CAFAC-2.*M)*0.5
 100      BETAP(M)=(17.*CAFAC**2-(5.*CAFAC+3.*CFFAC)*M)
     &            /BETA0(M)*0.25/PIFAC
        DO 120 N=1,5
          DO 110 M=4,6
            IF (M.LE.N) THEN
              SQRK(M,N)=ONE
            ELSEIF (M.EQ.4.OR.M.EQ.N+1) THEN
              NF=M
              IF (2*HWBVMC(N).GT.RMASS(M)) NF=M+1
              SQRK(M,N)=((BETAP(NF-1)+1/HWUALF(1,2*HWBVMC(N)))/
     $             (BETAP(NF-1)+1/HWUALF(1,RMASS(M))))**(1/BETA0(NF-1))
            ELSE
              SQRK(M,N)=SQRK(M-1,N)*
     $             ((BETAP(M-1)+1/HWUALF(1,RMASS(M-1)))/
     $             (BETAP(M-1)+1/HWUALF(1,RMASS(M))))**(1/BETA0(M-1))
            ENDIF
 110      CONTINUE
 120    CONTINUE
      ENDIF
      ID=IDPAR(KPAR)
C--TEST FOR PARTON TYPE
      IF (ID.LE.13) THEN
        JD=ID
        IS=ISUD(ID)
      ELSEIF (ID.GE.209.AND.ID.LE.220) THEN
        JD=ID-208
        IS=7
      ELSE
        IS=0
      END IF
      QNOW=-1.
      IF (IS.NE.0) THEN
C--TIMELIKE PARTON BRANCHING
        ENOW=PPAR(4,KPAR)
        XIPREV=PPAR(2,KPAR)
        IF (JMOPAR(1,KPAR).EQ.0) THEN
          EPREV=PPAR(4,KPAR)
        ELSE
          EPREV=PPAR(4,JMOPAR(1,KPAR))
        ENDIF
C--IF THIS IS CHARGED & PHOTONS ARE ALLOWED, ANGLES MIGHT NOT BE ORDERED
        QMAX=0
        QLST=PPAR(1,KPAR)
        IF (ICHRG(ID).NE.0 .AND. VPCUT.LT.PPAR(1,2)) THEN
C--LOOK FOR A PREVIOUS G->QQBAR, IF ANY
          MPAR=KPAR
 1        IF (JMOPAR(1,MPAR).NE.0) THEN
            IF (IDPAR(JMOPAR(1,MPAR)).EQ.ID) THEN
              MPAR=JMOPAR(1,MPAR)
              GOTO 1
            ENDIF
          ENDIF
C--IF CLIMBED TO THE TOP OF THE LIST, FIND QED INTERFERENCE PARTNER
          IF (MPAR.EQ.2) THEN
            JHEP=0
            IF (ID.LT.7) THEN
              IHEP=JDAHEP(2,JCOPAR(1,1))
              IF (IHEP.GT.0) JHEP=JDAHEP(2,IHEP)
            ELSE
              IHEP=JMOHEP(2,JCOPAR(1,1))
              IF (IHEP.GT.0) JHEP=JMOHEP(2,IHEP)
            ENDIF
            IF (IHEP.GT.0.AND.JHEP.GT.0) THEN
               QMAX=HWULDO(PHEP(1,IHEP),PHEP(1,JHEP))
     &              *(ENOW/PPAR(4,2))**2
            ELSE
C--FIX AT HARD PROCESS SCALE IF POINTER NOT YET SET
C  (CAN HAPPEN IN SUSY EVENTS)
               QMAX=EMSCA**2
            ENDIF
          ELSE
            QMAX=ENOW**2*PPAR(2,MPAR)
          ENDIF
C--IF PREVIOUS BRANCHING WAS Q->QGAMMA, LOOK FOR A QCD BRANCHING
          MPAR=KPAR
 2        IF (JMOPAR(1,MPAR).NE.0) THEN
            IF (IDPAR(JDAPAR(1,JMOPAR(1,MPAR))).EQ.59 .OR.
     &        IDPAR(JDAPAR(2,JMOPAR(1,MPAR))).EQ.59) THEN
              MPAR=JMOPAR(1,MPAR)
              GOTO 2
            ENDIF
          ENDIF
          QLST=ENOW**2*PPAR(2,MPAR)
          QMAX=SQRT(MAX(ZERO,MIN(
     &         QMAX , EPREV**2*XIPREV , ENOW**2*XIPREV*(2-XIPREV))))
          QLST=SQRT(MIN(
     &         QLST , EPREV**2*XIPREV , ENOW**2*XIPREV*(2-XIPREV)))
        ENDIF
        NTRY=0
    5   NTRY=NTRY+1
        IF (NTRY.GT.NBTRY) CALL HWWARN('HWBRAN',100,*999)
        IF (ID.EQ.13) THEN
C--GLUON -> QUARK+ANTIQUARK OPTION
          IF (QLST.GT.QCDL3) THEN
            DO 8 N=1,NFLAV
            QKTHR=2.*HWBVMC(N)
            IF (QLST.GT.QKTHR) THEN
              RN=HWRGEN(N)
              IF (SUDORD.NE.1) THEN
C---FIND IN WHICH FLAVOUR INTERVAL THE UPPER LIMIT LIES
                NF=3
                DO 200 M=MAX(3,N),NFLAV
 200              IF (QLST.GT.RMASS(M)) NF=M
C---CALCULATE THE FORM FACTOR
                IF (NF.EQ.MAX(3,N)) THEN
                  SFNL=((BETAP(NF)+1/HWUALF(1,QKTHR))/
     $                 (BETAP(NF)+1/HWUALF(1,QLST)))**(1/BETA0(NF))
                  SLST=SFNL
                ELSE
                  SFNL=((BETAP(NF)+1/HWUALF(1,RMASS(NF)))/
     $                 (BETAP(NF)+1/HWUALF(1,QLST)))**(1/BETA0(NF))
                  SLST=SFNL*SQRK(NF,N)
                ENDIF
              ENDIF
              IF (RN.GT.1.E-3) THEN
                QQBAR=QCDL3*(QLST/QCDL3)**(RN**BETAF)
              ELSE
                QQBAR=QCDL3
              ENDIF
              IF (SUDORD.NE.1) THEN
C---FIND IN WHICH FLAVOUR INTERVAL THE SOLUTION LIES
                IF (RN.GE.SFNL) THEN
                  NN=NF
                ELSEIF (RN.GE.SLST) THEN
                  NN=MAX(3,N)
                  DO 210 M=MAX(3,N)+1,NF-1
 210                IF (RN.GE.SLST/SQRK(M,N)) NN=M
                ELSE
                  NN=0
                  QQBAR=QCDL3
                ENDIF
                IF (NN.GT.0) THEN
                  IF (NN.EQ.NF) THEN
                    TARG=HWUALF(1,QLST)
                  ELSE
                    TARG=HWUALF(1,RMASS(NN+1))
                    RN=RN/SLST*SQRK(NN+1,N)
                  ENDIF
                  TARG=1/((BETAP(NN)+1/TARG)*RN**BETA0(NN)-BETAP(NN))
C---NOW SOLVE HWUALF(1,QQBAR)=TARG FOR QQBAR ITERATIVELY
 7                QQBAR=MAX(QQBAR,HALF*QKTHR)
                  ALF=HWUALF(1,QQBAR)
                  IF (ABS(ALF-TARG).GT.ACCUR) THEN
                    NTRY=NTRY+1
                    IF (NTRY.GT.NBTRY) CALL HWWARN('HWBRAN',101,*999)
                    QQBAR=QQBAR*(1+3*PIFAC*(ALF-TARG)
     $                   /(BETA0(NN)*ALF**2*(1+BETAP(NN)*ALF)))
                    GOTO 7
                  ENDIF
                ENDIF
              ENDIF
              IF (QQBAR.GT.QNOW.AND.QQBAR.GT.QKTHR) THEN
                QNOW=QQBAR
                ID2=N
              ENDIF
            ELSE
              GOTO 9
            ENDIF
    8       CONTINUE
          ENDIF
C--GLUON->DIQUARKS OPTION
    9     IF (QLST.LT.QDIQK) THEN
            IF (PDIQK.NE.ZERO) THEN
              RN=HWRGEN(0)
              DQQ=QLST*EXP(-RN/PDIQK)
              IF (DQQ.GT.QNOW) THEN
                IF (DQQ.GT.2.*RMASS(115)) THEN
                  QNOW=DQQ
                  ID2=115
                ENDIF
              ENDIF
            ENDIF
          ENDIF
        ENDIF
C--ENHANCE GLUON AND PHOTON EMISSION BY A FACTOR OF TWO IF THIS BRANCH
C  IS CAPABLE OF BEING THE HARDEST SO FAR
        NREJ=1
        IF (TMPAR(2).AND.0.25*MAX(QLST,QMAX).GT.HARDST) NREJ=2
C--BRANCHING ID->ID+GLUON
        QGTHR=HWBVMC(ID)+HWBVMC(13)
        IF (QLST.GT.QGTHR) THEN
         DO 300 IREJ=1,NREJ
          RN=HWRGEN(1)
          SLST=HWUTAB(SUD(1,IS),QEV(1,IS),NQEV,QLST,INTER)
          IF (RN.EQ.ZERO) THEN
            SNOW=2.
          ELSE
            SNOW=SLST/RN
          ENDIF
          IF (SNOW.LT.ONE) THEN
            QSUD=HWUTAB(QEV(1,IS),SUD(1,IS),NQEV,SNOW,INTER)
C---IF FORM FACTOR DID NOT GET INVERTED CORRECTLY TRY LINEAR INSTEAD
            IF (QSUD.GT.QLST) THEN
              SNOW=HWUTAB(SUD(1,IS),QEV(1,IS),NQEV,QLST,1)/RN
              QSUD=HWUTAB(QEV(1,IS),SUD(1,IS),NQEV,SNOW,1)
              IF (QSUD.GT.QLST) THEN
                CALL HWWARN('HWBRAN',1,*999)
                QSUD=-1
              ENDIF
            ENDIF
            IF (QSUD.GT.QGTHR.AND.QSUD.GT.QNOW) THEN
              ID2=13
              QNOW=QSUD
            ENDIF
          ENDIF
 300     CONTINUE
        ENDIF
C--BRANCHING ID->ID+PHOTON
        IF (ICHRG(ID).NE.0) THEN
          QGTHR=MAX(HWBVMC(ID)+HWBVMC(59),HWBVMC(59)*EXP(0.75))
          IF (QMAX.GT.QGTHR) THEN
           DO 400 IREJ=1,NREJ
            RN=HWRGEN(2)
            IF (RN.EQ.ZERO) THEN
              QGAM=0
            ELSE
              QGAM=(LOG(QMAX/HWBVMC(59))-0.75)**2
     &            +PIFAC*9/(ICHRG(ID)**2*ALPFAC*ALPHEM)*LOG(RN)
              IF (QGAM.GT.ZERO) THEN
                QGAM=HWBVMC(59)*EXP(0.75+SQRT(QGAM))
              ELSE
                QGAM=0
              ENDIF
            ENDIF
            IF (QGAM.GT.QGTHR.AND.QGAM.GT.QNOW) THEN
              ID2=59
              QNOW=QGAM
            ENDIF
 400       CONTINUE
          ENDIF
        ENDIF
        IF (QNOW.GT.ZERO) THEN
C--BRANCHING HAS OCCURRED
          ZMIN=HWBVMC(ID2)/QNOW
          ZMAX=1.-ZMIN
          IF (ID.EQ.13) THEN
            IF (ID2.EQ.13) THEN
C--GLUON -> GLUON + GLUON
              ID1=13
              WMIN=ZMIN*ZMAX
              ETEST=(1.-WMIN)**2*HWUALF(5-SUDORD*2,QNOW*WMIN)
              ZRAT=(ZMAX*(1-ZMIN))/(ZMIN*(1-ZMAX))
C--CHOOSE Z1 DISTRIBUTED ON (ZMIN,ZMAX)
C  ACCORDING TO GLUON BRANCHING FUNCTION
   10         Z1=ZMAX/(ZMAX+(1-ZMAX)*ZRAT**HWRGEN(0))
              Z2=1.-Z1
              ZTEST=(1.-(Z1*Z2))**2*HWUALF(5-SUDORD*2,QNOW*(Z1*Z2))
              IF (ZTEST.LT.ETEST*HWRGEN(1)) GOTO 10
              Z=Z1
            ELSEIF (ID2.NE.115) THEN
C--GLUON -> QUARKS
              ID1=ID2+6
              ETEST=ZMIN**2+ZMAX**2
   20         Z1=HWRUNI(0,ZMIN,ZMAX)
              Z2=1.-Z1
              ZTEST=Z1*Z1+Z2*Z2
              IF (ZTEST.LT.ETEST*HWRGEN(0)) GOTO 20
            ELSE
C--GLUON -> DIQUARKS
              ID2=HWRINT(115,117)
              ID1=ID2-6
              Z1=HWRUNI(0,ZMIN,ZMAX)
              Z2=1.-Z1
            ENDIF
          ELSE
C--QUARK OR ANTIQUARK BRANCHING
            IF (ID2.EQ.13) THEN
C--TO GLUON
              ZMAX=1.-HWBVMC(ID)/QNOW
              WMIN=MIN(ZMIN*(1.-ZMIN),ZMAX*(1.-ZMAX))
              ETEST=(1.+ZMAX**2)*HWUALF(5-SUDORD*2,QNOW*WMIN)
              ZRAT=ZMAX/ZMIN
   30         Z1=ZMIN*ZRAT**HWRGEN(0)
              Z2=1.-Z1
              ZTEST=(1.+Z2*Z2)*HWUALF(5-SUDORD*2,QNOW*Z1*Z2)
              IF (ZTEST.LT.ETEST*HWRGEN(1)) GOTO 30
            ELSE
C--TO PHOTON
              ZMIN=  HWBVMC(59)/QNOW
              ZMAX=1-HWBVMC(ID)/QNOW
              ZRAT=ZMAX/ZMIN
              ETEST=1+(1-ZMIN)**2
   40         Z1=ZMIN*ZRAT**HWRGEN(0)
              Z2=1-Z1
              ZTEST=1+Z2*Z2
              IF (ZTEST.LT.ETEST*HWRGEN(1)) GOTO 40
            ENDIF
C--QUARKS EMIT ON LOWER SIDE, ANTIQUARKS ON UPPER SIDE
            Z=Z1
            IF (JD.LE.6) THEN
              Z1=Z2
              Z2=1.-Z2
              ID1=ID
            ELSE
              ID1=ID2
              ID2=ID
            ENDIF
          ENDIF
C--UPDATE THIS BRANCH AND CREATE NEW BRANCHES
          XI=(QNOW/ENOW)**2
          IF (ID1.NE.59.AND.ID2.NE.59) THEN
            IF (ID.EQ.13.AND.ID1.NE.13) THEN
              QLAM=QNOW
            ELSE
              QLAM=QNOW*Z1*Z2
            ENDIF
            IF (SUDORD.EQ.1.AND.HWUALF(2,QLAM).LT.HWRGEN(0) .OR.
     &           (2.-XI)*(QNOW*Z1*Z2)**2.GT.EMSCA**2) THEN
C--BRANCHING REJECTED: REDUCE Q AND REPEAT
                QMAX=QNOW
                QLST=QNOW
                QNOW=-1.
                GOTO 5
            ENDIF
          ENDIF
C--IF THIS IS HARDEST EMISSION SO FAR, APPLY MATRIX-ELEMENT CORRECTION
          IF (ID.NE.13.OR.ID1.EQ.13) THEN
            QLAM=QNOW*Z1*Z2
            REJFAC=1
            IF (TMPAR(2).AND.QLAM.GT.HARDST) THEN
C----SOFT MATRIX-ELEMENT CORRECTION TO TOP DECAYS
              ITOP=JCOPAR(1,1)
              IF (ISTHEP(ITOP).EQ.155.AND.(IDHW(ITOP).EQ.6
     $             .OR.IDHW(ITOP).EQ.12)) THEN
                AW=(PHEP(5,JDAHEP(1,ITOP))/PHEP(5,ITOP))**2
                FF=0.5*(1-AW)*(1-2*AW+1/AW)
                CC=0.25*(1-AW)**2
                X1=1-2*CC*Z*(1-Z)*XI
                X3=0.5*(1-AW+2*CC*Z*(1-Z)*XI-(1-2*Z)
     &               *HWUSQR(((1+AW-2*CC*Z*(1-Z)*XI)**2-4*AW)
     &               /(1-2*Z*(1-Z)*XI)))
C-----JACOBIAN FACTOR
                JJ=(1-X1)*(2-AW-X1-2*X3)*(1-2*Z*(1-Z)*XI)/(
     $               4*CC**2*((X1+AW)**2-4*AW)*Z**2*(1-Z)**2*(1-2*Z)*XI)
C-----REJECTION FACTOR
                XCUT=2*GCUTME/PHEP(5,ITOP)
                IF (X3.GT.XCUT) REJFAC=FF*JJ
     &               *X3**2*(1-X1)*(1+(1-Z)**2)/(Z*XI)
     &               /((1+1/AW-2*AW)*((1-AW)*X3-(1-X1)
     &               *(1-X3)-X3**2)+(1+1/(2*AW))*X3*(X1+X3-1)**2
     &               +2*X3**2*(1-X1))
              ELSEIF (MOD(ISTHEP(JCOPAR(1,1)),10).GE.3) THEN
C---COLOUR PARTNER IS ALSO OUTGOING
                X1=1-Z*(1-Z)*XI
                X2=0.5*(1+Z*(1-Z)*XI +
     $               (1-Z*(1-Z)*XI)*(1-2*Z)/SQRT(1-2*Z*(1-Z)*XI))
                REJFAC=SQRT(2*X1-1)/(X1*Z*(1-Z))
     $               *(1+(1-Z)**2)/(Z*XI)
     $               *(1-X1)*(1-X2)/(X1**2+X2**2)
C---CHECK WHETHER IT IS IN THE OVERLAP REGION
                OTHXI=4*(1-X2)*X2**2/(X2**2-(2*X2-1)*(2*X1+X2-2)**2)
                IF (OTHXI.LT.ONE) THEN
                  OTHZ=0.5*(1-SQRT(2*X2-1)/X2*(2*X1+X2-2))
                  REJFAC=REJFAC+SQRT(2*X2-1)/(X2*OTHZ*(1-OTHZ))
     $                 *(1+(1-OTHZ)**2)/(OTHZ*OTHXI)
     $                 *(1-X2)*(1-X1)/(X2**2+X1**2)
                ENDIF
              ELSE
C---COLOUR PARTNER IS INCOMING (X1=XP, X2=ZP)
                X1=1/(1+Z*(1-Z)*XI)
                X2=0.5*(1+(1-2*Z)/SQRT(1-2*Z*(1-Z)*XI))
                REJFAC=SQRT(3-2/X1)/(X1**2*Z*(1-Z))
     $               *(1+(1-Z)**2)/(Z*XI)
     $               *(1-X1)*(1-X2)/
     $               (1+(1-X1-X2+2*X1*X2)**2+2*(1-X1)*(1-X2)*X1*X2)
C---CHECK WHETHER IT IS IN THE OVERLAP REGION
                OTHXI=(SQRT(X1+2*(1-X2)*(1-X2+X1*X2))-SQRT(X1))**2/
     $               (1+X1-X2-SQRT(X1*(X1+2*(1-X2)*(1-X2+X1*X2))))
                OTHZ=(SQRT(X1*(X1+2*(1-X2)*(1-X2+X1*X2)))-X1)/(1-X2)
                IF (OTHXI.LT.OTHZ**2) THEN
                  REJFAC=REJFAC+OTHZ**3*(1-X1-X2+2*X1*X2)
     $                 /(X1**2*(1-OTHZ)*(OTHZ+OTHXI*(1-OTHZ)))
     $                 *(1+OTHZ**2)/((1-OTHZ)*OTHXI)
     $                 *(1-X1)*(1-X2)/
     $                 (1+(1-X1-X2+2*X1*X2)**2+2*(1-X1)*(1-X2)*X1*X2)
                ENDIF
              ENDIF
            ENDIF
            IF (NREJ*REJFAC*HWRGEN(NREJ).GT.ONE) THEN
              QMAX=QNOW
              QLST=QNOW
              QNOW=-1.
              GOTO 5
            ENDIF
            IF (QLAM.GT.HARDST) HARDST=QLAM
          ENDIF
          MPAR=NPAR+1
          IDPAR(MPAR)=ID1
          TMPAR(MPAR)=.TRUE.
          PPAR(1,MPAR)=QNOW*Z1
          PPAR(2,MPAR)=XI
          PPAR(4,MPAR)=ENOW*Z1
          NPAR=NPAR+2
          IDPAR(NPAR)=ID2
          TMPAR(NPAR)=.TRUE.
          PPAR(1,NPAR)=QNOW*Z2
          PPAR(2,NPAR)=XI
          PPAR(4,NPAR)=ENOW*Z2
C---NEW MOTHER-DAUGHTER RELATIONS
          JDAPAR(1,KPAR)=MPAR
          JDAPAR(2,KPAR)=NPAR
          JMOPAR(1,MPAR)=KPAR
          JMOPAR(1,NPAR)=KPAR
C---NEW COLOUR CONNECTIONS
          JCOPAR(3,KPAR)=NPAR
          JCOPAR(4,KPAR)=MPAR
          JCOPAR(1,MPAR)=NPAR
          JCOPAR(2,MPAR)=KPAR
          JCOPAR(1,NPAR)=KPAR
          JCOPAR(2,NPAR)=MPAR
C
        ENDIF
      ENDIF
      IF (QNOW.LT.ZERO) THEN
C--BRANCHING STOPS
        IF (ID.EQ.IDPAR(2).AND.PPAR(5,2).GT.1D-6) THEN
          PPAR(5,KPAR)=PPAR(5,2)**2
        ELSE
          PPAR(5,KPAR)=RMASS(ID)**2
        ENDIF
        PMOM=PPAR(4,KPAR)**2-PPAR(5,KPAR)
        IF (PMOM.LT.-1E-6) CALL HWWARN('HWBRAN',104,*999)
        IF (PMOM.LT.ZERO) PMOM=ZERO
        PPAR(3,KPAR)=SQRT(PMOM)
        JDAPAR(1,KPAR)=0
        JDAPAR(2,KPAR)=0
        JCOPAR(3,KPAR)=0
        JCOPAR(4,KPAR)=0
      ENDIF
  999 END
CDECK  ID>, HWBRCN.
*CMZ :-        -31/03/00  17:54:05  by  Peter Richardson
*-- Author :    Peter Richardson
C-----------------------------------------------------------------------
      SUBROUTINE HWBRCN
C-----------------------------------------------------------------------
C     SUBROUTINE TO REPLACE HWBCON IN RPARITY VIOLATING SUSY
C     BASED ON HWBCON BY BRW
C-----------------------------------------------------------------------
      INCLUDE 'HERWIG62.INC'
      INTEGER IHEP,IST,ID,JC,JD,JHEP,IDP,IDM,IDP2,IDM2,
     &        RHEP,IST2,ORG,ANTC,XHEP,IP,COLP
      LOGICAL BVVUSE,BVVHRD,BVDEC1,BVDEC2,COLRD,ACOLRD,BVHRD,BVHRD2,
     &        BVDEC3
C--logical functions to decide if baryon number violating
C--BVDEC1 DELTAB=+1
      BVDEC1(IP) = ((IDHW(IP).GE.419.AND.IDHW(IP).LE.424).OR.
     &              IDHW(IP).EQ.411.OR.IDHW(IP).EQ.412.OR.
     &              IDHW(IP).EQ.449).AND.IDHW(JDAHEP(1,IP)).LE.6.
     &              AND.IDHW(JDAHEP(1,IP)+1).LE.6.AND.
     &              IDHW(JDAHEP(2,IP)).LE.6
C--BVDEC2 DELTAB=-1
      BVDEC2(IP) = ((IDHW(IP).GE.413.AND.IDHW(IP).LE.418).OR.
     &              IDHW(IP).EQ.405.OR.IDHW(IP).EQ.406.OR.
     &              IDHW(IP).EQ.449).AND.
     &    IDHW(JDAHEP(1,IP)).GE.7.AND.IDHW(JDAHEP(1,IP)).LE.12.AND.
     &    IDHW(JDAHEP(1,IP)+1).GE.7.AND.IDHW(JDAHEP(1,IP)+1).LE.12.AND.
     &    IDHW(JDAHEP(2,IP)).GE.7.AND.IDHW(JDAHEP(2,IP)).LE.12
C--Neutralino and Chargino Decays
      BVDEC3(IP) = ((IDHW(IP).GE.450.AND.IDHW(IP).LE.457).AND.
     &   (IDHW(JDAHEP(1,IP)).LE.12.AND.IDHW(JDAHEP(1,IP)+1).LE.12.
     &    .AND.IDHW(JDAHEP(2,IP)).LE.12))
C--Now the hard vertices
      BVHRD(IP) = IDHW(IP).EQ.15.AND.IDHW(JMOHEP(1,IP)).LE.12.
     &    AND.IDHW(JMOHEP(2,IP)).LE.12.AND.IDHW(JDAHEP(1,IP)).LE.12.
     &    AND.IDHW(JDAHEP(2,IP)).GE.449.AND.IDHW(JDAHEP(2,IP)).LE.457
      BVHRD2(IP) = IDHW(IP).EQ.15.AND.IDHW(JMOHEP(1,IP)).LE.12.
     &    AND.IDHW(JMOHEP(2,IP)).LE.12.AND.IDHW(JDAHEP(1,IP)).GE.198.
     &    AND.IDHW(JDAHEP(1,IP)).LE.207.
     &    AND.ABS(IDHEP(JDAHEP(2,IP))).GT.1000000
C--Those particles which are coloured
      COLRD(IP) = IP.LE.6.OR.IP.EQ.13.OR.IP.EQ.449.OR.
     &   (IP.GE.401.AND.IP.LE.406).OR.(IP.GE.413.AND.IP.LE.418).OR.
     &   (IP.GE.115.AND.IP.LE.120).OR.IP.EQ.59
C--Those particles which are anticoloured
      ACOLRD(IP) = (IP.GE.7.AND.IP.LE.12).OR.IP.EQ.13.OR.IP.EQ.449.OR.
     & (IP.GE.407.AND.IP.LE.412).OR.(IP.GE.419.AND.IP.LE.424).OR.
     & (IP.GE.109.AND.IP.LE.114).OR.IP.EQ.59
      IF (IERROR.NE.0) RETURN
C--Added 31/03/00 PR
      IF(NHEP.GT.NMXHEP) CALL HWWARN('HWBRCN',101,*999)
      COLP = 0
      IF(COLUPD.AND.HRDCOL(1,3).NE.0) THEN
        JD = 0
        DO IHEP = HRDCOL(1,3),HRDCOL(1,3)+4
          JD = JD+1
          IF(JD.NE.3) THEN
            JMOHEP(2,IHEP) = HRDCOL(1,JD)
            JDAHEP(2,IHEP) = HRDCOL(2,JD)
          ENDIF
        ENDDO
        COLUPD=.FALSE.
        DO IHEP=1,5
          DO JHEP=1,2
            HRDCOL(JHEP,IHEP)=0
          ENDDO
        ENDDO
      ELSEIF(COLUPD) THEN
        RETURN
      ENDIF
      DO 110 IHEP=1,NHEP
      IST=ISTHEP(IHEP)
      JD =0
      BVVUSE = .FALSE.
      BVVHRD = .FALSE.
C---LOOK FOR PARTONS WITHOUT COLOUR MOTHERS
      IF ((IST.LT.145.OR.IST.GT.152).AND.IST.NE.155) GOTO 110
      IF (JMOHEP(2,IHEP).EQ.0) THEN
C---FIND COLOUR-CONNECTED PARTON
        IF(IST.EQ.155.AND.ABS(IDHEP(IHEP)).EQ.6) THEN
          JC = JMOHEP(1,IHEP)
        ELSEIF(IST.EQ.155) THEN
          GOTO 110
        ELSE
          JC=JMOHEP(1,IHEP)
        ENDIF
        IF (IST.NE.152) JC=JMOHEP(1,JC)
C--Correction for BV
        IF(HRDCOL(1,1).NE.0) THEN
          IDP = IDHW(HRDCOL(1,1))
          IDP2 = 0
        ELSE
          IDP  = 0
          IDP2 = 0
        ENDIF
        IDM = JMOHEP(1,JC)
        IF(BVDEC1(IDM).OR.BVDEC2(IDM)) THEN
          IF(IDHW(IDM).EQ.449.AND.JDAHEP(1,IDM).EQ.JC) THEN
            JC=JMOHEP(2,JC)
          ELSE
            JD = JMOHEP(2,JC)
            JC = IDM
            IF(JC.EQ.JD) JD= JDAHEP(2,JC-1)
            BVVUSE = .TRUE.
          ENDIF
C--NEW FOR BV HARD PROCESS
        ELSEIF(BVHRD(IDM)) THEN
          IF(IDHW(JDAHEP(2,JMOHEP(1,JC))).EQ.449) THEN
            JD   = JMOHEP(2,JC)
            IDM2 = JDAHEP(2,HRDCOL(1,2))
            IF(JD.EQ.IDM2) JD = HRDCOL(1,1)
            IF(JC.EQ.JDAHEP(2,IDM2).AND.COLRD(IDHW(IHEP))) THEN
              JC = JMOHEP(2,JC)
            ELSEIF(JC.EQ.IDM2) THEN
              IF(JDAHEP(2,JMOHEP(2,JC)).EQ.JC) THEN
                JC = JMOHEP(2,JC)
              ELSE
              JMOHEP(2,IHEP)=JMOHEP(2,JC)
              GOTO 110
              ENDIF
            ELSE
              JC = HRDCOL(1,1)
              BVVUSE = .TRUE.
              BVVHRD = .TRUE.
              IF(ACOLRD(IDHW(IHEP))) JC = JD
              IF(JC.EQ.IDM2) GOTO 110
            ENDIF
          ELSE
            JC =JMOHEP(2,JC)
            BVVUSE = .TRUE.
            BVVHRD = .TRUE.
          ENDIF
        ELSEIF(BVHRD2(IDM)) THEN
          JD = JMOHEP(2,JC)
            IF(JC.EQ.JDAHEP(2,HRDCOL(1,2))) THEN
              JMOHEP(2,IHEP)=JMOHEP(2,JC)
              GOTO 110
            ENDIF
          IF(JD.EQ.JDAHEP(2,HRDCOL(1,2))) JD = HRDCOL(1,1)
          BVVUSE=.TRUE.
          BVVHRD = .TRUE.
          IF(JC.EQ.JDAHEP(2,HRDCOL(1,2))) THEN
            JC = JMOHEP(2,JC)
          ELSE
            JC = HRDCOL(1,1)
          ENDIF
        ELSE
          JC =JMOHEP(2,JC)
        ENDIF
        IF (JC.EQ.0) CALL HWWARN('HWBCON',51,*110)
C---FIND SPECTATOR WHEN JC IS DECAYED HEAVY QUARK OR SUSY PARTICLE
        IF (ISTHEP(JC).EQ.155) THEN
          IF (IDHEP(JMOHEP(1,JC)).EQ.94) THEN
C---DECAYED BEFORE HADRONIZING
            IF(BVVHRD) THEN
              JHEP = JC
            ELSEIF(BVVUSE) THEN
              JHEP=JDAHEP(2,JC-1)
            ELSE
              JHEP=JMOHEP(2,JC)
            ENDIF
            IF(JHEP.EQ.0.AND.ABS(IDHEP(JC)).EQ.6) THEN
              JHEP = JMOHEP(1,JMOHEP(1,JC))
              IF(BVDEC1(JMOHEP(1,JHEP)).OR.BVDEC2(JMOHEP(1,JHEP))) THEN
                JC = JHEP
                JHEP = JDAHEP(2,JC-1)
              ELSE
                JHEP = 0
              ENDIF
            ENDIF
            IF(BVVUSE.AND.ABS(IDHEP(JHEP)).GT.1000000.AND.
     &           ISTHEP(JHEP).NE.155.OR.JHEP.EQ.0) GOTO 110
            ID=IDHW(JHEP)
            IF (ISTHEP(JHEP).EQ.155) THEN
C---SPECIAL FOR GLUINO DECAYS
              IF (ID.EQ.449) THEN
                ID=IDHW(JC)
                IF(BVVUSE) THEN
                  ID=IDHW(IHEP)
                  IF(ID.LE.6.OR.ID.EQ.13.OR.
     &               (ID.GE.115.AND.ID.LE.120)) THEN
                    ID = 7
                  ELSE
                    ID = 1
                  ENDIF
                ENDIF
                CALL HWBRC1(JC,ID,JHEP,.TRUE.,*999)
                IF(BVVUSE.AND.JMOHEP(1,JC).EQ.JMOHEP(1,JD)) JC =JD
              ELSE
                JC=JDAHEP(2,JHEP)
                IF(COLRD(IDHW(IHEP)).AND.IDHW(JDAHEP(1,JHEP)).EQ.449)
     &             JC=JDAHEP(1,JHEP)
                IF(BVVUSE.AND.JMOHEP(1,JC).EQ.JMOHEP(1,JD)) JC =JD
              ENDIF
            ELSE
              IF(BVVUSE) THEN
                IF(BVDEC2(JMOHEP(1,JHEP)).OR.JD.NE.JHEP.OR.
     &            BVHRD(JMOHEP(1,JHEP)).OR.BVHRD2(JMOHEP(1,JHEP))) THEN
                  JC = JD
                  GOTO 100
                ELSE
                  JMOHEP(2,IHEP)=JHEP
                  ID = IDHW(JHEP)
                  IF((ID.GE.7.AND.ID.LE.12).OR.
     &               (ID.GE.109.AND.ID.LE.114)) JMOHEP(2,JHEP)=IHEP
                ENDIF
              ELSE
C--new for particles connected to BV
                IDM = JMOHEP(1,JHEP)
                IF(BVDEC1(IDM).OR.BVHRD(IDM).OR.BVHRD2(IDM)) THEN
                  JC = JHEP
                  IF(ABS(IDHEP(IHEP)).LT.1000000) GOTO 100
                  JMOHEP(2,IHEP)=JHEP
                  GOTO 110
                ENDIF
C--new for top's from BV
                ID = IDHW(JC)
                IDP  = JMOHEP(1,JMOHEP(1,JMOHEP(1,JC)))
                IF((ID.EQ.6.AND.(BVDEC1(IDP))).
     &              OR.(ID.EQ.12.AND.BVDEC2(IDP)).
     &              OR.((ID.EQ.12.OR.ID.EQ.449).AND.BVHRD(IDP))) THEN
                   JMOHEP(2,IHEP)=JHEP
                   IF(JDAHEP(2,JHEP).EQ.JC) JDAHEP(2,JHEP)=IHEP
                ELSE
                  IF((IDHW(IHEP).GE.7.AND.IDHW(IHEP).LE.12.
     &               AND.IDHW(JHEP).GE.7.AND.IDHW(JHEP).LE.12).OR.
     &               (IDHW(IHEP).LE.6.AND.IDHW(JHEP).LE.6)) THEN
                    JMOHEP(2,IHEP)=JHEP
                  ELSE
                    JMOHEP(2,IHEP)=JHEP
                    IF((COLRD(IDHW(IHEP)).AND.ACOLRD(IDHW(JHEP))).OR.
     &                (.NOT.COLRD(IDHW(IHEP)).AND.
     &                .NOT.ACOLRD(IDHW(JHEP)))) THEN
                      IF(JDAHEP(2,JHEP).EQ.0) THEN
                        JDAHEP(2,JHEP)=IHEP
                      ELSEIF(JMOHEP(2,JDAHEP(2,JHEP)).NE.JHEP) THEN
                        JDAHEP(2,JHEP)=IHEP
                      ENDIF
                    ELSE
                      IF(JMOHEP(2,JHEP).EQ.JC) JMOHEP(2,JHEP)=IHEP
                    ENDIF
                  ENDIF
                ENDIF
              ENDIF
              GOTO 110
            ENDIF
          ELSE
            JC=JMOHEP(2,JC)
          ENDIF
        ENDIF
 100    CONTINUE
        IF(BVVUSE.AND.ABS(IDHEP(JC)).LT.1000000.AND.JC.NE.JD
     &     .AND.JD.NE.0.AND.JD.NE.JMOHEP(1,JC)) JC = JD
        IF(BVVUSE.AND.ABS(IDHEP(JC)).GT.1000000) THEN
          IF(COLRD(IDHW(IHEP)).AND..NOT.BVVHRD) GOTO 110
        ENDIF
        IF(BVVUSE.AND.ISTHEP(JC).EQ.149) JC=JMOHEP(1,JMOHEP(1,JC))
C--SEARCH IN THE JET
        IF((ISTHEP(JC).GT.145.AND.ISTHEP(JC).LT.152).AND.
     &     ISTHEP(IHEP).EQ.155) THEN
          JMOHEP(2,IHEP) = JC
          GOTO 110
        ENDIF
        CALL HWBRC2(COLP,IHEP,JC,.TRUE.,BVVUSE,BVVHRD)
        IF(COLP.NE.0) THEN
          JMOHEP(2,IHEP) = COLP
          IF(COLRD(IDHW(IHEP)).AND.ACOLRD(IDHW(COLP)).
     &       AND.JDAHEP(2,COLP).EQ.0)
     &      JDAHEP(2,COLP) = IHEP
          IF((IDHW(IHEP).GE.7.AND.IDHW(IHEP).LE.12).AND.
     &       (IDHW(COLP).GE.7.AND.IDHW(COLP).LE.12)) THEN
             IF(JMOHEP(2,COLP).EQ.0) JMOHEP(2,COLP) = IHEP
          ENDIF
        ENDIF
      ENDIF
  110 CONTINUE
C---BREAK COLOUR CONNECTIONS WITH PHOTONS modified for Rslash
      IHEP=1
  130 IF (IHEP.LE.NHEP) THEN
        IF (IDHW(IHEP).EQ.59 .AND. ISTHEP(IHEP).EQ.149.AND.
     &      (JMOHEP(2,IHEP).NE.IHEP.OR.JDAHEP(2,IHEP).NE.IHEP)) THEN
          IF(JMOHEP(2,IHEP).NE.0) THEN
          IF (JDAHEP(2,JMOHEP(2,IHEP)).EQ.IHEP)
     &      JDAHEP(2,JMOHEP(2,IHEP))=JDAHEP(2,IHEP)
          ENDIF
          IF (JDAHEP(2,IHEP).NE.0) THEN
            IF (JMOHEP(2,JDAHEP(2,IHEP)).EQ.IHEP)
     &        JMOHEP(2,JDAHEP(2,IHEP))=JMOHEP(2,IHEP)
          ENDIF
          DO RHEP=1,NHEP
            IST=ISTHEP(RHEP)
            IF((IST.GE.147.AND.IST.LE.149).AND.JDAHEP(2,RHEP).EQ.IHEP)
     &        JDAHEP(2,RHEP)=JMOHEP(2,IHEP)
          ENDDO
          DO RHEP=1,NHEP
            IST=ISTHEP(RHEP)
            IF((IST.GE.147.AND.IST.LE.149).AND.JMOHEP(2,RHEP).EQ.IHEP)
     &        JMOHEP(2,RHEP) = JDAHEP(2,IHEP)
          ENDDO
          JMOHEP(2,IHEP)=IHEP
          JDAHEP(2,IHEP)=IHEP
        ENDIF
        IHEP=IHEP+1
        GOTO 130
      ENDIF
C--Update the BV anticolour corrections
      DO 210 IHEP=1,NHEP+1
      IF(IHEP.EQ.1) GOTO 210
      IST2 = 0
      IF(IHEP.EQ.NHEP+1) THEN
        ANTC = HRDCOL(1,1)
        IF(ANTC.EQ.0.OR.(IDHW(JMOHEP(1,HRDCOL(1,2))).LE.6)) GOTO 210
        IST=155
        XHEP=HRDCOL(1,2)
        IF(ANTC.EQ.JDAHEP(2,XHEP)) ANTC=JDAHEP(1,JDAHEP(1,ANTC))
        IF(ANTC.NE.0.AND.JDAHEP(1,ANTC).NE.0) IST2=ISTHEP(ANTC)
      ELSE
        ANTC = JDAHEP(2,IHEP-1)
        IF(ANTC.NE.0) IST2=ISTHEP(ANTC)
        IST=ISTHEP(IHEP)
        IDM = IDHW(IHEP)
        XHEP=IHEP
      ENDIF
      JC = 0
      JHEP = 0
      JD = 0
      ORG = 0
      IF(IST.EQ.155.AND.IST2.EQ.155) THEN
        IDM = IDHW(XHEP)
        ORG = ANTC
        IF(BVDEC1(XHEP).OR.BVDEC2(XHEP).OR.BVHRD(XHEP).OR.
     &     BVHRD2(XHEP)) THEN
          JC=ANTC
          ID = IDHW(JC)
          JHEP = JC
          IF(BVDEC1(JC).OR.BVDEC2(JC)) THEN
            IF(IHEP.EQ.(NHEP+1)) ANTC=JDAHEP(1,JC)
            GOTO 200
          ENDIF
          IF (ID.EQ.449) THEN
C--SPECIAL FOR GLUINO DECAYS
            ID=IDHW(XHEP)
            IF(IHEP.EQ.NHEP+1) ID = 407
            CALL HWBRC1(JC,ID,JHEP,.FALSE.,*999)
          ELSE
            IF(IDHW(JDAHEP(1,JHEP)).EQ.449) THEN
              JC=JDAHEP(1,JHEP)
            ELSE
              JC=JDAHEP(2,JHEP)
            ENDIF
          ENDIF
C--SEARCH IN JET
          CALL HWBRC2(COLP,XHEP,JC,.FALSE.,BVVUSE,.FALSE.)
          ANTC = COLP
          IF(IHEP.LE.NHEP.AND.ACOLRD(IDHW(IHEP)).AND.
     &       COLRD(IDHW(COLP)).AND.JMOHEP(2,COLP).EQ.0) THEN
             JMOHEP(2,COLP) = IHEP
          ELSEIF(IHEP.LE.NHEP.AND.IDHW(IHEP).LE.6.AND.
     &       IDHW(COLP).LE.6.AND.JDAHEP(2,COLP).EQ.0) THEN
             JDAHEP(2,COLP) = IHEP
          ELSEIF(IHEP.GT.NHEP.AND.
     &       ((BVHRD(XHEP).AND.COLRD(JDAHEP(1,XHEP))).
     &       OR.(BVHRD2(XHEP).AND.ACOLRD(JDAHEP(2,XHEP)))).AND.
     &       ACOLRD(IDHW(COLP)).AND.JDAHEP(2,COLP).EQ.0) THEN
            JDAHEP(2,COLP) = IHEP
          ENDIF
        ENDIF
      ENDIF
  200 CONTINUE
      IF(IHEP.EQ.NHEP+1) THEN
        IF(HRDCOL(1,1).NE.ANTC.AND.ANTC.NE.0) THEN
          HRDCOL(1,1)=ANTC
        IF(JDAHEP(2,ANTC).EQ.IHEP) THEN
          IF(JDAHEP(2,JMOHEP(1,HRDCOL(1,2))).EQ.JDAHEP(2,HRDCOL(1,2)).
     &    AND.JMOHEP(2,JDAHEP(2,HRDCOL(1,2))).EQ.JMOHEP(1,HRDCOL(1,2)))
     &      THEN
            JDAHEP(2,ANTC) = JMOHEP(2,HRDCOL(1,2))
          ELSE
            JDAHEP(2,ANTC) = JMOHEP(1,HRDCOL(1,2))
          ENDIF
        ELSEIF(JMOHEP(2,ANTC).EQ.IHEP) THEN
          JMOHEP(2,ANTC) = JMOHEP(1,HRDCOL(1,2))
        ENDIF
        ENDIF
      ELSEIF(IHEP.NE.1) THEN
        IF(JDAHEP(2,IHEP-1).NE.ANTC.AND.ANTC.NE.0) JDAHEP(2,IHEP-1)=ANTC
      ENDIF
 210  CONTINUE
C--Update BV decaying particles connections
      DO 310 IHEP=1,NHEP+1
      IF(IHEP.EQ.1) GOTO 310
      IF(IHEP.EQ.NHEP+1) THEN
        ANTC=HRDCOL(1,1)
        IF(ANTC.EQ.0.OR.IDHW(JDAHEP(1,HRDCOL(1,2))).LE.6) GOTO 310
        IST=155
        XHEP=HRDCOL(1,2)
        IF(ANTC.EQ.JDAHEP(2,XHEP)) ANTC=JDAHEP(1,JDAHEP(1,ANTC))
      ELSE
        ANTC=JMOHEP(2,IHEP)
        IST=ISTHEP(IHEP)
        IDM = IDHW(IHEP)
        XHEP=IHEP
      ENDIF
      IST2 = 0
      JC = 0
      JD = 0
      IF(ANTC.NE.0.AND.IHEP.NE.NHEP+1) THEN
        IF(JDAHEP(1,ANTC).NE.0) IST2 = ISTHEP(ANTC)
      ELSEIF(ANTC.NE.0.AND.IHEP.EQ.NHEP+1) THEN
        IST2=ISTHEP(ANTC)
      ENDIF
      IF(IST.EQ.155.AND.IST2.EQ.155) THEN
        IF(BVDEC2(XHEP).OR.BVHRD(XHEP).OR.BVHRD2(XHEP)) THEN
C--FIND COLOUR CONNECTED PARTON
          JC = ANTC
          ID=IDHW(JC)
          JHEP = JC
          IF(BVDEC2(JHEP)) THEN
             ANTC=JC
             GOTO 300
          ENDIF
          IF (ID.EQ.449) THEN
            ID=IDHW(XHEP)
            IF(IHEP.EQ.NHEP+1) ID = 401
C--SPECIAL FOR GLUINO DECAYS
            CALL HWBRC1(JC,ID,JHEP,.TRUE.,*999)
          ELSE
            IF(IDHW(JDAHEP(1,JHEP)).EQ.449) THEN
              JC=JDAHEP(1,JHEP)
            ELSE
              JC=JDAHEP(2,JHEP)
            ENDIF
          ENDIF
C--SEARCH IN JET
          CALL HWBRC2(COLP,XHEP,JC,.TRUE.,BVVUSE,.FALSE.)
          ANTC = COLP
          IF(COLP.EQ.0) GOTO 300
          IF(IHEP.LE.NHEP) THEN
            IF(JDAHEP(2,COLP).EQ.0) THEN
              JDAHEP(2,COLP) = JDAHEP(2,IHEP)
            ELSEIF(JMOHEP(2,JDAHEP(2,COLP)).NE.COLP) THEN
              JDAHEP(2,COLP) = JDAHEP(2,IHEP)
            ENDIF
          ELSEIF(IHEP.GT.NHEP.AND.
     &       ((BVHRD(XHEP).AND.ACOLRD(JDAHEP(1,XHEP)).AND.
     &       IDHW(JDAHEP(2,XHEP)).EQ.449).
     &       OR.(BVHRD2(XHEP).AND.ACOLRD(JDAHEP(2,XHEP)))).AND.
     &       ACOLRD(IDHW(COLP)).AND.JDAHEP(2,COLP).EQ.0) THEN
            JDAHEP(2,COLP) = IHEP
          ENDIF
        ENDIF
      ENDIF
  300 CONTINUE
      IF(IHEP.NE.NHEP+1.AND.IHEP.NE.1) THEN
        IF(JMOHEP(2,IHEP).NE.ANTC.AND.ANTC.NE.0) JMOHEP(2,IHEP)=ANTC
      ELSEIF(IHEP.GT.NHEP) THEN
        IF(HRDCOL(1,1).NE.ANTC.AND.ANTC.NE.0) HRDCOL(1,1)=ANTC
        IF(ANTC.EQ.0) GOTO 310
        IF(JDAHEP(2,ANTC).EQ.IHEP) THEN
          IF(JDAHEP(2,JMOHEP(1,HRDCOL(1,2))).EQ.JDAHEP(2,HRDCOL(1,2)).
     &    AND.JMOHEP(2,JDAHEP(2,HRDCOL(1,2))).EQ.JMOHEP(1,HRDCOL(1,2)))
     &      THEN
            JDAHEP(2,ANTC) = JMOHEP(2,HRDCOL(1,2))
          ELSE
            JDAHEP(2,ANTC) = JMOHEP(1,HRDCOL(1,2))
          ENDIF
        ELSEIF(JMOHEP(2,ANTC).EQ.IHEP) THEN
          JMOHEP(2,ANTC) = JMOHEP(1,HRDCOL(1,2))
        ENDIF
      ENDIF
 310  CONTINUE
C--Update partons connected to decaying SUSY particle
      DO 400 IHEP=1,NHEP
      IST=ISTHEP(IHEP)
C--LOOK FOR PARTONS CONNECTED TO A DECAYING SUSY PARTICLE
      IF (IST.LT.145.OR.IST.GT.152) GOTO 400
      IF(JMOHEP(2,IHEP).EQ.0) GOTO 400
      IF(ISTHEP(JMOHEP(2,IHEP)).EQ.155) THEN
C--FIND THE COLOUR CONNECTED PARTON
        JC=JMOHEP(2,IHEP)
        ID=IDHW(JC)
        JHEP = JC
        IF(BVDEC2(JC).AND.IDHW(JC).NE.449) GOTO 400
        IF (ID.EQ.449) THEN
C--SPECIAL FOR GLUINO DECAYS
          ID=IDHW(IHEP)
          CALL HWBRC1(JC,ID,JHEP,.TRUE.,*999)
        ELSE
          ID=IDHW(IHEP)
          IF(COLRD(ID).AND.IDHW(JDAHEP(1,JC)).EQ.449) THEN
            JC=JDAHEP(1,JHEP)
          ELSE
            JC=JDAHEP(2,JHEP)
          ENDIF
        ENDIF
C--SEARCH IN JET
        CALL HWBRC2(COLP,IHEP,JC,.TRUE.,BVVUSE,.FALSE.)
        JMOHEP(2,IHEP) = COLP
      ENDIF
 400  CONTINUE
C--Update partons connected to decaying SUSY particle
      DO 500 IHEP=1,NHEP
      IST=ISTHEP(IHEP)
C--LOOK FOR PARTONS CONNECTED TO A DECAYING SUSY PARTICLE
      IF (IST.LT.145.OR.IST.GT.152) GOTO 500
      IF(JDAHEP(2,IHEP).EQ.0) GOTO 500
      IF(ISTHEP(JDAHEP(2,IHEP)).EQ.155) THEN
C--FIND THE COLOUR CONNECTED PARTON
        JC=JDAHEP(2,IHEP)
        ID=IDHW(JC)
        ID=IDHW(JC)
        IF (ID.EQ.449) THEN
          ID=IDHW(IHEP)
C--SPECIAL FOR GLUINO DECAYS
          JHEP = JC
          CALL  HWBRC1(JC,ID,JHEP,.FALSE.,*999)
        ELSE
          IF(ACOLRD(IDHW(IHEP)).AND.IDHW(JDAHEP(1,JC)).EQ.449) THEN
            JC = JDAHEP(1,JC)
          ELSE
            JC=JDAHEP(2,JC)
          ENDIF
        ENDIF
C--SEARCH IN THE JET
        CALL HWBRC2(COLP,IHEP,JC,.FALSE.,BVVUSE,.FALSE.)
        IF(COLP.NE.0) JDAHEP(2,IHEP) = COLP
      ENDIF
 500  CONTINUE
C--Flavour and anticolour connections in Rslash
      DO 610 IHEP=1,NHEP
        IST=ISTHEP(IHEP)
        IF(IST.LT.145.OR.IST.GT.152.OR.JDAHEP(2,IHEP).NE.0) GOTO 610
        JD = 0
        BVVUSE = .FALSE.
        JC = JMOHEP(1,IHEP)
        IF(IST.NE.152) JC = JMOHEP(1,JC)
        IF(JC.EQ.0) CALL HWWARN('HWBRCN',51,*610)
C--For particles which came from a top decay
        IF(ABS(IDHEP(JMOHEP(1,JC))).EQ.6) THEN
          JD = JMOHEP(1,JMOHEP(1,JMOHEP(1,JC)))
C--flavour connect to self if needed
          IF(JDAHEP(2,JMOHEP(1,JC)-1).EQ.JMOHEP(1,JC)) THEN
            JDAHEP(2,IHEP) = IHEP
            GOTO 610
          ELSEIF(JDAHEP(2,JMOHEP(1,JC)-1).NE.0) THEN
            JDAHEP(2,IHEP) = JDAHEP(2,JMOHEP(1,JC)-1)
            GOTO 610
          ELSE
            JC = JD
          ENDIF
        ENDIF
C--Decide if this came from a BV decay
        IDM = JMOHEP(1,JC)
        IF(BVDEC1(IDM).OR.BVDEC2(IDM).OR.BVDEC3(IDM).
     &     OR.BVHRD(IDM).OR.BVHRD2(IDM)) THEN
C--Do BV piece
          IF(JDAHEP(2,JC).EQ.JMOHEP(1,JC)) THEN
           IF(IDHW(JMOHEP(1,JC)).EQ.449.AND.
     &        JDAHEP(1,JMOHEP(1,JC)).EQ.JC) THEN
              JC = JDAHEP(2,JMOHEP(1,JC)-1)
            ELSE
              JC = JMOHEP(2,JMOHEP(1,JC))
            ENDIF
            IF(ABS(IDHEP(JC)).LT.1000000) THEN
              IF(JDAHEP(1,JC).EQ.0) THEN
                JDAHEP(2,IHEP) = JC
                GOTO 610
              ELSE
                GOTO 600
              ENDIF
            ELSEIF(ABS(IDHEP(JC)).GT.1000000
     &        .AND.ISTHEP(JC).NE.155) THEN
              GOTO 610
            ENDIF
            IF(ISTHEP(JC).EQ.155.AND.ACOLRD(IDHW(IHEP))) THEN
              JC = JDAHEP(1,JC)
            ELSE
              IF(ISTHEP(JC).EQ.155.AND.IDHW(JDAHEP(1,JC)).NE.449) THEN
                JC = JDAHEP(1,JC)
              ELSE
                JC = JDAHEP(2,JC)
              ENDIF
            ENDIF
          ELSE
C--For the hard process
            IF(IDHW(IDM).EQ.15.AND.JC.EQ.JDAHEP(2,JMOHEP(1,JC))) THEN
              JDAHEP(2,IHEP) = JDAHEP(2,JC)
              GOTO 610
            ELSEIF(IDHW(IDM).EQ.15.AND.IDHW(IHEP).NE.449) THEN
              JD=HRDCOL(1,1)
              IF(BVHRD(IDM).AND.IDHW(JDAHEP(2,IDM)).NE.449) THEN
                JC = JDAHEP(2,JC)
                GOTO 600
              ELSEIF(JMOHEP(1,JDAHEP(2,JC)).EQ.JD) THEN
                JC=JDAHEP(2,JC)
                GOTO 600
              ENDIF
              IF(JDAHEP(2,JC).EQ.8) JC = JD
            ELSE
              JD=JMOHEP(2,JMOHEP(1,JC))
            ENDIF
            IF(COLRD(IDHW(IHEP)).AND..NOT.ACOLRD(IDHW(IHEP)).AND.
     &      ABS(IDHEP(JD)).GT.1000000.AND.ISTHEP(JD).NE.155) THEN
              JDAHEP(2,IHEP) = JD
              IF(JDAHEP(2,JD).EQ.0) JDAHEP(2,JD) = IHEP
            ENDIF
            IF(ABS(IDHEP(JD)).GT.1000000
     &        .AND.ISTHEP(JD).NE.155) GOTO 610
            IF(ISTHEP(JC).EQ.149) THEN
              JDAHEP(2,IHEP)=JC
              GOTO 610
            ENDIF
          IF(ACOLRD(IDHW(IHEP)).AND.IDHW(JC).EQ.449.AND.BVDEC2(JC)) THEN
              JC = JDAHEP(1,JC)
            ELSE
              JC = JDAHEP(2,JC)
            ENDIF
          ENDIF
C--SEARCH IN THE JET
 600      CALL HWBRC2(COLP,IHEP,JC,.FALSE.,BVVUSE,.FALSE.)
          IF(COLP.NE.0) THEN
            IF(ABS(IDHEP(COLP)).EQ.6.AND.JDAHEP(1,COLP).NE.0) THEN
              IF(ISTHEP(COLP).EQ.155) THEN
                JC = JDAHEP(2,COLP)
              ELSE
                JC = JDAHEP(2,JDAHEP(2,COLP))
              ENDIF
              GOTO 600
            ENDIF
            JDAHEP(2,IHEP) = COLP
          ENDIF
        ELSE
C--check if it came from a top
          IF(ABS(IDHEP(JC)).EQ.6) THEN
C--start the analysis again
            JC = JMOHEP(1,IHEP)
            IF(IST.NE.152) JC = JMOHEP(1,JC)
            JC = JDAHEP(2,JC)
            IF(JC.EQ.0) CALL HWWARN('HWBRCN',52,*610)
              IF(ISTHEP(JC).EQ.155) THEN
                IF (IDHEP(JMOHEP(1,JC)).EQ.94) THEN
C---DECAYED BEFORE HADRONIZING
                  JHEP=JDAHEP(2,JC-1)
                  IF (JHEP.EQ.0) GO TO 610
                  ID=IDHW(JHEP)
                  IF (ISTHEP(JHEP).EQ.155) THEN
C---SPECIAL FOR GLUINO DECAYS
                    IF (ID.EQ.449) THEN
                      CALL HWBRC1(JC,ID,JHEP,.TRUE.,*999)
                    ELSE
                      JC=JDAHEP(2,JHEP)
                    ENDIF
                  ELSE
                    IF(JMOHEP(2,JHEP).EQ.JC) JMOHEP(2,JHEP)=IHEP
                    JDAHEP(2,IHEP) = JHEP
                    GOTO 610
                  ENDIF
                ELSE
                  JC=JDAHEP(2,JC-1)
                ENDIF
              ENDIF
C--SEARCH IN JET
              CALL HWBRC2(COLP,IHEP,JC,.FALSE.,BVVUSE,.FALSE.)
              IF(COLP.NE.0) JDAHEP(2,IHEP) = COLP
          ELSE
            CALL HWWARN('HWBRCN',100,*610)
          ENDIF
        ENDIF
 610  CONTINUE
 999  END
CDECK  ID>, HWBRC1.
*CMZ :-        -20/07/99  10:56:12  by  Peter Richardson
*-- Author :    PeterRichardson
C-----------------------------------------------------------------------
      SUBROUTINE HWBRC1(JC,ID,JHEP,COL,*)
C-----------------------------------------------------------------------
C--Function to find the right daugther of a decaying gluino
C-----------------------------------------------------------------------
      INCLUDE 'HERWIG62.INC'
      INTEGER ID,JHEP,KC,JC
      LOGICAL COL
C---N.B. WILL NEED MODS WHEN SUSY PARTICLES CAN SHOWER
C--Rparity take the first daughther
      IF(IDHW(JDAHEP(1,JHEP)).LE.12.AND.IDHW(JDAHEP(1,JHEP)+1).LE.12
     &   .AND.IDHW(JDAHEP(2,JHEP)).LE.12) THEN
        KC = JDAHEP(1,JHEP)
        GOTO 20
      ELSEIF ((COL.AND.(ID.EQ.449.OR.ID.EQ.13)).OR.
     &        (ID.GE.401.AND.ID.LE.406).OR.
     &       (ID.GE.413.AND.ID.LE.418).OR.ID.LE.6.OR.
     &       (ID.GE.115.AND.ID.LE.120)) THEN
C---LOOK FOR ANTI(S)QUARK OR GLUON
        DO KC=JDAHEP(1,JHEP),JDAHEP(2,JHEP)
          ID=IDHW(KC)
          IF ((ID.GE.7.AND.ID.LE.13).OR.(ID.GE.407.AND.ID.LE.412).OR.
     &       (ID.GE.419.AND.ID.LE.424)) GOTO 20
        ENDDO
      ELSE
C---LOOK FOR (S)QUARK OR GLUON
        DO KC=JDAHEP(1,JHEP),JDAHEP(2,JHEP)
          ID=IDHW(KC)
          IF (ID.LE.  6.OR. ID.EQ. 13.OR.(ID.GE.401.AND.ID.LE.406).OR.
     &       (ID.GE.413.AND.ID.LE.418)) GOTO 20
        ENDDO
      ENDIF
C---COULDNT FIND ONE
      CALL HWWARN('HWBRC1',100,*10)
 10   RETURN 1
 20   JC=KC
      END
CDECK  ID>, HWBRC2.
*CMZ :-        -20/07/99  10:56:12  by  Peter Richardson
*-- Author :    Peter Richardson
C-----------------------------------------------------------------------
      SUBROUTINE HWBRC2(COLP,IHEP,JC,CON,BVVUSE,BVVHRD)
C-----------------------------------------------------------------------
C--Function to search in the jet for the particle
C-----------------------------------------------------------------------
      INCLUDE 'HERWIG62.INC'
      INTEGER JC,JD,QHEP,LHEP,IHEP,JHEP,IDM,NCOUNT,ID,IP,IDM2,COLP
      LOGICAL CON,BVVUSE,FLA,AFLA,BVVHRD
      FLA(IP)  = (IP.LE.6.OR.(IP.GE.115.AND.IP.LE.120).
     &           OR.(IP.GE.401.AND.IP.LE.406).
     &           OR.(IP.GE.413.AND.IP.LE.418))
      AFLA(IP) = ((IP.LE.12.AND.IP.GE.7).OR.(IP.GE.109.AND.IP.LE.114).
     &           OR.(IP.GE.407.AND.IP.LE.412).
     &           OR.(IP.GE.419.AND.IP.LE.424))
      ID = IDHW(IHEP)
      COLP = 0
C--begining and end of jet
      IF(JDAHEP(1,JC).NE.0) THEN
        JC=JDAHEP(1,JC)
        JD=JDAHEP(2,JC)
      ELSE
        COLP = JC
        RETURN
      ENDIF
      IF (JD.LT.JC) JD=JC
      LHEP=0
      IF(CON) THEN
C--SEARCH FOR A COLOUR PARTNER
        DO 110 JHEP=JC,JD
          IDM = IDHW(JHEP)
        IF (ISTHEP(JHEP).LT.145.OR.ISTHEP(JHEP).GT.152) GOTO 110
        IF(AFLA(ID).AND.IDM.EQ.13) GOTO 110
        IF (JDAHEP(2,JHEP).EQ.IHEP) LHEP=JHEP
        IF ((BVVUSE.AND.JMOHEP(2,JHEP).NE.0).OR.
     &      (.NOT.BVVUSE.AND.JDAHEP(2,JHEP).NE.0)) GOTO 110
        IF(BVVUSE.AND.ABS(IDHEP(JHEP)).GT.1000000) THEN
          IF(BVVHRD.AND.AFLA(ID)) THEN
            CONTINUE
          ELSE
            RETURN
          ENDIF
        ENDIF
        IF(BVVUSE.AND.(
     &      ((FLA(ID).OR.ID.EQ.13.OR.ID.EQ.449).AND.AFLA(IDM)).
     &  OR.(AFLA(ID).AND.(FLA(IDM).OR.IDM.EQ.13.OR.IDM.EQ.449))))
     &     GOTO 110
        IF(AFLA(ID).AND.(IDM.EQ.59.OR.IDM.EQ.449.OR.IDM.EQ.13)) GOTO 110
C---JOIN IHEP AND JHEP
        COLP=JHEP
        IF(BVVUSE.OR.(ID.GE.7.AND.ID.LE.12.
     &     AND.((IDM.GE.7.AND.IDM.LE.12)))) RETURN
        IF(IHEP.NE.HRDCOL(1,2).AND.
     &     (((FLA(ID).OR.ID.EQ.13.OR.ID.EQ.449.OR.ID.EQ.59)
     &       .AND.(AFLA(IDM).OR.IDM.EQ.13.OR.IDM.EQ.449.OR.IDM.EQ.59))
     &     .OR.(AFLA(ID).AND.(FLA(IDM).OR.IDM.EQ.59))))
     &    JDAHEP(2,JHEP)=IHEP
        RETURN
 110    CONTINUE
        IF (LHEP.NE.0) COLP=LHEP
C--Additional Baryon number violating piece
        IF(COLP.EQ.0) THEN
          IDM2= IDHW(JC)
         IF(JMOHEP(1,JC).LT.6) THEN
           IF(IDM2.LE.6) THEN
             IDM2= IDM2+6
           ELSEIF(IDM2.GT.6) THEN
             IDM2=IDM2-6
           ENDIF
         ENDIF
          IF(IHEP.EQ.HRDCOL(1,2).OR.
     &     ((FLA(ID).OR.ID.EQ.13.OR.ID.EQ.449.OR.ID.EQ.15.OR.ID.EQ.59)
     &       .AND.(AFLA(IDM2).OR.IDM2.EQ.13.OR.IDM2.EQ.13))) THEN
              QHEP = JD+1
 12           QHEP = QHEP-1
              IF(IDHEP(QHEP).EQ.0) GOTO 12
              IF(IDHW(QHEP).EQ.59) THEN
              IF(JC.EQ.JD.AND.IDHW(JMOHEP(1,QHEP)).EQ.59) THEN
                COLP = IHEP
                RETURN
              ELSE
                GOTO 12
              ENDIF
              ENDIF
              NCOUNT = 0
 11           IF(JDAHEP(2,QHEP).NE.0) THEN
                IF(JMOHEP(2,JDAHEP(2,QHEP)).EQ.QHEP.AND.
     &             JDAHEP(2,QHEP).NE.QHEP) THEN
                 IF(JDAHEP(2,QHEP).GE.JC.AND.JDAHEP(2,QHEP).LE.JD) THEN
                   QHEP = JDAHEP(2,QHEP)
                   NCOUNT = NCOUNT+1
                   IF(NCOUNT.LT.NHEP) GOTO 11
                 ENDIF
                ENDIF
              ENDIF
            ELSE
            QHEP = JC
 13         QHEP = QHEP+1
            IF(IDHEP(QHEP).EQ.0) GOTO 13
            IF(IDHW(QHEP).EQ.59) THEN
              IF(JC.EQ.JD.AND.IDHW(JMOHEP(1,QHEP)).EQ.59) THEN
                COLP = IHEP
                RETURN
              ELSE
                GOTO 13
              ENDIF
            ENDIF
            NCOUNT = 0
 9          IF(JMOHEP(2,QHEP).NE.0) THEN
            IF(JDAHEP(2,JMOHEP(2,QHEP)).EQ.QHEP.AND.
     &         JMOHEP(2,QHEP).NE.QHEP) THEN
               IF(JMOHEP(2,QHEP).GE.JC.AND.JMOHEP(2,QHEP).LE.JD) THEN
                 QHEP = JMOHEP(2,QHEP)
                 NCOUNT = NCOUNT+1
                 IF(NCOUNT.LT.NHEP) GOTO 9
               ENDIF
            ENDIF
            ENDIF
          ENDIF
          IF(ABS(IDHEP(QHEP)).LT.1000000) COLP=QHEP
        ENDIF
      ELSE
C--Search for an anticolour partner
        DO 210 JHEP=JC,JD
        IF (ISTHEP(JHEP).LT.145.OR.ISTHEP(JHEP).GT.152) GOTO 210
        IF (JMOHEP(2,JHEP).EQ.IHEP) LHEP=JHEP
        IF (JMOHEP(2,JHEP).NE.0) GOTO 210
C---JOIN IHEP AND JHEP
        COLP=JHEP
        RETURN
 210   CONTINUE
       IF (LHEP.NE.0) COLP=LHEP
C--New piece
       IF(COLP.EQ.0) THEN
         IDM2=IDHW(JC)
         IF(JMOHEP(1,JC).LT.6) THEN
           IF(IDM2.LE.6) THEN
             IDM2= IDM2+6
           ELSEIF(IDM2.GT.6) THEN
             IDM2=IDM2-6
           ENDIF
         ENDIF
C--Additional Baryon number violating piece
        IF((FLA(ID).AND.AFLA(IDM2)).OR.
     & ((AFLA(ID).OR.ID.EQ.13.OR.ID.EQ.449.OR.ID.EQ.15.OR.ID.EQ.59)
     &    .AND.(FLA(IDM2).OR.IDM2.EQ.13.OR.IDM2.EQ.449))) THEN
         QHEP = JC
 211     QHEP = QHEP+1
         IF(IDHEP(QHEP).EQ.0) GOTO 211
         IF(IDHW(QHEP).EQ.59) THEN
           IF(JC.EQ.JD.AND.IDHW(JMOHEP(1,QHEP)).EQ.59) THEN
             COLP = IHEP
             RETURN
           ELSE
             GOTO 211
           ENDIF
         ENDIF
         NCOUNT = 0
 209     IF(JMOHEP(2,QHEP).NE.0) THEN
           IF(JDAHEP(2,JMOHEP(2,QHEP)).EQ.QHEP.AND.
     &        JMOHEP(2,QHEP).NE.QHEP) THEN
              IF(JMOHEP(2,QHEP).GE.JC.AND.JMOHEP(2,QHEP).LE.JD) THEN
                QHEP = JMOHEP(2,QHEP)
                NCOUNT = NCOUNT+1
                IF(NCOUNT.LT.NHEP) GOTO 209
              ENDIF
           ENDIF
         ENDIF
        IF(QHEP.NE.0) COLP=QHEP
        IF(JDAHEP(2,QHEP).EQ.0.AND.IHEP.NE.6) THEN
          IDM2= IDHW(QHEP)
          IF(FLA(IHEP).AND.FLA(QHEP).OR.
     &       ((AFLA(IHEP).OR.ID.EQ.13.OR.ID.EQ.449).AND.
     &        (AFLA(QHEP).OR.IDM2.EQ.13.OR.IDM2.EQ.449)))
     &        JDAHEP(2,QHEP)=IHEP
        ENDIF
        ELSE
         QHEP = JD+1
 220     QHEP = QHEP-1
         IF(IDHEP(QHEP).EQ.0) GOTO 220
         IF(IDHW(QHEP).EQ.59) THEN
           IF(JC.EQ.JD.AND.IDHW(JMOHEP(1,QHEP)).EQ.59) THEN
             COLP = IHEP
             RETURN
           ELSE
             GOTO 220
           ENDIF
         ENDIF
          NCOUNT = 0
 219       IF(JDAHEP(2,QHEP).NE.0) THEN
            IF(JMOHEP(2,JDAHEP(2,QHEP)).EQ.QHEP) THEN
              IF(JDAHEP(2,QHEP).GE.JC.AND.JDAHEP(2,QHEP).LE.JD) THEN
                QHEP = JDAHEP(2,QHEP)
                NCOUNT = NCOUNT+1
                IF(NCOUNT.LT.200) GOTO 219
              ENDIF
            ENDIF
          ENDIF
        IF(QHEP.NE.0) COLP=QHEP
        IDM2 = IDHW(QHEP)
        IF(JDAHEP(2,QHEP).EQ.0.AND.
     &     (((AFLA(ID).OR.ID.EQ.13).AND.(AFLA(IDM2).OR.IDM2.EQ.13)).OR.
     &     (FLA(ID).AND.FLA(IDM2)))) JDAHEP(2,QHEP)=IHEP
        ENDIF
       ENDIF
      ENDIF
      END
CDECK  ID>, HWBSPA.
*CMZ :-        -26/04/91  14.26.44  by  Federico Carminati
*-- Author :    Ian Knowles
C-----------------------------------------------------------------------
      SUBROUTINE HWBSPA
C-----------------------------------------------------------------------
C     Constructs time-like 4-momenta & production vertices in space-like
C     jet started by parton no.2 interference partner 1 and spin density
C     DECPAR(2). RHOPAR(2) gives the jet spin density matrix.
C     See I.G. Knowles, Comp. Phys. Comm. 58 (90) 271.
C-----------------------------------------------------------------------
      INCLUDE 'HERWIG62.INC'
      DOUBLE PRECISION HWRGEN,DMIN,PT,EIKON,EISCR,EINUM,EIDEN1,EIDEN2,
     & WT,SPIN,Z1,Z2,TR,PRMAX,CX,SX,CAZ,ROHEP(3),RMAT(3,3),ZERO2(2)
      INTEGER JPAR,KPAR,LPAR,MPAR
      LOGICAL EICOR
      EXTERNAL HWRGEN
      DATA ZERO2,DMIN/ZERO,ZERO,1.D-15/
      IF (IERROR.NE.0) RETURN
      JPAR=2
      KPAR=1
      IF (NPAR.EQ.2) THEN
         CALL HWVZRO(2,RHOPAR(1,2))
         RETURN
      ENDIF
C Generate azimuthal angle of JPAR's branching using an M-function
C     Find the daughters of JPAR, with LPAR time-like
  10  LPAR=JDAPAR(1,JPAR)
      IF (TMPAR(LPAR)) THEN
         MPAR=LPAR+1
      ELSE
         MPAR=LPAR
         LPAR=MPAR+1
      ENDIF
C Soft correlations
      CALL HWUROT(PPAR(1,JPAR), ONE,ZERO,RMAT)
      CALL HWUROF(RMAT,PPAR(1,KPAR),ROHEP)
      PT=MAX(SQRT(ROHEP(1)*ROHEP(1)+ROHEP(2)*ROHEP(2)),DMIN)
      EIKON=1.
      EICOR=AZSOFT.AND.IDPAR(LPAR).EQ.13
      IF (EICOR) THEN
         EISCR=1.-PPAR(5,MPAR)*PPAR(5,MPAR)/(MIN(PPAR(2,LPAR),
     &   PPAR(2,MPAR))*PPAR(4,MPAR)*PPAR(4,MPAR))
         EINUM=PPAR(4,KPAR)*PPAR(4,LPAR)*ABS(PPAR(2,LPAR)-PPAR(2,MPAR))
         EIDEN1=PPAR(4,KPAR)*PPAR(4,LPAR)-ROHEP(3)*PPAR(3,LPAR)
         EIDEN2=PT*ABS(PPAR(1,LPAR))
         EIKON=MAX(EISCR+EINUM/MAX(EIDEN1-EIDEN2,DMIN),ZERO)
      ENDIF
C Spin correlations
      WT=0.
      SPIN=1.
      IF (AZSPIN.AND.IDPAR(JPAR).EQ.13) THEN
         Z1=PPAR(4,JPAR)/PPAR(4,MPAR)
         Z2=1.-Z1
         IF (IDPAR(MPAR).EQ.13) THEN
            TR=Z1/Z2+Z2/Z1+Z1*Z2
         ELSEIF (IDPAR(MPAR).LT.13) THEN
            TR=(Z1*Z1+Z2*Z2)/2.
         ENDIF
         WT=Z2/(Z1*TR)
      ENDIF
C Assign the azimuthal angle
      PRMAX=(1.+ABS(WT))*EIKON
  50  CALL HWRAZM( ONE,CX,SX)
      CALL HWUROT(PPAR(1,JPAR),CX,SX,RMAT)
C Determine the angle between the branching planes
      CALL HWUROF(RMAT,PPAR(1,KPAR),ROHEP)
      CAZ=ROHEP(1)/PT
      PHIPAR(1,JPAR)=2.*CAZ*CAZ-1.
      PHIPAR(2,JPAR)=2.*CAZ*ROHEP(2)/PT
      IF (EICOR) EIKON=MAX(EISCR+EINUM/MAX(EIDEN1-EIDEN2*CAZ,DMIN),ZERO)
      IF (AZSPIN) SPIN=1.+WT*(DECPAR(1,JPAR)*PHIPAR(1,JPAR)
     &                       +DECPAR(2,JPAR)*PHIPAR(2,JPAR))
      IF (SPIN*EIKON.LT.HWRGEN(0)*PRMAX) GOTO 50
C Construct full 4-momentum of LPAR, sum P-trans of MPAR
      PPAR(2,LPAR)=0.
      PPAR(2,MPAR)=0.
      CALL HWUROB(RMAT,PPAR(1,LPAR),PPAR(1,LPAR))
      CALL HWVDIF(2,PPAR(1,2),PPAR(1,LPAR),PPAR(1,2))
C Test for end of space-like branches
      IF (JDAPAR(1,MPAR).EQ.0) GOTO 60
C     Generate new Decay matrix
      CALL HWBAZF(MPAR,JPAR,ZERO2,DECPAR(1,JPAR),
     &            PHIPAR(1,JPAR),DECPAR(1,MPAR))
C     Advance along the space-like branch
      JPAR=MPAR
      KPAR=LPAR
      GOTO 10
C Retreat along space-like line
C     Assign initial spin density matrix
  60  CALL HWVEQU(2,ZERO2,RHOPAR(1,MPAR))
      CALL HWUMAS(PPAR(1,2))
      CALL HWVZRO(4,VPAR(1,MPAR))
  70  CALL HWVEQU(4,VPAR(1,MPAR),VPAR(1,LPAR))
      IF (MPAR.EQ.2) RETURN
C Construct spin density matrix for time-like branch
      CALL HWBAZF(MPAR,JPAR,RHOPAR(1,MPAR),PHIPAR(1,JPAR),
     &                      DECPAR(1,JPAR),RHOPAR(1,LPAR))
C Evolve time-like side branch
      CALL HWBTIM(LPAR,MPAR)
C Construct spin density matrix for space-like branch
      CALL HWBAZF(MPAR,JPAR,PHIPAR(1,JPAR),RHOPAR(1,MPAR),
     &                      DECPAR(1,LPAR),RHOPAR(1,JPAR))
C Assign production vertex to J
      CALL HWVDIF(4,PPAR(1,MPAR),PPAR(1,LPAR),PPAR(1,JPAR))
      CALL HWUDKL(IDPAR(JPAR),PPAR(1,JPAR),VPAR(1,JPAR))
      CALL HWVSUM(4,VPAR(1,MPAR),VPAR(1,JPAR),VPAR(1,JPAR))
C Find parent and partner of MPAR
      MPAR=JPAR
      JPAR=JMOPAR(1,MPAR)
      LPAR=MPAR+1
      IF (JMOPAR(1,LPAR).NE.JPAR) LPAR=MPAR-1
      GOTO 70
      END
CDECK  ID>, HWBSPN.
*CMZ :-        -26/04/91  11.11.54  by  Bryan Webber
*-- Author :    Ian Knowles
C-----------------------------------------------------------------------
      SUBROUTINE HWBSPN
C-----------------------------------------------------------------------
C     Constructs appropriate spin density/decay matrix for parton
C     in hard subprocess, othwise zero. Assignments based upon
C     Comp. Phys. Comm. 58 (1990) 271.
C-----------------------------------------------------------------------
      INCLUDE 'HERWIG62.INC'
      DOUBLE PRECISION C,V12,V23,V13,TR,C1,C2,C3,R1(2),R2(2)
      INTEGER IST
      SAVE R1,R2,V12
      IF (IERROR.NE.0) RETURN
      IST=MOD(ISTHEP(NEVPAR),10)
C Assumed partons processed in the order IST=1,2,3,4
      IF (IPROC.GE.100.AND.IPROC.LE.116) THEN
C  An e+e- ---> qqbar g event
         IF (IDPAR(2).EQ.13) THEN
            RHOPAR(1,2)=GPOLN
            RHOPAR(2,2)=0.
            RETURN
         ENDIF
      ELSEIF (IPRO.EQ.15.OR.IPRO.EQ.17) THEN
         IF (IHPRO.EQ. 7.OR.IHPRO.EQ. 8.OR.
     &       IHPRO.EQ.10.OR.IHPRO.EQ.11.OR.
     &       IHPRO.EQ.15.OR.IHPRO.EQ.16.OR.
     &      (IHPRO.GE.21.AND.IHPRO.LE.31)) THEN
C A hard 2 --- > 2 QCD subprocess involving gluons
            IF (IST.EQ.2) THEN
               CALL HWVEQU(2,RHOPAR(1,2),R1(1))
               C=GCOEF(2)/GCOEF(1)
               DECPAR(1,2)=C*R1(1)
               DECPAR(2,2)=C*R1(2)
               RETURN
            ELSEIF (IST.EQ.3) THEN
               CALL HWVEQU(2,RHOPAR(1,2),R2(1))
               V12=R1(1)*R2(1)+R1(2)*R2(2)
               TR=1./(GCOEF(1)+GCOEF(2)*V12)
               RHOPAR(1,2)= (GCOEF(3)*R1(1)+GCOEF(4)*R2(1))*TR
               RHOPAR(2,2)=-(GCOEF(3)*R1(2)+GCOEF(4)*R2(2))*TR
               RETURN
            ELSEIF (IST.EQ.4) THEN
               V13=R1(1)*DECPAR(1,2)+R1(2)*DECPAR(2,2)
               V23=R2(1)*DECPAR(1,2)+R2(2)*DECPAR(2,2)
               TR=1./(GCOEF(1)+GCOEF(2)*V12+GCOEF(3)*V13+GCOEF(4)*V23)
               C1=(GCOEF(2)+GCOEF(5))*TR
               C2=(GCOEF(3)+GCOEF(6))*TR
               C3=(GCOEF(4)+GCOEF(6))*TR
               RHOPAR(1,2)=C1*DECPAR(1,2)+C2*R2(1)+C3*R1(1)
               RHOPAR(2,2)=C1*DECPAR(2,2)-C2*R1(2)-C3*R2(2)
               RETURN
            ENDIF
         ENDIF
      ELSEIF (IPRO.EQ.16) THEN
C A gluon fusion ---> Higgs event
         IF (IST.EQ.2) THEN
            DECPAR(1,2)=RHOPAR(1,2)
            DECPAR(2,2)=-RHOPAR(2,2)
            RETURN
         ENDIF
      ENDIF
      CALL HWVZRO(2,RHOPAR(1,2))
      CALL HWVZRO(2,DECPAR(1,2))
      END
CDECK  ID>, HWBSU1.
*CMZ :-        -13/07/92  20.15.54  by  Mike Seymour
*-- Author :    Bryan Webber, modified by Mike Seymour
C-----------------------------------------------------------------------
      FUNCTION HWBSU1(ZLOG)
C-----------------------------------------------------------------------
C     Z TIMES THE INTEGRAND IN EXPONENT OF QUARK SUDAKOV FORM FACTOR.
C     HWBSU1 IS FOR UPPER PART OF Z INTEGRATION REGION
C-----------------------------------------------------------------------
      DOUBLE PRECISION HWBSU1,HWBSUL,Z,ZLOG,U
      EXTERNAL HWBSUL
      Z=EXP(ZLOG)
      U=1.-Z
      HWBSU1=HWBSUL(Z)*(1.+U*U)
      END
CDECK  ID>, HWBSU2.
*CMZ :-        -13/07/92  20.15.54  by  Mike Seymour
*-- Author :    Bryan Webber, modified by Mike Seymour
C-----------------------------------------------------------------------
      FUNCTION HWBSU2(Z)
C-----------------------------------------------------------------------
C     INTEGRAND IN EXPONENT OF QUARK SUDAKOV FORM FACTOR.
C     HWBSU2 IS FOR LOWER PART OF Z INTEGRATION REGION
C-----------------------------------------------------------------------
      DOUBLE PRECISION HWBSU2,HWBSUL,Z,U
      EXTERNAL HWBSUL
      U=1.-Z
      HWBSU2=HWBSUL(Z)*(1.+Z*Z)/U
      END
CDECK  ID>, HWBSUD.
*CMZ :-        -14/07/92  13.28.23  by  Mike Seymour
*-- Author :    Bryan Webber
C-----------------------------------------------------------------------
      SUBROUTINE HWBSUD
C-----------------------------------------------------------------------
C     COMPUTES (OR READS) TABLES OF SUDAKOV FORM FACTORS
C-----------------------------------------------------------------------
      INCLUDE 'HERWIG62.INC'
      DOUBLE PRECISION HWUGAU,HWBVMC,HWBSUG,HWBSU1,HWBSU2,G1,G2,QRAT,
     & QLAM,POWER,AFAC,QMIN,QFAC,QNOW,ZMIN,ZMAX,Q1,QCOLD,VGOLD,VQOLD,
     & RMOLD(6),ACOLD,ZLO,ZHI
      INTEGER IQ,IS,L1,L2,L,LL,I,INOLD,NQOLD,NSOLD,NCOLD,NFOLD,SDOLD
      EXTERNAL HWUGAU,HWBVMC,HWBSUG,HWBSU1,HWBSU2
      SAVE NQOLD,NSOLD,NCOLD,NFOLD,SDOLD,QCOLD,VGOLD,VQOLD,RMOLD,ACOLD,
     & INOLD
      COMMON/HWSINT/QRAT,QLAM
      IF (LRSUD.EQ.0) THEN
        POWER=1./FLOAT(NQEV-1)
        AFAC=6.*CAFAC/BETAF
        QMIN=QG+QG
        QFAC=(1.1*QLIM/QMIN)**POWER
        SUD(1,1)=1.
        QEV(1,1)=QMIN
C--IS=1 FOR GLUON->GLUON+GLUON FORM FACTOR
        DO 10 IQ=2,NQEV
        QNOW=QFAC*QEV(IQ-1,1)
        QLAM=QNOW/QCDL3
        ZMIN=QG/QNOW
        QRAT=1./ZMIN
        G1=0
        DO 5 I=3,6
          ZLO=ZMIN
          ZHI=HALF
          IF (I.NE.6) ZLO=MAX(ZLO,QG/RMASS(I+1))
          IF (I.NE.3) ZHI=MIN(ZHI,QG/RMASS(I))
          IF (ZHI.GT.ZLO) G1=G1+HWUGAU(HWBSUG,LOG(ZLO),LOG(ZHI),ACCUR)
    5   CONTINUE
        SUD(IQ,1)=EXP(AFAC*G1)
   10   QEV(IQ,1)=QNOW
        AFAC=3.*CFFAC/BETAF
C--QUARK FORM FACTORS.
C--IS=2,3,4,5,6,7 FOR U/D,S,C,B,T,V
        DO 15 IS=2,NSUD
        Q1=HWBVMC(IS)
        IF (IS.EQ.7) Q1=HWBVMC(209)
        QMIN=Q1+QG
        IF (QMIN.GT.QLIM) GOTO 15
        QFAC=(1.1*QLIM/QMIN)**POWER
        SUD(1,IS)=1.
        QEV(1,IS)=QMIN
        DO 14 IQ=2,NQEV
        QNOW=QFAC*QEV(IQ-1,IS)
        QLAM=QNOW/QCDL3
        ZMIN=QG/QNOW
        QRAT=1./ZMIN
        ZMAX=QG/QMIN
        G1=0
        DO 12 I=3,6
          ZLO=ZMIN
          ZHI=ZMAX
          IF (I.NE.6) ZLO=MAX(ZLO,QG/RMASS(I+1))
          IF (I.NE.3) ZHI=MIN(ZHI,QG/RMASS(I))
          IF (ZHI.GT.ZLO) G1=G1+HWUGAU(HWBSU1,LOG(ZLO),LOG(ZHI),ACCUR)
   12   CONTINUE
        ZMIN=Q1/QNOW
        QRAT=1./ZMIN
        ZMAX=Q1/QMIN
        G2=0
        DO 13 I=3,6
          ZLO=ZMIN
          ZHI=ZMAX
          IF (I.NE.6) ZLO=MAX(ZLO,Q1/RMASS(I+1))
          IF (I.NE.3) ZHI=MIN(ZHI,Q1/RMASS(I))
          IF (ZHI.GT.ZLO) G2=G2+HWUGAU(HWBSU2,ZLO,ZHI,ACCUR)
   13   CONTINUE
        SUD(IQ,IS)=EXP(AFAC*(G1+G2))
   14   QEV(IQ,IS)=QNOW
   15   CONTINUE
        QCOLD=QCDLAM
        VGOLD=VGCUT
        VQOLD=VQCUT
        ACOLD=ACCUR
        INOLD=INTER
        NQOLD=NQEV
        NSOLD=NSUD
        NCOLD=NCOLO
        NFOLD=NFLAV
        SDOLD=SUDORD
        DO 16 IS=1,NSUD
   16   RMOLD(IS)=RMASS(IS)
      ELSE
        IF (LRSUD.GT.0) THEN
          IF (IPRINT.NE.0) WRITE (6,17) LRSUD
   17     FORMAT(/10X,'READING SUDAKOV TABLE ON UNIT',I4)
          OPEN(UNIT=LRSUD,FORM='UNFORMATTED',STATUS='UNKNOWN')
          READ(UNIT=LRSUD) QCOLD,VGOLD,VQOLD,RMOLD,
     &       ACOLD,QEV,SUD,INOLD,NQOLD,NSOLD,NCOLD,NFOLD,SDOLD
          CLOSE(UNIT=LRSUD)
        ENDIF
C---CHECK THAT RELEVANT PARAMETERS ARE UNCHANGED
        IF (QCDLAM.NE.QCOLD) CALL HWWARN('HWBSUD',501,*999)
        IF (VGCUT .NE.VGOLD) CALL HWWARN('HWBSUD',502,*999)
        IF (VQCUT .NE.VQOLD) CALL HWWARN('HWBSUD',503,*999)
        IF (ACCUR .NE.ACOLD) CALL HWWARN('HWBSUD',504,*999)
        IF (INTER .NE.INOLD) CALL HWWARN('HWBSUD',505,*999)
        IF (NQEV  .NE.NQOLD) CALL HWWARN('HWBSUD',506,*999)
        IF (NSUD  .NE.NSOLD) CALL HWWARN('HWBSUD',507,*999)
        IF (NCOLO .NE.NCOLD) CALL HWWARN('HWBSUD',508,*999)
        IF (NFLAV .NE.NFOLD) CALL HWWARN('HWBSUD',509,*999)
        IF (SUDORD.NE.SDOLD) CALL HWWARN('HWBSUD',510,*999)
C---CHECK MASSES AND THAT TABLES ARE BIG ENOUGH FOR THIS RUN
        DO 18 IS=1,NSUD
          IF (RMASS(IS).NE.RMOLD(IS))
     &      CALL HWWARN('HWBSUD',510+IS,*999)
          IF (QEV(NQEV,IS).LT.QLIM.AND.HWBVMC(IS)+QG.LT.QLIM)
     &      CALL HWWARN('HWBSUD',500,*999)
   18   CONTINUE
      ENDIF
      IF (LWSUD.GT.0) THEN
        IF (IPRINT.NE.0) WRITE (6,19) LWSUD
   19   FORMAT(/10X,'WRITING SUDAKOV TABLE ON UNIT',I4)
        OPEN (UNIT=LWSUD,FORM='UNFORMATTED',STATUS='UNKNOWN')
        WRITE(UNIT=LWSUD)  QCDLAM,VGCUT,VQCUT,(RMASS(I),I=1,6),
     &     ACCUR,QEV,SUD,INTER,NQEV,NSUD,NCOLO,NFLAV,SUDORD
        CLOSE(UNIT=LWSUD)
      ENDIF
      IF (IPRINT.GT.2) THEN
C--PRINT EXTRACTS FROM TABLES OF FORM FACTORS
        DO 40 IS=1,NSUD
        WRITE(6,20) IS,NQEV
   20   FORMAT(1H1//10X,'EXTRACT FROM TABLE OF SUDAKOV FORM FACTOR NO.',
     &  I2,' (',I5,' ACTUAL ENTRIES)'//10X,'SUD IS PROBABILITY THAT',
     &  ' PARTON WITH GIVEN UPPER LIMIT ON Q WILL REACH THRESHOLD',
     &  ' WITHOUT BRANCHING'///2X,8('      Q     SUD ')/)
        L2=NQEV/8
        L1=L2/32
        IF (L1.LT.1) L1=1
        DO 40 L=L1,L2,L1
        LL=L+7*L2
        WRITE(6,30) (QEV(I,IS),SUD(I,IS),I=L,LL,L2)
   30   FORMAT(2X,8(F9.2,F7.4))
   40   CONTINUE
        WRITE(6,50)
   50   FORMAT(1H1)
      ENDIF
  999 END
CDECK  ID>, HWBSUG.
*CMZ :-        -13/07/92  20.15.54  by  Mike Seymour
*-- Author :    Bryan Webber, modified by Mike Seymour
C-----------------------------------------------------------------------
      FUNCTION HWBSUG(ZLOG)
C-----------------------------------------------------------------------
C     Z TIMES INTEGRAND IN EXPONENT OF GLUON SUDAKOV FORM FACTOR
C-----------------------------------------------------------------------
      DOUBLE PRECISION HWBSUG,HWBSUL,Z,ZLOG,W
      EXTERNAL HWBSUL
      Z=EXP(ZLOG)
      W=Z*(1.-Z)
      HWBSUG=HWBSUL(Z)*(W-2.+1./W)*Z
      END
CDECK  ID>, HWBSUL.
*CMZ :-        -13/07/92  20.15.54  by  Mike Seymour
*-- Author :    Mike Seymour
C-----------------------------------------------------------------------
      FUNCTION HWBSUL(Z)
C-----------------------------------------------------------------------
C     LOGARITHMIC PART OF INTEGRAND IN EXPONENT OF SUDAKOV FORM FACTOR.
C     THE SECOND ORDER ALPHAS CASE COMES FROM CONVERTING INTEGRAL OVER
C     Q^2 INTO ONE OVER ALPHAS, WITH FLAVOUR THRESHOLDS.
C-----------------------------------------------------------------------
      INCLUDE 'HERWIG62.INC'
      DOUBLE PRECISION HWBSUL,HWUALF,Z,QRAT,QLAM,U,AL,BL,QNOW,QMIN,
     & BET(6),BEP(6),MUMI(6),MUMA(6),ALMI(6),ALMA(6),FINT(6),ALFINT,
     & MUMIN,MUMAX,ALMIN,ALMAX
      INTEGER NF
      LOGICAL FIRST
      EXTERNAL HWUALF
      SAVE FIRST,BET,BEP,MUMI,MUMA
      COMMON/HWSINT/QRAT,QLAM
      DATA FIRST/.TRUE./
      ALFINT(AL,BL)=1/BET(NF)*
     &        LOG(BL/(AL*(1+BEP(NF)*BL))*(1+BEP(NF)*AL))
      HWBSUL=0
      U=1.-Z
      IF (SUDORD.EQ.1) THEN
        AL=LOG(QRAT*Z)
        BL=LOG(QLAM*U*Z)
        HWBSUL=LOG(1.-AL/BL)
      ELSE
        IF (FIRST) THEN
          DO 10 NF=3,6
            BET(NF)=(11*CAFAC-2*NF)/(12*PIFAC)
            BEP(NF)=(17*CAFAC**2-(5*CAFAC+3*CFFAC)*NF)/(24*PIFAC**2)
     &              /BET(NF)
            IF (NF.EQ.3) THEN
              MUMI(3)=0
              ALMI(3)=1D30
            ELSE
              MUMI(NF)=RMASS(NF)
              ALMI(NF)=HWUALF(1,MUMI(NF))
            ENDIF
            IF (NF.EQ.6) THEN
              MUMA(NF)=1D30
              ALMA(NF)=0
            ELSE
              MUMA(NF)=RMASS(NF+1)
              ALMA(NF)=HWUALF(1,MUMA(NF))
            ENDIF
            IF (NF.NE.3.AND.NF.NE.6) FINT(NF)=ALFINT(ALMI(NF),ALMA(NF))
 10       CONTINUE
          FIRST=.FALSE.
        ENDIF
        QNOW=QLAM*QCDL3
        QMIN=QNOW/QRAT
        MUMIN=  U*QMIN
        MUMAX=Z*U*QNOW
        IF (MUMAX.LE.MUMIN) RETURN
        ALMIN=HWUALF(1,MUMIN)
        ALMAX=HWUALF(1,MUMAX)
        NF=3
 20     IF (MUMIN.GT.MUMA(NF)) THEN
          NF=NF+1
          GOTO 20
        ENDIF
        IF (MUMAX.LT.MUMA(NF)) THEN
          HWBSUL=ALFINT(ALMIN,ALMAX)
        ELSE
          HWBSUL=ALFINT(ALMIN,ALMA(NF))
          NF=NF+1
 30       IF (MUMAX.GT.MUMA(NF)) THEN
            HWBSUL=HWBSUL+FINT(NF)
            NF=NF+1
            GOTO 30
          ENDIF
          HWBSUL=HWBSUL+ALFINT(ALMI(NF),ALMAX)
        ENDIF
        HWBSUL=HWBSUL*BET(5)
      ENDIF
      END
CDECK  ID>, HWBTIM.
*CMZ :-        -26/04/91  14.27.17  by  Federico Carminati
*-- Author :    Ian Knowles
C-----------------------------------------------------------------------
      SUBROUTINE HWBTIM(INITBR,INTERF)
C-----------------------------------------------------------------------
C     Constructs full 4-momentum & production vertices in time-like jet
C     initiated by INITBR, interference partner INTERF and spin density
C     RHOPAR(INITBR). DECPAR(INITBR) returns jet's spin density matrix.
C     Includes azimuthal angular correlations between branching planes
C     due to spin (if AZSPIN) using the algorithm of Knowles & Collins.
C     Ses Nucl. Phys. B304 (1988) 794 & Comp. Phys. Comm. 58 (1990) 271.
C-----------------------------------------------------------------------
      INCLUDE 'HERWIG62.INC'
      DOUBLE PRECISION HWRGEN,DMIN,PT,EIKON,EINUM,EIDEN1,EIDEN2,EISCR,
     & WT,SPIN,Z1,Z2,PRMAX,CAZ,CX,SX,ROHEP(3),RMAT(3,3),ZERO2(2)
      INTEGER INITBR,INTERF,IPAR,JPAR,KPAR,LPAR,MPAR,NTRY,JOLD
      LOGICAL EICOR,SWAP
      EXTERNAL HWRGEN
      DATA ZERO2,DMIN/ZERO,ZERO,1.D-15/
      IF (IERROR.NE.0) RETURN
      JPAR=INITBR
      KPAR=INTERF
      IF ((JDAPAR(1,JPAR).NE.0).OR.(IDPAR(JPAR).EQ.13)) GOTO 30
C No branching, assign decay matrix
      CALL HWVZRO(2,DECPAR(1,JPAR))
      RETURN
C Advance up the leader
C     Find the parent and partner of J
  10  IPAR=JMOPAR(1,JPAR)
      KPAR=JPAR+1
C Generate new Rho
      IF (JMOPAR(1,KPAR).EQ.IPAR) THEN
C        Generate Rho'
         CALL HWBAZF(IPAR,JPAR,PHIPAR(1,IPAR),RHOPAR(1,IPAR),
     &                                   ZERO2,RHOPAR(1,JPAR))
      ELSE
         KPAR=JPAR-1
         IF (JMOPAR(1,KPAR).NE.IPAR)
     &   CALL HWWARN('HWBTIM',100,*999)
C        Generate Rho''
         CALL HWBAZF(IPAR,KPAR,RHOPAR(1,IPAR),PHIPAR(1,IPAR),
     &                         DECPAR(1,KPAR),RHOPAR(1,JPAR))
      ENDIF
C Generate azimuthal angle of J's branching
  30  IF (JDAPAR(1,JPAR).EQ.0) THEN
C        Final state gluon
         CALL HWVZRO(2,DECPAR(1,JPAR))
         IF (JPAR.EQ.INITBR) RETURN
         GOTO 70
      ELSE
C Assign an angle to a branching using an M-function
C        Find the daughters of J
         LPAR=JDAPAR(1,JPAR)
         MPAR=JDAPAR(2,JPAR)
C Soft correlations
         CALL HWUROT(PPAR(1,JPAR), ONE,ZERO,RMAT)
         CALL HWUROF(RMAT,PPAR(1,KPAR),ROHEP)
         PT=MAX(SQRT(ROHEP(1)*ROHEP(1)+ROHEP(2)*ROHEP(2)),DMIN)
         EIKON=1.
         SWAP=.FALSE.
         EICOR=AZSOFT.AND.((IDPAR(LPAR).EQ.13).OR.(IDPAR(MPAR).EQ.13))
         IF (EICOR) THEN
C           Rearrange s.t. LPAR is the (softest) gluon
            IF (IDPAR(MPAR).EQ.13) THEN
               IF (IDPAR(LPAR).NE.13.OR.
     &             PPAR(4,MPAR).LT.PPAR(4,LPAR)) THEN
                  SWAP=.TRUE.
                  LPAR=MPAR
                  MPAR=LPAR-1
               ENDIF
            ENDIF
            EINUM=(PPAR(4,KPAR)*PPAR(4,LPAR))
     &        *ABS(PPAR(2,LPAR)-PPAR(2,MPAR))
            EIDEN1=(PPAR(4,KPAR)*PPAR(4,LPAR))-ROHEP(3)*PPAR(3,LPAR)
            EIDEN2=PT*ABS(PPAR(1,LPAR))
            EISCR=1.-(PPAR(5,MPAR)/PPAR(4,MPAR))**2
     &           /MIN(PPAR(2,LPAR),PPAR(2,MPAR))
            EIKON=EISCR+EINUM/MAX(EIDEN1-EIDEN2,DMIN)
         ENDIF
C Spin correlations
         WT=0.
         SPIN=1.
         IF (AZSPIN) THEN
            Z1=PPAR(4,LPAR)/PPAR(4,JPAR)
            Z2=1.-Z1
            IF (IDPAR(JPAR).EQ.13.AND.IDPAR(LPAR).EQ.13) THEN
               WT=Z1*Z2/(Z1/Z2+Z2/Z1+Z1*Z2)
            ELSEIF (IDPAR(JPAR).EQ.13.AND.IDPAR(LPAR).LT.13) THEN
               WT=-2.*Z1*Z2/(Z1*Z1+Z2*Z2)
            ENDIF
         ENDIF
C Assign the azimuthal angle
         PRMAX=(1.+ABS(WT))*EIKON
         NTRY=0
   50    NTRY=NTRY+1
         IF (NTRY.GT.NBTRY) CALL HWWARN('HWBTIM',101,*999)
         CALL HWRAZM( ONE,CX,SX)
         CALL HWUROT(PPAR(1,JPAR),CX,SX,RMAT)
C Determine the angle between the branching planes
         CALL HWUROF(RMAT,PPAR(1,KPAR),ROHEP)
         CAZ=ROHEP(1)/PT
         PHIPAR(1,JPAR)=2.*CAZ*CAZ-1.
         PHIPAR(2,JPAR)=2.*CAZ*ROHEP(2)/PT
         IF (EICOR) EIKON=EISCR+EINUM/MAX(EIDEN1-EIDEN2*CAZ,DMIN)
         IF (AZSPIN) SPIN=1.+WT*(RHOPAR(1,JPAR)*PHIPAR(1,JPAR)
     &                          +RHOPAR(2,JPAR)*PHIPAR(2,JPAR))
         IF (SPIN*EIKON.LT.HWRGEN(0)*PRMAX) GOTO 50
C Construct full 4-momentum of L and M
         JOLD=JPAR
         IF (SWAP) THEN
           PPAR(1,LPAR)=-PPAR(1,LPAR)
           PPAR(1,MPAR)=-PPAR(1,MPAR)
           JPAR=MPAR
         ELSE
           JPAR=LPAR
         ENDIF
         PPAR(2,LPAR)=0.
         CALL HWUROB(RMAT,PPAR(1,LPAR),PPAR(1,LPAR))
         PPAR(2,MPAR)=0.
         CALL HWUROB(RMAT,PPAR(1,MPAR),PPAR(1,MPAR))
C Assign production vertex to L and M
         CALL HWUDKL(IDPAR(JOLD),PPAR(1,JOLD),VPAR(1,LPAR))
         CALL HWVSUM(4,VPAR(1,JOLD),VPAR(1,LPAR),VPAR(1,LPAR))
         CALL HWVEQU(4,VPAR(1,LPAR),VPAR(1,MPAR))
      ENDIF
  60  IF (JDAPAR(1,JPAR).NE.0) GOTO 10
C Assign decay matrix
      CALL HWVZRO(2,DECPAR(1,JPAR))
C Backtrack down the leader
  70  IPAR=JMOPAR(1,JPAR)
      KPAR=JDAPAR(1,IPAR)
      IF (KPAR.EQ.JPAR) THEN
C        Develop the side branch
         JPAR=JDAPAR(2,IPAR)
         GOTO 60
      ELSE
C        Construct decay matrix
         CALL HWBAZF(IPAR,KPAR,DECPAR(1,JPAR),DECPAR(1,KPAR),
     &                         PHIPAR(1,IPAR),DECPAR(1,IPAR))
      ENDIF
      IF (IPAR.EQ.INITBR) RETURN
      JPAR=IPAR
      GOTO 70
  999 END
CDECK  ID>, HWBTOP.
*CMZ :-        -31/03/00  17:54:05  by  Peter Richardson
*-- Author :    Gennaro Corcella
C-----------------------------------------------------------------------
      SUBROUTINE HWBTOP
C-----------------------------------------------------------------------
      INCLUDE 'HERWIG62.INC'
      DOUBLE PRECISION HWBVMC,HWRGEN,HWUALF,HWUSQR,X(3),W,
     & X3MIN,X3MAX,X1MIN,X1MAX,QSCALE,GLUFAC,R(3,3),M(3),
     & E(3),AW,PTSQ,EM,EPS,MASDEP,A,B,C,GAMDEP,LAMBDA,
     & PW(5),PT(5),PW1(5),CS,SN,EPG,QQ,RR,CC
      INTEGER ID,ID3,IHEP,KHEP,WHEP,ICMF,K
      EXTERNAL HWBVMC,HWUALF,HWUSQR,HWRGEN
      LAMBDA(A,B,C)=(A**2+B**2+C**2-2*A*B-2*B*C-2*C*A)/(4*A)
C---FIND AN UNTREATED CMF
      ICMF=0
      DO 10 IHEP=1,NHEP
C----FIND A DECAYING TOP QUARK
 10     IF (ISTHEP(IHEP).EQ.155.AND.ISTHEP(JDAHEP(1,IHEP)).EQ.113
     &       .AND.(IDHW(IHEP).EQ.6.OR.IDHW(IHEP).EQ.12))
     &       ICMF=IHEP
      IF (ICMF.EQ.0) RETURN
      EM=PHEP(5,ICMF)
      X3MIN=2*GCUTME/EM
C---GENERATE X(1),X(3) ACCORDING TO 1/((1-X(1))*X(3)**2)
 100  CONTINUE
C-----AW=(MW/MT)**2
      AW=(PHEP(5,JDAHEP(1,ICMF))/EM)**2
C---CHOOSE X3
      X3MAX=1-AW
      X(3)=X3MIN*X3MAX/(X3MIN+(X3MAX-X3MIN)*HWRGEN(0))
C--CC, QQ AND RR ARE THE VARIABLE DEFINED IN OUR PAPER
C--IN ORDER TO SOLVE THE CUBIC EQUATION
      CC=(1-AW)**2/4
      QQ=(AW**2-4*(1-X(3))*(2-CC-X(3))-2*AW*(3+2*X(3)))/3
     &     -((3+2*AW-4*X(3))**2)/9
      RR=((3+2*AW-4*X(3))*(AW**2-4*(1-X(3))*(2-CC-X(3))
     &     -2*AW*(3+2*X(3)))-3*(AW*(4-AW)*(2-CC)+(1-CC)
     &     *(2*(1-X(3))-AW)**2))/6-(ONE/27)*(3+2*AW-4*X(3))**3
C---CHOOSE X1
      X1MAX=2*(-QQ**3)**(ONE/6)*COS(ACOS(RR/SQRT(-QQ**3))/3)
     &     -(3+2*AW-4*X(3))/3
      X1MIN=1-X(3)+(AW*X(3))/(1-X(3))
      IF (X1MAX.GE.1.OR.X1MIN.GE.1.OR.X1MAX.LE.X1MIN) GOTO 100
      X(1)=1-(1-X1MAX)*((1-X1MIN)/(1-X1MAX))**HWRGEN(1)
C---CALCULATE WEIGHT
      W=((1+1/AW-2*AW)*((1-AW)*X(3)-(1-X(1))*(1-X(3))-X(3)**2)
     &     +(1+1/(2*AW))*X(3)*(X(1)+X(3)-1)**2+2*X(3)**2*(1-X(1)))
     &     *(1/X3MIN-1/X3MAX)*LOG((1-X1MIN)/(1-X1MAX))
C---QSCALE=DURHAM-LIKE TRANSVERSE MOMENTUM OF THE GLUON
      QSCALE=EM*HWUSQR(X(3)*(1-X(1))/(2-X(1)-X(3)-AW))
C---FACTOR FOR GLUON EMISSION
      ID=IDHW(JDAHEP(2,ICMF))
      GLUFAC=0
      IF (QSCALE.GT.HWBVMC(13)) GLUFAC=CFFAC*HWUALF(1,QSCALE)
     &     /(PIFAC*(1-AW)*(1-2*AW+1/AW))
C---IN FRACTION GLUFAC*W OF EVENTS ADD A GLUON
      IF (GLUFAC*W.GT.HWRGEN(4)) THEN
        ID3=13
      ELSE
        RETURN
      ENDIF
C---CHECK INFRA-RED CUT-OFF FOR GLUON
      M(1)=PHEP(5,JDAHEP(1,ICMF))
      M(2)=HWBVMC(ID)
      M(3)=HWBVMC(ID3)
      E(1)=HALF*EM*(X(1)+AW+(-M(2)**2-M(3)**2)/EM**2)
      E(3)=HALF*EM*X(3)
      E(2)=EM-E(1)-E(3)
      PTSQ=-LAMBDA(E(1)**2-M(1)**2,E(3)**2-M(3)**2,
     &     E(2)**2-M(2)**2)
      IF (PTSQ.LE.0.OR.E(1).LE.M(1).OR.E(2).LE.M(2).OR.E(3).LE.M(3))
     $     RETURN
C---CALCULATE MASS-DEPENDENT SUPPRESSION
      EPS=(RMASS(ID)/EM)**2
      EPG=(RMASS(ID3)/EM)**2
      GAMDEP=(1-AW)*(1+1/AW-2*AW)/(SQRT(1+AW**2+EPS**2
     &     -2*AW-2*EPS-2*AW*EPS)*(1+EPS+(1-EPS)**2/AW-2*AW))
      MASDEP=GAMDEP/(1-X(1))*((1+EPS+(1-EPS)**2/AW-2*AW)
     &     *((1-AW+EPS)*X(3)*(1-X(1))-(1-X(1))**2*(1-X(3))
     &     -X(3)**2*(1-X(1)+EPS))+(1+(1+EPS)/(2*AW))*X(3)
     &     *(1-X(1))*(X(1)+X(3)-1)**2+2*X(3)**2*(1-X(1))**2)
      IF (MASDEP.LT.HWRGEN(7)*((1+1/AW-2*AW)*((1-AW)*X(3)
     &     -(1-X(1))*(1-X(3))-X(3)**2)+(1+1/(2*AW))*X(3)
     &     *(X(1)+X(3)-1)**2+2*X(3)**2*(1-X(1)))) RETURN
C---STORE OLD MOMENTA
c---PT = TOP MOMENTUM, PW= W MOMENTUM
      CALL HWVEQU(5,PHEP(1,ICMF),PT)
      CALL HWVEQU(5,PHEP(1,JDAHEP(1,ICMF)),PW)
C--------GET THE NON-EMITTING PARTON CMF DIRECTION
      CALL HWULOF(PHEP(1,ICMF),PW,PW)
      CALL HWRAZM(ONE,CS,SN)
      CALL HWUROT(PW,CS,SN,R)
      CALL HWUROF(R,PW,PW)
      CALL HWUMAS(PW)
C---REORDER ENTRIES: IHEP=EMITTER,  KHEP=EMITTED
      NHEP=NHEP+1
      IHEP=JDAHEP(2,ICMF)
      WHEP=JDAHEP(1,ICMF)
      KHEP=NHEP
C---SET UP MOMENTA IN TOP REST FRAME
      PHEP(1,ICMF)=0
      PHEP(2,ICMF)=0
      PHEP(3,ICMF)=0
      PHEP(4,ICMF)=EM
      PHEP(5,ICMF)=EM
      PHEP(4,IHEP)=HALF*EM*(2-X(1)-X(3)+EPS-AW+EPG)
      PHEP(4,KHEP)=HALF*EM*X(3)
      PHEP(5,IHEP)=RMASS(ID)
      PHEP(5,KHEP)=RMASS(ID3)
      PHEP(3,KHEP)=HALF*EM*((X(1)+AW-EPS-EPG)*X(3)-2*(1+EPS-AW
     $     -EPG-(2+EPS+EPG-AW-X(1)-X(3))))/HWUSQR((X(1)+AW
     $     -EPS-EPG)**2-4*AW)
      PHEP(3,IHEP)=-PHEP(3,KHEP)-HALF*EM
     $     *HWUSQR((X(1)+AW-EPS-EPG)**2-4*AW)
      PHEP(2,IHEP)=0
      PHEP(1,KHEP)=HWUSQR(PHEP(4,KHEP)**2-PHEP(5,KHEP)**2
     $     -PHEP(3,KHEP)**2)
      PHEP(1,IHEP)=-PHEP(1,KHEP)
      PHEP(2,KHEP)=0
      CALL HWVSUM(4,PHEP(1,IHEP),PHEP(1,KHEP),PW1)
      CALL HWVDIF(4,PHEP(1,ICMF),PW1,PW1)
      CALL HWUMAS(PW1)
      DO K=1,5
        PHEP(K,WHEP)=PW1(K)
      ENDDO
C---ORIENT IN CMF, THEN BOOST TO LAB
      CALL HWUROB(R,PHEP(1,ICMF),PHEP(1,ICMF))
      CALL HWUROB(R,PHEP(1,IHEP),PHEP(1,IHEP))
      CALL HWUROB(R,PHEP(1,WHEP),PHEP(1,WHEP))
      CALL HWUROB(R,PHEP(1,KHEP),PHEP(1,KHEP))
      CALL HWULOB(PT,PHEP(1,IHEP),PHEP(1,IHEP))
      CALL HWULOB(PT,PHEP(1,KHEP),PHEP(1,KHEP))
      CALL HWULOB(PT,PHEP(1,ICMF),PHEP(1,ICMF))
      CALL HWULOB(PT,PHEP(1,WHEP),PHEP(1,WHEP))
C---STATUS AND COLOUR CONNECTION
C--Bug fix 31/03/00 PR
      ISTHEP(KHEP)=114
      IDHW(KHEP)=ID3
      IDHEP(KHEP)=IDPDG(ID3)
      JMOHEP(1,KHEP)=ICMF
      JMOHEP(1,IHEP)=ICMF
      JDAHEP(1,KHEP)=0
      JDAHEP(2,ICMF)=KHEP
      IF(IDHW(ICMF).EQ.6) THEN
         JDAHEP(2,IHEP)=ICMF
         JDAHEP(2,KHEP)=IHEP
         JMOHEP(2,IHEP)=KHEP
         JMOHEP(2,KHEP)=ICMF
      ELSE
         JDAHEP(2,IHEP) = KHEP
         JDAHEP(2,KHEP) = ICMF
         JMOHEP(2,IHEP) = ICMF
         JMOHEP(2,KHEP) = IHEP
      ENDIF
C--End of Fix
 999  END
CDECK  ID>, HWBVMC.
*CMZ :-        -26/04/91  11.11.54  by  Bryan Webber
*-- Author :    Bryan Webber
C-----------------------------------------------------------------------
      FUNCTION HWBVMC(ID)
C-----------------------------------------------------------------------
C     VIRTUAL MASS CUTOFF FOR PARTON TYPE ID
C-----------------------------------------------------------------------
      INCLUDE 'HERWIG62.INC'
      DOUBLE PRECISION HWBVMC
      INTEGER ID
      IF (ID.EQ.13) THEN
        HWBVMC=RMASS(ID)+VGCUT
      ELSEIF (ID.LT.13) THEN
        HWBVMC=RMASS(ID)+VQCUT
      ELSEIF (ID.EQ.59) THEN
        HWBVMC=RMASS(ID)+VPCUT
      ELSE
        HWBVMC=RMASS(ID)
      ENDIF
      END
CDECK  ID>, HWCBCT.
*CMZ :-        -20/07/99  10:56:12  by  Peter Richardson
*-- Author :    Peter Richardson
C-----------------------------------------------------------------------
      SUBROUTINE HWCBCT(JHEP,KHEP,THEP,PCL,SPLIT)
C-----------------------------------------------------------------------
C  Subroutine to split a baryonic cluster containing two heavy quarks
C  Based on HWCCUT
C-----------------------------------------------------------------------
      INCLUDE 'HERWIG62.INC'
      DOUBLE PRECISION HWUPCM,HWRGEN,HWVDOT,EMC,QM1,QM2,QM3,QM4,
     &                 PXY,PCX,PCY,RCM,PCL(5),AX(5),PA(5),PB(5),PC(5),
     &                 VCLUS(4),DQM,EMX,EMY,SKAPPA,RKAPPA,VTMP(4),
     &                 DELTM,PDIQUK(5),AY(5)
      INTEGER HWRINT,JHEP,KHEP,LHEP,MHEP,THEP,ID1,ID2,ID3,ID4,NTRY,
     &        NTRYMX,J,IB
      LOGICAL SPLIT
      EXTERNAL HWUPCM,HWRGEN,HWVDOT
      PARAMETER(SKAPPA=1.,NTRYMX=100)
      IF(IERROR.NE.0) RETURN
      EMC=PCL(5)
      ID1=IDHW(JHEP)
      ID2=IDHW(KHEP)
      ID3=IDHW(THEP)
      QM1=RMASS(ID1)
      QM2=RMASS(ID2)
      QM3=RMASS(ID3)
      SPLIT = .FALSE.
      NTRY = 0
C Decide if cluster contains a b-(anti)quark
      IF (ID1.EQ.5.OR.ID1.EQ.11.OR.ID2.EQ.5.OR.ID2.EQ.11.OR.
     &    ID3.EQ.5.OR.ID3.EQ.11) THEN
        IB=2
      ELSE
        IB=1
      ENDIF
C-- Set the positon of the cluster to be that of the heavy quark
      CALL HWVEQU(4,VHEP(1,THEP),VCLUS)
C--SPLIT THE BARYONIC CLUSTER INTO A HEAVY FLAVOUR MESON AND A HEAVY
C--FLAVOUR BARYON
      PXY=EMC-QM1-QM2-QM3
 20   NTRY=NTRY+1
      IF(NTRY.GT.NTRYMX) RETURN
 30   EMX=QM1+QM2+PXY*HWRGEN(0)**PSPLT(IB)
      EMY=    QM3+PXY*HWRGEN(1)**PSPLT(IB)
      IF(EMX+EMY.GE.EMC) GOTO 30
C--PULL A LIGHT QUARK PAIR OUT OF THE VACUUM
 40   ID4=HWRINT(1,3)
      IF(QWT(ID4).LT.HWRGEN(3)) GOTO 40
      QM4=RMASS(ID4)
C--Now combine particles 3 & 4 into a diquark
C--If three also heavy this diquark doesn't exist in HERWIG
C--just assume mass is sum of quark masses,as for other diquarks
      DQM=QM3+QM4
C--Now obtain the masses for the cluster splitting
      PCX=HWUPCM(EMX,QM1,DQM)
      IF(PCX.LT.ZERO) GOTO 20
      PCY=HWUPCM(EMY,QM2,QM4)
      IF(PCY.LT.ZERO) GOTO 20
      SPLIT=.TRUE.
C--Now we've decided which light quark to pull out of the vacuum
C--Find the direction of the second heavy quark
      CALL HWULOF(PCL,PHEP(1,THEP),AX)
      RCM=1./SQRT(HWVDOT(3,AX,AX))
      CALL HWVSCA(3,RCM,AX,AX)
C--Construct the new CoM momenta(collinear)
      PXY=HWUPCM(EMC,EMX,EMY)
      CALL HWVSCA(3,PXY,AX,PC)
C--pc is momenta of Y cluster along 2nd quark dirn in cluster frame
      PC(4)=SQRT(PXY**2+EMY**2)
      PC(5)=EMY
C--pa is momenta of 2nd quark in Y frame
      CALL HWVSCA(3,PCY,AX,PA)
      PA(4)=SQRT(PCY**2+QM3**2)
      PA(5)=QM3
C--pb is momenta of 2nd quark in cluster frame,pa now momenta of antiquark
      CALL HWULOB(PC,PA,PB)
      CALL HWVDIF(4,PC,PB,PA)
      PA(5)=QM4
      LHEP=NHEP+1
      MHEP=NHEP+2
C--boost these momenta back to lab frame
      CALL HWULOB(PCL,PB,PHEP(1,THEP))
      CALL HWULOB(PCL,PA,PHEP(1,MHEP))
C--pc now becomes momenta of X cluster in cluster frame
      CALL HWVSCA(3,-ONE,PC,PC)
      PC(4)=EMC-PC(4)
      PC(5)=EMX
C--find the dirn of the 1st heavy quark in the X frame
C--transform to cluster frame
      CALL HWULOF(PCL,PHEP(1,JHEP),AY)
C--transform to X-frame
      CALL HWULOF(PC,AY,AY)
      RCM=1./SQRT(HWVDOT(3,AY,AY))
      CALL HWVSCA(3,RCM,AY,AY)
C--pa now momenta of 1st havy quark along this dirn
      CALL HWVSCA(3,PCX,AY,PA)
      PA(4)=SQRT(PCX**2+QM1**2)
      PA(5)=QM1
C--pb now momenta of 1st heavy quark in cluster frame then to lab
      CALL HWULOB(PC,PA,PB)
      CALL HWULOB(PCL,PB,PHEP(1,JHEP))
C--now find the diquark momenta by momentum conservation
      DO 50 J=1,4
 50   PDIQUK(J)=PCL(J)-PHEP(J,THEP)-PHEP(J,MHEP)-PHEP(J,JHEP)
      PDIQUK(5)=DQM
C--Now obtain the quark momenta from the diquark
      DO 60 J=1,3
 60   PA(J) = 0
      PA(4) = QM2
      PA(5) = QM2
      CALL HWULOB(PDIQUK,PA,PHEP(1,KHEP))
      CALL HWVDIF(4,PDIQUK,PHEP(1,KHEP),PHEP(1,LHEP))
C--Construct new vertex positions
      RKAPPA=GEV2MM/SKAPPA
      CALL HWVSCA(3,RKAPPA,AX,AX)
      DELTM=(EMX-EMY)*(EMX+EMY)/(TWO*EMC)
      CALL HWVSCA(3,DELTM,AX,VTMP)
      VTMP(4)=(HALF*EMC-PXY)*RKAPPA
      CALL HWULB4(PCL,VTMP,VTMP)
      CALL HWVSUM(4,VTMP,VCLUS,VHEP(1,LHEP))
      CALL HWVEQU(4,VHEP(1,LHEP),VHEP(1,MHEP))
C--Relabel the colours of the quarks
      IDHEP(LHEP) = IDPDG(ID4)
      IDHEP(MHEP) = IDPDG(ID4)
      IF(IDHEP(JHEP).GT.0) THEN
        IDHW(LHEP)  = ID4+6
        IDHEP(LHEP) = -IDHEP(LHEP)
        IDHW(MHEP)  = ID4
        JDAHEP(2,LHEP) = JHEP
        JMOHEP(2,LHEP) = MHEP
        JMOHEP(2,MHEP) = JMOHEP(2,JHEP)
        JDAHEP(2,MHEP) = LHEP
        JMOHEP(2,JHEP) = LHEP
      ELSE
        IDHW(LHEP)  = ID4
        IDHW(MHEP)  = ID4+6
        IDHEP(MHEP) = -IDHEP(MHEP)
        JMOHEP(2,LHEP) = JHEP
        JDAHEP(2,MHEP) = JDAHEP(2,JHEP)
        JDAHEP(2,LHEP) = MHEP
        JMOHEP(2,MHEP) = LHEP
        JDAHEP(2,JHEP) = LHEP
      ENDIF
      ISTHEP(LHEP) = 151
      ISTHEP(MHEP) = 151
      JMOHEP(1,LHEP) = JMOHEP(1,KHEP)
      JDAHEP(1,LHEP) = 0
      JMOHEP(1,MHEP) = JMOHEP(1,JHEP)
      JDAHEP(1,MHEP) = 0
      NHEP = NHEP+2
 999  END
CDECK  ID>, HWCBVI.
*CMZ :-
*-- Author :    Mark Gibbs  modified by Peter Richardson
C-----------------------------------------------------------------------
      SUBROUTINE HWCBVI
C-----------------------------------------------------------------------
C FINDS UNPAIRED PARTONS AFTER BARYON-NUMBER VIOLATION
C  MODIFIED FOR RPARITY VIOLATING SUSY
C-----------------------------------------------------------------------
      INCLUDE 'HERWIG62.INC'
      COMMON/HWBVIC/NBV,IBV(18)
      DOUBLE PRECISION HWRGEN,PDQ(5)
      INTEGER NBV,IBV,JBV,KBV,LBV,IHEP,IP1,IP2,IP3,JP1,JP2,JP3,
     & HWCBVT,NBR,MBV,IQ1,IQ2,IQ3,ID1,ID2,IDQ,IDIQK(3,3)
      LOGICAL SPLIT,DUNBV(18)
      DATA IDIQK/111,110,113,110,109,112,113,112,114/
C---Check for errors
      IF (IERROR.NE.0)  RETURN
C---Correct colour connections are gluon splitting
      CALL HWCCCC
C---Reset bvi clustering flag
      HVFCEN = .FALSE.
C---LIST PARTONS WITH WRONG COLOUR PARTNERS-QUARKS ONLY
    5 NBV=0
      DO 10 IHEP=1,NHEP
      IF (ISTHEP(IHEP).GT.149.AND.ISTHEP(IHEP).LT.155) THEN
        IF (QORQQB(IDHW(IHEP))) THEN
          IF (.NOT.QORQQB(IDHW(JMOHEP(2,IHEP))).
     &        AND.JMOHEP(2,IHEP).GT.6) GOTO 10
        ELSE
C---Extra check for Gamma's
          IF (IDHW(IHEP).EQ.59) GO TO 10
C---End of bug fix.
          IF (QORQQB(IDHW(JDAHEP(2,IHEP)))) GO TO 10
          GO TO 10
        ENDIF
        IF(JMOHEP(2,IHEP).LT.6.AND.
     &     .NOT.QBORQQ(IDHW(JMOHEP(2,IHEP)))) GOTO 10
C--new for hard process
        NBV=NBV+1
        IF (NBV.GT.18) CALL HWWARN('HWCBVI',100,*999)
        IBV(NBV)=IHEP
        DUNBV(NBV)=.FALSE.
      ENDIF
   10 CONTINUE
C--NOW FIND THE ANTIQUARKS WITH WRONG COLOUR CONNECTIONS
      DO 11 IHEP=1,NHEP
      IF(ISTHEP(IHEP).GT.149.AND.ISTHEP(IHEP).LT.155) THEN
        IF(QBORQQ(IDHW(IHEP))) THEN
          IF(.NOT.QBORQQ(IDHW(JDAHEP(2,IHEP))).AND.
     &        JDAHEP(2,IHEP).GT.6) GO TO 11
        ELSE
C--Extra check for gamma's
          IF(IDHW(IHEP).EQ.59) GO TO 11
          IF(QBORQQ(IDHW(JMOHEP(2,IHEP)))) GO TO 11
          GO TO 11
        ENDIF
        IF(JDAHEP(2,IHEP).LT.6.AND.
     &    .NOT.QORQQB(IDHW(JDAHEP(2,IHEP)))) GOTO 11
        NBV=NBV+1
        IF(NBV.GT.18) CALL HWWARN('HWCBVI',100,*999)
        IBV(NBV)=IHEP
        DUNBV(NBV)=.FALSE.
      ENDIF
 11   CONTINUE
      IF (NBV.EQ.0) RETURN
      IF(MOD(NBV,3).NE.0) CALL HWWARN('HWCBVI',101,*999)
C---PROCESS FOUND PARTONS, STARTING AT RANDOM POINT IN LIST
      NBR=NBV*HWRGEN(0)
      DO 100 MBV=1,NBV
      JBV=MBV+NBR
      IF (JBV.GT.NBV) JBV=JBV-NBV
      IF (.NOT.DUNBV(JBV)) THEN
        DUNBV(JBV)=.TRUE.
        IP1=IBV(JBV)
        JP1=HWCBVT(IP1)
C---FIND ASSOCIATED PARTONS
        DO 20 KBV=1,NBV
        IF (.NOT.DUNBV(KBV)) THEN
          IP2=IBV(KBV)
          JP2=HWCBVT(IP2)
          IF (JP2.EQ.JP1) THEN
            DUNBV(KBV)=.TRUE.
            DO 15 LBV=1,NBV
            IF (.NOT.DUNBV(LBV)) THEN
              IP3=IBV(LBV)
              JP3=HWCBVT(IP3)
              IF (JP3.EQ.JP2) THEN
                DUNBV(LBV)=.TRUE.
                GO TO 25
              ENDIF
            ENDIF
   15       CONTINUE
          ENDIF
        ENDIF
   20   CONTINUE
        CALL HWWARN('HWCBVI',102,*999)
   25   IQ1=0
C---LOOK FOR DIQUARK
        IF (ABS(IDHEP(IP1)).GT.100) THEN
          IQ1=IP1
          IQ2=IP2
          IQ3=IP3
        ELSEIF (ABS(IDHEP(IP2)).GT.100) THEN
          IQ1=IP2
          IQ2=IP3
          IQ3=IP1
        ELSEIF (ABS(IDHEP(IP3)).GT.100) THEN
          IQ1=IP3
          IQ2=IP1
          IQ3=IP2
        ENDIF
        IF (IQ1.EQ.0) THEN
C---NO DIQUARKS: COMBINE TWO (ANTI)QUARKS
          IF (ABS(IDHEP(IP1)).GT.3) THEN
            IQ1=IP2
            IQ2=IP3
            IQ3=IP1
          ELSEIF (ABS(IDHEP(IP2)).GT.3) THEN
            IQ1=IP3
            IQ2=IP1
            IQ3=IP2
          ELSE
            IQ1=IP1
            IQ2=IP2
            IQ3=IP3
          ENDIF
          ID1=IDHEP(IQ1)
          ID2=IDHEP(IQ2)
C---CHECK FLAVOURS
          IF (ID1.GT.0.AND.ID1.LT.4.AND.
     &        ID2.GT.0.AND.ID2.LT.4) THEN
            IDQ=IDIQK(ID1,ID2)
          ELSEIF (ID1.LT.0.AND.ID1.GT.-4.AND.
     &            ID1.LT.0.AND.ID2.GT.-4) THEN
            IDQ=IDIQK(-ID1,-ID2)+6
          ELSE
C---CANT MAKE DIQUARKS WITH HEAVY QUARKS: TRY CLUSTER SPLITTING
            CALL HWVSUM(4,PHEP(1,IQ1),PHEP(1,IQ2),PDQ)
            CALL HWUMAS(PDQ)
C--Use the original splitting procedure
            CALL HWCCUT(IQ1,IQ2,PDQ,.FALSE.,SPLIT)
            IF(SPLIT) GOTO 5
C--If it fails try the new procedure
            CALL HWVSUM(4,PDQ,PHEP(1,IQ3),PDQ)
            CALL HWUMAS(PDQ)
            IF(ABS(ID1).GT.3) THEN
              CALL HWCBCT(IQ3,IQ2,IQ1,PDQ,SPLIT)
            ELSEIF(ABS(ID2).GT.3) THEN
              CALL HWCBCT(IQ3,IQ1,IQ2,PDQ,SPLIT)
            ELSE
              CALL HWWARN('HWCBVI',100,*999)
            ENDIF
            IF (SPLIT) GO TO 5
C---Unable to form cluster; dispose of event
            CALL HWWARN('HWCBVI',-3,*999)
          ENDIF
C---OVERWRITE FIRST AND CANCEL SECOND
          IDHW(IQ1)=IDQ
          IDHEP(IQ1)=IDPDG(IDQ)
          CALL HWVSUM(4,PHEP(1,IQ1),PHEP(1,IQ2),PHEP(1,IQ1))
          CALL HWUMAS(PHEP(1,IQ1))
          ISTHEP(IQ2)=0
C---REMAKE COLOUR CONNECTIONS
          IF (QORQQB(IDQ)) THEN
            JMOHEP(2,IQ1)=IQ3
            JDAHEP(2,IQ3)=IQ1
          ELSE
            JDAHEP(2,IQ1)=IQ3
            JMOHEP(2,IQ3)=IQ1
          ENDIF
        ELSE
C---SPLIT A DIQUARK
          NHEP=NHEP+1
          CALL HWVSCA(5,HALF,PHEP(1,IQ1),PHEP(1,IQ1))
          CALL HWVEQU(5,PHEP(1,IQ1),PHEP(1,NHEP))
          ISTHEP(NHEP)=150
          JMOHEP(1,NHEP)=JMOHEP(1,IQ1)
          JDAHEP(1,NHEP)=0
C---FIND FLAVOURS
          IDQ=IDHW(IQ1)
          DO 30 ID2=1,3
          DO 30 ID1=1,3
          IF (IDIQK(ID1,ID2).EQ.IDQ) THEN
            IDHW(IQ1)=ID1
            IDHW(NHEP)=ID2
C---REMAKE COLOUR CONNECTIONS (DIQUARK)
            JMOHEP(2,IQ1)=IQ2
            JMOHEP(2,IQ2)=NHEP
            JMOHEP(2,IQ3)=IQ1
            JMOHEP(2,NHEP)=IQ3
            JDAHEP(2,IQ1)=IQ3
            JDAHEP(2,IQ2)=IQ1
            JDAHEP(2,IQ3)=NHEP
            JDAHEP(2,NHEP)=IQ2
            GO TO 35
          ELSEIF (IDIQK(ID1,ID2).EQ.IDQ-6) THEN
            IDHW(IQ1)=ID1+6
            IDHW(NHEP)=ID2+6
C---REMAKE COLOUR CONNECTIONS (ANTIDIQUARK)
            JMOHEP(2,IQ1)=IQ3
            JMOHEP(2,IQ2)=IQ1
            JMOHEP(2,IQ3)=NHEP
            JMOHEP(2,NHEP)=IQ2
            JDAHEP(2,IQ1)=IQ2
            JDAHEP(2,IQ2)=NHEP
            JDAHEP(2,IQ3)=IQ1
            JDAHEP(2,NHEP)=IQ3
            GO TO 35
          ENDIF
   30     CONTINUE
          CALL HWWARN('HWCBVI',104,*999)
   35     IDHEP(IQ1)=IDPDG(IDHW(IQ1))
          IDHEP(NHEP)=IDPDG(IDHW(NHEP))
        ENDIF
      ENDIF
  100 CONTINUE
      RETURN
  999 END
CDECK  ID>, HWCBVT.
*CMZ :-
*-- Author :    Peter Richardson
C-----------------------------------------------------------------------
      FUNCTION HWCBVT(IP)
C-----------------------------------------------------------------------
C  Function to find the baryon number violating vertex a parton came from
C-----------------------------------------------------------------------
      INCLUDE 'HERWIG62.INC'
      INTEGER HWCBVT,IP,JP(2),KP,I,J,ID,TYPE,IDM,IDM2,IDM3,IDM4
      JP(1) = IP
      ID = IDHW(IP)
      IF(ID.LE.6.OR.(ID.GE.115.AND.ID.LE.120)) THEN
        JP(2) = JMOHEP(2,IP)
      ELSE
        JP(2) = JDAHEP(2,IP)
      ENDIF
      DO I=1,2
        IDM = JMOHEP(1,JMOHEP(1,JMOHEP(1,JMOHEP(1,JP(I)))))
        IF(IDHW(IDM).EQ.6.OR.IDHW(IDM).EQ.12) THEN
          JP(I)=IDM
        ENDIF
      ENDDO
      DO J=1,7
        DO I=1,2
          KP = JMOHEP(1,JP(I))
          IDM = IDHW(KP)
          IDM2 = IDHW(JDAHEP(1,KP))
          IDM3 = IDHW(JDAHEP(2,KP))
          IDM4 = IDHW(JDAHEP(1,KP)+1)
          IF((ISTHEP(KP).EQ.155.AND.
     &      ((IDM.GE.449.AND.IDM.LE.457.AND.IDM2.LE.12.AND.
     &       IDM3.LE.12.AND.IDM4.LE.12).OR.
     &      (((IDM.GE.411.AND.IDM.LE.424).OR.IDM.EQ.405.OR.IDM.EQ.406)
     &      .AND.IDM2.LE.12.AND.IDM3.LE.12)))
     &        .OR.(IDM.EQ.15.AND.IDM2.LE.12.AND.
     &       IDHW(JMOHEP(1,KP)).LE.12.AND.
     &       IDHW(JMOHEP(2,KP)).LE.12.AND.IDM3.GE.449.AND.
     &       IDM3.LE.457).OR.
     &         (IDM.EQ.15.AND.IDM2.GE.198.AND.IDM2.LE.200.
     &          AND.ABS(IDPDG(IDM3)).GT.1000000)) THEN
            IF(IDHW(KP).EQ.449.AND.JDAHEP(1,KP).EQ.JP(I)) THEN
              KP = JMOHEP(1,KP)
            ELSEIF(IDHW(KP).EQ.15) THEN
              TYPE=IDHW(JDAHEP(1,KP))
              IF(TYPE.GE.7.AND.TYPE.LE.12.AND.
     &           JMOHEP(2,JDAHEP(2,KP)).EQ.JP(I)) THEN
                KP=IP
              ELSEIF(TYPE.LE.6.AND.
     &           JDAHEP(2,JDAHEP(2,KP)).EQ.JP(I)) THEN
                KP=IP
              ELSE
                HWCBVT = KP
                RETURN
              ENDIF
            ELSE
              HWCBVT = KP
              RETURN
            ENDIF
          ENDIF
          JP(I) =KP
        ENDDO
      ENDDO
      HWCBVT = 0
 999  END
CDECK  ID>, HWCCCC.
*CMZ :-
*-- Author :    Peter Richardson
C-----------------------------------------------------------------------
      SUBROUTINE HWCCCC
C-----------------------------------------------------------------------
C  Subroutine to correct colour connections after the gluon splitting
C-----------------------------------------------------------------------
      INCLUDE 'HERWIG62.INC'
      INTEGER IHEP,STFSPT,LHEP,MHEP,RHEP
      IF(IERROR.NE.0) RETURN
C--Find the first particle in the event record with status 150
      DO IHEP=1,NHEP
        IF(ISTHEP(IHEP).GE.150.AND.ISTHEP(IHEP).LE.154) THEN
          STFSPT = IHEP
          GOTO 10
        ENDIF
      ENDDO
 10   CONTINUE
C--Now find any that are colour connected to earlier particles
C--in the event record
      DO IHEP=STFSPT,NHEP
C--First the quarks and antidiquarks
        IF(IDHW(IHEP).LT.6.OR.
     &     (IDHW(IHEP).GE.115.AND.IDHW(IHEP).LE.120)) THEN
          IF(JMOHEP(2,IHEP).LT.STFSPT) THEN
            LHEP = IHEP
            MHEP = JMOHEP(2,IHEP)
            RHEP = MHEP
            IF(MHEP.GT.6) RHEP = JDAHEP(1,MHEP)
C--As from Rparity connect to particle not to antiparticle
            IF(IDHW(MHEP).NE.13) THEN
              JMOHEP(2,LHEP) = RHEP
            ELSE
              RHEP = RHEP+1
              JMOHEP(2,LHEP) = RHEP
            ENDIF
          ENDIF
        ENDIF
C--Now the antiquarks
        IF((IDHW(IHEP).GT.6.AND.IDHW(IHEP).LE.12).OR.
     &     (IDHW(IHEP).GE.109.AND.IDHW(IHEP).LE.114)) THEN
          IF(JDAHEP(2,IHEP).LT.STFSPT) THEN
            LHEP = IHEP
            MHEP = JDAHEP(2,IHEP)
            RHEP = MHEP
            IF(MHEP.GT.6) RHEP = JDAHEP(1,MHEP)
C--As from Rparity connect to antiparticle not particle
            IF(IDHW(MHEP).NE.13) THEN
              JDAHEP(2,LHEP) = RHEP
            ELSE
              JDAHEP(2,LHEP) = RHEP
            ENDIF
          ENDIF
        ENDIF
      ENDDO
      END
CDECK  ID>, HWCCUT.
*CMZ :-        -26/04/91  14.29.39  by  Federico Carminati
*-- Author :    Bryan Webber
C-----------------------------------------------------------------------
      SUBROUTINE HWCCUT(JHEP,KHEP,PCL,BTCLUS,SPLIT)
C-----------------------------------------------------------------------
C     Cuts into 2 the cluster, momentum PCL, made of partons JHEP & KHEP
C-----------------------------------------------------------------------
      INCLUDE 'HERWIG62.INC'
      DOUBLE PRECISION HWREXQ,HWUPCM,HWRGEN,HWVDOT,EMC,QM1,QM2,EMX,EMY,
     & QM3,PXY,PCX,PCY,RCM,PCL(5),AX(5),PA(5),PB(5),PC(5),SKAPPA,DELTM,
     & VSCA,VTMP(4),RKAPPA,VCLUS
      INTEGER HWRINT,JHEP,KHEP,LHEP,MHEP,ID1,ID2,ID3,NTRY,NTRYMX,J,IB
      LOGICAL BTCLUS,SPLIT
      EXTERNAL HWREXQ,HWUPCM,HWRGEN,HWVDOT,HWRINT
      COMMON/HWCFRM/VCLUS(4,NMXHEP)
      PARAMETER (SKAPPA=1.,NTRYMX=100)
      IF (IERROR.NE.0) RETURN
      EMC=PCL(5)
      ID1=IDHW(JHEP)
      ID2=IDHW(KHEP)
      QM1=RMASS(ID1)
      QM2=RMASS(ID2)
      SPLIT=.FALSE.
      NTRY=0
C Decide if cluster contains a b-(anti)quark
      IF (ID1.EQ.5.OR.ID1.EQ.11.OR.ID2.EQ.5.OR.ID2.EQ.11) THEN
        IB=2
      ELSE
        IB=1
      ENDIF
      IF (BTCLUS) THEN
C Split beam and target clusters as soft clusters
C Both (remnant) children treated like soft clusters if IOPREM=0(1)
  10    ID3=HWRINT(1,2)
        QM3=RMASS(ID3)
        IF (EMC.LE.QM1+QM2+2.*QM3) THEN
          ID3=3-ID3
          QM3=RMASS(ID3)
          IF (EMC.LE.QM1+QM2+2.*QM3) RETURN
        ENDIF
        PXY=EMC-QM1-QM2-TWO*QM3
        IF (ISTHEP(JHEP).EQ.153.OR.ISTHEP(JHEP).EQ.154.OR.
     &      IOPREM.EQ.0) THEN
          EMX=QM1+QM3+HWREXQ(BTCLM,PXY)
        ELSE
          EMX=QM1+QM3+PXY*HWRGEN(0)**PSPLT(IB)
        ENDIF
        IF (ISTHEP(KHEP).EQ.153.OR.ISTHEP(KHEP).EQ.154.OR.
     &      IOPREM.EQ.0) THEN
          EMY=QM2+QM3+HWREXQ(BTCLM,PXY)
        ELSE
          EMY=QM2+QM3+PXY*HWRGEN(1)**PSPLT(IB)
        ENDIF
        IF (EMX+EMY.GE.EMC) THEN
          NTRY=NTRY+1
          IF (NTRY.GT.NTRYMX) RETURN
          GOTO 10
        ENDIF
        PCX=HWUPCM(EMX,QM1,QM3)
        PCY=HWUPCM(EMY,QM2,QM3)
      ELSE
C Choose fragment masses for ordinary cluster
        PXY=EMC-QM1-QM2
  20    NTRY=NTRY+1
        IF (NTRY.GT.NTRYMX) RETURN
  30    EMX=QM1+PXY*HWRGEN(0)**PSPLT(IB)
        EMY=QM2+PXY*HWRGEN(1)**PSPLT(IB)
        IF (EMX+EMY.GE.EMC) GOTO 30
C u,d,s pair production with weights QWT
  40    ID3=HWRINT(1,3)
        IF (QWT(ID3).LT.HWRGEN(3)) GOTO 40
        QM3=RMASS(ID3)
        PCX=HWUPCM(EMX,QM1,QM3)
        IF (PCX.LT.ZERO) GOTO 20
        PCY=HWUPCM(EMY,QM2,QM3)
        IF (PCY.LT.ZERO) GOTO 20
        SPLIT=.TRUE.
      ENDIF
C Boost antiquark to CoM frame to find axis
      CALL HWULOF(PCL,PHEP(1,KHEP),AX)
      RCM=1./SQRT(HWVDOT(3,AX,AX))
      CALL HWVSCA(3,RCM,AX,AX)
C Construct new CoM momenta (collinear)
      PXY=HWUPCM(EMC,EMX,EMY)
      CALL HWVSCA(3,PXY,AX,PC)
      PC(4)=SQRT(PXY**2+EMY**2)
      PC(5)=EMY
      CALL HWVSCA(3,PCY,AX,PA)
      PA(4)=SQRT(PCY**2+QM2**2)
      PA(5)=QM2
      CALL HWULOB(PC,PA,PB)
      CALL HWVDIF(4,PC,PB,PA)
      PA(5)=QM3
      LHEP=NHEP+1
      MHEP=NHEP+2
      CALL HWULOB(PCL,PB,PHEP(1,KHEP))
      CALL HWULOB(PCL,PA,PHEP(1,MHEP))
      CALL HWVSCA(3,-ONE,PC,PC)
      PC(4)=EMC-PC(4)
      PC(5)=EMX
      CALL HWVSCA(3,PCX,AX,PA)
      PA(4)=SQRT(PCX**2+QM3**2)
      CALL HWULOB(PC,PA,PB)
      CALL HWULOB(PCL,PB,PHEP(1,LHEP))
      DO 50 J=1,4
  50  PHEP(J,JHEP)=PCL(J)-PHEP(J,KHEP)-PHEP(J,LHEP)-PHEP(J,MHEP)
      PHEP(5,JHEP)=QM1
      CALL HWVEQU(4,VHEP(1,LHEP),VHEP(1,MHEP))
C Construct new vertex positions
      RKAPPA=GEV2MM/SKAPPA
      CALL HWVSCA(3,RKAPPA,AX,AX)
      DELTM=(EMX-EMY)*(EMX+EMY)/(TWO*EMC)
      CALL HWVSCA(3,DELTM,AX,VTMP)
      VTMP(4)=(HALF*EMC-PXY)*RKAPPA
      CALL HWULB4(PCL,VTMP,VTMP)
      CALL HWVSUM(4,VTMP,VCLUS(1,JHEP),VHEP(1,LHEP))
      CALL HWVEQU(4,VHEP(1,LHEP),VHEP(1,MHEP))
      VSCA=0.25*EMC+HALF*(PXY+DELTM)
      CALL HWVSCA(3,VSCA,AX,VTMP)
      VTMP(4)=(EMC-VSCA)*RKAPPA
      CALL HWULB4(PCL,VTMP,VTMP)
      CALL HWVSUM(4,VTMP,VCLUS(1,JHEP),VCLUS(1,MHEP))
      VSCA=-0.25*EMC+HALF*(DELTM-PXY)
      CALL HWVSCA(3,VSCA,AX,VTMP)
      VTMP(4)=(EMC+VSCA)*RKAPPA
      CALL HWULB4(PCL,VTMP,VTMP)
      CALL HWVSUM(4,VTMP,VCLUS(1,JHEP),VCLUS(1,JHEP))
C (Re-)label quarks
      IDHW(LHEP)=ID3+6
      IDHW(MHEP)=ID3
      IDHEP(MHEP)= IDPDG(ID3)
      IDHEP(LHEP)=-IDPDG(ID3)
      ISTHEP(LHEP)=151
      ISTHEP(MHEP)=151
      JMOHEP(2,JHEP)=LHEP
      JDAHEP(2,KHEP)=MHEP
      JMOHEP(1,LHEP)=JMOHEP(1,KHEP)
      JMOHEP(2,LHEP)=MHEP
      JDAHEP(1,LHEP)=0
      JDAHEP(2,LHEP)=JHEP
      JMOHEP(1,MHEP)=JMOHEP(1,JHEP)
      JMOHEP(2,MHEP)=KHEP
      JDAHEP(1,MHEP)=0
      JDAHEP(2,MHEP)=LHEP
      NHEP=NHEP+2
  999 END
CDECK  ID>, HWCDEC.
*CMZ :-        -26/04/91  10.18.56  by  Bryan Webber
*-- Author :    Bryan Webber
C-----------------------------------------------------------------------
      SUBROUTINE HWCDEC
C-----------------------------------------------------------------------
C     DECAYS CLUSTERS INTO PRIMARY HADRONS
C-----------------------------------------------------------------------
      INCLUDE 'HERWIG62.INC'
      INTEGER JCL,KCL,IP,JP,KP,IST,ID1,ID2,ID3
      IF (IERROR.NE.0) RETURN
      IF (IPROC/1000.EQ.9.OR.IPROC/1000.EQ.5) THEN
C---RELABEL CLUSTER CONNECTED TO REMNANT IN DIS
        DO 10 JCL=2,NHEP
        IF (ISTHEP(JCL).EQ.164) GOTO 20
        IF (ISTHEP(JCL).EQ.165) THEN
          IP=JMOHEP(1,JCL)
          JP=JMOHEP(2,JCL)
          KP=IP
          IF (ISTHEP(IP).EQ.162) THEN
            KP=JP
            JP=IP
          ENDIF
          IF (JMOHEP(2,KP).NE.JP) THEN
            IP=JMOHEP(2,KP)
          ELSE
            IP=JDAHEP(2,KP)
          ENDIF
          KCL=JDAHEP(1,IP)
          IF (ISTHEP(KCL)/10.NE.16) CALL HWWARN('HWCDEC',100,*999)
          ISTHEP(KCL)=164
          GOTO 20
        ENDIF
   10   CONTINUE
      ENDIF
   20 CONTINUE
      DO 30 JCL=1,NHEP
      IST=ISTHEP(JCL)
      IF (IST.GT.162.AND.IST.LT.166) THEN
C---DON'T HADRONIZE BEAM/TARGET CLUSTERS
        IF (IST.EQ.163.OR..NOT.GENSOF) THEN
C---SET UP FLAVOURS FOR CLUSTER DECAY
          CALL HWCFLA(IDHW(JMOHEP(1,JCL)),IDHW(JMOHEP(2,JCL)),ID1,ID3)
          CALL HWCHAD(JCL,ID1,ID3,ID2)
        ENDIF
      ENDIF
   30 CONTINUE
      ISTAT=50
  999 END
CDECK  ID>, HWCFLA.
*CMZ :-        -26/04/91  10.18.56  by  Bryan Webber
*-- Author :    Bryan Webber
C-----------------------------------------------------------------------
      SUBROUTINE HWCFLA(JD1,JD2,ID1,ID2)
C-----------------------------------------------------------------------
C     SETS UP FLAVOURS FOR CLUSTER DECAY
C-----------------------------------------------------------------------
      INTEGER JD1,JD2,ID1,ID2,JD,JDEC(12)
      DATA JDEC/1,2,3,10,11,12,4,5,6,7,8,9/
      JD=JD1
      IF (JD.GT.12) JD=JD-108
      ID1=JDEC(JD)
      JD=JD2
      IF (JD.GT.12) JD=JD-96
      ID2=JDEC(JD-6)
      END
CDECK  ID>, HWCFOR.
*CMZ :-        -26/04/91  14.15.56  by  Federico Carminati
*-- Author :    Bryan Webber
C-----------------------------------------------------------------------
      SUBROUTINE HWCFOR
C-----------------------------------------------------------------------
C     Converts colour-connected quark-antiquark pairs into clusters
C     Modified by IGK to include BRW's colour rearrangement and
C     MHS's cluster vertices
C     MODIFIED 16/10/97 BY BRW FOR SUSY PROCESSES
C-----------------------------------------------------------------------
      INCLUDE 'HERWIG62.INC'
      DOUBLE PRECISION HWULDO,HWVDOT,HWRGEN,HWUPCM,DCL0,DCL(4),DCL1,
     & DFAC,DISP1(4),DISP2(4),DMAX,PCL(5),DOT1,DOT2,FAC,VCLUS,SCA1,SCA2,
     & EM0,EM1,EM2,PC0,PC1
      INTEGER HWRINT,MAP(120),IBHEP,IBCL,JBHEP,JHEP,
     & KHEP,LHEP,LCL,IHEP,MCL,I,ISTJ,ISTK,JCL,ID1,ID3,L
      LOGICAL HWRLOG,SPLIT
      EXTERNAL HWULDO,HWVDOT,HWRGEN,HWUPCM,HWRINT
      COMMON/HWCFRM/VCLUS(4,NMXHEP)
      DATA MAP/1,2,3,4,5,6,1,2,3,4,5,6,96*0,7,8,9,10,11,12,7,8,9,10,11,
     & 12/
      IF (IERROR.NE.0) RETURN
C Split gluons
      CALL HWCGSP
C Find colour partners after baryon number violating event
      IF (HVFCEN) THEN
        IF(RPARTY) THEN
          CALL HVCBVI
        ELSE
          CALL HWCBVI
        ENDIF
      ENDIF
      IF (IERROR.NE.0) RETURN
C Look for partons to cluster
      DO 10 IBHEP=1,NHEP
  10  IF (ISTHEP(IBHEP).GE.150.AND.ISTHEP(IBHEP).LE.154) GOTO 20
      IBCL=1
      GOTO 130
  20  CONTINUE
C--Final check for colour disconnections
      DO 25 JHEP=IBHEP,NHEP
        IF (ISTHEP(JHEP).GE.150.AND.ISTHEP(JHEP).LE.154.AND.
     &      QORQQB(IDHW(JHEP))) THEN
          KHEP=JMOHEP(2,JHEP)
C BRW FIX 13/03/99
          IF (KHEP.EQ.0.OR..NOT.(
     &      ISTHEP(KHEP).GE.150.AND.ISTHEP(KHEP).LE.154.AND.
     &      QBORQQ(IDHW(KHEP)))) THEN
            DO KHEP=IBHEP,NHEP
              IF (ISTHEP(KHEP).GE.150.AND.ISTHEP(KHEP).LE.154
     &        .AND.QBORQQ(IDHW(KHEP))) THEN
                LHEP=JDAHEP(2,KHEP)
                IF (LHEP.EQ.0.OR..NOT.(
     &          ISTHEP(LHEP).GE.150.AND.ISTHEP(LHEP).LE.154.AND.
     &          QORQQB(IDHW(LHEP)))) THEN
                  JMOHEP(2,JHEP)=KHEP
                  JDAHEP(2,KHEP)=JHEP
                  GOTO 25
                ENDIF
              ENDIF
            ENDDO
C END FIX
            CALL HWWARN('HWCFOR',100,*999)
          ENDIF
        ENDIF
  25  CONTINUE
      IF (CLRECO) THEN
C Allow for colour rearrangement of primary clusters
        NRECO=0
C Randomize starting point
        JBHEP=HWRINT(IBHEP,NHEP)
        JHEP=JBHEP
  30    JHEP=JHEP+1
        IF (JHEP.GT.NHEP) JHEP=IBHEP
        IF (ISTHEP(JHEP).GE.150.AND.ISTHEP(JHEP).LE.154.AND.
     &      QORQQB(IDHW(JHEP))) THEN
C Find colour connected antiquark or diquark
          KHEP=JMOHEP(2,JHEP)
C Find partner antiquark or diquark
          LHEP=JDAHEP(2,JHEP)
C Find closest antiquark or diquark
          DCL0=1.D15
          LCL=0
          DO 40 IHEP=IBHEP,NHEP
          IF (ISTHEP(IHEP).GE.150.AND.ISTHEP(IHEP).LE.154.AND.
     &        QBORQQ(IDHW(IHEP))) THEN
C Check whether already reconnected
            IF (JDAHEP(2,IHEP).GT.0.AND.IHEP.NE.LHEP) THEN
              CALL HWVDIF(4,VHEP(1,IHEP),VHEP(1,JHEP),DCL)
              DCL1=ABS(HWULDO(DCL,DCL))
              IF (DCL1.LT.DCL0) THEN
                DCL0=DCL1
                LCL=IHEP
              ENDIF
            ENDIF
          ENDIF
  40      CONTINUE
          IF (LCL.NE.0.AND.LCL.NE.KHEP) THEN
            MCL=JDAHEP(2,LCL)
            IF (JDAHEP(2,MCL).NE.KHEP) THEN
C Pairwise reconnection is possible
              CALL HWVDIF(4,VHEP(1,KHEP),VHEP(1,MCL ),DCL)
              DCL0=DCL0+ABS(HWULDO(DCL,DCL))
              CALL HWVDIF(4,VHEP(1,JHEP),VHEP(1,KHEP),DCL)
              DCL1=ABS(HWULDO(DCL,DCL))
              CALL HWVDIF(4,VHEP(1,LCL ),VHEP(1,MCL ),DCL)
              DCL1=DCL1+ABS(HWULDO(DCL,DCL))
              IF (DCL0.LT.DCL1.AND.HWRLOG(PRECO)) THEN
C Reconnection occurs
                JMOHEP(2,JHEP)= LCL
                JDAHEP(2,LCL )=-JHEP
                JMOHEP(2,MCL) = KHEP
                JDAHEP(2,KHEP)=-MCL
                NRECO=NRECO+1
              ENDIF
            ENDIF
          ENDIF
        ENDIF
        IF (JHEP.NE.JBHEP) GOTO 30
        IF (NRECO.NE.0) THEN
          DO 50 IHEP=IBHEP,NHEP
  50      JDAHEP(2,IHEP)=ABS(JDAHEP(2,IHEP))
        ENDIF
      ENDIF
C Find (adjusted) cluster positions using MHS prescription
      DFAC=ONE
      DMAX=1D-10
      DO 70 JHEP=IBHEP,NHEP
      IF (ISTHEP(JHEP).GE.150.AND.ISTHEP(JHEP).LE.154.AND.
     &    QORQQB(IDHW(JHEP))) THEN
        KHEP=JMOHEP(2,JHEP)
        CALL HWUDKL(IDHW(JHEP),PHEP(1,JHEP),DISP1)
        CALL HWVSCA(4,DFAC,DISP1,DISP1)
        CALL HWUDKL(IDHW(KHEP),PHEP(1,KHEP),DISP2)
        CALL HWVSCA(4,DFAC,DISP2,DISP2)
C Rescale the lengths of DISP1,DISP2 if too long
        DOT1=HWVDOT(3,DISP1,DISP1)
        DOT2=HWVDOT(3,DISP2,DISP2)
        IF (MAX(DOT1,DOT2).GT.DMAX**2) THEN
          CALL HWVSCA(4,DMAX/SQRT(DOT1),DISP1,DISP1)
          CALL HWVSCA(4,DMAX/SQRT(DOT2),DISP2,DISP2)
        ENDIF
        CALL HWVSUM(4,PHEP(1,JHEP),PHEP(1,KHEP),PCL)
        DOT1=HWVDOT(3,DISP1,PCL)
        DOT2=HWVDOT(3,DISP2,PCL)
C If PCL > 90^o from either quark, use a vector which isn't
        IF (DOT1.LE.ZERO.OR. DOT2.LE.ZERO) THEN
          CALL HWVSUM(4,DISP1,DISP2,PCL)
          DOT1=HWVDOT(3,DISP1,PCL)
          DOT2=HWVDOT(3,DISP2,PCL)
        ENDIF
C If vectors are exactly opposite each other this method cannot work
        IF (DOT1.EQ.ZERO.OR.DOT2.EQ.ZERO) THEN
C So use midpoint of quark constituents
          CALL HWVSUM(4,VHEP(1,JHEP),VHEP(1,KHEP),VCLUS(1,JHEP))
          CALL HWVSCA(4,HALF,VCLUS(1,JHEP),VCLUS(1,JHEP))
          GOTO 70
        ENDIF
C Rescale DISP1 or DISP2 to give equal components in the PCL direction
        FAC=DOT1/DOT2
        IF (FAC.GT.ONE) THEN
          CALL HWVSCA(4,    FAC,DISP2,DISP2)
          DOT2=DOT1
        ELSE
          CALL HWVSCA(4,ONE/FAC,DISP1,DISP1)
          DOT1=DOT2
        ENDIF
C Shift VHEP(1,JHEP) or VHEP(1,KHEP) s.t. their line is perp to PCL
        FAC=(HWVDOT(3,PCL,VHEP(1,KHEP))
     &      -HWVDOT(3,PCL,VHEP(1,JHEP)))/DOT1
        SCA1=MAX(ONE,ONE+FAC)
        SCA2=MAX(ONE,ONE-FAC)
        DO 60 I=1,4
  60    VCLUS(I,JHEP)=.5*(VHEP(I,JHEP)+VHEP(I,KHEP)
     &                   +SCA1*DISP1(I)+SCA2*DISP2(I))
      ENDIF
  70  CONTINUE
C First chop up beam/target clusters
      DO 80 JHEP=IBHEP,NHEP
      KHEP=JMOHEP(2,JHEP)
      ISTJ=ISTHEP(JHEP)
      ISTK=ISTHEP(KHEP)
C--PR MOD here 8/7/99
      IF (QORQQB(IDHW(JHEP)).AND.
     &   (((ISTJ.EQ.153.OR.ISTJ.EQ.154).AND.ISTK.NE.151.AND.ISTK.NE.0)
     &   .OR.((ISTK.EQ.153.OR.ISTK.EQ.154).
     &   AND.ISTJ.NE.151.AND.ISTJ.NE.0))) THEN
C--end
        CALL HWVSUM(4,PHEP(1,JHEP),PHEP(1,KHEP),PCL)
        CALL HWUMAS(PCL)
        CALL HWCCUT(JHEP,KHEP,PCL,.TRUE.,SPLIT)
      ENDIF
  80  CONTINUE
C Second chop up massive pairs
      DO 100 JHEP=IBHEP,NMXHEP
      IF (JHEP.GT.NHEP) GOTO 110
      IF (ISTHEP(JHEP).GE.150.AND.ISTHEP(JHEP).LE.154.AND.
     &    QORQQB(IDHW(JHEP))) THEN
  90    KHEP=JMOHEP(2,JHEP)
        CALL HWVSUM(4,PHEP(1,JHEP),PHEP(1,KHEP),PCL)
        CALL HWUMAS(PCL)
        IF (PCL(5).GT.CTHRPW(MAP(IDHW(JHEP)),MAP(IDHW(KHEP)))) THEN
          CALL HWCCUT(JHEP,KHEP,PCL,.FALSE.,SPLIT)
          IF (SPLIT) GOTO 90
        ENDIF
      ENDIF
  100 CONTINUE
C Third create clusters and store production vertex
  110 IBCL=NHEP+1
      JCL=NHEP
      DO 120 JHEP=IBHEP,NHEP
      IF (ISTHEP(JHEP).GE.150.AND.ISTHEP(JHEP).LE.154.AND.
     &    QORQQB(IDHW(JHEP))) THEN
        JCL=JCL+1
        IF(JCL.GT.NMXHEP) CALL HWWARN('HWCFOR',105,*999)
        IDHW(JCL)=19
        IDHEP(JCL)=91
        KHEP=JMOHEP(2,JHEP)
        IF (KHEP.EQ.0.OR..NOT.(
     &    ISTHEP(KHEP).GE.150.AND.ISTHEP(KHEP).LE.154.AND.
     &    QBORQQ(IDHW(KHEP)))) CALL HWWARN('HWCFOR',104,*999)
        CALL HWVSUM(4,PHEP(1,JHEP),PHEP(1,KHEP),PHEP(1,JCL))
        CALL HWUMAS(PHEP(1,JCL))
        IF (ISTHEP(JHEP).EQ.153.OR.ISTHEP(KHEP).EQ.153) THEN
          ISTHEP(JCL)=164
        ELSEIF (ISTHEP(JHEP).EQ.154.OR.ISTHEP(KHEP).EQ.154) THEN
          ISTHEP(JCL)=165
        ELSE
          ISTHEP(JCL)=163
        ENDIF
        JMOHEP(1,JCL)=JHEP
        JMOHEP(2,JCL)=KHEP
        JDAHEP(1,JCL)=0
        JDAHEP(2,JCL)=0
        JDAHEP(1,JHEP)=JCL
        JDAHEP(1,KHEP)=JCL
        ISTHEP(JHEP)=ISTHEP(JHEP)+8
        ISTHEP(KHEP)=ISTHEP(KHEP)+8
        CALL HWVEQU(4,VCLUS(1,JHEP),VHEP(1,JCL))
      ENDIF
  120 CONTINUE
      NHEP=JCL
C Fix up momenta for single-hadron clusters
  130 DO 150 JCL=IBCL,NHEP
C Don't hadronize beam/target clusters
      IF (ISTHEP(JCL).LT.163.OR.ISTHEP(JCL).GT.165) GOTO 150
      IF (ISTHEP(JCL).NE.163.AND.GENSOF) GOTO 150
C Set up flavours for cluster decay
      CALL HWCFLA(IDHW(JMOHEP(1,JCL)),IDHW(JMOHEP(2,JCL)),ID1,ID3)
      EM0=PHEP(5,JCL)
      IF ((B1LIM.EQ.ZERO).OR.(ID1.NE.11.AND.ID3.NE.11)) THEN
        IF (EM0.GT.RMIN(ID1,2)+RMIN(2,ID3)) GOTO 150
      ELSE
C Special for b clusters: allow 1-hadron decay above threshold
        IF (B1LIM*HWRGEN(1).LT.EM0/(RMIN(ID1,2)+RMIN(2,ID3))-1.)
     &   GOTO 150
      ENDIF
      EM1=RMIN(ID1,ID3)
      IF (ABS(EM0-EM1).LT.1.D-5) GOTO 150
C Decide to go backward or forward to transfer 4-momentum
      L=1-TWO*INT(HALF+HWRGEN(2))
      MCL=NHEP-IBCL+1
      LCL=JCL
      DO 140 I=1,MCL
      LCL=LCL+L
      IF (LCL.LT.IBCL) LCL=LCL+MCL
      IF (LCL.GT.NHEP) LCL=LCL-MCL
      IF (LCL.EQ.JCL) THEN
        IF (EM0.GE.EM1+RMIN(1,1)) GOTO 150
        CALL HWWARN('HWCFOR',101,*999)
      ENDIF
      IF (ISTHEP(LCL).LT.163.OR.ISTHEP(LCL).GT.165) GOTO 140
C Rescale momenta in 2-cluster CoM
      CALL HWVSUM(4,PHEP(1,JCL),PHEP(1,LCL),PCL)
      CALL HWUMAS(PCL)
      EM2=PHEP(5,LCL)
      PC0=HWUPCM(PCL(5),EM0,EM2)
      PC1=HWUPCM(PCL(5),EM1,EM2)
      IF (PC1.LT.ZERO) THEN
C Need to rescale other mass as well
        CALL HWCFLA(IDHW(JMOHEP(1,LCL)),IDHW(JMOHEP(2,LCL)),ID1,ID3)
        EM2=RMIN(ID1,ID3)
        PC1=HWUPCM(PCL(5),EM1,EM2)
        IF (PC1.LT.ZERO) GOTO 140
        PHEP(5,LCL)=EM2
      ENDIF
      IF (PC0.GT.ZERO) THEN
        PC0=PC1/PC0
        CALL HWULOF(PCL,PHEP(1,JCL),PHEP(1,JCL))
        CALL HWVSCA(3,PC0,PHEP(1,JCL),PHEP(1,JCL))
        PHEP(4,JCL)=SQRT(PC1**2+EM1**2)
        PHEP(5,JCL)=EM1
        CALL HWULOB(PCL,PHEP(1,JCL),PHEP(1,JCL))
        CALL HWVDIF(4,PCL,PHEP(1,JCL),PHEP(1,LCL))
        GOTO 150
      ELSEIF (PC0.EQ.ZERO) THEN
        PHEP(5,JCL)=EM1
        CALL HWDTWO(PCL,PHEP(1,JCL),PHEP(1,LCL),PC1,TWO,.TRUE.)
        GOTO 150
      ELSE
        CALL HWWARN('HWCFOR',102,*999)
      ENDIF
  140 CONTINUE
      CALL HWWARN('HWCFOR',103,*999)
  150 CONTINUE
      ISTAT=60
C Non-partons labelled as partons (ie photons) should get copied
      DO 160 IHEP=1,NHEP
      IF (ISTHEP(IHEP).EQ.150) THEN
        NHEP=NHEP+1
        JDAHEP(1,IHEP)=NHEP
        ISTHEP(IHEP)=157
        ISTHEP(NHEP)=190
        IDHW(NHEP)=IDHW(IHEP)
        IDHEP(NHEP)=IDPDG(IDHW(IHEP))
        CALL HWVEQU(5,PHEP(1,IHEP),PHEP(1,NHEP))
        CALL HWVEQU(4,VHEP(1,IHEP),VHEP(1,NHEP))
        JMOHEP(1,NHEP)=IHEP
        JMOHEP(2,NHEP)=JMOHEP(1,IHEP)
        JDAHEP(1,NHEP)=0
        JDAHEP(2,NHEP)=0
      ENDIF
  160 CONTINUE
  999 END
CDECK  ID>, HWCGSP.
*CMZ :-        -13/07/92  20.15.54  by  Mike Seymour
*-- Author :    Bryan Webber
C-----------------------------------------------------------------------
      SUBROUTINE HWCGSP
C-----------------------------------------------------------------------
C     SPLITS ANY TIMELIKE GLUONS REMAINING AFTER PERTURBATIVE
C     BRANCHING INTO LIGHT (I.E. U OR D) Q-QBAR PAIRS
C-----------------------------------------------------------------------
      INCLUDE 'HERWIG62.INC'
      DOUBLE PRECISION HWRGEN,PF
      INTEGER HWRINT,IHEP,JHEP,KHEP,LHEP,MHEP,ID,J,IST
      EXTERNAL HWRGEN,HWRINT
      IF (NGSPL.EQ.0) CALL HWWARN('HWCGSP',400,*999)
      LHEP=NHEP-1
      MHEP=NHEP
      DO 100 IHEP=1,NHEP
      IF (ISTHEP(IHEP).GE.147.AND.ISTHEP(IHEP).LE.149) THEN
        JHEP=JMOHEP(2,IHEP)
C BRW FIX 12/03/99
        IF (JHEP.LE.0) THEN
          KHEP=0
          DO JHEP=1,NHEP
            IF (ISTHEP(JHEP).GE.147.AND.ISTHEP(JHEP).LE.149
     &      .AND.JDAHEP(2,JHEP).LE.0) THEN
              KHEP=KHEP+1
              JMOHEP(2,IHEP)=JHEP
              JDAHEP(2,JHEP)=IHEP
            ENDIF
          ENDDO
          IF (KHEP.EQ.0) CALL HWWARN('HWCGSP',102,*999)
          IF (KHEP.NE.1) CALL HWWARN('HWCGSP',103,*999)
        ENDIF
C END FIX
C---CHECK FOR DECAYED HEAVY ANTIQUARKS
        IF (ISTHEP(JHEP).EQ.155) THEN
          JHEP=JDAHEP(1,JDAHEP(2,JHEP))
          DO 10 J=JDAHEP(1,JHEP),JDAHEP(2,JHEP)
  10      IF (ISTHEP(J).EQ.149.AND.JDAHEP(2,J).EQ.0) GOTO 20
          CALL HWWARN('HWCGSP',100,*999)
  20      JHEP=J
        ENDIF
        KHEP=JDAHEP(2,IHEP)
C BRW FIX 12/03/99
        IF (KHEP.LE.0) THEN
          KHEP=0
          DO JHEP=1,NHEP
            IF (ISTHEP(JHEP).GE.147.AND.ISTHEP(JHEP).LE.149
     &      .AND.JMOHEP(2,JHEP).LE.0) THEN
              KHEP=KHEP+1
              JDAHEP(2,IHEP)=JHEP
              JMOHEP(2,JHEP)=IHEP
            ENDIF
          ENDDO
          IF (KHEP.EQ.0) CALL HWWARN('HWCGSP',104,*999)
          IF (KHEP.NE.1) CALL HWWARN('HWCGSP',105,*999)
          KHEP=JDAHEP(2,IHEP)
        ENDIF
C END FIX
C---CHECK FOR DECAYED HEAVY QUARKS
        IF (ISTHEP(KHEP).EQ.155)  CALL HWWARN('HWCGSP',101,*999)
        IF (IDHW(IHEP).EQ.13) THEN
C---SPLIT A GLUON
          LHEP=LHEP+2
          MHEP=MHEP+2
          IF(MHEP.GT.NMXHEP) CALL HWWARN('HWCGSP',106,*999)
  30      ID=HWRINT(1,NGSPL)
          IF (PGSPL(ID).LT.PGSMX*HWRGEN(0)) GOTO 30
          PHEP(5,LHEP)=RMASS(ID)
          PHEP(5,MHEP)=RMASS(ID)
C---ASSUME ISOTROPIC ANGULAR DISTRIBUTION
          IF (PHEP(5,IHEP).GT.PHEP(5,LHEP)+PHEP(5,MHEP)) THEN
            CALL HWDTWO(PHEP(1,IHEP),PHEP(1,LHEP),
     &                  PHEP(1,MHEP),PGSPL(ID),TWO,.TRUE.)
          ELSE
            PF=HWRGEN(1)
            CALL HWVSCA(4,PF,PHEP(1,IHEP),PHEP(1,LHEP))
            CALL HWVDIF(4,PHEP(1,IHEP),PHEP(1,LHEP),PHEP(1,MHEP))
            PHEP(5,LHEP)=PF*PHEP(5,IHEP)
            PHEP(5,MHEP)=PHEP(5,IHEP)-PHEP(5,LHEP)
          ENDIF
          CALL HWUDKL(13,PHEP(1,IHEP),VHEP(1,LHEP))
          CALL HWVSUM(4,VHEP(1,IHEP),VHEP(1,LHEP),VHEP(1,LHEP))
          CALL HWVEQU(4,VHEP(1,LHEP),VHEP(1,MHEP))
          IDHW(LHEP)=ID+6
          IDHW(MHEP)=ID
          IDHEP(MHEP)= IDPDG(ID)
          IDHEP(LHEP)=-IDPDG(ID)
          ISTHEP(IHEP)=2
          ISTHEP(LHEP)=150
          ISTHEP(MHEP)=150
C---NEW COLOUR CONNECTIONS
          IF(RPARTY.OR.JMOHEP(2,KHEP).EQ.IHEP) JMOHEP(2,KHEP)=LHEP
          IF(RPARTY.OR.JDAHEP(2,JHEP).EQ.IHEP) JDAHEP(2,JHEP)=MHEP
          JMOHEP(1,LHEP)=JMOHEP(1,IHEP)
          JMOHEP(2,LHEP)=MHEP
          JMOHEP(1,MHEP)=JMOHEP(1,IHEP)
          JMOHEP(2,MHEP)=JHEP
          JDAHEP(1,LHEP)=0
          JDAHEP(2,LHEP)=KHEP
          JDAHEP(1,MHEP)=0
          JDAHEP(2,MHEP)=LHEP
          JDAHEP(1,IHEP)=LHEP
          JDAHEP(2,IHEP)=MHEP
        ELSE
C---COPY A NON-GLUON
          LHEP=LHEP+1
          MHEP=MHEP+1
          IF(MHEP.GT.NMXHEP) CALL HWWARN('HWCGSP',107,*999)
          CALL HWVEQU(5,PHEP(1,IHEP),PHEP(1,MHEP))
          CALL HWVEQU(4,VHEP(1,IHEP),VHEP(1,MHEP))
          IDHW(MHEP)=IDHW(IHEP)
          IDHEP(MHEP)=IDHEP(IHEP)
          IST=ISTHEP(IHEP)
          ISTHEP(IHEP)=2
          IF (IST.EQ.149) THEN
            ISTHEP(MHEP)=150
          ELSE
            ISTHEP(MHEP)=IST+6
          ENDIF
C---NEW COLOUR CONNECTIONS
          IF(RPARTY.OR.JMOHEP(2,KHEP).EQ.IHEP)
     &      JMOHEP(2,KHEP)=MHEP
          IF(RPARTY.OR.(JHEP.NE.IHEP.AND.JDAHEP(2,JHEP).EQ.IHEP))
     &      JDAHEP(2,JHEP)=MHEP
          JMOHEP(1,MHEP)=JMOHEP(1,IHEP)
          JMOHEP(2,MHEP)=JMOHEP(2,IHEP)
          JDAHEP(1,MHEP)=0
          JDAHEP(2,MHEP)=JDAHEP(2,IHEP)
          JDAHEP(1,IHEP)=MHEP
        ENDIF
      ENDIF
  100 CONTINUE
      NHEP=MHEP
  999 END
CDECK  ID>, HWCHAD.
*CMZ :-        -26/04/91  14.00.57  by  Federico Carminati
*-- Author :    Bryan Webber
C-----------------------------------------------------------------------
      SUBROUTINE HWCHAD(JCL,ID1,ID3,ID2)
C-----------------------------------------------------------------------
C     HADRONIZES CLUSTER JCL, CONSISTING OF PARTONS ID1,ID3
C     ID2 RETURNS PARTON-ANTIPARTON PAIR CREATED
C     (IN SPECIAL CLUSTER CODE - SEE HWCFLA)
C
C MODIFIED 15/11/99 TO SMEAR POSITIONS OF HADRONS BY 1/(CLUSTER MASS)
C-----------------------------------------------------------------------
      INCLUDE 'HERWIG62.INC'
      DOUBLE PRECISION HWRGEN,HWRGAU,HWVDOT,EM0,EM1,EM2,EMADU,EMSQ,
     & PCMAX,PCM,PTEST,PCQK,PP(5),EMLOW,RMAT(3,3),CT,ST,CX,SX,HPSMR
      INTEGER HWRINT,JCL,ID1,ID2,ID3,ID,IR1,IR2,NTRY,IDMIN,IMAX,I,MHEP,
     & IM,JM,KM,IB
      LOGICAL DIQK
      EXTERNAL HWRGEN,HWRINT
      DIQK(ID)=ID.GT.3.AND.ID.LT.10
      IF (IERROR.NE.0) RETURN
      ID2=0
      EM0=PHEP(5,JCL)
      IR1=NCLDK(LOCN(ID1,ID3))
      EM1=RMIN(ID1,ID3)
      IF (ABS(EM0-EM1).LT.0.001) THEN
C---SINGLE-HADRON CLUSTER
        NHEP=NHEP+1
        IF (NHEP.GT.NMXHEP) CALL HWWARN('HWCHAD',100,*999)
        IDHW(NHEP)=IR1
        IDHEP(NHEP)=IDPDG(IR1)
        ISTHEP(NHEP)=191
        JDAHEP(1,JCL)=NHEP
        JDAHEP(2,JCL)=NHEP
        CALL HWVEQU(5,PHEP(1,JCL),PHEP(1,NHEP))
        CALL HWVSUM(4,VHEP(1,JCL),VTXPIP,VHEP(1,NHEP))
      ELSE
        NTRY=0
        IDMIN=1
        EMLOW=RMIN(ID1,1)+RMIN(1,ID3)
        EMADU=RMIN(ID1,2)+RMIN(2,ID3)
        IF (EMADU.LT.EMLOW) THEN
          IDMIN=2
          EMLOW=EMADU
        ENDIF
        EMSQ=EM0**2
        PCMAX=EMSQ-EMLOW**2
        IF (PCMAX.GE.ZERO) THEN
C---SET UP TWO QUARK-ANTIQUARK PAIRS OR A
C   QUARK-DIQUARK AND AN ANTIDIQUARK-ANTIQUARK
          PCMAX=PCMAX*(EMSQ-(RMIN(ID1,IDMIN)-RMIN(IDMIN,ID3))**2)
          IMAX=12
          IF (DIQK(ID1).OR.DIQK(ID3)) IMAX=3
          DO 10 I=3,IMAX
          IF (EM0.LT.RMIN(ID1,I)+RMIN(I,ID3)) GOTO 20
  10      CONTINUE
          I=IMAX+1
  20      ID2=HWRINT(1,I-1)
          IF (PWT(ID2).NE.ONE) THEN
            IF (PWT(ID2).LT.HWRGEN(1)) GOTO 20
          ENDIF
C---PICK TWO PARTICLES WITH THESE QUANTUM NUMBERS
          NTRY=NTRY+1
  30      IR1=LOCN(ID1,ID2)+INT(RESN(ID1,ID2)*HWRGEN(2))
          IF (CLDKWT(IR1).LT.HWRGEN(3)) GOTO 30
          IR1=NCLDK(IR1)
  40      IR2=LOCN(ID2,ID3)+INT(RESN(ID2,ID3)*HWRGEN(4))
          IF (CLDKWT(IR2).LT.HWRGEN(5)) GOTO 40
          IR2=NCLDK(IR2)
          EM1=RMASS(IR1)
          EM2=RMASS(IR2)
          PCM=EMSQ-(EM1+EM2)**2
          IF (PCM.GT.ZERO) GOTO 70
  50      IF (NTRY.LE.NDTRY) GOTO 20
C---CAN'T FIND A DECAY MODE - CHOOSE LIGHTEST
  60      ID2=HWRINT(1,2)
          IR1=NCLDK(LOCN(ID1,ID2))
          IR2=NCLDK(LOCN(ID2,ID3))
          EM1=RMASS(IR1)
          EM2=RMASS(IR2)
          PCM=EMSQ-(EM1+EM2)**2
          IF (PCM.GT.ZERO) GOTO 70
          NTRY=NTRY+1
          IF (NTRY.LE.NDTRY+50) GOTO 60
          CALL HWWARN('HWCHAD',101,*999)
C---DECAY IS ALLOWED
  70      PCM=PCM*(EMSQ-(EM1-EM2)**2)
          IF (NTRY.GT.NCTRY) GOTO 80
          PTEST=PCM*SWTEF(IR1)*SWTEF(IR2)
          IF (PTEST.LT.PCMAX*HWRGEN(0)**2) GOTO 20
        ELSE
C---ALLOW DECAY BY PI0 EMISSION IF ONLY POSSIBILITY
          ID2=1
          IR2=NCLDK(LOCN(1,1))
          EM2=RMASS(IR2)
          PCM=(EMSQ-(EM1+EM2)**2)*(EMSQ-(EM1-EM2)**2)
        ENDIF
C---DECAY IS CHOSEN.  GENERATE DECAY MOMENTA
C   AND PUT PARTICLES IN /HEPEVT/
  80    IF (PCM.LT.ZERO) CALL HWWARN('HWCHAD',102,*999)
        PCM=0.5*SQRT(PCM)/EM0
        MHEP=NHEP+1
        NHEP=NHEP+2
        IF (NHEP.GT.NMXHEP) CALL HWWARN('HWCHAD',103,*999)
        PHEP(5,MHEP)=EM1
        PHEP(5,NHEP)=EM2
C Decide if cluster contains a b-(anti)quark or not
        IF (ID1.EQ.11.OR.ID2.EQ.11.OR.ID3.EQ.11) THEN
          IB=2
        ELSE
          IB=1
        ENDIF
        IF (CLDIR(IB).NE.0) THEN
          DO 110 IM=1,2
            JM=JMOHEP(IM,JCL)
            IF (JM.EQ.0) GOTO 110
            IF (ISTHEP(JM).NE.158) GOTO 110
C   LOOK FOR PARENT PARTON
            DO 100 KM=JMOHEP(1,JM)+1,JM
              IF (ISTHEP(KM).EQ.2) THEN
                IF (JDAHEP(1,KM).EQ.JM) THEN
C   FOUND PARENT PARTON
                  IF (IDHW(KM).NE.13) THEN
C   FIND ITS DIRECTION IN CLUSTER CMF
                   CALL HWULOF(PHEP(1,JCL),PHEP(1,KM),PP)
                   PCQK=PP(1)**2+PP(2)**2+PP(3)**2
                   IF (PCQK.GT.ZERO) THEN
                    PCQK=SQRT(PCQK)
                    IF (CLSMR(IB).GT.ZERO) THEN
C   DO GAUSSIAN SMEARING OF DIRECTION
  90                 CT=ONE+CLSMR(IB)*LOG(HWRGEN(0))
                     IF (CT.LT.-ONE) GOTO 90
                     ST=ONE-CT*CT
                     IF (ST.GT.ZERO) ST=SQRT(ST)
                     CALL HWRAZM( ONE,CX,SX)
                     CALL HWUROT(PP,CX,SX,RMAT)
                     PP(1)=ZERO
                     PP(2)=PCQK*ST
                     PP(3)=PCQK*CT
                     CALL HWUROB(RMAT,PP,PP)
                    ENDIF
                    PCQK=PCM/PCQK
                    IF (IM.EQ.2) PCQK=-PCQK
                    CALL HWVSCA(3,PCQK,PP,PHEP(1,MHEP))
                    PHEP(4,MHEP)=SQRT(PHEP(5,MHEP)**2+PCM**2)
                    CALL HWULOB(PHEP(1,JCL),PHEP(1,MHEP),PHEP(1,MHEP))
                    CALL HWVDIF(4,PHEP(1,JCL),PHEP(1,MHEP),PHEP(1,NHEP))
                    GOTO 130
                   ENDIF
                  ENDIF
                  GOTO 120
                ENDIF
              ELSEIF (ISTHEP(KM).GT.140) THEN
C   FINISHED THIS JET
                GOTO 110
              ENDIF
 100        CONTINUE
 110      CONTINUE
        ENDIF
 120    CALL HWDTWO(PHEP(1,JCL),PHEP(1,MHEP),PHEP(1,NHEP),
     &              PCM,TWO,.TRUE.)
 130    IDHW(MHEP)=IR1
        IDHW(NHEP)=IR2
        IDHEP(MHEP)=IDPDG(IR1)
        IDHEP(NHEP)=IDPDG(IR2)
        ISTHEP(MHEP)=192
        ISTHEP(NHEP)=192
        JMOHEP(1,MHEP)=JCL
C---SECOND MOTHER OF HADRON IS JET
        JMOHEP(2,MHEP)=JMOHEP(1,JMOHEP(1,JCL))
        JDAHEP(1,JCL)=MHEP
        JDAHEP(2,JCL)=NHEP
C---SMEAR HADRON POSITIONS
        HPSMR=GEV2MM/PHEP(5,JCL)
        DO I=1,4
          VHEP(I,MHEP)=HWRGAU(I,ZERO,HPSMR)
        ENDDO
        VHEP(4,MHEP)=ABS(VHEP(4,MHEP))
     &           +SQRT(HWVDOT(3,VHEP(1,MHEP),VHEP(1,MHEP)))
        CALL HWULB4(PHEP(1,JCL),VHEP(1,MHEP),VHEP(1,MHEP))
        CALL HWVSUM(4,VHEP(1,JCL),VHEP(1,MHEP),VHEP(1,MHEP))
        CALL HWVSUM(4,VTXPIP,VHEP(1,MHEP),VHEP(1,MHEP))
        DO I=1,4
          VHEP(I,NHEP)=HWRGAU(I,ZERO,HPSMR)
        ENDDO
        VHEP(4,NHEP)=ABS(VHEP(4,NHEP))
     &           +SQRT(HWVDOT(3,VHEP(1,NHEP),VHEP(1,NHEP)))
        CALL HWULB4(PHEP(1,JCL),VHEP(1,NHEP),VHEP(1,NHEP))
        CALL HWVSUM(4,VHEP(1,JCL),VHEP(1,NHEP),VHEP(1,NHEP))
        CALL HWVSUM(4,VTXPIP,VHEP(1,NHEP),VHEP(1,NHEP))
      ENDIF
      ISTHEP(JCL)=180+MOD(ISTHEP(JCL),10)
      JMOHEP(1,NHEP)=JCL
      JMOHEP(2,NHEP)=JMOHEP(1,JMOHEP(1,JCL))
  999 END
CDECK  ID>, HWDBOS.
*CMZ :-        -23/05/96  18.34.17  by  Mike Seymour
*-- Author :    Mike Seymour
C-----------------------------------------------------------------------
      SUBROUTINE HWDBOS(IBOSON)
C-----------------------------------------------------------------------
C     DECAY GAUGE BOSONS (ALREADY FOUND BY HWDHAD)
C     USES SPIN DENSITY MATRIX IN RHOHEP (1ST CMPT=>-VE,2=>LONG,3=>+VE)
C     IF BOSON CAME FROM HIGGS DECAY, GIVE BOTH THE SAME HELICITY (EPR)
C     IF BOSON CAME FROM W+1JET, GIVE IT THE CORRECT DECAY CORRELATIONS
C-----------------------------------------------------------------------
      INCLUDE 'HERWIG62.INC'
      DOUBLE PRECISION HWRGEN,HWRUNI,HWUPCM,HWULDO,R(3,3),CV,CA,BR,PCM,
     & PBOS(5),PMAX,PROB,RRLL,RLLR
      INTEGER HWRINT,IBOS,IBOSON,IPAIR,ICMF,IOPT,IHEL,IMOTH,
     & I,IQRK,IANT,ID,IQ
      LOGICAL QUARKS
      EXTERNAL HWRGEN,HWRUNI,HWUPCM,HWULDO,HWRINT
      IBOS=IBOSON
      IF (IDHW(IBOS).LT.198.OR.IDHW(IBOS).GT.200)
     &  CALL HWWARN('HWDBOS',101,*999)
      QUARKS=.FALSE.
C---SEE IF IT IS PART OF A PAIR
      IMOTH=JMOHEP(1,IBOS)
      IPAIR=JMOHEP(2,IBOS)
      ICMF=JMOHEP(1,IBOS)
      IF (IDHW(ICMF).EQ.IDHW(IBOS).AND.ISTHEP(ICMF)/10.EQ.12)
     &  ICMF=JMOHEP(1,ICMF)
      IOPT=0
      IF (IPAIR.NE.0) THEN
        IF (JMOHEP(2,IPAIR).NE.IBOS.OR.
     &    IDHW(IPAIR).LT.198.OR.IDHW(IPAIR).GT.200) IPAIR=0
      ENDIF
      IF (IPAIR.GT.0) IOPT=1
C---SELECT DECAY PRODUCTS
   10 CALL HWDBOZ(IDHW(IBOS),IDN(1),IDN(2),CV,CA,BR,IOPT)
C---V + 1JET DECAYS ARE NOW HANDLED HERE !
      IF (IPRO.EQ.21) THEN
        IQRK=IDHW(JMOHEP(1,ICMF))
        IANT=IDHW(JMOHEP(2,ICMF))
        IF (IQRK.EQ.13 .AND. IANT.LE.6) THEN
          IQRK=JMOHEP(2,ICMF)
          IANT=JDAHEP(2,ICMF)
        ELSEIF (IQRK.EQ.13) THEN
          IQRK=JDAHEP(2,ICMF)
          IANT=JMOHEP(2,ICMF)
        ELSEIF (IANT.EQ.13 .AND. IQRK.LE.6) THEN
          IQRK=JMOHEP(1,ICMF)
          IANT=JDAHEP(2,ICMF)
        ELSEIF (IANT.EQ.13) THEN
          IQRK=JDAHEP(2,ICMF)
          IANT=JMOHEP(1,ICMF)
        ELSEIF (IQRK.GT.IANT) THEN
          IQRK=JMOHEP(2,ICMF)
          IANT=JMOHEP(1,ICMF)
        ELSE
          IQRK=JMOHEP(1,ICMF)
          IANT=JMOHEP(2,ICMF)
        ENDIF
        PHEP(5,NHEP+1)=RMASS(IDN(1))
        PHEP(5,NHEP+2)=RMASS(IDN(2))
        PCM=HWUPCM(PHEP(5,IBOS),PHEP(5,NHEP+1),PHEP(5,NHEP+2))
        IF (PCM.LT.ZERO) CALL HWWARN('HWDBOS',103,*999)
        IF (IDHW(IBOS).EQ.200) THEN
          ID=IDN(1)
          IF (ID.GT.120) ID=ID-110
          IQ=IDHW(IQRK)
          IF (IQ.GT.6) IQ=IQ-6
          RRLL=(VFCH(IQ,1)**2+AFCH(IQ,1)**2)*
     $         (VFCH(ID,1)**2+AFCH(ID,1)**2)
     $         +4*VFCH(IQ,1)*AFCH(IQ,1)*
     $         VFCH(ID,1)*AFCH(ID,1)
          RLLR=(VFCH(IQ,1)**2+AFCH(IQ,1)**2)*
     $         (VFCH(ID,1)**2+AFCH(ID,1)**2)
     $         -4*VFCH(IQ,1)*AFCH(IQ,1)*
     $         VFCH(ID,1)*AFCH(ID,1)
        ELSE
          RRLL=1
          RLLR=0
        ENDIF
        PMAX=(RRLL+RLLR)
     &      *(HWULDO(PHEP(1,IANT),PHEP(1,IBOS))**2+
     &        HWULDO(PHEP(1,IQRK),PHEP(1,IBOS))**2)
 1      CALL HWDTWO(PHEP(1,IBOS),PHEP(1,NHEP+1),PHEP(1,NHEP+2),
     &              PCM,TWO,.TRUE.)
        PROB=RRLL*(HWULDO(PHEP(1,IANT),PHEP(1,NHEP+1))**2+
     &             HWULDO(PHEP(1,IQRK),PHEP(1,NHEP+2))**2)+
     &       RLLR*(HWULDO(PHEP(1,IANT),PHEP(1,NHEP+2))**2+
     &             HWULDO(PHEP(1,IQRK),PHEP(1,NHEP+1))**2)
        IF (PROB.GT.PMAX.OR.PROB.LT.ZERO)
     &   CALL HWWARN('HWDBOS',104,*999)
        IF (PMAX*HWRGEN(0).GT.PROB) GOTO 1
      ELSE
C---SELECT HELICITY, UNLESS IT IS THE SECOND OF A HIGGS DECAY (EPR)
      IF (IPAIR.NE.IBOS .OR. IDHW(ICMF).NE.201) THEN
      IF (RHOHEP(1,IBOS)+RHOHEP(2,IBOS)+RHOHEP(3,IBOS).LE.ZERO) THEN
C---COPY PARENT HELICITY IF IT WAS A GAUGE BOSON
        IF (IDHW(IMOTH).GE.198.AND.IDHW(IMOTH).LE.200) THEN
          CALL HWVEQU(3,RHOHEP(1,IMOTH),RHOHEP(1,IBOS))
          IF (RHOHEP(1,IBOS)+RHOHEP(2,IBOS)+RHOHEP(3,IBOS).GT.ZERO)
     &    GOTO 20
C---MAY BE FROM A SUSY DECAY
        ELSEIF (ABS(IDHEP(IMOTH)).LT.1000000) THEN
          CALL HWWARN('HWDBOS',1,*999)
        ENDIF
        RHOHEP(1,IBOS)=1.
        RHOHEP(2,IBOS)=1.
        RHOHEP(3,IBOS)=1.
      ENDIF
 20   IHEL=HWRINT(1,3)
      IF (HWRGEN(0).GT.RHOHEP(IHEL,IBOS)) GOTO 20
      ENDIF
C---SELECT DIRECTION OF FERMION
 30   COSTH=HWRUNI(0,-ONE,ONE)
      IF (IHEL.EQ.1 .AND. (ONE+COSTH)**2.LT.HWRGEN(0)*FOUR) GOTO 30
      IF (IHEL.EQ.2 .AND. (ONE-COSTH**2).LT.HWRGEN(0)     ) GOTO 30
      IF (IHEL.EQ.3 .AND. (ONE-COSTH)**2.LT.HWRGEN(0)*FOUR) GOTO 30
C---GENERATE DECAY RELATIVE TO Z-AXIS
      PHEP(5,NHEP+1)=RMASS(IDN(1))
      PHEP(5,NHEP+2)=RMASS(IDN(2))
      PCM=HWUPCM(PHEP(5,IBOS),PHEP(5,NHEP+1),PHEP(5,NHEP+2))
      IF (PCM.LT.ZERO) CALL HWWARN('HWDBOS',102,*999)
      CALL HWRAZM(PCM*SQRT(1-COSTH**2),PHEP(1,NHEP+1),PHEP(2,NHEP+1))
      PHEP(3,NHEP+1)=PCM*COSTH
      PHEP(4,NHEP+1)=SQRT(PHEP(5,NHEP+1)**2+PCM**2)
C---ROTATE SO THAT Z-AXIS BECOMES BOSON'S DIRECTION IN ORIGINAL CM FRAME
      CALL HWULOF(PHEP(1,ICMF),PHEP(1,IBOS),PBOS)
      CALL HWUROT(PBOS, ONE,ZERO,R)
      CALL HWUROB(R,PHEP(1,NHEP+1),PHEP(1,NHEP+1))
C---BOOST BACK TO LAB
      CALL HWULOB(PHEP(1,IBOS),PHEP(1,NHEP+1),PHEP(1,NHEP+1))
      CALL HWVDIF(4,PHEP(1,IBOS),PHEP(1,NHEP+1),PHEP(1,NHEP+2))
      ENDIF
C---STATUS, IDs AND POINTERS
      ISTHEP(IBOS)=195
      DO 50 I=1,2
        ISTHEP(NHEP+I)=193
        IDHW(NHEP+I)=IDN(I)
        IDHEP(NHEP+I)=IDPDG(IDN(I))
        JDAHEP(I,IBOS)=NHEP+I
        JMOHEP(1,NHEP+I)=IBOS
        JMOHEP(2,NHEP+I)=JMOHEP(1,IBOS)
 50   CONTINUE
      NHEP=NHEP+2
      IF (IDN(1).LE.12) THEN
        ISTHEP(NHEP-1)=113
        ISTHEP(NHEP)=114
        JMOHEP(2,NHEP)=NHEP-1
        JDAHEP(2,NHEP)=NHEP-1
        JMOHEP(2,NHEP-1)=NHEP
        JDAHEP(2,NHEP-1)=NHEP
        QUARKS=.TRUE.
      ENDIF
C---IF FIRST OF A PAIR, DO SECOND DECAY
      IF (IPAIR.NE.0 .AND. IPAIR.NE.IBOS) THEN
        IBOS=IPAIR
        GOTO 10
      ENDIF
C---IF QUARK DECAY, HADRONIZE
      IF (QUARKS) THEN
        EMSCA=PHEP(5,IBOS)
        CALL HWBGEN
        CALL HWDHOB
        CALL HWCFOR
        CALL HWCDEC
      ENDIF
 999  END
CDECK  ID>, HWDBOZ.
*CMZ :-        -29/04/91  18.00.03  by  Federico Carminati
*-- Author :    Mike Seymour
C-----------------------------------------------------------------------
      SUBROUTINE HWDBOZ(IDBOS,IFER,IANT,CV,CA,BR,IOPT)
C-----------------------------------------------------------------------
C     CHOOSE DECAY MODE OF BOSON
C     IOPT=2 TO RESET COUNTERS, 1 FOR BOSON PAIR, 0 FOR ANY OTHERS
C-----------------------------------------------------------------------
      INCLUDE 'HERWIG62.INC'
      DOUBLE PRECISION HWRGEN,BRMODE(12,3),CV,CA,BR,BRLST,BRCOM,FACZ,
     & FACW
      INTEGER HWRINT,IDBOS,IDEC,IDMODE(2,12,3),IFER,IANT,IOPT,I1,I2,
     & I1LST,I2LST,NWGLST,NUMDEC,NPAIR,MODTMP,JFER
      LOGICAL GENLST
      EXTERNAL HWRGEN,HWRINT
      SAVE FACW,FACZ,NWGLST,GENLST,NUMDEC,NPAIR,I1LST,I2LST,BRLST
      DATA NWGLST,GENLST,NPAIR/-1,.FALSE.,0/
C---STORE THE DECAY MODES (FERMION FIRST)
      DATA IDMODE/  2,  7,  4,  9,  6, 11,  2,  9,  4,  7,
     &            122,127,124,129,126,131,8*0,
     &              1,  8,  3, 10,  5, 12,  3,  8,  1, 10,
     &            121,128,123,130,125,132,8*0,
     &              1,  7,  2,  8,  3,  9,  4, 10,  5, 11,  6, 12,
     &            121,127,123,129,125,131,122,128,124,130,126,132/
C---STORE THE BRANCHING RATIOS TO THESE MODES
      DATA BRMODE/0.321,0.321,0.000,0.017,0.017,0.108,0.108,0.108,4*0.0,
     &            0.321,0.321,0.000,0.017,0.017,0.108,0.108,0.108,4*0.0,
     &            0.154,0.120,0.154,0.120,0.152,0.000,
     &            0.033,0.033,0.033,0.067,0.067,0.067/
C---FACTORS FOR CV AND CA FOR W AND Z
      DATA FACW,FACZ/2*0.0/
      IF (FACZ.EQ.ZERO) FACZ=SQRT(SWEIN)
      IF (FACW.EQ.ZERO) FACW=0.5/SQRT(2D0)
      IF (IDBOS.LT.198.OR.IDBOS.GT.200) CALL HWWARN('HWDBOZ',101,*999)
C---IF THIS IS A NEW EVENT SINCE LAST TIME, ZERO COUNTERS
      IF (NWGTS.NE.NWGLST .OR.(GENEV.NEQV.GENLST).OR. IOPT.EQ.2) THEN
        NPAIR=0
        NUMDEC=0
        NWGLST=NWGTS
        GENLST=GENEV
        IF (IOPT.EQ.2) RETURN
      ENDIF
      NUMDEC=NUMDEC+1
      IF (NUMDEC.GT.MODMAX) CALL HWWARN('HWDBOZ',102,*999)
C---IF PAIR OPTION SPECIFIED FOR THE FIRST TIME, MAKE CHOICE
      IF (IOPT.EQ.1) THEN
        IF (NUMDEC.GT.MODMAX-1) CALL HWWARN('HWDBOZ',103,*999)
        IF (NPAIR.EQ.0) THEN
          IF (HWRGEN(1).GT.HALF) THEN
            MODTMP=MODBOS(NUMDEC+1)
            MODBOS(NUMDEC+1)=MODBOS(NUMDEC)
            MODBOS(NUMDEC)=MODTMP
          ENDIF
          NPAIR=NUMDEC
        ELSE
          NPAIR=0
        ENDIF
      ENDIF
C---SELECT USER'S CHOICE
      IF (IDBOS.EQ.200) THEN
        IF (MODBOS(NUMDEC).EQ.1) THEN
          I1=1
          I2=6
        ELSEIF (MODBOS(NUMDEC).EQ.2) THEN
          I1=7
          I2=7
        ELSEIF (MODBOS(NUMDEC).EQ.3) THEN
          I1=8
          I2=8
        ELSEIF (MODBOS(NUMDEC).EQ.4) THEN
          I1=9
          I2=9
        ELSEIF (MODBOS(NUMDEC).EQ.5) THEN
          I1=7
          I2=8
        ELSEIF (MODBOS(NUMDEC).EQ.6) THEN
          I1=10
          I2=12
        ELSEIF (MODBOS(NUMDEC).EQ.7) THEN
          I1=5
          I2=5
        ELSE
          I1=1
          I2=12
        ENDIF
      ELSE
        IF (MODBOS(NUMDEC).EQ.1) THEN
          I1=1
          I2=5
        ELSEIF (MODBOS(NUMDEC).EQ.2) THEN
          I1=6
          I2=6
        ELSEIF (MODBOS(NUMDEC).EQ.3) THEN
          I1=7
          I2=7
        ELSEIF (MODBOS(NUMDEC).EQ.4) THEN
          I1=8
          I2=8
        ELSEIF (MODBOS(NUMDEC).EQ.5) THEN
          I1=6
          I2=7
        ELSE
          I1=1
          I2=8
        ENDIF
      ENDIF
 10   IDEC=HWRINT(I1,I2)
      IF (HWRGEN(0).GT.BRMODE(IDEC,IDBOS-197).AND.I1.NE.I2) GOTO 10
      IFER=IDMODE(1,IDEC,IDBOS-197)
      IANT=IDMODE(2,IDEC,IDBOS-197)
C---CALCULATE BRANCHING RATIO
C   (RESULT IS NOT WELL-DEFINED AFTER THE FIRST CALL OF A PAIR)
      BR=0
      DO 20 IDEC=I1,I2
 20     BR=BR+BRMODE(IDEC,IDBOS-197)
      IF (IOPT.EQ.1) THEN
        IF (NPAIR.NE.0) THEN
          I1LST=I1
          I2LST=I2
          BRLST=BR
        ELSE
          BRCOM=0
          DO 30 IDEC=MAX(I1,I1LST),MIN(I2,I2LST)
 30         BRCOM=BRCOM+BRMODE(IDEC,IDBOS-197)
          BR=2*BR*BRLST - BRCOM**2
        ENDIF
      ENDIF
C---SET UP VECTOR AND AXIAL VECTOR COUPLINGS (NORMALIZED TO THE
C   CONVENTION WHERE THE WEAK CURRENT IS G*(CV-CA*GAM5) )
      IF (IDBOS.EQ.200) THEN
        IF (IFER.LE.6) THEN
C Quark couplings
           CV=VFCH(IFER,1)
           CA=AFCH(IFER,1)
        ELSE
C lepton couplings
           JFER=IFER-110
           CV=VFCH(JFER,1)
           CA=AFCH(JFER,1)
        ENDIF
        CV=CV * FACZ
        CA=CA * FACZ
      ELSE
        CV=FACW
        CA=FACW
      ENDIF
 999  END
CDECK  ID>, HWDCHK.
*CMZ :-        -27/07/99  13.33.03  by  Mike Seymour
*-- Author :    Ian Knowles
C-----------------------------------------------------------------------
      SUBROUTINE HWDCHK(IDKY,L,*)
C-----------------------------------------------------------------------
C     Checks line L of decay table is compatible with decay of particle
C     IDKY, tidies up the line and sets NPRODS.
C-----------------------------------------------------------------------
      INCLUDE 'HERWIG62.INC'
      DOUBLE PRECISION EPS,QS,Q,DM
      INTEGER IDKY,L,IFAULT,I,ID,J
      PARAMETER (EPS=1.D-6)
      IF (VTOCDK(IDKY).AND.VTORDK(IDKY)) RETURN 1
      IFAULT=0
      QS=FLOAT(ICHRG(IDKY))
      IF (IDKY.LE.12.OR.(IDKY.GE.109.AND.IDKY.LE.120)
     &              .OR.(IDKY.GE.209.AND.IDKY.LE.220)
     &              .OR.(IDKY.GE.401.AND.IDKY.LE.424)) QS=QS/3.
      DM=RMASS(IDKY)
      NPRODS(L)=0
      DO 10 I=1,5
      ID=IDKPRD(I,L)
      IF (ID.LT.0.OR.ID.EQ.20.OR.ID.GT.NRES) THEN
        WRITE(6,20) L,RNAME(IDKY),(RNAME(IDKPRD(J,L)),J=1,5)
        IFAULT=IFAULT+1
      ELSEIF (ID.NE.0) THEN
        IF (VTORDK(ID)) THEN
          WRITE(6,30) L,RNAME(IDKY),(RNAME(IDKPRD(J,L)),J=1,5),RNAME(ID)
          IFAULT=IFAULT+1
        ENDIF
        NPRODS(L)=NPRODS(L)+1
        IDKPRD(NPRODS(L),L)=ID
        Q=FLOAT(ICHRG(ID))
        IF (ID.LE.12.OR.(ID.GE.109.AND.ID.LE.120)
     &              .OR.(ID.GE.209.AND.ID.LE.220)
     &              .OR.(ID.GE.401.AND.ID.LE.424)) Q=Q/3.
        QS=QS-Q
        DM=DM-RMASS(ID)
      ENDIF
  10  CONTINUE
C print any warnings
      IF (NPRODS(L).EQ.0) THEN
        WRITE(6,20) L,RNAME(IDKY),(RNAME(IDKPRD(I,L)),I=1,5)
        IFAULT=IFAULT+1
      ELSE
        IF (ABS(QS).GT.EPS) THEN
          WRITE(6,40) L,RNAME(IDKY),(RNAME(IDKPRD(I,L)),I=1,5),QS
          IFAULT=IFAULT+1
        ENDIF
        IF (DM.LT.ZERO) THEN
          WRITE(6,50) L,RNAME(IDKY),(RNAME(IDKPRD(I,L)),I=1,5),DM
          IFAULT=IFAULT+1
        ENDIF
      ENDIF
  20  FORMAT(1X,'Line ',I4,' decay: ',A8,' --> ',4(A8,1X),A8/
     &       1X,'contains no or unrecognised decay product(s)')
  30  FORMAT(1X,'Line ',I4,' decay: ',A8,' --> ',4(A8,1X),A8/
     &       1X,'contains decay product ',A8,' which is vetoed')
  40  FORMAT(1X,'Line ',I4,' decay: ',A8,' --> ',4(A8,1X),A8/
     &       1X,'violates charge conservation, Qin-Qout= ',F6.3)
  50  FORMAT(1X,'Line ',I4,' decay: ',A8,' --> ',4(A8,1X),A8/
     &       1X,'is kinematically not allowed, Min-Mout= ',F10.3)
      IF (IFAULT.NE.0) THEN
        RETURN 1
      ELSE
        RETURN
      ENDIF
      END
CDECK  ID>, HWDCLE.
*CMZ :-        -28/01/92  12.34.44  by  Mike Seymour
*-- Author :    Luca Stanco
C-----------------------------------------------------------------------
      SUBROUTINE HWDCLE(IHEP)
C-----------------------------------------------------------------------
C INTERFACE TO QQ-CLEO MONTE CARLO (LS 11/12/91)
C-----------------------------------------------------------------------
      INCLUDE 'HERWIG62.INC'
      INTEGER IHEP,IIHEP,NHEPHF,QQLMAT
      LOGICAL QQLERR
      CHARACTER*8 NAME
      EXTERNAL QQLMAT
C---QQ-CLEO COMMON'S
C***                 MCPARS.INC
      INTEGER MCTRK, NTRKS, MCVRTX, NVTXS, MCHANS, MCDTRS, MPOLQQ
      INTEGER MCNUM, MCSTBL, MCSTAB, MCTLQQ, MDECQQ
      INTEGER MHLPRB, MHLLST, MHLANG, MCPLST, MFDECA
      PARAMETER (MCTRK = 512)
      PARAMETER (NTRKS = MCTRK)
      PARAMETER (MCVRTX = 256)
      PARAMETER (NVTXS = MCVRTX)
      PARAMETER (MCHANS = 4000)
      PARAMETER (MCDTRS = 8000)
      PARAMETER (MPOLQQ = 300)
      PARAMETER (MCNUM = 500)
      PARAMETER (MCSTBL = 40)
      PARAMETER (MCSTAB = 512)
      PARAMETER (MCTLQQ = 100)
      PARAMETER (MDECQQ = 300)
      PARAMETER (MHLPRB = 500)
      PARAMETER (MHLLST = 1000)
      PARAMETER (MHLANG = 500)
      PARAMETER (MCPLST = 200)
      PARAMETER (MFDECA = 5)
C***                 MCPROP.INC
      REAL AMASS, CHARGE, CTAU, SPIN, RWIDTH, RMASMN, RMASMX
      REAL RMIXPP, RCPMIX
      INTEGER NPMNQQ, NPMXQQ, IDMC, INVMC, LPARTY, CPARTY
      INTEGER IMIXPP, ICPMIX
      COMMON/MCMAS1/
     *       NPMNQQ, NPMXQQ,
     *       AMASS(-20:MCNUM), CHARGE(-20:MCNUM), CTAU(-20:MCNUM),
     *       IDMC(-20:MCNUM), SPIN(-20:MCNUM),
     *       RWIDTH(-20:MCNUM), RMASMN(-20:MCNUM), RMASMX(-20:MCNUM),
     *       LPARTY(-20:MCNUM), CPARTY(-20:MCNUM),
     *       IMIXPP(-20:MCNUM), RMIXPP(-20:MCNUM),
     *       ICPMIX(-20:MCNUM), RCPMIX(-20:MCNUM),
     *       INVMC(0:MCSTBL)
C
      INTEGER NPOLQQ, IPOLQQ
      COMMON/MCPOL1/
     *       NPOLQQ, IPOLQQ(5,MPOLQQ)
C
      CHARACTER QNAME*10, PNAME*10
      COMMON/MCNAMS/
     *       QNAME(37), PNAME(-20:MCNUM)
C
C***                 MCCOMS.INC
      INTEGER NCTLQQ, NDECQQ, IVRSQQ, IORGQQ, IRS1QQ
      INTEGER IEVTQQ, IRUNQQ, IBMRAD
      INTEGER NTRKMC, QQNTRK, NSTBMC, NSTBQQ, NCHGMC, NCHGQQ
      INTEGER IRANQQ, IRANMC, IRANCC, IRS2QQ
      INTEGER IPFTQQ, IPCDQQ, IPRNTV, ITYPEV, IDECSV, IDAUTV
      INTEGER ISTBMC, NDAUTV
      INTEGER IVPROD, IVDECA
      REAL BFLDQQ
      REAL ENERQQ, BEAMQQ, BMPSQQ, BMNGQQ, EWIDQQ, BWPSQQ, BWNGQQ
      REAL BPOSQQ, BSIZQQ
      REAL ECM, P4CMQQ, P4PHQQ, ENERNW, BEAMNW, BEAMP, BEAMN
      REAL PSAV, P4QQ, HELCQQ
      CHARACTER DATEQQ*20, TIMEQQ*20, FOUTQQ*80, FCTLQQ*80, FDECQQ*80
      CHARACTER FGEOQQ*80
      CHARACTER CCTLQQ*80, CDECQQ*80
C
      COMMON/MCCM1A/
     *   NCTLQQ, NDECQQ, IVRSQQ, IORGQQ, IRS1QQ(3), BFLDQQ,
     *   ENERQQ, BEAMQQ, BMPSQQ, BMNGQQ, EWIDQQ, BWPSQQ, BWNGQQ,
     *   BPOSQQ(3), BSIZQQ(3),
     *   IEVTQQ, IRUNQQ,
     *   IBMRAD, ECM, P4CMQQ(4), P4PHQQ(4),
     *   ENERNW, BEAMNW, BEAMP, BEAMN,
     *   NTRKMC, QQNTRK, NSTBMC, NSTBQQ, NCHGMC, NCHGQQ,
     *   IRANQQ(2), IRANMC(2), IRANCC(2), IRS2QQ(5),
     *   IPFTQQ(MCTRK), IPCDQQ(MCTRK), IPRNTV(MCTRK), ITYPEV(MCTRK,2),
     *   IDECSV(MCTRK), IDAUTV(MCTRK), ISTBMC(MCTRK), NDAUTV(MCTRK),
     *   IVPROD(MCTRK), IVDECA(MCTRK),
     *   PSAV(MCTRK,4), HELCQQ(MCTRK), P4QQ(4,MCTRK)
C
      COMMON/MCCM1B/
     *   DATEQQ, TIMEQQ, FOUTQQ, FCTLQQ, FDECQQ, FGEOQQ,
     *   CCTLQQ(MCTLQQ), CDECQQ(MDECQQ)
      INTEGER IDSTBL
      COMMON/MCCM1C/
     *   IDSTBL(MCSTAB)
C
      INTEGER IFINAL(MCTRK), IFINSV(MCSTAB), NFINAL
      EQUIVALENCE (IFINAL,ISTBMC), (IFINSV,IDSTBL), (NFINAL,NSTBMC)
C
      INTEGER NVRTX, ITRKIN, NTRKOU, ITRKOU, IVKODE
      REAL XVTX, TVTX, RVTX
      COMMON/MCCM2/
     *   NVRTX, XVTX(MCVRTX,3), TVTX(MCVRTX), RVTX(MCVRTX),
     *   ITRKIN(MCVRTX), NTRKOU(MCVRTX), ITRKOU(MCVRTX),
     *   IVKODE(MCVRTX)
C***                 MCGEN.INC
      INTEGER QQIST,QQIFR,QQN,QQK,QQMESO,QQNC,QQKC,QQLASTN
      REAL QQPUD,QQPS1,QQSIGM,QQMAS,QQPAR,QQCMIX,QQCND,QQBSPI,QQBSYM,QQP
      REAL QQPC,QQCZF
C
      COMMON/DATA1/QQIST,QQIFR,QQPUD,QQPS1,QQSIGM,QQMAS(15),QQPAR(25)
      COMMON/DATA2/QQCZF(15),QQMESO(36),QQCMIX(6,2)
      COMMON/DATA3/QQCND(3)
      COMMON/DATA5/QQBSPI(5),QQBSYM(3)
      COMMON/JET/QQN,QQK(250,2),QQP(250,5),QQNC,QQKC(10),QQPC(10,4),
     *  QQLASTN
C---
      IF(FSTEVT) THEN
C---INITIALIZE QQ-CLEO
        CALL QQINIT(QQLERR)
        IF(QQLERR) CALL HWWARN('HWDEUR',500,*999)
      ENDIF
C---CONSTRUCT THE HADRON FOR QQ-CLEO
C NOTE: THE IDPDG CODE IS PROVIDED THROUGH THE QQLMAT ROUTINE
C       FROM THE CLEO PACKAGE (QQ-CLEO <--> IDPDG CODE TRANSFORMATION)
      QQN=1
      IDHEP(IHEP)=IDPDG(IDHW(IHEP))
      QQK(1,1)=0
      QQK(1,2)=QQLMAT(IDHEP(IHEP),1)
      QQP(1,1)=PHEP(1,IHEP)
      QQP(1,2)=PHEP(2,IHEP)
      QQP(1,3)=PHEP(3,IHEP)
      QQP(1,5)=AMASS(QQK(1,2))
      QQP(1,4)=SQRT(QQP(1,5)**2+QQP(1,1)**2+QQP(1,2)**2+QQP(1,3)**2)
C---LET QQ-CLEO DO THE JOB
      QQNTRK=0
      NVRTX=0
      CALL DECADD(.FALSE.)
C---UPDATE THE HERWIG TABLE : LOOP OVER QQN-CLEO FINAL PARTICLES
      DO 40 IIHEP=1,QQN
      NHEP=NHEP+1
      ISTHEP(NHEP)=198
      IF(ITYPEV(IIHEP,2).GE.0) ISTHEP(NHEP)=1
      IDHEP(NHEP)=QQLMAT(ITYPEV(IIHEP,1),2)
      CALL HWUIDT(1,IDHEP(NHEP),IDHW(NHEP),NAME)
      IF(IIHEP.EQ.1) THEN
        ISTHEP(IHEP)=199
        JDAHEP(1,IHEP)=NHEP
        JDAHEP(2,IHEP)=NHEP
        ISTHEP(NHEP)=199
        NHEPHF=NHEP
        JMOHEP(1,NHEP)=IHEP
        JMOHEP(2,NHEP)=IHEP
      ELSE
        JMOHEP(1,NHEP)=IPRNTV(IIHEP)+NHEPHF-1
        JMOHEP(2,NHEP)=NHEPHF
      ENDIF
      JDAHEP(1,NHEP)=0
      JDAHEP(2,NHEP)=0
      IF(NDAUTV(IIHEP).GT.0) THEN
        JDAHEP(1,NHEP)=IDAUTV(IIHEP)+NHEPHF-1
        JDAHEP(2,NHEP)=JDAHEP(1,NHEP)+NDAUTV(IIHEP)-1
      ENDIF
      PHEP(1,NHEP)=QQP(IIHEP,1)
      PHEP(2,NHEP)=QQP(IIHEP,2)
      PHEP(3,NHEP)=QQP(IIHEP,3)
      PHEP(4,NHEP)=QQP(IIHEP,4)
      PHEP(5,NHEP)=QQP(IIHEP,5)
      VHEP(1,NHEP)=XVTX(IVPROD(IIHEP),1)
      VHEP(2,NHEP)=XVTX(IVPROD(IIHEP),2)
      VHEP(3,NHEP)=XVTX(IVPROD(IIHEP),3)
      VHEP(4,NHEP)=0.
   40 CONTINUE
  999 END
CDECK  ID>, HWDEUR.
*CMZ :-        -28/01/92  12.34.44  by  Mike Seymour
*-- Author :    Luca Stanco
C-----------------------------------------------------------------------
      SUBROUTINE HWDEUR(IHEP)
C-----------------------------------------------------------------------
C INTERFACE TO EURODEC PACKAGE (LS 10/29/91)
C-----------------------------------------------------------------------
      INCLUDE 'HERWIG62.INC'
      INTEGER IHEP,IIHEP,NHEPHF,IEUPDG,IPDGEU
      CHARACTER*8 NAME
C---EURODEC COMMON'S : INITIAL INPUT
      INTEGER EULUN0,EULUN1,EULUN2,EURUN,EUEVNT
      CHARACTER*4 EUDATD,EUTIT
      REAL AMINIE(12),EUWEI
      COMMON/INPOUT/EULUN0,EULUN1,EULUN2
      COMMON/FILNAM/EUDATD,EUTIT
      COMMON/HVYINI/AMINIE
      COMMON/RUNINF/EURUN,EUEVNT,EUWEI
C---EURODEC WORKING COMMON'S
      INTEGER NPMAX,NTMAX
      PARAMETER (NPMAX=18,NTMAX=2000)
      INTEGER EUNP,EUIP(NPMAX),EUPHEL(NPMAX),EUTEIL,EUINDX(NTMAX),
     &    EUORIG(NTMAX),EUDCAY(NTMAX),EUTHEL(NTMAX)
      REAL EUAPM(NPMAX),EUPCM(5,NPMAX),EUPVTX(3,NPMAX),EUPTEI(5,NTMAX),
     &    EUSECV(3,NTMAX)
      COMMON/MOMGEN/EUNP,EUIP,EUAPM,EUPCM,EUPHEL,EUPVTX
      COMMON/RESULT/EUTEIL,EUPTEI,EUINDX,EUORIG,EUDCAY,EUTHEL,EUSECV
C---EURODEC COMMON'S FOR DECAY PROPERTIES
      INTEGER NGMAX,NCMAX
      PARAMETER (NGMAX=400,NCMAX=9000)
      INTEGER EUNPA,EUIPC(NGMAX),EUIPDG(NGMAX),EUIDP(NGMAX),
     &     EUCONV(NCMAX)
      REAL EUPM(NGMAX),EUPLT(NGMAX)
      COMMON/PCTABL/EUNPA,EUIPC,EUIPDG,EUPM,EUPLT,EUIDP
      COMMON/CONVRT/EUCONV
C---
      IF(FSTEVT) THEN
C---CHANGE HERE THE DEFAULT VALUES OF EURODEC COMMON'S
C
C---INITIALIZE EURODEC COMMON'S
CC        CALL EUDCIN
C---INITIALIZE EURODEC
        CALL EUDINI
      ENDIF
C---CONSTRUCT THE HADRON FOR EURODEC FROM ID1,ID2
      EUNP=1
      IDHEP(IHEP)=IDPDG(IDHW(IHEP))
      EUIP(1)=IPDGEU(IDHEP(IHEP))
      EUAPM(1)=EUPM(EUCONV(IABS(EUIP(1))))
      EUPCM(1,1)=PHEP(1,IHEP)
      EUPCM(2,1)=PHEP(2,IHEP)
      EUPCM(3,1)=PHEP(3,IHEP)
      EUPCM(5,1)=SQRT(PHEP(1,IHEP)**2+PHEP(2,IHEP)**2+PHEP(3,IHEP)**2)
      EUPCM(4,1)=SQRT(EUPCM(5,1)**2+EUAPM(1)**2)
C NOT POLARIZED HADRONS
      EUPHEL(1)=0
C HADRONS START FROM PRIMARY VERTEX
      EUPVTX(1,1)=0.
      EUPVTX(2,1)=0.
      EUPVTX(3,1)=0.
C---LET EURODEC DO THE JOB
      EUTEIL=0
      CALL FRAGMT(1,1,0)
C---UPDATE THE HERWIG TABLE : LOOP OVER N-EURODEC FINAL PARTICLES
      DO 40 IIHEP=1,EUTEIL
      NHEP=NHEP+1
      ISTHEP(NHEP)=198
      IF(EUDCAY(IIHEP).EQ.0) ISTHEP(NHEP)=1
      IDHEP(NHEP)=IEUPDG(EUINDX(IIHEP))
      CALL HWUIDT(1,IDHEP(NHEP),IDHW(NHEP),NAME)
      IF(IIHEP.EQ.1) THEN
        ISTHEP(IHEP)=199
        JDAHEP(1,IHEP)=NHEP
        JDAHEP(2,IHEP)=NHEP
        ISTHEP(NHEP)=199
        NHEPHF=NHEP
        JMOHEP(1,NHEP)=IHEP
        JMOHEP(2,NHEP)=IHEP
        JDAHEP(1,NHEP)=EUDCAY(IIHEP)/10000+NHEPHF-1
        JDAHEP(2,NHEP)=MOD(EUDCAY(IIHEP),10000)+NHEPHF-1
      ELSE
        JMOHEP(1,NHEP)=MOD(EUORIG(IIHEP),10000)+NHEPHF-1
        JMOHEP(2,NHEP)=NHEPHF
        JDAHEP(1,NHEP)=EUDCAY(IIHEP)/10000+NHEPHF-1
        JDAHEP(2,NHEP)=MOD(EUDCAY(IIHEP),10000)+NHEPHF-1
      ENDIF
      PHEP(1,NHEP)=EUPTEI(1,IIHEP)
      PHEP(2,NHEP)=EUPTEI(2,IIHEP)
      PHEP(3,NHEP)=EUPTEI(3,IIHEP)
      PHEP(4,NHEP)=EUPTEI(4,IIHEP)
      PHEP(5,NHEP)=EUPTEI(5,IIHEP)
      VHEP(1,NHEP)=EUSECV(1,IIHEP)
      VHEP(2,NHEP)=EUSECV(2,IIHEP)
      VHEP(3,NHEP)=EUSECV(3,IIHEP)
      VHEP(4,NHEP)=0.
      IF (IIHEP.GT.NTMAX) CALL HWWARN('HWDEUR',99,*999)
   40 CONTINUE
  999 END
CDECK  ID>, HWDFOR.
*CMZ :-        -01/04/99  19.52.44  by  Mike Seymour
*-- Author :    Ian Knowles
C-----------------------------------------------------------------------
      SUBROUTINE HWDFOR(P0,P1,P2,P3,P4)
C-----------------------------------------------------------------------
C     Generates 4-body decay 0->1+2+3+4 using pure phase space
C-----------------------------------------------------------------------
      IMPLICIT NONE
      DOUBLE PRECISION HWRGEN,P0(5),P1(5),P2(5),P3(5),P4(5),B,C,AA,BB,
     & CC,DD,EE,TT,S1,RS1,FF,S2,PP,QQ,RR,P1CM,P234(5),P2CM,P34(5),P3CM
      DOUBLE PRECISION TWO
      PARAMETER (TWO=2.D0)
      EXTERNAL HWRGEN
      B=P0(5)-P1(5)
      C=P2(5)+P3(5)+P4(5)
      IF (B.LT.C) CALL HWWARN('HWDFOR',100,*999)
      AA=(P0(5)+P1(5))**2
      BB=B**2
      CC=C**2
      DD=(P3(5)+P4(5))**2
      EE=(P3(5)-P4(5))**2
      TT=(B-C)*P0(5)**7/16
C Select squared masses S1 and S2 of 234 and 34 subsystems
  10  S1=BB+HWRGEN(1)*(CC-BB)
      RS1=SQRT(S1)
      FF=(RS1-P2(5))**2
      S2=DD+HWRGEN(2)*(FF-DD)
      PP=(AA-S1)*(BB-S1)
      QQ=((RS1+P2(5))**2-S2)*(FF-S2)/S1
      RR=(S2-DD)*(S2-EE)/S2
      IF (PP*QQ*RR*(FF-DD)**2.LT.TT*S1*S2*HWRGEN(3)**2) GOTO 10
C Do two body decays: 0-->1+234, 234-->2+34 and 34-->3+4
      P1CM=SQRT(PP/4)/P0(5)
      P234(5)=RS1
      P2CM=SQRT(QQ/4)
      P34(5)=SQRT(S2)
      P3CM=SQRT(RR/4)
      CALL HWDTWO(P0  ,P1,P234,P1CM,TWO,.TRUE.)
      CALL HWDTWO(P234,P2,P34 ,P2CM,TWO,.TRUE.)
      CALL HWDTWO(P34 ,P3,P4  ,P3CM,TWO,.TRUE.)
  999 END
CDECK  ID>, HWDFIV.
*CMZ :-        -01/04/99  19.52.44  by  Mike Seymour
*-- Author :    Ian Knowles
C-----------------------------------------------------------------------
      SUBROUTINE HWDFIV(P0,P1,P2,P3,P4,P5)
C-----------------------------------------------------------------------
C     Generates 5-body decay 0->1+2+3+4+5 using pure phase space
C-----------------------------------------------------------------------
      IMPLICIT NONE
      DOUBLE PRECISION HWRGEN,P0(5),P1(5),P2(5),P3(5),P4(5),P5(5),B,C,
     & AA,BB,CC,DD,EE,FF,TT,S1,RS1,GG,S2,RS2,HH,S3,PP,QQ,RR,SS,P1CM,
     & P2345(5),P2CM,P345(5),P3CM,P45(5),P4CM
      DOUBLE PRECISION TWO
      PARAMETER (TWO=2.D0)
      EXTERNAL HWRGEN
      B=P0(5)-P1(5)
      C=P2(5)+P3(5)+P4(5)+P5(5)
      IF (B.LT.C) CALL HWWARN('HWDFIV',100,*999)
      AA=(P0(5)+P1(5))**2
      BB=B**2
      CC=C**2
      DD=(P3(5)+P4(5)+P5(5))**2
      EE=(P4(5)+P5(5))**2
      FF=(P4(5)-P5(5))**2
      TT=(B-C)*P0(5)**11/729
C Select squared masses S1, S2 and S3 of 2345, 345 and 45 subsystems
  10  S1=BB+HWRGEN(1)*(CC-BB)
      RS1=SQRT(S1)
      GG=(RS1-P2(5))**2
      S2=DD+HWRGEN(2)*(GG-DD)
      RS2=SQRT(S2)
      HH=(RS2-P3(5))**2
      S3=EE+HWRGEN(3)*(HH-EE)
      PP=(AA-S1)*(BB-S1)
      QQ=((RS1+P2(5))**2-S2)*(GG-S2)/S1
      RR=((RS2+P3(5))**2-S3)*(HH-S3)/S2
      SS=(S3-EE)*(S3-FF)/S3
      IF (PP*QQ*RR*SS*((GG-DD)*(HH-EE))**2.LT.TT*S1*S2*S3*HWRGEN(4)**2)
     & GOTO 10
C Do two body decays: 0-->1+2345, 2345-->2+345, 345-->3+45 and 45-->4+5
      P1CM=SQRT(PP/4)/P0(5)
      P2345(5)=RS1
      P2CM=SQRT(QQ/4)
      P345(5)=RS2
      P3CM=SQRT(RR/4)
      P45(5)=SQRT(S3)
      P4CM=SQRT(SS/4)
      CALL HWDTWO(P0   ,P1,P2345,P1CM,TWO,.TRUE.)
      CALL HWDTWO(P2345,P2,P345 ,P2CM,TWO,.TRUE.)
      CALL HWDTWO(P345 ,P3,P45  ,P3CM,TWO,.TRUE.)
      CALL HWDTWO(P45  ,P4,P5   ,P4CM,TWO,.TRUE.)
  999 END
CDECK  ID>, HWDHAD.
*CMZ :-        -26/04/91  14.01.26  by  Federico Carminati
*-- Author :    Ian Knowles, Bryan Webber & Mike Seymour
C-----------------------------------------------------------------------
      SUBROUTINE HWDHAD
C-----------------------------------------------------------------------
C     GENERATES DECAYS OF UNSTABLE HADRONS AND LEPTONS
C-----------------------------------------------------------------------
      INCLUDE 'HERWIG62.INC'
      DOUBLE PRECISION HWRGEN,HWULDO,RN,BF,COSANG,RSUM,DIST(4),VERTX(4),
     & PMIX,WTMX,WTMX2,XS,DOT1,DOT2,HWDPWT,HWDWWT,XXX,YYY
      INTEGER IHEP,ID,MHEP,IDM,I,IDS,IM,MO,IPDG
      LOGICAL STABLE
      EXTERNAL HWRGEN,HWDPWT,HWDWWT,HWULDO
      IF (IERROR.NE.0) RETURN
      DO 100 IHEP=1,NMXHEP
      IF (IHEP.GT.NHEP) THEN
        ISTAT=90
        RETURN
      ELSEIF (ISTHEP(IHEP).EQ.120 .AND.
     &  JDAHEP(1,IHEP).EQ.IHEP.AND.JDAHEP(2,IHEP).EQ.IHEP) THEN
C---COPY COLOUR SINGLET CMF
        NHEP=NHEP+1
        IF (NHEP.GT.NMXHEP) CALL HWWARN('HWDHAD',100,*999)
        CALL HWVEQU(5,PHEP(1,IHEP),PHEP(1,NHEP))
        CALL HWVEQU(4,VHEP(1,IHEP),VHEP(1,NHEP))
        IDHW(NHEP)=IDHW(IHEP)
        IDHEP(NHEP)=IDHEP(IHEP)
        ISTHEP(NHEP)=190
        JMOHEP(1,NHEP)=IHEP
        JMOHEP(2,NHEP)=NHEP
        JDAHEP(2,NHEP)=NHEP
        JDAHEP(1,IHEP)=NHEP
        JDAHEP(2,IHEP)=NHEP
      ELSEIF (ISTHEP(IHEP).GE.190.AND.ISTHEP(IHEP).LE.193) THEN
C---FIRST CHECK FOR STABILITY
        ID=IDHW(IHEP)
        IF (RSTAB(ID)) THEN
          ISTHEP(IHEP)=1
          JDAHEP(1,IHEP)=0
          JDAHEP(2,IHEP)=0
C---SPECIAL FOR GAUGE BOSON DECAY
          IF (ID.GE.198.AND.ID.LE.200) CALL HWDBOS(IHEP)
C---SPECIAL FOR HIGGS BOSON DECAY
          IF (ID.EQ.201) CALL HWDHIG(ZERO)
        ELSE
C---UNSTABLE.
C Calculate position of decay vertex
          IF (DKLTM(ID).EQ.ZERO) THEN
            CALL HWVEQU(4,VHEP(1,IHEP),VERTX)
            MHEP=IHEP
            IDM=ID
          ELSE
            CALL HWUDKL(ID,PHEP(1,IHEP),DIST)
            CALL HWVSUM(4,VHEP(1,IHEP),DIST,VERTX)
            IF (MAXDKL) THEN
              CALL HWDXLM(VERTX,STABLE)
              IF (STABLE) THEN
                ISTHEP(IHEP)=1
                JDAHEP(1,IHEP)=0
                JDAHEP(2,IHEP)=0
                GOTO 100
              ENDIF
            ENDIF
            IF (MIXING.AND.(ID.EQ.221.OR.ID.EQ.223.OR.
     &                      ID.EQ.245.OR.ID.EQ.247)) THEN
C Select flavour of decaying b-meson allowing for flavour oscillation
              IDS=MOD(ID,3)
              XXX=XMRCT(IDS)*DIST(4)/PHEP(4,IHEP)
              YYY=YMRCT(IDS)*DIST(4)/PHEP(4,IHEP)
              IF (ABS(YYY).LT.10) THEN
                PMIX=HALF*(ONE-COS(XXX)/COSH(YYY))
              ELSE
                PMIX=HALF
              ENDIF
              IF (HWRGEN(1).LE.PMIX) THEN
                IF (ID.LE.223) THEN
                  IDM=ID+24
                ELSE
                  IDM=ID-24
                ENDIF
              ELSE
                IDM=ID
              ENDIF
C Introduce a decaying neutral b-meson
              IF (NHEP+1.GT.NMXHEP) CALL HWWARN('HWDHAD',101,*999)
              MHEP=NHEP+1
              ISTHEP(MHEP)=ISTHEP(IHEP)
              ISTHEP(IHEP)=200
              JDAHEP(1,IHEP)=MHEP
              JDAHEP(2,IHEP)=MHEP
              IDHW(MHEP)=IDM
              IDHEP(MHEP)=IDPDG(IDM)
              JMOHEP(1,MHEP)=IHEP
              JMOHEP(2,MHEP)=JMOHEP(2,IHEP)
              CALL HWVEQU(5,PHEP(1,IHEP),PHEP(1,MHEP))
              CALL HWVEQU(4,VERTX,VHEP(1,MHEP))
              NHEP=NHEP+1
            ELSE
              MHEP=IHEP
              IDM=ID
            ENDIF
          ENDIF
C Use CLEO/EURODEC packages for b-hadrons if requested
          IF ((IDM.GE.221.AND.IDM.LE.231).OR.
     &        (IDM.GE.245.AND.IDM.LE.254)) THEN
            IF (BDECAY.EQ.'CLEO') THEN
              CALL HWDCLE(MHEP)
              GOTO 100
            ELSEIF (BDECAY.EQ.'EURO') THEN
              CALL HWDEUR(MHEP)
              GOTO 100
            ENDIF
          ENDIF
C Choose decay mode
          ISTHEP(MHEP)=ISTHEP(MHEP)+5
          RN=HWRGEN(2)
          BF=0.
          IM=LSTRT(IDM)
          DO 10 I=1,NMODES(IDM)
          BF=BF+BRFRAC(IM)
          IF (BF.GE.RN) GOTO 20
  10      IM=LNEXT(IM)
          CALL HWWARN('HWDHAD',50,*20)
  20      IF ((IDKPRD(1,IM).GE.1.AND.IDKPRD(1,IM).LE.13).OR.
     &        (IDKPRD(3,IM).GE.1.AND.IDKPRD(3,IM).LE.13)) THEN
C Partonic decay of a heavy-(b,c)-hadron, store details
            NQDK=NQDK+1
            IF (NQDK.GT.NMXQDK) CALL HWWARN('HWDHAD',102,*999)
            LOCQ(NQDK)=MHEP
            IMQDK(NQDK)=IM
            CALL HWVEQU(4,VERTX,VTXQDK(1,NQDK))
            GOTO 100
          ELSE
C Exclusive decay, add decay products to event record
            IF (NHEP+NPRODS(IM).GT.NMXHEP)
     &        CALL HWWARN('HWDHAD',103,*999)
            JDAHEP(1,MHEP)=NHEP+1
            DO 30 I=1,NPRODS(IM)
            NHEP=NHEP+1
            IDHW(NHEP)=IDKPRD(I,IM)
            IDHEP(NHEP)=IDPDG(IDKPRD(I,IM))
            ISTHEP(NHEP)=193
            JMOHEP(1,NHEP)=MHEP
            JMOHEP(2,NHEP)=JMOHEP(2,MHEP)
            PHEP(5,NHEP)=RMASS(IDKPRD(I,IM))
  30        CALL HWVEQU(4,VERTX,VHEP(1,NHEP))
            JDAHEP(2,MHEP)=NHEP
          ENDIF
C Next choose momenta:
          IF (NPRODS(IM).EQ.1) THEN
C 1-body decay: K0(BR) --> K0S,K0L
            CALL HWVEQU(4,PHEP(1,MHEP),PHEP(1,NHEP))
          ELSEIF (NPRODS(IM).EQ.2) THEN
C 2-body decay
C---SPECIAL TREATMENT OF POLARIZED MESONS
            COSANG=TWO
            IF (ID.EQ.IDHW(JMOHEP(1,MHEP))) THEN
              MO=JMOHEP(1,MHEP)
              RSUM=0
              DO 40 I=1,3
  40          RSUM=RSUM+RHOHEP(I,MO)
              IF (RSUM.GT.ZERO) THEN
                RSUM=RSUM*HWRGEN(3)
                IF (RSUM.LT.RHOHEP(1,MO)) THEN
C---(1+COSANG)**2
                  COSANG=MAX(HWRGEN(4),HWRGEN(5),HWRGEN(6))*TWO-ONE
                ELSEIF (RSUM.LT.RHOHEP(1,MO)+RHOHEP(2,MO)) THEN
C---1-COSANG**2
                  COSANG=2*COS((ACOS(HWRGEN(7)*TWO-ONE)+PIFAC)/THREE)
                ELSE
C---(1-COSANG)**2
                  COSANG=MIN(HWRGEN(8),HWRGEN(9),HWRGEN(10))*TWO-ONE
                ENDIF
              ENDIF
            ENDIF
            CALL HWDTWO(PHEP(1,MHEP),PHEP(1,NHEP-1),
     &                  PHEP(1,NHEP),CMMOM(IM),COSANG,.FALSE.)
          ELSEIF (NPRODS(IM).EQ.3) THEN
C 3-body decay
            IF (NME(IM).EQ.100) THEN
C  Use free massless (V-A)*(V-A) Matrix Element
              CALL HWDTHR(PHEP(1,MHEP),PHEP(1,NHEP-1),PHEP(1,NHEP-2),
     &                    PHEP(1,NHEP),HWDWWT)
            ELSEIF (NME(IM).EQ.101) THEN
C  Use bound massless (V-A)*(V-A) Matrix Element
              WTMX=((PHEP(5,MHEP)-PHEP(5,NHEP))
     &             *(PHEP(5,MHEP)+PHEP(5,NHEP))
     &             +(PHEP(5,NHEP-1)-PHEP(5,NHEP-2))
     &             *(PHEP(5,NHEP-1)+PHEP(5,NHEP-2)))/TWO
              WTMX2=WTMX**2
              IPDG=ABS(IDHEP(MHEP))
              XS=ONE-MAX(RMASS(MOD(IPDG/1000,10)),
     &                   RMASS(MOD(IPDG/100,10)),RMASS(MOD(IPDG/10,10)))
     &              /(RMASS(MOD(IPDG/1000,10))+RMASS(MOD(IPDG/100,10))
     &               +RMASS(MOD(IPDG/10,10)))
  50          CALL HWDTHR(PHEP(1,MHEP),PHEP(1,NHEP-1),PHEP(1,NHEP-2),
     &                    PHEP(1,NHEP),HWDWWT)
              DOT1=HWULDO(PHEP(1,MHEP),PHEP(1,NHEP-1))
              DOT2=HWULDO(PHEP(1,MHEP),PHEP(1,NHEP-2))
              IF (DOT1*(WTMX-DOT1-XS*DOT2).LT.HWRGEN(11)*WTMX2) GOTO 50
            ELSE
              CALL HWDTHR(PHEP(1,MHEP),PHEP(1,NHEP-2),PHEP(1,NHEP-1),
     &                    PHEP(1,NHEP),HWDPWT)
            ENDIF
          ELSEIF (NPRODS(IM).EQ.4) THEN
C 4-body decay
            CALL HWDFOR(PHEP(1,MHEP  ),PHEP(1,NHEP-3),PHEP(1,NHEP-2),
     &                  PHEP(1,NHEP-1),PHEP(1,NHEP))
          ELSEIF (NPRODS(IM).EQ.5) THEN
C 5-body decay
            CALL HWDFIV(PHEP(1,MHEP  ),PHEP(1,NHEP-4),PHEP(1,NHEP-3),
     &                  PHEP(1,NHEP-2),PHEP(1,NHEP-1),PHEP(1,NHEP))
          ELSE
            CALL HWWARN('HWDHAD',104,*999)
          ENDIF
        ENDIF
      ENDIF
  100 CONTINUE
C---MAY HAVE OVERFLOWED /HEPEVT/
      CALL HWWARN('HWDHAD',105,*999)
  999 END
CDECK  ID>, HWDHGC.
*CMZ :-        -26/04/91  11.11.55  by  Bryan Webber
*-- Author :    Mike Seymour
C-----------------------------------------------------------------------
      SUBROUTINE HWDHGC(TAU,FNREAL,FNIMAG)
C-----------------------------------------------------------------------
C  CALCULATE THE COMPLEX FUNCTION F OF HHG eq 2.18
C  FOR USE IN H-->GAMMGAMM DECAYS
C-----------------------------------------------------------------------
      INCLUDE 'HERWIG62.INC'
      DOUBLE PRECISION TAU,FNREAL,FNIMAG,FNLOG,FNSQR
      IF (TAU.GT.ONE) THEN
        FNREAL=(ASIN(1/SQRT(TAU)))**2
        FNIMAG=0
      ELSEIF (TAU.LT.ONE) THEN
        FNSQR=SQRT(1-TAU)
        FNLOG=LOG((1+FNSQR)/(1-FNSQR))
        FNREAL=-0.25 * (FNLOG**2 - PIFAC**2)
        FNIMAG= 0.5  * PIFAC*FNLOG
      ELSE
        FNREAL=0.25*PIFAC**2
        FNIMAG=0
      ENDIF
      END
CDECK  ID>, HWDHGF.
*CMZ :-        -02/05/91  11.11.45  by  Federico Carminati
*-- Author :    Mike Seymour
C-----------------------------------------------------------------------
      FUNCTION HWDHGF(X,Y)
C-----------------------------------------------------------------------
C  CALCULATE THE DOUBLE BREIT-WIGNER INTEGRAL
C  X=(EMV/EMH)**2 , Y=EMV*GAMV/EMH**2
C-----------------------------------------------------------------------
      INCLUDE 'HERWIG62.INC'
      DOUBLE PRECISION HWDHGF,X,Y,CHANGE,X1,X2,FAC1,FAC2,TH1,TH2,TH1HI,
     & TH1LO,TH2HI,TH2LO,X2MAX,SQFAC
      INTEGER NBIN,IBIN1,IBIN2
C  CHANGE IS THE POINT WHERE DIRECT INTEGRATION BEGINS TO CONVERGE
C  FASTER THAN STANDARD BREIT-WIGNER SUBSTITUTION
      DATA CHANGE,NBIN/0.425,25/
      HWDHGF=0
      IF (Y.LT.ZERO) RETURN
      IF (X.GT.CHANGE) THEN
C---DIRECT INTEGRATION
        FAC1=0.25 / NBIN
        DO 200 IBIN1=1,NBIN
          X1=(IBIN1-0.5) * FAC1
          FAC2=( (1-SQRT(X1))**2-X1 ) / NBIN
          DO 100 IBIN2=1,NBIN
            X2=(IBIN2-0.5) * FAC2 + X1
            SQFAC=1+X1**2+X2**2-2*(X1+X2+X1*X2)
            IF (SQFAC.LT.ZERO) GOTO 100
            HWDHGF=HWDHGF + 2.
     &        * ((1-X1-X2)**2+8*X1*X2)
     &        * SQRT(SQFAC)
     &        / ((X1-X)**2+Y**2) *Y
     &        / ((X2-X)**2+Y**2) *Y
     &        * FAC1*FAC2
 100      CONTINUE
 200    CONTINUE
      ELSE
C---INTEGRATION USING TAN THETA SUBSTITUTIONS
        TH1LO=ATAN((0-X)/Y)
        TH1HI=ATAN((1-X)/Y)
        FAC1=(TH1HI-TH1LO) / NBIN
        DO 400 IBIN1=1,NBIN
          TH1=(IBIN1-0.5) * FAC1 + TH1LO
          X1=Y*TAN(TH1) + X
          X2MAX=MIN(X1,(1-SQRT(X1))**2)
          TH2LO=ATAN((0-X)/Y)
          TH2HI=ATAN((X2MAX-X)/Y)
          FAC2=(TH2HI-TH2LO) / NBIN
          DO 300 IBIN2=1,NBIN
            TH2=(IBIN2-0.5) * FAC2 + TH2LO
            X2=Y*TAN(TH2) + X
            SQFAC=1+X1**2+X2**2-2*(X1+X2+X1*X2)
            IF (SQFAC.LT.ZERO) GOTO 300
            HWDHGF=HWDHGF + 2.
     &        * ((1-X1-X2)**2+8*X1*X2)
     &        * SQRT(SQFAC)
     &        * FAC1 * FAC2
 300      CONTINUE
 400    CONTINUE
      ENDIF
      HWDHGF=HWDHGF/(PIFAC*PIFAC)
      END
CDECK  ID>, HWDHIG.
*CMZ :-        -24/04/92  14.23.44  by  Mike Seymour
*-- Author :    Mike Seymour
C-----------------------------------------------------------------------
      SUBROUTINE HWDHIG(GAMINP)
C-----------------------------------------------------------------------
C     HIGGS DECAY ROUTINE
C     A) FOR GAMinp=0 FIND AND DECAY HIGGS
C     B) FOR GAMinp>0 CALCULATE TOTAL HIGGS WIDTH
C                     FOR EMH=GAMINP. STORE RESULT IN GAMINP.
C-----------------------------------------------------------------------
      INCLUDE 'HERWIG62.INC'
      DOUBLE PRECISION HWDHGF,HWRGEN,HWRUNI,HWUSQR,HWUPCM,GAMINP,EMH,
     & EMF,COLFAC,ENF,K1,K0,BET0,BET1,GAM0,GAM1,SCLOG,CFAC,XF,EM,GAMLIM,
     & GAM,XW,EMW,XZ,EMZ,YW,YZ,EMI,TAUT,TAUW,WIDHIG,VECDEC,EMB,GAMB,
     & TMIN,TMAX1,EM1,TMAX2,EM2,X1,X2,PROB,PCM,SUMR,SUMI,TAUTR,TAUTI,
     & TAUWR,TAUWI,GFACTR
      INTEGER HWRINT,IHIG,I,IFERM,NLOOK,I1,I2,IPART,IMODE,IDEC,MMAX
      LOGICAL HWRLOG
      EXTERNAL HWDHGF,HWRGEN,HWRUNI,HWUSQR,HWUPCM,HWRINT,HWRLOG
      SAVE GAM,EM,VECDEC
      PARAMETER (NLOOK=100)
      DIMENSION VECDEC(2,0:NLOOK)
      EQUIVALENCE (EMW,RMASS(198)),(EMZ,RMASS(200))
      DATA GAMLIM,GAM,EM/10D0,2*0D0/
C---IF DECAY, FIND HIGGS (HWDHAD WILL HAVE GIVEN IT STATUS=1)
      IF (GAMINP.EQ.ZERO) THEN
        IHIG=0
        DO 10 I=1,NHEP
 10       IF (IHIG.EQ.0.AND.IDHW(I).EQ.201.AND.ISTHEP(I).EQ.1) IHIG=I
        IF (IHIG.EQ.0) CALL HWWARN('HWDHIG',101,*999)
        EMH=PHEP(5,IHIG)
        IF (EMH.LE.ZERO) CALL HWWARN('HWDHIG',102,*999)
        EMSCA=EMH
      ELSE
        EMH=GAMINP
        IF (EMH.LE.ZERO) THEN
          GAMINP=0
          RETURN
        ENDIF
      ENDIF
C---CALCULATE BRANCHING FRACTIONS
C---FERMIONS
C---NLL CORRECTION TO QUARK DECAY RATE (HHG eq 2.6-9)
      ENF=0
      DO 1 I=1,6
 1      IF (2*RMASS(I).LT.EMH) ENF=ENF+1
      K1=5/PIFAC**2
      K0=3/(4*PIFAC**2)
      BET0=(11*CAFAC-2*ENF)/3
      BET1=(34*CAFAC**2-(10*CAFAC+6*CFFAC)*ENF)/3
      GAM0=-8
      GAM1=-404./3+40*ENF/9
      SCLOG=LOG(EMH**2/QCDLAM**2)
      CFAC=1 + ( K1/K0 - 2*GAM0 + GAM0*BET1/BET0**2*LOG(SCLOG)
     &       +   (GAM0*BET1-GAM1*BET0)/BET0**2) / (BET0*SCLOG)
      DO 100 IFERM=1,9
        IF (IFERM.LE.6) THEN
          EMF=RMASS(IFERM)
          XF=(EMF/EMH)**2
          COLFAC=FLOAT(NCOLO)
          IF (EMF.GT.QCDLAM)
     &      EMF=EMF*(LOG(EMH/QCDLAM)/LOG(EMF/QCDLAM))**(GAM0/(2*BET0))
        ELSE
          EMF=RMASS(107+IFERM*2)
          XF=(EMF/EMH)**2
          COLFAC=1
          CFAC=1
        ENDIF
        IF (FOUR*XF.LT.ONE) THEN
        GFACTR=ALPHEM/(8.*SWEIN*EMW**2)
          BRHIG(IFERM)=COLFAC*GFACTR*EMH*EMF**2 * (1-4*XF)**1.5 * CFAC
        ELSE
          BRHIG(IFERM)=0
        ENDIF
 100  CONTINUE
C---W*W*/Z*Z*
      IF (ABS(EM-EMH).GE.GAMLIM*GAM) THEN
C---OFF EDGE OF LOOK-UP TABLE
        XW=(EMW/EMH)**2
        XZ=(EMZ/EMH)**2
        YW=EMW*GAMW/EMH**2
        YZ=EMZ*GAMZ/EMH**2
        BRHIG(10)=.50*GFACTR * EMH**3 * HWDHGF(XW,YW)
        BRHIG(11)=.25*GFACTR * EMH**3 * HWDHGF(XZ,YZ)
      ELSE
C---LOOK IT UP
        EMI=((EMH-EM)/(GAM*GAMLIM)+1)*NLOOK/2.0
        I1=INT(EMI)
        I2=INT(EMI+1)
        BRHIG(10)=.50*GFACTR * EMH**3 * ( VECDEC(1,I1)*(I2-EMI) +
     &                                    VECDEC(1,I2)*(EMI-I1) )
        BRHIG(11)=.25*GFACTR * EMH**3 * ( VECDEC(2,I1)*(I2-EMI) +
     &                                    VECDEC(2,I2)*(EMI-I1) )
      ENDIF
C---GAMMAGAMMA
      TAUT=(2*RMASS(6)/EMH)**2
      TAUW=(2*EMW/EMH)**2
      CALL HWDHGC(TAUT,TAUTR,TAUTI)
      CALL HWDHGC(TAUW,TAUWR,TAUWI)
      SUMR=4./3*(  - 2*TAUT*( 1 + (1-TAUT)*TAUTR ) ) * ENHANC(6)
     &         +(2 + 3*TAUW*( 1 + (2-TAUW)*TAUWR ) ) * ENHANC(10)
      SUMI=4./3*(  - 2*TAUT*(     (1-TAUT)*TAUTI ) ) * ENHANC(6)
     &         +(    3*TAUW*(     (2-TAUW)*TAUWI ) ) * ENHANC(10)
      BRHIG(12)=GFACTR*.03125*(ALPHEM/PIFAC)**2
     &         *EMH**3 * (SUMR**2 + SUMI**2)
      WIDHIG=0
      DO 200 IPART=1, 12
        IF (IPART.LT.12) BRHIG(IPART)=BRHIG(IPART)*ENHANC(IPART)**2
 200    WIDHIG=WIDHIG+BRHIG(IPART)
      IF (WIDHIG.EQ.ZERO) CALL HWWARN('HWDHIG',103,*999)
      DO 300 IPART=1, 12
 300    BRHIG(IPART)=BRHIG(IPART)/WIDHIG
      IF (EM.NE.RMASS(201)) THEN
C---SET UP W*W*/Z*Z* LOOKUP TABLES
        EM=EMH
        GAM=WIDHIG
        GAMLIM=MAX(GAMLIM,GAMMAX)
        DO 400 I=0,NLOOK
          EMH=(I*2.0/NLOOK-1)*GAM*GAMLIM+EM
          XW=(EMW/EMH)**2
          XZ=(EMZ/EMH)**2
          YW=EMW*GAMW/EMH**2
          YZ=EMZ*GAMZ/EMH**2
          VECDEC(1,I)=HWDHGF(XW,YW)
          VECDEC(2,I)=HWDHGF(XZ,YZ)
 400    CONTINUE
        EMH=EM
      ENDIF
      IF (GAMINP.GT.ZERO) THEN
        GAMINP=WIDHIG
        RETURN
      ENDIF
C---SEE IF USER SPECIFIED A DECAY MODE
      IMODE=MOD(IPROC,100)
C---IF NOT, CHOOSE ONE
      IF (IMODE.LT.1.OR.IMODE.GT.12) THEN
        MMAX=12
        IF (IMODE.LT.1) MMAX=6
 500    IMODE=HWRINT(1,MMAX)
        IF (BRHIG(IMODE).LT.HWRGEN(0)) GOTO 500
      ENDIF
C---SEE IF SPECIFIED DECAY IS POSSIBLE
      IF (BRHIG(IMODE).EQ.ZERO) CALL HWWARN('HWDHIG',104,*999)
      IF (IMODE.LE.6) THEN
        IDEC=IMODE
      ELSEIF (IMODE.LE.9) THEN
        IDEC=107+IMODE*2
      ELSEIF (IMODE.EQ.10) THEN
        IDEC=198
      ELSEIF (IMODE.EQ.11) THEN
        IDEC=200
      ELSEIF (IMODE.EQ.12) THEN
        IDEC=59
      ENDIF
C---STATUS, IDs AND POINTERS
      ISTHEP(IHIG)=195
      DO 600 I=1,2
        ISTHEP(NHEP+I)=193
        IDHW(NHEP+I)=IDEC
        IDHEP(NHEP+I)=IDPDG(IDEC)
        JDAHEP(I,IHIG)=NHEP+I
        JMOHEP(1,NHEP+I)=IHIG
        JMOHEP(2,NHEP+I)=NHEP+(3-I)
        JDAHEP(2,NHEP+I)=NHEP+(3-I)
        PHEP(5,NHEP+I)=RMASS(IDEC)
        IDEC=IDEC+6
        IF (IDEC.EQ.204) IDEC=199
        IF (IDEC.EQ.206) IDEC=200
        IF (IDEC.EQ. 65) IDEC= 59
 600  CONTINUE
C---ALLOW W/Z TO BE OFF-SHELL
      IF (IMODE.EQ.10.OR.IMODE.EQ.11) THEN
        IF (IMODE.EQ.10) THEN
          EMB=EMW
          GAMB=GAMW
        ELSE
          EMB=EMZ
          GAMB=GAMZ
        ENDIF
C---STANDARD MASS DISTRIBUTION
 700    TMIN=ATAN(-EMB/GAMB)
        TMAX1=ATAN((EMH**2/EMB-EMB)/GAMB)
        EM1=HWUSQR(EMB*(GAMB*TAN(HWRUNI(0,TMIN,TMAX1))+EMB))
        TMAX2=ATAN(((EMH-EM1)**2/EMB-EMB)/GAMB)
        EM2=HWUSQR(EMB*(GAMB*TAN(HWRUNI(0,TMIN,TMAX2))+EMB))
        X1=(EM1/EMH)**2
        X2=(EM2/EMH)**2
C---CORRECT MASS DISTRIBUTION
        PROB=HWUSQR(1+X1**2+X2**2-2*X1-2*X2-2*X1*X2)
     &        * ((X1+X2-1)**2 + 8*X1*X2)
        IF (.NOT.HWRLOG(PROB)) GOTO 700
C---CALCULATE SPIN DENSITY MATRIX
        RHOHEP(1,NHEP+1)=4*X1*X2      / (8*X1*X2 + (X1+X2-1)**2)
        RHOHEP(2,NHEP+1)=(X1+X2-1)**2 / (8*X1*X2 + (X1+X2-1)**2)
        RHOHEP(3,NHEP+1)=RHOHEP(1,NHEP+1)
C---SYMMETRIZE DISTRIBUTIONS IN PARTICLES 1,2
        IF (HWRLOG(HALF)) THEN
          PHEP(5,NHEP+1)=EM1
          PHEP(5,NHEP+2)=EM2
        ELSE
          PHEP(5,NHEP+1)=EM2
          PHEP(5,NHEP+2)=EM1
        ENDIF
      ENDIF
C---DO DECAY
      PCM=HWUPCM(EMH,PHEP(5,NHEP+1),PHEP(5,NHEP+2))
      IF (PCM.LT.ZERO) CALL HWWARN('HWDHIG',105,*999)
      CALL HWDTWO(PHEP(1,IHIG),PHEP(1,NHEP+1),PHEP(1,NHEP+2),
     &            PCM,TWO,.TRUE.)
      NHEP=NHEP+2
C---IF QUARK DECAY, HADRONIZE
      IF (IMODE.LE.6) THEN
        ISTHEP(NHEP-1)=113
        ISTHEP(NHEP)=114
        CALL HWBGEN
        CALL HWDHOB
        CALL HWCFOR
        CALL HWCDEC
      ENDIF
  999 END
CDECK  ID>, HWDHOB.
*CMZ :-        -20/10/99  09:46:43  by  Peter Richardson
*-- Author :    Ian Knowles & Bryan Webber
C-----------------------------------------------------------------------
      SUBROUTINE HWDHOB
C-----------------------------------------------------------------------
C   Performs decays of heavy objects (heavy quarks & SUSY particles)
C   MODIFIED TO INCLUDE R-PARITY VIOLATING SUSY PR 9/4/99
C-----------------------------------------------------------------------
      INCLUDE 'HERWIG62.INC'
      DOUBLE PRECISION HWUMBW,HWUPCM,HWRGEN,SDKM,RN,BF,PCM,
     & EMMX,EMWSQ,GMWSQ,EMLIM,PW(5),EMTST,HWDPWT,HWDWWT,HWULDO,PDW(5,3)
      INTEGER IST(3),IHEP,IS,ID,IM,I,JHEP,KHEP,LHEP,MHEP,NPR,ISM,JCM,
     & MTRY,NTRY,IDM,IDM2,THEP,CLSAVE(2),WHEP,RHEP
      LOGICAL FOUND
      EXTERNAL HWRGEN,HWDPWT,HWDWWT
      DATA IST/113,114,114/
      IF (IERROR.NE.0) RETURN
  10  FOUND=.FALSE.
      CLSAVE(1) = 0
      CLSAVE(2) = 0
      DO 60 IHEP=1,NMXHEP
      IS=ISTHEP(IHEP)
      ID=IDHW(IHEP)
      IF (.NOT.RSTAB(ID).AND.(ID.EQ.6.OR.ID.EQ.12.OR.
     & (ID.GE.203.AND.ID.LE.218).OR.ABS(IDPDG(ID)).GT.1000000).AND.
     & (IS.EQ.190.OR.(IS.GE.147.AND.IS.LE.151))) THEN
        FOUND=.TRUE.
        IF(.NOT.RPARTY) THEN
          NHEP = NHEP+1
          ISTHEP(NHEP) = 3
          IDHW(NHEP) = 20
          IDHEP(NHEP) = 0
          CALL HWVEQU(5,PHEP(1,IHEP),PHEP(1,NHEP))
          CALL HWVEQU(4,VHEP(1,IHEP),VHEP(1,NHEP))
          JMOHEP(1,NHEP)=JMOHEP(1,IHEP)
          JMOHEP(2,NHEP)=JMOHEP(2,IHEP)
          JDAHEP(1,NHEP)=JDAHEP(1,IHEP)
          JDAHEP(2,NHEP)=JDAHEP(2,IHEP)
        ENDIF
C Make a copy of decaying object
        NHEP=NHEP+1
        ISTHEP(NHEP)=155
        IDHW(NHEP)=IDHW(IHEP)
        IDHEP(NHEP)=IDHEP(IHEP)
        CALL HWVEQU(5,PHEP(1,IHEP),PHEP(1,NHEP))
        CALL HWVEQU(4,VHEP(1,IHEP),VHEP(1,NHEP))
        JMOHEP(1,NHEP)=JMOHEP(1,IHEP)
        JMOHEP(2,NHEP)=JMOHEP(2,IHEP)
        MTRY=0
 15     MTRY=MTRY+1
C Select decay mode
        RN=HWRGEN(0)
        BF=0.
        IM=LSTRT(ID)
        DO 20 I=1,NMODES(ID)
        BF=BF+BRFRAC(IM)
        IF (BF.GE.RN) GOTO 30
  20    IM=LNEXT(IM)
        CALL HWWARN('HWDHOB',50,*30)
  30    IF (NHEP+5.GT.NMXHEP) CALL HWWARN('HWDHOB',100,*999)
        NPR=NPRODS(IM)
        JDAHEP(1,NHEP)=NHEP+1
        JDAHEP(2,NHEP)=NHEP+NPR
C Reset colour pointers (if set)
        JHEP=JMOHEP(2,IHEP)
        IF (JHEP.GT.0) THEN
          IF (JDAHEP(2,JHEP).EQ.IHEP) JDAHEP(2,JHEP)=NHEP
          IF(.NOT.RPARTY.AND.ISTHEP(JHEP).EQ.155
     &    .AND.ABS(IDHEP(JHEP)).GT.1000000
     &    .AND.JDAHEP(2,JHEP-1).EQ.IHEP) JDAHEP(2,JHEP-1) = NHEP
        ENDIF
        JHEP=JDAHEP(2,IHEP)
        IF (JHEP.GT.0) THEN
          IF (JMOHEP(2,JHEP).EQ.IHEP) JMOHEP(2,JHEP)=NHEP
          IF(.NOT.RPARTY.AND.ISTHEP(JHEP).EQ.155
     &    .AND.ABS(IDHEP(JHEP)).GT.1000000
     &    .AND.JMOHEP(2,JHEP-1).EQ.IHEP) JMOHEP(2,JHEP-1) = NHEP
        ENDIF
C--Reset colour pointers if baryon number violated
        IF(.NOT.RPARTY) THEN
          DO JHEP=1,NHEP
            IF(ISTHEP(JHEP).EQ.155
     &         .AND.ABS(IDHEP(JHEP)).GT.1000000.AND.
     &         JDAHEP(2,JHEP-1).EQ.IHEP) JDAHEP(2,JHEP-1)= NHEP
            IF(JDAHEP(2,JHEP).EQ.IHEP) JDAHEP(2,JHEP)=NHEP
            IF(JMOHEP(2,JHEP).EQ.IHEP) JMOHEP(2,JHEP)=NHEP
          ENDDO
          IF(HRDCOL(1,1).EQ.IHEP) HRDCOL(1,1)=NHEP
        ENDIF
C Relabel original track
        ISTHEP(IHEP)=3
        JMOHEP(2,IHEP)=JMOHEP(1,IHEP)
        JDAHEP(1,IHEP)=NHEP
        JDAHEP(2,IHEP)=NHEP
C Label decay products and choose masses
        LHEP=NHEP
        MHEP=LHEP+1
        NTRY=0
 35     NTRY=NTRY+1
        SDKM=PHEP(5,NHEP)
        DO 40 I=1,NPR
        NHEP=NHEP+1
        IDHW(NHEP)=IDKPRD(I,IM)
        IDHEP(NHEP)=IDPDG(IDKPRD(I,IM))
        ISTHEP(NHEP)=IST(I)
        JMOHEP(1,NHEP)=LHEP
        JDAHEP(1,NHEP)=0
        PHEP(5,NHEP)=HWUMBW(IDKPRD(I,IM))
 40     SDKM=SDKM-PHEP(5,NHEP)
        IF (SDKM.LT.ZERO) THEN
          NHEP=NHEP-NPR
          IF (NTRY.LE.NETRY) GO TO 35
          CALL HWWARN('HWDHOB',1,*45)
 45       IF (MTRY.LE.NETRY) GO TO 15
          CALL HWWARN('HWDHOB',101,*999)
        ENDIF
C Assign production vertices to decay products
        CALL HWUDKL(ID,PHEP(1,IHEP),VHEP(1,MHEP))
        CALL HWVSUM(4,VHEP(1,IHEP),VHEP(1,MHEP),VHEP(1,MHEP))
        CALL HWVEQU(4,VHEP(1,MHEP),VHEP(1,NHEP))
        IF (NPR.EQ.2) THEN
C Two body decay: LHEP -> MHEP + NHEP
          PCM=HWUPCM(PHEP(5,IHEP),PHEP(5,MHEP),PHEP(5,NHEP))
          CALL HWDTWO(PHEP(1,IHEP),PHEP(1,MHEP),
     &                PHEP(1,NHEP),PCM,TWO,.FALSE.)
        ELSEIF (NPR.EQ.3) THEN
C Three body decay: LHEP -> KHEP + MHEP + NHEP
          KHEP=MHEP
          MHEP=MHEP+1
C Provisional colour self-connection of KHEP
          JMOHEP(2,KHEP)=KHEP
          JDAHEP(2,KHEP)=KHEP
          IF (NME(IM).EQ.100) THEN
C Generate decay momenta using full (V-A)*(V-A) matrix element
            EMMX=PHEP(5,IHEP)-PHEP(5,NHEP)
            EMWSQ=RMASS(198)**2
            GMWSQ=(RMASS(198)*GAMW)**2
            EMLIM=GMWSQ
            IF (EMMX.LT.RMASS(198)) EMLIM=EMLIM+(EMWSQ-EMMX**2)**2
  50        CALL HWDTHR(PHEP(1,IHEP),PHEP(1,MHEP),
     &                  PHEP(1,KHEP),PHEP(1,NHEP),HWDWWT)
            CALL HWVSUM(4,PHEP(1,KHEP),PHEP(1,MHEP),PW)
            PW(5)=HWULDO(PW,PW)
            EMTST=(EMWSQ-PW(5))**2
            IF ((EMTST+GMWSQ)*HWRGEN(1).GT.EMLIM) GOTO 50
            PW(5)=SQRT(PW(5))
C Assign production vertices to 1 and 2
            CALL HWUDKL(198,PW,VHEP(1,KHEP))
            CALL HWVSUM(4,VHEP(1,NHEP),VHEP(1,KHEP),VHEP(1,KHEP))
          ELSEIF(NME(IM).EQ.300) THEN
C Generate momenta using 3-body RPV matrix element
            CALL HWDRME(LHEP,KHEP)
          ELSE
C Three body phase space decay
            CALL HWDTHR(PHEP(1,IHEP),PHEP(1,MHEP),
     &                  PHEP(1,KHEP),PHEP(1,NHEP),HWDPWT)
          ENDIF
          CALL HWVEQU(4,VHEP(1,KHEP),VHEP(1,MHEP))
        ELSEIF(NPR.EQ.4) THEN
C Four body decay: LHEP -> KHEP + RHEP + MHEP + NHEP
          KHEP = MHEP
          RHEP = MHEP+1
          MHEP = MHEP+2
C Provisional colour connections of KHEP and RHEP
          JMOHEP(2,KHEP)=RHEP
          JDAHEP(2,KHEP)=RHEP
          JMOHEP(2,RHEP)=KHEP
          JDAHEP(2,RHEP)=KHEP
C Four body phase space decay
          CALL HWDFOR(PHEP(1,IHEP),PHEP(1,KHEP),PHEP(1,RHEP),
     &                  PHEP(1,MHEP),PHEP(1,NHEP))
          CALL HWVEQU(4,VHEP(1,KHEP),VHEP(1,RHEP))
          CALL HWVEQU(4,VHEP(1,KHEP),VHEP(1,MHEP))
        ELSE
          CALL HWWARN('HWDHOB',102,*999)
        ENDIF
C Colour connections
        IF (ID.EQ.6.OR.ID.EQ.12.OR.(ID.GE.209.AND.ID.LE.212)
     &                         .OR.(ID.GE.215.AND.ID.LE.218)) THEN
          IF (NPR.EQ.3.AND.NME(IM).EQ.100) THEN
C usual heavy quark decay
            JMOHEP(2,KHEP)=MHEP
            JDAHEP(2,KHEP)=MHEP
            JMOHEP(2,MHEP)=KHEP
            JDAHEP(2,MHEP)=KHEP
            JMOHEP(2,NHEP)=LHEP
            JDAHEP(2,NHEP)=LHEP
          ELSEIF (ABS(IDHEP(MHEP)).EQ.37) THEN
C heavy quark to charged Higgs
            JMOHEP(2,MHEP)=MHEP
            JDAHEP(2,MHEP)=MHEP
            JMOHEP(2,NHEP)=LHEP
            JDAHEP(2,NHEP)=LHEP
          ELSEIF (ABS(IDHEP(NHEP)).EQ.37) THEN
            JMOHEP(2,MHEP)=LHEP
            JDAHEP(2,MHEP)=LHEP
            JMOHEP(2,NHEP)=NHEP
            JDAHEP(2,NHEP)=NHEP
          ELSE
            CALL HWWARN('HWDHOB',103,*999)
          ENDIF
        ELSE
          IF(.NOT.RPARTY.AND.
     &       ((NPR.EQ.2.AND.ID.GE.401.AND.ID.LT.448.AND.
     &           IDHW(MHEP).LE.132.AND.IDHW(NHEP).LE.132)
     &       .OR.(NPR.EQ.3.AND.ID.GE.449.AND.ID.LE.457.AND.
     &           IDHW(MHEP).LE.132.AND.IDHW(NHEP).LE.132.AND.
     &           IDHW(MHEP-1).LE.132))) THEN
C R-parity violating SUSY decays
            IF(NPR.EQ.2) THEN
C--Rparity slepton colour connections
              IF(ID.GE.425.AND.ID.LE.448) THEN
                IF(IDHW(MHEP).GT.12) THEN
                  JMOHEP(2,MHEP) = MHEP
                  JDAHEP(2,MHEP) = MHEP
                  JMOHEP(2,NHEP) = NHEP
                  JDAHEP(2,NHEP) = NHEP
                ELSE
                  JMOHEP(2,MHEP) = NHEP
                  JDAHEP(2,MHEP) = NHEP
                  JMOHEP(2,NHEP) = MHEP
                  JDAHEP(2,NHEP) = MHEP
                ENDIF
C--Rparity squark colour connections
              ELSE
                IF(IDHEP(LHEP).GT.0) THEN
C--LQD decay colour connections
                  IF(IDHW(MHEP).GT.12) THEN
                    JMOHEP(2,MHEP) = MHEP
                    JDAHEP(2,MHEP) = MHEP
                    JMOHEP(2,NHEP) = LHEP
                    JDAHEP(2,NHEP) = LHEP
                  ELSE
C--UDD decay colour connections
                    HVFCEN = .TRUE.
                    CALL HWDRCL(LHEP,MHEP,CLSAVE)
                  ENDIF
                ELSE
C--Antisquark connections
                  IF(IDHW(MHEP).GT.12) THEN
                    JMOHEP(2,MHEP) = MHEP
                    JDAHEP(2,MHEP) = MHEP
                    JMOHEP(2,NHEP) = LHEP
                   JDAHEP(2,NHEP) = LHEP
                  ELSE
                    HVFCEN = .TRUE.
                   CALL HWDRCL(LHEP,MHEP,CLSAVE)
                  ENDIF
                ENDIF
              ENDIF
            ELSE
              IF(ID.GE.450.AND.ID.LE.457) THEN
C--Rparity Neutralino/Chargino colour connection
                IF(IDHW(MHEP-1).LE.12.AND.IDHW(MHEP).LE.12.
     &                 AND.IDHW(NHEP).LE.12) THEN
                  HVFCEN = .TRUE.
                  CALL HWDRCL(LHEP,MHEP,CLSAVE)
                ELSE
                  JMOHEP(2,MHEP) = NHEP
                  JDAHEP(2,MHEP) = NHEP
                  JMOHEP(2,NHEP) = MHEP
                  JDAHEP(2,NHEP) = MHEP
                ENDIF
C--Rparity gluino colour connections
              ELSEIF(ID.EQ.449) THEN
                IF(IDHW(MHEP-1).LE.12.AND.IDHW(MHEP).LE.12.
     &                 AND.IDHW(NHEP).LE.12) THEN
                  HVFCEN = .TRUE.
                  CALL HWDRCL(LHEP,MHEP,CLSAVE)
C--Now the lepton number violating decay
                ELSE
                  IF(IDHW(MHEP).LE.6) THEN
                    JMOHEP(2,MHEP) = LHEP
                    JDAHEP(2,MHEP) = NHEP
                    JMOHEP(2,NHEP) = MHEP
                    JDAHEP(2,NHEP) = LHEP
                  ELSE
                    JMOHEP(2,MHEP) = NHEP
                    JDAHEP(2,MHEP) = LHEP
                    JMOHEP(2,NHEP) = LHEP
                    JDAHEP(2,NHEP) = MHEP
                  ENDIF
                ENDIF
              ELSE
                CALL HWWARN('HWDHOB',104,*999)
              ENDIF
            ENDIF
          ELSE
C Normal SUSY decays
            IF (ID.LE.448.AND.ID.GT.207) THEN
C Squark (or slepton)
              IF (IDHW(MHEP).EQ.449) THEN
                IF (IDHEP(LHEP).GT.0) THEN
                  JMOHEP(2,MHEP)=LHEP
                  JDAHEP(2,MHEP)=NHEP
                  JMOHEP(2,NHEP)=MHEP
                  JDAHEP(2,NHEP)=LHEP
                ELSE
                  JMOHEP(2,MHEP)=NHEP
                  JDAHEP(2,MHEP)=LHEP
                  JMOHEP(2,NHEP)=LHEP
                  JDAHEP(2,NHEP)=MHEP
                ENDIF
              ELSE
                IF(NPR.EQ.3.AND.IDHW(MHEP).LE.12) THEN
                  JMOHEP(2,MHEP)=NHEP
                  JDAHEP(2,MHEP)=NHEP
                  JMOHEP(2,NHEP)=MHEP
                  JDAHEP(2,NHEP)=MHEP
                ELSE
                  JMOHEP(2,MHEP)=MHEP
                  JDAHEP(2,MHEP)=MHEP
                  JMOHEP(2,NHEP)=LHEP
                  JDAHEP(2,NHEP)=LHEP
                ENDIF
              ENDIF
            ELSEIF (ID.EQ.449) THEN
C Gluino
              IF (IDHW(NHEP).EQ.13) THEN
                JMOHEP(2,MHEP)=MHEP
                JDAHEP(2,MHEP)=MHEP
                JMOHEP(2,NHEP)=LHEP
                JDAHEP(2,NHEP)=LHEP
              ELSEIF (IDHEP(MHEP).GT.0) THEN
                JMOHEP(2,MHEP)=LHEP
                JDAHEP(2,MHEP)=NHEP
                JMOHEP(2,NHEP)=MHEP
                JDAHEP(2,NHEP)=LHEP
              ELSE
                JMOHEP(2,MHEP)=NHEP
                JDAHEP(2,MHEP)=LHEP
                JMOHEP(2,NHEP)=LHEP
                JDAHEP(2,NHEP)=MHEP
              ENDIF
            ELSE
C Gaugino or Higgs
              JMOHEP(2,MHEP)=NHEP
              JDAHEP(2,MHEP)=NHEP
              JMOHEP(2,NHEP)=MHEP
              JDAHEP(2,NHEP)=MHEP
            ENDIF
          ENDIF
        ENDIF
C---SPECIAL CASE FOR THREE-BODY TOP DECAYS:
C   RELABEL THEM AS TWO TWO-BODY DECAYS FOR PARTON SHOWERING
        IF ((ID.EQ.6.OR.ID.EQ.12).AND.NPR.EQ.3.AND.NME(IM).EQ.100) THEN
C---STORE W DECAY PRODUCTS
          CALL HWVEQU(10,PHEP(1,KHEP),PDW)
C---BOOST THEM INTO W REST FRAME
          CALL HWULOF(PW,PDW(1,1),PDW(1,3))
C---REPLACE THEM BY W
          CALL HWVEQU(5,PW,PHEP(1,KHEP))
          WHEP=KHEP
          IDHW(KHEP)=198
          IF (ID.EQ.12) IDHW(KHEP)=199
          IDHEP(KHEP)=IDPDG(IDHW(KHEP))
          JMOHEP(2,KHEP)=KHEP
          JDAHEP(2,KHEP)=KHEP
          CALL HWVEQU(4,VHEP(1,NHEP),VHEP(1,KHEP))
C---AND MOVE B UP
          CALL HWVEQU(5,PHEP(1,NHEP),PHEP(1,MHEP))
          IDHW(MHEP)=IDHW(NHEP)
          IDHEP(MHEP)=IDHEP(NHEP)
          JDAHEP(2,LHEP)=MHEP
          JMOHEP(2,MHEP)=JMOHEP(2,NHEP)
          JDAHEP(2,MHEP)=JDAHEP(2,NHEP)
          CALL HWVEQU(4,VHEP(1,NHEP),VHEP(1,MHEP))
          NHEP=MHEP
C---DO PARTON SHOWER
          EMSCA=PHEP(5,IHEP)
          CALL HWBGEN
          IF (IERROR.NE.0) RETURN
C---FIND BOOSTED W MOMENTUM
          NTRY=0
 41       NTRY=NTRY+1
          IF (NTRY.GT.NHEP.OR.WHEP.LE.0.OR.WHEP.GT.NHEP)
     $         CALL HWWARN('HWDHOB',101,*999)
          WHEP=JDAHEP(1,WHEP)
          IF (ISTHEP(WHEP).NE.190) GOTO 41
C---AND HENCE ITS CHILDRENS MOMENTA
          CALL HWULOB(PHEP(1,WHEP),PDW(1,3),PHEP(1,NHEP+1))
          CALL HWVDIF(4,PHEP(1,WHEP),PHEP(1,NHEP+1),PHEP(1,NHEP+2))
          PHEP(5,NHEP+2)=PDW(5,2)
C---LABEL THEM
          ISTHEP(WHEP)=195
          DO 51 I=1,2
            IDHW(NHEP+I)=IDKPRD(I,IM)
            IDHEP(NHEP+I)=IDPDG(IDHW(NHEP+I))
            ISTHEP(NHEP+I)=112+I
            JDAHEP(I,WHEP)=NHEP+I
            JMOHEP(1,NHEP+I)=WHEP
            JMOHEP(2,NHEP+I)=NHEP+3-I
            JDAHEP(2,NHEP+I)=NHEP+3-I
 51       CONTINUE
          NHEP=NHEP+2
C---ASSIGN PRODUCTION VERTICES TO 1 AND 2
          CALL HWUDKL(198,PW,VHEP(1,NHEP))
          CALL HWVSUM(4,VHEP(1,WHEP),VHEP(1,NHEP),VHEP(1,NHEP))
          CALL HWVEQU(4,VHEP(1,NHEP),VHEP(1,NHEP-1))
C---DO PARTON SHOWERS
          EMSCA=PW(5)
          CALL HWBGEN
          IF (IERROR.NE.0) RETURN
        ELSE
C Do parton showers
          EMSCA=PHEP(5,IHEP)
          CALL HWBGEN
          IF (IERROR.NE.0) RETURN
        ENDIF
      ENDIF
C--New to correct colour connections in Rslash
      IF(CLSAVE(1).NE.0) THEN
        THEP = MHEP+1
        ID   = IDHW(CLSAVE(1))
        IDM  = IDHW(JMOHEP(1,CLSAVE(1)))
        IDM2 = IDHW(LHEP)
        IF(IDM.EQ.15) ID=IDHW(JMOHEP(1,JMOHEP(1,CLSAVE(1))))
        IF((ID.LE.6.AND.((IDM.GE.419.AND.IDM.LE.424).OR.IDM.EQ.411.OR.
     &      IDM.EQ.412).
     &     AND.((IDM2.GE.413.AND.IDM2.LE.418)
     &     .OR.IDM2.EQ.449).OR.IDM2.EQ.405.OR.IDM2.EQ.406)
     &     .OR.(ID.LE.6.AND.IDM.EQ.449.AND.
     &    (((IDM2.GE.413.AND.IDM2.LE.418).OR.IDM2.EQ.405.OR.IDM2.EQ.406)
     &     .OR.IDM2.EQ.449)).OR.
     &    (IDM.EQ.15.AND.ID.LE.12.AND.ID.GE.7.AND.((IDM2.GE.413.AND.
     &     IDM2.LE.418).OR.IDM2.EQ.449.OR.IDM2.
     &     EQ.405.OR.IDM2.EQ.406))) THEN
          IF(JMOHEP(2,CLSAVE(1)).EQ.MHEP) THEN
            IF(IDHW(CLSAVE(1)).NE.13.AND.IDHW(CLSAVE(1)).NE.449)
     &                       JMOHEP(2,CLSAVE(2)) = THEP
            JDAHEP(2,MHEP) = CLSAVE(1)
            JDAHEP(2,THEP) = CLSAVE(2)
          ELSE
            IF(IDHW(CLSAVE(1)).NE.13.AND.IDHW(CLSAVE(1)).NE.449)
     &                       JMOHEP(2,CLSAVE(2)) = MHEP
            JDAHEP(2,MHEP) = CLSAVE(2)
            JDAHEP(2,THEP) = CLSAVE(1)
          ENDIF
        ELSEIF((ID.GT.6.AND.ID.LE.12.
     &     AND.((IDM.GE.413.AND.IDM.LE.418).OR.IDM.EQ.405.OR.
     &     IDM.EQ.406).AND.
     &      ((IDM2.GE.419.AND.IDM2.LE.424).OR.IDM2.EQ.449.OR.
     &      IDM2.EQ.411.OR.IDM2.EQ.412)).OR.
     &        (ID.GT.6.AND.ID.LE.12.AND.IDM.EQ.449.
     &   AND.((IDM2.GE.419.AND.IDM2.LE.424).OR.IDM2.EQ.449.OR.
     &       IDM2.EQ.411.OR.IDM2.EQ.412)).OR.
     &    (IDM.EQ.15.AND.ID.LE.6.AND.((IDM2.GE.419.AND.
     &     IDM2.LE.424).OR.IDM2.EQ.449.OR.IDM2.EQ.411.OR.
     &     IDM2.EQ.412))) THEN
          IF(JDAHEP(2,CLSAVE(1)).EQ.MHEP) THEN
            JDAHEP(2,CLSAVE(2))=THEP
            JMOHEP(2,MHEP)=CLSAVE(1)
            JMOHEP(2,THEP)=CLSAVE(2)
          ELSE
            JDAHEP(2,CLSAVE(2))=MHEP
            JMOHEP(2,MHEP)=CLSAVE(2)
            JMOHEP(2,THEP)=CLSAVE(1)
          ENDIF
        ENDIF
        COLUPD = .FALSE.
        CALL HWBCON
      ENDIF
      IF (IHEP.EQ.NHEP) GOTO 70
  60  CONTINUE
  70  IF (FOUND) THEN
C Fix any SUSY colour disconnections
        DO 80 IHEP=1,NHEP
          IF (ISTHEP(IHEP).GE.147.AND.ISTHEP(IHEP).LE.151
     &      .AND.JDAHEP(2,IHEP).EQ.0) THEN
            IM=JMOHEP(1,IHEP)
C Chase connection back through SUSY decays
  75        IM=JMOHEP(1,IM)
            ISM=ISTHEP(IM)
            IF (ISM.EQ.120) GOTO 80
            IF (ISM.NE.123.AND.ISM.NE.124.AND.ISM.NE.155) GOTO 75
C Look for unclustered parton to connect
            DO JHEP=1,NHEP
              IF (ISTHEP(JHEP).GE.147.AND.ISTHEP(JHEP).LE.151) THEN
                JCM=JMOHEP(2,JHEP)
                IF (JCM.EQ.IM) THEN
C Found it: connect
                  JMOHEP(2,JHEP)=IHEP
                  JDAHEP(2,IHEP)=JHEP
                  GOTO 80
                ENDIF
              ENDIF
            ENDDO
C Not found: need to go further back
            GOTO 75
          ENDIF
   80   CONTINUE
C Go back to check for further heavy decay products
        GOTO 10
      ENDIF
  999 END
CDECK  ID>, HWDHVY.
*CMZ :-        -26/04/91  12.19.24  by  Federico Carminati
*-- Author :    Ian Knowles & Bryan Webber
C-----------------------------------------------------------------------
      SUBROUTINE HWDHVY
C-----------------------------------------------------------------------
C     Performs partonic decays of hadrons containing heavy quark(s):
C     either, meson/baryon spectator model weak decays;
C     or, quarkonia -> 2-gluons, q-qbar, 3-gluons, or 2-gluons + photon.
C-----------------------------------------------------------------------
      INCLUDE 'HERWIG62.INC'
      DOUBLE PRECISION HWULDO,HWRGEN,XS,XB,EMWSQ,GMWSQ,EMLIM,PW(4),
     & EMTST,X1,X2,X3,TEST,HWDWWT,HWDPWT
      INTEGER IST(3),I,IHEP,IM,ID,IDQ,IQ,IS,J
      EXTERNAL HWRGEN,HWDWWT,HWDPWT,HWULDO
      DATA IST/113,114,114/
      IF (IERROR.NE.0) RETURN
      DO 100 I=1,NMXQDK
      IF (I.GT.NQDK) THEN
        NQDK=0
        RETURN
      ENDIF
      IHEP=LOCQ(I)
      IF (ISTHEP(IHEP).EQ.199) GOTO 100
      IM=IMQDK(I)
      IF (NHEP+NPRODS(IM).GT.NMXHEP) CALL HWWARN('HWDHVY',100,*999)
      IF (IDKPRD(4,IM).NE.0) THEN
C Weak decay of meson or baryon
C Idenitify decaying heavy quark and spectator
        ID=IDHW(IHEP)
        IF (ID.EQ.136.OR.ID.EQ.140.OR.ID.EQ.144.OR.
     &      ID.EQ.150.OR.ID.EQ.155.OR.ID.EQ.158.OR.ID.EQ.161.OR.
     &     (ID.EQ.254.AND.IDKPRD(4,IM).EQ.11)) THEN
C c hadron or c decay of B_c+
          IDQ=4
          IQ=NHEP+1
          IS=NHEP+2
        ELSEIF (ID.EQ.171.OR.ID.EQ.175.OR.ID.EQ.179.OR.
     &          ID.EQ.185.OR.ID.EQ.190.OR.ID.EQ.194.OR.ID.EQ.196.OR.
     &         (ID.EQ.230.AND.IDKPRD(4,IM).EQ.5)) THEN
C cbar hadron or cbar decay of B_c-
          IDQ=10
          IS=NHEP+1
          IQ=NHEP+2
        ELSEIF ((ID.GE.221.AND.ID.LE.229).OR.
     &          (ID.EQ.230.AND.IDKPRD(4,IM).EQ.10)) THEN
C b hadron or b decay of B_c-
          IDQ=5
          IQ=NHEP+1
          IS=NHEP+2
        ELSEIF ((ID.GE.245.AND.ID.LE.253).OR.
     &          (ID.EQ.254.AND.IDKPRD(4,IM).EQ.4)) THEN
C bbar hadron or bbar decay of B_c+
          IDQ=11
          IS=NHEP+1
          IQ=NHEP+2
        ELSE
C Decay not recognized
          CALL HWWARN('HWDHVY',101,*999)
        ENDIF
C Label constituents
        IF (NHEP+5.GT.NMXHEP) CALL HWWARN('HWDHVY',102,*999)
        ISTHEP(IHEP)=199
        JDAHEP(1,IHEP)=NHEP+1
        JDAHEP(2,IHEP)=NHEP+2
        IDHW(IQ)=IDQ
        IDHW(IS)=IDKPRD(4,IM)
        IDHEP(IQ)=IDPDG(IDQ)
        IDHEP(IS)=IDPDG(IDKPRD(4,IM))
        ISTHEP(IQ)=155
        ISTHEP(IS)=115
        JMOHEP(1,IQ)=IHEP
        JMOHEP(2,IQ)=IS
        JDAHEP(1,IQ)=NHEP+3
        JDAHEP(2,IQ)=NHEP+5
        JMOHEP(1,IS)=IHEP
        JMOHEP(2,IS)=NHEP+5
        JDAHEP(1,IS)=0
        JDAHEP(2,IS)=NHEP+5
        NHEP=NHEP+2
C and weak decay product jets
        DO 10 J=1,3
        NHEP=NHEP+1
        IDHW(NHEP)=IDKPRD(J,IM)
        IDHEP(NHEP)=IDPDG(IDKPRD(J,IM))
        ISTHEP(NHEP)=IST(J)
        JMOHEP(1,NHEP)=IQ
        JDAHEP(1,NHEP)=0
  10    PHEP(5,NHEP)=RMASS(IDKPRD(J,IM))
        JMOHEP(2,NHEP-2)=NHEP-1
        JDAHEP(2,NHEP-2)=NHEP-1
        JMOHEP(2,NHEP-1)=NHEP-2
        JDAHEP(2,NHEP-1)=NHEP-2
        JMOHEP(2,NHEP  )=IQ
        JDAHEP(2,NHEP  )=IQ
C Share momenta in ratio of masses, preserving specator mass
        XS=RMASS(IDHW(IS))/PHEP(5,IHEP)
        XB=ONE-XS
        CALL HWVSCA(5,XB,PHEP(1,IHEP),PHEP(1,IQ))
        CALL HWVSCA(5,XS,PHEP(1,IHEP),PHEP(1,IS))
        IF (NME(IM).EQ.100) THEN
C Generate decay momenta using full (V-A)*(V-A) matrix element
          EMWSQ=RMASS(198)**2
          GMWSQ=(RMASS(198)*GAMW)**2
          EMLIM=GMWSQ+(EMWSQ-(PHEP(5,IQ)-PHEP(5,NHEP))**2)**2
  20      CALL HWDTHR(PHEP(1,IQ  ),PHEP(1,NHEP-1),
     &                PHEP(1,NHEP-2),PHEP(1,NHEP),HWDWWT)
          CALL HWVSUM(4,PHEP(1,NHEP-2),PHEP(1,NHEP-1),PW)
          EMTST=(HWULDO(PW,PW)-EMWSQ)**2
          IF ((EMTST+GMWSQ)*HWRGEN(0).GT.EMLIM) GOTO 20
        ELSE
C Use phase space
          CALL HWDTHR(PHEP(1,IQ  ),PHEP(1,NHEP-2),
     &                PHEP(1,NHEP-1),PHEP(1,NHEP),HWDPWT)
          CALL HWVSUM(4,PHEP(1,NHEP-2),PHEP(1,NHEP-1),PW)
        ENDIF
C Set up production vertices
        CALL HWVZRO(4,VHEP(1,IQ))
        CALL HWVEQU(4,VHEP(1,IQ),VHEP(1,IS))
        CALL HWVEQU(4,VHEP(1,IQ),VHEP(1,NHEP))
        CALL HWUDKL(198,PW,VHEP(1,NHEP-2))
        CALL HWVSUM(4,VHEP(1,IQ),VHEP(1,NHEP-2),VHEP(1,NHEP-2))
        CALL HWVEQU(4,VHEP(1,NHEP-2),VHEP(1,NHEP-1))
        EMSCA=PHEP(5,IQ)
      ELSE
C Quarkonium decay
C Label products
        ISTHEP(IHEP)=199
        JDAHEP(1,IHEP)=NHEP+1
        DO 30 J=1,NPRODS(IM)
        NHEP=NHEP+1
        IDHW(NHEP)=IDKPRD(J,IM)
        IDHEP(NHEP)=IDPDG(IDKPRD(J,IM))
        ISTHEP(NHEP)=IST(J)
        JMOHEP(1,NHEP)=IHEP
        JDAHEP(1,NHEP)=0
        PHEP(5,NHEP)=RMASS(IDKPRD(J,IM))
  30    CALL HWVZRO(4,VHEP(1,NHEP))
        JDAHEP(2,IHEP)=NHEP
C Establish colour connections and select momentum configuration
        IF (NPRODS(IM).EQ.3) THEN
          IF (IDKPRD(3,IM).EQ.13) THEN
C 3-gluon decay
            JMOHEP(2,NHEP-2)=NHEP
            JMOHEP(2,NHEP-1)=NHEP-2
            JMOHEP(2,NHEP  )=NHEP-1
            JDAHEP(2,NHEP-2)=NHEP-1
            JDAHEP(2,NHEP-1)=NHEP
            JDAHEP(2,NHEP  )=NHEP-2
          ELSE
C or 2-gluon + photon decay
            JMOHEP(2,NHEP-2)=NHEP-1
            JMOHEP(2,NHEP-1)=NHEP-2
            JMOHEP(2,NHEP  )=NHEP
            JDAHEP(2,NHEP-2)=NHEP-1
            JDAHEP(2,NHEP-1)=NHEP-2
            JDAHEP(2,NHEP  )=NHEP
          ENDIF
          IF (NME(IM).EQ.130) THEN
C Use Ore & Powell orthopositronium matrix element
  40        CALL HWDTHR(PHEP(1,IHEP),PHEP(1,NHEP-2),
     &                               PHEP(1,NHEP-1),PHEP(1,NHEP),HWDPWT)
            X1=TWO*HWULDO(PHEP(1,IHEP),PHEP(1,NHEP-2))/PHEP(5,IHEP)**2
            X2=TWO*HWULDO(PHEP(1,IHEP),PHEP(1,NHEP-1))/PHEP(5,IHEP)**2
            X3=TWO-X1-X2
            TEST=((X1*(ONE-X1))**2+(X2*(ONE-X2))**2+(X3*(ONE-X3))**2)
     &          /(X1*X2*X3)**2
            IF (TEST.LT.TWO*HWRGEN(0)) GOTO 40
          ELSE
C Use phase space
            CALL HWDTHR(PHEP(1,IHEP),PHEP(1,NHEP-2),
     &                               PHEP(1,NHEP-1),PHEP(1,NHEP),HWDPWT)
          ENDIF
        ELSE
C Parapositronium 2-gluon or q-qbar decay
          JMOHEP(2,NHEP-1)=NHEP
          JMOHEP(2,NHEP  )=NHEP-1
          JDAHEP(2,NHEP-1)=NHEP
          JDAHEP(2,NHEP  )=NHEP-1
          CALL HWDTWO(PHEP(1,IHEP),PHEP(1,NHEP-1),
     &                             PHEP(1,NHEP),CMMOM(IM),TWO,.FALSE.)
        ENDIF
        EMSCA=PHEP(5,IHEP)
      ENDIF
C Process this new hard scatter
      CALL HWVEQU(4,VTXQDK(1,I),VTXPIP)
      CALL HWBGEN
      CALL HWCFOR
      CALL HWCDEC
      CALL HWDHAD
  100 CONTINUE
      NQDK=0
  999 END
CDECK  ID>, HWDRCL.
*CMZ :-        -20/07/99  10:56:12  by  Peter Richardson
*-- Author :    Peter Richardson
C-----------------------------------------------------------------------
      SUBROUTINE HWDRCL(IHEP,MHEP,CLSAVE)
C-----------------------------------------------------------------------
C     Sets the colour connections in Baryon number violating decays
C-----------------------------------------------------------------------
      INCLUDE 'HERWIG62.INC'
      INTEGER IHEP,MHEP,ID,ID2,IDM2,IDM3,COLCON(2,2,3),FLACON(2,3),JHEP,
     &        DECAY,COLANT,KHEP,IDM,IDMB,IDMB2,IDMB3,IDMB4,QHEP,IDM4,
     &        CLSAVE(2),XHEP,I,HWRINT,THEP
      LOGICAL CONBV
C--Colour connections for the decays
      DATA COLCON/-1,1,-1,-2,-2,1,-3,-1,-1,1,-2,-1/
      DATA FLACON/1,-1,1,-1,-1,0/
C--identify the decay
      IF(IERROR.NE.0) RETURN
      ID = IDHW(IHEP)
      ID2 = IDHW(MHEP)
      IF(ID.GE.450.AND.ID.LE.457) THEN
        DECAY = 1
      ELSEIF(ID.EQ.449) THEN
        DECAY = 2
      ELSEIF((ID.GE.411.AND.ID.LE.424).OR.ID.EQ.405.OR.ID.EQ.406) THEN
        DECAY = 3
      ELSE
C--UNKNOWN DECAY
        CALL HWWARN('HWDRCL',100,*999)
      ENDIF
      COLANT = 1
C--identify the colour partner
      IF(DECAY.GT.1.AND.ID2.LE.6) THEN
C--colour partner
        COLANT = 2
        KHEP = JDAHEP(2,IHEP-1)
      ELSEIF(DECAY.GT.1.AND.ID2.GE.7) THEN
C--anticolour partner
        COLANT = 3
        KHEP = JMOHEP(2,IHEP)
      ELSE
        KHEP=IHEP
      ENDIF
      IDM   = IDHW(JMOHEP(1,KHEP))
      IF(ABS(IDPDG(IDM)).GT.1000000.OR.IDM.EQ.15) THEN
        IDM2  = IDHW(JDAHEP(1,JMOHEP(1,KHEP)))
        IDM3  = IDHW(JDAHEP(2,JMOHEP(1,KHEP)))
        IDM4  = IDHW(JDAHEP(2,JMOHEP(1,KHEP))-1)
        QHEP  = JMOHEP(1,KHEP)
        IDMB  = IDHW(JMOHEP(1,QHEP))
        IDMB2 = IDHW(JMOHEP(2,QHEP))
        IDMB3 = IDHW(JDAHEP(1,QHEP))
        IDMB4 = IDHW(JDAHEP(2,QHEP))
      ENDIF
C--Now decide if the colour partner decayed via BV
      IF(COLANT.EQ.2.AND.((((IDM.GE.413.AND.IDM.LE.418).OR.
     &                     IDM.EQ.449.OR.IDM.EQ.405.OR.IDM.EQ.406).AND.
     &                       (IDM2.GE.7.AND.IDM2.LE.12.AND.
     &                       IDM3.GE.7.AND.IDM3.LE.12.AND.
     &                       IDM4.GE.7.AND.IDM4.LE.12)).OR.
     &             (IDM.EQ.15.AND.IDMB.LE.6.AND.IDMB2.LE.6.AND.
     &              ((IDMB3.GE.7.AND.IDMB4.GE.12.AND.IDMB4.EQ.449).OR.
     &               (IDMB3.GE.198.AND.IDMB3.LE.207.AND.
     &                ABS(IDPDG(IDMB4)).GT.1000000))))) THEN
        CONBV = .TRUE.
        COLUPD = .TRUE.
        HVFCEN = .FALSE.
        XHEP = JMOHEP(2,JDAHEP(2,JMOHEP(1,KHEP)))
      ELSEIF(COLANT.EQ.3.AND.((((IDM.GE.419.AND.IDM.LE.424).OR.
     &                   IDM.EQ.449.OR.IDM.EQ.411.OR.IDM.EQ.412).AND.
     &                    (IDM2.LE.6.AND.IDM3.LE.6.AND.IDM4.LE.6)).OR.
     &               (IDM.EQ.15.AND.IDMB.GE.7.AND.IDMB.LE.12.AND.
     &                IDMB2.GE.7.AND.IDMB2.LE.12.AND.((IDMB3.LE.6.AND.
     &                IDMB4.EQ.449).OR.(ABS(IDPDG(IDMB4)).GT.1000000
     &                .AND.IDMB3.GE.198.AND.IDMB3.LE.207))))) THEN
        CONBV = .TRUE.
        COLUPD = .TRUE.
        HVFCEN = .FALSE.
        XHEP = JDAHEP(2,JDAHEP(2,JMOHEP(1,KHEP)))
      ELSE
        CONBV = .FALSE.
        COLUPD = .FALSE.
        XHEP = 0
      ENDIF
      IF(CONBV) THEN
        IF(IDM.NE.15) THEN
          CLSAVE(1) = JDAHEP(2,JMOHEP(1,KHEP))-1
          CLSAVE(2) = CLSAVE(1)+1
        ELSE
          IF(IDMB4.EQ.449) THEN
            DO I=1,2
              CLSAVE(I) = JMOHEP(I,JMOHEP(1,KHEP))
              IF(CLSAVE(I).EQ.XHEP) CLSAVE(I)=JDAHEP(1,JMOHEP(1,KHEP))
            ENDDO
          ELSE
            CLSAVE(1) = JMOHEP(1,JMOHEP(1,KHEP))
            CLSAVE(2) = JMOHEP(2,JMOHEP(1,KHEP))
          ENDIF
        ENDIF
      ELSE
        CLSAVE(1)=0
        CLSAVE(2)=0
      ENDIF
C--Now set the colours for angular ordering
      THEP = MHEP-1
      IF(DECAY.EQ.1) THEN
        IF(ID2.LE.6) THEN
          JMOHEP(2,THEP) = THEP+HWRINT(1,2)
          JDAHEP(2,THEP) = THEP
        ELSE
          JMOHEP(2,THEP) = THEP
          JDAHEP(2,THEP) = THEP+HWRINT(1,2)
        ENDIF
      ELSEIF(DECAY.EQ.2) THEN
        IF(ID2.LE.6) THEN
          JMOHEP(2,THEP) = IHEP
          JDAHEP(2,THEP) = THEP
        ELSE
          JMOHEP(2,THEP) = THEP
          JDAHEP(2,THEP) = IHEP
        ENDIF
      ENDIF
C--Colour of the second two
      DO JHEP=1,2
        IF(ID2.LE.6) THEN
          JMOHEP(2,MHEP+JHEP-1) = MHEP+JHEP-1+
     &                           COLCON(HWRINT(1,2),JHEP,DECAY)
          JDAHEP(2,MHEP+JHEP-1) = MHEP+JHEP-1+FLACON(JHEP,DECAY)
        ELSE
          JDAHEP(2,MHEP+JHEP-1) = MHEP+JHEP-1+
     &                           COLCON(HWRINT(1,2),JHEP,DECAY)
          JMOHEP(2,MHEP+JHEP-1) = MHEP+JHEP-1+FLACON(JHEP,DECAY)
        ENDIF
      ENDDO
C--Now set the colours of the colour partner
      IF(DECAY.GT.1.AND..NOT.CONBV) THEN
        IF(ID2.LE.6) JMOHEP(2,KHEP) = MHEP+HWRINT(0,1)
        IF(ID2.GE.7) JDAHEP(2,KHEP) = MHEP+HWRINT(0,1)
      ELSEIF(CONBV) THEN
        IF(ID2.GT.6) THEN
          JMOHEP(2,CLSAVE(1)) = MHEP+HWRINT(0,1)
          IF(JMOHEP(2,CLSAVE(1)).EQ.MHEP) THEN
            JMOHEP(2,CLSAVE(2)) = MHEP+1
          ELSE
            JMOHEP(2,CLSAVE(2)) = MHEP
          ENDIF
        ELSE
          JDAHEP(2,CLSAVE(1)) = MHEP+HWRINT(0,1)
          IF(JDAHEP(2,CLSAVE(1)).EQ.MHEP) THEN
            JDAHEP(2,CLSAVE(2)) = MHEP+1
          ELSE
            JDAHEP(2,CLSAVE(2)) = MHEP
          ENDIF
        ENDIF
      ENDIF
 999  END
CDECK  ID>, HWDRME.
*CMZ :-        -20/07/99  10:56:12  by  Peter Richardson
*-- Author :    Peter Richardson
C-----------------------------------------------------------------------
      SUBROUTINE HWDRME(LHEP,MHEP)
C-----------------------------------------------------------------------
C     SUBROUTINE TO IMPLEMENT ALL RPARITY DECAY MATRIX ELEMENTS
C-----------------------------------------------------------------------
      INCLUDE 'HERWIG62.INC'
      DOUBLE PRECISION SM(6),SW(6),HWULDO,INFCOL,AM, M12SQ,M23SQ,MSGN,
     &                 M13SQ,A(6),B(6),SWEAK,MW,DECMOM(5),TEST(3),EPS,
     &                 M12SQT(6),M23SQT(6),M13SQT(6),LIMIT,M(4),RAND,
     &                 MC(2),MX2(6),MX(6),HWDPWT,HWRGEN,HWDRM1,LAMD(3),
     &                 TEST2
      EXTERNAL         HWDRM1,HWULDO,HWDPWT,HWRGEN
      INTEGER K,SN(3),LHEP,CSP,I,SB(3),J,ND,LTRY,MHEP,NSP,ID(3),IG,
     &        IDHWTP,IDHPTP,MTRY
      PARAMETER(EPS=1D-20)
      IF(IERROR.NE.0) RETURN
C--Electroweak parameters, etc
      SWEAK = SQRT(SWEIN)
      MW    = RMASS(198)
      M(4)  = PHEP(5,LHEP)
      IG    = IDHW(LHEP)
C--Find the masses of the final state and zero parameters
      DO K=1,3
        ID(K) = IDHW(MHEP+K-1)
        IF(ID(K).LE.12) THEN
          SN(K)=ID(K)
        ELSE
          SN(K)=ID(K)-120
        ENDIF
        IF(SN(K).GT.6) SN(K)=SN(K)-6
        M(K) = PHEP(5,LHEP+K)
        SB(K)=SN(K)
        LAMD(K) = ZERO
      ENDDO
      DO J=1,6
        MX2(J) = ZERO
        MX(J)  = ZERO
        M13SQT(J) = ZERO
        M23SQT(J) = ZERO
        M12SQT(J) = ZERO
      ENDDO
C--Evaluate the coefficents for the mode we want
      IF(IG.GE.450.AND.IG.LE.453) THEN
C--NEUTRALINO
        NSP = IG-449
        AM = RMASS(IG)
        MSGN = ZSGNSS(NSP)
        MC(1) =  ZMIXSS(NSP,3)/(2*MW*COSB*SWEAK)
        MC(2) =  ZMIXSS(NSP,4)/(2*MW*SINB*SWEAK)
C--Calculate the combinations of couplings needed
        IF(ID(1).LE.12.AND.ID(2).LE.12.AND.ID(3).LE.12) THEN
C--first for the UDD modes
          DO J=1,2
            A(J) = M(1)*MC(2)*QMIXSS(SN(1),2,J)
     &             +SLFCH(SN(1),NSP)*QMIXSS(SN(1),1,J)
            B(J) = MSGN*(M(1)*MC(2)*QMIXSS(SN(1),1,J)
     &             +SRFCH(SN(1),NSP)*QMIXSS(SN(1),2,J))
            MX2(J) = QMIXSS(SN(1),2,J)
            A(J+2) = M(2)*MC(1)*QMIXSS(SN(2),2,J)
     &               +SLFCH(SN(2),NSP)*QMIXSS(SN(2),1,J)
            B(J+2) = MSGN*(M(2)*MC(1)*QMIXSS(SN(2),1,J)
     &               +SRFCH(SN(2),NSP)*QMIXSS(SN(2),2,J))
            MX2(J+2) = QMIXSS(SN(2),2,J)
            A(J+4) = M(3)*MC(1)*QMIXSS(SN(3),2,J)
     &              +SLFCH(SN(3),NSP)*QMIXSS(SN(3),1,J)
            B(J+4) = MSGN*(M(3)*MC(1)*QMIXSS(SN(3),1,J)
     &              +SRFCH(SN(3),NSP)*QMIXSS(SN(3),2,J))
            MX2(J+2) = QMIXSS(SN(3),2,J)
          ENDDO
          DO K=1,3
            SN(K) = SN(K)+400
            SB(K) = SB(K)+412
          ENDDO
        ELSEIF(ID(1).GE.121.AND.ID(2).GE.121.AND.ID(3).GE.121) THEN
C--Now for the LLE modes
          DO J=1,2
            A(J)  = MSGN*(M(1)*MC(1)*LMIXSS(SN(1),1,J)
     &              +SRFCH(10+SN(1),NSP)*LMIXSS(SN(1),2,J))
            B(J)  = M(1)*MC(1)*LMIXSS(SN(1),2,J)
     &              +SLFCH(10+SN(1),NSP)*LMIXSS(SN(2),1,J)
            MX2(J)= LMIXSS(SN(1),1,J)
            A(J+2) = ZERO
            B(J+2) = SLFCH(10+SN(2),NSP)*LMIXSS(SN(2),1,J)
            MX2(J+2) =  LMIXSS(SN(2),1,J)
            A(J+4) = M(3)*MC(1)*LMIXSS(SN(3),2,J)
     &      +SLFCH(10+SN(3),NSP)*LMIXSS(SN(3),1,J)
            B(J+4) = MSGN*(M(3)*MC(1)*LMIXSS(SN(3),1,J)
     &      +SRFCH(10+SN(3),NSP)*LMIXSS(SN(3),2,J))
            MX2(4+J) = LMIXSS(SN(3),2,J)
          ENDDO
          DO J=1,3
            SN(J) = SN(J) + 424
            SB(J) = SB(J) + 436
          ENDDO
        ELSE
C--Now for both types of LQD modes
          IF(MOD(SN(1),2).EQ.0) THEN
C--First the neutrino,down,antidown mode
            DO J=1,2
              A(J) = ZERO
              B(J) = SLFCH(10+SN(1),NSP)*
     &               LMIXSS(SN(1),1,J)
              MX2(J) = LMIXSS(SN(1),1,J)
              A(J+2) = MSGN*(M(2)*MC(1)*QMIXSS(SN(2),1,J)
     &        +SRFCH(SN(2),NSP)*QMIXSS(SN(2),2,J))
              B(J+2) = M(2)*MC(1)*QMIXSS(SN(2),2,J)
     &        +SLFCH(SN(2),NSP)*QMIXSS(SN(2),1,J)
              MX2(2+J) = QMIXSS(SN(2),1,J)
              A(J+4) = M(3)*MC(1)*QMIXSS(SN(3),2,J)
     &        +SLFCH(SN(3),NSP)*QMIXSS(SN(3),1,J)
              B(J+4) = MSGN*(M(3)*MC(1)*QMIXSS(SN(3),1,J)
     &        +SRFCH(SN(3),NSP)*QMIXSS(SN(3),2,J))
              MX2(J+4) = QMIXSS(SN(3),2,J)
            ENDDO
          ELSE
C--Now the charged lepton, antiup,down modes
            DO J=1,2
              A(J) = MSGN*(M(1)*MC(1)*LMIXSS(SN(1),1,J)
     &        +SRFCH(10+SN(1),NSP)*LMIXSS(SN(1),2,J))
              B(J) = M(1)*MC(1)*LMIXSS(SN(1),2,J)
     &        +SLFCH(10+SN(1),NSP)*LMIXSS(SN(1),1,J)
              MX2(J) = LMIXSS(SN(1),1,J)
              A(J+2) =MSGN*(M(2)*MC(2)*QMIXSS(SN(2),1,J)
     &        +SRFCH(SN(2),NSP)*QMIXSS(SN(2),2,J))
              B(J+2) = M(2)*MC(2)*QMIXSS(SN(2),2,J)
     &        +SLFCH(SN(2),NSP)*QMIXSS(SN(2),1,J)
              MX2(2+J) = QMIXSS(SN(2),1,J)
              A(J+4) = M(3)*MC(1)*QMIXSS(SN(3),2,J)
     &        +SLFCH(SN(3),NSP)*QMIXSS(SN(3),1,J)
              B(J+4) = MSGN*(M(3)*MC(1)*QMIXSS(SN(3),1,J)
     &        +SRFCH(SN(3),NSP)*QMIXSS(SN(3),2,J))
              MX2(J+4) = QMIXSS(SN(3),2,J)
            ENDDO
          ENDIF
          SN(1) = SN(1) + 424
          SB(1) = SB(1) + 436
          DO J=2,3
            SN(J) = SN(J) + 400
            SB(J) = SB(J) + 412
          ENDDO
        ENDIF
        DO K=1,3
          SM(2*K-1) = RMASS(SN(K))
          SM(2*K)   = RMASS(SB(K))
          SW(2*K-1) = HBAR/RLTIM(SN(K))
          SW(2*K)   = HBAR/RLTIM(SB(K))
        ENDDO
        ND = 3
        DO K=1,3
          LAMD(K) = ONE
        ENDDO
        INFCOL = ONE
      ELSEIF(IG.EQ.449) THEN
C--GLUINO
C--First obtian the masses and widths needed
        AM  = RMASS(IG)
        ND = 3
C--Calculate the combinations of couplings needed
        IF(ID(1).LE.12.AND.ID(2).LE.12.AND.ID(3).LE.12) THEN
C--first for the UDD modes
          INFCOL = -0.5D0
C--Couplings
          DO I=1,3
            DO J=1,2
              A(2*I-2+J)  = -QMIXSS(SN(I),1,J)
              B(2*I-2+J)  =  QMIXSS(SN(I),2,J)
              MX2(2*I-2+J) =  QMIXSS(SN(I),2,J)
            ENDDO
            SN(I) = SN(I)+400
            SB(I) = SB(I)+412
          ENDDO
        ELSE
          INFCOL = ONE
C--Now for both types of LQD modes
          IF(MOD(SN(1),2).EQ.0) THEN
C--First the neutrino,down,antidown mode
            DO J=1,2
              A(J)  = ZERO
              B(J)  = ZERO
              MX2(J) = ZERO
              A(J+2)   =  QMIXSS(SN(2),2,J)
              B(J+2)   = -QMIXSS(SN(2),1,J)
              MX2(J+2) =  QMIXSS(SN(2),1,J)
              A(J+4)   = -QMIXSS(SN(3),1,J)
              B(J+4)   =  QMIXSS(SN(3),2,J)
              MX2(4+J) =  QMIXSS(SN(3),2,J)
            ENDDO
          ELSEIF(MOD(SN(1),2).EQ.1) THEN
C--Now the charged lepton, antiup,down modes
            DO J=1,2
              A(J)  = ZERO
              B(J)  = ZERO
              MX2(J) = ZERO
              A(J+2)   =  QMIXSS(SN(2),2,J)
              B(J+2)   = -QMIXSS(SN(2),1,J)
              MX2(J+2) =  QMIXSS(SN(2),1,J)
              A(J+4)     = -QMIXSS(SN(3),1,J)
              B(J+4)   =  QMIXSS(SN(3),2,J)
              MX2(J+4) =  QMIXSS(SN(3),2,J)
            ENDDO
          ENDIF
          SN(1) = SN(1) + 424
          SB(1) = SB(1) + 436
          DO K=2,3
            SN(K) = SN(K) + 400
            SB(K) = SB(K) + 412
          ENDDO
        ENDIF
        DO K=1,3
          SM(2*K-1) = RMASS(SN(K))
          SM(2*K)   = RMASS(SB(K))
          SW(2*K-1) = HBAR/RLTIM(SN(K))
          SW(2*K)   = HBAR/RLTIM(SB(K))
        ENDDO
        DO K=1,3
          LAMD(K) = ONE
        ENDDO
      ELSEIF(IG.GE.454.AND.IG.LE.457) THEN
C--CHARGINO
        CSP = IG-453
        IF(CSP.GT.2) CSP = CSP-2
        AM  = RMASS(IG)
        INFCOL = -ONE
        MSGN = WSGNSS(CSP)
        MC(1) =  ONE/(SQRT(2.0D0)*MW*COSB)
        MC(2) =  ONE/(SQRT(2.0D0)*MW*SINB)
C--Calculate the combinations of the couplings needed
        IF(ID(1).GT.120.AND.ID(2).GT.120.AND.ID(3).GT.120) THEN
C--first for the LLE modes, three modes
          IF(MOD(SN(1),2).EQ.0.AND.MOD(SN(3),2).EQ.0) THEN
C--the one diagram mode nubar,positron, nu
            DO J=1,2
              A(J+4) = LMIXSS(SN(3)-1,1,J)*WMXUSS(CSP,1)
     & -RMASS(SN(3)+119)*MC(1)*LMIXSS(SN(3)-1,2,J)*WMXUSS(CSP,2)
              B(J+4) = ZERO
              MX2(J+4) = LMIXSS(SN(3)-1,2,J)
            ENDDO
            ND = 1
            SN(3) = SN(3)+423
            SB(3) = SB(3)+435
          ELSEIF(MOD(SN(1),2).EQ.0.AND.MOD(SN(2),2).EQ.0) THEN
C--the first two diagram mode nu, nu, positron
            DO J=1,2
              A(J)   = ZERO
              B(J)   = LMIXSS(SN(1)-1,1,J)*WMXUSS(CSP,1)
     & -RMASS(SN(1)+119)*MC(1)*LMIXSS(SN(1)-1,2,J)*WMXUSS(CSP,2)
              A(J+2) = ZERO
              B(J+2) = LMIXSS(SN(2)-1,1,J)*WMXUSS(CSP,1)
     & -RMASS(SN(2)+119)*MC(1)*LMIXSS(SN(2)-1,2,J)*WMXUSS(CSP,2)
              MX2(J)   = LMIXSS(SN(1)-1,1,J)
              MX2(J+2) = LMIXSS(SN(2)-1,1,J)
            ENDDO
            ND = 2
            DO J=1,2
              SN(J) = SN(J)+423
              SB(J) = SB(J)+435
            ENDDO
          ELSE
C--the second two diagram mode positron, positron, electron
            DO J=1,2
              A(J)   = -M(1)*WMXUSS(CSP,2)*MC(1)*LMIXSS(SN(1)+1,1,J)
              B(J)   = MSGN*WMXVSS(CSP,1)*LMIXSS(SN(1)+1,1,J)
              A(J+2) = -M(2)*WMXUSS(CSP,2)*MC(1)*LMIXSS(SN(2)+1,1,J)
              B(J+2) = MSGN*WMXVSS(CSP,1)*LMIXSS(SN(2)+1,1,J)
              MX2(J)   = LMIXSS(SN(1)+1,1,J)
              MX2(J+2) = LMIXSS(SN(2)+1,1,J)
            ENDDO
            DO J=1,2
              SN(J) = SN(J)+425
              SB(J) = SB(J)+437
            ENDDO
            ND = 2
          ENDIF
          DO K=1,3
            LAMD(K) = ONE
          ENDDO
        ELSEIF(ID(1).LE.12.AND.ID(2).LE.12.AND.ID(3).LE.12) THEN
C--now for the UDD
          IF(MOD(SN(1),2).EQ.0) THEN
C--two diagram mode
            LAMD(1) = LAMDA3(SN(2)/2,SN(1)/2,(SN(3)+1)/2)
            LAMD(2) = LAMDA3(SN(1)/2,SN(2)/2,(SN(3)+1)/2)
            DO J=1,2
              A(J)   = WMXUSS(CSP,1)*QMIXSS(SN(1)-1,1,J)
     & -RMASS(SN(1)-1)*MC(1)*WMXUSS(CSP,2)*QMIXSS(SN(1)-1,2,J)
              B(J)   = -MSGN*M(2)*WMXVSS(CSP,2)*QMIXSS(SN(1)-1,1,J)
              A(J+2) = WMXUSS(CSP,1)*QMIXSS(SN(2)-1,1,J)
     & -RMASS(SN(2)-1)*MC(1)*WMXUSS(CSP,2)*QMIXSS(SN(2)-1,2,J)
              B(J+2) = -MSGN*M(2)*WMXVSS(CSP,2)*QMIXSS(SN(2)-1,1,J)
              MX2(J)   = QMIXSS(SN(1)-1,2,J)
              MX2(J+2) = QMIXSS(SN(2)-1,2,J)
            ENDDO
            DO J=1,2
              SN(J) = SN(J) + 399
              SB(J) = SB(J) + 411
            ENDDO
            ND = 2
          ELSE
C--three diagram mode
            LAMD(1) = LAMDA3((SN(1)+1)/2,(SN(2)+1)/2,(SN(3)+1)/2)
            LAMD(2) = LAMDA3((SN(2)+1)/2,(SN(1)+1)/2,(SN(3)+1)/2)
            LAMD(3) = LAMDA3((SN(3)+1)/2,(SN(2)+1)/2,(SN(1)+1)/2)
            DO I=1,3
              DO J=1,2
                A(J+2*I-2) = MSGN*(WMXVSS(CSP,1)*QMIXSS(SN(I)+1,1,J)
     & -RMASS(SN(I)+1)*MC(2)*WMXVSS(CSP,2)*QMIXSS(SN(I)+1,2,J))
                B(J+2*I-2) = -M(I)*MC(1)*WMXUSS(CSP,2)
     &                       *QMIXSS(SN(I)+1,1,J)
                MX2(J+2*I-2)   = QMIXSS(SN(I)+1,2,J)
              ENDDO
              SN(I) = SN(I) + 401
              SB(I) = SB(I) + 413
            ENDDO
            ND = 3
          ENDIF
        ELSE
C--now for the LQD modes
          IF(MOD(SN(2),2).EQ.1.AND.MOD(SN(3),2).EQ.0) THEN
C--first one diagram mode nubar, dbar, up
            DO J=1,2
              A(J+4) = -MSGN*M(3)*WMXVSS(CSP,2)*MC(2)*
     &                  QMIXSS(SN(3)-1,1,J)
              B(J+4) = WMXUSS(CSP,1)*QMIXSS(SN(3)-1,1,J)
     &        -RMASS(SN(3)-1)*MC(1)*WMXUSS(CSP,2)*QMIXSS(SN(3)-1,2,1)
              MX2(J+4)   = QMIXSS(SN(3)-1,2,J)
            ENDDO
            SN(3) = SN(3) + 399
            SB(3) = SB(3) + 411
            ND = 1
          ELSEIF(MOD(SN(2),2).EQ.0.AND.MOD(SN(3),2).EQ.0) THEN
C--second one diagram mode positron, ubar, up
            DO J=1,2
              A(J+4) = -MSGN*M(3)*WMXVSS(CSP,2)*MC(2)*
     &                  QMIXSS(SN(3)-1,1,J)
              B(J+4) = WMXUSS(CSP,1)*QMIXSS(SN(3)-1,1,J)
     &   -RMASS(SN(3)-1)*MC(1)*WMXUSS(CSP,2)*QMIXSS(SN(3)-1,2,1)
              MX2(J+4)   = QMIXSS(SN(3)-1,2,J)
            ENDDO
            SN(3) = SN(3) + 399
            SB(3) = SB(3) + 411
            ND = 1
          ELSEIF(MOD(SN(2),2).EQ.1.AND.MOD(SN(3),2).EQ.1) THEN
C--first two diagram mode positron, dbar, down
            DO J=1,2
              A(J)   = -M(1)*MC(1)*WMXUSS(CSP,2)*LMIXSS(SN(1)+1,1,J)
              B(J)   = MSGN*WMXVSS(CSP,1)*LMIXSS(SN(2)+1,1,J)
              A(J+2) = -M(2)*WMXUSS(CSP,2)*MC(1)*QMIXSS(SN(2)+1,1,J)
              B(J+2) = MSGN*(WMXVSS(CSP,1)*QMIXSS(SN(2)+1,1,J)
     &   -RMASS(SN(2)+1)*MC(2)*WMXVSS(CSP,2)*QMIXSS(SN(2)+1,2,J))
              MX2(J)   = LMIXSS(SN(1)+1,1,J)
              MX2(J+2) = QMIXSS(SN(2)+1,1,J)
            ENDDO
            SN(1) = SN(1) + 425
            SB(1) = SB(1) + 437
            SN(2) = SN(2) + 401
            SB(2) = SB(2) + 413
            ND = 2
          ELSE
C--second two diagram mode nu, up, dbar
            DO J=1,2
              A(J)   = ZERO
              B(J)   = WMXUSS(CSP,1)*LMIXSS(SN(1)-1,1,J)
     &   -RMASS(119+SN(1))*MC(1)*WMXUSS(CSP,2)*LMIXSS(SN(1)-1,2,J)
              A(J+2) = -MSGN*M(2)*MC(2)*WMXVSS(CSP,2)*
     &                 QMIXSS(SN(2)-1,1,J)
              B(J+2) = WMXUSS(CSP,1)*QMIXSS(SN(2)-1,1,J)
     &   -RMASS(SN(2)-1)*MC(1)*WMXUSS(CSP,2)*QMIXSS(SN(2)-1,2,J)
              MX2(J)   = LMIXSS(SN(1)-1,1,J)
              MX2(J+2) = QMIXSS(SN(2)-1,1,J)
            ENDDO
            SN(1) = SN(1) + 423
            SB(1) = SB(1) + 435
            SN(2) = SN(2) + 399
            SB(2) = SB(2) + 411
            ND = 2
          ENDIF
          DO K=1,3
            LAMD(K) = ONE
          ENDDO
        ENDIF
        IF(ND.EQ.1) THEN
          DO K=1,2
            SM(2*K-1) = 0.0D0
            SM(2*K)   = 0.0D0
            SW(2*K-1) = 0.0D0
            SW(2*K)   = 0.0D0
          ENDDO
          SM(5) = RMASS(SN(3))
          SM(6)   = RMASS(SB(3))
          SW(5) = HBAR/RLTIM(SN(3))
          SW(6)   = HBAR/RLTIM(SB(3))
        ELSE
          DO K=1,2
            SM(2*K-1) = RMASS(SN(K))
            SM(2*K)   = RMASS(SB(K))
            SW(2*K-1) = HBAR/RLTIM(SN(K))
            SW(2*K)   = HBAR/RLTIM(SB(K))
            SM(4+K)   = ZERO
            SW(4+K)   = ZERO
          ENDDO
        ENDIF
      ELSE
C--UNKNOWN
        CALL HWWARN('HWDRME',500,*999)
      ENDIF
C--Set mixing to zero if diagram not available
      IF((AM.LT.(ABS(SM(1))+M(1)).OR.ABS(SM(1)).LT.(M(2)+M(3)))
     &   .AND.ABS(MX2(1)).GT.ZERO.AND.ND.NE.1) MX(1) = MX2(1)*LAMD(1)
        IF((AM.LT.(ABS(SM(2))+M(1)).OR.ABS(SM(2)).LT.(M(2)+M(3)))
     &   .AND.ABS(MX2(2)).GT.ZERO.AND.ND.NE.1) MX(2) = MX2(2)*LAMD(1)
        IF((AM.LT.(ABS(SM(3))+M(2)).OR.ABS(SM(3)).LT.(M(1)+M(3)))
     &   .AND.ABS(MX2(3)).GT.ZERO.AND.ND.NE.1) MX(3) = MX2(3)*LAMD(2)
        IF((AM.LT.(ABS(SM(4))+M(2)).OR.ABS(SM(4)).LT.(M(1)+M(3)))
     &   .AND.ABS(MX2(4)).GT.ZERO.AND.ND.NE.1) MX(4) = MX2(4)*LAMD(2)
        IF((AM.LT.(ABS(SM(5))+M(3)).OR.ABS(SM(5)).LT.(M(1)+M(2)))
     &   .AND.ABS(MX2(5)).GT.ZERO.AND.ND.NE.2) MX(5) = MX2(5)*LAMD(3)
        IF((AM.LT.(ABS(SM(6))+M(3)).OR.ABS(SM(6)).LT.(M(1)+M(2)))
     &   .AND.ABS(MX2(6)).GT.ZERO.AND.ND.NE.2) MX(6) = MX2(6)*LAMD(3)
C--Calculate the limiting points
      DO J=1,2
        IF(ND.NE.1) THEN
          IF(ABS(MX(J)).GT.EPS) CALL HWDRM5(M23SQT(J),M13SQT(J),
     &      M12SQT(J),A(J),B(J),M(2),M(3),M(1),M(4),SM(J),SW(J))
          IF(ABS(MX(J+2)).GT.EPS) CALL HWDRM5(M13SQT(2+J),M23SQT(2+J),
     &    M12SQT(2+J),A(2+J),B(2+J),M(1),M(3),M(2),M(4),SM(2+J),SW(2+J))
        ENDIF
        IF(ND.NE.2) THEN
          IF(ABS(MX(J+4)).GT.EPS) CALL HWDRM5(M12SQT(4+J),M23SQT(4+J),
     &    M13SQT(4+J),A(4+J),B(4+J),M(1),M(2),M(3),M(4),SM(4+J),SW(4+J))
        ENDIF
      ENDDO
C--Now evaluate the limit using these points
      LIMIT = ZERO
      DO 100 I=1,6
        IF(ABS(MX(I)).LT.EPS) GOTO 100
        LIMIT = LIMIT+HWDRM1(TEST,M12SQT(I),M13SQT(I),M23SQT(I),A,B,MX,
     &                       M,SM,SW,INFCOL,AM,0,ND)
 100  CONTINUE
      LIMIT = TWO*LIMIT
C--Now evaluate at a random point
      MTRY = 0
 25   MTRY = MTRY+1
      LTRY = 0
 35   LTRY = LTRY+1
      CALL HWDTHR(PHEP(1,LHEP),PHEP(1,MHEP),
     &                  PHEP(1,MHEP+1),PHEP(1,MHEP+2),HWDPWT)
C--Now calculate the m12sq etc for the actual point
      M12SQ = M(1)**2+M(2)**2+2*HWULDO(PHEP(1,MHEP),PHEP(1,MHEP+1))
      M13SQ = M(1)**2+M(3)**2+2*HWULDO(PHEP(1,MHEP),PHEP(1,MHEP+2))
      M23SQ = M(2)**2+M(3)**2+2*HWULDO(PHEP(1,MHEP+1),PHEP(1,MHEP+2))
C--Now calulate the matrix element
      TEST2 = HWDRM1(TEST,M12SQ,M13SQ,M23SQ,A,B,MX,
     &                       M,SM,SW,INFCOL,AM,1,ND)
C--Now test the value againest the limit
      RAND = HWRGEN(0)*LIMIT
      IF(TEST2.GT.LIMIT) THEN
        LIMIT = 1.1D0*TEST2
        CALL HWWARN('HWDRME',51,*150)
      ENDIF
 150  IF(TEST2.LT.RAND.AND.LTRY.LT.NETRY) THEN
        GOTO 35
      ELSEIF(LTRY.GE.NETRY) THEN
        IF(MTRY.LE.NETRY) THEN
          LIMIT = LIMIT*0.9D0
          CALL HWWARN('HWDRME',52,*25)
        ELSE
          CALL HWWARN('HWDRME',100,*999)
        ENDIF
      ENDIF
C--Reorder the particles in gluino decay to get angular ordering right
      IF(IG.EQ.449.AND.ID(1).LE.12.AND.ID(2).LE.12.AND.ID(3).LE.12) THEN
        DO LTRY=1,3
          IF(TEST(LTRY).GT.RAND) THEN
            IF(LTRY.EQ.2) THEN
              IDHWTP        = IDHW(MHEP)
              IDHW(MHEP)    = IDHW(MHEP+1)
              IDHW(MHEP+1)  = IDHWTP
              IDHPTP        = IDHEP(MHEP)
              IDHEP(MHEP)   = IDHEP(MHEP+1)
              IDHEP(MHEP+1) = IDHPTP
              CALL HWVEQU(5,PHEP(1,MHEP),DECMOM)
              CALL HWVEQU(5,PHEP(1,MHEP+1),PHEP(1,MHEP))
              CALL HWVEQU(5,DECMOM,PHEP(1,MHEP+1))
            ELSEIF(LTRY.EQ.3) THEN
              IDHWTP        = IDHW(MHEP)
              IDHW(MHEP)    = IDHW(MHEP+2)
              IDHW(MHEP+2)    = IDHWTP
              IDHPTP        = IDHEP(MHEP)
              IDHEP(MHEP)   = IDHEP(MHEP+2)
              IDHEP(MHEP+2)   = IDHPTP
              DO I=1,5
              CALL HWVEQU(5,PHEP(1,MHEP),DECMOM)
              CALL HWVEQU(5,PHEP(1,MHEP+2),PHEP(1,MHEP))
              CALL HWVEQU(5,DECMOM,PHEP(1,MHEP+2))
              ENDDO
            ENDIF
            GOTO 52
          ENDIF
          RAND=RAND-TEST(LTRY)
        ENDDO
      ENDIF
 52   CONTINUE
 999  END
CDECK  ID>, HWDRM1.
*CMZ :-        -20/07/99  10:56:12  by  Peter Richardson
*-- Author :    Peter Richardson
C-----------------------------------------------------------------------
      FUNCTION HWDRM1(TEST,M12SQ,M13SQ,M23SQ,A,B,MX,M,SM,SW
     &                ,INFCOL,AM,LM,ND)
C-----------------------------------------------------------------------
C     FUNCTION TO GIVE THE R-PARITY VIOLATING MATRIX ELEMENT AT A GIVEN
C     PHASE-SPACE POINT
C-----------------------------------------------------------------------
      IMPLICIT NONE
      DOUBLE PRECISION M12SQ,M13SQ,M23SQ,MX(6),A(6),B(6),SM(6),SW(6),
     &                 INFCOL,AM,TERM(21),TEST(3),PLN,NPLN,ZERO,
     &                 M(4),HWDRM1,HWDRM2,HWDRM3,HWDRM4
      PARAMETER (ZERO=0)
      EXTERNAL HWDRM2,HWDRM3,HWDRM4
      INTEGER LM,K,ND
C--Zero the array
        DO K=1,21
          TERM(K) = 0.0D0
        ENDDO
        HWDRM1 = 0.0D0
C--The amplitude
      IF(ABS(MX(1)).GT.ZERO.AND.ND.NE.1) THEN
        TERM(1) = MX(1)**2*HWDRM2(M23SQ,M(2),M(3),M(1),M(4),SM(1),
     &            SW(1),A(1),B(1))
        IF(ABS(MX(2)).GT.ZERO) TERM(7)= MX(1)*MX(2)*HWDRM3(M23SQ,M(2),
     &   M(3),M(1),M(4),SM(1),SM(2),SW(1),SW(2),A(1),A(2),B(1),B(2))
        IF(ABS(MX(3)).GT.ZERO) TERM(10)=-MX(1)*MX(3)*HWDRM4(M13SQ,M23SQ,
     &  M(1),M(3),M(2),M(4),SM(3),SM(1),SW(3),SW(1),A(1),A(3),B(1),B(3))
        IF(ABS(MX(4)).GT.ZERO) TERM(11)=-MX(1)*MX(4)*HWDRM4(M13SQ,M23SQ,
     &  M(1),M(3),M(2),M(4),SM(4),SM(1),SW(4),SW(1),A(1),A(4),B(1),B(4))
        IF(ABS(MX(5)).GT.ZERO) TERM(12)=-MX(1)*MX(5)*HWDRM4(M23SQ,M12SQ,
     &  M(3),M(2),M(1),M(4),SM(1),SM(5),SW(1),SW(5),A(5),A(1),B(5),B(1))
        IF(ABS(MX(6)).GT.ZERO) TERM(13)=-MX(1)*MX(6)*HWDRM4(M23SQ,M12SQ,
     &  M(3),M(2),M(1),M(4),SM(1),SM(6),SW(1),SW(6),A(6),A(1),B(6),B(1))
      ENDIF
      IF(ABS(MX(2)).GT.ZERO.AND.ND.NE.1) THEN
        TERM(2) = MX(2)**2*HWDRM2(M23SQ,M(2),M(3),M(1),M(4),SM(2),
     &            SW(2),A(2),B(2))
        IF(ABS(MX(3)).GT.ZERO) TERM(14)=-MX(2)*MX(3)*HWDRM4(M13SQ,M23SQ,
     &  M(1),M(3),M(2),M(4),SM(3),SM(2),SW(3),SW(2),A(2),A(3),B(2),B(3))
        IF(ABS(MX(4)).GT.ZERO) TERM(15)=-MX(2)*MX(4)*HWDRM4(M13SQ,M23SQ,
     &  M(1),M(3),M(2),M(4),SM(4),SM(2),SW(4),SW(2),A(2),A(4),B(2),B(4))
        IF(ABS(MX(5)).GT.ZERO) TERM(16)=-MX(2)*MX(5)*HWDRM4(M23SQ,M12SQ,
     &  M(3),M(2),M(1),M(4),SM(2),SM(5),SW(2),SW(5),A(5),A(2),B(5),B(2))
        IF(ABS(MX(6)).GT.ZERO) TERM(17)=-MX(2)*MX(6)*HWDRM4(M23SQ,M12SQ,
     &  M(3),M(2),M(1),M(4),SM(2),SM(6),SW(2),SW(6),A(6),A(2),B(6),B(2))
      ENDIF
      IF(ABS(MX(3)).GT.ZERO.AND.ND.NE.1) THEN
        TERM(3) = MX(3)**2*HWDRM2(M13SQ,M(1),M(3),M(2),M(4),SM(3),
     &            SW(3),A(3),B(3))
        IF(ABS(MX(4)).GT.ZERO) TERM(8)= MX(3)*MX(4)*HWDRM3(M13SQ,M(1),
     &   M(3),M(2),M(4),SM(3),SM(4),SW(3),SW(4),A(3),A(4),B(3),B(4))
        IF(ABS(MX(5)).GT.ZERO) TERM(18)=-MX(3)*MX(5)*HWDRM4(M12SQ,M13SQ,
     &  M(2),M(1),M(3),M(4),SM(5),SM(3),SW(5),SW(3),A(3),A(5),B(3),B(5))
        IF(ABS(MX(6)).GT.ZERO) TERM(19)=-MX(3)*MX(6)*HWDRM4(M12SQ,M13SQ,
     &  M(2),M(1),M(3),M(4),SM(6),SM(3),SW(6),SW(3),A(3),A(6),B(3),B(6))
      ENDIF
      IF(ABS(MX(4)).GT.ZERO.AND.ND.NE.1) THEN
        TERM(4) = MX(4)**2*HWDRM2(M13SQ,M(1),M(3),M(2),M(4),SM(4),
     &            SW(4),A(4),B(4))
        IF(ABS(MX(5)).GT.ZERO) TERM(20)=-MX(4)*MX(5)*HWDRM4(M12SQ,M13SQ,
     &  M(2),M(1),M(3),M(4),SM(5),SM(4),SW(5),SW(4),A(4),A(5),B(4),B(5))
        IF(ABS(MX(6)).GT.ZERO) TERM(21)=-MX(4)*MX(6)*HWDRM4(M12SQ,M13SQ,
     &  M(2),M(1),M(3),M(4),SM(6),SM(4),SW(6),SW(4),A(4),A(6),B(4),B(6))
      ENDIF
      IF(ABS(MX(5)).GT.ZERO.AND.ND.NE.2) THEN
        TERM(5) = MX(5)**2*HWDRM2(M12SQ,M(1),M(2),M(3),M(4),SM(5),
     &            SW(5),A(5),B(5))
        IF(ABS(MX(6)).GT.ZERO) TERM(9)= MX(5)*MX(6)*HWDRM3(M12SQ,M(1),
     &     M(2),M(3),M(4),SM(5),SM(6),SW(5),SW(6),A(5),A(6),B(5),B(6))
      ENDIF
      IF(ABS(MX(6)).GT.ZERO.AND.ND.NE.2) TERM(6) = MX(6)**2*
     &    HWDRM2(M12SQ,M(1),M(2),M(3),M(4),SM(6),SW(6),A(6),B(6))
      DO K=10,21
        TERM(K)=TERM(K)*INFCOL
      ENDDO
C--Add them up
      DO K=1,21
        HWDRM1 = HWDRM1+TERM(K)
      ENDDO
C--Different colour flows for the gluino
      IF(LM.NE.0) THEN
        NPLN = 0.0D0
        PLN = 0.0D0
        DO K=1,9
          PLN = PLN+TERM(K)
        ENDDO
        DO K=10,21
          NPLN= NPLN+TERM(K)
        ENDDO
        DO K=1,3
          TEST(K) = (TERM(2*K-1)+TERM(2*K)+TERM(6+K))*(1+NPLN/PLN)
        ENDDO
      ELSE
        DO K=1,3
          TEST(K) = 0.0D0
        ENDDO
      ENDIF
      IF(HWDRM1.LT.ZERO) CALL HWWARN('HWDRM1',50,*999)
 999  END
CDECK  ID>, HWDRM2.
*CMZ :-        -20/07/99  10:56:12  by  Peter Richardson
*-- Author :    Peter Richardson
C-----------------------------------------------------------------------
      FUNCTION HWDRM2(X,MA,MB,MC,MD,MR1,GAM1,A,B)
C-----------------------------------------------------------------------
C     Function to compute the matrix element squared part of a 3-body
C     R-parity decay
C-----------------------------------------------------------------------
      IMPLICIT NONE
      DOUBLE PRECISION X,MA,MB,MC,MD,A,B,HWDRM2,MR1,GAM1
      HWDRM2  = (X - MA**2 - MB**2)*(4*A*B*MC*MD +
     &    (A**2 + B**2)*(-X + MC**2 + MD**2))/
     &     ((X-MR1**2)**2+GAM1**2*MR1**2)
      END
CDECK  ID>, HWDRM3.
*CMZ :-        -20/07/99  10:56:12  by  Peter Richardson
*-- Author :    Peter Richardson
C-----------------------------------------------------------------------
      FUNCTION HWDRM3(X,MA,MB,MC,MD,MR1,MR2,GAM1,GAM2,A1,A2,B1,B2)
C-----------------------------------------------------------------------
C     Function to compute the light/heavy interference part of a 3-body
C     R-parity decay
C-----------------------------------------------------------------------
      IMPLICIT NONE
      DOUBLE PRECISION X,MA,MB,MC,MD,A1,A2,B1,B2,HWDRM3,MR1,MR2,GAM1
     &                 ,GAM2
C
      HWDRM3  = 2*(X - MA**2 - MB**2)*(2*(A2*B1 + A1*B2)*MC*MD +
     &    (A1*A2 + B1*B2)*(-X + MC**2 + MD**2))*
     &  (GAM1*GAM2*MR1*MR2 + (X - MR1**2)*(X - MR2**2))/
     &  (((X-MR1**2)**2+GAM1**2*MR1**2)*((X-MR2**2)**2+GAM2**2*MR2**2))
      END
CDECK  ID>, HWDRM4.
*CMZ :-        -20/07/99  10:56:12  by  Peter Richardson
*-- Author :    Peter Richardson
C-----------------------------------------------------------------------
      FUNCTION HWDRM4(X,Y,MA,MB,MC,MD,MR1,MR2,GAM1,GAM2,A1,A2,B1,B2)
C-----------------------------------------------------------------------
C     Function to compute the interference part of a 3-body
C     R-parity decay
C-----------------------------------------------------------------------
      IMPLICIT NONE
      DOUBLE PRECISION X,Y,MA,MB,MC,MD,A1,A2,B1,B2,HWDRM4,MR1,MR2,GAM1
     &                 ,GAM2
C
      HWDRM4  = 2*((GAM1*GAM2*MR1*MR2 + (X - MR1**2)*(Y - MR2**2))*
     &    (A2*B1*MC*MD*(X - MA**2 - MB**2) +
     &      A1*A2*MA*MC*(X + Y - MA**2 - MC**2) +
     &      A1*B2*MA*MD*(Y - MB**2 - MC**2) +
     &      B1*B2*(X*Y - MA**2*MC**2 - MB**2*MD**2)))/
     &  (((X-MR1**2)**2+GAM1**2*MR1**2)*((Y-MR2**2)**2+GAM2**2*MR2**2))
      END
CDECK  ID>, HWDRM5.
*CMZ :-        -20/07/99  10:56:12  by  Peter Richardson
*-- Author :    Peter Richardson
C-----------------------------------------------------------------------
      SUBROUTINE HWDRM5(X,Y,Z,A,B,MA,MB,MC,MD,MR,GAM)
C-----------------------------------------------------------------------
C     Subroutine to find the maximum of the ME
C-----------------------------------------------------------------------
      IMPLICIT NONE
      DOUBLE PRECISION X,Y,Z,MA,MB,MC,MD,MR,GAM,RES(3),A,B,C,D,
     &                 E2S,E3S,E2M,E3M,LOW,UPP,HWRUNI,EPS,ZERO
      EXTERNAL HWRUNI
      PARAMETER(EPS=1D-9,ZERO=0)
      C = A**2+B**2
      D = 4*A*B
      RES(1) = -D*(MA**2 + MB**2)*MC*MD +
     &          C*(GAM**2*MR**2 + MR**4 - MA**2*MC**2 - MB**2*MC**2 -
     &          MA**2*MD**2 - MB**2*MD**2)
      RES(2) = (GAM**2*MR**2 + (-MR**2 + MA**2 + MB**2)**2)*
     &          (D**2*MC**2*MD**2 +
     &          2*C*D*MC*MD*(-MR**2 + MC**2 + MD**2) +
     &          C**2*(GAM**2*MR**2 + (-MR**2 + MC**2 + MD**2)**2))
      RES(3) = -D*MC*MD+C*(2*MR**2-(MA**2+MB**2+MC**2+MD**2))
      IF(RES(2).GT.ZERO) THEN
        RES(2) = SQRT(RES(2))
      ELSE
        RES(2) = 0.0D0
      ENDIF
      IF((RES(1)+RES(2))/RES(3).GT.(MD-MC)**2.OR.
     &              (RES(1)+RES(2))/RES(3).LT.(MA+MB)**2) THEN
        X = (RES(1)-RES(2))/RES(3)
      ELSE
        X = (RES(1)+RES(2))/RES(3)
      ENDIF
      IF(X.GT.(MD-MC)**2) X = (MD-MC)**2
      IF(X.LT.(MA+MB)**2) X = (MA+MB)**2
      E2S = (X-MA**2+MB**2)/(2*SQRT(X))
      E3S = (MD**2-X-MC**2)/(2*SQRT(X))
      E2M = E2S**2-MB**2
      E3M = E3S**2-MC**2
      IF(E2M.LT.ZERO) THEN
        IF(ABS(E2M/E2S).GT.EPS) CALL HWWARN('HWDRM5',2,*10)
 10     E2M= 0.0D0
      ENDIF
      IF(E3M.LT.ZERO) THEN
        IF(ABS(E3M/E3S).GT.EPS) CALL HWWARN('HWDRM5',3,*20)
 20     E3M= 0.0D0
      ENDIF
      E2M = SQRT(E2M)
      E3M = SQRT(E3M)
      LOW = (E2S+E3S)**2-(E2M+E3M)**2
      UPP = (E2S+E3S)**2-(E2M-E3M)**2
      Y   = HWRUNI(1,LOW,UPP)
      Z   = MA**2+MB**2+MC**2+MD**2-X-Y
      END
CDECK  ID>, HWDPWT.
*CMZ :-        -26/04/91  11.11.55  by  Bryan Webber
*-- Author :    Bryan Webber
C-----------------------------------------------------------------------
      FUNCTION HWDPWT(EMSQ,A,B,C)
C-----------------------------------------------------------------------
C     MATRIX ELEMENT SQUARED FOR PHASE SPACE DECAY
C-----------------------------------------------------------------------
      DOUBLE PRECISION HWDPWT,EMSQ,A,B,C
      HWDPWT=1.
      END
CDECK  ID>, HWDTHR.
*CMZ :-        -26/04/91  14.55.44  by  Federico Carminati
*-- Author :    Bryan Webber
C-----------------------------------------------------------------------
      SUBROUTINE HWDTHR(P0,P1,P2,P3,WEIGHT)
C-----------------------------------------------------------------------
C     GENERATES THREE-BODY DECAY 0->1+2+3 DISTRIBUTED
C     ACCORDING TO PHASE SPACE * WEIGHT
C-----------------------------------------------------------------------
      DOUBLE PRECISION HWRGEN,HWRUNI,A,B,C,D,AA,BB,CC,DD,EE,FF,PP,QQ,WW,
     & RR,PCM1,PC23,WEIGHT,P0(5),P1(5),P2(5),P3(5),P23(5),TWO
      EXTERNAL HWRGEN,HWRUNI,WEIGHT
      PARAMETER (TWO=2.D0)
      A=P0(5)+P1(5)
      B=P0(5)-P1(5)
      C=P2(5)+P3(5)
      IF (B.LT.C) CALL HWWARN('HWDTHR',100,*999)
      D=ABS(P2(5)-P3(5))
      AA=A*A
      BB=B*B
      CC=C*C
      DD=D*D
      EE=(B-C)*(A-D)
      A=0.5*(AA+BB)
      B=0.5*(CC+DD)
      C=4./(A-B)**2
C
C  CHOOSE MASS OF SUBSYSTEM 23 WITH PRESCRIBED DISTRIBUTION
C
   10 FF=HWRUNI(0,BB,CC)
      PP=(AA-FF)*(BB-FF)
      QQ=(CC-FF)*(DD-FF)
      WW=WEIGHT(FF,A,B,C)**2
      RR=EE*FF*HWRGEN(0)
      IF (PP*QQ*WW.LT.RR*RR) GOTO 10
C
C  FF IS MASS SQUARED OF SUBSYSTEM 23.
C
C  DO 2-BODY DECAYS 0->1+23, 23->2+3
C
      P23(5)=SQRT(FF)
      PCM1=SQRT(PP)*0.5/P0(5)
      PC23=SQRT(QQ)*0.5/P23(5)
      CALL HWDTWO(P0,P1,P23,PCM1,TWO,.TRUE.)
      CALL HWDTWO(P23,P2,P3,PC23,TWO,.TRUE.)
  999 END
CDECK  ID>, HWDTOP.
*CMZ :-        -09/12/92  11.03.46  by  Bryan Webber
*-- Author :    Bryan Webber
C-----------------------------------------------------------------------
      SUBROUTINE HWDTOP(DECAY)
C-----------------------------------------------------------------------
C     DECIDES WHETHER TO DO TOP QUARK DECAY BEFORE HADRONIZATION
C-----------------------------------------------------------------------
      INCLUDE 'HERWIG62.INC'
      LOGICAL DECAY
      DECAY=RMASS(6).GT.130D0
      END
CDECK  ID>, HWDTWO.
*CMZ :-        -27/01/94  17.38.49  by  Mike Seymour
*-- Author :    Bryan Webber & Mike Seymour
C-----------------------------------------------------------------------
      SUBROUTINE HWDTWO(P0,P1,P2,PCM,COSTH,ZAXIS)
C-----------------------------------------------------------------------
C     GENERATES DECAY 0 -> 1+2
C
C     PCM IS CM MOMENTUM
C
C     COSTH = COS THETA IN P0 REST FRAME (>1 FOR ISOTROPIC)
C     IF ZAXIS=.TRUE., COS THETA IS MEASURED FROM THE ZAXIS
C     IF .FALSE., IT IS MEASURED FROM P0'S DIRECTION
C-----------------------------------------------------------------------
      DOUBLE PRECISION HWRUNI,ONE,ZERO,PCM,COSTH,C,S,P0(5),P1(5),P2(5),
     & PP(5),R(9)
      LOGICAL ZAXIS
      EXTERNAL HWRUNI
      PARAMETER (ZERO=0.D0, ONE=1.D0)
C--CHOOSE C.M. ANGLES
      C=COSTH
      IF (C.GT.ONE) C=HWRUNI(0,-ONE,ONE)
      S=SQRT(ONE-C*C)
      CALL HWRAZM(PCM*S,PP(1),PP(2))
C--PP IS MOMENTUM OF 2 IN C.M.
      PP(3)=-PCM*C
      PP(4)=SQRT(P2(5)**2+PCM**2)
      PP(5)=P2(5)
C--ROTATE IF NECESSARY
      IF (COSTH.LE.ONE.AND..NOT.ZAXIS) THEN
        CALL HWUROT(P0,ONE,ZERO,R)
        CALL HWUROB(R,PP,PP)
      ENDIF
C--BOOST FROM C.M. TO LAB FRAME
      CALL HWULOB(P0,PP,P2)
      CALL HWVDIF(4,P0,P2,P1)
      END
CDECK  ID>, HWDWWT.
*CMZ :-        -26/04/91  11.11.55  by  Bryan Webber
*-- Author :    Bryan Webber
C-----------------------------------------------------------------------
      FUNCTION HWDWWT(EMSQ,A,B,C)
C-----------------------------------------------------------------------
C     MATRIX ELEMENT SQUARED FOR V-A WEAK DECAY
C-----------------------------------------------------------------------
      DOUBLE PRECISION HWDWWT,EMSQ,A,B,C
      HWDWWT=(A-EMSQ)*(EMSQ-B)*C
      END
CDECK  ID>, HWDXLM.
*CMZ :-        -07/09/00  10:06:23  by  Peter Richardson
*-- Author :    Ian Knowles
C-----------------------------------------------------------------------
      SUBROUTINE HWDXLM(DKVRTX,STAB)
C-----------------------------------------------------------------------
C     Sets STAB=.TRUE. if DKVRTX lies outside the specified region.
C  Revised 05/09/00 by BRW to put parameters in common
C-----------------------------------------------------------------------
      INCLUDE 'HERWIG62.INC'
      DOUBLE PRECISION DKVRTX(4),RR
      LOGICAL STAB
      STAB=.FALSE.
      RR=DKVRTX(1)**2+DKVRTX(2)**2
      IF (IOPDKL.EQ.1) THEN
C Cylindrical geometry
         IF (RR.GE.DXRCYL**2.OR.ABS(DKVRTX(3)).GE.DXZMAX) STAB=.TRUE.
      ELSEIF (IOPDKL.EQ.2) THEN
C Spherical geometry
         RR=RR+DKVRTX(3)**2
         IF (RR.GE.DXRSPH**2) STAB=.TRUE.
      ELSE
C User supplied geometry -- missing
         CALL HWWARN('HWDXLM',500,*999)
      ENDIF
  999 END
CDECK  ID>, HWEFIN.
*CMZ :-        -26/04/91  11.11.55  by  Bryan Webber
*-- Author :    Bryan Webber
C-----------------------------------------------------------------------
      SUBROUTINE HWEFIN
C-----------------------------------------------------------------------
C     TERMINAL CALCULATIONS ON ELEMENTARY PROCESS
C-----------------------------------------------------------------------
      INCLUDE 'HERWIG62.INC'
      DOUBLE PRECISION RNWGT,SPWGT,ERWGT
      WRITE (6,1)
    1 FORMAT(/10X,'OUTPUT ON ELEMENTARY PROCESS'/)
      IF (NWGTS.EQ.0) THEN
        WRITE (6,10)
   10   FORMAT(10X,'NO WEIGHTS GENERATED')
      ELSE
        RNWGT=1./FLOAT(NWGTS)
        AVWGT=WGTSUM*RNWGT
        SPWGT=SQRT(MAX(WSQSUM*RNWGT-AVWGT**2,ZERO))
        ERWGT=SPWGT*SQRT(RNWGT)
        IF (.NOT.NOWGT) WGTMAX=AVWGT
        IF (WGTMAX.EQ.ZERO) WGTMAX=ONE
        WRITE (6,11) NEVHEP,NWGTS,AVWGT,SPWGT,WBIGST,WGTMAX,
     &               IPROC+MAX(IMSSM,0),
     &               1000.*AVWGT,1000.*ERWGT,100.*AVWGT/WGTMAX
   11   FORMAT(1P,
     &         10X,'NUMBER OF EVENTS   = ',I11/
     &         10X,'NUMBER OF WEIGHTS  = ',I11/
     &         10X,'MEAN VALUE OF WGT  =',E12.4/
     &         10X,'RMS SPREAD IN WGT  =',E12.4/
     &         10X,'ACTUAL MAX WEIGHT  =',E12.4/
     &         10X,'ASSUMED MAX WEIGHT =',E12.4//
     &         10X,'PROCESS CODE IPROC = ',I11/
     &         10X,'CROSS SECTION (PB) =',G12.4/
     &         10X,'ERROR IN C-S  (PB) =',G12.4/
     &         10X,'EFFICIENCY PERCENT =',G12.4)
      ENDIF
      END
CDECK  ID>, HWEGAM.
*CMZ :-        -26/04/91  11.11.55  by  Bryan Webber
*-- Author :    Bryan Webber & Luca Stanco
C-----------------------------------------------------------------------
      SUBROUTINE HWEGAM(IHEP,ZMI,ZMA,WWA)
C-----------------------------------------------------------------------
C     GENERATES A PHOTON IN WEIZSACKER-WILLIAMS (WWA=.TRUE.) OR
C     ELSE EQUIVALENT PHOTON APPROX FROM INCOMING E+, E-, MU+ OR MU-
C-----------------------------------------------------------------------
      INCLUDE 'HERWIG62.INC'
      DOUBLE PRECISION HWRGEN,HWRUNI,EGMIN,ZMIN,ZMAX,ZGAM,SS,ZMI,ZMA,
     & PPL,PMI,QT2,Q2,QQMIN,QQMAX,S0,A,RPM(2)
      INTEGER IHEP,IHADIS,HQ,I
      LOGICAL WWA
      EXTERNAL HWRGEN,HWRUNI
      DATA EGMIN/5.D0/
      IF (IERROR.NE.0)  RETURN
      IF (IHEP.LT.1.OR.IHEP.GT.2) CALL HWWARN('HWEGAM',500,*999)
      SS=PHEP(5,3)
      IF (IHEP.EQ.1) THEN
        IHADIS=2
      ELSE
        IHADIS=1
        IF (JDAHEP(1,IHADIS).NE.0) IHADIS=JDAHEP(1,IHADIS)
      ENDIF
C---DEFINE LIMITS FOR GAMMA MOMENTUM FRACTION
      IF (ZMI.LE.ZERO .OR. ZMA.GT.ONE) THEN
        IF (IPRO.EQ.13.OR.IPRO.EQ.14) THEN
          S0 = EMMIN**2
        ELSEIF(IPRO.EQ.15.OR.IPRO.EQ.18.OR.IPRO.EQ.22.OR.IPRO.EQ.24.OR.
     &         IPRO.EQ.50.OR.IPRO.EQ.53.OR.IPRO.EQ.55)THEN
          S0 = 4.D0*PTMIN**2
        ELSEIF (IPRO.EQ.17.OR.IPRO.EQ.51) THEN
          HQ = MOD(IPROC,100)
          S0 = 4.D0*(PTMIN**2+RMASS(HQ)**2)
        ELSEIF (IPRO.EQ.16.OR.IPRO.EQ.19.OR.IPRO.EQ.25.OR.
     &          IPRO.EQ.26.OR.IPRO.EQ.27.OR.IPRO.EQ.95) THEN
          S0 = MAX(2*RMASS(1),RMASS(201)-GAMMAX*GAMH)**2
        ELSEIF (IPRO.EQ.33) THEN
          S0 = MAX(2*RMASS(1),RMASS(201+IHIGGS))**2
        ELSEIF (IPRO.EQ.34) THEN
          S0 = MAX(2*RMASS(5),RMASS(201+IHIGGS))**2
        ELSEIF (IPRO.EQ.23) THEN
          S0 = MAX(2*RMASS(1),RMASS(201)-GAMMAX*GAMH)**2
          S0 = (PTMIN+SQRT(PTMIN**2+S0))**2
        ELSEIF (IPRO.EQ.20) THEN
          S0 = RMASS(6)**2
        ELSEIF (IPRO.EQ.21) THEN
          S0 = (PTMIN+SQRT(PTMIN**2+RMASS(198)**2))**2
C--PR MOD 7/7/99
        ELSEIF (IPRO.EQ.30) THEN
          S0 = 4.0D0*(PTMIN**2+RMMNSS**2)
        ELSEIF(IPRO.EQ.40.OR.IPRO.EQ.41) THEN
          HQ = IPROC-100*IPRO
          RPM(1) = RMMNSS
          RPM(2) = ZERO
          IF(HQ.GE.10.AND.HQ.LT.20) THEN
            RPM(1) = ABS(RMASS(450))
            IF(HQ.GT.10) RPM(1) = ABS(RMASS(449+MOD(HQ,10)))
          ELSEIF(HQ.GE.20.AND.HQ.LT.30) THEN
            RPM(1) = ABS(RMASS(454))
            IF(HQ.GT.20) RPM(1) = ABS(RMASS(453+MOD(HQ,20)))
          ELSEIF(HQ.EQ.30) THEN
            RPM(1) = RMASS(449)
          ELSEIF(HQ.EQ.40) THEN
            IF(IPRO.EQ.40) THEN
              RPM(1) = RMASS(425)
              DO I=1,5
                RPM(1) = MIN(RPM(1),RMASS(425+I))
              ENDDO
            ELSE
              RPM(1) = MIN(RMASS(405),RMASS(406))
            ENDIF
            RPM(2) = RMASS(198)
          ELSEIF(HQ.EQ.50) THEN
            IF(IPRO.EQ.40) THEN
              RPM(1) = RMASS(425)
              DO I=1,5
                RPM(1) = MIN(RPM(1),RMASS(425+I))
              ENDDO
              DO I=1,3
                RPM(2) = MIN(RPM(1),RMASS(433+2*I))
              ENDDO
              RPM(1) = MIN(RPM(1),RPM(2))
              RPM(2) = RMASS(203)
              DO I=1,2
                RPM(2) = MIN(RPM(2),RMASS(204+I))
              ENDDO
            ELSE
              RPM(1) = RMASS(401)
              RPM(2) = RMASS(413)
              DO I=1,5
                RPM(1) = MIN(RPM(1),RMASS(401+I))
                RPM(2) = MIN(RPM(2),RMASS(413+I))
              ENDDO
              RPM(1) = MIN(RPM(1),RPM(2))
              RPM(2) = RMASS(203)
              DO I=1,2
                RPM(2) = MIN(RPM(2),RMASS(204+I))
              ENDDO
            ENDIF
            RPM(2) = RMASS(203)
            DO I=1,2
              RPM(2) = MIN(RPM(2),RMASS(204+I))
            ENDDO
          ELSEIF(HQ.GE.60) THEN
            RPM(1) = ZERO
          ENDIF
          RPM(1) = RPM(1)**2
          RPM(2) = RPM(2)**2
          S0 = RPM(1)+RPM(2)+TWO*(PTMIN**2+
     &         SQRT(RPM(1)*RPM(2)+PTMIN**2*(RPM(1)+RPM(2)+PTMIN**2)))
C--end of mod
C--PR MOD 9/9/00
        ELSEIF (IPRO.EQ.42) THEN
          S0 = EMMIN**2
        ELSEIF (IPRO.EQ.52) THEN
          HQ = MOD(IPROC,100)
          S0 = (PTMIN+SQRT(PTMIN**2+RMASS(HQ)**2))**2
        ELSEIF (IPRO.EQ.60) THEN
          HQ = MOD(IPROC,100)
          IF (HQ.EQ.0) THEN
            S0 = 4.D0*PTMIN**2
          ELSE
            IF (HQ.GT.6) HQ=2*HQ+107
            IF (HQ.EQ.127) HQ=198
            S0 = 4.D0*(PTMIN**2+RMASS(HQ)**2)
          ENDIF
        ELSEIF (IPRO.EQ.80) THEN
          S0 = WHMIN**2
        ELSEIF (IPRO.EQ.90) THEN
          S0 = Q2MIN
        ELSEIF (IPRO.EQ.91.OR.IPRO.EQ.92) THEN
          S0 = Q2MIN+4.D0*PTMIN**2
          HQ = MOD(IPROC,100)
          IF (HQ.GT.0) S0 = S0+4.D0*RMASS(HQ)**2
          IF (IPRO.EQ.91) S0 = MAX(S0,EMMIN**2)
        ELSE
          S0 = 0
        ENDIF
        IF (S0.GT.ZERO) THEN
          S0 = (SQRT(S0)+ABS(PHEP(5,IHADIS)))**2-PHEP(5,IHADIS)**2
          S0 = MAX(S0,WHMIN**2)
          ZMIN = S0 / (SS**2 - PHEP(5,IHEP)**2 - PHEP(5,IHADIS)**2)
          ZMAX = ONE
        ELSE
C---UNKNOWN PROCESS: USE ENERGY CUTOFF, AND WARN USER
          IF (FSTWGT) CALL HWWARN('HWEGAM',1,*999)
          ZMIN = EGMIN / PHEP(4,IHEP)
          ZMAX = ONE
        ENDIF
      ELSE
        ZMIN=ZMI
        ZMAX=ZMA
      ENDIF
C---APPLY USER DEFINED CUTS YWWMIN,YWWMAX AND INDIRECT LIMITS ON Z
      IF (.NOT.WWA) THEN
        ZMIN=MAX(ZMIN,YWWMIN,SQRT(Q2WWMN)/ABS(PHEP(3,IHEP)))
        ZMAX=MIN(ZMAX,YWWMAX)
        IF (ZMIN.GT.ZMAX) THEN
          GAMWT=ZERO
          RETURN
        ENDIF
      ENDIF
C---GENERATE GAMMA MOMENTUM FRACTION
      A=HALF
 10   IF (HWRGEN(2).LT.A) THEN
        ZGAM=(ZMIN/ZMAX)**HWRGEN(1)*ZMAX
      ELSE
        ZGAM=(ZMAX-ZMIN)*HWRGEN(1)+ZMIN
      ENDIF
      GAMWT = GAMWT * .5*ALPHEM/PIFAC *
     +     (1+(1-ZGAM)**2)/(A/LOG(ZMAX/ZMIN)+(1-A)/(ZMAX-ZMIN)*ZGAM)
      IF (WWA) THEN
        GAMWT = GAMWT * LOG((ONE-ZGAM)/ZGAM*(SS/PHEP(5,IHEP))**2)
      ELSE
C---Q2WWMN AND Q2WWMX ARE USER-DEFINED LIMITS IN THE Q**2 INTEGRATION
        QQMAX=MIN(Q2WWMX,(ZGAM*PHEP(3,IHEP))**2)
        QQMIN=MAX(Q2WWMN,(PHEP(5,IHEP)*ZGAM)**2/(1.-ZGAM))
        IF (QQMIN.GT.QQMAX) CALL HWWARN('HWEGAM',50,*10)
        Q2=EXP(HWRUNI(0,LOG(QQMIN),LOG(QQMAX)))
        GAMWT = GAMWT * LOG(QQMAX/QQMIN)
      ENDIF
      IF (GAMWT.LT.ZERO) GAMWT=ZERO
C---FILL PHOTON
      NHEP=NHEP+1
      IDHW(NHEP)=59
      ISTHEP(NHEP)=3
      IDHEP(NHEP)=22
      JMOHEP(1,NHEP)=IHEP
      JMOHEP(2,NHEP)=0
      JDAHEP(1,NHEP)=0
      JDAHEP(2,NHEP)=0
      JDAHEP(1,IHEP)=NHEP
      IF (WWA) THEN
C---FOR COLLINEAR KINEMATICS, ZGAM IS THE ENERGY FRACTION
        PHEP(4,NHEP)=PHEP(4,IHEP)*ZGAM
        PHEP(3,NHEP)=PHEP(3,IHEP)-SIGN(SQRT(
     &     (PHEP(4,IHEP)-PHEP(4,NHEP))**2-PHEP(5,IHEP)**2),PHEP(3,IHEP))
        PHEP(2,NHEP)=0
        PHEP(1,NHEP)=0
        CALL HWUMAS(PHEP(1,NHEP))
      ELSE
C---FOR EXACT KINEMATICS, ZGAM IS TAKEN TO BE FRACTION OF (E+PZ)
        PPL=ZGAM*(ABS(PHEP(3,IHEP))+PHEP(4,IHEP))
        QT2=(ONE-ZGAM)*Q2-(ZGAM*PHEP(5,IHEP))**2
        PMI=(QT2-Q2)/PPL
        PHEP(5,NHEP)=-SQRT(Q2)
        PHEP(4,NHEP)=(PPL+PMI)/TWO
        PHEP(3,NHEP)=SIGN((PPL-PMI)/TWO,PHEP(3,IHEP))
        CALL HWRAZM(SQRT(QT2),PHEP(1,NHEP),PHEP(2,NHEP))
      ENDIF
C---UPDATE OVERALL CM FRAME
      JMOHEP(IHEP,3)=NHEP
      CALL HWVDIF(4,PHEP(1,3),PHEP(1,IHEP),PHEP(1,3))
      CALL HWVSUM(4,PHEP(1,NHEP),PHEP(1,3),PHEP(1,3))
      CALL HWUMAS(PHEP(1,3))
C---FILL OUTGOING LEPTON
      NHEP=NHEP+1
      IDHW(NHEP)=IDHW(IHEP)
      ISTHEP(NHEP)=1
      IDHEP(NHEP)=IDHEP(IHEP)
      JMOHEP(1,NHEP)=IHEP
      JMOHEP(2,NHEP)=0
      JDAHEP(1,NHEP)=0
      JDAHEP(2,NHEP)=0
      JDAHEP(2,IHEP)=NHEP
      CALL HWVDIF(4,PHEP(1,IHEP),PHEP(1,NHEP-1),PHEP(1,NHEP))
      PHEP(5,NHEP)=PHEP(5,IHEP)
 999  END
CDECK  ID>, HWEINI.
*CMZ :-        -26/04/91  12.42.30  by  Federico Carminati
*-- Author :    Bryan Webber
C-----------------------------------------------------------------------
      SUBROUTINE HWEINI
C-----------------------------------------------------------------------
C     INITIALISES ELEMENTARY PROCESS
C-----------------------------------------------------------------------
      INCLUDE 'HERWIG62.INC'
      DOUBLE PRECISION HWRSET,DUMMY,SAFETY
      EXTERNAL HWRSET
      PARAMETER (SAFETY=1.001)
      INTEGER NBSH,I
C---NO OF WEIGHT GENERATED
      NWGTS=0
C---ACCUMULATED WEIGHTS
      WGTSUM=0.
C---ACCUMULATED WEIGHT-SQUARED
      WSQSUM=0.
C---CURRENT MAX WEIGHT
      WBIGST=0.
C---LAST VALUE OF SCALE
      EMLST=0.
C---NUMBER OF ERRORS REPORTED
      NUMER=0
C---NUMBER OF ERRORS UNREPORTED
      NUMERU=0
C---FIND MAXIMUM EVENT WEIGHT IN CASES WHERE THIS IS REQUIRED
      IF (NOWGT) THEN
        IF (WGTMAX.EQ.ZERO) THEN
          NBSH=IBSH
          DUMMY = HWRSET(IBRN)
          WRITE(6,10) IPROC+MAX(IMSSM,0),IBRN,NBSH
   10     FORMAT(/10X,'INITIAL SEARCH FOR MAX WEIGHT'//
     &            10X,'PROCESS CODE IPROC = ',I11/
     &            10X,'RANDOM NO. SEED 1  = ',I11/
     &            10X,'           SEED 2  = ',I11/
     &            10X,'NUMBER OF SHOTS    = ',I11)
          NEVHEP=0
          DO 11 I=1,NBSH
          CALL HWEPRO
   11     CONTINUE
          WRITE(6,20)
   20     FORMAT(/10X,'INITIAL SEARCH FINISHED')
          IF (WBIGST*NWGTS.LT.SAFETY*WGTSUM)
     &                 WGTMAX=SAFETY*WBIGST
          CALL HWEFIN
          NWGTS=0
          WGTSUM=0.
          WSQSUM=0.
          WBIGST=0.
        ELSE
          WRITE(6,21) AVWGT,WGTMAX
   21     FORMAT(/1P,10X,'INPUT EVT WEIGHT   =',E12.4/
     &               10X,'INPUT MAX WEIGHT   =',E12.4)
        ENDIF
      ENDIF
C---RESET RANDOM NUMBER
      DUMMY = HWRSET(NRN)
      ISTAT=5
  999 END
CDECK  ID>, HWEISR.
*CMZ :-        -01/04/99  19.55.17  by  Mike Seymour
*-- Author :    Mike Seymour
C-----------------------------------------------------------------------
      SUBROUTINE HWEISR(IHEP)
C-----------------------------------------------------------------------
C     GENERATES AN ISR PHOTON FROM INCOMING E+, E-, MU+ OR MU-
C-----------------------------------------------------------------------
      INCLUDE 'HERWIG62.INC'
      DOUBLE PRECISION HWRGEN,QSQMAX,QSQMIN,A,B,B1,B2,B3,B4,B5,B6,B7,B8,
     $ R,AA,T0,T1,C1,C2,T,Z(2),QSQ(2),PHI(2),C,NWID,NMASS
      INTEGER IHEP,I,J
      EXTERNAL HWRGEN
      SAVE Z,QSQ,PHI
C---IF ZMXISR IS ZERO, THERE CAN BE NO ISR
      IF (ZMXISR.EQ.ZERO.OR.(IPRO.GT.3.AND.IPRO.LT.6)
     &     .OR.IPRO.GT.8.OR.IPROC.EQ.850) RETURN
C---CHECK CONSISTENCY OF TMNISR AND ZMXISR
      IF (ZMXISR**2.LT.TMNISR) CALL HWWARN('HWEISR',200,*999)
C---CALCULATE VIRTUALITY LIMITS
      QSQMAX=4*PHEP(4,IHEP)**2
      QSQMIN=PHEP(5,IHEP)**2
C---AND THEREFORE THE Z DEPENDENCE
      A=ALPHEM/PIFAC
      B=A*(LOG(QSQMAX/QSQMIN)-1)
C---DECIDE HOW MUCH WEIGHT TO GIVE THE Z RESONANCE
      IF (IHEP.EQ.1) THEN
        IF (IPRO.EQ.1.OR.IPRO.EQ.6.OR.IPRO.EQ.8) THEN
          AA=10
        ELSEIF (IPRO.EQ.2) THEN
          AA=0
        ELSEIF (IPRO.EQ.3.OR.IPRO.EQ.7) THEN
          AA=1
        ELSE
          RETURN
        ENDIF
C--set up the parameters for the resonance
        IF(IPRO.NE.8) THEN
C--first the standard parameters if smoothing the Z resonance
          T0=RMASS(200)**2/QSQMAX
          T1=GAMZ*RMASS(200)/QSQMAX
        ELSE
C--now the parameters for a resonant sneutrino in RPV
C--uses the average of the muon and tau sneutrino mass and either the
C--larger width or the difference in masses (whichever is larger)
          NMASS = HALF*(RMASS(428)+RMASS(430))
          NWID  = MAX(HBAR/RLTIM(428),HBAR/RLTIM(430))
          NWID  = MAX(NWID,ABS(RMASS(428)-RMASS(430)))
          T0    = NMASS**2/QSQMAX
          T1    = NWID*NMASS/QSQMAX
        ENDIF
        IF (T0.GT.ONE) THEN
          T0=0
          AA=0
        ENDIF
        AA=AA*(1-T0)
C---GENERATE A T VALUE BETWEEN TMNISR AND 1 ACCORDING TO:
C   ( b**2*log(zmxisr**2/t)/t + 2*b*(1-(1-zmxisr)**b)*((1-t)**(2*b-1)+1/t
C     +(1-t0)**(2b-1)*aa*t1/((t-t0)**2+t1**2)) ) *theta(zmxisr**2-t)
C  +( 2*b*(1-zmxisr)**b*((1-t)**(b-1)+1/t
C     +(1-t0)**(b-1)*aa*t1/((t-t0)**2+t1**2))  ) *theta(zmxisr-t)
C  +( (1-zmxisr)**(2*b)                        ) *delta(1-t)
        B1=(1-ZMXISR)**(2*B)
        B2=B1+2*(1-ZMXISR)**B*((1-TMNISR)**B-(1-ZMXISR)**B)
        B3=B2+2*B*(1-ZMXISR)**B*LOG(ZMXISR/TMNISR)
        B4=B3+2*B*(1-ZMXISR)**B*AA*(1-T0)**(B-1)
     $       *(ATAN((ZMXISR-T0)/T1)-ATAN((TMNISR-T0)/T1))
        B5=B4+(1-(1-ZMXISR)**B)*((1-TMNISR)**(2*B)-(1-ZMXISR**2)**(2*B))
        B6=B5+2*B*(1-(1-ZMXISR)**B)*LOG(ZMXISR**2/TMNISR)
        B7=B6+B**2*LOG(ZMXISR**2/TMNISR)**2/2
        B8=B7+2*B*(1-(1-ZMXISR)**B)*AA*(1-T0)**(2*B-1)
     $       *(ATAN((ZMXISR**2-T0)/T1)-ATAN((TMNISR-T0)/T1))
        R=B8*HWRGEN(0)
        IF (R.LE.B1) THEN
C---NEITHER EMITS
          T=1
          GAMWT=GAMWT*B8/B1
          Z(1)=1
        ELSEIF (R.LE.B4) THEN
C---ONE EMITS
          IF (R.LE.B2) THEN
            R=(R-B1)/(B2-B1)
            T=1-(1-TMNISR)*(1-R*(1-((1-ZMXISR)/(1-TMNISR))**B))**(1/B)
          ELSEIF (R.LE.B3) THEN
            R=(R-B2)/(B3-B2)
            T=(TMNISR/ZMXISR)**R*ZMXISR
          ELSE
            R=(R-B3)/(B4-B3)
            T=T0+T1*TAN(
     $           ATAN((ZMXISR-T0)/T1)*R+ATAN((TMNISR-T0)/T1)*(1-R))
          ENDIF
          GAMWT=GAMWT*B8/(2*B*(1-ZMXISR)**B*((1-T)**(B-1)+1/T+
     $         (1-T0)**(B-1)*AA*T1/((T-T0)**2+T1**2)))
          Z(1)=1
          IF (HWRGEN(1).GT.HALF) Z(1)=T
          GAMWT=GAMWT*2
        ELSE
C---BOTH EMIT
          IF (R.LE.B5) THEN
            R=(R-B4)/(B5-B4)
            T=1-(1-TMNISR)*
     $           (1-R*(1-((1-ZMXISR**2)/(1-TMNISR))**(2*B)))**(.5/B)
          ELSEIF (R.LE.B6) THEN
            R=(R-B5)/(B6-B5)
            T=(TMNISR/ZMXISR**2)**R*ZMXISR**2
          ELSEIF (R.LE.B7) THEN
            R=(R-B6)/(B7-B6)
            T=(TMNISR/ZMXISR**2)**SQRT(R)*ZMXISR**2
          ELSE
            R=(R-B7)/(B8-B7)
            T=T0+T1*TAN(
     $           ATAN((ZMXISR**2-T0)/T1)*R+ATAN((TMNISR-T0)/T1)*(1-R))
          ENDIF
          GAMWT=GAMWT*B8/(B**2*LOG(ZMXISR**2/T)/T
     $         + 2*B*(1-(1-ZMXISR)**B)*((1-T)**(2*B-1)+1/T+
     $         (1-T0)**(B-1)*AA*T1/((T-T0)**2+T1**2)))
C---GENERATE A Z VALUE BETWEEN T/ZMXISR AND ZMXISR ACCORDING TO:
C   1/z+(1-z)**(b-1)+t/z**2*(1-t/z)**(b-1)
          C1=LOG(ZMXISR**2/T)
          C2=C1+2/B*((1-T/ZMXISR)**B-(1-ZMXISR)**B)
          IF (C2.GT.ZERO) THEN
            R=C2*HWRGEN(4)
            IF (R.LE.C1) THEN
              Z(1)=(T/ZMXISR**2)**HWRGEN(5)*ZMXISR
            ELSE
              Z(1)=1-(1-T/ZMXISR)*
     $             (1-HWRGEN(6)*(1-((1-ZMXISR)/(1-T/ZMXISR))**B))**(1/B)
              IF (2*R.LE.C2+C1) Z(1)=T/Z(1)
            ENDIF
          ELSE
            Z(1)=SQRT(T)
          ENDIF
          GAMWT=GAMWT*C2/Z(1)
     $         /(1/Z(1)+(1-Z(1))**(B-1)+T/Z(1)**2*(1-T/Z(1))**(B-1))
        ENDIF
C---INCLUDE DISTRIBUTION FUNCTIONS
        Z(2)=T/Z(1)
        DO 10 I=1,2
          IF (Z(I).GT.ZMXISR) THEN
            Z(I)=1
            GAMWT=GAMWT*(1-ZMXISR)**B*EXP(3*B/4)*(1-B**2*PIFAC**2/12)
          ELSE
            GAMWT=GAMWT*(B*(1-Z(I))**(B-1)*(1+Z(I)**2)/2
     $           *EXP(B*Z(I)/2*(1+Z(I)/2))*(1-B**2*PIFAC**2/12)
     $           +B**2/8*((1+Z(I))*((1+Z(I))**2+3*LOG(Z(I)))
     $           -4*LOG(Z(I))/(1-Z(I))))
          ENDIF
  10    CONTINUE
C---CHOOSE BOTH QSQ VALUES
        DO 30 I=1,2
          IF (Z(I).GT.ZMXISR .OR. COLISR) THEN
            QSQ(I)=0
          ELSE
            J=3-I
C---ACCORDING TO 1/(QSQ+QSQMIN) FROM 0 TO (1-Z)*(T/(Z+T))*QSQMAX
 20         QSQ(I)=(((1-Z(I))*(T/(Z(I)+T))
     $           *QSQMAX/QSQMIN+1)**HWRGEN(7)-1)*QSQMIN
C---AND REJECT TO QSQ/(QSQ+QSQMIN)**2
            IF (HWRGEN(8)*(QSQ(I)+QSQMIN).GT.QSQ(I)) GOTO 20
          ENDIF
 30     CONTINUE
C---CHOOSE BOTH AZIMUTHS
        PHI(1)=HWRGEN(9)*2*PIFAC
        PHI(2)=HWRGEN(10)*2*PIFAC
C---USE S-HAT PRESCRIPTION TO MODIFY Z VALUES
        I=0
        IF ((1-Z(1))*QSQ(1).GT.(1-Z(2))*QSQ(2)) I=1
        IF ((1-Z(2))*QSQ(2).GT.(1-Z(1))*QSQ(1)) I=2
        IF (I.GT.0) THEN
          J=3-I
          Z(I)=Z(I)+QSQ(I)/QSQMAX
          IF (QSQ(J).GT.ZERO) THEN
            Z(J)=((QSQ(I)*QSQMAX+QSQ(J)*QSQMAX
     $           -QSQ(I)*QSQ(J))/QSQMAX**2+T)/Z(I)
            C=COS(PHI(1)-PHI(2))*SQRT(QSQ(1)*QSQ(2))/QSQMAX
            Z(J)=Z(J)+(-2*C**2*(1-Z(I))+2*C*SQRT((1-Z(I))
     $           *(C**2*(1-Z(I))+Z(I)**2*(1-Z(J)))))/Z(I)**2
          ENDIF
        ENDIF
      ELSEIF (IHEP.EQ.2) THEN
C---EVERYTHING WAS GENERATED LAST TIME
      ELSE
C---ROUTINE CALLED UNEXPECTEDLY
        CALL HWWARN('HWEISR',201,*999)
      ENDIF
C---IF Z IS TOO LARGE THERE IS NO EMISSION
      IF (Z(IHEP).GT.ZMXISR) RETURN
C---PUT NEW LEPTON IN EVENT RECORD
      NHEP=NHEP+1
      IDHW(NHEP)=IDHW(IHEP)
      IDHEP(NHEP)=IDHEP(IHEP)
      ISTHEP(NHEP)=3
      JMOHEP(1,NHEP)=IHEP
      JMOHEP(2,NHEP)=0
      JDAHEP(1,NHEP)=0
      JDAHEP(2,NHEP)=0
      JDAHEP(1,IHEP)=NHEP
C---AND OUTGOING PHOTON
      NHEP=NHEP+1
      IDHW(NHEP)=59
      IDHEP(NHEP)=22
      ISTHEP(NHEP)=1
      JMOHEP(1,NHEP)=IHEP
      JMOHEP(2,NHEP)=0
      JDAHEP(1,NHEP)=0
      JDAHEP(2,NHEP)=0
      JDAHEP(2,IHEP)=NHEP
C---RECONSTRUCT PHOTON KINEMATICS (Z IS LIGHT-CONE MOMENTUM FRACTION)
      PHEP(1,NHEP)=SQRT(QSQ(IHEP)*(1-Z(IHEP)))*COS(PHI(IHEP))
      PHEP(2,NHEP)=SQRT(QSQ(IHEP)*(1-Z(IHEP)))*SIN(PHI(IHEP))
      PHEP(3,NHEP)=(1-Z(IHEP))*PHEP(4,IHEP)-QSQ(IHEP)/(4*PHEP(4,IHEP))
      IF (IHEP.EQ.2) PHEP(3,NHEP)=-PHEP(3,NHEP)
      PHEP(4,NHEP)=(1-Z(IHEP))*PHEP(4,IHEP)+QSQ(IHEP)/(4*PHEP(4,IHEP))
      PHEP(5,NHEP)=0
C---AND LEPTON
      CALL HWVDIF(4,PHEP(1,IHEP),PHEP(1,NHEP),PHEP(1,NHEP-1))
      CALL HWUMAS(PHEP(1,NHEP-1))
C---UPDATE OVERALL CM FRAME
      JMOHEP(IHEP,3)=NHEP-1
      CALL HWVDIF(4,PHEP(1,3),PHEP(1,IHEP),PHEP(1,3))
      CALL HWVSUM(4,PHEP(1,NHEP-1),PHEP(1,3),PHEP(1,3))
      CALL HWUMAS(PHEP(1,3))
 999  END
CDECK  ID>, HWEONE.
*CMZ :-        -26/04/91  11.11.55  by  Bryan Webber
*-- Author :    Bryan Webber
C-----------------------------------------------------------------------
      SUBROUTINE HWEONE
C-----------------------------------------------------------------------
C     SETS UP 2->1 (COLOUR SINGLET) HARD SUBPROCESS
C-----------------------------------------------------------------------
      INCLUDE 'HERWIG62.INC'
      DOUBLE PRECISION PA
      INTEGER ICMF,I,IBM,IHEP
C---INCOMING LINES
      ICMF=NHEP+3
      DO 15 I=1,2
      IBM=I
C---FIND BEAM AND TARGET
      IF (JDAHEP(1,I).NE.0) IBM=JDAHEP(1,I)
      IHEP=NHEP+I
      IDHW(IHEP)=IDN(I)
      IDHEP(IHEP)=IDPDG(IDN(I))
      ISTHEP(IHEP)=110+I
      JMOHEP(1,IHEP)=ICMF
      JMOHEP(I,ICMF)=IHEP
      JDAHEP(1,IHEP)=ICMF
C---SPECIAL - IF INCOMING PARTON IS INCOMING BEAM THEN COPY IT
      IF (XX(I).EQ.ONE.AND.IDHW(IBM).EQ.IDN(I)) THEN
        CALL HWVEQU(5,PHEP(1,IBM),PHEP(1,IHEP))
        IF (I.EQ.2) PHEP(3,IHEP)=-PHEP(3,IHEP)
      ELSE
        PHEP(1,IHEP)=0.
        PHEP(2,IHEP)=0.
        PHEP(5,IHEP)=RMASS(IDN(I))
        PA=XX(I)*(PHEP(4,IBM)+ABS(PHEP(3,IBM)))
        PHEP(4,IHEP)=0.5*(PA+PHEP(5,IHEP)**2/PA)
        PHEP(3,IHEP)=PA-PHEP(4,IHEP)
      ENDIF
 15   CONTINUE
      PHEP(3,NHEP+2)=-PHEP(3,NHEP+2)
C---HARD CENTRE OF MASS
      IDHW(ICMF)=IDCMF
      IDHEP(ICMF)=IDPDG(IDCMF)
      ISTHEP(ICMF)=110
      CALL HWVSUM(4,PHEP(1,NHEP+1),PHEP(1,NHEP+2),PHEP(1,ICMF))
      CALL HWUMAS(PHEP(1,ICMF))
C---SET UP COLOUR STRUCTURE LABELS
      JMOHEP(2,NHEP+1)=NHEP+2
      JDAHEP(2,NHEP+1)=NHEP+2
      JMOHEP(2,NHEP+2)=NHEP+1
      JDAHEP(2,NHEP+2)=NHEP+1
      JDAHEP(1,NHEP+3)=NHEP+3
      JDAHEP(2,NHEP+3)=NHEP+3
      NHEP=NHEP+3
  999 END
CDECK  ID>, HWEPRO.
*CMZ :-        -01/04/99  19.41.18  by  Mike Seymour
*-- Author :    Bryan Webber
C-----------------------------------------------------------------------
      SUBROUTINE HWEPRO
C-----------------------------------------------------------------------
C     WHEN NEVHEP=0, CHOOSES X VALUES AND FINDS WEIGHT FOR PROCESS IPROC
C     OTHERWISE, CHOOSES AND LOADS ALL VARIABLES FOR HARD PROCESS
C-----------------------------------------------------------------------
      INCLUDE 'HERWIG62.INC'
      DOUBLE PRECISION HWRGEN
      EXTERNAL HWRGEN
      IF (IERROR.NE.0)  RETURN
C---ROUTINE LOOPS BACK TO HERE IF GENERATED WEIGHT WAS NOT ACCEPTED
   10 GENEV=.FALSE.
C---FSTWGT IS .TRUE. DURING FIRST CALL TO HARD PROCESS ROUTINE
      FSTWGT=NWGTS.EQ.0
C---FSTEVT IS .TRUE. THROUGHOUT THE FIRST EVENT
      FSTEVT=NEVHEP.EQ.1
C---SET COLOUR CORRECTION TO FALSE
      COLUPD = .FALSE.
      HRDCOL(1,1)=0
      HRDCOL(1,3)=0
C---SET UP INITIAL STATE
      NHEP=1
      ISTHEP(NHEP)=101
      PHEP(1,NHEP)=0.
      PHEP(2,NHEP)=0.
      PHEP(3,NHEP)=PBEAM1
      PHEP(4,NHEP)=EBEAM1
      PHEP(5,NHEP)=RMASS(IPART1)
      JMOHEP(1,NHEP)=0
      JMOHEP(2,NHEP)=0
      JDAHEP(1,NHEP)=0
      JDAHEP(2,NHEP)=0
      IDHW(NHEP)=IPART1
      IDHEP(NHEP)=IDPDG(IPART1)
      NHEP=NHEP+1
      ISTHEP(NHEP)=102
      PHEP(1,NHEP)=0.
      PHEP(2,NHEP)=0.
      PHEP(3,NHEP)=-PBEAM2
      PHEP(4,NHEP)=EBEAM2
      PHEP(5,NHEP)=RMASS(IPART2)
      JMOHEP(1,NHEP)=0
      JMOHEP(2,NHEP)=0
      JDAHEP(1,NHEP)=0
      JDAHEP(2,NHEP)=0
      IDHW(NHEP)=IPART2
      IDHEP(NHEP)=IDPDG(IPART2)
C---NEXT ENTRY IS OVERALL CM FRAME
      NHEP=NHEP+1
      IDHW(NHEP)=14
      IDHEP(NHEP)=0
      ISTHEP(NHEP)=103
      JMOHEP(1,NHEP)=NHEP-2
      JMOHEP(2,NHEP)=NHEP-1
      JDAHEP(1,NHEP)=0
      JDAHEP(2,NHEP)=0
      CALL HWVSUM(4,PHEP(1,NHEP-1),PHEP(1,NHEP-2),PHEP(1,NHEP))
      CALL HWUMAS(PHEP(1,NHEP))
C Select a primary interaction point
      IF (PIPSMR) THEN
        CALL HWRPIP
      ELSE
        CALL HWVZRO(4,VTXPIP)
      ENDIF
      CALL HWVEQU(3,VTXPIP,VHEP(1,NHEP))
      VHEP(4,NHEP)=0.0
C---GENERATE PHOTONS (WEIZSACKER-WILLIAMS APPROX)
C   FOR HADRONIC PROCESSES WITH LEPTON BEAMS
      GAMWT=ONE
      IF (IPRO.GT.10.AND.IPRO.LT.90) THEN
        IF (ABS(IDHEP(1)).EQ.11.OR.ABS(IDHEP(1)).EQ.13)
     &       CALL HWEGAM(1,ZERO, ONE,.FALSE.)
        IF (ABS(IDHEP(2)).EQ.11.OR.ABS(IDHEP(2)).EQ.13)
     &       CALL HWEGAM(2,ZERO, ONE,.FALSE.)
      ELSEIF (IPRO.GE.90) THEN
        IF (ABS(IDHEP(2)).EQ.11.OR.ABS(IDHEP(2)).EQ.13)
     &       CALL HWEGAM(2,ZERO, ONE,.FALSE.)
      ENDIF
C---GENERATE ISR PHOTONS FOR LEPTONIC PROCESSES
      IF (IPRO.LT.10) THEN
        CALL HWEISR(1)
        CALL HWEISR(2)
      ENDIF
C---IF USER LIMITS WERE TOO TIGHT, MIGHT NOT BE ANY PHASE-SPACE
      IF (GAMWT.LE.ZERO) GOTO 30
C---IF CMF HAS ACQUIRED A TRANSVERSE BOOST, OR USER REQUESTS IT ANYWAY,
C   BOOST EVENT RECORD BACK TO CMF
      IF (PHEP(1,3)**2+PHEP(2,3)**2.GT.ZERO .OR. USECMF) CALL HWUBST(1)
C---ROUTINE LOOPS BACK TO HERE IF GENERATED WEIGHT WAS ACCEPTED
   20 CONTINUE
      IPRO=MOD(IPROC/100,100)
      IF (IPRO.EQ.1) THEN
        IF (IPROC.LT.110.OR.IPROC.GE.120) THEN
C--- E+E- -> Q-QBAR OR L-LBAR
          CALL HWHEPA
        ELSE
C--- E+E- -> Q-QBAR-GLUON
          CALL HWHEPG
        ENDIF
      ELSEIF (IPRO.EQ.2) THEN
C--- E+E- -> W+ W-
        CALL HWHEWW
      ELSEIF (IPRO.EQ.3) THEN
C---E+E- -> Z H
        CALL HWHIGZ
      ELSEIF (IPRO.EQ.4) THEN
C---E+E- -> NUEB NUE H
        CALL HWHIGW
      ELSEIF (IPRO.EQ.5 .AND. IPROC.LT.550) THEN
C---EE -> EE GAMGAM -> EE FFBAR/WW
        CALL HWHEGG
      ELSEIF (IPRO.EQ.5) THEN
C---EE -> ENU GAMW -> ENU FF'BAR/WZ
        CALL HWHEGW
      ELSEIF (IPRO.EQ.6) THEN
C---EE -> FOUR JETS
        CALL HWH4JT
      ELSEIF(IPRO.EQ.7) THEN
C--EE -> SUSY PARTICLES(PAIR PRODUCTION)
        CALL HWHESP
      ELSEIF(IPRO.EQ.8) THEN
C--EE -> RPV SUSY PARTICLE PRODUCTION
        CALL HWHREP
      ELSEIF (IPRO.EQ.13) THEN
C---GAMMA/Z0/Z' DRELL-YAN PROCESS
        CALL HWHDYP
      ELSEIF (IPRO.EQ.14) THEN
C---W+/- PRODUCTION VIA DRELL-YAN PROCESS
        CALL HWHWPR
      ELSEIF (IPRO.EQ.15) THEN
C---QCD HARD 2->2 PROCESSES
        CALL HWHQCD
      ELSEIF (IPRO.EQ.16) THEN
C---SM/MSSM HIGGS PRODUCTION VIA QUARK/GLUON FUSION
        CALL HWHIGS
      ELSEIF (IPRO.EQ.17) THEN
C---QCD HEAVY FLAVOUR PRODUCTION
        CALL HWHHVY
      ELSEIF (IPRO.EQ.18) THEN
C---QCD DIRECT PHOTON + JET PRODUCTION
        CALL HWHPHO
      ELSEIF (IPRO.EQ.19) THEN
C---HIGGS PRODUCTION VIA W FUSION
        CALL HWHIGW
      ELSEIF (IPRO.EQ.20) THEN
C---TOP PRODUCTION FROM W EXCHANGE
        CALL HWHWEX
      ELSEIF (IPRO.EQ.21) THEN
C---VECTOR BOSON + JET PRODUCTION
        CALL HWHV1J
      ELSEIF (IPRO.EQ.22) THEN
C QCD direct photon pair production
        CALL HWHPH2
      ELSEIF (IPRO.EQ.23) THEN
C QCD Higgs plus jet production
        CALL HWHIGJ
      ELSEIF (IPRO.EQ.24) THEN
C---COLOUR-SINGLET EXCHANGE
        CALL HWHSNG
      ELSEIF (IPRO.EQ.25) THEN
C---SM/MSSM neutral Higgs production with heavy quark flavours via qq and gg.
        CALL HWHIGQ
      ELSEIF ((IPRO.EQ.26).OR.(IPRO.EQ.27)) THEN
C---SM/MSSM Higgs production with heavy gauge bosons via qq(').
        CALL HWHIGV
      ELSEIF (IPRO.EQ.30) THEN
C---HADRON-HADRON SUSY PROCESSES
        CALL HWHSSP
      ELSEIF (IPRO.EQ.33) THEN
        IF(IPROC.EQ.3350)THEN
C---MSSM charged Higgs production in association with W: W+H- + W-H+.
          CALL HWHIBK
        ELSE
C---MSSM charged/neutral Higgs pair production.
          CALL HWHIGH
        END IF
      ELSEIF (IPRO.EQ.34) THEN
C---MSSM charged/neutral Higgs production via bg fusion.
        CALL HWHIBG
      ELSEIF(IPRO.EQ.40.OR.IPRO.EQ.41) THEN
C---HADRON-HADRON R-PARITY VIOLATING SUSY PROCESSES
        CALL HWHRSP
      ELSEIF (IPRO.EQ.42) THEN
C---SPIN-TWO RESONANCE
        CALL HWHGRV
      ELSEIF (IPRO.EQ.50) THEN
C Point-like photon two-jet production
        CALL HWHPPT
      ELSEIF (IPRO.EQ.51) THEN
C Point-like photon/QCD heavy flavour pair production
        CALL HWHPPH
      ELSEIF (IPRO.EQ.52) THEN
C Point-like photon/QCD heavy flavour single excitation
        CALL HWHPPE
      ELSEIF (IPRO.EQ.53) THEN
C Compton scattering of point-like photon and (anti)quark
        CALL HWHPQS
      ELSEIF (IPRO.EQ.55) THEN
C Point-like photon/higher twist meson production
        CALL HWHPPM
      ELSEIF (IPRO.EQ.60) THEN
C---QPM GAMMA-GAMMA-->QQBAR
        CALL HWHQPM
      ELSEIF (IPRO.GE.70.AND.IPRO.LE.79) THEN
C---BARYON-NUMBER VIOLATION, AND OTHER MULTI-W PRODUCTION PROCESSES
        CALL HVHBVI
      ELSEIF (IPRO.EQ.80) THEN
C---MINIMUM-BIAS: NO HARD SUBPROCESS
C   FIND WEIGHT
        CALL HWMWGT
      ELSEIF (IPRO.EQ.90) THEN
C---DEEP INELASTIC
        CALL HWHDIS
      ELSEIF(IPRO.EQ.91) THEN
C---BOSON - GLUON(QUARK) FUSION -->  ANTIQUARK(GLUON) + QUARK
        CALL HWHBGF
      ELSEIF(IPRO.EQ.92) THEN
C---DEEP INELASTIC WITH EXTRA JET: OBSOLETE PROCESS
        WRITE (6,40)
 40     FORMAT (1X,' IPROC=92** is no longer supported.'
     &         /1X,' Please use IPROC=91** instead.')
        CALL HWWARN('HWEPRO',500,*999)
      ELSEIF(IPRO.EQ.95) THEN
C---HIGGS PRODUCTION VIA W FUSION IN E P
        CALL HWHIGW
      ELSE
C---UNKNOWN PROCESS
        CALL HWWARN('HWEPRO',102,*999)
      ENDIF
 30   IF (GENEV) THEN
        IF (NOWGT) EVWGT=AVWGT
        ISTAT=10
        RETURN
      ELSE
C---IF AN EVENT IS CANCELLED BEFORE IT IS GENERATED, GIVE IT ZERO WEIGHT
        IF (IERROR.NE.0) THEN
          EVWGT=ZERO
          IERROR=0
        ENDIF
        EVWGT=EVWGT*GAMWT
        NWGTS=NWGTS+1
        WGTSUM=WGTSUM+EVWGT
        WSQSUM=WSQSUM+EVWGT**2
        IF (EVWGT.GT.WBIGST) THEN
          WBIGST=EVWGT
          IF (NOWGT.AND.WBIGST.GT.WGTMAX) THEN
            IF (NEVHEP.NE.0) CALL HWWARN('HWEPRO',1,*999)
            WGTMAX=WBIGST*1.1
            WRITE (6,99) WGTMAX
          ENDIF
        ELSEIF (EVWGT.LT.ZERO) THEN
          IF (EVWGT.LT.-1.D-9) CALL HWWARN('HWEPRO',3,*999)
          EVWGT=0.
        ENDIF
        IF (NEVHEP.NE.0) THEN
C---LOW EFFICIENCY WARNINGS:
C   WARN AT 10*EFFMIN, STOP AT EFFMIN
          IF (10*EFFMIN*NWGTS.GT.NEVHEP) THEN
            IF (EFFMIN*NWGTS.GT.NEVHEP) CALL HWWARN('HWEPRO',200,*999)
            IF (EFFMIN.GT.ZERO) THEN
              IF (MOD(NWGTS,INT(10/EFFMIN)).EQ.0) THEN
                CALL HWWARN('HWEPRO',2,*999)
                WRITE (6,98) WGTMAX
              ENDIF
            ENDIF
          ENDIF
          IF (NOWGT) THEN
            GENEV=EVWGT.GT.WGTMAX*HWRGEN(0)
          ELSE
            GENEV=EVWGT.NE.ZERO
          ENDIF
          IF (GENEV) GOTO 20
          GOTO 10
        ENDIF
      ENDIF
 98   FORMAT(10X,'    MAXIMUM WEIGHT =',1PG24.16)
 99   FORMAT(10X,'NEW MAXIMUM WEIGHT =',1PG24.16)
  999 END
CDECK  ID>, HWETWO.
*CMZ :-        -26/04/91  11.11.55  by  Bryan Webber
*-- Author :    Bryan Webber
C-----------------------------------------------------------------------
      SUBROUTINE HWETWO
C-----------------------------------------------------------------------
C     SETS UP 2->2 HARD SUBPROCESS
C-----------------------------------------------------------------------
      INCLUDE 'HERWIG62.INC'
      DOUBLE PRECISION HWUMBW,HWUPCM,PA,PCM
      INTEGER ICMF,IBM,I,J,K,IHEP,NTRY
      EXTERNAL HWUPCM
C---INCOMING LINES
      ICMF=NHEP+3
      DO 15 I=1,2
      IBM=I
C---FIND BEAM AND TARGET
      IF (JDAHEP(1,I).NE.0) IBM=JDAHEP(1,I)
      IHEP=NHEP+I
      IDHW(IHEP)=IDN(I)
      IDHEP(IHEP)=IDPDG(IDN(I))
      ISTHEP(IHEP)=110+I
      JMOHEP(1,IHEP)=ICMF
      JMOHEP(I,ICMF)=IHEP
      JDAHEP(1,IHEP)=ICMF
C---SPECIAL - IF INCOMING PARTON IS INCOMING BEAM THEN COPY IT
      IF (XX(I).EQ.ONE.AND.IDHW(IBM).EQ.IDN(I)) THEN
        CALL HWVEQU(5,PHEP(1,IBM),PHEP(1,IHEP))
        IF (I.EQ.2) PHEP(3,IHEP)=-PHEP(3,IHEP)
      ELSE
        PHEP(1,IHEP)=0.
        PHEP(2,IHEP)=0.
        PHEP(5,IHEP)=RMASS(IDN(I))
        PA=XX(I)*(PHEP(4,IBM)+ABS(PHEP(3,IBM)))
        PHEP(4,IHEP)=0.5*(PA+PHEP(5,IHEP)**2/PA)
        PHEP(3,IHEP)=PA-PHEP(4,IHEP)
      ENDIF
 15   CONTINUE
      PHEP(3,NHEP+2)=-PHEP(3,NHEP+2)
C---HARD CENTRE OF MASS
      IDHW(ICMF)=IDCMF
      IDHEP(ICMF)=IDPDG(IDCMF)
      ISTHEP(ICMF)=110
      CALL HWVSUM(4,PHEP(1,NHEP+1),PHEP(1,NHEP+2),PHEP(1,ICMF))
      CALL HWUMAS(PHEP(1,ICMF))
C---OUTGOING LINES
      NTRY=0
 19   CONTINUE
      DO 20 I=3,4
      IHEP=NHEP+I+1
      IDHW(IHEP)=IDN(I)
      IDHEP(IHEP)=IDPDG(IDN(I))
      ISTHEP(IHEP)=110+I
      JMOHEP(1,IHEP)=ICMF
      JDAHEP(I-2,ICMF)=IHEP
   20 PHEP(5,IHEP)=HWUMBW(IDN(I))
      PCM=HWUPCM(PHEP(5,NHEP+3),PHEP(5,NHEP+4),PHEP(5,NHEP+5))
      IF (PCM.LT.ZERO) THEN
        NTRY=NTRY+1
        IF (NTRY.LE.NETRY) GO TO 19
        CALL HWWARN('HWETWO',103,*999)
      ENDIF
      IHEP=NHEP+4
      PHEP(4,IHEP)=SQRT(PCM**2+PHEP(5,IHEP)**2)
      PHEP(3,IHEP)=PCM*COSTH
      PHEP(1,IHEP)=SQRT((PCM+PHEP(3,IHEP))*(PCM-PHEP(3,IHEP)))
      CALL HWRAZM(PHEP(1,IHEP),PHEP(1,IHEP),PHEP(2,IHEP))
      CALL HWULOB(PHEP(1,NHEP+3),PHEP(1,IHEP),PHEP(1,IHEP))
      CALL HWVDIF(4,PHEP(1,NHEP+3),PHEP(1,IHEP),PHEP(1,NHEP+5))
C---SET UP COLOUR STRUCTURE LABELS
      DO 30 I=1,4
      J=I
      IF (J.GT.2) J=J+1
      K=ICO(I)
      IF (K.GT.2) K=K+1
      JMOHEP(2,NHEP+J)=NHEP+K
   30 JDAHEP(2,NHEP+K)=NHEP+J
      NHEP=NHEP+5
  999 END
CDECK  ID>, HWH2BK.
*CMZ :-        -26/11/00  17.21.55  by  Bryan Webber
*-- Author :  Stefano Moretti
C-----------------------------------------------------------------------
      SUBROUTINE HWH2BK(P1,P2,P3,P4,RMW,RMH,RES,RESL,REST)
C-----------------------------------------------------------------------
C...Matrix element for q(1) + q-bar(2) -> W+/-(3) +  H-/+(4),
C...all masses retained.
C...It factorises (PIFAC*ALPHA/SWEIN/RMW/RMW/SQRT(2.))**2
C
C...First release:  1-APR-1998 by Stefano Moretti
C-----------------------------------------------------------------------
      INCLUDE 'HERWIG62.INC'
      INTEGER I
      DOUBLE PRECISION P1(0:3),P2(0:3),P3(0:3),P4(0:3)
      DOUBLE PRECISION P(0:3)
      DOUBLE PRECISION RES,S,T,U,MB2,MT2,MW2,MHP2,MH02,MA02,MSH2,
     &                 MGAMH0,MGAMA0,MGAMSH,PT,NC,KT2,RESL,REST
      DOUBLE PRECISION TT,UU,KKT2,TL
      DOUBLE COMPLEX Z,PV,PA
      DOUBLE PRECISION RMB,RMT,RMW,RMH
      DOUBLE PRECISION RMH01,GAMH01,
     &                 RMH02,GAMH02,
     &                 RMH03,GAMH03
      DOUBLE PRECISION VP,CFC
      EQUIVALENCE (RMB  ,RMASS(  5)),(RMT  ,RMASS(  6))
      EQUIVALENCE (RMH01,RMASS(204)),
     &            (RMH02,RMASS(203)),
     &            (RMH03,RMASS(205))
      PARAMETER (Z=(0.,1.),NC=3.)
C...Higgs widths.
      GAMH01=RMASS(204)/DKLTM(204)
      GAMH02=RMASS(203)/DKLTM(203)
      GAMH03=RMASS(205)/DKLTM(205)
C...constant terms.
      MB2=RMB*RMB
      MT2=RMT*RMT
      MW2=RMW*RMW
      MHP2=RMH  *RMH
      MH02=RMH01*RMH01
      MA02=RMH03*RMH03
      MSH2=RMH02*RMH02
      MGAMH0=RMH01*GAMH01
      MGAMA0=RMH03*GAMH03
      MGAMSH=RMH02*GAMH02
C...Mandelstam invariants.
      S=(P1(0)+P2(0))**2
      T=(P1(0)-P3(0))**2
      U=(P1(0)-P4(0))**2
        DO I=1,3
          S=S-(P1(I)+P2(I))**2
          T=T-(P1(I)-P3(I))**2
          U=U-(P1(I)-P4(I))**2
        END DO
C...propagators and couplings.
      PV=(-SINA*COSBMA/(S-MSH2+Z*MGAMSH)
     &    -COSA*SINBMA/(S-MH02+Z*MGAMH0) )/COSB
      PA=         TANB/(S-MA02+Z*MGAMA0)
      PT=         1./(T-MT2)
      KT2=(U*T-MHP2*MW2)/S
C...Total ME.
      RES=S/NC*( MB2/2.*((S-MW2-MHP2)**2-4.*MW2*MHP2)*
     & DREAL(DCONJG(PV)*PV+DCONJG(PA)*PA)+
     & MB2*TANB*PT*(MW2*MHP2-S*KT2-T**2)*DREAL(PV-PA)+
     & PT**2*((MT2/TANB)**2*(2.*MW2+KT2)
     & +MB2*TANB**2*(2.*MW2*KT2+T**2)))
     & *2.
C...Extracts spin dependence.
      VP=SQRT(P3(1)**2+P3(2)**2+P3(3)**2)
      CFC=P3(0)/VP
      DO I=1,3
        P(I)=P3(I)*CFC
      END DO
      P(0)=VP**2/P3(0)*CFC
      TT=(P1(0)-P(0))**2
      UU=(P2(0)-P(0))**2
      DO I=1,3
        TT=TT-(P1(I)-P(I))**2
        UU=UU-(P2(I)-P(I))**2
      END DO
      KKT2=((MW2+TT)*(MW2+UU)+(MW2+MHP2-T-U)*MW2)/S
      TL=((TT+MW2)*(UU+MW2)*((S+U-MW2)*(TT+MW2)/(UU+MW2)-T)
     &  +MW2*((MW2-T)*(MW2-U)-S*MW2))/S
C...Longitudinal ME (along V direction).
      RESL=S/NC*(MB2/2.*((S-MW2-MHP2)**2-4.*MW2*MHP2)*
     & DREAL(DCONJG(PV)*PV+DCONJG(PA)*PA)+
     & MB2*TANB*PT*(MW2*MHP2-S*KT2-T**2)*DREAL(PV-PA)+
     & PT**2*((MT2/TANB)**2*(KKT2)
     & +MB2*TANB**2*(TL)))
     & *2.
C...Transverse ME (perpendicular to V direction).
      REST=RES-RESL
 999  RETURN
      END
CDECK  ID>, HWH2QH.
*CMZ :-        -26/11/00  17.21.55  by  Bryan Webber
*-- Author :  Kosuke Odagiri
C-----------------------------------------------------------------------
      SUBROUTINE HWH2QH(SQS,P1,P2,P3,P4,P5,RM3,RM4,RM5,FACGPM,MGM3,
     & IGG,IQQ,GGQQHT,GGQQHU,GGQQHNP,QQQQH)
C-----------------------------------------------------------------------
C     MATRIX ELEMENT SQUARED FOR THE PROCESS GG/QQ(BAR) -> QQ(BAR) HIGGS
C-----------------------------------------------------------------------
C     NEEDS PREFACTOR G_S^4. COUPLINGS, E.G. FOR T(3)B(4)H-(5) ARE:
C     FACGPM(1) = GW/SQRT(TWO) M_B / M_W * TANB
C     FACGPM(2) = GW/SQRT(TWO) M_T / M_W / TANB
C     MGM3 = (TOP MASS)*(TOP WIDTH)
C     INITIAL STATE MOMENTA: P1=(SQS/2)(1,0,0,1), P2=(SQS/2)(1,0,0,-1)
C     PREFACTORS:
C     GGQQHTOT = (G_S**4)*(GGQQHT+GGQQHU-GGQQHNP/CAFAC**2)/(8.*CFFAC)
C     QQQQHTOT = (G_S**4)*(QQQQH                         )*(1.-1./CAFAC**2)/4.
C     N.B. SUBROUTINE CANNOT BE USED FOR PHOTON PHOTON -> ...
C-----------------------------------------------------------------------
      IMPLICIT NONE
C --- SUBPROCESS
      INTEGER IGG,IQQ
C --- CENTRE-OF-MASS ENERGY, FOUR-MOMENTA, MASSES AND WIDTHS
      DOUBLE PRECISION SQS,P1(0:3),P2(0:3),P3(0:3),P4(0:3),P5(0:3)
      DOUBLE PRECISION K3(0:3),K4(0:3), Q3(0:3),Q4(0:3), R3(0:3),R4(0:3)
      DOUBLE PRECISION RM3,RM4,RM5, MGM3,MGM4, TWOSQS
C --- SPINORS
      DOUBLE COMPLEX U0(4), F3(4,2),F4(4,2), F3K(4,2),F4K(4,2)
      DOUBLE COMPLEX F3Q(4,2,2),F4Q(4,2,2), F3R(4,2,2),F4R(4,2,2)
C --- MOMENTUM PROJECTION OPERATORS
      DOUBLE COMPLEX P3PROJ(4,4),P4PROJ(4,4),K3PROJ(4,4),K4PROJ(4,4)
      DOUBLE COMPLEX Q3PROJ(4,4),Q4PROJ(4,4),R3PROJ(4,4),R4PROJ(4,4)
C --- SPINOR INDICES AND PERMUTATION MATRICES
      INTEGER I,J,K,L, PERM0(4), PL(4,2),PR(4,2), PERMU0(4)
C --- CHIRALITY PROJECTION OPERATORS: 1 = - ,  2 = +
      DOUBLE PRECISION FACGPM(2),FACL(2,2),FACR(2,2),FAC0(2,2)
C --- GG AMPLITUDES
      DOUBLE COMPLEX AMPS1(2,2),AMPS2(2,2)
      DOUBLE COMPLEX AMPT1(2,2,2,2),AMPT2(2,2,2,2),AMPT3(2,2,2,2)
      DOUBLE COMPLEX AMPU1(2,2,2,2),AMPU2(2,2,2,2),AMPU3(2,2,2,2)
      DOUBLE COMPLEX AMPS, AMPT, AMPU, AMPST, AMPSU, AMPTU
      DOUBLE PRECISION AMPST2, AMPSU2, AMPTU2
      DOUBLE PRECISION GGQQHT,GGQQHU,GGQQHNP,QQQQH
C --- QQ AMPLITUDES
      DOUBLE PRECISION RM3452
      DOUBLE PRECISION S,PT32,PT42,PT52,GLAMBDA,LAMBDA,LAMBDAI,LA34,
     &                 PROP2,PROP3R,PROP3I,PROP4R,PROP4I,PROP34R,PT3452
      DOUBLE COMPLEX PROP3,PROP4,PROP
C --- CONSTANTS
      DOUBLE PRECISION ZERO,ONE,TWO,MONE,FAC
      DOUBLE COMPLEX CZERO,CONE
      INTEGER LEFT,RIGHT
C --- PARAMETER DEFINITIONS
      PARAMETER (ZERO=0.D0,ONE=1.D0,TWO=2.D0,MONE=-ONE, LEFT=1,RIGHT=2)
      PARAMETER (CZERO=(0.D0,0.D0),CONE=(1.D0,0.D0))
      DATA MGM4,U0,FAC0   /ZERO, 4*CONE        ,   ONE,ZERO, ZERO, ONE /
      DATA PERM0  ,PERMU0 / 1,2, 3,4           ,   1,0, 0,4            /
      DATA PL     ,PR     / 0,3, 0,1,  4,0, 2,0,   4,0, 2,0,  0,3, 0,1 /
      DATA FACL   ,FACR   /MONE, ONE,  ONE,MONE,   ONE,MONE, MONE, ONE /
      SAVE MGM4,PERM0,PL,FACL,PR,FACR,PERMU0,FAC0,U0
C --- INITIALIZE
      GGQQHT=ZERO
      GGQQHU=ZERO
      GGQQHNP=ZERO
      QQQQH=ZERO
C --- GG ME.
      IF(IGG.EQ.0)GOTO 100
      TWOSQS = 0.5D0/SQS
      DO I = 0, 3
       Q3(I) = P3(I)-P1(I)
       Q4(I) = P4(I)-P2(I)
       R3(I) = P3(I)-P2(I)
       R4(I) = P4(I)-P1(I)
       K3(I) = P3(I)+P5(I)
       K4(I) = P4(I)+P5(I)
      END DO
      CALL HWUMPO(P3, RM3,     (P3(0)-P3(3))  ,ZERO,P3PROJ, .FALSE.)
      CALL HWUMPO(P4,-RM4,     (P4(0)+P4(3))  ,ZERO,P4PROJ, .FALSE.)
      CALL HWUMPO(Q3, RM3,-SQS*(P3(0)-P3(3))  ,ZERO,Q3PROJ, .FALSE.)
      CALL HWUMPO(Q4,-RM4,-SQS*(P4(0)+P4(3))  ,ZERO,Q4PROJ, .FALSE.)
      CALL HWUMPO(R3, RM3,-SQS*(P3(0)+P3(3))  ,ZERO,R3PROJ, .FALSE.)
      CALL HWUMPO(R4,-RM4,-SQS*(P4(0)-P4(3))  ,ZERO,R4PROJ, .FALSE.)
      CALL HWUMPO(K3, RM4,SQS*(SQS-2.D0*P4(0)),MGM4,K3PROJ, .TRUE.)
      CALL HWUMPO(K4,-RM3,SQS*(SQS-2.D0*P3(0)),MGM3,K4PROJ, .TRUE.)
      DO I=1,2
       CALL  HWUMPP(P3PROJ,FAC0(1,I),PERMU0 ,U0     ,F3(1,I)   , LEFT)
       CALL  HWUMPP(K3PROJ,FACGPM   ,PERM0  ,F3(1,I),F3K(1,I)  , LEFT)
       CALL  HWUMPP(P4PROJ,FAC0(1,I),PERMU0 ,U0     ,F4(1,I)   , RIGHT)
       CALL  HWUMPP(K4PROJ,FACGPM   ,PERM0  ,F4(1,I),F4K(1,I)  , RIGHT)
       DO J=1,2
        CALL HWUMPP(Q3PROJ,FACL(1,J),PL(1,J),F3(1,I),F3Q(1,I,J), LEFT)
        CALL HWUMPP(R3PROJ,FACL(1,J),PL(1,J),F3(1,I),F3R(1,I,J), LEFT)
        CALL HWUMPP(R4PROJ,FACR(1,J),PR(1,J),F4(1,I),F4R(1,I,J), RIGHT)
        CALL HWUMPP(Q4PROJ,FACR(1,J),PR(1,J),F4(1,I),F4Q(1,I,J), RIGHT)
       END DO
      END DO
      DO I=1,2
       DO J=1,2
        AMPS1(I,J)=( - F3K(1,I)* F4(3,J) + F3K(2,I)* F4(4,J)
     &               + F3K(3,I)* F4(1,J) - F3K(4,I)* F4(2,J) ) * TWOSQS
        AMPS2(I,J)=( -  F3(1,I)*F4K(3,J) +  F3(2,I)*F4K(4,J)
     &               +  F3(3,I)*F4K(1,J) -  F3(4,I)*F4K(2,J) ) * TWOSQS
        DO K=1,2
         AMPT1(1,K,I,J)= F3K(1,I)*F4Q(4,J,K)-F3K(3,I)*F4Q(2,J,K)
         AMPT1(2,K,I,J)=-F3K(2,I)*F4Q(3,J,K)+F3K(4,I)*F4Q(1,J,K)
         AMPT3(K,1,I,J)= F3Q(1,I,K)*F4K(4,J)-F3Q(3,I,K)*F4K(2,J)
         AMPT3(K,2,I,J)=-F3Q(2,I,K)*F4K(3,J)+F3Q(4,I,K)*F4K(1,J)
         AMPU1(K,1,I,J)= F3K(1,I)*F4R(4,J,K)-F3K(3,I)*F4R(2,J,K)
         AMPU1(K,2,I,J)=-F3K(2,I)*F4R(3,J,K)+F3K(4,I)*F4R(1,J,K)
         AMPU3(1,K,I,J)= F3R(1,I,K)*F4K(4,J)-F3R(3,I,K)*F4K(2,J)
         AMPU3(2,K,I,J)=-F3R(2,I,K)*F4K(3,J)+F3R(4,I,K)*F4K(1,J)
         DO L=1,2
          AMPT2(K,L,I,J)
     &    = FACGPM(1)*( F3Q(1,I,K)*F4Q(1,J,L)+F3Q(2,I,K)*F4Q(2,J,L) )
     &    + FACGPM(2)*( F3Q(3,I,K)*F4Q(3,J,L)+F3Q(4,I,K)*F4Q(4,J,L) )
          AMPU2(L,K,I,J)
     &    = FACGPM(1)*( F3R(1,I,K)*F4R(1,J,L)+F3R(2,I,K)*F4R(2,J,L) )
     &    + FACGPM(2)*( F3R(3,I,K)*F4R(3,J,L)+F3R(4,I,K)*F4R(4,J,L) )
         END DO
        END DO
       END DO
      END DO
      AMPST2 = ZERO
      AMPSU2 = ZERO
      AMPTU2 = ZERO
      DO I = 1, 2
       DO J = 1, 2
        DO K = 1, 2
         DO L = 1, 2
          IF (I.NE.J) THEN
           AMPS  = AMPS1(K,L) - AMPS2(K,L)
          ELSE
           AMPS  = CZERO
          END IF
          AMPT   = AMPT1(I,J,K,L)+AMPT2(I,J,K,L)+AMPT3(I,J,K,L)
          AMPU   = AMPU1(I,J,K,L)+AMPU2(I,J,K,L)+AMPU3(I,J,K,L)
          AMPST  = AMPS - AMPT
          AMPSU  = AMPS + AMPU
          AMPTU  = AMPT + AMPU
          AMPST2 = AMPST2 + DREAL(DCONJG(AMPST)*AMPST)
          AMPSU2 = AMPSU2 + DREAL(DCONJG(AMPSU)*AMPSU)
          AMPTU2 = AMPTU2 + DREAL(DCONJG(AMPTU)*AMPTU)
         END DO
        END DO
       END DO
      END DO
      FAC  = (P3(0)-P3(3))*(P4(0)+P4(3))
      GGQQHT  = FAC*AMPST2
      GGQQHU  = FAC*AMPSU2
      GGQQHNP = FAC*AMPTU2
 100  CONTINUE
C --- QQ ME.
      IF(IQQ.EQ.0)GOTO 200
      S       = SQS**2
      PT32    = P3(1)**2+P3(2)**2
      PT42    = P4(1)**2+P4(2)**2
      PT52    = P5(1)**2+P5(2)**2
      PT3452  = (PT32+PT42-PT52)/TWO
      RM3452  = (RM3**2+RM4**2-RM5**2)/TWO
      GLAMBDA = FACGPM(1)**2+FACGPM(2)**2
      LAMBDA  = TWO*FACGPM(1)*FACGPM(2)/GLAMBDA
      LAMBDAI = (FACGPM(2)**2-FACGPM(1)**2)/GLAMBDA
      LA34    = S/TWO-SQS*P5(0)-RM3452-LAMBDA*RM3*RM4
      PROP3   = ONE/DCMPLX(SQS*(SQS-TWO*P4(0)),ZERO)
      PROP4   = ONE/DCMPLX(SQS*(SQS-TWO*P3(0)),MGM3)
      PROP    = PROP3+PROP4
      PROP2   = DREAL(DCONJG(PROP)*PROP)
      PROP3R  = DREAL(DCONJG(PROP)*PROP3)
      PROP3I  = DIMAG(DCONJG(PROP)*PROP3)
      PROP4R  = DREAL(DCONJG(PROP)*PROP4)
      PROP4I  = DIMAG(DCONJG(PROP)*PROP4)
      PROP34R = DREAL(DCONJG(PROP3)*PROP4)
      QQQQH   = TWO*GLAMBDA/S*(S*PROP2*(PT3452+TWO*P3(0)*P4(0)-
     & LA34)+TWO*LA34*(PROP3R*PT42+PROP4R*PT32-PROP34R*PT52)-TWO*SQS*((
     & PROP3R*(P3(0)*PT42+P4(0)*PT3452)+PROP4R*(P4(0)*PT32+P3(0)*PT3452)
     & )-(PROP3I*P4(3)-PROP4I*P3(3))*LAMBDAI*(P3(1)*P4(2)-P3(2)*P4(1))))
 200  CONTINUE
      RETURN
      END
CDECK  ID>, HWH2VH.
*CMZ :-        -26/11/00  17.21.55  by  Bryan Webber
*-- Author :  Stefano Moretti
C-----------------------------------------------------------------------
      SUBROUTINE HWH2VH(P1,P2,P3,P4,RMV,RES,RESL,REST)
C-----------------------------------------------------------------------
C...Matrix element for q(1) + q(')-bar(2) -> V(3) + Higgs(4),
C...V=Z(W+/-), all masses retained (but no Yukawa couplings to quarks).
C...It factorises 64.*PIFAC**3*ALPHA**3/4./SWEIN/SWEIN/SWEIN/EMW/EMW
C...times:
C...         (VQ*VQ+AQ*AQ)/(1.-SWEIN)/(1.-SWEIN)    if V=Z
C...         VCKM(q,q')**2                          if V=W+/-
C
C...First release:  1-APR-1998 by Stefano Moretti
C-----------------------------------------------------------------------
      IMPLICIT NONE
      DOUBLE PRECISION P1(0:3),P2(0:3),P3(0:3),P4(0:3)
      DOUBLE PRECISION P(0:3)
      DOUBLE PRECISION RMV,GAMV,RES,RESL,REST
      INTEGER I
      DOUBLE PRECISION S,S12,S13,S23
      DOUBLE PRECISION T,    T13,T23
      DOUBLE PRECISION PV,CFC
      PARAMETER (GAMV=0.D0)
      S=(P1(0)+P2(0))**2
      DO I=1,3
        S=S-(P1(I)+P2(I))**2
      END DO
      S12=P1(0)*P2(0)
      S13=P1(0)*P3(0)
      S23=P2(0)*P3(0)
      DO I=1,3
        S12=S12-P1(I)*P2(I)
        S13=S13-P1(I)*P3(I)
        S23=S23-P2(I)*P3(I)
      END DO
C...Total ME.
      RES=(S12+2.D0/RMV/RMV*(S13*S23))
     &   /((S-RMV**2)**2+GAMV**2*RMV**2)
     &   /12.D0
C...Extracts spin dependence.
      PV=SQRT(P3(1)**2+P3(2)**2+P3(3)**2)
      CFC=P3(0)/PV
      DO I=1,3
        P(I)=P3(I)*CFC
      END DO
      P(0)=PV**2/P3(0)*CFC
      T=P(0)**2
      DO I=1,3
        T=T-P(I)**2
      END DO
      T13=P1(0)*P(0)
      T23=P2(0)*P(0)
      DO I=1,3
        T13=T13-P1(I)*P(I)
        T23=T23-P2(I)*P(I)
      END DO
C...Longitudinal ME (along V direction).
      RESL=(2.D0/RMV/RMV*(T13*T23)-S12*T/RMV/RMV)
     &    /((S-RMV**2)**2+GAMV**2*RMV**2)
     &    /12.D0
C...Transverse ME (perpendicular to V direction).
      REST=RES-RESL
      RETURN
      END
CDECK  ID>, HWH4JT.
*CMZ :-        -01/04/99  19.47.55  by  Mike Seymour
*-- Author :    Ian Knowles
C-----------------------------------------------------------------------
      SUBROUTINE HWH4JT
C-----------------------------------------------------------------------
C     Four jet production in e^+e^- annihilation: qqbar+gg & qqbar+qqbar
C     IOP4JT controls the treatment of the colour flow interference term
C     qqbar-gg case:
C     IOP4JT(1)=0 neglect, =1 extreme 2341; =2 extreme 3421
C     qqbar-qqbar (identical quark flavour) case:
C     IOP4JT(2)=0 neglect, =1 extreme 4123; =2 extreme 2143
C
C     Matrix elements based on Ellis Ross & Terrano and Catani & Seymour
C
C     WARNING:  Phase space factor inaccurate for JADE y_cut > 0.14.
C-----------------------------------------------------------------------
      INCLUDE 'HERWIG62.INC'
      INTEGER LM,LP,IQK,I,J,IDMN,IDMX,ID1,ID2,IST(4)
      DOUBLE PRECISION HWRGEN,HWUALF,HWUAEM,HWULDO,HWH4J1,HWH4J2,
     & HWH4J4,HWH4J5,HWH4J6,HWH4J7,QNOW,Q2NOW,QLST,SCUT,PSFAC,FACT,
     & X12,X13,X14,X23,X24,X34,
     & COLA,COLB,COLC,CLF(7,6),P12,P13,P14,P23,P24,P34,FACTR,EP1,EP2,
     & EP3,EP4,GG1,GG2,GG12,GG3,GG13,GG23,GGINT,WTGG,QQ,QP,QQINT,QQ1,
     & QQ2,WTQQ,WTQP,HCS,WTAB,WTBA,WTOT,RCS,YLST
     $     ,EF,QF,E(4)
      LOGICAL INCLQG(6),INCLQQ(6,6),ORIENT
      EXTERNAL HWRGEN,HWUALF,HWUAEM,HWULDO,HWH4J1,HWH4J2,HWH4J4,
     & HWH4J5,HWH4J6,HWH4J7
      SAVE HCS,QLST,WTQP,WTQQ,WTGG,FACTR,COLA,COLB,COLC,IDMN,IDMX,
     & CLF,GG1,GG2,GGINT,INCLQG,INCLQQ,LM,LP,QQ1,QQ2,QQINT,FACT,ORIENT,
     & Q2NOW,SCUT,YLST
      DATA QLST,YLST,IST/-1D0,-1D0,113,114,114,114/
C
      IF (GENEV) THEN
        RCS=HCS*HWRGEN(0)
      ELSE
        IF (NHEP+5.GT.NMXHEP) CALL HWWARN('HWH4JT',100,*999)
        QNOW=PHEP(5,3)
        IF (QNOW.NE.QLST.OR.Y4JT.NE.YLST) THEN
          QLST=QNOW
          YLST=Y4JT
          Q2NOW=QNOW**2
          SCUT=Y4JT*Q2NOW
C Calculate allowed fraction of Phase Space using parameterization
          IF (DURHAM) THEN
            PSFAC=(1.-6.*Y4JT)**5.50*(1.-173.3*Y4JT*(1.-247.3*Y4JT
     &                              *(1.+148.3*Y4JT*(1.+3.913*Y4JT))))
     &                              /(1.-8.352*Y4JT*(1.-1102.*Y4JT
     &                              *(1.+1603.*Y4JT*(1.+22.99*Y4JT))))
          ELSE
            PSFAC=(1.-6.*Y4JT)**4.62*(1.-44.72*Y4JT*(1.-176.0*Y4JT
     &                              *(1.+102.9*Y4JT*(1.-6.579*Y4JT))))
     &                              /(1.-3.392*Y4JT*(1.-946.5*Y4JT
     &                              *(1.+423.4*Y4JT*(1.-3.971*Y4JT))))
          ENDIF
          FACT=GEV2NB*HWUAEM(Q2NOW)**2*CFFAC*FLOAT(NCOLO)*PSFAC
     &        /(THREE*16*PIFAC)
          COLA=CFFAC
          COLB=CFFAC-HALF*CAFAC
          COLC=HALF
          LM=1
          IF (JDAHEP(1,LM).NE.0) LM=JDAHEP(1,LM)
          LP=2
          IF (JDAHEP(1,LP).NE.0) LP=JDAHEP(1,LP)
          IQK=MOD(IPROC,10)
          IF (IQK.NE.0) THEN
            IDMN=IQK
            IDMX=IQK
          ELSE
            IDMN=1
            IDMX=6
          ENDIF
          DO 10 I=1,6
          CALL HWUCFF(11,I,Q2NOW,CLF(1,I))
          IF (QNOW.GT.TWO*(RMASS(I)+RMASS(13))) THEN
            INCLQG(I)=.TRUE.
          ELSE
            INCLQG(I)=.FALSE.
          ENDIF
          DO 10 J=I,6
          IF (QNOW.GT.TWO*(RMASS(I)+RMASS(J ))) THEN
            INCLQQ(I,J)=.TRUE.
            INCLQQ(J,I)=.TRUE.
          ELSE
            INCLQQ(I,J)=.FALSE.
            INCLQQ(J,I)=.FALSE.
          ENDIF
  10      CONTINUE
          IF (MOD(IPROC/10,10).EQ.5) THEN
            ORIENT=.FALSE.
          ELSE
            ORIENT=.TRUE.
          ENDIF
        ENDIF
C Generate phase space point and check it passes cuts
        CALL HWVEQU(5,PHEP(1,3),PHEP(1,NHEP+1))
        DO 20 I=2,5
  20    PHEP(5,NHEP+I)=0.
  30    CALL HWDFOR(PHEP(1,NHEP+1),PHEP(1,NHEP+2),PHEP(1,NHEP+3),
     &              PHEP(1,NHEP+4),PHEP(1,NHEP+5))
        IF (DURHAM) THEN
          P12=2*HWULDO(PHEP(1,NHEP+2),PHEP(1,NHEP+3))
          X12=MIN(PHEP(4,NHEP+2)/PHEP(4,NHEP+3),
     &          PHEP(4,NHEP+3)/PHEP(4,NHEP+2))*P12
          IF (X12.GT.SCUT) THEN
            P13=2*HWULDO(PHEP(1,NHEP+2),PHEP(1,NHEP+4))
            X13=MIN(PHEP(4,NHEP+2)/PHEP(4,NHEP+4),
     &            PHEP(4,NHEP+4)/PHEP(4,NHEP+2))*P13
            IF (X13.GT.SCUT) THEN
              P14=2*HWULDO(PHEP(1,NHEP+2),PHEP(1,NHEP+5))
              X14=MIN(PHEP(4,NHEP+2)/PHEP(4,NHEP+5),
     &              PHEP(4,NHEP+5)/PHEP(4,NHEP+2))*P14
              IF (X14.GT.SCUT) THEN
                P23=2*HWULDO(PHEP(1,NHEP+3),PHEP(1,NHEP+4))
                X23=MIN(PHEP(4,NHEP+3)/PHEP(4,NHEP+4),
     &                PHEP(4,NHEP+4)/PHEP(4,NHEP+3))*P23
                IF (X23.GT.SCUT) THEN
                  P24=2*HWULDO(PHEP(1,NHEP+3),PHEP(1,NHEP+5))
                  X24=MIN(PHEP(4,NHEP+3)/PHEP(4,NHEP+5),
     &                  PHEP(4,NHEP+5)/PHEP(4,NHEP+3))*P24
                  IF (X24.GT.SCUT) THEN
                    P34=2*HWULDO(PHEP(1,NHEP+4),PHEP(1,NHEP+5))
                    X34=MIN(PHEP(4,NHEP+4)/PHEP(4,NHEP+5),
     &                    PHEP(4,NHEP+5)/PHEP(4,NHEP+4))*P34
                    IF (X34.GT.SCUT) GOTO 40
                  ENDIF
                ENDIF
              ENDIF
            ENDIF
          ENDIF
        ELSE
          P12=2*HWULDO(PHEP(1,NHEP+2),PHEP(1,NHEP+3))
          IF (P12.GT.SCUT) THEN
            P13=2*HWULDO(PHEP(1,NHEP+2),PHEP(1,NHEP+4))
            IF (P13.GT.SCUT) THEN
              P14=2*HWULDO(PHEP(1,NHEP+2),PHEP(1,NHEP+5))
              IF (P14.GT.SCUT) THEN
                P23=2*HWULDO(PHEP(1,NHEP+3),PHEP(1,NHEP+4))
                IF (P23.GT.SCUT) THEN
                  P24=2*HWULDO(PHEP(1,NHEP+3),PHEP(1,NHEP+5))
                  IF (P24.GT.SCUT) THEN
                    P34=2*HWULDO(PHEP(1,NHEP+4),PHEP(1,NHEP+5))
                    IF (P34.GT.SCUT) GOTO 40
                  ENDIF
                ENDIF
              ENDIF
            ENDIF
          ENDIF
        ENDIF
C Failed cuts retry
        GOTO 30
C Passed cuts: calculate contributions to Matrix Elements
  40    EMSCA=SQRT(MIN(P12,P13,P14,P23,P24,P34))
        IF (DURHAM) EMSCA=SQRT(MIN(X12,X13,X14,X23,X24,X34))
        IF (FIX4JT) EMSCA=SQRT(SCUT)
        FACTR=FACT*HWUALF(1,EMSCA)**2
        IF (ORIENT) THEN
          QF=HWULDO(PHEP(1,LP),PHEP(1,3))
          EF=Q2NOW/(2*SQRT(QF**2-HWULDO(PHEP(1,LP),PHEP(1,LP))*Q2NOW))
          QF=HALF-EF*QF/Q2NOW
          DO I=1,4
            E(I)=EF*PHEP(I,LP)+QF*PHEP(I,3)
          ENDDO
          EP1=HWULDO(E,PHEP(1,NHEP+2))
          EP2=HWULDO(E,PHEP(1,NHEP+3))
          EP3=HWULDO(E,PHEP(1,NHEP+4))
          EP4=HWULDO(E,PHEP(1,NHEP+5))
        ENDIF
C q-qbar-g-g
        GG1=HWH4J1(P12,P13,P14,P23,P24,P34,EP1,EP2,EP3,EP4,ORIENT)
     &     +HWH4J1(P12,P24,P23,P14,P13,P34,EP2,EP1,EP4,EP3,ORIENT)
        GG2=HWH4J1(P12,P23,P24,P13,P14,P34,EP2,EP1,EP3,EP4,ORIENT)
     &     +HWH4J1(P12,P14,P13,P24,P23,P34,EP1,EP2,EP4,EP3,ORIENT)
        GG12=HWH4J2(P12,P13,P14,P23,P24,P34,EP1,EP2,EP3,EP4,ORIENT)
     &      +HWH4J2(P12,P14,P13,P24,P23,P34,EP1,EP2,EP4,EP3,ORIENT)
     &      +HWH4J2(P12,P23,P24,P13,P14,P34,EP2,EP1,EP3,EP4,ORIENT)
     &      +HWH4J2(P12,P24,P23,P14,P13,P34,EP2,EP1,EP4,EP3,ORIENT)
        GG3=HWH4J4(P12,P13,P14,P23,P24,P34,EP1,EP2,EP3,EP4,ORIENT)
     &     +HWH4J4(P12,P24,P23,P14,P13,P34,EP2,EP1,EP4,EP3,ORIENT)
        GG13=GG3+HWH4J5(P12,P13,P14,P23,P24,P34,EP1,EP2,EP3,EP4,ORIENT)
     &          +HWH4J5(P12,P24,P23,P14,P13,P34,EP2,EP1,EP4,EP3,ORIENT)
        GG23=GG3+HWH4J5(P12,P14,P13,P24,P23,P34,EP1,EP2,EP4,EP3,ORIENT)
     &          +HWH4J5(P12,P23,P24,P13,P14,P34,EP2,EP1,EP3,EP4,ORIENT)
C Add up weights
        GG1  =COLA*(GG1 +GG13)
        GG2  =COLA*(GG2 +GG23)
        GGINT=COLB*(GG12-GG13-GG23)
        WTGG=FACTR*(GG1+GG2+GGINT)
C q-qbar-q-qbar
        QP=HWH4J6(P13,P12,P14,P23,P34,P24,EP1,EP3,EP2,EP4,ORIENT)
     &    +HWH4J6(P24,P12,P23,P14,P34,P13,EP2,EP4,EP1,EP3,ORIENT)
     &    +HWH4J6(P13,P34,P23,P14,P12,P24,EP3,EP1,EP4,EP2,ORIENT)
     &    +HWH4J6(P24,P34,P14,P23,P12,P13,EP4,EP2,EP3,EP1,ORIENT)
        QQ=HWH4J6(P13,P23,P34,P12,P14,P24,EP3,EP1,EP2,EP4,ORIENT)
     &    +HWH4J6(P24,P23,P12,P34,P14,P13,EP2,EP4,EP3,EP1,ORIENT)
     &    +HWH4J6(P13,P14,P12,P34,P23,P24,EP1,EP3,EP4,EP2,ORIENT)
     &    +HWH4J6(P24,P14,P34,P12,P23,P13,EP4,EP2,EP1,EP3,ORIENT)
        QQINT=HWH4J7(P13,P12,P14,P23,P34,P24,EP1,EP3,EP2,EP4,ORIENT)
     &       +HWH4J7(P24,P12,P23,P14,P34,P13,EP2,EP4,EP1,EP3,ORIENT)
     &       +HWH4J7(P13,P23,P34,P12,P14,P24,EP3,EP1,EP2,EP4,ORIENT)
     &       +HWH4J7(P24,P23,P12,P34,P14,P13,EP2,EP4,EP3,EP1,ORIENT)
     &       +HWH4J7(P13,P14,P12,P34,P23,P24,EP1,EP3,EP4,EP2,ORIENT)
     &       +HWH4J7(P24,P14,P34,P12,P23,P13,EP4,EP2,EP1,EP3,ORIENT)
     &       +HWH4J7(P13,P34,P23,P14,P12,P24,EP3,EP1,EP4,EP2,ORIENT)
     &       +HWH4J7(P24,P34,P14,P23,P12,P13,EP4,EP2,EP3,EP1,ORIENT)
C Add up weights
        WTQP=FACTR*COLC*QP/TWO
        QQ1  =COLC*QP
        QQ2  =COLC*QQ
        QQINT=COLB*QQINT
        WTQQ=FACTR*(QQ1+QQ2+QQINT)/2
      ENDIF
C
      HCS=0.
      DO 60 ID1=IDMN,IDMX
      IF (INCLQG(ID1)) THEN
C Gluon channel
        HCS=HCS+CLF(1,ID1)*WTGG
        IF (GENEV.AND.HCS.GT.RCS) THEN
C Select colour flow
          WTAB=GG1
          WTBA=GG2
          IF (IOP4JT(1).EQ.1) THEN
            IF (GGINT.GE.ZERO) THEN
              WTAB=WTAB+GGINT
            ELSE
              WTBA=MAX(WTBA,WTBA+GGINT)
            ENDIF
          ELSEIF (IOP4JT(1).EQ.2) THEN
            IF (GGINT.GE.ZERO) THEN
              WTBA=WTBA+GGINT
            ELSE
              WTAB=MAX(WTAB,WTAB+GGINT)
            ENDIF
          ELSEIF (IOP4JT(1).NE.0) THEN
            CALL HWWARN('HWH4JT',101,*999)
          ENDIF
          WTOT=WTAB+WTBA
          IF (WTAB.GT.HWRGEN(1)*WTOT) THEN
            CALL HWHQCP( 13, 13,3142,91,*99)
          ELSE
            CALL HWHQCP( 13, 13,4123,92,*99)
          ENDIF
        ENDIF
      ENDIF
C Quark channels
      DO 50 ID2=1,6
C Identical quark pairs
      IF (ID1.EQ.ID2.AND.INCLQQ(ID1,ID1)) THEN
        HCS=HCS+CLF(1,ID1)*WTQQ
        IF (GENEV.AND.HCS.GT.RCS) THEN
C Select colour flow
          WTAB=QQ1
          WTBA=QQ2
          IF (IOP4JT(2).EQ.1) THEN
            IF (QQINT.GE.ZERO) THEN
              WTAB=WTAB+QQINT
            ELSE
              WTBA=MAX(WTBA,WTBA+QQINT)
            ENDIF
          ELSEIF (IOP4JT(2).EQ.2) THEN
            IF (QQINT.GE.ZERO) THEN
              WTBA=WTBA+QQINT
            ELSE
              WTAB=MAX(WTAB,WTAB+QQINT)
            ENDIF
          ELSEIF (IOP4JT(2).NE.0) THEN
            CALL HWWARN('HWH4JT',102,*999)
          ENDIF
          WTOT=WTAB+WTBA
          IF (WTAB.GT.HWRGEN(1)*WTOT) THEN
            CALL HWHQCP(ID1,ID1+6,4123,93,*99)
          ELSE
            CALL HWHQCP(ID1,ID1+6,2143,94,*99)
          ENDIF
        ENDIF
C Unlike quark pairs
      ELSEIF (INCLQQ(ID1,ID2)) THEN
        HCS=HCS+(CLF(1,ID1)+CLF(1,ID2))*WTQP
        IF (GENEV.AND.HCS.GT.RCS) CALL HWHQCP(ID2,ID2+6,4123,95,*99)
      ENDIF
  50  CONTINUE
  60  CONTINUE
      EVWGT=HCS
      RETURN
C Set up labels for selected final state
  99  IDN(1)=ID1
      IDN(2)=ID1+6
      J=NHEP+1
      IDHW(J)=200
      IDHEP(J)=23
      ISTHEP(J)=110
      JMOHEP(1,J)=LM
      JMOHEP(2,J)=LP
      JDAHEP(1,J)=NHEP+2
      JDAHEP(2,J)=NHEP+5
      DO 100 I=1,4
      J=NHEP+1+I
      IDHW(J)=IDN(I)
      IDHEP(J)=IDPDG(IDN(I))
      ISTHEP(J)=IST(I)
      JMOHEP(1,J)=NHEP+1
  100 JDAHEP(1,J)=0
C And colour structure pointers
      DO 110 I=1,4
      J=ICO(I)
      JMOHEP(2,NHEP+1+I)=NHEP+1+J
  110 JDAHEP(2,NHEP+1+J)=NHEP+1+I
      NHEP=NHEP+5
  999 END
CDECK  ID>, HWH4J1.
*CMZ :-        -01/04/99  19.47.55  by  Mike Seymour
*-- Author :    Ian Knowles
C-----------------------------------------------------------------------
      FUNCTION HWH4J1(S12,S13,S14,S23,S24,S34,EP1,EP2,EP3,EP4,ORIENT)
C-----------------------------------------------------------------------
C     Evaluate `ERT' functions A, B, C, D, E; S12=(p1+p2)^2 etc.
C-----------------------------------------------------------------------
      IMPLICIT NONE
      DOUBLE PRECISION HWH4J1,HWH4J2,HWH4J4,HWH4J5,HWH4J6,HWH4J7,
     & S12,S13,S14,S23,S24,S34,S123,S124,S134,S234,S,EP1,EP2,EP3,EP4,
     & SUM
      LOGICAL ORIENT
      S123=S12+S13+S23
      S124=S12+S14+S24
      S134=S13+S14+S34
      S234=S23+S24+S34
      S=S12+S13+S14+S23+S24+S34
      HWH4J1=(S12*((S12+S14+S23+S34)**2+S13*(S12+S14-S24)+S24*(S12+S23))
     &       +(S14*S23-S12*S34-S13*S24)*(S14+S23+S34)/2)
     &       /(S13*S24*S134*S234)
     &      +((S12+S24)*(S13+S34)-S14*S23)/(S13*S134**2)
     &      +2*S23*(S-S13)/(S13*S134*S24) + S34/(2*S13*S24)
      IF (ORIENT) THEN
        HWH4J1=HWH4J1
     &  +4*((EP1*EP1*((S-S13)*(S23+S24)-S24*S34)
     &      -EP1*EP2*(S12*(S123+S124)+(S+S12)*(S14+S23)+2*S14*S23
     &               +S24*S134+S234*(S13+2*S234))
     &      +EP1*EP3*(S*(S24-S12)+S12*S13+(S14+2*S234-S34)*S24)
     &      -EP1*EP4*(S12*S124+S23*(S+S12+S14))
     &      +EP2*EP2*((S-S24)*(S13+S14)+2*(S13+S34)*S234-S13*S34)
     &      -EP2*EP3*((S+S23)*(S12+S14)+(S12+2*(S23+S234))*S234)
     &      +EP2*EP4*(S12*(S24-S)+S13*(S+S23-S34)+2*(S13+S34-S234)*S234)
     &      +EP3*EP3*(S14+2*S234)*S24
     &      +EP3*EP4*(-S234*(2*(S12+S23)+S134)+S12*S34-S13*S24-S14*S23)
     &      +EP4*EP4*S13*S23)*S134
     &      +EP2*(EP1+EP3+EP4)*2*S14*S24*S234)/(S*S13*S24*S134**2*S234)
      ELSE
        HWH4J1=2*HWH4J1/3
      ENDIF
      RETURN
C-----------------------------------------------------------------------
      ENTRY HWH4J2(S12,S13,S14,S23,S24,S34,EP1,EP2,EP3,EP4,ORIENT)
C-----------------------------------------------------------------------
      S123=S12+S13+S23
      S124=S12+S14+S24
      S134=S13+S14+S34
      S234=S23+S24+S34
      S=S12+S13+S14+S23+S24+S34
      HWH4J2=(S12*S14*(S24+S34)+S24*(S12*(S14+S34)+S13*(S14-S24)))
     &       /(S14*S23*S13*S134)
     &      +S12*(S+S34)*S124/(S24*S234*S14*S134)
     &      -(S13*(2*(S12+S24)+S23)+S14**2)/(S134*S13*S14)
     &      +S12*S123*S124/(2*S13*S24*S14*S23)
      IF (ORIENT) THEN
        HWH4J2=HWH4J2
     &  +4*((EP1*EP1*(S12*S134*S234-4*S23*S24*S34)
     &      +EP1*EP2*(2*(2*S13*S234+S14*S123)*S24-S12*S134*(S+S12+S34))
     &      +EP1*EP3*(S12*(4*S24*S34-S134*(S12+S14-S24))
     &               -4*(S13*S24-S14*S23)*S24)
     &      +EP1*EP4*(4*(S13+S14)*S23*S24-S12*S134*(S12+S13-S23))
     &      +EP2*EP2*(S12*S134-4*S13*S24)*S134
     &      +EP2*EP3*(4*S13*(S12+S23+S24)*S24-S12*S134*(S12-S14+S24))
     &      -EP2*EP4*(4*(S12*(S14+S134)+S13*(S134-S234))*S24
     &               +S12*(S12-S13+S23)*S134)
     &      -EP3*EP3*4*S12*S14*S24
     &      -EP3*EP4*2*S12*(2*S14*S24+S12*S134))*S234
     &      +(EP1*(EP1*(S23+S24)+EP2*(S134-2*S))
     &       -(EP1+EP2)*(EP3+EP4)*S12+EP2*EP2*(S13+S14))*2*S14*S24*S123)
     &    /(2*S*S13*S14*S234*S23*S24*S134)
      ELSE
        HWH4J2=2*HWH4J2/3
      ENDIF
      RETURN
C-----------------------------------------------------------------------
      ENTRY HWH4J4(S12,S13,S14,S23,S24,S34,EP1,EP2,EP3,EP4,ORIENT)
C-----------------------------------------------------------------------
      S134=S13+S14+S34
      S234=S23+S24+S34
      S=S12+S13+S14+S23+S24+S34
      HWH4J4=-(S12*(S34*(3*(S+S34)+S12)-S134*S234-2*(S13*S24+S14*S23))
     &        +(S14*S23-S13*S24)*(S13-S14+S24-S23))/(2*S134*S234*S34**2)
     &      -(S12*(S134**2/2+2*S13*S14+S34*(S13+S14-S34))
     &       +S34*((S13+S14)*(S23+S24)+S14*S24+S13*S23)
     &       +(S13*S24-S14*S23)*(S14-S13))/(S34*S134)**2
      IF (ORIENT) THEN
        HWH4J4=HWH4J4
     &  +4*((-EP1*EP1*2*(S23+S24)*S34
     &       -EP1*EP2*(S13*(S23+3*S24)+S14*(3*S23+S24)-(4*S12-S34)*S34)
     &       +EP1*EP3*((2*S12-S24)*S34-(S13-S14)*S24)
     &       +EP1*EP4*((2*S12-S23)*S34+(S13-S14)*S23)
     &       -EP2*EP2*2*(S13+S14)*S34
     &       +EP2*EP3*(2*S12*S34-S14*(S23-S24+S34))
     &       +EP2*EP4*(2*S12*S34+S13*(S23-S24-S34))
     &       +EP3*EP3*2*S14*S24
     &       +EP3*EP4*2*(S12*S34-S13*S24-S14*S23)
     &       +EP4*EP4*2*S13*S23)/(S*S134*S234*S34**2)
     &      +(EP1*EP2*(S134*(S134+2*S34)+4*(S13*S14-S34**2))
     &       +EP2*EP3*2*(2*S13*S34+S14*(S13-S14+S34))
     &       +EP2*EP4*2*(2*S14*S34-S13*(S13-S14-S34)))
     &  /(S*(S134*S34)**2))
      ELSE
        HWH4J4=2*HWH4J4/3
      ENDIF
      RETURN
C-----------------------------------------------------------------------
      ENTRY HWH4J5(S12,S13,S14,S23,S24,S34,EP1,EP2,EP3,EP4,ORIENT)
C-----------------------------------------------------------------------
      S123=S12+S13+S23
      S124=S12+S14+S24
      S134=S13+S14+S34
      S234=S23+S24+S34
      S=S12+S13+S14+S23+S24+S34
      HWH4J5=(3*S12*S34**2-3*S13*S24*S34+3*S12*S24*S34+3*S14*S23*S34-
     $     S13*S24**2-S12*S23*S34+6*S12*S14*S34+2*S12*S13*S34-
     $     2*S12**2*S34+S14*S23*S24-3*S13*S23*S24-2*S13*S14*S24+
     $     4*S12*S14*S24+2*S12*S13*S24+3*S14*S23**2+2*S14**2*S23+
     $     2*S14**2*S12+2*S12**2*S14+6*S12*S14*S23-2*S12*S13**2-
     $     2*S12**2*S13)/(2*S13*S134*S234*S34)+
     $     (2*S12*S34**2-2*S13*S24*S34+S12*S24*S34+4*S13*S23*S34+
     $     4*S12*S14*S34+2*S12*S13*S34+2*S12**2*S34-S13*S24**2+
     $     3*S14*S23*S24+4*S13*S23*S24-2*S13*S14*S24+4*S12*S14*S24+
     $     2*S12*S13*S24+2*S14*S23**2+4*S13*S23**2+2*S13*S14*S23+
     $     2*S12*S14*S23+4*S12*S13*S23+2*S12*S14**2+4*S12**2*S13+
     $     4*S12*S13*S14+2*S12**2*S14)/(2*S13*S134*S24*S34)-
     $     (S12*S34**2-2*S14*S24*S34-2*S13*S24*S34-S14*S23*S34+
     $     S13*S23*S34+S12*S14*S34+2*S12*S13*S34-2*S14**2*S24-
     $     4*S13*S14*S24-4*S13**2*S24-S14**2*S23-S13**2*S23+
     $     S12*S13*S14-S12*S13**2)/(S13*S34*S134**2)
      IF (ORIENT) THEN
        SUM=
     &    +EP1*EP1*((S13-S14+S23-3*S24)*S34+(S134+S14+2*S34)*S234)
     &            *S24*S134
     &    +EP1*EP2*((2*(S12-S24)+S34)*S134-S14*(4*S12+S14+3*S23)
     &             +S13*(S13+S23)+S24*S34 )*S24*S134
     &    -EP1*EP2*(((2*S12*S134+S13*(2*(S12+S14+S23)-S24+S34)
     &              +S14*(S14-S23)+(2*S14-S34)*S234)*S234)*S134
     &             + 4*S13**2*S24*S234)
     &    +EP1*EP3*(S12*(2*S13-S134)+S13*(S24+2*S234)+S14*(3*S24-S234)
     &             +S34*(S234-3*S24))*S24*S134
     &    +EP1*EP4*((S12*(S13-S14+3*S34)-S23*(S13+3*S14-S34))*S24
     &             -(S12*(S13+S134+2*S34)+2*S13*S24
     &              +(S13-2*S14)*S23)*S234)*S134
     &    +EP2*EP2*(S13*((2*S13+S34)*S234+S24*(S134-2*S34))
     &             +2*S14*S134*(S24+S234))*S134
        SUM=SUM
     &    -EP2*EP3*(((S12*(S13+2*S14-S34)+S14*(S+2*S23-S34))*S24
     &              +(S12*(S13+S134)+(S13+S24+2*S234)*S14
     &               +2*S13*(2*S23+S34))*S234)*S134
     &             +4*S13**2*S24*S234)
     &    +EP2*EP4*(((S12*(S13-2*S134)+S13*(S+2*S23-3*S34))*S24
     &              -((S-3*S13+S23+2*S24)*S13+2*S12*S14
     &                +2*S14*(S23+2*S24))*S234)*S134-4*S13**2*S24*S234)
     &    +EP3*EP3*2*(S13*S234+S14*S24)*S24*S134
     &    +EP3*EP4*(2*(S12*S34-S13*S24-S14*S23)*S24
     &             -(S12*S134+2*S13*S23)*S234)*S134
     &    +EP4*EP4*2*(S12*S234+S23*S24)*S13*S134
        HWH4J5=HWH4J5+4*SUM/(S*S234*S134**2*S13*S34*S24)
      ELSE
        HWH4J5=2*HWH4J5/3
      ENDIF
      RETURN
C-----------------------------------------------------------------------
      ENTRY HWH4J6(S12,S13,S14,S23,S24,S34,EP1,EP2,EP3,EP4,ORIENT)
C-----------------------------------------------------------------------
      S123=S12+S13+S23
      S124=S12+S14+S24
      S134=S13+S14+S34
      S234=S23+S24+S34
      S=S12+S13+S14+S23+S24+S34
      HWH4J6=(S23*(S123*S234-S*S23)+S12*(S123*S124-S*S12))/(S13*S123)**2
     &     -(S12*S34*(S234-2*S23)+S14*S23*(S234-2*S34)
     &      -S13*S24*(S234+S13))/(S13**2*S123*S134)
      IF (ORIENT) THEN
        HWH4J6=HWH4J6
     &  +4*(-EP1*EP1*2*S23*S34
     &      +EP1*EP2*((S12-S23)*S34-S13*(S24-S34))
     &      +(EP1*EP3+EP2*EP4)*2*(S12*S34-S13*S24+S14*S23)
     &      -EP1*EP4*(S13*S24-(3*(S13+S14)+S34)*S23)
     &      -(EP1+EP2+EP3)*EP4*2
     &       *(S12*(S13+S23)+(S12+S13)*S23)*S134/S123
     &      +EP2*EP2*S13*(S14+S34)
     &      +EP2*EP3*(S13*(S14-S24)-(S12-S23)*S14)
     &      -EP3*EP3*2*S12*S14
     &      -EP3*EP4*(S13*S24-(3*(S13+S34)+S14)*S12)
     &      +EP4*EP4*(S12+S23)*S13)/(S*S134*S123*S13**2)
      ELSE
        HWH4J6=2*HWH4J6/3
      ENDIF
      RETURN
C-----------------------------------------------------------------------
      ENTRY HWH4J7(S12,S13,S14,S23,S24,S34,EP1,EP2,EP3,EP4,ORIENT)
C-----------------------------------------------------------------------
      S123=S12+S13+S23
      S124=S12+S14+S24
      S134=S13+S14+S34
      S234=S23+S24+S34
      S=S12+S13+S14+S23+S24+S34
      HWH4J7=((S12*S34+S13*S24-S14*S23)*(S13+S14+S23+S24)-2*S12*S24*S34)
     &      /(S13*S134*S23*S123)
     &      -S12*(S12*S-S123*S124)/(S123**2*S13*S23)
     &      -(S13+S14)*(S23+S24)*S34/(S13*S134*S23*S234)
      IF (ORIENT) THEN
        HWH4J7=HWH4J7
     &  +4*(+2*(EP1+EP2)*(S23*EP1-S13*EP2)*S34*S134
     &      -EP1*EP2*2*S34**2*S123
     &      +EP1*EP3*(S123*(S23+S24)*S34+2*S134*(S13*S24-S14*S23))
     &      +EP1*EP4*(S123*(S23+S24)*S34+2*S12**2*S134*S234/S123
     &               +2*S134*(S24*(S13-S12)-S23*(S12+S14)))
     &      +EP2*EP3*(2*(S12*S34+S13*S24-S14*S23)*S134
     &               +S123*(S13+S14)*S34)
     &      +EP2*EP4*(S123*(S13+S14)*S34+2*S12**2*S234*S134/S123
     &               -2*S134*(S12*S234-S13*S24+S14*S23))
     &      -EP3*EP3*S12*(2*S24*S134+S123*S34)
     &      +EP3*EP4*2*S12*(S134*(S23-S24)-S34*S123+S12*S134*S234/S123)
     &      +EP4*EP4*S12*(2*S23*S134-S123*S34))
     &     /(S*S13*S23*S123*S134*S234)
      ELSE
        HWH4J7=2*HWH4J7/3
      ENDIF
      RETURN
      END
CDECK  ID>, HWHBGF.
*CMZ :-        -26/04/91  11.11.55  by  Bryan Webber
*-- Author :    Giovanni Abbiendi & Luca Stanco
C-----------------------------------------------------------------------
      SUBROUTINE HWHBGF
C-----------------------------------------------------------------------
C     Order Alpha_s processes in charged lepton-hadron collisions
C
C       Process code IPROC has to be set in the Main Program
C       the following codes IPROC may be selected
C
C                9100 : NC  BOSON-GLUON FUSION
C                9100+IQK (IQK=1,...,6) :  produced flavour is IQK
C                9107 : produced  J/psi + gluon
C
C                9110 : NC  QCD COMPTON
C                9110+IQK (IQK=1,...,12) : struck parton is IQK
C
C                9130 : NC order alpha_s processes (9100+9110)
C
C       Select maximum and minimum generated flavour when IQK=0
C       setting IFLMIN and IFLMAX in the Main Program
C       (allowed values from 1 to 6), default are 1 and 5
C       allowing d,u,s,c,b,dbar,ubar,sbar,cbar,bbar
C
C           CHARGED CURRENT Boson-Gluon Fusion processes
C                9141 : CC  s cbar  (c sbar)
C                9142 : CC  b cbar  (c bbar)
C                9143 : CC  s tbar  (t cbar)
C                9144 : CC  b tbar  (t bbar)
C
C       other inputs : Q2MIN,Q2MAX,YBMIN,YBMAX,PTMIN,EMMIN,EMMAX
C       when IPROC=(1)9107 : as above but Q2WWMN, Q2WWMX substitute
C                            Q2MIN and Q2MAX (EPA is used); ZJMAX cut
C
C      Add 10000 to suppress soft remnant fragmentation
C
C      Mean EVWGT = cross section in nanoBarn
C
C-----------------------------------------------------------------------
      INCLUDE 'HERWIG62.INC'
      DOUBLE PRECISION HWRGEN,Y,Q2,SHAT,Z,PHI,AJACOB,DSIGMA,ME,MP,
     & ML,MREMIF(18),MFIN1(18),MFIN2(18),RS,SMA,W2,RSHAT,FSIGMA(18),
     & SIGSUM,PROB,PRAN,PVRT(4),X
      INTEGER LEP
      INTEGER IQK,IFLAVU,IFLAVD,IMIN,IMAX,IFL,IPROO,LEPFIN,ID1,ID2,I,IDD
      LOGICAL CHARGD,INCLUD(18),INSIDE(18)
      EXTERNAL HWRGEN
      SAVE LEPFIN,ID1,ID2,FSIGMA,SIGSUM
      COMMON /HWAREA/ Y,Q2,SHAT,Z,PHI,AJACOB,DSIGMA,ME,MP,ML,MREMIF,
     & MFIN1,MFIN2,RS,SMA,W2,RSHAT,IQK,IFLAVU,IFLAVD,IMIN,IMAX,IFL,LEP,
     & IPROO,CHARGD,INCLUD,INSIDE
C---Initialization
      IF (FSTWGT) THEN
C---LEP = 1 FOR LEPTONS, -1 FOR ANTILEPTONS
        LEP=0
        IF (IDHW(1).GE.121.AND.IDHW(1).LE.126) THEN
          LEP=1
        ELSEIF (IDHW(1).GE.127.AND.IDHW(1).LE.132) THEN
          LEP=-1
        ENDIF
        IF (LEP.EQ.0) CALL HWWARN('HWHBGF',500,*999)
        IPROO=MOD(IPROC,100)/10
        IF (IPROO.EQ.0.OR.IPROO.EQ.4) THEN
          IQK=MOD(IPROC,10)
          IFL=IQK
          IF (IQK.EQ.7) IFL=164
          CHARGD=IPROO.EQ.4
        ELSEIF (IPROO.EQ.1.OR.IPROO.EQ.2) THEN
          IQK=MOD(IPROC,100)-10
          IFL=IQK+6
          CHARGD=.FALSE.
        ELSEIF (IPROO.EQ.3) THEN
          IQK=0
          IFL=0
          CHARGD=.FALSE.
        ELSE
          CALL HWWARN('HWHBGF',501,*999)
        ENDIF
C
        LEPFIN = IDHW(1)
        IF(CHARGD) THEN
          LEPFIN = IDHW(1)+1
          IF (IQK.EQ.1) THEN
            IFLAVU=4
            IFLAVD=3
            ID1  = 3
            ID2  = 10
          ELSEIF (IQK.EQ.2) THEN
            IFLAVU=4
            IFLAVD=5
            ID1  = 5
            ID2  = 10
          ELSEIF (IQK.EQ.3) THEN
            IFLAVU=6
            IFLAVD=3
            ID1  = 3
            ID2  =12
          ELSE
            IFLAVU=6
            IFLAVD=5
            ID1  = 5
            ID2  =12
          ENDIF
          IF (LEP.EQ.-1) THEN
            IDD=ID1
            ID1=ID2-6
            ID2=IDD+6
          ENDIF
        ENDIF
C
        IF (IQK.EQ.0) THEN
          DO I=1,18
            INCLUD(I)=.TRUE.
          ENDDO
          IMIN=1
          IMAX=18
          DO I=1,6
            IF (I.LT.IFLMIN.OR.I.GT.IFLMAX) INCLUD(I)=.FALSE.
          ENDDO
          DO I=7,18
            IF (I.LE.12) THEN
              IF (I-6.LT.IFLMIN.OR.I-6.GT.IFLMAX) INCLUD(I)=.FALSE.
            ELSE
              IF (I-12.LT.IFLMIN.OR.I-12.GT.IFLMAX) INCLUD(I)=.FALSE.
            ENDIF
          ENDDO
          IF (IPROO.EQ.0) THEN
            DO I=7,18
              INCLUD(I)=.FALSE.
            ENDDO
            IMIN=IFLMIN
            IMAX=IFLMAX
          ELSEIF (IPROO.EQ.1.OR.IPROO.EQ.2) THEN
            DO I=1,6
              INCLUD(I)=.FALSE.
            ENDDO
            IMIN=IFLMIN+6
            IMAX=IFLMAX+12
          ELSEIF (IPROO.EQ.3) THEN
            IMIN=IFLMIN
            IMAX=IFLMAX+12
          ENDIF
        ELSEIF (IQK.NE.0 .AND. (.NOT.CHARGD)) THEN
          DO I=1,18
            INCLUD(I)=.FALSE.
          ENDDO
          IF (IFL.LE.18) THEN
            INCLUD(IFL)=.TRUE.
            IMIN=IFL
            IMAX=IFL
          ELSEIF (IFL.EQ.164) THEN
            INCLUD(7)=.TRUE.
            IMIN=7
            IMAX=7
          ENDIF
        ENDIF
      ENDIF
C---End of initialization
      IF(GENEV) THEN
      IF (.NOT.CHARGD) THEN
        IF (IQK.EQ.0) THEN
          PRAN= SIGSUM * HWRGEN(0)
          PROB=ZERO
          DO 10 IFL=IMIN,IMAX
            IF (.NOT.INSIDE(IFL)) GOTO 10
            PROB=PROB+FSIGMA(IFL)
            IF (PROB.GE.PRAN) GOTO 20
  10      CONTINUE
        ENDIF
C---at this point the subprocess has been selected (IFL)
  20    CONTINUE
        IF (IFL.LE.6) THEN
C---Boson-Gluon Fusion event
          IDHW(NHEP+1)=IDHW(1)
          IDHW(NHEP+2)=13
          IDHW(NHEP+3)=15
          IDHW(NHEP+4)=LEPFIN
          IDHW(NHEP+5)=IFL
          IDHW(NHEP+6)=IFL+6
        ELSEIF (IFL.GE.7.AND.IFL.LE.18) THEN
C---QCD_Compton event
          IDHW(NHEP+1)=IDHW(1)
          IDHW(NHEP+2)=IFL-6
          IDHW(NHEP+3)=15
          IDHW(NHEP+4)=LEPFIN
          IDHW(NHEP+5)=IFL-6
          IDHW(NHEP+6)=13
        ELSEIF (IFL.EQ.164) THEN
C---gamma+gluon-->J/Psi+gluon
          IDHW(NHEP+1)=IDHW(1)
          IDHW(NHEP+2)=13
          IDHW(NHEP+3)=15
          IDHW(NHEP+4)=LEPFIN
          IDHW(NHEP+5)=164
          IDHW(NHEP+6)=13
        ELSE
          CALL HWWARN('HWHBGF',503,*999)
        ENDIF
      ELSE
C---Charged current event of specified flavours
        IDHW(NHEP+1)=IDHW(1)
        IDHW(NHEP+2)=13
        IDHW(NHEP+3)=15
        IDHW(NHEP+4)=LEPFIN
        IDHW(NHEP+5)=ID1
        IDHW(NHEP+6)=ID2
      ENDIF
C
      DO 1 I=NHEP+1,NHEP+6
    1 IDHEP(I)=IDPDG(IDHW(I))
C
C---Codes common for all processes
      ISTHEP(NHEP+1)=111
      ISTHEP(NHEP+2)=112
      ISTHEP(NHEP+3)=110
      ISTHEP(NHEP+4)=113
      ISTHEP(NHEP+5)=114
      ISTHEP(NHEP+6)=114
C
      DO I=NHEP+1,NHEP+6
        JMOHEP(1,I)=NHEP+3
        JDAHEP(1,I)=0
      ENDDO
C---Incoming lepton
      JMOHEP(2,NHEP+1)=NHEP+4
      JDAHEP(2,NHEP+1)=NHEP+4
C---Hard Process C.M.
      JMOHEP(1,NHEP+3)=NHEP+1
      JMOHEP(2,NHEP+3)=NHEP+2
      JDAHEP(1,NHEP+3)=NHEP+4
      JDAHEP(2,NHEP+3)=NHEP+6
C---Outgoing lepton
      JMOHEP(2,NHEP+4)=NHEP+1
      JDAHEP(2,NHEP+4)=NHEP+1
C
      IF (IFL.LE.6 .OR. CHARGD) THEN
C---Codes for boson-gluon fusion processes
C---  Incoming gluon
        JMOHEP(2,NHEP+2)=NHEP+6
        JDAHEP(2,NHEP+2)=NHEP+5
C---  Outgoing quark
        JMOHEP(2,NHEP+5)=NHEP+2
        JDAHEP(2,NHEP+5)=NHEP+6
C---  Outgoing antiquark
        JMOHEP(2,NHEP+6)=NHEP+5
        JDAHEP(2,NHEP+6)=NHEP+2
      ELSEIF (IFL.GE.7 .AND. IFL.LE.12) THEN
C---Codes for V+q --> q+g
C---  Incoming quark
        JMOHEP(2,NHEP+2)=NHEP+5
        JDAHEP(2,NHEP+2)=NHEP+6
C---  Outgoing quark
        JMOHEP(2,NHEP+5)=NHEP+6
        JDAHEP(2,NHEP+5)=NHEP+2
C---  Outgoing gluon
        JMOHEP(2,NHEP+6)=NHEP+2
        JDAHEP(2,NHEP+6)=NHEP+5
      ELSEIF (IFL.GE.13 .AND. IFL.LE.18) THEN
C---Codes for V+qbar --> qbar+g
C---  Incoming antiquark
        JMOHEP(2,NHEP+2)=NHEP+6
        JDAHEP(2,NHEP+2)=NHEP+5
C---  Outgoing antiquark
        JMOHEP(2,NHEP+5)=NHEP+2
        JDAHEP(2,NHEP+5)=NHEP+6
C---  Outgoing gluon
        JMOHEP(2,NHEP+6)=NHEP+5
        JDAHEP(2,NHEP+6)=NHEP+2
      ELSEIF (IFL.EQ.164) THEN
C---Codes for Gamma+gluon --> J/Psi+gluon
C---  Incoming gluon
        JMOHEP(2,NHEP+2)=NHEP+6
        JDAHEP(2,NHEP+2)=NHEP+6
C---  Outgoing J/Psi
        JMOHEP(2,NHEP+5)=NHEP+1
        JDAHEP(2,NHEP+5)=NHEP+1
C---  Outgoing gluon
        JMOHEP(2,NHEP+6)=NHEP+2
        JDAHEP(2,NHEP+6)=NHEP+2
      ENDIF
C---Computation of momenta in Laboratory frame of reference
      CALL HWHBKI
      NHEP=NHEP+6
C Decide which quark radiated and assign production vertices
      IF (IFL.LE.6) THEN
C Boson-Gluon fusion case
        IF (1-Z.LT.HWRGEN(0)) THEN
C Gluon splitting to quark
          CALL HWVZRO(4,VHEP(1,NHEP-1))
          CALL HWVDIF(4,PHEP(1,NHEP-4),PHEP(1,NHEP),PVRT)
          CALL HWUDKL(IFL,PVRT,VHEP(1,NHEP))
          CALL HWVEQU(4,VHEP(1,NHEP),VHEP(1,NHEP-4))
        ELSE
C Gluon splitting to antiquark
          CALL HWVZRO(4,VHEP(1,NHEP))
          CALL HWVDIF(4,PHEP(1,NHEP-4),PHEP(1,NHEP-1),PVRT)
          CALL HWUDKL(IFL,PVRT,VHEP(1,NHEP-1))
          CALL HWVEQU(4,VHEP(1,NHEP-1),VHEP(1,NHEP-4))
        ENDIF
      ELSEIF (IFL.GE.7.AND.IFL.LE.18) THEN
C QCD Compton case
        X=1/(1+SHAT/Q2)
        IF (1.LT.HWRGEN(0)*(1+(1-X-Z)**2+6*X*(1-X)*Z*(1-Z))) THEN
C Incoming quark radiated the gluon
          CALL HWVZRO(4,VHEP(1,NHEP-1))
          CALL HWVDIF(4,PHEP(1,NHEP-4),PHEP(1,NHEP),PVRT)
          CALL HWUDKL(IFL-6,PVRT,VHEP(1,NHEP))
          CALL HWVEQU(4,VHEP(1,NHEP),VHEP(1,NHEP-4))
        ELSE
C Outgoing quark radiated the gluon
          CALL HWVZRO(4,VHEP(1,NHEP-4))
          CALL HWVSUM(4,PHEP(1,NHEP-1),PHEP(1,NHEP),PVRT)
          CALL HWUDKL(IFL-6,PVRT,VHEP(1,NHEP))
          CALL HWVEQU(4,VHEP(1,NHEP),VHEP(1,NHEP-1))
        ENDIF
      ENDIF
C---HERWIG gets confused if lepton momentum is different from beam
C   momentum, which it can be if incoming hadron has negative virtuality
C   As a temporary fix, simply copy the momentum.
C   Momentum conservation somehow gets taken care of HWBGEN!
      call hwvequ(5,phep(1,1),phep(1,nhep-5))
      ELSE
        EVWGT=ZERO
C---generation of the 5 variables Y,Q2,SHAT,Z,PHI and Jacobian computation
C---in the largest phase space avalaible for selected processes and
C---filling of logical vector INSIDE to tag contributing ones
        CALL HWHBRN (*999)
C---calculate differential cross section corresponding to the chosen
C---variables and the weight for MC generation
        IF (IQK.EQ.0) THEN
C---many subprocesses included
          DO I=1,18
            FSIGMA(I)=ZERO
          ENDDO
          SIGSUM=ZERO
          DO I=IMIN,IMAX
            IF (INSIDE(I)) THEN
              IFL=I
              DSIGMA=ZERO
              CALL HWHBSG
              FSIGMA(I)=DSIGMA
              SIGSUM=SIGSUM+DSIGMA
            ENDIF
          ENDDO
          EVWGT=SIGSUM * AJACOB
        ELSE
C---only one subprocess included
          CALL HWHBSG
          EVWGT= DSIGMA * AJACOB
        ENDIF
        IF (EVWGT.LT.ZERO) EVWGT=ZERO
      ENDIF
  999 END
CDECK  ID>, HWHBKI.
*CMZ :-        -26/04/91  13.19.32  by  Federico Carminati
*-- Author :    Giovanni Abbiendi & Luca Stanco
C----------------------------------------------------------------------
      SUBROUTINE HWHBKI
C----------------------------------------------------------------------
C     gives the fourmomenta in the laboratory system for the particles
C     of the hard 2-->3 subprocess, to match with HERWIG routines of
C     jet evolution.
C----------------------------------------------------------------------
      INCLUDE 'HERWIG62.INC'
      DOUBLE PRECISION HWUECM,HWUPCM,HWUSQR,Y,Q2,SHAT,Z,PHI,AJACOB,
     & DSIGMA,ME,MP,ML,MREMIF(18),MFIN1(18),MFIN2(18),RS,SMA,W2,RSHAT,
     & PGAMMA(5),SG,MF1,MF2,EP,PP,EL,PL,E1,E2,Q1,COSBET,SINBET,COSTHE,
     & SINTHE,SINAZI,COSAZI,ROTAZI(3,3),EGAM,A,PPROT,MREMIN,PGAM,PEP(5),
     & COSPHI,SINPHI,ROT(3,3),EPROT,PROTON(5),MPART
      INTEGER IQK,IFLAVU,IFLAVD,IMIN,IMAX,IFL,IPROO,I,IHAD,J,IS,ICMF,LEP
      LOGICAL CHARGD,INCLUD(18),INSIDE(18)
      EXTERNAL HWUECM,HWUPCM,HWUSQR
      COMMON /HWAREA/ Y,Q2,SHAT,Z,PHI,AJACOB,DSIGMA,ME,MP,ML,MREMIF,
     & MFIN1,MFIN2,RS,SMA,W2,RSHAT,IQK,IFLAVU,IFLAVD,IMIN,IMAX,IFL,LEP,
     & IPROO,CHARGD,INCLUD,INSIDE
C
      IHAD=2
      IF (JDAHEP(1,IHAD).NE.0) IHAD=JDAHEP(1,IHAD)
C---Set masses
      IF (CHARGD) THEN
        MPART=ZERO
        MF1=RMASS(IDHW(NHEP+5))
        MF2=RMASS(IDHW(NHEP+6))
        MREMIN=MP
      ELSE
        IS = IFL
        IF (IFL.EQ.164) IS=IQK
        MPART=ZERO
        IF (IFL.GE.7.AND.IFL.LE.18) MPART=RMASS(IFL-6)
        MF1=MFIN1(IS)
        MF2=MFIN2(IS)
        MREMIN = MREMIF(IS)
      ENDIF
C---Calculation of kinematical variables for the generated event
C   in the center of mass frame of the incoming boson and parton
C   with parton along +z
      EGAM = HWUECM (SHAT, -Q2, MPART**2)
      PGAM = SQRT( EGAM**2 + Q2 )
      EP = RSHAT-EGAM
      PP = PGAM
      A = (W2+Q2-MP**2)/TWO
      PPROT = (A*PGAM-EGAM*SQRT(A**2+MP**2*Q2))/Q2
      IF (PPROT.LT.ZERO) CALL HWWARN('HWHBKI',101,*999)
      EPROT = SQRT(PPROT**2+MP**2)
      IF ((EPROT+PPROT).LT.(EP+PP)) CALL HWWARN('HWHBKI',102,*999)
      EL = ( PGAM / PPROT * SMA - Q2 ) / TWO
     +     / (EGAM + PGAM / PPROT * EPROT)
      IF (EL.GT.ME) THEN
        PL = SQRT ( EL**2 - ME**2 )
      ELSE
        CALL HWWARN ('HWHBKI',103,*999)
      ENDIF
      COSBET = (TWO * EPROT * EL - SMA) / (TWO * PPROT * PL)
      IF ( ABS(COSBET) .GE. ONE ) THEN
        COSBET = SIGN (ONE,COSBET)
        SINBET = ZERO
      ELSE
        SINBET = SQRT (ONE - COSBET**2)
      ENDIF
      SG = ME**2 + MPART**2 + Q2 + TWO * RSHAT * EL
      IF (SG.LE.(RSHAT+ML)**2 .OR. SG.GE.(RS-MREMIN)**2)
     +    CALL HWWARN ('HWHBKI',104,*999)
      Q1 = HWUPCM( RSHAT, MF1, MF2)
      E1 = SQRT(Q1**2+MF1**2)
      E2 = SQRT(Q1**2+MF2**2)
      IF (Q1 .GT. ZERO) THEN
        COSTHE=(TWO*EP*E1 - Z*(SHAT+Q2))/(TWO*PP*Q1)
        IF (ABS(COSTHE) .GT. ONE) THEN
          COSTHE=SIGN(ONE,COSTHE)
          SINTHE=ZERO
        ELSE
          SINTHE=SQRT(ONE-COSTHE**2)
        ENDIF
      ELSE
        COSTHE=ZERO
        SINTHE=ONE
      ENDIF
C---Initial lepton
      PHEP(1,NHEP+1)=PL*SINBET
      PHEP(2,NHEP+1)=ZERO
      PHEP(3,NHEP+1)=PL*COSBET
      PHEP(4,NHEP+1)=EL
      PHEP(5,NHEP+1)=RMASS(IDHW(1))
C---Initial Hadron
      PROTON(1)=ZERO
      PROTON(2)=ZERO
      PROTON(3)=PPROT
      PROTON(4)=EPROT
      CALL HWUMAS (PROTON)
C---Initial parton
      PHEP(1,NHEP+2)=ZERO
      PHEP(2,NHEP+2)=ZERO
      PHEP(3,NHEP+2)=PP
      PHEP(4,NHEP+2)=EP
      PHEP(5,NHEP+2)=MPART
C---HARD SUBPROCESS 2-->3 CENTRE OF MASS
      PHEP(1,NHEP+3)=PHEP(1,NHEP+1)+PHEP(1,NHEP+2)
      PHEP(2,NHEP+3)=PHEP(2,NHEP+1)+PHEP(2,NHEP+2)
      PHEP(3,NHEP+3)=PHEP(3,NHEP+1)+PHEP(3,NHEP+2)
      PHEP(4,NHEP+3)=PHEP(4,NHEP+1)+PHEP(4,NHEP+2)
      CALL HWUMAS  ( PHEP(1,NHEP+3) )
C---Virtual boson
      PGAMMA(1)=ZERO
      PGAMMA(2)=ZERO
      PGAMMA(3)=-PGAM
      PGAMMA(4)=EGAM
      PGAMMA(5)=HWUSQR(Q2)
C---Scattered lepton
      PHEP(1,NHEP+4)=PHEP(1,NHEP+1)-PGAMMA(1)
      PHEP(2,NHEP+4)=PHEP(2,NHEP+1)-PGAMMA(2)
      PHEP(3,NHEP+4)=PHEP(3,NHEP+1)-PGAMMA(3)
      PHEP(4,NHEP+4)=PHEP(4,NHEP+1)-PGAMMA(4)
      PHEP(5,NHEP+4)=RMASS(IDHW(1))
      IF (CHARGD) PHEP(5,NHEP+4)=ZERO
C---First Final parton:  quark (or J/psi) in Boson-Gluon Fusion
C---                     quark or antiquark in QCD Compton
      PHEP(1,NHEP+5)=Q1*SINTHE*COS(PHI)
      PHEP(2,NHEP+5)=Q1*SINTHE*SIN(PHI)
      PHEP(3,NHEP+5)=Q1*COSTHE
      PHEP(4,NHEP+5)=E1
      PHEP(5,NHEP+5)=MF1
C---Second Final parton: antiquark in Boson-Gluon Fusion
C---                     gluon in QCD Compton
      PHEP(1,NHEP+6)=-PHEP(1,NHEP+5)
      PHEP(2,NHEP+6)=-PHEP(2,NHEP+5)
      PHEP(3,NHEP+6)=-PHEP(3,NHEP+5)
      PHEP(4,NHEP+6)=E2
      PHEP(5,NHEP+6)=MF2
C---Boost to lepton-hadron CM frame
      PEP(1) = PHEP(1,NHEP+1)
      PEP(2) = PHEP(2,NHEP+1)
      PEP(3) = PHEP(3,NHEP+1) + PPROT
      PEP(4) = PHEP(4,NHEP+1) + EPROT
      CALL HWUMAS (PEP)
      DO I=1,6
        CALL HWULOF (PEP,PHEP(1,NHEP+I),PHEP(1,NHEP+I))
      ENDDO
      CALL HWULOF (PEP,PROTON,PROTON)
      CALL HWULOF (PEP,PGAMMA,PGAMMA)
C---Rotation around y-axis to align lepton beam with z-axis
      COSPHI = PHEP(3,NHEP+1) /
     &           SQRT( PHEP(1,NHEP+1)**2 + PHEP(3,NHEP+1)**2 )
      SINPHI = PHEP(1,NHEP+1) /
     &           SQRT( PHEP(1,NHEP+1)**2 + PHEP(3,NHEP+1)**2 )
      DO I=1,3
      DO J=1,3
        ROT(I,J)=ZERO
      ENDDO
      ENDDO
        ROT(1,1) = COSPHI
        ROT(1,3) = -SINPHI
        ROT(2,2) = ONE
        ROT(3,1) = SINPHI
        ROT(3,3) = COSPHI
      DO I=1,6
        CALL HWUROF (ROT,PHEP(1,NHEP+I),PHEP(1,NHEP+I))
      ENDDO
      CALL HWUROF (ROT,PROTON,PROTON)
      CALL HWUROF (ROT,PGAMMA,PGAMMA)
C---Boost to the LAB frame
      ICMF=3
      DO I=1,6
        CALL HWULOB (PHEP(1,ICMF),PHEP(1,NHEP+I),PHEP(1,NHEP+I))
      ENDDO
      CALL HWULOB (PHEP(1,ICMF),PROTON,PROTON)
      CALL HWULOB (PHEP(1,ICMF),PGAMMA,PGAMMA)
C---Random azimuthal rotation
      CALL HWRAZM (ONE,COSAZI,SINAZI)
      DO I=1,3
      DO J=1,3
        ROTAZI(I,J)=ZERO
      ENDDO
      ENDDO
        ROTAZI(1,1) = COSAZI
        ROTAZI(1,2) = SINAZI
        ROTAZI(2,1) = -SINAZI
        ROTAZI(2,2) = COSAZI
        ROTAZI(3,3) = ONE
      DO I=1,6
        CALL HWUROF (ROTAZI,PHEP(1,NHEP+I),PHEP(1,NHEP+I))
      ENDDO
      CALL HWUROF (ROTAZI,PROTON,PROTON)
      CALL HWUROF (ROTAZI,PGAMMA,PGAMMA)
  999 END
CDECK  ID>, HWHBRN.
*CMZ :-        -03/07/95  19.02.12  by  Giovanni Abbiendi
*-- Author :    Giovanni Abbiendi & Luca Stanco
C-----------------------------------------------------------------------
      SUBROUTINE HWHBRN (*)
C----------------------------------------------------------------------
C     Returns a point in the phase space (Y,Q2,SHAT,Z,PHI) and the
C     corresponding Jacobian factor AJACOB
C     Fill the logical vector INSIDE to tag contributing subprocesses
C     to the cross-section
C-----------------------------------------------------------------------
      INCLUDE 'HERWIG62.INC'
      DOUBLE PRECISION HWRUNI,HWRGEN,HWUPCM,Y,Q2,SHAT,Z,PHI,AJACOB,
     & DSIGMA,ME,MP,ML,MREMIF(18),MFIN1(18),MFIN2(18),RS,SMA,W2,RSHAT,
     & MF1,MF2,YMIN,YMAX,YJAC,Q2INF,Q2SUP,Q2JAC,EMW2,ZMIN,ZMAX,ZJAC,
     & GAMMA2,LAMBDA,PHIJAC,ZINT,ZLMIN,ZL,EMW,TMIN,TMAX,EMLMIN,EMLMAX,
     & SHMIN,EMMIF(18),EMMAF(18),WMIF(18),WMIN,MREMIN,YMIF(18),Q1CM(18),
     & Q2MAF(18),EMMAWF(18),ZMIF(18),ZMAF(18),PLMAX,PINC,SHINF,SHSUP,
     & SHJAC,CTHLIM,Q1,DETDSH,SRY,SRY0,SRY1
      INTEGER LEP
      INTEGER IQK,IFLAVU,IFLAVD,I,IMIN,IMAX,IFL,IPROO,IHAD,NTRY,DEBUG
      LOGICAL CHARGD,INCLUD(18),INSIDE(18)
      EXTERNAL HWRUNI,HWRGEN,HWUPCM
      SAVE EMLMIN,EMLMAX,EMMIF,EMMAF,MREMIN,MF1,MF2,YMIF,
     &     YMIN,YMAX,WMIN,WMIF
      COMMON /HWAREA/ Y,Q2,SHAT,Z,PHI,AJACOB,DSIGMA,ME,MP,ML,MREMIF,
     & MFIN1,MFIN2,RS,SMA,W2,RSHAT,IQK,IFLAVU,IFLAVD,IMIN,IMAX,IFL,LEP,
     & IPROO,CHARGD,INCLUD,INSIDE
      EQUIVALENCE (EMW,RMASS(198))
C
      IHAD=2
      IF (JDAHEP(1,IHAD).NE.0) IHAD=JDAHEP(1,IHAD)
C---Initialization
      IF (FSTWGT.OR.IHAD.NE.2) THEN
        ME = RMASS(IDHW(1))
        MP = RMASS(IDHW(IHAD))
        RS = PHEP(5,3)
        SMA = RS**2-ME**2-MP**2
        PINC = HWUPCM(RS,ME,MP)
C---Charged current
        IF (CHARGD) THEN
          ML=RMASS(IDHW(1)+1)
          YMAX = ONE - TWO*ML*MP / SMA
          YMAX = MIN(YMAX,YBMAX)
          MREMIN=MP
          IF (LEP.EQ.1) THEN
            MF1=RMASS(IFLAVD)
            MF2=RMASS(IFLAVU)
          ELSE
            MF1=RMASS(IFLAVU)
            MF2=RMASS(IFLAVD)
          ENDIF
          SHMIN = MF1**2+MF2**2 + TWO * PTMIN**2 +
     +            TWO * SQRT(PTMIN**2+MF1**2) * SQRT(PTMIN**2+MF2**2)
          EMLMIN=MAX(EMMIN,SQRT(SHMIN))
          EMLMAX=MIN(EMMAX,RS-ML-MREMIN)
          DEBUG=1
          IF (EMLMIN.GT.EMLMAX) GOTO 888
          WMIN=EMLMIN+MREMIN
          PLMAX=HWUPCM(RS,ML,WMIN)
          YMIN = ONE-TWO*(SQRT(PINC**2+MP**2)*SQRT(PLMAX**2+ML**2)+
     +                    PINC*PLMAX)/SMA
          YMIN = MAX(YMIN,YBMIN)
          DEBUG=2
          IF (YMIN.GT.YMAX) GOTO 888
        ELSE
C---Neutral current
          ML = ME
          YMAX = ONE - TWO*ML*MP / SMA
          YMAX = MIN(YMAX,YBMAX)
          DO I=1,18
            YMIF(I)=ZERO
            EMMIF(I)=ZERO
            EMMAF(I)=ZERO
            WMIF(I)=ZERO
            IF (I.LE.8) THEN
C---Boson-Gluon Fusion (also J/Psi) and QCD Compton with struck u or d
              MREMIF(I)=MP
              IF (I.LE.6) THEN
                MFIN1(I)=RMASS(I)
                MFIN2(I)=RMASS(I+6)
              ELSE
                MFIN1(I)=RMASS(I-6)
                MFIN2(I)=ZERO
              ENDIF
            ELSE
C---QCD Compton with struck non-valence parton
              MREMIF(I)=MP+RMASS(I-6)
              MFIN1(I)=RMASS(I-6)
              MFIN2(I)=ZERO
            ENDIF
          ENDDO
          IF (IFL.EQ.164) THEN
C---J/Psi
            MFIN1(7)=RMASS(164)
            MFIN2(7)=ZERO
          ENDIF
C---y boundaries for different flavours and processes
          DO 100 I=IMIN,IMAX
            IF (INCLUD(I)) THEN
              MF1=MFIN1(I)
              MF2=MFIN2(I)
              MREMIN=MREMIF(I)
              SHMIN = MF1**2+MF2**2 + TWO * PTMIN**2 +
     +              TWO * SQRT(PTMIN**2+MF1**2) * SQRT(PTMIN**2+MF2**2)
              EMMIF(I) = MAX(EMMIN,SQRT(SHMIN))
              EMMAF(I) = MIN(EMMAX,RS-ML-MREMIN)
              IF (EMMIF(I).GT.EMMAF(I)) THEN
                INCLUD(I)=.FALSE.
                CALL HWWARN('HWHBRN',3,*999)
                GOTO 100
              ENDIF
              WMIF(I) = EMMIF(I)+MREMIF(I)
              WMIN = WMIF(I)
              PLMAX = HWUPCM(RS,ML,WMIN)
              YMIF(I)=ONE-TWO*(SQRT(PINC**2+MP**2)*SQRT(PLMAX**2+ML**2)+
     +                         PINC*PLMAX)/SMA
              IF (YMIF(I).GT.YMAX) THEN
                INCLUD(I)=.FALSE.
                CALL HWWARN('HWHBRN',4,*999)
                GOTO 100
              ENDIF
            ENDIF
 100      CONTINUE
C---considering the largest boundaries
          EMLMIN=EMMIF(IMIN)
          EMLMAX=EMMAF(IMIN)
          IF (IPROO.EQ.3) THEN
            EMLMIN=MIN(EMMIF(IMIN),EMMIF(IMIN+6))
            EMLMAX=MAX(EMMAF(IMIN),EMMAF(IMIN+6))
          ENDIF
          DEBUG=3
          IF (EMLMIN.GT.EMLMAX) GOTO 888
          YMIN=YMIF(IMIN)
          IF (IPROO.EQ.3) YMIN=MIN(YMIF(IMIN),YMIF(IMIN+6))
          YMIN = MAX(YMIN,YBMIN)
          DEBUG=4
          IF (YMIN.GT.YMAX) GOTO 888
          WMIN = WMIF(IMIN)
          MREMIN = MREMIF(IMIN)
          MF1=MFIN1(IMIN)
          MF2=MFIN2(IMIN)
          IF (IPROO.EQ.3) THEN
            WMIN = MIN(WMIF(IMIN),WMIF(IMIN+6))
            MREMIN = MIN(MREMIF(IMIN),MREMIF(IMIN+6))
          ENDIF
        ENDIF
      ENDIF
C---Random generation in largest phase space
      Y=ZERO
      Q2=ZERO
      SHAT=ZERO
      Z=ZERO
      PHI=ZERO
      AJACOB=ZERO
C---y generation
      IF (.NOT.CHARGD) THEN
        IF (IFL.LE.5.OR.(IFL.GE.7.AND.IFL.LE.18)) THEN
          SRY0 = SQRT(YMIN)
          SRY1 = SQRT(YMAX)
          SRY = HWRUNI(0,SRY0,SRY1)
          Y = SRY**2
          YJAC = TWO*SRY*(SRY1-SRY0)
        ELSEIF (IFL.EQ.6) THEN
          Y = SQRT(HWRUNI(0,YMIN**2,YMAX**2))
          YJAC = HALF * (YMAX**2-YMIN**2) / Y
        ELSEIF (IFL.EQ.164) THEN
C---in J/psi photoproduction Y and Q2 are given by the Equivalent Photon
C   Approximation
   10     NTRY=0
   20     NTRY=NTRY+1
          IF (NTRY.GT.NETRY) CALL HWWARN('HWHBRN',50,*10)
          Y = (YMIN/YMAX)**HWRGEN(1)*YMAX
          IF (ONE+(ONE-Y)**2.LT.TWO*HWRGEN(2)) GOTO 20
          YJAC=(TWO*LOG(YMAX/YMIN)-TWO*(YMAX-YMIN)
     &                            +HALF*(YMAX**2-YMIN**2))
        ENDIF
      ELSE
        IF (IPRO.EQ.5) THEN
          Y = EXP(HWRUNI(0,LOG(YMIN),LOG(YMAX)))
          YJAC = Y * LOG(YMAX/YMIN)
        ELSE
          Y = HWRUNI(0,YMIN,YMAX)
          YJAC = YMAX - YMIN
        ENDIF
      ENDIF
C---Q**2 generation
      Q2INF = ME**2*Y**2 / (ONE-Y)
      Q2SUP = MP**2 + SMA*Y - WMIN**2
      IF (IFL.EQ.164) THEN
        Q2INF = MAX(Q2INF,Q2WWMN)
        Q2SUP = MIN(Q2SUP,Q2WWMX)
      ELSE
        Q2INF = MAX(Q2INF,Q2MIN)
        Q2SUP = MIN(Q2SUP,Q2MAX)
      ENDIF
      DEBUG=5
      IF (Q2INF .GT. Q2SUP) GOTO 888
C
      IF (.NOT.CHARGD) THEN
        IF (IFL.EQ.164) THEN
          Q2 = EXP(HWRUNI(0,LOG(Q2INF),LOG(Q2SUP)))
          Q2JAC = LOG(Q2SUP/Q2INF)
        ELSEIF (Q2INF.LT.RMASS(4)**2) THEN
          Q2 = EXP(HWRUNI(0,LOG(Q2INF),LOG(Q2SUP)))
          Q2JAC = Q2 * LOG(Q2SUP/Q2INF)
        ELSE
          Q2 = Q2INF*Q2SUP/HWRUNI(0,Q2INF,Q2SUP)
          Q2JAC = Q2**2 * (Q2SUP-Q2INF)/(Q2SUP*Q2INF)
        ENDIF
      ELSE
        EMW2=EMW**2
        Q2=(Q2INF+EMW2)*(Q2SUP+EMW2)/(HWRUNI(0,Q2INF,Q2SUP)+EMW2)-EMW2
        Q2JAC=(Q2+EMW2)**2*(Q2SUP-Q2INF)/((Q2SUP+EMW2)*(Q2INF+EMW2))
      ENDIF
      W2 = MP**2 + SMA*Y - Q2
C---s_hat generation
      SHINF = EMLMIN **2
      SHSUP = (MIN(SQRT(W2)-MREMIN,EMLMAX))**2
      DEBUG=6
      IF (SHINF .GT. SHSUP) GOTO 888
C
      IF (IPRO.EQ.91) THEN
        IF (.NOT.CHARGD) THEN
          SHAT = SHINF*SHSUP/HWRUNI(0,SHINF,SHSUP)
          SHJAC = SHAT**2 * (SHSUP-SHINF)/(SHSUP*SHINF)
        ELSE
          SHAT = EXP(HWRUNI(0,LOG(SHINF),LOG(SHSUP)))
          SHJAC = SHAT*(LOG(SHSUP/SHINF))
        ENDIF
      ELSE
        EMW2=EMW**2
        IF (SHINF.GT.EMW2+10*GAMW*EMW) THEN
          SHAT = SHINF*SHSUP/HWRUNI(0,SHINF,SHSUP)
          SHJAC = SHAT**2 * (SHSUP-SHINF)/(SHSUP*SHINF)
        ELSEIF (SHSUP.LT.EMW2-10*EMW*GAMW) THEN
          SHAT = HWRUNI(0,SHINF,SHSUP)
          SHJAC = SHSUP-SHINF
        ELSE
          TMIN=ATAN((SHINF-EMW2)/(GAMW*EMW))
          TMAX=ATAN((SHSUP-EMW2)/(GAMW*EMW))
          SHAT = GAMW*EMW*TAN(HWRUNI(0,TMIN,TMAX))+EMW2
          SHJAC=((SHAT-EMW2)**2+(GAMW*EMW)**2)/(GAMW*EMW)*(TMAX-TMIN)
        ENDIF
      ENDIF
      DETDSH = ONE/SMA/Y
      SHJAC=SHJAC*DETDSH
      RSHAT = SQRT (SHAT)
C--- z generation
      ZMIN = 10E10
      ZMAX = -ONE
      IF (.NOT.CHARGD) THEN
        DO I=1,18
          Q1CM(I) = ZERO
          ZMIF(I) = ZERO
          ZMAF(I) = ZERO
        ENDDO
        DO 150 I=IMIN,IMAX
          IF (INCLUD(I)) THEN
            Q1CM(I) = HWUPCM( RSHAT, MFIN1(I), MFIN2(I) )
            IF (Q1CM(I) .LT. PTMIN) THEN
              ZMAF(I)=-ONE
              GOTO 150
            ENDIF
            CTHLIM = SQRT(ONE - (PTMIN / Q1CM(I))**2)
            GAMMA2 = SHAT + MFIN1(I)**2 - MFIN2(I)**2
            LAMBDA = (SHAT-MFIN1(I)**2-MFIN2(I)**2)**2 -
     +                4.D0*MFIN1(I)**2*MFIN2(I)**2
            ZMIF(I) = (GAMMA2 - SQRT(LAMBDA)*CTHLIM)/TWO/SHAT
            ZMIF(I) = MAX(ZMIF(I),ZERO)
            ZMAF(I) = (GAMMA2 + SQRT(LAMBDA)*CTHLIM)/TWO/SHAT
            ZMAF(I) = MIN(ZMAF(I),ONE)
            ZMIN = MIN( ZMIN, ZMIF(I) )
            ZMAX = MAX( ZMAX, ZMAF(I) )
          ENDIF
 150    CONTINUE
        IF (IFL.EQ.164) ZMAX=MIN(ZMAX,ZJMAX)
      ELSE
        Q1 = HWUPCM(RSHAT,MF1,MF2)
        DEBUG=7
        IF (Q1.LT.PTMIN) GOTO 888
        CTHLIM = SQRT(ONE-(PTMIN/Q1)**2)
        GAMMA2 = SHAT+MF1**2-MF2**2
        LAMBDA = (SHAT-MF1**2-MF2**2)**2-4.D0*MF1**2*MF2**2
        ZMIN = (GAMMA2-SQRT(LAMBDA)*CTHLIM)/TWO/SHAT
        ZMIN = MAX(ZMIN,1D-6)
        ZMAX = (GAMMA2+SQRT(LAMBDA)*CTHLIM)/TWO/SHAT
        ZMAX = MIN(ZMAX,ONE-1D-6)
      ENDIF
      DEBUG=8
      IF (ZMIN .GT. ZMAX) GOTO 888
      ZLMIN = LOG(ZMIN/(ONE-ZMIN))
      ZINT = LOG(ZMAX/(ONE-ZMAX)) - LOG(ZMIN/(ONE-ZMIN))
      ZL = ZLMIN+HWRGEN(0)*ZINT
      Z = EXP(ZL)/(ONE+EXP(ZL))
      ZJAC = Z*(ONE-Z)*ZINT
C
      DEBUG=9
      IF ((Y.LT.YMIN.OR.Y.GT.YMAX).OR.(Q2.LT.Q2INF.OR.Q2.GT.Q2SUP).OR.
     +   (SHAT.LT.SHINF.OR.SHAT.GT.SHSUP).OR.(Z.LT.ZMIN.OR.Z.GT.ZMAX))
     +     GOTO 888
C---Phi generation
      PHI = HWRUNI(0,ZERO,2*PIFAC)
      PHIJAC = 2 * PIFAC
      IF (IFL.EQ.164) PHIJAC=ONE
C
      AJACOB = YJAC * Q2JAC * SHJAC * ZJAC * PHIJAC
C
      IF (IQK.NE.0.OR.IPRO.EQ.5) GOTO 999
C---contributing subprocesses: filling of logical vector INSIDE
      DO I=1,18
        INSIDE(I)=.FALSE.
        Q2MAF(I)=ZERO
        EMMAWF(I)=ZERO
      ENDDO
      DO 200 I=IMIN,IMAX
      IF (INCLUD(I)) THEN
      IF ( Y.LT.YMIF(I) ) GOTO 200
C
      Q2MAF(I) = MP**2 + SMA*Y - WMIF(I)**2
      Q2MAF(I) = MIN( Q2MAF(I), Q2MAX)
      IF (Q2INF .GT. Q2MAF(I)) GOTO 200
      IF (Q2.LT.Q2INF .OR. Q2.GT.Q2MAF(I)) GOTO 200
C
      EMMAWF(I) = SQRT(W2) - MREMIF(I)
      EMMAWF(I) = MIN( EMMAWF(I), EMLMAX )
C
      IF (EMMIF(I) .GT. EMMAWF(I)) GOTO 200
      IF (SHAT.LT.EMMIF(I)**2.OR.SHAT.GT.EMMAWF(I)**2) GOTO 200
C
      IF (ZMIF(I) .GT. ZMAF(I)) GOTO 200
      IF (Z.LT.ZMIF(I) .OR. Z.GT.ZMAF(I)) GOTO 200
      INSIDE(I)=.TRUE.
      ENDIF
 200  CONTINUE
 999  RETURN
 888  EVWGT=ZERO
C---UNCOMMENT THIS LINE TO GET A DEBUGGING WARNING FOR NO PHASE-SPACE
C      CALL HWWARN('HWHBRN',DEBUG,*777)
 777  RETURN 1
      END
CDECK  ID>, HWHBSG.
*CMZ :-        -03/07/95  19.02.12  by  Giovanni Abbiendi
*-- Author :    Giovanni Abbiendi & Luca Stanco
C----------------------------------------------------------------------
      SUBROUTINE HWHBSG
C----------------------------------------------------------------------
C     Returns differential cross section DSIGMA in (Y,Q2,ETA,Z,PHI)
C     Scale for structure functions and alpha_s selected by BGSHAT
C----------------------------------------------------------------------
      INCLUDE 'HERWIG62.INC'
      DOUBLE PRECISION HWUALF,HWUAEM,Y,Q2,SHAT,Z,PHI,AJACOB,DSIGMA,
     & ME,MP,ML,MREMIF(18),MFIN1(18),MFIN2(18),RS,SMA,W2,RSHAT,
     & SFUN(13),ALPHA,LDSIG,DLQ(7),SG,XG,MF1,MF2,MSUM,MDIF,MPRO,FFUN,
     & GFUN,H43,H41,H11,H12,H14,H16,H21,H22,G11,G12,G1A,G1B,G21,G22,G3,
     & GC,A11,A12,A44,ALPHAS,PDENS,AFACT,BFACT,CFACT,DFACT,GAMMA,S,T,U,
     & MREMIN,POL,CCOL,ETA
      INTEGER LEP
      INTEGER IQK,IFLAVU,IFLAVD,IMIN,IMAX,IFL,IPROO,IHAD,ILEPT,IQ,IS
      LOGICAL CHARGD,INCLUD(18),INSIDE(18)
      EXTERNAL HWUALF,HWUAEM
      COMMON /HWAREA/ Y,Q2,SHAT,Z,PHI,AJACOB,DSIGMA,ME,MP,ML,MREMIF,
     & MFIN1,MFIN2,RS,SMA,W2,RSHAT,IQK,IFLAVU,IFLAVD,IMIN,IMAX,IFL,LEP,
     & IPROO,CHARGD,INCLUD,INSIDE
C
      IHAD=2
      IF (JDAHEP(1,IHAD).NE.0) IHAD=JDAHEP(1,IHAD)
C---set masses
      IF (CHARGD) THEN
        MREMIN=MP
        IF (LEP.EQ.1) THEN
          MF1=RMASS(IFLAVD)
          MF2=RMASS(IFLAVU)
        ELSE
          MF1=RMASS(IFLAVU)
          MF2=RMASS(IFLAVD)
        ENDIF
      ELSE
        IS=IFL
        IF (IFL.EQ.164) IS=IQK
        MREMIN = MREMIF(IS)
        MF1 = MFIN1(IS)
        MF2 = MFIN2(IS)
      ENDIF
C---choose subprocess scale
      IF (BGSHAT) THEN
        EMSCA = RSHAT
      ELSE
        S=SHAT+Q2
        IF (IFL.GE.7.AND.IFL.LE.18) S=SHAT+Q2-MF1**2
        T=-S*Z
        U=-S-T
        IF (IFL.GE.7.AND.IFL.LE.18) U=-S-T-2*MF1**2
        EMSCA = SQRT(TWO*S*T*U/(S**2+T**2+U**2))
        IF (IFL.EQ.164) EMSCA=SQRT(-U)
      ENDIF
      ALPHAS = HWUALF(1,EMSCA)
      IF (ALPHAS.GE.ONE.OR.ALPHAS.LE.ZERO) CALL HWWARN('HWHBSG',51,*888)
C---structure functions
      ETA = (SHAT+Q2)/SMA/Y
      IF (ETA.GT.ONE) ETA=ONE
      CALL HWSFUN (ETA,EMSCA,IDHW(IHAD),NSTRU,SFUN,2)
      XG = Q2/(SHAT + Q2)
      SG = ETA*SMA
      IF (SG.LE.(RSHAT+ML)**2.OR.SG.GE.(RS-MREMIN)**2) GOTO 888
C
      IF (IFL.EQ.164) GOTO 200
C
C---Electroweak couplings
      ALPHA=HWUAEM(-Q2)
      IF (CHARGD) THEN
        POL = PPOLN(3) - EPOLN(3)
        DLQ(1)=.0625*VCKM(IFLAVU/2,(IFLAVD+1)/2)/SWEIN**2 *
     +         Q2**2/((Q2+RMASS(198)**2)**2+(RMASS(198)*GAMW)**2) *
     +         (ONE + POL)
        DLQ(2)=ZERO
        DLQ(3)=DLQ(1)
      ELSE
        IQ=MOD(IFL-1,6)+1
        ILEPT=MOD(IDHW(1)-121,6)+11
        CALL HWUCFF(ILEPT,IQ,-Q2,DLQ(1))
      ENDIF
C
      IF (IFL.LE.6) THEN
C---For Boson-Gluon Fusion
        PDENS = SFUN(13)/ETA
        CCOL = HALF
        MSUM = (MF1**2 + MF2**2) / (Y*SG)
        MDIF = (MF1**2 - MF2**2) / (Y*SG)
        MPRO = MF1*MF2 / (Y*SG)
C
        FFUN = (1.D0-XG)*Z*(1.D0-Z) + (MDIF*(2.D0*Z-1.D0)-MSUM)/2.D0
        GFUN = (1.D0-XG)*(1.D0-Z) + XG*Z + MDIF
        IF ( FFUN .LT. ZERO ) FFUN = ZERO
        H43 = (8.D0*(2.D0*Z**2*XG-Z**2-2.D0*Z*XG+2.D0*Z*MDIF+Z-MDIF
     &         -MSUM)) / (Z*(1.D0-Z))**2
C
        H41 = (8.D0*(Z**2-Z*XG+Z*MDIF-MDIF-MSUM)) / (Z**2*(1.D0-Z))
C
        H11 = (4.D0*(2.D0*Z**4-4.D0*Z**3+2.D0*Z**2*MSUM*XG
     &         -2.D0*Z**2*MSUM+2.D0*Z**2*XG**2-2.D0*Z**2*XG+3.D0*Z**2
     &         +2.D0*Z*MDIF*MSUM+2.D0*Z*MDIF*XG-2.D0*Z*MSUM*XG
     &         +2.D0*Z*MSUM-2.D0*Z*XG**2+2.D0*Z*XG-Z-MDIF*MSUM-MDIF*XG
     &         -MSUM**2-MSUM*XG)) / (Z*(1.D0-Z))**2
C
        H12 = (16.D0*(-Z*MDIF+Z*XG+MDIF+MSUM))/(Z**2*(1.D0-Z))
C
        H14 = (16.D0*(-2.D0*Z**2*XG-2.D0*Z*MDIF+2.D0*Z*XG+MDIF+MSUM))
     &        / (Z*(1.D0-Z))**2
C
        H16 = (32.D0*(Z*MDIF-Z*XG-MDIF-MSUM)) / (Z**2*(1.D0-Z))
C
        H21 = (8.D0*MPRO*(-2.D0*Z**2*XG+2.D0*Z**2-2.D0*Z*MDIF+2.D0*Z*XG
     +         -2.D0*Z+MDIF+MSUM)) / (Z*(1.D0-Z))**2
C
        H22 = (-32.D0*MPRO) / (Z*(1.D0-Z))
C
        G11 = -2.D0*H11 + FFUN*H14
        G12 = 2.D0*XG*FFUN*H14 + H12 + GFUN * ( H16+GFUN*H14 )
        G1A = SQRT( XG*FFUN ) * ( H16 + 2.D0*GFUN*H14 )
        G1B = FFUN*H14
        G21 = -2.D0*H21
        G22 = H22
        G3  = H41 - GFUN*H43
        GC  = SQRT( XG*FFUN ) * (-2.D0*XG*H43 )
      ELSE
C---for QCD Compton, massless matrix element
        PDENS = SFUN(IFL-6)/ETA
        CCOL = CFFAC
        FFUN = XG*(ONE-XG)*Z*(ONE-Z)
        GFUN = (ONE-XG)*(ONE-Z)+XG*Z
        G11 = 8.D0*((Z**2+XG**2)/(ONE-XG)/(ONE-Z)+TWO*(XG*Z+ONE))
        G12 = 64.D0*XG**2*Z+TWO*XG*G11
        G1A = 32.D0*XG*GFUN*SQRT(FFUN)/((ONE-XG)*(ONE-Z))
        G1B = 16.D0*XG*Z
        G3  = -16.D0*(ONE-XG)*(ONE-Z)+G11
        GC  = -16.D0*XG*SQRT(FFUN)*(ONE-Z-XG)/((ONE-XG)*(ONE-Z))
        G21 = ZERO
        G22 = ZERO
      ENDIF
C
      A11 = XG * Y**2 * G11  +  (1.D0-Y) * G12
     &      - (2.D0-Y) * SQRT( 1.D0-Y ) * G1A  *  COS( PHI )
     &      + 2.D0 * XG * (1.D0-Y) * G1B  *  COS( 2.D0*PHI )
C
      A12 = XG * Y**2 * G21  +  (1.D0-Y) * G22
C
      A44 = XG * Y * (2.D0-Y) * G3
     &      - 2.D0 * Y * SQRT( 1.D0-Y ) * GC  *  COS( PHI )
C
      IF ( Y*Q2**2 .LT. 1D-38 ) THEN
C---prevent numerical uncertainties in DSIGMA computation
        DSIGMA = PDENS*ALPHA**2*ALPHAS*GEV2NB*CCOL/(16.D0*PIFAC)
     &           *(DLQ(1)*A11 + DLQ(2)*A12 + FLOAT(LEP)*DLQ(3)*A44)
        IF ( DSIGMA .LE. ZERO ) GOTO 888
        LDSIG = LOG (DSIGMA) - LOG (Y) - 2.D0 * LOG (Q2)
        DSIGMA = EXP (LDSIG)
      ELSE
        DSIGMA = PDENS*ALPHA**2*ALPHAS*GEV2NB*CCOL
     &         * (DLQ(1)*A11 + DLQ(2)*A12 + FLOAT(LEP)*DLQ(3)*A44)
     &         / (16.D0*PIFAC*Y*Q2**2)
      ENDIF
      IF (DSIGMA.LT.ZERO) GOTO 888
      RETURN
C
  200 CONTINUE
C--- J/psi production
      ALPHA = HWUAEM(-Q2)
      GAMMA = 4.8D-6
      PDENS = SFUN(13)/ETA
      AFACT = (8.D0*PIFAC*ALPHAS**2*RMASS(164)**3*GAMMA)/(3.D0*ALPHA)
      BFACT = ONE/(Y*SG*Z**2*((Z-ONE)*Y*SG-RMASS(164)**2)**2)
      CFACT = (RMASS(164)**2-Z*Y*SG)**2/(Y*SG*(ONE-XG)**2*
     &        ((ONE-XG)*Y*SG-RMASS(164)**2)**2*
     &        ((Z-ONE)*Y*SG-RMASS(164)**2)**2)
      DFACT = ((Z-ONE)*Y*SG)**2/(Y*SG*(ONE-XG)**2*
     &          ((ONE-XG)*Y*SG-RMASS(164)**2)**2*(Z*Y*SG)**2)
      DSIGMA = GEV2NB*ALPHA/(TWO*PIFAC)*AFACT*(BFACT+CFACT+DFACT)*PDENS
      IF (DSIGMA.LT.ZERO ) GOTO 888
      RETURN
 888  DSIGMA=ZERO
      END
CDECK  ID>, HWHDIS.
*CMZ :-        -26/04/91  14.55.44  by  Federico Carminati
*-- Author :    Giovanni Abbiendi & Luca Stanco
C----------------------------------------------------------------------
      SUBROUTINE HWHDIS
C----------------------------------------------------------------------
C     DEEP INELASTIC LEPTON-HADRON SCATTERING: MEAN EVWGT = SIGMA IN NB
C----------------------------------------------------------------------
      INCLUDE 'HERWIG62.INC'
      DOUBLE PRECISION HWRGEN,HWRUNI,HWUPCM,PRAN,PROB,SAMP,SIG,Q2,
     & XBJ,Y,W,S,MLEP,MHAD,MLSCAT,YMIN,YMAX,XXMAX,Q2JAC,XXJAC,
     & JACOBI,A1,A2,A3,B1,B2,PCM,PCMEP,PCMLW,PCMEQ,PCMLQ,COSPHI,PA,
     & EQ,PZQ,SHAT,PROP,DLEFT,DRGHT,DUP,DWN,FACT,EFACT,OMY2,YPLUS,
     & YMNUS,SIGMA,AF(7,12),SMA,Q2SUP,HWUAEM,DCHRG,DNEUT
      INTEGER I,IQK,IQKIN,IQKOUT,IDSCAT,IHAD,ILEPT,LEP
      LOGICAL CHARGD
      EXTERNAL HWRGEN,HWRUNI,HWUPCM
      SAVE MLEP,MHAD,S,SMA,PCM,MLSCAT,A1,A2,A3,B1,B2,DLEFT,DRGHT,Q2,
     & AF,XBJ,Y,YPLUS,YMNUS,OMY2,FACT,EFACT,SIGMA,IDSCAT,CHARGD,
     & ILEPT,DCHRG,DNEUT,LEP
      IQK=MOD(IPROC,10)
      IHAD=2
      IF (JDAHEP(1,IHAD).NE.0) IHAD=JDAHEP(1,IHAD)
      IF (FSTWGT.OR.IHAD.NE.2) THEN
C---INITIALISE PROCESS (MUST BE DONE EVERY TIME IF S VARIES)
C---LEPTON AND HADRON MASSES, INVARIANT MASS, MOMENTUM IN C.M. FRAME
        MLEP=PHEP(5,1)
        MHAD=PHEP(5,IHAD)
        S=PHEP(5,3)**2
        SMA=S-MLEP**2-MHAD**2
        PCM=HWUPCM(SQRT(S),MLEP,MHAD)
C---LEP = 1 FOR LEPTONS, -1 FOR ANTILEPTONS
        IF (IDHW(1).GE.121.AND.IDHW(1).LE.126) THEN
          LEP=1
        ELSEIF (IDHW(1).GE.127.AND.IDHW(1).LE.132) THEN
          LEP=-1
        ELSE
          CALL HWWARN('HWHDIS',500,*999)
        ENDIF
        DCHRG=FLOAT(MOD(IDHW(1)  ,2))
        DNEUT=FLOAT(MOD(IDHW(1)+1,2))
        ILEPT=MOD(IDHW(1)-121,6)+11
C---DLEFT,DRIGHT = 1,0 for leptons; = 0,1 for anti-leptons
        DLEFT=MAX(LEP,0)
        DRGHT=MAX(-LEP,0)
        CHARGD=MOD(IPROC,100)/10.EQ.1
C---Evaluate constant factor in cross section and
C   find and store scattered lepton identity
        IF (CHARGD) THEN
          IF ((EPOLN(3)-PPOLN(3)).EQ.ONE) THEN
             WRITE(6,5)
             CALL HWWARN('HWHDIS',501,*999)
  5          FORMAT(1X,'WARNING: Cross-section is zero for the',
     &                ' specified lepton helicity')
          ENDIF
          FACT=GEV2NB*(ONE-(EPOLN(3)-PPOLN(3)))*.25D0*PIFAC
     &        /(SWEIN*RMASS(198)**2)**2
          IDSCAT=IDHW(1)+NINT(DCHRG-DNEUT)
        ELSE
          FACT=GEV2NB*TWO*PIFAC
          IDSCAT=IDHW(1)
        ENDIF
        MLSCAT=RMASS(IDSCAT)
C---PARAMETERS USED FOR THE WEIGHT GENERATION IN NEUTRAL CURRENT
C   PROCESSES. ASSUME D(SIGMA)/D(Q**2) GOES LIKE A1+A2/Q**2+A3/Q**4
C   AND D(SIGMA)/D(X) LIKE B1+B2/X
        A1=0.5
        A2=0.5
        A3=1.
        B1=0.1
        B2=1.
      ENDIF
      IF (GENEV) THEN
C---GENERATE EVENT (KINEMATICAL VARIABLES AND STRUCTURE FUNCTION
C   ALREADY FOUND)
        PRAN=SIGMA*HWRGEN(0)
        IF (CHARGD) THEN
C---CHARGED CURRENT PROCESS
          IF (IQK.EQ.0) THEN
C---FIND FLAVOUR OF THE STRUCK QUARK (IF NOT SELECTED BY THE USER)
            PROB=ZERO
            DO 10 I=1,6
            DUP=MOD(I+1,2)
            DWN=MOD(I  ,2)
            PROB=PROB+EFACT*
     &          ((DCHRG*(DLEFT*DUP+DRGHT*DWN*OMY2)
     &           +DNEUT*(DLEFT*DWN+DRGHT*DUP*OMY2))*DISF(I  ,1)
     &          +(DCHRG*(DLEFT*DWN*OMY2+DRGHT*DUP)
     &           +DNEUT*(DLEFT*DUP*OMY2+DRGHT*DWN))*DISF(I+6,1))
            IF (PROB.GE.PRAN) GOTO 20
   10       CONTINUE
            I=6
   20       IQK=I
          ENDIF
          DUP=MOD(IQK+1,2)
          DWN=MOD(IQK  ,2)
          IQKIN=IQK
          IF ((LEP.EQ. 1.AND.MOD(IQK+IDHW(1),2).EQ.0)
     &    .OR.(LEP.EQ.-1.AND.MOD(IQK+IDHW(1),2).EQ.1)) IQKIN=IQK+6
C---FIND FLAVOUR OF THE OUTGOING QUARK
          PRAN=HWRGEN(0)
          PROB=ZERO
          IF (DUP.EQ.ONE) THEN
            DO 30 I=1,3
            PROB=PROB+VCKM(IQK/2,I)
            IF (PROB.GE.PRAN) GOTO 40
   30       CONTINUE
            I=3
   40       IQKOUT=2*I-1
            IF (IQKIN.GT.6) IQKOUT=IQKOUT+6
          ELSE
            DO 50 I=1,3
            PROB=PROB+VCKM(I,(IQK+1)/2)
            IF (PROB.GE.PRAN) GOTO 60
   50       CONTINUE
            I=3
   60       IQKOUT=2*I
            IF (IQKIN.GT.6) IQKOUT=IQKOUT+6
          ENDIF
        ELSE
C---NEUTRAL CURRENT PROCESS
          IF (IQK.NE.0) THEN
            IQKIN=IQK
            PROB=EFACT*(AF(1,IQK)*YPLUS*DISF(IQK,1)+
     &       FLOAT(LEP)*AF(3,IQK)*YMNUS*DISF(IQK,1))
            IF (PROB.LT.PRAN) IQKIN=IQK+6
          ELSE
C---FIND FLAVOUR OF THE STRUCK QUARK (IF NOT SELECTED BY THE USER)
            PROB=ZERO
            SIG=ONE
            DO 70 I=1,12
            IF (I.GT.6) SIG=-ONE
            PROB=PROB+EFACT*(AF(1,I)*YPLUS*DISF(I,1)+
     &        FLOAT(LEP)*SIG*AF(3,I)*YMNUS*DISF(I,1))
            IF (PROB.GE.PRAN) GOTO 80
   70       CONTINUE
            I=12
   80       IQKIN=I
          ENDIF
          IQKOUT=IQKIN
        ENDIF
        IDN(1)=IDHW(1)
        IDN(2)=IQKIN
        IDN(3)=IDSCAT
        IDN(4)=IQKOUT
        ICO(1)=1
        ICO(2)=4
        ICO(3)=3
        ICO(4)=2
        XX(1)=1.
        XX(2)=XBJ
C---CHECK PHASE SPACE WITH THE SELECTED FLAVOUR. IF OUTSIDE THE
C   EVENT IS KILLED.
        PA=XBJ*(PHEP(4,IHAD)+ABS(PHEP(3,IHAD)))
        EQ=HALF*(PA+RMASS(IDN(2))**2/PA)
        PZQ=-(PA-EQ)
        SHAT=(PHEP(4,1)+EQ)**2-(PHEP(3,1)+PZQ)**2
        PCMEQ=HWUPCM(SQRT(SHAT),MLEP,RMASS(IDN(2)))
        PCMLQ=HWUPCM(SQRT(SHAT),MLSCAT,RMASS(IDN(4)))
        IF (PCMLQ.LT.ZERO) THEN
          CALL HWWARN('HWHDIS',101,*999)
        ELSEIF (PCMLQ.EQ.ZERO) THEN
          COSTH=ZERO
        ELSE
          COSTH=(TWO*SQRT(PCMEQ**2+MLEP**2)*SQRT(PCMLQ**2+MLSCAT**2)
     &         -(Q2+MLEP**2+MLSCAT**2))/(TWO*PCMEQ*PCMLQ)
        ENDIF
        IF (ABS(COSTH).GT.ONE) CALL HWWARN('HWHDIS',102,*999)
        IDCMF=15
        CALL HWETWO
      ELSE
        EVWGT=ZERO
        IF (CHARGD) THEN
C---CHOOSE X,Y (CC PROCESS)
          YMIN=MAX(YBMIN,Q2MIN/SMA)
          YMAX=MIN(YBMAX,ONE)
          IF (YMIN.GT.YMAX) GOTO 999
          Y=HWRUNI(0,YMIN,YMAX)
          XXMIN=Q2MIN/S/Y
          XXMAX=MIN(Q2MAX/SMA/Y,ONE)
          IF (XXMIN.GT.XXMAX) GOTO 999
          XBJ=HWRUNI(0,XXMIN,XXMAX)
          Q2=XBJ*Y*(S-MLEP**2-MHAD**2)
          JACOBI=(YMAX-YMIN)*(XXMAX-XXMIN)*(S-MLEP**2-MHAD**2)*XBJ
        ELSE
C---CHOOSE X,Q**2 (NC PROCESS)
          Q2SUP=MIN(Q2MAX,SMA*YBMAX)
          IF (Q2MIN.GT.Q2SUP) GOTO 999
          SAMP=(A1+A2+A3)*HWRGEN(0)
          IF (SAMP.LE.A1) THEN
            Q2=HWRUNI(0,Q2MIN,Q2SUP)
          ELSEIF (SAMP.LE.(A1+A2)) THEN
            Q2=EXP(HWRUNI(0,LOG(Q2MIN),LOG(Q2SUP)))
          ELSE
            Q2=-ONE/HWRUNI(0,-ONE/Q2MIN,-ONE/Q2SUP)
          ENDIF
          Q2JAC=(A1+A2+A3)/
     &      (A1/(Q2SUP-Q2MIN)
     &      +A2/LOG(Q2SUP/Q2MIN)/Q2
     &      +A3*Q2MIN*Q2SUP/(Q2SUP-Q2MIN)/Q2**2)
          XXMIN=Q2/SMA/YBMAX
          XXMAX=ONE
          IF (YBMIN.GT.ZERO) XXMAX=MIN(Q2/SMA/YBMIN,ONE)
          IF (XXMIN.GT.XXMAX) GOTO 999
          SAMP=(B1+B2)*HWRGEN(0)
          IF (SAMP.LE.B1) THEN
            XBJ=HWRUNI(0,XXMIN,XXMAX)
          ELSE
            XBJ=EXP(HWRUNI(0,LOG(XXMIN),LOG(XXMAX)))
          ENDIF
          XXJAC=(B1+B2)/(B1/(XXMAX-XXMIN)+B2/LOG(XXMAX/XXMIN)/XBJ)
          Y=Q2/(S-MLEP**2-MHAD**2)/XBJ
          JACOBI=Q2JAC*XXJAC
        ENDIF
C---CHECK IF THE GENERATED POINT IS INSIDE PHASE SPACE. IF NOT
C   RETURN WITH WEIGHT EQUAL TO ZERO.
        W=SQRT(MHAD**2+Q2*(ONE-XBJ)/XBJ)
        IF (W.LT.WHMIN) RETURN
        PCMEP=PCM
        PCMLW=HWUPCM(SQRT(S),MLSCAT,W)
        IF (PCMLW.LT.ZERO) THEN
          EVWGT=ZERO
          RETURN
        ELSEIF (PCMLW.EQ.ZERO) THEN
          COSPHI=ZERO
        ELSE
          COSPHI=
     &    (TWO*SQRT(PCMEP**2+MLEP**2)*SQRT(PCMLW**2+MLSCAT**2)
     &    -(Q2+MLEP**2+MLSCAT**2))/(TWO*PCMEP*PCMLW)
        ENDIF
        IF (ABS(COSPHI).GT.ONE) THEN
          EVWGT=ZERO
          RETURN
        ENDIF
C---SET SCALE EQUAL Q. EVALUATE STRUCTURE FUNCTIONS.
        EMSCA=SQRT(Q2)
        CALL HWSFUN(XBJ,EMSCA,IDHW(IHAD),NSTRU,DISF,2)
C---SWITCH OFF ANY FLAVOURS THAT ARE BELOW THRESHOLD
        DO 90 I=1,12
 90     IF (W.LT.2*RMASS(I)) DISF(I,1)=0
C---EVALUATE DIFFERENTIAL CROSS SECTION
        IF (CHARGD) THEN
          PROP=RMASS(198)**2/(Q2+RMASS(198)**2)
          EFACT=FACT*(HWUAEM(-Q2)*PROP)**2/XBJ
          OMY2=(ONE-Y)**2
          SIGMA=ZERO
          DO 100 I=1,6
          DUP=MOD(I+1,2)
          DWN=MOD(I  ,2)
          IF (IQK.NE.0.AND.IQK.NE.I) GOTO 100
          SIGMA=SIGMA+EFACT*
     &        ((DCHRG*(DLEFT*DUP+DRGHT*DWN*OMY2)
     &         +DNEUT*(DLEFT*DWN+DRGHT*DUP*OMY2))*DISF(I  ,1)
     &        +(DCHRG*(DLEFT*DWN*OMY2+DRGHT*DUP)
     &         +DNEUT*(DLEFT*DUP*OMY2+DRGHT*DWN))*DISF(I+6,1))
  100     CONTINUE
        ELSE
          EFACT=FACT/XBJ*(HWUAEM(-Q2)/Q2)**2
          YPLUS=ONE+(ONE-Y)**2
          YMNUS=ONE-(ONE-Y)**2
          DO 110 I=1,6
          CALL HWUCFF(ILEPT,I,-Q2,AF(1,I))
          AF(1,I+6)=AF(1,I)
          AF(3,I+6)=AF(3,I)
  110     CONTINUE
          SIGMA=ZERO
          DO 200 I=1,6
          IF (IQK.NE.0.AND.IQK.NE.I) GOTO 200
          SIGMA=SIGMA+EFACT*(AF(1,I)*YPLUS*(DISF(I,1)+DISF(I+6,1))+
     &            FLOAT(LEP)*AF(3,I)*YMNUS*(DISF(I,1)-DISF(I+6,1)))
  200     CONTINUE
        ENDIF
C---FIND WEIGHT: DIFFERENTIAL CROSS SECTION TIME THE JACOBIAN FACTOR
        EVWGT=SIGMA*JACOBI
        IF (EVWGT.LT.ZERO) EVWGT=ZERO
      ENDIF
  999 END
CDECK  ID>, HWHDYP.
*CMZ :-        -18/05/99  12.41.07  by  Mike Seymour
*-- Author :    Bryan Webber, Ian Knowles and Mike Seymour
C-----------------------------------------------------------------------
      SUBROUTINE HWHDYP
C-----------------------------------------------------------------------
C     Drell-Yan Production of fermion pairs via photon, Z0 & (if ZPRIME)
C     Z' exchange. Lepton universality is assumed for photon and Z, and
C     for Z' if no lepton flavour is specified.
C     MEAN EVWGT = SIGMA IN NB
C
C     Modified 16/01/01 by BRW to implement Peter Richardson's
C     fix for bug in lepton mass effects on branching ratio
C-----------------------------------------------------------------------
      INCLUDE 'HERWIG62.INC'
      DOUBLE PRECISION HWRGEN,HWRUNI,HWUAEM,EPS,C1,C2,C3,EMSQZ,EMGMZ,
     & EMSQZP,EMGMZP,CQF(7,6,16),QPOW,RPOW,A01,A1,A02,A2,A03,A3,CRAN,
     & EMJ1,EMJ2,EMJ3,EMJAC,FACT,QSQ,HCS,FACTR,RCS,EXTRA,PMAX,PTHETA
      INTEGER IMODE,JQMN,JQMX,JQ,JLMN,JLMX,JL,IQ,I,IADD(2,2),ID1,ID2,
     & ID3,ID4,JF
      EXTERNAL HWRGEN,HWRUNI,HWUAEM
      SAVE HCS,JQMN,JQMX,JLMN,JLMX,C1,C2,C3,QPOW,RPOW,EMSQZ,EMGMZ,
     & A1,A01,A2,A02,A3,A03,EMSQZP,EMGMZP,FACT,CQF
      PARAMETER (EPS=1.D-9)
      DATA IADD/0,6,6,0/
      IF (GENEV) THEN
        RCS=HCS*HWRGEN(0)
      ELSE
        IF (FSTWGT) THEN
C Set limits for which particles to include
          JLMN=1
          JLMX=0
          JQMN=1
          JQMX=0
          IMODE=MOD(IPROC,100)
          IF (IMODE.EQ.0) THEN
            JQMN=1
            JQMX=6
          ELSEIF (IMODE.LE.10) THEN
            JQMN=IMODE
            JQMX=IMODE
          ELSEIF (IMODE.EQ.50) THEN
            JLMN=11
            JLMX=16
          ELSEIF (IMODE.GE.50.AND.IMODE.LE.60) THEN
            JLMN=IMODE-40
            JLMX=IMODE-40
          ELSEIF (IMODE.EQ.99) THEN
            JQMN=1
            JQMX=6
            JLMN=11
            JLMX=16
          ELSE
            CALL HWWARN('HWHDYP',500,*999)
          ENDIF
C Set up parameters for importance sampling:
C sum of power law and two Breit-Wigners (relative weights C1,C2,C3)
          C1=ONE
          C2=ONE
          C3=ZERO
          IF (ZPRIME) C3=ONE
          IF (EMPOW.EQ.ONE) CALL HWWARN('HWHDYP',501,*999)
          IF (C2.EQ.ZERO) CALL HWWARN('HWHDYP',502,*999)
          IF (C3.EQ.ZERO.AND.ZPRIME) CALL HWWARN('HWHDYP',503,*999)
          QPOW=-EMPOW+1
          RPOW=1/QPOW
          EMSQZ=RMASS(200)**2
          EMGMZ=RMASS(200)*GAMZ
          A01=EMMIN**QPOW
          A1=(EMMAX**QPOW-A01)/C1
          A02=ATAN((EMMIN**2-EMSQZ)/EMGMZ)
          A2=(ATAN((EMMAX**2-EMSQZ)/EMGMZ)-A02)/C2
          IF (C3.GT.ZERO) THEN
            EMSQZP=RMASS(202)**2
            EMGMZP=RMASS(202)*GAMZP
            A03=ATAN((EMMIN**2-EMSQZP)/EMGMZP)
            A3=(ATAN((EMMAX**2-EMSQZP)/EMGMZP)-A03)/C3
          ENDIF
        ENDIF
        EVWGT=0.
C Select a mass for the produced pair
        CRAN=(C1+C2+C3)*HWRGEN(1)
        IF (CRAN.LT.C1) THEN
C Use power law
          EMSCA=(A01+A1*CRAN)**RPOW
          QSQ=EMSCA**2
        ELSEIF (CRAN.LT.C1+C2) THEN
C Use Z Breit-Wigner
          CRAN=CRAN-C1
          QSQ=EMSQZ+EMGMZ*TAN(A02+A2*CRAN)
          EMSCA=SQRT(QSQ)
        ELSE
C Use Z' Breit-Wigner
          CRAN=CRAN-C1-C2
          QSQ=EMSQZP+EMGMZP*TAN(A03+A3*CRAN)
          EMSCA=SQRT(QSQ)
        ENDIF
        EMJ1=EMSCA**EMPOW/(1-EMPOW)*A1
        EMJ2=((QSQ-EMSQZ)**2+EMGMZ**2)/(2*EMSCA*EMGMZ)*A2
        IF (C3.GT.ZERO) THEN
          EMJ3=((QSQ-EMSQZP)**2+EMGMZP**2)/(2*EMSCA*EMGMZP)*A3
          EMJAC=(C1+C2+C3)/(1/EMJ1+1/EMJ2+1/EMJ3)
        ELSE
          EMJAC=(C1+C2)/(1/EMJ1+1/EMJ2)
        ENDIF
C Select initial momentum fractions
        XXMIN=QSQ/PHEP(5,3)**2
        XLMIN=LOG(XXMIN)
        CALL HWSGEN(.TRUE.)
        FACT=-GEV2NB*HWUAEM(QSQ)**2*PIFAC*8*EMJAC*XLMIN
     $       /(3*NCOLO*EMSCA**3)
C Store cross-section coefficients
        DO 50 IQ=1,6
        DO 30 JQ=JQMN,JQMX
        IF (EMSCA.GT.2.*RMASS(JQ)) THEN
          CALL HWUCFF(IQ,JQ,QSQ,CQF(1,IQ,JQ))
        ELSE
          CALL HWVZRO(7,CQF(1,IQ,JQ))
        ENDIF
  30    CONTINUE
        DO 40 JL=JLMN,JLMX
        IF (EMSCA.GT.2.*RMASS(JL+110)) THEN
          CALL HWUCFF(IQ,JL,QSQ,CQF(1,IQ,JL))
        ELSE
          CALL HWVZRO(7,CQF(1,IQ,JL))
        ENDIF
  40    CONTINUE
  50    CONTINUE
      ENDIF
C
      HCS=0.
      DO 90 I=1,2
C I=1 quark first, I=2 anti-quark first
      DO 80 IQ=1,6
      ID1=IQ+IADD(1,I)
      ID2=IQ+IADD(2,I)
      IF (DISF(ID1,1).LT.EPS.OR.DISF(ID2,2).LT.EPS) GOTO 80
      FACTR=FACT*DISF(ID1,1)*DISF(ID2,2)
C Quark final states
      DO 60 JQ=JQMN,JQMX
      ID3=JQ
      ID4=JQ+6
      IF (IQ.EQ.JQ) THEN
        HCS=HCS+FACTR*(CQF(1,IQ,JQ)*FLOAT(NCOLO)+3*HALF*QFCH(IQ)**4)
        IF (GENEV.AND.HCS.GT.RCS) CALL HWHQCP(ID3,ID4,2143,50,*99)
      ELSE
        HCS=HCS+FACTR*CQF(1,IQ,JQ)*FLOAT(NCOLO)
        IF (GENEV.AND.HCS.GT.RCS) CALL HWHQCP(ID3,ID4,2143,50,*99)
      ENDIF
  60  CONTINUE
C Lepton final states
      DO 70 JL=JLMN,JLMX
      ID3=110+JL
      ID4=ID3+6
      HCS=HCS+FACTR*CQF(1,IQ,JL)
      IF (GENEV.AND.HCS.GT.RCS) CALL HWHQCP(ID3,ID4,2134,50,*99)
  70  CONTINUE
  80  CONTINUE
  90  CONTINUE
      EVWGT=HCS
      RETURN
C Generate event
  99  IDN(1)=ID1
      IDN(2)=ID2
      IDCMF=200
      IF (ID3.LE.6) THEN
        JF=JQ
      ELSE
        JF=JL
      ENDIF
C Select polar angle from distribution:
C CQF(1,IQ,JF)*(ONE+COSTH**2)+CQF(3,IQ,JF)*COSTH+EXTRA*(ONE+COSTH)
      IF (ID1.EQ.ID3.OR.ID2.EQ.ID3) THEN
        EXTRA=TWO*QFCH(ID3)**4/NCOLO
      ELSE
        EXTRA=0
      ENDIF
      PMAX=2.*(CQF(1,IQ,JF)+EXTRA)+ABS(CQF(3,IQ,JF))
  100 COSTH=HWRUNI(0,-ONE,ONE)
      PTHETA=CQF(1,IQ,JF)*(ONE+COSTH**2)+TWO*CQF(3,IQ,JF)*COSTH
     &      +EXTRA*(ONE+COSTH)
      IF (PTHETA.LT.PMAX*HWRGEN(1)) GOTO 100
      IF (ID1.GT.ID2) COSTH=-COSTH
      IDCMF=200
      CALL HWETWO
  999 END
CDECK  ID>, HWHEGG.
*CMZ :-        -19/03/92  10.13.56  by  Mike Seymour
*-- Author :    Mike Seymour
C-----------------------------------------------------------------------
      SUBROUTINE HWHEGG
C----------------------------------------------------------------------
C     HARD PROCESS: EE --> EEGAMGAM --> EEFFBAR/WW
C     MEAN EVENT WEIGHT = CROSS-SECTION IN NB
C     AFTER CUTS ON PT AND MASS OF CENTRE-OF-MASS SYSTEM
C     AND COS(THETA) IN CENTRE-OF-MASS SYSTEM
C     AND TIMES BRANCHING FRACTION IF WW
C-----------------------------------------------------------------------
      INCLUDE 'HERWIG62.INC'
      DOUBLE PRECISION HWRGEN,HWULDO,EMSQ,BETA,S,T,U,TMIN,TMAX,TRAT,
     & DSDT,PROB,X,Z(2),ZMIN,ZMAX,PCMIN,PCMAX,PCFAC,PLOGMI,PLOGMA,PTCMF,
     & Q,PC,BLOG,EMCMIN,EMCMAX,EMLMIN,EMLMAX,WGT(6),RWGT,CV,CA,BR,QT(2),
     & QX(2),QY(2),PX,PY,ROOTS,DOT,A,B,C,SHAT,PCF(2),PCM(2),PCMAC,ZZ(2),
     & COLFAC
      INTEGER I,IGAM,ID,IDL,ID1,ID2,IHEP,JHEP,NADD,NTRY,NQ,JGAM
      LOGICAL HWRLOG
      EXTERNAL HWRGEN,HWULDO,HWRLOG
      SAVE S,BETA,X,ID,NQ,WGT,EMLMIN,EMLMAX,PCFAC,PLOGMA,PLOGMI,SHAT,
     &  PCF,PCM,Z,PCMAC,NADD
      IF (IERROR.NE.0) RETURN
C---INITIALIZE LOCAL COPIES OF EMMIN,EMMAX
      IF (FSTWGT) THEN
        EMLMIN=EMMIN
        EMLMAX=EMMAX
      ENDIF
      IF (.NOT.GENEV) THEN
C---CHOOSE Z1,Z2 AND CALCULATE SUB-PROCESS CROSS-SECTION
        EVWGT=0
C-----FIND FINAL STATE PARTICLES
        IHPRO=MOD(IPROC,100)
        IF (IHPRO.EQ.0) THEN
          ID=1
          NQ=6
          COLFAC=FLOAT(NCOLO)
          NADD=6
        ELSEIF (IHPRO.LE.6) THEN
          ID=IHPRO
          NQ=1
          COLFAC=FLOAT(NCOLO)
          NADD=6
          Q=QFCH(ID)
        ELSEIF (IHPRO.LE.9) THEN
          ID=119+2*(IHPRO-6)
          NQ=1
          COLFAC=1.
          NADD=6
          Q=QFCH(ID-110)
        ELSEIF (IHPRO.LE.10) THEN
          ID=198
          NQ=1
          NADD=1
        ELSE
          CALL HWWARN('HWHEGG',200,*999)
        ENDIF
C-----SPLIT ELECTRONS TO PHOTONS
        NHEP=3
        GAMWT=1
        S=2*HWULDO(PHEP(1,1),PHEP(1,2))
        ROOTS=SQRT(S)
        EMCMIN=MAX(EMLMIN,MAX(2*RMASS(ID),PTMIN))
        EMCMAX=MIN(EMLMAX,ROOTS)
        IF (EMCMIN.GT.EMCMAX) RETURN
        ZMIN=EMCMIN**2/S
        ZMAX=1-PHEP(5,1)/PHEP(4,1)
        IF (ZMIN.GT.ZMAX) RETURN
        CALL HWEGAM(1,ZMIN,ZMAX,.TRUE.)
        Z(1)=PHEP(4,NHEP-1)/PHEP(4,1)
        ZMIN=EMCMIN**2/(Z(1)*S)
        ZMAX=MIN(EMCMAX**2/(Z(1)*S), ONE-PHEP(5,2)/PHEP(4,2))
        IF (ZMIN.GT.ZMAX) RETURN
        CALL HWEGAM(2,ZMIN,ZMAX,.TRUE.)
        Z(2)=PHEP(4,NHEP-1)/PHEP(4,2)
        EMSCA=PHEP(5,3)
        SHAT=EMSCA**2
C-----REMOVE LOG TERMS FROM WEIGHT, CALCULATE NEW ONES FROM PT LIMITS
        GAMWT=GAMWT/(0.5*LOG((1-Z(1))*S/(Z(1)*PHEP(5,1)**2))
     &              *0.5*LOG((1-Z(2))*Z(1)*S/(Z(2)*PHEP(5,2)**2)))
        PCF(1)=Z(1)*PHEP(5,1)
        PCF(2)=Z(2)*PHEP(5,2)
        PCFAC=SQRT(PCF(1)*PCF(2))
        PCM(1)=(1-Z(1))*PHEP(4,1)
        PCM(2)=(1-Z(2))*PHEP(4,2)
        PCMAC=SQRT(PCM(1)*PCM(2))
        PCMIN=MAX(PTMIN,MAX(PCF(1),PCF(2)))
        PCMAX=MIN( MIN(PTMAX,PHEP(5,3)) , MIN(PCM(1),PCM(2)) )
        IF (PCMIN.GT.PCMAX) RETURN
        PLOGMI=(LOG(PCMIN/PCFAC))**2
        PLOGMA=(LOG(PCMAX/PCFAC))**2
        GAMWT=GAMWT*(PLOGMA-PLOGMI)
C-----CALCULATE CROSS-SECTION
        DO 10 IDL=1,NQ
          WGT(IDL)=EVWGT
          IF (IHPRO.EQ.0) THEN
            ID=IDL
            Q=QFCH(ID)
          ENDIF
          EMSQ=RMASS(ID)**2
          X=4*EMSQ/SHAT
          IF (X.GT.ONE) GOTO 10
          BETA=SQRT(1-X)
          BLOG=LOG((1+BETA*CTMAX)/(1-BETA*CTMAX))/BETA
          IF (IHPRO.LE.9) THEN
            EVWGT=EVWGT+GEV2NB*4*PIFAC*COLFAC*Q**4*ALPHEM**2*BETA
     &           /SHAT * GAMWT * ( (1+X-0.5*X**2)*BLOG
     &                     - CTMAX*(1+X**2/(CTMAX**2*(X-1)+1)) )
            WGT(IDL)=EVWGT
          ELSE
            CALL HWDBOZ(198,ID1,ID2,CV,CA,BR,1)
            CALL HWDBOZ(199,ID1,ID2,CV,CA,BR,1)
            EVWGT=EVWGT + GEV2NB*6*PIFAC*ALPHEM**2*BETA/SHAT*BR
     &        * GAMWT * (-(  X-0.5*X**2)*BLOG
     &                     + CTMAX*(1+(X**2+16/3.)/(CTMAX**2*(X-1)+1)) )
          ENDIF
 10     CONTINUE
C-----GAMWT MUST BE RESET TO ONE, SINCE IT IS REAPPLIED LATER!
        GAMWT=ONE
      ELSE
C---GENERATE EVENT
C-----CHOOSE PT OF THE CMF
        PTCMF=PCFAC*EXP(SQRT(HWRGEN(0)*(PLOGMA-PLOGMI)+PLOGMI))
C-----CHOOSE WHICH PHOTON USUALLY HAS SMALLER PT
        NTRY=0
 20     IGAM=1
        IF (LOG(PCM(1)/PCF(1)).LT.HWRGEN(1)*2*LOG(PCMAC/PCFAC)) IGAM=2
        JGAM=3-IGAM
C-----CHOOSE ITS PT
 30     NTRY=NTRY+1
        IF (NTRY.GT.NBTRY) CALL HWWARN('HWHEGG',100,*999)
        QT(IGAM)=(PCM(IGAM)/PCF(IGAM))**HWRGEN(2)
        PROB=(QT(IGAM)**2/(QT(IGAM)**2+1))**2
        QT(IGAM)=QT(IGAM)*PCF(IGAM)
        IF (HWRLOG(1-PROB)) GOTO 30
C-----CHOOSE ITS DIRECTION
        CALL HWRAZM(QT(IGAM),QX(IGAM),QY(IGAM))
C-----CALCULATE THE OTHER PHOTON'S PT
        QX(JGAM)=PTCMF-QX(IGAM)
        QY(JGAM)=     -QY(IGAM)
        QT(JGAM)=SQRT(QX(JGAM)**2+QY(JGAM)**2)
        IF (QT(JGAM).LT.PCF(JGAM).OR.QT(JGAM).GT.PCM(JGAM)) GOTO 20
C-----APPLY A RANDOM ROTATION AROUND THE BEAM AXIS
        CALL HWRAZM(ONE,PX,PY)
        IF (PX.EQ.ZERO) PX=1D-20
        QX(1)=(QX(1)*PX   -QY(1)*PY)
        QY(1)=(QY(1)      +QX(1)*PY)/PX
        QX(2)=(QX(2)*PX   -QY(2)*PY)
        QY(2)=(QY(2)      +QX(2)*PY)/PX
C-----RECONSTRUCT MOMENTA
        IF (QT(IGAM).GT.QT(JGAM)) THEN
          IGAM=3-IGAM
          JGAM=3-JGAM
        ENDIF
        DOT=-Z(JGAM)*S+SHAT+2*(QX(1)*QX(2)+QY(1)*QY(2))
C-------SOLVE QUADRATIC IN Z(IGAM) TO FIND ELECTRON ENERGIES
        A=S*(S*Z(JGAM)+QT(JGAM)**2)
        B=S*DOT*(1+Z(JGAM))
        C=DOT**2+S*QT(IGAM)**2*(1-Z(JGAM))**2-4*QT(IGAM)**2*QT(JGAM)**2
        IF (B**2.LT.4*A*C) GOTO 20
        ZZ(IGAM)=(-B+SQRT(B**2-4*A*C))/(2*A)
        IF (ZZ(IGAM).LT.ZERO .OR. ZZ(IGAM).GT.ONE-Z(IGAM)) GOTO 20
        ZZ(JGAM)=1-Z(JGAM)
C-------REJECT AGAINST PHOTON DISTRIBUTION FUNCTION
        PROB=((1+ZZ(IGAM)**2)/(1-ZZ(IGAM)))/((1+(1-Z(IGAM))**2)/Z(IGAM))
     &      *((1+ZZ(JGAM)**2)/(1-ZZ(JGAM)))/((1+(1-Z(JGAM))**2)/Z(JGAM))
        IF (HWRLOG(1-PROB)) GOTO 20
C-------RECONSTRUCT ALL OTHER VARIABLES
        DO 40 I=1,2
          IGAM=2*I+3
          PHEP(1,IGAM)=QX(I)
          PHEP(2,IGAM)=QY(I)
          PHEP(4,IGAM)=ZZ(I)*PHEP(4,I)
          PHEP(5,IGAM)=RMASS(IDHW(IGAM))
C---------IF MOMENTUM CANNOT BE CONSERVED TRY AGAIN
          IF (PHEP(4,IGAM)**2-PHEP(5,IGAM)**2-QT(I)**2 .LT. 0) GOTO 20
          PHEP(3,IGAM)=SIGN(SQRT(PHEP(4,IGAM)**2-PHEP(5,IGAM)**2-
     &      QT(I)**2),PHEP(3,IGAM))
          CALL HWVDIF(4,PHEP(1,I),PHEP(1,IGAM),PHEP(1,IGAM-1))
          CALL HWUMAS(PHEP(1,IGAM-1))
 40     CONTINUE
C-----TIDY UP EVENT RECORD
        NHEP=NHEP+1
        IDHW(NHEP)=IDHW(3)
        IDHEP(NHEP)=IDHEP(3)
        ISTHEP(NHEP)=110
        CALL HWVSUM(4,PHEP(1,4),PHEP(1,6),PHEP(1,NHEP))
        CALL HWVSUM(4,PHEP(1,1),PHEP(1,2),PHEP(1,3))
        CALL HWUMAS(PHEP(1,NHEP))
        CALL HWUMAS(PHEP(1,3))
        JMOHEP(1,NHEP)=4
        JMOHEP(2,NHEP)=6
        JMOHEP(1,3)=0
        JMOHEP(2,3)=0
C-----CHOOSE FINAL STATE QUARK
        IF (IHPRO.EQ.0) THEN
          RWGT=HWRGEN(2)*EVWGT
          ID=1
          DO 50 IDL=1,NQ
            IF (RWGT.GT.WGT(IDL)) ID=IDL+1
 50       CONTINUE
          EMSQ=RMASS(ID)**2
          X=4*EMSQ/SHAT
          BETA=SQRT(1-X)
        ENDIF
C-----CHOOSE T (WHERE T = MANDELSTAM_T - EMSQ)
        TMIN=-SHAT/2
        TMAX=-SHAT/2*(1-BETA*CTMAX)
        TRAT=TMAX/TMIN
        NTRY=0
        IF (IHPRO.LE.9) THEN
C-------FOR FFBAR, CHOOSE T ACCORDING TO -SHAT/T
 60       NTRY=NTRY+1
          IF (NTRY.GT.NBTRY) CALL HWWARN('HWHEGG',101,*999)
          T=TRAT**HWRGEN(3)*TMIN
          U=-T-SHAT
C-------REWEIGHT TO CORRECT DISTRIBUTION
          DSDT=(T*U-2*EMSQ*(T+2*EMSQ))/T**2
     &        +( 2*EMSQ*(SHAT-4*EMSQ))/(T*U)
     &        +(T*U-2*EMSQ*(U+2*EMSQ))/U**2
          PROB=-DSDT*T/SHAT / (1 + 2*X - 2*X**2)
          IF (HWRLOG(1-PROB)) GOTO 60
        ELSE
C-------FOR WW, CHOOSE T ACCORDING TO (SHAT/T)**2
 70       NTRY=NTRY+1
          IF (NTRY.GT.NBTRY) CALL HWWARN('HWHEGG',102,*999)
          T=TMAX/(1-(1-TRAT)*HWRGEN(4))
          U=-T-SHAT
C-------REWEIGHT TO CORRECT DISTRIBUTION
          DSDT=( 3*(T*U)**2 - SHAT*T*U*(4*SHAT+6*EMSQ)
     &      + SHAT**2*(2*SHAT**2+6*EMSQ**2) ) / (T*U)**2
          PROB=DSDT*(T/SHAT)**2 / (4.75 - 1.5*X + 1.5*X**2)
          IF (HWRLOG(1-PROB)) GOTO 70
        ENDIF
C-----SYMMETRIZE IN T,U
        IF (HWRLOG(HALF)) T=U
C-----FILL EVENT RECORD
        COSTH=(1+2*T/SHAT)/BETA
        PC=0.5*BETA*PHEP(5,NHEP)
        PHEP(5,NHEP+1)=RMASS(ID)
        PHEP(5,NHEP+2)=RMASS(ID)
        CALL HWDTWO(PHEP(1,NHEP),PHEP(1,NHEP+1),PHEP(1,NHEP+2),
     &              PC,COSTH,.TRUE.)
        DO 80 I=1,2
          IHEP=NHEP+I
          JHEP=NHEP+3-I
          ISTHEP(IHEP)=190
          IF (IHPRO.LE.6) ISTHEP(IHEP)=112+I
          IDHW(IHEP)=ID+NADD*(I-1)
          IDHEP(IHEP)=IDPDG(IDHW(IHEP))
          JDAHEP(I,NHEP)=IHEP
          JMOHEP(1,IHEP)=NHEP
          JMOHEP(2,IHEP)=JHEP
          JDAHEP(2,IHEP)=JHEP
          IF (IHPRO.EQ.10) THEN
            RHOHEP(1,IHEP)=0.3333
            RHOHEP(2,IHEP)=0.3333
            RHOHEP(3,IHEP)=0.3333
          ENDIF
 80     CONTINUE
        NHEP=NHEP+2
      ENDIF
 999  END
CDECK  ID>, HWHEGW.
*CMZ :-        -26/04/91  10.18.56  by  Bryan Webber
*-- Author :    Mike Seymour
C-----------------------------------------------------------------------
      SUBROUTINE HWHEGW
C----------------------------------------------------------------------
C     W + GAMMA --> FF'BAR :  MEAN EVWGT = CROSS SECTION IN NANOBARN
C     BASED ON BOSON GLUON FUSION OF ABBIENDI AND STANCO
C-----------------------------------------------------------------------
      INCLUDE 'HERWIG62.INC'
      DOUBLE PRECISION HWRGEN,GMASS,EV(3),RV,Y,Q2,SHAT,Z,PHI,AJACOB,
     & DSIGMA,ME,MP,ML,MREMIF(18),MFIN1(18),MFIN2(18),RS,SMA,W2,RSHAT
      INTEGER LEP
      INTEGER LEPFIN,ID1,ID2,I,IQK,IFLAVU,IFLAVD,IMIN,IMAX,IFL,IPROO
      LOGICAL CHARGD,INCLUD(18),INSIDE(18)
      EXTERNAL HWRGEN
      SAVE LEPFIN,ID1,ID2
      COMMON /HWAREA/ Y,Q2,SHAT,Z,PHI,AJACOB,DSIGMA,ME,MP,ML,MREMIF,
     & MFIN1,MFIN2,RS,SMA,W2,RSHAT,IQK,IFLAVU,IFLAVD,IMIN,IMAX,IFL,LEP,
     & IPROO,CHARGD,INCLUD,INSIDE
      IQK=MOD(IPROC,10)
      CHARGD=.TRUE.
      IF(GENEV) THEN
C
        IDHW(4)=IDHW(1)
        IDHW(5)=59
        IDHW(6)=15
        IDHW(7)=LEPFIN
        IDHW(8)=ID1
        IDHW(9)=ID2
        DO 1 I=4,9
    1   IDHEP(I)=IDPDG(IDHW(I))
C
        IFLAVD=ID1
        IFLAVU=ID2-6
C
        ISTHEP(4)=111
        ISTHEP(5)=112
        ISTHEP(6)=110
        ISTHEP(7)=113
        ISTHEP(8)=114
        ISTHEP(9)=114
C
        JMOHEP(1,4)=6
        JMOHEP(2,4)=7
        JMOHEP(1,5)=6
        JMOHEP(2,5)=5
        JMOHEP(1,6)=4
        JMOHEP(2,6)=5
        JMOHEP(1,7)=6
        JMOHEP(2,7)=4
        JMOHEP(1,8)=6
        JMOHEP(2,8)=9
        JMOHEP(1,9)=6
        JMOHEP(2,9)=8
        JDAHEP(1,4)=0
        JDAHEP(2,4)=7
        JDAHEP(1,5)=0
        JDAHEP(2,5)=5
        JDAHEP(1,6)=7
        JDAHEP(2,6)=9
        JDAHEP(1,7)=0
        JDAHEP(2,7)=4
        JDAHEP(1,8)=0
        JDAHEP(2,8)=9
        JDAHEP(1,9)=0
        JDAHEP(2,9)=8
C---COMPUTATION OF MOMENTA IN LABORATORY FRAME OF REFERENCE
C---Persuade HWHBKI that the gluon is actually a photon...
        GMASS=RMASS(13)
        RMASS(13)=0
        CALL HWHBKI
        RMASS(13)=GMASS
C---put the other outgoing lepton in as well
        IDHW(10)=IDHW(2)
        IDHEP(10)=IDPDG(IDHW(10))
        ISTHEP(10)=1
        JMOHEP(1,10)=2
        JMOHEP(2,10)=0
        JDAHEP(1,10)=0
        JDAHEP(2,10)=0
        JDAHEP(1,2)=5
        JDAHEP(2,2)=10
        CALL HWVDIF(4,PHEP(1,2),PHEP(1,5),PHEP(1,10))
        CALL HWUMAS(PHEP(1,10))
        NHEP=10
C
C---if antilepton was first, do charge conjugation
        IF (LEP.EQ.-1) THEN
          DO 27 I=7,9
            IF (IDHEP(I).NE.0 .AND. ABS(IDHEP(I)).LT.20) THEN
              IDHW(I)=IDHW(I) + 6*SIGN(1,IDHEP(I))
              IDHEP(I)=-IDHEP(I)
            ENDIF
 27       CONTINUE
        ENDIF
C
C---half the time, do charge conjugation and parity flip
        IF (HWRGEN(0).GT.HALF) THEN
          DO 2 I=4,10
            IF (IDHEP(I).NE.0 .AND. ABS(IDHEP(I)).LT.20) THEN
              IDHW(I)=IDHW(I) + 6*SIGN(1,IDHEP(I))
              IDHEP(I)=-IDHEP(I)
            ENDIF
            PHEP(1,I)=-PHEP(1,I)
            PHEP(2,I)=-PHEP(2,I)
            PHEP(3,I)=-PHEP(3,I)
 2        CONTINUE
          JMOHEP(1,10)=3-JMOHEP(1,10)
        ENDIF
C
      ELSE
C
        EVWGT=ZERO
C---LEP = 1 IF TRACK 1 IS A LEPTON, -1 FOR ANTILEPTON
        LEP=0
        IF (IDHW(1).GE.121.AND.IDHW(1).LE.126) THEN
          LEP=1
        ELSEIF (IDHW(1).GE.127.AND.IDHW(1).LE.132) THEN
          LEP=-1
        ENDIF
        IF (LEP.EQ.0) CALL HWWARN('HWHEGW',500,*999)
C---program only works if beam and target are charge conjugates
        IF (LEP*(IDHW(2)-IDHW(1)).NE.6)
     &   CALL HWWARN('HWHEGW',501,*999)
C---program only works for equal energy beams colliding
        IF (PHEP(3,3).NE.ZERO) CALL HWWARN('HWHEGW',503,*999)
C
C---FINAL STATE IS ALWAYS SET UP AS IF PARTICLE IS BEFORE ANTI-PARTICLE
C   AND THEN INVERTED IF NECESSARY
        LEPFIN = MIN(IDHW(1),IDHW(2))+1
        IF (IQK.LE.2) THEN
          IFLAVU=2
          IFLAVD=1
          ID1  = 1
          ID2  = 8
        ELSEIF (IQK.LE.4) THEN
          IFLAVU=4
          IFLAVD=3
          ID1  = 3
          ID2  =10
        ELSEIF (IQK.LE.6) THEN
          IFLAVU=6
          IFLAVD=5
          ID1  = 5
          ID2  =12
        ELSEIF (IQK.EQ.7) THEN
          IFLAVU=122
          IFLAVD=121
          ID1  = 121
          ID2  = 128
C---INTERFERENCE TERMS IN EE -> EE NUE NUEB  NEGLECTED: SIGMA UNRELIABLE
          IF (FSTWGT) CALL HWWARN('HWHEGW',1,*999)
        ELSEIF (IQK.EQ.8) THEN
          IFLAVU=124
          IFLAVD=123
          ID1  = 123
          ID2  = 130
        ELSEIF (IQK.EQ.9) THEN
          IFLAVU=126
          IFLAVD=125
          ID1  = 125
          ID2  = 132
        ELSE
          CALL HWWARN('HWHEGW',504,*999)
        ENDIF
        IF (IQK.GT.0) THEN
          IF (IQK.LE.6) IQK=0
          CALL HWHBRN(*999)
          CALL HWHEGX
          EVWGT = 2 * DSIGMA * AJACOB
          IF (EVWGT.LT.ZERO) EVWGT=ZERO
        ELSE
C---SUM OVER QUARK FLAVOURS
          CALL HWHBRN(*999)
          DO 3 I=1,3
            IF (SHAT.GT.(RMASS(IFLAVD)+RMASS(IFLAVU))**2) THEN
              CALL HWHEGX
              EV(I) = 2 * DSIGMA * AJACOB
              IF (EV(I).LT.ZERO) EV(I)=ZERO
            ELSE
              EV(I)=ZERO
            ENDIF
            EVWGT=EVWGT+EV(I)
            EV(I)=EVWGT
            IFLAVU=IFLAVU+2
            IFLAVD=IFLAVD+2
 3        CONTINUE
C---CHOOSE QUARK FLAVOUR
          RV=EV(3)*HWRGEN(1)
          IF (RV.LT.EV(1)) THEN
            ID1 = 1
            ID2 = 8
          ELSEIF (RV.LT.EV(2)) THEN
            ID1 = 3
            ID2 =10
          ELSE
            ID1 = 5
            ID2 =12
          ENDIF
        ENDIF
      ENDIF
  999 END
CDECK  ID>, HWHEGX.
*CMZ :-        -17/07/92  16.42.56  by  Mike Seymour
*-- Author :    Mike Seymour
C-----------------------------------------------------------------------
      SUBROUTINE HWHEGX
C-----------------------------------------------------------------------
C     COMPUTES DIFFERENTIAL CROSS SECTION DSIGMA IN (Y,Q2,ETA,Z,PHI)
C-----------------------------------------------------------------------
      INCLUDE 'HERWIG62.INC'
      DOUBLE PRECISION TMAX,TMIN,A1,A2,B1,B2,I0,I1,I2,I3,I4,I5,MUSQ,
     & MDSQ,ETA,Q1,COSTHE,S,G,T,U,C1,C2,D1,D2,F1,F2,COSBET,WPROP,D(4,4),
     & C(4,4),QU,QD,QE,QW,PHOTON,EMWSQ,EMSSQ,CFAC,Y,Q2,SHAT,Z,PHI,
     & AJACOB,DSIGMA,ME,MP,ML,MREMIF(18),MFIN1(18),MFIN2(18),RS,SMA,W2,
     & RSHAT
      INTEGER IQK,IFLAVU,IFLAVD,IMIN,IMAX,IFL,IPROO,I,J,LEP
      LOGICAL CHARGD,INCLUD(18),INSIDE(18)
      COMMON /HWAREA/ Y,Q2,SHAT,Z,PHI,AJACOB,DSIGMA,ME,MP,ML,MREMIF,
     & MFIN1,MFIN2,RS,SMA,W2,RSHAT,IQK,IFLAVU,IFLAVD,IMIN,IMAX,IFL,LEP,
     & IPROO,CHARGD,INCLUD,INSIDE
C---INPUT VARIABLES
      IF (IERROR.NE.0) RETURN
      DSIGMA=0
      IF (IFLAVU.LE.12) THEN
        QU=QFCH(MOD(IFLAVU-1,6)+1)
        QD=QFCH(MOD(IFLAVD-1,6)+1)
        CFAC=CAFAC
      ELSE
        QU=QFCH(MOD(IFLAVU-1,6)+11)
        QD=QFCH(MOD(IFLAVD-1,6)+11)
        CFAC=1
      ENDIF
      QE=QFCH(11)
      QW=+1
      EMWSQ=RMASS(198)**2
      EMSCA=PHEP(5,3)
      EMSSQ=EMSCA**2
      MUSQ=RMASS(IFLAVU)**2
      MDSQ=RMASS(IFLAVD)**2
      ETA=(SHAT+Q2)/EMSSQ/Y
      IF (ETA.GT.ONE) RETURN
C---CALCULATE KINEMATIC TERMS
      G=0.5*(ETA*EMSSQ*Y-Q2) -0.5*(MUSQ+MDSQ)
      S=0.5*ETA*EMSSQ
      T=0.5*ETA*EMSSQ*(1-Y)
      U=0.5*Q2
      C1=0.5*ETA*EMSSQ*Y*Z
      C2=0.5*ETA*EMSSQ*Y*(1-Z)
      COSBET=(-ETA*EMSSQ*Y+Q2*(2-Y))/(Y*(ETA*EMSSQ-Q2))
      IF (SHAT.LE.(RMASS(IFLAVU)+RMASS(IFLAVD))**2) RETURN
      Q1=SQRT((SHAT**2+MUSQ**2+MDSQ**2
     &  -2*SHAT*MUSQ-2*SHAT*MDSQ-2*MUSQ*MDSQ)/SHAT**2)
      COSTHE=(1+(MDSQ-MUSQ)/SHAT-2*Z)/Q1
      IF (ABS(COSTHE).GE.ONE .OR. ABS(COSBET).GE.ONE) RETURN
      D1=0.25*(ETA*EMSSQ-Q2)*(1+(MDSQ-MUSQ)/SHAT-Q1*
     &     (COSTHE*COSBET+SQRT((1-COSTHE**2)*(1-COSBET**2))*COS(PHI)))
      D2=S-U-D1
      F1=D1+C1-G            -MDSQ
      F2=U+T-F1
C---CALCULATE TRACE TERMS
      CALL HWVZRO(16,D)
      CALL HWVZRO(16,C)
      D(1,1)=2*F1*C2*S
      D(2,2)=2*C1*D2*T
      D(3,3)=-D1*(2*F2*G-D2*(F1+2*U))
     &       -D2*F1*(F2+U-D2+F1)
     &       +2*F1*F2*U
     &       -G*(-2*D1*(F1+F2+U)-F1*(D2+2*U)+2*D2*(U-F2)+2*U*(F2-U+G))
      D(4,4)=2*F1*C2*S
      D(1,2)=(D1+U-F2)*(D1*F2-F1*D2)-G*(D1*(F2+U)+U*(U-F2-G)+F1*D2)
      D(1,3)=D1*F2*(-2*F1+U-F2+D1)
     &      +F1*(F2*(D2-2*U)+F1*D2)
     &      +G*(-D1*(2*F1+F2+U)-F1*(D2+2*U)+U*(F2-U+G))
      D(1,4)=-2*F1*(D1+U)*(F2+G)
      D(2,3)=D1*(D2*(F1+2*(U-F2))+F2*(F2-U-D1))
     &      +F1*D2**2
     &      +G*(D1*(F2+U)+D2*(F1-2*(U-F2))+U*(U-F2-G))
      D(2,4)=-D1*F2*(U-F2+D1)
     &       -F1*D2*(U-D1-G-F2)
     &       -G*(U*(F2-U+G)-D1*(F2+U))
      D(3,4)=D1*(F1*(D2+2*F2)+F2*(F2-U-D1))
     &      +F1*(2*F2*U-D2*(U+F1))
     &      +G*(D1*(2*F1+F2+U)+U*(2*F1-F2+U-G))
C---REGULATE PROPAGATORS
      TMAX=EMSSQ-2*G
      TMIN=PHEP(5,2)**2
      A1=2*C1+MDSQ*(G+U)/G
      A2=2*C2+MUSQ*(G+U)/G
      B1=(2*U+MUSQ)/(2*G+2*U)
      B2=(2*U+MDSQ)/(2*G+2*U)
      I0=LOG(TMAX/TMIN)
      I1=1/A1*(I0-LOG((A1+B1*TMAX)/(A1+B1*TMIN)))
      I2=1/A2*(I0-LOG((A2+B2*TMAX)/(A2+B2*TMIN)))
      I3=(B1*I1-B2*I2)/(B1*A2-B2*A1)
      I4=1/A1*(I1+1/(A1+B1*TMAX)-1/(A1+B1*TMIN))
      I5=1/A2*(I2+1/(A2+B2*TMAX)-1/(A2+B2*TMIN))
      WPROP=1/((2*G-EMWSQ)**2+GAMW**2*EMWSQ)
C---CALCULATE COEFFICIENTS
      C(1,1)=    QU**2/(2*U+EMWSQ)**2                       *I5
      C(2,2)=    QD**2/(2*U+EMWSQ)**2                       *I4
      C(3,3)=    QW**2/(2*U+EMWSQ)**2    *WPROP             *I0
      C(4,4)=    QE**2/(2*S)**2          *WPROP             *I0
      C(1,2)=  2*QU*QD/(2*U+EMWSQ)**2                       *I3
      C(1,3)=  2*QW*QU/(2*U+EMWSQ)**2    *WPROP*(2*G-EMWSQ) *I2
      C(1,4)=  2*QU*QE/(2*S*(2*U+EMWSQ)) *WPROP*(2*G-EMWSQ) *I2
      C(2,3)=  2*QW*QD/(2*U+EMWSQ)**2    *WPROP*(2*G-EMWSQ) *I1
      C(2,4)=  2*QD*QE/(2*S*(2*U+EMWSQ)) *WPROP*(2*G-EMWSQ) *I1
      C(3,4)=  2*QW*QE/(2*S*(2*U+EMWSQ)) *WPROP             *I0
C---CALCULATE PHOTON STRUCTURE FUNCTION
      PHOTON=ALPHEM * (1+(1-ETA)**2) / (2*PIFAC*ETA)
C---SUM ALL TENSOR CONTRIBUTIONS
      DO 10 I=1,4
      DO 10 J=1,4
 10     DSIGMA=DSIGMA + C(I,J)*D(I,J)
C---CALCULATE TOTAL SUMMED AND AVERAGED MATRIX ELEMENT SQUARED
      DSIGMA = DSIGMA * 2*CFAC*(4*PIFAC*ALPHEM)**3/SWEIN**2
C---CALCULATE DIFFERENTIAL CROSS-SECTION
      DSIGMA = DSIGMA * GEV2NB*PHOTON/(512*PIFAC**4*ETA*EMSSQ)
 999  END
CDECK  ID>, HWHEPA.
*CMZ :-        -26/04/91  14.55.44  by  Federico Carminati
*-- Author :    Bryan Webber and Ian Knowles
C-----------------------------------------------------------------------
      SUBROUTINE HWHEPA
C-----------------------------------------------------------------------
C     (Initially polarised) e+e- --> ffbar (f=quark, mu or tau)
C     If IPROC=107: --> gg, distributed as sum of light quarks.
C     If fermion flavour specified mass effects fully included.
C     EVWGT=sig(e+e- --> ffbar) in nb
C-----------------------------------------------------------------------
      INCLUDE 'HERWIG62.INC'
      DOUBLE PRECISION HWRGEN,HWRUNI,HWUPCM,HWUAEM,Q2NOW,Q2LST,FACTR,
     & VF2,VF,CLF(7),PRAN,PQWT,PMAX,PTHETA,SINTH2,CPHI,SPHI,C2PHI,S2PHI,
     & PPHI,SINTH,PCM,PP(5),EWGT
      INTEGER ID1,ID2,IDF,IQ,IQ1,I
      EXTERNAL HWRGEN,HWRUNI,HWUPCM,HWUAEM
      SAVE Q2LST,FACTR,ID1,ID2,VF2,VF,CLF,EWGT
      DATA Q2LST/0./
      IF (GENEV) THEN
        IF (ID2.EQ.0) THEN
C Choose quark flavour
          PRAN=TQWT*HWRGEN(0)
          PQWT=0.
          DO 10 IQ=1,MAXFL
          PQWT=PQWT+CLQ(1,IQ)
          IF (PQWT.GT.PRAN) GOTO 11
   10     CONTINUE
          IQ=MAXFL
   11     IQ1=MAPQ(IQ)
          DO 20 I=1,7
   20     CLF(I)=CLQ(I,IQ)
        ELSE
          IQ1=ID1
        ENDIF
C Label particles, assign outgoing particle masses
        IDHW(NHEP+1)=200
        IDHEP(NHEP+1)=23
        ISTHEP(NHEP+1)=110
        IF (ID1.EQ.7) THEN
          IDHW(NHEP+2)=13
          IDHW(NHEP+3)=13
          IDHEP(NHEP+2)=21
          IDHEP(NHEP+3)=21
          PHEP(5,NHEP+2)=RMASS(13)
          PHEP(5,NHEP+3)=RMASS(13)
        ELSE
          IDHW(NHEP+2)=IQ1
          IDHW(NHEP+3)=IQ1+6
          IDHEP(NHEP+2)=IDPDG(IQ1)
          IDHEP(NHEP+3)=-IDHEP(NHEP+2)
          PHEP(5,NHEP+2)=RMASS(IQ1)
          PHEP(5,NHEP+3)=RMASS(IQ1)
        ENDIF
        ISTHEP(NHEP+2)=113
        ISTHEP(NHEP+3)=114
        JMOHEP(1,NHEP+1)=1
        IF (JDAHEP(1,1).NE.0) JMOHEP(1,NHEP+1)=JDAHEP(1,1)
        JMOHEP(2,NHEP+1)=2
        IF (JDAHEP(1,2).NE.0) JMOHEP(1,NHEP+1)=JDAHEP(1,2)
        JMOHEP(1,NHEP+2)=NHEP+1
        JMOHEP(2,NHEP+2)=NHEP+3
        JMOHEP(1,NHEP+3)=NHEP+1
        JMOHEP(2,NHEP+3)=NHEP+2
        JDAHEP(1,NHEP+1)=NHEP+2
        JDAHEP(2,NHEP+1)=NHEP+3
        JDAHEP(1,NHEP+2)=0
        JDAHEP(2,NHEP+2)=NHEP+3
        JDAHEP(1,NHEP+3)=0
        JDAHEP(2,NHEP+3)=NHEP+2
C Generate polar and azimuthal angular distributions:
C  CLF(1)*(1+(VF*COSTH)**2)+CLF(2)*(1-VF**2)+CLF(3)*2.*VF*COSTH
C +(VF*SINTH)**2*(CLF(4)*COS(2*PHI-PHI1-PHI2)
C                +CLF(6)*SIN(2*PHI-PHI1-PHI2))
        PMAX=CLF(1)*(1.+VF2)+CLF(2)*(1.-VF2)+ABS(CLF(3))*2.*VF
  30    COSTH=HWRUNI(0,-ONE, ONE)
        PTHETA=CLF(1)*(1.+VF2*COSTH**2)+CLF(2)*(1.-VF2)
     &        +CLF(3)*2.*VF*COSTH
        IF (PTHETA.LT.PMAX*HWRGEN(1)) GOTO 30
        IF (IDHW(1).GT.IDHW(2)) COSTH=-COSTH
        SINTH2=1.-COSTH**2
        IF (TPOL) THEN
          PMAX=PTHETA+VF2*SINTH2*SQRT(CLF(4)**2+CLF(6)**2)
  40      CALL HWRAZM(ONE,CPHI,SPHI)
          C2PHI=2.*CPHI**2-1.
          S2PHI=2.*CPHI*SPHI
          PPHI=PTHETA+(CLF(4)*(C2PHI*COSS+S2PHI*SINS)
     &                +CLF(6)*(S2PHI*COSS-C2PHI*SINS))*VF2*SINTH2
          IF (PPHI.LT.PMAX*HWRGEN(1)) GOTO 40
        ELSE
          CALL HWRAZM(ONE,CPHI,SPHI)
        ENDIF
C Construct final state 4-mommenta
        CALL HWVEQU(5,PHEP(1,3),PHEP(1,NHEP+1))
        PCM=HWUPCM(PHEP(5,NHEP+1),PHEP(5,NHEP+2),PHEP(5,NHEP+3))
C PP is momentum of track NHEP+2 in CoM (track NHEP+1) frame
        SINTH=SQRT(SINTH2)
        PP(5)=PHEP(5,NHEP+2)
        PP(1)=PCM*SINTH*CPHI
        PP(2)=PCM*SINTH*SPHI
        PP(3)=PCM*COSTH
        PP(4)=SQRT(PCM**2+PP(5)**2)
        CALL HWULOB(PHEP(1,NHEP+1),PP(1),PHEP(1,NHEP+2))
        CALL HWVDIF(4,PHEP(1,NHEP+1),PHEP(1,NHEP+2),PHEP(1,NHEP+3))
C Set production vertices
        CALL HWVZRO(4,VHEP(1,NHEP+2))
        CALL HWVEQU(4,VHEP(1,NHEP+2),VHEP(1,NHEP+3))
        NHEP=NHEP+3
      ELSE
        EMSCA=PHEP(5,3)
        Q2NOW=EMSCA**2
        IF (Q2NOW.NE.Q2LST) THEN
C Calculate coefficients for cross-section
          EMSCA=PHEP(5,3)
          Q2LST=Q2NOW
          FACTR=PIFAC*GEV2NB*HWUAEM(Q2NOW)**2/Q2NOW
          ID1=MOD(IPROC,10)
          ID2=MOD(ID1,7)
          IF (ID2.EQ.0) THEN
            CALL HWUEEC(1)
            VF2=1.
            VF=1.
            EWGT=FACTR*FLOAT(NCOLO)*TQWT*4./3.
          ELSE
            IF (IPROC.LT.150) THEN
              IDF=ID1
              FACTR=FACTR*FLOAT(NCOLO)
            ELSE
              ID1=2*ID1+119
              IDF=ID1-110
            ENDIF
            IF (EMSCA.LE.2.*RMASS(ID1)) then
              EWGT=0.
            ELSE
              CALL HWUCFF(11,IDF,Q2NOW,CLF(1))
              VF2=1.-4.*RMASS(ID1)**2/Q2NOW
              VF=SQRT(VF2)
              EWGT=FACTR*VF*(CLF(1)*(1.+VF2/3.)+CLF(2)*(1.-VF2))
            ENDIF
          ENDIF
        ENDIF
        EVWGT=EWGT
      ENDIF
  999 END
CDECK  ID>, HWHEPG.
*CMZ :-        -02/05/91  10.57.27  by  Federico Carminati
*-- Author :    Bryan Webber and Ian Knowles
C-----------------------------------------------------------------------
      SUBROUTINE HWHEPG
C-----------------------------------------------------------------------
C     (Initially polarised) e-e+ --> qqbar g with parton thrust < THMAX,
C     equivalent to: maximum parton energy < THMAX*EMSCA/2; or a JADE E0
c     scheme, y_cut=1.-THMAX.
C     If flavour specified mass effects fully included.
C     EVWGT=sig(e^-e^+ --> qqbar g) in nb
C-----------------------------------------------------------------------
      INCLUDE 'HERWIG62.INC'
      DOUBLE PRECISION HWRGEN,HWUALF,HWUAEM,HWULDO,HWDPWT,Q2NOW,Q2LST,
     & PHASP,QGMAX,QGMIN,FACTR,QM2,CLF(7),ORDER,PRAN,PQWT,QQG,QBG,SUM,
     & RUT,QQLM,QQLP,QBLM,QBLP,DYN1,DYN2,DYN3,DYN4,DYN5,DYN6,XQ2,X2SUM,
     & PVRT(4)
      INTEGER ID1,IQ,I,LM,LP,IQ1
      LOGICAL MASS
      EXTERNAL HWRGEN,HWUALF,HWUAEM,HWULDO,HWDPWT
      SAVE Q2NOW,Q2LST,QGMAX,QGMIN,FACTR,ORDER,ID1,MASS,QM2,CLF,LM,LP,
     & IQ1,QQG,QBG,SUM
      DATA Q2LST/0./
      IF (GENEV) THEN
C Label produced partons and calculate gluon spin
        IDHW(NHEP+1)=200
        IDHW(NHEP+2)=IQ1
        IDHW(NHEP+3)=13
        IDHW(NHEP+4)=IQ1+6
        IDHEP(NHEP+1)=23
        IDHEP(NHEP+2)=IQ1
        IDHEP(NHEP+3)=21
        IDHEP(NHEP+4)=-IQ1
        ISTHEP(NHEP+1)=110
        ISTHEP(NHEP+2)=113
        ISTHEP(NHEP+3)=114
        ISTHEP(NHEP+4)=114
        JMOHEP(1,NHEP+1)=LM
        JMOHEP(2,NHEP+1)=LP
        JMOHEP(1,NHEP+2)=NHEP+1
        JMOHEP(2,NHEP+2)=NHEP+3
        JMOHEP(1,NHEP+3)=NHEP+1
        JMOHEP(2,NHEP+3)=NHEP+4
        JMOHEP(1,NHEP+4)=NHEP+1
        JMOHEP(2,NHEP+4)=NHEP+2
        JDAHEP(1,NHEP+1)=NHEP+2
        JDAHEP(2,NHEP+1)=NHEP+4
        JDAHEP(1,NHEP+2)=0
        JDAHEP(2,NHEP+2)=NHEP+4
        JDAHEP(1,NHEP+3)=0
        JDAHEP(2,NHEP+3)=NHEP+2
        JDAHEP(1,NHEP+4)=0
        JDAHEP(2,NHEP+4)=NHEP+3
C Decide which quark radiated and assign production vertices
        XQ2=(Q2NOW-2.*QBG)**2
        X2SUM=XQ2+(Q2NOW-2.*QQG)**2
        IF (XQ2.LT.HWRGEN(0)*X2SUM) THEN
C Quark radiated the gluon
          CALL HWVZRO(4,VHEP(1,NHEP+4))
          CALL HWVSUM(4,PHEP(1,NHEP+2),PHEP(1,NHEP+3),PVRT)
          CALL HWUDKL(IQ1,PVRT,VHEP(1,NHEP+3))
          CALL HWVEQU(4,VHEP(1,NHEP+3),VHEP(1,NHEP+2))
        ELSE
C Anti-quark radiated the gluon
          CALL HWVZRO(4,VHEP(1,NHEP+2))
          CALL HWVSUM(4,PHEP(1,NHEP+4),PHEP(1,NHEP+3),PVRT)
          CALL HWUDKL(IQ1,PVRT,VHEP(1,NHEP+3))
          CALL HWVEQU(4,VHEP(1,NHEP+3),VHEP(1,NHEP+4))
        ENDIF
        IF (AZSPIN) THEN
C  Calculate the transverse polarisation of the gluon
C  Correlation with leptons presently neglected
           GPOLN=(QQG**2+QBG**2)/((Q2NOW-2.*SUM)*Q2NOW)
           GPOLN=2./(2.+GPOLN)
        ENDIF
        NHEP=NHEP+4
      ELSE
        EMSCA=PHEP(5,3)
        Q2NOW=EMSCA**2
        IF (Q2NOW.NE.Q2LST) THEN
          Q2LST=Q2NOW
          PHASP=3.*THMAX-2.
          IF (PHASP.LE.ZERO) CALL HWWARN('HWHEPG',400,*999)
          QGMAX=.5*Q2NOW*THMAX
          QGMIN=.5*Q2NOW*(1.-THMAX)
          FACTR=GEV2NB*FLOAT(NCOLO)*CFFAC*HWUALF(1,EMSCA)
     &         *.5*(HWUAEM(Q2NOW)*PHASP)**2/Q2NOW
          LM=1
          IF (JDAHEP(1,LM).NE.0) LM=JDAHEP(1,LM)
          LP=2
          IF (JDAHEP(1,LP).NE.0) LP=JDAHEP(1,LP)
          ORDER=1.
          IF (IDHW(1).GT.IDHW(2)) ORDER=-ORDER
          ID1=MOD(IPROC,10)
          IF (ID1.NE.0) THEN
             MASS=.TRUE.
             QM2=RMASS(ID1)**2
             CALL HWUCFF(11,ID1,Q2NOW,CLF(1))
             FACTR=FACTR*CLF(1)
          ELSE
             MASS=.FALSE.
             CALL HWUEEC(1)
             FACTR=FACTR*TQWT
          ENDIF
        ENDIF
        IF (ID1.EQ.0) THEN
C Select quark flavour
          PRAN=TQWT*HWRGEN(1)
          PQWT=0.
          DO 10 IQ=1,MAXFL
          PQWT=PQWT+CLQ(1,IQ)
          IF (PQWT.GT.PRAN) GOTO 11
   10     CONTINUE
          IQ=MAXFL
   11     IQ1=MAPQ(IQ)
          DO 20 I=1,7
   20     CLF(I)=CLQ(I,IQ)
        ELSEIF (Q2NOW.GT.4*QM2/(2*THMAX-1)) THEN
          IQ1=ID1
        ELSE
          EVWGT=0.
          RETURN
        ENDIF
C Select final state momentum configuration
        CALL HWVEQU(5,PHEP(1,3),PHEP(1,NHEP+1))
        PHEP(5,NHEP+2)=RMASS(IQ1)
        PHEP(5,NHEP+3)=RMASS(13)
        PHEP(5,NHEP+4)=RMASS(IQ1)
   30   CALL HWDTHR(PHEP(1,NHEP+1),PHEP(1,NHEP+2),
     &              PHEP(1,NHEP+3),PHEP(1,NHEP+4),HWDPWT)
        QQG=HWULDO(PHEP(1,NHEP+2),PHEP(1,NHEP+3))
        IF (QQG.LT.QGMIN) GOTO 30
        QBG=HWULDO(PHEP(1,NHEP+4),PHEP(1,NHEP+3))
        SUM=QQG+QBG
        IF (QBG.LT.QGMIN.OR.SUM.GT.QGMAX) GOTO 30
        QQLM=HWULDO(PHEP(1,NHEP+2),PHEP(1,LM))
        QQLP=HWULDO(PHEP(1,NHEP+2),PHEP(1,LP))
        QBLM=HWULDO(PHEP(1,NHEP+4),PHEP(1,LM))
        QBLP=HWULDO(PHEP(1,NHEP+4),PHEP(1,LP))
        DYN1=QQLM**2+QQLP**2+QBLM**2+QBLP**2
        DYN2=0.
        DYN3=DYN1-2.*(QQLM**2+QBLP**2)
        IF (MASS) THEN
           RUT=1./QQG+1./QBG
           DYN1=DYN1+8.*QM2*(1.-.25*Q2NOW*RUT
     &         +QQLM*QQLP/(Q2NOW*QBG)+QBLM*QBLP/(Q2NOW*QQG))
           DYN2=QM2*(Q2NOW-SUM*(2.+QM2*RUT)
     &         -4.*HWULDO(PHEP(1,NHEP+3),PHEP(1,LM))
     &            *HWULDO(PHEP(1,NHEP+3),PHEP(1,LP))/Q2NOW)
           DYN3=DYN3+QM2*2.*RUT*(QBG*(QBLP-QBLM)-QQG*(QQLP-QQLM))
        ENDIF
        EVWGT=CLF(1)*DYN1+CLF(2)*DYN2+ORDER*CLF(3)*DYN3
        IF (TPOL) THEN
C Include event plane azimuthal angle
           DYN4=.5*Q2NOW
           DYN5=DYN4
           DYN6=0.
           IF (MASS) THEN
              DYN4=DYN4-QM2*SUM/QBG
              DYN5=DYN5-QM2*SUM/QQG
              DYN6=QM2
           ENDIF
           EVWGT=EVWGT
     &     +(CLF(4)*COSS-CLF(6)*SINS)
     &      *(DYN4*(PHEP(1,NHEP+2)**2-PHEP(2,NHEP+2)**2)
     &       +DYN5*(PHEP(1,NHEP+4)**2-PHEP(2,NHEP+4)**2))
     &     +(CLF(4)*SINS+CLF(6)*COSS)*2.
     &      *(DYN4*PHEP(1,NHEP+2)*PHEP(2,NHEP+2)
     &       +DYN5*PHEP(1,NHEP+4)*PHEP(2,NHEP+4))
     &     +(CLF(5)*COSS-CLF(7)*SINS)*DYN6
     &      *(PHEP(1,NHEP+3)**2-PHEP(2,NHEP+3)**2)
     &     +(CLF(5)*SINS+CLF(7)*COSS)*DYN6*2.
     &      *PHEP(1,NHEP+3)*PHEP(2,NHEP+3)
        ENDIF
C Assign event weight
        EVWGT=EVWGT*FACTR/(QQG*QBG*CLF(1))
      ENDIF
  999 END
CDECK  ID>, HWHESG.
*CMZ :-        -18/10/00  13:46:47  by  Peter Richardson
*-- Author :    Kosuke Odagiri & Peter Richardson
C-----------------------------------------------------------------------
      SUBROUTINE HWHESG
C-----------------------------------------------------------------------
C     SUSY E+E- -> 2 GAUGINO PROCESSES
C-----------------------------------------------------------------------
      INCLUDE 'HERWIG62.INC'
      DOUBLE PRECISION HWRGEN,HWUAEM,HCS,RCS,MNU(4),MNU2(4),HWRUNI,
     &                 FACA,M1(4,4),S2W,XA(4),XB(4),XC(4),XD(4),MSNU,
     &                 MW,MZ,HWHSS1,U,T,QPE,SQPE,MSL,MSL2,MSR,MSR2,
     &                 SGN,SN2TH,S,SM,DM,PF,PCM,HWUPCM,XW,S22W,SQXW,
     &                 MSNU2,MCH(2),MCH2(2),DAB,M2(2,2),HWUMBW
      INTEGER I,IQ1,IQ2,SSNU,NTID(2),CHID(2),IG1,IG2,IHEP,SSCH,ISL,ISR,
     &        ISN,IDL,NTRY
      LOGICAL NEUT,CHAR
      SAVE HCS,M1,M2,NTID,ISL,ISR,ISN,IDL,CHID,NEUT,CHAR
      EXTERNAL HWRGEN,HWUAEM,HWRUNI,HWHSS1,HWUPCM,HWUMBW
      DOUBLE COMPLEX Z, Z0, Z1, C1, C2, C3,GZ, CLL, CLR, CRL, CRR
      PARAMETER (Z = (0.D0,1.D0), Z0 = (0.D0,0.D0), Z1 = (1.D0,0.D0))
      PARAMETER (SSNU=449,SSCH = 453)
      EQUIVALENCE (MZ, RMASS(200)), (MW, RMASS(198))
      EQUIVALENCE (XA(1), ZMIXSS(1,1)), (XA(2), ZMIXSS(2,1))
      EQUIVALENCE (XA(3), ZMIXSS(3,1)), (XA(4), ZMIXSS(4,1))
      EQUIVALENCE (XB(1), ZMIXSS(1,2)), (XB(2), ZMIXSS(2,2))
      EQUIVALENCE (XB(3), ZMIXSS(3,2)), (XB(4), ZMIXSS(4,2))
      EQUIVALENCE (XC(1), ZMIXSS(1,3)), (XC(2), ZMIXSS(2,3))
      EQUIVALENCE (XC(3), ZMIXSS(3,3)), (XC(4), ZMIXSS(4,3))
      EQUIVALENCE (XD(1), ZMIXSS(1,4)), (XD(2), ZMIXSS(2,4))
      EQUIVALENCE (XD(3), ZMIXSS(3,4)), (XD(4), ZMIXSS(4,4))
C--Start of the code
      IF(GENEV) THEN
        RCS = HCS*HWRGEN(0)
      ELSE
C--Decide which processes to generate
        IF(FSTWGT) THEN
          NEUT = .TRUE.
          CHAR = .TRUE.
C--neutralino pair production
          IF(IPROC.GE.710.AND.IPROC.LE.726) THEN
            CHAR = .FALSE.
            IF(IPROC.EQ.710) THEN
              NTID(1) = 0
              NTID(2) = 0
            ELSE
              NTID(1) = INT((IPROC-707)/4)
              NTID(2) = MOD((IPROC-711),4)+1
            ENDIF
C--chargino pair production
          ELSEIF(IPROC.GE.730.AND.IPROC.LE.734) THEN
            NEUT = .FALSE.
            IF(IPROC.EQ.730) THEN
              CHID(1) = 0
              CHID(2) = 0
            ELSE
              CHID(1) = INT((IPROC-729)/2)
              CHID(2) = MOD((IPROC-731),2)+1
            ENDIF
          ELSEIF(IPROC.NE.700) THEN
            CALL HWWARN('HWHESG',500,*999)
          ENDIF
C--check the particles in the beam
          IF(ABS(IDHEP(1)).EQ.11) THEN
C--electron beams
            ISL = 425
            ISR = 437
            ISN = 426
          ELSEIF(ABS(IDHEP(1)).EQ.13) THEN
C--muon beams
            ISL = 427
            ISR = 439
            ISN = 428
          ELSE
            CALL HWWARN('HWHESG',501,*999)
          ENDIF
          IDL=ABS(IDHEP(1))
        ENDIF
        DO I=1,4
          MNU(I) = RMASS(SSNU+I)
          MNU2(I) = MNU(I)**2
        ENDDO
        DO IG1 = 1,2
          MCH(IG1)  = RMASS(IG1+SSCH)
          MCH2(IG1) = MCH(IG1)**2
        ENDDO
        COSTH = HWRUNI(1,-ONE,ONE)
        SN2TH = 0.25D0-0.25D0*COSTH**2
        XW    = TWO * SWEIN
        SQXW  = SQRT(XW)
        S22W  = XW * (TWO - XW)
        S2W   = SQRT(S22W)
        S     = PHEP(5,3)**2
        EMSCA = PHEP(5,3)
        FACA  = HWUAEM(S)**2
        GZ    = S-MZ**2+Z*S/MZ*GAMZ
        MSL   = RMASS(ISL)
        MSR   = RMASS(ISR)
        MSL2  = MSL**2
        MSR2  = MSR**2
        MSNU  = RMASS(ISN)
        MSNU2 = MSNU**2
C--neutralino pair production
        IF(.NOT.NEUT) THEN
          DO IQ1=1,4
            DO IQ2=1,4
              M1(IQ1,IQ2) = ZERO
            ENDDO
          ENDDO
          GOTO 100
        ENDIF
        DO IQ1=1,4
          DO IQ2=1,4
            SM   = MNU(IQ1) + MNU(IQ2)
            QPE  = S - SM**2
            IF(QPE.GE.ZERO.AND.
     &           (NTID(1).EQ.0.OR.(IQ1.EQ.NTID(1).AND.IQ2.EQ.NTID(2))
     &           .OR.(IQ1.EQ.NTID(2).AND.IQ2.EQ.NTID(1)))) THEN
              DM   = MNU(IQ1) - MNU(IQ2)
              SQPE = SQRT(QPE*(S-DM**2))
              PF   = SQPE/S
              T    = HALF*(SQPE*COSTH - S + MNU2(IQ1) + MNU2(IQ2))
              U    = - T - S + MNU2(IQ1) + MNU2(IQ2)
              C1   = (XD(IQ1)*XD(IQ2)-XC(IQ1)*XC(IQ2))/S2W/GZ
              C2   = - C1
              SGN  = ZSGNSS(IQ1)*ZSGNSS(IQ2)
              CLL = LFCH(IDL)*C1+SLFCH(IDL,IQ1)*SLFCH(IDL,IQ2)/(U-MSL2)
              CLR = LFCH(IDL)*C2-SLFCH(IDL,IQ1)*SLFCH(IDL,IQ2)/(T-MSL2)
              CRL = RFCH(IDL)*C1-SRFCH(IDL,IQ1)*SRFCH(IDL,IQ2)/(T-MSR2)
              CRR = RFCH(IDL)*C2+SRFCH(IDL,IQ1)*SRFCH(IDL,IQ2)/(U-MSR2)
              M1(IQ1,IQ2) = FACA*PF*GEV2NB*PIFAC/S*HALF*
     &          HWHSS1(S,T,U,MNU(IQ1),MNU(IQ2),SGN,CLL,CLR,CRL,CRR)
            ELSE
              M1(IQ1,IQ2) = ZERO
            ENDIF
          ENDDO
        ENDDO
C--chargino pair production
 100    IF(.NOT.CHAR) THEN
          DO IG1=1,2
            DO IG2=1,2
              M2(IG1,IG2) = ZERO
            ENDDO
          ENDDO
          GOTO 200
        ENDIF
        DO IG1 = 1,2
          DO IG2 = 1,2
            SM  = MCH(IG1) + MCH(IG2)
            QPE = S - SM**2
            IF (QPE.GE.ZERO.AND.
     &           (CHID(1).EQ.0.OR.(CHID(1).EQ.IG1.AND.CHID(2).EQ.IG2)
     &            .OR.(CHID(1).EQ.IG2.AND.CHID(2).EQ.IG1))) THEN
              DM   = MCH(IG1) - MCH(IG2)
              SQPE = SQRT(QPE*(S-DM**2))
              PF   = SQPE/S
              T    = HALF*(SQPE*COSTH - S + MCH2(IG1) + MCH2(IG2))
              U    = - T - S + MCH2(IG1) + MCH2(IG2)
              DAB  = ABS(FLOAT(IG1+IG2-3))
              C1   = (-WMXVSS(IG1,2)*WMXVSS(IG2,2)+DAB*S22W/XW)/S2W/GZ
              C2   = (-WMXUSS(IG1,2)*WMXUSS(IG2,2)+DAB*S22W/XW)/S2W/GZ
              SGN  = WSGNSS(IG1)*WSGNSS(IG2)
              C3   = -DAB*QFCH(IDL)/S
              CLL  = C3- LFCH(IDL)*C1
     &               +WMXVSS(IG1,1)*WMXVSS(IG2,1)/((U-MSNU2)*XW)
              CLR  = C3- LFCH(IDL)*C2
              CRL  = C3- RFCH(IDL)*C1
              CRR  = C3- RFCH(IDL)*C2
              M2(IG1,IG2)=FACA*PF*GEV2NB*PIFAC/S*
     &             HWHSS1(S,T,U,MCH(IG1),MCH(IG2),SGN,CLL,CLR,CRL,CRR)
            ELSE
              M2(IG1,IG2) = ZERO
            ENDIF
          ENDDO
        ENDDO
      ENDIF
C--Add up the weights now
 200  HCS = ZERO
      IF(.NOT.NEUT) GOTO 250
      DO IQ1=1,4
        IG1 = SSNU+IQ1
        DO IQ2=1,4
          IG2 = SSNU+IQ2
          HCS = HCS+M1(IQ1,IQ2)
          IF(GENEV.AND.HCS.GT.RCS) GOTO 900
        ENDDO
      ENDDO
 250  IF(.NOT.CHAR) GOTO 900
      DO IQ1 = 1,2
        IG1 = SSCH+IQ1
        DO IQ2 = 1,2
          IG2 = SSCH+IQ2+2
          HCS = HCS + M2(IQ1,IQ2)
          IF (GENEV.AND.HCS.GT.RCS) GOTO 900
        ENDDO
      ENDDO
 900  IF(GENEV) THEN
C--change sign of COSTH if antiparticle first
        IF(IDHEP(1).LT.IDHEP(2)) COSTH = -COSTH
C-Set up the particle types
        IDHW(NHEP+1)     = 15
        IDHEP(NHEP+1)    = 0
        ISTHEP(NHEP+1)   = 110
        IDHW(NHEP+2)     = IG1
        IDHW(NHEP+3)     = IG2
        IDHEP(NHEP+2)    = IDPDG(IG1)
        IDHEP(NHEP+3)    = IDPDG(IG2)
C--select the particle masses and momenta
        NTRY = 0
 910    NTRY = NTRY+1
        PHEP(5,NHEP+2)   = HWUMBW(IG1)
        PHEP(5,NHEP+3)   = HWUMBW(IG2)
        CALL HWVEQU(5,PHEP(1,3),PHEP(1,NHEP+1))
        PCM   = HWUPCM(PHEP(5,NHEP+1),PHEP(5,NHEP+2),PHEP(5,NHEP+3))
        IF(PCM.LT.ZERO.AND.NTRY.LE.NETRY) THEN
          GOTO 910
        ELSEIF(PCM.LT.ZERO) THEN
          CALL HWWARN('HWHESG',100,*999)
        ENDIF
C--Set up the colours etc
        ISTHEP(NHEP+2)   = 113
        ISTHEP(NHEP+3)   = 114
        JMOHEP(1,NHEP+1) = 1
        IF (JDAHEP(1,1).NE.0) JMOHEP(1,NHEP+1)=JDAHEP(1,1)
        JMOHEP(2,NHEP+1) = 2
        IF (JDAHEP(1,2).NE.0) JMOHEP(1,NHEP+1)=JDAHEP(1,2)
        JMOHEP(1,NHEP+2) = NHEP+1
        JMOHEP(2,NHEP+2) = NHEP+2
        JMOHEP(1,NHEP+3) = NHEP+1
        JMOHEP(2,NHEP+3) = NHEP+3
        JDAHEP(1,NHEP+1) = NHEP+2
        JDAHEP(2,NHEP+1) = NHEP+3
        JDAHEP(1,NHEP+2) = 0
        JDAHEP(2,NHEP+2) = NHEP+3
        JDAHEP(1,NHEP+3) = 0
        JDAHEP(2,NHEP+3) = NHEP+2
C--Set up the momenta
        IHEP  = NHEP+2
        PHEP(4,IHEP) = SQRT(PCM**2+PHEP(5,IHEP)**2)
        PHEP(3,IHEP) = PCM*COSTH
        PHEP(1,IHEP) = SQRT((PCM+PHEP(3,IHEP))*(PCM-PHEP(3,IHEP)))
        PHEP(2,IHEP) = ZERO
        CALL HWRAZM(PHEP(1,IHEP),PHEP(1,IHEP),PHEP(2,IHEP))
        CALL HWULOB(PHEP(1,NHEP+1),PHEP(1,IHEP),PHEP(1,IHEP))
        CALL HWVDIF(4,PHEP(1,NHEP+1),PHEP(1,IHEP),PHEP(1,IHEP+1))
        NHEP  = NHEP+3
      ELSE
        EVWGT = HCS
      ENDIF
 999  END
CDECK  ID>, HWHESL.
*CMZ :-        -17/10/00  17:43:25  by  Peter Richardson
*-- Author :    Kosuke Odagiri & Peter Richardson
C-----------------------------------------------------------------------
      SUBROUTINE HWHESL
C-----------------------------------------------------------------------
C     SUSY E+E- -> 2 SLEPTON PROCESSES
C-----------------------------------------------------------------------
      INCLUDE 'HERWIG62.INC'
      DOUBLE PRECISION HWRGEN,HWUAEM,EPS,HCS,RCS,S,PF,QPE,HWUPCM,PCM,
     & FACTR,SN2TH,MZ,MW,ME2(2,2,6),EMSC2,HWUMBW,HWRUNI,T,SQPE
      INTEGER ID1, ID2, IL, IL1, IL2, I, J, IG,IG1,IHEP,RLID(2),NTRY,
     & IDL,ILP,IDLR(2),IDSLP(2)
      INTEGER SSNU, SSCH
      PARAMETER (SSNU = 449, SSCH = 453)
      EXTERNAL HWRGEN, HWUAEM,HWUMBW,HWUPCM,HWRUNI
      SAVE HCS,ME2,RLID,IDLR,IDSLP
      PARAMETER (EPS = 1.D-9)
      DOUBLE COMPLEX Z, GZ, A, BL, BR, CL, CR, D, E
      DOUBLE PRECISION F,FACT0
      PARAMETER (Z = (0.D0,1.D0))
      EQUIVALENCE (MZ, RMASS(200)), (MW, RMASS(198))
C
      S     = PHEP(5,3)**2
      EMSC2 = S
      EMSCA = SQRT(EMSC2)
      IF(FSTWGT) THEN
        IL = MOD((IPROC-740),5)
        IF(IPROC.EQ.700.OR.IPROC.EQ.740) THEN
          IDLR(1) = 0
          IDLR(2) = 0
          IDSLP(1) = 1
          IDSLP(2) = 6
        ELSE
          IF(IL.EQ.0) THEN
            IDLR(1) = 1
            IDLR(2) = 1
            IDSLP(1) = 2*(IPROC-740)/5
          ELSEIF(IL.EQ.1) THEN
            IDLR(1) = 0
            IDLR(2) = 0
            IDSLP(1) = 2*(IPROC-741)/5+1
          ELSEIF(IL.EQ.2) THEN
            IDLR(1) = 1
            IDLR(2) = 1
            IDSLP(1) = 2*(IPROC-742)/5+1
          ELSEIF(IL.EQ.3) THEN
            IDLR(1) = 1
            IDLR(2) = 2
            IDSLP(1) = 2*(IPROC-743)/5+1
          ELSEIF(IL.EQ.4) THEN
            IDLR(1) = 2
            IDLR(2) = 2
            IDSLP(1) = 2*(IPROC-744)/5+1
          ENDIF
          IDSLP(2) = IDSLP(1)
        ENDIF
      ENDIF
      IF (GENEV) THEN
        RCS = HCS*HWRGEN(0)
      ELSE
        IDL   = ABS(IDHEP(1))
        ILP   = IDL-10
        COSTH = HWRUNI(1,-ONE,ONE)
        SN2TH = 0.25D0 - 0.25D0*COSTH**2
        FACT0 = GEV2NB*PIFAC*HWUAEM(EMSC2)**2/S
        FACTR = FACT0*SN2TH
        GZ    = (S-MZ**2+Z*S*GAMZ/MZ)/S
c             ~  ~*
c    e+ e- -> l  l
c
        DO IL=1,6
          DO I=1,2
            DO J=1,2
              ME2(I,J,IL) = ZERO
            ENDDO	
          ENDDO
        ENDDO
        DO IL = IDSLP(1),IDSLP(2)
          DO I = 1,2
            DO J = 1,2
              IF ((I.EQ.2.OR.J.EQ.2).AND.(((IL/2)*2).EQ.IL).OR.
     &            (IDLR(1).NE.0.AND.(IDLR(1).NE.I.OR.IDLR(2).NE.J)
     &              .AND.(IDLR(1).NE.J.OR.IDLR(2).NE.I))) THEN
                QPE = -1.
              ELSE
                ID1 = 412 + I*12 + IL
                ID2 = 412 + J*12 + IL
                IL1 = IL + 10
                QPE = S-(RMASS(ID1)+RMASS(ID2))**2
              ENDIF
              IF (QPE.GT.ZERO) THEN
                SQPE = SQRT(QPE*(S-(RMASS(ID1)-RMASS(ID2))**2))
                PF = SQPE/S
                IF ((IL.NE.ILP).OR.(I.EQ.J)) THEN
                  A  = QFCH(IL1)*QFCH(IDL)
                  BL = LFCH(IL1)/GZ
                  BR = RFCH(IL1)/GZ
                  CL = LMIXSS(IL,1,I)*LMIXSS(IL,1,J)
                  CR = LMIXSS(IL,2,I)*LMIXSS(IL,2,J)
                  D  = (A+BL*LFCH(IDL))*CL+(A+BR*LFCH(11))*CR
                  E  = (A+BL*RFCH(IDL))*CL+(A+BR*RFCH(11))*CR
                  IF (IL.EQ.ILP+1.OR.IL.EQ.ILP) THEN
                    F = ZERO
                    T = HALF*(SQPE*COSTH-S+RMASS(ID1)**2+RMASS(ID2)**2)
                    IF (IL.EQ.ILP) THEN
                      IF (I.EQ.J) THEN
                        IF (I.EQ.1) THEN
                          DO IG = 1,4
                            IG1 = SSNU+IG
                            F   = F + SLFCH(IL1,IG)**2/(T-RMASS(IG1)**2)
                          ENDDO
                          D = D + F*S
                        ELSE
                          DO IG=1,4
                            IG1 = SSNU+IG
                            F   = F +SRFCH(IL1,IG)**2/(T-RMASS(IG1)**2)
                          ENDDO
                          E = E + F*S
                        ENDIF
                      ELSE
                      ENDIF
                    ELSE
                      DO IG = 1,2
                        IG1 = SSCH+IG
                        F   = F + WMXVSS(IG,1)**2/(T-RMASS(IG1)**2)
                      ENDDO
                      D = D + F*S/(TWO*SWEIN)
                    ENDIF
                  ENDIF
                  ME2(I,J,IL)=FACTR*PF**3*DREAL(DCONJG(D)*D+DCONJG(E)*E)
                ELSE
                  F = ZERO
                  T = HALF*(SQPE*COSTH-S+RMASS(ID1)**2+RMASS(ID2)**2)
                  DO IG = 1,4
                    IG1 = SSNU+IG
                    F   = F + SLFCH(IL1,IG)*SRFCH(IL1,IG)*
     &                    ZSGNSS(IG)*RMASS(IG1)/(T-RMASS(IG1)**2)
                  ENDDO
                  ME2(I,J,IL)=FACT0*PF*F**2*S
                ENDIF
              ELSE
                ME2(I,J,IL)=ZERO
              ENDIF
            ENDDO
          ENDDO
        ENDDO
      ENDIF
      HCS = ZERO
C
      DO IL = 1,6
         DO I = 1,2
            DO J = 1,2
               IL1 = IL+I*12+412
               IL2 = IL+J*12+418
               HCS = HCS + ME2(I,J,IL)
               IF (GENEV.AND.HCS.GT.RCS) GOTO 100
            ENDDO
         ENDDO
       ENDDO
C---GENERATE EVENT
 100  IF(GENEV) THEN
C--change sign of COSTH if antiparticle first
      IF(IDHEP(1).LT.IDHEP(2)) COSTH = -COSTH
        IDHW(NHEP+1)     = 15
        IDHEP(NHEP+1)    = 0
        ISTHEP(NHEP+1)   = 110
        IDHW(NHEP+2)     = IL1
        IDHW(NHEP+3)     = IL2
        IDHEP(NHEP+2)    = IDPDG(IL1)
        IDHEP(NHEP+3)    = IDPDG(IL2)
C--select the particle masses and momenta
        NTRY = 0
 110    NTRY = NTRY+1
        PHEP(5,NHEP+2)   = HWUMBW(IL1)
        PHEP(5,NHEP+3)   = HWUMBW(IL2)
        CALL HWVEQU(5,PHEP(1,3),PHEP(1,NHEP+1))
        PCM   = HWUPCM(PHEP(5,NHEP+1),PHEP(5,NHEP+2),PHEP(5,NHEP+3))
        IF(PCM.LT.ZERO.AND.NTRY.LE.NETRY) THEN
          GOTO 110
        ELSEIF(PCM.LT.ZERO) THEN
          CALL HWWARN('HWHESL',100,*999)
        ENDIF
C--Set up the colours etc
        ISTHEP(NHEP+2)   = 113
        ISTHEP(NHEP+3)   = 114
        JMOHEP(1,NHEP+1) = 1
        IF (JDAHEP(1,1).NE.0) JMOHEP(1,NHEP+1)=JDAHEP(1,1)
        JMOHEP(2,NHEP+1) = 2
        IF (JDAHEP(1,2).NE.0) JMOHEP(1,NHEP+1)=JDAHEP(1,2)
        JMOHEP(1,NHEP+2) = NHEP+1
        JMOHEP(2,NHEP+2) = NHEP+2
        JMOHEP(1,NHEP+3) = NHEP+1
        JMOHEP(2,NHEP+3) = NHEP+3
        JDAHEP(1,NHEP+1) = NHEP+2
        JDAHEP(2,NHEP+1) = NHEP+3
        JDAHEP(1,NHEP+2) = 0
        JDAHEP(2,NHEP+2) = NHEP+2
        JDAHEP(1,NHEP+3) = 0
        JDAHEP(2,NHEP+3) = NHEP+3
C--Set up the momenta
        IHEP  = NHEP+2
        IHEP  = NHEP+2
        PHEP(4,IHEP) = SQRT(PCM**2+PHEP(5,IHEP)**2)
        PHEP(3,IHEP) = PCM*COSTH
        PHEP(1,IHEP) = SQRT((PCM+PHEP(3,IHEP))*(PCM-PHEP(3,IHEP)))
        PHEP(2,IHEP) = ZERO
        CALL HWRAZM(PHEP(1,IHEP),PHEP(1,IHEP),PHEP(2,IHEP))
        CALL HWULOB(PHEP(1,NHEP+1),PHEP(1,IHEP),PHEP(1,IHEP))
        CALL HWVDIF(4,PHEP(1,NHEP+1),PHEP(1,IHEP),PHEP(1,IHEP+1))
        NHEP  = NHEP+3
      ELSE
        EVWGT = HCS
      ENDIF
 999  END
CDECK  ID>, HWHESP.
*CMZ :-        -18/10/00  13:46:47  by  Peter Richardson
*-- Author :    Kosuke Odagiri & Peter Richardson
C-----------------------------------------------------------------------
      SUBROUTINE HWHESP
C-----------------------------------------------------------------------
C     SUSY E+E- -> 2 SPARTICLE PROCESSES
C-----------------------------------------------------------------------
      INCLUDE 'HERWIG62.INC'
      DOUBLE PRECISION SAVWT(3),RANWT,HWRGEN
      EXTERNAL HWRGEN
      SAVE SAVWT
      IF(IPROC.EQ.700) THEN
        IF(GENEV) THEN
          RANWT    = SAVWT(3)*HWRGEN(0)
          IF(RANWT.LT.SAVWT(1)) THEN
            CALL HWHESG
          ELSEIF(RANWT.LT.SAVWT(2)) THEN
            CALL HWHESL
          ELSEIF(RANWT.LT.SAVWT(3)) THEN
            CALL HWHESQ
          ENDIF
        ELSE
          CALL HWHESG
          SAVWT(1) = EVWGT
          CALL HWHESL
          SAVWT(2) = SAVWT(1)+EVWGT
          CALL HWHESQ
          SAVWT(3) = SAVWT(2)+EVWGT
          EVWGT    = SAVWT(3)
        ENDIF
      ELSEIF(IPROC.LT.740) THEN
        CALL HWHESG
      ELSEIF(IPROC.LT.760) THEN
        CALL HWHESL
      ELSEIF(IPROC.LT.790) THEN
        CALL HWHESQ
      ELSE
C---UNRECOGNIZED PROCESS
        CALL HWWARN('HWHESP',500,*999)
      ENDIF
 999  END
CDECK  ID>, HWHESQ.
*CMZ :-        -16/10/00  15:34:113  by  Peter Richardson
*-- Author :    Kosuke Odagiri & Peter Richardson
C-----------------------------------------------------------------------
      SUBROUTINE HWHESQ
C-----------------------------------------------------------------------
C     SUSY E+E- -> 2 SQUARK PROCESSES
C-----------------------------------------------------------------------
      INCLUDE 'HERWIG62.INC'
      DOUBLE PRECISION HWRGEN,HWUAEM,EPS,HCS,RCS,S,PF,QPE,HWUPCM,PCM,
     & FACTR,SN2TH,MZ,MW,ME2(2,2,6),EMSC2,HWUMBW,HWRUNI,SQPE
      INTEGER ID1,ID2,IQ,IQ1,IQ2,I,J,IHEP,RLID(2),IDL,IDLR(2),IDSQU(2),
     &        NTRY
      EXTERNAL HWRGEN,HWUAEM,HWUMBW,HWUPCM,HWRUNI
      SAVE HCS,ME2,RLID,IDLR,IDSQU
      PARAMETER (EPS = 1.D-9)
      DOUBLE COMPLEX Z, GZ, A, BL, BR, CL, CR, D, E
      PARAMETER (Z = (0.D0,1.D0))
      EQUIVALENCE (MZ, RMASS(200)), (MW, RMASS(198))
C
      S     = PHEP(5,3)**2
      EMSC2 = S
      EMSCA = SQRT(EMSC2)
      IF(FSTWGT) THEN
        IF(IPROC.EQ.700.OR.IPROC.EQ.760) THEN
           IDLR(1) = 0
           IDLR(2) = 0
	   IDSQU(1) = 1
           IDSQU(2) = 6
        ELSEIF(IPROC.GT.760.AND.IPROC.LE.784) THEN
           IQ = MOD((IPROC-761),4)
           IF(IQ.EQ.0) THEN
              IDLR(1) = 0
              IDLR(2) = 0
           ELSEIF(IQ.EQ.1) THEN
              IDLR(1) = 1
              IDLR(2) = 1
           ELSEIF(IQ.EQ.2) THEN
              IDLR(1) = 1
              IDLR(2) = 2
           ELSEIF(IQ.EQ.3) THEN
              IDLR(1) = 2
              IDLR(2) = 2
           ENDIF
           IDSQU(1) = (IPROC-761)/4+1
           IDSQU(2) = IDSQU(1)
        ELSE
           CALL HWWARN('HWHESQ',500,*999)
        ENDIF
      ENDIF
      IF (GENEV) THEN
        RCS   = HCS*HWRGEN(0)
      ELSE
        COSTH = HWRUNI(1,-ONE,ONE)
        SN2TH = 0.25D0 - 0.25D0*COSTH**2
        FACTR = CAFAC*GEV2NB*PIFAC*HWUAEM(EMSC2)**2*SN2TH/S
        GZ    = (S-MZ**2+Z*S*GAMZ/MZ)/S
        IDL   = ABS(IDHEP(1))
c             ~  ~*
c    e+ e- -> q  q
c
        DO IQ=1,6
          DO I=1,2
            DO J=1,2
              ME2(I,J,IQ) = ZERO
            ENDDO	
          ENDDO
        ENDDO
        DO IQ = IDSQU(1),IDSQU(2)
          DO I = 1,2
            DO J = 1,2
              IF ((I.NE.J).AND.(IQ.LT.5).OR.
     &            (IDLR(1).NE.0.AND.(IDLR(1).NE.I.OR.IDLR(2).NE.J)
     &              .AND.(IDLR(1).NE.J.OR.IDLR(2).NE.I))) THEN
                QPE = -1.
              ELSE
                ID1 = 388 + I*12 + IQ
                ID2 = 388 + J*12 + IQ
                QPE = S-(RMASS(ID1)+RMASS(ID2))**2
              ENDIF
              IF (QPE.GT.ZERO) THEN
                SQPE = SQRT(QPE*(S-(RMASS(ID1)-RMASS(ID2))**2))
                PF = SQPE/S
                A  = QFCH(IQ)*QFCH(IDL)
                BL = LFCH(IQ)/GZ
                BR = RFCH(IQ)/GZ
                CL = QMIXSS(IQ,1,I)*QMIXSS(IQ,1,J)
                CR = QMIXSS(IQ,2,I)*QMIXSS(IQ,2,J)
                D  = (A+BL*LFCH(IDL))*CL+(A+BR*LFCH(IDL))*CR
                E  = (A+BL*RFCH(IDL))*CL+(A+BR*RFCH(IDL))*CR
                ME2(I,J,IQ)=FACTR*PF**3*DREAL(DCONJG(D)*D+DCONJG(E)*E)
              ELSE
                ME2(I,J,IQ)=ZERO
              ENDIF
            ENDDO
          ENDDO
        ENDDO
      ENDIF
      HCS = ZERO
C
      DO IQ = 1,6
        DO I = 1,2
          DO J = 1,2
            IQ1 = IQ+I*12+388
            IQ2 = IQ+J*12+394
            HCS = HCS + ME2(I,J,IQ)
            IF (GENEV.AND.HCS.GT.RCS) GOTO 100
          ENDDO
        ENDDO
      ENDDO
C---GENERATE EVENT
 100  IF(GENEV) THEN
        IDHW(NHEP+1)     = 15
        IDHEP(NHEP+1)    = 0
        ISTHEP(NHEP+1)   = 110
        IDHW(NHEP+2)     = IQ1
        IDHW(NHEP+3)     = IQ2
        IDHEP(NHEP+2)    = IDPDG(IQ1)
        IDHEP(NHEP+3)    = IDPDG(IQ2)
C--Select the particle masses and momenta
 110    NTRY = NTRY+1
        PHEP(5,NHEP+2)   = HWUMBW(IQ1)
        PHEP(5,NHEP+3)   = HWUMBW(IQ2)
        CALL HWVEQU(5,PHEP(1,3),PHEP(1,NHEP+1))
        PCM   = HWUPCM(PHEP(5,NHEP+1),PHEP(5,NHEP+2),PHEP(5,NHEP+3))
        IF(PCM.LT.ZERO.AND.NTRY.LE.NETRY) THEN
          GOTO 110
        ELSEIF(PCM.LT.ZERO) THEN
          CALL HWWARN('HWHESQ',100,*999)
        ENDIF
C--Set up the colours etc
        ISTHEP(NHEP+2)   = 113
        ISTHEP(NHEP+3)   = 114
        JMOHEP(1,NHEP+1) = 1
        IF (JDAHEP(1,1).NE.0) JMOHEP(1,NHEP+1)=JDAHEP(1,1)
        JMOHEP(2,NHEP+1) = 2
        IF (JDAHEP(1,2).NE.0) JMOHEP(1,NHEP+1)=JDAHEP(1,2)
        JMOHEP(1,NHEP+2) = NHEP+1
        JMOHEP(2,NHEP+2) = NHEP+3
        JMOHEP(1,NHEP+3) = NHEP+1
        JMOHEP(2,NHEP+3) = NHEP+2
        JDAHEP(1,NHEP+1) = NHEP+2
        JDAHEP(2,NHEP+1) = NHEP+3
        JDAHEP(1,NHEP+2) = 0
        JDAHEP(2,NHEP+2) = NHEP+3
        JDAHEP(1,NHEP+3) = 0
        JDAHEP(2,NHEP+3) = NHEP+2
C--Set up the momenta
        IHEP  = NHEP+2
        PHEP(4,IHEP) = SQRT(PCM**2+PHEP(5,IHEP)**2)
        PHEP(3,IHEP) = PCM*COSTH
        PHEP(1,IHEP) = SQRT((PCM+PHEP(3,IHEP))*(PCM-PHEP(3,IHEP)))
        CALL HWRAZM(PHEP(1,IHEP),PHEP(1,IHEP),PHEP(2,IHEP))
        CALL HWULOB(PHEP(1,NHEP+1),PHEP(1,IHEP),PHEP(1,IHEP))
        CALL HWVDIF(4,PHEP(1,NHEP+1),PHEP(1,IHEP),PHEP(1,IHEP+1))
        NHEP  = NHEP+3
      ELSE
        EVWGT = HCS
      ENDIF
 999  END
CDECK  ID>, HWHEW0.
*CMZ :-        -26/04/91  11.11.55  by  Bryan Webber
*-- Author :    Zoltan Kunszt, modified by Bryan Webber & Mike Seymour
C-----------------------------------------------------------------------
      SUBROUTINE HWHEW0(IP,ETOT,XM,PR,WEIGHT,CR)
C-----------------------------------------------------------------------
      INCLUDE 'HERWIG62.INC'
      DOUBLE PRECISION HWRGEN,ETOT,XM(2),PR(5,2),WEIGHT,CR,XM1,XM2,S,
     & D1,PABS,D,CX,C,E,F,SC,G
      INTEGER IP,I
      EXTERNAL HWRGEN
      WEIGHT=ZERO
      XM1=XM(1)**2
      XM2=XM(2)**2
      S=ETOT*ETOT
      D1=S-XM1-XM2
      PABS=D1*D1-4.*XM1*XM2
      IF (PABS.LE.ZERO) RETURN
      PABS=SQRT(PABS)
      D=D1/PABS
      IF(IP.EQ.2)GOTO3
      CX=CR
      C=D-(D+CX)*((D-CR)/(D+CX))**HWRGEN(2)
      GOTO 4
3     E=((D+ONE)/(D-ONE))*(TWO*HWRGEN(3)-ONE)
      C=D*((E-ONE)/(E+ONE))
4     F=2D0*PIFAC*HWRGEN(4)
      SC=SQRT(ONE-C*C)
      PR(4,1)=(S+XM1-XM2)/(TWO*ETOT)
      PR(5,1)=PR(4,1)*PR(4,1)-XM1
      IF (PR(5,1).LE.ZERO) RETURN
      PR(5,1)=SQRT(PR(5,1))
      PR(4,2)=ETOT-PR(4,1)
      PR(3,1)=PR(5,1)*C
      PR(5,2)=PR(5,1)
      PR(2,1)=PR(5,1)*SC*COS(F)
      PR(1,1)=PR(5,1)*SC*SIN(F)
      DO 7 I=1,3
7     PR(I,2)=-PR(I,1)
      G=0.
      IF(IP.EQ.1)G=(D-C)*LOG((D+CX)/(D-CR))
      IF(IP.EQ.2)G=(D*D-C*C)/D*LOG((D+ONE)/(D-ONE))
      WEIGHT=PIFAC*G*PR(5,1)/ETOT*HALF
      RETURN
      END
CDECK  ID>, HWHEW1.
*CMZ :-        -26/04/91  11.11.55  by  Bryan Webber
*-- Author :    Zoltan Kunszt, modified by Bryan Webber
C-----------------------------------------------------------------------
      SUBROUTINE HWHEW1(NPART)
C-----------------------------------------------------------------------
      IMPLICIT NONE
      DOUBLE PRECISION P(4,7),XMASS,PLAB,PRW,PCM
      INTEGER NPART,I,J,K
      COMMON/HWHEWP/ XMASS(10),PLAB(5,10),PRW(5,2),PCM(5,10)
      DO 10 I=1,NPART
      P(1,I)=PLAB(3,I)
      P(2,I)=PLAB(1,I)
      P(3,I)=PLAB(2,I)
      P(4,I)=PLAB(4,I)
  10  CONTINUE
      DO 20 J=1,4
      DO 30 K=1,(NPART-2)
  30  PCM(J,K)=P(J,K+2)
      PCM(J,NPART-1)=-P(J,1)
      PCM(J,NPART)=-P(J,2)
  20  CONTINUE
      END
CDECK  ID>, HWHEW2.
*CMZ :-        -26/04/91  13.22.25  by  Federico Carminati
*-- Author :    Zoltan Kunszt, modified by Bryan Webber
C-----------------------------------------------------------------------
      SUBROUTINE HWHEW2(NPART,PPCM,H,CH,D)
C-----------------------------------------------------------------------
C PCM SHOULD BE DEFINED SUCH THAT ALL 4-MOMENTA ARE OUTGOING.
C CONVENTION FOR PCM AND P IS THAT DIRECTION 1 =BEAM, COMPONENT
C 4 = ENERGY AND COMPONENT 2 AND 3 ARE TRANSVERSE COMPONENTS.
C THUS INCOMING MOMENTA SHOULD CORRESPOND TO OUTGOING MOMENTA
C OF NEGATIVE ENERGY.
C PCM IS FILLED BY PHASE SPACE MONTE CARLO.
C I1-I7 HERE REFER TO HOW PCM INDEXING IS MAPPED TO OUR STANDARD
C 1-6=GLUON,GLUON,Q,QBAR,QP,QPBAR ORDERING `
C-----------------------------------------------------------------------
      IMPLICIT NONE
      DOUBLE COMPLEX PT5,ZT,Z1,ZI,ZP,ZQ,ZD,ZPS,ZQS,ZDPM,ZDMP,H(7,7),
     & CH(7,7),D(7,7)
      DOUBLE PRECISION ZERO,ONE,PPCM(5,7),P(5,7),WRN(7),EPS,Q1,Q2,QP,QM,
     & P1,P2,PP,PM,DMP,DPM,PT,QT,PTI,QTI,HALF
      INTEGER J,L,IJ,II,JJ,I,NPART,IP1,IPP1
      PARAMETER (ZERO=0.D0,ONE=1.D0,HALF=0.5D0)
      EPS=0.0000001
      ZI=DCMPLX(ZERO,ONE)
      Z1=DCMPLX(ONE,ZERO)
C FOLLOWING DO LOOP IS TO CONVERT TO OUR STANDARD INDEXING
      DO 1 L=1,NPART
      DO 1 IJ=1,4
1     P(IJ,L)=PPCM(IJ,L)
      DO 2 II=1,7
      WRN(II)=ONE
      IF(P(4,II).LT.ZERO) WRN(II)=-ONE
      DO 2 JJ=1,4
      P(JJ,II)=WRN(II)*P(JJ,II)
    2 CONTINUE
C THE ABOVE CHECKS FOR MOMENTA WITH NEGATIVE ENERGY,INNER PRODUCTS
C ARE EXPRESSED DIFFERENTLY FOR DIFFERENT CASES
      DO 11 I=1,NPART-1
      IP1=I+1
      DO 11 J=IP1,NPART
      Q1=P(4,I)+P(1,I)
      QP=0.0
      IF(Q1.GT.EPS)QP=SQRT(Q1)
      Q2=P(4,I)-P(1,I)
      QM=0.0
      IF(Q2.GT.EPS)QM=SQRT(Q2)
      P1=P(4,J)+P(1,J)
      PP=0.
      IF(P1.GT.EPS)PP=SQRT(P1)
      P2=P(4,J)-P(1,J)
      PM=0.
      IF(P2.GT.EPS)PM=SQRT(P2)
      DMP=PM*QP
      ZDMP=DCMPLX(DMP,ZERO)
      DPM=PP*QM
      ZDPM=DCMPLX(DPM,ZERO)
C NOTE THAT IN OUR INNER PRODUCT NOTATION WE ARE COMPUTING <P,Q>
      PT=SQRT(P(2,J)**2+P(3,J)**2)
      QT=SQRT(P(2,I)**2+P(3,I)**2)
      IF(PT.GT.EPS) GOTO 99
      ZP=Z1
      GOTO 98
   99 PTI=ONE/PT
      ZP=DCMPLX(PTI*P(2,J),PTI*P(3,J))
   98 ZPS=DCONJG(ZP)
      IF(QT.GT.EPS) GOTO 89
      ZQ=Z1
      GOTO 88
   89 QTI=ONE/QT
      ZQ=DCMPLX(QTI*P(2,I),QTI*P(3,I))
   88 ZQS=DCONJG(ZQ)
      ZT=Z1
      IF(WRN(I).LT.ZERO) ZT=ZT*ZI
      IF(WRN(J).LT.ZERO) ZT=ZT*ZI
      H(J,I)=(ZDMP*ZP-ZDPM*ZQ)*ZT
      CH(J,I)=(ZDMP*ZPS-ZDPM*ZQS)*ZT
      ZD=H(J,I)*CH(J,I)
      PT5=DCMPLX(HALF,ZERO)
      D(J,I)=PT5*ZD
   11 CONTINUE
      DO 60 I=1,NPART-1
      IPP1=I+1
      DO 60 J=IPP1,NPART
      H(I,J)=-H(J,I)
      CH(I,J)=-CH(J,I)
   60 D(I,J)=D(J,I)
      RETURN
      END
CDECK  ID>, HWHEW3.
*CMZ :-        -27/03/92  19.48.55  by  Mike Seymour
*-- Author :    Zoltan Kunszt, modified by Bryan Webber
C-----------------------------------------------------------------------
      SUBROUTINE HWHEW3(N1,N2,N3,N4,N5,N6,AMPWW)
C-----------------------------------------------------------------------
C RECALL THAT N1,N3,N5 MUST BE OUTGOING FERMIONS, AND N2,N4,N6 MUST BE
C OUTGOING ANTI-FERMIONS; 3,4 FOR W-, 5,6 FOR W+
C
C EQ1 AND T31 ARE FOR OUTOING INITIAL QUARK
C CHOOSE APPROPRIATE CASE ACCORDING TO NUPDN
C NUPDN=1 FOR UUBAR COLLISIONS, NUPDN=2 FOR DDBAR COLLISIONS
C NFINAL CHOOSES THE FINAL DECAYS, 1 FOR DOUBLE LEPTON, 2 FOR 1 FLAVOR
C LEPTON+2FAMILIES OF QUARKS, 3 THE SAME, 4 FOR DOUBLE 2FAM3COLOR QUARKS
C
C NOTE: EXTERNAL FACTOR OF COLOR AVERAGE AND SPIN AVERAGE AND
C COUPLING (E**8/4/9) MUST BE INCLUDED AS WELL AS COMPENSATION
C FOR ON POLE APPROXIMATION AS DESIRED.
C-----------------------------------------------------------------------
      INCLUDE 'HERWIG62.INC'
      DOUBLE COMPLEX HWHEW4,ZH,ZCH,ZD,ZAMP1,ZAMP2,ZAMP3,DWW,CWW,BWW,AWW,
     & AWWM,AWWP,AMPTEM,ZTWO,ZHALF
      DOUBLE PRECISION XW,ZMASS,T3,EQ1,RR,RL,ZM2,AMP2,RKW,COLFAC(4),
     & AMPWW(4)
      INTEGER I,N1,N2,N3,N4,N5,N6
      EXTERNAL HWHEW4
      COMMON/HWHEWQ/ZH(7,7),ZCH(7,7),ZD(7,7)
      EQUIVALENCE (XW,SWEIN),(ZMASS,RMASS(200))
      DATA COLFAC/1.D0,3.D0,3.D0,9.D0/
      DATA ZTWO,ZHALF/(2.0,0.0),(0.5,0.0)/
      T3=-1.D0
      EQ1=-1.D0
      RR=-2.D0*EQ1*XW
      RL=T3+RR
      ZM2=ZMASS*ZMASS
      ZAMP1=DCMPLX(ZM2)/(ZTWO*ZD(N1,N2))
     &                /(ZTWO*ZD(N1,N2)+DCMPLX(-ZM2,GAMZ*ZMASS))
      ZAMP2=ZHALF/(ZD(N1,N3)+ZD(N1,N4)+ZD(N3,N4))
      ZAMP3=ZHALF/(ZD(N1,N5)+ZD(N1,N6)+ZD(N5,N6))
      DWW=DCMPLX(RL)*ZAMP1+T3/(ZTWO*ZD(N1,N2))
      CWW=DCMPLX(RR)*ZAMP1
      AWW=DWW
      BWW=DWW-ZAMP3
      AWWM=AWW*HWHEW4(N1,N2,N3,N4,N5,N6)-BWW*HWHEW4(N1,N2,N5,N6,N3,N4)
      AWWP=CWW*(HWHEW4(N2,N1,N5,N6,N3,N4)-HWHEW4(N2,N1,N3,N4,N5,N6))
      AMPTEM=AWWM*DCONJG(AWWM)+AWWP*DCONJG(AWWP)
      AMP2=DREAL(AMPTEM)
C AMP2 DOES NOT INCLUDE COLOR OR FLAVOR SUMS OR AVERAGES YET
C NOR DOES IT INCLUDE TO THIS POINT KWW**2
C 1 LEPTON FLAVOR IF APPROPRIATE FOR NFINAL CHOICE
      RKW=0.25D0/XW**2
      DO 6 I=1,4
6     AMPWW(I)=AMP2*COLFAC(I)*RKW*RKW
      RETURN
      END
CDECK  ID>, HWHEW4.
*CMZ :-        -26/04/91  10.18.57  by  Bryan Webber
*-- Author :    Zoltan Kunszt, modified by Bryan Webber
C-----------------------------------------------------------------------
      FUNCTION HWHEW4(N1,N2,N3,N4,N5,N6)
C-----------------------------------------------------------------------
      IMPLICIT NONE
      DOUBLE COMPLEX HWHEW4,ZH,ZCH,ZD
      INTEGER N1,N2,N3,N4,N5,N6
      COMMON/HWHEWQ/ZH(7,7),ZCH(7,7),ZD(7,7)
      HWHEW4=4*ZH(N1,N3)*ZCH(N2,N6)*(ZH(N1,N5)*ZCH(N1,N4)
     X                              +ZH(N3,N5)*ZCH(N3,N4))
      RETURN
      END
CDECK  ID>, HWHEW5.
*CMZ :          20/08/91  22.09.33  by  Federico Carminati
*-- Author :    Zoltan Kunszt, modified by Mike Seymour
C-----------------------------------------------------------------------
      SUBROUTINE HWHEW5(N1,N2,N3,N4,N5,N6,HELSUM,HELCTY,ID1,ID2)
C-----------------------------------------------------------------------
C RECALL THAT N1,N3,N5 MUST BE OUTGOING FERMIONS, AND N2,N4,N6 MUST BE
C OUTGOING ANTI-FERMIONS; 3,4 FOR Z0, 5,6 FOR Z0
C
C EQ1 AND T31 ARE FOR OUTOING INITIAL QUARK
C CHOOSE APPROPRIATE CASE ACCORDING TO NUPDN
C NUPDN=1 FOR UUBAR COLLISIONS, NUPDN=2 FOR DDBAR COLLISIONS
C NFINAL CHOOSES THE FINAL DECAYS, 1 FOR DOUBLE LEPTON, 2 FOR 1 FLAVOR
C LEPTON+2FAMILIES OF QUARKS, 3 THE SAME, 4 FOR DOUBLE 2FAM3COLOR QUARKS
C
C NOTE: EXTERNAL FACTOR OF COLOR AVERAGE AND SPIN AVERAGE AND
C COUPLING (E**8/4/9) MUST BE INCLUDED AS WELL AS COMPENSATION
C FOR ON POLE APPROXIMATION AS DESIRED.
C
C---SLIGHTLY MODIFIED BY MHS, SO THAT HELCTY REFERS TO THE FINAL STATE
C   INDICATED BY ID1,ID2
C-----------------------------------------------------------------------
      IMPLICIT NONE
      DOUBLE COMPLEX HWHEW4,ZH,ZCH,ZD,ZAMM(8),ZS134,ZS156,ZS234,ZS256,
     & ZTWO
      DOUBLE PRECISION CPFAC,CPALL,HELSUM,HELCTY,AMM
      INTEGER N1,N2,N3,N4,N5,N6,ID1,ID2,I
      EXTERNAL HWHEW4
      COMMON/HWHEWQ/ZH(7,7),ZCH(7,7),ZD(7,7)
      COMMON/HWHEWR/CPFAC(12,12,8),CPALL(8)
      DATA ZTWO/(2.0,0.0)/
C THE MATRIX ELEMENT DEPENDS ON
      ZS134=(ZD(N1,N3)+ZD(N1,N4)+ZD(N3,N4))*ZTWO
      ZS156=(ZD(N1,N5)+ZD(N1,N6)+ZD(N5,N6))*ZTWO
      ZS234=(ZD(N2,N3)+ZD(N2,N4)+ZD(N3,N4))*ZTWO
      ZS256=(ZD(N2,N5)+ZD(N2,N6)+ZD(N5,N6))*ZTWO
      ZAMM(1)=HWHEW4(N1,N2,N3,N4,N5,N6)/ZS134+
     >        HWHEW4(N1,N2,N5,N6,N3,N4)/ZS156
      ZAMM(2)=HWHEW4(N1,N2,N4,N3,N5,N6)/ZS134+
     >        HWHEW4(N1,N2,N5,N6,N4,N3)/ZS156
      ZAMM(3)=HWHEW4(N1,N2,N3,N4,N6,N5)/ZS134+
     >        HWHEW4(N1,N2,N6,N5,N3,N4)/ZS156
      ZAMM(4)=HWHEW4(N1,N2,N4,N3,N6,N5)/ZS134+
     >        HWHEW4(N1,N2,N6,N5,N4,N3)/ZS156
      ZAMM(5)=HWHEW4(N2,N1,N3,N4,N5,N6)/ZS234+
     >        HWHEW4(N2,N1,N5,N6,N3,N4)/ZS256
      ZAMM(6)=HWHEW4(N2,N1,N4,N3,N5,N6)/ZS234+
     >        HWHEW4(N2,N1,N5,N6,N4,N3)/ZS256
      ZAMM(7)=HWHEW4(N2,N1,N3,N4,N6,N5)/ZS234+
     >        HWHEW4(N2,N1,N6,N5,N3,N4)/ZS256
      ZAMM(8)=HWHEW4(N2,N1,N4,N3,N6,N5)/ZS234+
     >        HWHEW4(N2,N1,N6,N5,N4,N3)/ZS256
      HELSUM=0.0
      HELCTY=0.0
      DO 1 I=1,8
        AMM=DREAL(ZAMM(I)*DCONJG(ZAMM(I)))
        HELSUM=HELSUM+CPALL(I)*AMM
        HELCTY=HELCTY+CPFAC(ID1,ID2,I)*AMM
 1    CONTINUE
      RETURN
      END
CDECK  ID>, HWHEWW.
*CMZ :-        -02/05/91  10.58.29  by  Federico Carminati
*-- Author :    Zoltan Kunszt, modified by Bryan Webber
C-----------------------------------------------------------------------
      SUBROUTINE HWHEWW
C-----------------------------------------------------------------------
C     E+E- -> W+W-/Z0Z0 (BASED ON ZOLTAN KUNSZT'S PROGRAM)
C-----------------------------------------------------------------------
      INCLUDE 'HERWIG62.INC'
      DOUBLE COMPLEX ZH,ZCH,ZD
      DOUBLE PRECISION HWUAEM,HWRGEN,HWUPCM,ETOT,STOT,FLUXW,GAMM,GIMM,
     & WM2,WXMIN,WX1MAX,WX2MAX,FJAC1,FJAC2,WX1,WX2,WMM1,WMM2,XXM,W2BO,
     & PST,WEIGHT,TOTSIG,WMASS,WWIDTH,ELST,CV,CA,BR,XMASS,PLAB,PRW,PCM,
     & AMPWW(4),CCC,HELSUM,HELCTY,BRZED(12),BRTOT,CPFAC,CPALL,RLL(12),
     & RRL(12),DIST(4)
      INTEGER IB,IBOS,I,ID1,ID2,NTRY,IDP(10),IDBOS(2),J1,J2,IPRC,ILST,
     & IDZOLT(16),MAP(12),NEWHEP
      LOGICAL EISBM1,HWRLOG
      EXTERNAL HWUAEM,HWRGEN,HWUPCM
      SAVE IDP,STOT,FLUXW,GAMM,GIMM,WM2,WXMIN,WX1MAX,FJAC1,ELST,ILST,
     & IDBOS,WMASS,WWIDTH,BRZED
      COMMON/HWHEWP/XMASS(10),PLAB(5,10),PRW(5,2),PCM(5,10)
      COMMON/HWHEWQ/ZH(7,7),ZCH(7,7),ZD(7,7)
      COMMON/HWHEWR/CPFAC(12,12,8),CPALL(8)
      DATA ELST,ILST/0.,0/
      DATA IDZOLT/4,3,8,7,12,11,4*0,2,1,6,5,10,9/
      DATA MAP/12,11,2,1,14,13,4,3,16,15,6,5/
      IF (IERROR.NE.0) RETURN
      EISBM1=IDHW(1).LT.IDHW(2)
      IF (GENEV) THEN
        NEWHEP=NHEP
        NHEP=NHEP+2
        DO 20 IB=1,2
        IBOS=IB+NEWHEP
        CALL HWVEQU(5,PRW(1,IB),PHEP(1,IBOS))
        IF (EISBM1) PHEP(3,IBOS)=-PHEP(3,IBOS)
        CALL HWVZRO(4,VHEP(1,IBOS))
        CALL HWUDKL(IDBOS(IB),PHEP(1,IBOS),DIST)
        CALL HWVSUM(4,VHEP(1,IBOS),DIST,DIST)
        IDHW(IBOS)=IDBOS(IB)
        IDHEP(IBOS)=IDPDG(IDBOS(IB))
        JMOHEP(1,IBOS)=1
        JMOHEP(2,IBOS)=2
        ISTHEP(IBOS)=110
        DO 10 I=1,2
          CALL HWVEQU(5,PLAB(1,2*IB+I),PHEP(1,NHEP+I))
          IF (EISBM1) PHEP(3,NHEP+I)=-PHEP(3,NHEP+I)
          CALL HWVEQU(4,DIST,VHEP(1,NHEP+I))
C---STATUS, IDs AND POINTERS
          ISTHEP(NHEP+I)=112+I
          IDHW(NHEP+I)=IDP(2*IB+I)
          IDHEP(NHEP+I)=IDPDG(IDP(2*IB+I))
          JDAHEP(I,IBOS)=NHEP+I
          JMOHEP(1,NHEP+I)=IBOS
          JMOHEP(2,NHEP+I)=JMOHEP(1,IBOS)
 10     CONTINUE
        NHEP=NHEP+2
        JMOHEP(2,NHEP)=NHEP-1
        JDAHEP(2,NHEP)=NHEP-1
        JMOHEP(2,NHEP-1)=NHEP
        JDAHEP(2,NHEP-1)=NHEP
 20     CONTINUE
      ELSE
        EMSCA=PHEP(5,3)
        ETOT=EMSCA
        IPRC=MOD(IPROC,100)
        IF (ETOT.NE.ELST .OR. IPRC.NE.ILST) THEN
          STOT=ETOT*ETOT
          FLUXW=GEV2NB*.125*(HWUAEM(STOT)/PIFAC)**4/STOT
          IF (IPRC.EQ.0) THEN
            WMASS=RMASS(198)
            WWIDTH=GAMW
            IDBOS(1)=198
            IDBOS(2)=199
          ELSEIF (IPRC.EQ.50) THEN
            WMASS=RMASS(200)
            WWIDTH=GAMZ
            IDBOS(1)=200
            IDBOS(2)=200
C---LOAD FERMION COUPLINGS TO Z
            DO 30 I=1,12
              RLL(I)=VFCH(MAP(I),1)+AFCH(MAP(I),1)
              RRL(I)=VFCH(MAP(I),1)-AFCH(MAP(I),1)
 30         CONTINUE
            RLL(11)=0
            RRL(11)=0
            BRTOT=0
            DO 60 J1=1,12
              BRZED(J1)=0
              DO 50 J2=1,12
                CCC=1
                IF (MOD(J1-1,4).GE.2) CCC=CCC*CAFAC
                IF (MOD(J2-1,4).GE.2) CCC=CCC*CAFAC
                CPFAC(J1,J2,1)=CCC*(RLL(2)**2*RLL(J1)*RLL(J2))**2
                CPFAC(J1,J2,2)=CCC*(RLL(2)**2*RRL(J1)*RLL(J2))**2
                CPFAC(J1,J2,3)=CCC*(RLL(2)**2*RLL(J1)*RRL(J2))**2
                CPFAC(J1,J2,4)=CCC*(RLL(2)**2*RRL(J1)*RRL(J2))**2
                CPFAC(J1,J2,5)=CCC*(RRL(2)**2*RLL(J1)*RLL(J2))**2
                CPFAC(J1,J2,6)=CCC*(RRL(2)**2*RRL(J1)*RLL(J2))**2
                CPFAC(J1,J2,7)=CCC*(RRL(2)**2*RLL(J1)*RRL(J2))**2
                CPFAC(J1,J2,8)=CCC*(RRL(2)**2*RRL(J1)*RRL(J2))**2
                DO 40 I=1,8
                  IF (J1.EQ.1.AND.J2.EQ.1) CPALL(I)=0
                  CPALL(I)=CPALL(I)+CPFAC(J1,J2,I)
                  BRZED(J1)=BRZED(J1)+CPFAC(J1,J2,I)
                  BRTOT=BRTOT+CPFAC(J1,J2,I)
 40             CONTINUE
 50           CONTINUE
 60         CONTINUE
            DO 70 I=1,12
 70           BRZED(I)=BRZED(I)/BRTOT
          ELSE
            CALL HWWARN('HWHEWW',500,*999)
          ENDIF
          GAMM=WMASS*WWIDTH
          GIMM=1.D0/GAMM
          WM2=WMASS*WMASS
          WXMIN=ATAN(-WMASS/WWIDTH)
          WX1MAX=ATAN((STOT-WM2)*GIMM)
          FJAC1=WX1MAX-WXMIN
          ILST=IPRC
          ELST=ETOT
        ENDIF
        EVWGT=0
C---CHOOSE W MASSES
        WX1=WXMIN+FJAC1*HWRGEN(1)
        WMM1=GAMM*TAN(WX1)+WM2
        IF (WMM1.LE.0) RETURN
        XMASS(1)=SQRT(WMM1)
        WX2MAX=ATAN(((ETOT-XMASS(1))**2-WM2)*GIMM)
        FJAC2=WX2MAX-WXMIN
        WX2=WXMIN+FJAC2*HWRGEN(2)
        WMM2=GAMM*TAN(WX2)+WM2
        IF (WMM2.LE.0) RETURN
        XMASS(2)=SQRT(WMM2)
        IF (HWRLOG(HALF))THEN
         XXM=XMASS(1)
         XMASS(1)=XMASS(2)
         XMASS(2)=XXM
        ENDIF
C---CTMAX=ANGULAR CUT ON COS W-ANGLE
        CALL HWHEW0(1,ETOT,XMASS(1),PRW(1,1),W2BO,CTMAX)
        IF (W2BO.EQ.ZERO) RETURN
C---FOR ZZ EVENTS, FORCE BOSE STATISTICS, BY KILLING EVENTS WITH COS1<0
        IF (IPRC.NE.0) THEN
          IF (PRW(3,1).LT.ZERO) RETURN
C---AND THEN SYMMETRIZE (THIS PROCEDURE VASTLY IMPROVES EFFICIENCY)
          IF (HWRLOG(HALF)) THEN
            PRW(3,1)=-PRW(3,1)
            PRW(3,2)=-PRW(3,2)
          ENDIF
        ENDIF
        PLAB(3,1)=0.5*ETOT
        PLAB(4,1)=PLAB(3,1)
        PLAB(3,2)=-PLAB(3,1)
        PLAB(4,2)=PLAB(3,1)
C
C---LET THE W BOSONS DECAY
        NTRY=0
 80     NTRY=NTRY+1
        DO 90 IB=1,2
        CALL HWDBOZ(IDBOS(IB),ID1,ID2,CV,CA,BR,1)
        PST=HWUPCM(XMASS(IB),RMASS(ID1),RMASS(ID2))
        IF (PST.LT.ZERO) THEN
          CALL HWDBOZ(IDBOS(IB),ID1,ID2,CV,CA,BR,2)
          IF (NTRY.LE.NBTRY) GOTO 80
C          CALL HWWARN('HWHEWW',1,*999)
          RETURN
        ENDIF
        PRW(5,IB)=XMASS(IB)
        IDP(2*IB+1)=ID1
        IDP(2*IB+2)=ID2
        PLAB(5,2*IB+1)=RMASS(ID1)
        PLAB(5,2*IB+2)=RMASS(ID2)
        CALL HWDTWO(PRW(1,IB),PLAB(1,2*IB+1),PLAB(1,2*IB+2),
     &              PST,TWO,.TRUE.)
 90     CONTINUE
        WEIGHT=FLUXW*W2BO*FJAC1*FJAC2*(0.5D0*PIFAC*GIMM)**2
        CALL HWHEW1(6)
        CALL HWHEW2(6,PCM(1,1),ZH,ZCH,ZD)
        IF (IPRC.EQ.0) THEN
          CALL HWHEW3(5,6,3,4,1,2,AMPWW)
          TOTSIG=9.*AMPWW(1)+6.*(AMPWW(2)+AMPWW(3))+4.*AMPWW(4)
          EVWGT=TOTSIG*WEIGHT*BR
        ELSE
          ID1=IDZOLT(IDPDG(IDP(3)))
          ID2=IDZOLT(IDPDG(IDP(5)))
          CALL HWHEW5(5,6,3,4,1,2,HELSUM,HELCTY,ID1,ID2)
          EVWGT=HELCTY*WEIGHT*BR/(BRZED(ID1)*BRZED(ID2))
        ENDIF
      ENDIF
 999  END
CDECK  ID>, HWHGRV.
*CMZ :-        -13/10/00  10:48:07  by  Peter Richardson
*-- Author      Kosuke Odagiri
C-----------------------------------------------------------------------
      SUBROUTINE HWHGRV
C-----------------------------------------------------------------------
C     Massive spin-2 resonance (massive graviton)
C     Universal tensor coupling to the energy-momentum tensor is assumed
C     viz L = - G(mu,nu) T(mu,nu) / GRVLAM
C     If GAMGRV is zero, it is revaluated during the first run
C     MEAN EVWGT = SIGMA IN NB
C-----------------------------------------------------------------------
      INCLUDE 'HERWIG62.INC'
      DOUBLE PRECISION HWRGEN,HWRUNI,EPS,EMSQG,
     & EMGMG,S,CC,CC2,SS,SS2,M1(16),M2(16),M3,M4,M5(3),M6(3),
     & RNGLU,FACT,HCS,FACTR,RCS,A2,A02,QPE,SQPE,RGRV
      INTEGER IMODE,JQMN,JQMX,JQ,JLMN,JLMX,JL,IQ,I,ID1,ID2,ID3,ID4,
     & IADD(2,2)
      LOGICAL JGLU,JPHO,JW,JZ,JH
      EXTERNAL HWRGEN,HWRUNI
      SAVE HCS,JQMN,JQMX,JLMN,JLMX,JGLU,JPHO,JW,JZ,JH,EMSQG,EMGMG,
     & A2,A02,FACT,RNGLU,M1,M2,M3,M4,M5,M6
      PARAMETER (EPS=1.D-9)
      DATA IADD/0,6,6,0/
      IF (GENEV) THEN
       RCS=HCS*HWRGEN(0)
      ELSE
       IF (FSTWGT) THEN
C Set limits for which particles to include
        JLMN=1
        JLMX=0
        JQMN=1
        JQMX=0
        JGLU=.FALSE.
        JPHO=.FALSE.
        JW  =.FALSE.
        JZ  =.FALSE.
        JH  =.FALSE.
        IMODE=MOD(IPROC,100)
        IF (IMODE.EQ.0) THEN
         JQMN=1
         JQMX=6
         JGLU=.TRUE.
         JLMN=11
         JLMX=16
         JPHO=.TRUE.
         JW  =.TRUE.
         JZ  =.TRUE.
         JH  =.TRUE.
        ELSEIF (IMODE.EQ.10) THEN
         JQMN=1
         JQMX=6
         JGLU=.TRUE.
        ELSEIF (IMODE.GT.10.AND.IMODE.LE.16) THEN
         JQMN=IMODE-10
         JQMX=IMODE-10
        ELSEIF (IMODE.EQ.20) THEN
         JGLU=.TRUE.
        ELSEIF (IMODE.EQ.50) THEN
         JLMN=11
         JLMX=16
         JPHO=.TRUE.
        ELSEIF (IMODE.GT.50.AND.IMODE.LE.56) THEN
         JLMN=IMODE-40
         JLMX=IMODE-40
        ELSEIF (IMODE.EQ.60) THEN
         JPHO=.TRUE.
        ELSEIF (IMODE.EQ.70) THEN
         JW  =.TRUE.
         JZ  =.TRUE.
         JH  =.TRUE.
        ELSEIF (IMODE.EQ.71) THEN
         JW  =.TRUE.
        ELSEIF (IMODE.EQ.72) THEN
         JZ  =.TRUE.
        ELSEIF (IMODE.EQ.73) THEN
         JH  =.TRUE.
        ELSE
         CALL HWWARN('HWHGRV',500,*999)
        ENDIF
        RNGLU=CAFAC**2-ONE
        IF (GAMGRV.EQ.ZERO) THEN
C Calculate the width if GAMGRV=ZERO.
C Quarks
         DO 10 JQ=1,6
          RGRV=(RMASS(JQ)/EMGRV)**2
          QPE=ONE-4.D0*RGRV
          IF (QPE.GT.ZERO) THEN
           SQPE=SQRT(QPE)
           GAMGRV=GAMGRV+CAFAC*SQPE**3*(ONE+8.D0/3.D0*RGRV)/4.D0
          END IF
  10     CONTINUE
C Leptons
         DO 20 JL=121,126
          RGRV=(RMASS(JL)/EMGRV)**2
          QPE=ONE-4.D0*RGRV
          IF (QPE.GT.ZERO) THEN
           SQPE=SQRT(QPE)
           GAMGRV=GAMGRV+SQPE**3*(ONE+8.D0/3.D0*RGRV)/4.D0
          END IF
  20     CONTINUE
C Photons
         GAMGRV=GAMGRV+HALF
C gg
         GAMGRV=GAMGRV+HALF*RNGLU
C ZZ
         RGRV=(RMASS(200)/EMGRV)**2
         QPE=ONE-4.D0*RGRV
         IF (QPE.GT.ZERO) THEN
          SQPE=SQRT(QPE)
          GAMGRV=GAMGRV+SQPE*
     &     (13.D0/12.D0+14.D0/3.D0*RGRV+4.D0*RGRV**2)/TWO
         END IF
C WW
         RGRV=(RMASS(198)/EMGRV)**2
         QPE=ONE-4.D0*RGRV
         IF (QPE.GT.ZERO) THEN
          SQPE=SQRT(QPE)
          GAMGRV=GAMGRV+SQPE*
     &     (13.D0/12.D0+14.D0/3.D0*RGRV+4.D0*RGRV**2)
         END IF
C HH
         RGRV=(RMASS(201)/EMGRV)**2
         QPE=ONE-4.D0*RGRV
         IF (QPE.GT.ZERO) THEN
          SQPE=SQRT(QPE)
          GAMGRV=GAMGRV+SQPE**5/12.D0/TWO
         END IF
         GAMGRV=GAMGRV*EMGRV**3/(GRVLAM**2*40.D0*PIFAC)
        END IF
        EMSQG=EMGRV**2
        EMGMG=EMGRV*GAMGRV
        A02=ATAN((EMMIN**2-EMSQG)/EMGMG)
        A2 =ATAN((EMMAX**2-EMSQG)/EMGMG)-A02
       ENDIF
       EVWGT=0.
C Select a mass for the produced pair
       S=EMSQG+EMGMG*TAN(A02+A2*HWRGEN(1))
       EMSCA=SQRT(S)
C Select initial momentum fractions
       XXMIN=S/PHEP(5,3)**2
       XLMIN=LOG(XXMIN)
       CALL HWSGEN(.TRUE.)
       COSTH=HWRUNI(0,-ONE,ONE)
C
       FACT=-GEV2NB*A2*XLMIN*S**2/(GRVLAM**4*EMGMG*16.D0*PIFAC)
       CC = COSTH**2
       CC2= CC**2
       SS = ONE-CC
       SS2= SS**2
C QQ,GG -> FF
       DO 110 I=1,6
         JQ=I
         JL=I+10
         QPE=ONE-4.D0*RMASS(JQ)**2/S
         IF (QPE.GT.ZERO) THEN
           SQPE=SQRT(QPE)
           M1(JQ)=SQPE*QPE*(ONE+CC-4.D0*QPE*SS*CC)/64.D0/CAFAC
           M2(JQ)=SQPE*QPE*SS*(TWO-QPE*SS)/16.D0/RNGLU
         ELSE
           M1(JQ)=ZERO
           M2(JQ)=ZERO
         END IF
         QPE=ONE-4.D0*RMASS(JL+110)**2/S
         IF (QPE.GT.ZERO) THEN
           SQPE=SQRT(QPE)
           M1(JL)=SQPE*QPE*(ONE+CC-4.D0*QPE*SS*CC)/64.D0/CAFAC
           M2(JL)=SQPE*QPE*SS*(TWO-QPE*SS)/16.D0/RNGLU
         ELSE
           M1(JL)=ZERO
           M2(JL)=ZERO
         END IF
  110  CONTINUE
C QQ,GG -> BB (massless)
       M3=SS*(ONE+CC)/32.D0/CAFAC
       M4=(CC+SS2/8.D0)/4.D0/RNGLU
C QQ,GG -> W,Z,H
       QPE=ONE-4.D0*RMASS(198)**2/S
       IF (QPE.GT.ZERO) THEN
       SQPE=SQRT(QPE)
       M5(1)=SQPE*(ONE-.5D0*QPE*(ONE+CC)+.75D0*QPE**2*CC*SS)/8.D0/CAFAC
       M6(1)=SQPE*(ONE-QPE*SS+3.D0*QPE**2*SS2/16.D0)/2.D0/RNGLU
       ELSE
       M5(1)=ZERO
       M6(1)=ZERO
       END IF
       QPE=ONE-4.D0*RMASS(200)**2/S
       IF (QPE.GT.ZERO) THEN
       SQPE=SQRT(QPE)
       M5(2)=SQPE*(ONE-.5D0*QPE*(ONE+CC)+.75D0*QPE**2*CC*SS)/16.D0/CAFAC
       M6(2)=SQPE*(ONE-QPE*SS+3.D0*QPE**2*SS2/16.D0)/4.D0/RNGLU
       ELSE
       M5(2)=ZERO
       M6(2)=ZERO
       END IF
       QPE=ONE-4.D0*RMASS(201)**2/S
       IF (QPE.GT.ZERO) THEN
       SQPE=SQRT(QPE)
       M5(3)=SQPE*(QPE**2*SS*CC)/64.D0/CAFAC
       M6(3)=SQPE*(QPE**2*SS2)/64.D0/RNGLU
       ELSE
       M5(3)=ZERO
       M6(3)=ZERO
       END IF
      END IF
      HCS=ZERO
      DO 90 I=1,2
C I=1 quark first, I=2 anti-quark first
       DO 80 IQ=1,6
        ID1=IQ+IADD(1,I)
        ID2=IQ+IADD(2,I)
        IF (DISF(ID1,1).LT.EPS.OR.DISF(ID2,2).LT.EPS) GOTO 80
        FACTR=FACT*DISF(ID1,1)*DISF(ID2,2)
C Quark final states
        DO 60 JQ=JQMN,JQMX
         ID3=JQ
         ID4=JQ+6
         HCS=HCS+FACTR*M1(JQ)*CAFAC
         IF (GENEV.AND.HCS.GT.RCS) CALL HWHQCP(ID3,ID4,2143,50,*99)
  60    CONTINUE
C Lepton final states
        DO 70 JL=JLMN,JLMX
         ID3=110+JL
         ID4=ID3+6
         HCS=HCS+FACTR*M1(JL)
         IF (GENEV.AND.HCS.GT.RCS) CALL HWHQCP(ID3,ID4,2134,50,*99)
  70    CONTINUE
C Bosonic final states
        IF (JPHO) THEN
         ID3=59
         ID4=59
         HCS=HCS+FACTR*M3
         IF (GENEV.AND.HCS.GT.RCS) CALL HWHQCP(ID3,ID4,2134,50,*99)
        END IF
        IF (JW) THEN
         ID3=198
         ID4=199
         HCS=HCS+FACTR*M5(1)
         IF (GENEV.AND.HCS.GT.RCS) CALL HWHQCP(ID3,ID4,2134,50,*99)
        END IF
        IF (JZ) THEN
         ID3=200
         ID4=200
         HCS=HCS+FACTR*M5(2)
         IF (GENEV.AND.HCS.GT.RCS) CALL HWHQCP(ID3,ID4,2134,50,*99)
        END IF
        IF (JH) THEN
         ID3=201
         ID4=201
         HCS=HCS+FACTR*M5(3)
         IF (GENEV.AND.HCS.GT.RCS) CALL HWHQCP(ID3,ID4,2134,50,*99)
        END IF
        IF (JGLU) THEN
         ID3=13
         ID4=13
         HCS=HCS+FACTR*M3*RNGLU
         IF (GENEV.AND.HCS.GT.RCS) CALL HWHQCP(ID3,ID4,2143,50,*99)
        END IF
  80   CONTINUE
  90  CONTINUE
C Gluon initial states
      ID1=13
      ID2=13
      IF (DISF(ID1,1).LT.EPS.OR.DISF(ID2,2).LT.EPS) GOTO 30
      FACTR=FACT*DISF(ID1,1)*DISF(ID2,2)
C Quark final states
      DO 40 JQ=JQMN,JQMX
       ID3=JQ
       ID4=JQ+6
       HCS=HCS+FACTR*M2(JQ)*CAFAC
       IF (GENEV.AND.HCS.GT.RCS) CALL HWHQCP(ID3,ID4,2143,51,*99)
  40  CONTINUE
C Lepton final states
      DO 50 JL=JLMN,JLMX
       ID3=110+JL
       ID4=ID3+6
       HCS=HCS+FACTR*M2(JL)
       IF (GENEV.AND.HCS.GT.RCS) CALL HWHQCP(ID3,ID4,2134,51,*99)
  50  CONTINUE
C Vector boson final states
      IF (JPHO) THEN
       ID3=59
       ID4=59
       HCS=HCS+FACTR*M4
       IF (GENEV.AND.HCS.GT.RCS) CALL HWHQCP(ID3,ID4,2134,51,*99)
      END IF
      IF (JW) THEN
       ID3=198
       ID4=199
       HCS=HCS+FACTR*M6(1)
       IF (GENEV.AND.HCS.GT.RCS) CALL HWHQCP(ID3,ID4,2134,51,*99)
      END IF
      IF (JZ) THEN
       ID3=200
       ID4=200
       HCS=HCS+FACTR*M6(2)
       IF (GENEV.AND.HCS.GT.RCS) CALL HWHQCP(ID3,ID4,2134,51,*99)
      END IF
      IF (JH) THEN
       ID3=201
       ID4=201
       HCS=HCS+FACTR*M6(3)
       IF (GENEV.AND.HCS.GT.RCS) CALL HWHQCP(ID3,ID4,2134,51,*99)
      END IF
      IF (JGLU) THEN
       ID3=13
       ID4=13
       HCS=HCS+FACTR*M4*RNGLU
       IF (GENEV.AND.HCS.GT.RCS) CALL HWHQCP(ID3,ID4,2143,51,*99)
      END IF
  30  CONTINUE
      EVWGT=HCS
      RETURN
C Generate event
  99  IDN(1)=ID1
      IDN(2)=ID2
      IDCMF=208
      CALL HWETWO
      IF (AZSPIN) THEN
C Calculate coefficients for constructing spin density matrices
C Set to zero for now
        CALL HWVZRO(7,GCOEF)
      END IF
  999 END
CDECK  ID>, HWHHVY.
*CMZ :-        -18/05/99  14.55.44  by  Kosuke Odagiri
*-- Author :    Bryan Webber
C-----------------------------------------------------------------------
      SUBROUTINE HWHHVY
C-----------------------------------------------------------------------
C     QCD HEAVY FLAVOUR PRODUCTION: MEAN EVWGT = SIGMA IN NB
C-----------------------------------------------------------------------
      INCLUDE 'HERWIG62.INC'
      DOUBLE PRECISION HWRGEN,HWRUNI,HWUALF,EPS,RCS,Z1,Z2,ET,EJ,
     & QM2,QPE,FACTR,S,T,U,ST,TU,US,TUS,UST,EN,RN,AF,ASTU,
     & AUST,CF,CN,CS,CSTU,CSUT,CTSU,CTUS,HCS,UT,SU,GT,DIST,KK,KK2,
     & YJ1INF,YJ1SUP,YJ2INF,YJ2SUP
      INTEGER IQ1,IQ2,ID1,ID2
      LOGICAL HQ1,HQ2
      EXTERNAL HWRGEN,HWRUNI,HWUALF
      SAVE HCS,ASTU,AUST,CSTU,CSUT,CTSU,CTUS,S,T,TU,U,US
      PARAMETER (EPS=1.D-9)
      IF (GENEV) THEN
        RCS=HCS*HWRGEN(0)
      ELSE
        EVWGT=0.
        CALL HWRPOW(ET,EJ)
        KK = ET/PHEP(5,3)
        KK2=KK**2
        IF (KK.GE.ONE) RETURN
        YJ1INF = MAX( YJMIN, LOG((ONE-SQRT(ONE-KK2))/KK) )
        YJ1SUP = MIN( YJMAX, LOG((ONE+SQRT(ONE-KK2))/KK) )
        IF (YJ1INF.GE.YJ1SUP) RETURN
        Z1=EXP(HWRUNI(1,YJ1INF,YJ1SUP))
        YJ2INF = MAX( YJMIN, -LOG(TWO/KK-ONE/Z1) )
        YJ2SUP = MIN( YJMAX, LOG(TWO/KK-Z1) )
        IF (YJ2INF.GE.YJ2SUP) RETURN
        Z2=EXP(HWRUNI(2,YJ2INF,YJ2SUP))
        XX(1)=HALF*(Z1+Z2)*KK
        IF (XX(1).GE.ONE) RETURN
        XX(2)=XX(1)/(Z1*Z2)
        IF (XX(2).GE.ONE) RETURN
        S=XX(1)*XX(2)*PHEP(5,3)**2
        IQ1=MOD(IPROC,100)
        QM2=RMASS(IQ1)**2
        QPE=S-4.*QM2
        IF (QPE.LE.ZERO) RETURN
        COSTH=HALF*ET*(Z1-Z2)/SQRT(Z1*Z2*QPE)
        IF (ABS(COSTH).GT.ONE) RETURN
C---REDEFINE S, T, U AS P1.P2, -P1.P3, -P1.P4
        S=HALF*S
        T=-HALF*(1.+Z2/Z1)*(HALF*ET)**2
        U=-S-T
C---SET EMSCA TO HEAVY HARD PROCESS SCALE
        EMSCA=SQRT(4.*S*T*U/(S*S+T*T+U*U))
        FACTR = GEV2NB*.125*PIFAC*EJ*ET*(HWUALF(1,EMSCA)/S)**2
     &         *(YJ1SUP-YJ1INF)*(YJ2SUP-YJ2INF)
        CALL HWSGEN(.FALSE.)
C
        ST=S/T
        TU=T/U
        UT=U/T
        US=U/S
        SU=S/U
        TUS=US/ST
        UST=ST/TU
C
        EN=CAFAC
        RN=CFFAC/EN
        AF=FACTR*RN
        ASTU=AF*(1.-2.*UST+QM2/T)
        AUST=AF*(1.-2.*TUS+QM2/S)
        CF=FACTR/(2.*CFFAC)
        CN=1./(EN*EN)
C-----------------------------------------------------------------------
C---Heavy flavour colour decomposition modifications below (KO)
C-----------------------------------------------------------------------
        CS=(TU+UT-CN/TUS)*(HALF-TUS+QM2/S-QM2**2/U/T/TWO)
        CSTU=CF*CS/(ONE+TU**2)
        CSUT=CF*CS/(ONE+UT**2)
        CS=(SU+US-CN/UST)*(HALF-UST+QM2/T-QM2**2/U/S/TWO)
        CTSU=-FACTR*CS/(ONE+SU**2)
        CTUS=-FACTR*CS/(ONE+US**2)
C-----------------------------------------------------------------------
C       CS=HALF/TU-QM2/T-HALF*(QM2/T)**2
C       CSTU=CF*(CS-   US**2-QM2/S - CN*(CS+QM2*QM2/(S*T)))
C       CS=HALF*TU-QM2/U-HALF*(QM2/U)**2
C       CSUT=CF*(CS-1./ST**2-QM2/S - CN*(CS+QM2*QM2/(S*U)))
C       CS=HALF*US-QM2/S-HALF*(QM2/S)**2
C       CTSU=-FACTR*(CS-1./TU**2-QM2/T - CN*(CS+QM2*QM2/(S*T)))
C       CS=HALF/US-QM2/U-HALF*(QM2/U)**2
C       CTUS=-FACTR*(CS-   ST**2-QM2/T - CN*(CS+QM2*QM2/(T*U)))
C-----------------------------------------------------------------------
      ENDIF
C
      HCS=0.
      IQ2=IQ1+6
      DO 6 ID1=1,13
      IF (DISF(ID1,1).LT.EPS) GOTO 6
      HQ1=ID1.EQ.IQ1.OR.ID1.EQ.IQ2
      DO 5 ID2=1,13
      IF (DISF(ID2,2).LT.EPS) GOTO 5
      HQ2=ID2.EQ.IQ1.OR.ID2.EQ.IQ2
      DIST=DISF(ID1,1)*DISF(ID2,2)
      IF (HQ1.OR.HQ2) THEN
C---PROCESSES INVOLVING HEAVY CONSTITUENT
C   N.B. NEGLECT CASE THAT BOTH ARE HEAVY
      IF (HQ1.AND.HQ2) GOTO 5
      IF (ID1.LT.7) THEN
C---QUARK FIRST
       IF (ID2.LT.7) THEN
         HCS=HCS+ASTU*DIST
         IF (GENEV.AND.HCS.GT.RCS) CALL HWHQCP(ID1,ID2,3421, 3,*9)
       ELSEIF (ID2.NE.13) THEN
         HCS=HCS+ASTU*DIST
         IF (GENEV.AND.HCS.GT.RCS) CALL HWHQCP(ID1,ID2,3142, 9,*9)
       ELSE
         HCS=HCS+CTSU*DIST
         IF (GENEV.AND.HCS.GT.RCS) CALL HWHQCP(ID1,ID2,3142,10,*9)
         HCS=HCS+CTUS*DIST
         IF (GENEV.AND.HCS.GT.RCS) CALL HWHQCP(ID1,ID2,3421,11,*9)
       ENDIF
      ELSEIF (ID1.NE.13) THEN
C---QBAR FIRST
       IF (ID2.LT.7) THEN
         HCS=HCS+ASTU*DIST
         IF (GENEV.AND.HCS.GT.RCS) CALL HWHQCP(ID1,ID2,2413,17,*9)
       ELSEIF (ID2.NE.13) THEN
         HCS=HCS+ASTU*DIST
         IF (GENEV.AND.HCS.GT.RCS) CALL HWHQCP(ID1,ID2,4312,20,*9)
       ELSE
         HCS=HCS+CTSU*DIST
         IF (GENEV.AND.HCS.GT.RCS) CALL HWHQCP(ID1,ID2,2413,21,*9)
         HCS=HCS+CTUS*DIST
         IF (GENEV.AND.HCS.GT.RCS) CALL HWHQCP(ID1,ID2,4312,22,*9)
       ENDIF
      ELSE
C---GLUON FIRST
       IF (ID2.LT.7) THEN
         HCS=HCS+CTSU*DIST
         IF (GENEV.AND.HCS.GT.RCS) CALL HWHQCP(ID1,ID2,2413,23,*9)
         HCS=HCS+CTUS*DIST
         IF (GENEV.AND.HCS.GT.RCS) CALL HWHQCP(ID1,ID2,3421,24,*9)
       ELSEIF (ID2.LT.13) THEN
         HCS=HCS+CTSU*DIST
         IF (GENEV.AND.HCS.GT.RCS) CALL HWHQCP(ID1,ID2,3142,25,*9)
         HCS=HCS+CTUS*DIST
         IF (GENEV.AND.HCS.GT.RCS) CALL HWHQCP(ID1,ID2,4312,26,*9)
       ENDIF
      ENDIF
      ELSEIF (ID2.NE.13.AND.ID2.EQ.ID1+6) THEN
C---LIGHT Q-QBAR ANNIHILATION
         HCS=HCS+AUST*DIST
         IF (GENEV.AND.HCS.GT.RCS) CALL HWHQCP(IQ1,IQ2,2413, 4,*9)
      ELSEIF (ID1.NE.13.AND.ID1.EQ.ID2+6) THEN
C---LIGHT QBAR-Q ANNIHILATION
         HCS=HCS+AUST*DIST
         IF (GENEV.AND.HCS.GT.RCS) CALL HWHQCP(IQ2,IQ1,3142,12,*9)
      ELSEIF (ID1.EQ.13.AND.ID2.EQ.13) THEN
C---GLUON FUSION
         HCS=HCS+CSTU*DIST
         IF (GENEV.AND.HCS.GT.RCS) CALL HWHQCP(IQ1,IQ2,2413,27,*9)
         HCS=HCS+CSUT*DIST
         IF (GENEV.AND.HCS.GT.RCS) CALL HWHQCP(IQ1,IQ2,4123,28,*9)
      ENDIF
    5 CONTINUE
    6 CONTINUE
      EVWGT=HCS
      RETURN
C---GENERATE EVENT
    9 IDN(1)=ID1
      IDN(2)=ID2
      IDCMF=15
      CALL HWETWO
      IF (AZSPIN) THEN
C Calculate coefficients for constructing spin density matrices
         IF (IHPRO.EQ.7 .OR.IHPRO.EQ.8 .OR.
     &       IHPRO.EQ.15.OR.IHPRO.EQ.16) THEN
C qqbar-->gg or qbarq-->gg
            UT=1./TU
            GCOEF(1)=UT+TU
            GCOEF(2)=-2.
            GCOEF(3)=0.
            GCOEF(4)=0.
            GCOEF(5)=GCOEF(1)
            GCOEF(6)=UT-TU
            GCOEF(7)=-GCOEF(6)
         ELSEIF (IHPRO.EQ.10.OR.IHPRO.EQ.11.OR.
     &           IHPRO.EQ.21.OR.IHPRO.EQ.22.OR.
     &           IHPRO.EQ.23.OR.IHPRO.EQ.24.OR.
     &           IHPRO.EQ.25.OR.IHPRO.EQ.26) THEN
C qg-->qg or qbarg-->qbarg or gq-->gq  or gqbar-->gqbar
            SU=1./US
            GCOEF(1)=-(SU+US)
            GCOEF(2)=0.
            GCOEF(3)=2.
            GCOEF(4)=0.
            GCOEF(5)=SU-US
            GCOEF(6)=GCOEF(1)
            GCOEF(7)=-GCOEF(5)
         ELSEIF (IHPRO.EQ.27.OR.IHPRO.EQ.28) THEN
C gg-->qqbar
            UT=1./TU
            GCOEF(1)=TU+UT
            GCOEF(2)=-2.
            GCOEF(3)=0.
            GCOEF(4)=0.
            GCOEF(5)=GCOEF(1)
            GCOEF(6)=TU-UT
            GCOEF(7)=-GCOEF(6)
         ELSEIF (IHPRO.EQ.29.OR.IHPRO.EQ.30.OR.
     &                          IHPRO.EQ.31) THEN
C gg-->gg
            GT=S*S+T*T+U*U
            GCOEF(2)=2.*U*U*T*T
            GCOEF(3)=2.*S*S*U*U
            GCOEF(4)=2.*S*S*T*T
            GCOEF(1)=GT*GT-GCOEF(2)-GCOEF(3)-GCOEF(4)
            GCOEF(5)=GT*(GT-2.*S*S)-GCOEF(2)
            GCOEF(6)=GT*(GT-2.*T*T)-GCOEF(3)
            GCOEF(7)=GT*(GT-2.*U*U)-GCOEF(4)
         ELSE
            CALL HWVZRO(7,GCOEF)
         ENDIF
      ENDIF
  999 END
CDECK  ID>, HWHIBG.
*CMZ :-        -26/11/00  17.21.55  by  Bryan Webber
*-- Author :  Kosuke Odagiri & Stefano Moretti
C-----------------------------------------------------------------------
C...Generate completely differential cross section (EVWGT) in the variables
C...X(I) with I=1,3 (see below) for the processes IPROC=3410,3420,3430,3450
C...as described in the HERWIG 6 documentation file.
C...It includes interface to PDFs and takes into account color connections
C...among partons.
C
C...First release:  6-AUG-1999 by Kosuke Odagiri
C...Last modified:  6-SEP-1999 by Stefano Moretti
C
C-----------------------------------------------------------------------
      SUBROUTINE HWHIBG
C-----------------------------------------------------------------------
C     HIGGS + HEAVY QUARK (BOTTOM & TOP) PRODUCTION (2HDM)
C-----------------------------------------------------------------------
      INCLUDE 'HERWIG62.INC'
      DOUBLE PRECISION HWRGEN, HWUALF, HWUAEM, EPS, HCS, RCS,
     & DIST, SM, DM, QPE, PF, SQPE, EMSC2, FACTR, S, T3, U4,
     & SN2TH, ME2(0:4), MW, XWEIN, PT2MIN, PT2, GQH(0:4), G1, RMMIN,
     & EMG, EMQ, EMH, EMG2, EMQ2, EMH2, EMHWT, ECM_MAX, X(3), XL(3),
     & XU(3), WEIGHT, ECM, SHAT, TAU, T, TL, TLMIN, TLMAX, TTMIN, TTMAX,
     & CTMP, PCM, PCM2, RCM, RCM2, FKLN
      INTEGER ID1, ID2, IH, IQ, I
      EXTERNAL HWRGEN, HWUALF, HWUAEM
      SAVE HCS,ME2,S,SHAT
      PARAMETER (EPS = 1.D-9)
      EQUIVALENCE (MW, RMASS(198))
      PARAMETER (EMG=0.,EMG2=0.)
C...generate event.
      IF (GENEV) THEN
        RCS = HCS*HWRGEN(0)
      ELSE
        HCS = ZERO
        EVWGT = ZERO
C...minimum transverse momentum.
        PTMIN = ZERO
        PT2MIN = PTMIN**2
C...accompanying quark.
        IQ=5
        IF(IHIGGS.GE.5)IQ=6
        EMQ=RMASS(IQ)
        EMQ2=EMQ*EMQ
C...on-shell Higgs.
        EMH=RMASS(201+IHIGGS)
        EMHWT=1.D0
        EMH2=EMH*EMH
        RMMIN=(EMQ+EMH)/2.
C...energy at hadron level.
        ECM_MAX=PBEAM1+PBEAM2
        S=ECM_MAX*ECM_MAX
C...phase space variables.
C...IF IQ=5 -> X(1)=(LOG(|T|)-LOG(|TMIN|))/(LOG(|TMAX|)-LOG(|TMIN|),
C...IF IQ=6 -> X(1)=COS(THETA_CM);
C...X(2)=(1./SHAT-1./ECM_MAX**2)/(1./(EMQ+EMH)**2-1./ECM_MAX**2),
C...X(3)=(LOG(TAU)-LOG(X1))/LOG(TAU),
C...phase space borders.
        IF(IQ.EQ.5)XL(1)=0.
        IF(IQ.EQ.6)XL(1)=-1.
        XU(1)=1.
        XL(2)=0.
        XU(2)=1.
        XL(3)=0.
        XU(3)=1.
C...single phase space point.
 100    CONTINUE
        WEIGHT=1.
        DO I=1,3
          X(I)=XL(I)+(XU(I)-XL(I))*HWRGEN(0)
          WEIGHT=WEIGHT*ABS(XU(I)-XL(I))
        END DO
C...energy at parton level.
        ECM=SQRT(1./(X(2)*(1./(EMQ+EMH)**2-1./ECM_MAX**2)
     &                                    +1./ECM_MAX**2))
        IF((EMH.LE.0.).OR.(EMH.GE.ECM))RETURN
        SHAT=ECM*ECM
        TAU=SHAT/S
C...momentum fractions X1 and X2.
        XX(1)=EXP(LOG(TAU)*(1.-X(3)))
        XX(2)=TAU/XX(1)
C...reconstruct polar angle.
        IF(IQ.EQ.5)THEN
          PCM2=((SHAT-EMQ2-EMG2)**2
     &        -(2.*EMQ*EMG)**2)/(4.*SHAT)
          PCM=SQRT(PCM2)
          RCM2=((SHAT-EMQ2-EMH2)**2
     &        -(2.*EMQ*EMH)**2)/(4.*SHAT)
          RCM=SQRT(RCM2)
          FKLN=SQRT((SHAT-(EMQ+EMG)**2)*(SHAT-(EMQ-EMG)**2))
     &        *SQRT((SHAT-(EMQ+EMH)**2)*(SHAT-(EMQ-EMH)**2))
          TTMAX=EMG2+EMQ2-0.5D0/ECM/ECM
     &        *((SHAT+EMG2-EMQ2)*(SHAT+EMQ2-EMH2)
     &    -FKLN)
          TTMIN=EMG2+EMQ2-0.5D0/ECM/ECM
     &        *((SHAT+EMG2-EMQ2)*(SHAT+EMQ2-EMH2)
     &    +FKLN)
          TLMAX=LOG(ABS(TTMIN))
          TLMIN=LOG(ABS(TTMAX))
          TL=X(1)*(TLMAX-TLMIN)+TLMIN
          T=EXP(TL)
          CTMP=-T-EMG2-EMQ2
     &       +2.*SQRT(PCM2+EMG2)*SQRT(RCM2+EMQ2)
          COSTH = CTMP/2./PCM/RCM
        ELSE IF(IQ.EQ.6)THEN
          COSTH = X(1)
        END IF
        SN2TH = 0.25D0 - 0.25D0*COSTH**2
        IF((0.25D0-RMMIN**2/SHAT).LT.0.)THEN
          EVWGT=0.
          RETURN
        END IF
        T3    = ( SQRT(0.25D0-RMMIN**2/SHAT) * COSTH - HALF ) * SHAT
        U4    = - T3 - SHAT
        EMSC2 = TWO*SHAT*T3*U4/(SHAT**2+T3**2+U4**2)
        EMSCA = SQRT( EMSC2 )
        CALL    HWSGEN(.FALSE.)
        EVWGT = ZERO
        XWEIN = TWO * SWEIN
        FACTR = GEV2NB*PIFAC*HWUAEM(EMSC2)/XWEIN/SHAT
     &                      *HWUALF(1,EMSCA)/TWO/CAFAC/2.
C...Jacobians from COSTH to X(1).
        IF(IQ.EQ.5)THEN
          FACTR=FACTR*(TLMAX-TLMIN)/2./PCM/RCM*T
        ELSE
          CONTINUE
        END IF
C...Jacobians from X1,X2 to X(2),X(3).
        FACTR=FACTR/S*(-LOG(TAU))*(1./(EMQ+EMH)**2-1./ECM_MAX**2)
C...CKM mixing top/bottom quark.
        IF(IQ.EQ.6)FACTR=FACTR*VCKM(3,3)**2
C...Higgs resonance.
        FACTR=FACTR*EMHWT
C...constant weight.
        FACTR=FACTR*WEIGHT
C...SM/MSSM couplings.
        IF (IHIGGS.EQ.0) THEN
          GQH(0)=(RMASS(5)/MW)**2/TWO
        ELSE
          G1     = (RMASS(5)/MW/COSB)**2/TWO
          GQH(1) = G1*SINA**2
          GQH(2) = G1*COSA**2
          GQH(3) = G1*SINB**2
          GQH(4) = GQH(3)+(RMASS(6)/MW/TANB)**2/TWO
        END IF
C...Matrix elements.
        DO IH = 0,4
          ME2(IH) = ZERO
        END DO
c
c g b  -> Q  H
c
        ID1 = 5
        IH=IHIGGS
        IF(IHIGGS.NE.0)IH=IHIGGS-1
        IF (IH.EQ.4) ID1 = 6
        ID2 = 201+IHIGGS
        SM   = RMASS(ID1)+RMASS(ID2)
        QPE  = SHAT-SM**2
        IF (QPE.GT.ZERO) THEN
          DM   = RMASS(ID1)-RMASS(ID2)
          QPE  = QPE*(SHAT-DM**2)/SHAT
        END IF
        PT2  = QPE*SN2TH
        IF (PT2.GT.PT2MIN) THEN
          SQPE = SQRT(QPE*SHAT)
          PF   = SQPE/SHAT
          T3   = (SQPE*COSTH - SHAT - SM*DM) / TWO
          U4   = - T3 - SHAT
          ME2(IH) = FACTR*PF * GQH(IH) *
     &     U4/SHAT/T3*(-U4+TWO*SM*DM/T3/U4*SHAT*PT2)
        ELSE
          ME2(IH) = ZERO
        END IF
      END IF
      HCS = ZERO
c
c     g b
      ID1 = 13
      ID2 = 5
      IF ((DISF(ID1,1).GT.EPS).AND.(DISF(ID2,2).GT.EPS)) THEN
        DIST = DISF(ID1,1)*DISF(ID2,2)*S*SHAT
        DO IH = 0,3
          HCS = HCS + DIST*ME2(IH)
          IF (GENEV.AND.HCS.GT.RCS) CALL HWHQCP(5,IHIGGS+201,2314,1,*9)
        END DO
        HCS = HCS + DIST*ME2(4)
        IF (GENEV.AND.HCS.GT.RCS) CALL HWHQCP(6,207,2314,1,*9)
      END IF
c       _
c     g b
      ID1 = 13
      ID2 = 11
      IF ((DISF(ID1,1).GT.EPS).AND.(DISF(ID2,2).GT.EPS)) THEN
        DIST = DISF(ID1,1)*DISF(ID2,2)*S*SHAT
        DO IH = 0,3
          HCS = HCS + DIST*ME2(IH)
          IF (GENEV.AND.HCS.GT.RCS) CALL HWHQCP(11,IHIGGS+201,3124,1,*9)
        END DO
        HCS = HCS + DIST*ME2(4)
        IF (GENEV.AND.HCS.GT.RCS) CALL HWHQCP(12,206,3124,1,*9)
      END IF
c
c     b g
      ID1 = 5
      ID2 = 13
      IF ((DISF(ID1,1).GT.EPS).AND.(DISF(ID2,2).GT.EPS)) THEN
        DIST = DISF(ID1,1)*DISF(ID2,2)*S*SHAT
        DO IH = 0,3
          HCS = HCS + DIST*ME2(IH)
          IF (GENEV.AND.HCS.GT.RCS) CALL HWHQCP(IHIGGS+201,5,4132,1,*9)
        END DO
        HCS = HCS + DIST*ME2(4)
        IF (GENEV.AND.HCS.GT.RCS) CALL HWHQCP(207,6,4132,1,*9)
      END IF
c     _
c     b g
      ID1 = 11
      ID2 = 13
      IF ((DISF(ID1,1).GT.EPS).AND.(DISF(ID2,2).GT.EPS)) THEN
        DIST = DISF(ID1,1)*DISF(ID2,2)*S*SHAT
        DO IH = 0,3
          HCS = HCS + DIST*ME2(IH)
          IF (GENEV.AND.HCS.GT.RCS) CALL HWHQCP(IHIGGS+201,11,2431,1,*9)
        END DO
        HCS = HCS + DIST*ME2(4)
        IF (GENEV.AND.HCS.GT.RCS) CALL HWHQCP(206,12,2431,1,*9)
      END IF
      EVWGT = HCS
      RETURN
C---GENERATE EVENT
    9 IDN(1)=ID1
      IDN(2)=ID2
      IDCMF=15
      CALL HWETWO
      IF (AZSPIN) THEN
C Calculate coefficients for constructing spin density matrices
C Set to zero for now
        CALL HWVZRO(7,GCOEF)
      END IF
  888 END
CDECK  ID>, HWHIBK.
*CMZ :-        -26/11/00  17.21.55  by  Bryan Webber
*-- Author :  Stefano Moretti
C-----------------------------------------------------------------------
C...Generate completely differential cross section (EVWGT) in the variables
C...X(I) with I=1,4 (see below) for the process IPROC=3350, as described
C...in the HERWIG 6 documentation file.
C...It includes interface to PDFs and takes into account color connections
C...among partons.
C
C...First release: 8-APR-1999 by Stefano Moretti
C
      SUBROUTINE HWHIBK
C-----------------------------------------------------------------------
C     ASSOCIATE PRODUCTION W+H- FROM QUARK FUSION (2HDM)
C-----------------------------------------------------------------------
      INCLUDE 'HERWIG62.INC'
      INTEGER I,J,IHEL
      DOUBLE PRECISION EMH,EMHWT,RMW,EMW
      DOUBLE PRECISION RMH01,RMH02,RMH03,RMH
      DOUBLE PRECISION X(4),XL(4),XU(4)
      DOUBLE PRECISION CT,ST
      DOUBLE PRECISION P1(0:3),P2(0:3),P3(0:3),P4(0:3)
      DOUBLE PRECISION ECM_MAX,ECM,SHAT,S,TAU
      DOUBLE PRECISION EMIN,PCM2,PCM,RCM2,RCM
      DOUBLE PRECISION M2,M2L,M2T
      DOUBLE PRECISION ALPHA,EMSC2
      DOUBLE PRECISION HWRGEN,HWUAEM
      DOUBLE PRECISION RNMIN,RNMAX,THETA_MIN,THETA_MAX
      DOUBLE PRECISION EPS,HCS,RCS,FACT,DIST
      DOUBLE PRECISION WEIGHT
      DOUBLE PRECISION VSAVE,HSAVE
      SAVE EMH,EMW,HCS,M2,M2L,M2T,FACT,S,CT
      LOGICAL HWRLOG
      EXTERNAL HWHIGM,HWRGEN,HWUAEM,HWH2BK,HWETWO,HWRLOG
      PARAMETER (EPS=1.D-9)
      EQUIVALENCE (RMW  ,RMASS(198))
      EQUIVALENCE (RMH01,RMASS(204)),
     &            (RMH02,RMASS(203)),
     &            (RMH03,RMASS(205)),
     &            (RMH  ,RMASS(206))
      IF(GENEV)THEN
        RCS=HCS*HWRGEN(0)
      ELSE
        HCS=0.
        EVWGT=0.
C...assign final state masses.
        EMH=RMH
        EMHWT=1.D0
C...energy at hadron level.
        ECM_MAX=PBEAM1+PBEAM2
        S=ECM_MAX*ECM_MAX
C...phase space variables.
C...X(1)=COS(THETA_CM),
C...X(2)=(1./SHAT-1./ECM_MAX**2)/(1./(EMW+EMH)**2-1./ECM_MAX**2),
C...X(3)=(LOG(TAU)-LOG(X1))/LOG(TAU),
C...X(4)=(THETA-THETA_MIN)/(THETA_MAX-THETA_MIN),
C...where THETA=ATAN((EMW*EMW-RMW*RMW)/RMW/GAMW);
C...phase space borders.
        XL(1)=-1.
        XU(1)=1.
        XL(2)=0.
        XU(2)=1.
        XL(3)=0.
        XU(3)=1.
        XL(4)=0.
        XU(4)=1.
C...single phase space point.
 100    CONTINUE
        WEIGHT=1.
        DO I=1,4
          X(I)=XL(I)+(XU(I)-XL(I))*HWRGEN(0)
          WEIGHT=WEIGHT*ABS(XU(I)-XL(I))
        END DO
C...resonant boson mass (limits to -10*W-widths to improve efficiency).
        RNMIN=RMW-10.*GAMW
        THETA_MIN=ATAN((RNMIN*RNMIN-RMW*RMW)/RMW/GAMW)
        RNMAX=ECM_MAX-EMH
        THETA_MAX=ATAN((RNMAX*RNMAX-RMW*RMW)/RMW/GAMW)
        EMW=SQRT((TAN(X(4)*(THETA_MAX-THETA_MIN)+THETA_MIN))
     &     *RMW*GAMW+RMW*RMW)
C...energy at parton level.
        ECM=SQRT(1./(X(2)*(1./(EMW+EMH)**2-1./ECM_MAX**2)
     &                                    +1./ECM_MAX**2))
        IF((EMH.LE.0.).OR.(EMH.GE.ECM))RETURN
        SHAT=ECM*ECM
        TAU=SHAT/S
C...momentum fractions X1 and X2.
        XX(1)=EXP(LOG(TAU)*(1.-X(3)))
        XX(2)=TAU/XX(1)
C...two particle kinematics.
        CT=X(1)
        IF(HWRLOG(HALF))THEN
          ST=+SQRT(1.-CT*CT)
        ELSE
          ST=-SQRT(1.-CT*CT)
        END IF
        RCM2=((SHAT-EMW*EMW-EMH*EMH)**2
     &      -(2.*EMW*EMH)**2)/(4.*SHAT)
        RCM=SQRT(RCM2)
        P3(0)=SQRT(RCM2+EMW*EMW)
        P3(1)=0.
        P3(2)=RCM*ST
        P3(3)=RCM*CT
        P4(0)=SQRT(RCM2+EMH*EMH)
        P4(1)=0.
        P4(2)=-RCM*ST
        P4(3)=-RCM*CT
C...incoming parton: massless.
        EMIN=0.
C...initial state momenta in the partonic CM.
        PCM2=((SHAT-EMIN*EMIN-EMIN*EMIN)**2
     &      -(2.*EMIN*EMIN)**2)/(4.*SHAT)
        PCM=SQRT(PCM2)
        P1(0)=SQRT(PCM2+EMIN*EMIN)
        P1(1)=0.
        P1(2)=0.
        P1(3)=PCM
        P2(0)=SQRT(PCM2+EMIN*EMIN)
        P2(1)=0.
        P2(2)=0.
        P2(3)=-PCM
C...color structured ME summed/averaged over final/initial spins and colors.
        CALL HWH2BK(P1,P2,P3,P4,EMW,EMH,M2,M2L,M2T)
        IF(M2.LE.0.)RETURN
C...charge conjugation.
        M2=M2*2.
        M2L=M2L*2.
        M2T=M2T*2.
C...constant factors: phi along beam and conversion GeV^2->nb.
        FACT=2.*PIFAC*GEV2NB
C...Jacobians from X1,X2 to X(2),X(3)
        FACT=FACT/S*(-LOG(TAU))*(1./(EMW+EMH)**2-1./ECM_MAX**2)
C...phase space Jacobians, pi's and flux.
        FACT=FACT/64./PIFAC/PIFAC*RCM/PCM
C...hard scale.
        EMSCA=RMW+RMH
C...EW couplings.
        EMSC2=EMSCA*EMSCA
        ALPHA=HWUAEM(EMSC2)
        FACT=FACT*(PIFAC*ALPHA/SWEIN/RMW/RMW/SQRT(2.))**2
C...Higgs resonance.
        FACT=FACT*EMHWT
C...vector boson resonance.
        FACT=FACT*(THETA_MAX-THETA_MIN)/PIFAC
C...constant weight.
        FACT=FACT*WEIGHT
      END IF
C...set up PDFs.
      HCS=0.
      CALL HWSGEN(.FALSE.)
      DO I=5,11,6
        IF(DISF(I,1).LT.EPS)THEN
          GOTO 200
        END IF
        IF(I.LE.6)J=I+6
        IF(I.GE.7)J=I-6
        IF(DISF(J,2).LT.EPS)THEN
          GOTO 200
        END IF
        DIST=DISF(I,1)*DISF(J,2)*S
C...no need to set up color connections.
        HCS=HCS+M2*DIST*FACT
        IF(GENEV.AND.HCS.GT.RCS)THEN
C...generate event.
          IDN(1)=I
          IDN(2)=J
          IDN(3)=NINT(198.+HWRGEN(0))
          IF(IDN(3).EQ.198)IDN(4)=207
          IF(IDN(3).EQ.199)IDN(4)=206
C...set up status and IDs: use HWETWO.
          COSTH=CT
          IDCMF=15
          ICO(1)=2
          ICO(2)=1
          ICO(3)=3
          ICO(4)=4
C...trick HWETWO in using off-shell V and H masses.
          VSAVE=RMASS(IDN(3))
          HSAVE=RMASS(IDN(4))
          RMASS(IDN(3))=EMW
          RMASS(IDN(4))=EMH
          CALL HWETWO
          RMASS(IDN(3))=VSAVE
          RMASS(IDN(4))=HSAVE
          IF(AZSPIN)THEN
C...set to zero the coefficients of the spin density matrices.
            CALL HWVZRO(7,GCOEF)
          END IF
C...calculates approximately polarized decay matrix of gauge boson.
          IF(IERROR.NE.0)RETURN
          IHEL=0
          IF(ICHRG(I)*ICHRG(IDN(3)).LT.0.D0)IHEL=1
          IF(M2L.LT.0.)M2L=0.
          IF(M2T.LT.0.)M2T=0.
          RHOHEP(2,NHEP-1)=M2L/M2
          RHOHEP(1,NHEP-1)=M2T/M2*(1-IHEL)
          RHOHEP(3,NHEP-1)=M2T/M2*(  IHEL)
          RETURN
        END IF
 200    CONTINUE
      END DO
      EVWGT=HCS
      RETURN
 999  END
CDECK  ID>, HWHIG1.
*CMZ :-        -23/08/94  13.22.29  by  Mike Seymour
*-- Author :    Ulrich Baur & Nigel Glover, adapted by Ian Knowles
C-----------------------------------------------------------------------
      FUNCTION HWHIG1(S,T,U,EH2,EQ2,I,J,K,I1,J1,K1)
C-----------------------------------------------------------------------
C     Basic matrix elements for Higgs + jet production; used in HWHIGA
C-----------------------------------------------------------------------
      IMPLICIT NONE
      DOUBLE COMPLEX HWHIG1,HWHIG2,HWHIG5,BI(4),CI(7),DI(3)
      DOUBLE PRECISION S,T,U,EH2,EQ2,S1,T1,U1,ONE,TWO,FOUR,HALF
      INTEGER I,J,K,I1,J1,K1
      COMMON/CINTS/BI,CI,DI
      PARAMETER (ONE =1.D0, TWO =2.D0, FOUR =4.D0, HALF =0.5D0)
C-----------------------------------------------------------------------
C     +++ helicity amplitude for: g+g --> g+H
C-----------------------------------------------------------------------
      S1=S-EH2
      T1=T-EH2
      U1=U-EH2
      HWHIG1=EQ2*FOUR*DSQRT(TWO*S*T*U)*(
     & -FOUR*(ONE/(U*T)+ONE/(U*U1)+ONE/(T*T1))
     & -FOUR*((TWO*S+T)*BI(K)/U1**2+(TWO*S+U)*BI(J)/T1**2)/S
     & -(S-FOUR*EQ2)*(S1*CI(I1)+(U-S)*CI(J1)+(T-S)*CI(K1))/(S*T*U)
     & -8.D0*EQ2*(CI(J1)/(T*T1)+CI(K1)/(U*U1))
     & +HALF*(S-FOUR*EQ2)*(S*T*DI(K)+U*S*DI(J)-U*T*DI(I))/(S*T*U)
     & +FOUR*EQ2*DI(I)/S
     & -TWO*(U*CI(K)+T*CI(J)+U1*CI(K1)+T1*CI(J1)-U*T*DI(I))/S**2 )
      RETURN
C-----------------------------------------------------------------------
      ENTRY HWHIG2(S,T,U,EH2,EQ2,I,J,K,I1,J1,K1)
C-----------------------------------------------------------------------
C     ++- helicity amplitude for: g+g --> g+H
C-----------------------------------------------------------------------
      S1=S-EH2
      T1=T-EH2
      U1=U-EH2
      HWHIG2=EQ2*FOUR*DSQRT(TWO*S*T*U)*(FOUR*EH2
     & +(EH2-FOUR*EQ2)*(S1*CI(4)+T1*CI(5)+U1*CI(6))
     & -HALF*(EH2-FOUR*EQ2)*(S*T*DI(3)+U*S*DI(2)+U*T*DI(1)) )/(S*T*U)
      RETURN
C-----------------------------------------------------------------------
      ENTRY HWHIG5(S,T,U,EH2,EQ2,I,J,K,I1,J1,K1)
C-----------------------------------------------------------------------
C     Amplitude for: q+qbar --> g+H
C-----------------------------------------------------------------------
      HWHIG5=DCMPLX(TWO+TWO*S/(S-EH2))*BI(I)+DCMPLX(FOUR*EQ2-U-T)*CI(K)
      RETURN
      END
CDECK  ID>, HWHIGA.
*CMZ :-        -23/08/94  13.22.29  by  Mike Seymour
*-- Author :    Ulrich Baur & Nigel Glover, adapted by Ian Knowles
C-----------------------------------------------------------------------
      SUBROUTINE HWHIGA(S,T,U,EMH2,WTQQ,WTQG,WTGQ,WTGG)
C-----------------------------------------------------------------------
C     Gives amplitudes squared for q-qbar, q(bar)-g and gg -> Higgs +jet
C     IAPHIG (set in HWIGIN)=0: zero mass approximation =1: exact result
C                           =2: infinite mass limit.
C     Only top loop included. A factor (alpha_s**3*alpha_W) is extracted
C-----------------------------------------------------------------------
      INCLUDE 'HERWIG62.INC'
      DOUBLE COMPLEX HWHIGB,HWHIGC,HWHIGD,HWHIG5,HWHIG1,HWHIG2,BI(4),
     & CI(7),DI(3),EPSI,TAMP(7)
      DOUBLE PRECISION S,T,U,EMH2,WTQQ,WTQG,WTGQ,WTGG,EMW2,RNGLU,RNQRK,
     & FLUXGG,FLUXGQ,FLUXQQ,EMQ2,TAMPI(7),TAMPR(7)
      INTEGER I
      LOGICAL NOMASS
      EXTERNAL HWHIGB,HWHIGC,HWHIGD,HWHIG5,HWHIG1,HWHIG2
      COMMON/SMALL/EPSI
      COMMON/CINTS/BI,CI,DI
      EPSI=DCMPLX(ZERO,-1.D-10)
      EMW2=RMASS(198)**2
C Spin and colour flux factors plus enhancement factor
      RNGLU=1./FLOAT(NCOLO**2-1)
      RNQRK=1./FLOAT(NCOLO)
      FLUXGG=.25*RNGLU**2*ENHANC(6)**2
      FLUXGQ=.25*RNGLU*RNQRK*ENHANC(6)**2
      FLUXQQ=.25*RNQRK**2*ENHANC(6)**2
      IF (IAPHIG.EQ.2) THEN
C Infinite mass limit in loops
         WTGG=2./3.*FLOAT(NCOLO*(NCOLO**2-1))
     &       *(EMH2**4+S**4+T**4+U**4)/(S*T*U*EMW2)*FLUXGG
         WTQQ= 16./9.*(U**2+T**2)/(S*EMW2)*FLUXQQ
         WTQG=-16./9.*(U**2+S**2)/(T*EMW2)*FLUXGQ
         WTGQ=-16./9.*(S**2+T**2)/(U*EMW2)*FLUXGQ
         RETURN
      ELSEIF (IAPHIG.EQ.1) THEN
C Exact result for loops
         NOMASS=.FALSE.
      ELSEIF (IAPHIG.EQ.0) THEN
C Small mass approximation in loops
         NOMASS=.TRUE.
      ELSE
         CALL HWWARN('HWHIGA',500,*999)
      ENDIF
C Include only top quark contribution
      EMQ2=RMASS(6)**2
      BI(1)=HWHIGB(NOMASS,S,ZERO,ZERO,EMQ2)
      BI(2)=HWHIGB(NOMASS,T,ZERO,ZERO,EMQ2)
      BI(3)=HWHIGB(NOMASS,U,ZERO,ZERO,EMQ2)
      BI(4)=HWHIGB(NOMASS,EMH2,ZERO,ZERO,EMQ2)
      BI(1)=BI(1)-BI(4)
      BI(2)=BI(2)-BI(4)
      BI(3)=BI(3)-BI(4)
      CI(1)=HWHIGC(NOMASS,S,ZERO,ZERO,EMQ2)
      CI(2)=HWHIGC(NOMASS,T,ZERO,ZERO,EMQ2)
      CI(3)=HWHIGC(NOMASS,U,ZERO,ZERO,EMQ2)
      CI(7)=HWHIGC(NOMASS,EMH2,ZERO,ZERO,EMQ2)
      CI(4)=(S*CI(1)-EMH2*CI(7))/(S-EMH2)
      CI(5)=(T*CI(2)-EMH2*CI(7))/(T-EMH2)
      CI(6)=(U*CI(3)-EMH2*CI(7))/(U-EMH2)
      DI(1)=HWHIGD(NOMASS,U,T,EMH2,EMQ2)
      DI(2)=HWHIGD(NOMASS,S,U,EMH2,EMQ2)
      DI(3)=HWHIGD(NOMASS,S,T,EMH2,EMQ2)
C Compute complex amplitudes
      TAMP(1)=HWHIG1(S,T,U,EMH2,EMQ2,1,2,3,4,5,6)
      TAMP(2)=HWHIG2(S,T,U,EMH2,EMQ2,1,2,3,0,0,0)
      TAMP(3)=HWHIG1(T,S,U,EMH2,EMQ2,2,1,3,5,4,6)
      TAMP(4)=HWHIG1(U,T,S,EMH2,EMQ2,3,2,1,6,5,4)
      TAMP(5)=HWHIG5(S,T,U,EMH2,EMQ2,1,0,4,0,0,0)
      TAMP(6)=HWHIG5(T,S,U,EMH2,EMQ2,2,0,5,0,0,0)
      TAMP(7)=HWHIG5(U,T,S,EMH2,EMQ2,3,0,6,0,0,0)
      DO 20 I=1,7
      TAMPI(I)= DREAL(TAMP(I))
  20  TAMPR(I)=-DIMAG(TAMP(I))
C Square and add prefactors
      WTGG=0.03125*FLOAT(NCOLO*(NCOLO**2-1))
     &    *(TAMPR(1)**2+TAMPI(1)**2+TAMPR(2)**2+TAMPI(2)**2
     &     +TAMPR(3)**2+TAMPI(3)**2+TAMPR(4)**2+TAMPI(4)**2)*FLUXGG
      WTQQ= 16.*(U**2+T**2)/(U+T)**2*EMQ2**2/(S*EMW2)
     &     *(TAMPR(5)**2+TAMPI(5)**2)*FLUXQQ
      WTQG=-16.*(U**2+S**2)/(U+S)**2*EMQ2**2/(T*EMW2)
     &     *(TAMPR(6)**2+TAMPI(6)**2)*FLUXGQ
      WTGQ=-16.*(S**2+T**2)/(S+T)**2*EMQ2**2/(U*EMW2)
     &     *(TAMPR(7)**2+TAMPI(7)**2)*FLUXGQ
 999  RETURN
      END
CDECK  ID>, HWHIGB.
*CMZ :-        -23/08/94  13.22.29  by  Mike Seymour
*-- Author :    Ulrich Baur & Nigel Glover, adapted by Ian Knowles
C-----------------------------------------------------------------------
      FUNCTION HWHIGB(NOMASS,S,T,EH2,EQ2)
C-----------------------------------------------------------------------
C     One loop scalar integrals, used in HWHIGJ.
C     If NOMASS=.TRUE. use a small mass approx. for particle in loop.
C-----------------------------------------------------------------------
      INCLUDE 'HERWIG62.INC'
      DOUBLE COMPLEX HWHIGB,HWHIGC,HWHIGD,HWUCI2,HWULI2,EPSI,PII,Z1,Z2
      DOUBLE PRECISION S,T,EQ2,EH2,RAT,COSH,DLS,DLT,DLM,RZ12,DL1,DL2,
     & ST,ROOT,XP,XM
      LOGICAL NOMASS
      EXTERNAL HWULI2,HWUCI2
      COMMON/SMALL/EPSI
C-----------------------------------------------------------------------
C     B_0(2p1.p2=S;mq,mq)
C-----------------------------------------------------------------------
      PII=DCMPLX(ZERO,PIFAC)
      IF (NOMASS) THEN
         RAT=DABS(S/EQ2)
         HWHIGB=-DLOG(RAT)+TWO
         IF (S.GT.ZERO) HWHIGB=HWHIGB+PII
      ELSE
         RAT=S/(FOUR*EQ2)
         IF (S.LT.ZERO) THEN
            HWHIGB=TWO-TWO*DSQRT(ONE-ONE/RAT)
     &                    *DLOG(DSQRT(-RAT)+DSQRT(ONE-RAT))
         ELSEIF (S.GT.ZERO.AND.RAT.LT.ONE) THEN
            HWHIGB=TWO-TWO*DSQRT(ONE/RAT-ONE)*DASIN(DSQRT(RAT))
         ELSEIF (RAT.GT.ONE) THEN
            HWHIGB=TWO-DSQRT(ONE-ONE/RAT)
     &                *(TWO*DLOG(DSQRT(RAT)+DSQRT(RAT-ONE))-PII)
         ENDIF
      ENDIF
      RETURN
C-----------------------------------------------------------------------
      ENTRY HWHIGC(NOMASS,S,T,EH2,EQ2)
C-----------------------------------------------------------------------
C     C_0(p{1,2}^2=0,2p1.p2=S;mq,mq,mq)
C-----------------------------------------------------------------------
      PII=DCMPLX(ZERO,PIFAC)
      IF (NOMASS) THEN
         RAT=DABS(S/EQ2)
         HWHIGC=HALF*DLOG(RAT)**2
         IF (S.GT.ZERO) HWHIGC=HWHIGC-HALF*PIFAC**2-PII*DLOG(RAT)
         HWHIGC=HWHIGC/S
      ELSE
         RAT=S/(FOUR*EQ2)
         IF (S.LT.ZERO) THEN
            HWHIGC=TWO*DLOG(DSQRT(-RAT)+DSQRT(ONE-RAT))**2/S
         ELSEIF (S.GT.ZERO.AND.RAT.LT.ONE) THEN
            HWHIGC=-TWO*(DASIN(DSQRT(RAT)))**2/S
         ELSEIF (RAT.GT.ONE) THEN
            COSH=DLOG(DSQRT(RAT)+DSQRT(RAT-ONE))
            HWHIGC=TWO*(COSH**2-PIFAC**2/FOUR-PII*COSH)/S
         ENDIF
      ENDIF
      RETURN
C-----------------------------------------------------------------------
      ENTRY HWHIGD(NOMASS,S,T,EH2,EQ2)
C-----------------------------------------------------------------------
C     D_0(p{1,2,3}^2=0,p4^2=EH2,2p1.p2=S,2p2.p3=T;mq,mq,mq,mq)
C-----------------------------------------------------------------------
      PII=DCMPLX(ZERO,PIFAC)
      IF (NOMASS) THEN
         DLS=DLOG(DABS(S/EQ2))
         DLT=DLOG(DABS(T/EQ2))
         DLM=DLOG(DABS(EH2/EQ2))
         IF (S.GE.ZERO.AND.T.LE.ZERO) THEN
            DL1=DLOG((EH2-T)/S)
            Z1=T/(T-EH2)
            Z2=(S-EH2)/S
            HWHIGD=DLS**2+DLT**2-DLM**2+DL1**2
     &            +TWO*(DLOG(S/(EH2-T))*DLOG(-T/S)+HWULI2(Z1)-HWULI2(Z2)
     &                 +PII*DLOG(EH2/(EH2-T)))
         ELSEIF (S.LT.ZERO.AND.T.LT.ZERO) THEN
            Z1=(S-EH2)/S
            Z2=(T-EH2)/T
            RZ12=ONE/(Z1*Z2)
            DL1=DLOG((T-EH2)/(S-EH2))
            DL2=DLOG(RZ12)
            HWHIGD=DLS**2+DLT**2-DLM**2+TWO*PIFAC**2/THREE
     &            +TWO*DLOG(S/(T-EH2))*DLOG(ONE/DREAL(Z2))
     &            +TWO*DLOG(T/(S-EH2))*DLOG(ONE/DREAL(Z1))
     &            -DL1**2-DL2**2-TWO*(HWULI2(Z1)+HWULI2(Z2))
     &            +TWO*PII*DLOG(RZ12**2*EH2/EQ2)
         ENDIF
         HWHIGD=HWHIGD/(S*T)
      ELSE
         ST=S*T
         ROOT=DSQRT(ST**2-FOUR*ST*EQ2*(S+T-EH2))
         XP=HALF*(ST+ROOT)/ST
         XM=1-XP
         HWHIGD=TWO/ROOT*(-HWUCI2(EQ2,S,XP)-HWUCI2(EQ2,T,XP)
     &         +HWUCI2(EQ2,EH2,XP)+DLOG(-XM/XP)
     &         *(LOG(EQ2+EPSI)-LOG(EQ2+EPSI-S*XP*XM)
     &          +LOG(EQ2+EPSI-EH2*XP*XM)-LOG(EQ2+EPSI-T*XP*XM)))
      ENDIF
      RETURN
      END
CDECK  ID>, HWHIGH.
*CMZ :-        -26/11/00  17.21.55  by  Bryan Webber
*-- Author :  Kosuke Odagiri & Stefano Moretti
C-----------------------------------------------------------------------
C...Generate completely differential cross section (EVWGT) in the variables
C...X(I) with I=1,3 (see below) for the processes IPROC=3315,3325,3335,3355,
C...3365,3375 as described in the HERWIG 6 documentation file.
C...It includes interface to PDFs and takes into account color connections
C...among partons.
C
C...First release:  16-AUG-1999 by Kosuke Odagiri
C...Last modified:  26-SEP-1999 by Stefano Moretti
C-----------------------------------------------------------------------
      SUBROUTINE HWHIGH
C-----------------------------------------------------------------------
C     DRELL-YAN 2 PARTON -> 2 HIGGS PAIR (2HDM)
C-----------------------------------------------------------------------
      INCLUDE 'HERWIG62.INC'
      DOUBLE PRECISION HWRGEN, HWUAEM, EPS, HCS, RCS, DIST, S, PF, QPE,
     & FACTR, SN2TH, MZ, MW, MNN(2,2), MCC(2), MCN(3), EMSC2, GW2, GZ2,
     & GHH(4), XWEIN, S2W, PT2MIN, ECM_MAX, X(3), XL(3),
     & XU(3), WEIGHT, ECM, SHAT, TAU, RMH1, RMH2, EMH1, EMH2,
     & EMHWT1, EMHWT2, EMHHWT
      INTEGER I, J, IQ, IQ1, IQ2, ID1, ID2, IH, JH, IH1, IH2
      EXTERNAL HWRGEN, HWUAEM
      SAVE HCS,MNN,MCC,MCN,EMHHWT,S,SHAT
      PARAMETER (EPS = 1.D-9)
      DOUBLE COMPLEX Z, GZ, A, D, E
      PARAMETER (Z = (0.D0,1.D0))
      EQUIVALENCE (MZ, RMASS(200)), (MW, RMASS(198))
C...generate event.
      IF (GENEV) THEN
        RCS = HCS*HWRGEN(0)
      ELSE
        HCS = ZERO
        EVWGT = ZERO
C...minimum transverse momentum.
        PTMIN = ZERO
        PT2MIN = PTMIN**2
C...energy at hadron level.
        ECM_MAX=PBEAM1+PBEAM2
        S=ECM_MAX*ECM_MAX
C...phase space variables.
C...X(1)=COS(THETA_CM),
C...X(2)=(1./SHAT-1./ECM_MAX**2)/(1./(EMH1+EMH2)**2-1./ECM_MAX**2),
C...X(3)=(LOG(TAU)-LOG(X1))/LOG(TAU),
C...phase space borders.
        XL(1)=-1.
        XU(1)=1.
        XL(2)=0.
        XU(2)=1.
        XL(3)=0.
        XU(3)=1.
C...single phase space point.
 100    CONTINUE
        WEIGHT=1.
        DO I=1,3
          X(I)=XL(I)+(XU(I)-XL(I))*HWRGEN(0)
          WEIGHT=WEIGHT*ABS(XU(I)-XL(I))
        END DO
C...final state masses.
        IF((IPROC.EQ.3365).OR.(IPROC.EQ.3375))THEN
          JH  = IHIGGS-1
          ID1 = 205
          ID2 = 202 + JH
        ELSE IF(IPROC.EQ.3355)THEN
          JH  = 4
          ID1 = 206
          ID2 = 207
        ELSE IF((IPROC.EQ.3315).OR.
     &          (IPROC.EQ.3325).OR.
     &          (IPROC.EQ.3335))THEN
          JH  = IHIGGS-1
          ID1 = 206
          ID2 = 202 + JH
        END IF
        RMH1=RMASS(ID1)
        RMH2=RMASS(ID2)
        EMH1=RMH1
        EMH2=RMH2
        EMHWT1=1.
        EMHWT2=1.
        EMHHWT=EMHWT1*EMHWT2
C...energy at parton level.
        ECM=SQRT(1./(X(2)*(1./(EMH1+EMH2)**2-1./ECM_MAX**2)
     &                                      +1./ECM_MAX**2))
        IF((EMH1.LE.0.).OR.(EMH1.GE.ECM))RETURN
        IF((EMH2.LE.0.).OR.(EMH2.GE.ECM))RETURN
        SHAT=ECM*ECM
        TAU=SHAT/S
C...momentum fractions X1 and X2.
        XX(1) = EXP(LOG(TAU)*(1.-X(3)))
        XX(2) = TAU/XX(1)
        COSTH = X(1)
        SN2TH = 0.25D0 - 0.25D0*COSTH**2
        EMSCA = EMH1+EMH2
        EMSC2 = EMSCA*EMSCA
        CALL    HWSGEN(.FALSE.)
        EVWGT = ZERO
        FACTR = GEV2NB*PIFAC*(HWUAEM(EMSC2))**2/SHAT/CAFAC*SN2TH/2.
C...Jacobians from X1,X2 to X(2),X(3).
        FACTR = FACTR/S*(-LOG(TAU))*(1./(EMH1+EMH2)**2-1./ECM_MAX**2)
C...constant weight.
        FACTR = FACTR*WEIGHT
C...couplings and propagators.
        XWEIN = TWO*SWEIN
        S2W   = DSQRT(XWEIN*(TWO-XWEIN))
        GZ    = S2W*(SHAT-MZ**2+Z*SHAT*GAMZ/MZ)/SHAT
        GZ2   = DREAL(DCONJG(GZ)*GZ)
        GW2   = ((ONE-MW**2/SHAT)**2+(GAMW/MW)**2)*XWEIN**2
C...labels: 1 = h0, 2 = H0, 3 = A0, 4 = H+, 5 = H-.
        GHH(1)= COSBMA
        GHH(2)= SINBMA
        GHH(3)= ONE
        GHH(4)= ONE-XWEIN
C...set to zero all MEs.
        DO I=1,2
          MCC(I)=ZERO
          MCN(I)=ZERO
          DO J=1,2
            MNN(I,J)=ZERO
          END DO
        END DO
        MCN(3)=ZERO
C...start subprocesses.
        IF((IPROC.EQ.3365).OR.(IPROC.EQ.3375))THEN
c
c      _      o  o   o
c    q q  -> A  h / H
c
          DO IH = JH,JH
            QPE = SHAT-(EMH1+EMH2)**2
            IF (QPE.GT.ZERO) THEN
              PF = SQRT(QPE*(SHAT-(EMH1-EMH2)**2))/SHAT
              DO IQ = 1,2
                MNN(IH,IQ) =
     &          FACTR*PF**3*GHH(IH)**2*(LFCH(IQ)**2+RFCH(IQ)**2)/GZ2
              END DO
            ELSE
              CONTINUE
            END IF
          END DO
        ELSE IF(IPROC.EQ.3355)THEN
c
c      _      +  -
c    q q  -> H  H
c
          IH = JH
          QPE = SHAT-(EMH1+EMH2)**2
          IF (QPE.GT.ZERO) THEN
            PF = SQRT(QPE*(SHAT-(EMH1-EMH2)**2))/SHAT
            DO IQ = 1,2
              A = GHH(IH)/GZ
              D = QFCH(IQ)+A*LFCH(IQ)
              E = QFCH(IQ)+A*RFCH(IQ)
              MCC(IQ)=FACTR*PF**3*DREAL(DCONJG(D)*D+DCONJG(E)*E)
            END DO
          ELSE
            CONTINUE
          END IF
        ELSE IF((IPROC.EQ.3315).OR.
     &          (IPROC.EQ.3325).OR.
     &          (IPROC.EQ.3335))THEN
c
c      _      +-  o   o   o
c    q q' -> H   h / H / A
c
          DO IH = JH,JH
            QPE = SHAT-(EMH1+EMH2)**2
            IF (QPE.GT.ZERO) THEN
              PF = SQRT(QPE*(SHAT-(EMH1-EMH2)**2))/SHAT
              MCN(IH)=FACTR*PF**3/GW2*HALF*GHH(IH)**2
            ELSE
              CONTINUE
            END IF
          END DO
        END IF
      END IF
      HCS = 0.D0
C...start PDFs.
      DO 1 ID1 = 1, 12
       IF (DISF(ID1,1).LT.EPS) GOTO 1
       IF (ID1.GT.6) THEN
        ID2 = ID1 - 6
       ELSE
        ID2 = ID1 + 6
       END IF
       IQ  = ID1 - ((ID1-1)/2)*2
       IF (DISF(ID2,2).LT.EPS) GOTO 1
       DIST = DISF(ID1,1)*DISF(ID2,2)*S*SHAT
       IH1 = 205
       IH2 = 203
       HCS = HCS + DIST*EMHHWT*MNN(1,IQ)
       IF (GENEV.AND.HCS.GT.RCS) CALL HWHQCP(IH1,IH2,2134,1,*9)
       IH2 = 204
       HCS = HCS + DIST*EMHHWT*MNN(2,IQ)
       IF (GENEV.AND.HCS.GT.RCS) CALL HWHQCP(IH1,IH2,2134,2,*9)
       IH1 = 206
       IH2 = 207
       HCS = HCS + DIST*EMHHWT*MCC(IQ)
       IF (GENEV.AND.HCS.GT.RCS) CALL HWHQCP(IH1,IH2,2134,3,*9)
    1 CONTINUE
c      _     _       _     _
c     ud(+), ud(-), du(-), du(+)
c
      DO 2 IQ1 = 1, 3
      DO IQ2 = 1, 3
      IF(VCKM(IQ1,IQ2).GT.EPS) THEN
c      _
c     ud (+)
c
       ID1 = IQ1 * 2
       ID2 = IQ2 * 2 + 5
       IH1 = 206
       IF ((DISF(ID1,1).GT.EPS).AND.(DISF(ID2,2).GT.EPS)) THEN
        DIST = VCKM(IQ1,IQ2)*DISF(ID1,1)*DISF(ID2,2)*S*SHAT
        DO IH = 1,3
         IH2 = 202+IH
         HCS = HCS + DIST*EMHHWT*MCN(IH)
         IF (GENEV.AND.HCS.GT.RCS) CALL HWHQCP(IH1,IH2,2134,3+IH,*9)
        END DO
       END IF
c     _
c     du (+)
c
       ID1 = IQ2 * 2 + 5
       ID2 = IQ1 * 2
       IH1 = 206
       IF ((DISF(ID1,1).GT.EPS).AND.(DISF(ID2,2).GT.EPS)) THEN
        DIST = VCKM(IQ1,IQ2)*DISF(ID1,1)*DISF(ID2,2)*S*SHAT
        DO IH = 1,3
         IH2 = 202+IH
         HCS = HCS + DIST*EMHHWT*MCN(IH)
         IF (GENEV.AND.HCS.GT.RCS) CALL HWHQCP(IH1,IH2,2134,3+IH,*9)
        END DO
       END IF
c      _
c     du (-)
c
       ID1 = IQ2 * 2 - 1
       ID2 = IQ1 * 2 + 6
       IH1 = 207
       IF ((DISF(ID1,1).GT.EPS).AND.(DISF(ID2,2).GT.EPS)) THEN
        DIST = VCKM(IQ1,IQ2)*DISF(ID1,1)*DISF(ID2,2)*S*SHAT
        DO IH = 1,3
         IH2 = 202+IH
         HCS = HCS + DIST*EMHHWT*MCN(IH)
         IF (GENEV.AND.HCS.GT.RCS) CALL HWHQCP(IH1,IH2,2134,3+IH,*9)
        END DO
       END IF
c     _
c     ud (-)
c
       ID1 = IQ1 * 2 + 6
       ID2 = IQ2 * 2 - 1
       IH1 = 207
       IF ((DISF(ID1,1).GT.EPS).AND.(DISF(ID2,2).GT.EPS)) THEN
        DIST = VCKM(IQ1,IQ2)*DISF(ID1,1)*DISF(ID2,2)*S*SHAT
        DO IH = 1,3
         IH2 = 202+IH
         HCS = HCS + DIST*EMHHWT*MCN(IH)
         IF (GENEV.AND.HCS.GT.RCS) CALL HWHQCP(IH1,IH2,2134,3+IH,*9)
        END DO
       END IF
      END IF
      END DO
    2 CONTINUE
      EVWGT = HCS
      RETURN
C...generate event.
    9 IDN(1)=ID1
      IDN(2)=ID2
      IDCMF=15
      CALL HWETWO
      IF (AZSPIN) THEN
        CALL HWVZRO(7,GCOEF)
      END IF
      END
CDECK  ID>, HWHIGJ.
*CMZ :-        -23/08/94  13.22.29  by  Mike Seymour
*-- Author :    Ian Knowles
C-----------------------------------------------------------------------
      SUBROUTINE HWHIGJ
C-----------------------------------------------------------------------
C     QCD Higgs plus jet production; mean EVWGT = Sigma in nb*Higgs B.R.
C     Adapted from the program of U. Baur and E.W.N. Glover
C     See: Nucl. Phys. B339 (1990) 38
C-----------------------------------------------------------------------
      INCLUDE 'HERWIG62.INC'
      DOUBLE PRECISION HWRGEN,HWRUNI,HWUALF,HWUAEM,EPS,RCS,EMH,EMHWT,
     & EMHTMP,BR,CV,CA,EMH2,ET,EJ,PT,EMT,EMAX,YMAX,YHINF,YHSUP,EXYH,
     & YMIN,YJINF,YJSUP,EXYJ,S,T,U,FACT,AMPQQ,AMPQG,AMPGQ,AMPGG,HCS,
     & FACTR
      INTEGER I,IDEC,ID1,ID2
      EXTERNAL HWRGEN,HWRUNI,HWUALF,HWUAEM
      SAVE HCS,AMPGG,AMPGQ,AMPQG,AMPQQ,EMH,FACT
      PARAMETER (EPS=1.D-9)
      IF (GENEV) THEN
         RCS=HCS*HWRGEN(0)
      ELSE
         EVWGT=0.
C Select a Higgs mass
         CALL HWHIGM(EMH,EMHWT)
         IF (EMH.LE.ZERO .OR. EMH.GE.PHEP(5,3)) RETURN
C Store branching ratio for specified Higgs deacy channel
         IDEC=MOD(IPROC,100)
         BR=1.
         IF (IDEC.EQ.0) THEN
            BR=0.
            DO 10 I=1,6
  10        BR=BR+BRHIG(I)
         ELSEIF (IDEC.EQ.10) THEN
            CALL HWDBOZ(198,ID1,ID2,CV,CA,BR,1)
            CALL HWDBOZ(199,ID1,ID2,CV,CA,BR,1)
            BR=BR*BRHIG(IDEC)
         ELSEIF (IDEC.EQ.11) THEN
            CALL HWDBOZ(200,ID1,ID2,CV,CA,BR,1)
            CALL HWDBOZ(200,ID1,ID2,CV,CA,BR,1)
            BR=BR*BRHIG(IDEC)
         ELSEIF (IDEC.LE.12) THEN
            BR=BRHIG(IDEC)
         ENDIF
C Select subprocess kinematics
         EMH2=EMH**2
         CALL HWRPOW(ET,EJ)
         PT=.5*ET
         EMT=SQRT(PT**2+EMH2)
         EMAX=0.5*(PHEP(5,3)+EMH2/PHEP(5,3))
         IF (EMAX.LE.EMT) RETURN
         YMAX=LOG((EMAX+SQRT(EMAX**2-EMT**2))/EMT)
         YHINF=MAX(YJMIN,-YMAX)
         YHSUP=MIN(YJMAX, YMAX)
         IF (YHSUP.LE.YHINF) RETURN
         EXYH=EXP(HWRUNI(1,YHINF,YHSUP))
         YMIN=LOG(PT/(PHEP(5,3)-EMT/EXYH))
         YMAX=LOG((PHEP(5,3)-EMT*EXYH)/PT)
         YJINF=MAX(YJMIN,YMIN)
         YJSUP=MIN(YJMAX,YMAX)
         IF (YJSUP.LE.YJINF) RETURN
         EXYJ=EXP(HWRUNI(2,YJINF,YJSUP))
         XX(1)=(EMT*EXYH+PT*EXYJ)/PHEP(5,3)
         XX(2)=(EMT/EXYH+PT/EXYJ)/PHEP(5,3)
         S=XX(1)*XX(2)*PHEP(5,3)**2
         T=EMH2-XX(1)*EMT*PHEP(5,3)/EXYH
         U=EMH2-S-T
         COSTH=(S+2.*T-EMH2)/(S-EMH2)
C Set subprocess scale
         EMSCA=EMT
         CALL HWSGEN(.FALSE.)
         FACT=GEV2NB*PT*EJ*(YHSUP-YHINF)*(YJSUP-YJINF)*BR*EMHWT
     &       *HWUALF(1,EMSCA)**3*HWUAEM(EMH2)/(SWEIN*16*PIFAC*S**2)
         CALL HWHIGA(S,T,U,EMH2,AMPQQ,AMPQG,AMPGQ,AMPGG)
      ENDIF
      HCS=0.
      DO 30 ID1=1,13
      IF (DISF(ID1,1).LT.EPS) GOTO 30
      FACTR=FACT*DISF(ID1,1)
      IF (ID1.LT.7) THEN
C Quark first:
         ID2=ID1+6
         HCS=HCS+FACTR*DISF(ID2,2)*AMPQQ
         IF (GENEV.AND.HCS.GT.RCS) CALL HWHQCP(13 ,201,2314,81,*99)
         ID2=13
         HCS=HCS+FACTR*DISF(ID2,2)*AMPQG
         IF (GENEV.AND.HCS.GT.RCS) CALL HWHQCP(ID1,201,3124,82,*99)
      ELSEIF (ID1.LT.13) THEN
C Antiquark first:
         ID2=ID1-6
         HCS=HCS+FACTR*DISF(ID2,2)*AMPQQ
         IF (GENEV.AND.HCS.GT.RCS) CALL HWHQCP(13 ,201,3124,83,*99)
         ID2=13
         HCS=HCS+FACTR*DISF(ID2,2)*AMPQG
         IF (GENEV.AND.HCS.GT.RCS) CALL HWHQCP(ID1,201,2314,84,*99)
      ELSE
C Gluon first:
         DO 20 ID2=1,12
         IF (DISF(ID2,2).LT.EPS) GOTO 20
         IF (ID2.LT.7) THEN
            HCS=HCS+FACTR*DISF(ID2,2)*AMPGQ
            IF (GENEV.AND.HCS.GT.RCS) CALL HWHQCP(ID2,201,2314,85,*99)
         ELSE
            HCS=HCS+FACTR*DISF(ID2,2)*AMPGQ
            IF (GENEV.AND.HCS.GT.RCS) CALL HWHQCP(ID2,201,3124,86,*99)
         ENDIF
  20     CONTINUE
         HCS=HCS+FACTR*DISF(13,2)*AMPGG
         IF (GENEV.AND.HCS.GT.RCS) CALL HWHQCP(13 ,201,2314,87,*99)
      ENDIF
  30  CONTINUE
      EVWGT=HCS
      RETURN
C Generate event
  99  IDN(1)=ID1
      IDN(2)=ID2
      IDCMF=15
C Trick HWETWO into using off-shell Higgs mass
      EMHTMP=RMASS(IDN(4))
      RMASS(IDN(4))=EMH
      CALL HWETWO
      RMASS(IDN(4))=EMHTMP
  999 END
CDECK  ID>, HWHIGM.
*CMZ :-        -02/05/91  11.17.14  by  Federico Carminati
*-- Author :    Mike Seymour
C-----------------------------------------------------------------------
      SUBROUTINE HWHIGM(EM,WEIGHT)
C-----------------------------------------------------------------------
C     CHOOSE HIGGS MASS:
C     IF (IOPHIG.EQ.0.OR.IOPHIG.EQ.2) THEN
C       CHOOSE HIGGS MASS ACCORDING TO
C       EM**4       /  (EM**2-EMH**2)**2 + (GAMH*EMH)**2
C     ELSE
C       CHOOSE HIGGS MASS ACCORDING TO
C       EMH * GAMH  /  (EM**2-EMH**2)**2 + (GAMH*EMH)**2
C     ENDIF
C     IF (IOPHIG.EQ.0.OR.IOPHIG.EQ.1) THEN
C       SUPPLY WEIGHT FACTOR TO YIELD
C       EM * GAM(EM)/  (EM**2-EMH**2)**2 + (GAM(EM)*EM)**2
C     ELSE
C       SUPPLY WEIGHT FACTOR TO YIELD
C       EM*(EMH/EM)**4 * GAM(EM)
C                   /  (EM**2-EMH**2)**2 + (GAM(EM)*EMH**2/EM)**2
C       AS SUGGESTED IN M.H.SEYMOUR, PHYS.LETT.B354(1995)409.
C     ENDIF
C-----------------------------------------------------------------------
      INCLUDE 'HERWIG62.INC'
      DOUBLE PRECISION HWRUNI,EM,WEIGHT,EMH,DIF,FUN,THETA,T,EMHLST,W0,
     & W1,EMM,GAMEM,T0,TMIN,TMAX,THEMIN,THEMAX,ZMIN,ZMAX,Z,F,GAMOFS
      INTEGER I
      EXTERNAL HWRUNI
      SAVE EMHLST,GAMEM,T0,TMIN,TMAX,THEMIN,THEMAX,ZMIN,ZMAX,W0,W1
      EQUIVALENCE (EMH,RMASS(201))
      DATA EMHLST/0D0/
C---SET UP INTEGRAND AND INDEFINITE INTEGRAL OF DISTRIBUTION
C   THETA=ATAN((EM**2-EMH**2)/(GAMH*EMH)); T=TAN(THETA); T0=EMH/GAMH
      DIF(T,T0)=(T+T0)**2
      FUN(THETA,T,T0)=T + (T0*T0-1)*THETA + T0*LOG(1+T*T)
C---SET UP CONSTANTS
      IF (EMH.NE.EMHLST .OR. FSTWGT) THEN
        EMHLST=EMH
        GAMEM=GAMH*EMH
        T0=EMH/GAMH
        TMIN=(MAX(ONE*1E-10,EMH-GAMMAX*GAMH))**2/GAMEM-T0
        TMAX=(              EMH+GAMMAX*GAMH )**2/GAMEM-T0
        THEMIN=ATAN(TMIN)
        THEMAX=ATAN(TMAX)
        ZMIN=FUN(THEMIN,TMIN,T0)
        ZMAX=FUN(THEMAX,TMAX,T0)
        W0=(ZMAX-ZMIN) / PIFAC * GAMEM
        W1=(THEMAX-THEMIN) / PIFAC
      ENDIF
C---CHOOSE HIGGS MASS
      IF (IOPHIG.EQ.0.OR.IOPHIG.EQ.2) THEN
 1      EM=0
        WEIGHT=0
        Z=HWRUNI(1,ZMIN,ZMAX)
C---SOLVE FUN(THETA,TAN(THETA))=Z BY NEWTON'S METHOD
        THETA=MAX(THEMIN, MIN(THEMAX, Z/T0**2 ))
        I=1
        F=0
 10     IF (I.LE.20 .AND. ABS(1-F/Z).GT.1E-4) THEN
          I=I+1
          IF (2*ABS(THETA).GT.PIFAC) CALL HWWARN('HWHIGM',51,*999)
          T=TAN(THETA)
          F=FUN(THETA,T,T0)
          THETA=THETA-(F-Z)/DIF(T,T0)
          GOTO 10
        ENDIF
        IF (I.GT.20) CALL HWWARN('HWHIGM',1,*999)
      ELSE
        THETA=HWRUNI(0,THEMIN,THEMAX)
      ENDIF
      EM=SQRT(GAMEM*(T0+TAN(THETA)))
C---NOW CALCULATE WEIGHT FACTOR FOR NON-CONSTANT HIGGS WIDTH
      GAMOFS=EM
      CALL HWDHIG(GAMOFS)
      IF (IOPHIG.EQ.0) THEN
        WEIGHT=W0*GAMOFS*EM /EM**4 *((EM**2-EMH**2)**2 + GAMEM**2)
     &                             /((EM**2-EMH**2)**2 +(GAMOFS*EM)**2)
      ELSEIF (IOPHIG.EQ.1) THEN
        WEIGHT=W1*GAMOFS*EM /GAMEM *((EM**2-EMH**2)**2 + GAMEM**2)
     &                             /((EM**2-EMH**2)**2 +(GAMOFS*EM)**2)
      ELSEIF (IOPHIG.EQ.2) THEN
        EMM=EM*(EMH/EM)**4
        WEIGHT=W0*GAMOFS*EMM/EM**4 *((EM**2-EMH**2)**2 + GAMEM**2)
     &                             /((EM**2-EMH**2)**2 +(GAMOFS*EMM)**2)
      ELSEIF (IOPHIG.EQ.3) THEN
        EMM=EM*(EMH/EM)**4
        WEIGHT=W1*GAMOFS*EMM/GAMEM *((EM**2-EMH**2)**2 + GAMEM**2)
     &                             /((EM**2-EMH**2)**2 +(GAMOFS*EMM)**2)
      ELSE
        CALL HWWARN('HWHIGM',500,*999)
      ENDIF
 999  END
CDECK  ID>, HWHIGQ.
*CMZ :-        -26/11/00  17.21.55  by  Bryan Webber
*-- Author :  Stefano Moretti
C-----------------------------------------------------------------------
C...Generate completely differential cross section (EVWGT) in the variables
C...X(I) with I=1,6 (see below) for the processes from IPROC=2500-2599 (SM),
C...IPROC=3811-3899, as described in the HERWIG 6 documentation file.
C...(For IPROC=3839,3869,3899 it describes MSSM charged Higgs production.)
C...It includes interface to PDFs and takes into account color connections
C...among partons.
C
C...First release: 8-APR-1999 by Stefano Moretti
C
      SUBROUTINE HWHIGQ
C-----------------------------------------------------------------------
C     PRODUCTION OF MSSM HIGGSES IN ASSOCIATION WITH HEAVY QUARK PAIRS
C-----------------------------------------------------------------------
      INCLUDE 'HERWIG62.INC'
      INTEGER JHIGGS
      INTEGER I,J,K,L,M,N
      INTEGER IHLP,IQ,JQ,IIQ,JJQ,IQMIN,IQMAX,IGG,IQQ
      INTEGER IDEC,NC,FLIP
      DOUBLE PRECISION BRHIGQ,EMQ,ENQ,EMQQ,EMH,EMHWT,EMW
      DOUBLE PRECISION T,TL,TLMIN,TLMAX,TTMIN,TTMAX,CTMP,RCM,RCM2
      DOUBLE PRECISION X(6),XL(6),XU(6)
      DOUBLE PRECISION Q4(0:3),Q34(0:3)
      DOUBLE PRECISION CT5,ST5,CT4,ST4,CF4,SF4,RQ52,RQ5,RQ42,RQ4,PQ4
      DOUBLE PRECISION P1(0:3),P2(0:3),P3(0:3),P4(0:3),P5(0:3)
      DOUBLE PRECISION ECM_MAX,ECM,SHAT,S,TAU
      DOUBLE PRECISION EMIN,EMIN1,EMIN2,PCM2,PCM
      DOUBLE PRECISION M2GG,M2GGPL,M2GGMN,M2QQ
      DOUBLE PRECISION GM,GRND,FACGPM(2)
      DOUBLE PRECISION GGQQHT,GGQQHU,GGQQHNP,QQQQH
      DOUBLE PRECISION ALPHA,ALPHAS,EMSC2
      DOUBLE PRECISION HWRGEN,HWUAEM,HWUALF
      DOUBLE PRECISION PHI,CPHI,SPHI,ROT(3,3)
      DOUBLE PRECISION VCOL,GCOL,QAUX(0:3)
      DOUBLE PRECISION EPS,HCS,RCS,FACT,DIST
      DOUBLE PRECISION WEIGHT
      SAVE HCS,M2QQ,M2GG,M2GGPL,M2GGMN,FACT,S
      LOGICAL HWRLOG
      EXTERNAL HWHIGM,HWRGEN,HWUAEM,HWUALF,HWHQCP,HWH2QH,HWETWO,HWRLOG
      PARAMETER (EPS=1.D-9)
      EQUIVALENCE (EMW,RMASS(198)),(NC,NCOLO)
C...assign Q/Q'-flavour.
      IF((IPROC.EQ.3839).OR.(IPROC.EQ.3869).OR.(IPROC.EQ.3899))THEN
        IQ=6
        JQ=11
        GM=HBAR/RLTIM(6)*RMASS(6)
      ELSE
        IF(IMSSM.EQ.0)THEN
          IQ=6
        ELSE
          IHLP=IPROC/3810+IPROC/3820+IPROC/3830
          IQ=IPROC-3800-IHLP*10
        END IF
        JQ=IQ+6
        GM=ZERO
      END IF
C...process event.
      IF(GENEV)THEN
        RCS=HCS*HWRGEN(0)
      ELSE
        EVWGT=0.
        HCS=0.
C...assign final state masses.
        EMQ=RMASS(IQ)
        ENQ=RMASS(JQ)
        EMH=RMASS(201+IHIGGS)
        EMHWT=1.
        IF(IMSSM.EQ.0)CALL HWHIGM(EMH,EMHWT)
C...energy at hadron level.
        ECM_MAX=PBEAM1+PBEAM2
        S=ECM_MAX*ECM_MAX
C...phase space variables.
C...X(1)=(EMQQ-EMQ-ENQ)/(ECM-EMQ-ENQ-EMH),
C...LIGHT QUARKS -> X(2)=(1/|T|-1/|TMAX|)/(1/|TMIN|-1/|TMAX|),
C...                X(3)=SIN(THETA4_CM_34),X(4)=COS(FI4_CM_34),
C...HEAVY QUARKS -> X(2)=COS(THETA5_CM),
C...                X(3)=COS(THETA4_CM_34),X(4)=FI4_CM_34,
C...X(5)=(1./SHAT-1./ECM_MAX**2)/(1./(EMQ+ENQ+EMH)**2-1./ECM_MAX**2),
C...X(6)=(LOG(TAU)-LOG(X1))/LOG(TAU);
C...phase space borders.
        XL(1)=0.
        XU(1)=1.
        IF((IQ.NE.6).AND.(IQ.NE.12).AND.
     &     (JQ.NE.6).AND.(JQ.NE.12))THEN
          XL(2)=0.
          XL(4)=-1.
          XU(4)=1.
        ELSE
          XL(2)=-1.
          XL(4)=0.
          XU(4)=2.*PIFAC
        END IF
        XU(2)=1.
        XL(3)=-1.
        XU(3)=1.
        XL(5)=0.
        XU(5)=1.
        XL(6)=0.
        XU(6)=1.
C...single phase space point.
 100    CONTINUE
        WEIGHT=1.
        DO I=1,6
          X(I)=XL(I)+(XU(I)-XL(I))*HWRGEN(0)
          WEIGHT=WEIGHT*ABS(XU(I)-XL(I))
        END DO
C...energy at parton level.
        ECM=SQRT(1./(X(5)*(1./(EMQ+ENQ+EMH)**2-1./ECM_MAX**2)
     &                                        +1./ECM_MAX**2))
        IF((EMH.LE.0.).OR.(EMH.GE.ECM))RETURN
        SHAT=ECM*ECM
        TAU=SHAT/S
C...momentum fractions X1 and X2.
        XX(1)=EXP(LOG(TAU)*(1.-X(6)))
        XX(2)=TAU/XX(1)
C...three particle kinematics.
        EMQQ=X(1)*(ECM-EMQ-ENQ-EMH)+EMQ+ENQ
C...incoming partons: all massless.
        EMIN=0.
        IF((IQ.NE.6).AND.(IQ.NE.12).AND.
     &     (JQ.NE.6).AND.(JQ.NE.12))THEN
          PCM2=((ECM*ECM-EMIN*EMIN-EMIN*EMIN)**2
     &        -(2.*EMIN*EMIN)**2)/(4.*ECM*ECM)
          PCM=SQRT(PCM2)
          RCM2=((ECM*ECM-EMQQ*EMQQ-EMH*EMH)**2
     &        -(2.*EMQQ*EMH)**2)/(4.*ECM*ECM)
          RCM=SQRT(RCM2)
          TTMAX=EMIN**2+EMQQ**2-0.5D0/ECM/ECM
     &        *((ECM*ECM+EMIN**2-EMIN**2)*(ECM*ECM+EMQQ**2-EMH**2)
     &    -SQRT((ECM*ECM-(EMIN+EMIN)**2)*(ECM*ECM-(EMIN-EMIN)**2))
     &    *SQRT((ECM*ECM-(EMQQ+EMH)**2)*(ECM*ECM-(EMQQ-EMH)**2)))
          TTMIN=EMIN**2+EMQQ**2-0.5D0/ECM/ECM
     &        *((ECM*ECM+EMIN**2-EMIN**2)*(ECM*ECM+EMQQ**2-EMH**2)
     &    +SQRT((ECM*ECM-(EMIN+EMIN)**2)*(ECM*ECM-(EMIN-EMIN)**2))
     &    *SQRT((ECM*ECM-(EMQQ+EMH)**2)*(ECM*ECM-(EMQQ-EMH)**2)))
          TLMIN=1./(ABS(TTMIN))
          TLMAX=1./(ABS(TTMAX))
          TL=X(2)*(TLMAX-TLMIN)+TLMIN
          T=1./ABS(TL)
          CTMP=-T-EMIN**2-EMQQ**2
     &       +2.*SQRT(PCM**2+EMIN**2)*SQRT(RCM**2+EMQQ**2)
          CT5=CTMP/2./PCM/RCM
          ST4=X(3)
          CT4=SQRT(1.-ST4*ST4)
          CF4=X(4)
          SF4=SQRT(1.-CF4*CF4)
        ELSE
          CT5=X(2)
          CT4=X(3)
          ST4=SQRT(1.-CT4*CT4)
          CF4=COS(X(4))
          SF4=SIN(X(4))
        END IF
        IF(HWRLOG(HALF))THEN
          ST5=+SQRT(1.-CT5*CT5)
        ELSE
          ST5=-SQRT(1.-CT5*CT5)
        END IF
        RQ52=((ECM*ECM-EMH*EMH-EMQQ*EMQQ)**2-(2.*EMH*EMQQ)**2)/
     &     (4.*ECM*ECM)
        IF(RQ52.LT.0.)THEN
          GOTO 100
        ELSE
          RQ5=SQRT(RQ52)
        ENDIF
        P5(1)=0.
        P5(2)=RQ5*ST5
        P5(3)=RQ5*CT5
        P5(0)=SQRT(RQ52+EMH*EMH)
        DO I=1,3
          Q34(I)=-P5(I)
        END DO
        Q34(0)=SQRT(RQ52+EMQQ*EMQQ)
        RQ42=((EMQQ*EMQQ-EMQ*EMQ-ENQ*ENQ)**2-(2.*EMQ*ENQ)**2)/
     &     (4.*EMQQ*EMQQ)
        IF(RQ42.LT.0.)THEN
          GOTO 100
        ELSE
          RQ4=SQRT(RQ42)
        ENDIF
        Q4(1)=RQ4*ST4*CF4
        Q4(2)=RQ4*ST4*SF4
        Q4(3)=RQ4*CT4
        Q4(0)=SQRT(RQ42+ENQ*ENQ)
        PQ4=0.
        DO I=1,3
          PQ4=PQ4+Q34(I)*Q4(I)
        END DO
        P4(0)=(Q34(0)*Q4(0)+PQ4)/EMQQ
        P3(0)=Q34(0)-P4(0)
        DO I=1,3
          P4(I)=Q4(I)+Q34(I)*(P4(0)+Q4(0))/(Q34(0)+EMQQ)
          P3(I)=Q34(I)-P4(I)
        END DO
C...initial state momenta in the partonic CM.
        PCM2=((SHAT-EMIN*EMIN-EMIN*EMIN)**2
     &         -(2.*EMIN*EMIN)**2)/(4.*SHAT)
        PCM=SQRT(PCM2)
        P1(0)=SQRT(PCM2+EMIN*EMIN)
        P1(1)=0.
        P1(2)=0.
        P1(3)=PCM
        P2(0)=SQRT(PCM2+EMIN*EMIN)
        P2(1)=0.
        P2(2)=0.
        P2(3)=-PCM
C...color structured ME summed/averaged over final/initial spins and colors.
        IGG=1
        IQQ=1
        IF((IPROC.EQ.3839).OR.(IPROC.EQ.3869).OR.(IPROC.EQ.3899))THEN
          IF(IPROC.EQ.3869)IQQ=0
          IF(IPROC.EQ.3899)IGG=0
          GRND=TANB
        ELSE
          IF(IMSSM.NE.0)THEN
            IF((IPROC/10-380).EQ.1)IQQ=0
            IF((IPROC/10-380).EQ.2)IGG=0
          END IF
          GRND=ONE
        END IF
        FACGPM(1) = ENQ       *GRND
        FACGPM(2) = EMQ*PARITY/GRND
        CALL HWH2QH(ECM,P1,P2,P3,P4,P5,EMQ,ENQ,EMH,FACGPM,GM,IGG,IQQ,
     &              GGQQHT,GGQQHU,GGQQHNP,QQQQH)
        M2GG=GGQQHNP/(8.*CFFAC)
        M2GGPL=GGQQHT/(8.*CFFAC)
        M2GGMN=GGQQHU/(8.*CFFAC)
        M2QQ=QQQQH*(1.-1./CAFAC**2)/4.
C...constant factors: phi along beam and conversion GeV^2->nb.
        FACT=2.*PIFAC*GEV2NB
C...Jacobians from X1,X2 to X(5),X(6)
        FACT=FACT/S*(-LOG(TAU))*(1./(EMQ+ENQ+EMH)**2-1./ECM_MAX**2)
C...phase space Jacobians, pi's and flux.
        FACT=FACT*RQ4*RQ5/PCM/32./(2.*PIFAC)**5
     &      *(ECM-EMQ-ENQ-EMH)
        IF((IQ.NE.6).AND.(IQ.NE.12).AND.
     &     (JQ.NE.6).AND.(JQ.NE.12))THEN
C...Jacobians from CT5 to X(2).
          FACT=FACT*(TLMAX-TLMIN)/2./PCM/RCM*T**2
          FACT=FACT*2.*ABS(ST4/CT4/SF4)
        ELSE
          CONTINUE
        END IF
C...EW and QCD couplings.
        EMSCA=EMQ+ENQ+EMH
        EMSC2=EMSCA*EMSCA
        ALPHA=HWUAEM(EMSC2)
        ALPHAS=HWUALF(1,EMSCA)
        FACT=FACT*4.*PIFAC*ALPHA/4./SWEIN/EMW/EMW
        FACT=FACT*16.*PIFAC**2*ALPHAS**2
        IF((IPROC.EQ.3839).OR.(IPROC.EQ.3869).OR.(IPROC.EQ.3899))THEN
C...enhancement factor for coupling+c.c.
          FACT=FACT*4.
        ELSE
C...enhancement factor for MSSM.
          FACT=FACT*ENHANC(IQ)*ENHANC(IQ)
        END IF
C...Higgs resonance.
        FACT=FACT*EMHWT
C...constant weight.
        FACT=FACT*WEIGHT
C...include BR of Higgs.
        IF(IMSSM.EQ.0)THEN
          IDEC=MOD(IPROC,100)
          IF (IDEC.GT.0.AND.IDEC.LE.12) FACT=FACT*BRHIG(IDEC)
          IF (IDEC.EQ.0) THEN
            BRHIGQ=0.D0
            DO I=1,6
              BRHIGQ=BRHIGQ+BRHIG(I)
            END DO
            FACT=FACT*BRHIGQ
          ENDIF
        END IF
      END IF
C...set up flavours in final state.
      IF((IPROC.EQ.3839).OR.(IPROC.EQ.3869).OR.(IPROC.EQ.3899))THEN
        IF(HWRGEN(0).LT.0.5)THEN
          JHIGGS=207-201
          IIQ=6
          JJQ=11
          FLIP=0
        ELSE
          JHIGGS=206-201
          IIQ=5
          JJQ=12
          FLIP=1
        END IF
      ELSE
        JHIGGS=IHIGGS
        IIQ=IQ
        JJQ=JQ
        FLIP=0
      END IF
C...set up PDFs.
      HCS=0.
      CALL HWSGEN(.FALSE.)
      IQMAX=13
      IQMIN=1
      IF((IPROC.EQ.3839).OR.(IPROC.EQ.3869).OR.(IPROC.EQ.3899))THEN
        IF(IPROC.EQ.3869)IQMIN=13
        IF(IPROC.EQ.3899)IQMAX=12
      ELSE
        IF(IMSSM.NE.0)THEN
          IF(IPROC.GT.3820)IQMAX=12
          IF(IPROC.GT.3810)IQMIN=13
          IF(IPROC.GT.3820)IQMIN=1
        END IF
      END IF
      DO I=IQMIN,IQMAX
        IF(DISF(I,1).LT.EPS)THEN
          GOTO 200
        END IF
        K=I/7
        L=+1-2*K
        IF(I.EQ.13)L=0
        J=I+L*6
        IF(DISF(J,2).LT.EPS)THEN
          GOTO 200
        END IF
        DIST=DISF(I,1)*DISF(J,2)*S
        IF(I.LT.13)THEN
C...set up color connections: qq-scattering.
          IF(J.EQ.I+6)THEN
            HCS=HCS+M2QQ*DIST*FACT
            IF(GENEV.AND.HCS.GT.RCS)CALL HWHQCP(IIQ,JJQ,2413, 4,*9)
          ELSE IF(I.EQ.J+6)THEN
            HCS=HCS+M2QQ*DIST*FACT
            IF(GENEV.AND.HCS.GT.RCS)CALL HWHQCP(JJQ,IIQ,3142,12,*9)
          END IF
        ELSE
C...set up color connections: gg-scattering.
          HCS=HCS
     &   +(M2GGPL-M2GG*M2GGPL/(M2GGPL+M2GGMN)/FLOAT(NC)**2)*DIST*FACT
          IF(GENEV.AND.HCS.GT.RCS)CALL HWHQCP(IIQ,JJQ,2413,27,*9)
          HCS=HCS
     &   +(M2GGMN-M2GG*M2GGMN/(M2GGPL+M2GGMN)/FLOAT(NC)**2)*DIST*FACT
          IF(GENEV.AND.HCS.GT.RCS)CALL HWHQCP(IIQ,JJQ,4123,28,*9)
        END IF
 200    CONTINUE
      END DO
      EVWGT=HCS
      RETURN
C...generate event.
    9 IDN(1)=I
      IDN(2)=J
      IDN(5)=201+JHIGGS
C...incoming partons: now massive.
      EMIN1=RMASS(IDN(1))
      EMIN2=RMASS(IDN(2))
C...redo initial state momenta in the partonic CM.
      PCM2=((SHAT-EMIN1*EMIN1-EMIN2*EMIN2)**2
     &       -(2.*EMIN1*EMIN2)**2)/(4.*SHAT)
      PCM=SQRT(PCM2)
      P1(0)=SQRT(PCM2+EMIN1*EMIN1)
      P1(1)=0.
      P1(2)=0.
      P1(3)=PCM
      P2(0)=SQRT(PCM2+EMIN2*EMIN2)
      P2(1)=0.
      P2(2)=0.
      P2(3)=-PCM
C...randomly rotate final state momenta around beam axis.
      PHI=2.*PIFAC*HWRGEN(0)
      CPHI=COS(PHI)
      SPHI=SIN(PHI)
      ROT(1,1)=+CPHI
      ROT(1,2)=+SPHI
      ROT(1,3)=0.
      ROT(2,1)=-SPHI
      ROT(2,2)=+CPHI
      ROT(2,3)=0.
      ROT(3,1)=0.
      ROT(3,2)=0.
      ROT(3,3)=1.
      DO L=1,3
        DO M=1,3
          QAUX(M)=0.
          DO N=1,3
            IF(L.EQ.1)QAUX(M)=QAUX(M)+ROT(M,N)*P3(N)
            IF(L.EQ.2)QAUX(M)=QAUX(M)+ROT(M,N)*P4(N)
            IF(L.EQ.3)QAUX(M)=QAUX(M)+ROT(M,N)*P5(N)
          END DO
        END DO
        DO M=1,3
          IF(L.EQ.1)P3(M)=QAUX(M)
          IF(L.EQ.2)P4(M)=QAUX(M)
          IF(L.EQ.3)P5(M)=QAUX(M)
        END DO
      END DO
C...use HWETWO only to set up status and IDs of quarks.
      COSTH=0.
      IDCMF=15
      CALL HWETWO
C...do real incoming, outgoing momenta in the lab frame.
      VCOL=(XX(1)-XX(2))/(XX(1)+XX(2))
      GCOL=(XX(1)+XX(2))/2./SQRT(XX(1)*XX(2))
      DO M=NHEP-4,NHEP+1
        IF(M.EQ.NHEP-2)GO TO 888
        DO N=0,3
          IF(M.EQ.NHEP-4)QAUX(N)=P1(N)
          IF(M.EQ.NHEP-3)QAUX(N)=P2(N)
          IF(M.EQ.NHEP-1)QAUX(N)=P3(N)*(1-FLIP)+P4(N)*FLIP
          IF(M.EQ.NHEP  )QAUX(N)=P4(N)*(1-FLIP)+P3(N)*FLIP
          IF(M.EQ.NHEP+1)QAUX(N)=P5(N)
        END DO
C...perform boost.
        PHEP(4,M)=GCOL*(QAUX(0)+VCOL*QAUX(3))
        PHEP(3,M)=GCOL*(QAUX(3)+VCOL*QAUX(0))
        PHEP(2,M)=QAUX(2)
        PHEP(1,M)=QAUX(1)
 888    CONTINUE
      END DO
C...needs to set all final state masses.
      PHEP(5,NHEP-1)=SQRT(ABS(PHEP(4,NHEP-1)**2
     &                       -PHEP(3,NHEP-1)**2
     &                       -PHEP(2,NHEP-1)**2
     &                       -PHEP(1,NHEP-1)**2))
      PHEP(5,NHEP  )=SQRT(ABS(PHEP(4,NHEP  )**2
     &                       -PHEP(3,NHEP  )**2
     &                       -PHEP(2,NHEP  )**2
     &                       -PHEP(1,NHEP  )**2))
      PHEP(5,NHEP+1)=SQRT(ABS(PHEP(4,NHEP+1)**2
     &                       -PHEP(3,NHEP+1)**2
     &                       -PHEP(2,NHEP+1)**2
     &                       -PHEP(1,NHEP+1)**2))
C...sets CMF.
      DO I=1,4
        PHEP(I,NHEP-2)=PHEP(I,NHEP-4)+PHEP(I,NHEP-3)
      END DO
      PHEP(5,NHEP-2)=SQRT(ABS(PHEP(4,NHEP-2)**2
     &                       -PHEP(3,NHEP-2)**2
     &                       -PHEP(2,NHEP-2)**2
     &                       -PHEP(1,NHEP-2)**2))
C...status and IDs for Higgs.
      ISTHEP(NHEP+1)=114
      IDHW(NHEP+1)=IDN(5)
      IDHEP(NHEP+1)=IDPDG(IDN(5))
C...Higgs colour (self-)connections.
      JMOHEP(1,NHEP+1)=NHEP-2
      JMOHEP(2,NHEP+1)=NHEP+1
      JDAHEP(2,NHEP+1)=NHEP+1
      JDAHEP(2,NHEP-2)=NHEP+1
      NHEP=NHEP+1
      IF(AZSPIN)THEN
C...set to zero the coefficients of the spin density matrices.
        CALL HWVZRO(7,GCOEF)
      END IF
  999 END
C-----------------------------------------------------------------------
CDECK  ID>, HWHIGS.
*CMZ :-        -02/04/98  14.52.22  by  Mike Seymour
*-- Author :    Mike Seymour
*-- Modified:   Stefano Moretti 04/05/98
C-----------------------------------------------------------------------
      SUBROUTINE HWHIGS
C-----------------------------------------------------------------------
C     HIGGS PRODUCTION VIA GLUON OR QUARK FUSION
C     MEAN EVWGT = HIGGS PRODN C-S * BRANCHING FRACTION IN NB
C-----------------------------------------------------------------------
      INCLUDE 'HERWIG62.INC'
      DOUBLE PRECISION HWUALF,HWHIGT,HWRGEN,HWUSQR,HWUAEM,BRHIGQ,EMH,
     & CSFAC(13),EVSUM(13),EMFAC,CV,CA,BR,RWGT,E1,E2,EMQ,GFACTR
      INTEGER IDEC,I,J,ID1,ID2
      EXTERNAL HWUALF,HWHIGT,HWRGEN,HWUSQR,HWUAEM
      SAVE CSFAC,BR,EVSUM
      IF (GENEV) THEN
        RWGT=HWRGEN(0)*EVSUM(13)
        IDN(1)=1
        DO 10 I=1,12
 10       IF (RWGT.GT.EVSUM(I)) IDN(1)=I+1
        IDN(2)=13
        IF (IDN(1).LE.12) IDN(2)=IDN(1)-6
        IF (IDN(1).LE. 6) IDN(2)=IDN(1)+6
        IDCMF=201+IHIGGS
        CALL HWEONE
      ELSE
        EVWGT=0.
        EMH=RMASS(201+IHIGGS)
        EMFAC=1.D0
        IF(IMSSM.EQ.0)CALL HWHIGM(EMH,EMFAC)
        IF (EMH.LE.0 .OR. EMH.GE.PHEP(5,3)) RETURN
        EMSCA=EMH
        IF (EMSCA.NE.EMLST) THEN
          EMLST=EMH
          XXMIN=(EMH/PHEP(5,3))**2
          XLMIN=LOG(XXMIN)
          GFACTR=GEV2NB*HWUAEM(EMH**2)/(288.*SWEIN*RMASS(198)**2)
          DO 20 I=1,13
            EMQ=RMASS(I)
            IF (I.EQ.13) THEN
              CSFAC(I)=-GFACTR*HWHIGT(  EMH)*XLMIN
     &                        *HWUALF(1,EMH)**2*EMFAC
            ELSEIF (I.GT.6) THEN
              CSFAC(I)=CSFAC(I-6)
            ELSEIF (EMH.GT.2*EMQ) THEN
              CSFAC(I)=-GFACTR*96.*PIFAC**2 *(1-(2*EMQ/EMH)**2)
     &                *(EMQ/EMH)**2 *XLMIN *EMFAC*ENHANC(I)**2
            ELSE
              CSFAC(I)=0
            ENDIF
 20       CONTINUE
C  INCLUDE BRANCHING RATIO OF HIGGS
          IDEC=MOD(IPROC,100)
          BR=1
          IF(IMSSM.EQ.0)THEN
C SM case
            IF (IDEC.EQ.0) THEN
              BRHIGQ=0
              DO 30 I=1,6
 30             BRHIGQ=BRHIGQ+BRHIG(I)
              BR=BRHIGQ
            ELSEIF (IDEC.EQ.10) THEN
              CALL HWDBOZ(198,ID1,ID2,CV,CA,BR,1)
              CALL HWDBOZ(199,ID1,ID2,CV,CA,BR,1)
              BR=BR*BRHIG(IDEC)
            ELSEIF (IDEC.EQ.11) THEN
              CALL HWDBOZ(200,ID1,ID2,CV,CA,BR,1)
              CALL HWDBOZ(200,ID1,ID2,CV,CA,BR,1)
              BR=BR*BRHIG(IDEC)
            ELSEIF (IDEC.LE.12) THEN
              BR=BRHIG(IDEC)
            ENDIF
          ENDIF
        ENDIF
        CALL HWSGEN(.TRUE.)
        EVWGT=0
        E1=PHEP(4,MAX(1,JDAHEP(1,1)))
        E2=PHEP(4,MAX(2,JDAHEP(1,2)))
        DO 40 I=1,13
          EMQ=RMASS(I)
          IF (EMH.GT.2*EMQ) THEN
            J=13
            IF (I.LE.12) J=I-6
            IF (I.LE. 6) J=I+6
            IF (XX(1).LT.0.5*(1-EMQ/E1+HWUSQR(1-2*EMQ/E1)) .AND.
     &          XX(2).LT.0.5*(1-EMQ/E2+HWUSQR(1-2*EMQ/E2)))
     &          EVWGT=EVWGT+DISF(I,1)*DISF(J,2)*CSFAC(I)*BR
          ENDIF
          EVSUM(I)=EVWGT
 40     CONTINUE
      ENDIF
  999 END
CDECK  ID>, HWHIGT.
*CMZ :-        -02/04/98  15.00.39  by  Mike Seymour
*-- Author :    Mike Seymour
C-----------------------------------------------------------------------
      FUNCTION HWHIGT(EMH)
C-----------------------------------------------------------------------
C  CALCULATE MOD SQUARED I DEFINED AS IN BARGER & PHILLIPS p433
C  WARNING: THIS IS A FACTOR OF 3 GREATER THAN EHLQ'S ETA FUNCTION
C  PARITY=+1 FOR SCALAR AND -1 FOR PSEUDOSCALAR
C-----------------------------------------------------------------------
      INCLUDE 'HERWIG62.INC'
      DOUBLE PRECISION HWHIGT,RATIO,RAT2,EMH,FREAL,FIMAG,ETALOG,AIREAL,
     & AIIMAG
      INTEGER I,J,K,L
      IF (ABS(PARITY).NE.1) CALL HWWARN('HWHIGT',500,*999)
      AIREAL=0
      AIIMAG=0
C---CONTRIBUTION FROM QUARK LOOPS
      DO 100 I=1,NFLAV
        RATIO=RMASS(I)/EMH
        RAT2=RATIO**2
        IF     (RAT2.GT.0.25) THEN
          FREAL=-2.*ASIN(0.5/RATIO)**2
          FIMAG=0
        ELSEIF (RAT2.LT.0.25) THEN
          ETALOG=LOG( (0.5+SQRT(0.25-RAT2)) / (0.5-SQRT(0.25-RAT2)) )
          FREAL=0.5 * (ETALOG**2 - PIFAC**2)
          FIMAG=PIFAC * ETALOG
        ELSE
          FREAL=0.5 * (          - PIFAC**2)
          FIMAG=0
        ENDIF
        IF (PARITY.EQ.1) THEN
          AIREAL=AIREAL+3*RAT2*(2 + (4*RAT2-1)*FREAL)*ENHANC(I)
          AIIMAG=AIIMAG+3*RAT2*(    (4*RAT2-1)*FIMAG)*ENHANC(I)
        ELSE
          AIREAL=AIREAL-2*RAT2*(FREAL)*ENHANC(I)
          AIIMAG=AIIMAG-2*RAT2*(FIMAG)*ENHANC(I)
        ENDIF
 100  CONTINUE
C---CONTRIBUTION FROM SQUARK LOOPS
      DO 200 I=1,12
        J=I/7
        K=6*J+I
        L=K
        IF(K.GT.6)L=K-12
        RATIO=RMASS(L)/EMH
        RAT2=RATIO**2
        IF     (RAT2.GT.0.25) THEN
          FREAL=-2.*ASIN(0.5/RATIO)**2
          FIMAG=0
        ELSEIF (RAT2.LT.0.25) THEN
          ETALOG=LOG( (0.5+SQRT(0.25-RAT2)) / (0.5-SQRT(0.25-RAT2)) )
          FREAL=0.5 * (ETALOG**2 - PIFAC**2)
          FIMAG=PIFAC * ETALOG
        ELSE
          FREAL=0.5 * (          - PIFAC**2)
          FIMAG=0
        ENDIF
        IF (PARITY.EQ.1) THEN
          AIREAL=AIREAL-3*RAT2*(1 + 2*RAT2*FREAL)*SENHNC(K)
          AIIMAG=AIIMAG-3*RAT2*(    2*RAT2*FIMAG)*SENHNC(K)
        ENDIF
 200  CONTINUE
C---FUNCTION RETURNS MOD-SQUARED OF SUM
      HWHIGT=AIREAL**2 + AIIMAG**2
 999  END
CDECK  ID>, HWHIGV.
*CMZ :-        -26/11/00  17.21.55  by  Bryan Webber
*-- Author :  Stefano Moretti
C-----------------------------------------------------------------------
C...Generate completely differential cross section (EVWGT) in the variables
C...X(I) with I=1,4 (see below) for the processes of ther series
C...IPROC=2600,2700 as described in the HERWIG 6 documentation file.
C...It includes interface to PDFs and takes into account color connections
C...among partons.
C
C...First release: 8-APR-1999 by Stefano Moretti
C
      SUBROUTINE HWHIGV
C-----------------------------------------------------------------------
C     MSSM NEUTRAL HIGGS PRODUCTION IN ASSOCIATION WITH GAUGE BOSON
C-----------------------------------------------------------------------
      INCLUDE 'HERWIG62.INC'
      INTEGER I,J,K,L,M,N
      INTEGER IV,IDEC
      DOUBLE PRECISION BRHIGQ,EMH,EMHWT,EMV,RMV,GAMV,RMH
      DOUBLE PRECISION X(4),XL(4),XU(4)
      DOUBLE PRECISION CT,ST,CCT
      DOUBLE PRECISION P1(0:3),P2(0:3),P3(0:3),P4(0:3)
      DOUBLE PRECISION ECM_MAX,ECM,SHAT,S,TAU
      DOUBLE PRECISION EMIN,PCM2,PCM,RCM2,RCM
      DOUBLE PRECISION QQV(12,12),C4W,VQ(12),AQ(12)
      DOUBLE PRECISION M2,M2L,M2T
      DOUBLE PRECISION ALPHA,EMSC2
      DOUBLE PRECISION HWRGEN,HWUAEM
      DOUBLE PRECISION RNMIN,RNMAX,THETA_MIN,THETA_MAX
      DOUBLE PRECISION EPS,HCS,RCS,FACT,DIST
      DOUBLE PRECISION WEIGHT
      DOUBLE PRECISION VSAVE,HSAVE,CFT,QR,QL
      SAVE EMH,EMV,HCS,M2,M2L,M2T,FACT,QQV,S,CT
      LOGICAL HWRLOG
      EXTERNAL HWHIGM,HWRGEN,HWUAEM,HWH2VH,HWETWO,HWRLOG
      PARAMETER (EPS=1.D-9)
      IF(IPRO.EQ.26)IV=0
      IF(IPRO.EQ.27)IV=1
      IF(GENEV)THEN
        RCS=HCS*HWRGEN(0)
      ELSE
        HCS=0.
        EVWGT=0.
C...assign final state masses.
        RMV=RMASS(198+2*IV)
        RMH=RMASS(201+IHIGGS)
        IF(IV.EQ.0)GAMV=GAMW
        IF(IV.EQ.1)GAMV=GAMZ
        EMH=RMH
        EMHWT=1.D0
        IF(IMSSM.EQ.0)CALL HWHIGM(EMH,EMHWT)
C...energy at hadron level.
        ECM_MAX=PBEAM1+PBEAM2
        S=ECM_MAX*ECM_MAX
C...phase space variables.
C...X(1)=COS(THETA_CM),
C...X(2)=(1./SHAT-1./ECM_MAX**2)/(1./(EMV+EMH)**2-1./ECM_MAX**2),
C...X(3)=(LOG(TAU)-LOG(X1))/LOG(TAU),
C...X(4)=(THETA-THETA_MIN)/(THETA_MAX-THETA_MIN),
C...where THETA=ATAN((EMV*EMV-RMV*RMV)/RMV/GAMV);
C...phase space borders.
        XL(1)=-1.
        XU(1)=1.
        XL(2)=0.
        XU(2)=1.
        XL(3)=0.
        XU(3)=1.
        XL(4)=0.
        XU(4)=1.
C...single phase space point.
 100    CONTINUE
        WEIGHT=1.
        DO I=1,4
          X(I)=XL(I)+(XU(I)-XL(I))*HWRGEN(0)
          WEIGHT=WEIGHT*ABS(XU(I)-XL(I))
        END DO
C...resonant boson mass.
        RNMIN=RMV-10.*GAMV
        THETA_MIN=ATAN((RNMIN*RNMIN-RMV*RMV)/RMV/GAMV)
        RNMAX=ECM_MAX-EMH
        THETA_MAX=ATAN((RNMAX*RNMAX-RMV*RMV)/RMV/GAMV)
        EMV=SQRT((TAN(X(4)*(THETA_MAX-THETA_MIN)+THETA_MIN))
     &     *RMV*GAMV+RMV*RMV)
C...energy at parton level.
        ECM=SQRT(1./(X(2)*(1./(EMV+EMH)**2-1./ECM_MAX**2)
     &                                    +1./ECM_MAX**2))
        IF((EMH.LE.0.).OR.(EMH.GE.ECM))RETURN
        SHAT=ECM*ECM
        TAU=SHAT/S
C...momentum fractions X1 and X2.
        XX(1)=EXP(LOG(TAU)*(1.-X(3)))
        XX(2)=TAU/XX(1)
C...two particle kinematics.
        CT=X(1)
        IF(HWRLOG(HALF))THEN
          ST=+SQRT(1.-CT*CT)
        ELSE
          ST=-SQRT(1.-CT*CT)
        END IF
C...single phase space point.
        RCM2=((SHAT-EMV*EMV-EMH*EMH)**2
     &      -(2.*EMV*EMH)**2)/(4.*SHAT)
        RCM=SQRT(RCM2)
        P3(0)=SQRT(RCM2+EMV*EMV)
        P3(1)=0.
        P3(2)=RCM*ST
        P3(3)=RCM*CT
        P4(0)=SQRT(RCM2+EMH*EMH)
        P4(1)=0.
        P4(2)=-RCM*ST
        P4(3)=-RCM*CT
C...incoming partons: massless.
        EMIN=0.
C...initial state momenta in the partonic CM.
        PCM2=((SHAT-EMIN*EMIN-EMIN*EMIN)**2
     &      -(2.*EMIN*EMIN)**2)/(4.*SHAT)
        PCM=SQRT(PCM2)
        P1(0)=SQRT(PCM2+EMIN*EMIN)
        P1(1)=0.
        P1(2)=0.
        P1(3)=PCM
        P2(0)=SQRT(PCM2+EMIN*EMIN)
        P2(1)=0.
        P2(2)=0.
        P2(3)=-PCM
C...color structured ME summed/averaged over final/initial spins and colors.
        CALL HWH2VH(P1,P2,P3,P4,EMV,M2,M2L,M2T)
        IF(M2.LE.0.)RETURN
C...vector-axial couplings of V to qq'/qq.
        IF(IV.EQ.0)THEN
          DO I=2,12,2
            K=I
            IF(I.GT.6)K=I-6
            M=K/2
            N=0
            DO J=1,11,2
              L=J
              IF(J.GT.6)L=J-6
              N=L-N
              QQV(I,J)=VCKM(M,N)**2
              QQV(J,I)=QQV(I,J)
              IF(N.EQ.3)N=0
            END DO
          END DO
        ELSE IF(IV.EQ.1)THEN
          C4W=(1.-SWEIN)*(1.-SWEIN)
          DO I=1,11,2
            VQ(I)=2.*VFCH(1,1)*SQRT(SWEIN)*SQRT(1.-SWEIN)
            AQ(I)=2.*AFCH(1,1)*SQRT(SWEIN)*SQRT(1.-SWEIN)
            J=I+6
            IF(J.GT.12)J=J-12
            QQV(I,J)=(VQ(I)*VQ(I)+AQ(I)*AQ(I))/C4W
          END DO
          DO I=2,12,2
            VQ(I)=2.*VFCH(2,1)*SQRT(SWEIN)*SQRT(1.-SWEIN)
            AQ(I)=2.*AFCH(2,1)*SQRT(SWEIN)*SQRT(1.-SWEIN)
            J=I+6
            IF(J.GT.12)J=J-12
            QQV(I,J)=(VQ(I)*VQ(I)+AQ(I)*AQ(I))/C4W
          END DO
        END IF
C...constant factors: phi along beam and conversion GeV^2->nb.
        FACT=2.*PIFAC*GEV2NB
C...Jacobians from X1,X2 to X(2),X(3)
        FACT=FACT/S*(-LOG(TAU))*(1./(EMV+EMH)**2-1./ECM_MAX**2)
C...phase space Jacobians, pi's and flux.
        FACT=FACT/64./PIFAC/PIFAC*RCM/PCM
C...EW couplings.
        EMSCA=RMV+RMH
        EMSC2=EMSCA*EMSCA
        ALPHA=HWUAEM(EMSC2)
        FACT=FACT*16.*PIFAC**2*ALPHA**2/SWEIN/SWEIN*RMV*RMV
C...enhancement factor for MSSM.
        FACT=FACT*ENHANC(10+IV)*ENHANC(10+IV)
C...Higgs resonance.
        FACT=FACT*EMHWT
C...vector boson resonance.
        FACT=FACT*(THETA_MAX-THETA_MIN)/PIFAC
C...constant weight.
        FACT=FACT*WEIGHT
C...include BR of Higgs.
        IF(IMSSM.EQ.0)THEN
          IDEC=MOD(IPROC,100)
          IF (IDEC.GT.0.AND.IDEC.LE.12) FACT=FACT*BRHIG(IDEC)
          IF (IDEC.EQ.0) THEN
            BRHIGQ=0.D0
            DO I=1,6
              BRHIGQ=BRHIGQ+BRHIG(I)
            END DO
            FACT=FACT*BRHIGQ
          ENDIF
        END IF
      END IF
C...set up PDFs.
      HCS=0.
      CALL HWSGEN(.FALSE.)
      DO I=1,12
        IF(DISF(I,1).LT.EPS)THEN
          GOTO 200
        END IF
        K=I/7
        L=+1-2*K
        IF(IV.EQ.0)THEN
          J=I+L*6+(-1)**(I+1)
        ELSE IF(IV.EQ.1)THEN
          J=I+L*6
        END IF
        IF(DISF(J,2).LT.EPS)THEN
          GOTO 200
        END IF
        DIST=DISF(I,1)*DISF(J,2)*S
C...QQV vector and axial couplings.
        DIST=DIST*QQV(I,J)
C...no need to set up color connections.
        HCS=HCS+M2*DIST*FACT
        IF(GENEV.AND.HCS.GT.RCS)THEN
C...generate event.
          IDN(1)=I
          IDN(2)=J
          IF(IV.EQ.0)
     &    IDN(3)=NINT(198.5-.1667*FLOAT(ICHRG(IDN(1))+ICHRG(IDN(2))))
          IF(IV.EQ.1)IDN(3)=200
          IDN(4)=201+IHIGGS
          COSTH=CT
          IDCMF=15
          ICO(1)=2
          ICO(2)=1
          ICO(3)=3
          ICO(4)=4
C...trick HWETWO in using off-shell V and H masses.
          VSAVE=RMASS(IDN(3))
          HSAVE=RMASS(IDN(4))
          RMASS(IDN(3))=EMV
          RMASS(IDN(4))=EMH
          CALL HWETWO
          RMASS(IDN(3))=VSAVE
          RMASS(IDN(4))=HSAVE
          IF(AZSPIN)THEN
C...set to zero the coefficients of the spin density matrices.
            CALL HWVZRO(7,GCOEF)
          END IF
C...calculates exactly polarized decay matrix of gauge boson.
          IF(IERROR.NE.0)RETURN
          CCT=CT
          IF(I.GT.6)CCT=-CT
          IF(M2L.LT.0.)M2L=0.
          IF(M2T.LT.0.)M2T=0.
          RHOHEP(2,NHEP-1)=M2L/M2
          CFT=(M2-M2L)/(1.+CCT**2)/2.
          IF(IV.EQ.0)THEN
            RHOHEP(1,NHEP-1)=CFT*(1.+CCT)**2/M2
            RHOHEP(3,NHEP-1)=CFT*(1.-CCT)**2/M2
          ELSE IF(IV.EQ.1)THEN
            QR=(VQ(I)-AQ(I))/2.
            QL=(VQ(I)+AQ(I))/2.
            RHOHEP(1,NHEP-1)=CFT*(QR**2*(1.-CCT)**2+QL**2*(1.+CCT)**2)
     &                      /(QR**2+QL**2)/M2
            RHOHEP(3,NHEP-1)=CFT*(QR**2*(1.+CCT)**2+QL**2*(1.-CCT)**2)
     &                    /(QR**2+QL**2)/M2
          END IF
        RETURN
        END IF
 200    CONTINUE
      END DO
      EVWGT=HCS
      RETURN
 999  END
CDECK  ID>, HWHIGW.
*CMZ :-        -26/04/91  14.55.44  by  Federico Carminati
*-- Author :    Mike Seymour
C-----------------------------------------------------------------------
      SUBROUTINE HWHIGW
C-----------------------------------------------------------------------
C     HIGGS PRODUCTION VIA W BOSON FUSION
C     MEAN EVWGT = HIGGS PRODN C-S * BRANCHING FRACTION IN NB
C-----------------------------------------------------------------------
      INCLUDE 'HERWIG62.INC'
      DOUBLE PRECISION HWULDO,HWRUNI,HWRGEN,HWUAEM,K1MAX2,K1MIN2,K12,
     & K2MAX2,K2MIN2,K22,EMW2,EMW,ROOTS,EMH2,EMH,ROOTS2,P1,PHI1,PHI2,
     & COSPHI,COSTH1,SINTH1,COSTH2,SINTH2,P2,WEIGHT,TAU,TAULN,CSFAC,
     & PSUM,PROB,Q1(5),Q2(5),H(5),A,B,C,TERM2,BRHIGQ,G1WW,G2WW,G1ZZ(6),
     & G2ZZ(6),AWW,AZZ(6),PWW,PZZ(6),EMZ,EMZ2,RSUM,GLUSQ,GRUSQ,GLDSQ,
     & GRDSQ,GLESQ,GRESQ,CW,CZ,EMFAC,CV,CA,BR,X2,ETA,P1JAC,FACTR,EH2
      INTEGER HWRINT,IDEC,I,ID1,ID2,IHAD
      LOGICAL EE,EP
      EXTERNAL HWULDO,HWRUNI,HWRGEN,HWUAEM,HWRINT
      SAVE EMW2,EMZ2,EE,GLUSQ,GRUSQ,GLDSQ,GRDSQ,GLESQ,GRESQ,G1ZZ,G2ZZ,
     & G1WW,G2WW,CW,CZ,PSUM,AWW,PWW,AZZ,PZZ,ROOTS,Q1,Q2,H,FACTR
      EQUIVALENCE (EMW,RMASS(198)),(EMZ,RMASS(200))
      IHAD=2
      IF (JDAHEP(1,IHAD).NE.0) IHAD=JDAHEP(1,IHAD)
      IF (FSTWGT) THEN
        EMW2=EMW**2
        EMZ2=EMZ**2
        GLUSQ=(VFCH(2,1)+AFCH(2,1))**2
        GRUSQ=(VFCH(2,1)-AFCH(2,1))**2
        GLDSQ=(VFCH(1,1)+AFCH(1,1))**2
        GRDSQ=(VFCH(1,1)-AFCH(1,1))**2
        GLESQ=(VFCH(11,1)+AFCH(11,1))**2
        GRESQ=(VFCH(11,1)-AFCH(11,1))**2
        G1ZZ(1)=GLUSQ*GLUSQ+GRUSQ*GRUSQ
        G2ZZ(1)=GLUSQ*GRUSQ+GRUSQ*GLUSQ
        G1ZZ(2)=GLUSQ*GLDSQ+GRUSQ*GRDSQ
        G2ZZ(2)=GLUSQ*GRDSQ+GRUSQ*GLDSQ
        G1ZZ(3)=GLDSQ*GLDSQ+GRDSQ*GRDSQ
        G2ZZ(3)=GLDSQ*GRDSQ+GRDSQ*GLDSQ
        G1ZZ(4)=GLESQ*GLESQ+GRESQ*GRESQ
        G2ZZ(4)=GLESQ*GRESQ+GRESQ*GLESQ
        G1ZZ(5)=GLESQ*GLUSQ+GRESQ*GRUSQ
        G2ZZ(5)=GLESQ*GRUSQ+GRESQ*GLUSQ
        G1ZZ(6)=GLESQ*GLDSQ+GRESQ*GRDSQ
        G2ZZ(6)=GLESQ*GRDSQ+GRESQ*GLDSQ
        G1WW=0.25
        G2WW=0
        FACTR=GEV2NB/(128.*PIFAC**3)
        EH2=RMASS(201)**2
        CW=256*(PIFAC*HWUAEM(EH2)/SWEIN)**3*EMW2
        CZ=256.*(PIFAC*HWUAEM(EH2))**3*EMZ2/(SWEIN*(1.-SWEIN))
      ENDIF
      EE=IPRO.LT.10
      EP=IPRO.GE.90
      IF (.NOT.GENEV) THEN
C---CHOOSE PARAMETERS
        EVWGT=0.
        CALL HWHIGM(EMH,EMFAC)
        IF (EMH.LE.ZERO .OR. EMH.GE.PHEP(5,3)) RETURN
        EMSCA=EMH
        IF (EE) THEN
          ROOTS=PHEP(5,3)
        ELSE
          TAU=(EMH/PHEP(5,3))**2
          TAULN=LOG(TAU)
          ROOTS=PHEP(5,3)*SQRT(EXP(HWRUNI(0,-1D-10,TAULN)))
        ENDIF
        EMH2=EMH**2
        ROOTS2=ROOTS**2
C---CHOOSE P1 ACCORDING TO (1-ETA)*(ETA-X2)/ETA**2
C   WHERE ETA=1-2P1/ROOTS AND X2=EMH**2/S
        X2=EMH2/ROOTS2
 1      ETA=X2**HWRGEN(0)
        IF (HWRGEN(0)*(1-EMH/ROOTS)**2*ETA.GT.(1-ETA)*(ETA-X2))GOTO 1
        P1JAC=0.5*ROOTS*ETA**2/((1-ETA)*(ETA-X2))
     &    *(-LOG(X2)*(1+X2)-2*(1-X2))
        P1=0.5*ROOTS*(1-ETA)
C---CHOOSE PHI1,2 UNIFORMLY
        PHI1=2*PIFAC*HWRGEN(0)
        PHI2=2*PIFAC*HWRGEN(0)
        COSPHI=COS(PHI2-PHI1)
C---CHOOSE K1^2, ON PROPAGATOR FACTOR
        K1MAX2=2*P1*ROOTS
        K1MIN2=0
        K12=EMW2-(EMW2+K1MAX2)*(EMW2+K1MIN2)/
     &           ((K1MAX2-K1MIN2)*HWRGEN(0)+(EMW2+K1MIN2))
C---CALCULATE COSTH1 FROM K1^2
        COSTH1=1+K12/(P1*ROOTS)
        SINTH1=SQRT(1-COSTH1**2)
C---CHOOSE K2^2
        K2MAX2=ROOTS*(ROOTS2-EMH2-2*ROOTS*P1)*(ROOTS-P1-P1*COSTH1)
     &        /((ROOTS-P1)**2-(P1*COSTH1)**2-(P1*SINTH1*COSPHI)**2)
        K2MIN2=0
        K22=EMW2-(EMW2+K2MAX2)*(EMW2+K2MIN2)/
     &           ((K2MAX2-K2MIN2)*HWRGEN(0)+(EMW2+K2MIN2))
C---CALCULATE A,B,C FACTORS, AND...
        A=-2*K22*P1*COSTH1 - ROOTS*(ROOTS2-EMH2-2*ROOTS*P1)
        B=-2*K22*P1*SINTH1*COSPHI
        C=+2*K22*P1 - 2*ROOTS*K22 - ROOTS*(ROOTS2-EMH2-2*ROOTS*P1)
C---SOLVE A*COSTH2 + B*SINTH2 + C = 0 FOR COSTH2
        TERM2=B**2 + A**2 - C**2
        IF (TERM2.LT.ZERO) RETURN
        TERM2=B*SQRT(TERM2)
        IF (A.GE.ZERO) RETURN
        COSTH2=(-A*C + TERM2)/(A**2+B**2)
        SINTH2=SQRT(1-COSTH2**2)
C---FINALLY, GET P2
        IF (COSTH2.EQ.-ONE) RETURN
        P2=-K22/(ROOTS*(1+COSTH2))
C---LOAD UP CMF MOMENTA
        Q1(1)=P1*SINTH1*COS(PHI1)
        Q1(2)=P1*SINTH1*SIN(PHI1)
        Q1(3)=P1*COSTH1
        Q1(4)=P1
        Q1(5)=0
        Q2(1)=P2*SINTH2*COS(PHI2)
        Q2(2)=P2*SINTH2*SIN(PHI2)
        Q2(3)=P2*COSTH2
        Q2(4)=P2
        Q2(5)=0
        H(1)=-Q1(1)-Q2(1)
        H(2)=-Q1(2)-Q2(2)
        H(3)=-Q1(3)-Q2(3)
        H(4)=-Q1(4)-Q2(4)+ROOTS
        CALL HWUMAS(H)
C---CALCULATE MATRIX ELEMENTS SQUARED
        AWW=ENHANC(10)**2 * CW*(ROOTS2/2*HWULDO(Q1,Q2)*G1WW
     &         +ROOTS2/4*P1*P2*(1+COSTH1)*(1-COSTH2)*G2WW)
        DO 10 I=1,6
          AZZ(I)=ENHANC(11)**2 * CZ*(ROOTS2/2*HWULDO(Q1,Q2)*G1ZZ(I)
     &               +ROOTS2/4*P1*P2*(1+COSTH1)*(1-COSTH2)*G2ZZ(I))
     &          *((K12-EMW2)/(K12-EMZ2)*(K22-EMW2)/(K22-EMZ2))**2
 10     CONTINUE
C---CALCULATE WEIGHT IN INTEGRAL
        WEIGHT=FACTR*P2*P1JAC/(ROOTS2**2*HWULDO(H,Q2))
     &              *(K1MAX2-K1MIN2)/((K1MAX2+EMW2)*(K1MIN2+EMW2))
     &              *(K2MAX2-K2MIN2)/((K2MAX2+EMW2)*(K2MIN2+EMW2))
     &              * EMFAC
        EMSCA=EMW
        XXMIN=(ROOTS/PHEP(5,3))**2
        XLMIN=LOG(XXMIN)
C---INCLUDE BRANCHING RATIO OF HIGGS
        IDEC=MOD(IPROC,100)
        IF (IDEC.GT.0.AND.IDEC.LE.12) WEIGHT=WEIGHT*BRHIG(IDEC)
        IF (IDEC.EQ.0) THEN
          BRHIGQ=0
          DO 20 I=1,6
 20         BRHIGQ=BRHIGQ+BRHIG(I)
          WEIGHT=WEIGHT*BRHIGQ
        ENDIF
        IF (IDEC.EQ.10) THEN
          CALL HWDBOZ(198,ID1,ID2,CV,CA,BR,1)
          CALL HWDBOZ(199,ID1,ID2,CV,CA,BR,1)
          WEIGHT=WEIGHT*BR
        ELSEIF (IDEC.EQ.11) THEN
          CALL HWDBOZ(200,ID1,ID2,CV,CA,BR,1)
          CALL HWDBOZ(200,ID1,ID2,CV,CA,BR,1)
          WEIGHT=WEIGHT*BR
        ENDIF
        IF (EE) THEN
          CSFAC=WEIGHT
          PSUM=AWW+AZZ(4)
          EVWGT=CSFAC*PSUM
        ELSEIF (EP) THEN
          CSFAC=-WEIGHT*TAULN
          XX(1)=ONE
          XX(2)=XXMIN
          CALL HWSFUN(XX(2),EMSCA,IDHW(IHAD),NSTRU,DISF(1,2),2)
          IF (IDHW(1).LE.126) THEN
            PWW=(DISF(2,2)+DISF(4,2)+DISF(7,2)+DISF( 9,2))*AWW
          ELSE
            PWW=(DISF(1,2)+DISF(3,2)+DISF(8,2)+DISF(10,2))*AWW
          ENDIF
          PZZ(5)=(DISF(2,2)+DISF(4,2)+DISF(8,2)+DISF(10,2))*AZZ(5)
          PZZ(6)=(DISF(1,2)+DISF(3,2)+DISF(7,2)+DISF( 9,2))*AZZ(6)
          PSUM=PWW+PZZ(5)+PZZ(6)
          EVWGT=CSFAC*PSUM
        ELSE
          CSFAC=WEIGHT*TAULN*XLMIN
          CALL HWSGEN(.TRUE.)
          PWW=((DISF(2,1)+DISF(4, 1)+DISF(7,1)+DISF(9,1))
     &        *(DISF(8,2)+DISF(10,2)+DISF(1,2)+DISF(3,2))
     &        +(DISF(8,1)+DISF(10,1)+DISF(1,1)+DISF(3,1))
     &        *(DISF(2,2)+DISF(4, 2)+DISF(7,2)+DISF(9,2)))
     &        *AWW
          PZZ(1)=((DISF(2,1)+DISF(4,1)+DISF(8,1)+DISF(10,1))
     &           *(DISF(2,2)+DISF(4,2)+DISF(8,2)+DISF(10,2)))
     &           *AZZ(1)
          PZZ(2)=((DISF(2,1)+DISF(4,1)+DISF(8,1)+DISF(10,1))
     &           *(DISF(1,2)+DISF(3,2)+DISF(7,2)+DISF(9, 2))
     &           +(DISF(1,1)+DISF(3,1)+DISF(7,1)+DISF(9, 1))
     &           *(DISF(2,2)+DISF(4,2)+DISF(8,2)+DISF(10,2)))
     &           *AZZ(2)
          PZZ(3)=((DISF(1,1)+DISF(3,1)+DISF(7,1)+DISF(9,1))
     &           *(DISF(1,2)+DISF(3,2)+DISF(7,2)+DISF(9,2)))
     &           *AZZ(3)
          PSUM=PWW+PZZ(1)+PZZ(2)+PZZ(3)
C---EVENT WEIGHT IS SUM OVER ALL COMBINATIONS
          EVWGT=CSFAC*PSUM
        ENDIF
      ELSE
C---GENERATE EVENT
C---CHOOSE EVENT TYPE
        RSUM=PSUM*HWRGEN(0)
C---ELECTRON BEAMS?
        IF (EE) THEN
          IDN(1)=IDHW(1)
          IDN(2)=IDHW(2)
C---WW FUSION?
          IF (RSUM.LT.AWW) THEN
            IDN(3)=IDN(1)+1
            IDN(4)=IDN(2)+1
C---ZZ FUSION?
          ELSE
            IDN(3)=IDN(1)
            IDN(4)=IDN(2)
          ENDIF
C---LEPTON-HADRON COLISION?
        ELSEIF (EP) THEN
C---WW FUSION?
          IDN(1)=IDHW(1)
          IF (RSUM.LT.PWW) THEN
 24         IDN(2)=HWRINT(1,8)
            IF (IDN(2).GE.5) IDN(2)=IDN(2)+2
            IF (ICHRG(IDN(1))*ICHRG(IDN(2)).GT.0) GOTO 24
            PROB=DISF(IDN(2),2)*AWW/PWW
            IF (HWRGEN(0).GT.PROB) GOTO 24
            IDN(3)=IDN(1)+1
            IF (HWRGEN(0).GT.SCABI) THEN
              IDN(4)= 4*INT((IDN(2)-1)/2)-IDN(2)+3
            ELSE
              IDN(4)=12*INT((IDN(2)-1)/6)-IDN(2)+5
            ENDIF
C---ZZ FUSION FROM U-TYPE QUARK?
          ELSEIF (RSUM.LT.PWW+PZZ(5)) THEN
 26         IDN(2)=2*HWRINT(1,4)
            IF (IDN(2).GE.5) IDN(2)=IDN(2)+2
            PROB=DISF(IDN(2),2)*AZZ(5)/PZZ(5)
            IF (HWRGEN(0).GT.PROB) GOTO 26
            IDN(3)=IDN(1)
            IDN(4)=IDN(2)
C---ZZ FUSION FROM D-TYPE QUARK?
          ELSE
 28         IDN(2)=2*HWRINT(1,4)-1
            IF (IDN(2).GE.5) IDN(2)=IDN(2)+2
            PROB=DISF(IDN(2),2)*AZZ(6)/PZZ(6)
            IF (HWRGEN(0).GT.PROB) GOTO 28
            IDN(3)=IDN(1)
            IDN(4)=IDN(2)
          ENDIF
C---HADRON BEAMS?
        ELSE
C---WW FUSION?
          IF (RSUM.LT.PWW) THEN
 31         DO 32 I=1,2
              IDN(I)=HWRINT(1,8)
              IF (IDN(I).GE.5) IDN(I)=IDN(I)+2
 32         CONTINUE
            IF (ICHRG(IDN(1))*ICHRG(IDN(2)).GT.0) GOTO 31
            PROB=DISF(IDN(1),1)*DISF(IDN(2),2)*AWW/PWW
            IF (HWRGEN(0).GT.PROB) GOTO 31
C---CHOOSE OUTGOING QUARKS
            DO 33 I=1,2
              IF (HWRGEN(0).GT.SCABI) THEN
                IDN(I+2)=4*INT((IDN(I)-1)/2)-IDN(I)+3
              ELSE
                IDN(I+2)=12*INT((IDN(I)-1)/6)-IDN(I)+5
              ENDIF
 33         CONTINUE
C---ZZ FUSION FROM U-TYPE QUARKS?
          ELSEIF (RSUM.LT.PWW+PZZ(1)) THEN
 41         DO 42 I=1,2
              IDN(I)=2*HWRINT(1,4)
              IF (IDN(I).GE.5) IDN(I)=IDN(I)+2
 42         CONTINUE
            PROB=DISF(IDN(1),1)*DISF(IDN(2),2)*AZZ(1)/PZZ(1)
            IF (HWRGEN(0).GT.PROB) GOTO 41
            IDN(3)=IDN(1)
            IDN(4)=IDN(2)
C---ZZ FUSION FROM D-TYPE QUARKS?
          ELSEIF (RSUM.LT.PWW+PZZ(1)+PZZ(3)) THEN
 51         DO 52 I=1,2
              IDN(I)=2*HWRINT(1,4)-1
              IF (IDN(I).GE.5) IDN(I)=IDN(I)+2
 52         CONTINUE
            PROB=DISF(IDN(1),1)*DISF(IDN(2),2)*AZZ(3)/PZZ(3)
            IF (HWRGEN(0).GT.PROB) GOTO 51
            IDN(3)=IDN(1)
            IDN(4)=IDN(2)
C---ZZ FUSION FROM UD-TYPE PAIRS?
          ELSE
 61         IF (HWRGEN(0).GT.HALF) THEN
              IDN(1)=2*HWRINT(1,4)-1
              IDN(2)=2*HWRINT(1,4)
            ELSE
              IDN(1)=2*HWRINT(1,4)
              IDN(2)=2*HWRINT(1,4)-1
            ENDIF
            DO 62 I=1,2
 62           IF (IDN(I).GE.5) IDN(I)=IDN(I)+2
            PROB=DISF(IDN(1),1)*DISF(IDN(2),2)*AZZ(2)/PZZ(2)
            IF (HWRGEN(0).GT.PROB) GOTO 61
            IDN(3)=IDN(1)
            IDN(4)=IDN(2)
          ENDIF
        ENDIF
C---NOW BOOST TO LAB, AND SET UP STATUS CODES etc
        IDCMF=15
C---INCOMING
        IF (.NOT.EE) CALL HWEONE
C---CMF POINTERS
        JDAHEP(1,NHEP)=NHEP+1
        JDAHEP(2,NHEP)=NHEP+3
        JMOHEP(1,NHEP+1)=NHEP
        JMOHEP(1,NHEP+2)=NHEP
        JMOHEP(1,NHEP+3)=NHEP
C---OUTGOING MOMENTA (GIVE QUARKS MASS NON-COVARIANTLY!)
        Q1(5)=RMASS(IDN(1))
        Q1(4)=SQRT(Q1(4)**2+Q1(5)**2)
        Q2(5)=RMASS(IDN(2))
        Q2(4)=SQRT(Q2(4)**2+Q2(5)**2)
        H(4)=-Q1(4)-Q2(4)+PHEP(5,NHEP)
        CALL HWUMAS(H)
        CALL HWULOB(PHEP(1,NHEP),Q1,PHEP(1,NHEP+1))
        CALL HWULOB(PHEP(1,NHEP),Q2,PHEP(1,NHEP+2))
        CALL HWULOB(PHEP(1,NHEP),H,PHEP(1,NHEP+3))
C---STATUS AND IDs
        ISTHEP(NHEP+1)=113
        ISTHEP(NHEP+2)=114
        ISTHEP(NHEP+3)=114
        IDHW(NHEP+1)=IDN(3)
        IDHEP(NHEP+1)=IDPDG(IDN(3))
        IDHW(NHEP+2)=IDN(4)
        IDHEP(NHEP+2)=IDPDG(IDN(4))
        IDHW(NHEP+3)=201
        IDHEP(NHEP+3)=IDPDG(201)
C---COLOUR LABELS
        JMOHEP(2,NHEP+1)=NHEP-2
        JMOHEP(2,NHEP+2)=NHEP-1
        JMOHEP(2,NHEP-1)=NHEP+2
        JMOHEP(2,NHEP-2)=NHEP+1
        JMOHEP(2,NHEP+3)=NHEP+3
        JDAHEP(2,NHEP+1)=NHEP-2
        JDAHEP(2,NHEP+2)=NHEP-1
        JDAHEP(2,NHEP-1)=NHEP+2
        JDAHEP(2,NHEP-2)=NHEP+1
        JDAHEP(2,NHEP+3)=NHEP+3
        NHEP=NHEP+3
      ENDIF
  999 END
CDECK  ID>, HWHIGY.
*CMZ :-        -26/04/91  13.37.37  by  Federico Carminati
*-- Author :    Mike Seymour
C-----------------------------------------------------------------------
      FUNCTION HWHIGY(A,B,XP)
C-----------------------------------------------------------------------
C     CALCULATE THE INTEGRAL OF BERENDS AND KLEISS APPENDIX B
C-----------------------------------------------------------------------
      IMPLICIT NONE
      DOUBLE COMPLEX XQ,Z1,Z2,Z3,Z4,C0,C1,C2,C3,C4,C5,C6,C7,C8,FUN,Z
      DOUBLE PRECISION HWHIGY,TWO,A,B,XP,Y
      PARAMETER (TWO=2.D0)
C---DECLARE ALL THE STATEMENT-FUNCTION DEFINITIONS
      C0(Z,A)=(Z**2-A)**2*((Z**2+A)**2-24*Z*(Z**2+A)+8*Z**2*(A+6))/Z**4
      C1(Z,A)=A**4/(3*Z)
      C2(Z,A)=-A**3*(24*Z-A)/(2*Z**2)
      C3(Z,A)=A**2*(8*Z**2*(A+6)-24*A*Z+A**2)/Z**3
      C4(Z,A)=-A**2*(24*Z**3+8*Z**2*(A+6)-24*A*Z+A**2)/Z**4
      C5(Z,A)=Z**3-24*Z**2+8*Z*(A+6)+24*A
      C6(Z,A)=0.5*Z**2-12*Z+4*(A+6)
      C7(Z,A)=Z/3-8
      C8(Z,A)=0.25
      FUN(Z,Y,A)=C0(Z,A)*LOG(Y-Z)
     &          +C1(Z,A)/Y**3
     &          +C2(Z,A)/Y**2
     &          +C3(Z,A)/Y
     &          +C4(Z,A)*LOG(Y)
     &          +C5(Z,A)*Y
     &          +C6(Z,A)*Y**2
     &          +C7(Z,A)*Y**3
     &          +C8(Z,A)*Y**4
C---NOW EVALUATE THE INTEGRAL
      HWHIGY=0
      IF (A.GT.4) RETURN
      XQ=DCMPLX(XP,B)
      Z1=XQ+SQRT(XQ**2-A)
      Z2=XQ-SQRT(XQ**2-A)
      Z3=FUN(Z1,TWO,A)-FUN(Z1,SQRT(A),A)
      Z4=FUN(Z2,TWO,A)-FUN(Z2,SQRT(A),A)
      HWHIGY=DIMAG((Z3-Z4)/(Z1-Z2))/(8*B)
      END
CDECK  ID>, HWHIGZ.
*CMZ :-        -02/05/91  11.18.44  by  Federico Carminati
*-- Author :    Mike Seymour
C-----------------------------------------------------------------------
      SUBROUTINE HWHIGZ
C-----------------------------------------------------------------------
C     HIGGS PRODUCTION VIA THE BJORKEN PROCESS: E+E- --> Z(*) --> Z(*)H
C     WHERE ONE OR BOTH OF THE Zs IS OFF-SHELL
C     USES ALGORITHM OF BERENDS AND KLEISS: NUCL.PHYS. B260(1985)32
C
C     MEAN EVWGT = CROSS-SECTION (IN NB) * HIGGS BRANCHING FRACTION
C-----------------------------------------------------------------------
      INCLUDE 'HERWIG62.INC'
      DOUBLE PRECISION HWUAEM,HWHIGY,HWRUNI,HWRGEN,HWULDO,EMZ,CVE,CAE,
     & POL1,POL2,CE1,CE2,CE3,PMAX,EMZ2,S,B,FACTR,EMH,EMFAC,EMH2,A,XP,
     & CV,CA,BRHIGQ,BR,X1,X2,FAC1,FAC2,XPP,XPPSQ,COEF,X,XSQ,PROB,C1,C2,
     & CHIGG,PTHETA,SHIGG,C3,PHIMAX,CPHI,SPHI,C2PHI,S2PHI,PCM,ELST
      INTEGER IDEC,I,NLOOP,ICMF,IHIG,IZED,IFER,IANT,ID1,ID2,IN1,IN2
      EXTERNAL HWUAEM,HWHIGY,HWRUNI,HWRGEN,HWULDO
      SAVE CVE,CAE,CE1,CE2,CE3,PMAX,EMZ2,S,EMH,B,FACTR,A,EMH2
      EQUIVALENCE (EMZ,RMASS(200))
      DATA ELST/0/
C---SET UP CONSTANTS
      IN1=1
      IF (JDAHEP(1,IN1).NE.0) IN1=JDAHEP(1,IN1)
      IN2=2
      IF (JDAHEP(1,IN2).NE.0) IN2=JDAHEP(1,IN2)
      IF (FSTWGT.OR.ELST.NE.PHEP(5,3)) THEN
        ELST=PHEP(5,3)
        CVE=VFCH(11,1)
        CAE=AFCH(11,1)
        POL1=1.-EPOLN(3)*PPOLN(3)
        POL2=EPOLN(3)-PPOLN(3)
        CE1=(POL1*(CVE**2+CAE**2)+POL2*2.*CVE*CAE)
        CE2=(POL1*2.*CVE*CAE+POL2*(CVE**2+CAE**2))
        IF ((IDHW(IN1).GT.IDHW(IN2).AND.PHEP(3,IN1).LT.ZERO).OR.
     &      (IDHW(IN2).GT.IDHW(IN1).AND.PHEP(3,IN2).LT.ZERO)) CE2=-CE2
        IF (TPOL) CE3=(CVE**2-CAE**2)
        PMAX=4
        EMZ2=EMZ**2
        S=PHEP(5,3)**2
        B=EMZ*GAMZ/S
        FACTR=GEV2NB*CE1*(HWUAEM(RMASS(201)**2)*ENHANC(11))**2
     &       /(12.*S*SWEIN*(1.-SWEIN))*B/((1-EMZ2/S)**2+B**2)
      ENDIF
      IF (.NOT.GENEV) THEN
C---CHOOSE HIGGS MASS, AND CALCULATE EVENT WEIGHT
        EVWGT=0D0
        CALL HWHIGM(EMH,EMFAC)
        IF (EMH.LE.ZERO .OR. EMH.GT.PHEP(5,3)) RETURN
        EMSCA=EMH
        EMH2=EMH**2
        A=4*EMH2/S
        XP=1+(EMH2-EMZ2)/S
        EVWGT=FACTR*HWHIGY(A,B,XP)*EMFAC
C---INCLUDE BRANCHING RATIO OF HIGGS
        IDEC=MOD(IPROC,100)
        IF (IDEC.GT.0.AND.IDEC.LE.12) EVWGT=EVWGT*BRHIG(IDEC)
        IF (IDEC.EQ.0) THEN
          BRHIGQ=0
          DO 10 I=1,6
 10         BRHIGQ=BRHIGQ+BRHIG(I)
          EVWGT=EVWGT*BRHIGQ
        ENDIF
C Add Z branching fractions
        CALL HWDBOZ(200,ID1,ID2,CV,CA,BR,0)
        EVWGT=EVWGT*BR
        IF (IDEC.EQ.10) THEN
          CALL HWDBOZ(198,ID1,ID2,CV,CA,BR,1)
          CALL HWDBOZ(199,ID1,ID2,CV,CA,BR,1)
          EVWGT=EVWGT*BR
        ELSEIF (IDEC.EQ.11) THEN
          CALL HWDBOZ(200,ID1,ID2,CV,CA,BR,1)
          CALL HWDBOZ(200,ID1,ID2,CV,CA,BR,1)
          EVWGT=EVWGT*BR
        ENDIF
      ELSE
C---GENERATE EVENT
        ICMF=NHEP+1
        IHIG=NHEP+2
        IZED=NHEP+3
        IFER=NHEP+4
        IANT=NHEP+5
        CALL HWVEQU(5,PHEP(1,3),PHEP(1,ICMF))
        NHEP=NHEP+5
C---CHOOSE ENERGY FRACTION OF HIGGS
        X1=SQRT(A)
        X2=1+0.25*A
        XP=1+(EMH2-EMZ2)/S
        FAC1=ATAN((X1-XP)/B)
        FAC2=ATAN((X2-XP)/B)
        XPP=MIN(X2,MAX(X1+B,XP))
        XPPSQ=XPP**2
        NLOOP=0
        COEF=1./((12+2*A-12*XPP+XPPSQ)*SQRT(XPPSQ-A))
 20       NLOOP=NLOOP+1
          IF (NLOOP.GT.NBTRY) CALL HWWARN('HWHIGZ',101,*999)
          X=XP+B*TAN(HWRUNI(1,FAC1,FAC2))
          XSQ=X**2
          PROB=COEF*((12+2*A-12*X+XSQ)*SQRT(XSQ-A))
          IF (PROB.GT.PMAX) THEN
            PMAX=1.1*PROB
            CALL HWWARN('HWHIGZ',1,*999)
            WRITE (6,21) PMAX
 21         FORMAT(7X,'NEW HWHIGZ MAX WEIGHT =',F8.4)
          ENDIF
        IF (PROB.LT.PMAX*HWRGEN(0)) GOTO 20
C Choose Z decay mode
        CALL HWDBOZ(200,IDHW(IFER),IDHW(IANT),CV,CA,BR,0)
        C1=CE1*(CV**2+CA**2)
        C2=CE2*2.*CV*CA
C---CHOOSE HIGGS DIRECTION
C First polar angle
        NLOOP=0
        COEF=(XSQ-A)/(8.*(1.-X)+XSQ+A)
 30       NLOOP=NLOOP+1
          IF (NLOOP.GT.NBTRY) CALL HWWARN('HWHIGZ',102,*999)
          CHIGG=HWRUNI(2,-ONE, ONE)
          PTHETA=1-COEF*CHIGG**2
        IF (PTHETA.LT.HWRGEN(1)) GOTO 30
        SHIGG=SQRT(1-CHIGG**2)
C Now azimuthal angle
        IF (TPOL) THEN
           C3=CE3*(CV*2+CA**2)
           COEF=COEF*SHIGG**2*C3/C1
           PHIMAX=PTHETA+ABS(COEF)
  40       CALL HWRAZM(ONE,CPHI,SPHI)
           C2PHI=2.*CPHI**2-1.
           S2PHI=2.*CPHI*SPHI
           PROB=PTHETA-COEF*(C2PHI*COSS+S2PHI*SINS)
           IF (PROB.LT.HWRGEN(1)*PHIMAX) GOTO 40
        ELSE
           CALL HWRAZM(ONE,CPHI,SPHI)
        ENDIF
C Construct Higgs and Z momenta
        PHEP(5,IHIG)=EMH
        PHEP(4,IHIG)=X*PHEP(5,ICMF)/2
        PCM=SQRT(PHEP(4,IHIG)**2-EMH2)
        PHEP(3,IHIG)=CHIGG*PCM
        PHEP(1,IHIG)=SHIGG*PCM*CPHI
        PHEP(2,IHIG)=SHIGG*PCM*SPHI
        CALL HWVDIF(4,PHEP(1,ICMF),PHEP(1,IHIG),PHEP(1,IZED))
        CALL HWUMAS(PHEP(1,IZED))
C Choose orientation of Z decay
        NLOOP=0
        COEF=2.*(C1+ABS(C2))*HWULDO(PHEP(1,IN1),PHEP(1,IZED))
     &                      *HWULDO(PHEP(1,IN2),PHEP(1,IZED))/S
        IF (TPOL) COEF=COEF*(C1+ABS(C2)+ABS(C3))/(C1+ABS(C2))
        PCM=PHEP(5,IZED)/2
        PHEP(5,IFER)=0
        PHEP(5,IANT)=0
 50     NLOOP=NLOOP+1
        IF (NLOOP.GT.NBTRY) CALL HWWARN('HWHIGZ',103,*999)
        CALL HWDTWO(PHEP(1,IZED),PHEP(1,IFER),PHEP(1,IANT),
     &              PCM,TWO,.TRUE.)
        PROB=C1*(PHEP(4,IFER)*PHEP(4,IANT)-PHEP(3,IFER)*PHEP(3,IANT))
     &      +C2*(PHEP(4,IFER)*PHEP(3,IANT)-PHEP(3,IFER)*PHEP(4,IANT))
        IF (TPOL) PROB=PROB+C3*
     &   (COSS*(PHEP(1,IFER)*PHEP(1,IANT)-PHEP(2,IFER)*PHEP(2,IANT))
     &   +SINS*(PHEP(1,IFER)*PHEP(2,IANT)+PHEP(2,IFER)*PHEP(1,IANT)))
        IF (PROB.LT.HWRGEN(2)*COEF) GOTO 50
C---SET UP STATUS CODES,
        ISTHEP(ICMF)=120
        ISTHEP(IHIG)=190
        ISTHEP(IZED)=195
        ISTHEP(IFER)=113
        ISTHEP(IANT)=114
C---COLOR CONNECTIONS,
        JMOHEP(1,ICMF)=1
        JMOHEP(2,ICMF)=2
        JDAHEP(1,ICMF)=IHIG
        JDAHEP(2,ICMF)=IZED
        JMOHEP(1,IHIG)=ICMF
        JMOHEP(1,IZED)=ICMF
        JMOHEP(1,IFER)=IZED
        JMOHEP(1,IANT)=IZED
        JMOHEP(2,IFER)=IANT
        JMOHEP(2,IANT)=IFER
        JDAHEP(1,IZED)=IFER
        JDAHEP(2,IZED)=IANT
        JDAHEP(2,IFER)=IANT
        JDAHEP(2,IANT)=IFER
C---IDENTITY CODES
        IDHW(ICMF)=200
        IDHW(IHIG)=201
        IDHW(IZED)=200
        IDHEP(ICMF)=IDPDG(IDHW(ICMF))
        IDHEP(IHIG)=IDPDG(IDHW(IHIG))
        IDHEP(IZED)=IDPDG(IDHW(IZED))
        IDHEP(IFER)=IDPDG(IDHW(IFER))
        IDHEP(IANT)=IDPDG(IDHW(IANT))
      ENDIF
 999  END
CDECK  ID>, HWHPH2.
*CMZ :-        -12/01/93  10.12.43  by  Bryan Webber
*-- Author :    Ian Knowles
C-----------------------------------------------------------------------
      SUBROUTINE HWHPH2
C-----------------------------------------------------------------------
C     QQD direct photon pair production: mean EVWGT = sigma in nb
C-----------------------------------------------------------------------
      INCLUDE 'HERWIG62.INC'
      DOUBLE PRECISION HWRGEN,HWRUNI,HWUALF,HWHPPB,EPS,RCS,ET,EJ,KK,KK2,
     & YJ1INF,YJ1SUP,Z1,YJ2INF,YJ2SUP,Z2,FACT,FACTR,RS,S,T,U,CSTU,TQSQ,
     & DSTU,HCS
      INTEGER ID,ID1,ID2
      EXTERNAL HWRGEN,HWRUNI,HWUALF,HWHPPB
      SAVE HCS,CSTU,DSTU,FACT
      PARAMETER (EPS=1.D-9)
      IF (GENEV) THEN
        RCS=HCS*HWRGEN(0)
      ELSE
        EVWGT=0.
        CALL HWRPOW(ET,EJ)
        KK=ET/PHEP(5,3)
        KK2=KK**2
        IF (KK.GE.ONE) RETURN
        YJ1INF=MAX( YJMIN , LOG((1.-SQRT(1.-KK2))/KK) )
        YJ1SUP=MIN( YJMAX , LOG((1.+SQRT(1.-KK2))/KK) )
        IF (YJ1INF.GE.YJ1SUP) RETURN
        Z1=EXP(HWRUNI(1,YJ1INF,YJ1SUP))
        YJ2INF=MAX( YJMIN , -LOG(2./KK-1./Z1) )
        YJ2SUP=MIN( YJMAX ,  LOG(2./KK-Z1) )
        IF (YJ2INF.GE.YJ2SUP) RETURN
        Z2=EXP(HWRUNI(2,YJ2INF,YJ2SUP))
        XX(1)=0.5*(Z1+Z2)*KK
        IF (XX(1).GE.ONE) RETURN
        XX(2)=XX(1)/(Z1*Z2)
        IF (XX(2).GE.ONE) RETURN
        COSTH=(Z1-Z2)/(Z1+Z2)
        S=XX(1)*XX(2)*PHEP(5,3)**2
        RS=0.5*SQRT(S)
        T=-0.5*S*(1.-COSTH)
        U=-S-T
        EMSCA=SQRT(2.*S*T*U/(S*S+T*T+U*U))
        FACT=GEV2NB*PIFAC*0.5*ET*EJ*(YJ1SUP-YJ1INF)*(YJ2SUP-YJ2INF)
     &      *(ALPHEM/S)**2
        CALL HWSGEN(.FALSE.)
        CSTU=2.*(U/T+T/U)/CAFAC
        IF (DISF(13,1).GT.EPS.AND.DISF(13,2).GT.EPS) THEN
           TQSQ=0.
           DO 10 ID=1,6
  10       IF (RMASS(ID).LT.RS) TQSQ=TQSQ+QFCH(ID)**2
           DSTU=DISF(13,1)*DISF(13,2)*FACT*HWHPPB(S,T,U)
     &         /64.*(HWUALF(1,EMSCA)*TQSQ/PIFAC)**2
        ENDIF
      ENDIF
      HCS=0.
      DO 30 ID=1,6
      FACTR=FACT*CSTU*QFCH(ID)**4
C q+qbar ---> gamma+gamma
      ID1=ID
      ID2=ID+6
      IF (DISF(ID1,1).LT.EPS.OR.DISF(ID2,2).LT.EPS) GOTO 20
      HCS=HCS+FACTR*DISF(ID1,1)*DISF(ID2,2)
      IF (GENEV.AND.HCS.GT.RCS) CALL HWHQCP(59,59,2134,61,*99)
C qbar+q ---> gamma+gamma
  20  ID1=ID+6
      ID2=ID
      IF (DISF(ID1,1).LT.EPS.OR.DISF(ID2,2).LT.EPS) GOTO 30
      HCS=HCS+FACTR*DISF(ID1,1)*DISF(ID2,2)
      IF (GENEV.AND.HCS.GT.RCS) CALL HWHQCP(59,59,2134,62,*99)
  30  CONTINUE
C g+g ---> gamma+gamma
      ID1=13
      ID2=13
      HCS=HCS+DSTU
      IF (GENEV.AND.HCS.GT.RCS) CALL HWHQCP(59,59,2134,63,*99)
      EVWGT=HCS
      RETURN
C Generate event
  99  IDN(1)=ID1
      IDN(2)=ID2
      IDCMF=15
      CALL HWETWO
  999 END
CDECK  ID>, HWHPHO.
*CMZ :-        -26/04/91  14.55.45  by  Federico Carminati
*-- Author :    Bryan Webber
C-----------------------------------------------------------------------
      SUBROUTINE HWHPHO
C-----------------------------------------------------------------------
C     QCD DIRECT PHOTON + JET PRODUCTION: MEAN EVWGT = SIGMA IN NB
C-----------------------------------------------------------------------
      INCLUDE 'HERWIG62.INC'
      DOUBLE PRECISION HWRGEN,HWRUNI,HWUALF,HWHPPB,EPS,RCS,ET,EJ,KK,KK2,
     & YJ1INF,YJ1SUP,Z1,YJ2INF,YJ2SUP,Z2,FACT,FACTR,FACTF,RS,S,T,U,CF,
     & AF,CSTU,CTSU,CUST,DSTU,HCS,TQCH
      INTEGER ID,ID1,ID2
      EXTERNAL HWRGEN,HWRUNI,HWUALF,HWHPPB
      SAVE HCS
      PARAMETER (EPS=1.D-9)
      IF (GENEV) THEN
        RCS=HCS*HWRGEN(0)
      ELSE
        EVWGT=0.
        CALL HWRPOW(ET,EJ)
        KK=ET/PHEP(5,3)
        KK2=KK**2
        IF (KK.GE.ONE) RETURN
        YJ1INF=MAX( YJMIN , LOG((1.-SQRT(1.-KK2))/KK) )
        YJ1SUP=MIN( YJMAX , LOG((1.+SQRT(1.-KK2))/KK) )
        IF (YJ1INF.GE.YJ1SUP) RETURN
        Z1=EXP(HWRUNI(1,YJ1INF,YJ1SUP))
        YJ2INF=MAX( YJMIN , -LOG(2./KK-1./Z1) )
        YJ2SUP=MIN( YJMAX ,  LOG(2./KK-Z1) )
        IF (YJ2INF.GE.YJ2SUP) RETURN
        Z2=EXP(HWRUNI(2,YJ2INF,YJ2SUP))
        XX(1)=0.5*(Z1+Z2)*KK
        IF (XX(1).GE.ONE) RETURN
        XX(2)=XX(1)/(Z1*Z2)
        IF (XX(2).GE.ONE) RETURN
        COSTH=(Z1-Z2)/(Z1+Z2)
        S=XX(1)*XX(2)*PHEP(5,3)**2
        RS=0.5*SQRT(S)
        T=-0.5*S*(1.-COSTH)
        U=-S-T
C---SET EMSCA TO HARD PROCESS SCALE (APPROX ET-JET)
        EMSCA=SQRT(2.*S*T*U/(S*S+T*T+U*U))
        FACT=GEV2NB*PIFAC*0.5*ET*EJ*ALPHEM
     &      *HWUALF(1,EMSCA)*(YJ1SUP-YJ1INF)*(YJ2SUP-YJ2INF)/S**2
        CALL HWSGEN(.FALSE.)
C
        CF=2.*CFFAC/CAFAC
        AF=-1./CAFAC
        CSTU=CF*(U/T+T/U)
        CTSU=AF*(U/S+S/U)
        CUST=AF*(T/S+S/T)
        IF (DISF(13,1).GT.EPS.AND.DISF(13,2).GT.EPS) THEN
           TQCH=0.
           DO 10 ID=1,6
  10       IF (RMASS(ID).LT.RS) TQCH=TQCH+QFCH(ID)
           DSTU=DISF(13,1)*DISF(13,2)*FACT*HWHPPB(S,T,U)
     &         *5./768.*(HWUALF(1,EMSCA)*TQCH/PIFAC)**2
        ENDIF
      ENDIF
C
      HCS=0.
      DO 30 ID=1,6
      FACTR=FACT*QFCH(ID)**2
C---QUARK FIRST
      ID1=ID
      IF (DISF(ID1,1).LT.EPS) GOTO 20
      ID2=ID1+6
      HCS=HCS+CSTU*FACTR*DISF(ID1,1)*DISF(ID2,2)
      IF (GENEV.AND.HCS.GT.RCS) CALL HWHQCP( 13, 59,2314,41,*9)
      ID2=13
      HCS=HCS+CTSU*FACTR*DISF(ID1,1)*DISF(ID2,2)
      IF (GENEV.AND.HCS.GT.RCS) CALL HWHQCP(ID1, 59,3124,42,*9)
C---QBAR FIRST
  20  ID1=ID+6
      IF (DISF(ID1,1).LT.EPS) GOTO 30
      ID2=ID
      HCS=HCS+CSTU*FACTR*DISF(ID1,1)*DISF(ID2,2)
      IF (GENEV.AND.HCS.GT.RCS) CALL HWHQCP( 13, 59,3124,43,*9)
      ID2=13
      HCS=HCS+CTSU*FACTR*DISF(ID1,1)*DISF(ID2,2)
      IF (GENEV.AND.HCS.GT.RCS) CALL HWHQCP(ID1, 59,2314,44,*9)
  30  CONTINUE
C---GLUON FIRST
      ID1=13
      FACTF=FACT*CUST*DISF(ID1,1)
      DO 50 ID=1,6
      FACTR=FACTF*QFCH(ID)**2
      ID2=ID
      IF (DISF(ID2,2).LT.EPS) GOTO 40
      HCS=HCS+FACTR*DISF(ID2,2)
      IF (GENEV.AND.HCS.GT.RCS) CALL HWHQCP(ID2, 59,2314,45,*9)
  40  ID2=ID+6
      IF (DISF(ID2,2).LT.EPS) GOTO 50
      HCS=HCS+FACTR*DISF(ID2,2)
      IF (GENEV.AND.HCS.GT.RCS) CALL HWHQCP(ID2, 59,3124,46,*9)
  50  CONTINUE
C g+g ---> g+gamma
      ID2=13
      HCS=HCS+DSTU
      IF (GENEV.AND.HCS.GT.RCS) CALL HWHQCP( 13, 59,2314,47,*9)
      EVWGT=HCS
      RETURN
C---GENERATE EVENT
    9 IDN(1)=ID1
      IDN(2)=ID2
      IDCMF=15
      CALL HWETWO
  999 END
CDECK  ID>, HWHPPB.
*CMZ :-        -12/01/93  10.12.43  by  Bryan Webber
*-- Author :    Ian Knowles
C-----------------------------------------------------------------------
      FUNCTION HWHPPB(S,T,U)
C-----------------------------------------------------------------------
C     Quark box diagram contribution to photon/gluon scattering
C     Internal quark mass neglected: m_q << U,T,S
C-----------------------------------------------------------------------
      IMPLICIT NONE
      DOUBLE PRECISION HWHPPB,S,T,U,S2,T2,U2,PI2,ALNTU,ALNST,ALNSU
      PI2=ACOS(-1.D0)**2
      S2=S**2
      T2=T**2
      U2=U**2
      ALNTU=LOG(T/U)
      ALNST=LOG(-S/T)
      ALNSU=ALNST+ALNTU
      HWHPPB=5.*4.
     & +((2.*S2+2.*(U2-T2)*ALNTU+(T2+U2)*(ALNTU**2+PI2))/S2)**2
     & +((2.*U2+2.*(T2-S2)*ALNST+(T2+S2)* ALNST**2     )/U2)**2
     & +((2.*T2+2.*(U2-S2)*ALNSU+(U2+S2)* ALNSU**2     )/T2)**2
     & +4.*PI2*(((T2-S2+(T2+S2)*ALNST)/U2)**2
     &         +((U2-S2+(U2+S2)*ALNSU)/T2)**2)
      END
CDECK  ID>, HWHPPE.
*CMZ :-        -12/01/93  10.12.43  by  Bryan Webber
*-- Author :    Ian Knowles
C-----------------------------------------------------------------------
      SUBROUTINE HWHPPE
C-----------------------------------------------------------------------
C     point-like photon/QCD heavy flavour single excitation, using exact
C     massive lightcone kinematics, mean EVWGT = sigma in nb.
C-----------------------------------------------------------------------
      INCLUDE 'HERWIG62.INC'
      DOUBLE PRECISION HWRGEN,HWRUNI,HWUALF,EPS,PP1,PP2,QM2,FACTR,
     & PT,PJ,PT2,PTM,EXY,T,CC,EXY2,S,U,C,SIGE,HCS,RCS
      INTEGER IQ1,IQ2,ID1,ID2,IHAD1,IHAD2
      EXTERNAL HWRGEN,HWRUNI,HWUALF
      SAVE PP1,PP2,IQ1,IQ2,QM2,FACTR,SIGE,HCS
      PARAMETER (EPS=1.E-9)
      IHAD1=1
      IF (JDAHEP(1,IHAD1).NE.0) IHAD1=JDAHEP(1,IHAD1)
      IHAD2=2
      IF (JDAHEP(1,IHAD2).NE.0) IHAD2=JDAHEP(1,IHAD2)
      IF (FSTWGT.OR.IHAD1.NE.1.OR.IHAD2.NE.2) THEN
         PP1=PHEP(4,IHAD1)+ABS(PHEP(3,IHAD1))
         PP2=PHEP(4,IHAD2)+ABS(PHEP(3,IHAD2))
         XX(1)=1.
         IQ1=MOD(IPROC,100)
         IQ2=IQ1+6
         QM2=RMASS(IQ1)**2
         FACTR=GEV2NB*(YJMAX-YJMIN)*4.*PIFAC*CFFAC*PP1
     &        *ALPHEM*QFCH(IQ1)**2
      ENDIF
      IF (GENEV) THEN
         RCS=HCS*HWRGEN(0)
      ELSE
         EVWGT=0.
         CALL HWRPOW(PT,PJ)
         PT2=PT**2
         PTM=SQRT(PT2+QM2)
         EXY=EXP(HWRUNI(1,YJMIN,YJMAX))
         T=-PP1*PT/EXY
         CC=T**2-4.*QM2*(PT2+T)
         IF (CC.LT.ZERO) RETURN
         EXY2=(2.*PT2+T-SQRT(CC))*PP1/(2.*T*PTM)
         IF (EXY2.LT.EXP(YJMIN).OR.EXY2.GT.EXP(YJMAX)) RETURN
         XX(2)=(PT/EXY+PTM/EXY2)/PP2
         IF (XX(2).GT.ONE) RETURN
C define: S=Shat-M**2, T=That ,U=Uhat-M**2 (2p.Q, -2p.g, -2p.Q')
         S=XX(2)*PP1*PP2
         U=-S-T
         COSTH=(1.+QM2/S)*(T-U)/S-QM2/S
C Set hard process scale (Approx ET-jet)
         EMSCA=SQRT(2.*S*T*U/(S*S+T*T+U*U))
         C=QM2*T/(U*S)
         SIGE=-FACTR*PT*PJ*HWUALF(1,EMSCA)*(S/U+U/S+4.*C*(1.-C))
     &       /(S**2*EXY2*PTM*(1-QM2/(XX(2)*PP2*EXY2)**2))
         CALL HWSFUN(XX(2),EMSCA,IDHW(IHAD2),NSTRU,DISF(1,2),2)
      ENDIF
      HCS=0.
      ID1=59
C photon+Q ---> g+Q
      ID2=IQ1
      IF (DISF(ID2,2).LT.EPS) GOTO 10
      HCS=HCS+SIGE*DISF(ID2,2)
      IF (GENEV.AND.HCS.GT.RCS) CALL HWHQCP(13,ID2,1423,51,*99)
C photon+Qbar ---> g+Qbar
  10  ID2=IQ2
      IF (DISF(ID2,2).LT.EPS) GOTO 20
      HCS=HCS+SIGE*DISF(ID2,2)
      IF (GENEV.AND.HCS.GT.RCS) CALL HWHQCP(13,ID2,1342,52,*99)
  20  EVWGT=HCS
      RETURN
C Generate event
  99  IDN(1)=ID1
      IDN(2)=ID2
      IDCMF=15
      CALL HWETWO
  999 END
CDECK  ID>, HWHPPH.
*CMZ :-        -12/01/93  10.12.43  by  Bryan Webber
*-- Author :    Ian Knowles
C-----------------------------------------------------------------------
      SUBROUTINE HWHPPH
C-----------------------------------------------------------------------
C     Point-like photon/gluon heavy flavour pair production, with
C     exact lightcone massive kinematics, mean EVWGT = sigma in nb.
C-----------------------------------------------------------------------
      INCLUDE 'HERWIG62.INC'
      DOUBLE PRECISION HWRUNI,HWUALF,EPS,PP1,PP2,QM2,FACTR,ET,EJ,ET2,
     & EXY,EXY2,S,T,U,C
      INTEGER IQ1,IHAD1,IHAD2
      EXTERNAL HWRUNI,HWUALF
      SAVE PP1,PP2,IQ1,QM2,FACTR
      PARAMETER (EPS=1.E-9)
      IHAD1=1
      IF (JDAHEP(1,IHAD1).NE.0) IHAD1=JDAHEP(1,IHAD1)
      IHAD2=2
      IF (JDAHEP(1,IHAD2).NE.0) IHAD2=JDAHEP(1,IHAD2)
      IF (FSTWGT.OR.IHAD1.NE.1.OR.IHAD2.NE.2) THEN
         PP1=PHEP(4,IHAD1)+ABS(PHEP(3,IHAD1))
         PP2=PHEP(4,IHAD2)+ABS(PHEP(3,IHAD2))
         XX(1)=1.
         IQ1=MOD(IPROC,100)
         QM2=RMASS(IQ1)**2
         IHPRO=53
         FACTR=-GEV2NB*(YJMAX-YJMIN)*.5*PIFAC*ALPHEM*QFCH(IQ1)**2
      ENDIF
      IF (GENEV) THEN
C Generate event
         IDN(1)=59
         IDN(2)=13
         IDN(3)=IQ1
         IDN(4)=IQ1+6
         ICO(1)=1
         ICO(2)=4
         ICO(3)=2
         ICO(4)=3
         IDCMF=15
         CALL HWETWO
      ELSE
C Select kinematics
         EVWGT=0.
         CALL HWRPOW(ET,EJ)
         ET2=ET**2
         EXY=EXP(HWRUNI(1,YJMIN,YJMAX))
         EXY2=2.*PP1/ET-EXY
         IF (EXY2.LT.EXP(YJMIN).OR.EXY2.GT.EXP(YJMAX)) RETURN
         XX(2)=.5*ET*(1./EXY+1./EXY2)/PP2
         IF (XX(2).LT.ZERO.OR.XX(2).GT.ONE) RETURN
         S=XX(2)*PP1*PP2
         IF (S.LT.ET2) RETURN
C define: S=Shat, T=That-M**2, U=Uhat-M**2 (2p.g, -2p.Q, -2p.QBar)
         T=-.5*PP1*ET/EXY
         U=-S-T
         COSTH=(T-U)/(S*SQRT(1.-4.*QM2/S))
         EMSCA=SQRT(2.*S*T*U/(S*S+T*T+U*U))
         CALL HWSFUN(XX(2),EMSCA,IDHW(IHAD2),NSTRU,DISF(1,2),2)
C photon+g ---> Q+Qbar
         IF (DISF(13,2).LT.EPS) THEN
            EVWGT=0.
         ELSE
            C=QM2*S/(U*T)
            EVWGT=FACTR*EJ*ET*HWUALF(1,EMSCA)
     &           *DISF(13,2)*(T/U+U/T+4.*C*(1.-C))/(S*T)
         ENDIF
      ENDIF
  999 END
CDECK  ID>, HWHPPM.
*CMZ :-        -09/12/93  15.50.26  by  Mike Seymour
*-- Author :    Ian Knowles & Mike Seymour
C-----------------------------------------------------------------------
      SUBROUTINE HWHPPM
C-----------------------------------------------------------------------
C     Point-like photon/QCD direct meson production
C     See M. Benayoun, et al., Nucl. Phys. B282 (1987) 653 for details.
C     mean EVWGT = sigma in nb
C-----------------------------------------------------------------------
      INCLUDE 'HERWIG62.INC'
      DOUBLE PRECISION HWRGEN,HWRUNI,HWUALF,EPS,PP1,PP2,ET,EJ,EXY,EXY2,
     & FACT,FACTR,S,T,U,REDS,DELT(3,3),C1STU,C3STU,HCS,RCS,CMIX,SMIX,
     & C1WVFN,FPI,FETA8,FETA1,FRHO,FPHI8,FPHI1,FPI2,FETA2(3),FETAP2(3),
     7 FRHO2,FPHI2(3),FOMEG2(3)
      INTEGER MNAME(3,3,2),N4(3),I,J,ID2,ID4,I2,I4,M1,M2,IHAD1,IHAD2
      LOGICAL SPIN0,SPIN1
      EXTERNAL HWRGEN,HWRUNI,HWUALF
      SAVE FPI2,FETA2,FETAP2,FRHO2,FPHI2,FOMEG2,HCS,REDS,FACT,DELT,
     & C1STU,C3STU
      PARAMETER (EPS=1.D-20)
      DATA MNAME/21,38,42,30,21,34,50,46,0,23,39,43,31,23,35,51,47,0/
      DATA N4,SPIN0,SPIN1/3,3,2,.TRUE.,.TRUE./
      DATA C1WVFN,FPI,FETA8,FETA1,FRHO,FPHI8,FPHI1/1.,3*0.093,3*0.107/
      IF (FSTWGT) THEN
         FPI2=FPI**2
         CMIX=COS(ETAMIX*PIFAC/180.D0)
         SMIX=SIN(ETAMIX*PIFAC/180.D0)
         FETA2(1) =(+CMIX*FETA8/SQRT(TWO)-SMIX*FETA1)**2/THREE
         FETA2(2) =FETA2(1)
         FETA2(3) =(-CMIX*FETA8*SQRT(TWO)-SMIX*FETA1)**2/THREE
         FETAP2(1)=(+SMIX*FETA8/SQRT(TWO)+CMIX*FETA1)**2/THREE
         FETAP2(2)=FETAP2(1)
         FETAP2(3)=(-SMIX*FETA8*SQRT(TWO)+CMIX*FETA1)**2/THREE
         FRHO2=FRHO**2
         CMIX=COS(PHIMIX*PIFAC/180.D0)
         SMIX=SIN(PHIMIX*PIFAC/180.D0)
         FPHI2(1) =(+CMIX*FPHI8/SQRT(TWO)-SMIX*FPHI1)**2/THREE
         FPHI2(2) =FPHI2(1)
         FPHI2(3) =(-CMIX*FPHI8*SQRT(TWO)-SMIX*FPHI1)**2/THREE
         FOMEG2(1)=(+SMIX*FPHI8/SQRT(TWO)+CMIX*FPHI1)**2/THREE
         FOMEG2(2)=FOMEG2(1)
         FOMEG2(3)=(-SMIX*FPHI8*SQRT(TWO)+CMIX*FPHI1)**2/THREE
      ENDIF
      SPIN0=.NOT.(MOD(IPROC/10,10).EQ.2)
      SPIN1=.NOT.(MOD(IPROC/10,10).EQ.1)
      IF (GENEV) THEN
         RCS=HCS*HWRGEN(0)
      ELSE
         EVWGT=ZERO
         IHAD1=1
         IF (JDAHEP(1,IHAD1).NE.0) IHAD1=JDAHEP(1,IHAD1)
         IHAD2=2
         IF (JDAHEP(1,IHAD2).NE.0) IHAD2=JDAHEP(1,IHAD2)
         PP1=PHEP(4,IHAD1)+ABS(PHEP(3,IHAD1))
         PP2=PHEP(4,IHAD2)+ABS(PHEP(3,IHAD2))
         XX(1)=ONE
         CALL HWRPOW(ET,EJ)
         EXY=EXP(HWRUNI(1,YJMIN,YJMAX))
         EXY2=TWO*PP1/ET-EXY
         IF (EXY2.LE.EXP(YJMIN).OR.EXY2.GE.EXP(YJMAX)) RETURN
         XX(2)=PP1/(PP2*EXY*EXY2)
         IF (XX(2).LE.ZERO.OR.XX(2).GE.ONE) RETURN
         S=XX(2)*PP1*PP2
         REDS=SQRT(S-ET*SQRT(S))
         T=-HALF*PP1*ET/EXY
         U=-S-T
         COSTH=(T-U)/S
C Set EMSCA to hard process scale (Approx ET-jet)
         EMSCA=SQRT(TWO*S*T*U/(S*S+T*T+U*U))
         FACT=-GEV2NB*ET*EJ*(YJMAX-YJMIN)*ALPHEM*CFFAC
     &       *(HWUALF(1,EMSCA)*PIFAC*C1WVFN)**2*32.D0/(THREE*S*T)
         CALL HWSFUN(XX(2),EMSCA,IDHW(IHAD2),NSTRU,DISF(1,2),2)
         DO 10 I=1,3
         DO 10 J=1,3
 10      DELT(I,J)=(QFCH(I)*U+QFCH(J)*S)**2
         C1STU=-(S**2+U**2)/(T*S**2*U**2)
         C3STU=-8.D0*T/(S**2*U**2)
      ENDIF
      HCS=ZERO
      DO 50 I2=1,3
C Quark initiated processes
      ID2=I2
      IF (DISF(ID2,2).LT.EPS) GOTO 30
      DO 20 ID4=1,N4(I2)
      M1=MNAME(ID2,ID4,1)
      FACTR=FACT*DELT(ID2,ID4)*DISF(ID2,2)
      IF (ID2.EQ.ID4) FACTR=HALF*FACTR
      IF (SPIN0.AND.REDS.GT.RMASS(M1)) THEN
C  photon+q --> meson_0+q'
         HCS=HCS+HALF*FACTR*C1STU*FPI2
         IF (GENEV.AND.HCS.GT.RCS) CALL HWHQCP(M1,ID4,1432,71,*99)
      ENDIF
      M2=MNAME(ID2,ID4,2)
      IF (SPIN1.AND.REDS.GT.RMASS(M2)) THEN
C  photon+q --> meson_L+q'
         HCS=HCS+FACTR*C1STU*FRHO2
         IF (GENEV.AND.HCS.GT.RCS) CALL HWHQCP(M2,ID4,1432,72,*99)
C  photon+q --> meson_T+q'
         HCS=HCS+FACTR*C3STU*FRHO2
         IF (GENEV.AND.HCS.GT.RCS) CALL HWHQCP(M2,ID4,1432,73,*99)
      ENDIF
  20  CONTINUE
      FACTR=FACT*DELT(I2,I2)*DISF(ID2,2)
      IF (SPIN0.AND.REDS.GT.RMASS(22)) THEN
C  photon+q -->eta+q
         HCS=HCS+HALF*FACTR*C1STU*FETA2(I2)
         IF (GENEV.AND.HCS.GT.RCS) CALL HWHQCP(22,ID2,1432,71,*99)
      ENDIF
      IF (SPIN0.AND.REDS.GT.RMASS(25)) THEN
C  photon+q -->eta'+q
         HCS=HCS+HALF*FACTR*C1STU*FETAP2(I2)
         IF (GENEV.AND.HCS.GT.RCS) CALL HWHQCP(25,ID2,1432,71,*99)
      ENDIF
      IF (SPIN1.AND.REDS.GT.RMASS(56)) THEN
C  photon+q -->phi_L+q
         HCS=HCS+FACTR*C1STU*FPHI2(I2)
         IF (GENEV.AND.HCS.GT.RCS) CALL HWHQCP(56,ID2,1432,72,*99)
C  photon+q -->phi_T+q
         HCS=HCS+FACTR*C3STU*FPHI2(I2)
         IF (GENEV.AND.HCS.GT.RCS) CALL HWHQCP(56,ID2,1432,73,*99)
      ENDIF
      IF (SPIN1.AND.REDS.GT.RMASS(24)) THEN
C  photon+q -->omega_L+q
         HCS=HCS+FACTR*C1STU*FOMEG2(I2)
         IF (GENEV.AND.HCS.GT.RCS) CALL HWHQCP(24,ID2,1432,72,*99)
C  photon+q -->omega_T+q
         HCS=HCS+FACTR*C3STU*FOMEG2(I2)
         IF (GENEV.AND.HCS.GT.RCS) CALL HWHQCP(24,ID2,1432,73,*99)
      ENDIF
C Anti-quark initiated processes
  30  ID2=I2+6
      IF (DISF(ID2,2).LT.EPS) GOTO 50
      DO 40 I4=1,N4(I2)
      ID4=I4+6
      FACTR=FACT*DELT(I2,I4)*DISF(ID2,2)
      IF (ID2.EQ.ID4) FACTR=HALF*FACTR
      M1=MNAME(I4,I2,1)
      IF (SPIN0.AND.REDS.GT.RMASS(M1)) THEN
C  photon+qbar --> meson_0+qbar'
         HCS=HCS+HALF*FACTR*C1STU*FPI2
         IF (GENEV.AND.HCS.GT.RCS) CALL HWHQCP(M1,ID4,1432,74,*99)
      ENDIF
      M2=MNAME(I4,I2,2)
      IF (SPIN1.AND.REDS.GT.RMASS(M2)) THEN
C  photon+qbar --> meson_L+qbar'
         HCS=HCS+FACTR*C1STU*FRHO2
         IF (GENEV.AND.HCS.GT.RCS) CALL HWHQCP(M2,ID4,1432,75,*99)
C  photon+qbar --> meson_T+qbar'
         HCS=HCS+FACTR*C3STU*FRHO2
         IF (GENEV.AND.HCS.GT.RCS) CALL HWHQCP(M2,ID4,1432,76,*99)
      ENDIF
  40  CONTINUE
      FACTR=FACT*DELT(I2,I2)*DISF(ID2,2)
      IF (SPIN0.AND.REDS.GT.RMASS(22)) THEN
C  photon+qbar -->eta+qbar
         HCS=HCS+HALF*FACTR*C1STU*FETA2(I2)
         IF (GENEV.AND.HCS.GT.RCS) CALL HWHQCP(22,ID2,1432,74,*99)
      ENDIF
      IF (SPIN0.AND.REDS.GT.RMASS(25)) THEN
C  photon+qbar -->eta'+qbar
         HCS=HCS+HALF*FACTR*C1STU*FETAP2(I2)
         IF (GENEV.AND.HCS.GT.RCS) CALL HWHQCP(25,ID2,1432,74,*99)
      ENDIF
      IF (SPIN1.AND.REDS.GT.RMASS(56)) THEN
C  photon+qbar -->phi_L+qbar
         HCS=HCS+FACTR*C1STU*FPHI2(I2)
         IF (GENEV.AND.HCS.GT.RCS) CALL HWHQCP(56,ID2,1432,75,*99)
C  photon+qbar -->phi_T+qbar
         HCS=HCS+FACTR*C3STU*FPHI2(I2)
         IF (GENEV.AND.HCS.GT.RCS) CALL HWHQCP(56,ID2,1432,76,*99)
      ENDIF
      IF (SPIN1.AND.REDS.GT.RMASS(24)) THEN
C  photon+qbar -->omega_L+qbar
         HCS=HCS+FACTR*C1STU*FOMEG2(I2)
         IF (GENEV.AND.HCS.GT.RCS) CALL HWHQCP(24,ID2,1432,75,*99)
C  photon+qbar -->omega_T+qbar
         HCS=HCS+FACTR*C3STU*FOMEG2(I2)
         IF (GENEV.AND.HCS.GT.RCS) CALL HWHQCP(24,ID2,1432,76,*99)
      ENDIF
  50  CONTINUE
      EVWGT=HCS
      RETURN
C Generate event
  99  IDN(1)=59
      IDN(2)=ID2
      IDCMF=15
      CALL HWETWO
C Set polarization vector
      IF (IHPRO.EQ.72.OR.IHPRO.EQ.75) THEN
        RHOHEP(2,NHEP-1)=ONE
      ELSEIF (IHPRO.EQ.73.OR.IHPRO.EQ.76) THEN
        RHOHEP(1,NHEP-1)=HALF
        RHOHEP(3,NHEP-1)=HALF
      ENDIF
  999 END
CDECK  ID>, HWHPPT.
*CMZ :-        -12/01/93  10.12.43  by  Bryan Webber
*-- Author :    Ian Knowles
C-----------------------------------------------------------------------
      SUBROUTINE HWHPPT
C-----------------------------------------------------------------------
C     point-like photon/QCD di-jet production: mean EVWGT = sigma in nb
C-----------------------------------------------------------------------
      INCLUDE 'HERWIG62.INC'
      DOUBLE PRECISION HWRGEN,HWRUNI,HWUALF,EPS,RCS,PP1,PP2,ET,EJ,
     & EXY,EXY2,FACTR,RS,S,T,U,CSTU,CTSU,HCS
      INTEGER ID1,ID2,ID3,ID4,IHAD1,IHAD2
      EXTERNAL HWRGEN,HWRUNI,HWUALF
      SAVE CSTU,CTSU,HCS,FACTR,RS
      PARAMETER (EPS=1.E-9)
      IHAD1=1
      IF (JDAHEP(1,IHAD1).NE.0) IHAD1=JDAHEP(1,IHAD1)
      IHAD2=2
      IF (JDAHEP(1,IHAD2).NE.0) IHAD2=JDAHEP(1,IHAD2)
      IF (GENEV) THEN
         RCS=HCS*HWRGEN(0)
      ELSE
         EVWGT=0.
         PP1=PHEP(4,IHAD1)+ABS(PHEP(3,IHAD1))
         PP2=PHEP(4,IHAD2)+ABS(PHEP(3,IHAD2))
         XX(1)=1.
         CALL HWRPOW(ET,EJ)
         EXY=EXP(HWRUNI(1,YJMIN,YJMAX))
         EXY2=2.*PP1/ET-EXY
         IF (EXY2.LE.EXP(YJMIN).OR.EXY2.GE.EXP(YJMAX)) RETURN
         XX(2)=PP1/(PP2*EXY*EXY2)
         IF (XX(2).LE.ZERO.OR.XX(2).GE.ONE) RETURN
         S=XX(2)*PP1*PP2
         RS=.5*SQRT(S)
         T=-PP1*0.5*ET/EXY
         U=-S-T
         COSTH=(T-U)/S
C Set EMSCA to hard process scale (Approx ET-jet)
         EMSCA=SQRT(2.*S*T*U/(S*S+T*T+U*U))
         FACTR=-GEV2NB*0.5*EJ*(YJMAX-YJMIN)*ET*PIFAC*ALPHEM
     &        *HWUALF(1,EMSCA)/(S*T)
         CALL HWSFUN(XX(2),EMSCA,IDHW(IHAD2),NSTRU,DISF(1,2),2)
         CSTU=U/T+T/U
         CTSU=-2.*CFFAC*(U/S+S/U)
      ENDIF
      HCS=0.
      ID1=59
      DO 20 ID2=1,13
      IF (DISF(ID2,2).LT.EPS) GOTO 20
      IF (ID2.LT.7) THEN
C photon+q ---> g+q
         HCS=HCS+CTSU*DISF(ID2,2)*QFCH(ID2)**2
         IF (GENEV.AND.HCS.GT.RCS) CALL HWHQCP( 13,ID2,1423,51,*99)
      ELSEIF (ID2.LT.13) THEN
C photon+qbar ---> g+qbar
         HCS=HCS+CTSU*DISF(ID2,2)*QFCH(ID2-6)**2
         IF (GENEV.AND.HCS.GT.RCS) CALL HWHQCP( 13,ID2,1342,52,*99)
      ELSE
C photon+g ---> q+qbar
         DO 10 ID3=1,6
         IF (RS.GT.RMASS(ID3)) THEN
            ID4=ID3+6
            HCS=HCS+CSTU*DISF(ID2,2)*QFCH(ID3)**2
            IF (GENEV.AND.HCS.GT.RCS) CALL HWHQCP(ID3,ID4,1423,53,*99)
         ENDIF
  10     CONTINUE
      ENDIF
  20  CONTINUE
      EVWGT=FACTR*HCS
      RETURN
C Generate event
  99  IDN(1)=ID1
      IDN(2)=ID2
      IDCMF=15
      CALL HWETWO
  999 END
CDECK  ID>, HWHPQS.
*CMZ :-        -27/03/95  13.27.22  by  Mike Seymour
*-- Author :    Ian Knowles
C-----------------------------------------------------------------------
      SUBROUTINE HWHPQS
C-----------------------------------------------------------------------
C     Compton scattering of point-like photon and (anti)quark
C     mean EVWGT = sigma in nb
C-----------------------------------------------------------------------
      INCLUDE 'HERWIG62.INC'
      DOUBLE PRECISION HWRGEN,HWRUNI,EPS,RCS,PP1,PP2,ET,EJ,EXY,EXY2,
     & FACTR,S,T,U,CTSU,HCS
      INTEGER ID1,ID2,IHAD1,IHAD2
      EXTERNAL HWRGEN,HWRUNI
      SAVE CTSU,HCS,FACTR
      PARAMETER (EPS=1.E-9)
      IHAD1=1
      IF (JDAHEP(1,IHAD1).NE.0) IHAD1=JDAHEP(1,IHAD1)
      IHAD2=2
      IF (JDAHEP(1,IHAD2).NE.0) IHAD2=JDAHEP(1,IHAD2)
      IF (GENEV) THEN
         RCS=HCS*HWRGEN(0)
      ELSE
         EVWGT=0.
         PP1=PHEP(4,IHAD1)+ABS(PHEP(3,IHAD1))
         PP2=PHEP(4,IHAD2)+ABS(PHEP(3,IHAD2))
         XX(1)=1.
         CALL HWRPOW(ET,EJ)
         EXY=EXP(HWRUNI(1,YJMIN,YJMAX))
         EXY2=2.*PP1/ET-EXY
         IF (EXY2.LE.EXP(YJMIN).OR.EXY2.GE.EXP(YJMAX)) RETURN
         XX(2)=PP1/(PP2*EXY*EXY2)
         IF (XX(2).LE.ZERO.OR.XX(2).GE.ONE) RETURN
         S=XX(2)*PP1*PP2
         T=-PP1*0.5*ET/EXY
         U=-S-T
         COSTH=(T-U)/S
C Set EMSCA to hard process scale (Approx ET-jet)
         EMSCA=SQRT(2.*S*T*U/(S*S+T*T+U*U))
         FACTR=-GEV2NB*0.5*EJ*(YJMAX-YJMIN)*ET*PIFAC*ALPHEM**2/(S*T)
         CALL HWSFUN(XX(2),EMSCA,IDHW(IHAD2),NSTRU,DISF(1,2),2)
         CTSU=-2.*(U/S+S/U)
      ENDIF
      HCS=0.
      ID1=59
      DO 20 ID2=1,12
      IF (DISF(ID2,2).LT.EPS) GOTO 20
      IF (ID2.LT.7) THEN
C photon+q ---> photon+q
         HCS=HCS+CTSU*DISF(ID2,2)*QFCH(ID2)**4
         IF (GENEV.AND.HCS.GT.RCS) CALL HWHQCP( 59,ID2,1432,66,*99)
      ELSE
C photon+qbar ---> photon+qbar
         HCS=HCS+CTSU*DISF(ID2,2)*QFCH(ID2-6)**4
         IF (GENEV.AND.HCS.GT.RCS) CALL HWHQCP( 59,ID2,1432,67,*99)
      ENDIF
  20  CONTINUE
      EVWGT=FACTR*HCS
      RETURN
C Generate event
  99  IDN(1)=ID1
      IDN(2)=ID2
      IDCMF=15
      CALL HWETWO
  999 END
CDECK  ID>, HWHQCD.
*CMZ :-        -20/05/99  12.39.45  by  Kosuke Odagiri
*-- Author :    Bryan Webber
C-----------------------------------------------------------------------
      SUBROUTINE HWHQCD
C-----------------------------------------------------------------------
C     QCD HARD 2->2 PROCESSES: MEAN EVWGT = SIGMA IN NB
C-----------------------------------------------------------------------
      INCLUDE 'HERWIG62.INC'
      DOUBLE PRECISION HWRGEN,HWRUNI,HWUALF,RS,EPS,HF,RCS,Z1,Z2,ET,EJ,
     & FACTR,S,T,U,ST,TU,US,STU,TUS,UST,EN,RN,GFLA,AF,ASTU,ASUT,AUST,
     & BF,BSTU,BSUT,BUST,BUTS,CF,CSTU,CSUT,CTSU,CTUS,DF,DSTU,DTSU,DUTS,
     & DIST,HCS,UT,SU,GT,KK,KK2,YJ1INF,YJ1SUP,YJ2INF,YJ2SUP
      INTEGER ID1,ID2,I
      EXTERNAL HWRGEN,HWRUNI,HWUALF
      SAVE HCS,ASTU,AUST,BSTU,BSUT,BUST,BUTS,CSTU,CSUT,CTSU,CTUS,
     & DSTU,DTSU,DUTS,GFLA,RCS,S,T,TU,U,US
      PARAMETER (EPS=1.E-9,HF=0.5)
      IF (GENEV) THEN
        RCS=HCS*HWRGEN(0)
      ELSE
        EVWGT=0.
        CALL HWRPOW(ET,EJ)
        KK = ET/PHEP(5,3)
        KK2=KK**2
        IF (KK.GE.ONE) RETURN
        YJ1INF = MAX( YJMIN, LOG((ONE-SQRT(ONE-KK2))/KK) )
        YJ1SUP = MIN( YJMAX, LOG((ONE+SQRT(ONE-KK2))/KK) )
        IF (YJ1INF.GE.YJ1SUP) RETURN
        Z1=EXP(HWRUNI(1,YJ1INF,YJ1SUP))
        YJ2INF = MAX( YJMIN, -LOG(TWO/KK-ONE/Z1) )
        YJ2SUP = MIN( YJMAX, LOG(TWO/KK-Z1) )
        IF (YJ2INF.GE.YJ2SUP) RETURN
        Z2=EXP(HWRUNI(2,YJ2INF,YJ2SUP))
        XX(1)=.5*(Z1+Z2)*KK
        IF (XX(1).GE.ONE) RETURN
        XX(2)=XX(1)/(Z1*Z2)
        IF (XX(2).GE.ONE) RETURN
        COSTH=(Z1-Z2)/(Z1+Z2)
        S=XX(1)*XX(2)*PHEP(5,3)**2
        RS=HF*SQRT(S)
        DO 3 I=1,NFLAV
        IF (RS.LT.RMASS(I)) GOTO 4
    3   CONTINUE
        I=NFLAV+1
    4   MAXFL=I-1
        IF (MAXFL.EQ.0) CALL HWWARN('HWHQCD',100,*999)
C
        T=-HF*S*(1.-COSTH)
        U=-S-T
C---SET EMSCA TO HARD PROCESS SCALE (APPROX ET-JET)
        EMSCA=SQRT(2.*S*T*U/(S*S+T*T+U*U))
        FACTR = GEV2NB*.5*PIFAC*EJ*ET*(HWUALF(1,EMSCA)/S)**2
     &        * (YJ1SUP-YJ1INF)*(YJ2SUP-YJ2INF)
        CALL HWSGEN(.FALSE.)
C
        ST=S/T
        TU=T/U
        US=U/S
        STU=TU/US
        TUS=US/ST
        UST=ST/TU
C
        EN=CAFAC
        RN=CFFAC/EN
        GFLA=HF*FLOAT(MAXFL)/(EN*RN)**2
        AF=FACTR*RN
        ASTU=AF*(1.-2.*UST)
        ASUT=AF*(1.-2.*STU)
        AUST=AF*(1.-2.*TUS)
C-----------------------------------------------------------------------
C---Colour decomposition modifications below (KO)
C-----------------------------------------------------------------------
        BF=HF-AF/EN/TUS/(ASTU+ASUT)
        BSTU=BF*ASTU
        BSUT=BF*ASUT
        BF=ONE-TWO*AF/EN/STU/(AUST+ASTU)
        BUST=BF*AUST
        BUTS=BF*ASTU
C-----------------------------------------------------------------------
C       BF=2.*AF/EN
C       BSTU=HF*(ASTU+BF*ST)
C       BSUT=HF*(ASUT+BF/US)
C       BUST=AUST+BF*US
C       BUTS=ASTU+BF/TU
C-----------------------------------------------------------------------
        CF=AF*EN
        CSTU=(CF*(RN-TUS))/TU
        CSUT=(CF*(RN-TUS))*TU
        CTSU=(FACTR*(UST-RN))*US
        CTUS=(FACTR*(UST-RN))/US
        DF=HF*FACTR/RN
        DSTU=DF*(1.+1./TUS-STU-UST)
        DTSU=DF*(1.+1./UST-STU-TUS)
        DUTS=DF*(1.+1./STU-UST-TUS)
      ENDIF
C
      HCS=0.
      DO 6 ID1=1,13
      IF (DISF(ID1,1).LT.EPS) GOTO 6
      DO 5 ID2=1,13
      IF (DISF(ID2,2).LT.EPS) GOTO 5
      DIST=DISF(ID1,1)*DISF(ID2,2)
      IF (ID1.LT.7) THEN
C---QUARK FIRST
       IF (ID2.LT.7) THEN
        IF (ID1.NE.ID2) THEN
         HCS=HCS+ASTU*DIST
         IF (GENEV.AND.HCS.GT.RCS) CALL HWHQCP(ID1,ID2,3421, 3,*9)
        ELSE
         HCS=HCS+BSTU*DIST
         IF (GENEV.AND.HCS.GT.RCS) CALL HWHQCP(ID1,ID2,3421, 1,*9)
         HCS=HCS+BSUT*DIST
         IF (GENEV.AND.HCS.GT.RCS) CALL HWHQCP(ID1,ID2,4312, 2,*9)
        ENDIF
       ELSEIF (ID2.NE.13) THEN
        IF (ID2.NE.ID1+6) THEN
         HCS=HCS+ASTU*DIST
         IF (GENEV.AND.HCS.GT.RCS) CALL HWHQCP(ID1,ID2,3142, 9,*9)
        ELSE
         HCS=HCS+FLOAT(MAXFL-1)*AUST*DIST
         IF (GENEV.AND.HCS.GT.RCS) CALL HWHQCP(-ID1, 0,2413, 4,*9)
         HCS=HCS+BUTS*DIST
         IF (GENEV.AND.HCS.GT.RCS) CALL HWHQCP(ID1,ID2,3142, 5,*9)
         HCS=HCS+BUST*DIST
         IF (GENEV.AND.HCS.GT.RCS) CALL HWHQCP(ID1,ID2,2413, 6,*9)
         HCS=HCS+CSTU*DIST
         IF (GENEV.AND.HCS.GT.RCS) CALL HWHQCP( 13, 13,2413, 7,*9)
         HCS=HCS+CSUT*DIST
         IF (GENEV.AND.HCS.GT.RCS) CALL HWHQCP( 13, 13,2341, 8,*9)
        ENDIF
       ELSE
         HCS=HCS+CTSU*DIST
         IF (GENEV.AND.HCS.GT.RCS) CALL HWHQCP(ID1,ID2,3142,10,*9)
         HCS=HCS+CTUS*DIST
         IF (GENEV.AND.HCS.GT.RCS) CALL HWHQCP(ID1,ID2,3421,11,*9)
       ENDIF
      ELSEIF (ID1.NE.13) THEN
C---QBAR FIRST
       IF (ID2.LT.7) THEN
        IF (ID1.NE.ID2+6) THEN
         HCS=HCS+ASTU*DIST
         IF (GENEV.AND.HCS.GT.RCS) CALL HWHQCP(ID1,ID2,2413,17,*9)
        ELSE
         HCS=HCS+FLOAT(MAXFL-1)*AUST*DIST
         IF (GENEV.AND.HCS.GT.RCS) CALL HWHQCP(-ID1, 0,3142,12,*9)
         HCS=HCS+BUTS*DIST
         IF (GENEV.AND.HCS.GT.RCS) CALL HWHQCP(ID1,ID2,2413,13,*9)
         HCS=HCS+BUST*DIST
         IF (GENEV.AND.HCS.GT.RCS) CALL HWHQCP(ID1,ID2,3142,14,*9)
         HCS=HCS+CSTU*DIST
         IF (GENEV.AND.HCS.GT.RCS) CALL HWHQCP( 13, 13,3142,15,*9)
         HCS=HCS+CSUT*DIST
         IF (GENEV.AND.HCS.GT.RCS) CALL HWHQCP( 13, 13,4123,16,*9)
        ENDIF
       ELSEIF (ID2.NE.13) THEN
        IF (ID1.NE.ID2) THEN
         HCS=HCS+ASTU*DIST
         IF (GENEV.AND.HCS.GT.RCS) CALL HWHQCP(ID1,ID2,4312,20,*9)
        ELSE
         HCS=HCS+BSTU*DIST
         IF (GENEV.AND.HCS.GT.RCS) CALL HWHQCP(ID1,ID2,4312,18,*9)
         HCS=HCS+BSUT*DIST
         IF (GENEV.AND.HCS.GT.RCS) CALL HWHQCP(ID1,ID2,3421,19,*9)
        ENDIF
       ELSE
         HCS=HCS+CTSU*DIST
         IF (GENEV.AND.HCS.GT.RCS) CALL HWHQCP(ID1,ID2,2413,21,*9)
         HCS=HCS+CTUS*DIST
         IF (GENEV.AND.HCS.GT.RCS) CALL HWHQCP(ID1,ID2,4312,22,*9)
       ENDIF
      ELSE
C---GLUON FIRST
       IF (ID2.LT.7) THEN
         HCS=HCS+CTSU*DIST
         IF (GENEV.AND.HCS.GT.RCS) CALL HWHQCP(ID1,ID2,2413,23,*9)
         HCS=HCS+CTUS*DIST
         IF (GENEV.AND.HCS.GT.RCS) CALL HWHQCP(ID1,ID2,3421,24,*9)
       ELSEIF (ID2.LT.13) THEN
         HCS=HCS+CTSU*DIST
         IF (GENEV.AND.HCS.GT.RCS) CALL HWHQCP(ID1,ID2,3142,25,*9)
         HCS=HCS+CTUS*DIST
         IF (GENEV.AND.HCS.GT.RCS) CALL HWHQCP(ID1,ID2,4312,26,*9)
       ELSE
         HCS=HCS+GFLA*CSTU*DIST
         IF (GENEV.AND.HCS.GT.RCS) CALL HWHQCP(  0,  0,2413,27,*9)
         HCS=HCS+GFLA*CSUT*DIST
         IF (GENEV.AND.HCS.GT.RCS) CALL HWHQCP(  0,  0,4123,28,*9)
         HCS=HCS+DTSU*DIST
         IF (GENEV.AND.HCS.GT.RCS) CALL HWHQCP(ID1,ID2,2341,29,*9)
         HCS=HCS+DSTU*DIST
         IF (GENEV.AND.HCS.GT.RCS) CALL HWHQCP(ID1,ID2,3421,30,*9)
         HCS=HCS+DUTS*DIST
         IF (GENEV.AND.HCS.GT.RCS) CALL HWHQCP(ID1,ID2,2413,31,*9)
       ENDIF
      ENDIF
    5 CONTINUE
    6 CONTINUE
      EVWGT=HCS
      RETURN
C---GENERATE EVENT
    9 IDN(1)=ID1
      IDN(2)=ID2
      IDCMF=15
      CALL HWETWO
      IF (AZSPIN) THEN
C Calculate coefficients for constructing spin density matrices
         IF (IHPRO.EQ.7 .OR.IHPRO.EQ.8 .OR.
     &       IHPRO.EQ.15.OR.IHPRO.EQ.16) THEN
C qqbar-->gg or qbarq-->gg
            UT=1./TU
            GCOEF(1)=UT+TU
            GCOEF(2)=-2.
            GCOEF(3)=0.
            GCOEF(4)=0.
            GCOEF(5)=GCOEF(1)
            GCOEF(6)=UT-TU
            GCOEF(7)=-GCOEF(6)
         ELSEIF (IHPRO.EQ.10.OR.IHPRO.EQ.11.OR.
     &           IHPRO.EQ.21.OR.IHPRO.EQ.22.OR.
     &           IHPRO.EQ.23.OR.IHPRO.EQ.24.OR.
     &           IHPRO.EQ.25.OR.IHPRO.EQ.26) THEN
C qg-->qg or qbarg-->qbarg or gq-->gq  or gqbar-->gqbar
            SU=1./US
            GCOEF(1)=-(SU+US)
            GCOEF(2)=0.
            GCOEF(3)=2.
            GCOEF(4)=0.
            GCOEF(5)=SU-US
            GCOEF(6)=GCOEF(1)
            GCOEF(7)=-GCOEF(5)
         ELSEIF (IHPRO.EQ.27.OR.IHPRO.EQ.28) THEN
C gg-->qqbar
            UT=1./TU
            GCOEF(1)=TU+UT
            GCOEF(2)=-2.
            GCOEF(3)=0.
            GCOEF(4)=0.
            GCOEF(5)=GCOEF(1)
            GCOEF(6)=TU-UT
            GCOEF(7)=-GCOEF(6)
         ELSEIF (IHPRO.EQ.29.OR.IHPRO.EQ.30.OR.
     &                          IHPRO.EQ.31) THEN
C gg-->gg
            GT=S*S+T*T+U*U
            GCOEF(2)=2.*U*U*T*T
            GCOEF(3)=2.*S*S*U*U
            GCOEF(4)=2.*S*S*T*T
            GCOEF(1)=GT*GT-GCOEF(2)-GCOEF(3)-GCOEF(4)
            GCOEF(5)=GT*(GT-2.*S*S)-GCOEF(2)
            GCOEF(6)=GT*(GT-2.*T*T)-GCOEF(3)
            GCOEF(7)=GT*(GT-2.*U*U)-GCOEF(4)
         ELSE
            CALL HWVZRO(7,GCOEF)
         ENDIF
      ENDIF
  999 END
CDECK  ID>, HWHQCP.
*CMZ :-        -26/04/91  10.18.57  by  Bryan Webber
*-- Author :    Bryan Webber
C-----------------------------------------------------------------------
      SUBROUTINE HWHQCP(ID3,ID4,IPERM,IHPR,*)
C-----------------------------------------------------------------------
C     IDENTIFIES HARD SUBPROCESS
C-----------------------------------------------------------------------
      INCLUDE 'HERWIG62.INC'
      INTEGER HWRINT,ID3,ID4,IPERM,IHPR,ND3
      EXTERNAL HWRINT
      IHPRO=IHPR
      IF (ID3.GT.0) THEN
        IDN(3)=ID3
        IDN(4)=ID4
      ELSE
        ND3=-ID3
        IF (ID3.GT.-7) THEN
    1     IDN(3)=HWRINT(1,MAXFL)
          IF (IDN(3).EQ.ND3) GOTO 1
          IDN(4)=IDN(3)+6
        ELSE
    2     IDN(3)=HWRINT(1,MAXFL)+6
          IF (IDN(3).EQ.ND3) GOTO 2
          IDN(4)=IDN(3)-6
        ENDIF
      ENDIF
      ICO(1)=IPERM/1000
      ICO(2)=IPERM/100-10*ICO(1)
      ICO(3)=IPERM/10 -10*(IPERM/100)
      ICO(4)=IPERM    -10*(IPERM/10)
      RETURN 1
      END
CDECK  ID>, HWHQPM.
*CMZ :-        -27/07/95  14.13.56  by  Mike Seymour
*-- Author :    Mike Seymour
C-----------------------------------------------------------------------
      SUBROUTINE HWHQPM
C     HARD PROCESS: GAMGAM --> QQBAR/LLBAR/W+W-
C     MEAN EVENT WEIGHT = CROSS-SECTION IN NB AFTER CUTS ON PT
C-----------------------------------------------------------------------
      INCLUDE 'HERWIG62.INC'
      DOUBLE PRECISION RCS,HCS,RS,S,EMSQ,BE,TMIN,TMAX,T,U,FACTR,Q,CFAC,
     $     HWRGEN
      INTEGER IHAD1,IHAD2,HQ,ID3,ID4,I1,I2
      SAVE HCS,FACTR,HQ,RS
      IHAD1=1
      IF (JDAHEP(1,IHAD1).NE.0) IHAD1=JDAHEP(1,IHAD1)
      IHAD2=2
      IF (JDAHEP(1,IHAD2).NE.0) IHAD2=JDAHEP(1,IHAD2)
      IF (GENEV) THEN
        RCS=HCS*HWRGEN(0)
      ELSE
        EVWGT=0.
        RS=PHEP(5,3)
        S=RS**2
        HQ=MOD(IPROC,100)
        IF (HQ.EQ.0) THEN
          EMSQ=0
          BE=1
          CFAC=3
        ELSE
          IF (HQ.GT.6) HQ=2*HQ+107
          IF (HQ.EQ.127) HQ=198
          EMSQ=RMASS(HQ)**2
          BE=1-4*EMSQ/S
          IF (BE.LT.ZERO) RETURN
          BE=SQRT(BE)
          CFAC=1
          IF (HQ.LE.6) CFAC=3
        ENDIF
        TMIN=S/2*(1-SQRT(MAX(1-4*(EMSQ+PTMIN**2)/S,ZERO)))
        TMAX=S/2*(1-SQRT(MAX(1-4*(EMSQ+PTMAX**2)/S,ZERO)))
        IF (TMIN.GE.TMAX) RETURN
        T=-(TMAX/TMIN)**HWRGEN(1)*TMIN
        IF (HWRGEN(2).GT.HALF) T=-S-T
        U=-S-T
        COSTH=(T-U)/(BE*S)
        EMSCA=SQRT(2.*S*T*U/(S*S+T*T+U*U))
        IF (HQ.NE.198) THEN
          FACTR=-GEV2NB*2*LOG(TMAX/TMIN)*MAX(T,U)
     $         *2*PIFAC*CFAC*ALPHEM**2/S**2
     $         *((U-4*EMSQ)/T+(T-4*EMSQ)/U-4*(EMSQ/T+EMSQ/U)**2)
        ELSE
          FACTR=-GEV2NB*2*LOG(TMAX/TMIN)*MAX(T,U)
     $         *6*PIFAC*CFAC*ALPHEM**2/S**2
     $         *(1-S/(T*U)*(4D0/3*S+2*EMSQ)
     $         +(S/(T*U))**2*(2D0/3*S**2+2*EMSQ**2))
        ENDIF
      ENDIF
      HCS=0.
      XX(1)=1.
      XX(2)=1.
      IF (HQ.EQ.0) THEN
        I1=1
        I2=6
      ELSE
        I1=HQ
        I2=HQ
      ENDIF
      DO 10 ID3=I1,I2
        IF (RS.GT.2*RMASS(ID3)) THEN
          Q=ICHRG(ID3)
          IF (HQ.LE.6) Q=Q/THREE
          ID4=ID3+6
          IF (HQ.EQ.198) ID4=199
          HCS=HCS+Q**4
          IF (GENEV.AND.HCS.GT.RCS) CALL HWHQCP(ID3,ID4,1243,61,*99)
        ENDIF
 10   CONTINUE
      EVWGT=FACTR*HCS
      RETURN
 99   IDN(1)=59
      IDN(2)=59
      IDCMF=15
      CALL HWETWO
      END
CDECK  ID>, HWHRBB.
*CMZ :-        -20/10/99  09:46:43  by  Peter Richardson
*-- Author :    Peter Richardson
C-----------------------------------------------------------------------
      SUBROUTINE HWHRBB
C-----------------------------------------------------------------------
C  Subroutine for 2 parton -> 2 parton via UDD resonant squarks
C-----------------------------------------------------------------------
      INCLUDE 'HERWIG62.INC'
      DOUBLE PRECISION HCS,S,RCS,HWRGEN,MQ1,MQ2,TAU,LOWTLM,UPPTLM,RTAB,
     &                 SQSH,MATELM,SCF(12),CHANPB(2),HWRUNI,PCM,MIX(12),
     &                 ME(2,3,3,3,3),WD,MS(12),SWD(12),RAND,TAUA,
     &                 CHAN(12),EPS,SH,FAC,TAUB,LAM(6,3,3,3,3),
     &                 XMIN,XMAX,XPOW,XUPP,MS2(12),MSWD(12)
      INTEGER I,J,K,L,I1,J1,K1,L1,N,THEP,CONECT(4,5),HWRINT,
     &        GENR,GN,MIG,MXG,GEN
      LOGICAL FIRST
      EXTERNAL HWRGEN,HWRUNI
      PARAMETER(EPS=1D-20)
      COMMON/HWRPIN/XMIN,XMAX,XPOW,FIRST
      SAVE HCS,ME,MS,SWD,CHAN,LAM,MIX,FAC,SH,SQSH,SCF,MS2,MSWD
      DATA CONECT/1,1,3,4,-1,-1,2,3,0,0,0,0,1,1,-2,-3,-1,-1,-3,-4/
      IF(GENEV) THEN
        RCS = HCS*HWRGEN(0)
      ELSE
        IF(FSTWGT) THEN
C--Extract masses and width's needed
          DO I=1,3
            MS(2*I-1)  = RMASS(399+2*I)
            MS(2*I)    = RMASS(411+2*I)
            MS(2*I+5)  = RMASS(400+2*I)
            MS(2*I+6)  = RMASS(412+2*I)
            SWD(2*I-1) = HBAR/RLTIM(399+2*I)
            SWD(2*I)   = HBAR/RLTIM(411+2*I)
            SWD(2*I+5) = HBAR/RLTIM(400+2*I)
            SWD(2*I+6) = HBAR/RLTIM(412+2*I)
          ENDDO
          DO I=1,12
             MS2(I)  = MS(I)**2
             MSWD(I) = MS(I)*SWD(I)
          ENDDO
C--Now set up the parmaters for multichannel integration
          RAND = ZERO
          DO K=1,3
            CHANPB(1) = ZERO
            CHANPB(2) = ZERO
            DO I=1,3
              DO J=1,3
                CHANPB(1)=CHANPB(1)+LAMDA3(I,J,K)**2
                CHANPB(2)=CHANPB(2)+LAMDA3(K,I,J)**2
              ENDDO
            ENDDO
            RAND=RAND+CHANPB(1)+CHANPB(2)
            DO J=1,2
              CHAN(2*K-2+J) = CHANPB(1)*QMIXSS(2*K-1,2,J)**2
              CHAN(2*K+4+J) = CHANPB(2)*QMIXSS(2*K  ,2,J)**2
              MIX(2*K-2+J) = QMIXSS(2*K-1,2,J)**2
              MIX(2*K+4+J) = QMIXSS(2*K,2,J)**2
            ENDDO
          ENDDO
          IF(RAND.GT.ZERO) THEN
            DO I=1,12
              CHAN(I)=CHAN(I)/RAND
            ENDDO
          ELSE
            HCS =ZERO
            CALL HWWARN('HWHRBB',500,*999)
          ENDIF
C--find the couplings
          DO GN=1,3
            DO I=1,3
              DO J=1,3
                DO K=1,3
                  DO L=1,3
                    LAM(GN,I,J,K,L)  =LAMDA3(I,J,GN)*LAMDA3(K,L,GN)
                    LAM(GN+3,I,J,K,L)=LAMDA3(GN,I,J)*LAMDA3(GN,K,L)
                  ENDDO
                ENDDO
              ENDDO
            ENDDO
          ENDDO
        ENDIF
        EVWGT = ZERO
        S     = PHEP(5,3)**2
        COSTH = HWRUNI(0,-ONE,ONE)
C--Generate the smoothing
        RAND=HWRUNI(0,ZERO,ONE)
        DO I=1,12
          IF(CHAN(I).GT.RAND) GOTO 20
          RAND=RAND-CHAN(I)
        ENDDO
 20     GENR=I
C--Calculate hard scale and obtain parton distributions
        TAUA   = MS2(GENR)/S
        TAUB   = SWD(GENR)**2/S
        RTAB   = SQRT(TAUA*TAUB)
        XUPP = XMAX
        IF(XMAX**2.GT.S) XUPP = SQRT(S)
        LOWTLM = DATAN((XMIN**2/S-TAUA)/RTAB)/RTAB
        UPPTLM = DATAN((XUPP**2/S-TAUA)/RTAB)/RTAB
        TAU    = HWRUNI(0,LOWTLM,UPPTLM)
        TAU    = RTAB*TAN(RTAB*TAU)+TAUA
        SH     = S*TAU
        SQSH   = SQRT(SH)
        EMSCA  = SQSH
        XX(1)  = EXP(HWRUNI(0,ZERO,LOG(TAU)))
        XX(2)  = TAU/XX(1)
        CALL HWSGEN(.FALSE.)
C--Calculate the prefactor due multichannel approach
        FAC = ZERO
        DO GN=1,12
         SCF(GN)=1/((SH-MS2(GN))**2+MSWD(GN)**2)
         FAC=FAC+CHAN(GN)*SCF(GN)
        ENDDO
        FAC=-(UPPTLM-LOWTLM)*LOG(TAU)*GEV2NB
     &        /(24*PIFAC*SQSH*SH*TAU*FAC*S**2)
      ENDIF
C--loop over the quarks
      HCS = ZERO
C--temp mod
      DO GN=1,2
        IF(GN.EQ.1) THEN
          MIG = 1
          MXG = 6
        ELSE
          MIG = 7
          MXG = 12
        ENDIF
        DO K1=1,3
          DO 70 L1=1,3
            IF(GN.EQ.1) THEN
              K = 2*K1
              L = 2*L1-1
            ELSE
              K=2*K1-1
              L=2*L1-1
              IF(GN.EQ.2.AND.L1.GE.K1) GOTO 70
            ENDIF
            MQ1=RMASS(K)
            MQ2=RMASS(L)
            IF(SQSH.GT.(MQ1+MQ2)) THEN
              PCM=SQRT((SH-(MQ1+MQ2)**2)*(SH-(MQ1-MQ2)**2)/(4*SH))
              WD = SH*(SH-MQ1**2-MQ2**2)*PCM
            ELSE
              GOTO 70
            ENDIF
            DO I1=1,3
              DO 60 J1=1,3
                IF(GN.EQ.1) THEN
                  I = 2*I1
                  J = 2*J1-1
                ELSE
                  I=2*I1-1
                  J=2*J1-1
                  IF(J1.GT.I1) GOTO 60
                ENDIF
                IF(GENEV) GOTO 50
                MATELM = ZERO
                DO 40 GEN=MIG,MXG
                  IF(ABS(MIX(GEN)).LT.EPS.OR.
     &             ABS(LAM(INT((GEN+1)/2),I1,J1,K1,L1)).LT.EPS) GOTO 40
                  DO 30 GENR=MIG,MXG
                    IF(ABS(LAM(INT((GENR+1)/2),I1,J1,K1,L1)).LT.EPS.
     &                OR.ABS(MIX(GENR)).LT.EPS) GOTO 30
                    MATELM =MATELM+SCF(GEN)*SCF(GENR)*WD*
     &                  ((SH-MS2(GEN))*(SH-MS2(GENR))+
     &                  MSWD(GEN)*MSWD(GENR))
     &                  *LAM(INT((GEN+1)/2),I1,J1,K1,L1)*MIX(GEN)
     &                  *LAM(INT((GENR+1)/2),I1,J1,K1,L1)*MIX(GENR)
 30               CONTINUE
 40             CONTINUE
                ME(GN,I1,J1,K1,L1) = MATELM*FAC
C--Add up the term to get the cross-section
 50             HCS = HCS+ME(GN,I1,J1,K1,L1)*DISF(I,1)*DISF(J,2)
                IF(HCS.GT.RCS.AND.GENEV)
     &                           CALL HWHRSS(1,I,J,K,L,0,0,*100)
                HCS = HCS+ME(GN,I1,J1,K1,L1)*DISF(J,1)*DISF(I,2)
                IF(HCS.GT.RCS.AND.GENEV)
     &                           CALL HWHRSS(2,J,I,K,L,0,0,*100)
                HCS = HCS+ME(GN,I1,J1,K1,L1)*DISF(I+6,1)*DISF(J+6,2)
                IF(HCS.GT.RCS.AND.GENEV)
     &                           CALL HWHRSS(1,I,J,K,L,1,0,*100)
                HCS = HCS+ME(GN,I1,J1,K1,L1)*DISF(J+6,1)*DISF(I+6,2)
                IF(HCS.GT.RCS.AND.GENEV)
     &                           CALL HWHRSS(2,J,I,K,L,1,0,*100)
 60           CONTINUE
            ENDDO
 70       CONTINUE
        ENDDO
      ENDDO
 100  IF(GENEV) THEN
        CALL HWETWO
C--first stage of the colour connection corrections
        DO THEP=1,5
          IF(THEP.NE.3) THEN
            JMOHEP(2,THEP+NHEP-5)=NHEP-5+THEP+CONECT(HWRINT(1,4),THEP)
            JDAHEP(2,THEP+NHEP-5) = JMOHEP(2,THEP+NHEP-5)
          ENDIF
        ENDDO
        THEP = NHEP-4
        IF(HWRINT(1,2).EQ.1) THEN
          HRDCOL(2,1) = THEP+3
          HRDCOL(2,2) = THEP+4
          HRDCOL(1,4) = THEP
          HRDCOL(1,5) = THEP+1
        ELSE
          HRDCOL(2,1) = THEP+4
          HRDCOL(2,2) = THEP+3
          HRDCOL(1,4) = THEP+1
          HRDCOL(1,5) = THEP
        ENDIF
        DO N=1,5
          IF(N.LE.2) THEN
            HRDCOL(1,N)=HRDCOL(2,N)
          ELSEIF(N.GE.4) THEN
            HRDCOL(2,N)=HRDCOL(1,N)
          ENDIF
        ENDDO
        HRDCOL(1,3) = 4
        COLUPD = .TRUE.
      ELSE
        EVWGT = HCS
      ENDIF
 999  END
CDECK  ID>, HWHRBS.
*CMZ :-        -20/10/99  09:46:43  by  Peter Richardson
*-- Author :    Peter Richardson
C-----------------------------------------------------------------------
      SUBROUTINE HWHRBS
C-----------------------------------------------------------------------
C  Subroutine for 2 parton -> parton SUSY particle via UDD resonant
C  squarks.
C-----------------------------------------------------------------------
      INCLUDE 'HERWIG62.INC'
      DOUBLE PRECISION HCS,S,RCS,HWRGEN,ME(4),CW,MER(6),MZ,TAU,TAUA,
     &                 TAUB,LOWTLM,UPPTLM,HWRUNI,SH,SQSH,SCF(12),MW2,
     &                 LAMC(3),CHANPB(2),PCM,ECM,RAND,MEN(7,6,3,3),
     &                 MEC(2,6,3,3),RTAB,MS(12),SWD(12),AS,HWUALF,
     &                 MQ,MN,MQS,SIN2B,TH,UH,FAC,MX(14),CHAN(12),MC(2),
     &                 MNS,HWUAEM,SW,G,EC,MW,A(7,14),B(7,14),EPS,XUPP,
     &                 MEH(3,42),XMIN,XMAX,XPOW,FAC2,MH(4),ZSQU(2,2),
     &                 ZQRK(2),MZ2,GUU(4),GDD(4),ME2,MS2(12),MSWD(12)
      INTEGER I,J,K,I1,J1,GEN,THEP,HWRINT,L,GT,GU,GR,I2,
     &        CONECT(2,6,5),GN,GENR,SP,SPMN,SPMX,CON,CHARMN,CHARMX,
     &        CM,CN
      LOGICAL RAD,NEUT,CHAR,HIGGS,FIRST
      EXTERNAL HWRGEN,HWRUNI,HWUAEM,HWUALF,HWRINT
      COMMON/HWRPIN/XMIN,XMAX,XPOW,FIRST
      SAVE HCS,MS,SWD,MX,CHAN,A,B,SPMN,SPMX,RAD,MEN,MEC,HIGGS,
     &     CHARMN,CHARMX,NEUT,CHAR,SQSH,MEH,SW,CW,MW,MZ,MER,SH,MH,
     &     AS,EC,FAC,G,SCF,ZSQU,ZQRK,MW2,MZ2,MS2,MSWD
      PARAMETER(EPS=1D-20)
      DATA CONECT/ 4, 4, 2, 3, 0, 0, 1,-2,-1,-3,-4,-4,
     &             3, 4, 3, 3, 0, 0, 1,-3,-1,-4,-3,-3,
     &             1, 4,-1, 3, 0, 0, 1, 1,-3,-4,-1,-1,
     &             1, 3,-1, 2, 0, 0,-3,-2, 0, 0, 0, 0,
     &             1, 4,-1, 3, 0, 0,-3,-2,-1,-1,-1,-1/
      IF(GENEV) THEN
        RCS = HCS*HWRGEN(0)
      ELSE
        IF(FSTWGT) THEN
C--Extract masses and width's needed
          DO I=1,3
            MS(2*I-1) = RMASS(399+2*I)
            MS(2*I)   = RMASS(411+2*I)
            MS(2*I+5) = RMASS(400+2*I)
            MS(2*I+6) = RMASS(412+2*I)
            SWD(2*I-1) = HBAR/RLTIM(399+2*I)
            SWD(2*I)   = HBAR/RLTIM(411+2*I)
            SWD(2*I+5) = HBAR/RLTIM(400+2*I)
            SWD(2*I+6) = HBAR/RLTIM(412+2*I)
          ENDDO
          DO I=1,12
             MS2(I)  = MS(I)**2
             MSWD(I) = MS(I)*SWD(I)
          ENDDO
C--Electroweak parameters
          SW = SQRT(SWEIN)
          CW = SQRT(1-SWEIN)
          MW    = RMASS(198)
          MZ    = RMASS(200)
          MW2   = MW**2
          MZ2   = MZ**2
          SIN2B = TWO*SINB*COSB
C--Now set up the parmaters for multichannel integration
          RAND = ZERO
          DO K=1,3
            CHANPB(1) = ZERO
            CHANPB(2) = ZERO
            DO I=1,3
              DO J=1,3
                CHANPB(1)=CHANPB(1)+LAMDA3(I,J,K)**2
                CHANPB(2)=CHANPB(2)+LAMDA3(K,I,J)**2
              ENDDO
            ENDDO
            RAND=RAND+CHANPB(1)+CHANPB(2)
            DO J=1,2
              CHAN(2*K-2+J) = CHANPB(1)*QMIXSS(2*K-1,2,J)**2
              CHAN(2*K+4+J) = CHANPB(2)*QMIXSS(2*K  ,2,J)**2
              MX(2*K-2+J) = QMIXSS(2*K-1,2,J)
              MX(2*K+4+J) = QMIXSS(2*K,2,J)
            ENDDO
            MX(13) = ZERO
            MX(14) = ZERO
          ENDDO
          IF(RAND.GT.ZERO) THEN
            DO I=1,12
              CHAN(I)=CHAN(I)/RAND
            ENDDO
          ELSE
            CALL HWWARN('HWHRBS',500,*999)
          ENDIF
C--Couplings we need for the various processes
C--Gluino
          DO I=1,3
            DO J=1,2
              A(1,2*I-2+J) =  QMIXSS(2*I-1,2,J)
              B(1,2*I-2+J) = -QMIXSS(2*I-1,1,J)
              A(1,2*I+4+J) =  QMIXSS(2*I,2,J)
              B(1,2*I+4+J) = -QMIXSS(2*I,1,J)
            ENDDO
          ENDDO
C--Now the neutralinos
          DO L=1,4
            MC(1) =  ZMIXSS(L,3)/(2*MW*COSB*SW)
            MC(2) =  ZMIXSS(L,4)/(2*MW*SINB*SW)
            DO I=1,3
              DO J=1,2
                A(L+1,2*I-2+J) = ZSGNSS(L)*(MC(1)*QMIXSS(2*I-1,1,J)*
     &                    RMASS(2*I-1)+SRFCH(2*I-1,L)*QMIXSS(2*I-1,2,J))
                B(L+1,2*I-2+J) = MC(1)*QMIXSS(2*I-1,2,J)*
     &                    RMASS(2*I-1)+SLFCH(2*I-1,L)*QMIXSS(2*I-1,1,J)
                A(L+1,2*I+4+J) = ZSGNSS(L)*(MC(2)*QMIXSS(2*I,1,J)*
     &                    RMASS(2*I)+SRFCH(2*I  ,L)*QMIXSS(2*I,2,J))
                B(L+1,2*I+4+J) = MC(2)*QMIXSS(2*I,2,J)*
     &                    RMASS(2*I)+SLFCH(2*I,  L)*QMIXSS(2*I,1,J)
              ENDDO
            ENDDO
          ENDDO
C--Now for the charginos
          DO L=1,2
            MC(1) = 1/(SQRT(2.0D0)*MW*COSB)
            MC(2) = 1/(SQRT(2.0D0)*MW*SINB)
            DO I=1,3
              DO J=1,2
                A(5+L,2*I-2+J) = -WSGNSS(L)*WMXVSS(L,2)*MC(2)*
     &                            RMASS(2*I)*QMIXSS(2*I-1,1,J)
                B(5+L,2*I-2+J) = WMXUSS(L,1)*QMIXSS(2*I-1,1,J)
     &              -WMXUSS(L,2)*MC(1)*RMASS(2*I-1)*QMIXSS(2*I-1,2,J)
                A(5+L,2*I+4+J) = -WMXUSS(L,2)*MC(1)*RMASS(2*I-1)
     &                            *QMIXSS(2*I,1,J)
                B(5+L,2*I+4+J) = WSGNSS(L)*(WMXVSS(L,1)*QMIXSS(2*I,1,J)
     &              -WMXVSS(L,2)*MC(2)*RMASS(2*I)*QMIXSS(2*I,2,J))
              ENDDO
            ENDDO
          ENDDO
C--Zero couplings
          DO I=1,7
            A(I,13) = ZERO
            B(I,13) = ZERO
            A(I,14) = ZERO
            B(I,14) = ZERO
          ENDDO
C--Couplings to the Z boson of squarks and right-handed quarks
          ZQRK(1)   = -SW**2/6.0D0/CW
          ZQRK(2)   =  SW**2/3.0D0/CW
          ZSQU(1,1) =  HALF*(QMIXSS(5,1,1)**2-2.0D0*SW**2/3.0D0)/CW
          ZSQU(1,2) =  HALF*QMIXSS(5,1,1)*QMIXSS(5,1,2)/CW
          ZSQU(2,1) = -HALF*(QMIXSS(6,1,1)**2-4.0D0*SW**2/3.0D0)/CW
          ZSQU(2,2) = -HALF*QMIXSS(6,1,1)*QMIXSS(6,1,2)/CW
C--Higgs Masses
          DO I=1,4
            MH(I) = RMASS(202+I)
          ENDDO
C--Higgs couplings to quarks
          DO I=1,3
            GUU(I) = GHUUSS(I)**2*HALF**2/MW2
            GDD(I) = GHDDSS(I)**2*HALF**2/MW2
          ENDDO
          GUU(4) = ONE/TANB**2/MW2/8.0D0
          GDD(4) = ONE*TANB**2/MW2/8.0D0
C--decide which processes to generate from IPROC
          RAD   = .FALSE.
          NEUT  = .FALSE.
          CHAR  = .FALSE.
          HIGGS = .FALSE.
          SPMN = 1
          SPMX = 5
          CHARMN = 1
          CHARMX = 2
          IF(IPROC.EQ.4100) THEN
            RAD   = .TRUE.
            NEUT  = .TRUE.
            CHAR  = .TRUE.
            HIGGS = .TRUE.
          ELSEIF(IPROC.LT.4120) THEN
            SPMN = 2
            IF(IPROC.NE.4110) THEN
              SPMN = MOD(IPROC,10)+1
              SPMX = SPMN
            ENDIF
            NEUT=.TRUE.
          ELSEIF(IPROC.LT.4130) THEN
            IF(IPROC.NE.4120) THEN
              CHARMN = MOD(IPROC,10)
              CHARMX=CHARMN
            ENDIF
            CHAR = .TRUE.
          ELSEIF(IPROC.EQ.4130) THEN
            SPMX = 1
            NEUT=.TRUE.
          ELSEIF(IPROC.EQ.4140) THEN
            RAD = .TRUE.
          ELSEIF(IPROC.EQ.4150) THEN
            HIGGS = .TRUE.
          ELSE
            CALL HWWARN('HWHRBS',501,*999)
          ENDIF
        ENDIF
        EVWGT = ZERO
        S     = PHEP(5,3)**2
        COSTH = HWRUNI(0,-ONE,ONE)
C--zero the array
        DO I=1,6
          DO J=1,3
            DO K=1,3
              DO L=1,7
                MEN(L,I,J,K)=ZERO
              ENDDO
              DO L=1,2
                MEC(L,I,J,K)=ZERO
              ENDDO
            ENDDO
          ENDDO
        ENDDO
C--Multichannel peak
        RAND=HWRUNI(0,ZERO,ONE)
        DO I=1,12
          IF(CHAN(I).GT.RAND) GOTO 25
          RAND=RAND-CHAN(I)
        ENDDO
 25     GENR=I
C--Calculate the hard scale and obtain parton distributions
        TAUA   = MS2(GENR)/S
        TAUB   = SWD(GENR)**2/S
        RTAB   = SQRT(TAUA*TAUB)
        XUPP = XMAX
        IF(XMAX**2.GT.S) XUPP = SQRT(S)
        LOWTLM = DATAN((XMIN**2/S-TAUA)/RTAB)/RTAB
        UPPTLM = DATAN((XUPP**2/S-TAUA)/RTAB)/RTAB
        TAU    = HWRUNI(0,LOWTLM,UPPTLM)
        TAU    = RTAB*TAN(RTAB*TAU)+TAUA
        SH   = S*TAU
        SQSH = SQRT(SH)
        EMSCA  = SQSH
        XX(1)  = EXP(HWRUNI(0,ZERO,LOG(TAU)))
        XX(2)  = TAU/XX(1)
        CALL HWSGEN(.FALSE.)
C--Strong, EM coupling and weak couplings
        AS = HWUALF(1,EMSCA)
        EC = SQRT(4*PIFAC*HWUAEM(SH))
        G  = EC/SW
C--Calculate the prefactor due multichannel approach
        FAC = ZERO
        DO GN=1,12
         SCF(GN)=1/((SH-MS2(GN))**2+MSWD(GN)**2)
         FAC=FAC+CHAN(GN)*SCF(GN)
        ENDDO
        FAC=-(UPPTLM-LOWTLM)*LOG(TAU)*GEV2NB
     &        /(48*PIFAC*SQSH*SH*TAU*FAC*S**2)
      ENDIF
      HCS = ZERO
      IF(.NOT.NEUT) GOTO 200
      DO 140 GN=1,6
        GR=2*GN
        IF(CHAN(GR).LT.EPS) GOTO 140
        DO 130 L=SPMN,SPMX
          K = 2*GN+5
          IF(GN.GT.3) K = 2*GN
          MQ = RMASS(K)
          MN = ABS(RMASS(448+L))
          MQS = MQ**2
          MNS = MN**2
          IF(SQSH.LT.(MQ+MN)) GOTO 130
          PCM=SQRT((SH-(MQ+MN)**2)*(SH-(MQ-MN)**2)/(4*SH))
          ECM=SQRT(PCM**2+MQS)
          TH = MQS-SQSH*(ECM-PCM*COSTH)
          UH = MQS-SQSH*(ECM+PCM*COSTH)
          DO I=1,3
            DO 120 J=1,3
              IF(GN.LE.3) THEN
                GU = 6+2*I
                I1 = 2*I
                LAMC(1) = LAMDA3(I,J,GN)**2
              ELSE
                GU = 2*I
                I1 = 2*I-1
                LAMC(1) = LAMDA3(GN-3,I,J)**2
                IF(J.GT.I) LAMC(1) = ZERO
              ENDIF
              GT = 2*J
              J1 = 2*J-1
C--Now the matrix elements
              IF(LAMC(1).LT.EPS) GOTO 120
              IF(GENEV) GOTO 110
C--S channel
              ME(3) = MX(GR)**2*SCF(GR)*SH*((SH-MQS-MNS)*(A(L,GR)**2+
     &                 B(L,GR)**2)-4*MQ*MN*A(L,GR)*B(L,GR))
              ME(4) =-TWO*MX(GU)*MX(GT)*(MQS*MNS-UH*TH)*A(L,GT)*A(L,GU)
     &                 /(TH-MS2(GT))/(UH-MS2(GU))
     &               +TWO*MX(GR)*MX(GU)*(SH-MS2(GR))*SCF(GR)*SH*
     &                 A(L,GU)*(A(L,GR)*UH+B(L,GR)*MQ*MN)/(UH-MS2(GU))
     &               +TWO*MX(GR)*MX(GT)*(SH-MS2(GR))*SCF(GR)*SH*
     &                 A(L,GT)*(A(L,GR)*TH+B(L,GR)*MQ*MN)/(TH-MS2(GT))
C--L/R s channel and interference
              IF(ABS(MX(GR-1)).GT.EPS) THEN
                ME(3) = ME(3)+
     &             MX(GR-1)**2*SCF(GR-1)*SH*((SH-MQS-MNS)*(A(L,GR-1)**2
     &                +B(L,GR-1)**2)-4*MQ*MN*A(L,GR-1)*B(L,GR-1))
     &            +TWO*MX(GR)*MX(GR-1)*SCF(GR)*SCF(GR-1)*SH*
     &                ((SH-MS2(GR))*(SH-MS2(GR-1))+MSWD(GR)*MSWD(GR-1))*
     &                ((SH-MQS-MNS)*(A(L,GR)*A(L,GR-1)
     &                +B(L,GR)*B(L,GR-1))
     &                -TWO*MQ*MN*(A(L,GR)*B(L,GR-1)+A(L,GR-1)*B(L,GR)))
               ME(4) = ME(4)+TWO*MX(GR-1)*MX(GU)*(SH-MS2(GR-1))
     &           *SCF(GR-1)*A(L,GU)*SH*(A(L,GR-1)*UH+B(L,GR-1)*MQ*MN)
     &            /(UH-MS2(GU))
     &          +TWO*MX(GR-1)*MX(GT)*(SH-MS2(GR-1))*SCF(GR-1)*SH*
     &            A(L,GT)*(A(L,GR-1)*TH+B(L,GR-1)*MQ*MN)/(TH-MS2(GT))
                IF(ABS(MX(GU-1)).GT.EPS) ME(4)=ME(4)+TWO*MX(GR-1)*
     &                MX(GU-1)*(SH-MS2(GR-1))*SCF(GR-1)*A(L,GU-1)*SH*(
     &                A(L,GR-1)*UH+B(L,GR-1)*MQ*MN)/(UH-MS2(GU-1))
                IF(ABS(MX(GT-1)).GT.EPS) ME(4)=ME(4)+TWO*MX(GR-1)*
     &                MX(GT-1)*(SH-MS2(GR-1))*SCF(GR-1)*A(L,GT-1)*SH*
     &                (A(L,GR-1)*TH+B(L,GR-1)*MQ*MN)/(TH-MS2(GT-1))
              ENDIF
C--u channel and L/R mixing
              ME(1)= MX(GU)**2*(MQS-UH)*(MNS-UH)*
     &               (A(L,GU)**2+B(L,GU)**2)/(UH-MS2(GU))**2
              IF(ABS(MX(GU-1)).GT.EPS) THEN
                ME(1) = ME(1)+MX(GU-1)**2*(MQS-UH)*(MNS-UH)*
     &                   (A(L,GU-1)**2+B(L,GU-1)**2)/(UH-MS2(GU-1))**2
     &                 +TWO*MX(GU)*MX(GU-1)*(MQS-UH)*(MNS-UH)*
     &                   (A(L,GU)*A(L,GU-1)+B(L,GU)*B(L,GU-1))
     &                   /(UH-MS2(GU))/(UH-MS2(GU-1))
                ME(4) =ME(4)+TWO*MX(GR)*MX(GU-1)*(SH-MS2(GR))*
     &                   SCF(GR)*A(L,GU-1)*SH*(A(L,GR)*UH+B(L,GR)*MQ*MN)
     &                   /(UH-MS2(GU-1))
     &                -2*MX(GU-1)*MX(GT)*(MQS*MNS-UH*TH)*A(L,GT)*
     &                   A(L,GU-1)/(TH-MS2(GT))/(UH-MS2(GU-1))
                IF(ABS(MX(GT-1)).GT.EPS) ME(4)=ME(4)-2*MX(GU-1)*MX(GT-1)
     &               *(MQS*MNS-UH*TH)*A(L,GT-1)*A(L,GU-1)
     &               /(TH-MS2(GT-1))/(UH-MS2(GU-1))
              ENDIF
C--t channel and t channel L/R mixing
              ME(2) = MX(GT)**2*(MQS-TH)*(MNS-TH)*
     &                  (A(L,GT)**2+B(L,GT)**2)/(TH-MS2(GT))**2
              IF(ABS(MX(GT-1)).GT.EPS) THEN
                ME(2) = ME(2)+MX(GT-1)**2*(MQS-TH)*(MNS-TH)*
     &                   (A(L,GT-1)**2+B(L,GT-1)**2)/(TH-MS2(GT-1))**2
     &                 +TWO*MX(GT)*MX(GT-1)*(MQS-TH)*(MNS-TH)*(A(L,GT)*
     &                   A(L,GT-1)+ B(L,GT)*B(L,GT-1))
     &                   /(TH-MS2(GT))/(TH-MS2(GT-1))
                ME(4)=ME(4)-TWO*MX(GU)*MX(GT-1)*(MQS*MNS-UH*TH)*
     &                 A(L,GT-1)*A(L,GU)/(TH-MS2(GT-1))/(UH-MS2(GU))
     &               +TWO*MX(GR)*MX(GT-1)*(SH-MS2(GR))*SCF(GR)*
     &                 A(L,GT-1)*SH*(A(L,GR)*TH+B(L,GR)*MQ*MN)
     &                 /(TH-MS2(GT-1))
              ENDIF
C--Angular ordering and the phase space factors
              IF(L.EQ.1) THEN
               ME(4)=-HALF*ME(4)/(ME(1)+ME(2)+ME(3))
               LAMC(1) = 32.0D0*LAMC(1)*AS*PIFAC/THREE
               DO GEN=1,3
                 MEN(GEN,GN,I,J) = FAC*PCM*LAMC(1)*ME(GEN)*(ONE+ME(4))
               ENDDO
              ELSE
               LAMC(1) = TWO*LAMC(1)*EC**2
               MEN(L+2,GN,I,J)=FAC*PCM*LAMC(1)*(ME(1)+ME(2)+ME(3)+ME(4))
              ENDIF
C--Multiply by the pdf's
 110          IF(L.EQ.1) THEN
                CM = 1
                CN = 3
              ELSE
                CM = L+2
                CN = L+2
              ENDIF
              DO GEN=CM,CN
              CON = 4
              IF(GEN.LE.3) CON = GEN
           HCS=HCS+MEN(GEN,GN,I,J)*DISF(I1,1)*DISF(J1,2)
           IF(GENEV.AND.HCS.GT.RCS) CALL HWHRSS(3,I1,J1,K,GEN,0,0,*900)
           HCS=HCS+MEN(GEN,GN,I,J)*DISF(J1,1)*DISF(I1,2)
           IF(GENEV.AND.HCS.GT.RCS) CALL HWHRSS(4,J1,I1,K,GEN,0,0,*900)
           HCS=HCS+MEN(GEN,GN,I,J)*DISF(I1+6,1)*DISF(J1+6,2)
           IF(GENEV.AND.HCS.GT.RCS) CALL HWHRSS(3,I1,J1,K,GEN,1,0,*900)
           HCS=HCS+MEN(GEN,GN,I,J)*DISF(J1+6,1)*DISF(I1+6,2)
           IF(GENEV.AND.HCS.GT.RCS) CALL HWHRSS(4,J1,I1,K,GEN,1,0,*900)
              ENDDO
 120        CONTINUE
          ENDDO
 130    CONTINUE
 140  CONTINUE
C--Now the chargino processes if wanted
 200  IF(.NOT.CHAR) GOTO 300
        DO 240 GN=1,6
          GR=2*GN
          IF(CHAN(GR).LT.EPS) GOTO 240
          DO 230 L=CHARMN,CHARMX
          SP =5+L
          K = 2*GN+6
          IF(GN.GT.3) K = 2*GN-1
          MQ = RMASS(K)
          MN = ABS(RMASS(453+L))
          MQS = MQ**2
          MNS = MN**2
          IF(SQSH.LT.(MQ+MN)) GOTO 230
          PCM=SQRT((SH-(MQ+MN)**2)*(SH-(MQ-MN)**2)/(4*SH))
          ECM=SQRT(PCM**2+MQS)
          TH = MQS-SQSH*(ECM-PCM*COSTH)
          UH = MQS-SQSH*(ECM+PCM*COSTH)
          DO I=1,3
            DO 220 J=1,3
              IF(GN.LE.3) THEN
                GU = 2*I
                GT = 14
                I1 = 2*I
                LAMC(1) = LAMDA3(I,J,GN)
                LAMC(2) = LAMDA3(GN,I,J)
                LAMC(3) = ZERO
              ELSE
                GU = 6+2*I
                GT = 6+2*J
                I1 = 2*I-1
                LAMC(1) = LAMDA3(GN-3,I,J)
                LAMC(2) = LAMDA3(I,J,GN-3)
                LAMC(3) = LAMDA3(J,GN-3,I)
                IF(J.GT.I) LAMC(1) = ZERO
              ENDIF
              J1 = 2*J-1
              IF(ABS(LAMC(1)).LT.EPS) GOTO 220
              IF(GENEV) GOTO 210
C--Matrix element
C--S channel
              ME(1) = LAMC(1)**2*MX(GR)**2*SCF(GR)*SH*((SH-MQS-MNS)*
     &              (A(SP,GR)**2+B(SP,GR)**2)-4*MQ*MN*A(SP,GR)*B(SP,GR))
              IF(ABS(MX(GU)).GT.EPS) THEN
                ME(1) = ME(1)+LAMC(2)**2*MX(GU)**2*(MQS-UH)*(MNS-UH)*
     &                       (A(SP,GU)**2+B(SP,GU)**2)/(UH-MS2(GU))**2
     &                 +LAMC(1)*LAMC(2)*TWO*MX(GR)*MX(GU)*
     &                       (SH-MS2(GR))*SCF(GR)*A(SP,GU)*SH*
     &                       (A(SP,GR)*UH+B(SP,GR)*MQ*MN)/(UH-MS2(GU))
                IF(ABS(MX(GT)).GT.EPS) ME(1) = ME(1)-LAMC(2)*LAMC(3)*
     &                       TWO*MX(GU)*MX(GT)*(MQS*MNS-UH*TH)*A(SP,GT)*
     &                       A(SP,GU)/(TH-MS2(GT))/(UH-MS2(GU))
             ENDIF
             IF(ABS(MX(GT)).GT.EPS) THEN
               ME(1) = ME(1)+LAMC(3)**2*MX(GT)**2*(MQS-TH)*(MNS-TH)*
     &                       (A(SP,GT)**2+B(SP,GT)**2)/(TH-MS2(GT))**2
     &                +LAMC(1)*LAMC(3)*TWO*MX(GR)*MX(GT)*
     &                       (SH-MS2(GR))*SCF(GR)*A(SP,GT)*SH*
     &                       (A(SP,GR)*TH+B(SP,GR)*MQ*MN)/(TH-MS2(GT))
             ENDIF
c--L/R s channel and interference
              IF(ABS(MX(GR-1)).GT.EPS) THEN
                ME(1) = ME(1)+LAMC(1)**2*MX(GR-1)**2*SCF(GR-1)*SH*
     &                       ((SH-MQS-MNS)*(A(SP,GR-1)**2+B(SP,GR-1)**2)
     &                       -4*MQ*MN*A(SP,GR-1)*B(SP,GR-1))
     &                 +LAMC(1)**2*TWO*MX(GR)*MX(GR-1)*SCF(GR)*
     &                       SCF(GR-1)*SH*
     &                       ((SH-MS2(GR))*(SH-MS2(GR-1))+
     &                       MSWD(GR)*MSWD(GR-1))*
     &                       ((SH-MQS-MNS)*(A(SP,GR)*A(SP,GR-1)+
     &                       B(SP,GR)*B(SP,GR-1))-TWO*MQ*MN*
     &                       (A(SP,GR)*B(SP,GR-1)+A(SP,GR-1)*B(SP,GR)))
                 IF(ABS(MX(GU)).GT.EPS) ME(1) = ME(1)+LAMC(1)*LAMC(2)*
     &                   TWO*MX(GR-1)*MX(GU)*(SH-MS2(GR-1))*SCF(GR-1)*
     &                   A(SP,GU)*SH*(A(SP,GR-1)*UH+B(SP,GR-1)*MQ*MN)
     &                   /(UH-MS2(GU))
                 IF(ABS(MX(GT)).GT.EPS) ME(1) = ME(1)+LAMC(1)*LAMC(3)*
     &                   TWO*MX(GR-1)*MX(GT)*(SH-MS2(GR-1))*SCF(GR-1)*
     &                   A(SP,GT)*SH*(A(SP,GR-1)*TH+B(SP,GR-1)*MQ*MN)
     &                   /(TH-MS2(GT))
                 IF(ABS(MX(GU-1)).GT.EPS) ME(1)=ME(1)+LAMC(1)*LAMC(2)*
     &                   TWO*MX(GR-1)*MX(GU-1)*(SH-MS2(GR-1))*
     &                   SCF(GR-1)*A(SP,GU-1)*SH*(A(SP,GR-1)*UH+
     &                   B(SP,GR-1)*MQ*MN)/(UH-MS2(GU-1))
                IF(ABS(MX(GT-1)).GT.EPS) ME(1)=ME(1)+LAMC(1)*LAMC(3)*
     &                   TWO*MX(GR-1)*MX(GT-1)*(SH-MS2(GR-1))*
     &                   SCF(GR-1)*A(SP,GT-1)*SH*(A(SP,GR-1)*TH+
     &                    B(SP,GR-1)*MQ*MN)/(TH-MS2(GT-1))
              ENDIF
C--u channel and L/R mixing
              IF(ABS(MX(GU-1)).GT.EPS) THEN
                ME(1) = ME(1)+LAMC(2)**2*MX(GU-1)**2*(MQS-UH)*(MNS-UH)*
     &                 (A(SP,GU-1)**2+B(SP,GU-1)**2)/(UH-MS2(GU-1))**2
     &             +LAMC(2)**2*TWO*MX(GU)*MX(GU-1)*(MQS-UH)*(MNS-UH)*
     &                 (A(SP,GU)*A(SP,GU-1)+B(SP,GU)*B(SP,GU-1))
     &                 /(UH-MS2(GU))/(UH-MS2(GU-1))
     &             +TWO*LAMC(1)*LAMC(2)*MX(GR)*MX(GU-1)*
     &                 (SH-MS2(GR))*SCF(GR)*A(SP,GU-1)*SH*
     &                 (A(SP,GR)*UH+B(SP,GR)*MQ*MN)/(UH-MS2(GU-1))
                IF(ABS(MX(GT)).GT.EPS) ME(1)=ME(1)-LAMC(2)*LAMC(3)*TWO*
     &               MX(GU-1)*MX(GT)*(MQS*MNS-UH*TH)*A(SP,GT)*A(SP,GU-1)
     &               /(TH-MS2(GT))/(UH-MS2(GU-1))
                IF(ABS(MX(GT-1)).GT.EPS) ME(1)=ME(1)-LAMC(2)*LAMC(3)*
     &               TWO*MX(GU-1)*MX(GT-1)*(MQS*MNS-UH*TH)*A(SP,GT-1)*
     &               A(SP,GU-1)/(TH-MS2(GT-1))/(UH-MS2(GU-1))
              ENDIF
C--t channel and t channel L/R mixing
             IF(ABS(MX(GT-1)).GT.EPS) THEN
                ME(1) = ME(1)+LAMC(3)**2*MX(GT-1)**2*(MQS-TH)*(MNS-TH)*
     &                 (A(SP,GT-1)**2+B(SP,GT-1)**2)/(TH-MS2(GT-1))**2
     &              +LAMC(3)**2*TWO*MX(GT)*MX(GT-1)*(MQS-TH)*(MNS-TH)*
     &                 (A(SP,GT)*A(SP,GT-1)+B(SP,GT)*B(SP,GT-1))
     &                 /(TH-MS2(GT))/(TH-MS2(GT-1))
     &              +LAMC(1)*LAMC(3)*TWO*MX(GR)*MX(GT-1)*
     &                 (SH-MS2(GR))*SCF(GR)*A(SP,GT-1)*SH*
     &                 (A(SP,GR)*TH+B(SP,GR)*MQ*MN)/(TH-MS2(GT-1))
                IF(ABS(MX(GU)).GT.EPS) ME(1)=ME(1)-LAMC(2)*LAMC(3)*TWO*
     &               MX(GU)*MX(GT-1)*(MQS*MNS-UH*TH)*A(SP,GT-1)*A(SP,GU)
     &               /(TH-MS2(GT-1))/(UH-MS2(GU))
              ENDIF
c--phase space factors
              MEC(L,GN,I,J) = G**2*FAC*ME(1)*PCM
 210       CON = 4
           I2 = SP+2
           IF(MOD(K,2).EQ.1) I2 =I2+2
           HCS=HCS+MEC(L,GN,I,J)*DISF(I1,1)*DISF(J1,2)
           IF(GENEV.AND.HCS.GT.RCS) CALL HWHRSS(3,I1,J1,K,I2,0,0,*900)
           HCS=HCS+MEC(L,GN,I,J)*DISF(J1,1)*DISF(I1,2)
           IF(GENEV.AND.HCS.GT.RCS) CALL HWHRSS(4,J1,I1,K,I2,0,0,*900)
           HCS=HCS+MEC(L,GN,I,J)*DISF(I1+6,1)*DISF(J1+6,2)
           IF(GENEV.AND.HCS.GT.RCS) CALL HWHRSS(3,I1,J1,K,I2+2,1,0,*900)
           HCS=HCS+MEC(L,GN,I,J)*DISF(J1+6,1)*DISF(I1+6,2)
           IF(GENEV.AND.HCS.GT.RCS) CALL HWHRSS(4,J1,I1,K,I2+2,1,0,*900)
 220       CONTINUE
          ENDDO
 230      CONTINUE
 240      CONTINUE
C--Now the radiative decays, if possible
 300  IF(.NOT.RAD.OR.(CHAN(5).LT.EPS.AND.CHAN(11).LT.EPS)) GOTO 400
      IF(GENEV) GOTO 320
      DO 310 I=1,6
 310  MER(I)=ZERO
C--stop to light stop and Z
      IF(SH.GT.(MZ+MS(11))**2) THEN
        PCM = SQRT((SH-(MZ+MS(11))**2)*(SH-(MZ-MS(11))**2))*HALF/SQSH
        ECM=SQRT(PCM**2+MZ2)
        TH = MZ2-SQSH*(ECM-PCM*COSTH)
        UH = MZ2-SQSH*(ECM+PCM*COSTH)
        MER(3) = SH**2*PCM**2*(SCF(11)*ZSQU(2,1)**2*QMIXSS(6,2,1)**2
     &             +SCF(12)*ZSQU(2,2)**2*QMIXSS(6,2,2)**2
     &             +TWO*SCF(11)*SCF(12)*QMIXSS(6,2,1)*QMIXSS(6,2,2)*
     &                ZSQU(2,1)*ZSQU(2,2)*((SH-MS2(11))*
     &                (SH-MS2(12))+MSWD(11)*MSWD(12)))
     &       +QMIXSS(6,2,1)**2/UH**2*ZQRK(1)**2*(
     &             TWO*MZ2*(UH*TH-MS2(11)*MZ2)+UH**2*SH)
     &       +QMIXSS(6,2,1)**2/TH**2*ZQRK(1)**2*(
     &             TWO*MZ2*(UH*TH-MS2(11)*MZ2)+TH**2*SH)
     &       +ZQRK(1)*SH*QMIXSS(6,2,1)*
     &            (QMIXSS(6,2,1)*ZSQU(2,1)*(SH-MS2(11))*SCF(11)
     &            +QMIXSS(6,2,2)*ZSQU(2,2)*(SH-MS2(12))*SCF(12))
     &            *((MZ2*(TWO*MS2(11)-TH)+TH*(SH-MS2(11)))/TH
     &             +(MZ2*(TWO*MS2(11)-UH)+UH*(SH-MS2(11)))/UH)
     &       -TWO*QMIXSS(6,2,1)**2/UH/TH*ZQRK(1)**2*
     &            (TWO*MZ2*(MS2(11)-UH)*(MS2(11)-TH)-SH*TH*UH)
        MER(3) = MER(3)*FOUR*PCM/MZ2
      ENDIF
C--sbottom to light sbottom and Z
      IF(SH.GT.(MZ+MS(5))**2) THEN
        PCM = SQRT((SH-(MZ+MS(5))**2)*(SH-(MZ-MS(5))**2))*HALF/SQSH
        ECM=SQRT(PCM**2+MZ2)
        TH = MZ2-SQSH*(ECM-PCM*COSTH)
        UH = MZ2-SQSH*(ECM+PCM*COSTH)
        MER(6) = SH**2*PCM**2*(SCF(5)*QMIXSS(5,2,1)**2*ZSQU(1,1)**2
     &                +SCF(6)*QMIXSS(5,2,2)**2*ZSQU(1,2)**2
     &                +TWO*SCF(5)*SCF(6)*QMIXSS(5,2,1)*QMIXSS(5,2,2)*
     &                 ZSQU(1,1)*ZSQU(1,2)*((SH-MS2(5))*
     &                 (SH-MS2(6))+MSWD(5)*MSWD(6)))
     &       +QMIXSS(5,2,1)**2/UH**2*ZQRK(1)**2*
     &           (TWO*MZ2*(UH*TH-MS2(5)*MZ2)+UH**2*SH)
     &       +QMIXSS(5,2,1)**2/TH**2*ZQRK(2)**2*
     &           (TWO*MZ2*(UH*TH-MS2(5)*MZ2)+TH**2*SH)
     &       +QMIXSS(5,2,1)*SH*
     &           (QMIXSS(5,2,1)*ZSQU(1,1)*(SH-MS2(5))*SCF(5)
     &           +QMIXSS(5,2,2)*ZSQU(1,2)*(SH-MS2(6))*SCF(6))*
     &            (ZQRK(1)/UH*(MZ2*(TWO*MS2(5)-UH)+(SH-MS2(5))*UH)
     &            +ZQRK(2)/TH*(MZ2*(TWO*MS2(5)-TH)+(SH-MS2(5))*TH))
     &       -TWO*QMIXSS(5,2,1)**2*ZQRK(1)*ZQRK(2)/UH/TH*
     &            (TWO*MZ2*(MS2(5)-UH)*(MS2(5)-TH)-SH*TH*UH)
        MER(6) = MER(6)*FOUR*PCM/MZ2
      ENDIF
C--stop to sbottom and W
      DO J=1,2
        IF(SH.GT.(MW+MS(4+J))**2) THEN
          PCM =SQRT((SH-(MW+MS(4+J))**2)*(SH-(MW-MS(4+J))**2))*HALF/SQSH
C--diagram square pieces
          DO I=1,2
            MER(J)=MER(J)+SCF(10+I)*
     &             (QMIXSS(6,2,I)*QMIXSS(6,1,I)*QMIXSS(5,1,J))**2
          ENDDO
C--light/heavy interference
          MER(J)=TWO*SH**2*PCM**3/MW2*(MER(J)+TWO*SCF(11)*SCF(12)*
     &          ((SH-MS2(11))*(SH-MS2(12))
     &          +MSWD(11)*MSWD(12))*QMIXSS(5,1,J)**2*
     &          QMIXSS(6,2,1)*QMIXSS(6,2,2)*QMIXSS(6,1,1)*QMIXSS(6,1,2))
        ENDIF
C--sbottom to stop and W
        IF(SH.GT.(MW+MS(10+J))**2) THEN
         PCM=SQRT((SH-(MW+MS(10+J))**2)*(SH-(MW-MS(10+J))**2))*HALF/SQSH
C--diagram square pieces
          DO I=1,2
            MER(J+3)=MER(J+3)+SCF(4+I)*
     &           (QMIXSS(5,2,I)*QMIXSS(5,1,I)*QMIXSS(6,1,J))**2
          ENDDO
C--light/heavy interference
          MER(J+3)=TWO*SH**2*PCM**3/MW2*(MER(J+3)+TWO*SCF(5)*SCF(6)*
     &          ((SH-MS2(5))*(SH-MS2(6))+
     &          MSWD(5)*MSWD(6))*QMIXSS(6,1,J)**2*
     &          QMIXSS(5,2,1)*QMIXSS(5,2,2)*QMIXSS(5,1,1)*QMIXSS(5,1,2))
        ENDIF
      ENDDO
C--Now multiply by the parton distributions and phase space factors
 320  DO J=1,3
        DO K=1,3
          CON = 5
C--resonant stop's
          IF(ABS(LAMDA3(3,J,K)).GT.EPS.AND.J.LT.K) THEN
            FAC2 = LAMDA3(3,J,K)**2*FAC*G**2
            DO I=1,3
            I1=2*J-1
            J1=2*K-1
            ME2 = MER(I)*FAC2
            HCS=HCS+ME2*DISF(I1,1)*DISF(J1,2)
            IF(GENEV.AND.HCS.GT.RCS) CALL HWHRSS(5,I1,J1,I,I,0,0,*900)
            HCS=HCS+ME2*DISF(J1,1)*DISF(I1,2)
            IF(GENEV.AND.HCS.GT.RCS) CALL HWHRSS(6,J1,I1,I,I,0,0,*900)
            HCS=HCS+ME2*DISF(I1+6,1)*DISF(J1+6,2)
            IF(GENEV.AND.HCS.GT.RCS) CALL HWHRSS(5,I1,J1,I,I,1,0,*900)
            HCS=HCS+ME2*DISF(J1+6,1)*DISF(I1+6,2)
            IF(GENEV.AND.HCS.GT.RCS) CALL HWHRSS(6,J1,I1,I,I,1,0,*900)
            ENDDO
          ENDIF
C--resonant sbottom's
          IF(ABS(LAMDA3(J,K,3)).GT.EPS) THEN
            FAC2 = LAMDA3(J,K,3)**2*FAC*G**2
            DO I=4,6
            I1=2*J
            J1=2*K-1
            ME2 = MER(I)*FAC2
            HCS=HCS+ME2*DISF(I1,1)*DISF(J1,2)
            IF(GENEV.AND.HCS.GT.RCS) CALL HWHRSS(5,I1,J1,I,I,0,0,*900)
            HCS=HCS+ME2*DISF(J1,1)*DISF(I1,2)
            IF(GENEV.AND.HCS.GT.RCS) CALL HWHRSS(6,J1,I1,I,I,0,0,*900)
            HCS=HCS+ME2*DISF(I1+6,1)*DISF(J1+6,2)
            IF(GENEV.AND.HCS.GT.RCS) CALL HWHRSS(5,I1,J1,I,I,1,0,*900)
            HCS=HCS+ME2*DISF(J1+6,1)*DISF(I1+6,2)
            IF(GENEV.AND.HCS.GT.RCS) CALL HWHRSS(6,J1,I1,I,I,1,0,*900)
            ENDDO
          ENDIF
        ENDDO
      ENDDO
C--Now the Higgs decays if possible
 400  IF(.NOT.HIGGS) GOTO 900
      IF(GENEV) GOTO 490
      DO I=1,3
         DO 405 J=1,42
 405        MEH(I,J) = ZERO
      ENDDO
      DO I=1,3
        DO 420 J=1,3
C--Neutral Higgs down type squark
        IF(SQSH.LT.MH(J)+MS(2*I-1)) GOTO 410
        PCM = SQRT((SH-(MH(J)+MS(2*I-1))**2)*
     &             (SH-(MH(J)-MS(2*I-1))**2))*HALF/SQSH
        ECM=SQRT(PCM**2+MH(J)**2)
        TH = MH(J)**2-SQSH*(ECM-PCM*COSTH)
        UH = MH(J)**2-SQSH*(ECM+PCM*COSTH)
        MEH(1,3*I-3+J) = PCM*SH*(
     &            QMIXSS(2*I-1,2,1)**2*SCF(2*I-1)*GHSQSS(J,2*I-1,1,1)**2
     &             +QMIXSS(2*I-1,2,2)**2*SCF(2*I)*GHSQSS(J,2*I-1,2,1)**2
     &              +TWO*QMIXSS(2*I-1,2,1)*QMIXSS(2*I-1,2,2)*SCF(2*I-1)
     &               *SCF(2*I)*GHSQSS(J,2*I-1,1,1)*GHSQSS(J,2*I-1,2,1)*
     &            ((SH-MS2(2*I-1))*(SH-MS2(2*I))+MSWD(2*I-1)*MSWD(2*I)))
        MEH(2,3*I-3+J) = PCM*GUU(J)*QMIXSS(2*I,2,1)**2/TH**2*
     &                   (TH*UH-MH(J)**2*MS2(2*I-1))
        MEH(3,3*I-3+J) = PCM*GDD(J)*QMIXSS(2*I,2,1)**2/UH**2*
     &                   (TH*UH-MH(J)**2*MS2(2*I-1))
C--Neutral Higgs up type squarks
 410    IF(SQSH.LT.MH(J)+MS(2*I+5)) GOTO 420
        PCM = SQRT((SH-(MH(J)+MS(2*I+5))**2)*
     &             (SH-(MH(J)-MS(2*I+5))**2))*HALF/SQSH
        ECM=SQRT(PCM**2+MH(J)**2)
        TH = MH(J)**2-SQSH*(ECM-PCM*COSTH)
        UH = MH(J)**2-SQSH*(ECM+PCM*COSTH)
        MEH(1,3*I+6+J) = PCM*SH*(
     &               QMIXSS(2*I,2,1)**2*SCF(2*I+5)*GHSQSS(J,2*I,1,1)**2
     &              +QMIXSS(2*I,2,2)**2*SCF(2*I+6)*GHSQSS(J,2*I,2,1)**2
     &              +TWO*QMIXSS(2*I,2,1)*QMIXSS(2*I,2,2)*SCF(2*I+5)
     &               *SCF(2*I+6)*GHSQSS(J,2*I,1,1)*GHSQSS(J,2*I,2,1)*
     &              ((SH-MS2(2*I+5))*(SH-MS2(2*I+6))+
     &               MSWD(2*I+5)*MSWD(2*I+6)))
        MEH(2,3*I+6+J) = PCM*GDD(J)*QMIXSS(2*I-1,2,1)**2/TH**2*
     &                   (TH*UH-MH(J)**2*MS2(2*I+5))
        MEH(3,3*I+6+J) = PCM*GDD(J)*QMIXSS(2*I-1,2,1)**2/UH**2*
     &                   (TH*UH-MH(J)**2*MS2(2*I+5))
 420    CONTINUE
C--Charged Higgs up type squark
        DO 440 J=1,2
        IF(SQSH.LT.MH(4)+MS(2*I+4+J)) GOTO 430
        PCM = SQRT((SH-(MH(4)+MS(2*I+4+J))**2)*
     &             (SH-(MH(4)-MS(2*I+4+J))**2))*HALF/SQSH
        ECM=SQRT(PCM**2+MH(4)**2)
        TH = MH(4)**2-SQSH*(ECM-PCM*COSTH)
        UH = MH(4)**2-SQSH*(ECM+PCM*COSTH)
        MEH(1,4*I+14+J) = PCM*SH*(
     &              QMIXSS(2*I-1,2,1)**2*GHSQSS(4,2*I,J,1)**2*SCF(2*I-1)
     &             +QMIXSS(2*I-1,2,2)**2*GHSQSS(4,2*I,J,2)**2*SCF(2*I)
     &              +TWO*QMIXSS(2*I-1,2,1)*QMIXSS(2*I-1,2,2)*SCF(2*I-1)
     &               *SCF(2*I)*GHSQSS(4,2*I,J,1)*GHSQSS(4,2*I,J,2)*
     &              ((SH-MS2(2*I-1))*(SH-MS2(2*I))+
     &                   MSWD(2*I-1)*MSWD(2*I)))
        MEH(2,4*I+14+J) = PCM*QMIXSS(2*I,2,J)**2*GDD(4)/TH**2*
     &                    (UH*TH-MS2(2*I+4+J)*MH(4)**2)
C--Charged Higgs down type squark
 430    IF(SQSH.LT.MH(4)+MS(2*I-2+J)) GOTO 440
        PCM = SQRT((SH-(MH(4)+MS(2*I-2+J))**2)*
     &             (SH-(MH(4)-MS(2*I-2+J))**2))*HALF/SQSH
        ECM=SQRT(PCM**2+MH(4)**2)
        TH = MH(4)**2-SQSH*(ECM-PCM*COSTH)
        UH = MH(4)**2-SQSH*(ECM+PCM*COSTH)
        MEH(1,4*I+16+J) = PCM*SH*(
     &              QMIXSS(2*I,2,1)**2*GHSQSS(4,2*I-1,J,1)**2*SCF(2*I+5)
     &             +QMIXSS(2*I,2,2)**2*GHSQSS(4,2*I-1,J,2)**2*SCF(2*I+6)
     &              +TWO*QMIXSS(2*I,2,1)*QMIXSS(2*I,2,2)*SCF(2*I+5)
     &              *SCF(2*I+6)*GHSQSS(4,2*I-1,J,1)*GHSQSS(4,2*I-1,J,2)*
     &              ((SH-MS2(2*I+5))*(SH-MS2(2*I+6))+
     &              MSWD(2*I+5)*MSWD(2*I+6)))
        MEH(2,4*I+16+J) = PCM*QMIXSS(2*I-1,2,J)**2*GUU(4)/TH**2*
     &                    (UH*TH-MS2(2*I-2+J)*MH(4)**2)
        MEH(3,4*I+16+J) = PCM*QMIXSS(2*I-1,2,J)**2*GUU(4)/UH**2*
     &                    (UH*TH-MS2(2*I-2+J)*MH(4)**2)
 440    CONTINUE
      ENDDO
 490  DO I=1,3
      DO J=1,3
        DO K=1,3
          CON = 5
          DO L=1,3
          IF(ABS(LAMDA3(J,K,I)).GT.EPS) THEN
C--neutral higgs and sdown
            FAC2 = FAC*G**2*LAMDA3(J,K,I)**2
            I1=2*J
            J1=2*K-1
            ME2 = FAC2*(MEH(1,3*I-3+L)+RMASS(I1)**2*MEH(2,3*I-3+L)
     &                  +RMASS(J1)**2*MEH(3,3*I-3+L))
            HCS=HCS+ME2*DISF(I1,1)*DISF(J1,2)
          IF(GENEV.AND.HCS.GT.RCS) CALL HWHRSS(7,I1,J1,L,2*I-1,0,0,*900)
             HCS=HCS+ME2*DISF(J1,1)*DISF(I1,2)
          IF(GENEV.AND.HCS.GT.RCS) CALL HWHRSS(8,J1,I1,L,2*I-1,0,0,*900)
            IF(I2.NE.200) I2=198
            HCS=HCS+ME2*DISF(I1+6,1)*DISF(J1+6,2)
          IF(GENEV.AND.HCS.GT.RCS) CALL HWHRSS(7,I1,J1,L,2*I-1,1,0,*900)
            HCS=HCS+ME2*DISF(J1+6,1)*DISF(I1+6,2)
          IF(GENEV.AND.HCS.GT.RCS) CALL HWHRSS(8,J1,I1,L,2*I-1,1,0,*900)
          ENDIF
          IF(ABS(LAMDA3(I,J,K)).GT.EPS.AND.J.LT.K) THEN
            FAC2 = FAC*G**2*LAMDA3(I,J,K)**2
C--neutral higgs and sup
            I1=2*J-1
            J1=2*K-1
            ME2 = FAC2*(MEH(1,3*I+6+L)+RMASS(I1)**2*MEH(2,3*I+6+L)
     &                  +RMASS(J1)**2*MEH(3,3*I+6+L))
            HCS=HCS+ME2*DISF(I1,1)*DISF(J1,2)
          IF(GENEV.AND.HCS.GT.RCS) CALL HWHRSS(7,I1,J1,L,2*I+5,0,0,*900)
            HCS=HCS+ME2*DISF(J1,1)*DISF(I1,2)
          IF(GENEV.AND.HCS.GT.RCS) CALL HWHRSS(8,J1,I1,L,2*I+5,0,0,*900)
            HCS=HCS+ME2*DISF(I1+6,1)*DISF(J1+6,2)
          IF(GENEV.AND.HCS.GT.RCS) CALL HWHRSS(7,I1,J1,L,2*I+5,1,0,*900)
            HCS=HCS+ME2*DISF(J1+6,1)*DISF(I1+6,2)
          IF(GENEV.AND.HCS.GT.RCS) CALL HWHRSS(8,J1,I1,L,2*I+5,1,0,*900)
          ENDIF
          ENDDO
          DO L=1,2
          IF(ABS(LAMDA3(J,K,I)).GT.EPS) THEN
C--charged higgs and sup
            I1=2*J
            J1=2*K-1
            FAC2 = FAC*G**2
            ME2 = FAC2*(LAMDA3(J,K,I)**2*MEH(1,4*I+L+14)
     &                 +LAMDA3(I,J,K)**2*RMASS(I1-1)**2*MEH(2,4*I+L+14))
            HCS= HCS+ME2*DISF(I1,1)*DISF(J1,2)
        IF(GENEV.AND.HCS.GT.RCS) CALL HWHRSS(7,I1,J1,4,2*I+4+L,0,0,*900)
            HCS= HCS+ME2*DISF(J1,1)*DISF(I1,2)
        IF(GENEV.AND.HCS.GT.RCS) CALL HWHRSS(8,J1,I1,4,2*I+4+L,0,0,*900)
            HCS= HCS+ME2*DISF(I1+6,1)*DISF(J1+6,2)
        IF(GENEV.AND.HCS.GT.RCS) CALL HWHRSS(7,I1,J1,5,2*I+4+L,1,0,*900)
            HCS= HCS+ME2*DISF(J1+6,1)*DISF(I1+6,2)
        IF(GENEV.AND.HCS.GT.RCS) CALL HWHRSS(8,J1,I1,5,2*I+4+L,1,0,*900)
           ENDIF
C--charged higgs and sdown
          IF(ABS(LAMDA3(I,J,K)).GT.EPS.AND.J.LT.K) THEN
            I1=2*J-1
            J1=2*K-1
            FAC2 = FAC*G**2
            ME2 = FAC2*(MEH(1,4*I+L+16)*LAMDA3(I,J,K)**2
     &                 +RMASS(I1+1)**2*LAMDA3(J,I,K)**2*MEH(2,4*I+L+16)
     &                 +RMASS(J1+1)**2*LAMDA3(K,I,J)**2*MEH(3,4*I+L+16))
            HCS=HCS+ME2*DISF(I1,1)*DISF(J1,2)
        IF(GENEV.AND.HCS.GT.RCS) CALL HWHRSS(7,I1,J1,5,2*I-2+L,0,0,*900)
            HCS=HCS+ME2*DISF(J1,1)*DISF(I1,2)
        IF(GENEV.AND.HCS.GT.RCS) CALL HWHRSS(8,J1,I1,5,2*I-2+L,0,0,*900)
            HCS=HCS+ME2*DISF(I1+6,1)*DISF(J1+6,2)
        IF(GENEV.AND.HCS.GT.RCS) CALL HWHRSS(7,I1,J1,4,2*I-2+L,1,0,*900)
            HCS=HCS+ME2*DISF(J1+6,1)*DISF(I1+6,2)
        IF(GENEV.AND.HCS.GT.RCS) CALL HWHRSS(8,J1,I1,4,2*I-2+L,1,0,*900)
          ENDIF
          ENDDO
        ENDDO
      ENDDO
      ENDDO
C--calculate of the matrix elements
 900  IF(GENEV) THEN
        CALL HWETWO
        IF(IERROR.NE.0) RETURN
        HVFCEN = .TRUE.
C--first stage of the colour connection corrections
        DO THEP=1,5
          IF(THEP.NE.3) THEN
            JMOHEP(2,THEP+NHEP-5)=NHEP-5+THEP
     &                       +CONECT(HWRINT(1,2),THEP,CON)
            JDAHEP(2,THEP+NHEP-5) = JMOHEP(2,THEP+NHEP-5)
          ENDIF
        ENDDO
        IF(IDHEP(NHEP-4).LT.0) THEN
          JDAHEP(2,NHEP-4)=NHEP-1
          JDAHEP(2,NHEP-3)=NHEP-3
          JDAHEP(2,NHEP-1)=NHEP-4
          IF(CON.EQ.5) JDAHEP(2,NHEP-4)=NHEP
          JDAHEP(2,NHEP)=CONECT(1,6,CON)+NHEP
        ELSE
          JMOHEP(2,NHEP-4)=NHEP-1
          JMOHEP(2,NHEP-3)=NHEP-3
          JMOHEP(2,NHEP-1)=NHEP-4
          IF(CON.EQ.5) JMOHEP(2,NHEP-4)=NHEP
          JMOHEP(2,NHEP)=CONECT(1,6,CON)+NHEP
        ENDIF
        IF(CON.EQ.5) THEN
          SP=JDAHEP(2,NHEP)
          JDAHEP(2,NHEP) = JDAHEP(2,NHEP-1)
          JDAHEP(2,NHEP-1) = SP
          SP=JMOHEP(2,NHEP)
          JMOHEP(2,NHEP) = JMOHEP(2,NHEP-1)
          JMOHEP(2,NHEP-1) = SP
        ENDIF
        HRDCOL(1,1) = NHEP
        HRDCOL(1,2) = NHEP-2
      ELSE
        EVWGT = HCS
      ENDIF
 999  END
CDECK  ID>, HWHREE.
*CMZ :-        -27/10/00  15:52:00  by  Peter Richardson
*-- Author :    Peter Richardson
C-----------------------------------------------------------------------
      SUBROUTINE HWHREE
C-----------------------------------------------------------------------
C     SUSY E+E- --> SM PARTICLES VIA RPV
C-----------------------------------------------------------------------
      INCLUDE 'HERWIG62.INC'
      DOUBLE PRECISION HWRGEN,HWRUNI,HWUPCM,HWUMBW,HWUAEM,HCS,RCS,FACA,
     &                 S,T,PCM,MQ1,MQ2,SP,TP,TPZ,TPN,TPN2,MSL2(3),MZ,
     &                 MZ2,MSU2(3,2),MWD(3),GL,GR,GLP,GRP,EC,EE,THTMIN,
     &                 MIX(3,2),CFAC,LAM(4,3,3,3,3,3),MET,ME(2,3,3)
      DOUBLE COMPLEX FSLL,FSLR,FSRL,FSRR,FTLL,FTLR,FTRL,FTRR,Z,Z0,GZ,
     &               SCF(3)
      INTEGER I,IHEP,RSID(2),IL,GN,J,K,L,GNMN,GNMX,K1,L1,NTRY,GNR,FID(2)
      SAVE HCS,MSL2,MWD,LAM,ME,GL,GR,MZ,MZ2,MSU2,MIX,GNMN,GNMX,IL,RSID,
     &     FID
      EXTERNAL HWRGEN,HWRUNI,HWUPCM,HWUMBW,HWUAEM
      PARAMETER(Z=(0.D0,1.D0),Z0=(0.D0,0.D0))
C--Start of the code
      IF(GENEV) THEN
        RCS = HCS*HWRGEN(0)
      ELSE
        IF(FSTWGT) THEN
C--identify the beam particles
          IF(ABS(IDHEP(1)).EQ.11) THEN
C--electron beams
            RSID(1) = 2
            IL = 1
          ELSEIF(ABS(IDHEP(1)).EQ.13) THEN
C--muon beams
            RSID(1) = 1
            IL = 2
C--unrecognized beam particles issue warning
          ELSE
            CALL HWWARN('HWHREE',500,*999)
          ENDIF
          RSID(2) = 3
C--masses of the sleptons
          DO I=1,3
            MSL2(I) = RMASS(424+2*I)
            MWD(I)  = MSL2(I)*HBAR/RLTIM(424+2*I)
            MSL2(I) = MSL2(I)**2
          ENDDO
C--masses and mixings of the t channel squarks
          DO I=1,3
            MSU2(I,1) = RMASS(400+2*I)
            MSU2(I,2) = RMASS(412+2*I)
            DO J=1,2
              MIX(I,J)  = QMIXSS(2*I,1,J)**2
              MSU2(I,J) = MSU2(I,J)**2
            ENDDO
          ENDDO
C--Z mass
          MZ = RMASS(200)
          MZ2 = MZ**2
C--find the couplings
          DO GN=1,3
            DO I=1,3
              DO J=1,3
                DO K=1,3
                  DO L=1,3
                    LAM(1,GN,I,J,K,L) = LAMDA1(GN,I,J)*LAMDA1(GN,K,L)
                    LAM(2,GN,I,J,K,L) = LAMDA1(GN,I,J)*LAMDA2(GN,K,L)
                    LAM(3,GN,I,J,K,L) = LAM(1,GN,I,J,K,L)
                    LAM(4,GN,I,J,K,L) = LAMDA2(I,GN,J)*LAMDA2(K,GN,L)
                  ENDDO
                ENDDO
              ENDDO
            ENDDO
          ENDDO
C--Z couplings
          GL = LFCH(11)
          GR = RFCH(11)
C--select the process from the IPROC code
          IF(IPROC.EQ.860) THEN
            GNMN = 1
            GNMX = 2
            FID(1) = 0
            FID(2) = 0
          ELSEIF(IPROC.GE.870.AND.IPROC.LT.890) THEN
            J = MOD(IPROC,10)
            IF(MOD(IPROC,10).EQ.0) THEN
              FID(1) = 0
              FID(2) = 0
            ELSE
              FID(1) = MOD(J-1,3)+1
              FID(2) = INT((J-1)/3)+1
            ENDIF
            IF(IPROC.LT.880) THEN
              GNMN = 1
            ELSE
              GNMN = 2
            ENDIF
            GNMX = GNMN
          ELSE
            CALL HWWARN('HWHREE',501,*999)
          ENDIF
        ENDIF
C--calculate the kinematic varibles
        EVWGT  = ZERO
        S      = PHEP(5,3)**2
        THTMIN = ONE-FOUR*PTMIN**2/S
        IF(THTMIN.LT.ZERO) CALL HWWARN('HWHREE',502,*999)
        THTMIN = SQRT(THTMIN)
        COSTH  = HWRUNI(0,-THTMIN,THTMIN)
        EMSCA  = PHEP(5,3)
        GZ     = ONE/(S-MZ**2+Z*MZ*GAMZ)
        EE     = HWUAEM(S)
        FACA   = GEV2NB*EE**2*PIFAC*S/FOUR
        EE     = 0.25D0/EE/PIFAC
        SP     = ONE/S
        T      = -HALF*S*(ONE-COSTH)
        TP     = ONE/T
        TPZ    = ONE/(T-MZ2)
C--Calculate the prefactor due multichannel approach
        DO GN=1,3
          IF(GN.EQ.RSID(1).OR.GN.EQ.RSID(2)) THEN
            SCF(GN)= ONE/(S-MSL2(GN)+Z*MWD(GN))
          ELSE
            SCF(GN) = Z0
          ENDIF
        ENDDO
      ENDIF
C--Now the loop to actually calculate the cross sections
      HCS = ZERO
      DO GN=GNMN,GNMX
        GNR = GN+2
        DO K1=1,3
          DO 80 L1=1,3
            IF(FID(1).NE.0.AND.(FID(1).NE.K1.OR.FID(2).NE.L1).AND.
     &         (FID(1).NE.L1.OR.FID(2).NE.K1)) GOTO 80
            IF(GN.EQ.1) THEN
              K = 119+2*K1
              L = 125+2*L1
              GLP = GL
              GRP = GR
              EC = ONE
              CFAC = ONE
            ELSEIF(GN.EQ.2) THEN
              K = 2*K1-1
              L = 2*L1+5
              GLP = LFCH(K)
              GRP = RFCH(K)
              EC = ONE/THREE
              CFAC = THREE
            ENDIF
            MQ1 = RMASS(K)
            MQ2 = RMASS(L)
            IF(EMSCA.LT.(MQ1+MQ2)) GOTO 80
            MET = ZERO
            IF(GENEV) GOTO 60
C--calculate the matrix element
C--set all coefficents to zero
            FSLL = Z0
            FSLR = Z0
            FSRL = Z0
            FSRR = Z0
            FTLL = Z0
            FTLR = Z0
            FTRL = Z0
            FTRR = Z0
C--Standard Model terms
            IF(K1.EQ.L1) THEN
C--first if same flavour pair production
              FSLL = EC*SP+GL*GRP*GZ
              FSLR = EC*SP+GL*GLP*GZ
              FSRL = EC*SP+GR*GRP*GZ
              FSRR = EC*SP+GR*GLP*GZ
C--t channel terms if e+e- --> e+e-
              IF(K1.EQ.IL.AND.GN.EQ.1) THEN
                FTLL = TP+GL*GR*TPZ
                FTLR = TP+GL**2*TPZ
                FTRL = TP+GR**2*TPZ
                FTRR = TP+GL*GR*TPZ
              ENDIF
            ENDIF
C--Now add the RPV terms
            DO I=1,3
              IF(GN.EQ.1) THEN
                TPN  = ONE/(T-MSL2(I))
                TPN2 = TPN
              ELSE
                TPN  = MIX(I,1)/(T-MSU2(I,1))+ MIX(I,2)/(T-MSU2(I,2))
                TPN2 = ZERO
              ENDIF
              FSLL = FSLL+HALF*LAM(GNR,I,IL,K1,IL,L1)*EE*TPN
              FSRR = FSRR+HALF*LAM(GNR,I,K1,IL,L1,IL)*EE*TPN2
              FTLL = FTLL+HALF*LAM(GN,I,IL,IL,K1,L1)*EE*SCF(I)
              FTRR = FTRR+HALF*LAM(GN,I,IL,IL,L1,K1)*EE*SCF(I)
            ENDDO
C--now calculate the matrix element
            MET = (ONE+COSTH)**2
     &           *DREAL(DCONJG(FSLR)*FSLR+DCONJG(FSRL)*FSRL
     &           +DCONJG(FTLR)*FTLR+DCONJG(FTRL)*FTRL
     &                +TWO*FTLR*DCONJG(FSLR)
     &                +TWO*FTRL*DCONJG(FSRL))
     &           +(ONE-COSTH)**2*DREAL(DCONJG(FSLL)*FSLL
     &                +DCONJG(FSRR)*FSRR)
     &           +FOUR*DREAL(DCONJG(FTLL)*FTLL+DCONJG(FTRR)*FTRR)
C--final phase space factors
            ME(GN,K1,L1) = MET*CFAC*FACA*THTMIN
 60         HCS = HCS+ME(GN,K1,L1)
            IF(HCS.GT.RCS.AND.GENEV) GOTO 900
 80       CONTINUE
        ENDDO
      ENDDO
 900  IF(GENEV) THEN
C--change sign of COSTH if antiparticle first
        IF(IDHEP(1).LT.IDHEP(2)) COSTH = -COSTH
C-Set up the particle types
        IDHW(NHEP+1)     = 15
        IDHEP(NHEP+1)    = 0
        ISTHEP(NHEP+1)   = 110
        IDHW(NHEP+2)     = K
        IDHW(NHEP+3)     = L
        IDHEP(NHEP+2)    = IDPDG(K)
        IDHEP(NHEP+3)    = IDPDG(L)
C--Select the masses of the particles and the final-state momenta
 910    NTRY = NTRY+1
        PHEP(5,NHEP+2)   = HWUMBW(K)
        PHEP(5,NHEP+3)   = HWUMBW(L)
        CALL HWVEQU(5,PHEP(1,3),PHEP(1,NHEP+1))
        PCM   = HWUPCM(PHEP(5,NHEP+1),PHEP(5,NHEP+2),PHEP(5,NHEP+3))
        IF(PCM.LT.ZERO.AND.NTRY.LE.NETRY) THEN
          GOTO 910
        ELSEIF(PCM.LT.ZERO) THEN
          CALL HWWARN('HWHREE',100,*999)
        ENDIF
C--Set up the colours etc
        ISTHEP(NHEP+2)   = 113
        ISTHEP(NHEP+3)   = 114
        JMOHEP(1,NHEP+1) = 1
        IF (JDAHEP(1,1).NE.0) JMOHEP(1,NHEP+1)=JDAHEP(1,1)
        JMOHEP(2,NHEP+1) = 2
        IF (JDAHEP(1,2).NE.0) JMOHEP(1,NHEP+1)=JDAHEP(1,2)
        JMOHEP(1,NHEP+2) = NHEP+1
        JMOHEP(2,NHEP+2) = NHEP+3
        JMOHEP(1,NHEP+3) = NHEP+1
        JMOHEP(2,NHEP+3) = NHEP+2
        JDAHEP(1,NHEP+1) = NHEP+2
        JDAHEP(2,NHEP+1) = NHEP+3
        JDAHEP(1,NHEP+2) = 0
        JDAHEP(2,NHEP+2) = NHEP+3
        JDAHEP(1,NHEP+3) = 0
        JDAHEP(2,NHEP+3) = NHEP+2
C--Set up the momenta
        IHEP  = NHEP+2
        PHEP(4,IHEP) = SQRT(PCM**2+PHEP(5,IHEP)**2)
        PHEP(3,IHEP) = PCM*COSTH
        PHEP(1,IHEP) = SQRT((PCM+PHEP(3,IHEP))*(PCM-PHEP(3,IHEP)))
        PHEP(2,IHEP) = ZERO
        CALL HWRAZM(PHEP(1,IHEP),PHEP(1,IHEP),PHEP(2,IHEP))
        CALL HWULOB(PHEP(1,NHEP+1),PHEP(1,IHEP),PHEP(1,IHEP))
        CALL HWVDIF(4,PHEP(1,NHEP+1),PHEP(1,IHEP),PHEP(1,IHEP+1))
        NHEP  = NHEP+3
      ELSE
        EVWGT = HCS
      ENDIF
 999  END
CDECK  ID>, HWHREM.
*CMZ :-        -01/06/94  17.03.31  by  Mike Seymour
*-- Author :    Mike Seymour
C-----------------------------------------------------------------------
      SUBROUTINE HWHREM(IBEAM,ITARG)
C-----------------------------------------------------------------------
C     IDENTIFY THE REMNANTS OF THE HARD SCATTERING
C     AND BREAK THEIR COLOUR CONNECTION IF NECESSARY
C-----------------------------------------------------------------------
      INCLUDE 'HERWIG62.INC'
      DOUBLE PRECISION PCL(5)
      INTEGER IBEAM,ITARG,IHEP,NTEMP,I,ICOL,IANT
      LOGICAL LTEMP,T,COL,ANT
      PARAMETER (T=.TRUE.)
      COL(I)=I.EQ.13 .OR. I.GE.1.AND.I.LE.6 .OR. I.GE.115.AND.I.LE.120
      ANT(I)=I.EQ.13 .OR. I.GE.7.AND.I.LE.12.OR. I.GE.109.AND.I.LE.114
C---LOOK FOR UNTREATED BEAM AND TARGET REMNANTS
      IBEAM=0
      ITARG=0
      DO 10 IHEP=1,NHEP
        IF (ISTHEP(IHEP).EQ.148) THEN
          IF (ITARG.NE.0) CALL HWWARN('HWHREM',100,*999)
          ITARG=IHEP
        ELSEIF (ISTHEP(IHEP).EQ.147) THEN
          IF (IBEAM.NE.0) CALL HWWARN('HWHREM',101,*999)
          IBEAM=IHEP
        ENDIF
  10  CONTINUE
      IF (ITARG.EQ.0) CALL HWWARN('HWHREM',102,*999)
      IF (IBEAM.EQ.0) CALL HWWARN('HWHREM',103,*999)
C---IF THEY ARE COLOUR CONNECTED, DISCONNECT THEM BY EMITTING A SOFT
C   GLUON AND SPLITTING THAT GLUON TO LIGHT QUARKS
C  (WHICH NORMALLY GETS DONE AS THE FIRST STAGE OF CLUSTER FORMATION)
C---LOOP OVER COLOUR/ANTICOLOUR LINE
      DO 20 I=1,2
        IF (I.EQ.1) THEN
          ICOL=IBEAM
          IANT=ITARG
        ELSE
          ICOL=ITARG
          IANT=IBEAM
        ENDIF
        IF (COL(IDHW(ICOL)).AND.ANT(IDHW(IANT)).AND.
     $       JMOHEP(2,ICOL).EQ.IANT.AND.JDAHEP(2,IANT).EQ.ICOL) THEN
          CALL HWVSUM(4,PHEP(1,ICOL),PHEP(1,IANT),PCL)
          CALL HWUMAS(PCL)
          NTEMP=NHEP
          CALL HWCCUT(ICOL,IANT,PCL,T,LTEMP)
C---IF NOTHING WAS CREATED THEY MUST BE BELOW THRESHOLD, SO GIVE UP
          IF (NHEP.NE.NTEMP+2) RETURN
C---RELABEL THEM AS PERTUBATIVE JUST TO NEATEN UP THE EVENT RECORD
          ISTHEP(NHEP-1)=149
          ISTHEP(NHEP)=149
        ENDIF
 20   CONTINUE
 999  END
CDECK  ID>, HWHREP.
*CMZ :-        -18/10/00  13:46:47  by  Peter Richardson
*-- Author :    Peter Richardson
C-----------------------------------------------------------------------
      SUBROUTINE HWHREP
C-----------------------------------------------------------------------
C     SUSY E+E- RPV PRODUCTION
C-----------------------------------------------------------------------
      INCLUDE 'HERWIG62.INC'
      IF(IPROC.GE.800.AND.IPROC.LE.850) THEN
        CALL HWHRES
      ELSEIF(IPROC.GE.860.AND.IPROC.LT.890) THEN
        CALL HWHREE
C---UNRECOGNIZED PROCESS
      ELSE
        CALL HWWARN('HWHREP',500,*999)
      ENDIF
 999  END
CDECK  ID>, HWHRES.
*CMZ :-        -30/10/00  14:56:15  by  Peter Richardson
*-- Author :    Peter Richardson
C-----------------------------------------------------------------------
      SUBROUTINE HWHRES
C-----------------------------------------------------------------------
C     SUSY E+E- --> RPV SINGLE SPARTICLE PRODUCTION
C-----------------------------------------------------------------------
      INCLUDE 'HERWIG62.INC'
      DOUBLE PRECISION HWRGEN,HWUAEM,HWRUNI,HWUPCM,HWUMBW,HCS,RCS,FACA,
     &                 FACB,FACC,FACD,FACE,M1(4,4),M2(2,4),M3(8),M4(10),
     &                 MW,MZ,MSCL(2,2),MSCL2(2,2),MZ2,MSL2,MSR2,MSNU2,
     &                 MW2,MCH(2),MCH2(2),MNU(4),MNU2(4),MLT(3),MLT2(3),
     &                 MNUT(2),MNUT2(2),RMNUT(2),S,U,T,QPE,SQPE,SM,DM,
     &                 PF,PCM,SCF(2),UP,TP,MH(4),MH2(4),THCOS(2),THTMIN,
     &                 A(6,4),B(6,4),SW,CW,MC,SIN2B,ZNU,RHO,HSL(2,2),
     &                 HL(4),HNU(3)
      INTEGER I,SSNU,NTID(2),CHID(2),IG1,IG2,IHEP,SSCH,ISL,ISR,NTRY,
     &        ISN,IDL,J,L,RSID(2),K,L2,IL,IDZ,RADID(2,8),GMIN,GMAX
      LOGICAL NEUT,CHAR,RAD,HIGGS,THSGN
      SAVE HCS,M1,M2,M3,M4,SW,CW,MW,MZ,MW2,MZ2,MLT,MLT2,MNUT,MNUT2,
     &     RMNUT,MNU,MNU2,MCH,MCH2,MSNU2,A,B,MSL2,MSR2,MSCL,
     &     MSCL2,ZNU,THCOS,HSL,HL,HNU,MH,MH2,GMIN,GMAX,
     &     RADID,NTID,ISL,ISR,ISN,IDL,CHID,RSID,IL,NEUT,CHAR,RAD,HIGGS
      EXTERNAL HWRGEN,HWUAEM,HWRUNI,HWUPCM,HWUMBW
      PARAMETER (SSNU=449,SSCH = 455)
C--Start of the code
      IF(GENEV) THEN
        RCS = HCS*HWRGEN(0)
      ELSE
C--Initialise the hard processes
        IF(FSTWGT) THEN
C--Decide which processes to generate
          NEUT  = .FALSE.
          CHAR  = .FALSE.
          RAD   = .FALSE.
          HIGGS = .FALSE.
C--all single sparticle production
          IF(IPROC.EQ.800) THEN
            NEUT  = .TRUE.
            CHAR  = .TRUE.
            RAD   = .TRUE.
            HIGGS = .TRUE.
            NTID(1) = 1
            NTID(2) = 4
            CHID(1) = 1
            CHID(2) = 2
            GMIN    = 1
            GMAX    = 6
C--single neutralino production
          ELSEIF(IPROC.GE.810.AND.IPROC.LE.814) THEN
            NEUT = .TRUE.
            IF(IPROC.EQ.810) THEN
              NTID(1) = 1
              NTID(2) = 4
            ELSE
              NTID(1) = IPROC-810
              NTID(2) = NTID(1)
            ENDIF
C--single chargino production
          ELSEIF(IPROC.GE.820.AND.IPROC.LE.822) THEN
            CHAR = .TRUE.
            IF(IPROC.EQ.820) THEN
              CHID(1) = 1
              CHID(2) = 2
            ELSE
              CHID(1) = IPROC-820
              CHID(2) = CHID(1)
            ENDIF
C--single slepton production with gauge boson
          ELSEIF(IPROC.EQ.830) THEN
            RAD = .TRUE.
            GMIN    = 1
            GMAX    = 6
C--single slepton production with Higgs boson
          ELSEIF(IPROC.EQ.840) THEN
            HIGGS = .TRUE.
C--photon radiation processes
          ELSEIF(IPROC.EQ.850) THEN
            RAD = .TRUE.
            GMIN = 7
            GMAX = 8
C--unrecognized process issue warning
          ELSE
            CALL HWWARN('HWHRES',500,*999)
          ENDIF
C--check the particles in the beam
          RSID(2) = 3
          IF(ABS(IDHEP(1)).EQ.11) THEN
C--electron beams
            ISL     = 425
            ISR     = 437
            ISN     = 426
            RSID(1) = 2
            IL      = 1
          ELSEIF(ABS(IDHEP(1)).EQ.13) THEN
C--muon beams
            ISL     = 427
            ISR     = 439
            ISN     = 428
            RSID(1) = 1
            IL      = 2
C--unrecognised beam particles issue warning
          ELSE
            CALL HWWARN('HWHRES',501,*999)
          ENDIF
          IDL=ABS(IDHEP(1))
C--masses and electroweak parameters
          SW  = SQRT(SWEIN)
          CW  = SQRT(1-SWEIN)
          MW  = RMASS(198)
          MZ  = RMASS(200)
          MW2 = MW**2
          MZ2 = MZ**2
          SIN2B = TWO*SINB*COSB
C--neutralino and chargino masses
          DO I=1,4
            MNU(I)  = RMASS(SSNU+I)
            MNU2(I) = MNU(I)**2
          ENDDO
          DO I = 1,2
            MCH(I)  = RMASS(I+SSCH)
            MCH2(I) = MCH(I)**2
          ENDDO
C--incoming lepton mass
          MLT(1) = RMASS(IDL+110)
C--lepton masses in chargino production
          DO I=1,2
            MLT(I+1) = RMASS(119+2*RSID(I))
          ENDDO
          DO I=1,3
            MLT2(I) = MLT(I)**2
          ENDDO
C--t-channel slepton masses
          MSL2  = RMASS(ISL)**2
          MSR2  = RMASS(ISR)**2
          MSNU2 = RMASS(ISN)**2
C--resonant sneutrino masses and widths
          DO I=1,2
            MNUT(I)  = RMASS(424+2*RSID(I))
            MNUT2(I) = MNUT(I)**2
            RMNUT(I) = MNUT2(I)*HBAR**2/RLTIM(424+2*RSID(I))**2
          ENDDO
C--now calculate the coefficients for the processes
C--first neutralino production
          DO L=1,4
            MC = MLT(1)*ZMIXSS(L,3)/(TWO*MW*COSB*SW)
C--first for the left slepton
            A(L,1) = SLFCH(IDL,L)
            B(L,1) = ZSGNSS(L)*MC
C--then the right slepton
            A(L,2) = ZSGNSS(L)*SRFCH(IDL,L)
            B(L,2) = MC
C--the resonant sneutrino
            DO I=1,2
              A(L,2+I) = SLFCH(10+2*RSID(I),L)
              B(L,2+I) = ZERO
            ENDDO
          ENDDO
C--now chargino production
          DO L=1,2
            J=L+4
            MC = WMXUSS(L,2)/(SQRT(TWO)*MW*COSB*SW)
C--first for the t channel sneutrino
            A(J,1) = WSGNSS(L)*WMXVSS(L,1)/SW
            B(J,1) = -MLT(1)*MC
C--now for the resonant sneutrinos
            DO I=1,2
              A(J,I+1) = WSGNSS(L)*WMXVSS(L,1)/SW
              B(J,I+1) = -MLT(I+1)*MC
            ENDDO
          ENDDO
C--coupling of the Z to the sneutrino
          ZNU = HALF/SW/CW
C--now the masses and IDs of the slepton in the radiative processes
C--IDs and masses of the charged sleptons
          DO I=1,2
            RADID(2,2*I-1) = 423+RSID(I)*2
            RADID(2,2*I  ) = 435+RSID(I)*2
            MSCL(I,1)      = RMASS(RADID(2,2*I-1))
            MSCL(I,2)      = RMASS(RADID(2,2*I))
            DO J=1,2
              MSCL2(I,J) = MSCL(I,J)**2
            ENDDO
          ENDDO
C--ID of the W for charged slepton processes
          DO I=1,4
            RADID(1,I) = 198
          ENDDO
C--ID's for the Z and gamma processes
          DO I=1,2
             RADID(1,I+4) = 200
             RADID(1,I+6) = 59
             RADID(2,I+4) = 424+RSID(I)*2
             RADID(2,I+6) = RADID(2,I+4)
          ENDDO
C--couplings of the sleptons to the Higgs
          DO I=1,2
            DO J=1,2
              K = 2*RSID(I)-1
              L = 119+2*RSID(I)
              HSL(I,J) = LMIXSS(K,1,J)*(RMASS(L)**2*TANB-MW2*SIN2B)
     &                   +LMIXSS(K,2,J)*RMASS(L)*MUSS
              IF(RSID(I).EQ.3) HSL(I,J) = HSL(I,J)
     &          +LMIXSS(K,2,J)*RMASS(L)*ALSS*TANB
              HSL(I,J) = HSL(I,J)/SQRT(HALF)/MW
            ENDDO
          ENDDO
C--coupling of the sneutrino to the Higgs
          HNU(1) =  HALF*MZ*SINBPA/CW
          HNU(2) = -HALF*MZ*COSBPA/CW
          HNU(3) = ZERO
C--couplings of the leptons to the Higgs
          RHO   =  HALF*MLT(1)/MW
          HL(1) = -RHO*SINA/COSB
          HL(2) =  RHO*COSA/COSB
          HL(3) =  RHO*TANB
          HL(4) =  RHO*TANB/SQRT(HALF)
C--Higgs Masses
          DO I=1,4
            MH(I)  = RMASS(202+I)
            MH2(I) = MH(I)**2
          ENDDO
        ENDIF
C--Now calculate the weights
        COSTH    = HWRUNI(1,-ONE,ONE)
        S        = PHEP(5,3)**2
        EMSCA    = PHEP(5,3)
        FACA     = HWUAEM(S)*GEV2NB/S/8.0D0
        FACD     = HALF*FACA/SWEIN
        FACB     = HALF*FACD/MW2
        FACC     = HALF*FACA/MZ2
        FACE     = ALPHEM*GEV2NB/S/8.0D0
        DO I=1,2
          SCF(I) = ONE/((S-MNUT2(I))**2+RMNUT(I))
        ENDDO
C--single neutralino production
        IF(.NOT.NEUT) THEN
          DO L=1,4
            DO J=1,4
              M1(L,J) = ZERO
            ENDDO
          ENDDO
          GOTO 100
        ENDIF
        DO L=NTID(1),NTID(2)
          DO J=1,2
            SQPE  = S - MNU2(L)
            K    = J+2
            IF(SQPE.GE.ZERO) THEN
              PF   = SQPE/S
              T    = HALF*(SQPE*COSTH-S+MNU2(L))
              U    = -T-S+MNU2(L)
              UP   = ONE/(U-MSL2)
              TP   = ONE/(T-MSR2)
              M1(L,J) = A(L,K)**2*S*(S-MNU2(L))*SCF(J)
     &                 +U*(U-MNU2(L))*(A(L,1)**2+B(L,2)**2)*UP**2
     &                 +T*(T-MNU2(L))*(A(L,2)**2+B(L,2)**2)*TP**2
     &                 +TWO*S*U*(S-MNUT2(J))*UP*SCF(J)*A(L,K)*A(L,1)
     &                 +TWO*S*T*(S-MNUT2(J))*TP*SCF(J)*A(L,K)*A(L,2)
     &                 +TWO*U*T*UP*TP*A(L,1)*A(L,2)
              M1(L,J) = LAMDA1(RSID(J),IL,IL)**2*FACA*PF*M1(L,J)
              M1(L,K) = M1(L,J)
            ELSE
              M1(L,J) = ZERO
              M1(L,K) = ZERO
            ENDIF
          ENDDO
        ENDDO
C--single chargino production
 100    IF(.NOT.CHAR) THEN
          DO L=1,2
            DO J=1,4
              M2(L,J) = ZERO
            ENDDO
          ENDDO
          GOTO 200
        ENDIF
        DO L = CHID(1),CHID(2)
          DO J = 1,2
            K  = J+1
            L2 = L+4
            SM  = MCH(L) + MLT(K)
            QPE = S - SM**2
            IF (QPE.GE.ZERO) THEN
              DM   = MCH(L) - MLT(K)
              SQPE = SQRT(QPE*(S-DM**2))
              PF   = SQPE/S
              T    = HALF*(SQPE*COSTH-S+MCH2(L)+MLT2(K))
              U    = -T-S+MCH2(L)+MLT2(K)
              UP   = ONE/(U-MSNU2)
              M2(L,J) = S*SCF(J)*(-FOUR*MLT(K)*MCH(L)*A(L2,K)*B(L2,K)
     &                  +(S-MLT2(K)-MCH2(L))*(A(L2,K)**2+B(L2,K)**2))
     &          +(MLT2(K)-U)*(MCH2(L)-U)*UP**2*(A(L2,1)**2+B(L2,1)**2)
     &          -TWO*S*(S-MNUT2(J))*UP*SCF(J)*A(L2,1)*
     &                  (U*A(L2,K)+MLT2(K)*MCH(L)*B(L2,K))
              M2(L,J)   = HALF*LAMDA1(RSID(J),IL,IL)**2*FACA*PF*M2(L,J)
              M2(L,J+2) = M2(L,J)
            ELSE
              M2(L,J)   = ZERO
              M2(L,J+2) = ZERO
            ENDIF
          ENDDO
        ENDDO
C--Radiative processes
 200    IF(.NOT.RAD) THEN
          DO I=1,8
            M3(I) = ZERO
          ENDDO
          GOTO 300
        ENDIF
        IF(GMAX.LT.7) THEN
C--W charged slepton production
          DO I=1,2
            DO J=1,2
              QPE = S-(MW+MSCL(I,J))**2
              IF(QPE.GE.ZERO) THEN
                DM   = MW-MSCL(I,J)
                SQPE = SQRT(QPE*(S-DM**2))
                PF   = SQPE/S
                T    = HALF*(SQPE*COSTH-S+MW2+MSCL2(I,J))
                U    = -T-S+MW2+MSCL2(I,J)
                UP   = ONE/U
                M3(2*I+J-2) = SCF(I)*S*SQPE**2
     &            +UP**2*(TWO*MW2*(U*T-MW2*MSCL2(I,J))+U**2*S)
     &            -TWO*UP*SCF(I)*(S-MNUT2(I))*S*(MW2*(TWO*MSCL2(I,J)-U)+
     &                  U*(S-MSCL2(I,J)))
                M3(2*I+J-2) = LAMDA1(RSID(I),IL,IL)**2*FACB*PF
     &             *LMIXSS(2*RSID(I)-1,1,J)**2*M3(2*I+J-2)
              ELSE
                M3(2*I+J-2) = ZERO
              ENDIF
            ENDDO
          ENDDO
C--Z sneutrino production
          DO I=1,2
            QPE = S-(MZ+MNUT(I))**2
            IF(QPE.GE.ZERO) THEN
              DM    = MZ-MNUT(I)
              SQPE  = SQRT(QPE*(S-DM**2))
              PF    = SQPE/S
              T     = HALF*(SQPE*COSTH-S+MZ2+MNUT2(I))
              U     = -T-S+MZ2+MNUT2(I)
              UP    = ONE/U
              TP    = ONE/T
              IDZ   = 9+RSID(I)*2
              M3(I+4) = SCF(I)*S*SQPE**2*ZNU**2
     &           +TP**2*RFCH(IDZ)**2*(TWO*MZ2*(U*T-MNUT2(I)*MZ2)+S*T**2)
     &           +UP**2*LFCH(IDZ)**2*(TWO*MZ2*(U*T-MNUT2(I)*MZ2)+S*U**2)
     &           -TWO*ZNU*RFCH(IDZ)*TP*S*SCF(I)*(S-MNUT2(I))*
     &               (MZ2*(TWO*MNUT2(I)-T)+T*(S-MNUT2(I)))
     &           +TWO*ZNU*LFCH(IDZ)*UP*S*SCF(I)*(S-MNUT2(I))*
     &               (MZ2*(TWO*MNUT2(I)-U)+U*(S-MNUT2(I)))
     &           +TWO*LFCH(IDZ)*RFCH(IDZ)*UP*TP*
     &               (TWO*MZ2*(MNUT2(I)-T)*(MNUT2(I)-U)-S*U*T)
              M3(I+4) = LAMDA1(RSID(I),IL,IL)**2*FACC*PF*M3(I+4)
            ELSE
              M3(I+4) = ZERO
            ENDIF
          ENDDO
        ELSE
C--gamma sneutrino production (includes Jacobian 1-costh**2)
          DO I=1,2
            SQPE = S-MNUT2(I)
            IF(SQPE.GE.ZERO) THEN
              PF       = SQPE/S
              PCM      = HALF*EMSCA*PF
              THTMIN   = PTMIN/PCM
              IF(THTMIN.GT.ONE) CALL HWWARN('HWHRES',502,*999)
              THTMIN   = ONE-THTMIN**2
              THTMIN   = HALF*LOG((1+THTMIN)/(1-THTMIN))
              RHO      = HWRUNI(2,-THTMIN,THTMIN)
              THCOS(I) = -TANH(RHO)
              T        = HALF*(SQPE*THCOS(I)-S+MNUT2(I))
              U        = -T-S+MNUT2(I)
              UP       = ONE/U
              TP       = ONE/T
              M3(I+6)  = U*TP+T*UP+TWO*UP*TP*(MNUT2(I)-U)*(MNUT2(I)-T)
              M3(I+6)  = LAMDA1(RSID(I),IL,IL)**2*FACE*PF*M3(I+6)*
     &                   (ONE-THCOS(I)**2)*THTMIN
            ELSE
              M3(I+2) = ZERO
            ENDIF
          ENDDO
        ENDIF
C--Higgs processes
 300    IF(.NOT.HIGGS) THEN
          DO I=1,10
            M4(I) = ZERO
          ENDDO
          GOTO 500
        ENDIF
C--Charged Higgs charged slepton production
        DO I=1,2
          DO J=1,2
            QPE = S-(MH(4)+MSCL(I,J))**2
            IF(QPE.GE.ZERO) THEN
              DM   = MH(4)-MSCL(I,J)
              SQPE = SQRT(QPE*(S-DM**2))
              PF   = SQPE/S
              T    = HALF*(SQPE*COSTH-S+MH2(4)+MSCL2(I,J))
              U    = -T-S+MH2(4)+MSCL2(I,J)
              M4(2*I+J-2) = HSL(I,J)**2*S*SCF(I)
     &                     +FOUR*LMIXSS(2*RSID(I)-1,1,J)**2*HL(4)**2
     &                          *(U*T-MSCL2(I,J)*MH2(4))/U**2
              M4(2*I+J-2) = FACD*LAMDA1(RSID(I),IL,IL)**2*M4(2*I+J-2)*PF
            ELSE
              M4(2*I+J-2) = ZERO
            ENDIF
          ENDDO
        ENDDO
C--neutral higgs sneutrino production
        DO L=1,3
          DO I=1,2
            QPE = S-(MH(L)+MNUT(I))**2
            IF(QPE.GE.ZERO) THEN
              DM   = MH(L)-MNUT(I)
              SQPE = SQRT(QPE*(S-DM**2))
              PF   = SQPE/S
              T    = HALF*(SQPE*COSTH-S+MH2(L)+MNUT2(I))
              U    = -T-S+MH2(L)+MNUT2(I)
              M4(2*L+I+2) = HNU(L)**2*S*SCF(I)
     &             +HL(L)**2*(ONE/T**2+ONE/U**2)*(U*T-MH2(L)*MNUT2(I))
              M4(2*L+I+2) = FACD*LAMDA1(RSID(I),IL,IL)**2*M4(2*L+I+2)*PF
            ELSE
              M4(2*L+I+2) = ZERO
            ENDIF
          ENDDO
        ENDDO
      ENDIF
C--Add up the weights now
 500  HCS = ZERO
C--single neutralino production
      IF(.NOT.NEUT) GOTO 550
      DO L=NTID(1),NTID(2)
        IG1= SSNU+L
        DO J=1,4
          IG2 = 126+2*RSID(MOD(J-1,2)+1)-6*INT((J-1)/2)
          HCS = HCS+M1(L,J)
          THSGN = (IDHEP(1).LT.IDHEP(2).AND.J.LE.2).OR.
     &            (IDHEP(1).GT.IDHEP(2).AND.J.GE.3)
          IF(GENEV.AND.HCS.GT.RCS) GOTO 900
        ENDDO
      ENDDO
C--single chargino production
 550  IF(.NOT.CHAR) GOTO 600
      DO L=CHID(1),CHID(2)
        DO J=1,4
          IG1 = SSCH+L-2*INT((J-1)/2)
          IG2 = 125+2*RSID(MOD((J-1),2)+1)-6*INT((J-1)/2)
          HCS = HCS + M2(L,J)
          THSGN = (IDHEP(1).LT.IDHEP(2).AND.J.LE.2).OR.
     &            (IDHEP(1).GT.IDHEP(2).AND.J.GE.3)
          IF (GENEV.AND.HCS.GT.RCS) GOTO 900
        ENDDO
      ENDDO
C--gauge boson slepton production
 600  IF(.NOT.RAD) GOTO 650
      DO I=GMIN,GMAX
        IG1 = RADID(1,I)
        IG2 = RADID(2,I)
        IF(I.GE.7) COSTH = THCOS(I-6)
        DO J=1,2
          HCS = HCS+M3(I)
          THSGN = (IDHEP(1).LT.IDHEP(2).AND.J.EQ.1).OR.
     &            (IDHEP(1).GT.IDHEP(2).AND.J.EQ.2)
          IF(GENEV.AND.HCS.GT.RCS) GOTO 900
          IF(I.LE.4) IG1 = IG1+1
          IG2 = IG2+6
        ENDDO
      ENDDO
C--higgs slepton production
 650  IF(.NOT.HIGGS) GOTO 900
C--charged Higgs slepton
      DO I=1,4
        IG1 = 207
        IG2 = RADID(2,I)+6
        DO J=1,2
          HCS=HCS+M4(I)
          THSGN = (IDHEP(1).LT.IDHEP(2).AND.J.EQ.1).OR.
     &            (IDHEP(1).GT.IDHEP(2).AND.J.EQ.2)
          IF(GENEV.AND.HCS.GT.RCS) GOTO 900
          IG1 = IG1-1
          IG2 = IG2-6
        ENDDO
      ENDDO
C--Neutral Higgs sneutrino
      DO L=1,3
        DO I=1,2
          IG1 = 202+L
          IG2 = 430+2*RSID(I)
          DO J=1,2
            HCS = HCS+M4(2+2*L+I)
            THSGN = (IDHEP(1).LT.IDHEP(2).AND.J.EQ.1).OR.
     &              (IDHEP(1).GT.IDHEP(2).AND.J.EQ.2)
            IF(GENEV.AND.HCS.GT.RCS) GOTO 900
            IG2 = IG2-6
          ENDDO
        ENDDO
      ENDDO
 900  IF(GENEV) THEN
C--change sign of COSTH if antiparticle first
        IF(THSGN) COSTH = -COSTH
C-Set up the particle types
        IDHW(NHEP+1)     = 15
        IDHEP(NHEP+1)    = 0
        ISTHEP(NHEP+1)   = 110
        IDHW(NHEP+2)     = IG1
        IDHW(NHEP+3)     = IG2
        IDHEP(NHEP+2)    = IDPDG(IG1)
        IDHEP(NHEP+3)    = IDPDG(IG2)
C--generate the particle masses and final-state momenta
        NTRY = 0
 910    NTRY = NTRY+1
        PHEP(5,NHEP+2)   = HWUMBW(IG1)
        PHEP(5,NHEP+3)   = HWUMBW(IG2)
C--Set up the Centre-of-mass energy
        CALL HWVEQU(5,PHEP(1,3),PHEP(1,NHEP+1))
        PCM   = HWUPCM(PHEP(5,NHEP+1),PHEP(5,NHEP+2),PHEP(5,NHEP+3))
        IF(PCM.LT.ZERO.AND.NTRY.LE.NETRY) THEN
          GOTO 910
        ELSEIF(PCM.LT.ZERO) THEN
          CALL HWWARN('HWHRES',100,*999)
        ENDIF
C--Set up the colours etc
        ISTHEP(NHEP+2)   = 113
        ISTHEP(NHEP+3)   = 114
        JMOHEP(1,NHEP+1) = 1
        IF (JDAHEP(1,1).NE.0) JMOHEP(1,NHEP+1)=JDAHEP(1,1)
        JMOHEP(2,NHEP+1) = 2
        IF (JDAHEP(1,2).NE.0) JMOHEP(1,NHEP+1)=JDAHEP(1,2)
        JMOHEP(1,NHEP+2) = NHEP+1
        JMOHEP(2,NHEP+2) = NHEP+2
        JMOHEP(1,NHEP+3) = NHEP+1
        JMOHEP(2,NHEP+3) = NHEP+3
        JDAHEP(1,NHEP+1) = NHEP+2
        JDAHEP(2,NHEP+1) = NHEP+3
        JDAHEP(1,NHEP+2) = 0
        JDAHEP(2,NHEP+2) = NHEP+2
        JDAHEP(1,NHEP+3) = 0
        JDAHEP(2,NHEP+3) = NHEP+3
C--set up the rest of the momenta
        IHEP  = NHEP+2
        PHEP(4,IHEP) = SQRT(PCM**2+PHEP(5,IHEP)**2)
        PHEP(3,IHEP) = PCM*COSTH
        PHEP(1,IHEP) = SQRT((PCM+PHEP(3,IHEP))*(PCM-PHEP(3,IHEP)))
        PHEP(2,IHEP) = ZERO
        CALL HWRAZM(PHEP(1,IHEP),PHEP(1,IHEP),PHEP(2,IHEP))
        CALL HWULOB(PHEP(1,NHEP+1),PHEP(1,IHEP),PHEP(1,IHEP))
        CALL HWVDIF(4,PHEP(1,NHEP+1),PHEP(1,IHEP),PHEP(1,IHEP+1))
        NHEP  = NHEP+3
      ELSE
        EVWGT = HCS
      ENDIF
 999  END
CDECK  ID>, HWHRLL.
*CMZ :-        -13/12/99  15:12:21  by  Peter Richardson
*-- Author :    Peter Richardson
C-----------------------------------------------------------------------
      SUBROUTINE HWHRLL
C-----------------------------------------------------------------------
C  Subroutine for resonant sleptons to standard model particles
C-----------------------------------------------------------------------
      INCLUDE 'HERWIG62.INC'
      DOUBLE PRECISION HCS,S,RCS,HWRGEN,FAC,ECM,TH,PCM,CFAC,CHANPB,SH,
     &                 TAU,TAUA,TAUB,LOWTLM,UPPTLM,HWRUNI,MSL(12),
     &                 SQSH,MET(2),SCF(12),MIX(12),ME(4,3,3,3,3,2),
     &                 RAND,CHAN(12),LAM(2,7,3,3,3,3),SLWD(12),RTAB,
     &                 WD,MQ1,MQ2,EPS,XMIN,XMAX,XPOW,XUPP,MSL2(12),
     &                 MSWD(12)
      INTEGER I,J,K,L,I1,J1,K1,L1,GEN,GN,GR,GNMX,GNMN,MIG,MXG,CUP,CF
      LOGICAL FIRST
      EXTERNAL HWRGEN,HWRUNI
      PARAMETER(EPS=1D-20)
      COMMON/HWRPIN/XMIN,XMAX,XPOW,FIRST
      SAVE HCS,ME,MSL,SLWD,LAM,MIX,CHAN,GNMN,GNMX,SH,SQSH,FAC,SCF
      IF(GENEV) THEN
        RCS = HCS*HWRGEN(0)
      ELSE
        IF(FSTWGT) THEN
          DO I=1,3
            MSL(2*I-1)  = RMASS(423+2*I)
            MSL(2*I)    = RMASS(435+2*I)
            MSL(2*I+5)  = RMASS(424+2*I)
            MSL(2*I+6)  = RMASS(436+2*I)
            SLWD(2*I-1) = HBAR/RLTIM(423+2*I)
            SLWD(2*I)   = HBAR/RLTIM(435+2*I)
            SLWD(2*I+5) = HBAR/RLTIM(424+2*I)
            SLWD(2*I+6) = HBAR/RLTIM(436+2*I)
          ENDDO
          DO I=1,12
             MSL2(I) = MSL(I)**2
             MSWD(I) = MSL(I)*SLWD(I)
          ENDDO
          RAND = ZERO
          DO I=1,3
            CHANPB=ZERO
            DO J=1,3
              DO K=1,3
                CHANPB=CHANPB+LAMDA2(I,J,K)**4
              ENDDO
            ENDDO
            RAND=RAND+2*CHANPB
            DO J=1,2
              CHAN(2*I-2+J) = LMIXSS(2*I-1,1,J)**2*CHANPB
              CHAN(2*I+4+J) = LMIXSS(2*I  ,1,J)**2*CHANPB
              MIX(2*I-2+J)  = LMIXSS(2*I-1,1,J)**2
              MIX(2*I+4+J)  = LMIXSS(2*I  ,1,J)**2
            ENDDO
          ENDDO
          IF(RAND.GT.ZERO) THEN
            DO I=1,12
              CHAN(I)=CHAN(I)/RAND
            ENDDO
          ELSE
            CALL HWWARN('HWHRLL',500,*999)
          ENDIF
C--find the couplings
          DO GN=1,3
            DO I=1,3
              DO J=1,3
                DO K=1,3
                  DO L=1,3
                    LAM(1,GN,I,J,K,L)  =LAMDA2(GN,I,J)*LAMDA1(GN,K,L)
                    LAM(2,GN,I,J,K,L)  =LAMDA2(GN,I,J)*LAMDA2(GN,K,L)
                    LAM(1,GN+3,I,J,K,L)=LAM(1,GN,I,J,K,L)
                    LAM(2,GN+3,I,J,K,L)=LAM(2,GN,I,J,K,L)
                  ENDDO
                ENDDO
              ENDDO
            ENDDO
          ENDDO
C--select the process from the IPROC code
          GNMN = 1
          GNMX = 4
          IF(IPROC.EQ.4070) THEN
            GNMX = 2
          ELSEIF(IPROC.EQ.4080) THEN
            GNMN = 3
          ENDIF
        ENDIF
        EVWGT = ZERO
        S     = PHEP(5,3)**2
        COSTH = HWRUNI(0,-ONE,ONE)
C--Generate the smoothing
        RAND=HWRUNI(0,ZERO,ONE)
        DO I=1,12
          IF(CHAN(I).GT.RAND) GOTO 20
          RAND=RAND-CHAN(I)
        ENDDO
 20     GR = I
C--Calculate hard scale and obtain parton distributions
        TAUA   = MSL2(GR)/S
        TAUB   = SLWD(GR)**2/S
        RTAB   = SQRT(TAUA*TAUB)
        XUPP = XMAX
        IF(XMAX**2.GT.S) XUPP = SQRT(S)
        LOWTLM = DATAN((XMIN**2/S-TAUA)/RTAB)/RTAB
        UPPTLM = DATAN((XUPP**2/S-TAUA)/RTAB)/RTAB
        TAU    = HWRUNI(0,LOWTLM,UPPTLM)
        TAU    = RTAB*TAN(RTAB*TAU)+TAUA
        SH     = S*TAU
        SQSH   = SQRT(SH)
        EMSCA  = SQSH
        XX(1)  = EXP(HWRUNI(0,ZERO,LOG(TAU)))
        XX(2)  = TAU/XX(1)
        CALL HWSGEN(.FALSE.)
C--Calculate the prefactor due multichannel approach
        FAC = ZERO
        DO GN=1,12
         SCF(GN)=1/((SH-MSL2(GN))**2+MSWD(GN)**2)
         FAC=FAC+CHAN(GN)*SCF(GN)
        ENDDO
        FAC=-(UPPTLM-LOWTLM)*LOG(TAU)*GEV2NB
     &         /(96*PIFAC*SQSH*SH*TAU*FAC*S**2)
      ENDIF
C--Now the loop to actually calculate the cross-sections
      HCS = ZERO
      DO GN=GNMN,GNMX
        IF(MOD(GN,2).EQ.1) THEN
          MIG = 1
          MXG = 6
        ELSE
          MIG = 7
          MXG = 12
        ENDIF
        IF(GN.LE.2) THEN
          CFAC = THREE*FAC
          CUP=2
        ELSE
          CFAC = FAC
          CUP=1
        ENDIF
        DO K1=1,3
          DO 80 L1=1,3
            IF(GN.EQ.1) THEN
              K = 2*K1
              L = 2*L1+5
            ELSEIF(GN.EQ.2) THEN
              K = 2*K1-1
              L = 2*L1+5
            ELSEIF(GN.EQ.3) THEN
              K = 120+2*K1
              L = 125+2*L1
            ELSEIF(GN.EQ.4) THEN
              K = 119+2*K1
              L = 125+2*L1
            ENDIF
            MQ1 = RMASS(K)
            MQ2 = RMASS(L)
            IF(SQSH.GT.(MQ1+MQ2)) THEN
              PCM = SQRT((SH-(MQ1+MQ2)**2)*(SH-(MQ1-MQ2)**2))/(2*SQSH)
              WD = (SH-MQ1**2-MQ2**2)*SH*PCM
            ELSE
              GOTO 80
            ENDIF
            DO I1=1,3
              DO 70 J1=1,3
                IF(MOD(GN,2).EQ.1) THEN
                  I=2*I1
                  J=2*J1+5
                ELSE
                  I=2*I1-1
                  J=2*J1+5
                ENDIF
                DO GR =1,2
                  MET(GR) = ZERO
                ENDDO
                IF(GENEV) GOTO 60
                DO 50 GEN=MIG,MXG
                  IF(ABS(LAM(CUP,INT((GEN+1)/2),I1,J1,K1,L1)).LT.EPS.
     &                OR.ABS(MIX(GEN)).LT.EPS) GOTO 50
                  DO GR=MIG,MXG
                    IF(ABS(LAM(CUP,INT((GR+1)/2),I1,J1,K1,L1)).GT.EPS.
     &                AND.ABS(MIX(GR)).GT.EPS) THEN
                      MET(1) =MET(1)+SCF(GEN)*SCF(GR)*WD*
     &                 ((SH-MSL2(GEN))*(SH-MSL2(GR))+MSWD(GEN)*MSWD(GR))
     &                 *LAM(CUP,INT((GEN+1)/2),I1,J1,K1,L1)*MIX(GEN)
     &                 *LAM(CUP,INT((GR+1)/2),I1,J1,K1,L1)*MIX(GR)
                    ENDIF
                  ENDDO
C--Now the t-channel diagrams if the s-channel particles is a sneutrino
                  IF(GN.EQ.2) THEN
                    ECM=SQRT(PCM**2+MQ1**2)
                    TH=MQ1**2-SQSH*(ECM-PCM*COSTH)
                    DO GR=MIG,MXG
                      MET(2)=MET(2)+(MQ1**2-TH)*(MQ2**2-TH)*PCM*
     &                       LAM(2,INT((GEN+1)/2),I1,K1,J1,L1)*MIX(GEN)*
     &                       LAM(2,INT((GR+1)/2),I1,K1,J1,L1)*MIX(GR)
     &                       /((TH-MSL2(GEN))*(TH-MSL2(GR)))
                    ENDDO
                   ENDIF
 50              CONTINUE
C--final phase space factors
                IF(MET(1).LT.EPS.AND.MET(2).LT.EPS) GOTO 70
                DO GR = 1,2
                  ME(GN,I1,J1,K1,L1,GR) = MET(GR)*CFAC
                ENDDO
 60             DO GR = 1,2
                  CF = GR
                  IF(CUP.EQ.1) CF=0
                  HCS = HCS+ME(GN,I1,J1,K1,L1,GR)*DISF(I,1)*DISF(J,2)
                  IF(HCS.GT.RCS.AND.GENEV)
     &                           CALL HWHRSS(9,I,J,K,L,0,CF,*100)
                  HCS = HCS+ME(GN,I1,J1,K1,L1,GR)*DISF(J,1)*DISF(I,2)
                  IF(HCS.GT.RCS.AND.GENEV)
     &                           CALL HWHRSS(10,J,I,K,L,0,CF,*100)
                  HCS = HCS+ME(GN,I1,J1,K1,L1,GR)
     &                                       *DISF(I+6,1)*DISF(J-6,2)
                  IF(HCS.GT.RCS.AND.GENEV)
     &                           CALL HWHRSS(9,I,J,K,L,1,CF,*100)
                  HCS = HCS+ME(GN,I1,J1,K1,L1,GR)
     &                                       *DISF(J-6,1)*DISF(I+6,2)
                  IF(HCS.GT.RCS.AND.GENEV)
     &                           CALL HWHRSS(10,J,I,K,L,1,CF,*100)
                ENDDO
 70           CONTINUE
            ENDDO
 80       CONTINUE
        ENDDO
      ENDDO
 100  IF(GENEV) THEN
        CALL HWETWO
      ELSE
        EVWGT = HCS
      ENDIF
 999  END
CDECK  ID>, HWHRLS.
*CMZ :-        -23/10/00  13:53:06  by  Peter Richardson
*-- Author :    Peter Richardson
C-----------------------------------------------------------------------
      SUBROUTINE HWHRLS
C-----------------------------------------------------------------------
C  Subroutine for 2 parton -> sparticle + X via LQD
C-----------------------------------------------------------------------
      INCLUDE 'HERWIG62.INC'
      DOUBLE PRECISION HCS,A(6,12),B(6,12),S,RCS,HWRGEN,CW,FAC2,EC,ME2,
     &               MW,G,TAU,TAUA,TAUB,LOWTLM,UPPTLM,HWRUNI,SW,SQSH,LC,
     &               SH,MSL(12),MSU(12),MST(6),C(2,6,12),D(2,6,12),UH,
     &               TH,MEN(4,6,3,3),SCF(12),SLWD(12),MLT(6),MNT(4),PCM,
     &               MXS(12),MER(8),MCR(2),RTAB,H(18),MEH(3,18),MXT(12),
     &               CHAN(12),MXU(12),RAND,FAC,ECM,MC(2),MEC(2,6,3,3),
     &               MZ,CHPROB,EPS,HWUAEM,XMIN,XMAX,XPOW,SIN2B,GUU(4),
     &               ML,MN,MLS,MNS,XUPP,MW2,MZ2,ZSLP(2),ZQRK(2),GDD(4),
     &               MSL2(12),MH(4),MSWD(12)
      INTEGER I,J,K,L,J1,K1,GN,GR,SP,GU,GT,I2,I1,NEUTMN
     &        ,NEUTMX,CHARMN,CHARMX,P
      LOGICAL RAD,NEUT,CHAR,HIGGS,FIRST
      EXTERNAL HWRGEN,HWRUNI,HWUAEM
      COMMON/HWRPIN/XMIN,XMAX,XPOW,FIRST
      SAVE HCS,A,B,C,D,FAC,MER,MEC,MEN,MLT,MSL,MSU,MST,SLWD,MNT,MXT,MXU,
     &     SW,CW,MXS,H,MEH,CHAN,NEUTMN,NEUTMX,CHARMN,CHARMX,RAD,NEUT,
     &     CHAR,HIGGS,MW,MZ,MW2,MZ2,MCR,SH,SQSH,EC,G,SCF,ZSLP,ZQRK,GUU,
     &     GDD,MSL2,MH,MSWD
      PARAMETER(EPS=1D-20)
      IF(GENEV) THEN
        RCS = HCS*HWRGEN(0)
      ELSE
        IF(FSTWGT) THEN
C--Calculate Electroweak parameters needed
          SW  = SQRT(SWEIN)
          CW  = SQRT(1-SWEIN)
          MW  = RMASS(198)
          MZ  = RMASS(200)
          MW2 = MW**2
          MZ2 = MZ**2
          SIN2B = TWO*SINB*COSB
C--Masses and widths
          DO I=1,3
            MSL(2*I-1)  = RMASS(423+2*I)
            MSL(2*I)    = RMASS(435+2*I)
            MSL(2*I+5)  = RMASS(424+2*I)
            MSL(2*I+6)  = RMASS(436+2*I)
            SLWD(2*I-1) = HBAR/RLTIM(423+2*I)
            SLWD(2*I)   = HBAR/RLTIM(435+2*I)
            SLWD(2*I+5) = HBAR/RLTIM(424+2*I)
            SLWD(2*I+6) = HBAR/RLTIM(436+2*I)
            MSU(2*I-1)  = RMASS(400+2*I)**2
            MSU(2*I)    = RMASS(412+2*I)**2
            MSU(2*I+5)  = RMASS(399+2*I)**2
            MSU(2*I+6)  = RMASS(411+2*I)**2
            MST(2*I-1)  = RMASS(399+2*I)**2
            MST(2*I)    = RMASS(411+2*I)**2
            MLT(2*I)    = ZERO
            MLT(2*I-1)  = RMASS(119+2*I)
          ENDDO
          DO I=1,12
             MSL2(I) = MSL(I)**2
             MSWD(I) = MSL(I)*SLWD(I)
          ENDDO
          DO I=1,4
            MNT(I)   = ABS(RMASS(449+I))
          ENDDO
          MCR(1) = ABS(RMASS(454))
          MCR(2) = ABS(RMASS(455))
C--Couplings for the neutralinos
          DO L=1,4
            MC(1) =  ZMIXSS(L,3)/(2*MW*COSB*SW)
            MC(2) =  ZMIXSS(L,4)/(2*MW*SINB*SW)
            DO I=1,3
              DO J=1,2
C--resonant charged sleptons
                A(L,2*I-2+J) = MC(1)*MLT(2*I-1)*LMIXSS(2*I-1,2,J)
     &                         +SLFCH(9+2*I,L)*LMIXSS(2*I-1,1,J)
                B(L,2*I-2+J) = ZSGNSS(L)*(MC(1)*MLT(2*I-1)*
     &            LMIXSS(2*I-1,1,J)+SRFCH(9+2*I,L)*LMIXSS(2*I-1,2,J))
C--resonant sneutrinos
                A(L,2*I+4+J) = SLFCH(10+2*I,L)*LMIXSS(2*I,1,J)
                B(L,2*I+4+J) = ZERO
C--u channel up type squarks
                C(1,L,2*I-2+J) = MC(2)*QMIXSS(2*I,2,J)*
     &                    RMASS(2*I)+SLFCH(2*I,L)*QMIXSS(2*I,1,J)
                D(1,L,2*I-2+J) = ZSGNSS(L)*(MC(2)*QMIXSS(2*I,1,J)*
     &                    RMASS(2*I)+SRFCH(2*I  ,L)*QMIXSS(2*I,2,J))
C--u channel down type squarks
                C(1,L,2*I+4+J) = MC(1)*QMIXSS(2*I-1,2,J)*
     &                    RMASS(2*I-1)+SLFCH(2*I-1,L)*QMIXSS(2*I-1,1,J)
                D(1,L,2*I+4+J) = ZSGNSS(L)*(MC(1)*QMIXSS(2*I-1,1,J)*
     &                    RMASS(2*I-1)+SRFCH(2*I-1,L)*QMIXSS(2*I-1,2,J))
C--t channel down type squarks
                C(2,L,2*I-2+J) = ZSGNSS(L)*(MC(1)*QMIXSS(2*I-1,1,J)*
     &                    RMASS(2*I-1)+SRFCH(2*I-1,L)*QMIXSS(2*I-1,2,J))
                D(2,L,2*I-2+J) = MC(1)*QMIXSS(2*I-1,2,J)*
     &                    RMASS(2*I-1)+SLFCH(2*I-1,L)*QMIXSS(2*I-1,1,J)
              ENDDO
            ENDDO
            DO I=1,6
              C(2,L,6+I) = C(2,L,I)
              D(2,L,6+I) = D(2,L,I)
            ENDDO
          ENDDO
C--Couplings for charginos
          DO L=1,2
            MC(1) = 1/(SQRT(2.0D0)*MW*COSB)
            MC(2) = 1/(SQRT(2.0D0)*MW*SINB)
            SP=L+4
            DO I=1,3
              DO J=1,2
C--resonant charged slepton
                A(SP,2*I-2+J) = WMXUSS(L,1)*LMIXSS(2*I-1,1,J)
     &                          -LMIXSS(2*I-1,2,J)*WMXUSS(L,2)*
     &                             MLT(2*I-1)*MC(1)
                B(SP,2*I-2+J) = ZERO
C--resonant sneutrinos
                A(SP,2*I+4+J) = WSGNSS(L)*WMXVSS(L,1)*LMIXSS(2*I,1,J)
                B(SP,2*I+4+J) = -MLT(2*I-1)*WMXUSS(L,2)*LMIXSS(2*I,1,J)
     &                           *MC(1)
C--u channel sup
                C(1,SP,2*I-2+J) = WSGNSS(L)*(WMXVSS(L,1)*QMIXSS(2*I,1,J)
     &              -WMXVSS(L,2)*MC(2)*RMASS(2*I)*QMIXSS(2*I,2,J))
                D(1,SP,2*I-2+J) = -WMXUSS(L,2)*MC(1)*RMASS(2*I-1)
     &                            *QMIXSS(2*I,1,J)
C--u channel sdown
                C(1,SP,2*I+4+J) = WMXUSS(L,1)*QMIXSS(2*I-1,1,J)
     &              -WMXUSS(L,2)*MC(1)*RMASS(2*I-1)*QMIXSS(2*I-1,2,J)
                D(1,SP,2*I+4+J) = -WSGNSS(L)*WMXVSS(L,2)*MC(2)*
     &                            RMASS(2*I)*QMIXSS(2*I-1,1,J)
              ENDDO
            ENDDO
          ENDDO
C--Couplings and massesfor Higgs
          DO I=1,4
             MH(I) = RMASS(202+I)
          ENDDO
C--first the neutral Higgs
C--fix to the sign of the A and mu term 31/03/00 PR
          DO I=1,3
            H(I)  = MLT(2*I-1)*HALF/MW/COSB*MUSS*COSA
            H(I+4) = MLT(2*I-1)*HALF/MW/COSB*MUSS*SINA
            H(I+8) =  -MLT(2*I-1)*HALF/MW*MUSS
          ENDDO
          H(3) = (H(3)+MLT(5)*HALF/MW/COSB*ALSS*SINA)*TWO*
     &           LMIXSS(5,2,1)*LMIXSS(5,1,1)
     &           -MZ*SINBPA/CW*(LMIXSS(5,1,1)**2*(HALF-SWEIN)
     &           +SWEIN*LMIXSS(5,2,1)**2)+MLT(5)**2*SINA/MW/COSB
          H(4) = -MZ*SINBPA/CW*(LMIXSS(5,1,1)*LMIXSS(5,1,2)*(HALF-SWEIN)
     &            +SWEIN*LMIXSS(5,2,1)*LMIXSS(5,2,2))
     &            +MLT(5)*HALF/COSB/MW*(MUSS*COSA+ALSS*SINA)*
     &         (LMIXSS(5,2,2)*LMIXSS(5,1,1)+LMIXSS(5,1,2)*LMIXSS(5,2,1))
          H(7) = (H(7)-MLT(5)*HALF/MW/COSB*ALSS*COSA)*TWO*
     &            LMIXSS(5,2,1)*LMIXSS(5,1,1)
     &            +MZ*COSBPA/CW*(LMIXSS(5,1,1)**2*(HALF-SWEIN)
     &            +LMIXSS(5,2,1)**2*SWEIN)-MLT(5)**2*COSA/MW/COSB
          H(8) = MZ*COSBPA/CW*(LMIXSS(5,1,2)*LMIXSS(5,1,1)*(HALF-SWEIN)
     &            +LMIXSS(5,2,2)*LMIXSS(5,2,1)*SWEIN)
     &            +MLT(5)*HALF/MW/COSB*(MUSS*SINA-ALSS*COSA)*
     &         (LMIXSS(5,2,2)*LMIXSS(5,1,1)+LMIXSS(5,1,2)*LMIXSS(5,2,1))
          H(12) = H(11)-MLT(5)*HALF/MW*ALSS*TANB
          H(11) = ZERO
C--Now the charged Higgs
          DO J=1,2
            DO I=1,3
              H(10+2*I+J) = LMIXSS(2*I-1,1,J)*
     &                                  (MLT(2*I-1)**2*TANB-MW2*SIN2B)
     &                      +LMIXSS(2*I-1,2,J)*MLT(2*I-1)*MUSS
            ENDDO
            H(16+J) = H(16+J)+LMIXSS(5,2,J)*MLT(5)*ALSS*TANB
          ENDDO
C--End of fix
C--couplings of the Higgs to quarks
          DO I=1,3
             GUU(I) = GHUUSS(I)**2/MW2*HALF**2
             GDD(I) = GHDDSS(I)**2/MW2*HALF**2
          ENDDO
          GUU(4) = ONE/TANB**2/MW2/8.0D0
          GDD(4) = ONE*TANB**2/MW2/8.0D0
C--Couplings of the Z to quarks, left up right down, and charged sleptons
          ZQRK(1) = -SW**2/6.0D0/CW
          ZQRK(2) =  (SW**2/3.0D0-HALF**2)/CW
          ZSLP(1) =  HALF*(LMIXSS(5,1,1)**2-2.0D0*SW**2)/CW
          ZSLP(2) =  HALF*LMIXSS(5,1,1)*LMIXSS(5,1,2)/CW
C--parameters for multichannel integration
          RAND = ZERO
          DO I=1,3
            CHPROB = ZERO
            DO J=1,3
              DO K=1,3
                CHPROB=CHPROB+LAMDA2(I,J,K)**2
              ENDDO
            ENDDO
            RAND = RAND+2*CHPROB
            DO J=1,2
              MXS(2*I-2+J)  = LMIXSS(2*I-1,1,J)
              MXS(2*I+4+J)  = LMIXSS(2*I,1,J)
              MXU(2*I-2+J)   = QMIXSS(2*I,1,J)
              MXU(2*I+4+J)   = QMIXSS(2*I-1,1,J)
              MXT(2*I-2+J)   = QMIXSS(2*I-1,2,J)
              MXT(2*I+4+J)   = QMIXSS(2*I-1,2,J)
              CHAN(2*I-2+J) = LMIXSS(2*I-1,1,J)**2*CHPROB
              CHAN(2*I+4+J) = LMIXSS(2*I,1,J)**2*CHPROB
            ENDDO
          ENDDO
          IF(RAND.GT.ZERO) THEN
            DO I=1,12
              CHAN(I)=CHAN(I)/RAND
            ENDDO
          ELSE
            CALL HWWARN('HWHRLS',500,*999)
          ENDIF
C--decide what processes to generate
          RAD   = .FALSE.
          NEUT  = .FALSE.
          CHAR  = .FALSE.
          HIGGS = .FALSE.
          NEUTMN= 1
          NEUTMX = 4
          CHARMN = 1
          CHARMX = 2
C--Decide which process to generate
          IF(IPROC.EQ.4000) THEN
            RAD   = .TRUE.
            NEUT  = .TRUE.
            CHAR  = .TRUE.
            HIGGS = .TRUE.
          ELSEIF(IPROC.LT.4020) THEN
            IF(IPROC.NE.4010) THEN
              NEUTMN = MOD(IPROC,10)
              NEUTMX = NEUTMN
            ENDIF
            NEUT=.TRUE.
          ELSEIF(IPROC.LT.4030) THEN
            IF(IPROC.NE.4020) THEN
              CHARMN = MOD(IPROC,10)
              CHARMX=CHARMN
            ENDIF
            CHAR  = .TRUE.
          ELSEIF(IPROC.EQ.4040) THEN
            RAD   = .TRUE.
          ELSEIF(IPROC.EQ.4050) THEN
            HIGGS = .TRUE.
          ENDIF
        ENDIF
C--basic parameters
        EVWGT = ZERO
        S     = PHEP(5,3)**2
        COSTH = HWRUNI(0,-ONE,ONE)
        RAND  = HWRUNI(0,ZERO,ONE)
C--zero arrays
        DO I=1,6
          DO J=1,3
            DO K=1,3
              DO L=1,2
               MEN(L,I,J,K)   = ZERO
               MEN(L+2,I,J,K) = ZERO
               MEC(L,I,J,K)   = ZERO
              ENDDO
            ENDDO
          ENDDO
        ENDDO
        DO I=1,8
          MER(I)=ZERO
        ENDDO
C--Perform multichannel integration
        DO I=1,12
          IF(CHAN(I).GT.RAND) THEN
             GR=I
             GOTO 25
          ENDIF
          RAND=RAND-CHAN(I)
        ENDDO
C--Calculate the hard scale and obtain parton distributions
 25     TAUA   = MSL2(GR)/S
        TAUB   = SLWD(GR)**2/S
        RTAB   = SQRT(TAUA*TAUB)
        XUPP = XMAX
        IF(XMAX**2.GT.S) XUPP = SQRT(S)
        LOWTLM = DATAN((XMIN**2/S-TAUA)/RTAB)/RTAB
        UPPTLM = DATAN((XUPP**2/S-TAUA)/RTAB)/RTAB
        TAU    = HWRUNI(0,LOWTLM,UPPTLM)
        TAU    = RTAB*TAN(RTAB*TAU)+TAUA
        SH   = S*TAU
        SQSH = SQRT(SH)
        EMSCA  = SQSH
        XX(1)  = EXP(HWRUNI(0,LOG(TAU),ZERO))
        XX(2)  = TAU/XX(1)
        CALL HWSGEN(.FALSE.)
C--EM and Weak couplings
        EC = SQRT(4*PIFAC*HWUAEM(SH))
        G  = EC/SW
C--Calculate the prefactor due multichannel approach
        FAC = ZERO
        DO GN=1,12
         SCF(GN)=1/((SH-MSL2(GN))**2+MSWD(GN)**2)
         FAC=FAC+CHAN(GN)*SCF(GN)
        ENDDO
        FAC=-(UPPTLM-LOWTLM)*GEV2NB*LOG(TAU)/
     &       (48*TAU*FAC*PIFAC*S**2*SH*SQSH)
      ENDIF
      HCS = ZERO
C--First we do the neutralino production
      IF(.NOT.NEUT) GOTO 200
      DO 140 GN=1,6
      I=GN
      GR = 2*GN-1
      I1 = 2*GN-1
      IF(GN.GT.3) THEN
        I=I-3
        I1=I1-5
      ENDIF
      IF(CHAN(GR).LT.EPS) GOTO 140
        DO 130 L=NEUTMN,NEUTMX
        MN  = MNT(L)
        MNS = MN**2
        ML  = MLT(I1)
        MLS = ML**2
        IF((ML+MN).GT.SQSH) GOTO 130
C--that and uhat
        PCM = SQRT((SH-(ML+MN)**2)*(SH-(ML-MN)**2))*HALF/SQSH
        ECM = SQRT(PCM**2+MLS)
        TH = MLS-SQSH*(ECM-PCM*COSTH)
        UH = MLS-SQSH*(ECM+PCM*COSTH)
        DO J=1,3
          DO 120 K=1,3
            IF(ABS(LAMDA2(I,J,K)).LT.EPS) GOTO 120
            J1 = 2*J
            K1 = 2*K+5
            IF(GN.GT.3) J1=J1-1
            IF(GENEV) GOTO 110
C--squarks in u and t channels
            GU = 6*INT((GN-1)/3)+2*J-1
            GT = 2*K
C--calulate the matrix element
            ME2=MXS(GR)**2*SCF(GR)*SH*((SH-MLS-MNS)*
     &            (A(L,GR)**2+B(L,GR)**2)-4*ML*MN*A(L,GR)*B(L,GR))
     &          +MXU(GU)**2*(MLS-UH)*(MNS-UH)*
     &               (C(1,L,GU)**2+D(1,L,GU)**2)/(UH-MSU(GU))**2
     &          +MXT(GT)**2*(MLS-TH)*(MNS-TH)*
     &               (C(2,L,GT)**2+D(2,L,GT)**2)/(TH-MST(GT))**2
     &          -TWO*MXT(GT)*MXU(GU)*C(1,L,GU)*C(2,L,GT)*(MLS*MNS-UH*TH)
     &                 /(UH-MSU(GU))/(TH-MST(GT))
     &          +TWO*MXS(GR)*MXU(GU)*(SH-MSL2(GR))*SCF(GR)*C(1,L,GU)*
     &                 SH*(UH*A(L,GR)+ML*MN*B(L,GR))/(UH-MSU(GU))
     &          +TWO*MXS(GR)*MXT(GT)*(SH-MSL2(GR))*SCF(GR)*C(2,L,GT)*
     &                 SH*(TH*A(L,GR)+ML*MN*B(L,GR))/(TH-MST(GT))
C--s channel mixing L/R mixing
            IF(ABS(MXS(GR+1)).GT.EPS) THEN
              ME2=ME2+MXS(GR+1)**2*SCF(GR+1)*SH*((SH-MLS-MNS)*
     &               (A(L,GR+1)**2+B(L,GR+1)**2)
     &               -4*ML*MN*A(L,GR+1)*B(L,GR+1))
     &            +TWO*MXS(GR)*MXS(GR+1)*SCF(GR)*SCF(GR+1)*
     &               ((SH-MSL2(GR))*(SH-MSL2(GR+1))+
     &               MSWD(GR)*MSWD(GR+1))*SH*
     &               ((SH-MLS-MNS)*(A(L,GR)*A(L,GR+1)+B(L,GR)*B(L,GR+1))
     &               -2*ML*MN*(A(L,GR)*B(L,GR+1)+A(L,GR+1)*B(L,GR)))
     &            +TWO*MXS(GR+1)*MXU(GU)*(SH-MSL2(GR+1))*SCF(GR+1)*
     &               SH*C(1,L,GU)*(UH*A(L,GR+1)+ML*MN*B(L,GR+1))
     &               /(UH-MSU(GU))
     &            +TWO*MXS(GR+1)*MXT(GT)*(SH-MSL2(GR+1))*SCF(GR+1)*
     &               SH*C(2,L,GT)*(TH*A(L,GR+1)+ML*MN*B(L,GR+1))
     &               /(TH-MST(GT))
              IF(ABS(MXU(GU+1)).GT.EPS) ME2=ME2+TWO*MXS(GR+1)*MXU(GU+1)*
     &               (SH-MSL2(GR+1))*SCF(GR+1)*SH*C(1,L,GU+1)*
     &               (UH*A(L,GR+1)+ML*MN*B(L,GR+1))/(UH-MSU(GU+1))
              IF(ABS(MXT(GT-1)).GT.EPS) ME2=ME2+TWO*MXS(GR+1)*MXT(GT-1)*
     &               (SH-MSL2(GR+1))*SCF(GR+1)*SH*C(2,L,GT-1)*
     &               (TH*A(L,GR+1)+ML*MN*B(L,GR+1))/(TH-MST(GT-1))
            ENDIF
C--u channel L/R mixing
            IF(ABS(MXU(GU+1)).GT.EPS) THEN
              ME2=ME2+MXU(GU+1)**2*(MLS-UH)*(MNS-UH)*(C(1,L,GU+1)**2+
     &               D(1,L,GU+1)**2)/(UH-MSU(GU+1))**2
     &            +TWO*MXU(GU)*MXU(GU+1)*(MLS-UH)*(MNS-UH)*
     &               (C(1,L,GU)*C(1,L,GU+1)+D(1,L,GU)*D(1,L,GU+1))
     &               /(UH-MSU(GU))/(UH-MSU(GU+1))
     &            -TWO*MXT(GT)*MXU(GU+1)*C(1,L,GU+1)*C(2,L,GT)*
     &               (MLS*MNS-UH*TH)/(UH-MSU(GU+1))/(TH-MST(GT))
     &            +TWO*MXS(GR)*MXU(GU+1)*(SH-MSL2(GR))*SCF(GR)*
     &               SH*C(1,L,GU+1)*(UH*A(L,GR)+ML*MN*B(L,GR))
     &               /(UH-MSU(GU+1))
              IF(ABS(MXT(GT-1)).GT.EPS) ME2=ME2-TWO*MXT(GT-1)*MXU(GU+1)*
     &               C(1,L,GU+1)*C(2,L,GT-1)*(MLS*MNS-UH*TH)
     &               /(UH-MSU(GU+1))/(TH-MST(GT-1))
            ENDIF
C--t channel L/R mixing
            IF(ABS(MXT(GT-1)).GT.EPS) THEN
              ME2=ME2+MXT(GT-1)**2*(MLS-TH)*(MNS-TH)*(C(2,L,GT-1)**2
     &                +D(2,L,GT-1)**2)/(TH-MST(GT-1))**2
     &            +TWO*MXT(GT)*MXT(GT-1)*(MLS-TH)*(MNS-TH)*
     &               (C(2,L,GT)*C(2,L,GT-1)+D(2,L,GT)*D(2,L,GT-1))
     &               /(TH-MST(GT))/(TH-MST(GT-1))
     &            -TWO*MXT(GT-1)*MXU(GU)*C(1,L,GU)*C(2,L,GT-1)*
     &               (MLS*MNS-UH*TH)/(UH-MSU(GU))/(TH-MST(GT-1))
     &            +TWO*MXS(GR)*MXT(GT-1)*(SH-MSL2(GR))*SCF(GR)*
     &               SH*C(2,L,GT-1)*(TH*A(L,GR)+ML*MN*B(L,GR))
     &               /(TH-MST(GT-1))
            ENDIF
C--multiply by lamda and factors
            MEN(L,GN,J,K) = FAC*ME2*EC**2*LAMDA2(I,J,K)**2*PCM
 110        I2=I1+6
            HCS = HCS+MEN(L,GN,J,K)*DISF(J1,1)*DISF(K1,2)
            IF(GENEV.AND.HCS.GT.RCS) CALL HWHRSS(11,J1,K1,I2,L,0,0,*500)
            HCS = HCS+MEN(L,GN,J,K)*DISF(K1,1)*DISF(J1,2)
            IF(GENEV.AND.HCS.GT.RCS) CALL HWHRSS(12,K1,J1,I2,L,0,0,*500)
            HCS = HCS+MEN(L,GN,J,K)*DISF(J1+6,1)*DISF(K1-6,2)
            IF(GENEV.AND.HCS.GT.RCS) CALL HWHRSS(11,J1,K1,I2,L,1,0,*500)
            HCS = HCS+MEN(L,GN,J,K)*DISF(K1-6,1)*DISF(J1+6,2)
            IF(GENEV.AND.HCS.GT.RCS) CALL HWHRSS(12,K1,J1,I2,L,1,0,*500)
 120      CONTINUE
        ENDDO
 130    CONTINUE
 140  CONTINUE
 200  IF(.NOT.CHAR) GOTO 300
C--Chargino production
      DO 240 GN=1,6
      GR=2*GN-1
      I=GN
      I1 = 2*GN
      IF(GN.GT.3) THEN
        I1=I1-7
        I=GN-3
      ENDIF
      IF(CHAN(GR).LT.EPS) GOTO 240
      DO 230 L=CHARMN,CHARMX
        MN  = MCR(L)
        MNS = MN**2
        ML  = MLT(I1)
        MLS = ML**2
        SP = L+4
        IF((ML+MN).GT.EMSCA) GOTO 230
        PCM = SQRT((SH-(ML+MN)**2)*(SH-(ML-MN)**2))*HALF/SQSH
        ECM = SQRT(PCM**2+MLS)
        TH = MLS-SQSH*(ECM-PCM*COSTH)
        UH = MLS-SQSH*(ECM+PCM*COSTH)
        DO J=1,3
          DO 220 K=1,3
            IF(ABS(LAMDA2(I,J,K)).LT.EPS) GOTO 220
            J1=2*J
            K1=2*K+5
            IF(GN.GT.3) J1=J1-1
            IF(GENEV) GOTO 210
            GU = 2*J-1
            IF(GN.LE.3) GU=GU+6
C--Calculate the matrix element, s and u terms
             ME2 =MXS(GR)**2*SCF(GR)*SH*(
     &             (SH-MLS-MNS)*(A(SP,GR)**2+B(SP,GR)**2)
     &             -4*ML*MN*A(SP,GR)*B(SP,GR))
     &          +MXU(GU)**2*(MLS-UH)*(MNS-UH)*
     &             (C(1,SP,GU)**2+D(1,SP,GU)**2)/(UH-MSU(GU))**2
     &          -2*MXS(GR)*MXU(GU)*(SH-MSL2(GR))*SCF(GR)*C(1,SP,GU)*
     &             SH*(UH*A(SP,GR)+B(SP,GR)*ML*MN)/(UH-MSU(GU))
C--s channel L/R mixing
            IF(ABS(MXS(GR+1)).GT.EPS) THEN
              ME2=ME2+MXS(GR+1)**2*SCF(GR+1)*SH*((SH-MLS-MNS)*
     &               (A(SP,GR+1)**2+B(SP,GR+1)**2)
     &                -4*ML*MN*A(SP,GR+1)*B(SP,GR+1))
     &           +2*MXS(GR)*MXS(GR+1)*SCF(GR)*SCF(GR+1)*
     &               ((SH-MSL2(GR))*(SH-MSL2(GR+1))+
     &               MSWD(GR)*MSWD(GR+1))*SH*
     &               ((SH-MLS-MNS)*(A(SP,GR)*A(SP,GR+1)
     &               +B(SP,GR)*B(SP,GR+1))-4*ML*MN*
     &               (A(SP,GR)*B(SP,GR+1)+B(SP,GR)*A(SP,GR+1)))
     &           -2*MXS(GR+1)*MXU(GU)*(SH-MSL2(GR+1))*SCF(GR+1)*SH*
     &               C(1,SP,GU)*(UH*A(SP,GR+1)+B(SP,GR+1)*ML*MN)
     &               /(UH-MSU(GU))
              IF(ABS(MXU(GU+1)).GT.EPS) ME2=ME2-2*MXS(GR+1)*MXU(GU+1)*
     &               (SH-MSL2(GR+1))*SCF(GR+1)*C(1,SP,GU+1)*SH*
     &         (UH*A(SP,GR+1)+B(SP,GR+1)*ML*MN)/(UH-MSU(GU+1))
            ENDIF
C--u channel L/R mixing
            IF(ABS(MXU(GU+1)).GT.EPS) ME2 = ME2+MXU(GU+1)**2*(MLS-UH)*
     &             (MNS-UH)*(C(1,SP,GU+1)**2+D(1,SP,GU+1)**2)
     &             /(UH-MSU(GU+1))**2
     &          +2*MXU(GU)*MXU(GU+1)*(MLS-UH)*(MNS-UH)*
     &             (C(1,SP,GU)*C(1,SP,GU+1)+D(1,SP,GU)*D(1,SP,GU+1))
     &             /(UH-MSU(GU))/(UH-MSU(GU+1))
     &          -2*MXS(GR)*MXU(GU+1)*(SH-MSL2(GR))*SCF(GR)*SH*
     &             C(1,SP,GU+1)*(UH*A(SP,GR)+B(SP,GR)*ML*MN)
     &             /(UH-MSU(GU+1))
            MEC(L,GN,J,K) = FAC*ME2*G**2*LAMDA2(I,J,K)**2*PCM*HALF
 210        I2 = I1+6
            P = L+4
            HCS = HCS+MEC(L,GN,J,K)*DISF(J1,1)*DISF(K1,2)
            IF(GN.GT.3) P = P+2
            IF(GENEV.AND.HCS.GT.RCS) CALL HWHRSS(11,J1,K1,I2,P,0,0,*500)
            HCS = HCS+MEC(L,GN,J,K)*DISF(K1,1)*DISF(J1,2)
            IF(GENEV.AND.HCS.GT.RCS) CALL HWHRSS(12,K1,J1,I2,P,0,0,*500)
            HCS = HCS+MEC(L,GN,J,K)*DISF(J1+6,1)*DISF(K1-6,2)
            IF(GENEV.AND.HCS.GT.RCS) CALL HWHRSS(11,J1,K1,I2,P,1,0,*500)
            HCS = HCS+MEC(L,GN,J,K)*DISF(K1-6,1)*DISF(J1+6,2)
            IF(GENEV.AND.HCS.GT.RCS) CALL HWHRSS(12,K1,J1,I2,P,1,0,*500)
 220      CONTINUE
        ENDDO
 230  CONTINUE
 240  CONTINUE
 300   IF(.NOT.RAD) GOTO 400
C--Radiative decays
       IF(GENEV) GOTO 320
       DO 310 GN=1,3
       I1= 2*GN+5
       I = 2*GN-1
C--charged slepton to sneutrino W
       IF(SQSH.GT.(MW+MSL(I1))) THEN
       PCM = SQRT((SH-(MW+MSL(I1))**2)*(SH-(MW-MSL(I1))**2))*HALF/SQSH
       ECM = SQRT(PCM**2+MW2)
       TH = MW2-SQSH*(ECM-PCM*COSTH)
       UH = MW2-SQSH*(ECM+PCM*COSTH)
       ME2 = MXS(I)**4*SCF(I)*SH**2*PCM**2
     &       +HALF**2/TH**2*(TWO*MW2*(UH*TH-MSL2(I1)*MW2)+TH**2*SH)
     &       -HALF*MXS(I)*SH*(SH-MSL2(I))*SCF(I)/TH*
     &         (MW2*(TWO*MSL2(I1)-TH)+(SH-MSL2(I1))*TH)
       IF(GN.EQ.3) ME2 = ME2+MXS(I+1)**4*SCF(I+1)*SH**2*PCM**2
     &         +2*MXS(I)**2*MXS(I+1)**2*SCF(I)*SCF(I+1)*SH**2*PCM**2
     &         *((SH-MSL2(I))*(SH-MSL2(I+1))+MSWD(I)*MSWD(I+1))
     &         +HALF*MXS(I+1)*SH*(SH-MSL2(I+1))*SCF(I+1)/TH*
     &         (MW2*(TWO*MSL2(I1)-TH)+(SH-MSL2(I))*TH)
       MER(GN) = ME2*PCM/MW2
       ENDIF
C--sneutrino to charged slepton W
       IF(SQSH.GT.(MW+MSL(I))) THEN
       PCM = SQRT((SH-(MW+MSL(I))**2)*(SH-(MW-MSL(I))**2))*HALF/SQSH
       ECM = SQRT(PCM**2+MW2)
       TH = MW2-SQSH*(ECM-PCM*COSTH)
       UH = MW2-SQSH*(ECM+PCM*COSTH)
       ME2 = MXS(I)**2*SCF(I1)*SH**2*PCM**2
     &       +HALF**2*MXS(I)**2/TH**2*
     &                      (TWO*MW2*(UH*TH-MW2*MSL2(I))+TH**2*SH)
     &       -HALF*MXS(I)**2*SH*(SH-MSL2(I1))*SCF(I1)/TH*
     &        (MW2*(TWO*MSL2(I)-TH)+(SH-MSL2(I))*TH)
       MER(GN+4) = ME2*PCM/MW2
       ENDIF
 310   CONTINUE
C--now the decay stau_2 to stau_1 Z
       IF(SQSH.GT.(MZ+MSL(5))) THEN
       PCM = SQRT((SH-(MZ+MSL(5))**2)*(SH-(MZ-MSL(5))**2))*HALF/SQSH
       ECM = SQRT(PCM**2+MZ2)
       TH = MZ2-SQSH*(ECM-PCM*COSTH)
       UH = MZ2-SQSH*(ECM+PCM*COSTH)
       ME2 = SH**2*PCM**2*(SCF(5)*MXS(5)**2*ZSLP(1)**2
     &              +SCF(6)*MXS(6)**2*ZSLP(2)**2+TWO*SCF(5)*SCF(6)*
     &              MXS(5)*MXS(6)*ZSLP(1)*ZSLP(2)*((SH-MSL2(5))*
     &              (SH-MSL2(6))+MSWD(5)*MSWD(6)))
     &      +MXS(5)**2*ZQRK(2)**2/TH**2*
     &              (TWO*MZ2*(UH*TH-MZ2*MSL2(5))+TH**2*SH)
     &      -MXS(5)**2*ZQRK(1)**2/UH**2*
     &              (TWO*MZ2*(UH*TH-MZ2*MSL2(5))+UH**2*SH)
     &      +MXS(5)*SH*(MXS(5)*SCF(5)*ZSLP(1)*(SH-MSL2(5))
     &              +MXS(6)*SCF(6)*ZSLP(2)*(SH-MSL2(6)))*
     &              ( ZQRK(2)/TH*(MZ2*(TWO*MSL2(5)-TH)+TH*(SH-MSL2(5)))
     &               +ZQRK(1)/UH*(MZ2*(TWO*MSL2(5)-UH)+UH*(SH-MSL2(5))))
     &      +TWO*MXS(5)**2*ZQRK(1)*ZQRK(2)/UH/TH*
     &               (TWO*MZ2*(MSL2(5)-UH)*(MSL2(5)-TH)-SH*UH*TH)
       MER(4) = TWO*ME2*PCM/MZ2
       ENDIF
C--now the decay tau sneutrino to tau_2 W
       IF(SQSH.GT.(MW+MSL(6))) THEN
       PCM = SQRT((SH-(MW+MSL(6))**2)*(SH-(MW-MSL(6))**2))*HALF/SQSH
       ECM = SQRT(PCM**2+MW2)
       TH = MW2-SQSH*(ECM-PCM*COSTH)
       UH = MW2-SQSH*(ECM+PCM*COSTH)
       ME2 = MXS(6)**2*SCF(11)*SH**2*PCM**2
     &       +HALF**2*MXS(6)**2/TH**2*
     &                      (TWO*MW2*(UH*TH-MW2*MSL2(6))+TH**2*SH)
     &       -HALF*MXS(6)**2*SH*(SH-MSL2(11))*SCF(11)/TH*
     &        (MW2*(2*MSL2(6)-TH)+(SH-MSL2(6))*TH)
       MER(8) = ME2*PCM/MW2
       ENDIF
C--Multiply by the parton distributions
 320   DO I=1,4
        DO J=1,3
         DO 330 K=1,3
         IF(I.LE.3) THEN
           LC = LAMDA2(I,J,K)**2
         ELSE
           LC = LAMDA2(3,J,K)**2
         ENDIF
         IF(LC.LT.EPS) GOTO 330
         FAC2 = G**2*LC*FAC
C--radiative cross-sections
         J1=2*J
         K1=2*K+5
         ME2 = FAC2*MER(I)
         HCS = HCS+ME2*DISF(J1,1)*DISF(K1,2)
         IF(GENEV.AND.HCS.GT.RCS) CALL HWHRSS(13,J1,K1,I,I,0,0,*500)
         HCS = HCS+ME2*DISF(K1,1)*DISF(J1,2)
         IF(GENEV.AND.HCS.GT.RCS) CALL HWHRSS(14,K1,J1,I,I,0,0,*500)
         HCS = HCS+ME2*DISF(J1+6,1)*DISF(K1-6,2)
         IF(GENEV.AND.HCS.GT.RCS) CALL HWHRSS(13,J1,K1,I,I,1,0,*500)
         HCS = HCS+ME2*DISF(K1-6,1)*DISF(J1+6,2)
         IF(GENEV.AND.HCS.GT.RCS) CALL HWHRSS(14,K1,J1,I,I,1,0,*500)
         J1=2*J-1
         K1=2*K+5
         ME2 = FAC2*MER(I+4)
         HCS = HCS+ME2*DISF(J1,1)*DISF(K1,2)
         IF(GENEV.AND.HCS.GT.RCS) CALL HWHRSS(13,J1,K1,I+4,I+4,0,0,*500)
         HCS = HCS+ME2*DISF(K1,1)*DISF(J1,2)
         IF(GENEV.AND.HCS.GT.RCS) CALL HWHRSS(14,K1,J1,I+4,I+4,0,0,*500)
         HCS = HCS+ME2*DISF(J1+6,1)*DISF(K1-6,2)
         IF(GENEV.AND.HCS.GT.RCS) CALL HWHRSS(13,J1,K1,I+4,I+4,1,0,*500)
         HCS = HCS+ME2*DISF(K1-6,1)*DISF(J1+6,2)
         IF(GENEV.AND.HCS.GT.RCS) CALL HWHRSS(14,K1,J1,I+4,I+4,1,0,*500)
 330     CONTINUE
        ENDDO
       ENDDO
 400   IF(.NOT.HIGGS) GOTO 500
       IF(GENEV) GOTO 480
       DO I=1,3
          DO 405 J=1,18
 405      MEH(I,J) = ZERO
       ENDDO
C--Neutral higgs charged slepton
       DO 420 L=1,3
         DO 410 I=1,2
C--first two generations
           IF(SQSH.LT.MH(L)+MSL(2*I)) GOTO 410
           PCM = SQRT((SH-(MSL(2*I)+MH(L))**2)*
     &                (SH-(MSL(2*I)-MH(L))**2))*HALF/SQSH
           MEH(1,3*L-3+I) = PCM*SH*SCF(2*I-1)*H(4*L+I-4)**2
 410     CONTINUE
C--third generation
         IF(SQSH.LT.MH(L)+MSL(5)) GOTO 420
         PCM = SQRT((SH-(MSL(5)+MH(L))**2)*
     &              (SH-(MSL(5)-MH(L))**2))*HALF/SQSH
         ECM = SQRT(PCM**2+MH(L)**2)
         TH = MH(L)**2-SQSH*(ECM-PCM*COSTH)
         UH = MH(L)**2-SQSH*(ECM+PCM*COSTH)
         MEH(1,3*L) = PCM*SH*(MXS(5)**2*SCF(5)*H(4*L-1)**2
     &                 +MXS(6)**2*SCF(6)*H(4*L)**2
     &                 +TWO*MXS(5)*MXS(6)*SCF(5)*SCF(6)*H(4*L-1)*
     &                 H(4*L)*((SH-MSL2(5))*(SH-MSL2(6))+
     &                 MSWD(5)*MSWD(6)) )
         ME2        = MXS(5)**2*PCM*(UH*TH-MSL2(5)*MH(L)**2)
         MEH(2,3*L) =ME2*GUU(L)/TH**2
         MEH(3,3*L) =ME2*GDD(L)/UH**2
 420     CONTINUE
C--Charged higgs
        DO 440 I=1,3
C--charged slepton charged Higgs
          DO 430 J=1,2
          IF(SQSH.LT.(MH(4)+MSL(2*I-2+J))) GOTO 430
          PCM = SQRT((SH-(MH(4)+MSL(2*I-2+J))**2)*
     &               (SH-(MH(4)-MSL(2*I-2+J))**2))*HALF/SQSH
          ECM = SQRT(PCM**2+MH(4)**2)
          TH = MH(4)**2-SQSH*(ECM-PCM*COSTH)
          UH = MH(4)**2-SQSH*(ECM+PCM*COSTH)
          MEH(1,2*I+J+7) = PCM*SH*HALF/MW2*H(2*I+J+10)**2*SCF(5+2*I)
          MEH(2,2*I+J+7) = PCM*GDD(4)*MXS(2*I-2+J)**2*
     &                      (UH*TH-MH(4)**2*MSL2(2*I-2+J))/TH**2
 430      CONTINUE
C--Sneutrino Charged Higgs
          IF(SQSH.LT.(MH(4)+MSL(2*I+5))) GOTO 440
          PCM = SQRT((SH-(MH(4)+MSL(2*I+5))**2)*
     &               (SH-(MH(4)-MSL(2*I+5))**2))*HALF/SQSH
          ECM = SQRT(PCM**2+MH(4)**2)
          TH = MH(4)**2-SQSH*(ECM-PCM*COSTH)
          UH = MH(4)**2-SQSH*(ECM+PCM*COSTH)
          MEH(1,15+I) = PCM*SH*HALF/MW2*(
     &                MXS(2*I-1)**2*SCF(2*I-1)*H(11+2*I)**2
     &               +MXS(2*I)**2*SCF(2*I)*H(12+2*I)**2
     &               +TWO*MXS(2*I-1)*MXS(2*I)*SCF(2*I-1)*
     &                SCF(2*I)*H(11+2*I)*H(12+2*I)*
     &             ((SH-MSL2(2*I-1))*(SH-MSL2(2*I))+
     &              MSWD(2*I-1)*MSWD(2*I)))
          MEH(2,15+I) = PCM*GUU(4)*
     &                    (UH*TH-MH(4)**2*MSL2(2*I+5))/TH**2
 440    CONTINUE
C--Multiply by the parton distributions
 480    DO I=1,3
        DO J=1,3
         DO 490 K=1,3
         IF(LAMDA2(I,J,K).LT.EPS) GOTO 490
C--Higgs cross-sections
         J1=2*J
         K1=2*K+5
         FAC2 = G**2*LAMDA2(I,J,K)**2*FAC*HALF
         DO L=1,3
         ME2 = FAC2*(MEH(1,3*L-3+I)+RMASS(J1)**2*MEH(2,3*L-3+I)
     &            +RMASS(K1)**2*MEH(3,3*L-3+I))
         HCS = HCS+ME2*DISF(J1,1)*DISF(K1,2)
         IF(GENEV.AND.HCS.GT.RCS) CALL HWHRSS(15,J1,K1,I,L,0,0,*500)
         HCS = HCS+ME2*DISF(K1,1)*DISF(J1,2)
         IF(GENEV.AND.HCS.GT.RCS) CALL HWHRSS(16,K1,J1,I,L,0,0,*500)
         HCS = HCS+ME2*DISF(J1+6,1)*DISF(K1-6,2)
         IF(GENEV.AND.HCS.GT.RCS) CALL HWHRSS(15,J1,K1,I,L,1,0,*500)
         HCS = HCS+ME2*DISF(K1-6,1)*DISF(J1+6,2)
         IF(GENEV.AND.HCS.GT.RCS) CALL HWHRSS(16,K1,J1,I,L,1,0,*500)
         ENDDO
         ME2 = FAC2*(MEH(1,15+I)+RMASS(J1)**2*MEH(2,15+I))
         HCS = HCS+ME2*DISF(J1,1)*DISF(K1,2)
         IF(GENEV.AND.HCS.GT.RCS) CALL HWHRSS(15,J1,K1,9+I,4,0,0,*500)
         HCS = HCS+ME2*DISF(K1,1)*DISF(J1,2)
         IF(GENEV.AND.HCS.GT.RCS) CALL HWHRSS(16,K1,J1,9+I,4,0,0,*500)
         HCS = HCS+ME2*DISF(J1+6,1)*DISF(K1-6,2)
         IF(GENEV.AND.HCS.GT.RCS) CALL HWHRSS(15,J1,K1,9+I,5,1,0,*500)
         HCS = HCS+ME2*DISF(K1-6,1)*DISF(J1+6,2)
         IF(GENEV.AND.HCS.GT.RCS) CALL HWHRSS(16,K1,J1,9+I,5,1,0,*500)
         J1=2*J-1
         K1=2*K+5
         DO L=2,3
         ME2 = FAC2*(MEH(1,2*I+L+6)+RMASS(J1)**2*MEH(2,2*I+L+6))
         HCS = HCS+ME2*DISF(J1,1)*DISF(K1,2)
         IF(GENEV.AND.HCS.GT.RCS) CALL HWHRSS(15,J1,K1,2*I+L,5,0,0,*500)
         HCS = HCS+ME2*DISF(K1,1)*DISF(J1,2)
         IF(GENEV.AND.HCS.GT.RCS) CALL HWHRSS(16,K1,J1,2*I+L,5,0,0,*500)
         HCS = HCS+ME2*DISF(J1+6,1)*DISF(K1-6,2)
         IF(GENEV.AND.HCS.GT.RCS) CALL HWHRSS(15,J1,K1,2*I+L,4,1,0,*500)
         HCS = HCS+ME2*DISF(K1-6,1)*DISF(J1+6,2)
         IF(GENEV.AND.HCS.GT.RCS) CALL HWHRSS(16,K1,J1,2*I+L,4,1,0,*500)
         ENDDO
 490     CONTINUE
        ENDDO
       ENDDO
C--Setup to generate the event
 500  IF(GENEV) THEN
        CALL HWETWO
      ELSE
        EVWGT = HCS
      ENDIF
 999  END
CDECK  ID>, HWHRSP.
*CMZ :-        -20/07/99  10:56:12  by  Peter Richardson
*-- Author :    Peter Richardson
C-----------------------------------------------------------------------
      SUBROUTINE HWHRSP
C-----------------------------------------------------------------------
C     Subroutine for all hadron-hadron Rparity violating processes
C-----------------------------------------------------------------------
      INCLUDE 'HERWIG62.INC'
      IF(IPROC.GE.4000.AND.IPROC.LT.4060) THEN
C--SINGLE SPARTICLE VIA LQD
        CALL HWHRLS
      ELSEIF(IPROC.GE.4060.AND.IPROC.LT.4100) THEN
C--RESONANT SLEPTONS TO STANDARD MODEL VIA LQD
        CALL HWHRLL
      ELSEIF(IPROC.GE.4100.AND.IPROC.LT.4160) THEN
C--SINGLE SPARTICLE VIA UDD
        CALL HWHRBS
C--RESONANT SQUARKS TO STANDARD MODEL VIA UDD
      ELSEIF(IPROC.EQ.4160) THEN
        CALL HWHRBB
      ELSE
C--UNKNOWN PROCESS
        CALL HWWARN('HWHRSP',500,*999)
      ENDIF
 999  END
CDECK  ID>, HWHRSS.
*CMZ :-        -20/07/99  10:56:12  by  Peter Richardson
*-- Author :    Peter Richardson
C-----------------------------------------------------------------------
      SUBROUTINE HWHRSS(TYPE,ID1,ID2,ID3,ID4,R4,IPERM,*)
C-----------------------------------------------------------------------
C     IDENTIDY HARD R-PARITY VIOLATING PROCESS
C-----------------------------------------------------------------------
      INCLUDE 'HERWIG62.INC'
      INTEGER ID3, ID4, R4, IPERM,TYPE,ID1,ID2,NEUTD1(8),SLEPID(8),
     &        NEUTD2(13),SQUID(6),SGN,HWUANT,SQUID2(12),SLPID2(12),
     &        GAGID1(6),GAGID2(8)
      EXTERNAL HWUANT
      DATA NEUTD1 /450,451,452,453,454,455,456,457/
      DATA NEUTD2 /449,449,449,450,451,452,453,454,455,456,457,454,455/
      DATA SLEPID /432,434,436,435,431,433,435,447/
      DATA SQUID  /411,423,412,412,424,411/
      DATA SQUID2 /407,419,409,421,411,423,408,420,410,422,412,424/
      DATA SLPID2 /443,445,435,431,443,433,445,435,447,432,434,436/
      DATA GAGID1 /199,199,200,198,198,200/
      DATA GAGID2 /198,198,198,200,199,199,199,199/
      IDCMF = 15
      IF(IPERM.EQ.0) THEN
        ICO(1) = 2
        ICO(2) = 1
        ICO(3) = 3
        ICO(4) = 4
      ELSEIF(IPERM.EQ.1) THEN
        ICO(1) = 2
        ICO(2) = 1
        ICO(3) = 4
        ICO(4) = 3
      ELSEIF(IPERM.EQ.2) THEN
        ICO(1) = 3
        ICO(2) = 4
        ICO(3) = 1
        ICO(4) = 2
      ELSE
        CALL HWWARN('HWHRSS',100,*999)
      ENDIF
      IF(TYPE.LE.8) THEN
        IDN(1) = ID1+R4*6
        IDN(2) = ID2+R4*6
      ELSE
        SGN = 1
        IF(MOD(TYPE,2).EQ.0) SGN = -1
        IDN(1) = ID1+R4*6*SGN
        IDN(2) = ID2-R4*6*SGN
      ENDIF
      IF(TYPE.LE.2) THEN
        IDN(3) = ID3+6*R4
        IDN(4) = ID4+6*R4
      ELSEIF(TYPE.GE.3.AND.TYPE.LE.4) THEN
        IDN(3) = ID3-R4*6
        IDN(4) = NEUTD2(ID4)
      ELSEIF(TYPE.GE.5.AND.TYPE.LE.6) THEN
        IDN(3) = GAGID1(ID3)
        IDN(4) = SQUID(ID4)-R4*6
        IF(R4.EQ.1) IDN(3) = HWUANT(IDN(3))
      ELSEIF(TYPE.GE.7.AND.TYPE.LE.8) THEN
        IDN(3) =202+ID3
        IDN(4) =  SQUID2(ID4)-R4*6
      ELSEIF(TYPE.GE.9.AND.TYPE.LE.10) THEN
        IDN(3) = ID3+6*R4
        IDN(4) = ID4-6*R4
        IF(IPERM.EQ.2.AND.TYPE.EQ.10) THEN
          SGN=IDN(3)
          IDN(3) = IDN(4)
          IDN(4) = SGN
        ENDIF
      ELSEIF(TYPE.GE.11.AND.TYPE.LE.12) THEN
        IDN(3) = 120+ID3-R4*6
        IDN(4) = NEUTD1(ID4)
        IF(R4.EQ.1) IDN(4) = HWUANT(IDN(4))
      ELSEIF(TYPE.GE.13.AND.TYPE.LE.14) THEN
        IDN(3) = SLEPID(ID3)-R4*6
        IDN(4) = GAGID2(ID4)
        IF(R4.NE.0) IDN(4) = HWUANT(IDN(4))
      ELSEIF(TYPE.GE.15.AND.TYPE.LE.16) THEN
        IDN(3) = SLPID2(ID3)-R4*6
        IDN(4) = 202+ID4
      ENDIF
      IF(MOD(TYPE,2).EQ.0.AND.TYPE.NE.8) COSTH=-COSTH
      RETURN 1
 999  END
CDECK  ID>, HWHSCT.
*CMZ :-        -30/05/94  18.42.43  by  Mike Seymour
*-- Author :    Mike Seymour
C-----------------------------------------------------------------------
      SUBROUTINE HWHSCT(REPORT)
C-----------------------------------------------------------------------
C     RELABEL THE EVENT RECORD FOR EXTRA HARD SCATTERING,
C     DO THE SCATTERING, PARTON SHOWER IT, AND CLEAN UP THE EVENT RECORD
C     REPORT RETURNS THE OUTCOME:
C     0 = SUCCESSFUL
C     1 = FAILED DUE TO ERROR IN HARD SCATTERING GENERATION
C     2 = FAILED DUE TO ENERGY CONSERVATION IN HARD SCATTERING
C     3 = FAILED DUE TO ERROR IN PARTON EVOLUTION
C     4 = FAILED DUE TO ENERGY CONSERVATION IN PARTON EVOLUTION
C     5 = COMPLETELY FAILED (IERROR IS ALSO NON-ZERO TO CANCEL EVENT)
C-----------------------------------------------------------------------
      INCLUDE 'HERWIG62.INC'
      DOUBLE PRECISION HWRGEN,TMPWGT,PBOOST(5),RBOOST(3,3)
      INTEGER IHEP,IBM,ITG,IBMN,ITGN,IBMT,ITGT,I,REPORT
      LOGICAL COL
      EXTERNAL HWRGEN
      COL(I)=I.EQ.13 .OR. I.GE.1.AND.I.LE.6 .OR. I.GE.115.AND.I.LE.120
      REPORT=5
      IF (IERROR.NE.0) RETURN
C---FIND BEAM AND TARGET REMNANTS
      CALL HWHREM(IBM,ITG)
      IF (IERROR.NE.0) RETURN
C---RECALCULATE THEIR MASS CORRECTLY
      CALL HWUMAS(PHEP(1,IBM))
      CALL HWUMAS(PHEP(1,ITG))
C---SET UP NEW ENTRIES IN THE EVENT RECORD
      NHEP=NHEP+1
      CALL HWVEQU(5,PHEP(1,IBM),PHEP(1,NHEP))
      ISTHEP(NHEP)=3
      IBMN=NHEP
      IBMT=JDAHEP(1,1)
      IF (IBMT.EQ.0) THEN
        JMOHEP(1,NHEP)=1
        IDHW(NHEP)=72
      ELSE
        JMOHEP(1,NHEP)=IBMT
        IDHW(NHEP)=71
      ENDIF
      JMOHEP(2,NHEP)=0
      JDAHEP(1,NHEP)=0
      JDAHEP(2,NHEP)=0
      IDHEP(NHEP)=IDPDG(IDHW(NHEP))
      NHEP=NHEP+1
      CALL HWVEQU(5,PHEP(1,ITG),PHEP(1,NHEP))
      ISTHEP(NHEP)=3
      ITGN=NHEP
      ITGT=JDAHEP(1,2)
      IF (ITGT.EQ.0) THEN
        JMOHEP(1,NHEP)=2
        IDHW(NHEP)=72
      ELSE
        JMOHEP(1,NHEP)=ITGT
        IDHW(NHEP)=71
      ENDIF
      JMOHEP(2,NHEP)=0
      JDAHEP(1,NHEP)=0
      JDAHEP(2,NHEP)=0
      IDHEP(NHEP)=IDPDG(IDHW(NHEP))
C---BOOST TO THEIR CENTRE-OF-MASS FRAME
      CALL HWVSUM(4,PHEP(1,IBMN),PHEP(1,ITGN),PBOOST)
      CALL HWUMAS(PBOOST)
      DO 100 IHEP=IBMN,NHEP
        CALL HWULOF(PBOOST,PHEP(1,IHEP),PHEP(1,IHEP))
 100  CONTINUE
      CALL HWUROT(PHEP(1,IBMN),ONE,ZERO,RBOOST)
      DO 110 IHEP=IBMN,NHEP
        CALL HWUROF(RBOOST,PHEP(1,IHEP),PHEP(1,IHEP))
 110  CONTINUE
C---GENERATE A NEW HARD SCATTERING
      TMPWGT=EVWGT
      GENEV=.FALSE.
 10   CALL HWHQCD
      IF (IERROR.NE.0.OR.GAMWT*EVWGT.LE.WGTMAX*HWRGEN(0)) THEN
        IERROR=0
        GOTO 10
      ENDIF
      GENEV=.TRUE.
      CALL HWHQCD
      EVWGT=TMPWGT
C---IF MOMENTUM CANNOT BE CONSERVED, STOP GENERATING HARD SCATTERS
      IF (  PHEP(4,IBMN+2) .GT. PHEP(4,IBMN).OR.
     $      PHEP(4,ITGN+2) .GT. PHEP(4,ITGN).OR.
     $      PHEP(3,IBMN+2) .GT. PHEP(3,IBMN).OR.
     $     -PHEP(3,ITGN+2) .GT.-PHEP(3,ITGN).OR.IERROR.NE.0) THEN
        IF (IERROR.GT.0) THEN
          WRITE (6,'(A/A)')
     $       ' THIS ERROR OCCURED DURING A SECONDARY SCATTER AND WAS',
     $       ' CAUGHT BY HWHSCT, SO EVENT IS NOT KILLED AFTER ALL'
          REPORT=1
        ELSE
          REPORT=2
        ENDIF
        NHEP=IBMN-1
        IERROR=0
        RETURN
      ENDIF
C---RELABEL OUTGOING REMNANTS AS INCOMING HADRONS
      JDAHEP(1,1)=IBMN
      JDAHEP(1,2)=ITGN
C---EVOLVE THEM
      ISLENT=-1
      CALL HWBGEN
      ISLENT=1
C---PUT THE LABELS BACK
      JDAHEP(1,1)=IBMT
      JDAHEP(1,2)=ITGT
C---IF THERE WERE ANY PROBLEMS, STOP GENERATING HARD SCATTERS
      IF (IERROR.NE.0) THEN
        IF (IERROR.GT.0) THEN
          WRITE (6,'(A/A)')
     $       ' THIS ERROR OCCURED DURING A SECONDARY SCATTER AND WAS',
     $       ' CAUGHT BY HWHSCT, SO EVENT IS NOT KILLED AFTER ALL'
          REPORT=3
        ELSE
          REPORT=4
        ENDIF
        NHEP=IBMN-1
        IERROR=0
        RETURN
      ENDIF
C---UNDO THE LORENTZ BOOST
      DO 200 IHEP=IBMN,NHEP
        CALL HWUROB(RBOOST,PHEP(1,IHEP),PHEP(1,IHEP))
        CALL HWULOB(PBOOST,PHEP(1,IHEP),PHEP(1,IHEP))
 200  CONTINUE
C---FIND THE NEW BEAM AND TARGET REMNANTS
      ISTHEP(IBM)=3
      ISTHEP(ITG)=3
      CALL HWHREM(IBMN,ITGN)
      IF (IERROR.NE.0) RETURN
C---CONNECT UP THE COLOUR/FLAVOUR LINES OF THE TWO SCATTERS
      IDHW(IBMN)=IDHW(IBM)
      IDHEP(IBMN)=IDHEP(IBM)
      IF (COL(IDHW(IBM))) THEN
        JMOHEP(2,JDAHEP(2,IBMN))=JMOHEP(2,IBM)
        JDAHEP(2,JMOHEP(2,IBM))=JDAHEP(2,IBMN)
        JDAHEP(2,IBMN)=JDAHEP(2,IBM)
        JMOHEP(2,JDAHEP(2,IBM))=IBMN
      ELSE
        JDAHEP(2,JMOHEP(2,IBMN))=JDAHEP(2,IBM)
        JMOHEP(2,JDAHEP(2,IBM))=JMOHEP(2,IBMN)
        JMOHEP(2,IBMN)=JMOHEP(2,IBM)
        JDAHEP(2,JMOHEP(2,IBM))=IBMN
      ENDIF
      JMOHEP(2,IBM)=0
      JDAHEP(1,IBM)=IBMN
      JDAHEP(2,IBM)=0
      IDHW(ITGN)=IDHW(ITG)
      IDHEP(ITGN)=IDHEP(ITG)
      IF (COL(IDHW(ITG))) THEN
        JMOHEP(2,JDAHEP(2,ITGN))=JMOHEP(2,ITG)
        JDAHEP(2,JMOHEP(2,ITG))=JDAHEP(2,ITGN)
        JDAHEP(2,ITGN)=JDAHEP(2,ITG)
        JMOHEP(2,JDAHEP(2,ITG))=ITGN
      ELSE
        JDAHEP(2,JMOHEP(2,ITGN))=JDAHEP(2,ITG)
        JMOHEP(2,JDAHEP(2,ITG))=JMOHEP(2,ITGN)
        JMOHEP(2,ITGN)=JMOHEP(2,ITG)
        JDAHEP(2,JMOHEP(2,ITG))=ITGN
      ENDIF
      JMOHEP(2,ITG)=0
      JDAHEP(1,ITG)=ITGN
      JDAHEP(2,ITG)=0
C---LOOK FOR COLOUR SINGLET GLUONS (A RARE BUT ANNOYING SPECIAL CASE)
      DO 20 IHEP=1,NHEP
        IF (IDHW(IHEP).EQ.13.AND.JMOHEP(2,IHEP).EQ.IHEP)
     $       CALL HWWARN('HWHSCT',120,*999)
 20   CONTINUE
      REPORT=0
 999  END
CDECK  ID>, HWHSNG.
*CMZ :-        -20/09/95  14.59.15  by  Mike Seymour
*-- Author :    Mike Seymour
C-----------------------------------------------------------------------
      SUBROUTINE HWHSNG
C     PARTON-PARTON SCATTERING VIA COLOUR SINGLET
C     MEAN EVWGT = SIGMA IN NB
C     TREATS ALL PARTONS ON EQUAL FOOTING WITH HWHSNM(ID1,ID2,S,T)
C     PROVIDING THE MATRIX ELEMENT SQUARED FOR PARTON TYPES ID1 AND ID2
C-----------------------------------------------------------------------
      INCLUDE 'HERWIG62.INC'
      INTEGER ID1,ID2
      DOUBLE PRECISION HWRGEN,HWRUNI,HWHSNM,EPS,RCS,ET,EJ,KK,KK2,
     & YJ1INF,YJ1SUP,Z1,YJ2INF,YJ2SUP,Z2,FACT,S,T,U,HCS
      SAVE HCS,FACT,S,T
      PARAMETER (EPS=1.D-9)
      IF (GENEV) THEN
        RCS=HCS*HWRGEN(0)
      ELSE
        EVWGT=0.
        CALL HWRPOW(ET,EJ)
        KK=ET/PHEP(5,3)
        KK2=KK**2
        IF (KK.GE.ONE) RETURN
        YJ1INF=MAX( YJMIN , LOG((1.-SQRT(1.-KK2))/KK) )
        YJ1SUP=MIN( YJMAX , LOG((1.+SQRT(1.-KK2))/KK) )
        IF (YJ1INF.GE.YJ1SUP) RETURN
        Z1=EXP(HWRUNI(1,YJ1INF,YJ1SUP))
        YJ2INF=MAX( YJMIN , -LOG(2./KK-1./Z1) )
        YJ2SUP=MIN( YJMAX ,  LOG(2./KK-Z1) )
        IF (YJ2INF.GE.YJ2SUP) RETURN
        Z2=EXP(HWRUNI(2,YJ2INF,YJ2SUP))
        XX(1)=0.5*(Z1+Z2)*KK
        IF (XX(1).GE.ONE) RETURN
        XX(2)=XX(1)/(Z1*Z2)
        IF (XX(2).GE.ONE) RETURN
        COSTH=(Z1-Z2)/(Z1+Z2)
        S=XX(1)*XX(2)*PHEP(5,3)**2
        T=-0.5*S*(1.-COSTH)
        U=-S-T
C---SET EMSCA TO HARD PROCESS SCALE (APPROX ET-JET)
        EMSCA=SQRT(2.*S*T*U/(S*S+T*T+U*U))
        FACT=GEV2NB*0.5*ET*EJ*(YJ1SUP-YJ1INF)*(YJ2SUP-YJ2INF)
     $      /(16*PIFAC*S**2)
        CALL HWSGEN(.FALSE.)
      ENDIF
C
      HCS=0.
      DO 20 ID1=1,13
        IF (DISF(ID1,1).LT.EPS) GOTO 20
        DO 10 ID2=1,13
          IF (DISF(ID2,1).LT.EPS) GOTO 10
          HCS=HCS+FACT*DISF(ID1,1)*DISF(ID2,2)*HWHSNM(ID1,ID2,S,T)
          IF (GENEV.AND.HCS.GT.RCS) CALL HWHQCP(ID1,ID2,3412,90,*30)
 10     CONTINUE
 20   CONTINUE
      EVWGT=HCS
      RETURN
C---GENERATE EVENT
 30   IDN(1)=ID1
      IDN(2)=ID2
      IDCMF=15
      CALL HWETWO
 999  END
CDECK  ID>, HWHSNM.
*CMZ :-        -20/09/95  15.28.53  by  Mike Seymour
*-- Author :    Mike Seymour
C-----------------------------------------------------------------------
      FUNCTION HWHSNM(ID1,ID2,S,T)
C     MATRIX ELEMENT SQUARED FOR COLOUR-SINGLET PARTON-PARTON SCATTERING
C     INCLUDES SPIN AND COLOUR AVERAGES AND SUMS.
C     FOR PHOTON EXCHANGE, INTERFERENCE WITH U-CHANNEL CONTRIBUTION IS
C     INCLUDED FOR IDENTICAL QUARKS AND LIKEWISE S-CHANNEL CONTRIBUTION
C     FOR IDENTICAL QUARK-ANTIQUARK PAIRS.
C-----------------------------------------------------------------------
      INCLUDE 'HERWIG62.INC'
      DOUBLE PRECISION HWHSNM,HWUAEM,HWUALF,S,T,ASQ,AINU,AINS,Y,SOLD,
     $ TOLD,QQ(13,13),ZETA3
      INTEGER ID1,ID2
      LOGICAL PHOTON
C---ZETA3=RIEMANN ZETA FUNCTION(3)
      PARAMETER (ZETA3=1.202056903159594D0)
C---PHOTON=.TRUE. FOR PHOTON EXCHANGE, .FALSE. FOR MUELLER-TANG
      PHOTON=MOD(IPROC,100).GE.50
      DATA ASQ,AINU,AINS,SOLD,TOLD,QQ/5*0,169*-1/
C---QQ CACHES THE KINEMATIC-INDEPENDENT FACTORS, TO MAKE IT RUN FASTER
C  (BEARING IN MIND THAT THIS ROUTINE IS CALLED 169 TIMES PER EVENT)
      IF (QQ(ID1,ID2).LT.ZERO) THEN
        IF (PHOTON) THEN
          IF (ID1.EQ.13.OR.ID2.EQ.13) THEN
            QQ(ID1,ID2)=0
          ELSE
            QQ(ID1,ID2)=(QFCH(MOD(ID1-1,6)+1)*QFCH(MOD(ID2-1,6)+1))**2
     $           *(4*PIFAC)**2
          ENDIF
        ELSE
          IF (ID1.EQ.13.AND.ID2.EQ.13) THEN
            QQ(ID1,ID2)=CAFAC**4
          ELSEIF (ID1.EQ.13.OR.ID2.EQ.13) THEN
            QQ(ID1,ID2)=(CAFAC*CFFAC)**2
          ELSE
            QQ(ID1,ID2)=CFFAC**4
          ENDIF
          QQ(ID1,ID2)=QQ(ID1,ID2)*
     $         PIFAC**3/(4*(3.5*ASFIXD*CAFAC*ZETA3)**3)
     $         *(16*PIFAC)
        ENDIF
      ENDIF
C---THE KINEMATIC-DEPENDENT PART IS ALSO CACHED
      IF (S.NE.SOLD.OR.T.NE.TOLD) THEN
        IF (PHOTON) THEN
          AINS=HWUAEM(T)**2
          ASQ=2*(S**2+(S+T)**2)/T**2*AINS
          AINU=-4*S/T*AINS/NCOLO
          AINS=4*AINS/NCOLO-AINU
        ELSE
          Y=LOG(S/(-T))+ONE
          ASQ=HWUALF(1,EMSCA)**4*(S/T)**2*EXP(2*OMEGA0*Y)/Y**3
          AINU=0
          AINS=0
        ENDIF
      ENDIF
C---THE FINAL ANSWER IS JUST THEIR PRODUCT
      IF (ID1.EQ.ID2) THEN
        HWHSNM=QQ(ID1,ID2)*(ASQ+AINU)
      ELSEIF (ABS(ID1-ID2).EQ.6) THEN
        HWHSNM=QQ(ID1,ID2)*(ASQ+AINS)
      ELSE
        HWHSNM=QQ(ID1,ID2)*ASQ
      ENDIF
      END
CDECK  ID>, HWHSS1.
*CMZ :-        -18/05/99  20.33.45  by  Kosuke Odagiri
*-- Author :    Kosuke Odagiri
C-----------------------------------------------------------------------
      FUNCTION HWHSS1(S, T, U, M3, M4, SGN, CLL, CLR, CRL, CRR)
C-----------------------------------------------------------------------
C     QQ(BAR) -> GAUGINOS
C-----------------------------------------------------------------------
      IMPLICIT NONE
      DOUBLE PRECISION HWHSS1, S, T, U, M3, M4, SGN
      DOUBLE COMPLEX CLL, CLR, CRL, CRR
      HWHSS1 = DREAL(
     & (DCONJG(CLL)*CLL+DCONJG(CRR)*CRR)*(U-M3*M3)*(U-M4*M4)+
     & (DCONJG(CLR)*CLR+DCONJG(CRL)*CRL)*(T-M3*M3)*(T-M4*M4)+
     & (DCONJG(CLL)*CLR+DCONJG(CRL)*CRR)*2.*SGN*M3*M4*S )
      RETURN
      END
CDECK  ID>, HWHSSG.
*CMZ :-        -31/03/00  17:54:05  by  Peter Richardson
*-- Author :    Kosuke Odagiri
C-----------------------------------------------------------------------
      SUBROUTINE HWHSSG
C-----------------------------------------------------------------------
C     SUSY 2 PARTON -> 2 GAUGINOS PROCESSES        (1 - 3)
C                   -> GAUGINO + SPARTON PROCESSES (4 - 7)
C-----------------------------------------------------------------------
      INCLUDE 'HERWIG62.INC'
      DOUBLE PRECISION HWRGEN, HWUALF, HWUAEM, EPS, HCS, RCS, DIST,
     & ML(6), ML2(6), MR(6), MR2(6), MCH(2), MCH2(2), MNU(4), MNU2(4),
     & MSQK, MG, MG2, SM, DM, DAB, QPE, SGN, PF, SQPE, EMSC2,
     & FAC0, FACA, FACB, FACC, S, T, T3, U, U4, SN2TH
      DOUBLE PRECISION M1(2,2,6), M2(4,4,6), M3(2,4,6,6),
     & M4(4,6), M5(2,6,6), M6L(4,6), M6R(4,6), M7(2,2,6,6),
     & XA(4), XB(4), XC(4), XD(4), MZ, MW, XW, SQXW, S2W, S22W
      INTEGER I, IQ, IQ1, IQ2, IQ3, IQ4, IG1, IG2, IG3, IG4,
     & ID1, ID2, IGL, SSL, SSR, GLU, SSNU, SSCH, INU, ICH, IWD(6), IPB
      DOUBLE PRECISION DQD(6), DQU(6), HWHSS1
      EXTERNAL HWRGEN, HWUALF, HWUAEM, HWHSS1
      SAVE HCS, M1, M2, M3, M4, M5, M6L, M6R, M7
      PARAMETER (EPS = 1.D-9, IGL = 49, SSL = 400, SSR = 412, GLU = 449)
      PARAMETER (SSNU = 449, SSCH = 453, INU = 49, ICH = 53)
      DOUBLE COMPLEX Z, Z0, C1, C2, C3, GZ, GW, CLL, CLR, CRL, CRR
      PARAMETER (Z = (0.D0,1.D0), Z0 = (0.D0,0.D0))
      EQUIVALENCE (MZ, RMASS(200)), (MW, RMASS(198)), (MG, RMASS(GLU))
      EQUIVALENCE (XA(1), ZMIXSS(1,1)), (XA(2), ZMIXSS(2,1))
      EQUIVALENCE (XA(3), ZMIXSS(3,1)), (XA(4), ZMIXSS(4,1))
      EQUIVALENCE (XB(1), ZMIXSS(1,2)), (XB(2), ZMIXSS(2,2))
      EQUIVALENCE (XB(3), ZMIXSS(3,2)), (XB(4), ZMIXSS(4,2))
      EQUIVALENCE (XC(1), ZMIXSS(1,3)), (XC(2), ZMIXSS(2,3))
      EQUIVALENCE (XC(3), ZMIXSS(3,3)), (XC(4), ZMIXSS(4,3))
      EQUIVALENCE (XD(1), ZMIXSS(1,4)), (XD(2), ZMIXSS(2,4))
      EQUIVALENCE (XD(3), ZMIXSS(3,4)), (XD(4), ZMIXSS(4,4))
      DATA IWD/2,1,4,3,6,5/
      DATA DQD/ONE,ZERO,ONE,ZERO,ONE,ZERO/
      DATA DQU/ZERO,ONE,ZERO,ONE,ZERO,ONE/
C
      CALL    HWSGEN(.FALSE.)
      IF (GENEV) THEN
        RCS = HCS*HWRGEN(0)
      ELSE
        SN2TH = 0.25D0 - 0.25D0*COSTH**2
        S=XX(1)*XX(2)*PHEP(5,3)**2
        EMSC2 = EMSCA**2
        FAC0  = FACTSS*HWUAEM(EMSC2)
c       prefactor for pair production, includes 1/Nc colour factor
        FACA  = FAC0*HWUAEM(EMSC2) / CAFAC
c       prefactor for qq -> gaugino + gluino, includes CF/Nc colour factor
        FACB  = FAC0*HWUALF(1,EMSCA) * CFFAC / CAFAC
c       prefactor for qg -> gaugino + squark, includes 1/2Nc colour factor
        FACC  = FACB / CFFAC / TWO
        MG2   = MG**2
        GZ    = S-MZ**2+Z*S/MZ*GAMZ
        GW    = S-MW**2+Z*S/MW*GAMW
        DO IQ = 1,6
          IQ1     = SSL + IQ
          IQ2     = SSR + IQ
          ML(IQ)  = RMASS(IQ1)
          ML2(IQ) = ML(IQ)**2
          MR(IQ)  = RMASS(IQ2)
          MR2(IQ) = MR(IQ)**2
        END DO
        XW    =   TWO * SWEIN
        SQXW  =   SQRT(XW)
        S22W  =   XW * (TWO - XW)
        S2W   =   SQRT(S22W)
        DO IG1 = 1,4
          MNU(IG1)  = RMASS(IG1+SSNU)
          MNU2(IG1) = MNU(IG1)**2
        END DO
        DO IG1 = 1,2
          MCH(IG1)  = RMASS(IG1+SSCH)
          MCH2(IG1) = MCH(IG1)**2
        END DO
c       _     ~+ ~-
c (1) q q  -> X  X
c              a  b
        DO IG1 = 1,2
          DO IG2 = 1,2
            SM  = MCH(IG1) + MCH(IG2)
            QPE = S - SM**2
            IF (QPE.GE.ZERO) THEN
              DM   = MCH(IG1) - MCH(IG2)
              SQPE = SQRT(QPE*(S-DM**2))
              PF   = SQPE/S
              T    = (SQPE*COSTH - S + MCH2(IG1) + MCH2(IG2)) / TWO
              U    = - T - S + MCH2(IG1) + MCH2(IG2)
              DAB  = ABS(FLOAT(IG1+IG2-3))
              C1   = (-WMXVSS(IG1,2)*WMXVSS(IG2,2)+DAB*S22W/XW)/S2W/GZ
              C2   = (-WMXUSS(IG1,2)*WMXUSS(IG2,2)+DAB*S22W/XW)/S2W/GZ
              SGN = WSGNSS(IG1)*WSGNSS(IG2)
C--PR bug fix 31/03/00
              DO IQ = 1,6
                C3 = -DAB*QFCH(IQ)/S
                CLL = C3 - LFCH(IQ)*C1 +
     &        DQD(IQ)*WMXVSS(IG1,1)*WMXVSS(IG2,1)/((U-ML2(IWD(IQ)))*XW)
                CLR = C3 - LFCH(IQ)*C2 -
     &        DQU(IQ)*WMXUSS(IG1,1)*WMXUSS(IG2,1)/((T-ML2(IWD(IQ)))*XW)
                CRL = C3 - RFCH(IQ)*C1
                CRR = C3 - RFCH(IQ)*C2
                M1(IG1,IG2,IQ)=FACA*PF*
     &            HWHSS1(S,T,U,MCH(IG1),MCH(IG2),SGN,CLL,CLR,CRL,CRR)
              END DO
C--End of Fix
            ELSE
              DO IQ = 1,6
                M1(IG1,IG2,IQ) = ZERO
              END DO
            END IF
          END DO
        END DO
c       _     ~o ~o
c (2) q q  -> X  X
c              i  j
        DO IG1 = 1,4
          DO IG2 = 1,4
            SM   = MNU(IG1) + MNU(IG2)
            QPE  = S - SM**2
            IF (QPE.GE.ZERO) THEN
              DM   = MNU(IG1) - MNU(IG2)
              SQPE = SQRT(QPE*(S-DM**2))
              PF   = SQPE/S
              T    = (SQPE*COSTH - S + MNU2(IG1) + MNU2(IG2)) / TWO
              U    = - T - S + MNU2(IG1) + MNU2(IG2)
              C1   = (XD(IG1)*XD(IG2)-XC(IG1)*XC(IG2))/S2W/GZ
              C2   = - C1
              SGN  = ZSGNSS(IG1)*ZSGNSS(IG2)
              DO IQ = 1,6
                CLL =LFCH(IQ)*C1+SLFCH(IQ,IG1)*SLFCH(IQ,IG2)/(U-ML2(IQ))
                CLR =LFCH(IQ)*C2-SLFCH(IQ,IG1)*SLFCH(IQ,IG2)/(T-ML2(IQ))
                CRL =RFCH(IQ)*C1-SRFCH(IQ,IG1)*SRFCH(IQ,IG2)/(T-MR2(IQ))
                CRR =RFCH(IQ)*C2+SRFCH(IQ,IG1)*SRFCH(IQ,IG2)/(U-MR2(IQ))
                M2(IG1,IG2,IQ) = FACA*PF*HALF*
     &            HWHSS1(S,T,U,MNU(IG1),MNU(IG2),SGN,CLL,CLR,CRL,CRR)
              END DO
            ELSE
              DO IQ = 1,6
                M2(IG1,IG2,IQ) = ZERO
              END DO
            END IF
          END DO
        END DO
c       _     ~+ ~o
c (3) U D  -> X  X
c              a  i
        DO IG1 = 1,2
          DO IG2 = 1,4
            SM  = MCH(IG1) + MNU(IG2)
            QPE = S - SM**2
            IF (QPE.GE.ZERO) THEN
              DM   = MCH(IG1) - MNU(IG2)
              SQPE = SQRT(QPE*(S-DM**2))
              PF   = SQPE/S
              T    = (SQPE*COSTH - S + MCH2(IG1) + MNU2(IG2)) / TWO
              U    = - T - S + MCH2(IG1) + MNU2(IG2)
              C1   = XA(IG2)+S2W/XW*XB(IG2)
c note the new s-channel signs below.
              C2   = ( XC(IG2)*WMXUSS(IG1,2)/SQXW+C1*WMXUSS(IG1,1))/GW
              C3   = (-XD(IG2)*WMXVSS(IG1,2)/SQXW+C1*WMXVSS(IG1,1))/GW
              SGN = WSGNSS(IG1)*ZSGNSS(IG2)
              DO IQ1 = 1,3
                IQ3 = IQ1*2
                DO IQ2 = 1,3
                  IQ4 = IQ2*2-1
                  CLL = C2+WMXVSS(IG1,1)*SLFCH(IQ3,IG2)/(U-ML2(IQ3))
                  CLR = C3-WMXUSS(IG1,1)*SLFCH(IQ4,IG2)/(T-ML2(IQ4))
                  M3(IG1,IG2,IQ1,IQ2) = FACA*PF*VCKM(IQ1,IQ2)/XW*
     &              HWHSS1(S,T,U,MCH(IG1),MNU(IG2),SGN,CLL,CLR,Z0,Z0)
                END DO
              END DO
            ELSE
              DO IQ1 = 1,3
                DO IQ2 = 1,3
                  M3(IG1,IG2,IQ1,IQ2) = ZERO
                END DO
              END DO
            END IF
          END DO
        END DO
c       _     ~o ~
c (4) q q  -> X  g
c              i
        DO IG1 = 1,4
          SM   = MNU(IG1) + MG
          QPE  = S - SM**2
          IF (QPE.GE.ZERO) THEN
            DM   = MNU(IG1) - MG
            SQPE = SQRT(QPE*(S-DM**2))
            PF   = SQPE/S
            T    = (SQPE*COSTH - S + MG2 + MNU2(IG1)) / TWO
            U    = - T - S + MG2 + MNU2(IG1)
            DO IQ = 1,6
              CLL =   SLFCH(IQ,IG1)/(U-ML2(IQ))
              CLR = - SLFCH(IQ,IG1)/(T-ML2(IQ))
              CRL = - SRFCH(IQ,IG1)/(T-MR2(IQ))
              CRR =   SRFCH(IQ,IG1)/(U-MR2(IQ))
              M4(IG1,IQ) = FACB*PF*
     &          HWHSS1(S,T,U,MNU(IG1),MG,ZSGNSS(IG1),CLL,CLR,CRL,CRR)
            END DO
          ELSE
            DO IQ = 1,6
              M4(IG1,IQ) = ZERO
            END DO
          END IF
        END DO
c       _     ~+ ~
c (5) U D  -> X  g
c              a
        DO IG1 = 1,2
          SM   = MCH(IG1) + MG
          QPE  = S - SM**2
          IF (QPE.GE.ZERO) THEN
            DM   = MCH(IG1) - MG
            SQPE = SQRT(QPE*(S-DM**2))
            PF   = SQPE/S
            T    = (SQPE*COSTH - S + MCH2(IG1) + MG2) / TWO
            U    = - T - S + MCH2(IG1) + MG2
            DO IQ1 = 1,3
              IQ3 = IQ1*2
              DO IQ2 = 1,3
                IQ4 = IQ2*2-1
                CLL =   WMXVSS(IG1,1)/(U-ML2(IQ3))
                CLR = - WMXUSS(IG1,1)/(T-ML2(IQ4))
                M5(IG1,IQ1,IQ2) = FACB*PF*VCKM(IQ1,IQ2)/XW*
     &            HWHSS1(S,T,U,MCH(IG1),MG,WSGNSS(IG1),CLL,CLR,Z0,Z0)
              END DO
            END DO
          ELSE
            DO IQ1 = 1,3
              DO IQ2 = 1,3
                M5(IG1,IQ1,IQ2) = ZERO
              END DO
            END DO
          END IF
        END DO
c             ~o ~
c (6) g q  -> X  q
c              i  LR
        DO IG1 = 1,4
          DO IQ = 1,6
c           left squarks
            SM   = MNU(IG1)+ML(IQ)
            QPE  = S - SM**2
            IF (QPE.GE.ZERO) THEN
              DM   = MNU(IG1)-ML(IQ)
              SQPE = SQRT(QPE*(S-DM**2))
              PF   = SQPE/S
              T3   = (SQPE*COSTH - S - SM*DM) / TWO
              U4   = - T3 - S
C--KO bug fix 06/10/00
              M6L(IG1,IQ) = FACC*PF*((QMIXSS(IQ,1,1)*SLFCH(IQ,IG1))**2
     &          +(QMIXSS(IQ,2,1)*SRFCH(IQ,IG1))**2)*
     &         T3/S/U4*(-U4+TWO*SM*DM/T3/U4*SQPE*SQPE*SN2TH)
            ELSE
              M6L(IG1,IQ) = ZERO
            END IF
c           right squarks
            SM   = MNU(IG1)+MR(IQ)
            QPE  = S - SM**2
            IF (QPE.GE.ZERO) THEN
              DM   = MNU(IG1)-MR(IQ)
              SQPE = SQRT(QPE*(S-DM**2))
              PF   = SQPE/S
              T3   = (SQPE*COSTH - S - SM*DM) / TWO
              U4   = - T3 - S
              M6R(IG1,IQ) = FACC*PF * (
     &         QMIXSS(IQ,1,2)*SLFCH(IQ,IG1)+QMIXSS(IQ,2,2)*SRFCH(IQ,IG1)
     &         )**2 * T3/S/U4*(-U4+TWO*SM*DM/T3/U4*SQPE*SQPE*SN2TH)
            ELSE
              M6R(IG1,IQ) = ZERO
            END IF
          END DO
        END DO
c             ~+-~
c (7) g q  -> X  q'
c              a  L
        DO IG1 = 1,2
          DO IQ1 = 1,3
           IQ3 = IQ1*2
           DO IQ2 = 1,3
            IQ4 = IQ2*2-1
            DO I = 1,2
c             U initiated processes
              IF (I.EQ.1) THEN
                MSQK = ML(IQ4)
              ELSE
                MSQK = MR(IQ4)
              END IF
              SM  = MCH(IG1) + MSQK
              QPE = S - SM**2
              IF (((I.EQ.1).OR.(IQ2.EQ.3)).AND.(QPE.GE.ZERO)) THEN
                DM   = MCH(IG1) - MSQK
                SQPE = SQRT(QPE*(S-DM**2))
                PF   = SQPE/S
                T3   = (SQPE*COSTH - S - SM*DM) / TWO
                U4   = - T3 - S
                M7(I,IG1,IQ3,IQ4)=FACC*PF*WMXUSS(IG1,1)**2*VCKM(IQ1,IQ2)
     &            /XW*T3/S/U4*(-U4+TWO*SM*DM/T3/U4*SQPE*SQPE*SN2TH)*
     &            QMIXSS(IQ4,1,I)**2
              ELSE
                M7(I,IG1,IQ3,IQ4) = ZERO
              END IF
c             D initiated processes
              IF (I.EQ.1) THEN
                MSQK = ML(IQ3)
              ELSE
                MSQK = MR(IQ3)
              END IF
              SM  = MCH(IG1) + MSQK
              QPE = S - SM**2
              IF (((I.EQ.1).OR.(IQ1.EQ.3)).AND.(QPE.GE.ZERO)) THEN
                DM   = MCH(IG1) - MSQK
                SQPE = SQRT(QPE*(S-DM**2))
                PF   = SQPE/S
                T3   = (SQPE*COSTH - S - SM*DM) / TWO
                U4   = - T3 - S
                M7(I,IG1,IQ4,IQ3)=FACC*PF*WMXVSS(IG1,1)**2*VCKM(IQ1,IQ2)
     &            /XW*T3/S/U4*(-U4+TWO*SM*DM/T3/U4*SQPE*SQPE*SN2TH)*
     &            QMIXSS(IQ3,1,I)**2
              ELSE
                M7(I,IG1,IQ4,IQ3) = ZERO
              END IF
            END DO
           END DO
          END DO
        END DO
      END IF
      HCS = 0.
c       _    _       ~+ ~-   ~o ~o   ~o ~
c     q q ,  q q  -> X  X ,  X  X ,  X  g
c                     a  b    i  j    i
      DO 1 ID1 = 1,12
      IF (DISF(ID1,1).LT.EPS) GOTO 1
      IF (ID1.GT.6) THEN
       ID2 = ID1 - 6
       IQ  = ID2
       IPB = 4132
      ELSE
       ID2 = ID1 + 6
       IQ  = ID1
       IPB = 2431
      END IF
      IF (DISF(ID2,2).LT.EPS) GOTO 1
      DIST = DISF(ID1,1)*DISF(ID2,2)
      DO IG1 = 1,2
        IG3 = ICH+IG1
        DO IG2 = 1,2
          IG4 = ICH+IG2+2
          HCS = HCS + DIST*M1(IG1,IG2,IQ)
          IF (GENEV.AND.HCS.GT.RCS) CALL HWHSSS(IG3,0,IG4,0,2134,21,*9)
        END DO
      END DO
      DO IG1 = 1,4
        IG3 = INU+IG1
        DO IG2 = 1,4
          IG4 = INU+IG2
          IF (IG2.GE.IG1) HCS = HCS + DIST*M2(IG1,IG2,IQ)
          IF (GENEV.AND.HCS.GT.RCS) CALL HWHSSS(IG3,0,IG4,0,2134,22,*9)
        END DO
        HCS = HCS + DIST*M4(IG1,IQ)
        IF (GENEV.AND.HCS.GT.RCS) CALL HWHSSS(IG3,0,IGL,0, IPB,24,*9)
      END DO
    1 CONTINUE
c       _    _       ~+-~o   ~+-~
c     q q',  q q' -> X  X ,  X  g
c                     a  i    a
c
c      _     _       _     _
c     ud(+), ud(-), du(-), du(+)
      DO 2 IQ1 = 1, 3
      DO IQ2 = 1, 3
      IF(VCKM(IQ1,IQ2).GT.EPS) THEN
c      _
c     ud (+)
       ID1 = IQ1 * 2
       ID2 = IQ2 * 2 + 5
       IF ((DISF(ID1,1).GT.EPS).AND.(DISF(ID2,2).GT.EPS)) THEN
        DIST = DISF(ID1,1)*DISF(ID2,2)
        DO IG1 = 1,2
         IG3 = ICH+IG1
         DO IG2 = 1,4
          IG4 = INU+IG2
          HCS = HCS + DIST*M3(IG1,IG2,IQ1,IQ2)
          IF (GENEV.AND.HCS.GT.RCS) CALL HWHSSS(IG3,0,IG4,0,2134,23,*9)
         END DO
         HCS = HCS + DIST*M5(IG1,IQ1,IQ2)
         IF (GENEV.AND.HCS.GT.RCS) CALL HWHSSS(IG3,0,IGL,0,2431,25,*9)
        END DO
       END IF
c     _
c     du (+)
       ID1 = IQ2 * 2 + 5
       ID2 = IQ1 * 2
       IF ((DISF(ID1,1).GT.EPS).AND.(DISF(ID2,2).GT.EPS)) THEN
        DIST = DISF(ID1,1)*DISF(ID2,2)
        DO IG1 = 1,2
         IG3 = ICH+IG1
         DO IG2 = 1,4
          IG4 = INU+IG2
          HCS = HCS + DIST*M3(IG1,IG2,IQ1,IQ2)
          IF (GENEV.AND.HCS.GT.RCS) CALL HWHSSS(IG4,0,IG3,0,2134,23,*9)
         END DO
         HCS = HCS + DIST*M5(IG1,IQ1,IQ2)
         IF (GENEV.AND.HCS.GT.RCS) CALL HWHSSS(IGL,0,IG3,0,3124,25,*9)
        END DO
       END IF
c      _
c     du (-)
       ID1 = IQ2 * 2 - 1
       ID2 = IQ1 * 2 + 6
       IF ((DISF(ID1,1).GT.EPS).AND.(DISF(ID2,2).GT.EPS)) THEN
        DIST = DISF(ID1,1)*DISF(ID2,2)
        DO IG1 = 1,2
         IG3 = ICH+IG1+2
         DO IG2 = 1,4
          IG4 = INU+IG2
          HCS = HCS + DIST*M3(IG1,IG2,IQ1,IQ2)
          IF (GENEV.AND.HCS.GT.RCS) CALL HWHSSS(IG4,0,IG3,0,2134,23,*9)
         END DO
         HCS = HCS + DIST*M5(IG1,IQ1,IQ2)
         IF (GENEV.AND.HCS.GT.RCS) CALL HWHSSS(IGL,0,IG3,0,2314,25,*9)
        END DO
       END IF
c     _
c     ud (-)
       ID1 = IQ1 * 2 + 6
       ID2 = IQ2 * 2 - 1
       IF ((DISF(ID1,1).GT.EPS).AND.(DISF(ID2,2).GT.EPS)) THEN
        DIST = DISF(ID1,1)*DISF(ID2,2)
        DO IG1 = 1,2
         IG3 = ICH+IG1+2
         DO IG2 = 1,4
          IG4 = INU+IG2
          HCS = HCS + DIST*M3(IG1,IG2,IQ1,IQ2)
          IF (GENEV.AND.HCS.GT.RCS) CALL HWHSSS(IG3,0,IG4,0,2134,23,*9)
         END DO
         HCS = HCS + DIST*M5(IG1,IQ1,IQ2)
         IF (GENEV.AND.HCS.GT.RCS) CALL HWHSSS(IG3,0,IGL,0,4132,25,*9)
        END DO
       END IF
      END IF
      END DO
    2 CONTINUE
c              _           _       ~o ~    ~+-~
c     g q ,  g q ,  q g ,  q g  -> X  q ,  X  q'
c                                   i  LR   a  L
c     neutralino
      DO IQ1 = 1,6
c
c      gq
       ID1 = 13
       ID2 = IQ1
       IF ((DISF(ID1,1).GT.EPS).AND.(DISF(ID2,2).GT.EPS)) THEN
        DIST = DISF(ID1,1)*DISF(ID2,2)
        DO IG1 = 1,4
         IG3 = INU+IG1
         HCS = HCS + DIST*M6L(IG1,IQ1)
         IF (GENEV.AND.HCS.GT.RCS) CALL HWHSSS(IG3,0,ID2,0,2431,26,*9)
         HCS = HCS + DIST*M6R(IG1,IQ1)
         IF (GENEV.AND.HCS.GT.RCS) CALL HWHSSS(IG3,0,ID2,2,2431,26,*9)
        END DO
       END IF
c       _
c      gq
       ID1 = 13
       ID2 = IQ1 + 6
       IF ((DISF(ID1,1).GT.EPS).AND.(DISF(ID2,2).GT.EPS)) THEN
        DIST = DISF(ID1,1)*DISF(ID2,2)
        DO IG1 = 1,4
         IG3 = INU+IG1
         HCS = HCS + DIST*M6L(IG1,IQ1)
         IF (GENEV.AND.HCS.GT.RCS) CALL HWHSSS(IG3,0,ID2,0,4132,26,*9)
         HCS = HCS + DIST*M6R(IG1,IQ1)
         IF (GENEV.AND.HCS.GT.RCS) CALL HWHSSS(IG3,0,ID2,2,4132,26,*9)
        END DO
       END IF
c
c      qg
       ID1 = IQ1
       ID2 = 13
       IF ((DISF(ID1,1).GT.EPS).AND.(DISF(ID2,2).GT.EPS)) THEN
        DIST = DISF(ID1,1)*DISF(ID2,2)
        DO IG1 = 1,4
         IG3 = INU+IG1
         HCS = HCS + DIST*M6L(IG1,IQ1)
         IF (GENEV.AND.HCS.GT.RCS) CALL HWHSSS(ID1,0,IG3,0,3124,26,*9)
         HCS = HCS + DIST*M6R(IG1,IQ1)
         IF (GENEV.AND.HCS.GT.RCS) CALL HWHSSS(ID1,2,IG3,0,3124,26,*9)
        END DO
       END IF
c      _
c      qg
       ID1 = IQ1 + 6
       ID2 = 13
       IF ((DISF(ID1,1).GT.EPS).AND.(DISF(ID2,2).GT.EPS)) THEN
        DIST = DISF(ID1,1)*DISF(ID2,2)
        DO IG1 = 1,4
         IG3 = INU+IG1
         HCS = HCS + DIST*M6L(IG1,IQ1)
         IF (GENEV.AND.HCS.GT.RCS) CALL HWHSSS(ID1,0,IG3,0,2314,26,*9)
         HCS = HCS + DIST*M6R(IG1,IQ1)
         IF (GENEV.AND.HCS.GT.RCS) CALL HWHSSS(ID1,2,IG3,0,2314,26,*9)
        END DO
       END IF
      END DO
c     chargino
      DO IQ1 = 1,3
       IQ3 = IQ1*2
       DO 3 IQ2 = 1,3
        IF (VCKM(IQ1,IQ2).LT.EPS) GOTO 3
        IQ4 = IQ2*2-1
        DO IG1 = 1,2
         IG3 = ICH+IG1
         IG4 = ICH+IG1+2
c
c        gq & qg
         ID1 = 13
         ID2 = IQ3
         HCS = HCS + DISF(ID1,1)*DISF(ID2,2)*M7(1,IG1,IQ3,IQ4)
         IF (GENEV.AND.HCS.GT.RCS) CALL HWHSSS(IG3,0,IQ4,0,2431,27,*9)
         HCS = HCS + DISF(ID1,1)*DISF(ID2,2)*M7(2,IG1,IQ3,IQ4)
         IF (GENEV.AND.HCS.GT.RCS) CALL HWHSSS(IG3,0,IQ4,2,2431,27,*9)
         ID2 = IQ4
         HCS = HCS + DISF(ID1,1)*DISF(ID2,2)*M7(1,IG1,IQ4,IQ3)
         IF (GENEV.AND.HCS.GT.RCS) CALL HWHSSS(IG4,0,IQ3,0,2431,27,*9)
         HCS = HCS + DISF(ID1,1)*DISF(ID2,2)*M7(2,IG1,IQ4,IQ3)
         IF (GENEV.AND.HCS.GT.RCS) CALL HWHSSS(IG4,0,IQ3,2,2431,27,*9)
         ID1 = IQ3
         ID2 = 13
         HCS = HCS + DISF(ID1,1)*DISF(ID2,2)*M7(1,IG1,IQ3,IQ4)
         IF (GENEV.AND.HCS.GT.RCS) CALL HWHSSS(IQ4,0,IG3,0,3124,27,*9)
         HCS = HCS + DISF(ID1,1)*DISF(ID2,2)*M7(2,IG1,IQ3,IQ4)
         IF (GENEV.AND.HCS.GT.RCS) CALL HWHSSS(IQ4,2,IG3,0,3124,27,*9)
         ID1 = IQ4
         HCS = HCS + DISF(ID1,1)*DISF(ID2,2)*M7(1,IG1,IQ4,IQ3)
         IF (GENEV.AND.HCS.GT.RCS) CALL HWHSSS(IQ3,0,IG4,0,3124,27,*9)
         HCS = HCS + DISF(ID1,1)*DISF(ID2,2)*M7(2,IG1,IQ4,IQ3)
         IF (GENEV.AND.HCS.GT.RCS) CALL HWHSSS(IQ3,2,IG4,0,3124,27,*9)
c         _   _
c        gq & qg
         ID1 = 13
         ID2 = IQ3 + 6
         HCS = HCS + DISF(ID1,1)*DISF(ID2,2)*M7(1,IG1,IQ3,IQ4)
         IF (GENEV.AND.HCS.GT.RCS) CALL HWHSSS(IG4,0,IQ4,1,4132,27,*9)
         HCS = HCS + DISF(ID1,1)*DISF(ID2,2)*M7(2,IG1,IQ3,IQ4)
         IF (GENEV.AND.HCS.GT.RCS) CALL HWHSSS(IG4,0,IQ4,3,4132,27,*9)
         ID2 = IQ4 + 6
         HCS = HCS + DISF(ID1,1)*DISF(ID2,2)*M7(1,IG1,IQ4,IQ3)
         IF (GENEV.AND.HCS.GT.RCS) CALL HWHSSS(IG3,0,IQ3,1,4132,27,*9)
         HCS = HCS + DISF(ID1,1)*DISF(ID2,2)*M7(2,IG1,IQ4,IQ3)
         IF (GENEV.AND.HCS.GT.RCS) CALL HWHSSS(IG3,0,IQ3,3,4132,27,*9)
         ID1 = IQ3 + 6
         ID2 = 13
         HCS = HCS + DISF(ID1,1)*DISF(ID2,2)*M7(1,IG1,IQ3,IQ4)
         IF (GENEV.AND.HCS.GT.RCS) CALL HWHSSS(IQ4,1,IG4,0,2314,27,*9)
         HCS = HCS + DISF(ID1,1)*DISF(ID2,2)*M7(2,IG1,IQ3,IQ4)
         IF (GENEV.AND.HCS.GT.RCS) CALL HWHSSS(IQ4,3,IG4,0,2314,27,*9)
         ID1 = IQ4 + 6
         HCS = HCS + DISF(ID1,1)*DISF(ID2,2)*M7(1,IG1,IQ4,IQ3)
         IF (GENEV.AND.HCS.GT.RCS) CALL HWHSSS(IQ3,1,IG3,0,2314,27,*9)
         HCS = HCS + DISF(ID1,1)*DISF(ID2,2)*M7(2,IG1,IQ4,IQ3)
         IF (GENEV.AND.HCS.GT.RCS) CALL HWHSSS(IQ3,3,IG3,0,2314,27,*9)
        END DO
    3  CONTINUE
      END DO
      EVWGT = HCS
      RETURN
C---GENERATE EVENT
    9 IDN(1)=ID1
      IDN(2)=ID2
      IDCMF=15
      CALL HWETWO
      IF (AZSPIN) THEN
C Calculate coefficients for constructing spin density matrices
C Set to zero for now
        CALL HWVZRO(7,GCOEF)
      END IF
  888 END
CDECK  ID>, HWHSSL.
*CMZ :-        -18/05/99  20.33.45  by  Kosuke Odagiri
*-- Author :    Kosuke Odagiri
C-----------------------------------------------------------------------
      SUBROUTINE HWHSSL
C-----------------------------------------------------------------------
C     SUSY 2 PARTON -> 2 SLEPTON PROCESSES
C-----------------------------------------------------------------------
      INCLUDE 'HERWIG62.INC'
      DOUBLE PRECISION HWRGEN, HWUAEM, EPS, HCS, RCS, DIST, S, PF, QPE,
     & FACTR, SN2TH, MZ, MW, ME2(2,2,6,2), ME2W(2,3), EMSC2, GW2
      INTEGER IQ, IQ1, IQ2, ID1, ID2, IL, IL1, IL2, I, J
      EXTERNAL HWRGEN, HWUAEM
      SAVE HCS, ME2, ME2W
      PARAMETER (EPS = 1.D-9)
      DOUBLE COMPLEX Z, GZ, A, BL, BR, CL, CR, D, E
      PARAMETER (Z = (0.D0,1.D0))
      EQUIVALENCE (MZ, RMASS(200)), (MW, RMASS(198))
C
      S     = XX(1)*XX(2)*PHEP(5,3)**2
      EMSC2 = S
      EMSCA = SQRT(EMSC2)
      CALL    HWSGEN(.FALSE.)
      IF (GENEV) THEN
        RCS = HCS*HWRGEN(0)
      ELSE
        SN2TH = 0.25D0 - 0.25D0*COSTH**2
        FACTR = FACTSS*HWUAEM(EMSC2)**2/CAFAC*SN2TH
        GZ    = (S-MZ**2+Z*S*GAMZ/MZ)/S
        GW2   = ((ONE-MW**2/S)**2+(GAMW/MW)**2)*(TWO*SWEIN)**2
c      _     ~  ~*
c    q q  -> l  l
c
        DO IL = 1,6
          DO I = 1,2
            DO J = 1,2
              IF (((I.NE.J).AND.(IL.NE.5)).OR.
     &            ((I.EQ.2).AND.(((IL/2)*2).EQ.IL))) THEN
                QPE = -1.
              ELSE
                ID1 = 412 + I*12 + IL
                ID2 = 412 + J*12 + IL
                IL1 = IL + 10
                QPE = S-(RMASS(ID1)+RMASS(ID2))**2
              END IF
              IF (QPE.GT.ZERO) THEN
                PF = SQRT(QPE*(S-(RMASS(ID1)-RMASS(ID2))**2))/S
                DO IQ = 1,2
                 A = QFCH(IL1)*QFCH(IQ)
                 BL = LFCH(IL1)/GZ
                 BR = RFCH(IL1)/GZ
                 CL = LMIXSS(IL,1,I)*LMIXSS(IL,1,J)
                 CR = LMIXSS(IL,2,I)*LMIXSS(IL,2,J)
                 D = (A+BL*LFCH(IQ))*CL+(A+BR*LFCH(IQ))*CR
                 E = (A+BL*RFCH(IQ))*CL+(A+BR*RFCH(IQ))*CR
                 ME2(I,J,IL,IQ)=FACTR*PF**3
     $                *DREAL(DCONJG(D)*D+DCONJG(E)*E)
                END DO
              ELSE
                ME2(I,J,IL,1)=ZERO
                ME2(I,J,IL,2)=ZERO
              END IF
            END DO
          END DO
        END DO
c      _     ~  ~*
c    q q' -> l  v
c
        DO IL = 1,3
         DO I = 1,2
          IF ((IL.NE.3).AND.(I.EQ.2)) THEN
            QPE = -1.
          ELSE
            ID1 = 411 + IL*2 + I*12
            ID2 = 424 + IL*2
            QPE = S-(RMASS(ID1)+RMASS(ID2))**2
          END IF
          IF (QPE.GT.ZERO) THEN
            PF = SQRT(QPE*(S-(RMASS(ID1)-RMASS(ID2))**2))/S
            ME2W(I,IL)=FACTR*PF**3/GW2
            IF (IL.EQ.3) ME2W(I,3)=ME2W(I,3)*LMIXSS(5,1,I)**2
          ELSE
            ME2W(I,IL)=ZERO
          END IF
         END DO
        END DO

      END IF
      HCS = 0.
C
      DO 1 ID1 = 1, 12
       IF (DISF(ID1,1).LT.EPS) GOTO 1
       IF (ID1.GT.6) THEN
        ID2 = ID1 - 6
       ELSE
        ID2 = ID1 + 6
       END IF
       IQ  = ID1 - ((ID1-1)/2)*2
       IF (DISF(ID2,2).LT.EPS) GOTO 1
       DIST = DISF(ID1,1)*DISF(ID2,2)
       DO IL = 1,6
        DO I = 1,2
         DO J = 1,2
          IL1 = IL+I*12
          IL2 = IL+J*12
          HCS = HCS + DIST*ME2(I,J,IL,IQ)
          IF (GENEV.AND.HCS.GT.RCS) CALL HWHSSS(IL1,2,IL2,3,2134,30,*9)
         END DO
        END DO
       END DO
    1 CONTINUE
c      _     _       _     _
c     ud(+), ud(-), du(-), du(+)
      DO 2 IQ1 = 1, 3
      DO IQ2 = 1, 3
      IF(VCKM(IQ1,IQ2).GT.EPS) THEN
c      _
c     ud (+)
       ID1 = IQ1 * 2
       ID2 = IQ2 * 2 + 5
       IF ((DISF(ID1,1).GT.EPS).AND.(DISF(ID2,2).GT.EPS)) THEN
        DIST = VCKM(IQ1,IQ2)*DISF(ID1,1)*DISF(ID2,2)
        DO IL = 1,3
         IL1 = IL*2-1
         IL2 = IL1+1
         HCS = HCS + DIST*ME2W(1,IL)
         IF (GENEV.AND.HCS.GT.RCS) CALL HWHSSS(IL1,5,IL2,4,2134,30,*9)
        END DO
        HCS = HCS + DIST*ME2W(2,3)
        IF (GENEV.AND.HCS.GT.RCS) CALL HWHSSS(5,7,6,4,2134,30,*9)
       END IF
c     _
c     du (+)
       ID1 = IQ2 * 2 + 5
       ID2 = IQ1 * 2
       IF ((DISF(ID1,1).GT.EPS).AND.(DISF(ID2,2).GT.EPS)) THEN
        DIST = VCKM(IQ1,IQ2)*DISF(ID1,1)*DISF(ID2,2)
        DO IL = 1,3
         IL1 = IL*2-1
         IL2 = IL1+1
         HCS = HCS + DIST*ME2W(1,IL)
         IF (GENEV.AND.HCS.GT.RCS) CALL HWHSSS(IL1,5,IL2,4,2134,30,*9)
        END DO
        HCS = HCS + DIST*ME2W(2,3)
        IF (GENEV.AND.HCS.GT.RCS) CALL HWHSSS(5,7,6,4,2134,30,*9)
       END IF
c      _
c     du (-)
       ID1 = IQ2 * 2 - 1
       ID2 = IQ1 * 2 + 6
       IF ((DISF(ID1,1).GT.EPS).AND.(DISF(ID2,2).GT.EPS)) THEN
        DIST = VCKM(IQ1,IQ2)*DISF(ID1,1)*DISF(ID2,2)
        DO IL = 1,3
         IL1 = IL*2-1
         IL2 = IL1+1
         HCS = HCS + DIST*ME2W(1,IL)
         IF (GENEV.AND.HCS.GT.RCS) CALL HWHSSS(IL1,4,IL2,5,2134,30,*9)
        END DO
        HCS = HCS + DIST*ME2W(2,3)
        IF (GENEV.AND.HCS.GT.RCS) CALL HWHSSS(5,6,6,5,2134,30,*9)
       END IF
c     _
c     ud (-)
       ID1 = IQ1 * 2 + 6
       ID2 = IQ2 * 2 - 1
       IF ((DISF(ID1,1).GT.EPS).AND.(DISF(ID2,2).GT.EPS)) THEN
        DIST = VCKM(IQ1,IQ2)*DISF(ID1,1)*DISF(ID2,2)
        DO IL = 1,3
         IL1 = IL*2-1
         IL2 = IL1+1
         HCS = HCS + DIST*ME2W(1,IL)
         IF (GENEV.AND.HCS.GT.RCS) CALL HWHSSS(IL1,4,IL2,5,2134,30,*9)
        END DO
        HCS = HCS + DIST*ME2W(2,3)
        IF (GENEV.AND.HCS.GT.RCS) CALL HWHSSS(5,6,6,5,2134,30,*9)
       END IF
      END IF
      END DO
    2 CONTINUE

      EVWGT = HCS
      RETURN
C---GENERATE EVENT
    9 IDN(1)=ID1
      IDN(2)=ID2
      IDCMF=15
      CALL HWETWO
      IF (AZSPIN) THEN
C Calculate coefficients for constructing spin density matrices
C Set to zero for now
        CALL HWVZRO(7,GCOEF)
      END IF
      END
CDECK  ID>, HWHSSQ.
*CMZ :-        -18/05/99  20.33.45  by  Kosuke Odagiri
*-- Author :    Kosuke Odagiri
C-----------------------------------------------------------------------
      SUBROUTINE HWHSSQ
C-----------------------------------------------------------------------
C     SUSY HARD 2 PARTON -> 2 SPARTON PROCESSES
C-----------------------------------------------------------------------
      INCLUDE 'HERWIG62.INC'
      DOUBLE PRECISION HWRGEN, HWUALF, EPS, HCS, RCS, DIST, NC, NC2,
     & NC2C, ML2(6), ML4(6), MR2(6), MR4(6), MG2, SM, DM, QPE,
     & SQPE, FACTR, AFAC, AF, BONE, CFAC, CFC2, CFC3, CONE,
     & CONN, CONT, CONU, CONL, CONR, DFAC, DONE, PF, S,
     & S2, TT, TT2, TMG, TMG2, UU, UU2, UMG, UMG2,
     & L, L2, TTML, UUML, R, R2, TTMR, UUMR, SN2TH
      DOUBLE PRECISION
     & AUSTLL(6),   AUSTRR(6),
     & ASTULL(6,6), ASTURR(6,6), ASTULR(6,6), ASTURL(6,6),
     & AUTSLL(6,6), AUTSRR(6,6), AUTSLR(6,6), AUTSRL(6,6),
     & BSTULL(6),   BSTURR(6),   BSTULR(6),   BSTURL(6),
     & BSUTLL(6),   BSUTRR(6),   BSUTLR(6),   BSUTRL(6),
     & BUTSLL(6),   BUTSRR(6),   BUTSLR(6),   BUTSRL(6),
     & BUSTLL(6),   BUSTRR(6),   BUSTLR(6),   BUSTRL(6),
     & CSTU(6), CSUT(6), CSTUL(6), CSTUR(6), CSUTL(6), CSUTR(6),
     & CTSUL(6), CTSUR(6), CTUSL(6), CTUSR(6), DUTS, DTSU, DSTU
      INTEGER IQ, IQ1, IQ2, ID1, ID2, ID2MIN, IGL, SSL, SSR, GLU
      EXTERNAL HWRGEN, HWUALF
      SAVE HCS, AUSTLL, AUSTRR, ASTULL, ASTURR, ASTULR, ASTURL,
     & AUTSLL, AUTSRR, AUTSLR, AUTSRL, BSTULL, BSTURR, BSTULR,
     & BSTURL, BSUTLL, BSUTRR, BSUTLR, BSUTRL, BUTSLL, BUTSRR, BUTSLR,
     & BUTSRL, BUSTLL, BUSTRR, BUSTLR, BUSTRL, CSTU, CSUT, CSTUL, CSTUR,
     & CSUTL, CSUTR, CTSUL, CTSUR, CTUSL, CTUSR, DUTS, DTSU, DSTU
      PARAMETER (EPS = 1.D-9, IGL = 49, SSL = 400, SSR = 412, GLU = 449)
      CALL    HWSGEN(.FALSE.)
      IF (GENEV) THEN
        RCS = HCS*HWRGEN(0)
      ELSE
        SN2TH = 0.25D0 - 0.25D0*COSTH**2
        S     = XX(1)*XX(2)*PHEP(5,3)**2
        FACTR = FACTSS*HWUALF(1,EMSCA)**2
        NC    = CAFAC
        NC2   = NC**2
        NC2C  = ONE - ONE/NC2
        AFAC  = FACTR*NC2C/FOUR
        CFAC  = FACTR*CFFAC/FOUR
        CFC2  = FACTR/CFFAC/FOUR
        CFC3  = FACTR/FOUR
        DFAC  = FACTR/NC2C
        S2    = S**2
        MG2   = RMASS(GLU)**2
        DO 10 IQ = 1, 6
          IQ1     = SSL + IQ
          IQ2     = SSR + IQ
          ML2(IQ) = RMASS(IQ1)**2
          ML4(IQ) = ML2(IQ)**2
          MR2(IQ) = RMASS(IQ2)**2
          MR4(IQ) = MR2(IQ)**2
   10   CONTINUE
c     gluino pair production
        QPE  = S - FOUR*MG2
        IF (QPE.GE.ZERO) THEN
          SQPE = SQRT(S*QPE)
          PF   = SQPE/S
          TT   = (SQPE*COSTH - S) / TWO
          TT2  = TT**2
          UU   = - S - TT
          UU2  = UU**2
c            ~ ~
c     g g -> g g
c
          DONE =
     &     DFAC*PF/TWO*(UU2+TT2+FOUR*MG2*S*SQPE**2*SN2TH/TT/UU)/S2/TT/UU
          DUTS = DONE*UU2
          DTSU = DONE*TT2
          DSTU = DONE*S2
c       _    ~ ~
c     q q -> g g
c
          DO 21 IQ = 1, 6
            L    = ML2(IQ)-MG2
            L2   = L**2
            TTML = TT-L
            UUML = UU-L
            R    = MR2(IQ)-MG2
            R2   = R**2
            TTMR = TT-R
            UUMR = UU-R
            CONE = TWO*PF**2*SN2TH
            CONL = CONE/UUML/TTML
            CONR = CONE/UUMR/TTMR
            CONT = (UU2-L2)*CONL+(UU2-R2)*CONR+L2/TTML**2+R2/TTMR**2
            CONU = (TT2-L2)*CONL+(TT2-R2)*CONR+L2/UUML**2+R2/UUMR**2
            CONN = CFAC*(PF-PF/NC2/(CONT+CONU)*( S2*(CONL+CONR)+
     &            L2*((TT-UU)*CONL/CONE)**2+R2*((TT-UU)*CONR/CONE)**2 ))
            CSTU(IQ) = CONT*CONN
            CSUT(IQ) = CONU*CONN
   21     CONTINUE
        ELSE
          DUTS = ZERO
          DTSU = ZERO
          DSTU = ZERO
          DO 23 IQ = 1, 6
            CSTU(IQ) = ZERO
            CSUT(IQ) = ZERO
   23     CONTINUE
        END IF
c     left handed squark (identical flavour) pair production
        DO 22 IQ = 1, 6
          QPE = S - FOUR*ML2(IQ)
          IF (QPE.GE.ZERO) THEN
            SQPE = SQRT(S*QPE)
            PF   = SQPE/S
            TT   = (SQPE*COSTH - S) / TWO
            TT2  = TT**2
            UU   = - S - TT
            UU2  = UU**2
c            ~ ~*
c     g g -> q q
c             L L
            CONE = CFC2*PF*((SQPE*PF*SN2TH)**2+ML4(IQ))/TT2/UU2
            CONN = CONE-CONE*S2/(TT2+UU2)/NC2
            CSTUL(IQ)  = CONN*UU2
            CSUTL(IQ)  = CONN*TT2
c            ~ ~
c     q q -> q q
c             L L
            TMG  = TT+ML2(IQ)-MG2
            TMG2 = TMG**2
            UMG  = UU+ML2(IQ)-MG2
            UMG2 = UMG**2
            BONE = AFAC*PF*MG2*S*(HALF-TMG*UMG/(TMG2+UMG2)/NC)
            BSTULL(IQ) = BONE/TMG2
            BSUTLL(IQ) = BONE/UMG2
c       _    ~ ~*
c     q q -> q q
c             L L
            AF   = AFAC*PF*PF**2*SN2TH
            BONE = AF/TMG2-AF*S/(HALF*S2+TMG2)/TMG/NC
            BUTSLL(IQ) = BONE*S2
            BUSTLL(IQ) = BONE*TWO*TMG2
c       _     ~ ~*
c     q q  -> q'q'       q =/= q'
c              L L
            AUSTLL(IQ) = TWO*AF
          ELSE
            CSTUL(IQ)  = ZERO
            CSUTL(IQ)  = ZERO
            BSTULL(IQ) = ZERO
            BSUTLL(IQ) = ZERO
            BUTSLL(IQ) = ZERO
            BUSTLL(IQ) = ZERO
            AUSTLL(IQ) = ZERO
          END IF
c     right handed squark (identical flavour) pair production
          QPE = S - FOUR*MR2(IQ)
          IF (QPE.GE.ZERO) THEN
            SQPE = SQRT(S*QPE)
            PF   = SQPE/S
            TT   = (SQPE*COSTH - S) / TWO
            TT2  = TT**2
            UU   = - S - TT
            UU2  = UU**2
c            ~ ~*
c     g g -> q q
c             R R
            CONE = CFC2*PF*((SQPE*PF*SN2TH)**2+MR4(IQ))/TT2/UU2
            CONN = CONE-CONE*S2/(TT2+UU2)/NC2
            CSTUR(IQ) = CONN*UU2
            CSUTR(IQ) = CONN*TT2
c            ~ ~
c     q q -> q q
c             R R
            TMG  = TT+MR2(IQ)-MG2
            TMG2 = TMG**2
            UMG  = UU+MR2(IQ)-MG2
            UMG2 = UMG**2
            BONE = AFAC*PF*MG2*S*(HALF-TMG*UMG/(TMG2+UMG2)/NC)
            BSTURR(IQ) = BONE/TMG2
            BSUTRR(IQ) = BONE/UMG2
c       _    ~ ~*
c     q q -> q q
c             R R
            AF = AFAC*PF*PF**2*SN2TH
            BONE = AF/TMG2-AF*S/(HALF*S2+TMG2)/TMG/NC
            BUTSRR(IQ) = BONE*S2
            BUSTRR(IQ) = BONE*TWO*TMG2
c       _     ~ ~*
c     q q  -> q'q'       q =/= q'
c              R R
            AUSTRR(IQ) = TWO*AF
          ELSE
            CSTUR(IQ)  = ZERO
            CSUTR(IQ)  = ZERO
            BSTURR(IQ) = ZERO
            BSUTRR(IQ) = ZERO
            BUTSRR(IQ) = ZERO
            BUSTRR(IQ) = ZERO
            AUSTRR(IQ) = ZERO
          END IF
c     left and right handed squark (identical flavour) pair production
          IQ1  = SSL + IQ
          IQ2  = SSR + IQ
          SM   = RMASS(IQ1)+RMASS(IQ2)
          QPE  = S - SM**2
          IF (QPE.GE.ZERO) THEN
            DM   = RMASS(IQ1)-RMASS(IQ2)
            SQPE = SQRT( QPE*(S-DM**2) )
            PF   = SQPE/S
            AF   = AFAC*PF
            TT   = (SQPE*COSTH - S - SM*DM) / TWO
            UU   = - S - TT
            TMG  = TT + ML2(IQ) - MG2
            TMG2 = TMG**2
            UMG  = UU + MR2(IQ) - MG2
            UMG2 = UMG**2
c            ~ ~
c     q q -> q q
c             L R
            BONE = AFAC*PF*SQPE**2*SN2TH
            BSTULR(IQ) = BONE/TMG2
            BSUTLR(IQ) = BONE/UMG2
c       _    ~ ~*
c     q q -> q q
c             L R
            BUTSLR(IQ) = AFAC*PF*MG2*S/TMG2
            BUSTLR(IQ) = ZERO
            TT   = (SQPE*COSTH - S + SM*DM) / TWO
            UU   = - S - TT
            TMG  = TT + MR2(IQ) - MG2
            TMG2 = TMG**2
            UMG  = UU + ML2(IQ) - MG2
            UMG2 = UMG**2
c            ~ ~
c     q q -> q q
c             R L
c            BONE = AFAC*PF*SQPE**2*SN2TH
c            BSTURL(IQ) = BONE/TMG2
c            BSUTRL(IQ) = BONE/UMG2
            BSTURL(IQ) = ZERO
            BSUTRL(IQ) = ZERO
c       _    ~ ~*
c     q q -> q q
c             R L
            BUTSRL(IQ) = AFAC*PF*MG2*S/TMG2
            BUSTRL(IQ) = ZERO
          ELSE
            BSTULR(IQ) = ZERO
            BSUTLR(IQ) = ZERO
            BUTSLR(IQ) = ZERO
            BUSTLR(IQ) = ZERO
            BSTURL(IQ) = ZERO
            BSUTRL(IQ) = ZERO
            BUTSRL(IQ) = ZERO
            BUSTRL(IQ) = ZERO
          END IF
   22   CONTINUE
c     distinct flavours - gq, qq'
        DO 11 ID1 = 1, 6
          IQ1  = SSL + ID1
          SM   = RMASS(GLU)+RMASS(IQ1)
          QPE  = S - SM**2
          IF (QPE.GE.ZERO) THEN
            DM   = RMASS(GLU)-RMASS(IQ1)
            SQPE = SQRT( QPE*(S-DM**2) )
            PF   = SQPE/S
            TT   = (SQPE*COSTH - S - SM*DM) / TWO
            TT2  = TT**2
            UU   = - S - TT
            UU2  = UU**2
c            ~ ~
c     g q -> g q
c               L
            CONE = (-UU+TWO*SM*DM*(ONE+MG2/TT+ML2(ID1)/UU))/S/TT/UU
            CONN = CFC3*PF*CONE*(ONE-TT2/(UU2+S2)/NC2)
            CTSUL(ID1) = CONN*UU2
            CTUSL(ID1) = CONN*S2
          ELSE
            CTSUL(ID1) = ZERO
            CTUSL(ID1) = ZERO
          END IF
          IQ2  = SSR + ID1
          SM   = RMASS(GLU)+RMASS(IQ2)
          QPE  = S - SM**2
          IF (QPE.GE.ZERO) THEN
            DM   = RMASS(GLU)-RMASS(IQ2)
            SQPE = SQRT( QPE*(S-DM**2) )
            PF   = SQPE/S
            TT   = (SQPE*COSTH - S - SM*DM) / TWO
            TT2  = TT**2
            UU   = - S - TT
            UU2  = UU**2
c            ~ ~
c     g q -> g q
c               R
            CONE = (-UU+TWO*SM*DM*(ONE+MG2/TT+MR2(ID1)/UU))/S/TT/UU
            CONN = CFC3*PF*CONE*(ONE-TT2/(UU2+S2)/NC2)
            CTSUR(ID1) = CONN*UU2
            CTUSR(ID1) = CONN*S2
          ELSE
            CTSUR(ID1) = ZERO
            CTUSR(ID1) = ZERO
          END IF
          IF(ID1.EQ.6) GOTO 11
          ID2MIN = ID1+1
          DO 12 ID2 = ID2MIN, 6
            IQ1  = SSL + ID1
            IQ2  = SSL + ID2
            SM   = RMASS(IQ1)+RMASS(IQ2)
            QPE  = S - SM**2
            IF (QPE.GE.ZERO) THEN
              DM   = RMASS(IQ1)-RMASS(IQ2)
              SQPE = SQRT( QPE*(S-DM**2) )
              PF   = SQPE/S
              TT   = (SQPE*COSTH - S - SM*DM) / TWO
              UU   = - S - TT
              TMG  = TT+ML2(ID1)-MG2
              AF   = AFAC*PF/TMG/TMG
c             ~ ~
c     q q' -> q q'
c              L L
              ASTULL(ID1,ID2) = AF*MG2*S
              ASTULL(ID2,ID1) = ASTULL(ID1,ID2)
c       _     ~ ~*
c     q q' -> q q'
c              L L
              AUTSLL(ID1,ID2) = AF*SQPE**2*SN2TH
              AUTSLL(ID2,ID1) = AUTSLL(ID1,ID2)
            ELSE
              ASTULL(ID1,ID2) = ZERO
              ASTULL(ID2,ID1) = ZERO
              AUTSLL(ID1,ID2) = ZERO
              AUTSLL(ID2,ID1) = ZERO
            END IF
            IQ1  = SSR + ID1
            IQ2  = SSR + ID2
            SM   = RMASS(IQ1)+RMASS(IQ2)
            QPE  = S - SM**2
            IF (QPE.GE.ZERO) THEN
              DM   = RMASS(IQ1)-RMASS(IQ2)
              SQPE = SQRT( QPE*(S-DM**2) )
              PF   = SQPE/S
              TT   = (SQPE*COSTH - S - SM*DM) / TWO
              UU   = - S - TT
              TMG  = TT+MR2(ID1)-MG2
              AF   = AFAC*PF/TMG/TMG
c             ~ ~
c     q q' -> q q'
c              R R
              ASTURR(ID1,ID2) = AF*MG2*S
              ASTURR(ID2,ID1) = ASTURR(ID1,ID2)
c       _     ~ ~*
c     q q' -> q q'
c              R R
              AUTSRR(ID1,ID2) = AF*SQPE**2*SN2TH
              AUTSRR(ID2,ID1) = AUTSRR(ID1,ID2)
            ELSE
              ASTURR(ID1,ID2) = ZERO
              ASTURR(ID2,ID1) = ZERO
              AUTSRR(ID1,ID2) = ZERO
              AUTSRR(ID2,ID1) = ZERO
            END IF
            IQ1  = SSL + ID1
            IQ2  = SSR + ID2
            SM   = RMASS(IQ1)+RMASS(IQ2)
            QPE  = S - SM**2
            IF (QPE.GE.ZERO) THEN
              DM   = RMASS(IQ1)-RMASS(IQ2)
              SQPE = SQRT( QPE*(S-DM**2) )
              PF   = SQPE/S
              TT   = (SQPE*COSTH - S - SM*DM) / TWO
              UU   = - S - TT
              TMG  = TT+ML2(ID1)-MG2
              AF   = AFAC*PF/TMG/TMG
c             ~ ~
c     q q' -> q q'
c              L R
              ASTULR(ID1,ID2) = AF*SQPE**2*SN2TH
              ASTULR(ID2,ID1) = ASTULR(ID1,ID2)
c       _     ~ ~*
c     q q' -> q q'
c              L R
              AUTSLR(ID1,ID2) = AF*MG2*S
              AUTSLR(ID2,ID1) = AUTSLR(ID1,ID2)
              TT   = (SQPE*COSTH - S + SM*DM) / TWO
              UU   = - S - TT
              TMG    = TT+MR2(ID1)-MG2
              AF   = AFAC*PF/TMG/TMG
c             ~ ~
c     q q' -> q q'
c              R L
              ASTURL(ID1,ID2) = AF*SQPE**2*SN2TH
              ASTURL(ID2,ID1) = ASTULR(ID1,ID2)
c       _     ~ ~*
c     q q' -> q q'
c              R L
              AUTSRL(ID1,ID2) = AF*MG2*S
              AUTSRL(ID2,ID1) = AUTSLR(ID1,ID2)
            ELSE
              ASTULR(ID1,ID2) = ZERO
              ASTULR(ID2,ID1) = ZERO
              AUTSLR(ID1,ID2) = ZERO
              AUTSLR(ID2,ID1) = ZERO
              ASTURL(ID1,ID2) = ZERO
              ASTURL(ID2,ID1) = ZERO
              AUTSRL(ID1,ID2) = ZERO
              AUTSRL(ID2,ID1) = ZERO
            END IF
   12     CONTINUE
   11   CONTINUE
      END IF
      HCS = ZERO
      DO 6 ID1 = 1, 13
      IF (DISF(ID1,1).LT.EPS) GOTO 6
      DO 5 ID2 = 1, 13
      IF (DISF(ID2,2).LT.EPS) GOTO 5
      DIST = DISF(ID1,1)*DISF(ID2,2)

      IF (ID1.LT.7) THEN
       IQ1 = ID1
       IF (ID2.LT.7) THEN
        IQ2 = ID2
        IF (IQ1.NE.IQ2) THEN
c        ~ ~
c qq' -> q q'
         HCS = HCS + ASTULL(IQ1,IQ2)*DIST
         IF (GENEV.AND.HCS.GT.RCS) CALL HWHSSS(IQ1,0,IQ2,0,3421,10,*9)
         HCS = HCS + ASTURR(IQ1,IQ2)*DIST
         IF (GENEV.AND.HCS.GT.RCS) CALL HWHSSS(IQ1,2,IQ2,2,3421,10,*9)
         HCS = HCS + ASTULR(IQ1,IQ2)*DIST
         IF (GENEV.AND.HCS.GT.RCS) CALL HWHSSS(IQ1,0,IQ2,2,3421,10,*9)
         HCS = HCS + ASTURL(IQ1,IQ2)*DIST
         IF (GENEV.AND.HCS.GT.RCS) CALL HWHSSS(IQ1,2,IQ2,0,3421,10,*9)
        ELSE
c        ~ ~
c qq  -> q q
         HCS = HCS +     BSTULL(IQ1)*DIST
         IF (GENEV.AND.HCS.GT.RCS) CALL HWHSSS(IQ1,0,IQ2,0,3421,10,*9)
         HCS = HCS +     BSTURR(IQ1)*DIST
         IF (GENEV.AND.HCS.GT.RCS) CALL HWHSSS(IQ1,2,IQ2,2,3421,10,*9)
         HCS = HCS +     BSTULR(IQ1)*DIST
         IF (GENEV.AND.HCS.GT.RCS) CALL HWHSSS(IQ1,0,IQ2,2,3421,10,*9)
         HCS = HCS +     BSTURL(IQ1)*DIST
         IF (GENEV.AND.HCS.GT.RCS) CALL HWHSSS(IQ1,2,IQ2,0,3421,10,*9)
         HCS = HCS +     BSUTLL(IQ1)*DIST
         IF (GENEV.AND.HCS.GT.RCS) CALL HWHSSS(IQ1,0,IQ2,0,4312,10,*9)
         HCS = HCS +     BSUTRR(IQ1)*DIST
         IF (GENEV.AND.HCS.GT.RCS) CALL HWHSSS(IQ1,2,IQ2,2,4312,10,*9)
         HCS = HCS +     BSUTLR(IQ1)*DIST
         IF (GENEV.AND.HCS.GT.RCS) CALL HWHSSS(IQ1,0,IQ2,2,4312,10,*9)
         HCS = HCS +     BSUTRL(IQ1)*DIST
         IF (GENEV.AND.HCS.GT.RCS) CALL HWHSSS(IQ1,2,IQ2,0,4312,10,*9)
        END IF
       ELSEIF (ID2.NE.13) THEN
        IQ2 = ID2-6
        IF (IQ1.NE.IQ2) THEN
c  _     ~ ~*
c qq' -> q q'
         HCS = HCS + AUTSLL(IQ1,IQ2)*DIST
         IF (GENEV.AND.HCS.GT.RCS) CALL HWHSSS(IQ1,0,IQ2,1,3142,10,*9)
         HCS = HCS + AUTSRR(IQ1,IQ2)*DIST
         IF (GENEV.AND.HCS.GT.RCS) CALL HWHSSS(IQ1,2,IQ2,3,3142,10,*9)
         HCS = HCS + AUTSLR(IQ1,IQ2)*DIST
         IF (GENEV.AND.HCS.GT.RCS) CALL HWHSSS(IQ1,0,IQ2,3,3142,10,*9)
         HCS = HCS + AUTSRL(IQ1,IQ2)*DIST
         IF (GENEV.AND.HCS.GT.RCS) CALL HWHSSS(IQ1,2,IQ2,1,3142,10,*9)
        ELSE
c  _     ~ ~*
c qq  -> q'q'   (q =/= q')
         DO 30 IQ = 1, 6
         IF (IQ .EQ.IQ1) GOTO 30
         HCS = HCS +     AUSTLL(IQ )*DIST
         IF (GENEV.AND.HCS.GT.RCS) CALL HWHSSS(IQ ,0,IQ ,1,2413,10,*9)
         HCS = HCS +     AUSTRR(IQ )*DIST
         IF (GENEV.AND.HCS.GT.RCS) CALL HWHSSS(IQ ,2,IQ ,3,2413,10,*9)
  30     CONTINUE
c  _     ~ ~*
c qq  -> q q
         HCS = HCS +     BUTSLL(IQ1)*DIST
         IF (GENEV.AND.HCS.GT.RCS) CALL HWHSSS(IQ1,0,IQ2,1,3142,10,*9)
         HCS = HCS +     BUTSRR(IQ1)*DIST
         IF (GENEV.AND.HCS.GT.RCS) CALL HWHSSS(IQ1,2,IQ2,3,3142,10,*9)
         HCS = HCS +     BUTSLR(IQ1)*DIST
         IF (GENEV.AND.HCS.GT.RCS) CALL HWHSSS(IQ1,0,IQ2,3,3142,10,*9)
         HCS = HCS +     BUTSRL(IQ1)*DIST
         IF (GENEV.AND.HCS.GT.RCS) CALL HWHSSS(IQ1,2,IQ2,1,3142,10,*9)
         HCS = HCS +     BUSTLL(IQ1)*DIST
         IF (GENEV.AND.HCS.GT.RCS) CALL HWHSSS(IQ1,0,IQ2,1,2413,10,*9)
         HCS = HCS +     BUSTRR(IQ1)*DIST
         IF (GENEV.AND.HCS.GT.RCS) CALL HWHSSS(IQ1,2,IQ2,3,2413,10,*9)
         HCS = HCS +     BUSTLR(IQ1)*DIST
         IF (GENEV.AND.HCS.GT.RCS) CALL HWHSSS(IQ1,0,IQ2,3,2413,10,*9)
         HCS = HCS +     BUSTRL(IQ1)*DIST
         IF (GENEV.AND.HCS.GT.RCS) CALL HWHSSS(IQ1,2,IQ2,1,2413,10,*9)
         IQ  = IGL
c  _     ~ ~
c qq  -> g g
         HCS = HCS +       CSTU(IQ1)*DIST
         IF (GENEV.AND.HCS.GT.RCS) CALL HWHSSS(IQ ,0,IQ ,0,2413,10,*9)
         HCS = HCS +       CSUT(IQ1)*DIST
         IF (GENEV.AND.HCS.GT.RCS) CALL HWHSSS(IQ ,0,IQ ,0,2341,10,*9)
        END IF
       ELSE
         IQ2 = IGL
c        ~ ~
c qg  -> q g
         HCS = HCS +      CTSUL(IQ1)*DIST
         IF (GENEV.AND.HCS.GT.RCS) CALL HWHSSS(IQ1,0,IQ2,0,3142,10,*9)
         HCS = HCS +      CTSUR(IQ1)*DIST
         IF (GENEV.AND.HCS.GT.RCS) CALL HWHSSS(IQ1,2,IQ2,0,3142,10,*9)
         HCS = HCS +      CTUSL(IQ1)*DIST
         IF (GENEV.AND.HCS.GT.RCS) CALL HWHSSS(IQ1,0,IQ2,0,3421,10,*9)
         HCS = HCS +      CTUSR(IQ1)*DIST
         IF (GENEV.AND.HCS.GT.RCS) CALL HWHSSS(IQ1,2,IQ2,0,3421,10,*9)
       END IF
      ELSEIF (ID1.NE.13) THEN
       IQ1 = ID1 - 6
       IF (ID2.LT.7) THEN
        IQ2 = ID2
        IF (IQ1.NE.IQ2) THEN
c _      ~*~
c qq' -> q q'
         HCS = HCS + AUTSLL(IQ1,IQ2)*DIST
         IF (GENEV.AND.HCS.GT.RCS) CALL HWHSSS(IQ1,1,IQ2,0,2413,10,*9)
         HCS = HCS + AUTSRR(IQ1,IQ2)*DIST
         IF (GENEV.AND.HCS.GT.RCS) CALL HWHSSS(IQ1,3,IQ2,2,2413,10,*9)
         HCS = HCS + AUTSLR(IQ1,IQ2)*DIST
         IF (GENEV.AND.HCS.GT.RCS) CALL HWHSSS(IQ1,1,IQ2,2,2413,10,*9)
         HCS = HCS + AUTSRL(IQ1,IQ2)*DIST
         IF (GENEV.AND.HCS.GT.RCS) CALL HWHSSS(IQ1,3,IQ2,0,2413,10,*9)
        ELSE
c _      ~*~
c qq  -> q'q'   (q =/= q')
         DO 31 IQ = 1, 6
         IF (IQ .EQ.IQ1) GOTO 31
         HCS = HCS +      AUSTLL(IQ)*DIST
         IF (GENEV.AND.HCS.GT.RCS) CALL HWHSSS(IQ ,1,IQ ,0,3142,10,*9)
         HCS = HCS +      AUSTRR(IQ)*DIST
         IF (GENEV.AND.HCS.GT.RCS) CALL HWHSSS(IQ ,3,IQ ,2,3142,10,*9)
   31    CONTINUE
c _      ~*~
c qq  -> q q
         HCS = HCS +     BUTSLL(IQ1)*DIST
         IF (GENEV.AND.HCS.GT.RCS) CALL HWHSSS(IQ1,1,IQ2,0,2413,10,*9)
         HCS = HCS +     BUTSRR(IQ1)*DIST
         IF (GENEV.AND.HCS.GT.RCS) CALL HWHSSS(IQ1,3,IQ2,2,2413,10,*9)
         HCS = HCS +     BUTSLR(IQ1)*DIST
         IF (GENEV.AND.HCS.GT.RCS) CALL HWHSSS(IQ1,1,IQ2,2,2413,10,*9)
         HCS = HCS +     BUTSRL(IQ1)*DIST
         IF (GENEV.AND.HCS.GT.RCS) CALL HWHSSS(IQ1,3,IQ2,0,2413,10,*9)
         HCS = HCS +     BUSTLL(IQ1)*DIST
         IF (GENEV.AND.HCS.GT.RCS) CALL HWHSSS(IQ1,1,IQ2,0,3142,10,*9)
         HCS = HCS +     BUSTRR(IQ1)*DIST
         IF (GENEV.AND.HCS.GT.RCS) CALL HWHSSS(IQ1,3,IQ2,2,3142,10,*9)
         HCS = HCS +     BUSTLR(IQ1)*DIST
         IF (GENEV.AND.HCS.GT.RCS) CALL HWHSSS(IQ1,1,IQ2,2,3142,10,*9)
         HCS = HCS +     BUSTRL(IQ1)*DIST
         IF (GENEV.AND.HCS.GT.RCS) CALL HWHSSS(IQ1,3,IQ2,0,3142,10,*9)
c _      ~ ~
c qq  -> g g
         HCS = HCS +       CSTU(IQ1)*DIST
         IF (GENEV.AND.HCS.GT.RCS) CALL HWHSSS(IGL,0,IGL,0,3142,10,*9)
         HCS = HCS +       CSUT(IQ1)*DIST
         IF (GENEV.AND.HCS.GT.RCS) CALL HWHSSS(IGL,0,IGL,0,4123,10,*9)
        END IF
       ELSEIF (ID2.NE.13) THEN
        IQ2 = ID2 - 6
        IF (IQ1.NE.IQ2) THEN
c __     ~*~*
c qq' -> q q'
         HCS = HCS + ASTULL(IQ1,IQ2)*DIST
         IF (GENEV.AND.HCS.GT.RCS) CALL HWHSSS(IQ1,1,IQ2,1,4312,10,*9)
         HCS = HCS + ASTURR(IQ1,IQ2)*DIST
         IF (GENEV.AND.HCS.GT.RCS) CALL HWHSSS(IQ1,3,IQ2,3,4312,10,*9)
         HCS = HCS + ASTULR(IQ1,IQ2)*DIST
         IF (GENEV.AND.HCS.GT.RCS) CALL HWHSSS(IQ1,1,IQ2,3,4312,10,*9)
         HCS = HCS + ASTURL(IQ1,IQ2)*DIST
         IF (GENEV.AND.HCS.GT.RCS) CALL HWHSSS(IQ1,3,IQ2,1,4312,10,*9)
        ELSE
c __     ~*~*
c qq  -> q q
         HCS = HCS +     BSTULL(IQ1)*DIST
         IF (GENEV.AND.HCS.GT.RCS) CALL HWHSSS(IQ1,1,IQ2,1,4312,10,*9)
         HCS = HCS +     BSTURR(IQ1)*DIST
         IF (GENEV.AND.HCS.GT.RCS) CALL HWHSSS(IQ1,3,IQ2,3,4312,10,*9)
         HCS = HCS +     BSTULR(IQ1)*DIST
         IF (GENEV.AND.HCS.GT.RCS) CALL HWHSSS(IQ1,1,IQ2,3,4312,10,*9)
         HCS = HCS +     BSTURL(IQ1)*DIST
         IF (GENEV.AND.HCS.GT.RCS) CALL HWHSSS(IQ1,3,IQ2,1,4312,10,*9)
         HCS = HCS +     BSUTLL(IQ1)*DIST
         IF (GENEV.AND.HCS.GT.RCS) CALL HWHSSS(IQ1,1,IQ2,1,3421,10,*9)
         HCS = HCS +     BSUTRR(IQ1)*DIST
         IF (GENEV.AND.HCS.GT.RCS) CALL HWHSSS(IQ1,3,IQ2,3,3421,10,*9)
         HCS = HCS +     BSUTLR(IQ1)*DIST
         IF (GENEV.AND.HCS.GT.RCS) CALL HWHSSS(IQ1,1,IQ2,3,3421,10,*9)
         HCS = HCS +     BSUTRL(IQ1)*DIST
         IF (GENEV.AND.HCS.GT.RCS) CALL HWHSSS(IQ1,3,IQ2,1,3421,10,*9)
        END IF
       ELSE
         IQ2 = IGL
c _      ~*~
c qg  -> q g
         HCS = HCS +      CTSUL(IQ1)*DIST
         IF (GENEV.AND.HCS.GT.RCS) CALL HWHSSS(IQ1,1,IQ2,0,2413,10,*9)
         HCS = HCS +      CTSUR(IQ1)*DIST
         IF (GENEV.AND.HCS.GT.RCS) CALL HWHSSS(IQ1,3,IQ2,0,2413,10,*9)
         HCS = HCS +      CTUSL(IQ1)*DIST
         IF (GENEV.AND.HCS.GT.RCS) CALL HWHSSS(IQ1,1,IQ2,0,4312,10,*9)
         HCS = HCS +      CTUSR(IQ1)*DIST
         IF (GENEV.AND.HCS.GT.RCS) CALL HWHSSS(IQ1,3,IQ2,0,4312,10,*9)
       END IF
      ELSE
       IQ1 = IGL
       IF (ID2.LT.7) THEN
         IQ2 = ID2
c        ~ ~
c gq  -> g q
         HCS = HCS +      CTSUL(IQ2)*DIST
         IF (GENEV.AND.HCS.GT.RCS) CALL HWHSSS(IQ1,0,IQ2,0,2413,10,*9)
         HCS = HCS +      CTSUR(IQ2)*DIST
         IF (GENEV.AND.HCS.GT.RCS) CALL HWHSSS(IQ1,0,IQ2,2,2413,10,*9)
         HCS = HCS +      CTUSL(IQ2)*DIST
         IF (GENEV.AND.HCS.GT.RCS) CALL HWHSSS(IQ1,0,IQ2,0,3421,10,*9)
         HCS = HCS +      CTUSR(IQ2)*DIST
         IF (GENEV.AND.HCS.GT.RCS) CALL HWHSSS(IQ1,0,IQ2,2,3421,10,*9)
       ELSEIF (ID2.LT.13) THEN
         IQ2 = ID2 - 6
c  _     ~ ~*
c gq  -> g q
         HCS = HCS +      CTSUL(IQ2)*DIST
         IF (GENEV.AND.HCS.GT.RCS) CALL HWHSSS(IQ1,0,IQ2,1,3142,10,*9)
         HCS = HCS +      CTSUR(IQ2)*DIST
         IF (GENEV.AND.HCS.GT.RCS) CALL HWHSSS(IQ1,0,IQ2,3,3142,10,*9)
         HCS = HCS +      CTUSL(IQ2)*DIST
         IF (GENEV.AND.HCS.GT.RCS) CALL HWHSSS(IQ1,0,IQ2,1,4312,10,*9)
         HCS = HCS +      CTUSR(IQ2)*DIST
         IF (GENEV.AND.HCS.GT.RCS) CALL HWHSSS(IQ1,0,IQ2,3,4312,10,*9)
       ELSE
         IQ2 = IGL
c        ~ ~*
c gg  -> q q
         DO 32 IQ = 1, 6
         HCS = HCS +       CSTUL(IQ)*DIST
         IF (GENEV.AND.HCS.GT.RCS) CALL HWHSSS(IQ ,0,IQ ,1,2413,10,*9)
         HCS = HCS +       CSTUR(IQ)*DIST
         IF (GENEV.AND.HCS.GT.RCS) CALL HWHSSS(IQ ,2,IQ ,3,2413,10,*9)
         HCS = HCS +       CSUTL(IQ)*DIST
         IF (GENEV.AND.HCS.GT.RCS) CALL HWHSSS(IQ ,0,IQ ,1,4123,10,*9)
         HCS = HCS +       CSUTR(IQ)*DIST
         IF (GENEV.AND.HCS.GT.RCS) CALL HWHSSS(IQ ,2,IQ ,3,4123,10,*9)
   32    CONTINUE
c        ~ ~
c gg  -> g g
         HCS = HCS +            DTSU*DIST
         IF (GENEV.AND.HCS.GT.RCS) CALL HWHSSS(IQ1,0,IQ2,0,2341,10,*9)
         HCS = HCS +            DSTU*DIST
         IF (GENEV.AND.HCS.GT.RCS) CALL HWHSSS(IQ1,0,IQ2,0,3421,10,*9)
         HCS = HCS +            DUTS*DIST
         IF (GENEV.AND.HCS.GT.RCS) CALL HWHSSS(IQ1,0,IQ2,0,2413,10,*9)
       END IF
      END IF
    5 CONTINUE
    6 CONTINUE
      EVWGT = HCS
      RETURN
C---GENERATE EVENT
    9 IDN(1)=ID1
      IDN(2)=ID2
      IDCMF=15
      CALL HWETWO
      IF (AZSPIN) THEN
C Calculate coefficients for constructing spin density matrices
C Set to zero for now
        CALL HWVZRO(7,GCOEF)
      END IF
  999 END
CDECK  ID>, HWHSSP.
*CMZ :-        -25/06/99  20.33.45  by  Kosuke Odagiri
*-- Author :    Kosuke Odagiri & Bryan Webber
C-----------------------------------------------------------------------
      SUBROUTINE HWHSSP
C-----------------------------------------------------------------------
C     SUSY HARD 2 PARTON -> 2 SPARTON/GAUGINO/SLEPTON PROCESSES
C-----------------------------------------------------------------------
      INCLUDE 'HERWIG62.INC'
      DOUBLE PRECISION SAVWT(3),RANWT,HWRGEN,HWRUNI,Z1,Z2,ET,EJ,
     & QPE,S,T,U,KK,KK2,YJ1INF,YJ1SUP,YJ2INF,YJ2SUP,SVEMSC
      INTEGER ISP
      EXTERNAL HWRGEN,HWRUNI
      SAVE SAVWT,SVEMSC
      IF (.NOT.GENEV) THEN
        EVWGT=ZERO
        CALL HWRPOW(ET,EJ)
        KK = ET/PHEP(5,3)
        KK2=KK**2
        IF (KK.GE.ONE) RETURN
        YJ1INF = MAX( YJMIN, LOG((ONE-SQRT(ONE-KK2))/KK) )
        YJ1SUP = MIN( YJMAX, LOG((ONE+SQRT(ONE-KK2))/KK) )
        IF (YJ1INF.GE.YJ1SUP) RETURN
        Z1=EXP(HWRUNI(1,YJ1INF,YJ1SUP))
        YJ2INF = MAX( YJMIN, -LOG(TWO/KK-ONE/Z1) )
        YJ2SUP = MIN( YJMAX, LOG(TWO/KK-Z1) )
        IF (YJ2INF.GE.YJ2SUP) RETURN
        Z2=EXP(HWRUNI(2,YJ2INF,YJ2SUP))
        XX(1)=HALF*(Z1+Z2)*KK
        IF (XX(1).GE.ONE) RETURN
        XX(2)=XX(1)/(Z1*Z2)
        IF (XX(2).GE.ONE) RETURN
        S=XX(1)*XX(2)*PHEP(5,3)**2
        QPE=S-(TWO*RMMNSS)**2
        IF (QPE.LE.ZERO) RETURN
        COSTH=HALF*ET*(Z1-Z2)/SQRT(Z1*Z2*QPE)
        IF (ABS(COSTH).GT.ONE) RETURN
        T=-(ONE+Z2/Z1)*(HALF*ET)**2
        U=-S-T
C---SET EMSCA TO HEAVY HARD PROCESS SCALE
        SVEMSC = SQRT(TWO*S*T*U/(S*S+T*T+U*U))
        FACTSS = GEV2NB*HALF*PIFAC*EJ*ET/S**2
     &         * (YJ1SUP-YJ1INF)*(YJ2SUP-YJ2INF)
     &         * SQRT(S/QPE)
      ENDIF
      EMSCA=SVEMSC
      ISP=MOD(IPROC,100)
      IF (ISP.EQ.0) THEN
        IF (GENEV) THEN
          RANWT=SAVWT(3)*HWRGEN(0)
          IF (RANWT.LT.SAVWT(1)) THEN
            CALL HWHSSQ
          ELSEIF (RANWT.LT.SAVWT(2)) THEN
            CALL HWHSSG
          ELSE
            CALL HWHSSL
          ENDIF
        ELSE
          CALL HWHSSQ
          SAVWT(1)=EVWGT
          CALL HWHSSG
          SAVWT(2)=SAVWT(1)+EVWGT
          CALL HWHSSL
          SAVWT(3)=SAVWT(2)+EVWGT
          EVWGT=SAVWT(3)
        ENDIF
      ELSEIF (ISP.EQ.10) THEN
        CALL HWHSSQ
      ELSEIF (ISP.EQ.20) THEN
        CALL HWHSSG
      ELSEIF (ISP.EQ.30) THEN
        CALL HWHSSL
      ELSE
C---UNRECOGNIZED PROCESS
        CALL HWWARN('HWHSSP',500,*999)
      ENDIF
 999  END
CDECK  ID>, HWHSSS.
*CMZ :-        -18/05/99  20.33.45  by  Kosuke Odagiri
*-- Author :    Kosuke Odagiri
C-----------------------------------------------------------------------
      SUBROUTINE HWHSSS(ID3,R3,ID4,R4,IPERM,IHPR,*)
C-----------------------------------------------------------------------
C     IDENTIFIES HARD SUSY SUBPROCESS
C-----------------------------------------------------------------------
      INCLUDE 'HERWIG62.INC'
      INTEGER ID3, R3, ID4, R4, IPERM, IHPR, SSL
      PARAMETER (SSL = 400)
       IHPRO  = 3000 + IHPR
       IDN(3) = SSL + ID3 + R3*6
       IDN(4) = SSL + ID4 + R4*6
       ICO(1) = IPERM/1000
       ICO(2) = IPERM/100 - 10*ICO(1)
       ICO(3) = IPERM/10  - 10*(IPERM/100)
       ICO(4) = IPERM     - 10*(IPERM/10)
      RETURN 1
      END
CDECK  ID>, HWHV1J.
*CMZ :-        -18/05/99  14.37.45  by  Mike Seymour
*-- Author :    Mike Seymour
C-----------------------------------------------------------------------
      SUBROUTINE HWHV1J
C-----------------------------------------------------------------------
C   V + 1 JET PRODUCTION, WHERE V=W (IHPRO.LT.5) OR Z (IHPRO.GE.5).
C   USES CROSS-SECTIONS OF EHLQ FOR ANNIHILATION AND COMPTON SCATTERING
C   IHPRO=0 FOR BOTH, 1 FOR ANNIHILATION, AND 2 FOR COMPTON.
C-----------------------------------------------------------------------
      INCLUDE 'HERWIG62.INC'
      DOUBLE PRECISION HWRGEN,HWRUNI,DISFAC(2,12,2),EMV2,DISMAX,S,T,U,
     & SHAT,THAT,UHAT,Z,HWUALF,PT,EMT,GFACTR,SIGANN,SIGCOM(2),CSFAC,ET,
     & EJ,YMIN,YMAX,VYMIN,VYMAX,EMAX,CV,CA,BR,EMV,GAMV
      INTEGER HWRINT,IDINIT(2,12,2),ICOFLO(4,2),I,J,K,L,M,ID1,ID2,
     $     IDV,IDI,IDM
      EXTERNAL HWRINT
      SAVE DISFAC,SHAT,THAT,EMV,EMV2,IDV,IDI
C---IDINIT HOLDS THE INITIAL STATES FOR ANNIHILATION PROCESSES
      DATA IDINIT/1,8,2,7,3,10,4,9,5,12,6,11,1,10,2,9,3,8,4,7,5,12,6,11,
     $            1,7,2,8,3,9,4,10,5,11,6,12,1,7,2,8,3,9,4,10,5,11,6,12/
C---ICOFLO HOLDS THE COLOR FLOW FOR EACH PROCESS
C---DISFAC HOLDS THE DISTRIBUTION FUNCTION*CROSS-SECTION FOR EACH
C   POSSIBLE SUB-PROCESS.
C   INDEX1=INITIAL STATE PERMUTATION (1=AS IDINIT/QG;2=OPPOSITE/GQ),
C        2=QUARK (FOR ANNIHILATION, >6 IMPLIES CABIBBO ROTATED PAIR),
C        3=PROCESS (1=ANNIHILATION, 2=COMPTON)
      DATA ICOFLO,DISFAC/2,4,3,1,4,1,3,2,48*0./
      IF (GENEV) THEN
        DISMAX=0
        DO 110 I=1,2
        DO 110 J=1,12
        DO 110 K=1,2
 110      DISMAX=MAX(DISFAC(K,J,I),DISMAX)
 120    I=HWRINT(1,2)
        J=HWRINT(1,12)
        K=HWRINT(1,2)
        IF (HWRGEN(0)*DISMAX.GT.DISFAC(K,J,I)) GOTO 120
        IF (I.EQ.1) THEN
C---ANNIHILATION
          IDN(1)=IDINIT(K,J,IDI)
          IDN(2)=IDINIT(3-K,J,IDI)
          IDN(4)=13
        ELSE
C---COMPTON SCATTERING
          IDN(1)=J
          IDN(2)=13
          IF (IDV.EQ.200) THEN
            IDN(4)=J
          ELSE
            IF (J.EQ.5.OR.J.EQ.6.OR.J.GE.11.OR.HWRGEN(0).GT.SCABI) THEN
C---CHANGE QUARKS (1->2,2->1,3->4,4->3,...)
              IDN(4)=4*INT((J-1)/2)-J+3
            ELSE
C---CHANGE AND CABIBBO ROTATE QUARKS (1->4,2->3,3->2,...)
              IDN(4)=12*INT((J-1)/6)-J+5
            ENDIF
          ENDIF
          IF ((SQRT(EMV2)+RMASS(IDN(4)))**2.GT.SHAT) GOTO 120
          IF (K.EQ.2) THEN
C---SWAP INITIAL STATES
            IDN(3)=IDN(1)
            IDN(1)=IDN(2)
            IDN(2)=IDN(3)
          ENDIF
        ENDIF
        IF (IDV.EQ.200) THEN
          IDN(3)=200
        ELSE
C---W+ OR W-? USE CHARGE CONSERVATION TO WORK OUT
          IDN(3)=NINT(198.5-.1667*FLOAT(ICHRG(IDN(1))+ICHRG(IDN(2))))
        ENDIF
        M=K
        IF (I.EQ.2.AND.J.LE.6) M=3-K
        DO 130 L=1,4
 130      ICO(L)=ICOFLO(L,M)
        IDCMF=15
        COSTH=(SHAT+2*THAT-EMV2)/(SHAT-EMV2)
C---TRICK HWETWO INTO USING THE OFF-SHELL V MASS
        RMASS(IDN(3))=SQRT(EMV2)
        CALL HWETWO
        RMASS(IDN(3))=EMV
        RHOHEP(1,NHEP-1)=0.5
        RHOHEP(2,NHEP-1)=0.0
        RHOHEP(3,NHEP-1)=0.5
      ELSE
        EVWGT=0.
        IHPRO=MOD(IPROC,100)/10
        IF (IHPRO.LT.5) THEN
          IDV=198
          IDI=1
          IDM=10
          GAMV=GAMW
        ELSE
          IDV=200
          IDI=2
          IDM=6
          GAMV=GAMZ
          IHPRO=IHPRO-5
        ENDIF
        EMV=RMASS(IDV)
        EMV2=EMV*(EMV+GAMV*TAN(HWRUNI(0,-ONE-HALF,ONE+HALF)))
        IF (EMV2.LE.ZERO) RETURN
        CALL HWRPOW(ET,EJ)
        PT=0.5*ET
        EMT=SQRT(PT**2+EMV2)
        EMAX=0.5*(PHEP(5,3)+EMV2/PHEP(5,3))
        IF (EMAX.LE.EMT) RETURN
        VYMAX=0.5*LOG((EMAX+SQRT(EMAX**2-EMT**2))
     &              /(EMAX-SQRT(EMAX**2-EMT**2)))
        VYMIN=-VYMAX
        IF (VYMAX.LE.VYMIN) RETURN
        Z=EXP(HWRUNI(0,VYMIN,VYMAX))
        S= PHEP(5,3)**2
        T=-PHEP(5,3)*EMT/Z+EMV2
        U=-PHEP(5,3)*EMT*Z+EMV2
        XXMIN=-U/(S+T-EMV2)
        IF (XXMIN.LT.ZERO.OR.XXMIN.GT.ONE) RETURN
        YMIN=MAX(LOG((XXMIN*PHEP(5,3)-EMT*Z)/PT),YJMIN)
        YMAX=MIN(LOG((PHEP(5,3)-EMT*Z)/PT),YJMAX)
        IF (YMAX.LE.YMIN) RETURN
        XX(1)=(Z*EMT+EXP(HWRUNI(2,YMIN,YMAX))*PT)/PHEP(5,3)
        IF (XX(1).LE.ZERO.OR.XX(1).GT.ONE) RETURN
        THAT =XX(1)*T+(1.-XX(1))*EMV2
        XX(2)=-THAT / (XX(1)*S+U-EMV2)
        IF (XX(2).LT.ZERO.OR.XX(2).GT.ONE) RETURN
        UHAT =XX(2)*U+(1.-XX(2))*EMV2
        SHAT =XX(1)*XX(2)*S
        EMSCA=EMT
        CALL HWSGEN(.FALSE.)
        GFACTR=GEV2NB*2.*PIFAC*ALPHEM*HWUALF(1,EMSCA)/(9.*SWEIN)
        SIGANN=GFACTR*((THAT-EMV2)**2+(UHAT-EMV2)**2)
     &               /(SHAT**2*THAT*UHAT)
        SIGCOM(2)=.375*GFACTR*(SHAT**2+UHAT**2+2*EMV2*THAT)
     &                       /(-UHAT*SHAT**3)
        SIGCOM(1)=.375*GFACTR*(SHAT**2+THAT**2+2*EMV2*UHAT)
     &                       /(-THAT*SHAT**3)
C---IF USER SPECIFIED A SUB-PROCESS, ZERO THE OTHER
        IF (IHPRO.EQ.1) THEN
          SIGCOM(1)=0.
          SIGCOM(2)=0.
        ENDIF
        IF (IHPRO.EQ.2) SIGANN=0.
        DO 210 I=1,IDM
          IF (IDV.EQ.200) THEN
            J=I
            IF(I.GT.6) J=I-6
            DISFAC(1,I,1)=4*SWEIN*(VFCH(J,1)**2+AFCH(J,1)**2)
          ELSE
            IF (I.LE.4) THEN
              DISFAC(1,I,1)=1-SCABI
            ELSEIF (I.GE.7) THEN
              DISFAC(1,I,1)=SCABI
            ELSE
              DISFAC(1,I,1)=1.
            ENDIF
          ENDIF
          DISFAC(2,I,1)=DISFAC(1,I,1) *
     &         SIGANN*DISF(IDINIT(1,I,IDI),2)*DISF(IDINIT(2,I,IDI),1)
          DISFAC(1,I,1)=DISFAC(1,I,1) *
     &         SIGANN*DISF(IDINIT(1,I,IDI),1)*DISF(IDINIT(2,I,IDI),2)
 210    CONTINUE
        DO 211 I=IDM+1,12
          DISFAC(1,I,1)=0
          DISFAC(2,I,1)=0
 211    CONTINUE
        DO 220 I=1,12
          IF (IDV.EQ.200) THEN
            J=I
            IF(I.GT.6) J=I-6
            DISFAC(1,I,2)=4*SWEIN*(VFCH(J,1)**2+AFCH(J,1)**2)
          ELSE
            DISFAC(1,I,2)=1.
          ENDIF
          DISFAC(2,I,2)=DISFAC(1,I,2)*SIGCOM(2)*DISF(I,2)*DISF(13,1)
          DISFAC(1,I,2)=DISFAC(1,I,2)*SIGCOM(1)*DISF(I,1)*DISF(13,2)
 220    CONTINUE
        DO 230 I=1,2
        DO 230 J=1,12
        DO 230 K=1,2
 230      EVWGT=EVWGT+DISFAC(K,J,I)
        CSFAC=PT*EJ*(YMAX-YMIN)*(VYMAX-VYMIN)*THREE/PIFAC
C---INCLUDE BRANCHING RATIO OF V
        CALL HWDBOZ(IDV,ID1,ID2,CV,CA,BR,0)
        EVWGT=EVWGT*CSFAC*BR
      ENDIF
 999  END
CDECK  ID>, HWHWEX.
*CMZ :-        -26/04/91  14.55.45  by  Federico Carminati
*-- Author :    Mike Seymour
C-----------------------------------------------------------------------
      SUBROUTINE HWHWEX
C-----------------------------------------------------------------------
C     TOP QUARK PRODUCTION VIA W EXCHANGE: MEAN EVWGT=TOP PROD C-S IN NB
C     C-S IS SUM OF:
C     UbarBbar, DBbar, DbarB, UB, CbarBbar, SBbar, SbarB, AND CB
C     UNLESS USER SPECIFIES OTHERWISE BY MOD(IPROC,100)=1-8 RESPECTIVELY
C---DSDCOS HOLDS THE CROSS-SECTIONS FOR THE PROCESSES LISTED ABOVE
C   (1-8) ARE WITH B FROM BEAM 1, (9-16) ARE WITH B FROM BEAM 2.
C-----------------------------------------------------------------------
      INCLUDE 'HERWIG62.INC'
      DOUBLE PRECISION HWRGEN,HWRUNI,DSDCOS(16),EMT2,EMT,EMW2,EMW,
     & CMFMIN,TAUMIN,TAUMLN,S,T,U,ROOTS,DSMAX
      INTEGER HWRINT,IDHWEX(2,16),I
      EXTERNAL HWRGEN,HWRUNI,HWRINT
      SAVE DSDCOS,DSMAX
      EQUIVALENCE (EMW,RMASS(198)),(EMT,RMASS(6))
C---IDHWEX HOLDS THE IDs OF THE INCOMING PARTICLES FOR EACH SUB-PROCESS
      DATA IDHWEX/11,8,11,1,5,7,5,2,11,10,11,3,5,9,5,4,
     &            8,11,1,11,7,5,2,5,10,11,3,11,9,5,4,5/
      EMT2=EMT**2
      EMW2=EMW**2
      IF (GENEV) THEN
 300    IHPRO=HWRINT(1,16)
        IF (HWRGEN(0).GT.DSDCOS(IHPRO)/DSMAX) GOTO 300
        DO 10 I=1,2
          IDN(I)=IDHWEX(I,IHPRO)
          IF (IDN(I).EQ.5 .OR. IDN(I).EQ.11) THEN
C---CHANGE B QUARK INTO T QUARK
            IDN(I+2)=IDN(I)+1
          ELSEIF (HWRGEN(0).GT.SCABI) THEN
C---CHANGE QUARKS (1->2,2->1,3->4,4->3,7->8,8->7,...)
            IDN(I+2)=4*INT((IDN(I)-1)/2)-IDN(I)+3
          ELSE
C---CHANGE AND CABIBBO ROTATE QUARKS (1->4,2->3,3->2,4->1,7->10,...)
            IDN(I+2)=12*INT((IDN(I)-1)/6)-IDN(I)+5
          ENDIF
          ICO(I)=I+2
          ICO(I+2)=I
 10     CONTINUE
        IDCMF=15
        CALL HWETWO
      ELSE
        EVWGT=0.
        CMFMIN=EMT
        TAUMIN=(CMFMIN/PHEP(5,3))**2
        TAUMLN=LOG(TAUMIN)
        ROOTS=PHEP(5,3)*SQRT(EXP(HWRUNI(0,ZERO,TAUMLN)))
        XXMIN=(ROOTS/PHEP(5,3))**2
        XLMIN=LOG(XXMIN)
        COSTH=HWRUNI(0,-ONE, ONE)
        S=ROOTS**2
        T=-0.5*S*(1-COSTH)
        U=-0.5*S*(1+COSTH)
        EMSCA=SQRT(2*S*T*U/(S*S+T*T+U*U))
        DSDCOS(1)=GEV2NB*PIFAC*.125*(ALPHEM/SWEIN)**2
     &           *(S-EMT2)**2 / S / (EMW2 + 0.5*(S-EMT2)*(1-COSTH))**2
        DSDCOS(2)=DSDCOS(1) / 4
     &    * (1 + EMT2/S + 2*COSTH + (1-EMT2/S)*COSTH**2)
        DSDCOS(3)=DSDCOS(2)
        DSDCOS(4)=DSDCOS(1)
C---IF USER SPECIFIED SUB-PROCESS THEN ZERO ALL THE OTHERS
        IHPRO=MOD(IPROC,100)
        IF (IHPRO.GT.8) THEN
          CALL HWWARN('HWHWEX',1,*999)
          IHPRO=0
        ENDIF
        DO 100 I=1,8
          IF (I.LE.4) DSDCOS(I+4)=DSDCOS(I)
          IF (IHPRO.NE.0 .AND. IHPRO.NE.I) DSDCOS(I)=0
          DSDCOS(I+8)=DSDCOS(I)
 100    CONTINUE
        CALL HWSGEN(.TRUE.)
        DSMAX=0
        DO 200 I=1,16
          DSDCOS(I)=DSDCOS(I)*DISF(IDHWEX(1,I),1)*DISF(IDHWEX(2,I),2)
          EVWGT=EVWGT + 2*TAUMLN*XLMIN*DSDCOS(I)
          IF (DSDCOS(I).GT.DSMAX) DSMAX=DSDCOS(I)
 200    CONTINUE
      ENDIF
 999  END
CDECK  ID>, HWHWPR.
*CMZ :-        -18/05/99  14.22.13  by  Mike Seymour
*-- Author :    Bryan Webber
C-----------------------------------------------------------------------
      SUBROUTINE HWHWPR
C-----------------------------------------------------------------------
C     W+/- PRODUCTION AND DECAY VIA DRELL-YAN PROCESS
C     MEAN EVWGT IS SIG(W+/-)*(BRANCHING FRACTION) IN NB
C-----------------------------------------------------------------------
      INCLUDE 'HERWIG62.INC'
      DOUBLE PRECISION HWRGEN,HWRUNI,HWUPCM,PRAN,PROB,COEF,CSFAC,EMW,
     & FTQK,PTOP,ETOP,EBOT,PMAX,FHAD,FTOT,BRAF,FLEP,TMIN,HWUAEM
      INTEGER HWRINT,ICH,IC,IL,ID,IDEC,JDEC,IWP(2,16)
      LOGICAL HWRLOG
      EXTERNAL HWRGEN,HWRUNI,HWUPCM,HWRINT,HWRLOG
      SAVE CSFAC,IDEC,FLEP,FTQK,ETOP,PTOP,EBOT,PMAX,PROB
      DATA IWP/2,7,1,8,7,2,8,1,4,9,3,10,9,4,10,3,
     &         2,9,3,8,9,2,8,3,4,7,1,10,7,4,10,1/
      IF (GENEV) THEN
C---GENERATE EVENT (X'S AND STRUCTURE FUNCTIONS ALREADY FOUND)
        PRAN=PROB*HWRGEN(0)
C---LOOP OVER PARTON FLAVOURS
        PROB=0.
        COEF=1.-SCABI
        DO 10 IC=1,16
          IF (IC.EQ.9) COEF=SCABI
          PROB=PROB+DISF(IWP(1,IC),1)*DISF(IWP(2,IC),2)*COEF
          IF (PROB.GE.PRAN) GOTO 20
   10   CONTINUE
C---STORE INCOMING PARTONS
   20   IDN(1)=IWP(1,IC)
        IDN(2)=IWP(2,IC)
        ICO(1)=2
        ICO(2)=1
C---ICH=1/2 FOR W+/-
        ICH=2-MOD(IC,2)
        IF ((IDEC.GT.49.AND.IDEC.LT.54).OR.
     &      (IDEC.EQ.99.AND.HWRLOG(FLEP))) THEN
C---LEPTONIC DECAY
          IL=IDEC-50
          IF (IL.EQ.0.OR.IL.GT.3) IL=HWRINT(1,3)
          IDN(3)=2*IL+121-ICH
          IDN(4)=2*IL+124+ICH
C---W DECAY ANGLE (1+COSTH)**2
          COSTH=2.*HWRGEN(1)**0.3333-1.
        ELSEIF (IDEC.EQ.5.OR.IDEC.EQ.6.OR.
     &        ((IDEC.EQ.0.OR.IDEC.EQ.99).AND.HWRLOG(FTQK))) THEN
C---W -> TOP + BOTTOM DECAY
          IDN(3)=7-ICH
          IDN(4)=10+ICH
   21     COSTH=HWRUNI(1,-ONE, ONE)
          IF ((ETOP+(PTOP*COSTH))*(EBOT+(PTOP*COSTH)).LT.
     &         PMAX*HWRGEN(1)) GOTO 21
        ELSE
C---OTHER HADRONIC DECAY
   25     PROB=0.
          PRAN=2.*HWRGEN(2)
          COEF=1.-SCABI
          DO 30 ID=ICH,16,4
            IF (ID.GT.8) COEF=SCABI
            PROB=PROB+COEF
            IF (PROB.GE.PRAN) THEN
              IDN(3)=IWP(1,ID)
              IDN(4)=IWP(2,ID)
              GOTO 40
            ENDIF
   30     CONTINUE
   40     CONTINUE
          IF (IDEC.GT.0.AND.IDEC.LT.5) THEN
            JDEC=IDEC+6
            IF (IDN(3).NE.IDEC.AND.IDN(4).NE.IDEC
     &     .AND.IDN(3).NE.JDEC.AND.IDN(4).NE.JDEC) GOTO 25
          ENDIF
          COSTH=2.*HWRGEN(1)**0.3333-1.
        ENDIF
        IDCMF=197+ICH
        IF (IDN(1).GT.6) COSTH=-COSTH
        ICO(3)=4
        ICO(4)=3
        CALL HWETWO
      ELSE
        IDEC=MOD(IPROC,100)
        IF (IDEC.EQ.5.OR.IDEC.EQ.6) THEN
          TMIN=ATAN((RMASS(6)**2-RMASS(199)**2)/(GAMW*RMASS(199)))
        ELSE
          TMIN=-ATAN(RMASS(199)/GAMW)
        ENDIF
        EVWGT=0.
        EMW=GAMW*TAN(HWRUNI(0,TMIN,PIFAC/2.))+RMASS(199)
        IF (EMW.LE.ZERO) RETURN
        EMW=SQRT(EMW*RMASS(199))
        IF (EMW.LE.QSPAC.OR.EMW.GE.PHEP(5,3)) RETURN
        EMSCA=EMW
        IF (EMLST.NE.EMW) THEN
          EMLST=EMW
          XXMIN=(EMW/PHEP(5,3))**2
          XLMIN=LOG(XXMIN)
          CSFAC=-GEV2NB*PIFAC**2*HWUAEM(EMSCA**2)
     &          /(3.*SWEIN*RMASS(199)**2)*XLMIN
C---COMPUTE TOP AND LEPTONIC FRACTIONS
          FTQK=0.
          IF (NFLAV.GT.5) THEN
            PTOP=HWUPCM(EMW,RMASS(5),RMASS(6))
            IF (PTOP.GT.ZERO) THEN
              ETOP=SQRT(PTOP**2+RMASS(6)**2)
              EBOT=EMW-ETOP
              FTQK=2.*PTOP*(3.*ETOP*EBOT+PTOP**2)/EMW**3
              PMAX=(ETOP+PTOP)*(EBOT+PTOP)
            ENDIF
          ENDIF
          FHAD=FTQK+2.
          FTOT=FTQK+3.
C---MULTIPLY WEIGHT BY BRANCHING FRACTION
          IF (IDEC.EQ.0) THEN
            BRAF=FHAD
          ELSEIF (IDEC.LT.5.OR.IDEC.EQ.50) THEN
            BRAF=1.
          ELSEIF (IDEC.LT.7) THEN
            BRAF=FTQK
          ELSEIF (IDEC.EQ.99) THEN
            BRAF=FTOT
          ELSE
            BRAF=1/THREE
          ENDIF
          CSFAC=CSFAC*BRAF/FTOT*(0.5-TMIN/PIFAC)
          FTQK=FTQK/FHAD
          FLEP=1./FTOT
        ENDIF
        CALL HWSGEN(.TRUE.)
C---LOOP OVER PARTON FLAVOURS
        PROB=0.
        COEF=1.-SCABI
        DO 100 IC=1,16
          IF (IC.EQ.9) COEF=SCABI
          PROB=PROB+DISF(IWP(1,IC),1)*DISF(IWP(2,IC),2)*COEF
  100   CONTINUE
        EVWGT=PROB*CSFAC
      ENDIF
  999 END
CDECK  ID>, HWIGIN.
*CMZ :-        -01/04/99  19.44.55  by  Mike Seymour
*-- Author :    Bryan Webber
C----------------------------------------------------------------------
      SUBROUTINE HWIGIN
C-----------------------------------------------------------------------
C     SETS INPUT PARAMETERS
C----------------------------------------------------------------------
      INCLUDE 'HERWIG62.INC'
      DOUBLE PRECISION FAC,ANGLE
      INTEGER I,J,N,L
      CHARACTER*28 TITLE
      DATA TITLE/'HERWIG 6.202   February 2001'/
      WRITE (6,10) TITLE
  10  FORMAT(//10X,A28//,
     &         10X,'Please reference:  G. Marchesini, B.R. Webber,',/,
     &         10X,'G.Abbiendi, I.G.Knowles, M.H.Seymour & L.Stanco',/,
     &         10X,'Computer Physics Communications 67 (1992) 465',/,
     &         10X,'                   and',/,
     &         10X,'G.Corcella, I.G.Knowles, G.Marchesini, S.Moretti,'
     & ,/,     10X,'K.Odagiri, P.Richardson, M.H.Seymour & B.R.Webber,'
     & ,/,     10X,'hep-ph/0011363')
C---PRINT OPTIONS:
C     IPRINT=0     NO PRINTOUT
C            1     PRINT SELECTED INPUT PARAMETERS
C            2     1 + TABLE OF PARTICLE CODES AND PROPERTIES
C            3     2 + TABLES OF SUDAKOV FORM FACTORS
      IPRINT=1
C Format for track numbers in event listing
C     PRNDEC=.TRUE.  use decimal
C            .FALSE. use hexadecimal
      PRNDEC=(NMXHEP.LE.9999)
C Number of significant figures to print out in event listing
C NPRFMT (< 2) compact 80 character stout and A4-long tex output,
C (= 2) 2 decimal places in stout, (> 2) - 5 decimal places in stout
      NPRFMT=1
C Print out vertex information
      PRVTX=.TRUE.
C Print out particle properties/event record to stout, tex or web
      PRNDEF=.TRUE.
      PRNTEX=.FALSE.
      PRNWEB=.FALSE.
C---MAX NO OF EVENTS TO PRINT
      MAXPR=1
C---UNIT FOR READING SUDAKOV FORM FACTORS (IF ZERO THEN COMPUTE THEM)
      LRSUD=0
C---UNIT FOR WRITING SUDAKOV FORM FACTORS (IF ZERO THEN NOT WRITTEN)
      LWSUD=77
C---UNIT FOR WRITING EVENT DATA IN HWANAL (IF ZERO THEN NOT WRITTEN)
      LWEVT=0
C---SEEDS FOR RANDOM NUMBER GENERATOR (CALLED HWRGEN)
      NRN(1)= 17673
      NRN(2)= 63565
C---AZIMUTHAL CORRELATIONS?
C   THESE INCLUDE SOFT GLUON (INSIDE CONE)
      AZSOFT=.TRUE.
C   AND NEAREST-NEIGHBOUR SPIN CORRELATIONS
      AZSPIN=.TRUE.
C---MATRIX-ELEMENT MATCHING FOR E+E-, DIS, DRELL-YAN AND TOP DECAY
C---HARD EMISSION
      HARDME=.TRUE.
C---SOFT EMISSION
      SOFTME=.TRUE.
C---GLUON ENERGY CUT FOR TOP DECAY CASE
      GCUTME=2
C Electromagnetic fine structure constant: Thomson limit
      ALPHEM=.0072993
C---QCD LAMBDA: CORRESPONDS TO 5-FLAVOUR LAMBDA-MS-BAR AT LARGE X ONLY
      QCDLAM=0.18
C---NUMBER OF COLOURS
      NCOLO=3
C---NUMBER OF FLAVOURS
      NFLAV=6
C---QUARK, GLUON AND PHOTON VIRTUAL MASS CUTOFFS IN
C   PARTON SHOWER (ADDED TO MASSES GIVEN BELOW)
      VQCUT=0.48
      VGCUT=0.10
      VPCUT=0.40
      ALPFAC=1
C---D,U,S,C,B,T QUARK AND GLUON MASSES (IN THAT ORDER)
      RMASS(1)=0.32
      RMASS(2)=0.32
      RMASS(3)=0.5
      RMASS(4)=1.55
      RMASS(5)=4.95
      RMASS(6)=174.3
      RMASS(13)=0.75
C---W+/- AND Z0 MASSES
      RMASS(198)=80.42
      RMASS(199)=80.42
      RMASS(200)=91.188
C---HIGGS BOSON MASS
      RMASS(201)=115.
C---WIDTHS OF W, Z, HIGGS
      GAMW=2.12
      GAMZ=2.495
      GAMH=0.02
C Include additional neutral, massive vector boson (Z')
      ZPRIME=.FALSE.
C Z' mass and width
      RMASS(202)=500.
      GAMZP=5.
C Graviton properties
C Graviton mass and width (default mass 1 TeV and calculated width)
      EMGRV  = 1000.0D0
      GAMGRV = ZERO
C Graviton coupling (this has dimensions of mass)
      GRVLAM = 10000.0D0
C Lepton (EPOLN) and anti-lepton (PPOLN) beam polarisations used in:
C e+e- --> ffbar/qqbar g; and l/lbar N DIS.
C Cpts. 1,2 Transverse polarisation; cpt. 3 longitudinal polarisation.
C Note require POLN(1)**2+POLN(2)**2+POLN(3)**2 < 1.
      DO 20 I=1,3
      EPOLN(I)=0.
  20  PPOLN(I)=0.
C-----------------------------------------------------------------------
C     Specify couplings of weak vector bosons to fermions:
C
C     electric current:      QFCH(I)*e*G_mu       (electric charge, e>0)
C     weak neutral current: [VFCH(I,J).1+AFCH(I,J).G_5]*e*G_mu
C     weak charged current: SQRT(VCKM(K,L)/2.)*g*(1+G_5)*G_mu
C
C     I= 1- 6: d,u,s,c,b,t (quarks)
C      =11-16: e,nu_e,mu,nu_mu,tau,nu_tau (leptons) (`I=IDHW-110')
C     J=1 for minimal SM:
C      =2 for Z' couplings (ZPRIME=.TRUE.)
C     K=1,2,3 for u,c,t;    L=1,2,3 for d,s,b
C-----------------------------------------------------------------------
C Minimal standard model neutral vector boson couplings
C VFCH(I,1)=(T3/2-Q*S^2_W)/(C_W*S_W);  AFCH(I,1)=T3/(2*C_W*S_W)
C sin**2 Weinberg angle (PDG '94)
      SWEIN=.2319
      FAC=1./SQRT(SWEIN*(1.-SWEIN))
      DO 30 I=1,3
C Down-type quarks
      J=2*I-1
      QFCH(J)=-1./3.
      VFCH(J,1)=(-0.25+SWEIN/3.)*FAC
      AFCH(J,1)= -0.25*FAC
C Up-type quarks
      J=2*I
      QFCH(J)=+2./3.
      VFCH(J,1)=(+0.25-2.*SWEIN/3.)*FAC
      AFCH(J,1)= +0.25*FAC
C Charged leptons
      J=2*I+9
      QFCH(J)=-1.
      VFCH(J,1)=(-0.25+SWEIN)*FAC
      AFCH(J,1)= -0.25*FAC
C Neutrinos
      J=2*I+10
      QFCH(J)=0.
      VFCH(J,1)=+0.25*FAC
      AFCH(J,1)=+0.25*FAC
  30  CONTINUE
C Additional Z' couplings (To be set by the user)
      IF (.NOT.ZPRIME) THEN
         DO 40 I=1,6
         AFCH(I,2)=0.
         AFCH(10+I,2)=0.
         VFCH(I,2)=0.
         VFCH(10+I,2)=0.
  40     CONTINUE
      ENDIF
C Cabibbo-Kobayashi-Maskawa matrix elements squared (PDG '92):
C sin**2 of Cabibbo angle
      SCABI=.0488
C u ---> d,s,b
      VCKM(1,1)=1.-SCABI
      VCKM(1,2)=SCABI
      VCKM(1,3)=0.0
C c ---> d,s,b
      VCKM(2,1)=SCABI
      VCKM(2,2)=1.-SCABI-.002
      VCKM(2,3)=0.002
C t ---> d,b,s
      VCKM(3,1)=0.0
      VCKM(3,2)=0.002
      VCKM(3,3)=0.998
C---GAUGE BOSON DECAYS
      DO 50 I=1,12
      BRHIG(I)=1.D0/12
      ENHANC(I)=1.D0
 50   IF (I.LE.MODMAX) MODBOS(I)=0
C
C THE iTH GAUGE BOSON DECAY PER EVENT IS CONTROLLED BY MODBOS AS FOLLOWS
C         MODBOS(i)     W DECAY        Z DECAY
C             0           all            all
C             1          qqbar          qqbar
C             2           enu            e+e-
C             3           munu          mu+mu-
C             4          taunu         tau+tau-
C             5        enu & munu      ee & mumu
C             6           all            nunu
C             7           all           bbbar
C            >7           all            all
C BOSON PAIRS (eg FROM HIGGS DECAY) ARE CHOSEN FROM MODBOS(i),MODBOS(i+1
C
C---CONTROL OF LARGE EMH BEHAVIOUR (SEE HWHIGM FOR DETAILS)
      IOPHIG=3
      GAMMAX=10.
C Specicify approximation used in HWHIGA
      IAPHIG=1
C---MASSES OF HYPOTHETICAL NEW QUARKS GO
C   INTO 209-214 (ANTIQUARKS IN 215-220)
C   ID = 209,210 ARE B',T' WITH DECAYS T'->B'->C
C        211,212 ARE B',T' WITH DECAYS T'->B'->T
C        215-218 ARE THEIR ANTIQUARKS
      RMASS(209)=200.
      RMASS(215)=200.
C---MAXIMUM CLUSTER MASS PARAMETERS
C   N.B. LIMIT FOR Q1-Q2BAR CLUSTER MASS
C   IS (CLMAX**CLPOW + (QM1+QM2)**CLPOW)**(1/CLPOW)
      CLMAX=3.35
      CLPOW=2.0
C   For PSPLT(I), CLDIR(I) & CLSMR(I): I=1 light u,d,s,c cluster
C                                       =2 heavy b cluster
C---MASS SPECTRUM OF PRODUCTS IN CLUSTER
C   SPLITTING ABOVE CLMAX - FLAT IN M**PSPLT(*)
      PSPLT(1)=1.0
      PSPLT(2)=PSPLT(1)
C---KINEMATIC TREATMENT OF CLUSTER DECAY
C   0=ISOTROPIC, 1=REMEMBER DIRECTION OF PERTURBATIVELY PRODUCED QUARKS
      CLDIR(1)=1
      CLDIR(2)=CLDIR(1)
C   IF CLDIR(*)=1, DO GAUSSIAN SMEARING OF DIRECTION:
C   ACTUALLY EXPONENTIAL IN 1-COS(THETA) WITH MEAN CLSMR(*)
      CLSMR(1)=0.0
      CLSMR(2)=CLSMR(1)
C---OPTION FOR TREATMENT OF REMNANT CLUSTERS:
C   0=BOTH CHILDREN ARE SOFT, (EQUIVALENT TO PREVIOUS VERSIONS)
C   1=REMNANT CHILD IS SOFT, BUT PERTURBATIVE CHILD IS NORMAL
      IOPREM=1
C---TREATMENT OF LOWER LIMIT FOR SPACELIKE EVOLUTION
C   0=EVOLUTION STOPS AT QSPAC, BUT STRUCT FUNS CAN GET CALLED AT
C   SMALLER SCALES IN FORCED EMISSION (EQUIVALENT TO V5.7 AND EARLIER)
C   1=EVOLUTION STOPS AT QSPAC, STRUCTURE FUNCTIONS FREEZE AT QSPAC
C   2=EVOLUTION CONTINUES TO INFRARED CUT, BUT S.F.S FREEZE AT QSPAC
      ISPAC=0
C---LOWER LIMIT FOR SPACELIKE EVOLUTION
      QSPAC=2.5
C---SWITCH OFF SPACE-LIKE SHOWERS
      NOSPAC=.FALSE.
C---INTRINSIC PT OF SPACELIKE PARTONS (RMS)
      PTRMS=0.0
C---MASS PARAMETER IN REMNANT FRAGMENTATION
      BTCLM=1.0
C---STRUCTURE FUNCTION SET:
C   SET MODPDF(I)=MODE AND AUTPDF='AUTHOR GROUP' TO USE CERN LIBRARY
C   PDFLIB PACKAGE FOR STRUCTURE FUNCTIONS IN BEAM I
      MODPDF(1)=-1
      MODPDF(2)=-1
      AUTPDF(1)='MRS'
      AUTPDF(2)='MRS'
C   OR SET MODPDF(I)=-1 TO USE BUILT-IN STRUCTURE FUNCTION SET:
C   1,2 FOR DUKE+OWENS SETS 1,2 (SOFT/HARD GLUE)
C   3,4 FOR EICHTEN+AL SETS 1,2 (NUCLEONS ONLY)
C    5  FOR OWENS      SET  1.1 (SOFT GLUE ONLY)
      NSTRU=4
C   PARAMETER FOR B CLUSTER DECAY TO 1 HADRON. IF MCL IS CLUSTER MASS
C   AND MTH IS THRESHOLD FOR 2-HADRON DECAY, THEN PROBABILITY IS
C   1 IF MCL<MTH, 0 IF MCL>(1+B1LIM)*MTH, WITH LINEAR INTERPOLATION,
      B1LIM=0.0
C---B DECAY PACKAGE ('HERW'=>HERWIG, 'EURO'=>EURODEC, 'CLEO'=>CLEO)
      BDECAY='HERW'
C---HARD SUBPROCESS SCALE TO BE USED IN 4-JET MATRIX ELEMENT OPTION
C   IF (FIX4JT) THEN SCALE=C.M. ENERGY
C   ELSE SCALE=2.*MIN(PI.PJ)
      FIX4JT=.FALSE.
C---HARD SUBPROCESS SCALE TO BE USED IN BOSON-GLUON FUSION
C   IF (BGSHAT) THEN SCALE=SHAT
C   ELSE SCALE=2.*SHAT*THAT*UHAT/(SHAT**2+THAT**2+UHAT**2)
      BGSHAT=.FALSE.
C---RECONSTRUCT DIS EVENTS IN BREIT FRAME
      BREIT=.TRUE.
C---TREAT ALL EVENTS IN THEIR CMF (ELSE USE LAB FRAME)
      USECMF=.TRUE.
C---TREAT W/Z DECAY IN ITS REST FRAME
      WZRFR=.TRUE.
C---PROBABILITY OF UNDERLYING SOFT EVENT:
      PRSOF=1.
C---SOFT UNDERLYING OR MIN BIAS EVENT PARAMETERS
C   DEFAULT VALUES ARE FROM UA5 COLLAB, NPB291(1987)445
C   NCH_PPBAR(SQRT(S)) = PMBN1*S**PMBN2+PMBN3
      PMBN1= 9.11
      PMBN2= 0.115
      PMBN3=-9.50
C   1/K (IN NEG BINOMIAL) = PMBK1*LN(S)+PMBK2
      PMBK1= 0.029
      PMBK2=-0.104
C   SOFT CLUSTER MASS SPECTRUM (M-M1-M2-PMBM1)*EXP(-PMBM2*M)
      PMBM1= 0.4
      PMBM2= 2.0
C   SOFT CLUSTER PT SPECTRUM PT*EXP(-B*SQRT(PT**2+M**2))
C   B=PMBP1 FOR D,U, PMBP2 FOR S,C, PMBP3 FOR DIQUARKS
      PMBP1= 5.2
      PMBP2= 3.0
      PMBP3= 5.2
C---MULTIPLICITY ENHANCEMENT FOR UNDERLYING SOFT EVENT:
C   NCH = NCH_PPBAR(ENSOF*SQRT(S))
      ENSOF=1.
C   PARAMETERS FOR MUELLER TANG FORMUA: IPROC=2400
C---THE VALUE TO USE FOR FIXED ALPHA_S IN DENOMINATOR
      ASFIXD=0.25
C---OMEGA0=12*LOG(2)*ALPHA_S/PI, BUT NOT NECESSARILY THE SAME ALPHA_S
      OMEGA0=0.3
C---MIN AND MAX JET RAPIDITIES IN QCD 2->2,
C   HEAVY FLAVOUR, SUSY AND DIRECT PHOTON PROCESSES
      YJMAX=8.
      YJMIN=-YJMAX
C---MIN AND MAX PARTON TRANSVERSE MOMENTUM
C   IN ELEMENTARY 2 -> 2 SUBPROCESSES
      PTMIN=1D1
      PTMAX=1D8
C---UPPER LIMIT ON HARD PROCESS SCALE
      QLIM=1D8
C---MAX PARTON THRUST IN 2->3 HARD PROCESSES
      THMAX=0.9
C   Set parameters for 2->4 hard process
C   Choose inter-jet metric (else JADE) and minimum y-cut
      DURHAM=.TRUE.
      Y4JT=0.01
C---TREATMENT OF COLOUR INTERFERENCE IN E+E- -> 4 JETS:
C     qqbar-gg case:
C     IOP4JT(1)=0 neglect, =1 extreme 2341; =2 extreme 3421
C     qqbar-qqbar (identical quark flavour) case:
C     IOP4JT(2)=0 neglect, =1 extreme 4123; =2 extreme 2143
      IOP4JT(1)=0
      IOP4JT(2)=0
C---MIN AND MAX DILEPTON INVARIANT MASS IN DRELL-YAN PROCESS
      EMMIN=0D0
      EMMAX=1D8
C---MIN AND MAX ABS(Q**2) IN DEEP INELASTIC LEPTON SCATTERING
      Q2MIN=0D0
      Q2MAX=1D10
C---MIN AND MAX ABS(Q**2) IN WEISZACKER-WILLIAMS APPROXIMATION
      Q2WWMN=0.
      Q2WWMX=4.
C---MIN AND MAX ENERGY FRACTION IN WEISZACKER-WILLIAMS APPROXIMATION
      YWWMIN=0.
      YWWMAX=1.
C---MINIMUM HADRONIC MASS FOR PHOTON-INDUCED PROCESSES (INCLUDING DIS)
      WHMIN=0.
C---IF PHOMAS IS NON-ZERO, PARTON DISTRIBUTION FUNCTIONS FOR OFF-SHELL
C   PHOTONS IS DAMPED, WITH MASS PARAMETER = PHOMAS
      PHOMAS=0.
C---MIN AND MAX FLAVOURS GENERATED BY IPROC=9100,9110,9130
      IFLMIN=1
      IFLMAX=5
C---MAX Z IN J/PSI PHOTO- AND ELECTRO- PRODUCTION
      ZJMAX=0.9
C---MIN AND MAX BJORKEN-Y
      YBMIN=0.
      YBMAX=1.
C---MAX COS(THETA) FOR W'S IN E+E- -> W+W-
      CTMAX=0.9999
C   Minimum virtuality^2 of partons to use in calculating distances
      VMIN2=0.1
C   Exageration factor for lifetimes of weakly decaying heavy particles
      EXAG=1.
C   Include colour rearrangement in cluster formation
      CLRECO=.FALSE.
C   Probability for colour rearrangement to occur
      PRECO=1./9.
C   Minimum lifetime for particle to be considered stable
      PLTCUT=1.D-8
C   Incude neutral B-meson mixing
      MIXING=.TRUE.
C   Set B_s and B_d mixing parameters: X=Delta m/Gamma
      XMIX(1)=10.0
      XMIX(2)=0.70
C   Y=Delta Gamma/2*Gamma
      YMIX(1)=0.2
      YMIX(2)=0.0
C   Include a cut on particle decay lengths
      MAXDKL=.FALSE.
C   Set option for decay length cut (see HWDXLM)
      IOPDKL=1
C   Radius for cylindrical option (mm) (IOPDKL=1)
      DXRCYL=20.0D0
C   Length for cylindrical option(IOPDKL=1)
      DXZMAX=500.0D0
C   Radius for spherical option(IOPDKL=2)
      DXRSPH=100.0D0
C   Smear the primary interaction vertex: see HWRPIP for details
      PIPSMR=.FALSE.
C   Widths of Gaussian smearing in x,y,z (mm)
      VIPWID(1)=0.25D0
      VIPWID(2)=0.015D0
      VIPWID(3)=1.8D0
      DO 60 I=0,NMXRES
C   Veto cluster decays into particle type I
      VTOCDK(I)=.FALSE.
C   Veto unstable particle decays into modes involving particle type I
  60  VTORDK(I)=.FALSE.
C   Veto f_0(980) and a_0(980) production in cluster decays
      VTOCDK(290)=.TRUE.
      VTOCDK(291)=.TRUE.
      VTOCDK(292)=.TRUE.
      VTOCDK(293)=.TRUE.
C---MINIMUM AND MAXIMUM S-HAT/S RANGE FOR PHOTON ISR
      TMNISR=1D-4
      ZMXISR=1-1D-6
C---COLISR IS .TRUE. TO MAKE ISR PHOTONS COLLINEAR WITH BEAMS
      COLISR=.FALSE.
C A Priori weights for mesons w.r.t. pionic n=1, 0-(+) states:
C old VECWT=REPWT(0,1,0) & TENWT=REPWT(0,2,0)
      DO 70 N=0,4
      DO 70 J=0,4
      DO 70 L=0,3
  70  REPWT(L,J,N)=1.
C and singlet (Lambda-like) and decuplet barons
      SNGWT=1.
      DECWT=1.
C---A PRIORI WEIGHTS FOR D,U,S,C,B,T QUARKS AND DIQUARKS (IN THAT ORDER)
      PWT(1)=1.
      PWT(2)=1.
      PWT(3)=1.
      PWT(4)=1.
      PWT(5)=1.
      PWT(6)=1.
      PWT(7)=1.
C   Octet-Singlet isoscalar mixing angles in degrees
C   (use ANGLE for ideal mixing, recommended for F0MIX & OMHMIX)
      ANGLE=ATAN(ONE/SQRT(TWO))*180./ACOS(-ONE)
C     eta - eta'
      ETAMIX=-23.
C     phi - omega
      PHIMIX=+36.
C     h_1(1380) - h_1(1170)
      H1MIX=ANGLE
C     MISSING - f_0(1370)
      F0MIX=ANGLE
C     f_1(1420) - f_1(1285)
      F1MIX=ANGLE
C     f'_2 - f_2
      F2MIX=+26.
C     MISSING - omega(1600)
      OMHMIX=ANGLE
C     eta_2(1645) - eta_2(1870)
      ET2MIX=ANGLE
C     phi_3 - omega_3
      PH3MIX=+28.
C---PARAMETERS FOR NON-PERTURBATIVE SPLITTING OF GLUONS INTO
C   DIQUARK-ANTIDIQUARK PAIRS:
C   SCALE AT WHICH GLUONS CAN BE SPLIT INTO DIQUARKS
C   (0.0 FOR NO SPLITTING)
      QDIQK=0.0
C   PROBABILITY (PER UNIT LOG SCALE) OF DIQUARK SPLITTING
      PDIQK=5.0
C---PARAMETERS FOR IMPORTANCE SAMPLING
C   ASSUME QCD 2->2 DSIG/DET FALLS LIKE ET**(-PTPOW)
C   WHERE ET=SQRT(MQ**2+PT**2) FOR HEAVY FLAVOURS
      PTPOW=4.
C   DEFAULT PTPOW=2 FOR SUSY PROCESSES
      IF (MOD(IPROC/100,100).EQ.30) PTPOW=2.
C   ASSUME DRELL-YAN DSIG/DEM FALLS LIKE EM**(-EMPOW)
      EMPOW=4.
C   ASSUME DEEP INELASTIC DSIG/DQ**2 FALLS LIKE (Q**2)**(-Q2POW)
      Q2POW=2.5
C---GENERATE UNWEIGHTED EVENTS (EVWGT=AVWGT)?
      NOWGT=.TRUE.
C---DEFAULT MEAN EVENT WEIGHT
      AVWGT=1.
C---ASSUMED MAXIMUM WEIGHT (ZERO TO RECOMPUTE)
      WGTMAX=0.
C---MINIMUM ACCEPTABLE EVENT GENERATION EFFICIENCY
      EFFMIN=1E-3
C---MAX NO OF (CODE.GE.100) ERRORS
      MAXER=10
C---TIME (SEC) NEEDED TO TERMINATE GRACEFULLY
      TLOUT=5.
C---CURRENT NO OF EVENTS
      NEVHEP=0
C---CURRENT NO OF ENTRIES IN /HEPEVT/
      NHEP=0
C---ISTAT IS STATUS OF EVENT (I.E. STAGE IN PROCESSING)
      ISTAT=0
C---IERROR IS ERROR CODE
      IERROR=0
C---MORE TECHNICAL PARAMETERS - SHOULDN'T NEED ADJUSTMENT
C---PI
      PIFAC=ACOS(-1.D0)
C Speed of light (mm/s)
      CSPEED=2.99792D11
C Cross-section conversion factor (hbar.c/e)**2
      GEV2NB=389379.D0
C---NUMBER OF SHOTS FOR INITIAL MAX WEIGHT SEARCH
      IBSH=10000
C---RANDOM NO. SEEDS FOR INITIAL MAX WEIGHT SEARCH
      IBRN(1)=1246579
      IBRN(2)=8447766
C---NUMBER OF ENTRIES IN LOOKUP TABLES OF SUDAKOV FORM FACTORS
      NQEV=1024
C---MAXIMUM BIN SIZE IN Z FOR SPACELIKE BRANCHING
      ZBINM=0.05
C---MAXIMUM NUMBER OF Z BINS FOR SPACELIKE BRANCHING
      NZBIN=100
C---MAXIMUM NUMBER OF BRANCH REJECTIONS (TO AVOID INFINITE LOOPS)
      NBTRY=200
C---MAXIMUM NUMBER OF TRIES TO GENERATE CLUSTER DECAY
      NCTRY=200
C---MAXIMUM NUMBER OF TRIES TO GENERATE MASS REQUESTED
      NETRY=200
C---MAXIMUM NUMBER OF TRIES TO GENERATE SOFT SUBPROCESS
      NSTRY=200
C---PRECISION FOR GAUSSIAN INTEGRATION
      ACCUR=1.D-6
C---ORDER OF INTERPOLATION IN SUDAKOV TABLES
      INTER=3
C---ORDER TO USE FOR ALPHAS IN SUDAKOV TABLES
      SUDORD=1
C--DEFAULT UNIT FOR THE SUSY DATA FILE
      LRSUSY = 66
C--CONSERVATION OF RPARITY
      RPARTY = .TRUE.
C--CHECK WHETHER SUSY DATA INPUTTED
      SUSYIN=.FALSE.
  999 END
CDECK  ID>, HWIODK.
*CMZ :-        -27/07/99  13.33.03  by  Mike Seymour
*-- Author :    Ian Knowles
C-----------------------------------------------------------------------
      SUBROUTINE HWIODK(IUNIT,IOPT,IME)
C-----------------------------------------------------------------------
C     If IUNIT > 0 writes out present HERWIG decay tables to unit IUNIT
C              < 0 reads in decay tables from unit IUNIT
C     The format used during the read/write is specified by IOPT
C     =1 PDG; =2 HERWIG numeric; =3 HERWIG character name.
C     When reading in if IME =1 matrix element codes >= 100 are accepted
C                             0                            are set zero.
C-----------------------------------------------------------------------
      INCLUDE 'HERWIG62.INC'
      INTEGER IUNIT,IOPT,IME,JUNIT,I,J,K,L,IDKY,ITMP(5),IDUM
      CHARACTER*8 CDK(NMXDKS),CDKPRD(5,NMXDKS),CDUM
      JUNIT=ABS(IUNIT)
      OPEN(UNIT=JUNIT,FORM='FORMATTED',STATUS='UNKNOWN')
      IF (IUNIT.GT.0) THEN
C Write out the decay table
        WRITE(JUNIT,100) NDKYS
        IF (IOPT.EQ.1) THEN
          DO 20 I=1,NRES
          IF (NMODES(I).EQ.0) GOTO 20
          K=LSTRT(I)
          DO 10 J=1,NMODES(I)
          WRITE(JUNIT,110) IDPDG(I),BRFRAC(K),NME(K),
     &                    (IDPDG(IDKPRD(L,K)),L=1,5)
  10      K=LNEXT(K)
  20      CONTINUE
        ELSEIF (IOPT.EQ.2) THEN
          DO 40 I=1,NRES
          IF (NMODES(I).EQ.0) GOTO 40
          K=LSTRT(I)
          DO 30 J=1,NMODES(I)
          WRITE(JUNIT,120) I,BRFRAC(K),NME(K),(IDKPRD(L,K),L=1,5)
  30      K=LNEXT(K)
  40      CONTINUE
        ELSEIF (IOPT.EQ.3) THEN
          DO 60 I=1,NRES
          IF (NMODES(I).EQ.0) GOTO 60
          K=LSTRT(I)
          DO 50 J=1,NMODES(I)
          WRITE(JUNIT,130) RNAME(I),BRFRAC(K),NME(K),
     &                    (RNAME(IDKPRD(L,K)),L=1,5)
  50      K=LNEXT(K)
  60      CONTINUE
        ENDIF
      ELSEIF (IUNIT.LT.0) THEN
C Read in the decay table and convert to HERWIG numeric format
        READ(JUNIT,100) NDKYS
        IF (NDKYS.GT.NMXDKS) CALL HWWARN('HWIODK',100,*999)
        IF (IOPT.EQ.1) THEN
          DO 70 I=1,NDKYS
          READ(JUNIT,110) IDKY,BRFRAC(I),NME(I),ITMP
          IF (IME.EQ.0.AND.NME(I).GE.100) NME(I)=0
          CALL HWUIDT(1,IDKY,IDK(I),CDUM)
          DO 70 J=1,5
  70      CALL HWUIDT(1,ITMP(J),IDKPRD(J,I),CDUM)
        ELSEIF (IOPT.EQ.2) THEN
          DO 80 I=1,NDKYS
          READ(JUNIT,120) IDK(I),BRFRAC(I),NME(I),(IDKPRD(J,I),J=1,5)
          IF (IDK(I).LT.0.OR.IDK(I).GT.NRES) IDK(I)=20
  80      IF (IME.EQ.0.AND.NME(I).GE.100) NME(I)=0
        ELSEIF (IOPT.EQ.3) THEN
          DO 90 I=1,NDKYS
          READ(JUNIT,130) CDK(I),BRFRAC(I),NME(I),(CDKPRD(J,I),J=1,5)
          IF (IME.EQ.0.AND.NME(I).GE.100) NME(I)=0
          CALL HWUIDT(3,IDUM,IDK(I),CDK(I))
          DO 90 J=1,5
  90      CALL HWUIDT(3,IDUM,IDKPRD(J,I),CDKPRD(J,I))
        ELSE
          CALL HWWARN('HWIODK',101,*999)
        ENDIF
      ENDIF
      CLOSE(UNIT=JUNIT)
  100 FORMAT(1X,I4)
  110 FORMAT(1X,I7,1X,F7.5,1X,I3,5(1X,I7))
  120 FORMAT(1X,I3,1X,F7.5,6(1X,I3))
  130 FORMAT(1X,A8,1X,F7.5,1X,I3,5(1X,A8))
  999 RETURN
      END
CDECK  ID>, HWISSP.
*CMZ :-        -20/10/99  09:46:43  by  Peter Richardson
*-- Author :    Bryan Webber, modified by Kosuke Odagiri
C-----------------------------------------------------------------------
      SUBROUTINE HWISSP
C-----------------------------------------------------------------------
C  Reads in SUSY particle properties and decays,
C  in format generated by ISAWIG
C-----------------------------------------------------------------------
      INCLUDE 'HERWIG62.INC'
      INTEGER I,J,K,IH,IHW,NSSP,NDEC,MDKYS
      DOUBLE PRECISION BETAH, WEINCOS,WEINSIN, MW,MZ, RMMAX
      DOUBLE PRECISION FTM,FTMUU(4),FTMDD(4),FTMTT(4),FTMBB(4),FTMU,FTMD
      DOUBLE PRECISION YTM,YTM1,DTERM(4), SQHF,SNBCSB,MZSW2
      LOGICAL FIRST
      EQUIVALENCE (MW,RMASS(198)), (MZ,RMASS(200))
      DATA FIRST/.TRUE./
      SAVE MDKYS
      IF (FIRST) THEN
        MDKYS=NDKYS
        FIRST=.FALSE.
      ELSE
        NDKYS=MDKYS
      ENDIF
C--reset susy input flag
      IF (LRSUSY.LT.0) CALL HWWARN('HWISSP',500,*999)
      SUSYIN = .TRUE.
C
C  Input SUSY particle + top quark table
C
      WRITE (6,10) LRSUSY
 10   FORMAT (/10X,'Reading in SUSY data from unit',I3)
      READ (LRSUSY,'(I4)') NSSP
      IF (NSSP.LE.0) RETURN
      RMMAX=SQRT(HALF*(EBEAM1*EBEAM2+PBEAM1*PBEAM2))
      RMMNSS=RMMAX
      DO I=1,NSSP
        READ (LRSUSY,1) IHW,RMASS(IHW),RLTIM(IHW)
C  Negative gaugino mass means physical field is gamma_5*psi
C  Store the signs
        IF ((IHW.GE.450).AND.(IHW.LE.457)) THEN
          IF (IHW.LE.453) THEN
            J=IHW-449
            ZSGNSS(J)=RMASS(IHW)/ABS(RMASS(IHW))
          ELSEIF (IHW.LE.455) THEN
            J=IHW-453
            WSGNSS(J)=RMASS(IHW)/ABS(RMASS(IHW))
          ENDIF
          RMASS(IHW)=ABS(RMASS(IHW))
        ENDIF
        IF (ABS(IDPDG(IHW)).GT.1000000.AND.(RMASS(IHW).NE.ZERO))
     &    RMMNSS=MIN(RMMNSS,RMASS(IHW))
        IF (IHW.GT.NRES) THEN
          IF (IHW.GT.NMXRES) CALL HWWARN('HWISSP',501,*999)
          NRES=IHW
        ENDIF
      ENDDO
      XLMNSS=TWO*LOG(RMMNSS/RMMAX)
    1 FORMAT(I5,F12.4,E15.5)
C
C  Input decay modes
C
      DO I=1,NSSP
        READ (LRSUSY,'(I4)') NDEC
        IF (NDEC.GT.0) THEN
          DO J=1,NDEC
            NDKYS=NDKYS+1
            IF (NDKYS.GT.NMXDKS) CALL HWWARN('HWISSP',100,*999)
            READ (LRSUSY,11) IDK(NDKYS),BRFRAC(NDKYS),NME(NDKYS),
     &      (IDKPRD(K,NDKYS),K=1,5)
   11       FORMAT(I6,F16.8,6I6)
          ENDDO
        ENDIF
      ENDDO
C
C  Mixings and other SUSY parameters
C
      READ (LRSUSY,'(2F16.8)') TANB,ALPHAH
      DO I=1,4
        READ (LRSUSY,13) ZMXNSS(I,1),ZMXNSS(I,2),ZMXNSS(I,3),ZMXNSS(I,4)
      END DO
      WEINSIN = SQRT(SWEIN)
      WEINCOS = SQRT(1.-SWEIN)
      DO I=1,4
        ZMIXSS(I,1) =  WEINCOS*ZMXNSS(I,1)+WEINSIN*ZMXNSS(I,2)
        ZMIXSS(I,2) = -WEINSIN*ZMXNSS(I,1)+WEINCOS*ZMXNSS(I,2)
        ZMIXSS(I,3) =  ZMXNSS(I,3)
        ZMIXSS(I,4) =  ZMXNSS(I,4)
      END DO
      DO J=1,16
        IF ((J.LE.6).OR.(J.GE.11)) THEN
          LFCH(J)=VFCH(J,1)+AFCH(J,1)
          RFCH(J)=VFCH(J,1)-AFCH(J,1)
          DO I=1,4
            SLFCH(J,I)= ZMIXSS(I,1)*QFCH(J)+ZMIXSS(I,2)*LFCH(J)
            SRFCH(J,I)=-ZMIXSS(I,1)*QFCH(J)-ZMIXSS(I,2)*RFCH(J)
          END DO
        ENDIF
      END DO
      READ (LRSUSY,13) WMXVSS(1,1),WMXVSS(1,2), WMXVSS(2,1),WMXVSS(2,2)
      READ (LRSUSY,13) WMXUSS(1,1),WMXUSS(1,2), WMXUSS(2,1),WMXUSS(2,2)
      READ (LRSUSY,'(3F16.8)') THETAT,THETAB,THETAL
      READ (LRSUSY,'(3F16.8)') ATSS,ABSS,ALSS
      READ (LRSUSY,'( F16.8)') MUSS
      DO I=1,6
        QMIXSS(I,1,1)=1.
        QMIXSS(I,1,2)=0.
        QMIXSS(I,2,1)=0.
        QMIXSS(I,2,2)=1.
        LMIXSS(I,1,1)=1.
        LMIXSS(I,1,2)=0.
        LMIXSS(I,2,1)=0.
        LMIXSS(I,2,2)=1.
      END DO
      QMIXSS(6,1,1)= COS(THETAT)
      QMIXSS(6,1,2)= SIN(THETAT)
      QMIXSS(6,2,1)=-QMIXSS(6,1,2)
      QMIXSS(6,2,2)= QMIXSS(6,1,1)
      QMIXSS(5,1,1)= COS(THETAB)
      QMIXSS(5,1,2)= SIN(THETAB)
      QMIXSS(5,2,1)=-QMIXSS(5,1,2)
      QMIXSS(5,2,2)= QMIXSS(5,1,1)
      LMIXSS(5,1,1)= COS(THETAL)
      LMIXSS(5,1,2)= SIN(THETAL)
      LMIXSS(5,2,1)=-LMIXSS(5,1,2)
      LMIXSS(5,2,2)= LMIXSS(5,1,1)
C--Evaluating Higgs parameters and couplings
      BETAH=ATAN(TANB)
      COTB=ONE/TANB
      COSBPA=COS(BETAH+ALPHAH)
      SINBPA=SIN(BETAH+ALPHAH)
      COSBMA=COS(BETAH-ALPHAH)
      SINBMA=SIN(BETAH-ALPHAH)
      COSA=COS(ALPHAH)
      SINA=SIN(ALPHAH)
      COSB=COS(BETAH)
      SINB=SIN(BETAH)
      GHWWSS(1)=SINBMA
      GHWWSS(2)=COSBMA
      GHWWSS(3)=ZERO
      DO 30 I=1,3
        GHZZSS(I)=GHWWSS(I)
 30   CONTINUE
      GHDDSS(1)=-SINA/COSB
      GHDDSS(2)= COSA/COSB
      GHDDSS(3)= TANB
      GHUUSS(1)= COSA/SINB
      GHUUSS(2)= SINA/SINB
      GHUUSS(3)= COTB
      GHWHSS(1)= COSBMA
      GHWHSS(2)= SINBMA
      GHWHSS(3)= ONE
      MZSW2    = MZ**2 * SQRT(SWEIN*(ONE-SWEIN))
      DTERM(1) =-SINBPA*MZSW2
      DTERM(2) = COSBPA*MZSW2
      DTERM(3) = ZERO
      FTMUU(1) = MUSS*SINA/SINB
      FTMUU(2) =-MUSS*COSA/SINB
      FTMUU(3) =-MUSS
      FTMUU(4) =-MUSS
      FTMTT(1) = ATSS*COSA/SINB
      FTMTT(2) = ATSS*SINA/SINB
      FTMTT(3) =-ATSS*COTB
      FTMTT(4) =-ATSS*COTB
      FTMDD(1) =-MUSS*COSA/COSB
      FTMDD(2) =-MUSS*SINA/COSB
      FTMDD(3) =-MUSS
      FTMDD(4) =-MUSS
      FTMBB(1) =-ABSS*SINA/COSB
      FTMBB(2) = ABSS*COSA/COSB
      FTMBB(3) =-ABSS*TANB
      FTMBB(4) =-ABSS*TANB
      DO 40 IH=1,4
        FTMU=FTMUU(IH)
        FTMD=FTMDD(IH)
        DO 50 I=1,6
          IF (I.EQ.5) FTMU=FTMU+FTMTT(IH)
          IF (I.EQ.5) FTMD=FTMD+FTMBB(IH)
          IF (MOD(I,2).EQ.0) THEN
           YTM = GHUUSS(IH)
           FTM = FTMU
          ELSE
           YTM = GHDDSS(IH)
           FTM = FTMD
          END IF
          IF (IH.EQ.3) THEN
           GHSQSS(IH,I,1,1) = ZERO
           GHSQSS(IH,I,2,2) = ZERO
           GHSQSS(IH,I,1,2) = FTM*HALF*RMASS(I)/MW
           GHSQSS(IH,I,2,1) = - GHSQSS(IH,I,1,2)
           GOTO 50
          ELSEIF (IH.EQ.4) THEN
           SQHF=SQRT(HALF)
           SNBCSB=SINB*COSB
           DO 60 J=1,2
            DO 70 K=1,2
             IF (MOD(I,2).EQ.1) THEN
              GHSQSS(IH,I,J,K)=SQHF*(
     &          RMASS(I  )*FTMD*QMIXSS(I,2,J)*QMIXSS(I+1,1,K)
     &         +RMASS(I+1)*FTMU*QMIXSS(I,1,J)*QMIXSS(I+1,2,K)
     &         +( MW**2*TWO*SNBCSB-RMASS(I+1)**2*COTB
     &           -RMASS(I  )**2*TANB )*QMIXSS(I,1,J)*QMIXSS(I+1,1,K)
     &         -RMASS(I)*RMASS(I+1)/SNBCSB
     &          *QMIXSS(I,2,J)*QMIXSS(I+1,2,K) ) / MW
             ELSE
              GHSQSS(IH,I,J,K)=GHSQSS(IH,I-1,K,J)
             END IF
 70         END DO
 60        END DO
          ELSE
           DO 80 J=1,2
            DO 90 K=1,2
             YTM1=ZERO
             IF (J.EQ.K) YTM1=YTM*RMASS(I)**2
             GHSQSS(IH,I,J,K)=( YTM1
     &        +( LFCH(I)*QMIXSS(I,1,J)*QMIXSS(I,1,K)
     &          -RFCH(I)*QMIXSS(I,2,J)*QMIXSS(I,2,K) )*DTERM(IH)
     &        +FTM*HALF*RMASS(I)*(QMIXSS(I,1,J)*QMIXSS(I,2,K)
     &                           +QMIXSS(I,2,J)*QMIXSS(I,1,K)) ) / MW
 90         CONTINUE
 80        CONTINUE
          END IF
 50     CONTINUE
 40   CONTINUE
C--Rparity violation
      READ (LRSUSY,'(L5)') RPARTY
      IF(.NOT.RPARTY) THEN
        READ(LRSUSY,20) (((LAMDA1(I,J,K),K=1,3),J=1,3),I=1,3)
        READ(LRSUSY,20) (((LAMDA2(I,J,K),K=1,3),J=1,3),I=1,3)
        READ(LRSUSY,20) (((LAMDA3(I,J,K),K=1,3),J=1,3),I=1,3)
      ENDIF
 13   FORMAT(4F16.8)
 20   FORMAT(27E16.8)
      CLOSE(LRSUSY)
  999 END
CDECK  ID>, HWMEVT.
*CMZ :-        -04/05/99  14.28.59  by  Bryan Webber
*-- Author :    Bryan Webber
C-----------------------------------------------------------------------
      SUBROUTINE HWMEVT
C-----------------------------------------------------------------------
C     IPROC = 1000,... ADDS SOFT UNDERLYING EVENT
C           = 8000:  CREATES MINIMUM-BIAS EVENT
C     SUPPRESSED BY ADDING 10000 TO IPROC
C-----------------------------------------------------------------------
      INCLUDE 'HERWIG62.INC'
      DOUBLE PRECISION HWREXP,ENFAC,TECM,SECM,SUMM,EMCL,BMP(5),BMR(3,3)
      INTEGER HWRINT,NETC,IBT,IDBT,ID1,ID2,ID3,KHEP,LHEP,NTRY,ICMS,
     & NPPBAR,MCHT,JCL,JD1,JD2,JD3,ICH,MODC,NCHT,INHEP(2),
     & INID(2,2),JBT
      EXTERNAL HWREXP,HWRINT
      IF (IERROR.NE.0) RETURN
      IF (.NOT.GENSOF) GOTO 990
      IF (IPROC.EQ.8000) THEN
C---SET UP BEAM AND TARGET CLUSTERS
    5   NETC=0
        DO 10 IBT=1,2
        JBT=IBT
        IF (JDAHEP(1,IBT).NE.0) JBT=JDAHEP(1,IBT)
        IDBT=IDHW(JBT)
        IF (IDBT.EQ.73.OR.IDBT.EQ.75) THEN
          INID(1,IBT)=HWRINT(1,2)
          INID(2,IBT)=110
        ELSEIF (IDBT.EQ.91.OR.IDBT.EQ.93) THEN
          INID(1,IBT)=116
          INID(2,IBT)=HWRINT(7,8)
        ELSEIF (IDBT.EQ.30) THEN
          INID(1,IBT)=HWRINT(1,2)
          INID(2,IBT)=8
        ELSEIF (IDBT.EQ.38) THEN
          INID(1,IBT)=2
          INID(2,IBT)=HWRINT(7,8)
        ELSEIF (IDBT.EQ.34) THEN
          INID(1,IBT)=3
          INID(2,IBT)=HWRINT(7,8)
        ELSEIF (IDBT.EQ.46) THEN
          INID(1,IBT)=HWRINT(1,2)
          INID(2,IBT)=9
        ELSEIF (IDBT.EQ.59) THEN
          INID(1,IBT)=HWRINT(1,2)
          INID(2,IBT)=HWRINT(7,8)
        ELSE
          CALL HWWARN('HWMEVT',100,*999)
        ENDIF
        NETC=NETC+ICHRG(IDBT)
     &    -(ICHRG(INID(1,IBT))+ICHRG(INID(2,IBT)))/3
        ENFAC=1.
        IDHW(NHEP+IBT)=19
        IDHEP(NHEP+IBT)=91
        ISTHEP(NHEP+IBT)=163+IBT
        JMOHEP(1,NHEP+IBT)=JBT
   10   CONTINUE
        IF (NETC.EQ.0) THEN
          ID3=HWRINT(1,2)
        ELSEIF (NETC.EQ.-1) THEN
          ID3=1
        ELSEIF (NETC.EQ.1) THEN
          ID3=2
        ELSE
          GOTO 5
        ENDIF
        DO 12 IBT=1,2
        NHEP=NHEP+1
        JBT=IBT
        IF (JDAHEP(1,IBT).NE.0) JBT=JDAHEP(1,IBT)
        CALL HWVEQU(5,PHEP(1,JBT),PHEP(1,NHEP))
   12   INHEP(IBT)=NHEP
      ELSE
C---FIND BEAM AND TARGET CLUSTERS
        DO 20 IBT=1,2
        DO 15 KHEP=1,NHEP
        IF (ISTHEP(KHEP).EQ.163+IBT) THEN
          INHEP(IBT)=KHEP
          INID(1,IBT)=IDHW(JMOHEP(1,KHEP))
          INID(2,IBT)=IDHW(JMOHEP(2,KHEP))
          GOTO 20
        ENDIF
   15   CONTINUE
C---COULDN'T FIND ONE
        INHEP(IBT)=0
   20   CONTINUE
        JCL=-1
C---TEST FOR BOTH FOUND
        IF (INHEP(1).EQ.0) JCL=INHEP(2)
        IF (INHEP(2).EQ.0) JCL=INHEP(1)
        IF (JCL.EQ.0) CALL HWWARN('HWMEVT',101,*999)
        IF (JCL.GT.0) THEN
          ISTHEP(JCL)=163
          CALL HWCFOR
          CALL HWCDEC
          CALL HWDHAD
          CALL HWDHVY
          GOTO 90
        ENDIF
        ID3=HWRINT(1,2)
        ENFAC=ENSOF
        NETC=0
      ENDIF
C---FIND SOFT CM MOMENTUM AND MULTIPLICITY
      NTRY=0
      NHEP=NHEP+1
      IF (NHEP.GT.NMXHEP) CALL HWWARN('HWMEVT',102,*999)
      ICMS=NHEP
      IDHW(NHEP)=16
      IDHEP(NHEP)=0
C--Bug Fix 31/03/00 PR
      JMOHEP(1,ICMS)=INHEP(1)
      JMOHEP(2,ICMS)=INHEP(2)
C--End of Fix
      ISTHEP(NHEP)=170
      CALL HWVSUM(4,PHEP(1,INHEP(1)),PHEP(1,INHEP(2)),PHEP(1,NHEP))
      CALL HWUMAS(PHEP(1,NHEP))
      TECM=PHEP(5,NHEP)
      IF (IPROC/1000.EQ.9.OR.IPROC/1000.EQ.5) THEN
        SECM=TECM*ENFAC
      ELSE
        SECM=PHEP(5,3)*ENFAC
      ENDIF
C---CHOOSE MULTIPLICITY
   25 CALL HWMULT(SECM,NPPBAR)
   30 NCL=0
      MCHT=0
      IERROR=0
      NHEP =ICMS
      SUMM=0.
      NTRY=NTRY+1
C---CREATE CLUSTERS
   35 NCL=NCL+1
      NHEP=NHEP+1
      IF (NHEP.GT.NMXHEP) CALL HWWARN('HWMEVT',103,*999)
      JCL=NHEP
      IDHW(JCL)=19
      IDHEP(JCL)=91
      IF (NCL.LT.3) THEN
        ISTHEP(JCL)=170+NCL
        ID1=INID(1,NCL)
        ID2=INID(2,NCL)
      ELSE
        ID1=ID2-6
        IF (NCL.EQ.3) ID1=ID3
        ID2=HWRINT(7,8)
        ISTHEP(JCL)=173
      ENDIF
      JMOHEP(1,JCL)=ICMS
      JMOHEP(2,JCL)=0
      CALL HWVZRO(3,PHEP(1,JCL))
      PHEP(4,JCL)=RMASS(ID1)+RMASS(ID2)+PMBM1+HWREXP(TWO/PMBM2)
      PHEP(5,JCL)=PHEP(4,JCL)
C---HADRONIZE AND DECAY CLUSTERS
      CALL HWCFLA(ID1,ID2,JD1,JD2)
      CALL HWCHAD(JCL,JD1,JD2,JD3)
      IF (IERROR.NE.0) RETURN
      IF (JD3.EQ.0) THEN
        EMCL=RMASS(IDHW(NHEP))
        IF (PHEP(4,JCL).NE.EMCL) THEN
          PHEP(4,JCL)=EMCL
          PHEP(5,JCL)=EMCL
          PHEP(4,NHEP)=EMCL
          PHEP(5,NHEP)=EMCL
        ENDIF
      ELSE
        EMCL=PHEP(5,JCL)
      ENDIF
      IDCL(NCL)=JD3
      PPCL(5,NCL)=EMCL
      SUMM=SUMM +EMCL
      CALL HWDHAD
      CALL HWDHVY
      IF (IERROR.NE.0) RETURN
C---CHECK CHARGED MULTIPLICITY
      MODC=0
      DO 50 KHEP=JCL,NHEP
      IF (ISTHEP(KHEP).EQ.1) THEN
         ICH=ICHRG(IDHW(KHEP))
         IF (ICH.NE.0) THEN
            MCHT=MCHT+ABS(ICH)
            MODC=MODC+ICH
         ENDIF
      ENDIF
   50 CONTINUE
      IF (NCL.EQ.1) THEN
         NCHT=NPPBAR+NETC+ABS(MODC)
         GOTO 35
      ELSEIF (NCL.EQ.2) THEN
         NCHT=NCHT+ABS(MODC)
         IF (NCHT.LT.0) NCHT=NCHT+2
      ENDIF
      IF (MCHT.LT.NCHT) THEN
        GOTO 35
      ELSEIF (MCHT.GT.NCHT) THEN
        IF (MOD(NTRY,50).EQ.0) GOTO 25
        IF (NTRY.LT.NSTRY) GOTO 30
C---NO PHASE SPACE FOR SOFT EVENT
        NHEP=ICMS-1
        IF (IPROC.EQ.8000) THEN
C---MINIMUM BIAS: RELABEL BEAM AND TARGET CLUSTERS
          DO 60 IBT=1,2
            KHEP=INHEP(IBT)
            LHEP=JMOHEP(1,KHEP)
            ISTHEP(KHEP)=1
            IDHEP(KHEP)=IDHEP(LHEP)
            IDHW(KHEP)=IDHW(LHEP)
   60     CONTINUE
        ELSE
C---UNDERLYING EVENT: DECAY THEM
          ISTHEP(INHEP(1))=163
          ISTHEP(INHEP(2))=163
          CALL HWCFOR
          CALL HWCDEC
          CALL HWDHAD
          CALL HWDHVY
        ENDIF
        GOTO 90
      ENDIF
C---GENERATE CLUSTER MOMENTA IN CLUSTER CM
C   FRAME.   N.B. SECOND CLUSTER IS TARGET
      IF (SUMM.GT.TECM) GOTO 25
      CALL HWMLPS(TECM)
      IF (NCL.EQ.0) GOTO 25
      JCL=0
C---ROTATE & BOOST CLUSTERS & DECAY PRODUCTS
      CALL HWULOF(PHEP(1,ICMS),PHEP(1,INHEP(1)),BMP)
      CALL HWUROT(BMP, ONE,ZERO,BMR)
C---BMR PUTS BEAM ALONG Z AXIS (WE WANT INVERSE)
      DO 70 KHEP=ICMS+1,NHEP
      IF (ISTHEP(KHEP).GT.180.AND.ISTHEP(KHEP).LT.190
     $       .AND.JMOHEP(1,KHEP).EQ.ICMS) THEN
          ISTHEP(KHEP)=ISTHEP(KHEP)+3
          LHEP=KHEP
          JCL=JCL+1
          CALL HWUROB(BMR,PPCL(1,JCL),PPCL(1,JCL))
          CALL HWULOB(PHEP(1,ICMS),PPCL(1,JCL),PPCL(1,JCL))
C---NOW PPCL(*,JCL) IS LAB MOMENTUM OF JTH CLUSTER
      ENDIF
      CALL HWULOB(PPCL(1,JCL),PHEP(1,KHEP),PHEP(1,KHEP))
   70 CONTINUE
      ISTHEP(INHEP(1))=167
      ISTHEP(INHEP(2))=168
      JDAHEP(1,INHEP(1))=ICMS
      JDAHEP(2,INHEP(1))=0
      JDAHEP(1,INHEP(2))=ICMS
      JDAHEP(2,INHEP(2))=0
      JDAHEP(1,ICMS)=ICMS+1
      JDAHEP(2,ICMS)=LHEP
   90 CONTINUE
  990 ISTAT=100
  999 END
CDECK  ID>, HWMLPS.
*CMZ :-        -04/05/99  14.17.04  by  Bryan Webber
*-- Author :    David Ward, modified by Bryan Webber
C-----------------------------------------------------------------------
      SUBROUTINE HWMLPS(TECM)
C-----------------------------------------------------------------------
C     GENERATES CYLINDRICAL PHASE SPACE USING THE METHOD OF JADACH
C     RETURNS WITH NCL=0 IF UNSUCCESSFUL
C-----------------------------------------------------------------------
      INCLUDE 'HERWIG62.INC'
      DOUBLE PRECISION HWREXT,HWRUNG,HWUSQR,TECM,ESS,ALOGS,EPS,SUMX,
     & SUMY,PT,PX,PY,PT2,SUMPT2,SUMTM,XIMIN,XIMAX,YY,SUM1,SUM2,SUM3,
     & SUM4,EX,FY,DD,DYY,ZZ,E1,TM,SLOP,XI(NMXCL)
      INTEGER NTRY,I,NIT,IY(NMXCL),IDP
      EXTERNAL HWREXT,HWRUNG,HWUSQR
      IF (NCL.GT.NMXCL) THEN
        CALL HWWARN('HWMLPS',1,*999)
        NCL=NMXCL
      ENDIF
      ESS=TECM**2
      ALOGS=LOG(ESS)
      EPS=1D-10/NCL
      NTRY=0
  11  NTRY=NTRY+1
      IF (NTRY.GT.NSTRY) THEN
        NCL=0
        RETURN
      ENDIF
      SUMX=0.
      SUMY=0.
      DO 12 I=1,NCL
C---Pt distribution of form exp(-b*Mt)
C---Factors for pt slopes to fit data.  IDCL contains the type of
C   q-qbar pair produced in this cluster (0 if 1-particle cluster).
      IDP=IDCL(I)
      IF (IDP.LE.2) THEN
        SLOP=PMBP1
      ELSEIF(IDP.EQ.3.OR.IDP.EQ.10) THEN
        SLOP=PMBP2
      ELSEIF(IDP.GT.3.AND.IDP.LE.9) THEN
        SLOP=PMBP3
      ELSE
        CALL HWWARN('HWMLPS',IDP,*999)
        SLOP=PMBP2
      ENDIF
      PT=HWREXT(PPCL(5,I),SLOP)
      PT=HWUSQR(PT**2-PPCL(5,I)**2)
      CALL HWRAZM(PT,PX,PY)
      PPCL(1,I)=PX
      PPCL(2,I)=PY
      SUMX=SUMX+PPCL(1,I)
  12  SUMY=SUMY+PPCL(2,I)
      SUMX=SUMX/NCL
      SUMY=SUMY/NCL
      SUMPT2=0.
      SUMTM=0.
      DO 13 I=1,NCL
      PPCL(1,I)=PPCL(1,I)-SUMX
      PPCL(2,I)=PPCL(2,I)-SUMY
      PT2=PPCL(1,I)**2+PPCL(2,I)**2
      SUMPT2=SUMPT2+PT2
C---STORE TRANSVERSE MASS IN PPCL(3,I) TEMPORARILY
      PPCL(3,I)=SQRT(PT2+PPCL(5,I)**2)
  13  SUMTM=SUMTM+PPCL(3,I)
      IF (SUMTM.GT.TECM) GOTO 11
      DO 14 I=1,NCL
C---Form of "reduced rapidity" distribution
      XI(I)=HWRUNG(0.6*ONE,ONE)
  14  CONTINUE
      CALL HWUSOR(XI,NCL,IY,1)
      XIMIN=XI(1)
      XIMAX=XI(NCL)-XI(1)
C---N.B. TARGET CLUSTER IS SECOND
      XI(1)=0.
      DO 16 I=NCL-1,2,-1
      XI(I+1)=(XI(I)-XIMIN)/XIMAX
  16  CONTINUE
      XI(2)=1.
      YY=LOG(ESS/(PPCL(3,1)*PPCL(3,2)))
      DO 18 NIT=1,10
      SUM1=0.
      SUM2=0.
      SUM3=0.
      SUM4=0.
      DO 19 I=1,NCL
      TM=PPCL(3,I)
      EX=EXP(YY*XI(I))
      SUM1=SUM1+(TM*EX)
      SUM2=SUM2+(TM/EX)
      SUM3=SUM3+(TM*EX)*XI(I)
  19  SUM4=SUM4+(TM/EX)*XI(I)
      FY=ALOGS-LOG(SUM1*SUM2)
      DD=(SUM3*SUM2-SUM1*SUM4)/(SUM1*SUM2)
      DYY=FY/DD
      IF(ABS(DYY/YY).LT.EPS) GOTO 20
  18  YY=YY+DYY
C---Y ITERATIONS EXCEEDED - TRY AGAIN
      IF (NTRY.LT.100) GOTO 11
      EPS=10.*EPS
      IF (EPS.GT.ONE) CALL HWWARN('HWMLPS',100,*999)
      CALL HWWARN('HWMLPS',50,*11)
   20 YY=YY+DYY
      ZZ=LOG(TECM/SUM1)
      DO 22 I=1,NCL
      TM=PPCL(3,I)
      E1=EXP(ZZ+YY*XI(I))
      PPCL(3,I)=(0.5*TM)*((1./E1)-E1)
      PPCL(4,I)=(0.5*TM)*((1./E1)+E1)
  22  CONTINUE
 999  END
CDECK  ID>, HWMNBI.
*CMZ :-        -26/04/91  11.11.55  by  Bryan Webber
*-- Author :    David Ward, modified by Bryan Webber
C-----------------------------------------------------------------------
      FUNCTION HWMNBI(N,AVNCH,EK)
C-----------------------------------------------------------------------
C---Computes negative binomial probability
C-----------------------------------------------------------------------
      DOUBLE PRECISION HWMNBI,AVNCH,EK,R
      INTEGER N,I
      IF(N.LE.0) THEN
       HWMNBI=0
      ELSE
       R=AVNCH/EK
       HWMNBI=(1.+R)**(-EK)
       R=R/(1.+R)
       DO 1 I=1,N
       HWMNBI=HWMNBI*R*(EK+I-1)/I
    1  CONTINUE
      ENDIF
      END
CDECK  ID>, HWMODK.
*CMZ :-        -27/07/99  13.33.03  by  Mike Seymour
*-- Author :    Ian Knowles
C-----------------------------------------------------------------------
      SUBROUTINE HWMODK(IDKTMP,BRTMP,IMETMP,
     & IATMP,IBTMP,ICTMP,IDTMP,IETMP)
C-----------------------------------------------------------------------
C     Takes the decay, IDKTMP -> I-(A+B+C+D+E)-TMP, and simply stores it
C     if internal pointers not set up (.NOT.DKPSET) else if pre-existing
C     mode updates branching ratio BRTMP and matrix element code IMETMP,
C     if -ve leaves as is. If a new mode adds to table and if consistent
C     adjusts pointers,  sets CMMOM (for two-body mode) and resets RSTAB
C     if necessary.  The branching ratios of any other IDKTMP decays are
C     scaled by (1.-BRTMP)/(1.-BR_OLD)
C-----------------------------------------------------------------------
      INCLUDE 'HERWIG62.INC'
      DOUBLE PRECISION HWUPCM,BRTMP,SCALE,EPS
      INTEGER IDKTMP,IMETMP,IATMP,IBTMP,ICTMP,IDTMP,IETMP,IDKY,ITMP(5),
     & L,I,J,K,JPREV
      LOGICAL MATCH(5)
      CHARACTER*8 CDUM
      EXTERNAL HWUPCM
      PARAMETER (EPS=1.D-6)
C Convert to internal format
      CALL HWUIDT(1,IDKTMP,IDKY,CDUM)
      IF (IDKY.EQ.20) THEN
        WRITE(6,10) IDKTMP
  10    FORMAT(1X,'Particle decaying,',I7,', is not recognised')
        RETURN
      ENDIF
      CALL HWUIDT(1,IATMP,ITMP(1),CDUM)
      CALL HWUIDT(1,IBTMP,ITMP(2),CDUM)
      CALL HWUIDT(1,ICTMP,ITMP(3),CDUM)
      CALL HWUIDT(1,IDTMP,ITMP(4),CDUM)
      CALL HWUIDT(1,IETMP,ITMP(5),CDUM)
C If internal pointers not yet set up simply store decay
      IF (.NOT.DKPSET) THEN
        NDKYS=NDKYS+1
        IF (NDKYS.GT.NMXDKS) CALL HWWARN('HWMODK',100,*999)
        IDK(NDKYS)=IDKY
        BRFRAC(NDKYS)=BRTMP
        NME(NDKYS)=IMETMP
        DO 20 I=1,5
  20    IDKPRD(I,NDKYS)=ITMP(I)
      ELSE
        IF (NMODES(IDKY).GT.0) THEN
C First search to see if mode pre-exists
          IF ((ITMP(2).GE.1.AND.ITMP(2).LE.13).OR.
     &        (ITMP(3).GE.1.AND.ITMP(3).LE.13)) THEN
C Partonic respect order
            L=LSTRT(IDKY)
            DO 30 K=1,NMODES(IDKY)
                IF (ITMP(1).EQ.IDKPRD(1,L).AND.
     &              ITMP(2).EQ.IDKPRD(2,L).AND.
     &              ITMP(3).EQ.IDKPRD(3,L).AND.
     &              ITMP(4).EQ.IDKPRD(4,L).AND.
     &              ITMP(5).EQ.IDKPRD(5,L)) GOTO 90
  30        L=LNEXT(L)
          ELSE
C Allow for different order in matching
            L=LSTRT(IDKY)
            DO 70 I=1,NMODES(IDKY)
            DO 40 J=1,5
  40        MATCH(J)=.FALSE.
            DO 60 J=1,5
            DO 50 K=1,5
            IF (.NOT.MATCH(K).AND.ITMP(K).EQ.IDKPRD(J,L)) THEN
              MATCH(K)=.TRUE.
              GOTO 60
            ENDIF
  50        CONTINUE
  60        CONTINUE
            IF (MATCH(1).AND.MATCH(2).AND.MATCH(3).AND.
     &          MATCH(4).AND.MATCH(5)) GOTO 90
  70        L=LNEXT(L)
          ENDIF
        ENDIF
C A new mode put decay products in table
        NDKYS=NDKYS+1
        IF (NDKYS.GT.NMXDKS) CALL HWWARN('HWMODK',101,*999)
        DO 80 I=1,5
  80    IDKPRD(I,NDKYS)=ITMP(I)
C If decay consistent set up new pointers
        CALL HWDCHK(IDKY,NDKYS,*980)
        IF (NMODES(IDKY).EQ.0) THEN
          LSTRT(IDKY)=NDKYS
          IF (RLTIM(IDKY).LT.PLTCUT.AND.RMASS(IDKY).NE.ZERO) THEN
            RSTAB(IDKY)=.FALSE.
            DKLTM(IDKY)=RLTIM(IDKY)*RMASS(IDKY)/HBAR
          ELSE
            RSTAB(IDKY)=.TRUE.
          ENDIF
        ELSE
          LNEXT(L)=NDKYS
        ENDIF
        NMODES(IDKY)=NMODES(IDKY)+1
        LNEXT(NDKYS)=NDKYS
        L=NDKYS
C Set CMMOM if two body decay
        IF (NPRODS(L).EQ.2) CMMOM(L)=
     &   HWUPCM(RMASS(IDKY),RMASS(IDKPRD(1,L)),RMASS(IDKPRD(2,L)))
C A Pre-existing mode, line L, add/update ME code and BR, scaling all
C other branching fractions
  90    IF (IMETMP.GT.0) NME(L)=IMETMP
        IF (ABS(BRTMP-1.).LT.EPS) THEN
C This modes dominant: eliminate others
          NMODES(IDKY)=1
          LSTRT(IDKY)=L
          BRFRAC(L)=ONE
          LNEXT(L)=L
        ELSEIF (ABS(BRTMP).LT.EPS) THEN
C This mode insignificant: eliminate it
          IF (NMODES(IDKY).EQ.1) THEN
            RSTAB(IDKY)=.TRUE.
          ELSE
            J=LSTRT(IDKY)
            IF (J.EQ.L) THEN
              LSTRT(IDKY)=LNEXT(J)
            ELSE
              JPREV=J
              DO 100 I=2,NMODES(IDKY)
              J=LNEXT(J)
              IF (J.EQ.L) LNEXT(JPREV)=LNEXT(J)
  100         JPREV=J
            ENDIF
C           Rescale other modes
            SCALE=ONE/(ONE-BRFRAC(L))
            J=LSTRT(IDKY)
            DO 110 I=1,NMODES(IDKY)-1
            BRFRAC(J)=SCALE*BRFRAC(J)
  110       J=LNEXT(J)
          ENDIF
          NMODES(IDKY)=NMODES(IDKY)-1
        ELSE
C Rescale all other modes
          IF (NMODES(IDKY).EQ.1) THEN
            BRFRAC(L)=ONE
          ELSE
            IF (L.EQ.NDKYS) THEN
              SCALE=ONE-BRTMP
            ELSE
              SCALE=(ONE-BRTMP)/(ONE-BRFRAC(L))
            ENDIF
            J=LSTRT(IDKY)
            DO 120 I=1,NMODES(IDKY)
            IF (J.NE.L) BRFRAC(J)=SCALE*BRFRAC(J)
  120       J=LNEXT(J)
            BRFRAC(L)=BRTMP
          ENDIF
        ENDIF
      ENDIF
      GOTO 999
  980 WRITE(6,990)
  990 FORMAT(1X,'Decay mode inconsistent, no modifications made')
  999 RETURN
      END
CDECK  ID>, HWMULT.
*CMZ :-        -04/05/99  11.11.55  by  Bryan Webber
*-- Author :    David Ward, modified by Bryan Webber
C-----------------------------------------------------------------------
      SUBROUTINE HWMULT(EPPBAR,NCHT)
C-----------------------------------------------------------------------
C     Chooses charged multiplicity NCHT at the p-pbar c.m. energy EPPBAR
C-----------------------------------------------------------------------
      INCLUDE 'HERWIG62.INC'
      DOUBLE PRECISION HWMNBI,HWRGEN,EPPBAR,E0,ALOGS,RK,EK,AVN,SUM,R,
     & CUM(500)
      INTEGER NCHT,IMAX,I,N
      SAVE IMAX,CUM
      EXTERNAL HWMNBI,HWRGEN
      DATA E0/0/
      IF (EPPBAR.NE.E0) THEN
         E0=EPPBAR
C---Initialize
         ALOGS=2.*LOG(EPPBAR)
         RK=PMBK1*ALOGS+PMBK2
         IF (ABS(RK).GT.1000.) RK=1000.
         EK=1./RK
         AVN=PMBN1*EXP(PMBN2*ALOGS)+PMBN3
         IF (AVN.LT.ONE) AVN=1.
         SUM=0.
         IMAX=1
         DO 10 I=1,500
         N=2*I
         CUM(I)=HWMNBI(N,AVN,EK)
         IF (CUM(I).LT.1D-7*SUM) GOTO 11
         IMAX=I
         SUM=SUM+CUM(I)
         CUM(I)=SUM
  10     CONTINUE
  11     CONTINUE
         IF (IMAX.LE.1) THEN
            IMAX=1
            CUM(1)=1
         ELSEIF (IMAX.EQ.500) THEN
            CALL HWWARN('HWMULT',200,*999)
         ELSE
            DO 12 I=1,IMAX
  12        CUM(I)=CUM(I)/SUM
         ENDIF
      ENDIF
C --- Select NCHT
      R=HWRGEN(0)
      DO 20 I=1,IMAX
      IF(R.GT.CUM(I)) GOTO 20
      NCHT=2*I
      RETURN
  20  CONTINUE
      CALL HWWARN('HWMULT',100,*999)
  999 END
CDECK  ID>, HWMWGT.
*CMZ :-        -02/11/93  11.11.55  by  Bryan Webber
*-- Author :    Bryan Webber
C-----------------------------------------------------------------------
      SUBROUTINE HWMWGT
C-----------------------------------------------------------------------
C COMPUTES WEIGHT FOR MINIMUM-BIAS EVENT
C-----------------------------------------------------------------------
      INCLUDE 'HERWIG62.INC'
      DOUBLE PRECISION S,X,Y
      INTEGER IDB,IDT,IDBT
      IF (IERROR.NE.0) RETURN
      IDB=IDHW(1)
      IF (JDAHEP(1,1).NE.0) IDB=IDHW(JDAHEP(1,1))
      IDT=IDHW(2)
      IF (JDAHEP(1,2).NE.0) IDT=IDHW(JDAHEP(1,2))
      IDBT=100*IDB+IDT
      IF (IDT.GT.IDB) IDBT=100*IDT+IDB
C---USE TOTAL CROSS SECTION FITS OF DONNACHIE & LANDSHOFF
C   CERN-TH.6635/92
      IF (IDBT.EQ.9173) THEN
        X=21.70
        Y=98.39
      ELSEIF (IDBT.EQ.7373) THEN
        X=21.70
        Y=56.08
      ELSEIF (IDBT.EQ.7330) THEN
        X=13.63
        Y=36.02
      ELSEIF (IDBT.EQ.7338) THEN
        X=13.63
        Y=27.56
      ELSEIF (IDBT.EQ.7334) THEN
        X=11.82
        Y=26.36
      ELSEIF (IDBT.EQ.7346) THEN
        X=11.82
        Y= 8.15
      ELSEIF (IDBT.EQ.7359) THEN
        X=.0677
        Y=.1290
      ELSEIF (IDBT.EQ.9175) THEN
        X=21.70
        Y=92.71
      ELSEIF (IDBT.EQ.7573) THEN
        X=21.70
        Y=54.77
      ELSEIF (IDBT.EQ.5959) THEN
C---FOR GAMMA-GAMMA ASSUME X AND Y FACTORIZE
        X=2.1E-4
        Y=3.0E-4
      ELSE
        PRINT *,' IDBT=',IDBT
        CALL HWWARN('HWMWGT',100,*999)
      ENDIF
      S=PHEP(5,3)**2
C---EVWGT IS NON-DIFFRACTIVE CROSS SECTION IN NANOBARNS
C   ASSUMING NON-DIFFRACTIVE = TOTAL*0.7
      EVWGT=.7E6*(X*S**.0808 + Y*S**(-.4525))
  999 END
CDECK  ID>, HWRAZM.
*CMZ :-        -26/04/91  11.11.55  by  Bryan Webber
*-- Author :    Bryan Webber
C-----------------------------------------------------------------------
      SUBROUTINE HWRAZM(PT,PX,PY)
C-----------------------------------------------------------------------
C     RANDOMLY ROTATED 2-VECTOR (PX,PY) OF LENGTH PT
C-----------------------------------------------------------------------
      DOUBLE PRECISION HWRGEN,PT,PX,PY,C,S,CS,QT,ONE,ZERO
      PARAMETER(ONE=1.0D0, ZERO=0.0D0)
      EXTERNAL HWRGEN
   10 C=2.*HWRGEN(1)-1.
      S=2.*HWRGEN(2)-1.
      CS=C*C+S*S
      IF (CS.GT.ONE .OR. CS.EQ.ZERO) GOTO 10
      QT=PT/CS
      PX=(C*C-S*S)*QT
      PY=2.*C*S*QT
      END
CDECK  ID>, HWREXP.
*CMZ :-        -26/04/91  11.11.55  by  Bryan Webber
*-- Author :    David Ward, modified by Bryan Webber
C-----------------------------------------------------------------------
      FUNCTION HWREXP(AV)
C-----------------------------------------------------------------------
C     Random number from dN/d(x**2)=exp(-b*x) with mean AV
C-----------------------------------------------------------------------
      DOUBLE PRECISION HWREXP,HWRGEN,AV,B,R1,R2
      EXTERNAL HWRGEN
      B=2./AV
      R1=HWRGEN(0)
      R2=HWRGEN(1)
      HWREXP=-LOG(R1*R2)/B
      END
CDECK  ID>, HWREXQ.
*CMZ :-        -02/06/94  11.02.47  by  Mike Seymour
*-- Author :    David Ward, modified by Bryan Webber and Mike Seymour
C-----------------------------------------------------------------------
      FUNCTION HWREXQ(AV,XMAX)
C-----------------------------------------------------------------------
C     Random number from dN/d(x**2)=EXQ(-b*x) with mean AV,
C     But truncated at XMAX
C-----------------------------------------------------------------------
      DOUBLE PRECISION HWREXQ,HWRGEN,AV,B,BXMAX,R1,R2,XMAX,R,RMIN
      EXTERNAL HWRGEN
      B=2./AV
      BXMAX=B*XMAX
      IF (BXMAX.LT.50) THEN
        RMIN=EXP(-BXMAX)
      ELSE
        RMIN=0
      ENDIF
 10   R1=HWRGEN(0)*(1-RMIN)+RMIN
      R2=HWRGEN(1)*(1-RMIN)+RMIN
      R=R1*R2
      IF (R.LT.RMIN) GOTO 10
      HWREXQ=-LOG(R)/B
      END
CDECK  ID>, HWREXT.
*CMZ :-        -26/04/91  11.11.55  by  Bryan Webber
*-- Author :    David Ward, modified by Bryan Webber
C-----------------------------------------------------------------------
      FUNCTION HWREXT(AM0,B)
C-----------------------------------------------------------------------
C     Random number from dN/d(x**2)=exp(-B*TM) distribution, where
C     TM = SQRT(X**2+AM0**2).  Uses Newton's method to solve F-R=0
C-----------------------------------------------------------------------
      DOUBLE PRECISION HWREXT,HWRGEN,AM0,B,R,A,F,DF,DAM,AM
      INTEGER NIT
      EXTERNAL HWRGEN
      R=HWRGEN(0)
C --- Starting value
      AM=AM0-LOG(R)/B
      DO 1 NIT=1,20
      A=EXP(-B*(AM-AM0))/(1.+B*AM0)
      F=(1.+B*AM)*A-R
      DF=-B**2*AM*A
      DAM=-F/DF
      AM=AM+DAM
      IF(AM.LT.AM0) AM=AM0+.001
      IF(ABS(DAM).LT..001) GOTO 2
   1  CONTINUE
      CALL HWWARN('HWREXT',1,*2)
   2  HWREXT=AM
      END
CDECK  ID>, HWRGAU.
*CMZ :-        -19/05/99  11.11.56  by  Mike Seymour
*-- Author :    Mike Seymour
C-----------------------------------------------------------------------
      FUNCTION HWRGAU(J,A,B)
C-----------------------------------------------------------------------
C     Gaussian random number, mean A, standard deviation B.
C     Generates uncorrelated pairs and throws one of them away.
C-----------------------------------------------------------------------
      INCLUDE 'HERWIG62.INC'
      DOUBLE PRECISION HWRGAU,HWRGEN,A,B,X,TRASH
      INTEGER J
      EXTERNAL HWRGEN
 10   X=HWRGEN(J)
      IF (X.LE.ZERO.OR.X.GT.ONE) GOTO 10
      X=SQRT(-TWO*LOG(X))
      CALL HWRAZM(X,X,TRASH)
      HWRGAU=A+B*X
      END
CDECK  ID>, HWRGEN.
*CMZ :-        -26/04/91  12.42.30  by  Federico Carminati
*-- Author :    F. James, modified by Mike Seymour
C-----------------------------------------------------------------------
      FUNCTION HWRGEN(I)
C-----------------------------------------------------------------------
C     MAIN RANDOM NUMBER GENERATOR
C     USES METHOD OF l'Ecuyer, (VIA F.JAMES, COMP PHYS COMM 60(1990)329)
C-----------------------------------------------------------------------
      IMPLICIT NONE
      DOUBLE PRECISION HWRGEN,HWRSET,HWRGET
      INTEGER I,ISEED(2),K,IZ,JSEED(2)
      SAVE ISEED
      DATA ISEED/12345,67890/
      K=ISEED(1)/53668
      ISEED(1)=40014*(ISEED(1)-K*53668)-K*12211
      IF (ISEED(1).LT.0) ISEED(1)=ISEED(1)+2147483563
      K=ISEED(2)/52774
      ISEED(2)=40692*(ISEED(2)-K*52774)-K*3791
      IF (ISEED(2).LT.0) ISEED(2)=ISEED(2)+2147483399
      IZ=ISEED(1)-ISEED(2)
      IF (IZ.LT.1) IZ=IZ+2147483562
      HWRGEN=DBLE(IZ)*4.656613001013252D-10
C--->                (4.656613001013252D-10 = 1.D0/2147483589)
      RETURN
C-----------------------------------------------------------------------
      ENTRY HWRSET(JSEED)
C-----------------------------------------------------------------------
      IF (JSEED(1).EQ.0.OR.JSEED(2).EQ.0) CALL HWWARN('HWRSET',99,*999)
      ISEED(1)=JSEED(1)
      ISEED(2)=JSEED(2)
      HWRSET=0.0D0
 999  RETURN
C-----------------------------------------------------------------------
      ENTRY HWRGET(JSEED)
C-----------------------------------------------------------------------
      JSEED(1)=ISEED(1)
      JSEED(2)=ISEED(2)
      HWRGET=0.0D0
      RETURN
      END
CDECK  ID>, HWRINT.
*CMZ :-        -26/04/91  11.11.56  by  Bryan Webber
*-- Author :    Bryan Webber
C-----------------------------------------------------------------------
      FUNCTION HWRINT(IMIN,IMAX)
C-----------------------------------------------------------------------
C     RANDOM INTEGER IN [IMIN,IMAX]. N.B. ASSUMES IMAX.GE.IMIN
C-----------------------------------------------------------------------
      DOUBLE PRECISION HWRGEN,RN,ONE
      INTEGER HWRINT,IMIN,IMAX
      EXTERNAL HWRGEN
      PARAMETER (ONE=1.0D0)
    1 RN=HWRGEN(0)
      IF (RN.EQ.ONE) GOTO 1
      RN=RN*(IMAX-IMIN+1)
      HWRINT=IMIN+INT(RN)
      END
CDECK  ID>, HWRLOG.
*CMZ :-        -26/04/91  14.15.56  by  Federico Carminati
*-- Author :    Bryan Webber
C-----------------------------------------------------------------------
      FUNCTION HWRLOG(A)
C-----------------------------------------------------------------------
C     Returns .TRUE. with probability A
C-----------------------------------------------------------------------
      DOUBLE PRECISION HWRGEN,A,R
      LOGICAL HWRLOG
      EXTERNAL HWRGEN
      HWRLOG=.TRUE.
      R=HWRGEN(0)
      IF(R.GT.A) HWRLOG=.FALSE.
      END
CDECK  ID>, HWRPIP.
*CMZ :-        -07/09/00  10:06:23  by Peter Richardson
*-- Author :    Ian Knowles
C-----------------------------------------------------------------------
      SUBROUTINE HWRPIP
C-----------------------------------------------------------------------
C     Generates a random primary IP using a triple Gaussian distribution
C-----------------------------------------------------------------------
      INCLUDE 'HERWIG62.INC'
      DOUBLE PRECISION HWRGAU
      INTEGER I
      EXTERNAL HWRGAU
      DO 10 I=1,3
  10  VTXPIP(I)=HWRGAU(I,ZERO,VIPWID(I))
      VTXPIP(4)=ZERO
      END
CDECK  ID>, HWRPOW.
*CMZ :-        -26/04/91  11.11.56  by  Bryan Webber
*-- Author :    Bryan Webber
C-----------------------------------------------------------------------
      SUBROUTINE HWRPOW(XVAL,XJAC)
C-----------------------------------------------------------------------
C     RETURNS XVAL DISTRIBUTED ON (XMIN,XMAX) LIKE XVAL**XPOW
C     AND CORRESPONDING JACOBIAN FACTOR XJAC
C     SET FIRST=.TRUE. IF NEW XMIN,XMAX OR XPOW
C-----------------------------------------------------------------------
      DOUBLE PRECISION HWRGEN,XVAL,XJAC,XMIN,XMAX,XPOW,P,Q,A,B,C,Z,ZERO
      LOGICAL FIRST
      PARAMETER(ZERO=0.0D0)
      EXTERNAL HWRGEN
      SAVE Q,A,B,C
      COMMON/HWRPIN/XMIN,XMAX,XPOW,FIRST
      IF (FIRST) THEN
        P=XPOW+1.
        IF (P.EQ.ZERO) CALL HWWARN('HWRPOW',500,*999)
        Q=1./P
        A=XMIN**P
        B=XMAX**P-A
        C=B*Q
        FIRST=.FALSE.
      ENDIF
      Z=A+B*HWRGEN(0)
      XVAL=Z**Q
      XJAC=XVAL*C/Z
  999 END
CDECK  ID>, HWRUNG.
*CMZ :-        -26/04/91  14.55.45  by  Federico Carminati
*-- Author :    David Ward, modified by Bryan Webber
C-----------------------------------------------------------------------
      FUNCTION HWRUNG(A,B)
C-----------------------------------------------------------------------
C     Random number from distribution having flat top [-A,A] & gaussian
C     tail of s.d. B
C-----------------------------------------------------------------------
      DOUBLE PRECISION HWRUNG,HWRGAU,HWRUNI,A,B,PRUN,ZERO
      LOGICAL HWRLOG
      EXTERNAL HWRGAU,HWRUNI,HWRLOG
      PARAMETER (ZERO=0.D0)
      IF (A.EQ.ZERO) THEN
        PRUN=0
      ELSE
        PRUN=1./(1.+B*1.2533/A)
      ENDIF
      IF(HWRLOG(PRUN)) THEN
        HWRUNG=HWRUNI(0,-A,A)
      ELSE
        HWRUNG=HWRGAU(0,ZERO,B)
        HWRUNG=HWRUNG+SIGN(A,HWRUNG)
      ENDIF
      END
CDECK  ID>, HWRUNI.
*CMZ :-        -26/04/91  14.55.45  by  Federico Carminati
*-- Author :    Bryan Webber
C-----------------------------------------------------------------------
      FUNCTION HWRUNI(I,A,B)
C-----------------------------------------------------------------------
C     Uniform random random number in range [A,B]
C-----------------------------------------------------------------------
      DOUBLE PRECISION HWRUNI,HWRGEN,A,B,RN
      INTEGER I
      EXTERNAL HWRGEN
      RN=HWRGEN(I)
      HWRUNI=A+RN*(B-A)
      END
CDECK  ID>, HWSBRN.
*CMZ :-        -18/10/99  19.08.45  by  Mike Seymour
*-- Author :    Bryan Webber
C-----------------------------------------------------------------------
      SUBROUTINE HWSBRN(KPAR)
C-----------------------------------------------------------------------
C     DOES BRANCHING OF SPACELIKE PARTON KPAR
C-----------------------------------------------------------------------
      INCLUDE 'HERWIG62.INC'
      DOUBLE PRECISION HWBVMC,HWRGEN,HWRUNI,HWSTAB,HWUALF,HWUTAB,HWSGQQ,
     & HWSSUD,XLAST,QNOW,QLST,QP,QMIN,QLAM,QSAV,SMAX,SLST,SNOW,RN,SUDA,
     & SUDB,ZZ,ENOW,XI,PMOM,DIST(13),DMIN,X1,X2,REJFAC,OTHXI,OTHZ,QTMP,
     & PTMP(2),JAC,OTHJAC,S,T,U
      INTEGER N0,IS,ID,ID1,ID2,IDHAD,N1,I,MQ,NTRY,NDEL,NA,NB,IW1,IW2,
     & KPAR,LPAR,MPAR,ISUD(13),IREJ,NREJ
      LOGICAL HWSVAL,FORCE,VALPAR,FTMP
      EXTERNAL HWBVMC,HWRGEN,HWRUNI,HWSTAB,HWUALF,HWUTAB,HWSGQQ,HWSSUD,
     & HWSVAL
      COMMON/HWTABC/XLAST,N0,IS,ID
      DATA ISUD,DMIN/2,2,3,4,5,6,2,2,3,4,5,6,1,1.D-15/
      IF (IERROR.NE.0) RETURN
      ID=IDPAR(KPAR)
C--TEST FOR PARTON TYPE
      IF (ID.LE.13) THEN
        IS=ISUD(ID)
      ELSEIF (ID.GE.208) THEN
        IS=7
      ELSE
        IS=0
      END IF
      QNOW=-1.
      IF (IS.NE.0) THEN
C--SPACELIKE PARTON BRANCHING
        QLST=PPAR(1,KPAR)
        IDHAD=IDHW(INHAD)
        VALPAR=HWSVAL(ID)
        QP=HWBVMC(ID)
        XLAST=XFACT*PPAR(4,KPAR)
        IF (XLAST.GE.ONE) CALL HWWARN('HWSBRN',107,*999)
C--SET UP Q BOUNDARY
        IF (VALPAR) THEN
          QMIN=QG/(1.-XLAST)
        ELSEIF (ID.EQ.13) THEN
          QMIN=QV/(1.-XLAST)
        ELSE
          QMIN=.5*(QP+QV+SQRT((QP-QV)**2+4.*QP*QV*XLAST))/(1.-XLAST)
        ENDIF
        QSAV=QMIN
        IF (QMIN.LE.QSPAC.AND.ISPAC.LT.2) THEN
          QMIN=QSPAC
          N1=NSPAC(IS)
        ELSEIF (QMIN.LE.QEV(1,IS)) THEN
          QMIN=QEV(1,IS)
          N1=1
        ELSE
          DO 110 I=2,NQEV
          IF (QEV(I,IS).GT.QMIN) GOTO 120
  110     CONTINUE
  120     N1=I-1
        ENDIF
        N0=N1-1
        MQ=NQEV-N0
        NTRY=0
  125   NTRY=NTRY+1
        NREJ=1
        IF (QLST.GT.QMIN.AND..NOT.NOSPAC.OR..NOT.VALPAR) THEN
          IF (QLST.LE.QMIN) THEN
C--CHECK PHASE SPACE FOR FORCED SPLITTING OF NON-VALENCE PARTON
            IF (QLST.LT.QSAV) CALL HWWARN('HWSBRN',ISLENT*105,*999)
            FORCE=.TRUE.
            QNOW=(QLST/QSAV)**HWRGEN(0)*QSAV
          ELSE
C--ENHANCE EMISSION BY A FACTOR OF TWO IF THIS BRANCH
C  IS CAPABLE OF BEING THE HARDEST SO FAR
           IF (QLST.GT.HARDST) NREJ=2
           QTMP=-1
           DO 300 IREJ=1,NREJ
C--FIND NEW VALUE OF SUD/DIST
            CALL HWSFUN(XLAST,QMIN,IDHAD,NSTRU,DIST,JNHAD)
            IF (ID.EQ.13) DIST(ID)=DIST(ID)*HWSGQQ(QMIN)
            IF (DIST(ID).LT.DMIN) DIST(ID)=DMIN
            SMAX=HWUTAB(SUD(N1,IS),QEV(N1,IS),MQ,QMIN,INTER)/DIST(ID)
            CALL HWSFUN(XLAST,QLST,IDHAD,NSTRU,DIST,JNHAD)
            IF (ID.EQ.13) DIST(ID)=DIST(ID)*HWSGQQ(QLST)
            IF (DIST(ID).LT.DMIN) DIST(ID)=DMIN
            SLST=HWUTAB(SUD(N1,IS),QEV(N1,IS),MQ,QLST,INTER)/DIST(ID)
            RN=HWRGEN(0)
            IF (RN.EQ.ZERO) THEN
              SNOW=SLST*2.
            ELSE
              SNOW=SLST/RN
            ENDIF
            IF (VALPAR.AND.SNOW.GE.SMAX) GOTO 200
            IF (SNOW.LT.SMAX.AND..NOT.NOSPAC) THEN
              FORCE=.FALSE.
            ELSE
C--FORCE SPLITTING OF NON-VALENCE PARTON
              FORCE=.TRUE.
              QNOW=(MIN(QLST,1.1*QMIN)/QSAV)**HWRGEN(0)*QSAV
            ENDIF
            IF (QNOW.LT.ZERO) THEN
C--BRANCHING OCCURS. FIRST CHECK FOR MONOTONIC FORM FACTOR
              SUDA=SMAX
              NDEL=32
              NA=N1
  130         NB=NA+NDEL
              IF (NB.GT.NQEV) CALL HWWARN('HWSBRN',103,*999)
              CALL HWSFUN(XLAST,QEV(NB,IS),IDHAD,NSTRU,DIST,JNHAD)
              IF (ID.EQ.13) DIST(ID)=DIST(ID)*HWSGQQ(QEV(NB,IS))
              IF (DIST(ID).LT.DMIN) DIST(ID)=DMIN
              SUDB=SUD(NB,IS)/DIST(ID)
              IF (SUDB.GT.SUDA) THEN
                SUDA=SUDB
                NA=NB
                GOTO 130
              ELSEIF (NA.NE.N1) THEN
                IF (SUDB.LT.SNOW) THEN
                  NDEL=NDEL/2
                  IF (NDEL.EQ.0) CALL HWWARN('HWSBRN',100,*999)
                  GOTO 130
                ENDIF
                N1=NB
                N0=N1-1
                MQ=NQEV-N0
              ENDIF
C--NOW FIND NEW Q
              QNOW=HWSTAB(QEV(N1,IS),HWSSUD,MQ,SNOW,INTER)
              IF (QNOW.LE.QMIN.OR.QNOW.GT.QLST) THEN
C--INTERPOLATION PROBLEM: USE LINEAR INSTEAD
C                CALL HWWARN('HWSBRN',1,*999)
                QNOW=HWRUNI(0,QMIN,QLST)
              ENDIF
            ENDIF
 200        CONTINUE
            IF (QNOW.GT.QTMP) THEN
              QTMP=QNOW
              FTMP=FORCE
            ENDIF
            QNOW=-1
 300       CONTINUE
           QNOW=QTMP
           FORCE=FTMP
          ENDIF
          IF (QNOW.LT.ZERO) GOTO 210
C--NOW FIND NEW X
          CALL HWSFBR(XLAST,QNOW,FORCE,ID,1,ID1,ID2,IW1,IW2,ZZ)
          IF (ID1.LT.0) THEN
C--NO PHASE SPACE FOR BRANCHING
            FROST=.TRUE.
            RETURN
          ELSEIF (ID1.EQ.0) THEN
C--BRANCHING REJECTED: REDUCE Q AND REPEAT
            IF (NTRY.GT.NBTRY.OR.IERROR.NE.0)
     $           CALL HWWARN('HWSBRN',102,*999)
            QLST=QNOW
            QNOW=-1.
            GOTO 125
          ELSEIF (ID1.EQ.59) THEN
C--ANOMALOUS PHOTON SPLITTING: ADD PT TO INTRINSIC PT AND STOP BRANCHING
            IF (IDHAD.NE.59) CALL HWWARN('HWSBRN',109,*999)
            ENOW=PPAR(4,KPAR)/XLAST
            XI=(QNOW/ENOW)**2
            QLAM=QNOW*(1.-XLAST)
            IF ((2.-XI)*QLAM**2.GT.EMSCA**2) THEN
C--BRANCHING REJECTED: REDUCE Q AND REPEAT
              IF (NTRY.GT.NBTRY) CALL HWWARN('HWSBRN',110,*999)
              QLST=QNOW
              QNOW=-1.
              GOTO 125
            ENDIF
            CALL HWRAZM(QNOW*(1.-XLAST),PTMP(1),PTMP(2))
            CALL HWVSUM(2,PTMP,PTINT(1,JNHAD),PTINT(1,JNHAD))
            PTINT(3,JNHAD)=PTINT(1,JNHAD)**2+PTINT(2,JNHAD)**2
            ANOMSC(1,JNHAD)=QNOW
            ANOMSC(2,JNHAD)=QNOW*(1.-XLAST)
            QNOW=-1.
            QLST=QNOW
            GOTO 125
          ELSEIF (FORCE.AND..NOT.HWSVAL(ID1).AND.ID1.NE.13) THEN
C--FORCED BRANCHING PRODUCED A NON-VALENCE PARTON: TRY AGAIN
            IF (NTRY.GT.NBTRY) CALL HWWARN('HWSBRN',108,*999)
            QLST=QNOW
            QNOW=-1.
            GOTO 125
          ENDIF
        ENDIF
  210   CONTINUE
        IF (QNOW.GT.ZERO) THEN
C--BRANCHING HAS OCCURRED
          ENOW=PPAR(4,KPAR)/ZZ
          XI=(QNOW/ENOW)**2
          QLAM=QNOW*(1.-ZZ)
          IF (SUDORD.EQ.1.AND.HWUALF(2,QLAM).LT.HWRGEN(0) .OR.
     &        (2.-XI)*QLAM**2.GT.EMSCA**2.AND..NOT.FORCE) THEN
C--BRANCHING REJECTED: REDUCE Q AND REPEAT
              IF (NTRY.GT.NBTRY) CALL HWWARN('HWSBRN',104,*999)
              QLST=QNOW
              QNOW=-1.
              GOTO 125
          ENDIF
C--IF THIS IS HARDEST EMISSION SO FAR, APPLY MATRIX-ELEMENT CORRECTION
          IF (.NOT.FORCE) THEN
            REJFAC=1
            IF (QLAM.GT.HARDST .AND. ID.NE.13) THEN
              IF (MOD(ISTHEP(JCOPAR(1,1)),10).GE.3) THEN
C---COLOUR PARTNER IS OUTGOING (X1=XP, X2=ZP)
                X2=SQRT((ZZ**2-(1-ZZ)*XI)**2+2*(ZZ*(1-ZZ))**2*XI*(2-XI))
                X1=(ZZ**2+(1-ZZ)*XI-X2)/(2*(1-ZZ)*XI)
                X2=(ZZ**2-(1-ZZ)*XI+X2)/(2*ZZ**2)
                IF (ID2.EQ.13) THEN
C---GLUON EMISSION
                  REJFAC=ZZ**3*(1-X1-X2+2*X1*X2)
     $                 /(X1**2*(1-ZZ)*(ZZ+XI*(1-ZZ)))
     $                 *(1+ZZ**2)/((1-ZZ)*XI)
     $                 *(1-X1)*(1-X2)/
     $                 (1+(1-X1-X2+2*X1*X2)**2+2*(1-X1)*(1-X2)*X1*X2)
C---CHECK WHETHER IT IS IN THE OVERLAP REGION
                  OTHXI=2*(1-X1)/(1-X1+2*(3*X1-2)*X2*(1-X2))
                  IF (OTHXI.LT.ONE) THEN
                    OTHZ=(1-(2*X2-1)*SQRT((3*X1-2)/X1))/2
                    REJFAC=REJFAC+SQRT(3-2/X1)/(X1**2*OTHZ*(1-OTHZ))
     $               *(1+(1-OTHZ)**2)/(OTHZ*OTHXI)
     $               *(1-X1)*(1-X2)/
     $               (1+(1-X1-X2+2*X1*X2)**2+2*(1-X1)*(1-X2)*X1*X2)
                  ENDIF
                ELSEIF (ID1.EQ.13) THEN
C---GLUON SPLITTING
                  REJFAC=ZZ**3*(1-X1-X2+2*X1*X2)
     $                 /(X1**2*(1-ZZ)*(ZZ+XI*(1-ZZ)))
     $                 *(ZZ**2+(1-ZZ)**2)/XI
     $                 *(1-X2)/
     $                 ((  X1+X2-2*X1*X2)**2+2*(1-X1)*(1-X2)*X1*X2
     $                 +(1-X1-X2+2*X1*X2)**2+2*(1-X1)*(1-X2)*X1*X2)
                ENDIF
              ELSE
C---COLOUR PARTNER IS ALSO INCOMING
                T=-(1-ZZ)*XI/ZZ**2
                S=2*(ZZ**2+(1-ZZ)*XI)/(ZZ**2*(2*ZZ+XI*(1-ZZ)))
                U=1-S-T
                JAC=-T*(1-T)/S**2*ZZ**5/(XI*(1-ZZ)**2*(ZZ+XI*(1-ZZ)))
                IF (ID2.EQ.13) THEN
C---GLUON EMISSION
                  REJFAC=(1+ZZ**2)/((1-ZZ)*ZZ*XI)
     &                 *JAC*S**2*T*U/((1-U)**2+(1-T)**2)
C---CHECK WHETHER IT IS IN THE OVERLAPPING REGION
                  OTHZ=(1+SQRT(1-2*U*(1-U)/S))/U
                  OTHXI=2*(1-OTHZ+T/S)/(1-OTHZ)
                  IF (OTHXI.LT.OTHZ**2) THEN
                    OTHJAC=-U*(1-U)/S**2*OTHZ**5/(OTHXI*
     &                   (1-OTHZ)**2*(OTHZ+OTHXI*(1-OTHZ)))
                    REJFAC=REJFAC+(1+OTHZ**2)/((1-OTHZ)*OTHZ*OTHXI)
     &                   *OTHJAC*S**2*T*U/((1-U)**2+(1-T)**2)
                  ENDIF
                ELSEIF (ID1.EQ.13) THEN
C---GLUON SPLITTING
                  REJFAC=-((1-ZZ)**2+ZZ**2)/(ZZ*XI)
     &                 *JAC*S**3*T/((1-S)**2+(1-T)**2)
                ENDIF
              ENDIF
            ENDIF
            IF (NREJ*REJFAC*HWRGEN(NREJ).GT.ONE) THEN
              QLST=QNOW
              QNOW=-1.
              GOTO 125
            ENDIF
            IF (QLAM.GT.HARDST) HARDST=QLAM
          ENDIF
          IF (IW2.GT.IW1) THEN
            LPAR=NPAR+1
            MPAR=NPAR+2
C---NEW MOTHER-DAUGHTER RELATIONS
C   N.B. DEFINED MOVING AWAY FROM HARD PROCESS
            JDAPAR(1,KPAR)=LPAR
            JDAPAR(2,KPAR)=MPAR
C---NEW COLOUR CONNECTIONS
            JCOPAR(3,KPAR)=MPAR
            JCOPAR(4,KPAR)=LPAR
            JCOPAR(1,MPAR)=KPAR
            JCOPAR(2,MPAR)=LPAR
            JCOPAR(1,LPAR)=MPAR
            JCOPAR(2,LPAR)=KPAR
          ELSE
            MPAR=NPAR+1
            LPAR=NPAR+2
            JDAPAR(1,KPAR)=MPAR
            JDAPAR(2,KPAR)=LPAR
            JCOPAR(3,KPAR)=LPAR
            JCOPAR(4,KPAR)=MPAR
            JCOPAR(1,MPAR)=LPAR
            JCOPAR(2,MPAR)=KPAR
            JCOPAR(1,LPAR)=KPAR
            JCOPAR(2,LPAR)=MPAR
          ENDIF
          JMOPAR(1,LPAR)=KPAR
          JMOPAR(1,MPAR)=KPAR
          IDPAR(LPAR)=ID1
          IDPAR(MPAR)=ID2
          TMPAR(LPAR)=.FALSE.
          TMPAR(MPAR)=.TRUE.
          PPAR(1,LPAR)=QNOW
          PPAR(2,LPAR)=XI
          PPAR(4,LPAR)=ENOW
          PPAR(1,MPAR)=QNOW*(1.-ZZ)
          PPAR(2,MPAR)=XI
          PPAR(4,MPAR)=ENOW*(1.-ZZ)
          NPAR=NPAR+2
        ENDIF
      ENDIF
      IF (QNOW.LT.ZERO) THEN
C--BRANCHING STOPS
        JDAPAR(1,KPAR)=0
        JDAPAR(2,KPAR)=0
        JCOPAR(3,KPAR)=0
        JCOPAR(4,KPAR)=0
        IF (ID.LE.13) THEN
C---PUT SPECTATOR (APPROXIMATELY) ON-SHELL
          XLAST=XFACT*PPAR(4,KPAR)
          IF ((1-XLAST)**2.LT.(RMASS(ID)**2+PTINT(3,JNHAD))*XFACT**2)
     &         THEN
            FROST=.TRUE.
            RETURN
          ENDIF
          PPAR(5,KPAR)=-(RMASS(ID)**2*XLAST+PTINT(3,JNHAD))/(1.-XLAST)
     &         +XLAST*SIGN(PHEP(5,INHAD)**2,PHEP(5,INHAD))
        ELSEIF (ID.EQ.IDHW(INHAD)) THEN
C---IF INCOMING PARTON IS INCOMING BEAM, ALLOW IT TO BE OFF-SHELL
          PPAR(5,KPAR)=SIGN(PHEP(5,INHAD)**2,PHEP(5,INHAD))
        ELSE
          PPAR(5,KPAR)=RMASS(ID)**2
        ENDIF
        PMOM=PPAR(4,KPAR)**2-PPAR(5,KPAR)
        IF (PMOM.LT.ZERO) THEN
          FROST=.TRUE.
          RETURN
        ENDIF
        PPAR(3,KPAR)=SQRT(PMOM)
      ENDIF
  999 END
CDECK  ID>, HWSDGG.
*CMZ :=        =26/04/91  12.47.48  by  Federico Carminati
*-- Author :    Drees, Grassie, Charchula, modified by Bryan Webber
C ===============================================================
C  DREES & GRASSIE PARAMETRIZATION OF PHOTON STRUCTURE FUNCTION
C
C    HWSDGQ(X,Q2,NFL,NCH) - X*QUARK_IN_PHOTON/ALPHA  (!)
C    HWSDGG(X,Q2,NFL)     - X*GLUON_IN_PHOTON/ALPHA  (!)
C WHERE:
C        (INTEGER) NCH - QUARK CHARGE: 1 FOR 1/3
C                                      2 FOR 2/3
C        (INTEGER) NFL - NUMBER OF QUARK FLAVOURS /3 OR 4/
C                   Q2 - SQUARE OF MOMENTUM Q /IN GEV2/
C                   X  - LONGITUDINAL FRACTION
C  LAMBDA=0.4 GEV
C
C       NFL=3:     1 < Q2 < 50   GEV^2
C       NFL=4:    20 < Q2 < 500  GEV^2
C       NFL=5:   200 < Q2 < 10^4 GEV^2
C
C
C  KRZYSZTOF CHARCHULA  /14.02.1989/
C================================================================
C
C PS. Note that for the case of three flavors, one has to add
C the QPM charm contribution for getting F2.
C
C================================================================
C MODIFIED FOR HERWIG BY BRW 19/4/91
C--- -----------------------------------------------
C        GLUON PART OF THE PHOTON SF
C--- -----------------------------------------------
      FUNCTION HWSDGG(X,Q2,NFL)
      IMPLICIT REAL (A-H,P-Z)
      INTEGER NFL
      DIMENSION A(3,4,3),AT(3)
      ALAM2=0.160
      T=LOG(Q2/ALAM2)
C- ---  CHECK WHETHER NFL  HAVE RIGHT VALUES -----
      IF (.NOT.((NFL.EQ.3).OR.(NFL.EQ.4).OR.(NFL.EQ.5)))THEN
 130   WRITE(6,131)
 131   FORMAT(' NUMBER OF FLAVOURS(NFL) HAS NOT BEEN SET TO: 3,4 OR 5;'/
     *'          NFL=3 IS ASSUMED')
       NFL=3
      ELSEIF (T.LE.0) THEN
       WRITE(6,132)
 132   FORMAT(' HWSDGG CALLED WITH SCALE < LAMBDA. RETURNING ZERO.')
       HWSDGG=0
       RETURN
      ENDIF
C ------ INITIALIZATION OF PARAMETERS ARRAY -----
      DATA(((A(I,J,K),I=1,3),J=1,4),K=1,3)/
     + -0.20700,-0.19870, 5.11900,
     +  0.61580, 0.62570,-0.27520,
     +  1.07400, 8.35200,-6.99300,
     +  0.00000, 5.02400, 2.29800,
     +    0.8926E-2, 0.05090,-0.23130,
     +    0.659400, 0.27740, 0.13820,
     +    0.476600,-0.39060, 6.54200,
     +    0.019750,-0.32120, 0.51620,
     +  0.031970, -0.618E-2, -0.1216,
     +  1.0180,    0.94760,  0.90470,
     +  0.24610,  -0.60940,  2.6530,
     +  0.027070, -0.010670, 0.2003E-2/
C ------ Q2 DEPENDENCE -----------
      LF=NFL-2
      DO 20 I=1,3
        AT(I)=A(I,1,LF)*T**A(I,2,LF)+A(I,3,LF)*T**(-A(I,4,LF))
 20   CONTINUE
C ------ GLUON DISTRIBUTION -------------
      HWSDGG=AT(1)*X**AT(2)*(1.0-X)**AT(3)/137.
      RETURN
      END
CDECK  ID>, HWSDGQ.
*CMZ :-        -26/04/91  13.04.45  by  Federico Carminati
*-- Author :    Drees, Grassie, Charchula, modified by Bryan Webber
C --------------------------------------
C  QUARK PART OF THE PHOTON SF
C --------------------------------------
      FUNCTION HWSDGQ(X,Q2,NFL,NCH)
      IMPLICIT REAL (A-H,P-Z)
      INTEGER NFL,NCH
      DIMENSION A(5,4,2,3),AT(5,2),XQPOM(2),E(2)
      COMMON/DG/F2
C SQUARE OF LAMBDA=0.4 GEV
      ALAM2=0.160
      T=LOG(Q2/ALAM2)
C
C  CHECK WHETHER NFL AND NCH HAVE RIGHT VALUES
C
      IF(.NOT.((NFL.EQ.3).OR.(NFL.EQ.4).OR.(NFL.EQ.5))) THEN
 110   WRITE(6,111)
 111   FORMAT('NUMBER OF FLAVOURS (NFL) HAS NOT BEEN SET TO: 3,4 OR 5'/
     *'          NFL=3 IS ASSUMED')
       NFL=3
      ELSEIF (T.LE.0) THEN
       WRITE(6,132)
 132   FORMAT(' HWSDGQ CALLED WITH SCALE < LAMBDA. RETURNING ZERO.')
       HWSDGQ=0
       RETURN
      ENDIF
      IF (.NOT.((NCH.EQ.1).OR.(NCH.EQ.2))) THEN
 120     WRITE(6,121)
 121     FORMAT(' QUARK CHARGE NUMBER (NCH) HAS NOT BEEN SET',
     *'           TO 1 OR 2;'/
     *'           NCH=1 IS ASSUMED')
         NCH=1
      ENDIF
C ------ INITIALIZATION ------
      DATA(((A(I,J,K,1),I=1,5),J=1,4),K=1,2)/
     + 2.28500,  6.07300, -0.42020,-0.08080, 0.05530,
     +-0.01530, -0.81320,  0.01780, 0.63460, 1.13600,
     + 1.3300E3,-41.3100,   0.92160, 1.20800, 0.95120,
     + 4.21900,  3.16500,  0.18000, 0.20300, 0.01160,
     +16.6900,   0.17600, -0.02080,-0.01680,-0.19860,
     +-0.79160,  0.04790,  0.3386E-2,1.35300, 1.10000,
     + 1.0990E3,  1.04700,  4.85300, 1.42600, 1.13600,
     + 4.42800,  0.02500,  0.84040, 1.23900,-0.27790/
        DATA(((A(I,J,K,2),I=1,5),J=1,4),K=1,2)/
     +-0.37110,-0.17170, 0.087660,-0.89150,-0.18160,
     + 1.06100, 0.78150, 0.021970, 0.28570, 0.58660,
     + 4.75800, 1.53500, 0.109600, 2.97300, 2.42100,
     +-0.01500, 0.7067E-2,0.204000, 0.11850, 0.40590,
     +-0.12070,25.00000,-0.012300,-0.09190, 0.020150,
     + 1.07100,-1.64800, 1.162000, 0.79120, 0.98690,
     + 1.97700,-0.015630,0.482400, 0.63970,-0.070360,
     +-0.8625E-2,6.43800,-0.011000, 2.32700, 0.016940/
        DATA(((A(I,J,K,3),I=1,5),J=1,4),K=1,2)/
     +15.80,     2.7420,  0.029170,-0.03420, -0.023020,
     +-0.94640, -0.73320, 0.046570, 0.71960,  0.92290,
     +-0.50,     0.71480, 0.17850,  0.73380,  0.58730,
     +-0.21180,  3.2870,  0.048110, 0.081390,-0.79E-4,
     + 6.7340,  59.880,  -0.3226E-2,-0.03321,   0.10590,
     +-1.0080,  -2.9830,  0.84320,  0.94750,  0.69540,
     +-0.085940, 4.480,   0.36160, -0.31980, -0.66630,
     + 0.076250, 0.96860, 0.1383E-2, 0.021320, 0.36830/
      CF=10.0
C ------- EVALUATION OF PARAMETERS IN Q2 ---------
      E(1)=1.0
      IF (NFL.EQ.3) THEN
        E(2)=9.0
        LF=1
      ELSEIF (NFL.EQ.4) THEN
        E(2)=10.0
        LF=2
      ELSEIF (NFL.EQ.5) THEN
        E(2)=55.0/6.0
        LF=3
      ENDIF
      DO 10 J=1,2
        DO 20 I=1,5
           ATP=A(I,1,J,LF)*T**A(I,2,J,LF)
           AT(I,J)=ATP+A(I,3,J,LF)*T**(-A(I,4,J,LF))
 20     CONTINUE
 10   CONTINUE
      DO 30 J=1,2
       POM1=X*(X*X+(1.0-X)**2)/(AT(1,J)-AT(2,J)*ALOG(1.0-X))
       POM2=AT(3,J)*X**AT(4,J)*(1.0-X)**AT(5,J)
       XQPOM(J)=E(J)*POM1+POM2
 30   CONTINUE
C -------  QUARK DISTRIBUTIONS ----------
      IF (NFL.EQ.3) THEN
         IF (NCH.EQ.2) THEN
           HWSDGQ=1.0/6.0*(XQPOM(2)+9.0*XQPOM(1))
         ELSEIF(NCH.EQ.1) THEN
           HWSDGQ=1.0/6.0*(XQPOM(2)-9.0/2.0*XQPOM(1))
         ENDIF
        F2=2.0/9.0*XQPOM(2)+XQPOM(1)
      ELSEIF (NFL.EQ.4) THEN
         IF (NCH.EQ.2) THEN
           HWSDGQ=1.0/8.0*(XQPOM(2)+6.0*XQPOM(1))
         ELSEIF(NCH.EQ.1) THEN
           HWSDGQ=1.0/8.0*(XQPOM(2)-6.0*XQPOM(1))
         ENDIF
        F2=5.0/18.0*XQPOM(2)+XQPOM(1)
      ELSEIF (NFL.EQ.5) THEN
         IF (NCH.EQ.2) THEN
           HWSDGQ=1.0/10.0*(XQPOM(2)+15.0/2.0*XQPOM(1))
         ELSEIF(NCH.EQ.1) THEN
           HWSDGQ=1.0/10.0*(XQPOM(2)-5.0*XQPOM(1))
         ENDIF
        F2=11.0/45.0*XQPOM(2)+XQPOM(1)
      ENDIF
      HWSDGQ=HWSDGQ/137.
      RETURN
      END
CDECK  ID>, HWSFBR.
*CMZ :-        -15/07/92  14.08.45  by  Mike Seymour
*-- Author :    Bryan Webber
C-----------------------------------------------------------------------
      SUBROUTINE HWSFBR(X,QQ,FORCED,ID,IW,ID1,ID2,IW1,IW2,Z)
C-----------------------------------------------------------------------
C     FINDS BRANCHING (ID1->ID+ID2) AND Z=X/X1 IN BACKWARD
C     EVOLUTION AT ENERGY FRACTION X AND SCALE QQ
C
C     FORCED=.TRUE. FORCES SPLITTING OF NON-VALENCE PARTON
C
C     IW,IW1,IW2 ARE COLOUR CONNECTION WORDS
C
C     ID1.LT.0 ON RETURN MEANS NO PHASE SPACE
C     ID1.EQ.0 ON RETURN FLAGS REJECTED BRANCHINGS
C-----------------------------------------------------------------------
      INCLUDE 'HERWIG62.INC'
      DOUBLE PRECISION HWBVMC,HWRGEN,HWUALF,HWUAEM,QP,X,QQ,Z,WQG,WQV,
     & WQP,XQV,ZMIN,ZMAX,YMIN,YMAX,DELY,YY,PSUM,EZ,WQN,WR,ZR,WZ,ZZ,AZ,
     & PVAL,EY,DIST(13),PROB(13,100),PPHO
      INTEGER ID,IW,ID1,ID2,IW1,IW2,NZ,IDHAD,IP,IZ
      LOGICAL HWRLOG,HWSVAL,FORCED,NONF,NONV,PHOTPR
      EXTERNAL HWBVMC,HWRGEN,HWUALF,HWUAEM,HWRLOG,HWSVAL
      ID1=-1
      QP=HWBVMC(ID)
      WQG=1.-QG/QQ
      WQV=1.-QV/QQ
      WQP=1.-QP/QQ
      XQV=X/WQV
      NONV=.NOT.HWSVAL(ID)
      NONF=.NOT.FORCED
    5 IF (ID.EQ.13) THEN
        ZMIN=X
        IF (NONF) THEN
          ZMAX=WQG
        ELSE
          ZMAX=WQV
        ENDIF
      ELSE
        IF (NONV) THEN
          ZMIN=XQV
          IF (NONF) THEN
            ZMAX=WQG
          ELSE
            ZMAX=WQP
          ENDIF
        ELSE
          ZMIN=X
          ZMAX=MAX(WQG,WQP)
        ENDIF
      ENDIF
      IF (ZMIN.GE.ZMAX) RETURN
      ID1=0
C---INTERPOLATION VARIABLE IS Y=LN(Z/(1-Z))
      YMIN=LOG(ZMIN/(1.-ZMIN))
      YMAX=LOG(ZMAX/(1.-ZMAX))
      DELY=YMAX-YMIN
      NZ=MIN(INT(ZBINM*DELY)+1,NZBIN)
      DELY=(YMAX-YMIN)/FLOAT(NZ)
      YY=YMIN+0.5*DELY
      PSUM=0.
      IDHAD=IDHW(INHAD)
C---SET UP TABLES FOR CHOOSING BRANCHING
      DO 40 IZ=1,NZ
      EZ=EXP(YY)
      WR=1.+EZ
      ZR=WR/EZ
      WZ=1./WR
      ZZ=WZ*EZ
      AZ=WZ*ZZ*HWUALF(5-2*SUDORD,MAX(WZ*QQ,QG))
      CALL HWSFUN(X*ZR,QQ,IDHAD,NSTRU,DIST,JNHAD)
      IF (ID.NE.13) THEN
C---SPLITTING INTO QUARK
        DO 10 IP=1,ID-1
   10   PROB(IP,IZ)=PSUM
        IF (NONF) PSUM=PSUM+DIST(ID)*AZ*CFFAC*(1.+ZZ*ZZ)*WR
        DO 20 IP=ID,12
   20   PROB(IP,IZ)=PSUM
        PSUM=PSUM+DIST(13)*AZ*0.5*(ZZ*ZZ+WZ*WZ)
        PROB(13,IZ)=PSUM
      ELSE
C---SPLITTING INTO GLUON
        DO 30 IP=1,12
        PSUM=PSUM+DIST(IP)*AZ*CFFAC*(1.+WZ*WZ)*ZR
   30   PROB(IP,IZ)=PSUM
        IF (NONF) PSUM=PSUM+DIST(13)*AZ*2.*CAFAC*(WZ*ZR+ZZ*WR+WZ*ZZ)
        PROB(13,IZ)=PSUM
      ENDIF
   40 YY=YY+DELY
   50 PHOTPR=IDHAD.EQ.59.AND.ID.NE.13
      IF (PHOTPR) THEN
C---ALLOW ANOMALOUS PHOTON SPLITTING
         PPHO=HWUAEM(-QQ*QQ)*CAFAC*(ZMIN**2+(1.-ZMIN)**2)
     &        *ICHRG(ID)**2/(18.*PIFAC)
         IF (PPHO.GT.(PPHO+PSUM*DELY)*HWRGEN(2)) THEN
C---ANOMALOUS PHOTON SPLITTING OCCURRED
           ID1=59
           RETURN
         ENDIF
       ENDIF
      IF (PSUM.LE.ZERO) RETURN
C---CHOOSE Z
      PVAL=PSUM*HWRGEN(0)
      DO 60 IZ=1,NZ
      IF (PROB(13,IZ).GT.PVAL) GOTO 70
   60 CONTINUE
      IZ=NZ
   70 EY=EXP(YMIN+DELY*(FLOAT(IZ)-HWRGEN(1)))
      ZZ=EY/(1.+EY)
C---CHOOSE BRANCHING
      DO 80 IP=1,13
      IF (PROB(IP,IZ).GT.PVAL) GOTO 90
   80 CONTINUE
      IP=13
C---CHECK THAT Z IS INSIDE PHASE SPACE (RETURN IF NOT)
   90 CONTINUE
      IF (ID.NE.13) THEN
        IF (IP.EQ.ID) THEN
          IF ((NONV.AND.ZZ*WQP.LT.XQV).OR.ZZ.GT.WQG) THEN
            IF (PHOTPR) GOTO 50
            RETURN
          ENDIF
        ELSE
          IF (ZZ.LT.XQV.OR.ZZ.GT.WQP) THEN
            IF (PHOTPR) GOTO 50
            RETURN
          ENDIF
        ENDIF
      ELSE
        IF (IP.EQ.ID) THEN
          IF (ZZ.LT.XQV.OR.ZZ.GT.WQG) RETURN
        ELSEIF (.NOT.HWSVAL(IP)) THEN
          WQN=1.-HWBVMC(IP)/QQ
          IF (ZZ*WQN.LT.XQV.OR.ZZ.GT.WQN) RETURN
        ENDIF
      ENDIF
C---EVERYTHING OK: LABEL NEW BRANCHES
      Z=ZZ
      ID1=IP
      IW1=IW*2
      IW2=IW1+1
      IF (ID.LE.6) THEN
        IF (ID1.EQ.13) THEN
          ID2=ID+6
        ELSE
          ID2=13
          IW2=IW1
        ENDIF
      ELSE IF (ID.NE.13) THEN
        IF (ID1.EQ.13) THEN
          ID2=ID-6
          IW2=IW1
        ELSE
          ID2=13
        ENDIF
      ELSE
        ID2=ID1
        IF (ID1.EQ.13) THEN
          IF (HWRLOG(HALF)) IW2=IW1
        ELSE IF (ID1.GT.6) THEN
          IW2=IW1
        END IF
      END IF
      IF (IW2.EQ.IW1) IW1=IW1+1
  999 END
CDECK  ID>, HWSFUN.
*CMZ :-        -02/05/91  11.30.51  by  Federico Carminati
*-- Author :    Miscellaneous, combined by Bryan Webber
C-----------------------------------------------------------------------
      SUBROUTINE HWSFUN(X,SCALE,IDHAD,NSET,DIST,IBEAM)
C-----------------------------------------------------------------------
C     NUCLEON AND PION STRUCTURE FUNCTIONS DIST=X*QRK(X,Q=SCALE)
C
C     IDHAD = TYPE OF HADRON:
C     73=P  91=PBAR  75=N  93=NBAR  38=PI+  30=PI-  59=PHOTON
C
C     NEW SPECIAL CODES:
C     71=`REMNANT PHOTON' 72=`REMNANT NUCLEON'
C
C     NSET = STRUCTURE FUNCTION SET
C          = 1,2 FOR DUKE+OWENS SETS 1,2 (SOFT/HARD GLUE)
C          = 3,4 FOR EICHTEN ET AL SETS 1,2 (NUCLEON ONLY)
C          = 5   FOR OWENS SET 1.1 (PREPRINT FSU-HEP-910606)
C
C     FOR PHOTON DREES+GRASSIE IS USED
C
C     N.B. IF IBEAM.GT.0.AND.MODPDF(IBEAM).GE.0 THEN NSET IS
C     IGNORED AND CERN PDFLIB WITH AUTHOR GROUP=AUTPDF(IBEAM) AND
C     SET=MODPDF(IBEAM) IS USED.  FOR COMPATABILITY WITH VERSIONS 3
C     AND EARLIER, AUTPDF SHOULD BE SET TO 'MODE'
C     NOTE THAT NO CONSISTENCY CHECK IS MADE, FOR EXAMPLE THAT THE
C     REQUESTED SET FOR A PHOTON IS ACTUALLY A PHOTON SET
C
C     IF (ISPAC.GT.0) SCALE IS REPLACED BY MAX(SCALE,QSPAC)
C
C     FOR PHOTON, IF (PHOMAS.GT.0) THEN QUARK DISTRIBUTIONS ARE
C     SUPPRESSED BY      LOG((Q**2+PHOMAS**2)/(P**2+PHOMAS**2))
C                    L = -------------------------------------- ,
C                        LOG((Q**2+PHOMAS**2)/(     PHOMAS**2))
C     WHILE GLUON DISTRIBUTIONS ARE SUPPRESSED BY L**2,
C     WHERE Q=SCALE AND P=VIRTUALITY OF THE PHOTON
C
C   DUKE+OWENS = D.W.DUKE AND J.F.OWENS, PHYS. REV. D30 (1984) 49 (P/N)
C              + J.F.OWENS, PHYS. REV. D30 (1984) 943 (PI+/-)
C   WITH EXTRA SIGNIFICANT FIGURES VIA ED BERGER
C   WARNING....MOMENTUM SUM RULE BADLY VIOLATED ABOVE 1 TEV
C   DUKE+OWENS SETS 1,2 OBSOLETE. SET 1 UPDATED TO OWENS 1.1 (1991)
C   PION NOT RELIABLE ABOVE SCALE = 50 GEV
C
C   EICHTEN ET AL = E.EICHTEN,I.HINCHLIFFE,K.LANE AND C.QUIGG,
C                   REV. MOD. PHYS. 56 (1984) 579
C   REVISED AS IN   REV. MOD. PHYS. 58 (1986) 1065
C   RELIABLE RANGE : SQRT(5)GEV < SCALE < 10TEV, 1E-4 < X < 1
C
C   DREES+GRASSIE = M.DREES & K.GRASSIE, ZEIT. PHYS. C28 (1985) 451
C   MODIFIED IN     M.DREES & C.S.KIM, DESY 91-039
C                         AND C.S.KIM, DTP/91/16   FOR HEAVY QUARKS
C
C   FOR CERN PDFLIB DETAILS SEE PDFLIB DOC Q ON CERNVM OR
C   CERN_ROOT:[DOC]PDFLIB.TXT ON VXCERN
C-----------------------------------------------------------------------
      INCLUDE 'HERWIG62.INC'
      DOUBLE PRECISION HWSGAM,X,SCALE,XOLD,QOLD,XMWN,QSCA,SS,SMIN,S,T,
     & TMIN,TMAX,VX,AA,VT,WT,UPV,DNV,SEA,STR,CHM,BTM,TOP,GLU,WX,XQSUM,
     & DMIN,TPMIN,TPMAX,DIST(13),G(2),Q0(5),QL(5),F(5),A(6,5),
     & B(3,6,5,4),XQ(6),TX(6),TT(6),TB(6),NEHLQ(8,2),CEHLQ(6,6,2,8,2),
     & BB(4,6,5),VAL(20),USEA,DSEA,TOTAL,SCALEF,FAC,TBMIN(2),TTMIN(2)
      REAL HWSDGG,HWSDGQ,XSP,Q2,P2,W2,EMB2,EMC2,ALAM2,XPGA(-6:6),F2GM,
     & XPVMD,XPANL,XPANH,XPBEH,XPDIR
      COMMON/SASCOM/XPVMD(-6:6),XPANL(-6:6),XPANH(-6:6),XPBEH(-6:6),
     &     XPDIR(-6:6)
      LOGICAL PDFWRX(2,2),PDFWRQ(2,2)
      DOUBLE PRECISION PDFXMN,PDFXMX,PDFQMN,PDFQMX
      COMMON /W50513/PDFXMN,PDFXMX,PDFQMN,PDFQMX
      INTEGER IDHAD,NSET,IBEAM,IOLD,NOLD,IP,I,J,K,NX,IT,IX,IFL,NFL,
     & MPDF,IHAD,ISET,IOP1,IOP2,IP2
      CHARACTER*20 PARM(20)
      EXTERNAL HWSGAM,HWSDGG,HWSDGQ
      SAVE QOLD,IOLD,NOLD,XOLD,SS,S,T,TMIN,TMAX,G,A,TX,TT,TB,IP,NX
      DATA PDFWRX,PDFWRQ/8*.TRUE./
      DATA (((B(I,J,K,1),I=1,3),J=1,6),K=1,5)/
     &3.,0.,0.,.419,.004383,-.007412,
     &3.46,.72432,-.065998,4.4,-4.8644,1.3274,
     &6*0.,1.,
     &0.,0.,.763,-.23696,.025836,4.,.62664,-.019163,
     &0.,-.42068,.032809,6*0.,1.265,-1.1323,.29268,
     &0.,-.37162,-.028977,8.05,1.5877,-.15291,
     &0.,6.3059,-.27342,0.,-10.543,-3.1674,
     &0.,14.698,9.798,0.,.13479,-.074693,
     &-.0355,-.22237,-.057685,6.3494,3.2649,-.90945,
     &0.,-3.0331,1.5042,0.,17.431,-11.255,
     &0.,-17.861,15.571,1.564,-1.7112,.63751,
     &0.,-.94892,.32505,6.,1.4345,-1.0485,
     &9.,-7.1858,.25494,0.,-16.457,10.947,
     &0.,15.261,-10.085/
      DATA (((B(I,J,K,2),I=1,3),J=1,6),K=1,5)/
     &3.,0.,0.,.3743,.013946,-.00031695,
     &3.329,.75343,-.076125,6.032,-6.2153,1.5561,
     &6*0.,1.,0.,
     &0.,.7608,-.2317,.023232,3.83,.62746,-.019155,
     &0.,-.41843,.035972,6*0.,1.6714,-1.9168,.58175,
     &0.,-.27307,-.16392,9.145,.53045,-.76271,
     &0.,15.665,-2.8341,0.,-100.63,44.658,
     &0.,223.24,-116.76,0.,.067368,-.030574,
     &-.11989,-.23293,-.023273,3.5087,3.6554,-.45313,
     &0.,-.47369,.35793,0.,9.5041,-5.4303,
     &0.,-16.563,15.524,.8789,-.97093,.43388,
     &0.,-1.1612,.4759,4.,1.2271,-.25369,
     &9.,-5.6354,-.81747,0.,-7.5438,5.5034,
     &0.,-.59649,.12611/
      DATA (((B(I,J,K,3),I=1,3),J=1,6),K=1,5)/
     &1.,0.,0.,0.4,-0.06212,-0.007109,0.7,0.6478,0.01335,27*0.,
     &0.9,-0.2428,0.1386,0.,-0.2120,0.003671,5.0,0.8673,0.04747,
     &0.,1.266,-2.215,0.,2.382,0.3482,3*0.,
     &0.,0.07928,-0.06134,-0.02212,-0.3785,-0.1088,2.894,9.433,
     &-10.852,0.,5.248,-7.187,0.,8.388,-11.61,3*0.,
     &0.888,-1.802,1.812,0.,-1.576,1.20,3.11,-0.1317,0.5068,
     &6.0,2.801,-12.16,0.,-17.28,20.49,3*0./
      DATA (((B(I,J,K,4),I=1,3),J=1,6),K=1,5)/
     &1.,0.,0.,0.4,-0.05909,-0.006524,0.628,0.6436,0.01451,27*0.,
     &0.90,-0.1417,-0.1740,0.,-0.1697,-0.09623,5.0,-2.474,1.575,
     &0.,-2.534,1.378,0.,0.5621,-0.2701,3*0.,
     &0.,0.06229,-0.04099,-0.0882,-0.2892,-0.1082,1.924,0.2424,
     &2.036,0.,-4.463,5.209,0.,-0.8367,-0.04840,3*0.,
     &0.794,-0.9144,0.5966,0.,-1.237,0.6582,2.89,0.5966,-0.2550,
     &6.0,-3.671,-2.304,0.,-8.191,7.758,3*0./
C---COEFFTS FOR NEW OWENS 1.1 SET
      DATA BB/3.,3*0.,.665,-.1097,-.002442,0.,
     &3.614,.8395,-.02186,0.,.8673,-1.6637,.342,0.,
     &0.,1.1049,-.2369,5*0.,1.,3*0.,
     &.8388,-.2092,.02657,0.,4.667,.7951,.1081,0.,
     &0.,-1.0232,.05799,0.,0.,.8616,.153,5*0.,
     &.909,-.4023,.006305,0.,
     &0.,-.3823,.02766,0.,7.278,-.7904,.8108,0.,
     &0.,-1.6629,.5719,0.,0.,-.01333,.5299,0.,
     &0.,.1211,-.1739,0.,0.,.09469,-.07066,.01236,
     &-.1447,-.402,.1533,-.06479,6.7599,1.6596,.6798,-.8525,
     &0.,-4.4559,3.3756,-.9468,
     &0.,7.862,-3.6591,.03672,0.,-.2472,-.751,.0487,
     &3.017,-4.7347,3.3594,-.9443,0.,-.9342,.5454,-.1668,
     &5.304,1.4654,-1.4292,.7569,0.,-3.9141,2.8445,-.8411,
     &0.,9.0176,-10.426,4.0983,0.,-5.9602,7.515,-2.7329/
C...THE FOLLOWING DATA LINES ARE COEFFICIENTS NEEDED IN THE
C...EICHTEN, HINCHLIFFE, LANE, QUIGG PROTON STRUCTURE FUNCTION
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/
      DATA TBMIN,TTMIN/8.1905,7.4474,11.5528,10.8097/
      DATA XOLD,QOLD,IOLD,NOLD/-1.,0.,0,0/
      DATA DMIN,Q0,QL/0.,2*2.,2*2.236,2.,.2,.4,.2,.29,.177/
      IF (X.LE.ZERO) CALL HWWARN('HWSFUN',100,*999)
      XMWN=ONE-X
      IF (XMWN.LE.ZERO) THEN
        DO 1 I=1,13
          DIST(I)=0
 1      CONTINUE
        RETURN
      ENDIF
C---FREEZE THE SCALE IF REQUIRED
      SCALEF=SCALE
      IF (ISPAC.GT.0) SCALEF=MAX(SCALEF,QSPAC)
C---CHECK IF PDFLIB REQUESTED
      IF (IBEAM.EQ.1.OR.IBEAM.EQ.2) THEN
        MPDF=MODPDF(IBEAM)
      ELSE
        MPDF=-1
      ENDIF
      QSCA=ABS(SCALEF)
      IF (IDHAD.EQ.59.OR.IDHAD.EQ.71) THEN
        IF (MPDF.GE.0) THEN
C---USE PDFLIB PHOTON STRUCTURE FUNCTIONS
          PARM(1)=AUTPDF(IBEAM)
          VAL(1)=FLOAT(MPDF)
C---FIX TO CALL SCHULER-SJOSTRAND CODE
          IF (AUTPDF(IBEAM).EQ.'SaSph') THEN
            XSP=X
            IF (    XSP.LE.ZERO) CALL HWWARN('HWSFUN',102,*999)
            IF (ONE-XSP.LE.ZERO) CALL HWWARN('HWSFUN',103,*999)
            Q2=QSCA**2
            ISET=MOD(MODPDF(IBEAM),10)
            IOP1=MOD(MODPDF(IBEAM)/10,2)
            IOP2=MOD(MODPDF(IBEAM)/20,2)
            IP2=MODPDF(IBEAM)/100
            IF (IOP2.EQ.0) THEN
              P2=0.
            ELSE
              IHAD=IBEAM
              IF (JDAHEP(1,IHAD).NE.0) IHAD=JDAHEP(1,IHAD)
              P2=PHEP(5,IHAD)**2
            ENDIF
            CALL SASGAM(ISET,XSP,Q2,P2,IP2,F2GM,XPGA)
            IF (IOP1.EQ.1 .AND. ISTAT.LT.10) THEN
              DO 5 I=-6,6
 5            XPGA(I)=XPVMD(I)+XPANL(I)+XPBEH(I)+XPDIR(I)
            ENDIF
            UPV=XPGA(2)
            DNV=XPGA(1)
            USEA=XPGA(2)
            DSEA=XPGA(1)
            STR=XPGA(3)
            CHM=XPGA(4)
            BTM=XPGA(5)
            TOP=XPGA(6)
            GLU=XPGA(0)
          ELSE
            CALL PDFSET(PARM,VAL)
            IF (X.LT.PDFXMN.AND.PDFWRX(IBEAM,1) .OR.
     &          X.GT.PDFXMX.AND.PDFWRX(IBEAM,2)) THEN
              CALL HWWARN('HWSFUN',2,*999)
              WRITE (6,'(2A)') ' WARNING: PDFLIB CALLED WITH X',
     &             ' OUTSIDE ALLOWED RANGE!'
              WRITE (6,'(1P,3(A,E9.3))') ' X VALUE=',X,
     &             ', MINIMUM=',PDFXMN,', MAXIMUM=',PDFXMX
              WRITE (6,'(A)') ' NO FURTHER WARNINGS WILL BE ISSUED'
              IF (X.LT.PDFXMN) PDFWRX(IBEAM,1)=.FALSE.
              IF (X.GT.PDFXMX) PDFWRX(IBEAM,2)=.FALSE.
            ENDIF
            IF (QSCA**2.LT.PDFQMN.AND.PDFWRQ(IBEAM,1) .OR.
     &          QSCA**2.GT.PDFQMX.AND.PDFWRQ(IBEAM,2)) THEN
              CALL HWWARN('HWSFUN',3,*999)
              WRITE (6,'(2A)') ' WARNING: PDFLIB CALLED WITH Q',
     &             ' OUTSIDE ALLOWED RANGE!'
              WRITE (6,'(1P,3(A,E9.3))') ' Q VALUE=',QSCA,
     &             ', MINIMUM=',SQRT(PDFQMN),', MAXIMUM=',SQRT(PDFQMX)
              WRITE (6,'(A)') ' NO FURTHER WARNINGS WILL BE ISSUED'
              IF (QSCA**2.LT.PDFQMN) PDFWRQ(IBEAM,1)=.FALSE.
              IF (QSCA**2.GT.PDFQMN) PDFWRQ(IBEAM,2)=.FALSE.
            ENDIF
            CALL STRUCTM(X,QSCA,UPV,DNV,USEA,DSEA,STR,CHM,BTM,TOP,GLU)
          ENDIF
          DIST(1)=DSEA
          DIST(2)=USEA
          DIST(7)=DSEA
          DIST(8)=USEA
        ELSE
          XSP=X
          IF (    XSP.LE.ZERO) CALL HWWARN('HWSFUN',102,*999)
          IF (ONE-XSP.LE.ZERO) CALL HWWARN('HWSFUN',103,*999)
          Q2=SCALEF**2
          W2=Q2*(1-X)/X
          EMC2=4*RMASS(4)**2
          EMB2=4*RMASS(5)**2
          ALAM2=0.160
          NFL=3
          IF (Q2.GT.50.) NFL=4
          IF (Q2.GT.500.) NFL=5
          STR=HWSDGQ(XSP,Q2,NFL,1)
          CHM=HWSDGQ(XSP,Q2,NFL,2)
          GLU=HWSDGG(XSP,Q2,NFL)
          DIST(1)=STR
          DIST(2)=CHM
          DIST(7)=STR
          DIST(8)=CHM
          IF (W2.GT.EMB2) THEN
            BTM=STR
            IF (W2*ALAM2.LT.Q2*EMB2)
     &          BTM=BTM*LOG(W2/EMB2)/LOG(Q2/ALAM2)
          ELSE
            BTM=0.
          ENDIF
          IF (W2.GT.EMC2) THEN
            IF (W2*ALAM2.LT.Q2*EMC2)
     &          CHM=CHM*LOG(W2/EMC2)/LOG(Q2/ALAM2)
          ELSE
            CHM=0.
          ENDIF
          TOP=0.
        ENDIF
C---INCLUDE SUPPRESSION FROM PHOTON VIRTUALITY IF NECESSARY
        IF (PHOMAS.GT.ZERO.AND.(IBEAM.EQ.1.OR.IBEAM.EQ.2)) THEN
          IHAD=IBEAM
          IF (JDAHEP(1,IHAD).NE.0) IHAD=JDAHEP(1,IHAD)
          IF (IDHW(IHAD).EQ.59) THEN
            FAC=LOG((QSCA**2+PHOMAS**2)/(PHEP(5,IHAD)**2+PHOMAS**2))/
     $          LOG((QSCA**2+PHOMAS**2)/(                PHOMAS**2))
            IF (FAC.LT.ZERO) FAC=ZERO
            DIST(1)=DIST(1)*FAC
            DIST(2)=DIST(2)*FAC
            DIST(7)=DIST(7)*FAC
            DIST(8)=DIST(8)*FAC
            STR=STR*FAC
            CHM=CHM*FAC
            BTM=BTM*FAC
            TOP=TOP*FAC
            GLU=GLU*FAC**2
          ELSE
            CALL HWWARN('HWSFUN',1,*999)
          ENDIF
        ENDIF
        GOTO 900
      ENDIF
      IF (MPDF.GE.0) THEN
C---USE PDFLIB NUCLEON STRUCTURE FUNCTIONS
        PARM(1)=AUTPDF(IBEAM)
        VAL(1)=FLOAT(MPDF)
        CALL PDFSET(PARM,VAL)
        IF (X.LT.PDFXMN.AND.PDFWRX(IBEAM,1) .OR.
     &      X.GT.PDFXMX.AND.PDFWRX(IBEAM,2)) THEN
          CALL HWWARN('HWSFUN',4,*999)
          WRITE (6,'(2A)') ' WARNING: PDFLIB CALLED WITH X',
     &         ' OUTSIDE ALLOWED RANGE!'
          WRITE (6,'(1P,3(A,E9.3))') ' X VALUE=',X,
     &         ', MINIMUM=',PDFXMN,', MAXIMUM=',PDFXMX
          WRITE (6,'(A)') ' NO FURTHER WARNINGS WILL BE ISSUED'
          IF (X.LT.PDFXMN) PDFWRX(IBEAM,1)=.FALSE.
          IF (X.GT.PDFXMX) PDFWRX(IBEAM,2)=.FALSE.
        ENDIF
        IF (QSCA**2.LT.PDFQMN.AND.PDFWRQ(IBEAM,1) .OR.
     &      QSCA**2.GT.PDFQMX.AND.PDFWRQ(IBEAM,2)) THEN
          CALL HWWARN('HWSFUN',5,*999)
          WRITE (6,'(2A)') ' WARNING: PDFLIB CALLED WITH Q',
     &         ' OUTSIDE ALLOWED RANGE!'
          WRITE (6,'(1P,3(A,E9.3))') ' Q VALUE=',QSCA,
     &         ', MINIMUM=',SQRT(PDFQMN),', MAXIMUM=',SQRT(PDFQMX)
          WRITE (6,'(A)') ' NO FURTHER WARNINGS WILL BE ISSUED'
          IF (QSCA**2.LT.PDFQMN) PDFWRQ(IBEAM,1)=.FALSE.
          IF (QSCA**2.GT.PDFQMN) PDFWRQ(IBEAM,2)=.FALSE.
        ENDIF
        CALL STRUCTM(X,QSCA,UPV,DNV,USEA,DSEA,STR,CHM,BTM,TOP,GLU)
      ELSE
        IF (QSCA.LT.Q0(NSET)) QSCA=Q0(NSET)
        IF (QSCA.NE.QOLD.OR.IDHAD.NE.IOLD.OR.NSET.NE.NOLD) THEN
C---INITIALIZE
          IF (NSET.LT.1.OR.NSET.GT.5) CALL HWWARN('HWSFUN',400,*999)
          QOLD=QSCA
          IOLD=IDHAD
          NOLD=NSET
          SS=LOG(QSCA/QL(NSET))
          SMIN=LOG(Q0(NSET)/QL(NSET))
          IF (NSET.LT.3.OR.NSET.EQ.5) THEN
            S=LOG(SS/SMIN)
          ELSE
            T=2.*SS
            TMIN=2.*SMIN
            TMAX=2.*LOG(1.E4/QL(NSET))
          ENDIF
          IF (IDHAD.GE.72) THEN
            IF (NSET.LT.3) THEN
              IP=NSET
              DO 10 I=1,5
              DO 10 J=1,6
   10         A(J,I)=B(1,J,I,IP)+S*(B(2,J,I,IP)+S*B(3,J,I,IP))
              DO 20 K=1,2
              AA=ONE+A(2,K)+A(3,K)
   20         G(K)=HWSGAM(AA)/((ONE+A(2,K)*A(4,K)/AA)*HWSGAM(A(2,K))
     &            *HWSGAM(ONE+A(3,K)))
            ELSEIF (NSET.EQ.5) THEN
              DO 21 I=1,5
              DO 21 J=1,6
   21         A(J,I)=BB(1,J,I)+S*(BB(2,J,I)+S*(BB(3,J,I)+S*BB(4,J,I)))
              DO 22 K=1,2
              AA=ONE+A(2,K)+A(3,K)
   22         G(K)=HWSGAM(AA)/((ONE+A(2,K)/AA*(A(4,K)+
     &            (ONE+A(2,K))/(ONE+AA)*A(5,K)))*HWSGAM(A(2,K))
     &            *HWSGAM(ONE+A(3,K)))
            ELSE
              IP=NSET-2
              VT=MAX(-ONE,MIN(ONE,(2.*T-TMAX-TMIN)/(TMAX-TMIN)))
              WT=VT*VT
C...CHEBYSHEV POLYNOMIALS FOR T EXPANSION
              TT(1)=1.
              TT(2)=VT
              TT(3)=   2.*WT- 1.
              TT(4)=  (4.*WT- 3.)*VT
              TT(5)=  (8.*WT- 8.)*WT+1.
              TT(6)=((16.*WT-20.)*WT+5.)*VT
            ENDIF
          ELSEIF (NSET.LT.3) THEN
              IP=NSET+2
              DO 30 I=1,5
              DO 30 J=1,6
   30         A(J,I)=B(1,J,I,IP)+S*(B(2,J,I,IP)+S*B(3,J,I,IP))
              AA=ONE+A(2,1)+A(3,1)
              G(1)=HWSGAM(AA)/(HWSGAM(A(2,1))*HWSGAM(ONE+A(3,1)))
              G(2)=0.
           ENDIF
        ENDIF
C
        IF (NSET.LT.3.OR.NSET.EQ.5) THEN
          DO 50 I=1,5
   50     F(I)=A(1,I)*X**A(2,I)*XMWN**A(3,I)*(ONE+X*
     &        (A(4,I)+X*(A(5,I)  +  X*A(6,I))))
          F(1)=F(1)*G(1)
          F(2)=F(2)*G(2)
          UPV=F(1)-F(2)
          DNV=F(2)
          SEA=F(3)/6.
          STR=SEA
          CHM=F(4)
          BTM=0.
          TOP=0.
          GLU=F(5)
        ELSE
          IF (X.NE.XOLD) THEN
            XOLD=X
            IF (X.GT.0.1) THEN
              NX=1
              VX=(2.*X-1.1)/0.9
            ELSE
              NX=2
              VX=MAX(-ONE,(2.*LOG(X)+11.51293)/6.90776)
            ENDIF
            WX=VX*VX
            TX(1)=1.
            TX(2)=VX
            TX(3)=   2.*WX- 1.
            TX(4)=  (4.*WX- 3.)*VX
            TX(5)=  (8.*WX- 8.)*WX+1.
            TX(6)=((16.*WX-20.)*WX+5.)*VX
          ENDIF
C...CALCULATE STRUCTURE FUNCTIONS
          DO 120 IFL=1,6
          XQSUM=0.
          DO 110 IT=1,6
          DO 110 IX=1,6
  110     XQSUM=XQSUM+CEHLQ(IX,IT,NX,IFL,IP)*TX(IX)*TT(IT)
  120     XQ(IFL)=XQSUM*XMWN**NEHLQ(IFL,IP)
          UPV=XQ(1)
          DNV=XQ(2)
          STR=XQ(5)
          CHM=XQ(6)
          SEA=XQ(3)
          GLU=XQ(4)
C...SPECIAL EXPANSION FOR BOTTOM (THRESHOLD EFFECTS)
          IF (NFLAV.LT.5.OR.T.LE.TBMIN(IP)) THEN
            BTM=0.
          ELSE
            VT=MAX(-ONE,MIN(ONE,(2.*T-TMAX-TBMIN(IP))/(TMAX-TBMIN(IP))))
            WT=VT*VT
            TB(1)=1.
            TB(2)=VT
            TB(3)=   2.*WT- 1.
            TB(4)=  (4.*WT- 3.)*VT
            TB(5)=  (8.*WT- 8.)*WT+1.
            TB(6)=((16.*WT-20.)*WT+5.)*VT
            XQSUM=0.
            DO 130 IT=1,6
            DO 130 IX=1,6
  130       XQSUM=XQSUM+CEHLQ(IX,IT,NX,7,IP)*TX(IX)*TB(IT)
            BTM=XQSUM*XMWN**NEHLQ(7,IP)
          ENDIF
C...SPECIAL EXPANSION FOR TOP (THRESHOLD EFFECTS)
          TPMIN=TTMIN(IP)+TMTOP
C---TMTOP=2.*LOG(TOPMAS/30.)
          TPMAX=TMAX+TMTOP
          IF (NFLAV.LT.6.OR.T.LE.TPMIN) THEN
            TOP=0.
          ELSE
            VT=MAX(-ONE,MIN(ONE,(2.*T-TPMAX-TPMIN)/(TPMAX-TPMIN)))
            WT=VT*VT
            TB(1)=1.
            TB(2)=VT
            TB(3)=   2.*WT- 1.
            TB(4)=  (4.*WT- 3.)*VT
            TB(5)=  (8.*WT- 8.)*WT+1.
            TB(6)=((16.*WT-20.)*WT+5.)*VT
            XQSUM=0.
            DO 150 IT=1,6
            DO 150 IX=1,6
  150       XQSUM=XQSUM+CEHLQ(IX,IT,NX,8,IP)*TX(IX)*TB(IT)
            TOP=XQSUM*XMWN**NEHLQ(8,IP)
          ENDIF
        ENDIF
      ENDIF
      IF (MPDF.LT.0) THEN
        USEA=SEA
        DSEA=USEA
      ENDIF
      IF (IDHAD.EQ.73.OR.IDHAD.EQ.72) THEN
         DIST(1)=DSEA+DNV
         DIST(2)=USEA+UPV
         DIST(7)=DSEA
         DIST(8)=USEA
      ELSEIF (IDHAD.EQ.91) THEN
         DIST(1)=DSEA
         DIST(2)=USEA
         DIST(7)=DSEA+DNV
         DIST(8)=USEA+UPV
      ELSEIF (IDHAD.EQ.75) THEN
         DIST(1)=USEA+UPV
         DIST(2)=DSEA+DNV
         DIST(7)=USEA
         DIST(8)=DSEA
      ELSEIF (IDHAD.EQ.93) THEN
         DIST(1)=USEA
         DIST(2)=DSEA
         DIST(7)=USEA+UPV
         DIST(8)=DSEA+DNV
      ELSEIF (IDHAD.EQ.38) THEN
         DIST(1)=USEA
         DIST(2)=USEA+UPV
         DIST(7)=USEA+UPV
         DIST(8)=USEA
      ELSEIF (IDHAD.EQ.30) THEN
         DIST(1)=USEA+UPV
         DIST(2)=USEA
         DIST(7)=USEA
         DIST(8)=USEA+UPV
      ELSE
         PRINT *,' CALLED HWSFUN FOR IDHAD =',IDHAD
         CALL HWWARN('HWSFUN',400,*999)
      ENDIF
  900 DIST(3)=STR
      DIST(4)=CHM
      DIST(5)=BTM
      DIST(6)=TOP
      DIST(9)=STR
      DIST(10)=CHM
      DIST(11)=BTM
      DIST(12)=TOP
      DIST(13)=GLU
      DO 901 I=1,13
      IF (DIST(I).LT.DMIN) DIST(I)=DMIN
  901 CONTINUE
C---FOR REMNANT NUCLEONS SWITCH OFF VALENCE QUARKS,
C   WHILE MAINTAINING MOMENTUM SUM RULE
      IF (IDHAD.EQ.72) THEN
        TOTAL=0
        DO 910 I=1,13
          TOTAL=TOTAL+DIST(I)
 910    CONTINUE
        DIST(1)=DIST(1)-DNV
        DIST(2)=DIST(2)-UPV
        IF (TOTAL.GT.DNV+UPV) THEN
          DO 920 I=1,13
            DIST(I)=DIST(I)*TOTAL/(TOTAL-DNV-UPV)
 920      CONTINUE
        ENDIF
      ENDIF
  999 END
CDECK  ID>, HWSGAM.
*CMZ :-        -26/04/91  11.11.56  by  Bryan Webber
*-- Author :    Adapted by Bryan Webber
C-----------------------------------------------------------------------
      FUNCTION HWSGAM(ZINPUT)
C-----------------------------------------------------------------------
C   Gamma function computed by eq. 6.1.40, Abramowitz.
C   B(M) = B2m/(2m *(2m-1)) where B2m is the 2m'th Bernoulli number.
C   HLNTPI = .5*LOG(2.*PI)
C-----------------------------------------------------------------------
      DOUBLE PRECISION HWSGAM,ZINPUT,B(10),HLNTPI,Z,SHIFT,G,T,RECZSQ
      INTEGER I
      DATA B/
     1       0.83333333333333333333D-01,   -0.27777777777777777778D-02,
     1       0.79365079365079365079D-03,   -0.59523809523809523810D-03,
     1       0.84175084175084175084D-03,   -0.19175269175269175269D-02,
     1       0.64102564102564102564D-02,   -0.29550653594771241830D-01,
     1       0.17964437236883057316D0  ,    -1.3924322169059011164D0  /
      DATA HLNTPI/0.91893853320467274178D0/
C
C   Shift argument to large value ( > 20 )
C
      Z=ZINPUT
      SHIFT=1.
   10 IF (Z.LT.20.D0) THEN
         SHIFT = SHIFT*Z
         Z = Z + 1.D0
         GOTO 10
      ENDIF
C
C   Compute asymptotic formula
C
      G = (Z-.5D0)*LOG(Z) - Z + HLNTPI
      T = 1.D0/Z
      RECZSQ = T**2
      DO 20 I = 1,10
         G = G + B(I)*T
         T = T*RECZSQ
   20 CONTINUE
      HWSGAM = EXP(G)/SHIFT
      END
CDECK  ID>, HWSGEN.
*CMZ :-        -26/04/91  14.55.45  by  Federico Carminati
*-- Author :    Bryan Webber
C-----------------------------------------------------------------------
      SUBROUTINE HWSGEN(GENEX)
C-----------------------------------------------------------------------
C     GENERATES X VALUES (IF GENEX)
C     EVALUATES STRUCTURE FUNCTIONS AND ENFORCES CUTOFFS ON X
C-----------------------------------------------------------------------
      INCLUDE 'HERWIG62.INC'
      DOUBLE PRECISION HWBVMC,HWRUNI,X,QL
      INTEGER I,J
      LOGICAL GENEX
      EXTERNAL HWBVMC,HWRUNI
      IF (GENEX) THEN
        XX(1)=EXP(HWRUNI(0,ZERO,XLMIN))
        XX(2)=XXMIN/XX(1)
      ENDIF
      DO 10 I=1,2
        J=I
        IF (JDAHEP(1,I).NE.0) J=JDAHEP(1,I)
        X=XX(I)
        QL=(1.-X)*EMSCA
        CALL HWSFUN(X,EMSCA,IDHW(J),NSTRU,DISF(1,I),I)
      DO 10 J=1,13
        IF (QL.LT.HWBVMC(J)) DISF(J,I)=0.
   10 CONTINUE
      END
CDECK  ID>, HWSGQQ.
*CMZ :-        -26/04/91  11.11.56  by  Bryan Webber
*-- Author :    Bryan Webber
C-----------------------------------------------------------------------
      FUNCTION HWSGQQ(QSCA)
C-----------------------------------------------------------------------
C     CORRECTION TO GLUON STRUCTURE FUNCTION FOR BACKWARD EVOLUTION:
C     G->Q-QBAR PART OF FORM FACTOR
C-----------------------------------------------------------------------
      INCLUDE 'HERWIG62.INC'
      DOUBLE PRECISION HWSGQQ,HWUALF,QSCA,GG
      EXTERNAL HWUALF
      GG=HWUALF(1,QSCA)**(-ONE/BETAF)
      IF (GG.LT.ONE) GG=ONE
      IF (QSCA.GT.RMASS(6)) THEN
        HWSGQQ=GG**6
      ELSEIF (QSCA.GT.RMASS(5)) THEN
        HWSGQQ=GG**5
      ELSEIF (QSCA.GT.RMASS(4)) THEN
        HWSGQQ=GG**4
      ELSE
        HWSGQQ=GG**3
      ENDIF
      END
CDECK  ID>, HWSSPC.
*CMZ :-        -26/04/91  11.11.56  by  Bryan Webber
*-- Author :    Bryan Webber
C-----------------------------------------------------------------------
      SUBROUTINE HWSSPC
C-----------------------------------------------------------------------
C     REPLACES SPACELIKE PARTONS BY SPECTATORS
C-----------------------------------------------------------------------
      INCLUDE 'HERWIG62.INC'
      DOUBLE PRECISION HWUSQR,EMSQ,EMTR,EPAR,XPAR,QSQ,PCL(5)
      INTEGER KHEP,IP,JP,IDH,IDP,ISP,IDSPC,JHEP
      EXTERNAL HWUSQR
      IF (IERROR.NE.0) RETURN
      DO 50 KHEP=1,NHEP
      IF (ISTHEP(KHEP).EQ.145.OR.ISTHEP(KHEP).EQ.146) THEN
        IP=ISTHEP(KHEP)-144
        JP=IP
        IF (JDAHEP(1,IP).NE.0) JP=JDAHEP(1,IP)
        IDH=IDHW(JP)
        IDP=IDHW(KHEP)
        IF (IDH.NE.IDP) THEN
          IF (IDH.EQ.59) THEN
C---PHOTON CASE
            IF (IDP.LT.7) THEN
              IDSPC=IDP+6
            ELSEIF (IDP.LT.13) THEN
              IDSPC=IDP-6
            ELSE
              CALL HWWARN('HWSSPC',100,*999)
            ENDIF
C---IDENTIFY SPECTATOR
C   (1) QUARK CASE
          ELSEIF (IDP.LE.3) THEN
            DO 10 ISP=1,12
  10        IF (IDH.EQ.NCLDK(LOCN(IDP,ISP))) GOTO 20
            CALL HWWARN('HWSSPC',101,*999)
  20        IF (ISP.LE.3) THEN
              IDSPC=ISP+6
            ELSEIF (ISP.LE.9) THEN
              IDSPC=ISP+105
            ELSE
              IDSPC=ISP
            ENDIF
C---(2) ANTIQUARK CASE
          ELSEIF (IDP.GT.6.AND.IDP.LE.9) THEN
            IDP=IDP-6
            DO 30 ISP=1,12
  30        IF (IDH.EQ.NCLDK(LOCN(ISP,IDP))) GOTO 40
            CALL HWWARN('HWSSPC',103,*999)
            RETURN
  40        IF (ISP.LE.3) THEN
              IDSPC=ISP
            ELSEIF (ISP.LE.9) THEN
              IDSPC=ISP+111
            ELSE
              IDSPC=ISP-6
            ENDIF
C---SPECIAL CASE FOR REMNANT HADRON
          ELSEIF (IDH.EQ.71.OR.IDH.EQ.72) THEN
            IF (IDP.EQ.13) THEN
              IDSPC=IDP
            ELSE
              CALL HWWARN('HWSSPC',106,*999)
            ENDIF
          ELSE
            CALL HWWARN('HWSSPC',105,*999)
          ENDIF
C---REPLACE PARTON BY SPECTATOR
          IDHW(KHEP)=IDSPC
          IDHEP(KHEP)=IDPDG(IDSPC)
          ISTHEP(KHEP)=146+IP
          EMSQ=SIGN(PHEP(5,KHEP)**2,PHEP(5,KHEP))
          EMTR=EMSQ+PHEP(1,KHEP)**2+PHEP(2,KHEP)**2
          EPAR=PHEP(4,KHEP)
          CALL HWVDIF(4,PHEP(1,JP),PHEP(1,KHEP),PHEP(1,KHEP))
          IF (EPAR**2.LT.10000.*ABS(EMTR)) THEN
            CALL HWUMAS(PHEP(1,KHEP))
          ELSE
C---COMPUTE SPECTATOR MASS ELIMINATING ROUNDING ERRORS
            XPAR=EPAR/PHEP(4,JP)
            QSQ=SIGN(PHEP(5,JP)**2,PHEP(5,JP))
            PHEP(5,KHEP)=HWUSQR((1.-XPAR)*QSQ+EMSQ-EMTR/XPAR
     &                 -((QSQ*XPAR**2-EMTR)/(2*EPAR*XPAR**2))**2*XPAR)
          ENDIF
C---CHECK FOR UNPHYSICAL SPECTATOR
          IF (PHEP(4,KHEP).LT.ZERO) FROST=.TRUE.
C---FIND MASS OF CORRESPONDING CLUSTER, IF PARTNER IS IN THE SAME JET
          IF (QORQQB(IDHW(KHEP))) THEN
            JHEP=JMOHEP(2,KHEP)
          ELSEIF (QBORQQ(IDHW(KHEP))) THEN
            JHEP=JDAHEP(2,KHEP)
          ELSE
            JHEP=0
          ENDIF
          IF (JHEP.GT.0) THEN
            CALL HWVSUM(4,PHEP(1,KHEP),PHEP(1,JHEP),PCL)
            CALL HWUMAS(PCL)
C---IF IT IS NEGATIVE, REJECT
            IF (PCL(5).LT.ZERO) FROST=.TRUE.
          ENDIF
        ENDIF
      ENDIF
  50  CONTINUE
  999 END
CDECK  ID>, HWSSUD.
*CMZ :-        -26/04/91  11.11.56  by  Bryan Webber
*-- Author :    Bryan Webber
C-----------------------------------------------------------------------
      FUNCTION HWSSUD(I)
C-----------------------------------------------------------------------
      INCLUDE 'HERWIG62.INC'
      DOUBLE PRECISION HWSSUD,HWSGQQ,DMIN,QSCA,XLAST,DIST(13)
      INTEGER I,N0,IS,ID
      EXTERNAL HWSGQQ
      COMMON/HWTABC/XLAST,N0,IS,ID
      DATA DMIN/1.D-15/
      QSCA=QEV(N0+I,IS)
      CALL HWSFUN(XLAST,QSCA,IDHW(INHAD),NSTRU,DIST,JNHAD)
      IF (ID.EQ.13) DIST(ID)=DIST(ID)*HWSGQQ(QSCA)
      IF (DIST(ID).LT.DMIN) DIST(ID)=DMIN
      HWSSUD=SUD(N0+I,IS)/DIST(ID)
      END
CDECK  ID>, HWSTAB.
*CMZ :-        -26/04/91  11.11.56  by  Bryan Webber
*-- Author :    Adapted by Bryan Webber
C-----------------------------------------------------------------------
      FUNCTION HWSTAB(F,AFUN,NN,X,MM)
C-----------------------------------------------------------------------
C     MODIFIED CERN INTERPOLATION ROUTINE DIVDIF
C     LIKE HWUTAB BUT USES FUNCTION AFUN IN PLACE OF ARRAY A
C-----------------------------------------------------------------------
      IMPLICIT NONE
      INTEGER NN,MM,MMAX,N,M,MPLUS,IX,IY,MID,NPTS,IP,I,J,L,ISUB
      DOUBLE PRECISION HWSTAB,AFUN,SUM,X,F(NN),T(20),D(20)
      LOGICAL EXTRA
      EXTERNAL AFUN
      DATA MMAX/10/
      N=NN
      M=MIN(MM,MMAX,N-1)
      MPLUS=M+1
      IX=0
      IY=N+1
      IF (AFUN(1).GT.AFUN(N)) GOTO 94
   91 MID=(IX+IY)/2
      IF (X.GE.AFUN(MID)) GOTO 92
      IY=MID
      GOTO 93
   92 IX=MID
   93 IF (IY-IX.GT.1) GOTO 91
      GOTO 97
   94 MID=(IX+IY)/2
      IF (X.LE.AFUN(MID)) GOTO 95
      IY=MID
      GOTO 96
   95 IX=MID
   96 IF (IY-IX.GT.1) GOTO 94
   97 NPTS=M+2-MOD(M,2)
      IP=0
      L=0
      GOTO 99
   98 L=-L
      IF (L.GE.0) L=L+1
   99 ISUB=IX+L
      IF ((1.LE.ISUB).AND.(ISUB.LE.N)) GOTO 100
      NPTS=MPLUS
      GOTO 101
  100 IP=IP+1
      T(IP)=AFUN(ISUB)
      D(IP)=F(ISUB)
  101 IF (IP.LT.NPTS) GOTO 98
      EXTRA=NPTS.NE.MPLUS
      DO 14 L=1,M
      IF (.NOT.EXTRA) GOTO 12
      ISUB=MPLUS-L
      D(M+2)=(D(M+2)-D(M))/(T(M+2)-T(ISUB))
   12 I=MPLUS
      DO 13 J=L,M
      ISUB=I-L
      D(I)=(D(I)-D(I-1))/(T(I)-T(ISUB))
      I=I-1
   13 CONTINUE
   14 CONTINUE
      SUM=D(MPLUS)
      IF (EXTRA) SUM=0.5*(SUM+D(M+2))
      J=M
      DO 15 L=1,M
      SUM=D(J)+(X-T(J))*SUM
      J=J-1
   15 CONTINUE
      HWSTAB=SUM
      END
CDECK  ID>, HWSVAL.
*CMZ :-        -26/04/91  10.18.58  by  Bryan Webber
*-- Author :    Bryan Webber
C-----------------------------------------------------------------------
      FUNCTION HWSVAL(ID)
C-----------------------------------------------------------------------
C     TRUE FOR VALENCE PARTON ID IN INCOMING HADRON INHAD
C-----------------------------------------------------------------------
      INCLUDE 'HERWIG62.INC'
      INTEGER ID,IDHAD
      LOGICAL HWSVAL
      HWSVAL=.FALSE.
      IDHAD=IDHW(INHAD)
      IF (IDHAD.EQ.73.OR.IDHAD.EQ.75) THEN
        IF (ID.EQ.1.OR.ID.EQ.2) HWSVAL=.TRUE.
      ELSEIF (IDHAD.EQ.91.OR.IDHAD.EQ.93) THEN
        IF (ID.EQ.7.OR.ID.EQ.8) HWSVAL=.TRUE.
      ELSEIF (IDHAD.EQ.30) THEN
        IF (ID.EQ.1.OR.ID.EQ.8) HWSVAL=.TRUE.
      ELSEIF (IDHAD.EQ.38) THEN
        IF (ID.EQ.2.OR.ID.EQ.7) HWSVAL=.TRUE.
      ELSEIF (IDHAD.EQ.59) THEN
        IF (ID.LT.6.OR.(ID.GT.6.AND.ID.LT.12)) HWSVAL=.TRUE.
      ELSEIF (IDHAD.EQ.71.OR.IDHAD.EQ.72) THEN
        IF (ID.EQ.13) HWSVAL=.TRUE.
      ELSE
        CALL HWWARN('HWSVAL',100,*999)
      ENDIF
  999 END
CDECK  ID>, HWUAEM.
*CMZ :-        -23/08/94  13.22.29  by  Mike Seymour
*-- Author :    Ian Knowles
C-----------------------------------------------------------------------
      FUNCTION HWUAEM(Q2)
C-----------------------------------------------------------------------
C     Running electromagnetic coupling constant.
C     See R. Kleiss et al.: CERN yellow report 89-08, vol.3 p.129
C     Hadronic component from: H. Burkhardt et al.: Z. Phys C43 (89) 497
C-----------------------------------------------------------------------
      INCLUDE 'HERWIG62.INC'
      DOUBLE PRECISION HWUAEM,HWUAER,Q2,EPS,A1,B1,C1,A2,B2,C2,A3,B3,C3,
     & A4,B4,C4,AEMPI,EEL2,EMU2,ETAU2,ETOP2,REPIGG,X
      LOGICAL FIRST
      EXTERNAL HWUAER
      SAVE FIRST,AEMPI,EEL2,EMU2,ETAU2,ETOP2
      PARAMETER (EPS=1.D-6)
      DATA A1,B1,C1/0.0    ,0.00835,1.000/
      DATA A2,B2,C2/0.0    ,0.00238,3.927/
      DATA A3,B3,C3/0.00165,0.00299,1.000/
      DATA A4,B4,C4/0.00221,0.00293,1.000/
      DATA FIRST/.TRUE./
      IF (FIRST) THEN
         AEMPI=ALPHEM/(THREE*PIFAC)
         EEL2 =RMASS(121)**2
         EMU2 =RMASS(123)**2
         ETAU2=RMASS(125)**2
         ETOP2=RMASS(6)**2
         FIRST=.FALSE.
      ENDIF
      IF (ABS(Q2).LT.EPS) THEN
          HWUAEM=ALPHEM
          RETURN
      ENDIF
C Leptonic component
      REPIGG=AEMPI*(HWUAER(EEL2/Q2)+HWUAER(EMU2/Q2)+HWUAER(ETAU2/Q2))
C Hadronic component from light quarks
      X=ABS(Q2)
      IF (X.LT.9.D-2) THEN
          REPIGG=REPIGG+A1+B1*LOG(ONE+C1*X)
      ELSEIF (X.LT.9.D0) THEN
          REPIGG=REPIGG+A2+B2*LOG(ONE+C2*X)
      ELSEIF (X.LT.1.D4) THEN
          REPIGG=REPIGG+A3+B3*LOG(ONE+C3*X)
      ELSE
          REPIGG=REPIGG+A4+B4*LOG(ONE+C4*X)
      ENDIF
C Top Contribution
      REPIGG=REPIGG+AEMPI*HWUAER(ETOP2/Q2)
      HWUAEM=ALPHEM/(ONE-REPIGG)
      RETURN
      END
CDECK  ID>, HWUAER.
*CMZ :-        -23/08/94  13.22.29  by  Mike Seymour
*-- Author :    Ian Knowles
C-----------------------------------------------------------------------
      FUNCTION HWUAER(R)
C-----------------------------------------------------------------------
C     Real part of photon self-energy: Pi_{gg}(R=M^2/Q^2)
C-----------------------------------------------------------------------
      DOUBLE PRECISION HWUAER,R,ZERO,ONE,TWO,FOUR,FVTHR,THIRD,RMAX,BETA
      PARAMETER (ZERO=0.D0, ONE=1.D0, TWO=2.D0, FOUR=4.D0,
     &           FVTHR=1.666666666666667D0, THIRD=.3333333333333333D0)
      PARAMETER (RMAX=1.D6)
      IF (ABS(R).LT.1.D-3) THEN
C Use assymptotic formula
         HWUAER=-FVTHR-LOG(ABS(R))
      ELSEIF (ABS(R).GT.RMAX) THEN
         HWUAER=ZERO
      ELSEIF (FOUR*R.GT.ONE) THEN
         BETA=SQRT(FOUR*R-ONE)
         HWUAER=THIRD
     &         -(ONE+TWO*R)*(TWO-BETA*ACOS(ONE-ONE/(TWO*R)))
      ELSE
         BETA=SQRT(ONE-FOUR*R)
         HWUAER=THIRD
     &         -(ONE+TWO*R)*(TWO+BETA*LOG(ABS((BETA-ONE)/(BETA+ONE))))
      ENDIF
      RETURN
      END
CDECK  ID>, HWUALF.
*CMZ :-        -15/07/92  14.08.45  by  Mike Seymour
*-- Author :    Bryan Webber
C-----------------------------------------------------------------------
      FUNCTION HWUALF(IOPT,SCALE)
C-----------------------------------------------------------------------
C     STRONG COUPLING CONSTANT
C     IOPT.EQ.0  INITIALIZES
C         .EQ.1  TWO-LOOP, FLAVOUR THRESHOLDS
C         .EQ.2  RATIO OF ABOVE TO ONE-LOOP
C                WITH 5-FLAVOUR BETA, LAMBDA=QCDL3
C         .EQ.3  ONE-LOOP WITH 5-FLAVOUR BETA, LAMBDA=QCDL3
C-----------------------------------------------------------------------
      INCLUDE 'HERWIG62.INC'
      DOUBLE PRECISION HWUALF,SCALE,KAFAC,B3,B4,B5,B6,C3,C4,C5,C6,C35,
     & C45,C65,D35,RHO,RAT,RLF,DRH,EPS
      INTEGER IOPT,ITN
      SAVE B3,B4,B5,B6,C3,C4,C5,C6,C35,C45,C65,D35
      DATA EPS/1.D-6/
      IF (IOPT.EQ.0) THEN
C---INITIALIZE CONSTANTS
        CAFAC=FLOAT(NCOLO)
        CFFAC=FLOAT(NCOLO**2-1)/(2.*CAFAC)
        B3=((11.*CAFAC)- 6.)/(12.*PIFAC)
        B4=((11.*CAFAC)- 8.)/(12.*PIFAC)
        B5=((11.*CAFAC)-10.)/(12.*PIFAC)
        B6=((11.*CAFAC)-12.)/(12.*PIFAC)
        BETAF=6.*PIFAC*B5
        C3=((17.*CAFAC**2)-(5.*CAFAC+3.*CFFAC)*3.)/(24.*PIFAC**2)/B3**2
        C4=((17.*CAFAC**2)-(5.*CAFAC+3.*CFFAC)*4.)/(24.*PIFAC**2)/B4**2
        C5=((17.*CAFAC**2)-(5.*CAFAC+3.*CFFAC)*5.)/(24.*PIFAC**2)/B5**2
        C6=((17.*CAFAC**2)-(5.*CAFAC+3.*CFFAC)*6.)/(24.*PIFAC**2)/B6**2
        KAFAC=CAFAC*(67./18.-PIFAC**2/6.)-25./9.
C---QCDLAM IS 5-FLAVOUR LAMBDA-MS-BAR AT LARGE X OR Z
C---QCDL5  IS 5-FLAVOUR LAMBDA-MC
        QCDL5=QCDLAM*EXP(KAFAC/(4.*PIFAC*B5))/SQRT(2.D0)
C---COMPUTE THRESHOLD MATCHING
        RHO=2.*LOG(RMASS(6)/QCDL5)
        RAT=LOG(RHO)/RHO
        C65=(B5/(1.-C5*RAT)-B6/(1.-C6*RAT))*RHO
        RHO=2.*LOG(RMASS(5)/QCDL5)
        RAT=LOG(RHO)/RHO
        C45=(B5/(1.-C5*RAT)-B4/(1.-C4*RAT))*RHO
        RHO=2.*LOG(RMASS(4)/QCDL5)
        RAT=LOG(RHO)/RHO
        C35=(B4/(1.-C4*RAT)-B3/(1.-C3*RAT))*RHO+C45
C---FIND QCDL3
        D35=-1./(B3*C35)
        DO 10 ITN=1,100
          RAT=LOG(D35)/D35
          RLF=B3*D35/(1.-C3*RAT)
          DRH=B3*(RLF+C35)*D35**2/((1.-2.*C3*RAT+C3/D35)*RLF**2)
          D35=D35-DRH
          IF (ABS(DRH).LT.EPS*D35) GOTO 20
   10   CONTINUE
   20   QCDL3=QCDL5*EXP(0.5*D35)
      ENDIF
      IF (SCALE.LE.QCDL5) CALL HWWARN('HWUALF',51,*999)
      RHO=2.*LOG(SCALE/QCDL5)
      IF (IOPT.EQ.3) THEN
        IF (RHO.LE.D35) CALL HWWARN('HWUALF',52,*999)
        HWUALF=1./(B5*(RHO-D35))
        RETURN
      ENDIF
      RAT=LOG(RHO)/RHO
      IF (SCALE.GT.RMASS(6)) THEN
        RLF=B6*RHO/(1.-C6*RAT)+C65
      ELSEIF (SCALE.GT.RMASS(5)) THEN
        RLF=B5*RHO/(1.-C5*RAT)
      ELSEIF (SCALE.GT.RMASS(4)) THEN
        RLF=B4*RHO/(1.-C4*RAT)+C45
      ELSE
        RLF=B3*RHO/(1.-C3*RAT)+C35
      ENDIF
      IF (RLF.LE.ZERO) CALL HWWARN('HWUALF',53,*999)
      IF (IOPT.EQ.1) THEN
        HWUALF=1./RLF
      ELSE
        HWUALF=B5*(RHO-D35)/RLF
        IF (HWUALF.GT.ONE) CALL HWWARN('HWUALF',54,*999)
      ENDIF
      RETURN
 999  HWUALF=ZERO
      END
CDECK  ID>, HWUANT.
*CMZ :-        -27/07/99  13.33.03  by  Mike Seymour
*-- Author :    Ian Knowles
C-----------------------------------------------------------------------
      FUNCTION HWUANT(IPART)
C-----------------------------------------------------------------------
C     Returns the antiparticle of IPART; uses HERWIG numbering
C-----------------------------------------------------------------------
      INCLUDE 'HERWIG62.INC'
      INTEGER HWUANT,IPART,IPDG,IANTI,OLDERR
      CHARACTER*8 CDUM
      OLDERR=IERROR
      IPDG=IDPDG(IPART)
      IF (IPDG.EQ. 9.OR.IPDG.EQ.21.OR.IPDG.EQ.22.OR.IPDG.EQ.23.OR.
     &    IPDG.EQ.25.OR.IPDG.EQ.26.OR.IPDG.EQ.32.OR.IPDG.EQ.35.OR.
     &    IPDG.EQ.36.OR.IPDG.EQ.39.OR.IPDG.EQ.91.OR.IPDG.EQ.98.OR.
     &    IPDG.EQ.99.OR.IPDG.EQ.130.OR.IPDG.EQ.310.OR.
     &    IPDG.EQ.1000021.OR.IPDG.EQ.1000022.OR.IPDG.EQ.1000023.OR.
     &    IPDG.EQ.1000025.OR.IPDG.EQ.1000035.OR.IPDG.EQ.1000039.OR.
     &    (FLOAT(INT(RSPIN(IPART))).EQ.RSPIN(IPART).AND.
     &     MOD(IPDG/100,10).EQ.MOD(IPDG/10,10).AND.
     &     MOD(IPDG/10,10).NE.0)) THEN
C Self-conjugate boson
        IANTI=IPART
      ELSEIF(IPART.EQ.211.OR.IPART.EQ.212) THEN
C Fourth generation (anti-)quarks
        IANTI=IPART+6
      ELSEIF(IPART.EQ.217.OR.IPART.EQ.218) THEN
        IANTI=IPART-6
      ELSE
C Non-zero charge particle
        CALL HWUIDT(1,-IPDG,IANTI,CDUM)
      ENDIF
      IF (IANTI.EQ.20) WRITE(6,10) RNAME(IPART)
  10  FORMAT(1X,A8,' has no antiparticle'/)
      HWUANT=IANTI
      IERROR=OLDERR
      END
CDECK  ID>, HWUATS.
*CMZ :-        -07/07/99  17.42.00  by  Kosuke Odagiri
*-- Author :    Kosuke Odagiri
C-----------------------------------------------------------------------
      SUBROUTINE HWUATS
C-----------------------------------------------------------------------
C     Replaces all &'s in TXNAME by \'s
C-----------------------------------------------------------------------
      INCLUDE 'HERWIG62.INC'
      INTEGER I,J,L
      CHARACTER*1 Z
      Z=CHAR(92)
      L=LEN(TXNAME(1,1))
      DO 1 I=0,NMXRES
        DO 2 J=1,L
          IF (TXNAME(1,I)(J:J).EQ.'&') TXNAME(1,I)(J:J)=Z
 2      CONTINUE
 1    CONTINUE
      END
CDECK  ID>, HWUBPR.
*CMZ :-        -26/04/91  10.18.58  by  Bryan Webber
*-- Author :    Bryan Webber
C-----------------------------------------------------------------------
      SUBROUTINE HWUBPR
C-----------------------------------------------------------------------
C     PRINTS OUT DATA ON PARTON SHOWER
C-----------------------------------------------------------------------
      INCLUDE 'HERWIG62.INC'
      INTEGER I,J
      IF (PRVTX) THEN
        WRITE(6,10) INHAD,XFACT
  10    FORMAT(///10X,'DATA ON LAST PARTON SHOWER:   INHAD =',I3,
     &  '    XFACT =',E11.3//'  IPAR ID     TM  DA1 CMO AMO CDA',
     &  ' ADA  P-X     P-Y     P-Z   ENERGY    MASS',
     &  '   V-X        V-Y        V-Z        V-C*T')
        DO 20 J=1,NPAR
  20    WRITE(6,30) J,RNAME(ABS(IDPAR(J))),TMPAR(J),JDAPAR(1,J),
     &   (JCOPAR(I,J),I=1,4),(PPAR(I,J),I=1,5),(VPAR(I,J),I=1,4)
  30    FORMAT(I5,1X,A8,L2,5I4,F7.2,4F8.2,4E11.4)
      ELSE
        WRITE(6,40) INHAD,XFACT
  40    FORMAT(///10X,'DATA ON LAST PARTON SHOWER:   INHAD =',I3,
     &  '    XFACT =',E11.3//'  IPAR ID     TM  DA1 CMO AMO CDA',
     &  ' ADA  P-X     P-Y     P-Z   ENERGY    MASS')
        DO 50 J=1,NPAR
  50    WRITE(6,60) J,RNAME(ABS(IDPAR(J))),TMPAR(J),JDAPAR(1,J),
     &   (JCOPAR(I,J),I=1,4),(PPAR(I,J),I=1,5)
  60    FORMAT(I5,1X,A8,L2,5I4,F7.2,4F8.2)
      ENDIF
      END
CDECK  ID>, HWUBST.
*CMZ :-        -18/10/93  10.21.56  by  Mike Seymour
*-- Author :    Mike Seymour
C-----------------------------------------------------------------------
      SUBROUTINE HWUBST(IOPT)
C-----------------------------------------------------------------------
C     BOOST THE ENTIRE EVENT RECORD TO (IOPT=1) OR FROM (IOPT=0) ITS
C     CENTRE-OF-MASS FRAME, WITH INCOMING HADRONS ON Z-AXIS
C-----------------------------------------------------------------------
      INCLUDE 'HERWIG62.INC'
      DOUBLE PRECISION PBOOST(5),RBOOST(3,3)
      INTEGER IOPT,IHEP,BOOSTD,IHAD
      SAVE BOOSTD,PBOOST,RBOOST
      DATA BOOSTD/-1/
      IF (IERROR.NE.0) RETURN
      IF (IOPT.EQ.1) THEN
C---FIND FIRST INCOMING HADRON
        IHAD=1
        IF (JDAHEP(1,IHAD).NE.0) IHAD=JDAHEP(1,IHAD)
C---IF WE'RE ALREADY IN THE RIGHT FRAME, DON'T DO ANYTHING
        IF (PHEP(1,3)**2+PHEP(2,3)**2+PHEP(3,3)**2.EQ.ZERO .AND.
     &      PHEP(1,IHAD)**2+PHEP(2,IHAD)**2.EQ.ZERO) RETURN
C---FIND AND APPLY BOOST
        CALL HWVEQU(5,PHEP(1,3),PBOOST)
        DO 100 IHEP=1,NHEP
          CALL HWULOF(PBOOST,PHEP(1,IHEP),PHEP(1,IHEP))
          CALL HWULOF(PBOOST,VHEP(1,IHEP),VHEP(1,IHEP))
 100    CONTINUE
        CALL HWULOF(PBOOST,VTXPIP,VTXPIP)
C---FIND AND APPLY ROTATION TO PUT IT ON Z-AXIS
        CALL HWUROT(PHEP(1,IHAD),ONE,ZERO,RBOOST)
        DO 110 IHEP=1,NHEP
          CALL HWUROF(RBOOST,PHEP(1,IHEP),PHEP(1,IHEP))
          CALL HWUROF(RBOOST,VHEP(1,IHEP),VHEP(1,IHEP))
 110    CONTINUE
        CALL HWUROF(RBOOST,VTXPIP,VTXPIP)
C---ENSURE THAT WE ONLY EVER UNBOOST THE SAME EVENT THAT WE BOOSTED
C   (BEARING IN MIND THAT NWGTS IS UPDATED AFTER GENERATING THE WEIGHT)
        BOOSTD=NWGTS+1
      ELSEIF (IOPT.EQ.0) THEN
        IF (BOOSTD.NE.NWGTS) RETURN
C---UNDO ROTATION AND BOOST
        DO 200 IHEP=1,NHEP
          CALL HWUROB(RBOOST,PHEP(1,IHEP),PHEP(1,IHEP))
          CALL HWULOB(PBOOST,PHEP(1,IHEP),PHEP(1,IHEP))
          CALL HWUROB(RBOOST,VHEP(1,IHEP),VHEP(1,IHEP))
          CALL HWULB4(PBOOST,VHEP(1,IHEP),VHEP(1,IHEP))
 200    CONTINUE
      ENDIF
      END
CDECK  ID>, HWUCFF.
*CMZ :-        -23/08/94  13.22.29  by  Mike Seymour
*-- Author :    Bryan Webber and Ian Knowles
C-----------------------------------------------------------------------
      SUBROUTINE HWUCFF(I,J,QSQ,CLF)
C-----------------------------------------------------------------------
C     Calculates basic coefficients in cross-section formula for
C     ffbar --> f'fbar', at virtuality QSQ, I labels initial, J
C     labels final fermion; type given as:
C        I,J= 1- 6: d,u,s,c,b,t
C           =11-16: e,nu_e,mu,nu_mu,tau,nu_tau
C-----------------------------------------------------------------------
      INCLUDE 'HERWIG62.INC'
      DOUBLE PRECISION QSQ,CLF(7),POL1,POL2,QIF,VI,AI,VF,AF,PG,DQM,PMW,
     & DEN,XRE,XIM,XSQ,VI2,AI2,VF2,AF2,PG2,PG12,DQM2,PMW2,DEN2,XRE2,
     & XIM2,XSQ2,XRE12,XIM12
      INTEGER I,J
C Longitudinal Polarisation factors
      POL1=1.-EPOLN(3)*PPOLN(3)
      POL2=PPOLN(3)-EPOLN(3)
C Standard model couplings
      QIF=QFCH(I)*QFCH(J)
      VI=VFCH(I,1)
      AI=AFCH(I,1)
      VF=VFCH(J,1)
      AF=AFCH(J,1)
      PG=POL1*(VI**2+AI**2)+POL2*2.*VI*AI
C Z propagator factors
      DQM=QSQ-RMASS(200)**2
      PMW=GAMZ*RMASS(200)
      DEN=QSQ/(DQM**2+PMW**2)
      XRE=DEN*DQM
      XIM=DEN*PMW
      XSQ=DEN*QSQ
C Calculate cross-section coefficients
      CLF(1)=POL1*QIF**2+XRE*2.*QIF*(POL1*VI+POL2*AI)*VF
     &      +XSQ*PG*(VF**2+AF**2)
      CLF(2)=CLF(1)-2.*XSQ*PG*AF**2
      CLF(3)=2.*(XRE*QIF*(POL1*AI+POL2*VI)*AF
     &      +XSQ*(POL1*2.*VI*AI+POL2*(VI**2+AI**2))*VF*AF)
      IF (TPOL) THEN
         CLF(4)=QIF**2+XRE*2.*QIF*VI*VF+XSQ*(VI**2-AI**2)*(VF**2+AF**2)
         CLF(5)=CLF(4)-2.*XSQ*(VI**2-AI**2)*AF**2
         CLF(6)=XIM*2.*QIF*AI*VF
         CLF(7)=CLF(6)
      ENDIF
      IF (ZPRIME) THEN
C Z' couplings:
         VI2=VFCH(I,2)
         AI2=AFCH(I,2)
         VF2=VFCH(J,2)
         AF2=AFCH(J,2)
         PG2=POL1*(VI2**2+AI2**2)+POL2*2.*VI2*AI2
         PG12=POL1*(VI*VI2+AI*AI2)+POL2*(VI*AI2+AI+VI2)
C Z' propagator factors
         DQM2=QSQ-RMASS(202)**2
         PMW2=RMASS(202)*GAMZP
         DEN2=QSQ/(DQM2**2+PMW2**2)
         XRE2=DEN2*DQM2
         XIM2=DEN2*PMW2
         XSQ2=DEN2*QSQ
         XRE12=DEN*DEN2*(DQM*DQM2+PMW*PMW2)
         XIM12=DEN*DEN2*(DQM*PMW2-DQM2*PMW)
C Additional contributions to cross-section coefficients
         CLF(1)=CLF(1)+XRE2*2.*QIF*(POL1*VI2+POL2*AI2)*VF2
     &    +XSQ2*PG2*(VF2**2+AF2**2)+XRE12*2.*PG12*(VF*VF2+AF*AF2)
         CLF(2)=CLF(1)-2.*(XSQ2*PG2*AF2**2+XRE12*2.*PG12*AF*AF2)
         CLF(3)=CLF(3)+2.*(XRE2*QIF*(POL1*AI2+POL2*VI2)*AF2
     &    +XSQ2*(POL1*2.*VI2*AI2+POL2*(VI2**2+AI2**2))*VF2*AF2
     &    +XRE12*(POL1*(VI*AI2+AI*VI2)+POL1*(VI*VI2+AI*AI2))
     &    *(VF*VF2+AF*AF2))
         IF (TPOL) THEN
            CLF(4)=CLF(4)+XRE2*2.*QIF*VI2*VF2
     &       +XSQ2*(VI2**2-AI2**2)*(VF2**2+AF2**2)
     &       +XRE12*2.*(VI*VI2-AI*AI2)*(VF*VF2+AF*AF2)
            CLF(5)=CLF(4)-2*(XSQ2*(VI2**2-AI2**2)*AF2**2
     &       +XRE12*2.*(VI*VI2-AI*AI2)*AF*AF2)
            CLF(6)=CLF(6)+2.*(XIM2*QIF*AI2*VF2
     &       -XIM12*(VI*AI2-AI*VI2)*(VF*VF2+AF*AF2))
            CLF(7)=CLF(6)+4.*XIM12*(VI*AI2-AI*AI2)*AF*AF2
         ENDIF
      ENDIF
      RETURN
      END
CDECK  ID>, HWUCI2.
*CMZ :-        -23/08/94  13.22.29  by  Mike Seymour
*-- Author :    Ulrich Baur & Nigel Glover, adapted by Ian Knowles
C-----------------------------------------------------------------------
      FUNCTION HWUCI2(A,B,Y0)
C-----------------------------------------------------------------------
C     Integral  LOG(A-EPSI-BY(1-Y))/(Y-Y0)
C-----------------------------------------------------------------------
      IMPLICIT NONE
      DOUBLE COMPLEX HWUCI2,HWULI2,EPSI,Y1,Y2,Z1,Z2,Z3,Z4
      DOUBLE PRECISION A,B,Y0,ZERO,ONE,FOUR,HALF
      EXTERNAL HWULI2
      COMMON/SMALL/EPSI
      PARAMETER (ZERO=0.D0, ONE =1.D0, FOUR= 4.D0, HALF=0.5D0)
      IF(B.EQ.ZERO)THEN
         HWUCI2=DCMPLX(ZERO,ZERO)
      ELSE
         Y1=HALF*(ONE+SQRT(ONE-FOUR*(A+EPSI)/B))
         Y2=ONE-Y1
         Z1=Y0/(Y0-Y1)
         Z2=(Y0-ONE)/(Y0-Y1)
         Z3=Y0/(Y0-Y2)
         Z4=(Y0-ONE)/(Y0-Y2)
         HWUCI2=HWULI2(Z1)-HWULI2(Z2)+HWULI2(Z3)-HWULI2(Z4)
      ENDIF
      RETURN
      END
CDECK  ID>, HWUDAT.
*CMZ :-        -26/04/91  10.18.58  by  Bryan Webber
*-- Author :    Ian Knowles & Bryan Webber
C-----------------------------------------------------------------------
      BLOCK DATA HWUDAT
C-----------------------------------------------------------------------
C     Loads common blocks with particle properties data; for particle I:
C        RNAME(I) = Name
C        IDPDG(I) = PDG code
C        IFLAV(I) = HERWIG flavour code
C        ICHRG(I) = Electric charge (|e-|)          (*3 for (di-)quarks)
C        RMASS(I) = Mass (GeV/c^2)
C        RLTIM(I) = Proper life time (s)
C        RSPIN(I) = Spin
C       QORQQB(I) = .TRUE. if it is a quark or an antidiquark
C       QBORQQ(I) = .TRUE. if it is an antiquark or a diquark
C     And stores the particle decay tables: call HWUDPR to print them
C-----------------------------------------------------------------------
      INCLUDE 'HERWIG62.INC'
      INTEGER NLAST,NNEXT,NLEFT,NREST,I,J,MMWIDE,MMLONG,MMHOFF,MMVOFF
      COMMON/PAPER/MMWIDE,MMLONG,MMHOFF,MMVOFF
      PARAMETER (NLAST=458,NNEXT=458+1,NLEFT=NMXRES-458)
      PARAMETER (NREST=NMXRES-120)
      DATA NRES/458/
C Don't forget to change the three occurances above as well
      DATA MMWIDE,MMLONG,MMHOFF,MMVOFF/190,280,-39,-35/
      DATA (RNAME(I),IDPDG(I),IFLAV(I),ICHRG(I),RMASS(I),RLTIM(I),
     &      RSPIN(I),I=0,16)/
     & '        ',       0,   0, 0,0.0000,0.000D+00,0.0,
     & 'DQRK    ',       1,   0,-1,0.3200,0.000D+00,0.5,
     & 'UQRK    ',       2,   0,+2,0.3200,0.000D+00,0.5,
     & 'SQRK    ',       3,   0,-1,0.5000,0.000D+00,0.5,
     & 'CQRK    ',       4,   0,+2,1.5500,0.000D+00,0.5,
     & 'BQRK    ',       5,   0,-1,4.9500,0.000D+00,0.5,
     & 'TQRK    ',       6,   0,+2,174.30,0.000D+00,0.5,
     & 'DBAR    ',      -1,   0,+1,0.3200,0.000D+00,0.5,
     & 'UBAR    ',      -2,   0,-2,0.3200,0.000D+00,0.5,
     & 'SBAR    ',      -3,   0,+1,0.5000,0.000D+00,0.5,
     & 'CBAR    ',      -4,   0,-2,1.5500,0.000D+00,0.5,
     & 'BBAR    ',      -5,   0,+1,4.9500,0.000D+00,0.5,
     & 'TBAR    ',      -6,   0,-2,174.30,0.000D+00,0.5,
     & 'GLUON   ',      21,   0, 0,0.7500,0.000D+00,1.0,
     & 'CMF     ',       0,   0, 0,0.0000,0.000D+00,0.0,
     & 'HARD    ',       0,   0, 0,0.0000,0.000D+00,0.0,
     & 'SOFT    ',       0,   0, 0,0.0000,0.000D+00,0.0/
      DATA (RNAME(I),IDPDG(I),IFLAV(I),ICHRG(I),RMASS(I),RLTIM(I),
     &      RSPIN(I),I=17,32)/
     & 'CONE    ',       0,   0, 0,0.0000,0.000D+00,0.0,
     & 'HEAVY   ',       0,   0, 0,0.0000,0.000D+00,0.0,
     & 'CLUS    ',      91,   0, 0,0.0000,0.000D+00,0.0,
     & '****    ',       0,   0, 0,0.0000,0.000D+00,0.0,
     & 'PI0     ',     111,  11, 0,.13498,8.400D-17,0.0,
     & 'ETA     ',     221,  33, 0,.54730,0.000D+00,0.0,
     & 'RHO0    ',     113,  11, 0,.77000,0.000D+00,1.0,
     & 'OMEGA   ',     223,  33, 0,.78194,0.000D+00,1.0,
     & 'ETAP    ',     331,  33, 0,.95778,0.000D+00,0.0,
     & 'F_2     ',     225,  33, 0,1.2750,0.000D+00,2.0,
     & 'A_10    ',   20113,  11, 0,1.2300,0.000D+00,1.0,
     & 'FL_1    ',   20223,  33, 0,1.2819,0.000D+00,1.0,
     & 'A_20    ',     115,  11, 0,1.3181,0.000D+00,2.0,
     & 'PI-     ',    -211,  12,-1,.13957,2.603D-08,0.0,
     & 'RHO-    ',    -213,  12,-1,.77000,0.000D+00,1.0,
     & 'A_1-    ',  -20213,  12,-1,1.2300,0.000D+00,1.0/
      DATA (RNAME(I),IDPDG(I),IFLAV(I),ICHRG(I),RMASS(I),RLTIM(I),
     &      RSPIN(I),I=33,48)/
     & 'A_2-    ',    -215,  12,-1,1.3181,0.000D+00,2.0,
     & 'K-      ',    -321,  32,-1,.49368,1.237D-08,0.0,
     & 'K*-     ',    -323,  32,-1,.89166,0.000D+00,1.0,
     & 'KH_1-   ',  -20323,  32,-1,1.8500,0.000D+00,1.0,
     & 'K*_2-   ',    -325,  32,-1,1.4256,0.000D+00,2.0,
     & 'PI+     ',     211,  21,+1,.13957,2.603D-08,0.0,
     & 'RHO+    ',     213,  21,+1,.77000,0.000D+00,1.0,
     & 'A_1+    ',   20213,  21,+1,1.2300,0.000D+00,1.0,
     & 'A_2+    ',     215,  21,+1,1.3181,0.000D+00,2.0,
     & 'KBAR0   ',    -311,  31, 0,.49767,0.000D+00,0.0,
     & 'K*BAR0  ',    -313,  31, 0,.89610,0.000D+00,1.0,
     & 'KH_1BAR0',  -20313,  31, 0,1.8500,0.000D+00,1.0,
     & 'K*_2BAR0',    -315,  31, 0,1.4324,0.000D+00,2.0,
     & 'K+      ',     321,  23,+1,.49368,1.237D-08,0.0,
     & 'K*+     ',     323,  23,+1,.89166,0.000D+00,1.0,
     & 'KH_1+   ',   20323,  23,+1,1.8500,0.000D+00,1.0/
      DATA (RNAME(I),IDPDG(I),IFLAV(I),ICHRG(I),RMASS(I),RLTIM(I),
     &      RSPIN(I),I=49,64)/
     & 'K*_2+   ',     325,  23,+1,1.4256,0.000D+00,2.0,
     & 'K0      ',     311,  13, 0,.49767,0.000D+00,0.0,
     & 'K*0     ',     313,  13, 0,.89610,0.000D+00,1.0,
     & 'KH_10   ',   20313,  13, 0,1.8500,0.000D+00,1.0,
     & 'K*_20   ',     315,  13, 0,1.4324,0.000D+00,2.0,
     & '        ',       0,   0, 0,0.0000,0.000D+00,0.0,
     & '        ',       0,   0, 0,0.0000,0.000D+00,0.0,
     & 'PHI     ',     333,  33, 0,1.0194,0.000D+00,1.0,
     & 'FH_1    ',   20333,  33, 0,1.4262,0.000D+00,1.0,
     & 'FP_2    ',     335,  33, 0,1.5250,0.000D+00,2.0,
     & 'GAMMA   ',      22,   0, 0,0.0000,1.000D+30,1.0,
     & 'K_S0    ',     310,   0, 0,.49767,8.926D-11,0.0,
     & 'K_L0    ',     130,   0, 0,.49767,5.170D-08,0.0,
     & 'A_0(H)0 ',   10111,  11, 0,1.4740,0.000D+00,0.0,
     & 'A_0(H)+ ',   10211,  21,+1,1.4740,0.000D+00,0.0,
     & 'A_0(H)- ',  -10211,  12,-1,1.4740,0.000D+00,0.0/
      DATA (RNAME(I),IDPDG(I),IFLAV(I),ICHRG(I),RMASS(I),RLTIM(I),
     &      RSPIN(I),I=65,80)/
     & '        ',       0,   0, 0,0.0000,0.000D+00,0.0,
     & '        ',       0,   0, 0,0.0000,0.000D+00,0.0,
     & '        ',       0,   0, 0,0.0000,0.000D+00,0.0,
     & '        ',       0,   0, 0,0.0000,0.000D+00,0.0,
     & '        ',       0,   0, 0,0.0000,0.000D+00,0.0,
     & '        ',       0,   0, 0,0.0000,0.000D+00,0.0,
     & 'REMG    ',      98,   0, 0,0.0000,0.000D+00,0.0,
     & 'REMN    ',      99,   0, 0,0.0000,0.000D+00,0.0,
     & 'P       ',    2212, 122,+1,.93827,1.000D+30,0.5,
     & 'DELTA+  ',    2214, 122,+1,1.2320,0.000D+00,1.5,
     & 'N       ',    2112, 112, 0,.93957,8.870D+02,0.5,
     & 'DELTA0  ',    2114, 112, 0,1.2320,0.000D+00,1.5,
     & 'DELTA-  ',    1114, 111,-1,1.2320,0.000D+00,1.5,
     & 'LAMBDA  ',    3122, 123, 0,1.1157,2.632D-10,0.5,
     & 'SIGMA0  ',    3212, 123, 0,1.1926,7.400D-20,0.5,
     & 'SIGMA*0 ',    3214, 123, 0,1.3837,0.000D+00,1.5/
      DATA (RNAME(I),IDPDG(I),IFLAV(I),ICHRG(I),RMASS(I),RLTIM(I),
     &      RSPIN(I),I=81,96)/
     & 'SIGMA-  ',    3112, 113,-1,1.1974,1.479D-10,0.5,
     & 'SIGMA*- ',    3114, 113,-1,1.3872,0.000D+00,1.5,
     & 'XI-     ',    3312, 133,-1,1.3213,1.639D-10,0.5,
     & 'XI*-    ',    3314, 133,-1,1.5350,0.000D+00,1.5,
     & 'DELTA++ ',    2224, 222,+2,1.2320,0.000D+00,1.5,
     & 'SIGMA+  ',    3222, 223,+1,1.1894,7.990D-11,0.5,
     & 'SIGMA*+ ',    3224, 223,+1,1.3828,0.000D+00,1.5,
     & 'XI0     ',    3322, 233, 0,1.3149,2.900D-10,0.5,
     & 'XI*0    ',    3324, 233, 0,1.5318,0.000D+00,1.5,
     & 'OMEGA-  ',    3334, 333,-1,1.6725,8.220D-11,1.5,
     & 'PBAR    ',   -2212,-122,-1,.93827,1.000D+30,0.5,
     & 'DELTABR-',   -2214,-122,-1,1.2320,0.000D+00,1.5,
     & 'NBAR    ',   -2112,-112, 0,.93957,8.870D+02,0.5,
     & 'DELTABR0',   -2114,-112, 0,1.2320,0.000D+00,1.5,
     & 'DELTABR+',   -1114,-111,+1,1.2320,0.000D+00,1.5,
     & 'LAMBDABR',   -3122,-123, 0,1.1157,2.632D-10,0.5/
      DATA (RNAME(I),IDPDG(I),IFLAV(I),ICHRG(I),RMASS(I),RLTIM(I),
     &      RSPIN(I),I=97,112)/
     & 'SIGMABR0',   -3212,-123, 0,1.1926,7.400D-20,0.5,
     & 'SGMA*BR0',   -3214,-123, 0,1.3837,0.000D+00,1.5,
     & 'SIGMABR+',   -3112,-113,+1,1.1974,1.479D-10,0.5,
     & 'SGMA*BR+',   -3114,-113,+1,1.3872,0.000D+00,1.5,
     & 'XIBAR+  ',   -3312,-133,+1,1.3213,1.639D-10,0.5,
     & 'XI*BAR+ ',   -3314,-133,+1,1.5350,0.000D+00,1.5,
     & 'DLTABR--',   -2224,-222,-2,1.2320,0.000D+00,1.5,
     & 'SIGMABR-',   -3222,-223,-1,1.1894,7.990D-11,0.5,
     & 'SGMA*BR-',   -3224,-223,-1,1.3828,0.000D+00,1.5,
     & 'XIBAR0  ',   -3322,-233, 0,1.3149,2.900D-10,0.5,
     & 'XI*BAR  ',   -3324,-233, 0,1.5318,0.000D+00,1.5,
     & 'OMEGABR+',   -3334,-333,+1,1.6725,8.220D-11,1.5,
     & 'UU      ',    2203,   0,+4,0.6400,0.000D+00,0.0,
     & 'UD      ',    2101,   0,+1,0.6400,0.000D+00,0.0,
     & 'DD      ',    1103,   0,-2,0.6400,0.000D+00,0.0,
     & 'US      ',    3201,   0,+1,0.8200,0.000D+00,0.0/
      DATA (RNAME(I),IDPDG(I),IFLAV(I),ICHRG(I),RMASS(I),RLTIM(I),
     &      RSPIN(I),I=113,128)/
     & 'DS      ',    3101,   0,-2,0.8200,0.000D+00,0.0,
     & 'SS      ',    3303,   0,-2,1.0000,0.000D+00,0.0,
     & 'UBARUBAR',   -2203,   0,-4,0.6400,0.000D+00,0.0,
     & 'UBARDBAR',   -2101,   0,-1,0.6400,0.000D+00,0.0,
     & 'DBARDBAR',   -1103,   0,+2,0.6400,0.000D+00,0.0,
     & 'UBARSBAR',   -3201,   0,-1,0.8200,0.000D+00,0.0,
     & 'DBARSBAR',   -3101,   0,+2,0.8200,0.000D+00,0.0,
     & 'SBARSBAR',   -3303,   0,+2,1.0000,0.000D+00,0.0,
     & 'E-      ',      11,   0,-1,5.11D-4,1.00D+30,0.5,
     & 'NU_E    ',      12,   0, 0,0.0000,1.000D+30,0.5,
     & 'MU-     ',      13,   0,-1,.10566,2.197D-06,0.5,
     & 'NU_MU   ',      14,   0, 0,0.0000,1.000D+30,0.5,
     & 'TAU-    ',      15,   0,-1,1.7771,2.916D-13,0.5,
     & 'NU_TAU  ',      16,   0, 0,0.0000,1.000D+30,0.5,
     & 'E+      ',     -11,   0,+1,5.11D-4,1.00D+30,0.5,
     & 'NU_EBAR ',     -12,   0, 0,0.0000,1.000D+30,0.5/
      DATA (RNAME(I),IDPDG(I),IFLAV(I),ICHRG(I),RMASS(I),RLTIM(I),
     &      RSPIN(I),I=129,144)/
     & 'MU+     ',     -13,   0,+1,.10566,2.197D-06,0.5,
     & 'NU_MUBAR',     -14,   0, 0,0.0000,1.000D+30,0.5,
     & 'TAU+    ',     -15,   0,+1,1.7771,2.916D-13,0.5,
     & 'NU_TAUBR',     -16,   0, 0,0.0000,1.000D+30,0.5,
     & '        ',       0,   0, 0,0.0000,0.000D+00,0.0,
     & '        ',       0,   0, 0,0.0000,0.000D+00,0.0,
     & '        ',       0,   0, 0,0.0000,0.000D+00,0.0,
     & 'D+      ',     411,  41,+1,1.8693,1.057D-12,0.0,
     & 'D*+     ',     413,  41,+1,2.0100,0.000D+00,1.0,
     & 'DH_1+   ',   20413,  41,+1,2.4270,0.000D+00,1.0,
     & 'D*_2+   ',     415,  41,+1,2.4590,0.000D+00,2.0,
     & 'D0      ',     421,  42, 0,1.8646,4.150D-13,0.0,
     & 'D*0     ',     423,  42, 0,2.0067,0.000D+00,1.0,
     & 'DH_10   ',   20423,  42, 0,2.4222,0.000D+00,1.0,
     & 'D*_20   ',     425,  42, 0,2.4589,0.000D+00,2.0,
     & 'D_S+    ',     431,  43,+1,1.9685,4.670D-13,0.0/
      DATA (RNAME(I),IDPDG(I),IFLAV(I),ICHRG(I),RMASS(I),RLTIM(I),
     &      RSPIN(I),I=145,160)/
     & 'D*_S+   ',     433,  43,+1,2.1124,0.000D+00,1.0,
     & 'DH_S1+  ',   20433,  43,+1,2.5354,0.000D+00,1.0,
     & 'D*_S2+  ',     435,  43,+1,2.5735,0.000D+00,2.0,
     & 'SGMA_C++',    4222, 224,+2,2.4528,0.000D+00,0.5,
     & 'SGM*_C++',    4224, 224,+2,2.5194,0.000D+00,1.5,
     & 'LMBDA_C+',    4122, 124,+1,2.2849,2.060D-13,0.5,
     & 'SIGMA_C+',    4212, 124,+1,2.4536,0.000D+00,0.5,
     & 'SGMA*_C+',    4214, 124,+1,2.5185,0.000D+00,1.5,
     & 'SIGMA_C0',    4112, 114, 0,2.4522,0.000D+00,0.5,
     & 'SGMA*_C0',    4114, 114, 0,2.5175,0.000D+00,1.5,
     & 'XI_C+   ',    4232, 234,+1,2.4656,3.500D-13,0.5,
     & 'XIP_C+  ',    4322, 234,+1,2.5750,0.000D+00,0.5,
     & 'XI*_C+  ',    4324, 234,+1,2.6446,0.000D+00,1.5,
     & 'XI_C0   ',    4132, 134, 0,2.4703,9.800D-14,0.5,
     & 'XIP_C0  ',    4312, 134, 0,2.5800,0.000D+00,0.5,
     & 'XI*_C0  ',    4314, 134, 0,2.6438,0.000D+00,1.5/
      DATA (RNAME(I),IDPDG(I),IFLAV(I),ICHRG(I),RMASS(I),RLTIM(I),
     &      RSPIN(I),I=161,176)/
     & 'OMEGA_C0',    4332, 334, 0,2.7040,6.400D-14,0.5,
     & 'OMGA*_C0',    4334, 334, 0,2.7300,0.000D+00,1.5,
     & 'ETA_C   ',     441,  44, 0,2.9798,0.000D+00,0.0,
     & 'JPSI    ',     443,  44, 0,3.0969,0.000D+00,1.0,
     & 'CHI_C1  ',   10441,  44, 0,3.4173,0.000D+00,0.0,
     & 'PSI2S   ',  100443,  44, 0,3.6860,0.000D+00,1.0,
     & 'PSID    ',   30443,  44, 0,3.7699,0.000D+00,1.0,
     & '        ',       0,   0, 0,0.0000,0.000D+00,0.0,
     & '        ',       0,   0, 0,0.0000,0.000D+00,0.0,
     & '        ',       0,   0, 0,0.0000,0.000D+00,0.0,
     & 'D-      ',    -411,  14,-1,1.8693,1.057D-12,0.0,
     & 'D*-     ',    -413,  14,-1,2.0100,0.000D+00,1.0,
     & 'DH_1-   ',  -20413,  14,-1,2.4270,0.000D+00,1.0,
     & 'D*_2-   ',    -415,  14,-1,2.4590,0.000D+00,2.0,
     & 'DBAR0   ',    -421,  24, 0,1.8646,4.140D-13,0.0,
     & 'D*BAR0  ',    -423,  24, 0,2.0067,0.000D+00,1.0/
      DATA (RNAME(I),IDPDG(I),IFLAV(I),ICHRG(I),RMASS(I),RLTIM(I),
     &      RSPIN(I),I=177,192)/
     & 'DH_1BAR0',  -20423,  24, 0,2.4222,0.000D+00,1.0,
     & 'D*_2BAR0',    -425,  24, 0,2.4589,0.000D+00,2.0,
     & 'D_S-    ',    -431,  34,-1,1.9685,4.670D-13,0.0,
     & 'D*_S-   ',    -433,  34,-1,2.1124,0.000D+00,1.0,
     & 'DH_S1-  ',  -20433,  34,-1,2.5354,0.000D+00,1.0,
     & 'D*_S2-  ',    -435,  34,-1,2.5735,0.000D+00,2.0,
     & 'SGMA_C--',   -4222,-224,-2,2.4528,0.000D+00,0.5,
     & 'SGM*_C--',   -4224,-224,-2,2.5194,0.000D+00,1.5,
     & 'LMBDA_C-',   -4122,-124,-1,2.2849,2.060D-13,0.5,
     & 'SIGMA_C-',   -4212,-124,-1,2.4536,0.000D+00,0.5,
     & 'SGMA*_C-',   -4214,-124,-1,2.5185,0.000D+00,1.5,
     & 'SGM_CBR0',   -4112,-114, 0,2.4522,0.000D+00,0.5,
     & 'SG*_CBR0',   -4114,-114, 0,2.5175,0.000D+00,1.5,
     & 'XI_C-   ',   -4232,-234,-1,2.4656,3.500D-13,0.5,
     & 'XIP_C-  ',   -4322,-234,-1,2.5750,0.000D+00,0.5,
     & 'XI*_C-  ',   -4324,-234,-1,2.6446,0.000D+00,1.5/
      DATA (RNAME(I),IDPDG(I),IFLAV(I),ICHRG(I),RMASS(I),RLTIM(I),
     &      RSPIN(I),I=193,208)/
     & 'XI_CBAR0',   -4132,-134, 0,2.4703,9.800D-14,0.5,
     & 'XIP_CBR0',   -4312,-134, 0,2.5800,0.000D+00,0.5,
     & 'XI*_CBR0',   -4314,-134, 0,2.6438,0.000D+00,1.5,
     & 'OMG_CBR0',   -4332,-334, 0,2.7040,6.400D-14,0.5,
     & 'OM*_CBR0',   -4334,-334, 0,2.7300,0.000D+00,1.5,
     & 'W+      ',      24,   0,+1,80.420,0.000D+00,1.0,
     & 'W-      ',     -24,   0,-1,80.420,0.000D+00,1.0,
     & 'Z0/GAMA*',      23,   0, 0,91.188,0.000D+00,1.0,
     & 'HIGGS   ',      25,   0, 0,115.00,0.000D+00,0.0,
     & 'Z0P     ',      32,   0, 0,500.00,0.000D+00,1.0,
     & 'HIGGSL0 ',      26,   0, 0,0.0000,1.000D+30,0.0,
     & 'HIGGSH0 ',      35,   0, 0,0.0000,1.000D+30,0.0,
     & 'HIGGSA0 ',      36,   0, 0,0.0000,1.000D+30,0.0,
     & 'HIGGS+  ',      37,   0,+1,0.0000,1.000D+30,0.0,
     & 'HIGGS-  ',     -37,   0,-1,0.0000,1.000D+30,0.0,
     & 'GRAVITON',      39,   0, 0,0.0000,1.000D+30,2.0/
      DATA (RNAME(I),IDPDG(I),IFLAV(I),ICHRG(I),RMASS(I),RLTIM(I),
     &      RSPIN(I),I=209,224)/
     & 'VQRK    ',       7,   0,-1,200.00,0.000D+00,0.5,
     & 'AQRK    ',       8,   0,+2,400.00,0.000D+00,0.5,
     & 'HQRK    ',       7,   0,-1,400.00,0.000D+00,0.5,
     & 'HPQK    ',       8,   0,+2,600.00,0.000D+00,0.5,
     & '        ',       0,   0, 0,0.0000,0.000D+00,0.0,
     & '        ',       0,   0, 0,0.0000,0.000D+00,0.0,
     & 'VBAR    ',      -7,   0,+1,200.00,0.000D+00,0.5,
     & 'ABAR    ',      -8,   0,-2,400.00,0.000D+00,0.5,
     & 'HBAR    ',      -7,   0,+1,400.00,0.000D+00,0.5,
     & 'HPBR    ',      -8,   0,-2,600.00,0.000D+00,0.5,
     & '        ',       0,   0, 0,0.0000,0.000D+00,0.0,
     & '        ',       0,   0, 0,0.0000,0.000D+00,0.0,
     & 'B_DBAR0 ',    -511,  51, 0,5.2792,1.614D-12,0.0,
     & 'B-      ',    -521,  52,-1,5.2789,1.652D-12,0.0,
     & 'B_SBAR0 ',    -531,  53, 0,5.3693,1.540D-12,0.0,
     & 'SIGMA_B+',    5222, 225,+1,5.8200,1.070D-12,0.5/
      DATA (RNAME(I),IDPDG(I),IFLAV(I),ICHRG(I),RMASS(I),RLTIM(I),
     &      RSPIN(I),I=225,240)/
     & 'LMBDA_B0',    5122, 125, 0,5.6240,1.070D-12,0.5,
     & 'SIGMA_B-',    5112, 115,-1,5.8200,1.070D-12,0.5,
     & 'XI_B0   ',    5232, 235, 0,5.8000,1.070D-12,0.5,
     & 'XI_B-   ',    5132, 135,-1,5.8000,1.070D-12,0.5,
     & 'OMEGA_B-',    5332, 335,-1,6.0400,1.070D-12,0.5,
     & 'B_C-    ',    -541,  54,-1,6.2500,1.000D-12,0.5,
     & 'UPSLON1S',     553,  55, 0,9.4604,0.000D+00,1.0,
     & 'T_B-    ',    -651,  56,-1,0.0000,0.000D+00,0.0,
     & 'T+      ',     611,  61,+1,0.0000,0.000D+00,0.0,
     & 'T0      ',     621,  62, 0,0.0000,0.000D+00,0.0,
     & 'T_S+    ',     631,  63,+1,0.0000,0.000D+00,0.0,
     & 'SGMA_T++',    6222, 226,+2,0.0000,0.000D+00,0.5,
     & 'LMBDA_T0',    6122, 126,+1,0.0000,0.000D+00,0.5,
     & 'SIGMA_T0',    6112, 116, 0,0.0000,0.000D+00,0.5,
     & 'XI_T+   ',    6232, 236,+1,0.0000,0.000D+00,0.5,
     & 'XI_T0   ',    6132, 136, 0,0.0000,0.000D+00,0.5/
      DATA (RNAME(I),IDPDG(I),IFLAV(I),ICHRG(I),RMASS(I),RLTIM(I),
     &      RSPIN(I),I=241,256)/
     & 'OMEGA_T0',    6332, 336, 0,0.0000,0.000D+00,0.5,
     & 'T_C0    ',     641,  64, 0,0.0000,0.000D+00,0.0,
     & 'T_B+    ',     651,  65,+1,0.0000,0.000D+00,0.0,
     & 'TOPONIUM',     663,  66, 0,0.0000,0.000D+00,1.0,
     & 'B_D0    ',     511,  15, 0,5.2792,1.614D-12,0.0,
     & 'B+      ',     521,  25,+1,5.2789,1.652D-12,0.0,
     & 'B_S0    ',     531,  35, 0,5.3693,1.540D-12,0.0,
     & 'SGM_BBR-',   -5222,-225,-1,5.8200,1.070D-12,0.5,
     & 'LMD_BBR0',   -5122,-125, 0,5.6240,1.070D-12,0.5,
     & 'SGM_BBR+',   -5112,-115,+1,5.8200,1.070D-12,0.5,
     & 'XI_BBAR0',   -5232,-235, 0,5.8000,1.070D-12,0.5,
     & 'XI_B+   ',   -5132,-135,+1,5.8000,1.070D-12,0.5,
     & 'OMG_BBR+',   -5332,-335,+1,6.0400,1.070D-12,0.5,
     & 'B_C+    ',     541,  45,+1,6.2500,1.000D-12,0.5,
     & 'T-      ',    -611,  16,-1,0.0000,0.000D+00,0.0,
     & 'TBAR0   ',    -621,  26, 0,0.0000,0.000D+00,0.0/
      DATA (RNAME(I),IDPDG(I),IFLAV(I),ICHRG(I),RMASS(I),RLTIM(I),
     &      RSPIN(I),I=257,272)/
     & 'T_S-    ',    -631,  36,-1,0.0000,0.000D+00,0.0,
     & 'SGMA_T--',   -6222,-226,-2,0.0000,0.000D+00,0.5,
     & 'LAMDA_T-',   -6122,-126,-1,0.0000,0.000D+00,0.5,
     & 'SGM_TBR0',   -6112,-116, 0,0.0000,0.000D+00,0.5,
     & 'XI_T-   ',   -6232,-236,-1,0.0000,0.000D+00,0.5,
     & 'XI_TBAR0',   -6132,-136, 0,0.0000,0.000D+00,0.5,
     & 'OMG_TBR0',   -6332,-336, 0,0.0000,0.000D+00,0.5,
     & 'T_CBAR0 ',    -641,  46, 0,0.0000,0.000D+00,0.0,
     & 'B*BAR0  ',    -513,  51, 0,5.3249,0.000D+00,1.0,
     & 'B*-     ',    -523,  52,-1,5.3249,0.000D+00,1.0,
     & 'B*_SBAR0',    -533,  53, 0,5.4163,0.000D+00,1.0,
     & 'BH_1BAR0',  -20513,  51, 0,5.7600,0.000D+00,1.0,
     & 'BH_1-   ',  -20523,  52,-1,5.7600,0.000D+00,1.0,
     & 'BH_S1BR0',  -20533,  53, 0,5.8550,0.000D+00,1.0,
     & 'B*_2BAR0',    -515,  51, 0,5.7700,0.000D+00,2.0,
     & 'B*_2-   ',    -525,  52,-1,5.7700,0.000D+00,2.0/
      DATA (RNAME(I),IDPDG(I),IFLAV(I),ICHRG(I),RMASS(I),RLTIM(I),
     &      RSPIN(I),I=273,288)/
     & 'B*_S2BR0',    -535,  53, 0,5.8650,0.000D+00,2.0,
     & 'B*0     ',     513,  15, 0,5.3249,0.000D+00,1.0,
     & 'B*+     ',     523,  25,+1,5.3249,0.000D+00,1.0,
     & 'B*_S0   ',     533,  35, 0,5.4163,0.000D+00,1.0,
     & 'BH_10   ',   20513,  15, 0,5.7600,0.000D+00,1.0,
     & 'BH_1+   ',   20523,  25,+1,5.7600,0.000D+00,1.0,
     & 'BH_S10  ',   20533,  35, 0,5.8550,0.000D+00,1.0,
     & 'B*_20   ',     515,  15, 0,5.7700,0.000D+00,2.0,
     & 'B*_2+   ',     525,  25,+1,5.7700,0.000D+00,2.0,
     & 'B*_S20  ',     535,  35, 0,5.8650,0.000D+00,2.0,
     & '        ',       0,   0, 0,0.0000,0.000D+00,  0,
     & '        ',       0,   0, 0,0.0000,0.000D+00,  0,
     & 'B_10    ',   10113,  11, 0,1.2295,0.000D+00,1.0,
     & 'B_1+    ',   10213,  21,+1,1.2295,0.000D+00,1.0,
     & 'B_1-    ',  -10213,  12,-1,1.2295,0.000D+00,1.0,
     & 'HL_10   ',   10223,  33, 0,1.1700,0.000D+00,1.0/
      DATA (RNAME(I),IDPDG(I),IFLAV(I),ICHRG(I),RMASS(I),RLTIM(I),
     &      RSPIN(I),I=289,304)/
     & 'HH_10   ',   10333,  33, 0,1.3950,0.000D+00,1.0,
     & 'A_00    ', 9000111,  11, 0,.99600,0.000D+00,0.0,
     & 'A_0+    ', 9000211,  21,+1,.99600,0.000D+00,0.0,
     & 'A_0-    ',-9000211,  12,-1,.99600,0.000D+00,0.0,
     & 'F0P0    ', 9010221,  33, 0,.99600,0.000D+00,0.0,
     & 'FH_00   ',   10221,  33, 0,1.3500,0.000D+00,0.0,
     & 'B*_C+   ',     543,  45,+1,6.2950,0.000D+00,1.0,
     & 'B*_C-   ',    -543,  54,-1,6.2950,0.000D+00,1.0,
     & 'BH_C1+  ',   20543,  45,+1,6.7300,0.000D+00,1.0,
     & 'BH_C1-  ',  -20543,  54,-1,6.7300,0.000D+00,1.0,
     & 'B*_C2+  ',     545,  45,+1,6.7400,0.000D+00,2.0,
     & 'B*_C2-  ',    -545,  54,-1,6.7400,0.000D+00,2.0,
     & 'H_C     ',   10443,  44, 0,3.5261,0.000D+00,1.0,
     & 'CHI_C0  ',   20443,  44, 0,3.5105,0.000D+00,0.0,
     & 'CHI_C2  ',     445,  44, 0,3.5562,0.000D+00,2.0,
     & 'ETA_B   ',     551,  55, 0,9.0000,0.000D+00,0.0/
      DATA (RNAME(I),IDPDG(I),IFLAV(I),ICHRG(I),RMASS(I),RLTIM(I),
     &      RSPIN(I),I=305,320)/
     & 'H_B     ',   10553,  55, 0,9.8880,0.000D+00,1.0,
     & 'CHI_B0  ',   10551,  55, 0,9.8598,0.000D+00,0.0,
     & 'CHI_B1  ',   20553,  55, 0,9.8919,0.000D+00,1.0,
     & 'CHI_B2  ',     555,  55, 0,9.9132,0.000D+00,2.0,
     & 'KL_10   ',   10313,  13, 0,1.5700,0.000D+00,1.0,
     & 'KL_1+   ',   10323,  23,+1,1.5700,0.000D+00,1.0,
     & 'KL_1BAR0',  -10313,  31, 0,1.5700,0.000D+00,1.0,
     & 'KL_1-   ',  -10323,  32,-1,1.5700,0.000D+00,1.0,
     & 'DL_1+   ',   10413,  41,+1,2.4270,0.000D+00,1.0,
     & 'DL_10   ',   10423,  42, 0,2.4222,0.000D+00,1.0,
     & 'DL_S1+  ',   10433,  43,+1,2.5354,0.000D+00,1.0,
     & 'DL_1-   ',  -10413,  14,-1,2.4270,0.000D+00,1.0,
     & 'DL_1BAR0',  -10423,  24, 0,2.4222,0.000D+00,1.0,
     & 'DL_S1-  ',  -10433,  34,-1,2.5354,0.000D+00,1.0,
     & 'BL_10   ',   10513,  15, 0,5.7600,0.000D+00,1.0,
     & 'BL_1+   ',   10523,  25,+1,5.7600,0.000D+00,1.0/
      DATA (RNAME(I),IDPDG(I),IFLAV(I),ICHRG(I),RMASS(I),RLTIM(I),
     &      RSPIN(I),I=321,336)/
     & 'BL_S10  ',   10533,  35, 0,5.8530,0.000D+00,1.0,
     & 'BL_C1+  ',   10543,  45,+1,6.7300,0.000D+00,1.0,
     & 'BL_1BAR0',  -10513,  51, 0,5.7600,0.000D+00,1.0,
     & 'BL_1-   ',  -10523,  52,-1,5.7600,0.000D+00,1.0,
     & 'BL_S1BR0',  -10533,  53, 0,5.8530,0.000D+00,1.0,
     & 'BL_C1-  ',  -10543,  54,-1,6.7300,0.000D+00,1.0,
     & 'K*_0+   ',   10321,  23,+1,1.4290,0.000D+00,0.0,
     & 'K*_00   ',   10311,  13, 0,1.4290,0.000D+00,0.0,
     & 'K*_0BAR0',  -10311,  31, 0,1.4290,0.000D+00,0.0,
     & 'K*_0-   ',  -10321,  32,-1,1.4290,0.000D+00,0.0,
     & 'D*_0+   ',   10411,  41,+1,2.4230,0.000D+00,0.0,
     & 'D*_00   ',   10421,  42, 0,2.4230,0.000D+00,0.0,
     & 'D*_S0+  ',   10431,  43,+1,2.5250,0.000D+00,0.0,
     & 'D*_0-   ',  -10411,  14,-1,2.4230,0.000D+00,0.0,
     & 'D*_0BAR0',  -10421,  24, 0,2.4230,0.000D+00,0.0,
     & 'D*_S0-  ',  -10431,  34,-1,2.5250,0.000D+00,0.0/
      DATA (RNAME(I),IDPDG(I),IFLAV(I),ICHRG(I),RMASS(I),RLTIM(I),
     &      RSPIN(I),I=337,352)/
     & 'B*_00   ',   10511,  15, 0,5.7600,0.000D+00,0.0,
     & 'B*_0+   ',   10521,  25,+1,5.7600,0.000D+00,0.0,
     & 'B*_S00  ',   10531,  35, 0,5.8550,0.000D+00,0.0,
     & 'B*_C0+  ',   10541,  45,+1,6.7300,0.000D+00,0.0,
     & 'B*_0BAR0',  -10511,  51, 0,5.7600,0.000D+00,0.0,
     & 'B*_0-   ',  -10521,  52,-1,5.7600,0.000D+00,0.0,
     & 'B*_S0BR0',  -10531,  53, 0,5.8550,0.000D+00,0.0,
     & 'B*_C0-  ',  -10541,  54,-1,6.7300,0.000D+00,0.0,
     & 'SGMA*_B-',    5114, 115,-1,5.8400,0.000D+00,1.5,
     & 'SIGMA_B0',    5212, 125, 0,5.8200,0.000D+00,0.5,
     & 'SGMA*_B0',    5214, 125, 0,5.8400,0.000D+00,1.5,
     & 'SGMA*_B+',    5224, 225,+1,5.8400,0.000D+00,1.5,
     & 'XIP_B0  ',    5322, 235, 0,5.9450,0.000D+00,0.5,
     & 'XI*_B0  ',    5324, 235, 0,5.9450,0.000D+00,1.5,
     & 'XIP_B-  ',    5312, 135,-1,5.9450,0.000D+00,0.5,
     & 'XI*_B-  ',    5314, 135,-1,5.9450,0.000D+00,1.5/
      DATA (RNAME(I),IDPDG(I),IFLAV(I),ICHRG(I),RMASS(I),RLTIM(I),
     &      RSPIN(I),I=353,368)/
     & '0MGA*_B-',    5334, 335,-1,6.0600,0.000D+00,1.5,
     & 'SG*_BBR+',   -5114,-115,+1,5.8400,0.000D+00,1.5,
     & 'SGM_BBR0',   -5212,-125, 0,5.8200,0.000D+00,0.5,
     & 'SG*_BBR0',   -5214,-125, 0,5.8400,0.000D+00,1.5,
     & 'SG*_BBR-',   -5224,-225,-1,5.8400,0.000D+00,1.5,
     & 'XIP_BBR0',   -5322,-235, 0,5.9450,0.000D+00,0.5,
     & 'XI*_BBR0',   -5324,-235, 0,5.9450,0.000D+00,1.5,
     & 'XIP_B+  ',   -5312,-135,+1,5.9450,0.000D+00,0.5,
     & 'XI*_B+  ',   -5314,-135,+1,5.9450,0.000D+00,1.5,
     & '0MGA*_B+',   -5334,-335,+1,6.0600,0.000D+00,1.5,
     & 'KDL_2+  ',   10325,  23,+1,1.7730,0.000D+00,2.0,
     & 'KDL_20  ',   10315,  13, 0,1.7730,0.000D+00,2.0,
     & 'KDL_2BR0',  -10315,  31, 0,1.7730,0.000D+00,2.0,
     & 'KDL_2-  ',  -10325,  32,-1,1.7730,0.000D+00,2.0,
     & 'KD*+    ',   30323,  23,+1,1.717,0.000D+00,1.0,
     & 'KD*0    ',   30313,  13, 0,1.717,0.000D+00,1.0/
      DATA (RNAME(I),IDPDG(I),IFLAV(I),ICHRG(I),RMASS(I),RLTIM(I),
     &      RSPIN(I),I=369,384)/
     & 'KD*BAR0 ',  -30313,  31, 0,1.717,0.000D+00,1.0,
     & 'KD*-    ',  -30323,  32,-1,1.717,0.000D+00,1.0,
     & 'KDH_2+  ',   20325,  23,+1,1.8160,0.000D+00,2.0,
     & 'KDH_20  ',   20315,  13, 0,1.8160,0.000D+00,2.0,
     & 'KDH_2BR0',  -20315,  31, 0,1.8160,0.000D+00,2.0,
     & 'KDH_2-  ',  -20325,  32,-1,1.8160,0.000D+00,2.0,
     & 'KD_3+   ',     327,  23,+1,1.7730,0.000D+00,3.0,
     & 'KD_30   ',     317,  13, 0,1.7730,0.000D+00,3.0,
     & 'KD_3BAR0',    -317,  31, 0,1.7730,0.000D+00,3.0,
     & 'KD_3-   ',    -327,  32,-1,1.7730,0.000D+00,3.0,
     & 'PI_2+   ',   10215,  21,+1,1.6700,0.000D+00,2.0,
     & 'PI_20   ',   10115,  11, 0,1.6700,0.000D+00,2.0,
     & 'PI_2-   ',  -10215,  12,-1,1.6700,0.000D+00,2.0,
     & 'RHOD+   ',   30213,  21,+1,1.7000,0.000D+00,1.0,
     & 'RHOD0   ',   30113,  11, 0,1.7000,0.000D+00,1.0,
     & 'RHOD-   ',  -30213,  12,-1,1.7000,0.000D+00,1.0/
      DATA (RNAME(I),IDPDG(I),IFLAV(I),ICHRG(I),RMASS(I),RLTIM(I),
     &      RSPIN(I),I=385,400)/
     & 'RHO_3+  ',     217,  21,+1,1.6910,0.000D+00,3.0,
     & 'RHO_30  ',     117,  11, 0,1.6910,0.000D+00,3.0,
     & 'RHO_3-  ',    -217,  12,-1,1.6910,0.000D+00,3.0,
     & 'UPSLON2S',  100553,  55, 0,10.023,0.000D+00,1.0,
     & 'CHI2P_B0',  110551,  55, 0,10.232,0.000D+00,0.0,
     & 'CHI2P_B1',  120553,  55, 0,10.255,0.000D+00,1.0,
     & 'CHI2P_B2',  100555,  55, 0,10.269,0.000D+00,2.0,
     & 'UPSLON3S',  200553,  55, 0,10.355,0.000D+00,1.0,
     & 'UPSLON4S',  300553,  55, 0,10.580,0.000D+00,1.0,
     & '        ',       0,   0, 0,0.0   ,  0.0D+00,  0,
     & 'OMEGA_3 ',     227,  33, 0,1.6670,0.000D+00,3.0,
     & 'PHI_3   ',     337,  33, 0,1.8540,0.000D+00,3.0,
     & 'ETA_2(L)',   10225,  33, 0,1.6320,0.000D+00,2.0,
     & 'ETA_2(H)',   10335,  33, 0,1.8540,0.000D+00,2.0,
     & 'OMEGA(H)',   30223,  33, 0,1.6490,0.000D+00,1.0,
     & '        ',       0,   0, 0,0.0   ,0.0D+00  ,  0/
      DATA (RNAME(I),IDPDG(I),IFLAV(I),ICHRG(I),RMASS(I),RLTIM(I),
     &      RSPIN(I),I=401,416)/
     & 'SSDL    ', 1000001,   0,-1,0.00D0,1.000D+30,0.0,
     & 'SSUL    ', 1000002,   0,+2,0.00D0,1.000D+30,0.0,
     & 'SSSL    ', 1000003,   0,-1,0.00D0,1.000D+30,0.0,
     & 'SSCL    ', 1000004,   0,+2,0.00D0,1.000D+30,0.0,
     & 'SSB1    ', 1000005,   0,-1,0.00D0,1.000D+30,0.0,
     & 'SST1    ', 1000006,   0,+2,0.00D0,1.000D+30,0.0,
     & 'SSDLBR  ',-1000001,   0,+1,0.00D0,1.000D+30,0.0,
     & 'SSULBR  ',-1000002,   0,-2,0.00D0,1.000D+30,0.0,
     & 'SSSLBR  ',-1000003,   0,+1,0.00D0,1.000D+30,0.0,
     & 'SSCLBR  ',-1000004,   0,-2,0.00D0,1.000D+30,0.0,
     & 'SSB1BR  ',-1000005,   0,+1,0.00D0,1.000D+30,0.0,
     & 'SST1BR  ',-1000006,   0,-2,0.00D0,1.000D+30,0.0,
     & 'SSDR    ', 2000001,   0,-1,0.00D0,1.000D+30,0.0,
     & 'SSUR    ', 2000002,   0,+2,0.00D0,1.000D+30,0.0,
     & 'SSSR    ', 2000003,   0,-1,0.00D0,1.000D+30,0.0,
     & 'SSCR    ', 2000004,   0,+2,0.00D0,1.000D+30,0.0/
      DATA (RNAME(I),IDPDG(I),IFLAV(I),ICHRG(I),RMASS(I),RLTIM(I),
     &      RSPIN(I),I=417,432)/
     & 'SSB2    ', 2000005,   0,-1,0.00D0,1.000D+30,0.0,
     & 'SST2    ', 2000006,   0,+2,0.00D0,1.000D+30,0.0,
     & 'SSDRBR  ',-2000001,   0,+1,0.00D0,1.000D+30,0.0,
     & 'SSURBR  ',-2000002,   0,-2,0.00D0,1.000D+30,0.0,
     & 'SSSRBR  ',-2000003,   0,+1,0.00D0,1.000D+30,0.0,
     & 'SSCRBR  ',-2000004,   0,-2,0.00D0,1.000D+30,0.0,
     & 'SSB2BR  ',-2000005,   0,+1,0.00D0,1.000D+30,0.0,
     & 'SST2BR  ',-2000006,   0,-2,0.00D0,1.000D+30,0.0,
     & 'SSEL-   ', 1000011,   0,-1,0.00D0,1.000D+30,0.0,
     & 'SSNUEL  ', 1000012,   0, 0,0.00D0,1.000D+30,0.0,
     & 'SSMUL-  ', 1000013,   0,-1,0.00D0,1.000D+30,0.0,
     & 'SSNUMUL ', 1000014,   0, 0,0.00D0,1.000D+30,0.0,
     & 'SSTAU1- ', 1000015,   0,-1,0.00D0,1.000D+30,0.0,
     & 'SSNUTL  ', 1000016,   0, 0,0.00D0,1.000D+30,0.0,
     & 'SSEL+   ',-1000011,   0,+1,0.00D0,1.000D+30,0.0,
     & 'SSNUELBR',-1000012,   0, 0,0.00D0,1.000D+30,0.0/
      DATA (RNAME(I),IDPDG(I),IFLAV(I),ICHRG(I),RMASS(I),RLTIM(I),
     &      RSPIN(I),I=433,448)/
     & 'SSMUL+  ',-1000013,   0,+1,0.00D0,1.000D+30,0.0,
     & 'SSNUMLBR',-1000014,   0, 0,0.00D0,1.000D+30,0.0,
     & 'SSTAU1+ ',-1000015,   0,+1,0.00D0,1.000D+30,0.0,
     & 'SSNUTLBR',-1000016,   0, 0,0.00D0,1.000D+30,0.0,
     & 'SSER-   ', 2000011,   0,-1,0.00D0,1.000D+30,0.0,
     & 'SSNUER  ', 2000012,   0, 0,0.00D0,1.000D+30,0.0,
     & 'SSMUR-  ', 2000013,   0,-1,0.00D0,1.000D+30,0.0,
     & 'SSNUMUR ', 2000014,   0, 0,0.00D0,1.000D+30,0.0,
     & 'SSTAU2- ', 2000015,   0,-1,0.00D0,1.000D+30,0.0,
     & 'SSNUTR  ', 2000016,   0, 0,0.00D0,1.000D+30,0.0,
     & 'SSER+   ',-2000011,   0,+1,0.00D0,1.000D+30,0.0,
     & 'SSNUERBR',-2000012,   0, 0,0.00D0,1.000D+30,0.0,
     & 'SSMUR+  ',-2000013,   0,+1,0.00D0,1.000D+30,0.0,
     & 'SSNUMRBR',-2000014,   0, 0,0.00D0,1.000D+30,0.0,
     & 'SSTAU2+ ',-2000015,   0,+1,0.00D0,1.000D+30,0.0,
     & 'SSNUTRBR',-2000016,   0, 0,0.00D0,1.000D+30,0.0/
      DATA (RNAME(I),IDPDG(I),IFLAV(I),ICHRG(I),RMASS(I),RLTIM(I),
     &      RSPIN(I),I=449,NLAST)/
     & 'GLUINO  ', 1000021,   0, 0,0.00D0,1.000D+30,0.5,
     & 'NTLINO1 ', 1000022,   0, 0,0.00D0,1.000D+30,0.5,
     & 'NTLINO2 ', 1000023,   0, 0,0.00D0,1.000D+30,0.5,
     & 'NTLINO3 ', 1000025,   0, 0,0.00D0,1.000D+30,0.5,
     & 'NTLINO4 ', 1000035,   0, 0,0.00D0,1.000D+30,0.5,
     & 'CHGINO1+', 1000024,   0,+1,0.00D0,1.000D+30,0.5,
     & 'CHGINO2+', 1000037,   0,+1,0.00D0,1.000D+30,0.5,
     & 'CHGINO1-',-1000024,   0,-1,0.00D0,1.000D+30,0.5,
     & 'CHGINO2-',-1000037,   0,-1,0.00D0,1.000D+30,0.5,
     & 'GRAVTINO', 1000039,   0, 0,0.00D0,1.000D+30,1.5/
C
      DATA QORQQB/.FALSE.,
     & 6*.TRUE.,6*.FALSE.,96*.FALSE.,6*.FALSE.,6*.TRUE.,NREST*.FALSE./
      DATA QBORQQ/.FALSE.,
     & 6*.FALSE.,6*.TRUE.,96*.FALSE.,6*.TRUE.,6*.FALSE.,NREST*.FALSE./
C
C     In the character strings use an ampersand to represent a backslash
C     to avoid compiler problems with the C escape character i.e. & = \
      DATA ((TXNAME(J,I),J=1,2),I=0,8)/
     & '                                     ',
     & '                                     ',
     & '                                    d',
     & '                                    d',
     & '                                    u',
     & '                                    u',
     & '                                    s',
     & '                                    s',
     & '                                    c',
     & '                                    c',
     & '                                    b',
     & '                                    b',
     & '                                    t',
     & '                                    t',
     & '                        $&bar{&rm d}$',
     & '                                   -d',
     & '                        $&bar{&rm u}$',
     & '                                   -u'/
      DATA ((TXNAME(J,I),J=1,2),I=9,16)/
     & '                        $&bar{&rm s}$',
     & '                                   -s',
     & '                        $&bar{&rm c}$',
     & '                                   -c',
     & '                        $&bar{&rm b}$',
     & '                                   -b',
     & '                        $&bar{&rm t}$',
     & '                                   -t',
     & '                                  $g$',
     & '                                    g',
     & '                                  CoM',
     & '                                  CoM',
     & '                                 Hard',
     & '                                 Hard',
     & '                                 Soft',
     & '                                 Soft'/
      DATA ((TXNAME(J,I),J=1,2),I=17,24)/
     & '                                 Cone',
     & '                                 Cone',
     & '                                Heavy',
     & '                                Heavy',
     & '                              Cluster',
     & '                              Cluster',
     & '               $&star&star&star&star$',
     & '                                 ****',
     & '                              $&pi^0$',
     & '                       pi<SUP>0</SUP>',
     & '                               $&eta$',
     & '                                  eta',
     & '                             $&rho^0$',
     & '                      rho<SUP>0</SUP>',
     & '                             $&omega$',
     & '                                omega'/
      DATA ((TXNAME(J,I),J=1,2),I=25,32)/
     & '                        $&eta^&prime$',
     & '                      eta<SUP>''</SUP>',
     & '                                $f_2$',
     & '                        f<SUB>2</SUB>',
     & '                              $a^0_1$',
     & '            a<SUB>1</SUB><SUP>0</SUP>',
     & '                             $f_1(L)$',
     & '                     f<SUB>1</SUB>(L)',
     & '                              $a^0_2$',
     & '            a<SUB>2</SUB><SUP>0</SUP>',
     & '                              $&pi^-$',
     & '                       pi<SUP>-</SUP>',
     & '                             $&rho^-$',
     & '                      rho<SUP>-</SUP>',
     & '                              $a^-_1$',
     & '            a<SUB>1</SUB><SUP>-</SUP>'/
      DATA ((TXNAME(J,I),J=1,2),I=33,40)/
     & '                              $a^-_2$',
     & '            a<SUB>2</SUB><SUP>-</SUP>',
     & '                                K$^-$',
     & '                        K<SUP>-</SUP>',
     & '                         K$^{&star-}$',
     & '                       K<SUP>*-</SUP>',
     & '                           K$_1(H)^-$',
     & '         K<SUB>1</SUB>(H)<SUP>-</SUP>',
     & '                       K$^{&star-}_2$',
     & '           K<SUB>2</SUB><SUP>*-</SUP>',
     & '                              $&pi^+$',
     & '                       pi<SUP>+</SUP>',
     & '                             $&rho^+$',
     & '                      rho<SUP>+</SUP>',
     & '                              $a^+_1$',
     & '            a<SUB>1</SUB><SUP>+</SUP>'/
      DATA ((TXNAME(J,I),J=1,2),I=41,48)/
     & '                              $a^+_2$',
     & '            a<SUB>2</SUB><SUP>+</SUP>',
     & '                 $&overline{&rm K}^0$',
     & '                       -K<SUP>0</SUP>',
     & '          $&overline{&rm K}^{&star0}$',
     & '                      -K<SUP>*0</SUP>',
     & '            $&overline{&rm K}_1(H)^0$',
     & '        -K<SUB>1</SUB>(H)<SUP>0</SUP>',
     & '        $&overline{&rm K}^{&star0}_2$',
     & '          -K<SUB>2</SUB><SUP>*0</SUP>',
     & '                                K$^+$',
     & '                        K<SUP>+</SUP>',
     & '                         K$^{&star+}$',
     & '                       K<SUP>*+</SUP>',
     & '                           K$_1(H)^+$',
     & '         K<SUB>1</SUB>(H)<SUP>+</SUP>'/
      DATA ((TXNAME(J,I),J=1,2),I=49,56)/
     & '                       K$^{&star+}_2$',
     & '        K<SUB>2</SUB>(H)<SUP>*+</SUP>',
     & '                                K$^0$',
     & '                        K<SUP>0</SUP>',
     & '                         K$^{&star0}$',
     & '                       K<SUP>*-</SUP>',
     & '                           K$_1(H)^0$',
     & '         K<SUB>1</SUB>(H)<SUP>0</SUP>',
     & '                       K$^{&star0}_2$',
     & '           K<SUB>2</SUB><SUP>*0</SUP>',
     & '                                     ',
     & '                                     ',
     & '                                     ',
     & '                                     ',
     & '                               $&phi$',
     & '                                  phi'/
      DATA ((TXNAME(J,I),J=1,2),I=57,64)/
     & '                          $f_1(1420)$',
     & '                  f<SUB>1</SUB>(1420)',
     & '                         $f^&prime_2$',
     & '            f<SUP>''</SUP><SUB>2</SUB>',
     & '                             $&gamma$',
     & '                                gamma',
     & '                        K$^0_{&rm S}$',
     & '            K<SUB>S</SUB><SUP>0</SUP>',
     & '                        K$^0_{&rm L}$',
     & '            K<SUB>L</SUB><SUP>0</SUP>',
     & '                        $a_0(1450)^0$',
     & '      a<SUB>0</SUB>(1450)<SUP>0</SUP>',
     & '                        $a_0(1450)^+$',
     & '      a<SUB>0</SUB>(1450)<SUP>+</SUP>',
     & '                        $a_0(1450)^-$',
     & '      a<SUB>0</SUB>(1450)<SUP>-</SUP>'/
      DATA ((TXNAME(J,I),J=1,2),I=65,72)/
     & '                                     ',
     & '                                     ',
     & '                                     ',
     & '                                     ',
     & '                                     ',
     & '                                     ',
     & '                                     ',
     & '                                     ',
     & '                                     ',
     & '                                     ',
     & '                                     ',
     & '                                     ',
     & '                     $&gamma$-remnant',
     & '                        gamma-remnant',
     & '                          $N$-remnant',
     & '                            N-remnant'/
      DATA ((TXNAME(J,I),J=1,2),I=73,80)/
     & '                                    p',
     & '                                    p',
     & '                           $&Delta^+$',
     & '                    Delta<SUP>+</SUP>',
     & '                                    n',
     & '                                    n',
     & '                           $&Delta^0$',
     & '                    Delta<SUP>0</SUP>',
     & '                           $&Delta^-$',
     & '                    Delta<SUP>-</SUP>',
     & '                            $&Lambda$',
     & '                               Lambda',
     & '                           $&Sigma^0$',
     & '                    Sigma<SUP>0</SUP>',
     & '                    $&Sigma^{&star0}$',
     & '                   Sigma<SUP>*0</SUP>'/
      DATA ((TXNAME(J,I),J=1,2),I=81,88)/
     & '                           $&Sigma^-$',
     & '                    Sigma<SUP>-</SUP>',
     & '                    $&Sigma^{&star-}$',
     & '                   Sigma<SUP>*-</SUP>',
     & '                              $&Xi^-$',
     & '                       Xi<SUP>-</SUP>',
     & '                       $&Xi^{&star-}$',
     & '                      Xi<SUP>*-</SUP>',
     & '                        $&Delta^{++}$',
     & '                   Delta<SUP>++</SUP>',
     & '                           $&Sigma^+$',
     & '                    Sigma<SUP>+</SUP>',
     & '                    $&Sigma^{&star+}$',
     & '                   Sigma<SUP>*+</SUP>',
     & '                              $&Xi^0$',
     & '                       Xi<SUP>0</SUP>'/
      DATA ((TXNAME(J,I),J=1,2),I=89,96)/
     & '                       $&Xi^{&star0}$',
     & '                      Xi<SUP>*0</SUP>',
     & '                           $&Omega^-$',
     & '                    Omega<SUP>-</SUP>',
     & '                        $&bar{&rm p}$',
     & '                                   -p',
     & '                $&overline{&Delta}^-$',
     & '                   -Delta<SUP>-</SUP>',
     & '                        $&bar{&rm n}$',
     & '                                   -n',
     & '                $&overline{&Delta}^0$',
     & '                   -Delta<SUP>0</SUP>',
     & '                $&overline{&Delta}^+$',
     & '                   -Delta<SUP>+</SUP>',
     & '                 $&overline{&Lambda}$',
     & '                              -Lambda'/
      DATA ((TXNAME(J,I),J=1,2),I=97,104)/
     & '                $&overline{&Sigma}^0$',
     & '                   -Sigma<SUP>0</SUP>',
     & '         $&overline{&Sigma}^{&star0}$',
     & '                  -Sigma<SUP>*0</SUP>',
     & '                $&overline{&Sigma}^+$',
     & '                   -Sigma<SUP>+</SUP>',
     & '         $&overline{&Sigma}^{&star+}$',
     & '                  -Sigma<SUP>*+</SUP>',
     & '                   $&overline{&Xi}^+$',
     & '                      -Xi<SUP>+</SUP>',
     & '            $&overline{&Xi}^{&star+}$',
     & '                     -Xi<SUP>*+</SUP>',
     & '             $&overline{&Delta}^{--}$',
     & '                  -Delta<SUP>--</SUP>',
     & '                $&overline{&Sigma}^-$',
     & '                   -Sigma<SUP>-</SUP>'/
      DATA ((TXNAME(J,I),J=1,2),I=105,112)/
     & '         $&overline{&Sigma}^{&star-}$',
     & '                  -Sigma<SUP>*-</SUP>',
     & '                   $&overline{&Xi}^0$',
     & '                      -Xi<SUP>0</SUP>',
     & '              $&overline&Xi^{&star0}$',
     & '                     -Xi<SUP>*0</SUP>',
     & '                $&overline{&Omega}^+$',
     & '                   -Omega<SUP>+</SUP>',
     & '                                   uu',
     & '                                   uu',
     & '                                   ud',
     & '                                   ud',
     & '                                   dd',
     & '                                   dd',
     & '                                   us',
     & '                                   us'/
      DATA ((TXNAME(J,I),J=1,2),I=113,120)/
     & '                                   ds',
     & '                                   ds',
     & '                                   ss',
     & '                                   ss',
     & '             $&bar{&rm u}&bar{&rm u}$',
     & '                                  -uu',
     & '             $&bar{&rm u}&bar{&rm d}$',
     & '                                  -ud',
     & '             $&bar{&rm d}&bar{&rm d}$',
     & '                                  -dd',
     & '             $&bar{&rm u}&bar{&rm s}$',
     & '                                  -us',
     & '             $&bar{&rm d}&bar{&rm s}$',
     & '                                  -ds',
     & '             $&bar{&rm s}&bar{&rm s}$',
     & '                                  -ss'/
      DATA ((TXNAME(J,I),J=1,2),I=121,128)/
     & '                                e$^-$',
     & '                        e<SUP>-</SUP>',
     & '                        $&nu_{&rm e}$',
     & '                       nu<SUB>e</SUB>',
     & '                              $&mu^-$',
     & '                       mu<SUP>-</SUP>',
     & '                            $&nu_&mu$',
     & '                      nu<SUB>mu</SUB>',
     & '                             $&tau^-$',
     & '                      tau<SUP>-</SUP>',
     & '                           $&nu_&tau$',
     & '                     nu<SUB>tau</SUB>',
     & '                                e$^+$',
     & '                        e<SUP>+</SUP>',
     & '                  $&bar{&nu}_{&rm e}$',
     & '                      -nu<SUB>e</SUB>'/
      DATA ((TXNAME(J,I),J=1,2),I=129,136)/
     & '                              $&mu^+$',
     & '                       mu<SUP>+</SUP>',
     & '                      $&bar{&nu}_&mu$',
     & '                     -nu<SUB>mu</SUB>',
     & '                             $&tau^+$',
     & '                      tau<SUP>+</SUP>',
     & '                     $&bar{&nu}_&tau$',
     & '                    -nu<SUB>tau</SUB>',
     & '                                     ',
     & '                                     ',
     & '                                     ',
     & '                                     ',
     & '                                     ',
     & '                                     ',
     & '                                D$^+$',
     & '                        D<SUP>+</SUP>'/
      DATA ((TXNAME(J,I),J=1,2),I=137,144)/
     & '                         D$^{&star+}$',
     & '                       D<SUP>*+</SUP>',
     & '                           D$_1(H)^+$',
     & '         D<SUB>1</SUB>(H)<SUP>+</SUP>',
     & '                       D$_2^{&star+}$',
     & '           D<SUB>2</SUB><SUP>*+</SUP>',
     & '                                D$^0$',
     & '                        D<SUP>0</SUP>',
     & '                         D$^{&star0}$',
     & '                       D<SUP>*0</SUP>',
     & '                           D$_1(H)^0$',
     & '         D<SUB>1</SUB>(H)<SUP>0</SUP>',
     & '                       D$_2^{&star0}$',
     & '           D<SUB>2</SUB><SUP>*0</SUP>',
     & '                        D$_{&rm s}^+$',
     & '            D<SUB>s</SUB><SUP>+</SUP>'/
      DATA ((TXNAME(J,I),J=1,2),I=145,152)/
     & '                 D$_{&rm s}^{&star+}$',
     & '           D<SUB>s</SUB><SUP>*+</SUP>',
     & '                    D$_{&rm s1}(H)^+$',
     & '        D<SUB>s1</SUB>(H)<SUP>+</SUP>',
     & '                D$^{&star+}_{&rm s2}$',
     & '       D<SUB>s1</SUB>(H)<SUP>*+</SUP>',
     & '                $&Sigma_{&rm c}^{++}$',
     & '       Sigma<SUB>c</SUB><SUP>++</SUP>',
     & '           $&Sigma_{&rm c}^{&star++}$',
     & '      Sigma<SUB>c</SUB><SUP>*++</SUP>',
     & '                  $&Lambda_{&rm c}^+$',
     & '       Lambda<SUB>c</SUB><SUP>+</SUP>',
     & '                   $&Sigma_{&rm c}^+$',
     & '        Sigma<SUB>c</SUB><SUP>+</SUP>',
     & '            $&Sigma_{&rm c}^{&star+}$',
     & '       Sigma<SUB>c</SUB><SUP>*+</SUP>'/
      DATA ((TXNAME(J,I),J=1,2),I=153,160)/
     & '                   $&Sigma_{&rm c}^0$',
     & '        Sigma<SUB>c</SUB><SUP>0</SUP>',
     & '            $&Sigma_{&rm c}^{&star0}$',
     & '       Sigma<SUB>c</SUB><SUP>*0</SUP>',
     & '                      $&Xi_{&rm c}^+$',
     & '           Xi<SUB>c</SUB><SUP>+</SUP>',
     & '              $&Xi_{&rm c}^{&prime+}$',
     & '          Xi<SUB>c</SUB><SUP>''+</SUP>',
     & '               $&Xi_{&rm c}^{&star+}$',
     & '          Xi<SUB>c</SUB><SUP>*+</SUP>',
     & '                      $&Xi_{&rm c}^0$',
     & '           Xi<SUB>c</SUB><SUP>0</SUP>',
     & '              $&Xi_{&rm c}^{&prime0}$',
     & '          Xi<SUB>c</SUB><SUP>''0</SUP>',
     & '               $&Xi_{&rm c}^{&star0}$',
     & '          Xi<SUB>c</SUB><SUP>*0</SUP>'/
      DATA ((TXNAME(J,I),J=1,2),I=161,168)/
     & '                   $&Omega_{&rm c}^0$',
     & '        Omega<SUB>c</SUB><SUP>0</SUP>',
     & '            $&Omega_{&rm c}^{&star0}$',
     & '       Omega<SUB>c</SUB><SUP>*0</SUP>',
     & '                   $&eta_{&rm c}(1S)$',
     & '                  eta<SUB>c</SUB>(1S)',
     & '                             J/$&psi$',
     & '                                J/psi',
     & '                  $&chi_{&rm c0}(1P)$',
     & '                 chi<SUB>c0</SUB>(1P)',
     & '                           $&psi(2S)$',
     & '                              psi(2S)',
     & '                           $&psi(1D)$',
     & '                              psi(1D)',
     & '                                     ',
     & '                                     '/
      DATA ((TXNAME(J,I),J=1,2),I=169,176)/
     & '                                     ',
     & '                                     ',
     & '                                     ',
     & '                                     ',
     & '                                D$^-$',
     & '                        D<SUP>-</SUP>',
     & '                         D$^{&star-}$',
     & '                       D<SUP>*-</SUP>',
     & '                           D$_1(H)^-$',
     & '         D<SUB>1</SUB>(H)<SUP>-</SUP>',
     & '                       D$_2^{&star-}$',
     & '           D<SUB>2</SUB><SUP>*-</SUP>',
     & '                 $&overline{&rm D}^0$',
     & '                       -D<SUP>0</SUP>',
     & '          $&overline{&rm D}^{&star0}$',
     & '                      -D<SUP>*0</SUP>'/
      DATA ((TXNAME(J,I),J=1,2),I=177,184)/
     & '            $&overline{&rm D}_1(H)^0$',
     & '        -D<SUB>1</SUB>(H)<SUP>0</SUP>',
     & '        $&overline{&rm D}_2^{&star0}$',
     & '          -D<SUB>2</SUB><SUP>*0</SUP>',
     & '                        D$_{&rm s}^-$',
     & '            D<SUB>s</SUB><SUP>-</SUP>',
     & '                 D$_{&rm s}^{&star-}$',
     & '           D<SUB>s</SUB><SUP>*-</SUP>',
     & '                    D$_{&rm s1}(H)^-$',
     & '        D<SUB>s1</SUB>(H)<SUP>-</SUP>',
     & '                D$_{&rm s2}^{&star-}$',
     & '       D<SUB>s1</SUB>(H)<SUP>*-</SUP>',
     & '     $&overline{&Sigma}_{&rm c}^{--}$',
     & '      -Sigma<SUB>c</SUB><SUP>--</SUP>',
     & '$&overline{&Sigma}_{&rm c}^{&star--}$',
     & '     -Sigma<SUB>c</SUB><SUP>*--</SUP>'/
      DATA ((TXNAME(J,I),J=1,2),I=185,192)/
     & '       $&overline{&Lambda}_{&rm c}^-$',
     & '      -Lambda<SUB>c</SUB><SUP>-</SUP>',
     & '        $&overline{&Sigma}_{&rm c}^-$',
     & '       -Sigma<SUB>c</SUB><SUP>-</SUP>',
     & ' $&overline{&Sigma}_{&rm c}^{&star-}$',
     & '      -Sigma<SUB>c</SUB><SUP>*-</SUP>',
     & '        $&overline{&Sigma}_{&rm c}^0$',
     & '       -Sigma<SUB>c</SUB><SUP>0</SUP>',
     & ' $&overline{&Sigma}_{&rm c}^{&star0}$',
     & '      -Sigma<SUB>c</SUB><SUP>*0</SUP>',
     & '           $&overline{&Xi}_{&rm c}^-$',
     & '          -Xi<SUB>c</SUB><SUP>-</SUP>',
     & '   $&overline{&Xi}_{&rm c}^{&prime-}$',
     & '         -Xi<SUB>c</SUB><SUP>''-</SUP>',
     & '    $&overline{&Xi}_{&rm c}^{&star-}$',
     & '         -Xi<SUB>c</SUB><SUP>*-</SUP>'/
      DATA ((TXNAME(J,I),J=1,2),I=193,200)/
     & '           $&overline{&Xi}_{&rm c}^0$',
     & '          -Xi<SUB>c</SUB><SUP>0</SUP>',
     & '   $&overline{&Xi}_{&rm c}^{&prime0}$',
     & '         -Xi<SUB>c</SUB><SUP>''0</SUP>',
     & '    $&overline{&Xi}_{&rm c}^{&star0}$',
     & '         -Xi<SUB>c</SUB><SUP>*0</SUP>',
     & '        $&overline{&Omega}_{&rm c}^0$',
     & '       -Omega<SUB>c</SUB><SUP>0</SUP>',
     & ' $&overline{&Omega}_{&rm c}^{&star0}$',
     & '      -Omega<SUB>c</SUB><SUP>*0</SUP>',
     & '                                W$^+$',
     & '                        W<SUP>+</SUP>',
     & '                                W$^-$',
     & '                        W<SUP>-</SUP>',
     & '                   Z$^0/&gamma^&star$',
     & '      Z<SUP>0</SUP>/gamma<SUP>*</SUP>'/
      DATA ((TXNAME(J,I),J=1,2),I=201,208)/
     & '                       $H^0_{&rm SM}$',
     & '           H<SUP>0</SUP><SUB>SM</SUB>',
     & '                        Z$^{&prime0}$',
     & '                       Z<SUP>''0</SUP>',
     & '                                $h^0$',
     & '                        h<SUP>0</SUP>',
     & '                                $H^0$',
     & '                        H<SUP>0</SUP>',
     & '                                $A^0$',
     & '                        A<SUP>0</SUP>',
     & '                                $H^+$',
     & '                        H<SUP>+</SUP>',
     & '                                $H^-$',
     & '                        H<SUP>-</SUP>',
     & '                                  $G$',
     & '                                    G'/
      DATA ((TXNAME(J,I),J=1,2),I=209,216)/
     & '                              V-quark',
     & '                              V-quark',
     & '                              A-quark',
     & '                              A-quark',
     & '                              H-quark',
     & '                              H-quark',
     & '                     H$^&prime$-quark',
     & '                  H<SUP>''</SUP>-quark',
     & '                                     ',
     & '                                     ',
     & '                                     ',
     & '                                     ',
     & '             $&overline{&rm V}$-quark',
     & '                             -V-quark',
     & '             $&overline{&rm A}$-quark',
     & '                             -A-quark'/
      DATA ((TXNAME(J,I),J=1,2),I=217,224)/
     & '             $&overline{&rm H}$-quark',
     & '                             -H-quark',
     & '      $&overline{&rm H}^&prime$-quark',
     & '                 -H<SUP>''</SUP>-quark',
     & '                                     ',
     & '                                     ',
     & '                                     ',
     & '                                     ',
     & '         $&overline{&rm B}_{&rm d}^0$',
     & '           -B<SUB>d</SUB><SUP>0</SUP>',
     & '                                B$^-$',
     & '                        B<SUP>-</SUP>',
     & '         $&overline{&rm B}_{&rm s}^0$',
     & '           -B<SUB>s</SUB><SUP>0</SUP>',
     & '                   $&Sigma_{&rm b}^+$',
     & '        Sigma<SUB>b</SUB><SUP>+</SUP>'/
      DATA ((TXNAME(J,I),J=1,2),I=225,232)/
     & '                  $&Lambda_{&rm b}^0$',
     & '       Lambda<SUB>b</SUB><SUP>0</SUP>',
     & '                   $&Sigma_{&rm b}^-$',
     & '        Sigma<SUB>b</SUB><SUP>-</SUP>',
     & '                      $&Xi_{&rm b}^0$',
     & '           Xi<SUB>b</SUB><SUP>0</SUP>',
     & '                      $&Xi_{&rm b}^-$',
     & '           Xi<SUB>b</SUB><SUP>-</SUP>',
     & '                   $&Omega_{&rm b}^-$',
     & '        Omega<SUB>b</SUB><SUP>-</SUP>',
     & '                        B$_{&rm c}^-$',
     & '            B<SUB>c</SUB><SUP>-</SUP>',
     & '                       $&Upsilon(1S)$',
     & '                          Upsilon(1S)',
     & '                        T$_{&rm b}^-$',
     & '            T<SUB>b</SUB><SUP>-</SUP>'/
      DATA ((TXNAME(J,I),J=1,2),I=233,240)/
     & '                                T$^+$',
     & '                        T<SUP>+</SUP>',
     & '                                T$^0$',
     & '                        T<SUP>0</SUP>',
     & '                        T$_{&rm s}^+$',
     & '            T<SUB>s</SUB><SUP>+</SUP>',
     & '                $&Sigma_{&rm t}^{++}$',
     & '       Sigma<SUB>t</SUB><SUP>++</SUP>',
     & '                  $&Lambda_{&rm t}^0$',
     & '       Lambda<SUB>t</SUB><SUP>0</SUP>',
     & '                   $&Sigma_{&rm t}^0$',
     & '        Sigma<SUB>t</SUB><SUP>0</SUP>',
     & '                     $&chi_{&rm t}^+$',
     & '           Xi<SUB>t</SUB><SUP>+</SUP>',
     & '                     $&chi_{&rm t}^0$',
     & '           Xi<SUB>t</SUB><SUP>0</SUP>'/
      DATA ((TXNAME(J,I),J=1,2),I=241,248)/
     & '                   $&Omega_{&rm t}^0$',
     & '        Omega<SUB>t</SUB><SUP>0</SUP>',
     & '                        T$_{&rm c}^0$',
     & '            T<SUB>c</SUB><SUP>0</SUP>',
     & '                        T$_{&rm b}^+$',
     & '            T<SUB>b</SUB><SUP>+</SUP>',
     & '                             Toponium',
     & '                             Toponium',
     & '                        B$_{&rm d}^0$',
     & '            B<SUB>d</SUB><SUP>0</SUP>',
     & '                                B$^+$',
     & '                        B<SUP>+</SUP>',
     & '                        B$_{&rm s}^0$',
     & '            B<SUB>s</SUB><SUP>0</SUP>',
     & '        $&overline{&Sigma}_{&rm b}^-$',
     & '       -Sigma<SUB>b</SUB><SUP>-</SUP>'/
      DATA ((TXNAME(J,I),J=1,2),I=249,256)/
     & '       $&overline{&Lambda}_{&rm b}^-$',
     & '      -Lambda<SUB>b</SUB><SUP>-</SUP>',
     & '        $&overline{&Sigma}_{&rm b}^+$',
     & '       -Sigma<SUB>b</SUB><SUP>+</SUP>',
     & '           $&overline{&Xi}_{&rm b}^0$',
     & '          -Xi<SUB>b</SUB><SUP>0</SUP>',
     & '                      $&Xi_{&rm b}^+$',
     & '           Xi<SUB>b</SUB><SUP>+</SUP>',
     & '        $&overline{&Omega}_{&rm b}^+$',
     & '       -Omega<SUB>b</SUB><SUP>+</SUP>',
     & '                        B$_{&rm c}^+$',
     & '            B<SUB>c</SUB><SUP>+</SUP>',
     & '                                T$^-$',
     & '                        T<SUP>-</SUP>',
     & '                 $&overline{&rm T}^0$',
     & '                        T<SUP>0</SUP>'/
      DATA ((TXNAME(J,I),J=1,2),I=257,264)/
     & '                        T$_{&rm s}^-$',
     & '            T<SUB>s</SUB><SUP>-</SUP>',
     & '     $&overline{&Sigma}_{&rm t}^{--}$',
     & '       Sigma<SUB>t</SUB><SUP>--</SUP>',
     & '       $&overline{&Lambda}_{&rm t}^-$',
     & '      -Lambda<SUB>t</SUB><SUP>-</SUP>',
     & '        $&overline{&Sigma}_{&rm t}^0$',
     & '       -Sigma<SUB>t</SUB><SUP>0</SUP>',
     & '           $&overline{&Xi}_{&rm t}^-$',
     & '          -Xi<SUB>t</SUB><SUP>-</SUP>',
     & '           $&overline{&Xi}_{&rm t}^0$',
     & '          -Xi<SUB>t</SUB><SUP>0</SUP>',
     & '        $&overline{&Omega}_{&rm t}^0$',
     & '       -Omega<SUB>t</SUB><SUP>0</SUP>',
     & '         $&overline{&rm T}_{&rm c}^0$',
     & '            T<SUB>c</SUB><SUP>0</SUP>'/
      DATA ((TXNAME(J,I),J=1,2),I=265,272)/
     & '          $&overline{&rm B}^{&star0}$',
     & '                      -B<SUP>*0</SUP>',
     & '                         B$^{&star-}$',
     & '                       B<SUP>*-</SUP>',
     & '  $&overline{&rm B}_{&rm s}^{&star0}$',
     & '          -B<SUB>s</SUB><SUP>*0</SUP>',
     & '            $&overline{&rm B}_1(H)^0$',
     & '        -B<SUB>1</SUB>(H)<SUP>0</SUP>',
     & '                           B$_1(H)^-$',
     & '         B<SUB>1</SUB>(H)<SUP>-</SUP>',
     & '     $&overline{&rm B}_{&rm s1}(H)^0$',
     & '       -B<SUB>s1</SUB>(H)<SUP>0</SUP>',
     & '        $&overline{&rm B}_2^{&star0}$',
     & '          -B<SUB>2</SUB><SUP>*0</SUP>',
     & '                       B$_2^{&star-}$',
     & '           B<SUB>2</SUB><SUP>*-</SUP>'/
      DATA ((TXNAME(J,I),J=1,2),I=273,280)/
     & '                B$_{&rm s2}^{&star0}$',
     & '          B<SUB>s2</SUB><SUP>*0</SUP>',
     & '                         B$^{&star0}$',
     & '                       B<SUP>*0</SUP>',
     & '                         B$^{&star+}$',
     & '                       B<SUP>*+</SUP>',
     & '                 B$_{&rm s}^{&star0}$',
     & '           B<SUB>s</SUB><SUP>*0</SUP>',
     & '                           B$_1(H)^0$',
     & '         B<SUB>1</SUB>(H)<SUP>0</SUP>',
     & '                           B$_1(H)^+$',
     & '         B<SUB>1</SUB>(H)<SUP>+</SUP>',
     & '                    B$_{&rm s1}(H)^0$',
     & '        B<SUB>s1</SUB>(H)<SUP>0</SUP>',
     & '                       B$_2^{&star0}$',
     & '           B<SUB>2</SUB><SUP>*0</SUP>'/
      DATA ((TXNAME(J,I),J=1,2),I=281,288)/
     & '                       B$_2^{&star+}$',
     & '           B<SUB>2</SUB><SUP>*+</SUP>',
     & '                B$_{&rm s2}^{&star0}$',
     & '          B<SUB>s2</SUB><SUP>*0</SUP>',
     & '                                     ',
     & '                                     ',
     & '                                     ',
     & '                                     ',
     & '                              b$_1^0$',
     & '            b<SUB>1</SUB><SUP>0</SUP>',
     & '                              b$_1^+$',
     & '            b<SUB>1</SUB><SUP>+</SUP>',
     & '                              b$_1^-$',
     & '            b<SUB>1</SUB><SUP>-</SUP>',
     & '                           h$_1(L)^0$',
     & '         h<SUB>1</SUB>(L)<SUP>0</SUP>'/
      DATA ((TXNAME(J,I),J=1,2),I=289,296)/
     & '                           h$_1(H)^0$',
     & '         h<SUB>1</SUB>(H)<SUP>0</SUP>',
     & '                         a$_0(980)^0$',
     & '       a<SUB>0</SUB>(980)<SUP>0</SUP>',
     & '                         a$_0(980)^+$',
     & '       a<SUB>0</SUB>(980)<SUP>+</SUP>',
     & '                         a$_0(980)^-$',
     & '       a<SUB>0</SUB>(980)<SUP>-</SUP>',
     & '                           f$_0(980)$',
     & '                   f<SUB>0</SUB>(980)',
     & '                          f$_0(1370)$',
     & '                  f<SUB>0</SUB>(1370)',
     & '                 B$_{&rm c}^{&star+}$',
     & '           B<SUB>c</SUB><SUP>*+</SUP>',
     & '                 B$_{&rm c}^{&star-}$',
     & '           B<SUB>c</SUB><SUP>*-</SUP>'/
      DATA ((TXNAME(J,I),J=1,2),I=297,304)/
     & '                    B$_{&rm c1}(H)^+$',
     & '        B<SUB>c1</SUB>(H)<SUP>+</SUP>',
     & '                    B$_{&rm c1}(H)^-$',
     & '        B<SUB>c1</SUB>(H)<SUP>-</SUP>',
     & '                B$_{&rm c2}^{&star+}$',
     & '          B<SUB>c2</SUB><SUP>*+</SUP>',
     & '                B$_{&rm c2}^{&star-}$',
     & '          B<SUB>c2</SUB><SUP>*-</SUP>',
     & '                      h$_{&rm c}(1P)$',
     & '                    h<SUB>c</SUB>(1P)',
     & '                  $&chi_{&rm c0}(1P)$',
     & '                 chi<SUB>c0</SUB>(1P)',
     & '                  $&chi_{&rm c2}(1P)$',
     & '                 chi<SUB>c2</SUB>(1P)',
     & '                   $&eta_{&rm b}(1S)$',
     & '                  eta<SUB>b</SUB>(1S)'/
      DATA ((TXNAME(J,I),J=1,2),I=305,312)/
     & '                      h$_{&rm b}(1P)$',
     & '                    h<SUB>b</SUB>(1P)',
     & '                  $&chi_{&rm b0}(1P)$',
     & '                 chi<SUB>b0</SUB>(1P)',
     & '                  $&chi_{&rm b1}(1P)$',
     & '                 chi<SUB>b1</SUB>(1P)',
     & '                  $&chi_{&rm b2}(1P)$',
     & '                 chi<SUB>b2</SUB>(1P)',
     & '                           K$_1(L)^0$',
     & '         K<SUB>1</SUB>(L)<SUP>0</SUP>',
     & '                           K$_1(L)^+$',
     & '         K<SUB>1</SUB>(L)<SUP>+</SUP>',
     & '            $&overline{&rm K}_1(L)^0$',
     & '        -K<SUB>1</SUB>(L)<SUP>0</SUP>',
     & '                           K$_1(L)^-$',
     & '         K<SUB>1</SUB>(L)<SUP>-</SUP>'/
      DATA ((TXNAME(J,I),J=1,2),I=313,320)/
     & '                           D$_1(L)^+$',
     & '         D<SUB>1</SUB>(L)<SUP>+</SUP>',
     & '                           D$_1(L)^0$',
     & '         D<SUB>1</SUB>(L)<SUP>0</SUP>',
     & '                    D$_{&rm s1}(L)^+$',
     & '        D<SUB>s1</SUB>(L)<SUP>+</SUP>',
     & '                           D$_1(L)^-$',
     & '         D<SUB>1</SUB>(L)<SUP>-</SUP>',
     & '            $&overline{&rm D}_1(L)^0$',
     & '         D<SUB>1</SUB>(L)<SUP>0</SUP>',
     & '                    D$_{&rm s1}(L)^-$',
     & '        D<SUB>s1</SUB>(L)<SUP>-</SUP>',
     & '                           B$_1(L)^0$',
     & '         B<SUB>1</SUB>(L)<SUP>0</SUP>',
     & '                           B$_1(L)^+$',
     & '         B<SUB>1</SUB>(L)<SUP>+</SUP>'/
      DATA ((TXNAME(J,I),J=1,2),I=321,328)/
     & '                    B$_{&rm s1}(L)^0$',
     & '        B<SUB>s1</SUB>(L)<SUP>0</SUP>',
     & '                    B$_{&rm c1}(L)^+$',
     & '        B<SUB>c1</SUB>(L)<SUP>+</SUP>',
     & '            $&overline{&rm B}_1(L)^0$',
     & '        -B<SUB>1</SUB>(L)<SUP>0</SUP>',
     & '                           B$_1(L)^-$',
     & '         B<SUB>1</SUB>(L)<SUP>-</SUP>',
     & '     $&overline{&rm B}_{&rm s1}(L)^0$',
     & '       -B<SUB>s1</SUB>(L)<SUP>0</SUP>',
     & '                    B$_{&rm c1}(L)^-$',
     & '        B<SUB>c1</SUB>(L)<SUP>-</SUP>',
     & '                       K$_0^{&star+}$',
     & '           K<SUB>0</SUB><SUP>*+</SUP>',
     & '                       K$_0^{&star0}$',
     & '           K<SUB>0</SUB><SUP>*0</SUP>'/
      DATA ((TXNAME(J,I),J=1,2),I=329,336)/
     & '        $&overline{&rm K}_0^{&star0}$',
     & '          -K<SUB>0</SUB><SUP>*0</SUP>',
     & '                       K$_0^{&star-}$',
     & '           K<SUB>0</SUB><SUP>*-</SUP>',
     & '                       D$_0^{&star+}$',
     & '           D<SUB>0</SUB><SUP>*+</SUP>',
     & '                       D$_0^{&star0}$',
     & '           D<SUB>0</SUB><SUP>*0</SUP>',
     & '                D$_{&rm s0}^{&star+}$',
     & '          D<SUB>s0</SUB><SUP>*+</SUP>',
     & '                       D$_0^{&star-}$',
     & '           D<SUB>0</SUB><SUP>*-</SUP>',
     & '        $&overline{&rm D}_0^{&star0}$',
     & '          -D<SUB>0</SUB><SUP>*0</SUP>',
     & '                D$_{&rm s0}^{&star-}$',
     & '          D<SUB>s0</SUB><SUP>*-</SUP>'/
      DATA ((TXNAME(J,I),J=1,2),I=337,344)/
     & '                       B$_0^{&star0}$',
     & '           B<SUB>0</SUB><SUP>*0</SUP>',
     & '                       B$_0^{&star+}$',
     & '           B<SUB>0</SUB><SUP>*+</SUP>',
     & '                B$_{&rm s0}^{&star0}$',
     & '          B<SUB>s0</SUB><SUP>*0</SUP>',
     & '                B$_{&rm c0}^{&star+}$',
     & '          B<SUB>c0</SUB><SUP>*+</SUP>',
     & '        $&overline{&rm B}_0^{&star0}$',
     & '          -B<SUB>0</SUB><SUP>*0</SUP>',
     & '                       B$_0^{&star-}$',
     & '           B<SUB>0</SUB><SUP>*-</SUP>',
     & ' $&overline{&rm B}_{&rm s0}^{&star0}$',
     & '         -B<SUB>s0</SUB><SUP>*0</SUP>',
     & '                B$_{&rm c0}^{&star-}$',
     & '          B<SUB>c0</SUB><SUP>*-</SUP>'/
      DATA ((TXNAME(J,I),J=1,2),I=345,352)/
     & '                   $&Sigma_{&rm b}^0$',
     & '        Sigma<SUB>b</SUB><SUP>0</SUP>',
     & '            $&Sigma_{&rm b}^{&star-}$',
     & '       Sigma<SUB>b</SUB><SUP>*-</SUP>',
     & '            $&Sigma_{&rm b}^{&star0}$',
     & '       Sigma<SUB>b</SUB><SUP>*0</SUP>',
     & '            $&Sigma_{&rm b}^{&star+}$',
     & '       Sigma<SUB>b</SUB><SUP>*+</SUP>',
     & '              $&Xi_{&rm b}^{&prime0}$',
     & '          Xi<SUB>b</SUB><SUP>''0</SUP>',
     & '               $&Xi_{&rm b}^{&star0}$',
     & '          Xi<SUB>b</SUB><SUP>*0</SUP>',
     & '              $&Xi_{&rm b}^{&prime-}$',
     & '          Xi<SUB>b</SUB><SUP>''-</SUP>',
     & '               $&Xi_{&rm b}^{&star-}$',
     & '          Xi<SUB>b</SUB><SUP>*-</SUP>'/
      DATA ((TXNAME(J,I),J=1,2),I=353,360)/
     & '            $&Omega_{&rm b}^{&star-}$',
     & '      -Omega<SUB>b</SUB><SUP>*-</SUP>',
     & ' $&overline{&Sigma}_{&rm b}^{&star+}$',
     & '       Sigma<SUB>b</SUB><SUP>*+</SUP>',
     & '        $&overline{&Sigma}_{&rm b}^0$',
     & '       -Sigma<SUB>b</SUB><SUP>0</SUP>',
     & ' $&overline{&Sigma}_{&rm b}^{&star0}$',
     & '      -Sigma<SUB>b</SUB><SUP>*0</SUP>',
     & ' $&overline{&Sigma}_{&rm b}^{&star-}$',
     & '      -Sigma<SUB>b</SUB><SUP>*-</SUP>',
     & '   $&overline{&Xi}_{&rm b}^{&prime0}$',
     & '         -Xi<SUB>b</SUB><SUP>''0</SUP>',
     & '    $&overline{&Xi}_{&rm b}^{&star0}$',
     & '         -Xi<SUB>b</SUB><SUP>*0</SUP>',
     & '   $&overline{&Xi}_{&rm b}^{&prime+}$',
     & '         -Xi<SUB>b</SUB><SUP>''+</SUP>'/
      DATA ((TXNAME(J,I),J=1,2),I=361,368)/
     & '    $&overline{&Xi}_{&rm b}^{&star+}$',
     & '         -Xi<SUB>b</SUB><SUP>*+</SUP>',
     & '            $&Omega_{&rm b}^{&star+}$',
     & '       Omega<SUB>b</SUB><SUP>*+</SUP>',
     & '                          K$(DL)_2^+$',
     & '        K(DL)<SUB>2</SUB><SUP>+</SUP>',
     & '                          K$(DL)_2^0$',
     & '        K(DL)<SUB>2</SUB><SUP>0</SUP>',
     & '           $&overline{&rm K}(DL)_2^0$',
     & '       -K(DL)<SUB>2</SUB><SUP>0</SUP>',
     & '                          K$(DL)_2^-$',
     & '        K(DL)<SUB>2</SUB><SUP>-</SUP>',
     & '                      K$(D)^{&star+}$',
     & '                    K(D)<SUP>*+</SUP>',
     & '                      K$(D)^{&star0}$',
     & '                    K(D)<SUP>*0</SUP>'/
      DATA ((TXNAME(J,I),J=1,2),I=369,376)/
     & '      $&overline{&rm  K}(D)^{&star0}$',
     & '                   -K(D)<SUP>*0</SUP>',
     & '                      K$(D)^{&star-}$',
     & '                    K(D)<SUP>*-</SUP>',
     & '                          K$(DH)_2^+$',
     & '        K(DH)<SUB>2</SUB><SUP>+</SUP>',
     & '                          K$(DH)_2^0$',
     & '        K(DH)<SUB>2</SUB><SUP>0</SUP>',
     & '           $&overline{&rm K}(DH)_2^0$',
     & '       -K(DH)<SUB>2</SUB><SUP>0</SUP>',
     & '                          K$(DH)_2^-$',
     & '        K(DH)<SUB>2</SUB><SUP>-</SUP>',
     & '                           K$(D)_3^+$',
     & '         K(D)<SUB>3</SUB><SUP>+</SUP>',
     & '                           K$(D)_3^0$',
     & '         K(D)<SUB>3</SUB><SUP>0</SUP>'/
      DATA ((TXNAME(J,I),J=1,2),I=377,384)/
     & '            $&overline{&rm K}(D)_3^0$',
     & '        -K(D)<SUB>3</SUB><SUP>0</SUP>',
     & '                           K$(D)_3^-$',
     & '         K(D)<SUB>3</SUB><SUP>-</SUP>',
     & '                            $&pi_2^+$',
     & '           pi<SUB>2</SUB><SUP>+</SUP>',
     & '                            $&pi_2^0$',
     & '           pi<SUB>2</SUB><SUP>0</SUP>',
     & '                            $&pi_2^-$',
     & '           pi<SUB>2</SUB><SUP>-</SUP>',
     & '                          $&rho(D)^+$',
     & '                   rho(D)<SUP>+</SUP>',
     & '                          $&rho(D)^0$',
     & '                   rho(D)<SUP>0</SUP>',
     & '                          $&rho(D)^-$',
     & '                   rho(D)<SUP>-</SUP>'/
      DATA ((TXNAME(J,I),J=1,2),I=385,392)/
     & '                           $&rho_3^+$',
     & '          rho<SUB>3</SUB><SUP>+</SUP>',
     & '                           $&rho_3^0$',
     & '          rho<SUB>3</SUB><SUP>0</SUP>',
     & '                           $&rho_3^-$',
     & '          rho<SUB>3</SUB><SUP>-</SUP>',
     & '                       $&Upsilon(2S)$',
     & '                          Upsilon(2S)',
     & '                  $&chi_{&rm b0}(2P)$',
     & '                 Chi<SUB>b0</SUB>(2P)',
     & '                  $&chi_{&rm b1}(2P)$',
     & '                 Chi<SUB>b1</SUB>(2P)',
     & '                  $&chi_{&rm b2}(2P)$',
     & '                 Chi<SUB>b2</SUB>(2P)',
     & '                       $&Upsilon(3S)$',
     & '                          Upsilon(3S)'/
      DATA ((TXNAME(J,I),J=1,2),I=393,400)/
     & '                       $&Upsilon(4S)$',
     & '                          Upsilon(4S)',
     & '                                     ',
     & '                                     ',
     & '                           $&omega_3$',
     & '                    omega<SUB>3</SUB>',
     & '                             $&phi_3$',
     & '                      phi<SUB>3</SUB>',
     & '                          $&eta_2(L)$',
     & '                   eta<SUB>2</SUB>(L)',
     & '                          $&eta_2(H)$',
     & '                   eta<SUB>2</SUB>(H)',
     & '                          $&omega(H)$',
     & '                             omega(H)',
     & '                                     ',
     & '                                     '/
      DATA ((TXNAME(J,I),J=1,2),I=401,408)/
     & '              $&tilde{&rm d}_{&rm L}$',
     & '                       ~d<SUB>L</SUB>',
     & '              $&tilde{&rm u}_{&rm L}$',
     & '                       ~u<SUB>L</SUB>',
     & '              $&tilde{&rm s}_{&rm L}$',
     & '                       ~s<SUB>L</SUB>',
     & '              $&tilde{&rm c}_{&rm L}$',
     & '                       ~c<SUB>L</SUB>',
     & '                    $&tilde{&rm b}_1$',
     & '                       ~b<SUB>1</SUB>',
     & '                    $&tilde{&rm t}_1$',
     & '                       ~t<SUB>1</SUB>',
     & '   $&overline{&tilde{&rm d}}_{&rm L}$',
     & '                      -~d<SUB>L</SUB>',
     & '   $&overline{&tilde{&rm u}}_{&rm L}$',
     & '                      -~u<SUB>L</SUB>'/
      DATA ((TXNAME(J,I),J=1,2),I=409,416)/
     & '   $&overline{&tilde{&rm s}}_{&rm L}$',
     & '                      -~s<SUB>L</SUB>',
     & '   $&overline{&tilde{&rm c}}_{&rm L}$',
     & '                      -~c<SUB>L</SUB>',
     & '         $&overline{&tilde{&rm b}}_1$',
     & '                      -~b<SUB>1</SUB>',
     & '         $&overline{&tilde{&rm t}}_1$',
     & '                      -~t<SUB>1</SUB>',
     & '              $&tilde{&rm d}_{&rm R}$',
     & '                       ~d<SUB>R</SUB>',
     & '              $&tilde{&rm u}_{&rm R}$',
     & '                       ~u<SUB>R</SUB>',
     & '              $&tilde{&rm s}_{&rm R}$',
     & '                       ~s<SUB>R</SUB>',
     & '              $&tilde{&rm c}_{&rm R}$',
     & '                       ~c<SUB>R</SUB>'/
      DATA ((TXNAME(J,I),J=1,2),I=417,424)/
     & '                    $&tilde{&rm b}_2$',
     & '                       ~b<SUB>2</SUB>',
     & '                    $&tilde{&rm t}_2$',
     & '                       ~t<SUB>2</SUB>',
     & '   $&overline{&tilde{&rm d}}_{&rm R}$',
     & '                      -~d<SUB>R</SUB>',
     & '   $&overline{&tilde{&rm u}}_{&rm R}$',
     & '                      -~u<SUB>R</SUB>',
     & '   $&overline{&tilde{&rm s}}_{&rm R}$',
     & '                      -~s<SUB>R</SUB>',
     & '   $&overline{&tilde{&rm c}}_{&rm R}$',
     & '                      -~c<SUB>R</SUB>',
     & '         $&overline{&tilde{&rm b}}_2$',
     & '                      -~b<SUB>2</SUB>',
     & '         $&overline{&tilde{&rm t}}_2$',
     & '                      -~t<SUB>2</SUB>'/
      DATA ((TXNAME(J,I),J=1,2),I=425,432)/
     & '            $&tilde{&rm e}^-_{&rm L}$',
     & '           ~e<SUP>-</SUP><SUB>L</SUB>',
     & '                $&tilde{&nu}_{&rm e}$',
     & '                    ~nu<SUB>e L</SUB>',
     & '              $&tilde{&mu}^-_{&rm L}$',
     & '          ~mu<SUP>-</SUP><SUB>L</SUB>',
     & '                    $&tilde{&nu}_&mu$',
     & '                   ~nu<SUB>mu L</SUB>',
     & '                   $&tilde{&tau}^-_1$',
     & '         ~tau<SUP>-</SUP><SUB>1</SUB>',
     & '                   $&tilde{&nu}_&tau$',
     & '                  ~nu<SUB>tau L</SUB>',
     & '            $&tilde{&rm e}^+_{&rm L}$',
     & '           ~e<SUP>+</SUP><SUB>L</SUB>',
     & '    $&overline{&tilde{&nu}}_{&rm eL}$',
     & '                    -~nu<SUB>eL</SUB>'/
      DATA ((TXNAME(J,I),J=1,2),I=433,440)/
     & '              $&tilde{&mu}^+_{&rm L}$',
     & '          ~mu<SUP>+</SUP><SUB>L</SUB>',
     & '  $&overline{&tilde{&nu}}_{&rm&mu L}$',
     & '                  -~nu<SUB>mu L</SUB>',
     & '                   $&tilde{&tau}^+_1$',
     & '         ~tau<SUP>+</SUP><SUB>1</SUB>',
     & ' $&overline{&tilde{&nu}}_{&rm&tau L}$',
     & '                 -~nu<SUB>tau L</SUB>',
     & '            $&tilde{&rm e}^-_{&rm R}$',
     & '           ~e<SUP>-</SUP><SUB>R</SUB>',
     & '               $&tilde{&nu}_{&rm eR}$',
     & '                    ~nu<SUB>e R</SUB>',
     & '              $&tilde{&mu}^-_{&rm R}$',
     & '          ~mu<SUP>-</SUP><SUB>R</SUB>',
     & '           $&tilde{&nu}_{&mu{&rm R}}$',
     & '                   ~nu<SUB>mu R</SUB>'/
      DATA ((TXNAME(J,I),J=1,2),I=441,448)/
     & '                   $&tilde{&tau}^-_2$',
     & '         ~tau<SUP>-</SUP><SUB>2</SUB>',
     & '          $&tilde{&nu}_{&tau{&rm R}}$',
     & '                  ~nu<SUB>tau R</SUB>',
     & '            $&tilde{&rm e}^+_{&rm R}$',
     & '           ~e<SUP>+</SUP><SUB>R</SUB>',
     & '    $&overline{&tilde{&nu}}_{&rm eR}$',
     & '                   -~nu<SUB>e R</SUB>',
     & '              $&tilde{&mu}^+_{&rm R}$',
     & '          ~mu<SUP>+</SUP><SUB>R</SUB>',
     & '  $&overline{&tilde{&nu}}_{&rm&mu R}$',
     & '                  -~nu<SUB>mu R</SUB>',
     & '                   $&tilde{&tau}^+_2$',
     & '         ~tau<SUP>+</SUP><SUB>2</SUB>',
     & ' $&overline{&tilde{&nu}}_{&rm&tau R}$',
     & '                 -~nu<SUB>tau R</SUB>'/
      DATA ((TXNAME(J,I),J=1,2),I=449,456)/
     & '                          $&tilde{g}$',
     & '                                   ~g',
     & '                   $&tilde{&chi}^0_1$',
     & '         ~chi<SUP>0</SUP><SUB>1</SUB>',
     & '                   $&tilde{&chi}^0_2$',
     & '         ~chi<SUP>0</SUP><SUB>2</SUB>',
     & '                   $&tilde{&chi}^0_3$',
     & '         ~chi<SUP>0</SUP><SUB>3</SUB>',
     & '                   $&tilde{&chi}^0_4$',
     & '         ~chi<SUP>0</SUP><SUB>4</SUB>',
     & '                   $&tilde{&chi}^+_1$',
     & '         ~chi<SUP>+</SUP><SUB>1</SUB>',
     & '                   $&tilde{&chi}^+_2$',
     & '         ~chi<SUP>+</SUP><SUB>2</SUB>',
     & '                   $&tilde{&chi}^-_1$',
     & '         ~chi<SUP>-</SUP><SUB>1</SUB>'/
      DATA ((TXNAME(J,I),J=1,2),I=457,NLAST)/
     & '                   $&tilde{&chi}^-_2$',
     & '         ~chi<SUP>-</SUP><SUB>2</SUB>',
     & '                          $&tilde{G}$',
     & '                                   ~G'/
C
      DATA (RNAME(I),I=NNEXT,NMXRES)/NLEFT*'        '/
      DATA (IDPDG(I),I=NNEXT,NMXRES)/NLEFT*0/
      DATA (IFLAV(I),I=NNEXT,NMXRES)/NLEFT*0/
      DATA (RMASS(I),I=NNEXT,NMXRES)/NLEFT*0.0000/
      DATA (RLTIM(I),I=NNEXT,NMXRES)/NLEFT*0.000D+00/
      DATA (RSPIN(I),I=NNEXT,NMXRES)/NLEFT*0.0/
      DATA (TXNAME(1,I),I=NNEXT,NMXRES)/
     & NLEFT*'                                    '/
      DATA (TXNAME(2,I),I=NNEXT,NMXRES)/
     & NLEFT*'                                    '/
C
      DATA (RSTAB(I),I=1,NMXRES)/NMXRES*.FALSE./
      DATA DKPSET/.FALSE./
C
      DATA NDKYS/2263/
      DATA (IDK(I),BRFRAC(I),NME(I),(IDKPRD(J,I),J=1,5),I=   1,  19)/
     &   6,0.334,100,  2,  7,  5,  0,  0,
     &   6,0.333,100,  4,  9,  5,  0,  0,
     &   6,0.111,100,122,127,  5,  0,  0,
     &   6,0.111,100,124,129,  5,  0,  0,
     &   6,0.111,100,126,131,  5,  0,  0,
     &  12,0.334,100,  8,  1, 11,  0,  0,
     &  12,0.333,100, 10,  3, 11,  0,  0,
     &  12,0.111,100,128,121, 11,  0,  0,
     &  12,0.111,100,130,123, 11,  0,  0,
     &  12,0.111,100,132,125, 11,  0,  0,
     &  21,0.988,  0, 59, 59,  0,  0,  0,
     &  21,0.012,  0,127,121, 59,  0,  0,
     &  22,0.388,  0, 59, 59,  0,  0,  0,
     &  22,0.319,  0, 21, 21, 21,  0,  0,
     &  22,0.001,  0, 21, 59, 59,  0,  0,
     &  22,0.236,  0, 38, 30, 21,  0,  0,
     &  22,0.049,  0, 38, 30, 59,  0,  0,
     &  22,0.005,  0,127,121, 59,  0,  0,
     &  22,0.002,  0, 38, 30,127,121,  0/
      DATA (IDK(I),BRFRAC(I),NME(I),(IDKPRD(J,I),J=1,5),I=  20,  38)/
     &  23,0.989,  0, 38, 30,  0,  0,  0,
     &  23,0.010,  0, 38, 30, 59,  0,  0,
     &  23,0.001,  0, 21, 59,  0,  0,  0,
     &  24,0.888,  0, 38, 30, 21,  0,  0,
     &  24,0.085,  0, 21, 59,  0,  0,  0,
     &  24,0.022,  0, 38, 30,  0,  0,  0,
     &  24,0.001,  0, 22, 59,  0,  0,  0,
     &  24,0.001,  0, 21,127,121,  0,  0,
     &  24,0.003,  0, 38, 30, 21, 21,  0,
     &  25,0.437,  0, 38, 30, 22,  0,  0,
     &  25,0.302,  0, 23, 59,  0,  0,  0,
     &  25,0.208,  0, 21, 21, 22,  0,  0,
     &  25,0.030,  0, 24, 59,  0,  0,  0,
     &  25,0.021,  0, 59, 59,  0,  0,  0,
     &  25,0.002,  0, 21, 21, 21,  0,  0,
     &  26,0.566,  0, 38, 30,  0,  0,  0,
     &  26,0.283,  0, 21, 21,  0,  0,  0,
     &  26,0.069,  0, 38, 30, 21, 21,  0,
     &  26,0.023,  0, 46, 34,  0,  0,  0/
      DATA (IDK(I),BRFRAC(I),NME(I),(IDKPRD(J,I),J=1,5),I=  39,  57)/
     &  26,0.023,  0, 50, 42,  0,  0,  0,
     &  26,0.028,  0, 38, 38, 30, 30,  0,
     &  26,0.005,  0, 22, 22,  0,  0,  0,
     &  26,0.003,  0, 21, 21, 21, 21,  0,
     &  27,0.499,  0, 39, 30,  0,  0,  0,
     &  27,0.499,  0, 31, 38,  0,  0,  0,
     &  27,0.002,  0, 21, 59, 59,  0,  0,
     &  28,0.148,  0, 21, 21, 38, 30,  0,
     &  28,0.148,  0, 23, 38, 30,  0,  0,
     &  28,0.147,  0,291, 30,  0,  0,  0,
     &  28,0.147,  0,290, 21,  0,  0,  0,
     &  28,0.147,  0,292, 38,  0,  0,  0,
     &  28,0.067,  0, 22, 38, 30,  0,  0,
     &  28,0.033,  0, 22, 21, 21,  0,  0,
     &  28,0.032,  0, 46, 42, 30,  0,  0,
     &  28,0.016,  0, 46, 34, 21,  0,  0,
     &  28,0.016,  0, 50, 42, 21,  0,  0,
     &  28,0.032,  0, 50, 34, 38,  0,  0,
     &  28,0.066,  0, 59, 23,  0,  0,  0/
      DATA (IDK(I),BRFRAC(I),NME(I),(IDKPRD(J,I),J=1,5),I=  58,  76)/
     &  28,0.001,  0, 56, 59,  0,  0,  0,
     &  29,0.349,  0, 39, 30,  0,  0,  0,
     &  29,0.349,  0, 31, 38,  0,  0,  0,
     &  29,0.144,  0, 22, 21,  0,  0,  0,
     &  29,0.104,  0, 24, 38, 30,  0,  0,
     &  29,0.024,  0, 46, 34,  0,  0,  0,
     &  29,0.024,  0, 50, 42,  0,  0,  0,
     &  29,0.006,  0, 25, 21,  0,  0,  0,
     &  30,1.000,  0,123,130,  0,  0,  0,
     &  31,1.000,  0, 30, 21,  0,  0,  0,
     &  32,0.499,  0, 31, 21,  0,  0,  0,
     &  32,0.499,  0, 23, 30,  0,  0,  0,
     &  32,0.002,  0, 30, 59,  0,  0,  0,
     &  33,0.349,  0, 31, 21,  0,  0,  0,
     &  33,0.349,  0, 23, 30,  0,  0,  0,
     &  33,0.144,  0, 22, 30,  0,  0,  0,
     &  33,0.101,  0, 24, 30, 21,  0,  0,
     &  33,0.048,  0, 50, 34,  0,  0,  0,
     &  33,0.006,  0, 25, 30,  0,  0,  0/
      DATA (IDK(I),BRFRAC(I),NME(I),(IDKPRD(J,I),J=1,5),I=  77,  95)/
     &  33,0.003,  0, 30, 59,  0,  0,  0,
     &  34,0.629,  0,123,130,  0,  0,  0,
     &  34,0.212,  0, 30, 21,  0,  0,  0,
     &  34,0.056,  0, 30, 38, 30,  0,  0,
     &  34,0.017,  0, 30, 21, 21,  0,  0,
     &  34,0.048,101,121,128, 21,  0,  0,
     &  34,0.032,101,123,130, 21,  0,  0,
     &  34,0.006,  0,123,130, 59,  0,  0,
     &  35,0.666,  0, 42, 30,  0,  0,  0,
     &  35,0.333,  0, 34, 21,  0,  0,  0,
     &  35,0.001,  0, 34, 59,  0,  0,  0,
     &  36,0.627,  0, 43, 30,  0,  0,  0,
     &  36,0.313,  0, 35, 21,  0,  0,  0,
     &  36,0.020,  0, 42, 31,  0,  0,  0,
     &  36,0.010,  0, 34, 23,  0,  0,  0,
     &  36,0.020,  0, 34,294,  0,  0,  0,
     &  36,0.010,  0, 34, 24,  0,  0,  0,
     &  37,0.331,  0, 42, 30,  0,  0,  0,
     &  37,0.166,  0, 34, 21,  0,  0,  0/
      DATA (IDK(I),BRFRAC(I),NME(I),(IDKPRD(J,I),J=1,5),I=  96, 114)/
     &  37,0.168,  0, 43, 30,  0,  0,  0,
     &  37,0.084,  0, 35, 21,  0,  0,  0,
     &  37,0.087,  0, 35, 38, 30,  0,  0,
     &  37,0.044,  0, 35, 21, 21,  0,  0,
     &  37,0.059,  0, 42, 31,  0,  0,  0,
     &  37,0.029,  0, 34, 23,  0,  0,  0,
     &  37,0.029,  0, 34, 24,  0,  0,  0,
     &  37,0.002,  0, 34, 59,  0,  0,  0,
     &  37,0.001,  0, 34, 22,  0,  0,  0,
     &  38,1.000,  0,129,124,  0,  0,  0,
     &  39,1.000,  0, 38, 21,  0,  0,  0,
     &  40,0.499,  0, 39, 21,  0,  0,  0,
     &  40,0.499,  0, 23, 38,  0,  0,  0,
     &  40,0.002,  0, 38, 59,  0,  0,  0,
     &  41,0.349,  0, 39, 21,  0,  0,  0,
     &  41,0.349,  0, 23, 38,  0,  0,  0,
     &  41,0.144,  0, 22, 38,  0,  0,  0,
     &  41,0.101,  0, 24, 38, 21,  0,  0,
     &  41,0.048,  0, 46, 42,  0,  0,  0/
      DATA (IDK(I),BRFRAC(I),NME(I),(IDKPRD(J,I),J=1,5),I= 115, 133)/
     &  41,0.006,  0, 25, 38,  0,  0,  0,
     &  41,0.003,  0, 38, 59,  0,  0,  0,
     &  42,0.500,  0, 60,  0,  0,  0,  0,
     &  42,0.500,  0, 61,  0,  0,  0,  0,
     &  43,0.665,  0, 34, 38,  0,  0,  0,
     &  43,0.333,  0, 42, 21,  0,  0,  0,
     &  43,0.002,  0, 42, 59,  0,  0,  0,
     &  44,0.627,  0, 35, 38,  0,  0,  0,
     &  44,0.313,  0, 43, 21,  0,  0,  0,
     &  44,0.020,  0, 34, 39,  0,  0,  0,
     &  44,0.010,  0, 42, 23,  0,  0,  0,
     &  44,0.020,  0, 42,294,  0,  0,  0,
     &  44,0.010,  0, 42, 24,  0,  0,  0,
     &  45,0.331,  0, 34, 38,  0,  0,  0,
     &  45,0.166,  0, 42, 21,  0,  0,  0,
     &  45,0.168,  0, 35, 38,  0,  0,  0,
     &  45,0.084,  0, 43, 21,  0,  0,  0,
     &  45,0.089,  0, 42, 38, 30,  0,  0,
     &  45,0.044,  0, 42, 21, 21,  0,  0/
      DATA (IDK(I),BRFRAC(I),NME(I),(IDKPRD(J,I),J=1,5),I= 134, 152)/
     &  45,0.059,  0, 34, 39,  0,  0,  0,
     &  45,0.029,  0, 42, 23,  0,  0,  0,
     &  45,0.029,  0, 42, 24,  0,  0,  0,
     &  45,0.001,  0, 42, 22,  0,  0,  0,
     &  46,0.629,  0,129,124,  0,  0,  0,
     &  46,0.212,  0, 38, 21,  0,  0,  0,
     &  46,0.056,  0, 38, 38, 30,  0,  0,
     &  46,0.017,  0, 38, 21, 21,  0,  0,
     &  46,0.032,101,129,124, 21,  0,  0,
     &  46,0.048,101,127,122, 21,  0,  0,
     &  46,0.006,  0,129,124, 59,  0,  0,
     &  47,0.666,  0, 50, 38,  0,  0,  0,
     &  47,0.333,  0, 46, 21,  0,  0,  0,
     &  47,0.001,  0, 46, 59,  0,  0,  0,
     &  48,0.627,  0, 51, 38,  0,  0,  0,
     &  48,0.313,  0, 47, 21,  0,  0,  0,
     &  48,0.020,  0, 50, 39,  0,  0,  0,
     &  48,0.010,  0, 46, 23,  0,  0,  0,
     &  48,0.020,  0, 46,294,  0,  0,  0/
      DATA (IDK(I),BRFRAC(I),NME(I),(IDKPRD(J,I),J=1,5),I= 153, 171)/
     &  48,0.010,  0, 46, 24,  0,  0,  0,
     &  49,0.331,  0, 50, 38,  0,  0,  0,
     &  49,0.166,  0, 46, 21,  0,  0,  0,
     &  49,0.168,  0, 51, 38,  0,  0,  0,
     &  49,0.084,  0, 47, 21,  0,  0,  0,
     &  49,0.087,  0, 47, 38, 30,  0,  0,
     &  49,0.044,  0, 47, 21, 21,  0,  0,
     &  49,0.059,  0, 50, 39,  0,  0,  0,
     &  49,0.029,  0, 46, 23,  0,  0,  0,
     &  49,0.029,  0, 46, 24,  0,  0,  0,
     &  49,0.002,  0, 46, 59,  0,  0,  0,
     &  49,0.001,  0, 46, 22,  0,  0,  0,
     &  50,0.500,  0, 60,  0,  0,  0,  0,
     &  50,0.500,  0, 61,  0,  0,  0,  0,
     &  51,0.665,  0, 46, 30,  0,  0,  0,
     &  51,0.333,  0, 50, 21,  0,  0,  0,
     &  51,0.002,  0, 50, 59,  0,  0,  0,
     &  52,0.627,  0, 47, 30,  0,  0,  0,
     &  52,0.313,  0, 51, 21,  0,  0,  0/
      DATA (IDK(I),BRFRAC(I),NME(I),(IDKPRD(J,I),J=1,5),I= 172, 190)/
     &  52,0.020,  0, 46, 31,  0,  0,  0,
     &  52,0.010,  0, 50, 23,  0,  0,  0,
     &  52,0.020,  0, 50,294,  0,  0,  0,
     &  52,0.010,  0, 50, 24,  0,  0,  0,
     &  53,0.331,  0, 46, 30,  0,  0,  0,
     &  53,0.166,  0, 50, 21,  0,  0,  0,
     &  53,0.168,  0, 47, 30,  0,  0,  0,
     &  53,0.084,  0, 51, 21,  0,  0,  0,
     &  53,0.089,  0, 50, 38, 30,  0,  0,
     &  53,0.044,  0, 50, 21, 21,  0,  0,
     &  53,0.059,  0, 46, 31,  0,  0,  0,
     &  53,0.029,  0, 50, 23,  0,  0,  0,
     &  53,0.029,  0, 50, 24,  0,  0,  0,
     &  53,0.001,  0, 50, 22,  0,  0,  0,
     &  56,0.490,  0, 46, 34,  0,  0,  0,
     &  56,0.342,  0, 61, 60,  0,  0,  0,
     &  56,0.043,  0, 39, 30,  0,  0,  0,
     &  56,0.043,  0, 23, 21,  0,  0,  0,
     &  56,0.043,  0, 31, 38,  0,  0,  0/
      DATA (IDK(I),BRFRAC(I),NME(I),(IDKPRD(J,I),J=1,5),I= 191, 209)/
     &  56,0.025,  0, 38, 30, 21,  0,  0,
     &  56,0.013,  0, 22, 59,  0,  0,  0,
     &  56,0.001,  0, 21, 59,  0,  0,  0,
     &  57,0.250,  0, 50, 43,  0,  0,  0,
     &  57,0.250,  0, 34, 47,  0,  0,  0,
     &  57,0.250,  0, 42, 51,  0,  0,  0,
     &  57,0.250,  0, 46, 35,  0,  0,  0,
     &  58,0.356,  0, 46, 34,  0,  0,  0,
     &  58,0.356,  0, 50, 42,  0,  0,  0,
     &  58,0.279,  0, 22, 22,  0,  0,  0,
     &  58,0.006,  0, 38, 30,  0,  0,  0,
     &  58,0.003,  0, 21, 21,  0,  0,  0,
     &  60,0.684,  0, 38, 30,  0,  0,  0,
     &  60,0.314,  0, 21, 21,  0,  0,  0,
     &  60,0.002,  0, 38, 30, 59,  0,  0,
     &  61,0.216,  0, 21, 21, 21,  0,  0,
     &  61,0.124,  0, 38, 30, 21,  0,  0,
     &  61,0.135,101,123,130, 38,  0,  0,
     &  61,0.135,101,124,129, 30,  0,  0/
      DATA (IDK(I),BRFRAC(I),NME(I),(IDKPRD(J,I),J=1,5),I= 210, 228)/
     &  61,0.187,101,121,128, 38,  0,  0,
     &  61,0.187,101,122,127, 30,  0,  0,
     &  61,0.006,  0,121,128, 38, 59,  0,
     &  61,0.006,  0,122,127, 30, 59,  0,
     &  61,0.002,  0, 38, 30,  0,  0,  0,
     &  61,0.001,  0, 21, 21,  0,  0,  0,
     &  61,0.001,  0, 59, 59,  0,  0,  0,
     &  74,0.663,  0, 73, 21,  0,  0,  0,
     &  74,0.331,  0, 75, 38,  0,  0,  0,
     &  74,0.006,  0, 73, 59,  0,  0,  0,
     &  75,1.000,101,121,128, 73,  0,  0,
     &  76,0.663,  0, 75, 21,  0,  0,  0,
     &  76,0.331,  0, 73, 30,  0,  0,  0,
     &  76,0.006,  0, 75, 59,  0,  0,  0,
     &  77,1.000,  0, 75, 30,  0,  0,  0,
     &  78,0.638,  0, 73, 30,  0,  0,  0,
     &  78,0.358,  0, 75, 21,  0,  0,  0,
     &  78,0.002,  0, 75, 59,  0,  0,  0,
     &  78,0.001,  0, 73, 30, 59,  0,  0/
      DATA (IDK(I),BRFRAC(I),NME(I),(IDKPRD(J,I),J=1,5),I= 229, 247)/
     &  78,0.001,101,121,128, 73,  0,  0,
     &  79,0.995,  0, 78, 59,  0,  0,  0,
     &  79,0.005,  0, 78,127,121,  0,  0,
     &  80,0.880,  0, 78, 21,  0,  0,  0,
     &  80,0.060,  0, 86, 30,  0,  0,  0,
     &  80,0.060,  0, 81, 38,  0,  0,  0,
     &  81,0.998,  0, 75, 30,  0,  0,  0,
     &  81,0.001,  0, 75, 30, 59,  0,  0,
     &  81,0.001,101,121,128, 75,  0,  0,
     &  82,0.880,  0, 78, 30,  0,  0,  0,
     &  82,0.060,  0, 79, 30,  0,  0,  0,
     &  82,0.060,  0, 81, 21,  0,  0,  0,
     &  83,0.999,  0, 78, 30,  0,  0,  0,
     &  83,0.001,101,121,128, 78,  0,  0,
     &  84,0.667,  0, 88, 30,  0,  0,  0,
     &  84,0.333,  0, 83, 21,  0,  0,  0,
     &  85,1.000,  0, 73, 38,  0,  0,  0,
     &  86,0.516,  0, 73, 21,  0,  0,  0,
     &  86,0.483,  0, 75, 38,  0,  0,  0/
      DATA (IDK(I),BRFRAC(I),NME(I),(IDKPRD(J,I),J=1,5),I= 248, 266)/
     &  86,0.001,  0, 73, 59,  0,  0,  0,
     &  87,0.880,  0, 78, 38,  0,  0,  0,
     &  87,0.060,  0, 86, 21,  0,  0,  0,
     &  87,0.060,  0, 79, 38,  0,  0,  0,
     &  88,0.995,  0, 78, 21,  0,  0,  0,
     &  88,0.001,  0, 78, 59,  0,  0,  0,
     &  88,0.004,  0, 79, 59,  0,  0,  0,
     &  89,0.667,  0, 83, 38,  0,  0,  0,
     &  89,0.333,  0, 88, 21,  0,  0,  0,
     &  90,0.675,  0, 78, 34,  0,  0,  0,
     &  90,0.233,  0, 88, 30,  0,  0,  0,
     &  90,0.086,  0, 83, 21,  0,  0,  0,
     &  90,0.006,101,121,128, 88,  0,  0,
     &  92,0.663,  0, 91, 21,  0,  0,  0,
     &  92,0.331,  0, 93, 30,  0,  0,  0,
     &  92,0.006,  0, 91, 59,  0,  0,  0,
     &  93,1.000,101,127,122, 91,  0,  0,
     &  94,0.663,  0, 93, 21,  0,  0,  0,
     &  94,0.331,  0, 91, 38,  0,  0,  0/
      DATA (IDK(I),BRFRAC(I),NME(I),(IDKPRD(J,I),J=1,5),I= 267, 285)/
     &  94,0.006,  0, 93, 59,  0,  0,  0,
     &  95,1.000,  0, 93, 38,  0,  0,  0,
     &  96,0.638,  0, 91, 38,  0,  0,  0,
     &  96,0.358,  0, 93, 21,  0,  0,  0,
     &  96,0.002,  0, 93, 59,  0,  0,  0,
     &  96,0.001,  0, 91, 38, 59,  0,  0,
     &  96,0.001,101,127,122, 91,  0,  0,
     &  97,0.995,  0, 96, 59,  0,  0,  0,
     &  97,0.005,  0, 96,127,121,  0,  0,
     &  98,0.880,  0, 96, 21,  0,  0,  0,
     &  98,0.060,  0,104, 38,  0,  0,  0,
     &  98,0.060,  0, 99, 30,  0,  0,  0,
     &  99,0.998,  0, 93, 38,  0,  0,  0,
     &  99,0.001,  0, 93, 38, 59,  0,  0,
     &  99,0.001,101,127,122, 93,  0,  0,
     & 100,0.880,  0, 96, 38,  0,  0,  0,
     & 100,0.060,  0, 97, 38,  0,  0,  0,
     & 100,0.060,  0, 99, 21,  0,  0,  0,
     & 101,0.999,  0, 96, 38,  0,  0,  0/
      DATA (IDK(I),BRFRAC(I),NME(I),(IDKPRD(J,I),J=1,5),I= 286, 304)/
     & 101,0.001,101,127,122, 96,  0,  0,
     & 102,0.667,  0,106, 38,  0,  0,  0,
     & 102,0.333,  0,101, 21,  0,  0,  0,
     & 103,1.000,  0, 91, 30,  0,  0,  0,
     & 104,0.516,  0, 91, 21,  0,  0,  0,
     & 104,0.483,  0, 93, 30,  0,  0,  0,
     & 104,0.001,  0, 91, 59,  0,  0,  0,
     & 105,0.880,  0, 96, 30,  0,  0,  0,
     & 105,0.060,  0,104, 21,  0,  0,  0,
     & 105,0.060,  0, 97, 30,  0,  0,  0,
     & 106,0.995,  0, 96, 21,  0,  0,  0,
     & 106,0.001,  0, 96, 59,  0,  0,  0,
     & 106,0.004,  0, 97, 59,  0,  0,  0,
     & 107,0.667,  0,101, 30,  0,  0,  0,
     & 107,0.333,  0,106, 21,  0,  0,  0,
     & 108,0.675,  0, 96, 46,  0,  0,  0,
     & 108,0.233,  0,106, 38,  0,  0,  0,
     & 108,0.086,  0,101, 21,  0,  0,  0,
     & 108,0.006,101,127,122,106,  0,  0/
      DATA (IDK(I),BRFRAC(I),NME(I),(IDKPRD(J,I),J=1,5),I= 305, 323)/
     & 123,0.986,100,121,128,124,  0,  0,
     & 123,0.014,  0,121,128,124, 59,  0,
     & 125,0.178,100,121,128,126,  0,  0,
     & 125,0.171,100,123,130,126,  0,  0,
     & 125,0.002,  0,123,130, 59,126,  0,
     & 125,0.111,  0, 30,126,  0,  0,  0,
     & 125,0.253,  0, 31,126,  0,  0,  0,
     & 125,0.181,  0, 32,126,  0,  0,  0,
     & 125,0.002,  0, 30, 22, 21,126,  0,
     & 125,0.018,  0, 30, 24,126,  0,  0,
     & 125,0.004,  0, 30, 24, 21,126,  0,
     & 125,0.015,  0, 31, 23,126,  0,  0,
     & 125,0.001,  0, 31, 24, 21,126,  0,
     & 125,0.024,  0, 32, 21,126,  0,  0,
     & 125,0.002,  0, 32, 38, 30,126,  0,
     & 125,0.007,  0, 34,126,  0,  0,  0,
     & 125,0.014,  0, 35,126,  0,  0,  0,
     & 125,0.003,  0, 35, 21,126,  0,  0,
     & 125,0.001,  0, 34, 38, 30,126,  0/
      DATA (IDK(I),BRFRAC(I),NME(I),(IDKPRD(J,I),J=1,5),I= 324, 342)/
     & 125,0.004,  0, 30, 43,126,  0,  0,
     & 125,0.003,  0, 34, 50,126,  0,  0,
     & 125,0.003,  0, 34, 51,126,  0,  0,
     & 125,0.003,  0, 30, 50, 42,126,  0,
     & 129,0.986,100,127,122,130,  0,  0,
     & 129,0.014,  0,127,122,130, 59,  0,
     & 131,0.178,100,127,122,132,  0,  0,
     & 131,0.171,100,129,124,132,  0,  0,
     & 131,0.002,  0,129,124, 59,132,  0,
     & 131,0.111,  0, 38,132,  0,  0,  0,
     & 131,0.253,  0, 39,132,  0,  0,  0,
     & 131,0.181,  0, 40,132,  0,  0,  0,
     & 131,0.002,  0, 38, 22, 21,132,  0,
     & 131,0.018,  0, 38, 24,132,  0,  0,
     & 131,0.004,  0, 38, 24, 21,132,  0,
     & 131,0.015,  0, 39, 23,132,  0,  0,
     & 131,0.001,  0, 39, 24, 21,132,  0,
     & 131,0.024,  0, 40, 21,132,  0,  0,
     & 131,0.002,  0, 40, 38, 30,132,  0/
      DATA (IDK(I),BRFRAC(I),NME(I),(IDKPRD(J,I),J=1,5),I= 343, 361)/
     & 131,0.007,  0, 46,132,  0,  0,  0,
     & 131,0.014,  0, 47,132,  0,  0,  0,
     & 131,0.003,  0, 47, 21,132,  0,  0,
     & 131,0.001,  0, 46, 38, 30,132,  0,
     & 131,0.004,  0, 38, 51,132,  0,  0,
     & 131,0.003,  0, 46, 42,132,  0,  0,
     & 131,0.003,  0, 46, 43,132,  0,  0,
     & 131,0.003,  0, 38, 50, 42,132,  0,
     & 136,0.067,101,122,127, 42,  0,  0,
     & 136,0.067,101,124,129, 42,  0,  0,
     & 136,0.048,101,122,127, 43,  0,  0,
     & 136,0.048,101,124,129, 43,  0,  0,
     & 136,0.003,  0, 34, 38,122,127,  0,
     & 136,0.003,  0, 34, 38,124,129,  0,
     & 136,0.006,101,122,127, 21,  0,  0,
     & 136,0.006,101,124,129, 21,  0,  0,
     & 136,0.002,101,122,127, 23,  0,  0,
     & 136,0.002,101,124,129, 23,  0,  0,
     & 136,0.055,  0, 34, 38, 38,  0,  0/
      DATA (IDK(I),BRFRAC(I),NME(I),(IDKPRD(J,I),J=1,5),I= 362, 380)/
     & 136,0.031,  0, 34, 39, 38,  0,  0,
     & 136,0.042,  0, 34, 38, 38, 21, 21,
     & 136,0.002,  0, 34, 38, 38, 38, 31,
     & 136,0.021,  0, 35, 38, 38,  0,  0,
     & 136,0.027,  0, 42, 38,  0,  0,  0,
     & 136,0.066,  0, 42, 39,  0,  0,  0,
     & 136,0.081,  0, 42, 40,  0,  0,  0,
     & 136,0.024,  0, 42, 38, 21,  0,  0,
     & 136,0.004,  0, 42, 38, 23,  0,  0,
     & 136,0.069,  0, 42, 38, 38, 30, 21,
     & 136,0.001,  0, 42, 38, 38, 30, 23,
     & 136,0.022,  0, 43, 38,  0,  0,  0,
     & 136,0.021,  0, 43, 39,  0,  0,  0,
     & 136,0.042,  0, 43, 38, 21,  0,  0,
     & 136,0.008,  0, 43, 38, 23,  0,  0,
     & 136,0.010,  0, 43, 38, 38, 30,  0,
     & 136,0.050,  0,311, 38,  0,  0,  0,
     & 136,0.034,  0,329, 38,  0,  0,  0,
     & 136,0.010,  0,369, 38,  0,  0,  0/
      DATA (IDK(I),BRFRAC(I),NME(I),(IDKPRD(J,I),J=1,5),I= 381, 399)/
     & 136,0.031,  0, 46, 42, 42,  0,  0,
     & 136,0.003,  0, 38, 21,  0,  0,  0,
     & 136,0.001,  0, 38, 23,  0,  0,  0,
     & 136,0.002,  0, 38, 38, 30,  0,  0,
     & 136,0.008,  0, 38, 22,  0,  0,  0,
     & 136,0.001,  0, 38, 38, 38, 30, 30,
     & 136,0.003,  0, 38, 38, 38, 30, 31,
     & 136,0.008,  0, 46, 42,  0,  0,  0,
     & 136,0.005,  0, 46, 43,  0,  0,  0,
     & 136,0.026,  0, 47, 43,  0,  0,  0,
     & 136,0.005,  0, 46, 34, 38,  0,  0,
     & 136,0.007,  0, 38, 56,  0,  0,  0,
     & 136,0.023,  0, 38, 56, 21,  0,  0,
     & 136,0.005,  0, 46, 46, 34,  0,  0,
     & 137,0.683,  0,140, 38,  0,  0,  0,
     & 137,0.306,  0,136, 21,  0,  0,  0,
     & 137,0.011,  0,136, 59,  0,  0,  0,
     & 138,0.667,  0,141, 38,  0,  0,  0,
     & 138,0.333,  0,137, 21,  0,  0,  0/
      DATA (IDK(I),BRFRAC(I),NME(I),(IDKPRD(J,I),J=1,5),I= 400, 418)/
     & 139,0.220,  0,140, 38,  0,  0,  0,
     & 139,0.110,  0,136, 21,  0,  0,  0,
     & 139,0.380,  0,141, 38,  0,  0,  0,
     & 139,0.190,  0,137, 21,  0,  0,  0,
     & 139,0.004,  0,136, 22,  0,  0,  0,
     & 139,0.064,  0,141, 38, 21,  0,  0,
     & 139,0.032,  0,137, 38, 30,  0,  0,
     & 140,0.037,101,122,127, 34,  0,  0,
     & 140,0.037,101,124,129, 34,  0,  0,
     & 140,0.016,101,122,127, 35,  0,  0,
     & 140,0.016,101,124,129, 35,  0,  0,
     & 140,0.013,  0, 34, 21,122,127,  0,
     & 140,0.013,  0, 34, 21,124,129,  0,
     & 140,0.012,  0, 42, 30,122,127,  0,
     & 140,0.012,  0, 42, 30,124,129,  0,
     & 140,0.003,101,122,127, 30,  0,  0,
     & 140,0.003,101,124,129, 30,  0,  0,
     & 140,0.039,  0, 34, 38,  0,  0,  0,
     & 140,0.091,  0, 34, 39,  0,  0,  0/
      DATA (IDK(I),BRFRAC(I),NME(I),(IDKPRD(J,I),J=1,5),I= 419, 437)/
     & 140,0.067,  0, 34, 40,  0,  0,  0,
     & 140,0.004,  0, 34, 38, 21,  0,  0,
     & 140,0.100,  0, 34, 38, 21, 21,  0,
     & 140,0.058,  0, 34, 38, 23,  0,  0,
     & 140,0.020,  0, 34, 38, 24,  0,  0,
     & 140,0.006,  0, 34, 38, 25,  0,  0,
     & 140,0.043,  0, 35, 38,  0,  0,  0,
     & 140,0.035,  0, 35, 39,  0,  0,  0,
     & 140,0.007,  0,312, 38,  0,  0,  0,
     & 140,0.007,  0,330, 38,  0,  0,  0,
     & 140,0.020,  0, 42, 21,  0,  0,  0,
     & 140,0.006,  0, 42, 22,  0,  0,  0,
     & 140,0.009,  0, 42, 23,  0,  0,  0,
     & 140,0.016,  0, 42, 24,  0,  0,  0,
     & 140,0.014,  0, 42, 25,  0,  0,  0,
     & 140,0.003,  0, 42,293,  0,  0,  0,
     & 140,0.007,  0, 42, 56,  0,  0,  0,
     & 140,0.003,  0, 42, 26,  0,  0,  0,
     & 140,0.004,  0, 42,294,  0,  0,  0/
      DATA (IDK(I),BRFRAC(I),NME(I),(IDKPRD(J,I),J=1,5),I= 438, 456)/
     & 140,0.006,  0, 42, 21, 21,  0,  0,
     & 140,0.042,  0, 42, 38, 30, 21,  0,
     & 140,0.004,  0, 42, 38, 38, 30, 30,
     & 140,0.076,  0, 42, 38, 30, 21, 21,
     & 140,0.026,  0, 43, 21,  0,  0,  0,
     & 140,0.014,  0, 43, 22,  0,  0,  0,
     & 140,0.014,  0, 43, 23,  0,  0,  0,
     & 140,0.011,  0, 43, 24,  0,  0,  0,
     & 140,0.018,  0, 43, 38, 30,  0,  0,
     & 140,0.004,  0, 42, 46, 34,  0,  0,
     & 140,0.004,  0, 42, 46, 34, 21,  0,
     & 140,0.005,  0, 42, 42, 50,  0,  0,
     & 140,0.002,  0, 38, 30,  0,  0,  0,
     & 140,0.001,  0, 21, 21,  0,  0,  0,
     & 140,0.008,  0, 38, 30, 21,  0,  0,
     & 140,0.007,  0, 38, 38, 30, 30,  0,
     & 140,0.015,  0, 38, 38, 30, 30, 21,
     & 140,0.004,  0, 46, 34,  0,  0,  0,
     & 140,0.003,  0, 47, 34,  0,  0,  0/
      DATA (IDK(I),BRFRAC(I),NME(I),(IDKPRD(J,I),J=1,5),I= 457, 475)/
     & 140,0.002,  0, 46, 35,  0,  0,  0,
     & 140,0.001,  0, 50, 42,  0,  0,  0,
     & 140,0.002,  0, 51, 43,  0,  0,  0,
     & 140,0.003,  0, 50, 34, 38,  0,  0,
     & 140,0.003,  0, 42, 46, 30,  0,  0,
     & 140,0.001,  0, 46, 34, 38, 30, 21,
     & 140,0.002,  0, 56, 23,  0,  0,  0,
     & 140,0.001,  0, 56, 38, 30,  0,  0,
     & 141,0.636,  0,140, 21,  0,  0,  0,
     & 141,0.364,  0,140, 59,  0,  0,  0,
     & 142,0.667,  0,137, 30,  0,  0,  0,
     & 142,0.333,  0,141, 21,  0,  0,  0,
     & 143,0.220,  0,136, 30,  0,  0,  0,
     & 143,0.110,  0,140, 21,  0,  0,  0,
     & 143,0.380,  0,137, 30,  0,  0,  0,
     & 143,0.190,  0,141, 21,  0,  0,  0,
     & 143,0.004,  0,140, 22,  0,  0,  0,
     & 143,0.064,  0,137, 30, 21,  0,  0,
     & 143,0.032,  0,141, 38, 30,  0,  0/
      DATA (IDK(I),BRFRAC(I),NME(I),(IDKPRD(J,I),J=1,5),I= 476, 494)/
     & 144,0.009,  0,124,129,  0,  0,  0,
     & 144,0.019,101,122,127, 56,  0,  0,
     & 144,0.019,101,124,129, 56,  0,  0,
     & 144,0.025,101,122,127, 22,  0,  0,
     & 144,0.025,101,124,129, 22,  0,  0,
     & 144,0.009,101,122,127, 25,  0,  0,
     & 144,0.009,101,124,129, 25,  0,  0,
     & 144,0.036,  0, 46, 42,  0,  0,  0,
     & 144,0.034,  0, 46, 43,  0,  0,  0,
     & 144,0.007,  0, 46,329,  0,  0,  0,
     & 144,0.043,  0, 47, 42,  0,  0,  0,
     & 144,0.058,  0, 47, 43,  0,  0,  0,
     & 144,0.011,  0, 46, 34, 38,  0,  0,
     & 144,0.055,  0, 46, 34, 38, 21,  0,
     & 144,0.003,  0, 46, 34, 38, 38, 30,
     & 144,0.014,  0, 46, 42, 38, 30,  0,
     & 144,0.017,  0, 50, 34, 38, 38,  0,
     & 144,0.036,  0, 56, 38,  0,  0,  0,
     & 144,0.067,  0, 56, 39,  0,  0,  0/
      DATA (IDK(I),BRFRAC(I),NME(I),(IDKPRD(J,I),J=1,5),I= 495, 513)/
     & 144,0.023,  0, 56, 38, 21,  0,  0,
     & 144,0.018,  0, 56, 38, 38, 30,  0,
     & 144,0.020,  0, 22, 38,  0,  0,  0,
     & 144,0.001,  0, 23, 38,  0,  0,  0,
     & 144,0.009,  0, 24, 38,  0,  0,  0,
     & 144,0.049,  0, 25, 38,  0,  0,  0,
     & 144,0.011,  0,293, 38,  0,  0,  0,
     & 144,0.015,  0, 22, 38, 21,  0,  0,
     & 144,0.016,  0, 25, 38, 21,  0,  0,
     & 144,0.103,  0, 22, 39,  0,  0,  0,
     & 144,0.120,  0, 25, 39,  0,  0,  0,
     & 144,0.010,  0, 38, 38, 30,  0,  0,
     & 144,0.046,  0, 38, 38, 30, 21,  0,
     & 144,0.003,  0, 38, 38, 38, 30, 30,
     & 144,0.042,  0, 38, 30, 30, 38, 39,
     & 144,0.001,  0, 46, 23,  0,  0,  0,
     & 144,0.005,  0, 46, 38, 30,  0,  0,
     & 144,0.001,  0, 46, 56,  0,  0,  0,
     & 144,0.004,  0, 50, 38,  0,  0,  0/
      DATA (IDK(I),BRFRAC(I),NME(I),(IDKPRD(J,I),J=1,5),I= 514, 532)/
     & 144,0.007,  0, 51, 38,  0,  0,  0,
     & 145,0.900,  0,144, 59,  0,  0,  0,
     & 145,0.100,  0,144, 21,  0,  0,  0,
     & 146,0.500,  0,137, 50,  0,  0,  0,
     & 146,0.500,  0,141, 46,  0,  0,  0,
     & 147,0.440,  0,136, 50,  0,  0,  0,
     & 147,0.440,  0,140, 46,  0,  0,  0,
     & 147,0.055,  0,137, 50,  0,  0,  0,
     & 147,0.055,  0,141, 46,  0,  0,  0,
     & 147,0.010,  0,144, 22,  0,  0,  0,
     & 148,1.000,  0,150, 38,  0,  0,  0,
     & 149,1.000,  0,150, 38,  0,  0,  0,
     & 150,0.028,101,122,127, 78,  0,  0,
     & 150,0.010,101,122,127, 80,  0,  0,
     & 150,0.028,101,124,129, 78,  0,  0,
     & 150,0.010,101,124,129, 80,  0,  0,
     & 150,0.026,  0, 73, 42,  0,  0,  0,
     & 150,0.030,  0, 73, 42, 21,  0,  0,
     & 150,0.029,  0, 73, 42, 38, 30,  0/
      DATA (IDK(I),BRFRAC(I),NME(I),(IDKPRD(J,I),J=1,5),I= 533, 551)/
     & 150,0.014,  0, 73, 42, 22,  0,  0,
     & 150,0.020,  0, 73, 43,  0,  0,  0,
     & 150,0.029,  0, 73, 34, 38,  0,  0,
     & 150,0.039,  0, 73, 34, 38, 21,  0,
     & 150,0.002,  0, 73, 34, 38, 38, 30,
     & 150,0.010,  0, 73, 34, 38, 21, 21,
     & 150,0.014,  0, 73, 35, 38,  0,  0,
     & 150,0.010,  0, 74, 42,  0,  0,  0,
     & 150,0.020,  0, 74, 43,  0,  0,  0,
     & 150,0.010,  0, 74, 43, 21,  0,  0,
     & 150,0.007,  0, 85, 34,  0,  0,  0,
     & 150,0.014,  0, 85, 35,  0,  0,  0,
     & 150,0.004,  0, 73,293,  0,  0,  0,
     & 150,0.003,  0, 73, 38, 30,  0,  0,
     & 150,0.003,  0, 73, 38, 30, 38, 30,
     & 150,0.001,  0, 73, 56,  0,  0,  0,
     & 150,0.002,  0, 73, 46, 34,  0,  0,
     & 150,0.010,  0, 78, 38,  0,  0,  0,
     & 150,0.020,  0, 78, 39,  0,  0,  0/
      DATA (IDK(I),BRFRAC(I),NME(I),(IDKPRD(J,I),J=1,5),I= 552, 570)/
     & 150,0.030,  0, 78, 38, 21,  0,  0,
     & 150,0.010,  0, 78, 38, 22,  0,  0,
     & 150,0.020,  0, 78, 38, 24,  0,  0,
     & 150,0.035,  0, 78, 38, 38, 30,  0,
     & 150,0.020,  0, 78, 38, 21, 21,  0,
     & 150,0.010,  0, 78, 38, 38, 30, 21,
     & 150,0.010,  0, 78, 38, 21, 21, 21,
     & 150,0.007,  0, 78, 46, 42,  0,  0,
     & 150,0.011,  0, 79, 38,  0,  0,  0,
     & 150,0.022,  0, 79, 38, 21,  0,  0,
     & 150,0.013,  0, 79, 38, 38, 30,  0,
     & 150,0.010,  0, 79, 38, 21, 21,  0,
     & 150,0.007,  0, 79, 38, 38, 30, 21,
     & 150,0.005,  0, 79, 38, 21, 21, 21,
     & 150,0.005,  0, 80, 38,  0,  0,  0,
     & 150,0.015,  0, 80, 39,  0,  0,  0,
     & 150,0.011,  0, 86, 21,  0,  0,  0,
     & 150,0.007,  0, 86, 22,  0,  0,  0,
     & 150,0.010,  0, 86, 23,  0,  0,  0/
      DATA (IDK(I),BRFRAC(I),NME(I),(IDKPRD(J,I),J=1,5),I= 571, 589)/
     & 150,0.031,  0, 86, 24,  0,  0,  0,
     & 150,0.010,  0, 86, 25,  0,  0,  0,
     & 150,0.004,  0, 86, 56,  0,  0,  0,
     & 150,0.026,  0, 86, 38, 30,  0,  0,
     & 150,0.005,  0, 86, 38, 38, 30, 30,
     & 150,0.005,  0, 86, 38, 30, 21, 21,
     & 150,0.005,  0, 87, 21,  0,  0,  0,
     & 150,0.006,  0, 87, 23,  0,  0,  0,
     & 150,0.004,  0, 86, 46, 34,  0,  0,
     & 150,0.002,  0, 86, 46, 30,  0,  0,
     & 150,0.001,  0, 86, 46, 30, 21,  0,
     & 150,0.016,  0, 81, 38, 38,  0,  0,
     & 150,0.003,  0, 88, 46,  0,  0,  0,
     & 150,0.002,  0, 89, 46,  0,  0,  0,
     & 150,0.003,  0, 83, 46, 38,  0,  0,
     & 150,0.040,  0, 75, 46, 21,  0,  0,
     & 150,0.040,  0, 75, 46, 38, 30,  0,
     & 150,0.020,  0, 75, 46, 21, 21,  0,
     & 150,0.010,  0, 75, 46, 38, 30, 21/
      DATA (IDK(I),BRFRAC(I),NME(I),(IDKPRD(J,I),J=1,5),I= 590, 608)/
     & 150,0.010,  0, 75, 46, 21, 21, 21,
     & 150,0.020,  0, 75, 47, 21,  0,  0,
     & 150,0.040,  0, 75, 42, 38,  0,  0,
     & 150,0.020,  0, 75, 42, 39,  0,  0,
     & 150,0.010,  0, 75, 42, 38, 38, 30,
     & 150,0.010,  0, 75, 42, 38, 21, 21,
     & 150,0.006,  0, 75, 43, 38,  0,  0,
     & 151,1.000,  0,150, 21,  0,  0,  0,
     & 152,1.000,  0,150, 21,  0,  0,  0,
     & 153,1.000,  0,150, 30,  0,  0,  0,
     & 154,1.000,  0,150, 30,  0,  0,  0,
     & 155,0.045,101,122,127, 88,  0,  0,
     & 155,0.005,101,122,127, 89,  0,  0,
     & 155,0.045,101,124,129, 88,  0,  0,
     & 155,0.005,101,124,129, 89,  0,  0,
     & 155,0.021,  0, 86, 42,  0,  0,  0,
     & 155,0.032,  0, 87, 42,  0,  0,  0,
     & 155,0.032,  0, 79, 38, 42,  0,  0,
     & 155,0.045,  0, 86, 43,  0,  0,  0/
      DATA (IDK(I),BRFRAC(I),NME(I),(IDKPRD(J,I),J=1,5),I= 609, 627)/
     & 155,0.065,  0, 87, 43,  0,  0,  0,
     & 155,0.065,  0, 79, 38, 43,  0,  0,
     & 155,0.055,  0, 88, 38,  0,  0,  0,
     & 155,0.160,  0, 88, 39,  0,  0,  0,
     & 155,0.105,  0, 89, 38,  0,  0,  0,
     & 155,0.320,  0, 89, 39,  0,  0,  0,
     & 156,1.000,  0,155, 59,  0,  0,  0,
     & 157,0.667,  0,158, 38,  0,  0,  0,
     & 157,0.333,  0,155, 21,  0,  0,  0,
     & 158,0.045,101,122,127, 83,  0,  0,
     & 158,0.045,101,124,129, 83,  0,  0,
     & 158,0.005,101,122,127, 84,  0,  0,
     & 158,0.005,101,124,129, 84,  0,  0,
     & 158,0.020,  0, 79, 42,  0,  0,  0,
     & 158,0.020,  0, 79, 21, 42,  0,  0,
     & 158,0.020,  0, 80, 42,  0,  0,  0,
     & 158,0.060,  0, 79, 43,  0,  0,  0,
     & 158,0.060,  0, 79, 21, 43,  0,  0,
     & 158,0.060,  0, 80, 43,  0,  0,  0/
      DATA (IDK(I),BRFRAC(I),NME(I),(IDKPRD(J,I),J=1,5),I= 628, 646)/
     & 158,0.020,  0, 86, 34,  0,  0,  0,
     & 158,0.060,  0, 86, 35,  0,  0,  0,
     & 158,0.040,  0, 87, 34,  0,  0,  0,
     & 158,0.120,  0, 87, 35,  0,  0,  0,
     & 158,0.020,  0, 83, 38,  0,  0,  0,
     & 158,0.060,  0, 83, 39,  0,  0,  0,
     & 158,0.040,  0, 84, 38,  0,  0,  0,
     & 158,0.120,  0, 84, 39,  0,  0,  0,
     & 158,0.010,  0, 88, 21,  0,  0,  0,
     & 158,0.030,  0, 88, 23,  0,  0,  0,
     & 158,0.020,  0, 89, 21,  0,  0,  0,
     & 158,0.060,  0, 89, 23,  0,  0,  0,
     & 158,0.030,  0, 88, 56,  0,  0,  0,
     & 158,0.030,  0, 90, 46,  0,  0,  0,
     & 159,1.000,  0,158, 59,  0,  0,  0,
     & 160,0.670,  0,155, 30,  0,  0,  0,
     & 160,0.330,  0,158, 21,  0,  0,  0,
     & 161,0.050,101,122,127, 90,  0,  0,
     & 161,0.050,101,124,129, 90,  0,  0/
      DATA (IDK(I),BRFRAC(I),NME(I),(IDKPRD(J,I),J=1,5),I= 647, 665)/
     & 161,0.075,  0, 88, 42,  0,  0,  0,
     & 161,0.225,  0, 88, 43,  0,  0,  0,
     & 161,0.150,  0, 89, 42,  0,  0,  0,
     & 161,0.450,  0, 89, 43,  0,  0,  0,
     & 162,1.000,  0,161, 59,  0,  0,  0,
     & 163,0.028,  0, 25, 38, 30,  0,  0,
     & 163,0.014,  0, 25, 21, 21,  0,  0,
     & 163,0.018,  0, 39, 31,  0,  0,  0,
     & 163,0.009,  0, 23, 23,  0,  0,  0,
     & 163,0.010,  0, 51, 34, 38,  0,  0,
     & 163,0.010,  0, 43, 47, 30,  0,  0,
     & 163,0.004,  0, 51, 43,  0,  0,  0,
     & 163,0.004,  0, 47, 35,  0,  0,  0,
     & 163,0.007,  0, 56, 56,  0,  0,  0,
     & 163,0.022,  0, 46, 42, 30,  0,  0,
     & 163,0.011,  0, 46, 34, 21,  0,  0,
     & 163,0.011,  0, 50, 42, 21,  0,  0,
     & 163,0.022,  0, 50, 34, 38,  0,  0,
     & 163,0.032,  0, 22, 38, 30,  0,  0/
      DATA (IDK(I),BRFRAC(I),NME(I),(IDKPRD(J,I),J=1,5),I= 666, 684)/
     & 163,0.016,  0, 22, 21, 21,  0,  0,
     & 163,0.020,  0, 38, 30, 46, 34,  0,
     & 163,0.012,  0, 38, 30, 38, 30,  0,
     & 163,0.001,  0, 73, 91,  0,  0,  0,
     & 163,0.001,  0, 59, 59,  0,  0,  0,
     & 163,0.748,  0, 13, 13,  0,  0,  0,
     & 164,0.060,  0,121,127,  0,  0,  0,
     & 164,0.060,  0,123,129,  0,  0,  0,
     & 164,0.004,  0, 39, 30,  0,  0,  0,
     & 164,0.004,  0, 23, 21,  0,  0,  0,
     & 164,0.004,  0, 31, 38,  0,  0,  0,
     & 164,0.003,  0, 41, 31,  0,  0,  0,
     & 164,0.003,  0, 29, 23,  0,  0,  0,
     & 164,0.003,  0, 33, 39,  0,  0,  0,
     & 164,0.009,  0, 24, 38, 38, 30, 30,
     & 164,0.007,  0, 24, 38, 30,  0,  0,
     & 164,0.003,  0, 51, 45,  0,  0,  0,
     & 164,0.003,  0, 43, 53,  0,  0,  0,
     & 164,0.003,  0, 24, 51, 42,  0,  0/
      DATA (IDK(I),BRFRAC(I),NME(I),(IDKPRD(J,I),J=1,5),I= 685, 703)/
     & 164,0.003,  0, 24, 43, 50,  0,  0,
     & 164,0.004,  0, 24, 26,  0,  0,  0,
     & 164,0.003,  0, 46, 35,  0,  0,  0,
     & 164,0.003,  0, 34, 47,  0,  0,  0,
     & 164,0.002,  0, 50, 43,  0,  0,  0,
     & 164,0.002,  0, 42, 51,  0,  0,  0,
     & 164,0.003,  0, 24, 21, 21,  0,  0,
     & 164,0.002,  0,286, 30,  0,  0,  0,
     & 164,0.002,  0,287, 38,  0,  0,  0,
     & 164,0.003,  0, 24, 46, 42, 30,  0,
     & 164,0.003,  0, 24, 34, 50, 38,  0,
     & 164,0.002,  0,285, 21,  0,  0,  0,
     & 164,0.001,  0, 56, 51, 42,  0,  0,
     & 164,0.001,  0, 56, 43, 50,  0,  0,
     & 164,0.001,  0, 24, 50, 42,  0,  0,
     & 164,0.001,  0, 24, 46, 34,  0,  0,
     & 164,0.002,  0, 56, 38, 30, 38, 30,
     & 164,0.002,  0, 85, 91, 30,  0,  0,
     & 164,0.002,  0,103, 73, 38,  0,  0/
      DATA (IDK(I),BRFRAC(I),NME(I),(IDKPRD(J,I),J=1,5),I= 704, 722)/
     & 164,0.002,  0, 24, 22,  0,  0,  0,
     & 164,0.001,  0, 56, 50, 42,  0,  0,
     & 164,0.001,  0, 56, 46, 34,  0,  0,
     & 164,0.001,  0, 73, 91, 24,  0,  0,
     & 164,0.001,  0, 85,103,  0,  0,  0,
     & 164,0.001,  0, 82,100,  0,  0,  0,
     & 164,0.001,  0, 87,105,  0,  0,  0,
     & 164,0.001,  0, 73, 91, 25,  0,  0,
     & 164,0.001,  0, 56, 58,  0,  0,  0,
     & 164,0.001,  0, 56, 38, 30,  0,  0,
     & 164,0.001,  0, 56, 46, 42, 30,  0,
     & 164,0.001,  0, 56, 34, 50, 38,  0,
     & 164,0.001,  0, 56, 22,  0,  0,  0,
     & 164,0.001,  0, 84,102,  0,  0,  0,
     & 164,0.001,  0, 73, 34, 98,  0,  0,
     & 164,0.001,  0, 91, 46, 80,  0,  0,
     & 164,0.034,  0, 38, 38, 30, 30, 21,
     & 164,0.029,  0, 23, 23, 23, 21,  0,
     & 164,0.015,  0, 38, 30, 21,  0,  0/
      DATA (IDK(I),BRFRAC(I),NME(I),(IDKPRD(J,I),J=1,5),I= 723, 741)/
     & 164,0.012,  0, 38, 30, 21, 34, 46,
     & 164,0.009,  0, 23, 23, 23, 24,  0,
     & 164,0.007,  0, 38, 30, 34, 46,  0,
     & 164,0.002,  0, 46, 42, 30,  0,  0,
     & 164,0.001,  0, 46, 34, 21,  0,  0,
     & 164,0.001,  0, 50, 42, 21,  0,  0,
     & 164,0.002,  0, 50, 34, 38,  0,  0,
     & 164,0.006,  0, 73, 91, 38, 30,  0,
     & 164,0.004,  0, 38, 30, 38, 30,  0,
     & 164,0.004,  0, 38, 30, 38, 30, 23,
     & 164,0.004,  0, 75, 93, 38, 30,  0,
     & 164,0.001,  0, 86,104,  0,  0,  0,
     & 164,0.001,  0, 79, 97,  0,  0,  0,
     & 164,0.001,  0, 81, 99,  0,  0,  0,
     & 164,0.003,  0, 23, 23, 34, 46,  0,
     & 164,0.002,  0, 73, 91, 38, 30, 21,
     & 164,0.002,  0, 73, 91,  0,  0,  0,
     & 164,0.002,  0, 73, 91, 22,  0,  0,
     & 164,0.002,  0, 73, 93, 30,  0,  0/
      DATA (IDK(I),BRFRAC(I),NME(I),(IDKPRD(J,I),J=1,5),I= 742, 760)/
     & 164,0.002,  0, 75, 93,  0,  0,  0,
     & 164,0.001,  0, 83,102,  0,  0,  0,
     & 164,0.001,  0, 88,106,  0,  0,  0,
     & 164,0.001,  0, 78, 96,  0,  0,  0,
     & 164,0.001,  0, 73, 91, 21,  0,  0,
     & 164,0.001,  0, 78,104, 38,  0,  0,
     & 164,0.001,  0, 96, 86, 30,  0,  0,
     & 164,0.001,  0, 73, 34, 96,  0,  0,
     & 164,0.001,  0, 91, 46, 78,  0,  0,
     & 164,0.001,  0, 46, 34, 46, 34,  0,
     & 164,0.013,  0, 59,163,  0,  0,  0,
     & 164,0.008,  0, 59, 38, 30, 21, 21,
     & 164,0.004,  0, 59, 22, 38, 30,  0,
     & 164,0.002,  0, 59, 22, 21, 21,  0,
     & 164,0.003,  0, 59, 39, 31,  0,  0,
     & 164,0.002,  0, 59, 23, 23,  0,  0,
     & 164,0.004,  0, 59, 25,  0,  0,  0,
     & 164,0.003,  0, 59, 38, 30, 38, 30,
     & 164,0.002,  0, 59, 24, 24,  0,  0/
      DATA (IDK(I),BRFRAC(I),NME(I),(IDKPRD(J,I),J=1,5),I= 761, 779)/
     & 164,0.001,  0, 59, 26,  0,  0,  0,
     & 164,0.001,  0, 59, 22,  0,  0,  0,
     & 164,0.001,  0, 59, 28,  0,  0,  0,
     & 164,0.001,  0, 59, 58,  0,  0,  0,
     & 164,0.020,  0,  1,  7,  0,  0,  0,
     & 164,0.080,  0,  2,  8,  0,  0,  0,
     & 164,0.020,  0,  3,  9,  0,  0,  0,
     & 164,0.364,130, 13, 13, 13,  0,  0,
     & 164,0.091,130, 13, 13, 59,  0,  0,
     & 165,0.037,  0, 38, 30, 38, 30,  0,
     & 165,0.030,  0, 38, 30, 46, 34,  0,
     & 165,0.016,  0, 23, 38, 30,  0,  0,
     & 165,0.015,  0, 23, 38, 30, 38, 30,
     & 165,0.004,  0, 46, 43, 30,  0,  0,
     & 165,0.002,  0, 46, 35, 21,  0,  0,
     & 165,0.002,  0, 51, 43, 21,  0,  0,
     & 165,0.004,  0, 51, 35, 38,  0,  0,
     & 165,0.008,  0, 38, 30,  0,  0,  0,
     & 165,0.007,  0, 46, 34,  0,  0,  0/
      DATA (IDK(I),BRFRAC(I),NME(I),(IDKPRD(J,I),J=1,5),I= 780, 798)/
     & 165,0.005,  0, 38, 30, 73, 91,  0,
     & 165,0.003,  0, 21, 21,  0,  0,  0,
     & 165,0.003,  0, 22, 22,  0,  0,  0,
     & 165,0.007,  0, 59,164,  0,  0,  0,
     & 165,0.857,  0, 13, 13,  0,  0,  0,
     & 166,0.008,  0,121,127,  0,  0,  0,
     & 166,0.008,  0,123,129,  0,  0,  0,
     & 166,0.001,  0,125,131,  0,  0,  0,
     & 166,0.338,  0,164, 38, 30,  0,  0,
     & 166,0.169,  0,164, 21, 21,  0,  0,
     & 166,0.027,  0,164, 22,  0,  0,  0,
     & 166,0.001,  0,164, 21,  0,  0,  0,
     & 166,0.004,  0, 23, 23, 23, 21,  0,
     & 166,0.003,  0, 23, 23, 21,  0,  0,
     & 166,0.002,  0, 38, 30, 46, 34,  0,
     & 166,0.001,  0, 38, 30, 73, 91,  0,
     & 166,0.093,  0, 59,165,  0,  0,  0,
     & 166,0.087,  0, 59,302,  0,  0,  0,
     & 166,0.078,  0, 59,303,  0,  0,  0/
      DATA (IDK(I),BRFRAC(I),NME(I),(IDKPRD(J,I),J=1,5),I= 799, 817)/
     & 166,0.003,  0, 59,163,  0,  0,  0,
     & 166,0.003,  0,  1,  7,  0,  0,  0,
     & 166,0.012,  0,  2,  8,  0,  0,  0,
     & 166,0.003,  0,  3,  9,  0,  0,  0,
     & 166,0.127,130, 13, 13, 13,  0,  0,
     & 166,0.032,130, 13, 13, 59,  0,  0,
     & 167,0.500,  0,136,171,  0,  0,  0,
     & 167,0.500,  0,140,175,  0,  0,  0,
     & 171,0.067,101,128,121, 50,  0,  0,
     & 171,0.067,101,130,123, 50,  0,  0,
     & 171,0.048,101,128,121, 51,  0,  0,
     & 171,0.048,101,130,123, 51,  0,  0,
     & 171,0.003,  0,128,121, 46, 30,  0,
     & 171,0.003,  0,130,123, 46, 30,  0,
     & 171,0.006,101,128,121, 21,  0,  0,
     & 171,0.006,101,130,123, 21,  0,  0,
     & 171,0.002,101,128,121, 23,  0,  0,
     & 171,0.002,101,130,123, 23,  0,  0,
     & 171,0.055,  0, 46, 30, 30,  0,  0/
      DATA (IDK(I),BRFRAC(I),NME(I),(IDKPRD(J,I),J=1,5),I= 818, 836)/
     & 171,0.031,  0, 46, 31, 30,  0,  0,
     & 171,0.042,  0, 46, 30, 30, 21, 21,
     & 171,0.002,  0, 46, 30, 30, 30, 39,
     & 171,0.021,  0, 47, 30, 30,  0,  0,
     & 171,0.027,  0, 50, 30,  0,  0,  0,
     & 171,0.066,  0, 50, 31,  0,  0,  0,
     & 171,0.081,  0, 50, 32,  0,  0,  0,
     & 171,0.024,  0, 50, 30, 21,  0,  0,
     & 171,0.004,  0, 50, 30, 23,  0,  0,
     & 171,0.069,  0, 50, 30, 30, 38, 21,
     & 171,0.001,  0, 50, 30, 30, 38, 23,
     & 171,0.022,  0, 51, 30,  0,  0,  0,
     & 171,0.021,  0, 51, 31,  0,  0,  0,
     & 171,0.042,  0, 51, 30, 21,  0,  0,
     & 171,0.008,  0, 51, 30, 23,  0,  0,
     & 171,0.010,  0, 51, 30, 30, 38,  0,
     & 171,0.050,  0,309, 30,  0,  0,  0,
     & 171,0.034,  0,328, 30,  0,  0,  0,
     & 171,0.010,  0,368, 30,  0,  0,  0/
      DATA (IDK(I),BRFRAC(I),NME(I),(IDKPRD(J,I),J=1,5),I= 837, 855)/
     & 171,0.031,  0, 34, 50, 50,  0,  0,
     & 171,0.003,  0, 30, 21,  0,  0,  0,
     & 171,0.001,  0, 30, 23,  0,  0,  0,
     & 171,0.002,  0, 30, 30, 38,  0,  0,
     & 171,0.008,  0, 30, 22,  0,  0,  0,
     & 171,0.001,  0, 30, 30, 30, 38, 38,
     & 171,0.003,  0, 30, 30, 30, 38, 39,
     & 171,0.008,  0, 34, 50,  0,  0,  0,
     & 171,0.005,  0, 34, 51,  0,  0,  0,
     & 171,0.026,  0, 35, 51,  0,  0,  0,
     & 171,0.005,  0, 34, 46, 30,  0,  0,
     & 171,0.007,  0, 30, 56,  0,  0,  0,
     & 171,0.023,  0, 30, 56, 21,  0,  0,
     & 171,0.005,  0, 34, 34, 46,  0,  0,
     & 172,0.683,  0,175, 30,  0,  0,  0,
     & 172,0.306,  0,171, 21,  0,  0,  0,
     & 172,0.011,  0,171, 59,  0,  0,  0,
     & 173,0.667,  0,176, 30,  0,  0,  0,
     & 173,0.333,  0,172, 21,  0,  0,  0/
      DATA (IDK(I),BRFRAC(I),NME(I),(IDKPRD(J,I),J=1,5),I= 856, 874)/
     & 174,0.220,  0,175, 30,  0,  0,  0,
     & 174,0.110,  0,171, 21,  0,  0,  0,
     & 174,0.380,  0,176, 30,  0,  0,  0,
     & 174,0.190,  0,172, 21,  0,  0,  0,
     & 174,0.004,  0,171, 22,  0,  0,  0,
     & 174,0.064,  0,176, 30, 21,  0,  0,
     & 174,0.032,  0,172, 38, 30,  0,  0,
     & 175,0.037,101,128,121, 46,  0,  0,
     & 175,0.037,101,130,123, 46,  0,  0,
     & 175,0.016,101,128,121, 47,  0,  0,
     & 175,0.016,101,130,123, 47,  0,  0,
     & 175,0.013,  0,128,121, 46, 21,  0,
     & 175,0.013,  0,130,123, 46, 21,  0,
     & 175,0.012,  0,128,121, 50, 38,  0,
     & 175,0.012,  0,130,123, 50, 38,  0,
     & 175,0.003,101,128,121, 38,  0,  0,
     & 175,0.003,101,130,123, 38,  0,  0,
     & 175,0.039,  0, 46, 30,  0,  0,  0,
     & 175,0.091,  0, 46, 31,  0,  0,  0/
      DATA (IDK(I),BRFRAC(I),NME(I),(IDKPRD(J,I),J=1,5),I= 875, 893)/
     & 175,0.067,  0, 46, 32,  0,  0,  0,
     & 175,0.004,  0, 46, 30, 21,  0,  0,
     & 175,0.100,  0, 46, 30, 21, 21,  0,
     & 175,0.058,  0, 46, 30, 23,  0,  0,
     & 175,0.020,  0, 46, 30, 24,  0,  0,
     & 175,0.006,  0, 46, 30, 25,  0,  0,
     & 175,0.043,  0, 47, 30,  0,  0,  0,
     & 175,0.035,  0, 47, 31,  0,  0,  0,
     & 175,0.007,  0,310, 30,  0,  0,  0,
     & 175,0.007,  0,327, 30,  0,  0,  0,
     & 175,0.020,  0, 50, 21,  0,  0,  0,
     & 175,0.006,  0, 50, 22,  0,  0,  0,
     & 175,0.009,  0, 50, 23,  0,  0,  0,
     & 175,0.016,  0, 50, 24,  0,  0,  0,
     & 175,0.014,  0, 50, 25,  0,  0,  0,
     & 175,0.003,  0, 50,293,  0,  0,  0,
     & 175,0.007,  0, 50, 56,  0,  0,  0,
     & 175,0.003,  0, 50, 26,  0,  0,  0,
     & 175,0.004,  0, 50,294,  0,  0,  0/
      DATA (IDK(I),BRFRAC(I),NME(I),(IDKPRD(J,I),J=1,5),I= 894, 912)/
     & 175,0.006,  0, 50, 21, 21,  0,  0,
     & 175,0.042,  0, 50, 30, 38, 21,  0,
     & 175,0.004,  0, 50, 30, 30, 38, 38,
     & 175,0.076,  0, 50, 30, 38, 21, 21,
     & 175,0.026,  0, 51, 21,  0,  0,  0,
     & 175,0.014,  0, 51, 22,  0,  0,  0,
     & 175,0.014,  0, 51, 23,  0,  0,  0,
     & 175,0.011,  0, 51, 24,  0,  0,  0,
     & 175,0.018,  0, 51, 30, 38,  0,  0,
     & 175,0.004,  0, 50, 34, 46,  0,  0,
     & 175,0.004,  0, 50, 34, 46, 21,  0,
     & 175,0.005,  0, 50, 50, 42,  0,  0,
     & 175,0.002,  0, 30, 38,  0,  0,  0,
     & 175,0.001,  0, 21, 21,  0,  0,  0,
     & 175,0.008,  0, 30, 38, 21,  0,  0,
     & 175,0.007,  0, 30, 30, 38, 38,  0,
     & 175,0.015,  0, 30, 30, 38, 38, 21,
     & 175,0.004,  0, 34, 46,  0,  0,  0,
     & 175,0.003,  0, 35, 46,  0,  0,  0/
      DATA (IDK(I),BRFRAC(I),NME(I),(IDKPRD(J,I),J=1,5),I= 913, 931)/
     & 175,0.002,  0, 34, 47,  0,  0,  0,
     & 175,0.001,  0, 42, 50,  0,  0,  0,
     & 175,0.002,  0, 43, 51,  0,  0,  0,
     & 175,0.003,  0, 42, 46, 30,  0,  0,
     & 175,0.003,  0, 50, 34, 38,  0,  0,
     & 175,0.001,  0, 34, 46, 30, 38, 21,
     & 175,0.002,  0, 56, 23,  0,  0,  0,
     & 175,0.001,  0, 56, 30, 38,  0,  0,
     & 176,0.636,  0,175, 21,  0,  0,  0,
     & 176,0.364,  0,175, 59,  0,  0,  0,
     & 177,0.667,  0,172, 38,  0,  0,  0,
     & 177,0.333,  0,176, 21,  0,  0,  0,
     & 178,0.220,  0,171, 38,  0,  0,  0,
     & 178,0.110,  0,175, 21,  0,  0,  0,
     & 178,0.380,  0,172, 38,  0,  0,  0,
     & 178,0.190,  0,176, 21,  0,  0,  0,
     & 178,0.004,  0,175, 22,  0,  0,  0,
     & 178,0.064,  0,172, 38, 21,  0,  0,
     & 178,0.032,  0,176, 38, 30,  0,  0/
      DATA (IDK(I),BRFRAC(I),NME(I),(IDKPRD(J,I),J=1,5),I= 932, 950)/
     & 179,0.009,  0,130,123,  0,  0,  0,
     & 179,0.019,101,128,121, 56,  0,  0,
     & 179,0.019,101,130,123, 56,  0,  0,
     & 179,0.025,101,128,121, 22,  0,  0,
     & 179,0.025,101,130,123, 22,  0,  0,
     & 179,0.009,101,128,121, 25,  0,  0,
     & 179,0.009,101,130,123, 25,  0,  0,
     & 179,0.036,  0, 34, 50,  0,  0,  0,
     & 179,0.034,  0, 34, 51,  0,  0,  0,
     & 179,0.007,  0, 34,328,  0,  0,  0,
     & 179,0.043,  0, 35, 50,  0,  0,  0,
     & 179,0.058,  0, 35, 51,  0,  0,  0,
     & 179,0.011,  0, 34, 46, 30,  0,  0,
     & 179,0.055,  0, 34, 46, 30, 21,  0,
     & 179,0.003,  0, 34, 46, 30, 38, 30,
     & 179,0.014,  0, 34, 50, 38, 30,  0,
     & 179,0.017,  0, 42, 46, 30, 30,  0,
     & 179,0.036,  0, 56, 30,  0,  0,  0,
     & 179,0.067,  0, 56, 31,  0,  0,  0/
      DATA (IDK(I),BRFRAC(I),NME(I),(IDKPRD(J,I),J=1,5),I= 951, 969)/
     & 179,0.023,  0, 56, 30, 21,  0,  0,
     & 179,0.018,  0, 56, 30, 38, 30,  0,
     & 179,0.020,  0, 22, 30,  0,  0,  0,
     & 179,0.001,  0, 23, 30,  0,  0,  0,
     & 179,0.009,  0, 24, 30,  0,  0,  0,
     & 179,0.049,  0, 25, 30,  0,  0,  0,
     & 179,0.011,  0,293, 30,  0,  0,  0,
     & 179,0.015,  0, 22, 30, 21,  0,  0,
     & 179,0.016,  0, 25, 30, 21,  0,  0,
     & 179,0.103,  0, 22, 31,  0,  0,  0,
     & 179,0.120,  0, 25, 31,  0,  0,  0,
     & 179,0.010,  0, 30, 38, 30,  0,  0,
     & 179,0.046,  0, 30, 38, 30, 21,  0,
     & 179,0.003,  0, 30, 38, 38, 30, 30,
     & 179,0.042,  0, 30, 38, 38, 30, 31,
     & 179,0.001,  0, 34, 23,  0,  0,  0,
     & 179,0.005,  0, 34, 38, 30,  0,  0,
     & 179,0.001,  0, 34, 56,  0,  0,  0,
     & 179,0.004,  0, 42, 30,  0,  0,  0/
      DATA (IDK(I),BRFRAC(I),NME(I),(IDKPRD(J,I),J=1,5),I= 970, 988)/
     & 179,0.007,  0, 43, 30,  0,  0,  0,
     & 180,0.900,  0,179, 59,  0,  0,  0,
     & 180,0.100,  0,179, 21,  0,  0,  0,
     & 181,0.500,  0,172, 42,  0,  0,  0,
     & 181,0.500,  0,176, 34,  0,  0,  0,
     & 182,0.440,  0,171, 42,  0,  0,  0,
     & 182,0.440,  0,175, 34,  0,  0,  0,
     & 182,0.055,  0,172, 42,  0,  0,  0,
     & 182,0.055,  0,176, 34,  0,  0,  0,
     & 182,0.010,  0,179, 22,  0,  0,  0,
     & 183,1.000,  0,185, 30,  0,  0,  0,
     & 184,1.000,  0,185, 30,  0,  0,  0,
     & 185,0.028,101,128,121, 96,  0,  0,
     & 185,0.010,101,128,121, 98,  0,  0,
     & 185,0.028,101,130,123, 96,  0,  0,
     & 185,0.010,101,130,123, 98,  0,  0,
     & 185,0.026,  0, 91, 50,  0,  0,  0,
     & 185,0.030,  0, 91, 50, 21,  0,  0,
     & 185,0.029,  0, 91, 50, 38, 30,  0/
      DATA (IDK(I),BRFRAC(I),NME(I),(IDKPRD(J,I),J=1,5),I= 989,1007)/
     & 185,0.014,  0, 91, 50, 22,  0,  0,
     & 185,0.020,  0, 91, 51,  0,  0,  0,
     & 185,0.029,  0, 91, 46, 30,  0,  0,
     & 185,0.039,  0, 91, 46, 30, 21,  0,
     & 185,0.002,  0, 91, 46, 30, 30, 38,
     & 185,0.010,  0, 91, 46, 30, 21, 21,
     & 185,0.014,  0, 91, 47, 30,  0,  0,
     & 185,0.010,  0, 92, 50,  0,  0,  0,
     & 185,0.020,  0, 92, 51,  0,  0,  0,
     & 185,0.010,  0, 92, 51, 21,  0,  0,
     & 185,0.007,  0,103, 46,  0,  0,  0,
     & 185,0.014,  0,103, 47,  0,  0,  0,
     & 185,0.004,  0, 91,293,  0,  0,  0,
     & 185,0.003,  0, 91, 38, 30,  0,  0,
     & 185,0.003,  0, 91, 38, 30, 38, 30,
     & 185,0.001,  0, 91, 56,  0,  0,  0,
     & 185,0.002,  0, 91, 46, 34,  0,  0,
     & 185,0.010,  0, 96, 30,  0,  0,  0,
     & 185,0.020,  0, 96, 31,  0,  0,  0/
      DATA (IDK(I),BRFRAC(I),NME(I),(IDKPRD(J,I),J=1,5),I=1008,1026)/
     & 185,0.030,  0, 96, 30, 21,  0,  0,
     & 185,0.010,  0, 96, 30, 22,  0,  0,
     & 185,0.020,  0, 96, 30, 24,  0,  0,
     & 185,0.035,  0, 96, 30, 30, 38,  0,
     & 185,0.020,  0, 96, 30, 21, 21,  0,
     & 185,0.010,  0, 96, 30, 38, 30, 21,
     & 185,0.010,  0, 96, 30, 21, 21, 21,
     & 185,0.007,  0, 96, 34, 50,  0,  0,
     & 185,0.011,  0, 97, 30,  0,  0,  0,
     & 185,0.022,  0, 97, 30, 21,  0,  0,
     & 185,0.013,  0, 97, 30, 38, 30,  0,
     & 185,0.010,  0, 97, 30, 21, 21,  0,
     & 185,0.007,  0, 97, 30, 38, 30, 21,
     & 185,0.005,  0, 97, 30, 21, 21, 21,
     & 185,0.005,  0, 98, 30,  0,  0,  0,
     & 185,0.015,  0, 98, 31,  0,  0,  0,
     & 185,0.011,  0,104, 21,  0,  0,  0,
     & 185,0.007,  0,104, 22,  0,  0,  0,
     & 185,0.010,  0,104, 23,  0,  0,  0/
      DATA (IDK(I),BRFRAC(I),NME(I),(IDKPRD(J,I),J=1,5),I=1027,1045)/
     & 185,0.031,  0,104, 24,  0,  0,  0,
     & 185,0.010,  0,104, 25,  0,  0,  0,
     & 185,0.004,  0,104, 56,  0,  0,  0,
     & 185,0.026,  0,104, 38, 30,  0,  0,
     & 185,0.005,  0,104, 38, 38, 30, 30,
     & 185,0.005,  0,104, 38, 30, 21, 21,
     & 185,0.005,  0,105, 21,  0,  0,  0,
     & 185,0.006,  0,105, 23,  0,  0,  0,
     & 185,0.004,  0,104, 46, 34,  0,  0,
     & 185,0.002,  0,104, 34, 38,  0,  0,
     & 185,0.001,  0,104, 34, 38, 21,  0,
     & 185,0.016,  0, 99, 30, 30,  0,  0,
     & 185,0.003,  0,106, 34,  0,  0,  0,
     & 185,0.002,  0,107, 34,  0,  0,  0,
     & 185,0.003,  0,101, 34, 30,  0,  0,
     & 185,0.040,  0, 93, 34, 21,  0,  0,
     & 185,0.040,  0, 93, 34, 38, 30,  0,
     & 185,0.020,  0, 93, 34, 21, 21,  0,
     & 185,0.010,  0, 93, 34, 38, 30, 21/
      DATA (IDK(I),BRFRAC(I),NME(I),(IDKPRD(J,I),J=1,5),I=1046,1064)/
     & 185,0.010,  0, 93, 34, 21, 21, 21,
     & 185,0.020,  0, 93, 35, 21,  0,  0,
     & 185,0.040,  0, 93, 50, 30,  0,  0,
     & 185,0.020,  0, 93, 50, 31,  0,  0,
     & 185,0.010,  0, 93, 50, 30, 38, 30,
     & 185,0.010,  0, 93, 50, 30, 21, 21,
     & 185,0.006,  0, 93, 51, 30,  0,  0,
     & 186,1.000,  0,185, 21,  0,  0,  0,
     & 187,1.000,  0,185, 21,  0,  0,  0,
     & 188,1.000,  0,185, 38,  0,  0,  0,
     & 189,1.000,  0,185, 38,  0,  0,  0,
     & 190,0.045,101,128,121,106,  0,  0,
     & 190,0.005,101,128,121,107,  0,  0,
     & 190,0.045,101,130,123,106,  0,  0,
     & 190,0.005,101,130,123,107,  0,  0,
     & 190,0.021,  0,104, 50,  0,  0,  0,
     & 190,0.032,  0,105, 50,  0,  0,  0,
     & 190,0.032,  0, 97, 30, 50,  0,  0,
     & 190,0.045,  0,104, 51,  0,  0,  0/
      DATA (IDK(I),BRFRAC(I),NME(I),(IDKPRD(J,I),J=1,5),I=1065,1083)/
     & 190,0.065,  0,105, 51,  0,  0,  0,
     & 190,0.065,  0, 97, 30, 51,  0,  0,
     & 190,0.055,  0,106, 30,  0,  0,  0,
     & 190,0.160,  0,106, 31,  0,  0,  0,
     & 190,0.105,  0,107, 30,  0,  0,  0,
     & 190,0.320,  0,107, 31,  0,  0,  0,
     & 191,1.000,  0,190, 59,  0,  0,  0,
     & 192,0.667,  0,193, 30,  0,  0,  0,
     & 192,0.333,  0,190, 21,  0,  0,  0,
     & 193,0.045,101,128,121,101,  0,  0,
     & 193,0.045,101,130,123,101,  0,  0,
     & 193,0.005,101,128,121,102,  0,  0,
     & 193,0.005,101,130,123,102,  0,  0,
     & 193,0.020,  0, 97, 50,  0,  0,  0,
     & 193,0.020,  0, 97, 21, 50,  0,  0,
     & 193,0.020,  0, 98, 50,  0,  0,  0,
     & 193,0.060,  0, 97, 51,  0,  0,  0,
     & 193,0.060,  0, 97, 21, 51,  0,  0,
     & 193,0.060,  0, 98, 51,  0,  0,  0/
      DATA (IDK(I),BRFRAC(I),NME(I),(IDKPRD(J,I),J=1,5),I=1084,1102)/
     & 193,0.020,  0,104, 46,  0,  0,  0,
     & 193,0.060,  0,104, 47,  0,  0,  0,
     & 193,0.040,  0,105, 46,  0,  0,  0,
     & 193,0.120,  0,105, 47,  0,  0,  0,
     & 193,0.020,  0,101, 30,  0,  0,  0,
     & 193,0.060,  0,101, 31,  0,  0,  0,
     & 193,0.040,  0,102, 30,  0,  0,  0,
     & 193,0.120,  0,102, 31,  0,  0,  0,
     & 193,0.010,  0,106, 21,  0,  0,  0,
     & 193,0.030,  0,106, 23,  0,  0,  0,
     & 193,0.020,  0,107, 21,  0,  0,  0,
     & 193,0.060,  0,107, 23,  0,  0,  0,
     & 193,0.030,  0,106, 56,  0,  0,  0,
     & 193,0.030,  0,108, 34,  0,  0,  0,
     & 194,1.000,  0,193, 59,  0,  0,  0,
     & 195,0.670,  0,190, 38,  0,  0,  0,
     & 195,0.330,  0,193, 21,  0,  0,  0,
     & 196,0.050,101,128,121,108,  0,  0,
     & 196,0.050,101,130,123,108,  0,  0/
      DATA (IDK(I),BRFRAC(I),NME(I),(IDKPRD(J,I),J=1,5),I=1103,1121)/
     & 196,0.075,  0,106, 50,  0,  0,  0,
     & 196,0.225,  0,106, 51,  0,  0,  0,
     & 196,0.150,  0,107, 50,  0,  0,  0,
     & 196,0.450,  0,107, 51,  0,  0,  0,
     & 197,1.000,  0,196, 59,  0,  0,  0,
     & 209,0.250,100,  1,  8,  4,  0,  0,
     & 209,0.250,100,  3, 10,  4,  0,  0,
     & 209,0.250,100,  5, 12,  4,  0,  0,
     & 209,0.085,100,121,128,  4,  0,  0,
     & 209,0.085,100,123,130,  4,  0,  0,
     & 209,0.080,100,125,132,  4,  0,  0,
     & 210,0.250,100,  2,  7,209,  0,  0,
     & 210,0.250,100,  4,  9,209,  0,  0,
     & 210,0.250,100,  6, 11,209,  0,  0,
     & 210,0.085,100,122,127,209,  0,  0,
     & 210,0.085,100,124,129,209,  0,  0,
     & 210,0.080,100,126,131,209,  0,  0,
     & 211,0.250,100,  1,  8,  6,  0,  0,
     & 211,0.250,100,  3, 10,  6,  0,  0/
      DATA (IDK(I),BRFRAC(I),NME(I),(IDKPRD(J,I),J=1,5),I=1122,1140)/
     & 211,0.250,100,  5, 12,  6,  0,  0,
     & 211,0.085,100,121,128,  6,  0,  0,
     & 211,0.085,100,123,130,  6,  0,  0,
     & 211,0.080,100,125,132,  6,  0,  0,
     & 212,0.250,100,  2,  7,211,  0,  0,
     & 212,0.250,100,  4,  9,211,  0,  0,
     & 212,0.250,100,  6, 11,211,  0,  0,
     & 212,0.085,100,122,127,211,  0,  0,
     & 212,0.085,100,124,129,211,  0,  0,
     & 212,0.080,100,126,131,211,  0,  0,
     & 215,0.250,100,  7,  2, 10,  0,  0,
     & 215,0.250,100,  9,  4, 10,  0,  0,
     & 215,0.250,100, 11,  6, 10,  0,  0,
     & 215,0.085,100,127,122, 10,  0,  0,
     & 215,0.085,100,129,124, 10,  0,  0,
     & 215,0.080,100,131,126, 10,  0,  0,
     & 216,0.250,100,  8,  1,215,  0,  0,
     & 216,0.250,100, 10,  3,215,  0,  0,
     & 216,0.250,100, 12,  5,215,  0,  0/
      DATA (IDK(I),BRFRAC(I),NME(I),(IDKPRD(J,I),J=1,5),I=1141,1159)/
     & 216,0.085,100,128,121,215,  0,  0,
     & 216,0.085,100,130,123,215,  0,  0,
     & 216,0.080,100,132,125,215,  0,  0,
     & 217,0.250,100,  7,  2, 12,  0,  0,
     & 217,0.250,100,  9,  4, 12,  0,  0,
     & 217,0.250,100, 11,  6, 12,  0,  0,
     & 217,0.085,100,127,122, 12,  0,  0,
     & 217,0.085,100,129,124, 12,  0,  0,
     & 217,0.080,100,131,126, 12,  0,  0,
     & 218,0.250,100,  8,  1,217,  0,  0,
     & 218,0.250,100, 10,  3,217,  0,  0,
     & 218,0.250,100, 12,  5,217,  0,  0,
     & 218,0.085,100,128,121,217,  0,  0,
     & 218,0.085,100,130,123,217,  0,  0,
     & 218,0.080,100,132,125,217,  0,  0,
     & 221,0.016,101,121,128,136,  0,  0,
     & 221,0.016,101,123,130,136,  0,  0,
     & 221,0.008,101,125,132,136,  0,  0,
     & 221,0.048,101,121,128,137,  0,  0/
      DATA (IDK(I),BRFRAC(I),NME(I),(IDKPRD(J,I),J=1,5),I=1160,1178)/
     & 221,0.048,101,123,130,137,  0,  0,
     & 221,0.022,101,125,132,137,  0,  0,
     & 221,0.003,101,121,128,331,  0,  0,
     & 221,0.003,101,123,130,331,  0,  0,
     & 221,0.001,101,125,132,331,  0,  0,
     & 221,0.008,101,121,128,138,  0,  0,
     & 221,0.008,101,123,130,138,  0,  0,
     & 221,0.004,101,125,132,138,  0,  0,
     & 221,0.008,101,121,128,313,  0,  0,
     & 221,0.008,101,123,130,313,  0,  0,
     & 221,0.004,101,125,132,313,  0,  0,
     & 221,0.013,101,121,128,139,  0,  0,
     & 221,0.013,101,123,130,139,  0,  0,
     & 221,0.006,101,125,132,139,  0,  0,
     & 221,0.004,  0,136, 30,  0,  0,  0,
     & 221,0.010,  0,136, 31,  0,  0,  0,
     & 221,0.006,  0,136, 32,  0,  0,  0,
     & 221,0.003,  0,137, 30,  0,  0,  0,
     & 221,0.009,  0,137, 31,  0,  0,  0/
      DATA (IDK(I),BRFRAC(I),NME(I),(IDKPRD(J,I),J=1,5),I=1179,1197)/
     & 221,0.017,  0,137, 32,  0,  0,  0,
     & 221,0.011,  0,136,179,  0,  0,  0,
     & 221,0.015,  0,136,180,  0,  0,  0,
     & 221,0.011,  0,137,179,  0,  0,  0,
     & 221,0.022,  0,137,180,  0,  0,  0,
     & 221,0.001,  0,164, 42,  0,  0,  0,
     & 221,0.002,  0,164, 43,  0,  0,  0,
     & 221,0.001,  0,165, 42,  0,  0,  0,
     & 221,0.001,  0,165, 43,  0,  0,  0,
     & 221,0.001,  0,166, 42,  0,  0,  0,
     & 221,0.001,  0,166, 43,  0,  0,  0,
     & 221,0.207,100,  1,  8,  4,  7,  0,
     & 221,0.207,100,  3, 10,  4,  7,  0,
     & 221,0.024,100,  1,  8,  2,  7,  0,
     & 221,0.024,100,  3, 10,  2,  7,  0,
     & 221,0.012,100,  3,  8,  4,  7,  0,
     & 221,0.012,100,  1, 10,  4,  7,  0,
     & 221,0.069,100,  4,  8,  1,  7,  0,
     & 221,0.069,100,  4, 10,  3,  7,  0/
      DATA (IDK(I),BRFRAC(I),NME(I),(IDKPRD(J,I),J=1,5),I=1198,1216)/
     & 221,0.008,100,  2,  8,  1,  7,  0,
     & 221,0.008,100,  2, 10,  3,  7,  0,
     & 221,0.004,100,  4,  8,  3,  7,  0,
     & 221,0.004,100,  4, 10,  1,  7,  0,
     & 222,0.016,101,121,128,140,  0,  0,
     & 222,0.016,101,123,130,140,  0,  0,
     & 222,0.008,101,125,132,140,  0,  0,
     & 222,0.048,101,121,128,141,  0,  0,
     & 222,0.048,101,123,130,141,  0,  0,
     & 222,0.022,101,125,132,141,  0,  0,
     & 222,0.003,101,121,128,332,  0,  0,
     & 222,0.003,101,123,130,332,  0,  0,
     & 222,0.001,101,125,132,332,  0,  0,
     & 222,0.008,101,121,128,142,  0,  0,
     & 222,0.008,101,123,130,142,  0,  0,
     & 222,0.004,101,125,132,142,  0,  0,
     & 222,0.008,101,121,128,314,  0,  0,
     & 222,0.008,101,123,130,314,  0,  0,
     & 222,0.004,101,125,132,314,  0,  0/
      DATA (IDK(I),BRFRAC(I),NME(I),(IDKPRD(J,I),J=1,5),I=1217,1235)/
     & 222,0.013,101,121,128,143,  0,  0,
     & 222,0.013,101,123,130,143,  0,  0,
     & 222,0.006,101,125,132,143,  0,  0,
     & 222,0.004,  0,140, 30,  0,  0,  0,
     & 222,0.010,  0,140, 31,  0,  0,  0,
     & 222,0.006,  0,140, 32,  0,  0,  0,
     & 222,0.003,  0,141, 30,  0,  0,  0,
     & 222,0.009,  0,141, 31,  0,  0,  0,
     & 222,0.017,  0,141, 32,  0,  0,  0,
     & 222,0.011,  0,140,179,  0,  0,  0,
     & 222,0.015,  0,140,180,  0,  0,  0,
     & 222,0.011,  0,141,179,  0,  0,  0,
     & 222,0.022,  0,141,180,  0,  0,  0,
     & 222,0.001,  0,164, 34,  0,  0,  0,
     & 222,0.002,  0,164, 35,  0,  0,  0,
     & 222,0.001,  0,165, 34,  0,  0,  0,
     & 222,0.001,  0,165, 35,  0,  0,  0,
     & 222,0.001,  0,166, 34,  0,  0,  0,
     & 222,0.001,  0,166, 35,  0,  0,  0/
      DATA (IDK(I),BRFRAC(I),NME(I),(IDKPRD(J,I),J=1,5),I=1236,1254)/
     & 222,0.207,100,  1,  8,  4,  8,  0,
     & 222,0.207,100,  3, 10,  4,  8,  0,
     & 222,0.024,100,  1,  8,  2,  8,  0,
     & 222,0.024,100,  3, 10,  2,  8,  0,
     & 222,0.012,100,  3,  8,  4,  8,  0,
     & 222,0.012,100,  1, 10,  4,  8,  0,
     & 222,0.069,100,  4,  8,  1,  8,  0,
     & 222,0.069,100,  4, 10,  3,  8,  0,
     & 222,0.008,100,  2,  8,  1,  8,  0,
     & 222,0.008,100,  2, 10,  3,  8,  0,
     & 222,0.004,100,  4,  8,  3,  8,  0,
     & 222,0.004,100,  4, 10,  1,  8,  0,
     & 223,0.016,101,121,128,144,  0,  0,
     & 223,0.016,101,123,130,144,  0,  0,
     & 223,0.008,101,125,132,144,  0,  0,
     & 223,0.048,101,121,128,145,  0,  0,
     & 223,0.048,101,123,130,145,  0,  0,
     & 223,0.022,101,125,132,145,  0,  0,
     & 223,0.003,101,121,128,333,  0,  0/
      DATA (IDK(I),BRFRAC(I),NME(I),(IDKPRD(J,I),J=1,5),I=1255,1273)/
     & 223,0.003,101,123,130,333,  0,  0,
     & 223,0.001,101,125,132,333,  0,  0,
     & 223,0.008,101,121,128,146,  0,  0,
     & 223,0.008,101,123,130,146,  0,  0,
     & 223,0.004,101,125,132,146,  0,  0,
     & 223,0.008,101,121,128,315,  0,  0,
     & 223,0.008,101,123,130,315,  0,  0,
     & 223,0.004,101,125,132,315,  0,  0,
     & 223,0.013,101,121,128,147,  0,  0,
     & 223,0.013,101,123,130,147,  0,  0,
     & 223,0.006,101,125,132,147,  0,  0,
     & 223,0.004,  0,144, 30,  0,  0,  0,
     & 223,0.010,  0,144, 31,  0,  0,  0,
     & 223,0.006,  0,144, 32,  0,  0,  0,
     & 223,0.003,  0,145, 30,  0,  0,  0,
     & 223,0.009,  0,145, 31,  0,  0,  0,
     & 223,0.017,  0,145, 32,  0,  0,  0,
     & 223,0.011,  0,144,179,  0,  0,  0,
     & 223,0.015,  0,144,180,  0,  0,  0/
      DATA (IDK(I),BRFRAC(I),NME(I),(IDKPRD(J,I),J=1,5),I=1274,1292)/
     & 223,0.011,  0,145,179,  0,  0,  0,
     & 223,0.022,  0,145,180,  0,  0,  0,
     & 223,0.001,  0,164, 25,  0,  0,  0,
     & 223,0.002,  0,164, 56,  0,  0,  0,
     & 223,0.001,  0,165, 25,  0,  0,  0,
     & 223,0.001,  0,165, 56,  0,  0,  0,
     & 223,0.001,  0,166, 25,  0,  0,  0,
     & 223,0.001,  0,166, 56,  0,  0,  0,
     & 223,0.207,100,  1,  8,  4,  9,  0,
     & 223,0.207,100,  3, 10,  4,  9,  0,
     & 223,0.024,100,  1,  8,  2,  9,  0,
     & 223,0.024,100,  3, 10,  2,  9,  0,
     & 223,0.012,100,  3,  8,  4,  9,  0,
     & 223,0.012,100,  1, 10,  4,  9,  0,
     & 223,0.069,100,  4,  8,  1,  9,  0,
     & 223,0.069,100,  4, 10,  3,  9,  0,
     & 223,0.008,100,  2,  8,  1,  9,  0,
     & 223,0.008,100,  2, 10,  3,  9,  0,
     & 223,0.004,100,  4,  8,  3,  9,  0/
      DATA (IDK(I),BRFRAC(I),NME(I),(IDKPRD(J,I),J=1,5),I=1293,1311)/
     & 223,0.004,100,  4, 10,  1,  9,  0,
     & 224,0.090,100,121,128,  4,109,  0,
     & 224,0.090,100,123,130,  4,109,  0,
     & 224,0.045,100,125,132,  4,109,  0,
     & 224,0.010,100,121,128,  2,109,  0,
     & 224,0.010,100,123,130,  2,109,  0,
     & 224,0.005,100,125,132,  2,109,  0,
     & 224,0.242,100,  1,  8,  4,109,  0,
     & 224,0.242,100,  3, 10,  4,109,  0,
     & 224,0.027,100,  1,  8,  2,109,  0,
     & 224,0.027,100,  3, 10,  2,109,  0,
     & 224,0.012,100,  3,  8,  4,109,  0,
     & 224,0.012,100,  1, 10,  4,109,  0,
     & 224,0.081,100,  4,  8,  1,109,  0,
     & 224,0.081,100,  4, 10,  3,109,  0,
     & 224,0.009,100,  2,  8,  1,109,  0,
     & 224,0.009,100,  2, 10,  3,109,  0,
     & 224,0.004,100,  4,  8,  3,109,  0,
     & 224,0.004,100,  4, 10,  1,109,  0/
      DATA (IDK(I),BRFRAC(I),NME(I),(IDKPRD(J,I),J=1,5),I=1312,1330)/
     & 225,0.090,100,121,128,  4,110,  0,
     & 225,0.090,100,123,130,  4,110,  0,
     & 225,0.045,100,125,132,  4,110,  0,
     & 225,0.010,100,121,128,  2,110,  0,
     & 225,0.010,100,123,130,  2,110,  0,
     & 225,0.005,100,125,132,  2,110,  0,
     & 225,0.242,100,  1,  8,  4,110,  0,
     & 225,0.242,100,  3, 10,  4,110,  0,
     & 225,0.027,100,  1,  8,  2,110,  0,
     & 225,0.027,100,  3, 10,  2,110,  0,
     & 225,0.012,100,  3,  8,  4,110,  0,
     & 225,0.012,100,  1, 10,  4,110,  0,
     & 225,0.081,100,  4,  8,  1,110,  0,
     & 225,0.081,100,  4, 10,  3,110,  0,
     & 225,0.009,100,  2,  8,  1,110,  0,
     & 225,0.009,100,  2, 10,  3,110,  0,
     & 225,0.004,100,  4,  8,  3,110,  0,
     & 225,0.004,100,  4, 10,  1,110,  0,
     & 226,0.090,100,121,128,  4,111,  0/
      DATA (IDK(I),BRFRAC(I),NME(I),(IDKPRD(J,I),J=1,5),I=1331,1349)/
     & 226,0.090,100,123,130,  4,111,  0,
     & 226,0.045,100,125,132,  4,111,  0,
     & 226,0.010,100,121,128,  2,111,  0,
     & 226,0.010,100,123,130,  2,111,  0,
     & 226,0.005,100,125,132,  2,111,  0,
     & 226,0.242,100,  1,  8,  4,111,  0,
     & 226,0.242,100,  3, 10,  4,111,  0,
     & 226,0.027,100,  1,  8,  2,111,  0,
     & 226,0.027,100,  3, 10,  2,111,  0,
     & 226,0.012,100,  3,  8,  4,111,  0,
     & 226,0.012,100,  1, 10,  4,111,  0,
     & 226,0.081,100,  4,  8,  1,111,  0,
     & 226,0.081,100,  4, 10,  3,111,  0,
     & 226,0.009,100,  2,  8,  1,111,  0,
     & 226,0.009,100,  2, 10,  3,111,  0,
     & 226,0.004,100,  4,  8,  3,111,  0,
     & 226,0.004,100,  4, 10,  1,111,  0,
     & 227,0.090,100,121,128,  4,112,  0,
     & 227,0.090,100,123,130,  4,112,  0/
      DATA (IDK(I),BRFRAC(I),NME(I),(IDKPRD(J,I),J=1,5),I=1350,1368)/
     & 227,0.045,100,125,132,  4,112,  0,
     & 227,0.010,100,121,128,  2,112,  0,
     & 227,0.010,100,123,130,  2,112,  0,
     & 227,0.005,100,125,132,  2,112,  0,
     & 227,0.242,100,  1,  8,  4,112,  0,
     & 227,0.242,100,  3, 10,  4,112,  0,
     & 227,0.027,100,  1,  8,  2,112,  0,
     & 227,0.027,100,  3, 10,  2,112,  0,
     & 227,0.012,100,  3,  8,  4,112,  0,
     & 227,0.012,100,  1, 10,  4,112,  0,
     & 227,0.081,100,  4,  8,  1,112,  0,
     & 227,0.081,100,  4, 10,  3,112,  0,
     & 227,0.009,100,  2,  8,  1,112,  0,
     & 227,0.009,100,  2, 10,  3,112,  0,
     & 227,0.004,100,  4,  8,  3,112,  0,
     & 227,0.004,100,  4, 10,  1,112,  0,
     & 228,0.090,100,121,128,  4,113,  0,
     & 228,0.090,100,123,130,  4,113,  0,
     & 228,0.045,100,125,132,  4,113,  0/
      DATA (IDK(I),BRFRAC(I),NME(I),(IDKPRD(J,I),J=1,5),I=1369,1387)/
     & 228,0.010,100,121,128,  2,113,  0,
     & 228,0.010,100,123,130,  2,113,  0,
     & 228,0.005,100,125,132,  2,113,  0,
     & 228,0.242,100,  1,  8,  4,113,  0,
     & 228,0.242,100,  3, 10,  4,113,  0,
     & 228,0.027,100,  1,  8,  2,113,  0,
     & 228,0.027,100,  3, 10,  2,113,  0,
     & 228,0.012,100,  3,  8,  4,113,  0,
     & 228,0.012,100,  1, 10,  4,113,  0,
     & 228,0.081,100,  4,  8,  1,113,  0,
     & 228,0.081,100,  4, 10,  3,113,  0,
     & 228,0.009,100,  2,  8,  1,113,  0,
     & 228,0.009,100,  2, 10,  3,113,  0,
     & 228,0.004,100,  4,  8,  3,113,  0,
     & 228,0.004,100,  4, 10,  1,113,  0,
     & 229,0.090,100,121,128,  4,114,  0,
     & 229,0.090,100,123,130,  4,114,  0,
     & 229,0.045,100,125,132,  4,114,  0,
     & 229,0.010,100,121,128,  2,114,  0/
      DATA (IDK(I),BRFRAC(I),NME(I),(IDKPRD(J,I),J=1,5),I=1388,1406)/
     & 229,0.010,100,123,130,  2,114,  0,
     & 229,0.005,100,125,132,  2,114,  0,
     & 229,0.242,100,  1,  8,  4,114,  0,
     & 229,0.242,100,  3, 10,  4,114,  0,
     & 229,0.027,100,  1,  8,  2,114,  0,
     & 229,0.027,100,  3, 10,  2,114,  0,
     & 229,0.012,100,  3,  8,  4,114,  0,
     & 229,0.012,100,  1, 10,  4,114,  0,
     & 229,0.081,100,  4,  8,  1,114,  0,
     & 229,0.081,100,  4, 10,  3,114,  0,
     & 229,0.009,100,  2,  8,  1,114,  0,
     & 229,0.009,100,  2, 10,  3,114,  0,
     & 229,0.004,100,  4,  8,  3,114,  0,
     & 229,0.004,100,  4, 10,  1,114,  0,
     & 230,0.080,100,121,128,  4, 10,  0,
     & 230,0.080,100,123,130,  4, 10,  0,
     & 230,0.040,100,125,132,  4, 10,  0,
     & 230,0.080,100,121,128,  9,  5,  0,
     & 230,0.080,100,123,130,  9,  5,  0/
      DATA (IDK(I),BRFRAC(I),NME(I),(IDKPRD(J,I),J=1,5),I=1407,1425)/
     & 230,0.228,100,  1,  8,  4, 10,  0,
     & 230,0.228,100,  3, 10,  4, 10,  0,
     & 230,0.012,100,  3,  8,  4, 10,  0,
     & 230,0.012,100,  1, 10,  4, 10,  0,
     & 230,0.076,100,  4,  8,  1, 10,  0,
     & 230,0.076,100,  4, 10,  3, 10,  0,
     & 230,0.004,100,  4,  8,  3, 10,  0,
     & 230,0.004,100,  4, 10,  1, 10,  0,
     & 231,0.025,  0,121,127,  0,  0,  0,
     & 231,0.025,  0,123,129,  0,  0,  0,
     & 231,0.025,  0,125,131,  0,  0,  0,
     & 231,0.008,  0,  1,  7,  0,  0,  0,
     & 231,0.033,  0,  2,  8,  0,  0,  0,
     & 231,0.008,  0,  3,  9,  0,  0,  0,
     & 231,0.033,  0,  4, 10,  0,  0,  0,
     & 231,0.801,130, 13, 13, 13,  0,  0,
     & 231,0.042,130, 13, 13, 59,  0,  0,
     & 245,0.016,101,127,122,171,  0,  0,
     & 245,0.016,101,129,124,171,  0,  0/
      DATA (IDK(I),BRFRAC(I),NME(I),(IDKPRD(J,I),J=1,5),I=1426,1444)/
     & 245,0.008,101,131,126,171,  0,  0,
     & 245,0.048,101,127,122,172,  0,  0,
     & 245,0.048,101,129,124,172,  0,  0,
     & 245,0.022,101,131,126,172,  0,  0,
     & 245,0.003,101,127,122,334,  0,  0,
     & 245,0.003,101,129,124,334,  0,  0,
     & 245,0.001,101,131,126,334,  0,  0,
     & 245,0.008,101,127,122,173,  0,  0,
     & 245,0.008,101,129,124,173,  0,  0,
     & 245,0.004,101,131,126,173,  0,  0,
     & 245,0.008,101,127,122,316,  0,  0,
     & 245,0.008,101,129,124,316,  0,  0,
     & 245,0.004,101,131,126,316,  0,  0,
     & 245,0.013,101,127,122,174,  0,  0,
     & 245,0.013,101,129,124,174,  0,  0,
     & 245,0.006,101,131,126,174,  0,  0,
     & 245,0.004,  0,171, 38,  0,  0,  0,
     & 245,0.010,  0,171, 39,  0,  0,  0,
     & 245,0.006,  0,171, 40,  0,  0,  0/
      DATA (IDK(I),BRFRAC(I),NME(I),(IDKPRD(J,I),J=1,5),I=1445,1463)/
     & 245,0.003,  0,172, 38,  0,  0,  0,
     & 245,0.009,  0,172, 39,  0,  0,  0,
     & 245,0.017,  0,172, 40,  0,  0,  0,
     & 245,0.011,  0,171,144,  0,  0,  0,
     & 245,0.015,  0,171,145,  0,  0,  0,
     & 245,0.011,  0,172,144,  0,  0,  0,
     & 245,0.022,  0,172,145,  0,  0,  0,
     & 245,0.001,  0,164, 50,  0,  0,  0,
     & 245,0.002,  0,164, 51,  0,  0,  0,
     & 245,0.001,  0,165, 50,  0,  0,  0,
     & 245,0.001,  0,165, 51,  0,  0,  0,
     & 245,0.001,  0,166, 50,  0,  0,  0,
     & 245,0.001,  0,166, 51,  0,  0,  0,
     & 245,0.207,100,  7,  2, 10,  1,  0,
     & 245,0.207,100,  9,  4, 10,  1,  0,
     & 245,0.024,100,  7,  2,  8,  1,  0,
     & 245,0.024,100,  9,  4,  8,  1,  0,
     & 245,0.012,100,  9,  2, 10,  1,  0,
     & 245,0.012,100,  7,  4, 10,  1,  0/
      DATA (IDK(I),BRFRAC(I),NME(I),(IDKPRD(J,I),J=1,5),I=1464,1482)/
     & 245,0.069,100, 10,  2,  7,  1,  0,
     & 245,0.069,100, 10,  4,  9,  1,  0,
     & 245,0.008,100,  8,  2,  7,  1,  0,
     & 245,0.008,100,  8,  4,  9,  1,  0,
     & 245,0.004,100, 10,  2,  9,  1,  0,
     & 245,0.004,100, 10,  4,  7,  1,  0,
     & 246,0.016,101,127,122,175,  0,  0,
     & 246,0.016,101,129,124,175,  0,  0,
     & 246,0.008,101,131,126,175,  0,  0,
     & 246,0.048,101,127,122,176,  0,  0,
     & 246,0.048,101,129,124,176,  0,  0,
     & 246,0.022,101,131,126,176,  0,  0,
     & 246,0.003,101,127,122,335,  0,  0,
     & 246,0.003,101,129,124,335,  0,  0,
     & 246,0.001,101,131,126,335,  0,  0,
     & 246,0.008,101,127,122,177,  0,  0,
     & 246,0.008,101,129,124,177,  0,  0,
     & 246,0.004,101,131,126,177,  0,  0,
     & 246,0.008,101,127,122,317,  0,  0/
      DATA (IDK(I),BRFRAC(I),NME(I),(IDKPRD(J,I),J=1,5),I=1483,1501)/
     & 246,0.008,101,129,124,317,  0,  0,
     & 246,0.004,101,131,126,317,  0,  0,
     & 246,0.013,101,127,122,178,  0,  0,
     & 246,0.013,101,129,124,178,  0,  0,
     & 246,0.006,101,131,126,178,  0,  0,
     & 246,0.004,  0,175, 38,  0,  0,  0,
     & 246,0.010,  0,175, 39,  0,  0,  0,
     & 246,0.006,  0,175, 40,  0,  0,  0,
     & 246,0.003,  0,176, 38,  0,  0,  0,
     & 246,0.009,  0,176, 39,  0,  0,  0,
     & 246,0.017,  0,176, 40,  0,  0,  0,
     & 246,0.011,  0,175,144,  0,  0,  0,
     & 246,0.015,  0,175,145,  0,  0,  0,
     & 246,0.011,  0,176,144,  0,  0,  0,
     & 246,0.022,  0,176,145,  0,  0,  0,
     & 246,0.001,  0,164, 46,  0,  0,  0,
     & 246,0.002,  0,164, 47,  0,  0,  0,
     & 246,0.001,  0,165, 46,  0,  0,  0,
     & 246,0.001,  0,165, 47,  0,  0,  0/
      DATA (IDK(I),BRFRAC(I),NME(I),(IDKPRD(J,I),J=1,5),I=1502,1520)/
     & 246,0.001,  0,166, 46,  0,  0,  0,
     & 246,0.001,  0,166, 47,  0,  0,  0,
     & 246,0.207,100,  7,  2, 10,  2,  0,
     & 246,0.207,100,  9,  4, 10,  2,  0,
     & 246,0.024,100,  7,  2,  8,  2,  0,
     & 246,0.024,100,  9,  4,  8,  2,  0,
     & 246,0.012,100,  9,  2, 10,  2,  0,
     & 246,0.012,100,  7,  4, 10,  2,  0,
     & 246,0.069,100, 10,  2,  7,  2,  0,
     & 246,0.069,100, 10,  4,  9,  2,  0,
     & 246,0.008,100,  8,  2,  7,  2,  0,
     & 246,0.008,100,  8,  4,  9,  2,  0,
     & 246,0.004,100, 10,  2,  9,  2,  0,
     & 246,0.004,100, 10,  4,  7,  2,  0,
     & 247,0.016,101,127,122,179,  0,  0,
     & 247,0.016,101,129,124,179,  0,  0,
     & 247,0.008,101,131,126,179,  0,  0,
     & 247,0.048,101,127,122,180,  0,  0,
     & 247,0.048,101,129,124,180,  0,  0/
      DATA (IDK(I),BRFRAC(I),NME(I),(IDKPRD(J,I),J=1,5),I=1521,1539)/
     & 247,0.022,101,131,126,180,  0,  0,
     & 247,0.003,101,127,122,336,  0,  0,
     & 247,0.003,101,129,124,336,  0,  0,
     & 247,0.001,101,131,126,336,  0,  0,
     & 247,0.008,101,127,122,181,  0,  0,
     & 247,0.008,101,129,124,181,  0,  0,
     & 247,0.004,101,131,126,181,  0,  0,
     & 247,0.008,101,127,122,318,  0,  0,
     & 247,0.008,101,129,124,318,  0,  0,
     & 247,0.004,101,131,126,318,  0,  0,
     & 247,0.013,101,127,122,182,  0,  0,
     & 247,0.013,101,129,124,182,  0,  0,
     & 247,0.006,101,131,126,182,  0,  0,
     & 247,0.004,  0,179, 38,  0,  0,  0,
     & 247,0.010,  0,179, 39,  0,  0,  0,
     & 247,0.006,  0,179, 40,  0,  0,  0,
     & 247,0.003,  0,180, 38,  0,  0,  0,
     & 247,0.009,  0,180, 39,  0,  0,  0,
     & 247,0.017,  0,180, 40,  0,  0,  0/
      DATA (IDK(I),BRFRAC(I),NME(I),(IDKPRD(J,I),J=1,5),I=1540,1558)/
     & 247,0.011,  0,179,144,  0,  0,  0,
     & 247,0.015,  0,179,145,  0,  0,  0,
     & 247,0.011,  0,180,144,  0,  0,  0,
     & 247,0.022,  0,180,145,  0,  0,  0,
     & 247,0.001,  0,164, 25,  0,  0,  0,
     & 247,0.002,  0,164, 56,  0,  0,  0,
     & 247,0.001,  0,165, 25,  0,  0,  0,
     & 247,0.001,  0,165, 56,  0,  0,  0,
     & 247,0.001,  0,166, 25,  0,  0,  0,
     & 247,0.001,  0,166, 56,  0,  0,  0,
     & 247,0.207,100,  7,  2, 10,  3,  0,
     & 247,0.207,100,  9,  4, 10,  3,  0,
     & 247,0.024,100,  7,  2,  8,  3,  0,
     & 247,0.024,100,  9,  4,  8,  3,  0,
     & 247,0.012,100,  9,  2, 10,  3,  0,
     & 247,0.012,100,  7,  4, 10,  3,  0,
     & 247,0.069,100, 10,  2,  7,  3,  0,
     & 247,0.069,100, 10,  4,  9,  3,  0,
     & 247,0.008,100,  8,  2,  7,  3,  0/
      DATA (IDK(I),BRFRAC(I),NME(I),(IDKPRD(J,I),J=1,5),I=1559,1577)/
     & 247,0.008,100,  8,  4,  9,  3,  0,
     & 247,0.004,100, 10,  2,  9,  3,  0,
     & 247,0.004,100, 10,  4,  7,  3,  0,
     & 248,0.090,100,127,122, 10,115,  0,
     & 248,0.090,100,129,124, 10,115,  0,
     & 248,0.045,100,131,126, 10,115,  0,
     & 248,0.010,100,127,122,  8,115,  0,
     & 248,0.010,100,129,124,  8,115,  0,
     & 248,0.005,100,131,126,  8,115,  0,
     & 248,0.242,100,  7,  2, 10,115,  0,
     & 248,0.242,100,  9,  4, 10,115,  0,
     & 248,0.027,100,  7,  2,  8,115,  0,
     & 248,0.027,100,  9,  4,  8,115,  0,
     & 248,0.012,100,  9,  2, 10,115,  0,
     & 248,0.012,100,  7,  4, 10,115,  0,
     & 248,0.081,100, 10,  2,  7,115,  0,
     & 248,0.081,100, 10,  4,  9,115,  0,
     & 248,0.009,100,  8,  2,  7,115,  0,
     & 248,0.009,100,  8,  4,  9,115,  0/
      DATA (IDK(I),BRFRAC(I),NME(I),(IDKPRD(J,I),J=1,5),I=1578,1596)/
     & 248,0.004,100, 10,  2,  9,115,  0,
     & 248,0.004,100, 10,  4,  7,115,  0,
     & 249,0.090,100,127,122, 10,116,  0,
     & 249,0.090,100,129,124, 10,116,  0,
     & 249,0.045,100,131,126, 10,116,  0,
     & 249,0.010,100,127,122,  8,116,  0,
     & 249,0.010,100,129,124,  8,116,  0,
     & 249,0.005,100,131,126,  8,116,  0,
     & 249,0.242,100,  7,  2, 10,116,  0,
     & 249,0.242,100,  9,  4, 10,116,  0,
     & 249,0.027,100,  7,  2,  8,116,  0,
     & 249,0.027,100,  9,  4,  8,116,  0,
     & 249,0.012,100,  9,  2, 10,116,  0,
     & 249,0.012,100,  7,  4, 10,116,  0,
     & 249,0.081,100, 10,  2,  7,116,  0,
     & 249,0.081,100, 10,  4,  9,116,  0,
     & 249,0.009,100,  8,  2,  7,116,  0,
     & 249,0.009,100,  8,  4,  9,116,  0,
     & 249,0.004,100, 10,  2,  9,116,  0/
      DATA (IDK(I),BRFRAC(I),NME(I),(IDKPRD(J,I),J=1,5),I=1597,1615)/
     & 249,0.004,100, 10,  4,  7,116,  0,
     & 250,0.090,100,127,122, 10,117,  0,
     & 250,0.090,100,129,124, 10,117,  0,
     & 250,0.045,100,131,126, 10,117,  0,
     & 250,0.010,100,127,122,  8,117,  0,
     & 250,0.010,100,129,124,  8,117,  0,
     & 250,0.005,100,131,126,  8,117,  0,
     & 250,0.242,100,  7,  2, 10,117,  0,
     & 250,0.242,100,  9,  4, 10,117,  0,
     & 250,0.027,100,  7,  2,  8,117,  0,
     & 250,0.027,100,  9,  4,  8,117,  0,
     & 250,0.012,100,  9,  2, 10,117,  0,
     & 250,0.012,100,  7,  4, 10,117,  0,
     & 250,0.081,100, 10,  2,  7,117,  0,
     & 250,0.081,100, 10,  4,  9,117,  0,
     & 250,0.009,100,  8,  2,  7,117,  0,
     & 250,0.009,100,  8,  4,  9,117,  0,
     & 250,0.004,100, 10,  2,  9,117,  0,
     & 250,0.004,100, 10,  4,  7,117,  0/
      DATA (IDK(I),BRFRAC(I),NME(I),(IDKPRD(J,I),J=1,5),I=1616,1634)/
     & 251,0.090,100,127,122, 10,118,  0,
     & 251,0.090,100,129,124, 10,118,  0,
     & 251,0.045,100,131,126, 10,118,  0,
     & 251,0.010,100,127,122,  8,118,  0,
     & 251,0.010,100,129,124,  8,118,  0,
     & 251,0.005,100,131,126,  8,118,  0,
     & 251,0.242,100,  7,  2, 10,118,  0,
     & 251,0.242,100,  9,  4, 10,118,  0,
     & 251,0.027,100,  7,  2,  8,118,  0,
     & 251,0.027,100,  9,  4,  8,118,  0,
     & 251,0.012,100,  9,  2, 10,118,  0,
     & 251,0.012,100,  7,  4, 10,118,  0,
     & 251,0.081,100, 10,  2,  7,118,  0,
     & 251,0.081,100, 10,  4,  9,118,  0,
     & 251,0.009,100,  8,  2,  7,118,  0,
     & 251,0.009,100,  8,  4,  9,118,  0,
     & 251,0.004,100, 10,  2,  9,118,  0,
     & 251,0.004,100, 10,  4,  7,118,  0,
     & 252,0.090,100,127,122, 10,119,  0/
      DATA (IDK(I),BRFRAC(I),NME(I),(IDKPRD(J,I),J=1,5),I=1635,1653)/
     & 252,0.090,100,129,124, 10,119,  0,
     & 252,0.045,100,131,126, 10,119,  0,
     & 252,0.010,100,127,122,  8,119,  0,
     & 252,0.010,100,129,124,  8,119,  0,
     & 252,0.005,100,131,126,  8,119,  0,
     & 252,0.242,100,  7,  2, 10,119,  0,
     & 252,0.242,100,  9,  4, 10,119,  0,
     & 252,0.027,100,  7,  2,  8,119,  0,
     & 252,0.027,100,  9,  4,  8,119,  0,
     & 252,0.012,100,  9,  2, 10,119,  0,
     & 252,0.012,100,  7,  4, 10,119,  0,
     & 252,0.081,100, 10,  2,  7,119,  0,
     & 252,0.081,100, 10,  4,  9,119,  0,
     & 252,0.009,100,  8,  2,  7,119,  0,
     & 252,0.009,100,  8,  4,  9,119,  0,
     & 252,0.004,100, 10,  2,  9,119,  0,
     & 252,0.004,100, 10,  4,  7,119,  0,
     & 253,0.090,100,127,122, 10,120,  0,
     & 253,0.090,100,129,124, 10,120,  0/
      DATA (IDK(I),BRFRAC(I),NME(I),(IDKPRD(J,I),J=1,5),I=1654,1672)/
     & 253,0.045,100,131,126, 10,120,  0,
     & 253,0.010,100,127,122,  8,120,  0,
     & 253,0.010,100,129,124,  8,120,  0,
     & 253,0.005,100,131,126,  8,120,  0,
     & 253,0.242,100,  7,  2, 10,120,  0,
     & 253,0.242,100,  9,  4, 10,120,  0,
     & 253,0.027,100,  7,  2,  8,120,  0,
     & 253,0.027,100,  9,  4,  8,120,  0,
     & 253,0.012,100,  9,  2, 10,120,  0,
     & 253,0.012,100,  7,  4, 10,120,  0,
     & 253,0.081,100, 10,  2,  7,120,  0,
     & 253,0.081,100, 10,  4,  9,120,  0,
     & 253,0.009,100,  8,  2,  7,120,  0,
     & 253,0.009,100,  8,  4,  9,120,  0,
     & 253,0.004,100, 10,  2,  9,120,  0,
     & 253,0.004,100, 10,  4,  7,120,  0,
     & 254,0.080,100,127,122, 10,  4,  0,
     & 254,0.080,100,129,124, 10,  4,  0,
     & 254,0.040,100,131,126, 10,  4,  0/
      DATA (IDK(I),BRFRAC(I),NME(I),(IDKPRD(J,I),J=1,5),I=1673,1691)/
     & 254,0.080,100,127,122,  3, 11,  0,
     & 254,0.080,100,129,124,  3, 11,  0,
     & 254,0.228,100,  7,  2, 10,  4,  0,
     & 254,0.228,100,  9,  4, 10,  4,  0,
     & 254,0.012,100,  9,  2, 10,  4,  0,
     & 254,0.012,100,  7,  4, 10,  4,  0,
     & 254,0.076,100, 10,  2,  7,  4,  0,
     & 254,0.076,100, 10,  4,  9,  4,  0,
     & 254,0.004,100, 10,  2,  9,  4,  0,
     & 254,0.004,100, 10,  4,  7,  4,  0,
     & 265,1.000,  0,221, 59,  0,  0,  0,
     & 266,1.000,  0,222, 59,  0,  0,  0,
     & 267,1.000,  0,223, 59,  0,  0,  0,
     & 268,0.667,  0,266, 38,  0,  0,  0,
     & 268,0.333,  0,265, 21,  0,  0,  0,
     & 269,0.667,  0,265, 30,  0,  0,  0,
     & 269,0.333,  0,266, 21,  0,  0,  0,
     & 270,0.500,  0,265, 50,  0,  0,  0,
     & 270,0.500,  0,266, 46,  0,  0,  0/
      DATA (IDK(I),BRFRAC(I),NME(I),(IDKPRD(J,I),J=1,5),I=1692,1710)/
     & 271,0.290,  0,266, 38,  0,  0,  0,
     & 271,0.150,  0,265, 21,  0,  0,  0,
     & 271,0.290,  0,222, 38,  0,  0,  0,
     & 271,0.150,  0,221, 21,  0,  0,  0,
     & 271,0.060,  0,266, 38, 21,  0,  0,
     & 271,0.020,  0,265, 38, 30,  0,  0,
     & 271,0.010,  0,265, 21, 21,  0,  0,
     & 271,0.020,  0,222, 38, 21,  0,  0,
     & 271,0.010,  0,221, 38, 30,  0,  0,
     & 272,0.290,  0,265, 30,  0,  0,  0,
     & 272,0.150,  0,266, 21,  0,  0,  0,
     & 272,0.290,  0,221, 30,  0,  0,  0,
     & 272,0.150,  0,222, 21,  0,  0,  0,
     & 272,0.060,  0,265, 30, 21,  0,  0,
     & 272,0.020,  0,266, 38, 30,  0,  0,
     & 272,0.010,  0,266, 21, 21,  0,  0,
     & 272,0.020,  0,221, 30, 21,  0,  0,
     & 272,0.010,  0,222, 38, 30,  0,  0,
     & 273,0.350,  0,221, 50,  0,  0,  0/
      DATA (IDK(I),BRFRAC(I),NME(I),(IDKPRD(J,I),J=1,5),I=1711,1729)/
     & 273,0.350,  0,222, 46,  0,  0,  0,
     & 273,0.150,  0,265, 50,  0,  0,  0,
     & 273,0.150,  0,266, 46,  0,  0,  0,
     & 274,1.000,  0,245, 59,  0,  0,  0,
     & 275,1.000,  0,246, 59,  0,  0,  0,
     & 276,1.000,  0,247, 59,  0,  0,  0,
     & 277,0.667,  0,275, 30,  0,  0,  0,
     & 277,0.333,  0,274, 21,  0,  0,  0,
     & 278,0.667,  0,274, 38,  0,  0,  0,
     & 278,0.333,  0,275, 21,  0,  0,  0,
     & 279,0.500,  0,274, 42,  0,  0,  0,
     & 279,0.500,  0,275, 34,  0,  0,  0,
     & 280,0.290,  0,275, 30,  0,  0,  0,
     & 280,0.150,  0,274, 21,  0,  0,  0,
     & 280,0.290,  0,246, 30,  0,  0,  0,
     & 280,0.150,  0,245, 21,  0,  0,  0,
     & 280,0.060,  0,275, 30, 21,  0,  0,
     & 280,0.020,  0,274, 38, 30,  0,  0,
     & 280,0.010,  0,274, 21, 21,  0,  0/
      DATA (IDK(I),BRFRAC(I),NME(I),(IDKPRD(J,I),J=1,5),I=1730,1748)/
     & 280,0.020,  0,246, 30, 21,  0,  0,
     & 280,0.010,  0,245, 38, 30,  0,  0,
     & 281,0.290,  0,274, 38,  0,  0,  0,
     & 281,0.150,  0,275, 21,  0,  0,  0,
     & 281,0.290,  0,245, 38,  0,  0,  0,
     & 281,0.150,  0,246, 21,  0,  0,  0,
     & 281,0.060,  0,274, 38, 21,  0,  0,
     & 281,0.020,  0,275, 38, 30,  0,  0,
     & 281,0.010,  0,275, 21, 21,  0,  0,
     & 281,0.020,  0,245, 38, 21,  0,  0,
     & 281,0.010,  0,246, 38, 30,  0,  0,
     & 282,0.350,  0,245, 42,  0,  0,  0,
     & 282,0.350,  0,246, 34,  0,  0,  0,
     & 282,0.150,  0,274, 42,  0,  0,  0,
     & 282,0.150,  0,275, 34,  0,  0,  0,
     & 285,1.000,  0, 24, 21,  0,  0,  0,
     & 286,0.998,  0, 24, 38,  0,  0,  0,
     & 286,0.002,  0, 38, 59,  0,  0,  0,
     & 287,0.998,  0, 24, 30,  0,  0,  0/
      DATA (IDK(I),BRFRAC(I),NME(I),(IDKPRD(J,I),J=1,5),I=1749,1767)/
     & 287,0.002,  0, 30, 59,  0,  0,  0,
     & 288,0.330,  0, 39, 30,  0,  0,  0,
     & 288,0.340,  0, 23, 21,  0,  0,  0,
     & 288,0.330,  0, 31, 38,  0,  0,  0,
     & 289,0.250,  0, 46, 35,  0,  0,  0,
     & 289,0.250,  0, 34, 47,  0,  0,  0,
     & 289,0.250,  0, 50, 43,  0,  0,  0,
     & 289,0.250,  0, 42, 51,  0,  0,  0,
     & 290,0.996,  0, 22, 21,  0,  0,  0,
     & 290,0.002,  0, 46, 34,  0,  0,  0,
     & 290,0.002,  0, 50, 42,  0,  0,  0,
     & 291,0.996,  0, 22, 38,  0,  0,  0,
     & 291,0.004,  0, 46, 42,  0,  0,  0,
     & 292,0.996,  0, 22, 30,  0,  0,  0,
     & 292,0.004,  0, 50, 34,  0,  0,  0,
     & 293,0.520,  0, 38, 30,  0,  0,  0,
     & 293,0.260,  0, 21, 21,  0,  0,  0,
     & 293,0.110,  0, 46, 34,  0,  0,  0,
     & 293,0.110,  0, 50, 42,  0,  0,  0/
      DATA (IDK(I),BRFRAC(I),NME(I),(IDKPRD(J,I),J=1,5),I=1768,1786)/
     & 294,0.620,  0, 38, 30,  0,  0,  0,
     & 294,0.310,  0, 21, 21,  0,  0,  0,
     & 294,0.035,  0, 46, 34,  0,  0,  0,
     & 294,0.035,  0, 50, 42,  0,  0,  0,
     & 295,1.000,  0,254, 59,  0,  0,  0,
     & 296,1.000,  0,230, 59,  0,  0,  0,
     & 297,1.000,  0,254, 59,  0,  0,  0,
     & 298,1.000,  0,230, 59,  0,  0,  0,
     & 299,1.000,  0,254, 59,  0,  0,  0,
     & 300,1.000,  0,230, 59,  0,  0,  0,
     & 301,0.050,  0,121,127,  0,  0,  0,
     & 301,0.050,  0,123,129,  0,  0,  0,
     & 301,0.017,  0,  1,  7,  0,  0,  0,
     & 301,0.066,  0,  2,  8,  0,  0,  0,
     & 301,0.017,  0,  3,  9,  0,  0,  0,
     & 301,0.640,130, 13, 13, 13,  0,  0,
     & 301,0.160,130, 13, 13, 59,  0,  0,
     & 302,0.022,  0, 38, 30, 38, 30, 23,
     & 302,0.016,  0, 38, 30, 38, 30,  0/
      DATA (IDK(I),BRFRAC(I),NME(I),(IDKPRD(J,I),J=1,5),I=1787,1805)/
     & 302,0.009,  0, 38, 30, 46, 34,  0,
     & 302,0.004,  0, 23, 38, 30,  0,  0,
     & 302,0.002,  0, 46, 43, 30,  0,  0,
     & 302,0.002,  0, 34, 51, 38,  0,  0,
     & 302,0.001,  0, 38, 30, 73, 91,  0,
     & 302,0.273,  0, 59,164,  0,  0,  0,
     & 302,0.671,  0, 13, 13,  0,  0,  0,
     & 303,0.022,  0, 38, 30, 38, 30,  0,
     & 303,0.019,  0, 38, 30, 46, 34,  0,
     & 303,0.012,  0, 38, 30, 38, 30, 23,
     & 303,0.007,  0, 23, 38, 30,  0,  0,
     & 303,0.002,  0, 46, 43, 30,  0,  0,
     & 303,0.002,  0, 34, 51, 38,  0,  0,
     & 303,0.003,  0, 38, 30, 73, 91,  0,
     & 303,0.002,  0, 38, 30,  0,  0,  0,
     & 303,0.002,  0, 46, 34,  0,  0,  0,
     & 303,0.001,  0, 21, 21,  0,  0,  0,
     & 303,0.135,  0, 59,164,  0,  0,  0,
     & 303,0.793,  0, 13, 13,  0,  0,  0/
      DATA (IDK(I),BRFRAC(I),NME(I),(IDKPRD(J,I),J=1,5),I=1806,1824)/
     & 304,1.000,  0, 13, 13,  0,  0,  0,
     & 305,1.000,  0, 13, 13,  0,  0,  0,
     & 306,0.050,  0, 59,231,  0,  0,  0,
     & 306,0.950,  0, 13, 13,  0,  0,  0,
     & 307,0.350,  0, 59,231,  0,  0,  0,
     & 307,0.650,  0, 13, 13,  0,  0,  0,
     & 308,0.220,  0, 59,231,  0,  0,  0,
     & 308,0.780,  0, 13, 13,  0,  0,  0,
     & 309,0.280,  0, 46, 31,  0,  0,  0,
     & 309,0.140,  0, 50, 23,  0,  0,  0,
     & 309,0.187,  0,327, 30,  0,  0,  0,
     & 309,0.093,  0,328, 21,  0,  0,  0,
     & 309,0.110,  0, 50, 24,  0,  0,  0,
     & 309,0.107,  0, 47, 30,  0,  0,  0,
     & 309,0.053,  0, 51, 21,  0,  0,  0,
     & 309,0.030,  0, 50,293,  0,  0,  0,
     & 310,0.280,  0, 50, 39,  0,  0,  0,
     & 310,0.140,  0, 46, 23,  0,  0,  0,
     & 310,0.187,  0,328, 38,  0,  0,  0/
      DATA (IDK(I),BRFRAC(I),NME(I),(IDKPRD(J,I),J=1,5),I=1825,1843)/
     & 310,0.093,  0,327, 21,  0,  0,  0,
     & 310,0.110,  0, 46, 24,  0,  0,  0,
     & 310,0.107,  0, 51, 38,  0,  0,  0,
     & 310,0.053,  0, 47, 21,  0,  0,  0,
     & 310,0.030,  0, 46,293,  0,  0,  0,
     & 311,0.280,  0, 34, 39,  0,  0,  0,
     & 311,0.140,  0, 42, 23,  0,  0,  0,
     & 311,0.187,  0,330, 38,  0,  0,  0,
     & 311,0.093,  0,329, 21,  0,  0,  0,
     & 311,0.110,  0, 42, 24,  0,  0,  0,
     & 311,0.107,  0, 35, 38,  0,  0,  0,
     & 311,0.053,  0, 43, 21,  0,  0,  0,
     & 311,0.030,  0, 42,293,  0,  0,  0,
     & 312,0.280,  0, 42, 31,  0,  0,  0,
     & 312,0.140,  0, 34, 23,  0,  0,  0,
     & 312,0.187,  0,329, 30,  0,  0,  0,
     & 312,0.093,  0,330, 21,  0,  0,  0,
     & 312,0.110,  0, 34, 24,  0,  0,  0,
     & 312,0.107,  0, 43, 30,  0,  0,  0/
      DATA (IDK(I),BRFRAC(I),NME(I),(IDKPRD(J,I),J=1,5),I=1844,1862)/
     & 312,0.053,  0, 35, 21,  0,  0,  0,
     & 312,0.030,  0, 34,293,  0,  0,  0,
     & 313,0.430,  0,140, 38,  0,  0,  0,
     & 313,0.215,  0,136, 21,  0,  0,  0,
     & 313,0.235,  0,140, 38, 21,  0,  0,
     & 313,0.120,  0,136, 38, 30,  0,  0,
     & 314,0.430,  0,136, 30,  0,  0,  0,
     & 314,0.215,  0,140, 21,  0,  0,  0,
     & 314,0.235,  0,136, 30, 21,  0,  0,
     & 314,0.120,  0,140, 38, 30,  0,  0,
     & 315,0.480,  0,136, 50,  0,  0,  0,
     & 315,0.480,  0,140, 46,  0,  0,  0,
     & 315,0.040,  0,145, 59,  0,  0,  0,
     & 316,0.430,  0,175, 30,  0,  0,  0,
     & 316,0.215,  0,171, 21,  0,  0,  0,
     & 316,0.235,  0,175, 30, 21,  0,  0,
     & 316,0.120,  0,171, 38, 30,  0,  0,
     & 317,0.430,  0,171, 38,  0,  0,  0,
     & 317,0.215,  0,175, 21,  0,  0,  0/
      DATA (IDK(I),BRFRAC(I),NME(I),(IDKPRD(J,I),J=1,5),I=1863,1881)/
     & 317,0.235,  0,171, 38, 21,  0,  0,
     & 317,0.120,  0,175, 38, 30,  0,  0,
     & 318,0.480,  0,171, 42,  0,  0,  0,
     & 318,0.480,  0,175, 34,  0,  0,  0,
     & 318,0.040,  0,180, 59,  0,  0,  0,
     & 319,0.540,  0,275, 30,  0,  0,  0,
     & 319,0.270,  0,274, 21,  0,  0,  0,
     & 319,0.030,  0,275, 30, 21,  0,  0,
     & 319,0.010,  0,274, 38, 30,  0,  0,
     & 319,0.010,  0,274, 21, 21,  0,  0,
     & 319,0.090,  0,246, 30, 21,  0,  0,
     & 319,0.030,  0,245, 38, 30,  0,  0,
     & 319,0.020,  0,245, 21, 21,  0,  0,
     & 320,0.540,  0,274, 38,  0,  0,  0,
     & 320,0.270,  0,275, 21,  0,  0,  0,
     & 320,0.030,  0,274, 38, 21,  0,  0,
     & 320,0.010,  0,275, 38, 30,  0,  0,
     & 320,0.010,  0,275, 21, 21,  0,  0,
     & 320,0.090,  0,245, 38, 21,  0,  0/
      DATA (IDK(I),BRFRAC(I),NME(I),(IDKPRD(J,I),J=1,5),I=1882,1900)/
     & 320,0.030,  0,246, 38, 30,  0,  0,
     & 320,0.020,  0,246, 21, 21,  0,  0,
     & 321,0.500,  0,266, 46,  0,  0,  0,
     & 321,0.500,  0,265, 50,  0,  0,  0,
     & 322,1.000,  0,254, 59,  0,  0,  0,
     & 323,0.540,  0,266, 38,  0,  0,  0,
     & 323,0.270,  0,265, 21,  0,  0,  0,
     & 323,0.030,  0,266, 38, 21,  0,  0,
     & 323,0.010,  0,265, 38, 30,  0,  0,
     & 323,0.010,  0,265, 21, 21,  0,  0,
     & 323,0.090,  0,222, 38, 21,  0,  0,
     & 323,0.030,  0,221, 38, 30,  0,  0,
     & 323,0.020,  0,221, 21, 21,  0,  0,
     & 324,0.540,  0,265, 30,  0,  0,  0,
     & 324,0.270,  0,266, 21,  0,  0,  0,
     & 324,0.030,  0,265, 30, 21,  0,  0,
     & 324,0.010,  0,266, 38, 30,  0,  0,
     & 324,0.010,  0,266, 21, 21,  0,  0,
     & 324,0.090,  0,221, 30, 21,  0,  0/
      DATA (IDK(I),BRFRAC(I),NME(I),(IDKPRD(J,I),J=1,5),I=1901,1919)/
     & 324,0.030,  0,222, 38, 30,  0,  0,
     & 324,0.020,  0,222, 21, 21,  0,  0,
     & 325,0.500,  0,275, 34,  0,  0,  0,
     & 325,0.500,  0,274, 42,  0,  0,  0,
     & 326,1.000,  0,230, 59,  0,  0,  0,
     & 327,0.667,  0, 50, 38,  0,  0,  0,
     & 327,0.333,  0, 46, 21,  0,  0,  0,
     & 328,0.667,  0, 46, 30,  0,  0,  0,
     & 328,0.333,  0, 50, 21,  0,  0,  0,
     & 329,0.667,  0, 34, 38,  0,  0,  0,
     & 329,0.333,  0, 42, 21,  0,  0,  0,
     & 330,0.667,  0, 42, 30,  0,  0,  0,
     & 330,0.333,  0, 34, 21,  0,  0,  0,
     & 331,0.667,  0,140, 38,  0,  0,  0,
     & 331,0.333,  0,136, 21,  0,  0,  0,
     & 332,0.667,  0,136, 30,  0,  0,  0,
     & 332,0.333,  0,140, 21,  0,  0,  0,
     & 333,0.500,  0,136, 50,  0,  0,  0,
     & 333,0.500,  0,140, 46,  0,  0,  0/
      DATA (IDK(I),BRFRAC(I),NME(I),(IDKPRD(J,I),J=1,5),I=1920,1938)/
     & 334,0.667,  0,175, 30,  0,  0,  0,
     & 334,0.333,  0,171, 21,  0,  0,  0,
     & 335,0.667,  0,171, 38,  0,  0,  0,
     & 335,0.333,  0,175, 21,  0,  0,  0,
     & 336,0.500,  0,171, 42,  0,  0,  0,
     & 336,0.500,  0,175, 34,  0,  0,  0,
     & 337,0.667,  0,246, 30,  0,  0,  0,
     & 337,0.333,  0,245, 21,  0,  0,  0,
     & 338,0.667,  0,245, 38,  0,  0,  0,
     & 338,0.333,  0,246, 21,  0,  0,  0,
     & 339,0.500,  0,246, 34,  0,  0,  0,
     & 339,0.500,  0,245, 42,  0,  0,  0,
     & 340,1.000,  0,254, 59,  0,  0,  0,
     & 341,0.667,  0,222, 38,  0,  0,  0,
     & 341,0.333,  0,221, 21,  0,  0,  0,
     & 342,0.667,  0,221, 30,  0,  0,  0,
     & 342,0.333,  0,222, 21,  0,  0,  0,
     & 343,0.500,  0,222, 46,  0,  0,  0,
     & 343,0.500,  0,221, 50,  0,  0,  0/
      DATA (IDK(I),BRFRAC(I),NME(I),(IDKPRD(J,I),J=1,5),I=1939,1957)/
     & 344,1.000,  0,230, 59,  0,  0,  0,
     & 345,1.000,  0,225, 30,  0,  0,  0,
     & 346,1.000,  0,225, 21,  0,  0,  0,
     & 347,1.000,  0,225, 21,  0,  0,  0,
     & 348,1.000,  0,225, 38,  0,  0,  0,
     & 349,0.600,  0,228, 38,  0,  0,  0,
     & 349,0.300,  0,227, 21,  0,  0,  0,
     & 349,0.100,  0,227, 59,  0,  0,  0,
     & 350,0.600,  0,228, 38,  0,  0,  0,
     & 350,0.300,  0,227, 21,  0,  0,  0,
     & 350,0.100,  0,227, 59,  0,  0,  0,
     & 351,0.600,  0,227, 30,  0,  0,  0,
     & 351,0.300,  0,228, 21,  0,  0,  0,
     & 351,0.100,  0,228, 59,  0,  0,  0,
     & 352,0.600,  0,227, 30,  0,  0,  0,
     & 352,0.300,  0,228, 21,  0,  0,  0,
     & 352,0.100,  0,228, 59,  0,  0,  0,
     & 353,1.000,  0,229, 59,  0,  0,  0,
     & 354,1.000,  0,249, 38,  0,  0,  0/
      DATA (IDK(I),BRFRAC(I),NME(I),(IDKPRD(J,I),J=1,5),I=1958,1976)/
     & 355,1.000,  0,249, 21,  0,  0,  0,
     & 356,1.000,  0,249, 21,  0,  0,  0,
     & 357,1.000,  0,249, 30,  0,  0,  0,
     & 358,0.600,  0,252, 30,  0,  0,  0,
     & 358,0.300,  0,251, 21,  0,  0,  0,
     & 358,0.100,  0,251, 59,  0,  0,  0,
     & 359,0.600,  0,252, 30,  0,  0,  0,
     & 359,0.300,  0,251, 21,  0,  0,  0,
     & 359,0.100,  0,251, 59,  0,  0,  0,
     & 360,0.600,  0,251, 38,  0,  0,  0,
     & 360,0.300,  0,252, 21,  0,  0,  0,
     & 360,0.100,  0,252, 59,  0,  0,  0,
     & 361,0.600,  0,251, 38,  0,  0,  0,
     & 361,0.300,  0,252, 21,  0,  0,  0,
     & 361,0.100,  0,252, 59,  0,  0,  0,
     & 362,1.000,  0,253, 59,  0,  0,  0,
     & 363,0.400,  0, 53, 38,  0,  0,  0,
     & 363,0.200,  0, 49, 21,  0,  0,  0,
     & 363,0.100,  0, 51, 38,  0,  0,  0/
      DATA (IDK(I),BRFRAC(I),NME(I),(IDKPRD(J,I),J=1,5),I=1977,1995)/
     & 363,0.050,  0, 47, 21,  0,  0,  0,
     & 363,0.150,  0, 46, 26,  0,  0,  0,
     & 363,0.050,  0, 46, 56,  0,  0,  0,
     & 363,0.050,  0, 46, 24,  0,  0,  0,
     & 364,0.400,  0, 49, 30,  0,  0,  0,
     & 364,0.200,  0, 53, 21,  0,  0,  0,
     & 364,0.100,  0, 47, 30,  0,  0,  0,
     & 364,0.050,  0, 51, 21,  0,  0,  0,
     & 364,0.150,  0, 50, 26,  0,  0,  0,
     & 364,0.050,  0, 50, 56,  0,  0,  0,
     & 364,0.050,  0, 50, 24,  0,  0,  0,
     & 365,0.400,  0, 37, 38,  0,  0,  0,
     & 365,0.200,  0, 45, 21,  0,  0,  0,
     & 365,0.100,  0, 35, 38,  0,  0,  0,
     & 365,0.050,  0, 43, 21,  0,  0,  0,
     & 365,0.150,  0, 42, 26,  0,  0,  0,
     & 365,0.050,  0, 42, 56,  0,  0,  0,
     & 365,0.050,  0, 42, 24,  0,  0,  0,
     & 366,0.400,  0, 45, 30,  0,  0,  0/
      DATA (IDK(I),BRFRAC(I),NME(I),(IDKPRD(J,I),J=1,5),I=1996,2014)/
     & 366,0.200,  0, 37, 21,  0,  0,  0,
     & 366,0.100,  0, 43, 30,  0,  0,  0,
     & 366,0.050,  0, 35, 21,  0,  0,  0,
     & 366,0.150,  0, 34, 26,  0,  0,  0,
     & 366,0.050,  0, 34, 56,  0,  0,  0,
     & 366,0.050,  0, 34, 24,  0,  0,  0,
     & 367,0.258,  0, 50, 38,  0,  0,  0,
     & 367,0.129,  0, 46, 21,  0,  0,  0,
     & 367,0.209,  0, 50, 39,  0,  0,  0,
     & 367,0.105,  0, 46, 23,  0,  0,  0,
     & 367,0.199,  0, 51, 38,  0,  0,  0,
     & 367,0.100,  0, 47, 21,  0,  0,  0,
     & 368,0.258,  0, 46, 30,  0,  0,  0,
     & 368,0.129,  0, 50, 21,  0,  0,  0,
     & 368,0.209,  0, 46, 31,  0,  0,  0,
     & 368,0.105,  0, 50, 23,  0,  0,  0,
     & 368,0.199,  0, 47, 30,  0,  0,  0,
     & 368,0.100,  0, 51, 21,  0,  0,  0,
     & 369,0.258,  0, 34, 38,  0,  0,  0/
      DATA (IDK(I),BRFRAC(I),NME(I),(IDKPRD(J,I),J=1,5),I=2015,2033)/
     & 369,0.129,  0, 42, 21,  0,  0,  0,
     & 369,0.209,  0, 34, 39,  0,  0,  0,
     & 369,0.105,  0, 42, 23,  0,  0,  0,
     & 369,0.199,  0, 35, 38,  0,  0,  0,
     & 369,0.100,  0, 43, 21,  0,  0,  0,
     & 370,0.258,  0, 42, 30,  0,  0,  0,
     & 370,0.129,  0, 34, 21,  0,  0,  0,
     & 370,0.209,  0, 42, 31,  0,  0,  0,
     & 370,0.105,  0, 34, 23,  0,  0,  0,
     & 370,0.199,  0, 43, 30,  0,  0,  0,
     & 370,0.100,  0, 35, 21,  0,  0,  0,
     & 371,0.400,  0, 53, 38,  0,  0,  0,
     & 371,0.200,  0, 49, 21,  0,  0,  0,
     & 371,0.100,  0, 51, 38,  0,  0,  0,
     & 371,0.050,  0, 47, 21,  0,  0,  0,
     & 371,0.150,  0, 46, 26,  0,  0,  0,
     & 371,0.050,  0, 46, 56,  0,  0,  0,
     & 371,0.050,  0, 46, 24,  0,  0,  0,
     & 372,0.400,  0, 49, 30,  0,  0,  0/
      DATA (IDK(I),BRFRAC(I),NME(I),(IDKPRD(J,I),J=1,5),I=2034,2052)/
     & 372,0.200,  0, 53, 21,  0,  0,  0,
     & 372,0.100,  0, 47, 30,  0,  0,  0,
     & 372,0.050,  0, 51, 21,  0,  0,  0,
     & 372,0.150,  0, 50, 26,  0,  0,  0,
     & 372,0.050,  0, 50, 56,  0,  0,  0,
     & 372,0.050,  0, 50, 24,  0,  0,  0,
     & 373,0.400,  0, 37, 38,  0,  0,  0,
     & 373,0.200,  0, 45, 21,  0,  0,  0,
     & 373,0.100,  0, 35, 38,  0,  0,  0,
     & 373,0.050,  0, 43, 21,  0,  0,  0,
     & 373,0.150,  0, 42, 26,  0,  0,  0,
     & 373,0.050,  0, 42, 56,  0,  0,  0,
     & 373,0.050,  0, 42, 24,  0,  0,  0,
     & 374,0.400,  0, 45, 30,  0,  0,  0,
     & 374,0.200,  0, 37, 21,  0,  0,  0,
     & 374,0.100,  0, 43, 30,  0,  0,  0,
     & 374,0.050,  0, 35, 21,  0,  0,  0,
     & 374,0.150,  0, 34, 26,  0,  0,  0,
     & 374,0.050,  0, 34, 56,  0,  0,  0/
      DATA (IDK(I),BRFRAC(I),NME(I),(IDKPRD(J,I),J=1,5),I=2053,2071)/
     & 374,0.050,  0, 34, 24,  0,  0,  0,
     & 375,0.208,  0, 50, 39,  0,  0,  0,
     & 375,0.104,  0, 46, 23,  0,  0,  0,
     & 375,0.134,  0, 51, 38,  0,  0,  0,
     & 375,0.067,  0, 47, 21,  0,  0,  0,
     & 375,0.124,  0, 50, 38,  0,  0,  0,
     & 375,0.062,  0, 46, 21,  0,  0,  0,
     & 375,0.301,  0, 46, 22,  0,  0,  0,
     & 376,0.208,  0, 46, 31,  0,  0,  0,
     & 376,0.104,  0, 50, 23,  0,  0,  0,
     & 376,0.134,  0, 47, 30,  0,  0,  0,
     & 376,0.067,  0, 51, 21,  0,  0,  0,
     & 376,0.124,  0, 46, 30,  0,  0,  0,
     & 376,0.062,  0, 50, 21,  0,  0,  0,
     & 376,0.301,  0, 50, 22,  0,  0,  0,
     & 377,0.208,  0, 34, 39,  0,  0,  0,
     & 377,0.104,  0, 42, 23,  0,  0,  0,
     & 377,0.134,  0, 35, 38,  0,  0,  0,
     & 377,0.067,  0, 43, 21,  0,  0,  0/
      DATA (IDK(I),BRFRAC(I),NME(I),(IDKPRD(J,I),J=1,5),I=2072,2090)/
     & 377,0.124,  0, 34, 38,  0,  0,  0,
     & 377,0.062,  0, 42, 21,  0,  0,  0,
     & 377,0.301,  0, 42, 22,  0,  0,  0,
     & 378,0.208,  0, 42, 31,  0,  0,  0,
     & 378,0.104,  0, 34, 23,  0,  0,  0,
     & 378,0.134,  0, 43, 30,  0,  0,  0,
     & 378,0.067,  0, 35, 21,  0,  0,  0,
     & 378,0.124,  0, 42, 30,  0,  0,  0,
     & 378,0.062,  0, 34, 21,  0,  0,  0,
     & 378,0.301,  0, 34, 22,  0,  0,  0,
     & 379,0.562,  0, 26, 38,  0,  0,  0,
     & 379,0.155,  0, 39, 21,  0,  0,  0,
     & 379,0.155,  0, 23, 38,  0,  0,  0,
     & 379,0.088,  0,293, 38,  0,  0,  0,
     & 379,0.020,  0, 46, 43,  0,  0,  0,
     & 379,0.020,  0, 42, 47,  0,  0,  0,
     & 380,0.562,  0, 26, 21,  0,  0,  0,
     & 380,0.155,  0, 39, 30,  0,  0,  0,
     & 380,0.155,  0, 31, 38,  0,  0,  0/
      DATA (IDK(I),BRFRAC(I),NME(I),(IDKPRD(J,I),J=1,5),I=2091,2109)/
     & 380,0.088,  0,293, 21,  0,  0,  0,
     & 380,0.010,  0, 46, 35,  0,  0,  0,
     & 380,0.010,  0, 50, 43,  0,  0,  0,
     & 380,0.010,  0, 34, 47,  0,  0,  0,
     & 380,0.010,  0, 42, 51,  0,  0,  0,
     & 381,0.562,  0, 26, 30,  0,  0,  0,
     & 381,0.155,  0, 31, 21,  0,  0,  0,
     & 381,0.155,  0, 23, 30,  0,  0,  0,
     & 381,0.088,  0,293, 30,  0,  0,  0,
     & 381,0.020,  0, 34, 51,  0,  0,  0,
     & 381,0.020,  0, 50, 35,  0,  0,  0,
     & 382,0.360,  0, 31, 38, 38,  0,  0,
     & 382,0.180,  0, 23, 38, 21,  0,  0,
     & 382,0.040,  0, 39, 21, 21,  0,  0,
     & 382,0.020,  0, 39, 38, 30,  0,  0,
     & 382,0.300,  0, 38, 21,  0,  0,  0,
     & 382,0.040,  0, 46, 43,  0,  0,  0,
     & 382,0.040,  0, 42, 47,  0,  0,  0,
     & 382,0.020,  0, 22, 39,  0,  0,  0/
      DATA (IDK(I),BRFRAC(I),NME(I),(IDKPRD(J,I),J=1,5),I=2110,2128)/
     & 383,0.180,  0, 39, 30, 21,  0,  0,
     & 383,0.180,  0, 31, 38, 21,  0,  0,
     & 383,0.160,  0, 23, 21, 21,  0,  0,
     & 383,0.080,  0, 23, 38, 30,  0,  0,
     & 383,0.300,  0, 38, 30,  0,  0,  0,
     & 383,0.020,  0, 46, 35,  0,  0,  0,
     & 383,0.020,  0, 50, 43,  0,  0,  0,
     & 383,0.020,  0, 34, 47,  0,  0,  0,
     & 383,0.020,  0, 42, 51,  0,  0,  0,
     & 383,0.020,  0, 22, 23,  0,  0,  0,
     & 384,0.360,  0, 39, 30, 30,  0,  0,
     & 384,0.180,  0, 23, 30, 21,  0,  0,
     & 384,0.040,  0, 31, 21, 21,  0,  0,
     & 384,0.020,  0, 31, 30, 38,  0,  0,
     & 384,0.300,  0, 30, 21,  0,  0,  0,
     & 384,0.040,  0, 34, 51,  0,  0,  0,
     & 384,0.040,  0, 50, 35,  0,  0,  0,
     & 384,0.020,  0, 22, 31,  0,  0,  0,
     & 385,0.184,  0, 41, 21,  0,  0,  0/
      DATA (IDK(I),BRFRAC(I),NME(I),(IDKPRD(J,I),J=1,5),I=2129,2147)/
     & 385,0.184,  0, 29, 38,  0,  0,  0,
     & 385,0.184,  0, 39, 23,  0,  0,  0,
     & 385,0.236,  0, 38, 21,  0,  0,  0,
     & 385,0.160,  0, 24, 38,  0,  0,  0,
     & 385,0.018,  0, 46, 43,  0,  0,  0,
     & 385,0.018,  0, 42, 47,  0,  0,  0,
     & 385,0.016,  0, 46, 42,  0,  0,  0,
     & 386,0.184,  0, 41, 30,  0,  0,  0,
     & 386,0.184,  0, 33, 38,  0,  0,  0,
     & 386,0.184,  0, 39, 31,  0,  0,  0,
     & 386,0.236,  0, 38, 30,  0,  0,  0,
     & 386,0.160,  0, 24, 21,  0,  0,  0,
     & 386,0.009,  0, 46, 35,  0,  0,  0,
     & 386,0.009,  0, 50, 43,  0,  0,  0,
     & 386,0.009,  0, 34, 47,  0,  0,  0,
     & 386,0.009,  0, 42, 51,  0,  0,  0,
     & 386,0.008,  0, 46, 34,  0,  0,  0,
     & 386,0.008,  0, 42, 50,  0,  0,  0,
     & 387,0.184,  0, 33, 21,  0,  0,  0/
      DATA (IDK(I),BRFRAC(I),NME(I),(IDKPRD(J,I),J=1,5),I=2148,2166)/
     & 387,0.184,  0, 29, 30,  0,  0,  0,
     & 387,0.184,  0, 31, 23,  0,  0,  0,
     & 387,0.236,  0, 30, 21,  0,  0,  0,
     & 387,0.160,  0, 24, 30,  0,  0,  0,
     & 387,0.018,  0, 34, 51,  0,  0,  0,
     & 387,0.018,  0, 50, 35,  0,  0,  0,
     & 387,0.016,  0, 34, 50,  0,  0,  0,
     & 388,0.183,  0,231, 38, 30,  0,  0,
     & 388,0.091,  0,231, 21, 21,  0,  0,
     & 388,0.067,  0, 59,307,  0,  0,  0,
     & 388,0.066,  0, 59,308,  0,  0,  0,
     & 388,0.043,  0, 59,309,  0,  0,  0,
     & 388,0.446,130, 13, 13, 13,  0,  0,
     & 388,0.023,130, 13, 13, 59,  0,  0,
     & 388,0.013,  0,121,127,  0,  0,  0,
     & 388,0.013,  0,123,129,  0,  0,  0,
     & 388,0.013,  0,125,131,  0,  0,  0,
     & 388,0.004,  0,  1,  7,  0,  0,  0,
     & 388,0.017,  0,  2,  8,  0,  0,  0/
      DATA (IDK(I),BRFRAC(I),NME(I),(IDKPRD(J,I),J=1,5),I=2167,2185)/
     & 388,0.004,  0,  3,  9,  0,  0,  0,
     & 388,0.017,  0,  4, 10,  0,  0,  0,
     & 389,0.046,  0, 59,388,  0,  0,  0,
     & 389,0.009,  0, 59,231,  0,  0,  0,
     & 389,0.755,  0, 13, 13,  0,  0,  0,
     & 389,0.030,  0,121,127,  0,  0,  0,
     & 389,0.030,  0,123,129,  0,  0,  0,
     & 389,0.030,  0,125,131,  0,  0,  0,
     & 389,0.010,  0,  1,  7,  0,  0,  0,
     & 389,0.040,  0,  2,  8,  0,  0,  0,
     & 389,0.010,  0,  3,  9,  0,  0,  0,
     & 389,0.040,  0,  4, 10,  0,  0,  0,
     & 390,0.210,  0, 59,388,  0,  0,  0,
     & 390,0.085,  0, 59,231,  0,  0,  0,
     & 390,0.565,  0, 13, 13,  0,  0,  0,
     & 390,0.022,  0,121,127,  0,  0,  0,
     & 390,0.022,  0,123,129,  0,  0,  0,
     & 390,0.022,  0,125,131,  0,  0,  0,
     & 390,0.007,  0,  1,  7,  0,  0,  0/
      DATA (IDK(I),BRFRAC(I),NME(I),(IDKPRD(J,I),J=1,5),I=2186,2204)/
     & 390,0.030,  0,  2,  8,  0,  0,  0,
     & 390,0.007,  0,  3,  9,  0,  0,  0,
     & 390,0.030,  0,  4, 10,  0,  0,  0,
     & 391,0.162,  0, 59,388,  0,  0,  0,
     & 391,0.071,  0, 59,231,  0,  0,  0,
     & 391,0.615,  0, 13, 13,  0,  0,  0,
     & 391,0.024,  0,121,127,  0,  0,  0,
     & 391,0.024,  0,123,129,  0,  0,  0,
     & 391,0.024,  0,125,131,  0,  0,  0,
     & 391,0.008,  0,  1,  7,  0,  0,  0,
     & 391,0.032,  0,  2,  8,  0,  0,  0,
     & 391,0.008,  0,  3,  9,  0,  0,  0,
     & 391,0.032,  0,  4, 10,  0,  0,  0,
     & 392,0.034,  0,267, 38, 30,  0,  0,
     & 392,0.017,  0,267, 21, 21,  0,  0,
     & 392,0.044,  0,231, 38, 30,  0,  0,
     & 392,0.022,  0,231, 21, 21,  0,  0,
     & 392,0.050,  0,267, 59, 59,  0,  0,
     & 392,0.114,  0, 59,389,  0,  0,  0/
      DATA (IDK(I),BRFRAC(I),NME(I),(IDKPRD(J,I),J=1,5),I=2205,2223)/
     & 392,0.113,  0, 59,390,  0,  0,  0,
     & 392,0.054,  0, 59,391,  0,  0,  0,
     & 392,0.403,130, 13, 13, 13,  0,  0,
     & 392,0.021,130, 13, 13, 59,  0,  0,
     & 392,0.020,  0,121,127,  0,  0,  0,
     & 392,0.020,  0,123,129,  0,  0,  0,
     & 392,0.020,  0,125,131,  0,  0,  0,
     & 392,0.007,  0,  1,  7,  0,  0,  0,
     & 392,0.027,  0,  2,  8,  0,  0,  0,
     & 392,0.007,  0,  3,  9,  0,  0,  0,
     & 392,0.027,  0,  4, 10,  0,  0,  0,
     & 393,0.250,  0,246,222,  0,  0,  0,
     & 393,0.250,  0,245,221,  0,  0,  0,
     & 393,0.385,130, 13, 13, 13,  0,  0,
     & 393,0.020,130, 13, 13, 59,  0,  0,
     & 393,0.015,  0,121,127,  0,  0,  0,
     & 393,0.015,  0,123,129,  0,  0,  0,
     & 393,0.015,  0,125,131,  0,  0,  0,
     & 393,0.005,  0,  1,  7,  0,  0,  0/
      DATA (IDK(I),BRFRAC(I),NME(I),(IDKPRD(J,I),J=1,5),I=2224,2242)/
     & 393,0.020,  0,  2,  8,  0,  0,  0,
     & 393,0.005,  0,  3,  9,  0,  0,  0,
     & 393,0.020,  0,  4, 10,  0,  0,  0,
     & 395,0.195,  0, 39, 30,  0,  0,  0,
     & 395,0.195,  0, 23, 21,  0,  0,  0,
     & 395,0.195,  0, 31, 38,  0,  0,  0,
     & 395,0.105,  0,286, 30,  0,  0,  0,
     & 395,0.105,  0,285, 21,  0,  0,  0,
     & 395,0.105,  0,287, 38,  0,  0,  0,
     & 395,0.065,  0, 24, 38, 30,  0,  0,
     & 395,0.035,  0, 24, 21, 21,  0,  0,
     & 396,0.320,  0, 46, 34,  0,  0,  0,
     & 396,0.320,  0, 60, 61,  0,  0,  0,
     & 396,0.090,  0, 46, 35,  0,  0,  0,
     & 396,0.090,  0, 42, 51,  0,  0,  0,
     & 396,0.090,  0, 50, 43,  0,  0,  0,
     & 396,0.090,  0, 34, 47,  0,  0,  0,
     & 397,0.312,  0, 41, 30,  0,  0,  0,
     & 397,0.312,  0, 29, 21,  0,  0,  0/
      DATA (IDK(I),BRFRAC(I),NME(I),(IDKPRD(J,I),J=1,5),I=2243,2261)/
     & 397,0.312,  0, 33, 38,  0,  0,  0,
     & 397,0.016,  0, 46, 35,  0,  0,  0,
     & 397,0.016,  0, 42, 51,  0,  0,  0,
     & 397,0.016,  0, 50, 43,  0,  0,  0,
     & 397,0.016,  0, 34, 47,  0,  0,  0,
     & 398,0.805,  0, 26, 22,  0,  0,  0,
     & 398,0.065,  0, 41, 30,  0,  0,  0,
     & 398,0.065,  0, 29, 21,  0,  0,  0,
     & 398,0.065,  0, 33, 38,  0,  0,  0,
     & 399,0.667,  0, 24, 38, 30,  0,  0,
     & 399,0.333,  0, 24, 21, 21,  0,  0,
     &  62,0.440,  0, 21, 22,  0,  0,  0,
     &  62,0.160,  0, 21, 25,  0,  0,  0,
     &  62,0.200,  0, 50, 42,  0,  0,  0,
     &  62,0.200,  0, 46, 34,  0,  0,  0,
     &  63,0.440,  0, 38, 22,  0,  0,  0,
     &  63,0.160,  0, 38, 25,  0,  0,  0,
     &  63,0.400,  0, 46, 42,  0,  0,  0,
     &  64,0.440,  0, 30, 22,  0,  0,  0/
      DATA (IDK(I),BRFRAC(I),NME(I),(IDKPRD(J,I),J=1,5),I=2262,2263)/
     &  64,0.160,  0, 30, 25,  0,  0,  0,
     &  64,0.400,  0, 50, 34,  0,  0,  0/
      END
CDECK  ID>, HWUDKL.
*CMZ :-        -27/07/99  13.33.03  by  Mike Seymour
*-- Author :    Ian Knowles
C-----------------------------------------------------------------------
      SUBROUTINE HWUDKL(ID,PMOM,DISP)
C-----------------------------------------------------------------------
C     Given a real or virtual particle, flavour ID and 4-momentum PMOM,
C     returns DISP its distance travelled in mm.
C
C     Modified 16/01/01 by BRW to force particle on mass shell if
C     p^2-m^2 < 10^-10 GeV^2 (rounding errors)
C-----------------------------------------------------------------------
      INCLUDE 'HERWIG62.INC'
      DOUBLE PRECISION HWRGEN,PMOM(4),DISP(4),PMOM2,SCALE,OFFSH
      INTEGER ID
      EXTERNAL HWRGEN
      PMOM2=(PMOM(4)+PMOM(3))*(PMOM(4)-PMOM(3))-PMOM(1)**2-PMOM(2)**2
      OFFSH=PMOM2-RMASS(ID)**2
      IF (OFFSH.LT.1D-10) OFFSH=ZERO
      SCALE=-GEV2MM*LOG(HWRGEN(0))/SQRT(OFFSH**2+(PMOM2/DKLTM(ID))**2)
      IF (ID.GT.197.AND.ID.LT.203) SCALE=SCALE*EXAG
      CALL HWVSCA(4,SCALE,PMOM,DISP)
      END
CDECK  ID>, HWUDKS.
*CMZ :-        -27/07/99  13.33.03  by  Mike Seymour
*-- Author :    Ian Knowles
C-----------------------------------------------------------------------
      SUBROUTINE HWUDKS
C-----------------------------------------------------------------------
C     Sets up internal pointers based on the decay table in HWUDAT or as
C     supplied via HWIODK. Computes CoM momenta of two-body decay modes.
C     Particles with long lifetimes or no allowed decay (excepting light
C     b hadrons when CLEO/EURODEC decays requested) are set stable, else
C     calculate DKLTM(I) = mass/width ( = mass * lifetime/hbar).
C     Gives warnings if: a particle has no decay modes or antiparticle's
C     modes are not the charge conjugates of the particles.
C     (N.B. CP violation permits this).
C-----------------------------------------------------------------------
      INCLUDE 'HERWIG62.INC'
      DOUBLE PRECISION HWUPCM,HWUAEM,HWUALF,BRSUM,EPS,SCALE,
     & BRTMP(NMXDKS),FN,X,W,Q,FAC
      INTEGER HWUANT,I,IDKY,LAST,LTMP(NMXMOD),J,L,K,M,N,INDX(NMXMOD),
     & IRES,IAPDG,IPART,LR,LP,KPRDLR
      LOGICAL BPDK,TOPDKS,MATCH(5),PMATCH(NMXMOD)
      CHARACTER*7 CVETO(2)
      CHARACTER*8 CDUM
      EXTERNAL HWUPCM,HWUAEM,HWUALF,HWUANT
      PARAMETER(EPS=1.E-6)
      FN(X,Q,W)=X**4/(((X*X-Q*Q)**2+W*W*(X*X+Q*Q)-2.*W**4)
     &               *SQRT(X**4+Q**4+W**4-2.*(X*X*Q*Q+X*X*W*W+Q*Q*W*W)))
      WRITE(6,10)
  10  FORMAT(/10X,'Checking consistency of decay tables'/)
      DKPSET=.TRUE.
C First zero arrays
      DO 20 I=1,NMXRES
      LSTRT(I)=0
  20  NMODES(I)=0
      DO 30 I=1,NMXDKS
      NPRODS(I)=0
      LNEXT(I)=0
  30  CMMOM(I)=0
      BPDK=BDECAY.NE.'HERW'
      DO 180 I=1,NDKYS
C Search for next decaying particle type
      IDKY=IDK(I)
C Skip if particle is not recognised or already dealt with
      IF (IDKY.EQ.0.OR.IDKY.EQ.20) THEN
        WRITE(6,40) I
  40    FORMAT(1X,'Line ',I4,': decaying particle not recognised')
        GOTO 180
      ENDIF
      IF (NMODES(IDKY).GT.0) GOTO 180
C Check and include first decay mode, storing a copy
      CALL HWDCHK(IDKY,I,*180)
      LSTRT(IDKY)=I
      NMODES(IDKY)=1
      BRSUM=BRFRAC(I)
      LTMP(1)=I
      BRTMP(1)=-BRFRAC(I)
      LAST=I
C Sets CMMOM(IDKY) = CoM momentum for first 2-body decay mode I (else 0)
      IF (NPRODS(I).EQ.2) CMMOM(I)=
     & HWUPCM(RMASS(IDKY),RMASS(IDKPRD(1,I)),RMASS(IDKPRD(2,I)))
C Include any other decay modes of IDKY
      DO 120 J=I+1,NDKYS
      IF (IDK(J).EQ.IDKY) THEN
C First see if it is a copy of the same decay channel
        IF ((IDKPRD(2,J).GE.1.AND.IDKPRD(2,J).LE.13).OR.
     &      (IDKPRD(3,J).GE.1.AND.IDKPRD(3,J).LE.13)) THEN
C Partonic respect order
          L=LSTRT(IDKY)
          DO 50 K=1,NMODES(IDKY)
              IF (IDKPRD(1,L).EQ.IDKPRD(1,J).AND.
     &            IDKPRD(2,L).EQ.IDKPRD(2,J).AND.
     &            IDKPRD(3,L).EQ.IDKPRD(3,J).AND.
     &            IDKPRD(4,L).EQ.IDKPRD(4,J).AND.
     &            IDKPRD(5,L).EQ.IDKPRD(5,J)) GOTO 100
  50      L=LNEXT(L)
        ELSE
C Allow for different order in matching
          L=LSTRT(IDKY)
          DO 90 K=1,NMODES(IDKY)
          DO 60 M=1,5
  60      MATCH(M)=.FALSE.
          DO 80 M=1,5
          DO 70 N=1,5
          IF (.NOT.MATCH(N).AND.IDKPRD(N,L).EQ.IDKPRD(M,J)) THEN
            MATCH(N)=.TRUE.
            GOTO 80
          ENDIF
  70      CONTINUE
  80      CONTINUE
          IF (MATCH(1).AND.MATCH(2).AND.MATCH(3).AND.
     &        MATCH(4).AND.MATCH(5)) GOTO 100
  90      L=LNEXT(L)
        ENDIF
        CALL HWDCHK(IDKY,J,*120)
        NMODES(IDKY)=NMODES(IDKY)+1
        IF (NMODES(IDKY).GT.NMXMOD) CALL HWWARN('HWUDKS',100,*999)
        LNEXT(LAST)=J
        BRSUM=BRSUM+BRFRAC(J)
        LTMP(NMODES(IDKY))=J
        BRTMP(NMODES(IDKY))=-BRFRAC(J)
        LAST=J
C Sets CMMOM(IDKY) = CoM momentum for next 2-body decay mode J (else 0)
        IF (NPRODS(J).EQ.2) CMMOM(J)=
     &   HWUPCM(RMASS(IDKY),RMASS(IDKPRD(1,J)),RMASS(IDKPRD(2,J)))
      ENDIF
      GOTO 120
  100 WRITE(6,110) L,J,BRFRAC(J),NME(J)
      BRSUM=BRSUM-BRFRAC(L)+BRFRAC(J)
      BRFRAC(L)=BRFRAC(J)
      BRTMP(L)=-BRFRAC(L)
      NME(L)=NME(J)
  110 FORMAT(1X,'Line ',I4,' is the same as line ',I4/
     &       1X,'Take BR ',F5.3,' and ME code ',I3,' from second entry')
  120 CONTINUE
C Set sum of branching ratios to 1. if necessary
      IF (ABS(BRSUM-1.).GT.EPS) THEN
        WRITE(6,130) RNAME(IDKY),BRSUM
  130   FORMAT(1X,A8,': BR sum =',F8.5)
        IF (ABS(BRSUM).LT.EPS) THEN
          WRITE(6,140)
  140     FORMAT(1X,'Setting particle stable'/)
          NMODES(IDKY)=0
        ELSE
          WRITE(6,150)
  150     FORMAT(1X,'Rescaling to 1'/)
          SCALE=1./BRSUM
          K=LSTRT(IDKY)
          DO 160 J=1,NMODES(IDKY)
          BRFRAC(K)=SCALE*BRFRAC(K)
  160     K=LNEXT(K)
        ENDIF
      ENDIF
C Sort branching ratios into descending order and rearrange pointers
      CALL HWUSOR(BRTMP,NMODES(IDKY),INDX,2)
      LSTRT(IDKY)=LTMP(INDX(1))
      LNEXT(LTMP(INDX(1)))=LTMP(INDX(1))
      DO 170 J=2,NMODES(IDKY)
      IF (ABS(BRFRAC(LTMP(INDX(J)))).LT.EPS) THEN
        NMODES(IDKY)=J-1
        GOTO 175
      ENDIF
  170 LNEXT(LTMP(INDX(J-1)))=LTMP(INDX(J))
  175 LNEXT(LTMP(INDX(NMODES(IDKY))))=LTMP(INDX(NMODES(IDKY)))
  180 CONTINUE
C If not a short lived particle with a decay mode then set stable
      DO 190 I=1,NRES
      IF (.NOT.RSTAB(I).AND.RLTIM(I).LT.PLTCUT.AND.
     &    (NMODES(I).GT.0.OR.
     &     (BPDK.AND.((I.GE.221.AND.I.LE.231).OR.
     &                (I.GE.245.AND.I.LE.254))))) THEN
        DKLTM(I)=RLTIM(I)*RMASS(I)/HBAR
      ELSE
        RSTAB(I)=.TRUE.
      ENDIF
  190 CONTINUE
C Set up DKLTM for light quarks
      DO 200 I=1,5
      DKLTM(I)=RMASS(I)**2/VMIN2
  200 DKLTM(I+6)=DKLTM(I)
C gluon
      DKLTM(13)=RMASS(13)**2/VMIN2
C and diquarks
      DO 210 I=109,114
      DKLTM(I)=RMASS(I)**2/VMIN2
  210 DKLTM(I+6)=DKLTM(I)
C Set up DKLTM for weak bosons
      DKLTM(198)=RMASS(198)/GAMW
      DKLTM(199)=DKLTM(198)
      DKLTM(200)=RMASS(200)/GAMZ
      DKLTM(201)=RMASS(201)/GAMH
      DKLTM(202)=RMASS(202)/GAMZP
C Set up DKTRM for massive quarks (plus check m_Q > M_W + m_q)
      FAC=SWEIN*(FOUR*RMASS(198))**2/HWUAEM(RMASS(198)**2)
      IF (.NOT.SUSYIN) THEN
        IF (RMASS(6).GT.RMASS(5)+RMASS(198)) THEN
          DKLTM(6)=FAC*FN(RMASS(6  ),RMASS(5  ),RMASS(198))
     &            /(1-HWUALF(1,RMASS(6))*2*(2*PIFAC**2/3-5/2)/(3*PIFAC))
          DKLTM(12)=DKLTM(6)
        ELSE
          WRITE(6,220) RNAME(6),RNAME(5),RNAME(198)
        ENDIF
      ENDIF
      IF (RMASS(209).GT.RMASS(4)+RMASS(198)) THEN
        DKLTM(209)=FAC*FN(RMASS(209),RMASS(4  ),RMASS(198))
        DKLTM(215)=DKLTM(209)
      ELSE
        WRITE(6,220) RNAME(209),RNAME(4),RNAME(198)
      ENDIF
      IF (RMASS(210).GT.RMASS(209)+RMASS(198)) THEN
        DKLTM(210)=FAC*FN(RMASS(210),RMASS(209),RMASS(198))
        DKLTM(216)=DKLTM(210)
      ELSE
        WRITE(6,220) RNAME(210),RNAME(209),RNAME(198)
      ENDIF
      IF (RMASS(211).GT.RMASS(6)+RMASS(198)) THEN
        DKLTM(211)=FAC*FN(RMASS(211),RMASS(6  ),RMASS(198))
        DKLTM(217)=DKLTM(211)
      ELSE
        WRITE(6,220) RNAME(211),RNAME(6),RNAME(198)
      ENDIF
      IF (RMASS(212).GT.RMASS(211)+RMASS(198)) THEN
        DKLTM(212)=FAC*FN(RMASS(212),RMASS(211),RMASS(198))
        DKLTM(218)=DKLTM(212)
      ELSE
        WRITE(6,220) RNAME(212),RNAME(211),RNAME(198)
      ENDIF
 220  FORMAT(1X,'W not real in the decay: ',A8,' --> ',A8,' + ',A8)
C Now carry out diagnostic checks on decay table
      CALL HWDTOP(TOPDKS)
      DO 310 IRES=1,NRES
      IAPDG=ABS(IDPDG(IRES))
C Do not check (di-)quarks, gauge bosons, higgses or special particles
      IF ((IAPDG.GE.1.AND.IAPDG.LE.9).OR.
     &    (MOD(IAPDG/10,10).EQ.0.AND.MOD(IAPDG/1000,10).NE.0).OR.
     &    (IAPDG.GE.21.AND.IAPDG.LE.26).OR.
     &    IAPDG.EQ.32.OR.
     &    (IAPDG.GE.35.AND.IAPDG.LE.37).OR.
     &    IAPDG.EQ.91.OR.
     &    IAPDG.EQ.98.OR.IAPDG.EQ.99) THEN
        GOTO 310
C Ignore top hadrons if top decays
      ELSEIF(TOPDKS.AND.((IRES.GE.232.AND.IRES.LE.244).OR.
     &                   (IRES.GE.255.AND.IRES.LE.264))) THEN
        GOTO 310
C Ignore particles not produced in cluster or particle decays
      ELSEIF(VTOCDK(IRES).AND.VTORDK(IRES)) THEN
        GOTO 310
C Ignore B's if EURO or CLEO decay package used
      ELSEIF(((IRES.GE.221.AND.IRES.LE.223).OR.
     &        (IRES.GE.245.AND.IRES.LE.247)).AND.BDECAY.NE.'HERW') THEN
        WRITE(6,320) BDECAY,RNAME(IRES)
C Check decay modes exist for massive, short lived particles
      ELSEIF (NMODES(IRES).EQ.0.AND.RMASS(IRES).NE.ZERO.AND.
     &        RLTIM(IRES).LT.PLTCUT) THEN
        IF (VTOCDK(IRES)) THEN
          CVETO(1)='VETOED '
        ELSE
          CVETO(1)='ALLOWED'
        ENDIF
        IF (VTORDK(IRES)) THEN
          CVETO(2)='VETOED '
        ELSE
          CVETO(2)='ALLOWED'
        ENDIF
        WRITE(6,330) RNAME(IRES),CVETO(1),CVETO(2)
C ignore particles with no modes if massless or long lived
      ELSEIF (NMODES(IRES).EQ.0.AND.
     &        (RMASS(IRES).EQ.ZERO.OR.RLTIM(IRES).GT.PLTCUT)) THEN
        GOTO 310
      ELSEIF (IDPDG(IRES).LT.0) THEN
C Antiparticle: check decays are charge conjugates of particle decays
        CALL HWUIDT(1,-IDPDG(IRES),IPART,CDUM)
        IF (NMODES(IPART).EQ.0) THEN
C Nothing to compare to
          WRITE(6,340) RNAME(IPART),RNAME(IRES)
        ELSE
C First initialize particle matching array
          DO 230 I=1,NMODES(IPART)
  230     PMATCH(I)=.FALSE.
C Loop through antiparticle decay modes
          LR=LSTRT(IRES)
          DO 290 I=1,NMODES(IRES)
C Search for conjugate mode allowing for different particle order
          LP=LSTRT(IPART)
          DO 270 J=1,NMODES(IPART)
          IF (PMATCH(J)) GOTO 270
          DO 240 K=1,5
  240     MATCH(K)=.FALSE.
          DO 260 K=1,5
          KPRDLR=HWUANT(IDKPRD(K,LR))
          DO 250 L=1,5
          IF (.NOT.MATCH(L).AND.KPRDLR.EQ.IDKPRD(L,LP) ) THEN
            MATCH(L)=.TRUE.
            GOTO 260
          ENDIF
  250     CONTINUE
  260     CONTINUE
          IF (MATCH(1).AND.MATCH(2).AND.MATCH(3).AND.
     &        MATCH(4).AND.MATCH(5)) GOTO 280
  270     LP=LNEXT(LP)
C No match found
          WRITE(6,350) LR,RNAME(IRES),(RNAME(IDKPRD(J,LR)),J=1,5)
          GOTO 290
C Match found, check branching ratios and matrix element codes
  280     PMATCH(J)=.TRUE.
          IF (BRFRAC(LR).NE.BRFRAC(LP))
     &     WRITE(6,360) LR,RNAME(IRES),(RNAME(IDKPRD(J,LR)),J=1,5),
     &                  BRFRAC(LR),BRFRAC(LP)
          IF (NME(LR).NE.NME(LP))
     &     WRITE(6,370) LR,RNAME(IRES),(RNAME(IDKPRD(J,LR)),J=1,5),
     &                  NME(LR),NME(LP)
  290     LR=LNEXT(LR)
C Check for unmatched modes of particle conjugate to antiparticle
          LP=LSTRT(IPART)
          DO 300 I=1,NMODES(IPART)
          IF (.NOT.PMATCH(I))
     &     WRITE(6,350) LP,RNAME(IPART),(RNAME(IDKPRD(J,LP)),J=1,5)
  300     LP=LNEXT(LP)
        ENDIF
      ENDIF
  310 CONTINUE
  320 FORMAT(1X,A8,' decay package to be used for particle ',A8)
  330 FORMAT(1X,'No decay modes available for particle ',A8/
     & 1X,'Production in cluster decays ',A7,' and particle decays ',A7)
  340 FORMAT(1X,A8,' has no modes conjugate to those of ',A8)
  350 FORMAT(1X,'Line, ',I4,' decay: ',A8,' --> ',4(A8,1X),A8/
     &       1X,'A charge conjugate decay mode does not exist')
  360 FORMAT(1X,'Line, ',I4,' decay: ',A8,' --> ',4(A8,1X),A8/
     &       1X,'BR ',F5.3,' unequal to that of conjugate mode ',F5.3)
  370 FORMAT(1X,'Line, ',I4,' decay: ',A8,' --> ',4(A8,1X),A8/
     &       1X,'ME code ',I3,' unequal to that of conjugate mode ',I3)
  999 RETURN
      END
CDECK  ID>, HWUDPR.
*CMZ :-        -27/07/99  13.33.03  by  Mike Seymour
*-- Author :    Ian Knowles, Bryan Webber & Kosuke Odagiri
C-----------------------------------------------------------------------
      SUBROUTINE HWUDPR
C-----------------------------------------------------------------------
C     Prints out particle properies/decay tables in a number of formats:
C     If (PRNDEF) ASCII to stout
C     If (PRNTEX) LaTeX to the file HW_decays.tex
C                 Paper size and offsets as set in HWUEPR
C                 Uses the package longtable.sty
C                 Designed to be printed as landscape
C     If (PRNWEB) HTML  to the file HW_decays/index.html
C                                            /PART0000001.html etc.
C-----------------------------------------------------------------------
      INCLUDE 'HERWIG62.INC'
      INTEGER MMWIDE,MMLONG,MMHOFF,MMVOFF,IUNITT,IUNTW1,IUNTW2,I,NM,J,K,
     & L,M
      CHARACTER*1  Z
      CHARACTER*2  ZZ,ACHRG
      CHARACTER*3  ASPIN(0:10)
      CHARACTER*6  BGCOLS(5),TBCOLS(3)
      CHARACTER*7  HWUNST,TMPNME
      CHARACTER*17 FNAMEP
      CHARACTER*33 FNAMEW
      COMMON/PAPER/MMWIDE,MMLONG,MMHOFF,MMVOFF
      EXTERNAL HWUNST
      DATA BGCOLS/'ffffff','0000aa','aa0000','00aa00','aa00ff'/
      DATA TBCOLS/'ccccff','9966ff','ffff00'/
      DATA ASPIN/' 0 ','1/2',' 1 ','3/2',' 2 ','5/2',' 3 ','7/2',
     &           ' 4 ','9/2',' 5 '/
C
      Z=CHAR(92)
      ZZ=Z//Z
C
      IUNITT=50
      IUNTW1=51
      IUNTW2=52
C Open and write out file header information for index file
      IF (PRNDEF) THEN
        IF (NPRFMT.LE.1) THEN
          WRITE (6,10) NRES
        ELSE
          WRITE (6,20) NRES
        END IF
      END IF
      IF (PRNTEX) THEN
        OPEN(IUNITT,STATUS='UNKNOWN',FILE='HW_decays.tex')
        IF (NPRFMT.LE.1) THEN
          WRITE(IUNITT,30) Z,Z,Z,MMWIDE,Z,MMLONG,Z,MMHOFF,Z,MMVOFF,
     &     Z,Z,Z,Z,Z,ZZ,Z,Z,Z,Z,Z,Z,NRES,ZZ,Z,Z,ZZ,Z,Z
        ELSE
          WRITE(IUNITT,40) Z,Z,Z,MMLONG,Z,MMWIDE,Z,MMHOFF,Z,MMVOFF,
     &     Z,Z,Z,Z,Z,Z,ZZ,Z,Z,Z,Z,Z,Z,NRES,ZZ,Z,Z,Z,ZZ,Z,Z
        END IF
      ENDIF
      IF (PRNWEB) THEN
        OPEN(IUNTW1,STATUS='UNKNOWN',FILE='HW_decays/index.html')
        WRITE(IUNTW1,50) BGCOLS,TBCOLS,NRES,((TBCOLS(I),I=2,3),J=1,7)
      ENDIF
   10 FORMAT(1H1//15X,'TABLE OF PROPERTIES OF',I4,' PARTICLES USED'/)
   20 FORMAT(1H1//30X,'TABLE OF PROPERTIES OF',I4,' PARTICLES USED'//
     & 5X,'Name        IDPDG   Mass   Chg Spn Lifetime Modes ',
     & ' Branching fractions ME codes and decay products')
   30 FORMAT(A1,'documentclass{article}'/A1,'usepackage{longtable}'/
     & A1,'textwidth ',I4,'mm ',A1,'textheight ',I4,'mm'/
     & A1,'hoffset   ',I4,'mm ',A1,'voffset    ',I4,'mm'/
     & A1,'pagestyle{empty}'/A1,'begin{document}'/
     & A1,'begin{center}'/A1,'begin{longtable}{|r|c|r|r|r|r|r|r|}'/
     & A1,'hline'/'Id HW & Name & Id PDG & Mass & Charge & Spin ',
     & '& Lifetime & Modes ',A2/A1,'hline'/
     & A1,'endhead'/A1,'hline'/A1,'endfoot'/A1,'hline'/
     & A1,'multicolumn{8}{|c|}{HERWIG 6.0: Table of properties',
     & ' of the ',I3,' particles used} ',A2/A1,'hline',A1,'hline'/
     & 'Id HW & Name & Id PDG & Mass & Charge & Spin & ',
     & 'Lifetime & Modes ',A2/A1,'hline'/A1,'endfirsthead')
   40 FORMAT(A1,'documentclass{article}'/A1,'usepackage{longtable}'/
     & A1,'textwidth ',I4,'mm ',A1,'textheight ',I4,'mm'/
     & A1,'hoffset   ',I4,'mm ',A1,'voffset    ',I4,'mm'/
     & A1,'pagestyle{empty}'/A1,'begin{document}'/A1,'begin{center}'/
     & A1,'begin{longtable}{|r|c|r|r|r|r|r|r|c|r|ccccc|}'/
     & A1,'hline'/'Id HW & Name & Id PDG & Mass & Charge & Spin ',
     & '& Lifetime & Modes & B.R. & M.E. & ' /
     & A1,'multicolumn{5}{|c|}{Decay Products} ',A2/A1,'hline'/
     & A1,'endhead'/A1,'hline'/A1,'endfoot'/A1,'hline'/
     & A1,'multicolumn{15}{|c|}{HERWIG 6.0: Table of properties',
     & ' of the ',I3,' particles used} ',A2/A1,'hline',A1,'hline'/
     & 'Id HW & Name & Id PDG & Mass & Charge & Spin & ',
     & 'Lifetime & Modes & B.R. & M.E. & '/
     & A1,'multicolumn{5}{|c|}{Decay Products} ',A2/A1,'hline'/
     & A1,'endfirsthead')
   50 FORMAT('<!-- No Less productions -->'/'<HTML>'/'<HEAD>'/
     & '<TITLE>HERWIG 6.0 Particle Properties</TITLE>'/'</HEAD>'/
     & '<BODY BGCOLOR=#',A6,' TEXT=#',A6,' LINK=#',A6,
     & ' ALINK=#',A6,' VLINK=#',A6,'>'/'<CENTER>'/
     & '<TABLE ALIGN="CENTER" BGCOLOR=#',A6,'>',
     & '<TR>'/'<TH COLSPAN=8 BGCOLOR=#',A6,' ALIGN="CENTER">',
     & '<A HREF=="http://hepwww.rl.ac.uk/theory/seymour/herwig/">',
     & 'HERWIG 6.0:</A><FONT COLOR=#',A6,'> Table of properties of',
     & ' the ',I3,' particles used</FONT></TH>'/'<TR>'/'<TH></TH>'/
     & '<TH BGCOLOR=#',A6,'><FONT COLOR=#',A6,'>Name</FONT></TH>'/
     & '<TH BGCOLOR=#',A6,' ALIGN="CENTER"><FONT COLOR=#',A6,'>',
     & 'Id PDG</FONT></TH>'/
     & '<TH BGCOLOR=#',A6,'><FONT COLOR=#',A6,'>Mass</FONT></TH>'/
     & '<TH BGCOLOR=#',A6,'><FONT COLOR=#',A6,'>Charge</FONT></TH>'/
     & '<TH BGCOLOR=#',A6,'><FONT COLOR=#',A6,'>Spin</FONT></TH>'/
     & '<TH BGCOLOR=#',A6,'><FONT COLOR=#',A6,'>Lifetime</FONT></TH>'/
     & '<TH BGCOLOR=#',A6,'><FONT COLOR=#',A6,'>Modes</FONT></TH>'/
     & '</TR>')
C Loop through resonances
      DO 260 I=1,NRES
C Skip particles that can't be produced or blank lines
      IF ((VTOCDK(I).AND.VTORDK(I)).OR.
     &    (RNAME(I).EQ.'        ')) GOTO 260
C Open and write out header information for particle file
      IF (PRNWEB) THEN
        TMPNME = HWUNST(I)
        WRITE(FNAMEP,'(A5,A7,A5)') 'PART_',TMPNME,'.html'
        WRITE(FNAMEW,'(A,A17)') 'HW_decays/',FNAMEP
        OPEN(IUNTW2,STATUS='UNKNOWN',FILE=FNAMEW)
        WRITE(IUNTW2,60) RNAME(I),BGCOLS
        WRITE(IUNTW2,70) TBCOLS,((TBCOLS(L),L=2,3),M=1,6)
      ENDIF
   60 FORMAT('<!-- No Less productions -->'/'<HTML>'/'<HEAD>'/
     & '<TITLE>HERWIG 6.0: ',A8,' properties</TITLE>'/'</HEAD>'/
     & '<BODY BGCOLOR=#',A6,' TEXT=#',A6,' LINK=#',A6,
     & ' ALINK=#',A6,' VLINK=#',A6,'>'/'<CENTER>')
   70 FORMAT('<TABLE ALIGN="CENTER" BGCOLOR=#',A6,'>'/
     & '<TR>'/'<TH></TH>'/
     & '<TH BGCOLOR=#',A6,'><FONT COLOR=#',A6,'>Name</FONT></TH>'/
     & '<TH BGCOLOR=#',A6,' ALIGN="CENTER"><FONT COLOR=#',A6,
     & '>Id PDG</FONT></TH>'/
     & '<TH BGCOLOR=#',A6,'><FONT COLOR=#',A6,'>Mass</FONT></TH>'/
     & '<TH BGCOLOR=#',A6,'><FONT COLOR=#',A6,'>Charge</FONT></TH>'/
     & '<TH BGCOLOR=#',A6,'><FONT COLOR=#',A6,'>Spin</FONT></TH>'/
     & '<TH BGCOLOR=#',A6,'><FONT COLOR=#',A6,'>Lifetime</FONT></TH>'/
     & '<TH BGCOLOR=#',A6,'><FONT COLOR=#',A6,'>Modes</FONT></TH>'/
     & '</TR>')
C Trick to output charge in fractions for di/s - quarks
      IF ((I.GE.  1.AND.I.LE. 12).OR.(I.GE.109.AND.I.LE.120).OR.
     &    (I.GE.209.AND.I.LE.218).OR.(I.GE.401.AND.I.LE.424)) THEN
        ACHRG='/3'
      ELSE
        ACHRG='  '
      ENDIF
C Write out special particles with no decay modes
      IF (NMODES(I).EQ.0) THEN
        IF (PRNDEF) THEN
          IF (NPRFMT.LE.1) THEN
            WRITE(6,80) I,RNAME(I),IDPDG(I),RMASS(I),ICHRG(I),
     &                  ASPIN(INT(TWO*RSPIN(I))),RLTIM(I),0
          ELSE
            WRITE(6,90) I,RNAME(I),IDPDG(I),RMASS(I),ICHRG(I),
     &                  ASPIN(INT(TWO*RSPIN(I))),RLTIM(I),0
          ENDIF
        ENDIF
C Add particle to LaTeX file
        IF (PRNTEX) THEN
          IF (NPRFMT.LE.1) THEN
            WRITE(IUNITT,100) Z,I,TXNAME(1,I),IDPDG(I),RMASS(I),
     &       ICHRG(I),ACHRG,ASPIN(INT(TWO*RSPIN(I))),RLTIM(I),0,ZZ
          ELSE
            WRITE(IUNITT,110) Z,I,TXNAME(1,I),IDPDG(I),RMASS(I),
     &       ICHRG(I),ACHRG,ASPIN(INT(TWO*RSPIN(I))),RLTIM(I),0,Z,ZZ
          ENDIF
        ENDIF
        IF (PRNWEB) THEN
C Add properties to Web index
          WRITE(IUNTW1,120) TBCOLS(2),TBCOLS(3),I,FNAMEP,TXNAME(2,I),
     &                      IDPDG(I),RMASS(I),ICHRG(I),ACHRG,
     &                      ASPIN(INT(TWO*RSPIN(I))),RLTIM(I),0
C Add properties to Web particle file
          WRITE(IUNTW2,130) TBCOLS(2),TBCOLS(3),I,TXNAME(2,I),
     &                      IDPDG(I),RMASS(I),ICHRG(I),ACHRG,
     &                      ASPIN(INT(TWO*RSPIN(I))),RLTIM(I),0
        ENDIF
   80   FORMAT(/1X,I3,1X,A8,' IDPDG=',I8,', M=',F8.3,', Q=',I2,',  J=',
     &   A3,', T=',1P,E9.3,',',I3,' Modes')
   90   FORMAT(/1X,I3,1X,A8,1X,I8,1X,F8.3,1X,I2,1X,A3,1X,1P,E9.3,1X,I3)
  100   FORMAT(A1,'hline',I4,' & ',A37,' & $',I8,'$ & ',F8.3,' & $',I2,
     &   A2,'$ & ',A3,' & $',1P,E9.3,'$ & ',I3,' ',A2)
  110   FORMAT(A1,'cline{1-8}'/
     &   I4,' & ',A37,' & $',I8,'$ & ',F8.3,' & $',I2,A2,'$ & ',A3,
     &   ' & $',1P,E9.3,'$ & ',I3,' & ',A1,'multicolumn{7}{|c|}{} ',A2)
  120   FORMAT('<TR>'/
     &   '<TD ALIGN="RIGHT" BGCOLOR=#',A6,'><FONT COLOR=#',A6,'>',I3,
     &   '</FONT></TD>'/
     &   '<TD ALIGN="CENTER"><A HREF="',A17,'">',A37,'</A></TD>'/
     &   '<TD ALIGN="RIGHT">',I8,'</TD>'/
     &   '<TD ALIGN="RIGHT">',F8.3,'</TD>'/
     &   '<TD ALIGN="RIGHT">',I2,A2,'</TD>'/
     &   '<TD ALIGN="RIGHT">',A3,'</TD>'/
     &   '<TD ALIGN="RIGHT">',1P,E9.3,'</TD>'/
     &   '<TD ALIGN="RIGHT">',I3,'</TD>'/'</TR>')
  130   FORMAT('<TR>'/
     &   '<TD ALIGN="RIGHT" BGCOLOR=#',A6,'><FONT COLOR=#',A6,'>',I3,
     &   '</FONT></TD>'/
     &   '<TD ALIGN="CENTER">',A37,'</TD>'/
     &   '<TD ALIGN="RIGHT">',I8,'</TD>'/
     &   '<TD ALIGN="RIGHT">',F8.3,'</TD>'/
     &   '<TD ALIGN="RIGHT">',I2,A2,'</TD>'/
     &   '<TD ALIGN="RIGHT">',A3,'</TD>'/
     &   '<TD ALIGN="RIGHT">',1P,E9.3,'</TD>'/
     &   '<TD ALIGN="RIGHT">',I3,'</TD>'/'</TR>'/'</TABLE>'/'<P>')
      ELSE
C Particle with decay modes
        IF (RSTAB(I)) THEN
          NM=0
        ELSEIF (VTOCDK(I)) THEN
          NM=-NMODES(I)
        ELSE
          NM=NMODES(I)
        ENDIF
        K=LSTRT(I)
C Write out properties and first decay mode
        IF (PRNDEF) THEN
          IF (NPRFMT.LE.1) THEN
            WRITE(6, 80) I,RNAME(I),IDPDG(I),RMASS(I),ICHRG(I),
     &       ASPIN(INT(TWO*RSPIN(I))),RLTIM(I),NM
            WRITE(6,140) (RNAME(IDKPRD(L,K)),L=1,5),BRFRAC(K),NME(K)
          ELSE
            WRITE(6,150) I,RNAME(I),IDPDG(I),RMASS(I),ICHRG(I),
     &       ASPIN(INT(TWO*RSPIN(I))),RLTIM(I),NM,BRFRAC(K),NME(K),
     &       (RNAME(IDKPRD(L,K)),L=1,5)
          ENDIF
        ENDIF
        IF (PRNTEX) THEN
          IF (NPRFMT.LE.1) THEN
            WRITE(IUNITT,160) Z,I,TXNAME(1,I),IDPDG(I),RMASS(I),
     &       ICHRG(I),ACHRG,ASPIN(INT(TWO*RSPIN(I))),RLTIM(I),NM,ZZ,Z
            WRITE(IUNITT,170) Z,Z,(TXNAME(1,IDKPRD(L,K)),L=1,5),Z,
     &       BRFRAC(K),Z,NME(K),ZZ
          ELSE
            WRITE(IUNITT,180) Z,I,TXNAME(1,I),IDPDG(I),RMASS(I),
     &       ICHRG(I),ACHRG,ASPIN(INT(TWO*RSPIN(I))),RLTIM(I),NM,
     &       BRFRAC(K),NME(K),(TXNAME(1,IDKPRD(L,K)),L=1,5),ZZ,Z
          ENDIF
        END IF
        IF (PRNWEB) THEN
C Add properties to index
          WRITE(IUNTW1,120) TBCOLS(2),TBCOLS(3),I,FNAMEP,TXNAME(2,I),
     &     IDPDG(I),RMASS(I),ICHRG(I),ACHRG,ASPIN(INT(TWO*RSPIN(I))),
     &     RLTIM(I),NM
C Add properties to Web particle file
          WRITE(IUNTW2,130) TBCOLS(2),TBCOLS(3),I,TXNAME(2,I),IDPDG(I),
     &     RMASS(I),ICHRG(I),ACHRG,ASPIN(INT(TWO*RSPIN(I))),RLTIM(I),NM
          WRITE(IUNTW2,190) TBCOLS,TXNAME(2,I),
     &     ((TBCOLS(L),L=2,3),M=1,3)
          WRITE(IUNTW2,200) TBCOLS(2),TBCOLS(3),1,BRFRAC(K),NME(K),
     &     (TXNAME(2,IDKPRD(L,K)),L=1,5)
        ENDIF
  140   FORMAT(5X,'BR[ -->',5(1X,A6),']=',F5.3,', ME code',I4)
  150   FORMAT(/1X,I3,1X,A8,1X,I8,1X,F8.3,1X,I2,1X,A3,1X,1P,E9.3,1X,I3,
     &   2X,F5.3,1X,I3,5(1X,A8))
  160   FORMAT(A1,'hline',
     &   I4,' & ',A37,' & $',I8,'$ & ',F8.3,' & $',I2,A2,'$ & ',
     &   A3,' & $',1P,E9.3,'$ & ',I3,' ',A2/A1,'cline{2-8}')
  170   FORMAT(' & & ',A1,'multicolumn{2}{l}{$',A1,'longrightarrow$'/
     &   5(A37,' '),'}'/' & ',A1,'multicolumn{2}{l}{BR = ',F5.3,'} & ',
     &   A1,'multicolumn{2}{l|}{ME code = ',I3,'} ',A2)
  180   FORMAT(A1,'hline'/
     &   I4,' & ',A37,' & $',I8,'$ & ',F8.3,' & $',I2,A2,'$ & ',
     &   A3,' & $',1P,E9.3,'$ & ',I3,' & ',F5.3,' & ',I3,
     &   5(' & ',A37), ' ',A2/A1,'cline{2-8}')
  190   FORMAT('<TABLE ALIGN="CENTER" BGCOLOR=#',A6,'>'/'<TR>'/
     &   '<TH COLSPAN=8 BGCOLOR=#',A6,'><FONT COLOR=#',A6,'>',A37,
     &   ' Decay Modes</FONT></TH>'/'</TR>'/'<TR>'/'<TH></TH>',
     &   '<TH BGCOLOR=#',A6,'><FONT COLOR=#',A6,'>B.R.</FONT></TH>'/
     &   '<TH BGCOLOR=#',A6,'><FONT COLOR=#',A6,'>M.E.</FONT></TH>'/
     &   '<TH BGCOLOR=#',A6,' ALIGN="CENTER" COLSPAN=5>',
     &   '<FONT COLOR=#',A6,'>Decay products</FONT></TH>'/'</TR>')
  200   FORMAT('<TR>'/
     &   '<TD ALIGN="RIGHT" BGCOLOR=#',A6,'><FONT COLOR=#',A6,'>',
     &   I3,'</FONT></TD>'/
     &   '<TD ALIGN="RIGHT">',F5.3,'</TD>'/
     &   '<TD ALIGN="RIGHT">',I3,'</TD>'/
     &   5('<TD ALIGN="CENTER">',A37,'</TD>'/),'</TR>')
C Write out additional decay modes
        IF (NMODES(I).GE.2) THEN
          DO 210 J=2,NMODES(I)
          K=LNEXT(K)
          IF (PRNDEF) THEN
            IF (NPRFMT.LE.1) THEN
              WRITE(6,140) (RNAME(IDKPRD(L,K)),L=1,5),BRFRAC(K),NME(K)
            ELSE
              WRITE(6,220) BRFRAC(K),NME(K),(RNAME(IDKPRD(L,K)),L=1,5)
            END IF
          END IF
          IF (PRNTEX) THEN
            IF (NPRFMT.LE.1) THEN
              WRITE(IUNITT,170) Z,Z,(TXNAME(1,IDKPRD(L,K)),L=1,5),Z,
     &         BRFRAC(K),Z,NME(K),ZZ
            ELSE
              WRITE(IUNITT,230) Z,BRFRAC(K),NME(K),
     &         (TXNAME(1,IDKPRD(L,K)),L=1,5),ZZ
            ENDIF
          ENDIF
          IF (PRNWEB) WRITE(IUNTW2,200) TBCOLS(2),TBCOLS(3),J,
     &     BRFRAC(K),NME(K),(TXNAME(2,IDKPRD(L,K)),L=1,5)
  210     CONTINUE
          IF (PRNTEX.AND.NPRFMT.EQ.2.AND.NMODES(I+1).EQ.0)
     &     WRITE(IUNITT,240) Z
  220     FORMAT(54X,F5.3,1X,I3,5(1X,A8))
  230     FORMAT(' & ',A1,'multicolumn{7}{|c|}{} & ',F5.3,' & ',I3,
     &     5(' & ',A37),' ',A2)
  240     FORMAT(A1,'hline')
        ENDIF
      ENDIF
C Close Web particle file
      IF (PRNWEB) THEN
        WRITE(IUNTW2,250)
        CLOSE(IUNTW2)
      ENDIF
  250 FORMAT('</TABLE>'/'</CENTER>'/'<P>'/
     & 'Main particle <A HREF="index.html">index</A>'/
     & '</BODY>'/'</HTML>')
  260 CONTINUE
C Close the LaTeX file
      IF (PRNTEX) THEN
        WRITE(IUNITT,270) Z,Z,Z
        CLOSE(IUNITT)
      ENDIF
C Close the index file
      IF (PRNWEB) THEN
        WRITE(IUNTW1,280)
        CLOSE(IUNTW1)
      ENDIF
  270 FORMAT(A1,'end{longtable}'/A1,'end{center}'/A1,'end{document}')
  280 FORMAT('</TABLE>'/'</CENTER>'/'</BODY>'/'</HTML>')
      RETURN
      END
CDECK  ID>, HWUECM.
*CMZ :-        -29/01/93  11.11.55  by  Bryan Webber
*-- Author :    Giovanni Abbiendi & Luca Stanco
C---------------------------------------------------------------------
      FUNCTION HWUECM (S,M1QUAD,M2QUAD)
C-----------------------------------------------------------------------
C     C.M. ENERGY OF A PARTICLE IN 1-->2 BRANCH, MAY BE SPACELIKE
C---------------------------------------------------------------------
      DOUBLE PRECISION HWUECM,S,M1QUAD,M2QUAD
      HWUECM = (S+M1QUAD-M2QUAD)/(2.D0*SQRT(S))
      END
CDECK  ID>, HWUEDT.
*CMZ :-        -09/12/91  12.07.08  by  Mike Seymour
*-- Author :    Mike Seymour
C-----------------------------------------------------------------------
      SUBROUTINE HWUEDT(N,IEDT)
C-----------------------------------------------------------------------
C     EDIT THE EVENT RECORD
C     IF N>0 DELETE THE N ENTRIES IN IEDT FROM EVENT RECORD
C     IF N<0 INSERT LINES AFTER THE -N ENTRIES IN IEDT
C-----------------------------------------------------------------------
      INCLUDE 'HERWIG62.INC'
      INTEGER N,IEDT(*),IMAP(0:NMXHEP),IHEP,I,J,I1,I2
      COMMON /HWUMAP/IMAP
C---MOVE ENTRIES AND CALCULATE MAPPING OF POINTERS
      IF (N.EQ.0) THEN
        RETURN
      ELSEIF (N.GT.0) THEN
        I=1
        I1=1
        I2=NHEP
      ELSE
        I=NHEP-N
        I1=NHEP
        I2=1
      ENDIF
      DO 110 IHEP=I1,I2,SIGN(1,I2-I1)
        IMAP(IHEP)=I
        DO 100 J=1,ABS(N)
          IF (IHEP.EQ.IEDT(J)) THEN
            IF (N.GT.0) IMAP(IHEP)=0
            I=I-1
            IF (N.LT.0) IMAP(IHEP)=I
          ENDIF
 100    CONTINUE
        IF (IMAP(IHEP).EQ.I .AND. IHEP.NE.I) THEN
          ISTHEP(I)=ISTHEP(IHEP)
          IDHW(I)=IDHW(IHEP)
          IDHEP(I)=IDHEP(IHEP)
          JMOHEP(1,I)=JMOHEP(1,IHEP)
          JMOHEP(2,I)=JMOHEP(2,IHEP)
          JDAHEP(1,I)=JDAHEP(1,IHEP)
          JDAHEP(2,I)=JDAHEP(2,IHEP)
          CALL HWVEQU(5,PHEP(1,IHEP),PHEP(1,I))
          CALL HWVEQU(4,VHEP(1,IHEP),VHEP(1,I))
          ISTHEP(IHEP)=0
          IDHW(IHEP)=20
          IDHEP(IHEP)=0
          JMOHEP(1,IHEP)=0
          JMOHEP(2,IHEP)=0
          JDAHEP(1,IHEP)=0
          JDAHEP(2,IHEP)=0
          CALL HWVZRO(5,PHEP(1,IHEP))
          CALL HWVZRO(4,VHEP(1,IHEP))
        ENDIF
        I=I+SIGN(1,N)
 110  CONTINUE
      NHEP=NHEP-N
C---RELABEL POINTERS, SETTING ANY WHICH WERE TO DELETED ENTRIES TO ZERO
      IMAP(0)=0
      DO 200 IHEP=1,NHEP
        JMOHEP(1,IHEP)=IMAP(JMOHEP(1,IHEP))
        JMOHEP(2,IHEP)=IMAP(JMOHEP(2,IHEP))
        JDAHEP(1,IHEP)=IMAP(JDAHEP(1,IHEP))
        JDAHEP(2,IHEP)=IMAP(JDAHEP(2,IHEP))
 200  CONTINUE
      END
CDECK  ID>, HWUEEC.
*CMZ :-        -26/04/91  14.22.30  by  Federico Carminati
*-- Author :    Bryan Webber and Ian Knowles
C-----------------------------------------------------------------------
      SUBROUTINE HWUEEC(IL)
C-----------------------------------------------------------------------
C     Loads cross-section coefficients, for kinematically open channels,
C     in llbar-->qqbar; lepton label IL=1-6: e,nu_e,mu,nu_mu,tau,nu_tau.
C-----------------------------------------------------------------------
      INCLUDE 'HERWIG62.INC'
      DOUBLE PRECISION Q2
      INTEGER IL,JL,IQ
      Q2=EMSCA**2
      JL=IL+10
      MAXFL=0
      TQWT=0.
      DO 10 IQ=1,NFLAV
      IF (EMSCA.GT.2.*RMASS(IQ)) THEN
         MAXFL=MAXFL+1
         MAPQ(MAXFL)=IQ
         CALL HWUCFF(JL,IQ,Q2,CLQ(1,MAXFL))
         TQWT=TQWT+CLQ(1,MAXFL)
      ENDIF
  10  CONTINUE
      IF (MAXFL.EQ.0) CALL HWWARN('HWUEEC',100,*999)
  999 END
CDECK  ID>, HWUEMV.
*CMZ :-        -30/06/94  19.31.08  by  Mike Seymour
*-- Author :    Mike Seymour
C-----------------------------------------------------------------------
      SUBROUTINE HWUEMV(N,IFROM,ITO)
C-----------------------------------------------------------------------
C     MOVE A BLOCK OF ENTRIES IN THE EVENT RECORD
C     N ENTRIES IN HEPEVT STARTING AT IFROM ARE MOVED TO AFTER ITO
C-----------------------------------------------------------------------
      INCLUDE 'HERWIG62.INC'
      INTEGER N,IFROM,ITO,IMAP(0:NMXHEP),LFROM,LTO,I,IEDT(NMXHEP),IHEP,
     $ JHEP,KHEP
      COMMON /HWUMAP/IMAP
      LFROM=IFROM
      LTO=ITO
      DO 100 I=1,N
 100  IEDT(I)=LTO
      CALL HWUEDT(-N,IEDT)
      DO 300 I=1,N
        IHEP=LTO+I
        JHEP=IMAP(LFROM+I-1)
        ISTHEP(IHEP)=ISTHEP(JHEP)
        IDHW(IHEP)=IDHW(JHEP)
        IDHEP(IHEP)=IDHEP(JHEP)
        JMOHEP(1,IHEP)=JMOHEP(1,JHEP)
        JMOHEP(2,IHEP)=JMOHEP(2,JHEP)
        JDAHEP(1,IHEP)=JDAHEP(1,JHEP)
        JDAHEP(2,IHEP)=JDAHEP(2,JHEP)
        CALL HWVEQU(5,PHEP(1,JHEP),PHEP(1,IHEP))
        CALL HWVEQU(4,VHEP(1,JHEP),VHEP(1,IHEP))
        DO 200 KHEP=1,NHEP
          IF (JMOHEP(1,KHEP).EQ.JHEP) JMOHEP(1,KHEP)=IHEP
          IF (JMOHEP(2,KHEP).EQ.JHEP) JMOHEP(2,KHEP)=IHEP
          IF (JDAHEP(1,KHEP).EQ.JHEP) JDAHEP(1,KHEP)=IHEP
          IF (JDAHEP(2,KHEP).EQ.JHEP) JDAHEP(2,KHEP)=IHEP
 200    CONTINUE
        IEDT(I)=JHEP
 300  CONTINUE
      CALL HWUEDT(N,IEDT)
 999  END
CDECK  ID>, HWUEPR.
*CMZ :-        -27/07/99  13.33.03  by  Mike Seymour
*-- Author :    Ian Knowles, Bryan Webber & Kosuke Odagiri
C-----------------------------------------------------------------------
      SUBROUTINE HWUEPR
C-----------------------------------------------------------------------
C     Prints out event data in a number of possible formats:
C     If (PRNDEF) ASCII to stout
C     If (PRNTEX) LaTeX to the file HWEV_*******.tex
C                 Please check paper size and offsets given in mm
C                 Uses the package longtable.sty
C                 If (PRVTX>OR.NPRFMT.EQ.2) designed to be printed
C                 as landscape
C     If (PRNWEB) HTML  to the file HWEV_*******.html
C                 Call HWUDPR to create particle property files in
C                 the subdirectory HW_decays/
C     ******* gives the event number 0000001 etc.
C-----------------------------------------------------------------------
      INCLUDE 'HERWIG62.INC'
      INTEGER MMWIDE,MMLONG,MMHOFF,MMVOFF,I,IST,IS,ID,MS,J,K,IUNITW,
     & IUNITT
      CHARACTER*1 Z
      CHARACTER*2 ZZ
      CHARACTER*6 BGCOLS(5),TBCOLS(3),THEAD(17,3)
      CHARACTER*7 HWUNST,TMPNME
      CHARACTER*16 FNAMET
      CHARACTER*17 FNAMEW
      CHARACTER*27 FNAMEP
      CHARACTER*28 TITLE(11),SECTXT
      LOGICAL FIRST(11),NEWSEC
      COMMON/PAPER/MMWIDE,MMLONG,MMHOFF,MMVOFF
      EXTERNAL HWUNST
C
      DATA BGCOLS/'ffffff','0000aa','aa0000','00aa00','aa00ff'/
      DATA TBCOLS/'ccccff','9966ff','ffff00'/
      DATA THEAD/ 17*'9966ff',17*'ffff00',
     &            'IHEP  ','  ID  ',' IDPDG',' IST  ',' MO1  ',' MO2  ',
     &            ' DA1  ',' DA2  ',' P-X  ',' P-Y  ',' P-Z  ','ENERGY',
     &            ' MASS ',' V-X  ',' V-Y  ',' V-Z  ',' V-C*T'/
      DATA TITLE/'     ---INITIAL STATE---    ',
     &           '    ---HARD SUBPROCESS---   ',
     &           '    ---PARTON SHOWERS---    ',
     &           '    ---GLUON SPLITTING---   ',
     &           '   ---CLUSTER FORMATION---  ',
     &           '    ---CLUSTER DECAYS---    ',
     &           ' ---STRONG HADRON DECAYS--- ',
     &           ' ---HEAVY PARTICLE DECAYS---',
     &           '  ---H/W/Z BOSON DECAYS---  ',
     &           ' ---SOFT UNDERLYING EVENT---',
     &           '  ---MULTIPLE SCATTERING--- '/
      Z=CHAR(92)
      ZZ=Z//Z
C
      IUNITT=50
      IUNITW=51
C Write out any required file header information
      TMPNME=HWUNST(NEVHEP)
      IF (PRNTEX) THEN
        WRITE(FNAMET,'(A5,A7,A4)') 'HWEV_',TMPNME,'.tex'
        OPEN(IUNITT,STATUS='UNKNOWN',FILE=FNAMET)
        IF (PRVTX.OR.NPRFMT.EQ.2) THEN
          WRITE(IUNITT,10) Z,Z,Z,MMLONG,Z,MMWIDE,Z,MMVOFF,Z,MMHOFF,Z,Z,Z
        ELSE
          WRITE(IUNITT,10) Z,Z,Z,MMWIDE,Z,MMLONG,Z,MMHOFF,Z,MMVOFF,Z,Z,Z
        ENDIF
      ENDIF
      IF (PRNWEB) THEN
        WRITE(FNAMEW,'(A5,A7,A5)') 'HWEV_',TMPNME,'.html'
        OPEN(IUNITW,STATUS='UNKNOWN',FILE=FNAMEW)
        WRITE(IUNITW,20) BGCOLS
      ENDIF
   10 FORMAT(A1,'documentclass{article}'/A1,'usepackage{longtable}'/
     & A1,'textwidth ',I4,'mm ',A1,'textheight ',I4,'mm'/
     & A1,'hoffset   ',I4,'mm ',A1,'voffset    ',I4,'mm'/
     & A1,'pagestyle{empty}'/A1,'begin{document}'/A1,'begin{center}')
   20 FORMAT('<!-- No Less productions -->'/'<HTML>'/'<HEAD>'/
     & '<TITLE>HERWIG Event Record</TITLE>'/'</HEAD>'/
     & '<BODY BGCOLOR=#',A6,' TEXT=#',A6,' LINK=#',A6,
     & ' ALINK=#',A6,' VLINK=#',A6,'>')
C Write out event header details and set up tables
      IF (PRNDEF) THEN
        WRITE(6,30) NEVHEP,PBEAM1,PART1,PBEAM2,PART2,
     &   IPROC+MAX(IMSSM,0),NRN,ISTAT,IERROR,EVWGT
      ENDIF
      IF (PRNTEX) THEN
        WRITE(IUNITT,40) Z,Z,Z,ISTAT,ZZ,Z,
     &   IPROC+MAX(IMSSM,0),PBEAM1,PBEAM2,NRN(1),
     &   IERROR,ZZ,Z,Z,NEVHEP,TXNAME(1,IDHW(1)),TXNAME(1,IDHW(2)),
     &   NRN(2),EVWGT,ZZ,Z,Z,Z
        IF (PRVTX) THEN
          WRITE(IUNITT,50) Z,Z,Z,Z,Z
        ELSE
          WRITE(IUNITT,60) Z,Z,Z,Z,Z
        ENDIF
      ENDIF
      IF (PRNWEB) THEN
        WRITE(IUNITW,70) TBCOLS(1),TBCOLS(2),(TBCOLS(2),TBCOLS(3),
     &   I=1,4),ISTAT,TBCOLS(2),TBCOLS(3),
     &   IPROC+MAX(IMSSM,0),PBEAM1,PBEAM2,NRN(1),
     &   TBCOLS(2),TBCOLS(3),IERROR
        WRITE(IUNITW,71) TBCOLS(2),TBCOLS(3),NEVHEP,TXNAME(2,IDHW(1)),
     &   TXNAME(2,IDHW(2)),NRN(2),TBCOLS(2),TBCOLS(3),EVWGT,TBCOLS(1)
      ENDIF
   30 FORMAT(///1X,'EVENT ',I7,':',F8.2,' GEV/C ',A8,' ON ',F8.2,
     & ' GEV/C ',A8,' PROCESS:',I6/1X,'SEEDS: ',I11,' & ',I11,
     & '   STATUS: ',I4,' ERROR:',I4,'  WEIGHT: ',1P,E11.4/)
   40 FORMAT(A1,'begin{tabular}{|l|r|c|c|r|l|c|}'/A1,'hline'/
     & A1,'multicolumn{2}{|c|}{HERWIG 6.0} & Beam 1: & Beam 2: & ',
     & 'Seeds: & Status: & ',I4, ' ',A2/A1,'hline'/'Process: & ',I6,
     & ' & ',F8.2,'~GeV/c & ',F8.2,'~GeV/c',' & ',I11,' & Error: & ',
     & I4,' ',A2/A1,'cline{1-2} ',A1,'cline{6-7}'/'Event: & ',I7,' & ',
     & A37,' & ',A37,' & ',I11,' & Weight: & ',1P,E11.4,' ',A2/A1,
     & 'hline'/A1,'end{tabular}'/A1,'vskip 5mm')
   50 FORMAT(A1,'begin{longtable}{|r|c|r|r|r|r|r|r|r|r|r|r|r|r|r|r|r|}'/
     & A1,'hline'/A1,'endhead'/A1,'hline'/A1,'endfoot')
   60 FORMAT(A1,'begin{longtable}{|r|c|r|r|r|r|r|r|r|r|r|r|r|}'/
     & A1,'hline'/A1,'endhead'/A1,'hline'/A1,'endfoot')
   70 FORMAT(/'<CENTER>'/'<TABLE ALIGN="CENTER" BGCOLOR=#',A6,'>'/
     & '<TR>'/'<TH BGCOLOR=#',A6,' COLSPAN=2>',
     & '<A HREF="http://hepwww.rl.ac.uk/theory/seymour/herwig/">',
     & 'HERWIG 6.0</A></TH>'/
     & '<TH BGCOLOR=#',A6,'><FONT COLOR=#',A6,'>Beam 1:</FONT></TH>'/
     & '<TH BGCOLOR=#',A6,'><FONT COLOR=#',A6,'>Beam 2:</FONT></TH>'/
     & '<TH BGCOLOR=#',A6,'><FONT COLOR=#',A6,'>Seeds:</FONT></TH>'/
     & '<TH BGCOLOR=#',A6,' ALIGN="LEFTT"><FONT COLOR=#',A6,
     & '>Status:</FONT></TH>'/'<TD ALIGN="RIGHT">',I4,'</TD>'/'</TR>'/
     & '<TR>'/
     & '<TH BGCOLOR=#',A6,' ALIGN="LEFTT"><FONT COLOR=#',A6,
     & '>Process:</Th>'/'<TD>',I6,'</TD>'/
     & '<TD>',F8.2,' GeV/c</TD>'/'<TD>',F8.2,' GeV/c</TD>'/
     & '<TD ALIGN="RIGHT">',I11,'</TD>'/
     & '<TH BGCOLOR=#',A6,' ALIGN="LEFT"><FONT COLOR=#',A6,
     & '>Error:</FONT></TH>'/'<TD ALIGN="RIGHT">',I4,'</TD>'/'</TR>')
   71 FORMAT('<TR>'/
     & '<TH BGCOLOR=#',A6,' ALIGN="LEFT"><FONT COLOR=#',A6,
     & '>Event:</Th>'/'<TD ALIGN="RIGHT">',I7,'</TD>'/
     & '<TD ALIGN="CENTER">',A37,'</TD>'/
     & '<TD ALIGN="CENTER">',A37,'</TD>'/
     & '<TD ALIGN="RIGHT">',I11,'</TD>'/
     & '<TH BGCOLOR=#',A6,' ALIGN="LEFT"><FONT COLOR=#',A6,
     & '>Weight:</FONT></TH>'/'<TD>',1P,E11.4,'</TD>'/'</TR>'/
     & '</TABLE>'//'<P>'/
     & '<TABLE ALIGN="CENTER" BGCOLOR=#',A6,'>')
C Initialize control flags
      DO 80 I=1,11
   80 FIRST(I)=.TRUE.
C Loop through event record
      DO 410 I=1,NHEP
      NEWSEC=.FALSE.
C First find start of new sections
      IST=ISTHEP(I)
      IS=IST/10
      ID=IDHW(I)
      IF (IST.EQ.101) THEN
        NEWSEC=.TRUE.
        SECTXT=TITLE(1)
      ELSEIF (FIRST(2).AND.IS.EQ.12) THEN
        NEWSEC=.TRUE.
        SECTXT=TITLE(2)
        FIRST(2)=.FALSE.
      ELSEIF (FIRST(3).AND.IS.EQ.14) THEN
        NEWSEC=.TRUE.
        SECTXT=TITLE(3)
        FIRST(3)=.FALSE.
        FIRST(8)=.TRUE.
        FIRST(9)=.TRUE.
        FIRST(11)=.TRUE.
      ELSEIF (FIRST(4).AND.IST.GE.158.AND.IST.NE.160
     &                .AND.IST.LE.162) THEN
        NEWSEC=.TRUE.
        SECTXT=TITLE(4)
        FIRST(4)=.FALSE.
      ELSEIF (FIRST(5).AND.(IS.EQ.16.OR.IS.EQ.18)
     &                .AND.IST.GT.162) THEN
        NEWSEC=.TRUE.
        SECTXT=TITLE(5)
        FIRST(5)=.FALSE.
      ELSEIF (IS.EQ.19.OR.IST.EQ.1.OR.IST.EQ.200) THEN
        MS=ISTHEP(JMOHEP(1,I))/10
        IF (MS.EQ.15.OR.MS.EQ.16.OR.MS.EQ.18) THEN
          IF (FIRST(6)) THEN
            NEWSEC=.TRUE.
            SECTXT=TITLE(6)
            FIRST(6)=.FALSE.
          ENDIF
        ELSEIF (FIRST(7).AND.(.NOT.FIRST(6))) THEN
          NEWSEC=.TRUE.
          SECTXT=TITLE(7)
          FIRST(7)=.FALSE.
        ENDIF
      ELSEIF (FIRST(8).AND.(IST.EQ.125.OR.IST.EQ.155.OR.
     &        (IST.EQ.123.AND.ISTHEP(JMOHEP(1,I)).EQ.199))) THEN
        NEWSEC=.TRUE.
        SECTXT=TITLE(8)
        FIRST(3)=.TRUE.
        FIRST(4)=.TRUE.
        FIRST(5)=.TRUE.
        FIRST(6)=.TRUE.
        FIRST(7)=.TRUE.
        FIRST(8)=.FALSE.
      ELSEIF (FIRST(9).AND.(IST.EQ.123.OR.IST.EQ.124)) THEN
        MS=ABS(IDHEP(JMOHEP(1,I)))
        IF (MS.EQ.23.OR.MS.EQ.24.OR.MS.EQ.25) THEN
          NEWSEC=.TRUE.
          SECTXT=TITLE(9)
          FIRST(3)=.TRUE.
          FIRST(4)=.TRUE.
          FIRST(5)=.TRUE.
          FIRST(6)=.TRUE.
          FIRST(7)=.TRUE.
          FIRST(8)=.TRUE.
          FIRST(9)=.FALSE.
        ENDIF
      ELSEIF (IST.EQ.170) THEN
        NEWSEC=.TRUE.
        SECTXT=TITLE(10)
      ELSEIF (FIRST(11).AND.(ID.EQ.71.OR.ID.EQ.72)) THEN
        NEWSEC=.TRUE.
        SECTXT=TITLE(11)
        FIRST(3)=.TRUE.
        FIRST(11)=.FALSE.
      ENDIF
C Prit out section heading
      IF (NEWSEC) THEN
        IF (PRVTX) THEN
          IF (PRNDEF) THEN
            IF (NPRFMT.EQ.1) THEN
              WRITE(6, 90) SECTXT,(THEAD(J,3),J=1,17)
            ELSE
              WRITE(6,100) SECTXT,(THEAD(J,3),J=1,17)
            ENDIF
          ENDIF
          IF (PRNTEX) WRITE(IUNITT,110) Z,Z,SECTXT,ZZ,Z,
     &     (Z,THEAD(J,3),J=1,17),ZZ,Z
          IF (PRNWEB) WRITE(IUNITW,120) TBCOLS(2),TBCOLS(3),
     &     SECTXT,((THEAD(K,J),J=1,3),K=1,17)
   90     FORMAT(/46X,A28//1X,A4,2X,A6,3X,A6,5A4,3(2X,A6),A6,3X,A5,
     &     4(4X,A6))
  100     FORMAT(/58X,A28//1X,A4,2X,A6,3X,A6,5A4,3(6X,A6),5X,A6,8X,A5,
     &     4X,A6,2(5X,A6),6X,A6)
  110     FORMAT(A1,'hline'/A1,'multicolumn{17}{|c|}{',A28,'} ',A2/A1,
     &     'hline'/16(A1,'multicolumn{1}{|c|}{',A6,'} & '),
     &     A1,'multicolumn{1}{|c|}{',A6,'} ',A2/A1,'hline')
  120     FORMAT('<TR><TH COLSPAN=17 BGCOLOR=#',A6,'>',
     &     '<FONT COLOR=#',A6,'>',A28,'</FONT></TH></TR>'/
     &     '<TR>',17(/,1X,'<TH BGCOLOR=#',A6,'>
     &     <FONT COLOR=',A6,'>',A6,'</FONT></TH>'),'</TR>')
        ELSE
          IF (PRNDEF) THEN
            IF (NPRFMT.EQ.1) THEN
              WRITE(6,130) SECTXT,(THEAD(J,3),J=1,13)
            ELSE
              WRITE(6,140) SECTXT,(THEAD(J,3),J=1,13)
            ENDIF
          END IF
          IF (PRNTEX) WRITE(IUNITT,150) Z,Z,SECTXT,ZZ,Z,
     &     (Z,THEAD(J,3),J=1,13),ZZ,Z
          IF (PRNWEB) WRITE(IUNITW,160) TBCOLS(2),TBCOLS(3),
     &     SECTXT,((THEAD(K,J),J=1,3),K=1,13)
  130     FORMAT(/26X,A28//1X,A4,2X,A6,3X,A6,5A4,3(2X,A6),A6,3X,A5)
  140     FORMAT(/36X,A28//1X,A4,2X,A6,3X,A6,5A4,3(6X,A6),5X,A6,8X,A5)
  150     FORMAT(A1,'hline'/A1,'multicolumn{13}{|c|}{',A28,'} ',A2/A1,
     &     'hline'/12(A1,'multicolumn{1}{|c|}{',A6,'} & '),
     &     A1,'multicolumn{1}{|c|}{',A6,'} ',A2/A1,'hline')
  160     FORMAT('<TR><TH COLSPAN=13 BGCOLOR=#',A6,'>',
     &     '<FONT COLOR=#',A6,'>',A28,'</FONT></TH></TR>'/
     &     '<TR>',13(/'<TH BGCOLOR=#',A6,'>',
     &     '<FONT COLOR=#',A6,'>',A6,'</FONT></TH>'),'</TR>')
        ENDIF
      ENDIF
C Now print out the data line
      IF (PRVTX) THEN
C     Include vertex information
        IF (PRNDEF) THEN
          IF (PRNDEC) THEN
            IF (NPRFMT.EQ.1) THEN
              WRITE(6,190) I,RNAME(IDHW(I)),IDHEP(I),IST,
     &         JMOHEP(1,I),JMOHEP(2,I),JDAHEP(1,I),JDAHEP(2,I),
     &         (PHEP(J,I),J=1,5),(VHEP(J,I),J=1,4)
            ELSE
              WRITE(6,200) I,RNAME(IDHW(I)),IDHEP(I),IST,
     &         JMOHEP(1,I),JMOHEP(2,I),JDAHEP(1,I),JDAHEP(2,I),
     &         (PHEP(J,I),J=1,5),(VHEP(J,I),J=1,4)
            ENDIF
          ELSE
            IF (NPRFMT.EQ.1) THEN
              WRITE(6,210) I,RNAME(IDHW(I)),IDHEP(I),IST,
     &         JMOHEP(1,I),JMOHEP(2,I),JDAHEP(1,I),JDAHEP(2,I),
     &         (PHEP(J,I),J=1,5),(VHEP(J,I),J=1,4)
            ELSE
              WRITE(6,220) I,RNAME(IDHW(I)),IDHEP(I),IST,
     &         JMOHEP(1,I),JMOHEP(2,I),JDAHEP(1,I),JDAHEP(2,I),
     &         (PHEP(J,I),J=1,5),(VHEP(J,I),J=1,4)
            ENDIF
          ENDIF
        ENDIF
        IF (PRNTEX) WRITE(IUNITT,230) I,TXNAME(1,IDHW(I)),IDHEP(I),
     &   IST,JMOHEP(1,I),JMOHEP(2,I),JDAHEP(1,I),JDAHEP(2,I),
     &   (PHEP(J,I),J=1,5),(VHEP(J,I),J=1,4),ZZ
        IF (PRNWEB) THEN
          WRITE(IUNITW,240) TBCOLS(2),TBCOLS(3),I,I
          IF (IDHEP(I).EQ.0.OR.IDHEP(I).EQ.91) THEN
            WRITE(IUNITW,250) TXNAME(2,IDHW(I)),IDHEP(I),IST
          ELSE
            TMPNME=HWUNST(IDHW(I))
            WRITE(FNAMEP,'(A15,A7,A5)')
     &       'HW_decays/PART_',TMPNME,'.html'
            WRITE(IUNITW,260) FNAMEP,TXNAME(2,IDHW(I)),IDHEP(I),IST
          ENDIF
          DO 170 J=1,2
            IF (JMOHEP(J,I).NE.0) THEN
              WRITE(IUNITW,270) JMOHEP(J,I),JMOHEP(J,I)
            ELSE
              WRITE(IUNITW,280) JMOHEP(J,I)
            ENDIF
  170     CONTINUE
          DO 180 J=1,2
            IF (JDAHEP(J,I).NE.0) THEN
              WRITE(IUNITW,270) JDAHEP(J,I),JDAHEP(J,I)
            ELSE
              WRITE(IUNITW,280) JDAHEP(J,I)
            ENDIF
  180     CONTINUE
          IF (NPRFMT.EQ.1) THEN
            WRITE(IUNITW,290) (PHEP(J,I),J=1,5),(VHEP(J,I),J=1,4)
          ELSE
            WRITE(IUNITW,300) (PHEP(J,I),J=1,5),(VHEP(J,I),J=1,4)
          ENDIF
        ENDIF
  190   FORMAT(1X,I4,1X,A8,I8,5I4,   2F8.2,2F7.1,F8.2,1P,4E10.3)
  200   FORMAT(1X,I4,1X,A8,I8,5I4,   5F12.5,1P,4E11.4)
  210   FORMAT(1X,Z4,1X,A8,I8,I4,4Z4,2F8.2,2F7.1,F8.2,1P,4E10.3)
  220   FORMAT(1X,Z4,1X,A8,I8,I4,4Z4,5F12.5,1P,4E11.4)
  230   FORMAT(I4,' & ',A37,' & $',I8,'$',5(' & ',I4),
     &   5(' & $',F8.2,'$'),4(' & $',1P,E11.3,'$'),' ',A2)
  240   FORMAT('<TR>'/'<TD BGCOLOR=#',A6,' ALIGN="RIGHT">',
     &   '<FONT COLOR=#',A6,'><A NAME="',I4,'">',I4,'</A></FONT></TD>'/)
  250   FORMAT('<TD ALIGN="CENTER">',A37,'</TD>'/'<TD ALIGN="RIGHT">',
     &   I8,'</TD>'/'<TD ALIGN="RIGHT">',I4,'</TD>')
  260   FORMAT('<TD ALIGN="CENTER"><A HREF="',A27,'">',A37,'</A></TD>'/
     &   '<TD ALIGN="RIGHT">',I8,'</TD>'/
     &   '<TD ALIGN="RIGHT">',I4,'</TD>')
  270   FORMAT(/'<TD ALIGN="RIGHT"><A HREF="#',I4,'">',I4,'</A></TD>')
  280   FORMAT(/'<TD ALIGN="RIGHT">',I4,'</TD>')
  290   FORMAT(5(/'<TD ALIGN="RIGHT">',F8.2,'</TD>'),1P,
     &   4(/'<TD ALIGN="RIGHT">',E10.3,'</TD>')/'</TR>')
  300   FORMAT(5(/'<TD ALIGN="RIGHT">',F12.5,'</TD>'),1P,
     &   4(/'<TD ALIGN="RIGHT">',E11.4,'</TD>')/'</TR>')
      ELSE
C     Do not include vertex information
        IF (PRNDEF) THEN
          IF (PRNDEC) THEN
            IF (NPRFMT.EQ.1) THEN
              WRITE(6,330) I,RNAME(IDHW(I)),IDHEP(I),IST,
     &         JMOHEP(1,I),JMOHEP(2,I),JDAHEP(1,I),JDAHEP(2,I),
     &         (PHEP(J,I),J=1,5)
            ELSE
              WRITE(6,340) I,RNAME(IDHW(I)),IDHEP(I),IST,
     &         JMOHEP(1,I),JMOHEP(2,I),JDAHEP(1,I),JDAHEP(2,I),
     &         (PHEP(J,I),J=1,5)
            ENDIF
          ELSE
            IF (NPRFMT.EQ.1) THEN
              WRITE(6,350) I,RNAME(IDHW(I)),IDHEP(I),IST,
     &          JMOHEP(1,I),JMOHEP(2,I),JDAHEP(1,I),JDAHEP(2,I),
     &          (PHEP(J,I),J=1,5)
            ELSE
              WRITE(6,360) I,RNAME(IDHW(I)),IDHEP(I),IST,
     &         JMOHEP(1,I),JMOHEP(2,I),JDAHEP(1,I),JDAHEP(2,I),
     &         (PHEP(J,I),J=1,5)
            ENDIF
          ENDIF
        ENDIF
        IF (PRNTEX) THEN
          IF (NPRFMT.EQ.1) THEN
            WRITE(IUNITT,370) I,TXNAME(1,IDHW(I)),IDHEP(I),
     &       IST,JMOHEP(1,I),JMOHEP(2,I),JDAHEP(1,I),JDAHEP(2,I),
     &       (PHEP(J,I),J=1,5),ZZ
          ELSE
            WRITE(IUNITT,380) I,TXNAME(1,IDHW(I)),IDHEP(I),
     &       IST,JMOHEP(1,I),JMOHEP(2,I),JDAHEP(1,I),JDAHEP(2,I),
     &       (PHEP(J,I),J=1,5),ZZ
          ENDIF
        ENDIF
        IF (PRNWEB) THEN
          WRITE(IUNITW,240) TBCOLS(2),TBCOLS(3),I,I
          IF (IDHEP(I).EQ.0.OR.IDHEP(I).EQ.91) THEN
            WRITE(IUNITW,250) TXNAME(2,IDHW(I)),IDHEP(I),IST
          ELSE
            TMPNME = HWUNST(IDHW(I))
            WRITE(FNAMEP,'(A15,A7,A5)')
     &       'HW_decays/PART_',TMPNME,'.html'
            WRITE(IUNITW,260) FNAMEP,TXNAME(2,IDHW(I)),IDHEP(I),IST
          ENDIF
          DO 310 J=1,2
            IF (JMOHEP(J,I).NE.0) THEN
              WRITE(IUNITW,270) JMOHEP(J,I),JMOHEP(J,I)
            ELSE
              WRITE(IUNITW,280) JMOHEP(J,I)
            ENDIF
  310     CONTINUE
          DO 320 J=1,2
            IF (JDAHEP(J,I).NE.0) THEN
              WRITE(IUNITW,270) JDAHEP(J,I),JDAHEP(J,I)
            ELSE
              WRITE(IUNITW,280) JDAHEP(J,I)
            ENDIF
  320     CONTINUE
          IF (NPRFMT.EQ.1) THEN
            WRITE(IUNITW,390) (PHEP(J,I),J=1,5)
          ELSE
            WRITE(IUNITW,400) (PHEP(J,I),J=1,5)
          ENDIF
        ENDIF
  330   FORMAT(1X,I4,1X,A8,I8,5I4   ,2F8.2,2F7.1,F8.2)
  340   FORMAT(1X,I4,1X,A8,I8,5I4   ,5F12.5)
  350   FORMAT(1X,Z4,1X,A8,I8,I4,4Z4,2F8.2,2F7.1,F8.2)
  360   FORMAT(1X,Z4,1X,A8,I8,I4,4Z4,5F12.5)
  370   FORMAT(I4,' & ',A37,' & $',I8,'$',5(' & ',I4),
     &   5(' & $',F8.2,'$'),' ',A2)
  380   FORMAT(I4,' & ',A37,' & $',I8,'$',5(' & ',I4),
     &   5(' & $',F12.5,'$'),' ',A2)
  390   FORMAT(5(/'<TD ALIGN="RIGHT">',F8.2,'</TD>')/'</TR>')
  400   FORMAT(5(/'<TD ALIGN="RIGHT">',F12.5,'</TD>')/'</TR>')
      ENDIF
  410 CONTINUE
C Close the files
      IF (PRNTEX) THEN
        WRITE(IUNITT,420) Z,Z,Z
  420   FORMAT(A1,'end{longtable}'/A1,'end{center}'/A1,'end{document}')
        CLOSE(IUNITT)
      ENDIF
      IF (PRNWEB) THEN
        WRITE(IUNITW,430)
  430   FORMAT('</TABLE>'/'</CENTER>'/'</BODY>'/'</HTML>')
        CLOSE(IUNITW)
      ENDIF
      RETURN
      END
CDECK  ID>, HWUFNE.
*CMZ :-        -16/10/93  12.42.15  by  Mike Seymour
*-- Author :    Mike Seymour
C-----------------------------------------------------------------------
      SUBROUTINE HWUFNE
C-----------------------------------------------------------------------
C     FINALISES THE EVENT BY UNDOING THE LORENTZ BOOST IF THERE WAS ONE,
C     CHECKING FOR ERRORS, AND PRINTING
C-----------------------------------------------------------------------
      INCLUDE 'HERWIG62.INC'
      INTEGER IHEP
      LOGICAL CALLED
      COMMON/HWDBUG/CALLED
      CALLED=.TRUE.
C---UNBOOST EVENT RECORD IF NECESSARY
      CALL HWUBST(0)
C---CHECK FOR NEGATIVE ENERGY PARTICLES (REMNANT BUG?)
      DO IHEP=1,NHEP
         IF (ISTHEP(IHEP).EQ.1.AND.PHEP(4,IHEP).LT.ZERO)
     &       CALL HWWARN('HWUFNE',100,*99)
      ENDDO
 99   CONTINUE
C---CHECK FOR FATAL ERROR
      IF (IERROR.NE.0) THEN
        IF (IERROR.GT.0) THEN
          NUMER=NUMER+1
        ELSE
          NUMERU=NUMERU+1
        ENDIF
        IF (NUMER.GT.MAXER) CALL HWWARN('HWUFNE',300,*999)
        NEVHEP=NEVHEP-1
C---PRINT FIRST MAXPR EVENTS
      ELSEIF (NEVHEP.LE.MAXPR) THEN
        CALL HWUEPR
      END IF
  999 END
CDECK  ID>, HWUGAU.
*CMZ :-        -26/04/91  11.11.56  by  Bryan Webber
*-- Author :    Adapted by Bryan Webber
C-----------------------------------------------------------------------
      FUNCTION HWUGAU(F,A,B,EPS)
C-----------------------------------------------------------------------
C     ADAPTIVE GAUSSIAN INTEGRATION OF FUNCTION F
C     IN INTERVAL (A,B) WITH PRECISION EPS
C     (MODIFIED CERN LIBRARY ROUTINE GAUSS)
C-----------------------------------------------------------------------
      DOUBLE PRECISION HWUGAU,F,A,B,EPS,CONST,AA,BB,C1,C2,S8,U,S16,
     & W(12),X(12),ZERO
      INTEGER I
      EXTERNAL F
      PARAMETER (ZERO=0.0D0)
      DATA W/.1012285363D0,.2223810345D0,.3137066459D0,
     &       .3626837834D0,.0271524594D0,.0622535239D0,
     &       .0951585117D0,.1246289713D0,.1495959888D0,
     &       .1691565194D0,.1826034150D0,.1894506105D0/
      DATA X/.9602898565D0,.7966664774D0,.5255324099D0,
     &       .1834346425D0,.9894009350D0,.9445750231D0,
     &       .8656312024D0,.7554044084D0,.6178762444D0,
     &       .4580167777D0,.2816035508D0,.0950125098D0/
      HWUGAU=0.
      IF (A.EQ.B) RETURN
      CONST=.005/ABS(B-A)
      BB=A
    1 AA=BB
      BB=B
    2    C1=0.5*(BB+AA)
         C2=0.5*(BB-AA)
         S8=0.
         DO 3 I=1,4
            U=C2*X(I)
            S8=S8+W(I)*(F(C1+U)+F(C1-U))
    3    CONTINUE
         S8=C2*S8
         S16=0.
         DO 4 I=5,12
            U=C2*X(I)
            S16=S16+W(I)*(F(C1+U)+F(C1-U))
    4    CONTINUE
         S16=C2*S16
         IF (ABS(S16-S8).LE.EPS*(1.+ABS(S16))) GOTO 5
         BB=C1
         IF (CONST*ABS(C2).NE.ZERO) GOTO 2
C---TOO HIGH ACCURACY REQUESTED
         CALL HWWARN('HWUGAU',500,*999)
    5 HWUGAU=HWUGAU+S16
      IF (BB.NE.B) GOTO 1
  999 END
CDECK  ID>, HWUIDT.
*CMZ :-        -26/04/91  10.18.58  by  Bryan Webber
*-- Author :    Bryan Webber
C-----------------------------------------------------------------------
      SUBROUTINE HWUIDT(IOPT,IPDG,IWIG,NWIG)
C-----------------------------------------------------------------------
C     TRANSLATES PARTICLE IDENTIFIERS:
C     IPDG = PARTICLE DATA GROUP CODE
C     IWIG = HERWIG IDENTITY CODE
C     NWIG = HERWIG CHARACTER*8 NAME
C
C     IOPT= 1 GIVEN IPDG, RETURNS IWIG AND NWIG
C     IOPT= 2 GIVEN IWIG, RETURNS IPDG AND NWIG
C     IOPT= 3 GIVEN NWIG, RETURNS IPDG AND IWIG
C-----------------------------------------------------------------------
      INCLUDE 'HERWIG62.INC'
      INTEGER IOPT,IPDG,IWIG,I
      CHARACTER*8 NWIG
      IF (IOPT.EQ.1) THEN
        DO 10 I=0,NRES
        IF (IDPDG(I).EQ.IPDG) THEN
          IWIG=I
          NWIG=RNAME(I)
          RETURN
        ENDIF
  10    CONTINUE
        WRITE(6,20) IPDG
  20    FORMAT(1X,'Particle not recognised, PDG code: ',I8)
        IWIG=20
        NWIG=RNAME(20)
        CALL HWWARN('HWUIDT',101,*999)
      ELSEIF (IOPT.EQ.2) THEN
        IF (IWIG.LT.0.OR.IWIG.GT.NRES) THEN
          WRITE(6,30) IWIG
  30      FORMAT(1X,'Particle not recognised, HERWIG code: ',I3)
          IPDG=0
          NWIG=RNAME(20)
          CALL HWWARN('HWUIDT',102,*999)
        ELSE
          IPDG=IDPDG(IWIG)
          NWIG=RNAME(IWIG)
          RETURN
        ENDIF
      ELSEIF (IOPT.EQ.3) THEN
        DO 40 I=0,NRES
        IF (RNAME(I).EQ.NWIG) THEN
          IWIG=I
          IPDG=IDPDG(I)
          RETURN
        ENDIF
  40    CONTINUE
        WRITE(6,50) NWIG
  50    FORMAT(1X,'Particle not recognised, HERWIG name: ',A8)
        IWIG=20
        IPDG=0
        CALL HWWARN('HWUIDT',103,*999)
      ELSE
        CALL HWWARN('HWUIDT',404,*999)
      ENDIF
  999 END
CDECK  ID>, HWUINC.
*CMZ :-        -26/04/91  11.11.56  by  Bryan Webber
*-- Author :    Bryan Webber
C-----------------------------------------------------------------------
      SUBROUTINE HWUINC
C-----------------------------------------------------------------------
C     COMPUTES CONSTANTS AND LOOKUP TABLES
C-----------------------------------------------------------------------
      INCLUDE 'HERWIG62.INC'
      DOUBLE PRECISION HWBVMC,HWUALF,HWUPCM,XMIN,XMAX,XPOW,QR,DQKWT,
     & UQKWT,SQKWT,DIQWT,QMAX,PMAX,PTLIM,ETLIM,PGS,PTELM,X,QSCA,UPV,DNV,
     & USEA,DSEA,STR,CHM,BTM,TOP,GLU,VAL(20),CLMXPW,RCLPOW,TEST,RPM(2)
      INTEGER ISTOP,I,J,IQK,IDB,IDT,ISET,IOP1,IOP2,IP2,ID,IH,IV,KPROC
      LOGICAL FIRST,FSTPDF
      CHARACTER*20 PARM(20)
      EXTERNAL HWBVMC,HWUALF,HWUPCM
      COMMON/HWRPIN/XMIN,XMAX,XPOW,FIRST
      COMMON/W50516/FSTPDF
C---MSSM Higgs processes: additional IDs to distinguish from SM-like ones.
      IMSSM=0
      IHIGGS=0
C---Sets even parity of Higgs bosons (in the coupling to fermions) as default.
      PARITY=1
C---IPRO=31...38, MSSM Higgs production.
      IF((IPROC.LT.3100).OR.(IPROC.GE.3900))GO TO 666
C-----------------------------------------------------------------------
C     HARD 2   PARTON -> HIGGS + X PROCESSES IN MSSM
C     IH = 1   MSSM h^0     IV = 0 SM W+/-     IQ = 1,3,5 d,s,b-quark
C        = 2   MSSM H^0        = 1 SM Z             2,4,6 u,c,t-quark
C        = 3   MSSM A^0                        ID = IQ, IL
C        = 4/5 MSSM H^+/-                      IL = 1,2,3 e,mu,tau-lepton
C-----------------------------------------------------------------------
      IF(IPROC/100.EQ.33)THEN
        IF((IPROC.EQ.3350).OR.(IPROC.EQ.3355))THEN
          IMSSM=-1
          IHIGGS=206-201
        ELSE IF((IPROC.EQ.3310).OR.(IPROC.EQ.3320).OR.
     &          (IPROC.EQ.3360).OR.(IPROC.EQ.3370))THEN
          KPROC=MIN(3351,IPROC)
          IV=MAX(KPROC-3350,0)
          IF((IV.LT.0).OR.(IV.GT.1))CALL HWWARN('HWUINC',607,*999)
          IH=IPROC/10-330-5*IV
          IF((IH.LE.0).OR.(IH.GT.2))CALL HWWARN('HWUINC',606,*999)
          IF(IPROC.LE.3320)IMSSM=IPROC-2600
          IF(IPROC.GE.3360)IMSSM=IPROC-2700
C...assign enhancement for MSSM Higgs-VV couplings, V->W,Z-gauge bosons.
          DO 555 I=10,10
            ENHANC(I  )=GHWWSS(IH)
            ENHANC(I+1)=GHZZSS(IH)
 555      CONTINUE
          IF(IH.EQ.1)IHIGGS=203-201
          IF(IH.EQ.2)IHIGGS=204-201
          IF(IH.EQ.3)IHIGGS=205-201
        ELSE IF((IPROC.EQ.3315).OR.(IPROC.EQ.3365))THEN
          IHIGGS=203-201
          IMSSM=-1
        ELSE IF((IPROC.EQ.3325).OR.(IPROC.EQ.3375))THEN
          IHIGGS=204-201
          IMSSM=-1
        ELSE IF(IPROC.EQ.3335)THEN
          IHIGGS=205-201
          IMSSM=-1
        ELSE
          CALL HWWARN('HWUINC',605,*999)
        END IF
      ELSE IF(IPROC/100.EQ.34)THEN
        IMSSM=-1
        IF(IPROC.EQ.3410)IHIGGS=203-201
        IF(IPROC.EQ.3420)IHIGGS=204-201
        IF(IPROC.EQ.3430)IHIGGS=205-201
        IF(IPROC.EQ.3450)IHIGGS=206-201
        IF(IHIGGS.EQ.0)CALL HWWARN('HWUINC',604,*999)
      ELSE IF(IPROC/100.EQ.36)THEN
        IF((IPROC.NE.3610).AND.(IPROC.NE.3620).AND.(IPROC.NE.3630))
     &  CALL HWWARN('HWUINC',603,*999)
        IH=IPROC/10-360
        IF((IH.LE.0).OR.(IH.GT.3))CALL HWWARN('HWUINC',602,*999)
        ID=IPROC-3600-10*IH
        IF((ID.LT.0).OR.(ID.GT.9))CALL HWWARN('HWUINC',601,*999)
        IMSSM=IPROC-(1600+ID)
C...assign Neutral MSSM Higgs parity.
        IF(IH.EQ.3)PARITY=-1
        DO 222 I=1,5,2
C...assign enhancement for Neutral MSSM Higgs-QQ couplings, Q->U,D-type quarks.
          ENHANC(I)=GHDDSS(IH)
          ENHANC(I+1)=GHUUSS(IH)
 222    CONTINUE
C...assign enhancement for Neutral MSSM Higgs-Q~Q~ couplings,
C   Q~->U,D-type squarks.
        DO 223 I=1,6
          SENHNC(I   )=RMASS(198)*GHSQSS(IH,I,1,1)/RMASS(400+I)**2
          SENHNC(I+12)=RMASS(198)*GHSQSS(IH,I,2,2)/RMASS(412+I)**2
 223    CONTINUE
        IF(IH.EQ.1)IHIGGS=203-201
        IF(IH.EQ.2)IHIGGS=204-201
        IF(IH.EQ.3)IHIGGS=205-201
      END IF
C...here starts making use of SM-like implementation.
      IPROC=IPROC-MAX(IMSSM,0)
 666  CONTINUE
      IPRO=MOD(IPROC/100,100)
      IQK=MOD(IPROC,100)
C---SET UP BEAMS
      CALL HWUIDT(3,IDB,IPART1,PART1)
      CALL HWUIDT(3,IDT,IPART2,PART2)
      EBEAM1=SQRT(PBEAM1**2+RMASS(IPART1)**2)
      EBEAM2=SQRT(PBEAM2**2+RMASS(IPART2)**2)
C---PHOTON CUTOFF DEFAULTS TO ROOT S
      PTLIM=SQRT(HALF*(EBEAM1*EBEAM2+PBEAM1*PBEAM2))
      ETLIM=TWO*PTLIM
      IF (VPCUT.GT.ETLIM) VPCUT=ETLIM
      IF (Q2MAX.GT.ETLIM**2) Q2MAX=ETLIM**2
C---PRINT OUT MOST IMPORTANT INPUT PARAMETERS
      IF (IPRINT.EQ.0) GOTO 50
      WRITE (6,10) PART1,PBEAM1,PART2,PBEAM2,IPROC,NFLAV,NSTRU,
     & AZSPIN,AZSOFT,QCDLAM,(RMASS(I),I=1,6),RMASS(13)
      IF (ISPAC.LE.1) THEN
        WRITE (6,20) VQCUT,VGCUT,VPCUT,CLMAX,QSPAC,PTRMS
      ELSE
        WRITE (6,30) VQCUT,VGCUT,VPCUT,CLMAX,QSPAC,PTRMS
      ENDIF
      IF (NOSPAC) WRITE (6,40)
  10  FORMAT(/10X,'INPUT CONDITIONS FOR THIS RUN'//
     &        10X,'BEAM 1 (',A8,') MOM. =',F10.2/
     &        10X,'BEAM 2 (',A8,') MOM. =',F10.2/
     &        10X,'PROCESS CODE (IPROC)   =',I8/
     &        10X,'NUMBER OF FLAVOURS     =',I5/
     &        10X,'STRUCTURE FUNCTION SET =',I5/
     &        10X,'AZIM SPIN CORRELATIONS =',L5/
     &        10X,'AZIM SOFT CORRELATIONS =',L5/
     &        10X,'QCD LAMBDA (GEV)       =',F10.4/
     &        10X,'DOWN     QUARK  MASS   =',F10.4/
     &        10X,'UP       QUARK  MASS   =',F10.4/
     &        10X,'STRANGE  QUARK  MASS   =',F10.4/
     &        10X,'CHARMED  QUARK  MASS   =',F10.4/
     &        10X,'BOTTOM   QUARK  MASS   =',F10.4/
     &        10X,'TOP      QUARK  MASS   =',F10.4/
     &        10X,'GLUON EFFECTIVE MASS   =',F10.4)
  20  FORMAT(10X,'EXTRA SHOWER CUTOFF (Q)=',F10.4/
     &       10X,'EXTRA SHOWER CUTOFF (G)=',F10.4/
     &       10X,'PHOTON SHOWER CUTOFF   =',F10.4/
     &       10X,'CLUSTER MASS PARAMETER =',F10.4/
     &       10X,'SPACELIKE EVOLN CUTOFF =',F10.4/
     &       10X,'INTRINSIC P-TRAN (RMS) =',F10.4)
  30  FORMAT(10X,'EXTRA SHOWER CUTOFF (Q)=',F10.4/
     &       10X,'EXTRA SHOWER CUTOFF (G)=',F10.4/
     &       10X,'PHOTON SHOWER CUTOFF   =',F10.4/
     &       10X,'CLUSTER MASS PARAMETER =',F10.4/
     &       10X,'PDF FREEZING CUTOFF    =',F10.4/
     &       10X,'INTRINSIC P-TRAN (RMS) =',F10.4)
  40  FORMAT(10X,'NO SPACE-LIKE SHOWERS')
  50  ISTOP=0
C---INITIALIZE ALPHA-STRONG
      IF (QLIM.GT.ETLIM) QLIM=ETLIM
      QR=HWUALF(0,QLIM)
C---DO SOME SAFETY CHECKS ON INPUT PARAMETERS
C Check beam order for point-like photon/QCD processes
      IF (IPRO.GE.50.AND.IPRO.LE.59.AND.
     &     IDB.NE.22.AND.ABS(IDB).NE.11.AND.ABS(IDB).NE.13) THEN
         WRITE(6,60)
  60     FORMAT(1X,'WARNING: require FIRST beam to be a photon/lepton')
         ISTOP=ISTOP+1
      ENDIF
      QG=HWBVMC(13)
      QR=QG/QCDL3
      IF (QR.GE.2.01) GOTO 80
      WRITE (6,70) QG,QCDLAM,QCDL3
  70  FORMAT(//10X,'SHOWER GLUON VIRTUAL MASS CUTOFF =',F8.5/
     &         10X,'TOO SMALL RELATIVE TO QCD LAMBDA =',F8.5/
     &         10X,'CORRESPONDS TO  3-FLAV MC LAMBDA =',F8.5)
      ISTOP=ISTOP+1
  80  QV=MIN(HWBVMC(1),HWBVMC(2))
      IF (QV.GE.QG/(QR-1.)) GOTO 100
      ISTOP=ISTOP+1
      WRITE (6,90) QV,QCDLAM,QCDL3
  90  FORMAT(//10X,'SHOWER QUARK VIRTUAL MASS CUTOFF =',F8.5/
     &         10X,'TOO SMALL RELATIVE TO QCD LAMBDA =',F8.5/
     &         10X,'CORRESPONDS TO  3-FLAV MC LAMBDA =',F8.5)
  100 IF (ISTOP.NE.0) THEN
        WRITE (6,110) ISTOP
  110   FORMAT(//10X,'EXECUTION PREVENTED BY',I2,
     &  ' ERRORS IN INPUT PARAMETERS.')
        STOP
      ENDIF
      DO 120 I=1,6
  120 RMASS(I+6)=RMASS(I)
      RMASS(199)=RMASS(198)
C---A PRIORI WEIGHTS FOR QUARK AND DIQUARKS
      DQKWT=PWT(1)
      UQKWT=PWT(2)
      SQKWT=PWT(3)
      DIQWT=PWT(7)
      PWT(10)=PWT(4)
      PWT(11)=PWT(5)
      PWT(12)=PWT(6)
C
      PWT(4)=UQKWT*UQKWT*DIQWT
      PWT(5)=UQKWT*DQKWT*DIQWT*HALF
      PWT(6)=DQKWT*DQKWT*DIQWT
      PWT(7)=UQKWT*SQKWT*DIQWT*HALF
      PWT(8)=DQKWT*SQKWT*DIQWT*HALF
      PWT(9)=SQKWT*SQKWT*DIQWT
      QMAX=MAX(PWT(1),PWT(2),PWT(3))
      PMAX=MAX(PWT(4),PWT(5),PWT(6),PWT(7),PWT(8),PWT(9),
     &         PWT(10),PWT(11),PWT(12),QMAX)
      PMAX=1./PMAX
      QMAX=1./QMAX
      DO 130 I=1,3
  130 QWT(I)=PWT(I)*QMAX
      DO 140 I=1,12
  140 PWT(I)=PWT(I)*PMAX
C  MASSES OF DIQUARKS (ASSUME BINDING NEGLIGIBLE)
      RMASS(109)=RMASS(2)+RMASS(2)
      RMASS(110)=RMASS(1)+RMASS(2)
      RMASS(111)=RMASS(1)+RMASS(1)
      RMASS(112)=RMASS(2)+RMASS(3)
      RMASS(113)=RMASS(1)+RMASS(3)
      RMASS(114)=RMASS(3)+RMASS(3)
      DO 150 I=109,114
  150 RMASS(I+6)=RMASS(I)
C  MASSES OF TOP HADRONS (ASSUME BINDING NEGLIGIBLE)
      RMASS(232)=RMASS(6)+RMASS(5)
      RMASS(233)=RMASS(6)+RMASS(1)
      RMASS(234)=RMASS(6)+RMASS(2)
      RMASS(235)=RMASS(6)+RMASS(3)
      RMASS(236)=RMASS(6)+RMASS(2)+RMASS(2)
      RMASS(237)=RMASS(6)+RMASS(1)+RMASS(2)
      RMASS(238)=RMASS(6)+RMASS(1)+RMASS(1)
      RMASS(239)=RMASS(6)+RMASS(2)+RMASS(3)
      RMASS(240)=RMASS(6)+RMASS(1)+RMASS(3)
      RMASS(241)=RMASS(6)+RMASS(3)+RMASS(3)
      RMASS(242)=RMASS(6)+RMASS(4)
      RMASS(243)=RMASS(6)+RMASS(5)
      RMASS(244)=RMASS(6)+RMASS(6)
      RMASS(232)=RMASS(243)
      DO 160 I=233,242
  160 RMASS(I+22)=RMASS(I)
C Set up an array of cluster mass threholds
      CLMXPW=CLMAX**CLPOW
      RCLPOW=ONE/CLPOW
      CALL HWVZRO(144,CTHRPW(1,1))
      DO 170 I=1,6
      DO 170 J=1,6
      CTHRPW(I ,J  )=(CLMXPW+(RMASS(I    )+RMASS(J+6  ))**CLPOW)**RCLPOW
      CTHRPW(I ,J+6)=(CLMXPW+(RMASS(I    )+RMASS(J+108))**CLPOW)**RCLPOW
  170 CTHRPW(I+6,J )=(CLMXPW+(RMASS(I+114)+RMASS(J+6  ))**CLPOW)**RCLPOW
C Decay length conversion factor GEV2MM hbar.c/e
      GEV2MM=1.D-15*SQRT(GEV2NB/10.)
C Plank's constant/2pi (GeV.s)
      HBAR=GEV2MM/CSPEED
C Check the SUSY DATA has been read in (if needed)
      IF((IPRO.EQ.7.OR.(IPRO.GE.30.AND.IPRO.LE.41)).AND..NOT.SUSYIN)
     &     CALL HWWARN('HWUINC',600,*999)
C---IMPORTANCE SAMPLING
      FIRST=.TRUE.
      IF (IPRO.EQ.5) THEN
        IF (EMMAX.GT.ETLIM)  EMMAX=ETLIM
        IF (PTMAX.GT.PTLIM)  PTMAX=PTLIM
      ELSEIF (IPRO.EQ.13) THEN
        IF (EMMIN.EQ.ZERO)   EMMIN=10
        IF (EMMAX.GT.ETLIM)  EMMAX=ETLIM
        IF (IQK.GT.0.AND.IQK.LE.6) EMMIN=MAX(EMMIN,2*RMASS(IQK))
        XMIN=EMMIN
        XMAX=EMMAX
        XPOW=-EMPOW
      ELSEIF (IPRO.EQ.15.OR.IPRO.EQ.17.OR.IPRO.EQ.18.OR.IPRO.EQ.21
     &    .OR.IPRO.EQ.22.OR.IPRO.EQ.23.OR.IPRO.EQ.24.OR.IPRO.EQ.50
     &    .OR.IPRO.EQ.51.OR.IPRO.EQ.53.OR.IPRO.EQ.55.OR.IPRO.EQ.60) THEN
        IF (PTMAX.GT.PTLIM)  PTMAX=PTLIM
        IF (IQK.NE.0.AND.IQK.LT.7.AND.IPRO.NE.23) THEN
          XMIN=2.*SQRT(PTMIN**2+RMASS(IQK)**2)
          XMAX=2.*SQRT(PTMAX**2+RMASS(IQK)**2)
          IF (XMAX.GT.ETLIM)  XMAX=ETLIM
        ELSE
          XMIN=2.*PTMIN
          XMAX=2.*PTMAX
        ENDIF
        XPOW=-PTPOW
C--Cuts on the graviton to avoid unitarity violations
C--If the width exceeds 0.1 times the mass this should be reset
      ELSEIF(IPRO.EQ.42) THEN
         EMMIN = 0.9D0*EMGRV
         EMMAX = 1.1D0*EMGRV
      ELSEIF (IPRO.EQ.52) THEN
        PTELM=PTLIM-RMASS(IQK)**2/(4.*PTLIM)
        IF (PTMAX.GT.PTELM) PTMAX=PTELM
        XMIN=PTMIN
        XMAX=PTMAX
        XPOW=-PTPOW
      ELSEIF (IPRO.EQ.30) THEN
        IF (PTMAX.GT.PTLIM)  PTMAX=PTLIM
        XMIN=2.*SQRT(PTMIN**2+RMMNSS**2)
        XMAX=2.*SQRT(PTMAX**2+RMMNSS**2)
        IF (XMAX.GT.ETLIM)  XMAX=ETLIM
        XPOW=-PTPOW
C--PR MOD 7/7/99
      ELSEIF(IPRO.EQ.40.OR.IPRO.EQ.41) THEN
        IF (PTMAX.GT.PTLIM)  PTMAX=PTLIM
          ID = IPROC-100*IPRO
          RPM(1) = RMMNSS
          RPM(2) = ZERO
          IF(ID.GE.10.AND.ID.LT.20) THEN
            RPM(1) = ABS(RMASS(450))
            IF(ID.GT.10) RPM(1) = ABS(RMASS(449+MOD(ID,10)))
          ELSEIF(ID.GE.20.AND.ID.LT.30) THEN
            RPM(1) = ABS(RMASS(454))
            IF(ID.GT.20) RPM(1) = ABS(RMASS(453+MOD(ID,20)))
          ELSEIF(ID.EQ.30) THEN
            RPM(1) = RMASS(449)
          ELSEIF(ID.EQ.40) THEN
            IF(IPRO.EQ.40) THEN
              RPM(1) = RMASS(425)
              DO I=1,5
                RPM(1) = MIN(RPM(1),RMASS(425+I))
              ENDDO
            ELSE
              RPM(1) = MIN(RMASS(405),RMASS(406))
            ENDIF
            RPM(2) = RMASS(198)
          ELSEIF(ID.EQ.50) THEN
            IF(IPRO.EQ.40) THEN
              RPM(1) = RMASS(425)
              DO I=1,5
                RPM(1) = MIN(RPM(1),RMASS(425+I))
              ENDDO
              DO I=1,3
                RPM(2) = MIN(RPM(1),RMASS(433+2*I))
              ENDDO
              RPM(1) = MIN(RPM(1),RPM(2))
              RPM(2) = RMASS(203)
              DO I=1,2
                RPM(2) = MIN(RPM(2),RMASS(204+I))
              ENDDO
            ELSE
              RPM(1) = RMASS(401)
              RPM(2) = RMASS(413)
              DO I=1,5
                RPM(1) = MIN(RPM(1),RMASS(401+I))
                RPM(2) = MIN(RPM(2),RMASS(413+I))
              ENDDO
              RPM(1) = MIN(RPM(1),RPM(2))
              RPM(2) = RMASS(203)
              DO I=1,2
                RPM(2) = MIN(RPM(2),RMASS(204+I))
              ENDDO
            ENDIF
            RPM(2) = RMASS(203)
            DO I=1,2
              RPM(2) = MIN(RPM(2),RMASS(204+I))
            ENDDO
          ELSEIF(ID.GE.60) THEN
            RPM(1) = ZERO
          ENDIF
          RPM(1) = RPM(1)**2
          RPM(2) = RPM(2)**2
          XMIN = SQRT(RPM(1)+RPM(2)+TWO*(PTMIN**2+
     &           SQRT(RPM(1)*RPM(2)+PTMIN**2*(RPM(1)+RPM(2)+PTMIN**2))))
          XMAX = SQRT(RPM(1)+RPM(2)+TWO*(PTMAX**2+
     &           SQRT(RPM(1)*RPM(2)+PTMAX**2*(RPM(1)+RPM(2)+PTMAX**2))))
        IF (XMAX.GT.ETLIM)  XMAX=ETLIM
C--end of mod
      ELSEIF (IPRO.EQ.90) THEN
        XMIN=SQRT(Q2MIN)
        XMAX=SQRT(Q2MAX)
        XPOW=1.-2.*Q2POW
      ELSEIF (IPRO.EQ.91) THEN
        IF (EMMAX.GT.ETLIM) EMMAX=ETLIM
      ENDIF
C---CALCULATE HIGGS WIDTH
      IF (IPRO.EQ. 3.OR.IPRO.EQ. 4.OR.IPRO.EQ.16.OR.IPRO.EQ.19
     &.OR.IPRO.EQ.23.OR.IPRO.EQ.25.OR.IPRO.EQ.26.OR.IPRO.EQ.27
     &.OR.IPRO.EQ.95) THEN
        GAMH=RMASS(201)
        CALL HWDHIG(GAMH)
      ENDIF
C---IF Q**2 CAN BE TOO SMALL, BREIT FRAME MAKES NO SENSE
      IF ((IPRO/10.EQ.9.AND.Q2MIN.LE.1.D-2).OR.
     &    (IPRO.EQ.91.AND.IQK.EQ.7)) BREIT=.FALSE.
      IF (IPRINT.NE.0) THEN
        IF (PBEAM1.NE.PBEAM2) WRITE (6,180) USECMF
        IF (IPRO.EQ.91.OR.IPRO.EQ.92)
     &      WRITE (6,190) PTMIN
        IF (IPRO.EQ.90.OR.(IPRO.EQ.91.AND.IQK.NE.7).OR.IPRO.EQ.92)
     &      WRITE (6,200) Q2MIN,Q2MAX,BREIT
        IF (IPRO.EQ.90.OR.(IPRO.EQ.91.AND.IQK.NE.7).OR.IPRO.EQ.92)
     &      WRITE (6,210) YBMIN,YBMAX
        IF (IPRO.EQ.91.AND.IQK.EQ.7)
     &      WRITE (6,220) Q2WWMN,Q2WWMX,BREIT,ZJMAX
        IF (IPROC/10.EQ.11) WRITE (6,230) THMAX
        IF (IPRO.EQ.13) WRITE (6,240) EMMIN,EMMAX
        IF (IPRO.EQ.15.OR.IPRO.EQ.17.OR.IPRO.EQ.18.OR.IPRO.EQ.21
     &  .OR.IPRO.EQ.22.OR.IPRO.EQ.23.OR.IPRO.EQ.24.OR.IPRO.EQ.50
     &  .OR.IPRO.EQ.51.OR.IPRO.EQ.52.OR.IPRO.EQ.53.OR.IPRO.EQ.55
     &  .OR.IPRO.EQ.60)
     &      WRITE (6,250) PTMIN,PTMAX
        IF (IPRO.EQ. 3.OR.IPRO.EQ. 4.OR.IPRO.EQ.16.OR.IPRO.EQ.19
     &  .OR.IPRO.EQ.23.OR.IPRO.EQ.25.OR.IPRO.EQ.26.OR.IPRO.EQ.27
     &  .OR.IPRO.EQ.95)
     &      WRITE (6,260) RMASS(201),GAMH,
     &      GAMMAX,RMASS(201)+GAMMAX*GAMH,(BRHIG(I)*100,I=1,12)
        IF (IPRO.EQ.91) WRITE (6,270) BGSHAT,EMMIN,EMMAX
        IF (IPRO.EQ.5.AND.IQK.LT.50)
     &      WRITE (6,280) EMMIN,EMMAX,PTMIN,PTMAX,CTMAX
        IF (IPRO.EQ.5.AND.IQK.GE.50)
     &      WRITE (6,290) EMMIN,EMMAX,Q2MIN,Q2MAX,PTMIN
        IF (IPRO.GT.10.AND.
     &    (IPRO.LT.90.AND.(ABS(IDB).EQ.11.OR.ABS(IDB).EQ.13).OR.
     &                    (ABS(IDT).EQ.11.OR.ABS(IDT).EQ.13))) THEN
          WRITE (6,300) Q2WWMN,Q2WWMX,YWWMIN,YWWMAX
          IF (PHOMAS.GT.ZERO) WRITE (6,310) PHOMAS
        ENDIF
        IF (IPROC/10.EQ.10.OR.IPRO.EQ.90)
     &      WRITE (6,320) HARDME,SOFTME
C  Check minimum mass threshold if ISR switched on
        IF ((IPRO.LE.3.OR.IPRO.EQ.6).AND.ZMXISR.GT.ZERO) THEN
          TEST=TWO*RMASS(IPART1)**2+ETLIM**2
          TEST=FOUR*RMASS(2)**2/TEST
          IF (TMNISR.LT.TEST) THEN
            WRITE(6,175) TMNISR,TEST
  175       FORMAT(10X,'Minimum invariant mass',F10.6,' too low'/
     &             10X,'increasing to  TMNISR=',F10.6)
            TMNISR=TEST
          ENDIF
          WRITE (6,330) TMNISR,ONE-ZMXISR
        ENDIF
        IF (WHMIN.GT.ZERO .AND. IPRO.GT.10.AND.(IPRO.EQ.90.OR.
     &       (ABS(IDB).EQ.11.OR.ABS(IDB).EQ.13).OR.
     &       (ABS(IDT).EQ.11.OR.ABS(IDT).EQ.13))) WRITE (6,340) WHMIN
  180   FORMAT(10X,'USE BEAM-TARGET C.M.F. =',L5)
  190   FORMAT(10X,'MIN P-T FOR O(AS) DILS =',F10.4)
  200   FORMAT(10X,'MIN ABS(Q**2) FOR DILS =',E10.4/
     &         10X,'MAX ABS(Q**2) FOR DILS =',E10.4/
     &         10X,'BREIT FRAME SHOWERING  =',L5)
  210   FORMAT(10X,'MIN BJORKEN Y FOR DILS =',F10.4/
     &         10X,'MAX BJORKEN Y FOR DILS =',F10.4)
  220   FORMAT(10X,'MIN ABS(Q**2) FOR J/PSI=',E10.4/
     &         10X,'MAX ABS(Q**2) FOR J/PSI=',E10.4/
     &         10X,'BREIT FRAME SHOWERING  =',L5/
     &         10X,'MAX Z FOR J/PSI        =',F10.4)
  230   FORMAT(10X,'MAX THRUST FOR 2->3    =',F10.4)
  240   FORMAT(10X,'MIN MASS FOR DRELL-YAN =',F10.4/
     &         10X,'MAX MASS FOR DRELL-YAN =',F10.4)
  250   FORMAT(10X,'MIN P-TRAN FOR 2->2    =',F10.4/
     &         10X,'MAX P-TRAN FOR 2->2    =',F10.4)
  260   FORMAT(10X,'HIGGS BOSON MASS       =',F10.4/
     &         10X,'HIGGS BOSON WIDTH      =',F10.4/
     &         10X,'CUTOFF = EMH +',F4.1,'*GAMH=',F10.4/
     &         10X,'HIGGS          D DBAR  =',F10.4/
     &         10X,'BRANCHING      U UBAR  =',F10.4/
     &         10X,'FRACTIONS      S SBAR  =',F10.4/
     &         10X,'(PER CENT)     C CBAR  =',F10.4/
     &         10X,'               B BBAR  =',F10.4/
     &         10X,'               T TBAR  =',F10.4/
     &         10X,'              E+ E-    =',F10.4/
     &         10X,'             MU+ MU-   =',F10.4/
     &         10X,'            TAU+ TAU-  =',F10.4/
     &         10X,'               W W     =',F10.4/
     &         10X,'               Z Z     =',F10.4/
     &         10X,'           GAMMA GAMMA =',F10.4)
  270   FORMAT(10X,'SCALE FOR BGF IS S-HAT =',L5/
     &         10X,'MIN MASS FOR BGF       =',F10.4/
     &         10X,'MAX MASS FOR BGF       =',F10.4)
  280   FORMAT(10X,'MIN MASS FOR 2 PHOTONS =',F10.4/
     &         10X,'MAX MASS FOR 2 PHOTONS =',F10.4/
     &         10X,'MIN PT OF 2 PHOTON CMF =',F10.4/
     &         10X,'MAX PT OF 2 PHOTON CMF =',F10.4/
     &         10X,'MAX COS THETA IN CMF   =',F10.4)
  290   FORMAT(10X,'MIN MASS FOR GAMMA + W =',F10.4/
     &         10X,'MAX MASS FOR GAMMA + W =',F10.4/
     &         10X,'MIN ABS(Q**2)          =',E10.4/
     &         10X,'MAX ABS(Q**2)          =',E10.4/
     &         10X,'MIN PT                 =',F10.4)
  300   FORMAT(10X,'MIN Q**2 FOR WW PHOTON =',F10.4/
     &         10X,'MAX Q**2 FOR WW PHOTON =',F10.4/
     &         10X,'MIN MOMENTUM FRACTION  =',F10.4/
     &         10X,'MAX MOMENTUM FRACTION  =',F10.4)
  310   FORMAT(10X,'GAMMA* S.F. MASS PARAM =',F10.4)
  320   FORMAT(10X,'HARD M.E. MATCHING     =',L5/
     &         10X,'SOFT M.E. MATCHING     =',L5)
  330   FORMAT(10X,'MIN MTM FRAC FOR ISR   =',1PE10.4/
     &         10X,'1-MAX MTM FRAC FOR ISR =',1PE10.4)
  340   FORMAT(10X,'MINIMUM HADRONIC MASS  =',F10.4)
        IF (LWEVT.LE.0) THEN
          WRITE (6,350)
        ELSE
          WRITE (6,360) LWEVT
        ENDIF
  350   FORMAT(/10X,'NO EVENTS WILL BE WRITTEN TO DISK')
  360   FORMAT(/10X,'EVENTS WILL BE OUTPUT ON UNIT',I4)
      ENDIF
C Verify and print beam polarisations
      IF (IPRO.EQ.1.OR.IPRO.EQ.3) THEN
C Set up transverse polarisation parameters for e+e-
        IF ((EPOLN(1)**2+EPOLN(2)**2)
     &     *(PPOLN(1)**2+PPOLN(2)**2).GT.ZERO) THEN
          TPOL=.TRUE.
          COSS=EPOLN(1)*PPOLN(1)-EPOLN(2)*PPOLN(2)
          SINS=EPOLN(2)*PPOLN(1)+EPOLN(1)*PPOLN(2)
        ELSE
          TPOL=.FALSE.
        ENDIF
C print out lepton beam polarisation(s)
        IF (IPRINT.NE.0) THEN
          IF (IPART1.EQ.121) THEN
            WRITE (6,370) PART1,EPOLN,PART2,PPOLN
          ELSE
            WRITE (6,370) PART1,PPOLN,PART2,EPOLN
          ENDIF
 370      FORMAT(/10X,A8,'Beam polarisation=',3F10.4/
     &            10X,A8,'Beam polarisation=',3F10.4)
        ENDIF
      ELSEIF (IPRO.GE.90.AND.IPRO.LE.99) THEN
        IF (IDB.GE.11.AND.IDB.LE.16) THEN
          CALL HWVZRO(3,PPOLN)
C Check neutrino polarisations for DIS
          IF (IDB.EQ. 12.OR.IDB.EQ. 14.OR.IDB.EQ. 16.AND.
     &        EPOLN(3).NE.-ONE) EPOLN(3)=-ONE
          IF (IPRINT.NE.0) WRITE(6,380) PART1,EPOLN(3)
        ELSE
          CALL HWVZRO(3,EPOLN)
C Check anti-neutrino polarisations for DIS
          IF (IDB.EQ.-12.OR.IDB.EQ.-14.OR.IDB.EQ.-16.AND.
     &        PPOLN(3).NE.ONE) PPOLN(3)=ONE
          IF (IPRINT.NE.0) WRITE(6,380) PART1,PPOLN(3)
        ENDIF
 380    FORMAT(/10X,A8,1X,'Longitudinal beam polarisation=',F10.4/)
      ENDIF
      IF (IPRINT.NE.0) THEN
        IF (ZPRIME) THEN
          WRITE(6,390) RMASS(200),RMASS(202),GAMZ,GAMZP
          WRITE(6,400) (RNAME(I),VFCH(I,1),AFCH(I,1),VFCH(I,2),
     &                  AFCH(I,2),I=1,6)
          WRITE(6,400) (RNAME(110+I),VFCH(I,1),AFCH(I,1),
     &                  VFCH(I,2),AFCH(I,2),I=11,16)
  390     FORMAT(/10X,'MASSIVE NEUTRAL VECTOR BOSON PARAMS'/
     &            10X,'Z   MASS=',F10.4,7X,'Z-PRIME MASS=',F10.4/
     &            10X,'   WIDTH=',F10.4,7X,'       WIDTH=',F10.4/
     &            10X,'FERMION COUPLINGS: e.(V.1+A.G_5)G_mu'/
     &            10X,'FERMION:  VECTOR     AXIAL',6X,
     &                'VECTOR     AXIAL'/)
  400     FORMAT(10X,A8,2X,F10.4,1X,F10.4,1X,F10.4,1X,F10.4)
        ENDIF
        IF (MIXING) THEN
          WRITE(6,410) XMIX(2),YMIX(2),XMIX(1),YMIX(1)
  410     FORMAT(/10X,'B_d: Delt-M/Gam =',F6.4,
     &                ' Delt-Gam/2*Gam =',F6.4,/
     &            10X,'B_s: Delt-M/Gam =',F6.2,
     &                ' Delt-Gam/2*Gam =',F6.4)
        ENDIF
        IF (CLRECO) WRITE(6,420) PRECO,EXAG
  420   FORMAT(/10X,'Colour rearrangement ALLOWED, probability =',F6.4,/
     &          10x,'Weak boson life-time exaggeration factor =',F10.6)
C---PDF STRUCTURE FUNCTIONS
        WRITE (6,'(X)')
        DO 450 I=1,2
          IF (MODPDF(I).GE.0) THEN
            WRITE (6,430) I,MODPDF(I),AUTPDF(I)
          ELSE
            WRITE (6,440) I
          ENDIF
 430      FORMAT(10X,'PDFLIB USED FOR BEAM',I2,': SET',I3,' OF ',A20)
 440      FORMAT(10X,'PDFLIB NOT USED FOR BEAM',I2)
 450    CONTINUE
C---GET THE UGLY INITIALISATION MESSAGES OVER AND DONE WITH NOW TOO
        DO 460 I=1,2
          IF (MODPDF(I).GE.0) THEN
            PARM(1)=AUTPDF(I)
            VAL(1)=MODPDF(I)
            FSTPDF=.TRUE.
            X=0.5
            QSCA=10
C---FIX TO CALL SCHULER-SJOSTRAND CODE
            IF (AUTPDF(I).EQ.'SaSph') THEN
              ISET=MOD(MODPDF(I),10)
              IOP1=MOD(MODPDF(I)/10,2)
              IOP2=MOD(MODPDF(I)/20,2)
              IP2=MODPDF(I)/100
              IF (ISET.EQ.1) THEN
                WRITE (6,'(10X,A)')'SCHULER-SJOSTRAND PHOTON PDF SET 1D'
              ELSEIF (ISET.EQ.2) THEN
                WRITE (6,'(10X,A)')'SCHULER-SJOSTRAND PHOTON PDF SET 1M'
              ELSEIF (ISET.EQ.3) THEN
                WRITE (6,'(10X,A)')'SCHULER-SJOSTRAND PHOTON PDF SET 2D'
              ELSEIF (ISET.EQ.4) THEN
                WRITE (6,'(10X,A)')'SCHULER-SJOSTRAND PHOTON PDF SET 2M'
              ELSE
                WRITE (6,'(10X,A)')'UNKNOWN SCHULER-SJOSTRAND PDF SET'
                CALL HWWARN('HWUINC',500,*999)
              ENDIF
              IF (IOP1.EQ.1) THEN
                WRITE (6,'(10X,A)') 'WITH DIRECT COMPONENT IN DIS'
                IF (IPRO.NE.90) WRITE (6,'(10X,A)')
     $               'NOT RECOMMENDED FOR NON-DIS PROCESSES'
              ENDIF
              IF (IOP2.EQ.1) THEN
                WRITE (6,'(10X,A)') 'WITH P**2 DEPENDENCE INCLUDED'
                IF (PHOMAS.GT.ZERO)
     $          WRITE (6,'(10X,A)') 'NOT RECOMMENDED WITH PHOMAS.GT.0'
                IF (IP2.GT.0)
     $          WRITE (6,'(10X,A,I2)') 'WITH IP2 OPTION EQUAL TO',IP2
              ENDIF
            ELSEIF (AUTPDF(I).EQ.'SSph') THEN
              WRITE (6,'(10X,A)') 'THE ACRONYM FOR SCHULER-SJOSTRAND'
              WRITE (6,'(10X,A)') 'HAS CHANGED TO SaSph ACCORDING TO'
              WRITE (6,'(10X,A)') 'THEIR WISHES.  SSph NO LONGER WORKS'
              STOP
            ELSE
              CALL PDFSET(PARM,VAL)
              CALL STRUCTM(X,QSCA,UPV,DNV,USEA,DSEA,STR,CHM,BTM,TOP,GLU)
            ENDIF
          ENDIF
 460    CONTINUE
        WRITE (6,'(X)')
      ENDIF
C Set up neutral B meson mixing parameters
      IF (MIXING.AND..NOT.(RSTAB(223).AND.RSTAB(247))) THEN
        XMRCT(1)=XMIX(1)*RMASS(223)/(CSPEED*RLTIM(223))
        YMRCT(1)=YMIX(1)*RMASS(223)/(CSPEED*RLTIM(223))
      ENDIF
      IF (MIXING.AND..NOT.(RSTAB(221).AND.RSTAB(245))) THEN
        XMRCT(2)=XMIX(2)*RMASS(221)/(CSPEED*RLTIM(221))
        YMRCT(2)=YMIX(2)*RMASS(221)/(CSPEED*RLTIM(221))
      ENDIF
C---B DECAY PACKAGE
      IF (BDECAY.EQ.'EURO') THEN
        IF (IPRINT.NE.0) WRITE (6,470) 'EURODEC'
      ELSEIF (BDECAY.EQ.'CLEO') THEN
        IF (IPRINT.NE.0) WRITE (6,470) 'CLEO'
      ELSE
        BDECAY='HERW'
      ENDIF
  470 FORMAT (10X,A,' B DECAY PACKAGE WILL BE USED')
C---COMPUTE PARTICLE PROPERTIES FOR HADRONIZATION
      CALL HWURES
C Prepare internal decay tables and do diagnostic checks
      CALL HWUDKS
C Convert ampersands to backslahes in particle LaTeX names
      CALL HWUATS
C Print particle decay tables here
      IF (IPRINT.GE.2) CALL HWUDPR
C---MISCELLANEOUS DERIVED QUANTITIES
      TMTOP=2.*LOG(RMASS(6)/30.)
      PXRMS=PTRMS/SQRT(2.)
      ZBINM=0.25/ZBINM
      PSPLT(1)=1./PSPLT(1)
      PSPLT(2)=1./PSPLT(2)
      NDTRY=2*NCTRY
      NGSPL=0
      PGSMX=0.
      DO 480 I=1,4
      PGS=HWUPCM(RMASS(13),RMASS(I),RMASS(I))
      IF (PGS.GE.ZERO) NGSPL=I
      IF (PGS.GE.PGSMX) PGSMX=PGS
  480 PGSPL(I)=PGS
      CALL HWVZRO(6,PTINT)
      IF (IPRO.NE.80) THEN
C---SET UP TABLES OF SUDAKOV FORM FACTORS, GIVING
C   PROBABILITY DISTRIBUTION IN VARIABLE Q = E*SQRT(XI)
        NSUD=NFLAV
        CALL HWBSUD
C---SET PARAMETERS FOR SPACELIKE BRANCHING
        DO 500 I=1,NSUD
        DO 490 J=2,NQEV
        IF (QEV(J,I).GT.QSPAC) GOTO 500
  490   CONTINUE
  500   NSPAC(I)=J-1
      ENDIF
      EVWGT=AVWGT
      ISTAT=1
  999 END
CDECK  ID>, HWUINE.
*CMZ :-        -16/10/93  12.42.15  by  Mike Seymour
*-- Author :    Bryan Webber
C-----------------------------------------------------------------------
      SUBROUTINE HWUINE
C-----------------------------------------------------------------------
C     INITIALISES AN EVENT
C-----------------------------------------------------------------------
      INCLUDE 'HERWIG62.INC'
      DOUBLE PRECISION HWRGEN,HWRGET,DUMMY
      REAL TL
      LOGICAL CALLED
      EXTERNAL HWRGEN,HWRGET
      COMMON/HWDBUG/CALLED
C---CHECK THAT MAIN PROGRAM HAS BEEN MODIFIED CORRECTLY
      IF (NEVHEP.GT.0.AND..NOT.CALLED) THEN
        WRITE (6,10)
 10     FORMAT (1X,'A call to the subroutine HWUFNE should be added to',
     &      /,' the main program, immediately after the call to HWMEVT')
        CALL HWWARN('HWUINE',500,*999)
      ENDIF
      CALLED=.FALSE.
C---CHECK TIME LEFT
      CALL HWUTIM(TL)
      IF (TL.LT.TLOUT) CALL HWWARN('HWUINE',200,*999)
C---UPDATE RANDOM NUMBER SEED
      DUMMY = HWRGET(NRN)
      NEVHEP=NEVHEP+1
      NHEP=0
      ISTAT=6
      IERROR=0
      EVWGT=AVWGT
      HVFCEN=.FALSE.
      ISLENT=1
      NQDK=0
C---DECIDE WHETHER TO GENERATE SOFT UNDERLYING EVENT
      GENSOF=IPROC.GT.1000.AND.IPROC.LT.10000.AND.
     &      (IPROC.EQ.8000.OR.HWRGEN(0).LT.PRSOF)
C Zero arrays
      CALL HWVZRI(2*NMXHEP,JMOHEP)
      CALL HWVZRI(2*NMXHEP,JDAHEP)
      CALL HWVZRO(4*NMXHEP,VHEP)
      CALL HWVZRO(3*NMXHEP,RHOHEP)
      EMSCA=ZERO
  999 END
CDECK  ID>, HWULB4.
*CMZ :-        -05/11/95  19.33.42  by  Mike Seymour
*-- Author :    Adapted by Bryan Webber
C-----------------------------------------------------------------------
      SUBROUTINE HWULB4(PS,PI,PF)
C-----------------------------------------------------------------------
C     TRANSFORMS PI (GIVEN IN REST FRAME OF PS) INTO PF (IN LAB)
C     N.B. P(1,2,3,4) = (PX,PY,PZ,E); PS(5)=M
C-----------------------------------------------------------------------
      DOUBLE PRECISION PF4,FN,PS(5),PI(4),PF(4)
      IF (PS(4).EQ.PS(5)) THEN
        PF(1)= PI(1)
        PF(2)= PI(2)
        PF(3)= PI(3)
        PF(4)= PI(4)
      ELSE
        PF4  = (PI(1)*PS(1)+PI(2)*PS(2)
     &         +PI(3)*PS(3)+PI(4)*PS(4))/PS(5)
        FN   = (PF4+PI(4)) / (PS(4)+PS(5))
        PF(1)= PI(1) + FN*PS(1)
        PF(2)= PI(2) + FN*PS(2)
        PF(3)= PI(3) + FN*PS(3)
        PF(4)= PF4
      END IF
      END
CDECK  ID>, HWULDO.
*CMZ :-        -26/04/91  11.11.56  by  Bryan Webber
*-- Author :    Bryan Webber
C----------------------------------------------------------------------
      FUNCTION HWULDO(P,Q)
C----------------------------------------------------------------------
C   LORENTZ 4-VECTOR DOT PRODUCT
C----------------------------------------------------------------------
      DOUBLE PRECISION HWULDO,P(4),Q(4)
      HWULDO=P(4)*Q(4)-(P(1)*Q(1)+P(2)*Q(2)+P(3)*Q(3))
      END
CDECK  ID>, HWULF4.
*CMZ :-        -05/11/95  19.33.42  by  Mike Seymour
*-- Author :    Adapted by Bryan Webber
C-----------------------------------------------------------------------
      SUBROUTINE HWULF4(PS,PI,PF)
C-----------------------------------------------------------------------
C     TRANSFORMS PI (GIVEN IN LAB) INTO PF (IN REST FRAME OF PS)
C     N.B. P(1,2,3,4) = (PX,PY,PZ,E); PS(5)=M
C-----------------------------------------------------------------------
      DOUBLE PRECISION PF4,FN,PS(5),PI(4),PF(4)
      IF (PS(4).EQ.PS(5)) THEN
        PF(1)= PI(1)
        PF(2)= PI(2)
        PF(3)= PI(3)
        PF(4)= PI(4)
      ELSE
        PF4  = (PI(4)*PS(4)-PI(3)*PS(3)
     &         -PI(2)*PS(2)-PI(1)*PS(1))/PS(5)
        FN   = (PF4+PI(4)) / (PS(4)+PS(5))
        PF(1)= PI(1) - FN*PS(1)
        PF(2)= PI(2) - FN*PS(2)
        PF(3)= PI(3) - FN*PS(3)
        PF(4)= PF4
      END IF
      END
CDECK  ID>, HWULI2.
*CMZ :-        -23/08/94  13.22.29  by  Mike Seymour
*-- Author :    Ulrich Baur & Nigel Glover, adapted by Ian Knowles
C-----------------------------------------------------------------------
      FUNCTION HWULI2(X)
C-----------------------------------------------------------------------
C     Complex dilogarithm function, Li_2 (Spence function)
C-----------------------------------------------------------------------
      IMPLICIT NONE
      DOUBLE COMPLEX HWULI2,PROD,Y,Y2,X,Z
      DOUBLE PRECISION XR,XI,R2,A1,A2,A3,A4,A5,A6,A7,A8,A9,A10,ZETA2,
     & ZERO,ONE,HALF
      PARAMETER (ZERO=0.0D0, ONE=1.0D0, HALF=0.5D0)
      DATA A1,A2,A3,A4,A5,A6,A7,A8,A9,A10,ZETA2/ -0.250000000000000D0,
     & -0.111111111111111D0,-0.010000000000000D0,-0.017006802721088D0,
     & -0.019444444444444D0,-0.020661157024793D0,-0.021417300648069D0,
     & -0.021948866377231D0,-0.022349233811171D0,-0.022663689135191D0,
     &  1.644934066848226D0/
      PROD(Y,Y2)=Y*(ONE+A1*Y*(ONE+A2*Y*(ONE+A3*Y2*(ONE+A4*Y2*(ONE+A5*Y2*
     & (ONE+A6*Y2*(ONE+A7*Y2*(ONE+A8*Y2*(ONE+A9*Y2*(ONE+A10*Y2))))))))))
      XR=DREAL(X)
      XI=DIMAG(X)
      R2=XR*XR+XI*XI
      IF (R2.GT.ONE.AND.(XR/R2).GT.HALF) THEN
         Z=-LOG(ONE/X)
         HWULI2=PROD(Z,Z*Z)+ZETA2-LOG(X)*LOG(ONE-X)+HALF*LOG(X)**2
      ELSEIF (R2.GT.ONE.AND.(XR/R2).LE.HALF) THEN
         Z=-LOG(ONE-ONE/X)
         HWULI2=-PROD(Z,Z*Z)-ZETA2-HALF*LOG(-X)**2
      ELSEIF (R2.EQ.ONE.AND.XI.EQ.ZERO) THEN
         HWULI2=ZETA2
      ELSEIF (R2.LE.ONE.AND.XR.GT.HALF) THEN
         Z=-LOG(X)
         HWULI2=-PROD(Z,Z*Z)+ZETA2-LOG(X)*LOG(ONE-X)
      ELSE
         Z=-LOG(ONE-X)
         HWULI2=PROD(Z,Z*Z)
      ENDIF
      END
CDECK  ID>, HWULOB.
*CMZ :-        -05/11/95  19.33.42  by  Mike Seymour
*-- Author :    Adapted by Bryan Webber
C-----------------------------------------------------------------------
      SUBROUTINE HWULOB(PS,PI,PF)
C-----------------------------------------------------------------------
C     TRANSFORMS PI (GIVEN IN REST FRAME OF PS) INTO PF (IN LAB)
C     N.B. P(1,2,3,4,5) = (PX,PY,PZ,E,M)
C-----------------------------------------------------------------------
      DOUBLE PRECISION PS(5),PI(5),PF(5)
      CALL HWULB4(PS,PI,PF)
      PF(5)= PI(5)
      END
CDECK  ID>, HWULOF.
*CMZ :-        -05/11/95  19.33.42  by  Mike Seymour
*-- Author :    Adapted by Bryan Webber
C-----------------------------------------------------------------------
      SUBROUTINE HWULOF(PS,PI,PF)
C-----------------------------------------------------------------------
C     TRANSFORMS PI (GIVEN IN LAB) INTO PF (IN REST FRAME OF PS)
C     N.B. P(1,2,3,4,5) = (PX,PY,PZ,E,M)
C-----------------------------------------------------------------------
      DOUBLE PRECISION PS(5),PI(5),PF(5)
      CALL HWULF4(PS,PI,PF)
      PF(5)= PI(5)
      END
CDECK  ID>, HWULOR.
*CMZ :-        -26/04/91  11.11.56  by  Bryan Webber
*-- Author :    Giovanni Abbiendi & Luca Stanco
C-----------------------------------------------------------------------
      SUBROUTINE HWULOR (TRANSF,PI,PF)
C-----------------------------------------------------------------------
C     Makes the HWULOR transformation specified by TRANSF on the
C     quadrivector PI(5), giving PF(5).
C-----------------------------------------------------------------------
      DOUBLE PRECISION TRANSF(4,4),PI(5),PF(5)
      INTEGER I,J
      DO 1 I=1,5
        PF(I)=0.D0
    1 CONTINUE
      DO 3 I=1,4
       DO 2 J=1,4
         PF(I) = PF(I) + TRANSF(I,J) * PI(J)
    2  CONTINUE
    3 CONTINUE
      PF(5) = PI(5)
      RETURN
      END
CDECK  ID>, HWUMAS.
*CMZ :-        -26/04/91  11.11.56  by  Bryan Webber
*-- Author :    Bryan Webber
C-----------------------------------------------------------------------
      SUBROUTINE HWUMAS(P)
C-----------------------------------------------------------------------
C     PUTS INVARIANT MASS IN 5TH COMPONENT OF VECTOR
C     (NEGATIVE SIGN IF SPACELIKE)
C-----------------------------------------------------------------------
      DOUBLE PRECISION HWUSQR,P(5)
      EXTERNAL HWUSQR
      P(5)=HWUSQR((P(4)+P(3))*(P(4)-P(3))-P(1)**2-P(2)**2)
      END
CDECK  ID>, HWUMBW.
*CMZ :-        -21/02/98  11.11.56  by  Bryan Webber
*-- Author :    Bryan Webber
C-----------------------------------------------------------------------
      FUNCTION HWUMBW(ID)
C-----------------------------------------------------------------------
C     CHOOSES MASS ACCORDING TO BREIT-WIGNER DISTRIBUTION
C-----------------------------------------------------------------------
      INCLUDE 'HERWIG62.INC'
      DOUBLE PRECISION HWUMBW,HWRGEN,WMX,TAU,T
      INTEGER ID
C--WMX IS MAX NUMBER OF WIDTHS FROM NOMINAL MASS
      DATA WMX/10D0/
      SAVE WMX
      HWUMBW=RMASS(ID)
      TAU=RLTIM(ID)
      IF (TAU.EQ.ZERO.OR.TAU.GT.1D-18) RETURN
 1    T=HALF*TAN(PIFAC*(HWRGEN(0)-HALF))
      IF (ABS(T).GT.WMX) GO TO 1
      HWUMBW=HWUMBW+HBAR*T/TAU
      IF(HWUMBW.LT.ZERO) GOTO 1
      END
CDECK  ID>, HWUNST.
*CMZ :-        -27/07/99  13.33.03  by  Mike Seymour
*-- Author :    Ian Knowles
C-----------------------------------------------------------------------
      FUNCTION HWUNST(N)
C-----------------------------------------------------------------------
C     Creates a character string of length 7 equivalent to integer N
C-----------------------------------------------------------------------
      INTEGER N,I,M,NN(7)
      CHARACTER*1 NCHAR(0:9)
      CHARACTER*7 HWUNST
      DATA NCHAR/'0','1','2','3','4','5','6','7','8','9'/
      M=1
      DO 10 I=7,1,-1
      NN(I)=MOD(N/M,10)
  10  M=M*10
      WRITE(HWUNST,'(7A1)') (NCHAR(NN(I)),I=1,7)
      RETURN
      END
CDECK  ID>, HWUPCM.
*CMZ :-        -26/04/91  11.11.56  by  Bryan Webber
*-- Author :    Bryan Webber
C-----------------------------------------------------------------------
      FUNCTION HWUPCM(EM0,EM1,EM2)
C-----------------------------------------------------------------------
C     C.M. MOMENTUM FOR DECAY MASSES EM0 -> EM1 + EM2
C     SET TO -1 BELOW THRESHOLD
C-----------------------------------------------------------------------
      DOUBLE PRECISION HWUPCM,EM0,EM1,EM2,EMS,EMD
      EMS=ABS(EM1+EM2)
      EMD=ABS(EM1-EM2)
      IF (EM0.LT.EMS.OR.EM0.LT.EMD) THEN
        HWUPCM=-1.
      ELSEIF (EM0.EQ.EMS.OR.EM0.EQ.EMD) THEN
        HWUPCM=0.
      ELSE
        HWUPCM=SQRT((EM0+EMD)*(EM0-EMD)*
     &              (EM0+EMS)*(EM0-EMS))*.5/EM0
      ENDIF
      END
CDECK  ID>, HWURAP.
*CMZ :-        -26/04/91  11.11.56  by  Bryan Webber
*-- Author :    Bryan Webber
C-----------------------------------------------------------------------
      FUNCTION HWURAP(P)
C-----------------------------------------------------------------------
C     LONGITUDINAL RAPIDITY (SET TO +/-1000 IF TOO LARGE)
C-----------------------------------------------------------------------
      DOUBLE PRECISION HWURAP,EMT2,P(5),ZERO
      PARAMETER (ZERO=0.D0)
      EMT2=P(1)**2+P(2)**2+P(5)**2
      IF (P(3).GT.ZERO) THEN
        IF (EMT2.EQ.ZERO) THEN
          HWURAP=1000.
        ELSE
          HWURAP= 0.5*LOG((P(3)+P(4))**2/EMT2)
        ENDIF
      ELSEIF (P(3).LT.ZERO) THEN
        IF (EMT2.EQ.ZERO) THEN
          HWURAP=-1000.
        ELSE
          HWURAP=-0.5*LOG((P(3)-P(4))**2/EMT2)
        ENDIF
      ELSE
          HWURAP=0.
      ENDIF
      END
CDECK  ID>, HWUMPO.
*CMZ :-        -26/11/00  17.21.55  by  Bryan Webber
*-- Author :  Kosuke Odagiri
C-----------------------------------------------------------------------
      SUBROUTINE HWUMPO(P,M,PMM,MGAM,PPROJ,FPROP)
C-----------------------------------------------------------------------
C     RETURNS PROJECTION OPERATOR 1/(P-SLASH - M + I*MGAM) IN WEYL-BASIS
C     USED IN SUBROUTINE HWH2QH
C-----------------------------------------------------------------------
      DOUBLE PRECISION P(0:3),M,PMM,MGAM,ZERO,ONE
      DOUBLE COMPLEX PROP, PPROJ(4,4), CZERO
      LOGICAL FPROP
      PARAMETER (ZERO=0.D0,CZERO=(0.D0,0.D0),ONE=1.D0)
      IF (FPROP) THEN
       PROP=ONE/DCMPLX(PMM,MGAM)
      ELSE
       PROP=DCMPLX(ONE/PMM, ZERO)
      END IF
      PPROJ(1,1) =  M*PROP
      PPROJ(1,2) =  CZERO
      PPROJ(2,1) =  CZERO
      PPROJ(2,2) =  PPROJ(1,1)
      PPROJ(1,3) = (P(0)-P(3))*PROP
      PPROJ(1,4) =  DCMPLX(-P(1),P(2))*PROP
      PPROJ(2,3) =  DCMPLX(-P(1),-P(2))*PROP
      PPROJ(2,4) = (P(0)+P(3))*PROP
      PPROJ(3,1) =  PPROJ(2,4)
      PPROJ(3,2) = -PPROJ(1,4)
      PPROJ(4,1) = -PPROJ(2,3)
      PPROJ(4,2) =  PPROJ(1,3)
      PPROJ(3,3) =  PPROJ(1,1)
      PPROJ(3,4) =  CZERO
      PPROJ(4,3) =  CZERO
      PPROJ(4,4) =  PPROJ(1,1)
      RETURN
      END
CDECK  ID>, HWUMPP.
*CMZ :-        -26/11/00  17.21.55  by  Bryan Webber
*-- Author :  Kosuke Odagiri
C-----------------------------------------------------------------------
      SUBROUTINE HWUMPP(M,GPM,PERM,U,UU,LR)
C-----------------------------------------------------------------------
C     APPLIES OPERATOR FROM HWUMPO ON SPINORS.
C     SPINOR COMPONENTS CAN BE PERMUTATED (PERM) AND TRANSVERSED (LR)
C-----------------------------------------------------------------------
      DOUBLE COMPLEX U(4), TEMP, A(4,4), M(16), UU(4), CZERO
      DOUBLE PRECISION GPM(2), FAC, ZERO, ONE, MONE
      INTEGER LR,TV(4,4,2),I,J, PERM(4), IZERO, GTOF(4)
      PARAMETER (ZERO=0.D0,CZERO=(0.D0,0.D0),IZERO=0)
      PARAMETER (ONE =1.D0,MONE = -1.D0)
      DATA GTOF/1,1,2,2/
      DATA TV/1,2,3,4,5,6,7,8,9,10,11,12,13,14,15,16,
     &        1,5,9,13,2,6,10,14,3,7,11,15,4,8,12,16/
      SAVE GTOF
      DO I=1,4
       FAC = GPM(GTOF(I))
       IF ((PERM(I).EQ.IZERO).OR.(FAC.EQ.ZERO)) THEN
        DO J=1,4
         A(I,J)=CZERO
        END DO
       ELSE
        IF(FAC.EQ.ONE) THEN
         TEMP = U(PERM(I))
        ELSEIF(FAC.EQ.MONE) THEN
         TEMP = -U(PERM(I))
        ELSE
         TEMP = FAC*U(PERM(I))
        ENDIF
        IF(TEMP.NE.ZERO) THEN
         DO J=1,4
          IF(M(TV(I,J,LR)).NE.ZERO) THEN
           A(I,J)=TEMP*M(TV(I,J,LR))
          ELSE
           A(I,J)=ZERO
          ENDIF
         END DO
        ELSE
         DO J=1,4
          A(I,J)=ZERO
         END DO
        END IF
       END IF
      END DO
      DO J=1,4
       UU(J)=A(1,J)+A(2,J)+A(3,J)+A(4,J)
      END DO
      RETURN
      END
CDECK  ID>, HWURES.
*CMZ :-        -26/04/91  11.11.56  by  Bryan Webber
*-- Author :    Ian Knowles & Bryan Webber
C-----------------------------------------------------------------------
      SUBROUTINE HWURES
C-----------------------------------------------------------------------
C     Using properties of particle I supplied in HWUDAT checks particles
C     and antiparticles have compatible properties and sets   SWTEF(I) =
C     ( rep. enhancement factor)^2  - used in cluster decays
C     Finds iso-flavour hadrons and creates pointers for cluster decays.
C     Sets CLDKWT(K) =(2J+1) spin weight normalizing largest value to 1.
C-----------------------------------------------------------------------
      INCLUDE 'HERWIG62.INC'
      INTEGER NMXTMP
      PARAMETER (NMXTMP=20)
      DOUBLE PRECISION EPS,WTMX,REMMN,RWTMX,WTMP,RESTMP(91),WTMX2,
     & REMMN2,WT,CDWTMP(NMXTMP)
      INTEGER HWUANT,MAPF(89),MAPC(12,12),I,IANT,IABPDG,J,L,N,K,LTMP,
     & NCDKS,IMN,ITMP,LOCTMP(91),NTMP,NCDTMP(NMXTMP),IMN2
      EXTERNAL HWUANT
      PARAMETER (EPS=1.D-6)
      DATA MAPF/21,31,41,51,61,12,32,42,52,62,13,23,43,53,63,14,24,34,
     & 44,54,64,15,25,35,45,55,65,16,26,36,46,56,66,111,112,113,122,123,
     & 133,222,223,233,333,-111,-112,-113,-122,-123,-133,-222,-223,-233,
     & -333,114,124,134,224,234,334,-114,-124,-134,-224,-234,-334,115,
     & 125,135,225,235,335,-115,-125,-135,-225,-235,-335,116,126,136,
     & 226,236,336,-116,-126,-136,-226,-236,-336/
      DATA MAPC/90,1,2,47,45,44,48,46,49,3,4,5,6,90,7,50,47,45,51,48,52,
     & 8,9,10,11,12,91,51,48,46,52,49,53,13,14,15,37,40,41,6*0,57,69,81,
     & 35,37,38,6*0,55,67,79,34,35,36,6*0,54,66,78,38,41,42,6*0,58,70,
     & 82,36,38,39,6*0,56,68,80,39,42,43,6*0,59,71,83,16,17,18,63,61,60,
     & 64,62,65,19,20,21,22,23,24,75,73,72,76,74,77,25,26,27,28,29,30,
     & 87,85,84,88,86,89,31,32,33/
C Check particle/anti-particle properties are compatible
      WRITE(6,10)
  10  FORMAT(/10X,'Checking consistency of particle properties'/)
      DO 20 I=10,NRES
      IF (IDPDG(I).GT.0) THEN
        IANT=HWUANT(I)
        IF (IANT.EQ.20) GOTO 20
        IF (MOD(IDPDG(I)/1000,10).EQ.0.AND.
     &      MOD(IDPDG(I)/100 ,10).NE.0) THEN
          IF (MOD(IFLAV(I)/10-IFLAV(IANT),10).NE.0.OR.
     &        MOD(IFLAV(I)-IFLAV(IANT)/10,10).NE.0)
     &     WRITE(6,30) RNAME(I),IFLAV(I),IFLAV(IANT)
        ELSE
          IF (IFLAV(I)+IFLAV(IANT).NE.0)
     &     WRITE(6,30) RNAME(I),IFLAV(I),IFLAV(IANT)
        ENDIF
        IF (ICHRG(I)+ICHRG(IANT).NE.0)
     &   WRITE(6,40) RNAME(I),RNAME(IANT),ICHRG(I),ICHRG(IANT)
        IF (ABS(RMASS(I)-RMASS(IANT)).GT.EPS)
     &   WRITE(6,50) RNAME(I),RMASS(I),RMASS(IANT)
        IF (ABS(RLTIM(I)-RLTIM(IANT)).GT.EPS)
     &   WRITE(6,60) RNAME(I),RLTIM(I),RLTIM(IANT)
        IF (ABS(RSPIN(I)-RSPIN(IANT)).GT.EPS)
     &   WRITE(6,70) RNAME(I),RSPIN(I),RSPIN(IANT)
      ENDIF
  20  CONTINUE
  30  FORMAT(10X,A8,' flavour code=',I4,5X,' antiparticle=',I4)
  40  FORMAT(10X,2A8,' charge      =',I2,7X,' antiparticle=',I2)
  50  FORMAT(10X,A8,' mass        =',F7.3,2X,' antiparticle=',F7.3)
  60  FORMAT(10X,A8,' life time   =',E9.3,' antiparticle=',E9.3)
  70  FORMAT(10X,A8,' spin        =',F3.1,6X,' antiparticle=',F3.1)
C Compute resonance properties
      DO 80 I=21,NRES
C Compute representation weights for hadrons, used in cluster decays
      IABPDG=ABS(IDPDG(I))
      J=MOD(IABPDG,10)
      IF (J.EQ.2.AND.MOD(IABPDG/100,10).LT.MOD(IABPDG/10,10)) THEN
C Singlet (Lambda-like) baryon
        SWTEF(I)=SNGWT**2
      ELSEIF (J.EQ.4) THEN
C Decuplet baryon
        SWTEF(I)=DECWT**2
      ELSEIF(2*(J/2).NE.J) THEN
C Mesons: identify by spin, angular momentum & radial excitation
        J=(J-1)/2
        L= MOD(IABPDG/10000 ,10)
        N= MOD(IABPDG/100000,10)
        IF (L.EQ.0.AND.J.EQ.0.AND.N.EQ.0.OR.
     &      L.GT.3.OR. J.GT.4.OR .N.GT.4) THEN
          SWTEF(I)=1.
        ELSE
          SWTEF(I)=REPWT(L,J,N)**2
        ENDIF
      ELSE
C Not recognized
        SWTEF(I)=1.
      ENDIF
  80  CONTINUE
C Prepare tables for cluster decays, except flavourless light mesons
      LTMP=1
      NCDKS=0
      DO 120 I=1,89
C Store particles, flavour MAPF(I), noting highest spin and lowest mass
      WTMX=0.
      REMMN=1000.
      DO 90 J=21,NRES
      IF (VTOCDK(J).OR.IFLAV(J).NE.MAPF(I)) GOTO 90
      NCDKS=NCDKS+1
      IF (NCDKS.GT.NMXCDK) CALL HWWARN('HWURES',101,*999)
      NCLDK(NCDKS)=J
      CLDKWT(NCDKS)=TWO*RSPIN(J)+ONE
      IF (CLDKWT(NCDKS).GT.WTMX) WTMX=CLDKWT(NCDKS)
      IF (RMASS(J).LT.REMMN) THEN
        REMMN=RMASS(J)
        IMN=NCDKS
      ENDIF
  90  CONTINUE
      IF (NCDKS+1-LTMP.EQ.0) THEN
        WRITE(6,100) MAPF(I)
  100   FORMAT(1X,'No particles exist for a cluster with flavour, ',I4,
     &            ' to decay into')
        CALL HWWARN('HWURES',51,*120)
      ENDIF
C Set scaled spin weights
      RWTMX=1./WTMX
      DO 110 J=LTMP,NCDKS
  110 CLDKWT(J)=CLDKWT(J)*RWTMX
C Swap order if lightest hadron of given flavour not first
      IF (IMN.NE.LTMP) THEN
        ITMP=NCLDK(LTMP)
        WTMP=CLDKWT(LTMP)
        NCLDK(LTMP)=NCLDK(IMN)
        CLDKWT(LTMP)=CLDKWT(IMN)
        NCLDK(IMN)=ITMP
        CLDKWT(IMN)=WTMP
      ENDIF
C Set pointers etc
      LOCTMP(I)=LTMP
      RESTMP(I)=FLOAT(NCDKS+1-LTMP)
      LTMP=NCDKS+1
  120 CONTINUE
C Now do flavourless light mesons, allowing for mixing in weights
      WTMX=0.
      REMMN=1000.
      WTMX2=0.
      REMMN2=1000.
      NTMP=0
      DO 140 J=21,NRES
      IF (VTOCDK(J)) THEN
        GOTO 140
C Calculate mixing weight for (|uubar>+|ddbar>)/sqrt(2) component
      ELSEIF (IFLAV(J).EQ.11) THEN
        WT=1.
      ELSEIF (IFLAV(J).EQ.33) THEN
C eta - eta'
        IF     (J.EQ.22 ) THEN
          WT=COS(ETAMIX*PIFAC/180.+ATAN(SQRT(TWO)))**2
        ELSEIF (J.EQ.25 ) THEN
          WT=SIN(ETAMIX*PIFAC/180.+ATAN(SQRT(TWO)))**2
C phi - omega
        ELSEIF (J.EQ.56 ) THEN
          WT=COS(PHIMIX*PIFAC/180.+ATAN(SQRT(TWO)))**2
        ELSEIF (J.EQ.24 ) THEN
          WT=SIN(PHIMIX*PIFAC/180.+ATAN(SQRT(TWO)))**2
C f'_2 - f_2
        ELSEIF (J.EQ.58 ) THEN
          WT=COS(F2MIX *PIFAC/180.+ATAN(SQRT(TWO)))**2
        ELSEIF (J.EQ.26 ) THEN
          WT=SIN(F2MIX *PIFAC/180.+ATAN(SQRT(TWO)))**2
C f_1(1420) - f_1(1285)
        ELSEIF (J.EQ.57 ) THEN
          WT=COS(F1MIX *PIFAC/180.+ATAN(SQRT(TWO)))**2
        ELSEIF (J.EQ.28 ) THEN
          WT=SIN(F1MIX *PIFAC/180.+ATAN(SQRT(TWO)))**2
C h_1(1380) - h_1(1170)
        ELSEIF (J.EQ.289) THEN
          WT=COS(H1MIX *PIFAC/180.+ATAN(SQRT(TWO)))**2
        ELSEIF (J.EQ.288) THEN
          WT=SIN(H1MIX *PIFAC/180.+ATAN(SQRT(TWO)))**2
C MISSING - f_0(1370)
        ELSEIF (J.EQ.294) THEN
          WT=SIN(F0MIX *PIFAC/180.+ATAN(SQRT(TWO)))**2
C phi_3 - omega_3
        ELSEIF (J.EQ.396) THEN
          WT=COS(PH3MIX*PIFAC/180.+ATAN(SQRT(TWO)))**2
        ELSEIF (J.EQ.395) THEN
          WT=SIN(PH3MIX*PIFAC/180.+ATAN(SQRT(TWO)))**2
C eta_2(1645) - eta_2(1870)
        ELSEIF (J.EQ.397) THEN
          WT=COS(ET2MIX*PIFAC/180.+ATAN(SQRT(TWO)))**2
        ELSEIF (J.EQ.398) THEN
          WT=SIN(ET2MIX*PIFAC/180.+ATAN(SQRT(TWO)))**2
C MISSING - omega(1600)
        ELSEIF (J.EQ.399) THEN
          WT=SIN(OMHMIX*PIFAC/180.+ATAN(SQRT(TWO)))**2
        ELSE
          WT=1./3.
          WRITE(6,130) J
  130   FORMAT(1X,'Isoscalar particle ',I3,' not recognised,',
     &            ' no I=0 mixing assumed')
        ENDIF
      ELSE
        GOTO 140
      ENDIF
      IF (WT.GT.EPS) THEN
        NCDKS=NCDKS+1
        IF (NCDKS.GT.NMXCDK) CALL HWWARN('HWURES',102,*999)
        NCLDK(NCDKS)=J
        CLDKWT(NCDKS)=WT*(TWO*RSPIN(J)+ONE)
        IF (CLDKWT(NCDKS).GT.WTMX) WTMX=CLDKWT(NCDKS)
        IF (RMASS(J).LT.REMMN) THEN
          REMMN=RMASS(J)
          IMN=NCDKS
        ENDIF
      ENDIF
      IF (ONE-WT.GT.EPS) THEN
        NTMP=NTMP+1
        IF (NTMP.GT.NMXTMP) CALL HWWARN('HWURES',103,*999)
        NCDTMP(NTMP)=J
        CDWTMP(NTMP)=(ONE-WT)*(TWO*RSPIN(J)+ONE)
        IF (CDWTMP(NTMP).GT.WTMX2) WTMX2=CDWTMP(NTMP)
        IF (RMASS(J).LT.REMMN2) THEN
          REMMN2=RMASS(J)
          IMN2=NTMP
        ENDIF
      ENDIF
  140 CONTINUE
      IF (NCDKS+1-LTMP.EQ.0) THEN
        WRITE(6,100) 11
        CALL HWWARN('HWURES',52,*160)
      ENDIF
C Normalize scaled spin weights
      RWTMX=1./WTMX
      DO 150 I=LTMP,NCDKS
  150 CLDKWT(I)=CLDKWT(I)*RWTMX
C Swap order if lightest hadron of flavour 11 not first
      IF (IMN.NE.LTMP) THEN
        ITMP=NCLDK(LTMP)
        WTMP=CLDKWT(LTMP)
        NCLDK(LTMP)=NCLDK(IMN)
        CLDKWT(LTMP)=CLDKWT(IMN)
        NCLDK(IMN)=ITMP
        CLDKWT(IMN)=WTMP
      ENDIF
  160 IF (NTMP.EQ.0) THEN
        WRITE(6,100) 33
        CALL HWWARN('HWURES',53,*180)
      ENDIF
      IF (NCDKS+NTMP.GT.NMXCDK) CALL HWWARN('HWURES',104,*999)
C Store hadrons for |ssbar> channel and normalize their weights
      RWTMX=1./WTMX2
      DO 170 I=1,NTMP
      J=NCDKS+I
      NCLDK(J)=NCDTMP(I)
  170 CLDKWT(J)=CDWTMP(I)*RWTMX
C Swap order if lightest hadron of flavour 33 not first
      IF (IMN2.NE.1) THEN
        ITMP=NCLDK(NCDKS+1)
        WTMP=CLDKWT(NCDKS+1)
        NCLDK(NCDKS+1)=NCLDK(NCDKS+IMN2)
        CLDKWT(NCDKS+1)=CLDKWT(NCDKS+IMN2)
        NCLDK(NCDKS+IMN2)=ITMP
        CLDKWT(NCDKS+IMN2)=WTMP
      ENDIF
C Set pointers etc
  180 LOCTMP(90)=LTMP
      RESTMP(90)=FLOAT(NCDKS+1-LTMP)
      LOCTMP(91)=NCDKS+1
      RESTMP(91)=FLOAT(NTMP)
C Set pointers to hadrons of given flavours for cluster decays
      DO 190 I=1,12
      DO 190 J=1,12
      K=MAPC(I,J)
      IF (K.EQ.0) THEN
        RMIN(I,J)=RMASS(NCLDK(LOCN(I,2)))+RMASS(NCLDK(LOCN(I,2)))+1.D-2
      ELSE
        LOCN(I,J)=LOCTMP(K)
        RESN(I,J)=RESTMP(K)
        RMIN(I,J)=RMASS(NCLDK(LOCN(I,J)))
      ENDIF
  190 CONTINUE
  999 END
CDECK  ID>, HWUROB.
*CMZ :-        -26/04/91  11.11.56  by  Bryan Webber
*-- Author :    Bryan Webber
C-----------------------------------------------------------------------
      SUBROUTINE HWUROB(R,P,Q)
C-----------------------------------------------------------------------
C     ROTATES VECTORS BY INVERSE OF ROTATION MATRIX R
C-----------------------------------------------------------------------
      DOUBLE PRECISION S1,S2,S3,R(3,3),P(3),Q(3)
      S1=P(1)*R(1,1)+P(2)*R(2,1)+P(3)*R(3,1)
      S2=P(1)*R(1,2)+P(2)*R(2,2)+P(3)*R(3,2)
      S3=P(1)*R(1,3)+P(2)*R(2,3)+P(3)*R(3,3)
      Q(1)=S1
      Q(2)=S2
      Q(3)=S3
      END
CDECK  ID>, HWUROF.
*CMZ :-        -26/04/91  11.11.56  by  Bryan Webber
*-- Author :    Bryan Webber
C-----------------------------------------------------------------------
      SUBROUTINE HWUROF(R,P,Q)
C-----------------------------------------------------------------------
C     ROTATES VECTORS BY ROTATION MATRIX R
C-----------------------------------------------------------------------
      DOUBLE PRECISION S1,S2,S3,R(3,3),P(3),Q(3)
      S1=R(1,1)*P(1)+R(1,2)*P(2)+R(1,3)*P(3)
      S2=R(2,1)*P(1)+R(2,2)*P(2)+R(2,3)*P(3)
      S3=R(3,1)*P(1)+R(3,2)*P(2)+R(3,3)*P(3)
      Q(1)=S1
      Q(2)=S2
      Q(3)=S3
      END
CDECK  ID>, HWUROT.
*CMZ :-        -26/04/91  11.11.56  by  Bryan Webber
*-- Author :    Bryan Webber
C-----------------------------------------------------------------------
      SUBROUTINE HWUROT(P,CP,SP,R)
C-----------------------------------------------------------------------
C     R IS ROTATION MATRIX TO GET FROM VECTOR P TO Z AXIS, FOLLOWED BY
C     A ROTATION BY PSI ABOUT Z AXIS, WHERE CP = COS-PSI, SP = SIN-PSI
C-----------------------------------------------------------------------
      DOUBLE PRECISION WN,CP,SP,PTCUT,PP,PT,CT,ST,CF,SF,P(3),R(3,3)
      DATA WN,PTCUT/1.,1.D-20/
      PT=P(1)**2+P(2)**2
      PP=P(3)**2+PT
      IF (PT.LE.PP*PTCUT) THEN
         CT=SIGN(WN,P(3))
         ST=0.
         CF=1.
         SF=0.
      ELSE
         PP=SQRT(PP)
         PT=SQRT(PT)
         CT=P(3)/PP
         ST=PT/PP
         CF=P(1)/PT
         SF=P(2)/PT
      END IF
      R(1,1)= CP*CF*CT+SP*SF
      R(1,2)= CP*SF*CT-SP*CF
      R(1,3)=-CP*ST
      R(2,1)=-CP*SF+SP*CF*CT
      R(2,2)= CP*CF+SP*SF*CT
      R(2,3)=-SP*ST
      R(3,1)= CF*ST
      R(3,2)= SF*ST
      R(3,3)= CT
      END
CDECK  ID>, HWUSOR.
*CMZ :-        -26/04/91  11.11.56  by  Bryan Webber
*-- Author :    Adapted by Bryan Webber
C-----------------------------------------------------------------------
      SUBROUTINE HWUSOR(A,N,K,IOPT)
C-----------------------------------------------------------------------
C     Sort A(N) into ascending order
C     IOPT = 1 : return sorted A and index array K
C     IOPT = 2 : return index array K only
C-----------------------------------------------------------------------
      DOUBLE PRECISION A(N),B(500)
      INTEGER N,I,J,IOPT,K(N),IL(500),IR(500)
      IF (N.GT.500) CALL HWWARN('HWUSOR',100,*999)
      IL(1)=0
      IR(1)=0
      DO 10 I=2,N
      IL(I)=0
      IR(I)=0
      J=1
   2  IF(A(I).GT.A(J)) GOTO 5
   3  IF(IL(J).EQ.0) GOTO 4
      J=IL(J)
      GOTO 2
   4  IR(I)=-J
      IL(J)=I
      GOTO 10
   5  IF(IR(J).LE.0) GOTO 6
      J=IR(J)
      GOTO 2
   6  IR(I)=IR(J)
      IR(J)=I
  10  CONTINUE
      I=1
      J=1
      GOTO 8
  20  J=IL(J)
   8  IF(IL(J).GT.0) GOTO 20
   9  K(I)=J
      B(I)=A(J)
      I=I+1
      IF(IR(J)) 12,30,13
  13  J=IR(J)
      GOTO 8
  12  J=-IR(J)
      GOTO 9
  30  IF(IOPT.EQ.2) RETURN
      DO 31 I=1,N
  31  A(I)=B(I)
 999  END
CDECK  ID>, HWUSQR.
*CMZ :-        -26/04/91  11.11.56  by  Bryan Webber
*-- Author :    Bryan Webber
C-----------------------------------------------------------------------
      FUNCTION HWUSQR(X)
C-----------------------------------------------------------------------
C     SQUARE ROOT WITH SIGN RETENTION
C-----------------------------------------------------------------------
      DOUBLE PRECISION HWUSQR,X
      HWUSQR=SIGN(SQRT(ABS(X)),X)
      END
CDECK  ID>, HWUSTA.
*CMZ :-        -26/04/91  10.18.58  by  Bryan Webber
*-- Author :    Bryan Webber
C-----------------------------------------------------------------------
      SUBROUTINE HWUSTA(NAME)
C-----------------------------------------------------------------------
C     MAKES PARTICLE TYPE 'NAME' STABLE
C-----------------------------------------------------------------------
      INCLUDE 'HERWIG62.INC'
      INTEGER IPDG,IWIG
      CHARACTER*8 NAME
      CALL HWUIDT(3,IPDG,IWIG,NAME)
      IF (IWIG.EQ.20) CALL HWWARN('HWUSTA',500,*999)
      RSTAB(IWIG)=.TRUE.
      WRITE (6,10) IWIG,NAME
   10 FORMAT(/10X,'PARTICLE TYPE',I4,'=',A8,' SET STABLE')
  999 END
CDECK  ID>, HWUTAB.
*CMZ :-        -26/04/91  11.11.56  by  Bryan Webber
*-- Author :    Adapted by Bryan Webber
C-----------------------------------------------------------------------
      FUNCTION HWUTAB(F,A,NN,X,MM)
C-----------------------------------------------------------------------
C     MODIFIED CERN INTERPOLATION ROUTINE DIVDIF
C-----------------------------------------------------------------------
      IMPLICIT NONE
      INTEGER NN,MM,MMAX,N,M,MPLUS,IX,IY,MID,NPTS,IP,I,J,L,ISUB
      DOUBLE PRECISION HWUTAB,SUM,X,F(NN),A(NN),T(20),D(20)
      LOGICAL EXTRA
      DATA MMAX/10/
      N=NN
      M=MIN(MM,MMAX,N-1)
      MPLUS=M+1
      IX=0
      IY=N+1
      IF (A(1).GT.A(N)) GOTO 4
    1 MID=(IX+IY)/2
      IF (X.GE.A(MID)) GOTO 2
      IY=MID
      GOTO 3
    2 IX=MID
    3 IF (IY-IX.GT.1) GOTO 1
      GOTO 7
    4 MID=(IX+IY)/2
      IF (X.LE.A(MID)) GOTO 5
      IY=MID
      GOTO 6
    5 IX=MID
    6 IF (IY-IX.GT.1) GOTO 4
    7 NPTS=M+2-MOD(M,2)
      IP=0
      L=0
      GOTO 9
    8 L=-L
      IF (L.GE.0) L=L+1
    9 ISUB=IX+L
      IF ((1.LE.ISUB).AND.(ISUB.LE.N)) GOTO 10
      NPTS=MPLUS
      GOTO 11
   10 IP=IP+1
      T(IP)=A(ISUB)
      D(IP)=F(ISUB)
   11 IF (IP.LT.NPTS) GOTO 8
      EXTRA=NPTS.NE.MPLUS
      DO 14 L=1,M
      IF (.NOT.EXTRA) GOTO 12
      ISUB=MPLUS-L
      D(M+2)=(D(M+2)-D(M))/(T(M+2)-T(ISUB))
   12 I=MPLUS
      DO 13 J=L,M
      ISUB=I-L
      D(I)=(D(I)-D(I-1))/(T(I)-T(ISUB))
      I=I-1
   13 CONTINUE
   14 CONTINUE
      SUM=D(MPLUS)
      IF (EXTRA) SUM=0.5*(SUM+D(M+2))
      J=M
      DO 15 L=1,M
      SUM=D(J)+(X-T(J))*SUM
      J=J-1
   15 CONTINUE
      HWUTAB=SUM
      END
CDECK  ID>, HWUTIM.
*CMZ :-        -26/04/91  11.38.43  by  Federico Carminati
*-- Author :    Federico Carminati
C-----------------------------------------------------------------------
      SUBROUTINE HWUTIM(TRES)
C-----------------------------------------------------------------------
      CALL TIMEL(TRES)
      END
CDECK  ID>, HWVDIF.
*CMZ :-        -26/04/91  11.11.56  by  Bryan Webber
*-- Author :    Bryan Webber
C-----------------------------------------------------------------------
      SUBROUTINE HWVDIF(N,P,Q,R)
C-----------------------------------------------------------------------
C     VECTOR DIFFERENCE
C-----------------------------------------------------------------------
      DOUBLE PRECISION P(N),Q(N),R(N)
      INTEGER N,I
      DO 10 I=1,N
   10 R(I)=P(I)-Q(I)
      END
CDECK  ID>, HWVDOT.
*CMZ :-        -26/04/91  11.11.56  by  Bryan Webber
*-- Author :    Bryan Webber
C-----------------------------------------------------------------------
      FUNCTION HWVDOT(N,P,Q)
C-----------------------------------------------------------------------
C     VECTOR DOT PRODUCT
C-----------------------------------------------------------------------
      DOUBLE PRECISION HWVDOT,PQ,P(N),Q(N)
      INTEGER N,I
      PQ=0.
      DO 10 I=1,N
   10 PQ=PQ+P(I)*Q(I)
      HWVDOT=PQ
      END
CDECK  ID>, HWVEQU.
*CMZ :-        -26/04/91  11.11.56  by  Bryan Webber
*-- Author :    Bryan Webber
C-----------------------------------------------------------------------
      SUBROUTINE HWVEQU(N,P,Q)
C-----------------------------------------------------------------------
C     VECTOR EQUALITY
C-----------------------------------------------------------------------
      DOUBLE PRECISION P(N),Q(N)
      INTEGER N,I
      DO 10 I=1,N
   10 Q(I)=P(I)
      END
CDECK  ID>, HWVSCA.
*CMZ :-        -26/04/91  11.11.56  by  Bryan Webber
*-- Author :    Bryan Webber
C-----------------------------------------------------------------------
      SUBROUTINE HWVSCA(N,C,P,Q)
C-----------------------------------------------------------------------
C     VECTOR TIMES SCALAR
C-----------------------------------------------------------------------
      DOUBLE PRECISION C,P(N),Q(N)
      INTEGER N,I
      DO 10 I=1,N
   10 Q(I)=C*P(I)
      END
CDECK  ID>, HWVSUM.
*CMZ :-        -26/04/91  11.11.56  by  Bryan Webber
*-- Author :    Bryan Webber
C-----------------------------------------------------------------------
      SUBROUTINE HWVSUM(N,P,Q,R)
C-----------------------------------------------------------------------
C    VECTOR SUM
C-----------------------------------------------------------------------
      DOUBLE PRECISION P(N),Q(N),R(N)
      INTEGER N,I
      DO 10 I=1,N
   10 R(I)=P(I)+Q(I)
      END
CDECK  ID>, HWVZRI.
*CMZ :-        -05/02/98  11.11.56  by  Bryan Webber
*-- Author :    Bryan Webber
C-----------------------------------------------------------------------
      SUBROUTINE HWVZRI(N,IP)
C-----------------------------------------------------------------------
C     ZERO INTEGER VECTOR
C-----------------------------------------------------------------------
      INTEGER N,IP(N),I
      DO 10 I=1,N
   10 IP(I)=0
      END
CDECK  ID>, HWVZRO.
*CMZ :-        -26/04/91  11.11.56  by  Bryan Webber
*-- Author :    Bryan Webber
C-----------------------------------------------------------------------
      SUBROUTINE HWVZRO(N,P)
C-----------------------------------------------------------------------
C     ZERO VECTOR
C-----------------------------------------------------------------------
      DOUBLE PRECISION P(N)
      INTEGER N,I
      DO 10 I=1,N
   10 P(I)=0D0
      END
CDECK  ID>, HWWARN.
*CMZ :-        -26/04/91  10.18.58  by  Bryan Webber
*-- Author :    Bryan Webber
C-----------------------------------------------------------------------
      SUBROUTINE HWWARN(SUBRTN,ICODE,*)
C-----------------------------------------------------------------------
C     DEALS WITH ERRORS DURING EXECUTION
C     SUBRTN = NAME OF CALLING SUBROUTINE
C     ICODE  = ERROR CODE:    - -1 NONFATAL, KILL EVENT & PRINT NOTHING
C                            0- 49 NONFATAL, PRINT WARNING & CONTINUE
C                           50- 99 NONFATAL, PRINT WARNING & JUMP
C                          100-199 NONFATAL, DUMP & KILL EVENT
C                          200-299    FATAL, TERMINATE RUN
C                          300-399    FATAL, DUMP EVENT & TERMINATE RUN
C                          400-499    FATAL, DUMP EVENT & STOP DEAD
C                          500-       FATAL, STOP DEAD WITH NO DUMP
C-----------------------------------------------------------------------
      INCLUDE 'HERWIG62.INC'
      INTEGER ICODE
      CHARACTER*6 SUBRTN
      IF (ICODE.GE.0) WRITE (6,10) SUBRTN,ICODE
   10 FORMAT(/' HWWARN CALLED FROM SUBPROGRAM ',A6,': CODE =',I4)
      IF (ICODE.LT.0) THEN
         IERROR=ICODE
         RETURN 1
      ELSEIF (ICODE.LT.100) THEN
         WRITE (6,20) NEVHEP,NRN,EVWGT
   20    FORMAT(' EVENT',I8,':   SEEDS =',I11,' &',I11,
     &'  WEIGHT =',E11.4/' EVENT SURVIVES. EXECUTION CONTINUES')
         IF (ICODE.GT.49) RETURN 1
      ELSEIF (ICODE.LT.200) THEN
         WRITE (6,30) NEVHEP,NRN,EVWGT
   30    FORMAT(' EVENT',I8,':   SEEDS =',I11,' &',I11,
     &'  WEIGHT =',E11.4/' EVENT KILLED.   EXECUTION CONTINUES')
         IERROR=ICODE
         RETURN 1
      ELSEIF (ICODE.LT.300) THEN
         WRITE (6,40)
   40    FORMAT(' EVENT SURVIVES.  RUN ENDS GRACEFULLY')
         CALL HWEFIN
         CALL HWAEND
         STOP
      ELSEIF (ICODE.LT.400) THEN
         WRITE (6,50)
   50    FORMAT(' EVENT KILLED: DUMP FOLLOWS.  RUN ENDS GRACEFULLY')
         IERROR=ICODE
         CALL HWUEPR
         CALL HWUBPR
         CALL HWEFIN
         CALL HWAEND
         STOP
      ELSEIF (ICODE.LT.500) THEN
         WRITE (6,60)
   60    FORMAT(' EVENT KILLED: DUMP FOLLOWS.  RUN STOPS DEAD')
         IERROR=ICODE
         CALL HWUEPR
         CALL HWUBPR
         STOP
      ELSE
         WRITE (6,70)
   70    FORMAT(' RUN CANNOT CONTINUE')
         STOP
      ENDIF
      END
CDECK  ID>, IEUPDG.
*CMZ :-        -28/01/92  12.34.44  by  Mike Seymour
*-- Author :    Luca Stanco
C-----------------------------------------------------------------------
      FUNCTION IEUPDG(I)
C-----------------------------------------------------------------------
C     DUMMY SUBROUTINE: DELETE AND SET BDECAY='EURO'
C     IN MAIN PROGRAM IF YOU USE EURODEC DECAY PACKAGE
C-----------------------------------------------------------------------
      INTEGER IEUPDG,I
      WRITE (6,10)
   10 FORMAT(/10X,'IEUPDG CALLED BUT NOT LINKED')
      IEUPDG=0
      STOP
      END
CDECK  ID>, IPDGEU.
*CMZ :-        -28/01/92  12.34.44  by  Mike Seymour
*-- Author :    Luca Stanco
C-----------------------------------------------------------------------
      FUNCTION IPDGEU(I)
C-----------------------------------------------------------------------
C     DUMMY SUBROUTINE: DELETE AND SET BDECAY='EURO'
C     IN MAIN PROGRAM IF YOU USE EURODEC DECAY PACKAGE
C-----------------------------------------------------------------------
      INTEGER IPDGEU,I
      WRITE (6,10)
   10 FORMAT(/10X,'IPDGEU CALLED BUT NOT LINKED')
      IPDGEU=0
      STOP
      END
CDECK  ID>, PDFSET.
*CMZ :-        -26/04/91  11.11.54  by  Bryan Webber
*-- Author :    Bryan Webber
C----------------------------------------------------------------------
      SUBROUTINE PDFSET(PARM,VAL)
C----------------------------------------------------------------------
C     DUMMY SUBROUTINE: DELETE AND SET MODPDF(I)
C     IN MAIN PROGRAM IF YOU USE PDFLIB CERN-LIBRARY
C     PACKAGE FOR NUCLEON STRUCTURE FUNCTIONS
C----------------------------------------------------------------------
      DOUBLE PRECISION VAL(20)
      CHARACTER*20 PARM(20)
      WRITE (6,10)
   10 FORMAT(/10X,'PDFSET CALLED BUT NOT LINKED')
      STOP
      END
CDECK  ID>, QQINIT.
*CMZ :-        -28/01/92  12.34.44  by  Mike Seymour
*-- Author :    Luca Stanco
C-----------------------------------------------------------------------
      SUBROUTINE QQINIT(QQLERR)
C-----------------------------------------------------------------------
C     DUMMY SUBROUTINE: DELETE AND SET BDECAY='CLEO'
C     IN MAIN PROGRAM IF YOU USE CLEO DECAY PACKAGE
C-----------------------------------------------------------------------
      LOGICAL QQLERR
      WRITE (6,10)
   10 FORMAT(/10X,'QQINIT CALLED BUT NOT LINKED')
      STOP
      END
CDECK  ID>, QQLMAT.
*CMZ :-        -28/01/92  12.34.44  by  Mike Seymour
*-- Author :    Luca Stanco
C-----------------------------------------------------------------------
      INTEGER FUNCTION QQLMAT(IDL,NDIR)
C-----------------------------------------------------------------------
C. QQLMAT - Given a particle flavor (KF), converts it to QQ particle number
C.          (KF = IDPDG code)
C.
C. Inputs    : IDL    (input  particle code)
C              NDIR = 1   LUND --> QQ
C              NDIR = 2   QQ   --> LUND
C
C. Outputs   : QQLMAT (output particle code)
C.
C-----------------------------------------------------------------------
      IMPLICIT NONE
C-- Calling variable
      INTEGER IDL,NDIR
C-- External declaration
C-- Local variables
      INTEGER AKF(321),I
      DATA (AKF(I), I=1,151) /
     +    0,    0,    0,    0,    0,    0,    0,   21,   -6,   -5,
     +   -4,   -3,   -1,   -2,    6,    5,    4,    3,    1,    2,
     +    0,
     +   22,   23,   24,  -24,   90,    0,   11,  -11,   12,  -12,
     +   13,  -13,   14,  -14,   15,  -15,   16,  -16,20313,-20313,
     +  211, -211,  321, -321,  311, -311,  421, -421,  411, -411,
     +  431, -431, -521,  521, -511,  511, -531,  531, -541,  541,
     +  621, -621,  611, -611,  631, -631,  641, -641,  651, -651,
     +  111,  221,  331,  441,20551,  661,  310,  130,10313,-10313,
     +  213, -213,  323, -323,  313, -313,  423, -423,  413, -413,
     +  433, -433, -523,  523, -513,  513, -533,  533, -543,  543,
     +  623, -623,  613, -613,  633, -633,  643, -643,  653, -653,
     +  113,  223,  333,  443,  553,  136,  20553, 30553, 40553, 551,
     +  10553, 555, 10551,70553,10555, 0, 20213, 20113, -20213, 10441,
     +  10443, 445, 8*0,
     +  3122, -3122, 4122, -4122, 4232, -4232, 4132, -4132, 3212, -3212/
      DATA (AKF(I), I=152,321) /
     +  4212, -4212, 4322, -4322, 4312, -4312, 2212, -2212, 3222, -3222,
     +  4222, -4222, 2112, -2112, 3112, -3112, 4112, -4112, 3322, -3322,
     +  3312, -3312, 4332, -4332, 6*0,
     +  3214, -3214, 4214, -4214, 4324, -4324, 4314, -4314, 2214, -2214,
     +  3224, -3224, 4224, -4224, 2114, -2114, 3114, -3114, 4114, -4114,
     +  3324, -3324, 3314, -3314, 4334, -4334, 4*0,
     +  0, 0,  2224, -2224, 1114, -1114, 3334, -3334, 0, 0,
     +  10323, -10323, 20323, -20323, 6*0,
     +  30443, 0, 0, 0, 70443, 50553, 60553, 80553, 20443, 0,
     +  10411, 20413, 10413, 415,
     + -10411,-20413,-10413,-415,
     +  10421, 20423, 10423, 425,
     + -10421,-20423,-10423,-425,
     +  10431, 20433, 10433, 435,
     + -10431,-20433,-10433,-435, 0,0,0,0,0,0,
     +  10111, 10211,-10211, 115, 215, -215,10221,10331,20223,20333,
     +  225, 335, 10223, 10333, 10113, 10213,-10213, 33*0 /
      IF(NDIR.EQ.1) THEN
        DO 10 I=1,321
        IF (IDL.EQ.AKF(I)) THEN
          QQLMAT=I-21
          RETURN
        ENDIF
  10    CONTINUE
        WRITE(6,20) IDL
  20    FORMAT(1X,'Lund code particle ',I6,' not recognized')
      ELSEIF(NDIR.EQ.2) THEN
        QQLMAT = AKF(IDL+21)
      ENDIF
      RETURN
      END
CDECK  ID>, STRUCTM.
*CMZ :S        E26/04/91  11.11.54  by  Bryan Webber
*-- Author :    Bryan Webber
C-----------------------------------------------------------------------
      SUBROUTINE STRUCTM(X,QSCA,UPV,DNV,USEA,DSEA,STR,CHM,BOT,TOP,GLU)
C-----------------------------------------------------------------------
C     DUMMY SUBROUTINE: DELETE IF YOU USE PDFLIB CERN-LIBRARY
C     PACKAGE FOR NUCLEON STRUCTURE FUNCTIONS
C-----------------------------------------------------------------------
      DOUBLE PRECISION X,QSCA,UPV,DNV,USEA,DSEA,STR,CHM,BOT,TOP,GLU
      WRITE (6,10)
  10  FORMAT(/10X,'STRUCTM CALLED BUT NOT LINKED')
      STOP
      END
C-----------------------------------------------------------------------
C...SaSgam version 2 - parton distributions of the photon
C...by Gerhard A. Schuler and Torbjorn Sjostrand
C...For further information see Z. Phys. C68 (1995) 607
C...and CERN-TH/96-04 and LU TP 96-2.
C...Program last changed on 18 January 1996.
C
C!!!Note that one further call parameter - IP2 - has been added
C!!!to the SASGAM argument list compared with version 1.
C
C...The user should only need to call the SASGAM routine,
C...which in turn calls the auxiliary routines SASVMD, SASANO,
C...SASBEH and SASDIR. The package is self-contained.
C
C...One particular aspect of these parametrizations is that F2 for
C...the photon is not obtained just as the charge-squared-weighted
C...sum of quark distributions, but differ in the treatment of
C...heavy flavours (in F2 the DIS relation W2 = Q2*(1-x)/x restricts
C...the kinematics range of heavy-flavour production, but the same
C...kinematics is not relevant e.g. for jet production) and, for the
C...'MSbar' fits, in the addition of a Cgamma term related to the
C...separation of direct processes. Schematically:
C...PDF = VMD (rho, omega, phi) + anomalous (d, u, s, c, b).
C...F2  = VMD (rho, omega, phi) + anomalous (d, u, s) +
C...      Bethe-Heitler (c, b) (+ Cgamma (d, u, s)).
C...The J/psi and Upsilon states have not been included in the VMD sum,
C...but low c and b masses in the other components should compensate
C...for this in a duality sense.
C
C...The calling sequence is the following:
C     CALL SASGAM(ISET,X,Q2,P2,IP2,F2GM,XPDFGM)
C...with the following declaration statement:
C     DIMENSION XPDFGM(-6:6)
C...and, optionally, further information in:
C     COMMON/SASCOM/XPVMD(-6:6),XPANL(-6:6),XPANH(-6:6),XPBEH(-6:6),
C    &XPDIR(-6:6)
C     COMMON/SASVAL/VXPVMD(-6:6),VXPANL(-6:6),VXPANH(-6:6),VXPDGM(-6:6)
C...Input:  ISET = 1 : SaS set 1D ('DIS',   Q0 = 0.6 GeV)
C                = 2 : SaS set 1M ('MSbar', Q0 = 0.6 GeV)
C                = 3 : SaS set 2D ('DIS',   Q0 =  2  GeV)
C                = 4 : SaS set 2M ('MSbar', Q0 =  2  GeV)
C           X : x value.
C           Q2 : Q2 value.
C           P2 : P2 value; should be = 0. for an on-shell photon.
C           IP2 : scheme used to evaluate off-shell anomalous component.
C               = 0 : recommended default, see = 7.
C               = 1 : dipole dampening by integration; very time-consuming.
C               = 2 : P_0^2 = max( Q_0^2, P^2 )
C               = 3 : P'_0^2 = Q_0^2 + P^2.
C               = 4 : P_{eff} that preserves momentum sum.
C               = 5 : P_{int} that preserves momentum and average
C                     evolution range.
C               = 6 : P_{eff}, matched to P_0 in P2 -> Q2 limit.
C               = 7 : P_{eff}, matched to P_0 in P2 -> Q2 limit.
C...Output: F2GM : F2 value of the photon (including factors of alpha_em).
C           XPFDGM :  x times parton distribution functions of the photon,
C               with elements 0 = g, 1 = d, 2 = u, 3 = s, 4 = c, 5 = b,
C               6 = t (always empty!), - for antiquarks (result is same).
C...The breakdown by component is stored in the commonblock SASCOM,
C               with elements as above.
C           XPVMD : rho, omega, phi VMD part only of output.
C           XPANL : d, u, s anomalous part only of output.
C           XPANH : c, b anomalous part only of output.
C           XPBEH : c, b Bethe-Heitler part only of output.
C           XPDIR : Cgamma (direct contribution) part only of output.
C...The above arrays do not distinguish valence and sea contributions,
C...although this information is available internally. The additional
C...commonblock SASVAL provides the valence part only of the above
C...distributions. Array names VXPVMD, VXPANL and VXPANH correspond
C...to XPVMD, XPANL and XPANH, while XPBEH and XPDIR are valence only
C...and therefore not given doubly. VXPDGM gives the sum of valence
C...parts, and so matches XPDFGM. The difference, i.e. XPVMD-VXPVMD
C...and so on, gives the sea part only.
C
      SUBROUTINE SASGAM(ISET,X,Q2,P2,IP2,F2GM,XPDFGM)
C...Purpose: to construct the F2 and parton distributions of the photon
C...by summing homogeneous (VMD) and inhomogeneous (anomalous) terms.
C...For F2, c and b are included by the Bethe-Heitler formula;
C...in the 'MSbar' scheme additionally a Cgamma term is added.
      DIMENSION XPDFGM(-6:6)
      COMMON/SASCOM/XPVMD(-6:6),XPANL(-6:6),XPANH(-6:6),XPBEH(-6:6),
     &XPDIR(-6:6)
      COMMON/SASVAL/VXPVMD(-6:6),VXPANL(-6:6),VXPANH(-6:6),VXPDGM(-6:6)
      SAVE /SASCOM/,/SASVAL/
C
C...Temporary array.
      DIMENSION XPGA(-6:6), VXPGA(-6:6)
C...Charm and bottom masses (low to compensate for J/psi etc.).
      DATA PMC/1.3/, PMB/4.6/
C...alpha_em and alpha_em/(2*pi).
      DATA AEM/0.007297/, AEM2PI/0.0011614/
C...Lambda value for 4 flavours.
      DATA ALAM/0.20/
C...Mixture u/(u+d), = 0.5 for incoherent and = 0.8 for coherent sum.
      DATA FRACU/0.8/
C...VMD couplings f_V**2/(4*pi).
      DATA FRHO/2.20/, FOMEGA/23.6/, FPHI/18.4/
C...Masses for rho (=omega) and phi.
      DATA PMRHO/0.770/, PMPHI/1.020/
C...Number of points in integration for IP2=1.
      DATA NSTEP/100/
C
C...Reset output.
      F2GM=0.
      DO 100 KFL=-6,6
      XPDFGM(KFL)=0.
      XPVMD(KFL)=0.
      XPANL(KFL)=0.
      XPANH(KFL)=0.
      XPBEH(KFL)=0.
      XPDIR(KFL)=0.
      VXPVMD(KFL)=0.
      VXPANL(KFL)=0.
      VXPANH(KFL)=0.
      VXPDGM(KFL)=0.
  100 CONTINUE
C
C...Check that input sensible.
      IF(ISET.LE.0.OR.ISET.GE.5) THEN
        WRITE(*,*) ' FATAL ERROR: SaSgam called for unknown set'
        WRITE(*,*) ' ISET = ',ISET
        STOP
      ENDIF
      IF(X.LE.0..OR.X.GT.1.) THEN
        WRITE(*,*) ' FATAL ERROR: SaSgam called for unphysical x'
        WRITE(*,*) ' X = ',X
        STOP
      ENDIF
C
C...Set Q0 cut-off parameter as function of set used.
      IF(ISET.LE.2) THEN
        Q0=0.6
      ELSE
        Q0=2.
      ENDIF
      Q02=Q0**2
C
C...Scale choice for off-shell photon; common factors.
      Q2A=Q2
      FACNOR=1.
      IF(IP2.EQ.1) THEN
        P2MX=P2+Q02
        Q2A=Q2+P2*Q02/MAX(Q02,Q2)
        FACNOR=LOG(Q2/Q02)/NSTEP
      ELSEIF(IP2.EQ.2) THEN
        P2MX=MAX(P2,Q02)
      ELSEIF(IP2.EQ.3) THEN
        P2MX=P2+Q02
        Q2A=Q2+P2*Q02/MAX(Q02,Q2)
      ELSEIF(IP2.EQ.4) THEN
        P2MX=Q2*(Q02+P2)/(Q2+P2)*EXP(P2*(Q2-Q02)/
     &  ((Q2+P2)*(Q02+P2)))
      ELSEIF(IP2.EQ.5) THEN
        P2MXA=Q2*(Q02+P2)/(Q2+P2)*EXP(P2*(Q2-Q02)/
     &  ((Q2+P2)*(Q02+P2)))
        P2MX=Q0*SQRT(P2MXA)
        FACNOR=LOG(Q2/P2MXA)/LOG(Q2/P2MX)
      ELSEIF(IP2.EQ.6) THEN
        P2MX=Q2*(Q02+P2)/(Q2+P2)*EXP(P2*(Q2-Q02)/
     &  ((Q2+P2)*(Q02+P2)))
        P2MX=MAX(0.,1.-P2/Q2)*P2MX+MIN(1.,P2/Q2)*MAX(P2,Q02)
      ELSE
        P2MXA=Q2*(Q02+P2)/(Q2+P2)*EXP(P2*(Q2-Q02)/
     &  ((Q2+P2)*(Q02+P2)))
        P2MX=Q0*SQRT(P2MXA)
        P2MXB=P2MX
        P2MX=MAX(0.,1.-P2/Q2)*P2MX+MIN(1.,P2/Q2)*MAX(P2,Q02)
        P2MXB=MAX(0.,1.-P2/Q2)*P2MXB+MIN(1.,P2/Q2)*P2MXA
        FACNOR=LOG(Q2/P2MXA)/LOG(Q2/P2MXB)
      ENDIF
C
C...Call VMD parametrization for d quark and use to give rho, omega,
C...phi. Note dipole dampening for off-shell photon.
      CALL SASVMD(ISET,1,X,Q2A,P2MX,ALAM,XPGA,VXPGA)
      XFVAL=VXPGA(1)
      XPGA(1)=XPGA(2)
      XPGA(-1)=XPGA(-2)
      FACUD=AEM*(1./FRHO+1./FOMEGA)*(PMRHO**2/(PMRHO**2+P2))**2
      FACS=AEM*(1./FPHI)*(PMPHI**2/(PMPHI**2+P2))**2
      DO 110 KFL=-5,5
      XPVMD(KFL)=(FACUD+FACS)*XPGA(KFL)
  110 CONTINUE
      XPVMD(1)=XPVMD(1)+(1.-FRACU)*FACUD*XFVAL
      XPVMD(2)=XPVMD(2)+FRACU*FACUD*XFVAL
      XPVMD(3)=XPVMD(3)+FACS*XFVAL
      XPVMD(-1)=XPVMD(-1)+(1.-FRACU)*FACUD*XFVAL
      XPVMD(-2)=XPVMD(-2)+FRACU*FACUD*XFVAL
      XPVMD(-3)=XPVMD(-3)+FACS*XFVAL
      VXPVMD(1)=(1.-FRACU)*FACUD*XFVAL
      VXPVMD(2)=FRACU*FACUD*XFVAL
      VXPVMD(3)=FACS*XFVAL
      VXPVMD(-1)=(1.-FRACU)*FACUD*XFVAL
      VXPVMD(-2)=FRACU*FACUD*XFVAL
      VXPVMD(-3)=FACS*XFVAL
C
      IF(IP2.NE.1) THEN
C...Anomalous parametrizations for different strategies
C...for off-shell photons; except full integration.
C
C...Call anomalous parametrization for d + u + s.
        CALL SASANO(-3,X,Q2A,P2MX,ALAM,XPGA,VXPGA)
        DO 120 KFL=-5,5
        XPANL(KFL)=FACNOR*XPGA(KFL)
        VXPANL(KFL)=FACNOR*VXPGA(KFL)
  120   CONTINUE
C
C...Call anomalous parametrization for c and b.
        CALL SASANO(4,X,Q2A,P2MX,ALAM,XPGA,VXPGA)
        DO 130 KFL=-5,5
        XPANH(KFL)=FACNOR*XPGA(KFL)
        VXPANH(KFL)=FACNOR*VXPGA(KFL)
  130   CONTINUE
        CALL SASANO(5,X,Q2A,P2MX,ALAM,XPGA,VXPGA)
        DO 140 KFL=-5,5
        XPANH(KFL)=XPANH(KFL)+FACNOR*XPGA(KFL)
        VXPANH(KFL)=VXPANH(KFL)+FACNOR*VXPGA(KFL)
  140   CONTINUE
C
      ELSE
C...Special option: loop over flavours and integrate over k2.
        DO 170 KF=1,5
        DO 160 ISTEP=1,NSTEP
        Q2STEP=Q02*(Q2/Q02)**((ISTEP-0.5)/NSTEP)
        IF((KF.EQ.4.AND.Q2STEP.LT.PMC**2).OR.
     &  (KF.EQ.5.AND.Q2STEP.LT.PMB**2)) GOTO 160
        CALL SASVMD(0,KF,X,Q2,Q2STEP,ALAM,XPGA,VXPGA)
        FACQ=AEM2PI*(Q2STEP/(Q2STEP+P2))**2*FACNOR
        IF(MOD(KF,2).EQ.0) FACQ=FACQ*(8./9.)
        IF(MOD(KF,2).EQ.1) FACQ=FACQ*(2./9.)
        DO 150 KFL=-5,5
        IF(KF.LE.3) XPANL(KFL)=XPANL(KFL)+FACQ*XPGA(KFL)
        IF(KF.GE.4) XPANH(KFL)=XPANH(KFL)+FACQ*XPGA(KFL)
        IF(KF.LE.3) VXPANL(KFL)=VXPANL(KFL)+FACQ*VXPGA(KFL)
        IF(KF.GE.4) VXPANH(KFL)=VXPANH(KFL)+FACQ*VXPGA(KFL)
  150   CONTINUE
  160   CONTINUE
  170   CONTINUE
      ENDIF
C
C...Call Bethe-Heitler term expression for charm and bottom.
      CALL SASBEH(4,X,Q2,P2,PMC**2,XPBH)
      XPBEH(4)=XPBH
      XPBEH(-4)=XPBH
      CALL SASBEH(5,X,Q2,P2,PMB**2,XPBH)
      XPBEH(5)=XPBH
      XPBEH(-5)=XPBH
C
C...For MSbar subtraction call C^gamma term expression for d, u, s.
      IF(ISET.EQ.2.OR.ISET.EQ.4) THEN
        CALL SASDIR(X,Q2,P2,Q02,XPGA)
        DO 180 KFL=-5,5
        XPDIR(KFL)=XPGA(KFL)
  180   CONTINUE
      ENDIF
C
C...Store result in output array.
      DO 190 KFL=-5,5
      CHSQ=1./9.
      IF(IABS(KFL).EQ.2.OR.IABS(KFL).EQ.4) CHSQ=4./9.
      XPF2=XPVMD(KFL)+XPANL(KFL)+XPBEH(KFL)+XPDIR(KFL)
      IF(KFL.NE.0) F2GM=F2GM+CHSQ*XPF2
      XPDFGM(KFL)=XPVMD(KFL)+XPANL(KFL)+XPANH(KFL)
      VXPDGM(KFL)=VXPVMD(KFL)+VXPANL(KFL)+VXPANH(KFL)
  190 CONTINUE
C
      RETURN
      END
C
C*********************************************************************
C
      SUBROUTINE SASVMD(ISET,KF,X,Q2,P2,ALAM,XPGA,VXPGA)
C...Purpose: to evaluate the VMD parton distributions of a photon,
C...evolved homogeneously from an initial scale P2 to Q2.
C...Does not include dipole suppression factor.
C...ISET is parton distribution set, see above;
C...additionally ISET=0 is used for the evolution of an anomalous photon
C...which branched at a scale P2 and then evolved homogeneously to Q2.
C...ALAM is the 4-flavour Lambda, which is automatically converted
C...to 3- and 5-flavour equivalents as needed.
      DIMENSION XPGA(-6:6), VXPGA(-6:6)
      DATA PMC/1.3/, PMB/4.6/
C
C...Reset output.
      DO 100 KFL=-6,6
      XPGA(KFL)=0.
      VXPGA(KFL)=0.
  100 CONTINUE
      KFA=IABS(KF)
C
C...Calculate Lambda; protect against unphysical Q2 and P2 input.
      ALAM3=ALAM*(PMC/ALAM)**(2./27.)
      ALAM5=ALAM*(ALAM/PMB)**(2./23.)
      P2EFF=MAX(P2,1.2*ALAM3**2)
      IF(KFA.EQ.4) P2EFF=MAX(P2EFF,PMC**2)
      IF(KFA.EQ.5) P2EFF=MAX(P2EFF,PMB**2)
      Q2EFF=MAX(Q2,P2EFF)
C
C...Find number of flavours at lower and upper scale.
      NFP=4
      IF(P2EFF.LT.PMC**2) NFP=3
      IF(P2EFF.GT.PMB**2) NFP=5
      NFQ=4
      IF(Q2EFF.LT.PMC**2) NFQ=3
      IF(Q2EFF.GT.PMB**2) NFQ=5
C
C...Find s as sum of 3-, 4- and 5-flavour parts.
      S=0.
      IF(NFP.EQ.3) THEN
        Q2DIV=PMC**2
        IF(NFQ.EQ.3) Q2DIV=Q2EFF
        S=S+(6./27.)*LOG(LOG(Q2DIV/ALAM3**2)/LOG(P2EFF/ALAM3**2))
      ENDIF
      IF(NFP.LE.4.AND.NFQ.GE.4) THEN
        P2DIV=P2EFF
        IF(NFP.EQ.3) P2DIV=PMC**2
        Q2DIV=Q2EFF
        IF(NFQ.EQ.5) Q2DIV=PMB**2
        S=S+(6./25.)*LOG(LOG(Q2DIV/ALAM**2)/LOG(P2DIV/ALAM**2))
      ENDIF
      IF(NFQ.EQ.5) THEN
        P2DIV=PMB**2
        IF(NFP.EQ.5) P2DIV=P2EFF
        S=S+(6./23.)*LOG(LOG(Q2EFF/ALAM5**2)/LOG(P2DIV/ALAM5**2))
      ENDIF
C
C...Calculate frequent combinations of x and s.
      X1=1.-X
      XL=-LOG(X)
      S2=S**2
      S3=S**3
      S4=S**4
C
C...Evaluate homogeneous anomalous parton distributions below or
C...above threshold.
      IF(ISET.EQ.0) THEN
      IF(Q2.LE.P2.OR.(KFA.EQ.4.AND.Q2.LT.PMC**2).OR.
     &(KFA.EQ.5.AND.Q2.LT.PMB**2)) THEN
        XVAL = X * 1.5 * (X**2+X1**2)
        XGLU = 0.
        XSEA = 0.
      ELSE
        XVAL = (1.5/(1.-0.197*S+4.33*S2)*X**2 + (1.5+2.10*S)/
     &  (1.+3.29*S)*X1**2 + 5.23*S/(1.+1.17*S+19.9*S3)*X*X1) *
     &  X**(1./(1.+1.5*S)) * (1.-X**2)**(2.667*S)
        XGLU = 4.*S/(1.+4.76*S+15.2*S2+29.3*S4) *
     &  X**(-2.03*S/(1.+2.44*S)) * (X1*XL)**(1.333*S) *
     &  ((4.*X**2+7.*X+4.)*X1/3. - 2.*X*(1.+X)*XL)
        XSEA = S2/(1.+4.54*S+8.19*S2+8.05*S3) *
     &  X**(-1.54*S/(1.+1.29*S)) * X1**(2.667*S) *
     &  ((8.-73.*X+62.*X**2)*X1/9. + (3.-8.*X**2/3.)*X*XL +
     &  (2.*X-1.)*X*XL**2)
      ENDIF
C
C...Evaluate set 1D parton distributions below or above threshold.
      ELSEIF(ISET.EQ.1) THEN
      IF(Q2.LE.P2.OR.(KFA.EQ.4.AND.Q2.LT.PMC**2).OR.
     &(KFA.EQ.5.AND.Q2.LT.PMB**2)) THEN
        XVAL = 1.294 * X**0.80 * X1**0.76
        XGLU = 1.273 * X**0.40 * X1**1.76
        XSEA = 0.100 * X1**3.76
      ELSE
        XVAL = 1.294/(1.+0.252*S+3.079*S2) * X**(0.80-0.13*S) *
     &  X1**(0.76+0.667*S) * XL**(2.*S)
        XGLU = 7.90*S/(1.+5.50*S) * EXP(-5.16*S) *
     &  X**(-1.90*S/(1.+3.60*S)) * X1**1.30 * XL**(0.50+3.*S) +
     &  1.273 * EXP(-10.*S) * X**0.40 * X1**(1.76+3.*S)
        XSEA = (0.1-0.397*S2+1.121*S3)/(1.+5.61*S2+5.26*S3) *
     &  X**(-7.32*S2/(1.+10.3*S2)) *
     &  X1**((3.76+15.*S+12.*S2)/(1.+4.*S))
        XSEA0 = 0.100 * X1**3.76
      ENDIF
C
C...Evaluate set 1M parton distributions below or above threshold.
      ELSEIF(ISET.EQ.2) THEN
      IF(Q2.LE.P2.OR.(KFA.EQ.4.AND.Q2.LT.PMC**2).OR.
     &(KFA.EQ.5.AND.Q2.LT.PMB**2)) THEN
        XVAL = 0.8477 * X**0.51 * X1**1.37
        XGLU = 3.42 * X**0.255 * X1**2.37
        XSEA = 0.
      ELSE
        XVAL = 0.8477/(1.+1.37*S+2.18*S2+3.73*S3) * X**(0.51+0.21*S)
     &  * X1**1.37 * XL**(2.667*S)
        XGLU = 24.*S/(1.+9.6*S+0.92*S2+14.34*S3) * EXP(-5.94*S) *
     &  X**((-0.013-1.80*S)/(1.+3.14*S)) * X1**(2.37+0.4*S) *
     &  XL**(0.32+3.6*S) + 3.42 * EXP(-12.*S) * X**0.255 *
     &  X1**(2.37+3.*S)
        XSEA = 0.842*S/(1.+21.3*S-33.2*S2+229.*S3) *
     &  X**((0.13-2.90*S)/(1.+5.44*S)) * X1**(3.45+0.5*S) *
     &  XL**(2.8*S)
        XSEA0 = 0.
      ENDIF
C
C...Evaluate set 2D parton distributions below or above threshold.
      ELSEIF(ISET.EQ.3) THEN
      IF(Q2.LE.P2.OR.(KFA.EQ.4.AND.Q2.LT.PMC**2).OR.
     &(KFA.EQ.5.AND.Q2.LT.PMB**2)) THEN
        XVAL = X**0.46 * X1**0.64 + 0.76 * X
        XGLU = 1.925 * X1**2
        XSEA = 0.242 * X1**4
      ELSE
        XVAL = (1.+0.186*S)/(1.-0.209*S+1.495*S2) * X**(0.46+0.25*S)
     &  * X1**((0.64+0.14*S+5.*S2)/(1.+S)) * XL**(1.9*S) +
     &  (0.76+0.4*S) * X * X1**(2.667*S)
        XGLU = (1.925+5.55*S+147.*S2)/(1.-3.59*S+3.32*S2) *
     &  EXP(-18.67*S) * X**((-5.81*S-5.34*S2)/(1.+29.*S-4.26*S2))
     &  * X1**((2.-5.9*S)/(1.+1.7*S)) * XL**(9.3*S/(1.+1.7*S))
        XSEA = (0.242-0.252*S+1.19*S2)/(1.-0.607*S+21.95*S2) *
     &  X**(-12.1*S2/(1.+2.62*S+16.7*S2)) * X1**4 * XL**S
        XSEA0 = 0.242 * X1**4
      ENDIF
C
C...Evaluate set 2M parton distributions below or above threshold.
      ELSEIF(ISET.EQ.4) THEN
      IF(Q2.LE.P2.OR.(KFA.EQ.4.AND.Q2.LT.PMC**2).OR.
     &(KFA.EQ.5.AND.Q2.LT.PMB**2)) THEN
        XVAL = 1.168 * X**0.50 * X1**2.60 + 0.965 * X
        XGLU = 1.808 * X1**2
        XSEA = 0.209 * X1**4
      ELSE
        XVAL = (1.168+1.771*S+29.35*S2) * EXP(-5.776*S) *
     &  X**((0.5+0.208*S)/(1.-0.794*S+1.516*S2)) *
     &  X1**((2.6+7.6*S)/(1.+5.*S)) * XL**(5.15*S/(1.+2.*S)) +
     &  (0.965+22.35*S)/(1.+18.4*S) * X * X1**(2.667*S)
        XGLU = (1.808+29.9*S)/(1.+26.4*S) * EXP(-5.28*S) *
     &  X**((-5.35*S-10.11*S2)/(1.+31.71*S)) *
     &  X1**((2.-7.3*S+4.*S2)/(1.+2.5*S)) *
     &  XL**(10.9*S/(1.+2.5*S))
        XSEA = (0.209+0.644*S2)/(1.+0.319*S+17.6*S2) *
     &  X**((-0.373*S-7.71*S2)/(1.+0.815*S+11.0*S2)) *
     &  X1**(4.+S) * XL**(0.45*S)
        XSEA0 = 0.209 * X1**4
      ENDIF
      ENDIF
C
C...Threshold factors for c and b sea.
      SLL=LOG(LOG(Q2EFF/ALAM**2)/LOG(P2EFF/ALAM**2))
      XCHM=0.
      IF(Q2.GT.PMC**2.AND.Q2.GT.1.001*P2EFF) THEN
        SCH=MAX(0.,LOG(LOG(PMC**2/ALAM**2)/LOG(P2EFF/ALAM**2)))
        IF(ISET.EQ.0) THEN
          XCHM=XSEA*(1.-(SCH/SLL)**2)
        ELSE
          XCHM=MAX(0.,XSEA-XSEA0*X1**(2.667*S))*(1.-SCH/SLL)
        ENDIF
      ENDIF
      XBOT=0.
      IF(Q2.GT.PMB**2.AND.Q2.GT.1.001*P2EFF) THEN
        SBT=MAX(0.,LOG(LOG(PMB**2/ALAM**2)/LOG(P2EFF/ALAM**2)))
        IF(ISET.EQ.0) THEN
          XBOT=XSEA*(1.-(SBT/SLL)**2)
        ELSE
          XBOT=MAX(0.,XSEA-XSEA0*X1**(2.667*S))*(1.-SBT/SLL)
        ENDIF
      ENDIF
C
C...Fill parton distributions.
      XPGA(0)=XGLU
      XPGA(1)=XSEA
      XPGA(2)=XSEA
      XPGA(3)=XSEA
      XPGA(4)=XCHM
      XPGA(5)=XBOT
      XPGA(KFA)=XPGA(KFA)+XVAL
      DO 110 KFL=1,5
      XPGA(-KFL)=XPGA(KFL)
  110 CONTINUE
      VXPGA(KFA)=XVAL
      VXPGA(-KFA)=XVAL
C
      RETURN
      END
C
C*********************************************************************
C
      SUBROUTINE SASANO(KF,X,Q2,P2,ALAM,XPGA,VXPGA)
C...Purpose: to evaluate the parton distributions of the anomalous
C...photon, inhomogeneously evolved from a scale P2 (where it vanishes)
C...to Q2.
C...KF=0 gives the sum over (up to) 5 flavours,
C...KF<0 limits to flavours up to abs(KF),
C...KF>0 is for flavour KF only.
C...ALAM is the 4-flavour Lambda, which is automatically converted
C...to 3- and 5-flavour equivalents as needed.
      DIMENSION XPGA(-6:6), VXPGA(-6:6), ALAMSQ(3:5)
      DATA PMC/1.3/, PMB/4.6/, AEM2PI/0.0011614/
C
C...Reset output.
      DO 100 KFL=-6,6
      XPGA(KFL)=0.
      VXPGA(KFL)=0.
  100 CONTINUE
      IF(Q2.LE.P2) RETURN
      KFA=IABS(KF)
C
C...Calculate Lambda; protect against unphysical Q2 and P2 input.
      ALAMSQ(3)=(ALAM*(PMC/ALAM)**(2./27.))**2
      ALAMSQ(4)=ALAM**2
      ALAMSQ(5)=(ALAM*(ALAM/PMB)**(2./23.))**2
      P2EFF=MAX(P2,1.2*ALAMSQ(3))
      IF(KF.EQ.4) P2EFF=MAX(P2EFF,PMC**2)
      IF(KF.EQ.5) P2EFF=MAX(P2EFF,PMB**2)
      Q2EFF=MAX(Q2,P2EFF)
      XL=-LOG(X)
C
C...Find number of flavours at lower and upper scale.
      NFP=4
      IF(P2EFF.LT.PMC**2) NFP=3
      IF(P2EFF.GT.PMB**2) NFP=5
      NFQ=4
      IF(Q2EFF.LT.PMC**2) NFQ=3
      IF(Q2EFF.GT.PMB**2) NFQ=5
C
C...Define range of flavour loop.
      IF(KF.EQ.0) THEN
        KFLMN=1
        KFLMX=5
      ELSEIF(KF.LT.0) THEN
        KFLMN=1
        KFLMX=KFA
      ELSE
        KFLMN=KFA
        KFLMX=KFA
      ENDIF
C
C...Loop over flavours the photon can branch into.
      DO 110 KFL=KFLMN,KFLMX
C
C...Light flavours: calculate t range and (approximate) s range.
      IF(KFL.LE.3.AND.(KFL.EQ.1.OR.KFL.EQ.KF)) THEN
        TDIFF=LOG(Q2EFF/P2EFF)
        S=(6./(33.-2.*NFQ))*LOG(LOG(Q2EFF/ALAMSQ(NFQ))/
     &  LOG(P2EFF/ALAMSQ(NFQ)))
        IF(NFQ.GT.NFP) THEN
          Q2DIV=PMB**2
          IF(NFQ.EQ.4) Q2DIV=PMC**2
          SNFQ=(6./(33.-2.*NFQ))*LOG(LOG(Q2DIV/ALAMSQ(NFQ))/
     &    LOG(P2EFF/ALAMSQ(NFQ)))
          SNFP=(6./(33.-2.*(NFQ-1)))*LOG(LOG(Q2DIV/ALAMSQ(NFQ-1))/
     &    LOG(P2EFF/ALAMSQ(NFQ-1)))
          S=S+(LOG(Q2DIV/P2EFF)/LOG(Q2EFF/P2EFF))*(SNFP-SNFQ)
        ENDIF
        IF(NFQ.EQ.5.AND.NFP.EQ.3) THEN
          Q2DIV=PMC**2
          SNF4=(6./(33.-2.*4))*LOG(LOG(Q2DIV/ALAMSQ(4))/
     &    LOG(P2EFF/ALAMSQ(4)))
          SNF3=(6./(33.-2.*3))*LOG(LOG(Q2DIV/ALAMSQ(3))/
     &    LOG(P2EFF/ALAMSQ(3)))
          S=S+(LOG(Q2DIV/P2EFF)/LOG(Q2EFF/P2EFF))*(SNF3-SNF4)
        ENDIF
C
C...u and s quark do not need a separate treatment when d has been done.
      ELSEIF(KFL.EQ.2.OR.KFL.EQ.3) THEN
C
C...Charm: as above, but only include range above c threshold.
      ELSEIF(KFL.EQ.4) THEN
        IF(Q2.LE.PMC**2) GOTO 110
        P2EFF=MAX(P2EFF,PMC**2)
        Q2EFF=MAX(Q2EFF,P2EFF)
        TDIFF=LOG(Q2EFF/P2EFF)
        S=(6./(33.-2.*NFQ))*LOG(LOG(Q2EFF/ALAMSQ(NFQ))/
     &  LOG(P2EFF/ALAMSQ(NFQ)))
        IF(NFQ.EQ.5.AND.NFP.EQ.4) THEN
          Q2DIV=PMB**2
          SNFQ=(6./(33.-2.*NFQ))*LOG(LOG(Q2DIV/ALAMSQ(NFQ))/
     &    LOG(P2EFF/ALAMSQ(NFQ)))
          SNFP=(6./(33.-2.*(NFQ-1)))*LOG(LOG(Q2DIV/ALAMSQ(NFQ-1))/
     &    LOG(P2EFF/ALAMSQ(NFQ-1)))
          S=S+(LOG(Q2DIV/P2EFF)/LOG(Q2EFF/P2EFF))*(SNFP-SNFQ)
        ENDIF
C
C...Bottom: as above, but only include range above b threshold.
      ELSEIF(KFL.EQ.5) THEN
        IF(Q2.LE.PMB**2) GOTO 110
        P2EFF=MAX(P2EFF,PMB**2)
        Q2EFF=MAX(Q2,P2EFF)
        TDIFF=LOG(Q2EFF/P2EFF)
        S=(6./(33.-2.*NFQ))*LOG(LOG(Q2EFF/ALAMSQ(NFQ))/
     &  LOG(P2EFF/ALAMSQ(NFQ)))
      ENDIF
C
C...Evaluate flavour-dependent prefactor (charge^2 etc.).
      CHSQ=1./9.
      IF(KFL.EQ.2.OR.KFL.EQ.4) CHSQ=4./9.
      FAC=AEM2PI*2.*CHSQ*TDIFF
C
C...Evaluate parton distributions (normalized to unit momentum sum).
      IF(KFL.EQ.1.OR.KFL.EQ.4.OR.KFL.EQ.5.OR.KFL.EQ.KF) THEN
        XVAL= ((1.5+2.49*S+26.9*S**2)/(1.+32.3*S**2)*X**2 +
     &  (1.5-0.49*S+7.83*S**2)/(1.+7.68*S**2)*(1.-X)**2 +
     &  1.5*S/(1.-3.2*S+7.*S**2)*X*(1.-X)) *
     &  X**(1./(1.+0.58*S)) * (1.-X**2)**(2.5*S/(1.+10.*S))
        XGLU= 2.*S/(1.+4.*S+7.*S**2) *
     &  X**(-1.67*S/(1.+2.*S)) * (1.-X**2)**(1.2*S) *
     &  ((4.*X**2+7.*X+4.)*(1.-X)/3. - 2.*X*(1.+X)*XL)
        XSEA= 0.333*S**2/(1.+4.90*S+4.69*S**2+21.4*S**3) *
     &  X**(-1.18*S/(1.+1.22*S)) * (1.-X)**(1.2*S) *
     &  ((8.-73.*X+62.*X**2)*(1.-X)/9. + (3.-8.*X**2/3.)*X*XL +
     &  (2.*X-1.)*X*XL**2)
C
C...Threshold factors for c and b sea.
        SLL=LOG(LOG(Q2EFF/ALAM**2)/LOG(P2EFF/ALAM**2))
        XCHM=0.
        IF(Q2.GT.PMC**2.AND.Q2.GT.1.001*P2EFF) THEN
          SCH=MAX(0.,LOG(LOG(PMC**2/ALAM**2)/LOG(P2EFF/ALAM**2)))
          XCHM=XSEA*(1.-(SCH/SLL)**3)
        ENDIF
        XBOT=0.
        IF(Q2.GT.PMB**2.AND.Q2.GT.1.001*P2EFF) THEN
          SBT=MAX(0.,LOG(LOG(PMB**2/ALAM**2)/LOG(P2EFF/ALAM**2)))
          XBOT=XSEA*(1.-(SBT/SLL)**3)
        ENDIF
      ENDIF
C
C...Add contribution of each valence flavour.
      XPGA(0)=XPGA(0)+FAC*XGLU
      XPGA(1)=XPGA(1)+FAC*XSEA
      XPGA(2)=XPGA(2)+FAC*XSEA
      XPGA(3)=XPGA(3)+FAC*XSEA
      XPGA(4)=XPGA(4)+FAC*XCHM
      XPGA(5)=XPGA(5)+FAC*XBOT
      XPGA(KFL)=XPGA(KFL)+FAC*XVAL
      VXPGA(KFL)=VXPGA(KFL)+FAC*XVAL
  110 CONTINUE
      DO 120 KFL=1,5
      XPGA(-KFL)=XPGA(KFL)
      VXPGA(-KFL)=VXPGA(KFL)
  120 CONTINUE
C
      RETURN
      END
C
C*********************************************************************
C
      SUBROUTINE SASBEH(KF,X,Q2,P2,PM2,XPBH)
C...Purpose: to evaluate the Bethe-Heitler cross section for
C...heavy flavour production.
      DATA AEM2PI/0.0011614/
C
C...Reset output.
      XPBH=0.
      SIGBH=0.
C
C...Check kinematics limits.
      IF(X.GE.Q2/(4.*PM2+Q2+P2)) RETURN
      W2=Q2*(1.-X)/X-P2
      BETA2=1.-4.*PM2/W2
      IF(BETA2.LT.1E-10) RETURN
      BETA=SQRT(BETA2)
      RMQ=4.*PM2/Q2
C
C...Simple case: P2 = 0.
      IF(P2.LT.1E-4) THEN
        IF(BETA.LT.0.99) THEN
          XBL=LOG((1.+BETA)/(1.-BETA))
        ELSE
          XBL=LOG((1.+BETA)**2*W2/(4.*PM2))
        ENDIF
        SIGBH=BETA*(8.*X*(1.-X)-1.-RMQ*X*(1.-X))+
     &  XBL*(X**2+(1.-X)**2+RMQ*X*(1.-3.*X)-0.5*RMQ**2*X**2)
C
C...Complicated case: P2 > 0, based on approximation of
C...C.T. Hill and G.G. Ross, Nucl. Phys. B148 (1979) 373
      ELSE
        RPQ=1.-4.*X**2*P2/Q2
        IF(RPQ.GT.1E-10) THEN
          RPBE=SQRT(RPQ*BETA2)
          IF(RPBE.LT.0.99) THEN
            XBL=LOG((1.+RPBE)/(1.-RPBE))
            XBI=2.*RPBE/(1.-RPBE**2)
          ELSE
            RPBESN=4.*PM2/W2+(4.*X**2*P2/Q2)*BETA2
            XBL=LOG((1.+RPBE)**2/RPBESN)
            XBI=2.*RPBE/RPBESN
          ENDIF
          SIGBH=BETA*(6.*X*(1.-X)-1.)+
     &    XBL*(X**2+(1.-X)**2+RMQ*X*(1.-3.*X)-0.5*RMQ**2*X**2)+
     &    XBI*(2.*X/Q2)*(PM2*X*(2.-RMQ)-P2*X)
        ENDIF
      ENDIF
C
C...Multiply by charge-squared etc. to get parton distribution.
      CHSQ=1./9.
      IF(IABS(KF).EQ.2.OR.IABS(KF).EQ.4) CHSQ=4./9.
      XPBH=3.*CHSQ*AEM2PI*X*SIGBH
C
      RETURN
      END
C
C*********************************************************************
C
      SUBROUTINE SASDIR(X,Q2,P2,Q02,XPGA)
C...Purpose: to evaluate the direct contribution, i.e. the C^gamma term,
C...as needed in MSbar parametrizations.
      DIMENSION XPGA(-6:6)
      DATA AEM2PI/0.0011614/
C
C...Reset output.
      DO 100 KFL=-6,6
      XPGA(KFL)=0.
  100 CONTINUE
C
C...Evaluate common x-dependent expression.
      XTMP = (X**2+(1.-X)**2) * (-LOG(X)) - 1.
      CGAM = 3.*AEM2PI*X * (XTMP*(1.+P2/(P2+Q02)) + 6.*X*(1.-X))
C
C...d, u, s part by simple charge factor.
      XPGA(1)=(1./9.)*CGAM
      XPGA(2)=(4./9.)*CGAM
      XPGA(3)=(1./9.)*CGAM
C
C...Also fill for antiquarks.
      DO 110 KF=1,5
      XPGA(-KF)=XPGA(KF)
  110 CONTINUE
C
      RETURN
      END
C-----------------------------------------------------------------------
