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 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(X)
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-Bicocca
C($)  School of Physics & Astronomy, University of Manchester
C(&)  Theory Physics Group, CERN
C(#)  Cavendish Laboratory, Cambridge
C(")  School of Physics & Astronomy, Southampton
C(^)  Academia Sinica, Taiwan
C(X)  Institute of Particle Physics Phenomenology, University of Durham
C(@)  Dipartimento di Fisica, Universita di Bologna
C(%)  Dipartimento di Fisica, Universita di Padova
C(~)  Institute of Physics, Prague
C-----------------------------------------------------------------------
C                  Version 6.521 - 11th March 2013
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, JHEP 0101 (2001) 010
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://www.hep.phy.cam.ac.uk/theory/webber/Herwig/
C-----------------------------------------------------------------------
CDECK  ID>, CIRCEE.
*CMZ :-        -03/07/01  17.07.47  by  Bryan Webber
*-- Author :    Bryan Webber
C-----------------------------------------------------------------------
      FUNCTION CIRCEE (X1, X2)
C-----------------------------------------------------------------------
C     DUMMY FUNCTION: DELETE AND SET CIRCOP NON-ZERO
C     IN MAIN PROGRAM IF YOU USE CIRCE BEAM SPECTRUM PACKAGE
C-----------------------------------------------------------------------
      IMPLICIT NONE
      DOUBLE PRECISION CIRCEE, X1, X2
      WRITE (6,10)
   10 FORMAT(/10X,'CIRCEE CALLED BUT NOT LINKED')
      CIRCEE = 0.0D0+X1+X2
      STOP
      END
CDECK  ID>, CIRCES.
*CMZ :-        -03/07/01  17.07.47  by  Bryan Webber
*-- Author :    Bryan Webber
C-----------------------------------------------------------------------
      SUBROUTINE CIRCES (XX1M, XX2M, XROOTS, XACC, XVER, XREV, XCHAT)
C-----------------------------------------------------------------------
C     DUMMY SUBROUTINE: DELETE AND SET CIRCOP NON-ZERO
C     IN MAIN PROGRAM IF YOU USE CIRCE BEAM SPECTRUM PACKAGE
C-----------------------------------------------------------------------
      IMPLICIT NONE
      DOUBLE PRECISION XX1M, XX2M, XROOTS
      INTEGER XACC, XVER, XREV, XCHAT
      WRITE (6,10)
   10 FORMAT(/10X,'CIRCES CALLED BUT NOT LINKED')
      IF (XX1M.GT.1D10) WRITE (6,*) XX2M,XROOTS,XACC,XVER,XREV,XCHAT
      STOP
      END
CDECK  ID>, CIRCGG.
*CMZ :-        -03/07/01  17.07.47  by  Bryan Webber
*-- Author :    Bryan Webber
C-----------------------------------------------------------------------
      FUNCTION CIRCGG (X1, X2)
C-----------------------------------------------------------------------
C     DUMMY FUNCTION: DELETE AND SET CIRCOP NON-ZERO
C     IN MAIN PROGRAM IF YOU USE CIRCE BEAM SPECTRUM PACKAGE
C-----------------------------------------------------------------------
      IMPLICIT NONE
      DOUBLE PRECISION CIRCGG, X1, X2
      WRITE (6,10)
   10 FORMAT(/10X,'CIRCGG CALLED BUT NOT LINKED')
      CIRCGG = 0.0D0+X1+X2
      STOP
      END
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-----------------------------------------------------------------------
      IMPLICIT NONE
      LOGICAL LOGI
      WRITE (6,10)
   10 FORMAT(/10X,'DECADD CALLED BUT NOT LINKED')
      IF (LOGI) STOP
      STOP
      END
CDECK  ID>, DEXAY.
*CMZ :-        -17/10/01  10.03.37  by  Peter Richardson
*-- Author :    Peter Richardson
C-----------------------------------------------------------------------
      SUBROUTINE DEXAY(IMODE,POL)
C-----------------------------------------------------------------------
C     DUMMY SUBROUTINE: DELETE AND SET TAUDEC='TAUOLA'
C     IN MAIN PROGRAM IF YOU USE TAUOLA DECAY PACKAGE
C-----------------------------------------------------------------------
      IMPLICIT NONE
      INTEGER IMODE
      REAL POL(4)
      WRITE (6,10)
   10 FORMAT(/10X,'DEXAY CALLED BUT NOT LINKED')
      IF (IMODE.GT.1000) WRITE (6,*) POL
      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-----------------------------------------------------------------------
      IMPLICIT NONE
      WRITE (6,10)
   10 FORMAT(/10X,'EUDINI CALLED BUT NOT LINKED')
      STOP
      END
CDECK  ID>, FILHEP.
*CMZ :-        -17/10/01  09:42:21  by  Peter Richardson
*-- Author :    Martin W. Gruenewald
C-----------------------------------------------------------------------
      SUBROUTINE FILHEP(N,IST,ID,JMO1,JMO2,JDA1,JDA2,P4,PINV,PHFLAG)
C ----------------------------------------------------------------------
C this subroutine fills one entry into the HEPEVT common
C and updates the information for affected mother entries
C used by TAUOLA
C
C written by Martin W. Gruenewald (91/01/28)
C ----------------------------------------------------------------------
      INCLUDE 'HERWIG65.INC'
      LOGICAL QEDRAD
      COMMON /PHORAD/ QEDRAD(NMXHEP)
      INTEGER N,IHEP,IST,ID,JMO1,JMO2,JDA1,JDA2,I,IP
      REAL PINV
      LOGICAL PHFLAG
      REAL*4 P4(4)
C
C check address mode
      IF (N.EQ.0) THEN
C append mode
        IHEP=NHEP+1
      ELSE IF (N.GT.0) THEN
C absolute position
        IHEP=N
      ELSE
C relative position
        IHEP=NHEP+N
      END IF
C check on IHEP
      IF ((IHEP.LE.0).OR.(IHEP.GT.NMXHEP)) RETURN
C add entry
      NHEP=IHEP
      ISTHEP(IHEP)=IST
      IDHEP(IHEP)=ID
      JMOHEP(1,IHEP)=JMO1
      IF(JMO1.LT.0)JMOHEP(1,IHEP)=JMOHEP(1,IHEP)+IHEP
      JMOHEP(2,IHEP)=JMO2
      IF(JMO2.LT.0)JMOHEP(2,IHEP)=JMOHEP(2,IHEP)+IHEP
      JDAHEP(1,IHEP)=JDA1
      JDAHEP(2,IHEP)=JDA2
      DO I=1,4
        PHEP(I,IHEP)=P4(I)
C KORAL-B and KORAL-Z do not provide vertex and/or lifetime informations
        VHEP(I,IHEP)=0.0
      END DO
      PHEP(5,IHEP)=PINV
C FLAG FOR PHOTOS...
      QEDRAD(IHEP)=PHFLAG
C update process:
      DO IP=JMOHEP(1,IHEP),JMOHEP(2,IHEP)
        IF(IP.GT.0)THEN
C if there is a daughter at IHEP, mother entry at IP has decayed
          IF(ISTHEP(IP).EQ.1)ISTHEP(IP)=2
C and daughter pointers of mother entry must be updated
          IF(JDAHEP(1,IP).EQ.0)THEN
            JDAHEP(1,IP)=IHEP
            JDAHEP(2,IP)=IHEP
          ELSE
            JDAHEP(2,IP)=MAX(IHEP,JDAHEP(2,IP))
          END IF
        END IF
      END DO
      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-----------------------------------------------------------------------
      IMPLICIT NONE
      INTEGER I,J,K
      WRITE (6,10)
   10 FORMAT(/10X,'FRAGMT CALLED BUT NOT LINKED')
      IF (I.GT.1000) WRITE (6,*) J,K
      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-----------------------------------------------------------------------
      IMPLICIT NONE
      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-----------------------------------------------------------------------
      IMPLICIT NONE
      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 'HERWIG65.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 :-        -11/10/01  12.01.52  by  Peter Richardson
*-- Author :    Bryan Webber
C-----------------------------------------------------------------------
      SUBROUTINE HWBCON
C-----------------------------------------------------------------------
C     MAKES COLOUR CONNECTIONS BETWEEN JETS
C     MODIFIED 12/10/97 BY BRW FOR SUSY PROCESSES
C     MODIFIED 11/01/01 BY PR  FOR SPIN CORRELATIONS(PROBLEM WITH ORDER
C                                                    OF DECAYS)
C     NEW VARAIBLE BACK TO ALLOW CODE TO SEARCH DOWN CHAIN
C-----------------------------------------------------------------------
      INCLUDE 'HERWIG65.INC'
      INTEGER IHEP,IST,ID,JC,KC,JD,JHEP,LHEP,ID2,NTRY,KHEP
      LOGICAL BACK
      IF (IERROR.NE.0) RETURN
      IF(.NOT.RPARTY) THEN
        CALL HWBRCN
        RETURN
      ENDIF
      DO 20 IHEP=1,NHEP
      BACK = .FALSE.
      IST=ISTHEP(IHEP)
C---LOOK FOR PARTONS WITHOUT COLOUR MOTHERS
      IF (IST.LT.145.OR.IST.GT.152) GOTO 20
 51   IF (JMOHEP(2,IHEP).EQ.0.OR.BACK.OR.
     &     ISTHEP(JMOHEP(2,IHEP)).EQ.155) THEN
C---FIND COLOUR-CONNECTED PARTON
        IF(BACK) GOTO 52
        IF(JMOHEP(2,IHEP).EQ.0) THEN
          JC=JMOHEP(1,IHEP)
          IF (IST.NE.152) JC=JMOHEP(1,JC)
          JC =JMOHEP(2,JC)
        ELSE
          JC = JMOHEP(2,IHEP)
          JHEP = JC
        ENDIF
        IF (JC.EQ.0) THEN
          CALL HWWARN('HWBCON',51)
          GOTO 20
        ENDIF
C---FIND SPECTATOR WHEN JC IS DECAYED HEAVY QUARK OR SUSY PARTICLE
 52       IF (ISTHEP(JC).EQ.155.OR.BACK) THEN
          IF (IDHEP(JMOHEP(1,JC)).EQ.94.OR.BACK) THEN
C---DECAYED BEFORE HADRONIZING
            IF(BACK.OR.(JMOHEP(2,IHEP).NE.0.AND.
     &                  ISTHEP(JMOHEP(2,IHEP)).EQ.155)) GOTO 53
            JHEP=JMOHEP(2,JC)
C--new bit to try and fix the problems for spin correlations
C--move one step further up the tree and hope this helps
            IF (JHEP.EQ.0) THEN
              NTRY = 0
 1            NTRY = NTRY+1
              JC   = JMOHEP(1,JC)
              JHEP = JMOHEP(2,JC)
              IF(JHEP.NE.0.AND.ISTHEP(JHEP).EQ.155)
     &             JHEP = JMOHEP(2,JHEP)
              IF(JHEP.EQ.0.AND.NTRY.LT.NHEP) GOTO 1
              IF(NHEP.EQ.NTRY) GOTO 20
            ENDIF
 53         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)
                GOTO 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
C--modifcation for top ME correction (modified for additional photon radiation)
                  IF(IDHW(JHEP).EQ.6) THEN
                    JC = JDAHEP(1,JHEP)+1
                  ELSE
                    JC = JDAHEP(1,JHEP)+1
                    IF(IDHW(JDAHEP(1,JHEP)+2).EQ.13) JC=JC+1
                  ENDIF
                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
        ID=IDHW(JHEP)
        JMOHEP(2,IHEP)=JHEP
        JDAHEP(2,JHEP)=IHEP
        GOTO 20
   10   CONTINUE
        IF (LHEP.NE.0) THEN
          JMOHEP(2,IHEP)=LHEP
        ELSE
C--search down the tree
          DO 50 KHEP=JC,JD
          IF(ISTHEP(KHEP).EQ.3.AND.ISTHEP(JDAHEP(1,KHEP)).EQ.155) THEN
            JHEP = JDAHEP(1,KHEP)
            BACK = .TRUE.
            GOTO 51
          ENDIF
 50       CONTINUE
C---DIDN'T FIND PARTNER OF IHEP YET
C          CALL HWWARN('HWBCON',52)
C          GOTO 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  RETURN
      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 'HERWIG65.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
      SAVE WSUM,     X1MIN,X1MAX,EMIT,ICMF,IEVT
      DATA WSUM,WMAX,X1MIN,X1MAX,EMIT,ICMF,IEVT
     & /0.994651D0,1.84096D0,0.0D0,0.773459D0,3*0.0D0/
      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)
      ENDIF
      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 'HERWIG65.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
      SAVE EMIT,COMINT,BGFINT,COMWGT,C1,C2,CM,B1,B2,BM
      DATA EMIT,COMINT,BGFINT,COMWGT/0D0,3.9827D0,1.2462D0,0.3D0/
      DATA C1,C2,CM,B1,B2,BM/0.56D0,0.20D0,10D0,0.667D0,0.167D0,3D0/
      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) THEN
          CALL HWWARN('HWBDIS',100)
          GOTO 999
        ENDIF
        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)
      ENDIF
 999  RETURN
      END
CDECK  ID>, HWBDYP.
*CMZ :-        -02/10/08  14.45.41  by  Mike Seymour
*-- Author :    Gennaro Corcella
C-----------------------------------------------------------------------
      SUBROUTINE HWBDYP(IOPT)
C     MATRIX ELEMENT CORRECTIONS TO DRELL-YAN PROCESSES
C-----------------------------------------------------------------------
      INCLUDE 'HERWIG65.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(3),PS(5),PD(5),P2N(5),
     & PBOS(5),PLAB(5),PTOT(5),P3N(5),SVNTN,PM1(4),PM2(4),HWULDO,
     & PPDOT,GAM,PMDOT,PTMP(4),EMSQ1,EMSQ2
      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
      SAVE EMIT,NTMP
      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)
c---minorimprovement---mhs---4/8/04---include mass effects correctly
        ETA1=(P1(4)+P1(3))/(PHAD1(4)+PHAD1(3))
        ETA2=(P2(4)-P2(3))/(PHAD2(4)-PHAD2(3))
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))
c---minorimprovement---mhs---4/8/04---apply infrared cutoff for large x
          IF ((1-XI1)*SCALE.LT.HWBVMC(ID1)) RETURN
          IF ((1-XI2)*SCALE.LT.HWBVMC(ID2)) 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
c---bug fix---mhs---4/8/04---swap u and t in mtm frac definitions
            XI1=(HALF/PHAD1(4))*EXP(Y)*SQRT(S*(S+T)/(S+U))
            XI2=S/(4*XI1*PHAD1(4)*PHAD2(4))
c---minorimprovement---mhs---4/8/04---apply infrared cutoff for large x
            IF ((1-XI1)*SCALE.LT.HWBVMC(13)) RETURN
            IF ((1-XI2)*SCALE.LT.HWBVMC(ID2)) 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
c---bug fix---mhs---4/8/04---swap u and t in mtm frac definitions
            XI1=(HALF/PHAD1(4))*EXP(Y)*SQRT(S*(S+U)/(S+T))
            XI2=S/(4*XI1*PHAD1(4)*PHAD2(4))
c---minorimprovement---mhs---4/8/04---apply infrared cutoff for large x
            IF ((1-XI1)*SCALE.LT.HWBVMC(ID1)) RETURN
            IF ((1-XI2)*SCALE.LT.HWBVMC(13)) 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
c---bug fix---mhs---4/8/04---swap emitter and nonemitter
          EMIT=2
          IF (HWRGEN(10).LT.(EM**2-S)**2/((EM**2-S)**2+(EM**2-T)**2))
     &         EMIT=1
          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 HWUMAS(PP1)
        CALL HWUMAS(PP2)
C---SUBTRACT A LITTLE EXTRA TO PUT THEM BACK ON MASS-SHELL
        PPDOT=HWULDO(PP1,PP2)
        GAM=PPDOT**2-(PP1(5)*PP2(5))**2
        IF (GAM.LT.0.OR.PP1(5).LE.0.OR.PP2(5).LE.0) THEN
          CALL HWWARN('HWBDYP',100)
          GOTO 999
        ENDIF
        GAM=PPDOT-SQRT(GAM)
        CALL HWVSCA(4,GAM/PP2(5)**2,PP2,PM1)
        CALL HWVDIF(4,PP1,PM1,PM1)
        CALL HWVSCA(4,GAM/PP1(5)**2,PP1,PM2)
        CALL HWVDIF(4,PP2,PM2,PM2)
        PMDOT=HWULDO(PM1,PM2)
        EMSQ1=SIGN(PHEP(5,IHAD1)**2,PHEP(5,IHAD1))
        CALL HWVSCA(4,(PP1(5)**2-EMSQ1)/(2*HWULDO(PP1,PM2)),PM2,PTMP)
        CALL HWVDIF(4,PP1,PTMP,PP1)
        EMSQ2=SIGN(PHEP(5,IHAD2)**2,PHEP(5,IHAD2))
        CALL HWVSCA(4,(PP2(5)**2-EMSQ2)/(2*HWULDO(PP2,PM1)),PM1,PTMP)
        CALL HWVDIF(4,PP2,PTMP,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)
        CALL HWULOF(PLAB,PP1,PP1)
C----PUT HADRON 1 ON THE Z-AXIS
        CALL HWVEQU(3,PP1,PZ)
        MODP=SQRT(PZ(1)**2+PZ(2)**2)
        IF (MODP.EQ.0) THEN
          CALL HWWARN('HWBDYP',101)
          GOTO 999
        ENDIF
        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
C--special for spin correlations(relabel in spin common block)
        IF(SYSPIN.AND.NSPN.NE.0) THEN
          IDSPN(2) = NHEP+1
          IDSPN(3) = NHEP+2
          ISNHEP(NHEP+1) = 2
          ISNHEP(NHEP+2) = 3
        ENDIF
        NHEP=NHEP+2
        EMIT=0
      ENDIF
 999  RETURN
      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 'HERWIG65.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) THEN
        CALL HWWARN('HWBFIN',100)
        GOTO 999
      ENDIF
      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) THEN
          CALL HWWARN('HWBFIN',101)
          GOTO 999
        ENDIF
        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)
   15 JPAR=JCOPAR(1,IPAR)
      KHEP=KHEP+1
      IF(KHEP.GT.NMXHEP) THEN
        CALL HWWARN('HWBFIN',102)
        GOTO 999
      ENDIF
      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  RETURN
      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 'HERWIG65.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)
      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) THEN
        CALL HWWARN('HWBGEN',ISLENT*100)
        GOTO 999
      ENDIF
      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
C--BRW mod 15/12/06 for Nason method
          IF (TRUNSH) THEN
C--If truncated shower added, use smaller of 2 scales for gluon jet
            IF (JHEP.LE.0.OR.JHEP.GT.NHEP) THEN
              CALL HWWARN('HWBGEN',101)
              RETURN
            ENDIF
            ERTXI=HWULDO(PHEP(1,IHEP),PHEP(1,JHEP))/PHEP(4,JHEP)
            JHEP=JDAHEP(2,IHEP)
            IF (JHEP.LE.0.OR.JHEP.GT.NHEP) THEN
              CALL HWWARN('HWBGEN',102)
              RETURN
            ENDIF
            IF (ERTXI.LT.HWULDO(PHEP(1,IHEP),PHEP(1,JHEP))/PHEP(4,JHEP))
     &         JHEP=JMOHEP(2,IHEP)
          ELSE
            IF (HWRLOG(HALF)) JHEP=JDAHEP(2,IHEP)
          ENDIF
C--end mod
        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)
          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  RETURN
      END
CDECK  ID>, HWBGUP.
*CMZ :-        -16/07/02  09.40.25  by  Peter Richardson
*-- Author :    Peter Richardson
C----------------------------------------------------------------------
      SUBROUTINE HWBGUP(ISTART,ICMF)
C----------------------------------------------------------------------
C     Makes the colour connections and performs the parton shower
C     for events read in from the GUPI (Generic User Process Interface)
C     event common block
C----------------------------------------------------------------------
      INCLUDE 'HERWIG65.INC'
      INTEGER MAXNUP
      PARAMETER (MAXNUP=500)
      INTEGER NUP,IDPRUP,IDUP,ISTUP,MOTHUP,ICOLUP
      DOUBLE PRECISION XWGTUP,SCALUP,AQEDUP,AQCDUP,PUP,VTIMUP,SPINUP
      COMMON/HEPEUP/NUP,IDPRUP,XWGTUP,SCALUP,AQEDUP,AQCDUP,
     &              IDUP(MAXNUP),ISTUP(MAXNUP),MOTHUP(2,MAXNUP),
     &              ICOLUP(2,MAXNUP),PUP(5,MAXNUP),VTIMUP(MAXNUP),
     &              SPINUP(MAXNUP)
C--Local variables
      INTEGER ISTART,ICMF,J,K,I,JCOL,ICOL
      LOGICAL FOUND
      COMMON /HWGUP/ILOC(NMXHEP),JLOC(MAXNUP)
      INTEGER ILOC,JLOC
C--now we need to do the colour connections
 20   ISTART = ISTART+1
      IF(ISTART.GT.NHEP) GOTO 30
      IF(ISTART.EQ.ICMF) ISTART = ISTART+1
      IF(JMOHEP(2,ISTART).NE.0.AND.JDAHEP(2,ISTART).NE.0) GOTO 20
      K = ISTART
      J = ILOC(K)
      IF(ICOLUP(1,J).NE.0) THEN
        JCOL = 1
        ICOL = ICOLUP(1,J)
      ELSE
        JCOL = 2
        ICOL = ICOLUP(2,J)
      ENDIF
      IF(ICOL.EQ.0) THEN
        JMOHEP(2,K) = K
        JDAHEP(2,K) = K
        GOTO 20
      ENDIF
C--now search for the partner
C--first search for the flavour partner if not looking for colour partner
C--search for the flavour partner of the particle
C--this must be set or HERWIG won't work
 10   IF(JDAHEP(2,K).NE.0.AND.JMOHEP(2,K).NE.0) GOTO 20
      IF(ICOL.EQ.0) THEN
        FOUND = .FALSE.
C--look for unpaired particle
        DO 15 I=1,NUP
          IF(JLOC(I).EQ.0) GOTO 15
          IF(IDUP(I).EQ.21.OR.IDUP(I).EQ.9) GOTO 15
          IF(JLOC(I).EQ.ISTART) GOTO 15
          IF(ICOLUP(1,I).EQ.0.AND.ICOLUP(2,I).EQ.0) GOTO 15
C--antiflavour partner
          IF(JDAHEP(2,JLOC(I)).EQ.0) THEN
C--pair incoming     particle with outgoing     particle
C-- or  outgoing antiparticle with outgoing     particle
            IF(ISTUP(I).GT.0.AND.IDUP(I).GT.0.AND.
     &         ((IDUP(J).GT.0.AND.ISTUP(J).EQ.-1).OR.
     &          (IDUP(J).LT.0.AND.ISTUP(J).GT.0 )))  THEN
              FOUND = .TRUE.
              JCOL = 1
C--pair incoming     particle with incoming antiparticle
C-- or  outgoing antiparticle with incoming antiparticle
            ELSEIF(IDUP(I).LT.0.AND.ISTUP(I).EQ.-1.AND.
     &             ((IDUP(J).GT.0.AND.ISTUP(J).EQ.-1).OR.
     &              (IDUP(J).LT.0.AND.ISTUP(J).GT.0 ))) THEN
              FOUND = .TRUE.
              JCOL = 2
            ENDIF
C--make the connection
            IF(FOUND) THEN
              JMOHEP(2,K)       = JLOC(I)
              JDAHEP(2,JLOC(I)) = K
            ENDIF
          ENDIF
C--flavour partner
          IF(JMOHEP(2,JLOC(I)).EQ.0.AND.(.NOT.FOUND)) THEN
C--pair incoming antiparticle with outgoing antiparticle
C-- or  outgoing     particle with outgoing antiparticle
            IF(IDUP(I).LT.0.AND.ISTUP(I).GT.0.AND.
     &         ((IDUP(J).LT.0.AND.ISTUP(J).EQ.-1).OR.
     &          (IDUP(J).GT.0.AND.ISTUP(J).GT.0 ))) THEN
              FOUND = .TRUE.
              JCOL = 2
C--pair incoming antiparticle with incoming     particle
C-- or  outgoing     particle with incoming     particle
            ELSEIF(IDUP(I).GT.0.AND.ISTUP(I).EQ.-1.AND.
     &             ((IDUP(J).LT.0.AND.ISTUP(J).EQ.-1).OR.
     &              (IDUP(J).GT.0.AND.ISTUP(J).GT.0 ))) THEN
              FOUND = .TRUE.
              JCOL = 1
            ENDIF
C--make the connection
            IF(FOUND) THEN
              JDAHEP(2,K) = JLOC(I)
              JMOHEP(2,JLOC(I)) = K
            ENDIF
          ENDIF
C--set up the search for the next partner
          IF(FOUND) THEN
            FOUND = .FALSE.
            ICOL = ICOLUP(JCOL,I)
            K = JLOC(I)
            J = I
            GOTO 10
          ENDIF
 15     CONTINUE
C--if no other choice then connect to the first particle in the loop
        IF(JDAHEP(2,K).EQ.0.AND.JMOHEP(2,ISTART).EQ.0) THEN
           JDAHEP(2,K) = ISTART
           JMOHEP(2,ISTART) = K
        ELSEIF(JDAHEP(2,ISTART).EQ.0.AND.JMOHEP(2,K).EQ.0) THEN
           JMOHEP(2,K) = ISTART
           JDAHEP(2,ISTART) = K
        ELSE
          CALL HWWARN('HWBGUP',100)
          GOTO 999
        ENDIF
        GOTO 20
      ENDIF
C--now the bit to find colour partners
      FOUND = .FALSE.
C--special for particle from a decaying coloured particle
      IF(MOTHUP(1,J).NE.0) THEN
        IF(ISTUP(MOTHUP(1,J)).EQ.2.OR.ISTUP(MOTHUP(1,J)).EQ.3) THEN
          IF(IDUP(J).LT.0.AND.ICOL.EQ.ICOLUP(2,MOTHUP(1,J))) THEN
            JDAHEP(2,K) = JLOC(MOTHUP(1,J))
            JMOHEP(2,K) = JLOC(MOTHUP(1,J))
            GOTO 20
          ELSEIF(IDUP(J).GT.0.AND.ICOL.EQ.ICOLUP(1,MOTHUP(1,J))) THEN
            JDAHEP(2,K) = JLOC(MOTHUP(1,J))
            JMOHEP(2,K) = JLOC(MOTHUP(1,J))
            GOTO 20
          ENDIF
        ENDIF
      ENDIF
C--search for the partner
      DO I=1,NUP
        IF(ICOLUP(1,I).EQ.ICOL.AND.I.NE.J) THEN
          IF((JCOL.EQ.1.AND.ISTUP(J).EQ.-1.AND.ISTUP(I).GT.0).OR.
     &       (JCOL.EQ.2.AND.ISTUP(J).GT.0.AND.ISTUP(I).GE.0)) THEN
            JDAHEP(2,K)       = JLOC(I)
            JMOHEP(2,JLOC(I)) = K
            FOUND = .TRUE.
          ELSEIF((JCOL.EQ.1.AND.ISTUP(J).GT.0.AND.ISTUP(I).EQ.-1).OR.
     &          (JCOL.EQ.2.AND.ISTUP(J).EQ.-1.AND.ISTUP(I).EQ.-1)) THEN
            JMOHEP(2,K)       = JLOC(I)
            JDAHEP(2,JLOC(I)) = K
            FOUND = .TRUE.
          ENDIF
          IF(FOUND) JCOL = 2
        ELSEIF(ICOLUP(2,I).EQ.ICOL.AND.I.NE.J) THEN
          IF((JCOL.EQ.1.AND.ISTUP(J).EQ.-1.AND.ISTUP(I).EQ.-1).OR.
     &       (JCOL.EQ.2.AND.ISTUP(J).GT.0.AND.ISTUP(I).EQ.-1)) THEN
            JDAHEP(2,K) = JLOC(I)
            JMOHEP(2,JLOC(I)) = K
            FOUND = .TRUE.
          ELSEIF((JCOL.EQ.1.AND.ISTUP(J).GE.0.AND.ISTUP(I).GE.0).OR.
     &           (JCOL.EQ.2.AND.ISTUP(J).EQ.-1.AND.ISTUP(I).GE.0)) THEN
            JMOHEP(2,K) = JLOC(I)
            JDAHEP(2,JLOC(I)) = K
            FOUND = .TRUE.
          ENDIF
          IF(FOUND) JCOL = 1
        ENDIF
        IF(FOUND) THEN
          K = JLOC(I)
          J = I
          ICOL = ICOLUP(JCOL,I)
          GOTO 10
        ENDIF
      ENDDO
C--special for self connected gluons
      IF(IDUP(J).EQ.21.OR.IDUP(J).EQ.9.AND.
     &     ICOLUP(1,J).EQ.ICOLUP(2,J)) THEN
        JMOHEP(2,K) = K
        JDAHEP(2,K) = K
C--options for self connected gluons
        IF(LHGLSF) THEN
          CALL HWWARN('HWBGUP',1)
        ELSE
          CALL HWWARN('HWBGUP',101)
          GOTO 999
        ENDIF
        GOTO 20
      ENDIF
C--perform the shower
 30   CALL HWBGEN
C--recompute spectator etc if process was direct photoproduction
      J=JDAHEP(1,1)
      IF (J.LE.0) RETURN
      IF (IDHEP(J).NE.22) RETURN
      DO I=J+1,NHEP
         IF (IDHEP(I).EQ.22.AND.ISTHEP(I).EQ.3) THEN
            K=I
            GOTO 40
         ENDIF
      ENDDO
      RETURN
 40   CALL HWVEQU(4,PHEP(1,K),PHEP(1,J))
      CALL HWVSUM(4,PHEP(1,K),PHEP(1,2),PHEP(1,3))
      CALL HWUMAS(PHEP(1,3))
      J=JDAHEP(2,1)
      CALL HWVDIF(4,PHEP(1,1),PHEP(1,K),PHEP(1,J))
      CALL HWUMAS(PHEP(1,J))
 999  RETURN
      END
CDECK  ID>, HWBJCO.
*CMZ :-        -30/09/02  09.19.58  by  Peter Richardson
*-- Author :    Bryan Webber
C-----------------------------------------------------------------------
      SUBROUTINE HWBJCO
C-----------------------------------------------------------------------
C     COMBINES JETS WITH REQUIRED KINEMATICS
C-----------------------------------------------------------------------
      INCLUDE 'HERWIG65.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),PA(5),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),HWUSQR
      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,HWUSQR
      PARAMETER (EPS=1.D-4)
      IF (IERROR.NE.0) RETURN
      AZCOR=AZSOFT.OR.AZSPIN
      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) THEN
          CALL HWWARN('HWBJCO',100)
          GOTO 999
        ENDIF
        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) THEN
          CALL HWWARN('HWBJCO',103)
          GOTO 999
        ENDIF
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) THEN
            CALL HWWARN('HWBJCO',102)
            GOTO 999
          ENDIF
          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)
          GOTO 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)
            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
C---BUG FIX BY MHS 17/03/05: RETURNED TO VERSION 6.500!
              IF (ISTHEP(KP).EQ.100.AND.ISTHEP(KP-1).GE.141
     $                             .AND.ISTHEP(KP-1).LE.144) THEN
C---END FIX
                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
C--change to preserve either long mom or rapidity rather than long mom
C--by PR and BRW 30/9/02
C--BRW fix 6/11/08: reset CM pL (may have been rescaled already)
          PHEP(3,ICM)=PHEP(3,IP1)+PHEP(3,IP2)
C--End BRW fix 6/11/08
          IF (PRESPL) THEN
C--PRESERVE LONG MOM OF CMF
            PHEP(4,ICM)=
     &            SQRT(PTX**2+PTY**2+PHEP(3,ICM)**2+PHEP(5,ICM)**2)
          ELSE
C--PRESERVE RAPIDITY OF CMF
C--BRW fix 6/11/08: reset CM E (may have been rescaled already)
            PHEP(4,ICM)=PHEP(4,IP1)+PHEP(4,IP2)
C--End BRW fix 6/11/08
            DET=SQRT(ONE+(PTX**2+PTY**2)/(PHEP(4,ICM)**2
     &                -PHEP(3,ICM)**2))
            CALL HWVSCA(2,DET,PHEP(3,ICM),PHEP(3,ICM))
          ENDIF
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=HWUSQR(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) THEN
C--BRW FIX 12/06/08
             IF (PJ(KP).GT.-EPS*EPS) THEN
                PJ(KP)=ZERO
             ELSE
                CALL HWWARN('HWBJCO',104)
                GOTO 999
             ENDIF
C--END FIX
          ENDIF
  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)
            GOTO 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
C--Modified by MHS 17/08/05 to do unboost in 2 stages (trans,long)
          PA(1)=PQ(1)
          PA(2)=PQ(2)
          PA(3)=ZERO
          PA(5)=SQRT(PQ(3)**2+PQ(5)**2)
          PA(4)=PQ(4)
          CALL HWULOF(PA,PR,PR)
          PA(1)=ZERO
          PA(2)=ZERO
          PA(3)=PQ(3)
          PA(4)=PA(5)
          PA(5)=PQ(5)
          CALL HWULOF(PA,PR,PR)
C--End mod
          CALL HWUROT(PR, ONE,ZERO,RR)
          PR(1)=ZERO
          PR(2)=ZERO
          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)
C--Modified by BRW 25/10/02 to do boost in 2 stages (long,trans)
          PA(1)=ZERO
          PA(2)=ZERO
          PA(3)=PC(3)
          PA(5)=PC(5)
          PA(4)=SQRT(PA(3)**2+PA(5)**2)
          CALL HWULOB(PA,PR,PR)
          PA(1)=PC(1)
          PA(2)=PC(2)
          PA(3)=ZERO
          PA(5)=PA(4)
          PA(4)=PC(4)
          CALL HWULOB(PA,PR,PR)
C--End mod
        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)
            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
C---BUG FIX BY MHS 17/03/05: RETURNED TO VERSION 6.500!
              IF (ISTHEP(JP).EQ.100.AND.ISTHEP(JP-1).GE.141
     $                             .AND.ISTHEP(JP-1).LE.144) THEN
C---END FIX
                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))
C--MHS FIX 07/03/05 FOR VERTEX POSITION OF LONG LIVED NON-PARTON JETS
        IF (KHEP.EQ.IHEP.AND.(IDHW(JHEP).GE.121.AND.IDHW(JHEP).LE.132
     $       .OR.IDHW(JHEP).EQ.59))
     $       CALL HWVSUM(4,VTXPIP,VHEP(1,JHEP),VHEP(1,JHEP))
C--END FIX
  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)))
C--MHS FIX 07/03/05 - DO NOT REBOOST PRIMARY VERTEX
            IF (ISTHEP(IJET(IP)).EQ.190)
     $           CALL HWVDIF(4,VHEP(1,IJET(IP)),VTXPIP,VHEP(1,IJET(IP)))
            CALL HWULB4(PLAB,VHEP(1,IJET(IP)),VHEP(1,IJET(IP)))
            IF (ISTHEP(IJET(IP)).EQ.190)
     $           CALL HWVSUM(4,VHEP(1,IJET(IP)),VTXPIP,VHEP(1,IJET(IP)))
C---END FIX
            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  RETURN
      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 'HERWIG65.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(ABS((EMI-EMJ-EMK)**2-4*EMJ*EMK)))/(2*EMI))
              ZMAX=1-MAX((EMI-EMJ+EMK)/(2*(EMI+NQ)),
     $      (EMI-EMJ+EMK-SQRT(ABS((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 'HERWIG65.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
      SAVE ISUD
      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) THEN
          CALL HWWARN('HWBRAN',100)
          GOTO 999
        ENDIF
        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) THEN
                      CALL HWWARN('HWBRAN',101)
                      GOTO 999
                    ENDIF
                    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)
                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.AND.IS.NE.0) THEN
          CALL HWWARN('HWBRAN',104)
          GOTO 999
        ENDIF
        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  RETURN
      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 'HERWIG65.INC'
      INTEGER IHEP,IST,ID,JC,JD,JHEP,IDP,IDM,IDM2,
     &        RHEP,IST2,ANTC,XHEP,IP,COLP
      LOGICAL BVVUSE,BVVHRD,BVDEC1,BVDEC2,COLRD,ACOLRD,BVHRD,BVHRD2,
     &        BVDEC3
      LOGICAL IFGO
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) THEN
        CALL HWWARN('HWBRCN',101)
        GOTO 999
      ENDIF
      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))
        ELSE
          IDP  = 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) THEN
          CALL HWWARN('HWBCON',51)
          GOTO 110
        ENDIF
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.,IFGO)
                IF(IFGO) GOTO 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
      IF(IST.EQ.155.AND.IST2.EQ.155) THEN
        IDM = IDHW(XHEP)
        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.,IFGO)
            IF(IFGO) GOTO 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.,IFGO)
            IF(IFGO) GOTO 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) THEN
          IF(IDHW(IHEP).GE.7.AND.IDHW(IHEP).LE.12)
     &          JMOHEP(2,IHEP)=JDAHEP(1,JC)
          GOTO 400
        ENDIF
        IF (ID.EQ.449) THEN
C--SPECIAL FOR GLUINO DECAYS
          ID=IDHW(IHEP)
          CALL HWBRC1(JC,ID,JHEP,.TRUE.,IFGO)
          IF(IFGO) GOTO 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)
            IF(IDHW(JHEP).EQ.6.AND.IDHW(JC).EQ.13) JC=JC-1
          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.,IFGO)
          IF(IFGO) GOTO 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) THEN
          CALL HWWARN('HWBRCN',51)
          GOTO 610
        ENDIF
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) THEN
              CALL HWWARN('HWBRCN',52)
              GOTO 610
            ENDIF
              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.,IFGO)
                      IF(IFGO) GOTO 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
            IF(ISTHEP(JMOHEP(1,JC)).EQ.155
     &            .AND.IDHW(JC).LE.6) THEN
               JDAHEP(2,IHEP) = JDAHEP(2,JMOHEP(1,JC)-1)
               IF(JDAHEP(2,IHEP).NE.0) GOTO 610
            ENDIF
            CALL HWWARN('HWBRCN',100)
            GOTO 610
          ENDIF
        ENDIF
 610  CONTINUE
 999  RETURN
      END
CDECK  ID>, HWBRC1.
*CMZ :-        -20/07/99  10:56:12  by  Peter Richardson
*-- Author :    PeterRichardson
C-----------------------------------------------------------------------
      SUBROUTINE HWBRC1(JC,ID,JHEP,COL,IFGO)
C-----------------------------------------------------------------------
C--Function to find the right daugther of a decaying gluino
C-----------------------------------------------------------------------
      INCLUDE 'HERWIG65.INC'
      INTEGER ID,JHEP,KC,JC
      LOGICAL COL,IFGO
C---N.B. WILL NEED MODS WHEN SUSY PARTICLES CAN SHOWER
C--Rparity take the first daughther
      IFGO = .FALSE.
      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)
      IFGO = .TRUE.
      RETURN
 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 'HERWIG65.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)
     &  .AND..NOT.(IDHW(JMOHEP(1,JC)).EQ.13.AND.
     &        IDHW(JMOHEP(1,JMOHEP(1,JC))).EQ.12.AND.
     &        ISTHEP(JMOHEP(1,JMOHEP(1,JC))).EQ.155)
     &        )) THEN
C--special for gluino decay to gluon
         IF(ID.EQ.449.AND.IDHW(JMOHEP(1,JMOHEP(1,JC))).EQ.449.AND.
     &          IDHW(JMOHEP(1,JC)).EQ.13) RETURN
         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 'HERWIG65.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 IPAR,JPAR,KPAR,LPAR,MPAR,JSTR,LSTR,MSTR
      LOGICAL EICOR
      EXTERNAL HWRGEN
      SAVE ZERO2,DMIN
      DATA ZERO2,DMIN/2*0D0,1D-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
         IF (ABS(PPAR(5,MPAR)).LT.DMIN) THEN
           EISCR=ONE
         ELSE
           EISCR=ONE-(PPAR(5,MPAR)/PPAR(4,MPAR))**2
     &           /MIN(PPAR(2,LPAR),PPAR(2,MPAR))
         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))
         EIKON=MAX(EISCR+EINUM/MAX(EIDEN1-EIDEN2,DMIN),ZERO)
      ENDIF
C Spin correlations
      WT=ZERO
      SPIN=ONE
      IF (AZSPIN.AND.IDPAR(JPAR).EQ.13) THEN
         Z1=PPAR(4,JPAR)/PPAR(4,MPAR)
         Z2=ONE-Z1
         IF (IDPAR(MPAR).EQ.13) THEN
            TR=Z1/Z2+Z2/Z1+Z1*Z2
         ELSEIF (IDPAR(MPAR).LT.13) THEN
            TR=(ONE+Z2**2)/(TWO*Z1)
         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)=ZERO
      PPAR(2,MPAR)=ZERO
      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  CONTINUE
      CALL HWVEQU(2,ZERO2,RHOPAR(1,MPAR))
      CALL HWUMAS(PPAR(1,2))
      CALL HWVZRO(4,VPAR(1,MPAR))
      JSTR=JPAR
      LSTR=LPAR
      MSTR=MPAR
  70  JPAR=JSTR
      LPAR=LSTR
      MPAR=MSTR
      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)
C BRW modified here 19/06/01 to avoid compiler-dependent bug
C (overwriting of JPAR etc.)
      IPAR=MPAR+1
      KPAR=JMOPAR(1,IPAR)
      IF (JPAR.EQ.KPAR) THEN
         LPAR=MPAR+1
      ELSE
         LPAR=MPAR-1
      ENDIF
      JSTR=JPAR
      LSTR=LPAR
      MSTR=MPAR
      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, otherwise zero. Assignments based upon
C     Comp. Phys. Comm. 58 (1990) 271.
C-----------------------------------------------------------------------
      INCLUDE 'HERWIG65.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).OR.(IPRO.EQ.36)) THEN
C A gluon fusion ---> Higgs event
         IF (IST.EQ.2) THEN
            IF (IHIGGS.NE.4) THEN
               DECPAR(1,2)=RHOPAR(1,2)
               DECPAR(2,2)=-RHOPAR(2,2)
            ELSE
               DECPAR(1,2)=-RHOPAR(1,2)
               DECPAR(2,2)=RHOPAR(2,2)
            END IF
            RETURN
         ENDIF
      ELSEIF (IPRO.EQ.42) THEN
C A gluon fusion (or qq-bar annihilation) ---> graviton production 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-----------------------------------------------------------------------
      IMPLICIT NONE
      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-----------------------------------------------------------------------
      IMPLICIT NONE
      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 'HERWIG65.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)
        IF (VGCUT .NE.VGOLD) CALL HWWARN('HWBSUD',502)
        IF (VQCUT .NE.VQOLD) CALL HWWARN('HWBSUD',503)
        IF (ACCUR .NE.ACOLD) CALL HWWARN('HWBSUD',504)
        IF (INTER .NE.INOLD) CALL HWWARN('HWBSUD',505)
        IF (NQEV  .NE.NQOLD) CALL HWWARN('HWBSUD',506)
        IF (NSUD  .NE.NSOLD) CALL HWWARN('HWBSUD',507)
        IF (NCOLO .NE.NCOLD) CALL HWWARN('HWBSUD',508)
        IF (NFLAV .NE.NFOLD) CALL HWWARN('HWBSUD',509)
        IF (SUDORD.NE.SDOLD) CALL HWWARN('HWBSUD',510)
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)
          IF (QEV(NQEV,IS).LT.QLIM.AND.HWBVMC(IS)+QG.LT.QLIM)
     &      CALL HWWARN('HWBSUD',500)
   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
      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-----------------------------------------------------------------------
      IMPLICIT NONE
      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 'HERWIG65.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 'HERWIG65.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
      SAVE ZERO2,DMIN
      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) THEN
           CALL HWWARN('HWBTIM',100)
           GOTO 999
         ENDIF
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))
            IF (ABS(PPAR(2,MPAR)).LT.DMIN) THEN
              IF (ABS(PPAR(5,MPAR)).LT.DMIN) THEN
                 EISCR=ONE
              ELSE
                 CALL HWWARN('HWBTIM',102)
                 GOTO 999
              ENDIF
            ELSE
              EISCR=ONE-(PPAR(5,MPAR)/PPAR(4,MPAR))**2
     &              /MIN(PPAR(2,LPAR),PPAR(2,MPAR))
            ENDIF
            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) THEN
           CALL HWWARN('HWBTIM',101)
           GOTO 999
         ENDIF
         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  RETURN
      END
CDECK  ID>, HWBTOP.
*CMZ :-        -31/03/00  17:54:05  by  Peter Richardson
*-- Author :    Gennaro Corcella
C-----------------------------------------------------------------------
      SUBROUTINE HWBTOP
C-----------------------------------------------------------------------
      INCLUDE 'HERWIG65.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
        GOTO 1000
      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))
     $     GOTO 1000
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)))) GOTO 1000
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
C--modification to allow photon radiation via photos in top decay
 1000 IF(ITOPRD.EQ.1) CALL HWPHTP(ICMF)
      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 'HERWIG65.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 'HERWIG65.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
      END
CDECK  ID>, HWCBVI.
*CMZ :-        -12/12/01  14:59:58  by  Peter Richardson
*-- 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 'HERWIG65.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)
      SAVE IDIQK
      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) THEN
          CALL HWWARN('HWCBVI',100)
          GOTO 999
        ENDIF
        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) THEN
          CALL HWWARN('HWCBVI',100)
          GOTO 999
        ENDIF
        IBV(NBV)=IHEP
        DUNBV(NBV)=.FALSE.
      ENDIF
 11   CONTINUE
      IF (NBV.EQ.0) RETURN
      IF(MOD(NBV,3).NE.0) THEN
        CALL HWWARN('HWCBVI',101)
        GOTO 999
      ENDIF
C---PROCESS FOUND PARTONS, STARTING AT RANDOM POINT IN LIST
      NBR=INT(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)
        GOTO 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 (IERROR.NE.0) RETURN
            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)
              GOTO 999
            ENDIF
            IF (SPLIT) GO TO 5
C---Unable to form cluster; dispose of event
            CALL HWWARN('HWCBVI',-3)
            GOTO 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)
          GOTO 999
   35     IDHEP(IQ1)=IDPDG(IDHW(IQ1))
          IDHEP(NHEP)=IDPDG(IDHW(NHEP))
        ENDIF
      ENDIF
  100 CONTINUE
 999  RETURN
      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 'HERWIG65.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
      END
CDECK  ID>, HWCCCC.
*CMZ :-
*-- Author :    Peter Richardson
C-----------------------------------------------------------------------
      SUBROUTINE HWCCCC
C-----------------------------------------------------------------------
C  Subroutine to correct colour connections after the gluon splitting
C-----------------------------------------------------------------------
      INCLUDE 'HERWIG65.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 'HERWIG65.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
      IF (MHEP.GT.NMXHEP) THEN
        CALL HWWARN('HWCCUT',100)
        GOTO 999
      ENDIF
      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  RETURN
      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 'HERWIG65.INC'
      INTEGER JCL,KCL,IP,JP,KP,IST,ID1,ID2,ID3
      IF (IERROR.NE.0) RETURN
      IF (IPRO/10.EQ.9.OR.IPRO/10.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) THEN
            CALL HWWARN('HWCDEC',100)
            GOTO 999
          ENDIF
          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  RETURN
      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-----------------------------------------------------------------------
      IMPLICIT NONE
      INTEGER JD1,JD2,ID1,ID2,JD,JDEC(12)
      SAVE JDEC
      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 'HERWIG65.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)
      SAVE MAP
      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)
            GOTO 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)
        IF (IERROR.NE.0) RETURN
      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 (IERROR.NE.0) RETURN
          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) THEN
          CALL HWWARN('HWCFOR',105)
          GOTO 999
        ENDIF
        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)))) THEN
          CALL HWWARN('HWCFOR',104)
          GOTO 999
        ENDIF
        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.MIN(RMIN(ID1,1)+RMIN(1,ID3),
     $       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/(MIN(RMIN(ID1,1)+RMIN(1,ID3),
     $       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-2*HWRINT(0,1)
      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)
        GOTO 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)
        GOTO 999
      ENDIF
  140 CONTINUE
      CALL HWWARN('HWCFOR',103)
      GOTO 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))
C--MHS FIX 07/03/05 - VERTEX SHOULD BE RELATIVE TO FIXED AXES
        CALL HWVSUM(4,VTXPIP,VHEP(1,IHEP),VHEP(1,NHEP))
C--END FIXES
        JMOHEP(1,NHEP)=IHEP
        JMOHEP(2,NHEP)=JMOHEP(1,IHEP)
        JDAHEP(1,NHEP)=0
        JDAHEP(2,NHEP)=0
      ENDIF
  160 CONTINUE
 999  RETURN
      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 'HERWIG65.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)
      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) THEN
            CALL HWWARN('HWCGSP',102)
            GOTO 999
          ENDIF
          IF (KHEP.NE.1) THEN
            CALL HWWARN('HWCGSP',103)
            GOTO 999
          ENDIF
C BRW FIX 13/07/10
          CALL HWWARN('HWCGSP',13)
          JHEP=JMOHEP(2,IHEP)
C END FIX
        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)
          GOTO 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) THEN
            CALL HWWARN('HWCGSP',104)
            GOTO 999
          ENDIF
          IF (KHEP.NE.1) THEN
            CALL HWWARN('HWCGSP',105)
            GOTO 999
          ENDIF
C BRW FIX 13/07/10
          CALL HWWARN('HWCGSP',15)
          JHEP=JMOHEP(2,IHEP)
C END FIX
          KHEP=JDAHEP(2,IHEP)
        ENDIF
C END FIX
C---CHECK FOR DECAYED HEAVY QUARKS
        IF (ISTHEP(KHEP).EQ.155)  THEN
          CALL HWWARN('HWCGSP',101)
          GOTO 999
        ENDIF
        IF (IDHW(IHEP).EQ.13) THEN
C---SPLIT A GLUON
          LHEP=LHEP+2
          MHEP=MHEP+2
          IF(MHEP.GT.NMXHEP) THEN
            CALL HWWARN('HWCGSP',106)
            GOTO 999
          ENDIF
  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) THEN
            CALL HWWARN('HWCGSP',107)
            GOTO 999
          ENDIF
          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  RETURN
      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 'HERWIG65.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)
      IF (LOCN(ID1,ID3).LE.0) THEN
        CALL HWWARN('HWCHAD',104)
        GOTO 999
      ENDIF
      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) THEN
          CALL HWWARN('HWCHAD',100)
          GOTO 999
        ENDIF
        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
          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)
          GOTO 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) THEN
          CALL HWWARN('HWCHAD',102)
          GOTO 999
        ENDIF
        PCM=0.5*SQRT(PCM)/EM0
        MHEP=NHEP+1
        NHEP=NHEP+2
        IF (NHEP.GT.NMXHEP) THEN
          CALL HWWARN('HWCHAD',103)
          GOTO 999
        ENDIF
        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  RETURN
      END
CDECK  ID>, HWD2ME.
*CMZ :-        -09/04/02  13:37:38  by  Peter Richardson
*-- Author :    Peter Richardson
C-----------------------------------------------------------------------
      SUBROUTINE HWD2ME(IMODE)
C-----------------------------------------------------------------------
C     Computes the width and maximum weight for a two body mode
C-----------------------------------------------------------------------
      INCLUDE 'HERWIG65.INC'
      INTEGER IMODE,I
      DOUBLE PRECISION A(2),M(3),PCM,E1,E2,HWUPCM,PHS,WGT,MWGT,PCM2,
     &     M2(3)
      EXTERNAL HWUPCM
C--set up the masses and couplings
      M(1) = RMASS(IDK(ID2PRT(IMODE)))
      DO 1 I=1,2
      A(I)   = A2MODE(I,IMODE)
 1    M(I+1) = RMASS(IDKPRD(I,ID2PRT(IMODE)))
      DO 2 I=1,3
 2    M2(I)  = M(I)**2
C--first compute the masses etc
      PCM = HWUPCM(M(1),M(2),M(3))
      PCM2 = PCM**2
      PHS = PCM/M2(1)/8.0D0/PIFAC
C--now compute the width and max weight
C--first the fermion --> fermion scalar diagrams
      IF(I2DRTP(IMODE).EQ.1) THEN
        WGT = HALF*((A(1)**2+A(2)**2)*(M2(1)+M2(2)-M2(3))
     &              +FOUR*A(1)*A(2)*M(1)*M(2))
        E1 = SQRT(M2(2)+PCM2)
        E2 = SQRT(M2(3)+PCM2)
        MWGT = HALF*M2(1)/(E1+E2)*(E1+PCM)*ABS(A(1)**2-A(2)**2)+WGT
C--next the fermion --> scalar fermion   diagrams
      ELSEIF(I2DRTP(IMODE).EQ.2) THEN
        WGT = HALF*((A(1)**2+A(2)**2)*(M2(1)+M2(3)-M2(2))
     &              +FOUR*A(1)*A(2)*M(1)*M(3))
        E1 = SQRT(M2(2)+PCM2)
        E2 = SQRT(M2(3)+PCM2)
        MWGT = HALF*M2(1)/(E1+E2)*(E2+PCM)*ABS(A(1)**2-A(2)**2)+WGT
C--next the fermion --> scalar antifermion   diagrams
      ELSEIF(I2DRTP(IMODE).EQ.3) THEN
        WGT = HALF*((A(1)**2+A(2)**2)*(M2(1)+M2(3)-M2(2))
     &              +FOUR*A(1)*A(2)*M(1)*M(3))
        E1 = SQRT(M2(2)+PCM2)
        E2 = SQRT(M2(3)+PCM2)
        MWGT = HALF*M2(1)/(E1+E2)*(E2+PCM)*ABS(A(1)**2-A(2)**2)+WGT
C--next the fermion --> fermion gauge boson diagrams
      ELSEIF(I2DRTP(IMODE).EQ.4) THEN
        WGT = 2.0D0*(M2(1)-M2(2))**2
        MWGT = WGT
C--next the scalar --> fermion antifermion diagrams
      ELSEIF(I2DRTP(IMODE).EQ.5) THEN
        WGT = (M2(1)-M2(2)-M2(3))*(A(1)**2+A(2)**2)
     &        -FOUR*M(2)*M(3)*A(1)*A(2)
        MWGT = WGT
C--next the scalar --> fermion fermion diagrams
      ELSEIF(I2DRTP(IMODE).EQ.6) THEN
        WGT = (M2(1)-M2(2)-M2(3))*(A(1)**2+A(2)**2)
     &        -FOUR*M(2)*M(3)*A(1)*A(2)
        MWGT = WGT
C--next the fermion --> fermion pion diagrams
      ELSEIF(I2DRTP(IMODE).EQ.7) THEN
        WGT = HALF/FOUR/RMASS(198)**4*(
     &        (A(1)**2+A(2)**2)*((M2(1)-M2(2))**2-M2(3)*(M2(1)+M2(2)))
     &         +FOUR*M(1)*M(2)*M2(3)*A(1)*A(2))
        E1 = SQRT(M2(2)+PCM2)
        E2 = SQRT(M2(3)+PCM2)
        MWGT =ONE/8.0D0/RMASS(198)**4*ABS(A(1)**2-A(2)**2)*
     &        M(1)*(M(1)*M2(3)+(M2(1)-M2(2)+M2(3))*(E2+PCM))+WGT
C--next scalar --> antifermion fermion diagrams
      ELSEIF(I2DRTP(IMODE).EQ.8) THEN
        WGT = (M2(1)-M2(2)-M2(3))*(A(1)**2+A(2)**2)
     &        -FOUR*M(2)*M(3)*A(1)*A(2)
        MWGT = WGT
C--next fermion --> gravitino photon
      ELSEIF(I2DRTP(IMODE).EQ.9) THEN
        WGT = 8.0D0*M2(1)**3
        MWGT = WGT
C--next fermion --> gravitino scalar
      ELSEIF(I2DRTP(IMODE).EQ.10) THEN
        WGT = HALF*(M2(1)-M2(3))**3
        E1 = SQRT(M2(2)+PCM2)
        E2 = SQRT(M2(3)+PCM2)
        MWGT = TWO*M2(1)/(E1+E2)*(E1+PCM)*(M2(1)-M2(3))**2 +WGT
C--next sfermion --> fermion gravitino
      ELSEIF(I2DRTP(IMODE).EQ.11) THEN
        WGT = (M2(1)-M2(2))**3
        MWGT = WGT
C--next antisfermion --> fermion gravitino
      ELSEIF(I2DRTP(IMODE).EQ.12) THEN
        WGT = (M2(1)-M2(2))**3
        MWGT = WGT
C--next the scalar --> antifermion antifermion diagrams
      ELSEIF(I2DRTP(IMODE).EQ.13) THEN
        WGT = (M2(1)-M2(2)-M2(3))*(A(1)**2+A(2)**2)
     &        -FOUR*M(2)*M(3)*A(1)*A(2)
        MWGT = WGT
C--next the antifermion --> scalar antifermion diagrams
      ELSEIF(I2DRTP(IMODE).EQ.14) THEN
        WGT = HALF*((A(1)**2+A(2)**2)*(M2(1)+M2(3)-M2(2))
     &              +FOUR*A(1)*A(2)*M(1)*M(3))
        E1 = SQRT(M2(2)+PCM2)
        E2 = SQRT(M2(3)+PCM2)
        MWGT = HALF*M2(1)/(E1+E2)*(E2+PCM)*ABS(A(1)**2-A(2)**2)+WGT
C--unrecognised issue warning
      ELSE
        CALL HWWARN('HWITWO',500)
      ENDIF
      WGT  =       P2MODE(IMODE)* WGT*PHS
      MWGT = 1.1D0*P2MODE(IMODE)*MWGT*PHS
C--put the information in the common block
      WT2MAX(IMODE) = MWGT
C--output the information
      IF(IPRINT.GE.2) THEN
        WRITE(*,3010) WGT
        WRITE(*,3020) MWGT
        WRITE(*,3030) WGT/HBAR/BRFRAC(ID2PRT(IMODE))*
     &       RLTIM(IDK(ID2PRT(IMODE)))
      ENDIF
      RETURN
C--format statements
 3010 FORMAT('            PARTIAL WIDTH  = ',G12.4)
 3020 FORMAT('            MAXIMUM WEIGHT = ',E12.4)
 3030 FORMAT('     RATIO TO ISAJET VALUE = ',G12.4)
      END
CDECK  ID>, HWD3ME.
*CMZ :-        -20/10/99  09:46:43  by  Peter Richardson
*-- Author :    Peter Richardson
C-----------------------------------------------------------------------
      SUBROUTINE HWD3ME(ID,ITYPE,IMODE,RHOIN,IDSPIN)
C-----------------------------------------------------------------------
C     Subroutine to perform the three body decays for spin correlations
C     and SUSY three body modes
C-----------------------------------------------------------------------
      INCLUDE 'HERWIG65.INC'
      INTEGER IMODE,I,J,ID,IDP(4+NDIAGR),ITYPE,NDIA,ID1,ID2,
     &     DRTYPE(NDIAGR),NTRY,IDSPIN,NCTHRE,DRCF(NDIAGR)
      DOUBLE PRECISION A,B,MS,MWD,MA,MB,MA2,MB2,WGT,M342,HWRUNI,
     &     HWUPCM,M232,M242,WMAX,WSUM,WSSUM,MR,PRE,TEMP,HWRGEN,WTMAX,
     &     BRW(6),BRZ(12),P(5,4),PM(5,4),WGTM,CFTHRE(NCFMAX,NCFMAX)
      DOUBLE COMPLEX S,D,RHOIN(2,2),F0(2,2,8),F3(2,2,8),F1(2,2,8),
     &     F2(2,2,8),F0M(2,2,8),F1M(2,2,8),F01(2,2,8,8)
      EXTERNAL HWRUNI,HWUPCM,HWRGEN
      COMMON/HWHEWS/S(8,8,2),D(8,8)
      COMMON/HWD3BY/F0,F0M,F1M,F1,F2,F3,F01,A(2,NDIAGR),B(2,NDIAGR),
     &     MS(NDIAGR),MWD(NDIAGR),MR(NDIAGR),MA(4),MA2(4),MB(4),MB2(4),
     &     M342,M232,M242,P,PM,CFTHRE,IDP,DRTYPE,NCTHRE,DRCF
      SAVE BRW,BRZ
      DATA BRW/0.321D0,0.321D0,0.000D0,0.108D0,0.108D0,0.108D0/
      DATA BRZ/0.154D0,0.120D0,0.154D0,0.120D0,0.152D0,0.000D0,
     &         0.033D0,0.067D0,0.033D0,0.067D0,0.033D0,0.067D0/
C--compute the masses of external particles for the decay mode
C--first for true three body decay modes
      IF(ITYPE.EQ.0) THEN
C--initalisation for the diagrams
        WTMAX  = WT3MAX(IMODE)
        PRE    = P3MODE(IMODE)
        NCTHRE = N3NCFL(IMODE)
        NDIA   = NDI3BY(IMODE)
        IDP(1) = IDK(ID3PRT(IMODE))
        DO 1 I=1,3
 1      IDP(I+1) = IDKPRD(I,ID3PRT(IMODE))
        DO 2 I=1,NCTHRE
        DO 2 J=1,NCTHRE
 2      CFTHRE(I,J) = SPN3CF(I,J,IMODE)
C--enter the couplings for the diagrams
        DO 3 I=1,NDI3BY(IMODE)
        DRTYPE(I) = I3DRTP(I,IMODE)
        DRCF  (I) = I3DRCF(I,IMODE)
        DO 3 J=1,2
        A(J,I) = A3MODE(J,I,IMODE)
 3      B(J,I) = B3MODE(J,I,IMODE)
C--enter the intermediate masses for the diagrams
        DO 4 I=1,NDI3BY(IMODE)
        IDP(I+4) = I3MODE(I,IMODE)
        MR(I)  = RMASS(I3MODE(I,IMODE))
        MS(I)  = MR(I)**2
        IF(I3MODE(I,IMODE).GT.200) THEN
          MWD(I) = RMASS(I3MODE(I,IMODE))*HBAR/RLTIM(I3MODE(I,IMODE))
        ELSEIF(I3MODE(I,IMODE).EQ.200) THEN
          MWD(I) = RMASS(200)*GAMZ
        ELSEIF(I3MODE(I,IMODE).EQ.198.OR.I3MODE(I,IMODE).EQ.199) THEN
          MWD(I) = RMASS(198)*GAMW
        ELSEIF(I3MODE(I,IMODE).EQ.59) THEN
          MWD(I) = 0.0D0
        ENDIF
 4      CONTINUE
C--reorder for top quark decay modes(b first then W products)
        IF(IDP(1).EQ.6.OR.IDP(1).EQ.12) THEN
          I = IDP(2)
          IDP(2) = IDP(4)
          IDP(4) = IDP(3)
          IDP(3) = I
        ENDIF
C--reorder if fermion not first
        IF(IDP(3).GT.IDP(4).AND.((IDP(1).EQ.6.OR.IDP(1).EQ.12).OR.
     &     IDP(2).GE.400)) THEN
          I = IDP(3)
          IDP(3) = IDP(4)
          IDP(4) = I
        ENDIF
C--then for two body modes to gauge bosons including boson decays
      ELSE
C--initalisation for the diagram
        WTMAX       = WTBMAX(ITYPE,IMODE)
        NDIA        = 1
        PRE         = PBMODE(ITYPE,IMODE)
        DRTYPE(1)   = IBDRTP(IMODE)
        DRCF  (1)   = 1
        NCTHRE      = 1
        CFTHRE(1,1) = ONE
C--particles in decay
        IDP(1) = IDK(IDBPRT(IMODE))
        IDP(2) = IDKPRD(1,IDBPRT(IMODE))
        IF(IDP(2).GE.198.AND.IDP(2).LE.200)
     &       IDP(2) = IDKPRD(2,IDBPRT(IMODE))
        IDP(5) = IBMODE(IMODE)
C--masses of virtual particles and couplings
        MR(1) = RMASS(IBMODE(IMODE))
        MS(1) = MR(1)**2
        DO J=1,2
          A(J,1) = ABMODE(J,IMODE)
          B(J,1) = BBMODE(J,ITYPE,IMODE)
        ENDDO
        IF(IBMODE(IMODE).EQ.200) THEN
          MWD(1) = RMASS(200)*GAMZ
        ELSE
          MWD(1) = RMASS(198)*GAMW
        ENDIF
C--particles from boson decay
        IF(IBMODE(IMODE).EQ.200) THEN
          ID1 = ITYPE
          IF(ITYPE.GT.6) ID1 = ID1+114
          ID2 = ID1+6
        ELSE
          ID1 = 2*ITYPE-1
          IF(ITYPE.GT.3) ID1 = ID1+114
          ID2 = ID1+7
          IF(IBMODE(IMODE).EQ.198) THEN
            I   = ID1+6
            ID1 = ID2-6
            ID2 = I
          ENDIF
        ENDIF
        IDP(3) = ID1
        IDP(4) = ID2
C--only do the decay if possible for an on-shell boson
        IF(RMASS(ID1)+RMASS(ID2).GT.MR(1)) RETURN
        IF(IPRINT.GE.2.AND..NOT.GENEV)
     &        WRITE(6,3000) RNAME(IDP(5)),RNAME(IDP(3)),RNAME(IDP(4))
        MA(3) = RMASS(IDP(3))
        MA(4) = RMASS(IDP(4))
        DO 5 I=1,4
 5      MA2(I) = MA(I)**2
      ENDIF
C--set up the masses MA OFF SHELL MB ON SHELL
      DO 6 I=1,4
        MB(I) = RMASS(IDP(I))
        MB2(I) = MB(I)**2
        IF(.NOT.GENEV) THEN
          MA (I) = MB (I)
          MA2(I) = MB2(I)
        ENDIF
 6    CONTINUE
      IF(MA(1).LT.MA(2)+MA(3)+MA(4)) RETURN
C--compute the width and maximum weight if initialising
      IF(.NOT.GENEV) THEN
C--search for maximum weight
        WMAX  = ZERO
        WSUM  = ZERO
        WSSUM = ZERO
        DO 7 I=1,NSEARCH
          CALL HWD3M0(1,NDIA,WGT,WGTM,RHOIN,IDSPIN)
          WGT = WGT*PRE
          WGTM=WGTM*PRE
          IF(WGTM.GT.WMAX) WMAX = WGTM
          WSUM = WSUM+WGT
          WSSUM = WSSUM+WGT**2
          IF(WGT.LT.ZERO) CALL HWWARN('HWD3ME',500)
 7      CONTINUE
C--compute width and maximum weight
        WSUM = WSUM/DBLE(NSEARCH)
        WSSUM = MAX(ZERO,WSSUM/DBLE(NSEARCH)-WSUM**2)
        WSSUM = SQRT(WSSUM/DBLE(NSEARCH))
C--if required output results
        IF(IPRINT.GE.2) THEN
          WRITE(6,3010) WSUM,WSSUM
          WRITE(6,3020) WMAX
          IF(ITYPE.EQ.0) THEN
            TEMP = BRFRAC(ID3PRT(IMODE))*HBAR/RLTIM(IDK(ID3PRT(IMODE)))
          ELSE
            IF(IBMODE(IMODE).EQ.200) THEN
              TEMP = BRFRAC(IDBPRT(IMODE))*HBAR/
     &              RLTIM(IDK(IDBPRT(IMODE)))*BRZ(ITYPE)
            ELSE
              TEMP = BRFRAC(IDBPRT(IMODE))*HBAR/
     &              RLTIM(IDK(IDBPRT(IMODE)))*BRW(ITYPE)
            ENDIF
          ENDIF
          WRITE(6,3030) WSUM/TEMP,WSSUM/TEMP
        ENDIF
C--set up the maximum weight
        IF(ITYPE.EQ.0) THEN
          WT3MAX(IMODE)       = 1.1D0*WMAX
        ELSE
          WTBMAX(ITYPE,IMODE) = 1.1D0*WMAX
        ENDIF
C--if not initialising generate the momenta
      ELSE
C--generate a configuation
        NTRY = 0
 100    NTRY = NTRY+1
        CALL HWD3M0(ID,NDIA,WGT,WGTM,RHOIN,IDSPIN)
        WGT = WGT*PRE
C--check maximum isn't violated, increase and issue warning if it is
        IF(WGT.GT.WTMAX) THEN
          CALL HWWARN('HWD3ME',1)
          IF(ITYPE.EQ.0) THEN
            WRITE(6,3040) RNAME(IDP(1)),RNAME(IDP(2)),RNAME(IDP(3)),
     &            RNAME(IDP(4)),WTMAX,WGT*1.1D0
          ELSE
            WRITE(6,3050) RNAME(IDP(1)),RNAME(IDP(2)),RNAME(IDP(5))
            WRITE(6,3060) RNAME(IDP(5)),RNAME(IDP(3)),RNAME(IDP(4)),
     &           WTMAX,WGT*1.1D0
          ENDIF
          WTMAX = WGT*1.1D0
          IF(ITYPE.EQ.0) THEN
            WT3MAX(IMODE) = WTMAX
          ELSE
            WTBMAX(ITYPE,IMODE) = WTMAX
          ENDIF
        ENDIF
        IF(HWRGEN(0)*WTMAX.GT.WGT.AND.NTRY.LT.NSNTRY) GOTO 100
        IF(NTRY.GE.NSNTRY) THEN
          CALL HWWARN('HWD3ME',100)
          GOTO 999
        ENDIF
      ENDIF
      RETURN
C--format statements for the outputs
 3000 FORMAT(/'  FOLLOWED BY ',A8,' --> ',A8,' ',A8)
 3010 FORMAT('            PARTIAL WIDTH  = ',G12.4,' +/- ',G12.4)
 3020 FORMAT('            MAXIMUM WEIGHT = ',E12.4)
 3030 FORMAT('     RATIO TO ISAJET VALUE = ',G12.4,' +/- ',G12.4)
 3040 FORMAT(/'WEIGHT FOR DECAY ',A8,' --> ',A8,' ',A8,' ',A8,
     &     'EXCEEDS MAX',
     &       /10X,'    MAXIMUM WEIGHT =',1PG24.16,
     &       /10X,'NEW MAXIMUM WEIGHT =',1PG24.16)
 3050 FORMAT(/'WEIGHT FOR DECAY ',A8,' --> ',A8,' ',A8)
 3060 FORMAT(/'  FOLLOWED BY ',A8,' --> ',A8,' ',A8,' EXCEEDS MAX',
     &       /10X,'    MAXIMUM WEIGHT =',1PG24.16,
     &       /10X,'NEW MAXIMUM WEIGHT =',1PG24.16)
 999  RETURN
      END
CDECK  ID>, HWD3M0.
*CMZ :-        -09/04/02  13:46:07  by  Peter Richardson
*-- Author :    Peter Richardson
C-----------------------------------------------------------------------
      SUBROUTINE HWD3M0(ID,NDIA,WGT,MWGT,RHOIN,IDSPIN)
C-----------------------------------------------------------------------
C     Subroutine to calculate the matrix element for a given mode
C-----------------------------------------------------------------------
      INCLUDE 'HERWIG65.INC'
      INTEGER I,J,P0,P1,P2,P3,P0P,IB,ID,IDP(4+NDIAGR),IDSPIN,NDIA,
     &     DRTYPE(NDIAGR),NCTHRE,DRCF(NDIAGR)
      DOUBLE PRECISION A,B,MS,MWD,MA,MB,MA2,MB2,WGT,FJAC,M342,HWRUNI,
     &     M34,PCMA,PCMB,HWUPCM,PHS,N(3),HWVDOT,PP,HWULDO,EPS,PTMP(5),
     &     M232,M242,PRE,PLAB,PRW,XMASS,PCM,P(5,4),PM(5,4),MR,PREF(5),
     &     MMIN,MMAX,MWGT,CFTHRE(NCFMAX,NCFMAX),WGTB(NCFMAX),WGTC,
     &     HWRGEN,A02,A2
      DOUBLE COMPLEX S,D,ME(2,2,2,2,NCFMAX),MED(2,2,2,2),F01(2,2,8,8),
     &     RHOIN(2,2),F0(2,2,8),F1(2,2,8),F2(2,2,8),F0M(2,2,8),
     &     RHOB(2,2),F1M(2,2,8),F3(2,2,8)
      EXTERNAL HWRUNI,HWUPCM,HWVDOT,HWULDO,HWRGEN
      COMMON/HWHEWP/XMASS(10),PLAB(5,10),PRW(5,2),PCM(5,10)
      COMMON/HWD3BY/F0,F0M,F1M,F1,F2,F3,F01,A(2,NDIAGR),B(2,NDIAGR),
     &     MS(NDIAGR),MWD(NDIAGR),MR(NDIAGR),MA(4),MA2(4),MB(4),MB2(4),
     &     M342,M232,M242,P,PM,CFTHRE,IDP,DRTYPE,NCTHRE,DRCF
      COMMON/HWHEWS/S(8,8,2),D(8,8)
      PARAMETER(EPS=1D-10)
      SAVE PREF
      DATA PREF/1.0D0,0.0D0,0.0D0,1.0D0,0.0D0/
C--select the momenta of the particles
C--first see if there is a boson mode
      IB = -1
      DO 1 I=1,NDIA
        IF(DRTYPE(I).EQ.1.OR.DRTYPE(I).EQ.5.OR.DRTYPE(I).EQ.6.OR.
     &     DRTYPE(I).EQ.7) IB = IDP(I+4)
 1    CONTINUE
C--compute the mass of the 34 subsystem flat if no boson otherwise Breit-Wigner
      MMIN = (MA(3)+MA(4))**2
      MMAX = (MA(1)-MA(2))**2
      IF(IB.GT.0.AND.IB.NE.59) THEN
        CALL HWHGB1(1,2,IB,FJAC,M342,MMAX,MMIN)
      ELSEIF(IB.EQ.59) THEN
         M342 = HWRUNI(1,LOG(MMIN),LOG(MMAX))
         M342 = EXP(M342)
         FJAC = (LOG(MMAX)-LOG(MMIN))*M342
      ELSEIF((DRTYPE(1).EQ.2.OR.DRTYPE(1).EQ.17).AND.
     &        IDP(5).EQ.206.OR.IDP(5).EQ.207) THEN
        A02   = ATAN((MMIN-MS(1))/MWD(1))
        A2    = ATAN((MMAX-MS(1))/MWD(1))-A02
        M342  = MS(1)+MWD(1)*TAN(A02+A2*HWRGEN(1))
        FJAC  = A2*((M342-MS(1))**2+MWD(1)**2)/MWD(1)
      ELSE
        FJAC = MMAX-MMIN
        M342 = HWRUNI(1,MMIN,MMAX)
      ENDIF
      M34 = SQRT(M342)
      FJAC = HALF*FJAC/M34
C--copy the momentum of the decaying particle into the internal common block
      CALL HWVEQU(5,PHEP(1,ID),P(1,1))
      DO 2 I=2,4
 2    P(5,I) = MA(I)
C--perform the decay 1---> 2+34
      PCMA = HWUPCM(MA(1),MA(2),M34)
      PLAB(5,1) = M34
      CALL HWDTWO(P(1,1),PLAB(1,1),P(1,2),PCMA,2.0D0,.TRUE.)
C--perform the decay 34 --> 3+4
      PCMB = HWUPCM(M34,MA(3),MA(4))
      CALL HWDTWO(PLAB(1,1),P(1,3),P(1,4),PCMB,2.0D0,.TRUE.)
C--compute the phase sapce factors
      PHS = PCMA*PCMB*FJAC/32.0D0/PIFAC**3/MA2(1)
C--compute the other possible masses for the propagator
      M232 = MA2(2)+MA2(3)+TWO*HWULDO(P(1,2),P(1,3))
      M242 = MA2(2)+MA2(4)+TWO*HWULDO(P(1,2),P(1,4))
C--compute the vectors for the helicity amplitudes
      DO 3 I=1,4
C--compute the references vectors
C--not important if SM particle which can't have spin measured
C--ie anything other the top and tau
C--also not important if particle is approx massless
C--first the SM particles other than top and tau
      IF(IDP(I).LT.400.AND.(IDP(I).NE.6.AND.IDP(I).NE.12
     &                .AND.IDP(I).NE.125.AND.IDP(I).NE.131)) THEN
        CALL HWVEQU(5,PREF,PLAB(1,I+4))
C--all other particles
      ELSE
        PP = SQRT(HWVDOT(3,P(1,I),P(1,I)))
        CALL HWVSCA(3,ONE/PP,P(1,I),N)
        PLAB(4,I+4) = HALF*(P(4,I)-PP)
        PP = HALF*(PP-MA(I)-PP**2/(MA(I)+P(4,I)))
        CALL HWVSCA(3,PP,N,PLAB(1,I+4))
        CALL HWUMAS(PLAB(1,I+4))
        PP = HWVDOT(3,PLAB(1,I+4),PLAB(1,I+4))
C--fix to avoid problems if approx massless due to energy
        IF(PP.LT.EPS) CALL HWVEQU(5,PREF,PLAB(1,I+4))
      ENDIF
C--now the massless vectors
      PP = HALF*MA2(I)/HWULDO(PLAB(1,I+4),P(1,I))
      DO 4 J=1,4
 4    PLAB(J,I) = P(J,I)-PP*PLAB(J,I+4)
 3    CALL HWUMAS(PLAB(1,I))
C--change order of momenta for call to HE code
      DO 5 I=1,4
      PM(1,I) = P(3,I)
      PM(2,I) = P(1,I)
      PM(3,I) = P(2,I)
      PM(4,I) = P(4,I)
 5    PM(5,I) = P(5,I)
      DO 6 I=1,8
      PCM(1,I)=PLAB(3,I)
      PCM(2,I)=PLAB(1,I)
      PCM(3,I)=PLAB(2,I)
      PCM(4,I)=PLAB(4,I)
 6    PCM(5,I)=PLAB(5,I)
C--compute the S functions
      CALL HWHEW2(8,PCM(1,1),S(1,1,2),S(1,1,1),D)
      DO 7 I=1,8
      DO 7 J=1,8
      S(I,J,2) = -S(I,J,2)
 7    D(I,J)   = TWO*D(I,J)
C--compute the F functions
      CALL HWVSUM(5,PM(1,1),PM(1,2),PTMP)
      CALL HWUMAS(PTMP)
      CALL HWH2F2(8,F0 ,5,PM(1,1), MA(1))
      CALL HWH2F1(8,F1 ,6,PM(1,2), MA(2))
      CALL HWH2F1(8,F2 ,7,PM(1,3), MA(3))
      CALL HWH2F1(8,F3 ,8,PM(1,4), MA(4))
      CALL HWH2F1(8,F0M,5,PM(1,1),-MA(1))
      CALL HWH2F2(8,F1M,6,PM(1,2),-MA(2))
      CALL HWH2F3(8,F01,PTMP,ZERO)
C--now find the prefactor for all the diagrams
      PRE = HWULDO(PCM(1,5),PM(1,1))*HWULDO(PCM(1,6),PM(1,2))*
     &      HWULDO(PCM(1,7),PM(1,3))*HWULDO(PCM(1,8),PM(1,4))
      PRE = ONE/SQRT(PRE)
C--zero the matrix element
      DO 8 P0=1,2
      DO 8 P1=1,2
      DO 8 P2=1,2
      DO 8 P3=1,2
      DO 8 I =1,NCTHRE
 8    ME(P0,P1,P2,P3,I) = (0.0D0,0.0D0)
C--now call the subroutines to compute the individual diagrams
      DO 9 I=1,NDIA
C--vector boson exchange diagram
      IF(DRTYPE(I).EQ.1) THEN
        CALL HWD3M1(I,MED)
C--Higgs boson exchange diagram
      ELSEIF(DRTYPE(I).EQ.2) THEN
        CALL HWD3M2(I,MED)
C--antisfermion exchange diagram
      ELSEIF(DRTYPE(I).EQ.3) THEN
        CALL HWD3M3(I,MED)
C--sfermion exchange diagram
      ELSEIF(DRTYPE(I).EQ.4) THEN
        CALL HWD3M4(I,MED)
C--antifermion vector boson exchange diagram
      ELSEIF(DRTYPE(I).EQ.5) THEN
        CALL HWD3M5(I,MED)
C--scalar vector boson exchange diagram
      ELSEIF(DRTYPE(I).EQ.6) THEN
        CALL HWD3M6(I,MED)
C--gravitino fermion fermion
      ELSEIF(DRTYPE(I).EQ.7) THEN
        CALL HWD3M7(I,MED)
C--fermion RPV1
      ELSEIF(DRTYPE(I).EQ.8) THEN
        CALL HWD3M8(I,MED)
C--fermion RPV2
      ELSEIF(DRTYPE(I).EQ.9) THEN
        CALL HWD3M9(I,MED)
C--fermion RPV3
      ELSEIF(DRTYPE(I).EQ.10) THEN
        CALL HWD3MA(I,MED)
C--fermion --> 3 fermions 1
      ELSEIF(DRTYPE(I).EQ.11) THEN
        CALL HWD3MB(I,MED)
C--fermion --> 3 fermions 2
      ELSEIF(DRTYPE(I).EQ.12) THEN
        CALL HWD3MC(I,MED)
C--fermion --> 3 fermions 3
      ELSEIF(DRTYPE(I).EQ.13) THEN
        CALL HWD3MD(I,MED)
C--fermion --> 3 antifermions 1
      ELSEIF(DRTYPE(I).EQ.14) THEN
        CALL HWD3MF(I,MED)
C--fermion --> 3 antifermions 2
      ELSEIF(DRTYPE(I).EQ.15) THEN
        CALL HWD3MG(I,MED)
C--fermion --> 3 antifermions 3
      ELSEIF(DRTYPE(I).EQ.16) THEN
        CALL HWD3MH(I,MED)
C--antifermion --> antifermion fermion fermion
      ELSEIF(DRTYPE(I).EQ.17) THEN
        CALL HWD3MI(I,MED)
C--error not known
      ELSE
        CALL HWWARN('HWD3M0',501)
      ENDIF
C--add up the matrix elements
      DO 10 P0=1,2
      DO 10 P1=1,2
      DO 10 P2=1,2
      DO 10 P3=1,2
 10   ME(P0,P1,P2,P3,DRCF(I)) = ME(P0,P1,P2,P3,DRCF(I))
     &                           +MED(P0,P1,P2,P3)
 9    CONTINUE
C--preform the final normalisation
      DO 15 P0=1,2
      DO 15 P1=1,2
      DO 15 P2=1,2
      DO 15 P3=1,2
      DO 15 I =1,NCTHRE
 15   ME(P0,P1,P2,P3,I) = PRE*ME(P0,P1,P2,P3,I)
C--compute the unnormalised spin density matrix
      DO 35 P0 =1,2
      DO 35 P0P=1,2
      RHOB(P0,P0P) = (0.0D0,0.0D0)
      DO 35 P1=1,2
      DO 35 P2=1,2
      DO 35 P3=1,2
      DO 35 I =1,NCTHRE
      DO 35 J =1,NCTHRE
 35   RHOB(P0,P0P)=RHOB(P0,P0P)+CFTHRE(I,J)*ME(P0,P1,P2,P3,I)*
     &             DCONJG(ME(P0P,P1,P2,P3,J))
C--compute the weight
      WGT = ZERO
      DO 45 P0=1,2
      DO 45 P0P=1,2
 45   WGT = WGT+DREAL(RHOIN(P0,P0P)*RHOB(P0,P0P))
C--normalise this for phase space
      WGT = WGT*PHS
C--if initialising select the max weight
      IF(SYSPIN.OR.THREEB)
     &        MWGT = PHS*(MAX(DBLE(RHOB(1,1)),DBLE(RHOB(2,2)))
     &               +ABS(DBLE(RHOB(1,2)))+ABS(DIMAG(RHOB(1,2))))
C--if generating the event put the information in the common block
      IF(GENEV) THEN
C--put the matrix element into the spin common block
        IF(SYSPIN) THEN
          DO 25 P0=1,2
          DO 25 P1=1,2
          DO 25 P2=1,2
          DO 25 P3=1,2
          DO 25 I =1,NCTHRE
 25       MESPN(P0,P1,P2,P3,I,IDSPIN) = ME(P0,P1,P2,P3,I)
          NCFL(IDSPIN) = NCTHRE
        ENDIF
C--if more than one colour flow pick the flow
        IF(SPCOPT.EQ.2.AND.NCTHRE.NE.1) THEN
C--contstruct the matrix elements for the colour flows
          WGTC = ZERO
          DO 50 I=1,NCTHRE
          WGTB(I) = ZERO
          DO 55 P0=1,2
          DO 55 P0P=1,2
          DO 55 P1=1,2
          DO 55 P2=1,2
          DO 55 P3=1,2
 55       WGTB(I) = WGTB(I)+CFTHRE(I,I)*DREAL(
     &    RHOIN(P0,P0P)*ME(P0 ,P1,P2,P3,I)*DCONJG(ME(P0P,P1,P2,P3,I)))
          WGTB(I) = WGTB(I)*PHS
 50       WGTC    = WGTC+WGTB(I)
          WGTC    = WGT/WGTC
          DO 60 I=1,NCTHRE
 60       WGTB(I) = WGTB(I)*WGTC
C--select the colour flow
          WGTC    = HWRGEN(1)*WGT
          DO 70 I=1,NCTHRE
          IF(WGTB(I).GE.WGTC) THEN
            NCFL(IDSPIN) = I
            RETURN
          ENDIF
 70       WGTC = WGTC-WGTB(I)
C--otherwise if wrong options set issue warning
        ELSEIF(NCTHRE.NE.1) THEN
          WRITE(6,1000)
          CALL HWWARN('HWD3M0',500)
        ENDIF
      ENDIF
 1000 FORMAT(/'MULTIPLE COLOUR FLOWS IN DECAY'/'SPCOPT=2 MUST BE USED')
      END
CDECK  ID>, HWD3M1.
*CMZ :-        -10/10/01  14:34:54  by  Peter Richardson
*-- Author :    Peter Richardson
C-----------------------------------------------------------------------
      SUBROUTINE HWD3M1(ID,ME)
C-----------------------------------------------------------------------
C  Subroutine to calculate the helicity amplitudes for the three body
C  gauge boson exchange diagram
C-----------------------------------------------------------------------
      INCLUDE 'HERWIG65.INC'
      DOUBLE COMPLEX ME(2,2,2,2),S,D,F0(2,2,8),F1(2,2,8),F01(2,2,8,8),
     &     F0M(2,2,8),F2(2,2,8),PRE,C(2,2),E(2,2),ZI,APP(2,2),APM(2,2),
     &     AMP(2,2),AMM(2,2),F1M(2,2,8),F3(2,2,8)
      DOUBLE PRECISION A,B,MS,MWD,MA,MB,MA2,MB2,M342,M232,M242,CN,
     &     MR,P(5,4),PM(5,4),CFTHRE(NCFMAX,NCFMAX)
      INTEGER P0,P1,P2,P3,ID,O(2),IDP(4+NDIAGR),DRTYPE(NDIAGR),NCTHRE,
     &     DRCF(NDIAGR)
      COMMON/HWD3BY/F0,F0M,F1M,F1,F2,F3,F01,A(2,NDIAGR),B(2,NDIAGR),
     &     MS(NDIAGR),MWD(NDIAGR),MR(NDIAGR),MA(4),MA2(4),MB(4),MB2(4),
     &     M342,M232,M242,P,PM,CFTHRE,IDP,DRTYPE,NCTHRE,DRCF
      PARAMETER(ZI=(0.0D0,1.0D0))
      COMMON/HWHEWS/S(8,8,2),D(8,8)
      SAVE O
      DATA O/2,1/
C--compute the propagator factor
      PRE = -0.25D0/(M342-MS(ID)+ZI*MWD(ID))
      CN = -ONE/MS(ID)
C--compute the C and D functions
      DO 10 P1=1,2
      DO 10 P2=1,2
        IF(P1.EQ.P2) THEN
C--the A functions
          APP(P1,P2) =  B(  P2 ,ID)*S(7,3,O(P1))*S(4,8,  P1 )
          APM(P1,P2) = 0.0D0
          AMP(P1,P2) = 0.0D0
          AMM(P1,P2) = -B(O(P2),ID)*MA(3)*MA(4)
C--the C and E functions
          C(P1,P2) = A(  P1 ,ID)*( MA2(1)*S(6,2,O(P2))*S(2,5,  P2 )
     &                            -MA2(2)*S(6,1,O(P2))*S(1,5,  P2 ))
     &          +A(O(P1),ID)*MA(1)*MA(2)*( S(6,1,O(P2))*S(1,5,  P2 )
     &                                    -S(6,2,O(P2))*S(2,5,  P2 ))
          E(P1,P2) =CN*(B(  P2 ,ID)*( MA2(3)*S(7,4,O(P1))*S(4,8,  P1 )
     &                               +MA2(4)*S(7,3,O(P1))*S(3,8,  P1 ))
     &         -B(O(P2),ID)*MA(3)*MA(4)*( S(7,3,O(P1))*S(3,8,  P1 )
     &                                   +S(7,4,O(P1))*S(4,8,  P1 )))
        ELSE
C--the A functions
          APP(P1,P2) = 0.0D0
          APM(P1,P2) = B(  P2 ,ID)*MA(3)*S(4,8,O(P1))
          AMP(P1,P2) =-B(O(P2),ID)*MA(4)*S(7,3,O(P1))
          AMM(P1,P2) = 0.0D0
C--the C and D functions
          C(P1,P2) = A(  P1 ,ID)*MA(2)*( MA2(1)*S(6,5,O(P2))
     &                   -S(6,2,O(P2))*S(2,1,  P2 )*S(1,5,O(P2)))
     &              +A(O(P1),ID)*MA(1)*(-MA2(2)*S(6,5,O(P2))
     &                   +S(6,2,O(P2))*S(2,1,  P2 )*S(1,5,O(P2)))
          E(P1,P2) =CN*( B(  P2 ,ID)*MA(3)*( MA2(4)*S(7,8,O(P1))
     &                      +S(7,3,O(P1))*S(3,4,  P1 )*S(4,8,O(P1)))
     &                  -B(O(P2),ID)*MA(4)*( MA2(3)*S(7,8,O(P1))
     &                      +S(7,3,O(P1))*S(3,4,  P1 )*S(4,8,O(P1))))
        ENDIF
 10   CONTINUE
C--compute the matrix element
      DO 20 P0=1,2
      DO 20 P1=1,2
      DO 20 P2=1,2
      DO 20 P3=1,2
        ME(P0,P1,P2,P3) =
     &     APP(P2,P3)*( A(O(P2),ID)*F1(O(P1),  P2 ,4)*F0(  P2 ,O(P0),3)
     &                 +A(  P2 ,ID)*F1(O(P1),O(P2),3)*F0(O(P2),O(P0),4))
     &    +APM(P2,P3)*( A(  P2 ,ID)*F1(O(P1),O(P2),4)*F0(O(P2),O(P0),7)
     &                 +A(O(P2),ID)*F1(O(P1),  P2 ,7)*F0(  P2 ,O(P0),4))
     &    +AMP(P2,P3)*( A(O(P2),ID)*F1(O(P1),  P2 ,8)*F0(  P2 ,O(P0),3)
     &                 +A(  P2 ,ID)*F1(O(P1),O(P2),3)*F0(O(P2),O(P0),8))
     &    +AMM(P2,P3)*( A(  P2 ,ID)*F1(O(P1),O(P2),8)*F0(O(P2),O(P0),7)
     &                 +A(O(P2),ID)*F1(O(P1),  P2 ,7)*F0(  P2 ,O(P0),8))
 20         ME(P0,P1,P2,P3) =PRE*(TWO*ME(P0,P1,P2,P3)+C(P0,P1)*E(P2,P3))
      END
CDECK  ID>, HWD3M2.
*CMZ :-        -10/10/01  14:34:54  by  Peter Richardson
*-- Author :    Peter Richardson
C-----------------------------------------------------------------------
      SUBROUTINE HWD3M2(ID,ME)
C-----------------------------------------------------------------------
C  Subroutine to calculate the helicity amplitudes for the three body
C  Higgs boson exchange diagram
C-----------------------------------------------------------------------
      INCLUDE 'HERWIG65.INC'
      DOUBLE COMPLEX ME(2,2,2,2),S,D,F0(2,2,8),F1(2,2,8),F01(2,2,8,8),
     &     F0M(2,2,8),F2(2,2,8),PRE,ZI,V1(2,2),V2(2,2),F1M(2,2,8),
     &     F3(2,2,8)
      DOUBLE PRECISION A,B,MS,MWD,MA,MB,MA2,MB2,M342,M232,M242,MR,
     &     P(5,4),PM(5,4),CFTHRE(NCFMAX,NCFMAX)
      INTEGER P0,P1,P2,P3,ID,O(2),IDP(4+NDIAGR),DRTYPE(NDIAGR),NCTHRE,
     &     DRCF(NDIAGR)
      COMMON/HWD3BY/F0,F0M,F1M,F1,F2,F3,F01,A(2,NDIAGR),B(2,NDIAGR),
     &     MS(NDIAGR),MWD(NDIAGR),MR(NDIAGR),MA(4),MA2(4),MB(4),MB2(4),
     &     M342,M232,M242,P,PM,CFTHRE,IDP,DRTYPE,NCTHRE,DRCF
      COMMON/HWHEWS/S(8,8,2),D(8,8)
      PARAMETER(ZI=(0.0D0,1.0D0))
      SAVE O
      DATA O/2,1/
C--decide whether to do the diagram
      IF(MB(2)+MR(ID).LT.MB(1).AND.MR(ID).GT.MB(3)+MB(4).AND.
     &     IDP(4+ID).NE.206) THEN
        DO 5 P0=1,2
        DO 5 P1=1,2
        DO 5 P2=1,2
        DO 5 P3=1,2
 5      ME(P0,P1,P2,P3) = (0.0D0,0.0D0)
        RETURN
      ENDIF
C--calculate the propagator factor
      PRE = 0.25D0/(M342-MS(ID)+ZI*MWD(ID))
C--calculate the vertex functions
      DO 10 P1=1,2
      DO 10 P2=1,2
         V1(P1,P2) = PRE*( A(  P1 ,ID)*F1(O(P2),  P1 ,1)*S(1,5,P1)
     &                    +A(O(P1),ID)*F1(O(P2),O(P1),5)*MA(1))
 10      V2(P1,P2) =       B(  P2 ,ID)*F2(O(P1),  P2 ,4)*S(4,8,P2)
     &                    -B(O(P2),ID)*F2(O(P1),O(P2),8)*MA(4)
C--calculate the matrix element
      DO 20 P0=1,2
      DO 20 P1=1,2
      DO 20 P2=1,2
      DO 20 P3=1,2
 20   ME(P0,P1,P2,P3) = V1(P0,P1)*V2(P2,P3)
      END
CDECK  ID>, HWD3M3.
*CMZ :-        -10/10/01  14:34:54  by  Peter Richardson
*-- Author :    Peter Richardson
C-----------------------------------------------------------------------
      SUBROUTINE HWD3M3(ID,ME)
C-----------------------------------------------------------------------
C  Subroutine to calculate the helicity amplitudes for the three body
C  antisfermion exchange diagram
C-----------------------------------------------------------------------
      INCLUDE 'HERWIG65.INC'
      DOUBLE COMPLEX ME(2,2,2,2),S,D,F0(2,2,8),F1(2,2,8),F01(2,2,8,8),
     &     F0M(2,2,8),F2(2,2,8),PRE,V1(2,2),V2(2,2),ZI,F1M(2,2,8),
     &     F3(2,2,8)
      DOUBLE PRECISION A,B,MS,MWD,MA,MB,MA2,MB2,M342,M232,M242,MR,
     &     P(5,4),PM(5,4),CFTHRE(NCFMAX,NCFMAX)
      INTEGER P0,P1,P2,P3,ID,O(2),IDP(4+NDIAGR),DRTYPE(NDIAGR),NCTHRE,
     &     DRCF(NDIAGR)
      COMMON/HWD3BY/F0,F0M,F1M,F1,F2,F3,F01,A(2,NDIAGR),B(2,NDIAGR),
     &     MS(NDIAGR),MWD(NDIAGR),MR(NDIAGR),MA(4),MA2(4),MB(4),MB2(4),
     &     M342,M232,M242,P,PM,CFTHRE,IDP,DRTYPE,NCTHRE,DRCF
      COMMON/HWHEWS/S(8,8,2),D(8,8)
      PARAMETER(ZI=(0.0D0,1.0D0))
      SAVE O
      DATA O/2,1/
C--decide whether to do the diagram
      IF(MB(3)+MR(ID).LT.MB(1).AND.MR(ID).GT.MB(2)+MB(4)) THEN
        DO 5 P0=1,2
        DO 5 P1=1,2
        DO 5 P2=1,2
        DO 5 P3=1,2
 5      ME(P0,P1,P2,P3) = (0.0D0,0.0D0)
        RETURN
      ENDIF
C--compute the propagator factor
      PRE = -0.25D0/(M242-MS(ID)+ZI*MWD(ID))
C--compute the vertex factors
      DO 10 P1=1,2
      DO 10 P2=1,2
         V1(P1,P2) = PRE*( A(  P1 ,ID)*F2(O(P2),  P1 ,1)*S(1,5,P1)
     &                    +A(O(P1),ID)*F2(O(P2),O(P1),5)*MA(1))
 10      V2(P1,P2) = B(  P2 ,ID)*F1(O(P1),  P2 ,4)*S(4,8,P2)
     &              -B(O(P2),ID)*F1(O(P1),O(P2),8)*MA(4)
C--compute the matrix element
      DO 20 P0=1,2
      DO 20 P1=1,2
      DO 20 P2=1,2
      DO 20 P3=1,2
 20   ME(P0,P1,P2,P3) = V1(P0,P2)*V2(P1,P3)
      END
CDECK  ID>, HWD3M4.
*CMZ :-        -10/10/01  14:34:54  by  Peter Richardson
*-- Author :    Peter Richardson
C-----------------------------------------------------------------------
      SUBROUTINE HWD3M4(ID,ME)
C-----------------------------------------------------------------------
C  Subroutine to calculate the helicity amplitudes for the three body
C  sfermion exchange diagram
C-----------------------------------------------------------------------
      INCLUDE 'HERWIG65.INC'
      DOUBLE COMPLEX ME(2,2,2,2),S,D,F0(2,2,8),F1(2,2,8),F01(2,2,8,8),
     &     F0M(2,2,8),F2(2,2,8),PRE,ZI,V1(2,2),V2(2,2),F1M(2,2,8),
     &     F3(2,2,8)
      DOUBLE PRECISION A,B,MS,MWD,MA,MB,MA2,MB2,M342,M232,M242,MR,
     &P(5,4),PM(5,4),CFTHRE(NCFMAX,NCFMAX)
      INTEGER P0,P1,P2,P3,ID,O(2),IDP(4+NDIAGR),DRTYPE(NDIAGR),NCTHRE,
     &     DRCF(NDIAGR)
      COMMON/HWHEWS/S(8,8,2),D(8,8)
      COMMON/HWD3BY/F0,F0M,F1M,F1,F2,F3,F01,A(2,NDIAGR),B(2,NDIAGR),
     &     MS(NDIAGR),MWD(NDIAGR),MR(NDIAGR),MA(4),MA2(4),MB(4),MB2(4),
     &     M342,M232,M242,P,PM,CFTHRE,IDP,DRTYPE,NCTHRE,DRCF
      PARAMETER(ZI=(0.0D0,1.0D0))
      SAVE O
      DATA O/2,1/
C--decide whether to do the diagram
      IF(MB(4)+MR(ID).LT.MB(1).AND.MR(ID).GT.MB(2)+MB(3)) THEN
        DO 5 P0=1,2
        DO 5 P1=1,2
        DO 5 P2=1,2
        DO 5 P3=1,2
 5      ME(P0,P1,P2,P3) = (0.0D0,0.0D0)
        RETURN
      ENDIF
C--compute the propagator factor
      PRE = 0.25D0/(M232-MS(ID)+ZI*MWD(ID))
C--compute the factors for the two vertices
      DO 10 P1=1,2
      DO 10 P2=1,2
         V1(P1,P2) = PRE*( A(  P2 ,ID)*F0M(  P1 ,  P2 ,4)*S(4,8,  P2 )
     &                    -A(O(P2),ID)*F0M(  P1 ,O(P2),8)*MA(4))
 10      V2(P1,P2) = B(O(P1),ID)*F2 (O(P2),O(P1),2)*S(2,6,O(P1))
     &              -B(  P1 ,ID)*F2 (O(P2),  P1 ,6)*MA(2)
C--now compute the matrix element
      DO 20 P0=1,2
      DO 20 P1=1,2
      DO 20 P2=1,2
      DO 20 P3=1,2
 20   ME(P0,P1,P2,P3) = V1(P0,P3)*V2(P1,P2)
      END
CDECK  ID>, HWD3M5.
*CMZ :-        -10/10/01  14:34:54  by  Peter Richardson
*-- Author :    Peter Richardson
C-----------------------------------------------------------------------
      SUBROUTINE HWD3M5(ID,ME)
C-----------------------------------------------------------------------
C  Subroutine to calculate the helicity amplitudes for the three body
C  gauge boson exchange diagram (antiparticle decay)
C-----------------------------------------------------------------------
      INCLUDE 'HERWIG65.INC'
      DOUBLE COMPLEX ME(2,2,2,2),S,D,F0(2,2,8),F1(2,2,8),
     &     F0M(2,2,8),F2(2,2,8),PRE,C(2,2),E(2,2),ZI,APP(2,2),APM(2,2),
     &     AMP(2,2),AMM(2,2),F1M(2,2,8),F3(2,2,8),F01(2,2,8,8)
      DOUBLE PRECISION A,B,MS,MWD,MA,MB,MA2,MB2,M342,M232,M242,CN,MR,
     &     P(5,4),PM(5,4),CFTHRE(NCFMAX,NCFMAX)
      INTEGER P0,P1,P2,P3,ID,O(2),IDP(4+NDIAGR),DRTYPE(NDIAGR),NCTHRE,
     &     DRCF(NDIAGR)
      COMMON/HWD3BY/F0,F0M,F1M,F1,F2,F3,F01,A(2,NDIAGR),B(2,NDIAGR),
     &     MS(NDIAGR),MWD(NDIAGR),MR(NDIAGR),MA(4),MA2(4),MB(4),MB2(4),
     &     M342,M232,M242,P,PM,CFTHRE,IDP,DRTYPE,NCTHRE,DRCF
      PARAMETER(ZI=(0.0D0,1.0D0))
      COMMON/HWHEWS/S(8,8,2),D(8,8)
      SAVE O
      DATA O/2,1/
C--compute the propagator factor
      PRE = -0.25D0/(M342-MS(ID)+ZI*MWD(ID))
      CN = -ONE/MS(ID)
C--compute the C and D functions
      DO 10 P1=1,2
      DO 10 P2=1,2
        IF(P1.EQ.P2) THEN
C--the A functions
          APP(P1,P2) =  B(  P2 ,ID)*S(7,3,O(P1))*S(4,8,  P1 )
          APM(P1,P2) = 0.0D0
          AMP(P1,P2) = 0.0D0
          AMM(P1,P2) = -B(O(P2),ID)*MA(3)*MA(4)
C--the C and E functions
          C(P1,P2) = A(  P2 ,ID)*( MA2(1)*S(5,2,O(P1))*S(2,6,  P1 )
     &                            -MA2(2)*S(5,1,O(P1))*S(1,6,  P1 ))
     &          +A(O(P2),ID)*MA(1)*MA(2)*( S(5,1,O(P1))*S(1,6,  P1 )
     &                                    -S(5,2,O(P1))*S(2,6,  P1 ))
          E(P1,P2) =CN*(B(  P2 ,ID)*( MA2(3)*S(7,4,O(P1))*S(4,8,  P1 )
     &                               +MA2(4)*S(7,3,O(P1))*S(3,8,  P1 ))
     &         -B(O(P2),ID)*MA(3)*MA(4)*( S(7,3,O(P1))*S(3,8,  P1 )
     &                                   +S(7,4,O(P1))*S(4,8,  P1 )))
        ELSE
C--the A functions
          APP(P1,P2) = 0.0D0
          APM(P1,P2) = B(  P2 ,ID)*MA(3)*S(4,8,O(P1))
          AMP(P1,P2) =-B(O(P2),ID)*MA(4)*S(7,3,O(P1))
          AMM(P1,P2) = 0.0D0
C--the C and D functions
          C(P1,P2) = A(  P2 ,ID)*MA(1)*( MA2(2)*S(5,6,O(P1))
     &                   -S(5,1,O(P1))*S(1,2,  P1 )*S(2,6,O(P1)))
     &              +A(O(P2),ID)*MA(2)*(-MA2(1)*S(5,6,O(P1))
     &                   +S(5,1,O(P1))*S(1,2,  P1 )*S(2,6,O(P1)))
          E(P1,P2) =CN*( B(  P2 ,ID)*MA(3)*( MA2(4)*S(7,8,O(P1))
     &                      +S(7,3,O(P1))*S(3,4,  P1 )*S(4,8,O(P1)))
     &                  -B(O(P2),ID)*MA(4)*( MA2(3)*S(7,8,O(P1))
     &                      +S(7,3,O(P1))*S(3,4,  P1 )*S(4,8,O(P1))))
        ENDIF
 10   CONTINUE
C--compute the matrix element
      DO 20 P0=1,2
      DO 20 P1=1,2
      DO 20 P2=1,2
      DO 20 P3=1,2
      ME(P0,P1,P2,P3) =
     &   APP(P2,P3)*( A(O(P2),ID)*F0M(O(P0),  P2 ,4)*F1M(  P2 ,O(P1),3)
     &               +A(  P2 ,ID)*F0M(O(P0),O(P2),3)*F1M(O(P2),O(P1),4))
     &  +APM(P2,P3)*( A(  P2 ,ID)*F0M(O(P0),O(P2),4)*F1M(O(P2),O(P1),7)
     &               +A(O(P2),ID)*F0M(O(P0),  P2 ,7)*F1M(  P2 ,O(P1),4))
     &  +AMP(P2,P3)*( A(O(P2),ID)*F0M(O(P0),  P2 ,8)*F1M(  P2 ,O(P1),3)
     &               +A(  P2 ,ID)*F0M(O(P0),O(P2),3)*F1M(O(P2),O(P1),8))
     &  +AMM(P2,P3)*( A(  P2 ,ID)*F0M(O(P0),O(P2),8)*F1M(O(P2),O(P1),7)
     &               +A(O(P2),ID)*F0M(O(P0),  P2 ,7)*F1M(  P2 ,O(P1),8))
 20   ME(P0,P1,P2,P3) =PRE*(TWO*ME(P0,P1,P2,P3)+C(P0,P1)*E(P2,P3))
      END
CDECK  ID>, HWD3M6.
*CMZ :-        -10/10/01  14:34:54  by  Peter Richardson
*-- Author :    Peter Richardson
C-----------------------------------------------------------------------
      SUBROUTINE HWD3M6(ID,ME)
C-----------------------------------------------------------------------
C  Subroutine to calculate the helicity amplitudes for the three body
C  gauge boson exchange diagram
C-----------------------------------------------------------------------
      INCLUDE 'HERWIG65.INC'
      DOUBLE COMPLEX ME(2,2,2,2),S,D,F0(2,2,8),F1(2,2,8),
     &     F0M(2,2,8),F2(2,2,8),PRE,C(2,2),ZI,APP(2,2),APM(2,2),
     &     AMP(2,2),AMM(2,2),F1M(2,2,8),F3(2,2,8),F01(2,2,8,8)
      DOUBLE PRECISION A,B,MS,MWD,MA,MB,MA2,MB2,M342,M232,M242,CN,MR,
     &     P(5,4),DOT,HWULDO,PM(5,4),CFTHRE(NCFMAX,NCFMAX)
      INTEGER P0,P1,P2,P3,ID,O(2),IDP(4+NDIAGR),DRTYPE(NDIAGR),NCTHRE,
     &     DRCF(NDIAGR)
      COMMON/HWD3BY/F0,F0M,F1M,F1,F2,F3,F01,A(2,NDIAGR),B(2,NDIAGR),
     &     MS(NDIAGR),MWD(NDIAGR),MR(NDIAGR),MA(4),MA2(4),MB(4),MB2(4),
     &     M342,M232,M242,P,PM,CFTHRE,IDP,DRTYPE,NCTHRE,DRCF
      DOUBLE PRECISION XMASS,PLAB,PRW,PCM
      COMMON/HWHEWP/XMASS(10),PLAB(5,10),PRW(5,2),PCM(5,10)
      PARAMETER(ZI=(0.0D0,1.0D0))
      COMMON/HWHEWS/S(8,8,2),D(8,8)
      EXTERNAL HWULDO
      SAVE O
      DATA O/2,1/
C--compute the propagator factor
      PRE = SQRT(HWULDO(PCM(1,5),PM(1,1))*HWULDO(PCM(1,6),PM(1,2)))
      PRE = -HALF*PRE*A(1,ID)/(M342-MS(ID)+ZI*MWD(ID))
      CN = -ONE/MS(ID)
      DOT = HWULDO(P(1,1),P(1,3))+HWULDO(P(1,1),P(1,4))
     &     +HWULDO(P(1,2),P(1,3))+HWULDO(P(1,2),P(1,4))
C--compute the C and D functions
      DO 10 P1=1,2
      DO 10 P2=1,2
        IF(P1.EQ.P2) THEN
C--the A functions
          APP(P1,P2) =  B(  P2 ,ID)*S(7,3,O(P1))*S(4,8,  P1 )
          APM(P1,P2) = 0.0D0
          AMP(P1,P2) = 0.0D0
          AMM(P1,P2) = -B(O(P2),ID)*MA(3)*MA(4)
C--the C function
          C(P1,P2) =CN*(B(  P2 ,ID)*( MA2(3)*S(7,4,O(P1))*S(4,8,  P1 )
     &                               +MA2(4)*S(7,3,O(P1))*S(3,8,  P1 ))
     &         -B(O(P2),ID)*MA(3)*MA(4)*( S(7,3,O(P1))*S(3,8,  P1 )
     &                                   +S(7,4,O(P1))*S(4,8,  P1 )))
        ELSE
C--the A functions
          APP(P1,P2) = 0.0D0
          APM(P1,P2) = B(  P2 ,ID)*MA(3)*S(4,8,O(P1))
          AMP(P1,P2) =-B(O(P2),ID)*MA(4)*S(7,3,O(P1))
          AMM(P1,P2) = 0.0D0
C--the C functions
          C(P1,P2) =CN*( B(  P2 ,ID)*MA(3)*( MA2(4)*S(7,8,O(P1))
     &                      +S(7,3,O(P1))*S(3,4,  P1 )*S(4,8,O(P1)))
     &                  -B(O(P2),ID)*MA(4)*( MA2(3)*S(7,8,O(P1))
     &                      +S(7,3,O(P1))*S(3,4,  P1 )*S(4,8,O(P1))))
        ENDIF
 10   CONTINUE
C--compute the matrix element
      DO 15 P0=1,2
      DO 15 P1=1,2
      DO 15 P2=1,2
      DO 15 P3=1,2
 15   ME(P0,P1,P2,P3) = (0.0D0,0.0D0)
      DO 20 P2=1,2
      DO 20 P3=1,2
 20   ME(1,1,P2,P3) = PRE*(DOT*C(P2,P3)
     & +APP(P2,P3)*F01(  P2 ,  P2 ,3,4)+APM(P2,P3)*F01(O(P2),O(P2),7,4)
     & +AMP(P2,P3)*F01(  P2 ,  P2 ,3,8)+AMM(P2,P3)*F01(O(P2),O(P2),7,8))
      END
CDECK  ID>, HWD3M7.
*CMZ :-        -13/03/02  14:19:47  by  Peter Richardson
*-- Author :    Peter Richardson
C-----------------------------------------------------------------------
      SUBROUTINE HWD3M7(ID,ME)
C-----------------------------------------------------------------------
C  Subroutine to calculate the helicity amplitudes for the three body
C  decay fermion --> gravitino fermion antifermion (via gauge boson)
C-----------------------------------------------------------------------
      INCLUDE 'HERWIG65.INC'
      DOUBLE COMPLEX ME(2,2,2,2),S,D,F0(2,2,8),F1(2,2,8),F01(2,2,8,8),
     &     F0M(2,2,8),F2(2,2,8),PRE,ZI,F1M(2,2,8),F3(2,2,8)
      DOUBLE PRECISION A,B,MS,MWD,MA,MB,MA2,MB2,M342,M232,M242,MR,
     &P(5,4),PM(5,4),CFTHRE(NCFMAX,NCFMAX),HWULDO,DL(2,2)
      INTEGER P0,P1,ID,O(2),IDP(4+NDIAGR),DRTYPE(NDIAGR),NCTHRE,
     &     DRCF(NDIAGR)
      COMMON/HWHEWS/S(8,8,2),D(8,8)
      COMMON/HWD3BY/F0,F0M,F1M,F1,F2,F3,F01,A(2,NDIAGR),B(2,NDIAGR),
     &     MS(NDIAGR),MWD(NDIAGR),MR(NDIAGR),MA(4),MA2(4),MB(4),MB2(4),
     &     M342,M232,M242,P,PM,CFTHRE,IDP,DRTYPE,NCTHRE,DRCF
      PARAMETER(ZI=(0.0D0,1.0D0))
      DOUBLE PRECISION XMASS,PLAB,PRW,PCM
      COMMON/HWHEWP/XMASS(10),PLAB(5,10),PRW(5,2),PCM(5,10)
      EXTERNAL HWULDO
      SAVE O,DL
      DATA O/2,1/
      DATA DL/1.0D0,0.0D0,0.0D0,1.0D0/
C--compute the propagator factor
      PRE = HALF*HWULDO(PCM(1,6),PM(1,2))*
     &      HWULDO(PCM(1,7),PM(1,3))*HWULDO(PCM(1,8),PM(1,4))
      PRE = SQRT(PRE)
      PRE = PRE/(M342-MS(ID)+ZI*MWD(ID))
      DO 10 P0=1,2
      DO 10 P1=1,2
      ME(P0,P1,  P1 ,  P1 ) = PRE*B(  P1 ,ID)*(
     &   A(1,ID)*S(2,3,P1)*S(3,4,O(P1))*S(3,2,  P1 )*F0(O(P1),O(P0),2)
     &  +A(2,ID)* DL(P1,1)*S(2,3,  P1 )*S(4,2,O(P1))*F0(  1  ,O(P0),2))
      ME(P0,P1,O(P1),O(P1)) = PRE*B(O(P1),ID)*(
     &   A(1,ID)*S(2,4,P1)*S(4,3,O(P1))*S(4,2,  P1 )*F0(O(P1),O(P0),2)
     &  +A(2,ID)* DL(P1,1)*S(2,4,  P1 )*S(3,2,O(P1))*F0(  1  ,O(P0),2))
      ME(P0,P1,O(P1),  P1 ) = (0.0D0,0.0D0)
 10   ME(P0,P1,  P1 ,O(P1)) = (0.0D0,0.0D0)
      END
CDECK  ID>, HWD3M8.
*CMZ :-        -08/04/02  14:48:42  by  Peter Richardson
*-- Author :    Peter Richardson
C-----------------------------------------------------------------------
      SUBROUTINE HWD3M8(ID,ME)
C-----------------------------------------------------------------------
C  Subroutine to calculate the helicity amplitudes for 1st 3 body RPV
C  diagram f--> fbar fbar f
C-----------------------------------------------------------------------
      INCLUDE 'HERWIG65.INC'
      DOUBLE COMPLEX ME(2,2,2,2),S,D,F0(2,2,8),F1(2,2,8),F01(2,2,8,8),
     &     F0M(2,2,8),F2(2,2,8),PRE,ZI,V1(2,2),V2(2,2),F1M(2,2,8),
     &     F3(2,2,8)
      DOUBLE PRECISION A,B,MS,MWD,MA,MB,MA2,MB2,M342,M232,M242,MR,
     &     P(5,4),PM(5,4),CFTHRE(NCFMAX,NCFMAX)
      INTEGER P0,P1,P2,P3,ID,O(2),IDP(4+NDIAGR),DRTYPE(NDIAGR),NCTHRE,
     &     DRCF(NDIAGR)
      COMMON/HWD3BY/F0,F0M,F1M,F1,F2,F3,F01,A(2,NDIAGR),B(2,NDIAGR),
     &     MS(NDIAGR),MWD(NDIAGR),MR(NDIAGR),MA(4),MA2(4),MB(4),MB2(4),
     &     M342,M232,M242,P,PM,CFTHRE,IDP,DRTYPE,NCTHRE,DRCF
      COMMON/HWHEWS/S(8,8,2),D(8,8)
      PARAMETER(ZI=(0.0D0,1.0D0))
      SAVE O
      DATA O/2,1/
C--decide whether to do the diagram
      IF(MB(2)+MR(ID).LT.MB(1).AND.MR(ID).GT.MB(3)+MB(4)) THEN
        DO 5 P0=1,2
        DO 5 P1=1,2
        DO 5 P2=1,2
        DO 5 P3=1,2
 5      ME(P0,P1,P2,P3) = (0.0D0,0.0D0)
        RETURN
      ENDIF
C--calculate the propagator factor
      PRE = 0.25D0/(M342-MS(ID)+ZI*MWD(ID))
C--calculate the vertex functions
      DO 10 P1=1,2
      DO 10 P2=1,2
      V1(P1,P2) = PRE*( A(  P2 ,ID)*F0M(  P1 ,  P2 ,2)*S(2,6,  P2)
     &                 -A(O(P2),ID)*F0M(  P1 ,O(P2),6)*MA(2))
 10   V2(P1,P2) =       B(  P1 ,ID)*F3 (O(P2),  P1 ,3)*S(3,7,P1)
     &                 -B(O(P1),ID)*F3 (O(P2),O(P1),7)*MA(3)
C--calculate the matrix element
      DO 20 P0=1,2
      DO 20 P1=1,2
      DO 20 P2=1,2
      DO 20 P3=1,2
 20   ME(P0,P1,P2,P3) = V1(P0,P1)*V2(P2,P3)
      END
CDECK  ID>, HWD3M9.
*CMZ :-        -08/04/02  14:48:42  by  Peter Richardson
*-- Author :    Peter Richardson
C-----------------------------------------------------------------------
      SUBROUTINE HWD3M9(ID,ME)
C-----------------------------------------------------------------------
C  Subroutine to calculate the helicity amplitudes for 2nd 3 body RPV
C  diagram f --> fbar fbar f
C-----------------------------------------------------------------------
      INCLUDE 'HERWIG65.INC'
      DOUBLE COMPLEX ME(2,2,2,2),S,D,F0(2,2,8),F1(2,2,8),F01(2,2,8,8),
     &     F0M(2,2,8),F2(2,2,8),PRE,V1(2,2),V2(2,2),ZI,F1M(2,2,8),
     &     F3(2,2,8)
      DOUBLE PRECISION A,B,MS,MWD,MA,MB,MA2,MB2,M342,M232,M242,MR,
     &     P(5,4),PM(5,4),CFTHRE(NCFMAX,NCFMAX)
      INTEGER P0,P1,P2,P3,ID,O(2),IDP(4+NDIAGR),DRTYPE(NDIAGR),NCTHRE,
     &     DRCF(NDIAGR)
      COMMON/HWD3BY/F0,F0M,F1M,F1,F2,F3,F01,A(2,NDIAGR),B(2,NDIAGR),
     &     MS(NDIAGR),MWD(NDIAGR),MR(NDIAGR),MA(4),MA2(4),MB(4),MB2(4),
     &     M342,M232,M242,P,PM,CFTHRE,IDP,DRTYPE,NCTHRE,DRCF
      COMMON/HWHEWS/S(8,8,2),D(8,8)
      PARAMETER(ZI=(0.0D0,1.0D0))
      SAVE O
      DATA O/2,1/
C--decide whether to do the diagram
      IF(MB(3)+MR(ID).LT.MB(1).AND.MR(ID).GT.MB(2)+MB(4)) THEN
        DO 5 P0=1,2
        DO 5 P1=1,2
        DO 5 P2=1,2
        DO 5 P3=1,2
 5      ME(P0,P1,P2,P3) = (0.0D0,0.0D0)
        RETURN
      ENDIF
C--compute the propagator factor
      PRE = -0.25D0/(M242-MS(ID)+ZI*MWD(ID))
C--compute the vertex factors
      DO 10 P1=1,2
      DO 10 P2=1,2
      V1(P1,P2) = PRE*( A(  P2 ,ID)*F0M(  P1 ,  P2 ,3)*S(3,7,P2)
     &                 -A(O(P2),ID)*F0M(  P1 ,O(P2),7)*MA(3))
 10   V2(P1,P2) =       B(  P1 ,ID)*F3 (O(P2),  P1 ,2)*S(2,6,P1)
     &                 -B(O(P1),ID)*F3 (O(P2),O(P1),6)*MA(2)
C--compute the matrix element
      DO 20 P0=1,2
      DO 20 P1=1,2
      DO 20 P2=1,2
      DO 20 P3=1,2
 20   ME(P0,P1,P2,P3) = V1(P0,P2)*V2(P1,P3)
      END
CDECK  ID>, HWD3MA.
*CMZ :-        -08/04/02  14:48:42  by  Peter Richardson
*-- Author :    Peter Richardson
C-----------------------------------------------------------------------
      SUBROUTINE HWD3MA(ID,ME)
C-----------------------------------------------------------------------
C  Subroutine to calculate the helicity amplitudes for 3rd 3 body RPV
C  diagram f --> fbar fbar f
C-----------------------------------------------------------------------
      INCLUDE 'HERWIG65.INC'
      DOUBLE COMPLEX ME(2,2,2,2),S,D,F0(2,2,8),F1(2,2,8),F01(2,2,8,8),
     &     F0M(2,2,8),F2(2,2,8),PRE,ZI,V1(2,2),V2(2,2),F1M(2,2,8),
     &     F3(2,2,8)
      DOUBLE PRECISION A,B,MS,MWD,MA,MB,MA2,MB2,M342,M232,M242,MR,
     &P(5,4),PM(5,4),CFTHRE(NCFMAX,NCFMAX)
      INTEGER P0,P1,P2,P3,ID,O(2),IDP(4+NDIAGR),DRTYPE(NDIAGR),NCTHRE,
     &     DRCF(NDIAGR)
      COMMON/HWHEWS/S(8,8,2),D(8,8)
      COMMON/HWD3BY/F0,F0M,F1M,F1,F2,F3,F01,A(2,NDIAGR),B(2,NDIAGR),
     &     MS(NDIAGR),MWD(NDIAGR),MR(NDIAGR),MA(4),MA2(4),MB(4),MB2(4),
     &     M342,M232,M242,P,PM,CFTHRE,IDP,DRTYPE,NCTHRE,DRCF
      PARAMETER(ZI=(0.0D0,1.0D0))
      SAVE O
      DATA O/2,1/
C--decide whether to do the diagram
      IF(MB(4)+MR(ID).LT.MB(1).AND.MR(ID).GT.MB(2)+MB(3)) THEN
        DO 5 P0=1,2
        DO 5 P1=1,2
        DO 5 P2=1,2
        DO 5 P3=1,2
 5      ME(P0,P1,P2,P3) = (0.0D0,0.0D0)
        RETURN
      ENDIF
C--compute the propagator factor
      PRE = 0.25D0/(M232-MS(ID)+ZI*MWD(ID))
C--compute the factors for the two vertices
      DO 10 P1=1,2
      DO 10 P2=1,2
      V1(P1,P2) = PRE*( A(  P1 ,ID)*F3(O(P2),  P1 ,1)*S(1,5,P1)
     &                 +A(O(P1),ID)*F3(O(P2),O(P1),5)*MA(1))
 10   V2(P1,P2) =       B(  P2 ,ID)*F1(  P1 ,  P2 ,3)*S(3,7,P2)
     &                 -B(O(P2),ID)*F1(  P1 ,O(P2),7)*MA(3)
C--now compute the matrix element
      DO 20 P0=1,2
      DO 20 P1=1,2
      DO 20 P2=1,2
      DO 20 P3=1,2
 20   ME(P0,P1,P2,P3) = V1(P0,P3)*V2(P1,P2)
      END
CDECK  ID>, HWD3MB.
*CMZ :-        -08/04/02  14:48:42  by  Peter Richardson
*-- Author :    Peter Richardson
C-----------------------------------------------------------------------
      SUBROUTINE HWD3MB(ID,ME)
C-----------------------------------------------------------------------
C  Subroutine to calculate the helicity amplitudes for 4th 3 body RPV
C  diagram f --> f f f
C-----------------------------------------------------------------------
      INCLUDE 'HERWIG65.INC'
      DOUBLE COMPLEX ME(2,2,2,2),S,D,F0(2,2,8),F1(2,2,8),F01(2,2,8,8),
     &     F0M(2,2,8),F2(2,2,8),PRE,ZI,V1(2,2),V2(2,2),F1M(2,2,8),
     &     F3(2,2,8)
      DOUBLE PRECISION A,B,MS,MWD,MA,MB,MA2,MB2,M342,M232,M242,MR,
     &     P(5,4),PM(5,4),CFTHRE(NCFMAX,NCFMAX)
      INTEGER P0,P1,P2,P3,ID,O(2),IDP(4+NDIAGR),DRTYPE(NDIAGR),NCTHRE,
     &     DRCF(NDIAGR)
      COMMON/HWD3BY/F0,F0M,F1M,F1,F2,F3,F01,A(2,NDIAGR),B(2,NDIAGR),
     &     MS(NDIAGR),MWD(NDIAGR),MR(NDIAGR),MA(4),MA2(4),MB(4),MB2(4),
     &     M342,M232,M242,P,PM,CFTHRE,IDP,DRTYPE,NCTHRE,DRCF
      COMMON/HWHEWS/S(8,8,2),D(8,8)
      PARAMETER(ZI=(0.0D0,1.0D0))
      SAVE O
      DATA O/2,1/
C--decide whether to do the diagram
      IF(MB(2)+MR(ID).LT.MB(1).AND.MR(ID).GT.MB(3)+MB(4)) THEN
        DO 5 P0=1,2
        DO 5 P1=1,2
        DO 5 P2=1,2
        DO 5 P3=1,2
 5      ME(P0,P1,P2,P3) = (0.0D0,0.0D0)
        RETURN
      ENDIF
C--calculate the propagator factor
      PRE = 0.25D0/(M342-MS(ID)+ZI*MWD(ID))
C--calculate the vertex functions
      DO 10 P1=1,2
      DO 10 P2=1,2
         V1(P1,P2) = PRE*( A(  P1 ,ID)*F1(O(P2),  P1 ,1)*S(1,5,P1)
     &                    +A(O(P1),ID)*F1(O(P2),O(P1),5)*MA(1))
 10      V2(P1,P2) =       B(O(P2),ID)*F2(O(P1),O(P2),4)*S(4,8,O(P2))
     &                    -B(  P2 ,ID)*F2(O(P1),  P2 ,8)*MA(4)
C--calculate the matrix element
      DO 20 P0=1,2
      DO 20 P1=1,2
      DO 20 P2=1,2
      DO 20 P3=1,2
 20   ME(P0,P1,P2,P3) = V1(P0,P1)*V2(P2,P3)
      END
CDECK  ID>, HWD3MC.
*CMZ :-        -08/04/02  14:48:42  by  Peter Richardson
*-- Author :    Peter Richardson
C-----------------------------------------------------------------------
      SUBROUTINE HWD3MC(ID,ME)
C-----------------------------------------------------------------------
C  Subroutine to calculate the helicity amplitudes for 5th 3 body RPV
C  diagram f --> f f f
C-----------------------------------------------------------------------
      INCLUDE 'HERWIG65.INC'
      DOUBLE COMPLEX ME(2,2,2,2),S,D,F0(2,2,8),F1(2,2,8),F01(2,2,8,8),
     &     F0M(2,2,8),F2(2,2,8),PRE,V1(2,2),V2(2,2),ZI,F1M(2,2,8),
     &     F3(2,2,8)
      DOUBLE PRECISION A,B,MS,MWD,MA,MB,MA2,MB2,M342,M232,M242,MR,
     &     P(5,4),PM(5,4),CFTHRE(NCFMAX,NCFMAX)
      INTEGER P0,P1,P2,P3,ID,O(2),IDP(4+NDIAGR),DRTYPE(NDIAGR),NCTHRE,
     &     DRCF(NDIAGR)
      COMMON/HWD3BY/F0,F0M,F1M,F1,F2,F3,F01,A(2,NDIAGR),B(2,NDIAGR),
     &     MS(NDIAGR),MWD(NDIAGR),MR(NDIAGR),MA(4),MA2(4),MB(4),MB2(4),
     &     M342,M232,M242,P,PM,CFTHRE,IDP,DRTYPE,NCTHRE,DRCF
      COMMON/HWHEWS/S(8,8,2),D(8,8)
      PARAMETER(ZI=(0.0D0,1.0D0))
      SAVE O
      DATA O/2,1/
C--decide whether to do the diagram
      IF(MB(3)+MR(ID).LT.MB(1).AND.MR(ID).GT.MB(2)+MB(4)) THEN
        DO 5 P0=1,2
        DO 5 P1=1,2
        DO 5 P2=1,2
        DO 5 P3=1,2
 5      ME(P0,P1,P2,P3) = (0.0D0,0.0D0)
        RETURN
      ENDIF
C--compute the propagator factor
      PRE =-0.25D0/(M242-MS(ID)+ZI*MWD(ID))
C--compute the vertex factors
      DO 10 P1=1,2
      DO 10 P2=1,2
         V1(P1,P2) = PRE*( A(  P1 ,ID)*F2(O(P2),  P1 ,1)*S(1,5,P1)
     &                    +A(O(P1),ID)*F2(O(P2),O(P1),5)*MA(1))
 10      V2(P1,P2) = B(O(P2),ID)*F1(O(P1),O(P2),4)*S(4,8,O(P2))
     &              -B(  P2 ,ID)*F1(O(P1),  P2 ,8)*MA(4)
C--compute the matrix element
      DO 20 P0=1,2
      DO 20 P1=1,2
      DO 20 P2=1,2
      DO 20 P3=1,2
 20   ME(P0,P1,P2,P3) = V1(P0,P2)*V2(P1,P3)
      END
CDECK  ID>, HWD3MD.
*CMZ :-        -08/04/02  14:48:42  by  Peter Richardson
*-- Author :    Peter Richardson
C-----------------------------------------------------------------------
      SUBROUTINE HWD3MD(ID,ME)
C-----------------------------------------------------------------------
C  Subroutine to calculate the helicity amplitudes for 6th 3 body RPV
C  diagram f --> f f f
C-----------------------------------------------------------------------
      INCLUDE 'HERWIG65.INC'
      DOUBLE COMPLEX ME(2,2,2,2),S,D,F0(2,2,8),F1(2,2,8),F01(2,2,8,8),
     &     F0M(2,2,8),F2(2,2,8),PRE,ZI,V1(2,2),V2(2,2),F1M(2,2,8),
     &     F3(2,2,8)
      DOUBLE PRECISION A,B,MS,MWD,MA,MB,MA2,MB2,M342,M232,M242,MR,
     &P(5,4),PM(5,4),CFTHRE(NCFMAX,NCFMAX)
      INTEGER P0,P1,P2,P3,ID,O(2),IDP(4+NDIAGR),DRTYPE(NDIAGR),NCTHRE,
     &     DRCF(NDIAGR)
      COMMON/HWHEWS/S(8,8,2),D(8,8)
      COMMON/HWD3BY/F0,F0M,F1M,F1,F2,F3,F01,A(2,NDIAGR),B(2,NDIAGR),
     &     MS(NDIAGR),MWD(NDIAGR),MR(NDIAGR),MA(4),MA2(4),MB(4),MB2(4),
     &     M342,M232,M242,P,PM,CFTHRE,IDP,DRTYPE,NCTHRE,DRCF
      PARAMETER(ZI=(0.0D0,1.0D0))
      SAVE O
      DATA O/2,1/
C--decide whether to do the diagram
      IF(MB(4)+MR(ID).LT.MB(1).AND.MR(ID).GT.MB(2)+MB(3)) THEN
        DO 5 P0=1,2
        DO 5 P1=1,2
        DO 5 P2=1,2
        DO 5 P3=1,2
 5      ME(P0,P1,P2,P3) = (0.0D0,0.0D0)
        RETURN
      ENDIF
C--compute the propagator factor
      PRE = 0.25D0/(M232-MS(ID)+ZI*MWD(ID))
C--compute the factors for the two vertices
      DO 10 P1=1,2
      DO 10 P2=1,2
         V1(P1,P2) = PRE*( A(O(P2),ID)*F0M(  P1 ,O(P2),4)*S(4,8,O(P2))
     &                    -A(  P2 ,ID)*F0M(  P1 ,  P2 ,8)*MA(4))
 10      V2(P1,P2) = B(O(P1),ID)*F2 (O(P2),O(P1),2)*S(2,6,O(P1))
     &              -B(  P1 ,ID)*F2 (O(P2),  P1 ,6)*MA(2)
C--now compute the matrix element
      DO 20 P0=1,2
      DO 20 P1=1,2
      DO 20 P2=1,2
      DO 20 P3=1,2
 20   ME(P0,P1,P2,P3) = V1(P0,P3)*V2(P1,P2)
      END
CDECK  ID>, HWD3MF.
*CMZ :-        -08/04/02  14:48:42  by  Peter Richardson
*-- Author :    Peter Richardson
C-----------------------------------------------------------------------
      SUBROUTINE HWD3MF(ID,ME)
C-----------------------------------------------------------------------
C  Subroutine to calculate the helicity amplitudes for 7th 3 body RPV
C  diagram f --> fbar fbar fbar
C-----------------------------------------------------------------------
      INCLUDE 'HERWIG65.INC'
      DOUBLE COMPLEX ME(2,2,2,2),S,D,F0(2,2,8),F1(2,2,8),F01(2,2,8,8),
     &     F0M(2,2,8),F2(2,2,8),PRE,ZI,V1(2,2),V2(2,2),F1M(2,2,8),
     &     F3(2,2,8)
      DOUBLE PRECISION A,B,MS,MWD,MA,MB,MA2,MB2,M342,M232,M242,MR,
     &     P(5,4),PM(5,4),CFTHRE(NCFMAX,NCFMAX)
      INTEGER P0,P1,P2,P3,ID,O(2),IDP(4+NDIAGR),DRTYPE(NDIAGR),NCTHRE,
     &     DRCF(NDIAGR)
      COMMON/HWD3BY/F0,F0M,F1M,F1,F2,F3,F01,A(2,NDIAGR),B(2,NDIAGR),
     &     MS(NDIAGR),MWD(NDIAGR),MR(NDIAGR),MA(4),MA2(4),MB(4),MB2(4),
     &     M342,M232,M242,P,PM,CFTHRE,IDP,DRTYPE,NCTHRE,DRCF
      COMMON/HWHEWS/S(8,8,2),D(8,8)
      PARAMETER(ZI=(0.0D0,1.0D0))
      SAVE O
      DATA O/2,1/
C--decide whether to do the diagram
      IF(MB(2)+MR(ID).LT.MB(1).AND.MR(ID).GT.MB(3)+MB(4)) THEN
        DO 5 P0=1,2
        DO 5 P1=1,2
        DO 5 P2=1,2
        DO 5 P3=1,2
 5      ME(P0,P1,P2,P3) = (0.0D0,0.0D0)
        RETURN
      ENDIF
C--calculate the propagator factor
      PRE = 0.25D0/(M342-MS(ID)+ZI*MWD(ID))
C--calculate the vertex functions
      DO 10 P1=1,2
      DO 10 P2=1,2
         V1(P1,P2) = PRE*( A(  P2 ,ID)*F0M(  P1 ,  P2 ,2)*S(2,6,P2)
     &                    -A(O(P2),ID)*F0M(  P1 ,O(P2),6)*MA(2))
 10      V2(P1,P2) =       B(  P2 ,ID)*F2(  P1 ,  P2 ,4)*S(4,8,P2)
     &                    -B(O(P2),ID)*F2(  P1 ,O(P2),8)*MA(4)
C--calculate the matrix element
      DO 20 P0=1,2
      DO 20 P1=1,2
      DO 20 P2=1,2
      DO 20 P3=1,2
 20   ME(P0,P1,P2,P3) = V1(P0,P1)*V2(P2,P3)
      END
CDECK  ID>, HWD3MG.
*CMZ :-        -08/04/02  14:48:42  by  Peter Richardson
*-- Author :    Peter Richardson
C-----------------------------------------------------------------------
      SUBROUTINE HWD3MG(ID,ME)
C-----------------------------------------------------------------------
C  Subroutine to calculate the helicity amplitudes for 8th 3 body RPV
C  diagram f --> fbar fbar fbar
C-----------------------------------------------------------------------
      INCLUDE 'HERWIG65.INC'
      DOUBLE COMPLEX ME(2,2,2,2),S,D,F0(2,2,8),F1(2,2,8),F01(2,2,8,8),
     &     F0M(2,2,8),F2(2,2,8),PRE,V1(2,2),V2(2,2),ZI,F1M(2,2,8),
     &     F3(2,2,8)
      DOUBLE PRECISION A,B,MS,MWD,MA,MB,MA2,MB2,M342,M232,M242,MR,
     &     P(5,4),PM(5,4),CFTHRE(NCFMAX,NCFMAX)
      INTEGER P0,P1,P2,P3,ID,O(2),IDP(4+NDIAGR),DRTYPE(NDIAGR),NCTHRE,
     &     DRCF(NDIAGR)
      COMMON/HWD3BY/F0,F0M,F1M,F1,F2,F3,F01,A(2,NDIAGR),B(2,NDIAGR),
     &     MS(NDIAGR),MWD(NDIAGR),MR(NDIAGR),MA(4),MA2(4),MB(4),MB2(4),
     &     M342,M232,M242,P,PM,CFTHRE,IDP,DRTYPE,NCTHRE,DRCF
      COMMON/HWHEWS/S(8,8,2),D(8,8)
      PARAMETER(ZI=(0.0D0,1.0D0))
      SAVE O
      DATA O/2,1/
C--decide whether to do the diagram
      IF(MB(3)+MR(ID).LT.MB(1).AND.MR(ID).GT.MB(2)+MB(4)) THEN
        DO 5 P0=1,2
        DO 5 P1=1,2
        DO 5 P2=1,2
        DO 5 P3=1,2
 5      ME(P0,P1,P2,P3) = (0.0D0,0.0D0)
        RETURN
      ENDIF
C--compute the propagator factor
      PRE = 0.25D0/(M242-MS(ID)+ZI*MWD(ID))
C--compute the vertex factors
      DO 10 P1=1,2
      DO 10 P2=1,2
         V1(P1,P2) = PRE*( A(  P2 ,ID)*F0M(  P1 ,  P2 ,3)*S(3,7,  P2 )
     &                    -A(O(P2),ID)*F0M(  P1 ,O(P2),7)*MA(3))
 10      V2(P1,P2) =       B(  P1 ,ID)*F3 (  P2 ,  P1 ,2)*S(2,6,  P1 )
     &                    -B(O(P1),ID)*F3 (  P2 ,O(P1),6)*MA(2)
C--compute the matrix element
      DO 20 P0=1,2
      DO 20 P1=1,2
      DO 20 P2=1,2
      DO 20 P3=1,2
 20   ME(P0,P1,P2,P3) = V1(P0,P2)*V2(P1,P3)
      END
CDECK  ID>, HWD3MH.
*CMZ :-        -08/04/02  14:48:42  by  Peter Richardson
*-- Author :    Peter Richardson
C-----------------------------------------------------------------------
      SUBROUTINE HWD3MH(ID,ME)
C-----------------------------------------------------------------------
C  Subroutine to calculate the helicity amplitudes for 9th 3 body RPV
C  diagram f --> fbar fbar fbar
C-----------------------------------------------------------------------
      INCLUDE 'HERWIG65.INC'
      DOUBLE COMPLEX ME(2,2,2,2),S,D,F0(2,2,8),F1(2,2,8),F01(2,2,8,8),
     &     F0M(2,2,8),F2(2,2,8),PRE,ZI,V1(2,2),V2(2,2),F1M(2,2,8),
     &     F3(2,2,8)
      DOUBLE PRECISION A,B,MS,MWD,MA,MB,MA2,MB2,M342,M232,M242,MR,
     &P(5,4),PM(5,4),CFTHRE(NCFMAX,NCFMAX)
      INTEGER P0,P1,P2,P3,ID,O(2),IDP(4+NDIAGR),DRTYPE(NDIAGR),NCTHRE,
     &     DRCF(NDIAGR)
      COMMON/HWHEWS/S(8,8,2),D(8,8)
      COMMON/HWD3BY/F0,F0M,F1M,F1,F2,F3,F01,A(2,NDIAGR),B(2,NDIAGR),
     &     MS(NDIAGR),MWD(NDIAGR),MR(NDIAGR),MA(4),MA2(4),MB(4),MB2(4),
     &     M342,M232,M242,P,PM,CFTHRE,IDP,DRTYPE,NCTHRE,DRCF
      PARAMETER(ZI=(0.0D0,1.0D0))
      SAVE O
      DATA O/2,1/
C--decide whether to do the diagram
      IF(MB(4)+MR(ID).LT.MB(1).AND.MR(ID).GT.MB(2)+MB(3)) THEN
        DO 5 P0=1,2
        DO 5 P1=1,2
        DO 5 P2=1,2
        DO 5 P3=1,2
 5      ME(P0,P1,P2,P3) = (0.0D0,0.0D0)
        RETURN
      ENDIF
C--compute the propagator factor
      PRE = -0.25D0/(M232-MS(ID)+ZI*MWD(ID))
C--compute the factors for the two vertices
      DO 10 P1=1,2
      DO 10 P2=1,2
         V1(P1,P2) = PRE*( A(  P2 ,ID)*F0M(  P1 ,  P2 ,4)*S(4,8,P2)
     &                    -A(O(P2),ID)*F0M(  P1 ,O(P2),8)*MA(4))
 10      V2(P1,P2) =       B(  P1 ,ID)*F2 (  P2 ,  P1 ,2)*S(2,6,P1)
     &                    -B(O(P1),ID)*F2 (  P2 ,O(P1),6)*MA(2)
C--now compute the matrix element
      DO 20 P0=1,2
      DO 20 P1=1,2
      DO 20 P2=1,2
      DO 20 P3=1,2
 20   ME(P0,P1,P2,P3) = V1(P0,P3)*V2(P1,P2)
      END
CDECK  ID>, HWD3MI.
*CMZ :-        -09/04/02  13:37:38  by  Peter Richardson
*-- Author :    Peter Richardson
C-----------------------------------------------------------------------
      SUBROUTINE HWD3MI(ID,ME)
C-----------------------------------------------------------------------
C  Subroutine to calculate the helicity amplitudes for the three body
C  Higgs boson exchange diagram antifermion decay
C-----------------------------------------------------------------------
      INCLUDE 'HERWIG65.INC'
      DOUBLE COMPLEX ME(2,2,2,2),S,D,F0(2,2,8),F1(2,2,8),F01(2,2,8,8),
     &     F0M(2,2,8),F2(2,2,8),PRE,ZI,V1(2,2),V2(2,2),F1M(2,2,8),
     &     F3(2,2,8)
      DOUBLE PRECISION A,B,MS,MWD,MA,MB,MA2,MB2,M342,M232,M242,MR,
     &     P(5,4),PM(5,4),CFTHRE(NCFMAX,NCFMAX)
      INTEGER P0,P1,P2,P3,ID,O(2),IDP(4+NDIAGR),DRTYPE(NDIAGR),NCTHRE,
     &     DRCF(NDIAGR)
      COMMON/HWD3BY/F0,F0M,F1M,F1,F2,F3,F01,A(2,NDIAGR),B(2,NDIAGR),
     &     MS(NDIAGR),MWD(NDIAGR),MR(NDIAGR),MA(4),MA2(4),MB(4),MB2(4),
     &     M342,M232,M242,P,PM,CFTHRE,IDP,DRTYPE,NCTHRE,DRCF
      COMMON/HWHEWS/S(8,8,2),D(8,8)
      PARAMETER(ZI=(0.0D0,1.0D0))
      SAVE O
      DATA O/2,1/
C--decide whether to do the diagram
      IF(MB(2)+MR(ID).LT.MB(1).AND.MR(ID).GT.MB(3)+MB(4).AND.
     &   IDP(4+ID).NE.207) THEN
        DO 5 P0=1,2
        DO 5 P1=1,2
        DO 5 P2=1,2
        DO 5 P3=1,2
 5      ME(P0,P1,P2,P3) = (0.0D0,0.0D0)
        RETURN
      ENDIF
C--calculate the propagator factor
      PRE = 0.25D0/(M342-MS(ID)+ZI*MWD(ID))
C--calculate the vertex functions
      DO 10 P1=1,2
      DO 10 P2=1,2
      V1(P1,P2) = PRE*( A(  P2 ,ID)*F0M(O(P1),  P2 ,2)*S(2,6,P2)
     &                 -A(O(P2),ID)*F0M(O(P1),O(P2),6)*MA(2))
 10   V2(P1,P2) =       B(  P2 ,ID)*F2(O(P1),  P2 ,4)*S(4,8,P2)
     &                 -B(O(P2),ID)*F2(O(P1),O(P2),8)*MA(4)
C--calculate the matrix element
      DO 20 P0=1,2
      DO 20 P1=1,2
      DO 20 P2=1,2
      DO 20 P3=1,2
 20   ME(P0,P1,P2,P3) = V1(P0,P1)*V2(P2,P3)
      END
CDECK  ID>, HWD4ME.
*CMZ :-        -20/10/99  09:46:43  by  Peter Richardson
*-- Author :    Peter Richardson
C-----------------------------------------------------------------------
      SUBROUTINE HWD4ME(ID,ITYPE1,ITYPE2,IMODE)
C-----------------------------------------------------------------------
C     Subroutine to perform the four body Higgs decays
C-----------------------------------------------------------------------
      INCLUDE 'HERWIG65.INC'
      INTEGER IMODE,I,J,ID,IDP(4+NDIAGR),ITYPE(2),NTRY,ITYPE1,ITYPE2
      DOUBLE PRECISION A,B,MS,MWD,M,M2,WGT,HWRUNI,BRW(6),BRZ(12),
     &     HWUPCM,WMAX,WSUM,WSSUM,MR,PRE,TEMP,HWRGEN,WTMAX,P(5,5)
      EXTERNAL HWRUNI,HWUPCM,HWRGEN
      COMMON/HWD4BY/A(2),B(2),MS(2),MWD(2),MR(2),M(5),M2(5),P,IDP
      SAVE BRW,BRZ
      DATA BRW/0.321D0,0.321D0,0.000D0,0.108D0,0.108D0,0.108D0/
      DATA BRZ/0.154D0,0.120D0,0.154D0,0.120D0,0.152D0,0.000D0,
     &         0.033D0,0.067D0,0.033D0,0.067D0,0.033D0,0.067D0/
      ITYPE(1) = ITYPE1
      ITYPE(2) = ITYPE2
      WTMAX = WT4MAX(ITYPE(1),ITYPE(2),IMODE)
      PRE=P4MODE(ITYPE(1),ITYPE(2),IMODE)
C--compute the masses of external particles for the decay mode
      DO I=1,2
C--couplings and masses of the internal particles
        A(I) = A4MODE(I,ITYPE1,IMODE)
        B(I) = B4MODE(I,ITYPE2,IMODE)
        MR(I)  = RMASS(I4MODE(I,IMODE))
        MS(I)  = MR(I)**2
        IF(I4MODE(I,IMODE).EQ.200) THEN
          MWD(I) = MR(I)*GAMZ
        ELSE
          MWD(I) = MR(I)*GAMW
        ENDIF
        IDP(5+I) = I4MODE(I,IMODE)
C--id's of outgoing particles
        IF(I4MODE(I,IMODE).EQ.200) THEN
          IDP(2*I  ) = ITYPE(I)
          IF(ITYPE(I).GT.6) IDP(2*I) = IDP(2*I)+114
          IDP(2*I+1) = IDP(2*I)+6
        ELSE
          IDP(2*I  ) = 2*ITYPE(I)-1
          IF(ITYPE(I).GT.3) IDP(2*I) = IDP(2*I)+114
          IDP(2*I+1) = IDP(2*I)+7
          IF(I4MODE(I,IMODE).EQ.198) THEN
            J          = IDP(2*I  )+6
            IDP(2*I) = IDP(2*I+1)-6
            IDP(2*I+1) = J
          ENDIF
        ENDIF
      ENDDO
      IDP(1) = IDK(ID4PRT(IMODE))
      DO 1 I=1,5
      M(I) = RMASS(IDP(I))
 1    M2(I) = M(I)**2
      IF(M(1).LT.M(2)+M(3)+M(4)+M(5).OR.MR(1).LT.M(2)+M(3).OR.
     &     MR(2).LT.M(4)+M(5)) RETURN
      IF(IPRINT.GE.2.AND..NOT.GENEV)
     &        WRITE(6,3000) RNAME(IDP(6)),RNAME(IDP(2)),RNAME(IDP(3)),
     &                      RNAME(IDP(7)),RNAME(IDP(4)),RNAME(IDP(5))
C--compute the width and maximum weight if initialising
      IF(.NOT.GENEV) THEN
        WMAX  = ZERO
        WSUM  = ZERO
        WSSUM = ZERO
        DO I=1,NSEARCH
          CALL HWD4M0(1,WGT)
          WGT = WGT*PRE
          IF(WGT.GT.WMAX) WMAX = WGT
          WSUM = WSUM+WGT
          WSSUM = WSSUM+WGT**2
          IF(WGT.LT.ZERO) CALL HWWARN('HWD4ME',500)
        ENDDO
        WSUM = WSUM/DBLE(NSEARCH)
        WSSUM = MAX(ZERO,WSSUM/DBLE(NSEARCH)-WSUM**2)
        WSSUM = SQRT(WSSUM/DBLE(NSEARCH))
        IF(IPRINT.GE.2) WRITE(6,3010) WSUM,WSSUM
        IF(IPRINT.GE.2) WRITE(6,3020) WMAX
        TEMP = BRFRAC(ID4PRT(IMODE))*HBAR/RLTIM(IDK(ID4PRT(IMODE)))
        DO J=1,2
          IF(I4MODE(J,IMODE).EQ.200) THEN
            TEMP = TEMP*BRZ(ITYPE(J))
          ELSE
            TEMP = TEMP*BRW(ITYPE(J))
          ENDIF
        ENDDO
        IF(IPRINT.GE.2) WRITE(6,3030) WSUM/TEMP,WSSUM/TEMP
C--set up the maximum weight
        WT4MAX(ITYPE(1),ITYPE(2),IMODE) = WMAX
      ELSE
C--generate a configuation
        NTRY = 0
        IF(SYSPIN.AND.NSPN.NE.0) CALL HWWARN('HWD4ME',501)
 100    NTRY = NTRY+1
        CALL HWD4M0(ID,WGT)
        WGT = WGT*PRE
        IF(HWRGEN(0)*WTMAX.GT.WGT.AND.NTRY.LT.NSNTRY) GOTO 100
        IF(NTRY.GE.NSNTRY) THEN
          CALL HWWARN('HWD4ME',100)
          GOTO 999
        ENDIF
      ENDIF
 3000 FORMAT(/'  FOLLOWED BY ',A8,' --> ',A8,' ',A8,' AND ',
     &                         A8,' --> ',A8,' ',A8)
 3010 FORMAT('            PARTIAL WIDTH  = ',G12.4,' +/- ',G12.4)
 3020 FORMAT('            MAXIMUM WEIGHT = ',E12.4)
 3030 FORMAT('     RATIO TO ISAJET VALUE = ',G12.4,' +/- ',G12.4)
 999  RETURN
      END
CDECK  ID>, HWD4M0.
*CMZ :-        -11/10/01  12:32:39  by  Peter Richardson
*-- Author :    Peter Richardson
C-----------------------------------------------------------------------
      SUBROUTINE HWD4M0(ID,WGT)
C-----------------------------------------------------------------------
C     Subroutine to calculate the matrix element for a given four body
C     decay mode
C-----------------------------------------------------------------------
      INCLUDE 'HERWIG65.INC'
      INTEGER I,J,P0,P1,P2,P3,ID,O(2),IDP(4+NDIAGR),II,P4
      DOUBLE PRECISION A,B,MS,MWD,M,M2,WGT,HWRUNI,
     &     M23,PCMA,PCMB(2),HWUPCM,PHS,N(3),HWVDOT,PP,HWULDO,EPS,
     &     M232,PRE,PLAB,PRW,XMASS,PCM,P(5,5),PM(5,5),MR,PREF(5),
     &     M45,M452,MJAC(2),PTMP(5,2),CN(2),DOT
      DOUBLE COMPLEX S,D,ME(2,2,2,2),APP(2,2),AMP(2,2),APM(2,2),
     &     AMM(2,2),BPP(2,2),BPM(2,2),BMP(2,2),BMM(2,2),ZI,
     &     F45(2,2,8,8),F23(2,2,8,8),C(2,2),E(2,2)
      LOGICAL HWRLOG
      EXTERNAL HWRUNI,HWUPCM,HWVDOT,HWULDO,HWRLOG
      COMMON/HWHEWP/XMASS(10),PLAB(5,10),PRW(5,2),PCM(5,10)
      COMMON/HWD4BY/A(2),B(2),MS(2),MWD(2),MR(2),M(5),M2(5),P,IDP
      COMMON/HWHEWS/S(8,8,2),D(8,8)
      PARAMETER(EPS=1D-20,ZI=(0.0D0,1.0D0))
      SAVE O,PREF
      DATA O/2,1/
      DATA PREF/1.0D0,0.0D0,0.0D0,1.0D0,0.0D0/
C--select the masses of the gauge bosons and compute Jacobians
      IF(HWRLOG(HALF)) THEN
        CALL HWHGB1(1,2,IDP(6),MJAC(1),M232,(M(1)-M(4)-M(5))**2,
     &                                             (M(2)+M(3))**2)
        M23 = SQRT(M232)
        CALL HWHGB1(1,2,IDP(7),MJAC(2),M452,
     &       (M(1)-M23)**2,(M(4)+M(5))**2)
        M45 = SQRT(M452)
      ELSE
        CALL HWHGB1(1,2,IDP(7),MJAC(2),M452,(M(1)-M(2)-M(3))**2,
     &                                            (M(4)+M(5))**2)
        M45 = SQRT(M452)
        CALL HWHGB1(1,2,IDP(6),MJAC(1),M232,(M(1)-M45)**2,
     &       (M(2)+M(3))**2)
        M23 = SQRT(M232)
      ENDIF
      MJAC(1) = MJAC(1)/((M232-MS(1))**2+MWD(1)**2)
      MJAC(2) = MJAC(2)/((M452-MS(2))**2+MWD(2)**2)
      DO 1 I=2,5
 1    P(5,I) = M(I)
      DO 2 I=1,2
 2    CN(I) = -ONE/MS(I)
C--now perform the decay of the Higgs to the bosons
      PCMA = HWUPCM(M(1),M23,M45)
      PLAB(5,1) = M23
      PLAB(5,2) = M45
      CALL HWVEQU(5,PHEP(1,ID),P(1,1))
      CALL HWDTWO(P(1,1),PLAB(1,1),PLAB(1,2),PCMA,2.0D0,.TRUE.)
      PCMB(1) = HWUPCM(M23,M(2),M(3))
      CALL HWDTWO(PLAB(1,1),P(1,2),P(1,3),PCMB(1),2.0D0,.TRUE.)
      PCMB(2) = HWUPCM(M45,M(4),M(5))
      CALL HWDTWO(PLAB(1,2),P(1,4),P(1,5),PCMB(2),2.0D0,.TRUE.)
      DOT = HWULDO(PLAB(1,1),PLAB(1,2))
C--compute the phase sapce factors
      PHS = PCMA*PCMB(1)*PCMB(2)*MJAC(1)*MJAC(2)/512.0D0/PIFAC**5/
     &        M2(1)/M23/M45
C--compute the vectors for the helicity amplitudes
      DO 3 I=1,4
      II=I+1
C--compute the references vectors
C--not important if SM particle which can't have spin measured
C--ie anything other the top and tau
C--also not important if particle is approx massless
C--first the SM particles other than top and tau
      IF(IDP(II).LT.400.AND.(IDP(II).NE.6.AND.IDP(II).NE.12
     &                 .AND.IDP(II).NE.125.AND.IDP(II).NE.131)) THEN
        CALL HWVEQU(5,PREF,PLAB(1,I+4))
C--all other particles
      ELSE
        PP = SQRT(HWVDOT(3,P(1,II),P(1,II)))
        CALL HWVSCA(3,ONE/PP,P(1,II),N)
        PLAB(4,I+4) = HALF*(P(4,II)-PP)
        PP = HALF*(PP-M(II)-PP**2/(M(II)+P(4,II)))
        CALL HWVSCA(3,PP,N,PLAB(1,I+4))
        CALL HWUMAS(PLAB(1,I+4))
        PP = HWVDOT(3,PLAB(1,I+4),PLAB(1,I+4))
C--fix to avoid problems if approx massless due to energy
        IF(PP.LT.EPS) CALL HWVEQU(5,PREF,PLAB(1,I+4))
      ENDIF
C--now the massless vectors
      PP = HALF*M2(II)/HWULDO(PLAB(1,I+4),P(1,II))
      DO 4 J=1,4
 4    PLAB(J,I) = P(J,II)-PP*PLAB(J,I+4)
 3    CALL HWUMAS(PLAB(1,I))
C--change ordr of momenta for call to HE code
      DO 5 I=1,5
      PM(1,I) = P(3,I)
      PM(2,I) = P(1,I)
      PM(3,I) = P(2,I)
      PM(4,I) = P(4,I)
 5    PM(5,I) = P(5,I)
      DO 6 I=1,8
      PCM(1,I)=PLAB(3,I)
      PCM(2,I)=PLAB(1,I)
      PCM(3,I)=PLAB(2,I)
      PCM(4,I)=PLAB(4,I)
 6    PCM(5,I)=PLAB(5,I)
C--compute the S functions
      CALL HWHEW2(8,PCM(1,1),S(1,1,2),S(1,1,1),D)
      DO 7 I=1,8
      DO 7 J=1,8
      S(I,J,2) = -S(I,J,2)
 7    D(I,J)   = TWO*D(I,J)
      CALL HWVSUM(4,PM(1,2),PM(1,3),PTMP(1,1))
      CALL HWVSUM(4,PM(1,4),PM(1,5),PTMP(1,2))
      CALL HWUMAS(PTMP(1,1))
      CALL HWUMAS(PTMP(1,2))
C--compute the F functions
      CALL HWH2F3(8,F23,PTMP(1,1),ZERO)
      CALL HWH2F3(8,F45,PTMP(1,2),ZERO)
C--now find the prefactor for all the diagrams
      PRE = HWULDO(PCM(1,5),PM(1,2))*HWULDO(PCM(1,6),PM(1,3))*
     &      HWULDO(PCM(1,7),PM(1,4))*HWULDO(PCM(1,8),PM(1,5))
      PRE = 0.25D0/SQRT(PRE)
C--zero the matrix element
      DO 8 P0=1,2
      DO 8 P1=1,2
      DO 8 P2=1,2
      DO 8 P3=1,2
 8    ME(P0,P1,P2,P3) = (0.0D0,0.0D0)
C--compute the A, B, C and E functions
      DO 9 P1=1,2
      DO 9 P2=1,2
        IF(P1.EQ.P2) THEN
C--the A and B functions
          APP(P1,P2) =  A(  P2 )*S(5,1,O(P1))*S(2,6,  P1 )
          APM(P1,P2) = 0.0D0
          AMP(P1,P2) = 0.0D0
          AMM(P1,P2) = -A(O(P2))*M(2)*M(3)
          BPP(P1,P2) =  B(  P2 )*S(7,3,O(P1))*S(4,8,  P1 )
          BPM(P1,P2) = 0.0D0
          BMP(P1,P2) = 0.0D0
          BMM(P1,P2) = -B(O(P2))*M(4)*M(5)
C--the C and E functions
          C(P1,P2) =CN(1)*(A(  P2 )*( M2(2)*S(5,2,O(P1))*S(2,6,  P1 )
     &                               +M2(3)*S(5,1,O(P1))*S(1,6,  P1 ))
     &         -A(O(P2))*M(2)*M(3)*( S(5,1,O(P1))*S(1,6,  P1 )
     &                              +S(5,2,O(P1))*S(2,6,  P1 )))
          E(P1,P2) =CN(2)*(B(  P2 )*( M2(4)*S(7,4,O(P1))*S(4,8,  P1 )
     &                               +M2(5)*S(7,3,O(P1))*S(3,8,  P1 ))
     &         -B(O(P2))*M(4)*M(5)*( S(7,3,O(P1))*S(3,8,  P1 )
     &                              +S(7,4,O(P1))*S(4,8,  P1 )))
        ELSE
C--the A functions
          APP(P1,P2) = 0.0D0
          APM(P1,P2) = A(  P2 )*M(2)*S(2,6,O(P1))
          AMP(P1,P2) =-A(O(P2))*M(3)*S(5,1,O(P1))
          AMM(P1,P2) = 0.0D0
          BPP(P1,P2) = 0.0D0
          BPM(P1,P2) = B(  P2 )*M(4)*S(4,8,O(P1))
          BMP(P1,P2) =-B(O(P2))*M(5)*S(7,3,O(P1))
          BMM(P1,P2) = 0.0D0
C--the C and D functions
          C(P1,P2) =CN(1)*( A(  P2 )*M(2)*( M2(3)*S(5,6,O(P1))
     &                      +S(5,1,O(P1))*S(1,2,  P1 )*S(2,6,O(P1)))
     &                     -A(O(P2))*M(3)*( M2(2)*S(5,6,O(P1))
     &                      +S(5,1,O(P1))*S(1,2,  P1 )*S(2,6,O(P1))))
          E(P1,P2) =CN(2)*( B(  P2 )*M(4)*( M2(5)*S(7,8,O(P1))
     &                      +S(7,3,O(P1))*S(3,4,  P1 )*S(4,8,O(P1)))
     &                     -B(O(P2))*M(5)*( M2(4)*S(7,8,O(P1))
     &                      +S(7,3,O(P1))*S(3,4,  P1 )*S(4,8,O(P1))))
        ENDIF
 9    CONTINUE
C--now put the whole thing together to give the matrix element
      DO 10 P1=1,2
      DO 10 P2=1,2
      DO 10 P3=1,2
      DO 10 P4=1,2
        P0=O(P1)
        IF(P1.EQ.P3) THEN
          ME(P1,P2,P3,P4) =
     & APP(P1,P2)*(S(1,3,P1)*(BPP(P3,P4)*S(4,2,P0)+BMP(P3,P4)*S(8,2,P0))
     &           +S(7,2,P0)*(BPM(P3,P4)*S(1,4,P1)+BMM(P3,P4)*S(1,8,P1)))
     &+APM(P1,P2)*(S(5,7,P0)*(BPM(P3,P4)*S(4,2,P1)+BMM(P3,P4)*S(8,2,P1))
     &           +S(3,2,P1)*(BPP(P3,P4)*S(5,4,P0)+BMP(P3,P4)*S(5,8,P0)))
     &+AMP(P1,P2)*(S(1,3,P1)*(BPP(P3,P4)*S(4,6,P0)+BMP(P3,P4)*S(8,6,P0))
     &           +S(7,6,P0)*(BPM(P3,P4)*S(1,4,P1)+BMM(P3,P4)*S(1,8,P1)))
     &+AMM(P1,P2)*(S(3,6,P1)*(BPP(P3,P4)*S(5,4,P0)+BMP(P3,P4)*S(5,8,P0))
     &           +S(5,7,P0)*(BPM(P3,P4)*S(4,6,P1)+BMM(P3,P4)*S(8,6,P1)))
        ELSE
          ME(P1,P2,P3,P4) =
     & APP(P1,P2)*(S(3,2,P0)*(BPP(P3,P4)*S(1,4,P1)+BMP(P3,P4)*S(1,8,P1))
     &           +S(1,7,P1)*(BPM(P3,P4)*S(4,2,P0)+BMM(P3,P4)*S(8,2,P0)))
     &+APM(P1,P2)*(S(5,3,P0)*(BPP(P3,P4)*S(4,2,P1)+BMP(P3,P4)*S(8,2,P1))
     &           +S(7,2,P1)*(BPM(P3,P4)*S(5,4,P0)+BMM(P3,P4)*S(5,8,P0)))
     &+AMP(P1,P2)*(S(3,6,P0)*(BPP(P3,P4)*S(1,4,P1)+BMP(P3,P3)*S(1,8,P1))
     &           +S(1,7,P1)*(BPM(P3,P4)*S(4,6,P0)+BMM(P3,P4)*S(8,6,P0)))
     &+AMM(P1,P2)*(S(5,3,P0)*(BPP(P3,P4)*S(4,6,P1)+BMP(P3,P4)*S(8,6,P1))
     &           +S(7,6,P1)*(BPM(P3,P4)*S(5,4,P0)+BMM(P3,P4)*S(5,8,P0)))
        ENDIF
      ME(P1,P2,P3,P4) = TWO*ME(P1,P2,P3,P4)
     &      +C(P1,P2)*(
     &        BPP(P3,P4)*F23(P3,P3,3,4)+BPM(P3,P4)*F23(O(P3),O(P3),7,4)
     &       +BMP(P3,P4)*F23(P3,P3,3,8)+BMM(P3,P4)*F23(O(P3),O(P3),7,8))
     &      +E(P3,P4)*(
     &        APP(P1,P2)*F45(P1,P1,1,2)+APM(P1,P2)*F45(P0,P0,5,2)
     &       +AMP(P1,P2)*F45(P1,P1,1,6)+AMM(P1,P2)*F45(P0,P0,5,6))
     &       +DOT*C(P1,P2)*E(P3,P4)
 10   ME(P1,P2,P3,P4) = PRE*ME(P1,P2,P3,P4)
C--compute the weight
      WGT = ZERO
      DO 40 P1=1,2
      DO 40 P2=1,2
      DO 40 P3=1,2
      DO 40 P4=1,2
 40   WGT = WGT+DREAL(ME(P1,P2,P3,P4)*DCONJG(ME(P1,P2,P3,P4)))
C--normalise this for phase space
      WGT = WGT*PHS
C--enter the matrix element into the spin common block
      IF(GENEV.AND.SYSPIN) THEN
        NSPN = 5
        DO 11 P1=1,2
        DO 11 P2=1,2
        DO 11 P3=1,2
        DO 11 P4=1,2
 11     MESPN(P1,P2,P3,P4,1,1) = ME(P1,P2,P3,P4)
        SPNCFC(1,1,1) = ONE
        NCFL(1) = 1
      ENDIF
      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--BRW FIX 20/07/04: ADD FULL DECAY CORRELATIONS FOR W/Z+HIGGS
C--BRW FIX 18/07/07: ADD FULL DECAY CORRELATIONS IN HIGGS->VV
C-----------------------------------------------------------------------
      INCLUDE 'HERWIG65.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,ITRY,JBOS
      LOGICAL QUARKS,HIGV2
      EXTERNAL HWRGEN,HWRUNI,HWUPCM,HWULDO,HWRINT
      IBOS=IBOSON
      IF (IDHW(IBOS).LT.198.OR.IDHW(IBOS).GT.200) THEN
        CALL HWWARN('HWDBOS',101)
        GOTO 999
      ENDIF
      QUARKS=.FALSE.
C---SEE IF IT IS PART OF A PAIR
      IMOTH=JMOHEP(1,IBOS)
      IPAIR=JMOHEP(2,IBOS)
      ICMF=JMOHEP(1,IBOS)
C--BRW FIX 17/07/03
      IF (IPAIR.EQ.IBOS) THEN
        IOPT=0
        IF (IPRO.EQ.26.OR.IPRO.EQ.27) ICMF=JMOHEP(1,IMOTH)
      ELSE
        IF (IDHW(ICMF).EQ.IDHW(IBOS).AND.ISTHEP(ICMF)/10.EQ.12) THEN
          IPAIR=JMOHEP(2,ICMF)
          IF (IPAIR.NE.0) THEN
            IPAIR=JDAHEP(1,IPAIR)
            IF (IPAIR.NE.0) JMOHEP(2,IPAIR)=IBOS
          ENDIF
          ICMF=JMOHEP(1,ICMF)
        ENDIF
        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.AND.IPAIR.NE.IBOS) IOPT=1
      ENDIF
C--END FIX
C---SELECT DECAY PRODUCTS
   10 CALL HWDBOZ(IDHW(IBOS),IDN(1),IDN(2),CV,CA,BR,IOPT)
C---V + 1JET, V+HIGGS DECAYS ARE NOW HANDLED HERE !
      IF (IPRO.EQ.21.OR.IPRO.EQ.26.OR.IPRO.EQ.27) 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) THEN
          CALL HWWARN('HWDBOS',103)
          GOTO 999
        ENDIF
        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=ONE
          RLLR=ZERO
        ENDIF
        IF (IPRO.EQ.21) THEN
           PMAX=(RRLL+RLLR)*(HWULDO(PHEP(1,IANT),PHEP(1,IBOS))**2+
     &                       HWULDO(PHEP(1,IQRK),PHEP(1,IBOS))**2)
        ELSE
           PMAX=(RRLL+RLLR)* HWULDO(PHEP(1,IANT),PHEP(1,IBOS))*
     &                       HWULDO(PHEP(1,IQRK),PHEP(1,IBOS))
        ENDIF
 1         CALL HWDTWO(PHEP(1,IBOS),PHEP(1,NHEP+1),PHEP(1,NHEP+2),
     &                 PCM,TWO,.TRUE.)
        IF (IPRO.EQ.21) THEN
           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)
        ELSE
           PROB=RRLL* HWULDO(PHEP(1,IANT),PHEP(1,NHEP+1))*
     &                HWULDO(PHEP(1,IQRK),PHEP(1,NHEP+2))+
     &          RLLR* HWULDO(PHEP(1,IANT),PHEP(1,NHEP+2))*
     &                HWULDO(PHEP(1,IQRK),PHEP(1,NHEP+1))
        ENDIF
        IF (PROB.GT.PMAX.OR.PROB.LT.ZERO) THEN
          CALL HWWARN('HWDBOS',104)
          GOTO 999
        ENDIF
        IF (PMAX*HWRGEN(0).GT.PROB) GOTO 1
      ELSE
C---SELECT HELICITY, UNLESS IT IS THE SECOND OF A HIGGS DECAY (EPR)
      ITRY=0
      HIGV2=IPAIR.EQ.IBOS.AND.IDHW(ICMF).EQ.201
      IF (HIGV2) THEN
        IQRK=JDAHEP(1,JBOS)
        IANT=JDAHEP(2,JBOS)
        IF (IDHW(IBOS).EQ.200) THEN
          ID=IDN(1)
          IF (ID.GT.120) ID=ID-110
          IQ=IDHW(IQRK)
          IF (IQ.GT.120) IQ=IQ-110
          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=ONE
          RLLR=ZERO
        ENDIF
        PMAX=(RRLL+RLLR)* HWULDO(PHEP(1,IANT),PHEP(1,IBOS))*
     &                    HWULDO(PHEP(1,IQRK),PHEP(1,IBOS))
      ELSE
       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)
        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
 25   ITRY=ITRY+1
      IF (ITRY.GT.NDTRY) THEN
           CALL HWWARN('HWDBOS',105)
           GOTO 999
      ENDIF
 30   COSTH=HWRUNI(0,-ONE,ONE)
      IF (HIGV2) GOTO 32
      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
 32   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) THEN
        CALL HWWARN('HWDBOS',102)
        GOTO 999
      ENDIF
      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
C--BRW FIX 30/11/08: BOOST FIRST TO HIGGS RF, THEN TO LAB
      CALL HWULOB(PBOS,PHEP(1,NHEP+1),PHEP(1,NHEP+1))
      CALL HWULOB(PHEP(1,ICMF),PHEP(1,NHEP+1),PHEP(1,NHEP+1))
C--END BRW FIX
      CALL HWVDIF(4,PHEP(1,IBOS),PHEP(1,NHEP+1),PHEP(1,NHEP+2))
      IF (HIGV2) THEN
C---HIGGS->VV DECAY CORRELATION
         PROB=RRLL* HWULDO(PHEP(1,IANT),PHEP(1,NHEP+2))*
     &              HWULDO(PHEP(1,IQRK),PHEP(1,NHEP+1))+
     &        RLLR* HWULDO(PHEP(1,IANT),PHEP(1,NHEP+1))*
     &              HWULDO(PHEP(1,IQRK),PHEP(1,NHEP+2))
         IF (PROB.GT.PMAX.OR.PROB.LT.ZERO) THEN
           CALL HWWARN('HWDBOS',106)
           GOTO 999
         ENDIF
         IF (PMAX*HWRGEN(0).GT.PROB) GOTO 25
      ENDIF
      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.
      ELSE
C--MHS FIX 07/03/05 - VERTEX POSITION FOR DECAYS TO LEPTONS
        CALL HWVEQU(4,VTXPIP,VHEP(1,NHEP-1))
        CALL HWVEQU(4,VTXPIP,VHEP(1,NHEP))
C--END FIX
      ENDIF
C---IF FIRST OF A PAIR, DO SECOND DECAY
      IF (IPAIR.NE.0 .AND. IPAIR.NE.IBOS) THEN
        JBOS=IBOS
        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  RETURN
      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 'HERWIG65.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
      SAVE IDMODE,BRMODE
      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.321D0,0.321D0,0.000D0,0.017D0,0.017D0,0.108D0,
     &            0.108D0,0.108D0,4*0.0D0,
     &            0.321D0,0.321D0,0.000D0,0.017D0,0.017D0,0.108D0,
     &            0.108D0,0.108D0,4*0.0D0,
     &            0.154D0,0.120D0,0.154D0,0.120D0,0.152D0,0.000D0,
     &            0.033D0,0.033D0,0.033D0,0.067D0,0.067D0,0.067D0/
C---FACTORS FOR CV AND CA FOR W AND Z
      DATA FACW,FACZ/2*0.0D0/
      IF (FACZ.EQ.ZERO) FACZ=SQRT(SWEIN)
      IF (FACW.EQ.ZERO) FACW=0.5/SQRT(2D0)
      IF (IDBOS.LT.198.OR.IDBOS.GT.200) THEN
        CALL HWWARN('HWDBOZ',101)
        GOTO 999
      ENDIF
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) THEN
        CALL HWWARN('HWDBOZ',102)
        GOTO 999
      ENDIF
C---IF PAIR OPTION SPECIFIED FOR THE FIRST TIME, MAKE CHOICE
      IF (IOPT.EQ.1) THEN
        IF (NUMDEC.GT.MODMAX-1) THEN
          CALL HWWARN('HWDBOZ',103)
          GOTO 999
        ENDIF
        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  RETURN
      END
CDECK  ID>, HWDBZ2.
*CMZ :-        -02/04/01  12.11.55  by  Peter Richardson
*-- Author :    Peter Richardson based on Mike Seymour's HWDBOZ
C-----------------------------------------------------------------------
      SUBROUTINE HWDBZ2(IDBOS,IFER,IANT,CV,CA,BR,IOPT,MASS)
C-----------------------------------------------------------------------
C     CHOOSE DECAY MODE OF BOSON
C     IOPT=2 TO RESET COUNTERS, 1 FOR BOSON PAIR, 0 FOR ANY OTHERS
C     IDENTICAL TO HWDBOZ BUT REQUIRES DECAY MODE ACCESSIBLE FOR GIVEN
C     MASS
C-----------------------------------------------------------------------
      INCLUDE 'HERWIG65.INC'
      DOUBLE PRECISION HWRGEN,BRMODE(12,3),CV,CA,BR,BRLST,BRCOM,FACZ,
     & FACW,MSMODE(12,3),MASS
      INTEGER HWRINT,IDBOS,IDEC,IDMODE(2,12,3),IFER,IANT,IOPT,I1,I2,
     & I1LST,I2LST,NWGLST,NUMDEC,NPAIR,MODTMP,JFER,NTRY
      LOGICAL GENLST
      EXTERNAL HWRGEN,HWRINT
      SAVE FACW,FACZ,MSMODE,NWGLST,GENLST,NUMDEC,NPAIR,I1LST,I2LST,BRLST
      SAVE IDMODE,BRMODE
      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.321D0,0.321D0,0.000D0,0.017D0,0.017D0,0.108D0,
     &            0.108D0,0.108D0,4*0.0D0,
     &            0.321D0,0.321D0,0.000D0,0.017D0,0.017D0,0.108D0,
     &            0.108D0,0.108D0,4*0.0D0,
     &            0.154D0,0.120D0,0.154D0,0.120D0,0.152D0,0.000D0,
     &            0.033D0,0.033D0,0.033D0,0.067D0,0.067D0,0.067D0/
      DATA MSMODE/36*0.0D0/
C---FACTORS FOR CV AND CA FOR W AND Z
      DATA FACW,FACZ/2*0.0D0/
      IF (FACZ.EQ.ZERO) FACZ=SQRT(SWEIN)
      IF (FACW.EQ.ZERO) FACW=0.5/SQRT(2D0)
      IF (IDBOS.LT.198.OR.IDBOS.GT.200) THEN
        CALL HWWARN('HWDBZ2',101)
        GOTO 999
      ENDIF
      IF(MSMODE(1,1).EQ.ZERO) THEN
        DO I1=1,12
          DO I2=1,3
            MSMODE(I1,I2)=RMASS(IDMODE(1,I1,I2))+RMASS(IDMODE(2,I1,I2))
          ENDDO
        ENDDO
      ENDIF
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) THEN
        CALL HWWARN('HWDBZ2',102)
        GOTO 999
      ENDIF
C---IF PAIR OPTION SPECIFIED FOR THE FIRST TIME, MAKE CHOICE
      IF (IOPT.EQ.1) THEN
        IF (NUMDEC.GT.MODMAX-1) THEN
          CALL HWWARN('HWDBZ2',103)
          GOTO 999
        ENDIF
        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
      NTRY = 0
 10   IDEC=HWRINT(I1,I2)
      NTRY = NTRY+1
      IF (HWRGEN(0).GT.BRMODE(IDEC,IDBOS-197).AND.I1.NE.I2) GOTO 10
      IF(MASS.LT.MSMODE(IDEC,IDBOS-197).AND.NTRY.LT.NBTRY) GOTO 10
      IF(NTRY.GE.NBTRY) THEN
        BR = ZERO
        RETURN
      ENDIF
      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     IF(MSMODE(IDEC,IDBOS-197).LT.MASS) 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         IF(MSMODE(IDEC,IDBOS-197).LT.MASS)
     &            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  RETURN
      END
CDECK  ID>, HWDCHK.
*CMZ :-        -27/07/99  13.33.03  by  Mike Seymour
*-- Author :    Ian Knowles
C-----------------------------------------------------------------------
      SUBROUTINE HWDCHK(IDKY,L,IFGO)
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 'HERWIG65.INC'
      DOUBLE PRECISION EPS,QS,Q,DM
      INTEGER IDKY,L,IFAULT,I,ID,J
      LOGICAL IFGO
      PARAMETER (EPS=1.D-6)
      IFGO = .FALSE.
      IF (VTOCDK(IDKY).AND.VTORDK(IDKY)) THEN
        IFGO = .TRUE.
        RETURN
      ENDIF
      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
C--modification so doesn't remove H --> W*W* Z*Z* modes
        IF (DM.LT.ZERO.AND..NOT.
     &        (FOURB.AND.IDK(L).GE.203.AND.IDK(L).LE.205.AND.
     &         IDKPRD(1,L).GE.198.AND.IDKPRD(2,L).LE.200.AND.
     &         IDKPRD(2,L).GE.198.AND.IDKPRD(2,L).LE.200)) 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
        IFGO = .TRUE.
        RETURN
      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 'HERWIG65.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)
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/HWRJET/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)
      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)=SNGL(PHEP(1,IHEP))
      QQP(1,2)=SNGL(PHEP(2,IHEP))
      QQP(1,3)=SNGL(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
      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 'HERWIG65.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)=SNGL(PHEP(1,IHEP))
      EUPCM(2,1)=SNGL(PHEP(2,IHEP))
      EUPCM(3,1)=SNGL(PHEP(3,IHEP))
      EUPCM(5,1)=SQRT(EUPCM(1,1)**2+EUPCM(2,1)**2+EUPCM(3,1)**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) THEN
        CALL HWWARN('HWDEUR',99)
        GOTO 999
      ENDIF
   40 CONTINUE
 999  RETURN
      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-----------------------------------------------------------------------
      INCLUDE 'HERWIG65.INC'
      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
      INTEGER NTRY
      EXTERNAL HWRGEN
      B=P0(5)-P1(5)
      C=P2(5)+P3(5)+P4(5)
      IF (B.LT.C) THEN
        CALL HWWARN('HWDFOR',100)
        GOTO 999
      ENDIF
      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
      NTRY=0
  10  NTRY=NTRY+1
      IF(NTRY.GT.NDETRY) THEN
         CALL HWWARN('HWDFOR',101)
         GOTO 999
      ENDIF
      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  RETURN
      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-----------------------------------------------------------------------
      INCLUDE 'HERWIG65.INC'
      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
      INTEGER NTRY
      EXTERNAL HWRGEN
      B=P0(5)-P1(5)
      C=P2(5)+P3(5)+P4(5)+P5(5)
      IF (B.LT.C) THEN
        CALL HWWARN('HWDFIV',100)
        GOTO 999
      ENDIF
      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
      NTRY=0
  10  NTRY=NTRY+1
      IF(NTRY.GT.NDETRY) THEN
         CALL HWWARN('HWDFIV',101)
         GOTO 999
      ENDIF
      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  RETURN
      END
CDECK  ID>, HWDHAD.
*CMZ :-        -26/04/91  11.11.54  by  Peter Richardson
*-- Author :    Ian Knowles, Bryan Webber & Mike Seymour
C-----------------------------------------------------------------------
      SUBROUTINE HWDHAD
C-----------------------------------------------------------------------
C     GENERATES DECAYS OF UNSTABLE HADRONS AND LEPTONS
C     Modified for TAUOLA interface 16/10/01 PR
C-----------------------------------------------------------------------
      INCLUDE 'HERWIG65.INC'
      COMMON/FFS/TB,BT
      COMMON/SFF/IT1,IB1,IT2,IB2
      DOUBLE PRECISION TB,BT
      INTEGER IT1,IB1,IT2,IB2
      DOUBLE PRECISION HWRGEN,HWULDO,RN,BF,COSANG,RSUM,DIST(4),VERTX(4),
     & PMIX,WTMX,WTMX2,XS,DOT1,DOT2,HWDPWT,HWDWWT,HWDHWT,XXX,YYY
      INTEGER IHEP,ID,MHEP,IDM,I,IDS,IM,MO,IPDG
      LOGICAL STABLE
      EXTERNAL HWRGEN,HWDPWT,HWDWWT,HWDHWT,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) THEN
          CALL HWWARN('HWDHAD',100)
          GOTO 999
        ENDIF
        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) THEN
                CALL HWWARN('HWDHAD',101)
                GOTO 999
              ENDIF
              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 Use TAUOLA package for tau decays if requested
          IF((IDM.EQ.125.OR.IDM.EQ.131).AND.TAUDEC.EQ.'TAUOLA') THEN
            CALL HWDTAU(1,MHEP,0.0D0)
            GOTO 100
          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)
          GOTO 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) THEN
              CALL HWWARN('HWDHAD',102)
              GOTO 999
            ENDIF
            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) THEN
              CALL HWWARN('HWDHAD',103)
              GOTO 999
            ENDIF
            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 IF (NME(IM).EQ.200) THEN
C Use free massless ((V-A)*TB1+(V+A)*CT1)*((V-A)*TB2+(V+A)*CT2)) Matrix Element
C sort tan(beta)
              IF((IDK(IM).EQ.  2).OR.(IDK(IM).EQ.  4).OR.
     &           (IDK(IM).EQ.  6).OR.(IDK(IM).EQ.  8).OR.
     &           (IDK(IM).EQ. 10).OR.(IDK(IM).EQ. 12).OR.
     &           (IDK(IM).EQ.122).OR.(IDK(IM).EQ.124).OR.
     &           (IDK(IM).EQ.126).OR.(IDK(IM).EQ.128).OR.
     &           (IDK(IM).EQ.130).OR.(IDK(IM).EQ.132))THEN
                TB=TANB
              ELSE
                TB=1./TANB
              END IF
              IF((IDKPRD(1,IM).EQ.  2).OR.(IDKPRD(1,IM).EQ.  4).OR.
     &           (IDKPRD(1,IM).EQ.  6).OR.(IDKPRD(1,IM).EQ.  8).OR.
     &           (IDKPRD(1,IM).EQ. 10).OR.(IDKPRD(1,IM).EQ. 12).OR.
     &           (IDKPRD(1,IM).EQ.122).OR.(IDKPRD(1,IM).EQ.124).OR.
     &           (IDKPRD(1,IM).EQ.126).OR.(IDKPRD(1,IM).EQ.128).OR.
     &           (IDKPRD(1,IM).EQ.130).OR.(IDKPRD(1,IM).EQ.132))THEN
                BT=TANB
              ELSE
                BT=1./TANB
              END IF
              IT1=IDK(IM)
              IB1=IDKPRD(3,IM)
              IT2=IDKPRD(1,IM)
              IB2=IDKPRD(2,IM)
              CALL HWDTHR(PHEP(1,MHEP),PHEP(1,NHEP),PHEP(1,NHEP-2),
     &                    PHEP(1,NHEP-1),HWDHWT)
            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))
            IF(IERROR.NE.0) RETURN
          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))
            IF(IERROR.NE.0) RETURN
          ELSE
            CALL HWWARN('HWDHAD',104)
            GOTO 999
          ENDIF
        ENDIF
      ENDIF
  100 CONTINUE
C---MAY HAVE OVERFLOWED /HEPEVT/
      CALL HWWARN('HWDHAD',105)
 999  RETURN
      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 'HERWIG65.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 'HERWIG65.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
      SAVE CHANGE,NBIN
      DATA CHANGE,NBIN/0.425D0,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 'HERWIG65.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))
      SAVE GAMLIM
      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) THEN
          CALL HWWARN('HWDHIG',101)
          GOTO 999
        ENDIF
        EMH=PHEP(5,IHIG)
        IF (EMH.LE.ZERO) THEN
          CALL HWWARN('HWDHIG',102)
          GOTO 999
        ENDIF
        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) THEN
        CALL HWWARN('HWDHIG',103)
        GOTO 999
      ENDIF
      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(ABS(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) THEN
        CALL HWWARN('HWDHIG',104)
        GOTO 999
      ENDIF
      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) THEN
        CALL HWWARN('HWDHIG',105)
        GOTO 999
      ENDIF
      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
C--MHS FIX 07/03/05 - VERTEX POSITION FOR DECAYS TO LEPTONS OR PHOTONS
      ELSEIF (IMODE.LE.9.OR.IMODE.EQ.12) THEN
        CALL HWVEQU(4,VTXPIP,VHEP(1,NHEP-1))
        CALL HWVEQU(4,VTXPIP,VHEP(1,NHEP))
C--END FIX
      ENDIF
 999  RETURN
      END
CDECK  ID>, HWDHOB.
*CMZ :-        -17/10/01  10:19:15  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   MODIFIED TO CALL A NUMBER OF ROUTINES TO DO THE VARIOUS BITS OF
C   THE PROCESS
C-----------------------------------------------------------------------
      INCLUDE 'HERWIG65.INC'
      DOUBLE PRECISION PW(5)
      INTEGER IHEP,IS,ID,IM,KHEP,LHEP,MHEP,NPR,CLSAVE(2),NHEPST
      LOGICAL FOUND
      SAVE NHEPST
      IF (IERROR.NE.0) RETURN
  10  FOUND=.FALSE.
      NHEPST = NHEP
      CLSAVE(1) = 0
      CLSAVE(2) = 0
      DO 60 IHEP=1,NMXHEP
      IS=ISTHEP(IHEP)
      ID=IDHW(IHEP)
      IF(SYSPIN.AND.NSPN.NE.0) CALL HWDSIN(CLSAVE)
      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.120.AND.JDAHEP(1,IHEP).EQ.IHEP).OR.
     & IS.EQ.190.OR.(IS.GE.147.AND.IS.LE.151))) THEN
        FOUND=.TRUE.
C--select the decay mode and enter the decay products in the event record
        CALL  HWDHO1(IHEP,ID,IM,NPR,LHEP,MHEP)
        IF (IERROR.NE.0) RETURN
C--select the momenta of the decay products
        CALL HWDHO2(IHEP,IM,NPR,MHEP,LHEP,KHEP,PW)
        IF (IERROR.NE.0) RETURN
C--make the colour connections
        CALL HWDHO3(ID,IM,NPR,MHEP,LHEP,KHEP,CLSAVE)
        IF (IERROR.NE.0) RETURN
C--perform the parton-showers
        CALL HWDHO4(IHEP,ID,IM,NPR,MHEP,LHEP,KHEP,PW)
        IF (IERROR.NE.0) RETURN
      ENDIF
C--perform the colour corrections for RPV
      CALL HWDHO5(MHEP,LHEP,CLSAVE)
      IF(IERROR.NE.0) RETURN
      IF (IHEP.EQ.NHEP) GOTO 70
  60  CONTINUE
  70  IF(SYSPIN.AND.NHEP.NE.NHEPST) FOUND=.TRUE.
      IF (FOUND) THEN
C--final check for colour disconnection
        CALL HWDHO6
C Go back to check for further heavy decay products
        GOTO 10
      ENDIF
      END
CDECK  ID>, HWDHO1.
*CMZ :-        -17/10/01  10:19:15  by  Peter Richardson
*-- Author :    Ian Knowles & Bryan Webber
C-----------------------------------------------------------------------
      SUBROUTINE HWDHO1(IHEP,ID,IM,NPR,LHEP,MHEP)
C-----------------------------------------------------------------------
C   Subroutine to perform the first part of the heavy object decays
C   IE to select the decay mode
C   was part of HWDHOB
C-----------------------------------------------------------------------
      INCLUDE 'HERWIG65.INC'
      DOUBLE PRECISION HWUMBW,HWRGEN,SDKM,RN,BF
      INTEGER IST(3),IHEP,ID,IM,I,JHEP,LHEP,MHEP,NPR,MTRY,NTRY,IS
      EXTERNAL HWRGEN
      SAVE IST
      DATA IST/113,114,114/
      IF (IERROR.NE.0) RETURN
      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)
C--copy the location of the particle in the spin block
      IF(SYSPIN.AND.NSPN.NE.0) THEN
         IF(ISNHEP(IHEP).EQ.0) THEN
           IS = IHEP
           MTRY = 0
 5         MTRY = MTRY+1
           IS = JMOHEP(1,IS)
           IF(ISNHEP(IS).EQ.0.AND.MTRY.LE.NETRY) GOTO 5
           IF(MTRY.GT.NETRY) THEN
             CALL HWWARN('HWDHO1',102)
             GOTO 999
           ENDIF
           ISNHEP(IHEP) = ISNHEP(IS)
         ENDIF
         ISNHEP(NHEP) = ISNHEP(JMOHEP(1,NHEP))
      ENDIF
      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('HWDHO1',50)
  30  IF (NHEP+5.GT.NMXHEP) THEN
        CALL HWWARN('HWDHO1',100)
        GOTO 999
      ENDIF
      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
      IF (ISTHEP(IHEP).NE.120) 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('HWDHO1',1)
        IF (MTRY.LE.NETRY) GO TO 15
        CALL HWWARN('HWDHO1',101)
        GOTO 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))
 999  RETURN
      END
CDECK  ID>, HWDH02.
*CMZ :-        -30/09/02  14:05:28  by  Peter Richardson
*-- Author :    Ian Knowles & Bryan Webber
C-----------------------------------------------------------------------
      SUBROUTINE HWDHO2(IHEP,IM,NPR,MHEP,LHEP,KHEP,PW)
C-----------------------------------------------------------------------
C   Subroutine to perform the second part of the heavy object decays
C   IE generate the kinematics for the decay
C   was part of HWDHOB
C-----------------------------------------------------------------------
      INCLUDE 'HERWIG65.INC'
      COMMON/FFS/TB,BT
      COMMON/SFF/IT1,IB1,IT2,IB2
      DOUBLE PRECISION TB,BT
      INTEGER IT1,IB1,IT2,IB2,ISP
      DOUBLE PRECISION GAMHPM
      DOUBLE PRECISION HWUPCM,HWRGEN,PCM,
     & EMMX,EMWSQ,GMWSQ,EMLIM,PW(5),EMTST,HWDPWT,HWDWWT,HWULDO,HWDHWT
      DOUBLE COMPLEX RHOIN(2,2,2)
      INTEGER IHEP,IM,KHEP,LHEP,MHEP,NPR,RHEP
      EXTERNAL HWRGEN,HWDPWT,HWDWWT,HWDHWT
      SAVE RHOIN
      DATA RHOIN/(1.0D0,0.0D0),(0.0D0,0.0D0),
     &           (0.0D0,0.0D0),(0.0D0,0.0D0),
     &           (0.5D0,0.0D0),(0.0D0,0.0D0),
     &           (0.0D0,0.0D0),(0.5D0,0.0D0)/
      ISP = INT(2*RSPIN(IDHW(IHEP)))+1
      IF (IERROR.NE.0) RETURN
      IF (NPR.EQ.2) THEN
C Two body decay: LHEP -> MHEP + NHEP
        IF(NME(IM).GT.20000.AND.NME(IM).LT.30000) THEN
C--generate a two body decay to a gauge boson as a three body decay
          CALL HWDSM3(2,IHEP,MHEP,NHEP,0,NME(IM)-20000,RHOIN(1,1,ISP),1)
C--generate a two body decay of a Higgs to two gauge bosons
        ELSEIF(NME(IM).GT.40000.AND.NME(IM).LT.50000) THEN
          CALL HWDSM4(1,IHEP,MHEP,NHEP,NME(IM)-40000)
C--if spin correlations call the routine to set-up the matrix element
        ELSEIF(SYSPIN.AND.NME(IM).GE.30000.AND.NME(IM).LE.40000) THEN
          CALL HWDSM2(IHEP,MHEP,NHEP,NME(IM)-30000,RHOIN(1,1,ISP),1)
        ELSE
          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.)
        ENDIF
      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))
        ELSE IF (NME(IM).EQ.200) THEN
C Generate decay momenta using full
C ((V-A)*TB1+(V+A)*CT1)*((V-A)*TB2+(V+A)*CT2)) matrix element
          GAMHPM=RMASS(206)/DKLTM(206)
C sort tan(beta)
          IF((IDK(IM).EQ.  2).OR.(IDK(IM).EQ.  4).OR.
     &       (IDK(IM).EQ.  6).OR.(IDK(IM).EQ.  8).OR.
     &       (IDK(IM).EQ. 10).OR.(IDK(IM).EQ. 12).OR.
     &       (IDK(IM).EQ.122).OR.(IDK(IM).EQ.124).OR.
     &       (IDK(IM).EQ.126).OR.(IDK(IM).EQ.128).OR.
     &       (IDK(IM).EQ.130).OR.(IDK(IM).EQ.132))THEN
            TB=TANB
          ELSE
            TB=1./TANB
          END IF
          IF((IDKPRD(1,IM).EQ.  2).OR.(IDKPRD(1,IM).EQ.  4).OR.
     &       (IDKPRD(1,IM).EQ.  6).OR.(IDKPRD(1,IM).EQ.  8).OR.
     &       (IDKPRD(1,IM).EQ. 10).OR.(IDKPRD(1,IM).EQ. 12).OR.
     &       (IDKPRD(1,IM).EQ.122).OR.(IDKPRD(1,IM).EQ.124).OR.
     &       (IDKPRD(1,IM).EQ.126).OR.(IDKPRD(1,IM).EQ.128).OR.
     &       (IDKPRD(1,IM).EQ.130).OR.(IDKPRD(1,IM).EQ.132))THEN
            BT=TANB
          ELSE
            BT=1./TANB
          END IF
          IT1=IDK(IM)
          IB1=IDKPRD(3,IM)
          IT2=IDKPRD(1,IM)
          IB2=IDKPRD(2,IM)
          EMMX=PHEP(5,IHEP)-PHEP(5,NHEP)
          EMWSQ=RMASS(206)**2
          GMWSQ=(RMASS(206)*GAMHPM)**2
          EMLIM=GMWSQ
          IF (EMMX.LT.RMASS(206)) EMLIM=EMLIM+(EMWSQ-EMMX**2)**2
  55      CALL HWDTHR(PHEP(1,IHEP),PHEP(1,NHEP),
     &                PHEP(1,KHEP),PHEP(1,MHEP),HWDHWT)
          CALL HWVSUM(4,PHEP(1,KHEP),PHEP(1,MHEP),PW)
          PW(5)=HWULDO(PW,PW)
          EMTST=(EMWSQ-PW(5))**2
          IF ((EMTST+GMWSQ)*HWRGEN(2).GT.EMLIM) GOTO 55
          PW(5)=SQRT(PW(5))
C Assign production vertices to 1 and 2
          CALL HWUDKL(206,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)
C--Three body SUSY decay
        ELSEIF(NME(IM).GE.10000.AND.NME(IM).LT.20000) THEN
          CALL HWDSM3(3,IHEP,MHEP,KHEP,NHEP,NME(IM)-10000,
     &                RHOIN(1,1,ISP),1)
C--special for top decay
          IF(ABS(IDHEP(IHEP)).EQ.6) THEN
            CALL HWVSUM(4,PHEP(1,KHEP),PHEP(1,MHEP),PW)
            CALL HWUMAS(PW)
          ENDIF
        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
        ISTHEP(NHEP) = 114
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))
        IF(IERROR.NE.0) RETURN
        CALL HWVEQU(4,VHEP(1,KHEP),VHEP(1,RHEP))
        CALL HWVEQU(4,VHEP(1,KHEP),VHEP(1,MHEP))
      ELSE
        CALL HWWARN('HWDHO2',100)
      ENDIF
      END
CDECK  ID>, HWDHO3.
*CMZ :-        -17/10/01  10:19:15  by  Peter Richardson
*-- Author :    Ian Knowles & Bryan Webber
C-----------------------------------------------------------------------
      SUBROUTINE HWDHO3(ID,IM,NPR,MHEP,LHEP,KHEP,CLSAVE)
C-----------------------------------------------------------------------
C   Subroutine to perform the third part of the heavy object decays
C   IE setup the colour connections
C   was part of HWDHOB
C-----------------------------------------------------------------------
      INCLUDE 'HERWIG65.INC'
      INTEGER ID,IM,KHEP,LHEP,MHEP,NPR,CLSAVE(2)
      IF (IERROR.NE.0) RETURN
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).OR.
     &      ((SYSPIN.OR.THREEB).AND.NPR.EQ.3.AND.
     &        NME(IM).GE.10000.AND.NME(IM).LE.20000)) 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 2->2
          JMOHEP(2,MHEP)=MHEP
          JDAHEP(2,MHEP)=MHEP
          JMOHEP(2,NHEP)=LHEP
          JDAHEP(2,NHEP)=LHEP
        ELSEIF (ABS(IDHEP(NHEP)).EQ.37) THEN
C heavy quark to charged Higgs 2->2
          JMOHEP(2,MHEP)=LHEP
          JDAHEP(2,MHEP)=LHEP
          JMOHEP(2,NHEP)=NHEP
          JDAHEP(2,NHEP)=NHEP
        ELSE IF (NPR.EQ.3.AND.NME(IM).EQ.200) THEN
C heavy quark to charged Higgs 2->3
          JMOHEP(2,KHEP)=MHEP
          JDAHEP(2,KHEP)=MHEP
          JMOHEP(2,MHEP)=KHEP
          JDAHEP(2,MHEP)=KHEP
          JMOHEP(2,NHEP)=LHEP
          JDAHEP(2,NHEP)=LHEP
        ELSE
          CALL HWWARN('HWDHO3',100)
          GOTO 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('HWDHO3',101)
              GOTO 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
 999  RETURN
      END
CDECK  ID>, HWDHO4.
*CMZ :-        -30/09/02  14:05:28  by  Peter Richardson
*-- Author :    Ian Knowles & Bryan Webber
C-----------------------------------------------------------------------
      SUBROUTINE HWDHO4(IHEP,ID,IM,NPR,MHEP,LHEP,KHEP,PW)
C-----------------------------------------------------------------------
C   Subroutine to perform the fourth part of the heavy object decays
C   IE parton-showers with special treatment for top
C   was part of HWDHOB
C-----------------------------------------------------------------------
      INCLUDE 'HERWIG65.INC'
      DOUBLE PRECISION PW(5),PDW(5,3)
      INTEGER IHEP,ID,IM,I,KHEP,LHEP,MHEP,NPR,NTRY,WHEP,SHEP
      DOUBLE COMPLEX RHOIN(2,2)
      SAVE RHOIN
      DATA RHOIN/(0.5D0,0.0D0),(0.0D0,0.0D0),
     &           (0.0D0,0.0D0),(0.5D0,0.0D0)/
      IF (IERROR.NE.0) RETURN
      SHEP = NHEP
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.OR.NME(IM).EQ.200.OR.
     &     (NME(IM).GT.10000.AND.NME(IM).LE.20000.AND.
     &     (SYSPIN.OR.THREEB)))) THEN
C---STORE W/H DECAY PRODUCTS
        CALL HWVEQU(10,PHEP(1,KHEP),PDW)
C---BOOST THEM INTO W/H REST FRAME
        CALL HWULOF(PW,PDW(1,1),PDW(1,3))
C---REPLACE THEM BY W/H
        CALL HWVEQU(5,PW,PHEP(1,KHEP))
        WHEP=KHEP
        IF (NME(IM).EQ.100.OR.(NME(IM).GT.10000.AND.
     &      NME(IM).LE.20000.AND.(SYSPIN.OR.THREEB)))IDHW(KHEP)=198
        IF((NME(IM).EQ.100.OR.(NME(IM).GT.10000.AND.
     &      NME(IM).LE.20000.AND.(SYSPIN.OR.THREEB))).AND.(ID.EQ.12))
     &       IDHW(KHEP)=199
        IF (NME(IM).EQ.200)IDHW(KHEP)=206
        IF((NME(IM).EQ.200).AND.(ID.EQ.12))IDHW(KHEP)=207
        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/H MOMENTUM
        NTRY=0
 41     NTRY=NTRY+1
        IF (NTRY.GT.NHEP.OR.WHEP.LE.0.OR.WHEP.GT.NHEP) THEN
          CALL HWWARN('HWDHO4',100)
          GOTO 999
        ENDIF
        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
        IF(NME(IM).EQ.100)CALL HWUDKL(198,PW,VHEP(1,NHEP))
        IF(NME(IM).EQ.200)CALL HWUDKL(206,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)
C--modification to use photos in top decays
        IF(ITOPRD.EQ.1) CALL HWPHTP(WHEP)
C--end of modification
        CALL HWBGEN
        IF (IERROR.NE.0) RETURN
      ELSE
C Do parton showers
        EMSCA=PHEP(5,IHEP)
        CALL HWBGEN
        IF (IERROR.NE.0) RETURN
C--special for gauge boson decay modes of gauginos and four body higgs
C--call routine to add decay products and generate parton shower
        IF(NME(IM).GT.20000.AND.NME(IM).LT.30000) THEN
          CALL HWDSM3(-1,IHEP,MHEP,SHEP,0,NME(IM)-20000,RHOIN,
     &       ISNHEP(IHEP))
        ELSEIF(NME(IM).GT.40000.AND.NME(IM).LT.50000) THEN
          CALL HWDSM4(2,IHEP,MHEP,SHEP,NME(IM)-40000)
        ENDIF
        IF (IERROR.NE.0) RETURN
      ENDIF
 999  RETURN
      END
CDECK  ID>, HWDHO5.
*CMZ :-        -17/10/01  10:19:15  by  Peter Richardson
*-- Author :    Ian Knowles & Bryan Webber
C-----------------------------------------------------------------------
      SUBROUTINE HWDHO5(MHEP,LHEP,CLSAVE)
C-----------------------------------------------------------------------
C   Subroutine to perform the fifth part of the heavy object decays
C   IE sort out RPV colour connections
C   was part of HWDHOB
C-----------------------------------------------------------------------
      INCLUDE 'HERWIG65.INC'
      INTEGER ID,LHEP,MHEP,IDM,IDM2,THEP,CLSAVE(2)
      IF (IERROR.NE.0) RETURN
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
      END
CDECK  ID>, HWDHO6.
*CMZ :-        -17/10/01  10:19:15  by  Peter Richardson
*-- Author :    Ian Knowles & Bryan Webber
C-----------------------------------------------------------------------
      SUBROUTINE HWDHO6
C-----------------------------------------------------------------------
C   Subroutine to perform the final part of the heavy object decays
C   IE sort out any colour connection problems
C-----------------------------------------------------------------------
      INCLUDE 'HERWIG65.INC'
      INTEGER IHEP,IM,JHEP,ISM,JCM
      IF (IERROR.NE.0) RETURN
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
      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 'HERWIG65.INC'
      COMMON/FFS/TB,BT
      COMMON/SFF/IT1,IB1,IT2,IB2
      DOUBLE PRECISION TB,BT
      INTEGER IT1,IB1,IT2,IB2
      DOUBLE PRECISION GAMHPM
      DOUBLE PRECISION HWULDO,HWRGEN,XS,XB,EMWSQ,GMWSQ,EMLIM,PW(4),
     & EMTST,X1,X2,X3,TEST,HWDWWT,HWDHWT,HWDPWT
      INTEGER IST(3),I,IHEP,IM,ID,IDQ,IQ,IS,J,IDS
      EXTERNAL HWRGEN,HWDWWT,HWDHWT,HWDPWT,HWULDO
      SAVE IST
      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) THEN
        CALL HWWARN('HWDHVY',100)
        GOTO 999
      ENDIF
      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)
          GOTO 999
        ENDIF
C Label constituents
        IF (NHEP+5.GT.NMXHEP) THEN
          CALL HWWARN('HWDHVY',102)
          GOTO 999
        ENDIF
        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 spectator mass
C--BW fix 13/07/10: give diquarks extra mass in heavy baryon decays
        IDS=IDHW(IS)
        IF (IDS.GT.108.AND.IDS.LT.121) THEN
           XS=(RMASS(IDS)+DQXTRA)/PHEP(5,IHEP)
        ELSE
           XS=RMASS(IDS)/PHEP(5,IHEP)
        ENDIF
        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
        ELSEIF (NME(IM).EQ.200) THEN
C Generate decay momenta using full
C ((V-A)*TB1+(V+A)*CT1)*((V-A)*TB2+(V+A)*CT2)) matrix element
          GAMHPM=RMASS(206)/DKLTM(206)
C sort tan(beta)
          IF((IQ.EQ.  2).OR.(IQ.EQ.  4).OR.
     &       (IQ.EQ.  6).OR.(IQ.EQ.  8).OR.
     &       (IQ.EQ. 10).OR.(IQ.EQ. 12).OR.
     &       (IQ.EQ.122).OR.(IQ.EQ.124).OR.
     &       (IQ.EQ.126).OR.(IQ.EQ.128).OR.
     &       (IQ.EQ.130).OR.(IQ.EQ.132))THEN
            TB=TANB
          ELSE
            TB=1./TANB
          END IF
          IF((IDKPRD(1,IM).EQ.  2).OR.(IDKPRD(1,IM).EQ.  4).OR.
     &       (IDKPRD(1,IM).EQ.  6).OR.(IDKPRD(1,IM).EQ.  8).OR.
     &       (IDKPRD(1,IM).EQ. 10).OR.(IDKPRD(1,IM).EQ. 12).OR.
     &       (IDKPRD(1,IM).EQ.122).OR.(IDKPRD(1,IM).EQ.124).OR.
     &       (IDKPRD(1,IM).EQ.126).OR.(IDKPRD(1,IM).EQ.128).OR.
     &       (IDKPRD(1,IM).EQ.130).OR.(IDKPRD(1,IM).EQ.132))THEN
            BT=TANB
          ELSE
            BT=1./TANB
          END IF
          IT1=IQ
          IB1=IDKPRD(3,IM)
          IT2=IDKPRD(1,IM)
          IB2=IDKPRD(2,IM)
          EMWSQ=RMASS(206)**2
          GMWSQ=(RMASS(206)*GAMHPM)**2
          EMLIM=GMWSQ+(EMWSQ-(PHEP(5,IQ)-PHEP(5,NHEP))**2)**2
  25      CALL HWDTHR(PHEP(1,IQ  ),PHEP(1,NHEP),
     &                PHEP(1,NHEP-2),PHEP(1,NHEP-1),HWDHWT)
          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 25
        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  RETURN
      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 'HERWIG65.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
      SAVE COLCON,FLACON
      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)
        GOTO 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  RETURN
      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 'HERWIG65.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)
      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)
        GOTO 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)
          GOTO 25
        ELSE
          CALL HWWARN('HWDRME',100)
          GOTO 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  RETURN
      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)
      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)
        E2M= 0.0D0
      ENDIF
      IF(E3M.LT.ZERO) THEN
        IF(ABS(E3M/E3S).GT.EPS) CALL HWWARN('HWDRM5',3)
        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,DUMMYA,DUMMYB,DUMMYC)
C-----------------------------------------------------------------------
C     MATRIX ELEMENT SQUARED FOR PHASE SPACE DECAY
C-----------------------------------------------------------------------
      IMPLICIT NONE
      DOUBLE PRECISION HWDPWT,EMSQ,DUMMYA,DUMMYB,DUMMYC
      HWDPWT=1.
      END
CDECK  ID>, HWDSIN.
*CMZ :-        -30/09/02  14:05:28  by  Peter Richardson
*-- Author :    Peter Richardson
C-----------------------------------------------------------------------
      SUBROUTINE HWDSIN(CLSAVE)
C-----------------------------------------------------------------------
C  Subroutine to perform decays including spin correlations
C-----------------------------------------------------------------------
      INCLUDE 'HERWIG65.INC'
      DOUBLE PRECISION PW(5)
      INTEGER IDEC,IP,IS,IHEP,ID,IM,LHEP,MHEP,NPR,KHEP,CLSAVE(2),NTRY,
     &     ID1
      IF(IERROR.NE.0) RETURN
      NTRY = 0
      IDEC = 1
 1    NTRY = NTRY+1
C--search the decay products and decide which one to decay next
      IF(.NOT.DECSPN(IDEC)) THEN
        CALL HWDSI1(IDEC,IP)
      ELSE
        IDEC = JMOSPN(IDEC)
        GOTO 1
      ENDIF
C--first no more particles in this decay to develop so move up chain
      IF(IP.EQ.0) THEN
        IDEC = JMOSPN(IDEC)
C--reached the end of this spin chain go back to HWDHOB
        IF(IDEC.EQ.0) THEN
          NSPN = 0
          RETURN
C--otherwise keep going up the chain
        ELSE
          IF(NTRY.LE.NBTRY) THEN
            GOTO 1
          ELSE
            CALL HWWARN('HWDSIN',100)
            GOTO 999
          ENDIF
        ENDIF
C--special for tau decays call spin correlation in tau decay routine
      ELSEIF(ABS(IDHEP(IDSPN(IP))).EQ.15) THEN
        CALL HWDSI3(IP)
        IF(IERROR.NE.0) RETURN
        GOTO 1
      ENDIF
C--work out where that particle is
      IHEP = IDSPN(IP)
C--if particle has daughters
 10   IF(JDAHEP(1,IHEP).NE.0) THEN
        IF(ISTHEP(IHEP).GE.141.AND.ISTHEP(IHEP).LE.144) THEN
          DO ID1=JDAHEP(1,IHEP),JDAHEP(2,IHEP)
            IF(IDHW(ID1).EQ.ID) IHEP=ID1
          ENDDO
        ELSE
          IHEP = JDAHEP(1,IHEP)
        ENDIF
      ENDIF
      IS=ISTHEP(IHEP)
      ID=IDHW(IHEP)
      NTRY = NTRY+1
      IF(NTRY.GE.NBTRY) THEN
        CALL HWWARN('HWDSIN',101)
        GOTO 999
      ENDIF
      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
        CALL HWDHO1(IHEP,ID,IM,NPR,LHEP,MHEP)
        IF(IERROR.NE.0) RETURN
      ELSE
        GOTO 10
      ENDIF
C--perform the decay including spin correlations
      CALL HWDSI2(IHEP,IM,NPR,MHEP,KHEP,PW)
      IF(IERROR.NE.0) RETURN
C--make the colour connections
      CALL HWDHO3(ID,IM,NPR,MHEP,LHEP,KHEP,CLSAVE)
      IF (IERROR.NE.0) RETURN
C--perform the parton-showers
      CALL HWDHO4(IHEP,ID,IM,NPR,MHEP,LHEP,KHEP,PW)
      IF(IERROR.NE.0) RETURN
C--perform RPV colour connections
      CALL HWDHO5(MHEP,LHEP,CLSAVE)
      IF(IERROR.NE.0) RETURN
C--continue and perform the next decay
      IDEC = IP
      IF(NTRY.LE.NBTRY) THEN
        GOTO 1
      ELSE
        CALL HWWARN('HWDSIN',102)
      ENDIF
 999  RETURN
      END
CDECK  ID>, HWDSI1.
*CMZ :-        -30/09/02  14:05:28  by  Peter Richardson
*-- Author :    Peter Richardson
C-----------------------------------------------------------------------
      SUBROUTINE HWDSI1(IDEC,IP)
C-----------------------------------------------------------------------
C  Subroutine to check a vertex and decide which branch to treat
C-----------------------------------------------------------------------
      INCLUDE 'HERWIG65.INC'
      INTEGER IDEC,I,IPICK(5),IP,HWRINT,P1,P2,P3,P4,P3P,P4P,NPR,P0,P0P,
     &     P1P,P2P,IF1,IF2,P5,P5P
      DOUBLE PRECISION NORM
      DOUBLE COMPLEX RHOLP(2,2),RHOPS(2,2)
      EXTERNAL HWRINT
C--loop over the daughters and decide what to do
      IP = 0
C--if daughters of particle the same issue warning
      IF(JDASPN(1,IDEC).EQ.JDASPN(2,IDEC)) THEN
        CALL HWWARN('HWDSI1',100)
        GOTO 999
      ENDIF
C--loop over the decay products
      DO I=JDASPN(1,IDEC),JDASPN(2,IDEC)
        IF(.NOT.DECSPN(I)) THEN
C--first SM particles other than tau and top and stable particles
          IF(RSTAB(IDHW(IDSPN(I)))
     &    .OR.(IDHW(IDSPN(I)).LE.12.AND.ABS(IDHEP(IDSPN(I))).NE.6)
     &    .OR.(IDHW(IDSPN(I)).GE.121.AND.IDHW(IDSPN(I)).LE.132.AND.
     &          ABS(IDHEP(IDSPN(I))).NE.15)) THEN
             DECSPN(I) = .TRUE.
             RHOSPN(1,1,I) = HALF
             RHOSPN(1,2,I) = ZERO
             RHOSPN(2,1,I) = ZERO
             RHOSPN(2,2,I) = HALF
C--spinless particles
          ELSEIF(RSPIN(IDHW(IDSPN(I))).EQ.ZERO) THEN
             DECSPN(I) = .TRUE.
             RHOSPN(1,1,I) = ONE
             RHOSPN(1,2,I) = ZERO
             RHOSPN(2,1,I) = ZERO
             RHOSPN(2,2,I) = ZERO
          ELSE
C--particle which needs development
            IP = IP+1
            IPICK(IP) = I
          ENDIF
        ENDIF
      ENDDO
C--pick the particle to decay next
      IF(IP.EQ.0) THEN
        IF(JMOSPN(IDEC).EQ.0) RETURN
C--done everything compute the decay matrix and move up
        DECSPN(IDEC) = .TRUE.
        NPR = JDASPN(2,IDEC)-JDASPN(1,IDEC)+1
        DO 20 P0=1,2
        DO 20 P0P=1,2
 20     RHOSPN(P0,P0P,IDEC) = ZERO
C--two body decay
        IF(NPR.EQ.2) THEN
          DO 21 P0 =1,2
          DO 21 P0P=1,2
          DO 21 P1 =1,2
          DO 21 P1P=1,2
          DO 21 P2 =1,2
          DO 21 P2P=1,2
 21       RHOSPN(P0,P0P,IDEC) = RHOSPN(P0,P0P,IDEC)+
     &              MESPN(P0 ,P1 ,P2 ,1,NCFL(IDEC),IDEC)*
     &       DCONJG(MESPN(P0P,P1P,P2P,1,NCFL(IDEC),IDEC))*
     &       RHOSPN(P1,P1P,JDASPN(1,IDEC))*RHOSPN(P2,P2P,JDASPN(2,IDEC))
C--three body decay
        ELSEIF(NPR.EQ.3) THEN
          DO 25 P0 =1,2
          DO 25 P0P=1,2
          DO 25 P1 =1,2
          DO 25 P1P=1,2
          DO 25 P2 =1,2
          DO 25 P2P=1,2
          DO 25 P3 =1,2
          DO 25 P3P=1,2
 25       RHOSPN(P0,P0P,IDEC) = RHOSPN(P0,P0P,IDEC)+
     &           MESPN(P0 ,P1 ,P2 ,P3 ,NCFL(IDEC),IDEC)*
     &    DCONJG(MESPN(P0P,P1P,P2P,P3P,NCFL(IDEC),IDEC))*
     &    RHOSPN(P1,P1P,JDASPN(1,IDEC))*RHOSPN(P2,P2P,JDASPN(1,IDEC)+1)*
     &    RHOSPN(P3,P3P,JDASPN(2,IDEC))
C--higher
        ELSE
          CALL HWWARN('HWDSI1',500)
        ENDIF
C--now normalise this
        NORM = DBLE(RHOSPN(1,1,IDEC))+DBLE(RHOSPN(2,2,IDEC))
        IF(NORM.GT.ZERO) THEN
          NORM = ONE/NORM
          DO 35 P0=1,2
          DO 35 P0P=1,2
 35       RHOSPN(P0,P0P,IDEC) = NORM*RHOSPN(P0,P0P,IDEC)
        ELSE
          CALL HWWARN('HWDSI1',101)
          GOTO 999
        ENDIF
      ELSE
C--pick the particle to be decayed
        IP = IPICK(HWRINT(1,IP))
C--setup the spin density matrix for the decay
C--special for the hard process
        IF(ISTHEP(IDSPN(IDEC)).EQ.120) THEN
          NPR = JDASPN(2,IDEC)-JDASPN(1,IDEC)+1
C--set up the spin density matrices for the incoming partons
C--zero off diagonal elements
          RHOLP(2,1) = ZERO
          RHOLP(1,2) = ZERO
          RHOPS(2,1) = ZERO
          RHOPS(1,2) = ZERO
C--set up for polarized incoming beams in lepton collisons
          IF(IDHW(JMOHEP(1,IDSPN(IDEC))).GE.121.AND.
     &       IDHW(JMOHEP(1,IDSPN(IDEC))).LE.132) THEN
            RHOLP(1,1) = HALF*(ONE+EPOLN(3))
            RHOLP(2,2) = HALF*(ONE-EPOLN(3))
            RHOPS(1,1) = HALF*(ONE-PPOLN(3))
            RHOPS(2,2) = HALF*(ONE+PPOLN(3))
C--otherwise average
          ELSE
            RHOLP(1,1) = HALF
            RHOLP(2,2) = HALF
            RHOPS(1,1) = HALF
            RHOPS(2,2) = HALF
          ENDIF
C--first decay product
          IF(NPR.EQ.2) THEN
           IF(IP.EQ.JDASPN(1,IDEC)) THEN
C--if using first colour flow option
            IF(SPCOPT.EQ.1) THEN
              DO 5 P3 =1,2
              DO 5 P3P=1,2
              RHOSPN(P3,P3P,IP) = ZERO
              DO 5 IF1=1,NCFL(1)
              DO 5 IF2=1,NCFL(1)
              DO 5 P1 =1,2
              DO 5 P1P=1,2
              DO 5 P2 =1,2
              DO 5 P2P=1,2
              DO 5 P4 =1,2
              DO 5 P4P=1,2
 5            RHOSPN(P3,P3P,IP) = RHOSPN(P3,P3P,IP)+SPNCFC(IF1,IF2,1)*
     &               MESPN(P1 ,P2 ,P3 ,P4 ,IF1,1)*
     &        DCONJG(MESPN(P1P,P2P,P3P,P4P,IF2,1))*
     &        RHOLP(P1,P1P)*RHOPS(P2,P2P)*RHOSPN(P4,P4P,IP+1)
C--if using second colour flow option
            ELSEIF(SPCOPT.EQ.2) THEN
              DO 6 P3 =1,2
              DO 6 P3P=1,2
              RHOSPN(P3,P3P,IP) = ZERO
              DO 6 P1 =1,2
              DO 6 P1P=1,2
              DO 6 P2 =1,2
              DO 6 P2P=1,2
              DO 6 P4 =1,2
              DO 6 P4P=1,2
 6            RHOSPN(P3,P3P,IP) = RHOSPN(P3,P3P,IP)
     &                +SPNCFC(NCFL(1),NCFL(1),1)*
     &               MESPN(P1 ,P2 ,P3 ,P4 ,NCFL(1),1)*
     &        DCONJG(MESPN(P1P,P2P,P3P,P4P,NCFL(1),1))*
     &        RHOLP(P1,P1P)*RHOPS(P2,P2P)*RHOSPN(P4,P4P,IP+1)
C--unknown option issue warning
            ELSE
              CALL HWWARN('HWDSI1',501)
            ENDIF
C--second decay product
           ELSE
            IF(SPCOPT.EQ.1) THEN
              DO 10 P4 =1,2
              DO 10 P4P=1,2
              RHOSPN(P4,P4P,IP) = (0.0D0,0.0D0)
              DO 10 IF1=1,NCFL(1)
              DO 10 IF2=1,NCFL(1)
              DO 10 P1 =1,2
              DO 10 P1P=1,2
              DO 10 P2 =1,2
              DO 10 P2P=1,2
              DO 10 P3 =1,2
              DO 10 P3P=1,2
 10           RHOSPN(P4,P4P,IP) = RHOSPN(P4,P4P,IP)+SPNCFC(IF1,IF2,1)*
     &                 MESPN(P1 ,P2 ,P3 ,P4 ,IF1,1)*
     &          DCONJG(MESPN(P1P,P2P,P3P,P4P,IF2,1))*
     &          RHOLP(P1,P1P)*RHOPS(P2,P2P)*RHOSPN(P3,P3P,IP-1)
            ELSEIF(SPCOPT.EQ.2) THEN
              DO 11 P4 =1,2
              DO 11 P4P=1,2
              RHOSPN(P4,P4P,IP) = (0.0D0,0.0D0)
              DO 11 P1 =1,2
              DO 11 P1P=1,2
              DO 11 P2 =1,2
              DO 11 P2P=1,2
              DO 11 P3 =1,2
              DO 11 P3P=1,2
 11           RHOSPN(P4,P4P,IP) = RHOSPN(P4,P4P,IP)
     &                +SPNCFC(NCFL(1),NCFL(1),1)*
     &                 MESPN(P1 ,P2 ,P3 ,P4 ,NCFL(1),1)*
     &          DCONJG(MESPN(P1P,P2P,P3P,P4P,NCFL(1),1))*
     &          RHOLP(P1,P1P)*RHOPS(P2,P2P)*RHOSPN(P3,P3P,IP-1)
            ELSE
              CALL HWWARN('HWDSI1',502)
              GOTO 999
            ENDIF
           ENDIF
C--new for four body gauge boson pair processes
          ELSEIF(NPR.EQ.4) THEN
C--first particle
           IF(IP.EQ.JDASPN(1,IDEC)) THEN
             DO 41 P1 =1,2
             DO 41 P1P=1,2
             RHOSPN(P1,P1P,IP) = (0.0D0,0.0D0)
             DO 41 P3 =1,2
             DO 41 P3P=1,2
             DO 41 P5 =1,2
             DO 41 P5P=1,2
 41          RHOSPN(P1,P1P,IP) = RHOSPN(P1,P1P,IP)+
     &       MESPN(P5,P1,P3,1,1,1)*DCONJG(MESPN(P5P,P1P,P3P,1,1,1))*
     &       RHOSPN(P1,P1P,JDASPN(1,IDEC)+1)*
     &       RHOSPN(P3,P3P,JDASPN(1,IDEC)+2)*
     &       RHOSPN(P3,P3P,JDASPN(2,IDEC))
C--second particle
           ELSEIF(IP.EQ.JDASPN(1,IDEC)+1) THEN
             DO 42 P1 =1,2
             DO 42 P1P=1,2
             RHOSPN(P1,P1P,IP) = (0.0D0,0.0D0)
             DO 42 P3 =1,2
             DO 42 P3P=1,2
             DO 42 P5 =1,2
             DO 42 P5P=1,2
 42          RHOSPN(P1,P1P,IP) = RHOSPN(P1,P1P,IP)+
     &       MESPN(P5,P1,P3,1,1,1)*DCONJG(MESPN(P5P,P1P,P3P,1,1,1))*
     &       RHOSPN(P1,P1P,JDASPN(1,IDEC))*
     &       RHOSPN(P3,P3P,JDASPN(1,IDEC)+2)*
     &       RHOSPN(P3,P3P,JDASPN(2,IDEC))
C--third particle
           ELSEIF(IP.EQ.JDASPN(1,IDEC)+2) THEN
             DO 43 P3 =1,2
             DO 43 P3P=1,2
             RHOSPN(P3,P3P,IP) = (0.0D0,0.0D0)
             DO 43 P1 =1,2
             DO 43 P1P=1,2
             DO 43 P5 =1,2
             DO 43 P5P=1,2
 43          RHOSPN(P3,P3P,IP) = RHOSPN(P3,P3P,IP)+
     &       MESPN(P5,P1,P3,1,1,1)*DCONJG(MESPN(P5P,P1P,P3P,1,1,1))*
     &       RHOSPN(P1,P1P,JDASPN(1,IDEC))*
     &       RHOSPN(P1,P1P,JDASPN(1,IDEC)+1)*
     &       RHOSPN(P3,P3P,JDASPN(2,IDEC))
C--fourth particle
           ELSEIF(IP.EQ.JDASPN(2,IDEC)) THEN
             DO 44 P3 =1,2
             DO 44 P3P=1,2
             RHOSPN(P3,P3P,IP) = (0.0D0,0.0D0)
             DO 44 P1 =1,2
             DO 44 P1P=1,2
             DO 44 P5 =1,2
             DO 44 P5P=1,2
 44          RHOSPN(P3,P3P,IP) = RHOSPN(P3,P3P,IP)+
     &       MESPN(P5,P1,P3,1,1,1)*DCONJG(MESPN(P5P,P1P,P3P,1,1,1))*
     &       RHOSPN(P1,P1P,JDASPN(1,IDEC))*
     &       RHOSPN(P1,P1P,JDASPN(1,IDEC)+1)*
     &       RHOSPN(P3,P3P,JDASPN(1,IDEC)+2)
C--unrecognized issue warning
           ELSE
             CALL HWWARN('HWDSI1',509)
             GOTO 999
           ENDIF
C--unrecognized issue warning
          ELSE
            CALL HWWARN('HWDSI1',508)
            GOTO 999
          ENDIF
        ELSE
          NPR = JDASPN(2,IDEC)-JDASPN(1,IDEC)+1
          DO 50 P1 =1,2
          DO 50 P1P=1,2
 50       RHOSPN(P1,P1P,IP) = (0.0D0,0.0D0)
C--set-up matrix for 2-body decay
          IF(NPR.EQ.2) THEN
            IF(NCFL(IDEC).NE.1) CALL HWWARN('HWDSI1',503)
            IF(IP.EQ.JDASPN(1,IDEC)) THEN
              DO 60 P0 =1,2
              DO 60 P0P=1,2
              DO 60 P1 =1,2
              DO 60 P1P=1,2
              DO 60 P2 =1,2
              DO 60 P2P=1,2
 60           RHOSPN(P1,P1P,IP) = RHOSPN(P1,P1P,IP)+RHOSPN(P0,P0P,IDEC)*
     &               MESPN(P0 ,P1 ,P2 ,1,1,IDEC)*
     &        DCONJG(MESPN(P0P,P1P,P2P,1,1,IDEC))*
     &        RHOSPN(P2,P2P,JDASPN(2,IDEC))
            ELSE
              DO 70 P0 =1,2
              DO 70 P0P=1,2
              DO 70 P1 =1,2
              DO 70 P1P=1,2
              DO 70 P2 =1,2
              DO 70 P2P=1,2
 70           RHOSPN(P2,P2P,IP) = RHOSPN(P2,P2P,IP)+RHOSPN(P0,P0P,IDEC)*
     &               MESPN(P0 ,P1 ,P2 ,1,1,IDEC)*
     &        DCONJG(MESPN(P0P,P1P,P2P,1,1,IDEC))*
     &        RHOSPN(P1,P1P,JDASPN(1,IDEC))
            ENDIF
C--set-up matrix for 3-body decay
          ELSEIF(NPR.EQ.3) THEN
            IF(SPCOPT.NE.2.AND.NCFL(IDEC).NE.1)
     &        CALL HWWARN('HWDSI1',504)
C--first particle
            IF(IP.EQ.JDASPN(1,IDEC)) THEN
              DO 100 P0 =1,2
              DO 100 P0P=1,2
              DO 100 P1 =1,2
              DO 100 P1P=1,2
              DO 100 P2 =1,2
              DO 100 P2P=1,2
              DO 100 P3 =1,2
              DO 100 P3P=1,2
 100          RHOSPN(P1,P1P,IP) = RHOSPN(P1,P1P,IP)+RHOSPN(P0,P0P,IDEC)*
     &               MESPN(P0 ,P1 ,P2 ,P3 ,NCFL(IDEC),IDEC)*
     &        DCONJG(MESPN(P0P,P1P,P2P,P3P,NCFL(IDEC),IDEC))*
     &        RHOSPN(P2,P2P,JDASPN(1,IDEC)+1)*
     &        RHOSPN(P3,P3P,JDASPN(2,IDEC))
C--second particle
            ELSEIF(IP.EQ.JDASPN(1,IDEC)+1) THEN
              DO 105 P0 =1,2
              DO 105 P0P=1,2
              DO 105 P1 =1,2
              DO 105 P1P=1,2
              DO 105 P2 =1,2
              DO 105 P2P=1,2
              DO 105 P3 =1,2
              DO 105 P3P=1,2
 105          RHOSPN(P2,P2P,IP) = RHOSPN(P2,P2P,IP)+RHOSPN(P0,P0P,IDEC)*
     &               MESPN(P0 ,P1 ,P2 ,P3 ,NCFL(IDEC),IDEC)*
     &        DCONJG(MESPN(P0P,P1P,P2P,P3P,NCFL(IDEC),IDEC))*
     &        RHOSPN(P1,P1P,JDASPN(1,IDEC))*
     &        RHOSPN(P3,P3P,JDASPN(2,IDEC))
C--third particle
            ELSEIF(IP.EQ.JDASPN(2,IDEC)) THEN
              DO 110 P0 =1,2
              DO 110 P0P=1,2
              DO 110 P1 =1,2
              DO 110 P1P=1,2
              DO 110 P2 =1,2
              DO 110 P2P=1,2
              DO 110 P3 =1,2
              DO 110 P3P=1,2
 110          RHOSPN(P3,P3P,IP) = RHOSPN(P3,P3P,IP)+RHOSPN(P0,P0P,IDEC)*
     &               MESPN(P0 ,P1 ,P2 ,P3 ,NCFL(IDEC),IDEC)*
     &        DCONJG(MESPN(P0P,P1P,P2P,P3P,NCFL(IDEC),IDEC))*
     &        RHOSPN(P1,P1P,JDASPN(1,IDEC))*
     &        RHOSPN(P2,P2P,JDASPN(1,IDEC)+1)
C--unrecognized
            ELSE
              CALL HWWARN('HWDSI1',102)
              GOTO 999
            ENDIF
          ELSEIF(NPR.EQ.4) THEN
C--first particle
            IF(IP.EQ.JDASPN(1,IDEC)) THEN
              DO 151 P1 =1,2
              DO 151 P1P=1,2
              RHOSPN(P1,P1P,IP) = (0.0D0,0.0D0)
              DO 151 P2 =1,2
              DO 151 P2P=1,2
              DO 151 P3 =1,2
              DO 151 P3P=1,2
              DO 151 P4 =1,2
              DO 151 P4P=1,2
 151          RHOSPN(P1,P1P,IP) = RHOSPN(P1,P1P,IP)+
     &                  MESPN(P1 ,P2 ,P3 ,P4 ,1,1)*
     &           DCONJG(MESPN(P1P,P2P,P3P,P4P,1,1))*
     &           RHOSPN(P2,P2P,JDASPN(1,IDEC)+1)*
     &           RHOSPN(P3,P3P,JDASPN(1,IDEC)+2)*
     &           RHOSPN(P4,P4P,JDASPN(2,IDEC))
C--second particle
            ELSEIF(IP.EQ.JDASPN(1,IDEC)+1) THEN
              DO 152 P2 =1,2
              DO 152 P2P=1,2
              RHOSPN(P2,P2P,IP) = (0.0D0,0.0D0)
              DO 152 P1 =1,2
              DO 152 P1P=1,2
              DO 152 P3 =1,2
              DO 152 P3P=1,2
              DO 152 P4 =1,2
              DO 152 P4P=1,2
 152             RHOSPN(P2,P2P,IP) = RHOSPN(P2,P2P,IP)+
     &                  MESPN(P1 ,P2 ,P3 ,P4 ,1,1)*
     &           DCONJG(MESPN(P1P,P2P,P3P,P4P,1,1))*
     &           RHOSPN(P1,P1P,JDASPN(1,IDEC))*
     &           RHOSPN(P3,P3P,JDASPN(1,IDEC)+2)*
     &           RHOSPN(P4,P4P,JDASPN(2,IDEC))
C--third particle
            ELSEIF(IP.EQ.JDASPN(1,IDEC)+2) THEN
              DO 153 P3 =1,2
              DO 153 P3P=1,2
              RHOSPN(P3,P3P,IP) = (0.0D0,0.0D0)
              DO 153 P1 =1,2
              DO 153 P1P=1,2
              DO 153 P2 =1,2
              DO 153 P2P=1,2
              DO 153 P4 =1,2
              DO 153 P4P=1,2
 153          RHOSPN(P3,P3P,IP) = RHOSPN(P3,P3P,IP)+
     &                  MESPN(P1 ,P2 ,P3 ,P4 ,1,1)*
     &           DCONJG(MESPN(P1P,P2P,P3P,P4P,1,1))*
     &           RHOSPN(P1,P1P,JDASPN(1,IDEC))*
     &           RHOSPN(P2,P2P,JDASPN(1,IDEC)+1)*
     &           RHOSPN(P4,P4P,JDASPN(2,IDEC))
C--fourth particle
            ELSEIF(IP.EQ.JDASPN(2,IDEC)) THEN
              DO 154 P4 =1,2
              DO 154 P4P=1,2
              RHOSPN(P4,P4P,IP) = (0.0D0,0.0D0)
              DO 154 P1 =1,2
              DO 154 P1P=1,2
              DO 154 P2 =1,2
              DO 154 P2P=1,2
              DO 154 P3 =1,2
              DO 154 P3P=1,2
 154          RHOSPN(P4,P4P,IP) = RHOSPN(P4,P4P,IP)+
     &                  MESPN(P1 ,P2 ,P3 ,P4 ,1,1)*
     &           DCONJG(MESPN(P1P,P2P,P3P,P4P,1,1))*
     &           RHOSPN(P1,P1P,JDASPN(1,IDEC))*
     &           RHOSPN(P2,P2P,JDASPN(1,IDEC)+1)*
     &           RHOSPN(P3,P3P,JDASPN(1,IDEC)+2)
            ELSE
              CALL HWWARN('HWDSI1',505)
            ENDIF
          ELSE
            CALL HWWARN('HWDSI1',506)
          ENDIF
        ENDIF
C--normalise the spin density matrix
        NORM = DBLE(RHOSPN(1,1,IP))+DBLE(RHOSPN(2,2,IP))
        IF(NORM.GT.ZERO) THEN
          NORM = ONE/NORM
          DO 15 P3=1,2
          DO 15 P3P=1,2
 15       RHOSPN(P3,P3P,IP) = NORM*RHOSPN(P3,P3P,IP)
        ELSE
          CALL HWWARN('HWDSI1',107)
          GOTO 999
        ENDIF
      ENDIF
 999  RETURN
      END
CDECK  ID>, HWDSI2.
*CMZ :-        -30/09/02  14:05:28  by  Peter Richardson
*-- Author :    Peter Richardson
C-----------------------------------------------------------------------
      SUBROUTINE HWDSI2(IHEP,IM,NPR,MHEP,KHEP,PW)
C-----------------------------------------------------------------------
C   Subroutine to perform the second part of the heavy object decays
C   IE generate the kinematics for the decay
C   including spin correlations
C   was part of HWDHOB
C-----------------------------------------------------------------------
      INCLUDE 'HERWIG65.INC'
      DOUBLE PRECISION HWRGEN,PW(5),HWDPWT,HWDWWT,PCM,HWUPCM
      INTEGER IHEP,IM,KHEP,MHEP,NPR,ISN,RHEP
      EXTERNAL HWRGEN,HWDPWT,HWDWWT,HWUPCM
      IF (IERROR.NE.0) RETURN
      ISN = ISNHEP(IHEP)
      IF (NPR.EQ.2) THEN
C Two body decay: LHEP -> MHEP + NHEP
        IF(NME(IM).GT.20000.AND.NME(IM).LT.30000) THEN
C--generate a two body decay to a gauge boson as a three body decay
          CALL HWDSM3(2,IHEP,MHEP,NHEP,0,NME(IM)-20000,
     &                 RHOSPN(1,1,ISN),ISN)
C--two body decay
        ELSEIF(NME(IM).GT.30000.AND.NME(IM).LT.40000) THEN
          CALL HWDSM2(IHEP,MHEP,NHEP,NME(IM)-30000,
     &          RHOSPN(1,1,ISN),ISN)
C--otherwise issue warning
C--change by PR 9/30/02 to issue non-terminal warning and continue
        ELSE
          CALL HWWARN('HWDSI2',1)
          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.)
          DECSPN(ISN) = .TRUE.
          IF(RSPIN(IDHW(IHEP)).EQ.ZERO) THEN
            RHOSPN(1,1,ISN) = ONE
            RHOSPN(1,2,ISN) = ZERO
            RHOSPN(2,1,ISN) = ZERO
            RHOSPN(2,2,ISN) = ZERO
          ELSE
            RHOSPN(1,1,ISN) = HALF
            RHOSPN(1,2,ISN) = ZERO
            RHOSPN(2,1,ISN) = ZERO
            RHOSPN(2,2,ISN) = HALF
          ENDIF
        ENDIF
      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
C--if old codes issue warning
        IF (NME(IM).EQ.100.OR.NME(IM).EQ.200.OR.NME(IM).EQ.300) THEN
          CALL HWWARN('HWDSI2',502)
C--three body spin matrix element
        ELSEIF(NME(IM).GE.10000.AND.NME(IM).LT.20000) THEN
          CALL HWDSM3(3,IHEP,MHEP,KHEP,NHEP,NME(IM)-10000,
     &            RHOSPN(1,1,ISN),ISN)
C--special for top decay
          IF(ABS(IDHEP(IHEP)).EQ.6) THEN
            CALL HWVSUM(4,PHEP(1,KHEP),PHEP(1,MHEP),PW)
            CALL HWUMAS(PW)
          ENDIF
C--unknown issue warning
        ELSE
          CALL HWWARN('HWDSI2',2)
C Three body phase space decay
          CALL HWDTHR(PHEP(1,IHEP),PHEP(1,MHEP),
     &                PHEP(1,KHEP),PHEP(1,NHEP),HWDPWT)
          CALL HWVEQU(4,VHEP(1,KHEP),VHEP(1,MHEP))
          DECSPN(ISN) = .TRUE.
          IF(RSPIN(IDHW(IHEP)).EQ.ZERO) THEN
            RHOSPN(1,1,ISN) = ONE
            RHOSPN(1,2,ISN) = ZERO
            RHOSPN(2,1,ISN) = ZERO
            RHOSPN(2,2,ISN) = ZERO
          ELSE
            RHOSPN(1,1,ISN) = HALF
            RHOSPN(1,2,ISN) = ZERO
            RHOSPN(2,1,ISN) = ZERO
            RHOSPN(2,2,ISN) = HALF
          ENDIF
        ENDIF
      ELSEIF(NPR.EQ.4) THEN
        CALL HWWARN('HWDSI2',3)
C Four body decay: LHEP -> KHEP + RHEP + MHEP + NHEP
        KHEP = MHEP
        RHEP = MHEP+1
        MHEP = MHEP+2
        ISTHEP(NHEP) = 114
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))
        IF(IERROR.NE.0) RETURN
        CALL HWVEQU(4,VHEP(1,KHEP),VHEP(1,RHEP))
        CALL HWVEQU(4,VHEP(1,KHEP),VHEP(1,MHEP))
        DECSPN(ISN) = .TRUE.
        IF(RSPIN(IDHW(IHEP)).EQ.ZERO) THEN
          RHOSPN(1,1,ISN) = ONE
          RHOSPN(1,2,ISN) = ZERO
          RHOSPN(2,1,ISN) = ZERO
          RHOSPN(2,2,ISN) = ZERO
        ELSE
          RHOSPN(1,1,ISN) = HALF
          RHOSPN(1,2,ISN) = ZERO
          RHOSPN(2,1,ISN) = ZERO
          RHOSPN(2,2,ISN) = HALF
        ENDIF
      ELSE
        CALL HWWARN('HWDSI2',100)
      ENDIF
      END
CDECK  ID>, HWDSI3.
*CMZ :-        -30/09/02  14:05:28  by  Peter Richardson
*-- Author :    Peter Richardson
C-----------------------------------------------------------------------
      SUBROUTINE HWDSI3(IP)
C-----------------------------------------------------------------------
C     Subroutine to handle spin correlations in tau decays
C     averages spin if not using TAUOLA
C     if using TAUOLA selects the spin and uses TAUOLA to perform the
C     decay
C-----------------------------------------------------------------------
      INCLUDE 'HERWIG65.INC'
      INTEGER IP,IHEP,ID1,ID,NTRY
      DOUBLE PRECISION PPOL,HWRGEN,POL
      EXTERNAL HWRGEN
C--if HERWIG is performing tau decays average over spins and return
C--spin averaged tau decay will be done later
      IF(TAUDEC.EQ.'HERWIG') THEN
        DECSPN(IP) = .TRUE.
        RHOSPN(1,1,IP) = HALF
        RHOSPN(2,1,IP) = ZERO
        RHOSPN(1,2,IP) = ZERO
        RHOSPN(2,2,IP) = HALF
C--if using tauola select the polarization for the decay
      ELSEIF(TAUDEC.EQ.'TAUOLA') THEN
C--work out where that particle is
        IHEP = IDSPN(IP)
        NTRY = 0
 10     ID   = IDHW(IHEP)
        IF(JDAHEP(1,IHEP).NE.0) THEN
          IF(ISTHEP(IHEP).GE.141.AND.ISTHEP(IHEP).LE.144) THEN
            DO ID1=JDAHEP(1,IHEP),JDAHEP(2,IHEP)
              IF(IDHW(ID1).EQ.ID) IHEP=ID1
            ENDDO
          ELSE
            IHEP = JDAHEP(1,IHEP)
          ENDIF
          NTRY = NTRY+1
          IF(NTRY.LT.NBTRY) THEN
            GOTO 10
          ELSE
            CALL HWWARN('HWDSI3',100)
            GOTO 999
          ENDIF
        ENDIF
C--select the tau polarization
        PPOL = DBLE(RHOSPN(1,1,IP))
        IF(PPOL.GE.HWRGEN(0)) THEN
          POL = 1.0D0
          RHOSPN(1,1,IP) =  ONE
          RHOSPN(2,1,IP) = ZERO
          RHOSPN(1,2,IP) = ZERO
          RHOSPN(2,2,IP) = ZERO
        ELSE
          POL =-1.0D0
          RHOSPN(1,1,IP) = ZERO
          RHOSPN(2,1,IP) = ZERO
          RHOSPN(1,2,IP) = ZERO
          RHOSPN(2,2,IP) =  ONE
        ENDIF
C--decay the particle
        CALL HWDTAU(1,IHEP,POL)
        DECSPN(IP) = .TRUE.
      ELSE
        CALL HWWARN('HWDSI3',500)
      ENDIF
 999  RETURN
      END
CDECK  ID>, HWDSM2.
*CMZ :-        -09/04/02  13:46:07  by  Peter Richardson
*-- Author :    Peter Richardson
C-----------------------------------------------------------------------
      SUBROUTINE HWDSM2(ID,IOUT1,IOUT2,IMODE,RHOIN,IDSPIN)
C-----------------------------------------------------------------------
C  Subroutine to calculate the two body matrix element for spin
C  correlations
C-----------------------------------------------------------------------
      INCLUDE 'HERWIG65.INC'
      INTEGER IOUT1,IOUT2,IMODE,IDSPIN,ID,I,J,IDP(3),P0,P1,P2,O(2),P0P,
     &     NTRY
      DOUBLE PRECISION XMASS,PLAB,PRW,PCM,PREF(5),P(5,3),PM(5,3),PCMA,
     &     HWUPCM,MA(3),MA2(3),HWULDO,PP,HWVDOT,N(3),EPS,PRE,PHS,A(2),
     &     WGT,WTMAX,HWRGEN
      DOUBLE COMPLEX RHOIN(2,2),S,D,ME(2,2,2),F1(2,2,8),F0(2,2,8),
     &     F2M(2,2,8),F1M(2,2,8),F1F(2,2,8),F2(2,2,8,8),F0B(2,2,8,8)
      COMMON/HWHEWP/XMASS(10),PLAB(5,10),PRW(5,2),PCM(5,10)
      COMMON/HWHEWS/S(8,8,2),D(8,8)
      PARAMETER(EPS=1D-20)
      EXTERNAL HWUPCM,HWULDO,HWVDOT,HWRGEN
      SAVE O,PREF
      DATA PREF/1.0D0,0.0D0,0.0D0,1.0D0,0.0D0/
      DATA O/2,1/
C--first setup if this is the start of a new spin chain
      IF(NSPN.EQ.0) THEN
C--zero the elements of the array
        CALL HWVZRI(  NMXHEP,ISNHEP)
        CALL HWVZRI(  NMXSPN,JMOSPN)
        CALL HWVZRI(2*NMXSPN,JDASPN)
        CALL HWVZRI(  NMXSPN, IDSPN)
        NSPN = NSPN+1
        JMOSPN(NSPN) = 0
        IDSPN (NSPN) = ID
        DECSPN(NSPN) = .FALSE.
        IF(RSPIN(IDHW(ID)).EQ.ZERO) THEN
          RHOSPN(1,1,NSPN) = ONE
          RHOSPN(2,1,NSPN) = ZERO
          RHOSPN(1,2,NSPN) = ZERO
          RHOSPN(2,2,NSPN) = ZERO
        ELSE
          RHOSPN(1,1,NSPN) = HALF
          RHOSPN(2,1,NSPN) = ZERO
          RHOSPN(1,2,NSPN) = ZERO
          RHOSPN(2,2,NSPN) = HALF
        ENDIF
        ISNHEP(ID)    = NSPN
      ENDIF
C--MA is mass for this decay (OFF-SHELL)
C--generate the momenta for a two body decay
      P(5,1) = PHEP(5,   ID)
      P(5,2) = PHEP(5,IOUT1)
      P(5,3) = PHEP(5,IOUT2)
      IDP(1) = IDHW(ID)
      IDP(2) = IDHW(IOUT1)
      IDP(3) = IDHW(IOUT2)
      DO 1 I=1,3
      MA(I)  = P(5,I)
 1    MA2(I) = MA(I)**2
      PCMA   = HWUPCM(P(5,1),P(5,2),P(5,3))
C--setup the couplings
      DO 2 I=1,2
 2    A(I) = A2MODE(I,IMODE)
C--phase space factor
      PHS = PCMA/MA2(1)/8.0D0/PIFAC
C--maximum weight
      WTMAX = WT2MAX(IMODE)
      NTRY = 0
 1000 NTRY = NTRY+1
      CALL HWVEQU(5,PHEP(1,ID),P(1,1))
      CALL HWDTWO(P(1,1),P(1,2),P(1,3),PCMA,2.0D0,.TRUE.)
      DO 3 I=1,3
C--compute the references vectors
C--not important if SM particle which can't have spin measured
C--ie anything other the top and tau
C--also not important if particle is approx massless
C--first the SM particles other than top and tau
      IF(IDP(I).LT.400.AND.(IDP(I).NE.6.AND.IDP(I).NE.12
     &                .AND.IDP(I).NE.125.AND.IDP(I).NE.131)) THEN
        CALL HWVEQU(5,PREF,PLAB(1,I+3))
C--all other particles
      ELSE
        PP = SQRT(HWVDOT(3,P(1,I),P(1,I)))
        CALL HWVSCA(3,ONE/PP,P(1,I),N)
        PLAB(4,I+3) = HALF*(P(4,I)-PP)
        PP = HALF*(PP-MA(I)-PP**2/(MA(I)+P(4,I)))
        CALL HWVSCA(3,PP,N,PLAB(1,I+3))
        CALL HWUMAS(PLAB(1,I+3))
        PP = HWVDOT(3,PLAB(1,I+3),PLAB(1,I+3))
C--fix to avoid problems if approx massless due to energy
        IF(PP.LT.EPS) CALL HWVEQU(5,PREF,PLAB(1,I+3))
      ENDIF
C--now the massless vectors
      PP = HALF*P(5,I)**2/HWULDO(PLAB(1,I+3),P(1,I))
      DO 4 J=1,4
 4    PLAB(J,I) = P(J,I)-PP*PLAB(J,I+3)
 3    CALL HWUMAS(PLAB(1,I))
C--change order of momenta for call to HE code
      DO 5 I=1,3
      PM(1,I) = P(3,I)
      PM(2,I) = P(1,I)
      PM(3,I) = P(2,I)
      PM(4,I) = P(4,I)
 5    PM(5,I) = P(5,I)
      DO 6 I=1,6
      PCM(1,I)=PLAB(3,I)
      PCM(2,I)=PLAB(1,I)
      PCM(3,I)=PLAB(2,I)
      PCM(4,I)=PLAB(4,I)
 6    PCM(5,I)=PLAB(5,I)
C--compute the S functions
      CALL HWHEW2(6,PCM(1,1),S(1,1,2),S(1,1,1),D)
      DO 7 I=1,6
      DO 7 J=1,6
      S(I,J,2) = -S(I,J,2)
 7    D(I,J)   = TWO*D(I,J)
C--now compute the F functions needed
      CALL HWH2F2(6,F1 ,5,PM(1,2), MA(2))
      CALL HWH2F2(6,F0 ,4,PM(1,1), MA(1))
      CALL HWH2F2(6,F1M,5,PM(1,2),-MA(2))
      CALL HWH2F2(6,F2M,6,PM(1,3),-MA(3))
      CALL HWH2F1(6,F1F,5,PM(1,2), MA(2))
      CALL HWH2F3(6,F2   ,PM(1,3),ZERO  )
      CALL HWH2F3(6,F0B  ,PM(1,1),ZERO  )
C--now compute the diagrams
C--fermion --> fermion scalar
      IF(I2DRTP(IMODE).EQ.1) THEN
        PRE = HWULDO(PM(1,1),PCM(1,4))*HWULDO(PM(1,2),PCM(1,5))
        PRE = HALF/SQRT(PRE)
        DO 10 P0=1,2
        DO 10 P1=1,2
        ME(P0,P1,2) = (0.0D0,0.0D0)
 10     ME(P0,P1,1) = PRE*( A(O(P1))*S(5,2,O(P1))*F0(  P1 ,O(P0),2)
     &                     +A(  P1 )*MA(2)*       F0(O(P1),O(P0),5))
C--fermion --> scalar fermion   diagrams
      ELSEIF(I2DRTP(IMODE).EQ.2) THEN
        PRE = HWULDO(PM(1,1),PCM(1,4))*HWULDO(PM(1,3),PCM(1,6))
        PRE = HALF/SQRT(PRE)
        DO 20 P0=1,2
        DO 20 P2=1,2
        ME(P0,2,P2) = (0.0D0,0.0D0)
 20     ME(P0,1,P2) = PRE*( A(O(P2))*S(6,3,O(P2))*F0(  P2 ,O(P0),3)
     &                     +A(  P2 )*MA(3)*       F0(O(P2),O(P0),6))
C--fermion --> scalar antifermion
      ELSEIF(I2DRTP(IMODE).EQ.3) THEN
        PRE = HWULDO(PM(1,1),PCM(1,4))*HWULDO(PM(1,3),PCM(1,6))
        PRE =-HALF/SQRT(PRE)
        DO 30 P0=1,2
        DO 30 P2=1,2
        ME(P0,2,P2) = (0.0D0,0.0D0)
 30     ME(P0,1,P2) = PRE*( A(  P0 )*S(4,1,P0)*F2M(O(P0),O(P2),1)
     &                     -A(O(P0))*MA(1)    *F2M(  P0 ,O(P2),4))
C--fermion --> fermion gauge boson
      ELSEIF(I2DRTP(IMODE).EQ.4) THEN
        PRE = HWULDO(PM(1,1),PCM(1,4))*HWULDO(PM(1,2),PCM(1,5))*
     &        HWULDO(PM(1,3),PCM(1,6))
        PRE = HALF/SQRT(PRE)
        DO 40 P0=1,2
        DO 40 P1=1,2
        ME(P0,P1,1) =-PRE*A(1)*F1F(O(P1),2,3)*S(3,6,2)*F0(1,O(P0),3)
 40     ME(P0,P1,2) = PRE*     F1F(O(P1),1,3)*S(3,6,1)*F0(2,O(P0),3)
C--scalar  --> fermion antifermion
      ELSEIF(I2DRTP(IMODE).EQ.5) THEN
        PRE = HWULDO(PM(1,2),PCM(1,5))*HWULDO(PM(1,3),PCM(1,6))
        PRE =-HALF/SQRT(PRE)
        DO 50 P1=1,2
        DO 50 P2=1,2
        ME(2,P1,P2) = (0.0D0,0.0D0)
 50     ME(1,P1,P2) = PRE*( A(O(P1))*S(5,2,O(P1))*F2M(  P1 ,O(P2),2)
     &                     +A(  P1 )*MA(2)*       F2M(O(P1),O(P2),5))
C--scalar --> fermion fermion
      ELSEIF(I2DRTP(IMODE).EQ.6) THEN
        PRE = HWULDO(PM(1,2),PCM(1,5))*HWULDO(PM(1,3),PCM(1,6))
        PRE = HALF/SQRT(PRE)
        DO 60 P1=1,2
        DO 60 P2=1,2
        ME(2,P1,P2) = (0.0D0,0.0D0)
 60     ME(1,P1,P2) = PRE*( A(O(P2))*S(6,3,O(P2))*F1M(  P2 ,P1,3)
     &                     +A(  P2 )*MA(3)*       F1M(O(P2),P1,6))
C--fermion --> fermion pion
      ELSEIF(I2DRTP(IMODE).EQ.7) THEN
        PRE = HWULDO(PM(1,1),PCM(1,4))*HWULDO(PM(1,2),PCM(1,5))
        PRE = 0.25D0/SQRT(PRE)/RMASS(198)**2
        DO 70 P0=1,2
        DO 70 P1=1,2
        ME(P0,P1,2) = (0.0D0,0.0D0)
 70     ME(P0,P1,1) =PRE*(
     &              MA(1)*A(O(P0))*( S(5,2,O(P1))*F2(  P1 ,O(P0),2,4)
     &                                     +MA(2)*F2(O(P1),O(P0),5,4))
     &            +A(P0)*S(1,4,P0)*( S(5,2,O(P1))*F2(  P1 ,  P0 ,2,1)
     &                                     +MA(2)*F2(O(P1),  P0 ,5,1)))
C--scalar  --> antifermion fermion
      ELSEIF(I2DRTP(IMODE).EQ.8) THEN
        PRE = HWULDO(PM(1,2),PCM(1,5))*HWULDO(PM(1,3),PCM(1,6))
        PRE =-HALF/SQRT(PRE)
        DO 80 P1=1,2
        DO 80 P2=1,2
        ME(2,P1,P2) = (0.0D0,0.0D0)
 80     ME(1,P1,P2) = PRE*( A(O(P2))*S(6,3,O(P2))*F1M(  P2 ,O(P1),3)
     &                     +A(  P2 )*MA(3)*       F1M(O(P2),O(P1),6))
C--neutralino --> gravitino photon
      ELSEIF(I2DRTP(IMODE).EQ.9) THEN
        PRE = TWO*HWULDO(PM(1,1),PCM(1,4))*HWULDO(PM(1,3),PCM(1,6))
        PRE = TWO/SQRT(PRE)
        DO 90 P1=1,2
        DO 90 P2=1,2
        ME(P1,P2,O(P2)) = (0.0D0,0.0D0)
 90     ME(P1,P2,  P2 ) = PRE*S(2,3,P2)*S(3,6,O(P2))*
     &       S(3,2,P2)*F0(O(P2),P1,2)
C--neutralino --> gravitino scalar
      ELSEIF(I2DRTP(IMODE).EQ.10) THEN
        PRE = TWO*HWULDO(PM(1,1),PCM(1,4))
        PRE = ONE/SQRT(PRE)
        DO 100 P1=1,2
        DO 100 P2=1,2
        ME(P1,P2,2) = (0.0D0,0.0D0)
 100    ME(P1,P2,1) = PRE*F2(P2,1,2,2)*F0(1,O(P1),2)
C--sfermion --> fermion gravitino
      ELSEIF(I2DRTP(IMODE).EQ.11) THEN
        PRE = TWO*HWULDO(PM(1,2),PCM(1,5))
        PRE = ONE/SQRT(PRE)
        DO 110 P1=1,2
        DO 110 P2=1,2
        ME(2,P1,P2) = (0.0D0,0.0D0)
 110    ME(1,P1,P2) = PRE*A(O(P2))*F1M(O(P1),P2,3)*F0B(P2,P2,3,3)
C--antisfermion --> antifermion gravitino
      ELSEIF(I2DRTP(IMODE).EQ.12) THEN
        PRE = TWO*HWULDO(PM(1,2),PCM(1,5))
        PRE = ONE/SQRT(PRE)
        DO 120 P1=1,2
        DO 120 P2=1,2
        ME(2,P1,P2) = (0.0D0,0.0D0)
 120    ME(1,P1,P2) = PRE*A(O(P2))*F0B(P2,P2,3,3)*F1(P2,O(P1),3)
C--scalar --> antifermion antifermion
      ELSEIF(I2DRTP(IMODE).EQ.13) THEN
        PRE = HWULDO(PM(1,2),PCM(1,5))*HWULDO(PM(1,3),PCM(1,6))
        PRE = HALF/SQRT(PRE)
        DO 130 P1=1,2
        DO 130 P2=1,2
        ME(2,P1,P2) = (0.0D0,0.0D0)
 130    ME(1,P1,P2) = PRE*( A(  P1 )*S(5,2,  P1 )*F2M(O(P1),O(P2),2)
     &                     +A(O(P1))*MA(2)       *F2M(  P1 ,O(P2),5))
C--antifermion --> scalar antifermion
      ELSEIF(I2DRTP(IMODE).EQ.14) THEN
        PRE = HWULDO(PM(1,1),PCM(1,4))*HWULDO(PM(1,3),PCM(1,6))
        PRE = HALF/SQRT(PRE)
        DO 140 P0=1,2
        DO 140 P2=1,2
        ME(P0,2,P2) = (0.0D0,0.0D0)
 140    ME(P0,1,P2) = PRE*( A(O(P0))*S(4,1,O(P0))*F2M(  P0 ,O(P2),1)
     &                     -A(  P0 )*MA(1)       *F2M(O(P0),O(P2),4))
C--unrecognized type of diagram
      ELSE
        CALL HWWARN('HWDSM2',500)
      ENDIF
C--now compute the weight
      WGT = ZERO
      DO 500 P0 =1,2
      DO 500 P0P=1,2
      DO 500 P1 =1,2
      DO 500 P2 =1,2
 500  WGT = WGT+PHS*P2MODE(IMODE)*DREAL(
     &       ME(P0,P1,P2)*DCONJG(ME(P0P,P1,P2))*RHOIN(P0,P0P))
      IF(I2DRTP(IMODE).EQ.5.OR.I2DRTP(IMODE).EQ.6.OR.
     &   I2DRTP(IMODE).EQ.8.OR.I2DRTP(IMODE).EQ.13) GOTO 300
C--issue warning if greater than maximum
      IF(WGT.GT.WTMAX) THEN
        CALL HWWARN('HWDSM2',1)
        WRITE(6,2000) RNAME(IDK(ID2PRT(IMODE))),
     &   RNAME(IDKPRD(1,ID2PRT(IMODE))),RNAME(IDKPRD(2,ID2PRT(IMODE))),
     &   WTMAX,1.1D0*WGT
        WT2MAX(IMODE) = 1.1D0*WGT
        WTMAX         = WT2MAX(IMODE)
      ENDIF
      IF(HWRGEN(0)*WTMAX.GT.WGT.AND.NTRY.LT.NSNTRY) GOTO 1000
      IF(NTRY.GE.NSNTRY) THEN
        CALL HWWARN('HWDSM2',100)
        GOTO 999
      ENDIF
C--now enter the momenta in the common block
 300  CALL HWVEQU(5,P(1,2),PHEP(1,IOUT1))
      CALL HWVEQU(5,P(1,3),PHEP(1,IOUT2))
C--set up the spin information
C--setup for all decays
      JMOSPN(NSPN+1) = IDSPIN
      JMOSPN(NSPN+2) = IDSPIN
      JDASPN(1,IDSPIN) = NSPN+1
      JDASPN(2,IDSPIN) = NSPN+2
      IDSPN(NSPN+1) = IOUT1
      IDSPN(NSPN+2) = IOUT2
      DO 11 I=1,2
      DECSPN(NSPN+I) = .FALSE.
      DO 11 J=1,2
 11   JDASPN(I,NSPN+J) = 0
      ISNHEP(IOUT1) = NSPN+1
      ISNHEP(IOUT2) = NSPN+2
      DO 12 I=1,2
        IF(RSPIN(IDHW(IDSPN(NSPN+I))).EQ.ZERO) THEN
          RHOSPN(1,1,NSPN+I) = ONE
          RHOSPN(2,1,NSPN+I) = ZERO
          RHOSPN(1,2,NSPN+I) = ZERO
          RHOSPN(2,2,NSPN+I) = ZERO
        ELSE
          RHOSPN(1,1,NSPN+I) = HALF
          RHOSPN(2,1,NSPN+I) = ZERO
          RHOSPN(1,2,NSPN+I) = ZERO
          RHOSPN(2,2,NSPN+I) = HALF
        ENDIF
 12   CONTINUE
      NSPN = NSPN+2
C--now enter the matrix element
      DO 150 P0=1,2
      DO 150 P1=1,2
      DO 150 P2=1,2
      MESPN(P0,P1,P2,2,1,IDSPIN) = (0.0D0,0.0D0)
 150  MESPN(P0,P1,P2,1,1,IDSPIN) = ME(P0,P1,P2)
      SPNCFC(1,1,IDSPIN) = ONE
      NCFL(IDSPIN) = 1
      RETURN
C--format statements
 2000 FORMAT(/'WEIGHT FOR DECAY ',A8,' --> ',A8,' ',A8, 'EXCEEDS MAX',
     &       /10X,'    MAXIMUM WEIGHT =',1PG24.16,
     &       /10X,'NEW MAXIMUM WEIGHT =',1PG24.16)
 999  RETURN
      END
CDECK  ID>, HWDSM3.
*CMZ :-        -09/04/02  13:46:07  by  Peter Richardson
*-- Author :    Peter Richardson
C-----------------------------------------------------------------------
      SUBROUTINE HWDSM3(NPR,ID,IOUT1,IOUT2,IOUT3,IMODE,RHOIN,IDSPIN)
C-----------------------------------------------------------------------
C     Master subroutine for three body SUSY and spin ME's
C     Uses HWD3ME to generate the momenta etc
C-----------------------------------------------------------------------
      INCLUDE 'HERWIG65.INC'
      DOUBLE COMPLEX F0(2,2,8),F1(2,2,8),F1M(2,2,8),F3(2,2,8),
     &     F0M(2,2,8),F2(2,2,8),RHOIN(2,2),F01(2,2,8,8)
      DOUBLE PRECISION A,B,MS,MWD,MA,MB,MA2,MB2,M342,M232,M242,MR,
     &  P(5,4),PZ(5),HWRGEN,CV,CA,BR,PM(5,4),CFTHRE(NCFMAX,NCFMAX)
      INTEGER ID,IDP(4+NDIAGR),NPR,ITYPE,I,IB,ID1,ID2,IDSPIN,
     &     DRTYPE(NDIAGR),IOUT(3),IMODE,IOUT1,IOUT2,IOUT3,J,NCTHRE,
     &     DRCF(NDIAGR)
      COMMON/HWD3BY/F0,F0M,F1M,F1,F2,F3,F01,A(2,NDIAGR),B(2,NDIAGR),
     &     MS(NDIAGR),MWD(NDIAGR),MR(NDIAGR),MA(4),MA2(4),MB(4),MB2(4),
     &     M342,M232,M242,P,PM,CFTHRE,IDP,DRTYPE,NCTHRE,DRCF
      EXTERNAL HWRGEN
      SAVE PZ,IOUT,ITYPE,ID1,ID2
C--calculate the matrix element for a three body decay
      IF(NPR.EQ.3) THEN
C--set up the decay products, if a SUSY decay the SUSY particle
C--must be the first decay product
        IF(ABS(IDHEP(IOUT1)).GT.1000000) THEN
          IOUT(1) = IOUT1
          IOUT(2) = IOUT2
          IOUT(3) = IOUT3
        ELSEIF(ABS(IDHEP(IOUT2)).GT.1000000) THEN
          IOUT(1) = IOUT2
          IOUT(2) = IOUT1
          IOUT(3) = IOUT3
        ELSEIF(ABS(IDHEP(IOUT3)).GT.1000000) THEN
          IOUT(1) = IOUT3
          IOUT(2) = IOUT1
          IOUT(3) = IOUT3
C--special for top decay (bottom must be first)
        ELSEIF(ABS(IDHEP(ID)).EQ.6) THEN
          IOUT(1) = IOUT3
          IOUT(2) = IOUT1
          IOUT(3) = IOUT2
        ELSE
          IOUT(1) = IOUT2
          IOUT(2) = IOUT1
          IOUT(3) = IOUT3
        ENDIF
C--fermion must be second and antifermion third
        IF(IDHEP(IOUT(2)).LT.0.AND.
     &    (ABS(IDHEP(IOUT(1))).GT.1000000.OR.ABS(IDHEP(ID)).EQ.6)) THEN
          I = IOUT(2)
          IOUT(2) = IOUT(3)
          IOUT(3) = I
        ENDIF
C--setup the OFF SHELL MASSES
        MA(1) = PHEP(5,ID)
        DO 1 I=1,3
 1      MA(I+1) = PHEP(5,IOUT(I))
        DO 2 I=1,4
 2      MA2(I) = MA(I)**2
C--call to ME code
        CALL HWD3ME(ID,0,IMODE,RHOIN,IDSPIN)
        IF(IERROR.NE.0) RETURN
C--juggle the momenta for the RPV BV gluino if needed
        IF(SPCOPT.EQ.2.AND.N3NCFL(IMODE).EQ.3) THEN
          IF(NCFL(IDSPIN).EQ.2) THEN
            IOUT(1) = IOUT1
            IOUT(2) = IOUT2
            IOUT(3) = IOUT3
          ELSEIF(NCFL(IDSPIN).EQ.3) THEN
            IOUT(1) = IOUT3
            IOUT(2) = IOUT2
            IOUT(3) = IOUT1
          ENDIF
          DO I=1,3
            IDHW(IOUT(I)) = IDP(I+1)
          ENDDO
        ENDIF
C--copy momenta into event record
        DO 3 I=1,3
 3      CALL HWVEQU(5,P(1,1+I),PHEP(1,IOUT(I)))
C--enter the spin information in the common block
        IF(SYSPIN) THEN
C--set up if start of new spin chain
          IF(NSPN.EQ.0) THEN
C--zero the elements
            CALL HWVZRI(  NMXHEP,ISNHEP)
            CALL HWVZRI(  NMXSPN,JMOSPN)
            CALL HWVZRI(2*NMXSPN,JDASPN)
            CALL HWVZRI(  NMXSPN, IDSPN)
            NSPN = NSPN+1
            JMOSPN(NSPN) = 0
            IDSPN (NSPN) = ID
            DECSPN(NSPN) = .FALSE.
C--set up spin density matrix for particle
            IF(RSPIN(IDHW(ID)).EQ.ZERO) THEN
              RHOSPN(1,1,NSPN) = ONE
              RHOSPN(2,1,NSPN) = ZERO
              RHOSPN(1,2,NSPN) = ZERO
              RHOSPN(2,2,NSPN) = ZERO
            ELSE
              RHOSPN(1,1,NSPN) = HALF
              RHOSPN(2,1,NSPN) = ZERO
              RHOSPN(1,2,NSPN) = ZERO
              RHOSPN(2,2,NSPN) = HALF
            ENDIF
            ISNHEP(ID)    = NSPN
          ENDIF
C--enter the decay products
          JDASPN(1,IDSPIN) = NSPN+1
          JDASPN(2,IDSPIN) = NSPN+3
          DO 7 I=1,3
          JMOSPN(NSPN+I  ) = IDSPIN
          IDSPN (NSPN+I  ) = IOUT(I)
          DECSPN(NSPN+I  ) = .FALSE.
          ISNHEP(IOUT(I) ) = NSPN+I
          IF(RSPIN(IDHW(IOUT(I))).EQ.ZERO) THEN
            RHOSPN(1,1,NSPN+I) = ONE
            RHOSPN(2,1,NSPN+I) = ZERO
            RHOSPN(1,2,NSPN+I) = ZERO
            RHOSPN(2,2,NSPN+I) = ZERO
          ELSE
            RHOSPN(1,1,NSPN+I) = HALF
            RHOSPN(2,1,NSPN+I) = ZERO
            RHOSPN(1,2,NSPN+I) = ZERO
            RHOSPN(2,2,NSPN+I) = HALF
          ENDIF
          DO 7 J=1,2
 7        JDASPN(J,NSPN+I) = 0
          NSPN = NSPN+3
        ENDIF
C--select the decay mode and generate the decay for a two body mode
      ELSEIF(NPR.EQ.2) THEN
        IF(IDHW(IOUT2).GE.198.AND.IDHW(IOUT2).LE.200) THEN
          IB = IDHW(IOUT2)
          IOUT(1) = IOUT1
          IOUT(2) = IOUT2
        ELSEIF(IDHW(IOUT1).GE.198.AND.IDHW(IOUT1).LE.200) THEN
          IB = IDHW(IOUT1)
          IOUT(1) = IOUT2
          IOUT(2) = IOUT1
        ELSE
          CALL HWWARN('HWDSM3',501)
        ENDIF
C--setup the off shell masses and particle ids for me code
        MA(1) = PHEP(5,ID)
        MA(2) = PHEP(5,IOUT(1))
        CALL HWDBOZ(IB,ID1,ID2,CV,CA,BR,0)
        ITYPE = ID1
        IF(IB.EQ.199) ITYPE = ITYPE+1
        IF(ITYPE.GT.120) ITYPE = ITYPE-114
        IF(IB.NE.200) ITYPE = ITYPE/2
C--generate momenta of decay products
        CALL HWD3ME(ID,ITYPE,IMODE,RHOIN,IDSPIN)
        CALL HWVEQU(5,P(1,2),PHEP(1,IOUT(1)))
        CALL HWVSUM(4,P(1,3),P(1,4),PZ)
        CALL HWUMAS(PZ)
        CALL HWVEQU(5,PZ,PHEP(1,IOUT(2)))
C--enter the spin information in the common block if starting new chain
        IF(SYSPIN.AND.NSPN.EQ.0) THEN
C--zero elements of common block
          CALL HWVZRI(  NMXHEP,ISNHEP)
          CALL HWVZRI(  NMXSPN,JMOSPN)
          CALL HWVZRI(2*NMXSPN,JDASPN)
          CALL HWVZRI(  NMXSPN, IDSPN)
          NSPN = NSPN+1
          JMOSPN(NSPN) = 0
          IDSPN (NSPN) = ID
          DECSPN(NSPN) = .FALSE.
          IF(RSPIN(IDHW(ID)).EQ.ZERO) THEN
            RHOSPN(1,1,NSPN) = ONE
            RHOSPN(2,1,NSPN) = ZERO
            RHOSPN(1,2,NSPN) = ZERO
            RHOSPN(2,2,NSPN) = ZERO
          ELSE
            RHOSPN(1,1,NSPN) = HALF
            RHOSPN(2,1,NSPN) = ZERO
            RHOSPN(1,2,NSPN) = ZERO
            RHOSPN(2,2,NSPN) = HALF
          ENDIF
          ISNHEP(ID)    = NSPN
        ENDIF
        IF(SYSPIN) THEN
          IDSPN (NSPN+1  ) = IOUT(1)
          ISNHEP(IOUT(1))  = NSPN+1
        ENDIF
C--put the boson decay products into the event record for a two body mode
      ELSEIF(NPR.EQ.-1) THEN
        IOUT(1) = JDAHEP(1,IOUT(2))
        IOUT(2) = NHEP+1
        IOUT(3) = NHEP+2
C--set up the status of the particles
        ISTHEP(IOUT(1)) = 195
        JDAHEP(1,IOUT(1)) = NHEP+1
        JDAHEP(2,IOUT(1)) = NHEP+2
C--find the ID's of the particles
        IF(IDHW(IOUT(1)).EQ.200) THEN
          ID1 = ITYPE
          IF(ITYPE.GT.6) ID1 = ID1+114
          ID2 = ID1+6
        ELSE
          ID1 = 2*ITYPE-1
          IF(ITYPE.GT.3) ID1 = ID1+114
          ID2 = ID1+7
          IF(IDHW(IOUT(1)).EQ.198) THEN
            I   = ID1+6
            ID1 = ID2-6
            ID2 = I
          ENDIF
        ENDIF
C--put id's of decay products into the event record
        IDHW(NHEP+1)  = ID1
        IDHW(NHEP+2)  = ID2
        IDHEP(NHEP+1) = IDPDG(ID1)
        IDHEP(NHEP+2) = IDPDG(ID2)
C--boost decay products momenta to rest frame of boson
        CALL HWULOF(PZ,P(1,3),P(1,3))
        CALL HWULOF(PZ,P(1,4),P(1,4))
C--boost back to lab using new boson
        CALL HWULOB(PHEP(1,IOUT(1)),P(1,3),PHEP(1,NHEP+1))
        CALL HWULOB(PHEP(1,IOUT(1)),P(1,4),PHEP(1,NHEP+2))
C--setup for decay to quarks
        IF(ID1.LE.12) THEN
          ISTHEP(NHEP+1) = 113
          ISTHEP(NHEP+2) = 114
          JMOHEP(2,NHEP+1) = NHEP+2
          JDAHEP(2,NHEP+1) = NHEP+2
          JMOHEP(2,NHEP+2) = NHEP+1
          JDAHEP(2,NHEP+2) = NHEP+1
          JMOHEP(1,NHEP+1) = IOUT(1)
          JMOHEP(1,NHEP+2) = IOUT(1)
C--setup for decay to leptons
        ELSE
          ISTHEP(NHEP+1) = 193
          ISTHEP(NHEP+2) = 193
          JMOHEP(1,NHEP+1) = IOUT(1)
          JMOHEP(1,NHEP+2) = IOUT(1)
          JMOHEP(2,NHEP+1) = JMOHEP(1,IOUT(1))
          JMOHEP(2,NHEP+2) = JMOHEP(1,IOUT(1))
          JDAHEP(1,NHEP+1) = 0
          JDAHEP(1,NHEP+2) = 0
          JDAHEP(2,NHEP+1) = 0
          JDAHEP(2,NHEP+2) = 0
        ENDIF
        NHEP=NHEP+2
C--finish entering the spin information in the common block
        IF(SYSPIN) THEN
          JDASPN(1,IDSPIN) = NSPN+1
          JDASPN(2,IDSPIN) = NSPN+3
          DO 6 I=1,3
          JMOSPN(NSPN+I  ) = IDSPIN
          DECSPN(NSPN+I  ) = .FALSE.
          IF(RSPIN(IDHW(IOUT(I))).EQ.ZERO) THEN
            RHOSPN(1,1,NSPN+I) = ONE
            RHOSPN(2,1,NSPN+I) = ZERO
            RHOSPN(1,2,NSPN+I) = ZERO
            RHOSPN(2,2,NSPN+I) = ZERO
          ELSE
            RHOSPN(1,1,NSPN+I) = HALF
            RHOSPN(2,1,NSPN+I) = ZERO
            RHOSPN(1,2,NSPN+I) = ZERO
            RHOSPN(2,2,NSPN+I) = HALF
          ENDIF
          DO 6 J=1,2
 6        JDASPN(J,NSPN+I) =0
          NSPN = NSPN+3
          IDSPN (NSPN-1) = NHEP-1
          IDSPN (NSPN  ) = NHEP
          ISNHEP(NHEP-1) = NSPN-1
          ISNHEP(NHEP  ) = NSPN
        ENDIF
C--perform the parton shower for the decay products of the gauge boson
        IF(ID1.LE.12) CALL HWBGEN
C--error issue warning
      ELSE
        CALL HWWARN('HWDSM3',500)
      ENDIF
      END
CDECK  ID>, HWDSM4.
*CMZ :-        -11/10/01  14:03:42  by  Peter Richardson
*-- Author :    Peter Richardson
C-----------------------------------------------------------------------
      SUBROUTINE HWDSM4(IOPT,ID,IOUT1,IOUT2,IMODE)
C-----------------------------------------------------------------------
C     Subroutine to perform the four body decays
C     IOPT = 1 select decay mode and generate momenta
C     IOPT = 2 enter first decays and perform parton shower
C-----------------------------------------------------------------------
      INCLUDE 'HERWIG65.INC'
      INTEGER IOPT,ID,IOUT1,IOUT2,IB(2),I,IDF(4),ITYPE(2),IMODE,
     &     IDP(4+NDIAGR),ID1,ID2,J
      DOUBLE PRECISION CV,CA,A,B,MS,MWD,MR,M,M2,P(5,5),PW(5,2),BR
      COMMON/HWD4BY/A(2),B(2),MS(2),MWD(2),MR(2),M(5),M2(5),P,IDP
      SAVE PW,ITYPE
C--generate the decay
      IF(IOPT.EQ.1) THEN
        IB(1) = IDHW(IOUT1)
        IB(2) = IDHW(IOUT2)
C--select the decays of the bosons
        DO 1 I=1,2
        CALL HWDBOZ(IB(I),IDF(2*I-1),IDF(2*I),CV,CA,BR,1)
        ITYPE(I) = IDF(2*I-1)
        IF(IB(I).EQ.199) ITYPE(I)    = ITYPE(I)+1
        IF(ITYPE(I).GT.120) ITYPE(I) = ITYPE(I)-114
 1      IF(IB(I).NE.200) ITYPE(I)    = ITYPE(I)/2
C--generate the momenta of the decay products
        CALL HWD4ME(ID,ITYPE(1),ITYPE(2),IMODE)
        DO 2 I=1,2
        CALL HWVSUM(4,P(1,2*I),P(1,2*I+1),PW(1,I))
 2      CALL HWUMAS(PW(1,I))
        CALL HWVEQU(5,PW(1,1),PHEP(1,IOUT1))
        CALL HWVEQU(5,PW(1,2),PHEP(1,IOUT2))
        IF(SYSPIN) THEN
          IDSPN(1)     = JDAHEP(1,ID)
          DECSPN(1)    = .FALSE.
          ISNHEP(JDAHEP(1,ID)) = 1
          JDASPN(1,1)  = 2
          JDASPN(2,1)  = 5
          DO 4 I=2,5
          DECSPN(I) = .FALSE.
 4        JMOSPN(I) = 1
        ENDIF
      ELSEIF(IOPT.EQ.2) THEN
        IB(1) = JDAHEP(1,IOUT1)
        IB(2) = JDAHEP(1,IOUT2)
        DO 3 I=1,2
          ISTHEP(IB(I)) = 195
          JDAHEP(1,IB(I)) = NHEP+1
          JDAHEP(2,IB(I)) = NHEP+2
C--find the ID's of the particles
          IF(IDHW(IB(I)).EQ.200) THEN
            ID1 = ITYPE(I)
            IF(ITYPE(I).GT.6) ID1 = ID1+114
            ID2 = ID1+6
          ELSE
            ID1 = 2*ITYPE(I)-1
            IF(ITYPE(I).GT.3) ID1 = ID1+114
            ID2 = ID1+7
            IF(IDHW(IB(I)).EQ.198) THEN
              J   = ID1+6
              ID1 = ID2-6
              ID2 = J
            ENDIF
          ENDIF
C--put id's of decay products into the event record
          IDHW(NHEP+1)  = ID1
          IDHW(NHEP+2)  = ID2
          IDHEP(NHEP+1) = IDPDG(ID1)
          IDHEP(NHEP+2) = IDPDG(ID2)
C--boost decay products momenta to rest frame of boson
          CALL HWULOF(PW(1,I),P(1,2*I  ),P(1,2*I  ))
          CALL HWULOF(PW(1,I),P(1,2*I+1),P(1,2*I+1))
C--boost back to lab using new boson
          CALL HWULOB(PHEP(1,IB(I)),P(1,2*I  ),PHEP(1,NHEP+1))
          CALL HWULOB(PHEP(1,IB(I)),P(1,2*I+1),PHEP(1,NHEP+2))
C--setup for decay to quarks
          IF(ID1.LE.12) THEN
            ISTHEP(NHEP+1) = 113
            ISTHEP(NHEP+2) = 114
            JMOHEP(2,NHEP+1) = NHEP+2
            JDAHEP(2,NHEP+1) = NHEP+2
            JMOHEP(2,NHEP+2) = NHEP+1
            JDAHEP(2,NHEP+2) = NHEP+1
            JMOHEP(1,NHEP+1) = IB(I)
            JMOHEP(1,NHEP+2) = IB(I)
C--setup for decay to leptons
          ELSE
            ISTHEP(NHEP+1) = 193
            ISTHEP(NHEP+2) = 193
            JMOHEP(1,NHEP+1) = IB(I)
            JMOHEP(1,NHEP+2) = IB(I)
            JMOHEP(2,NHEP+1) = JMOHEP(1,IB(I))
            JMOHEP(2,NHEP+2) = JMOHEP(1,IB(I))
          ENDIF
C--enter the information in the spin common block
          IF(SYSPIN) THEN
            IDSPN(2*I  ) = NHEP+1
            IDSPN(2*I+1) = NHEP+2
            ISNHEP(NHEP+1) = 2*I
            ISNHEP(NHEP+2) = 2*I+1
          ENDIF
          NHEP=NHEP+2
C--perform the parton shower for the decay products of the gauge boson
          IF(ID1.LE.12) CALL HWBGEN
 3      CONTINUE
      ENDIF
      END
CDECK  ID>, HWDTAU.
*CMZ :-        -17/10/01  09:42:21  by  Peter Richardson
*-- Author :    Peter Richardson
C-----------------------------------------------------------------------
      SUBROUTINE HWDTAU(IOPT,IHEP,POL)
C-----------------------------------------------------------------------
C     HERWIG-TAUOLA interface to perform tau decays using TAUOLA rather
C     than HERWIG
C     IOPT =-1 initialises
C     IOPT = 1 performs decay
C     IOPT = 2 write outs final TAUOLA information
C-----------------------------------------------------------------------
      INCLUDE 'HERWIG65.INC'
      INTEGER IOPT,IHEP,ID,ITAU,I,IMO,NHEPPO
      DOUBLE PRECISION POL
      REAL POL1(4)
      CHARACTER *8 DUMMY
C--common block for PHOTOS
      LOGICAL QEDRAD
      COMMON /PHOQED/ QEDRAD(NMXHEP)
C--common blocks for TAUOLA
      INTEGER NP1,NP2
      COMMON /TAUPOS/ NP1, NP2
      DOUBLE PRECISION Q1(4),Q2(4),P1(4),P2(4),P3(4),P4(4)
      COMMON / MOMDEC / Q1,Q2,P1,P2,P3,P4
      DOUBLE PRECISION DIST(4),VERTX(4)
C--initialisation
      IF(IOPT.EQ.-1) THEN
C--initialise TAUOLA
        CALL INIETC(JAK1,JAK2,ITDKRC,IFPHOT)
        CALL INIMAS
        CALL INIPHX(0.01d0)
        CALL INITDK
C--generate a decay
      ELSEIF(IOPT.EQ.1) THEN
        ISTHEP(IHEP)=195
        ID = IDHW(IHEP)
        IMO = IHEP
 1      IMO = JMOHEP(1,IMO)
        IF(IDHW(IMO).EQ.ID) GOTO 1
C--id of tau for tauola
        IF(ID.EQ.125) THEN
          ITAU = 2
          NP1 = IHEP
          NP2 = IHEP
        ELSEIF(ID.EQ.131) THEN
          ITAU = 1
          NP1 = IHEP
          NP2 = IHEP
        ELSE
          CALL HWWARN('HWDTAU',501)
        ENDIF
C--set up the tau polarization
        POL1(1) = 0.
        POL1(2) = 0.
        POL1(3) = REAL(POL)
        POL1(4) = 0.
C--tau momentum
C--three components
        DO I=1,3
           IF(ID.EQ.125) THEN
              P1(I) =-PHEP(I,IHEP)
              P2(I) = PHEP(I,IHEP)
           ELSE
              P1(I) = PHEP(I,IHEP)
              P2(I) =-PHEP(I,IHEP)
           ENDIF
C--we measure tau spins in lab frame
          Q1(I) = ZERO
        ENDDO
C--energies
        P1(4)=PHEP(4,IHEP)
        P2(4)=PHEP(4,IHEP)
        Q1(4)=P1(4)+P2(4)
C--perform the decay and generate QED radiation if needed
        NHEPPO=NHEP
        CALL DEXAY(ITAU,POL1)
C--add tau decay vertex info.
        CALL HWUDKL(125,PHEP(1,IHEP),DIST)
        CALL HWVSUM(4,VHEP(1,IHEP),DIST,VERTX)
        IF(IFPHOT.EQ.1) THEN
          IF(ID.EQ.1) THEN
            CALL PHOTOS(NP1)
          ELSE
            CALL PHOTOS(NP2)
          ENDIF
        ENDIF
        IF(NHEPPO.NE.NHEP) THEN
          DO 2 I=NHEPPO+1,NHEP
          CALL HWVEQU(4,VERTX,VHEP(1,I))
 2        CALL HWUIDT(1,IDHEP(I),IDHW(I),DUMMY)
        ENDIF
C--write out info at end
      ELSEIF(IOPT.EQ.2) THEN
        CALL DEXAY(100,POL1)
C--otherwise issue warning
      ELSE
        CALL HWWARN('HWDTAU',500)
      ENDIF
      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-----------------------------------------------------------------------
      IMPLICIT NONE
      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) THEN
        CALL HWWARN('HWDTHR',100)
        GOTO 999
      ENDIF
      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  RETURN
      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 'HERWIG65.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-----------------------------------------------------------------------
      IMPLICIT NONE
      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-----------------------------------------------------------------------
      IMPLICIT NONE
      DOUBLE PRECISION HWDWWT,EMSQ,A,B,C
      HWDWWT=(A-EMSQ)*(EMSQ-B)*C
      END
CDECK  ID>, HWDHWT.
*CMZ :-        -26/06/01  14.44.53  by  Stefano Moretti
*-- Author :    Stefano Moretti
C-----------------------------------------------------------------------
      FUNCTION HWDHWT(EMSQ,DUMMYA,DUMMYB,DUMMYC)
C-----------------------------------------------------------------------
C     MATRIX ELEMENT SQUARED FOR
C     ((V-A)*TB1+(V+A)*CT1)*((V-A)*TB2+(V+A)*CT2)) WEAK DECAY
C-----------------------------------------------------------------------
      INCLUDE 'HERWIG65.INC'
      COMMON/FFS/TB,BT
      COMMON/SFF/IT1,IB1,IT2,IB2
      DOUBLE PRECISION TB,BT
      INTEGER IT1,IB1,IT2,IB2
      DOUBLE PRECISION TBH,HBT,CB1,TB1,CB2,TB2
      DOUBLE PRECISION DUMMYA,DUMMYB,DUMMYC
      DOUBLE PRECISION HWDHWT,EMSQ
      CB1=RMASS(IT1)**2
      TB1=RMASS(IB1)**2
      CB2=RMASS(IT2)**2
      TB2=RMASS(IB2)**2
C use formula (4.52) page 217 of `Higgs Hunter Guide'.
      TBH=(TB1+CB1-EMSQ)*(TB1*TB*TB+CB1/TB/TB)+4.*TB1*CB1
C use formula (B. 1) page 411 of `Higgs Hunter Guide'.
      HBT=(EMSQ-TB2-CB2)*(TB2*BT*BT+CB2/BT/BT)-4.*TB2*CB2
      HWDHWT=TBH*HBT
      HWDHWT=ABS(HWDHWT)*SQRT(EMSQ)
      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 'HERWIG65.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)
      ENDIF
      END
CDECK  ID>, HWECIR.
*CMZ :-        -11/05/01  15.44.55  by  Mike Seymour
*-- Author :    Mike Seymour
C-----------------------------------------------------------------------
      FUNCTION HWECIR(Y)
C-----------------------------------------------------------------------
C   INTEGRAND OF BEAMSTRAHLUNG FUNCTION INTEGRATION
C   NOTE THAT THE JACOBIAN TRANSFORMATION (1-Z)^ETA HAS ETA HARDCODED
C-----------------------------------------------------------------------
      IMPLICIT NONE
      DOUBLE PRECISION HWECIR,Y,Z,ETA,CIRCEE
      EXTERNAL CIRCEE
      ETA=0.6D0
      Z=1-Y**(1/(1-ETA))
      HWECIR=(1-Z)**ETA/(1-ETA)*CIRCEE(Z,-1D0)/SQRT(CIRCEE(-1D0,-1D0))
      END
CDECK  ID>, HWEFIN.
*CMZ :-        -15/07/02  17.56.53  by  Peter Richardson
*-- Author :    Bryan Webber
C-----------------------------------------------------------------------
      SUBROUTINE HWEFIN
C-----------------------------------------------------------------------
C     TERMINAL CALCULATIONS ON ELEMENTARY PROCESS
C     Modified 28/03/01 by BRW to handle negative weights
C     Modified 15/07/02 by PR for Les Houches Accord
C-----------------------------------------------------------------------
      INCLUDE 'HERWIG65.INC'
      INTEGER I
      DOUBLE PRECISION RNWGT,SPWGT,ERWGT
C--Les Houches Common Block
      INTEGER MAXPUP
      PARAMETER(MAXPUP=100)
      INTEGER IDBMUP,PDFGUP,PDFSUP,IDWTUP,NPRUP,LPRUP
      DOUBLE PRECISION EBMUP,XSECUP,XERRUP,XMAXUP
      COMMON /HEPRUP/ IDBMUP(2),EBMUP(2),PDFGUP(2),PDFSUP(2),
     &                IDWTUP,NPRUP,XSECUP(MAXPUP),XERRUP(MAXPUP),
     &                XMAXUP(MAXPUP),LPRUP(MAXPUP)
      IF(TAUDEC.EQ.'TAUOLA') CALL HWDTAU(2,0,0.0D0)
      IF (NWGTS.EQ.0) THEN
        WRITE (6,1)
        WRITE (6,10)
   10   FORMAT(10X,'NO WEIGHTS GENERATED')
        RETURN
      ENDIF
C--output Les Houches common block information
      IF(IPROC.LE.0) THEN
C--WRITE THE HEADER
        WRITE(6,13)
        WRITE(6,14)
C--FOR THE FIRST WEIGHT OPTION CALCULATE THE CROSS SECTION
        IF(ABS(IDWTUP).EQ.1) THEN
          DO I=1,NPRUP
            RNWGT     = 1.0D0/DBLE(LHIWGT(I))
            LHXSCT(I) = LHWGT(I)*RNWGT
            LHXERR(I) = SQRT(MAX(LHWGTS(I)*RNWGT-LHXSCT(I)**2,ZERO))
            LHXERR(I) = LHXERR(I)*SQRT(RNWGT)
            LHXSCT(I) = LHXSCT(I)*1.0D3
            LHXERR(I) = LHXERR(I)*1.0D3
            LHXMAX(I) = LHXMAX(I)*1.0D3
          ENDDO
C--FOR THE SECOND WEIGHT OPTION THIS WAS AN INPUT
        ELSEIF(ABS(IDWTUP).EQ.2) THEN
          DO I=1,NPRUP
            LHXMAX(I) = LHXMAX(I)*1.0D3
          ENDDO
        ENDIF
        IF(ABS(IDWTUP).LE.2) THEN
          AVWGT = ZERO
          ERWGT = ZERO
          DO I=1,NPRUP
            WRITE(6,15) LPRUP(I),LHXSCT(I),LHXERR(I),LHXMAX(I)*1.0D-3,
     &            LHNEVT(I)
            AVWGT = AVWGT+LHXSCT(I)
            ERWGT = ERWGT+LHXERR(I)**2
          ENDDO
          AVWGT = AVWGT*1.0D-3
          ERWGT = SQRT(ERWGT)*1.0D-3
        ELSE
          RNWGT=1./FLOAT(NWGTS)
          IF (NEGWTS) AVABW=ABWSUM*RNWGT
          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
        ENDIF
C--STANDARD HERWIG OPTION
      ELSE
        RNWGT=1./FLOAT(NWGTS)
        IF (NEGWTS) AVABW=ABWSUM*RNWGT
        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
      ENDIF
C--PRINT OUT THE INFO
      WRITE (6,1)
 1    FORMAT(/10X,'OUTPUT ON ELEMENTARY PROCESS'/)
      IF (NEGWTS) THEN
         WRITE (6,12) NEVHEP,NNEGEV,NWGTS,NNEGWT,AVWGT,SPWGT,
     &        AVABW,WBIGST,WGTMAX,IPROC,
     &        1000.*AVWGT,1000.*ERWGT,100.*AVWGT/WGTMAX
      ELSE
         WRITE (6,11) NEVHEP,NWGTS,AVWGT,SPWGT,WBIGST,WGTMAX,
     &        IPROC,
     &        1000.*AVWGT,1000.*ERWGT,100.*AVWGT/WGTMAX
      ENDIF
 11   FORMAT(1P,
     &     10X,'N.B. NEGATIVE WEIGHTS NOT ALLOWED'//
     &     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)
 12   FORMAT(1P,
     &     10X,'N.B. NEGATIVE WEIGHTS ALLOWED'//
     &     10X,'NUMBER OF EVENTS   = ',I11/
     &     10X,'NEGATIVE  EVENTS   = ',I11/
     &     10X,'NUMBER OF WEIGHTS  = ',I11/
     &     10X,'NEGATIVE  WEIGHTS  = ',I11/
     &     10X,'MEAN VALUE OF WGT  =',E12.4/
     &     10X,'RMS SPREAD IN WGT  =',E12.4/
     &     10X,'MEAN ABS WEIGHT    =',E12.4/
     &     10X,'ACTUAL MAX ABS WGT =',E12.4/
     &     10X,'ASSUMED MAXABS WGT =',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)
 13   FORMAT(/1P,10X,'OUTPUT ON LES HOUCHES EVENTS'/)
 14   FORMAT(/1P,5X,' PROC CODE',1X,' XSECT(pb)     ',1X,
     &     '  XERR(pb)  ',1X,'   Max wgt(nb)',1X,'No. of events'/)
 15   FORMAT(5X,I7,E15.5,1X,E15.5,1X,E15.5,2X,I7)
      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 'HERWIG65.INC'
      DOUBLE PRECISION HWRGEN,HWRUNI,EGMIN,ZMIN,ZMAX,ZGAM,SS,ZMI,ZMA,
     & PPL,PMI,QT2,Q2,QQMIN,QQMAX,S0,A
      INTEGER IHEP,IHADIS
      LOGICAL WWA
      EXTERNAL HWRGEN,HWRUNI
      SAVE EGMIN
      DATA EGMIN/5.D0/
      IF (IERROR.NE.0)  RETURN
      IF (IHEP.LT.1.OR.IHEP.GT.2) CALL HWWARN('HWEGAM',500)
      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
        CALL HWEGAS(S0)
        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)
          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)
      ELSE
        ZMAX=MIN(ZMAX,1-PHEP(5,IHEP)/PHEP(4,IHEP))
      ENDIF
      IF (ZMIN.GE.ZMAX) THEN
        GAMWT=ZERO
        RETURN
      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) THEN
          CALL HWWARN('HWEGAM',50)
          GOTO 10
        ENDIF
        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)
      END
CDECK  ID>, HWEGAS.
*CMZ :-        -18/04/04  10.45.55  by  Mike Seymour
*-- Author :    Bryan Webber & Luca Stanco
C-----------------------------------------------------------------------
      SUBROUTINE HWEGAS(S0)
C-----------------------------------------------------------------------
C     FIND MINIMUM INVARIANT MASS SQUARED NEEDED FOR HARD PROCESS, S0
C-----------------------------------------------------------------------
      INCLUDE 'HERWIG65.INC'
      DOUBLE PRECISION S0,RPM(2)
      INTEGER HQ,I
      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.31).OR.(IPRO.EQ.32)) THEN
        S0 = MAX(2*RMASS(1),RMASS(201+IHIGGS))**2
      ELSEIF (IPRO.EQ.33) THEN
        IF((MOD(IPROC,10000).EQ.3350).OR.
     &       (MOD(IPROC,10000).EQ.3355))THEN
          S0 = MAX(2*RMASS(1),RMASS(206))**2
        ELSEIF(MOD(IPROC,10000).EQ.3315)THEN
          S0 = MAX(2*RMASS(1),RMASS(206),RMASS(203))**2
        ELSEIF(MOD(IPROC,10000).EQ.3325)THEN
          S0 = MAX(2*RMASS(1),RMASS(206),RMASS(204))**2
        ELSEIF(MOD(IPROC,10000).EQ.3335)THEN
          S0 = MAX(2*RMASS(1),RMASS(206),RMASS(205))**2
        ELSEIF(MOD(IPROC,10000).EQ.3365)THEN
          S0 = MAX(2*RMASS(1),RMASS(205),RMASS(203))**2
        ELSEIF(MOD(IPROC,10000).EQ.3375)THEN
          S0 = MAX(2*RMASS(1),RMASS(205),RMASS(204))**2
        ELSE
          S0 = MAX(2*RMASS(1),RMASS(201+IHIGGS))**2
        END IF
      ELSEIF ((IPRO.EQ.34).OR.(IPRO.EQ.35)) THEN
        S0 = MAX(RMASS(5),RMASS(201+IHIGGS))**2
      ELSEIF (IPRO.EQ.36.OR.IPRO.EQ.37) THEN
        S0 = MAX(2*RMASS(1),RMASS(201+IHIGGS))**2
      ELSEIF (IPRO.EQ.38) THEN
        IF((MOD(IPROC,10000).EQ.3839).OR.
     &       (MOD(IPROC,10000).EQ.3869).OR.
     &       (MOD(IPROC,10000).EQ.3899))THEN
          S0 = MAX(RMASS(6),RMASS(206))**2
        ELSE
          S0 = RMASS(201+IHIGGS)**2
        END IF
      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 = MOD(IPROC,100)
        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
      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     Modified 28/03/01 by BRW to handle negative weights
C-----------------------------------------------------------------------
      INCLUDE 'HERWIG65.INC'
      DOUBLE PRECISION HWRSET,DUMMY,SAFETY
      EXTERNAL HWRSET
      PARAMETER (SAFETY=1.001)
      INTEGER NBSH,I
C---NO OF WEIGHT GENERATED
      NWGTS=0
      NNEGWT=0
C---ACCUMULATED WEIGHTS
      WGTSUM=ZERO
      ABWSUM=ZERO
C---ACCUMULATED WEIGHT-SQUARED
      WSQSUM=ZERO
C---CURRENT MAX WEIGHT
      WBIGST=ZERO
C---LAST VALUE OF SCALE
      EMLST=ZERO
C---NUMBER OF ERRORS REPORTED
      NUMER=0
C---NUMBER OF ERRORS UNREPORTED
      NUMERU=0
C---FIND MAXIMUM ABSOLUTE WEIGHT IN CASES WHERE THIS IS REQUIRED
      IF (NOWGT) THEN
        IF (WGTMAX.EQ.ZERO.AND.IPROC.GT.0) THEN
          NBSH=IBSH
          DUMMY = HWRSET(IBRN)
          WRITE(6,10) IPROC,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
          NNEGWT=0
          WGTSUM=ZERO
          WSQSUM=ZERO
          ABWSUM=ZERO
          WBIGST=ZERO
        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
      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 'HERWIG65.INC'
      DOUBLE PRECISION CIRCKP(2)
      COMMON /HWCIR2/CIRCKP
      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.12.OR.IPROC.EQ.850) RETURN
C---CHECK CONSISTENCY OF TMNISR AND ZMXISR
      IF (ZMXISR**2.LT.TMNISR) CALL HWWARN('HWEISR',200)
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.OR.IPRO.EQ.10.OR.IPRO.EQ.11) THEN
          AA=1
        ELSEIF (IPRO.EQ.9) THEN
          AA=0
          IF((MOD(IPROC,10000).EQ.960).OR.
     &       (MOD(IPROC,10000).EQ.970))THEN
            AA=1
          ELSE
            CONTINUE
          ENDIF
        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
            CIRCKP(I)=(1-ZMXISR)**B*EXP(3*B/4)*(1-B**2*PIFAC**2/12)
          ELSE
            CIRCKP(I)=(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
          GAMWT=GAMWT*CIRCKP(I)
  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)
      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))
      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 'HERWIG65.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
      END
CDECK  ID>, HWEPRO.
*CMZ :-        -15/07/02  17.56.53  by  Peter Richardson
*-- 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     modifications for Les Houches accord by PR (7/15/02)
C-----------------------------------------------------------------------
      INCLUDE 'HERWIG65.INC'
      DOUBLE PRECISION CIRCKP(2)
      COMMON /HWCIR2/CIRCKP
      DOUBLE PRECISION Z1,Z2,C1,C2,B1,B2,CIRCEE,CIRCGG,RS,MISS,ETA,
     $     HWUGAU,HWECIR,QMX1,QMN1,QMX2,QMN2,TEST
      INTEGER IHAD
      SAVE MISS
      DOUBLE PRECISION HWRGEN
      EXTERNAL HWRGEN,HWECIR
C--Les Houches Common Block
      INTEGER MAXPUP
      PARAMETER(MAXPUP=100)
      INTEGER IDBMUP,PDFGUP,PDFSUP,IDWTUP,NPRUP,LPRUP
      DOUBLE PRECISION EBMUP,XSECUP,XERRUP,XMAXUP
      COMMON /HEPRUP/ IDBMUP(2),EBMUP(2),PDFGUP(2),PDFSUP(2),
     &                IDWTUP,NPRUP,XSECUP(MAXPUP),XERRUP(MAXPUP),
     &                XMAXUP(MAXPUP),LPRUP(MAXPUP)
      IF (IERROR.NE.0)  RETURN
C--pick the type of event to generate if using Les Houches accord
C--first choice according to maxiumum weight
      IF(IPROC.LT.0) THEN
        IF(ABS(IDWTUP).EQ.1) THEN
          IF(ITYPLH.EQ.0) THEN
            TEST = HWRGEN(1)*LHMXSM
            DO ITYPLH=1,NPRUP
              IF(TEST.LE.ABS(LHXMAX(ITYPLH))) GOTO 5
              TEST = TEST-ABS(LHXMAX(ITYPLH))
            ENDDO
 5          WGTMAX = ABS(LHXMAX(ITYPLH))
            WBIGST = ABS(LHXMAX(ITYPLH))
          ENDIF
C--second choice according to cross section
        ELSEIF(ABS(IDWTUP).EQ.2) THEN
          IF(ITYPLH.EQ.0) THEN
            TEST = HWRGEN(1)*LHMXSM
            DO ITYPLH=1,NPRUP
              IF(TEST.LE.ABS(LHXSCT(ITYPLH))) GOTO 6
              TEST = TEST-ABS(LHXSCT(ITYPLH))
            ENDDO
 6          WGTMAX = ABS(LHXMAX(ITYPLH))
            WBIGST = ABS(LHXMAX(ITYPLH))
          ENDIF
        ELSE
          WGTMAX = 1.0D0
          WBIGST = 1.0D0
          ITYPLH = 1
        ENDIF
      ENDIF
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.12.AND.IPRO.LT.90) THEN
        IF (CIRCOP.EQ.0) 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.)
        ELSE
C---MODIFIED TO USE CIRCE FOR BEAMSTRAHLUNG EFFECTS
          IF (ABS(IDHEP(1)).NE.11.OR.IDHEP(1)+IDHEP(2).NE.0) STOP
     $         'This version only works for e+e- annihilation'
          IF (FSTWGT) THEN
            RS=NINT(PHEP(5,3)*10)/1D1
            CALL CIRCES(ZERO,ZERO,RS,CIRCAC,CIRCVR,CIRCRV,CIRCCH)
          ENDIF
          CALL HWEGAM(1,ZERO, ONE,.TRUE.)
          CALL HWEGAM(2,ZERO, ONE,.TRUE.)
          Z1=PHEP(4,4)/PHEP(4,1)
          Z2=PHEP(4,6)/PHEP(4,2)
C---FACTORIZE THE DISTRIBUTIONS FROM CIRCE
          C1=CIRCGG(Z1,-1D0)/SQRT(CIRCGG(-1D0,-1D0))
          C2=CIRCGG(-1D0,Z2)/SQRT(CIRCGG(-1D0,-1D0))
C---REMOVE SPURIOUS WEIGHT GIVEN IN HWEGAM
          GAMWT=GAMWT/(.5*ALPHEM/PIFAC*(1+(1-Z1)**2)/Z1*
     $         LOG((ONE-Z1)/Z1*4*PHEP(4,1)*PHEP(4,2)/PHEP(5,1)**2))
     $               /(.5*ALPHEM/PIFAC*(1+(1-Z2)**2)/Z2*
     $         LOG((ONE-Z2)/Z2*4*PHEP(4,4)*PHEP(4,2)/PHEP(5,1)**2))
C---REPLACE IT BY THE SUM OF BEAM AND BREM STRAHLUNG
          QMX1=MIN(Q2WWMX,(Z1*PHEP(3,1))**2)
          QMN1=MAX(Q2WWMN,(PHEP(5,1)*Z1)**2/(1-Z1))
          QMX2=MIN(Q2WWMX,(Z2*PHEP(3,2))**2)
          QMN2=MAX(Q2WWMN,(PHEP(5,2)*Z2)**2/(1-Z2))
          B1=.5*ALPHEM/PIFAC*(1+(1-Z1)**2)/Z1*LOG(QMX1/QMN1)
          B2=.5*ALPHEM/PIFAC*(1+(1-Z2)**2)/Z2*LOG(QMX2/QMN2)
          IF (CIRCOP.EQ.1) THEN
            GAMWT=GAMWT*B1*B2
          ELSEIF (CIRCOP.EQ.2) THEN
            GAMWT=GAMWT*C1*C2
          ELSEIF (CIRCOP.EQ.3) THEN
            GAMWT=GAMWT*(C1+B1)*(C2+B2)
          ELSE
            STOP 'Illegal value of circop!'
          ENDIF
        ENDIF
      ELSEIF (IPRO.GE.90) THEN
        IF (CIRCOP.NE.0) STOP 'Circe not interfaced for DIS processes'
        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.GT.0.AND.IPRO.LE.12) THEN
        IF (CIRCOP.EQ.0) THEN
           CALL HWEISR(1)
           CALL HWEISR(2)
        ELSE
C---MODIFIED TO USE CIRCE FOR BEAMSTRAHLUNG EFFECTS
          IF (ABS(IDHEP(1)).NE.11.OR.IDHEP(1)+IDHEP(2).NE.0) STOP
     $         'This version only works for e+e- annihilation'
          IF (FSTWGT) THEN
            RS=NINT(PHEP(5,3)*10)/1D1
            CALL CIRCES(ZERO,ZERO,RS,CIRCAC,CIRCVR,CIRCRV,CIRCCH)
C---PRECALCULATE THE PART OF THE SPECTRUM MISSED BETWEEN ZMXISR AND 1
            ETA=0.6D0
            MISS=HWUGAU(HWECIR,1D-15**(1-ETA),(1-ZMXISR)**(1-ETA),1D-12)
          ENDIF
          COLISR=.TRUE.
          CALL HWEISR(1)
          CALL HWEISR(2)
          IHAD=1
          IF (JDAHEP(1,IHAD).NE.0) IHAD=JDAHEP(1,IHAD)
          Z1=PHEP(4,IHAD)/PHEP(4,1)
          IHAD=2
          IF (JDAHEP(1,IHAD).NE.0) IHAD=JDAHEP(1,IHAD)
          Z2=PHEP(4,IHAD)/PHEP(4,2)
C---FACTORIZE THE DISTRIBUTIONS FROM CIRCE
          C1=CIRCEE(Z1,-1D0)/SQRT(CIRCEE(-1D0,-1D0))
          C2=CIRCEE(-1D0,Z2)/SQRT(CIRCEE(-1D0,-1D0))
          IF (Z1.EQ.ONE) C1=C1+MISS
          IF (Z2.EQ.ONE) C2=C2+MISS
C---REMOVE WEIGHT GIVEN IN HWEISR
          B1=CIRCKP(1)
          B2=CIRCKP(2)
          GAMWT=GAMWT/(B1*B2)
C---REPLACE IT BY THE SUM OF BEAM AND BREM STRAHLUNG
          IF (CIRCOP.EQ.1) THEN
            GAMWT=GAMWT*B1*B2
          ELSEIF (CIRCOP.EQ.2) THEN
            GAMWT=GAMWT*C1*C2
          ELSEIF (CIRCOP.EQ.3) THEN
C---IN THE APPROXIMATION OF DOMINANCE BY THE DELTA-FUNCTION TERM
            IF (Z1.EQ.ONE) C1=C1-1
            IF (Z2.EQ.ONE) C2=C2-1
C---IF IT DOES NOT DOMINATE, ZMXISR SHOULD BE DECREASED
            IF (B1+C1.LT.ZERO) CALL HWWARN('HWEPRO',501)
            IF (B2+C2.LT.ZERO) CALL HWWARN('HWEPRO',502)
            GAMWT=GAMWT*(C1+B1)*(C2+B2)
          ELSE
            STOP 'Illegal value of circop!'
          ENDIF
        ENDIF
      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)
C---PROCESS GENERATED BY LES HOUCHES INTERFACE
      IF(IPRO.LE.0) THEN
        CALL HWHGUP
      ELSEIF (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.9) THEN
        IF((MOD(IPROC,10000).EQ.955).OR.
     &     (MOD(IPROC,10000).EQ.965).OR.
     &     (MOD(IPROC,10000).EQ.975))THEN
C---MSSM Higgs pair production in l+l-: H+ H- and A0 Higgs, Higgs=h0,H0.
          CALL HWHIHH
        ELSEIF((MOD(IPROC,10000).EQ.910).OR.
     &         (MOD(IPROC,10000).EQ.920))THEN
C---MSSM scalar Higgs production from vector-vector fusion.
          CALL HWHIGW
        ELSEIF((MOD(IPROC,10000).EQ.960).OR.
     &         (MOD(IPROC,10000).EQ.970))THEN
C---MSSM scalar Higgs production from Higgs-strahlung.
          CALL HWHIGZ
        END IF
      ELSEIF ((IPRO.EQ.10).OR.(IPRO.EQ.11)) THEN
C---SM/MSSM Higgs production with heavy quark flavours via e+e-.
        CALL HWHIGE
      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).OR.(IPRO.EQ.36)) 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).OR.(IPRO.EQ.37)) THEN
C---SM/MSSM HIGGS PRODUCTION VIA W/Z 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 Higgs production with heavy quark flavours via qq and gg.
        CALL HWHIGQ
      ELSEIF ((IPRO.EQ.26).OR.(IPRO.EQ.27)) THEN
C---SM Higgs production with heavy gauge bosons via qq(').
        CALL HWHIGV
C---Gauge boson pair in hadron hadron
      ELSEIF (IPRO.EQ.28) THEN
        IF (MOD(IPROC,10000).LT.2850) THEN
          CALL HWHGBP
        ELSE
          CALL HWHVVJ
        ENDIF
C--Vector boson + two jets
      ELSEIF(IPRO.EQ.29) THEN
        CALL HWHV2J
      ELSEIF (IPRO.EQ.30) THEN
C---HADRON-HADRON SUSY PROCESSES
        CALL HWHSSP
      ELSEIF ((IPRO.EQ.31).OR.(IPRO.EQ.32)) THEN
C---MSSM charged/neutral Higgs production in association with squarks.
        CALL HWHISQ
      ELSEIF (IPRO.EQ.33) THEN
        IF(MOD(IPROC,10000).EQ.3350)THEN
C---MSSM charged Higgs production in association with W: W+H- + W-H+.
          CALL HWHIBK
        ELSEIF((MOD(IPROC,10000).EQ.3310).OR.
     &         (MOD(IPROC,10000).EQ.3320).OR.
     &         (MOD(IPROC,10000).EQ.3360).OR.
     &         (MOD(IPROC,10000).EQ.3370))THEN
C---MSSM Higgs production with heavy gauge bosons via qq(').
          CALL HWHIGV
        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.35) THEN
C---MSSM charged Higgs production via bq fusion.
        CALL HWHIBQ
      ELSEIF (IPRO.EQ.38) THEN
C---MSSM charged/neutral Higgs production with heavy quarks via qq and gg.
        CALL HWHIGQ
      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)
      ELSEIF(IPRO.EQ.95) THEN
C---HIGGS PRODUCTION VIA W FUSION IN E P
        CALL HWHIGW
      ELSE
C---UNKNOWN PROCESS
        CALL HWWARN('HWEPRO',102)
        GOTO 999
      ENDIF
 30   IF (GENEV) THEN
         IF (NOWGT) THEN
            IF (NEGWTS) THEN
               IF (EVWGT.LT.ZERO) THEN
                  EVWGT=-AVABW
               ELSE
                  EVWGT= AVABW
               ENDIF
            ELSE
               EVWGT=AVWGT
            ENDIF
         ENDIF
         ISTAT=10
C--New call spin correlation code if needed
         IF(SYSPIN.AND.(IPRO.EQ. 1.OR.IPRO.EQ.13.OR.IPRO.EQ.14.OR.
     &                  IPRO.EQ.15.OR.IPRO.EQ.17.OR.IPRO.EQ.20.OR.
     &                  IPRO.EQ. 7.OR.IPRO.EQ.30.OR.IPRO.EQ.40.OR.
     &                  IPRO.EQ.41.OR.IPRO.EQ.8)) CALL HWHSPN
C--generate additional photon radition in top production
         IF(ITOPRD.EQ.1.AND.MOD(IPROC,10000).EQ.1706) CALL HWPHTT
         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
        ABWGT=ABS(EVWGT)
        IF (EVWGT.LT.ZERO) THEN
           IF (NEGWTS) THEN
              NNEGWT=NNEGWT+1
           ELSE
              IF (EVWGT.LT.-1.D-9) CALL HWWARN('HWEPRO',3)
              EVWGT=ZERO
              ABWGT=ZERO
           ENDIF
        ENDIF
        WGTSUM=WGTSUM+EVWGT
        WSQSUM=WSQSUM+EVWGT**2
        ABWSUM=ABWSUM+ABWGT
C--weight addition for Les Houches accord
        IF(IPROC.LE.0) THEN
          IF(ABS(IDWTUP).EQ.1) THEN
             LHWGT (ITYPLH) = LHWGT (ITYPLH)+EVWGT
             LHWGTS(ITYPLH) = LHWGTS(ITYPLH)+EVWGT**2
             LHIWGT(ITYPLH) = LHIWGT(ITYPLH)+1
          ENDIF
        ENDIF
        IF (ABWGT.GT.WBIGST) THEN
           WBIGST=ABWGT
           IF (NOWGT.AND.WBIGST.GT.WGTMAX) THEN
              IF (NEVHEP.NE.0) CALL HWWARN('HWEPRO',1)
              WGTMAX=WBIGST*1.1
              WRITE (6,99) WGTMAX
C--additional for Les Houche accord
              IF(IPROC.LE.0) THEN
                IF(ABS(IDWTUP).EQ.1)
     &                LHMXSM = LHMXSM-LHXMAX(ITYPLH)+ABWGT
                LHXMAX(ITYPLH) = EVWGT
              ENDIF
           ENDIF
        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)
            IF (EFFMIN.GT.ZERO) THEN
              IF (MOD(NWGTS,INT(10/EFFMIN)).EQ.0) THEN
                CALL HWWARN('HWEPRO',2)
                WRITE (6,98) WGTMAX
              ENDIF
            ENDIF
          ENDIF
          IF (NOWGT) THEN
            GENEV=ABWGT.GT.WGTMAX*HWRGEN(0)
          ELSE
            GENEV=ABWGT.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  RETURN
      END
CDECK  ID>, HWETWO.
*CMZ :-        -26/04/91  11.11.55  by  Bryan Webber
*-- Author :    Bryan Webber
C-----------------------------------------------------------------------
      SUBROUTINE HWETWO(SMR3,SMR4)
C-----------------------------------------------------------------------
C     SETS UP 2->2 HARD SUBPROCESS
c BRW change 18/8/04: BW smearing of mass i only if SMRi is true
C-----------------------------------------------------------------------
      INCLUDE 'HERWIG65.INC'
      DOUBLE PRECISION HWUMBW,HWUPCM,PCM
      INTEGER ICMF,IBM,I,J,K,IHEP,NTRY
      LOGICAL SMR3,SMR4
      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))
C--BRW fix 5/11/08: define x as fraction of p_3 not p_+
        PHEP(3,IHEP)=XX(I)*PHEP(3,IBM)
        PHEP(4,IHEP)=SQRT(PHEP(3,IHEP)**2+PHEP(5,IHEP)**2)
C--End BRW fix 5/11/08
      ENDIF
 15   CONTINUE
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
      DO 16 I=3,4
      IHEP=NHEP+I+1
      IDHW(IHEP)=IDN(I)
      IDHEP(IHEP)=IDPDG(IDN(I))
      ISTHEP(IHEP)=110+I
      JMOHEP(1,IHEP)=ICMF
 16   JDAHEP(I-2,ICMF)=IHEP
 19   CONTINUE
      IF (SMR3) THEN
         PHEP(5,NHEP+4)=HWUMBW(IDN(3))
      ELSE
         PHEP(5,NHEP+4)=RMASS(IDN(3))
      ENDIF
      IF (SMR4) THEN
         PHEP(5,NHEP+5)=HWUMBW(IDN(4))
      ELSE
         PHEP(5,NHEP+5)=RMASS(IDN(4))
      ENDIF
      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)
        GOTO 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  RETURN
      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 'HERWIG65.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=(0D0,1D0),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
      END
CDECK  ID>, HWH2DD.
*CMZ :-        -27/02/01  17:04:16  by  Peter Richardson
*-- Author :    Peter Richardson
C-----------------------------------------------------------------------
      FUNCTION HWH2DD(ND,I,J,K,L,Z1,Z2)
C-----------------------------------------------------------------------
C     Returns the coefficient D1-10 from Nucl. Phys. B262 (1985) 235-262
C     N.B. THE STRONG COUPLING AND GV+/-GA ARE INCLUDED IN THE CROSS
C     SECTION ROUTINE
C     I-L are the particles (all outgoing)
C     Z1 and Z2 are the decay products of the Z
C-----------------------------------------------------------------------
      INCLUDE 'HERWIG65.INC'
      INTEGER ND,I,J,K,L,Z1,Z2
      DOUBLE COMPLEX HWH2DD,ZI,S,D,F
      PARAMETER(ZI=(0.0D0,1.0D0))
      COMMON/HWHEWS/S(8,8,2),D(8,8)
      COMMON/HWHZBB/F(8,8)
      IF(ND.EQ.1) THEN
        HWH2DD = ZI
      ELSEIF(ND.EQ.2) THEN
        HWH2DD =  ZI/F(J,K)/SQRT(TWO*D(I,K))
      ELSEIF(ND.EQ.3) THEN
        HWH2DD = -ZI/F(I,K)/SQRT(TWO*D(I,K))
      ELSEIF(ND.EQ.4) THEN
        HWH2DD = -ZI/F(K,L)/(F(Z1,I)+F(Z2,I)+F(Z1,Z2))
      ELSEIF(ND.EQ.5) THEN
        HWH2DD =  ZI/F(K,L)/(F(Z1,J)+F(Z2,J)+F(Z1,Z2))
      ELSEIF(ND.EQ.6) THEN
        HWH2DD =  ZI*HALF/F(J,L)/(F(J,L)+F(J,K)+F(K,L))/D(K,L)
      ELSEIF(ND.EQ.7) THEN
        HWH2DD = -ZI*HALF/F(I,K)/F(J,L)/D(K,L)
      ELSEIF(ND.EQ.8) THEN
        HWH2DD =  ZI*HALF/F(I,K)/(F(I,K)+F(I,L)+F(K,L))/D(K,L)
      ELSEIF(ND.EQ.9) THEN
        HWH2DD = -ZI/F(K,L)/(F(J,K)+F(J,L)+F(K,L))
      ELSEIF(ND.EQ.10) THEN
        HWH2DD =  ZI/F(K,L)/(F(I,K)+F(I,L)+F(K,L))
      ENDIF
      END
CDECK  ID>, HWH2BH.
*CMZ :-        -30/06/01  18.21.35  by  Stefano Moretti
*-- Author :  Kosuke Odagiri & Stefano Moretti
C-----------------------------------------------------------------------
      SUBROUTINE HWH2BH(P1,P2,P3,P4,P5,
     &                  EMW,EMH,EMH01,EMH02,EMH03,EMB,EMT,IFL,IRES,CKM,
     &                  GAMT,M2)
C-----------------------------------------------------------------------
C...Matrix element for b(1) + q(2) -> b(3) + q'(4) + H+/-(5) and C.C.,
C...q(q') massless incoming(outgoing) quark, all other masses retained.
C...It factorises 64.*PIFAC**3*ALPHA**3/4./SWEIN/SWEIN/SWEIN/EMW/EMW.
C
C...First release:  01-APR-1998 by Kosuke Odagiri
C...First modified: 12-APR-1998 by Stefano Moretti
C-----------------------------------------------------------------------
      INCLUDE 'HERWIG65.INC'
      INTEGER MU,IRES,IFL
      DOUBLE PRECISION P1(0:3),P2(0:3),P3(0:3),P4(0:3),P5(0:3)
      DOUBLE PRECISION EMB,EMT,EMW,EMH,EMH01,EMH02,EMH03
      DOUBLE PRECISION GAMT,GAMWTMP,GAMH01,GAMH03,GAMH02,CKM
      DOUBLE PRECISION QW(0:3),QS(0:3)
      DOUBLE PRECISION N0,DOTHH,DOTSS,DOTWW,E1234
      DOUBLE PRECISION DOTTT,DOT12,DOT13,DOT14,DOT23
      DOUBLE PRECISION DOT24,DOT2H,DOT34,DOT3H,DOT4H
      DOUBLE PRECISION PT2,PV2,PA2
      DOUBLE PRECISION M2
      DOUBLE COMPLEX PV,PA,PT,PW,Z
      PARAMETER (GAMWTMP=0.D0,GAMH01=0.D0,GAMH03=0.D0,GAMH02=0.D0)
      PARAMETER (Z=(0.D0,1.D0))
      DOUBLE PRECISION SC,RICCI
      EXTERNAL SC,RICCI
C
      DO 670 MU=0,3
         QW(MU)=P2(MU)-P4(MU)
         QS(MU)=P1(MU)-P3(MU)
 670  CONTINUE
C
      DOTHH=EMH*EMH
      DOTSS=SC(QS,QS)
      DOTWW=SC(QW,QW)
      DOT13=EMB*EMB-DOTSS/2.D0
      DOT24=-DOTWW/2.D0
      DOT2H=SC(P2,P5)
      DOT4H=SC(P4,P5)
C
      IF(IFL.EQ.1)THEN
        DOT12=SC(P1,P2)
        DOT14=SC(P1,P4)
        DOT23=SC(P2,P3)
        DOT34=SC(P3,P4)
        DOT3H=SC(P3,P5)
        E1234=RICCI(P1,P2,P3,P4)
      ELSE IF(IFL.EQ.-1)THEN
        DOT12=-SC(P3,P2)
        DOT14=-SC(P3,P4)
        DOT23=-SC(P2,P1)
        DOT34=-SC(P1,P4)
        DOT3H=-SC(P1,P5)
        E1234=-RICCI(P1,P2,P3,P4)
      END IF
C
      DOTTT=DOTHH+EMB*EMB+2.D0*DOT3H
C
      PV=COSA*SINBMA/(DOTSS-EMH01*EMH01+Z*EMH01*GAMH01)+
     1   SINA*COSBMA/(DOTSS-EMH02*EMH02+Z*EMH02*GAMH02)
      PA=SINB/(DOTSS-EMH03*EMH03+Z*EMH03*GAMH03)
      PW=1./(DOTWW-EMW*EMW+Z*EMW*GAMWTMP)
C REMOVE TOP DIAGRAM.
      IF(IRES.EQ.1)PT=1./(DOTTT-EMT*EMT+Z*EMT*GAMT)
      IF(IRES.EQ.0)PT=(0.D0,0.D0)
      PT=PT*CKM
      PT2 =DREAL(DCONJG(PT)*PT)
      PV2 =DREAL(DCONJG(PV)*PV)
      PA2 =DREAL(DCONJG(PA)*PA)
C
      N0=ABS(PW)
C
      M2=N0*N0* ( EMB*EMB/COSB/COSB*(PV2+PA2)*DOT13*
     &   (2.D0*DOT4H*DOT2H-DOT24*DOTHH)+
     T 2.D0*PT2*DOT12*
     O   (EMB*EMB*TANB*TANB*(2.D0*DOT3H*DOT4H-DOT34*DOTHH)+
     P    EMT*EMT/TANB/TANB*(EMT*EMT*DOT34))+
     & EMB*EMB*TANB/COSB*DREAL(PV+PA)*
     X   (DREAL(PT)*(4.D0*DOT4H*DOT12*DOT13-
     T    (2.D0*DOT4H+DOTHH)*(DOT12*DOT34+DOT13*DOT24-DOT14*DOT23))+
     M    DIMAG(PT)*(2.D0*DOT4H+DOTHH)*E1234) )
      END
C
      DOUBLE PRECISION FUNCTION SC(A,B)
      IMPLICIT NONE
      DOUBLE PRECISION A(0:3),B(0:3)
      SC=A(0)*B(0)-A(1)*B(1)-A(2)*B(2)-A(3)*B(3)
      END
C
      DOUBLE PRECISION FUNCTION RICCI(A,B,C,D)
      IMPLICIT NONE
      DOUBLE PRECISION A(0:3),B(0:3),C(0:3),D(0:3)
      RICCI=
     & A(0)*B(1)*C(2)*D(3)+A(0)*B(2)*C(3)*D(1)+A(0)*B(3)*C(1)*D(2)-
     & A(0)*B(3)*C(2)*D(1)-A(0)*B(1)*C(3)*D(2)-A(0)*B(2)*C(1)*D(3)+
     & A(1)*B(0)*C(3)*D(2)+A(1)*B(2)*C(0)*D(3)+A(1)*B(3)*C(2)*D(0)-
     & A(1)*B(2)*C(3)*D(0)-A(1)*B(3)*C(0)*D(2)-A(1)*B(0)*C(2)*D(3)+
     & A(2)*B(3)*C(0)*D(1)+A(2)*B(0)*C(1)*D(3)+A(2)*B(1)*C(3)*D(0)-
     & A(2)*B(1)*C(0)*D(3)-A(2)*B(3)*C(1)*D(0)-A(2)*B(0)*C(3)*D(1)+
     & A(3)*B(2)*C(1)*D(0)+A(3)*B(0)*C(2)*D(1)+A(3)*B(1)*C(0)*D(2)-
     & A(3)*B(0)*C(1)*D(2)-A(3)*B(1)*C(2)*D(0)-A(3)*B(2)*C(0)*D(1)
      END
CDECK  ID>, HWH2F1
*CMZ :-        -27/02/01  17:04:16  by  Peter Richardson
C-----------------------------------------------------------------------
      SUBROUTINE HWH2F1(NP,F,I,P,MQ)
C-----------------------------------------------------------------------
C     Subroutine to implement the F function of Eijk and Kliess
C     fixed first momenta and all second momenta
C-----------------------------------------------------------------------
      INCLUDE 'HERWIG65.INC'
      DOUBLE PRECISION P(5),MQ,PM(5),XMASS,PLAB,PRW,PCM,HWULDO,PDOT,EPS
      DOUBLE COMPLEX F(2,2,8),S,D,SIP(2),SJP(2)
      INTEGER I,J,NP
      EXTERNAL HWULDO
      COMMON/HWHEWS/S(8,8,2),D(8,8)
      COMMON/HWHEWP/XMASS(10),PLAB(5,10),PRW(5,2),PCM(5,10)
      PARAMETER(EPS=1D-10)
C--find the massless momentum we need
      PDOT = HWULDO(PCM(1,I),P)
      P(5) = P(4)**2-P(1)**2-P(2)**2-P(3)**2
      IF(ABS(PDOT).LT.EPS.AND.ABS(P(5)).LT.EPS) THEN
         PDOT = HALF
      ELSE
         PDOT = HALF*P(5)/PDOT
      ENDIF
      DO J=1,4
        PM(J) = P(J)-PDOT*PCM(J,I)
      ENDDO
      IF(P(5).GT.ZERO) THEN
         P(5)=SQRT(P(5))
      ELSE
         P(5)=ZERO
      ENDIF
      PM(5) = ZERO
C--calculate its spinor product with the fixed momentum
      CALL HWH2SS(SIP,PCM(1,I),PM)
C--calculate the F functions
      DO J=1,NP
        CALL HWH2SS(SJP,PM,PCM(1,J))
        F(1,1,J) = SIP(1)*SJP(2)
        F(1,2,J) = MQ*S(I,J,1)
        F(2,1,J) = MQ*S(I,J,2)
        F(2,2,J) = SIP(2)*SJP(1)
      ENDDO
      END
CDECK  ID>, HWH2F2
*CMZ :-        -27/02/01  17:04:16  by  Peter Richardson
C-----------------------------------------------------------------------
      SUBROUTINE HWH2F2(NP,F,I,P,MQ)
C-----------------------------------------------------------------------
C     Subroutine to implement the F function of Eijk and Kliess
C     fixed second momenta and all first momenta
C-----------------------------------------------------------------------
      INCLUDE 'HERWIG65.INC'
      DOUBLE PRECISION P(5),MQ,PM(5),XMASS,PLAB,PRW,PCM,HWULDO,PDOT,EPS
      DOUBLE COMPLEX F(2,2,8),S,D,SIP(2),SJP(2)
      INTEGER I,J,NP
      EXTERNAL HWULDO
      COMMON/HWHEWS/S(8,8,2),D(8,8)
      COMMON/HWHEWP/XMASS(10),PLAB(5,10),PRW(5,2),PCM(5,10)
      PARAMETER(EPS=1D-10)
C--find the massless momentum we need
      PDOT = HWULDO(PCM(1,I),P)
      P(5) = P(4)**2-P(1)**2-P(2)**2-P(3)**2
      IF(ABS(PDOT).LT.EPS.AND.ABS(P(5)).LT.EPS) THEN
         PDOT = HALF
      ELSE
         PDOT = HALF*P(5)/PDOT
      ENDIF
      DO J=1,4
        PM(J) = P(J)-PDOT*PCM(J,I)
      ENDDO
      IF(P(5).GT.ZERO) THEN
         P(5)=SQRT(P(5))
      ELSE
         P(5)=ZERO
      ENDIF
      PM(5) = ZERO
C--calculate its spinor product with the fixed momentum
      CALL HWH2SS(SIP,PM,PCM(1,I))
C--calculate the F functions
      DO J=1,NP
        CALL HWH2SS(SJP,PCM(1,J),PM)
        F(1,1,J) = SIP(2)*SJP(1)
        F(1,2,J) = MQ*S(J,I,1)
        F(2,1,J) = MQ*S(J,I,2)
        F(2,2,J) = SIP(1)*SJP(2)
      ENDDO
      END
CDECK  ID>, HWH2F3
*CMZ :-        -27/02/01  17:04:16  by  Peter Richardson
C-----------------------------------------------------------------------
      SUBROUTINE HWH2F3(NP,F,P,MQ)
C-----------------------------------------------------------------------
C     Subroutine to implement the F function of Eijk and Kliess
C     All first and second momenta
C-----------------------------------------------------------------------
      INCLUDE 'HERWIG65.INC'
      DOUBLE PRECISION P(5),MQ,PM(5),XMASS,PLAB,PRW,PCM,HWULDO,PDOT,EPS
      DOUBLE COMPLEX F(2,2,8,8),SIP(2),SJP(2),S,D
      INTEGER I,J,NP
      COMMON/HWHEWS/S(8,8,2),D(8,8)
      COMMON/HWHEWP/XMASS(10),PLAB(5,10),PRW(5,2),PCM(5,10)
      EXTERNAL HWULDO
      PARAMETER(EPS=1D-10)
C--find the massless momentum we need
      DO I=1,NP
        PDOT = HWULDO(PCM(1,I),P)
        P(5) = P(4)**2-P(1)**2-P(2)**2-P(3)**2
        IF(ABS(PDOT).LT.EPS.AND.ABS(P(5)).LT.EPS) THEN
           PDOT = HALF
        ELSE
           PDOT = HALF*P(5)/PDOT
        ENDIF
        DO J=1,4
          PM(J) = P(J)-PDOT*PCM(J,I)
        ENDDO
        IF(P(5).GT.ZERO) THEN
           P(5)=SQRT(P(5))
        ELSE
           P(5)=ZERO
        ENDIF
        PM(5) = ZERO
C--calculate its spinor product with the fixed momentum
        CALL HWH2SS(SIP,PCM(1,I),PM)
C--calculate the F functions
        DO J=I,NP
          CALL HWH2SS(SJP,PM,PCM(1,J))
          F(1,1,I,J) = SIP(1)*SJP(2)
          F(1,2,I,J) = MQ*S(I,J,1)
          F(2,1,I,J) = MQ*S(I,J,2)
          F(2,2,I,J) = SIP(2)*SJP(1)
        ENDDO
      ENDDO
      DO I=1,NP
        DO J=I+1,NP
          F(1,1,J,I) =  F(2,2,I,J)
          F(1,2,J,I) = -F(1,2,I,J)
          F(2,1,J,I) = -F(2,1,I,J)
          F(2,2,J,I) =  F(1,1,I,J)
        ENDDO
      ENDDO
      END
CDECK  ID>, HWH2HE.
*CMZ :-        -13/10/02  09.43.05  by  Peter Richardson
*-- Author :    Kosuke Odagiri and Stefano Moretti
C-----------------------------------------------------------------------
      SUBROUTINE HWH2HE(FIRST,GAUGE,IFL,IH,HFC,HBC,
     & E,S2W,TANB,AL,RMW,S,Q3, P3,P4,P5,
     & RM3,YM3,GAM3,RM4,YM4,GAM4,RM5,GAM5,
     & RML,GAML,RMH,GAMH,RMA,GAMA,
     & RMZ,GAMZ,CFAC,RES)
C-----------------------------------------------------------------------
C     MATRIX ELEMENT SQUARED FOR
C     e-(1) e+(2) -> f(3) f(')bar(4) Higgs(5)
C     (SAME QUARK MASSES IN YUKAWA AND KINEMATICS)
C-----------------------------------------------------------------------
      IMPLICIT NONE
      LOGICAL FIRST,GAUGE
      DOUBLE PRECISION HFC,HBC
      DOUBLE PRECISION CFAC
      DOUBLE PRECISION E,S2W,TANB,AL,RMW,S,Q3,RES
      DOUBLE PRECISION P3(0:3),P4(0:3),P5(0:3)
      DOUBLE PRECISION RM3,YM3,GAM3,RM4,YM4,GAM4,RM5,GAM5,RMZ,GAMZ
      DOUBLE PRECISION RML,GAML,RMH,GAMH,RMA,GAMA,Q2
      DOUBLE PRECISION XW,GE(-1:1),G3(-1:1),G4(-1:1),G5(-1:1)
      DOUBLE PRECISION RM(-1:1),RN1(-1:1),RN2(-1:1),RN3
      DOUBLE PRECISION SQS,TWOSQS,HLFSQS,P34,M34,PREFAC
      DOUBLE PRECISION RLE,RLLE,EP3(-1:1),EP4(-1:1),ZERO,ONE,TWO,HLF
      DOUBLE PRECISION BE,SA,CA,SB,CB
      INTEGER I,LE,L,IFL,IH
      DOUBLE COMPLEX PROPZ,PROP3(-1:1),PROP4(-1:1),PROP5,PROP6
      DOUBLE COMPLEX PROP7(-1:1)
      DOUBLE COMPLEX PP(-1:1),MM(-1:1),QQ(-1:1),ZP3,ZP4,ZP5
      PARAMETER (ZERO=0.D0,ONE=1.D0,TWO=2.D0,HLF=.5D0)
      SAVE XW,GE,G3,G4,G5,RM,PREFAC
C QUANTITIES WHICH CAN BE COMPUTED ONLY ONCE
      IF(FIRST)THEN
C SOME COMMON INITIALISATIONS
        DO I=-1,1
          RM(I)=ZERO
          RN1(I)=ZERO
          RN2(I)=ZERO
        END DO
        RN3=ZERO
        XW=TWO*S2W
        GE( 0)=-ONE
        GE(+1)=-GE(0)*XW
        GE(-1)=-ONE+GE(1)
        IF(IH.LE.3)THEN
          G3( 0)=Q3
          G3(+1)=-G3(0)*XW
          G3(-1)=-ONE*(-Q3/ABS(Q3))+G3(1)
          G4( 0)=G3( 0)
          G4(+1)=G3(+1)
          G4(-1)=G3(-1)
          G5( 0)=ZERO
          G5(+1)=ONE
          G5(-1)=ONE
C HIGGS ANGLES
          BE=ATAN(TANB)
          SA=SIN(AL)
          CA=COS(AL)
          SB=SIN(BE)
          CB=COS(BE)
C MSSM SCALING FACTORS FOR COUPLINGS
          IF(IH.LE.2)THEN
            RM(-1)=+YM3/RMW*HFC
            RM(+1)=+YM4/RMW*HFC
          ELSE IF(IH.EQ.3)THEN
            RM(-1)=+YM3/RMW*HFC
            RM(+1)=-YM4/RMW*HFC
          END IF
          IF(IH.LE.2)THEN
            IF(IH.EQ.1)RN1(-1)=+YM3/RMW*((2-IFL)*TANB+(IFL-1)/TANB)
     &                        *(-SQRT(ABS(ONE-HBC**2)))
            IF(IH.EQ.1)RN1(+1)=-YM4/RMW*((2-IFL)*TANB+(IFL-1)/TANB)
     &                        *(-SQRT(ABS(ONE-HBC**2)))
            IF(IH.EQ.2)RN1(-1)=-YM3/RMW*((2-IFL)*TANB+(IFL-1)/TANB)
     &                        *(+SQRT(ABS(ONE-HBC**2)))
            IF(IH.EQ.2)RN1(+1)=+YM4/RMW*((2-IFL)*TANB+(IFL-1)/TANB)
     &                        *(+SQRT(ABS(ONE-HBC**2)))
            RN2(-1)=ZERO
            RN2(+1)=ZERO
            IF(IH.EQ.0)RN3=1.D0
            IF(IH.EQ.1)RN3=HBC
            IF(IH.EQ.2)RN3=HBC
          ELSE IF(IH.EQ.3)THEN
            RN1(-1)=+YM3/RMW*((2-IFL)*(-SA/CB)+(IFL-1)*(+CA/SB))
     &                      *COS(BE-AL)
            RN1(+1)=+YM4/RMW*((2-IFL)*(-SA/CB)+(IFL-1)*(+CA/SB))
     &                      *COS(BE-AL)
            RN2(-1)=+YM3/RMW*((2-IFL)*(+CA/CB)+(IFL-1)*(+SA/SB))
     &                      *SIN(BE-AL)
            RN2(+1)=+YM4/RMW*((2-IFL)*(+CA/CB)+(IFL-1)*(+SA/SB))
     &                      *SIN(BE-AL)
            RN3=ZERO
          END IF
          PREFAC=E**6/(XW*S)*CFAC/TWO
        ELSE
          G3( 0)=Q3
          G3(+1)=-G3(0)*XW
          G3(-1)=-ONE+G3(1)
          G4( 0)=ONE+G3(0)
          G4(+1)=-G4(0)*XW
          G4(-1)=ONE+G4(1)
          G5( 0)=ONE
          G5(+1)=ONE-XW
          G5(-1)=ONE-XW
          RM(-1)=YM3*TANB/RMW
          RM(+1)=YM4/TANB/RMW
          RN1(-1)=RM(-1)
          RN1(+1)=RM(+1)
          RN2(-1)=ZERO
          RN2(+1)=ZERO
          RN3=ZERO
          PREFAC=E**6/(XW*S)*CFAC
        END IF
        FIRST=.FALSE.
      END IF
C SOME ENERGY CONSTANTS
      SQS=DSQRT(S)
      TWOSQS=TWO*SQS
      HLFSQS=HLF*SQS
      PROPZ=S/(XW*(TWO-XW)*DCMPLX(S-RMZ**2,-RMZ*GAMZ))
C SOME KINEMATICS
      P34=P3(0)*P4(0)-P3(1)*P4(1)-P3(2)*P4(2)-P3(3)*P4(3)
      M34=RM3*RM4
      RES=ZERO
C FF(')-BAR PROPAGATOR
      Q2=RM3**2+RM4**2+TWO*P34
C CONSTRUCT AMPLITUDE
      DO LE=-1,1,2
        RLE=DFLOAT(LE)
        IF(IH.LE.2)THEN
          PROP5=(GE(0)*G5(0)+GE(LE)*G5(-1)*PROPZ)/
     &                 DCMPLX(Q2-RMA**2,-RMA*GAMA)
          PROP6=(0.D0,0.D0)
        ELSE IF(IH.EQ.3)THEN
          PROP5=(GE(0)*G5(0)+GE(LE)*G5(-1)*PROPZ)/
     &                 DCMPLX(Q2-RML**2,-RML*GAML)
          PROP6=(GE(0)*G5(0)+GE(LE)*G5(-1)*PROPZ)/
     &                 DCMPLX(Q2-RMH**2,-RMH*GAMH)
        ELSE
          PROP5=(GE(0)*G5(0)+GE(LE)*G5(-1)*PROPZ)/
     &                 DCMPLX(Q2-RM5**2,-RM5*GAM5)
        END IF
        ZP3=DCMPLX(P3(1),-RLE*P3(2))
        ZP4=DCMPLX(P4(1),-RLE*P4(2))
        ZP5=-ZP3-ZP4
        DO L=-1,1,2
          PROP3(L)=(GE(0)*G3(0)+GE(LE)*G3(L)*PROPZ)/
     &               DCMPLX(S-TWOSQS*P3(0),-RM3*GAM3)
          PROP4(L)=(GE(0)*G4(0)+GE(LE)*G4(L)*PROPZ)/
     &               DCMPLX(S-TWOSQS*P4(0),-RM4*GAM4)
          PROP7(L)=GE(LE)*G3(L)*PROPZ/DCMPLX(Q2-RMZ**2,-RMZ*GAMZ)
        END DO
        DO L=-1,1,2
          PP(L)=-RM(-L)*SQS*(PROP3(L)+PROP4(-L))
          MM(L)=RM3*RM(+L)*(PROP3(L)-PROP3(-L))
     &         +RM4*RM(-L)*(PROP4(L)-PROP4(-L))
     &         +TWO*RMZ**2/RMW*RN3*PROP7(L)
          IF(GAUGE)THEN
            ZP3=P3(0)-HLFSQS
            ZP4=P4(0)-HLFSQS
            ZP5=P5(0)-HLFSQS
            PP(L)=DCMPLX(ZERO,ZERO)
            MM(L)=MM(L)+PROPZ*GE(LE)*DFLOAT(L)/TWOSQS*
     &                           (RM3*RM(L)/ZP3-RM4*RM(-L)/ZP4)
          END IF
          QQ(L)=RM(L)*(PROP3(-L)*ZP3-PROP4(L)*ZP4)
     &         +RN1(L)*PROP5*ZP5
     &         -RN2(L)*PROP6*ZP5
     &         +RM3/RMW*RN3*(PROP7(L)-PROP7(-L))*ZP5
          RLLE=DFLOAT(L*LE)
          EP3(L)=P3(0)+RLLE*P3(3)
          EP4(L)=P4(0)+RLLE*P4(3)
        END DO
        DO L=-1,1,2
          RES=RES+DREAL(
     &      EP3(+L)*EP4(+L)*DCONJG(PP(+L))*PP(+L)+
     &      EP3(+L)*EP4(-L)*DCONJG(MM(+L))*MM(+L)-
     &      TWO*RM3*EP4(+L)*DCONJG(PP(+L))*MM(-L)-
     &      TWO*RM4*EP3(+L)*DCONJG(PP(+L))*MM(+L)+
     &      M34*(DCONJG(PP(-L))*PP(+L)+DCONJG(MM(-L))*MM(+L))
     &      +TWO*DCONJG(QQ(-L))
     &      *((RM3*MM(-L)-EP3(+L)*PP(+L))*ZP4-
     &        (RM4*MM(+L)-EP4(+L)*PP(+L))*ZP3+
     &        P34*QQ(-L)-M34*QQ(+L)))
        END DO
      END DO
      RES=PREFAC*RES
      END
CDECK  ID>, HWH2M0.
*CMZ :-        -14/03/01  09:03:25  by  Peter Richardson
*-- Author :    Peter Richardson
C-----------------------------------------------------------------------
      SUBROUTINE HWH2M0(IQ,IDZ,MG,MQ)
C-----------------------------------------------------------------------
C     Massless matrix elements for gg-->qqZ and qq-->qqZ
C     using the matrix elements given in Nucl. Phys. B262 (1985) 235-242
C-----------------------------------------------------------------------
      INCLUDE 'HERWIG65.INC'
      INTEGER IQ,I,J,OZ(2,2),IDZ,P1,P2,P3,P4,IQI,ID(2),K
      DOUBLE PRECISION MG(2),MQ(2,5),G(12,2),FLOW(3,3),CQFC,CQIFC,
     &     CGFC,CGIFC
      DOUBLE COMPLEX MQAMP(2),HWH2T1,HWH2T2,HWH2T3,HWH2T4,HWH2T5,
     &     HWH2T6,HWH2T7,HWH2T8,HWH2T9,HWH2T0,DCF(8),HWH2DD,
     &     MGAMP(2,2,2,2,2),TRPGL(2)
      EXTERNAL HWH2DD,HWH2T0,HWH2T1,HWH2T2,HWH2T3,HWH2T4,HWH2T5,HWH2T6,
     &         HWH2T7,HWH2T8,HWH2T9
      PARAMETER(CQFC=2.0D0,CQIFC=-2.0D0/3.0D0,CGFC=16.0D0/3.0D0,
     &          CGIFC=-2.0D0/3.0D0)
      COMMON /HWHZBC/G
      SAVE OZ,ID
      DATA OZ/6,5,5,6/
      DATA ID/1,2/
C--flavour of the final-state quark (1 is down-type and 2 is up-type)
      IQI  = MOD(IQ,2)
      IF(IQI.EQ.0) IQI=2
C--calculate qqbar---> q'q'barZ
      DCF(1) = HWH2DD(4,2,1,3,4,5,6)
      DCF(2) = HWH2DD(5,2,1,3,4,5,6)
      DCF(3) = HWH2DD(4,3,4,2,1,5,6)
      DCF(4) = HWH2DD(5,3,4,2,1,5,6)
      DCF(5) = HWH2DD(4,3,1,2,4,5,6)
      DCF(6) = HWH2DD(5,3,1,2,4,5,6)
      DCF(7) = HWH2DD(4,2,4,3,1,5,6)
      DCF(8) = HWH2DD(5,2,4,3,1,5,6)
      DO I=1,3
        DO J=1,3
          FLOW(I,J) = ZERO
        ENDDO
      ENDDO
      DO I=1,2
C--calculate the matrix element, N.B. two possibe colour flows
       DO P1=1,2
        DO P2=1,2
         DO P3=1,2
            MQAMP(1)= G(IDZ,P3)*(
     &      G(ID(I),P1)*(DCF(1)*HWH2T4(2,1,3,4,OZ(P3,1),OZ(P3,2),P1,P2)
     &                  +DCF(2)*HWH2T5(2,1,3,4,OZ(P3,1),OZ(P3,2),P1,P2))
     &       +G(IQ,P2)*(DCF(3)*HWH2T4(3,4,2,1,OZ(P3,1),OZ(P3,2),P2,P1)
     &                 +DCF(4)*HWH2T5(3,4,2,1,OZ(P3,1),OZ(P3,2),P2,P1)))
          IF(ID(I).NE.IQI) THEN
            MQAMP(2)=ZERO
          ELSE
            MQAMP(2)= G(IDZ,P3)*(
     &        G(IQ,P1)*(DCF(5)*HWH2T4(3,1,2,4,OZ(P3,1),OZ(P3,2),P1,P2)
     &                 +DCF(6)*HWH2T5(3,1,2,4,OZ(P3,1),OZ(P3,2),P1,P2))
     &       +G(IQ,P2)*(DCF(7)*HWH2T4(2,4,3,1,OZ(P3,1),OZ(P3,2),P2,P1)
     &                 +DCF(8)*HWH2T5(2,4,3,1,OZ(P3,1),OZ(P3,2),P2,P1)))
          ENDIF
          FLOW(I,1) = FLOW(I,1)+DBLE(MQAMP(1)*DCONJG(MQAMP(1)))
          FLOW(I,2) = ZERO
          FLOW(I,3) = ZERO
          IF(IQI.EQ.ID(I)) THEN
            FLOW(3,1) = FLOW(3,1)+DBLE(MQAMP(1)*DCONJG(MQAMP(1)))
            FLOW(3,2) = FLOW(3,2)+DBLE(MQAMP(2)*DCONJG(MQAMP(2)))
            IF(P1.EQ.P2) FLOW(3,3) = FLOW(3,3)
     &                         -TWO*DBLE(MQAMP(1)*DCONJG(MQAMP(2)))
          ENDIF
         ENDDO
        ENDDO
       ENDDO
      ENDDO
      DO I=1,3
        FLOW(I,1) =  CQFC*FLOW(I,1)
        FLOW(I,2) =  CQFC*FLOW(I,2)
        FLOW(I,3) = CQIFC*FLOW(I,3)
      ENDDO
C--now find the matrix elements
      DO I=1,5
        K = MOD(I,2)
        IF(K.EQ.0) K=2
        IF(I.EQ.IQ) K=3
        DO J=1,2
          IF(FLOW(K,J).NE.ZERO) MQ(J,I) = FLOW(K,J)*
     &                           (ONE+FLOW(K,3)/(FLOW(K,1)+FLOW(K,2)))
        ENDDO
      ENDDO
C--calculate gg---> bbbarZ
C--coefficients for the diagrams
      DCF(1) = HWH2DD( 6,3,4,1,2,5,6)
      DCF(2) = HWH2DD( 7,3,4,1,2,5,6)
      DCF(3) = HWH2DD( 8,3,4,1,2,5,6)
      DCF(4) = HWH2DD( 6,3,4,2,1,5,6)
      DCF(5) = HWH2DD( 7,3,4,2,1,5,6)
      DCF(6) = HWH2DD( 8,3,4,2,1,5,6)
      DCF(7) = HWH2DD( 9,3,4,1,2,5,6)
      DCF(8) = HWH2DD(10,3,4,1,2,5,6)
C--helicity amplitudes
      DO P1=1,2
       DO P2=1,2
         DO P3=1,2
          DO P4=1,2
           TRPGL(1)=
     &            DCF(7)*HWH2T9(3,4,1,2,OZ(P4,1),OZ(P4,2),P3,P1,P2)
     &           +DCF(8)*HWH2T0(3,4,1,2,OZ(P4,1),OZ(P4,2),P3,P1,P2)
           TRPGL(2)=
     &            DCF(7)*HWH2T9(3,4,1,2,OZ(P4,1),OZ(P4,2),P3,P2,P1)
     &           +DCF(8)*HWH2T0(3,4,1,2,OZ(P4,1),OZ(P4,2),P3,P2,P1)
           MGAMP(1,P1,P2,P3,P4) = G(IDZ,P4)*G(IQ,P3)*(
     &          TRPGL(1)
     &         +DCF(1)*HWH2T6(3,4,1,2,OZ(P4,1),OZ(P4,2),P3,P1,P2)
     &         +DCF(2)*HWH2T7(3,4,1,2,OZ(P4,1),OZ(P4,2),P3,P1,P2)
     &         +DCF(3)*HWH2T8(3,4,1,2,OZ(P4,1),OZ(P4,2),P3,P1,P2)
     &          )
           MGAMP(2,P2,P1,P3,P4) = G(IDZ,P4)*G(IQ,P3)*(-TRPGL(2)
     &         +DCF(4)*HWH2T6(3,4,2,1,OZ(P4,1),OZ(P4,2),P3,P1,P2)
     &         +DCF(5)*HWH2T7(3,4,2,1,OZ(P4,1),OZ(P4,2),P3,P1,P2)
     &         +DCF(6)*HWH2T8(3,4,2,1,OZ(P4,1),OZ(P4,2),P3,P1,P2))
         ENDDO
        ENDDO
       ENDDO
      ENDDO
C--square to obtain the matrix element
      DO I=1,3
        FLOW(1,I) = ZERO
      ENDDO
      DO P1=1,2
        DO P2=1,2
          DO P3=1,2
            DO P4=1,2
             FLOW(1,1) = FLOW(1,1)+DBLE(MGAMP(1,P1,P2,P3,P4)*
     &                              DCONJG(MGAMP(1,P1,P2,P3,P4)))
             FLOW(1,2) = FLOW(1,2)+DBLE(MGAMP(2,P1,P2,P3,P4)*
     &                              DCONJG(MGAMP(2,P1,P2,P3,P4)))
             FLOW(1,3) = FLOW(1,3)+TWO*DBLE(MGAMP(1,P1,P2,P3,P4)*
     &                              DCONJG(MGAMP(2,P1,P2,P3,P4)))
            ENDDO
          ENDDO
        ENDDO
      ENDDO
      FLOW(1,1) = CGFC*FLOW(1,1)
      FLOW(1,2) = CGFC*FLOW(1,2)
      FLOW(1,3) = CGIFC*FLOW(1,3)
      DO I=1,2
        MG(I) = FLOW(1,I)*(ONE+FLOW(1,3)/(FLOW(1,1)+FLOW(1,2)))
      ENDDO
      END
CDECK  ID>, HWH2MQ.
*CMZ :-        -14/03/01  09:03:25  by  Peter Richardson
*-- Author :    Peter Richardson
C-----------------------------------------------------------------------
      SUBROUTINE HWH2MQ(IQ,IDZ,MG,MQ)
C-----------------------------------------------------------------------
C     Massive matrix elements for gg --> qqbarZ and qqbar --> qqbarZ
C-----------------------------------------------------------------------
      INCLUDE 'HERWIG65.INC'
      INTEGER IQ,I,IDZ,P1,P2,PL,PB,PBB,O(2),J,IQI
      DOUBLE PRECISION MG(2),MQ(2,5),G(12,2),CQFC,CQIFC,CGFC,CGIFC,
     &     PTMP(5,10),XMASS,PLAB,PRW,PCM,HWULDO,QBL,QBBL,Q2B,Q1B,Q2BB,
     &     Q1BB,QM2,FLOW(3,3),PG,PBQB,PBBQBB,QM,PQ,Q1L,Q2L,
     &     Q1LB,Q2LB,MQB(2,3),QBB
      DOUBLE COMPLEX S,D,FBB(2,2,8),FBBB(2,2,8),FBLL(2,2,8,8),MQP(2),
     &     FBBLL(2,2,8,8),F1B(2,2,8,8),F1BB(2,2,8,8),F2B(2,2,8,8),
     &     F2BB(2,2,8,8),DL(2,2),DCF(8),MGAMP(3),MQAMP(3,2,2,2,2),
     &     MQQAMP(2,2,2,2,2),F1LL(2,2,8,8),F2LL(2,2,8,8)
      COMMON/HWHZBC/G
      COMMON/HWHEWS/S(8,8,2),D(8,8)
      COMMON/HWHEWP/XMASS(10),PLAB(5,10),PRW(5,2),PCM(5,10)
      PARAMETER(CQFC=2.0D0,CQIFC=-2.0D0/3.0D0,CGFC=16.0D0/3.0D0,
     &          CGIFC=-2.0D0/3.0D0)
      EXTERNAL HWULDO
      SAVE DL,O
      DATA DL/(1.0D0,0.0D0),(0.0D0,0.0D0),(0.0D0,0.0D0),(1.0D0,0.0D0)/
      DATA O   /2,1/
C--mass of the final-state quark
      QM  = RMASS(IQ)
      QM2 = RMASS(IQ)**2
C--first calculate the F functions we will need
      DO I=1,4
        PTMP(I,1)  =  PCM(I,9)+PCM(I,5)+PCM(I,6)
        PTMP(I,2)  = -PCM(I,10)-PCM(I,5)-PCM(I,6)
        PTMP(I,3)  =  PCM(I,9)-PCM(I,1)
        PTMP(I,4)  =  PCM(I,1)-PCM(I,10)
        PTMP(I,5)  =  PCM(I,9)-PCM(I,2)
        PTMP(I,6)  =  PCM(I,2)-PCM(I,10)
        PTMP(I,7)  =  PCM(I,9)
        PTMP(I,8)  = -PCM(I,10)
        PTMP(I,9)  = PCM(I,1)-PCM(I,5)-PCM(I,6)
        PTMP(I,10) =-PCM(I,2)+PCM(I,5)+PCM(I,6)
      ENDDO
      CALL HWH2F3(8,FBLL ,  PTMP(1, 1),QM)
      CALL HWH2F3(8,FBBLL,  PTMP(1, 2),QM)
      CALL HWH2F3(8,F1B  ,  PTMP(1, 3),QM)
      CALL HWH2F3(8,F1BB ,  PTMP(1, 4),QM)
      CALL HWH2F3(8,F2B  ,  PTMP(1, 5),QM)
      CALL HWH2F3(8,F2BB ,  PTMP(1, 6),QM)
      CALL HWH2F1(8,FBB  ,3,PTMP(1, 7),QM)
      CALL HWH2F2(8,FBBB ,4,PTMP(1, 8),QM)
      CALL HWH2F3(8,F1LL ,  PTMP(1, 9),QM)
      CALL HWH2F3(8,F2LL ,  PTMP(1,10),QM)
C--calculate the momenta squared for the denominators
      QBB = HALF/(QM2+HWULDO(PCM(1,9),PCM(1,10)))
      QBL   = ONE/(HWULDO(PTMP(1,1),PTMP(1,1))-QM2)
      QBBL  = ONE/(HWULDO(PTMP(1,2),PTMP(1,2))-QM2)
      Q1B   = ONE/(HWULDO(PTMP(1,3),PTMP(1,3))-QM2)
      Q1BB  = ONE/(HWULDO(PTMP(1,4),PTMP(1,4))-QM2)
      Q2B   = ONE/(HWULDO(PTMP(1,5),PTMP(1,5))-QM2)
      Q2BB  = ONE/(HWULDO(PTMP(1,6),PTMP(1,6))-QM2)
      Q1L  = HWULDO(PTMP(1, 9),PTMP(1, 9))
      Q2L  = HWULDO(PTMP(1,10),PTMP(1,10))
      Q1LB = ONE/(Q1L-QM2)
      Q2LB = ONE/(Q2L-QM2)
      Q1L  = ONE/Q1L
      Q2L  = ONE/Q2L
C--first construct the massless momenta
      PBQB   = HWULDO(PCM(1,3),PCM(1,9))
      PBBQBB = HWULDO(PCM(1,4),PCM(1,10))
C--first gg  --> q qbar Z
C--calculate the denominators due gluon polaizations and massive quarks
      PG   = 0.25D0/(PBQB*PBBQBB*DREAL(D(1,2)*D(1,2)))
C--and the denominators
      DCF(1) = FOUR*QBL*Q2BB
      DCF(2) = FOUR*QBL*Q1BB
      DCF(3) = FOUR*Q1B*Q2BB
      DCF(4) = FOUR*Q2B*Q1BB
      DCF(5) = FOUR*Q1B*QBBL
      DCF(6) = FOUR*Q2B*QBBL
      DCF(7) =  TWO*QBL/D(1,2)
      DCF(8) =  TWO*QBBL/D(1,2)
C--now calculate the matrix elements we need
      DO I=1,3
        FLOW(1,I) = ZERO
      ENDDO
      DO P1=1,2
      DO P2=1,2
      DO PL=1,2
      DO PB=1,2
      DO PBB=1,2
C--first amplitude from notes
        MGAMP(1) = DCF(1)*(
     &     ( G(IQ,O(PL))*FBB(PB,   PL,6)*FBLL(  PL ,P1,5,2)
     &      +G(IQ,  PL )*FBB(PB,O(PL),5)*FBLL(O(PL),P1,6,2))*
     &         (F2BB(  P1 ,  P2 ,1,1)*FBBB(  P2 ,PBB,2)+
     &          F2BB(  P1 ,O(P2),1,2)*FBBB(O(P2),PBB,1))
     &    +( G(IQ,O(PL))*FBB(PB,  PL ,6)*FBLL(   PL,O(P1),5,1)
     &      +G(IQ,  PL )*FBB(PB,O(PL),5)*FBLL(O(PL),O(P1),6,1))*
     &         (F2BB(O(P1),  P2 ,2,1)*FBBB(  P2 ,PBB,2)+
     &          F2BB(O(P1),O(P2),2,2)*FBBB(O(P2),PBB,1)))
C--second amplitude from notes (1st with gluons interchanged)
        MGAMP(2) = DCF(2)*(
     &     ( G(IQ,O(PL))*FBB(PB,  PL ,6)*FBLL(  PL ,  P2 ,5,1)
     &      +G(IQ,  PL )*FBB(PB,O(PL),5)*FBLL(O(PL),  P2 ,6,1))*
     &         (F1BB(  P2 ,  P1 ,2,2)*FBBB(  P1 ,PBB,1)+
     &          F1BB(  P2 ,O(P1),2,1)*FBBB(O(P1),PBB,2))
     &    +( G(IQ,O(PL))*FBB(PB,  PL ,6)*FBLL(  PL ,O(P2),5,2)
     &      +G(IQ,  PL )*FBB(PB,O(PL),5)*FBLL(O(PL),O(P2),6,2))*
     &         (F1BB(O(P2),  P1 ,1,2)*FBBB(  P1 ,PBB,1)+
     &          F1BB(O(P2),O(P1),1,1)*FBBB(O(P1),PBB,2)))
C--third amplitude from notes
        MGAMP(1) = MGAMP(1)+DCF(3)*(
     &     G(IQ,O(PL))*( FBB(PB,  P1 ,2)*F1B(  P1 ,  PL ,1,6)
     &                  +FBB(PB,O(P1),1)*F1B(O(P1),  PL ,2,6))*
     &         (F2BB(PL,  P2 ,5,1)*FBBB(  P2 ,PBB,2)+
     &          F2BB(PL,O(P2),5,2)*FBBB(O(P2),PBB,1))
     &    +G(IQ,  PL )*( FBB(PB,  P1 ,2)*F1B(  P1 ,O(PL),1,5)
     &                  +FBB(PB,O(P1),1)*F1B(O(P1),O(PL),2,5))*
     &         (F2BB(O(PL),  P2 ,6,1)*FBBB(  P2 ,PBB,2)+
     &          F2BB(O(PL),O(P2),6,2)*FBBB(O(P2),PBB,1)))
C--fourth amplitude from notes (3rd with gluons interchanged)
        MGAMP(2) = MGAMP(2)+DCF(4)*(
     &     G(IQ,O(PL))*( FBB(PB,  P2 ,1)*F2B(  P2 ,  PL ,2,6)
     &                  +FBB(PB,O(P2),2)*F2B(O(P2),  PL ,1,6))*
     &         (F1BB(  PL ,  P1 ,5,2)*FBBB(  P1 ,PBB,1)+
     &          F1BB(  PL ,O(P1),5,1)*FBBB(O(P1),PBB,2))
     &    +G(IQ,  PL )*( FBB(PB,  P2 ,1)*F2B(  P2 ,O(PL),2,5)
     &                  +FBB(PB,O(P2),2)*F2B(O(P2),O(PL),1,5))*
     &         ( F1BB(O(PL),  P1 ,6,2)*FBBB(  P1 ,PBB,1)
     &          +F1BB(O(PL),O(P1),6,1)*FBBB(O(P1),PBB,2)))
C--fifth amplitude from notes
        MGAMP(1) = MGAMP(1)+DCF(5)*(
     &     ( G(IQ,O(PL))*FBBLL(  P2 ,  PL ,2,6)*FBBB(  PL ,PBB,5)
     &      +G(IQ,  PL )*FBBLL(  P2 ,O(PL),2,5)*FBBB(O(PL),PBB,6))*
     &         ( FBB(PB,  P1 ,2)*F1B(  P1 ,  P2 ,1,1)
     &          +FBB(PB,O(P1),1)*F1B(O(P1),  P2 ,2,1))
     &    +( G(IQ,O(PL))*FBBLL(O(P2),  PL ,1,6)*FBBB(  PL ,PBB,5)
     &      +G(IQ,  PL )*FBBLL(O(P2),O(PL),1,5)*FBBB(O(PL),PBB,6))*
     &         ( FBB(PB,  P1 ,2)*F1B(  P1 ,O(P2),1,2)
     &          +FBB(PB,O(P1),1)*F1B(O(P1),O(P2),2,2)))
C--sixth amplitude from notes (5th with gluons interchanged)
        MGAMP(2) = MGAMP(2)+DCF(6)*(
     &     ( G(IQ,O(PL))*FBBLL(  P1 ,  PL ,1,6)*FBBB(  PL ,PBB,5)
     &      +G(IQ,  PL )*FBBLL(  P1 ,O(PL),1,5)*FBBB(O(PL),PBB,6))*
     &         ( FBB(PB,  P2 ,1)*F2B(  P2 ,  P1 ,2,2)
     &          +FBB(PB,O(P2),2)*F2B(O(P2),  P1 ,1,2))
     &    +( G(IQ,O(PL))*FBBLL(O(P1),  PL ,2,6)*FBBB(  PL ,PBB,5)
     &      +G(IQ,  PL )*FBBLL(O(P1),O(PL),2,5)*FBBB(O(PL),PBB,6))*
     &         ( FBB(PB,  P2 ,1)*F2B(  P2 ,O(P1),2,1)
     &          +FBB(PB,O(P2),2)*F2B(O(P2),O(P1),1,1)))
C--seventh amplitude from notes (first non-Abelian one)
        MGAMP(3) = DCF(7)*DL(P1,P2)*S(1,2,P1)*S(1,2,O(P1))*(
     &         G(IQ,O(PL))*FBB(PB,  PL ,6)*
     &                   ( FBLL(  PL ,1,5,1)*FBBB(1,PBB,1)
     &                    +FBLL(  PL ,2,5,1)*FBBB(2,PBB,1)
     &                    -FBLL(  PL ,1,5,2)*FBBB(1,PBB,2)
     &                    -FBLL(  PL ,2,5,2)*FBBB(2,PBB,2))
     &        +G(IQ,  PL )*FBB(PB,O(PL),5)*
     &                   ( FBLL(O(PL),1,6,1)*FBBB(1,PBB,1)
     &                    +FBLL(O(PL),2,6,1)*FBBB(2,PBB,1)
     &                    -FBLL(O(PL),1,6,2)*FBBB(1,PBB,2)
     &                    -FBLL(O(PL),2,6,2)*FBBB(2,PBB,2)))
C--eighth amplitude from notes (second non-Abelian one)
C--bug fix 12/7/03 by PR (too many continuations for NAG)
        MGAMP(3) = MGAMP(3)
     &        + DCF(8)*DL(P1,P2)*S(1,2,P1)*S(1,2,O(P1))*(
     &         G(IQ,O(PL))*FBBB(  PL ,PBB,5)*
     &                   ( FBB(PB,1,1)*FBBLL(1,PL,1,6)
     &                    +FBB(PB,2,1)*FBBLL(2,PL,1,6)
     &                    -FBB(PB,1,2)*FBBLL(1,PL,2,6)
     &                    -FBB(PB,2,2)*FBBLL(2,PL,2,6))
     &        +G(IQ,  PL )*FBBB(O(PL),PBB,6)*
     &                   ( FBB(PB,1,1)*FBBLL(1,O(PL),1,5)
     &                    +FBB(PB,2,1)*FBBLL(2,O(PL),1,5)
     &                    -FBB(PB,1,2)*FBBLL(1,O(PL),2,5)
     &                    -FBB(PB,2,2)*FBBLL(2,O(PL),2,5)))
        MGAMP(1) = G(IDZ,PL)*(MGAMP(1)+MGAMP(3))
        MGAMP(2) = G(IDZ,PL)*(MGAMP(2)-MGAMP(3))
C--now square them
        FLOW(1,1) = FLOW(1,1)+DREAL(MGAMP(1)*DCONJG(MGAMP(1)))
        FLOW(1,2) = FLOW(1,2)+DREAL(MGAMP(2)*DCONJG(MGAMP(2)))
        FLOW(1,3) = FLOW(1,3)+TWO*DREAL(MGAMP(1)*DCONJG(MGAMP(2)))
      ENDDO
      ENDDO
      ENDDO
      ENDDO
      ENDDO
C--add up the diagrams to obtain the amplitudes for the two colour flows
      FLOW(1,1) = CGFC*FLOW(1,1)
      FLOW(1,2) = CGFC*FLOW(1,2)
      FLOW(1,3) = CGIFC*FLOW(1,3)
      DO I=1,2
        IF(FLOW(1,3).NE.ZERO) THEN
          MG(I) = PG*FLOW(1,I)*(ONE+FLOW(1,3)/(FLOW(1,1)+FLOW(1,2)))
        ELSE
          MG(I) = PG*FLOW(1,I)
        ENDIF
      ENDDO
C--now q qbar --> q qbar Z
C--calculate the denominators
      DCF(1) = -TWO*QBL/D(1,2)
      DCF(2) = -TWO*QBBL/D(1,2)
      DCF(3) = -TWO*Q1L*QBB
      DCF(4) = +TWO*Q2L*QBB
      DCF(5) =  TWO*Q1LB*Q2BB
      DCF(6) = -TWO*Q2LB*Q1B
      DCF(7) =  TWO*QBL*Q2BB
      DCF(8) = -TWO*QBBL*Q1B
      PQ = ONE/PBQB/PBBQBB
      DO P1=1,2
      DO PL=1,2
      DO PB=1,2
      DO PBB=1,2
C--first the amplitudes for q qbar --> q' q'bar Z
C--the first two amplitudes have Z off the final state and therefore
C--the flavour of the incoming quarks doesn't matter
C--first amplitude from notes
        MQAMP(3,P1,PL,PB,PBB) = G(IDZ,PL)*(
     &     DCF(1)*(G(IQ,O(PL))*FBB(O(PB),  PL ,6)*
     &                ( FBLL(  PL ,  P1 ,5,1)*FBBB(  P1 ,O(PBB),2)
     &                 +FBLL(  PL ,O(P1),5,2)*FBBB(O(P1),O(PBB),1))
     &            +G(IQ,  PL )*FBB(O(PB),O(PL),5)*
     &                ( FBLL(O(PL),  P1 ,6,1)*FBBB(  P1 ,O(PBB),2)
     &                 +FBLL(O(PL),O(P1),6,2)*FBBB(O(P1),O(PBB),1)))
C--second amplitide from notes
     &    +DCF(2)*(G(IQ,O(PL))*FBBB(  PL ,O(PBB),5)*
     &          ( FBB(O(PB),  P1 ,1)*FBBLL(  P1 ,  PL ,2,6)
     &           +FBB(O(PB),O(P1),2)*FBBLL(O(P1),  PL ,1,6))
     &    +G(IQ,  PL )*FBBB(O(PL),O(PBB),6)*
     &          ( FBB(O(PB),  P1 ,1)*FBBLL(  P1 ,O(PL),2,5)
     &           +FBB(O(PB),O(P1),2)*FBBLL(O(P1),O(PL),1,5))))
C--third amplitide from notes
        DO I=1,2
           MQAMP(I,P1,PL,PB,PBB) =
     &     DCF(3)*(G(I,O(PL))*DL(P1,O(PL))*S(5,1,  PL )*(
     &          S(1,6,O(PL))*( FBB(O(PB),  P1 ,1)*FBBB(  P1 ,O(PBB),2)
     &                        +FBB(O(PB),O(P1),2)*FBBB(O(P1),O(PBB),1))
     &         -S(5,6,O(PL))*( FBB(O(PB),  P1 ,5)*FBBB(  P1 ,O(PBB),2)
     &                        +FBB(O(PB),O(P1),2)*FBBB(O(P1),O(PBB),5)))
     &    +G(I,  PL )*DL(P1,  PL )*S(6,1,O(PL))*(
     &          S(1,5,  PL )*( FBB(O(PB),  P1 ,1)*FBBB(  P1 ,O(PBB),2)
     &                        +FBB(O(PB),O(P1),2)*FBBB(O(P1),O(PBB),1))
     &      -S(6,5,  PL )*( FBB(O(PB),  P1 ,6)*FBBB(  P1 ,O(PBB),2)
     &                     +FBB(O(PB),O(P1),2)*FBBB(O(P1),O(PBB),6))))
C--fourth amplitude from notes
           MQAMP(I,P1,PL,PB,PBB) = MQAMP(I,P1,PL,PB,PBB)
     &    +DCF(4)*(G(I,O(PL))*DL(P1,O(PL))*S(2,6,  P1 )*(
     &          S(5,2,  PL )*( FBB(O(PB),  P1 ,1)*FBBB(  P1 ,O(PBB),2)
     &                        +FBB(O(PB),O(P1),2)*FBBB(O(P1),O(PBB),1))
     &         -S(5,6,  PL )*( FBB(O(PB),  P1 ,1)*FBBB(  P1 ,O(PBB),6)
     &                        +FBB(O(PB),O(P1),6)*FBBB(O(P1),O(PBB),1)))
     &    +G(I,  PL )*DL(P1,  PL )*S(2,5,  P1 )*(
     &          S(6,2,O(PL))*( FBB(O(PB),  P1 ,1)*FBBB(  P1 ,O(PBB),2)
     &                        +FBB(O(PB),O(P1),2)*FBBB(O(P1),O(PBB),1))
     &        -S(6,5,O(PL))*( FBB(O(PB),  P1 ,1)*FBBB(  P1 ,O(PBB),5)
     &                      +FBB(O(PB),O(P1),5)*FBBB(O(P1),O(PBB),1))))
           MQAMP(I,P1,PL,PB,PBB) = G(IDZ,PL)*MQAMP(I,P1,PL,PB,PBB)
        ENDDO
C--now the extra amplitudes for q qbar --> q qbar Z
        DO P2=1,2
C--first amplitude for notes
           MQQAMP(P1,P2,PL,PB,PBB) =
     &   DCF(5)*(DL(P2,PBB)*S(8,4,PBB)*(
     &          G(IQ,O(PL))*DL(P1,O(PL))*S(5,1,  PL )*
     &             ( FBB(O(PB),  PBB,8)*F1LL(  P2  ,  PL ,2,6)
     &              +FBB(O(PB),O(P2),2)*F1LL(O(PBB),  PL ,8,6))
     &         +G(IQ,  PL )*DL(P1,  PL )*S(6,1,O(PL))*
     &             ( FBB(O(PB),  PBB ,8)*F1LL(  P2  ,O(PL),2,5)
     &              +FBB(O(PB),O(P2) ,2)*F1LL(O(PBB),O(PL),8,5)))
     &      -QM*DL(P2,O(PBB))*(
     &          G(IQ,O(PL))*DL(P1,O(PL))*S(5,1,PL)*
     &             ( FBB(O(PB),O(PBB),8)*F1LL(  P2  ,  PL ,2,6)
     &              +FBB(O(PB),O(P2) ,2)*F1LL(  PBB ,  PL ,8,6))
     &         +G(IQ,  PL )*DL(P1,  PL )*S(6,1,O(PL))*
     &             ( FBB(O(PB),O(PBB),8)*F1LL(  P2  ,O(PL),2,5)
     &              +FBB(O(PB), O(P2),2)*F1LL(  PBB ,O(PL),8,5))))
C--second amplitude from notes
           MQQAMP(P1,P2,PL,PB,PBB) = MQQAMP(P1,P2,PL,PB,PBB)
     &  +DCF(6)*(DL(P1,PB)*S(3,7,O(PB))*(
     &          G(IQ,O(PL))*DL(P2,O(PL))*S(2,6,  P2 )*
     &             ( F2LL(  PL ,  P1 ,5,1)*FBBB(  PB ,O(PBB),7)
     &              +F2LL(  PL ,O(PB),5,7)*FBBB(O(P1),O(PBB),1))
     &         +G(IQ,  PL )*DL(P2,  PL )*S(2,5,  P2 )*
     &             ( F2LL(O(PL),  P1 ,6,1)*FBBB(  PB ,O(PBB),7)
     &              +F2LL(O(PL),O(PB),6,7)*FBBB(O(P1),O(PBB),1)))
     &     -QM*DL(P1,O(PB))*(
     &          G(IQ,O(PL))*DL(P2,O(PL))*S(2,6,  P2 )*
     &             ( F2LL(  PL ,  P1 ,5,1)*FBBB(O(PB),O(PBB),7)
     &              +F2LL(  PL ,  PB ,5,7)*FBBB(O(P1),O(PBB),1))
     &         +G(IQ,  PL )*DL(P2,  PL )*S(2,5,  P2 )*
     &             ( F2LL(O(PL),  P1 ,6,1)*FBBB(O(PB),O(PBB),7)
     &              +F2LL(O(PL),  PB ,6,7)*FBBB(O(P1),O(PBB),1))))
C--third  amplitude from notes
           MQQAMP(P1,P2,PL,PB,PBB) = MQQAMP(P1,P2,PL,PB,PBB)
     &  +DCF(7)*(DL(P2,PBB)*S(8,4,PBB)*(
     &          G(IQ,O(PL))*FBB(O(PB),  PL ,6)*
     &             ( DL(P2,O(P1) )*S(2,1,  P2  )*FBLL(  PL , PBB ,5,8)
     &              +DL(P1,PBB   )*S(8,1,O(PBB))*FBLL(  PL ,O(P2),5,2))
     &         +G(IQ,  PL )*FBB(O(PB),O(PL),5)*
     &             ( DL(P2,O(P1) )*S(2,1,  P2  )*FBLL(O(PL), PBB ,6,8)
     &              +DL(P1,PBB   )*S(8,1,O(PBB))*FBLL(O(PL),O(P2),6,2)))
     &      -QM*DL(P2,O(PBB))*(
     &          G(IQ,O(PL))*FBB(O(PB),PL,6)*
     &             ( DL(P2,O(P1) )*S(2,1,  P2  )*FBLL(  PL ,O(PBB),5,8)
     &              +DL(P1,O(PBB))*S(8,1,  PBB )*FBLL(  PL ,O(P2) ,5,2))
     &         +G(IQ,  PL )*FBB(O(PB),O(PB),5)*
     &           ( DL(P2,O(PL) )*S(2,1,  P2  )*FBLL(O(PL),O(PBB),6,8)
     &            +DL(P1,O(PBB))*S(8,1,  PBB )*FBLL(O(PL),O(P2) ,6,2))))
C--fourth amplitude from notes
           MQQAMP(P1,P2,PL,PB,PBB) = MQQAMP(P1,P2,PL,PB,PBB)
     &  +DCF(8)*(DL(P1,PB)*S(3,7,O(PB))*(
     &          DL(P1,O(P2))*S(2,1,P2)*
     &           ( G(IQ,O(PL))*FBBLL(PB,  PL ,7,6)*FBBB(  PL ,O(PBB),5)
     &            +G(IQ,  PL )*FBBLL(PB,O(PL),7,5)*FBBB(O(PL),O(PBB),6))
     &         +DL(P2,PB)*S(2,7,P2)*
     &     (G(IQ,O(PL))*FBBLL(O(P1),  PL ,1,6)*FBBB(  PL ,O(PBB),5)
     &     +G(IQ,   PL )*FBBLL(O(P1),O(PL),1,5)*FBBB(O(PL),O(PBB),6)))
     &       +QM*DL(P1,O(PB))*(
     &          DL(P2,O(P1))*S(2,1,P2)*
     &        ( G(IQ,O(PL))*FBBLL(O(PB),  PL ,3,6)*FBBB(  PL ,O(PBB),5)
     &         +G(IQ,  PL )*FBBLL(O(PB),O(PL),3,5)*FBBB(O(PL),O(PBB),6))
     &          +DL(P2,O(PB))*S(2,3,P2)*
     &      ( G(IQ,O(PL))*FBBLL(O(P1),  PL ,1,6)*FBBB(  PL ,O(PBB),5)
     &      +G(IQ,  PL )*FBBLL(O(P1),O(PL),1,5)*FBBB(O(PL),O(PBB),6))))
           MQQAMP(P1,P2,PL,PB,PBB) =  G(IDZ,PL)*MQQAMP(P1,P2,PL,PB,PBB)
        ENDDO
      ENDDO
      ENDDO
      ENDDO
      ENDDO
C--now obtain the matrix elements squared for the quarks
      DO I=1,3
         DO J=1,3
            FLOW(I,J) = ZERO
         ENDDO
      ENDDO
      IF(MOD(IQ,2).EQ.1) THEN
        IQI = 1
      ELSE
        IQI = 2
      ENDIF
      DO P1=1,2
      DO PL=1,2
      DO PB=1,2
      DO PBB=1,2
C--different quarks in inital and final states
         DO I=1,2
            MQP(I) = MQAMP(I,P1,PL,PB,PBB)+MQAMP(3,P1,PL,PB,PBB)
            FLOW(I,1) = FLOW(I,1)+DREAL(DCONJG(MQP(I))*MQP(I))
         ENDDO
C--same quark in inital and final state
         DO P2=1,2
            FLOW(3,2) = FLOW(3,2)+DREAL(
     &          DCONJG(MQQAMP(P1,P2,PL,PB,PBB))*MQQAMP(P1,P2,PL,PB,PBB))
           IF(P1.EQ.P2) THEN
              FLOW(3,1) = FLOW(3,1)+DREAL(DCONJG(MQP(IQI))*MQP(IQI))
              FLOW(3,3) = FLOW(3,3)-TWO*
     &           DREAL(DCONJG(MQP(IQI))*MQQAMP(P1,P2,PL,PB,PBB))
           ENDIF
         ENDDO
      ENDDO
      ENDDO
      ENDDO
      ENDDO
C--split up the non-planar pieces according to Kosuke's prescription
      DO I=1,3
      FLOW(I,1) =  CQFC*FLOW(I,1)
      FLOW(I,2) =  CQFC*FLOW(I,2)
      FLOW(I,3) = CQIFC*FLOW(I,3)
        DO J=1,2
          IF(FLOW(I,J).NE.ZERO) THEN
             MQB(J,I) = PQ*FLOW(I,J)*
     &                            (ONE+FLOW(I,3)/(FLOW(I,1)+FLOW(I,2)))
          ELSE
             MQB(J,I) = ZERO
          ENDIF
        ENDDO
      ENDDO
C--now set them
      DO I=1,5
        IF(I.EQ.IQ) THEN
          DO J=1,2
            MQ(J,I) = MQB(J,3)
          ENDDO
        ELSEIF(MOD(I,2).EQ.1) THEN
          DO J=1,2
            MQ(J,I) = MQB(J,1)
          ENDDO
        ELSE
          DO J=1,2
            MQ(J,I) = MQB(J,2)
          ENDDO
        ENDIF
      ENDDO
      END
CDECK  ID>, HWH2PS.
*CMZ :-        -14/03/01  09:03:25  by  Peter Richardson
*-- Author :    Peter Richardson
C-----------------------------------------------------------------------
      SUBROUTINE HWH2PS(WEIGHT,GEN,MQ,MQ2)
C-----------------------------------------------------------------------
C     Phase Space for vector boson plus 2 jets
C-----------------------------------------------------------------------
      INCLUDE 'HERWIG65.INC'
      DOUBLE PRECISION WEIGHT,XMASS,PLAB,PRW,PCM,Y(3),Y35,Y34,Y45,RAND,
     &     HWRGEN,HWRUNI,M35,M35S,G(IMAXCH),DEM,MT(3),PT(3),MJAC,ETOT,
     &     STOT,MQ(3),MQ2(3),PS35,HWUPCM,TWOPI2,MT35,PTJ(3),MT2(3),A,C,
     &     PT2(3),YMIN,YMAX,EY(3),EY34,YJAC,YJJMAX,YJJMIN,EY35,PHI(3),
     &     MT45,PS45,EY45,M45,M45S,M34,PS34,M34S,MT34,XJAC,SJAC,PST,TAU,
     &     FLUX,ETMP,PZTMP,XT1,XT2,WI(IMAXCH)
      COMMON /HWPSOM/ WI
      INTEGER I,ICH,J
      COMMON/HWHEWP/XMASS(10),PLAB(5,10),PRW(5,2),PCM(5,10)
      LOGICAL GEN
      EXTERNAL HWRGEN,HWRUNI,HWUPCM
      PARAMETER(YJJMIN=-8.0D0,YJJMAX=8.0D0)
      IF(IERROR.NE.0) RETURN
      TWOPI2 = FOUR*PIFAC**2
      WEIGHT = ZERO
      IF(OPTM) THEN
        DO I=1,IMAXCH
          WI(I) = ZERO
        ENDDO
      ENDIF
      GEN = .FALSE.
C--centre of mass energy
      ETOT = PHEP(5,3)
      STOT = ETOT**2
C--first select the channel to be used
      RAND=HWRGEN(0)
      DO ICH=1,IMAXCH
        IF(CHON(ICH)) THEN
          IF(CHNPRB(ICH).GT.RAND) GOTO 10
          RAND = RAND-CHNPRB(ICH)
        ENDIF
      ENDDO
 10   CONTINUE
C--generate the phase space according to the channel selected
C--FIRST CHANNEL
      IF(ICH.EQ.1) THEN
C--first generate the mass of 35
        CALL HWH2P1(2,MJAC,MQ2(1),M35S,(ETOT-MQ(2))**2,(MQ(1)+MQ(3))**2)
        M35 = SQRT(M35S)
        PS35 = HWUPCM(M35,MQ(1),MQ(3))
        MJAC = HALF*MJAC*PS35/M35/TWOPI2
C--the generate the PT of 4
        CALL HWH2P2(2,PTJ(1),MT2(2),MQ2(2)+PTMAX**2,MQ2(2)+PTMIN**2)
        MT (2) = SQRT(MT2(2))
        PT2(2) = MT2(2)-MQ2(2)
        PT(2)  = SQRT(PT2(2))
        MT35   = SQRT(M35S+PT2(2))
C--generate the rapidities of 4 and 35
        YMAX  = MIN(YJJMAX, LOG(PHEP(5,3)/MT35))
        YMIN  = MAX(YJJMIN,-LOG(PHEP(5,3)/MT35))
        IF(YMAX.LT.YMIN) RETURN
        Y35   = HWRUNI(1,YMIN,YMAX)
        EY35  = EXP(Y35)
        YJAC  = (YMAX-YMIN)
        YMAX  = MIN(YJMAX, LOG((PHEP(5,3)-MT35*EY35)/MT(2)))
        YMIN  = MAX(YJMIN,-LOG((PHEP(5,3)-MT35/EY35)/MT(2)))
        IF(YMAX.LT.YMIN) RETURN
        Y(2)  = HWRUNI(2,YMIN,YMAX)
        YJAC  = (YMAX-YMIN)*YJAC
        EY(2) = EXP(Y(2))
C--generate the incoming quark momentum fractions
        XX(1) = (MT(2)*EY(2)+MT35*EY35)/ETOT
        XX(2) = (MT(2)/EY(2)+MT35/EY35)/ETOT
        STOT = XX(1)*XX(2)*STOT
C--azimuthal angle of 4 and 35
        PHI(1) = HWRUNI(3,ZERO,TWO*PIFAC)
C--construct the momenta of 4 and 35
        PLAB(1,4) = PT(2)*SIN(PHI(1))
        PLAB(2,4) = PT(2)*COS(PHI(1))
        PLAB(3,4) = HALF*MT(2)*(EY(2)-ONE/EY(2))
        PLAB(4,4) = HALF*MT(2)*(EY(2)+ONE/EY(2))
        PLAB(5,4) = MQ(2)
        PLAB(1,6) =-PT(2)*SIN(PHI(1))
        PLAB(2,6) =-PT(2)*COS(PHI(1))
        PLAB(3,6) = HALF*MT35*(EY35-ONE/EY35)
        PLAB(4,6) = HALF*MT35*(EY35+ONE/EY35)
        PLAB(5,6) = M35
C--perform the decay 35 --> 3+5
        PLAB(5,3) = MQ(1)
        PLAB(5,5) = MQ(3)
        CALL HWDTWO(PLAB(1,6),PLAB(1,3),PLAB(1,5),PS35,TWO,.TRUE.)
C--phase space weight
        FLUX = MJAC*YJAC*PTJ(1)/16.0D0/PIFAC/STOT**2
C--SECOND CHANNEL
      ELSEIF(ICH.EQ.2) THEN
C--first generate the pt's and azimuthal angles of 3 and 4
        DO I=1,2
           CALL HWH2P2(2,PTJ(I),MT2(I),MQ2(I)+PTMAX**2,MQ2(I)+PTMIN**2)
           PT2(I) = MT2(I)-MQ2(I)
           MT(I) = SQRT(MT2(I))
           PT(I) = SQRT(PT2(I))
           PHI(I) = HWRUNI(I,ZERO,TWO*PIFAC)
        ENDDO
C--find the pt and azimuth of 5 by conservation of transverse momentum
        A      = PT(1)*SIN(PHI(1))+PT(2)*SIN(PHI(2))
        C      = PT(1)*COS(PHI(1))+PT(2)*COS(PHI(2))
        PT(3)  = A**2+C**2
        MT(3)  = SQRT(PT(3)+MQ2(3))
        PT(3)  = SQRT(PT(3))
        PHI(3) = -ACOS(-C/PT(3))
        IF(A.LT.ZERO) PHI(3)=-PHI(3)
C--generate the rapidities of 3,4 and 5
        XX(1) = ZERO
        XX(2) = ZERO
        YJAC  = ONE
        DO I=1,3
          YMAX = MIN(YJMAX, LOG((PHEP(5,3)-XX(1))/MT(I)))
          YMIN = MAX(YJMIN,-LOG((PHEP(5,3)-XX(2))/MT(I)))
          IF(YMAX.LT.YMIN) RETURN
          Y(I)  = HWRUNI(I+2,YMIN,YMAX)
          EY(I) = EXP(Y(I))
          XX(1) = XX(1)+MT(I)*EY(I)
          XX(2) = XX(2)+MT(I)/EY(I)
          YJAC  = YJAC*(YMAX-YMIN)
        ENDDO
C--generate the incoming quark momentum fractions
        XX(1) = XX(1)/PHEP(5,3)
        XX(2) = XX(2)/PHEP(5,3)
        IF(XX(1).GT.ONE.OR.XX(2).GT.ONE) RETURN
C--Construct the 4-momenta of the outgoing particles
        DO I=1,3
          PLAB(1,I+2) = PT(I)*SIN(PHI(I))
          PLAB(2,I+2) = PT(I)*COS(PHI(I))
          PLAB(3,I+2) = HALF*MT(I)*(EY(I)-ONE/EY(I))
          PLAB(4,I+2) = HALF*MT(I)*(EY(I)+ONE/EY(I))
          PLAB(5,I+2) = MQ(I)
       ENDDO
C--phase space weight
       STOT = XX(1)*XX(2)*STOT
       FLUX = YJAC*PTJ(1)*PTJ(2)/64.0D0/PIFAC/TWOPI2/STOT**2
C--THIRD CHANNEL
      ELSEIF(ICH.EQ.3) THEN
C--first generate the mass of 45
        CALL HWH2P1(2,MJAC,MQ2(2),M45S,(ETOT-MQ(1))**2,(MQ(2)+MQ(3))**2)
        M45 = SQRT(M45S)
        PS45 = HWUPCM(M45,MQ(2),MQ(3))
        MJAC = HALF*MJAC*PS45/M45/TWOPI2
C--the generate the PT of 4
        CALL HWH2P2(2,PTJ(1),MT2(1),MQ2(1)+PTMAX**2,MQ2(1)+PTMIN**2)
        MT (1) = SQRT(MT2(1))
        PT2(1) = MT2(1)-MQ2(1)
        PT(1)  = SQRT(PT2(1))
        MT45   = SQRT(M45S+PT2(1))
C--generate the rapidities of 3 and 45
        YMAX  = MIN(YJJMAX, LOG(PHEP(5,3)/MT45))
        YMIN  = MAX(YJJMIN,-LOG(PHEP(5,3)/MT45))
        IF(YMAX.LT.YMIN) RETURN
        Y45   = HWRUNI(1,YMIN,YMAX)
        EY45  = EXP(Y45)
        YJAC  = (YMAX-YMIN)
        YMAX  = MIN(YJMAX, LOG((PHEP(5,3)-MT45*EY45)/MT(1)))
        YMIN  = MAX(YJMIN,-LOG((PHEP(5,3)-MT45/EY45)/MT(1)))
        IF(YMAX.LT.YMIN) RETURN
        Y(1)  = HWRUNI(2,YMIN,YMAX)
        YJAC  = (YMAX-YMIN)*YJAC
        EY(1) = EXP(Y(1))
C--generate the incoming quark momentum fractions
        XX(1) = (MT(1)*EY(1)+MT45*EY45)/ETOT
        XX(2) = (MT(1)/EY(1)+MT45/EY45)/ETOT
        STOT = XX(1)*XX(2)*STOT
C--azimuthal angle of 3 and 45
        PHI(1) = HWRUNI(3,ZERO,TWO*PIFAC)
C--construct the momenta of 3 and 45
        PLAB(1,3) = PT(1)*SIN(PHI(1))
        PLAB(2,3) = PT(1)*COS(PHI(1))
        PLAB(3,3) = HALF*MT(1)*(EY(1)-ONE/EY(1))
        PLAB(4,3) = HALF*MT(1)*(EY(1)+ONE/EY(1))
        PLAB(5,3) = MQ(1)
        PLAB(1,6) =-PT(1)*SIN(PHI(1))
        PLAB(2,6) =-PT(1)*COS(PHI(1))
        PLAB(3,6) = HALF*MT45*(EY45-ONE/EY45)
        PLAB(4,6) = HALF*MT45*(EY45+ONE/EY45)
        PLAB(5,6) = M45
C--perform the decay 45 --> 4+5
        PLAB(5,4) = MQ(2)
        PLAB(5,5) = MQ(3)
        CALL HWDTWO(PLAB(1,6),PLAB(1,4),PLAB(1,5),PS45,TWO,.TRUE.)
C--phase space weight
        FLUX = MJAC*YJAC*PTJ(1)/16.0D0/PIFAC/STOT**2
C--FOURTH CHANNEL
      ELSEIF(ICH.EQ.4) THEN
C--generate shat according to a power law
        CALL HWHGB1(1,2,200,SJAC,STOT,PHEP(5,3)**2,
     &                                        (MQ(1)+MQ(2)+MQ(3))**2)
        ETOT = SQRT(STOT)
C--generate x1
        TAU   = STOT/PHEP(5,3)**2
        XJAC  = -LOG(TAU)
        XX(1) = EXP(HWRUNI(2,LOG(TAU),ZERO))
        XX(2) = TAU/XX(1)
C--generate m35
        CALL HWH2P1(2,MJAC,MQ2(1),M35S,(ETOT-MQ(2))**2,
     &                                               (MQ(1)+MQ(3))**2)
        M35 = SQRT(M35S)
        PS35 = HWUPCM(M35,MQ(1),MQ(3))
        MJAC = HALF*MJAC*PS35/M35/TWOPI2
C--generate the momenta of 4 and 35
        PST = HWUPCM(ETOT,M35,MQ(2))
        PLAB(1,7) = ZERO
        PLAB(2,7) = ZERO
        PLAB(3,7) = HALF*(XX(1)-XX(2))*PHEP(5,3)
        PLAB(4,7) = HALF*(XX(1)+XX(2))*PHEP(5,3)
        PLAB(5,7) = ETOT
        PLAB(5,3) = MQ(1)
        PLAB(5,6) = M35
        PLAB(5,4) = MQ(2)
        CALL HWDTWO(PLAB(1,7),PLAB(1,4),PLAB(1,6),PST,TWO,.TRUE.)
C--perform the decay 35 --> 3+5
        PLAB(5,4) = MQ(2)
        PLAB(5,5) = MQ(3)
        CALL HWDTWO(PLAB(1,6),PLAB(1,3),PLAB(1,5),PS35,TWO,.TRUE.)
C--phase space weight
        FLUX = SJAC*XJAC*MJAC*PST/ETOT/STOT**2/8.0D0/PIFAC
C--FIFTH CHANNEL
      ELSEIF(ICH.EQ.5) THEN
C--generate shat according to a power law
        CALL HWHGB1(1,2,200,SJAC,STOT,PHEP(5,3)**2,
     &                                        (MQ(1)+MQ(2)+MQ(3))**2)
        ETOT = SQRT(STOT)
C--generate x1
        TAU   = STOT/PHEP(5,3)**2
        XJAC  = -LOG(TAU)
        XX(1) = EXP(HWRUNI(2,LOG(TAU),ZERO))
        XX(2) = TAU/XX(1)
C--generate m45
        CALL HWH2P1(2,MJAC,MQ2(2),M45S,(ETOT-MQ(1))**2,(MQ(2)+MQ(3))**2)
        M45 = SQRT(M45S)
        PS45 = HWUPCM(M45,MQ(2),MQ(3))
        MJAC = HALF*MJAC*PS45/M45/TWOPI2
C--generate the momenta of 4 and 35
        PST = HWUPCM(ETOT,M45,MQ(1))
        PLAB(1,7) = ZERO
        PLAB(2,7) = ZERO
        PLAB(3,7) = HALF*(XX(1)-XX(2))*PHEP(5,3)
        PLAB(4,7) = HALF*(XX(1)+XX(2))*PHEP(5,3)
        PLAB(5,7) = ETOT
        PLAB(5,3) = MQ(1)
        PLAB(5,6) = M45
        CALL HWDTWO(PLAB(1,7),PLAB(1,3),PLAB(1,6),PST,TWO,.TRUE.)
C--perform the decay 45 --> 4+5
        PLAB(5,4) = MQ(2)
        PLAB(5,5) = MQ(3)
        CALL HWDTWO(PLAB(1,6),PLAB(1,4),PLAB(1,5),PS45,TWO,.TRUE.)
C--phase space weight
        FLUX = SJAC*XJAC*MJAC*PST/ETOT/STOT**2/8.0D0/PIFAC
C--SIXTH CHANNEL
      ELSEIF(ICH.EQ.6) THEN
C--first generate the mass of 34
        CALL HWH2P1(2,MJAC,ZERO,M34S,(ETOT-MQ(3))**2,MJJMIN**2)
        M34 = SQRT(M34S)
        PS34 = HWUPCM(M34,MQ(1),MQ(2))
        MJAC = HALF*MJAC*PS34/M34/TWOPI2
C--the generate the PT of 5
        CALL HWH2P2(2,PTJ(1),MT2(3),MQ2(3)+PTMAX**2,MQ2(3))
        MT (3) = SQRT(MT2(3))
        PT2(3) = MT2(3)-MQ2(3)
        PT(3)  = SQRT(PT2(3))
        MT34   = SQRT(M34S+PT2(3))
C--generate the rapidities of 5 and 34
        YMAX  = MIN(YJJMAX, LOG(PHEP(5,3)/MT34))
        YMIN  = MAX(YJJMIN,-LOG(PHEP(5,3)/MT34))
        IF(YMAX.LT.YMIN) RETURN
        Y34   = HWRUNI(1,YMIN,YMAX)
        EY34  = EXP(Y34)
        YJAC  = (YMAX-YMIN)
        YMAX  = MIN(YJMAX, LOG((PHEP(5,3)-MT34*EY34)/MT(3)))
        YMIN  = MAX(YJMIN,-LOG((PHEP(5,3)-MT34/EY34)/MT(3)))
        IF(YMAX.LT.YMIN) RETURN
        Y(3)  = HWRUNI(2,YMIN,YMAX)
        YJAC  = (YMAX-YMIN)*YJAC
        EY(3) = EXP(Y(3))
C--generate the incoming quark momentum fractions
        XX(1) = (MT(3)*EY(3)+MT34*EY34)/ETOT
        XX(2) = (MT(3)/EY(3)+MT34/EY34)/ETOT
        STOT = XX(1)*XX(2)*STOT
C--azimuthal angle of 3 and 45
        PHI(1) = HWRUNI(3,ZERO,TWO*PIFAC)
C--construct the momenta of 5 and 34
        PLAB(1,5) = PT(3)*SIN(PHI(1))
        PLAB(2,5) = PT(3)*COS(PHI(1))
        PLAB(3,5) = HALF*MT(3)*(EY(3)-ONE/EY(3))
        PLAB(4,5) = HALF*MT(3)*(EY(3)+ONE/EY(3))
        PLAB(5,5) = MQ(3)
        PLAB(1,6) =-PT(3)*SIN(PHI(1))
        PLAB(2,6) =-PT(3)*COS(PHI(1))
        PLAB(3,6) = HALF*MT34*(EY34-ONE/EY34)
        PLAB(4,6) = HALF*MT34*(EY34+ONE/EY34)
        PLAB(5,6) = M34
C--perform the decay 34 --> 3+4
        PLAB(5,3) = MQ(1)
        PLAB(5,4) = MQ(2)
        CALL HWDTWO(PLAB(1,6),PLAB(1,3),PLAB(1,4),PS34,TWO,.TRUE.)
C--phase space weight
        FLUX = MJAC*YJAC*PTJ(1)/16.0D0/PIFAC/STOT**2
      ELSE
        CALL HWWARN('HWH2PS',500)
      ENDIF
C--calculate the variables we need for the smoothing functions
C--pt,mt and y for outgoing particles
      DO I=1,3
        J=I+2
        PT2(I) = PLAB(1,J)**2+PLAB(2,J)**2
        PT(I)  = SQRT(PT2(I))
        MT2(I) = MQ2(I)+PT2(I)
        MT(I)  = SQRT(MT2(I))
        Y(I)   = HALF*LOG((PLAB(4,J)+PLAB(3,J))/(PLAB(4,J)-PLAB(3,J)))
        EY(I)  = EXP(Y(I))
        IF(I.LE.2.AND.(Y(I).LT.YJMIN.OR.Y(I).GT.YJMAX)) RETURN
      ENDDO
      IF(PT(1).LT.PTMIN.OR.PT(2).LT.PTMIN) RETURN
C--masses of composite particles
      M34S = (PLAB(4,3)+PLAB(4,4))**2
      M45S = (PLAB(4,4)+PLAB(4,5))**2
      M35S = (PLAB(4,3)+PLAB(4,5))**2
      DO I=1,3
        M34S = M34S-(PLAB(I,3)+PLAB(I,4))**2
        M45S = M45S-(PLAB(I,4)+PLAB(I,5))**2
        M35S = M35S-(PLAB(I,3)+PLAB(I,5))**2
      ENDDO
      M34 = SQRT(M34S)
      M45 = SQRT(M45S)
      M35 = SQRT(M35S)
      IF(M34.LT.MJJMIN) RETURN
C--tramsverse masses of the composite particles
      MT34 = ZERO
      MT35 = ZERO
      MT45 = ZERO
      DO I=1,2
        MT34 = MT34+(PLAB(I,3)+PLAB(I,4))**2
        MT35 = MT35+(PLAB(I,3)+PLAB(I,5))**2
        MT45 = MT45+(PLAB(I,4)+PLAB(I,5))**2
      ENDDO
      MT34 = SQRT(M34S+MT34)
      MT35 = SQRT(M35S+MT35)
      MT45 = SQRT(M45S+MT45)
C--final the momenta
      PS34 = HWUPCM(M34,MQ(1),MQ(2))
      PS35 = HWUPCM(M35,MQ(1),MQ(3))
      PS45 = HWUPCM(M45,MQ(2),MQ(3))
C--the rapidities of the composite particles
      ETMP  = PLAB(4,3)+PLAB(4,4)
      PZTMP = PLAB(3,3)+PLAB(3,4)
      Y34   = HALF*LOG((ETMP+PZTMP)/(ETMP-PZTMP))
      EY34  = EXP(Y34)
      ETMP  = PLAB(4,3)+PLAB(4,5)
      PZTMP = PLAB(3,3)+PLAB(3,5)
      Y35   = HALF*LOG((ETMP+PZTMP)/(ETMP-PZTMP))
      EY35  = EXP(Y35)
      ETMP  = PLAB(4,4)+PLAB(4,5)
      PZTMP = PLAB(3,4)+PLAB(3,5)
      Y45   = HALF*LOG((ETMP+PZTMP)/(ETMP-PZTMP))
      EY45  = EXP(Y45)
C--find the pdf's and set the scale
      ETOT = SQRT(STOT)
      EMSCA = ETOT
      CALL HWSGEN(.FALSE.)
C--construct the incoming momenta
      DO I=1,2
        PLAB(1,I) = ZERO
        PLAB(2,I) = ZERO
        PLAB(3,I) = HALF*XX(I)*PHEP(5,3)
        PLAB(4,I) = HALF*XX(I)*PHEP(5,3)
        PLAB(5,I) = ZERO
      ENDDO
      PLAB(3,2) = -PLAB(3,2)
      TAU   = XX(1)*XX(2)
C--find the smoothing functions for the different channels
C--function for first channel
      IF(CHON(1)) THEN
        CALL HWH2P1(1,MJAC,MQ2(1),M35S,(PHEP(5,3)-MQ(2))**2,
     &                                              (MQ(1)+MQ(3))**2)
        MJAC = MJAC/PS35*M35
        CALL HWH2P2(1,PTJ(1),MT2(2),PTMAX**2+MQ2(2),MQ2(2)+PTMIN**2)
        YMAX  = MIN(YJJMAX, LOG(PHEP(5,3)/MT35))
        YMIN  = MAX(YJJMIN,-LOG(PHEP(5,3)/MT35))
        YJAC  = (YMAX-YMIN)
        YMAX  = MIN(YJMAX, LOG((PHEP(5,3)-MT35*EY35)/MT(2)))
        YMIN  = MAX(YJMIN,-LOG((PHEP(5,3)-MT35/EY35)/MT(2)))
        YJAC  = (YMAX-YMIN)*YJAC
        G(1)  = 2.0D0*MJAC*PTJ(1)/YJAC
      ENDIF
C--function for second channel
      IF(CHON(2)) THEN
        DO I=1,2
           CALL HWH2P2(1,PTJ(I),MT2(I),PTMAX**2+MQ2(I),MQ2(I)+PTMIN**2)
        ENDDO
        XT1 = ZERO
        XT2 = ZERO
        YJAC  = ONE
        DO I=1,3
          YMAX = MIN(YJMAX, LOG((PHEP(5,3)-XT1)/MT(I)))
          YMIN = MAX(YJMIN,-LOG((PHEP(5,3)-XT2)/MT(I)))
          XT1  = XT1+MT(I)*EY(I)
          XT2  = XT2+MT(I)/EY(I)
          YJAC  = YJAC*(YMAX-YMIN)
        ENDDO
        G(2) = 4.0D0*PTJ(1)*PTJ(2)/YJAC
      ENDIF
C--function for third channel
      IF(CHON(3)) THEN
        CALL HWH2P1(1,MJAC,MQ2(2),M45S,(PHEP(5,3)-MQ(1))**2,
     &                                            (MQ(2)+MQ(3))**2)
        MJAC = MJAC/PS45*M45
        CALL HWH2P2(1,PTJ(1),MT2(1),PTMAX**2+MQ2(1),MQ2(1)+PTMIN**2)
        YMAX  = MIN(YJJMAX, LOG(PHEP(5,3)/MT45))
        YMIN  = MAX(YJJMIN,-LOG(PHEP(5,3)/MT45))
        YJAC  = (YMAX-YMIN)
        YMAX  = MIN(YJMAX, LOG((PHEP(5,3)-MT45*EY45)/MT(1)))
        YMIN  = MAX(YJMIN,-LOG((PHEP(5,3)-MT45/EY45)/MT(1)))
        YJAC  = (YMAX-YMIN)*YJAC
        G(3)  = 2.0D0*MJAC*PTJ(1)/YJAC
      ENDIF
C--function for fourth channel
      IF(CHON(4)) THEN
        CALL HWHGB1(1,1,200,SJAC,STOT,PHEP(5,3)**2,
     &                                        (MQ(1)+MQ(2)+MQ(3))**2)
        XJAC  = -LOG(TAU)
        CALL HWH2P1(1,MJAC,MQ2(1),M35S,(ETOT-MQ(2))**2,(MQ(1)+MQ(3))**2)
        M35 = SQRT(M35S)
        MJAC = MJAC/PS35*M35
        PST = HWUPCM(ETOT,M35,MQ(2))
        G(4) = SJAC*MJAC/XJAC*ETOT/PST
      ENDIF
C--function for fifth channel
      IF(CHON(5)) THEN
        CALL HWHGB1(1,1,200,SJAC,STOT,PHEP(5,3)**2,
     &                                        (MQ(1)+MQ(2)+MQ(3))**2)
        XJAC  = -LOG(TAU)
        CALL HWH2P1(1,MJAC,MQ2(2),M45S,(ETOT-MQ(1))**2,(MQ(2)+MQ(3))**2)
        MJAC = MJAC/PS45*M45
        PST = HWUPCM(ETOT,M45,MQ(1))
        G(5) = SJAC/XJAC*MJAC/PST*ETOT
      ENDIF
C--function for sixth chaneel
      IF(CHON(6)) THEN
        CALL HWH2P1(1,MJAC,ZERO,M34S,(PHEP(5,3)-MQ(3))**2,MJJMIN**2)
        MJAC = MJAC/PS34*M34
        CALL HWH2P2(1,PTJ(1),MT2(3),MQ2(3)+PTMAX**2,MQ2(3))
        YMAX  = MIN(YJJMAX, LOG(PHEP(5,3)/MT34))
        YMIN  = MAX(YJJMIN,-LOG(PHEP(5,3)/MT34))
        YJAC  = (YMAX-YMIN)
        YMAX  = MIN(YJMAX, LOG((PHEP(5,3)-MT34*EY34)/MT(3)))
        YMIN  = MAX(YJMIN,-LOG((PHEP(5,3)-MT34/EY34)/MT(3)))
        YJAC  = (YMAX-YMIN)*YJAC
        G(6)  = 2.0D0*MJAC/YJAC*PTJ(1)
      ENDIF
C--add them all up
      DEM = ZERO
      DO I=1,IMAXCH
        IF(CHON(I)) DEM = DEM+CHNPRB(I)*G(I)
      ENDDO
C--now the weight
      WEIGHT = FLUX*GEV2NB*G(ICH)/DEM
      GEN = .TRUE.
C--compute the weights for the different channels if optimizing
      IF(OPTM) THEN
        DO I=1,IMAXCH
          IF(CHON(I)) WI(I)=G(I)*WEIGHT**2/DEM
        ENDDO
      ENDIF
      END
CDECK  ID>, HWH2P1.
*CMZ :-        -02/04/01  12.11.55  by  Peter Richardson
*-- Author :    Peter Richardson
C-----------------------------------------------------------------------
      SUBROUTINE HWH2P1(IOPT,FJAC,MQ2,M2,MMX,MMN)
C-----------------------------------------------------------------------
C     Subroutine to select virtual quark mass for HWH2PS
C     IOPT=1 return the function at M2
C     IOPT=2 calculate M2
C-----------------------------------------------------------------------
      INCLUDE 'HERWIG65.INC'
      INTEGER IOPT
      DOUBLE PRECISION FJAC,MPOW,MMN,MQ2,M2,A1,A01,RPOW,QPOW,HWRGEN,MMX
      EXTERNAL HWRGEN
C--smooth a powerlaw
      IF(EMPOW.EQ.TWO) THEN
        A01   = LOG(MMN-MQ2)
        A1    = LOG(MMX-MQ2)-A01
        IF(IOPT.EQ.1) THEN
          FJAC = ONE/(M2-MQ2)/A1
        ELSE
          M2 = EXP(A01+A1*HWRGEN(2))
          FJAC  = A1*M2
          M2 = M2+MQ2
        ENDIF
      ELSE
        MPOW = -EMPOW/TWO
        QPOW =  ONE+MPOW
        RPOW =  ONE/QPOW
        A01  =  (MMN-MQ2)**QPOW
        A1   =  (MMX-MQ2)**QPOW-A01
        IF(IOPT.EQ.1) THEN
          FJAC = QPOW*(M2-MQ2)**MPOW/A1
        ELSE
          M2 = (A01+A1*HWRGEN(2))**RPOW
          FJAC  = A1*RPOW/M2**MPOW
          M2 = M2+MQ2
        ENDIF
      ENDIF
      END
CDECK  ID>, HWH2P2.
*CMZ :-        -02/04/01  12.11.55  by  Peter Richardson
*-- Author :    Peter Richardson
C-----------------------------------------------------------------------
      SUBROUTINE HWH2P2(IOPT,FJAC,PT2,PTMX2,PTMN2)
C-----------------------------------------------------------------------
C     Subroutine to select virtual quark mass for HWH2PS
C     IOPT=1 return the function at M2
C     IOPT=2 calculate M2
C-----------------------------------------------------------------------
      INCLUDE 'HERWIG65.INC'
      INTEGER IOPT
      DOUBLE PRECISION FJAC,MPOW,A1,A01,RPOW,QPOW,HWRGEN,PT2,
     &     PPOW,PTMN2,PTMX2,Z
      EXTERNAL HWRGEN
C--smooth a powerlaw
      PPOW = HALF*PTPOW
      IF(PPOW.EQ.ONE) THEN
        A01   = LOG(PTMN2)
        A1    = LOG(PTMX2)-A01
        IF(IOPT.EQ.1) THEN
          FJAC = ONE/PT2/A1
        ELSE
          PT2 = EXP(A01+A1*HWRGEN(2))
          FJAC  = A1*PT2
        ENDIF
      ELSE
        MPOW = -PPOW
        QPOW =  ONE+MPOW
        RPOW =  ONE/QPOW
        A01  =  PTMN2**QPOW
        A1   =  PTMX2**QPOW-A01
        IF(IOPT.EQ.1) THEN
          FJAC = QPOW*PT2**MPOW/A1
        ELSE
          Z    = A01+A1*HWRGEN(2)
          PT2  = Z**RPOW
          FJAC = A1*RPOW/Z*PT2
        ENDIF
      ENDIF
      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))
      SAVE MGM4,PERM0,PL,FACL,PR,FACR,PERMU0,FAC0,U0
      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 /
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
      END
CDECK  ID>, HWH2SH.
*CMZ :-        -30/06/01  18.25.35  by  Stefano Moretti
*-- Author :  Kosuke Odagiri & Stefano Moretti
C-----------------------------------------------------------------------
      SUBROUTINE HWH2SH(SQS,P1,P2,P3,P4,P5,RM3,RM4,RM5,MGM3,MGM4,
     & IGG,IQQ,GGSQHT,GGSQHU,GGSQHN,QQSQH)
C-----------------------------------------------------------------------
C     MATRIX ELEMENT SQUARED FOR THE PROCESS GG/QQ(BAR) -> SQ SQ* HIGGS
C-----------------------------------------------------------------------
C     NEEDS PREFACTOR G_S^4 AND G_(HIGGS-SQ-SQ)^2
C     MGM3, MGM4 = MASS * WIDTH
C     INITIAL STATE MOMENTA: P1=(SQS/2)(1,0,0,1), P2=(SQS/2)(1,0,0,-1)
C     PREFACTORS:
C     GGSQHTOT =
C     (G_S**4)*(G_HIGGS**2)*(GGSQHT+GGSQHU-GGSQHN/CAFAC**2)/(8.*CFFAC)
C     QQSQHTOT =
C     (G_S**4)*(G_HIGGS**2)*(QQSQH                        )*(1.-1./CAFAC**2)/4.
C     N.B. SUBROUTINE CANNOT BE USED FOR PHOTON PHOTON -> ...
C
C...First release:  08-OCT-1999 by Kosuke Odagiri
C...First modified: 12-NOV-1999 by Stefano Moretti
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 RM3,RM4,RM5, MGM3,MGM4
C --- POLARISATION INDICES, PROPAGATORS AND GG AMPLITUDES
      INTEGER I,J
      DOUBLE PRECISION G14,G24,G23,G13,MSQS, GGSQHT,GGSQHU,GGSQHN
      DOUBLE COMPLEX G35,G45, AMPT,AMPU,AMPS,AMPC, AMPST,AMPSU,AMPTU
C --- QQ AMPLITUDES
      DOUBLE PRECISION QQSQH
      DOUBLE PRECISION PT32,PT42,PT34
      DOUBLE COMPLEX PROP3,PROP4
C --- CONSTANT PARAMETERS
      DOUBLE PRECISION ZERO,ONE,TWO,SQTWO,MSQTWO
      PARAMETER (ZERO=0.D0,ONE=1.D0,TWO=2.D0)
      SQTWO=SQRT(TWO)
      MSQTWO=-SQTWO/4.D0
      GGSQHT = ZERO
      GGSQHU = ZERO
      GGSQHN = ZERO
      QQSQH  = ZERO
      IF(IGG.EQ.0)GOTO 100
C -- GG SCATTERING.
      MSQS = -SQTWO/SQS
      G13  = MSQS/(P3(0)-P3(3))
      G23  = MSQS/(P3(0)+P3(3))
      G14  = MSQS/(P4(0)-P4(3))
      G24  = MSQS/(P4(0)+P4(3))
      G35  = SQTWO/CMPLX(SQS*(SQS-TWO*P4(0)),MGM4)
      G45  = SQTWO/CMPLX(SQS*(SQS-TWO*P3(0)),MGM3)
      AMPS = 0.5D0*MSQS*(P4(3)*G35-P3(3)*G45)
      AMPC = MSQTWO*(G35+G45)
      DO 10 I = 1,2
       DO 20 J = 1,2
        AMPT=P3(I)*P4(J)*G24*G13-P4(I)*P4(J)*G24*G35-P3(I)*P3(J)*G13*G45
        AMPU=P4(I)*P3(J)*G14*G23-P4(I)*P4(J)*G14*G35-P3(I)*P3(J)*G23*G45
        IF (I.EQ.J) THEN
         AMPST = AMPT-AMPS+AMPC
         AMPSU = AMPU+AMPS+AMPC
        ELSE
         AMPST = AMPT
         AMPSU = AMPU
        END IF
        AMPTU  = AMPST+AMPSU
        GGSQHT = GGSQHT + DREAL(DCONJG(AMPST)*AMPST)
        GGSQHU = GGSQHU + DREAL(DCONJG(AMPSU)*AMPSU)
        GGSQHN = GGSQHN + DREAL(DCONJG(AMPTU)*AMPTU)
 20    CONTINUE
 10   CONTINUE
 100  CONTINUE
      IF(IQQ.EQ.0)GOTO 200
C -- QQ SCATTERING.
      PT32  = P3(1)**2+P3(2)**2
      PT42  = P4(1)**2+P4(2)**2
      PT34  = P3(1)*P4(1)+P3(2)*P4(2)
      PROP3 = ONE/CMPLX(SQS*(SQS-TWO*P3(0)),MGM3)
      PROP4 = ONE/CMPLX(SQS*(SQS-TWO*P4(0)),MGM4)
      QQSQH = TWO/SQS**2*DREAL(PT32*DCONJG(PROP3)*PROP3+
     &            PT42*DCONJG(PROP4)*PROP4-TWO*PT34*DCONJG(PROP3)*PROP4)
 200  CONTINUE
      END
CDECK  ID>, HWH2SS
*CMZ :-        -27/02/01  17:04:16  by  Peter Richardson
C-----------------------------------------------------------------------
      SUBROUTINE HWH2SS(S,K,KK)
C-----------------------------------------------------------------------
C     Subroutine to calculate the spinor products in the notation of
C     Kleiss and Strirling S(1) is S and S(2) is T
C-----------------------------------------------------------------------
      INCLUDE 'HERWIG65.INC'
      DOUBLE PRECISION WRN(2),K(5),KK(5),P(5,2),Q1,Q2,EPS,QTI,PTI,
     &     PT,QT,DPM,DMP,QP,QM,P1,P2,PP,PM
      DOUBLE COMPLEX S(2),ZI,Z1,ZT,ZQ,ZQS,ZPS,ZP,ZDPM,ZDMP
      INTEGER I,II,JJ
      EPS=0.0000001
      ZI=DCMPLX(ZERO,ONE)
      Z1=DCMPLX(ONE,ZERO)
C FOLLOWING DO LOOP IS TO CONVERT TO OUR STANDARD INDEXING
      DO I=1,4
        P(I,2) = K(I)
        P(I,1) = KK(I)
      ENDDO
      DO 2 II=1,2
      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
      Q1=P(4,1)+P(1,1)
      QP=ZERO
      IF(Q1.GT.EPS) QP=SQRT(Q1)
      Q2=P(4,1)-P(1,1)
      QM=0.0
      IF(Q2.GT.EPS)QM=SQRT(Q2)
      P1=P(4,2)+P(1,2)
      PP=ZERO
      IF(P1.GT.EPS)PP=SQRT(P1)
      P2=P(4,2)-P(1,2)
      PM=ZERO
      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,2)**2+P(3,2)**2)
      QT=SQRT(P(2,1)**2+P(3,1)**2)
      IF(PT.GT.EPS) GOTO 99
      ZP=Z1
      GOTO 98
   99 PTI=ONE/PT
      ZP=DCMPLX(PTI*P(2,2),PTI*P(3,2))
   98 ZPS=DCONJG(ZP)
      IF(QT.GT.EPS) GOTO 89
      ZQ=Z1
      GOTO 88
   89 QTI=ONE/QT
      ZQ=DCMPLX(QTI*P(2,1),QTI*P(3,1))
   88 ZQS=DCONJG(ZQ)
      ZT=Z1
      IF(WRN(1).LT.ZERO) ZT=ZT*ZI
      IF(WRN(2).LT.ZERO) ZT=ZT*ZI
      S(2)=-(ZDMP*ZP-ZDPM*ZQ)*ZT
      S(1)=(ZDMP*ZPS-ZDPM*ZQS)*ZT
      END
CDECK  ID>, HWH2T1.
*CMZ :-        -27/02/01  17:04:16  by  Peter Richardson
*-- Author :    Peter Richardson
C-----------------------------------------------------------------------
      FUNCTION HWH2T1(I,J,K,L,Z1,Z2,P1)
C-----------------------------------------------------------------------
C     Returns the amplitude T1 from Nucl. Phys. B262 (1985) 235-262
C     I-L are the particles
C     Z1 and Z2 are the decay products of the Z
C     P1 is the polarization of the line I,J
C-----------------------------------------------------------------------
      INCLUDE 'HERWIG65.INC'
      DOUBLE COMPLEX HWH2T1,S,D
      INTEGER I,J,K,L,Z1,Z2,P1
      COMMON/HWHEWS/S(8,8,2),D(8,8)
      IF(P1.EQ.1) THEN
        HWH2T1 = TWO*S(I,Z2,1)*S(Z1,J,2)
      ELSEIF(P1.EQ.2) THEN
        HWH2T1 = TWO*S(I,Z1,2)*S(Z2,J,1)
      ELSE
        CALL HWWARN('HWH2T1',500)
      ENDIF
      END
CDECK  ID>, HWH2T2
*CMZ :-        -27/02/01  17:04:16  by  Peter Richardson
*-- Author :    Peter Richardson
C-----------------------------------------------------------------------
      FUNCTION HWH2T2(I,J,K,L,Z1,Z2,P1,P2)
C-----------------------------------------------------------------------
C     Returns the amplitude T2 from Nucl. Phys. B262 (1985) 235-262
C     I-L are the particles
C     Z1 and Z2 are the decay products of the Z
C     P1 is the polarization of the line I,J
C     P2 is the polarization of the gluon K
C-----------------------------------------------------------------------
      INCLUDE 'HERWIG65.INC'
      DOUBLE COMPLEX HWH2T2,S,D
      INTEGER I,J,K,L,Z1,Z2,P1,P2
      DOUBLE PRECISION B(6)
      COMMON/HWHEWS/S(8,8,2),D(8,8)
      SAVE B
      DATA B/-1.0D0,-1.0D0,1.0D0,1.0D0,1.0D0,1.0D0/
      IF(P1.EQ.1.AND.P2.EQ.1) THEN
        HWH2T2 = FOUR*B(J)*S(I,Z2,1)*S(Z1,J,2)*S(J,K,1)*S(I,J,2)
      ELSEIF(P1.EQ.1.AND.P2.EQ.2) THEN
        HWH2T2 = FOUR*S(I,Z2,1)*S(K,J,2)*(B(J)*S(Z1,J,2)*S(J,I,1)
     &                                +B(K)*S(Z1,K,2)*S(K,I,1))
      ELSEIF(P1.EQ.2.AND.P2.EQ.1) THEN
        HWH2T2 = FOUR*S(I,Z1,2)*S(K,J,1)*(B(J)*S(Z2,J,1)*S(J,I,2)
     &                                +B(K)*S(Z2,K,1)*S(K,I,2))
      ELSEIF(P1.EQ.2.AND.P2.EQ.2) THEN
        HWH2T2 = FOUR*B(J)*S(I,Z1,2)*S(Z2,J,1)*S(J,K,2)*S(I,J,1)
      ELSE
        CALL HWWARN('HWH2T2',500)
      ENDIF
      END
CDECK  ID>, HWH2T3.
*CMZ :-        -27/02/01  17:04:16  by  Peter Richardson
*-- Author :    Peter Richardson
C-----------------------------------------------------------------------
      FUNCTION HWH2T3(I,J,K,L,Z1,Z2,P1,P2)
C-----------------------------------------------------------------------
C     Returns the amplitude T3 from Nucl. Phys. B262 (1985) 235-262
C     I-L are the particles
C     Z1 and Z2 are the decay products of the Z
C     P1 is the polarization of the line I,J
C     P2 is the polarization of the gluon K
C-----------------------------------------------------------------------
      INCLUDE 'HERWIG65.INC'
      DOUBLE COMPLEX HWH2T3,S,D
      INTEGER I,J,K,L,Z1,Z2,P1,P2
      DOUBLE PRECISION B(6)
      COMMON/HWHEWS/S(8,8,2),D(8,8)
      SAVE B
      DATA B/-1.0D0,-1.0D0,1.0D0,1.0D0,1.0D0,1.0D0/
      IF(P1.EQ.1.AND.P2.EQ.1) THEN
        HWH2T3 = FOUR*B(K)*S(I,K,1)*S(I,K,2)*S(K,Z2,1)*S(Z1,J,2)
      ELSEIF(P1.EQ.1.AND.P2.EQ.2) THEN
        HWH2T3 = ZERO
      ELSEIF(P1.EQ.2.AND.P2.EQ.1) THEN
        HWH2T3 = ZERO
      ELSEIF(P1.EQ.2.AND.P2.EQ.2) THEN
        HWH2T3 = FOUR*B(K)*S(I,K,2)*S(I,K,1)*S(K,Z1,2)*S(Z2,J,1)
      ELSE
        CALL HWWARN('HWH2T3',500)
      ENDIF
      END
CDECK  ID>, HWH2T4
*CMZ :-        -27/02/01  17:04:16  by  Peter Richardson
*-- Author :    Peter Richardson
C-----------------------------------------------------------------------
      FUNCTION HWH2T4(I,J,K,L,Z1,Z2,P1,P2)
C-----------------------------------------------------------------------
C     Returns the amplitude T4 from Nucl. Phys. B262 (1985) 235-262
C     I-L are the particles
C     Z1 and Z2 are the decay products of the Z
C     P1 is the polarization of the line I,J
C     P2 is the polarization of the line K,L
C-----------------------------------------------------------------------
      INCLUDE 'HERWIG65.INC'
      DOUBLE COMPLEX HWH2T4,AP,AM,S,D
      INTEGER I,J,K,L,Z1,Z2,J1,J2,J3,J4,P1,P2
      DOUBLE PRECISION B(6)
      COMMON/HWHEWS/S(8,8,2),D(8,8)
      SAVE B
      DATA B/-1.0D0,-1.0D0,1.0D0,1.0D0,1.0D0,1.0D0/
      AP(J1,J2,J3,J4) = FOUR*S(J1,Z2,1)*S(J4,J2,2)*
     &     (S(Z1,Z2,2)*S(Z2,J3,1)+B(J1)*S(Z1,J1,2)*S(J1,J3,1))
      AM(J1,J2,J3,J4) = FOUR*S(J1,Z1,2)*S(J4,J2,1)*
     &     (S(Z2,Z1,1)*S(Z1,J3,2)+B(J1)*S(Z2,J1,1)*S(J1,J3,2))
      IF(P1.EQ.1.AND.P2.EQ.1) THEN
        HWH2T4 = AP(I,J,K,L)
      ELSEIF(P1.EQ.1.AND.P2.EQ.2) THEN
        HWH2T4 = AP(I,J,L,K)
      ELSEIF(P1.EQ.2.AND.P2.EQ.1) THEN
        HWH2T4 = AM(I,J,L,K)
      ELSEIF(P1.EQ.2.AND.P2.EQ.2) THEN
        HWH2T4 = AM(I,J,K,L)
      ELSE
        CALL HWWARN('HWH2T4',500)
      ENDIF
      END
CDECK  ID>, HWH2T5
*CMZ :-        -27/02/01  17:04:16  by  Peter Richardson
*-- Author :    Peter Richardson
C-----------------------------------------------------------------------
      FUNCTION HWH2T5(I,J,K,L,Z1,Z2,P1,P2)
C-----------------------------------------------------------------------
C     Returns the amplitude T5 from Nucl. Phys. B262 (1985) 235-262
C     I-L are the particles
C     Z1 and Z2 are the decay products of the Z
C     P1 is the polarization of the line I,J
C     P2 is the polarization of the line K,L
C-----------------------------------------------------------------------
      INCLUDE 'HERWIG65.INC'
      DOUBLE COMPLEX HWH2T5,AP,AM,S,D
      INTEGER I,J,K,L,Z1,Z2,J1,J2,J3,J4,P1,P2
      DOUBLE PRECISION B(6)
      COMMON/HWHEWS/S(8,8,2),D(8,8)
      SAVE B
      DATA B/-1.0D0,-1.0D0,1.0D0,1.0D0,1.0D0,1.0D0/
      AP(J1,J2,J3,J4) = FOUR*S(J1,Z2,1)*S(J4,J2,2)*
     &     (S(Z1,Z2,2)*S(Z2,J3,1)+B(J1)*S(Z1,J1,2)*S(J1,J3,1))
      AM(J1,J2,J3,J4) = FOUR*S(J1,Z1,2)*S(J4,J2,1)*
     &     (S(Z2,Z1,1)*S(Z1,J3,2)+B(J1)*S(Z2,J1,1)*S(J1,J3,2))
      IF(P1.EQ.1.AND.P2.EQ.1) THEN
        HWH2T5 = AM(J,I,L,K)
      ELSEIF(P1.EQ.1.AND.P2.EQ.2) THEN
        HWH2T5 = AM(J,I,K,L)
      ELSEIF(P1.EQ.2.AND.P2.EQ.1) THEN
        HWH2T5 = AP(J,I,K,L)
      ELSEIF(P1.EQ.2.AND.P2.EQ.2) THEN
        HWH2T5 = AP(J,I,L,K)
      ELSE
        CALL HWWARN('HWH2T5',500)
      ENDIF
      END
CDECK  ID>, HWH2T6
*CMZ :-        -27/02/01  17:04:16  by  Peter Richardson
*-- Author :    Peter Richardson
C-----------------------------------------------------------------------
      FUNCTION HWH2T6(I,J,K,L,Z1,Z2,P1,P2,P3)
C-----------------------------------------------------------------------
C     Returns the amplitude T6 from Nucl. Phys. B262 (1985) 235-262
C     I-L are the particles
C     Z1 and Z2 are the decay products of the Z
C     P1 is the polarization of the line I,J
C     P2 is the polarization of the gluon K
C     P3 is the polarization of the gluon L
C-----------------------------------------------------------------------
      INCLUDE 'HERWIG65.INC'
      DOUBLE COMPLEX HWH2T6,S,D
      INTEGER I,J,K,L,Z1,Z2,J1,J2,P1,P2,P3
      DOUBLE PRECISION B(6)
      COMMON/HWHEWS/S(8,8,2),D(8,8)
      SAVE B
      DATA B/-1.0D0,-1.0D0,1.0D0,1.0D0,1.0D0,1.0D0/
      IF(P1.EQ.1) THEN
         J1 = Z1
         J2 = Z2
      ELSE
         J1 = Z2
         J2 = Z1
      ENDIF
      IF((P1.EQ.1.AND.P2.EQ.1.AND.P3.EQ.1).OR.
     &   (P1.EQ.2.AND.P2.EQ.2.AND.P3.EQ.2)) THEN
        HWH2T6 = 8.0D0*B(J)*S(I,J2,1)*D(L,J)*S(K,J,2)*
     &             (B(J)*S(J1,J,2)*S(J,K,1)+B(L)*S(J1,L,2)*S(L,K,1))
      ELSEIF((P1.EQ.1.AND.P2.EQ.1.AND.P3.EQ.2).OR.
     &       (P1.EQ.2.AND.P2.EQ.2.AND.P3.EQ.1)) THEN
        HWH2T6 = 8.0D0*B(J)*S(I,J2,1)*S(L,J,2)*S(J,K,1)*S(L,J,2)*
     &            (B(J)*S(J1,J,2)*S(J,K,1)+B(L)*S(J1,L,2)*S(L,K,1))
      ELSEIF((P1.EQ.1.AND.P2.EQ.2.AND.P3.EQ.1).OR.
     &       (P1.EQ.2.AND.P2.EQ.1.AND.P3.EQ.2)) THEN
        HWH2T6 = 8.0D0*B(J)*S(I,J2,1)*S(K,J,2)*S(J,L,1)*S(K,J,2)*
     &            (B(J)*S(J1,J,2)*S(J,L,1)+B(K)*S(J1,K,2)*S(K,L,1))
      ELSEIF((P1.EQ.1.AND.P2.EQ.2.AND.P3.EQ.2).OR.
     &       (P1.EQ.2.AND.P2.EQ.1.AND.P3.EQ.1)) THEN
        HWH2T6 = 8.0D0*S(I,J2,1)*S(L,J,2)*(B(J)*D(K,J)+B(L)*D(K,L))*
     &             (B(J)*S(J1,J,2)*S(J,L,1)+B(K)*S(J1,K,2)*S(K,L,1))
      ELSE
        CALL HWWARN('HWH2T6',500)
      ENDIF
      IF(P1.EQ.2) HWH2T6 = DCONJG(HWH2T6)
      END
CDECK  ID>, HWH2T7
*CMZ :-        -27/02/01  17:04:16  by  Peter Richardson
*-- Author :    Peter Richardson
C-----------------------------------------------------------------------
      FUNCTION HWH2T7(I,J,K,L,Z1,Z2,P1,P2,P3)
C-----------------------------------------------------------------------
C     Returns the amplitude T7 from Nucl. Phys. B262 (1985) 235-262
C     I-L are the particles
C     Z1 and Z2 are the decay products of the Z
C     P1 is the polarization of the line I,J
C     P2 is the polarization of the gluon K
C     P3 is the polarization of the gluon L
C-----------------------------------------------------------------------
      INCLUDE 'HERWIG65.INC'
      DOUBLE COMPLEX HWH2T7,S,D
      INTEGER I,J,K,L,Z1,Z2,J1,J2,P1,P2,P3
      DOUBLE PRECISION B(6)
      COMMON/HWHEWS/S(8,8,2),D(8,8)
      SAVE B
      DATA B/-1.0D0,-1.0D0,1.0D0,1.0D0,1.0D0,1.0D0/
      IF(P1.EQ.1) THEN
        J1 = Z1
        J2 = Z2
      ELSE
        J1 = Z2
        J2 = Z1
      ENDIF
      IF((P1.EQ.1.AND.P2.EQ.1.AND.P3.EQ.1).OR.
     &   (P1.EQ.2.AND.P2.EQ.2.AND.P3.EQ.2)) THEN
        HWH2T7 = 8.0D0*B(J)*S(I,K,1)*S(J1,J,2)*S(J,L,1)*S(K,J,2)*
     &                 (B(I)*S(L,I,2)*S(I,J2,1)+B(K)*S(L,K,2)*S(K,J2,1))
      ELSEIF((P1.EQ.1.AND.P2.EQ.1.AND.P3.EQ.2).OR.
     &       (P1.EQ.2.AND.P2.EQ.2.AND.P3.EQ.1)) THEN
        HWH2T7 = 8.0D0*S(I,K,1)*S(L,J,2)*
     &                (B(I)*S(L,I,2)*S(I,J2,1)+B(K)*S(L,K,2)*S(K,J2,1))*
     &                (B(J)*S(J1,J,2)*S(J,K,1)+B(L)*S(J1,L,2)*S(L,K,1))
      ELSEIF((P1.EQ.1.AND.P2.EQ.2.AND.P3.EQ.1).OR.
     &       (P1.EQ.2.AND.P2.EQ.1.AND.P3.EQ.2)) THEN
        HWH2T7 = 8.0D0*B(I)*B(J)*S(I,L,1)*S(K,I,2)*
     &        S(I,J2,1)*S(J1,J,2)*S(J,L,1)*S(K,J,2)
      ELSEIF((P1.EQ.1.AND.P2.EQ.2.AND.P3.EQ.2).OR.
     &       (P1.EQ.2.AND.P2.EQ.1.AND.P3.EQ.1)) THEN
        HWH2T7 = 8.0D0*B(I)*S(I,L,1)*S(K,I,2)*S(I,J2,1)*S(L,J,2)*
     &                 (B(J)*S(J1,J,2)*S(J,K,1)+B(L)*S(J1,L,2)*S(L,K,1))
      ELSE
        CALL HWWARN('HWH2T7',500)
      ENDIF
      IF(P1.EQ.2) HWH2T7 = DCONJG(HWH2T7)
      END
CDECK  ID>, HWH2T8
*CMZ :-        -27/02/01  17:04:16  by  Peter Richardson
*-- Author :    Peter Richardson
C-----------------------------------------------------------------------
      FUNCTION HWH2T8(I,J,K,L,Z1,Z2,P1,P2,P3)
C-----------------------------------------------------------------------
C     Returns the amplitude T8 from Nucl. Phys. B262 (1985) 235-262
C     I-L are the particles
C     Z1 and Z2 are the decay products of the Z
C     P1 is the polarization of the line I,J
C     P2 is the polarization of the gluon K
C     P3 is the polarization of the gluon L
C-----------------------------------------------------------------------
      INCLUDE 'HERWIG65.INC'
      DOUBLE COMPLEX HWH2T8,S,D
      INTEGER I,J,K,L,Z1,Z2,J1,J2,P1,P2,P3
      DOUBLE PRECISION B(6)
      COMMON/HWHEWS/S(8,8,2),D(8,8)
      SAVE B
      DATA B/-1.0D0,-1.0D0,1.0D0,1.0D0,1.0D0,1.0D0/
      IF(P1.EQ.1) THEN
        J1 = Z1
        J2 = Z2
      ELSE
        J1 = Z2
        J2 = Z1
      ENDIF
      IF((P1.EQ.1.AND.P2.EQ.1.AND.P3.EQ.1).OR.
     &   (P1.EQ.2.AND.P2.EQ.2.AND.P3.EQ.2)) THEN
        HWH2T8 = 8.0D0*S(I,K,1)*S(J1,J,2)*(B(I)*D(L,I)+B(K)*D(L,K))*
     &                (B(I)*S(K,I,2)*S(I,J2,1)+B(L)*S(K,L,2)*S(L,J2,1))
      ELSEIF((P1.EQ.1.AND.P2.EQ.1.AND.P3.EQ.2).OR.
     &       (P1.EQ.2.AND.P2.EQ.2.AND.P3.EQ.1)) THEN
        HWH2T8 = 8.0D0*B(I)*S(I,K,1)*S(L,I,2)*S(I,K,1)*S(J1,J,2)*
     &                 (B(I)*S(L,I,2)*S(I,J2,1)+B(K)*S(L,K,2)*S(K,J2,1))
      ELSEIF((P1.EQ.1.AND.P2.EQ.2.AND.P3.EQ.1).OR.
     &       (P1.EQ.2.AND.P2.EQ.1.AND.P3.EQ.2)) THEN
        HWH2T8 = 8.0D0*B(I)*S(I,L,1)*S(K,I,2)*S(I,L,1)*S(J1,J,2)*
     &                 (B(I)*S(K,I,2)*S(I,J2,1)+B(L)*S(K,L,2)*S(L,J2,1))
      ELSEIF((P1.EQ.1.AND.P2.EQ.2.AND.P3.EQ.2).OR.
     &       (P1.EQ.2.AND.P2.EQ.1.AND.P3.EQ.1)) THEN
        HWH2T8 = 8.0D0*B(I)*S(I,L,1)*D(I,K)*S(J1,J,2)*
     &                 (B(I)*S(L,I,2)*S(I,J2,1)+B(K)*S(L,K,2)*S(K,J2,1))
      ELSE
        CALL HWWARN('HWH2T8',500)
      ENDIF
      IF(P1.EQ.2) HWH2T8 = DCONJG(HWH2T8)
      END
CDECK  ID>, HWH2T9
*CMZ :-        -27/02/01  17:04:16  by  Peter Richardson
*-- Author :    Peter Richardson
C-----------------------------------------------------------------------
      FUNCTION HWH2T9(I,J,K,L,Z1,Z2,P1,P2,P3)
C-----------------------------------------------------------------------
C     Returns the amplitude T9 from Nucl. Phys. B262 (1985) 235-262
C     N.B. DELTA FUNCTION FOR THE GLUON POLARIZATIONS HERE
C     I-L are the particles
C     Z1 and Z2 are the decay products of the Z
C     P1 is the polarization of the line I,J
C     P2 is the polarization of the gluon K
C     P3 is the polarization of the gluon L
C-----------------------------------------------------------------------
      INCLUDE 'HERWIG65.INC'
      DOUBLE COMPLEX HWH2T9,S,D
      INTEGER I,J,K,L,Z1,Z2,J1,J2,P1,P2,P3
      DOUBLE PRECISION B(6)
      COMMON/HWHEWS/S(8,8,2),D(8,8)
      SAVE B
      DATA B/-1.0D0,-1.0D0,1.0D0,1.0D0,1.0D0,1.0D0/
      IF(P2.NE.P3) THEN
         HWH2T9 = ZERO
      ELSE
        IF(P1.EQ.1) THEN
          J1 = Z1
          J2 = Z2
        ELSEIF(P1.EQ.2) THEN
          J1 = Z2
          J2 = Z1
        ENDIF
        HWH2T9 = TWO*S(I,J2,1)*(
     &           B(K)*S(K,J,2)*(B(J)*S(J1,J,2)*S(J,K,1)
     &                           +B(L)*S(J1,L,2)*S(L,K,1))
     &          -B(L)*S(L,J,2)*(B(J)*S(J1,J,2)*S(J,L,1)
     &                           +B(K)*S(J1,K,2)*S(K,L,1)))
        IF(P1.EQ.2) HWH2T9 = DCONJG(HWH2T9)
      ENDIF
      END
CDECK  ID>, HWH2T0
*CMZ :-        -27/02/01  17:04:16  by  Peter Richardson
*-- Author :    Peter Richardson
C-----------------------------------------------------------------------
      FUNCTION HWH2T0(I,J,K,L,Z1,Z2,P1,P2,P3)
C-----------------------------------------------------------------------
C     Returns the amplitude T10 from Nucl. Phys. B262 (1985) 235-262
C     N.B. DELTA FUNCTION FOR THE GLUON POLARIZATIONS HERE
C     I-L are the particles
C     Z1 and Z2 are the decay products of the Z
C     P1 is the polarization of the line I,J
C     P2 is the polarization of the gluon K
C     P3 is the polarization of the gluon L
C-----------------------------------------------------------------------
      INCLUDE 'HERWIG65.INC'
      DOUBLE COMPLEX HWH2T0,S,D
      INTEGER I,J,K,L,Z1,Z2,J1,J2,P1,P2,P3
      DOUBLE PRECISION B(6)
      COMMON/HWHEWS/S(8,8,2),D(8,8)
      SAVE B
      DATA B/-1.0D0,-1.0D0,1.0D0,1.0D0,1.0D0,1.0D0/
      IF(P2.NE.P3) THEN
         HWH2T0 = ZERO
      ELSE
        IF(P1.EQ.1) THEN
          J1 = Z1
          J2 = Z2
        ELSEIF(P1.EQ.2) THEN
          J1 = Z2
          J2 = Z1
        ENDIF
        HWH2T0 = TWO*S(J1,J,2)*(
     &            B(K)*S(I,K,1)*(B(I)*S(K,I,2)*S(I,J2,1)
     &                           +B(L)*S(K,L,2)*S(L,J2,1))
     &           -B(L)*S(I,L,1)*(B(I)*S(L,I,2)*S(I,J2,1)
     &                           +B(K)*S(L,K,2)*S(K,J2,1)))
        IF(P1.EQ.2) HWH2T0 = DCONJG(HWH2T0)
      ENDIF
      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')                             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
      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 'HERWIG65.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
      SAVE IST
      DATA QLST,YLST,IST/-1D0,-1D0,113,114,114,114/
C
      IF (GENEV) THEN
        RCS=HCS*HWRGEN(0)
      ELSE
        IF (NHEP+5.GT.NMXHEP) THEN
          CALL HWWARN('HWH4JT',100)
          GOTO 999
        ENDIF
        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(IERROR.NE.0) RETURN
        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)
            GOTO 999
          ENDIF
          WTOT=WTAB+WTBA
          IF (WTAB.GT.HWRGEN(1)*WTOT) THEN
            CALL HWHQCP( 13, 13,3142,91)
            GOTO 99
          ELSE
            CALL HWHQCP( 13, 13,4123,92)
            GOTO 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)
            GOTO 999
          ENDIF
          WTOT=WTAB+WTBA
          IF (WTAB.GT.HWRGEN(1)*WTOT) THEN
            CALL HWHQCP(ID1,ID1+6,4123,93)
            GOTO 99
          ELSE
            CALL HWHQCP(ID1,ID1+6,2143,94)
            GOTO 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) THEN
          CALL HWHQCP(ID2,ID2+6,4123,95)
          GOTO 99
        ENDIF
      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  RETURN
      END
CDECK  ID>, HWH4J1.
*CMZ :-        -01/04/99  19.47.55  by  Mike Seymour
*-- Author :    Ian Knowles
*- Split in 6 files by M. Kirsanov.
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,
     & S12,S13,S14,S23,S24,S34,S123,S124,S134,S234,S,EP1,EP2,EP3,EP4
      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
      END
CDECK  ID>, HWH4J2.
*CMZ :-        -01/04/99  19.47.55  by  Mike Seymour
*-- Author :    Ian Knowles
C-----------------------------------------------------------------------
      FUNCTION HWH4J2(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 HWH4J2,
     & S12,S13,S14,S23,S24,S34,S123,S124,S134,S234,S,EP1,EP2,EP3,EP4
      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
      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
      END
CDECK  ID>, HWH4J4.
*CMZ :-        -01/04/99  19.47.55  by  Mike Seymour
*-- Author :    Ian Knowles
C-----------------------------------------------------------------------
      FUNCTION HWH4J4(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 HWH4J4,
     & S12,S13,S14,S23,S24,S34,S134,S234,S,EP1,EP2,EP3,EP4
      LOGICAL ORIENT
      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
      END
CDECK  ID>, HWH4J5.
*CMZ :-        -01/04/99  19.47.55  by  Mike Seymour
*-- Author :    Ian Knowles
C-----------------------------------------------------------------------
      FUNCTION HWH4J5(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 HWH4J5,
     & S12,S13,S14,S23,S24,S34,S134,S234,S,EP1,EP2,EP3,EP4,
     & SUM
      LOGICAL ORIENT
      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
      END
CDECK  ID>, HWH4J6.
*CMZ :-        -01/04/99  19.47.55  by  Mike Seymour
*-- Author :    Ian Knowles
C-----------------------------------------------------------------------
      FUNCTION HWH4J6(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 HWH4J6,
     & S12,S13,S14,S23,S24,S34,S123,S124,S134,S234,S,EP1,EP2,EP3,EP4
      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
      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
      END
CDECK  ID>, HWH4J7.
*CMZ :-        -01/04/99  19.47.55  by  Mike Seymour
*-- Author :    Ian Knowles
C-----------------------------------------------------------------------
      FUNCTION HWH4J7(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 HWH4J7,
     & S12,S13,S14,S23,S24,S34,S123,S124,S134,S234,S,EP1,EP2,EP3,EP4
      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
      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
      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 'HERWIG65.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),IFGO
      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)
        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)
        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)
        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 (IFGO)
        IF(IFGO) GOTO 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  RETURN
      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 'HERWIG65.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) THEN
        CALL HWWARN('HWHBKI',101)
        GOTO 999
      ENDIF
      EPROT = SQRT(PPROT**2+MP**2)
      IF ((EPROT+PPROT).LT.(EP+PP)) THEN
        CALL HWWARN('HWHBKI',102)
        GOTO 999
      ENDIF
      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)
        GOTO 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) THEN
        CALL HWWARN ('HWHBKI',104)
        GOTO 999
      ENDIF
      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  RETURN
      END
CDECK  ID>, HWHBRN.
*CMZ :-        -03/07/95  19.02.12  by  Giovanni Abbiendi
*-- Author :    Giovanni Abbiendi & Luca Stanco
C-----------------------------------------------------------------------
      SUBROUTINE HWHBRN (IFGO)
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 'HERWIG65.INC'
      LOGICAL IFGO
      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
      IFGO = .FALSE.
      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)
                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)
                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) THEN
            CALL HWWARN('HWHBRN',50)
            GOTO 10
          ENDIF
          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)
      IFGO = .TRUE.
      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 'HERWIG65.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) THEN
        CALL HWWARN('HWHBSG',51)
        GOTO 888
      ENDIF
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 'HERWIG65.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)
        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)
  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)
          GOTO 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) THEN
          CALL HWWARN('HWHDIS',102)
          GOTO 999
        ENDIF
        IDCMF=15
        CALL HWETWO(.TRUE.,.TRUE.)
      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  RETURN
      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 'HERWIG65.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)
      SAVE IADD
      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)
          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)
          IF (C2.EQ.ZERO) CALL HWWARN('HWHDYP',502)
          IF (C3.EQ.ZERO.AND.ZPRIME) CALL HWWARN('HWHDYP',503)
          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) THEN
          CALL HWHQCP(ID3,ID4,2143,50)
          GOTO 99
        ENDIF
      ELSE
        HCS=HCS+FACTR*CQF(1,IQ,JQ)*FLOAT(NCOLO)
        IF (GENEV.AND.HCS.GT.RCS) THEN
          CALL HWHQCP(ID3,ID4,2143,50)
          GOTO 99
        ENDIF
      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) THEN
        CALL HWHQCP(ID3,ID4,2134,50)
        GOTO 99
      ENDIF
  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(.TRUE.,.TRUE.)
      END
CDECK  ID>, HWHDYQ.
*CMZ :-        -14/03/01  09:03:25  by  Peter Richardson
*-- Author :    Peter Richardson
C-----------------------------------------------------------------------
      SUBROUTINE HWHDYQ(FSTCLL,HCS,IFLOW,IDP,ORD,IQ,MASS)
C-----------------------------------------------------------------------
C     Drell-Yan production with a q qbar pair
C-----------------------------------------------------------------------
      INCLUDE 'HERWIG65.INC'
      INTEGER I,MAP(12),ORD,IFL,IDP(6),IFLOW,QCFL(2,2),GCFL(2),IDZ,IQ
      DOUBLE PRECISION HCS,RCS,MQ(2,5),HWRGEN,G(12,2),DIST(2),MG(2)
      LOGICAL FSTCLL,MASS
      EXTERNAL HWRGEN
      COMMON/HWHZBC/G
      SAVE MQ,MG
      SAVE MAP,QCFL,GCFL
      DATA MAP/1,2,3,4,5,6,11,12,13,14,15,16/
      DATA QCFL/2413,3142,4123,2341/
      DATA GCFL/2413,4123/
      IF(GENEV) THEN
        RCS = HCS*HWRGEN(1)
      ELSE
C--to the initalisation
        IF(FSTCLL) THEN
C--G(I,1) is the right charge and G(I,2) is the left charge
          DO I=1,12
            G(I,1) = VFCH(MAP(I),1)-AFCH(MAP(I),1)
            G(I,2) = VFCH(MAP(I),1)+AFCH(MAP(I),1)
          ENDDO
          FSTCLL = .FALSE.
        ENDIF
C--identify the Z decay product
        IDZ = IDP(5)
        IF(IDZ.GT.6) IDZ = IDZ-114
C--calculate the matrix elements
        IF(MASS) THEN
C--massive case
          CALL HWH2MQ(IQ,IDZ,MG,MQ)
        ELSE
C--massless case
          CALL HWH2M0(IQ,IDZ,MG,MQ)
        ENDIF
      ENDIF
C--multiply the matrix elements by the PDF's to obtain the cross section
      HCS = ZERO
      IDP(3) = IQ
      IDP(4) = IQ+6
C--first the qqbar initial states
      DO I=1,5
        IDP(1) = I
        IDP(2) = IDP(1)+6
        DIST(1) = DISF(IDP(1),1)*DISF(IDP(2),2)
        DIST(2) = DISF(IDP(1),2)*DISF(IDP(2),1)
        DO ORD=1,2
          DO IFL=1,2
            IFLOW = QCFL(IFL,ORD)
            HCS = HCS+DIST(ORD)*MQ(IFL,IDP(1))/36.0D0
            IF(GENEV.AND.HCS.GT.RCS) RETURN
          ENDDO
        ENDDO
      ENDDO
C--then the gluon gluon inital state
      IDP(1) = 13
      IDP(2) = 13
      DIST(1) = DISF(IDP(1),1)*DISF(IDP(1),2)
      DO IFL=1,2
        IFLOW = GCFL(IFL)
        HCS = HCS+DIST(1)*MG(IFL)/256.0D0
        IF(GENEV.AND.HCS.GT.RCS) RETURN
      ENDDO
      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 'HERWIG65.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)
        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) THEN
          CALL HWWARN('HWHEGG',100)
          GOTO 999
        ENDIF
        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) THEN
            CALL HWWARN('HWHEGG',101)
            GOTO 999
          ENDIF
          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) THEN
            CALL HWWARN('HWHEGG',102)
            GOTO 999
          ENDIF
          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  RETURN
      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 'HERWIG65.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),IFGO
      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)
C---program only works if beam and target are charge conjugates
        IF (LEP*(IDHW(2)-IDHW(1)).NE.6) CALL HWWARN('HWHEGW',501)
C---program only works for equal energy beams colliding
        IF (PHEP(3,3).NE.ZERO) CALL HWWARN('HWHEGW',503)
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)
        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)
        ENDIF
        IF (IQK.GT.0) THEN
          IF (IQK.LE.6) IQK=0
          CALL HWHBRN(IFGO)
          IF(IFGO) GOTO 999
          CALL HWHEGX
          EVWGT = 2 * DSIGMA * AJACOB
          IF (EVWGT.LT.ZERO) EVWGT=ZERO
        ELSE
C---SUM OVER QUARK FLAVOURS
          CALL HWHBRN(IFGO)
          IF(IFGO) GOTO 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  RETURN
      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 'HERWIG65.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)
      END
CDECK  ID>, HWHEPA.
*CMZ :-        -12/10/01  10.05.16  by  Peter Richardson
*-- 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 'HERWIG65.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.D0/
      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(2,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
      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 'HERWIG65.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.D0/
      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)
          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
      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 'HERWIG65.INC'
      DOUBLE PRECISION HWRGEN,HWUAEM,EPS,HCS,RCS,S,PF,QPE,HWUPCM,PCM,
     & FACTR,SN2TH,MZ,ME2(2,2,6),EMSC2,HWUMBW,HWRUNI,T,SQPE
      INTEGER ID1,ID2,IL,IL1,IL2,I,J,IG,IG1,IHEP,NTRY,IDL,ILP,IDLR(2),
     & IDSLP(2)
      INTEGER SSNU, SSCH
      PARAMETER (SSNU = 449, SSCH = 453)
      EXTERNAL HWRGEN, HWUAEM,HWUMBW,HWUPCM,HWRUNI
      SAVE HCS,ME2,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))
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(IDL))*CR
                  E  = (A+BL*RFCH(IDL))*CL+(A+BR*RFCH(IDL))*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(
     &                  (ONE-EPOLN(3))*(ONE+PPOLN(3))*DCONJG(D)*D
     &                 +(ONE+EPOLN(3))*(ONE-PPOLN(3))*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
C--production of el- er+
                  IF(I.EQ.1.AND.J.EQ.2) THEN
                    ME2(I,J,IL)=FACT0*PF*F**2*S*
     &                    (ONE-EPOLN(3))*(ONE-PPOLN(3))
                  ELSE
C--production of er- el+
                    ME2(I,J,IL)=FACT0*PF*F**2*S*
     &                    (ONE+EPOLN(3))*(ONE+PPOLN(3))
                  ENDIF
                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)
          GOTO 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(2,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  RETURN
      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 'HERWIG65.INC'
      DOUBLE PRECISION HWRGEN,HWUAEM,HCS,RCS,MNU(4),MNU2(4),HWRUNI,
     &                 FACA,M1(4,4),S2W,XC(4),XD(4),MSNU,
     &                 MZ,HWHSS2,U,T,QPE,SQPE,MSL,MSL2,MSR,MSR2,
     &                 SGN,S,SM,DM,PF,PCM,HWUPCM,XW,S22W,
     &                 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,HWHSS2,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))
      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)
          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)
          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)
        XW    = TWO * SWEIN
        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)
C--modified to include beam polarization PR 10/10/01
              M1(IQ1,IQ2) = FACA*PF*GEV2NB*PIFAC/S*HALF*
     &          HWHSS2(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
C--modified to include beam polarization PR 10/10/01
              M2(IG1,IG2)=FACA*PF*GEV2NB*PIFAC/S*
     &             HWHSS2(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)
          GOTO 999
        ENDIF
C--Set up the colours etc
        ISTHEP(NHEP+2)   = 113
        ISTHEP(NHEP+3)   = 114
        JMOHEP(1,NHEP+1) = 1
C--PR Bug fix 10/10/01
        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(2,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  RETURN
      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 'HERWIG65.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)
      ENDIF
      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 'HERWIG65.INC'
      DOUBLE PRECISION HWRGEN,HWUAEM,EPS,HCS,RCS,S,PF,QPE,HWUPCM,PCM,
     & FACTR,SN2TH,MZ,ME2(2,2,6),EMSC2,HWUMBW,HWRUNI,SQPE
      INTEGER ID1,ID2,IQ,IQ1,IQ2,I,J,IHEP,IDL,IDLR(2),IDSQU(2),NTRY
      EXTERNAL HWRGEN,HWUAEM,HWUMBW,HWUPCM,HWRUNI
      SAVE HCS,ME2,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))
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)
        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(
     &                  (ONE-EPOLN(3))*(ONE+PPOLN(3))*DCONJG(D)*D
     &                 +(ONE+EPOLN(3))*(ONE-PPOLN(3))*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)
          GOTO 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(2,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  RETURN
      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 'HERWIG65.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
      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(8,8),
     & CH(8,8),D(8,8)
      DOUBLE PRECISION ZERO,ONE,PPCM(5,8),P(5,8),WRN(8),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,8
      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)
      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 'HERWIG65.INC'
      DOUBLE COMPLEX HWHEW4,ZH,ZCH,ZD,ZAMP1,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(8,8),ZCH(8,8),ZD(8,8)
      EQUIVALENCE (XW,SWEIN),(ZMASS,RMASS(200))
      SAVE COLFAC,ZTWO,ZHALF
      DATA COLFAC/1.D0,3.D0,3.D0,9.D0/
      DATA ZTWO,ZHALF/(2.0D0,0.0D0),(0.5D0,0.0D0)/
      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))
      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
      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(8,8),ZCH(8,8),ZD(8,8)
      HWHEW4=4*ZH(N1,N3)*ZCH(N2,N6)*(ZH(N1,N5)*ZCH(N1,N4)
     X                              +ZH(N3,N5)*ZCH(N3,N4))
      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(8,8),ZCH(8,8),ZD(8,8)
      COMMON/HWHEWR/CPFAC(12,12,8),CPALL(8)
      SAVE ZTWO
      DATA ZTWO/(2.0D0,0.0D0)/
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
      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 'HERWIG65.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(8,8),ZCH(8,8),ZD(8,8)
      COMMON/HWHEWR/CPFAC(12,12,8),CPALL(8)
      SAVE IDZOLT,MAP
      DATA ELST,ILST/0.D0,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)
          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)
          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
      END
CDECK  ID>, HWHGBP.
*CMZ :-        -02/04/01  12.11.55  by  Peter Richardson
*-- Author :    Peter Richardson
C-----------------------------------------------------------------------
      SUBROUTINE HWHGBP
C-----------------------------------------------------------------------
C     Hadron-Hadron to WW/WZ/ZZ (BASED ON ZOLTAN KUNSZT'S PROGRAM)
C-----------------------------------------------------------------------
      INCLUDE 'HERWIG65.INC'
      DOUBLE COMPLEX ZH,ZCH,ZD
      DOUBLE PRECISION HWUAEM,HWRGEN,HWUPCM,FLUXW,CSW,XMASS,
     &     PLAB,PRW,PCM,HWRUNI,P(5,10),AMPWW,DIST(4),MW2,CFAC1,AMP,
     &     MZ2,GMW,GMZ,G(4,2),EE(4),CKM2(12),RF(2),LF(2),TAUI(2),FPI4
      INTEGER IB,IBOS,I,IDP,IDBOS,IPRC,NEWHEP,J,ICMF,IHEP,IBRAD,K,IOPT,
     &     MAP(4),IDRES
      LOGICAL PHOTON,GEN
      EXTERNAL HWUAEM,HWRGEN,HWUPCM,HWRUNI
      COMMON/HWHEWQ/ZH(8,8),ZCH(8,8),ZD(8,8)
      COMMON/HWHGBC/ MW2,MZ2,GMW,GMZ,G,EE,CKM2,RF,LF,TAUI,CSW,CFAC1
      COMMON /HWBOSN/XMASS(2),PLAB(5,10),PRW(5,2),PCM(5,10),IDBOS(2),
     &     IDRES,IDP(10),IOPT
      SAVE AMPWW,IPRC,PHOTON
      PARAMETER(FPI4=24936.72731D0)
      DOUBLE PRECISION WI(IMAXCH)
      COMMON /HWPSOM/ WI
      SAVE MAP
      DATA MAP/1,2,11,12/
      IF (IERROR.NE.0) RETURN
      IF (GENEV) THEN
        IF (IPRC.EQ.0) THEN
          CALL HWHGB2(AMPWW,IDP,PHOTON)
        ELSEIF(IPRC.EQ.10) THEN
          CALL HWHGB3(AMPWW,IDP,PHOTON)
        ELSEIF(IPRC.EQ.20) THEN
          CALL HWHGB4(AMPWW,IDP,PHOTON)
          IF((IDP(1).LE.6.AND.MOD(IDP(1),2).EQ.1).OR.
     &       (IDP(2).LE.6.AND.MOD(IDP(2),2).EQ.1)) THEN
            IDBOS(1)=199
            IDP(3) = IDP(3)+6
            IDP(4) = IDP(4)-6
          ENDIF
        ENDIF
C--change the sign of the z component (in CMF) if particle first
        IF(IDP(1).LT.IDP(2)) THEN
          DO IB=1,2
            PRW(3,IB) = -PRW(3,IB)
            DO I=1,2
              PLAB(3,2*IB+I)=-PLAB(3,2*IB+I)
            ENDDO
          ENDDO
        ENDIF
C--boost particles back to the lab frame from the centre of mass frame
        DO IB=1,2
          CALL HWULOB(PLAB(1,7),PRW(1,IB),PRW(1,IB))
        ENDDO
        DO I=1,6
          CALL HWULOB(PLAB(1,7),PLAB(1,I),PLAB(1,I))
        ENDDO
C--put the particles in the event record
C--first the incoming quarks
        ICMF = NHEP+3
        DO I=1,2
          IHEP = NHEP+I
          CALL HWVEQU(5,PLAB(1,I),PHEP(1,IHEP))
          IDHW(IHEP) = IDP(I)
          IDHEP(IHEP)=IDPDG(IDP(I))
          ISTHEP(IHEP)=110+I
          JMOHEP(1,IHEP)=ICMF
          JMOHEP(I,ICMF)=IHEP
          JDAHEP(1,IHEP)=ICMF
        ENDDO
        JMOHEP(2,NHEP+1) = NHEP+2
        JMOHEP(2,NHEP+2) = NHEP+1
        JDAHEP(2,NHEP+1) = NHEP+2
        JDAHEP(2,NHEP+2) = NHEP+1
C--Centre-of-mass energy
        ICMF = NHEP+3
C--new for spin correlations
        IF(SYSPIN) THEN
          IDSPN(1) = ICMF
          ISNHEP(ICMF) = 1
          JMOSPN(1) = 0
          JDASPN(1,1) = 2
          JDASPN(2,1) = 5
          DECSPN(1) = .FALSE.
        ENDIF
        IDHW(ICMF)=15
        IDHEP(ICMF)=IDPDG(15)
        ISTHEP(ICMF)=110
        CALL HWVEQU(5,PLAB(1,7),PHEP(1,ICMF))
        CALL HWUMAS(PHEP(1,ICMF))
        JDAHEP(1,ICMF) = ICMF+1
        JDAHEP(2,ICMF) = ICMF+2
        NHEP   = NHEP+3
        NEWHEP = NHEP
        NHEP   = NHEP+2
C--Now the bosons
        DO IB=1,2
          IBOS=IB+NEWHEP
          CALL HWVEQU(5,PRW(1,IB),PHEP(1,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)=ICMF
          JMOHEP(2,IBOS)=ICMF
          JDAHEP(2,IBOS)=IBOS
          ISTHEP(IBOS)=112+IB
        ENDDO
C--now generate the initial state shower
        CALL HWBGEN
        IF(IERROR.NE.0) RETURN
C--now add the outgoing fermions to the event record
        DO 20 IB=1,2
        IBOS=IB+NEWHEP
        IBRAD = JDAHEP(1,IBOS)
        ISTHEP(IBRAD) = 195
        DO 10 I=1,2
          CALL HWVEQU(5,PLAB(1,2*IB+I),PHEP(1,NHEP+I))
          CALL HWVEQU(4,DIST,VHEP(1,NHEP+I))
C--Boost the fermion momenta to the rest frame of the original W
          CALL HWULOF(PRW(1,IB),PHEP(1,NHEP+I),PHEP(1,NHEP+I))
C--Now boost back to the lab from rest frame of the W after radiation
          CALL HWULOB(PHEP(1,IBRAD),PHEP(1,NHEP+I),PHEP(1,NHEP+I))
C--Set the status and pointers
          ISTHEP(NHEP+I)=112+I
          IDHW(NHEP+I)=IDP(2*IB+I)
          IDHEP(NHEP+I)=IDPDG(IDP(2*IB+I))
          JDAHEP(I,IBRAD)=NHEP+I
          JMOHEP(1,NHEP+I)=IBRAD
C--New for spin correlations
          IF(SYSPIN) THEN
            ISNHEP(NHEP+I)   = 2*IB+I-1
            IDSPN(2*IB+I-1)  = NHEP+I
            JMOSPN(2*IB+I-1) = 1
            DECSPN(2*IB+I-1) = .FALSE.
            RHOSPN(1,1,2*IB+I-1) = HALF
            RHOSPN(1,2,2*IB+I-1) = ZERO
            RHOSPN(2,1,2*IB+I-1) = ZERO
            RHOSPN(2,2,2*IB+I-1) = HALF
            NSPN = NSPN+1
          ENDIF
 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
        IF(FSTWGT) THEN
          IPRC=MOD(IPROC,100)
          IF(MOD(IPRC,5).EQ.0.AND.MOD(IPRC,10).NE.0) THEN
            PHOTON = .FALSE.
            IPRC = IPRC-5
          ELSE
            PHOTON = .TRUE.
          ENDIF
          IOPT=1
          IF (IPRC.EQ.0) THEN
C--WW production
            IDBOS(1)=199
            IDBOS(2)=198
            IDRES   =200
C--ZZ production
          ELSEIF (IPRC.EQ.10) THEN
            IDBOS(1)=200
            IDBOS(2)=200
            IDRES   =200
          ELSEIF(IPRC.EQ.20) THEN
C--WZ production
            IDBOS(1)=198
            IDBOS(2)=200
            IDRES   =198
            IOPT = 0
          ELSE
            CALL HWWARN('HWHGBP',500)
          ENDIF
C--calculate the couplings etc
          MW2 = RMASS(198)**2
          GMW = RMASS(198)*GAMW
          MZ2 = RMASS(200)**2
          GMZ = RMASS(200)*GAMZ
C--couplings to Z and photon
          DO I=1,4
            G(I,1) = VFCH(MAP(I),1)+AFCH(MAP(I),1)
            G(I,2) = VFCH(MAP(I),1)-AFCH(MAP(I),1)
            EE(I)  = QFCH(MAP(I))
          ENDDO
C--elements of the CKM matrix for the various decay modes of the W
          DO I=1,3
            DO J=1,3
C**Bug fix 2/7/01 by BRW (unsquare)
              CKM2(3*I-3+J) = VCKM(J,I)
C**End bug fix
            ENDDO
            CKM2(9+I) = ONE
          ENDDO
C--couplings of the up and down
          TAUI(1) = -ONE
          TAUI(2) =  ONE
          DO I=1,2
            RF(I)   = -TWO*QFCH(I)*SWEIN
            LF(I)   = TAUI(I)+RF(I)
          ENDDO
          CFAC1 = ONE/THREE
          CSW = SQRT((ONE-SWEIN)/SWEIN)
        ENDIF
        EVWGT=ZERO
C--find the momenta and the phase space weight
        CALL HWHGBS(FLUXW,GEN)
        IF(.NOT.GEN) RETURN
C--couplings
        AMP = FPI4*HWUAEM(EMSCA**2)**4
C--copy the momenta and change the sign of the beam
        DO I=1,6
          P(1,I)=PLAB(3,I)
          P(2,I)=PLAB(1,I)
          P(3,I)=PLAB(2,I)
          P(4,I)=PLAB(4,I)
        ENDDO
        DO 120 J=1,4
        DO 130 K=3,6
  130   PCM(J,K)=P(J,K)
        PCM(J,1)=-P(J,1)
        PCM(J,2)=-P(J,2)
  120   CONTINUE
C--use the e+e- code to calulate the spinor products
        CALL HWHEW2(6,PCM(1,1),ZH,ZCH,ZD)
C--calculate the matrix elements
       IF (IPRC.EQ.0) THEN
C--WW matrix element
         CALL HWHGB2(AMPWW,IDP,PHOTON)
       ELSEIF(IPRC.EQ.10) THEN
C--ZZ matrix element
         CALL HWHGB3(AMPWW,IDP,PHOTON)
       ELSEIF(IPRC.EQ.20) THEN
C--WZ matrix element
         CALL HWHGB4(AMPWW,IDP,PHOTON)
       ENDIF
C--Now calculate the cross section
       EVWGT = AMPWW*FLUXW*AMP
       IF(OPTM) THEN
         DO I=1,IMAXCH
           IF(CHON(I)) WI(I) = WI(I)*AMPWW**2*AMP**2
         ENDDO
       ENDIF
      ENDIF
      END
CDECK  ID>, HWHGBS.
*CMZ :-        -02/04/01  12.11.55  by  Peter Richardson
*-- Author :    Peter Richardson
C-----------------------------------------------------------------------
      SUBROUTINE HWHGBS(WEIGHT,GEN)
C-----------------------------------------------------------------------
C     Multichannel phase space for gauge boson pair production
C     ICH returns the channel used if OPTM=.FALSE.
C     ICH specifies the channel to be used if OPTM=.TRUE.
C     This is used in optimising the weights for the different channels
C-----------------------------------------------------------------------
      INCLUDE 'HERWIG65.INC'
      INTEGER ICH,IDBOS,ISM(2,IMAXCH),I,J,IB(2),IDRES,IDP,IOPT,IPRC,ID1
      DOUBLE PRECISION XMASS,PLAB,PRW,PCM,RAND,HWRGEN,BMS2(2),TJAC,PLM,
     &     MJAC(2),TWOPI2,SJAC,STOT,THAT,UHAT,TMIN,TMAX,UMIN,UMAX,PS(2),
     &     ETOT,HWUPCM,PST,HWRUNI,TAU,XJAC,PHI,SINTH,SIG(2),CV,CA,BR(2),
     &     G(IMAXCH),XF,DEM,TN,UN,SN,S1,S2,MB1,MB2,WEIGHT,BRFAC,BRZ(12)
      LOGICAL HWRLOG,GEN
      COMMON /HWBOSN/ XMASS(2),PLAB(5,10),PRW(5,2),PCM(5,10),IDBOS(2),
     &     IDRES,IDP(10),IOPT
      EXTERNAL HWRGEN,HWRLOG,HWUPCM,HWRUNI
      SAVE ISM,IPRC
      PARAMETER(TWOPI2=39.4784176D0)
      DOUBLE PRECISION WI(IMAXCH)
      COMMON /HWPSOM/ WI
      SAVE SIG,BRZ
      DATA SIG/1.0D0,-1.0D0/
      DATA BRZ/0.154D0,0.120D0,0.154D0,0.120D0,0.152D0,0.000D0,
     &         0.033D0,0.067D0,0.033D0,0.067D0,0.033D0,0.067D0/
      IF(IERROR.NE.0) RETURN
      WEIGHT = ZERO
      IF(OPTM) THEN
        DO I=1,IMAXCH
          WI(I) = ZERO
        ENDDO
      ENDIF
      GEN = .FALSE.
C--set the smoothing for the bosons in the various channels
      IF(FSTWGT) THEN
        IPRC = MOD(IPROC,100)
        DO I=1,2
          ISM(1,I) = 1
          DO J=1,2
            ISM(1,4*I-2+J  ) = 1
            ISM(1,4*I+J    ) = 2
            ISM(2,4*I+2*J-3) = 1
            ISM(2,4*I+2*J-2) = 2
          ENDDO
        ENDDO
        ISM(2,1) = 1
        ISM(2,2) = 2
      ENDIF
C--select the channel to be used
      RAND=HWRGEN(0)
      DO ICH=1,IMAXCH
        IF(CHON(ICH)) THEN
          IF(CHNPRB(ICH).GT.RAND) GOTO 10
          RAND = RAND-CHNPRB(ICH)
        ENDIF
      ENDDO
 10   CONTINUE
C--select the boson masses and compute that part of the denominator
C--decide which boson to do first
      IF(HWRLOG(HALF)) THEN
        IB(1) = 1
        IB(2) = 2
      ELSE
        IB(1) = 2
        IB(2) = 1
      ENDIF
C--find the boson masses
      CALL HWHGB1(ISM(IB(1),ICH),2,IDBOS(IB(1)),MJAC(IB(1)),BMS2(IB(1)),
     &     (PHEP(5,3)-EMMIN)**2,EMMIN**2)
      XMASS(IB(1)) = SQRT(BMS2(IB(1)))
      CALL HWHGB1(ISM(IB(2),ICH),2,IDBOS(IB(2)),MJAC(IB(2)),BMS2(IB(2)),
     &     (PHEP(5,3)-XMASS(IB(1)))**2,EMMIN**2)
      XMASS(IB(2)) = SQRT(BMS2(IB(2)))
      DO I=1,2
        MJAC(I) = HALF*MJAC(I)/TWOPI2
      ENDDO
C--now generate the values of s
C--according to a Breit-Wigner for the first two
      IF(ICH.LE.2) THEN
        CALL HWHGB1(1,2,IDRES,SJAC,STOT,PHEP(5,3)**2,
     &        (SQRT(BMS2(1)+PTMIN**2)+SQRT(BMS2(2)+PTMIN**2))**2)
C--according to a power law for the rest
      ELSE
        CALL HWHGB1(2,2,IDRES,SJAC,STOT,PHEP(5,3)**2,
     &        (SQRT(BMS2(1)+PTMIN**2)+SQRT(BMS2(2)+PTMIN**2))**2)
      ENDIF
      ETOT = SQRT(STOT)
C--find the centre of mass momenta
      PST = HWUPCM(ETOT,XMASS(1),XMASS(2))
      IF(PST.LT.PTMIN) RETURN
      PRW(4,1) = SQRT(BMS2(1)+PST**2)
      PRW(4,2) = SQRT(BMS2(2)+PST**2)
C--now generate the value of t and u
      PLM = SQRT(PST**2-PTMIN**2)
      TMIN   = BMS2(1)-ETOT*(PRW(4,1)+PLM)
      TMAX   = BMS2(1)-ETOT*(PRW(4,1)-PLM)
      UMIN   = BMS2(2)-ETOT*(PRW(4,2)+PLM)
      UMAX   = BMS2(2)-ETOT*(PRW(4,2)-PLM)
      SN     = ONE/(TMAX-TMIN)
C--for the first two channels uniform in t
      IF(ICH.LE.2) THEN
        THAT = HWRUNI(1,TMIN,TMAX)
        UHAT = BMS2(1)+BMS2(2)-STOT-THAT
        TJAC = TMAX-TMIN
C--for the next four channels generate t according to 1/t
      ELSEIF(ICH.LE.6) THEN
        CALL HWHGB5(2,TJAC,THAT,TMAX,TMIN)
        UHAT = BMS2(1)+BMS2(2)-STOT-THAT
C--for the last four channels generate u according to 1/u
      ELSEIF(ICH.LE.10) THEN
        CALL HWHGB5(2,TJAC,UHAT,UMAX,UMIN)
        THAT = BMS2(1)+BMS2(2)-STOT-UHAT
      ELSE
        CALL HWWARN('HWHGBS',500)
      ENDIF
      CALL HWHGB5(1,TN,THAT,TMAX,TMIN)
      CALL HWHGB5(1,UN,UHAT,UMAX,UMIN)
C--generate the parton momentum fractions and find the pdf's
      TAU = STOT/PHEP(5,3)**2
      XX(1) = EXP(HWRUNI(3,LOG(TAU),ZERO))
      XX(2) = TAU/XX(1)
      XJAC = -LOG(TAU)*XX(1)
      XF   = ONE/XJAC
      EMSCA=ETOT
      CALL HWSGEN(.FALSE.)
C--Centre of mass collison angle
      COSTH = (THAT-BMS2(1)+ETOT*PRW(4,1))/ETOT/PST
      PHI   = HWRUNI(4,ZERO,TWO*PIFAC)
      SINTH = SQRT(ONE-COSTH**2)
C--incoming momenta in the centre of mass frame
      DO I=1,2
        PLAB(1,I) = ZERO
        PLAB(2,I) = ZERO
        PLAB(3,I) = HALF*ETOT
        PLAB(4,I) = HALF*ETOT
        PLAB(5,I) = ZERO
      ENDDO
      PLAB(3,2) = -PLAB(3,2)
C--outgoing boson momenta in the centre of mass frame
      DO I=1,2
        PRW(1,I) = SIG(I)*SINTH*COS(PHI)*PST
        PRW(2,I) = SIG(I)*SINTH*SIN(PHI)*PST
        PRW(3,I) = SIG(I)*COSTH*PST
        PRW(5,I) = XMASS(I)
      ENDDO
C--now find the boson decay products
C--find the momenta of the boson decay products
      IF(IPRC.EQ.20) IDBOS(1)=198
      DO 90 I=1,2
        CALL HWDBZ2(IDBOS(I),IDP(2*I+1),IDP(2*I+2),CV,CA,BR(I),IOPT,
     &        XMASS(I))
        IF(BR(I).EQ.ZERO) RETURN
        PRW(5,I)=XMASS(I)
        PLAB(5,2*I+1) = ZERO
        PLAB(5,2*I+2) = ZERO
        PS(I) = HALF*XMASS(I)
        PLAB(5,2*I+1)=ZERO
        PLAB(5,2*I+2)=ZERO
        CALL HWDTWO(PRW(1,I),PLAB(1,2*I+1),PLAB(1,2*I+2),
     &              PS(I),TWO,.TRUE.)
 90   CONTINUE
      BRFAC = BR(2)
      IF(IOPT.EQ.0) BRFAC = BRFAC*BR(1)
      DO I=1,2
         IF(IDBOS(I).EQ.200) THEN
            ID1 = IDP(1+2*I)
            IF(ID1.GE.121) ID1 = ID1-114
            BRFAC = BRFAC/BRZ(ID1)
         ENDIF
      ENDDO
      DO I=1,2
        MJAC(I) = MJAC(I)*PS(I)/XMASS(I)
      ENDDO
C--set up a vector with the centre of mass
      PLAB(1,7) = ZERO
      PLAB(2,7) = ZERO
      PLAB(3,7) = HALF*PHEP(5,3)*(XX(1)-XX(2))
      PLAB(4,7) = HALF*PHEP(5,3)*(XX(1)+XX(2))
      PLAB(5,7) = ETOT
C--now find the denominator
      CALL HWHGB1(1,1,IDRES,S1,STOT,PHEP(5,3)**2,
     &     (XMASS(1)+XMASS(2))**2)
      CALL HWHGB1(2,1,IDRES,S2,STOT,PHEP(5,3)**2,
     &        (XMASS(1)+XMASS(2))**2)
      DEM = ZERO
      DO I=1,IMAXCH
        IF(CHON(I)) THEN
C--factors due to the choice of s and t
          IF(I.LE.2) THEN
            G(I) = SN*S1
          ELSEIF(I.LE.6) THEN
            G(I) = TN*S2
          ELSE
            G(I) = UN*S2
          ENDIF
C--factors due to the boson masses
          CALL HWHGB1(ISM(IB(1),I),1,IDBOS(IB(1)),MB1,BMS2(IB(1)),
     &         (PHEP(5,3)-EMMIN)**2,EMMIN**2)
          CALL HWHGB1(ISM(IB(2),I),1,IDBOS(IB(2)),MB2,BMS2(IB(2)),
     &         (PHEP(5,3)-XMASS(IB(1)))**2,EMMIN**2)
          G(I)   = G(I)*MB1*MB2*XF
          DEM = DEM+CHNPRB(I)*G(I)
        ENDIF
      ENDDO
C--now combine everything to get the weight
      WEIGHT = GEV2NB*TJAC*SJAC*G(ICH)/DEM/XX(1)*
     &     MJAC(1)*MJAC(2)*XJAC/64.0D0/PIFAC/STOT**3*BRFAC
      GEN = .TRUE.
C--compute the weights for the different channels if optimizing
      IF(OPTM) THEN
        DO I=1,IMAXCH
          IF(CHON(I)) WI(I)=G(I)*WEIGHT**2/DEM
        ENDDO
      ENDIF
      END
CDECK  ID>, HWHGB1.
*CMZ :-        -02/04/01  12.11.55  by  Peter Richardson
*-- Author :    Peter Richardson
C-----------------------------------------------------------------------
      SUBROUTINE HWHGB1(ISM,IOPT,IDBOZ,FJAC,MBOS2,MMAX,MMIN)
C-----------------------------------------------------------------------
C     Subroutine to select gauge boson mass for HWHGBP
C     ISM=1 select according to Breit-Wigner for IDBOZ
C     ISM=2 select according to power law  for IDBOZ
C     IOPT=1 return the function at MBOS2
C     IOPT=2 calculate MBOS2
C-----------------------------------------------------------------------
      INCLUDE 'HERWIG65.INC'
      INTEGER IDBOZ,ISM,IOPT
      DOUBLE PRECISION MBOZ,FJAC,GBOZ,GMBOZ,MPOW,MMIN,
     &     MBOS2,A1,A2,A01,A02,RPOW,QPOW,HWRGEN,MMAX,EMSQ
      EXTERNAL HWRGEN
C--set the boson mass
      IF(IDBOZ.EQ.198.OR.IDBOZ.EQ.199) THEN
        MBOZ = RMASS(198)
        GBOZ = GAMW
      ELSEIF(IDBOZ.EQ.200) THEN
        MBOZ = RMASS(200)
        GBOZ = GAMZ
      ELSE
        CALL HWWARN('HWHGB1',500)
      ENDIF
      EMSQ=MBOZ**2
      GMBOZ=MBOZ*GBOZ
C--smooth a Breit-Wigner only
      IF(ISM.EQ.1) THEN
        A02   = ATAN((MMIN-EMSQ)/GMBOZ)
        A2    = ATAN((MMAX-EMSQ)/GMBOZ)-A02
        IF(IOPT.EQ.1) THEN
          FJAC = GMBOZ/((MBOS2-EMSQ)**2+GMBOZ**2)/A2
        ELSE
          MBOS2 = EMSQ+GMBOZ*TAN(A02+A2*HWRGEN(1))
          FJAC  = A2*((MBOS2-EMSQ)**2+GMBOZ**2)/GMBOZ
        ENDIF
C--smooth a powerlaw only
      ELSEIF(ISM.EQ.2) THEN
        IF(EMPOW.EQ.TWO) THEN
          A01   = LOG(MMIN)
          A1    = LOG(MMAX)-A01
          IF(IOPT.EQ.1) THEN
            FJAC = ONE/MBOS2/A1
          ELSE
            MBOS2 = EXP(A01+A1*HWRGEN(2))
            FJAC  = A1*MBOS2
          ENDIF
        ELSE
          MPOW = -EMPOW/TWO
          QPOW =  ONE+MPOW
          RPOW =  ONE/QPOW
          A01  =  MMIN**QPOW
          A1   = (MMAX**QPOW-A01)
          IF(IOPT.EQ.1) THEN
            FJAC = QPOW*MBOS2**MPOW/A1
          ELSE
            MBOS2 = (A01+A1*HWRGEN(2))**RPOW
            FJAC  = A1*RPOW/MBOS2**MPOW
          ENDIF
        ENDIF
      ELSE
        CALL HWWARN('HWHGB1',501)
      ENDIF
      END
CDECK  ID>, HWHGB2.
*CMZ :-        -02/04/01  12.11.55  by  Peter Richardson
*-- Author :    Peter Richardson
C-----------------------------------------------------------------------
      SUBROUTINE HWHGB2(HCS,IDP,PHOTON)
C-----------------------------------------------------------------------
C     WW cross section in hadron hadron
C-----------------------------------------------------------------------
      INCLUDE 'HERWIG65.INC'
      DOUBLE PRECISION HCS,RCS,HWRGEN,DIST(2),CFAC,WAMP(2),S34,S56,KWW2,
     &     MW2,MZ2,GMW,GMZ,G(4,2),EE(4),CKM2(12),RF(2),LF(2),TAUI(2),
     &     CSW,CFAC1
      DOUBLE COMPLEX ZH,ZCH,ZD,Z1,Z2,ZHF,P12,Z12,S134,S156,AWW,BWW,
     &     CWW,DWW,AWWM(2),AWWP(2),HWHEW4
      INTEGER IDP(10),I,I1,I2,MAPZ(4,3),P1,P2,P3,P4
      PARAMETER(Z1=(0.0D0,1.0D0),Z2=(2.0D0,0.0D0),
     &          ZHF=(0.5D0,0.0D0))
      LOGICAL PHOTON
      EXTERNAL HWRGEN,HWHEW4
      COMMON/HWHEWQ/ZH(8,8),ZCH(8,8),ZD(8,8)
      COMMON /HWHGBC/ MW2,MZ2,GMW,GMZ,G,EE,CKM2,RF,LF,TAUI,CSW,CFAC1
      SAVE WAMP,AWWM,AWWP
      SAVE MAPZ
      DATA MAPZ/1,2,121,122,3,4,123,125,5,6,124,126/
      IF(GENEV) THEN
        RCS = HCS*HWRGEN(1)
      ELSE
C--Now calculate the matrix element
        Z12  = ONE/(Z2*ZD(1,2)-MZ2+Z1*GMZ)
        P12  = ZHF*(Z2*ZD(1,2)-MZ2)*Z12/ZD(1,2)
        S134 = ZHF*(Z2*ZD(1,2)-MZ2)*Z12/(ZD(1,3)+ZD(1,4)+ZD(3,4))
        S156 = ZHF*(Z2*ZD(1,2)-MZ2)*Z12/(ZD(1,5)+ZD(1,6)+ZD(5,6))
        S34  = DBLE(Z2*ZD(3,4))
        S56  = DBLE(Z2*ZD(5,6))
        KWW2 = ONE/((S34-MW2)**2+GMW**2)/((S56-MW2)**2+GMW**2)
     &            /SWEIN**4/16.0D0
        DO I=1,2
          DWW     = LF(I)*Z12-RF(I)*P12
          CWW     = RF(I)*(Z12-P12)
          AWW     = DWW + ZHF*S134*(TAUI(I)+ONE)
          BWW     = DWW + ZHF*S156*(TAUI(I)-ONE)
          AWWM(I) = AWW*HWHEW4(1,2,3,4,5,6)-BWW*HWHEW4(1,2,5,6,3,4)
          AWWP(I) = CWW*(HWHEW4(2,1,5,6,3,4)-HWHEW4(2,1,3,4,5,6))
          WAMP(I) = KWW2*DBLE( AWWM(I)*DCONJG(AWWM(I))
     &                        +AWWP(I)*DCONJG(AWWP(I)))
        ENDDO
      ENDIF
      HCS = ZERO
      CFAC = CFAC1*81.0D0
      DO I=1,2
        DO I1=1,3
          IDP(1) = MAPZ(I,I1)
          IDP(2) = IDP(1)+6
          DIST(1)=DISF(IDP(1),1)*DISF(IDP(2),2)
          DIST(2)=DISF(IDP(2),1)*DISF(IDP(1),2)
          DO I2=1,2
            HCS = HCS+DIST(I2)*CFAC*WAMP(I)
            IF(GENEV.AND.HCS.GT.RCS) THEN
C--new for spin correlations
              IF(SYSPIN) THEN
                NSPN = 1
                DO 10 P1=1,2
                DO 10 P2=1,2
                DO 10 P3=1,2
                DO 10 P4=1,2
 10             MESPN(P1,P2,P3,P4,1,1) = (0.0D0,0.0D0)
                MESPN(1,2,2,1,1,1) = AWWP(I)
                MESPN(2,2,2,1,1,1) = AWWM(I)
                NCFL(1) = 1
                SPNCFC(1,1,1) = ONE
              ENDIF
              GOTO 999
            ENDIF
            IDP(1) = IDP(1)+6
            IDP(2) = IDP(2)-6
          ENDDO
        ENDDO
      ENDDO
 999  RETURN
      END
CDECK  ID>, HWHGB3.
*CMZ :-        -02/04/01  12.11.55  by  Peter Richardson
*-- Author :    Peter Richardson
C-----------------------------------------------------------------------
      SUBROUTINE HWHGB3(HCS,IDP,PHOTON)
C-----------------------------------------------------------------------
C     ZZ cross section in hadron hadron
C-----------------------------------------------------------------------
      INCLUDE 'HERWIG65.INC'
      DOUBLE PRECISION AMP(2),RCS,HCS,HWRGEN,DIST(2),S34,S56,CFAC,
     &     MW2,MZ2,GMW,GMZ,G(4,2),EE(4),CKM2(12),RF(2),LF(2),TAUI(2),
     &     CSW,CFAC1
      DOUBLE COMPLEX ZH,ZCH,ZD,P34,P56,Z34,Z56,Z1,ZAMP(8),S134,S156,
     &        HWHEW4,TAMP,Z0,AMPT(2,2,2,2),CP
      INTEGER I,P1,P2,P3,IDP(10),I2,MAPZ(4,3),I1,ID(2),O(2)
      EXTERNAL HWHEW4,HWRGEN
      LOGICAL PHOTON
      COMMON/HWHEWQ/ZH(8,8),ZCH(8,8),ZD(8,8)
      COMMON /HWHGBC/ MW2,MZ2,GMW,GMZ,G,EE,CKM2,RF,LF,TAUI,CSW,CFAC1
      PARAMETER(Z0=(0.0D0,0.0D0),Z1=(0.0D0,1.0D0))
      SAVE AMP,ID,AMPT
      SAVE MAPZ,O
      DATA MAPZ/1,2,121,122,3,4,123,125,5,6,124,126/
      DATA O/2,1/
C--initialisation
      IF(GENEV) THEN
         RCS = HCS*HWRGEN(0)
      ELSE
C--Identitiys of the decay prodcucts (d=1,u=2,e=3,nu=4)
        DO I=1,2
          ID(I) = IDP(1+2*I)
          IF(ID(I).GE.121) ID(I) = ID(I)-114
          ID(I) = MOD(ID(I)+1,2)+2*INT((ID(I)-1)/6)+1
        ENDDO
C--the various propagators we need
        S34 = TWO*DBLE(ZD(3,4))
        S56 = TWO*DBLE(ZD(5,6))
        Z34 = ONE/(S34-MZ2+Z1*GMZ)
        Z56 = ONE/(S56-MZ2+Z1*GMZ)
        IF(PHOTON) THEN
          P34 = Z34*(S34-MZ2)/S34
          P56 = Z56*(S56-MZ2)/S56
        ELSE
          P34 = Z0
          P56 = Z0
        ENDIF
        S134 = HALF/(ZD(1,3)+ZD(1,4)+ZD(3,4))
        S156 = HALF/(ZD(1,5)+ZD(1,6)+ZD(5,6))
C--Now calculate the amplitudes
        ZAMP(1)=HWHEW4(1,2,3,4,5,6)*S134+HWHEW4(1,2,5,6,3,4)*S156
        ZAMP(2)=HWHEW4(1,2,4,3,5,6)*S134+HWHEW4(1,2,5,6,4,3)*S156
        ZAMP(3)=HWHEW4(1,2,3,4,6,5)*S134+HWHEW4(1,2,6,5,3,4)*S156
        ZAMP(4)=HWHEW4(1,2,4,3,6,5)*S134+HWHEW4(1,2,6,5,4,3)*S156
        ZAMP(5)=HWHEW4(2,1,3,4,5,6)*S156+HWHEW4(2,1,5,6,3,4)*S134
        ZAMP(6)=HWHEW4(2,1,4,3,5,6)*S156+HWHEW4(2,1,5,6,4,3)*S134
        ZAMP(7)=HWHEW4(2,1,3,4,6,5)*S156+HWHEW4(2,1,6,5,3,4)*S134
        ZAMP(8)=HWHEW4(2,1,4,3,6,5)*S156+HWHEW4(2,1,6,5,4,3)*S134
C--Now the amplitudes squared for the process
        DO I=1,2
          TAMP = Z0
          DO P1=1,2
            DO P2=1,2
              DO P3=1,2
                IF(PHOTON) THEN
                  CP = G(I,P1)**2*G(ID(1),P2)*G(ID(2),P3)*Z34*Z56
     &                +G(I,P1)*EE(I)*G(ID(1),P2)*EE(ID(2))*Z34*P56
     &                +G(I,P1)*EE(I)*EE(ID(1))*G(ID(2),P3)*P34*Z56
     &                +EE(I)**2*EE(ID(1))*EE(ID(2))*P34*P56
                ELSE
                  CP = G(I,P1)**2*G(ID(1),P2)*G(ID(2),P3)*Z34*Z56
                ENDIF
                AMPT(I,P1,P2,P3) = ZAMP(4*P1+2*P3+P2-6)*CP
                TAMP = TAMP+AMPT(I,P1,P2,P3)*DCONJG(AMPT(I,P1,P2,P3))
              ENDDO
            ENDDO
          ENDDO
          AMP(I) = HALF*DBLE(TAMP)
        ENDDO
      ENDIF
C--Now calculate the cross section
      HCS = 0.0D0
      CFAC = CFAC1
      IF(ID(1).LE.2) CFAC = CFAC*THREE
      IF(ID(2).LE.2) CFAC = CFAC*THREE
      DO I=1,2
        DO I1=1,3
          IDP(1) = MAPZ(I,I1)
          IDP(2) = MAPZ(I,I1)+6
          DIST(1)=DISF(IDP(1),1)*DISF(IDP(2),2)
          DIST(2)=DISF(IDP(2),1)*DISF(IDP(1),2)
          DO I2=1,2
            HCS = HCS+CFAC*DIST(I2)*AMP(I)
            IF(GENEV.AND.HCS.GT.RCS) THEN
C--New for spin correlations
              IF(SYSPIN) THEN
                NSPN = 1
                DO 10 P1=1,2
                DO 10 P2=1,2
                DO 10 P3=1,2
                MESPN(P1,P2,P3,1,1,1) = AMPT(I,O(P1),O(P2),O(P3))
 10             MESPN(P1,P2,P3,2,1,1) = (0.0D0,0.0D0)
                NCFL(1) = 1
                SPNCFC(1,1,1) = ONE
              ENDIF
              GOTO 999
            ENDIF
          ENDDO
          IDP(1) = IDP(1)+6
          IDP(2) = IDP(2)-6
        ENDDO
      ENDDO
 999  RETURN
      END
CDECK  ID>, HWHGB4.
*CMZ :-        -02/04/01  12.11.55  by  Peter Richardson
*-- Author :    Peter Richardson
C-----------------------------------------------------------------------
      SUBROUTINE HWHGB4(HCS,IDP,PHOTON)
C-----------------------------------------------------------------------
C     WZ cross section in hadron hadron
C-----------------------------------------------------------------------
      INCLUDE 'HERWIG65.INC'
      DOUBLE PRECISION AMP(2),HCS,RCS,HWRGEN,W34,DIST(2),S34,S56,CFAC,
     &     TCS,S12,MW2,MZ2,GMW,GMZ,G(4,2),EE(4),CKM2(12),RF(2),LF(2),
     &     TAUI(2),CSW,CFAC1
      DOUBLE COMPLEX ZH,ZCH,ZD,P56,Z56,Z1,Z0,S134,S156,HWHEW4,
     &     CP(4),W12,F(4),TAMP(2,2)
      INTEGER IDP(10),I,J,I1,I2,ID,P1,P2,P3,P4
      LOGICAL PHOTON
      EXTERNAL HWRGEN,HWHEW4
      COMMON/HWHEWQ/ZH(8,8),ZCH(8,8),ZD(8,8)
      COMMON /HWHGBC/ MW2,MZ2,GMW,GMZ,G,EE,CKM2,RF,LF,TAUI,CSW,CFAC1
      PARAMETER(Z0=(0.0D0,0.0D0),Z1=(0.0D0,1.0D0))
      SAVE AMP,ID,TAMP
      IF(GENEV) THEN
        RCS = HCS*HWRGEN(1)
      ELSE
C--identity of the Z decay product (d=1,u=2,e=3,nu=4)
        ID = IDP(5)
        IF(ID.GE.121) ID = ID-114
        ID = MOD(ID+1,2)+2*INT((ID-1)/6)+1
C--the various propagators we need
        S12 = TWO*DBLE(ZD(1,2))
        S34 = TWO*DBLE(ZD(3,4))
        S56 = TWO*DBLE(ZD(5,6))
        Z56 = ONE/(S56-MZ2+Z1*GMZ)
        IF(PHOTON) THEN
          P56 = Z56*(S56-MZ2)/S56
        ELSE
          P56 = Z0
        ENDIF
        W12 = ONE/(S12-MW2+Z1*GMW)
        S134 = HALF*W12*(S12-MW2)/(ZD(1,3)+ZD(1,4)+ZD(3,4))
        S156 = HALF*W12*(S12-MW2)/(ZD(1,5)+ZD(1,6)+ZD(5,6))
        W34  = ONE/((S34-MW2)**2+GMW**2)/SWEIN**2/FOUR
C--calculate the coefficents of the various amplitudes
        F(1)  = HWHEW4(1,2,3,4,5,6)
        F(2)  = HWHEW4(1,2,5,6,3,4)
        F(3)  = HWHEW4(1,2,3,4,6,5)
        F(4)  = HWHEW4(1,2,6,5,3,4)
        DO I=1,2
          IF(I.EQ.1) THEN
            J=2
          ELSE
            J=1
          ENDIF
          CP(1) = G(J,1)*S134-TAUI(I)*CSW*W12
          CP(2) = G(I,1)*S156+TAUI(I)*CSW*W12
          IF(PHOTON) THEN
            CP(3) = EE(J)*S134-TAUI(I)*W12
            CP(4) = EE(I)*S156+TAUI(I)*W12
          ELSE
            CP(3) = Z0
            CP(4) = Z0
          ENDIF
          TAMP(I,1)  = F(1)*(G(ID,1)*Z56*CP(1)+EE(ID)*P56*CP(3))
     &                +F(2)*(G(ID,1)*Z56*CP(2)+EE(ID)*P56*CP(4))
          TAMP(I,2)  = F(3)*(G(ID,2)*Z56*CP(1)+EE(ID)*P56*CP(3))
     &                +F(4)*(G(ID,2)*Z56*CP(2)+EE(ID)*P56*CP(4))
          AMP(I) = W34*DBLE( TAMP(I,1)*DCONJG(TAMP(I,1))
     &                      +TAMP(I,2)*DCONJG(TAMP(I,2)))
        ENDDO
      ENDIF
C--Now calculate the cross section
      HCS  = ZERO
      CFAC = CFAC1*9.0D0
      IF(ID.LE.2) CFAC = CFAC*THREE
      DO I=1,2
        DO I1=1,3
          IF(I.EQ.1) THEN
            IDP(1) = 2*I1+5
          ELSE
            IDP(1) = 2*I1+6
          ENDIF
          DO J=1,3
            IF(I.EQ.1) THEN
              IDP(2) = 2*J
C**Bug fix 2/7/01 by BRW (unsquare)
              TCS = VCKM(J,I1)
            ELSE
              IDP(2) = 2*J-1
              TCS = VCKM(I1,J)
C**End bug fix
            ENDIF
            DIST(1) = TCS*DISF(IDP(1),1)*DISF(IDP(2),2)
            DIST(2) = TCS*DISF(IDP(2),1)*DISF(IDP(1),2)
            DO I2=1,2
              HCS = HCS+CFAC*DIST(I2)*AMP(I)
              IF(GENEV.AND.HCS.GT.RCS) GOTO 900
            ENDDO
          ENDDO
        ENDDO
      ENDDO
 900  IF(GENEV.AND.I2.EQ.2) THEN
        I1 = IDP(1)
        IDP(1) = IDP(2)
        IDP(2) = I1
      ENDIF
      IF(SYSPIN.AND.GENEV) THEN
        NSPN = 1
        DO 10 P1=1,2
        DO 10 P2=1,2
        DO 10 P3=1,2
        DO 10 P4=1,2
 10     MESPN(P1,P2,P3,P4,1,1) = (0.0D0,0.0D0)
        MESPN(2 ,2 ,1 ,1 ,1,1) = TAMP(I,2)
        MESPN(2 ,2 ,2 ,1 ,1,1) = TAMP(I,1)
        NCFL(1) = 1
        SPNCFC(1,1,1) = ONE
      ENDIF
      END
CDECK  ID>, HWHGB5.
*CMZ :-        -02/04/01  12.11.55  by  Peter Richardson
*-- Author :    Peter Richardson
C-----------------------------------------------------------------------
      SUBROUTINE HWHGB5(IOPT,FJAC,T,TMAX,TMIN)
C-----------------------------------------------------------------------
C     Subroutine to select t or u for HWHGBP
C-----------------------------------------------------------------------
      INCLUDE 'HERWIG65.INC'
      INTEGER IOPT
      DOUBLE PRECISION FJAC,TPOW,TMIN,T,A1,A01,RPOW,QPOW,HWRGEN,TMAX,TN,
     &     TX,MT
      EXTERNAL HWRGEN
      TPOW = -1.0D0
      TX = -TMIN
      TN = -TMAX
      IF(TPOW.EQ.-ONE) THEN
         A1    = LOG(TX/TN)
        IF(IOPT.EQ.1) THEN
          FJAC =-ONE/T/A1
        ELSE
          T = -TN*EXP(A1*HWRGEN(2))
          FJAC  =-A1*T
        ENDIF
      ELSE
        QPOW = ONE+TPOW
        RPOW = ONE/QPOW
        A01   = TN**QPOW
        A1    = (TX**QPOW-A01)
        IF(IOPT.EQ.1) THEN
          MT = -T
          FJAC =QPOW*MT**TPOW/A1
        ELSE
          MT = (A01+A1*HWRGEN(2))**RPOW
          T = -MT
          FJAC  = A1*RPOW/MT**TPOW
        ENDIF
      ENDIF
      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 'HERWIG65.INC'
      DOUBLE PRECISION HWRGEN,HWRUNI,EPS,EMSQG,
     & EMGMG,S,CC,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)
      SAVE IADD
      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)
        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
       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) THEN
           CALL HWHQCP(ID3,ID4,2143,50)
           GOTO 99
         ENDIF
  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) THEN
           CALL HWHQCP(ID3,ID4,2134,50)
           GOTO 99
         ENDIF
  70    CONTINUE
C Bosonic final states
        IF (JPHO) THEN
         ID3=59
         ID4=59
         HCS=HCS+FACTR*M3
         IF (GENEV.AND.HCS.GT.RCS) THEN
           CALL HWHQCP(ID3,ID4,2134,50)
           GOTO 99
         ENDIF
        END IF
        IF (JW) THEN
         ID3=198
         ID4=199
         HCS=HCS+FACTR*M5(1)
         IF (GENEV.AND.HCS.GT.RCS) THEN
           CALL HWHQCP(ID3,ID4,2134,50)
           GOTO 99
         ENDIF
        END IF
        IF (JZ) THEN
         ID3=200
         ID4=200
         HCS=HCS+FACTR*M5(2)
         IF (GENEV.AND.HCS.GT.RCS) THEN
           CALL HWHQCP(ID3,ID4,2134,50)
           GOTO 99
         ENDIF
        END IF
        IF (JH) THEN
         ID3=201
         ID4=201
         HCS=HCS+FACTR*M5(3)
         IF (GENEV.AND.HCS.GT.RCS) THEN
           CALL HWHQCP(ID3,ID4,2134,50)
           GOTO 99
         ENDIF
        END IF
        IF (JGLU) THEN
         ID3=13
         ID4=13
         HCS=HCS+FACTR*M3*RNGLU
         IF (GENEV.AND.HCS.GT.RCS) THEN
           CALL HWHQCP(ID3,ID4,2143,50)
           GOTO 99
         ENDIF
        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) THEN
         CALL HWHQCP(ID3,ID4,2143,51)
         GOTO 99
       ENDIF
  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) THEN
         CALL HWHQCP(ID3,ID4,2134,51)
         GOTO 99
       ENDIF
  50  CONTINUE
C Vector boson final states
      IF (JPHO) THEN
       ID3=59
       ID4=59
       HCS=HCS+FACTR*M4
       IF (GENEV.AND.HCS.GT.RCS) THEN
         CALL HWHQCP(ID3,ID4,2134,51)
         GOTO 99
       ENDIF
      END IF
      IF (JW) THEN
       ID3=198
       ID4=199
       HCS=HCS+FACTR*M6(1)
       IF (GENEV.AND.HCS.GT.RCS) THEN
         CALL HWHQCP(ID3,ID4,2134,51)
         GOTO 99
       ENDIF
      END IF
      IF (JZ) THEN
       ID3=200
       ID4=200
       HCS=HCS+FACTR*M6(2)
       IF (GENEV.AND.HCS.GT.RCS) THEN
         CALL HWHQCP(ID3,ID4,2134,51)
         GOTO 99
       ENDIF
      END IF
      IF (JH) THEN
       ID3=201
       ID4=201
       HCS=HCS+FACTR*M6(3)
       IF (GENEV.AND.HCS.GT.RCS) THEN
         CALL HWHQCP(ID3,ID4,2134,51)
         GOTO 99
       ENDIF
      END IF
      IF (JGLU) THEN
       ID3=13
       ID4=13
       HCS=HCS+FACTR*M4*RNGLU
       IF (GENEV.AND.HCS.GT.RCS) THEN
         CALL HWHQCP(ID3,ID4,2143,51)
         GOTO 99
       ENDIF
      END IF
  30  CONTINUE
      EVWGT=HCS
      RETURN
C Generate event
  99  IDN(1)=ID1
      IDN(2)=ID2
      IDCMF=208
      CALL HWETWO(.TRUE.,.TRUE.)
      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>, HWHGUP.
*CMZ :-        -16/07/02  09.40.25  by  Peter Richardson
*-- Author :    Peter Richardson
C----------------------------------------------------------------------
      SUBROUTINE HWHGUP
C----------------------------------------------------------------------
C     Use the GUPI (Generic User Process Interface) event common block
C     as the hard process for HERWIG
C----------------------------------------------------------------------
      INCLUDE 'HERWIG65.INC'
C--Les Houches Common Block
      INTEGER MAXPUP
      PARAMETER(MAXPUP=100)
      INTEGER IDBMUP,PDFGUP,PDFSUP,IDWTUP,NPRUP,LPRUP
      DOUBLE PRECISION EBMUP,XSECUP,XERRUP,XMAXUP
      COMMON /HEPRUP/ IDBMUP(2),EBMUP(2),PDFGUP(2),PDFSUP(2),
     &                IDWTUP,NPRUP,XSECUP(MAXPUP),XERRUP(MAXPUP),
     &                XMAXUP(MAXPUP),LPRUP(MAXPUP)
      INTEGER MAXNUP
      PARAMETER (MAXNUP=500)
      INTEGER NUP,IDPRUP,IDUP,ISTUP,MOTHUP,ICOLUP
      DOUBLE PRECISION XWGTUP,SCALUP,AQEDUP,AQCDUP,PUP,VTIMUP,SPINUP
      COMMON/HEPEUP/NUP,IDPRUP,XWGTUP,SCALUP,AQEDUP,AQCDUP,
     &              IDUP(MAXNUP),ISTUP(MAXNUP),MOTHUP(2,MAXNUP),
     &              ICOLUP(2,MAXNUP),PUP(5,MAXNUP),VTIMUP(MAXNUP),
     &              SPINUP(MAXNUP)
C--Local variables
      COMMON /HWGUP/ILOC(NMXHEP),JLOC(MAXNUP)
      INTEGER ILOC,JLOC,JHEP,ID,IPHO,LTRY
      INTEGER IHEP,IDIN(2),I,IDRES(2,MAXPUP),IRES,ICMF,ISTART,JRES,J
      COMMON/PHOCOM/XEPHO
      DOUBLE PRECISION PTEMP(5),XEPHO
      CHARACTER *8 DUMMY
      LOGICAL HWRLOG
      EXTERNAL HWRLOG
      IRES = 0
C--zero the variables
      DO I=1,NUP
         JLOC(I) = 0
      ENDDO
      DO I=1,NMXHEP
         ILOC(I) = 0
      ENDDO
c---generate hard subprocess
C--now do the event selection bit
      IF(.NOT.GENEV) THEN
        IDPRUP = LPRUP(ITYPLH)
c        CALL UPEVNT
        IF(ABS(IDWTUP).EQ.1.OR.ABS(IDWTUP).EQ.2.OR.
     &     ABS(IDWTUP).EQ.4) THEN
          EVWGT = XWGTUP*1.0D-3
        ELSEIF(ABS(IDWTUP).EQ.3) THEN
          EVWGT = SIGN(ONE,XWGTUP)
        ELSE
          CALL HWWARN('HWHGUP',510)
        ENDIF
C--check the sign of the weight
        IF(IDWTUP.GT.ZERO.AND.EVWGT.LT.ZERO) CALL HWWARN('HWHGUP',520)
        RETURN
      ENDIF
C--update the number of events
      LHNEVT(ITYPLH) = LHNEVT(ITYPLH)+1
      ITYPLH = 0
C--first search to see if there are incoming beam particles in the record
      I = 0
      DO IHEP=1,NUP
        IF(ISTUP(IHEP).EQ.-9) THEN
          I=I+1
          IF(I.EQ.3) THEN
            CALL HWWARN('HWHGUP',102)
            GOTO 999
          ENDIF
          IDIN(I) = IHEP
        ENDIF
      ENDDO
C--put the beam particles in the record
C--require the soft event
      GENSOF = LHSOFT.AND.HWRLOG(PRSOF)
C--if given for event from event common block
      NHEP = 0
      IF(I.EQ.2) THEN
C--otherwise from the process common block
      ELSEIF(I.EQ.0) THEN
        DO I=1,2
          CALL HWUIDT(1,IDBMUP(I),IDHW(I),DUMMY)
          PHEP(1,I) = ZERO
          PHEP(2,I) = ZERO
          PHEP(4,I) = EBMUP(I)
          PHEP(5,I) = RMASS(IDHW(I))
          PHEP(3,I) = SQRT(EBMUP(I)**2-RMASS(IDHW(I))**2)
          ISTHEP(I) = 100+I
        ENDDO
        PHEP(3,2) = -PHEP(3,2)
        NHEP = NHEP+2
C--if not correct issue warning
      ELSE
        CALL HWWARN('HWHGUP',103)
        GOTO 999
      ENDIF
C--setup the centre-of-mass energy
      CALL HWVSUM(4,PHEP(1,NHEP-1),PHEP(1,NHEP),PHEP(1,NHEP+1))
      CALL HWUMAS(PHEP(1,NHEP+1))
      JMOHEP(1,NHEP+1) = NHEP-1
      JMOHEP(2,NHEP+1) = NHEP
      IDHW(3) = 14
      ISTHEP(3) = 103
      NHEP = NHEP+1
C--search for the incoming particles in collision
      I = 0
      DO IHEP=1,NUP
        IF(ISTUP(IHEP).EQ.-1) THEN
          I = I+1
          IF(I.EQ.3) THEN
            CALL HWWARN('HWHGUP',100)
            GOTO 999
          ENDIF
          IDIN(I) = IHEP
        ENDIF
      ENDDO
C--require two incoming particles
      IF(I.NE.2) THEN
        CALL HWWARN('HWHGUP',101)
        GOTO 999
      ENDIF
C--special for MC@NLO photoproduction
      IF (ABS(IDPRUP/100).EQ.51) THEN
         IF (IDUP(IDIN(1)).EQ.22) THEN
            IPHO=IDIN(1)
         ELSE
            IPHO=NUP+1
            CALL HWVZRO(5,PUP(1,IPHO))
            PUP(4,IPHO)=XEPHO
            PUP(3,IPHO)=PUP(4,IPHO)
         ENDIF
C--recompute cmf
         CALL HWVSUM(4,PHEP(1,2),PUP(1,IPHO),PHEP(1,NHEP))
            CALL HWUMAS(PHEP(1,NHEP))
            JMOHEP(1,NHEP)=NHEP+1
C--insert photon
         NHEP=NHEP+1
         CALL HWVEQU(5,PUP(1,IPHO),PHEP(1,NHEP))
         IDHEP(NHEP)=22
         CALL HWUIDT(1,IDHEP(NHEP),IDHW(NHEP),DUMMY)
         ISTHEP(NHEP)=3
         JMOHEP(1,NHEP)=1
         JDAHEP(1,1)=NHEP
C--insert outgoing beam particle
         NHEP=NHEP+1
         CALL HWVDIF(4,PHEP(1,1),PUP(1,IPHO),PHEP(1,NHEP))
         CALL HWUMAS(PHEP(1,NHEP))
         IDHEP(NHEP)=IDHEP(1)
         IDHW(NHEP)=IDHW(1)
         ISTHEP(NHEP)=1
         JMOHEP(1,NHEP)=1
         JDAHEP(2,1)=NHEP
      ENDIF
C--Now write incoming particles into the event record
      DO I=1,2
        IDHEP(NHEP+I) = IDUP(IDIN(I))
        ISTHEP(NHEP+I) = 110+I
        CALL HWUIDT(1,IDUP(IDIN(I)),IDHW(NHEP+I),DUMMY)
        CALL HWVEQU(5,PUP(1,IDIN(I)),PHEP(1,NHEP+I))
        JMOHEP(1,NHEP+I) = NHEP+3
        ILOC(NHEP+I) = IDIN(I)
        JLOC(I) = NHEP+I
C--special for particles which are identical to the beam
        DO J=1,2
          IF(IDHEP(NHEP+I).EQ.IDHEP(J)) THEN
            JDAHEP(1,J) = NHEP+I
            JDAHEP(2,J) = NHEP+I
          ENDIF
        ENDDO
      ENDDO
      CALL HWVSUM(4,PHEP(1,NHEP+1),PHEP(1,NHEP+2),PHEP(1,NHEP+3))
      CALL HWUMAS(PHEP(1,NHEP+3))
C--add the hard entry
      IDHW(NHEP+3) = 15
      IDHEP(NHEP+3)=0
      ISTHEP(NHEP+3) = 110
      JMOHEP(1,NHEP+3) = NHEP+1
      JMOHEP(2,NHEP+3) = NHEP+2
      JDAHEP(1,NHEP+3) = NHEP+4
      NHEP = NHEP+3
      ICMF = NHEP
C--now search for the outgoing particles and add them to the event record
      DO I=1,NUP
C--normal outgoing particles
        IF(ISTUP(I).EQ.1.AND.
     &        (MOTHUP(1,I).EQ.IDIN(1).OR.MOTHUP(1,I).EQ.IDIN(2))) THEN
          NHEP = NHEP+1
          IDHEP(NHEP) = IDUP(I)
          CALL HWUIDT(1,IDUP(I),IDHW(NHEP),DUMMY)
          CALL HWVEQU(5,PUP(1,I),PHEP(1,NHEP))
          JMOHEP(1,NHEP) = ICMF
          JMOHEP(2,NHEP) = 0
          JDAHEP(2,NHEP) = 0
          ILOC(NHEP) = I
          JLOC(I) = NHEP
C--resonances which must have mass preserved and resonances
C-- which don't have to have mass preserved
C--for the time being we won't disguish between these two options
        ELSEIF((ISTUP(I).EQ.2.OR.ISTUP(I).EQ.3).AND.
     &        (MOTHUP(1,I).EQ.IDIN(1).OR.MOTHUP(1,I).EQ.IDIN(2))) THEN
          NHEP = NHEP+1
          IDHEP(NHEP) = IDUP(I)
          CALL HWUIDT(1,IDUP(I),IDHW(NHEP),DUMMY)
          CALL HWVEQU(5,PUP(1,I),PHEP(1,NHEP))
          IRES = IRES+1
          IDRES(1,IRES) = NHEP
          IDRES(2,IRES) = I
          JMOHEP(1,NHEP) = ICMF
          JMOHEP(2,NHEP) = 0
          JDAHEP(2,NHEP) = 0
          ILOC(NHEP) = I
          JLOC(I) = NHEP
        ELSEIF(ISTUP(I).NE.-9.AND.ISTUP(I).NE.-1.AND.ISTUP(I).NE.1.AND.
     &         ISTUP(I).NE.2.AND.ISTUP(I).NE.3) THEN
          CALL HWWARN('HWHGUP',500)
        ENDIF
      ENDDO
C--Modified 2/7/03 for 2->1 processes
      IF(ICMF+1.EQ.NHEP) THEN
         NHEP = NHEP-1
         IDHEP(NHEP) = IDHEP(NHEP+1)
         IDHEP(NHEP+1) = 0
         IDHW(NHEP) = IDHW(NHEP+1)
         IDHW(NHEP+1) = 0
         CALL HWVEQU(5,PHEP(1,NHEP+1),PHEP(1,NHEP))
         JMOHEP(1,NHEP+1) = 0
         JMOHEP(2,NHEP+1) = 0
         JDAHEP(1,NHEP+1) = 0
         JDAHEP(2,NHEP+1) = 0
         JDAHEP(1,NHEP  ) = NHEP
         JDAHEP(2,NHEP  ) = NHEP
         ILOC(NHEP) = ILOC(NHEP+1)
         ILOC(NHEP+1) = 0
         JLOC(ILOC(NHEP)) = NHEP
         JLOC(NHEP+1) = 0
         DO I=1,IRES
            IF(IDRES(1,IRES).EQ.NHEP+1) IDRES(1,IRES) = NHEP
         ENDDO
      ELSE
         JDAHEP(2,ICMF) = NHEP
C--setup the status codes
         ISTHEP(ICMF+1) = 113
         DO IHEP=ICMF+2,NHEP
            ISTHEP(IHEP) = 114
         ENDDO
      ENDIF
C--End mod
      ISTART = ICMF-3
      EMSCA = SCALUP
C--generate parton shower
      CALL HWBGUP(ISTART,ICMF)
      IF (IERROR.NE.0) RETURN
C--now we need to sort out the resonances
      IF(IRES.EQ.0) RETURN
      JRES = 1
 35   ID = IDHEP(IDRES(1,JRES))
C--BRW fix to close ticket 51 caused problems: revert to Kluth solution
      LTRY=0
 36   IF(JDAHEP(1,IDRES(1,JRES)).NE.0.AND.
     &     JDAHEP(1,IDRES(1,JRES)).NE.IDRES(1,JRES)) THEN
        LTRY=LTRY+1
        IF (LTRY.GT.NSNTRY) THEN
           CALL HWWARN('HWHGUP',199)
           GOTO 999
        ENDIF
        IF(IDHEP(IDRES(1,JRES)).EQ.94) THEN
          DO IHEP=JDAHEP(1,IDRES(1,JRES)),JDAHEP(2,IDRES(1,JRES))
            IF(IDHEP(IHEP).EQ.ID) THEN
              IDRES(1,JRES) = IHEP
              GOTO 36
            ENDIF
          ENDDO
        ELSE
          IDRES(1,JRES) = JDAHEP(1,IDRES(1,JRES))
        ENDIF
        GOTO 36
      ENDIF
C--make a copy of this particle
      IHEP = IDRES(1,JRES)
      JMOHEP(1,NHEP+1) = JMOHEP(1,IDRES(1,JRES))
      JMOHEP(2,NHEP+1) = JMOHEP(2,IDRES(1,JRES))
      IDHEP(NHEP+1) = IDHEP(IDRES(1,JRES))
      IDHW(NHEP+1)  =  IDHW(IDRES(1,JRES))
      CALL HWVEQU(5,PHEP(1,IDRES(1,JRES)),PHEP(1,NHEP+1))
      IDRES(1,JRES) = NHEP+1
      JLOC(IDRES(2,JRES)) = IDRES(1,JRES)
      ISTHEP(NHEP+1) = 155
      NHEP = NHEP+1
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 Relabel original track
      IF (ISTHEP(IHEP).NE.120) ISTHEP(IHEP)=3
      JMOHEP(2,IHEP)=JMOHEP(1,IHEP)
      JDAHEP(1,IHEP)=NHEP
      JDAHEP(2,IHEP)=NHEP
C--look for all the particles which have this as a mother
C--now search for the outgoing particles and add them to the event record
      JDAHEP(1,NHEP) = NHEP+1
      ISTHEP(NHEP+1) = 113
      DO I=1,NUP
        IF(ISTUP(I).EQ.1.AND.MOTHUP(1,I).EQ.IDRES(2,JRES)) THEN
          NHEP = NHEP+1
          IDHEP(NHEP) = IDUP(I)
          CALL HWUIDT(1,IDUP(I),IDHW(NHEP),DUMMY)
          CALL HWULOF(PUP(1,IDRES(2,JRES)),PUP(1,I),PHEP(1,NHEP))
          CALL HWULOB(PHEP(1,IDRES(1,JRES)),PHEP(1,NHEP),PHEP(1,NHEP))
          JMOHEP(1,NHEP) = IDRES(1,JRES)
          JMOHEP(2,NHEP) = 0
          JDAHEP(2,NHEP) = 0
          ILOC(NHEP) = I
          JLOC(I) = NHEP
        ELSEIF((ISTUP(I).EQ.2.OR.ISTUP(I).EQ.3).AND.
     &          MOTHUP(1,I).EQ.IDRES(2,JRES)) THEN
          NHEP = NHEP+1
          IDHEP(NHEP) = IDUP(I)
          CALL HWUIDT(1,IDUP(I),IDHW(NHEP),DUMMY)
          CALL HWULOF(PUP(1,IDRES(2,JRES)),PUP(1,I),PHEP(1,NHEP))
          CALL HWULOB(PHEP(1,IDRES(1,JRES)),PHEP(1,NHEP),PHEP(1,NHEP))
          IRES = IRES+1
          IDRES(1,IRES) = NHEP
          IDRES(2,IRES) = I
          JMOHEP(1,NHEP) = IDRES(1,JRES)
          JMOHEP(2,NHEP) = 0
          JDAHEP(2,NHEP) = 0
          ILOC(NHEP) = I
          JLOC(I) = NHEP
        ENDIF
      ENDDO
C--special for top decays to ensure b is second and W is first, this seems
C--to cause problems if the order is the other way around
      IF(ABS(IDHEP(IDRES(1,JRES))).EQ.6.AND.
     &     NHEP-IDRES(1,JRES).EQ.2) THEN
C--BW fix 01/08/12 (allows for non-b decays)
C        IF(ABS(IDHEP(NHEP-1)).EQ.5) THEN
        IF(ABS(IDHEP(NHEP-1)).LE.5) THEN
C--end fix
C--swap momenta
           CALL HWVEQU(5,PHEP(1,NHEP),PTEMP)
           CALL HWVEQU(5,PHEP(1,NHEP-1),PHEP(1,NHEP))
           CALL HWVEQU(5,PTEMP,PHEP(1,NHEP-1))
C--swap id's
           J = IDHW(NHEP)
           IDHW(NHEP) = IDHW(NHEP-1)
           IDHW(NHEP-1) = J
           J = IDHEP(NHEP)
           IDHEP(NHEP) = IDHEP(NHEP-1)
           IDHEP(NHEP-1) = J
C--locations
           J = ILOC(NHEP)
           ILOC(NHEP) = ILOC(NHEP-1)
           ILOC(NHEP-1) = J
           JLOC(ILOC(NHEP-1)) = NHEP-1
           JLOC(ILOC(NHEP))   = NHEP
C--resonances
           DO I=1,IRES
              IF(IDRES(1,I).EQ.NHEP) IDRES(1,I) = NHEP-1
           ENDDO
        ENDIF
      ENDIF
      DO IHEP=IDRES(1,JRES)+2,NHEP
        ISTHEP(IHEP) = 114
      ENDDO
      JDAHEP(2,IDRES(1,JRES)) = NHEP
      ISTART = IDRES(1,JRES)
C--BRW mod 21/11/06 for pt-veto
      IF (.NOT.PTVETO) EMSCA = PHEP(4,IDRES(1,JRES))
      CALL HWBGUP(ISTART,0)
      IF (IERROR.NE.0) RETURN
      IF(JRES.NE.IRES) THEN
        JRES = JRES+1
        GOTO 35
      ENDIF
 999  RETURN
      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 'HERWIG65.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
C---BRW mod 30/01/07: save IQ1
      SAVE HCS,ASTU,AUST,CSTU,CSUT,CTSU,CTUS,S,T,TU,U,US,IQ1
      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) THEN
           CALL HWHQCP(ID1,ID2,3421, 3)
           GOTO 9
         ENDIF
       ELSEIF (ID2.NE.13) THEN
         HCS=HCS+ASTU*DIST
         IF (GENEV.AND.HCS.GT.RCS) THEN
           CALL HWHQCP(ID1,ID2,3142, 9)
           GOTO 9
         ENDIF
       ELSE
         HCS=HCS+CTSU*DIST
         IF (GENEV.AND.HCS.GT.RCS) THEN
           CALL HWHQCP(ID1,ID2,3142,10)
           GOTO 9
         ENDIF
         HCS=HCS+CTUS*DIST
         IF (GENEV.AND.HCS.GT.RCS) THEN
           CALL HWHQCP(ID1,ID2,3421,11)
           GOTO 9
         ENDIF
       ENDIF
      ELSEIF (ID1.NE.13) THEN
C---QBAR FIRST
       IF (ID2.LT.7) THEN
         HCS=HCS+ASTU*DIST
         IF (GENEV.AND.HCS.GT.RCS) THEN
           CALL HWHQCP(ID1,ID2,2413,17)
           GOTO 9
         ENDIF
       ELSEIF (ID2.NE.13) THEN
         HCS=HCS+ASTU*DIST
         IF (GENEV.AND.HCS.GT.RCS) THEN
           CALL HWHQCP(ID1,ID2,4312,20)
           GOTO 9
         ENDIF
       ELSE
         HCS=HCS+CTSU*DIST
         IF (GENEV.AND.HCS.GT.RCS) THEN
           CALL HWHQCP(ID1,ID2,2413,21)
           GOTO 9
         ENDIF
         HCS=HCS+CTUS*DIST
         IF (GENEV.AND.HCS.GT.RCS) THEN
           CALL HWHQCP(ID1,ID2,4312,22)
           GOTO 9
         ENDIF
       ENDIF
      ELSE
C---GLUON FIRST
       IF (ID2.LT.7) THEN
         HCS=HCS+CTSU*DIST
         IF (GENEV.AND.HCS.GT.RCS) THEN
           CALL HWHQCP(ID1,ID2,2413,23)
           GOTO 9
         ENDIF
         HCS=HCS+CTUS*DIST
         IF (GENEV.AND.HCS.GT.RCS) THEN
           CALL HWHQCP(ID1,ID2,3421,24)
           GOTO 9
         ENDIF
       ELSEIF (ID2.LT.13) THEN
         HCS=HCS+CTSU*DIST
         IF (GENEV.AND.HCS.GT.RCS) THEN
           CALL HWHQCP(ID1,ID2,3142,25)
           GOTO 9
         ENDIF
         HCS=HCS+CTUS*DIST
         IF (GENEV.AND.HCS.GT.RCS) THEN
           CALL HWHQCP(ID1,ID2,4312,26)
           GOTO 9
         ENDIF
       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) THEN
           CALL HWHQCP(IQ1,IQ2,2413, 4)
           GOTO 9
         ENDIF
      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) THEN
           CALL HWHQCP(IQ2,IQ1,3142,12)
           GOTO 9
         ENDIF
      ELSEIF (ID1.EQ.13.AND.ID2.EQ.13) THEN
C---GLUON FUSION
         HCS=HCS+CSTU*DIST
         IF (GENEV.AND.HCS.GT.RCS) THEN
           CALL HWHQCP(IQ1,IQ2,2413,27)
           GOTO 9
         ENDIF
         HCS=HCS+CSUT*DIST
         IF (GENEV.AND.HCS.GT.RCS) THEN
           CALL HWHQCP(IQ1,IQ2,4123,28)
           GOTO 9
         ENDIF
      ENDIF
    5 CONTINUE
    6 CONTINUE
      EVWGT=HCS
      RETURN
C---GENERATE EVENT
    9 IDN(1)=ID1
      IDN(2)=ID2
      IDCMF=15
      CALL HWETWO(.TRUE.,.TRUE.)
      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
      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 'HERWIG65.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.
        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.
c bug fix 20/05/01 SM.
        IF(IQ.EQ.6)FACTR=FACTR*VCKM(3,3)
c end of bug fix.
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) THEN
            CALL HWHQCP(5,IHIGGS+201,2314,1)
            GOTO 9
          ENDIF
        END DO
        HCS = HCS + DIST*ME2(4)
        IF (GENEV.AND.HCS.GT.RCS) THEN
          CALL HWHQCP(6,207,2314,1)
          GOTO 9
        ENDIF
      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) THEN
            CALL HWHQCP(11,IHIGGS+201,3124,1)
            GOTO 9
          ENDIF
        END DO
        HCS = HCS + DIST*ME2(4)
        IF (GENEV.AND.HCS.GT.RCS) THEN
          CALL HWHQCP(12,206,3124,1)
          GOTO 9
        ENDIF
      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) THEN
            CALL HWHQCP(IHIGGS+201,5,4132,1)
            GOTO 9
          ENDIF
        END DO
        HCS = HCS + DIST*ME2(4)
        IF (GENEV.AND.HCS.GT.RCS) THEN
          CALL HWHQCP(207,6,4132,1)
          GOTO 9
        ENDIF
      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) THEN
            CALL HWHQCP(IHIGGS+201,11,2431,1)
            GOTO 9
          ENDIF
        END DO
        HCS = HCS + DIST*ME2(4)
        IF (GENEV.AND.HCS.GT.RCS) THEN
          CALL HWHQCP(206,12,2431,1)
          GOTO 9
        ENDIF
      END IF
      EVWGT = HCS
      RETURN
C---GENERATE EVENT
    9 IDN(1)=ID1
      IDN(2)=ID2
      IDCMF=15
      CALL HWETWO(.TRUE.,.TRUE.)
      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>, 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 'HERWIG65.INC'
      INTEGER I,J,IHEL
      DOUBLE PRECISION EMH,EMHWT,RMW,EMW
      DOUBLE PRECISION 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
      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 (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.
        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-GAMMAX*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 mass
          VSAVE=RMASS(IDN(3))
          RMASS(IDN(3))=EMW
C-- BRW fix 27/8/04: avoid double smearing of V mass
          CALL HWETWO(.FALSE.,.TRUE.)
          RMASS(IDN(3))=VSAVE
          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
      END
CDECK  ID>, HWHIG1.
*CMZ :-        -23/08/94  13.22.29  by  Mike Seymour
*-- Author :    Ulrich Baur & Nigel Glover, adapted by Ian Knowles
*- Split in 3 files by M. Kirsanov
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,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 )
      END
CDECK  ID>, HWHIG2.
*CMZ :-        -23/08/94  13.22.29  by  Mike Seymour
*-- Author :    Ulrich Baur & Nigel Glover, adapted by Ian Knowles
C-----------------------------------------------------------------------
      FUNCTION HWHIG2(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 HWHIG2,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
      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)
      END
CDECK  ID>, HWHIG5.
*CMZ :-        -23/08/94  13.22.29  by  Mike Seymour
*-- Author :    Ulrich Baur & Nigel Glover, adapted by Ian Knowles
C-----------------------------------------------------------------------
      FUNCTION HWHIG5(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 HWHIG5,BI(4),CI(7),DI(3)
      DOUBLE PRECISION S,T,U,EH2,EQ2,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     Amplitude for: q+qbar --> g+H
C-----------------------------------------------------------------------
      HWHIG5=DCMPLX(TWO)+DCMPLX(TWO*S/(S-EH2))*BI(I)
     &      +DCMPLX(FOUR*EQ2-U-T)*CI(K)
      END
CDECK  ID>, HWHIBQ.
*CMZ :-        -30/06/01  18.40.33  by  Stefano Moretti
*-- 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 process IPROC=3500, 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: 12-APR-2000 by Stefano Moretti
C
C-----------------------------------------------------------------------
      SUBROUTINE HWHIBQ
C-----------------------------------------------------------------------
C     PRODUCTION OF MSSM CHARGED HIGGSES FROM B-QUARK+LIGHT-QUARK FUSION
C-----------------------------------------------------------------------
      INCLUDE 'HERWIG65.INC'
      INTEGER I,J,K,L,M,N
      INTEGER II,JJ,ITMP
      INTEGER IFL,IRES
      DOUBLE PRECISION EMQ,ENQ,EMQH,EMB,EMH,EMHWT,EMT,EMW
      DOUBLE PRECISION EMH01,EMH02,EMH03
      DOUBLE PRECISION WCKM,CKM,GAMT
      DOUBLE PRECISION X(6),XL(6),XU(6)
      DOUBLE PRECISION Q3(0:3),Q35(0:3)
      DOUBLE PRECISION Q1(5),Q2(5),H(5)
      DOUBLE PRECISION CT4,ST4,CT3,ST3,CF3,SF3,RQ42,RQ4,RQ32,RQ3,PQ3
      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 XTMP
      DOUBLE PRECISION EMIN1,EMIN2,PCM2,PCM
      DOUBLE PRECISION M2B,M2BBAR
      DOUBLE PRECISION ALPHA,EMSC2
      DOUBLE PRECISION HWRGEN,HWUAEM
      DOUBLE PRECISION PHI,CPHI,SPHI,ROT(3,3)
      DOUBLE PRECISION QAUX(0:3)
      DOUBLE PRECISION EPS,HCS,RCS,FACT,DIST
      DOUBLE PRECISION WEIGHT
      SAVE HCS,M2B,M2BBAR,FACT,S,WCKM,P3,P4,P5
      LOGICAL HWRLOG
      EXTERNAL HWRGEN,HWUAEM,HWH2BH,HWEONE,HWRLOG,
     &         HWUMAS,HWULOB
      EQUIVALENCE (EMB,RMASS(5)),(EMT,RMASS(6))
      EQUIVALENCE (EMW,RMASS(198))
      EQUIVALENCE (EMH01,RMASS(204)),
     &            (EMH02,RMASS(203)),
     &            (EMH03,RMASS(205))
      EQUIVALENCE (CKM,VCKM(3,3))
      PARAMETER (EPS=1.D-9)
      IF(GENEV)THEN
        RCS=HCS*HWRGEN(0)
      ELSE
        HCS=0.
        EVWGT=0.
C...assign final state masses.
        EMQ=0.
        ENQ=0
        EMH=RMASS(206)
        EMHWT=1.
C...assign top width.
        GAMT=HBAR/RLTIM(6)
C...energy at hadron level.
        ECM_MAX=PBEAM1+PBEAM2
        S=ECM_MAX*ECM_MAX
C...phase space variables.
C...X(1)=(EMQH-EMQ-EMH)/(ECM-EMQ-ENQ-EMH),
C...X(2)=1/[-(P2-P3)^2+MW^2],X(3)=COS(THETA4_CM_35),X(4)=FI4_CM_35,
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.
c...for XL(2),XU(2) see below (non constant).
        XL(3)=-1.
        XU(3)=1.
        XL(4)=0.
        XU(4)=2.*PIFAC
        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
          IF(I.EQ.2)GOTO 125
          X(I)=XL(I)+(XU(I)-XL(I))*HWRGEN(0)
          WEIGHT=WEIGHT*ABS(XU(I)-XL(I))
 125      CONTINUE
        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...incoming partons massless.
        EMIN1=0.
        EMIN2=0.
C...initial state momenta in the partonic CM.
        PCM2=((SHAT-EMIN1*EMIN1-EMIN2*EMIN2)**2
     &         -(2.*EMIN1*EMIN2)**2)/(4.*SHAT)
        PCM=SQRT(PCM2)
C...three particle kinematics.
        EMQH=X(1)*(ECM-EMQ-ENQ-EMH)+EMQ+EMH
        RQ42=((ECM*ECM-ENQ*ENQ-EMQH*EMQH)**2-(2.*ENQ*EMQH)**2)/
     &       (4.*ECM*ECM)
        IF(RQ42.LT.0.)THEN
          GOTO 100
        ELSE
          RQ4=SQRT(RQ42)
        ENDIF
C...X(2): integrate over W propagator.
        XL(2)=1./(4.*SQRT(PCM2+EMIN2*EMIN2)*RQ4+EMW*EMW)
        XU(2)=1./(EMW*EMW)
        X(2)=XL(2)+(XU(2)-XL(2))*HWRGEN(0)
        WEIGHT=WEIGHT*ABS(XU(2)-XL(2))
        XTMP=1./X(2)
        XTMP=(XTMP-EMW*EMW)/2./SQRT(PCM2+EMIN2*EMIN2)
        CT4=1.-XTMP/((SHAT-EMQH*EMQH+2.*ENQ*ENQ)/(2.*ECM))
        IF(CT4.GT.+1.)CT4=+1.
        IF(CT4.LT.-1.)CT4=-1.
        IF(HWRLOG(HALF))THEN
          ST4=+SQRT(1.-CT4*CT4)
        ELSE
          ST4=-SQRT(1.-CT4*CT4)
        END IF
        CT3=X(3)
        ST3=SQRT(1.-CT3*CT3)
        CF3=COS(X(4))
        SF3=SIN(X(4))
        P4(1)=0.
        P4(2)=-RQ4*ST4
        P4(3)=-RQ4*CT4
        P4(0)=SQRT(RQ42+ENQ*ENQ)
        DO I=1,3
          Q35(I)=-P4(I)
        END DO
        Q35(0)=SQRT(RQ42+EMQH*EMQH)
        RQ32=((EMQH*EMQH-EMH*EMH-EMQ*EMQ)**2-(2.*EMH*EMQ)**2)/
     &      (4.*EMQH*EMQH)
        IF(RQ32.LT.0.)THEN
          GOTO 100
        ELSE
          RQ3=SQRT(RQ32)
        ENDIF
        Q3(1)=RQ3*ST3*CF3
        Q3(2)=RQ3*ST3*SF3
        Q3(3)=RQ3*CT3
        Q3(0)=SQRT(RQ32+EMQ*EMQ)
        PQ3=0.
        DO I=1,3
          PQ3=PQ3+Q35(I)*Q3(I)
        END DO
        P3(0)=(Q35(0)*Q3(0)+PQ3)/EMQH
        P5(0)=Q35(0)-P3(0)
        DO I=1,3
          P3(I)=Q3(I)+Q35(I)*(P3(0)+Q3(0))/(Q35(0)+EMQH)
          P5(I)=Q35(I)-P3(I)
        END DO
C...initial state.
        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...option: top diagram removed if can be resonant to avoid double counting.
        IRES=1
C        IF((EMT-EMB-EMH).GE.0.)IRES=0
C...color structured ME summed/averaged over final/initial spins and colors.
C...IFL=+1 selects b.
        IFL=+1
        CALL HWH2BH(P1,P2,P3,P4,P5,EMW,EMH,EMH01,EMH02,EMH03,EMB,EMT,
     &              IFL,IRES,CKM,GAMT,M2B)
C...IFL=-1 selects b-bar.
        IFL=-1
        CALL HWH2BH(P1,P2,P3,P4,P5,EMW,EMH,EMH01,EMH02,EMH03,EMB,EMT,
     &              IFL,IRES,CKM,GAMT,M2BBAR)
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*RQ3*RQ4/PCM/32./(2.*PIFAC)**5
     &      *(ECM-EMQ-ENQ-EMH)
        FACT=FACT/2./P2(0)/P4(0)
        FACT=FACT*(2.*P2(0)*P4(0)*(1.-CT4)+EMW*EMW)**2
C...EW couplings.
        EMSCA=EMQ+ENQ+EMH
        EMSC2=EMSCA*EMSCA
        ALPHA=HWUAEM(EMSC2)
        FACT=FACT*64.*PIFAC**3*ALPHA**3/4./SWEIN/SWEIN/SWEIN/EMW/EMW
C...Higgs resonance.
        FACT=FACT*EMHWT
C...constant weight.
        FACT=FACT*WEIGHT
      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
        DO J=1,12
          IF(DISF(J,2).LT.EPS)THEN
            GOTO 175
          END IF
          IF((I.NE.5).AND.(I.NE.11).AND.
     &       (J.NE.5).AND.(J.NE.11))THEN
            GOTO 150
          END IF
          II=J
          IF((I.NE.5).AND.(I.NE.11))II=I
          IF(II.GT.6)II=II-6
          ITMP=II
          II=(II+1)/2
          DIST=0.
          DO JJ=1,3
            WCKM=VCKM(II,JJ)
            IF((ITMP.EQ.5).AND.(II.EQ.3).AND.(JJ.EQ.3))WCKM=0.
            DIST=DIST+DISF(I,1)*DISF(J,2)*WCKM*S
          END DO
          IF((I.LE.6).AND.(J.LE.6))THEN
            HCS=HCS+M2B*DIST*FACT
          ELSE IF((I.LE.6).AND.(J.GE.7))THEN
            IF(J.NE.11)HCS=HCS+M2B*DIST*FACT
            IF(J.EQ.11)HCS=HCS+M2BBAR*DIST*FACT
          ELSE IF((I.GE.7).AND.(J.LE.6))THEN
            IF(I.NE.11)HCS=HCS+M2B*DIST*FACT
            IF(I.EQ.11)HCS=HCS+M2BBAR*DIST*FACT
          ELSE IF((I.GE.7).AND.(J.GE.7))THEN
            HCS=HCS+M2BBAR*DIST*FACT
          END IF
          IF(GENEV.AND.HCS.GT.RCS)THEN
C...generate event.
            IDN(1)=I
            IDN(2)=J
            IF((I.EQ.5).OR.(I.EQ.11))THEN
              K=I
              L=J+(-1)**(J+1)
              IDN(3)=K
              IDN(4)=L
            ELSE
              L=I+(-1)**(J+1)
              K=J
              IDN(3)=L
              IDN(4)=K
            END IF
            IF(IDN(2).EQ.IDN(4))THEN
              IDN(5)=
     &        NINT(198.5-.1667*FLOAT(ICHRG(IDN(1))-ICHRG(IDN(3))))
          ELSE
              IDN(5)=
     &        NINT(198.5-.1667*FLOAT(ICHRG(IDN(2))-ICHRG(IDN(4))))
            END IF
            IDN(5)=IDN(5)+8
C...sets up incoming status and IDs only for 2->1: use HWEONE.
            IDCMF=15
            CALL HWEONE
            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...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...outgoing momenta (give quark masses non covariantly!)
            DO M=1,3
              Q1(M)=P3(M)
              Q2(M)=P4(M)
              H( M)=P5(M)
            END DO
            Q1(4)=P3(0)
            Q2(4)=P4(0)
            H( 4)=P5(0)
            Q1(5)=RMASS(IDN(3))
            Q1(4)=SQRT(Q1(4)**2+Q1(5)**2)
            Q2(5)=RMASS(IDN(4))
            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...sets up outgoing 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)=IDN(5)
            IDHEP(NHEP+3)=IDPDG(IDN(5))
C...sets up colour connections.
            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
            IF(AZSPIN)THEN
C...set to zero the coefficients of the spin density matrices.
              CALL HWVZRO(7,GCOEF)
            END IF
            RETURN
          END IF
 150      CONTINUE
 175      CONTINUE
        END DO
 200    CONTINUE
      END DO
      EVWGT=HCS
      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 'HERWIG65.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.)**2*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)
      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))/EMW2
     &    *(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
      END
CDECK  ID>, HWHIGB.
*CMZ :-        -23/08/94  13.22.29  by  Mike Seymour
*-- Author :    Ulrich Baur & Nigel Glover, adapted by Ian Knowles
*- split in 3 files by M. Kirsanov
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 'HERWIG65.INC'
      DOUBLE COMPLEX HWHIGB,HWUCI2,HWULI2,EPSI,PII
      DOUBLE PRECISION S,T,EQ2,EH2,RAT
      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
      END
CDECK  ID>, HWHIGC.
*CMZ :-        -23/08/94  13.22.29  by  Mike Seymour
*-- Author :    Ulrich Baur & Nigel Glover, adapted by Ian Knowles
C-----------------------------------------------------------------------
      FUNCTION HWHIGC(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 'HERWIG65.INC'
      DOUBLE COMPLEX HWHIGC,HWUCI2,HWULI2,EPSI,PII
      DOUBLE PRECISION S,T,EQ2,EH2,RAT,COSH
      LOGICAL NOMASS
      EXTERNAL HWULI2,HWUCI2
      COMMON/SMALL/EPSI
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
      END
CDECK  ID>, HWHIGD.
*CMZ :-        -23/08/94  13.22.29  by  Mike Seymour
*-- Author :    Ulrich Baur & Nigel Glover, adapted by Ian Knowles
C-----------------------------------------------------------------------
      FUNCTION HWHIGD(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 'HERWIG65.INC'
      DOUBLE COMPLEX HWHIGD,HWUCI2,HWULI2,EPSI,PII,Z1,Z2
      DOUBLE PRECISION S,T,EQ2,EH2,DLS,DLT,DLM,RZ12,DL1,DL2,
     & ST,ROOT,XP,XM
      LOGICAL NOMASS
      EXTERNAL HWULI2,HWUCI2
      COMMON/SMALL/EPSI
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/DREAL(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
      END
CDECK  ID>, HWHIGE.
*CMZ :-        -13/10/02  09.43.05  by  Peter Richardson
*-- Author :    Kosuke Odagiri and 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 from IPROC=1000-1099 (SM),
C...IPROC=1111-1139 (MSSM), as described in the HERWIG 6 documentation file.
C...(For IPROC=1140-1145 it describes MSSM charged Higgs production.)
C
C...First release: 18-SEP-2002 by Stefano Moretti
C
      SUBROUTINE HWHIGE
C--------------------------------------------------------------------------
C     LEPTOPRODUCTION OF MS(SM) HIGGSES IN ASSOCIATION WITH HEAVY QUARK PAIRS
C--------------------------------------------------------------------------
      INCLUDE 'HERWIG65.INC'
      INTEGER JHIGGS
      INTEGER I,L,M,N,NN
      INTEGER IH,IQ,JQ,IIQ,JJQ
      INTEGER IAD
      INTEGER IDEC,FLIP
      INTEGER ID1,ID2
      DOUBLE PRECISION CV,CA,BR
      DOUBLE PRECISION BRHIGQ,EMQ,ENQ,GMQ,EMQQ,EMH,GMH,EMHWT
      DOUBLE PRECISION T,TL,TLMIN,TLMAX,TTMIN,TTMAX,CTMP,RCM,RCM2
      DOUBLE PRECISION X(4),XL(4),XU(4)
      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 F(0:3),G(0:3)
      DOUBLE PRECISION ECM,SHAT,S
      DOUBLE PRECISION EMIN,EMIN1,EMIN2,PCM2,PCM
      DOUBLE PRECISION HFC,HBC
      DOUBLE PRECISION M2EE
      DOUBLE PRECISION ALPHA,EMSC2
      DOUBLE PRECISION HWRGEN,HWUAEM
      DOUBLE PRECISION PHI,CPHI,SPHI,ROT(3,3)
      DOUBLE PRECISION QAUX(0:3)
      DOUBLE PRECISION EPS,HCS,RCS,FACT
      DOUBLE PRECISION WEIGHT
      INTEGER IFL,KHIGGS,JH,JFL
      LOGICAL FIRST,GAUGE
      DOUBLE PRECISION E,Q3,YM3,GAM3,YM4,GAM4,GAM5,COLOUR
      DOUBLE PRECISION RM3,RM4,RM5
      DOUBLE PRECISION S2W,RMW,RMZ
      DOUBLE PRECISION RMHL,GAMHL
      DOUBLE PRECISION RMHH,GAMHH
      DOUBLE PRECISION RMHA,GAMHA
      EQUIVALENCE (RMHL,RMASS(203)),(RMHH,RMASS(204)),(RMHA,RMASS(205))
      LOGICAL HWRLOG
      EXTERNAL HWHIGM,HWRGEN,HWUAEM,HWH2HE,HWEONE,HWRLOG
      PARAMETER (EPS=1.D-9)
      SAVE HCS,M2EE,FACT,S,SHAT,P3,P4,P5
      SAVE IIQ,JJQ,JHIGGS
C...ASSIGN Q/Q'-FLAVOUR.
      IF(IPROC.GE.1140)THEN
        IH=4
        IF(IPROC.EQ.1140)IQ=2
        IF(IPROC.EQ.1141)IQ=4
        IF(IPROC.EQ.1142)IQ=6
        IF(IPROC.EQ.1143)IQ=7
        IF(IPROC.EQ.1144)IQ=8
        IF(IPROC.EQ.1145)IQ=9
        IAD=7
        JQ=IQ+5
        GMQ=ZERO
        IF(JQ.EQ.11)GMQ=HBAR/RLTIM(6)
      ELSE
        IF(IMSSM.EQ.0)THEN
          IH=0
          IQ=6
        ELSE
          IF(IPROC.LT.1140)IH=3
          IF(IPROC.LT.1130)IH=2
          IF(IPROC.LT.1120)IH=1
          IQ=IPROC-1100-10*IH
        END IF
        IAD=6
        JQ=IQ+6
        GMQ=ZERO
      END IF
C...PROCESS EVENT.
      IF(GENEV)THEN
        RCS=HCS*HWRGEN(0)
      ELSE
        EVWGT=0.
        HCS=0.
C...ASSIGN FINAL STATE MASSES.
        IF(IQ.LE.6)THEN
          EMQ=RMASS(IQ)
          ENQ=RMASS(JQ)
        ELSE
          EMQ=RMASS(2*IQ-7+114+IAD)
          ENQ=RMASS(2*IQ-7+114    )
        END IF
        EMH=RMASS(201+IHIGGS)
        GMH=HBAR/RLTIM(201+IHIGGS)
        EMHWT=1.
C...ENERGY AT PARTON LEVEL.
        ECM=PBEAM1+PBEAM2
        S=ECM*ECM
        SHAT=S
        IF((EMH.LE.0.).OR.(EMH.GE.ECM))RETURN
C...PHASE SPACE VARIABLES.
C...X(1)=(EMQQ**2-(EMQ+ENQ)**2)/((ECM-EMH)**2-(EMQ+ENQ)**2),
C...LIGHT QUARKS -> X(2)=(LOG|T|-LOG|TMIN|)/(LOG|TMAX|-LOG|TMIN|),
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...PHASE SPACE BORDERS.
        XL(1)=0.
        XU(1)=1.
        IF((IQ+JQ).EQ.18)THEN
          XL(2)=-1.
          XL(4)=0.
          XU(4)=2.*PIFAC
        ELSE
          XL(2)=0.
          XL(4)=-1.
          XU(4)=1.
        END IF
        XU(2)=1.
        XL(3)=-1.
        XU(3)=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...THREE PARTICLE KINEMATICS.
        EMQQ=SQRT(X(1)*((ECM-EMH)**2-(EMQ+ENQ)**2)+(EMQ+ENQ)**2)
C...INCOMING PARTONS: ALL MASSLESS.
        EMIN=0.
        IF((IQ+JQ).EQ.18)THEN
          CT5=X(2)
          CT4=X(3)
          ST4=SQRT(1.-CT4*CT4)
          CF4=COS(X(4))
          SF4=SIN(X(4))
        ELSE
          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=LOG(ABS(TTMAX))
          TLMAX=LOG(ABS(TTMIN))
          TL=X(2)*(TLMAX-TLMIN)+TLMIN
          T=EXP(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)
        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
        IF(IMSSM.NE.0)THEN
          IF(IPROC.GE.1140)THEN
            IF(SQRT(P4(1)**2+P4(2)**2).LT.PTMIN)RETURN
          ELSE
            IF((IQ.NE.6).AND.(IQ.NE.12).AND.
     &         (JQ.NE.6).AND.(JQ.NE.12))THEN
              IF(SQRT(P3(1)**2+P3(2)**2).LT.PTMIN)RETURN
              IF(SQRT(P4(1)**2+P4(2)**2).LT.PTMIN)RETURN
            ELSE
              CONTINUE
            END IF
          END IF
        END IF
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.
C...EW AND QCD COUPLINGS.
        EMSCA=EMQ+ENQ+EMH
        EMSC2=EMSCA*EMSCA
        ALPHA=HWUAEM(EMSC2)
        FIRST=.TRUE.
        GAUGE=.FALSE.
        E=SQRT(4.D0*PIFAC*ALPHA)
        IF(IPROC.GE.1140)THEN
          IFL=IQ-1
          IF(IQ.EQ.7)IFL=IQ
          IF(IQ.EQ.8)IFL=IQ+1
          IF(IQ.EQ.9)IFL=IQ+2
          RM3=ENQ
          YM3=ENQ
          GAM3=0.D0
          RM4=EMQ
          YM4=EMQ
          GAM4=GMQ
C...CHARGED HIGGSES
          Q3=-1.D0
          IF(IFL.LE.6)Q3=-1.D0/3.D0
          JFL=0
          JH=IH
C...ASSIGN FERMION MOMENTA
          DO I=0,3
            F(I)=P4(I)
            G(I)=P3(I)
          END DO
        ELSE
          IFL=IQ
          IF(IQ.EQ.7)IFL=IQ
          IF(IQ.EQ.8)IFL=IQ+1
          IF(IQ.EQ.9)IFL=IQ+2
          RM3=EMQ
          YM3=EMQ
          GAM3=0.D0
          RM4=ENQ
          YM4=ENQ
          GAM4=0.D0
C...NEUTRAL HIGGSES
          IF((IFL.EQ.1).OR.(IFL.EQ.3).OR.(IFL.EQ.5 ))THEN
            Q3=-1.D0/3.D0
          ELSEIF((IFL.EQ.2).OR.(IFL.EQ.4).OR.(IFL.EQ.6 ))THEN
            Q3=+2.D0/3.D0
          ELSEIF((IFL.EQ.7).OR.(IFL.EQ.9).OR.(IFL.EQ.11))THEN
            Q3=-1.D0
          END IF
          IF((IFL.EQ.1).OR.(IFL.EQ.3).OR.(IFL.EQ. 5).OR.
     &       (IFL.EQ.7).OR.(IFL.EQ.9).OR.(IFL.EQ.11))THEN
            JFL=1
          ELSEIF((IFL.EQ.2).OR.(IFL.EQ.4).OR.(IFL.EQ.6))THEN
            JFL=2
          END IF
          KHIGGS=IHIGGS
          IF(IHIGGS.NE.0)KHIGGS=IHIGGS-1
          JH=KHIGGS
C...ASSIGN FERMION MOMENTA
          DO I=0,3
            F(I)=P3(I)
            G(I)=P4(I)
          END DO
        END IF
        RM5=EMH
        GAM5=GMH
        S2W=SWEIN
        RMW=RMASS(198)
        RMZ=RMASS(200)
        GAMHL=HBAR/RLTIM(203)
        GAMHH=HBAR/RLTIM(204)
        GAMHA=HBAR/RLTIM(205)
        COLOUR=1.D0
        IF(IFL.LE.6)COLOUR=3.D0
C...MSSM COUPLINGS.
        IF(JH.LE.3)THEN
          HFC=ENHANC(IQ)
          HBC=ENHANC(10)
        ELSE
          HFC=ONE
          HBC=ONE
        END IF
C...ME.
        CALL HWH2HE(FIRST,GAUGE,JFL,JH,HFC,HBC,
     &     E,S2W,TANB,ALPHAH,RMW,S,Q3,F,G,P5,
     &     RM3,YM3,GAM3,RM4,YM4,GAM4,RM5,GAM5,
     &     RMHL,GAMHL,RMHH,GAMHH,RMHA,GAMHA,
     &     RMZ,GAMZ,COLOUR,M2EE)
C...CONSTANT FACTORS: PHI ALONG BEAM AND CONVERSION GEV^2->NB.
        FACT=2.*PIFAC*GEV2NB
C...PHASE SPACE JACOBIANS, PI'S AND FLUX.
        FACT=FACT*RQ4*RQ5/PCM/32./(2.*PIFAC)**5
     &      *((ECM-EMH)**2-(EMQ+ENQ)**2)
     &      /2./EMQQ/S
C...JACOBIANS FROM CT5 TO X(2).
        IF((IQ+JQ).EQ.18)THEN
          CONTINUE
        ELSE
          FACT=FACT*(TLMAX-TLMIN)/2./PCM/RCM*ABS(T)
          FACT=FACT*2.*ABS(ST4/CT4/SF4)
        END IF
C...CHARGE CONJUGATION.
        IF(IPROC.GE.1140)THEN
C...YES FOR CHARGED HIGGS.
          FACT=FACT*2.
        ELSE
C...NO FOR NEUTRAL HIGGSES.
          CONTINUE
        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
          IF (IDEC.EQ.10) THEN
            CALL HWDBOZ(198,ID1,ID2,CV,CA,BR,1)
            CALL HWDBOZ(199,ID1,ID2,CV,CA,BR,1)
            FACT=FACT*BR
          ELSEIF (IDEC.EQ.11) THEN
            CALL HWDBOZ(200,ID1,ID2,CV,CA,BR,1)
            CALL HWDBOZ(200,ID1,ID2,CV,CA,BR,1)
            FACT=FACT*BR
          ENDIF
        END IF
      END IF
C...SET UP FLAVOURS IN FINAL STATE.
      IF(IPROC.GE.1140)THEN
        IF(HWRGEN(0).LT.0.5)THEN
          JHIGGS=207-201
          IIQ=IQ
          JJQ=JQ
          FLIP=0
        ELSE
          JHIGGS=206-201
          IIQ=IQ-1
          JJQ=JQ+1
          FLIP=1
        END IF
      ELSE
        JHIGGS=IHIGGS
        IIQ=IQ
        JJQ=JQ
        FLIP=0
      END IF
      HCS=FACT*M2EE
      IF (GENEV.AND.HCS.GT.RCS) THEN
C...GENERATE EVENT.
        IDN(1)=IDHW(1)
        IDN(2)=IDHW(2)
        IF(IIQ.LE.12.AND.JJQ.LE.12)THEN
          IDN(3)=IIQ
          IDN(4)=JJQ
        ELSE
          IDN(3)=2*IIQ-7+114
          IDN(4)=2*IIQ-7+114+IAD
        END IF
        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...SETS UP INCOMING STATUS AND IDS ONLY FOR 2->1: USE HWEONE.
        IDCMF=15
        XX(1)=ONE
        XX(2)=ONE
        CALL HWEONE
        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...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...DO REAL INCOMING, OUTGOING MOMENTA IN THE LAB FRAME.
        DO M=NHEP-2,NHEP+3
          IF(M.EQ.NHEP  )GO TO 888
          DO N=0,3
            NN=N
            IF(N.EQ.0)NN=4
            IF(M.EQ.NHEP-2)PHEP(NN,M)=P1(N)
            IF(M.EQ.NHEP-1)PHEP(NN,M)=P2(N)
            IF(M.EQ.NHEP+1)PHEP(NN,M)=P3(N)*(1-FLIP)+P4(N)*FLIP
            IF(M.EQ.NHEP+2)PHEP(NN,M)=P4(N)*(1-FLIP)+P3(N)*FLIP
            IF(M.EQ.NHEP+3)PHEP(NN,M)=P5(N)
          END DO
 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+2)=SQRT(ABS(PHEP(4,NHEP+2)**2
     &                         -PHEP(3,NHEP+2)**2
     &                         -PHEP(2,NHEP+2)**2
     &                         -PHEP(1,NHEP+2)**2))
        PHEP(5,NHEP+3)=SQRT(ABS(PHEP(4,NHEP+3)**2
     &                         -PHEP(3,NHEP+3)**2
     &                         -PHEP(2,NHEP+3)**2
     &                         -PHEP(1,NHEP+3)**2))
C...SETS CMF.
        DO I=1,4
          PHEP(I,NHEP  )=PHEP(I,NHEP-2)+PHEP(I,NHEP-1)
        END DO
        PHEP(5,NHEP  )=SQRT(ABS(PHEP(4,NHEP  )**2
     &                         -PHEP(3,NHEP  )**2
     &                         -PHEP(2,NHEP  )**2
     &                         -PHEP(1,NHEP  )**2))
C...SETS UP OUTGOING 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)=IDN(5)
        IDHEP(NHEP+3)=IDPDG(IDN(5))
C...SETS UP COLOUR CONNECTIONS.
        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-1
        JDAHEP(2,NHEP-2)=NHEP-2
        JDAHEP(2,NHEP+3)=NHEP+3
        NHEP=NHEP+3
        IF(AZSPIN)THEN
C...SET TO ZERO THE COEFFICIENTS OF THE SPIN DENSITY MATRICES.
          CALL HWVZRO(7,GCOEF)
        END IF
      END IF
C...COLLECT WEIGHT.
      EVWGT=HCS
      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 'HERWIG65.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, 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...process event.
      IF (GENEV) THEN
        RCS = HCS*HWRGEN(0)
      ELSE
        HCS = ZERO
        EVWGT = ZERO
C...minimum transverse momentum.
        PTMIN = ZERO
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.
        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((MOD(IPROC,10000).EQ.3365).OR.
     &     (MOD(IPROC,10000).EQ.3375))THEN
          JH  = IHIGGS-1
          ID1 = 205
          ID2 = 202 + JH
        ELSE IF(MOD(IPROC,10000).EQ.3355)THEN
          JH  = 4
          ID1 = 206
          ID2 = 207
        ELSE IF((MOD(IPROC,10000).EQ.3315).OR.
     &          (MOD(IPROC,10000).EQ.3325).OR.
     &          (MOD(IPROC,10000).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((MOD(IPROC,10000).EQ.3365).OR.
     &     (MOD(IPROC,10000).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(MOD(IPROC,10000).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((MOD(IPROC,10000).EQ.3315).OR.
     &          (MOD(IPROC,10000).EQ.3325).OR.
     &          (MOD(IPROC,10000).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) THEN
         CALL HWHQCP(IH1,IH2,2134,1)
         GOTO 9
       ENDIF
       IH2 = 204
       HCS = HCS + DIST*EMHHWT*MNN(2,IQ)
       IF (GENEV.AND.HCS.GT.RCS) THEN
         CALL HWHQCP(IH1,IH2,2134,2)
         GOTO 9
       ENDIF
       IH1 = 206
       IH2 = 207
       HCS = HCS + DIST*EMHHWT*MCC(IQ)
       IF (GENEV.AND.HCS.GT.RCS) THEN
         CALL HWHQCP(IH1,IH2,2134,3)
         GOTO 9
       ENDIF
    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) THEN
           CALL HWHQCP(IH1,IH2,2134,3+IH)
           GOTO 9
         ENDIF
        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) THEN
           CALL HWHQCP(IH1,IH2,2134,3+IH)
           GOTO 9
         ENDIF
        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) THEN
           CALL HWHQCP(IH1,IH2,2134,3+IH)
           GOTO 9
         ENDIF
        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) THEN
           CALL HWHQCP(IH1,IH2,2134,3+IH)
           GOTO 9
         ENDIF
        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(.TRUE.,.TRUE.)
      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 'HERWIG65.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) THEN
           CALL HWHQCP(13 ,201,2314,81)
           GOTO 99
         ENDIF
         ID2=13
         HCS=HCS+FACTR*DISF(ID2,2)*AMPQG
         IF (GENEV.AND.HCS.GT.RCS) THEN
           CALL HWHQCP(ID1,201,3124,82)
           GOTO 99
         ENDIF
      ELSEIF (ID1.LT.13) THEN
C Antiquark first:
         ID2=ID1-6
         HCS=HCS+FACTR*DISF(ID2,2)*AMPQQ
         IF (GENEV.AND.HCS.GT.RCS) THEN
           CALL HWHQCP(13 ,201,3124,83)
           GOTO 99
         ENDIF
         ID2=13
         HCS=HCS+FACTR*DISF(ID2,2)*AMPQG
         IF (GENEV.AND.HCS.GT.RCS) THEN
           CALL HWHQCP(ID1,201,2314,84)
           GOTO 99
         ENDIF
      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) THEN
              CALL HWHQCP(ID2,201,2314,85)
              GOTO 99
            ENDIF
         ELSE
            HCS=HCS+FACTR*DISF(ID2,2)*AMPGQ
            IF (GENEV.AND.HCS.GT.RCS) THEN
              CALL HWHQCP(ID2,201,3124,86)
              GOTO 99
            ENDIF
         ENDIF
  20     CONTINUE
         HCS=HCS+FACTR*DISF(13,2)*AMPGG
         IF (GENEV.AND.HCS.GT.RCS) THEN
           CALL HWHQCP(13 ,201,2314,87)
           GOTO 99
         ENDIF
      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
C-- BRW fix 27/8/04: avoid double smearing of H mass
      CALL HWETWO(.TRUE.,.FALSE.)
      RMASS(IDN(4))=EMHTMP
      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 'HERWIG65.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
        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) THEN
            CALL HWWARN('HWHIGM',51)
            GOTO 999
          ENDIF
          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)
      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**2*EMM*EM)
      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**2*EMM*EM)
      ELSE
        CALL HWWARN('HWHIGM',500)
      ENDIF
 999  RETURN
      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: 08-APR-1999 by Stefano Moretti
C...Last modified: 28-JUN-2001 by Stefano Moretti
C
      SUBROUTINE HWHIGQ
C-----------------------------------------------------------------------
C     PRODUCTION OF MSSM HIGGSES IN ASSOCIATION WITH HEAVY QUARK PAIRS
C-----------------------------------------------------------------------
      INCLUDE 'HERWIG65.INC'
      INTEGER JHIGGS
      INTEGER I,J,K,L,M,N
      INTEGER IS,IH,IQ,JQ,IIQ,JJQ,IQMIN,IQMAX,IGG,IQQ
      INTEGER IDEC,NC,FLIP
      INTEGER ID1,ID2
      DOUBLE PRECISION CV,CA,BR
      DOUBLE PRECISION BRHIGQ,EMQ,ENQ,EMQQ,EMH,EMHWT,EMW
      DOUBLE PRECISION PTMMIN,PTNMIN
      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,SHAT,P3,P4,P5
      SAVE IIQ,JJQ,JHIGGS
      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((MOD(IPROC,10000).EQ.3839).OR.
     &   (MOD(IPROC,10000).EQ.3869).OR.
     &   (MOD(IPROC,10000).EQ.3899))THEN
        IQ=6
        JQ=11
        GM=HBAR/RLTIM(6)*RMASS(6)
      ELSE
        IF(IMSSM.EQ.0)THEN
          IS=0
          IH=0
          IQ=6
        ELSE
          IF(MOD(IPROC,10000).LT.4000)IS=6
          IF(MOD(IPROC,10000).LT.3870)IS=3
          IF(MOD(IPROC,10000).LT.3840)IS=0
          IH=MOD(IPROC,10000)/10-380-IS
          IQ=MOD(IPROC,10000)-3800-10*(IH+IS)
        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**2-(EMQ+ENQ)**2)/((ECM-EMH)**2-(EMQ+ENQ)**2),
C...LIGHT QUARKS -> X(2)=(LOG|T|-LOG|TMIN|)/(LOG|TMAX|-LOG|TMIN|),
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+JQ).EQ.18)THEN
          XL(2)=-1.
          XL(4)=0.
          XU(4)=2.*PIFAC
        ELSE
          XL(2)=0.
          XL(4)=-1.
          XU(4)=1.
        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.
        PTMMIN=0.
        PTNMIN=0.
        IF(IMSSM.NE.0)THEN
          IF((MOD(IPROC,10000).EQ.3839).OR.
     &       (MOD(IPROC,10000).EQ.3869).OR.
     &       (MOD(IPROC,10000).EQ.3899))THEN
            PTNMIN=PTMIN
          ELSE
            IF((IQ.NE.6).AND.(IQ.NE.12).AND.
     &         (JQ.NE.6).AND.(JQ.NE.12))THEN
              PTMMIN=PTMIN
              PTNMIN=PTMIN
            ELSE
              CONTINUE
            END IF
          END IF
        END IF
        ECM=SQRT(1./(X(5)*(1./(SQRT(PTMMIN**2+EMQ**2)
     &                        +SQRT(PTNMIN**2+ENQ**2)+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=SQRT(X(1)*((ECM-EMH)**2-(EMQ+ENQ)**2)+(EMQ+ENQ)**2)
C...incoming partons: all massless.
        EMIN=0.
        IF((IQ+JQ).EQ.18)THEN
          CT5=X(2)
          CT4=X(3)
          ST4=SQRT(1.-CT4*CT4)
          CF4=COS(X(4))
          SF4=SIN(X(4))
        ELSE
          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=LOG(ABS(TTMAX))
          TLMAX=LOG(ABS(TTMIN))
          TL=X(2)*(TLMAX-TLMIN)+TLMIN
          T=EXP(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)
          IF (HWRLOG(HALF)) CT4=-CT4
          CF4=X(4)
          SF4=SQRT(1.-CF4*CF4)
          IF (HWRLOG(HALF)) SF4=-SF4
        END IF
        ST5=SQRT(1.-CT5*CT5)
        IF (HWRLOG(HALF)) ST5=-ST5
        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
        IF(IMSSM.NE.0)THEN
          IF((MOD(IPROC,10000).EQ.3839).OR.
     &       (MOD(IPROC,10000).EQ.3869).OR.
     &       (MOD(IPROC,10000).EQ.3899))THEN
            IF(SQRT(P4(1)**2+P4(2)**2).LT.PTMIN)RETURN
          ELSE
            IF((IQ.NE.6).AND.(IQ.NE.12).AND.
     &         (JQ.NE.6).AND.(JQ.NE.12))THEN
              IF(SQRT(P3(1)**2+P3(2)**2).LT.PTMIN)RETURN
              IF(SQRT(P4(1)**2+P4(2)**2).LT.PTMIN)RETURN
            ELSE
              CONTINUE
            END IF
          END IF
        END IF
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((MOD(IPROC,10000).EQ.3839).OR.
     &     (MOD(IPROC,10000).EQ.3869).OR.
     &     (MOD(IPROC,10000).EQ.3899))THEN
          IF(MOD(IPROC,10000).EQ.3869)IQQ=0
          IF(MOD(IPROC,10000).EQ.3899)IGG=0
          GRND=TANB
        ELSE
          IF(IMSSM.NE.0)THEN
            IF((MOD(IPROC,10000)/10-380).EQ.4)IQQ=0
            IF((MOD(IPROC,10000)/10-380).EQ.7)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-EMH)**2-(EMQ+ENQ)**2)
     &      /2./EMQQ
C...Jacobians from CT5 to X(2).
        IF((IQ+JQ).EQ.18)THEN
          CONTINUE
        ELSE
          FACT=FACT*(TLMAX-TLMIN)/2./PCM/RCM*ABS(T)
          FACT=FACT*2.*ABS(ST4/CT4/SF4)
        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((MOD(IPROC,10000).EQ.3839).OR.
     &     (MOD(IPROC,10000).EQ.3869).OR.
     &     (MOD(IPROC,10000).EQ.3899))THEN
C...enhancement factor for coupling+c.c.
          FACT=FACT*4.*VCKM(3,3)
        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
c bug fix 11/10/02 SM.
          IF (IDEC.EQ.10) THEN
            CALL HWDBOZ(198,ID1,ID2,CV,CA,BR,1)
            CALL HWDBOZ(199,ID1,ID2,CV,CA,BR,1)
            FACT=FACT*BR
          ELSEIF (IDEC.EQ.11) THEN
            CALL HWDBOZ(200,ID1,ID2,CV,CA,BR,1)
            CALL HWDBOZ(200,ID1,ID2,CV,CA,BR,1)
            FACT=FACT*BR
          ENDIF
c end of bug fix.
        END IF
      END IF
C...set up flavours in final state.
      IF((MOD(IPROC,10000).EQ.3839).OR.
     &   (MOD(IPROC,10000).EQ.3869).OR.
     &   (MOD(IPROC,10000).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((MOD(IPROC,10000).EQ.3839).OR.
     &   (MOD(IPROC,10000).EQ.3869).OR.
     &   (MOD(IPROC,10000).EQ.3899))THEN
        IF(MOD(IPROC,10000).EQ.3869)IQMIN=13
        IF(MOD(IPROC,10000).EQ.3899)IQMAX=12
      ELSE
        IF(IMSSM.NE.0)THEN
C...Some compilers don't like this statement.
C   Since it does nothing, just comment it out.
C         IF((MOD(IPROC,10000).GE.3811).AND.
C    &       (MOD(IPROC,10000).LE.3836))CONTINUE
          IF((MOD(IPROC,10000).GE.3841).AND.
     &       (MOD(IPROC,10000).LE.3866))IQMIN=13
          IF((MOD(IPROC,10000).GE.3871).AND.
     &       (MOD(IPROC,10000).LE.3896))IQMAX=12
        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)THEN
              CONTINUE
              CALL HWHQCP(IIQ,JJQ,2413, 4)
              GOTO 9
            END IF
          ELSE IF(I.EQ.J+6)THEN
            HCS=HCS+M2QQ*DIST*FACT
            IF(GENEV.AND.HCS.GT.RCS)THEN
              FLIP=(2-2*FLIP)/2
              CALL HWHQCP(JJQ,IIQ,3142,12)
              GOTO 9
            END IF
          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) THEN
            CALL HWHQCP(IIQ,JJQ,2413,27)
            GOTO 9
          ENDIF
          HCS=HCS
     &   +(M2GGMN-M2GG*M2GGMN/(M2GGPL+M2GGMN)/FLOAT(NC)**2)*DIST*FACT
          IF(GENEV.AND.HCS.GT.RCS) THEN
            CALL HWHQCP(IIQ,JJQ,4123,28)
            GOTO 9
          ENDIF
        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(.TRUE.,.TRUE.)
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
      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 'HERWIG65.INC'
      DOUBLE PRECISION HWUALF,HWHIGT,HWRGEN,HWUSQR,HWUAEM,BRHIGQ,EMH,
     & CSFAC(13),EVSUM(13),EMFAC,CV,CA,BR,RWGT,E1,E2,EMQ,GFACTR,RQM(6)
      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)/(576.*SWEIN*RMASS(198)**2)
C--MOD BY BRW 16/07/03 TO USE RUNNING MASSES
          CALL HWURQM(EMH,RQM)
          DO 20 I=13,13
            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)
            ELSE
              EMQ=RQM(I)
              IF (EMQ.GT.ZERO.AND.EMH.GT.TWO*EMQ) THEN
                CSFAC(I)=-GFACTR*96.*PIFAC**2 *(1-(TWO*EMQ/EMH)**2)
     &                *(EMQ/EMH)**2 *XLMIN *EMFAC*ENHANC(I)**2
              ELSE
                CSFAC(I)=0
              ENDIF
            ENDIF
C--END MOD
 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
      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 'HERWIG65.INC'
      DOUBLE PRECISION HWHIGT,RATIO,RAT2,EMH,FREAL,FIMAG,ETALOG,AIREAL,
     & AIIMAG
      INTEGER I,J,K,L
      HWHIGT=0
      IF (ABS(PARITY).NE.1) CALL HWWARN('HWHIGT',500)
      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
      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--BRW fix 27/8/04: corrected off-shell gauge boson mass dependence
C-----------------------------------------------------------------------
      INCLUDE 'HERWIG65.INC'
      INTEGER I,J,K,L,M,N
      INTEGER IV,IDEC
      INTEGER ID1,ID2
      DOUBLE PRECISION CV,CA,BR
      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(IMSSM.EQ.0)THEN
        IF(IPRO.EQ.26)IV=0
        IF(IPRO.EQ.27)IV=1
      ELSE
        IF((MOD(IPROC,10000).EQ.3310).OR.
     &     (MOD(IPROC,10000).EQ.3320))THEN
          IV=0
        ELSEIF((MOD(IPROC,10000).EQ.3360).OR.
     &         (MOD(IPROC,10000).EQ.3370))THEN
          IV=1
        END IF
      END IF
      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.
        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-GAMMAX*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
c bug fix 20/05/01 SM.
              QQV(I,J)=VCKM(M,N)
c end of bug fix.
              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)
C--BRW fix 27/8/04: RMV*RMV --> EMV*EMV
        FACT=FACT*16.*PIFAC**2*ALPHA**2/SWEIN/SWEIN*EMV*EMV
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
c bug fix 11/10/02 SM.
          IF (IDEC.EQ.10) THEN
            CALL HWDBOZ(198,ID1,ID2,CV,CA,BR,1)
            CALL HWDBOZ(199,ID1,ID2,CV,CA,BR,1)
            FACT=FACT*BR
          ELSEIF (IDEC.EQ.11) THEN
            CALL HWDBOZ(200,ID1,ID2,CV,CA,BR,1)
            CALL HWDBOZ(200,ID1,ID2,CV,CA,BR,1)
            FACT=FACT*BR
          ENDIF
c end of bug fix.
        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
C-- BRW fix 27/8/04: avoid double smearing of W and H masses
          CALL HWETWO(.FALSE.,.FALSE.)
          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
      END
CDECK  ID>, HWHIGW.
*CMZ :-        -26/04/91  14.55.44  by  Federico Carminati
*-- Author :    Mike Seymour, modified by Stefano Moretti
C-----------------------------------------------------------------------
      SUBROUTINE HWHIGW
C-----------------------------------------------------------------------
C     HIGGS PRODUCTION VIA W/Z BOSON FUSION
C     MEAN EVWGT = HIGGS PRODN C-S * BRANCHING FRACTION IN NB
C-----------------------------------------------------------------------
      INCLUDE 'HERWIG65.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(2),AZZ(2,6),PWW,PZZ(6),EMZ,EMZ2,RSUM,
     & GLUSQ,GRUSQ,GLDSQ,GRDSQ,GLESQ,GRESQ,
     & CW,CZ,EMFAC,CV,CA,BR,X2,ETA,P1JAC,FACTR,EH2,K22JAC,COSMIN
      INTEGER HWRINT,IDEC,I,ID1,ID2,IHAD,NPOW
      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+IHIGGS)**2
        CW=256*(PIFAC*HWUAEM(EH2)/SWEIN)**3*EMW2
        CZ=256.*(PIFAC*HWUAEM(EH2))**3*EMZ2/(SWEIN*(1.-SWEIN))
      ENDIF
      EE=IPRO.LE.12
      EP=IPRO.GE.90
      IF (.NOT.GENEV) THEN
C---CHOOSE PARAMETERS
        EVWGT=0.
        EMH=RMASS(201+IHIGGS)
        EMFAC=ONE
        IF(IMSSM.EQ.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
        IF (COSPHI.GT.0 .OR. HWRGEN(0).GT.HALF) THEN
        K2MAX2=ROOTS*(ROOTS2-EMH2-2*P1*ROOTS)/(ROOTS-P1*(1-COSTH1))
        K2MIN2=0
        K22=EMW2-(EMW2+K2MAX2)*(EMW2+K2MIN2)/
     &           ((K2MAX2-K2MIN2)*HWRGEN(0)+(EMW2+K2MIN2))
        K22JAC=(K2MAX2-K2MIN2)/((K2MAX2+EMW2)*(K2MIN2+EMW2))
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)
        COSTH2=(-A*C + TERM2)/(A**2+B**2)
        SINTH2=-(C+A*COSTH2)/B
        IF (ABS(COSTH2).GE.1.OR.SINTH2.LT.0) RETURN
        K22JAC=K22JAC
     $       /(1-(1+COSTH2)*(P1*(COSTH1-SINTH1*COSTH2/SINTH2*COSPHI))
     $       /(ROOTS-P1*(1-COSTH1*COSTH2-SINTH1*SINTH2*COSPHI)) )
        IF (COSPHI.LE.0) K22JAC=K22JAC*2
        ELSE
          A=ROOTS-P1*(1+COSTH1)
          B=2*P1*SINTH1*COSPHI
          COSMIN=(A**2-B**2)/(A**2+B**2)
          IF (ABS(COSMIN).GE.1) RETURN
          NPOW=-3
          COSTH2=(TWO**NPOW
     $         -(TWO**NPOW-(1+COSMIN)**NPOW)*HWRGEN(0))**(ONE/NPOW)-1
          IF (ABS(COSTH2).GE.1) RETURN
          SINTH2=SQRT(1-COSTH2**2)
          K22=-ROOTS*(1+COSTH2)*(ROOTS2-EMH2-2*ROOTS*P1)/
     $         (2*ROOTS-2*P1*(1-COSTH1*COSTH2-SINTH1*SINTH2*COSPHI))
          K22JAC=-K22/(1+COSTH2)/(K22-EMW2)**2
     $        *(1+COSTH2)**(1-NPOW)/(-NPOW)*((1+COSMIN)**NPOW-TWO**NPOW)
          K22JAC=K22JAC*2
        ENDIF
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(1)=ENHANC(10)**2 * CW*(ROOTS2/2*HWULDO(Q1,Q2)*G1WW
     &         +ROOTS2/4*P1*P2*(1+COSTH1)*(1-COSTH2)*G2WW)
        AWW(2)=ENHANC(10)**2 * CW*(ROOTS2/2*HWULDO(Q1,Q2)*G2WW
     &         +ROOTS2/4*P1*P2*(1+COSTH1)*(1-COSTH2)*G1WW)
        DO 10 I=1,6
          AZZ(1,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
          AZZ(2,I)=ENHANC(11)**2 * CZ*(ROOTS2/2*HWULDO(Q1,Q2)*G2ZZ(I)
     &               +ROOTS2/4*P1*P2*(1+COSTH1)*(1-COSTH2)*G1ZZ(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))
     &              *K22JAC
     &              * EMFAC
        EMSCA=EMH
        XXMIN=(ROOTS/PHEP(5,3))**2
        XLMIN=LOG(XXMIN)
C---INCLUDE BRANCHING RATIO OF HIGGS
        IF(IMSSM.EQ.0)THEN
          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
        END IF
        IF (EE) THEN
          CSFAC=WEIGHT
          IF (IDHW(1).EQ.IDHW(2)) THEN
            PWW=AWW(1)
            PZZ(4)=AZZ(1,4)
          ELSE
            PWW=AWW(2)
            PZZ(4)=AZZ(2,4)
          ENDIF
          PSUM=PWW+PZZ(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))*AWW(1)+
     &          (DISF(7,2)+DISF( 9,2))*AWW(2)
            PZZ(5)=(DISF(2,2)+DISF( 4,2))*AZZ(1,5)+
     &             (DISF(8,2)+DISF(10,2))*AZZ(2,5)
            PZZ(6)=(DISF(1,2)+DISF( 3,2))*AZZ(1,6)+
     &             (DISF(7,2)+DISF( 9,2))*AZZ(2,6)
          ELSE
            PWW=(DISF(8,2)+DISF(10,2))*AWW(1)+
     &          (DISF(1,2)+DISF( 3,2))*AWW(2)
            PZZ(5)=(DISF(8,2)+DISF(10,2))*AZZ(1,5)+
     &             (DISF(2,2)+DISF( 4,2))*AZZ(2,5)
            PZZ(6)=(DISF(7,2)+DISF( 9,2))*AZZ(1,6)+
     &             (DISF(1,2)+DISF( 3,2))*AZZ(2,6)
          ENDIF
          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(1,2)+DISF( 3,2))
     &        +(DISF(1,1)+DISF( 3,1))*(DISF(2,2)+DISF( 4,2))
     &        +(DISF(7,1)+DISF( 9,1))*(DISF(8,2)+DISF(10,2))
     &        +(DISF(8,1)+DISF(10,1))*(DISF(7,2)+DISF( 9,2)))
     &        *AWW(1)+
     &        ((DISF(2,1)+DISF( 4,1))*(DISF(8,2)+DISF(10,2))
     &        +(DISF(1,1)+DISF( 3,1))*(DISF(7,2)+DISF( 9,2))
     &        +(DISF(7,1)+DISF( 9,1))*(DISF(1,2)+DISF( 3,2))
     &        +(DISF(8,1)+DISF(10,1))*(DISF(2,2)+DISF( 4,2)))
     &        *AWW(2)
          PZZ(1)=((DISF(2,1)+DISF( 4,1))*(DISF(2,2)+DISF( 4,2))
     &           +(DISF(8,1)+DISF(10,1))*(DISF(8,2)+DISF(10,2)))
     &           *AZZ(1,1)+
     &           ((DISF(2,1)+DISF( 4,1))*(DISF(8,2)+DISF(10,2))
     &           +(DISF(8,1)+DISF(10,1))*(DISF(2,2)+DISF( 4,2)))
     &           *AZZ(2,1)
          PZZ(2)=((DISF(2,1)+DISF( 4,1))*(DISF(1,2)+DISF( 3,2))
     &           +(DISF(1,1)+DISF( 3,1))*(DISF(2,2)+DISF( 4,2))
     &           +(DISF(8,1)+DISF(10,1))*(DISF(7,2)+DISF( 9,2))
     &           +(DISF(7,1)+DISF( 9,1))*(DISF(8,2)+DISF(10,2)))
     &           *AZZ(1,2)+
     &           ((DISF(2,1)+DISF( 4,1))*(DISF(7,2)+DISF( 9,2))
     &           +(DISF(1,1)+DISF( 3,1))*(DISF(8,2)+DISF(10,2))
     &           +(DISF(8,1)+DISF(10,1))*(DISF(1,2)+DISF( 3,2))
     &           +(DISF(7,1)+DISF( 9,1))*(DISF(2,2)+DISF( 4,2)))
     &           *AZZ(2,2)
          PZZ(3)=((DISF(1,1)+DISF(3,1))*(DISF(1,2)+DISF(3,2))
     &           +(DISF(7,1)+DISF(9,1))*(DISF(7,2)+DISF(9,2)))
     &           *AZZ(1,3)+
     &           ((DISF(1,1)+DISF(3,1))*(DISF(7,2)+DISF(9,2))
     &           +(DISF(7,1)+DISF(9,1))*(DISF(1,2)+DISF(3,2)))
     &           *AZZ(2,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.PWW) 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 COLLISION?
        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
            IF (IDN(1).LE.126.AND.IDN(2).LE.6
     $      .OR.IDN(1).GE.127.AND.IDN(2).GE.7) THEN
              PROB=DISF(IDN(2),2)*AWW(1)/PWW
            ELSE
              PROB=DISF(IDN(2),2)*AWW(2)/PWW
            ENDIF
            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
            IF (IDN(1).LE.126.AND.IDN(2).LE.6
     $      .OR.IDN(1).GE.127.AND.IDN(2).GE.7) THEN
              PROB=DISF(IDN(2),2)*AZZ(1,5)/PZZ(5)
            ELSE
              PROB=DISF(IDN(2),2)*AZZ(2,5)/PZZ(5)
            ENDIF
            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
            IF (IDN(1).LE.126.AND.IDN(2).LE.6
     $      .OR.IDN(1).GE.127.AND.IDN(2).GE.7) THEN
              PROB=DISF(IDN(2),2)*AZZ(1,6)/PZZ(6)
            ELSE
              PROB=DISF(IDN(2),2)*AZZ(2,6)/PZZ(6)
            ENDIF
            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
            IF (IDN(1).LE.6.AND.IDN(2).LE.6
     $      .OR.IDN(1).GE.7.AND.IDN(2).GE.7) THEN
              PROB=DISF(IDN(1),1)*DISF(IDN(2),2)*AWW(1)/PWW
            ELSE
              PROB=DISF(IDN(1),1)*DISF(IDN(2),2)*AWW(2)/PWW
            ENDIF
            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
            IF (IDN(1).LE.6.AND.IDN(2).LE.6
     $      .OR.IDN(1).GE.7.AND.IDN(2).GE.7) THEN
              PROB=DISF(IDN(1),1)*DISF(IDN(2),2)*AZZ(1,1)/PZZ(1)
            ELSE
              PROB=DISF(IDN(1),1)*DISF(IDN(2),2)*AZZ(2,1)/PZZ(1)
            ENDIF
            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
            IF (IDN(1).LE.6.AND.IDN(2).LE.6
     $      .OR.IDN(1).GE.7.AND.IDN(2).GE.7) THEN
              PROB=DISF(IDN(1),1)*DISF(IDN(2),2)*AZZ(1,3)/PZZ(3)
            ELSE
              PROB=DISF(IDN(1),1)*DISF(IDN(2),2)*AZZ(2,3)/PZZ(3)
            ENDIF
            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
            IF (IDN(1).LE.6.AND.IDN(2).LE.6
     $      .OR.IDN(1).GE.7.AND.IDN(2).GE.7) THEN
              PROB=DISF(IDN(1),1)*DISF(IDN(2),2)*AZZ(1,2)/PZZ(2)
            ELSE
              PROB=DISF(IDN(1),1)*DISF(IDN(2),2)*AZZ(2,2)/PZZ(2)
            ENDIF
            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(3))
        Q1(4)=SQRT(Q1(4)**2+Q1(5)**2)
        Q2(5)=RMASS(IDN(4))
        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+IHIGGS
        IDHEP(NHEP+3)=IDPDG(201+IHIGGS)
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
      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, modified by Stefano Moretti
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 'HERWIG65.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))
      SAVE ELST
      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=PPOLN(3)-EPOLN(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+IHIGGS)**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
        EMH=RMASS(201+IHIGGS)
        EMFAC=ONE
        IF(IMSSM.EQ.0)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
        IF(IMSSM.EQ.0)THEN
          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
        END IF
      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) THEN
            CALL HWWARN('HWHIGZ',101)
            GOTO 999
          ENDIF
          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)
            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) THEN
            CALL HWWARN('HWHIGZ',102)
            GOTO 999
          ENDIF
          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) THEN
          CALL HWWARN('HWHIGZ',103)
          GOTO 999
        ENDIF
        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+IHIGGS
        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  RETURN
      END
CDECK  ID>, HWHIHH.
*CMZ :-        -25/11/01  17.11.33  by  Stefano Moretti
*-- Author :  Kosuke Odagiri, modified by Stefano Moretti
C-----------------------------------------------------------------------
C...Generate completely differential cross section (EVWGT) in the variable
C...X(I) with I=1 (see below) for the processes IPROC=955,965,975 as
C...described in the HERWIG 6 documentation file.
C
C...First release: 12-NOV-2001 by Stefano Moretti
C
C-----------------------------------------------------------------------
      SUBROUTINE HWHIHH
C-----------------------------------------------------------------------
C     PRODUCTION OF MSSM HIGGS PAIRS IN L+L- (L=E,MU)
C-----------------------------------------------------------------------
      INCLUDE 'HERWIG65.INC'
      DOUBLE PRECISION HWRGEN, HWUAEM, HCS, RCS, S, PF, QPE,
     & FACTR, SN2TH, MZ, MNN(2), MCC, EMSC2, GZ2,
     & GHH(4), XWEIN, S2W, X(1), XL(1),
     & XU(1), WEIGHT, ECM, RMH1, RMH2, EMH1, EMH2,
     & EMHWT1, EMHWT2, EMHHWT, SHAT
      INTEGER I, ID1, ID2, IH1, IH2, IH, JH
      EXTERNAL HWRGEN, HWUAEM
      SAVE HCS,MNN,MCC,EMHHWT,S,SHAT
      DOUBLE COMPLEX Z, GZ, A, D, E
      PARAMETER (Z = (0.D0,1.D0))
      EQUIVALENCE (MZ, RMASS(200))
C...process event.
      IF (GENEV) THEN
        RCS = HCS*HWRGEN(0)
      ELSE
        HCS = ZERO
        EVWGT = ZERO
C...energy at parton level.
        ECM = PBEAM1+PBEAM2
        S = ECM*ECM
        SHAT = S
C...phase space variables.
C...X(1)=COS(THETA_CM),
C...phase space borders.
        XL(1)= -1.
        XU(1)= 1.
C...single phase space point.
        WEIGHT=1.
        DO I=1,1
          X(I)=XL(I)+(XU(I)-XL(I))*HWRGEN(0)
          WEIGHT=WEIGHT*ABS(XU(I)-XL(I))
        END DO
C...final state masses.
        IF((MOD(IPROC,10000).EQ.965).OR.
     &     (MOD(IPROC,10000).EQ.975))THEN
          JH  = IHIGGS-1
          ID1 = 205
          ID2 = 202 + JH
        ELSE IF(MOD(IPROC,10000).EQ.955)THEN
          JH  = 4
          ID1 = 206
          ID2 = 207
        END IF
        RMH1=RMASS(ID1)
        RMH2=RMASS(ID2)
        EMH1=RMH1
        EMH2=RMH2
        EMHWT1=1.
        EMHWT2=1.
        EMHHWT=EMHWT1*EMHWT2
C...polar angle.
        COSTH = X(1)
        SN2TH = 0.25D0 - 0.25D0*COSTH**2
        EMSCA = EMH1+EMH2
        EMSC2 = EMSCA*EMSCA
        EVWGT = ZERO
        FACTR = GEV2NB*PIFAC*(HWUAEM(EMSC2))**2/SHAT*SN2TH/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)
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
          MNN(I)=ZERO
        END DO
        MCC=ZERO
C...start subprocesses.
        IF((MOD(IPROC,10000).EQ.965).OR.
     &     (MOD(IPROC,10000).EQ.975))THEN
c
c   -  +      o  o   o
c  l  l   -> 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
              MNN(IH) =
     &          FACTR*PF**3*GHH(IH)**2*(LFCH(11)**2+RFCH(11)**2)/GZ2
            ELSE
              CONTINUE
            END IF
          END DO
        ELSE IF(MOD(IPROC,10000).EQ.955)THEN
c
c   -  +     +  -
c  l  l  -> H  H
c
          IH = JH
          QPE = SHAT-(EMH1+EMH2)**2
          IF (QPE.GT.ZERO) THEN
            PF = SQRT(QPE*(SHAT-(EMH1-EMH2)**2))/SHAT
            A = GHH(IH)/GZ
            D = QFCH(11)+A*LFCH(11)
            E = QFCH(11)+A*RFCH(11)
            MCC=FACTR*PF**3*DREAL(DCONJG(D)*D+DCONJG(E)*E)
          ELSE
            CONTINUE
          END IF
        END IF
      END IF
      HCS = ZERO
      IF(MOD(IPROC,10000).EQ.965)THEN
        IH1 = 205
        IH2 = 203
        HCS = HCS + EMHHWT*MNN(1)
      ELSE IF(MOD(IPROC,10000).EQ.975)THEN
        IH1 = 205
        IH2 = 204
        HCS = HCS + EMHHWT*MNN(2)
      ELSE IF(MOD(IPROC,10000).EQ.955)THEN
        IH1 = 206
        IH2 = 207
        HCS = HCS + EMHHWT*MCC
      END IF
      IF (GENEV.AND.HCS.GT.RCS) THEN
C...generate event.
        IDN(1)=IDHW(1)
        IDN(2)=IDHW(2)
        IDN(3)=IH1
        IDN(4)=IH2
        IDCMF=15
        XX(1) = ONE
        XX(2) = ONE
        CALL HWETWO(.TRUE.,.TRUE.)
        IF (AZSPIN) THEN
          CALL HWVZRO(7,GCOEF)
        END IF
      END IF
      EVWGT = HCS
      END
CDECK  ID>, HWHISQ.
*CMZ :-        -30/06/01  18.41.23  by  Stefano Moretti
*-- 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=3110
C...to IPROC=3298, 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: 08-APR-2000 by Stefano Moretti
C...Last modified: 29-JUN-2001 by Stefano Moretti
C
C-----------------------------------------------------------------------
      SUBROUTINE HWHISQ
C-----------------------------------------------------------------------
C     PRODUCTION OF MSSM HIGGSES IN ASSOCIATION WITH B,T-SQUARK PAIRS
C-----------------------------------------------------------------------
      INCLUDE 'HERWIG65.INC'
      COMMON/SQSQH/JHIGGS,ILBL,JH,IF1MIN,IF1MAX,IF2MIN,IF2MAX
      INTEGER      JHIGGS,ILBL,JH,IF1MIN,IF1MAX,IF2MIN,IF2MAX
      INTEGER I,J,K,L,M,N
      INTEGER IQMIN,IQMAX,IGG,IQQ,JPP
      INTEGER NC,FLIP
      INTEGER IF1,IF2
      INTEGER JHH,IMIX1,IMIX2
      INTEGER JSQ,JSQ1,JSQ2
      INTEGER IME,JME
      DOUBLE PRECISION EMSQ1,EMSQ2,GAMSQ1,GAMSQ2,EMSQQ,EMH,EMHWT
      DOUBLE PRECISION GSQ1,GSQ2
      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 GGSQHT,GGSQHU,GGSQHN,QQSQH
      DOUBLE PRECISION M2GG(8),M2GGPL(8),M2GGMN(8),M2QQ(8)
      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,GACT,FACT(8),DIST
      DOUBLE PRECISION WEIGHT
      SAVE HCS,M2QQ,M2GG,M2GGPL,M2GGMN,FACT,S,SHAT,P3,P4,P5
      SAVE IME,JSQ1,JSQ2
      LOGICAL HWRLOG
      EXTERNAL HWRGEN,HWUAEM,HWUALF,HWHQCP,HWH2SH,HWETWO,HWRLOG
      PARAMETER (EPS=1.D-9)
      EQUIVALENCE (NC,NCOLO)
C...process the event.
      IF(GENEV)THEN
        RCS=HCS*HWRGEN(0)
      ELSE
        HCS=0.
        EVWGT=0.
C...loop over final state flavours.
        IME=0
        DO I=1,8
          M2GG(I)=0.
          M2GGPL(I)=0.
          M2GGMN(I)=0.
          M2QQ(I)=0.
          FACT(I)=0.
        END DO
        DO 2 IF1=IF1MIN,IF1MAX
        IF((IF1.GE.407).AND.(IF1.LE.416))GOTO 2
        DO 1 IF2=IF2MIN,IF2MAX
        IF((IF2.GE.413).AND.(IF2.LE.422))GOTO 1
C...assign squark flavour.
        JSQ1=IF1
        JSQ2=IF2
C...check charge.
        IF((ICHRG(JSQ1)+ICHRG(JSQ2))/3.NE.-ICHRG(201+JHIGGS+1))GOTO 1
        IME=IME+1
        IF((IME.LE.0).OR.(IME.GT.8)) THEN
          CALL HWWARN('HWHISQ',100)
          GOTO 999
        ENDIF
C...assign final state masses and widths.
        EMSQ1=RMASS(JSQ1)
        EMSQ2=RMASS(JSQ2)
        GAMSQ1=HBAR/RLTIM(JSQ1)
        GAMSQ2=HBAR/RLTIM(JSQ2)
        EMH=RMASS(201+JHIGGS+1)
        EMHWT=1.
C...energy at hadron level.
        ECM_MAX=PBEAM1+PBEAM2
        S=ECM_MAX*ECM_MAX
C...phase space variables.
C...X(1)=(EMSQQ-EMSQ1-EMSQ2)/(ECM-EMSQ1-EMSQ2-EMH),
C...X(2)=COS(THETA5_CM),X(3)=COS(THETA4_CM_34),X(4)=FI4_CM_34,
C...X(5)=(1./SHAT-1./ECM_MAX**2)/(1./(EMSQ1+EMSQ2+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.
        XL(2)=-1.
        XU(2)=1.
        XL(3)=-1.
        XU(3)=1.
        XL(4)=0.
        XU(4)=2.*PIFAC
        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./(EMSQ1+EMSQ2+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.
        EMSQQ=X(1)*(ECM-EMSQ1-EMSQ2-EMH)+EMSQ1+EMSQ2
        CT5=X(2)
        IF(HWRLOG(HALF))THEN
          ST5=+SQRT(1.-CT5*CT5)
        ELSE
          ST5=-SQRT(1.-CT5*CT5)
        END IF
        CT4=X(3)
        ST4=SQRT(1.-CT4*CT4)
        CF4=COS(X(4))
        SF4=SIN(X(4))
        RQ52=((ECM*ECM-EMH*EMH-EMSQQ*EMSQQ)**2-(2.*EMH*EMSQQ)**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+EMSQQ*EMSQQ)
        RQ42=((EMSQQ*EMSQQ-EMSQ1*EMSQ1-EMSQ2*EMSQ2)**2
     &    -(2.*EMSQ1*EMSQ2)**2)/
     &     (4.*EMSQQ*EMSQQ)
        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+EMSQ2*EMSQ2)
        PQ4=0.
        DO I=1,3
          PQ4=PQ4+Q34(I)*Q4(I)
        END DO
        P4(0)=(Q34(0)*Q4(0)+PQ4)/EMSQQ
        P3(0)=Q34(0)-P4(0)
        DO I=1,3
          P4(I)=Q4(I)+Q34(I)*(P4(0)+Q4(0))/(Q34(0)+EMSQQ)
          P3(I)=Q34(I)-P4(I)
        END DO
C...incoming partons: all 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.
        IGG=1
        IQQ=1
        JPP=(MOD(IPROC,10000)/10-ILBL/10)
        IF((JPP.EQ.4).OR.(JPP.EQ.5).OR.(JPP.EQ.6))IQQ=0
        IF((JPP.EQ.7).OR.(JPP.EQ.8).OR.(JPP.EQ.9))IGG=0
        GSQ1=GAMSQ1*EMSQ1
        GSQ2=GAMSQ2*EMSQ2
        CALL HWH2SH(ECM,P1,P2,P3,P4,P5,EMSQ1,EMSQ2,EMH,GSQ1,GSQ2,
     &              IGG,IQQ,GGSQHT,GGSQHU,GGSQHN,QQSQH)
        M2GG(IME)=GGSQHN/(8.*CFFAC)
        M2GGPL(IME)=GGSQHT/(8.*CFFAC)
        M2GGMN(IME)=GGSQHU/(8.*CFFAC)
        M2QQ(IME)=QQSQH*(1.-1./CAFAC**2)/4.
C...constant factors: phi along beam and conversion GeV^2->nb.
        GACT=2.*PIFAC*GEV2NB
C...Jacobians from X1,X2 to X(5),X(6)
        GACT=GACT/S*(-LOG(TAU))*(1./(EMSQ1+EMSQ2+EMH)**2-1./ECM_MAX**2)
C...phase space Jacobians, pi's and flux.
        GACT=GACT*RQ4*RQ5/PCM/32./(2.*PIFAC)**5
     &      *(ECM-EMSQ1-EMSQ2-EMH)
C...EW and QCD couplings.
        EMSCA=EMSQ1+EMSQ2+EMH
        EMSC2=EMSCA*EMSCA
        ALPHA=HWUAEM(EMSC2)
        ALPHAS=HWUALF(1,EMSCA)
        GACT=GACT*4.*PIFAC*ALPHA/SWEIN
        GACT=GACT*16.*PIFAC**2*ALPHAS**2
C...enhancement factor for MSSM.
        JHH=JHIGGS
        IF(JHIGGS.EQ.5)JHH=4
        JSQ=JSQ1-400
        IF(JSQ1.GT.412)JSQ=JSQ1-412
        IMIX1=1
        IMIX2=1
        IF(JSQ1.GT.412)IMIX1=2
        IF(JSQ2.GT.418)IMIX2=2
        SENHNC(JSQ)=GHSQSS(JHH,JSQ,IMIX1,IMIX2)
        GACT=GACT*SENHNC(JSQ)*SENHNC(JSQ)
C...Higgs resonance.
        GACT=GACT*EMHWT
C...constant weight.
        GACT=GACT*WEIGHT
C...collects it.
        FACT(IME)=GACT
 1      CONTINUE
 2      CONTINUE
      END IF
C...set up flavours in final state.
      FLIP=0
C...set up PDFs.
      HCS=0.
      CALL HWSGEN(.FALSE.)
      IQMAX=13
      IF(MOD(IPROC,10000)-ILBL.GE.70)IQMAX=12
      IQMIN=1
      IF(MOD(IPROC,10000)-ILBL.GE.40)IQMIN=13
      IF(MOD(IPROC,10000)-ILBL.GE.70)IQMIN=1
      DO 3 JME=1,IME
      IF((M2GGPL(JME)+M2GGMN(JME)).EQ.0.)GOTO 3
      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(JME)*DIST*FACT(JME)
            IF(GENEV.AND.HCS.GT.RCS)THEN
              CONTINUE
              CALL HWHQCP(JSQ1,JSQ2,2413, 4)
              GOTO 9
            END IF
          ELSE IF(I.EQ.J+6)THEN
            HCS=HCS+M2QQ(JME)*DIST*FACT(JME)
            IF(GENEV.AND.HCS.GT.RCS)THEN
              FLIP=1
              CALL HWHQCP(JSQ2,JSQ1,3142,12)
              GOTO 9
            END IF
          END IF
        ELSE
C...set up color connections: gg-scattering.
          HCS=HCS
     &   +(M2GGPL(JME)-M2GG(JME)*M2GGPL(JME)
     &   /(M2GGPL(JME)+M2GGMN(JME))/FLOAT(NC)**2)*DIST*FACT(JME)
          IF(GENEV.AND.HCS.GT.RCS) THEN
            CALL HWHQCP(JSQ1,JSQ2,2413,27)
            GOTO 9
          ENDIF
          HCS=HCS
     &   +(M2GGMN(JME)-M2GG(JME)*M2GGMN(JME)
     &   /(M2GGPL(JME)+M2GGMN(JME))/FLOAT(NC)**2)*DIST*FACT(JME)
          IF(GENEV.AND.HCS.GT.RCS) THEN
            CALL HWHQCP(JSQ1,JSQ2,4123,28)
            GOTO 9
          ENDIF
        END IF
 200    CONTINUE
      END DO
 3    CONTINUE
      EVWGT=HCS
      RETURN
C...generate event.
    9 IDN(1)=I
      IDN(2)=J
      IDN(5)=JH
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 (s)quarks.
      COSTH=0.
      IDCMF=15
      CALL HWETWO(.TRUE.,.TRUE.)
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  RETURN
      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 'HERWIG65.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))
C--BRW fix 15/07/10 put in ident particle factor of 1/2
        FACT=GEV2NB*PIFAC*0.25*ET*EJ*(YJ1SUP-YJ1INF)*(YJ2SUP-YJ2INF)
C--end fix
     &      *(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
        ELSE
           DSTU=0
        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) THEN
        CALL HWHQCP(59,59,2134,61)
        GOTO 99
      ENDIF
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) THEN
        CALL HWHQCP(59,59,2134,62)
        GOTO 99
      ENDIF
  30  CONTINUE
C g+g ---> gamma+gamma
      ID1=13
      ID2=13
      HCS=HCS+DSTU
      IF (GENEV.AND.HCS.GT.RCS) THEN
        CALL HWHQCP(59,59,2134,63)
        GOTO 99
      ENDIF
      EVWGT=HCS
      RETURN
C Generate event
  99  IDN(1)=ID1
      IDN(2)=ID2
      IDCMF=15
      CALL HWETWO(.TRUE.,.TRUE.)
      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 'HERWIG65.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,FACT,CSTU,CTSU,CUST,DSTU
      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
        ELSE
           DSTU=0
        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) THEN
        CALL HWHQCP( 13, 59,2314,41)
        GOTO 9
      ENDIF
      ID2=13
      HCS=HCS+CTSU*FACTR*DISF(ID1,1)*DISF(ID2,2)
      IF (GENEV.AND.HCS.GT.RCS) THEN
        CALL HWHQCP(ID1, 59,3124,42)
        GOTO 9
      ENDIF
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) THEN
        CALL HWHQCP( 13, 59,3124,43)
        GOTO 9
      ENDIF
      ID2=13
      HCS=HCS+CTSU*FACTR*DISF(ID1,1)*DISF(ID2,2)
      IF (GENEV.AND.HCS.GT.RCS) THEN
        CALL HWHQCP(ID1, 59,2314,44)
        GOTO 9
      ENDIF
  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) THEN
        CALL HWHQCP(ID2, 59,2314,45)
        GOTO 9
      ENDIF
  40  ID2=ID+6
      IF (DISF(ID2,2).LT.EPS) GOTO 50
      HCS=HCS+FACTR*DISF(ID2,2)
      IF (GENEV.AND.HCS.GT.RCS) THEN
        CALL HWHQCP(ID2, 59,3124,46)
        GOTO 9
      ENDIF
  50  CONTINUE
C g+g ---> g+gamma
      ID2=13
      HCS=HCS+DSTU
      IF (GENEV.AND.HCS.GT.RCS) THEN
        CALL HWHQCP( 13, 59,2314,47)
        GOTO 9
      ENDIF
      EVWGT=HCS
      RETURN
C---GENERATE EVENT
    9 IDN(1)=ID1
      IDN(2)=ID2
      IDCMF=15
      CALL HWETWO(.TRUE.,.TRUE.)
      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 'HERWIG65.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) THEN
        CALL HWHQCP(13,ID2,1423,51)
        GOTO 99
      ENDIF
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) THEN
        CALL HWHQCP(13,ID2,1342,52)
        GOTO 99
      ENDIF
  20  EVWGT=HCS
      RETURN
C Generate event
  99  IDN(1)=ID1
      IDN(2)=ID2
      IDCMF=15
      CALL HWETWO(.TRUE.,.TRUE.)
      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 'HERWIG65.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(.TRUE.,.TRUE.)
      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
      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 'HERWIG65.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)
      SAVE MNAME,N4,SPIN0,SPIN1,C1WVFN,FPI,FETA8,FETA1,FRHO,FPHI8,FPHI1
      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.D0,3*0.093D0,3*0.107D0/
      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) THEN
           CALL HWHQCP(M1,ID4,1432,71)
           GOTO 99
         ENDIF
      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) THEN
           CALL HWHQCP(M2,ID4,1432,72)
           GOTO 99
         ENDIF
C  photon+q --> meson_T+q'
         HCS=HCS+FACTR*C3STU*FRHO2
         IF (GENEV.AND.HCS.GT.RCS) THEN
           CALL HWHQCP(M2,ID4,1432,73)
           GOTO 99
         ENDIF
      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) THEN
           CALL HWHQCP(22,ID2,1432,71)
           GOTO 99
         ENDIF
      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) THEN
           CALL HWHQCP(25,ID2,1432,71)
           GOTO 99
         ENDIF
      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) THEN
           CALL HWHQCP(56,ID2,1432,72)
           GOTO 99
         ENDIF
C  photon+q -->phi_T+q
         HCS=HCS+FACTR*C3STU*FPHI2(I2)
         IF (GENEV.AND.HCS.GT.RCS) THEN
           CALL HWHQCP(56,ID2,1432,73)
           GOTO 99
         ENDIF
      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) THEN
           CALL HWHQCP(24,ID2,1432,72)
           GOTO 99
         ENDIF
C  photon+q -->omega_T+q
         HCS=HCS+FACTR*C3STU*FOMEG2(I2)
         IF (GENEV.AND.HCS.GT.RCS) THEN
           CALL HWHQCP(24,ID2,1432,73)
           GOTO 99
         ENDIF
      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) THEN
           CALL HWHQCP(M1,ID4,1432,74)
           GOTO 99
         ENDIF
      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) THEN
           CALL HWHQCP(M2,ID4,1432,75)
           GOTO 99
         ENDIF
C  photon+qbar --> meson_T+qbar'
         HCS=HCS+FACTR*C3STU*FRHO2
         IF (GENEV.AND.HCS.GT.RCS) THEN
           CALL HWHQCP(M2,ID4,1432,76)
           GOTO 99
         ENDIF
      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) THEN
           CALL HWHQCP(22,ID2,1432,74)
           GOTO 99
         ENDIF
      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) THEN
           CALL HWHQCP(25,ID2,1432,74)
           GOTO 99
         ENDIF
      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) THEN
           CALL HWHQCP(56,ID2,1432,75)
           GOTO 99
         ENDIF
C  photon+qbar -->phi_T+qbar
         HCS=HCS+FACTR*C3STU*FPHI2(I2)
         IF (GENEV.AND.HCS.GT.RCS) THEN
           CALL HWHQCP(56,ID2,1432,76)
           GOTO 99
         ENDIF
      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) THEN
           CALL HWHQCP(24,ID2,1432,75)
           GOTO 99
         ENDIF
C  photon+qbar -->omega_T+qbar
         HCS=HCS+FACTR*C3STU*FOMEG2(I2)
         IF (GENEV.AND.HCS.GT.RCS) THEN
           CALL HWHQCP(24,ID2,1432,76)
           GOTO 99
         ENDIF
      ENDIF
  50  CONTINUE
      EVWGT=HCS
      RETURN
C Generate event
  99  IDN(1)=59
      IDN(2)=ID2
      IDCMF=15
      CALL HWETWO(.TRUE.,.TRUE.)
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
      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 'HERWIG65.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) THEN
           CALL HWHQCP( 13,ID2,1423,51)
           GOTO 99
         ENDIF
      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) THEN
           CALL HWHQCP( 13,ID2,1342,52)
           GOTO 99
         ENDIF
      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) THEN
              CALL HWHQCP(ID3,ID4,1423,53)
              GOTO 99
            ENDIF
         ENDIF
  10     CONTINUE
      ENDIF
  20  CONTINUE
      EVWGT=FACTR*HCS
      RETURN
C Generate event
  99  IDN(1)=ID1
      IDN(2)=ID2
      IDCMF=15
      CALL HWETWO(.TRUE.,.TRUE.)
      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 'HERWIG65.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) THEN
           CALL HWHQCP( 59,ID2,1432,66)
           GOTO 99
         ENDIF
      ELSE
C photon+qbar ---> photon+qbar
         HCS=HCS+CTSU*DISF(ID2,2)*QFCH(ID2-6)**4
         IF (GENEV.AND.HCS.GT.RCS) THEN
           CALL HWHQCP( 59,ID2,1432,67)
           GOTO 99
         ENDIF
      ENDIF
  20  CONTINUE
      EVWGT=FACTR*HCS
      RETURN
C Generate event
  99  IDN(1)=ID1
      IDN(2)=ID2
      IDCMF=15
      CALL HWETWO(.TRUE.,.TRUE.)
      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 'HERWIG65.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) THEN
          CALL HWWARN('HWHQCD',100)
          GOTO 999
        ENDIF
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) THEN
           CALL HWHQCP(ID1,ID2,3421, 3)
           GOTO 9
         ENDIF
        ELSE
         HCS=HCS+BSTU*DIST
         IF (GENEV.AND.HCS.GT.RCS) THEN
           CALL HWHQCP(ID1,ID2,3421, 1)
           GOTO 9
         ENDIF
         HCS=HCS+BSUT*DIST
         IF (GENEV.AND.HCS.GT.RCS) THEN
           CALL HWHQCP(ID1,ID2,4312, 2)
           GOTO 9
         ENDIF
        ENDIF
       ELSEIF (ID2.NE.13) THEN
        IF (ID2.NE.ID1+6) THEN
         HCS=HCS+ASTU*DIST
         IF (GENEV.AND.HCS.GT.RCS) THEN
           CALL HWHQCP(ID1,ID2,3142, 9)
           GOTO 9
         ENDIF
        ELSE
         HCS=HCS+FLOAT(MAXFL-1)*AUST*DIST
         IF (GENEV.AND.HCS.GT.RCS) THEN
           CALL HWHQCP(-ID1, 0,2413, 4)
           GOTO 9
         ENDIF
         HCS=HCS+BUTS*DIST
         IF (GENEV.AND.HCS.GT.RCS) THEN
           CALL HWHQCP(ID1,ID2,3142, 5)
           GOTO 9
         ENDIF
         HCS=HCS+BUST*DIST
         IF (GENEV.AND.HCS.GT.RCS) THEN
           CALL HWHQCP(ID1,ID2,2413, 6)
           GOTO 9
         ENDIF
         HCS=HCS+CSTU*DIST
         IF (GENEV.AND.HCS.GT.RCS) THEN
           CALL HWHQCP( 13, 13,2413, 7)
           GOTO 9
         ENDIF
         HCS=HCS+CSUT*DIST
         IF (GENEV.AND.HCS.GT.RCS) THEN
           CALL HWHQCP( 13, 13,2341, 8)
           GOTO 9
         ENDIF
        ENDIF
       ELSE
         HCS=HCS+CTSU*DIST
         IF (GENEV.AND.HCS.GT.RCS) THEN
           CALL HWHQCP(ID1,ID2,3142,10)
           GOTO 9
         ENDIF
         HCS=HCS+CTUS*DIST
         IF (GENEV.AND.HCS.GT.RCS) THEN
           CALL HWHQCP(ID1,ID2,3421,11)
           GOTO 9
         ENDIF
       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) THEN
           CALL HWHQCP(ID1,ID2,2413,17)
           GOTO 9
         ENDIF
        ELSE
         HCS=HCS+FLOAT(MAXFL-1)*AUST*DIST
         IF (GENEV.AND.HCS.GT.RCS) THEN
           CALL HWHQCP(-ID1, 0,3142,12)
           GOTO 9
         ENDIF
         HCS=HCS+BUTS*DIST
         IF (GENEV.AND.HCS.GT.RCS) THEN
           CALL HWHQCP(ID1,ID2,2413,13)
           GOTO 9
         ENDIF
         HCS=HCS+BUST*DIST
         IF (GENEV.AND.HCS.GT.RCS) THEN
           CALL HWHQCP(ID1,ID2,3142,14)
           GOTO 9
         ENDIF
         HCS=HCS+CSTU*DIST
         IF (GENEV.AND.HCS.GT.RCS) THEN
           CALL HWHQCP( 13, 13,3142,15)
           GOTO 9
         ENDIF
         HCS=HCS+CSUT*DIST
         IF (GENEV.AND.HCS.GT.RCS) THEN
           CALL HWHQCP( 13, 13,4123,16)
           GOTO 9
         ENDIF
        ENDIF
       ELSEIF (ID2.NE.13) THEN
        IF (ID1.NE.ID2) THEN
         HCS=HCS+ASTU*DIST
         IF (GENEV.AND.HCS.GT.RCS) THEN
           CALL HWHQCP(ID1,ID2,4312,20)
           GOTO 9
         ENDIF
        ELSE
         HCS=HCS+BSTU*DIST
         IF (GENEV.AND.HCS.GT.RCS) THEN
           CALL HWHQCP(ID1,ID2,4312,18)
           GOTO 9
         ENDIF
         HCS=HCS+BSUT*DIST
         IF (GENEV.AND.HCS.GT.RCS) THEN
           CALL HWHQCP(ID1,ID2,3421,19)
           GOTO 9
         ENDIF
        ENDIF
       ELSE
         HCS=HCS+CTSU*DIST
         IF (GENEV.AND.HCS.GT.RCS) THEN
           CALL HWHQCP(ID1,ID2,2413,21)
           GOTO 9
         ENDIF
         HCS=HCS+CTUS*DIST
         IF (GENEV.AND.HCS.GT.RCS) THEN
           CALL HWHQCP(ID1,ID2,4312,22)
           GOTO 9
         ENDIF
       ENDIF
      ELSE
C---GLUON FIRST
       IF (ID2.LT.7) THEN
         HCS=HCS+CTSU*DIST
         IF (GENEV.AND.HCS.GT.RCS) THEN
           CALL HWHQCP(ID1,ID2,2413,23)
           GOTO 9
         ENDIF
         HCS=HCS+CTUS*DIST
         IF (GENEV.AND.HCS.GT.RCS) THEN
           CALL HWHQCP(ID1,ID2,3421,24)
           GOTO 9
         ENDIF
       ELSEIF (ID2.LT.13) THEN
         HCS=HCS+CTSU*DIST
         IF (GENEV.AND.HCS.GT.RCS) THEN
           CALL HWHQCP(ID1,ID2,3142,25)
           GOTO 9
         ENDIF
         HCS=HCS+CTUS*DIST
         IF (GENEV.AND.HCS.GT.RCS) THEN
           CALL HWHQCP(ID1,ID2,4312,26)
           GOTO 9
         ENDIF
       ELSE
         HCS=HCS+GFLA*CSTU*DIST
         IF (GENEV.AND.HCS.GT.RCS) THEN
           CALL HWHQCP(  0,  0,2413,27)
           GOTO 9
         ENDIF
         HCS=HCS+GFLA*CSUT*DIST
         IF (GENEV.AND.HCS.GT.RCS) THEN
           CALL HWHQCP(  0,  0,4123,28)
           GOTO 9
         ENDIF
         HCS=HCS+DTSU*DIST
         IF (GENEV.AND.HCS.GT.RCS) THEN
           CALL HWHQCP(ID1,ID2,2341,29)
           GOTO 9
         ENDIF
         HCS=HCS+DSTU*DIST
         IF (GENEV.AND.HCS.GT.RCS) THEN
           CALL HWHQCP(ID1,ID2,3421,30)
           GOTO 9
         ENDIF
        HCS=HCS+DUTS*DIST
         IF (GENEV.AND.HCS.GT.RCS) THEN
           CALL HWHQCP(ID1,ID2,2413,31)
           GOTO 9
         ENDIF
       ENDIF
      ENDIF
    5 CONTINUE
    6 CONTINUE
      EVWGT=HCS
      RETURN
C---GENERATE EVENT
    9 IDN(1)=ID1
      IDN(2)=ID2
      IDCMF=15
      CALL HWETWO(.TRUE.,.TRUE.)
      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  RETURN
      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 'HERWIG65.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)
      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 'HERWIG65.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) THEN
            CALL HWHQCP(ID3,ID4,1243,61)
            GOTO 99
          ENDIF
        ENDIF
 10   CONTINUE
      EVWGT=FACTR*HCS
      RETURN
 99   IDN(1)=59
      IDN(2)=59
      IDCMF=15
      CALL HWETWO(.TRUE.,.TRUE.)
      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 'HERWIG65.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
      SAVE CONECT
      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)
          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
      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) THEN
                  CALL HWHRSS(1,I,J,K,L,0,0)
                  GOTO 100
                ENDIF
                HCS = HCS+ME(GN,I1,J1,K1,L1)*DISF(J,1)*DISF(I,2)
                IF(HCS.GT.RCS.AND.GENEV) THEN
                  CALL HWHRSS(2,J,I,K,L,0,0)
                  GOTO 100
                ENDIF
                HCS = HCS+ME(GN,I1,J1,K1,L1)*DISF(I+6,1)*DISF(J+6,2)
                IF(HCS.GT.RCS.AND.GENEV) THEN
                  CALL HWHRSS(1,I,J,K,L,1,0)
                  GOTO 100
                ENDIF
                HCS = HCS+ME(GN,I1,J1,K1,L1)*DISF(J+6,1)*DISF(I+6,2)
                IF(HCS.GT.RCS.AND.GENEV) THEN
                  CALL HWHRSS(2,J,I,K,L,1,0)
                  GOTO 100
                ENDIF
 60           CONTINUE
            ENDDO
 70       CONTINUE
        ENDDO
      ENDDO
 100  IF(GENEV) THEN
        CALL HWETWO(.TRUE.,.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,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
      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 'HERWIG65.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,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,GUU,GDD
      PARAMETER(EPS=1D-20)
      SAVE CONECT
      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
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)
          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(MOD(IPROC,10000).EQ.4100) THEN
            RAD   = .TRUE.
            NEUT  = .TRUE.
            CHAR  = .TRUE.
            HIGGS = .TRUE.
          ELSEIF(MOD(IPROC,10000).LT.4120) THEN
            SPMN = 2
            IF(MOD(IPROC,10000).NE.4110) THEN
              SPMN = MOD(IPROC,10)+1
              SPMX = SPMN
            ENDIF
            NEUT=.TRUE.
          ELSEIF(MOD(IPROC,10000).LT.4130) THEN
            IF(MOD(IPROC,10000).NE.4120) THEN
              CHARMN = MOD(IPROC,10)
              CHARMX=CHARMN
            ENDIF
            CHAR = .TRUE.
          ELSEIF(MOD(IPROC,10000).EQ.4130) THEN
            SPMX = 1
            NEUT=.TRUE.
          ELSEIF(MOD(IPROC,10000).EQ.4140) THEN
            RAD = .TRUE.
          ELSEIF(MOD(IPROC,10000).EQ.4150) THEN
            HIGGS = .TRUE.
          ELSE
            CALL HWWARN('HWHRBS',501)
          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) THEN
             CALL HWHRSS(3,I1,J1,K,GEN,0,0)
             GOTO 900
           ENDIF
           HCS=HCS+MEN(GEN,GN,I,J)*DISF(J1,1)*DISF(I1,2)
           IF(GENEV.AND.HCS.GT.RCS) THEN
             CALL HWHRSS(4,J1,I1,K,GEN,0,0)
             GOTO 900
           ENDIF
           HCS=HCS+MEN(GEN,GN,I,J)*DISF(I1+6,1)*DISF(J1+6,2)
           IF(GENEV.AND.HCS.GT.RCS) THEN
             CALL HWHRSS(3,I1,J1,K,GEN,1,0)
             GOTO 900
           ENDIF
           HCS=HCS+MEN(GEN,GN,I,J)*DISF(J1+6,1)*DISF(I1+6,2)
           IF(GENEV.AND.HCS.GT.RCS) THEN
             CALL HWHRSS(4,J1,I1,K,GEN,1,0)
             GOTO 900
           ENDIF
              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) THEN
             CALL HWHRSS(3,I1,J1,K,I2,0,0)
             GOTO 900
           ENDIF
           HCS=HCS+MEC(L,GN,I,J)*DISF(J1,1)*DISF(I1,2)
           IF(GENEV.AND.HCS.GT.RCS) THEN
             CALL HWHRSS(4,J1,I1,K,I2,0,0)
             GOTO 900
           ENDIF
           HCS=HCS+MEC(L,GN,I,J)*DISF(I1+6,1)*DISF(J1+6,2)
           IF(GENEV.AND.HCS.GT.RCS) THEN
             CALL HWHRSS(3,I1,J1,K,I2+2,1,0)
             GOTO 900
           ENDIF
           HCS=HCS+MEC(L,GN,I,J)*DISF(J1+6,1)*DISF(I1+6,2)
           IF(GENEV.AND.HCS.GT.RCS) THEN
             CALL HWHRSS(4,J1,I1,K,I2+2,1,0)
             GOTO 900
           ENDIF
 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) THEN
              CALL HWHRSS(5,I1,J1,I,I,0,0)
              GOTO 900
            ENDIF
            HCS=HCS+ME2*DISF(J1,1)*DISF(I1,2)
            IF(GENEV.AND.HCS.GT.RCS) THEN
              CALL HWHRSS(6,J1,I1,I,I,0,0)
              GOTO 900
            ENDIF
            HCS=HCS+ME2*DISF(I1+6,1)*DISF(J1+6,2)
            IF(GENEV.AND.HCS.GT.RCS) THEN
              CALL HWHRSS(5,I1,J1,I,I,1,0)
              GOTO 900
            ENDIF
            HCS=HCS+ME2*DISF(J1+6,1)*DISF(I1+6,2)
            IF(GENEV.AND.HCS.GT.RCS) THEN
              CALL HWHRSS(6,J1,I1,I,I,1,0)
              GOTO 900
            ENDIF
            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) THEN
              CALL HWHRSS(5,I1,J1,I,I,0,0)
              GOTO 900
            ENDIF
            HCS=HCS+ME2*DISF(J1,1)*DISF(I1,2)
            IF(GENEV.AND.HCS.GT.RCS) THEN
              CALL HWHRSS(6,J1,I1,I,I,0,0)
              GOTO 900
            ENDIF
            HCS=HCS+ME2*DISF(I1+6,1)*DISF(J1+6,2)
            IF(GENEV.AND.HCS.GT.RCS) THEN
              CALL HWHRSS(5,I1,J1,I,I,1,0)
              GOTO 900
            ENDIF
            HCS=HCS+ME2*DISF(J1+6,1)*DISF(I1+6,2)
            IF(GENEV.AND.HCS.GT.RCS) THEN
              CALL HWHRSS(6,J1,I1,I,I,1,0)
              GOTO 900
            ENDIF
            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) THEN
              CALL HWHRSS(7,I1,J1,L,2*I-1,0,0)
              GOTO 900
            ENDIF
            HCS=HCS+ME2*DISF(J1,1)*DISF(I1,2)
            IF(GENEV.AND.HCS.GT.RCS) THEN
              CALL HWHRSS(8,J1,I1,L,2*I-1,0,0)
              GOTO 900
            ENDIF
            IF(I2.NE.200) I2=198
            HCS=HCS+ME2*DISF(I1+6,1)*DISF(J1+6,2)
            IF(GENEV.AND.HCS.GT.RCS) THEN
              CALL HWHRSS(7,I1,J1,L,2*I-1,1,0)
              GOTO 900
            ENDIF
            HCS=HCS+ME2*DISF(J1+6,1)*DISF(I1+6,2)
            IF(GENEV.AND.HCS.GT.RCS) THEN
              CALL HWHRSS(8,J1,I1,L,2*I-1,1,0)
              GOTO 900
            ENDIF
          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) THEN
              CALL HWHRSS(7,I1,J1,L,2*I+5,0,0)
              GOTO 900
            ENDIF
            HCS=HCS+ME2*DISF(J1,1)*DISF(I1,2)
            IF(GENEV.AND.HCS.GT.RCS) THEN
              CALL HWHRSS(8,J1,I1,L,2*I+5,0,0)
              GOTO 900
            ENDIF
            HCS=HCS+ME2*DISF(I1+6,1)*DISF(J1+6,2)
            IF(GENEV.AND.HCS.GT.RCS) THEN
              CALL HWHRSS(7,I1,J1,L,2*I+5,1,0)
              GOTO 900
            ENDIF
            HCS=HCS+ME2*DISF(J1+6,1)*DISF(I1+6,2)
            IF(GENEV.AND.HCS.GT.RCS) THEN
              CALL HWHRSS(8,J1,I1,L,2*I+5,1,0)
              GOTO 900
            ENDIF
          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) THEN
              CALL HWHRSS(7,I1,J1,4,2*I+4+L,0,0)
              GOTO 900
            ENDIF
            HCS= HCS+ME2*DISF(J1,1)*DISF(I1,2)
            IF(GENEV.AND.HCS.GT.RCS) THEN
              CALL HWHRSS(8,J1,I1,4,2*I+4+L,0,0)
              GOTO 900
            ENDIF
            HCS= HCS+ME2*DISF(I1+6,1)*DISF(J1+6,2)
            IF(GENEV.AND.HCS.GT.RCS) THEN
              CALL HWHRSS(7,I1,J1,5,2*I+4+L,1,0)
              GOTO 900
            ENDIF
            HCS= HCS+ME2*DISF(J1+6,1)*DISF(I1+6,2)
            IF(GENEV.AND.HCS.GT.RCS) THEN
              CALL HWHRSS(8,J1,I1,5,2*I+4+L,1,0)
              GOTO 900
            ENDIF
          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) THEN
              CALL HWHRSS(7,I1,J1,5,2*I-2+L,0,0)
              GOTO 900
            ENDIF
            HCS=HCS+ME2*DISF(J1,1)*DISF(I1,2)
            IF(GENEV.AND.HCS.GT.RCS) THEN
              CALL HWHRSS(8,J1,I1,5,2*I-2+L,0,0)
              GOTO 900
            ENDIF
            HCS=HCS+ME2*DISF(I1+6,1)*DISF(J1+6,2)
            IF(GENEV.AND.HCS.GT.RCS) THEN
              CALL HWHRSS(7,I1,J1,4,2*I-2+L,1,0)
              GOTO 900
            ENDIF
            HCS=HCS+ME2*DISF(J1+6,1)*DISF(I1+6,2)
            IF(GENEV.AND.HCS.GT.RCS) THEN
              CALL HWHRSS(8,J1,I1,4,2*I-2+L,1,0)
              GOTO 900
            ENDIF
          ENDIF
          ENDDO
        ENDDO
      ENDDO
      ENDDO
C--calculate of the matrix elements
 900  IF(GENEV) THEN
        CALL HWETWO(.TRUE.,.TRUE.)
        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
      END
CDECK  ID>, HWHREE.
*CMZ :-        -05/04/02  15:40:41  by  Peter Richardson
*-- Author :    Peter Richardson
C-----------------------------------------------------------------------
      SUBROUTINE HWHREE
C-----------------------------------------------------------------------
C     SUSY E+E- --> SM PARTICLES VIA RPV
C     MODIFIED TO INCLUDE BEAM POLARIZATION EFFECTS BY PETER RICHARDSON
C-----------------------------------------------------------------------
      INCLUDE 'HERWIG65.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)
          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)
          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)
        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 (including beam polarization)
            MET =(ONE+COSTH)**2*DREAL(
     &              DCONJG(FSLR)*FSLR*(ONE-EPOLN(3))*(ONE+PPOLN(3))
     &             +DCONJG(FSRL)*FSRL*(ONE+EPOLN(3))*(ONE-PPOLN(3))
     &             +DCONJG(FTLR)*FTLR*(ONE-EPOLN(3))*(ONE+PPOLN(3))
     &             +DCONJG(FTRL)*FTRL*(ONE+EPOLN(3))*(ONE-PPOLN(3))
     &             +TWO*FTLR*DCONJG(FSLR)*(ONE-EPOLN(3))*(ONE+PPOLN(3))
     &             +TWO*FTRL*DCONJG(FSRL)*(ONE+EPOLN(3))*(ONE-PPOLN(3)))
     &          +(ONE-COSTH)**2*DREAL(
     &               DCONJG(FSLL)*FSLL*(ONE-EPOLN(3))*(ONE+PPOLN(3))
     &              +DCONJG(FSRR)*FSRR*(ONE+EPOLN(3))*(ONE-PPOLN(3)))
     &          +FOUR*DREAL(
     &               DCONJG(FTLL)*FTLL*(ONE+EPOLN(3))*(ONE+PPOLN(3))
     &              +DCONJG(FTRR)*FTRR*(ONE-EPOLN(3))*(ONE-PPOLN(3)))
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)
          GOTO 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(2,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  RETURN
      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 'HERWIG65.INC'
      DOUBLE PRECISION PCL(5),
     $     P1P2,P1SQ,P2SQ,S,M1SQ,M2SQ,TMP1,TMP2,A,B,C,D,PTOT(4),HWULDO
      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) THEN
            CALL HWWARN('HWHREM',100)
            GOTO 999
          ENDIF
          ITARG=IHEP
        ELSEIF (ISTHEP(IHEP).EQ.147) THEN
          IF (IBEAM.NE.0) THEN
            CALL HWWARN('HWHREM',101)
            GOTO 999
          ENDIF
          IBEAM=IHEP
        ENDIF
  10  CONTINUE
      IF (ITARG.EQ.0) THEN
        CALL HWWARN('HWHREM',102)
        GOTO 999
      ENDIF
      IF (IBEAM.EQ.0) THEN
        CALL HWWARN('HWHREM',103)
        GOTO 999
      ENDIF
C---MHS FIX TO PREVENT MOMENTUM VIOLATION DUE TO OFF-SHELL BEAM REMNANTS
C---FIND REMNANT MOMENTA AND MASSES
      P1P2=HWULDO(PHEP(1,IBEAM),PHEP(1,ITARG))
      P1SQ=HWULDO(PHEP(1,IBEAM),PHEP(1,IBEAM))
      P2SQ=HWULDO(PHEP(1,ITARG),PHEP(1,ITARG))
      S=P1SQ+2*P1P2+P2SQ
      TMP1=P1P2**2-P1SQ*P2SQ
      IF (TMP1.LE.0) THEN
        CALL HWWARN('HWHREM',104)
        GOTO 999
      ENDIF
      TMP1=SQRT(TMP1)
      M1SQ=RMASS(IDHW(IBEAM))**2
      M2SQ=RMASS(IDHW(ITARG))**2
      TMP2=(S-M1SQ-M2SQ)**2-4*M1SQ*M2SQ
      IF (TMP2.LE.0) THEN
        CALL HWWARN('HWHREM',105)
        GOTO 999
      ENDIF
      TMP2=SQRT(TMP2)
C---EXCHANGE A LITTLE MOMENTUM TO PUT THEM BOTH ON MASS-SHELL
      A=(1-(P1P2+P2SQ)/TMP1)/2
      B=(1-(P1P2+P1SQ)/TMP1)/2
      C=(S-M1SQ+M2SQ-TMP2)/(2*S)
      D=(S+M1SQ-M2SQ-TMP2)/(2*S)
      CALL HWVSUM(4,PHEP(1,IBEAM),PHEP(1,ITARG),PTOT)
      CALL HWVSCA(4,(1-A)*(1-C)+A*D,PHEP(1,IBEAM),PHEP(1,IBEAM))
      CALL HWVSCA(4,B*(1-C)+(1-B)*D,PHEP(1,ITARG),PHEP(1,ITARG))
      CALL HWVSUM(4,PHEP(1,IBEAM),PHEP(1,ITARG),PHEP(1,IBEAM))
      CALL HWVDIF(4,PTOT,PHEP(1,IBEAM),PHEP(1,ITARG))
      CALL HWUMAS(PHEP(1,IBEAM))
      CALL HWUMAS(PHEP(1,ITARG))
C---END MHS FIX
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)
          IF (IERROR.NE.0) RETURN
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  RETURN
      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 'HERWIG65.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)
      ENDIF
      END
CDECK  ID>, HWHRES.
*CMZ :-        -07/04/02  10:38:51  by  Peter Richardson
*-- Author :    Peter Richardson
C-----------------------------------------------------------------------
      SUBROUTINE HWHRES
C-----------------------------------------------------------------------
C     SUSY E+E- --> RPV SINGLE SPARTICLE PRODUCTION
C     POLARZATION EFFECTS ADDED 5/4/02 BY PETER RICHARDSON
C-----------------------------------------------------------------------
      INCLUDE 'HERWIG65.INC'
      DOUBLE PRECISION HWRGEN,HWUAEM,HWRUNI,HWUPCM,HWUMBW,HCS,RCS,FACA,
     &                 FACB,FACC,FACD,FACE,M1(4,4),M2(2,4),M3(8,2),
     &                 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),M4(10,2),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)
          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)
          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)
C--neutralino antineutrino production (including beam polarization)
              M1(L,J) = (ONE-EPOLN(3))*(ONE-PPOLN(3))*(
     &                      A(L,K)**2*S*(S-MNU2(L))*SCF(J)
     &                     +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))
     &           +U*(U-MNU2(L))*UP**2*(ONE-PPOLN(3))*
     &               (A(L,1)**2*(ONE-EPOLN(3))+B(L,1)**2*(ONE+EPOLN(3)))
     &           +T*(T-MNU2(L))*TP**2*(ONE-EPOLN(3))*
     &               (A(L,2)**2*(ONE-PPOLN(3))+B(L,2)**2*(ONE+PPOLN(3)))
C--neutralino neutrino production (including beam polarization)
              M1(L,K) = (ONE+EPOLN(3))*(ONE+PPOLN(3))*(
     &                      A(L,K)**2*S*(S-MNU2(L))*SCF(J)
     &                     +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))
     &           +U*(U-MNU2(L))*UP**2*(ONE+PPOLN(3))*
     &               (A(L,1)**2*(ONE+EPOLN(3))+B(L,1)**2*(ONE-EPOLN(3)))
     &           +T*(T-MNU2(L))*TP**2*(ONE+EPOLN(3))*
     &               (A(L,2)**2*(ONE+PPOLN(3))+B(L,2)**2*(ONE-PPOLN(3)))
C--final coefficients
              M1(L,J) = LAMDA1(RSID(J),IL,IL)**2*FACA*PF*M1(L,J)
              M1(L,K) = LAMDA1(RSID(J),IL,IL)**2*FACA*PF*M1(L,K)
            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)
C--chargino antilepton (including beam polarization)
              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))*
     &                    (ONE-EPOLN(3))*(ONE-PPOLN(3))
     &          +(MLT2(K)-U)*(MCH2(L)-U)*UP**2*(ONE-PPOLN(3))*
     &             (A(L2,1)**2*(ONE-EPOLN(3))+B(L2,1)**2*(ONE+EPOLN(3)))
     &          -TWO*S*(S-MNUT2(J))*UP*SCF(J)*A(L2,1)*(ONE-EPOLN(3))*
     &             (ONE-PPOLN(3))*(U*A(L2,K)+MLT(K)*MCH(L)*B(L2,K))
C--chargino lepton (including beam polarization)
              M2(L,J+2) = 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))*
     &                    (ONE+EPOLN(3))*(ONE+PPOLN(3))
     &          +(MLT2(K)-U)*(MCH2(L)-U)*UP**2*(ONE+PPOLN(3))*
     &             (A(L2,1)**2*(ONE+EPOLN(3))+B(L2,1)**2*(ONE-EPOLN(3)))
     &          -TWO*S*(S-MNUT2(J))*UP*SCF(J)*A(L2,1)*(ONE+EPOLN(3))*
     &             (ONE+PPOLN(3))*(U*A(L2,K)+MLT(K)*MCH(L)*B(L2,K))
C--final coefficients
              M2(L,J)  =HALF*LAMDA1(RSID(J),IL,IL)**2*FACA*PF*M2(L,J)
              M2(L,J+2)=HALF*LAMDA1(RSID(J),IL,IL)**2*FACA*PF*M2(L,J+2)
            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
            DO J=1,2
              M3(I,J) = ZERO
            ENDDO
          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
C--W slepton
                M3(2*I+J-2,1) = 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,1) = LAMDA1(RSID(I),IL,IL)**2*FACB*PF
     &             *LMIXSS(2*RSID(I)-1,1,J)**2*M3(2*I+J-2,1)
C--W- antislepton (including beam polarization)
                M3(2*I+J-2,2) = (ONE-EPOLN(3))*(ONE-PPOLN(3))*
     &                           M3(2*I+J-2,1)
C--W+ antislepton (including beam polarization)
                M3(2*I+J-2,1) = (ONE+EPOLN(3))*(ONE+PPOLN(3))*
     &                           M3(2*I+J-2,1)
              ELSE
                M3(2*I+J-2,1) = ZERO
                M3(2*I+J-2,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
C--Z sneutrino production
              M3(I+4,1) = 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,1) = LAMDA1(RSID(I),IL,IL)**2*FACC*PF*M3(I+4,1)
C--Z antisneutrino (including beam polarization)
              M3(I+4,2) = (ONE-EPOLN(3))*(ONE-PPOLN(3))*M3(I+4,1)
C--Z sneutrino     (including beam polarization)
              M3(I+4,1) = (ONE+EPOLN(3))*(ONE+PPOLN(3))*M3(I+4,1)
            ELSE
              M3(I+4,1) = ZERO
              M3(I+4,2) = ZERO
            ENDIF
          ENDDO
        ELSE
C--gamma sneutrino production (includes Jacobian 1-costh**2)
C--now includes polarization effects
          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)
              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,1)  = U*TP+T*UP+TWO*UP*TP*(MNUT2(I)-U)*(MNUT2(I)-T)
              M3(I+6,1)  = LAMDA1(RSID(I),IL,IL)**2*FACE*PF*M3(I+6,1)*
     &                   (ONE-THCOS(I)**2)*THTMIN
              M3(I+6,2) = M3(I+6,1)*(ONE-EPOLN(3))*(ONE-PPOLN(3))
              M3(I+6,1) = M3(I+6,1)*(ONE+EPOLN(3))*(ONE+PPOLN(3))
            ELSE
              M3(I+6,1) = ZERO
              M3(I+6,2) = ZERO
            ENDIF
          ENDDO
        ENDIF
C--Higgs processes
 300    IF(.NOT.HIGGS) THEN
          DO I=1,10
            DO J=1,2
              M4(I,J) = ZERO
            ENDDO
          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)
C--charged Higgs antislepton
              M4(2*I+J-2,1) = HSL(I,J)**2*S*SCF(I)*
     &                          (ONE-EPOLN(3))*(ONE-PPOLN(3))
     &                     +FOUR*LMIXSS(2*RSID(I)-1,1,J)**2*HL(4)**2
     &                          *(U*T-MSCL2(I,J)*MH2(4))/U**2*
     &                          (ONE+EPOLN(3))*(ONE-PPOLN(3))
C--charged Higgs slepton
              M4(2*I+J-2,2) = HSL(I,J)**2*S*SCF(I)*
     &                          (ONE+EPOLN(3))*(ONE+PPOLN(3))
     &                     +FOUR*LMIXSS(2*RSID(I)-1,1,J)**2*HL(4)**2
     &                          *(U*T-MSCL2(I,J)*MH2(4))/U**2*
     &                          (ONE-EPOLN(3))*(ONE+PPOLN(3))
C--final coefficients
              M4(2*I+J-2,1) = FACD*LAMDA1(RSID(I),IL,IL)**2*
     &                        M4(2*I+J-2,1)*PF
              M4(2*I+J-2,2) = FACD*LAMDA1(RSID(I),IL,IL)**2*
     &                        M4(2*I+J-2,2)*PF
            ELSE
              M4(2*I+J-2,1) = ZERO
              M4(2*I+J-2,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)
              IF(L.NE.3) THEN
C--h0, H0 antisneutrino (including beam polarization)
                M4(2*L+I+2,1) = HNU(L)**2*S*SCF(I)*
     &                         (ONE-EPOLN(3))*(ONE-PPOLN(3))
     &             +HL(L)**2*( ONE/T**2*(ONE+EPOLN(3))*(ONE-PPOLN(3))
     &                        +ONE/U**2*(ONE-EPOLN(3))*(ONE+PPOLN(3)))
     &                        *(U*T-MH2(L)*MNUT2(I))
C--h0, H0 sneutrino (including beam polarization)
                M4(2*L+I+2,2) = HNU(L)**2*S*SCF(I)*
     &                         (ONE+EPOLN(3))*(ONE+PPOLN(3))
     &             +HL(L)**2*( ONE/T**2*(ONE-EPOLN(3))*(ONE+PPOLN(3))
     &                        +ONE/U**2*(ONE+EPOLN(3))*(ONE-PPOLN(3)))
     &                        *(U*T-MH2(L)*MNUT2(I))
             ELSE
C--A0 antisneutrino (including beam polarization)
                M4(2*L+I+2,1) = (ONE-EPOLN(3))*(ONE-PPOLN(3))*(
     &              HNU(L)**2*S*SCF(I)
     &             +HL(L)**2*(ONE/T**2+ONE/U**2)*(U*T-MH2(L)*MNUT2(I)))
C--A0 sneutrino (including beam polarization)
                M4(2*L+I+2,2) = (ONE+EPOLN(3))*(ONE+PPOLN(3))*(
     &              HNU(L)**2*S*SCF(I)
     &             +HL(L)**2*(ONE/T**2+ONE/U**2)*(U*T-MH2(L)*MNUT2(I)))
             ENDIF
C--final coefficients
              M4(2*L+I+2,1) = FACD*LAMDA1(RSID(I),IL,IL)**2*
     &                        M4(2*L+I+2,1)*PF
              M4(2*L+I+2,2) = FACD*LAMDA1(RSID(I),IL,IL)**2*
     &                        M4(2*L+I+2,2)*PF
            ELSE
              M4(2*L+I+2,1) = ZERO
              M4(2*L+I+2,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.GT.2).OR.
     &            (IDHEP(1).GT.IDHEP(2).AND.J.LE.2)
          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.GT.2).OR.
     &            (IDHEP(1).GT.IDHEP(2).AND.J.LE.2)
          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,J)
          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,J)
          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,J)
            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)
          GOTO 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(2,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  RETURN
      END
CDECK  ID>, HWHRLL.
*CMZ :-        -08/04/02  09:00:27  by  Peter Richardson
*-- Author :    Peter Richardson
C-----------------------------------------------------------------------
      SUBROUTINE HWHRLL
C-----------------------------------------------------------------------
C  Subroutine for resonant sleptons to standard model particles
C  slepton mass and mass*width added to save statement to
C  avoid problems with Linux by Peter Richardson
C-----------------------------------------------------------------------
      INCLUDE 'HERWIG65.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,MSL2,
     &     MSWD
      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)
          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(MOD(IPROC,10000).EQ.4070) THEN
            GNMX = 2
          ELSEIF(MOD(IPROC,10000).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) THEN
                    CALL HWHRSS(9,I,J,K,L,0,CF)
                    GOTO 100
                  ENDIF
                  HCS = HCS+ME(GN,I1,J1,K1,L1,GR)*DISF(J,1)*DISF(I,2)
                  IF(HCS.GT.RCS.AND.GENEV) THEN
                    CALL HWHRSS(10,J,I,K,L,0,CF)
                    GOTO 100
                  ENDIF
                  HCS = HCS+ME(GN,I1,J1,K1,L1,GR)
     &                                       *DISF(I+6,1)*DISF(J-6,2)
                  IF(HCS.GT.RCS.AND.GENEV) THEN
                    CALL HWHRSS(9,I,J,K,L,1,CF)
                    GOTO 100
                  ENDIF
                  HCS = HCS+ME(GN,I1,J1,K1,L1,GR)
     &                                       *DISF(J-6,1)*DISF(I+6,2)
                  IF(HCS.GT.RCS.AND.GENEV) THEN
                    CALL HWHRSS(10,J,I,K,L,1,CF)
                    GOTO 100
                  ENDIF
                ENDDO
 70           CONTINUE
            ENDDO
 80       CONTINUE
        ENDDO
      ENDDO
 100  IF(GENEV) THEN
        CALL HWETWO(.TRUE.,.TRUE.)
      ELSE
        EVWGT = HCS
      ENDIF
      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 'HERWIG65.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)
          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(MOD(IPROC,10000).EQ.4000) THEN
            RAD   = .TRUE.
            NEUT  = .TRUE.
            CHAR  = .TRUE.
            HIGGS = .TRUE.
          ELSEIF(MOD(IPROC,10000).LT.4020) THEN
            IF(MOD(IPROC,10000).NE.4010) THEN
              NEUTMN = MOD(IPROC,10)
              NEUTMX = NEUTMN
            ENDIF
            NEUT=.TRUE.
          ELSEIF(MOD(IPROC,10000).LT.4030) THEN
            IF(MOD(IPROC,10000).NE.4020) THEN
              CHARMN = MOD(IPROC,10)
              CHARMX=CHARMN
            ENDIF
            CHAR  = .TRUE.
          ELSEIF(MOD(IPROC,10000).EQ.4040) THEN
            RAD   = .TRUE.
          ELSEIF(MOD(IPROC,10000).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) THEN
              CALL HWHRSS(11,J1,K1,I2,L,0,0)
              GOTO 500
            ENDIF
            HCS = HCS+MEN(L,GN,J,K)*DISF(K1,1)*DISF(J1,2)
            IF(GENEV.AND.HCS.GT.RCS) THEN
              CALL HWHRSS(12,K1,J1,I2,L,0,0)
              GOTO 500
            ENDIF
            HCS = HCS+MEN(L,GN,J,K)*DISF(J1+6,1)*DISF(K1-6,2)
            IF(GENEV.AND.HCS.GT.RCS) THEN
              CALL HWHRSS(11,J1,K1,I2,L,1,0)
              GOTO 500
            ENDIF
            HCS = HCS+MEN(L,GN,J,K)*DISF(K1-6,1)*DISF(J1+6,2)
            IF(GENEV.AND.HCS.GT.RCS) THEN
              CALL HWHRSS(12,K1,J1,I2,L,1,0)
              GOTO 500
            ENDIF
 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) THEN
              CALL HWHRSS(11,J1,K1,I2,P,0,0)
              GOTO 500
            ENDIF
            HCS = HCS+MEC(L,GN,J,K)*DISF(K1,1)*DISF(J1,2)
            IF(GENEV.AND.HCS.GT.RCS) THEN
              CALL HWHRSS(12,K1,J1,I2,P,0,0)
              GOTO 500
            ENDIF
            HCS = HCS+MEC(L,GN,J,K)*DISF(J1+6,1)*DISF(K1-6,2)
            IF(GENEV.AND.HCS.GT.RCS) THEN
              CALL HWHRSS(11,J1,K1,I2,P,1,0)
              GOTO 500
            ENDIF
            HCS = HCS+MEC(L,GN,J,K)*DISF(K1-6,1)*DISF(J1+6,2)
            IF(GENEV.AND.HCS.GT.RCS) THEN
              CALL HWHRSS(12,K1,J1,I2,P,1,0)
              GOTO 500
            ENDIF
 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)**2*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.0D0*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)**2*SH*(SH-MSL2(I+1))*SCF(I+1)/TH*
     &         (MW2*(TWO*MSL2(I1)-TH)+(SH-MSL2(I1))*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) THEN
           CALL HWHRSS(13,J1,K1,I,I,0,0)
           GOTO 500
         ENDIF
         HCS = HCS+ME2*DISF(K1,1)*DISF(J1,2)
         IF(GENEV.AND.HCS.GT.RCS) THEN
            CALL HWHRSS(14,K1,J1,I,I,0,0)
            GOTO 500
         ENDIF
         HCS = HCS+ME2*DISF(J1+6,1)*DISF(K1-6,2)
         IF(GENEV.AND.HCS.GT.RCS) THEN
           CALL HWHRSS(13,J1,K1,I,I,1,0)
           GOTO 500
         ENDIF
         HCS = HCS+ME2*DISF(K1-6,1)*DISF(J1+6,2)
         IF(GENEV.AND.HCS.GT.RCS) THEN
           CALL HWHRSS(14,K1,J1,I,I,1,0)
           GOTO 500
         ENDIF
         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) THEN
           CALL HWHRSS(13,J1,K1,I+4,I+4,0,0)
           GOTO 500
         ENDIF
         HCS = HCS+ME2*DISF(K1,1)*DISF(J1,2)
         IF(GENEV.AND.HCS.GT.RCS) THEN
           CALL HWHRSS(14,K1,J1,I+4,I+4,0,0)
           GOTO 500
         ENDIF
         HCS = HCS+ME2*DISF(J1+6,1)*DISF(K1-6,2)
         IF(GENEV.AND.HCS.GT.RCS) THEN
           CALL HWHRSS(13,J1,K1,I+4,I+4,1,0)
           GOTO 500
         ENDIF
         HCS = HCS+ME2*DISF(K1-6,1)*DISF(J1+6,2)
         IF(GENEV.AND.HCS.GT.RCS) THEN
           CALL HWHRSS(14,K1,J1,I+4,I+4,1,0)
           GOTO 500
         ENDIF
 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) THEN
           CALL HWHRSS(15,J1,K1,I,L,0,0)
           GOTO 500
         ENDIF
         HCS = HCS+ME2*DISF(K1,1)*DISF(J1,2)
         IF(GENEV.AND.HCS.GT.RCS) THEN
           CALL HWHRSS(16,K1,J1,I,L,0,0)
           GOTO 500
         ENDIF
         HCS = HCS+ME2*DISF(J1+6,1)*DISF(K1-6,2)
         IF(GENEV.AND.HCS.GT.RCS) THEN
           CALL HWHRSS(15,J1,K1,I,L,1,0)
           GOTO 500
         ENDIF
         HCS = HCS+ME2*DISF(K1-6,1)*DISF(J1+6,2)
         IF(GENEV.AND.HCS.GT.RCS) THEN
           CALL HWHRSS(16,K1,J1,I,L,1,0)
           GOTO 500
         ENDIF
         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) THEN
           CALL HWHRSS(15,J1,K1,9+I,4,0,0)
           GOTO 500
         ENDIF
         HCS = HCS+ME2*DISF(K1,1)*DISF(J1,2)
         IF(GENEV.AND.HCS.GT.RCS) THEN
           CALL HWHRSS(16,K1,J1,9+I,4,0,0)
           GOTO 500
         ENDIF
         HCS = HCS+ME2*DISF(J1+6,1)*DISF(K1-6,2)
         IF(GENEV.AND.HCS.GT.RCS) THEN
           CALL HWHRSS(15,J1,K1,9+I,5,1,0)
           GOTO 500
         ENDIF
         HCS = HCS+ME2*DISF(K1-6,1)*DISF(J1+6,2)
         IF(GENEV.AND.HCS.GT.RCS) THEN
           CALL HWHRSS(16,K1,J1,9+I,5,1,0)
           GOTO 500
         ENDIF
         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) THEN
           CALL HWHRSS(15,J1,K1,2*I+L,5,0,0)
           GOTO 500
         ENDIF
         HCS = HCS+ME2*DISF(K1,1)*DISF(J1,2)
         IF(GENEV.AND.HCS.GT.RCS) THEN
           CALL HWHRSS(16,K1,J1,2*I+L,5,0,0)
           GOTO 500
         ENDIF
         HCS = HCS+ME2*DISF(J1+6,1)*DISF(K1-6,2)
         IF(GENEV.AND.HCS.GT.RCS) THEN
           CALL HWHRSS(15,J1,K1,2*I+L,4,1,0)
           GOTO 500
         ENDIF
         HCS = HCS+ME2*DISF(K1-6,1)*DISF(J1+6,2)
         IF(GENEV.AND.HCS.GT.RCS) THEN
           CALL HWHRSS(16,K1,J1,2*I+L,4,1,0)
           GOTO 500
         ENDIF
         ENDDO
 490     CONTINUE
        ENDDO
       ENDDO
C--Setup to generate the event
 500  IF(GENEV) THEN
        CALL HWETWO(.TRUE.,.TRUE.)
      ELSE
        EVWGT = HCS
      ENDIF
      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 'HERWIG65.INC'
      IF(MOD(IPROC,10000).GE.4000.AND.MOD(IPROC,10000).LT.4060) THEN
C--SINGLE SPARTICLE VIA LQD
        CALL HWHRLS
      ELSEIF(MOD(IPROC,10000).GE.4060.AND.MOD(IPROC,10000).LT.4100) THEN
C--RESONANT SLEPTONS TO STANDARD MODEL VIA LQD
        CALL HWHRLL
      ELSEIF(MOD(IPROC,10000).GE.4100.AND.MOD(IPROC,10000).LT.4160) THEN
C--SINGLE SPARTICLE VIA UDD
        CALL HWHRBS
C--RESONANT SQUARKS TO STANDARD MODEL VIA UDD
      ELSEIF(MOD(IPROC,10000).EQ.4160) THEN
        CALL HWHRBB
      ELSE
C--UNKNOWN PROCESS
        CALL HWWARN('HWHRSP',500)
      ENDIF
      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 'HERWIG65.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
      SAVE NEUTD1,NEUTD2,SLEPID,SQUID ,SQUID2,SLPID2,GAGID1,GAGID2
      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)
        GOTO 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
 999  RETURN
      END
CDECK  ID>, HWHSCT.
*CMZ :-        -18/03/04  18.42.43  by  Mike Seymour
*-- Author :    Mike Seymour
C-----------------------------------------------------------------------
      SUBROUTINE HWHSCT(REPORT,FIRSTC,JMUEO,PTJIM)
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     FIRSTC IS AN INPUT FLAG THAT SAYS THAT THIS IS THE FIRST CALL
C     OF THE EVENT
C     JMUEO IS THE UNDERLYING EVENT OPTION: 1=>VETO EVENTS WITH M
C     SCATTERS ABOVE PTMIN WITH PROBABILITY 1/(M+1)
C     PTJIM IS THE MINIMUM TRANSVERSE MOMENTUM FOR ADDITIONAL SCATTERS
C-----------------------------------------------------------------------
      INCLUDE 'HERWIG65.INC'
      DOUBLE PRECISION HWRGEN,HWRGET,HWRSET,WGT,PBOOST(5),RBOOST(3,3),
     $     WJMAX,PT,PTJIM,DUMMY,HWUPCM
      INTEGER IHEP,IBM,ITG,IBMN,ITGN,IBMT,ITGT,I,REPORT,NHARD,
     $     MYRN(2),TMPRN(2),JMUEO
      LOGICAL COL,FIRSTC,TMPFLG
      INTEGER IPRTMP
      EXTERNAL HWRGEN,HWRGET,HWRSET,HWUPCM
      SAVE WJMAX,MYRN,NHARD
      DATA WJMAX,MYRN,NHARD/0,004122,7679781,0/
      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---RESET THE COUNTER FOR HARD SCATTERS ON THE FIRST CALL
      IF (FIRSTC) NHARD=0
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---PERFORM A SEARCH FOR THE MAXIMUM WEIGHT, IF IT IS NOT YET FOUND
      IF (WJMAX.EQ.0) THEN
C---USING LOCAL RANDOM NUMBER SEEDS
        DUMMY=HWRGET(TMPRN)
        DUMMY=HWRSET(MYRN)
        GENEV=.FALSE.
        DO I=1,IBSH
          CALL HWHSCU(WGT,PTJIM)
          WJMAX=MAX(WJMAX,WGT)
        ENDDO
        WRITE (6,'(A,G12.4)') ' Jimmy search for maximum weight=',WJMAX
        DUMMY=HWRGET(MYRN)
        DUMMY=HWRSET(TMPRN)
C---BECAUSE OF THE ENERGY DEPENDENCE, LEAVE LOTS OF SAFETY MARGIN
        WJMAX=WJMAX*2
      ENDIF
C---GENERATE A NEW HARD SCATTERING
 5    GENEV=.FALSE.
 10   CALL HWHSCU(WGT,PTJIM)
      IF (WGT.GT.WJMAX) THEN
        WRITE (6,'(A,G12.4/A,G12.4,A,G12.4)')
     $       ' Jimmy maximum weight exceeded!  SQRT(S)=',PHEP(5,3),
     $       ' Increasing from ',WJMAX,' to ',WGT*2
        WJMAX=WGT*2
      ENDIF
      IF (WGT.LE.WJMAX*HWRGEN(0)) GOTO 10
      GENEV=.TRUE.
      CALL HWHSCU(WGT,PTJIM)
C---IF ADDING LOW PT SCATTERS TO HIGH PT EVENTS ADD AN EXTRA VETO ON
C   SCATTERS THAT HAPPEN TO BE HIGH PT
      TMPFLG=.FALSE.
      IF (JMUEO.EQ.1) THEN
C---FIRST RECONSTRUCT THE PT THAT WAS GENERATED IN THE SCATTERING
        PT=SQRT(PHEP(1,NHEP)**2+PHEP(2,NHEP)**2)*
     $       SQRT(XX(1)*XX(2))*PHEP(5,3)
     $       /(2*HWUPCM(PHEP(5,NHEP-2),PHEP(5,NHEP-1),PHEP(5,NHEP)))
C---IF IT IS ABOVE THE TRIGGER THRESHOLD APPLY THE VETO
        IF (PT.GT.PTMIN) THEN
          IF ((NHARD+2)*HWRGEN(1).LT.1) THEN
            NHEP=IBMN-1
            GOTO 5
          ENDIF
          TMPFLG=.TRUE.
        ENDIF
      ENDIF
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
C---SAVE THE CURRENT PROCESS TYPE, AND SWITCH TO
C   QCD SCATTERING TO AVOID PROBLEMS WITH THE
C   PARTON SHOWER.
      IPRTMP=IPRO
      IPRO=15
      CALL HWBGEN
      IPRO=IPRTMP
      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) THEN
          CALL HWWARN('HWHSCT',120)
          GOTO 999
        ENDIF
 20   CONTINUE
      REPORT=0
      IF (TMPFLG) NHARD=NHARD+1
 999  RETURN
      END
CDECK  ID>, HWHSCU
*CMZ :-        -17/03/04  14.37.43  by  Mike Seymour
*-- Author :    Mike Seymour
C-----------------------------------------------------------------------
      SUBROUTINE HWHSCU(WGT,PTJIM)
C-----------------------------------------------------------------------
C     SWAP THE HARD PROCESS GENERATION PARAMETERS,
C     CALL HWHQCD, AND SWAP BACK
C     WGT IS THE OUTPUT EVENT WEIGHT
C-----------------------------------------------------------------------
      INCLUDE 'HERWIG65.INC'
      DOUBLE PRECISION WGT,PTJIM,XMIN,XMAX,XPOW,
     $     TMPXMN,TMPXMX,TMPXPW,TMPWGT
      LOGICAL FIRST
      COMMON/HWRPIN/XMIN,XMAX,XPOW,FIRST
C---STORE THE CURRENT VALUES
      TMPWGT=EVWGT
      TMPXMN=XMIN
      TMPXMX=XMAX
      TMPXPW=XPOW
C---REPLACE BY NEW ONES
      XMIN=2*PTJIM
      XMAX=2*SQRT(HALF*(EBEAM1*EBEAM2+PBEAM1*PBEAM2))
      XPOW=-4D0
C---AND ENSURE THAT HWRPOW GETS REINITIALIZED
      FIRST=.TRUE.
C---GENERATE A PHASE SPACE POINT
      CALL HWHQCD
      IF (IERROR.NE.0.OR.EVWGT.LT.0) THEN
        IERROR=0
        EVWGT=0
      ENDIF
      WGT=EVWGT
C---PUT THE OLD VALUES BACK
      EVWGT=TMPWGT
      XMIN=TMPXMN
      XMAX=TMPXMX
      XPOW=TMPXPW
C---AND AGAIN ENSURE THAT HWRPOW GETS REINITIALIZED
      FIRST=.TRUE.
C---INCLUDE GAMWT HERE
      WGT=WGT*GAMWT
      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 'HERWIG65.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) THEN
            CALL HWHQCP(ID1,ID2,3412,90)
            GOTO 30
          ENDIF
 10     CONTINUE
 20   CONTINUE
      EVWGT=HCS
      RETURN
C---GENERATE EVENT
 30   IDN(1)=ID1
      IDN(2)=ID2
      IDCMF=15
      CALL HWETWO(.TRUE.,.TRUE.)
      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 'HERWIG65.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)
      SAVE ASQ,AINU,AINS,SOLD,TOLD,QQ
      DATA ASQ,AINU,AINS,SOLD,TOLD,QQ/5*0,169*-1/
C---PHOTON=.TRUE. FOR PHOTON EXCHANGE, .FALSE. FOR MUELLER-TANG
      PHOTON=MOD(IPROC,100).GE.50
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>, HWHSPN.
*CMZ :-        -01/10/01  19.41.18  by  Peter Richardson
*-- Author :    Peter Richardson
C-----------------------------------------------------------------------
      SUBROUTINE HWHSPN
C-----------------------------------------------------------------------
C     Calculates the spin correlations for the hard process
C-----------------------------------------------------------------------
      INCLUDE 'HERWIG65.INC'
      INTEGER NDIAHD
      PARAMETER(NDIAHD=10)
      DOUBLE COMPLEX ZI,S,D,ME(2,2,2,2,NCFMAX),MED(2,2,2,2),F3(2,2,8),
     &     F4(2,2,8),F3M(2,2,8),F4M(2,2,8),FTP(2,2,8,8),FTM(2,2,8,8),
     &     FUP(2,2,8,8),FUM(2,2,8,8),FST(2,2,8)
      DOUBLE PRECISION P(5,4),A(2,NDIAHD),B(2,NDIAHD),XMASS,PLAB,
     &     PRW,PCM,MS(NDIAHD),MWD(NDIAHD),MR(NDIAHD),HWULDO,EE,
     &     PREF(5),EPS,N(3),HWVDOT,PP,PRE,SH,TH,UH,PM(5,4),DIJ(2,2),
     &     MA(4),MA2(4),PTMP(5),WGT,WGTB(NCFMAX),WGTC,HWRGEN
      INTEGER ICM,IHEP,IST,JHEP,KHEP,ID,LHEP,MHEP,IK,IL,IM,IJ,L1,L2,I,J,
     &     IDP(4+NDIAHD),DRTYPE(NDIAHD),NDIA,P1,P2,P3,P4,IFLOW(NDIAHD),
     &     ID1,ID2,III,JJJ,KKK,O(2),LLL,MMM
      DOUBLE PRECISION SW,CW,TW,E,G,RT,ORT,MW,MZ,GS,AFN(2,12,2,4),
     &     AFG(2,6,2),AFC(2,12,2,2),OIJ(2,4,2),OIJP(2,2,2),OIJPP(2,4,4),
     &     HNN(2,3,4,4),HCC(2,3,2,2),HNC(2,4,2),HFF(2,4,12),HWW(2),
     &     HZZ(2),ZAB(12,2,2),HHB(2,3),HWUAEM
      COMMON /HWSPNC/ SW,CW,TW,E,G,RT,ORT,MW,MZ,GS,AFN,AFG,AFC,OIJ,OIJP,
     &               OIJPP,HNN,HCC,HNC,HFF,HWW,HZZ,ZAB,HHB
      LOGICAL SPIN,FIRST
      EXTERNAL HWUAEM
      PARAMETER(ZI=(0.0D0,1.0D0))
      COMMON/HWHEWS/S(8,8,2),D(8,8)
      COMMON/HWSPHC/F3,F4,F3M,F4M,FTP,FTM,FUP,FUM,FST,A,B,MS,MWD,MR,MA,
     &     MA2,SH,TH,UH,IDP,DRTYPE
      COMMON/HWHEWP/XMASS(10),PLAB(5,10),PRW(5,2),PCM(5,10)
      PARAMETER(EPS=1D-20)
      EXTERNAL HWULDO,HWVDOT,HWRGEN
      SAVE PREF,DIJ,O,FIRST
      DATA PREF/1.0D0,0.0D0,0.0D0,1.0D0,0.0D0/
      DATA DIJ/1.0D0,0.0D0,0.0D0,1.0D0/
      DATA O/2,1/
      DATA FIRST/.TRUE./
      IF(IERROR.NE.0) RETURN
      IF(FIRST) THEN
        CALL HWISPC
        FIRST = .FALSE.
      ENDIF
C--search the event record for the hard process
      DO 1 IHEP=1,NHEP
      IST = ISTHEP(IHEP)
      IF(IST.EQ.110.OR.IST.EQ.120) THEN
        ICM = IHEP
        GOTO 2
      ENDIF
 1    CONTINUE
C--now decide whether or not to perform spin correlation
 2    KHEP = JDAHEP(1,ICM)
      IK   = IDHW(KHEP)
      JHEP = JDAHEP(2,ICM)
      IJ   = IDHW(JHEP)
      IF(JHEP-KHEP+1.NE.2) CALL HWWARN('HWHSPN',500)
      SPIN = .FALSE.
      DO 3 IHEP=KHEP,JHEP
        ID = IDHW(IHEP)
        IF(RSPIN(ID).EQ.0.5D0) SPIN=.TRUE.
 3    CONTINUE
      IF(.NOT.SPIN) RETURN
      IF((RSPIN(IDHW(KHEP)).EQ.ONE.AND.RSPIN(IDHW(JHEP)).EQ.ZERO).OR.
     &  (RSPIN(IDHW(KHEP)).EQ.ZERO.AND.RSPIN(IDHW(JHEP)).EQ.ONE)) RETURN
      LHEP = JMOHEP(1,ICM)
      MHEP = JMOHEP(2,ICM)
C--now identify the hard process
C--SM processes first
C--fermion-antifermion production in lepton-lepton collisions
C--or via Z/gamma in hadron-hadron collisions
      IF(IPRO.EQ.1.OR.IPRO.EQ.13) THEN
C--only need spin correlations for top and tau production
        IF((IK.EQ.  6.AND.IJ.EQ. 12).OR.(IK.EQ. 12.AND.IJ.EQ.6  ).OR.
     &     (IK.EQ.125.AND.IJ.EQ.131).OR.(IK.EQ.131.AND.IJ.EQ.125)) THEN
C--check fermion first and change order if not
          IF(IDHEP(LHEP).LT.0) THEN
            ID   = LHEP
            LHEP = MHEP
            MHEP = ID
          ENDIF
C--Id's of the incoming and outgoing fermions
          IL  = IDHW(LHEP)
          ID1 = IL-6*INT((IL-1)/6)+10*INT((IL-1)/120)
          ID2 = IK-6*INT((IK-1)/6)+10*INT((IK-1)/120)
C--couplings for the diagrams
C--first the photon exchange
          A(1,1) = -QFCH(ID1)
          A(2,1) = -QFCH(ID1)
          B(1,1) = -QFCH(ID2)
          B(2,1) = -QFCH(ID2)
          IDP(5) = 59
          DRTYPE(1) = 4
C--then the Z exchange
          A(1,2) = -RFCH(ID1)
          A(2,2) = -LFCH(ID1)
          B(1,2) = -RFCH(ID2)
          B(2,2) = -LFCH(ID2)
          IDP(6) = 200
          DRTYPE(2) = 4
C--setup the colour flow
          NDIA = 2
          NCFL(1) = 1
          SPNCFC(1,1,1) = ONE
          IFLOW(1) = 1
          IFLOW(2) = 1
        ELSE
          RETURN
        ENDIF
C--fermion-antifermion via s-channel W in hadron-hadron
      ELSEIF(IPRO.EQ.14) THEN
        IF(IK.EQ.  6.OR.IK.EQ. 12.OR.IJ.EQ.  6.OR.IJ.EQ. 12.OR.
     &     IK.EQ.125.OR.IJ.EQ.131.OR.IK.EQ.131.OR.IJ.EQ.125) THEN
C--check fermion first and reorder if not
          IF(IDHEP(LHEP).LT.0) THEN
            ID   = LHEP
            LHEP = MHEP
            MHEP = ID
          ENDIF
C--couplings for the diagram
          A(1,1) = ZERO
          A(2,1) =-ORT/SW
          B(1,1) = ZERO
          B(2,1) =-ORT/SW
          IDP(5) = 198
          DRTYPE(1) = 4
          NDIA = 1
          NCFL(1) = 1
          SPNCFC(1,1,1) = ONE
          IFLOW(1) = 1
        ELSE
          RETURN
        ENDIF
C--top quark production via QCD
      ELSEIF(IPRO.EQ.15.OR.IPRO.EQ.17) THEN
        IF((IK.EQ.6.AND.IJ.EQ.12).OR.(IK.EQ.12.AND.IJ.EQ.6)) THEN
C--check if the outgoing fermion is first and change order if not
          IF(IDHEP(KHEP).LT.0) THEN
            ID   = KHEP
            KHEP = JHEP
            JHEP = ID
          ENDIF
C--quark-quark to t tbar
          IF(IDHW(LHEP).LE.12.AND.IDHW(MHEP).LE.12) THEN
C--first check the incoming fermion is first and change order if not
            IF(IDHEP(LHEP).LT.0) THEN
              ID   = LHEP
              LHEP = MHEP
              MHEP = ID
            ENDIF
            IL   = IDHW(LHEP)
C--couplings for the diagram
            A(1,1) =-ONE
            A(2,1) =-ONE
            B(1,1) =-ONE
            B(2,1) =-ONE
            IDP(5) = 13
            DRTYPE(1) = 4
            NDIA = 1
C--setup the colour flow
            NCFL(1) = 1
            SPNCFC(1,1,1) = TWO/9.0D0
            IFLOW(1) = 1
C--gluon-gluon to t tbar
          ELSEIF(IDHW(LHEP).EQ.13.AND.IDHW(MHEP).EQ.13) THEN
C--setup the diagrams
            IDP(5) = 12
            IDP(6) = 12
            IDP(7) = 13
            IDP(8) = 13
            DRTYPE(1) = 5
            DRTYPE(2) = 6
            DRTYPE(3) = 7
            DRTYPE(4) = 7
            NDIA = 4
C--setup the colour flow
            NCFL(1) = 2
            IFLOW(1) = 1
            IFLOW(2) = 2
            IFLOW(3) = 1
            IFLOW(4) = 2
            SPNCFC(1,1,1) = 0.25D0/THREE
            SPNCFC(2,2,1) = SPNCFC(1,1,1)
            SPNCFC(1,2,1) = ONE/THREE/32.0D0
            SPNCFC(2,1,1) = ONE/THREE/32.0D0
C--incorrect initial state
          ELSE
            CALL HWWARN('HWHSPN',501)
          ENDIF
C--don't need spin correlations haven't produced top
        ELSE
          RETURN
        ENDIF
C--single top quark production in hadron collisions
      ELSEIF(IPRO.EQ.20) THEN
C--change order if b quark not first and identify incoming particles
        IF(ABS(IDHEP(LHEP)).NE.5) THEN
          ID   = LHEP
          LHEP = MHEP
          MHEP = ID
        ENDIF
        IL  = IDHEP(LHEP)
        IM  = IDHEP(MHEP)
C--change order if t quark not first
        IF(ABS(IDHEP(KHEP)).NE.6) THEN
          ID   = KHEP
          KHEP = JHEP
          JHEP = ID
        ENDIF
C--identify diagram type
C--fermion fermion
        IF(IL.GT.0.AND.IM.GT.0) THEN
          DRTYPE(1) = 17
C--fermion antifermion
        ELSEIF(IL.GT.0.AND.IM.LT.0) THEN
          DRTYPE(1) = 18
C--antifermion fermion
        ELSEIF(IL.LT.0.AND.IM.GT.0) THEN
          DRTYPE(1) = 19
C--antifermion antifermion
        ELSEIF(IL.LT.0.AND.IM.LT.0) THEN
          DRTYPE(1) = 20
C--incorrect initial state
        ELSE
          CALL HWWARN('HWHSPN',502)
        ENDIF
C--couplings
        A(1,1) = ZERO
        A(2,1) = -ORT/SW
        B(1,1) = ZERO
        B(2,1) = -ORT/SW
C--virtual particle etc
        IDP(5) = 198
        NDIA = 1
        NCFL(1) = 1
        SPNCFC(1,1,1) = ONE
        IFLOW(1) = 1
C--SUSY particle production
      ELSEIF(IPRO.EQ.7.OR.IPRO.EQ.30) THEN
        IF(MOD(IPROC,10000).GT.3030) RETURN
C--fermion-antifermion to neutralino neutralino
        IF(IK.GE.450.AND.IK.LE.453.AND.IJ.GE.450.AND.IJ.LE.453) THEN
C--first check the fermion is first and change order if not
          IF(IDHEP(LHEP).LT.0) THEN
            ID   = LHEP
            LHEP = MHEP
            MHEP = ID
          ENDIF
          IL   = IDHW(LHEP)
          IM   = IDHW(MHEP)
C--couplings of the various diagrams
          L1     = IK-449
          L2     = IJ-449
          ID     = IL-6*INT((IL-1)/6)+10*INT((IL-1)/120)
C--couplings for the Z exchange diagram
          A(1,1) = -RFCH(ID)
          A(2,1) = -LFCH(ID)
          B(2,1) = HALF*(-ZMIXSS(L1,3)*ZMIXSS(L2,3)
     &                   +ZMIXSS(L1,4)*ZMIXSS(L2,4))/SW/CW
          B(1,1) = -B(2,1)
          B(2,1) = B(2,1)*ZSGNSS(L1)*ZSGNSS(L2)
          DRTYPE(1) = 1
          IDP(5) = 200
C--couplings for the t-channel diagrams
          A(1,2) = ZERO
          A(2,2) =-RT*SLFCH(ID,L1)
          B(1,2) =-RT*SLFCH(ID,L2)
          B(2,2) = ZERO
          IDP(6) = IL-6*INT((IL-1)/6)+24*INT((IL-1)/120)+400
          A(1,3) =-RT*SRFCH(ID,L1)*ZSGNSS(L1)
          A(2,3) = ZERO
          B(1,3) = ZERO
          B(2,3) =-RT*SRFCH(ID,L2)*ZSGNSS(L2)
          IDP(7) = IL-6*INT((IL-1)/6)+24*INT((IL-1)/120)+412
          DRTYPE(2) = 2
          DRTYPE(3) = 2
C--couplings for the u-channel diagrams
          A(1,4) = ZERO
          A(2,4) =-RT*SLFCH(ID,L2)*ZSGNSS(L2)
          B(1,4) =-RT*SLFCH(ID,L1)*ZSGNSS(L1)
          B(2,4) = ZERO
          IDP(8) = IDP(6)
          A(1,5) =-RT*SRFCH(ID,L2)
          A(2,5) = ZERO
          B(1,5) = ZERO
          B(2,5) =-RT*SRFCH(ID,L1)
          IDP(9) = IDP(7)
          DRTYPE(4) = 3
          DRTYPE(5) = 3
          NDIA=5
C--setup the colour flow
          NCFL(1) = 1
          SPNCFC(1,1,1) = ONE
          IFLOW(1) = 1
          IFLOW(2) = 1
          IFLOW(3) = 1
          IFLOW(4) = 1
          IFLOW(5) = 1
C--chargino pair production
        ELSEIF(IK.GE.454.AND.IK.LE.457.AND.IJ.GE.454.AND.IJ.LE.457) THEN
C--first check the fermion is first and change order if not
          IF(IDHEP(LHEP).LT.0) THEN
            ID   = LHEP
            LHEP = MHEP
            MHEP = ID
          ENDIF
          IL   = IDHW(LHEP)
          IM   = IDHW(MHEP)
C--couplings of the various diagrams
          L1     = IK-453-2*INT((IK-454)/2)
          L2     = IJ-453-2*INT((IJ-454)/2)
          ID     = IL-6*INT((IL-1)/6)+10*INT((IL-1)/120)
C--couplings for the s-channel photon exchange
          A(1,1) = -QFCH(ID)
          A(2,1) = -QFCH(ID)
          B(1,1) = -DIJ(L1,L2)
          B(2,1) = -DIJ(L1,L2)
          IDP(5) = 59
          DRTYPE(1) = 1
C--couplings for the s-channel Z exchange
          A(1,2) = -RFCH(ID)
          A(2,2) = -LFCH(ID)
          B(1,2) =(-WMXUSS(L1,1)*WMXUSS(L2,1)
     &         -HALF*WMXUSS(L1,2)*WMXUSS(L2,2)+DIJ(L1,L2)*SWEIN)/CW/SW
          B(2,2) =WSGNSS(L1)*WSGNSS(L2)*(-WMXVSS(L1,1)*WMXVSS(L2,1)
     &         -HALF*WMXVSS(L1,2)*WMXVSS(L2,2)+DIJ(L1,L2)*SWEIN)/CW/SW
          IDP(6) = 200
          DRTYPE(2) = 1
C--couplings for the t-channel diagram
          IF(IDHEP(KHEP).GT.0.AND.MOD(IL,2).EQ.0) THEN
            A(1,3)    = ZERO
            A(2,3)    =-WMXUSS(L1,1)/SW
            B(1,3)    =-WMXUSS(L2,1)/SW
            B(2,3)    = ZERO
            DRTYPE(3) = 2
          ELSEIF(IDHEP(KHEP).LT.0.AND.MOD(IL,2).NE.0) THEN
            A(1,3)    =-WMXVSS(L1,1)*WSGNSS(L1)/SW
            A(2,3)    = ZERO
            B(1,3)    = ZERO
            B(2,3)    =-WMXVSS(L2,1)*WSGNSS(L2)/SW
            DRTYPE(3) = 2
          ELSEIF(IDHEP(KHEP).GT.0.AND.MOD(IL,2).NE.0) THEN
            A(1,3)    = ZERO
            A(2,3)    =-WMXVSS(L2,1)*WSGNSS(L2)/SW
            B(1,3)    =-WMXVSS(L1,1)*WSGNSS(L1)/SW
            B(2,3)    = ZERO
            DRTYPE(3) = 3
          ELSE
            A(1,3)    =-WMXUSS(L2,1)/SW
            A(2,3)    = ZERO
            B(1,3)    = ZERO
            B(2,3)    =-WMXUSS(L1,1)/SW
            DRTYPE(3) = 3
          ENDIF
          IDP(7) = IL-6*INT((IL-1)/6)+24*INT((IL-1)/120)+400
     &             +2*MOD(IL,2)-1
          NDIA = 3
C--setup the colour flow
          NCFL(1) = 1
          SPNCFC(1,1,1) = ONE
          IFLOW(1) = 1
          IFLOW(2) = 1
          IFLOW(3) = 1
C--chargino neutralino production
        ELSEIF((IK.GE.454.AND.IK.LE.457.AND.IJ.GE.450.AND.IJ.LE.453).OR.
     &       (IJ.GE.454.AND.IJ.LE.457.AND.IK.GE.450.AND.IK.LE.453)) THEN
C--first check the fermion is first and change order if not
          IF(IDHEP(LHEP).LT.0) THEN
            ID   = LHEP
            LHEP = MHEP
            MHEP = ID
          ENDIF
C--chargino first
          IF(IK.GT.453) THEN
C--change order of outgoing particles if negative chargino
            IF(IDHEP(KHEP).LT.0) THEN
              ID =KHEP
              KHEP=JHEP
              JHEP=ID
            ENDIF
            L1 = IK-453-2*INT((IK-454)/2)
            L2 = IJ-449
C--chargino second
          ELSE
            IF(IDHEP(JHEP).GT.0) THEN
              ID =KHEP
              KHEP=JHEP
              JHEP=ID
            ENDIF
            L1 = IJ-453-2*INT((IJ-454)/2)
            L2 = IK-449
          ENDIF
C--first the W exchange diagram
          A(1,1) = ZERO
          A(2,1) =-ORT/SW
          B(1,1) =( ORT*ZMXNSS(L2,3)*WMXUSS(L1,2)
     &         +ZMXNSS(L2,2)*WMXUSS(L1,1))/SW
          B(2,1) =WSGNSS(L1)*ZSGNSS(L2)*(-ORT*ZMXNSS(L2,4)*WMXVSS(L1,2)
     &         +ZMXNSS(L2,2)*WMXVSS(L1,1))/SW
          IDP(5) = 198
          DRTYPE(1) = 1
C--intermediate particles for the t and u channel diagrams
          IL = IDHW(LHEP)
          IM = IDHW(MHEP)
          IDP(6) = IM+394
          IDP(7) = IL+406
          IF(MOD(IL,2).EQ.0) THEN
            A(1,2) = ZERO
            A(2,2) =-WMXUSS(L1,1)/SW
            B(1,2) =-RT*SLFCH(IM-6,L2)
            B(2,2) = ZERO
            DRTYPE(2) = 2
            A(1,3) = ZERO
            A(2,3) =-RT*ZSGNSS(L2)*SLFCH(IL,L2)
            B(1,3) =-WSGNSS(L1)*WMXVSS(L1,1)/SW
            B(2,3) = ZERO
            DRTYPE(3) = 3
          ELSE
            A(1,2) = ZERO
            A(2,2) =-WSGNSS(L1)*WMXVSS(L1,1)/SW
            B(1,2) =-RT*ZSGNSS(L2)*SLFCH(IM-6,L2)
            B(2,2) = ZERO
            DRTYPE(2) = 3
            A(1,3) = ZERO
            A(2,3) =-RT*SLFCH(IL,L2)
            B(1,3) =-WMXUSS(L1,1)/SW
            B(2,3) = ZERO
            DRTYPE(3) = 2
          ENDIF
C--setup the colour flow
          NDIA = 3
          NCFL(1) = 1
          SPNCFC(1,1,1) = ONE
          IFLOW(1) = 1
          IFLOW(2) = 1
          IFLOW(3) = 1
C--neutralino gluino production
        ELSEIF((IK.EQ.449.AND.IJ.GE.450.AND.IJ.LE.453).OR.
     &         (IJ.EQ.449.AND.IK.GE.450.AND.IK.LE.453)) THEN
C--first check the fermion is first and change order if not
          IF(IDHEP(LHEP).LT.0) THEN
            ID   = LHEP
            LHEP = MHEP
            MHEP = ID
          ENDIF
C--check neutralino first and change order if not
          IF(IK.EQ.449) THEN
            L1 = IJ-449
            ID = KHEP
            KHEP = JHEP
            JHEP = ID
          ELSE
            L1 = IK-449
          ENDIF
          IL = IDHW(LHEP)
C--coupling for the diagrams
C--first t-channel squark exchange
          IDP(5) = 400+IL
          A(1,1) = ZERO
          A(2,1) =-RT*SLFCH(IL,L1)
          B(1,1) =-RT
          B(2,1) = ZERO
          DRTYPE(1) = 2
          IDP(6) = 412+IL
          A(1,2) =-RT*ZSGNSS(L1)*SRFCH(IL,L1)
          A(2,2) = ZERO
          B(1,2) = ZERO
          B(2,2) = RT
          DRTYPE(2) = 2
C--then u-channel s squark exchange
          IDP(7) = 400+IL
          A(1,3) = ZERO
          A(2,3) =-RT
          B(1,3) =-RT*ZSGNSS(L1)*SLFCH(IL,L1)
          B(2,3) = ZERO
          DRTYPE(3) = 3
          IDP(8) = 412+IL
          A(1,4) = RT
          A(2,4) = ZERO
          B(1,4) = ZERO
          B(2,4) =-RT*SRFCH(IL,L1)
          DRTYPE(4) = 3
C--colour flow information
          NDIA = 4
          NCFL(1) = 1
          IFLOW(1) = 1
          IFLOW(2) = 1
          IFLOW(3) = 1
          IFLOW(4) = 1
          SPNCFC(1,1,1) = ONE
C--chargino gluino production
        ELSEIF((IK.GE.454.AND.IK.LE.457.AND.IJ.EQ.449).OR.
     &         (IJ.GE.454.AND.IJ.LE.457.AND.IK.EQ.449)) THEN
C--first check the fermion is first and change order if not
          IF(IDHEP(LHEP).LT.0) THEN
            ID   = LHEP
            LHEP = MHEP
            MHEP = ID
          ENDIF
C--check chargino first and change order if not
          IF(IK.EQ.449) THEN
            L1 = IJ-453-2*INT((IJ-454)/2)
            ID = KHEP
            KHEP = JHEP
            JHEP = ID
          ELSE
            L1 = IK-453-2*INT((IK-454)/2)
          ENDIF
          IL = IDHW(LHEP)
          IM = IDHW(MHEP)
          IDP(5) = IM+394
          IDP(6) = IL+406
          IF(MOD(IL,2).EQ.0) THEN
            A(1,1) = ZERO
            A(2,1) =-WMXUSS(L1,1)/SW
            B(1,1) =-RT
            B(2,1) = ZERO
            DRTYPE(1) = 2
            A(1,2) = ZERO
            A(2,2) =-RT
            B(1,2) =-WSGNSS(L1)*WMXVSS(L1,1)/SW
            B(2,2) = ZERO
            DRTYPE(2) = 3
          ELSE
            A(1,1) = ZERO
            A(2,1) =-WSGNSS(L1)*WMXVSS(L1,1)/SW
            B(1,1) =-RT
            B(2,1) = ZERO
            DRTYPE(1) = 2
            A(1,2) = ZERO
            A(2,2) =-RT
            B(1,2) =-WMXUSS(L1,1)/SW
            B(2,2) = ZERO
            DRTYPE(2) = 3
          ENDIF
C--setup the colour flow
          NDIA = 2
          NCFL(1) = 1
          SPNCFC(1,1,1) = ONE
          IFLOW(1) = 1
          IFLOW(2) = 1
C--quark quark to gluino gluino
        ELSEIF(IJ.EQ.449.AND.IK.EQ.449.AND.
     &         IDHW(LHEP).LE.12.AND.IDHW(MHEP).LE.12) THEN
C--change order if antiquark first
          IF(IDHEP(LHEP).LT.0) THEN
            ID   = LHEP
            LHEP = MHEP
            MHEP = ID
          ENDIF
          IL   = IDHW(LHEP)
C--couplings of the various diagrams
          A(1,1) = ZERO
          A(2,1) =-RT
          B(1,1) =-RT
          B(2,1) = ZERO
          A(1,2) = RT
          A(2,2) = ZERO
          B(1,2) = ZERO
          B(2,2) = RT
          DO 4 I=1,2
          A(I,3) = A(I,1)
          B(I,3) = B(I,1)
          A(I,4) = A(I,2)
 4        B(I,4) = B(I,2)
          A(1,5) = ONE
          A(2,5) = ONE
          B(1,5) = ONE
          B(2,5) = ONE
          A(1,6) =-ONE
          A(2,6) =-ONE
          B(1,6) = ONE
          B(2,6) = ONE
C--intermediate particles
          IDP(5) = 400+IL
          IDP(6) = 412+IL
          IDP(7) = 400+IL
          IDP(8) = 412+IL
          IDP(9)  = 13
          IDP(10) = 13
C--types of diagram
          DRTYPE(1) = 2
          DRTYPE(2) = 2
          DRTYPE(3) = 3
          DRTYPE(4) = 3
          DRTYPE(5) = 1
          DRTYPE(6) = 1
          NDIA = 6
C--setup the colour flow
          NCFL(1) = 2
          SPNCFC(1,1,1) = 8.0D0/27.0D0
          SPNCFC(2,2,1) = 8.0D0/27.0D0
          SPNCFC(1,2,1) =-ONE/27.0D0
          SPNCFC(2,1,1) =-ONE/27.0D0
          IFLOW(1) = 1
          IFLOW(2) = 1
          IFLOW(3) = 2
          IFLOW(4) = 2
          IFLOW(5) = 1
          IFLOW(6) = 2
C--gluon gluon to gluino gluino
        ELSEIF(IDHW(LHEP).EQ.13.AND.IDHW(MHEP).EQ.13.AND.IJ.EQ.449
     &         .AND.IK.EQ.449) THEN
C--setup the diagrams
          IDP(5) = 449
          IDP(6) = 449
          IDP(7) = 13
          IDP(8) = 13
          DRTYPE(1) = 14
          DRTYPE(2) = 15
          DRTYPE(3) = 16
          DRTYPE(4) = 16
          NDIA = 4
C--setup the colour flow
          NCFL(1) = 2
          IFLOW(1) = 1
          IFLOW(2) = 2
          IFLOW(3) = 1
          IFLOW(4) = 2
          SPNCFC(1,1,1) = 9.0D0/16.0D0
          SPNCFC(2,2,1) = SPNCFC(1,1,1)
          SPNCFC(1,2,1) =-9.0D0/32.0D0
          SPNCFC(2,1,1) =-9.0D0/32.0D0
C--neutralino squark production
        ELSEIF(    (IK.GE.450.AND.IK.LE.453.AND.
     &        ((IJ.GE.401.AND.IJ.LE.406).OR.(IJ.GE.413.AND.IJ.LE.418)))
     &        .OR.(IJ.GE.450.AND.IJ.LE.453.AND.
     &        ((IK.GE.401.AND.IK.LE.406).OR.(IK.GE.413.AND.IK.LE.418))))
     &         THEN
C--change order if gluon first
          IF(IDHW(LHEP).EQ.13) THEN
            ID   = LHEP
            LHEP = MHEP
            MHEP = ID
          ENDIF
C--change order in squark first
          IF(IJ.GE.450) THEN
            ID = KHEP
            KHEP = JHEP
            JHEP = ID
            IK = IDHW(KHEP)
            IJ = IDHW(JHEP)
          ENDIF
          IL = IDHW(LHEP)
          L1 = IK-449
C--left handed (lighter) squark
          IF(IJ.LT.412) THEN
            A(1,1) =-RT*SRFCH(IL,L1)*QMIXSS(IL,2,1)
            A(2,1) =-RT*ZSGNSS(L1)*SLFCH(IL,L1)*QMIXSS(IL,1,1)
C--right handed (heavier) squark
          ELSEIF(IJ.GT.412) THEN
            A(1,1) =-RT*SRFCH(IL,L1)*QMIXSS(IL,2,2)
            A(2,1) =-RT*ZSGNSS(L1)*SLFCH(IL,L1)*QMIXSS(IL,1,2)
          ENDIF
          DO 5 I=1,2
 5        A(I,2) = A(I,1)
          IDP(5) = IJ
          IDP(6) = IL
C--colour flow info
          DRTYPE(1) = 8
          DRTYPE(2) = 10
          NDIA = 2
          NCFL(1) = 1
          SPNCFC(1,1,1) = HALF/THREE
          IFLOW(1) = 1
          IFLOW(2) = 1
C--neutralino antisquark production
        ELSEIF(    (IK.GE.450.AND.IK.LE.453.AND.
     &        ((IJ.GE.407.AND.IJ.LE.412).OR.(IJ.GE.419.AND.IJ.LE.424)))
     &        .OR.(IJ.GE.450.AND.IJ.LE.453.AND.
     &        ((IK.GE.407.AND.IK.LE.412).OR.(IK.GE.419.AND.IK.LE.424))))
     &         THEN
C--change order if gluon first
          IF(IDHW(LHEP).EQ.13) THEN
            ID   = LHEP
            LHEP = MHEP
            MHEP = ID
          ENDIF
C--change order in squark first
          IF(IJ.GE.450) THEN
            ID = KHEP
            KHEP = JHEP
            JHEP = ID
            IK = IDHW(KHEP)
            IJ = IDHW(JHEP)
          ENDIF
          IL = IDHW(LHEP)-6
          L1 = IK-449
C--left handed (lighter) squark
          IF(IJ.LE.412) THEN
            A(1,1) =-RT*ZSGNSS(L1)*SLFCH(IL,L1)*QMIXSS(IL,1,1)
            A(2,1) =-RT*SRFCH(IL,L1)*QMIXSS(IL,2,1)
C--right handed (heavier) squark
          ELSEIF(IJ.GT.412) THEN
            A(1,1) =-RT*ZSGNSS(L1)*SLFCH(IL,L1)*QMIXSS(IL,1,2)
            A(2,1) =-RT*SRFCH(IL,L1)*QMIXSS(IL,2,2)
          ENDIF
          DO 6 I=1,2
 6        A(I,2) = A(I,1)
          IDP(5) = IJ
          IDP(6) = IL
C--colour flow info
          DRTYPE(1) = 9
          DRTYPE(2) = 11
          NDIA = 2
          NCFL(1) = 1
          SPNCFC(1,1,1) = HALF/THREE
          IFLOW(1) = 1
          IFLOW(2) = 1
C--chargino squark
        ELSEIF((IK.GE.454.AND.IK.LE.457.AND.
     &         ((IJ.GE.401.AND.IJ.LE.406).OR.(IJ.GE.413.AND.IJ.LE.418)))
     &         .OR.(IJ.GE.454.AND.IJ.LE.457.AND.
     &        ((IK.GE.401.AND.IK.LE.406).OR.(IK.GE.413.AND.IK.LE.418))))
     &         THEN
C--change order if gluon first
          IF(IDHW(LHEP).EQ.13) THEN
            ID   = LHEP
            LHEP = MHEP
            MHEP = ID
          ENDIF
C--change order if squark first
          IF(IJ.GE.454) THEN
            ID = KHEP
            KHEP = JHEP
            JHEP = ID
            IK = IDHW(KHEP)
            IJ = IDHW(JHEP)
          ENDIF
          IL = IDHW(LHEP)
          L1 = IK-453-2*INT((IK-454)/2)
C--left handed (lighter) squark
          A(1,1) = ZERO
          IF(IJ.LE.412) THEN
            IF(MOD(IL,2).EQ.0) THEN
              A(2,1) = -WMXUSS(L1,1)*QMIXSS(IL-1,1,1)/SW
            ELSE
              A(2,1) = -WSGNSS(L1)*WMXVSS(L1,1)*QMIXSS(IL+1,1,1)/SW
            ENDIF
C--right handed (heavier) squark
          ELSEIF(IJ.GT.412) THEN
            IF(MOD(IL,2).EQ.0) THEN
              A(2,1) = -WMXUSS(L1,1)*QMIXSS(IL-1,1,2)/SW
            ELSE
              A(2,1) = -WSGNSS(L1)*WMXVSS(L1,1)*QMIXSS(IL+1,1,2)/SW
            ENDIF
          ENDIF
          DO 7 I=1,2
 7        A(I,2) = A(I,1)
          IDP(5) = IJ
          IDP(6) = IL
C--colour flow info
          DRTYPE(1) = 8
          DRTYPE(2) = 10
          NDIA = 2
          NCFL(1) = 1
          SPNCFC(1,1,1) = HALF/THREE
          IFLOW(1) = 1
          IFLOW(2) = 1
C--chargino antisquark
        ELSEIF((IK.GE.454.AND.IK.LE.457.AND.
     &         ((IJ.GE.407.AND.IJ.LE.412).OR.(IJ.GE.419.AND.IJ.LE.424)))
     &         .OR.(IJ.GE.454.AND.IJ.LE.457.AND.
     &        ((IK.GE.407.AND.IK.LE.412).OR.(IK.GE.419.AND.IK.LE.424))))
     &         THEN
C--change order if gluon first
          IF(IDHW(LHEP).EQ.13) THEN
            ID   = LHEP
            LHEP = MHEP
            MHEP = ID
          ENDIF
C--change order in squark first
          IF(IJ.GE.454) THEN
            ID = KHEP
            KHEP = JHEP
            JHEP = ID
            IK = IDHW(KHEP)
            IJ = IDHW(JHEP)
          ENDIF
          IL = IDHW(LHEP)-6
          L1 = IK-453-2*INT((IK-454)/2)
C--left handed (lighter) squark
          A(2,1) = ZERO
          IF(IJ.LE.412) THEN
            IF(MOD(IL,2).EQ.0) THEN
              A(1,1) = -WMXUSS(L1,1)*QMIXSS(IL-1,1,1)/SW
            ELSE
              A(1,1) = -WSGNSS(L1)*WMXVSS(L1,1)*QMIXSS(IL+1,1,1)/SW
            ENDIF
C--right handed (heavier) squark
          ELSEIF(IJ.GT.412) THEN
            IF(MOD(IL,2).EQ.0) THEN
              A(1,1) = -WMXUSS(L1,1)*QMIXSS(IL-1,1,2)/SW
            ELSE
              A(1,1) = -WMXVSS(L1,1)*QMIXSS(IL+1,1,2)/SW
            ENDIF
          ENDIF
          DO 8 I=1,2
 8        A(I,2) = A(I,1)
          IDP(5) = IJ
          IDP(6) = IL
C--colour flow info
          DRTYPE(1) = 9
          DRTYPE(2) = 11
          NDIA = 2
          NCFL(1) = 1
          SPNCFC(1,1,1) = ONE
          IFLOW(1) = 1
          IFLOW(2) = 1
C--squark gluino production
        ELSEIF((IK.EQ.449.AND.((IJ.GE.401.AND.IJ.LE.406)
     &                         .OR.(IJ.GE.413.AND.IJ.LE.418)))
     &         .OR.(IJ.GE.449.AND.((IK.GE.401.AND.IK.LE.406)
     &                         .OR.(IK.GE.413.AND.IK.LE.418)))) THEN
C--change order if gluon first
          IF(IDHW(LHEP).EQ.13) THEN
            ID   = LHEP
            LHEP = MHEP
            MHEP = ID
          ENDIF
          IL = IDHW(LHEP)
C--change order in squark first
          IF(IJ.EQ.449) THEN
            ID = KHEP
            KHEP = JHEP
            JHEP = ID
            IJ = IDHW(JHEP)
          ENDIF
          ID = INT((IJ-401)/12)+1
          IF(ID.EQ.1) THEN
            A(1,1) = ZERO
            A(2,1) =-RT
          ELSE
            A(1,1) = RT
            A(2,1) = ZERO
          ENDIF
          DO 9 I=1,2
          A(I,2) =-A(I,1)
          A(I,3) = A(I,1)
 9        A(I,4) = A(I,1)
          DRTYPE(1) = 12
          DRTYPE(2) = 12
          DRTYPE(3) = 8
          DRTYPE(4) = 10
          IDP(5) = 449
          IDP(6) = 449
          IDP(7) = IJ
          IDP(8) = IL
C--colour flows
          NDIA = 4
          NCFL(1) = 2
          IFLOW(1) = 1
          IFLOW(2) = 2
          IFLOW(3) = 1
          IFLOW(4) = 2
          SPNCFC(1,1,1) = 2.0D0/9.0D0
          SPNCFC(2,2,1) = 2.0D0/9.0D0
          SPNCFC(1,2,1) = -0.25D0/9.0D0
          SPNCFC(2,1,1) = -0.25D0/9.0D0
C--antisquark gluino production
        ELSEIF((IK.GE.449..AND.((IJ.GE.407.AND.IJ.LE.412)
     &                          .OR.(IJ.GE.419.AND.IJ.LE.424)))
     &         .OR.(IJ.GE.449.AND.((IK.GE.407.AND.IK.LE.412)
     &                          .OR.(IK.GE.419.AND.IK.LE.424)))) THEN
C--change order if gluon first
          IF(IDHW(LHEP).EQ.13) THEN
            ID   = LHEP
            LHEP = MHEP
            MHEP = ID
          ENDIF
          IL = IDHW(LHEP)
C--change order in squark first
          IF(IJ.EQ.449) THEN
            ID = KHEP
            KHEP = JHEP
            JHEP = ID
            IJ = IDHW(JHEP)
          ENDIF
          ID = INT((IJ-401)/12)+1
          IF(ID.EQ.1) THEN
            A(1,1) =-RT
            A(2,1) = ZERO
          ELSE
            A(1,1) = ZERO
            A(2,1) = RT
          ENDIF
          DO 10 I=1,2
          A(I,2) =-A(I,1)
          A(I,3) = A(I,1)
 10       A(I,4) = A(I,1)
          DRTYPE(1) = 13
          DRTYPE(2) = 13
          DRTYPE(3) = 9
          DRTYPE(4) = 11
          IDP(5) = 449
          IDP(6) = 449
          IDP(7) = IJ
          IDP(8) = IL
C--colour flows
          NDIA = 4
          NCFL(1) = 2
          IFLOW(1) = 1
          IFLOW(2) = 2
          IFLOW(3) = 1
          IFLOW(4) = 2
          SPNCFC(1,1,1) = 2.0D0/9.0D0
          SPNCFC(2,2,1) = 2.0D0/9.0D0
          SPNCFC(1,2,1) = -0.25D0/9.0D0
          SPNCFC(2,1,1) = -0.25D0/9.0D0
C--unrecognised SUSY process
        ELSE
          CALL HWWARN('HWHSPN',503)
        ENDIF
C--LLE processes
      ELSEIF(IPRO.EQ.8) THEN
C--neutralino antineutrino production
        IF(IK.GE.450.AND.IK.LE.453.AND.
     &     IJ.GE.127.AND.IJ.LE.132.AND.MOD(IJ,2).EQ.0) THEN
C--ensure lepton first
          IF(IDHEP(LHEP).LT.0) THEN
            ID = LHEP
            LHEP = MHEP
            MHEP = ID
          ENDIF
C--RPV indices
          III = (IJ-126)/2
          JJJ = (IDHW(LHEP)-119)/2
          KKK = (IDHW(MHEP)-125)/2
          L1  = IK-449
          IDP(5) = 424+2*III
          DO 11 I=1,2
          IDP(5+I) = 423+2*JJJ+(I-1)*12
 11       IDP(7+I) = 423+2*KKK+(I-1)*12
C--types of diagram
          DRTYPE(1) = 21
          DRTYPE(2) = 22
          DRTYPE(3) = 22
          DRTYPE(4) = 23
          DRTYPE(5) = 23
C--RPV couplings
          A(1,1) = ZERO
          A(2,1) = -LAMDA1(III,JJJ,KKK)
          DO 12 I=1,2
          B(1,I+1) = ZERO
          B(2,I+1) = -LMIXSS(2*JJJ-1,1,I)*LAMDA1(III,JJJ,KKK)
          A(1,I+3) = ZERO
 12       A(2,I+3) = -LMIXSS(2*KKK-1,2,I)*LAMDA1(III,JJJ,KKK)
C--MSSM couplings
          DO 13 J=1,2
          B(J,1) = AFN(O(J),2*III+6,1,L1)
          DO 13 I=1,2
          A(J,I+1) = AFN(O(J),2*JJJ+5,I,L1)
 13       B(J,I+3) = AFN(  J ,2*KKK+5,I,L1)
C--colour flows
          NDIA = 5
          NCFL(1) = 1
          DO 14 I=1,5
 14       IFLOW(I) = 1
          SPNCFC(1,1,1) = ONE
C--neutralino neutrino production
        ELSEIF(IK.GE.450.AND.IK.LE.453.AND.
     &         IJ.GE.121.AND.IJ.LE.126.AND.MOD(IJ,2).EQ.0) THEN
C--ensure lepton first
          IF(IDHEP(LHEP).LT.0) THEN
            ID = LHEP
            LHEP = MHEP
            MHEP = ID
          ENDIF
C--RPV indices
          III = (IJ-120)/2
          JJJ = (IDHW(MHEP)-125)/2
          KKK = (IDHW(LHEP)-119)/2
          L1  = IK-449
          IDP(5) = 424+2*III
          DO 15 I=1,2
          IDP(5+I) = 423+2*JJJ+(I-1)*12
 15       IDP(7+I) = 423+2*KKK+(I-1)*12
C--types of diagram
          DRTYPE(1) = 24
          DRTYPE(2) = 25
          DRTYPE(3) = 25
          DRTYPE(4) = 26
          DRTYPE(5) = 26
C--RPV couplings
          A(1,1) = -LAMDA1(III,JJJ,KKK)
          A(2,1) = ZERO
          DO 16 I=1,2
          B(1,I+1) = -LMIXSS(2*JJJ-1,1,I)*LAMDA1(III,JJJ,KKK)
          B(2,I+1) = ZERO
          A(1,I+3) = -LMIXSS(2*KKK-1,2,I)*LAMDA1(III,JJJ,KKK)
 16       A(2,I+3) = ZERO
C--MSSM couplings
          DO 17 J=1,2
          B(J,1) = AFN(  J ,2*III+6,1,L1)
          DO 17 I=1,2
          A(J,I+1) = AFN(  J ,2*JJJ+5,I,L1)
 17       B(J,I+3) = AFN(O(J),2*KKK+5,I,L1)
C--colour flows
          NDIA = 5
          NCFL(1) = 1
          DO 18 I=1,5
 18       IFLOW(I) = 1
          SPNCFC(1,1,1) = ONE
C--chargino antilepton
        ELSEIF(IK.GE.456.AND.IK.LE.457.AND.
     &         IJ.GE.127.AND.IJ.LE.132.AND.MOD(IJ,2).EQ.1) THEN
C--ensure lepton first
          IF(IDHEP(LHEP).LT.0) THEN
            ID = LHEP
            LHEP = MHEP
            MHEP = ID
          ENDIF
C--RPV indices
          III = (IJ-125)/2
          JJJ = (IDHW(LHEP)-119)/2
          KKK = (IDHW(MHEP)-125)/2
          L1 = IK-455
          IDP(5) = 2*III+424
          IDP(6) = 2*JJJ+424
C--RPV couplings
          A(1,1) = ZERO
          A(2,1) = LAMDA1(III,JJJ,KKK)
          B(1,2) = ZERO
          B(2,2) =-LAMDA1(III,JJJ,KKK)
C--MSSM couplings
          DO 19 J=1,2
          B(J,1) = AFC(O(J),2*III+6,1,L1)
 19       A(J,2) = AFC(O(J),2*JJJ+6,1,L1)
C--colour flows
          DRTYPE(1) = 21
          DRTYPE(2) = 22
          NDIA = 2
          NCFL(1) = 1
          DO 20 I=1,2
 20       IFLOW(I) = 1
          SPNCFC(1,1,1) = ONE
C--chargino lepton
        ELSEIF(IK.GE.454.AND.IK.LE.455.AND.
     &         IJ.GE.121.AND.IJ.LE.126.AND.MOD(IJ,2).EQ.1) THEN
C--ensure lepton first
          IF(IDHEP(LHEP).LT.0) THEN
            ID = LHEP
            LHEP = MHEP
            MHEP = ID
          ENDIF
C--RPV indices
          III = (IJ-119)/2
          JJJ = (IDHW(MHEP)-125)/2
          KKK = (IDHW(LHEP)-119)/2
          L1 = IK-453
          IDP(5) = 2*III+424
          IDP(6) = 2*JJJ+424
C--RPV couplings
          A(1,1) = LAMDA1(III,JJJ,KKK)
          A(2,1) = ZERO
          B(1,2) =-LAMDA1(III,JJJ,KKK)
          B(2,2) = ZERO
C--MSSM couplings
          DO 21 J=1,2
          B(J,1) = AFC(J,2*III+6,1,L1)
 21       A(J,2) = AFC(J,2*JJJ+6,1,L1)
C--colour flows
          DRTYPE(1) = 24
          DRTYPE(2) = 25
          NDIA = 2
          NCFL(1) = 1
          DO 22 I=1,2
 22       IFLOW(I) = 1
          SPNCFC(1,1,1) = ONE
C--e+e- production
        ELSEIF(IK.GE.121.AND.IK.LE.132.AND.MOD(IK,2).EQ.1.AND.
     &         IJ.GE.121.AND.IJ.LE.132.AND.MOD(IJ,2).EQ.1) THEN
C--ensure incoming lepton first
          IF(IDHEP(LHEP).LT.0) THEN
            ID = MHEP
            MHEP = LHEP
            LHEP = ID
          ENDIF
C--ensure outgoing lepton first
          IF(IDHEP(KHEP).LT.0) THEN
            ID = IK
            IK = IJ
            IJ = ID
            ID = KHEP
            KHEP = JHEP
            JHEP = ID
          ENDIF
C--only need the correlations for tau production
          IF(IK.NE.125.AND.IJ.NE.131) RETURN
C--find the RPV indices
          III = (IDHW(LHEP)-119)/2
          KKK = (IK-119)/2
          LLL = (IJ-125)/2
          NDIA = 0
          EE = SQRT(HWUAEM(SH)*FOUR*PIFAC)
C--s-channel photon and Z exchange if needed
          IF(KKK.EQ.LLL) THEN
            NDIA = 2
            ID1 = 9+2*III
            ID2 = 9+2*KKK
C--photon first
            A(1,1) = -EE*QFCH(ID1)
            A(2,1) = -EE*QFCH(ID1)
            B(1,1) = -EE*QFCH(ID2)
            B(2,1) = -EE*QFCH(ID2)
            IDP(5) = 59
            DRTYPE(1) = 4
C--then the Z exchange
            A(1,2) = -EE*RFCH(ID1)
            A(2,2) = -EE*LFCH(ID1)
            B(1,2) = -EE*RFCH(ID2)
            B(2,2) = -EE*LFCH(ID2)
            IDP(6) = 200
            DRTYPE(2) = 4
          ENDIF
          DO 23 JJJ=1,3
C--s-channel sneutrino exchange
            IF(ABS(LAMDA1(III,JJJ,III)*LAMDA1(LLL,JJJ,KKK)).GT.EPS) THEN
              NDIA = NDIA+1
              DRTYPE(NDIA) = 21
              IDP(NDIA+4) = 424+2*JJJ
              A(1,NDIA)   = LAMDA1(III,JJJ,III)
              A(2,NDIA)   = ZERO
              B(1,NDIA)   = ZERO
              B(2,NDIA)   = LAMDA1(LLL,JJJ,KKK)
            ENDIF
C--s-channel antisneutrino exchange
            IF(ABS(LAMDA1(III,JJJ,III)*LAMDA1(KKK,JJJ,LLL)).GT.EPS) THEN
              NDIA = NDIA+1
              DRTYPE(NDIA) = 21
              IDP(NDIA+4)  = 424+2*JJJ
              A(1,NDIA)    = ZERO
              A(2,NDIA)    = LAMDA1(III,JJJ,III)
              B(1,NDIA)    = LAMDA1(KKK,JJJ,LLL)
              B(2,NDIA)    = ZERO
            ENDIF
C--t-channel sneutrino exchange
            IF(ABS(LAMDA1(KKK,JJJ,III)*LAMDA1(LLL,JJJ,III)).GT.EPS) THEN
              NDIA = NDIA+1
              DRTYPE(NDIA) = 22
              IDP(NDIA+4)  = 424+2*JJJ
              A(1,NDIA)    = LAMDA1(KKK,JJJ,III)
              A(2,NDIA)    = ZERO
              B(1,NDIA)    = ZERO
              B(2,NDIA)    = LAMDA1(LLL,JJJ,III)
            ENDIF
C--t-channel antisneutrino exchange
            IF(ABS(LAMDA1(III,JJJ,KKK)*LAMDA1(III,JJJ,LLL)).GT.EPS) THEN
              NDIA = NDIA+1
              DRTYPE(NDIA) = 22
              IDP(NDIA+4)  = 424+2*JJJ
              A(1,NDIA)    = ZERO
              A(2,NDIA)    = LAMDA1(III,JJJ,KKK)
              B(1,NDIA)    = LAMDA1(III,JJJ,LLL)
              B(2,NDIA)    = ZERO
            ENDIF
 23       CONTINUE
C--setup the colour flow
          NCFL(1) = 1
          SPNCFC(1,1,1) = ONE
          DO 24 I=1,NDIA
 24       IFLOW(I) = 1
C--d dbar production
        ELSEIF(IK.LE.12.AND.IK.LE.12.AND.
     &         MOD(IJ,2).EQ.1.AND.MOD(IK,2).EQ.1) THEN
C--can't produce quark which decays before hadronization
          RETURN
C--unrecognised process
        ELSE
          CALL HWWARN('HWHSPN',504)
        ENDIF
C--LQD processes
      ELSEIF(IPRO.EQ.40) THEN
C--change outgoing order
        ID = IJ
        IJ = IK
        IK = ID
        ID = JHEP
        JHEP = KHEP
        KHEP = ID
C--neutrino neutralino production
        IF(IK.GE.450.AND.IK.LE.453.AND.MOD(IJ,2).EQ.0.AND.
     &     IDPDG(IJ).GT.0) THEN
C--change order if antiparticle first
          IF(IDHEP(LHEP).LT.0) THEN
            ID   = LHEP
            LHEP = MHEP
            MHEP = ID
          ENDIF
C--indices for RPV coupling
          III = (IJ-120)/2
          JJJ = (IDHW(MHEP)-5)/2
          KKK = (IDHW(LHEP)+1)/2
          L1  = IK - 449
          IDP(5) = 424+2*III
          DO 25 I=1,2
          IDP(5+I) = 399+2*JJJ+(I-1)*12
 25       IDP(7+I) = 399+2*KKK+(I-1)*12
C--types of diagram
          DRTYPE(1) = 24
          DRTYPE(2) = 25
          DRTYPE(3) = 25
          DRTYPE(4) = 26
          DRTYPE(5) = 26
C--RPV couplings
          A(1,1) = -LAMDA2(III,JJJ,KKK)
          A(2,1) = ZERO
          DO 26 I=1,2
          B(1,I+1) = -QMIXSS(2*JJJ-1,1,I)*LAMDA2(III,JJJ,KKK)
          B(2,I+1) = ZERO
          A(1,I+3) = -QMIXSS(2*KKK-1,2,I)*LAMDA2(III,JJJ,KKK)
 26       A(2,I+3) = ZERO
C--MSSM couplings
          DO 27 J=1,2
          B(J,1) = AFN(  J ,2*III+6,1,L1)
          DO 27 I=1,2
          A(J,I+1) = AFN(  J ,2*JJJ-1,I,L1)
 27       B(J,I+3) = AFN(O(J),2*KKK-1,I,L1)
C--colour flows
          NDIA = 5
          NCFL(1) = 1
          DO 28 I=1,5
 28       IFLOW(I) = 1
          SPNCFC(1,1,1) = ONE/THREE
C--antineutrino neutralino production
        ELSEIF(IK.GE.450.AND.IK.LE.453.AND.MOD(IJ,2).EQ.0.AND.
     &         IDPDG(IJ).LT.0) THEN
C--change order if antiparticle first
          IF(IDHEP(LHEP).LT.0) THEN
            ID   = LHEP
            LHEP = MHEP
            MHEP = ID
          ENDIF
C--indices for RPV coupling
          III = (IJ-126)/2
          JJJ = (IDHW(LHEP)+1)/2
          KKK = (IDHW(MHEP)-5)/2
          L1  = IK - 449
          IDP(5) = 424+2*III
          DO 29 I=1,2
          IDP(5+I) = 399+2*JJJ+(I-1)*12
 29       IDP(7+I) = 399+2*KKK+(I-1)*12
C--types of diagram
          DRTYPE(1) = 21
          DRTYPE(2) = 22
          DRTYPE(3) = 22
          DRTYPE(4) = 23
          DRTYPE(5) = 23
C--RPV couplings
          A(1,1) = ZERO
          A(2,1) = -LAMDA2(III,JJJ,KKK)
          DO 30 I=1,2
          B(1,I+1) = ZERO
          B(2,I+1) = -QMIXSS(2*JJJ-1,1,I)*LAMDA2(III,JJJ,KKK)
          A(1,I+3) = ZERO
 30       A(2,I+3) = -QMIXSS(2*KKK-1,2,I)*LAMDA2(III,JJJ,KKK)
C--MSSM couplings
          DO 31 J=1,2
          B(J,1) = AFN(O(J),2*III+6,1,L1)
          DO 31 I=1,2
          A(J,I+1) = AFN(O(J),2*JJJ-1,I,L1)
 31       B(J,I+3) = AFN(  J ,2*KKK-1,I,L1)
C--colour flows
          NDIA = 5
          NCFL(1) = 1
          DO 32 I=1,5
 32       IFLOW(I) = 1
          SPNCFC(1,1,1) = ONE/THREE
C--lepton neutralino production
        ELSEIF(IK.GE.450.AND.IK.LE.453.AND.MOD(IJ,2).EQ.1.AND.
     &         IDPDG(IJ).GT.0) THEN
C--change order if antiparticle first
          IF(IDHEP(LHEP).LT.0) THEN
            ID   = LHEP
            LHEP = MHEP
            MHEP = ID
          ENDIF
C--indices for RPV coupling
          III = (IJ-119)/2
          JJJ = (IDHW(MHEP)-6)/2
          KKK = (IDHW(LHEP)+1)/2
          L1  = IK - 449
          DO 33 I=1,2
          IDP(4+I) = 423+2*III+(I-1)*12
          IDP(6+I) = 400+2*JJJ+(I-1)*12
 33       IDP(8+I) = 399+2*KKK+(I-1)*12
C--types of diagram
          DRTYPE(1) = 24
          DRTYPE(2) = 24
          DRTYPE(3) = 25
          DRTYPE(4) = 25
          DRTYPE(5) = 26
          DRTYPE(6) = 26
C--RPV couplings
          DO 34 I=1,2
          A(1,I  ) = LMIXSS(2*III-1,1,I)*LAMDA2(III,JJJ,KKK)
          A(2,I  ) = 0.0D0
          B(1,I+2) = QMIXSS(2*JJJ  ,1,I)*LAMDA2(III,JJJ,KKK)
          B(2,I+2) = 0.0D0
          A(1,I+4) = QMIXSS(2*KKK-1,2,I)*LAMDA2(III,JJJ,KKK)
          A(2,I+4) = 0.0D0
C--MSSM couplings
          DO 34 J=1,2
          B(J,I  ) = AFN(  J ,2*III+5,I,L1)
          A(J,I+2) = AFN(  J ,2*JJJ  ,I,L1)
 34       B(J,I+4) = AFN(O(J),2*KKK-1,I,L1)
C--colour flows
          NDIA = 6
          NCFL(1) = 1
          DO 35 I=1,6
 35       IFLOW(I) = 1
          SPNCFC(1,1,1) = ONE/THREE
C--antilepton neutralino production
        ELSEIF(IK.GE.450.AND.IK.LE.453.AND.MOD(IJ,2).EQ.1.AND.
     &         IDPDG(IJ).LT.0) THEN
C--change order if antiparticle first
          IF(IDHEP(LHEP).LT.0) THEN
            ID   = LHEP
            LHEP = MHEP
            MHEP = ID
          ENDIF
C--indices for RPV coupling
          III = (IJ-125)/2
          JJJ = IDHW(LHEP)/2
          KKK = (IDHW(MHEP)-5)/2
          L1  = IK - 449
          DO 36 I=1,2
          IDP(4+I) = 423+2*III+(I-1)*12
          IDP(6+I) = 400+2*JJJ+(I-1)*12
 36       IDP(8+I) = 399+2*KKK+(I-1)*12
C--types of diagram
          DRTYPE(1) = 21
          DRTYPE(2) = 21
          DRTYPE(3) = 22
          DRTYPE(4) = 22
          DRTYPE(5) = 23
          DRTYPE(6) = 23
C--RPV couplings
          DO 37 I=1,2
          A(1,I  ) = 0.0D0
          A(2,I  ) = LMIXSS(2*III-1,1,I)*LAMDA2(III,JJJ,KKK)
          B(1,I+2) = 0.0D0
          B(2,I+2) = QMIXSS(2*JJJ  ,1,I)*LAMDA2(III,JJJ,KKK)
          A(1,I+4) = 0.0D0
          A(2,I+4) = QMIXSS(2*KKK-1,2,I)*LAMDA2(III,JJJ,KKK)
C--MSSM couplings
          DO 37 J=1,2
          B(J,I  ) = AFN(O(J),2*III+5,I,L1)
          A(J,I+2) = AFN(O(J),2*JJJ  ,I,L1)
 37       B(J,I+4) = AFN(  J ,2*KKK-1,I,L1)
C--colour flows
          NDIA = 6
          NCFL(1) = 1
          DO 39 I=1,6
 39       IFLOW(I) = 1
          SPNCFC(1,1,1) = ONE/THREE
C-- +ve chargino antineutrino
        ELSEIF(IK.GE.454.AND.IK.LE.455.AND.MOD(IJ,2).EQ.0) THEN
C--change order if antiparticle first
          IF(IDHEP(LHEP).LT.0) THEN
            ID   = LHEP
            LHEP = MHEP
            MHEP = ID
          ENDIF
C--indices for RPV
          III = (IJ-126)/2
          JJJ =  IDHW(LHEP)/2
          KKK = (IDHW(MHEP)-5)/2
          L1 = IK-453
          DO 40 I=1,2
          IDP(4+I) = 423+2*III+(I-1)*12
 40       IDP(6+I) = 399+2*JJJ+(I-1)*12
C--types of diagram
          DRTYPE(1) = 21
          DRTYPE(2) = 21
          DRTYPE(3) = 22
          DRTYPE(4) = 22
          DO 41 I=1,2
C--RPV couplings
          A(1,I  ) = ZERO
          A(2,I  ) = LMIXSS(2*III-1,1,I)*LAMDA2(III,JJJ,KKK)
          B(1,I+2) = ZERO
          B(2,I+2) =-QMIXSS(2*JJJ-1,1,I)*LAMDA2(III,JJJ,KKK)
C--MSSM couplings
          DO 41 J=1,2
          B(J,I  ) = AFC(O(J),2*III+5,I,L1)
 41       A(J,I+2) = AFC(O(J),2*JJJ-1,I,L1)
C--colour flows
          NDIA = 4
          NCFL(1) = 1
          DO 42 I=1,4
 42       IFLOW(I) = 1
          SPNCFC(1,1,1) = ONE/THREE
C-- -ve chargino neutrino
        ELSEIF(IK.GE.456.AND.IK.LE.457.AND.MOD(IJ,2).EQ.0) THEN
C--change order if antiparticle first
          IF(IDHEP(LHEP).LT.0) THEN
            ID   = LHEP
            LHEP = MHEP
            MHEP = ID
          ENDIF
C--indices for RPV
          III = (IJ-120)/2
          JJJ = (IDHW(MHEP)-6)/2
          KKK = (IDHW(LHEP)+1)/2
          L1 = IK-455
          DO 43 I=1,2
          IDP(4+I) = 423+2*III+(I-1)*12
 43       IDP(6+I) = 399+2*JJJ+(I-1)*12
C--types of diagram
          DRTYPE(1) = 24
          DRTYPE(2) = 24
          DRTYPE(3) = 25
          DRTYPE(4) = 25
          DO 44 I=1,2
C--RPV couplings
          A(1,I  ) = LMIXSS(2*III-1,1,I)*LAMDA2(III,JJJ,KKK)
          A(2,I  ) = ZERO
          B(1,I+2) =-QMIXSS(2*JJJ-1,1,I)*LAMDA2(III,JJJ,KKK)
          B(2,I+2) = ZERO
C--MSSM couplings
          DO 44 J=1,2
          B(J,I  ) = AFC(J,2*III+5,I,L1)
 44       A(J,I+2) = AFC(J,2*JJJ-1,I,L1)
C--colour flows
          NDIA = 4
          NCFL(1) = 1
          DO 45 I=1,4
 45       IFLOW(I) = 1
          SPNCFC(1,1,1) = ONE/THREE
C-- -ve chargino antilepton
        ELSEIF(IK.GE.456.AND.IK.LE.457.AND.MOD(IJ,2).EQ.1) THEN
C--change order if antiparticle first
          IF(IDHEP(LHEP).LT.0) THEN
            ID   = LHEP
            LHEP = MHEP
            MHEP = ID
          ENDIF
C--indices for RPV
          III = (IJ-125)/2
          JJJ = (IDHW(LHEP)+1)/2
          KKK = (IDHW(MHEP)-5)/2
          L1 = IK-455
          IDP(5) = 424+2*III
          DO 46 I=1,2
 46       IDP(5+I) = 400+2*JJJ+(I-1)*12
C--types of diagram
          DRTYPE(1) = 21
          DRTYPE(2) = 22
          DRTYPE(3) = 22
C--RPV couplings
          A(1,1) = 0.0D0
          A(2,1) =-LAMDA2(III,JJJ,KKK)
          DO 47 I=1,2
          B(1,I+1) = 0.0D0
 47       B(2,I+1) = QMIXSS(2*JJJ,1,I)*LAMDA2(III,JJJ,KKK)
C--MSSM couplings
          DO 48 J=1,2
          B(J,1) = AFC(O(J),2*III+6,1,L1)
          DO 48 I=1,2
 48       A(J,I+1) = AFC(O(J),2*JJJ,I,L1)
C--colour flows
          NDIA = 3
          NCFL(1) = 1
          DO 49 I=1,3
 49       IFLOW(I) = 1
          SPNCFC(1,1,1) = ONE/THREE
C-- +ve chargino lepton
        ELSEIF(IK.GE.454.AND.IK.LE.455.AND.MOD(IJ,2).EQ.1) THEN
C--change order if antiparticle first
          IF(IDHEP(LHEP).LT.0) THEN
            ID   = LHEP
            LHEP = MHEP
            MHEP = ID
          ENDIF
C--indices for RPV
          III = (IJ-119)/2
          JJJ = (IDHW(MHEP)-5)/2
          KKK = (IDHW(LHEP)+1)/2
          L1 = IK-453
          IDP(5) = 424+2*III
          DO 50 I=1,2
 50       IDP(5+I) = 400+2*JJJ+(I-1)*12
C--types of diagram
          DRTYPE(1) = 24
          DRTYPE(2) = 25
          DRTYPE(3) = 25
C--RPV couplings
          A(1,1) =-LAMDA2(III,JJJ,KKK)
          A(2,1) = 0.0D0
          DO 51 I=1,2
          B(1,I+1) = QMIXSS(2*JJJ,1,I)*LAMDA2(III,JJJ,KKK)
 51       B(2,I+1) = 0.0D0
C--MSSM couplings
          DO 52 J=1,2
          B(J,1) = AFC(J,2*III+6,1,L1)
          DO 52 I=1,2
 52       A(J,I+1) = AFC(J,2*JJJ,I,L1)
C--colour flows
          NDIA = 3
          NCFL(1) = 1
          DO 53 I=1,3
 53       IFLOW(I) = 1
          SPNCFC(1,1,1) = ONE/THREE
C--d dbar d dbar
        ELSEIF(IK.LE.12.AND.IJ.LE.12.AND.
     &         MOD(IJ,2).EQ.1.AND.MOD(IK,2).EQ.1) THEN
C--can't produce unstable quark (on hadronization timescale)
          RETURN
C--u    dbar --> u    dbar
        ELSEIF((IJ.LE. 6.AND.MOD(IJ,2).EQ.0.AND.
     &          IK.LE.12.AND.MOD(IK,2).EQ.1).OR.
     &         (IK.LE.6 .AND.MOD(IK,2).EQ.0.AND.
     &          IJ.LE.12.AND.MOD(IJ,2).EQ.1)) THEN
C--ensure u first (incoming)
          IF(MOD(IDHW(LHEP),2).EQ.1) THEN
            ID   = MHEP
            MHEP = LHEP
            LHEP = ID
          ENDIF
C--ensure u first (outgoing)
          IF(MOD(IK,2).EQ.1) THEN
            ID = IJ
            IJ = IK
            IK = ID
            ID = JHEP
            JHEP = KHEP
            KHEP = ID
          ENDIF
C--can't produce unstable quark (on hadronization timescale)
          IF(IK.NE.6) RETURN
C--RPV indices
          JJJ = IDHW(LHEP)/2
          KKK = (IDHW(MHEP)-5)/2
          LLL = IK/2
          MMM = (IJ-5)/2
          NDIA = 0
          DO 54 III=1,3
          IF(ABS(LAMDA2(III,JJJ,KKK)*LAMDA2(III,LLL,MMM)).LT.EPS)
     &            GOTO 54
          DO 55 J=1,2
          IFLOW(NDIA+J) = 1
          IDP(4+NDIA+J) = 423+2*III+12*(J-1)
          A(1,NDIA+J) = ZERO
          A(2,NDIA+J) = LAMDA2(III,JJJ,KKK)*LMIXSS(2*III-1,1,J)
          B(1,NDIA+J) = LAMDA2(III,LLL,MMM)*LMIXSS(2*III-1,1,J)
          B(2,NDIA+J) = ZERO
 55       DRTYPE(NDIA+J) = 21
          NDIA = NDIA+2
 54       CONTINUE
          NCFL(1) = 1
          SPNCFC(1,1,1) = ONE
C--ubar d    --> ubar d
        ELSEIF((IJ.LE.12.AND.MOD(IJ,2).EQ.0.AND.
     &          IK.LE. 6.AND.MOD(IK,2).EQ.1).OR.
     &         (IK.LE.12.AND.MOD(IK,2).EQ.0.AND.
     &          IJ.LE. 6.AND.MOD(IJ,2).EQ.1)) THEN
C--ensure d first (incoming)
          IF(MOD(IDHW(LHEP),2).EQ.0) THEN
            ID   = MHEP
            MHEP = LHEP
            LHEP = ID
          ENDIF
C--ensure d first (outgoing)
          IF(MOD(IK,2).EQ.0) THEN
            ID = IJ
            IJ = IK
            IK = ID
            ID = JHEP
            JHEP = KHEP
            KHEP = ID
          ENDIF
C--can't produce unstable quark (on hadronization timescale)
          IF(IJ.NE.12) RETURN
C--RPV indices
          JJJ = (IDHW(MHEP)-6)/2
          KKK = (IDHW(LHEP)+1)/2
          LLL = (IJ-6)/2
          MMM = (IK+1)/2
          NDIA = 0
          DO 56 III=1,3
          IF(ABS(LAMDA2(III,JJJ,KKK)*LAMDA2(III,LLL,MMM)).LT.EPS)
     &             GOTO 56
          DO 57 J=1,2
          IFLOW(NDIA+J) = 1
          IDP(4+NDIA+J) = 423+2*III+12*(J-1)
          A(1,NDIA+J) = LAMDA2(III,JJJ,KKK)*LMIXSS(2*III-1,1,J)
          A(2,NDIA+J) = ZERO
          B(1,NDIA+J) = ZERO
          B(2,NDIA+J) = LAMDA2(III,LLL,MMM)*LMIXSS(2*III-1,1,J)
 57       DRTYPE(NDIA+J) = 21
          NDIA = NDIA+2
 56       CONTINUE
          NCFL(1) = 1
          SPNCFC(1,1,1) = ONE
C--d dbar --> ell- ell+
        ELSEIF(IDHW(LHEP).LE.12.AND.MOD(IDHW(LHEP),2).EQ.1.AND.
     &         IDHW(MHEP).LE.12.AND.MOD(IDHW(MHEP),2).EQ.1.AND.
     &         IK.GE.127.AND.IK.LE.132.AND.MOD(IK,2).EQ.1.AND.
     &         IJ.GE.121.AND.IJ.LE.126.AND.MOD(IJ,2).EQ.1) THEN
C--change outgoing order
          ID = IK
          IK = IJ
          IJ = ID
          ID = JHEP
          JHEP = KHEP
          KHEP = ID
C--change order if dbar first
          IF(IDHEP(LHEP).LT.0) THEN
            ID = LHEP
            LHEP = MHEP
            MHEP = ID
          ENDIF
C--don't do correlations if no taus
          IF(IK.NE.125.AND.IJ.NE.131) RETURN
C--RPV couplings
          JJJ = (IDHW(LHEP)+1)/2
          KKK = (IDHW(MHEP)-5)/2
          LLL = (IK-119)/2
          MMM = (IJ-125)/2
          NDIA = 0
          DO 58 III=1,3
          IF(ABS(LAMDA2(III,JJJ,KKK)*LAMDA1(III,LLL,MMM)).LT.EPS)
     &             GOTO 58
          NDIA = NDIA+1
          IFLOW(NDIA) = 1
          IDP(4+NDIA) = 424+2*III
          A(1,NDIA) = ZERO
          A(2,NDIA) = LAMDA2(III,JJJ,KKK)
          B(1,NDIA) = LAMDA1(III,LLL,MMM)
          B(2,NDIA) = ZERO
          DRTYPE(NDIA) = 21
 58       CONTINUE
          NCFL(1) = 1
          SPNCFC(1,1,1) = ONE/THREE
C--dbar d --> ell+ ell-
        ELSEIF(IDHW(LHEP).LE.12.AND.MOD(IDHW(LHEP),2).EQ.1.AND.
     &         IDHW(MHEP).LE.12.AND.MOD(IDHW(MHEP),2).EQ.1.AND.
     &         IK.GE.121.AND.IK.LE.126.AND.MOD(IK,2).EQ.1.AND.
     &         IJ.GE.127.AND.IJ.LE.132.AND.MOD(IJ,2).EQ.1) THEN
C--change order if dbar first
          IF(IDHEP(LHEP).LT.0) THEN
            ID = LHEP
            LHEP = MHEP
            MHEP = ID
          ENDIF
C--don't do correlations if no taus
          IF(IK.NE.125.AND.IJ.NE.131) RETURN
C--RPV couplings
          JJJ = (IDHW(MHEP)-5)/2
          KKK = (IDHW(LHEP)+1)/2
          LLL = (IJ-125)/2
          MMM = (IK-119)/2
          NDIA = 0
          DO 59 III=1,3
          IF(ABS(LAMDA2(III,JJJ,KKK)*LAMDA1(III,LLL,MMM)).LT.EPS)
     &             GOTO 59
          NDIA = NDIA+1
          IFLOW(NDIA) = 1
          IDP(4+NDIA) = 424+2*III
          A(1,NDIA) = LAMDA2(III,JJJ,KKK)
          A(2,NDIA) = ZERO
          B(1,NDIA) = ZERO
          B(2,NDIA) = LAMDA1(III,LLL,MMM)
          DRTYPE(NDIA) = 21
 59       CONTINUE
          NCFL(1) = 1
          SPNCFC(1,1,1) = ONE/THREE
C--u dbar --> nu ell+
        ELSEIF((IK.GE.121.AND.IK.LE.126.AND.MOD(IK,2).EQ.0.AND.
     &          IJ.GE.127.AND.IJ.LE.132.AND.MOD(IJ,2).EQ.1).OR.
     &         (IK.GE.127.AND.IK.LE.132.AND.MOD(IK,2).EQ.1.AND.
     &          IJ.GE.121.AND.IJ.LE.126.AND.MOD(IJ,2).EQ.0)) THEN
C--ensure u first
          IF(MOD(IDHW(LHEP),2).NE.0) THEN
            ID = LHEP
            LHEP = MHEP
            MHEP = ID
          ENDIF
C--ensure nu first
          IF(MOD(IK,2).NE.0) THEN
            ID = IK
            IK = IJ
            IJ = ID
            ID = JHEP
            JHEP = KHEP
            KHEP = ID
          ENDIF
C--only need correlations if tau
          IF(IJ.NE.131) RETURN
C--RPV couplings
          JJJ = IDHW(LHEP)/2
          KKK = (IDHW(MHEP)-5)/2
          LLL = (IK-120)/2
          MMM = (IJ-125)/2
          NDIA = 0
          DO 60 III=1,3
          IF(ABS(LAMDA2(III,JJJ,KKK)*LAMDA1(III,LLL,MMM)).LT.EPS)
     &             GOTO 60
          DO 61 J=1,2
          IFLOW(NDIA+J) = 1
          IDP(4+NDIA+J) = 423+2*III+12*(J-1)
          A(1,NDIA+J) = ZERO
          A(2,NDIA+J) = LAMDA2(III,JJJ,KKK)*LMIXSS(2*III-1,1,J)
          B(1,NDIA+J) = LAMDA1(III,LLL,MMM)*LMIXSS(2*III-1,1,J)
          B(2,NDIA+J) = ZERO
 61       DRTYPE(NDIA+J) = 21
          NDIA = NDIA+2
 60       CONTINUE
          NCFL(1) = 1
          SPNCFC(1,1,1) = ONE/THREE
C--ubar d --> ell nubar
        ELSEIF((IK.GE.127.AND.IK.LE.132.AND.MOD(IK,2).EQ.0.AND.
     &          IJ.GE.121.AND.IJ.LE.126.AND.MOD(IJ,2).EQ.1).OR.
     &         (IK.GE.121.AND.IK.LE.126.AND.MOD(IK,2).EQ.1.AND.
     &          IJ.GE.127.AND.IJ.LE.132.AND.MOD(IJ,2).EQ.0)) THEN
C--ensure u second
          IF(MOD(IDHW(MHEP),2).NE.0) THEN
            ID = LHEP
            LHEP = MHEP
            MHEP = ID
          ENDIF
C--   ensure nu second
          IF(MOD(IJ,2).NE.0) THEN
            ID = IK
            IK = IJ
            IJ = ID
            ID = JHEP
            JHEP = KHEP
            KHEP = ID
          ENDIF
C--only need correlations if tau
          IF(IK.NE.125) RETURN
C--RPV couplings
          JJJ = (IDHW(MHEP)-6)/2
          KKK = (IDHW(LHEP)+1)/2
          LLL = (IJ-126)/2
          MMM = (IK-119)/2
          NDIA = 0
          DO 62 III=1,3
          IF(ABS(LAMDA2(III,JJJ,KKK)*LAMDA1(III,LLL,MMM)).LT.EPS)
     &             GOTO 62
          DO 63 J=1,2
          IFLOW(NDIA+J) = 1
          IDP(4+NDIA+J) = 423+2*III+12*(J-1)
          A(1,NDIA+J) = LAMDA2(III,JJJ,KKK)*LMIXSS(2*III-1,1,J)
          A(2,NDIA+J) = ZERO
          B(1,NDIA+J) = ZERO
          B(2,NDIA+J) = LAMDA1(III,LLL,MMM)*LMIXSS(2*III-1,1,J)
 63       DRTYPE(NDIA+J) = 21
          NDIA = NDIA+2
 62       CONTINUE
          NCFL(1) = 1
          SPNCFC(1,1,1) = ONE/THREE
C--unrecognized process
        ELSE
          CALL HWWARN('HWHSPN',505)
        ENDIF
C--UDD processes
      ELSEIF(IPRO.EQ.41) THEN
C--change outgoing order
        ID = IJ
        IJ = IK
        IK = ID
        ID = JHEP
        JHEP = KHEP
        KHEP = ID
C--ubar neutralino
        IF(IK.GE.450.AND.IK.LE.453.AND.MOD(IJ,2).EQ.0.AND.
     &     IDPDG(IJ).LT.0) THEN
C--indices for RPV
          III = (IJ-6)/2
          JJJ = (IDHW(LHEP)+1)/2
          KKK = (IDHW(MHEP)+1)/2
          L1  = IK - 449
C--types of diagram
          DRTYPE(1) = 27
          DRTYPE(2) = 27
          DRTYPE(3) = 28
          DRTYPE(4) = 28
          DRTYPE(5) = 29
          DRTYPE(6) = 29
C--RPV couplings
          DO 64 J=1,2
          A(1,J  ) = QMIXSS(2*III,2,J)*LAMDA3(III,JJJ,KKK)
          A(2,J  ) = ZERO
          B(1,J+2) = QMIXSS(2*JJJ-1,2,J)*LAMDA3(III,JJJ,KKK)
          B(2,J+2) = ZERO
          A(1,J+4) = QMIXSS(2*KKK-1,2,J)*LAMDA3(III,JJJ,KKK)
          A(2,J+4) = ZERO
C--particles
          IDP(4+J) = 400+2*III+12*(J-1)
          IDP(6+J) = 399+2*JJJ+12*(J-1)
          IDP(8+J) = 399+2*KKK+12*(J-1)
C--MSSM couplings
          DO 64 I=1,2
          B(I,J)   = AFN(O(I),2*III,J,L1)
          A(I,J+2) = AFN(O(I),2*JJJ-1,J,L1)
 64       B(I,J+4) = AFN(O(I),2*KKK-1,J,L1)
C--colour flows
          NDIA = 6
          NCFL(1) = 1
          DO 65 I=1,6
 65       IFLOW(I) = 1
          SPNCFC(1,1,1) = TWO/THREE
C--u    neutralino
        ELSEIF(IK.GE.450.AND.IK.LE.453.AND.MOD(IJ,2).EQ.0.AND.
     &         IDPDG(IJ).GT.0) THEN
C--indices for RPV
          III = IJ/2
          JJJ = (IDHW(LHEP)-5)/2
          KKK = (IDHW(MHEP)-5)/2
          L1  = IK - 449
C--types of diagram
          DRTYPE(1) = 30
          DRTYPE(2) = 30
          DRTYPE(3) = 31
          DRTYPE(4) = 31
          DRTYPE(5) = 32
          DRTYPE(6) = 32
C--RPV couplings
          DO 66 J=1,2
          A(1,J  ) = ZERO
          A(2,J  ) = QMIXSS(2*III,2,J)*LAMDA3(III,JJJ,KKK)
          B(1,J+2) = ZERO
          B(2,J+2) = QMIXSS(2*JJJ-1,2,J)*LAMDA3(III,JJJ,KKK)
          A(1,J+4) = ZERO
          A(2,J+4) = QMIXSS(2*KKK-1,2,J)*LAMDA3(III,JJJ,KKK)
C--particles
          IDP(4+J) = 400+2*III+12*(J-1)
          IDP(6+J) = 399+2*JJJ+12*(J-1)
          IDP(8+J) = 399+2*KKK+12*(J-1)
C--MSSM couplings
          DO 66 I=1,2
          B(I,J)   = AFN(I,2*III,J,L1)
          A(I,J+2) = AFN(I,2*JJJ-1,J,L1)
 66       B(I,J+4) = AFN(I,2*KKK-1,J,L1)
C--colour flows
          NDIA = 6
          NCFL(1) = 1
          DO 67 I=1,6
 67       IFLOW(I) = 1
          SPNCFC(1,1,1) = TWO/THREE
C--dbar neutralino
        ELSEIF(IK.GE.450.AND.IK.LE.453.AND.MOD(IJ,2).EQ.1.AND.
     &         IDPDG(IJ).LT.0) THEN
C--ensure u type first
          IF(MOD(IDHW(LHEP),2).NE.0) THEN
            ID   = LHEP
            LHEP = MHEP
            MHEP = ID
          ENDIF
C--RPV indices
          III = IDHW(LHEP)/2
          JJJ = (IDHW(MHEP)+1)/2
          KKK = (IJ-5)/2
          L1  = IK - 449
C--types of diagram
          DRTYPE(1) = 27
          DRTYPE(2) = 27
          DRTYPE(3) = 28
          DRTYPE(4) = 28
          DRTYPE(5) = 29
          DRTYPE(6) = 29
C--RPV couplings
          DO 68 I=1,2
          A(1,I  ) = QMIXSS(2*KKK-1,2,I)*LAMDA3(III,JJJ,KKK)
          A(2,I  ) = ZERO
          B(1,I+2) = QMIXSS(2*III,2,I)*LAMDA3(III,JJJ,KKK)
          B(2,I+2) = ZERO
          A(1,I+4) = QMIXSS(2*JJJ-1,2,I)*LAMDA3(III,JJJ,KKK)
          A(2,I+4) = ZERO
C--particles
          IDP(4+I) = 399+2*KKK+12*(I-1)
          IDP(6+I) = 400+2*III+12*(I-1)
          IDP(8+I) = 399+2*JJJ+12*(I-1)
C--MSSM couplings
          DO 68 J=1,2
          B(J,I  ) = AFN(O(J),2*KKK-1,I,L1)
          A(J,I+2) = AFN(O(J),2*III  ,I,L1)
 68       B(J,I+4) = AFN(O(J),2*JJJ-1,I,L1)
C--colour flows
          NDIA = 6
          NCFL(1) = 1
          DO 69 I=1,6
 69       IFLOW(I) = 1
          SPNCFC(1,1,1) = TWO/THREE
C--d    neutralino
        ELSEIF(IK.GE.450.AND.IK.LE.453.AND.MOD(IJ,2).EQ.1.AND.
     &         IDPDG(IJ).GT.0) THEN
C--ensure u type first
          IF(MOD(IDHW(LHEP),2).NE.0) THEN
            ID   = LHEP
            LHEP = MHEP
            MHEP = ID
          ENDIF
C--RPV indices
          III = (IDHW(LHEP)-6)/2
          JJJ = (IDHW(MHEP)-5)/2
          KKK = (IJ+1)/2
          L1  = IK - 449
C--types of diagram
          DRTYPE(1) = 30
          DRTYPE(2) = 30
          DRTYPE(3) = 31
          DRTYPE(4) = 31
          DRTYPE(5) = 32
          DRTYPE(6) = 32
C--RPV couplings
          DO 70 I=1,2
          A(1,I  ) = ZERO
          A(2,I  ) = QMIXSS(2*KKK-1,2,I)*LAMDA3(III,JJJ,KKK)
          B(1,I+2) = ZERO
          B(2,I+2) = QMIXSS(2*III,2,I)*LAMDA3(III,JJJ,KKK)
          A(1,I+4) = ZERO
          A(2,I+4) = QMIXSS(2*JJJ-1,2,I)*LAMDA3(III,JJJ,KKK)
C--particles
          IDP(4+I) = 399+2*KKK+12*(I-1)
          IDP(6+I) = 400+2*III+12*(I-1)
          IDP(8+I) = 399+2*JJJ+12*(I-1)
C--MSSM couplings
          DO 70 J=1,2
          B(J,I  ) = AFN(J,2*KKK-1,I,L1)
          A(J,I+2) = AFN(J,2*III  ,I,L1)
 70       B(J,I+4) = AFN(J,2*JJJ-1,I,L1)
C--colour flows
          NDIA = 6
          NCFL(1) = 1
          DO 71 I=1,6
 71       IFLOW(I) = 1
          SPNCFC(1,1,1) = TWO/THREE
C--ubar gluino
        ELSEIF(IK.EQ.449.AND.MOD(IJ,2).EQ.0.AND.IDPDG(IJ).LT.0) THEN
C--indices for RPV
          III = (IJ-6)/2
          JJJ = (IDHW(LHEP)+1)/2
          KKK = (IDHW(MHEP)+1)/2
C--types of diagram
          DRTYPE(1) = 27
          DRTYPE(2) = 27
          DRTYPE(3) = 28
          DRTYPE(4) = 28
          DRTYPE(5) = 29
          DRTYPE(6) = 29
C--RPV couplings
          DO 72 J=1,2
          A(1,J  ) = QMIXSS(2*III,2,J)*LAMDA3(III,JJJ,KKK)
          A(2,J  ) = ZERO
          B(1,J+2) = QMIXSS(2*JJJ-1,2,J)*LAMDA3(III,JJJ,KKK)
          B(2,J+2) = ZERO
          A(1,J+4) = QMIXSS(2*KKK-1,2,J)*LAMDA3(III,JJJ,KKK)
          A(2,J+4) = ZERO
C--particles
          IDP(4+J) = 400+2*III+12*(J-1)
          IDP(6+J) = 399+2*JJJ+12*(J-1)
          IDP(8+J) = 399+2*KKK+12*(J-1)
C--MSSM couplings
          DO 72 I=1,2
          B(I,J)   = AFG(O(I),2*III,J)
          A(I,J+2) = AFG(O(I),2*JJJ-1,J)
 72       B(I,J+4) = AFG(O(I),2*KKK-1,J)
C--colour flows
          NDIA = 6
          NCFL(1) = 3
          DO 73 I=1,2
          IFLOW(I  ) = 1
          IFLOW(I+2) = 2
 73       IFLOW(I+4) = 3
          DO 74 I=1,3
          DO 74 J=1,3
          IF(I.EQ.J) THEN
            SPNCFC(I,J,1) = 8.0D0/9.0D0
          ELSE
            SPNCFC(I,J,1) =-4.0D0/9.0D0
          ENDIF
 74       CONTINUE
C--u    gluino
        ELSEIF(IK.EQ.449.AND.MOD(IJ,2).EQ.0.AND.IDPDG(IJ).GT.0) THEN
C--indices for RPV
          III = IJ/2
          JJJ = (IDHW(LHEP)-5)/2
          KKK = (IDHW(MHEP)-5)/2
C--types of diagram
          DRTYPE(1) = 30
          DRTYPE(2) = 30
          DRTYPE(3) = 31
          DRTYPE(4) = 31
          DRTYPE(5) = 32
          DRTYPE(6) = 32
C--RPV couplings
          DO 75 J=1,2
          A(1,J  ) = ZERO
          A(2,J  ) = QMIXSS(2*III,2,J)*LAMDA3(III,JJJ,KKK)
          B(1,J+2) = ZERO
          B(2,J+2) = QMIXSS(2*JJJ-1,2,J)*LAMDA3(III,JJJ,KKK)
          A(1,J+4) = ZERO
          A(2,J+4) = QMIXSS(2*KKK-1,2,J)*LAMDA3(III,JJJ,KKK)
C--particles
          IDP(4+J) = 400+2*III+12*(J-1)
          IDP(6+J) = 399+2*JJJ+12*(J-1)
          IDP(8+J) = 399+2*KKK+12*(J-1)
C--MSSM couplings
          DO 75 I=1,2
          B(I,J)   = AFG(I,2*III,J)
          A(I,J+2) = AFG(I,2*JJJ-1,J)
 75       B(I,J+4) = AFG(I,2*KKK-1,J)
C--colour flows
          NDIA = 6
          NCFL(1) = 3
          DO 76 I=1,2
          IFLOW(I  ) = 1
          IFLOW(I+2) = 2
 76       IFLOW(I+4) = 3
          DO 77 I=1,3
          DO 77 J=1,3
          IF(I.EQ.J) THEN
            SPNCFC(I,J,1) = 8.0D0/9.0D0
          ELSE
            SPNCFC(I,J,1) =-4.0D0/9.0D0
          ENDIF
 77       CONTINUE
C--dbar gluino
        ELSEIF(IK.EQ.449.AND.MOD(IJ,2).EQ.1.AND.IDPDG(IJ).LT.0) THEN
C--ensure u type first
          IF(MOD(IDHW(LHEP),2).NE.0) THEN
            ID   = LHEP
            LHEP = MHEP
            MHEP = ID
          ENDIF
C--RPV indices
          III = IDHW(LHEP)/2
          JJJ = (IDHW(MHEP)+1)/2
          KKK = (IJ-5)/2
C--types of diagram
          DRTYPE(1) = 27
          DRTYPE(2) = 27
          DRTYPE(3) = 28
          DRTYPE(4) = 28
          DRTYPE(5) = 29
          DRTYPE(6) = 29
C--RPV couplings
          DO 78 I=1,2
          A(1,I  ) = QMIXSS(2*KKK-1,2,I)*LAMDA3(III,JJJ,KKK)
          A(2,I  ) = ZERO
          B(1,I+2) = QMIXSS(2*III,2,I)*LAMDA3(III,JJJ,KKK)
          B(2,I+2) = ZERO
          A(1,I+4) = QMIXSS(2*JJJ-1,2,I)*LAMDA3(III,JJJ,KKK)
          A(2,I+4) = ZERO
C--particles
          IDP(4+I) = 399+2*KKK+12*(I-1)
          IDP(6+I) = 400+2*III+12*(I-1)
          IDP(8+I) = 399+2*JJJ+12*(I-1)
C--MSSM couplings
          DO 78 J=1,2
          B(J,I  ) = AFG(O(J),2*KKK-1,I)
          A(J,I+2) = AFG(O(J),2*III  ,I)
 78       B(J,I+4) = AFG(O(J),2*JJJ-1,I)
C--colour flows
          NDIA = 6
          NCFL(1) = 3
          DO 79 I=1,2
          IFLOW(I  ) = 1
          IFLOW(I+2) = 2
 79       IFLOW(I+4) = 3
          DO 80 I=1,3
          DO 80 J=1,3
          IF(I.EQ.J) THEN
            SPNCFC(I,J,1) = 8.0D0/9.0D0
          ELSE
            SPNCFC(I,J,1) =-4.0D0/9.0D0
          ENDIF
 80       CONTINUE
C--d    gluino
        ELSEIF(IK.EQ.449.AND.MOD(IJ,2).EQ.1.AND.IDPDG(IJ).GT.0) THEN
C--ensure u type first
          IF(MOD(IDHW(LHEP),2).NE.0) THEN
            ID   = LHEP
            LHEP = MHEP
            MHEP = ID
          ENDIF
C--RPV indices
          III = (IDHW(LHEP)-6)/2
          JJJ = (IDHW(MHEP)-5)/2
          KKK = (IJ+1)/2
C--types of diagram
          DRTYPE(1) = 30
          DRTYPE(2) = 30
          DRTYPE(3) = 31
          DRTYPE(4) = 31
          DRTYPE(5) = 32
          DRTYPE(6) = 32
C--RPV couplings
          DO 81 I=1,2
          A(1,I  ) = ZERO
          A(2,I  ) = QMIXSS(2*KKK-1,2,I)*LAMDA3(III,JJJ,KKK)
          B(1,I+2) = ZERO
          B(2,I+2) = QMIXSS(2*III,2,I)*LAMDA3(III,JJJ,KKK)
          A(1,I+4) = ZERO
          A(2,I+4) = QMIXSS(2*JJJ-1,2,I)*LAMDA3(III,JJJ,KKK)
C--particles
          IDP(4+I) = 399+2*KKK+12*(I-1)
          IDP(6+I) = 400+2*III+12*(I-1)
          IDP(8+I) = 399+2*JJJ+12*(I-1)
C--MSSM couplings
          DO 81 J=1,2
          B(J,I  ) = AFG(J,2*KKK-1,I)
          A(J,I+2) = AFG(J,2*III  ,I)
 81       B(J,I+4) = AFG(J,2*JJJ-1,I)
C--colour flows
          NDIA = 6
          NCFL(1) = 3
          DO 82 I=1,2
          IFLOW(I  ) = 1
          IFLOW(I+2) = 2
 82       IFLOW(I+4) = 3
          DO 83 I=1,3
          DO 83 J=1,3
          IF(I.EQ.J) THEN
            SPNCFC(I,J,1) = 8.0D0/9.0D0
          ELSE
            SPNCFC(I,J,1) =-4.0D0/9.0D0
          ENDIF
 83       CONTINUE
C--dbar -ve chargino
        ELSEIF(IK.GE.456.AND.IK.LE.457.AND.MOD(IJ,2).EQ.1) THEN
C--change order so highest generation first
          IF(IDHW(MHEP).GT.IDHW(LHEP)) THEN
            ID = MHEP
            MHEP = LHEP
            LHEP = ID
          ENDIF
C--RPV indices
          III = (IJ-5)/2
          JJJ = (IDHW(LHEP)+1)/2
          KKK = (IDHW(MHEP)+1)/2
          L1  = IK-455
C--types of diagram
          DRTYPE(1) = 27
          DRTYPE(2) = 27
          DRTYPE(3) = 28
          DRTYPE(4) = 28
          DRTYPE(5) = 29
          DRTYPE(6) = 29
C--RPV couplings
          DO 84 I=1,2
          A(1,I  ) = QMIXSS(2*III,2,I)*LAMDA3(III,JJJ,KKK)
          A(2,I  ) = ZERO
          B(1,I+2) = QMIXSS(2*JJJ,2,I)*LAMDA3(JJJ,KKK,III)
          B(2,I+2) = ZERO
          A(1,I+4) = QMIXSS(2*KKK,2,I)*LAMDA3(KKK,III,JJJ)
          A(2,I+4) = ZERO
C--particles
          IDP(4+I) = 400+2*III+12*(I-1)
          IDP(6+I) = 400+2*JJJ+12*(I-1)
          IDP(8+I) = 400+2*KKK+12*(I-1)
C--MSSM couplings
          DO 84 J=1,2
          B(J,I  ) = AFC(O(J),2*III,I,L1)
          A(J,I+2) = AFC(O(J),2*JJJ,I,L1)
 84       B(J,I+4) = AFC(O(J),2*KKK,I,L1)
C--colour flows
          NDIA = 6
          NCFL(1) = 1
          DO 85 I=1,6
 85       IFLOW(I) = 1
          SPNCFC(1,1,1) = TWO/THREE
C--d    +ve chargino
        ELSEIF(IK.GE.454.AND.IK.LE.455.AND.MOD(IJ,2).EQ.1) THEN
C--change order so highest generation first
          IF(IDHW(MHEP).GT.IDHW(LHEP)) THEN
            ID = MHEP
            MHEP = LHEP
            LHEP = ID
          ENDIF
C--RPV indices
          III = (IJ+1)/2
          JJJ = (IDHW(LHEP)-5)/2
          KKK = (IDHW(MHEP)-5)/2
          L1  = IK-453
C--types of diagram
          DRTYPE(1) = 30
          DRTYPE(2) = 30
          DRTYPE(3) = 31
          DRTYPE(4) = 31
          DRTYPE(5) = 32
          DRTYPE(6) = 32
C--RPV couplings
          DO 86 I=1,2
          A(1,I  ) = ZERO
          A(2,I  ) = QMIXSS(2*III,2,I)*LAMDA3(III,JJJ,KKK)
          B(1,I+2) = ZERO
          B(2,I+2) = QMIXSS(2*JJJ,2,I)*LAMDA3(JJJ,KKK,III)
          A(1,I+4) = ZERO
          A(2,I+4) = QMIXSS(2*KKK,2,I)*LAMDA3(KKK,III,JJJ)
C--particles
          IDP(4+I) = 400+2*III+12*(I-1)
          IDP(6+I) = 400+2*JJJ+12*(I-1)
          IDP(8+I) = 400+2*KKK+12*(I-1)
C--MSSM couplings
          DO 86 J=1,2
          B(J,I  ) = AFC(J,2*III,I,L1)
          A(J,I+2) = AFC(J,2*JJJ,I,L1)
 86       B(J,I+4) = AFC(J,2*KKK,I,L1)
C--colour flows
          NDIA = 6
          NCFL(1) = 1
          DO 87 I=1,6
 87       IFLOW(I) = 1
          SPNCFC(1,1,1) = TWO/THREE
C--ubar +ve chargino
        ELSEIF(IK.GE.454.AND.IK.LE.455.AND.MOD(IJ,2).EQ.0) THEN
C--ensure u type first
          IF(MOD(IDHW(LHEP),2).NE.0) THEN
            ID   = LHEP
            LHEP = MHEP
            MHEP = ID
          ENDIF
C--RPV indices
          III = IDHW(LHEP)/2
          JJJ = (IDHW(MHEP)+1)/2
          KKK = (IJ-6)/2
          L1  = IK-453
C--types of diagram
          DRTYPE(1) = 27
          DRTYPE(2) = 27
          DRTYPE(3) = 28
          DRTYPE(4) = 28
C--RPV couplings
          DO 88 I=1,2
          A(1,I  ) = QMIXSS(2*KKK-1,2,I)*LAMDA3(III,JJJ,KKK)
          A(2,I  ) = ZERO
          B(1,I+2) = QMIXSS(2*III-1,2,I)*LAMDA3(KKK,III,JJJ)
          B(2,I+2) = ZERO
C--particles
          IDP(4+I) = 399+2*KKK+12*(I-1)
          IDP(6+I) = 399+2*III+12*(I-1)
C--MSSM couplings
          DO 88 J=1,2
          B(J,I  ) = AFC(O(J),2*KKK-1,I,L1)
 88       A(J,I+2) = AFC(O(J),2*III-1,I,L1)
C--colour flows
          NDIA = 4
          NCFL(1) = 1
          DO 89 I=1,4
 89       IFLOW(I) = 1
          SPNCFC(1,1,1) = TWO/THREE
C--u    -ve chargino
        ELSEIF(IK.GE.456.AND.IK.LE.457.AND.MOD(IJ,2).EQ.0) THEN
C--ensure u type first
          IF(MOD(IDHW(LHEP),2).NE.0) THEN
            ID   = LHEP
            LHEP = MHEP
            MHEP = ID
          ENDIF
C--RPV indices
          III = (IDHW(LHEP)-6)/2
          JJJ = (IDHW(MHEP)-5)/2
          KKK = IJ/2
          L1  = IK-455
C--types of diagram
          DRTYPE(1) = 30
          DRTYPE(2) = 30
          DRTYPE(3) = 31
          DRTYPE(4) = 31
C--RPV couplings
          DO 90 I=1,2
          A(1,I  ) = ZERO
          A(2,I  ) = QMIXSS(2*KKK-1,2,I)*LAMDA3(III,JJJ,KKK)
          B(1,I+2) = ZERO
          B(2,I+2) = QMIXSS(2*III-1,2,I)*LAMDA3(KKK,III,JJJ)
C--particles
          IDP(4+I) = 399+2*KKK+12*(I-1)
          IDP(6+I) = 399+2*III+12*(I-1)
C--MSSM couplings
          DO 90 J=1,2
          B(J,I  ) = AFC(J,2*KKK-1,I,L1)
 90       A(J,I+2) = AFC(J,2*III-1,I,L1)
C--colour flows
          NDIA = 4
          NCFL(1) = 1
          DO 91 I=1,4
 91       IFLOW(I) = 1
          SPNCFC(1,1,1) = TWO/THREE
C--d d --> d d
        ELSEIF(IDPDG(IK).GT.0.AND.IDPDG(IK).GT.0.AND.
     &         MOD(IK,2).EQ.1.AND.MOD(IJ,2).EQ.1) THEN
C--can't produce unstable quark on hadronisation timescale
          RETURN
C--dbar dbar --> dbar dbar
        ELSEIF(IDPDG(IK).LT.0.AND.IDPDG(IJ).LT.0.AND.
     &         MOD(IJ,2).EQ.1.AND.MOD(IK,2).EQ.1) THEN
C--can't produce unstable quark on hadronisation timescale
          RETURN
C--u d --> u d
        ELSEIF(IDPDG(IK).GT.0.AND.IDPDG(IJ).GT.0.AND.
     &         ((MOD(IJ,2).EQ.1.AND.MOD(IK,2).EQ.0).OR.
     &          (MOD(IJ,2).EQ.0.AND.MOD(IK,2).EQ.1))) THEN
C--ensure u first (incoming)
          IF(MOD(IDHW(LHEP),2).EQ.1) THEN
            ID   = MHEP
            MHEP = LHEP
            LHEP = ID
          ENDIF
C--ensure u first (outgoing)
          IF(MOD(IK,2).EQ.1) THEN
            ID = IJ
            IJ = IK
            IK = ID
            ID = JHEP
            JHEP = KHEP
            KHEP = ID
          ENDIF
C--can't produce unstable quark on hadronisation timescale
          IF(IK.NE.6) RETURN
C--RPV indices
          III = IDHW(LHEP)/2
          KKK = (IDHW(MHEP)+1)/2
          LLL = IK/2
          MMM = (IJ+1)/2
          NDIA = 0
          DO 92 JJJ=1,3
          IF(ABS(LAMDA3(III,JJJ,KKK)*LAMDA3(LLL,JJJ,MMM)).LT.EPS)
     &            GOTO 92
          DO 93 J=1,2
          IFLOW(NDIA+J) = 1
          IDP(4+NDIA+J) = 399+2*JJJ+12*(J-1)
          A(1,NDIA+J) = LAMDA3(III,JJJ,KKK)*QMIXSS(2*JJJ-1,2,J)
          A(2,NDIA+J) = ZERO
          B(1,NDIA+J) = ZERO
          B(2,NDIA+J) = LAMDA3(LLL,JJJ,MMM)*QMIXSS(2*JJJ-1,2,J)
 93       DRTYPE(NDIA+J) = 33
          NDIA = NDIA+2
 92       CONTINUE
          NCFL(1) = 1
          SPNCFC(1,1,1) = ONE/THREE
C--ubar dbar --> ubar dbar
        ELSEIF(IDPDG(IK).LT.0.AND.IDPDG(IJ).LT.0.AND.
     &         ((MOD(IJ,2).EQ.1.AND.MOD(IK,2).EQ.0).OR.
     &          (MOD(IJ,2).EQ.0.AND.MOD(IK,2).EQ.1))) THEN
C--ensure u first (incoming)
          IF(MOD(IDHW(LHEP),2).EQ.1) THEN
            ID   = MHEP
            MHEP = LHEP
            LHEP = ID
          ENDIF
C--ensure u first (outgoing)
          IF(MOD(IK,2).EQ.1) THEN
            ID = IJ
            IJ = IK
            IK = ID
            ID = JHEP
            JHEP = KHEP
            KHEP = ID
          ENDIF
C--can't produce unstable quark on hadronisation timescale
          IF(IK.NE.6) RETURN
C--RPV indices
          III = (IDHW(LHEP)-6)/2
          KKK = (IDHW(MHEP)-5)/2
          LLL = (IK-6)/2
          MMM = (IJ-5)/2
          NDIA = 0
          DO 94 JJJ=1,3
          IF(ABS(LAMDA3(III,JJJ,KKK)*LAMDA3(LLL,JJJ,MMM)).LT.EPS)
     &             GOTO 94
          DO 95 J=1,2
          IFLOW(NDIA+J) = 1
          IDP(4+NDIA+J) = 399+2*JJJ+12*(J-1)
          A(1,NDIA+J) = ZERO
          A(2,NDIA+J) = LAMDA3(III,JJJ,KKK)*QMIXSS(2*JJJ-1,2,J)
          B(1,NDIA+J) = LAMDA3(LLL,JJJ,MMM)*QMIXSS(2*JJJ-1,2,J)
          B(2,NDIA+J) = ZERO
 95       DRTYPE(NDIA+J) = 34
          NDIA = NDIA+2
 94       CONTINUE
          NCFL(1) = 1
          SPNCFC(1,1,1) = ONE/THREE
C--unrecognized process
        ELSE
          CALL HWWARN('HWHSPN',506)
        ENDIF
C--unrecognized process
      ELSE
        CALL HWWARN('HWHSPN',507)
      ENDIF
C--copy the momenta into the internal array
      CALL HWVEQU(5,PHEP(1,LHEP),P(1,1))
      CALL HWVEQU(5,PHEP(1,MHEP),P(1,2))
      CALL HWVEQU(5,PHEP(1,KHEP),P(1,3))
      CALL HWVEQU(5,PHEP(1,JHEP),P(1,4))
C--now compute the masses etc for the diagrams
      IDP(1) = IDHW(LHEP)
      IDP(2) = IDHW(MHEP)
      IDP(3) = IDHW(KHEP)
      IDP(4) = IDHW(JHEP)
      DO 104 I=1,4
      MA (I) = P(5,I)
 104  MA2(I) = SIGN(MA(I)**2,MA(I))
      DO 105 I=1,NDIA
      MR(I) = RMASS(IDP(4+I))
      MS(I) = MR(I)**2
      IF(IDP(I+4).EQ.200) THEN
        MWD(I) = RMASS(200)*GAMZ
      ELSEIF(IDP(I+4).EQ.198.OR.IDP(I+4).EQ.199) THEN
        MWD(I) = RMASS(198)*GAMW
      ELSEIF(IDP(I+4).EQ.59.OR.IDP(I+4).EQ.13.OR.
     &  IDP(I+4).LE.5.OR.(IDP(I+4).GE.7.AND.IDP(I+4).LE.11)) THEN
        MR(I)  = ZERO
        MS(I)  = ZERO
        MWD(I) = ZERO
      ELSE
        MWD(I) = MR(I)*HBAR/RLTIM(IDP(I+4))
      ENDIF
 105  CONTINUE
C--set up the mandelstam variables
      SH = TWO*HWULDO(P(1,1),P(1,2))
      CALL HWVSCA(4,-ONE,P(1,3),PLAB(1,2))
      CALL HWVSUM(5,P(1,1),PLAB(1,2),PLAB(1,1))
      TH = P(5,3)**2-TWO*HWULDO(P(1,1),P(1,3))
      UH = P(5,4)**2-TWO*HWULDO(P(1,1),P(1,4))
C--copy the momenta into the common block for spinor computation
      DO 106 I=1,4
      IF(IDP(I).LT.400.AND.(IDP(I).NE.6.AND.IDP(I).NE.12
     &                .AND.IDP(I).NE.125.AND.IDP(I).NE.131)) THEN
        CALL HWVEQU(5,PREF,PLAB(1,I+4))
C--all other particles
      ELSE
        PP = SQRT(HWVDOT(3,P(1,I),P(1,I)))
        CALL HWVSCA(3,ONE/PP,P(1,I),N)
        PLAB(4,I+4) = HALF*(P(4,I)-PP)
        PP = HALF*(PP-P(5,I)-PP**2/(P(5,I)+P(4,I)))
        CALL HWVSCA(3,PP,N,PLAB(1,I+4))
        CALL HWUMAS(PLAB(1,I+4))
        PP = HWVDOT(3,PLAB(1,I+4),PLAB(1,I+4))
C--fix to avoid problems if approx massless due to energy
        IF(PP.LT.EPS) CALL HWVEQU(5,PREF,PLAB(1,I+4))
      ENDIF
C--now the massless vectors
      PP = HALF*MA2(I)/HWULDO(PLAB(1,I+4),P(1,I))
      DO 107 J=1,4
 107  PLAB(J,I) = P(J,I)-PP*PLAB(J,I+4)
 106  CALL HWUMAS(PLAB(1,I))
C--change order of momenta for call to HE code
      DO 108 I=1,4
      PM(1,I) = P(3,I)
      PM(2,I) = P(1,I)
      PM(3,I) = P(2,I)
      PM(4,I) = P(4,I)
 108  PM(5,I) = P(5,I)
      DO 109 I=1,8
      PCM(1,I)=PLAB(3,I)
      PCM(2,I)=PLAB(1,I)
      PCM(3,I)=PLAB(2,I)
      PCM(4,I)=PLAB(4,I)
 109  PCM(5,I)=PLAB(5,I)
C--compute the S functions
      CALL HWHEW2(8,PCM(1,1),S(1,1,2),S(1,1,1),D)
      DO 110 I=1,8
      DO 110 J=1,8
      S(I,J,2) = -S(I,J,2)
 110  D(I,J)   = TWO*D(I,J)
C--compute the F functions
      CALL HWH2F1(8,F3 ,7,PM(1,3), MA(3))
      CALL HWH2F2(8,F4 ,8,PM(1,4),-MA(4))
      CALL HWH2F1(8,F4M,8,PM(1,4), MA(4))
      CALL HWH2F2(8,F3M,7,PM(1,3),-MA(3))
C--t and u channel functions
C--first the t channel ones
      CALL HWVSCA(4,-ONE,PM(1,4),PTMP)
      CALL HWVSUM(4,PM(1,2),PTMP,PTMP)
      CALL HWUMAS(PTMP)
      CALL HWH2F3(8,FTP,PTMP, MR(1))
      CALL HWH2F3(8,FTM,PTMP,-MR(1))
C--then the u-channel ones
      CALL HWVSCA(4,-ONE,PM(1,4),PTMP)
      CALL HWVSUM(4,PM(1,1),PTMP,PTMP)
      CALL HWUMAS(PTMP)
      CALL HWH2F3(8,FUP,PTMP, MR(1))
      CALL HWH2F3(8,FUM,PTMP,-MR(1))
C--function for t-channel scalar exchange
      CALL HWVSUM(4,PM(1,4),PM(1,4),PTMP)
      CALL HWUMAS(PTMP)
      CALL HWH2F1(8,FST,2,PTMP,ZERO)
C--compute the prefactor for all diagrams
      PRE = HWULDO(PCM(1,7),PM(1,3))*HWULDO(PCM(1,8),PM(1,4))
      PRE = ONE/SQRT(PRE)
C--zero the matrix element
      DO 200 P1=1,2
      DO 200 P2=1,2
      DO 200 P3=1,2
      DO 200 P4=1,2
      DO 200 I=1,NCFL(1)
 200  ME(P1,P2,P3,P4,I) = (0.0D0,0.0D0)
C--now call the subroutines to compute the individual diagrams
      DO 210 I=1,NDIA
C--s-channel vector boson exchange diagram (f fbar to fermion fermion)
      IF(DRTYPE(I).EQ.1) THEN
        CALL HWHS01(I,MED)
C--t-channel sfermion exchange diagram (f fbar to fermion fermion)
      ELSEIF(DRTYPE(I).EQ.2) THEN
        CALL HWHS02(I,MED)
C--u-channel sfermion exchange diagram(f fbar to fermion fermion)
      ELSEIF(DRTYPE(I).EQ.3) THEN
        CALL HWHS03(I,MED)
C--s-channel vector boson (f fbar to fermion antifermion)
      ELSEIF(DRTYPE(I).EQ.4) THEN
        CALL HWHS04(I,MED)
C--t-channel fermion exchange (g g to fermion antifermion)
      ELSEIF(DRTYPE(I).EQ.5) THEN
        CALL HWHS05(I,MED)
C--u-channel fermion exchange (g g to fermion antifermion)
      ELSEIF(DRTYPE(I).EQ.6) THEN
        CALL HWHS06(I,MED)
C--s-channel gluon exchange (g g to fermion antifermion)
      ELSEIF(DRTYPE(I).EQ.7) THEN
        CALL HWHS07(I,MED)
C--t-channel sfermion exchange (g q to fermion sfermion)
      ELSEIF(DRTYPE(I).EQ.8) THEN
        CALL HWHS08(I,MED)
C--t-channel sfermion exchange  (g qbar to fermion antisfermion)
      ELSEIF(DRTYPE(I).EQ.9) THEN
        CALL HWHS09(I,MED)
C--s-channel quark exchange     (g q to fermion antisfermion)
      ELSEIF(DRTYPE(I).EQ.10) THEN
        CALL HWHS10(I,MED)
C--s-channel antiquark exchange (g qbar to fermion antisfermion)
      ELSEIF(DRTYPE(I).EQ.11) THEN
        CALL HWHS11(I,MED)
C--u-channel gluino exchange (g q to fermion antisfermion)
      ELSEIF(DRTYPE(I).EQ.12) THEN
        CALL HWHS12(I,MED)
C--u-channel gluino exchange (g qbar to fermion antisfermion)
      ELSEIF(DRTYPE(I).EQ.13) THEN
        CALL HWHS13(I,MED)
C--t-channel fermion exchange (g g to fermion fermion)
      ELSEIF(DRTYPE(I).EQ.14) THEN
        CALL HWHS14(I,MED)
C--u-channel fermion exchange (g g to fermion fermion)
      ELSEIF(DRTYPE(I).EQ.15) THEN
        CALL HWHS15(I,MED)
C--s-channel gluon exchange (g g to fermion fermion)
      ELSEIF(DRTYPE(I).EQ.16) THEN
        CALL HWHS16(I,MED)
C--t-channel gauge boson exchange (fermion fermion)
      ELSEIF(DRTYPE(I).EQ.17) THEN
        CALL HWHS17(I,MED)
C--t-channel gauge boson exchange (fermion antifermion)
      ELSEIF(DRTYPE(I).EQ.18) THEN
        CALL HWHS18(I,MED)
C--t-channel gauge boson exchange (antifermion fermion)
      ELSEIF(DRTYPE(I).EQ.19) THEN
        CALL HWHS19(I,MED)
C--t-channel gauge boson exchange (antifermion antifermion)
      ELSEIF(DRTYPE(I).EQ.20) THEN
        CALL HWHS20(I,MED)
C--s-channel scalar exchange (f fbar --> f fbar)
      ELSEIF(DRTYPE(I).EQ.21) THEN
        CALL HWHS21(I,MED)
C--t-channel scalar exchange (f fbar --> f fbar)
      ELSEIF(DRTYPE(I).EQ.22) THEN
        CALL HWHS22(I,MED)
C--u-channel scalar exchange (f fbar --> f fbar)
      ELSEIF(DRTYPE(I).EQ.23) THEN
        CALL HWHS23(I,MED)
C--s-channel scalar exchange (fbar f --> f f)
      ELSEIF(DRTYPE(I).EQ.24) THEN
        CALL HWHS24(I,MED)
C--t-channel scalar exchange (fbar f --> f f)
      ELSEIF(DRTYPE(I).EQ.25) THEN
        CALL HWHS25(I,MED)
C--u-channel scalar exchange (fbar f --> f f)
      ELSEIF(DRTYPE(I).EQ.26) THEN
        CALL HWHS26(I,MED)
C--s-channel scalar exchange (f f --> f fbar)
      ELSEIF(DRTYPE(I).EQ.27) THEN
        CALL HWHS27(I,MED)
C--t-channel scalar exchange (f f --> f fbar)
      ELSEIF(DRTYPE(I).EQ.28) THEN
        CALL HWHS28(I,MED)
C--u-channel scalar exchange (f f --> f fbar)
      ELSEIF(DRTYPE(I).EQ.29) THEN
        CALL HWHS29(I,MED)
C--s-channel scalar exchange (fbar fbar --> f f)
      ELSEIF(DRTYPE(I).EQ.30) THEN
        CALL HWHS30(I,MED)
C--t-channel scalar exchange (fbar fbar --> f f)
      ELSEIF(DRTYPE(I).EQ.31) THEN
        CALL HWHS31(I,MED)
C--u-channel scalar exchange (fbar fbar --> f f)
      ELSEIF(DRTYPE(I).EQ.32) THEN
        CALL HWHS32(I,MED)
C--s-channel scalar exchange (f f --> f f)
      ELSEIF(DRTYPE(I).EQ.33) THEN
        CALL HWHS33(I,MED)
C--s-channel scalar exchange (fbar fbar --> fbar fbar)
      ELSEIF(DRTYPE(I).EQ.34) THEN
        CALL HWHS34(I,MED)
C--error not known
      ELSE
        CALL HWWARN('HWHSPN',508)
      ENDIF
C--add up the matrix elements
      DO 210 P1=1,2
      DO 210 P2=1,2
      DO 210 P3=1,2
      DO 210 P4=1,2
 210  ME(P1,P2,P3,P4,IFLOW(I)) = ME(P1,P2,P3,P4,IFLOW(I))
     &                             +MED(P1,P2,P3,P4)
C--preform the final normalisation
      DO 215 P1=1,2
      DO 215 P2=1,2
      DO 215 P3=1,2
      DO 215 P4=1,2
      DO 215 I=1,NCFL(1)
 215  ME(P1,P2,P3,P4,I) = PRE*ME(P1,P2,P3,P4,I)
C--now enter the matrix element in the spin common block
      NSPN        = 1
      IDSPN(1)    = ICM
      ISNHEP(ICM) = 1
      JMOSPN(1)   = 0
      JDASPN(1,1) = 2
      JDASPN(2,1) = 3
      DECSPN(1) = .FALSE.
      DO 225 P1=1,2
      DO 225 P2=1,2
      DO 225 P3=1,2
      DO 225 P4=1,2
      DO 225 I=1,NCFL(1)
 225  MESPN(P1,P2,P3,P4,I,1) = ME(P1,P2,P3,P4,I)
C--now enter the daughter particles
      NSPN         = NSPN+2
      IDSPN(2)     = KHEP
      ISNHEP(KHEP) = 2
      IDSPN(3)     = JHEP
      ISNHEP(JHEP) = 3
      JMOSPN(2)    = 1
      JMOSPN(3)    = 1
C--spin density matrices for daughter particles
      DO 230 P1=1,2
      DO 230 P2=1,2
      DO 230 I=1,3
      RHOSPN(1,1,I) = HALF
      RHOSPN(1,2,I) = ZERO
      RHOSPN(2,1,I) = ZERO
 230  RHOSPN(2,2,I) = HALF
      DECSPN(2) = .FALSE.
      DECSPN(3) = .FALSE.
C--select the colour flow if needed
      IF(SPCOPT.EQ.2.AND.NCFL(1).NE.1) THEN
        WGT = ZERO
C--assume no incoming polarization, no processes with more than one
C--colour flow in e+e-
        DO 335 I =1,NCFL(1)
        WGTB(I) = ZERO
        DO 335 P1=1,2
        DO 335 P2=1,2
        DO 335 P3=1,2
        DO 335 P4=1,2
        WGTB(I) = WGTB(I)+SPNCFC(I,I,1)*DREAL(
     &         MESPN(P1,P2,P3,P4,I,1)*DCONJG(MESPN(P1,P2,P3,P4,I,1)))
        DO 335 J =1,NCFL(1)
 335    WGT = WGT+SPNCFC(I,J,1)*DREAL(
     &         MESPN(P1,P2,P3,P4,I,1)*DCONJG(MESPN(P1,P2,P3,P4,J,1)))
        WGTC = ZERO
        DO 340 I=1,NCFL(1)
 340    WGTC = WGTC+WGTB(I)
        WGTC = WGT/WGTC
        DO 345 I=1,NCFL(1)
 345    WGTB(I) = WGTB(I)*WGTC
        WGTC = WGT*HWRGEN(0)
        DO 350 I=1,NCFL(1)
        IF(WGTB(I).GE.WGTC) THEN
          NCFL(1) = I
          RETURN
        ENDIF
 350    WGTC =WGTC-WGTB(I)
      ENDIF
      END
CDECK  ID>, HWHS01.
*CMZ :-        -02/10/01  10:17:10  by  Peter Richardson
*-- Author :    Peter Richardson
C-----------------------------------------------------------------------
      SUBROUTINE HWHS01(ID,ME)
C-----------------------------------------------------------------------
C  Subroutine to calculate the helicity amplitudes for the 2-to-2 cross
C  section f fbar --> gauge boson --> fermion fermion
C  This diagram 1 from DAMTP-2001-83 with opposite sign of P4
C-----------------------------------------------------------------------
      INCLUDE 'HERWIG65.INC'
      INTEGER NDIAHD
      PARAMETER(NDIAHD=10)
      DOUBLE COMPLEX ME(2,2,2,2),S,D,F3(2,2,8),F4(2,2,8),PRE,ZI
     &     ,F3M(2,2,8),F4M(2,2,8),FST(2,2,8),
     &     FTP(2,2,8,8),FTM(2,2,8,8),FUP(2,2,8,8),FUM(2,2,8,8)
      DOUBLE PRECISION A(2,NDIAHD),B(2,NDIAHD),MS(NDIAHD),MWD(NDIAHD),
     &     MA(4),MA2(4),MR(NDIAHD),SH,TH,UH
      INTEGER P1,P2,P3,P4,ID,O(2),IDP(4+NDIAHD),DRTYPE(NDIAHD)
      COMMON/HWSPHC/F3,F4,F3M,F4M,FTP,FTM,FUP,FUM,FST,A,B,MS,MWD,MR,MA,
     &     MA2,SH,TH,UH,IDP,DRTYPE
      PARAMETER(ZI=(0.0D0,1.0D0))
      COMMON/HWHEWS/S(8,8,2),D(8,8)
      SAVE O
      DATA O/2,1/
C--compute the propagator factor
      PRE = -ONE/(SH-MS(ID)+ZI*MWD(ID))
      DO 10 P1=1,2
      DO 10 P2=1,2
      DO 10 P3=1,2
      DO 10 P4=1,2
        IF(P1.EQ.P2) THEN
          ME(P1,P2,P3,P4) = PRE*A(P1,ID)*(
     &          B(O(P1),ID)*F3(O(P3),  P1 ,1)*F4(  P1 ,P4,2)
     &         +B(  P1 ,ID)*F3(O(P3),O(P1),2)*F4(O(P1),P4,1))
        ELSE
          ME(P1,P2,P3,P4) = ZERO
        ENDIF
 10   CONTINUE
      END
CDECK  ID>, HWHS02.
*CMZ :-        -02/10/01  10:17:10  by  Peter Richardson
*-- Author :    Peter Richardson
C-----------------------------------------------------------------------
      SUBROUTINE HWHS02(ID,ME)
C-----------------------------------------------------------------------
C  Subroutine to calculate the helicity amplitudes for the 2-to-2 cross
C  section  f fbar ---> fermion fermion via t-channel scalar exchange
C  This diagram 2 from DAMTP-2001-83 with opposite sign of P4
C-----------------------------------------------------------------------
      INCLUDE 'HERWIG65.INC'
      INTEGER NDIAHD
      PARAMETER(NDIAHD=10)
      DOUBLE COMPLEX ME(2,2,2,2),S,D,F3(2,2,8),F4(2,2,8),PRE
     &     ,F3M(2,2,8),F4M(2,2,8),FST(2,2,8),
     &     FTP(2,2,8,8),FTM(2,2,8,8),FUP(2,2,8,8),FUM(2,2,8,8)
      DOUBLE PRECISION A(2,NDIAHD),B(2,NDIAHD),MS(NDIAHD),MWD(NDIAHD),
     &     MA(4),MA2(4),MR(NDIAHD),SH,TH,UH
      INTEGER P1,P2,P3,P4,ID,O(2),IDP(4+NDIAHD),DRTYPE(NDIAHD)
      COMMON/HWSPHC/F3,F4,F3M,F4M,FTP,FTM,FUP,FUM,FST,A,B,MS,MWD,MR,MA,
     &     MA2,SH,TH,UH,IDP,DRTYPE
      COMMON/HWHEWS/S(8,8,2),D(8,8)
      SAVE O
      DATA O/2,1/
C--compute the propagator factor
      PRE = -HALF/(TH-MS(ID))
      DO 10 P1=1,2
      DO 10 P2=1,2
      DO 10 P3=1,2
      DO 10 P4=1,2
 10   ME(P1,P2,P3,P4) = PRE*A(P1,ID)*B(O(P2),ID)*
     &        F3(O(P3),P1,1)*F4(P2,P4,2)
      END
CDECK  ID>, HWHS03.
*CMZ :-        -02/10/01  10:17:10  by  Peter Richardson
*-- Author :    Peter Richardson
C-----------------------------------------------------------------------
      SUBROUTINE HWHS03(ID,ME)
C-----------------------------------------------------------------------
C  Subroutine to calculate the helicity amplitudes for the 2-to-2 cross
C  section  f fbar ---> fermion fermion via u-channel scalar exchange
C  This diagram 3 from DAMTP-2001-83 with opposite sign of P4
C-----------------------------------------------------------------------
      INCLUDE 'HERWIG65.INC'
      INTEGER NDIAHD
      PARAMETER(NDIAHD=10)
      DOUBLE COMPLEX ME(2,2,2,2),S,D,F3(2,2,8),F4(2,2,8),PRE,
     &     F3M(2,2,8),F4M(2,2,8),FST(2,2,8),
     &     FTP(2,2,8,8),FTM(2,2,8,8),FUP(2,2,8,8),FUM(2,2,8,8)
      DOUBLE PRECISION A(2,NDIAHD),B(2,NDIAHD),MS(NDIAHD),MWD(NDIAHD),
     &     MA(4),MA2(4),MR(NDIAHD),SH,TH,UH
      INTEGER P1,P2,P3,P4,ID,O(2),IDP(4+NDIAHD),DRTYPE(NDIAHD)
      COMMON/HWSPHC/F3,F4,F3M,F4M,FTP,FTM,FUP,FUM,FST,A,B,MS,MWD,MR,MA,
     &     MA2,SH,TH,UH,IDP,DRTYPE
      COMMON/HWHEWS/S(8,8,2),D(8,8)
      SAVE O
      DATA O/2,1/
C--compute the propagator factor
      PRE = HALF/(UH-MS(ID))
      DO 10 P1=1,2
      DO 10 P2=1,2
      DO 10 P3=1,2
      DO 10 P4=1,2
 10   ME(P1,P2,P3,P4) = PRE*A(P1,ID)*B(O(P2),ID)*
     &        F4M(O(P4),P1,1)*F3M(P2,P3,2)
      END
CDECK  ID>, HWHS04.
*CMZ :-        -02/10/01  10:17:10  by  Peter Richardson
*-- Author :    Peter Richardson
C-----------------------------------------------------------------------
      SUBROUTINE HWHS04(ID,ME)
C-----------------------------------------------------------------------
C  Subroutine to calculate the helicity amplitudes for the 2-to-2 cross
C  section f fbar --> gauge boson --> fermion antifermion
C  This diagram 1 from DAMTP-2001-83
C-----------------------------------------------------------------------
      INCLUDE 'HERWIG65.INC'
      INTEGER NDIAHD
      PARAMETER(NDIAHD=10)
      DOUBLE COMPLEX ME(2,2,2,2),S,D,F3(2,2,8),F4(2,2,8),PRE,ZI
     &     ,F3M(2,2,8),F4M(2,2,8),FST(2,2,8),
     &     FTP(2,2,8,8),FTM(2,2,8,8),FUP(2,2,8,8),FUM(2,2,8,8)
      DOUBLE PRECISION A(2,NDIAHD),B(2,NDIAHD),MS(NDIAHD),MWD(NDIAHD),
     &     MA(4),MA2(4),MR(NDIAHD),SH,TH,UH
      INTEGER P1,P2,P3,P4,ID,O(2),IDP(4+NDIAHD),DRTYPE(NDIAHD)
      COMMON/HWSPHC/F3,F4,F3M,F4M,FTP,FTM,FUP,FUM,FST,A,B,MS,MWD,MR,MA,
     &     MA2,SH,TH,UH,IDP,DRTYPE
      PARAMETER(ZI=(0.0D0,1.0D0))
      COMMON/HWHEWS/S(8,8,2),D(8,8)
      SAVE O
      DATA O/2,1/
C--compute the propagator factor
      PRE = -ONE/(SH-MS(ID)+ZI*MWD(ID))
      DO 10 P1=1,2
      DO 10 P2=1,2
      DO 10 P3=1,2
      DO 10 P4=1,2
        IF(P1.EQ.P2) THEN
          ME(P1,P2,P3,P4) = PRE*A(P1,ID)*(
     &          B(O(P1),ID)*F3(O(P3),  P1 ,1)*F4(  P1 ,O(P4),2)
     &         +B(  P1 ,ID)*F3(O(P3),O(P1),2)*F4(O(P1),O(P4),1))
        ELSE
          ME(P1,P2,P3,P4) = (0.0D0,0.0D0)
        ENDIF
 10   CONTINUE
      END
CDECK  ID>, HWHS05.
*CMZ :-        -02/10/01  10:17:10  by  Peter Richardson
*-- Author :    Peter Richardson
C-----------------------------------------------------------------------
      SUBROUTINE HWHS05(ID,ME)
C-----------------------------------------------------------------------
C  Subroutine to calculate the helicity amplitudes for the 2-to-2 cross
C  section gluon gluon --> fermion antifermion (1st colour flow)
C  N.B. a gauge choice has been made to simplify the triple gluon vertex
C  This diagram 4 from DAMTP-2001-83 with the gauge choice L1=2 L2=1
C-----------------------------------------------------------------------
      INCLUDE 'HERWIG65.INC'
      INTEGER NDIAHD
      PARAMETER(NDIAHD=10)
      DOUBLE COMPLEX ME(2,2,2,2),S,D,F3(2,2,8),F4(2,2,8),PRE,ZI
     &     ,F3M(2,2,8),F4M(2,2,8),FST(2,2,8),
     &     FTP(2,2,8,8),FTM(2,2,8,8),FUP(2,2,8,8),FUM(2,2,8,8)
      DOUBLE PRECISION A(2,NDIAHD),B(2,NDIAHD),MS(NDIAHD),MWD(NDIAHD),
     &     MA(4),MA2(4),MR(NDIAHD),SH,TH,UH
      INTEGER P1,P2,P3,P4,ID,O(2),IDP(4+NDIAHD),DRTYPE(NDIAHD)
      COMMON/HWSPHC/F3,F4,F3M,F4M,FTP,FTM,FUP,FUM,FST,A,B,MS,MWD,MR,MA,
     &     MA2,SH,TH,UH,IDP,DRTYPE
      PARAMETER(ZI=(0.0D0,1.0D0))
      COMMON/HWHEWS/S(8,8,2),D(8,8)
      SAVE O
      DATA O/2,1/
C--compute the propagator factor
      PRE =+ONE/SH/(TH-MS(ID))
      DO 10 P1=1,2
      DO 10 P2=1,2
      DO 10 P3=1,2
      DO 10 P4=1,2
 10   ME(P1,P2,P3,P4) = PRE*(
     &  F3(O(P3),  P1 ,2)*( FTP(  P1 ,  P2 ,1,1)*F4(  P2 ,O(P4),2)
     &                     +FTP(  P1 ,O(P2),1,2)*F4(O(P2),O(P4),1))
     & +F3(O(P3),O(P1),1)*( FTP(O(P1),  P2 ,2,1)*F4(  P2 ,O(P4),2)
     &                     +FTP(O(P1),O(P2),2,2)*F4(O(P2),O(P4),1)))
      END
CDECK  ID>, HWHS06.
*CMZ :-        -02/10/01  10:17:10  by  Peter Richardson
*-- Author :    Peter Richardson
C-----------------------------------------------------------------------
      SUBROUTINE HWHS06(ID,ME)
C-----------------------------------------------------------------------
C  Subroutine to calculate the helicity amplitudes for the 2-to-2 cross
C  section gluon gluon --> fermion antifermion (2st colour flow)
C  N.B. a gauge choice has been made to simplify the triple gluon vertex
C  This diagram 5 from DAMTP-2001-83 with the gauge choice L1=2 L2=1
C-----------------------------------------------------------------------
      INCLUDE 'HERWIG65.INC'
      INTEGER NDIAHD
      PARAMETER(NDIAHD=10)
      DOUBLE COMPLEX ME(2,2,2,2),S,D,F3(2,2,8),F4(2,2,8),PRE,ZI
     &     ,F3M(2,2,8),F4M(2,2,8),FST(2,2,8),
     &     FTP(2,2,8,8),FTM(2,2,8,8),FUP(2,2,8,8),FUM(2,2,8,8)
      DOUBLE PRECISION A(2,NDIAHD),B(2,NDIAHD),MS(NDIAHD),MWD(NDIAHD),
     &     MA(4),MA2(4),MR(NDIAHD),SH,TH,UH
      INTEGER P1,P2,P3,P4,ID,O(2),IDP(4+NDIAHD),DRTYPE(NDIAHD)
      COMMON/HWSPHC/F3,F4,F3M,F4M,FTP,FTM,FUP,FUM,FST,A,B,MS,MWD,MR,MA,
     &     MA2,SH,TH,UH,IDP,DRTYPE
      PARAMETER(ZI=(0.0D0,1.0D0))
      COMMON/HWHEWS/S(8,8,2),D(8,8)
      SAVE O
      DATA O/2,1/
C--compute the propagator factor
      PRE =-ONE/SH/(UH-MS(ID))
      DO 10 P1=1,2
      DO 10 P2=1,2
      DO 10 P3=1,2
      DO 10 P4=1,2
 10   ME(P1,P2,P3,P4) = PRE*(
     &     F3(O(P3),  P2 ,1)*( FUP(  P2 ,  P1 ,2,2)*F4(  P1 ,O(P4),1)
     &                        +FUP(  P2 ,O(P1),2,1)*F4(O(P1),O(P4),2))
     &    +F3(O(P3),O(P2),2)*( FUP(O(P2),  P1 ,1,2)*F4(  P1 ,O(P4),1)
     &                        +FUP(O(P2),O(P1),1,1)*F4(O(P1),O(P4),2)))
      END
CDECK  ID>, HWHS07.
*CMZ :-        -02/10/01  10:17:10  by  Peter Richardson
*-- Author :    Peter Richardson
C-----------------------------------------------------------------------
      SUBROUTINE HWHS07(ID,ME)
C-----------------------------------------------------------------------
C  Subroutine to calculate the helicity amplitudes for the 2-to-2 cross
C  section gluon gluon --> fermion antifermion (triple gluon piece)
C  N.B. a gauge choice has been made to simplify the triple gluon vertex
C  This diagram 6 from DAMTP-2001-83 with the gauge choice L1=2 L2=1
C-----------------------------------------------------------------------
      INCLUDE 'HERWIG65.INC'
      INTEGER NDIAHD
      PARAMETER(NDIAHD=10)
      DOUBLE COMPLEX ME(2,2,2,2),S,D,F3(2,2,8),F4(2,2,8),PRE,ZI
     &     ,F3M(2,2,8),F4M(2,2,8),MET,FST(2,2,8),
     &     FTP(2,2,8,8),FTM(2,2,8,8),FUP(2,2,8,8),FUM(2,2,8,8)
      DOUBLE PRECISION A(2,NDIAHD),B(2,NDIAHD),MS(NDIAHD),MWD(NDIAHD),
     &     MA(4),MA2(4),MR(NDIAHD),SH,TH,UH
      INTEGER I,P1,P2,P3,P4,ID,O(2),IDP(4+NDIAHD),DRTYPE(NDIAHD)
      COMMON/HWSPHC/F3,F4,F3M,F4M,FTP,FTM,FUP,FUM,FST,A,B,MS,MWD,MR,MA,
     &     MA2,SH,TH,UH,IDP,DRTYPE
      PARAMETER(ZI=(0.0D0,1.0D0))
      COMMON/HWHEWS/S(8,8,2),D(8,8)
      SAVE O
      DATA O/2,1/
C--compute the propagator factor
      PRE = HALF/SH**2
      DO 10 P3=1,2
      DO 10 P4=1,2
      MET = (0.0D0,0.0D0)
      DO 5 I=1,2
 5    MET=MET+F3(O(P3),I,1)*F4(I,O(P4),1)-F3(O(P3),I,2)*F4(I,O(P4),2)
      DO 10 P1=1,2
      DO 10 P2=1,2
      IF(P1.EQ.P2) THEN
        ME(P1,P2,P3,P4) = PRE*S(1,2,P1)*S(1,2,O(P1))*MET
      ELSE
        ME(P1,P2,P3,P4) = (0.0D0,0.0D0)
      ENDIF
 10   CONTINUE
      END
CDECK  ID>, HWHS08.
*CMZ :-        -02/10/01  10:17:10  by  Peter Richardson
*-- Author :    Peter Richardson
C-----------------------------------------------------------------------
      SUBROUTINE HWHS08(ID,ME)
C-----------------------------------------------------------------------
C  Subroutine to calculate the helicity amplitudes for the 2-to-2 cross
C  section quark gluon --> fermion sfermion
C  This diagram 7 from DAMTP-2001-83 with the gauge choice L2=1
C-----------------------------------------------------------------------
      INCLUDE 'HERWIG65.INC'
      INTEGER NDIAHD
      PARAMETER(NDIAHD=10)
      DOUBLE COMPLEX ME(2,2,2,2),S,D,F3(2,2,8),F4(2,2,8),PRE,ZI
     &     ,F3M(2,2,8),F4M(2,2,8),FST(2,2,8),
     &     FTP(2,2,8,8),FTM(2,2,8,8),FUP(2,2,8,8),FUM(2,2,8,8)
      DOUBLE PRECISION A(2,NDIAHD),B(2,NDIAHD),MS(NDIAHD),MWD(NDIAHD),
     &     MA(4),MA2(4),MR(NDIAHD),SH,TH,UH,HWULDO,XMASS,PLAB,PRW,PCM
      INTEGER P1,P2,P3,ID,O(2),IDP(4+NDIAHD),DRTYPE(NDIAHD)
      COMMON/HWSPHC/F3,F4,F3M,F4M,FTP,FTM,FUP,FUM,FST,A,B,MS,MWD,MR,MA,
     &     MA2,SH,TH,UH,IDP,DRTYPE
      PARAMETER(ZI=(0.0D0,1.0D0))
      COMMON/HWHEWS/S(8,8,2),D(8,8)
      COMMON/HWHEWP/XMASS(10),PLAB(5,10),PRW(5,2),PCM(5,10)
      EXTERNAL HWULDO
      SAVE O
      DATA O/2,1/
C--compute the propagator factor
      PRE = HALF*SQRT(HWULDO(PCM(1,8),PCM(1,4)))/SQRT(TWO)/
     &      SQRT(HWULDO(PCM(1,1),PCM(1,2)))/
     &        (TH-MS(ID))
      DO 10 P1=1,2
      DO 10 P2=1,2
      DO 10 P3=1,2
      ME(P1,P2,P3,2) = ZERO
 10   ME(P1,P2,P3,1) = A(P1,ID)*PRE*FST(P2,P2,1)*F3(O(P3),  P1,1)
      END
CDECK  ID>, HWHS09.
*CMZ :-        -02/10/01  10:17:10  by  Peter Richardson
*-- Author :    Peter Richardson
C-----------------------------------------------------------------------
      SUBROUTINE HWHS09(ID,ME)
C-----------------------------------------------------------------------
C  Subroutine to calculate the helicity amplitudes for the 2-to-2 cross
C  section antiquark gluon --> fermion antisfermion
C  This diagram 10 from DAMTP-2001-83 with the gauge choice L2=1
C-----------------------------------------------------------------------
      INCLUDE 'HERWIG65.INC'
      INTEGER NDIAHD
      PARAMETER(NDIAHD=10)
      DOUBLE COMPLEX ME(2,2,2,2),S,D,F3(2,2,8),F4(2,2,8),PRE,ZI
     &     ,F3M(2,2,8),F4M(2,2,8),FST(2,2,8),
     &     FTP(2,2,8,8),FTM(2,2,8,8),FUP(2,2,8,8),FUM(2,2,8,8)
      DOUBLE PRECISION A(2,NDIAHD),B(2,NDIAHD),MS(NDIAHD),MWD(NDIAHD),
     &     MA(4),MA2(4),MR(NDIAHD),SH,TH,UH,HWULDO,XMASS,PLAB,PRW,PCM
      INTEGER P1,P2,P3,ID,O(2),IDP(4+NDIAHD),DRTYPE(NDIAHD)
      COMMON/HWSPHC/F3,F4,F3M,F4M,FTP,FTM,FUP,FUM,FST,A,B,MS,MWD,MR,MA,
     &     MA2,SH,TH,UH,IDP,DRTYPE
      PARAMETER(ZI=(0.0D0,1.0D0))
      COMMON/HWHEWS/S(8,8,2),D(8,8)
      COMMON/HWHEWP/XMASS(10),PLAB(5,10),PRW(5,2),PCM(5,10)
      EXTERNAL HWULDO
      SAVE O
      DATA O/2,1/
C--compute the propagator factor
      PRE = HALF*SQRT(HWULDO(PCM(1,8),PCM(1,4)))/SQRT(TWO)/
     &      SQRT(HWULDO(PCM(1,1),PCM(1,2)))/
     &        (TH-MS(ID))
      DO 10 P1=1,2
      DO 10 P2=1,2
      DO 10 P3=1,2
      ME(P1,P2,P3,2) = ZERO
  10  ME(P1,P2,P3,1) = A(O(P1),ID)*PRE*FST(P2,P2,1)*F3M(P1,P3,1)
      END
CDECK  ID>, HWHS10.
*CMZ :-        -02/10/01  10:17:10  by  Peter Richardson
*-- Author :    Peter Richardson
C-----------------------------------------------------------------------
      SUBROUTINE HWHS10(ID,ME)
C-----------------------------------------------------------------------
C  Subroutine to calculate the helicity amplitudes for the 2-to-2 cross
C  section quark gluon --> fermion antisfermion (s-channel quark)
C  This is diagram 8 from DAMTP-2001-83 with the gauge choice L2=1
C-----------------------------------------------------------------------
      INCLUDE 'HERWIG65.INC'
      INTEGER NDIAHD
      PARAMETER(NDIAHD=10)
      DOUBLE COMPLEX ME(2,2,2,2),S,D,F3(2,2,8),F4(2,2,8),PRE,ZI
     &     ,F3M(2,2,8),F4M(2,2,8),FST(2,2,8),
     &     FTP(2,2,8,8),FTM(2,2,8,8),FUP(2,2,8,8),FUM(2,2,8,8)
      DOUBLE PRECISION A(2,NDIAHD),B(2,NDIAHD),MS(NDIAHD),MWD(NDIAHD),
     &     MA(4),MA2(4),MR(NDIAHD),SH,TH,UH,HWULDO,XMASS,PLAB,PRW,PCM
      INTEGER P1,P2,P3,ID,O(2),IDP(4+NDIAHD),DRTYPE(NDIAHD)
      COMMON/HWSPHC/F3,F4,F3M,F4M,FTP,FTM,FUP,FUM,FST,A,B,MS,MWD,MR,MA,
     &     MA2,SH,TH,UH,IDP,DRTYPE
      PARAMETER(ZI=(0.0D0,1.0D0))
      COMMON/HWHEWS/S(8,8,2),D(8,8)
      COMMON/HWHEWP/XMASS(10),PLAB(5,10),PRW(5,2),PCM(5,10)
      EXTERNAL HWULDO
      SAVE O
      DATA O/2,1/
C--compute the propagator factor
      PRE = SQRT(HWULDO(PCM(1,8),PCM(1,4)))/SQRT(TWO)/
     &      SQRT(HWULDO(PCM(1,1),PCM(1,2)))/SH
      DO 10 P1=1,2
      DO 10 P2=1,2
      DO 10 P3=1,2
      IF(P1.EQ.P2) THEN
        ME(p1,p2,p3,1) = PRE*A(  P2 ,ID)*F3(O(P3),  P2 ,1)*S(1,2,P2)*
     &        S(1,1,O(P2))
      ELSE
        ME(P1,P2,P3,1) = PRE*
     &      A(O(P2),ID)*( F3(O(P3),O(P2),1)*S(1,1,O(P2))
     &                   +F3(O(P3),O(P2),2)*S(2,1,O(P2)))*S(2,1,P2)
      ENDIF
 10   ME(P1,P2,P3,2) = ZERO
      END
CDECK  ID>, HWHS11.
*CMZ :-        -02/10/01  10:17:10  by  Peter Richardson
*-- Author :    Peter Richardson
C-----------------------------------------------------------------------
      SUBROUTINE HWHS11(ID,ME)
C-----------------------------------------------------------------------
C  Subroutine to calculate the helicity amplitudes for the 2-to-2 cross
C  section quark gluon --> fermion antisfermion (s-channel quark)
C  This is diagram 11 from DAMTP-2001-83 with the gauge choice L2=1
C-----------------------------------------------------------------------
      INCLUDE 'HERWIG65.INC'
      INTEGER NDIAHD
      PARAMETER(NDIAHD=10)
      DOUBLE COMPLEX ME(2,2,2,2),S,D,F3(2,2,8),F4(2,2,8),PRE,ZI
     &     ,F3M(2,2,8),F4M(2,2,8),FST(2,2,8),
     &     FTP(2,2,8,8),FTM(2,2,8,8),FUP(2,2,8,8),FUM(2,2,8,8)
      DOUBLE PRECISION A(2,NDIAHD),B(2,NDIAHD),MS(NDIAHD),MWD(NDIAHD),
     &     MA(4),MA2(4),MR(NDIAHD),SH,TH,UH,HWULDO,XMASS,PLAB,PRW,PCM
      INTEGER P1,P2,P3,ID,O(2),IDP(4+NDIAHD),DRTYPE(NDIAHD)
      COMMON/HWSPHC/F3,F4,F3M,F4M,FTP,FTM,FUP,FUM,FST,A,B,MS,MWD,MR,MA,
     &     MA2,SH,TH,UH,IDP,DRTYPE
      PARAMETER(ZI=(0.0D0,1.0D0))
      COMMON/HWHEWS/S(8,8,2),D(8,8)
      COMMON/HWHEWP/XMASS(10),PLAB(5,10),PRW(5,2),PCM(5,10)
      EXTERNAL HWULDO
      SAVE O
      DATA O/2,1/
C--compute the propagator factor
      PRE = SQRT(HWULDO(PCM(1,8),PCM(1,4)))/SQRT(TWO)/
     &      SQRT(HWULDO(PCM(1,1),PCM(1,2)))/SH
      DO 10 P1=1,2
      DO 10 P2=1,2
      DO 10 P3=1,2
      IF(P1.EQ.P2) THEN
        ME(P1,P2,P3,1) = PRE*A(O(P2),ID)*S(1,2,P1)*
     &        (S(1,1,O(P2))*F3M(P2,P3,1)+S(1,2,O(P2))*F3M(P2,P3,2))
      ELSE
        ME(P1,P2,P3,1)=PRE*A(P2,ID)*S(1,1,P1)*S(2,1,P2)*F3M(O(P2),P3,1)
      ENDIF
 10   ME(P1,P2,P3,2) = ZERO
      END
CDECK  ID>, HWHS12.
*CMZ :-        -02/10/01  10:17:10  by  Peter Richardson
*-- Author :    Peter Richardson
C-----------------------------------------------------------------------
      SUBROUTINE HWHS12(ID,ME)
C-----------------------------------------------------------------------
C  Subroutine to calculate the helicity amplitudes for the 2-to-2 cross
C  section quark gluon --> fermion antisfermion (s-channel quark)
C  This is diagram 9 from DAMTP-2001-83 with the gauge choice L2=1
C-----------------------------------------------------------------------
      INCLUDE 'HERWIG65.INC'
      INTEGER NDIAHD
      PARAMETER(NDIAHD=10)
      DOUBLE COMPLEX ME(2,2,2,2),S,D,F3(2,2,8),F4(2,2,8),PRE,ZI
     &     ,F3M(2,2,8),F4M(2,2,8),FST(2,2,8),
     &     FTP(2,2,8,8),FTM(2,2,8,8),FUP(2,2,8,8),FUM(2,2,8,8)
      DOUBLE PRECISION A(2,NDIAHD),B(2,NDIAHD),MS(NDIAHD),MWD(NDIAHD),
     &     MA(4),MA2(4),MR(NDIAHD),SH,TH,UH,HWULDO,XMASS,PLAB,PRW,PCM
      INTEGER P1,P2,P3,ID,O(2),IDP(4+NDIAHD),DRTYPE(NDIAHD)
      COMMON/HWSPHC/F3,F4,F3M,F4M,FTP,FTM,FUP,FUM,FST,A,B,MS,MWD,MR,MA,
     &     MA2,SH,TH,UH,IDP,DRTYPE
      PARAMETER(ZI=(0.0D0,1.0D0))
      COMMON/HWHEWS/S(8,8,2),D(8,8)
      COMMON/HWHEWP/XMASS(10),PLAB(5,10),PRW(5,2),PCM(5,10)
      EXTERNAL HWULDO
      SAVE O
      DATA O/2,1/
C--compute the propagator factor
      PRE =-SQRT(HWULDO(PCM(1,8),PCM(1,4)))/SQRT(TWO)/
     &      SQRT(HWULDO(PCM(1,1),PCM(1,2)))/(UH-MS(ID))
      DO 10 P1=1,2
      DO 10 P2=1,2
      DO 10 P3=1,2
      ME(P1,P2,P3,1) = PRE*A(P1,ID)*(
     &                       F3(O(P3),  P2 ,1)*FUP(  P2 ,P1, 2,1)
     &                      +F3(O(P3),O(P2), 2)*FUP(O(P2),P1,1,1))
 10   ME(P1,P2,P3,2) = ZERO
      END
CDECK  ID>, HWHS13.
*CMZ :-        -02/10/01  10:17:10  by  Peter Richardson
*-- Author :    Peter Richardson
C-----------------------------------------------------------------------
      SUBROUTINE HWHS13(ID,ME)
C-----------------------------------------------------------------------
C  Subroutine to calculate the helicity amplitudes for the 2-to-2 cross
C  section quark gluon --> fermion antisfermion (s-channel quark)
C  This is diagram 12 from DAMTP-2001-83 with the gauge choice L2=1
C-----------------------------------------------------------------------
      INCLUDE 'HERWIG65.INC'
      INTEGER NDIAHD
      PARAMETER(NDIAHD=10)
      DOUBLE COMPLEX ME(2,2,2,2),S,D,F3(2,2,8),F4(2,2,8),PRE,ZI
     &     ,F3M(2,2,8),F4M(2,2,8),FST(2,2,8),
     &     FTP(2,2,8,8),FTM(2,2,8,8),FUP(2,2,8,8),FUM(2,2,8,8)
      DOUBLE PRECISION A(2,NDIAHD),B(2,NDIAHD),MS(NDIAHD),MWD(NDIAHD),
     &     MA(4),MA2(4),MR(NDIAHD),SH,TH,UH,HWULDO,XMASS,PLAB,PRW,PCM
      INTEGER P1,P2,P3,ID,O(2),IDP(4+NDIAHD),DRTYPE(NDIAHD)
      COMMON/HWSPHC/F3,F4,F3M,F4M,FTP,FTM,FUP,FUM,FST,A,B,MS,MWD,MR,MA,
     &     MA2,SH,TH,UH,IDP,DRTYPE
      PARAMETER(ZI=(0.0D0,1.0D0))
      COMMON/HWHEWS/S(8,8,2),D(8,8)
      COMMON/HWHEWP/XMASS(10),PLAB(5,10),PRW(5,2),PCM(5,10)
      EXTERNAL HWULDO
      SAVE O
      DATA O/2,1/
C--compute the propagator factor
      PRE =-SQRT(HWULDO(PCM(1,8),PCM(1,4)))/SQRT(TWO)/
     &      SQRT(HWULDO(PCM(1,1),PCM(1,2)))/(UH-MS(ID))
      DO 10 P1=1,2
      DO 10 P2=1,2
      DO 10 P3=1,2
      ME(P1,P2,P3,1) = PRE*A(O(P1),ID)*(
     &                       FUM(P1,  P2 ,1,1)*F3M(  P2 ,P3, 2)
     &                      +FUM(P1,O(P2),1, 2)*F3M(O(P2),P3,1))
 10   ME(P1,P2,P3,2) = ZERO
      END
CDECK  ID>, HWHS14.
*CMZ :-        -02/10/01  10:17:10  by  Peter Richardson
*-- Author :    Peter Richardson
C-----------------------------------------------------------------------
      SUBROUTINE HWHS14(ID,ME)
C-----------------------------------------------------------------------
C  Subroutine to calculate the helicity amplitudes for the 2-to-2 cross
C  section gluon gluon --> fermion antifermion (1st colour flow)
C  N.B. a gauge choice has been made to simplify the triple gluon vertex
C  This diagram 4 from DAMTP-2001-83 with opposite helicity for 4
C  and gauge choice L1=2 L2=1
C-----------------------------------------------------------------------
      INCLUDE 'HERWIG65.INC'
      INTEGER NDIAHD
      PARAMETER(NDIAHD=10)
      DOUBLE COMPLEX ME(2,2,2,2),S,D,F3(2,2,8),F4(2,2,8),PRE,ZI,
     &     F3M(2,2,8),F4M(2,2,8),FST(2,2,8),FTP(2,2,8,8),FTM(2,2,8,8),
     &     FUP(2,2,8,8),FUM(2,2,8,8)
      DOUBLE PRECISION A(2,NDIAHD),B(2,NDIAHD),MS(NDIAHD),MWD(NDIAHD),
     &     MA(4),MA2(4),MR(NDIAHD),SH,TH,UH
      INTEGER P1,P2,P3,P4,ID,O(2),IDP(4+NDIAHD),DRTYPE(NDIAHD)
      COMMON/HWSPHC/F3,F4,F3M,F4M,FTP,FTM,FUP,FUM,FST,A,B,MS,MWD,MR,MA,
     &     MA2,SH,TH,UH,IDP,DRTYPE
      PARAMETER(ZI=(0.0D0,1.0D0))
      COMMON/HWHEWS/S(8,8,2),D(8,8)
      SAVE O
      DATA O/2,1/
C--compute the propagator factor
      PRE =+ONE/(TH-MS(ID))/SH
C--matrix element
      DO 10 P1=1,2
      DO 10 P2=1,2
      DO 10 P3=1,2
      DO 10 P4=1,2
 10   ME(P1,P2,P3,P4) = PRE*(
     &  F3(O(P3),  P1 ,2)*( FTP(  P1 ,  P2 , 1,1)*F4(  P2 ,P4,2)
     &                     +FTP(  P1 ,O(P2), 1,2)*F4(O(P2),P4,1))
     & +F3(O(P3),O(P1),1)*( FTP(O(P1),  P2 ,2,1)*F4(  P2 ,P4,2)
     &                     +FTP(O(P1),O(P2),2,2)*F4(O(P2),P4,1)))
      END
CDECK  ID>, HWHS15.
*CMZ :-        -02/10/01  10:17:10  by  Peter Richardson
*-- Author :    Peter Richardson
C-----------------------------------------------------------------------
      SUBROUTINE HWHS15(ID,ME)
C-----------------------------------------------------------------------
C  Subroutine to calculate the helicity amplitudes for the 2-to-2 cross
C  section gluon gluon --> fermion antifermion (2st colour flow)
C  N.B. a gauge choice has been made to simplify the triple gluon vertex
C  This diagram 5 from DAMTP-2001-83 with opposite helicity for 4
C  and gauge choice L1=2 L2=1
C-----------------------------------------------------------------------
      INCLUDE 'HERWIG65.INC'
      INTEGER NDIAHD
      PARAMETER(NDIAHD=10)
      DOUBLE COMPLEX ME(2,2,2,2),S,D,F3(2,2,8),F4(2,2,8),PRE,ZI,
     &     F3M(2,2,8),F4M(2,2,8),FST(2,2,8),FTP(2,2,8,8),FTM(2,2,8,8),
     &     FUP(2,2,8,8),FUM(2,2,8,8)
      DOUBLE PRECISION A(2,NDIAHD),B(2,NDIAHD),MS(NDIAHD),MWD(NDIAHD),
     &     MA(4),MA2(4),MR(NDIAHD),SH,TH,UH
      INTEGER P1,P2,P3,P4,ID,O(2),IDP(4+NDIAHD),DRTYPE(NDIAHD)
      COMMON/HWSPHC/F3,F4,F3M,F4M,FTP,FTM,FUP,FUM,FST, A,B,MS,MWD,MR,MA,
     &    MA2,SH,TH,UH,IDP,DRTYPE
      PARAMETER(ZI=(0.0D0,1.0D0))
      COMMON/HWHEWS/S(8,8,2),D(8,8)
      SAVE O
      DATA O/2,1/
C--compute the propagator factor
      PRE =-ONE/(UH-MS(ID))/SH
C--matrix element
      DO 10 P1=1,2
      DO 10 P2=1,2
      DO 10 P3=1,2
      DO 10 P4=1,2
 10   ME(P1,P2,P3,P4) = PRE*(
     & F3(O(P3),  P2 ,1)*( FUP(  P2 ,  P1 ,2,2)*F4(  P1 ,P4,1)
     &                    +FUP(  P2 ,O(P1),2,1)*F4(O(P1),P4,2))
     &+F3(O(P3),O(P2),2)*( FUP(O(P2),  P1 ,1,2)*F4(  P1 ,P4,1)
     &                    +FUP(O(P2),O(P1),1,1)*F4(O(P1),P4,2)))
      END
CDECK  ID>, HWHS16.
*CMZ :-        -02/10/01  10:17:10  by  Peter Richardson
*-- Author :    Peter Richardson
C-----------------------------------------------------------------------
      SUBROUTINE HWHS16(ID,ME)
C-----------------------------------------------------------------------
C  Subroutine to calculate the helicity amplitudes for the 2-to-2 cross
C  section gluon gluon --> fermion antifermion (triple gluon piece)
C  N.B. a gauge choice has been made to simplify the triple gluon vertex
C  This diagram 6 from DAMTP-2001-83 with opposite helicity for 4
C  and gauge choice L1=2 L2=1
C-----------------------------------------------------------------------
      INCLUDE 'HERWIG65.INC'
      INTEGER NDIAHD
      PARAMETER(NDIAHD=10)
      DOUBLE COMPLEX ME(2,2,2,2),S,D,F3(2,2,8),F4(2,2,8),PRE,ZI
     &     ,F3M(2,2,8),F4M(2,2,8),MET,FST(2,2,8),
     &     FTP(2,2,8,8),FTM(2,2,8,8),FUP(2,2,8,8),FUM(2,2,8,8)
      DOUBLE PRECISION A(2,NDIAHD),B(2,NDIAHD),MS(NDIAHD),MWD(NDIAHD),
     &     MA(4),MA2(4),MR(NDIAHD),SH,TH,UH
      INTEGER I,P1,P2,P3,P4,ID,O(2),IDP(4+NDIAHD),DRTYPE(NDIAHD)
      COMMON/HWSPHC/F3,F4,F3M,F4M,FTP,FTM,FUP,FUM,FST,A,B,MS,MWD,MR,MA,
     &     MA2,SH,TH,UH,IDP,DRTYPE
      PARAMETER(ZI=(0.0D0,1.0D0))
      COMMON/HWHEWS/S(8,8,2),D(8,8)
      SAVE O
      DATA O/2,1/
C--compute the propagator factor
      PRE = HALF/SH**2
C--matrix element
      DO 10 P3=1,2
      DO 10 P4=1,2
      MET = (0.0D0,0.0D0)
      DO 5 I=1,2
 5    MET=MET+F3(O(P3),I,1)*F4(I,P4,1)-F3(O(P3),I,2)*F4(I,P4,2)
      DO 10 P1=1,2
      DO 10 P2=1,2
      IF(P1.EQ.P2) THEN
        ME(P1,P2,P3,P4) = PRE*MET*S(1,2,P1)*S(1,2,O(P1))
      ELSE
        ME(P1,P2,P3,P4) = (0.0D0,0.0D0)
      ENDIF
 10   CONTINUE
      END
CDECK  ID>, HWHS17.
*CMZ :-        -02/10/01  10:17:10  by  Peter Richardson
*-- Author :    Peter Richardson
C-----------------------------------------------------------------------
      SUBROUTINE HWHS17(ID,ME)
C-----------------------------------------------------------------------
C  Subroutine to calculate the helicity amplitudes for the 2-to-2 cross
C  section fermion fermion --> fermion fermion (t-channel boson)
C  This diagram 13 from DAMTP-2001-83
C-----------------------------------------------------------------------
      INCLUDE 'HERWIG65.INC'
      INTEGER NDIAHD
      PARAMETER(NDIAHD=10)
      DOUBLE COMPLEX ME(2,2,2,2),S,D,F3(2,2,8),F4(2,2,8),PRE,ZI,
     &     F3M(2,2,8),F4M(2,2,8),FST(2,2,8),
     &     FTP(2,2,8,8),FTM(2,2,8,8),FUP(2,2,8,8),FUM(2,2,8,8),DL(2,2)
      DOUBLE PRECISION A(2,NDIAHD),B(2,NDIAHD),MS(NDIAHD),MWD(NDIAHD),
     &     MA(4),MA2(4),MR(NDIAHD),SH,TH,UH,HWULDO,XMASS,PLAB,PRW,PCM
      INTEGER P1,P2,P3,P4,ID,O(2),IDP(4+NDIAHD),DRTYPE(NDIAHD)
      COMMON/HWSPHC/F3,F4,F3M,F4M,FTP,FTM,FUP,FUM,FST,A,B,MS,MWD,MR,MA,
     &     MA2,SH,TH,UH,IDP,DRTYPE
      PARAMETER(ZI=(0.0D0,1.0D0))
      COMMON/HWHEWS/S(8,8,2),D(8,8)
      COMMON/HWHEWP/XMASS(10),PLAB(5,10),PRW(5,2),PCM(5,10)
      EXTERNAL HWULDO
      SAVE O,DL
      DATA O/2,1/
      DATA DL/(1.0,0.0D0),(0.0D0,0.0D0),(0.0D0,0.0D0),(1.0D0,0.0D0)/
C--compute the propagator factor
      PRE = SQRT(TWO*HWULDO(PCM(1,8),PCM(1,4)))/(TH-MS(ID))
      DO 10 P1=1,2
      DO 10 P2=1,2
      DO 10 P3=1,2
      DO 10 P4=1,2
        IF(P2.EQ.P4) THEN
          ME(P1,P2,P3,P4) = PRE*A(P1,ID)*B(P2,ID)*
     &          ( DL(P1,O(P2))*F3(O(P3),  P2 ,2)*S(4,1,  P2 )
     &           +DL(P1,  P2 )*F3(O(P3),O(P2),4)*S(2,1,O(P2)))
        ELSE
          ME(P1,P2,P3,P4) = (0.0D0,0.0D0)
        ENDIF
 10   CONTINUE
      END
CDECK  ID>, HWHS18.
*CMZ :-        -02/10/01  10:17:10  by  Peter Richardson
*-- Author :    Peter Richardson
C-----------------------------------------------------------------------
      SUBROUTINE HWHS18(ID,ME)
C-----------------------------------------------------------------------
C  Subroutine to calculate the helicity amplitudes for the 2-to-2 cross
C  section fermion antifermion --> fermion antifermion (t-channel boson)
C  This diagram 14 from DAMTP-2001-83
C-----------------------------------------------------------------------
      INCLUDE 'HERWIG65.INC'
      INTEGER NDIAHD
      PARAMETER(NDIAHD=10)
      DOUBLE COMPLEX ME(2,2,2,2),S,D,F3(2,2,8),F4(2,2,8),PRE,ZI,
     &     F3M(2,2,8),F4M(2,2,8),FST(2,2,8),
     &     FTP(2,2,8,8),FTM(2,2,8,8),FUP(2,2,8,8),FUM(2,2,8,8),DL(2,2)
      DOUBLE PRECISION A(2,NDIAHD),B(2,NDIAHD),MS(NDIAHD),MWD(NDIAHD),
     &     MA(4),MA2(4),MR(NDIAHD),SH,TH,UH,HWULDO,XMASS,PLAB,PRW,PCM
      INTEGER P1,P2,P3,P4,ID,O(2),IDP(4+NDIAHD),DRTYPE(NDIAHD)
      COMMON/HWSPHC/F3,F4,F3M,F4M,FTP,FTM,FUP,FUM,FST,A,B,MS,MWD,MR,MA,
     &     MA2,SH,TH,UH,IDP,DRTYPE
      PARAMETER(ZI=(0.0D0,1.0D0))
      COMMON/HWHEWS/S(8,8,2),D(8,8)
      COMMON/HWHEWP/XMASS(10),PLAB(5,10),PRW(5,2),PCM(5,10)
      EXTERNAL HWULDO
      SAVE O,DL
      DATA O/2,1/
      DATA DL/(1.0,0.0D0),(0.0D0,0.0D0),(0.0D0,0.0D0),(1.0D0,0.0D0)/
C--compute the propagator factor
      PRE = SQRT(TWO*HWULDO(PCM(1,8),PCM(1,4)))/(TH-MS(ID))
      DO 10 P1=1,2
      DO 10 P2=1,2
      DO 10 P3=1,2
      DO 10 P4=1,2
        IF(P2.EQ.P4) THEN
          ME(P1,P2,P3,P4) = PRE*A(P1,ID)*B(P2,ID)*
     &          ( DL(P1,O(P2))*F3(O(P3),  P2 ,4)*S(2,1,  P2 )
     &           +DL(P1,  P2 )*F3(O(P3),O(P2),2)*S(4,1,O(P2)))
        ELSE
          ME(P1,P2,P3,P4) = (0.0D0,0.0D0)
        ENDIF
 10   CONTINUE
      END
CDECK  ID>, HWHS19.
*CMZ :-        -02/10/01  10:17:10  by  Peter Richardson
*-- Author :    Peter Richardson
C-----------------------------------------------------------------------
      SUBROUTINE HWHS19(ID,ME)
C-----------------------------------------------------------------------
C  Subroutine to calculate the helicity amplitudes for the 2-to-2 cross
C  section antifermion fermion --> antifermion fermion (t-channel boson)
C  This diagram 15 from DAMTP-2001-83
C-----------------------------------------------------------------------
      INCLUDE 'HERWIG65.INC'
      INTEGER NDIAHD
      PARAMETER(NDIAHD=10)
      DOUBLE COMPLEX ME(2,2,2,2),S,D,F3(2,2,8),F4(2,2,8),PRE,ZI,
     &     F3M(2,2,8),F4M(2,2,8),FST(2,2,8),
     &     FTP(2,2,8,8),FTM(2,2,8,8),FUP(2,2,8,8),FUM(2,2,8,8),DL(2,2)
      DOUBLE PRECISION A(2,NDIAHD),B(2,NDIAHD),MS(NDIAHD),MWD(NDIAHD),
     &     MA(4),MA2(4),MR(NDIAHD),SH,TH,UH,HWULDO,XMASS,PLAB,PRW,PCM
      INTEGER P1,P2,P3,P4,ID,O(2),IDP(4+NDIAHD),DRTYPE(NDIAHD)
      COMMON/HWSPHC/F3,F4,F3M,F4M,FTP,FTM,FUP,FUM,FST,A,B,MS,MWD,MR,MA,
     &     MA2,SH,TH,UH,IDP,DRTYPE
      PARAMETER(ZI=(0.0D0,1.0D0))
      COMMON/HWHEWS/S(8,8,2),D(8,8)
      COMMON/HWHEWP/XMASS(10),PLAB(5,10),PRW(5,2),PCM(5,10)
      EXTERNAL HWULDO
      SAVE O,DL
      DATA O/2,1/
      DATA DL/(1.0,0.0D0),(0.0D0,0.0D0),(0.0D0,0.0D0),(1.0D0,0.0D0)/
C--compute the propagator factor
      PRE = SQRT(TWO*HWULDO(PCM(1,8),PCM(1,4)))/(TH-MS(ID))
      DO 10 P1=1,2
      DO 10 P2=1,2
      DO 10 P3=1,2
      DO 10 P4=1,2
        IF(P2.EQ.P4) THEN
          ME(P1,P2,P3,P4) = PRE*A(P1,ID)*B(P2,ID)*
     &          ( DL(P1,O(P2))*S(1,2,  P1 )*F3M(  P2 ,O(P3),4)
     &           +DL(P1,  P2 )*S(1,4,  P1 )*F3M(O(P2),O(P3),2))
        ELSE
          ME(P1,P2,P3,P4) = (0.0D0,0.0D0)
        ENDIF
 10   CONTINUE
      END
CDECK  ID>, HWHS20.
*CMZ :-        -02/10/01  10:17:10  by  Peter Richardson
*-- Author :    Peter Richardson
C-----------------------------------------------------------------------
      SUBROUTINE HWHS20(ID,ME)
C-----------------------------------------------------------------------
C  Subroutine to calculate the helicity amplitudes for the 2-to-2 cross
C  section antifermion fermion --> antifermion fermion (t-channel boson)
C  This diagram 16 from DAMTP-2001-83
C-----------------------------------------------------------------------
      INCLUDE 'HERWIG65.INC'
      INTEGER NDIAHD
      PARAMETER(NDIAHD=10)
      DOUBLE COMPLEX ME(2,2,2,2),S,D,F3(2,2,8),F4(2,2,8),PRE,ZI,
     &     F3M(2,2,8),F4M(2,2,8),FST(2,2,8),
     &     FTP(2,2,8,8),FTM(2,2,8,8),FUP(2,2,8,8),FUM(2,2,8,8),DL(2,2)
      DOUBLE PRECISION A(2,NDIAHD),B(2,NDIAHD),MS(NDIAHD),MWD(NDIAHD),
     &     MA(4),MA2(4),MR(NDIAHD),SH,TH,UH,HWULDO,XMASS,PLAB,PRW,PCM
      INTEGER P1,P2,P3,P4,ID,O(2),IDP(4+NDIAHD),DRTYPE(NDIAHD)
      COMMON/HWSPHC/F3,F4,F3M,F4M,FTP,FTM,FUP,FUM,FST,A,B,MS,MWD,MR,MA,
     &     MA2,SH,TH,UH,IDP,DRTYPE
      PARAMETER(ZI=(0.0D0,1.0D0))
      COMMON/HWHEWS/S(8,8,2),D(8,8)
      COMMON/HWHEWP/XMASS(10),PLAB(5,10),PRW(5,2),PCM(5,10)
      EXTERNAL HWULDO
      SAVE O,DL
      DATA O/2,1/
      DATA DL/(1.0,0.0D0),(0.0D0,0.0D0),(0.0D0,0.0D0),(1.0D0,0.0D0)/
C--compute the propagator factor
      PRE = SQRT(TWO*HWULDO(PCM(1,8),PCM(1,4)))/(TH-MS(ID))
      DO 10 P1=1,2
      DO 10 P2=1,2
      DO 10 P3=1,2
      DO 10 P4=1,2
        IF(P2.EQ.P4) THEN
          ME(P1,P2,P3,P4) = PRE*A(P1,ID)*B(P2,ID)*
     &          ( DL(P1,O(P2))*S(1,4,  P1 )*F3M(  P2 ,O(P3),2)
     &           +DL(P1,  P2 )*S(1,2,  P1 )*F3M(O(P2),O(P3),4))
        ELSE
          ME(P1,P2,P3,P4) = (0.0D0,0.0D0)
        ENDIF
 10   CONTINUE
      END
CDECK  ID>, HWHS21.
*CMZ :-        -02/10/01  10:17:10  by  Peter Richardson
*-- Author :    Peter Richardson
C-----------------------------------------------------------------------
      SUBROUTINE HWHS21(ID,ME)
C-----------------------------------------------------------------------
C  Subroutine to calculate the helicity amplitudes for the 2-to-2 cross
C  section  f fbar ---> f fbar via s-channel scalar exchange
C  This is diagram 1 from RPV notes
C-----------------------------------------------------------------------
      INCLUDE 'HERWIG65.INC'
      INTEGER NDIAHD
      PARAMETER(NDIAHD=10)
      DOUBLE COMPLEX ME(2,2,2,2),S,D,F3(2,2,8),F4(2,2,8),PRE
     &     ,F3M(2,2,8),F4M(2,2,8),FST(2,2,8),ZI,
     &     FTP(2,2,8,8),FTM(2,2,8,8),FUP(2,2,8,8),FUM(2,2,8,8)
      DOUBLE PRECISION A(2,NDIAHD),B(2,NDIAHD),MS(NDIAHD),MWD(NDIAHD),
     &     MA(4),MA2(4),MR(NDIAHD),SH,TH,UH
      INTEGER P1,P3,P4,ID,O(2),IDP(4+NDIAHD),DRTYPE(NDIAHD)
      COMMON/HWSPHC/F3,F4,F3M,F4M,FTP,FTM,FUP,FUM,FST,A,B,MS,MWD,MR,MA,
     &     MA2,SH,TH,UH,IDP,DRTYPE
      COMMON/HWHEWS/S(8,8,2),D(8,8)
      PARAMETER(ZI=(0.0D0,1.0D0))
      SAVE O
      DATA O/2,1/
C--compute the propagator factor
      PRE = HALF/(SH-MS(ID)+ZI*MWD(ID))
      DO 10 P1=1,2
      DO 10 P3=1,2
      DO 10 P4=1,2
      ME(P1,  P1 ,P3,P4) = (0.0D0,0.0D0)
 10   ME(P1,O(P1),P3,P4) = PRE*A(P1,ID)*S(2,1,O(P1))*
     &     ( B(  P4 ,ID)*F3(O(P3),  P4 ,4)*S(4,8,P4)
     &      -B(O(P4),ID)*F3(O(P3),O(P4),8)*MA(4))
      END
CDECK  ID>, HWHS22.
*CMZ :-        -08/04/02  11:54:39  by  Peter Richardson
*-- Author :    Peter Richardson
C-----------------------------------------------------------------------
      SUBROUTINE HWHS22(ID,ME)
C-----------------------------------------------------------------------
C  Subroutine to calculate the helicity amplitudes for the 2-to-2 cross
C  section  f fbar ---> f fbar via t-channel scalar exchange
C  This is diagram 2 from RPV notes
C-----------------------------------------------------------------------
      INCLUDE 'HERWIG65.INC'
      INTEGER NDIAHD
      PARAMETER(NDIAHD=10)
      DOUBLE COMPLEX ME(2,2,2,2),S,D,F3(2,2,8),F4(2,2,8),PRE
     &     ,F3M(2,2,8),F4M(2,2,8),FST(2,2,8),
     &     FTP(2,2,8,8),FTM(2,2,8,8),FUP(2,2,8,8),FUM(2,2,8,8)
      DOUBLE PRECISION A(2,NDIAHD),B(2,NDIAHD),MS(NDIAHD),MWD(NDIAHD),
     &     MA(4),MA2(4),MR(NDIAHD),SH,TH,UH
      INTEGER P1,P2,P3,P4,ID,O(2),IDP(4+NDIAHD),DRTYPE(NDIAHD)
      COMMON/HWSPHC/F3,F4,F3M,F4M,FTP,FTM,FUP,FUM,FST,A,B,MS,MWD,MR,MA,
     &     MA2,SH,TH,UH,IDP,DRTYPE
      COMMON/HWHEWS/S(8,8,2),D(8,8)
      SAVE O
      DATA O/2,1/
C--compute the propagator factor
      PRE = -HALF/(TH-MS(ID))
      DO 10 P1=1,2
      DO 10 P2=1,2
      DO 10 P3=1,2
      DO 10 P4=1,2
 10   ME(P1,P2,P3,P4) = PRE*B(O(P2),ID)*A(  P1 ,ID)*
     &                  F4(P2,O(P4),2)*F3(O(P3),P1,1)
      END
CDECK  ID>, HWHS23.
*CMZ :-        -08/04/02  11:54:39  by  Peter Richardson
*-- Author :    Peter Richardson
C-----------------------------------------------------------------------
      SUBROUTINE HWHS23(ID,ME)
C-----------------------------------------------------------------------
C  Subroutine to calculate the helicity amplitudes for the 2-to-2 cross
C  section  f fbar ---> fermion fermion via t-channel scalar exchange
C  This is diagram 3 from RPV notes
C-----------------------------------------------------------------------
      INCLUDE 'HERWIG65.INC'
      INTEGER NDIAHD
      PARAMETER(NDIAHD=10)
      DOUBLE COMPLEX ME(2,2,2,2),S,D,F3(2,2,8),F4(2,2,8),PRE
     &     ,F3M(2,2,8),F4M(2,2,8),FST(2,2,8),
     &     FTP(2,2,8,8),FTM(2,2,8,8),FUP(2,2,8,8),FUM(2,2,8,8)
      DOUBLE PRECISION A(2,NDIAHD),B(2,NDIAHD),MS(NDIAHD),MWD(NDIAHD),
     &     MA(4),MA2(4),MR(NDIAHD),SH,TH,UH
      INTEGER P1,P2,P3,P4,ID,O(2),IDP(4+NDIAHD),DRTYPE(NDIAHD)
      COMMON/HWSPHC/F3,F4,F3M,F4M,FTP,FTM,FUP,FUM,FST,A,B,MS,MWD,MR,MA,
     &     MA2,SH,TH,UH,IDP,DRTYPE
      COMMON/HWHEWS/S(8,8,2),D(8,8)
      SAVE O
      DATA O/2,1/
C--compute the propagator factor
      PRE = HALF/(UH-MS(ID))
      DO 10 P1=1,2
      DO 10 P2=1,2
      DO 10 P3=1,2
      DO 10 P4=1,2
 10   ME(P1,P2,P3,P4) = PRE*B(O(P2),ID)*A(  P1 ,ID)*
     &                  F4M(P4,P1,1)*F3M(P2,P3,2)
      END
CDECK  ID>, HWHS24.
*CMZ :-        -08/04/02  11:54:39  by  Peter Richardson
*-- Author :    Peter Richardson
C-----------------------------------------------------------------------
      SUBROUTINE HWHS24(ID,ME)
C-----------------------------------------------------------------------
C  Subroutine to calculate the helicity amplitudes for the 2-to-2 cross
C  section  f fbar ---> f f via s-channel scalar exchange
C  This is diagram 4 from RPV notes
C-----------------------------------------------------------------------
      INCLUDE 'HERWIG65.INC'
      INTEGER NDIAHD
      PARAMETER(NDIAHD=10)
      DOUBLE COMPLEX ME(2,2,2,2),S,D,F3(2,2,8),F4(2,2,8),PRE
     &     ,F3M(2,2,8),F4M(2,2,8),FST(2,2,8),ZI,
     &     FTP(2,2,8,8),FTM(2,2,8,8),FUP(2,2,8,8),FUM(2,2,8,8)
      DOUBLE PRECISION A(2,NDIAHD),B(2,NDIAHD),MS(NDIAHD),MWD(NDIAHD),
     &     MA(4),MA2(4),MR(NDIAHD),SH,TH,UH
      INTEGER P1,P3,P4,ID,O(2),IDP(4+NDIAHD),DRTYPE(NDIAHD)
      COMMON/HWSPHC/F3,F4,F3M,F4M,FTP,FTM,FUP,FUM,FST,A,B,MS,MWD,MR,MA,
     &     MA2,SH,TH,UH,IDP,DRTYPE
      COMMON/HWHEWS/S(8,8,2),D(8,8)
      PARAMETER(ZI=(0.0D0,1.0D0))
      SAVE O
      DATA O/2,1/
C--compute the propagator factor
      PRE = HALF/(SH-MS(ID)+ZI*MWD(ID))
      DO 10 P1=1,2
      DO 10 P3=1,2
      DO 10 P4=1,2
      ME(P1,  P1 ,P3,P4) = (0.0D0,0.0D0)
 10   ME(P1,O(P1),P3,P4) = PRE*A(P1,ID)*S(2,1,O(P1))*
     &                    ( B(O(P3),ID)*F4M(O(P4),O(P3),3)*S(3,7,O(P3))
     &                     -B(  P3 ,ID)*F4M(O(P4),  P3 ,7)*MA(3))
      END
CDECK  ID>, HWHS25.
*CMZ :-        -08/04/02  11:54:39  by  Peter Richardson
*-- Author :    Peter Richardson
C-----------------------------------------------------------------------
      SUBROUTINE HWHS25(ID,ME)
C-----------------------------------------------------------------------
C  Subroutine to calculate the helicity amplitudes for the 2-to-2 cross
C  section  f fbar ---> f f via u-channel scalar exchange
C  This is diagram 5 from RPV notes
C-----------------------------------------------------------------------
      INCLUDE 'HERWIG65.INC'
      INTEGER NDIAHD
      PARAMETER(NDIAHD=10)
      DOUBLE COMPLEX ME(2,2,2,2),S,D,F3(2,2,8),F4(2,2,8),PRE
     &     ,F3M(2,2,8),F4M(2,2,8),FST(2,2,8),
     &     FTP(2,2,8,8),FTM(2,2,8,8),FUP(2,2,8,8),FUM(2,2,8,8)
      DOUBLE PRECISION A(2,NDIAHD),B(2,NDIAHD),MS(NDIAHD),MWD(NDIAHD),
     &     MA(4),MA2(4),MR(NDIAHD),SH,TH,UH
      INTEGER P1,P2,P3,P4,ID,O(2),IDP(4+NDIAHD),DRTYPE(NDIAHD)
      COMMON/HWSPHC/F3,F4,F3M,F4M,FTP,FTM,FUP,FUM,FST,A,B,MS,MWD,MR,MA,
     &     MA2,SH,TH,UH,IDP,DRTYPE
      COMMON/HWHEWS/S(8,8,2),D(8,8)
      SAVE O
      DATA O/2,1/
C--compute the propagator factor
      PRE = -HALF/(UH-MS(ID))
      DO 10 P1=1,2
      DO 10 P2=1,2
      DO 10 P3=1,2
      DO 10 P4=1,2
 10   ME(P1,P2,P3,P4) = PRE*B(P1,ID)*A(O(P2),ID)*
     &                  F4M(O(P4),P1,1)*F3M(P2,P3,2)
      END
CDECK  ID>, HWHS26.
*CMZ :-        -08/04/02  11:54:39  by  Peter Richardson
*-- Author :    Peter Richardson
C-----------------------------------------------------------------------
      SUBROUTINE HWHS26(ID,ME)
C-----------------------------------------------------------------------
C  Subroutine to calculate the helicity amplitudes for the 2-to-2 cross
C  section  f fbar ---> f f via t-channel scalar exchange
C  This is diagram 6 from RPV notes
C-----------------------------------------------------------------------
      INCLUDE 'HERWIG65.INC'
      INTEGER NDIAHD
      PARAMETER(NDIAHD=10)
      DOUBLE COMPLEX ME(2,2,2,2),S,D,F3(2,2,8),F4(2,2,8),PRE
     &     ,F3M(2,2,8),F4M(2,2,8),FST(2,2,8),
     &     FTP(2,2,8,8),FTM(2,2,8,8),FUP(2,2,8,8),FUM(2,2,8,8)
      DOUBLE PRECISION A(2,NDIAHD),B(2,NDIAHD),MS(NDIAHD),MWD(NDIAHD),
     &     MA(4),MA2(4),MR(NDIAHD),SH,TH,UH
      INTEGER P1,P2,P3,P4,ID,O(2),IDP(4+NDIAHD),DRTYPE(NDIAHD)
      COMMON/HWSPHC/F3,F4,F3M,F4M,FTP,FTM,FUP,FUM,FST,A,B,MS,MWD,MR,MA,
     &     MA2,SH,TH,UH,IDP,DRTYPE
      COMMON/HWHEWS/S(8,8,2),D(8,8)
      SAVE O
      DATA O/2,1/
C--compute the propagator factor
      PRE = HALF/(TH-MS(ID))
      DO 10 P1=1,2
      DO 10 P2=1,2
      DO 10 P3=1,2
      DO 10 P4=1,2
 10   ME(P1,P2,P3,P4) = PRE*B(P1,ID)*A(O(P2),ID)*
     &                  F4(P2,P4,2)*F3(O(P3),P1,1)
      END
CDECK  ID>, HWHS27.
*CMZ :-        -08/04/02  11:54:39  by  Peter Richardson
*-- Author :    Peter Richardson
C-----------------------------------------------------------------------
      SUBROUTINE HWHS27(ID,ME)
C-----------------------------------------------------------------------
C  Subroutine to calculate the helicity amplitudes for the 2-to-2 cross
C  section  f f ---> f fbar via s-channel scalar exchange
C  This is diagram 7 from RPV notes
C-----------------------------------------------------------------------
      INCLUDE 'HERWIG65.INC'
      INTEGER NDIAHD
      PARAMETER(NDIAHD=10)
      DOUBLE COMPLEX ME(2,2,2,2),S,D,F3(2,2,8),F4(2,2,8),PRE
     &     ,F3M(2,2,8),F4M(2,2,8),FST(2,2,8),ZI,
     &     FTP(2,2,8,8),FTM(2,2,8,8),FUP(2,2,8,8),FUM(2,2,8,8)
      DOUBLE PRECISION A(2,NDIAHD),B(2,NDIAHD),MS(NDIAHD),MWD(NDIAHD),
     &     MA(4),MA2(4),MR(NDIAHD),SH,TH,UH
      INTEGER P1,P3,P4,ID,O(2),IDP(4+NDIAHD),DRTYPE(NDIAHD)
      COMMON/HWSPHC/F3,F4,F3M,F4M,FTP,FTM,FUP,FUM,FST,A,B,MS,MWD,MR,MA,
     &     MA2,SH,TH,UH,IDP,DRTYPE
      COMMON/HWHEWS/S(8,8,2),D(8,8)
      PARAMETER(ZI=(0.0D0,1.0D0))
      SAVE O
      DATA O/2,1/
C--compute the propagator factor
      PRE =-HALF/(SH-MS(ID)+ZI*MWD(ID))
      DO 10 P1=1,2
      DO 10 P3=1,2
      DO 10 P4=1,2
      ME(P1,O(P1),P3,P4) = (0.0D0,0.0D0)
 10   ME(P1,  P1 ,P3,P4) = PRE*A(P1,ID)*S(1,2,O(P1))*
     &     ( B(  P4 ,ID)*F3(O(P3),  P4 ,4)*S(4,8,P4)
     &      -B(O(P4),ID)*F3(O(P3),O(P4),8)*MA(4))
      END
CDECK  ID>, HWHS28.
*CMZ :-        -08/04/02  11:54:39  by  Peter Richardson
*-- Author :    Peter Richardson
C-----------------------------------------------------------------------
      SUBROUTINE HWHS28(ID,ME)
C-----------------------------------------------------------------------
C  Subroutine to calculate the helicity amplitudes for the 2-to-2 cross
C  section  f f ---> f fbar via t-channel scalar exchange
C  This is diagram 8 from RPV notes
C-----------------------------------------------------------------------
      INCLUDE 'HERWIG65.INC'
      INTEGER NDIAHD
      PARAMETER(NDIAHD=10)
      DOUBLE COMPLEX ME(2,2,2,2),S,D,F3(2,2,8),F4(2,2,8),PRE
     &     ,F3M(2,2,8),F4M(2,2,8),FST(2,2,8),ZI,
     &     FTP(2,2,8,8),FTM(2,2,8,8),FUP(2,2,8,8),FUM(2,2,8,8)
      DOUBLE PRECISION A(2,NDIAHD),B(2,NDIAHD),MS(NDIAHD),MWD(NDIAHD),
     &     MA(4),MA2(4),MR(NDIAHD),SH,TH,UH
      INTEGER P1,P2,P3,P4,ID,O(2),IDP(4+NDIAHD),DRTYPE(NDIAHD)
      COMMON/HWSPHC/F3,F4,F3M,F4M,FTP,FTM,FUP,FUM,FST,A,B,MS,MWD,MR,MA,
     &     MA2,SH,TH,UH,IDP,DRTYPE
      COMMON/HWHEWS/S(8,8,2),D(8,8)
      PARAMETER(ZI=(0.0D0,1.0D0))
      SAVE O
      DATA O/2,1/
C--compute the propagator factor
      PRE = -HALF/(TH-MS(ID))
      DO 10 P1=1,2
      DO 10 P2=1,2
      DO 10 P3=1,2
      DO 10 P4=1,2
 10   ME(P1,P2,P3,P4) = PRE*B(P2,ID)*A(  P1 ,ID)*
     &                  F4(O(P2),O(P4),2)*F3(O(P3),P1,1)
      END
CDECK  ID>, HWHS29.
*CMZ :-        -08/04/02  11:54:39  by  Peter Richardson
*-- Author :    Peter Richardson
C-----------------------------------------------------------------------
      SUBROUTINE HWHS29(ID,ME)
C-----------------------------------------------------------------------
C  Subroutine to calculate the helicity amplitudes for the 2-to-2 cross
C  section  f f ---> f fbar via u-channel scalar exchange
C  This is diagram 9 from RPV notes
C-----------------------------------------------------------------------
      INCLUDE 'HERWIG65.INC'
      INTEGER NDIAHD
      PARAMETER(NDIAHD=10)
      DOUBLE COMPLEX ME(2,2,2,2),S,D,F3(2,2,8),F4(2,2,8),PRE
     &     ,F3M(2,2,8),F4M(2,2,8),FST(2,2,8),ZI,
     &     FTP(2,2,8,8),FTM(2,2,8,8),FUP(2,2,8,8),FUM(2,2,8,8)
      DOUBLE PRECISION A(2,NDIAHD),B(2,NDIAHD),MS(NDIAHD),MWD(NDIAHD),
     &     MA(4),MA2(4),MR(NDIAHD),SH,TH,UH
      INTEGER P1,P2,P3,P4,ID,O(2),IDP(4+NDIAHD),DRTYPE(NDIAHD)
      COMMON/HWSPHC/F3,F4,F3M,F4M,FTP,FTM,FUP,FUM,FST,A,B,MS,MWD,MR,MA,
     &     MA2,SH,TH,UH,IDP,DRTYPE
      COMMON/HWHEWS/S(8,8,2),D(8,8)
      PARAMETER(ZI=(0.0D0,1.0D0))
      SAVE O
      DATA O/2,1/
C--compute the propagator factor
      PRE = HALF/(UH-MS(ID))
      DO 10 P1=1,2
      DO 10 P2=1,2
      DO 10 P3=1,2
      DO 10 P4=1,2
 10   ME(P1,P2,P3,P4) = PRE*B(P2,ID)*A(P1,ID)*
     &                  F3(O(P3),P2,2)*F4(O(P1),O(P4),1)
      END
CDECK  ID>, HWHS30.
*CMZ :-        -08/04/02  11:54:39  by  Peter Richardson
*-- Author :    Peter Richardson
C-----------------------------------------------------------------------
      SUBROUTINE HWHS30(ID,ME)
C-----------------------------------------------------------------------
C  Subroutine to calculate the helicity amplitudes for the 2-to-2 cross
C  section  fbar fbar ---> f f via s-channel scalar exchange
C  This is diagram 10 from RPV notes
C-----------------------------------------------------------------------
      INCLUDE 'HERWIG65.INC'
      INTEGER NDIAHD
      PARAMETER(NDIAHD=10)
      DOUBLE COMPLEX ME(2,2,2,2),S,D,F3(2,2,8),F4(2,2,8),PRE
     &     ,F3M(2,2,8),F4M(2,2,8),FST(2,2,8),ZI,
     &     FTP(2,2,8,8),FTM(2,2,8,8),FUP(2,2,8,8),FUM(2,2,8,8)
      DOUBLE PRECISION A(2,NDIAHD),B(2,NDIAHD),MS(NDIAHD),MWD(NDIAHD),
     &     MA(4),MA2(4),MR(NDIAHD),SH,TH,UH
      INTEGER P1,P3,P4,ID,O(2),IDP(4+NDIAHD),DRTYPE(NDIAHD)
      COMMON/HWSPHC/F3,F4,F3M,F4M,FTP,FTM,FUP,FUM,FST,A,B,MS,MWD,MR,MA,
     &     MA2,SH,TH,UH,IDP,DRTYPE
      COMMON/HWHEWS/S(8,8,2),D(8,8)
      PARAMETER(ZI=(0.0D0,1.0D0))
      SAVE O
      DATA O/2,1/
C--compute the propagator factor
      PRE = HALF/(SH-MS(ID)+ZI*MWD(ID))
      DO 10 P1=1,2
      DO 10 P3=1,2
      DO 10 P4=1,2
      ME(P1,O(P1),P3,P4) = (0.0D0,0.0D0)
 10   ME(P1,  P1 ,P3,P4) = PRE*A(O(P1),ID)*S(2,1,P1)*
     &                    ( B(O(P3),ID)*F4M(O(P4),O(P3),3)*S(3,7,O(P3))
     &                     -B(  P3 ,ID)*F4M(O(P4),  P3 ,7)*MA(3))
      END
CDECK  ID>, HWHS31.
*CMZ :-        -08/04/02  11:54:39  by  Peter Richardson
*-- Author :    Peter Richardson
C-----------------------------------------------------------------------
      SUBROUTINE HWHS31(ID,ME)
C-----------------------------------------------------------------------
C  Subroutine to calculate the helicity amplitudes for the 2-to-2 cross
C  section  fbar fbar ---> f f via t-channel scalar exchange
C  This is diagram 11 from RPV notes
C-----------------------------------------------------------------------
      INCLUDE 'HERWIG65.INC'
      INTEGER NDIAHD
      PARAMETER(NDIAHD=10)
      DOUBLE COMPLEX ME(2,2,2,2),S,D,F3(2,2,8),F4(2,2,8),PRE
     &     ,F3M(2,2,8),F4M(2,2,8),FST(2,2,8),ZI,
     &     FTP(2,2,8,8),FTM(2,2,8,8),FUP(2,2,8,8),FUM(2,2,8,8)
      DOUBLE PRECISION A(2,NDIAHD),B(2,NDIAHD),MS(NDIAHD),MWD(NDIAHD),
     &     MA(4),MA2(4),MR(NDIAHD),SH,TH,UH
      INTEGER P1,P2,P3,P4,ID,O(2),IDP(4+NDIAHD),DRTYPE(NDIAHD)
      COMMON/HWSPHC/F3,F4,F3M,F4M,FTP,FTM,FUP,FUM,FST,A,B,MS,MWD,MR,MA,
     &     MA2,SH,TH,UH,IDP,DRTYPE
      COMMON/HWHEWS/S(8,8,2),D(8,8)
      PARAMETER(ZI=(0.0D0,1.0D0))
      SAVE O
      DATA O/2,1/
C--compute the propagator factor
      PRE = HALF/(TH-MS(ID))
      DO 10 P1=1,2
      DO 10 P2=1,2
      DO 10 P3=1,2
      DO 10 P4=1,2
 10   ME(P1,P2,P3,P4) = PRE*B(O(P2),ID)*A(O(P1),ID)*
     &                  F4M(O(P4),O(P2),2)*F3M(P1,P3,1)
      END
CDECK  ID>, HWHS32.
*CMZ :-        -08/04/02  11:54:39  by  Peter Richardson
*-- Author :    Peter Richardson
C-----------------------------------------------------------------------
      SUBROUTINE HWHS32(ID,ME)
C-----------------------------------------------------------------------
C  Subroutine to calculate the helicity amplitudes for the 2-to-2 cross
C  section  fbar fbar ---> f f via u-channel scalar exchange
C  This is diagram 12 from RPV notes
C-----------------------------------------------------------------------
      INCLUDE 'HERWIG65.INC'
      INTEGER NDIAHD
      PARAMETER(NDIAHD=10)
      DOUBLE COMPLEX ME(2,2,2,2),S,D,F3(2,2,8),F4(2,2,8),PRE
     &     ,F3M(2,2,8),F4M(2,2,8),FST(2,2,8),ZI,
     &     FTP(2,2,8,8),FTM(2,2,8,8),FUP(2,2,8,8),FUM(2,2,8,8)
      DOUBLE PRECISION A(2,NDIAHD),B(2,NDIAHD),MS(NDIAHD),MWD(NDIAHD),
     &     MA(4),MA2(4),MR(NDIAHD),SH,TH,UH
      INTEGER P1,P2,P3,P4,ID,O(2),IDP(4+NDIAHD),DRTYPE(NDIAHD)
      COMMON/HWSPHC/F3,F4,F3M,F4M,FTP,FTM,FUP,FUM,FST,A,B,MS,MWD,MR,MA,
     &     MA2,SH,TH,UH,IDP,DRTYPE
      COMMON/HWHEWS/S(8,8,2),D(8,8)
      PARAMETER(ZI=(0.0D0,1.0D0))
      SAVE O
      DATA O/2,1/
C--compute the propagator factor
      PRE =-HALF/(UH-MS(ID))
      DO 10 P1=1,2
      DO 10 P2=1,2
      DO 10 P3=1,2
      DO 10 P4=1,2
 10   ME(P1,P2,P3,P4) = PRE*B(O(P2),ID)*A(O(P1),ID)*
     &                   F4M(O(P4),O(P1),1)*F3M(P2,P3,2)
      END
CDECK  ID>, HWHS33.
*CMZ :-        -08/04/02  11:54:39  by  Peter Richardson
*-- Author :    Peter Richardson
C-----------------------------------------------------------------------
      SUBROUTINE HWHS33(ID,ME)
C-----------------------------------------------------------------------
C  Subroutine to calculate the helicity amplitudes for the 2-to-2 cross
C  section  f f ---> f f via s-channel scalar exchange
C  This is diagram 13 from RPV
C-----------------------------------------------------------------------
      INCLUDE 'HERWIG65.INC'
      INTEGER NDIAHD
      PARAMETER(NDIAHD=10)
      DOUBLE COMPLEX ME(2,2,2,2),S,D,F3(2,2,8),F4(2,2,8),PRE
     &     ,F3M(2,2,8),F4M(2,2,8),FST(2,2,8),ZI,
     &     FTP(2,2,8,8),FTM(2,2,8,8),FUP(2,2,8,8),FUM(2,2,8,8)
      DOUBLE PRECISION A(2,NDIAHD),B(2,NDIAHD),MS(NDIAHD),MWD(NDIAHD),
     &     MA(4),MA2(4),MR(NDIAHD),SH,TH,UH
      INTEGER P1,P3,P4,ID,O(2),IDP(4+NDIAHD),DRTYPE(NDIAHD)
      COMMON/HWSPHC/F3,F4,F3M,F4M,FTP,FTM,FUP,FUM,FST,A,B,MS,MWD,MR,MA,
     &     MA2,SH,TH,UH,IDP,DRTYPE
      COMMON/HWHEWS/S(8,8,2),D(8,8)
      PARAMETER(ZI=(0.0D0,1.0D0))
      SAVE O
      DATA O/2,1/
C--compute the propagator factor
      PRE = HALF/(SH-MS(ID)+ZI*MWD(ID))
      DO 10 P1=1,2
      DO 10 P3=1,2
      DO 10 P4=1,2
      ME(P1,O(P1),P3,P4) = (0.0D0,0.0D0)
 10   ME(P1,  P1 ,P3,P4) = PRE*A(P1,ID)*S(1,2,O(P1))*
     &     ( B(O(P3),ID)*F4M(O(P4),O(P3),3)*S(3,7,O(P3))
     &      -B(  P3 ,ID)*F4M(O(P4),  P3 ,7)*MA(3))
      END
CDECK  ID>, HWHS34.
*CMZ :-        -08/04/02  11:54:39  by  Peter Richardson
*-- Author :    Peter Richardson
C-----------------------------------------------------------------------
      SUBROUTINE HWHS34(ID,ME)
C-----------------------------------------------------------------------
C  Subroutine to calculate the helicity amplitudes for the 2-to-2 cross
C  section  fbar fbar ---> fbar fbar via t-channel scalar exchange
C  This is diagram 14 from RPV notes
C-----------------------------------------------------------------------
      INCLUDE 'HERWIG65.INC'
      INTEGER NDIAHD
      PARAMETER(NDIAHD=10)
      DOUBLE COMPLEX ME(2,2,2,2),S,D,F3(2,2,8),F4(2,2,8),PRE
     &     ,F3M(2,2,8),F4M(2,2,8),FST(2,2,8),ZI,
     &     FTP(2,2,8,8),FTM(2,2,8,8),FUP(2,2,8,8),FUM(2,2,8,8)
      DOUBLE PRECISION A(2,NDIAHD),B(2,NDIAHD),MS(NDIAHD),MWD(NDIAHD),
     &     MA(4),MA2(4),MR(NDIAHD),SH,TH,UH
      INTEGER P1,P3,P4,ID,O(2),IDP(4+NDIAHD),DRTYPE(NDIAHD)
      COMMON/HWSPHC/F3,F4,F3M,F4M,FTP,FTM,FUP,FUM,FST,A,B,MS,MWD,MR,MA,
     &     MA2,SH,TH,UH,IDP,DRTYPE
      COMMON/HWHEWS/S(8,8,2),D(8,8)
      PARAMETER(ZI=(0.0D0,1.0D0))
      SAVE O
      DATA O/2,1/
C--compute the propagator factor
      PRE = HALF/(SH-MS(ID)+ZI*MWD(ID))
      DO 10 P1=1,2
      DO 10 P3=1,2
      DO 10 P4=1,2
      ME(P1,O(P1),P3,P4) = (0.0D0,0.0D0)
 10   ME(P1,  P1 ,P3,P4) = PRE*A(O(P1),ID)*S(2,1,P1)*
     &     ( B(  P4 ,ID)*F3(P3,  P4 ,4)*S(4,8,P4)
     &      -B(O(P4),ID)*F3(P3,O(P4),8)*MA(4))
      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 )
      END
CDECK  ID>, HWHSS2.
*CMZ :-        -10/10/01  10:38:15  by  Peter Richardson
*-- Author :    Kosuke Odagiri
C-----------------------------------------------------------------------
      FUNCTION HWHSS2(S, T, U, M3, M4, SGN, CLL, CLR, CRL, CRR)
C-----------------------------------------------------------------------
C     LL(BAR) -> GAUGINOS (including beam polarization)
C-----------------------------------------------------------------------
      INCLUDE 'HERWIG65.INC'
      DOUBLE PRECISION HWHSS2, S, T, U, M3, M4, SGN
      DOUBLE COMPLEX CLL, CLR, CRL, CRR
      HWHSS2 =
C--first the incoming left electron
     & (ONE-EPOLN(3))*(ONE+PPOLN(3))*DREAL(
     & DCONJG(CLL)*CLL*(U-M3*M3)*(U-M4*M4)+
     & DCONJG(CLR)*CLR*(T-M3*M3)*(T-M4*M4)+
     & DCONJG(CLL)*CLR*2.*SGN*M3*M4*S )
C--then the incoming right electron
     &+(ONE+EPOLN(3))*(ONE-PPOLN(3))*DREAL(
     & DCONJG(CRR)*CRR*(U-M3*M3)*(U-M4*M4)+
     & DCONJG(CRL)*CRL*(T-M3*M3)*(T-M4*M4)+
     & DCONJG(CRL)*CRR*2.*SGN*M3*M4*S )
      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 'HERWIG65.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))
      SAVE IWD,DQD,DQU
      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. (PR BUG FIX 3/9/01)
              C2   = (-XD(IG2)*WMXVSS(IG1,2)/SQXW+C1*WMXVSS(IG1,1))/GW
              C3   = ( XC(IG2)*WMXUSS(IG1,2)/SQXW+C1*WMXUSS(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
C--PR bug fix 28/08/01
              M6R(IG1,IQ) = FACC*PF * ((QMIXSS(IQ,1,2)*SLFCH(IQ,IG1))**2
     &         +(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)
C--PR bug fix 10/10/01
          IF (GENEV.AND.HCS.GT.RCS) THEN
            IF(ID2.LT.ID1) COSTH=-COSTH
            CALL HWHSSS(IG3,0,IG4,0,2134,21)
            GOTO 9
          ENDIF
        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)
C--PR bug fix 10/10/01
          IF (GENEV.AND.HCS.GT.RCS) THEN
            IF(ID2.LT.ID1) COSTH=-COSTH
            CALL HWHSSS(IG3,0,IG4,0,2134,22)
            GOTO 9
          ENDIF
        END DO
        HCS = HCS + DIST*M4(IG1,IQ)
C--PR bug fix 10/10/01
        IF (GENEV.AND.HCS.GT.RCS) THEN
          IF(ID2.LT.ID1) COSTH=-COSTH
          CALL HWHSSS(IG3,0,IGL,0, IPB,24)
          GOTO 9
        ENDIF
      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) THEN
            CALL HWHSSS(IG3,0,IG4,0,2134,23)
            GOTO 9
          ENDIF
         END DO
         HCS = HCS + DIST*M5(IG1,IQ1,IQ2)
         IF (GENEV.AND.HCS.GT.RCS) THEN
           CALL HWHSSS(IG3,0,IGL,0,2431,25)
           GOTO 9
         ENDIF
        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) THEN
            CALL HWHSSS(IG4,0,IG3,0,2134,23)
            GOTO 9
          ENDIF
         END DO
         HCS = HCS + DIST*M5(IG1,IQ1,IQ2)
         IF (GENEV.AND.HCS.GT.RCS) THEN
           CALL HWHSSS(IGL,0,IG3,0,3124,25)
           GOTO 9
         ENDIF
        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) THEN
            CALL HWHSSS(IG4,0,IG3,0,2134,23)
            GOTO 9
          ENDIF
         END DO
         HCS = HCS + DIST*M5(IG1,IQ1,IQ2)
         IF (GENEV.AND.HCS.GT.RCS) THEN
           CALL HWHSSS(IGL,0,IG3,0,2314,25)
           GOTO 9
         ENDIF
        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) THEN
            CALL HWHSSS(IG3,0,IG4,0,2134,23)
            GOTO 9
          ENDIF
         END DO
         HCS = HCS + DIST*M5(IG1,IQ1,IQ2)
         IF (GENEV.AND.HCS.GT.RCS) THEN
           CALL HWHSSS(IG3,0,IGL,0,4132,25)
           GOTO 9
         ENDIF
        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) THEN
           CALL HWHSSS(IG3,0,ID2,0,2431,26)
           GOTO 9
         ENDIF
         HCS = HCS + DIST*M6R(IG1,IQ1)
         IF (GENEV.AND.HCS.GT.RCS) THEN
           CALL HWHSSS(IG3,0,ID2,2,2431,26)
           GOTO 9
         ENDIF
        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) THEN
           CALL HWHSSS(IG3,0,ID2,0,4132,26)
           GOTO 9
         ENDIF
         HCS = HCS + DIST*M6R(IG1,IQ1)
         IF (GENEV.AND.HCS.GT.RCS) THEN
           CALL HWHSSS(IG3,0,ID2,2,4132,26)
           GOTO 9
         ENDIF
        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) THEN
           CALL HWHSSS(ID1,0,IG3,0,3124,26)
           GOTO 9
         ENDIF
         HCS = HCS + DIST*M6R(IG1,IQ1)
         IF (GENEV.AND.HCS.GT.RCS) THEN
           CALL HWHSSS(ID1,2,IG3,0,3124,26)
           GOTO 9
         ENDIF
        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) THEN
           CALL HWHSSS(ID1,0,IG3,0,2314,26)
           GOTO 9
         ENDIF
         HCS = HCS + DIST*M6R(IG1,IQ1)
         IF (GENEV.AND.HCS.GT.RCS) THEN
           CALL HWHSSS(ID1,2,IG3,0,2314,26)
           GOTO 9
         ENDIF
        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) THEN
           CALL HWHSSS(IG3,0,IQ4,0,2431,27)
           GOTO 9
         ENDIF
         HCS = HCS + DISF(ID1,1)*DISF(ID2,2)*M7(2,IG1,IQ3,IQ4)
         IF (GENEV.AND.HCS.GT.RCS) THEN
           CALL HWHSSS(IG3,0,IQ4,2,2431,27)
           GOTO 9
         ENDIF
         ID2 = IQ4
         HCS = HCS + DISF(ID1,1)*DISF(ID2,2)*M7(1,IG1,IQ4,IQ3)
         IF (GENEV.AND.HCS.GT.RCS) THEN
           CALL HWHSSS(IG4,0,IQ3,0,2431,27)
           GOTO 9
         ENDIF
         HCS = HCS + DISF(ID1,1)*DISF(ID2,2)*M7(2,IG1,IQ4,IQ3)
         IF (GENEV.AND.HCS.GT.RCS) THEN
           CALL HWHSSS(IG4,0,IQ3,2,2431,27)
           GOTO 9
         ENDIF
         ID1 = IQ3
         ID2 = 13
         HCS = HCS + DISF(ID1,1)*DISF(ID2,2)*M7(1,IG1,IQ3,IQ4)
         IF (GENEV.AND.HCS.GT.RCS) THEN
           CALL HWHSSS(IQ4,0,IG3,0,3124,27)
           GOTO 9
         ENDIF
         HCS = HCS + DISF(ID1,1)*DISF(ID2,2)*M7(2,IG1,IQ3,IQ4)
         IF (GENEV.AND.HCS.GT.RCS) THEN
           CALL HWHSSS(IQ4,2,IG3,0,3124,27)
           GOTO 9
         ENDIF
         ID1 = IQ4
         HCS = HCS + DISF(ID1,1)*DISF(ID2,2)*M7(1,IG1,IQ4,IQ3)
         IF (GENEV.AND.HCS.GT.RCS) THEN
           CALL HWHSSS(IQ3,0,IG4,0,3124,27)
           GOTO 9
         ENDIF
         HCS = HCS + DISF(ID1,1)*DISF(ID2,2)*M7(2,IG1,IQ4,IQ3)
         IF (GENEV.AND.HCS.GT.RCS) THEN
           CALL HWHSSS(IQ3,2,IG4,0,3124,27)
           GOTO 9
         ENDIF
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) THEN
           CALL HWHSSS(IG4,0,IQ4,1,4132,27)
           GOTO 9
         ENDIF
         HCS = HCS + DISF(ID1,1)*DISF(ID2,2)*M7(2,IG1,IQ3,IQ4)
         IF (GENEV.AND.HCS.GT.RCS) THEN
           CALL HWHSSS(IG4,0,IQ4,3,4132,27)
           GOTO 9
         ENDIF
         ID2 = IQ4 + 6
         HCS = HCS + DISF(ID1,1)*DISF(ID2,2)*M7(1,IG1,IQ4,IQ3)
         IF (GENEV.AND.HCS.GT.RCS) THEN
           CALL HWHSSS(IG3,0,IQ3,1,4132,27)
           GOTO 9
         ENDIF
         HCS = HCS + DISF(ID1,1)*DISF(ID2,2)*M7(2,IG1,IQ4,IQ3)
         IF (GENEV.AND.HCS.GT.RCS) THEN
           CALL HWHSSS(IG3,0,IQ3,3,4132,27)
           GOTO 9
         ENDIF
         ID1 = IQ3 + 6
         ID2 = 13
         HCS = HCS + DISF(ID1,1)*DISF(ID2,2)*M7(1,IG1,IQ3,IQ4)
         IF (GENEV.AND.HCS.GT.RCS) THEN
           CALL HWHSSS(IQ4,1,IG4,0,2314,27)
           GOTO 9
         ENDIF
         HCS = HCS + DISF(ID1,1)*DISF(ID2,2)*M7(2,IG1,IQ3,IQ4)
         IF (GENEV.AND.HCS.GT.RCS) THEN
           CALL HWHSSS(IQ4,3,IG4,0,2314,27)
           GOTO 9
         ENDIF
         ID1 = IQ4 + 6
         HCS = HCS + DISF(ID1,1)*DISF(ID2,2)*M7(1,IG1,IQ4,IQ3)
         IF (GENEV.AND.HCS.GT.RCS) THEN
           CALL HWHSSS(IQ3,1,IG3,0,2314,27)
           GOTO 9
         ENDIF
         HCS = HCS + DISF(ID1,1)*DISF(ID2,2)*M7(2,IG1,IQ4,IQ3)
         IF (GENEV.AND.HCS.GT.RCS) THEN
           CALL HWHSSS(IQ3,3,IG3,0,2314,27)
           GOTO 9
         ENDIF
        END DO
    3  CONTINUE
      END DO
      EVWGT = HCS
      RETURN
C---GENERATE EVENT
    9 IDN(1)=ID1
      IDN(2)=ID2
      IDCMF=15
      CALL HWETWO(.TRUE.,.TRUE.)
      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>, 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 'HERWIG65.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) THEN
            CALL HWHSSS(IL1,2,IL2,3,2134,30)
            GOTO 9
          ENDIF
         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) THEN
           CALL HWHSSS(IL1,5,IL2,4,2134,30)
           GOTO 9
         ENDIF
        END DO
        HCS = HCS + DIST*ME2W(2,3)
        IF (GENEV.AND.HCS.GT.RCS) THEN
          CALL HWHSSS(5,7,6,4,2134,30)
          GOTO 9
        ENDIF
       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) THEN
           CALL HWHSSS(IL1,5,IL2,4,2134,30)
           GOTO 9
         ENDIF
        END DO
        HCS = HCS + DIST*ME2W(2,3)
        IF (GENEV.AND.HCS.GT.RCS) THEN
          CALL HWHSSS(5,7,6,4,2134,30)
          GOTO 9
        ENDIF
       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) THEN
           CALL HWHSSS(IL1,4,IL2,5,2134,30)
           GOTO 9
         ENDIF
        END DO
        HCS = HCS + DIST*ME2W(2,3)
        IF (GENEV.AND.HCS.GT.RCS) THEN
          CALL HWHSSS(5,6,6,5,2134,30)
          GOTO 9
        ENDIF
       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) THEN
           CALL HWHSSS(IL1,4,IL2,5,2134,30)
           GOTO 9
         ENDIF
        END DO
        HCS = HCS + DIST*ME2W(2,3)
        IF (GENEV.AND.HCS.GT.RCS) THEN
          CALL HWHSSS(5,6,6,5,2134,30)
          GOTO 9
        ENDIF
       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(.TRUE.,.TRUE.)
      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 'HERWIG65.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) THEN
           CALL HWHSSS(IQ1,0,IQ2,0,3421,10)
           GOTO 9
         ENDIF
         HCS = HCS + ASTURR(IQ1,IQ2)*DIST
         IF (GENEV.AND.HCS.GT.RCS) THEN
           CALL HWHSSS(IQ1,2,IQ2,2,3421,10)
           GOTO 9
         ENDIF
         HCS = HCS + ASTULR(IQ1,IQ2)*DIST
         IF (GENEV.AND.HCS.GT.RCS) THEN
           CALL HWHSSS(IQ1,0,IQ2,2,3421,10)
           GOTO 9
         ENDIF
         HCS = HCS + ASTURL(IQ1,IQ2)*DIST
         IF (GENEV.AND.HCS.GT.RCS) THEN
           CALL HWHSSS(IQ1,2,IQ2,0,3421,10)
           GOTO 9
         ENDIF
        ELSE
c        ~ ~
c qq  -> q q
         HCS = HCS +     BSTULL(IQ1)*DIST
         IF (GENEV.AND.HCS.GT.RCS) THEN
           CALL HWHSSS(IQ1,0,IQ2,0,3421,10)
           GOTO 9
         ENDIF
         HCS = HCS +     BSTURR(IQ1)*DIST
         IF (GENEV.AND.HCS.GT.RCS) THEN
           CALL HWHSSS(IQ1,2,IQ2,2,3421,10)
           GOTO 9
         ENDIF
         HCS = HCS +     BSTULR(IQ1)*DIST
         IF (GENEV.AND.HCS.GT.RCS) THEN
           CALL HWHSSS(IQ1,0,IQ2,2,3421,10)
           GOTO 9
         ENDIF
         HCS = HCS +     BSTURL(IQ1)*DIST
         IF (GENEV.AND.HCS.GT.RCS) THEN
           CALL HWHSSS(IQ1,2,IQ2,0,3421,10)
           GOTO 9
         ENDIF
         HCS = HCS +     BSUTLL(IQ1)*DIST
         IF (GENEV.AND.HCS.GT.RCS) THEN
           CALL HWHSSS(IQ1,0,IQ2,0,4312,10)
           GOTO 9
         ENDIF
         HCS = HCS +     BSUTRR(IQ1)*DIST
         IF (GENEV.AND.HCS.GT.RCS) THEN
           CALL HWHSSS(IQ1,2,IQ2,2,4312,10)
           GOTO 9
         ENDIF
         HCS = HCS +     BSUTLR(IQ1)*DIST
         IF (GENEV.AND.HCS.GT.RCS) THEN
           CALL HWHSSS(IQ1,0,IQ2,2,4312,10)
           GOTO 9
         ENDIF
         HCS = HCS +     BSUTRL(IQ1)*DIST
         IF (GENEV.AND.HCS.GT.RCS) THEN
           CALL HWHSSS(IQ1,2,IQ2,0,4312,10)
           GOTO 9
         ENDIF
        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) THEN
           CALL HWHSSS(IQ1,0,IQ2,1,3142,10)
           GOTO 9
         ENDIF
         HCS = HCS + AUTSRR(IQ1,IQ2)*DIST
         IF (GENEV.AND.HCS.GT.RCS) THEN
           CALL HWHSSS(IQ1,2,IQ2,3,3142,10)
           GOTO 9
         ENDIF
         HCS = HCS + AUTSLR(IQ1,IQ2)*DIST
         IF (GENEV.AND.HCS.GT.RCS) THEN
           CALL HWHSSS(IQ1,0,IQ2,3,3142,10)
           GOTO 9
         ENDIF
         HCS = HCS + AUTSRL(IQ1,IQ2)*DIST
         IF (GENEV.AND.HCS.GT.RCS) THEN
           CALL HWHSSS(IQ1,2,IQ2,1,3142,10)
           GOTO 9
         ENDIF
        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) THEN
           CALL HWHSSS(IQ ,0,IQ ,1,2413,10)
           GOTO 9
         ENDIF
         HCS = HCS +     AUSTRR(IQ )*DIST
         IF (GENEV.AND.HCS.GT.RCS) THEN
           CALL HWHSSS(IQ ,2,IQ ,3,2413,10)
           GOTO 9
         ENDIF
  30     CONTINUE
c  _     ~ ~*
c qq  -> q q
         HCS = HCS +     BUTSLL(IQ1)*DIST
         IF (GENEV.AND.HCS.GT.RCS) THEN
           CALL HWHSSS(IQ1,0,IQ2,1,3142,10)
           GOTO 9
         ENDIF
         HCS = HCS +     BUTSRR(IQ1)*DIST
         IF (GENEV.AND.HCS.GT.RCS) THEN
           CALL HWHSSS(IQ1,2,IQ2,3,3142,10)
           GOTO 9
         ENDIF
         HCS = HCS +     BUTSLR(IQ1)*DIST
         IF (GENEV.AND.HCS.GT.RCS) THEN
           CALL HWHSSS(IQ1,0,IQ2,3,3142,10)
           GOTO 9
         ENDIF
         HCS = HCS +     BUTSRL(IQ1)*DIST
         IF (GENEV.AND.HCS.GT.RCS) THEN
           CALL HWHSSS(IQ1,2,IQ2,1,3142,10)
           GOTO 9
         ENDIF
         HCS = HCS +     BUSTLL(IQ1)*DIST
         IF (GENEV.AND.HCS.GT.RCS) THEN
           CALL HWHSSS(IQ1,0,IQ2,1,2413,10)
           GOTO 9
         ENDIF
         HCS = HCS +     BUSTRR(IQ1)*DIST
         IF (GENEV.AND.HCS.GT.RCS) THEN
           CALL HWHSSS(IQ1,2,IQ2,3,2413,10)
           GOTO 9
         ENDIF
         HCS = HCS +     BUSTLR(IQ1)*DIST
         IF (GENEV.AND.HCS.GT.RCS) THEN
           CALL HWHSSS(IQ1,0,IQ2,3,2413,10)
           GOTO 9
         ENDIF
         HCS = HCS +     BUSTRL(IQ1)*DIST
         IF (GENEV.AND.HCS.GT.RCS) THEN
           CALL HWHSSS(IQ1,2,IQ2,1,2413,10)
           GOTO 9
         ENDIF
         IQ  = IGL
c  _     ~ ~
c qq  -> g g
         HCS = HCS +       CSTU(IQ1)*DIST
         IF (GENEV.AND.HCS.GT.RCS) THEN
           CALL HWHSSS(IQ ,0,IQ ,0,2413,10)
           GOTO 9
         ENDIF
         HCS = HCS +       CSUT(IQ1)*DIST
         IF (GENEV.AND.HCS.GT.RCS) THEN
           CALL HWHSSS(IQ ,0,IQ ,0,2341,10)
           GOTO 9
         ENDIF
        END IF
       ELSE
         IQ2 = IGL
c        ~ ~
c qg  -> q g
         HCS = HCS +      CTSUL(IQ1)*DIST
         IF (GENEV.AND.HCS.GT.RCS) THEN
           CALL HWHSSS(IQ1,0,IQ2,0,3142,10)
           GOTO 9
         ENDIF
         HCS = HCS +      CTSUR(IQ1)*DIST
         IF (GENEV.AND.HCS.GT.RCS) THEN
           CALL HWHSSS(IQ1,2,IQ2,0,3142,10)
           GOTO 9
         ENDIF
         HCS = HCS +      CTUSL(IQ1)*DIST
         IF (GENEV.AND.HCS.GT.RCS) THEN
           CALL HWHSSS(IQ1,0,IQ2,0,3421,10)
           GOTO 9
         ENDIF
         HCS = HCS +      CTUSR(IQ1)*DIST
         IF (GENEV.AND.HCS.GT.RCS) THEN
           CALL HWHSSS(IQ1,2,IQ2,0,3421,10)
           GOTO 9
         ENDIF
       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) THEN
           CALL HWHSSS(IQ1,1,IQ2,0,2413,10)
           GOTO 9
         ENDIF
         HCS = HCS + AUTSRR(IQ1,IQ2)*DIST
         IF (GENEV.AND.HCS.GT.RCS) THEN
           CALL HWHSSS(IQ1,3,IQ2,2,2413,10)
           GOTO 9
         ENDIF
         HCS = HCS + AUTSLR(IQ1,IQ2)*DIST
         IF (GENEV.AND.HCS.GT.RCS) THEN
           CALL HWHSSS(IQ1,1,IQ2,2,2413,10)
           GOTO 9
         ENDIF
         HCS = HCS + AUTSRL(IQ1,IQ2)*DIST
         IF (GENEV.AND.HCS.GT.RCS) THEN
           CALL HWHSSS(IQ1,3,IQ2,0,2413,10)
           GOTO 9
         ENDIF
        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) THEN
           CALL HWHSSS(IQ ,1,IQ ,0,3142,10)
           GOTO 9
         ENDIF
         HCS = HCS +      AUSTRR(IQ)*DIST
         IF (GENEV.AND.HCS.GT.RCS) THEN
           CALL HWHSSS(IQ ,3,IQ ,2,3142,10)
           GOTO 9
         ENDIF
   31    CONTINUE
c _      ~*~
c qq  -> q q
         HCS = HCS +     BUTSLL(IQ1)*DIST
         IF (GENEV.AND.HCS.GT.RCS) THEN
           CALL HWHSSS(IQ1,1,IQ2,0,2413,10)
           GOTO 9
         ENDIF
         HCS = HCS +     BUTSRR(IQ1)*DIST
         IF (GENEV.AND.HCS.GT.RCS) THEN
           CALL HWHSSS(IQ1,3,IQ2,2,2413,10)
           GOTO 9
         ENDIF
         HCS = HCS +     BUTSLR(IQ1)*DIST
         IF (GENEV.AND.HCS.GT.RCS) THEN
           CALL HWHSSS(IQ1,1,IQ2,2,2413,10)
           GOTO 9
         ENDIF
         HCS = HCS +     BUTSRL(IQ1)*DIST
         IF (GENEV.AND.HCS.GT.RCS) THEN
           CALL HWHSSS(IQ1,3,IQ2,0,2413,10)
           GOTO 9
         ENDIF
         HCS = HCS +     BUSTLL(IQ1)*DIST
         IF (GENEV.AND.HCS.GT.RCS) THEN
           CALL HWHSSS(IQ1,1,IQ2,0,3142,10)
           GOTO 9
         ENDIF
         HCS = HCS +     BUSTRR(IQ1)*DIST
         IF (GENEV.AND.HCS.GT.RCS) THEN
           CALL HWHSSS(IQ1,3,IQ2,2,3142,10)
           GOTO 9
         ENDIF
         HCS = HCS +     BUSTLR(IQ1)*DIST
         IF (GENEV.AND.HCS.GT.RCS) THEN
           CALL HWHSSS(IQ1,1,IQ2,2,3142,10)
           GOTO 9
         ENDIF
         HCS = HCS +     BUSTRL(IQ1)*DIST
         IF (GENEV.AND.HCS.GT.RCS) THEN
           CALL HWHSSS(IQ1,3,IQ2,0,3142,10)
           GOTO 9
         ENDIF
c _      ~ ~
c qq  -> g g
         HCS = HCS +       CSTU(IQ1)*DIST
         IF (GENEV.AND.HCS.GT.RCS) THEN
           CALL HWHSSS(IGL,0,IGL,0,3142,10)
           GOTO 9
         ENDIF
         HCS = HCS +       CSUT(IQ1)*DIST
         IF (GENEV.AND.HCS.GT.RCS) THEN
           CALL HWHSSS(IGL,0,IGL,0,4123,10)
           GOTO 9
         ENDIF
        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) THEN
           CALL HWHSSS(IQ1,1,IQ2,1,4312,10)
           GOTO 9
         ENDIF
         HCS = HCS + ASTURR(IQ1,IQ2)*DIST
         IF (GENEV.AND.HCS.GT.RCS) THEN
           CALL HWHSSS(IQ1,3,IQ2,3,4312,10)
           GOTO 9
         ENDIF
         HCS = HCS + ASTULR(IQ1,IQ2)*DIST
         IF (GENEV.AND.HCS.GT.RCS) THEN
           CALL HWHSSS(IQ1,1,IQ2,3,4312,10)
           GOTO 9
         ENDIF
         HCS = HCS + ASTURL(IQ1,IQ2)*DIST
         IF (GENEV.AND.HCS.GT.RCS) THEN
           CALL HWHSSS(IQ1,3,IQ2,1,4312,10)
           GOTO 9
         ENDIF
        ELSE
c __     ~*~*
c qq  -> q q
         HCS = HCS +     BSTULL(IQ1)*DIST
         IF (GENEV.AND.HCS.GT.RCS) THEN
           CALL HWHSSS(IQ1,1,IQ2,1,4312,10)
           GOTO 9
         ENDIF
         HCS = HCS +     BSTURR(IQ1)*DIST
         IF (GENEV.AND.HCS.GT.RCS) THEN
           CALL HWHSSS(IQ1,3,IQ2,3,4312,10)
           GOTO 9
         ENDIF
         HCS = HCS +     BSTULR(IQ1)*DIST
         IF (GENEV.AND.HCS.GT.RCS) THEN
           CALL HWHSSS(IQ1,1,IQ2,3,4312,10)
           GOTO 9
         ENDIF
         HCS = HCS +     BSTURL(IQ1)*DIST
         IF (GENEV.AND.HCS.GT.RCS) THEN
           CALL HWHSSS(IQ1,3,IQ2,1,4312,10)
           GOTO 9
         ENDIF
         HCS = HCS +     BSUTLL(IQ1)*DIST
         IF (GENEV.AND.HCS.GT.RCS) THEN
           CALL HWHSSS(IQ1,1,IQ2,1,3421,10)
           GOTO 9
         ENDIF
         HCS = HCS +     BSUTRR(IQ1)*DIST
         IF (GENEV.AND.HCS.GT.RCS) THEN
           CALL HWHSSS(IQ1,3,IQ2,3,3421,10)
           GOTO 9
         ENDIF
         HCS = HCS +     BSUTLR(IQ1)*DIST
         IF (GENEV.AND.HCS.GT.RCS) THEN
           CALL HWHSSS(IQ1,1,IQ2,3,3421,10)
           GOTO 9
         ENDIF
         HCS = HCS +     BSUTRL(IQ1)*DIST
         IF (GENEV.AND.HCS.GT.RCS) THEN
           CALL HWHSSS(IQ1,3,IQ2,1,3421,10)
           GOTO 9
         ENDIF
        END IF
       ELSE
         IQ2 = IGL
c _      ~*~
c qg  -> q g
         HCS = HCS +      CTSUL(IQ1)*DIST
         IF (GENEV.AND.HCS.GT.RCS) THEN
           CALL HWHSSS(IQ1,1,IQ2,0,2413,10)
           GOTO 9
         ENDIF
         HCS = HCS +      CTSUR(IQ1)*DIST
         IF (GENEV.AND.HCS.GT.RCS) THEN
           CALL HWHSSS(IQ1,3,IQ2,0,2413,10)
           GOTO 9
         ENDIF
         HCS = HCS +      CTUSL(IQ1)*DIST
         IF (GENEV.AND.HCS.GT.RCS) THEN
           CALL HWHSSS(IQ1,1,IQ2,0,4312,10)
           GOTO 9
         ENDIF
         HCS = HCS +      CTUSR(IQ1)*DIST
         IF (GENEV.AND.HCS.GT.RCS) THEN
           CALL HWHSSS(IQ1,3,IQ2,0,4312,10)
           GOTO 9
         ENDIF
       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) THEN
           CALL HWHSSS(IQ1,0,IQ2,0,2413,10)
           GOTO 9
         ENDIF
         HCS = HCS +      CTSUR(IQ2)*DIST
         IF (GENEV.AND.HCS.GT.RCS) THEN
           CALL HWHSSS(IQ1,0,IQ2,2,2413,10)
           GOTO 9
         ENDIF
         HCS = HCS +      CTUSL(IQ2)*DIST
         IF (GENEV.AND.HCS.GT.RCS) THEN
           CALL HWHSSS(IQ1,0,IQ2,0,3421,10)
           GOTO 9
         ENDIF
         HCS = HCS +      CTUSR(IQ2)*DIST
         IF (GENEV.AND.HCS.GT.RCS) THEN
           CALL HWHSSS(IQ1,0,IQ2,2,3421,10)
           GOTO 9
         ENDIF
       ELSEIF (ID2.LT.13) THEN
         IQ2 = ID2 - 6
c  _     ~ ~*
c gq  -> g q
         HCS = HCS +      CTSUL(IQ2)*DIST
         IF (GENEV.AND.HCS.GT.RCS) THEN
           CALL HWHSSS(IQ1,0,IQ2,1,3142,10)
           GOTO 9
         ENDIF
         HCS = HCS +      CTSUR(IQ2)*DIST
         IF (GENEV.AND.HCS.GT.RCS) THEN
           CALL HWHSSS(IQ1,0,IQ2,3,3142,10)
           GOTO 9
         ENDIF
         HCS = HCS +      CTUSL(IQ2)*DIST
         IF (GENEV.AND.HCS.GT.RCS) THEN
           CALL HWHSSS(IQ1,0,IQ2,1,4312,10)
           GOTO 9
         ENDIF
         HCS = HCS +      CTUSR(IQ2)*DIST
         IF (GENEV.AND.HCS.GT.RCS) THEN
           CALL HWHSSS(IQ1,0,IQ2,3,4312,10)
           GOTO 9
         ENDIF
       ELSE
         IQ2 = IGL
c        ~ ~*
c gg  -> q q
         DO 32 IQ = 1, 6
         HCS = HCS +       CSTUL(IQ)*DIST
         IF (GENEV.AND.HCS.GT.RCS) THEN
           CALL HWHSSS(IQ ,0,IQ ,1,2413,10)
           GOTO 9
         ENDIF
         HCS = HCS +       CSTUR(IQ)*DIST
         IF (GENEV.AND.HCS.GT.RCS) THEN
           CALL HWHSSS(IQ ,2,IQ ,3,2413,10)
           GOTO 9
         ENDIF
         HCS = HCS +       CSUTL(IQ)*DIST
         IF (GENEV.AND.HCS.GT.RCS) THEN
           CALL HWHSSS(IQ ,0,IQ ,1,4123,10)
           GOTO 9
         ENDIF
         HCS = HCS +       CSUTR(IQ)*DIST
         IF (GENEV.AND.HCS.GT.RCS) THEN
           CALL HWHSSS(IQ ,2,IQ ,3,4123,10)
           GOTO 9
         ENDIF
   32    CONTINUE
c        ~ ~
c gg  -> g g
         HCS = HCS +            DTSU*DIST
         IF (GENEV.AND.HCS.GT.RCS) THEN
           CALL HWHSSS(IQ1,0,IQ2,0,2341,10)
           GOTO 9
         ENDIF
         HCS = HCS +            DSTU*DIST
         IF (GENEV.AND.HCS.GT.RCS) THEN
           CALL HWHSSS(IQ1,0,IQ2,0,3421,10)
           GOTO 9
         ENDIF
         HCS = HCS +            DUTS*DIST
         IF (GENEV.AND.HCS.GT.RCS) THEN
           CALL HWHSSS(IQ1,0,IQ2,0,2413,10)
           GOTO 9
         ENDIF
       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(.TRUE.,.TRUE.)
      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>, 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 'HERWIG65.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)
      ENDIF
      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 'HERWIG65.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)
      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 'HERWIG65.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,HWUAEM,TMIN,TMAX
      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
      SAVE IDINIT,ICOFLO
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.D0/
      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)
C-- BRW fix 27/8/04: avoid double smearing of V mass
        CALL HWETWO(.FALSE.,.TRUE.)
        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)
c---mhs---implement cut on number of widths from nominal mass
        TMIN=-ATAN(2*GAMMAX-GAMV*GAMMAX**2/EMV)
        TMAX=ATAN(2*GAMMAX+GAMV*GAMMAX**2/EMV)
        EMV2=EMV*(EMV+GAMV*TAN(HWRUNI(0,TMIN,TMAX)))
        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.)
c---mhs minor improvement: replace thomson coupling by running coupling
c---mhs bug fix: missing factor of m^2/m0^2, where m0 is nominal mass
        GFACTR=GEV2NB*2.*PIFAC*HWUAEM(EMV2)*HWUALF(1,EMSCA)/(9.*SWEIN)
     $       *EMV2/EMV**2
        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.
c---mhs fix: switch off bg->Wt process since we neglect quark masses!
            IF (I.EQ.5.OR.I.EQ.11) DISFAC(1,I,2)=0
          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)*(TMAX-TMIN)/PIFAC
C---INCLUDE BRANCHING RATIO OF V
        CALL HWDBOZ(IDV,ID1,ID2,CV,CA,BR,0)
        EVWGT=EVWGT*CSFAC*BR
      ENDIF
      END
CDECK  ID>, HWHV2J.
*CMZ :-        -14/03/01  09:03:25  by  Peter Richardson
*-- Author :    Peter Richardson
C-----------------------------------------------------------------------
      SUBROUTINE HWHV2J
C-----------------------------------------------------------------------
C     Vector Boson production with two hard jets
C     Master subroutine for all vector boson + 2 jet processes
C     Currently implemented qqbar Z only
C-----------------------------------------------------------------------
      INCLUDE 'HERWIG65.INC'
      INTEGER I,J,K,IDBS,IPRC,IDP(6),ORD,IB,ICMF,IHEP,IFLOW,IZ,IBRAD,
     &     ICOL(5),IDZ,IQ
      DOUBLE PRECISION HWRGEN,HWRUNI,XMASS,PLAB,PRW,PCM,HWUAEM,BR,FLUX,
     &     MBOS,MBOS2,ME,DT(4),B(6),HWUPCM,CV,CA,PST,HWUALF,GMBS,FPI4,
     &     MQ(3),MQ2(3),MJAC,BRZED(12),PTP(5,2),PDOT(2),HWULDO,TWOPI2,
     &     AMP,WI(IMAXCH)
      DOUBLE COMPLEX S,D,F
      LOGICAL FSTCLL,MASS,GEN
      EXTERNAL HWRGEN,HWRUNI,HWUPCM,HWUALF,HWUAEM,HWULDO
      COMMON/HWHEWP/XMASS(10),PLAB(5,10),PRW(5,2),PCM(5,10)
      COMMON/HWHEWS/S(8,8,2),D(8,8)
      COMMON/HWHZBB/F(8,8)
      COMMON /HWPSOM/ WI
      SAVE ME,MBOS,MBOS2,GMBS,IDBS,IPRC,IDP,FSTCLL,MQ,MQ2,TWOPI2,FPI4,
     &     IQ,MASS
      SAVE B,BRZED
      DATA B/-1.0D0,-1.0D0,1.0D0,1.0D0,1.0D0,1.0D0/
      DATA BRZED/0.154D0,0.120D0,0.154D0,0.120D0,0.152D0,0.000D0,
     &           0.033D0,0.067D0,0.033D0,0.067D0,0.033D0,0.067D0/
C--generate the event
      IF(GENEV) THEN
C--find the particles produced
        IF(IPRC.EQ.0) THEN
          WRITE(*,1000)
          STOP
        ELSEIF(IPRC.GT.0.AND.IPRC.LE.16) THEN
          CALL HWHDYQ(FSTCLL,ME,IFLOW,IDP,ORD,IQ,MASS)
        ELSE
          CALL HWWARN('HWHV2J',502)
        ENDIF
        IF(ORD.EQ.2) THEN
          IB     = IDP(1)
          IDP(1) = IDP(2)
          IDP(2) = IB
          PRW(3,1) = -PRW(3,1)
          DO I=3,6
            PLAB(3,I)=-PLAB(3,I)
          ENDDO
        ENDIF
C--enter the incoming particles
        ICMF = NHEP+3
        DO I=1,2
          IHEP = NHEP+I
          CALL HWVEQU(5,PLAB(1,I),PHEP(1,IHEP))
          IDHW(IHEP) = IDP(I)
          IDHEP(IHEP)= IDPDG(IDP(I))
          ISTHEP(IHEP)=110+I
          JMOHEP(1,IHEP)=ICMF
          JMOHEP(I,ICMF)=IHEP
          JDAHEP(1,IHEP)=ICMF
        ENDDO
        IDHW(ICMF)=15
        IDHEP(ICMF)=IDPDG(15)
        ISTHEP(ICMF)=110
        CALL HWVSUM(4,PHEP(1,NHEP+1),PHEP(1,NHEP+2),PHEP(1,ICMF))
        CALL HWUMAS(PHEP(1,ICMF))
        JDAHEP(1,ICMF) = ICMF+1
        JDAHEP(2,ICMF) = ICMF+3
        NHEP = NHEP+3
C--Now the outgoing jets
        DO 10 I=1,2
          CALL HWVEQU(5,PLAB(1,2+I),PHEP(1,NHEP+I))
C--Set the status and pointers
          ISTHEP(NHEP+I)=113
          IDHW(NHEP+I)=IDP(2+I)
          IDHEP(NHEP+I)=IDPDG(IDP(2+I))
          JMOHEP(1,NHEP+I)=NHEP
 10     CONTINUE
        NHEP=NHEP+2
C--Now sort out the colour connections
        ICOL(1)=IFLOW/1000
        ICOL(2)=IFLOW/100-10*ICOL(1)
        ICOL(3)=IFLOW/10 -10*(IFLOW/100)
        ICOL(4)=IFLOW    -10*(IFLOW/10)
        DO 30 I=1,4
        J=I
        IF (J.GT.2) J=J+1
        K=ICOL(I)
        IF (K.GT.2) K=K+1
        JMOHEP(2,NHEP-5+J)=NHEP+K-5
 30     JDAHEP(2,NHEP-5+K)=NHEP+J-5
C--Now add the Z to the event record
        CALL HWVEQU(5,PRW(1,1),PHEP(1,NHEP+1))
        CALL HWVZRO(4,VHEP(1,NHEP+1))
        CALL HWUDKL(200,PHEP(1,NHEP+1),DT)
        CALL HWVSUM(4,VHEP(1,NHEP+1),DT,DT)
        IDHW(NHEP+1)=IDBS
        IDHEP(NHEP+1)=IDPDG(IDBS)
        JMOHEP(1,NHEP+1)=ICMF
        JMOHEP(2,NHEP+1)=ICMF
        ISTHEP(NHEP+1)=114
        NHEP = NHEP+1
        IBRAD = NHEP
C--generate the inital-state shower
        CALL HWBGEN
C--now add the decay products of the Z
        IZ = JDAHEP(1,IBRAD)
        ISTHEP(IZ) = 195
        JDAHEP(1,IZ) = NHEP+1
        JDAHEP(2,IZ) = NHEP+2
        IDHW(NHEP+1) = IDP(5)
        IDHW(NHEP+2) = IDP(6)
        ISTHEP(NHEP+1) = 113
        ISTHEP(NHEP+2) = 114
        IDHEP(NHEP+1) = IDPDG(IDP(5))
        IDHEP(NHEP+2) = IDPDG(IDP(6))
        JMOHEP(1,NHEP+1) = IZ
        JMOHEP(1,NHEP+2) = IZ
        JMOHEP(2,NHEP+1) = NHEP+2
        JDAHEP(2,NHEP+1) = NHEP+2
        JMOHEP(2,NHEP+2) = NHEP+1
        JDAHEP(2,NHEP+2) = NHEP+1
        CALL HWVEQU(5,PLAB(1,5),PHEP(1,NHEP+1))
        CALL HWVEQU(5,PLAB(1,6),PHEP(1,NHEP+2))
        DO IHEP=NHEP+1,NHEP+2
          CALL HWVEQU(4,DT,VHEP(1,IHEP))
C--Boost the fermion momenta to the rest frame of the original Z
          CALL HWULOF(PRW(1,1),PHEP(1,IHEP),PHEP(1,IHEP))
C--Now boost back to the lab from rest frame of the Z after radiation
          CALL HWULOB(PHEP(1,IZ),PHEP(1,IHEP),PHEP(1,IHEP))
        ENDDO
        NHEP = NHEP+2
      ELSE
C--initialisation
        IF(FSTWGT) THEN
C--for second option minimum invariant mass of the jet pair
C--set the type of events to be generated
          TWOPI2= FOUR*PIFAC**2
          FPI4  = (FOUR*PIFAC)**4
          IPRC = MOD(IPROC,100)
          IF(IPRC.GE.0.AND.IPRC.LE.16) THEN
C--Z + 2 jets
            MBOS  = RMASS(200)
            MBOS2 = MBOS**2
            GMBS  = MBOS2*GAMZ**2
            IDBS  = 200
            MQ(1) = ZERO
            MQ(2) = ZERO
            IF(IPRC.EQ.0) THEN
              IQ    = 0
            ELSEIF(IPRC.GT.0.AND.IPRC.LE.6) THEN
              IQ = IPRC
              IF(MJJMIN.LT.TWO*RMASS(IQ)) MJJMIN = TWO*RMASS(IQ)
            ELSEIF(IPRC.GE.11.AND.IPRC.LE.16) THEN
              MASS = .TRUE.
              IQ = IPRC-10
              MQ(1) = RMASS(IQ)
              MQ(2) = RMASS(IQ)
              IF(MJJMIN.LT.(MQ(1)+MQ(2))) MJJMIN = MQ(1)+MQ(2)
            ELSE
              CALL HWWARN('HWHV2J',500)
            ENDIF
            DO I=1,2
              MQ2(I) = MQ(I)**2
            ENDDO
          ELSE
            CALL HWWARN('HWHV2J',503)
          ENDIF
          FSTCLL = .TRUE.
        ENDIF
C--generate the weight
        EVWGT = ZERO
C--find the mass of the gauge boson
        CALL HWHGB1(1,2,IDBS,MJAC,MQ2(3),(PHEP(5,3)-MQ(1)-MQ(2))**2,
     &                                                       EMMIN**2)
        MQ(3) = SQRT(MQ2(3))
        MJAC = MJAC/((MQ2(3)-MBOS2)**2+GMBS)
C--do the phase space
        CALL HWH2PS(FLUX,GEN,MQ,MQ2)
        AMP = ONE
        IF(.NOT.GEN) RETURN
C--copy the gauge boson momentum
        CALL HWVEQU(5,PLAB(1,5),PRW(1,1))
C--select the decay mode of the boson
        CALL HWDBOZ(IDBS,IDP(5),IDP(6),CV,CA,BR,0)
        IDZ = IDP(5)
        IF(IDZ.GT.6) IDZ = IDZ-114
        BR = BR/BRZED(IDZ)
        IF(IDZ.LE.6) AMP = AMP*THREE
C--Finds the momenta of the boson decay products
        PST=HWUPCM(PRW(5,1),ZERO,ZERO)
        PLAB(5,5)=ZERO
        PLAB(5,6)=ZERO
        IF(PRW(5,1).LT.(RMASS(IDP(5))+RMASS(IDP(6)))) RETURN
        CALL HWDTWO(PRW(1,1),PLAB(1,5),PLAB(1,6),PST,TWO,.FALSE.)
        MJAC = HALF*PST*MJAC/TWOPI2/MQ(3)
C--copy the momenta, change order and boost to CMF
        PTP(1,1) = ZERO
        PTP(2,1) = ZERO
        PTP(3,1) = HALF*(XX(1)-XX(2))*PHEP(5,3)
        PTP(4,1) = HALF*(XX(1)+XX(2))*PHEP(5,3)
        PTP(5,1) = PHEP(5,3)*SQRT(XX(1)*XX(2))
        DO I=1,6
          CALL HWULOF(PTP(1,1),PLAB(1,I),PTP(1,2))
          PCM(1,I)=PTP(3,2)
          PCM(2,I)=PTP(1,2)
          PCM(3,I)=PTP(2,2)
          PCM(4,I)=PTP(4,2)
        ENDDO
        IF(MASS) THEN
C--Massive momentum case
C--reorder the products
C--move b and bbar to 9 and 10
          DO I=3,4
            DO J=1,5
              PCM(J,I+6) = PCM(J,I)
            ENDDO
          ENDDO
C--select the reference momenta for the b and bbar and put in 3,4
C--the results is independent of this choice
          CALL HWVEQU(5,PCM(1,1),PCM(1,3))
          CALL HWVEQU(5,PCM(1,1),PCM(1,4))
C--find the massless vectors for the b and bbar
          PDOT(1) = HALF*MQ2(1)/HWULDO(PCM(1,3),PCM(1, 9))
          PDOT(2) = HALF*MQ2(2)/HWULDO(PCM(1,4),PCM(1,10))
          DO I=1,4
            PCM(I,7) = PCM(I,9) -PDOT(1)*PCM(I,3)
            PCM(I,8) = PCM(I,10)-PDOT(2)*PCM(I,4)
          ENDDO
          PCM(5,7) = ZERO
          PCM(5,8) = ZERO
C--use e+e- code to calculate the spinor products
          CALL HWHEW2(8,PCM(1,1),S(1,1,2),S(1,1,1),D)
          DO I=1,8
            DO J=1,8
              S(I,J,2) = -S(I,J,2)
              D(I,J)   = TWO*D(I,J)
            ENDDO
          ENDDO
        ELSE
C--Massless case, use the e+e- code to calculate the spinor products
          CALL HWHEW2(6,PCM(1,1),S(1,1,2),S(1,1,1),D)
          DO I=1,6
            DO J=1,6
              D(I,J) = TWO*D(I,J)
              F(I,J) = B(I)*B(J)*D(I,J)
              S(I,J,2) = -S(I,J,2)
            ENDDO
          ENDDO
        ENDIF
C--now call the code to calculate the matrix element*PDF
        IF(IPRC.EQ.0) THEN
          WRITE(*,1000)
          STOP
        ELSEIF(IPRC.GT.0.AND.IPRC.LE.16) THEN
          CALL HWHDYQ(FSTCLL,ME,IFLOW,IDP,ORD,IQ,MASS)
        ELSE
          CALL HWWARN('HWHV2J',501)
          GOTO 999
        ENDIF
        AMP = AMP*MJAC*BR*FPI4*HWUAEM(EMSCA**2)**2*HWUALF(1,EMSCA)**2
        EVWGT = FLUX*ME*AMP
        IF(OPTM) THEN
          DO I=1,IMAXCH
            IF(CHON(I)) WI(I) = WI(I)*ME**2*AMP**2
          ENDDO
        ENDIF
      ENDIF
      RETURN
 1000 FORMAT('DRELL-YAN + 2 JETS NOT YET IMPLEMENTED')
 999  RETURN
      END
CDECK  ID>, HWHVVJ.
*CMZ :-        -11/05/01  09.19.45  by  Bryan Webber
*-- Author :    Bryan Webber
C-----------------------------------------------------------------------
      SUBROUTINE HWHVVJ
C-----------------------------------------------------------------------
C   VV + 1 JET PRODUCTION, WHERE VV=WW,ZZ,WZ FOR IPROC=2850,2860,2870
C-----------------------------------------------------------------------
      IMPLICIT NONE
      PRINT *,'  VV + 1 JET CALLED BUT NOT YET IMPLEMENTED'
      CALL HWWARN('HWHVVJ',500)
      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 'HERWIG65.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
      SAVE IDHWEX
      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(.TRUE.,.TRUE.)
      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)
          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
      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 'HERWIG65.INC'
      DOUBLE PRECISION HWRGEN,HWRUNI,HWUPCM,PRAN,PROB,COEF,CSFAC,EMW,
     & FTQK,PTOP,ETOP,EBOT,PMAX,FHAD,FTOT,BRAF,FLEP,TMIN,HWUAEM,TMAX
      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
      SAVE IWP
      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(.TRUE.,.TRUE.)
      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.
c---mhs---implement cut on number of widths from nominal mass
C--BRW fix 4/12/07: allow GAMMAX>Mass/Gamma
        IF (GAMW*GAMMAX.LT.RMASS(199))
     &       TMIN=MAX(TMIN,-ATAN(2*GAMMAX-GAMW*GAMMAX**2/RMASS(199)))
C--End BRW fix 4/12/07
        TMAX=ATAN(2*GAMMAX+GAMW*GAMMAX**2/RMASS(199))
        EMW=GAMW*TAN(HWRUNI(0,TMIN,TMAX))+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
c---mhs fix: normalization should be to on-shell total width
c  (only different if chosen mass is above top threshold)
          CSFAC=CSFAC*BRAF/THREE*(TMAX-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
      END
CDECK  ID>, HWICHK.
*-- Author :  M. Kirsanov
C-----------------------------------------------------------------------
      SUBROUTINE HWICHK
C-----------------------------------------------------------------------
      INCLUDE 'HERWIG65.INC'
      IF(RMASS(1).LT.0.1.OR.RMASS(1).GT.1.0.OR.
     &   FMRS(1,1,20,1).LT.0.1.OR.FMRS(1,1,20,1).GT.1.0) THEN
        STOP 'Block data hwudat not loaded, stop execution'
      ENDIF
      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 'HERWIG65.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) THEN
          CALL HWWARN('HWIODK',100)
          GOTO 999
        ENDIF
        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)
          GOTO 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>, HWIGIN.
*CMZ :-        -12/10/01  09.50.50  by  Peter Richardson
*-- Author :    Bryan Webber
C----------------------------------------------------------------------
      SUBROUTINE HWIGIN
C-----------------------------------------------------------------------
C     SETS INPUT PARAMETERS
C----------------------------------------------------------------------
      INCLUDE 'HERWIG65.INC'
      DOUBLE PRECISION FAC,ANGLE
      INTEGER I,J,N,L
      CHARACTER*28 TITLE
      SAVE TITLE
      DATA TITLE/'HERWIG 6.521  11th Mar. 2013'/
      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,'JHEP 0101 (2001) 010')
      CALL HWICHK
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---ALLOW NEGATIVE WEIGHTS?
      NEGWTS=.FALSE.
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
C SM Higgs width is actually recomputed by HWDHIG
C but this value corresponds to RMASS(201)=115.
      GAMH=0.0037
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--calculate left and right couplings of bosons for axial and vector ones
      DO 45 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)
        ENDIF
 45   CONTINUE
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   CONTINUE
      DO 55 I=1,MODMAX
      MODBOS(I)=0
 55   CONTINUE
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 Specify 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--NEW IN V6.521: Rescale factor for PDFs in initial-state showers ONLY
      FSHWR=1.0
C---INTRINSIC PT OF SPACELIKE PARTONS (RMS)
      PTRMS=0.0
C---MASS PARAMETER IN REMNANT FRAGMENTATION
      BTCLM=1.0
C---PARAMETERS CONTROLLING VERY SMALL-X BEHAVIOUR OF PDFS
      PDFX0=0
      PDFPOW=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)
C    6  FOR MRST98LO   central alpha_s/gluon
C    7  FOR MRST98LO   higher gluon
C    8  FOR MRST98LO average of central and higher gluon (default)
      NSTRU=8
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--EXTRA MASS FOR DIQUARKS IN B & C BARYON PARTONIC DECAYS
      DQXTRA=0.2D0
C---B DECAY PACKAGE ('HERW'=>HERWIG, 'EURO'=>EURODEC, 'CLEO'=>CLEO)
      BDECAY='HERW'
C---TAU DECAY PACKAGE ('HERWIG'=>HERWIG, 'TAUOLA'=> TAUOLA)
      TAUDEC='HERWIG'
C--default options for TAUOLA (if used)
C JAK=0 ALL MODES
C JAK=1 ELECTRON MODE
C JAK=2 MUON MODE
C JAK=3 PION MODE
C JAK=4 RHO MODE
C JAK=5 A1 MODE
C JAK=6 K MODE
C JAK=7 K* MODE
C JAK=8 nPI MODE
C--tau decay modes (1 is tau+ and 2 is tau-)
      JAK1 = 0
      JAK2 = 0
C--radiative corrections in tau decay (1 on/ 0 off)
      ITDKRC=1
C--use PHOTOS in tau decays (1 PHOTOS/ 0 no PHOTOS)
      IFPHOT=1
C--use PHOTOS in ttbar production and decay
      ITOPRD=0
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=ONE
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 FORMULA: 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---MIN jet-jet mass in Drell-Yan+2 jets
      MJJMIN = 10.0D0
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=1D-3
C---MAX NO OF (CODE.GE.100) ERRORS
      MAXER=MAX(10,MAXEV/100)
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 shots and steps for the optimisation procedure
      IOPSH  = 1000
      IOPSTP = 10
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---MAXIMUM NUMBER OF TRIES TO GENERATE SPIN DECAYS
      NSNTRY=500
C---MAXIMUM NUMBER OF TRIES TO GENERATE FOUR/FIVE BODY DECAYS
      NDETRY=20000
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.
C---SPIN CORRELATIONS IN TOP/TAU/SUSY DECAYS
      SYSPIN = .TRUE.
C---THREE BODY SUSY MATRIX ELEMENTS
      THREEB = .TRUE.
C---FOUR  BODY SUSY MATRIX ELEMENTS
      FOURB  = .FALSE.
C---OPTION FOR DIFFERENT COLOUR FLOWS IN SPIN CORRELATION
C---(1 is first  option in DAMTP-2001-83 only for SM/MSSM)
C---(2 is second option in DAMTP-2001-83 needed for RPV)
      SPCOPT = 1
C---number of weights for maximum search for 3/4 body MEs
      NSEARCH = 500
C--unit to read three/four body decays from (if 0 computed)
      LRDEC = 0
C--unit to write three/four body decays to (if 0 not written)
      LWDEC = 88
C--WHETHER OR NOT TO OPTIMIZE THE WEIGHTS IN MULTICHANNEL PROCESSES
      OPTM = .FALSE.
C--initializes the multichannel integrals
      CALL HWIPHS(1)
C   CIRCE INTERFACE
C---CIRCE IS CONTROLLED BY THESE NEW VARIABLES:
C---CIRCOP = CIRCE OPTION: 0=NO CIRCE, STANDARD HERWIG
C                          1=NO CIRCE, HERWIG WITH COLLINEAR KINEMATICS
C                          2=BEAMSTRAHLUNG FROM CIRCE
C                          3=BEAMSTRAHLUNG FROM CIRCE PLUS BREMSTRAHLUNG
C   THEREFORE 0 SHOULD BE REGARDED AS OFF AND 3 AS ON.  THE OTHERS ARE
C   MAINLY THERE FOR CROSS-CHECKING PURPOSES
      CIRCOP=0
C---CIRCAC, CIRCVR, CIRCRV, CIRCCH = CIRCE INPUTS ACC, VER, REV AND CHAT
C   EG CIRCAC=1=SBAND, CIRCAC=2=TESLA, CIRCAC=3=XBAND
      CIRCAC=2
      CIRCVR=7
      CIRCRV=9999 12 31
      CIRCCH=0
C---END OF CIRCE VARIABLES
C--options for Les Houches Accord
C--allow self connected gluons (.TRUE.) or forbid (.FALSE.)
      LHGLSF = .FALSE.
C--generate the soft event (.TRUE.) or don't (.FALSE.)
      LHSOFT = .TRUE.
C--conserve longitudinal momentum (.true.) or rapidity of hard process
      PRESPL = .TRUE.
C--BRW mod 21/11/06 to allow for truncated shower and pt-veto
      TRUNSH = .FALSE.
      PTVETO = .FALSE.
      END
CDECK  ID>, HWIGUP.
*CMZ :-        -15/07/02  16.42.23  by  Peter Richardson
*-- Author :    Peter Richardson
C----------------------------------------------------------------------
      SUBROUTINE HWIGUP
C----------------------------------------------------------------------
C     Use the GUPI (Generic User Process Interface) run common block
C     to initialise HERWIG
C----------------------------------------------------------------------
      INCLUDE 'HERWIG65.INC'
      INTEGER MAXPUP
      PARAMETER(MAXPUP=100)
      INTEGER IDBMUP,PDFGUP,PDFSUP,IDWTUP,NPRUP,LPRUP
      DOUBLE PRECISION EBMUP,XSECUP,XERRUP,XMAXUP
      COMMON /HEPRUP/ IDBMUP(2),EBMUP(2),PDFGUP(2),PDFSUP(2),
     &                IDWTUP,NPRUP,XSECUP(MAXPUP),XERRUP(MAXPUP),
     &                XMAXUP(MAXPUP),LPRUP(MAXPUP)
      CHARACTER *8 DUMMY,PDFNUC(9),PDFPI(9),PDFPHT(9)
      INTEGER I,IDB(2)
      SAVE PDFNUC,PDFPI ,PDFPHT
      DATA PDFNUC/ 'DO','DFLM','MRS','CTEQ','GRV','ABFOW','BM',
     &             '       ','       '/
      DATA PDFPI / 'OW-P','       ','SMRS-P','       ','GRV-P',
     &             'ABFKW-P','       ','       ','       '/
      DATA PDFPHT /'DO-G','DG-G','LAC-G','GS-G','GRV-G','ACG-G',
     &             '       ','WHIT-G','SaSph'/
C--call the user routine to do the initialisation
c      CALL UPINIT
C--setup the beam particles and momentum
      CALL HWUIDT(1,IDBMUP(1),IDB(1),DUMMY)
      PART1=DUMMY
      CALL HWUIDT(1,IDBMUP(2),IDB(2),DUMMY)
      PART2=DUMMY
      PBEAM1 = SQRT(EBMUP(1)**2-RMASS(IDB(1))**2)
      PBEAM2 = SQRT(EBMUP(2)**2-RMASS(IDB(2))**2)
C--set up for PDFLIB if need
      DO I=1,2
        IF(PDFGUP(I).NE.-1) THEN
          IF(PDFGUP(I).LT.1.OR.PDFGUP(I).GT.9) CALL HWWARN('HWIGUP',500)
          MODPDF(I) = PDFSUP(I)
C--proton/neutron beams
          IF(ABS(IDBMUP(I)).EQ.2212.OR.ABS(IDBMUP(I)).EQ.2112) THEN
            AUTPDF(I) = PDFNUC(PDFGUP(I))
C--photon beams
          ELSEIF(ABS(IDBMUP(I)).EQ.22) THEN
            AUTPDF(I) = PDFPHT(PDFGUP(I))
C--pion beams
          ELSEIF(ABS(IDBMUP(I)).EQ.211) THEN
            AUTPDF(I) = PDFPI(PDFGUP(I))
C--unknown beam type
          ELSE
            CALL HWWARN('HWIGUP',500)
          ENDIF
        ENDIF
      ENDDO
C--decide what to do about the weights
      IF(ABS(IDWTUP).EQ.1) THEN
        WGTMAX = ZERO
        AVWGT  = ONE
        AVABW  = ONE
        NOWGT  = .TRUE.
C--sum up the magnitudes of the maximum weight
        LHMXSM = ZERO
        DO I=1,NPRUP
          LHXMAX(I) = XMAXUP(I)*1.0D-3
          LHMXSM    = LHMXSM+ABS(LHXMAX(I))
        ENDDO
        ITYPLH = 0
      ELSEIF(ABS(IDWTUP).EQ.2) THEN
        WGTMAX = ZERO
        AVWGT  = ONE
        AVABW  = ONE
        NOWGT = .TRUE.
C--sum the cross sections and obtain the total
        LHMXSM = ZERO
        DO I=1,NPRUP
          LHXSCT(I) = XSECUP(I)*1.0D-3
          LHXMAX(I) = XMAXUP(I)*1.0D-3
          LHMXSM = LHMXSM+ABS(LHXSCT(I))
        ENDDO
        ITYPLH = 0
      ELSEIF(ABS(IDWTUP).EQ.3) THEN
        WGTMAX = ONE
        AVWGT  = ONE
        AVABW  = ONE
        NOWGT = .TRUE.
      ELSEIF(ABS(IDWTUP).EQ.4) THEN
        WGTMAX = ONE
        AVWGT  = ONE
        NOWGT = .FALSE.
      ENDIF
      IF(IDWTUP.LT.0) NEGWTS = .TRUE.
C--zero the weight
      DO I=1,NPRUP
        LHWGT (I) = ZERO
        LHWGTS(I) = ZERO
        LHIWGT(I) = 0
        LHNEVT(I) = 0
      ENDDO
      END
CDECK  ID>, HWIMDE.
*CMZ :-        -12/10/01  17.14.22  by  Peter Richardson
*-- Author :    Peter Richardson
C-----------------------------------------------------------------------
      SUBROUTINE HWIMDE
C-----------------------------------------------------------------------
C     Subroutine to merge Higgs WW/ZZ decay modes for four body ME
C-----------------------------------------------------------------------
      INCLUDE 'HERWIG65.INC'
      INTEGER IH,I,NMODE,J,K
      LOGICAL REMOVE
      DOUBLE PRECISION BR
      REMOVE = .FALSE.
C--first identify the WW modes
      DO IH=203,204
        BR = ZERO
        NMODE = 0
        DO I=NDECSY,NDKYS
          IF(IDK(I).EQ.IH.AND.((IDKPRD(3,I).NE.0.AND.IDKPRD(4,I).EQ.0
     &      .AND.(IDKPRD(1,I).EQ.198.OR.IDKPRD(1,I).EQ.199).AND.
     &          ((IDKPRD(2,I).LE.12 .AND.IDKPRD(3,I).LE.12).OR.
     &           (IDKPRD(2,I).GE.121.AND.IDKPRD(3,I).GE.121.AND.
     &            IDKPRD(2,I).LE.132.AND.IDKPRD(3,I).LE.132)))
     &          .OR.((IDKPRD(4,I).NE.0.AND.IDKPRD(5,I).EQ.0.AND.
     &          (((IDKPRD(1,I).LE.12 .AND.IDKPRD(2,I).LE.12).OR.
     &            (IDKPRD(1,I).GE.121.AND.IDKPRD(2,I).GE.121.AND.
     &             IDKPRD(1,I).LE.132.AND.IDKPRD(2,I).LE.132))
     &          .AND.ICHRG(IDKPRD(1,I))+ICHRG(IDKPRD(2,I)).NE.0)
     &          .AND.
     &          (((IDKPRD(3,I).LE.12 .AND.IDKPRD(4,I).LE.12).OR.
     &           (IDKPRD(3,I).GE.121.AND.IDKPRD(4,I).GE.121.AND.
     &            IDKPRD(3,I).LE.132.AND.IDKPRD(4,I).LE.132))
     &       .AND.ICHRG(IDKPRD(3,I))+ICHRG(IDKPRD(4,I)).NE.0))))) THEN
            BR=BR+BRFRAC(I)
            NME(I) = -100
            NMODE=NMODE+1
          ENDIF
        ENDDO
C--add the new mode to the event record
        IF(NMODE.GT.0) THEN
          REMOVE = .TRUE.
          NDKYS = NDKYS+1
          IDK(NDKYS) = IH
          BRFRAC(NDKYS) = BR
          NME(I) = 0
          IDKPRD(1,NDKYS) = 198
          IDKPRD(2,NDKYS) = 199
          DO I=3,5
            IDKPRD(I,NDKYS) = 0
          ENDDO
        ENDIF
      ENDDO
C--now do the ZZ modes
      DO IH=203,204
        BR = ZERO
        NMODE = 0
        DO I=NDECSY,NDKYS
          IF(IDK(I).EQ.IH.AND.(IDKPRD(3,I).NE.0.AND.IDKPRD(4,I).EQ.0
     &          .AND.IDKPRD(1,I).EQ.200.AND.
     &          ((IDKPRD(2,I).LE.12 .AND.IDKPRD(3,I).LE.12).OR.
     &           (IDKPRD(2,I).GE.121.AND.IDKPRD(3,I).GE.121.AND.
     &            IDKPRD(2,I).LE.132.AND.IDKPRD(3,I).LE.132))
     &          .OR.((IDKPRD(4,I).NE.0.AND.IDKPRD(5,I).EQ.0.AND.
     &          (((IDKPRD(1,I).LE.12 .AND.IDKPRD(2,I).LE.12).OR.
     &            (IDKPRD(1,I).GE.121.AND.IDKPRD(2,I).GE.121.AND.
     &             IDKPRD(1,I).LE.132.AND.IDKPRD(2,I).LE.132))
     &          .AND.ICHRG(IDKPRD(1,I))+ICHRG(IDKPRD(2,I)).EQ.0)
     &          .AND.
     &          (((IDKPRD(3,I).LE.12 .AND.IDKPRD(4,I).LE.12).OR.
     &           (IDKPRD(3,I).GE.121.AND.IDKPRD(4,I).GE.121.AND.
     &            IDKPRD(3,I).LE.132.AND.IDKPRD(4,I).LE.132))
     &     .AND.ICHRG(IDKPRD(3,I))+ICHRG(IDKPRD(4,I)).EQ.0))))) THEN
            BR=BR+BRFRAC(I)
            NME(I) = -100
            NMODE=NMODE+1
          ENDIF
        ENDDO
C--add the new mode to the event record
        IF(NMODE.GT.0) THEN
          REMOVE = .TRUE.
          NDKYS = NDKYS+1
          IDK(NDKYS) = IH
          BRFRAC(NDKYS) = BR
          NME(I) = 0
          IDKPRD(1,NDKYS) = 200
          IDKPRD(2,NDKYS) = 200
          DO I=3,5
            IDKPRD(I,NDKYS) = 0
          ENDDO
        ENDIF
      ENDDO
      IF(.NOT.REMOVE) RETURN
C--now remove the modes we have marked
      I = 0
      DO J=NDECSY,NDKYS
 10     IF(NME(I+J).EQ.-100) I=I+1
        IDK(J) = IDK(J+I)
        BRFRAC(J)=BRFRAC(I+J)
        NME(J) = NME(I+J)
        DO K=1,5
          IDKPRD(K,J)=IDKPRD(K,I+J)
        ENDDO
        IF(NME(J).EQ.-100) GOTO 10
      ENDDO
C--reset the number of modes
      NDKYS = NDKYS-I
      END
CDECK  ID>, HWIPHS.
*CMZ :-        -02/04/01  12.11.55  by  Peter Richardson
*-- Author :    Peter Richardson
C-----------------------------------------------------------------------
      SUBROUTINE HWIPHS(IOPT)
C-----------------------------------------------------------------------
C     Subroutine to initialise the multichannel integration
C     IOPT = 1 sets the weights for the different channels to their
C              default values
C     IOPT = 2 optimises the weights for the process selected
C-----------------------------------------------------------------------
      INCLUDE 'HERWIG65.INC'
      INTEGER I,IPRC,ICH,IOPT,ISTP,IWGT,IFER,IANT,IGAU,IQRK
      LOGICAL CALLED,TEV,LHC
      DOUBLE PRECISION CHNPST(IMAXCH,IMAXOP),D(IMAXOP),CHWGTS(IMAXCH),
     &     TOTAL,DEM,DMIN,CV,CA,BR,WA(IMAXCH),WITOT,WI(IMAXCH),
     &     TEVGWT(10,5),LHCGWT(10,5),TEVQWT(6,6,2),LHCQWT(6,6,2)
      COMMON /HWPSOM/ WI
      SAVE CALLED,DEM,TEVGWT,LHCGWT,TEVQWT,LHCQWT
      DATA CALLED/.FALSE./
      DATA TEVGWT/0.19684D0,0.00403D0,0.63772D0,0.01209D0,0.01321D0,
     &            0.00054D0,0.12984D0,0.00257D0,0.00296D0,0.00019D0,
     &            0.24146D0,0.00944D0,0.33949D0,0.01430D0,0.01918D0,
     &            0.00169D0,0.33919D0,0.01433D0,0.01931D0,0.00161D0,
     &            0.22270D0,0.00004D0,0.38873D0,0.00007D0,0.00009D0,
     &            0.00000D0,0.38820D0,0.00007D0,0.00009D0,0.00000D0,
     &            0.03228D0,0.00629D0,0.43227D0,0.01147D0,0.00010D0,
     &            0.03685D0,0.43270D0,0.01193D0,0.00010D0,0.03602D0,
     &            0.05828D0,0.00018D0,0.46870D0,0.00033D0,0.00047D0,
     &            0.00092D0,0.46940D0,0.00033D0,0.00047D0,0.00094D0/
      DATA LHCGWT/0.10679D0,0.00075D0,0.50915D0,0.00105D0,0.00126D0,
     &            0.00039D0,0.37853D0,0.00080D0,0.00092D0,0.00037D0,
     &            0.18163D0,0.00456D0,0.38555D0,0.00906D0,0.01160D0,
     &            0.00095D0,0.38498D0,0.00920D0,0.01163D0,0.00084D0,
     &            0.16647D0,0.00003D0,0.41691D0,0.00007D0,0.00009D0,
     &            0.00000D0,0.41627D0,0.00007D0,0.00009D0,0.00000D0,
     &            0.01957D0,0.00578D0,0.42971D0,0.01087D0,0.00015D0,
     &            0.02305D0,0.47944D0,0.00750D0,0.00016D0,0.02377D0,
     &            0.03659D0,0.00027D0,0.45268D0,0.00041D0,0.00063D0,
     &            0.00062D0,0.50700D0,0.00045D0,0.00069D0,0.00066D0/
      DATA TEVQWT/0.37855D0,0.15212D0,0.38016D0,0.00048D0,0.00047D0,
     &            0.08822D0,0.37292D0,0.19051D0,0.36770D0,0.00178D0,
     &            0.00180D0,0.06529D0,0.37724D0,0.12202D0,0.37579D0,
     &            0.00013D0,0.00013D0,0.12470D0,0.36728D0,0.12100D0,
     &            0.36521D0,0.00014D0,0.00014D0,0.14622D0,0.37548D0,
     &            0.12144D0,0.37410D0,0.00013D0,0.00013D0,0.12873D0,
     &            0.08694D0,0.32633D0,0.07192D0,0.00000D0,0.00000D0,
     &            0.51481D0,0.37831D0,0.15131D0,0.38081D0,0.00079D0,
     &            0.00077D0,0.08801D0,0.37494D0,0.19012D0,0.36496D0,
     &            0.00243D0,0.00246D0,0.06509D0,0.37726D0,0.12071D0,
     &            0.37641D0,0.00031D0,0.00032D0,0.12499D0,0.36248D0,
     &            0.12007D0,0.36203D0,0.00242D0,0.00243D0,0.15057D0,
     &            0.31054D0,0.13065D0,0.30760D0,0.04158D0,0.04178D0,
     &            0.16785D0,0.04116D0,0.00125D0,0.04116D0,0.32149D0,
     &            0.32030D0,0.27465D0/
      DATA LHCQWT/0.45556D0,0.06337D0,0.45712D0,0.00022D0,0.00022D0,
     &            0.02351D0,0.43712D0,0.07332D0,0.45023D0,0.00021D0,
     &            0.00021D0,0.03890D0,0.44611D0,0.08021D0,0.44572D0,
     &            0.00176D0,0.00170D0,0.02450D0,0.47268D0,0.03728D0,
     &            0.46843D0,0.00004D0,0.00004D0,0.02152D0,0.45662D0,
     &            0.06644D0,0.45586D0,0.00065D0,0.00063D0,0.01980D0,
     &            0.18486D0,0.27252D0,0.19067D0,0.00000D0,0.00000D0,
     &            0.35195D0,0.45530D0,0.06307D0,0.45770D0,0.00037D0,
     &            0.00038D0,0.02318D0,0.43653D0,0.07295D0,0.45173D0,
     &            0.00036D0,0.00036D0,0.03807D0,0.47312D0,0.04168D0,
     &            0.46993D0,0.00010D0,0.00010D0,0.01506D0,0.47047D0,
     &            0.03721D0,0.46860D0,0.00101D0,0.00100D0,0.02172D0,
     &            0.44379D0,0.05231D0,0.45440D0,0.01608D0,0.01624D0,
     &            0.01717D0,0.25443D0,0.04115D0,0.25503D0,0.18346D0,
     &            0.18255D0,0.08337D0/
      IF(IERROR.NE.0) RETURN
C--initialize for tevatron or LHC based on energy
      TEV = NINT(PBEAM1/1000.0D0).EQ.1
      LHC = NINT(PBEAM1/1000.0D0).EQ.7
C--first the initalisation
      IF(IOPT.EQ.1) THEN
        IPRO = MOD(IPROC/100,100)
        IPRC=MOD(IPROC,100)
        DO I=1,20
          CHNPRB(I) = ZERO
          CHON(I) = .FALSE.
        ENDDO
C--gauge boson pair production
        IF(IPRO.EQ.28.AND.IPRC.LT.50) THEN
          IF(MOD(IPRC,5).NE.0.OR.IPRC.EQ.5.OR.IPRC.GT.25)
     &          CALL HWWARN('HWIPHS',500)
          DO I=1,10
             CHON(I) = .TRUE.
          ENDDO
C--select the process
          IGAU = INT(IPRC/5)
          IF(IGAU.EQ.0) IGAU = IGAU+1
          IF(TEV) THEN
            DO I=1,10
              CHNPRB(I) = TEVGWT(I,IGAU)
            ENDDO
          ELSEIF(LHC) THEN
            DO I=1,10
              CHNPRB(I) = LHCGWT(I,IGAU)
            ENDDO
          ELSE
            DO I=1,10
              CHNPRB(I) = 0.1D0
            ENDDO
          ENDIF
          CALLED=.TRUE.
          DEM = ONE/DBLE(IOPSH)
C--Drell Yan + 2 jet production
        ELSEIF(IPRO.EQ.29) THEN
          DO I=1,6
            CHON(I) = .TRUE.
          ENDDO
          IF(IPRC.LE.6) THEN
            IGAU = 1
          ELSEIF(IPRC.GE.11.AND.IPRC.LE.16) THEN
            IGAU = 2
          ELSE
            CALL HWWARN('HWIPHS',502)
          ENDIF
          IQRK = MOD(IPRC,10)
          IF(IQRK.EQ.0.OR.IQRK.GT.6) CALL HWWARN('HWIPHS',503)
          IF(TEV) THEN
            DO I=1,6
              CHNPRB(I) = TEVQWT(I,IQRK,IGAU)
            ENDDO
          ELSEIF(LHC) THEN
            DO I=1,6
              CHNPRB(I) = LHCQWT(I,IQRK,IGAU)
            ENDDO
          ELSE
            DO I=1,6
              CHNPRB(I) = 1.0D0/6.0D0
            ENDDO
          ENDIF
          CALLED=.TRUE.
          DEM = ONE/DBLE(IOPSH)
        ELSE
          CALLED=.FALSE.
          RETURN
        ENDIF
      ELSE
        IF(.NOT.CALLED) RETURN
        TOTAL = ZERO
        DO I=1,IMAXCH
          IF(CHON(I)) TOTAL = TOTAL+CHNPRB(I)
        ENDDO
        IF(TOTAL.EQ.ZERO) CALL HWWARN('HWIPHS',501)
        IF(TOTAL.NE.ONE) THEN
          DO I=1,IMAXCH
            IF(CHON(I)) CHNPRB(I) = CHNPRB(I)/TOTAL
          ENDDO
        ENDIF
        IF(.NOT.OPTM) RETURN
        WRITE(*,50)
C--optimise the weights
        FSTWGT=.TRUE.
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))
        DO ISTP=1,IOPSTP
          WRITE(*,100) ISTP
          DO ICH=1,IMAXCH
            CHWGTS(ICH)  = ZERO
            CHNPST(ICH,ISTP) = CHNPRB(ICH)
            IF(CHON(ICH)) WRITE(*,200) ICH,CHNPRB(ICH)
          ENDDO
C--compute the weights for the various channels
          DO I=1,IOPSH
             IF(IPRO.EQ.28) THEN
               CALL HWHGBP
               FSTWGT=.FALSE.
               CALL HWDBZ2(200,IFER,IANT,CV,CA,BR,2,ZERO)
             ELSEIF(IPRO.EQ.29) THEN
               CALL HWHV2J
               FSTWGT=.FALSE.
               CALL HWDBOZ(200,IFER,IANT,CV,CA,BR,2)
             ENDIF
             DO ICH=1,IMAXCH
             IF(CHON(ICH)) CHWGTS(ICH) = CHWGTS(ICH)+WI(ICH)
             ENDDO
          ENDDO
          WITOT = ZERO
          DO ICH=1,IMAXCH
            IF(CHON(ICH)) THEN
              WA(ICH)  = CHWGTS(ICH)*DEM
              WITOT = WITOT+WA(ICH)*CHNPRB(ICH)
            ENDIF
          ENDDO
C--now pick the next set of probablities for the different channels
          TOTAL = ZERO
          DO ICH=1,IMAXCH
            IF(CHON(ICH)) THEN
              CHNPRB(ICH) = CHNPRB(ICH)*SQRT(WA(ICH))
              TOTAL = TOTAL+CHNPRB(ICH)
            ENDIF
          ENDDO
          DO ICH=1,IMAXCH
            CHNPRB(ICH)=CHNPRB(ICH)/TOTAL
          ENDDO
          D(ISTP) = ZERO
          DO ICH=1,IMAXCH
            IF(CHON(ICH)) THEN
              IF(D(ISTP).EQ.ZERO) THEN
                 D(ISTP) = ABS(WITOT-WA(ICH))
              ELSE
                 D(ISTP) = MAX(D(ISTP),ABS(WITOT-WA(ICH)))
              ENDIF
            ENDIF
          ENDDO
          WRITE(*,300) D(ISTP)
        ENDDO
C--pick the best set of weights
        IWGT = 1
        DMIN = D(1)
        DO I=2,IOPSTP
          IF(D(I).LT.DMIN) THEN
            IWGT = I
            DMIN = D(I)
          ENDIF
        ENDDO
        WRITE(*,500) IWGT
        DO I=1,IMAXCH
          IF(CHON(I)) THEN
            CHNPRB(I)=CHNPST(I,IWGT)
            WRITE(*,200) I,CHNPRB(I)
          ENDIF
        ENDDO
        OPTM = .FALSE.
      ENDIF
      RETURN
 50   FORMAT(/10X,'OPTIMIZING THE WEIGHTS FOR MULTICHANNEL INTEGRATION')
 100  FORMAT(/10X,'PERFORMING ITERATION',I2,/10X)
 200  FORMAT( 12X,'CHNPRB(',I2,') = ',F7.5)
 300  FORMAT(/10X,'DIFFERENCE IN W BETWEEN CHANNELS',E15.5)
 500  FORMAT(/10X,'SELECTED ITERATION',I2)
      END
CDECK  ID>, HWISPC.
*CMZ :-        -27/07/99  16.38.25  by  Peter Richardson
*-- Author :    Peter Richardson
C-----------------------------------------------------------------------
      SUBROUTINE HWISPC
C-----------------------------------------------------------------------
C     Calculates the couplings for the SUSY decays for spin correlations
C     and 3/4 body matrix elements
C-----------------------------------------------------------------------
      INCLUDE 'HERWIG65.INC'
      DOUBLE PRECISION HWUALF,PRE,MCHAR(2),QIJPP(4,4),SIJPP(4,4),
     &     DIJ(2,2),QIJ(2,2),R(4,2),SIJ(2,2)
      INTEGER I,J,K,L,IH,IK,IL,IQ
      COMMON /HWSPNC/ SW,CW,TW,E,G,RT,ORT,MW,MZ,GS,AFN,AFG,AFC,OIJ,OIJP,
     &               OIJPP,HNN,HCC,HNC,HFF,HWW,HZZ,ZAB,HHB
      DOUBLE PRECISION SW,CW,TW,E,G,RT,ORT,MW,MZ,GS,AFN(2,12,2,4),
     &     AFG(2,6,2),AFC(2,12,2,2),OIJ(2,4,2),OIJP(2,2,2),OIJPP(2,4,4),
     &     HNN(2,3,4,4),HCC(2,3,2,2),HNC(2,4,2),HFF(2,4,12),HWW(2),
     &     HZZ(2),ZAB(12,2,2),HHB(2,3)
      EXTERNAL HWUALF
      SAVE DIJ
      DATA DIJ/1.0D0,0.0D0,0.0D0,1.0D0/
      IF(IERROR.NE.0) RETURN
C--coupling constants
      SW  = SQRT(SWEIN)
      CW  = SQRT(ONE-SWEIN)
      TW  = SW/CW
      E   = SQRT(FOUR*PIFAC/128.0D0)
      G   = E/SW
      RT  = SQRT(TWO)
      ORT = ONE/RT
      MW  = RMASS(198)
      MZ  = RMASS(200)
      IF(.NOT.SUSYIN) RETURN
      GS  = SQRT(HWUALF(3,RMASS(449))*FOUR*PIFAC)
C--couplings of the neutralinos to the squarks
      DO 1 L=1,4
      MCHAR(1) = ORT*G*ZMIXSS(L,3)/MW/COSB
      MCHAR(2) = ORT*G*ZMIXSS(L,4)/MW/SINB
      DO 1 I=1,3
      J = 2*I-1
      DO 2 K=1,2
      AFN(1,J,K,L) =-MCHAR(1)*RMASS(J)*QMIXSS(J,2,K)
     &                    -RT*E*QMIXSS(J,1,K)*SLFCH(J,L)
 2    AFN(2,J,K,L) =-ZSGNSS(L)*(MCHAR(1)*RMASS(J)*QMIXSS(J,1,K)
     &                          +RT*E*QMIXSS(J,2,K)*SRFCH(J,L))
      J = 2*I
      DO 1 K=1,2
      AFN(1,J,K,L) =-MCHAR(2)*RMASS(J)*QMIXSS(J,2,K)
     &                       -RT*E*QMIXSS(J,1,K)*SLFCH(J,L)
 1    AFN(2,J,K,L) =-ZSGNSS(L)*(MCHAR(2)*RMASS(J)*QMIXSS(J,1,K)
     &                        +RT*E*QMIXSS(J,2,K)*SRFCH(J,L))
C--couplings of the neutralinos to the sleptons
      DO 3 L=1,4
      MCHAR(1) = ORT*G*ZMIXSS(L,3)/MW/COSB
      DO 3 I=1,3
      J = 2*I-1
      IL = J+10
      IK = J+6
      DO 4 K=1,2
      AFN(1,IK,K,L) =-(MCHAR(1)*RMASS(110+IL)*LMIXSS(J,2,K)
     &                        +RT*E*LMIXSS(J,1,K)*SLFCH(IL,L))
 4    AFN(2,IK,K,L) =-ZSGNSS(L)*(MCHAR(1)*RMASS(110+IL)*LMIXSS(J,1,K)
     &                            +RT*E*LMIXSS(J,2,K)*SRFCH(IL,L))
      J = J+1
      IL = IL+1
      IK = IK+1
      DO 3 K=1,2
      AFN(1,IK,K,L) =-RT*E*LMIXSS(J,1,K)*SLFCH(IL,L)
 3    AFN(2,IK,K,L) = ZERO
C--couplings of the gluinos to the squarks
      DO 5 I=1,6
      DO 5 K=1,2
      AFG(1,I,K) = -GS*RT*QMIXSS(I,1,K)
 5    AFG(2,I,K) = +GS*RT*QMIXSS(I,2,K)
C--couplings of the charginos to the squarks
      DO 6 L=1,2
      MCHAR(1) =-WMXVSS(L,2)*ORT/MW/SINB
      MCHAR(2) =-WMXUSS(L,2)*ORT/MW/COSB
      DO 6 I=1,3
      J = 2*I-1
      DO 7 K=1,2
      AFC(1,J,K,L) = -G*( WMXUSS(L,1)*QMIXSS(J,1,K)
     &                   +MCHAR(2)*RMASS(J)*QMIXSS(J,2,K))
 7    AFC(2,J,K,L) = -G*WSGNSS(L)*MCHAR(1)*
     &              RMASS(J+1)*QMIXSS(J,1,K)
      J = 2*I
      DO 6 K=1,2
      AFC(1,J,K,L) = -G*WSGNSS(L)*( WMXVSS(L,1)*QMIXSS(J,1,K)
     &                           +MCHAR(1)*RMASS(J)*QMIXSS(J,2,K))
 6    AFC(2,J,K,L) = -G*MCHAR(2)*RMASS(J-1)*QMIXSS(J,1,K)
C--couplings of the charginos to the sleptons
      DO 8 L=1,2
      MCHAR(1) = -WMXUSS(L,2)*ORT/MW/COSB
      DO 8 I=1,3
      J = 2*I-1
      IL = J+6
      DO 9 K=1,2
      AFC(1,IL,K,L) = -G*(WMXUSS(L,1)*LMIXSS(J,1,K)
     &                +RMASS(120+J)*MCHAR(1)*LMIXSS(J,2,K))
 9    AFC(2,IL,K,L) = ZERO
      J = J+1
      IL = IL+1
      DO 8 K=1,2
      AFC(1,IL,K,L) =-WSGNSS(L)*G*WMXVSS(L,1)
 8    AFC(2,IL,K,L) =-MCHAR(1)*G*RMASS(119+J)
C--couplings of chargino-neutralino to the W
      DO 10 I=1,4
      DO 10 J=1,2
      OIJ(1,I,J) = G*( ORT*ZMXNSS(I,3)*WMXUSS(J,2)
     &                    +ZMXNSS(I,2)*WMXUSS(J,1))
 10   OIJ(2,I,J) = ZSGNSS(I)*WSGNSS(J)*G*(-ORT*ZMXNSS(I,4)*WMXVSS(J,2)
     &                                        +ZMXNSS(I,2)*WMXVSS(J,1))
C--couplings of chargino-chargino to the Z
      PRE = G/CW
      DO 11 I=1,2
      DO 11 J=1,2
      OIJP(1,I,J) = PRE*(-WMXUSS(I,1)*WMXUSS(J,1)
     &             -HALF*WMXUSS(I,2)*WMXUSS(J,2)+DIJ(I,J)*SWEIN)
 11   OIJP(2,I,J) = WSGNSS(I)*WSGNSS(J)*PRE*(-WMXVSS(I,1)*WMXVSS(J,1)
     &             -HALF*WMXVSS(I,2)*WMXVSS(J,2)+DIJ(I,J)*SWEIN)
C--couplings of neutralino-neutralino to the Z
      PRE = HALF*G/CW
      DO 12 I=1,4
      DO 12 J=1,4
      OIJPP(1,I,J) = PRE*(ZMIXSS(I,3)*ZMIXSS(J,3)
     &                           -ZMIXSS(I,4)*ZMIXSS(J,4))
 12   OIJPP(2,I,J) = -ZSGNSS(I)*ZSGNSS(J)*OIJPP(1,I,J)
C--couplings of the neutralino-neutralino to the Higgs
      DO 13 I=1,4
      DO 13 J=1,4
      QIJPP(I,J) = HALF*ZSGNSS(I)*
     &                      (ZMXNSS(I,3)*(ZMXNSS(J,2)-ZMXNSS(J,1)*TW)
     &                      +ZMXNSS(J,3)*(ZMXNSS(I,2)-ZMXNSS(I,1)*TW))
 13   SIJPP(I,J) = HALF*ZSGNSS(I)*
     &                      (ZMXNSS(I,4)*(ZMXNSS(J,2)-ZMXNSS(J,1)*TW)
     &                      +ZMXNSS(J,4)*(ZMXNSS(I,2)-ZMXNSS(I,1)*TW))
      DO 14 I=1,4
      DO 14 J=1,4
      HNN(1,1,I,J) = G*(QIJPP(I,J)*SINA+SIJPP(I,J)*COSA)
      HNN(2,1,I,J) = G*(QIJPP(J,I)*SINA+SIJPP(J,I)*COSA)
      HNN(1,2,I,J) = G*(SIJPP(I,J)*SINA-QIJPP(I,J)*COSA)
      HNN(2,2,I,J) = G*(SIJPP(J,I)*SINA-QIJPP(J,I)*COSA)
      HNN(1,3,I,J) = G*(QIJPP(I,J)*SINB-SIJPP(I,J)*COSB)
 14   HNN(2,3,I,J) =-G*(QIJPP(J,I)*SINB-SIJPP(J,I)*COSB)
C--couplings of chargino-chargino to the Higgs
      DO 15 I=1,2
      DO 15 J=1,2
      QIJ(I,J) = ORT*WSGNSS(I)*WMXVSS(I,1)*WMXUSS(J,2)
 15   SIJ(I,J) = ORT*WSGNSS(I)*WMXVSS(I,2)*WMXUSS(J,1)
      DO 16 I=1,2
      DO 16 J=1,2
      HCC(1,1,I,J) = G*(QIJ(I,J)*SINA-SIJ(I,J)*COSA)
      HCC(2,1,I,J) = G*(QIJ(J,I)*SINA-SIJ(J,I)*COSA)
      HCC(1,2,I,J) =-G*(QIJ(I,J)*COSA+SIJ(I,J)*SINA)
      HCC(2,2,I,J) =-G*(QIJ(J,I)*COSA+SIJ(J,I)*SINA)
      HCC(1,3,I,J) = G*(QIJ(I,J)*SINB+SIJ(I,J)*COSB)
 16   HCC(2,3,I,J) =-G*(QIJ(J,I)*SINB+SIJ(J,I)*COSB)
C--couplings of chargino-neutralino to the Higgs
      DO 17 I=1,4
      DO 17 J=1,2
      HNC(1,I,J) =-G*ZSGNSS(I)*SINB*(ZMXNSS(I,3)*WMXUSS(J,1)
     &            -ORT*(ZMXNSS(I,2)+ZMXNSS(I,1)*TW)*WMXUSS(J,2))
 17   HNC(2,I,J) =-G*WSGNSS(J)*COSB*(ZMXNSS(I,4)*WMXVSS(J,1)
     &            +ORT*(ZMXNSS(I,2)+ZMXNSS(I,1)*TW)*WMXVSS(J,2))
C--fermion couplings to the Higgs
      R(1,1) = HALF*G*SINA/MW/COSB
      R(1,2) =-HALF*G*COSA/MW/SINB
      R(2,1) =-HALF*G*COSA/MW/COSB
      R(2,2) =-HALF*G*SINA/MW/SINB
      R(3,1) = HALF*G*TANB/MW
      R(3,2) = HALF*G*COTB/MW
      R(4,1) = G*ORT*TANB/MW
      R(4,2) = G*ORT*COTB/MW
      DO 18 I=1,3
      J = 2*I-1
      K = 2*I
      IL = J+6
      IQ = K+6
      DO 19 IK=1,3
      DO 19 L=1,2
      HFF(L,IK,J ) = R(IK,1)*RMASS(J)
      HFF(L,IK,K ) = R(IK,2)*RMASS(K)
      HFF(L,IK,IL) = R(IK,1)*RMASS(114+IL)
 19   HFF(L,IK,IQ) = ZERO
      HFF(2,3,J )  = -HFF(2,3, J)
      HFF(2,3,K )  = -HFF(2,3, K)
      HFF(2,3,IL)  = -HFF(2,3,IL)
      HFF(1,4,I)   = RMASS(J)*R(4,1)
      HFF(2,4,I)   = RMASS(K)*R(4,2)
      HFF(1,4,I+3) = RMASS(114+IL)*R(4,1)
 18   HFF(2,4,I+3) = ZERO
C--couplings of the Higgs to gauge boson pairs
      HWW(1) = G*MW*SINBMA
      HWW(2) = G*MW*COSBMA
      HZZ(1) = G*MZ*SINBMA/CW
      HZZ(2) = G*MZ*COSBMA/CW
C--couplings of the Z to the sfermions
      DO 20 I=1,3
      IQ = 2*I-1
      IL = 2*I
      IK = 2*I+5
      IH = 2*I+6
      DO 20 J=1,2
      DO 20 K=1,2
      ZAB(IQ,J,K) = G/CW*HALF*( QMIXSS(IQ,1,J)*QMIXSS(IQ,1,K)
     &                         -TWO*DIJ(J,K) *SWEIN/THREE)
      ZAB(IL,J,K) = G/CW*HALF*(-QMIXSS(IL,1,J)*QMIXSS(IL,1,K)
     &                         -FOUR*DIJ(J,K)*SWEIN/THREE)
      ZAB(IK,J,K) = G/CW*HALF*( LMIXSS(IQ,1,J)*LMIXSS(IQ,1,K)
     &                         -TWO*DIJ(J,K)*SWEIN)
 20   ZAB(IH,J,K) =-G/CW*HALF*DIJ(J,1)*DIJ(K,1)
C--couplings of the Higgs Higgs to the gauge bosons
      HHB(1,1) = HALF*G*COSBMA
      HHB(1,2) = HALF*G*SINBMA
      HHB(1,3) = HALF*G
      HHB(2,1) =-HALF*G*COSBMA/CW
      HHB(2,2) = HALF*G*SINBMA/CW
      HHB(2,3) = ZERO
      END
CDECK  ID>, HWISPN.
*CMZ :-        -12/10/01  17.22.48  by  Peter Richardson
*-- Author :    Peter Richardson
C-----------------------------------------------------------------------
      SUBROUTINE HWISPN
C-----------------------------------------------------------------------
C     Initialise all the decay modes for three/four body MEs and spin
C     correlations
C-----------------------------------------------------------------------
      INCLUDE 'HERWIG65.INC'
      INTEGER I,J,K,NDKYST
C--set the number of two and three body modes to zero
      N2MODE = 0
      N3MODE = 0
      NBMODE = 0
      N4MODE = 0
C--if not reading in decay info calculate it
      IF(LRDEC.EQ.0) THEN
C--initialise the couplings for the various decay modes
        CALL HWISPC
C--Top decays and SUSY three body decays (including SUSY gauge
C--boson 2 body modes which are treated as three body)
        IF(THREEB) CALL HWISP3
        IF(IERROR.NE.0) RETURN
C--then four body modes if needed
        IF(FOURB)  CALL HWISP4
        IF(IERROR.NE.0) RETURN
C--Two body modes if needed for spin correlations
        IF(SYSPIN) CALL HWISP2
        IF(IERROR.NE.0) RETURN
C--otherwise read it in
      ELSEIF(LRDEC.GT.0) THEN
C--open the unit
        IF (IPRINT.NE.0) WRITE (6,1) LRDEC
   1    FORMAT(/10X,'READING MATRIX ELEMENT TABLE ON UNIT',I4)
        OPEN(UNIT=LRDEC,FORM='UNFORMATTED',STATUS='UNKNOWN')
C--read  options
        READ(UNIT=LRDEC) NDKYST
        IF(NDKYS.NE.NDKYST) CALL HWWARN('HWISPN',501)
        READ(UNIT=LRDEC) SYSPIN,THREEB,FOURB
C--read two body decays
        IF(SYSPIN) THEN
          READ(UNIT=LRDEC) N2MODE
          DO 2 I=1,N2MODE
 2        READ(UNIT=LRDEC) (A2MODE(J,I),J=1,2),P2MODE(I),WT2MAX(I),
     &                     ID2PRT(I),I2DRTP(I)
        ENDIF
C--read three body decays
        IF(SYSPIN.OR.THREEB) THEN
          READ(UNIT=LRDEC) N3MODE
          DO 3 I=1,N3MODE
          READ(UNIT=LRDEC) P3MODE(I),WT3MAX(I),ID3PRT(I),NDI3BY(I),
     &            ((SPN3CF(J,K,I),J=1,NCFMAX),K=1,NCFMAX),N3NCFL(I)
          DO 3 J=1,NDI3BY(I)
 3        READ(UNIT=LRDEC) (A3MODE(K,J,I),K=1,2),(B3MODE(K,J,I),K=1,2),
     &                      I3DRTP(J,I),I3MODE(J,I),I3DRCF(J,I)
C--read two body gauge boson modes
          READ(UNIT=LRDEC) NBMODE
          DO 4 I=1,NBMODE
 4        READ(UNIT=LRDEC) (ABMODE(J,I),J=1,2),
     &            ((BBMODE(J,K,I),J=1,2),K=1,12),(PBMODE(K,I),K=1,12),
     &            (WTBMAX(K,I),K=1,12),IDBPRT(I),IBMODE(I),IBDRTP(I)
        ENDIF
C--read four body decays
        IF(FOURB) THEN
          READ(UNIT=LRDEC) N4MODE
          DO 5 I=1,N4MODE
 5        READ(UNIT=LRDEC) ((A4MODE(J,K,I),J=1,2),K=1,12),
     &            ((B4MODE(J,K,I),J=1,2),K=1,12),
     &            ((P4MODE(J,K,I),J=1,12),K=1,12),
     &            ((WT4MAX(J,K,I),J=1,12),K=1,12),ID4PRT(I),
     &            (I4MODE(J,I),J=1,2)
        ENDIF
C--finally read in the matrix element codes
        READ(UNIT=LRDEC) NME
      ELSE
        CALL HWWARN('HWISPN',500)
      ENDIF
C--write the decay information if needed
      IF(LWDEC.GT.0) THEN
C--open the file
        IF (IPRINT.NE.0) WRITE (6,6) LWDEC
 6      FORMAT(/10X,'WRITING MATRIX ELEMENT TABLE ON UNIT',I4)
        OPEN(UNIT=LWDEC,FORM='UNFORMATTED',STATUS='UNKNOWN')
C--write  options
        WRITE(UNIT=LWDEC) NDKYS
        WRITE(UNIT=LWDEC) SYSPIN,THREEB,FOURB
C--write two body decays
        IF(SYSPIN) THEN
          WRITE(UNIT=LWDEC) N2MODE
          DO 7 I=1,N2MODE
 7        WRITE(UNIT=LWDEC) (A2MODE(J,I),J=1,2),P2MODE(I),WT2MAX(I),
     &                     ID2PRT(I),I2DRTP(I)
        ENDIF
C--write three body decays
        IF(SYSPIN.OR.THREEB) THEN
          WRITE(UNIT=LWDEC) N3MODE
          DO 8 I=1,N3MODE
          WRITE(UNIT=LWDEC) P3MODE(I),WT3MAX(I),ID3PRT(I),NDI3BY(I),
     &            ((SPN3CF(J,K,I),J=1,NCFMAX),K=1,NCFMAX),N3NCFL(I)
          DO 8 J=1,NDI3BY(I)
 8        WRITE(UNIT=LWDEC) (A3MODE(K,J,I),K=1,2),(B3MODE(K,J,I),K=1,2),
     &                      I3DRTP(J,I),I3MODE(J,I),I3DRCF(J,I)
C--write two body gauge boson modes
          WRITE(UNIT=LWDEC) NBMODE
          DO 9 I=1,NBMODE
 9        WRITE(UNIT=LWDEC) (ABMODE(J,I),J=1,2),
     &            ((BBMODE(J,K,I),J=1,2),K=1,12),(PBMODE(K,I),K=1,12),
     &            (WTBMAX(K,I),K=1,12),IDBPRT(I),IBMODE(I),IBDRTP(I)
        ENDIF
C--write four body decays
        IF(FOURB) THEN
          WRITE(UNIT=LWDEC) N4MODE
          DO 10 I=1,N4MODE
 10       WRITE(UNIT=LWDEC) ((A4MODE(J,K,I),J=1,2),K=1,12),
     &            ((B4MODE(J,K,I),J=1,2),K=1,12),
     &            ((P4MODE(J,K,I),J=1,12),K=1,12),
     &            ((WT4MAX(J,K,I),J=1,12),K=1,12),ID4PRT(I),
     &            (I4MODE(J,I),J=1,2)
        ENDIF
C--finally write the matrix element codes
        WRITE(UNIT=LWDEC) NME
      ENDIF
      END
CDECK  ID>, HWISP2.
*CMZ :-        -30/09/02  14:05:28  by  Peter Richardson
*-- Author :    Peter Richardson
C-----------------------------------------------------------------------
      SUBROUTINE HWISP2
C-----------------------------------------------------------------------
C     Initialise the SUSY two body modes for spin correlations
C-----------------------------------------------------------------------
      INCLUDE 'HERWIG65.INC'
      INTEGER I,J,IL,IH,L,L1,IM,O(2),II,JJ,III,JJJ,KKK
      COMMON /HWSPNC/ SW,CW,TW,E,G,RT,ORT,MW,MZ,GS,AFN,AFG,AFC,OIJ,OIJP,
     &               OIJPP,HNN,HCC,HNC,HFF,HWW,HZZ,ZAB,HHB
      DOUBLE PRECISION SW,CW,TW,E,G,RT,ORT,MW,MZ,GS,AFN(2,12,2,4),
     &     AFG(2,6,2),AFC(2,12,2,2),OIJ(2,4,2),OIJP(2,2,2),OIJPP(2,4,4),
     &     HNN(2,3,4,4),HCC(2,3,2,2),HNC(2,4,2),HFF(2,4,12),HWW(2),
     &     HZZ(2),ZAB(12,2,2),HHB(2,3),FPI
      SAVE O,FPI
      DATA O/2,1/
      DATA FPI/0.09298D0/
      IF(IERROR.NE.0.OR..NOT.SUSYIN) RETURN
C--now the two body modes for spin corrections
      DO 1000 JJ=1,NRES
      DO 1000 II=1,NMODES(JJ)
        IF(II.EQ.1) THEN
          I = LSTRT(JJ)
        ELSE
          I = LNEXT(I)
        ENDIF
        IF(IDKPRD(2,I).EQ.0.OR.IDKPRD(3,I).NE.0.OR.
     &        (NME(I).GT.10000.AND.NME(I).LT.50000)) GOTO 1000
        L1 = IDK(I)-449
C--two body top to charged higgs decay
        IF(IDK(I).EQ.6.AND.IDKPRD(1,I).EQ.206.AND.
     &                     IDKPRD(2,I).EQ.5) THEN
            N2MODE = N2MODE+1
            IF(N2MODE.GT.NMODE2) THEN
              CALL HWWARN('HWISP2',100)
              GOTO 999
            ENDIF
            NME(I) = 30000+N2MODE
            ID2PRT(N2MODE) = I
            I2DRTP(N2MODE) = 2
            P2MODE(N2MODE) = ONE
            DO 201 J=1,2
 201        A2MODE(J,N2MODE) = HFF(O(J),4,3)
C--two body antitop to charged higgs
        ELSEIF(IDK(I).EQ.12.AND.IDKPRD(1,I).EQ.207.AND.
     &                          IDKPRD(2,I).EQ.11) THEN
            N2MODE = N2MODE+1
            IF(N2MODE.GT.NMODE2) THEN
              CALL HWWARN('HWISP2',101)
              GOTO 999
            ENDIF
            NME(I) = 30000+N2MODE
            ID2PRT(N2MODE) = I
            I2DRTP(N2MODE) = 14
            P2MODE(N2MODE) = ONE
            DO 202 J=1,2
 202        A2MODE(J,N2MODE) = HFF(  J ,4,3)
C--two body modes of the gluino
        ELSEIF(L1.EQ.0) THEN
          L = IDKPRD(1,I)-449
C--gluino to antisfermion fermion
          IF(IDPDG(IDKPRD(2,I)).GT.0.AND.L.GE.-48.AND.L.LE.-1) THEN
            N2MODE = N2MODE+1
            IF(N2MODE.GT.NMODE2) THEN
              CALL HWWARN('HWISP2',102)
              GOTO 999
            ENDIF
            NME(I) = 30000+N2MODE
            ID2PRT(N2MODE) = I
            I2DRTP(N2MODE) = 2
            P2MODE(N2MODE) = HALF
            IM = MOD(INT((IDKPRD(1,I)-389)/12)+1,2)+1
            IL = 6*INT((IDKPRD(1,I)-401)/24)+MOD(IDKPRD(1,I)-401,6)+1
            DO 1 J=1,2
 1          A2MODE(J,N2MODE) = AFG(J,IL,IM)
C--gluino to sfermion antifermion
          ELSEIF(IDPDG(IDKPRD(2,I)).LT.0.AND.L.GE.-48.AND.L.LE.-1) THEN
            N2MODE = N2MODE+1
            IF(N2MODE.GT.NMODE2) THEN
              CALL HWWARN('HWISP2',103)
              GOTO 999
            ENDIF
            NME(I) = 30000+N2MODE
            ID2PRT(N2MODE) = I
            I2DRTP(N2MODE) = 3
            P2MODE(N2MODE) = HALF
            IM = MOD(INT((IDKPRD(1,I)-389)/12)+1,2)+1
            IL = 6*INT((IDKPRD(1,I)-401)/24)+MOD(IDKPRD(1,I)-401,6)+1
            DO 2 J=1,2
 2          A2MODE(J,N2MODE) = AFG(O(J),IL,IM)
C--gluino to neutralino gluon
          ELSEIF(L.GE.1.AND.L.LE.4.AND.IDKPRD(2,I).EQ.13) THEN
            N2MODE = N2MODE+1
            IF(N2MODE.GT.NMODE2) THEN
              CALL HWWARN('HWISP2',104)
              GOTO 999
            ENDIF
            NME(I) = 30000+N2MODE
            ID2PRT(N2MODE) = I
            I2DRTP(N2MODE) = 4
            P2MODE(N2MODE) = 8.0D0*PIFAC*RMASS(IDK(I))**3/
     &           (RMASS(IDK(I))**2-RMASS(IDKPRD(1,I))**2)**3*
     &           HBAR/RLTIM(IDK(I))*BRFRAC(I)
            A2MODE(1,N2MODE) = ZSGNSS(L)
C--gluino to gravitino gluon
          ELSEIF(IDKPRD(1,I).EQ.458.AND.IDKPRD(2,I).EQ.13) THEN
            N2MODE = N2MODE+1
            IF(N2MODE.GT.NMODE2) THEN
              CALL HWWARN('HWISP2',105)
              GOTO 999
            ENDIF
            NME(I) = 30000+N2MODE
            ID2PRT(N2MODE) = I
            I2DRTP(N2MODE) = 9
            P2MODE(N2MODE) = ONE/24.0D0
          ENDIF
C--two body modes of the neutralinos
        ELSEIF(L1.GE.1.AND.L1.LE.4) THEN
          L  = IDKPRD(1,I)-449
          IH = IDKPRD(2,I)-202
C--first the neutralino modes to neutralino Higgs
          IF(L.GE.1.AND.L.LE.4.AND.IH.GE.1.AND.IH.LE.3) THEN
            N2MODE = N2MODE+1
            IF(N2MODE.GE.NMODE2) THEN
              CALL HWWARN('HWISP2',106)
              GOTO 999
            ENDIF
            NME(I) = 30000+N2MODE
            ID2PRT(N2MODE) = I
            I2DRTP(N2MODE) = 1
            P2MODE(N2MODE) = ONE
            DO 3 J=1,2
 3          A2MODE(J,N2MODE) = HNN(J,IH,L,L1)
C--neutralino to positive chargino negative Higgs
          ELSEIF((L.EQ.5.OR.L.EQ.6).AND.IH.EQ.5) THEN
            L = L-4
            N2MODE = N2MODE+1
            IF(N2MODE.GE.NMODE2) THEN
              CALL HWWARN('HWISP2',107)
              GOTO 999
            ENDIF
            NME(I) = 30000+N2MODE
            ID2PRT(N2MODE) = I
            I2DRTP(N2MODE) = 1
            P2MODE(N2MODE) = ONE
            DO 4 J=1,2
 4          A2MODE(J,N2MODE) = HNC(O(J),L1,L)
C--neutralino to negative chargino positive Higgs
          ELSEIF((L.EQ.7.OR.L.EQ.8).AND.IH.EQ.6) THEN
            L = L-6
            N2MODE = N2MODE+1
            IF(N2MODE.GE.NMODE2) THEN
              CALL HWWARN('HWISP2',108)
              GOTO 999
            ENDIF
            NME(I) = 30000+N2MODE
            ID2PRT(N2MODE) = I
            I2DRTP(N2MODE) = 1
            P2MODE(N2MODE) = ONE
            DO 5 J=1,2
 5          A2MODE(J,N2MODE) = HNC(J,L1,L)
C--neutralino to antisfermion sfermion
          ELSEIF(IDPDG(IDKPRD(2,I)).GT.0.AND.L.GE.-48.AND.L.LE.-1) THEN
            N2MODE = N2MODE+1
            IF(N2MODE.GT.NMODE2) THEN
              CALL HWWARN('HWISP2',109)
              GOTO 999
            ENDIF
            NME(I) = 30000+N2MODE
            ID2PRT(N2MODE) = I
            I2DRTP(N2MODE) = 2
            P2MODE(N2MODE) = ONE
            IM = MOD(INT((IDKPRD(1,I)-389)/12)+1,2)+1
            IL = 6*INT((IDKPRD(1,I)-401)/24)+MOD(IDKPRD(1,I)-401,6)+1
            IF(IL.LE.6) P2MODE(N2MODE) = THREE
            DO 6 J=1,2
 6          A2MODE(J,N2MODE) = AFN(J,IL,IM,L1)
C--neutralino to sfermion antifermion
          ELSEIF(IDPDG(IDKPRD(2,I)).LT.0.AND.L.GE.-48.AND.L.LE.-1) THEN
            N2MODE = N2MODE+1
            IF(N2MODE.GT.NMODE2) THEN
              CALL HWWARN('HWISP2',110)
              GOTO 999
            ENDIF
            NME(I) = 30000+N2MODE
            ID2PRT(N2MODE) = I
            I2DRTP(N2MODE) = 3
            P2MODE(N2MODE) = ONE
            IM = MOD(INT((IDKPRD(1,I)-389)/12)+1,2)+1
            IL = 6*INT((IDKPRD(1,I)-401)/24)+MOD(IDKPRD(1,I)-401,6)+1
            IF(IL.LE.6) P2MODE(N2MODE) = THREE
            DO 7 J=1,2
 7          A2MODE(J,N2MODE) = AFN(O(J),IL,IM,L1)
C--neutralino to neutralino photon
          ELSEIF(L.GE.1.AND.L.LE.4.AND.IDKPRD(2,I).EQ.59) THEN
            N2MODE = N2MODE+1
            IF(N2MODE.GT.NMODE2) THEN
              CALL HWWARN('HWISP2',111)
              GOTO 999
            ENDIF
            NME(I) = 30000+N2MODE
            ID2PRT(N2MODE) = I
            I2DRTP(N2MODE) = 4
            P2MODE(N2MODE) = 8.0D0*PIFAC*RMASS(IDK(I))**3/
     &           (RMASS(IDK(I))**2-RMASS(IDKPRD(1,I))**2)**3*
     &           HBAR/RLTIM(IDK(I))*BRFRAC(I)
            A2MODE(1,N2MODE) = ZSGNSS(L)*ZSGNSS(L1)
C--neutralino to gravitino photon for GMSB
          ELSEIF(IDKPRD(1,I).EQ.458.AND.IDKPRD(2,I).EQ.59) THEN
            N2MODE = N2MODE+1
            IF(N2MODE.GT.NMODE2) THEN
              CALL HWWARN('HWISP2',112)
              GOTO 999
            ENDIF
            NME(I) = 30000+N2MODE
            ID2PRT(N2MODE) = I
            I2DRTP(N2MODE) = 9
            P2MODE(N2MODE) = ZMIXSS(L1,1)**2/24.0D0
C--neutralino to gravitino Higgs for GMSB
          ELSEIF(IDKPRD(1,I).EQ.458.AND.IH.GE.1.AND.IH.LE.3) THEN
            N2MODE = N2MODE+1
            IF(N2MODE.GT.NMODE2) THEN
              CALL HWWARN('HWISP2',113)
              GOTO 999
            ENDIF
            NME(I) = 30000+N2MODE
            ID2PRT(N2MODE) = I
            I2DRTP(N2MODE) = 10
            IF(IH.EQ.1) THEN
              P2MODE(N2MODE) = ZMIXSS(L1,3)*SINA-ZMIXSS(L1,4)*COSA
            ELSEIF(IH.EQ.2) THEN
              P2MODE(N2MODE) = ZMIXSS(L1,3)*COSA+ZMIXSS(L1,4)*SINA
            ELSE
              P2MODE(N2MODE) = ZMIXSS(L1,3)*SINB+ZMIXSS(L1,4)*COSB
            ENDIF
            P2MODE(N2MODE) = P2MODE(N2MODE)**2/3.0D0
          ELSE
            CALL HWWARN('HWISP2',1)
          ENDIF
C--two body modes of the positive charginos
        ELSEIF(L1.EQ.5.OR.L1.EQ.6) THEN
          L1 = L1-4
          L  = IDKPRD(1,I)-449
          IH = IDKPRD(2,I)-202
C--first the chargino modes to chargino Higgs
          IF((L.EQ.5.OR.L.EQ.6).AND.IH.GE.1.AND.IH.LE.3) THEN
            L = L-4
            N2MODE = N2MODE+1
            IF(N2MODE.GT.NMODE2) THEN
              CALL HWWARN('HWISP2',114)
              GOTO 999
            ENDIF
            NME(I) = 30000+N2MODE
            ID2PRT(N2MODE) = I
            I2DRTP(N2MODE) = 1
            P2MODE(N2MODE) = ONE
            DO 8 J=1,2
 8          A2MODE(J,N2MODE) = HCC(J,IH,L,L1)
C--then the chargino modes to neutralino Higgs
          ELSEIF(L.GE.1.AND.L.LE.4.AND.IH.EQ.4) THEN
            N2MODE = N2MODE+1
            IF(N2MODE.GT.NMODE2) THEN
              CALL HWWARN('HWISP2',115)
              GOTO 999
            ENDIF
            NME(I) = 30000+N2MODE
            ID2PRT(N2MODE) = I
            I2DRTP(N2MODE) = 1
            P2MODE(N2MODE) = ONE
            DO 9 J=1,2
 9          A2MODE(J,N2MODE) = HNC(J,L,L1)
C--chargino modes to antisfermion fermion
          ELSEIF(IDPDG(IDKPRD(2,I)).GT.0.AND.L.GE.-48.AND.L.LE.-1) THEN
            N2MODE = N2MODE+1
            IF(N2MODE.GT.NMODE2) THEN
              CALL HWWARN('HWISP2',116)
              GOTO 999
            ENDIF
            NME(I) = 30000+N2MODE
            ID2PRT(N2MODE) = I
            I2DRTP(N2MODE) = 2
            P2MODE(N2MODE) = ONE
            IM = MOD(INT((IDKPRD(1,I)-389)/12)+1,2)+1
            IL = 6*INT((IDKPRD(1,I)-401)/24)+MOD(IDKPRD(1,I)-401,6)+1
            IF(IL.LE.6) P2MODE(N2MODE) = THREE
            DO 10 J=1,2
 10         A2MODE(J,N2MODE) = AFC(J,IL,IM,L1)
C--chargino modes to sfermion antifermion
          ELSEIF(IDPDG(IDKPRD(2,I)).LT.0.AND.L.GE.-48.AND.L.LE.-1) THEN
            N2MODE = N2MODE+1
            IF(N2MODE.GT.NMODE2) THEN
              CALL HWWARN('HWISP2',117)
              GOTO 999
            ENDIF
            NME(I) = 30000+N2MODE
            ID2PRT(N2MODE) = I
            I2DRTP(N2MODE) = 3
            P2MODE(N2MODE) = ONE
            IM = MOD(INT((IDKPRD(1,I)-389)/12)+1,2)+1
            IL = 6*INT((IDKPRD(1,I)-401)/24)+MOD(IDKPRD(1,I)-401,6)+1
            IF(IL.LE.6) P2MODE(N2MODE) = THREE
            DO 11 J=1,2
 11         A2MODE(J,N2MODE) = AFC(O(J),IL,IM,L1)
C--chargino --> neutralino pi+
          ELSEIF(L.GE.1.AND.L.LE.4.AND.IDKPRD(2,I).EQ.38) THEN
            N2MODE = N2MODE+1
            IF(N2MODE.GT.NMODE2) THEN
              CALL HWWARN('HWISP2',118)
              GOTO 999
            ENDIF
            NME(I) = 30000+N2MODE
            ID2PRT(N2MODE) = I
            I2DRTP(N2MODE) = 7
            P2MODE(N2MODE) = FPI**2*G**2
            DO 12 J=1,2
 12         A2MODE(J,N2MODE) = OIJ(J,L,L1)
          ENDIF
C--two body modes of the negative charginos
        ELSEIF(L1.EQ.7.OR.L1.EQ.8) THEN
          L1 = L1-6
          L  = IDKPRD(1,I)-449
          IH = IDKPRD(2,I)-202
C--first the chargino modes to chargino Higgs
          IF((L.EQ.7.OR.L.EQ.8).AND.IH.GE.1.AND.IH.LE.3) THEN
            L = L-6
            N2MODE = N2MODE+1
            IF(N2MODE.GT.NMODE2) THEN
              CALL HWWARN('HWISP2',119)
              GOTO 999
            ENDIF
            NME(I) = 30000+N2MODE
            ID2PRT(N2MODE) = I
            I2DRTP(N2MODE) = 1
            P2MODE(N2MODE) = ONE
            DO 13 J=1,2
 13         A2MODE(J,N2MODE) = HCC(O(J),IH,L,L1)
C--then the chargino modes to neutralino Higgs
          ELSEIF(L.GE.1.AND.L.LE.4.AND.IH.EQ.5) THEN
            N2MODE = N2MODE+1
            IF(N2MODE.GT.NMODE2) THEN
              CALL HWWARN('HWISP2',120)
              GOTO 999
            ENDIF
            NME(I) = 30000+N2MODE
            ID2PRT(N2MODE) = I
            I2DRTP(N2MODE) = 1
            P2MODE(N2MODE) = ONE
            DO 14 J=1,2
 14         A2MODE(J,N2MODE) = HNC(O(J),L,L1)
C--chargino to antisfermion fermion
          ELSEIF(IDPDG(IDKPRD(2,I)).GT.0.AND.L.GE.-48.AND.L.LE.-1) THEN
            N2MODE = N2MODE+1
            IF(N2MODE.GT.NMODE2) THEN
              CALL HWWARN('HWISP2',121)
              GOTO 999
            ENDIF
            NME(I) = 30000+N2MODE
            ID2PRT(N2MODE) = I
            I2DRTP(N2MODE) = 2
            P2MODE(N2MODE) = ONE
            IM = MOD(INT((IDKPRD(1,I)-389)/12)+1,2)+1
            IL = 6*INT((IDKPRD(1,I)-401)/24)+MOD(IDKPRD(1,I)-401,6)+1
            IF(IL.LE.6) P2MODE(N2MODE) = THREE
            DO 15 J=1,2
 15         A2MODE(J,N2MODE) = AFC(J,IL,IM,L1)
C--chargino to sfermion antifermion
          ELSEIF(IDPDG(IDKPRD(2,I)).LT.0.AND.L.GE.-48.AND.L.LE.-1) THEN
            N2MODE = N2MODE+1
            IF(N2MODE.GT.NMODE2) THEN
              CALL HWWARN('HWISP2',122)
              GOTO 999
            ENDIF
            NME(I) = 30000+N2MODE
            ID2PRT(N2MODE) = I
            I2DRTP(N2MODE) = 3
            P2MODE(N2MODE) = ONE
            IM = MOD(INT((IDKPRD(1,I)-389)/12)+1,2)+1
            IL = 6*INT((IDKPRD(1,I)-401)/24)+MOD(IDKPRD(1,I)-401,6)+1
            IF(IL.LE.6) P2MODE(N2MODE) = THREE
            DO 16 J=1,2
 16         A2MODE(J,N2MODE) = AFC(O(J),IL,IM,L1)
C--chargino --> neutralino pi-
          ELSEIF(L.GE.1.AND.L.LE.4.AND.IDKPRD(2,I).EQ.30) THEN
            N2MODE = N2MODE+1
            IF(N2MODE.GT.NMODE2) THEN
              CALL HWWARN('HWISP2',123)
              GOTO 999
            ENDIF
            NME(I) = 30000+N2MODE
            ID2PRT(N2MODE) = I
            I2DRTP(N2MODE) = 7
            P2MODE(N2MODE) = FPI**2*G**2
            DO 17 J=1,2
 17         A2MODE(J,N2MODE) =-OIJ(O(J),L,L1)
          ENDIF
        ELSEIF(L1.GE.-48.AND.L1.LT.0) THEN
C--sfermion decay modes
          L = IDKPRD(1,I)-449
C--first sfermion modes to gluinos
          IF(L.EQ.0) THEN
C--first sfermion --> fermion gluino
            IF(IDPDG(IDKPRD(2,I)).GT.0) THEN
              N2MODE = N2MODE+1
              IF(N2MODE.GT.NMODE2) THEN
                CALL HWWARN('HWISP2',124)
                GOTO 999
              ENDIF
              NME(I) = 30000+N2MODE
              ID2PRT(N2MODE) = I
              I2DRTP(N2MODE) = 6
              P2MODE(N2MODE) = FOUR/THREE
              IM = MOD(INT((IDK(I)-389)/12)+1,2)+1
              IL = 6*INT((IDK(I)-401)/24)+MOD(IDK(I)-401,6)+1
              DO 18 J=1,2
 18           A2MODE(J,N2MODE) = AFG(J,IL,IM)
C--then antisfermion --> antifermion gluino
            ELSE
              N2MODE = N2MODE+1
              IF(N2MODE.GT.NMODE2) THEN
                CALL HWWARN('HWISP2',125)
                GOTO 999
              ENDIF
              NME(I) = 30000+N2MODE
              ID2PRT(N2MODE) = I
              I2DRTP(N2MODE) = 5
              P2MODE(N2MODE) = FOUR/THREE
              IM = MOD(INT((IDK(I)-389)/12)+1,2)+1
              IL = 6*INT((IDK(I)-401)/24)+MOD(IDK(I)-401,6)+1
              DO 19 J=1,2
 19           A2MODE(J,N2MODE) = AFG(O(J),IL,IM)
            ENDIF
C--then sfermion modes to neutralinos
          ELSEIF(L.GE.1.AND.L.LE.4) THEN
C--first sfermion --> fermion neutralino
            IF(IDPDG(IDKPRD(2,I)).GT.0) THEN
              N2MODE = N2MODE+1
              IF(N2MODE.GT.NMODE2) THEN
                CALL HWWARN('HWISP2',126)
                GOTO 999
              ENDIF
              NME(I) = 30000+N2MODE
              ID2PRT(N2MODE) = I
              I2DRTP(N2MODE) = 6
              P2MODE(N2MODE) = ONE
              IM = MOD(INT((IDK(I)-389)/12)+1,2)+1
              IL = 6*INT((IDK(I)-401)/24)+MOD(IDK(I)-401,6)+1
              DO 20 J=1,2
 20           A2MODE(J,N2MODE) = AFN(J,IL,IM,L)
C--then antisfermion --> fermion neutralino
            ELSE
              N2MODE = N2MODE+1
              IF(N2MODE.GT.NMODE2) THEN
                CALL HWWARN('HWISP2',127)
                GOTO 999
              ENDIF
              NME(I) = 30000+N2MODE
              ID2PRT(N2MODE) = I
              I2DRTP(N2MODE) = 5
              P2MODE(N2MODE) = ONE
              IM = MOD(INT((IDK(I)-389)/12)+1,2)+1
              IL = 6*INT((IDK(I)-401)/24)+MOD(IDK(I)-401,6)+1
              DO 21 J=1,2
 21           A2MODE(J,N2MODE) = AFN(O(J),IL,IM,L)
            ENDIF
C--sfermion modes to charginos
          ELSEIF(L.GE.5.AND.L.LE.8) THEN
            L = MOD(L-5,2)+1
C--first sfermion --> fermion chargino
            IF(IDPDG(IDKPRD(2,I)).GT.0) THEN
              N2MODE = N2MODE+1
              IF(N2MODE.GT.NMODE2) THEN
                CALL HWWARN('HWISP2',128)
                GOTO 999
              ENDIF
              NME(I) = 30000+N2MODE
              ID2PRT(N2MODE) = I
              I2DRTP(N2MODE) = 6
              P2MODE(N2MODE) = ONE
              IM = MOD(INT((IDK(I)-389)/12)+1,2)+1
              IL = 6*INT((IDK(I)-401)/24)+MOD(IDK(I)-401,6)+1
              DO 22 J=1,2
 22           A2MODE(J,N2MODE) = AFC(J,IL,IM,L)
C--then antisfermion --> fermion chargino
            ELSE
              N2MODE = N2MODE+1
              IF(N2MODE.GT.NMODE2) THEN
                CALL HWWARN('HWISP2',129)
                GOTO 999
              ENDIF
              NME(I) = 30000+N2MODE
              ID2PRT(N2MODE) = I
              I2DRTP(N2MODE) = 5
              P2MODE(N2MODE) = ONE
              IM = MOD(INT((IDK(I)-389)/12)+1,2)+1
              IL = 6*INT((IDK(I)-401)/24)+MOD(IDK(I)-401,6)+1
              DO 23 J=1,2
 23           A2MODE(J,N2MODE) = AFC(O(J),IL,IM,L)
            ENDIF
C--sfermion modes to  fermion gravitino
          ELSEIF(IDKPRD(2,I).EQ.458) THEN
            IF(IDPDG(IDKPRD(1,I)).GT.0) THEN
              N2MODE = N2MODE+1
              IF(N2MODE.GT.NMODE2) THEN
                CALL HWWARN('HWISP2',130)
                GOTO 999
              ENDIF
              NME(I) = 30000+N2MODE
              ID2PRT(N2MODE) = I
              I2DRTP(N2MODE) = 11
              P2MODE(N2MODE) = ONE/THREE
              IM = MOD(INT((IDK(I)-389)/12)+1,2)+1
              IL = 6*INT((IDK(I)-401)/24)+MOD(IDK(I)-401,6)+1
              IF(IL.LE.6) THEN
                DO 40 J=1,2
 40             A2MODE(J,N2MODE) = QMIXSS(IL,O(J),IM)
              ELSE
                DO 41 J=1,2
 41             A2MODE(J,N2MODE) = LMIXSS(IL-6,O(J),IM)
              ENDIF
            ELSE
              N2MODE = N2MODE+1
              IF(N2MODE.GT.NMODE2) THEN
                CALL HWWARN('HWISP2',131)
                GOTO 999
              ENDIF
              NME(I) = 30000+N2MODE
              ID2PRT(N2MODE) = I
              I2DRTP(N2MODE) = 12
              P2MODE(N2MODE) = ONE/THREE
              IM = MOD(INT((IDK(I)-389)/12)+1,2)+1
              IL = 6*INT((IDK(I)-401)/24)+MOD(IDK(I)-401,6)+1
              IF(IL.LE.6) THEN
                DO 42 J=1,2
 42             A2MODE(J,N2MODE) = QMIXSS(IL,O(J),IM)
              ELSE
                DO 43 J=1,2
 43             A2MODE(J,N2MODE) = LMIXSS(IL-6,O(J),IM)
              ENDIF
            ENDIF
C--R-parity violating decay modes
C--LLE modes
          ELSEIF(IDK(I).GE.425.AND.IDK(I).LE.448.AND.
     &           IDKPRD(1,I).GE.121.AND.IDKPRD(1,I).LE.132.AND.
     &           IDKPRD(2,I).GE.121.AND.IDKPRD(2,I).LE.132) THEN
C--charged slepton decays
            IF(MOD(IDK(I),2).EQ.1) THEN
C--right slepton decay
              IF(IDPDG(IDKPRD(1,I))/ABS(IDPDG(IDKPRD(1,I))).EQ.
     &           IDPDG(IDKPRD(2,I))/ABS(IDPDG(IDKPRD(2,I)))) THEN
C--particle decay
                N2MODE = N2MODE+1
                IF(N2MODE.GT.NMODE2) THEN
                  CALL HWWARN('HWISP2',132)
                  GOTO 999
                ENDIF
                NME(I) = 30000+N2MODE
                ID2PRT(N2MODE) = I
                P2MODE(N2MODE) = ONE
                IF(IDPDG(IDK(I)).GT.0) THEN
                  KKK = (IDK(I)-423)/2
                  IF(KKK.GT.3) THEN
                     KKK = KKK-6
                     IM = 2
                  ELSE
                     IM = 1
                  ENDIF
                  IF(MOD(IDKPRD(1,I),2).EQ.0) THEN
                    III = (IDKPRD(1,I)-120)/2
                    JJJ = (IDKPRD(2,I)-119)/2
                  ELSE
                    III = (IDKPRD(2,I)-120)/2
                    JJJ = (IDKPRD(1,I)-119)/2
                  ENDIF
                  I2DRTP(N2MODE) = 6
                  A2MODE(1,N2MODE) = LMIXSS(2*KKK-1,2,IM)*
     &                 LAMDA1(III,JJJ,KKK)
                  A2MODE(2,N2MODE) = 0.0D0
                ELSE
C--antiparticle decay
                  KKK = (IDK(I)-429)/2
                  IF(KKK.GT.3) THEN
                     KKK = KKK-6
                     IM = 2
                  ELSE
                     IM = 1
                  ENDIF
                  IF(MOD(IDKPRD(1,I),2).EQ.0) THEN
                    III = (IDKPRD(1,I)-126)/2
                    JJJ = (IDKPRD(2,I)-125)/2
                  ELSE
                    III = (IDKPRD(2,I)-126)/2
                    JJJ = (IDKPRD(1,I)-125)/2
                  ENDIF
                  I2DRTP(N2MODE) = 13
                  A2MODE(1,N2MODE) = 0.0D0
                  A2MODE(2,N2MODE) = LMIXSS(2*KKK-1,2,IM)*
     &                 LAMDA1(III,JJJ,KKK)
                ENDIF
C--left slepton decay
              ELSE
                N2MODE = N2MODE+1
                IF(N2MODE.GT.NMODE2) THEN
                  CALL HWWARN('HWISP2',133)
                  GOTO 999
                ENDIF
                NME(I) = 30000+N2MODE
                ID2PRT(N2MODE) = I
                P2MODE(N2MODE) = ONE
                IF(IDPDG(IDK(I)).GT.0) THEN
                  JJJ = (IDK(I)-423)/2
                  IF(JJJ.GT.3) THEN
                    JJJ = JJJ-6
                    IM = 2
                  ELSE
                    IM = 1
                  ENDIF
                  IF(MOD(IDKPRD(1,I),2).EQ.0) THEN
                    III = (IDKPRD(1,I)-126)/2
                    KKK = (IDKPRD(2,I)-119)/2
                    I2DRTP(N2MODE) = 8
                  ELSE
                    III = (IDKPRD(2,I)-126)/2
                    KKK = (IDKPRD(1,I)-119)/2
                    I2DRTP(N2MODE) = 5
                  ENDIF
                  A2MODE(1,N2MODE) = 0.0D0
                  A2MODE(2,N2MODE) = LMIXSS(2*JJJ-1,1,IM)*
     &                 LAMDA1(III,JJJ,KKK)
                ELSE
                  JJJ = (IDK(I)-429)/2
                  IF(JJJ.GT.3) THEN
                    JJJ = JJJ-6
                    IM = 2
                  ELSE
                    IM = 1
                  ENDIF
                  IF(MOD(IDKPRD(1,I),2).EQ.0) THEN
                    III = (IDKPRD(1,I)-120)/2
                    KKK = (IDKPRD(2,I)-125)/2
                    I2DRTP(N2MODE) = 5
                  ELSE
                    III = (IDKPRD(2,I)-120)/2
                    KKK = (IDKPRD(1,I)-125)/2
                    I2DRTP(N2MODE) = 8
                  ENDIF
                  A2MODE(1,N2MODE) = LMIXSS(2*JJJ-1,1,IM)*
     &                 LAMDA1(III,JJJ,KKK)
                  A2MODE(2,N2MODE) = 0.0D0
                ENDIF
              ENDIF
C--sneutrino decays
            ELSEIF(MOD(IDK(I),2).EQ.0.AND.IDK(I).LE.436) THEN
C--sneutrino decay
              N2MODE = N2MODE+1
              IF(N2MODE.GT.NMODE2) THEN
                CALL HWWARN('HWISP2',134)
                GOTO 999
              ENDIF
              NME(I) = 30000+N2MODE
              ID2PRT(N2MODE) = I
              P2MODE(N2MODE) = ONE
              IF(IDPDG(IDK(I)).GT.0) THEN
                III = (IDK(I)-424)/2
                IF(IDPDG(IDKPRD(1,I)).GT.0) THEN
                  KKK = (IDKPRD(1,I)-119)/2
                  JJJ = (IDKPRD(2,I)-125)/2
                  I2DRTP(N2MODE) = 5
                ELSE
                  JJJ = (IDKPRD(1,I)-125)/2
                  KKK = (IDKPRD(2,I)-119)/2
                  I2DRTP(N2MODE) = 8
                ENDIF
                A2MODE(1,N2MODE) = 0.0D0
                A2MODE(2,N2MODE) = LAMDA1(III,JJJ,KKK)
C--antisneutrino decay
              ELSE
                III = (IDK(I)-430)/2
                IF(IDPDG(IDKPRD(1,I)).LT.0) THEN
                  KKK = (IDKPRD(1,I)-125)/2
                  JJJ = (IDKPRD(2,I)-119)/2
                  I2DRTP(N2MODE) = 8
                ELSE
                  JJJ = (IDKPRD(1,I)-119)/2
                  KKK = (IDKPRD(2,I)-125)/2
                  I2DRTP(N2MODE) = 5
                ENDIF
                A2MODE(1,N2MODE) = LAMDA1(III,JJJ,KKK)
                A2MODE(2,N2MODE) = 0.0D0
              ENDIF
            ENDIF
C--LQD modes
C--squark decays
          ELSEIF(IDK(I).GE.401.AND.IDK(I).LE.424.AND.
     &           IDKPRD(1,I).GE.121.AND.IDKPRD(2,I).LE.132.AND.
     &           IDKPRD(2,I).LE.12) THEN
C--up type squark decay
            IF(MOD(IDK(I),2).EQ.0) THEN
              N2MODE = N2MODE+1
              IF(N2MODE.GT.NMODE2) THEN
                CALL HWWARN('HWISP2',135)
                GOTO 999
              ENDIF
              NME(I) = 30000+N2MODE
              ID2PRT(N2MODE) = I
              P2MODE(N2MODE) = ONE
              IF(IDPDG(IDK(I)).GT.0) THEN
                JJJ = (IDK(I)-400)/2
                IF(JJJ.GT.3) THEN
                  JJJ = JJJ-6
                  IM  = 2
                ELSE
                  IM = 1
                ENDIF
                III = (IDKPRD(1,I)-125)/2
                KKK = (IDKPRD(2,I)+1)/2
                I2DRTP(N2MODE) = 8
                A2MODE(1,N2MODE) = ZERO
                A2MODE(2,N2MODE) = QMIXSS(2*JJJ,1,IM)*
     &                             LAMDA2(III,JJJ,KKK)
              ELSE
                JJJ = (IDK(I)-406)/2
                IF(JJJ.GT.3) THEN
                  JJJ = JJJ-6
                  IM  = 2
                ELSE
                  IM = 1
                ENDIF
                III = (IDKPRD(1,I)-119)/2
                KKK = (IDKPRD(2,I)-5)/2
                I2DRTP(N2MODE) = 5
                A2MODE(1,N2MODE) = QMIXSS(2*JJJ,1,IM)*
     &                             LAMDA2(III,JJJ,KKK)
                A2MODE(2,N2MODE) = ZERO
              ENDIF
C--down type squark to lepton up
            ELSEIF(MOD(IDK(I),2).EQ.1.AND.MOD(IDKPRD(1,I),2).EQ.1) THEN
              N2MODE = N2MODE+1
              IF(N2MODE.GT.NMODE2) THEN
                CALL HWWARN('HWISP2',136)
                GOTO 999
              ENDIF
              NME(I) = 30000+N2MODE
              ID2PRT(N2MODE) = I
              P2MODE(N2MODE) = ONE
C--particle
              IF(IDPDG(IDK(I)).GT.0) THEN
                KKK = (IDK(I)-399)/2
                IF(KKK.GT.3) THEN
                  KKK = KKK-6
                  IM  = 2
                ELSE
                  IM  = 1
                ENDIF
                III = (IDKPRD(1,I)-119)/2
                JJJ = IDKPRD(2,I)/2
                I2DRTP(N2MODE) = 6
                A2MODE(1,N2MODE) = QMIXSS(2*KKK-1,2,IM)*
     &                             LAMDA2(III,JJJ,KKK)
                A2MODE(2,N2MODE) = ZERO
C--antiparticle
              ELSE
                KKK = (IDK(I)-405)/2
                IF(KKK.GT.3) THEN
                  KKK = KKK-6
                  IM  = 2
                ELSE
                  IM  = 1
                ENDIF
                III = (IDKPRD(1,I)-125)/2
                JJJ = (IDKPRD(2,I)-6)/2
                I2DRTP(N2MODE) = 13
                A2MODE(1,N2MODE) = ZERO
                A2MODE(2,N2MODE) = QMIXSS(2*KKK-1,2,IM)*
     &                             LAMDA2(III,JJJ,KKK)
              ENDIF
C--down (left) squark --> nu d
            ELSEIF(MOD(IDK(I),2).EQ.1.AND.
     &           IDPDG(IDK(I))/ABS(IDPDG(IDK(I))).EQ.
     &          -IDPDG(IDKPRD(1,I))/ABS(IDPDG(IDKPRD(1,I)))) THEN
              N2MODE = N2MODE+1
              IF(N2MODE.GT.NMODE2) THEN
                CALL HWWARN('HWISP2',137)
                GOTO 999
              ENDIF
              NME(I) = 30000+N2MODE
              ID2PRT(N2MODE) = I
              P2MODE(N2MODE) = ONE
              IF(IDPDG(IDK(I)).GT.0) THEN
                JJJ = (IDK(I)-399)/2
                IF(JJJ.GT.3) THEN
                  JJJ = JJJ-6
                  IM  = 2
                ELSE
                  IM  = 1
                ENDIF
                III = (IDKPRD(1,I)-126)/2
                KKK = (IDKPRD(2,I)+1)/2
                I2DRTP(N2MODE) = 8
                A2MODE(1,N2MODE) = ZERO
                A2MODE(2,N2MODE) = QMIXSS(2*JJJ-1,1,IM)*
     &                             LAMDA2(III,JJJ,KKK)
              ELSE
                JJJ = (IDK(I)-405)/2
                IF(JJJ.GT.3) THEN
                  JJJ = JJJ-6
                  IM = 2
                ELSE
                  IM = 1
                ENDIF
                III = (IDKPRD(1,I)-120)/2
                KKK = (IDKPRD(2,I)-5)/2
                I2DRTP(N2MODE) = 5
                A2MODE(1,N2MODE) = QMIXSS(2*JJJ-1,1,IM)*
     &                             LAMDA2(III,JJJ,KKK)
                A2MODE(2,N2MODE) = ZERO
              ENDIF
C--down (right) squark --> nu d
            ELSEIF(MOD(IDK(I),2).EQ.1.AND.
     &           IDPDG(IDK(I))/ABS(IDPDG(IDK(I))).EQ.
     &           IDPDG(IDKPRD(1,I))/ABS(IDPDG(IDKPRD(1,I)))) THEN
              N2MODE = N2MODE+1
              IF(N2MODE.GT.NMODE2) THEN
                CALL HWWARN('HWISP2',138)
                GOTO 999
              ENDIF
              NME(I) = 30000+N2MODE
              ID2PRT(N2MODE) = I
              P2MODE(N2MODE) = ONE
              IF(IDPDG(IDK(I)).GT.0) THEN
                KKK = (IDK(I)-399)/2
                IF(KKK.GT.3) THEN
                  KKK = KKK-6
                  IM  = 2
                ELSE
                  IM  = 1
                ENDIF
                III = (IDKPRD(1,I)-120)/2
                JJJ = (IDKPRD(2,I)+1)/2
                I2DRTP(N2MODE) = 6
                A2MODE(1,N2MODE) = QMIXSS(2*KKK-1,2,IM)*
     &                             LAMDA2(III,JJJ,KKK)
                A2MODE(2,N2MODE) = ZERO
              ELSE
                KKK = (IDK(I)-405)/2
                IF(KKK.GT.3) THEN
                  KKK = KKK-6
                  IM  = 2
                ELSE
                  IM  = 1
                ENDIF
                III = (IDKPRD(1,I)-126)/2
                JJJ = (IDKPRD(2,I)-5)/2
                I2DRTP(N2MODE) = 13
                A2MODE(1,N2MODE) = ZERO
                A2MODE(2,N2MODE) = QMIXSS(2*KKK-1,2,IM)*
     &                             LAMDA2(III,JJJ,KKK)
              ENDIF
            ELSE
              CALL HWWARN('HWISP2',2)
            ENDIF
C--slepton decays
          ELSEIF(IDK(I).GE.425.AND.IDK(I).LE.448.AND.
     &           IDKPRD(1,I).LE.12.AND.IDKPRD(2,I).LE.12) THEN
C--sneutrino decay
            IF(MOD(IDK(I),2).EQ.0) THEN
              N2MODE = N2MODE+1
              IF(N2MODE.GT.NMODE2) THEN
                CALL HWWARN('HWISP2',140)
                GOTO 999
              ENDIF
              NME(I) = 30000+N2MODE
              ID2PRT(N2MODE) = I
              P2MODE(N2MODE) = THREE
C--particle
              IF(IDPDG(IDK(I)).GT.0) THEN
                III = (IDK(I)-424)/2
                JJJ = (IDKPRD(1,I)-5)/2
                KKK = (IDKPRD(2,I)+1)/2
                I2DRTP(N2MODE) = 8
                A2MODE(1,N2MODE) = 0.0D0
                A2MODE(2,N2MODE) = LAMDA2(III,JJJ,KKK)
C--antiparticle
              ELSE
                III = (IDK(I)-430)/2
                JJJ = (IDKPRD(1,I)+1)/2
                KKK = (IDKPRD(2,I)-5)/2
                I2DRTP(N2MODE) = 5
                A2MODE(1,N2MODE) = LAMDA2(III,JJJ,KKK)
                A2MODE(2,N2MODE) = 0.0D0
              ENDIF
C--slepton decay
            ELSEIF(MOD(IDK(I),2).EQ.1) THEN
              N2MODE = N2MODE+1
              IF(N2MODE.GT.NMODE2) THEN
                CALL HWWARN('HWISP2',141)
                GOTO 999
              ENDIF
              NME(I) = 30000+N2MODE
              ID2PRT(N2MODE) = I
              P2MODE(N2MODE) = THREE
C--particle
              IF(IDPDG(IDK(I)).GT.0) THEN
                III = (IDK(I)-423)/2
                IF(III.GT.3) THEN
                   III = III -6
                   IM = 2
                ELSE
                   IM = 1
                ENDIF
                JJJ = (IDKPRD(1,I)-6)/2
                KKK = (IDKPRD(2,I)+1)/2
                I2DRTP(N2MODE) = 8
                A2MODE(1,N2MODE) = 0.0D0
                A2MODE(2,N2MODE) = LMIXSS(2*III-1,1,IM)*
     &                             LAMDA2(III,JJJ,KKK)
C--antiparticle
              ELSE
                III = (IDK(I)-429)/2
                IF(III.GT.3) THEN
                   III = III -6
                   IM = 2
                ELSE
                   IM = 1
                ENDIF
                JJJ = IDKPRD(1,I)/2
                KKK = (IDKPRD(2,I)-5)/2
                I2DRTP(N2MODE) = 5
                A2MODE(1,N2MODE) = LMIXSS(2*III-1,1,IM)*
     &                             LAMDA2(III,JJJ,KKK)
                A2MODE(2,N2MODE) = 0.0D0
              ENDIF
            ELSE
              CALL HWWARN('HWISP2',3)
            ENDIF
C--UDD modes
          ELSEIF(IDK(I).GE.401.AND.IDK(I).LE.424.AND.
     &           IDKPRD(1,I).LE.12.AND.IDKPRD(2,I).LE.12) THEN
C--up type squark decay
            IF(MOD(IDK(I),2).EQ.0) THEN
              N2MODE = N2MODE+1
              IF(N2MODE.GT.NMODE2) THEN
                CALL HWWARN('HWISP2',143)
                GOTO 999
              ENDIF
              NME(I) = 30000+N2MODE
              ID2PRT(N2MODE) = I
              P2MODE(N2MODE) = 2.0D0
C--squark decay
              IF(IDPDG(IDK(I)).GT.0) THEN
                III = (IDK(I)-400)/2
                IF(III.GT.3) THEN
                  III = III-6
                  IM = 2
                ELSE
                  IM = 1
                ENDIF
                JJJ = (IDKPRD(1,I)-5)/2
                KKK = (IDKPRD(2,I)-5)/2
                I2DRTP(N2MODE) = 13
                A2MODE(1,N2MODE)=QMIXSS(2*III,2,IM)*LAMDA3(III,JJJ,KKK)
                A2MODE(2,N2MODE)=0.0D0
C--antisquark decay
              ELSE
                III = (IDK(I)-406)/2
                IF(III.GT.3) THEN
                  III = III-6
                  IM = 2
                ELSE
                  IM = 1
                ENDIF
                JJJ = (IDKPRD(1,I)+1)/2
                KKK = (IDKPRD(2,I)+1)/2
                I2DRTP(N2MODE) = 6
                A2MODE(1,N2MODE) =0.0D0
                A2MODE(2,N2MODE) =QMIXSS(2*III,2,IM)*LAMDA3(III,JJJ,KKK)
              ENDIF
            ELSE
C--down type squark decay
              N2MODE = N2MODE+1
              IF(N2MODE.GT.NMODE2) THEN
                CALL HWWARN('HWISP2',144)
                GOTO 999
              ENDIF
              NME(I) = 30000+N2MODE
              ID2PRT(N2MODE) = I
              P2MODE(N2MODE) = 2.0D0
C--squark decay
              IF(IDPDG(IDK(I)).GT.0) THEN
                JJJ = (IDK(I)-399)/2
                IF(JJJ.GT.3) THEN
                  JJJ = JJJ-6
                  IM = 2
                ELSE
                  IM = 1
                ENDIF
                III = (IDKPRD(1,I)-6)/2
                KKK = (IDKPRD(2,I)-5)/2
                I2DRTP(N2MODE) = 13
                A2MODE(1,N2MODE)= QMIXSS(2*JJJ-1,2,IM)*
     &                            LAMDA3(III,JJJ,KKK)
                A2MODE(2,N2MODE)= 0.0D0
C--antisquark decay
              ELSE
                JJJ = (IDK(I)-405)/2
                IF(JJJ.GT.3) THEN
                  JJJ = JJJ-6
                  IM = 2
                ELSE
                  IM = 1
                ENDIF
                III = IDKPRD(1,I)/2
                KKK = (IDKPRD(2,I)+1)/2
                I2DRTP(N2MODE) = 6
                A2MODE(1,N2MODE) = 0.0D0
                A2MODE(2,N2MODE) = QMIXSS(2*JJJ-1,2,IM)*
     &                             LAMDA3(III,JJJ,KKK)
              ENDIF
            ENDIF
          ELSE
            IF(.NOT.(RSPIN(IDKPRD(1,I)).EQ.ZERO.AND.
     &         RSPIN(IDKPRD(2,I)).EQ.ZERO)) CALL HWWARN('HWISP2',4)
          ENDIF
        ELSEIF(IDK(I).GE.203.AND.IDK(I).LE.207) THEN
          IH = IDK(I)-202
          L  = IDKPRD(1,I)-449
          L1 = IDKPRD(2,I)-449
C--Neutral Higgs decays
          IF(IH.GE.1.AND.IH.LE.3) THEN
C--Higgs to neutralino neutralino
            IF(L.GE.1.AND.L.LE.4) THEN
              N2MODE = N2MODE+1
              IF(N2MODE.GT.NMODE2) THEN
                CALL HWWARN('HWISP2',146)
                GOTO 999
              ENDIF
              NME(I) = 30000+N2MODE
              ID2PRT(N2MODE) = I
              I2DRTP(N2MODE) = 6
              P2MODE(N2MODE) = ONE
              IF(L.EQ.L1) P2MODE(N2MODE) = HALF
              DO 24 J=1,2
 24           A2MODE(J,N2MODE) = HNN(J,IH,L,L1)
C--Higgs to chargino chargino
            ELSEIF(L.GE.5.AND.L.LE.8) THEN
              L  = MOD(L -5,2)+1
              L1 = MOD(L1-5,2)+1
              N2MODE = N2MODE+1
              IF(N2MODE.GT.NMODE2) THEN
                CALL HWWARN('HWISP2',147)
                GOTO 999
              ENDIF
              NME(I) = 30000+N2MODE
              ID2PRT(N2MODE) = I
              I2DRTP(N2MODE) = 6
              P2MODE(N2MODE) = ONE
              DO 25 J=1,2
              IF(IDPDG(IDKPRD(1,I)).GT.0) THEN
                A2MODE(J,N2MODE) = HCC(  J ,IH,L,L1)
              ELSE
                A2MODE(J,N2MODE) = HCC(O(J),IH,L,L1)
              ENDIF
 25           CONTINUE
C--Higgs to fermion antifermion
            ELSEIF((L.GE.-448.AND.L.LE.-437)
     &         .OR.(L.GE.-328.AND.L.LE.-317)) THEN
              N2MODE = N2MODE+1
              IF(N2MODE.GT.NMODE2) THEN
                CALL HWWARN('HWISP2',148)
                GOTO 999
              ENDIF
              NME(I) = 30000+N2MODE
              ID2PRT(N2MODE) = I
              I2DRTP(N2MODE) = 5
              P2MODE(N2MODE) = ONE
              IL = IDKPRD(1,I)
              IL = IL-6*INT((IL-1)/6)+6*INT((IL-1)/120)
              IF(IL.LE.6) P2MODE(N2MODE) = THREE
              DO 26 J=1,2
 26           A2MODE(J,N2MODE) = HFF(J,IH,IL)
            ELSE
              IF(.NOT.
     &       (RSPIN(IDKPRD(1,I)).EQ.ZERO.AND.RSPIN(IDKPRD(2,I)).EQ.ZERO)
     &        .AND..NOT.(IDKPRD(1,I).EQ.13.AND.IDKPRD(2,I).EQ.13)
     &        .AND..NOT.(IDKPRD(1,I).EQ.59.AND.IDKPRD(2,I).EQ.59)
     &        .AND..NOT.(IDKPRD(1,I).GE.198.AND.IDKPRD(1,I).LE.200.AND.
     &                   IDKPRD(2,I).GE.198.AND.IDKPRD(2,I).LE.200))
     &        CALL HWWARN('HWISP2',5)
            ENDIF
C--charged Higgs decays
          ELSE
            IH = IDK(I)-205
            L  = IDKPRD(1,I)-449
            L1 = IDKPRD(2,I)-449
C--positive Higgs decays
            IF(IH.EQ.1) THEN
C--decay to chargino neutralino
              IF(L.EQ.5.OR.L.EQ.6) THEN
                L = L-4
                N2MODE = N2MODE+1
                IF(N2MODE.GT.NMODE2) THEN
                  CALL HWWARN('HWISP2',149)
                  GOTO 999
                ENDIF
                NME(I) = 30000+N2MODE
                ID2PRT(N2MODE) = I
                I2DRTP(N2MODE) = 6
                P2MODE(N2MODE) = ONE
                DO 27 J=1,2
 27             A2MODE(J,N2MODE) = HNC(O(J),L1,L)
C--decay to neutralino chargino
              ELSEIF(L.GE.1.AND.L.LE.4) THEN
                L1 = L1-4
                N2MODE = N2MODE+1
                IF(N2MODE.GT.NMODE2) THEN
                  CALL HWWARN('HWISP2',150)
                  GOTO 999
                ENDIF
                NME(I) = 30000+N2MODE
                ID2PRT(N2MODE) = I
                I2DRTP(N2MODE) = 6
                P2MODE(N2MODE) = ONE
                DO 28 J=1,2
 28             A2MODE(J,N2MODE) = HNC(O(J),L1,L)
C--fermion antifermion decay modes
              ELSEIF((L.GE.-448.AND.L.LE.-437)
     &               .OR.(L.GE.-328.AND.L.LE.-317)) THEN
                N2MODE = N2MODE+1
                IF(N2MODE.GT.NMODE2) THEN
                  CALL HWWARN('HWISP2',151)
                  GOTO 999
                ENDIF
                NME(I) = 30000+N2MODE
                ID2PRT(N2MODE) = I
                I2DRTP(N2MODE) = 5
                P2MODE(N2MODE) = ONE
                IL = IDKPRD(1,I)
                IL = IL-6*INT((IL-1)/6)+6*INT((IL-1)/120)
                IL = INT((IL+1)/2)
                IF(IL.LE.3) P2MODE(N2MODE) = THREE
                DO 29 J=1,2
 29             A2MODE(J,N2MODE) = HFF(J,4,IL)
              ELSE
                IF(RSPIN(IDKPRD(1,I)).NE.ZERO.OR.RSPIN(IDKPRD(2,I)).NE.
     &           ZERO) CALL HWWARN('HWISP2',6)
              ENDIF
C--negative Higgs decays
            ELSE
C--Higgs to chargino neutralino
              IF(L.EQ.7.OR.L.EQ.8) THEN
                L = L-6
                N2MODE = N2MODE+1
                IF(N2MODE.GT.NMODE2) THEN
                  CALL HWWARN('HWISP2',152)
                  GOTO 999
                ENDIF
                NME(I) = 30000+N2MODE
                ID2PRT(N2MODE) = I
                I2DRTP(N2MODE) = 6
                P2MODE(N2MODE) = ONE
                DO 30 J=1,2
 30             A2MODE(J,N2MODE) = HNC(J,L1,L)
C--Higgs to neutralino chargino
              ELSEIF(L.GE.1.AND.L.LE.4) THEN
                L1 = L1-6
                N2MODE = N2MODE+1
                IF(N2MODE.GT.NMODE2) THEN
                  CALL HWWARN('HWISP2',153)
                  GOTO 999
                ENDIF
                NME(I) = 30000+N2MODE
                ID2PRT(N2MODE) = I
                I2DRTP(N2MODE) = 6
                P2MODE(N2MODE) = ONE
                DO 31 J=1,2
 31             A2MODE(J,N2MODE) = HNC(J,L1,L)
C--fermion antifermion decay modes
              ELSEIF((L.GE.-448.AND.L.LE.-437)
     &               .OR.(L.GE.-328.AND.L.LE.-317)) THEN
                N2MODE = N2MODE+1
                IF(N2MODE.GT.NMODE2) THEN
                  CALL HWWARN('HWISP2',154)
                  GOTO 999
                ENDIF
                NME(I) = 30000+N2MODE
                ID2PRT(N2MODE) = I
                I2DRTP(N2MODE) = 8
                P2MODE(N2MODE) = ONE
                IL = IDKPRD(1,I)
                IL = IL-6*INT((IL-1)/6)+6*INT((IL-1)/120)
                IL = INT((IL+1)/2)
                IF(IL.LE.3) P2MODE(N2MODE) = THREE
                DO 32 J=1,2
 32             A2MODE(J,N2MODE) = HFF(O(J),4,IL)
              ELSE
                IF(RSPIN(IDKPRD(1,I)).NE.ZERO.OR.RSPIN(IDKPRD(1,I)).NE.
     &           ZERO) CALL HWWARN('HWISP2',7)
              ENDIF
            ENDIF
          ENDIF
        ENDIF
 1000 CONTINUE
C--now find the maximum weights and compute the decay rates
      DO 2000 I=1,N2MODE
      IF(IPRINT.GE.2) WRITE(6,5010) RNAME(IDK(ID2PRT(I))),
     &   RNAME(IDKPRD(1,ID2PRT(I))),RNAME(IDKPRD(2,ID2PRT(I)))
 2000 CALL HWD2ME(I)
      RETURN
 5010 FORMAT(/'CALCULATING TWO BODY DECAY ',
     &     A8,' --> ',A8,' ',A8/)
 999  RETURN
      END
CDECK  ID>, HWISP3.
*CMZ :-        -30/09/02  14:05:28  by  Peter Richardson
*-- Author :    Peter Richardson
C-----------------------------------------------------------------------
      SUBROUTINE HWISP3
C-----------------------------------------------------------------------
C     Initialise the top/SUSY three body decay modes
C     gravitino and RPV modes added by Peter Richardson
C-----------------------------------------------------------------------
      INCLUDE 'HERWIG65.INC'
      INTEGER I,J,K,L,L1,IL,IQ,IQ1,IQ2,IFR,SIFR,IH,IH1,IM,O(2),II,JJ,
     &     III,JJJ,KKK
      DOUBLE PRECISION SW,CW,TW,E,G,RT,ORT,MW,MZ,GS,AFN(2,12,2,4),
     &     AFG(2,6,2),AFC(2,12,2,2),OIJ(2,4,2),OIJP(2,2,2),OIJPP(2,4,4),
     &     HNN(2,3,4,4),HCC(2,3,2,2),HNC(2,4,2),HFF(2,4,12),HWW(2),
     &     HZZ(2),ZAB(12,2,2),HHB(2,3)
      DOUBLE COMPLEX RHOIN(2,2)
      COMMON /HWSPNC/ SW,CW,TW,E,G,RT,ORT,MW,MZ,GS,AFN,AFG,AFC,OIJ,OIJP,
     &               OIJPP,HNN,HCC,HNC,HFF,HWW,HZZ,ZAB,HHB
      SAVE O
      DATA O/2,1/
      IF(IERROR.NE.0) RETURN
C--loop over the decays and find the top decays
      DO 1000 JJ=6,12,6
      DO 1000 II=1,NMODES(JJ)
        IF(II.EQ.1) THEN
          I = LSTRT(JJ)
        ELSE
          I = LNEXT(I)
        ENDIF
C--top decay via W
        IF(IDK(I).EQ.6.AND.NME(I).EQ.100) THEN
          N3MODE = N3MODE+1
          IF(N3MODE.GT.NMODE3) THEN
            CALL HWWARN('HWISP3',100)
            GOTO 999
          ENDIF
          P3MODE(N3MODE) = ONE
          IF(IDKPRD(1,I).LE.12) P3MODE(N3MODE) = THREE
          SPN3CF(1,1,N3MODE) = ONE
          N3NCFL(N3MODE) = 1
          ID3PRT(N3MODE) = I
          NME(I)         = 10000+N3MODE
          NDI3BY(N3MODE)   = 1
          I3DRTP(1,N3MODE) = 1
          I3DRCF(1,N3MODE) = 1
          I3MODE(1,N3MODE) = 198
          A3MODE(1,1,N3MODE) = ZERO
          A3MODE(2,1,N3MODE) = -G*ORT
          B3MODE(1,1,N3MODE) = ZERO
          B3MODE(2,1,N3MODE) = -G*ORT
C--antitop decay via W
        ELSEIF(IDK(I).EQ.12.AND.NME(I).EQ.100) THEN
          N3MODE = N3MODE+1
          IF(N3MODE.GT.NMODE3) THEN
            CALL HWWARN('HWISP3',101)
            GOTO 999
          ENDIF
          P3MODE(N3MODE) = ONE
          IF(IDKPRD(1,I).LE.12) P3MODE(N3MODE) = THREE
          SPN3CF(1,1,N3MODE) = ONE
          N3NCFL(N3MODE) = 1
          ID3PRT(N3MODE) = I
          NME(I) = 10000+N3MODE
          NDI3BY(N3MODE)   = 1
          I3DRTP(1,N3MODE) = 5
          I3DRCF(1,N3MODE) = 1
          I3MODE(1,N3MODE) = 199
          A3MODE(1,1,N3MODE) = ZERO
          A3MODE(2,1,N3MODE) = -G*ORT
          B3MODE(1,1,N3MODE) = ZERO
          B3MODE(2,1,N3MODE) = -G*ORT
C--top decay via charged Higgs
        ELSEIF(IDK(I).EQ.6.AND.NME(I).EQ.200) THEN
          N3MODE = N3MODE+1
          IF(N3MODE.GT.NMODE3) THEN
            CALL HWWARN('HWISP3',102)
            GOTO 999
          ENDIF
          P3MODE(N3MODE) = ONE
          IF(IDKPRD(1,I).LE.12) P3MODE(N3MODE) = THREE
          SPN3CF(1,1,N3MODE) = ONE
          N3NCFL(N3MODE) = 1
          ID3PRT(N3MODE) = I
          NME(I) = 10000+N3MODE
          NDI3BY(N3MODE)   = 1
          I3DRTP(1,N3MODE) = 2
          I3DRCF(1,N3MODE) = 1
          I3MODE(1,N3MODE) = 206
          IL = IDKPRD(1,I)
          IL = IL-6*INT((IL-1)/6)+6*INT((IL-1)/120)
          IL = INT((IL+1)/2)
          DO 201 J=1,2
          A3MODE(J,1,N3MODE) = HFF(O(J),4,3)
 201      B3MODE(J,1,N3MODE) = HFF(  J ,4,IL)
C--antitop decay via charged Higgs
        ELSEIF(IDK(I).EQ.12.AND.NME(I).EQ.200) THEN
          N3MODE = N3MODE+1
          IF(N3MODE.GT.NMODE3) THEN
            CALL HWWARN('HWISP3',103)
            GOTO 999
          ENDIF
          P3MODE(N3MODE) = ONE
          IF(IDKPRD(1,I).LE.12) P3MODE(N3MODE) = THREE
          SPN3CF(1,1,N3MODE) = ONE
          N3NCFL(N3MODE) = 1
          ID3PRT(N3MODE) = I
          NME(I) = 10000+N3MODE
          NDI3BY(N3MODE)   = 1
          I3DRTP(1,N3MODE) = 17
          I3DRCF(1,N3MODE) = 1
          I3MODE(1,N3MODE) = 207
          IL = IDKPRD(1,I)
          IL = IL-6*INT((IL-1)/6)+6*INT((IL-1)/120)
          IL = INT((IL+1)/2)
          DO 202 J=1,2
          A3MODE(J,1,N3MODE) = HFF(  J ,4,3)
 202      B3MODE(J,1,N3MODE) = HFF(O(J),4,IL)
        ENDIF
 1000 CONTINUE
      IF(.NOT.SUSYIN) GOTO 2999
C--loop over all the SUSY decay modes and find the ones we want
C--first the true three body gaugino decays
      DO 2000 JJ=1,NRES
      DO 2000 II=1,NMODES(JJ)
        IF(II.EQ.1) THEN
          I = LSTRT(JJ)
        ELSE
          I = LNEXT(I)
        ENDIF
        L = IDKPRD(1,I)-449
        IF(IDKPRD(3,I).EQ.0.OR.IDKPRD(4,I).NE.0) GOTO 2500
C--gluino modes first
        IF(IDK(I).EQ.449) THEN
C--first the gluino modes to quark-antiquark neutralino
          IF(L.GE.1.AND.L.LE.4.AND.(IDKPRD(2,I).LE.12.OR.
     &       (IDKPRD(2,I).GE.121.AND.IDKPRD(2,I).LE.132))) THEN
            IQ = IDKPRD(2,I)
            IF(IQ.GT.6) IQ=IQ-6
            IF(IQ.GT.6.OR.IQ.LT.1) CALL HWWARN('HWISP3',200)
            N3MODE = N3MODE+1
            IF(N3MODE.GT.NMODE3) THEN
              CALL HWWARN('HWISP3',104)
              GOTO 999
            ENDIF
            P3MODE(N3MODE) = HALF
            SPN3CF(1,1,N3MODE) = ONE
            N3NCFL(N3MODE) = 1
            ID3PRT(N3MODE) = I
            NME(I) = 10000+N3MODE
            NDI3BY(N3MODE)   = 4
C--only squark exchange diagrams
            DO 1 K=1,2
            I3DRTP(K  ,N3MODE) = 3
            I3DRCF(K  ,N3MODE) = 1
            I3DRTP(K+2,N3MODE) = 4
            I3DRCF(K+2,N3MODE) = 1
            I3MODE(K  ,N3MODE) = 12*(K-1)+400+IQ
            I3MODE(K+2,N3MODE) = 12*(K-1)+406+IQ
            DO 1 J=1,2
            A3MODE(J,K  ,N3MODE) = AFG(  J ,IQ,K)
            B3MODE(J,K  ,N3MODE) = AFN(O(J),IQ,K,L)
            A3MODE(J,K+2,N3MODE) = AFG(O(J),IQ,K)
 1          B3MODE(J,K+2,N3MODE) = ZSGNSS(L)*AFN(  J ,IQ,K,L)
C--then the gluino modes to quark-antiquark +ve chargino
          ELSEIF(L.EQ.5.OR.L.EQ.6.AND.(IDKPRD(2,I).LE.12.OR.
     &       (IDKPRD(2,I).GE.121.AND.IDKPRD(2,I).LE.132))) THEN
            L = L-4
            IQ = IDKPRD(2,I)
            IF(IQ.GT.6) IQ=IQ-6
            IF(IQ.GT.6.OR.IQ.LT.1) CALL HWWARN('HWISP3',201)
            IQ = (IQ+MOD(IQ,2))/2
            IQ1 = 2*IQ-1
            IQ2 = 2*IQ
            N3MODE = N3MODE+1
            IF(N3MODE.GT.NMODE3) THEN
              CALL HWWARN('HWISP3',105)
              GOTO 999
            ENDIF
            P3MODE(N3MODE) = HALF
            SPN3CF(1,1,N3MODE) = ONE
            N3NCFL(N3MODE) = 1
            ID3PRT(N3MODE) = I
            NME(I) = 10000+N3MODE
            NDI3BY(N3MODE)   = 4
C--only squark exchange diagrams
            DO 2 K=1,2
            I3DRTP(K  ,N3MODE) = 3
            I3DRCF(K  ,N3MODE) = 1
            I3DRTP(K+2,N3MODE) = 4
            I3DRCF(K+2,N3MODE) = 1
            I3MODE(K  ,N3MODE) = 12*(K-1)+400+IQ1
            I3MODE(K+2,N3MODE) = 12*(K-1)+406+IQ2
            DO 2 J=1,2
            A3MODE(J,K  ,N3MODE) = AFG(  J ,IQ1,K)
            B3MODE(J,K  ,N3MODE) = AFC(O(J),IQ1,K,L)
            A3MODE(J,K+2,N3MODE) = AFG(O(J),IQ2,K)
 2          B3MODE(J,K+2,N3MODE) = AFC(  J ,IQ2,K,L)
C--then the gluino modes to quark-antiquark -ve chargino
          ELSEIF(L.EQ.7.OR.L.EQ.8.AND.(IDKPRD(2,I).LE.12.OR.
     &       (IDKPRD(2,I).GE.121.AND.IDKPRD(2,I).LE.132))) THEN
            L = L-6
            IQ = IDKPRD(2,I)
            IF(IQ.GT.6) IQ=IQ-6
            IF(IQ.GT.6.OR.IQ.LT.1) CALL HWWARN('HWISP3',202)
            IQ = (IQ+MOD(IQ,2))/2
            IQ1 = 2*IQ
            IQ2 = 2*IQ-1
            N3MODE = N3MODE+1
            IF(N3MODE.GT.NMODE3) THEN
              CALL HWWARN('HWISP3',106)
              GOTO 999
            ENDIF
            P3MODE(N3MODE) = HALF
            SPN3CF(1,1,N3MODE) = ONE
            N3NCFL(N3MODE) = 1
            ID3PRT(N3MODE) = I
            NME(I) = 10000+N3MODE
            NDI3BY(N3MODE)   = 4
C--only squark exchange diagrams
            DO 3 K=1,2
            I3DRTP(K  ,N3MODE) = 3
            I3DRCF(K  ,N3MODE) = 1
            I3DRTP(K+2,N3MODE) = 4
            I3DRCF(K+2,N3MODE) = 1
            I3MODE(K  ,N3MODE) = 12*(K-1)+400+IQ1
            I3MODE(K+2,N3MODE) = 12*(K-1)+406+IQ2
            DO 3 J=1,2
            A3MODE(J,K  ,N3MODE) = AFG(  J ,IQ1,K)
            B3MODE(J,K  ,N3MODE) = AFC(O(J),IQ1,K,L)
            A3MODE(J,K+2,N3MODE) = AFG(O(J),IQ2,K)
 3          B3MODE(J,K+2,N3MODE) = AFC(  J ,IQ2,K,L)
C--RPV decay modes
C--LQD first
          ELSEIF(IDKPRD(1,I).GE.121.AND.IDKPRD(1,I).LE.132.AND.
     &           IDKPRD(2,I).LE.12 .AND.IDKPRD(3,I).LE.12) THEN
            N3MODE = N3MODE+1
            IF(N3MODE.GT.NMODE3) THEN
              CALL HWWARN('HWISP3',107)
              GOTO 999
            ENDIF
            ID3PRT(N3MODE) = I
            NME(I) = 10000+N3MODE
            P3MODE(N3MODE) = HALF
            SPN3CF(1,1,N3MODE) = ONE
            N3NCFL(N3MODE) = 1
            NDI3BY(N3MODE) = 4
            DO 98 J=1,4
 98         I3DRCF(J,N3MODE) = 1
C--first the neutrino mode
            IF(MOD(IDKPRD(1,I),2).EQ.0) THEN
C--particle mode
              IF(IDPDG(IDKPRD(1,I)).GT.0) THEN
                III = (IDKPRD(1,I)-120)/2
                JJJ = (IDKPRD(2,I)+1)/2
                KKK = (IDKPRD(3,I)-5)/2
                DO 99 K=1,2
                I3DRTP(K  ,N3MODE) = 3
                I3DRTP(K+2,N3MODE) = 4
                I3MODE(K  ,N3MODE) = 399+2*JJJ+(K-1)*12
                I3MODE(K+2,N3MODE) = 399+2*KKK+(K-1)*12
                B3MODE(2,K  ,N3MODE) = 0.0D0
                B3MODE(1,K  ,N3MODE) = -QMIXSS(2*JJJ-1,1,K)*
     &                                 LAMDA2(III,JJJ,KKK)
                B3MODE(2,K+2,N3MODE) = 0.0D0
                B3MODE(1,K+2,N3MODE) = -QMIXSS(2*KKK-1,2,K)*
     &                                 LAMDA2(III,JJJ,KKK)
                DO 99 J=1,2
                A3MODE(J,K  ,N3MODE) = AFG(  J ,2*JJJ-1,K)
 99             A3MODE(J,K+2,N3MODE) = AFG(O(J),2*KKK-1,K)
C--antiparticle mode
              ELSE
                III = (IDKPRD(1,I)-126)/2
                JJJ = (IDKPRD(2,I)-5)/2
                KKK = (IDKPRD(3,I)+1)/2
                DO 101 K=1,2
                I3DRTP(K  ,N3MODE) = 9
                I3DRTP(K+2,N3MODE) = 10
                I3MODE(K  ,N3MODE) = 399+2*JJJ+(K-1)*12
                I3MODE(K+2,N3MODE) = 399+2*KKK+(K-1)*12
                B3MODE(1,K  ,N3MODE) = 0.0D0
                B3MODE(2,K  ,N3MODE) = -QMIXSS(2*JJJ-1,1,K)*
     &                                 LAMDA2(III,JJJ,KKK)
                B3MODE(1,K+2,N3MODE) = 0.0D0
                B3MODE(2,K+2,N3MODE) = -QMIXSS(2*KKK-1,2,K)*
     &                                 LAMDA2(III,JJJ,KKK)
                DO 101 J=1,2
                A3MODE(J,K  ,N3MODE) = AFG(O(J),2*JJJ-1,K)
 101            A3MODE(J,K+2,N3MODE) = AFG(  J ,2*KKK-1,K)
              ENDIF
C--then the charged lepton mode
            ELSE
C--particle mode
              IF(IDPDG(IDKPRD(1,I)).GT.0) THEN
                III = (IDKPRD(1,I)-119)/2
                JJJ = IDKPRD(2,I)/2
                KKK = (IDKPRD(3,I)-5)/2
                DO 102 K=1,2
                I3DRTP(K  ,N3MODE) = 3
                I3DRTP(K+2,N3MODE) = 4
                I3MODE(K  ,N3MODE) = 400+2*JJJ+(K-1)*12
                I3MODE(K+2,N3MODE) = 399+2*KKK+(K-1)*12
                B3MODE(2,K  ,N3MODE) = 0.0D0
                B3MODE(1,K  ,N3MODE) = QMIXSS(2*JJJ,1,K)*
     &                                 LAMDA2(III,JJJ,KKK)
                B3MODE(2,K+2,N3MODE) = 0.0D0
                B3MODE(1,K+2,N3MODE) = QMIXSS(2*KKK-1,2,K)*
     &                                 LAMDA2(III,JJJ,KKK)
                DO 102 J=1,2
                A3MODE(J,K  ,N3MODE) = AFG(  J ,2*JJJ  ,K)
 102            A3MODE(J,K+2,N3MODE) = AFG(O(J),2*KKK-1,K)
C--antiparticle mode
              ELSE
                III = (IDKPRD(1,I)-125)/2
                JJJ = (IDKPRD(2,I)-6)/2
                KKK = (IDKPRD(3,I)+1)/2
                DO 103 K=1,2
                I3DRTP(K  ,N3MODE) = 9
                I3DRTP(K+2,N3MODE) = 10
                I3MODE(K  ,N3MODE) = 400+2*JJJ+(K-1)*12
                I3MODE(K+2,N3MODE) = 399+2*KKK+(K-1)*12
                B3MODE(1,K  ,N3MODE) = 0.0D0
                B3MODE(2,K  ,N3MODE) = QMIXSS(2*JJJ,1,K)*
     &                                 LAMDA2(III,JJJ,KKK)
                B3MODE(1,K+2,N3MODE) = 0.0D0
                B3MODE(2,K+2,N3MODE) = QMIXSS(2*KKK-1,2,K)*
     &                                 LAMDA2(III,JJJ,KKK)
                DO 103 J=1,2
                A3MODE(J,K  ,N3MODE) = AFG(O(J),2*JJJ  ,K)
 103            A3MODE(J,K+2,N3MODE) = AFG(  J ,2*KKK-1,K)
              ENDIF
            ENDIF
C--then UDD
          ELSEIF(IDKPRD(1,I).LE.12.AND.IDKPRD(2,I).LE.12.AND.
     &           IDKPRD(3,I).LE.12) THEN
            N3MODE = N3MODE+1
            IF(N3MODE.GT.NMODE3) THEN
              CALL HWWARN('HWISP3',108)
              GOTO 999
            ENDIF
            P3MODE(N3MODE) = ONE
            N3NCFL(N3MODE) = 3
            ID3PRT(N3MODE) = I
            NME(I) = 10000+N3MODE
            NDI3BY(N3MODE)   = 6
            DO 70 J=1,3
            DO 70 K=1,3
              IF(J.NE.K) THEN
                SPN3CF(J,K,N3MODE) = -HALF
              ELSE
                SPN3CF(J,K,N3MODE) =  ONE
              ENDIF
 70         CONTINUE
C--particle mode
            IF(IDKPRD(1,I).LE.6) THEN
C--antiparticle mode
              III =  IDKPRD(1,I)/2
              JJJ = (IDKPRD(2,I)+1)/2
              KKK = (IDKPRD(3,I)+1)/2
              DO 71 K=1,2
              I3DRTP(K  ,N3MODE) = 11
              I3DRCF(K  ,N3MODE) = 1
              I3DRTP(K+2,N3MODE) = 12
              I3DRCF(K+2,N3MODE) = 2
              I3DRTP(K+4,N3MODE) = 13
              I3DRCF(K+4,N3MODE) = 3
              I3MODE(K  ,N3MODE) = 400+2*III+(K-1)*12
              I3MODE(K+2,N3MODE) = 399+2*JJJ+(K-1)*12
              I3MODE(K+4,N3MODE) = 399+2*KKK+(K-1)*12
              B3MODE(2,K  ,N3MODE) = QMIXSS(2*III,2,K)*
     &                               LAMDA3(III,JJJ,KKK)
              B3MODE(2,K+2,N3MODE) = QMIXSS(2*JJJ-1,2,K)*
     &                               LAMDA3(III,JJJ,KKK)
              B3MODE(2,K+4,N3MODE) = QMIXSS(2*KKK-1,2,K)*
     &                               LAMDA3(III,JJJ,KKK)
              B3MODE(1,K  ,N3MODE) = 0.0D0
              B3MODE(1,K+2,N3MODE) = 0.0D0
              B3MODE(1,K+4,N3MODE) = 0.0D0
              DO 71 J=1,2
              A3MODE(J,K  ,N3MODE) = AFG(J,2*III  ,K)
              A3MODE(J,K+2,N3MODE) = AFG(J,2*JJJ-1,K)
 71           A3MODE(J,K+4,N3MODE) = AFG(J,2*KKK-1,K)
            ELSE
              III = (IDKPRD(1,I)-6)/2
              JJJ = (IDKPRD(2,I)-5)/2
              KKK = (IDKPRD(3,I)-5)/2
              DO 72 K=1,2
              I3DRTP(K  ,N3MODE) = 14
              I3DRCF(K  ,N3MODE) = 1
              I3DRTP(K+2,N3MODE) = 15
              I3DRCF(K+2,N3MODE) = 2
              I3DRTP(K+4,N3MODE) = 16
              I3DRCF(K+4,N3MODE) = 3
              I3MODE(K  ,N3MODE) = 400+2*III+(K-1)*12
              I3MODE(K+2,N3MODE) = 399+2*JJJ+(K-1)*12
              I3MODE(K+4,N3MODE) = 399+2*KKK+(K-1)*12
              B3MODE(1,K  ,N3MODE) = QMIXSS(2*III,2,K)*
     &                               LAMDA3(III,JJJ,KKK)
              B3MODE(1,K+2,N3MODE) = QMIXSS(2*JJJ-1,2,K)*
     &                               LAMDA3(III,JJJ,KKK)
              B3MODE(1,K+4,N3MODE) = QMIXSS(2*KKK-1,2,K)*
     &                               LAMDA3(III,JJJ,KKK)
              B3MODE(2,K  ,N3MODE) = 0.0D0
              B3MODE(2,K+2,N3MODE) = 0.0D0
              B3MODE(2,K+4,N3MODE) = 0.0D0
              DO 72 J=1,2
              A3MODE(J,K  ,N3MODE) = AFG(O(J),2*III  ,K)
              A3MODE(J,K+2,N3MODE) = AFG(O(J),2*JJJ-1,K)
 72           A3MODE(J,K+4,N3MODE) = AFG(O(J),2*KKK-1,K)
            ENDIF
C--unrecognized decay issue warning
          ELSE
            CALL HWWARN('HWISP3',1)
          ENDIF
        ELSEIF(IDK(I).GE.450.AND.IDK(I).LE.453) THEN
          L1 = IDK(I)-449
C--neutralino modes next
          IF(L.GE.1.AND.L.LE.4.AND.(IDKPRD(2,I).LE.12.OR.
     &       (IDKPRD(2,I).GE.121.AND.IDKPRD(2,I).LE.132))) THEN
C--first the neutralino modes to fermion-antifermion neutralino
            IFR  = IDKPRD(2,I)
            J    = INT((IFR-1)/120)
            IFR  = IFR-6*INT((IFR-1)/6)+6*J
            IL   = IFR+4*J
            SIFR = IFR+18*J
            N3MODE = N3MODE+1
            IF(N3MODE.GT.NMODE3) THEN
              CALL HWWARN('HWISP3',109)
              GOTO 999
            ENDIF
            P3MODE(N3MODE) = ONE
            IF(IFR.LE.6) P3MODE(N3MODE)=THREE
            SPN3CF(1,1,N3MODE) = ONE
            N3NCFL(N3MODE) = 1
            ID3PRT(N3MODE) = I
            NME(I) = 10000+N3MODE
            NDI3BY(N3MODE) = 4
C--sfermion exchange diagrams
            DO 4 K=1,2
            I3DRTP(K  ,N3MODE) = 3
            I3DRCF(K  ,N3MODE) = 1
            I3DRTP(K+2,N3MODE) = 4
            I3DRCF(K+2,N3MODE) = 1
            I3MODE(K  ,N3MODE) = 12*(K-1)+400+SIFR
            I3MODE(K+2,N3MODE) = 12*(K-1)+406+SIFR
            DO 4 J=1,2
            A3MODE(J,K  ,N3MODE) = AFN(  J ,IFR,K,L1)
            B3MODE(J,K  ,N3MODE) = AFN(O(J),IFR,K,L )
            A3MODE(J,K+2,N3MODE) = ZSGNSS(L1)*AFN(O(J),IFR,K,L1)
 4          B3MODE(J,K+2,N3MODE) = ZSGNSS(L )*AFN(  J ,IFR,K,L )
C--now add higgs diagrams if third generation fermion, if Higgs off shell
            IF(IFR.EQ.5.OR.IFR.EQ.6.OR.IFR.EQ.11) THEN
              DO 5 J=1,3
                IF(RMASS(IDK(I)).LT.
     &                RMASS(203+J)+RMASS(IDKPRD(1,I))) THEN
                  NDI3BY(N3MODE) = NDI3BY(N3MODE)+1
                  I3DRTP(  NDI3BY(N3MODE),N3MODE) = 2
                  I3DRCF(  NDI3BY(N3MODE),N3MODE) = 1
                  I3MODE(  NDI3BY(N3MODE),N3MODE) = 203+J
                  DO 6 K=1,2
                  A3MODE(K,NDI3BY(N3MODE),N3MODE) = HNN(K,J,L,L1)
 6                B3MODE(K,NDI3BY(N3MODE),N3MODE) = HFF(K,J,IFR)
                ENDIF
 5            CONTINUE
            ENDIF
C-- and gauge boson diagrams if Z not on-shell
            IF(RMASS(IDK(I)).LT.MZ+RMASS(IDKPRD(1,I))) THEN
              NDI3BY(N3MODE) = NDI3BY(N3MODE)+1
              I3DRTP(NDI3BY(N3MODE),N3MODE) = 1
              I3DRCF(NDI3BY(N3MODE),N3MODE) = 1
              I3MODE(NDI3BY(N3MODE),N3MODE) = 200
              DO 7 J=1,2
 7            A3MODE(J,NDI3BY(N3MODE),N3MODE) =  OIJPP(J,L,L1)
              B3MODE(1,NDI3BY(N3MODE),N3MODE) = -E*RFCH(IL)
              B3MODE(2,NDI3BY(N3MODE),N3MODE) = -E*LFCH(IL)
            ENDIF
          ELSEIF(L.EQ.5.OR.L.EQ.6.AND.(IDKPRD(2,I).LE.12.OR.
     &       (IDKPRD(2,I).GE.121.AND.IDKPRD(2,I).LE.132))) THEN
C--then  the neutralino modes to fermion-antifermion +ve chargino
C--NB ISAJET ONLY HAS W EXCHANGE AND THEREFORE SO DO WE
            IF(RMASS(IDK(I)).GT.MW+RMASS(IDKPRD(1,I))) GOTO 2000
            L = L-4
            N3MODE = N3MODE+1
            IF(N3MODE.GT.NMODE3) THEN
              CALL HWWARN('HWISP3',110)
              GOTO 999
            ENDIF
            ID3PRT(N3MODE) = I
            NME(I) = 10000+N3MODE
            NDI3BY(N3MODE) = 1
            P3MODE(N3MODE) = ONE
            IF(IDKPRD(2,I).LE.12) P3MODE(N3MODE) = THREE
            SPN3CF(1,1,N3MODE) = ONE
            N3NCFL(N3MODE) = 1
C--gauge boson diagram
            I3DRTP(1,N3MODE) = 1
            I3DRCF(1,N3MODE) = 1
            I3MODE(1,N3MODE) = 199
            DO 8 J=1,2
 8          A3MODE(J,1,N3MODE) = OIJ(J,L1,L)
            B3MODE(1,1,N3MODE) = ZERO
            B3MODE(2,1,N3MODE) = -G*ORT
          ELSEIF(L.EQ.7.OR.L.EQ.8.AND.(IDKPRD(2,I).LE.12.OR.
     &       (IDKPRD(2,I).GE.121.AND.IDKPRD(2,I).LE.132))) THEN
C--then  the neutralino modes to fermion-antifermion -ve chargino
C--NB ISAJET ONLY HAS W EXCHANGE AND THEREFORE SO DO WE
            IF(RMASS(IDK(I)).GT.MW+RMASS(IDKPRD(1,I))) GOTO 2000
            L = L-6
            N3MODE = N3MODE+1
            IF(N3MODE.GT.NMODE3) THEN
              CALL HWWARN('HWISP3',111)
              GOTO 999
            ENDIF
            ID3PRT(N3MODE) = I
            NME(I) = 10000+N3MODE
            NDI3BY(N3MODE) = 1
            P3MODE(N3MODE) = ONE
            IF(IDKPRD(2,I).LE.12) P3MODE(N3MODE) = THREE
            SPN3CF(1,1,N3MODE) = ONE
            N3NCFL(N3MODE) = 1
C--gauge boson diagram
            I3DRTP(1,N3MODE) = 1
            I3DRCF(1,N3MODE) = 1
            I3MODE(1,N3MODE) = 198
            DO 9 J=1,2
 9          A3MODE(J,1,N3MODE) =-OIJ(O(J),L1,L)
            B3MODE(1,1,N3MODE) = ZERO
            B3MODE(2,1,N3MODE) = -G*ORT
C--gravitino E+e- modes
          ELSEIF(L.EQ.9.AND.(IDKPRD(2,I).LE.12.OR.
     &       (IDKPRD(2,I).GE.121.AND.IDKPRD(2,I).LE.132))) THEN
            IFR  = IDKPRD(2,I)
            J    = INT((IFR-1)/120)
            IFR  = IFR-6*INT((IFR-1)/6)+6*J
            IL   = IFR+4*J
            N3MODE = N3MODE+1
            IF(N3MODE.GT.NMODE3) THEN
              CALL HWWARN('HWISP3',112)
              GOTO 999
            ENDIF
            ID3PRT(N3MODE) = I
            NME(I) = 10000+N3MODE
            NDI3BY(N3MODE) = 1
            P3MODE(N3MODE) = ONE
            IF(IDKPRD(2,I).LE.12) P3MODE(N3MODE) = THREE
            SPN3CF(1,1,N3MODE) = ONE
            N3NCFL(N3MODE) = 1
C--diagram
            I3DRTP(1,N3MODE) = 7
            I3DRCF(1,N3MODE) = 1
            I3MODE(1,N3MODE) = 59
            A3MODE(1,1,N3MODE) = 2.0D0/SQRT(6.0D0)*ZMIXSS(L1,1)
            A3MODE(2,1,N3MODE) = 0
            B3MODE(1,1,N3MODE) = -E*QFCH(IL)
            B3MODE(2,1,N3MODE) = -E*QFCH(IL)
C--R-parity violating modes
C--LLE modes
          ELSEIF(IDKPRD(1,I).GE.121.AND.IDKPRD(1,I).LE.132.AND.
     &           IDKPRD(2,I).GE.121.AND.IDKPRD(2,I).LE.132.AND.
     &           IDKPRD(3,I).GE.121.AND.IDKPRD(3,I).LE.132) THEN
            N3MODE = N3MODE+1
            IF(N3MODE.GT.NMODE3) THEN
              CALL HWWARN('HWISP3',113)
              GOTO 999
            ENDIF
            ID3PRT(N3MODE) = I
            NME(I) = 10000+N3MODE
            NDI3BY(N3MODE) = 5
            P3MODE(N3MODE) = ONE
            SPN3CF(1,1,N3MODE) = ONE
            N3NCFL(N3MODE) = 1
C--particle mode
            DO 53 J=1,6
 53         I3DRCF(J,N3MODE) = 1
            IF(IDPDG(IDKPRD(1,I)).GT.0) THEN
              III = (IDKPRD(1,I)-119)/2
              JJJ = (IDKPRD(2,I)-120)/2
              KKK = (IDKPRD(3,I)-125)/2
              DO 51 J=1,2
              I3DRTP(J  ,N3MODE) = 2
              I3DRTP(J+2,N3MODE) = 4
              I3MODE(J  ,N3MODE) = 423+2*III+(J-1)*12
              I3MODE(J+2,N3MODE) = 423+2*KKK+(J-1)*12
              B3MODE(1,J  ,N3MODE) = LMIXSS(2*III-1,1,J)*
     &             LAMDA1(III,JJJ,KKK)
              B3MODE(2,J  ,N3MODE) = 0.0D0
              B3MODE(1,J+2,N3MODE) = LMIXSS(2*KKK-1,2,J)*
     &             LAMDA1(III,JJJ,KKK)
              B3MODE(2,J+2,N3MODE) = 0.0D0
              DO 51 K=1,2
              A3MODE(K,J  ,N3MODE) = AFN(  K ,5+2*III,J,L1)
 51           A3MODE(K,J+2,N3MODE) = AFN(O(K),5+2*KKK,J,L1)
              DO 48 K=1,2
 48           A3MODE(K,5,N3MODE) = AFN(  K ,6+2*JJJ,1,L1)
              I3DRTP(5,N3MODE) = 3
              I3MODE(5,N3MODE) = 430+2*JJJ
              B3MODE(1,5,N3MODE) = LAMDA1(III,JJJ,KKK)
              B3MODE(2,5,N3MODE) = 0.0D0
C--antiparticle mode
            ELSE
              III = (IDKPRD(1,I)-125)/2
              JJJ = (IDKPRD(2,I)-126)/2
              KKK = (IDKPRD(3,I)-119)/2
              DO 52 J=1,2
              I3DRTP(J  ,N3MODE) = 8
              I3DRTP(J+2,N3MODE) = 10
              I3MODE(J  ,N3MODE) = 423+2*III+(J-1)*12
              I3MODE(J+2,N3MODE) = 423+2*KKK+(J-1)*12
              B3MODE(2,J  ,N3MODE) = LMIXSS(2*III-1,1,J)*
     &             LAMDA1(III,JJJ,KKK)
              B3MODE(1,J  ,N3MODE) = 0.0D0
              B3MODE(2,J+2,N3MODE) = LMIXSS(2*KKK-1,2,J)*
     &             LAMDA1(III,JJJ,KKK)
              B3MODE(1,J+2,N3MODE) = 0.0D0
              DO 52 K=1,2
              A3MODE(K,J  ,N3MODE) = AFN(O(K),5+2*III,J,L1)
 52           A3MODE(K,J+2,N3MODE) = AFN(  K ,5+2*KKK,J,L1)
              DO 49 K=1,2
 49           A3MODE(K,5,N3MODE) = AFN(O(K),6+2*JJJ,1,L1)
              I3DRTP(5,N3MODE) = 9
              I3MODE(5,N3MODE) = 430+2*JJJ
              B3MODE(2,5,N3MODE) = LAMDA1(III,JJJ,KKK)
              B3MODE(1,5,N3MODE) = 0.0D0
            ENDIF
C--LQD modes
          ELSEIF(IDKPRD(1,I).GE.121.AND.IDKPRD(1,I).LE.132.AND.
     &           IDKPRD(2,I).LE.12 .AND.IDKPRD(3,I).LE.12) THEN
            N3MODE = N3MODE+1
            IF(N3MODE.GT.NMODE3) THEN
              CALL HWWARN('HWISP3',114)
              GOTO 999
            ENDIF
            ID3PRT(N3MODE) = I
            NME(I) = 10000+N3MODE
            P3MODE(N3MODE) = 3.0D0
            SPN3CF(1,1,N3MODE) = ONE
            N3NCFL(N3MODE) = 1
            DO 81 J=1,6
 81         I3DRCF(J,N3MODE) = 1
C--first the neutrino mode
            IF(MOD(IDKPRD(1,I),2).EQ.0) THEN
              NDI3BY(N3MODE) = 5
C--particle mode
              IF(IDPDG(IDKPRD(1,I)).GT.0) THEN
                III = (IDKPRD(1,I)-120)/2
                JJJ = (IDKPRD(2,I)+1)/2
                KKK = (IDKPRD(3,I)-5)/2
                DO 82 K=1,2
                I3DRTP(K  ,N3MODE) = 3
                I3DRTP(K+2,N3MODE) = 4
                I3MODE(K  ,N3MODE) = 399+2*JJJ+(K-1)*12
                I3MODE(K+2,N3MODE) = 399+2*KKK+(K-1)*12
                B3MODE(2,K  ,N3MODE) = 0.0D0
                B3MODE(1,K  ,N3MODE) = -QMIXSS(2*JJJ-1,1,K)*
     &                                 LAMDA2(III,JJJ,KKK)
                B3MODE(2,K+2,N3MODE) = 0.0D0
                B3MODE(1,K+2,N3MODE) = -QMIXSS(2*KKK-1,2,K)*
     &                                 LAMDA2(III,JJJ,KKK)
                DO 82 J=1,2
                A3MODE(J,K  ,N3MODE) = AFN(  J ,2*JJJ-1,K,L1)
 82             A3MODE(J,K+2,N3MODE) = AFN(O(J),2*KKK-1,K,L1)
                I3DRTP(5,N3MODE) = 2
                I3MODE(5,N3MODE) = 424+2*III
                B3MODE(2,5,N3MODE) = 0.0D0
                B3MODE(1,5,N3MODE) = -LAMDA2(III,JJJ,KKK)
                DO 83 J=1,2
 83             A3MODE(J,5,N3MODE) = AFN(J,6+2*III,1,L1)
C--antiparticle mode
              ELSE
                III = (IDKPRD(1,I)-126)/2
                JJJ = (IDKPRD(2,I)-5)/2
                KKK = (IDKPRD(3,I)+1)/2
                DO 84 K=1,2
                I3DRTP(K  ,N3MODE) = 9
                I3DRTP(K+2,N3MODE) = 10
                I3MODE(K  ,N3MODE) = 399+2*JJJ+(K-1)*12
                I3MODE(K+2,N3MODE) = 399+2*KKK+(K-1)*12
                B3MODE(1,K  ,N3MODE) = 0.0D0
                B3MODE(2,K  ,N3MODE) = -QMIXSS(2*JJJ-1,1,K)*
     &                                 LAMDA2(III,JJJ,KKK)
                B3MODE(1,K+2,N3MODE) = 0.0D0
                B3MODE(2,K+2,N3MODE) = -QMIXSS(2*KKK-1,2,K)*
     &                                 LAMDA2(III,JJJ,KKK)
                DO 84 J=1,2
                A3MODE(J,K  ,N3MODE) = AFN(O(J),2*JJJ-1,K,L1)
 84             A3MODE(J,K+2,N3MODE) = AFN(  J ,2*KKK-1,K,L1)
                I3DRTP(5,N3MODE) = 8
                I3MODE(5,N3MODE) = 424+2*III
                B3MODE(1,5,N3MODE) = 0.0D0
                B3MODE(2,5,N3MODE) = -LAMDA2(III,JJJ,KKK)
                DO 85 J=1,2
 85             A3MODE(J,5,N3MODE) = AFN(O(J),6+2*III,1,L1)
              ENDIF
C--then the charged lepton mode
            ELSE
              NDI3BY(N3MODE) = 6
C--particle mode
              IF(IDPDG(IDKPRD(1,I)).GT.0) THEN
                III = (IDKPRD(1,I)-119)/2
                JJJ = IDKPRD(2,I)/2
                KKK = (IDKPRD(3,I)-5)/2
                DO 86 K=1,2
                I3DRTP(K  ,N3MODE) = 2
                I3DRTP(K+2,N3MODE) = 3
                I3DRTP(K+4,N3MODE) = 4
                I3MODE(K  ,N3MODE) = 423+2*III+(K-1)*12
                I3MODE(K+2,N3MODE) = 400+2*JJJ+(K-1)*12
                I3MODE(K+4,N3MODE) = 399+2*KKK+(K-1)*12
                B3MODE(2,K  ,N3MODE) = 0.0D0
                B3MODE(1,K  ,N3MODE) = LMIXSS(2*III-1,1,K)*
     &                                 LAMDA2(III,JJJ,KKK)
                B3MODE(2,K+2,N3MODE) = 0.0D0
                B3MODE(1,K+2,N3MODE) = QMIXSS(2*JJJ,1,K)*
     &                                 LAMDA2(III,JJJ,KKK)
                B3MODE(2,K+4,N3MODE) = 0.0D0
                B3MODE(1,K+4,N3MODE) = QMIXSS(2*KKK-1,2,K)*
     &                                 LAMDA2(III,JJJ,KKK)
                DO 86 J=1,2
                A3MODE(J,K  ,N3MODE) = AFN(  J ,2*III+5,K,L1)
                A3MODE(J,K+2,N3MODE) = AFN(  J ,2*JJJ  ,K,L1)
 86             A3MODE(J,K+4,N3MODE) = AFN(O(J),2*KKK-1,K,L1)
C--antiparticle mode
              ELSE
                III = (IDKPRD(1,I)-125)/2
                JJJ = (IDKPRD(2,I)-6)/2
                KKK = (IDKPRD(3,I)+1)/2
                DO 87 K=1,2
                I3DRTP(K  ,N3MODE) = 8
                I3DRTP(K+2,N3MODE) = 9
                I3DRTP(K+4,N3MODE) = 10
                I3MODE(K  ,N3MODE) = 423+2*III+(K-1)*12
                I3MODE(K+2,N3MODE) = 400+2*JJJ+(K-1)*12
                I3MODE(K+4,N3MODE) = 399+2*KKK+(K-1)*12
                B3MODE(1,K  ,N3MODE) = 0.0D0
                B3MODE(2,K  ,N3MODE) = LMIXSS(2*III-1,1,K)*
     &                                 LAMDA2(III,JJJ,KKK)
                B3MODE(1,K+2,N3MODE) = 0.0D0
                B3MODE(2,K+2,N3MODE) = QMIXSS(2*JJJ,1,K)*
     &                                 LAMDA2(III,JJJ,KKK)
                B3MODE(1,K+4,N3MODE) = 0.0D0
                B3MODE(2,K+4,N3MODE) = QMIXSS(2*KKK-1,2,K)*
     &                                 LAMDA2(III,JJJ,KKK)
                DO 87 J=1,2
                A3MODE(J,K  ,N3MODE) = AFN(O(J),2*III+5,K,L1)
                A3MODE(J,K+2,N3MODE) = AFN(O(J),2*JJJ  ,K,L1)
 87             A3MODE(J,K+4,N3MODE) = AFN(  J ,2*KKK-1,K,L1)
              ENDIF
            ENDIF
C--UDD modes
          ELSEIF(IDKPRD(1,I).LE.12.AND.IDKPRD(2,I).LE.12.AND.
     &           IDKPRD(3,I).LE.12) THEN
            N3MODE = N3MODE+1
            IF(N3MODE.GT.NMODE3) THEN
              CALL HWWARN('HWISP3',115)
              GOTO 999
            ENDIF
            ID3PRT(N3MODE) = I
            NME(I) = 10000+N3MODE
            NDI3BY(N3MODE) = 6
            P3MODE(N3MODE) = 6.0D0
            SPN3CF(1,1,N3MODE) = ONE
            N3NCFL(N3MODE) = 1
            DO 61 J=1,6
 61         I3DRCF(J,N3MODE) = 1
C--particle mode
            IF(IDPDG(IDKPRD(1,I)).GT.0) THEN
              III = IDKPRD(1,I)/2
              JJJ = (IDKPRD(2,I)+1)/2
              KKK = (IDKPRD(3,I)+1)/2
              DO 62 J=1,2
              I3DRTP(J  ,N3MODE) = 11
              I3DRTP(J+2,N3MODE) = 12
              I3DRTP(J+4,N3MODE) = 13
              I3MODE(J  ,N3MODE) = 400+2*III+(J-1)*12
              I3MODE(J+2,N3MODE) = 399+2*JJJ+(J-1)*12
              I3MODE(J+4,N3MODE) = 399+2*KKK+(J-1)*12
              B3MODE(2,J  ,N3MODE) = QMIXSS(2*III,2,J)*
     &                               LAMDA3(III,JJJ,KKK)
              B3MODE(2,J+2,N3MODE) = QMIXSS(2*JJJ-1,2,J)*
     &                               LAMDA3(III,JJJ,KKK)
              B3MODE(2,J+4,N3MODE) = QMIXSS(2*KKK-1,2,J)*
     &                               LAMDA3(III,JJJ,KKK)
              B3MODE(1,J  ,N3MODE) = 0.0D0
              B3MODE(1,J+2,N3MODE) = 0.0D0
              B3MODE(1,J+4,N3MODE) = 0.0D0
              DO 62 K=1,2
              A3MODE(K,J  ,N3MODE) = AFN(K,2*III  ,J,L1)
              A3MODE(K,J+2,N3MODE) = AFN(K,2*JJJ-1,J,L1)
 62           A3MODE(K,J+4,N3MODE) = AFN(K,2*KKK-1,J,L1)
C--antiparticle mode
            ELSE
              III = (IDKPRD(1,I)-6)/2
              JJJ = (IDKPRD(2,I)-5)/2
              KKK = (IDKPRD(3,I)-5)/2
              DO 63 J=1,2
              I3DRTP(J  ,N3MODE) = 14
              I3DRTP(J+2,N3MODE) = 15
              I3DRTP(J+4,N3MODE) = 16
              I3MODE(J  ,N3MODE) = 400+2*III+(J-1)*12
              I3MODE(J+2,N3MODE) = 399+2*JJJ+(J-1)*12
              I3MODE(J+4,N3MODE) = 399+2*KKK+(J-1)*12
              B3MODE(2,J  ,N3MODE) = 0.0D0
              B3MODE(2,J+2,N3MODE) = 0.0D0
              B3MODE(2,J+4,N3MODE) = 0.0D0
              B3MODE(1,J  ,N3MODE) = QMIXSS(2*III,2,J)*
     &                               LAMDA3(III,JJJ,KKK)
              B3MODE(1,J+2,N3MODE) = QMIXSS(2*JJJ-1,2,J)*
     &                               LAMDA3(III,JJJ,KKK)
              B3MODE(1,J+4,N3MODE) = QMIXSS(2*KKK-1,2,J)*
     &                               LAMDA3(III,JJJ,KKK)
              DO 63 K=1,2
              A3MODE(K,J  ,N3MODE) = AFN(O(K),2*III  ,J,L1)
              A3MODE(K,J+2,N3MODE) = AFN(O(K),2*JJJ-1,J,L1)
 63           A3MODE(K,J+4,N3MODE) = AFN(O(K),2*KKK-1,J,L1)
            ENDIF
C--unrecognized decay issue warning
          ELSE
            CALL HWWARN('HWISP3',2)
          ENDIF
        ELSEIF(IDK(I).GE.454.AND.IDK(I).LE.455) THEN
C--+ve chargino modes
C--first the chargino modes to fermion-antifermion neutralino
          IF(L.GE.1.AND.L.LE.4.AND.(IDKPRD(2,I).LE.12.OR.
     &       (IDKPRD(2,I).GE.121.AND.IDKPRD(2,I).LE.132))) THEN
            IFR = IDKPRD(2,I)
            IFR = IFR+MOD(IFR,2)
            J    = INT((IFR-1)/120)
            IFR  = IFR-6*INT((IFR-1)/6)+6*J
            IL   = IFR+4*J
            SIFR = IFR+18*J
            L1 = IDK(I)-453
            N3MODE = N3MODE+1
            IF(N3MODE.GT.NMODE3) THEN
              CALL HWWARN('HWISP3',116)
              GOTO 999
            ENDIF
            ID3PRT(N3MODE) = I
            NME(I) = 10000+N3MODE
            NDI3BY(N3MODE) = 4
            P3MODE(N3MODE) = ONE
            IF(IDKPRD(2,I).LE.12) P3MODE(N3MODE) = THREE
            SPN3CF(1,1,N3MODE) = ONE
            N3NCFL(N3MODE) = 1
C--sfermion exchange diagrams
            DO 10 K=1,2
            I3DRTP(K  ,N3MODE) = 3
            I3DRCF(K  ,N3MODE) = 1
            I3DRTP(K+2,N3MODE) = 4
            I3DRCF(K+2,N3MODE) = 1
            I3MODE(K  ,N3MODE) = 12*(K-1)+405+SIFR
            I3MODE(K+2,N3MODE) = 12*(K-1)+400+SIFR
            DO 10 J=1,2
            A3MODE(J,K  ,N3MODE) = AFC(  J ,IFR-1,K,L1)
            B3MODE(J,K  ,N3MODE) = AFN(O(J),IFR-1,K,L )
            A3MODE(J,K+2,N3MODE) = AFC(O(J),IFR  ,K,L1)
 10         B3MODE(J,K+2,N3MODE) = AFN(  J ,IFR  ,K,L )
C--gauge boson diagram
            IF(RMASS(IDK(I)).LT.MW+RMASS(IDKPRD(1,I))) THEN
              NDI3BY(N3MODE) = NDI3BY(N3MODE)+1
              I3DRTP(NDI3BY(N3MODE),N3MODE) = 1
              I3DRCF(NDI3BY(N3MODE),N3MODE) = 1
              I3MODE(NDI3BY(N3MODE),N3MODE) = 198
              DO 11 J=1,2
 11           A3MODE(J,NDI3BY(N3MODE),N3MODE) = OIJ(J,L,L1)
              B3MODE(1,NDI3BY(N3MODE),N3MODE) = ZERO
              B3MODE(2,NDI3BY(N3MODE),N3MODE) = -G*ORT
            ENDIF
C--then  the chargino modes to fermion-antifermion chargino
          ELSEIF(L.GE.5.AND.L.LE.8.AND.(IDKPRD(2,I).LE.12.OR.
     &       (IDKPRD(2,I).GE.121.AND.IDKPRD(2,I).LE.132))) THEN
            L = L-4
            IFR = IDKPRD(2,I)
            J    = INT((IFR-1)/120)
            IFR  = IFR-6*INT((IFR-1)/6)+6*J
            IL   = IFR+4*J
            SIFR = IFR+18*J
            IF(MOD(IFR,2).EQ.0) THEN
              IFR = IFR-1
              SIFR = SIFR-1
            ELSE
              IFR = IFR+1
              SIFR = SIFR+1
            ENDIF
            L1 = IDK(I)-453
            N3MODE = N3MODE+1
            IF(N3MODE.GT.NMODE3) THEN
              CALL HWWARN('HWISP3',117)
              GOTO 999
            ENDIF
            ID3PRT(N3MODE) = I
            NME(I) = 10000+N3MODE
            NDI3BY(N3MODE) = 2
            P3MODE(N3MODE) = ONE
            IF(IDKPRD(2,I).LE.12) P3MODE(N3MODE) = THREE
            SPN3CF(1,1,N3MODE) = ONE
            N3NCFL(N3MODE) = 1
C--sfermion exchange diagrams
            IF(MOD(IL,2).EQ.0) THEN
              DO 12 K=1,2
              I3DRTP(K,N3MODE) = 3
              I3DRCF(K,N3MODE) = 1
              I3MODE(K,N3MODE) = 12*(K-1)+400+SIFR
              DO 12 J=1,2
              A3MODE(J,K,N3MODE) = AFC(  J ,IFR,K,L1)
 12           B3MODE(J,K,N3MODE) = AFC(O(J),IFR,K,L )
            ELSE
              DO 13 K=1,2
              I3DRTP(K,N3MODE) = 4
              I3DRCF(K,N3MODE) = 1
              I3MODE(K,N3MODE) = 12*(K-1)+400+SIFR
              DO 13 J=1,2
              A3MODE(J,K,N3MODE) = AFC(O(J),IFR,K,L1)
 13           B3MODE(J,K,N3MODE) = AFC(  J ,IFR,K,L )
            ENDIF
C--gauge boson diagram
            IF(RMASS(IDK(I)).LT.MZ+RMASS(IDKPRD(1,I))) THEN
              NDI3BY(N3MODE) = NDI3BY(N3MODE)+1
              I3DRTP(NDI3BY(N3MODE),N3MODE) = 1
              I3DRCF(NDI3BY(N3MODE),N3MODE) = 1
              I3MODE(NDI3BY(N3MODE),N3MODE) = 200
              DO 14 J=1,2
 14           A3MODE(J,NDI3BY(N3MODE),N3MODE) = OIJP(J,L,L1)
              B3MODE(1,NDI3BY(N3MODE),N3MODE) = -E*RFCH(IL)
              B3MODE(2,NDI3BY(N3MODE),N3MODE) = -E*LFCH(IL)
            ENDIF
C--R-parity violating decays
C--LLE first
          ELSEIF(IDKPRD(1,I).GE.121.AND.IDKPRD(1,I).LE.132.AND.
     &           IDKPRD(2,I).GE.121.AND.IDKPRD(2,I).LE.132.AND.
     &           IDKPRD(1,I).GE.121.AND.IDKPRD(3,I).LE.132) THEN
            L1 = IDK(I)-453
C--neutrino lepton neutrino
            IF(MOD(IDKPRD(1,I),2).EQ.0.AND.MOD(IDKPRD(2,I),2).EQ.1.AND.
     &         MOD(IDKPRD(3,I),2).EQ.0) THEN
              N3MODE = N3MODE+1
              IF(N3MODE.GT.NMODE3) THEN
                CALL HWWARN('HWISP3',118)
                GOTO 999
              ENDIF
              ID3PRT(N3MODE) = I
              NME(I) = 10000+N3MODE
              NDI3BY(N3MODE) = 2
              P3MODE(N3MODE) = ONE
              N3NCFL(N3MODE) = 1
              SPN3CF(1,1,N3MODE) = ONE
              III = (IDKPRD(1,I)-126)/2
              JJJ = (IDKPRD(2,I)-125)/2
              KKK = (IDKPRD(3,I)-120)/2
              DO 54 K=1,2
              I3DRTP(K,N3MODE) = 10
              I3DRCF(K,N3MODE) = 1
              I3MODE(K,N3MODE) = 423+2*KKK+12*(K-1)
              B3MODE(1,K,N3MODE) = 0.0D0
              B3MODE(2,K,N3MODE)=LAMDA1(III,JJJ,KKK)*LMIXSS(2*KKK-1,2,K)
              DO 54 J=1,2
 54           A3MODE(J,K,N3MODE) = AFC(J,5+2*KKK,K,L1)
C--neutrino neutrino lepton
            ELSEIF(MOD(IDKPRD(1,I),2).EQ.0.AND.MOD(IDKPRD(2,I),2).EQ.0
     &             .AND.MOD(IDKPRD(3,I),2).EQ.1) THEN
              N3MODE = N3MODE+1
              IF(N3MODE.GT.NMODE3) THEN
                CALL HWWARN('HWISP3',119)
                GOTO 999
              ENDIF
              ID3PRT(N3MODE) = I
              NME(I) = 10000+N3MODE
              NDI3BY(N3MODE) = 4
              P3MODE(N3MODE) = ONE
              N3NCFL(N3MODE) = 1
              SPN3CF(1,1,N3MODE) = ONE
              III = (IDKPRD(1,I)-120)/2
              JJJ = (IDKPRD(2,I)-120)/2
              KKK = (IDKPRD(3,I)-125)/2
              DO 55 K=1,2
              I3DRTP(K  ,N3MODE) = 2
              I3DRTP(K+2,N3MODE) = 3
              I3DRCF(K  ,N3MODE) = 1
              I3DRCF(K+2,N3MODE) = 1
              I3MODE(K  ,N3MODE) = 423+2*III+12*(K-1)
              I3MODE(K+2,N3MODE) = 423+2*JJJ+12*(K-1)
              B3MODE(1,K,N3MODE) = LAMDA1(III,JJJ,KKK)*
     &             LMIXSS(2*III-1,1,K)
              B3MODE(2,K,N3MODE) = 0.0D0
              B3MODE(1,K+2,N3MODE) =-LAMDA1(III,JJJ,KKK)*
     &             LMIXSS(2*JJJ-1,1,K)
              B3MODE(2,K+2,N3MODE) = 0.0D0
              DO 55 J=1,2
              A3MODE(J,K,N3MODE)   = AFC(J,5+2*III,K,L1)
 55           A3MODE(J,K+2,N3MODE) = AFC(J,5+2*JJJ,K,L1)
C--lepton lepton lepton
            ELSEIF(MOD(IDKPRD(1,I),2).EQ.1.AND.MOD(IDKPRD(2,I),2).EQ.1
     &             .AND.MOD(IDKPRD(3,I),2).EQ.1) THEN
              N3MODE = N3MODE+1
              IF(N3MODE.GT.NMODE3) THEN
                CALL HWWARN('HWISP3',120)
                GOTO 999
              ENDIF
              ID3PRT(N3MODE) = I
              NME(I) = 10000+N3MODE
              NDI3BY(N3MODE) = 2
              P3MODE(N3MODE) = ONE
              N3NCFL(N3MODE) = 1
              SPN3CF(1,1,N3MODE) = ONE
              III = (IDKPRD(1,I)-125)/2
              JJJ = (IDKPRD(2,I)-125)/2
              KKK = (IDKPRD(3,I)-119)/2
              I3DRTP(1,N3MODE) = 8
              I3DRTP(2,N3MODE) = 9
              I3DRCF(1,N3MODE) = 1
              I3DRCF(2,N3MODE) = 1
              I3MODE(1,N3MODE) = 424+2*III
              I3MODE(2,N3MODE) = 424+2*JJJ
              B3MODE(1,1,N3MODE) = 0.0D0
              B3MODE(2,1,N3MODE) = LAMDA1(III,JJJ,KKK)
              B3MODE(1,2,N3MODE) = 0.0D0
              B3MODE(2,2,N3MODE) =-LAMDA1(III,JJJ,KKK)
              DO 56 J=1,2
              A3MODE(J,1,N3MODE) = AFC(O(J),6+2*III,1,L1)
 56           A3MODE(J,2,N3MODE) = AFC(O(J),6+2*JJJ,1,L1)
            ELSE
              CALL HWWARN('HWISP3',3)
            ENDIF
C--LQD decays
          ELSEIF(IDKPRD(1,I).GE.121.AND.IDKPRD(1,I).LE.132.AND.
     &           IDKPRD(2,I).LE.12 .AND.IDKPRD(3,I).LE. 12) THEN
            L1 = IDK(I)-453
C--nubar dbar u
            IF(IDKPRD(1,I).GE.128.AND.MOD(IDKPRD(1,I),2).EQ.0) THEN
              N3MODE = N3MODE+1
              IF(N3MODE.GT.NMODE3) THEN
                CALL HWWARN('HWISP3',121)
                GOTO 999
              ENDIF
              ID3PRT(N3MODE) = I
              NME(I) = 10000+N3MODE
              NDI3BY(N3MODE) = 2
              P3MODE(N3MODE) = THREE
              N3NCFL(N3MODE) = 1
              SPN3CF(1,1,N3MODE) = ONE
              III = (IDKPRD(1,I)-126)/2
              JJJ = (IDKPRD(2,I)-5)/2
              KKK = IDKPRD(3,I)/2
              DO 88 K=1,2
              I3DRTP(K,N3MODE) = 10
              I3DRCF(K,N3MODE) = 1
              I3MODE(K,N3MODE) = 399+2*KKK+12*(K-1)
              B3MODE(1,K,N3MODE) = 0.0D0
              B3MODE(2,K,N3MODE) = QMIXSS(2*KKK-1,2,K)*
     &                             LAMDA2(III,JJJ,KKK)
              DO 88 J=1,2
 88           A3MODE(J,K,N3MODE) = AFC(J,2*KKK-1,K,L1)
C--l+ ubar u
            ELSEIF(IDKPRD(1,I).GE.127.AND.MOD(IDKPRD(1,I),2).EQ.1.AND.
     &             MOD(IDKPRD(2,I),2).EQ.0) THEN
              N3MODE = N3MODE+1
              IF(N3MODE.GT.NMODE3) THEN
                CALL HWWARN('HWISP3',122)
                GOTO 999
              ENDIF
              ID3PRT(N3MODE) = I
              NME(I) = 10000+N3MODE
              NDI3BY(N3MODE) = 2
              P3MODE(N3MODE) = THREE
              N3NCFL(N3MODE) = 1
              SPN3CF(1,1,N3MODE) = ONE
              III = (IDKPRD(1,I)-125)/2
              JJJ = (IDKPRD(2,I)-6)/2
              KKK = IDKPRD(3,I)/2
              DO 89 K=1,2
              I3DRTP(K,N3MODE) = 10
              I3DRCF(K,N3MODE) = 1
              I3MODE(K,N3MODE) = 399+2*KKK+12*(K-1)
              B3MODE(1,K,N3MODE) = 0.0D0
              B3MODE(2,K,N3MODE) = QMIXSS(2*KKK-1,2,K)*
     &                             LAMDA2(III,JJJ,KKK)
              DO 89 J=1,2
 89           A3MODE(J,K,N3MODE) = AFC(J,2*KKK-1,K,L1)
C--l+ dbar d
            ELSEIF(IDKPRD(1,I).GE.127.AND.MOD(IDKPRD(1,I),2).EQ.1.AND.
     &             MOD(IDKPRD(2,I),2).EQ.1) THEN
              N3MODE = N3MODE+1
              IF(N3MODE.GT.NMODE3) THEN
                CALL HWWARN('HWISP3',123)
                GOTO 999
              ENDIF
              ID3PRT(N3MODE) = I
              NME(I) = 10000+N3MODE
              NDI3BY(N3MODE) = 3
              P3MODE(N3MODE) = THREE
              N3NCFL(N3MODE) = 1
              SPN3CF(1,1,N3MODE) = ONE
              III = (IDKPRD(1,I)-125)/2
              JJJ = (IDKPRD(2,I)-5)/2
              KKK = (IDKPRD(3,I)+1)/2
              I3DRTP(1,N3MODE) = 8
              I3DRCF(1,N3MODE) = 1
              I3MODE(1,N3MODE) = 424+2*III
              B3MODE(1,1,N3MODE) = 0.0D0
              B3MODE(2,1,N3MODE) = -LAMDA2(III,JJJ,KKK)
              DO 91 J=1,2
 91           A3MODE(J,1,N3MODE) = AFC(O(J),2*III+6,1,L1)
              DO 92 K=1,2
              I3DRTP(K+1,N3MODE) = 9
              I3DRCF(K+1,N3MODE) = 1
              I3MODE(K+1,N3MODE) = 400+2*JJJ+12*(K-1)
              B3MODE(1,K+1,N3MODE) = 0.0D0
              B3MODE(2,K+1,N3MODE) = QMIXSS(2*JJJ,1,K)*
     &                               LAMDA2(III,JJJ,KKK)
              DO 92 J=1,2
 92           A3MODE(J,K+1,N3MODE) = AFC(O(J),2*JJJ,K,L1)
C--nu u dbar
            ELSEIF(IDKPRD(1,I).LE.126.AND.MOD(IDKPRD(1,I),2).EQ.0) THEN
              N3MODE = N3MODE+1
              IF(N3MODE.GT.NMODE3) THEN
                CALL HWWARN('HWISP3',124)
                GOTO 999
              ENDIF
              ID3PRT(N3MODE) = I
              NME(I) = 10000+N3MODE
              NDI3BY(N3MODE) = 4
              P3MODE(N3MODE) = THREE
              N3NCFL(N3MODE) = 1
              SPN3CF(1,1,N3MODE) = ONE
              III = (IDKPRD(1,I)-120)/2
              JJJ = IDKPRD(2,I)/2
              KKK = (IDKPRD(3,I)-5)/2
              DO 90 K=1,2
              I3DRTP(K  ,N3MODE) = 2
              I3DRTP(K+2,N3MODE) = 3
              I3DRCF(K  ,N3MODE) = 1
              I3DRCF(K+2,N3MODE) = 1
              I3MODE(K  ,N3MODE) = 423+2*III+12*(K-1)
              I3MODE(K+2,N3MODE) = 399+2*JJJ+12*(K-1)
              B3MODE(1,K  ,N3MODE) = LMIXSS(2*III-1,1,K)*
     &                               LAMDA2(III,JJJ,KKK)
              B3MODE(2,K  ,N3MODE) = 0.0D0
              B3MODE(1,K+2,N3MODE) = -QMIXSS(2*JJJ-1,1,K)*
     &                               LAMDA2(III,JJJ,KKK)
              B3MODE(2,K+2,N3MODE) = 0.0D0
              DO 90 J=1,2
              A3MODE(J,K  ,N3MODE) = AFC(J,2*III+5,K,L1)
 90           A3MODE(J,K+2,N3MODE) = AFC(J,2*JJJ-1,K,L1)
C--unrecognised
            ELSE
              CALL HWWARN('HWISP3',4)
            ENDIF
C--UDD decays
          ELSEIF(IDKPRD(1,I).LE.12.AND.IDKPRD(2,I).LE.12.AND.
     &           IDKPRD(3,I).LE.12) THEN
             L1 = IDK(I)-453
C--dbar dbar dbar mode
            IF(MOD(IDKPRD(1,I),2).EQ.1.AND.MOD(IDKPRD(2,I),2).EQ.1.AND.
     &         MOD(IDKPRD(3,I),2).EQ.1) THEN
              N3MODE = N3MODE+1
              IF(N3MODE.GT.NMODE3) THEN
                CALL HWWARN('HWISP3',125)
                GOTO 999
              ENDIF
              ID3PRT(N3MODE) = I
              NME(I) = 10000+N3MODE
              NDI3BY(N3MODE) = 6
              N3NCFL(N3MODE) = 1
              SPN3CF(1,1,N3MODE) = ONE
              III = (IDKPRD(1,I)-5)/2
              JJJ = (IDKPRD(2,I)-5)/2
              KKK = (IDKPRD(3,I)-5)/2
              P3MODE(N3MODE) = ONE
              IF(III.EQ.JJJ) P3MODE(N3MODE) = P3MODE(N3MODE)+ONE
              IF(JJJ.EQ.KKK) P3MODE(N3MODE) = P3MODE(N3MODE)+ONE
              IF(III.EQ.KKK) P3MODE(N3MODE) = P3MODE(N3MODE)+ONE
              P3MODE(N3MODE) = 6.0D0/P3MODE(N3MODE)
              DO 66 K=1,6
 66           I3DRCF(K,N3MODE) = 1
              DO 65 K=1,2
              I3DRTP(K  ,N3MODE) = 14
              I3DRTP(K+2,N3MODE) = 15
              I3DRTP(K+4,N3MODE) = 16
              I3MODE(K  ,N3MODE) = 400+2*III+(K-1)*12
              I3MODE(K+2,N3MODE) = 400+2*JJJ+(K-1)*12
              I3MODE(K+4,N3MODE) = 400+2*KKK+(K-1)*12
              B3MODE(1,K  ,N3MODE) = QMIXSS(2*III,2,K)*
     &                               LAMDA3(III,JJJ,KKK)
              B3MODE(2,K  ,N3MODE) = 0.0D0
              B3MODE(1,K+2,N3MODE) =-QMIXSS(2*JJJ,2,K)*
     &                               LAMDA3(JJJ,III,KKK)
              B3MODE(2,K+2,N3MODE) = 0.0D0
              B3MODE(1,K+4,N3MODE) = QMIXSS(2*KKK,2,K)*
     &                               LAMDA3(KKK,III,JJJ)
              B3MODE(2,K+4,N3MODE) = 0.0D0
              DO 65 J=1,2
              A3MODE(J,K  ,N3MODE) = AFC(O(J),2*III,K,L1)
              A3MODE(J,K+2,N3MODE) = AFC(O(J),2*JJJ,K,L1)
 65           A3MODE(J,K+4,N3MODE) = AFC(O(J),2*KKK,K,L1)
C--u u d mode
            ELSEIF(MOD(IDKPRD(1,I),2).EQ.0.AND.MOD(IDKPRD(2,I),2).EQ.0
     &              .AND.MOD(IDKPRD(3,I),2).EQ.1) THEN
              N3MODE = N3MODE+1
              IF(N3MODE.GT.NMODE3) THEN
                CALL HWWARN('HWISP3',126)
                GOTO 999
              ENDIF
              ID3PRT(N3MODE) = I
              NME(I) = 10000+N3MODE
              NDI3BY(N3MODE) = 4
              P3MODE(N3MODE) = 6.0D0
              N3NCFL(N3MODE) = 1
              SPN3CF(1,1,N3MODE) = ONE
              III = IDKPRD(1,I)/2
              JJJ = IDKPRD(2,I)/2
              KKK = (IDKPRD(3,I)+1)/2
              IF(III.EQ.JJJ) P3MODE(N3MODE) = HALF*P3MODE(N3MODE)
              DO 64 K=1,2
              I3DRTP(K  ,N3MODE) = 11
              I3DRTP(K+2,N3MODE) = 12
              I3DRCF(K  ,N3MODE) = 1
              I3DRCF(K+2,N3MODE) = 1
              I3MODE(K  ,N3MODE) = 399+2*III+(K-1)*12
              I3MODE(K+2,N3MODE) = 399+2*JJJ+(K-1)*12
              B3MODE(1,K  ,N3MODE) = 0.0D0
              B3MODE(2,K  ,N3MODE) = QMIXSS(2*III-1,2,K)*
     &                               LAMDA3(JJJ,III,KKK)
c              B3MODE(2,K,N3MODE) = 0.0D0
              B3MODE(1,K+2,N3MODE) = 0.0D0
              B3MODE(2,K+2,N3MODE) =-QMIXSS(2*JJJ-1,2,K)*
     &                               LAMDA3(III,JJJ,KKK)
              DO 64 J=1,2
              A3MODE(J,K  ,N3MODE) = AFC(J,2*III-1,K,L1)
 64           A3MODE(J,K+2,N3MODE) = AFC(J,2*JJJ-1,K,L1)
C--unrecognized decay issue warning
            ELSE
              CALL HWWARN('HWISP3',5)
            ENDIF
C--unrecognized decay issue warning
          ELSE
            CALL HWWARN('HWISP3',6)
          ENDIF
        ELSEIF(IDK(I).GE.456.AND.IDK(I).LE.457) THEN
C-- -ve chargino modes last
C--first the chargino modes to fermion-antifermion neutralino
          IF(L.GE.1.AND.L.LE.4.AND.(IDKPRD(2,I).LE.12.OR.
     &       (IDKPRD(2,I).GE.121.AND.IDKPRD(2,I).LE.132))) THEN
            IFR = IDKPRD(2,I)
            IFR = IFR+MOD(IFR,2)
            J    = INT((IFR-1)/120)
            IFR  = IFR-6*INT((IFR-1)/6)+6*J
            IL   = IFR+4*J
            SIFR = IFR+18*J
            L1 = IDK(I)-455
            N3MODE = N3MODE+1
            IF(N3MODE.GT.NMODE3) THEN
              CALL HWWARN('HWISP3',127)
              GOTO 999
            ENDIF
            ID3PRT(N3MODE) = I
            NME(I) = 10000+N3MODE
            NDI3BY(N3MODE) = 4
            P3MODE(N3MODE) = ONE
            IF(IDKPRD(2,I).LE.12) P3MODE(N3MODE) = THREE
            SPN3CF(1,1,N3MODE) = ONE
            N3NCFL(N3MODE) = 1
C--sfermion exchange diagrams
            DO 15 K=1,2
            I3DRTP(K  ,N3MODE) = 3
            I3DRCF(K  ,N3MODE) = 1
            I3DRTP(K+2,N3MODE) = 4
            I3DRCF(K+2,N3MODE) = 1
            I3MODE(K  ,N3MODE) = 12*(K-1)+406+SIFR
            I3MODE(K+2,N3MODE) = 12*(K-1)+399+SIFR
            DO 15 J=1,2
            A3MODE(J,K  ,N3MODE) = AFC(  J ,IFR  ,K,L1)
            B3MODE(J,K  ,N3MODE) = AFN(O(J),IFR  ,K,L )
            A3MODE(J,K+2,N3MODE) = AFC(O(J),IFR-1,K,L1)
 15         B3MODE(J,K+2,N3MODE) = AFN(  J ,IFR-1,K,L )
C--gauge boson diagram
            IF(RMASS(IDK(I)).LT.MW+RMASS(IDKPRD(1,I))) THEN
              NDI3BY(N3MODE) = NDI3BY(N3MODE)+1
              I3DRTP(NDI3BY(N3MODE),N3MODE) = 1
              I3DRCF(NDI3BY(N3MODE),N3MODE) = 1
              I3MODE(NDI3BY(N3MODE),N3MODE) = 199
              DO 16 J=1,2
 16           A3MODE(J,NDI3BY(N3MODE),N3MODE) =-OIJ(O(J),L,L1)
              B3MODE(1,NDI3BY(N3MODE),N3MODE) = ZERO
              B3MODE(2,NDI3BY(N3MODE),N3MODE) = -G*ORT
            ENDIF
C--then  the chargino modes to fermion-antifermion chargino
          ELSEIF(L.GE.5.AND.L.LE.8.AND.(IDKPRD(2,I).LE.12.OR.
     &       (IDKPRD(2,I).GE.121.AND.IDKPRD(2,I).LE.132))) THEN
            L = L-6
            IFR = IDKPRD(2,I)
            J    = INT((IFR-1)/120)
            IFR  = IFR-6*INT((IFR-1)/6)+6*J
            IL   = IFR+4*J
            SIFR = IFR+18*J
            IF(MOD(IFR,2).EQ.0) THEN
              IFR = IFR-1
              SIFR = SIFR-1
            ELSE
              IFR = IFR+1
              SIFR = SIFR+1
            ENDIF
            L1 = IDK(I)-455
            N3MODE = N3MODE+1
            IF(N3MODE.GT.NMODE3) THEN
              CALL HWWARN('HWISP3',128)
              GOTO 999
            ENDIF
            ID3PRT(N3MODE) = I
            NME(I) = 10000+N3MODE
            NDI3BY(N3MODE) = 2
            P3MODE(N3MODE) = ONE
            IF(IDKPRD(2,I).LE.12) P3MODE(N3MODE) = THREE
            SPN3CF(1,1,N3MODE) = ONE
            N3NCFL(N3MODE) = 1
C--sfermion exchange diagrams
            IF(MOD(IL,2).EQ.0) THEN
              DO 17 K=1,2
              I3DRTP(K,N3MODE) = 4
              I3DRCF(K,N3MODE) = 1
              I3MODE(K,N3MODE) = 12*(K-1)+400+SIFR
              DO 17 J=1,2
              A3MODE(J,K,N3MODE) = AFC(O(J),IFR,K,L1)
 17           B3MODE(J,K,N3MODE) = AFC(  J ,IFR,K,L )
            ELSE
              DO 18 K=1,2
              I3DRTP(K,N3MODE) = 3
              I3DRCF(K,N3MODE) = 1
              I3MODE(K,N3MODE) = 12*(K-1)+400+SIFR
              DO 18 J=1,2
              A3MODE(J,K,N3MODE) = AFC(  J ,IFR,K,L1)
 18           B3MODE(J,K,N3MODE) = AFC(O(J),IFR,K,L )
            ENDIF
C--gauge boson diagram
            IF(RMASS(IDK(I)).LT.MZ+RMASS(IDKPRD(1,I))) THEN
              NDI3BY(N3MODE) = NDI3BY(N3MODE)+1
              I3DRTP(NDI3BY(N3MODE),N3MODE) = 1
              I3DRCF(NDI3BY(N3MODE),N3MODE) = 1
              I3MODE(NDI3BY(N3MODE),N3MODE) = 200
              DO 19 J=1,2
 19           A3MODE(J,NDI3BY(N3MODE),N3MODE) =-OIJP(O(J),L,L1)
              B3MODE(1,NDI3BY(N3MODE),N3MODE) = -E*RFCH(IL)
              B3MODE(2,NDI3BY(N3MODE),N3MODE) = -E*LFCH(IL)
            ENDIF
C--R-parity violating decays
C--LLE first
          ELSEIF(IDKPRD(1,I).GE.121.AND.IDKPRD(1,I).LE.132.AND.
     &           IDKPRD(2,I).GE.121.AND.IDKPRD(2,I).LE.132.AND.
     &           IDKPRD(1,I).GE.121.AND.IDKPRD(3,I).LE.132) THEN
             L1 = IDK(I)-455
C--neutrino lepton neutrino
            IF(MOD(IDKPRD(1,I),2).EQ.0.AND.MOD(IDKPRD(2,I),2).EQ.1.AND.
     &         MOD(IDKPRD(3,I),2).EQ.0) THEN
              N3MODE = N3MODE+1
              IF(N3MODE.GT.NMODE3) THEN
                CALL HWWARN('HWISP3',129)
                GOTO 999
              ENDIF
              ID3PRT(N3MODE) = I
              NME(I) = 10000+N3MODE
              NDI3BY(N3MODE) = 2
              P3MODE(N3MODE) = ONE
              N3NCFL(N3MODE) = 1
              SPN3CF(1,1,N3MODE) = ONE
              III = (IDKPRD(1,I)-120)/2
              JJJ = (IDKPRD(2,I)-119)/2
              KKK = (IDKPRD(3,I)-126)/2
              DO 57 K=1,2
              I3DRTP(K,N3MODE) = 4
              I3DRCF(K,N3MODE) = 1
              I3MODE(K,N3MODE) = 423+2*KKK+12*(K-1)
              B3MODE(2,K,N3MODE) = 0.0D0
              B3MODE(1,K,N3MODE)=LAMDA1(III,JJJ,KKK)*LMIXSS(2*KKK-1,2,K)
              DO 57 J=1,2
 57           A3MODE(J,K,N3MODE) = AFC(O(J),5+2*KKK,K,L1)
C--neutrino neutrino lepton
            ELSEIF(MOD(IDKPRD(1,I),2).EQ.0.AND.MOD(IDKPRD(2,I),2).EQ.0
     &             .AND.MOD(IDKPRD(3,I),2).EQ.1) THEN
              N3MODE = N3MODE+1
              IF(N3MODE.GT.NMODE3) THEN
                CALL HWWARN('HWISP3',130)
                GOTO 999
              ENDIF
              ID3PRT(N3MODE) = I
              NME(I) = 10000+N3MODE
              NDI3BY(N3MODE) = 4
              P3MODE(N3MODE) = ONE
              N3NCFL(N3MODE) = 1
              SPN3CF(1,1,N3MODE) = ONE
              III = (IDKPRD(1,I)-126)/2
              JJJ = (IDKPRD(2,I)-126)/2
              KKK = (IDKPRD(3,I)-119)/2
              DO 58 K=1,2
              I3DRTP(K  ,N3MODE) = 8
              I3DRTP(K+2,N3MODE) = 9
              I3DRCF(K  ,N3MODE) = 1
              I3DRCF(K+2,N3MODE) = 1
              I3MODE(K  ,N3MODE) = 423+2*III+12*(K-1)
              I3MODE(K+2,N3MODE) = 423+2*JJJ+12*(K-1)
              B3MODE(2,K,N3MODE) = LAMDA1(III,JJJ,KKK)*
     &             LMIXSS(2*III-1,1,K)
              B3MODE(1,K,N3MODE) = 0.0D0
              B3MODE(2,K+2,N3MODE) =-LAMDA1(III,JJJ,KKK)*
     &             LMIXSS(2*JJJ-1,1,K)
              B3MODE(1,K+2,N3MODE) = 0.0D0
              DO 58 J=1,2
              A3MODE(J,K,N3MODE)   = AFC(O(J),5+2*III,K,L1)
 58           A3MODE(J,K+2,N3MODE) = AFC(O(J),5+2*JJJ,K,L1)
C--lepton lepton lepton
            ELSEIF(MOD(IDKPRD(1,I),2).EQ.1.AND.MOD(IDKPRD(2,I),2).EQ.1
     &             .AND.MOD(IDKPRD(3,I),2).EQ.1) THEN
              N3MODE = N3MODE+1
              IF(N3MODE.GT.NMODE3) THEN
                CALL HWWARN('HWISP3',131)
                GOTO 999
              ENDIF
              ID3PRT(N3MODE) = I
              NME(I) = 10000+N3MODE
              NDI3BY(N3MODE) = 2
              P3MODE(N3MODE) = ONE
              N3NCFL(N3MODE) = 1
              SPN3CF(1,1,N3MODE) = ONE
              III = (IDKPRD(1,I)-119)/2
              JJJ = (IDKPRD(2,I)-119)/2
              KKK = (IDKPRD(3,I)-125)/2
              I3DRTP(1,N3MODE) = 2
              I3DRTP(2,N3MODE) = 3
              I3DRCF(1,N3MODE) = 1
              I3DRCF(2,N3MODE) = 1
              I3MODE(1,N3MODE) = 424+2*III
              I3MODE(2,N3MODE) = 424+2*JJJ
              B3MODE(1,1,N3MODE) = LAMDA1(III,JJJ,KKK)
              B3MODE(2,1,N3MODE) = 0.0D0
              B3MODE(1,2,N3MODE) =-LAMDA1(III,JJJ,KKK)
              B3MODE(2,2,N3MODE) = 0.0D0
              DO 59 J=1,2
              A3MODE(J,1,N3MODE) = AFC(J,6+2*III,1,L1)
 59           A3MODE(J,2,N3MODE) = AFC(J,6+2*JJJ,1,L1)
            ELSE
              CALL HWWARN('HWISP3',7)
            ENDIF
C--LQD decays
          ELSEIF(IDKPRD(1,I).GE.121.AND.IDKPRD(1,I).LE.132.AND.
     &           IDKPRD(2,I).LE.12 .AND.IDKPRD(3,I).LE. 12) THEN
            L1 = IDK(I)-455
C--nu d ubar
            IF(IDKPRD(1,I).LE.126.AND.MOD(IDKPRD(1,I),2).EQ.0) THEN
              N3MODE = N3MODE+1
              IF(N3MODE.GT.NMODE3) THEN
                CALL HWWARN('HWISP3',132)
                GOTO 999
              ENDIF
              ID3PRT(N3MODE) = I
              NME(I) = 10000+N3MODE
              NDI3BY(N3MODE) = 2
              P3MODE(N3MODE) = THREE
              N3NCFL(N3MODE) = 1
              SPN3CF(1,1,N3MODE) = ONE
              III = (IDKPRD(1,I)-120)/2
              JJJ = (IDKPRD(2,I)+1)/2
              KKK = (IDKPRD(3,I)-6)/2
              DO 93 K=1,2
              I3DRTP(K,N3MODE) = 4
              I3DRCF(K,N3MODE) = 1
              I3MODE(K,N3MODE) = 399+2*KKK+12*(K-1)
              B3MODE(2,K,N3MODE) = 0.0D0
              B3MODE(1,K,N3MODE) = QMIXSS(2*KKK-1,2,K)*
     &                             LAMDA2(III,JJJ,KKK)
              DO 93 J=1,2
 93           A3MODE(J,K,N3MODE) = AFC(O(J),2*KKK-1,K,L1)
C--l- u ubar
            ELSEIF(IDKPRD(1,I).LE.125.AND.MOD(IDKPRD(1,I),2).EQ.1.AND.
     &             MOD(IDKPRD(2,I),2).EQ.0) THEN
              N3MODE = N3MODE+1
              IF(N3MODE.GT.NMODE3) THEN
                CALL HWWARN('HWISP3',133)
                GOTO 999
              ENDIF
              ID3PRT(N3MODE) = I
              NME(I) = 10000+N3MODE
              NDI3BY(N3MODE) = 2
              P3MODE(N3MODE) = THREE
              N3NCFL(N3MODE) = 1
              SPN3CF(1,1,N3MODE) = ONE
              III = (IDKPRD(1,I)-119)/2
              JJJ = IDKPRD(2,I)/2
              KKK = (IDKPRD(3,I)-6)/2
              DO 94 K=1,2
              I3DRTP(K,N3MODE) = 4
              I3DRCF(K,N3MODE) = 1
              I3MODE(K,N3MODE) = 399+2*KKK+12*(K-1)
              B3MODE(2,K,N3MODE) = 0.0D0
              B3MODE(1,K,N3MODE) = QMIXSS(2*KKK-1,2,K)*
     &                             LAMDA2(III,JJJ,KKK)
              DO 94 J=1,2
 94           A3MODE(J,K,N3MODE) = AFC(J,2*KKK-1,K,L1)
C--l- d dbar
            ELSEIF(IDKPRD(1,I).LE.125.AND.MOD(IDKPRD(1,I),2).EQ.1.AND.
     &             MOD(IDKPRD(2,I),2).EQ.1) THEN
              N3MODE = N3MODE+1
              IF(N3MODE.GT.NMODE3) THEN
                CALL HWWARN('HWISP3',134)
                GOTO 999
              ENDIF
              ID3PRT(N3MODE) = I
              NME(I) = 10000+N3MODE
              NDI3BY(N3MODE) = 3
              P3MODE(N3MODE) = THREE
              N3NCFL(N3MODE) = 1
              SPN3CF(1,1,N3MODE) = ONE
              III = (IDKPRD(1,I)-119)/2
              JJJ = (IDKPRD(2,I)+1)/2
              KKK = (IDKPRD(3,I)-5)/2
              I3DRTP(1,N3MODE) = 2
              I3DRCF(1,N3MODE) = 1
              I3MODE(1,N3MODE) = 424+2*III
              B3MODE(2,1,N3MODE) = 0.0D0
              B3MODE(1,1,N3MODE) = -LAMDA2(III,JJJ,KKK)
              DO 95 J=1,2
 95           A3MODE(J,1,N3MODE) = AFC(J,2*III+6,1,L1)
              DO 96 K=1,2
              I3DRTP(K+1,N3MODE) = 3
              I3DRCF(K+1,N3MODE) = 1
              I3MODE(K+1,N3MODE) = 400+2*JJJ+12*(K-1)
              B3MODE(2,K+1,N3MODE) = 0.0D0
              B3MODE(1,K+1,N3MODE) = QMIXSS(2*JJJ,1,K)*
     &                               LAMDA2(III,JJJ,KKK)
              DO 96 J=1,2
 96           A3MODE(J,K+1,N3MODE) = AFC(J,2*JJJ,K,L1)
C--nubar ubar d
            ELSEIF(IDKPRD(1,I).GE.128.AND.MOD(IDKPRD(1,I),2).EQ.0) THEN
              N3MODE = N3MODE+1
              IF(N3MODE.GT.NMODE3) THEN
                CALL HWWARN('HWISP3',135)
                GOTO 999
              ENDIF
              ID3PRT(N3MODE) = I
              NME(I) = 10000+N3MODE
              NDI3BY(N3MODE) = 4
              P3MODE(N3MODE) = THREE
              N3NCFL(N3MODE) = 1
              SPN3CF(1,1,N3MODE) = ONE
              III = (IDKPRD(1,I)-126)/2
              JJJ = (IDKPRD(2,I)-6)/2
              KKK = (IDKPRD(3,I)+1)/2
              DO 97 K=1,2
              I3DRTP(K  ,N3MODE) = 8
              I3DRTP(K+2,N3MODE) = 9
              I3DRCF(K  ,N3MODE) = 1
              I3DRCF(K+2,N3MODE) = 1
              I3MODE(K  ,N3MODE) = 423+2*III+12*(K-1)
              I3MODE(K+2,N3MODE) = 399+2*JJJ+12*(K-1)
              B3MODE(2,K  ,N3MODE) = LMIXSS(2*III-1,1,K)*
     &                               LAMDA2(III,JJJ,KKK)
              B3MODE(1,K  ,N3MODE) = 0.0D0
              B3MODE(2,K+2,N3MODE) = -QMIXSS(2*JJJ-1,1,K)*
     &                               LAMDA2(III,JJJ,KKK)
              B3MODE(1,K+2,N3MODE) = 0.0D0
              DO 97 J=1,2
              A3MODE(J,K  ,N3MODE) = AFC(O(J),2*III+5,K,L1)
 97           A3MODE(J,K+2,N3MODE) = AFC(O(J),2*JJJ-1,K,L1)
C--unrecognised
            ELSE
              CALL HWWARN('HWISP3',8)
            ENDIF
C-- UDD modes
          ELSEIF(IDKPRD(1,I).LE.12.AND.IDKPRD(2,I).LE.12.AND.
     &           IDKPRD(3,I).LE.12) THEN
             L1 = IDK(I)-455
C-- d d d mode
            IF(MOD(IDKPRD(1,I),2).EQ.1.AND.MOD(IDKPRD(2,I),2).EQ.1.AND.
     &         MOD(IDKPRD(3,I),2).EQ.1) THEN
              N3MODE = N3MODE+1
              IF(N3MODE.GT.NMODE3) THEN
                CALL HWWARN('HWISP3',136)
                GOTO 999
              ENDIF
              ID3PRT(N3MODE) = I
              NME(I) = 10000+N3MODE
              NDI3BY(N3MODE) = 6
              N3NCFL(N3MODE) = 1
              SPN3CF(1,1,N3MODE) = ONE
              III = (IDKPRD(1,I)+1)/2
              JJJ = (IDKPRD(2,I)+1)/2
              KKK = (IDKPRD(3,I)+1)/2
              P3MODE(N3MODE) = ONE
              IF(III.EQ.JJJ) P3MODE(N3MODE) = P3MODE(N3MODE)+ONE
              IF(JJJ.EQ.KKK) P3MODE(N3MODE) = P3MODE(N3MODE)+ONE
              IF(III.EQ.KKK) P3MODE(N3MODE) = P3MODE(N3MODE)+ONE
              P3MODE(N3MODE) = 6.0D0/P3MODE(N3MODE)
              DO 68 K=1,6
 68           I3DRCF(K,N3MODE) = 1
              DO 67 K=1,2
              I3DRTP(K  ,N3MODE) = 12
              I3DRTP(K+2,N3MODE) = 13
              I3DRTP(K+4,N3MODE) = 14
              I3MODE(K  ,N3MODE) = 400+2*III+(K-1)*12
              I3MODE(K+2,N3MODE) = 400+2*JJJ+(K-1)*12
              I3MODE(K+4,N3MODE) = 400+2*KKK+(K-1)*12
              B3MODE(1,K  ,N3MODE) = 0.0D0
              B3MODE(1,K+2,N3MODE) = 0.0D0
              B3MODE(1,K+4,N3MODE) = 0.0D0
              B3MODE(2,K  ,N3MODE) = QMIXSS(2*III,2,K)*
     &                               LAMDA3(III,JJJ,KKK)
              B3MODE(2,K+2,N3MODE) =-QMIXSS(2*JJJ,2,K)*
     &                               LAMDA3(JJJ,III,KKK)
              B3MODE(2,K+4,N3MODE) = QMIXSS(2*KKK,2,K)*
     &                               LAMDA3(KKK,III,JJJ)
              DO 67 J=1,2
              A3MODE(J,K  ,N3MODE) = AFC(J,2*III,K,L1)
              A3MODE(J,K+2,N3MODE) = AFC(J,2*JJJ,K,L1)
 67           A3MODE(J,K+4,N3MODE) = AFC(J,2*KKK,K,L1)
C--u u d mode
            ELSEIF(MOD(IDKPRD(1,I),2).EQ.0.AND.MOD(IDKPRD(2,I),2).EQ.0
     &              .AND.MOD(IDKPRD(3,I),2).EQ.1) THEN
              N3MODE = N3MODE+1
              IF(N3MODE.GT.NMODE3) THEN
                CALL HWWARN('HWISP3',137)
                GOTO 999
              ENDIF
              ID3PRT(N3MODE) = I
              NME(I) = 10000+N3MODE
              NDI3BY(N3MODE) = 4
              P3MODE(N3MODE) = 6.0D0
              N3NCFL(N3MODE) = 1
              SPN3CF(1,1,N3MODE) = ONE
              III = (IDKPRD(1,I)-6)/2
              JJJ = (IDKPRD(2,I)-6)/2
              KKK = (IDKPRD(3,I)-5)/2
              IF(III.EQ.JJJ) P3MODE(N3MODE) = HALF*P3MODE(N3MODE)
              DO 69 K=1,2
              I3DRTP(K  ,N3MODE) = 11
              I3DRTP(K+2,N3MODE) = 12
              I3DRCF(K  ,N3MODE) = 1
              I3DRCF(K+2,N3MODE) = 1
              I3MODE(K  ,N3MODE) = 399+2*III+(K-1)*12
              I3MODE(K+2,N3MODE) = 399+2*JJJ+(K-1)*12
              B3MODE(1,K  ,N3MODE) = QMIXSS(2*III-1,2,K)*
     &                               LAMDA3(JJJ,III,KKK)
              B3MODE(1,K+2,N3MODE) =-QMIXSS(2*JJJ-1,2,K)*
     &                               LAMDA3(III,JJJ,KKK)
              B3MODE(2,K+2,N3MODE) = 0.0D0
              B3MODE(2,K+2,N3MODE) = 0.0D0
              DO 69 J=1,2
              A3MODE(J,K  ,N3MODE) = AFC(O(J),2*III-1,K,L1)
 69           A3MODE(J,K+2,N3MODE) = AFC(O(J),2*JJJ-1,K,L1)
C--unrecognized decay issue warning
            ELSE
              CALL HWWARN('HWISP3',9)
            ENDIF
C--unrecognized decay issue warning
          ELSE
            CALL HWWARN('HWISP3',10)
          ENDIF
        ENDIF
C--NOW FIND THE TWO BODY MODES WE WILL TREAT AS THREE BODY
 2500   IF(IDKPRD(2,I).EQ.0.OR.IDKPRD(3,I).NE.0) GOTO 2000
        L1  = IDK(I)-449
        IH1 = IDK(I)-202
        IH  = IDKPRD(1,I)-202
C--first the neutralino decay modes
        IF(L1.GE.1.AND.L1.LE.4.AND.
     &     IDKPRD(2,I).GE.198.AND.IDKPRD(2,I).LE.200) THEN
C--neutralino --> neutralino Z
          IF(L.GE.1.AND.L.LE.4.AND.IDKPRD(2,I).EQ.200) THEN
            NBMODE = NBMODE+1
            IF(NBMODE.GT.NMODEB) THEN
              CALL HWWARN('HWISP3',138)
              GOTO 999
            ENDIF
            NME(I) = 20000+NBMODE
            IDBPRT(NBMODE) = I
            IBMODE(NBMODE) = 200
            IBDRTP(NBMODE) = 1
            DO 20 J=1,2
 20         ABMODE(J,NBMODE) = OIJPP(J,L,L1)
            DO 21 K=1,12
            IF(K.LE.6) THEN
              IL = K
              PBMODE(K,NBMODE) = THREE
            ELSE
              IL=K+4
              PBMODE(K,NBMODE) = ONE
            ENDIF
            BBMODE(1,K,NBMODE) = -E*RFCH(IL)
 21         BBMODE(2,K,NBMODE) = -E*LFCH(IL)
C--neutralino --> chargino+ W-
          ELSEIF((L.EQ.5.OR.L.EQ.6).AND.IDKPRD(2,I).EQ.199) THEN
            L = L-4
            NBMODE = NBMODE+1
            IF(NBMODE.GT.NMODEB) THEN
              CALL HWWARN('HWISP3',139)
              GOTO 999
            ENDIF
            NME(I) = 20000+NBMODE
            IDBPRT(NBMODE) = I
            IBMODE(NBMODE) = 199
            IBDRTP(NBMODE) = 1
            DO 22 J=1,2
 22         ABMODE(J,NBMODE) = OIJ(J,L1,L)
            DO 23 K=1,6
            PBMODE(K,NBMODE) = ONE
            IF(K.LE.3) PBMODE(K,NBMODE) = THREE
            BBMODE(1,K,NBMODE) = ZERO
 23         BBMODE(2,K,NBMODE) = -G*ORT
C--neutralino --> chargino- W+
          ELSEIF((L.EQ.7.OR.L.EQ.8).AND.IDKPRD(2,I).EQ.198) THEN
            L = L-6
            NBMODE = NBMODE+1
            IF(NBMODE.GT.NMODEB) THEN
              CALL HWWARN('HWISP3',140)
              GOTO 999
            ENDIF
            NME(I) = 20000+NBMODE
            IDBPRT(NBMODE) = I
            IBMODE(NBMODE) = 198
            IBDRTP(NBMODE) = 1
            DO 24 J=1,2
 24         ABMODE(J,NBMODE) =-OIJ(O(J),L1,L)
            DO 25 K=1,6
            PBMODE(K,NBMODE) = ONE
            IF(K.LE.3) PBMODE(K,NBMODE) = THREE
            BBMODE(1,K,NBMODE) = ZERO
 25         BBMODE(2,K,NBMODE) = -G*ORT
C--gravitino Z modes
          ELSEIF(L.EQ.9.AND.IDKPRD(2,I).EQ.200) THEN
            NBMODE = NBMODE+1
            IF(NBMODE.GT.NMODEB) THEN
              CALL HWWARN('HWISP3',141)
              GOTO 999
            ENDIF
            NME(I) = 20000+NBMODE
            IDBPRT(NBMODE) = I
            IBMODE(NBMODE) = 200
            IBDRTP(NBMODE) = 7
            ABMODE(1,NBMODE) = 2.0D0/SQRT(6.0D0)*ZMIXSS(L1,2)
            ABMODE(2,NBMODE) = 2.0D0/SQRT(6.0D0)*RMASS(200)*
     &                         (ZMIXSS(L1,3)*COSB-ZMIXSS(L1,4)*SINB)
            DO 41 K=1,12
            IF(K.LE.6) THEN
              IL = K
              PBMODE(K,NBMODE) = THREE
            ELSE
              IL=K+4
              PBMODE(K,NBMODE) = ONE
            ENDIF
            BBMODE(1,K,NBMODE) = -E*RFCH(IL)
 41         BBMODE(2,K,NBMODE) = -E*LFCH(IL)
C--unrecognized decay issue warning
          ELSE
            CALL HWWARN('HWISP3',11)
          ENDIF
C--then the +ve chargino decay modes
        ELSEIF((L1.EQ.5.OR.L1.EQ.6)
     &         .AND.IDKPRD(2,I).GE.198.AND.IDKPRD(2,I).LE.200) THEN
          L1 = L1-4
C--chargino --> chargino Z
          IF((L.EQ.5.OR.L.EQ.6).AND.IDKPRD(2,I).EQ.200) THEN
            L = L-4
            NBMODE = NBMODE+1
            IF(NBMODE.GT.NMODEB) THEN
              CALL HWWARN('HWISP3',142)
              GOTO 999
            ENDIF
            NME(I) = 20000+NBMODE
            IDBPRT(NBMODE) = I
            IBMODE(NBMODE) = 200
            IBDRTP(NBMODE) = 1
            DO 26 J=1,2
 26         ABMODE(J,NBMODE) = OIJP(J,L,L1)
            DO 27 K=1,12
            IF(K.LE.6) THEN
              IL = K
              PBMODE(K,NBMODE) = THREE
            ELSE
              IL=K+4
              PBMODE(K,NBMODE) = ONE
            ENDIF
            BBMODE(1,K,NBMODE) = -E*RFCH(IL)
 27         BBMODE(2,K,NBMODE) = -E*LFCH(IL)
C--chargino --> neutralino W+
          ELSEIF(L.GE.1.AND.L.LE.4.AND.IDKPRD(2,I).EQ.198) THEN
            NBMODE = NBMODE+1
            IF(NBMODE.GT.NMODEB) THEN
              CALL HWWARN('HWISP3',143)
              GOTO 999
            ENDIF
            NME(I) = 20000+NBMODE
            IDBPRT(NBMODE) = I
            IBMODE(NBMODE) = 198
            IBDRTP(NBMODE) = 1
            DO 28 J=1,2
 28         ABMODE(J,NBMODE) = OIJ(J,L,L1)
            DO 29 K=1,6
            PBMODE(K,NBMODE) = ONE
            IF(K.LE.3) PBMODE(K,NBMODE) = THREE
            BBMODE(1,K,NBMODE) = ZERO
 29         BBMODE(2,K,NBMODE) = -G*ORT
C--unrecognised decay issue warning
          ELSE
            CALL HWWARN('HWISP3',12)
          ENDIF
C--then the -ve chargino decay modes
        ELSEIF((L1.EQ.7.OR.L1.EQ.8)
     &         .AND.IDKPRD(2,I).GE.198.AND.IDKPRD(2,I).LE.200) THEN
          L1 = L1-6
C--chargino --> chargino Z
          IF((L.EQ.7.OR.L.EQ.8).AND.IDKPRD(2,I).EQ.200) THEN
            L = L-6
            NBMODE = NBMODE+1
            IF(NBMODE.GT.NMODEB) THEN
              CALL HWWARN('HWISP3',144)
              GOTO 999
            ENDIF
            NME(I) = 20000+NBMODE
            IDBPRT(NBMODE) = I
            IBMODE(NBMODE) = 200
            IBDRTP(NBMODE) = 1
            DO 30 J=1,2
 30         ABMODE(J,NBMODE) =-OIJP(O(J),L,L1)
            DO 31 K=1,12
            IF(K.LE.6) THEN
              IL = K
              PBMODE(K,NBMODE) = THREE
            ELSE
              IL=K+4
              PBMODE(K,NBMODE) = ONE
            ENDIF
            BBMODE(1,K,NBMODE) = -E*RFCH(IL)
 31         BBMODE(2,K,NBMODE) = -E*LFCH(IL)
C--chargino --> neutralino W-
          ELSEIF(L.GE.1.AND.L.LE.4.AND.IDKPRD(2,I).EQ.199) THEN
            NBMODE = NBMODE+1
            IF(NBMODE.GT.NMODEB) THEN
              CALL HWWARN('HWISP3',145)
              GOTO 999
            ENDIF
            NME(I) = 20000+NBMODE
            IDBPRT(NBMODE) = I
            IBMODE(NBMODE) = 199
            IBDRTP(NBMODE) = 1
            DO 32 J=1,2
 32         ABMODE(J,NBMODE) =-OIJ(O(J),L,L1)
            DO 33 K=1,6
            PBMODE(K,NBMODE) = ONE
            IF(K.LE.3) PBMODE(K,NBMODE) = THREE
            BBMODE(1,K,NBMODE) = ZERO
 33         BBMODE(2,K,NBMODE) = -G*ORT
C--unrecognised decay issue warning
          ELSE
            CALL HWWARN('HWISP3',13)
          ENDIF
C--gauge boson decay modes of the Higgs
        ELSEIF(IH.GE.1.AND.IH.LE.5.AND.IH1.GE.1.AND.IH1.LE.5.AND.
     &         IDKPRD(1,I).GE.198.AND.IDKPRD(2,I).LE.200) THEN
C--decay of the A0 to scalar Higgs and Z boson
          IF(IH1.EQ.3.AND.IH.LE.2) THEN
            NBMODE = NBMODE+1
            IF(NBMODE.GT.NMODEB) THEN
              CALL HWWARN('HWISP3',146)
              GOTO 999
            ENDIF
            NME(I) = 20000+NBMODE
            IDBPRT(NBMODE) = I
            IBMODE(NBMODE) = 200
            IBDRTP(NBMODE) = 6
            ABMODE(1,NBMODE) =-HHB(2,IH)
            ABMODE(2,NBMODE) = ZERO
            DO 34 K=1,12
            IF(K.LE.6) THEN
              IL = K
              PBMODE(K,NBMODE) = 3.0D0
            ELSE
              IL=K+4
              PBMODE(K,NBMODE) = 1.0D0
            ENDIF
            BBMODE(1,K,NBMODE) = -E*RFCH(IL)
 34         BBMODE(2,K,NBMODE) = -E*LFCH(IL)
C--decay of scalar Higgs to A0 and Z
          ELSEIF(IH.EQ.3.AND.IH1.LE.3) THEN
            NBMODE = NBMODE+1
            IF(NBMODE.GT.NMODEB) THEN
              CALL HWWARN('HWISP3',147)
              GOTO 999
            ENDIF
            NME(I) = 20000+NBMODE
            IDBPRT(NBMODE) = I
            IBMODE(NBMODE) = 200
            IBDRTP(NBMODE) = 6
            ABMODE(1,NBMODE) = HHB(2,IH1)
            ABMODE(2,NBMODE) = ZERO
            DO 35 K=1,12
            IF(K.LE.6) THEN
              IL = K
              PBMODE(K,NBMODE) = 3.0D0
            ELSE
              IL=K+4
              PBMODE(K,NBMODE) = 1.0D0
            ENDIF
            BBMODE(1,K,NBMODE) = -E*RFCH(IL)
 35         BBMODE(2,K,NBMODE) = -E*LFCH(IL)
C--decay of the positively charged Higgs
          ELSEIF(IH1.EQ.4.AND.IH.LE.3) THEN
            NBMODE = NBMODE+1
            IF(NBMODE.GT.NMODEB) THEN
              CALL HWWARN('HWISP3',148)
              GOTO 999
            ENDIF
            NME(I) = 20000+NBMODE
            IDBPRT(NBMODE) = I
            IBMODE(NBMODE) = 198
            IBDRTP(NBMODE) = 6
            ABMODE(1,NBMODE) =-HHB(1,IH)
            ABMODE(2,NBMODE) = ZERO
            DO 36 K=1,6
            PBMODE(K,NBMODE) = 1.0D0
            IF(K.LE.3) PBMODE(K,NBMODE) = 3.0D0
            BBMODE(1,K,NBMODE) = ZERO
 36         BBMODE(2,K,NBMODE) = -G*ORT
C--decay of the negatively charged Higgs
          ELSEIF(IH1.EQ.5.AND.IH.LE.3) THEN
            NBMODE = NBMODE+1
            IF(NBMODE.GT.NMODEB) THEN
              CALL HWWARN('HWISP3',149)
              GOTO 999
            ENDIF
            NME(I) = 20000+NBMODE
            IDBPRT(NBMODE) = I
            IBMODE(NBMODE) = 199
            IBDRTP(NBMODE) = 6
            ABMODE(1,NBMODE) =-HHB(1,IH)
            ABMODE(2,NBMODE) = ZERO
            DO 37 K=1,6
            PBMODE(K,NBMODE) = 1.0D0
            IF(K.LE.3) PBMODE(K,NBMODE) = 3.0D0
            BBMODE(1,K,NBMODE) = ZERO
 37         BBMODE(2,K,NBMODE) = -G*ORT
          ENDIF
C--finally sfermion modes to gauge bosons
        ELSEIF(IDK(I).GE.401.AND.IDK(I).LE.448.AND.
     &         IDKPRD(2,I).GE.401.AND.IDKPRD(2,I).LE.448.AND.
     &         IDKPRD(1,I).GE.198.AND.IDKPRD(1,I).LE.200) THEN
C--change the order of the decay products
          IM = MOD(INT((IDK(I)-389)/12)+1,2)+1
          IL = 6*INT((IDK(I)-401)/24)+MOD(IDK(I)-401,6)+1
          IH = MOD(INT((IDKPRD(2,I)-389)/12)+1,2)+1
          IQ = 6*INT((IDKPRD(2,I)-401)/24)+MOD(IDKPRD(2,I)-401,6)+1
C--first the Z decay modes
          IF(IDKPRD(1,I).EQ.200) THEN
            NBMODE = NBMODE+1
            IF(NBMODE.GT.NMODEB) THEN
              CALL HWWARN('HWISP3',150)
              GOTO 999
            ENDIF
            NME(I) = 20000+NBMODE
            IDBPRT(NBMODE) = I
            IBMODE(NBMODE) = 200
            IBDRTP(NBMODE) = 6
            ABMODE(1,NBMODE) = ZAB(IL,IM,IH)
            ABMODE(2,NBMODE) = ZERO
            DO 38 K=1,12
            IF(K.LE.6) THEN
              IL = K
              PBMODE(K,NBMODE) = 3.0D0
            ELSE
              IL=K+4
              PBMODE(K,NBMODE) = 1.0D0
            ENDIF
            BBMODE(1,K,NBMODE) = -E*RFCH(IL)
 38         BBMODE(2,K,NBMODE) = -E*LFCH(IL)
C--then  the W+ decay modes
          ELSEIF(IDKPRD(1,I).EQ.198) THEN
            NBMODE = NBMODE+1
            IF(NBMODE.GT.NMODEB) THEN
              CALL HWWARN('HWISP3',151)
              GOTO 999
            ENDIF
            NME(I) = 20000+NBMODE
            IDBPRT(NBMODE) = I
            IBMODE(NBMODE) = 198
            IBDRTP(NBMODE) = 6
            IF(IL.LE.6) THEN
              ABMODE(1,NBMODE) = -G*ORT*QMIXSS(IL,1,IM)*QMIXSS(IQ,1,IH)
            ELSE
              ABMODE(1,NBMODE) = -G*ORT*LMIXSS(IL-6,1,IM)*
     &                                  LMIXSS(IQ-6,1,IH)
            ENDIF
            ABMODE(2,NBMODE) = ZERO
            DO 39 K=1,6
            PBMODE(K,NBMODE) = 1.0D0
            IF(K.LE.3) PBMODE(K,NBMODE) = 3.0D0
            BBMODE(1,K,NBMODE) = ZERO
 39         BBMODE(2,K,NBMODE) = -G*ORT
          ELSEIF(IDKPRD(1,I).EQ.199) THEN
            NBMODE = NBMODE+1
            IF(NBMODE.GT.NMODEB) THEN
              CALL HWWARN('HWISP3',152)
              GOTO 999
            ENDIF
            NME(I) = 20000+NBMODE
            IDBPRT(NBMODE) = I
            IBMODE(NBMODE) = 199
            IBDRTP(NBMODE) = 6
            IF(IL.LE.6) THEN
              ABMODE(1,NBMODE) = -G*ORT*QMIXSS(IL,1,IM)*QMIXSS(IQ,1,IH)
            ELSE
              ABMODE(1,NBMODE) = -G*ORT*LMIXSS(IL-6,1,IM)*
     &                                  LMIXSS(IQ-6,1,IH)
            ENDIF
            ABMODE(2,NBMODE) = ZERO
            DO 40 K=1,6
            PBMODE(K,NBMODE) = 1.0D0
            IF(K.LE.3) PBMODE(K,NBMODE) = 3.0D0
            BBMODE(1,K,NBMODE) = ZERO
 40         BBMODE(2,K,NBMODE) = -G*ORT
          ENDIF
        ENDIF
 2000 CONTINUE
C--now compute the maximum weights for the three body decays found
 2999 CONTINUE
      DO 3000 I=1,N3MODE
      IF(RSPIN(IDK(ID3PRT(I))).EQ.ZERO) THEN
        RHOIN(1,1) = ONE
        RHOIN(1,2) = ZERO
        RHOIN(2,1) = ZERO
        RHOIN(2,2) = ZERO
      ELSE
        RHOIN(1,1) = HALF
        RHOIN(1,2) = ZERO
        RHOIN(2,1) = ZERO
        RHOIN(2,2) = HALF
      ENDIF
      PHEP(5,1) = RMASS(IDK(ID3PRT(I)))
      PHEP(4,1) = SQRT(100.0D0**2+PHEP(5,1)**2)
      PHEP(1,1) = 100.0D0
      PHEP(2,1) = 0.0D0
      PHEP(3,1) = 0.0D0
      IF(IPRINT.GE.2) WRITE(6,5000) RNAME(IDK(ID3PRT(I))),
     &   RNAME(IDKPRD(1,ID3PRT(I))),RNAME(IDKPRD(2,ID3PRT(I))),
     &   RNAME(IDKPRD(3,ID3PRT(I)))
 3000 CALL HWD3ME(1,0,I,RHOIN,1)
      IF(.NOT.SUSYIN) RETURN
C--and for the two body gauge boson modes
      DO 4000 I=1,NBMODE
      IF(RSPIN(IDK(IDBPRT(I))).EQ.ZERO) THEN
        RHOIN(1,1) = ONE
        RHOIN(1,2) = ZERO
        RHOIN(2,1) = ZERO
        RHOIN(2,2) = ZERO
      ELSE
        RHOIN(1,1) = HALF
        RHOIN(1,2) = ZERO
        RHOIN(2,1) = ZERO
        RHOIN(2,2) = HALF
      ENDIF
      PHEP(5,1) = RMASS(IDK(IDBPRT(I)))
      PHEP(4,1) = SQRT(100.0D0**2+PHEP(5,1)**2)
      PHEP(1,1) = 100.0D0
      PHEP(2,1) = 0.0D0
      PHEP(3,1) = 0.0D0
      IF(IPRINT.GE.2) WRITE(6,5010) RNAME(IDK(IDBPRT(I))),
     & RNAME(IDKPRD(1,IDBPRT(I))),RNAME(IDKPRD(2,IDBPRT(I)))
      IL = 12
      IF(IBMODE(I).NE.200) IL = 6
      DO 4000 J=1,IL
 4000 CALL HWD3ME(1,J,I,RHOIN,1)
      RETURN
 5000 FORMAT(/'CALCULATING THREE BODY DECAY ',
     &     A8,' --> ',A8,' ',A8,' ',A8/)
 5010 FORMAT(/'CALCULATING TWO BODY DECAY ',
     &     A8,' --> ',A8,' ',A8/)
 999  RETURN
      END
CDECK  ID>, HWISP4.
*CMZ :-        -12/10/01  12.04.54  by  Peter Richardson
*-- Author :    Peter Richardson
C-----------------------------------------------------------------------
      SUBROUTINE HWISP4
C-----------------------------------------------------------------------
C     Initialise the Higgs four body modes
C-----------------------------------------------------------------------
      INCLUDE 'HERWIG65.INC'
      INTEGER I,J,K,IL,IH,II,JJ
      DOUBLE PRECISION COL(2),SW,CW,TW,E,G,RT,ORT,MW,MZ,AFN(2,12,2,4),
     &     AFG(2,6,2),AFC(2,12,2,2),OIJ(2,4,2),OIJP(2,2,2),OIJPP(2,4,4),
     &     HNN(2,3,4,4),HCC(2,3,2,2),HNC(2,4,2),HFF(2,4,12),HWW(2),
     &     HZZ(2),ZAB(12,2,2),HHB(2,3),GS
      COMMON /HWSPNC/ SW,CW,TW,E,G,RT,ORT,MW,MZ,GS,AFN,AFG,AFC,OIJ,OIJP,
     &               OIJPP,HNN,HCC,HNC,HFF,HWW,HZZ,ZAB,HHB
      IF(IERROR.NE.0.OR..NOT.SUSYIN) RETURN
C--four body Higgs modes via virtual WW and ZZ
      DO 1000 JJ=1,NRES
      DO 1000 II=1,NMODES(JJ)
        IF(II.EQ.1) THEN
          I = LSTRT(JJ)
        ELSE
          I = LNEXT(I)
        ENDIF
        IH=IDK(I)-202
        IF((IH.EQ.1.OR.IH.EQ.2).AND.IDKPRD(3,I).EQ.0.AND.
     &       IDKPRD(1,I).GE.198.AND.IDKPRD(1,I).LE.200.AND.
     &       IDKPRD(2,I).GE.198.AND.IDKPRD(2,I).LE.200) THEN
C--first the WW modes
          IF(IDKPRD(1,I).NE.200) THEN
            N4MODE = N4MODE+1
            IF(N4MODE.GT.NMODE4) THEN
              CALL HWWARN('HWISP4',100)
              GOTO 999
            ENDIF
            NME(I) = 40000+N4MODE
            ID4PRT(N4MODE) = I
            I4MODE(1,N4MODE) = 198
            I4MODE(2,N4MODE) = 199
            DO 1 K=1,6
            A4MODE(1,K,N4MODE) = ZERO
            A4MODE(2,K,N4MODE) =-G*ORT
            B4MODE(1,K,N4MODE) = ZERO
 1          B4MODE(2,K,N4MODE) =-G*ORT
C--now the prefactors
            DO 2 J=1,6
            COL(1) = HWW(IH)**2
            IF(J.LE.3) COL(1) = THREE*COL(1)
            DO 2 K=1,6
            COL(2) = ONE
            IF(K.LE.3) COL(2) = THREE*COL(2)
 2          P4MODE(J,K,N4MODE) = COL(1)*COL(2)
C--then the ZZ modes
          ELSE
            N4MODE = N4MODE+1
            IF(N4MODE.GT.NMODE4) THEN
              CALL HWWARN('HWISP4',101)
              GOTO 999
            ENDIF
            NME(I) = 40000+N4MODE
            ID4PRT(N4MODE) = I
            I4MODE(1,N4MODE) = 200
            I4MODE(2,N4MODE) = 200
            DO 3 K=1,12
            IL = K
            IF(K.GT.6) IL=K+4
            A4MODE(1,K,N4MODE) =-E*RFCH(IL)
            A4MODE(2,K,N4MODE) =-E*LFCH(IL)
            B4MODE(1,K,N4MODE) =-E*RFCH(IL)
 3          B4MODE(2,K,N4MODE) =-E*LFCH(IL)
            DO 4 J=1,12
            COL(1) = HALF*HZZ(IH)**2
            IF(J.LE.6) COL(1)=THREE*COL(1)
            DO 4 K=1,12
            COL(2) = ONE
            IF(K.LE.6) COL(2) = THREE
 4          P4MODE(J,K,N4MODE) = COL(1)*COL(2)
          ENDIF
        ENDIF
 1000 CONTINUE
C--compute the maximum weights
      IF(N4MODE.EQ.0) RETURN
      DO 2000 I=1,N4MODE
      PHEP(5,1) = RMASS(IDK(ID4PRT(I)))
      PHEP(4,1) = SQRT(100.0D0**2+PHEP(5,1)**2)
      PHEP(1,1) = 100.0D0
      PHEP(2,1) = 0.0D0
      PHEP(3,1) = 0.0D0
      IF(IPRINT.GE.2) WRITE(6,5010) RNAME(IDK(ID4PRT(I))),
     &            RNAME(IDKPRD(1,ID4PRT(I))),RNAME(IDKPRD(2,ID4PRT(I)))
      IL = 12
      IF(I4MODE(1,I).NE.200) IL = 6
      DO 2000 J=1,IL
      DO 2000 K=1,IL
 2000 CALL HWD4ME(1,J,K,I)
      RETURN
 5010 FORMAT(/'CALCULATING TWO BODY DECAY ',
     &     A8,' --> ',A8,' ',A8/)
 999  RETURN
      END
CDECK  ID>, HWISSP.
*CMZ :-        -12/10/01  09:41: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 'HERWIG65.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))
      SAVE MDKYS
      SAVE FIRST
      DATA FIRST/.TRUE./
      IF (FIRST) THEN
        MDKYS=NDKYS
        FIRST=.FALSE.
      ELSE
        NDKYS=MDKYS
      ENDIF
C--reset susy input flag
      IF (LRSUSY.LT.0) CALL HWWARN('HWISSP',500)
      SUSYIN = .TRUE.
C
C  Input SUSY particle + top quark table
C
      WRITE (6,9)       '                           '
  9   FORMAT(//10X,A28//,
     &         10X,'Since SUSY processes are called,'
     & ,/,     10X,'please also reference: S.Moretti, K.Odagiri,'
     & ,/,     10X,'P.Richardson, M.H.Seymour & B.R.Webber,'
     & ,/,     10X,'JHEP 0204 (2002) 028')
      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)
          NRES=IHW
        ENDIF
      ENDDO
      XLMNSS=TWO*LOG(RMMNSS/RMMAX)
    1 FORMAT(I5,F12.4,E15.5)
C
C  Input decay modes
C
      NDECSY = NDKYS+1
      DO I=1,NSSP
        READ (LRSUSY,'(I4)') NDEC
        IF (NDEC.GT.0) THEN
          DO J=1,NDEC
            NDKYS=NDKYS+1
            IF (NDKYS.GT.NMXDKS) THEN
              CALL HWWARN('HWISSP',100)
              GOTO 999
            ENDIF
            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
C--left and right couplings now computed in HWIGIN
          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)
      IF(FOURB) CALL HWIMDE
 999  RETURN
      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 'HERWIG65.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
C--BRW FIX 30/12/04 FOR SPACE-TIME STRUCTURE
C--RMS CLUSTER COORDINATES (GAUSSIAN) AND C*LIFETIME (IN MM)
      DOUBLE PRECISION VCLX,VCLY,VCLZ,VCLT,HWRGAU,HWRGEN
      EXTERNAL HWREXP,HWRINT,HWRGAU,HWRGEN
      SAVE VCLX,VCLY,VCLZ,VCLT
      DATA VCLX,VCLY,VCLZ,VCLT/4*1D-12/
C--END FIX
      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)
          GOTO 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) THEN
          CALL HWWARN('HWMEVT',101)
          GOTO 999
        ENDIF
        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) THEN
        CALL HWWARN('HWMEVT',102)
        GOTO 999
      ENDIF
      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 (IPRO/10.EQ.9.OR.IPRO/10.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) THEN
        CALL HWWARN('HWMEVT',103)
        GOTO 999
      ENDIF
      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--BRW FIX 30/12/04 FOR SPACE-TIME STRUCTURE
C--VERTEX POSITION FOR CLUSTER FORMATION
      VHEP(1,JCL)=HWRGAU(1,ZERO,VCLX)
      VHEP(2,JCL)=HWRGAU(2,ZERO,VCLY)
      VHEP(3,JCL)=HWRGAU(3,ZERO,VCLZ)
      VHEP(4,JCL)=SQRT(VHEP(1,JCL)**2+VHEP(2,JCL)**2+VHEP(3,JCL)**2)
     &            -VCLT*LOG(HWRGEN(0))
C--MHS FIX 07/03/05 - MEASURE DISPLACEMENTS RELATIVE TO SOFT CM
      CALL HWVZRO(4,VTXPIP)
C--END FIXES
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))
C--BRW FIX 30/12/04 FOR SPACE-TIME STRUCTURE
      CALL HWULOB(PPCL(1,JCL),VHEP(1,KHEP),VHEP(1,KHEP))
C--MHS FIX 07/03/05 - ASSUME THAT SOFT CM COINCIDES WITH PRIMARY IP
      IF (.NOT.(ISTHEP(KHEP).GT.180.AND.ISTHEP(KHEP).LT.190
     $       .AND.JMOHEP(1,KHEP).EQ.ICMS))
     $     CALL HWVSUM(4,VHEP(1,3),VHEP(1,KHEP),VHEP(1,KHEP))
C--END FIXES
   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  RETURN
      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 'HERWIG65.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)
        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)
        IF(IDP.LT.0.OR.IDP.GT.49) GOTO 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) THEN
        CALL HWWARN('HWMLPS',100)
        GOTO 999
      ENDIF
      CALL HWWARN('HWMLPS',50)
      GOTO 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  RETURN
      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-----------------------------------------------------------------------
      IMPLICIT NONE
      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 'HERWIG65.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),IFGO
      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) THEN
          CALL HWWARN('HWMODK',100)
          GOTO 999
        ENDIF
        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) THEN
          CALL HWWARN('HWMODK',101)
          GOTO 999
        ENDIF
        DO 80 I=1,5
  80    IDKPRD(I,NDKYS)=ITMP(I)
C If decay consistent set up new pointers
        CALL HWDCHK(IDKY,NDKYS,IFGO)
        IF(IFGO) GOTO 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 'HERWIG65.INC'
      DOUBLE PRECISION HWMNBI,HWRGEN,EPPBAR,E0,ALOGS,RK,EK,AVN,SUM,R,
     & CUM(500)
      INTEGER NCHT,IMAX,I,N
      SAVE E0,CUM,IMAX
      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
            E0=0
            CALL HWWARN('HWMULT',101)
            GOTO 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  RETURN
      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 'HERWIG65.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)
        GOTO 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  RETURN
      END
CDECK  ID>, HWPHTP.
*CMZ :-        -11/08/03  15:30:25  by  Peter Richardson
*-- Author :    Peter Richardson and Zbigniew Was
C-----------------------------------------------------------------------
      SUBROUTINE HWPHTP(IHEP)
C-----------------------------------------------------------------------
C     subroutine for radiation in top decays
C-----------------------------------------------------------------------
      INCLUDE 'HERWIG65.INC'
      INTEGER IHEP,KK,IPOS,NN,NHEP0,KK1,KK2,JMOH(NMXHEP)
      DOUBLE PRECISION HWDPWT
      EXTERNAL HWDPWT
C--add an extra photon for top or W
      IF(IERROR.NE.0) RETURN
      IF(ABS(IDHEP(IHEP)).EQ.6.OR.ABS(IDHEP(IHEP)).EQ.24) THEN
        NHEP0=NHEP
        KK1=JDAHEP(1,IHEP)
        KK2=JDAHEP(2,IHEP)
C--copy the colour mother infomation
        DO KK=KK1,KK2
          JMOH(KK)=JMOHEP(2,KK)
          JMOHEP(2,KK)=0
        ENDDO
C--call photos
        IPOS=-IHEP
        CALL PHOTOS(IPOS)
C--reset the colour mother infomation
        DO KK=KK1,KK2
          JMOHEP(2,KK)=JMOH(KK)
        ENDDO
C--update the decaying particle
        JDAHEP(2,IHEP) = NHEP
C--set up the additions photons in the record
        NN=NHEP-NHEP0
        NHEP=NHEP0
        IF(NN.GT.0) THEN
          DO KK=1,NN
C--photon mass probably not needed
            PHEP(5,NHEP+1) = ZERO
C--info on the photon
            ISTHEP(NHEP+1) = 114
            IDHW(NHEP+1) = 59
            IDHEP(NHEP+1) = 22
            JMOHEP(1,NHEP+1) = IHEP
            JMOHEP(2,NHEP+1) = NHEP+1
            JDAHEP(2,NHEP+1) = NHEP+1
            NHEP = NHEP+1
          ENDDO
        ENDIF
      ENDIF
      END
CDECK  ID>, HWPHTT.
*CMZ :-        -11/08/03  15:30:25  by  Peter Richardson
*-- Author :    Peter Richardson and Zbigniew Was
C-----------------------------------------------------------------------
      SUBROUTINE HWPHTT
C-----------------------------------------------------------------------
C     subroutine for radiation in top production
C-----------------------------------------------------------------------
      INCLUDE 'HERWIG65.INC'
C--local variables
      INTEGER IMO(10),IFOUND,JMO(2),I,J,K,L,NSTART,NHEPX
C--initialisation
      IF(IERROR.NE.0) RETURN
      IFOUND=0
      DO K=1,10
        IMO(K)=0
      ENDDO
C--loop to find mothers of any tops
      NSTART=1
      DO I=NSTART,NHEP
        IF (ABS(IDHEP(I)).EQ.6) THEN
          DO K=1,IFOUND
           IF(IMO(K).EQ.JMOHEP(1,I)) GOTO 10
          ENDDO
          IFOUND=IFOUND+1
          IMO(IFOUND)=JMOHEP(1,I)
        ENDIF
 10     CONTINUE
      ENDDO
C--generate the radiation
      DO K=1,IFOUND
C--save the colour mother pointers
        JMO(1)=JMOHEP(2,JDAHEP(1,IMO(K)))
        JMO(2)=JMOHEP(2,1+JDAHEP(1,IMO(K)))
C--zero the second mothers
        JMOHEP(2,JDAHEP(1,IMO(K)))=0
        JMOHEP(2,JDAHEP(2,IMO(K)))=0
C--call photos to generate radiation
        CALL PHOTOS(IMO(K))
        NHEPX=NHEP
        DO 11 J=NHEP,1,-1
          IF(IDHEP(J).EQ.22) THEN
            NHEPX=NHEPX-1
          ELSE
            GOTO 11
          ENDIF
 11     CONTINUE
C--reset the colour pointers
        JMOHEP(2,  JDAHEP(1,IMO(K)))=JMO(1)
        JMOHEP(2,1+JDAHEP(1,IMO(K)))=JMO(2)
C--setup the photons
        DO L=NHEPX+1,NHEP
          ISTHEP(L)=114
          JMOHEP(2,L) = L
          JDAHEP(2,L) = L
          IDHW(L) = 59
        ENDDO
      ENDDO
      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-----------------------------------------------------------------------
      IMPLICIT NONE
      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-----------------------------------------------------------------------
      IMPLICIT NONE
      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-----------------------------------------------------------------------
      IMPLICIT NONE
      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-----------------------------------------------------------------------
      IMPLICIT NONE
      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  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 'HERWIG65.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
*- Split in 3 files by M. Kirsanov. Initial seeds ISEED set in HWUDAT
cC-----------------------------------------------------------------------
c      FUNCTION HWRGEN(I)
cC-----------------------------------------------------------------------
cC     MAIN RANDOM NUMBER GENERATOR
cC     USES METHOD OF l'Ecuyer, (VIA F.JAMES, COMP PHYS COMM 60(1990)329)
cC-----------------------------------------------------------------------
c      IMPLICIT NONE
c      DOUBLE PRECISION HWRGEN
c      COMMON/HWSEED/ISEED(2)
c      INTEGER ISEED
c      INTEGER I,K,IZ
cC
c      K=ISEED(1)/53668
c      ISEED(1)=40014*(ISEED(1)-K*53668)-K*12211
c      IF (ISEED(1).LT.0) ISEED(1)=ISEED(1)+2147483563
c      K=ISEED(2)/52774
c      ISEED(2)=40692*(ISEED(2)-K*52774)-K*3791
c      IF (ISEED(2).LT.0) ISEED(2)=ISEED(2)+2147483399
c      IZ=ISEED(1)-ISEED(2)
c      IF (IZ.LT.1) IZ=IZ+2147483562
c      HWRGEN=DBLE(IZ)*4.656613001013252D-10
cC--->                (4.656613001013252D-10 = 1.D0/2147483589)
c      END
cCDECK  ID>, HWRSET.
c*CMZ :-        -26/04/91  12.42.30  by  Federico Carminati
c*-- Author :    F. James, modified by Mike Seymour
cC-----------------------------------------------------------------------
c      FUNCTION HWRSET(JSEED)
cC-----------------------------------------------------------------------
cC     MAIN RANDOM NUMBER GENERATOR
cC     SETTING SEEDS
cC-----------------------------------------------------------------------
c      IMPLICIT NONE
c      DOUBLE PRECISION HWRSET
c      COMMON/HWSEED/ISEED(2)
c      INTEGER ISEED
c      INTEGER JSEED(2)
c      HWRSET=0.0D0
c      IF (JSEED(1).EQ.0.OR.JSEED(2).EQ.0) THEN
c        CALL HWWARN('HWRSET',99)
c        GOTO 999
c      ENDIF
c      ISEED(1)=JSEED(1)
c      ISEED(2)=JSEED(2)
c 999  RETURN
c      END
cCDECK  ID>, HWRGET.
c*CMZ :-        -26/04/91  12.42.30  by  Federico Carminati
c*-- Author :    F. James, modified by Mike Seymour
cC-----------------------------------------------------------------------
c      FUNCTION HWRGET(JSEED)
cC-----------------------------------------------------------------------
cC     MAIN RANDOM NUMBER GENERATOR
cC     GET SEEDS
cC-----------------------------------------------------------------------
c      IMPLICIT NONE
c      DOUBLE PRECISION HWRGET
c      COMMON/HWSEED/ISEED(2)
c      INTEGER ISEED
c      INTEGER JSEED(2)
cC
c      JSEED(1)=ISEED(1)
c      JSEED(2)=ISEED(2)
c      HWRGET=0.0D0
c      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-----------------------------------------------------------------------
      IMPLICIT NONE
      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-----------------------------------------------------------------------
      IMPLICIT NONE
      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 'HERWIG65.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-----------------------------------------------------------------------
      IMPLICIT NONE
      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)
        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
      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-----------------------------------------------------------------------
      IMPLICIT NONE
      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-----------------------------------------------------------------------
      IMPLICIT NONE
      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 'HERWIG65.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,EMB2,PTMX
      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
      SAVE ISUD,DMIN
      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) THEN
          CALL HWWARN('HWSBRN',107)
          GOTO 999
        ENDIF
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) THEN
              CALL HWWARN('HWSBRN',ISLENT*105)
              GOTO 999
            ENDIF
            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*FSHWR,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*FSHWR,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) THEN
                CALL HWWARN('HWSBRN',103)
                GOTO 999
              ENDIF
              CALL HWSFUN(XLAST,QEV(NB,IS)*FSHWR,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) THEN
                    CALL HWWARN('HWSBRN',100)
                    GOTO 999
                  ENDIF
                  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)
                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) THEN
              CALL HWWARN('HWSBRN',102)
              GOTO 999
            ENDIF
            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) THEN
              CALL HWWARN('HWSBRN',109)
              GOTO 999
            ENDIF
            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) THEN
                CALL HWWARN('HWSBRN',110)
                GOTO 999
              ENDIF
              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) THEN
              CALL HWWARN('HWSBRN',108)
              GOTO 999
            ENDIF
            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) THEN
                CALL HWWARN('HWSBRN',104)
                GOTO 999
              ENDIF
              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
C---BRW MOD: INCLUDE HIGHER ORDER CORRECTION IN MASS CALCULATION
c$$$          PPAR(5,KPAR)=-(RMASS(ID)**2*XLAST+PTINT(3,JNHAD))/(1.-XLAST)
c$$$     &         +XLAST*SIGN(PHEP(5,INHAD)**2,PHEP(5,INHAD))
          PTMX=(RMASS(ID)**2+PTINT(3,JNHAD))/(ONE-XLAST)
          EMB2=SIGN(PHEP(5,INHAD)**2,PHEP(5,INHAD))
          PPAR(5,KPAR)=-PTINT(3,JNHAD)-XLAST*(PTMX-EMB2)-0.25D0*
     $     ((PTMX-EMB2)**2+XLAST*(PTMX**2/(ONE-XLAST)-EMB2**2))*XFACT**2
C---END BRW MOD
        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  RETURN
      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
        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.
      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
       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
         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/
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 ----------
      HWSDGQ=0
      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.
      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 'HERWIG65.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
      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*FSHWR,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=ZMIN*HWUAEM(-QQ*QQ)*CAFAC*(ZMIN**2+(1.-ZMIN)**2)
     &        *ICHRG(ID)**2/9D0
         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
      END
CDECK  ID>, HWSFUN.
*CMZ :-        -02/05/91  11.30.51  by  Federico Carminati
*-- Author :    Miscellaneous, combined by Bryan Webber
C-----------------------------------------------------------------------
      SUBROUTINE HWSFUN(XIN,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     IF (X.LT.PDFX0) REPLACE X*F(X) BY PDFX0*F(PDFX0)*(X/PDFX0)**PDFPOW
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-----------------------------------------------------------------------
C---BRW change 27/8/04: include Frixione's fix to reduce PDFSET calls
C-----------------------------------------------------------------------
      INCLUDE 'HERWIG65.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)
      DOUBLE PRECISION XIN,PDFFAC
      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)
      CHARACTER*20 PARMSAVE
      DOUBLE PRECISION VALSAVE
      COMMON/HWSFSA/PARMSAVE
      COMMON/HWSFSB/VALSAVE
      EXTERNAL HWSGAM,HWSDGG,HWSDGQ
      SAVE QOLD,IOLD,NOLD,XOLD,SS,S,T,TMIN,TMAX,G,A,TX,TT,TB,IP,NX
      SAVE PDFWRX,PDFWRQ,B,BB,NEHLQ,CEHLQ,TBMIN,TTMIN,DMIN,Q0,QL
      DATA PDFWRX,PDFWRQ/8*.TRUE./
      DATA (((B(I,J,K,1),I=1,3),J=1,6),K=1,5)/
     &3.D0,0.D0,0.D0,.419D0,.004383D0,-.007412D0,
     &3.46D0,.72432D0,-.065998D0,4.4D0,-4.8644D0,1.3274D0,
     &6*0.D0,1.D0,
     &0.D0,0.D0,.763D0,-.23696D0,.025836D0,4.D0,.62664D0,-.019163D0,
     &0.D0,-.42068D0,.032809D0,6*0.D0,1.265D0,-1.1323D0,.29268D0,
     &0.D0,-.37162D0,-.028977D0,8.05D0,1.5877D0,-.15291D0,
     &0.D0,6.3059D0,-.27342D0,0.D0,-10.543D0,-3.1674D0,
     &0.D0,14.698D0,9.798D0,0.D0,.13479D0,-.074693D0,
     &-.0355D0,-.22237D0,-.057685D0,6.3494D0,3.2649D0,-.90945D0,
     &0.D0,-3.0331D0,1.5042D0,0.D0,17.431D0,-11.255D0,
     &0.D0,-17.861D0,15.571D0,1.564D0,-1.7112D0,.63751D0,
     &0.D0,-.94892D0,.32505D0,6.D0,1.4345D0,-1.0485D0,
     &9.D0,-7.1858D0,.25494D0,0.D0,-16.457D0,10.947D0,
     &0.D0,15.261D0,-10.085D0/
      DATA (((B(I,J,K,2),I=1,3),J=1,6),K=1,5)/
     &3.D0,0.D0,0.D0,.3743D0,.013946D0,-.00031695D0,
     &3.329D0,.75343D0,-.076125D0,6.032D0,-6.2153D0,1.5561D0,
     &6*0.D0,1.D0,0.D0,
     &0.D0,.7608D0,-.2317D0,.023232D0,3.83D0,.62746D0,-.019155D0,
     &0.D0,-.41843D0,.035972D0,6*0.D0,1.6714D0,-1.9168D0,.58175D0,
     &0.D0,-.27307D0,-.16392D0,9.145D0,.53045D0,-.76271D0,
     &0.D0,15.665D0,-2.8341D0,0.D0,-100.63D0,44.658D0,
     &0.D0,223.24D0,-116.76D0,0.D0,.067368D0,-.030574D0,
     &-.11989D0,-.23293D0,-.023273D0,3.5087D0,3.6554D0,-.45313D0,
     &0.D0,-.47369D0,.35793D0,0.D0,9.5041D0,-5.4303D0,
     &0.D0,-16.563D0,15.524D0,.8789D0,-.97093D0,.43388D0,
     &0.D0,-1.1612D0,.4759D0,4.D0,1.2271D0,-.25369D0,
     &9.D0,-5.6354D0,-.81747D0,0.D0,-7.5438D0,5.5034D0,
     &0.D0,-.59649D0,.12611D0/
      DATA (((B(I,J,K,3),I=1,3),J=1,6),K=1,5)/
     &1.D0,0.D0,0.D0,0.4D0,-0.06212D0,-0.007109D0,0.7D0,0.6478D0,
     &0.01335D0,27*0.D0,0.9D0,-0.2428D0,0.1386D0,0.D0,-0.2120D0,
     &0.003671D0,5.0D0,0.8673D0,0.04747D0,
     &0.D0,1.266D0,-2.215D0,0.D0,2.382D0,0.3482D0,3*0.D0,
     &0.D0,0.07928D0,-0.06134D0,-0.02212D0,-0.3785D0,-0.1088D0,2.894D0,
     &9.433D0,
     &-10.852D0,0.D0,5.248D0,-7.187D0,0.D0,8.388D0,-11.61D0,3*0.D0,
     &0.888D0,-1.802D0,1.812D0,0.D0,-1.576D0,1.20D0,3.11D0,-0.1317D0,
     &0.5068D0,6.0D0,2.801D0,-12.16D0,0.D0,-17.28D0,20.49D0,3*0.D0/
      DATA (((B(I,J,K,4),I=1,3),J=1,6),K=1,5)/
     &1.D0,0.D0,0.D0,0.4D0,-0.05909D0,-0.006524D0,0.628D0,0.6436D0,
     &0.01451D0,27*0.D0,
     &0.90D0,-0.1417D0,-0.1740D0,0.D0,-0.1697D0,-0.09623D0,5.0D0,
     &-2.474D0,1.575D0,
     &0.D0,-2.534D0,1.378D0,0.D0,0.5621D0,-0.2701D0,3*0.D0,
     &0.D0,0.06229D0,-0.04099D0,-0.0882D0,-0.2892D0,-0.1082D0,1.924D0,
     &0.2424D0,
     &2.036D0,0.D0,-4.463D0,5.209D0,0.D0,-0.8367D0,-0.04840D0,3*0.D0,
     &0.794D0,-0.9144D0,0.5966D0,0.D0,-1.237D0,0.6582D0,2.89D0,0.5966D0,
     &-0.2550D0,
     &6.0D0,-3.671D0,-2.304D0,0.D0,-8.191D0,7.758D0,3*0.D0/
C---COEFFTS FOR NEW OWENS 1.1 SET
      DATA BB/3.D0,3*0.D0,.665D0,-.1097D0,-.002442D0,0.D0,
     &3.614D0,.8395D0,-.02186D0,0.D0,.8673D0,-1.6637D0,.342D0,0.D0,
     &0.D0,1.1049D0,-.2369D0,5*0.D0,1.D0,3*0.D0,
     &.8388D0,-.2092D0,.02657D0,0.D0,4.667D0,.7951D0,.1081D0,0.D0,
     &0.D0,-1.0232D0,.05799D0,0.D0,0.D0,.8616D0,.153D0,5*0.D0,
     &.909D0,-.4023D0,.006305D0,0.D0,
     &0.D0,-.3823D0,.02766D0,0.D0,7.278D0,-.7904D0,.8108D0,0.D0,
     &0.D0,-1.6629D0,.5719D0,0.D0,0.D0,-.01333D0,.5299D0,0.D0,
     &0.D0,.1211D0,-.1739D0,0.D0,0.D0,.09469D0,-.07066D0,.01236D0,
     &-.1447D0,-.402D0,.1533D0,-.06479D0,6.7599D0,1.6596D0,.6798D0,
     &-.8525D0,0.D0,-4.4559D0,3.3756D0,-.9468D0,
     &0.D0,7.862D0,-3.6591D0,.03672D0,0.D0,-.2472D0,-.751D0,.0487D0,
     &3.017D0,-4.7347D0,3.3594D0,-.9443D0,0.D0,-.9342D0,.5454D0,
     &-.1668D0,
     &5.304D0,1.4654D0,-1.4292D0,.7569D0,0.D0,-3.9141D0,2.8445D0,
     &-.8411D0,
     &0.D0,9.0176D0,-10.426D0,4.0983D0,0.D0,-5.9602D0,7.515D0,-2.7329D0/
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.677D-01,-2.087D-01,-3.303D-01,-2.517D-02,-1.570D-02,-1.000D-04,
     2-5.326D-01,-2.661D-01, 3.201D-01, 1.192D-01, 2.434D-02, 7.620D-03,
     3 2.162D-01, 1.881D-01,-8.375D-02,-6.515D-02,-1.743D-02,-5.040D-03,
     4-9.211D-02,-9.952D-02, 1.373D-02, 2.506D-02, 8.770D-03, 2.550D-03,
     5 3.670D-02, 4.409D-02, 9.600D-04,-7.960D-03,-3.420D-03,-1.050D-03,
     6-1.549D-02,-2.026D-02,-3.060D-03, 2.220D-03, 1.240D-03, 4.100D-04,
     1 2.395D-01, 2.905D-01, 9.778D-02, 2.149D-02, 3.440D-03, 5.000D-04,
     2 1.751D-02,-6.090D-03,-2.687D-02,-1.916D-02,-7.970D-03,-2.750D-03,
     3-5.760D-03,-5.040D-03, 1.080D-03, 2.490D-03, 1.530D-03, 7.500D-04,
     4 1.740D-03, 1.960D-03, 3.000D-04,-3.400D-04,-2.900D-04,-1.800D-04,
     5-5.300D-04,-6.400D-04,-1.700D-04, 4.000D-05, 6.000D-05, 4.000D-05,
     6 1.700D-04, 2.200D-04, 8.000D-05, 1.000D-05,-1.000D-05,-1.000D-05/
      DATA (((CEHLQ(IX,IT,NX,1,2),IX=1,6),IT=1,6),NX=1,2)/
     1 7.237D-01,-2.189D-01,-2.995D-01,-1.909D-02,-1.477D-02, 2.500D-04,
     2-5.314D-01,-2.425D-01, 3.283D-01, 1.119D-01, 2.223D-02, 7.070D-03,
     3 2.289D-01, 1.890D-01,-9.859D-02,-6.900D-02,-1.747D-02,-5.080D-03,
     4-1.041D-01,-1.084D-01, 2.108D-02, 2.975D-02, 9.830D-03, 2.830D-03,
     5 4.394D-02, 5.116D-02,-1.410D-03,-1.055D-02,-4.230D-03,-1.270D-03,
     6-1.991D-02,-2.539D-02,-2.780D-03, 3.430D-03, 1.720D-03, 5.500D-04,
     1 2.410D-01, 2.884D-01, 9.369D-02, 1.900D-02, 2.530D-03, 2.400D-04,
     2 1.765D-02,-9.220D-03,-3.037D-02,-2.085D-02,-8.440D-03,-2.810D-03,
     3-6.450D-03,-5.260D-03, 1.720D-03, 3.110D-03, 1.830D-03, 8.700D-04,
     4 2.120D-03, 2.320D-03, 2.600D-04,-4.900D-04,-3.900D-04,-2.300D-04,
     5-6.900D-04,-8.200D-04,-2.000D-04, 7.000D-05, 9.000D-05, 6.000D-05,
     6 2.400D-04, 3.100D-04, 1.100D-04, 0.000D+00,-2.000D-05,-2.000D-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.813D-01,-8.090D-02,-1.634D-01,-2.185D-02,-8.430D-03,-6.200D-04,
     2-2.948D-01,-1.435D-01, 1.665D-01, 6.638D-02, 1.473D-02, 4.080D-03,
     3 1.252D-01, 1.042D-01,-4.722D-02,-3.683D-02,-1.038D-02,-2.860D-03,
     4-5.478D-02,-5.678D-02, 8.900D-03, 1.484D-02, 5.340D-03, 1.520D-03,
     5 2.220D-02, 2.567D-02,-3.000D-05,-4.970D-03,-2.160D-03,-6.500D-04,
     6-9.530D-03,-1.204D-02,-1.510D-03, 1.510D-03, 8.300D-04, 2.700D-04,
     1 1.261D-01, 1.354D-01, 3.958D-02, 8.240D-03, 1.660D-03, 4.500D-04,
     2 3.890D-03,-1.159D-02,-1.625D-02,-9.610D-03,-3.710D-03,-1.260D-03,
     3-1.910D-03,-5.600D-04, 1.590D-03, 1.590D-03, 8.400D-04, 3.900D-04,
     4 6.400D-04, 4.900D-04,-1.500D-04,-2.900D-04,-1.800D-04,-1.000D-04,
     5-2.000D-04,-1.900D-04, 0.000D+00, 6.000D-05, 4.000D-05, 3.000D-05,
     6 7.000D-05, 8.000D-05, 2.000D-05,-1.000D-05,-1.000D-05,-1.000D-05/
      DATA (((CEHLQ(IX,IT,NX,2,2),IX=1,6),IT=1,6),NX=1,2)/
     1 3.578D-01,-8.622D-02,-1.480D-01,-1.840D-02,-7.820D-03,-4.500D-04,
     2-2.925D-01,-1.304D-01, 1.696D-01, 6.243D-02, 1.353D-02, 3.750D-03,
     3 1.318D-01, 1.041D-01,-5.486D-02,-3.872D-02,-1.038D-02,-2.850D-03,
     4-6.162D-02,-6.143D-02, 1.303D-02, 1.740D-02, 5.940D-03, 1.670D-03,
     5 2.643D-02, 2.957D-02,-1.490D-03,-6.450D-03,-2.630D-03,-7.700D-04,
     6-1.218D-02,-1.497D-02,-1.260D-03, 2.240D-03, 1.120D-03, 3.500D-04,
     1 1.263D-01, 1.334D-01, 3.732D-02, 7.070D-03, 1.260D-03, 3.400D-04,
     2 3.660D-03,-1.357D-02,-1.795D-02,-1.031D-02,-3.880D-03,-1.280D-03,
     3-2.100D-03,-3.600D-04, 2.050D-03, 1.920D-03, 9.800D-04, 4.400D-04,
     4 7.700D-04, 5.400D-04,-2.400D-04,-3.900D-04,-2.400D-04,-1.300D-04,
     5-2.600D-04,-2.300D-04, 2.000D-05, 9.000D-05, 6.000D-05, 4.000D-05,
     6 9.000D-05, 1.000D-04, 2.000D-05,-2.000D-05,-2.000D-05,-1.000D-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.870D-02,-6.861D-02, 2.973D-02,-5.400D-03, 3.780D-03,-9.700D-04,
     2-1.802D-02, 1.400D-04, 6.490D-03,-8.540D-03, 1.220D-03,-1.750D-03,
     3-4.650D-03, 1.480D-03,-5.930D-03, 6.000D-04,-1.030D-03,-8.000D-05,
     4 6.440D-03, 2.570D-03, 2.830D-03, 1.150D-03, 7.100D-04, 3.300D-04,
     5-3.930D-03,-2.540D-03,-1.160D-03,-7.700D-04,-3.600D-04,-1.900D-04,
     6 2.340D-03, 1.930D-03, 5.300D-04, 3.700D-04, 1.600D-04, 9.000D-05,
     1 1.014D+00,-1.106D+00, 3.374D-01,-7.444D-02, 8.850D-03,-8.700D-04,
     2 9.233D-01,-1.285D+00, 4.475D-01,-9.786D-02, 1.419D-02,-1.120D-03,
     3 4.888D-02,-1.271D-01, 8.606D-02,-2.608D-02, 4.780D-03,-6.000D-04,
     4-2.691D-02, 4.887D-02,-1.771D-02, 1.620D-03, 2.500D-04,-6.000D-05,
     5 7.040D-03,-1.113D-02, 1.590D-03, 7.000D-04,-2.000D-04, 0.000D+00,
     6-1.710D-03, 2.290D-03, 3.800D-04,-3.500D-04, 4.000D-05, 1.000D-05/
      DATA (((CEHLQ(IX,IT,NX,3,2),IX=1,6),IT=1,6),NX=1,2)/
     1 1.008D-01,-7.100D-02, 1.973D-02,-5.710D-03, 2.930D-03,-9.900D-04,
     2-5.271D-02,-1.823D-02, 1.792D-02,-6.580D-03, 1.750D-03,-1.550D-03,
     3 1.220D-02, 1.763D-02,-8.690D-03,-8.800D-04,-1.160D-03,-2.100D-04,
     4-1.190D-03,-7.180D-03, 2.360D-03, 1.890D-03, 7.700D-04, 4.100D-04,
     5-9.100D-04, 2.040D-03,-3.100D-04,-1.050D-03,-4.000D-04,-2.400D-04,
     6 1.190D-03,-1.700D-04,-2.000D-04, 4.200D-04, 1.700D-04, 1.000D-04,
     1 1.081D+00,-1.189D+00, 3.868D-01,-8.617D-02, 1.115D-02,-1.180D-03,
     2 9.917D-01,-1.396D+00, 4.998D-01,-1.159D-01, 1.674D-02,-1.720D-03,
     3 5.099D-02,-1.338D-01, 9.173D-02,-2.885D-02, 5.890D-03,-6.500D-04,
     4-3.178D-02, 5.703D-02,-2.070D-02, 2.440D-03, 1.100D-04,-9.000D-05,
     5 8.970D-03,-1.392D-02, 2.050D-03, 6.500D-04,-2.300D-04, 2.000D-05,
     6-2.340D-03, 3.010D-03, 5.000D-04,-3.900D-04, 6.000D-05, 1.000D-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.482D-01,-9.578D-01, 1.009D-01,-1.051D-01, 3.456D-02,-3.054D-02,
     2-9.627D-01, 5.379D-01, 3.368D-01,-9.525D-02, 1.488D-02,-2.051D-02,
     3 4.300D-01,-8.306D-02,-3.372D-01, 4.902D-02,-9.160D-03, 1.041D-02,
     4-1.925D-01,-1.790D-02, 2.183D-01, 7.490D-03, 4.140D-03,-1.860D-03,
     5 8.183D-02, 1.926D-02,-1.072D-01,-1.944D-02,-2.770D-03,-5.200D-04,
     6-3.884D-02,-1.234D-02, 5.410D-02, 1.879D-02, 3.350D-03, 1.040D-03,
     1 2.948D+01,-3.902D+01, 1.464D+01,-3.335D+00, 5.054D-01,-5.915D-02,
     2 2.559D+01,-3.955D+01, 1.661D+01,-4.299D+00, 6.904D-01,-8.243D-02,
     3-1.663D+00, 1.176D+00, 1.118D+00,-7.099D-01, 1.948D-01,-2.404D-02,
     4-2.168D-01, 8.170D-01,-7.169D-01, 1.851D-01,-1.924D-02,-3.250D-03,
     5 2.088D-01,-4.355D-01, 2.239D-01,-2.446D-02,-3.620D-03, 1.910D-03,
     6-9.097D-02, 1.601D-01,-5.681D-02,-2.500D-03, 2.580D-03,-4.700D-04/
      DATA (((CEHLQ(IX,IT,NX,4,2),IX=1,6),IT=1,6),NX=1,2)/
     1 2.367D+00, 4.453D-01, 3.660D-01, 9.467D-02, 1.341D-01, 1.661D-02,
     2-3.170D+00,-1.795D+00, 3.313D-02,-2.874D-01,-9.827D-02,-7.119D-02,
     3 1.823D+00, 1.457D+00,-2.465D-01, 3.739D-02, 6.090D-03, 1.814D-02,
     4-1.033D+00,-9.827D-01, 2.136D-01, 1.169D-01, 5.001D-02, 1.684D-02,
     5 5.133D-01, 5.259D-01,-1.173D-01,-1.139D-01,-4.988D-02,-2.021D-02,
     6-2.881D-01,-3.145D-01, 5.667D-02, 9.161D-02, 4.568D-02, 1.951D-02,
     1 3.036D+01,-4.062D+01, 1.578D+01,-3.699D+00, 6.020D-01,-7.031D-02,
     2 2.700D+01,-4.167D+01, 1.770D+01,-4.804D+00, 7.862D-01,-1.060D-01,
     3-1.909D+00, 1.357D+00, 1.127D+00,-7.181D-01, 2.232D-01,-2.481D-02,
     4-2.488D-01, 9.781D-01,-8.127D-01, 2.094D-01,-2.997D-02,-4.710D-03,
     5 2.506D-01,-5.427D-01, 2.672D-01,-3.103D-02,-1.800D-03, 2.870D-03,
     6-1.128D-01, 2.087D-01,-6.972D-02,-2.480D-03, 2.630D-03,-8.400D-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.968D-02,-4.173D-02, 2.102D-02,-3.270D-03, 3.240D-03,-6.700D-04,
     2-6.150D-03,-1.294D-02, 6.740D-03,-6.890D-03, 9.000D-04,-1.510D-03,
     3-8.580D-03, 5.050D-03,-4.900D-03,-1.600D-04,-9.400D-04,-1.500D-04,
     4 7.840D-03, 1.510D-03, 2.220D-03, 1.400D-03, 7.000D-04, 3.500D-04,
     5-4.410D-03,-2.220D-03,-8.900D-04,-8.500D-04,-3.600D-04,-2.000D-04,
     6 2.520D-03, 1.840D-03, 4.100D-04, 3.900D-04, 1.600D-04, 9.000D-05,
     1 9.235D-01,-1.085D+00, 3.464D-01,-7.210D-02, 9.140D-03,-9.100D-04,
     2 9.315D-01,-1.274D+00, 4.512D-01,-9.775D-02, 1.380D-02,-1.310D-03,
     3 4.739D-02,-1.296D-01, 8.482D-02,-2.642D-02, 4.760D-03,-5.700D-04,
     4-2.653D-02, 4.953D-02,-1.735D-02, 1.750D-03, 2.800D-04,-6.000D-05,
     5 6.940D-03,-1.132D-02, 1.480D-03, 6.500D-04,-2.100D-04, 0.000D+00,
     6-1.680D-03, 2.340D-03, 4.200D-04,-3.400D-04, 5.000D-05, 1.000D-05/
      DATA (((CEHLQ(IX,IT,NX,5,2),IX=1,6),IT=1,6),NX=1,2)/
     1 6.478D-02,-4.537D-02, 1.643D-02,-3.490D-03, 2.710D-03,-6.700D-04,
     2-2.223D-02,-2.126D-02, 1.247D-02,-6.290D-03, 1.120D-03,-1.440D-03,
     3-1.340D-03, 1.362D-02,-6.130D-03,-7.900D-04,-9.000D-04,-2.000D-04,
     4 5.080D-03,-3.610D-03, 1.700D-03, 1.830D-03, 6.800D-04, 4.000D-04,
     5-3.580D-03, 6.000D-05,-2.600D-04,-1.050D-03,-3.800D-04,-2.300D-04,
     6 2.420D-03, 9.300D-04,-1.000D-04, 4.500D-04, 1.700D-04, 1.100D-04,
     1 9.868D-01,-1.171D+00, 3.940D-01,-8.459D-02, 1.124D-02,-1.250D-03,
     2 1.001D+00,-1.383D+00, 5.044D-01,-1.152D-01, 1.658D-02,-1.830D-03,
     3 4.928D-02,-1.368D-01, 9.021D-02,-2.935D-02, 5.800D-03,-6.600D-04,
     4-3.133D-02, 5.785D-02,-2.023D-02, 2.630D-03, 1.600D-04,-8.000D-05,
     5 8.840D-03,-1.416D-02, 1.900D-03, 5.800D-04,-2.500D-04, 1.000D-05,
     6-2.300D-03, 3.080D-03, 5.500D-04,-3.700D-04, 7.000D-05, 1.000D-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.270D-03,-1.817D-02, 9.590D-03,-6.390D-03, 1.690D-03,-1.540D-03,
     2 5.710D-03,-1.188D-02, 6.090D-03,-4.650D-03, 1.240D-03,-1.310D-03,
     3-3.960D-03, 7.100D-03,-3.590D-03, 1.840D-03,-3.900D-04, 3.400D-04,
     4 1.120D-03,-1.960D-03, 1.120D-03,-4.800D-04, 1.000D-04,-4.000D-05,
     5 4.000D-05,-3.000D-05,-1.800D-04, 9.000D-05,-5.000D-05,-2.000D-05,
     6-4.200D-04, 7.300D-04,-1.600D-04, 5.000D-05, 5.000D-05, 5.000D-05,
     1 8.098D-01,-1.042D+00, 3.398D-01,-6.824D-02, 8.760D-03,-9.000D-04,
     2 8.961D-01,-1.217D+00, 4.339D-01,-9.287D-02, 1.304D-02,-1.290D-03,
     3 3.058D-02,-1.040D-01, 7.604D-02,-2.415D-02, 4.600D-03,-5.000D-04,
     4-2.451D-02, 4.432D-02,-1.651D-02, 1.430D-03, 1.200D-04,-1.000D-04,
     5 1.122D-02,-1.457D-02, 2.680D-03, 5.800D-04,-1.200D-04, 3.000D-05,
     6-7.730D-03, 7.330D-03,-7.600D-04,-2.400D-04, 1.000D-05, 0.000D+00/
      DATA (((CEHLQ(IX,IT,NX,6,2),IX=1,6),IT=1,6),NX=1,2)/
     1 9.980D-03,-1.945D-02, 1.055D-02,-6.870D-03, 1.860D-03,-1.560D-03,
     2 5.700D-03,-1.203D-02, 6.250D-03,-4.860D-03, 1.310D-03,-1.370D-03,
     3-4.490D-03, 7.990D-03,-4.170D-03, 2.050D-03,-4.400D-04, 3.300D-04,
     4 1.470D-03,-2.480D-03, 1.460D-03,-5.700D-04, 1.200D-04,-1.000D-05,
     5-9.000D-05, 1.500D-04,-3.200D-04, 1.200D-04,-6.000D-05,-4.000D-05,
     6-4.200D-04, 7.600D-04,-1.400D-04, 4.000D-05, 7.000D-05, 5.000D-05,
     1 8.698D-01,-1.131D+00, 3.836D-01,-8.111D-02, 1.048D-02,-1.300D-03,
     2 9.626D-01,-1.321D+00, 4.854D-01,-1.091D-01, 1.583D-02,-1.700D-03,
     3 3.057D-02,-1.088D-01, 8.022D-02,-2.676D-02, 5.590D-03,-5.600D-04,
     4-2.845D-02, 5.164D-02,-1.918D-02, 2.210D-03,-4.000D-05,-1.500D-04,
     5 1.311D-02,-1.751D-02, 3.310D-03, 5.100D-04,-1.200D-04, 5.000D-05,
     6-8.590D-03, 8.380D-03,-9.200D-04,-2.600D-04, 1.000D-05,-1.000D-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.010D-03,-1.401D-02, 7.150D-03,-4.130D-03, 1.260D-03,-1.040D-03,
     2 6.280D-03,-9.320D-03, 4.780D-03,-2.890D-03, 9.100D-04,-8.200D-04,
     3-2.930D-03, 4.090D-03,-1.890D-03, 7.600D-04,-2.300D-04, 1.400D-04,
     4 3.900D-04,-1.200D-03, 4.400D-04,-2.500D-04, 2.000D-05,-2.000D-05,
     5 2.600D-04, 1.400D-04,-8.000D-05, 1.000D-04, 1.000D-05, 1.000D-05,
     6-2.600D-04, 3.200D-04, 1.000D-05,-1.000D-05, 1.000D-05,-1.000D-05,
     1 8.029D-01,-1.075D+00, 3.792D-01,-7.843D-02, 1.007D-02,-1.090D-03,
     2 7.903D-01,-1.099D+00, 4.153D-01,-9.301D-02, 1.317D-02,-1.410D-03,
     3-1.704D-02,-1.130D-02, 2.882D-02,-1.341D-02, 3.040D-03,-3.600D-04,
     4-7.200D-04, 7.230D-03,-5.160D-03, 1.080D-03,-5.000D-05,-4.000D-05,
     5 3.050D-03,-4.610D-03, 1.660D-03,-1.300D-04,-1.000D-05, 1.000D-05,
     6-4.360D-03, 5.230D-03,-1.610D-03, 2.000D-04,-2.000D-05, 0.000D+00/
      DATA (((CEHLQ(IX,IT,NX,7,2),IX=1,6),IT=1,6),NX=1,2)/
     1 8.980D-03,-1.459D-02, 7.510D-03,-4.410D-03, 1.310D-03,-1.070D-03,
     2 5.970D-03,-9.440D-03, 4.800D-03,-3.020D-03, 9.100D-04,-8.500D-04,
     3-3.050D-03, 4.440D-03,-2.100D-03, 8.500D-04,-2.400D-04, 1.400D-04,
     4 5.300D-04,-1.300D-03, 5.600D-04,-2.700D-04, 3.000D-05,-2.000D-05,
     5 2.000D-04, 1.400D-04,-1.100D-04, 1.000D-04, 0.000D+00, 0.000D+00,
     6-2.600D-04, 3.200D-04, 0.000D+00,-3.000D-05, 1.000D-05,-1.000D-05,
     1 8.672D-01,-1.174D+00, 4.265D-01,-9.252D-02, 1.244D-02,-1.460D-03,
     2 8.500D-01,-1.194D+00, 4.630D-01,-1.083D-01, 1.614D-02,-1.830D-03,
     3-2.241D-02,-5.630D-03, 2.815D-02,-1.425D-02, 3.520D-03,-4.300D-04,
     4-7.300D-04, 8.030D-03,-5.780D-03, 1.380D-03,-1.300D-04,-4.000D-05,
     5 3.460D-03,-5.380D-03, 1.960D-03,-2.100D-04, 1.000D-05, 1.000D-05,
     6-4.850D-03, 5.950D-03,-1.890D-03, 2.600D-04,-3.000D-05, 0.000D+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.410D-03,-7.480D-03, 3.770D-03,-2.580D-03, 7.300D-04,-7.100D-04,
     2 3.840D-03,-6.050D-03, 3.030D-03,-2.030D-03, 5.800D-04,-5.900D-04,
     3-8.800D-04, 1.660D-03,-7.500D-04, 4.700D-04,-1.000D-04, 1.000D-04,
     4-8.000D-05,-1.500D-04, 1.200D-04,-9.000D-05, 3.000D-05, 0.000D+00,
     5 1.300D-04,-2.200D-04,-2.000D-05,-2.000D-05,-2.000D-05,-2.000D-05,
     6-7.000D-05, 1.900D-04,-4.000D-05, 2.000D-05, 0.000D+00, 0.000D+00,
     1 6.623D-01,-9.248D-01, 3.519D-01,-7.930D-02, 1.110D-02,-1.180D-03,
     2 6.380D-01,-9.062D-01, 3.582D-01,-8.479D-02, 1.265D-02,-1.390D-03,
     3-2.581D-02, 2.125D-02, 4.190D-03,-4.980D-03, 1.490D-03,-2.100D-04,
     4 7.100D-04, 5.300D-04,-1.270D-03, 3.900D-04,-5.000D-05,-1.000D-05,
     5 3.850D-03,-5.060D-03, 1.860D-03,-3.500D-04, 4.000D-05, 0.000D+00,
     6-3.530D-03, 4.460D-03,-1.500D-03, 2.700D-04,-3.000D-05, 0.000D+00/
      DATA (((CEHLQ(IX,IT,NX,8,2),IX=1,6),IT=1,6),NX=1,2)/
     1 4.260D-03,-7.530D-03, 3.830D-03,-2.680D-03, 7.600D-04,-7.300D-04,
     2 3.640D-03,-6.050D-03, 3.030D-03,-2.090D-03, 5.900D-04,-6.000D-04,
     3-9.200D-04, 1.710D-03,-8.200D-04, 5.000D-04,-1.200D-04, 1.000D-04,
     4-5.000D-05,-1.600D-04, 1.300D-04,-9.000D-05, 3.000D-05, 0.000D+00,
     5 1.300D-04,-2.100D-04,-1.000D-05,-2.000D-05,-2.000D-05,-1.000D-05,
     6-8.000D-05, 1.800D-04,-5.000D-05, 2.000D-05, 0.000D+00, 0.000D+00,
     1 7.146D-01,-1.007D+00, 3.932D-01,-9.246D-02, 1.366D-02,-1.540D-03,
     2 6.856D-01,-9.828D-01, 3.977D-01,-9.795D-02, 1.540D-02,-1.790D-03,
     3-3.053D-02, 2.758D-02, 2.150D-03,-4.880D-03, 1.640D-03,-2.500D-04,
     4 9.200D-04, 4.200D-04,-1.340D-03, 4.600D-04,-8.000D-05,-1.000D-05,
     5 4.230D-03,-5.660D-03, 2.140D-03,-4.300D-04, 6.000D-05, 0.000D+00,
     6-3.890D-03, 5.000D-03,-1.740D-03, 3.300D-04,-4.000D-05, 0.000D+00/
      DATA TBMIN,TTMIN/8.1905D0,7.4474D0,11.5528D0,10.8097D0/
      DATA XOLD,QOLD,IOLD,NOLD/-1.D0,0.D0,0,0/
      DATA DMIN,Q0,QL/0.D0,2*2.D0,2*2.236D0,2.D0,.2D0,
     &                .4D0,.2D0,.29D0,.177D0/
C---X IS EQUAL TO XIN, UNLESS IT IS LESS THAN PDFX0
      X=MAX(XIN,PDFX0)
      IF (X.LE.ZERO) THEN
        CALL HWWARN('HWSFUN',100)
        GOTO 999
      ENDIF
      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=SNGL(X)
            IF (    XSP.LE.ZERO) THEN
              CALL HWWARN('HWSFUN',102)
              GOTO 999
            ENDIF
            IF (ONE-XSP.LE.ZERO) THEN
              CALL HWWARN('HWSFUN',103)
              GOTO 999
            ENDIF
            Q2=SNGL(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=SNGL(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
            IF(PARM(1).NE.PARMSAVE.OR.VAL(1).NE.VALSAVE)THEN
              PARMSAVE=PARM(1)
              VALSAVE=VAL(1)
              CALL PDFSET(PARM,VAL)
            ENDIF
            IF (X.LT.PDFXMN.AND.PDFWRX(IBEAM,1) .OR.
     &          X.GT.PDFXMX.AND.PDFWRX(IBEAM,2)) THEN
              CALL HWWARN('HWSFUN',2)
              WRITE (6,'(2A)') ' WARNING: PDFLIB CALLED WITH X',
     &             ' OUTSIDE ALLOWED RANGE!'
              WRITE (6,'(1P,3(A,E10.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)
              WRITE (6,'(2A)') ' WARNING: PDFLIB CALLED WITH Q',
     &             ' OUTSIDE ALLOWED RANGE!'
              WRITE (6,'(1P,3(A,E10.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=SNGL(X)
          IF (    XSP.LE.ZERO) THEN
            CALL HWWARN('HWSFUN',102)
            GOTO 999
          ENDIF
          IF (ONE-XSP.LE.ZERO) THEN
            CALL HWWARN('HWSFUN',103)
            GOTO 999
          ENDIF
          Q2=SNGL(SCALEF**2)
          W2=Q2*(1-XSP)/XSP
          EMC2=SNGL(4*RMASS(4)**2)
          EMB2=SNGL(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)
          ENDIF
        ENDIF
        GOTO 900
      ENDIF
      IF (MPDF.GE.0) THEN
C---USE PDFLIB NUCLEON STRUCTURE FUNCTIONS
        PARM(1)=AUTPDF(IBEAM)
        VAL(1)=FLOAT(MPDF)
        IF(PARM(1).NE.PARMSAVE.OR.VAL(1).NE.VALSAVE)THEN
          PARMSAVE=PARM(1)
          VALSAVE=VAL(1)
          CALL PDFSET(PARM,VAL)
        ENDIF
        IF (X.LT.PDFXMN.AND.PDFWRX(IBEAM,1) .OR.
     &      X.GT.PDFXMX.AND.PDFWRX(IBEAM,2)) THEN
          CALL HWWARN('HWSFUN',4)
          WRITE (6,'(2A)') ' WARNING: PDFLIB CALLED WITH X',
     &         ' OUTSIDE ALLOWED RANGE!'
          WRITE (6,'(1P,3(A,E10.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)
          WRITE (6,'(2A)') ' WARNING: PDFLIB CALLED WITH Q',
     &         ' OUTSIDE ALLOWED RANGE!'
          WRITE (6,'(1P,3(A,E10.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)
C--new MRST98 LO PDF's
      ELSEIF(NSET.GE.6.AND.NSET.LE.8) THEN
        CALL HWSMRS(X,SCALEF,NSET-5,UPV,DNV,USEA,DSEA,STR,CHM,BTM,GLU)
        TOP=ZERO
      ELSE
        IF (NSET.LT.1.OR.NSET.GT.5) CALL HWWARN('HWSFUN',400)
        IF (QSCA.LT.Q0(NSET)) QSCA=Q0(NSET)
        IF (QSCA.NE.QOLD.OR.IDHAD.NE.IOLD.OR.NSET.NE.NOLD) THEN
C---INITIALIZE
          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=ZERO
          TOP=ZERO
          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.AND.NSET.LE.5) THEN
        USEA=SEA
        DSEA=USEA
      ENDIF
      IF(MPDF.LT.0.AND.NSET.GT.2.AND.(IDHAD.EQ.38.OR.IDHAD.EQ.30)) THEN
        WRITE(6,*) '     THIS SET OF PDFS DOES NOT SUPPORT PIONS'
        WRITE(6,*) 'EITHER USE SET NSTRU=1,2 OR A PION SET FROM PDFLIB'
        STOP
      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',401)
      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
C---IF X HAS BEEN FROZEN USE A POWER LAW
      IF (XIN.LT.PDFX0) THEN
        PDFFAC=(XIN/PDFX0)**PDFPOW
        DO 930 I=1,13
          DIST(I)=DIST(I)*PDFFAC
 930    CONTINUE
      ENDIF
 999  RETURN
      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-----------------------------------------------------------------------
      IMPLICIT NONE
      DOUBLE PRECISION HWSGAM,ZINPUT,B(10),HLNTPI,Z,SHIFT,G,T,RECZSQ
      INTEGER I
      SAVE B,HLNTPI
      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 'HERWIG65.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 'HERWIG65.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>, HWSMRS.
*CMZ :-        -26/04/01  10.00.16  by  Peter Richardson
*-- Author :    Dick Roberts, modified by Peter Richardson
C-----------------------------------------------------------------------
      SUBROUTINE HWSMRS(X,Q,MODE,UPV,DNV,USEA,DSEA,STR,CHM,BOT,GLU)
C-----------------------------------------------------------------------
C     MRST98 Leading order PDF's central and higher gluon + average
C-----------------------------------------------------------------------
      INCLUDE 'HERWIG65.INC'
      DOUBLE PRECISION X,Q,UPV,DNV,USEA,DSEA,STR,CHM,BOT,GLU,XMIN,XMAX,
     &     QSQMIN,QSQMAX,Q2,QQ(NQMRS),XXMRS(NXMRS),G(NPMRS),N0(NPMRS),
     &     XSAVE,Q2SAVE,XXX,A,B,FAC
      INTEGER MODE,INIT,NTENTH,N,M,I,J,K,ML,WARN(2)
      PARAMETER(NTENTH=23)
      SAVE INIT,WARN,XMIN,XMAX,QSQMIN,QSQMAX,XXMRS,QQ,N0
      DATA XMIN,XMAX,QSQMIN,QSQMAX/1D-5,1D0,1.25D0,1D7/
      DATA XXMRS/1d-5,2d-5,4d-5,6d-5,8d-5,
     &        1d-4,2d-4,4d-4,6d-4,8d-4,
     &        1d-3,2d-3,4d-3,6d-3,8d-3,
     &        1d-2,1.4d-2,2d-2,3d-2,4d-2,6d-2,8d-2,
     &     .1d0,.125d0,.15d0,.175d0,.2d0,.225d0,.25d0,.275d0,
     &     .3d0,.325d0,.35d0,.375d0,.4d0,.425d0,.45d0,.475d0,
     &     .5d0,.525d0,.55d0,.575d0,.6d0,.65d0,.7d0,.75d0,
     &     .8d0,.9d0,1d0/
      DATA QQ/1.25d0,1.5d0,2d0,2.5d0,3.2d0,4d0,5d0,6.4d0,8d0,1d1,
     &        1.2d1,1.8d1,2.6d1,4d1,6.4d1,1d2,
     &        1.6d2,2.4d2,4d2,6.4d2,1d3,1.8d3,3.2d3,5.6d3,1d4,
     &        1.8d4,3.2d4,5.6d4,1d5,1.8d5,3.2d5,5.6d5,1d6,
     &        1.8d6,3.2d6,5.6d6,1d7/
      DATA N0/3,4,5,9,9,9,9,9/
      DATA INIT,WARN/0,0,0/
      Q2=Q*Q
C--issue warning if x or q out of range
      IF((Q2.LT.QSQMIN.OR.Q2.GT.QSQMAX).AND.WARN(1).EQ.0) THEN
        CALL HWWARN('HWSMRS',5)
        WRITE (6,'(2A)') ' WARNING: MRST98 CALLED WITH Q',
     &         ' OUTSIDE ALLOWED RANGE!'
        WRITE (6,'(1P,3(A,E10.3))') ' Q VALUE=',Q,
     &         ', MINIMUM=',SQRT(QSQMIN),', MAXIMUM=',SQRT(QSQMAX)
        WRITE (6,'(A)') ' NO FURTHER WARNINGS WILL BE ISSUED'
        WARN(1) = 1
      ENDIF
      IF((X.LT.XMIN.OR.X.GT.XMAX).AND.WARN(2).EQ.0) THEN
        CALL HWWARN('HWSMRS',4)
        WRITE (6,'(2A)') ' WARNING: MRST98 CALLED WITH X',
     &         ' OUTSIDE ALLOWED RANGE!'
        WRITE (6,'(1P,3(A,E10.3))') ' X VALUE=',X,
     &         ', MINIMUM=',XMIN,', MAXIMUM=',XMAX
        WRITE (6,'(A)') ' NO FURTHER WARNINGS WILL BE ISSUED'
        WARN(2) = 1
      ENDIF
C--now the evaluation
      XSAVE  = X
      Q2SAVE = Q2
C--first the initialisation
      IF(INIT.NE.0) GOTO 10
      DO 15 ML=3,1,-1
      DO 20 N=1,NXMRS-1
      DO 20 M=1,NQMRS
      DO 20 I=1,NPMRS
c notation: 1=uval 2=val 3=glue 4=usea 5=chm 6=str 7=btm 8=dsea
        IF(ML.LE.2) THEN
          FMRS(ML,I,N,M) = FMRS(ML,I,N,M)/(1.0D0-XXMRS(N))**N0(I)
        ELSE
          FMRS(ML,I,N,M) = 0.5D0*(FMRS(1,I,N,M)+FMRS(2,I,N,M))/
     &                              (1.0D0-XXMRS(N))**N0(I)
        ENDIF
 20   CONTINUE
      DO 31 J=1,NTENTH-1
      DO 31 I=1,8
      IF(I.EQ.5.OR.I.EQ.7) GOTO 31
      DO 30 K=1,NQMRS
 30   FMRS(ML,I,J,K)=DLOG10(FMRS(ML,I,J,K)/FMRS(ML,I,NTENTH,K))
     &                 +FMRS(ML,I,NTENTH,K)
 31   CONTINUE
      DO 40 I=1,NPMRS
      DO 40 M=1,NQMRS
 40   FMRS(ML,I,NXMRS,M)=0.0D0
 15   CONTINUE
      DO 32 J=1,NTENTH-1
 32   XXMRS(J)=DLOG10(XXMRS(J)/XXMRS(NTENTH))+XXMRS(NTENTH)
      INIT=1
 10   CONTINUE
C--check x and q within range of set
      IF(X.LT.XMIN) X=XMIN
      IF(X.GT.XMAX) X=XMAX
      IF(Q2.LT.QSQMIN)  Q2=QSQMIN
      IF(Q2.GT.QSQMAX)  Q2=QSQMAX
C--find X and Q
      XXX=X
      IF(X.LT.XXMRS(NTENTH)) XXX=DLOG10(X/XXMRS(NTENTH))+XXMRS(NTENTH)
      N = 0
 70   N=N+1
      IF(XXX.GT.XXMRS(N+1)) GOTO 70
      A=(XXX-XXMRS(N))/(XXMRS(N+1)-XXMRS(N))
      M=0
 80   M=M+1
      IF(Q2.GT.QQ(M+1)) GOTO 80
      B=(Q2-QQ(M))/(QQ(M+1)-QQ(M))
      DO 60 I=1,NPMRS
      G(I)= (1.0D0-A)*(1.0D0-B)*FMRS(MODE,I,N  ,M  )
     &     +(1.0D0-A)*       B *FMRS(MODE,I,N  ,M+1)
     &     +       A *(1.0D0-B)*FMRS(MODE,I,N+1,M  )
     &     +       A *       B *FMRS(MODE,I,N+1,M+1)
      IF(N.GE.NTENTH) GOTO 65
      IF(I.EQ.5.OR.I.EQ.7) GOTO 65
      FAC  = (1.0D0-B)*FMRS(MODE,I,NTENTH,M)+B*FMRS(MODE,I,NTENTH,M+1)
      G(I) = FAC*10.0d0**(G(I)-FAC)
  65  continue
      G(I)=G(I)*(1.0d0-X)**N0(I)
  60  continue
      UPV  = G(1)
      DNV  = G(2)
      USEA = G(4)
      DSEA = G(8)
      STR  = G(6)
      CHM  = G(5)
      GLU  = G(3)
      BOT  = G(7)
      X    = XSAVE
      Q2   = Q2SAVE
      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 'HERWIG65.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)
              GOTO 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)
            GOTO 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)
            GOTO 999
  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)
              GOTO 999
            ENDIF
          ELSE
            CALL HWWARN('HWSSPC',105)
            GOTO 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  RETURN
      END
CDECK  ID>, HWSSUD.
*CMZ :-        -26/04/91  11.11.56  by  Bryan Webber
*-- Author :    Bryan Webber
C-----------------------------------------------------------------------
      FUNCTION HWSSUD(I)
C-----------------------------------------------------------------------
      INCLUDE 'HERWIG65.INC'
      DOUBLE PRECISION HWSSUD,HWSGQQ,DMIN,QSCA,XLAST,DIST(13)
      INTEGER I,N0,IS,ID
      EXTERNAL HWSGQQ
      COMMON/HWTABC/XLAST,N0,IS,ID
      SAVE DMIN
      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
      SAVE MMAX
      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 'HERWIG65.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)
      ENDIF
      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 'HERWIG65.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)
      SAVE A1,B1,C1,A2,B2,C2,A3,B3,C3,A4,B4,C4
      DATA A1,B1,C1/0.0    D0,0.00835D0,1.000D0/
      DATA A2,B2,C2/0.0    D0,0.00238D0,3.927D0/
      DATA A3,B3,C3/0.00165D0,0.00299D0,1.000D0/
      DATA A4,B4,C4/0.00221D0,0.00293D0,1.000D0/
      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)
      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-----------------------------------------------------------------------
      IMPLICIT NONE
      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
      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 'HERWIG65.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
      SAVE EPS
      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) THEN
        CALL HWWARN('HWUALF',51)
        GOTO 999
      ENDIF
      RHO=2.*LOG(SCALE/QCDL5)
      IF (IOPT.EQ.3) THEN
        IF (RHO.LE.D35) THEN
          CALL HWWARN('HWUALF',52)
          GOTO 999
        ENDIF
        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) THEN
        CALL HWWARN('HWUALF',53)
        GOTO 999
      ENDIF
      IF (IOPT.EQ.1) THEN
        HWUALF=1./RLF
      ELSE
        HWUALF=B5*(RHO-D35)/RLF
        IF (HWUALF.GT.ONE) THEN
          CALL HWWARN('HWUALF',54)
          GOTO 999
        ENDIF
      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 'HERWIG65.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 backslashes
C-----------------------------------------------------------------------
      INCLUDE 'HERWIG65.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 'HERWIG65.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 'HERWIG65.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 'HERWIG65.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
      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
      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 'HERWIG65.INC'
      COMMON/HWSEED/ISEED(2)
      INTEGER ISEED
      INTEGER NLAST,NNEXT,NLEFT,NREST,I,J,MMWIDE,MMLONG,MMHOFF,MMVOFF
      COMMON/PAPER/MMWIDE,MMLONG,MMHOFF,MMVOFF
c      PARAMETER (NLAST=458,NNEXT=458+1,NLEFT=NMXRES-458)
c      PARAMETER (NREST=NMXRES-120)
c      DATA NRES/458/
      PARAMETER (NLAST=458,NNEXT=NLAST+1,NLEFT=NMXRES-NLAST)
      PARAMETER (NREST=NMXRES-120)
      DATA NRES/NLAST/
C Don't forget to change the three occurances above as well
      DATA MMWIDE,MMLONG,MMHOFF,MMVOFF/190,280,-39,-35/
      DATA ISEED/12345,67890/
      DATA (RNAME(I),IDPDG(I),IFLAV(I),ICHRG(I),RMASS(I),RLTIM(I),
     &      RSPIN(I),I=0,16)/
     & '        ',       0,   0, 0,0.0000D0,0.000D+00,0.0D0,
     & 'DQRK    ',       1,   0,-1,0.3200D0,0.000D+00,0.5D0,
     & 'UQRK    ',       2,   0,+2,0.3200D0,0.000D+00,0.5D0,
     & 'SQRK    ',       3,   0,-1,0.5000D0,0.000D+00,0.5D0,
     & 'CQRK    ',       4,   0,+2,1.5500D0,0.000D+00,0.5D0,
     & 'BQRK    ',       5,   0,-1,4.9500D0,0.000D+00,0.5D0,
     & 'TQRK    ',       6,   0,+2,174.30D0,4.000D-25,0.5D0,
     & 'DBAR    ',      -1,   0,+1,0.3200D0,0.000D+00,0.5D0,
     & 'UBAR    ',      -2,   0,-2,0.3200D0,0.000D+00,0.5D0,
     & 'SBAR    ',      -3,   0,+1,0.5000D0,0.000D+00,0.5D0,
     & 'CBAR    ',      -4,   0,-2,1.5500D0,0.000D+00,0.5D0,
     & 'BBAR    ',      -5,   0,+1,4.9500D0,0.000D+00,0.5D0,
     & 'TBAR    ',      -6,   0,-2,174.30D0,4.000D-25,0.5D0,
     & 'GLUON   ',      21,   0, 0,0.7500D0,0.000D+00,1.0D0,
     & 'CMF     ',       0,   0, 0,0.0000D0,0.000D+00,0.0D0,
     & 'HARD    ',       0,   0, 0,0.0000D0,0.000D+00,0.0D0,
     & 'SOFT    ',       0,   0, 0,0.0000D0,0.000D+00,0.0D0/
      DATA (RNAME(I),IDPDG(I),IFLAV(I),ICHRG(I),RMASS(I),RLTIM(I),
     &      RSPIN(I),I=17,32)/
     & 'CONE    ',       0,   0, 0,0.0000D0,0.000D+00,0.0D0,
     & 'HEAVY   ',       0,   0, 0,0.0000D0,0.000D+00,0.0D0,
     & 'CLUS    ',      91,   0, 0,0.0000D0,0.000D+00,0.0D0,
     & '****    ',       0,   0, 0,0.0000D0,0.000D+00,0.0D0,
     & 'PI0     ',     111,  11, 0,.13498D0,8.400D-17,0.0D0,
     & 'ETA     ',     221,  33, 0,.54730D0,0.000D+00,0.0D0,
     & 'RHO0    ',     113,  11, 0,.77000D0,0.000D+00,1.0D0,
     & 'OMEGA   ',     223,  33, 0,.78194D0,0.000D+00,1.0D0,
     & 'ETAP    ',     331,  33, 0,.95778D0,0.000D+00,0.0D0,
     & 'F_2     ',     225,  33, 0,1.2750D0,0.000D+00,2.0D0,
     & 'A_10    ',   20113,  11, 0,1.2300D0,0.000D+00,1.0D0,
     & 'FL_1    ',   20223,  33, 0,1.2819D0,0.000D+00,1.0D0,
     & 'A_20    ',     115,  11, 0,1.3181D0,0.000D+00,2.0D0,
     & 'PI-     ',    -211,  12,-1,.13957D0,2.603D-08,0.0D0,
     & 'RHO-    ',    -213,  12,-1,.77000D0,0.000D+00,1.0D0,
     & 'A_1-    ',  -20213,  12,-1,1.2300D0,0.000D+00,1.0D0/
      DATA (RNAME(I),IDPDG(I),IFLAV(I),ICHRG(I),RMASS(I),RLTIM(I),
     &      RSPIN(I),I=33,48)/
     & 'A_2-    ',    -215,  12,-1,1.3181D0,0.000D+00,2.0D0,
     & 'K-      ',    -321,  32,-1,.49368D0,1.237D-08,0.0D0,
     & 'K*-     ',    -323,  32,-1,.89166D0,0.000D+00,1.0D0,
     & 'KH_1-   ',  -20323,  32,-1,1.8500D0,0.000D+00,1.0D0,
     & 'K*_2-   ',    -325,  32,-1,1.4256D0,0.000D+00,2.0D0,
     & 'PI+     ',     211,  21,+1,.13957D0,2.603D-08,0.0D0,
     & 'RHO+    ',     213,  21,+1,.77000D0,0.000D+00,1.0D0,
     & 'A_1+    ',   20213,  21,+1,1.2300D0,0.000D+00,1.0D0,
     & 'A_2+    ',     215,  21,+1,1.3181D0,0.000D+00,2.0D0,
     & 'KBAR0   ',    -311,  31, 0,.49767D0,0.000D+00,0.0D0,
     & 'K*BAR0  ',    -313,  31, 0,.89610D0,0.000D+00,1.0D0,
     & 'KH_1BAR0',  -20313,  31, 0,1.8500D0,0.000D+00,1.0D0,
     & 'K*_2BAR0',    -315,  31, 0,1.4324D0,0.000D+00,2.0D0,
     & 'K+      ',     321,  23,+1,.49368D0,1.237D-08,0.0D0,
     & 'K*+     ',     323,  23,+1,.89166D0,0.000D+00,1.0D0,
     & 'KH_1+   ',   20323,  23,+1,1.8500D0,0.000D+00,1.0D0/
      DATA (RNAME(I),IDPDG(I),IFLAV(I),ICHRG(I),RMASS(I),RLTIM(I),
     &      RSPIN(I),I=49,64)/
     & 'K*_2+   ',     325,  23,+1,1.4256D0,0.000D+00,2.0D0,
     & 'K0      ',     311,  13, 0,.49767D0,0.000D+00,0.0D0,
     & 'K*0     ',     313,  13, 0,.89610D0,0.000D+00,1.0D0,
     & 'KH_10   ',   20313,  13, 0,1.8500D0,0.000D+00,1.0D0,
     & 'K*_20   ',     315,  13, 0,1.4324D0,0.000D+00,2.0D0,
     & '        ',       0,   0, 0,0.0000D0,0.000D+00,0.0D0,
     & '        ',       0,   0, 0,0.0000D0,0.000D+00,0.0D0,
     & 'PHI     ',     333,  33, 0,1.0194D0,0.000D+00,1.0D0,
     & 'FH_1    ',   20333,  33, 0,1.4262D0,0.000D+00,1.0D0,
     & 'FP_2    ',     335,  33, 0,1.5250D0,0.000D+00,2.0D0,
     & 'GAMMA   ',      22,   0, 0,0.0000D0,1.000D+30,1.0D0,
     & 'K_S0    ',     310,   0, 0,.49767D0,8.926D-11,0.0D0,
     & 'K_L0    ',     130,   0, 0,.49767D0,5.170D-08,0.0D0,
     & 'A_0(H)0 ',   10111,  11, 0,1.4740D0,0.000D+00,0.0D0,
     & 'A_0(H)+ ',   10211,  21,+1,1.4740D0,0.000D+00,0.0D0,
     & 'A_0(H)- ',  -10211,  12,-1,1.4740D0,0.000D+00,0.0D0/
      DATA (RNAME(I),IDPDG(I),IFLAV(I),ICHRG(I),RMASS(I),RLTIM(I),
     &      RSPIN(I),I=65,80)/
     & '        ',       0,   0, 0,0.0000D0,0.000D+00,0.0D0,
     & '        ',       0,   0, 0,0.0000D0,0.000D+00,0.0D0,
     & '        ',       0,   0, 0,0.0000D0,0.000D+00,0.0D0,
     & '        ',       0,   0, 0,0.0000D0,0.000D+00,0.0D0,
     & '        ',       0,   0, 0,0.0000D0,0.000D+00,0.0D0,
     & '        ',       0,   0, 0,0.0000D0,0.000D+00,0.0D0,
     & 'REMG    ',      98,   0, 0,0.0000D0,0.000D+00,0.0D0,
     & 'REMN    ',      99,   0, 0,0.0000D0,0.000D+00,0.0D0,
     & 'P       ',    2212, 122,+1,.93827D0,1.000D+30,0.5D0,
     & 'DELTA+  ',    2214, 122,+1,1.2320D0,0.000D+00,1.5D0,
     & 'N       ',    2112, 112, 0,.93957D0,8.870D+02,0.5D0,
     & 'DELTA0  ',    2114, 112, 0,1.2320D0,0.000D+00,1.5D0,
     & 'DELTA-  ',    1114, 111,-1,1.2320D0,0.000D+00,1.5D0,
     & 'LAMBDA  ',    3122, 123, 0,1.1157D0,2.632D-10,0.5D0,
     & 'SIGMA0  ',    3212, 123, 0,1.1926D0,7.400D-20,0.5D0,
     & 'SIGMA*0 ',    3214, 123, 0,1.3837D0,0.000D+00,1.5D0/
      DATA (RNAME(I),IDPDG(I),IFLAV(I),ICHRG(I),RMASS(I),RLTIM(I),
     &      RSPIN(I),I=81,96)/
     & 'SIGMA-  ',    3112, 113,-1,1.1974D0,1.479D-10,0.5D0,
     & 'SIGMA*- ',    3114, 113,-1,1.3872D0,0.000D+00,1.5D0,
     & 'XI-     ',    3312, 133,-1,1.3213D0,1.639D-10,0.5D0,
     & 'XI*-    ',    3314, 133,-1,1.5350D0,0.000D+00,1.5D0,
     & 'DELTA++ ',    2224, 222,+2,1.2320D0,0.000D+00,1.5D0,
     & 'SIGMA+  ',    3222, 223,+1,1.1894D0,7.990D-11,0.5D0,
     & 'SIGMA*+ ',    3224, 223,+1,1.3828D0,0.000D+00,1.5D0,
     & 'XI0     ',    3322, 233, 0,1.3149D0,2.900D-10,0.5D0,
     & 'XI*0    ',    3324, 233, 0,1.5318D0,0.000D+00,1.5D0,
     & 'OMEGA-  ',    3334, 333,-1,1.6725D0,8.220D-11,1.5D0,
     & 'PBAR    ',   -2212,-122,-1,.93827D0,1.000D+30,0.5D0,
     & 'DELTABR-',   -2214,-122,-1,1.2320D0,0.000D+00,1.5D0,
     & 'NBAR    ',   -2112,-112, 0,.93957D0,8.870D+02,0.5D0,
     & 'DELTABR0',   -2114,-112, 0,1.2320D0,0.000D+00,1.5D0,
     & 'DELTABR+',   -1114,-111,+1,1.2320D0,0.000D+00,1.5D0,
     & 'LAMBDABR',   -3122,-123, 0,1.1157D0,2.632D-10,0.5D0/
      DATA (RNAME(I),IDPDG(I),IFLAV(I),ICHRG(I),RMASS(I),RLTIM(I),
     &      RSPIN(I),I=97,112)/
     & 'SIGMABR0',   -3212,-123, 0,1.1926D0,7.400D-20,0.5D0,
     & 'SGMA*BR0',   -3214,-123, 0,1.3837D0,0.000D+00,1.5D0,
     & 'SIGMABR+',   -3112,-113,+1,1.1974D0,1.479D-10,0.5D0,
     & 'SGMA*BR+',   -3114,-113,+1,1.3872D0,0.000D+00,1.5D0,
     & 'XIBAR+  ',   -3312,-133,+1,1.3213D0,1.639D-10,0.5D0,
     & 'XI*BAR+ ',   -3314,-133,+1,1.5350D0,0.000D+00,1.5D0,
     & 'DLTABR--',   -2224,-222,-2,1.2320D0,0.000D+00,1.5D0,
     & 'SIGMABR-',   -3222,-223,-1,1.1894D0,7.990D-11,0.5D0,
     & 'SGMA*BR-',   -3224,-223,-1,1.3828D0,0.000D+00,1.5D0,
     & 'XIBAR0  ',   -3322,-233, 0,1.3149D0,2.900D-10,0.5D0,
     & 'XI*BAR  ',   -3324,-233, 0,1.5318D0,0.000D+00,1.5D0,
     & 'OMEGABR+',   -3334,-333,+1,1.6725D0,8.220D-11,1.5D0,
     & 'UU      ',    2203,   0,+4,0.6400D0,0.000D+00,0.0D0,
     & 'UD      ',    2101,   0,+1,0.6400D0,0.000D+00,0.0D0,
     & 'DD      ',    1103,   0,-2,0.6400D0,0.000D+00,0.0D0,
     & 'US      ',    3201,   0,+1,0.8200D0,0.000D+00,0.0D0/
      DATA (RNAME(I),IDPDG(I),IFLAV(I),ICHRG(I),RMASS(I),RLTIM(I),
     &      RSPIN(I),I=113,128)/
     & 'DS      ',    3101,   0,-2,0.8200D0,0.000D+00,0.0D0,
     & 'SS      ',    3303,   0,-2,1.0000D0,0.000D+00,0.0D0,
     & 'UBARUBAR',   -2203,   0,-4,0.6400D0,0.000D+00,0.0D0,
     & 'UBARDBAR',   -2101,   0,-1,0.6400D0,0.000D+00,0.0D0,
     & 'DBARDBAR',   -1103,   0,+2,0.6400D0,0.000D+00,0.0D0,
     & 'UBARSBAR',   -3201,   0,-1,0.8200D0,0.000D+00,0.0D0,
     & 'DBARSBAR',   -3101,   0,+2,0.8200D0,0.000D+00,0.0D0,
     & 'SBARSBAR',   -3303,   0,+2,1.0000D0,0.000D+00,0.0D0,
     & 'E-      ',      11,   0,-1,5.11D-04,1.000D+30,0.5D0,
     & 'NU_E    ',      12,   0, 0,0.0000D0,1.000D+30,0.5D0,
     & 'MU-     ',      13,   0,-1,.10566D0,2.197D-06,0.5D0,
     & 'NU_MU   ',      14,   0, 0,0.0000D0,1.000D+30,0.5D0,
     & 'TAU-    ',      15,   0,-1,1.7771D0,2.916D-13,0.5D0,
     & 'NU_TAU  ',      16,   0, 0,0.0000D0,1.000D+30,0.5D0,
     & 'E+      ',     -11,   0,+1,5.11D-04,1.000D+30,0.5D0,
     & 'NU_EBAR ',     -12,   0, 0,0.0000D0,1.000D+30,0.5D0/
      DATA (RNAME(I),IDPDG(I),IFLAV(I),ICHRG(I),RMASS(I),RLTIM(I),
     &      RSPIN(I),I=129,144)/
     & 'MU+     ',     -13,   0,+1,.10566D0,2.197D-06,0.5D0,
     & 'NU_MUBAR',     -14,   0, 0,0.0000D0,1.000D+30,0.5D0,
     & 'TAU+    ',     -15,   0,+1,1.7771D0,2.916D-13,0.5D0,
     & 'NU_TAUBR',     -16,   0, 0,0.0000D0,1.000D+30,0.5D0,
     & '        ',       0,   0, 0,0.0000D0,0.000D+00,0.0D0,
     & '        ',       0,   0, 0,0.0000D0,0.000D+00,0.0D0,
     & '        ',       0,   0, 0,0.0000D0,0.000D+00,0.0D0,
     & 'D+      ',     411,  41,+1,1.8693D0,1.057D-12,0.0D0,
     & 'D*+     ',     413,  41,+1,2.0100D0,0.000D+00,1.0D0,
     & 'DH_1+   ',   20413,  41,+1,2.4270D0,0.000D+00,1.0D0,
     & 'D*_2+   ',     415,  41,+1,2.4590D0,0.000D+00,2.0D0,
     & 'D0      ',     421,  42, 0,1.8646D0,4.150D-13,0.0D0,
     & 'D*0     ',     423,  42, 0,2.0067D0,0.000D+00,1.0D0,
     & 'DH_10   ',   20423,  42, 0,2.4222D0,0.000D+00,1.0D0,
     & 'D*_20   ',     425,  42, 0,2.4589D0,0.000D+00,2.0D0,
     & 'D_S+    ',     431,  43,+1,1.9685D0,4.670D-13,0.0D0/
      DATA (RNAME(I),IDPDG(I),IFLAV(I),ICHRG(I),RMASS(I),RLTIM(I),
     &      RSPIN(I),I=145,160)/
     & 'D*_S+   ',     433,  43,+1,2.1124D0,0.000D+00,1.0D0,
     & 'DH_S1+  ',   20433,  43,+1,2.5354D0,0.000D+00,1.0D0,
     & 'D*_S2+  ',     435,  43,+1,2.5735D0,0.000D+00,2.0D0,
     & 'SGMA_C++',    4222, 224,+2,2.4528D0,0.000D+00,0.5D0,
     & 'SGM*_C++',    4224, 224,+2,2.5194D0,0.000D+00,1.5D0,
     & 'LMBDA_C+',    4122, 124,+1,2.2849D0,2.060D-13,0.5D0,
     & 'SIGMA_C+',    4212, 124,+1,2.4536D0,0.000D+00,0.5D0,
     & 'SGMA*_C+',    4214, 124,+1,2.5185D0,0.000D+00,1.5D0,
     & 'SIGMA_C0',    4112, 114, 0,2.4522D0,0.000D+00,0.5D0,
     & 'SGMA*_C0',    4114, 114, 0,2.5175D0,0.000D+00,1.5D0,
     & 'XI_C+   ',    4232, 234,+1,2.4656D0,3.500D-13,0.5D0,
     & 'XIP_C+  ',    4322, 234,+1,2.5750D0,0.000D+00,0.5D0,
     & 'XI*_C+  ',    4324, 234,+1,2.6446D0,0.000D+00,1.5D0,
     & 'XI_C0   ',    4132, 134, 0,2.4703D0,9.800D-14,0.5D0,
     & 'XIP_C0  ',    4312, 134, 0,2.5800D0,0.000D+00,0.5D0,
     & 'XI*_C0  ',    4314, 134, 0,2.6438D0,0.000D+00,1.5D0/
      DATA (RNAME(I),IDPDG(I),IFLAV(I),ICHRG(I),RMASS(I),RLTIM(I),
     &      RSPIN(I),I=161,176)/
     & 'OMEGA_C0',    4332, 334, 0,2.7040D0,6.400D-14,0.5D0,
     & 'OMGA*_C0',    4334, 334, 0,2.7300D0,0.000D+00,1.5D0,
     & 'ETA_C   ',     441,  44, 0,2.9798D0,0.000D+00,0.0D0,
     & 'JPSI    ',     443,  44, 0,3.0969D0,0.000D+00,1.0D0,
     & 'CHI_C1  ',   10441,  44, 0,3.4173D0,0.000D+00,0.0D0,
     & 'PSI2S   ',  100443,  44, 0,3.6860D0,0.000D+00,1.0D0,
     & 'PSID    ',   30443,  44, 0,3.7699D0,0.000D+00,1.0D0,
     & '        ',       0,   0, 0,0.0000D0,0.000D+00,0.0D0,
     & '        ',       0,   0, 0,0.0000D0,0.000D+00,0.0D0,
     & '        ',       0,   0, 0,0.0000D0,0.000D+00,0.0D0,
     & 'D-      ',    -411,  14,-1,1.8693D0,1.057D-12,0.0D0,
     & 'D*-     ',    -413,  14,-1,2.0100D0,0.000D+00,1.0D0,
     & 'DH_1-   ',  -20413,  14,-1,2.4270D0,0.000D+00,1.0D0,
     & 'D*_2-   ',    -415,  14,-1,2.4590D0,0.000D+00,2.0D0,
     & 'DBAR0   ',    -421,  24, 0,1.8646D0,4.140D-13,0.0D0,
     & 'D*BAR0  ',    -423,  24, 0,2.0067D0,0.000D+00,1.0D0/
      DATA (RNAME(I),IDPDG(I),IFLAV(I),ICHRG(I),RMASS(I),RLTIM(I),
     &      RSPIN(I),I=177,192)/
     & 'DH_1BAR0',  -20423,  24, 0,2.4222D0,0.000D+00,1.0D0,
     & 'D*_2BAR0',    -425,  24, 0,2.4589D0,0.000D+00,2.0D0,
     & 'D_S-    ',    -431,  34,-1,1.9685D0,4.670D-13,0.0D0,
     & 'D*_S-   ',    -433,  34,-1,2.1124D0,0.000D+00,1.0D0,
     & 'DH_S1-  ',  -20433,  34,-1,2.5354D0,0.000D+00,1.0D0,
     & 'D*_S2-  ',    -435,  34,-1,2.5735D0,0.000D+00,2.0D0,
     & 'SGMA_C--',   -4222,-224,-2,2.4528D0,0.000D+00,0.5D0,
     & 'SGM*_C--',   -4224,-224,-2,2.5194D0,0.000D+00,1.5D0,
     & 'LMBDA_C-',   -4122,-124,-1,2.2849D0,2.060D-13,0.5D0,
     & 'SIGMA_C-',   -4212,-124,-1,2.4536D0,0.000D+00,0.5D0,
     & 'SGMA*_C-',   -4214,-124,-1,2.5185D0,0.000D+00,1.5D0,
     & 'SGM_CBR0',   -4112,-114, 0,2.4522D0,0.000D+00,0.5D0,
     & 'SG*_CBR0',   -4114,-114, 0,2.5175D0,0.000D+00,1.5D0,
     & 'XI_C-   ',   -4232,-234,-1,2.4656D0,3.500D-13,0.5D0,
     & 'XIP_C-  ',   -4322,-234,-1,2.5750D0,0.000D+00,0.5D0,
     & 'XI*_C-  ',   -4324,-234,-1,2.6446D0,0.000D+00,1.5D0/
      DATA (RNAME(I),IDPDG(I),IFLAV(I),ICHRG(I),RMASS(I),RLTIM(I),
     &      RSPIN(I),I=193,208)/
     & 'XI_CBAR0',   -4132,-134, 0,2.4703D0,9.800D-14,0.5D0,
     & 'XIP_CBR0',   -4312,-134, 0,2.5800D0,0.000D+00,0.5D0,
     & 'XI*_CBR0',   -4314,-134, 0,2.6438D0,0.000D+00,1.5D0,
     & 'OMG_CBR0',   -4332,-334, 0,2.7040D0,6.400D-14,0.5D0,
     & 'OM*_CBR0',   -4334,-334, 0,2.7300D0,0.000D+00,1.5D0,
     & 'W+      ',      24,   0,+1,80.420D0,0.000D+00,1.0D0,
     & 'W-      ',     -24,   0,-1,80.420D0,0.000D+00,1.0D0,
     & 'Z0/GAMA*',      23,   0, 0,91.188D0,0.000D+00,1.0D0,
     & 'HIGGS   ',      25,   0, 0,115.00D0,0.000D+00,0.0D0,
     & 'Z0P     ',      32,   0, 0,500.00D0,0.000D+00,1.0D0,
     & 'HIGGSL0 ',      26,   0, 0,0.0000D0,1.000D+30,0.0D0,
     & 'HIGGSH0 ',      35,   0, 0,0.0000D0,1.000D+30,0.0D0,
     & 'HIGGSA0 ',      36,   0, 0,0.0000D0,1.000D+30,0.0D0,
     & 'HIGGS+  ',      37,   0,+1,0.0000D0,1.000D+30,0.0D0,
     & 'HIGGS-  ',     -37,   0,-1,0.0000D0,1.000D+30,0.0D0,
     & 'GRAVITON',      39,   0, 0,0.0000D0,1.000D+30,2.0D0/
      DATA (RNAME(I),IDPDG(I),IFLAV(I),ICHRG(I),RMASS(I),RLTIM(I),
     &      RSPIN(I),I=209,224)/
     & 'VQRK    ',       7,   0,-1,200.00D0,0.000D+00,0.5D0,
     & 'AQRK    ',       8,   0,+2,400.00D0,0.000D+00,0.5D0,
     & 'HQRK    ',       7,   0,-1,400.00D0,0.000D+00,0.5D0,
     & 'HPQK    ',       8,   0,+2,600.00D0,0.000D+00,0.5D0,
     & '        ',       0,   0, 0,0.0000D0,0.000D+00,0.0D0,
     & '        ',       0,   0, 0,0.0000D0,0.000D+00,0.0D0,
     & 'VBAR    ',      -7,   0,+1,200.00D0,0.000D+00,0.5D0,
     & 'ABAR    ',      -8,   0,-2,400.00D0,0.000D+00,0.5D0,
     & 'HBAR    ',      -7,   0,+1,400.00D0,0.000D+00,0.5D0,
     & 'HPBR    ',      -8,   0,-2,600.00D0,0.000D+00,0.5D0,
     & '        ',       0,   0, 0,0.0000D0,0.000D+00,0.0D0,
     & '        ',       0,   0, 0,0.0000D0,0.000D+00,0.0D0,
     & 'B_DBAR0 ',    -511,  51, 0,5.2792D0,1.614D-12,0.0D0,
     & 'B-      ',    -521,  52,-1,5.2789D0,1.652D-12,0.0D0,
     & 'B_SBAR0 ',    -531,  53, 0,5.3693D0,1.540D-12,0.0D0,
     & 'SIGMA_B+',    5222, 225,+1,5.8200D0,1.070D-12,0.5D0/
      DATA (RNAME(I),IDPDG(I),IFLAV(I),ICHRG(I),RMASS(I),RLTIM(I),
     &      RSPIN(I),I=225,240)/
     & 'LMBDA_B0',    5122, 125, 0,5.6240D0,1.070D-12,0.5D0,
     & 'SIGMA_B-',    5112, 115,-1,5.8200D0,1.070D-12,0.5D0,
     & 'XI_B0   ',    5232, 235, 0,5.8000D0,1.070D-12,0.5D0,
     & 'XI_B-   ',    5132, 135,-1,5.8000D0,1.070D-12,0.5D0,
     & 'OMEGA_B-',    5332, 335,-1,6.0400D0,1.070D-12,0.5D0,
     & 'B_C-    ',    -541,  54,-1,6.2500D0,1.000D-12,0.5D0,
     & 'UPSLON1S',     553,  55, 0,9.4604D0,0.000D+00,1.0D0,
     & 'T_B-    ',    -651,  56,-1,0.0000D0,0.000D+00,0.0D0,
     & 'T+      ',     611,  61,+1,0.0000D0,0.000D+00,0.0D0,
     & 'T0      ',     621,  62, 0,0.0000D0,0.000D+00,0.0D0,
     & 'T_S+    ',     631,  63,+1,0.0000D0,0.000D+00,0.0D0,
     & 'SGMA_T++',    6222, 226,+2,0.0000D0,0.000D+00,0.5D0,
     & 'LMBDA_T0',    6122, 126,+1,0.0000D0,0.000D+00,0.5D0,
     & 'SIGMA_T0',    6112, 116, 0,0.0000D0,0.000D+00,0.5D0,
     & 'XI_T+   ',    6232, 236,+1,0.0000D0,0.000D+00,0.5D0,
     & 'XI_T0   ',    6132, 136, 0,0.0000D0,0.000D+00,0.5D0/
      DATA (RNAME(I),IDPDG(I),IFLAV(I),ICHRG(I),RMASS(I),RLTIM(I),
     &      RSPIN(I),I=241,256)/
     & 'OMEGA_T0',    6332, 336, 0,0.0000D0,0.000D+00,0.5D0,
     & 'T_C0    ',     641,  64, 0,0.0000D0,0.000D+00,0.0D0,
     & 'T_B+    ',     651,  65,+1,0.0000D0,0.000D+00,0.0D0,
     & 'TOPONIUM',     663,  66, 0,0.0000D0,0.000D+00,1.0D0,
     & 'B_D0    ',     511,  15, 0,5.2792D0,1.614D-12,0.0D0,
     & 'B+      ',     521,  25,+1,5.2789D0,1.652D-12,0.0D0,
     & 'B_S0    ',     531,  35, 0,5.3693D0,1.540D-12,0.0D0,
     & 'SGM_BBR-',   -5222,-225,-1,5.8200D0,1.070D-12,0.5D0,
     & 'LMD_BBR0',   -5122,-125, 0,5.6240D0,1.070D-12,0.5D0,
     & 'SGM_BBR+',   -5112,-115,+1,5.8200D0,1.070D-12,0.5D0,
     & 'XI_BBAR0',   -5232,-235, 0,5.8000D0,1.070D-12,0.5D0,
     & 'XI_B+   ',   -5132,-135,+1,5.8000D0,1.070D-12,0.5D0,
     & 'OMG_BBR+',   -5332,-335,+1,6.0400D0,1.070D-12,0.5D0,
     & 'B_C+    ',     541,  45,+1,6.2500D0,1.000D-12,0.5D0,
     & 'T-      ',    -611,  16,-1,0.0000D0,0.000D+00,0.0D0,
     & 'TBAR0   ',    -621,  26, 0,0.0000D0,0.000D+00,0.0D0/
      DATA (RNAME(I),IDPDG(I),IFLAV(I),ICHRG(I),RMASS(I),RLTIM(I),
     &      RSPIN(I),I=257,272)/
     & 'T_S-    ',    -631,  36,-1,0.0000D0,0.000D+00,0.0D0,
     & 'SGMA_T--',   -6222,-226,-2,0.0000D0,0.000D+00,0.5D0,
     & 'LAMDA_T-',   -6122,-126,-1,0.0000D0,0.000D+00,0.5D0,
     & 'SGM_TBR0',   -6112,-116, 0,0.0000D0,0.000D+00,0.5D0,
     & 'XI_T-   ',   -6232,-236,-1,0.0000D0,0.000D+00,0.5D0,
     & 'XI_TBAR0',   -6132,-136, 0,0.0000D0,0.000D+00,0.5D0,
     & 'OMG_TBR0',   -6332,-336, 0,0.0000D0,0.000D+00,0.5D0,
     & 'T_CBAR0 ',    -641,  46, 0,0.0000D0,0.000D+00,0.0D0,
     & 'B*BAR0  ',    -513,  51, 0,5.3249D0,0.000D+00,1.0D0,
     & 'B*-     ',    -523,  52,-1,5.3249D0,0.000D+00,1.0D0,
     & 'B*_SBAR0',    -533,  53, 0,5.4163D0,0.000D+00,1.0D0,
     & 'BH_1BAR0',  -20513,  51, 0,5.7600D0,0.000D+00,1.0D0,
     & 'BH_1-   ',  -20523,  52,-1,5.7600D0,0.000D+00,1.0D0,
     & 'BH_S1BR0',  -20533,  53, 0,5.8550D0,0.000D+00,1.0D0,
     & 'B*_2BAR0',    -515,  51, 0,5.7700D0,0.000D+00,2.0D0,
     & 'B*_2-   ',    -525,  52,-1,5.7700D0,0.000D+00,2.0D0/
      DATA (RNAME(I),IDPDG(I),IFLAV(I),ICHRG(I),RMASS(I),RLTIM(I),
     &      RSPIN(I),I=273,288)/
     & 'B*_S2BR0',    -535,  53, 0,5.8650D0,0.000D+00,2.0D0,
     & 'B*0     ',     513,  15, 0,5.3249D0,0.000D+00,1.0D0,
     & 'B*+     ',     523,  25,+1,5.3249D0,0.000D+00,1.0D0,
     & 'B*_S0   ',     533,  35, 0,5.4163D0,0.000D+00,1.0D0,
     & 'BH_10   ',   20513,  15, 0,5.7600D0,0.000D+00,1.0D0,
     & 'BH_1+   ',   20523,  25,+1,5.7600D0,0.000D+00,1.0D0,
     & 'BH_S10  ',   20533,  35, 0,5.8550D0,0.000D+00,1.0D0,
     & 'B*_20   ',     515,  15, 0,5.7700D0,0.000D+00,2.0D0,
     & 'B*_2+   ',     525,  25,+1,5.7700D0,0.000D+00,2.0D0,
     & 'B*_S20  ',     535,  35, 0,5.8650D0,0.000D+00,2.0D0,
     & '        ',       0,   0, 0,0.0000D0,0.000D+00,  0D0,
     & '        ',       0,   0, 0,0.0000D0,0.000D+00,  0D0,
     & 'B_10    ',   10113,  11, 0,1.2295D0,0.000D+00,1.0D0,
     & 'B_1+    ',   10213,  21,+1,1.2295D0,0.000D+00,1.0D0,
     & 'B_1-    ',  -10213,  12,-1,1.2295D0,0.000D+00,1.0D0,
     & 'HL_10   ',   10223,  33, 0,1.1700D0,0.000D+00,1.0D0/
      DATA (RNAME(I),IDPDG(I),IFLAV(I),ICHRG(I),RMASS(I),RLTIM(I),
     &      RSPIN(I),I=289,304)/
     & 'HH_10   ',   10333,  33, 0,1.3950D0,0.000D+00,1.0D0,
     & 'A_00    ', 9000111,  11, 0,.99600D0,0.000D+00,0.0D0,
     & 'A_0+    ', 9000211,  21,+1,.99600D0,0.000D+00,0.0D0,
     & 'A_0-    ',-9000211,  12,-1,.99600D0,0.000D+00,0.0D0,
     & 'F0P0    ', 9010221,  33, 0,.99600D0,0.000D+00,0.0D0,
     & 'FH_00   ',   10221,  33, 0,1.3500D0,0.000D+00,0.0D0,
     & 'B*_C+   ',     543,  45,+1,6.2950D0,0.000D+00,1.0D0,
     & 'B*_C-   ',    -543,  54,-1,6.2950D0,0.000D+00,1.0D0,
     & 'BH_C1+  ',   20543,  45,+1,6.7300D0,0.000D+00,1.0D0,
     & 'BH_C1-  ',  -20543,  54,-1,6.7300D0,0.000D+00,1.0D0,
     & 'B*_C2+  ',     545,  45,+1,6.7400D0,0.000D+00,2.0D0,
     & 'B*_C2-  ',    -545,  54,-1,6.7400D0,0.000D+00,2.0D0,
     & 'H_C     ',   10443,  44, 0,3.5261D0,0.000D+00,1.0D0,
     & 'CHI_C0  ',   20443,  44, 0,3.5105D0,0.000D+00,0.0D0,
     & 'CHI_C2  ',     445,  44, 0,3.5562D0,0.000D+00,2.0D0,
     & 'ETA_B   ',     551,  55, 0,9.0000D0,0.000D+00,0.0D0/
      DATA (RNAME(I),IDPDG(I),IFLAV(I),ICHRG(I),RMASS(I),RLTIM(I),
     &      RSPIN(I),I=305,320)/
     & 'H_B     ',   10553,  55, 0,9.8880D0,0.000D+00,1.0D0,
     & 'CHI_B0  ',   10551,  55, 0,9.8598D0,0.000D+00,0.0D0,
     & 'CHI_B1  ',   20553,  55, 0,9.8919D0,0.000D+00,1.0D0,
     & 'CHI_B2  ',     555,  55, 0,9.9132D0,0.000D+00,2.0D0,
     & 'KL_10   ',   10313,  13, 0,1.5700D0,0.000D+00,1.0D0,
     & 'KL_1+   ',   10323,  23,+1,1.5700D0,0.000D+00,1.0D0,
     & 'KL_1BAR0',  -10313,  31, 0,1.5700D0,0.000D+00,1.0D0,
     & 'KL_1-   ',  -10323,  32,-1,1.5700D0,0.000D+00,1.0D0,
     & 'DL_1+   ',   10413,  41,+1,2.4270D0,0.000D+00,1.0D0,
     & 'DL_10   ',   10423,  42, 0,2.4222D0,0.000D+00,1.0D0,
     & 'DL_S1+  ',   10433,  43,+1,2.5354D0,0.000D+00,1.0D0,
     & 'DL_1-   ',  -10413,  14,-1,2.4270D0,0.000D+00,1.0D0,
     & 'DL_1BAR0',  -10423,  24, 0,2.4222D0,0.000D+00,1.0D0,
     & 'DL_S1-  ',  -10433,  34,-1,2.5354D0,0.000D+00,1.0D0,
     & 'BL_10   ',   10513,  15, 0,5.7600D0,0.000D+00,1.0D0,
     & 'BL_1+   ',   10523,  25,+1,5.7600D0,0.000D+00,1.0D0/
      DATA (RNAME(I),IDPDG(I),IFLAV(I),ICHRG(I),RMASS(I),RLTIM(I),
     &      RSPIN(I),I=321,336)/
     & 'BL_S10  ',   10533,  35, 0,5.8530D0,0.000D+00,1.0D0,
     & 'BL_C1+  ',   10543,  45,+1,6.7300D0,0.000D+00,1.0D0,
     & 'BL_1BAR0',  -10513,  51, 0,5.7600D0,0.000D+00,1.0D0,
     & 'BL_1-   ',  -10523,  52,-1,5.7600D0,0.000D+00,1.0D0,
     & 'BL_S1BR0',  -10533,  53, 0,5.8530D0,0.000D+00,1.0D0,
     & 'BL_C1-  ',  -10543,  54,-1,6.7300D0,0.000D+00,1.0D0,
     & 'K*_0+   ',   10321,  23,+1,1.4290D0,0.000D+00,0.0D0,
     & 'K*_00   ',   10311,  13, 0,1.4290D0,0.000D+00,0.0D0,
     & 'K*_0BAR0',  -10311,  31, 0,1.4290D0,0.000D+00,0.0D0,
     & 'K*_0-   ',  -10321,  32,-1,1.4290D0,0.000D+00,0.0D0,
     & 'D*_0+   ',   10411,  41,+1,2.4230D0,0.000D+00,0.0D0,
     & 'D*_00   ',   10421,  42, 0,2.4230D0,0.000D+00,0.0D0,
     & 'D*_S0+  ',   10431,  43,+1,2.5250D0,0.000D+00,0.0D0,
     & 'D*_0-   ',  -10411,  14,-1,2.4230D0,0.000D+00,0.0D0,
     & 'D*_0BAR0',  -10421,  24, 0,2.4230D0,0.000D+00,0.0D0,
     & 'D*_S0-  ',  -10431,  34,-1,2.5250D0,0.000D+00,0.0D0/
      DATA (RNAME(I),IDPDG(I),IFLAV(I),ICHRG(I),RMASS(I),RLTIM(I),
     &      RSPIN(I),I=337,352)/
     & 'B*_00   ',   10511,  15, 0,5.7600D0,0.000D+00,0.0D0,
     & 'B*_0+   ',   10521,  25,+1,5.7600D0,0.000D+00,0.0D0,
     & 'B*_S00  ',   10531,  35, 0,5.8550D0,0.000D+00,0.0D0,
     & 'B*_C0+  ',   10541,  45,+1,6.7300D0,0.000D+00,0.0D0,
     & 'B*_0BAR0',  -10511,  51, 0,5.7600D0,0.000D+00,0.0D0,
     & 'B*_0-   ',  -10521,  52,-1,5.7600D0,0.000D+00,0.0D0,
     & 'B*_S0BR0',  -10531,  53, 0,5.8550D0,0.000D+00,0.0D0,
     & 'B*_C0-  ',  -10541,  54,-1,6.7300D0,0.000D+00,0.0D0,
     & 'SGMA*_B-',    5114, 115,-1,5.8400D0,0.000D+00,1.5D0,
     & 'SIGMA_B0',    5212, 125, 0,5.8200D0,0.000D+00,0.5D0,
     & 'SGMA*_B0',    5214, 125, 0,5.8400D0,0.000D+00,1.5D0,
     & 'SGMA*_B+',    5224, 225,+1,5.8400D0,0.000D+00,1.5D0,
     & 'XIP_B0  ',    5322, 235, 0,5.9450D0,0.000D+00,0.5D0,
     & 'XI*_B0  ',    5324, 235, 0,5.9450D0,0.000D+00,1.5D0,
     & 'XIP_B-  ',    5312, 135,-1,5.9450D0,0.000D+00,0.5D0,
     & 'XI*_B-  ',    5314, 135,-1,5.9450D0,0.000D+00,1.5D0/
      DATA (RNAME(I),IDPDG(I),IFLAV(I),ICHRG(I),RMASS(I),RLTIM(I),
     &      RSPIN(I),I=353,368)/
     & '0MGA*_B-',    5334, 335,-1,6.0600D0,0.000D+00,1.5D0,
     & 'SG*_BBR+',   -5114,-115,+1,5.8400D0,0.000D+00,1.5D0,
     & 'SGM_BBR0',   -5212,-125, 0,5.8200D0,0.000D+00,0.5D0,
     & 'SG*_BBR0',   -5214,-125, 0,5.8400D0,0.000D+00,1.5D0,
     & 'SG*_BBR-',   -5224,-225,-1,5.8400D0,0.000D+00,1.5D0,
     & 'XIP_BBR0',   -5322,-235, 0,5.9450D0,0.000D+00,0.5D0,
     & 'XI*_BBR0',   -5324,-235, 0,5.9450D0,0.000D+00,1.5D0,
     & 'XIP_B+  ',   -5312,-135,+1,5.9450D0,0.000D+00,0.5D0,
     & 'XI*_B+  ',   -5314,-135,+1,5.9450D0,0.000D+00,1.5D0,
     & '0MGA*_B+',   -5334,-335,+1,6.0600D0,0.000D+00,1.5D0,
     & 'KDL_2+  ',   10325,  23,+1,1.7730D0,0.000D+00,2.0D0,
     & 'KDL_20  ',   10315,  13, 0,1.7730D0,0.000D+00,2.0D0,
     & 'KDL_2BR0',  -10315,  31, 0,1.7730D0,0.000D+00,2.0D0,
     & 'KDL_2-  ',  -10325,  32,-1,1.7730D0,0.000D+00,2.0D0,
     & 'KD*+    ',   30323,  23,+1,1.7170D0,0.000D+00,1.0D0,
     & 'KD*0    ',   30313,  13, 0,1.7170D0,0.000D+00,1.0D0/
      DATA (RNAME(I),IDPDG(I),IFLAV(I),ICHRG(I),RMASS(I),RLTIM(I),
     &      RSPIN(I),I=369,384)/
     & 'KD*BAR0 ',  -30313,  31, 0,1.7170D0,0.000D+00,1.0D0,
     & 'KD*-    ',  -30323,  32,-1,1.7170D0,0.000D+00,1.0D0,
     & 'KDH_2+  ',   20325,  23,+1,1.8160D0,0.000D+00,2.0D0,
     & 'KDH_20  ',   20315,  13, 0,1.8160D0,0.000D+00,2.0D0,
     & 'KDH_2BR0',  -20315,  31, 0,1.8160D0,0.000D+00,2.0D0,
     & 'KDH_2-  ',  -20325,  32,-1,1.8160D0,0.000D+00,2.0D0,
     & 'KD_3+   ',     327,  23,+1,1.7730D0,0.000D+00,3.0D0,
     & 'KD_30   ',     317,  13, 0,1.7730D0,0.000D+00,3.0D0,
     & 'KD_3BAR0',    -317,  31, 0,1.7730D0,0.000D+00,3.0D0,
     & 'KD_3-   ',    -327,  32,-1,1.7730D0,0.000D+00,3.0D0,
     & 'PI_2+   ',   10215,  21,+1,1.6700D0,0.000D+00,2.0D0,
     & 'PI_20   ',   10115,  11, 0,1.6700D0,0.000D+00,2.0D0,
     & 'PI_2-   ',  -10215,  12,-1,1.6700D0,0.000D+00,2.0D0,
     & 'RHOD+   ',   30213,  21,+1,1.7000D0,0.000D+00,1.0D0,
     & 'RHOD0   ',   30113,  11, 0,1.7000D0,0.000D+00,1.0D0,
     & 'RHOD-   ',  -30213,  12,-1,1.7000D0,0.000D+00,1.0D0/
      DATA (RNAME(I),IDPDG(I),IFLAV(I),ICHRG(I),RMASS(I),RLTIM(I),
     &      RSPIN(I),I=385,400)/
     & 'RHO_3+  ',     217,  21,+1,1.6910D0,0.000D+00,3.0D0,
     & 'RHO_30  ',     117,  11, 0,1.6910D0,0.000D+00,3.0D0,
     & 'RHO_3-  ',    -217,  12,-1,1.6910D0,0.000D+00,3.0D0,
     & 'UPSLON2S',  100553,  55, 0,10.023D0,0.000D+00,1.0D0,
     & 'CHI2P_B0',  110551,  55, 0,10.232D0,0.000D+00,0.0D0,
     & 'CHI2P_B1',  120553,  55, 0,10.255D0,0.000D+00,1.0D0,
     & 'CHI2P_B2',  100555,  55, 0,10.269D0,0.000D+00,2.0D0,
     & 'UPSLON3S',  200553,  55, 0,10.355D0,0.000D+00,1.0D0,
     & 'UPSLON4S',  300553,  55, 0,10.580D0,0.000D+00,1.0D0,
     & '        ',       0,   0, 0,0.0   D0,  0.0D+00,  0D0,
     & 'OMEGA_3 ',     227,  33, 0,1.6670D0,0.000D+00,3.0D0,
     & 'PHI_3   ',     337,  33, 0,1.8540D0,0.000D+00,3.0D0,
     & 'ETA_2(L)',   10225,  33, 0,1.6320D0,0.000D+00,2.0D0,
     & 'ETA_2(H)',   10335,  33, 0,1.8540D0,0.000D+00,2.0D0,
     & 'OMEGA(H)',   30223,  33, 0,1.6490D0,0.000D+00,1.0D0,
     & '        ',       0,   0, 0,0.0   D0,0.0D+00  ,  0D0/
      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.0D0,
     & 'SSUL    ', 1000002,   0,+2,0.00D0,1.000D+30,0.0D0,
     & 'SSSL    ', 1000003,   0,-1,0.00D0,1.000D+30,0.0D0,
     & 'SSCL    ', 1000004,   0,+2,0.00D0,1.000D+30,0.0D0,
     & 'SSB1    ', 1000005,   0,-1,0.00D0,1.000D+30,0.0D0,
     & 'SST1    ', 1000006,   0,+2,0.00D0,1.000D+30,0.0D0,
     & 'SSDLBR  ',-1000001,   0,+1,0.00D0,1.000D+30,0.0D0,
     & 'SSULBR  ',-1000002,   0,-2,0.00D0,1.000D+30,0.0D0,
     & 'SSSLBR  ',-1000003,   0,+1,0.00D0,1.000D+30,0.0D0,
     & 'SSCLBR  ',-1000004,   0,-2,0.00D0,1.000D+30,0.0D0,
     & 'SSB1BR  ',-1000005,   0,+1,0.00D0,1.000D+30,0.0D0,
     & 'SST1BR  ',-1000006,   0,-2,0.00D0,1.000D+30,0.0D0,
     & 'SSDR    ', 2000001,   0,-1,0.00D0,1.000D+30,0.0D0,
     & 'SSUR    ', 2000002,   0,+2,0.00D0,1.000D+30,0.0D0,
     & 'SSSR    ', 2000003,   0,-1,0.00D0,1.000D+30,0.0D0,
     & 'SSCR    ', 2000004,   0,+2,0.00D0,1.000D+30,0.0D0/
      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.0D0,
     & 'SST2    ', 2000006,   0,+2,0.00D0,1.000D+30,0.0D0,
     & 'SSDRBR  ',-2000001,   0,+1,0.00D0,1.000D+30,0.0D0,
     & 'SSURBR  ',-2000002,   0,-2,0.00D0,1.000D+30,0.0D0,
     & 'SSSRBR  ',-2000003,   0,+1,0.00D0,1.000D+30,0.0D0,
     & 'SSCRBR  ',-2000004,   0,-2,0.00D0,1.000D+30,0.0D0,
     & 'SSB2BR  ',-2000005,   0,+1,0.00D0,1.000D+30,0.0D0,
     & 'SST2BR  ',-2000006,   0,-2,0.00D0,1.000D+30,0.0D0,
     & 'SSEL-   ', 1000011,   0,-1,0.00D0,1.000D+30,0.0D0,
     & 'SSNUEL  ', 1000012,   0, 0,0.00D0,1.000D+30,0.0D0,
     & 'SSMUL-  ', 1000013,   0,-1,0.00D0,1.000D+30,0.0D0,
     & 'SSNUMUL ', 1000014,   0, 0,0.00D0,1.000D+30,0.0D0,
     & 'SSTAU1- ', 1000015,   0,-1,0.00D0,1.000D+30,0.0D0,
     & 'SSNUTL  ', 1000016,   0, 0,0.00D0,1.000D+30,0.0D0,
     & 'SSEL+   ',-1000011,   0,+1,0.00D0,1.000D+30,0.0D0,
     & 'SSNUELBR',-1000012,   0, 0,0.00D0,1.000D+30,0.0D0/
      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.0D0,
     & 'SSNUMLBR',-1000014,   0, 0,0.00D0,1.000D+30,0.0D0,
     & 'SSTAU1+ ',-1000015,   0,+1,0.00D0,1.000D+30,0.0D0,
     & 'SSNUTLBR',-1000016,   0, 0,0.00D0,1.000D+30,0.0D0,
     & 'SSER-   ', 2000011,   0,-1,0.00D0,1.000D+30,0.0D0,
     & 'SSNUER  ', 2000012,   0, 0,0.00D0,1.000D+30,0.0D0,
     & 'SSMUR-  ', 2000013,   0,-1,0.00D0,1.000D+30,0.0D0,
     & 'SSNUMUR ', 2000014,   0, 0,0.00D0,1.000D+30,0.0D0,
     & 'SSTAU2- ', 2000015,   0,-1,0.00D0,1.000D+30,0.0D0,
     & 'SSNUTR  ', 2000016,   0, 0,0.00D0,1.000D+30,0.0D0,
     & 'SSER+   ',-2000011,   0,+1,0.00D0,1.000D+30,0.0D0,
     & 'SSNUERBR',-2000012,   0, 0,0.00D0,1.000D+30,0.0D0,
     & 'SSMUR+  ',-2000013,   0,+1,0.00D0,1.000D+30,0.0D0,
     & 'SSNUMRBR',-2000014,   0, 0,0.00D0,1.000D+30,0.0D0,
     & 'SSTAU2+ ',-2000015,   0,+1,0.00D0,1.000D+30,0.0D0,
     & 'SSNUTRBR',-2000016,   0, 0,0.00D0,1.000D+30,0.0D0/
      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.5D0,
     & 'NTLINO1 ', 1000022,   0, 0,0.00D0,1.000D+30,0.5D0,
     & 'NTLINO2 ', 1000023,   0, 0,0.00D0,1.000D+30,0.5D0,
     & 'NTLINO3 ', 1000025,   0, 0,0.00D0,1.000D+30,0.5D0,
     & 'NTLINO4 ', 1000035,   0, 0,0.00D0,1.000D+30,0.5D0,
     & 'CHGINO1+', 1000024,   0,+1,0.00D0,1.000D+30,0.5D0,
     & 'CHGINO2+', 1000037,   0,+1,0.00D0,1.000D+30,0.5D0,
     & 'CHGINO1-',-1000024,   0,-1,0.00D0,1.000D+30,0.5D0,
     & 'CHGINO2-',-1000037,   0,-1,0.00D0,1.000D+30,0.5D0,
     & 'GRAVTINO', 1000039,   0, 0,0.00D0,1.000D+30,1.5D0/
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
      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.0000D0/
      DATA (RLTIM(I),I=NNEXT,NMXRES)/NLEFT*0.000D+00/
      DATA (RSPIN(I),I=NNEXT,NMXRES)/NLEFT*0.0D0/
      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.334D0,100,  2,  7,  5,  0,  0,
     &   6,0.333D0,100,  4,  9,  5,  0,  0,
     &   6,0.111D0,100,122,127,  5,  0,  0,
     &   6,0.111D0,100,124,129,  5,  0,  0,
     &   6,0.111D0,100,126,131,  5,  0,  0,
     &  12,0.334D0,100,  8,  1, 11,  0,  0,
     &  12,0.333D0,100, 10,  3, 11,  0,  0,
     &  12,0.111D0,100,128,121, 11,  0,  0,
     &  12,0.111D0,100,130,123, 11,  0,  0,
     &  12,0.111D0,100,132,125, 11,  0,  0,
     &  21,0.988D0,  0, 59, 59,  0,  0,  0,
     &  21,0.012D0,  0,127,121, 59,  0,  0,
     &  22,0.388D0,  0, 59, 59,  0,  0,  0,
     &  22,0.319D0,  0, 21, 21, 21,  0,  0,
     &  22,0.001D0,  0, 21, 59, 59,  0,  0,
     &  22,0.236D0,  0, 38, 30, 21,  0,  0,
     &  22,0.049D0,  0, 38, 30, 59,  0,  0,
     &  22,0.005D0,  0,127,121, 59,  0,  0,
     &  22,0.002D0,  0, 38, 30,127,121,  0/
      DATA (IDK(I),BRFRAC(I),NME(I),(IDKPRD(J,I),J=1,5),I=  20,  38)/
     &  23,0.989D0,  0, 38, 30,  0,  0,  0,
     &  23,0.010D0,  0, 38, 30, 59,  0,  0,
     &  23,0.001D0,  0, 21, 59,  0,  0,  0,
     &  24,0.888D0,  0, 38, 30, 21,  0,  0,
     &  24,0.085D0,  0, 21, 59,  0,  0,  0,
     &  24,0.022D0,  0, 38, 30,  0,  0,  0,
     &  24,0.001D0,  0, 22, 59,  0,  0,  0,
     &  24,0.001D0,  0, 21,127,121,  0,  0,
     &  24,0.003D0,  0, 38, 30, 21, 21,  0,
     &  25,0.437D0,  0, 38, 30, 22,  0,  0,
     &  25,0.302D0,  0, 23, 59,  0,  0,  0,
     &  25,0.208D0,  0, 21, 21, 22,  0,  0,
     &  25,0.030D0,  0, 24, 59,  0,  0,  0,
     &  25,0.021D0,  0, 59, 59,  0,  0,  0,
     &  25,0.002D0,  0, 21, 21, 21,  0,  0,
     &  26,0.566D0,  0, 38, 30,  0,  0,  0,
     &  26,0.283D0,  0, 21, 21,  0,  0,  0,
     &  26,0.069D0,  0, 38, 30, 21, 21,  0,
     &  26,0.023D0,  0, 46, 34,  0,  0,  0/
      DATA (IDK(I),BRFRAC(I),NME(I),(IDKPRD(J,I),J=1,5),I=  39,  57)/
     &  26,0.023D0,  0, 50, 42,  0,  0,  0,
     &  26,0.028D0,  0, 38, 38, 30, 30,  0,
     &  26,0.005D0,  0, 22, 22,  0,  0,  0,
     &  26,0.003D0,  0, 21, 21, 21, 21,  0,
     &  27,0.499D0,  0, 39, 30,  0,  0,  0,
     &  27,0.499D0,  0, 31, 38,  0,  0,  0,
     &  27,0.002D0,  0, 21, 59, 59,  0,  0,
     &  28,0.148D0,  0, 21, 21, 38, 30,  0,
     &  28,0.148D0,  0, 23, 38, 30,  0,  0,
     &  28,0.147D0,  0,291, 30,  0,  0,  0,
     &  28,0.147D0,  0,290, 21,  0,  0,  0,
     &  28,0.147D0,  0,292, 38,  0,  0,  0,
     &  28,0.067D0,  0, 22, 38, 30,  0,  0,
     &  28,0.033D0,  0, 22, 21, 21,  0,  0,
     &  28,0.032D0,  0, 46, 42, 30,  0,  0,
     &  28,0.016D0,  0, 46, 34, 21,  0,  0,
     &  28,0.016D0,  0, 50, 42, 21,  0,  0,
     &  28,0.032D0,  0, 50, 34, 38,  0,  0,
     &  28,0.066D0,  0, 59, 23,  0,  0,  0/
      DATA (IDK(I),BRFRAC(I),NME(I),(IDKPRD(J,I),J=1,5),I=  58,  76)/
     &  28,0.001D0,  0, 56, 59,  0,  0,  0,
     &  29,0.349D0,  0, 39, 30,  0,  0,  0,
     &  29,0.349D0,  0, 31, 38,  0,  0,  0,
     &  29,0.144D0,  0, 22, 21,  0,  0,  0,
     &  29,0.104D0,  0, 24, 38, 30,  0,  0,
     &  29,0.024D0,  0, 46, 34,  0,  0,  0,
     &  29,0.024D0,  0, 50, 42,  0,  0,  0,
     &  29,0.006D0,  0, 25, 21,  0,  0,  0,
     &  30,1.000D0,  0,123,130,  0,  0,  0,
     &  31,1.000D0,  0, 30, 21,  0,  0,  0,
     &  32,0.499D0,  0, 31, 21,  0,  0,  0,
     &  32,0.499D0,  0, 23, 30,  0,  0,  0,
     &  32,0.002D0,  0, 30, 59,  0,  0,  0,
     &  33,0.349D0,  0, 31, 21,  0,  0,  0,
     &  33,0.349D0,  0, 23, 30,  0,  0,  0,
     &  33,0.144D0,  0, 22, 30,  0,  0,  0,
     &  33,0.101D0,  0, 24, 30, 21,  0,  0,
     &  33,0.048D0,  0, 50, 34,  0,  0,  0,
     &  33,0.006D0,  0, 25, 30,  0,  0,  0/
      DATA (IDK(I),BRFRAC(I),NME(I),(IDKPRD(J,I),J=1,5),I=  77,  95)/
     &  33,0.003D0,  0, 30, 59,  0,  0,  0,
     &  34,0.629D0,  0,123,130,  0,  0,  0,
     &  34,0.212D0,  0, 30, 21,  0,  0,  0,
     &  34,0.056D0,  0, 30, 38, 30,  0,  0,
     &  34,0.017D0,  0, 30, 21, 21,  0,  0,
     &  34,0.048D0,101,121,128, 21,  0,  0,
     &  34,0.032D0,101,123,130, 21,  0,  0,
     &  34,0.006D0,  0,123,130, 59,  0,  0,
     &  35,0.666D0,  0, 42, 30,  0,  0,  0,
     &  35,0.333D0,  0, 34, 21,  0,  0,  0,
     &  35,0.001D0,  0, 34, 59,  0,  0,  0,
     &  36,0.627D0,  0, 43, 30,  0,  0,  0,
     &  36,0.313D0,  0, 35, 21,  0,  0,  0,
     &  36,0.020D0,  0, 42, 31,  0,  0,  0,
     &  36,0.010D0,  0, 34, 23,  0,  0,  0,
     &  36,0.020D0,  0, 34,294,  0,  0,  0,
     &  36,0.010D0,  0, 34, 24,  0,  0,  0,
     &  37,0.331D0,  0, 42, 30,  0,  0,  0,
     &  37,0.166D0,  0, 34, 21,  0,  0,  0/
      DATA (IDK(I),BRFRAC(I),NME(I),(IDKPRD(J,I),J=1,5),I=  96, 114)/
     &  37,0.168D0,  0, 43, 30,  0,  0,  0,
     &  37,0.084D0,  0, 35, 21,  0,  0,  0,
     &  37,0.087D0,  0, 35, 38, 30,  0,  0,
     &  37,0.044D0,  0, 35, 21, 21,  0,  0,
     &  37,0.059D0,  0, 42, 31,  0,  0,  0,
     &  37,0.029D0,  0, 34, 23,  0,  0,  0,
     &  37,0.029D0,  0, 34, 24,  0,  0,  0,
     &  37,0.002D0,  0, 34, 59,  0,  0,  0,
     &  37,0.001D0,  0, 34, 22,  0,  0,  0,
     &  38,1.000D0,  0,129,124,  0,  0,  0,
     &  39,1.000D0,  0, 38, 21,  0,  0,  0,
     &  40,0.499D0,  0, 39, 21,  0,  0,  0,
     &  40,0.499D0,  0, 23, 38,  0,  0,  0,
     &  40,0.002D0,  0, 38, 59,  0,  0,  0,
     &  41,0.349D0,  0, 39, 21,  0,  0,  0,
     &  41,0.349D0,  0, 23, 38,  0,  0,  0,
     &  41,0.144D0,  0, 22, 38,  0,  0,  0,
     &  41,0.101D0,  0, 24, 38, 21,  0,  0,
     &  41,0.048D0,  0, 46, 42,  0,  0,  0/
      DATA (IDK(I),BRFRAC(I),NME(I),(IDKPRD(J,I),J=1,5),I= 115, 133)/
     &  41,0.006D0,  0, 25, 38,  0,  0,  0,
     &  41,0.003D0,  0, 38, 59,  0,  0,  0,
     &  42,0.500D0,  0, 60,  0,  0,  0,  0,
     &  42,0.500D0,  0, 61,  0,  0,  0,  0,
     &  43,0.665D0,  0, 34, 38,  0,  0,  0,
     &  43,0.333D0,  0, 42, 21,  0,  0,  0,
     &  43,0.002D0,  0, 42, 59,  0,  0,  0,
     &  44,0.627D0,  0, 35, 38,  0,  0,  0,
     &  44,0.313D0,  0, 43, 21,  0,  0,  0,
     &  44,0.020D0,  0, 34, 39,  0,  0,  0,
     &  44,0.010D0,  0, 42, 23,  0,  0,  0,
     &  44,0.020D0,  0, 42,294,  0,  0,  0,
     &  44,0.010D0,  0, 42, 24,  0,  0,  0,
     &  45,0.331D0,  0, 34, 38,  0,  0,  0,
     &  45,0.166D0,  0, 42, 21,  0,  0,  0,
     &  45,0.168D0,  0, 35, 38,  0,  0,  0,
     &  45,0.084D0,  0, 43, 21,  0,  0,  0,
     &  45,0.089D0,  0, 42, 38, 30,  0,  0,
     &  45,0.044D0,  0, 42, 21, 21,  0,  0/
      DATA (IDK(I),BRFRAC(I),NME(I),(IDKPRD(J,I),J=1,5),I= 134, 152)/
     &  45,0.059D0,  0, 34, 39,  0,  0,  0,
     &  45,0.029D0,  0, 42, 23,  0,  0,  0,
     &  45,0.029D0,  0, 42, 24,  0,  0,  0,
     &  45,0.001D0,  0, 42, 22,  0,  0,  0,
     &  46,0.629D0,  0,129,124,  0,  0,  0,
     &  46,0.212D0,  0, 38, 21,  0,  0,  0,
     &  46,0.056D0,  0, 38, 38, 30,  0,  0,
     &  46,0.017D0,  0, 38, 21, 21,  0,  0,
     &  46,0.032D0,101,129,124, 21,  0,  0,
     &  46,0.048D0,101,127,122, 21,  0,  0,
     &  46,0.006D0,  0,129,124, 59,  0,  0,
     &  47,0.666D0,  0, 50, 38,  0,  0,  0,
     &  47,0.333D0,  0, 46, 21,  0,  0,  0,
     &  47,0.001D0,  0, 46, 59,  0,  0,  0,
     &  48,0.627D0,  0, 51, 38,  0,  0,  0,
     &  48,0.313D0,  0, 47, 21,  0,  0,  0,
     &  48,0.020D0,  0, 50, 39,  0,  0,  0,
     &  48,0.010D0,  0, 46, 23,  0,  0,  0,
     &  48,0.020D0,  0, 46,294,  0,  0,  0/
      DATA (IDK(I),BRFRAC(I),NME(I),(IDKPRD(J,I),J=1,5),I= 153, 171)/
     &  48,0.010D0,  0, 46, 24,  0,  0,  0,
     &  49,0.331D0,  0, 50, 38,  0,  0,  0,
     &  49,0.166D0,  0, 46, 21,  0,  0,  0,
     &  49,0.168D0,  0, 51, 38,  0,  0,  0,
     &  49,0.084D0,  0, 47, 21,  0,  0,  0,
     &  49,0.087D0,  0, 47, 38, 30,  0,  0,
     &  49,0.044D0,  0, 47, 21, 21,  0,  0,
     &  49,0.059D0,  0, 50, 39,  0,  0,  0,
     &  49,0.029D0,  0, 46, 23,  0,  0,  0,
     &  49,0.029D0,  0, 46, 24,  0,  0,  0,
     &  49,0.002D0,  0, 46, 59,  0,  0,  0,
     &  49,0.001D0,  0, 46, 22,  0,  0,  0,
     &  50,0.500D0,  0, 60,  0,  0,  0,  0,
     &  50,0.500D0,  0, 61,  0,  0,  0,  0,
     &  51,0.665D0,  0, 46, 30,  0,  0,  0,
     &  51,0.333D0,  0, 50, 21,  0,  0,  0,
     &  51,0.002D0,  0, 50, 59,  0,  0,  0,
     &  52,0.627D0,  0, 47, 30,  0,  0,  0,
     &  52,0.313D0,  0, 51, 21,  0,  0,  0/
      DATA (IDK(I),BRFRAC(I),NME(I),(IDKPRD(J,I),J=1,5),I= 172, 190)/
     &  52,0.020D0,  0, 46, 31,  0,  0,  0,
     &  52,0.010D0,  0, 50, 23,  0,  0,  0,
     &  52,0.020D0,  0, 50,294,  0,  0,  0,
     &  52,0.010D0,  0, 50, 24,  0,  0,  0,
     &  53,0.331D0,  0, 46, 30,  0,  0,  0,
     &  53,0.166D0,  0, 50, 21,  0,  0,  0,
     &  53,0.168D0,  0, 47, 30,  0,  0,  0,
     &  53,0.084D0,  0, 51, 21,  0,  0,  0,
     &  53,0.089D0,  0, 50, 38, 30,  0,  0,
     &  53,0.044D0,  0, 50, 21, 21,  0,  0,
     &  53,0.059D0,  0, 46, 31,  0,  0,  0,
     &  53,0.029D0,  0, 50, 23,  0,  0,  0,
     &  53,0.029D0,  0, 50, 24,  0,  0,  0,
     &  53,0.001D0,  0, 50, 22,  0,  0,  0,
     &  56,0.490D0,  0, 46, 34,  0,  0,  0,
     &  56,0.342D0,  0, 61, 60,  0,  0,  0,
     &  56,0.043D0,  0, 39, 30,  0,  0,  0,
     &  56,0.043D0,  0, 23, 21,  0,  0,  0,
     &  56,0.043D0,  0, 31, 38,  0,  0,  0/
      DATA (IDK(I),BRFRAC(I),NME(I),(IDKPRD(J,I),J=1,5),I= 191, 209)/
     &  56,0.025D0,  0, 38, 30, 21,  0,  0,
     &  56,0.013D0,  0, 22, 59,  0,  0,  0,
     &  56,0.001D0,  0, 21, 59,  0,  0,  0,
     &  57,0.250D0,  0, 50, 43,  0,  0,  0,
     &  57,0.250D0,  0, 34, 47,  0,  0,  0,
     &  57,0.250D0,  0, 42, 51,  0,  0,  0,
     &  57,0.250D0,  0, 46, 35,  0,  0,  0,
     &  58,0.356D0,  0, 46, 34,  0,  0,  0,
     &  58,0.356D0,  0, 50, 42,  0,  0,  0,
     &  58,0.279D0,  0, 22, 22,  0,  0,  0,
     &  58,0.006D0,  0, 38, 30,  0,  0,  0,
     &  58,0.003D0,  0, 21, 21,  0,  0,  0,
     &  60,0.684D0,  0, 38, 30,  0,  0,  0,
     &  60,0.314D0,  0, 21, 21,  0,  0,  0,
     &  60,0.002D0,  0, 38, 30, 59,  0,  0,
     &  61,0.216D0,  0, 21, 21, 21,  0,  0,
     &  61,0.124D0,  0, 38, 30, 21,  0,  0,
     &  61,0.135D0,101,123,130, 38,  0,  0,
     &  61,0.135D0,101,124,129, 30,  0,  0/
      DATA (IDK(I),BRFRAC(I),NME(I),(IDKPRD(J,I),J=1,5),I= 210, 228)/
     &  61,0.187D0,101,121,128, 38,  0,  0,
     &  61,0.187D0,101,122,127, 30,  0,  0,
     &  61,0.006D0,  0,121,128, 38, 59,  0,
     &  61,0.006D0,  0,122,127, 30, 59,  0,
     &  61,0.002D0,  0, 38, 30,  0,  0,  0,
     &  61,0.001D0,  0, 21, 21,  0,  0,  0,
     &  61,0.001D0,  0, 59, 59,  0,  0,  0,
     &  74,0.663D0,  0, 73, 21,  0,  0,  0,
     &  74,0.331D0,  0, 75, 38,  0,  0,  0,
     &  74,0.006D0,  0, 73, 59,  0,  0,  0,
     &  75,1.000D0,101,121,128, 73,  0,  0,
     &  76,0.663D0,  0, 75, 21,  0,  0,  0,
     &  76,0.331D0,  0, 73, 30,  0,  0,  0,
     &  76,0.006D0,  0, 75, 59,  0,  0,  0,
     &  77,1.000D0,  0, 75, 30,  0,  0,  0,
     &  78,0.638D0,  0, 73, 30,  0,  0,  0,
     &  78,0.358D0,  0, 75, 21,  0,  0,  0,
     &  78,0.002D0,  0, 75, 59,  0,  0,  0,
     &  78,0.001D0,  0, 73, 30, 59,  0,  0/
      DATA (IDK(I),BRFRAC(I),NME(I),(IDKPRD(J,I),J=1,5),I= 229, 247)/
     &  78,0.001D0,101,121,128, 73,  0,  0,
     &  79,0.995D0,  0, 78, 59,  0,  0,  0,
     &  79,0.005D0,  0, 78,127,121,  0,  0,
     &  80,0.880D0,  0, 78, 21,  0,  0,  0,
     &  80,0.060D0,  0, 86, 30,  0,  0,  0,
     &  80,0.060D0,  0, 81, 38,  0,  0,  0,
     &  81,0.998D0,  0, 75, 30,  0,  0,  0,
     &  81,0.001D0,  0, 75, 30, 59,  0,  0,
     &  81,0.001D0,101,121,128, 75,  0,  0,
     &  82,0.880D0,  0, 78, 30,  0,  0,  0,
     &  82,0.060D0,  0, 79, 30,  0,  0,  0,
     &  82,0.060D0,  0, 81, 21,  0,  0,  0,
     &  83,0.999D0,  0, 78, 30,  0,  0,  0,
     &  83,0.001D0,101,121,128, 78,  0,  0,
     &  84,0.667D0,  0, 88, 30,  0,  0,  0,
     &  84,0.333D0,  0, 83, 21,  0,  0,  0,
     &  85,1.000D0,  0, 73, 38,  0,  0,  0,
     &  86,0.516D0,  0, 73, 21,  0,  0,  0,
     &  86,0.483D0,  0, 75, 38,  0,  0,  0/
      DATA (IDK(I),BRFRAC(I),NME(I),(IDKPRD(J,I),J=1,5),I= 248, 266)/
     &  86,0.001D0,  0, 73, 59,  0,  0,  0,
     &  87,0.880D0,  0, 78, 38,  0,  0,  0,
     &  87,0.060D0,  0, 86, 21,  0,  0,  0,
     &  87,0.060D0,  0, 79, 38,  0,  0,  0,
     &  88,0.995D0,  0, 78, 21,  0,  0,  0,
     &  88,0.001D0,  0, 78, 59,  0,  0,  0,
     &  88,0.004D0,  0, 79, 59,  0,  0,  0,
     &  89,0.667D0,  0, 83, 38,  0,  0,  0,
     &  89,0.333D0,  0, 88, 21,  0,  0,  0,
     &  90,0.675D0,  0, 78, 34,  0,  0,  0,
     &  90,0.233D0,  0, 88, 30,  0,  0,  0,
     &  90,0.086D0,  0, 83, 21,  0,  0,  0,
     &  90,0.006D0,101,121,128, 88,  0,  0,
     &  92,0.663D0,  0, 91, 21,  0,  0,  0,
     &  92,0.331D0,  0, 93, 30,  0,  0,  0,
     &  92,0.006D0,  0, 91, 59,  0,  0,  0,
     &  93,1.000D0,101,127,122, 91,  0,  0,
     &  94,0.663D0,  0, 93, 21,  0,  0,  0,
     &  94,0.331D0,  0, 91, 38,  0,  0,  0/
      DATA (IDK(I),BRFRAC(I),NME(I),(IDKPRD(J,I),J=1,5),I= 267, 285)/
     &  94,0.006D0,  0, 93, 59,  0,  0,  0,
     &  95,1.000D0,  0, 93, 38,  0,  0,  0,
     &  96,0.638D0,  0, 91, 38,  0,  0,  0,
     &  96,0.358D0,  0, 93, 21,  0,  0,  0,
     &  96,0.002D0,  0, 93, 59,  0,  0,  0,
     &  96,0.001D0,  0, 91, 38, 59,  0,  0,
     &  96,0.001D0,101,127,122, 91,  0,  0,
     &  97,0.995D0,  0, 96, 59,  0,  0,  0,
     &  97,0.005D0,  0, 96,127,121,  0,  0,
     &  98,0.880D0,  0, 96, 21,  0,  0,  0,
     &  98,0.060D0,  0,104, 38,  0,  0,  0,
     &  98,0.060D0,  0, 99, 30,  0,  0,  0,
     &  99,0.998D0,  0, 93, 38,  0,  0,  0,
     &  99,0.001D0,  0, 93, 38, 59,  0,  0,
     &  99,0.001D0,101,127,122, 93,  0,  0,
     & 100,0.880D0,  0, 96, 38,  0,  0,  0,
     & 100,0.060D0,  0, 97, 38,  0,  0,  0,
     & 100,0.060D0,  0, 99, 21,  0,  0,  0,
     & 101,0.999D0,  0, 96, 38,  0,  0,  0/
      DATA (IDK(I),BRFRAC(I),NME(I),(IDKPRD(J,I),J=1,5),I= 286, 304)/
     & 101,0.001D0,101,127,122, 96,  0,  0,
     & 102,0.667D0,  0,106, 38,  0,  0,  0,
     & 102,0.333D0,  0,101, 21,  0,  0,  0,
     & 103,1.000D0,  0, 91, 30,  0,  0,  0,
     & 104,0.516D0,  0, 91, 21,  0,  0,  0,
     & 104,0.483D0,  0, 93, 30,  0,  0,  0,
     & 104,0.001D0,  0, 91, 59,  0,  0,  0,
     & 105,0.880D0,  0, 96, 30,  0,  0,  0,
     & 105,0.060D0,  0,104, 21,  0,  0,  0,
     & 105,0.060D0,  0, 97, 30,  0,  0,  0,
     & 106,0.995D0,  0, 96, 21,  0,  0,  0,
     & 106,0.001D0,  0, 96, 59,  0,  0,  0,
     & 106,0.004D0,  0, 97, 59,  0,  0,  0,
     & 107,0.667D0,  0,101, 30,  0,  0,  0,
     & 107,0.333D0,  0,106, 21,  0,  0,  0,
     & 108,0.675D0,  0, 96, 46,  0,  0,  0,
     & 108,0.233D0,  0,106, 38,  0,  0,  0,
     & 108,0.086D0,  0,101, 21,  0,  0,  0,
     & 108,0.006D0,101,127,122,106,  0,  0/
      DATA (IDK(I),BRFRAC(I),NME(I),(IDKPRD(J,I),J=1,5),I= 305, 323)/
     & 123,0.986D0,100,121,128,124,  0,  0,
     & 123,0.014D0,  0,121,128,124, 59,  0,
     & 125,0.178D0,100,121,128,126,  0,  0,
     & 125,0.171D0,100,123,130,126,  0,  0,
     & 125,0.002D0,  0,123,130, 59,126,  0,
     & 125,0.111D0,  0, 30,126,  0,  0,  0,
     & 125,0.253D0,  0, 31,126,  0,  0,  0,
     & 125,0.181D0,  0, 32,126,  0,  0,  0,
     & 125,0.002D0,  0, 30, 22, 21,126,  0,
     & 125,0.018D0,  0, 30, 24,126,  0,  0,
     & 125,0.004D0,  0, 30, 24, 21,126,  0,
     & 125,0.015D0,  0, 31, 23,126,  0,  0,
     & 125,0.001D0,  0, 31, 24, 21,126,  0,
     & 125,0.024D0,  0, 32, 21,126,  0,  0,
     & 125,0.002D0,  0, 32, 38, 30,126,  0,
     & 125,0.007D0,  0, 34,126,  0,  0,  0,
     & 125,0.014D0,  0, 35,126,  0,  0,  0,
     & 125,0.003D0,  0, 35, 21,126,  0,  0,
     & 125,0.001D0,  0, 34, 38, 30,126,  0/
      DATA (IDK(I),BRFRAC(I),NME(I),(IDKPRD(J,I),J=1,5),I= 324, 342)/
     & 125,0.004D0,  0, 30, 43,126,  0,  0,
     & 125,0.003D0,  0, 34, 50,126,  0,  0,
     & 125,0.003D0,  0, 34, 51,126,  0,  0,
     & 125,0.003D0,  0, 30, 50, 42,126,  0,
     & 129,0.986D0,100,127,122,130,  0,  0,
     & 129,0.014D0,  0,127,122,130, 59,  0,
     & 131,0.178D0,100,127,122,132,  0,  0,
     & 131,0.171D0,100,129,124,132,  0,  0,
     & 131,0.002D0,  0,129,124, 59,132,  0,
     & 131,0.111D0,  0, 38,132,  0,  0,  0,
     & 131,0.253D0,  0, 39,132,  0,  0,  0,
     & 131,0.181D0,  0, 40,132,  0,  0,  0,
     & 131,0.002D0,  0, 38, 22, 21,132,  0,
     & 131,0.018D0,  0, 38, 24,132,  0,  0,
     & 131,0.004D0,  0, 38, 24, 21,132,  0,
     & 131,0.015D0,  0, 39, 23,132,  0,  0,
     & 131,0.001D0,  0, 39, 24, 21,132,  0,
     & 131,0.024D0,  0, 40, 21,132,  0,  0,
     & 131,0.002D0,  0, 40, 38, 30,132,  0/
      DATA (IDK(I),BRFRAC(I),NME(I),(IDKPRD(J,I),J=1,5),I= 343, 361)/
     & 131,0.007D0,  0, 46,132,  0,  0,  0,
     & 131,0.014D0,  0, 47,132,  0,  0,  0,
     & 131,0.003D0,  0, 47, 21,132,  0,  0,
     & 131,0.001D0,  0, 46, 38, 30,132,  0,
     & 131,0.004D0,  0, 38, 51,132,  0,  0,
     & 131,0.003D0,  0, 46, 42,132,  0,  0,
     & 131,0.003D0,  0, 46, 43,132,  0,  0,
     & 131,0.003D0,  0, 38, 50, 42,132,  0,
     & 136,0.067D0,101,122,127, 42,  0,  0,
     & 136,0.067D0,101,124,129, 42,  0,  0,
     & 136,0.048D0,101,122,127, 43,  0,  0,
     & 136,0.048D0,101,124,129, 43,  0,  0,
     & 136,0.003D0,  0, 34, 38,122,127,  0,
     & 136,0.003D0,  0, 34, 38,124,129,  0,
     & 136,0.006D0,101,122,127, 21,  0,  0,
     & 136,0.006D0,101,124,129, 21,  0,  0,
     & 136,0.002D0,101,122,127, 23,  0,  0,
     & 136,0.002D0,101,124,129, 23,  0,  0,
     & 136,0.055D0,  0, 34, 38, 38,  0,  0/
      DATA (IDK(I),BRFRAC(I),NME(I),(IDKPRD(J,I),J=1,5),I= 362, 380)/
     & 136,0.031D0,  0, 34, 39, 38,  0,  0,
     & 136,0.042D0,  0, 34, 38, 38, 21, 21,
     & 136,0.002D0,  0, 34, 38, 38, 38, 31,
     & 136,0.021D0,  0, 35, 38, 38,  0,  0,
     & 136,0.027D0,  0, 42, 38,  0,  0,  0,
     & 136,0.066D0,  0, 42, 39,  0,  0,  0,
     & 136,0.081D0,  0, 42, 40,  0,  0,  0,
     & 136,0.024D0,  0, 42, 38, 21,  0,  0,
     & 136,0.004D0,  0, 42, 38, 23,  0,  0,
     & 136,0.069D0,  0, 42, 38, 38, 30, 21,
     & 136,0.001D0,  0, 42, 38, 38, 30, 23,
     & 136,0.022D0,  0, 43, 38,  0,  0,  0,
     & 136,0.021D0,  0, 43, 39,  0,  0,  0,
     & 136,0.042D0,  0, 43, 38, 21,  0,  0,
     & 136,0.008D0,  0, 43, 38, 23,  0,  0,
     & 136,0.010D0,  0, 43, 38, 38, 30,  0,
     & 136,0.050D0,  0,311, 38,  0,  0,  0,
     & 136,0.034D0,  0,329, 38,  0,  0,  0,
     & 136,0.010D0,  0,369, 38,  0,  0,  0/
      DATA (IDK(I),BRFRAC(I),NME(I),(IDKPRD(J,I),J=1,5),I= 381, 399)/
     & 136,0.031D0,  0, 46, 42, 42,  0,  0,
     & 136,0.003D0,  0, 38, 21,  0,  0,  0,
     & 136,0.001D0,  0, 38, 23,  0,  0,  0,
     & 136,0.002D0,  0, 38, 38, 30,  0,  0,
     & 136,0.008D0,  0, 38, 22,  0,  0,  0,
     & 136,0.001D0,  0, 38, 38, 38, 30, 30,
     & 136,0.003D0,  0, 38, 38, 38, 30, 31,
     & 136,0.008D0,  0, 46, 42,  0,  0,  0,
     & 136,0.005D0,  0, 46, 43,  0,  0,  0,
     & 136,0.026D0,  0, 47, 43,  0,  0,  0,
     & 136,0.005D0,  0, 46, 34, 38,  0,  0,
     & 136,0.007D0,  0, 38, 56,  0,  0,  0,
     & 136,0.023D0,  0, 38, 56, 21,  0,  0,
     & 136,0.005D0,  0, 46, 46, 34,  0,  0,
     & 137,0.683D0,  0,140, 38,  0,  0,  0,
     & 137,0.306D0,  0,136, 21,  0,  0,  0,
     & 137,0.011D0,  0,136, 59,  0,  0,  0,
     & 138,0.667D0,  0,141, 38,  0,  0,  0,
     & 138,0.333D0,  0,137, 21,  0,  0,  0/
      DATA (IDK(I),BRFRAC(I),NME(I),(IDKPRD(J,I),J=1,5),I= 400, 418)/
     & 139,0.220D0,  0,140, 38,  0,  0,  0,
     & 139,0.110D0,  0,136, 21,  0,  0,  0,
     & 139,0.380D0,  0,141, 38,  0,  0,  0,
     & 139,0.190D0,  0,137, 21,  0,  0,  0,
     & 139,0.004D0,  0,136, 22,  0,  0,  0,
     & 139,0.064D0,  0,141, 38, 21,  0,  0,
     & 139,0.032D0,  0,137, 38, 30,  0,  0,
     & 140,0.037D0,101,122,127, 34,  0,  0,
     & 140,0.037D0,101,124,129, 34,  0,  0,
     & 140,0.016D0,101,122,127, 35,  0,  0,
     & 140,0.016D0,101,124,129, 35,  0,  0,
     & 140,0.013D0,  0, 34, 21,122,127,  0,
     & 140,0.013D0,  0, 34, 21,124,129,  0,
     & 140,0.012D0,  0, 42, 30,122,127,  0,
     & 140,0.012D0,  0, 42, 30,124,129,  0,
     & 140,0.003D0,101,122,127, 30,  0,  0,
     & 140,0.003D0,101,124,129, 30,  0,  0,
     & 140,0.039D0,  0, 34, 38,  0,  0,  0,
     & 140,0.091D0,  0, 34, 39,  0,  0,  0/
      DATA (IDK(I),BRFRAC(I),NME(I),(IDKPRD(J,I),J=1,5),I= 419, 437)/
     & 140,0.067D0,  0, 34, 40,  0,  0,  0,
     & 140,0.004D0,  0, 34, 38, 21,  0,  0,
     & 140,0.100D0,  0, 34, 38, 21, 21,  0,
     & 140,0.058D0,  0, 34, 38, 23,  0,  0,
     & 140,0.020D0,  0, 34, 38, 24,  0,  0,
     & 140,0.006D0,  0, 34, 38, 25,  0,  0,
     & 140,0.043D0,  0, 35, 38,  0,  0,  0,
     & 140,0.035D0,  0, 35, 39,  0,  0,  0,
     & 140,0.007D0,  0,312, 38,  0,  0,  0,
     & 140,0.007D0,  0,330, 38,  0,  0,  0,
     & 140,0.020D0,  0, 42, 21,  0,  0,  0,
     & 140,0.006D0,  0, 42, 22,  0,  0,  0,
     & 140,0.009D0,  0, 42, 23,  0,  0,  0,
     & 140,0.016D0,  0, 42, 24,  0,  0,  0,
     & 140,0.014D0,  0, 42, 25,  0,  0,  0,
     & 140,0.003D0,  0, 42,293,  0,  0,  0,
     & 140,0.007D0,  0, 42, 56,  0,  0,  0,
     & 140,0.003D0,  0, 42, 26,  0,  0,  0,
     & 140,0.004D0,  0, 42,294,  0,  0,  0/
      DATA (IDK(I),BRFRAC(I),NME(I),(IDKPRD(J,I),J=1,5),I= 438, 456)/
     & 140,0.006D0,  0, 42, 21, 21,  0,  0,
     & 140,0.042D0,  0, 42, 38, 30, 21,  0,
     & 140,0.004D0,  0, 42, 38, 38, 30, 30,
     & 140,0.076D0,  0, 42, 38, 30, 21, 21,
     & 140,0.026D0,  0, 43, 21,  0,  0,  0,
     & 140,0.014D0,  0, 43, 22,  0,  0,  0,
     & 140,0.014D0,  0, 43, 23,  0,  0,  0,
     & 140,0.011D0,  0, 43, 24,  0,  0,  0,
     & 140,0.018D0,  0, 43, 38, 30,  0,  0,
     & 140,0.004D0,  0, 42, 46, 34,  0,  0,
     & 140,0.004D0,  0, 42, 46, 34, 21,  0,
     & 140,0.005D0,  0, 42, 42, 50,  0,  0,
     & 140,0.002D0,  0, 38, 30,  0,  0,  0,
     & 140,0.001D0,  0, 21, 21,  0,  0,  0,
     & 140,0.008D0,  0, 38, 30, 21,  0,  0,
     & 140,0.007D0,  0, 38, 38, 30, 30,  0,
     & 140,0.015D0,  0, 38, 38, 30, 30, 21,
     & 140,0.004D0,  0, 46, 34,  0,  0,  0,
     & 140,0.003D0,  0, 47, 34,  0,  0,  0/
      DATA (IDK(I),BRFRAC(I),NME(I),(IDKPRD(J,I),J=1,5),I= 457, 475)/
     & 140,0.002D0,  0, 46, 35,  0,  0,  0,
     & 140,0.001D0,  0, 50, 42,  0,  0,  0,
     & 140,0.002D0,  0, 51, 43,  0,  0,  0,
     & 140,0.003D0,  0, 50, 34, 38,  0,  0,
     & 140,0.003D0,  0, 42, 46, 30,  0,  0,
     & 140,0.001D0,  0, 46, 34, 38, 30, 21,
     & 140,0.002D0,  0, 56, 23,  0,  0,  0,
     & 140,0.001D0,  0, 56, 38, 30,  0,  0,
     & 141,0.636D0,  0,140, 21,  0,  0,  0,
     & 141,0.364D0,  0,140, 59,  0,  0,  0,
     & 142,0.667D0,  0,137, 30,  0,  0,  0,
     & 142,0.333D0,  0,141, 21,  0,  0,  0,
     & 143,0.220D0,  0,136, 30,  0,  0,  0,
     & 143,0.110D0,  0,140, 21,  0,  0,  0,
     & 143,0.380D0,  0,137, 30,  0,  0,  0,
     & 143,0.190D0,  0,141, 21,  0,  0,  0,
     & 143,0.004D0,  0,140, 22,  0,  0,  0,
     & 143,0.064D0,  0,137, 30, 21,  0,  0,
     & 143,0.032D0,  0,141, 38, 30,  0,  0/
      DATA (IDK(I),BRFRAC(I),NME(I),(IDKPRD(J,I),J=1,5),I= 476, 494)/
     & 144,0.009D0,  0,124,129,  0,  0,  0,
     & 144,0.019D0,101,122,127, 56,  0,  0,
     & 144,0.019D0,101,124,129, 56,  0,  0,
     & 144,0.025D0,101,122,127, 22,  0,  0,
     & 144,0.025D0,101,124,129, 22,  0,  0,
     & 144,0.009D0,101,122,127, 25,  0,  0,
     & 144,0.009D0,101,124,129, 25,  0,  0,
     & 144,0.036D0,  0, 46, 42,  0,  0,  0,
     & 144,0.034D0,  0, 46, 43,  0,  0,  0,
     & 144,0.007D0,  0, 46,329,  0,  0,  0,
     & 144,0.043D0,  0, 47, 42,  0,  0,  0,
     & 144,0.058D0,  0, 47, 43,  0,  0,  0,
     & 144,0.011D0,  0, 46, 34, 38,  0,  0,
     & 144,0.055D0,  0, 46, 34, 38, 21,  0,
     & 144,0.003D0,  0, 46, 34, 38, 38, 30,
     & 144,0.014D0,  0, 46, 42, 38, 30,  0,
     & 144,0.017D0,  0, 50, 34, 38, 38,  0,
     & 144,0.036D0,  0, 56, 38,  0,  0,  0,
     & 144,0.067D0,  0, 56, 39,  0,  0,  0/
      DATA (IDK(I),BRFRAC(I),NME(I),(IDKPRD(J,I),J=1,5),I= 495, 513)/
     & 144,0.023D0,  0, 56, 38, 21,  0,  0,
     & 144,0.018D0,  0, 56, 38, 38, 30,  0,
     & 144,0.020D0,  0, 22, 38,  0,  0,  0,
     & 144,0.001D0,  0, 23, 38,  0,  0,  0,
     & 144,0.009D0,  0, 24, 38,  0,  0,  0,
     & 144,0.049D0,  0, 25, 38,  0,  0,  0,
     & 144,0.011D0,  0,293, 38,  0,  0,  0,
     & 144,0.015D0,  0, 22, 38, 21,  0,  0,
     & 144,0.016D0,  0, 25, 38, 21,  0,  0,
     & 144,0.103D0,  0, 22, 39,  0,  0,  0,
     & 144,0.120D0,  0, 25, 39,  0,  0,  0,
     & 144,0.010D0,  0, 38, 38, 30,  0,  0,
     & 144,0.046D0,  0, 38, 38, 30, 21,  0,
     & 144,0.003D0,  0, 38, 38, 38, 30, 30,
     & 144,0.042D0,  0, 38, 30, 30, 38, 39,
     & 144,0.001D0,  0, 46, 23,  0,  0,  0,
     & 144,0.005D0,  0, 46, 38, 30,  0,  0,
     & 144,0.001D0,  0, 46, 56,  0,  0,  0,
     & 144,0.004D0,  0, 50, 38,  0,  0,  0/
      DATA (IDK(I),BRFRAC(I),NME(I),(IDKPRD(J,I),J=1,5),I= 514, 532)/
     & 144,0.007D0,  0, 51, 38,  0,  0,  0,
     & 145,0.900D0,  0,144, 59,  0,  0,  0,
     & 145,0.100D0,  0,144, 21,  0,  0,  0,
     & 146,0.500D0,  0,137, 50,  0,  0,  0,
     & 146,0.500D0,  0,141, 46,  0,  0,  0,
     & 147,0.440D0,  0,136, 50,  0,  0,  0,
     & 147,0.440D0,  0,140, 46,  0,  0,  0,
     & 147,0.055D0,  0,137, 50,  0,  0,  0,
     & 147,0.055D0,  0,141, 46,  0,  0,  0,
     & 147,0.010D0,  0,144, 22,  0,  0,  0,
     & 148,1.000D0,  0,150, 38,  0,  0,  0,
     & 149,1.000D0,  0,150, 38,  0,  0,  0,
     & 150,0.028D0,101,122,127, 78,  0,  0,
     & 150,0.010D0,101,122,127, 80,  0,  0,
     & 150,0.028D0,101,124,129, 78,  0,  0,
     & 150,0.010D0,101,124,129, 80,  0,  0,
     & 150,0.026D0,  0, 73, 42,  0,  0,  0,
     & 150,0.030D0,  0, 73, 42, 21,  0,  0,
     & 150,0.029D0,  0, 73, 42, 38, 30,  0/
      DATA (IDK(I),BRFRAC(I),NME(I),(IDKPRD(J,I),J=1,5),I= 533, 551)/
     & 150,0.014D0,  0, 73, 42, 22,  0,  0,
     & 150,0.020D0,  0, 73, 43,  0,  0,  0,
     & 150,0.029D0,  0, 73, 34, 38,  0,  0,
     & 150,0.039D0,  0, 73, 34, 38, 21,  0,
     & 150,0.002D0,  0, 73, 34, 38, 38, 30,
     & 150,0.010D0,  0, 73, 34, 38, 21, 21,
     & 150,0.014D0,  0, 73, 35, 38,  0,  0,
     & 150,0.010D0,  0, 74, 42,  0,  0,  0,
     & 150,0.020D0,  0, 74, 43,  0,  0,  0,
     & 150,0.010D0,  0, 74, 43, 21,  0,  0,
     & 150,0.007D0,  0, 85, 34,  0,  0,  0,
     & 150,0.014D0,  0, 85, 35,  0,  0,  0,
     & 150,0.004D0,  0, 73,293,  0,  0,  0,
     & 150,0.003D0,  0, 73, 38, 30,  0,  0,
     & 150,0.003D0,  0, 73, 38, 30, 38, 30,
     & 150,0.001D0,  0, 73, 56,  0,  0,  0,
     & 150,0.002D0,  0, 73, 46, 34,  0,  0,
     & 150,0.010D0,  0, 78, 38,  0,  0,  0,
     & 150,0.020D0,  0, 78, 39,  0,  0,  0/
      DATA (IDK(I),BRFRAC(I),NME(I),(IDKPRD(J,I),J=1,5),I= 552, 570)/
     & 150,0.030D0,  0, 78, 38, 21,  0,  0,
     & 150,0.010D0,  0, 78, 38, 22,  0,  0,
     & 150,0.020D0,  0, 78, 38, 24,  0,  0,
     & 150,0.035D0,  0, 78, 38, 38, 30,  0,
     & 150,0.020D0,  0, 78, 38, 21, 21,  0,
     & 150,0.010D0,  0, 78, 38, 38, 30, 21,
     & 150,0.010D0,  0, 78, 38, 21, 21, 21,
     & 150,0.007D0,  0, 78, 46, 42,  0,  0,
     & 150,0.011D0,  0, 79, 38,  0,  0,  0,
     & 150,0.022D0,  0, 79, 38, 21,  0,  0,
     & 150,0.013D0,  0, 79, 38, 38, 30,  0,
     & 150,0.010D0,  0, 79, 38, 21, 21,  0,
     & 150,0.007D0,  0, 79, 38, 38, 30, 21,
     & 150,0.005D0,  0, 79, 38, 21, 21, 21,
     & 150,0.005D0,  0, 80, 38,  0,  0,  0,
     & 150,0.015D0,  0, 80, 39,  0,  0,  0,
     & 150,0.011D0,  0, 86, 21,  0,  0,  0,
     & 150,0.007D0,  0, 86, 22,  0,  0,  0,
     & 150,0.010D0,  0, 86, 23,  0,  0,  0/
      DATA (IDK(I),BRFRAC(I),NME(I),(IDKPRD(J,I),J=1,5),I= 571, 589)/
     & 150,0.031D0,  0, 86, 24,  0,  0,  0,
     & 150,0.010D0,  0, 86, 25,  0,  0,  0,
     & 150,0.004D0,  0, 86, 56,  0,  0,  0,
     & 150,0.026D0,  0, 86, 38, 30,  0,  0,
     & 150,0.005D0,  0, 86, 38, 38, 30, 30,
     & 150,0.005D0,  0, 86, 38, 30, 21, 21,
     & 150,0.005D0,  0, 87, 21,  0,  0,  0,
     & 150,0.006D0,  0, 87, 23,  0,  0,  0,
     & 150,0.004D0,  0, 86, 46, 34,  0,  0,
     & 150,0.002D0,  0, 86, 46, 30,  0,  0,
     & 150,0.001D0,  0, 86, 46, 30, 21,  0,
     & 150,0.016D0,  0, 81, 38, 38,  0,  0,
     & 150,0.003D0,  0, 88, 46,  0,  0,  0,
     & 150,0.002D0,  0, 89, 46,  0,  0,  0,
     & 150,0.003D0,  0, 83, 46, 38,  0,  0,
     & 150,0.040D0,  0, 75, 46, 21,  0,  0,
     & 150,0.040D0,  0, 75, 46, 38, 30,  0,
     & 150,0.020D0,  0, 75, 46, 21, 21,  0,
     & 150,0.010D0,  0, 75, 46, 38, 30, 21/
      DATA (IDK(I),BRFRAC(I),NME(I),(IDKPRD(J,I),J=1,5),I= 590, 608)/
     & 150,0.010D0,  0, 75, 46, 21, 21, 21,
     & 150,0.020D0,  0, 75, 47, 21,  0,  0,
     & 150,0.040D0,  0, 75, 42, 38,  0,  0,
     & 150,0.020D0,  0, 75, 42, 39,  0,  0,
     & 150,0.010D0,  0, 75, 42, 38, 38, 30,
     & 150,0.010D0,  0, 75, 42, 38, 21, 21,
     & 150,0.006D0,  0, 75, 43, 38,  0,  0,
     & 151,1.000D0,  0,150, 21,  0,  0,  0,
     & 152,1.000D0,  0,150, 21,  0,  0,  0,
     & 153,1.000D0,  0,150, 30,  0,  0,  0,
     & 154,1.000D0,  0,150, 30,  0,  0,  0,
     & 155,0.045D0,101,122,127, 88,  0,  0,
     & 155,0.005D0,101,122,127, 89,  0,  0,
     & 155,0.045D0,101,124,129, 88,  0,  0,
     & 155,0.005D0,101,124,129, 89,  0,  0,
     & 155,0.021D0,  0, 86, 42,  0,  0,  0,
     & 155,0.032D0,  0, 87, 42,  0,  0,  0,
     & 155,0.032D0,  0, 79, 38, 42,  0,  0,
     & 155,0.045D0,  0, 86, 43,  0,  0,  0/
      DATA (IDK(I),BRFRAC(I),NME(I),(IDKPRD(J,I),J=1,5),I= 609, 627)/
     & 155,0.065D0,  0, 87, 43,  0,  0,  0,
     & 155,0.065D0,  0, 79, 38, 43,  0,  0,
     & 155,0.055D0,  0, 88, 38,  0,  0,  0,
     & 155,0.160D0,  0, 88, 39,  0,  0,  0,
     & 155,0.105D0,  0, 89, 38,  0,  0,  0,
     & 155,0.320D0,  0, 89, 39,  0,  0,  0,
     & 156,1.000D0,  0,155, 59,  0,  0,  0,
     & 157,0.667D0,  0,158, 38,  0,  0,  0,
     & 157,0.333D0,  0,155, 21,  0,  0,  0,
     & 158,0.045D0,101,122,127, 83,  0,  0,
     & 158,0.045D0,101,124,129, 83,  0,  0,
     & 158,0.005D0,101,122,127, 84,  0,  0,
     & 158,0.005D0,101,124,129, 84,  0,  0,
     & 158,0.020D0,  0, 79, 42,  0,  0,  0,
     & 158,0.020D0,  0, 79, 21, 42,  0,  0,
     & 158,0.020D0,  0, 80, 42,  0,  0,  0,
     & 158,0.060D0,  0, 79, 43,  0,  0,  0,
     & 158,0.060D0,  0, 79, 21, 43,  0,  0,
     & 158,0.060D0,  0, 80, 43,  0,  0,  0/
      DATA (IDK(I),BRFRAC(I),NME(I),(IDKPRD(J,I),J=1,5),I= 628, 646)/
     & 158,0.020D0,  0, 86, 34,  0,  0,  0,
     & 158,0.060D0,  0, 86, 35,  0,  0,  0,
     & 158,0.040D0,  0, 87, 34,  0,  0,  0,
     & 158,0.120D0,  0, 87, 35,  0,  0,  0,
     & 158,0.020D0,  0, 83, 38,  0,  0,  0,
     & 158,0.060D0,  0, 83, 39,  0,  0,  0,
     & 158,0.040D0,  0, 84, 38,  0,  0,  0,
     & 158,0.120D0,  0, 84, 39,  0,  0,  0,
     & 158,0.010D0,  0, 88, 21,  0,  0,  0,
     & 158,0.030D0,  0, 88, 23,  0,  0,  0,
     & 158,0.020D0,  0, 89, 21,  0,  0,  0,
     & 158,0.060D0,  0, 89, 23,  0,  0,  0,
     & 158,0.030D0,  0, 88, 56,  0,  0,  0,
     & 158,0.030D0,  0, 90, 46,  0,  0,  0,
     & 159,1.000D0,  0,158, 59,  0,  0,  0,
     & 160,0.670D0,  0,155, 30,  0,  0,  0,
     & 160,0.330D0,  0,158, 21,  0,  0,  0,
     & 161,0.050D0,101,122,127, 90,  0,  0,
     & 161,0.050D0,101,124,129, 90,  0,  0/
      DATA (IDK(I),BRFRAC(I),NME(I),(IDKPRD(J,I),J=1,5),I= 647, 665)/
     & 161,0.075D0,  0, 88, 42,  0,  0,  0,
     & 161,0.225D0,  0, 88, 43,  0,  0,  0,
     & 161,0.150D0,  0, 89, 42,  0,  0,  0,
     & 161,0.450D0,  0, 89, 43,  0,  0,  0,
     & 162,1.000D0,  0,161, 59,  0,  0,  0,
     & 163,0.028D0,  0, 25, 38, 30,  0,  0,
     & 163,0.014D0,  0, 25, 21, 21,  0,  0,
     & 163,0.018D0,  0, 39, 31,  0,  0,  0,
     & 163,0.009D0,  0, 23, 23,  0,  0,  0,
     & 163,0.010D0,  0, 51, 34, 38,  0,  0,
     & 163,0.010D0,  0, 43, 47, 30,  0,  0,
     & 163,0.004D0,  0, 51, 43,  0,  0,  0,
     & 163,0.004D0,  0, 47, 35,  0,  0,  0,
     & 163,0.007D0,  0, 56, 56,  0,  0,  0,
     & 163,0.022D0,  0, 46, 42, 30,  0,  0,
     & 163,0.011D0,  0, 46, 34, 21,  0,  0,
     & 163,0.011D0,  0, 50, 42, 21,  0,  0,
     & 163,0.022D0,  0, 50, 34, 38,  0,  0,
     & 163,0.032D0,  0, 22, 38, 30,  0,  0/
      DATA (IDK(I),BRFRAC(I),NME(I),(IDKPRD(J,I),J=1,5),I= 666, 684)/
     & 163,0.016D0,  0, 22, 21, 21,  0,  0,
     & 163,0.020D0,  0, 38, 30, 46, 34,  0,
     & 163,0.012D0,  0, 38, 30, 38, 30,  0,
     & 163,0.001D0,  0, 73, 91,  0,  0,  0,
     & 163,0.001D0,  0, 59, 59,  0,  0,  0,
     & 163,0.748D0,  0, 13, 13,  0,  0,  0,
     & 164,0.060D0,  0,121,127,  0,  0,  0,
     & 164,0.060D0,  0,123,129,  0,  0,  0,
     & 164,0.004D0,  0, 39, 30,  0,  0,  0,
     & 164,0.004D0,  0, 23, 21,  0,  0,  0,
     & 164,0.004D0,  0, 31, 38,  0,  0,  0,
     & 164,0.003D0,  0, 41, 31,  0,  0,  0,
     & 164,0.003D0,  0, 29, 23,  0,  0,  0,
     & 164,0.003D0,  0, 33, 39,  0,  0,  0,
     & 164,0.009D0,  0, 24, 38, 38, 30, 30,
     & 164,0.007D0,  0, 24, 38, 30,  0,  0,
     & 164,0.003D0,  0, 51, 45,  0,  0,  0,
     & 164,0.003D0,  0, 43, 53,  0,  0,  0,
     & 164,0.003D0,  0, 24, 51, 42,  0,  0/
      DATA (IDK(I),BRFRAC(I),NME(I),(IDKPRD(J,I),J=1,5),I= 685, 703)/
     & 164,0.003D0,  0, 24, 43, 50,  0,  0,
     & 164,0.004D0,  0, 24, 26,  0,  0,  0,
     & 164,0.003D0,  0, 46, 35,  0,  0,  0,
     & 164,0.003D0,  0, 34, 47,  0,  0,  0,
     & 164,0.002D0,  0, 50, 43,  0,  0,  0,
     & 164,0.002D0,  0, 42, 51,  0,  0,  0,
     & 164,0.003D0,  0, 24, 21, 21,  0,  0,
     & 164,0.002D0,  0,286, 30,  0,  0,  0,
     & 164,0.002D0,  0,287, 38,  0,  0,  0,
     & 164,0.003D0,  0, 24, 46, 42, 30,  0,
     & 164,0.003D0,  0, 24, 34, 50, 38,  0,
     & 164,0.002D0,  0,285, 21,  0,  0,  0,
     & 164,0.001D0,  0, 56, 51, 42,  0,  0,
     & 164,0.001D0,  0, 56, 43, 50,  0,  0,
     & 164,0.001D0,  0, 24, 50, 42,  0,  0,
     & 164,0.001D0,  0, 24, 46, 34,  0,  0,
     & 164,0.002D0,  0, 56, 38, 30, 38, 30,
     & 164,0.002D0,  0, 85, 91, 30,  0,  0,
     & 164,0.002D0,  0,103, 73, 38,  0,  0/
      DATA (IDK(I),BRFRAC(I),NME(I),(IDKPRD(J,I),J=1,5),I= 704, 722)/
     & 164,0.002D0,  0, 24, 22,  0,  0,  0,
     & 164,0.001D0,  0, 56, 50, 42,  0,  0,
     & 164,0.001D0,  0, 56, 46, 34,  0,  0,
     & 164,0.001D0,  0, 73, 91, 24,  0,  0,
     & 164,0.001D0,  0, 85,103,  0,  0,  0,
     & 164,0.001D0,  0, 82,100,  0,  0,  0,
     & 164,0.001D0,  0, 87,105,  0,  0,  0,
     & 164,0.001D0,  0, 73, 91, 25,  0,  0,
     & 164,0.001D0,  0, 56, 58,  0,  0,  0,
     & 164,0.001D0,  0, 56, 38, 30,  0,  0,
     & 164,0.001D0,  0, 56, 46, 42, 30,  0,
     & 164,0.001D0,  0, 56, 34, 50, 38,  0,
     & 164,0.001D0,  0, 56, 22,  0,  0,  0,
     & 164,0.001D0,  0, 84,102,  0,  0,  0,
     & 164,0.001D0,  0, 73, 34, 98,  0,  0,
     & 164,0.001D0,  0, 91, 46, 80,  0,  0,
     & 164,0.034D0,  0, 38, 38, 30, 30, 21,
     & 164,0.029D0,  0, 23, 23, 23, 21,  0,
     & 164,0.015D0,  0, 38, 30, 21,  0,  0/
      DATA (IDK(I),BRFRAC(I),NME(I),(IDKPRD(J,I),J=1,5),I= 723, 741)/
     & 164,0.012D0,  0, 38, 30, 21, 34, 46,
     & 164,0.009D0,  0, 23, 23, 23, 24,  0,
     & 164,0.007D0,  0, 38, 30, 34, 46,  0,
     & 164,0.002D0,  0, 46, 42, 30,  0,  0,
     & 164,0.001D0,  0, 46, 34, 21,  0,  0,
     & 164,0.001D0,  0, 50, 42, 21,  0,  0,
     & 164,0.002D0,  0, 50, 34, 38,  0,  0,
     & 164,0.006D0,  0, 73, 91, 38, 30,  0,
     & 164,0.004D0,  0, 38, 30, 38, 30,  0,
     & 164,0.004D0,  0, 38, 30, 38, 30, 23,
     & 164,0.004D0,  0, 75, 93, 38, 30,  0,
     & 164,0.001D0,  0, 86,104,  0,  0,  0,
     & 164,0.001D0,  0, 79, 97,  0,  0,  0,
     & 164,0.001D0,  0, 81, 99,  0,  0,  0,
     & 164,0.003D0,  0, 23, 23, 34, 46,  0,
     & 164,0.002D0,  0, 73, 91, 38, 30, 21,
     & 164,0.002D0,  0, 73, 91,  0,  0,  0,
     & 164,0.002D0,  0, 73, 91, 22,  0,  0,
     & 164,0.002D0,  0, 73, 93, 30,  0,  0/
      DATA (IDK(I),BRFRAC(I),NME(I),(IDKPRD(J,I),J=1,5),I= 742, 760)/
     & 164,0.002D0,  0, 75, 93,  0,  0,  0,
     & 164,0.001D0,  0, 83,102,  0,  0,  0,
     & 164,0.001D0,  0, 88,106,  0,  0,  0,
     & 164,0.001D0,  0, 78, 96,  0,  0,  0,
     & 164,0.001D0,  0, 73, 91, 21,  0,  0,
     & 164,0.001D0,  0, 78,104, 38,  0,  0,
     & 164,0.001D0,  0, 96, 86, 30,  0,  0,
     & 164,0.001D0,  0, 73, 34, 96,  0,  0,
     & 164,0.001D0,  0, 91, 46, 78,  0,  0,
     & 164,0.001D0,  0, 46, 34, 46, 34,  0,
     & 164,0.013D0,  0, 59,163,  0,  0,  0,
     & 164,0.008D0,  0, 59, 38, 30, 21, 21,
     & 164,0.004D0,  0, 59, 22, 38, 30,  0,
     & 164,0.002D0,  0, 59, 22, 21, 21,  0,
     & 164,0.003D0,  0, 59, 39, 31,  0,  0,
     & 164,0.002D0,  0, 59, 23, 23,  0,  0,
     & 164,0.004D0,  0, 59, 25,  0,  0,  0,
     & 164,0.003D0,  0, 59, 38, 30, 38, 30,
     & 164,0.002D0,  0, 59, 24, 24,  0,  0/
      DATA (IDK(I),BRFRAC(I),NME(I),(IDKPRD(J,I),J=1,5),I= 761, 779)/
     & 164,0.001D0,  0, 59, 26,  0,  0,  0,
     & 164,0.001D0,  0, 59, 22,  0,  0,  0,
     & 164,0.001D0,  0, 59, 28,  0,  0,  0,
     & 164,0.001D0,  0, 59, 58,  0,  0,  0,
     & 164,0.020D0,  0,  1,  7,  0,  0,  0,
     & 164,0.080D0,  0,  2,  8,  0,  0,  0,
     & 164,0.020D0,  0,  3,  9,  0,  0,  0,
     & 164,0.364D0,130, 13, 13, 13,  0,  0,
     & 164,0.091D0,130, 13, 13, 59,  0,  0,
     & 165,0.037D0,  0, 38, 30, 38, 30,  0,
     & 165,0.030D0,  0, 38, 30, 46, 34,  0,
     & 165,0.016D0,  0, 23, 38, 30,  0,  0,
     & 165,0.015D0,  0, 23, 38, 30, 38, 30,
     & 165,0.004D0,  0, 46, 43, 30,  0,  0,
     & 165,0.002D0,  0, 46, 35, 21,  0,  0,
     & 165,0.002D0,  0, 51, 43, 21,  0,  0,
     & 165,0.004D0,  0, 51, 35, 38,  0,  0,
     & 165,0.008D0,  0, 38, 30,  0,  0,  0,
     & 165,0.007D0,  0, 46, 34,  0,  0,  0/
      DATA (IDK(I),BRFRAC(I),NME(I),(IDKPRD(J,I),J=1,5),I= 780, 798)/
     & 165,0.005D0,  0, 38, 30, 73, 91,  0,
     & 165,0.003D0,  0, 21, 21,  0,  0,  0,
     & 165,0.003D0,  0, 22, 22,  0,  0,  0,
     & 165,0.007D0,  0, 59,164,  0,  0,  0,
     & 165,0.857D0,  0, 13, 13,  0,  0,  0,
     & 166,0.008D0,  0,121,127,  0,  0,  0,
     & 166,0.008D0,  0,123,129,  0,  0,  0,
     & 166,0.001D0,  0,125,131,  0,  0,  0,
     & 166,0.338D0,  0,164, 38, 30,  0,  0,
     & 166,0.169D0,  0,164, 21, 21,  0,  0,
     & 166,0.027D0,  0,164, 22,  0,  0,  0,
     & 166,0.001D0,  0,164, 21,  0,  0,  0,
     & 166,0.004D0,  0, 23, 23, 23, 21,  0,
     & 166,0.003D0,  0, 23, 23, 21,  0,  0,
     & 166,0.002D0,  0, 38, 30, 46, 34,  0,
     & 166,0.001D0,  0, 38, 30, 73, 91,  0,
     & 166,0.093D0,  0, 59,165,  0,  0,  0,
     & 166,0.087D0,  0, 59,302,  0,  0,  0,
     & 166,0.078D0,  0, 59,303,  0,  0,  0/
      DATA (IDK(I),BRFRAC(I),NME(I),(IDKPRD(J,I),J=1,5),I= 799, 817)/
     & 166,0.003D0,  0, 59,163,  0,  0,  0,
     & 166,0.003D0,  0,  1,  7,  0,  0,  0,
     & 166,0.012D0,  0,  2,  8,  0,  0,  0,
     & 166,0.003D0,  0,  3,  9,  0,  0,  0,
     & 166,0.127D0,130, 13, 13, 13,  0,  0,
     & 166,0.032D0,130, 13, 13, 59,  0,  0,
     & 167,0.500D0,  0,136,171,  0,  0,  0,
     & 167,0.500D0,  0,140,175,  0,  0,  0,
     & 171,0.067D0,101,128,121, 50,  0,  0,
     & 171,0.067D0,101,130,123, 50,  0,  0,
     & 171,0.048D0,101,128,121, 51,  0,  0,
     & 171,0.048D0,101,130,123, 51,  0,  0,
     & 171,0.003D0,  0,128,121, 46, 30,  0,
     & 171,0.003D0,  0,130,123, 46, 30,  0,
     & 171,0.006D0,101,128,121, 21,  0,  0,
     & 171,0.006D0,101,130,123, 21,  0,  0,
     & 171,0.002D0,101,128,121, 23,  0,  0,
     & 171,0.002D0,101,130,123, 23,  0,  0,
     & 171,0.055D0,  0, 46, 30, 30,  0,  0/
      DATA (IDK(I),BRFRAC(I),NME(I),(IDKPRD(J,I),J=1,5),I= 818, 836)/
     & 171,0.031D0,  0, 46, 31, 30,  0,  0,
     & 171,0.042D0,  0, 46, 30, 30, 21, 21,
     & 171,0.002D0,  0, 46, 30, 30, 30, 39,
     & 171,0.021D0,  0, 47, 30, 30,  0,  0,
     & 171,0.027D0,  0, 50, 30,  0,  0,  0,
     & 171,0.066D0,  0, 50, 31,  0,  0,  0,
     & 171,0.081D0,  0, 50, 32,  0,  0,  0,
     & 171,0.024D0,  0, 50, 30, 21,  0,  0,
     & 171,0.004D0,  0, 50, 30, 23,  0,  0,
     & 171,0.069D0,  0, 50, 30, 30, 38, 21,
     & 171,0.001D0,  0, 50, 30, 30, 38, 23,
     & 171,0.022D0,  0, 51, 30,  0,  0,  0,
     & 171,0.021D0,  0, 51, 31,  0,  0,  0,
     & 171,0.042D0,  0, 51, 30, 21,  0,  0,
     & 171,0.008D0,  0, 51, 30, 23,  0,  0,
     & 171,0.010D0,  0, 51, 30, 30, 38,  0,
     & 171,0.050D0,  0,309, 30,  0,  0,  0,
     & 171,0.034D0,  0,328, 30,  0,  0,  0,
     & 171,0.010D0,  0,368, 30,  0,  0,  0/
      DATA (IDK(I),BRFRAC(I),NME(I),(IDKPRD(J,I),J=1,5),I= 837, 855)/
     & 171,0.031D0,  0, 34, 50, 50,  0,  0,
     & 171,0.003D0,  0, 30, 21,  0,  0,  0,
     & 171,0.001D0,  0, 30, 23,  0,  0,  0,
     & 171,0.002D0,  0, 30, 30, 38,  0,  0,
     & 171,0.008D0,  0, 30, 22,  0,  0,  0,
     & 171,0.001D0,  0, 30, 30, 30, 38, 38,
     & 171,0.003D0,  0, 30, 30, 30, 38, 39,
     & 171,0.008D0,  0, 34, 50,  0,  0,  0,
     & 171,0.005D0,  0, 34, 51,  0,  0,  0,
     & 171,0.026D0,  0, 35, 51,  0,  0,  0,
     & 171,0.005D0,  0, 34, 46, 30,  0,  0,
     & 171,0.007D0,  0, 30, 56,  0,  0,  0,
     & 171,0.023D0,  0, 30, 56, 21,  0,  0,
     & 171,0.005D0,  0, 34, 34, 46,  0,  0,
     & 172,0.683D0,  0,175, 30,  0,  0,  0,
     & 172,0.306D0,  0,171, 21,  0,  0,  0,
     & 172,0.011D0,  0,171, 59,  0,  0,  0,
     & 173,0.667D0,  0,176, 30,  0,  0,  0,
     & 173,0.333D0,  0,172, 21,  0,  0,  0/
      DATA (IDK(I),BRFRAC(I),NME(I),(IDKPRD(J,I),J=1,5),I= 856, 874)/
     & 174,0.220D0,  0,175, 30,  0,  0,  0,
     & 174,0.110D0,  0,171, 21,  0,  0,  0,
     & 174,0.380D0,  0,176, 30,  0,  0,  0,
     & 174,0.190D0,  0,172, 21,  0,  0,  0,
     & 174,0.004D0,  0,171, 22,  0,  0,  0,
     & 174,0.064D0,  0,176, 30, 21,  0,  0,
     & 174,0.032D0,  0,172, 38, 30,  0,  0,
     & 175,0.037D0,101,128,121, 46,  0,  0,
     & 175,0.037D0,101,130,123, 46,  0,  0,
     & 175,0.016D0,101,128,121, 47,  0,  0,
     & 175,0.016D0,101,130,123, 47,  0,  0,
     & 175,0.013D0,  0,128,121, 46, 21,  0,
     & 175,0.013D0,  0,130,123, 46, 21,  0,
     & 175,0.012D0,  0,128,121, 50, 38,  0,
     & 175,0.012D0,  0,130,123, 50, 38,  0,
     & 175,0.003D0,101,128,121, 38,  0,  0,
     & 175,0.003D0,101,130,123, 38,  0,  0,
     & 175,0.039D0,  0, 46, 30,  0,  0,  0,
     & 175,0.091D0,  0, 46, 31,  0,  0,  0/
      DATA (IDK(I),BRFRAC(I),NME(I),(IDKPRD(J,I),J=1,5),I= 875, 893)/
     & 175,0.067D0,  0, 46, 32,  0,  0,  0,
     & 175,0.004D0,  0, 46, 30, 21,  0,  0,
     & 175,0.100D0,  0, 46, 30, 21, 21,  0,
     & 175,0.058D0,  0, 46, 30, 23,  0,  0,
     & 175,0.020D0,  0, 46, 30, 24,  0,  0,
     & 175,0.006D0,  0, 46, 30, 25,  0,  0,
     & 175,0.043D0,  0, 47, 30,  0,  0,  0,
     & 175,0.035D0,  0, 47, 31,  0,  0,  0,
     & 175,0.007D0,  0,310, 30,  0,  0,  0,
     & 175,0.007D0,  0,327, 30,  0,  0,  0,
     & 175,0.020D0,  0, 50, 21,  0,  0,  0,
     & 175,0.006D0,  0, 50, 22,  0,  0,  0,
     & 175,0.009D0,  0, 50, 23,  0,  0,  0,
     & 175,0.016D0,  0, 50, 24,  0,  0,  0,
     & 175,0.014D0,  0, 50, 25,  0,  0,  0,
     & 175,0.003D0,  0, 50,293,  0,  0,  0,
     & 175,0.007D0,  0, 50, 56,  0,  0,  0,
     & 175,0.003D0,  0, 50, 26,  0,  0,  0,
     & 175,0.004D0,  0, 50,294,  0,  0,  0/
      DATA (IDK(I),BRFRAC(I),NME(I),(IDKPRD(J,I),J=1,5),I= 894, 912)/
     & 175,0.006D0,  0, 50, 21, 21,  0,  0,
     & 175,0.042D0,  0, 50, 30, 38, 21,  0,
     & 175,0.004D0,  0, 50, 30, 30, 38, 38,
     & 175,0.076D0,  0, 50, 30, 38, 21, 21,
     & 175,0.026D0,  0, 51, 21,  0,  0,  0,
     & 175,0.014D0,  0, 51, 22,  0,  0,  0,
     & 175,0.014D0,  0, 51, 23,  0,  0,  0,
     & 175,0.011D0,  0, 51, 24,  0,  0,  0,
     & 175,0.018D0,  0, 51, 30, 38,  0,  0,
     & 175,0.004D0,  0, 50, 34, 46,  0,  0,
     & 175,0.004D0,  0, 50, 34, 46, 21,  0,
     & 175,0.005D0,  0, 50, 50, 42,  0,  0,
     & 175,0.002D0,  0, 30, 38,  0,  0,  0,
     & 175,0.001D0,  0, 21, 21,  0,  0,  0,
     & 175,0.008D0,  0, 30, 38, 21,  0,  0,
     & 175,0.007D0,  0, 30, 30, 38, 38,  0,
     & 175,0.015D0,  0, 30, 30, 38, 38, 21,
     & 175,0.004D0,  0, 34, 46,  0,  0,  0,
     & 175,0.003D0,  0, 35, 46,  0,  0,  0/
      DATA (IDK(I),BRFRAC(I),NME(I),(IDKPRD(J,I),J=1,5),I= 913, 931)/
     & 175,0.002D0,  0, 34, 47,  0,  0,  0,
     & 175,0.001D0,  0, 42, 50,  0,  0,  0,
     & 175,0.002D0,  0, 43, 51,  0,  0,  0,
     & 175,0.003D0,  0, 42, 46, 30,  0,  0,
     & 175,0.003D0,  0, 50, 34, 38,  0,  0,
     & 175,0.001D0,  0, 34, 46, 30, 38, 21,
     & 175,0.002D0,  0, 56, 23,  0,  0,  0,
     & 175,0.001D0,  0, 56, 30, 38,  0,  0,
     & 176,0.636D0,  0,175, 21,  0,  0,  0,
     & 176,0.364D0,  0,175, 59,  0,  0,  0,
     & 177,0.667D0,  0,172, 38,  0,  0,  0,
     & 177,0.333D0,  0,176, 21,  0,  0,  0,
     & 178,0.220D0,  0,171, 38,  0,  0,  0,
     & 178,0.110D0,  0,175, 21,  0,  0,  0,
     & 178,0.380D0,  0,172, 38,  0,  0,  0,
     & 178,0.190D0,  0,176, 21,  0,  0,  0,
     & 178,0.004D0,  0,175, 22,  0,  0,  0,
     & 178,0.064D0,  0,172, 38, 21,  0,  0,
     & 178,0.032D0,  0,176, 38, 30,  0,  0/
      DATA (IDK(I),BRFRAC(I),NME(I),(IDKPRD(J,I),J=1,5),I= 932, 950)/
     & 179,0.009D0,  0,130,123,  0,  0,  0,
     & 179,0.019D0,101,128,121, 56,  0,  0,
     & 179,0.019D0,101,130,123, 56,  0,  0,
     & 179,0.025D0,101,128,121, 22,  0,  0,
     & 179,0.025D0,101,130,123, 22,  0,  0,
     & 179,0.009D0,101,128,121, 25,  0,  0,
     & 179,0.009D0,101,130,123, 25,  0,  0,
     & 179,0.036D0,  0, 34, 50,  0,  0,  0,
     & 179,0.034D0,  0, 34, 51,  0,  0,  0,
     & 179,0.007D0,  0, 34,328,  0,  0,  0,
     & 179,0.043D0,  0, 35, 50,  0,  0,  0,
     & 179,0.058D0,  0, 35, 51,  0,  0,  0,
     & 179,0.011D0,  0, 34, 46, 30,  0,  0,
     & 179,0.055D0,  0, 34, 46, 30, 21,  0,
     & 179,0.003D0,  0, 34, 46, 30, 38, 30,
     & 179,0.014D0,  0, 34, 50, 38, 30,  0,
     & 179,0.017D0,  0, 42, 46, 30, 30,  0,
     & 179,0.036D0,  0, 56, 30,  0,  0,  0,
     & 179,0.067D0,  0, 56, 31,  0,  0,  0/
      DATA (IDK(I),BRFRAC(I),NME(I),(IDKPRD(J,I),J=1,5),I= 951, 969)/
     & 179,0.023D0,  0, 56, 30, 21,  0,  0,
     & 179,0.018D0,  0, 56, 30, 38, 30,  0,
     & 179,0.020D0,  0, 22, 30,  0,  0,  0,
     & 179,0.001D0,  0, 23, 30,  0,  0,  0,
     & 179,0.009D0,  0, 24, 30,  0,  0,  0,
     & 179,0.049D0,  0, 25, 30,  0,  0,  0,
     & 179,0.011D0,  0,293, 30,  0,  0,  0,
     & 179,0.015D0,  0, 22, 30, 21,  0,  0,
     & 179,0.016D0,  0, 25, 30, 21,  0,  0,
     & 179,0.103D0,  0, 22, 31,  0,  0,  0,
     & 179,0.120D0,  0, 25, 31,  0,  0,  0,
     & 179,0.010D0,  0, 30, 38, 30,  0,  0,
     & 179,0.046D0,  0, 30, 38, 30, 21,  0,
     & 179,0.003D0,  0, 30, 38, 38, 30, 30,
     & 179,0.042D0,  0, 30, 38, 38, 30, 31,
     & 179,0.001D0,  0, 34, 23,  0,  0,  0,
     & 179,0.005D0,  0, 34, 38, 30,  0,  0,
     & 179,0.001D0,  0, 34, 56,  0,  0,  0,
     & 179,0.004D0,  0, 42, 30,  0,  0,  0/
      DATA (IDK(I),BRFRAC(I),NME(I),(IDKPRD(J,I),J=1,5),I= 970, 988)/
     & 179,0.007D0,  0, 43, 30,  0,  0,  0,
     & 180,0.900D0,  0,179, 59,  0,  0,  0,
     & 180,0.100D0,  0,179, 21,  0,  0,  0,
     & 181,0.500D0,  0,172, 42,  0,  0,  0,
     & 181,0.500D0,  0,176, 34,  0,  0,  0,
     & 182,0.440D0,  0,171, 42,  0,  0,  0,
     & 182,0.440D0,  0,175, 34,  0,  0,  0,
     & 182,0.055D0,  0,172, 42,  0,  0,  0,
     & 182,0.055D0,  0,176, 34,  0,  0,  0,
     & 182,0.010D0,  0,179, 22,  0,  0,  0,
     & 183,1.000D0,  0,185, 30,  0,  0,  0,
     & 184,1.000D0,  0,185, 30,  0,  0,  0,
     & 185,0.028D0,101,128,121, 96,  0,  0,
     & 185,0.010D0,101,128,121, 98,  0,  0,
     & 185,0.028D0,101,130,123, 96,  0,  0,
     & 185,0.010D0,101,130,123, 98,  0,  0,
     & 185,0.026D0,  0, 91, 50,  0,  0,  0,
     & 185,0.030D0,  0, 91, 50, 21,  0,  0,
     & 185,0.029D0,  0, 91, 50, 38, 30,  0/
      DATA (IDK(I),BRFRAC(I),NME(I),(IDKPRD(J,I),J=1,5),I= 989,1007)/
     & 185,0.014D0,  0, 91, 50, 22,  0,  0,
     & 185,0.020D0,  0, 91, 51,  0,  0,  0,
     & 185,0.029D0,  0, 91, 46, 30,  0,  0,
     & 185,0.039D0,  0, 91, 46, 30, 21,  0,
     & 185,0.002D0,  0, 91, 46, 30, 30, 38,
     & 185,0.010D0,  0, 91, 46, 30, 21, 21,
     & 185,0.014D0,  0, 91, 47, 30,  0,  0,
     & 185,0.010D0,  0, 92, 50,  0,  0,  0,
     & 185,0.020D0,  0, 92, 51,  0,  0,  0,
     & 185,0.010D0,  0, 92, 51, 21,  0,  0,
     & 185,0.007D0,  0,103, 46,  0,  0,  0,
     & 185,0.014D0,  0,103, 47,  0,  0,  0,
     & 185,0.004D0,  0, 91,293,  0,  0,  0,
     & 185,0.003D0,  0, 91, 38, 30,  0,  0,
     & 185,0.003D0,  0, 91, 38, 30, 38, 30,
     & 185,0.001D0,  0, 91, 56,  0,  0,  0,
     & 185,0.002D0,  0, 91, 46, 34,  0,  0,
     & 185,0.010D0,  0, 96, 30,  0,  0,  0,
     & 185,0.020D0,  0, 96, 31,  0,  0,  0/
      DATA (IDK(I),BRFRAC(I),NME(I),(IDKPRD(J,I),J=1,5),I=1008,1026)/
     & 185,0.030D0,  0, 96, 30, 21,  0,  0,
     & 185,0.010D0,  0, 96, 30, 22,  0,  0,
     & 185,0.020D0,  0, 96, 30, 24,  0,  0,
     & 185,0.035D0,  0, 96, 30, 30, 38,  0,
     & 185,0.020D0,  0, 96, 30, 21, 21,  0,
     & 185,0.010D0,  0, 96, 30, 38, 30, 21,
     & 185,0.010D0,  0, 96, 30, 21, 21, 21,
     & 185,0.007D0,  0, 96, 34, 50,  0,  0,
     & 185,0.011D0,  0, 97, 30,  0,  0,  0,
     & 185,0.022D0,  0, 97, 30, 21,  0,  0,
     & 185,0.013D0,  0, 97, 30, 38, 30,  0,
     & 185,0.010D0,  0, 97, 30, 21, 21,  0,
     & 185,0.007D0,  0, 97, 30, 38, 30, 21,
     & 185,0.005D0,  0, 97, 30, 21, 21, 21,
     & 185,0.005D0,  0, 98, 30,  0,  0,  0,
     & 185,0.015D0,  0, 98, 31,  0,  0,  0,
     & 185,0.011D0,  0,104, 21,  0,  0,  0,
     & 185,0.007D0,  0,104, 22,  0,  0,  0,
     & 185,0.010D0,  0,104, 23,  0,  0,  0/
      DATA (IDK(I),BRFRAC(I),NME(I),(IDKPRD(J,I),J=1,5),I=1027,1045)/
     & 185,0.031D0,  0,104, 24,  0,  0,  0,
     & 185,0.010D0,  0,104, 25,  0,  0,  0,
     & 185,0.004D0,  0,104, 56,  0,  0,  0,
     & 185,0.026D0,  0,104, 38, 30,  0,  0,
     & 185,0.005D0,  0,104, 38, 38, 30, 30,
     & 185,0.005D0,  0,104, 38, 30, 21, 21,
     & 185,0.005D0,  0,105, 21,  0,  0,  0,
     & 185,0.006D0,  0,105, 23,  0,  0,  0,
     & 185,0.004D0,  0,104, 46, 34,  0,  0,
     & 185,0.002D0,  0,104, 34, 38,  0,  0,
     & 185,0.001D0,  0,104, 34, 38, 21,  0,
     & 185,0.016D0,  0, 99, 30, 30,  0,  0,
     & 185,0.003D0,  0,106, 34,  0,  0,  0,
     & 185,0.002D0,  0,107, 34,  0,  0,  0,
     & 185,0.003D0,  0,101, 34, 30,  0,  0,
     & 185,0.040D0,  0, 93, 34, 21,  0,  0,
     & 185,0.040D0,  0, 93, 34, 38, 30,  0,
     & 185,0.020D0,  0, 93, 34, 21, 21,  0,
     & 185,0.010D0,  0, 93, 34, 38, 30, 21/
      DATA (IDK(I),BRFRAC(I),NME(I),(IDKPRD(J,I),J=1,5),I=1046,1064)/
     & 185,0.010D0,  0, 93, 34, 21, 21, 21,
     & 185,0.020D0,  0, 93, 35, 21,  0,  0,
     & 185,0.040D0,  0, 93, 50, 30,  0,  0,
     & 185,0.020D0,  0, 93, 50, 31,  0,  0,
     & 185,0.010D0,  0, 93, 50, 30, 38, 30,
     & 185,0.010D0,  0, 93, 50, 30, 21, 21,
     & 185,0.006D0,  0, 93, 51, 30,  0,  0,
     & 186,1.000D0,  0,185, 21,  0,  0,  0,
     & 187,1.000D0,  0,185, 21,  0,  0,  0,
     & 188,1.000D0,  0,185, 38,  0,  0,  0,
     & 189,1.000D0,  0,185, 38,  0,  0,  0,
     & 190,0.045D0,101,128,121,106,  0,  0,
     & 190,0.005D0,101,128,121,107,  0,  0,
     & 190,0.045D0,101,130,123,106,  0,  0,
     & 190,0.005D0,101,130,123,107,  0,  0,
     & 190,0.021D0,  0,104, 50,  0,  0,  0,
     & 190,0.032D0,  0,105, 50,  0,  0,  0,
     & 190,0.032D0,  0, 97, 30, 50,  0,  0,
     & 190,0.045D0,  0,104, 51,  0,  0,  0/
      DATA (IDK(I),BRFRAC(I),NME(I),(IDKPRD(J,I),J=1,5),I=1065,1083)/
     & 190,0.065D0,  0,105, 51,  0,  0,  0,
     & 190,0.065D0,  0, 97, 30, 51,  0,  0,
     & 190,0.055D0,  0,106, 30,  0,  0,  0,
     & 190,0.160D0,  0,106, 31,  0,  0,  0,
     & 190,0.105D0,  0,107, 30,  0,  0,  0,
     & 190,0.320D0,  0,107, 31,  0,  0,  0,
     & 191,1.000D0,  0,190, 59,  0,  0,  0,
     & 192,0.667D0,  0,193, 30,  0,  0,  0,
     & 192,0.333D0,  0,190, 21,  0,  0,  0,
     & 193,0.045D0,101,128,121,101,  0,  0,
     & 193,0.045D0,101,130,123,101,  0,  0,
     & 193,0.005D0,101,128,121,102,  0,  0,
     & 193,0.005D0,101,130,123,102,  0,  0,
     & 193,0.020D0,  0, 97, 50,  0,  0,  0,
     & 193,0.020D0,  0, 97, 21, 50,  0,  0,
     & 193,0.020D0,  0, 98, 50,  0,  0,  0,
     & 193,0.060D0,  0, 97, 51,  0,  0,  0,
     & 193,0.060D0,  0, 97, 21, 51,  0,  0,
     & 193,0.060D0,  0, 98, 51,  0,  0,  0/
      DATA (IDK(I),BRFRAC(I),NME(I),(IDKPRD(J,I),J=1,5),I=1084,1102)/
     & 193,0.020D0,  0,104, 46,  0,  0,  0,
     & 193,0.060D0,  0,104, 47,  0,  0,  0,
     & 193,0.040D0,  0,105, 46,  0,  0,  0,
     & 193,0.120D0,  0,105, 47,  0,  0,  0,
     & 193,0.020D0,  0,101, 30,  0,  0,  0,
     & 193,0.060D0,  0,101, 31,  0,  0,  0,
     & 193,0.040D0,  0,102, 30,  0,  0,  0,
     & 193,0.120D0,  0,102, 31,  0,  0,  0,
     & 193,0.010D0,  0,106, 21,  0,  0,  0,
     & 193,0.030D0,  0,106, 23,  0,  0,  0,
     & 193,0.020D0,  0,107, 21,  0,  0,  0,
     & 193,0.060D0,  0,107, 23,  0,  0,  0,
     & 193,0.030D0,  0,106, 56,  0,  0,  0,
     & 193,0.030D0,  0,108, 34,  0,  0,  0,
     & 194,1.000D0,  0,193, 59,  0,  0,  0,
     & 195,0.670D0,  0,190, 38,  0,  0,  0,
     & 195,0.330D0,  0,193, 21,  0,  0,  0,
     & 196,0.050D0,101,128,121,108,  0,  0,
     & 196,0.050D0,101,130,123,108,  0,  0/
      DATA (IDK(I),BRFRAC(I),NME(I),(IDKPRD(J,I),J=1,5),I=1103,1121)/
     & 196,0.075D0,  0,106, 50,  0,  0,  0,
     & 196,0.225D0,  0,106, 51,  0,  0,  0,
     & 196,0.150D0,  0,107, 50,  0,  0,  0,
     & 196,0.450D0,  0,107, 51,  0,  0,  0,
     & 197,1.000D0,  0,196, 59,  0,  0,  0,
     & 209,0.250D0,100,  1,  8,  4,  0,  0,
     & 209,0.250D0,100,  3, 10,  4,  0,  0,
     & 209,0.250D0,100,  5, 12,  4,  0,  0,
     & 209,0.085D0,100,121,128,  4,  0,  0,
     & 209,0.085D0,100,123,130,  4,  0,  0,
     & 209,0.080D0,100,125,132,  4,  0,  0,
     & 210,0.250D0,100,  2,  7,209,  0,  0,
     & 210,0.250D0,100,  4,  9,209,  0,  0,
     & 210,0.250D0,100,  6, 11,209,  0,  0,
     & 210,0.085D0,100,122,127,209,  0,  0,
     & 210,0.085D0,100,124,129,209,  0,  0,
     & 210,0.080D0,100,126,131,209,  0,  0,
     & 211,0.250D0,100,  1,  8,  6,  0,  0,
     & 211,0.250D0,100,  3, 10,  6,  0,  0/
      DATA (IDK(I),BRFRAC(I),NME(I),(IDKPRD(J,I),J=1,5),I=1122,1140)/
     & 211,0.250D0,100,  5, 12,  6,  0,  0,
     & 211,0.085D0,100,121,128,  6,  0,  0,
     & 211,0.085D0,100,123,130,  6,  0,  0,
     & 211,0.080D0,100,125,132,  6,  0,  0,
     & 212,0.250D0,100,  2,  7,211,  0,  0,
     & 212,0.250D0,100,  4,  9,211,  0,  0,
     & 212,0.250D0,100,  6, 11,211,  0,  0,
     & 212,0.085D0,100,122,127,211,  0,  0,
     & 212,0.085D0,100,124,129,211,  0,  0,
     & 212,0.080D0,100,126,131,211,  0,  0,
     & 215,0.250D0,100,  7,  2, 10,  0,  0,
     & 215,0.250D0,100,  9,  4, 10,  0,  0,
     & 215,0.250D0,100, 11,  6, 10,  0,  0,
     & 215,0.085D0,100,127,122, 10,  0,  0,
     & 215,0.085D0,100,129,124, 10,  0,  0,
     & 215,0.080D0,100,131,126, 10,  0,  0,
     & 216,0.250D0,100,  8,  1,215,  0,  0,
     & 216,0.250D0,100, 10,  3,215,  0,  0,
     & 216,0.250D0,100, 12,  5,215,  0,  0/
      DATA (IDK(I),BRFRAC(I),NME(I),(IDKPRD(J,I),J=1,5),I=1141,1159)/
     & 216,0.085D0,100,128,121,215,  0,  0,
     & 216,0.085D0,100,130,123,215,  0,  0,
     & 216,0.080D0,100,132,125,215,  0,  0,
     & 217,0.250D0,100,  7,  2, 12,  0,  0,
     & 217,0.250D0,100,  9,  4, 12,  0,  0,
     & 217,0.250D0,100, 11,  6, 12,  0,  0,
     & 217,0.085D0,100,127,122, 12,  0,  0,
     & 217,0.085D0,100,129,124, 12,  0,  0,
     & 217,0.080D0,100,131,126, 12,  0,  0,
     & 218,0.250D0,100,  8,  1,217,  0,  0,
     & 218,0.250D0,100, 10,  3,217,  0,  0,
     & 218,0.250D0,100, 12,  5,217,  0,  0,
     & 218,0.085D0,100,128,121,217,  0,  0,
     & 218,0.085D0,100,130,123,217,  0,  0,
     & 218,0.080D0,100,132,125,217,  0,  0,
     & 221,0.016D0,101,121,128,136,  0,  0,
     & 221,0.016D0,101,123,130,136,  0,  0,
     & 221,0.008D0,101,125,132,136,  0,  0,
     & 221,0.048D0,101,121,128,137,  0,  0/
      DATA (IDK(I),BRFRAC(I),NME(I),(IDKPRD(J,I),J=1,5),I=1160,1178)/
     & 221,0.048D0,101,123,130,137,  0,  0,
     & 221,0.022D0,101,125,132,137,  0,  0,
     & 221,0.003D0,101,121,128,331,  0,  0,
     & 221,0.003D0,101,123,130,331,  0,  0,
     & 221,0.001D0,101,125,132,331,  0,  0,
     & 221,0.008D0,101,121,128,138,  0,  0,
     & 221,0.008D0,101,123,130,138,  0,  0,
     & 221,0.004D0,101,125,132,138,  0,  0,
     & 221,0.008D0,101,121,128,313,  0,  0,
     & 221,0.008D0,101,123,130,313,  0,  0,
     & 221,0.004D0,101,125,132,313,  0,  0,
     & 221,0.013D0,101,121,128,139,  0,  0,
     & 221,0.013D0,101,123,130,139,  0,  0,
     & 221,0.006D0,101,125,132,139,  0,  0,
     & 221,0.004D0,  0,136, 30,  0,  0,  0,
     & 221,0.010D0,  0,136, 31,  0,  0,  0,
     & 221,0.006D0,  0,136, 32,  0,  0,  0,
     & 221,0.003D0,  0,137, 30,  0,  0,  0,
     & 221,0.009D0,  0,137, 31,  0,  0,  0/
      DATA (IDK(I),BRFRAC(I),NME(I),(IDKPRD(J,I),J=1,5),I=1179,1197)/
     & 221,0.017D0,  0,137, 32,  0,  0,  0,
     & 221,0.011D0,  0,136,179,  0,  0,  0,
     & 221,0.015D0,  0,136,180,  0,  0,  0,
     & 221,0.011D0,  0,137,179,  0,  0,  0,
     & 221,0.022D0,  0,137,180,  0,  0,  0,
     & 221,0.001D0,  0,164, 42,  0,  0,  0,
     & 221,0.002D0,  0,164, 43,  0,  0,  0,
     & 221,0.001D0,  0,165, 42,  0,  0,  0,
     & 221,0.001D0,  0,165, 43,  0,  0,  0,
     & 221,0.001D0,  0,166, 42,  0,  0,  0,
     & 221,0.001D0,  0,166, 43,  0,  0,  0,
     & 221,0.207D0,100,  1,  8,  4,  7,  0,
     & 221,0.207D0,100,  3, 10,  4,  7,  0,
     & 221,0.024D0,100,  1,  8,  2,  7,  0,
     & 221,0.024D0,100,  3, 10,  2,  7,  0,
     & 221,0.012D0,100,  3,  8,  4,  7,  0,
     & 221,0.012D0,100,  1, 10,  4,  7,  0,
     & 221,0.069D0,100,  4,  8,  1,  7,  0,
     & 221,0.069D0,100,  4, 10,  3,  7,  0/
      DATA (IDK(I),BRFRAC(I),NME(I),(IDKPRD(J,I),J=1,5),I=1198,1216)/
     & 221,0.008D0,100,  2,  8,  1,  7,  0,
     & 221,0.008D0,100,  2, 10,  3,  7,  0,
     & 221,0.004D0,100,  4,  8,  3,  7,  0,
     & 221,0.004D0,100,  4, 10,  1,  7,  0,
     & 222,0.016D0,101,121,128,140,  0,  0,
     & 222,0.016D0,101,123,130,140,  0,  0,
     & 222,0.008D0,101,125,132,140,  0,  0,
     & 222,0.048D0,101,121,128,141,  0,  0,
     & 222,0.048D0,101,123,130,141,  0,  0,
     & 222,0.022D0,101,125,132,141,  0,  0,
     & 222,0.003D0,101,121,128,332,  0,  0,
     & 222,0.003D0,101,123,130,332,  0,  0,
     & 222,0.001D0,101,125,132,332,  0,  0,
     & 222,0.008D0,101,121,128,142,  0,  0,
     & 222,0.008D0,101,123,130,142,  0,  0,
     & 222,0.004D0,101,125,132,142,  0,  0,
     & 222,0.008D0,101,121,128,314,  0,  0,
     & 222,0.008D0,101,123,130,314,  0,  0,
     & 222,0.004D0,101,125,132,314,  0,  0/
      DATA (IDK(I),BRFRAC(I),NME(I),(IDKPRD(J,I),J=1,5),I=1217,1235)/
     & 222,0.013D0,101,121,128,143,  0,  0,
     & 222,0.013D0,101,123,130,143,  0,  0,
     & 222,0.006D0,101,125,132,143,  0,  0,
     & 222,0.004D0,  0,140, 30,  0,  0,  0,
     & 222,0.010D0,  0,140, 31,  0,  0,  0,
     & 222,0.006D0,  0,140, 32,  0,  0,  0,
     & 222,0.003D0,  0,141, 30,  0,  0,  0,
     & 222,0.009D0,  0,141, 31,  0,  0,  0,
     & 222,0.017D0,  0,141, 32,  0,  0,  0,
     & 222,0.011D0,  0,140,179,  0,  0,  0,
     & 222,0.015D0,  0,140,180,  0,  0,  0,
     & 222,0.011D0,  0,141,179,  0,  0,  0,
     & 222,0.022D0,  0,141,180,  0,  0,  0,
     & 222,0.001D0,  0,164, 34,  0,  0,  0,
     & 222,0.002D0,  0,164, 35,  0,  0,  0,
     & 222,0.001D0,  0,165, 34,  0,  0,  0,
     & 222,0.001D0,  0,165, 35,  0,  0,  0,
     & 222,0.001D0,  0,166, 34,  0,  0,  0,
     & 222,0.001D0,  0,166, 35,  0,  0,  0/
      DATA (IDK(I),BRFRAC(I),NME(I),(IDKPRD(J,I),J=1,5),I=1236,1254)/
     & 222,0.207D0,100,  1,  8,  4,  8,  0,
     & 222,0.207D0,100,  3, 10,  4,  8,  0,
     & 222,0.024D0,100,  1,  8,  2,  8,  0,
     & 222,0.024D0,100,  3, 10,  2,  8,  0,
     & 222,0.012D0,100,  3,  8,  4,  8,  0,
     & 222,0.012D0,100,  1, 10,  4,  8,  0,
     & 222,0.069D0,100,  4,  8,  1,  8,  0,
     & 222,0.069D0,100,  4, 10,  3,  8,  0,
     & 222,0.008D0,100,  2,  8,  1,  8,  0,
     & 222,0.008D0,100,  2, 10,  3,  8,  0,
     & 222,0.004D0,100,  4,  8,  3,  8,  0,
     & 222,0.004D0,100,  4, 10,  1,  8,  0,
     & 223,0.016D0,101,121,128,144,  0,  0,
     & 223,0.016D0,101,123,130,144,  0,  0,
     & 223,0.008D0,101,125,132,144,  0,  0,
     & 223,0.048D0,101,121,128,145,  0,  0,
     & 223,0.048D0,101,123,130,145,  0,  0,
     & 223,0.022D0,101,125,132,145,  0,  0,
     & 223,0.003D0,101,121,128,333,  0,  0/
      DATA (IDK(I),BRFRAC(I),NME(I),(IDKPRD(J,I),J=1,5),I=1255,1273)/
     & 223,0.003D0,101,123,130,333,  0,  0,
     & 223,0.001D0,101,125,132,333,  0,  0,
     & 223,0.008D0,101,121,128,146,  0,  0,
     & 223,0.008D0,101,123,130,146,  0,  0,
     & 223,0.004D0,101,125,132,146,  0,  0,
     & 223,0.008D0,101,121,128,315,  0,  0,
     & 223,0.008D0,101,123,130,315,  0,  0,
     & 223,0.004D0,101,125,132,315,  0,  0,
     & 223,0.013D0,101,121,128,147,  0,  0,
     & 223,0.013D0,101,123,130,147,  0,  0,
     & 223,0.006D0,101,125,132,147,  0,  0,
     & 223,0.004D0,  0,144, 30,  0,  0,  0,
     & 223,0.010D0,  0,144, 31,  0,  0,  0,
     & 223,0.006D0,  0,144, 32,  0,  0,  0,
     & 223,0.003D0,  0,145, 30,  0,  0,  0,
     & 223,0.009D0,  0,145, 31,  0,  0,  0,
     & 223,0.017D0,  0,145, 32,  0,  0,  0,
     & 223,0.011D0,  0,144,179,  0,  0,  0,
     & 223,0.015D0,  0,144,180,  0,  0,  0/
      DATA (IDK(I),BRFRAC(I),NME(I),(IDKPRD(J,I),J=1,5),I=1274,1292)/
     & 223,0.011D0,  0,145,179,  0,  0,  0,
     & 223,0.022D0,  0,145,180,  0,  0,  0,
     & 223,0.001D0,  0,164, 25,  0,  0,  0,
     & 223,0.002D0,  0,164, 56,  0,  0,  0,
     & 223,0.001D0,  0,165, 25,  0,  0,  0,
     & 223,0.001D0,  0,165, 56,  0,  0,  0,
     & 223,0.001D0,  0,166, 25,  0,  0,  0,
     & 223,0.001D0,  0,166, 56,  0,  0,  0,
     & 223,0.207D0,100,  1,  8,  4,  9,  0,
     & 223,0.207D0,100,  3, 10,  4,  9,  0,
     & 223,0.024D0,100,  1,  8,  2,  9,  0,
     & 223,0.024D0,100,  3, 10,  2,  9,  0,
     & 223,0.012D0,100,  3,  8,  4,  9,  0,
     & 223,0.012D0,100,  1, 10,  4,  9,  0,
     & 223,0.069D0,100,  4,  8,  1,  9,  0,
     & 223,0.069D0,100,  4, 10,  3,  9,  0,
     & 223,0.008D0,100,  2,  8,  1,  9,  0,
     & 223,0.008D0,100,  2, 10,  3,  9,  0,
     & 223,0.004D0,100,  4,  8,  3,  9,  0/
      DATA (IDK(I),BRFRAC(I),NME(I),(IDKPRD(J,I),J=1,5),I=1293,1311)/
     & 223,0.004D0,100,  4, 10,  1,  9,  0,
     & 224,0.090D0,100,121,128,  4,109,  0,
     & 224,0.090D0,100,123,130,  4,109,  0,
     & 224,0.045D0,100,125,132,  4,109,  0,
     & 224,0.010D0,100,121,128,  2,109,  0,
     & 224,0.010D0,100,123,130,  2,109,  0,
     & 224,0.005D0,100,125,132,  2,109,  0,
     & 224,0.242D0,100,  1,  8,  4,109,  0,
     & 224,0.242D0,100,  3, 10,  4,109,  0,
     & 224,0.027D0,100,  1,  8,  2,109,  0,
     & 224,0.027D0,100,  3, 10,  2,109,  0,
     & 224,0.012D0,100,  3,  8,  4,109,  0,
     & 224,0.012D0,100,  1, 10,  4,109,  0,
     & 224,0.081D0,100,  4,  8,  1,109,  0,
     & 224,0.081D0,100,  4, 10,  3,109,  0,
     & 224,0.009D0,100,  2,  8,  1,109,  0,
     & 224,0.009D0,100,  2, 10,  3,109,  0,
     & 224,0.004D0,100,  4,  8,  3,109,  0,
     & 224,0.004D0,100,  4, 10,  1,109,  0/
      DATA (IDK(I),BRFRAC(I),NME(I),(IDKPRD(J,I),J=1,5),I=1312,1330)/
     & 225,0.090D0,100,121,128,  4,110,  0,
     & 225,0.090D0,100,123,130,  4,110,  0,
     & 225,0.045D0,100,125,132,  4,110,  0,
     & 225,0.010D0,100,121,128,  2,110,  0,
     & 225,0.010D0,100,123,130,  2,110,  0,
     & 225,0.005D0,100,125,132,  2,110,  0,
     & 225,0.242D0,100,  1,  8,  4,110,  0,
     & 225,0.242D0,100,  3, 10,  4,110,  0,
     & 225,0.027D0,100,  1,  8,  2,110,  0,
     & 225,0.027D0,100,  3, 10,  2,110,  0,
     & 225,0.012D0,100,  3,  8,  4,110,  0,
     & 225,0.012D0,100,  1, 10,  4,110,  0,
     & 225,0.081D0,100,  4,  8,  1,110,  0,
     & 225,0.081D0,100,  4, 10,  3,110,  0,
     & 225,0.009D0,100,  2,  8,  1,110,  0,
     & 225,0.009D0,100,  2, 10,  3,110,  0,
     & 225,0.004D0,100,  4,  8,  3,110,  0,
     & 225,0.004D0,100,  4, 10,  1,110,  0,
     & 226,0.090D0,100,121,128,  4,111,  0/
      DATA (IDK(I),BRFRAC(I),NME(I),(IDKPRD(J,I),J=1,5),I=1331,1349)/
     & 226,0.090D0,100,123,130,  4,111,  0,
     & 226,0.045D0,100,125,132,  4,111,  0,
     & 226,0.010D0,100,121,128,  2,111,  0,
     & 226,0.010D0,100,123,130,  2,111,  0,
     & 226,0.005D0,100,125,132,  2,111,  0,
     & 226,0.242D0,100,  1,  8,  4,111,  0,
     & 226,0.242D0,100,  3, 10,  4,111,  0,
     & 226,0.027D0,100,  1,  8,  2,111,  0,
     & 226,0.027D0,100,  3, 10,  2,111,  0,
     & 226,0.012D0,100,  3,  8,  4,111,  0,
     & 226,0.012D0,100,  1, 10,  4,111,  0,
     & 226,0.081D0,100,  4,  8,  1,111,  0,
     & 226,0.081D0,100,  4, 10,  3,111,  0,
     & 226,0.009D0,100,  2,  8,  1,111,  0,
     & 226,0.009D0,100,  2, 10,  3,111,  0,
     & 226,0.004D0,100,  4,  8,  3,111,  0,
     & 226,0.004D0,100,  4, 10,  1,111,  0,
     & 227,0.090D0,100,121,128,  4,112,  0,
     & 227,0.090D0,100,123,130,  4,112,  0/
      DATA (IDK(I),BRFRAC(I),NME(I),(IDKPRD(J,I),J=1,5),I=1350,1368)/
     & 227,0.045D0,100,125,132,  4,112,  0,
     & 227,0.010D0,100,121,128,  2,112,  0,
     & 227,0.010D0,100,123,130,  2,112,  0,
     & 227,0.005D0,100,125,132,  2,112,  0,
     & 227,0.242D0,100,  1,  8,  4,112,  0,
     & 227,0.242D0,100,  3, 10,  4,112,  0,
     & 227,0.027D0,100,  1,  8,  2,112,  0,
     & 227,0.027D0,100,  3, 10,  2,112,  0,
     & 227,0.012D0,100,  3,  8,  4,112,  0,
     & 227,0.012D0,100,  1, 10,  4,112,  0,
     & 227,0.081D0,100,  4,  8,  1,112,  0,
     & 227,0.081D0,100,  4, 10,  3,112,  0,
     & 227,0.009D0,100,  2,  8,  1,112,  0,
     & 227,0.009D0,100,  2, 10,  3,112,  0,
     & 227,0.004D0,100,  4,  8,  3,112,  0,
     & 227,0.004D0,100,  4, 10,  1,112,  0,
     & 228,0.090D0,100,121,128,  4,113,  0,
     & 228,0.090D0,100,123,130,  4,113,  0,
     & 228,0.045D0,100,125,132,  4,113,  0/
      DATA (IDK(I),BRFRAC(I),NME(I),(IDKPRD(J,I),J=1,5),I=1369,1387)/
     & 228,0.010D0,100,121,128,  2,113,  0,
     & 228,0.010D0,100,123,130,  2,113,  0,
     & 228,0.005D0,100,125,132,  2,113,  0,
     & 228,0.242D0,100,  1,  8,  4,113,  0,
     & 228,0.242D0,100,  3, 10,  4,113,  0,
     & 228,0.027D0,100,  1,  8,  2,113,  0,
     & 228,0.027D0,100,  3, 10,  2,113,  0,
     & 228,0.012D0,100,  3,  8,  4,113,  0,
     & 228,0.012D0,100,  1, 10,  4,113,  0,
     & 228,0.081D0,100,  4,  8,  1,113,  0,
     & 228,0.081D0,100,  4, 10,  3,113,  0,
     & 228,0.009D0,100,  2,  8,  1,113,  0,
     & 228,0.009D0,100,  2, 10,  3,113,  0,
     & 228,0.004D0,100,  4,  8,  3,113,  0,
     & 228,0.004D0,100,  4, 10,  1,113,  0,
     & 229,0.090D0,100,121,128,  4,114,  0,
     & 229,0.090D0,100,123,130,  4,114,  0,
     & 229,0.045D0,100,125,132,  4,114,  0,
     & 229,0.010D0,100,121,128,  2,114,  0/
      DATA (IDK(I),BRFRAC(I),NME(I),(IDKPRD(J,I),J=1,5),I=1388,1406)/
     & 229,0.010D0,100,123,130,  2,114,  0,
     & 229,0.005D0,100,125,132,  2,114,  0,
     & 229,0.242D0,100,  1,  8,  4,114,  0,
     & 229,0.242D0,100,  3, 10,  4,114,  0,
     & 229,0.027D0,100,  1,  8,  2,114,  0,
     & 229,0.027D0,100,  3, 10,  2,114,  0,
     & 229,0.012D0,100,  3,  8,  4,114,  0,
     & 229,0.012D0,100,  1, 10,  4,114,  0,
     & 229,0.081D0,100,  4,  8,  1,114,  0,
     & 229,0.081D0,100,  4, 10,  3,114,  0,
     & 229,0.009D0,100,  2,  8,  1,114,  0,
     & 229,0.009D0,100,  2, 10,  3,114,  0,
     & 229,0.004D0,100,  4,  8,  3,114,  0,
     & 229,0.004D0,100,  4, 10,  1,114,  0,
     & 230,0.080D0,100,121,128,  4, 10,  0,
     & 230,0.080D0,100,123,130,  4, 10,  0,
     & 230,0.040D0,100,125,132,  4, 10,  0,
     & 230,0.080D0,100,121,128,  9,  5,  0,
     & 230,0.080D0,100,123,130,  9,  5,  0/
      DATA (IDK(I),BRFRAC(I),NME(I),(IDKPRD(J,I),J=1,5),I=1407,1425)/
     & 230,0.228D0,100,  1,  8,  4, 10,  0,
     & 230,0.228D0,100,  3, 10,  4, 10,  0,
     & 230,0.012D0,100,  3,  8,  4, 10,  0,
     & 230,0.012D0,100,  1, 10,  4, 10,  0,
     & 230,0.076D0,100,  4,  8,  1, 10,  0,
     & 230,0.076D0,100,  4, 10,  3, 10,  0,
     & 230,0.004D0,100,  4,  8,  3, 10,  0,
     & 230,0.004D0,100,  4, 10,  1, 10,  0,
     & 231,0.025D0,  0,121,127,  0,  0,  0,
     & 231,0.025D0,  0,123,129,  0,  0,  0,
     & 231,0.025D0,  0,125,131,  0,  0,  0,
     & 231,0.008D0,  0,  1,  7,  0,  0,  0,
     & 231,0.033D0,  0,  2,  8,  0,  0,  0,
     & 231,0.008D0,  0,  3,  9,  0,  0,  0,
     & 231,0.033D0,  0,  4, 10,  0,  0,  0,
     & 231,0.801D0,130, 13, 13, 13,  0,  0,
     & 231,0.042D0,130, 13, 13, 59,  0,  0,
     & 245,0.016D0,101,127,122,171,  0,  0,
     & 245,0.016D0,101,129,124,171,  0,  0/
      DATA (IDK(I),BRFRAC(I),NME(I),(IDKPRD(J,I),J=1,5),I=1426,1444)/
     & 245,0.008D0,101,131,126,171,  0,  0,
     & 245,0.048D0,101,127,122,172,  0,  0,
     & 245,0.048D0,101,129,124,172,  0,  0,
     & 245,0.022D0,101,131,126,172,  0,  0,
     & 245,0.003D0,101,127,122,334,  0,  0,
     & 245,0.003D0,101,129,124,334,  0,  0,
     & 245,0.001D0,101,131,126,334,  0,  0,
     & 245,0.008D0,101,127,122,173,  0,  0,
     & 245,0.008D0,101,129,124,173,  0,  0,
     & 245,0.004D0,101,131,126,173,  0,  0,
     & 245,0.008D0,101,127,122,316,  0,  0,
     & 245,0.008D0,101,129,124,316,  0,  0,
     & 245,0.004D0,101,131,126,316,  0,  0,
     & 245,0.013D0,101,127,122,174,  0,  0,
     & 245,0.013D0,101,129,124,174,  0,  0,
     & 245,0.006D0,101,131,126,174,  0,  0,
     & 245,0.004D0,  0,171, 38,  0,  0,  0,
     & 245,0.010D0,  0,171, 39,  0,  0,  0,
     & 245,0.006D0,  0,171, 40,  0,  0,  0/
      DATA (IDK(I),BRFRAC(I),NME(I),(IDKPRD(J,I),J=1,5),I=1445,1463)/
     & 245,0.003D0,  0,172, 38,  0,  0,  0,
     & 245,0.009D0,  0,172, 39,  0,  0,  0,
     & 245,0.017D0,  0,172, 40,  0,  0,  0,
     & 245,0.011D0,  0,171,144,  0,  0,  0,
     & 245,0.015D0,  0,171,145,  0,  0,  0,
     & 245,0.011D0,  0,172,144,  0,  0,  0,
     & 245,0.022D0,  0,172,145,  0,  0,  0,
     & 245,0.001D0,  0,164, 50,  0,  0,  0,
     & 245,0.002D0,  0,164, 51,  0,  0,  0,
     & 245,0.001D0,  0,165, 50,  0,  0,  0,
     & 245,0.001D0,  0,165, 51,  0,  0,  0,
     & 245,0.001D0,  0,166, 50,  0,  0,  0,
     & 245,0.001D0,  0,166, 51,  0,  0,  0,
     & 245,0.207D0,100,  7,  2, 10,  1,  0,
     & 245,0.207D0,100,  9,  4, 10,  1,  0,
     & 245,0.024D0,100,  7,  2,  8,  1,  0,
     & 245,0.024D0,100,  9,  4,  8,  1,  0,
     & 245,0.012D0,100,  9,  2, 10,  1,  0,
     & 245,0.012D0,100,  7,  4, 10,  1,  0/
      DATA (IDK(I),BRFRAC(I),NME(I),(IDKPRD(J,I),J=1,5),I=1464,1482)/
     & 245,0.069D0,100, 10,  2,  7,  1,  0,
     & 245,0.069D0,100, 10,  4,  9,  1,  0,
     & 245,0.008D0,100,  8,  2,  7,  1,  0,
     & 245,0.008D0,100,  8,  4,  9,  1,  0,
     & 245,0.004D0,100, 10,  2,  9,  1,  0,
     & 245,0.004D0,100, 10,  4,  7,  1,  0,
     & 246,0.016D0,101,127,122,175,  0,  0,
     & 246,0.016D0,101,129,124,175,  0,  0,
     & 246,0.008D0,101,131,126,175,  0,  0,
     & 246,0.048D0,101,127,122,176,  0,  0,
     & 246,0.048D0,101,129,124,176,  0,  0,
     & 246,0.022D0,101,131,126,176,  0,  0,
     & 246,0.003D0,101,127,122,335,  0,  0,
     & 246,0.003D0,101,129,124,335,  0,  0,
     & 246,0.001D0,101,131,126,335,  0,  0,
     & 246,0.008D0,101,127,122,177,  0,  0,
     & 246,0.008D0,101,129,124,177,  0,  0,
     & 246,0.004D0,101,131,126,177,  0,  0,
     & 246,0.008D0,101,127,122,317,  0,  0/
      DATA (IDK(I),BRFRAC(I),NME(I),(IDKPRD(J,I),J=1,5),I=1483,1501)/
     & 246,0.008D0,101,129,124,317,  0,  0,
     & 246,0.004D0,101,131,126,317,  0,  0,
     & 246,0.013D0,101,127,122,178,  0,  0,
     & 246,0.013D0,101,129,124,178,  0,  0,
     & 246,0.006D0,101,131,126,178,  0,  0,
     & 246,0.004D0,  0,175, 38,  0,  0,  0,
     & 246,0.010D0,  0,175, 39,  0,  0,  0,
     & 246,0.006D0,  0,175, 40,  0,  0,  0,
     & 246,0.003D0,  0,176, 38,  0,  0,  0,
     & 246,0.009D0,  0,176, 39,  0,  0,  0,
     & 246,0.017D0,  0,176, 40,  0,  0,  0,
     & 246,0.011D0,  0,175,144,  0,  0,  0,
     & 246,0.015D0,  0,175,145,  0,  0,  0,
     & 246,0.011D0,  0,176,144,  0,  0,  0,
     & 246,0.022D0,  0,176,145,  0,  0,  0,
     & 246,0.001D0,  0,164, 46,  0,  0,  0,
     & 246,0.002D0,  0,164, 47,  0,  0,  0,
     & 246,0.001D0,  0,165, 46,  0,  0,  0,
     & 246,0.001D0,  0,165, 47,  0,  0,  0/
      DATA (IDK(I),BRFRAC(I),NME(I),(IDKPRD(J,I),J=1,5),I=1502,1520)/
     & 246,0.001D0,  0,166, 46,  0,  0,  0,
     & 246,0.001D0,  0,166, 47,  0,  0,  0,
     & 246,0.207D0,100,  7,  2, 10,  2,  0,
     & 246,0.207D0,100,  9,  4, 10,  2,  0,
     & 246,0.024D0,100,  7,  2,  8,  2,  0,
     & 246,0.024D0,100,  9,  4,  8,  2,  0,
     & 246,0.012D0,100,  9,  2, 10,  2,  0,
     & 246,0.012D0,100,  7,  4, 10,  2,  0,
     & 246,0.069D0,100, 10,  2,  7,  2,  0,
     & 246,0.069D0,100, 10,  4,  9,  2,  0,
     & 246,0.008D0,100,  8,  2,  7,  2,  0,
     & 246,0.008D0,100,  8,  4,  9,  2,  0,
     & 246,0.004D0,100, 10,  2,  9,  2,  0,
     & 246,0.004D0,100, 10,  4,  7,  2,  0,
     & 247,0.016D0,101,127,122,179,  0,  0,
     & 247,0.016D0,101,129,124,179,  0,  0,
     & 247,0.008D0,101,131,126,179,  0,  0,
     & 247,0.048D0,101,127,122,180,  0,  0,
     & 247,0.048D0,101,129,124,180,  0,  0/
      DATA (IDK(I),BRFRAC(I),NME(I),(IDKPRD(J,I),J=1,5),I=1521,1539)/
     & 247,0.022D0,101,131,126,180,  0,  0,
     & 247,0.003D0,101,127,122,336,  0,  0,
     & 247,0.003D0,101,129,124,336,  0,  0,
     & 247,0.001D0,101,131,126,336,  0,  0,
     & 247,0.008D0,101,127,122,181,  0,  0,
     & 247,0.008D0,101,129,124,181,  0,  0,
     & 247,0.004D0,101,131,126,181,  0,  0,
     & 247,0.008D0,101,127,122,318,  0,  0,
     & 247,0.008D0,101,129,124,318,  0,  0,
     & 247,0.004D0,101,131,126,318,  0,  0,
     & 247,0.013D0,101,127,122,182,  0,  0,
     & 247,0.013D0,101,129,124,182,  0,  0,
     & 247,0.006D0,101,131,126,182,  0,  0,
     & 247,0.004D0,  0,179, 38,  0,  0,  0,
     & 247,0.010D0,  0,179, 39,  0,  0,  0,
     & 247,0.006D0,  0,179, 40,  0,  0,  0,
     & 247,0.003D0,  0,180, 38,  0,  0,  0,
     & 247,0.009D0,  0,180, 39,  0,  0,  0,
     & 247,0.017D0,  0,180, 40,  0,  0,  0/
      DATA (IDK(I),BRFRAC(I),NME(I),(IDKPRD(J,I),J=1,5),I=1540,1558)/
     & 247,0.011D0,  0,179,144,  0,  0,  0,
     & 247,0.015D0,  0,179,145,  0,  0,  0,
     & 247,0.011D0,  0,180,144,  0,  0,  0,
     & 247,0.022D0,  0,180,145,  0,  0,  0,
     & 247,0.001D0,  0,164, 25,  0,  0,  0,
     & 247,0.002D0,  0,164, 56,  0,  0,  0,
     & 247,0.001D0,  0,165, 25,  0,  0,  0,
     & 247,0.001D0,  0,165, 56,  0,  0,  0,
     & 247,0.001D0,  0,166, 25,  0,  0,  0,
     & 247,0.001D0,  0,166, 56,  0,  0,  0,
     & 247,0.207D0,100,  7,  2, 10,  3,  0,
     & 247,0.207D0,100,  9,  4, 10,  3,  0,
     & 247,0.024D0,100,  7,  2,  8,  3,  0,
     & 247,0.024D0,100,  9,  4,  8,  3,  0,
     & 247,0.012D0,100,  9,  2, 10,  3,  0,
     & 247,0.012D0,100,  7,  4, 10,  3,  0,
     & 247,0.069D0,100, 10,  2,  7,  3,  0,
     & 247,0.069D0,100, 10,  4,  9,  3,  0,
     & 247,0.008D0,100,  8,  2,  7,  3,  0/
      DATA (IDK(I),BRFRAC(I),NME(I),(IDKPRD(J,I),J=1,5),I=1559,1577)/
     & 247,0.008D0,100,  8,  4,  9,  3,  0,
     & 247,0.004D0,100, 10,  2,  9,  3,  0,
     & 247,0.004D0,100, 10,  4,  7,  3,  0,
     & 248,0.090D0,100,127,122, 10,115,  0,
     & 248,0.090D0,100,129,124, 10,115,  0,
     & 248,0.045D0,100,131,126, 10,115,  0,
     & 248,0.010D0,100,127,122,  8,115,  0,
     & 248,0.010D0,100,129,124,  8,115,  0,
     & 248,0.005D0,100,131,126,  8,115,  0,
     & 248,0.242D0,100,  7,  2, 10,115,  0,
     & 248,0.242D0,100,  9,  4, 10,115,  0,
     & 248,0.027D0,100,  7,  2,  8,115,  0,
     & 248,0.027D0,100,  9,  4,  8,115,  0,
     & 248,0.012D0,100,  9,  2, 10,115,  0,
     & 248,0.012D0,100,  7,  4, 10,115,  0,
     & 248,0.081D0,100, 10,  2,  7,115,  0,
     & 248,0.081D0,100, 10,  4,  9,115,  0,
     & 248,0.009D0,100,  8,  2,  7,115,  0,
     & 248,0.009D0,100,  8,  4,  9,115,  0/
      DATA (IDK(I),BRFRAC(I),NME(I),(IDKPRD(J,I),J=1,5),I=1578,1596)/
     & 248,0.004D0,100, 10,  2,  9,115,  0,
     & 248,0.004D0,100, 10,  4,  7,115,  0,
     & 249,0.090D0,100,127,122, 10,116,  0,
     & 249,0.090D0,100,129,124, 10,116,  0,
     & 249,0.045D0,100,131,126, 10,116,  0,
     & 249,0.010D0,100,127,122,  8,116,  0,
     & 249,0.010D0,100,129,124,  8,116,  0,
     & 249,0.005D0,100,131,126,  8,116,  0,
     & 249,0.242D0,100,  7,  2, 10,116,  0,
     & 249,0.242D0,100,  9,  4, 10,116,  0,
     & 249,0.027D0,100,  7,  2,  8,116,  0,
     & 249,0.027D0,100,  9,  4,  8,116,  0,
     & 249,0.012D0,100,  9,  2, 10,116,  0,
     & 249,0.012D0,100,  7,  4, 10,116,  0,
     & 249,0.081D0,100, 10,  2,  7,116,  0,
     & 249,0.081D0,100, 10,  4,  9,116,  0,
     & 249,0.009D0,100,  8,  2,  7,116,  0,
     & 249,0.009D0,100,  8,  4,  9,116,  0,
     & 249,0.004D0,100, 10,  2,  9,116,  0/
      DATA (IDK(I),BRFRAC(I),NME(I),(IDKPRD(J,I),J=1,5),I=1597,1615)/
     & 249,0.004D0,100, 10,  4,  7,116,  0,
     & 250,0.090D0,100,127,122, 10,117,  0,
     & 250,0.090D0,100,129,124, 10,117,  0,
     & 250,0.045D0,100,131,126, 10,117,  0,
     & 250,0.010D0,100,127,122,  8,117,  0,
     & 250,0.010D0,100,129,124,  8,117,  0,
     & 250,0.005D0,100,131,126,  8,117,  0,
     & 250,0.242D0,100,  7,  2, 10,117,  0,
     & 250,0.242D0,100,  9,  4, 10,117,  0,
     & 250,0.027D0,100,  7,  2,  8,117,  0,
     & 250,0.027D0,100,  9,  4,  8,117,  0,
     & 250,0.012D0,100,  9,  2, 10,117,  0,
     & 250,0.012D0,100,  7,  4, 10,117,  0,
     & 250,0.081D0,100, 10,  2,  7,117,  0,
     & 250,0.081D0,100, 10,  4,  9,117,  0,
     & 250,0.009D0,100,  8,  2,  7,117,  0,
     & 250,0.009D0,100,  8,  4,  9,117,  0,
     & 250,0.004D0,100, 10,  2,  9,117,  0,
     & 250,0.004D0,100, 10,  4,  7,117,  0/
      DATA (IDK(I),BRFRAC(I),NME(I),(IDKPRD(J,I),J=1,5),I=1616,1634)/
     & 251,0.090D0,100,127,122, 10,118,  0,
     & 251,0.090D0,100,129,124, 10,118,  0,
     & 251,0.045D0,100,131,126, 10,118,  0,
     & 251,0.010D0,100,127,122,  8,118,  0,
     & 251,0.010D0,100,129,124,  8,118,  0,
     & 251,0.005D0,100,131,126,  8,118,  0,
     & 251,0.242D0,100,  7,  2, 10,118,  0,
     & 251,0.242D0,100,  9,  4, 10,118,  0,
     & 251,0.027D0,100,  7,  2,  8,118,  0,
     & 251,0.027D0,100,  9,  4,  8,118,  0,
     & 251,0.012D0,100,  9,  2, 10,118,  0,
     & 251,0.012D0,100,  7,  4, 10,118,  0,
     & 251,0.081D0,100, 10,  2,  7,118,  0,
     & 251,0.081D0,100, 10,  4,  9,118,  0,
     & 251,0.009D0,100,  8,  2,  7,118,  0,
     & 251,0.009D0,100,  8,  4,  9,118,  0,
     & 251,0.004D0,100, 10,  2,  9,118,  0,
     & 251,0.004D0,100, 10,  4,  7,118,  0,
     & 252,0.090D0,100,127,122, 10,119,  0/
      DATA (IDK(I),BRFRAC(I),NME(I),(IDKPRD(J,I),J=1,5),I=1635,1653)/
     & 252,0.090D0,100,129,124, 10,119,  0,
     & 252,0.045D0,100,131,126, 10,119,  0,
     & 252,0.010D0,100,127,122,  8,119,  0,
     & 252,0.010D0,100,129,124,  8,119,  0,
     & 252,0.005D0,100,131,126,  8,119,  0,
     & 252,0.242D0,100,  7,  2, 10,119,  0,
     & 252,0.242D0,100,  9,  4, 10,119,  0,
     & 252,0.027D0,100,  7,  2,  8,119,  0,
     & 252,0.027D0,100,  9,  4,  8,119,  0,
     & 252,0.012D0,100,  9,  2, 10,119,  0,
     & 252,0.012D0,100,  7,  4, 10,119,  0,
     & 252,0.081D0,100, 10,  2,  7,119,  0,
     & 252,0.081D0,100, 10,  4,  9,119,  0,
     & 252,0.009D0,100,  8,  2,  7,119,  0,
     & 252,0.009D0,100,  8,  4,  9,119,  0,
     & 252,0.004D0,100, 10,  2,  9,119,  0,
     & 252,0.004D0,100, 10,  4,  7,119,  0,
     & 253,0.090D0,100,127,122, 10,120,  0,
     & 253,0.090D0,100,129,124, 10,120,  0/
      DATA (IDK(I),BRFRAC(I),NME(I),(IDKPRD(J,I),J=1,5),I=1654,1672)/
     & 253,0.045D0,100,131,126, 10,120,  0,
     & 253,0.010D0,100,127,122,  8,120,  0,
     & 253,0.010D0,100,129,124,  8,120,  0,
     & 253,0.005D0,100,131,126,  8,120,  0,
     & 253,0.242D0,100,  7,  2, 10,120,  0,
     & 253,0.242D0,100,  9,  4, 10,120,  0,
     & 253,0.027D0,100,  7,  2,  8,120,  0,
     & 253,0.027D0,100,  9,  4,  8,120,  0,
     & 253,0.012D0,100,  9,  2, 10,120,  0,
     & 253,0.012D0,100,  7,  4, 10,120,  0,
     & 253,0.081D0,100, 10,  2,  7,120,  0,
     & 253,0.081D0,100, 10,  4,  9,120,  0,
     & 253,0.009D0,100,  8,  2,  7,120,  0,
     & 253,0.009D0,100,  8,  4,  9,120,  0,
     & 253,0.004D0,100, 10,  2,  9,120,  0,
     & 253,0.004D0,100, 10,  4,  7,120,  0,
     & 254,0.080D0,100,127,122, 10,  4,  0,
     & 254,0.080D0,100,129,124, 10,  4,  0,
     & 254,0.040D0,100,131,126, 10,  4,  0/
      DATA (IDK(I),BRFRAC(I),NME(I),(IDKPRD(J,I),J=1,5),I=1673,1691)/
     & 254,0.080D0,100,127,122,  3, 11,  0,
     & 254,0.080D0,100,129,124,  3, 11,  0,
     & 254,0.228D0,100,  7,  2, 10,  4,  0,
     & 254,0.228D0,100,  9,  4, 10,  4,  0,
     & 254,0.012D0,100,  9,  2, 10,  4,  0,
     & 254,0.012D0,100,  7,  4, 10,  4,  0,
     & 254,0.076D0,100, 10,  2,  7,  4,  0,
     & 254,0.076D0,100, 10,  4,  9,  4,  0,
     & 254,0.004D0,100, 10,  2,  9,  4,  0,
     & 254,0.004D0,100, 10,  4,  7,  4,  0,
     & 265,1.000D0,  0,221, 59,  0,  0,  0,
     & 266,1.000D0,  0,222, 59,  0,  0,  0,
     & 267,1.000D0,  0,223, 59,  0,  0,  0,
     & 268,0.667D0,  0,266, 38,  0,  0,  0,
     & 268,0.333D0,  0,265, 21,  0,  0,  0,
     & 269,0.667D0,  0,265, 30,  0,  0,  0,
     & 269,0.333D0,  0,266, 21,  0,  0,  0,
     & 270,0.500D0,  0,265, 50,  0,  0,  0,
     & 270,0.500D0,  0,266, 46,  0,  0,  0/
      DATA (IDK(I),BRFRAC(I),NME(I),(IDKPRD(J,I),J=1,5),I=1692,1710)/
     & 271,0.290D0,  0,266, 38,  0,  0,  0,
     & 271,0.150D0,  0,265, 21,  0,  0,  0,
     & 271,0.290D0,  0,222, 38,  0,  0,  0,
     & 271,0.150D0,  0,221, 21,  0,  0,  0,
     & 271,0.060D0,  0,266, 38, 21,  0,  0,
     & 271,0.020D0,  0,265, 38, 30,  0,  0,
     & 271,0.010D0,  0,265, 21, 21,  0,  0,
     & 271,0.020D0,  0,222, 38, 21,  0,  0,
     & 271,0.010D0,  0,221, 38, 30,  0,  0,
     & 272,0.290D0,  0,265, 30,  0,  0,  0,
     & 272,0.150D0,  0,266, 21,  0,  0,  0,
     & 272,0.290D0,  0,221, 30,  0,  0,  0,
     & 272,0.150D0,  0,222, 21,  0,  0,  0,
     & 272,0.060D0,  0,265, 30, 21,  0,  0,
     & 272,0.020D0,  0,266, 38, 30,  0,  0,
     & 272,0.010D0,  0,266, 21, 21,  0,  0,
     & 272,0.020D0,  0,221, 30, 21,  0,  0,
     & 272,0.010D0,  0,222, 38, 30,  0,  0,
     & 273,0.350D0,  0,221, 50,  0,  0,  0/
      DATA (IDK(I),BRFRAC(I),NME(I),(IDKPRD(J,I),J=1,5),I=1711,1729)/
     & 273,0.350D0,  0,222, 46,  0,  0,  0,
     & 273,0.150D0,  0,265, 50,  0,  0,  0,
     & 273,0.150D0,  0,266, 46,  0,  0,  0,
     & 274,1.000D0,  0,245, 59,  0,  0,  0,
     & 275,1.000D0,  0,246, 59,  0,  0,  0,
     & 276,1.000D0,  0,247, 59,  0,  0,  0,
     & 277,0.667D0,  0,275, 30,  0,  0,  0,
     & 277,0.333D0,  0,274, 21,  0,  0,  0,
     & 278,0.667D0,  0,274, 38,  0,  0,  0,
     & 278,0.333D0,  0,275, 21,  0,  0,  0,
     & 279,0.500D0,  0,274, 42,  0,  0,  0,
     & 279,0.500D0,  0,275, 34,  0,  0,  0,
     & 280,0.290D0,  0,275, 30,  0,  0,  0,
     & 280,0.150D0,  0,274, 21,  0,  0,  0,
     & 280,0.290D0,  0,246, 30,  0,  0,  0,
     & 280,0.150D0,  0,245, 21,  0,  0,  0,
     & 280,0.060D0,  0,275, 30, 21,  0,  0,
     & 280,0.020D0,  0,274, 38, 30,  0,  0,
     & 280,0.010D0,  0,274, 21, 21,  0,  0/
      DATA (IDK(I),BRFRAC(I),NME(I),(IDKPRD(J,I),J=1,5),I=1730,1748)/
     & 280,0.020D0,  0,246, 30, 21,  0,  0,
     & 280,0.010D0,  0,245, 38, 30,  0,  0,
     & 281,0.290D0,  0,274, 38,  0,  0,  0,
     & 281,0.150D0,  0,275, 21,  0,  0,  0,
     & 281,0.290D0,  0,245, 38,  0,  0,  0,
     & 281,0.150D0,  0,246, 21,  0,  0,  0,
     & 281,0.060D0,  0,274, 38, 21,  0,  0,
     & 281,0.020D0,  0,275, 38, 30,  0,  0,
     & 281,0.010D0,  0,275, 21, 21,  0,  0,
     & 281,0.020D0,  0,245, 38, 21,  0,  0,
     & 281,0.010D0,  0,246, 38, 30,  0,  0,
     & 282,0.350D0,  0,245, 42,  0,  0,  0,
     & 282,0.350D0,  0,246, 34,  0,  0,  0,
     & 282,0.150D0,  0,274, 42,  0,  0,  0,
     & 282,0.150D0,  0,275, 34,  0,  0,  0,
     & 285,1.000D0,  0, 24, 21,  0,  0,  0,
     & 286,0.998D0,  0, 24, 38,  0,  0,  0,
     & 286,0.002D0,  0, 38, 59,  0,  0,  0,
     & 287,0.998D0,  0, 24, 30,  0,  0,  0/
      DATA (IDK(I),BRFRAC(I),NME(I),(IDKPRD(J,I),J=1,5),I=1749,1767)/
     & 287,0.002D0,  0, 30, 59,  0,  0,  0,
     & 288,0.330D0,  0, 39, 30,  0,  0,  0,
     & 288,0.340D0,  0, 23, 21,  0,  0,  0,
     & 288,0.330D0,  0, 31, 38,  0,  0,  0,
     & 289,0.250D0,  0, 46, 35,  0,  0,  0,
     & 289,0.250D0,  0, 34, 47,  0,  0,  0,
     & 289,0.250D0,  0, 50, 43,  0,  0,  0,
     & 289,0.250D0,  0, 42, 51,  0,  0,  0,
     & 290,0.996D0,  0, 22, 21,  0,  0,  0,
     & 290,0.002D0,  0, 46, 34,  0,  0,  0,
     & 290,0.002D0,  0, 50, 42,  0,  0,  0,
     & 291,0.996D0,  0, 22, 38,  0,  0,  0,
     & 291,0.004D0,  0, 46, 42,  0,  0,  0,
     & 292,0.996D0,  0, 22, 30,  0,  0,  0,
     & 292,0.004D0,  0, 50, 34,  0,  0,  0,
     & 293,0.520D0,  0, 38, 30,  0,  0,  0,
     & 293,0.260D0,  0, 21, 21,  0,  0,  0,
     & 293,0.110D0,  0, 46, 34,  0,  0,  0,
     & 293,0.110D0,  0, 50, 42,  0,  0,  0/
      DATA (IDK(I),BRFRAC(I),NME(I),(IDKPRD(J,I),J=1,5),I=1768,1786)/
     & 294,0.620D0,  0, 38, 30,  0,  0,  0,
     & 294,0.310D0,  0, 21, 21,  0,  0,  0,
     & 294,0.035D0,  0, 46, 34,  0,  0,  0,
     & 294,0.035D0,  0, 50, 42,  0,  0,  0,
     & 295,1.000D0,  0,254, 59,  0,  0,  0,
     & 296,1.000D0,  0,230, 59,  0,  0,  0,
     & 297,1.000D0,  0,254, 59,  0,  0,  0,
     & 298,1.000D0,  0,230, 59,  0,  0,  0,
     & 299,1.000D0,  0,254, 59,  0,  0,  0,
     & 300,1.000D0,  0,230, 59,  0,  0,  0,
     & 301,0.050D0,  0,121,127,  0,  0,  0,
     & 301,0.050D0,  0,123,129,  0,  0,  0,
     & 301,0.017D0,  0,  1,  7,  0,  0,  0,
     & 301,0.066D0,  0,  2,  8,  0,  0,  0,
     & 301,0.017D0,  0,  3,  9,  0,  0,  0,
     & 301,0.640D0,130, 13, 13, 13,  0,  0,
     & 301,0.160D0,130, 13, 13, 59,  0,  0,
     & 302,0.022D0,  0, 38, 30, 38, 30, 23,
     & 302,0.016D0,  0, 38, 30, 38, 30,  0/
      DATA (IDK(I),BRFRAC(I),NME(I),(IDKPRD(J,I),J=1,5),I=1787,1805)/
     & 302,0.009D0,  0, 38, 30, 46, 34,  0,
     & 302,0.004D0,  0, 23, 38, 30,  0,  0,
     & 302,0.002D0,  0, 46, 43, 30,  0,  0,
     & 302,0.002D0,  0, 34, 51, 38,  0,  0,
     & 302,0.001D0,  0, 38, 30, 73, 91,  0,
     & 302,0.273D0,  0, 59,164,  0,  0,  0,
     & 302,0.671D0,  0, 13, 13,  0,  0,  0,
     & 303,0.022D0,  0, 38, 30, 38, 30,  0,
     & 303,0.019D0,  0, 38, 30, 46, 34,  0,
     & 303,0.012D0,  0, 38, 30, 38, 30, 23,
     & 303,0.007D0,  0, 23, 38, 30,  0,  0,
     & 303,0.002D0,  0, 46, 43, 30,  0,  0,
     & 303,0.002D0,  0, 34, 51, 38,  0,  0,
     & 303,0.003D0,  0, 38, 30, 73, 91,  0,
     & 303,0.002D0,  0, 38, 30,  0,  0,  0,
     & 303,0.002D0,  0, 46, 34,  0,  0,  0,
     & 303,0.001D0,  0, 21, 21,  0,  0,  0,
     & 303,0.135D0,  0, 59,164,  0,  0,  0,
     & 303,0.793D0,  0, 13, 13,  0,  0,  0/
      DATA (IDK(I),BRFRAC(I),NME(I),(IDKPRD(J,I),J=1,5),I=1806,1824)/
     & 304,1.000D0,  0, 13, 13,  0,  0,  0,
     & 305,1.000D0,  0, 13, 13,  0,  0,  0,
     & 306,0.050D0,  0, 59,231,  0,  0,  0,
     & 306,0.950D0,  0, 13, 13,  0,  0,  0,
     & 307,0.350D0,  0, 59,231,  0,  0,  0,
     & 307,0.650D0,  0, 13, 13,  0,  0,  0,
     & 308,0.220D0,  0, 59,231,  0,  0,  0,
     & 308,0.780D0,  0, 13, 13,  0,  0,  0,
     & 309,0.280D0,  0, 46, 31,  0,  0,  0,
     & 309,0.140D0,  0, 50, 23,  0,  0,  0,
     & 309,0.187D0,  0,327, 30,  0,  0,  0,
     & 309,0.093D0,  0,328, 21,  0,  0,  0,
     & 309,0.110D0,  0, 50, 24,  0,  0,  0,
     & 309,0.107D0,  0, 47, 30,  0,  0,  0,
     & 309,0.053D0,  0, 51, 21,  0,  0,  0,
     & 309,0.030D0,  0, 50,293,  0,  0,  0,
     & 310,0.280D0,  0, 50, 39,  0,  0,  0,
     & 310,0.140D0,  0, 46, 23,  0,  0,  0,
     & 310,0.187D0,  0,328, 38,  0,  0,  0/
      DATA (IDK(I),BRFRAC(I),NME(I),(IDKPRD(J,I),J=1,5),I=1825,1843)/
     & 310,0.093D0,  0,327, 21,  0,  0,  0,
     & 310,0.110D0,  0, 46, 24,  0,  0,  0,
     & 310,0.107D0,  0, 51, 38,  0,  0,  0,
     & 310,0.053D0,  0, 47, 21,  0,  0,  0,
     & 310,0.030D0,  0, 46,293,  0,  0,  0,
     & 311,0.280D0,  0, 34, 39,  0,  0,  0,
     & 311,0.140D0,  0, 42, 23,  0,  0,  0,
     & 311,0.187D0,  0,330, 38,  0,  0,  0,
     & 311,0.093D0,  0,329, 21,  0,  0,  0,
     & 311,0.110D0,  0, 42, 24,  0,  0,  0,
     & 311,0.107D0,  0, 35, 38,  0,  0,  0,
     & 311,0.053D0,  0, 43, 21,  0,  0,  0,
     & 311,0.030D0,  0, 42,293,  0,  0,  0,
     & 312,0.280D0,  0, 42, 31,  0,  0,  0,
     & 312,0.140D0,  0, 34, 23,  0,  0,  0,
     & 312,0.187D0,  0,329, 30,  0,  0,  0,
     & 312,0.093D0,  0,330, 21,  0,  0,  0,
     & 312,0.110D0,  0, 34, 24,  0,  0,  0,
     & 312,0.107D0,  0, 43, 30,  0,  0,  0/
      DATA (IDK(I),BRFRAC(I),NME(I),(IDKPRD(J,I),J=1,5),I=1844,1862)/
     & 312,0.053D0,  0, 35, 21,  0,  0,  0,
     & 312,0.030D0,  0, 34,293,  0,  0,  0,
     & 313,0.430D0,  0,140, 38,  0,  0,  0,
     & 313,0.215D0,  0,136, 21,  0,  0,  0,
     & 313,0.235D0,  0,140, 38, 21,  0,  0,
     & 313,0.120D0,  0,136, 38, 30,  0,  0,
     & 314,0.430D0,  0,136, 30,  0,  0,  0,
     & 314,0.215D0,  0,140, 21,  0,  0,  0,
     & 314,0.235D0,  0,136, 30, 21,  0,  0,
     & 314,0.120D0,  0,140, 38, 30,  0,  0,
     & 315,0.480D0,  0,136, 50,  0,  0,  0,
     & 315,0.480D0,  0,140, 46,  0,  0,  0,
     & 315,0.040D0,  0,145, 59,  0,  0,  0,
     & 316,0.430D0,  0,175, 30,  0,  0,  0,
     & 316,0.215D0,  0,171, 21,  0,  0,  0,
     & 316,0.235D0,  0,175, 30, 21,  0,  0,
     & 316,0.120D0,  0,171, 38, 30,  0,  0,
     & 317,0.430D0,  0,171, 38,  0,  0,  0,
     & 317,0.215D0,  0,175, 21,  0,  0,  0/
      DATA (IDK(I),BRFRAC(I),NME(I),(IDKPRD(J,I),J=1,5),I=1863,1881)/
     & 317,0.235D0,  0,171, 38, 21,  0,  0,
     & 317,0.120D0,  0,175, 38, 30,  0,  0,
     & 318,0.480D0,  0,171, 42,  0,  0,  0,
     & 318,0.480D0,  0,175, 34,  0,  0,  0,
     & 318,0.040D0,  0,180, 59,  0,  0,  0,
     & 319,0.540D0,  0,275, 30,  0,  0,  0,
     & 319,0.270D0,  0,274, 21,  0,  0,  0,
     & 319,0.030D0,  0,275, 30, 21,  0,  0,
     & 319,0.010D0,  0,274, 38, 30,  0,  0,
     & 319,0.010D0,  0,274, 21, 21,  0,  0,
     & 319,0.090D0,  0,246, 30, 21,  0,  0,
     & 319,0.030D0,  0,245, 38, 30,  0,  0,
     & 319,0.020D0,  0,245, 21, 21,  0,  0,
     & 320,0.540D0,  0,274, 38,  0,  0,  0,
     & 320,0.270D0,  0,275, 21,  0,  0,  0,
     & 320,0.030D0,  0,274, 38, 21,  0,  0,
     & 320,0.010D0,  0,275, 38, 30,  0,  0,
     & 320,0.010D0,  0,275, 21, 21,  0,  0,
     & 320,0.090D0,  0,245, 38, 21,  0,  0/
      DATA (IDK(I),BRFRAC(I),NME(I),(IDKPRD(J,I),J=1,5),I=1882,1900)/
     & 320,0.030D0,  0,246, 38, 30,  0,  0,
     & 320,0.020D0,  0,246, 21, 21,  0,  0,
     & 321,0.500D0,  0,275, 34,  0,  0,  0,
     & 321,0.500D0,  0,274, 42,  0,  0,  0,
     & 322,1.000D0,  0,254, 59,  0,  0,  0,
     & 323,0.540D0,  0,266, 38,  0,  0,  0,
     & 323,0.270D0,  0,265, 21,  0,  0,  0,
     & 323,0.030D0,  0,266, 38, 21,  0,  0,
     & 323,0.010D0,  0,265, 38, 30,  0,  0,
     & 323,0.010D0,  0,265, 21, 21,  0,  0,
     & 323,0.090D0,  0,222, 38, 21,  0,  0,
     & 323,0.030D0,  0,221, 38, 30,  0,  0,
     & 323,0.020D0,  0,221, 21, 21,  0,  0,
     & 324,0.540D0,  0,265, 30,  0,  0,  0,
     & 324,0.270D0,  0,266, 21,  0,  0,  0,
     & 324,0.030D0,  0,265, 30, 21,  0,  0,
     & 324,0.010D0,  0,266, 38, 30,  0,  0,
     & 324,0.010D0,  0,266, 21, 21,  0,  0,
     & 324,0.090D0,  0,221, 30, 21,  0,  0/
      DATA (IDK(I),BRFRAC(I),NME(I),(IDKPRD(J,I),J=1,5),I=1901,1919)/
     & 324,0.030D0,  0,222, 38, 30,  0,  0,
     & 324,0.020D0,  0,222, 21, 21,  0,  0,
     & 325,0.500D0,  0,266, 46,  0,  0,  0,
     & 325,0.500D0,  0,265, 50,  0,  0,  0,
     & 326,1.000D0,  0,230, 59,  0,  0,  0,
     & 327,0.667D0,  0, 50, 38,  0,  0,  0,
     & 327,0.333D0,  0, 46, 21,  0,  0,  0,
     & 328,0.667D0,  0, 46, 30,  0,  0,  0,
     & 328,0.333D0,  0, 50, 21,  0,  0,  0,
     & 329,0.667D0,  0, 34, 38,  0,  0,  0,
     & 329,0.333D0,  0, 42, 21,  0,  0,  0,
     & 330,0.667D0,  0, 42, 30,  0,  0,  0,
     & 330,0.333D0,  0, 34, 21,  0,  0,  0,
     & 331,0.667D0,  0,140, 38,  0,  0,  0,
     & 331,0.333D0,  0,136, 21,  0,  0,  0,
     & 332,0.667D0,  0,136, 30,  0,  0,  0,
     & 332,0.333D0,  0,140, 21,  0,  0,  0,
     & 333,0.500D0,  0,136, 50,  0,  0,  0,
     & 333,0.500D0,  0,140, 46,  0,  0,  0/
      DATA (IDK(I),BRFRAC(I),NME(I),(IDKPRD(J,I),J=1,5),I=1920,1938)/
     & 334,0.667D0,  0,175, 30,  0,  0,  0,
     & 334,0.333D0,  0,171, 21,  0,  0,  0,
     & 335,0.667D0,  0,171, 38,  0,  0,  0,
     & 335,0.333D0,  0,175, 21,  0,  0,  0,
     & 336,0.500D0,  0,171, 42,  0,  0,  0,
     & 336,0.500D0,  0,175, 34,  0,  0,  0,
     & 337,0.667D0,  0,246, 30,  0,  0,  0,
     & 337,0.333D0,  0,245, 21,  0,  0,  0,
     & 338,0.667D0,  0,245, 38,  0,  0,  0,
     & 338,0.333D0,  0,246, 21,  0,  0,  0,
     & 339,0.500D0,  0,246, 34,  0,  0,  0,
     & 339,0.500D0,  0,245, 42,  0,  0,  0,
     & 340,1.000D0,  0,254, 59,  0,  0,  0,
     & 341,0.667D0,  0,222, 38,  0,  0,  0,
     & 341,0.333D0,  0,221, 21,  0,  0,  0,
     & 342,0.667D0,  0,221, 30,  0,  0,  0,
     & 342,0.333D0,  0,222, 21,  0,  0,  0,
     & 343,0.500D0,  0,222, 46,  0,  0,  0,
     & 343,0.500D0,  0,221, 50,  0,  0,  0/
      DATA (IDK(I),BRFRAC(I),NME(I),(IDKPRD(J,I),J=1,5),I=1939,1957)/
     & 344,1.000D0,  0,230, 59,  0,  0,  0,
     & 345,1.000D0,  0,225, 30,  0,  0,  0,
     & 346,1.000D0,  0,225, 21,  0,  0,  0,
     & 347,1.000D0,  0,225, 21,  0,  0,  0,
     & 348,1.000D0,  0,225, 38,  0,  0,  0,
     & 349,0.600D0,  0,228, 38,  0,  0,  0,
     & 349,0.300D0,  0,227, 21,  0,  0,  0,
     & 349,0.100D0,  0,227, 59,  0,  0,  0,
     & 350,0.600D0,  0,228, 38,  0,  0,  0,
     & 350,0.300D0,  0,227, 21,  0,  0,  0,
     & 350,0.100D0,  0,227, 59,  0,  0,  0,
     & 351,0.600D0,  0,227, 30,  0,  0,  0,
     & 351,0.300D0,  0,228, 21,  0,  0,  0,
     & 351,0.100D0,  0,228, 59,  0,  0,  0,
     & 352,0.600D0,  0,227, 30,  0,  0,  0,
     & 352,0.300D0,  0,228, 21,  0,  0,  0,
     & 352,0.100D0,  0,228, 59,  0,  0,  0,
     & 353,1.000D0,  0,229, 59,  0,  0,  0,
     & 354,1.000D0,  0,249, 38,  0,  0,  0/
      DATA (IDK(I),BRFRAC(I),NME(I),(IDKPRD(J,I),J=1,5),I=1958,1976)/
     & 355,1.000D0,  0,249, 21,  0,  0,  0,
     & 356,1.000D0,  0,249, 21,  0,  0,  0,
     & 357,1.000D0,  0,249, 30,  0,  0,  0,
     & 358,0.600D0,  0,252, 30,  0,  0,  0,
     & 358,0.300D0,  0,251, 21,  0,  0,  0,
     & 358,0.100D0,  0,251, 59,  0,  0,  0,
     & 359,0.600D0,  0,252, 30,  0,  0,  0,
     & 359,0.300D0,  0,251, 21,  0,  0,  0,
     & 359,0.100D0,  0,251, 59,  0,  0,  0,
     & 360,0.600D0,  0,251, 38,  0,  0,  0,
     & 360,0.300D0,  0,252, 21,  0,  0,  0,
     & 360,0.100D0,  0,252, 59,  0,  0,  0,
     & 361,0.600D0,  0,251, 38,  0,  0,  0,
     & 361,0.300D0,  0,252, 21,  0,  0,  0,
     & 361,0.100D0,  0,252, 59,  0,  0,  0,
     & 362,1.000D0,  0,253, 59,  0,  0,  0,
     & 363,0.400D0,  0, 53, 38,  0,  0,  0,
     & 363,0.200D0,  0, 49, 21,  0,  0,  0,
     & 363,0.100D0,  0, 51, 38,  0,  0,  0/
      DATA (IDK(I),BRFRAC(I),NME(I),(IDKPRD(J,I),J=1,5),I=1977,1995)/
     & 363,0.050D0,  0, 47, 21,  0,  0,  0,
     & 363,0.150D0,  0, 46, 26,  0,  0,  0,
     & 363,0.050D0,  0, 46, 56,  0,  0,  0,
     & 363,0.050D0,  0, 46, 24,  0,  0,  0,
     & 364,0.400D0,  0, 49, 30,  0,  0,  0,
     & 364,0.200D0,  0, 53, 21,  0,  0,  0,
     & 364,0.100D0,  0, 47, 30,  0,  0,  0,
     & 364,0.050D0,  0, 51, 21,  0,  0,  0,
     & 364,0.150D0,  0, 50, 26,  0,  0,  0,
     & 364,0.050D0,  0, 50, 56,  0,  0,  0,
     & 364,0.050D0,  0, 50, 24,  0,  0,  0,
     & 365,0.400D0,  0, 37, 38,  0,  0,  0,
     & 365,0.200D0,  0, 45, 21,  0,  0,  0,
     & 365,0.100D0,  0, 35, 38,  0,  0,  0,
     & 365,0.050D0,  0, 43, 21,  0,  0,  0,
     & 365,0.150D0,  0, 42, 26,  0,  0,  0,
     & 365,0.050D0,  0, 42, 56,  0,  0,  0,
     & 365,0.050D0,  0, 42, 24,  0,  0,  0,
     & 366,0.400D0,  0, 45, 30,  0,  0,  0/
      DATA (IDK(I),BRFRAC(I),NME(I),(IDKPRD(J,I),J=1,5),I=1996,2014)/
     & 366,0.200D0,  0, 37, 21,  0,  0,  0,
     & 366,0.100D0,  0, 43, 30,  0,  0,  0,
     & 366,0.050D0,  0, 35, 21,  0,  0,  0,
     & 366,0.150D0,  0, 34, 26,  0,  0,  0,
     & 366,0.050D0,  0, 34, 56,  0,  0,  0,
     & 366,0.050D0,  0, 34, 24,  0,  0,  0,
     & 367,0.258D0,  0, 50, 38,  0,  0,  0,
     & 367,0.129D0,  0, 46, 21,  0,  0,  0,
     & 367,0.209D0,  0, 50, 39,  0,  0,  0,
     & 367,0.105D0,  0, 46, 23,  0,  0,  0,
     & 367,0.199D0,  0, 51, 38,  0,  0,  0,
     & 367,0.100D0,  0, 47, 21,  0,  0,  0,
     & 368,0.258D0,  0, 46, 30,  0,  0,  0,
     & 368,0.129D0,  0, 50, 21,  0,  0,  0,
     & 368,0.209D0,  0, 46, 31,  0,  0,  0,
     & 368,0.105D0,  0, 50, 23,  0,  0,  0,
     & 368,0.199D0,  0, 47, 30,  0,  0,  0,
     & 368,0.100D0,  0, 51, 21,  0,  0,  0,
     & 369,0.258D0,  0, 34, 38,  0,  0,  0/
      DATA (IDK(I),BRFRAC(I),NME(I),(IDKPRD(J,I),J=1,5),I=2015,2033)/
     & 369,0.129D0,  0, 42, 21,  0,  0,  0,
     & 369,0.209D0,  0, 34, 39,  0,  0,  0,
     & 369,0.105D0,  0, 42, 23,  0,  0,  0,
     & 369,0.199D0,  0, 35, 38,  0,  0,  0,
     & 369,0.100D0,  0, 43, 21,  0,  0,  0,
     & 370,0.258D0,  0, 42, 30,  0,  0,  0,
     & 370,0.129D0,  0, 34, 21,  0,  0,  0,
     & 370,0.209D0,  0, 42, 31,  0,  0,  0,
     & 370,0.105D0,  0, 34, 23,  0,  0,  0,
     & 370,0.199D0,  0, 43, 30,  0,  0,  0,
     & 370,0.100D0,  0, 35, 21,  0,  0,  0,
     & 371,0.400D0,  0, 53, 38,  0,  0,  0,
     & 371,0.200D0,  0, 49, 21,  0,  0,  0,
     & 371,0.100D0,  0, 51, 38,  0,  0,  0,
     & 371,0.050D0,  0, 47, 21,  0,  0,  0,
     & 371,0.150D0,  0, 46, 26,  0,  0,  0,
     & 371,0.050D0,  0, 46, 56,  0,  0,  0,
     & 371,0.050D0,  0, 46, 24,  0,  0,  0,
     & 372,0.400D0,  0, 49, 30,  0,  0,  0/
      DATA (IDK(I),BRFRAC(I),NME(I),(IDKPRD(J,I),J=1,5),I=2034,2052)/
     & 372,0.200D0,  0, 53, 21,  0,  0,  0,
     & 372,0.100D0,  0, 47, 30,  0,  0,  0,
     & 372,0.050D0,  0, 51, 21,  0,  0,  0,
     & 372,0.150D0,  0, 50, 26,  0,  0,  0,
     & 372,0.050D0,  0, 50, 56,  0,  0,  0,
     & 372,0.050D0,  0, 50, 24,  0,  0,  0,
     & 373,0.400D0,  0, 37, 38,  0,  0,  0,
     & 373,0.200D0,  0, 45, 21,  0,  0,  0,
     & 373,0.100D0,  0, 35, 38,  0,  0,  0,
     & 373,0.050D0,  0, 43, 21,  0,  0,  0,
     & 373,0.150D0,  0, 42, 26,  0,  0,  0,
     & 373,0.050D0,  0, 42, 56,  0,  0,  0,
     & 373,0.050D0,  0, 42, 24,  0,  0,  0,
     & 374,0.400D0,  0, 45, 30,  0,  0,  0,
     & 374,0.200D0,  0, 37, 21,  0,  0,  0,
     & 374,0.100D0,  0, 43, 30,  0,  0,  0,
     & 374,0.050D0,  0, 35, 21,  0,  0,  0,
     & 374,0.150D0,  0, 34, 26,  0,  0,  0,
     & 374,0.050D0,  0, 34, 56,  0,  0,  0/
      DATA (IDK(I),BRFRAC(I),NME(I),(IDKPRD(J,I),J=1,5),I=2053,2071)/
     & 374,0.050D0,  0, 34, 24,  0,  0,  0,
     & 375,0.208D0,  0, 50, 39,  0,  0,  0,
     & 375,0.104D0,  0, 46, 23,  0,  0,  0,
     & 375,0.134D0,  0, 51, 38,  0,  0,  0,
     & 375,0.067D0,  0, 47, 21,  0,  0,  0,
     & 375,0.124D0,  0, 50, 38,  0,  0,  0,
     & 375,0.062D0,  0, 46, 21,  0,  0,  0,
     & 375,0.301D0,  0, 46, 22,  0,  0,  0,
     & 376,0.208D0,  0, 46, 31,  0,  0,  0,
     & 376,0.104D0,  0, 50, 23,  0,  0,  0,
     & 376,0.134D0,  0, 47, 30,  0,  0,  0,
     & 376,0.067D0,  0, 51, 21,  0,  0,  0,
     & 376,0.124D0,  0, 46, 30,  0,  0,  0,
     & 376,0.062D0,  0, 50, 21,  0,  0,  0,
     & 376,0.301D0,  0, 50, 22,  0,  0,  0,
     & 377,0.208D0,  0, 34, 39,  0,  0,  0,
     & 377,0.104D0,  0, 42, 23,  0,  0,  0,
     & 377,0.134D0,  0, 35, 38,  0,  0,  0,
     & 377,0.067D0,  0, 43, 21,  0,  0,  0/
      DATA (IDK(I),BRFRAC(I),NME(I),(IDKPRD(J,I),J=1,5),I=2072,2090)/
     & 377,0.124D0,  0, 34, 38,  0,  0,  0,
     & 377,0.062D0,  0, 42, 21,  0,  0,  0,
     & 377,0.301D0,  0, 42, 22,  0,  0,  0,
     & 378,0.208D0,  0, 42, 31,  0,  0,  0,
     & 378,0.104D0,  0, 34, 23,  0,  0,  0,
     & 378,0.134D0,  0, 43, 30,  0,  0,  0,
     & 378,0.067D0,  0, 35, 21,  0,  0,  0,
     & 378,0.124D0,  0, 42, 30,  0,  0,  0,
     & 378,0.062D0,  0, 34, 21,  0,  0,  0,
     & 378,0.301D0,  0, 34, 22,  0,  0,  0,
     & 379,0.562D0,  0, 26, 38,  0,  0,  0,
     & 379,0.155D0,  0, 39, 21,  0,  0,  0,
     & 379,0.155D0,  0, 23, 38,  0,  0,  0,
     & 379,0.088D0,  0,293, 38,  0,  0,  0,
     & 379,0.020D0,  0, 46, 43,  0,  0,  0,
     & 379,0.020D0,  0, 42, 47,  0,  0,  0,
     & 380,0.562D0,  0, 26, 21,  0,  0,  0,
     & 380,0.155D0,  0, 39, 30,  0,  0,  0,
     & 380,0.155D0,  0, 31, 38,  0,  0,  0/
      DATA (IDK(I),BRFRAC(I),NME(I),(IDKPRD(J,I),J=1,5),I=2091,2109)/
     & 380,0.088D0,  0,293, 21,  0,  0,  0,
     & 380,0.010D0,  0, 46, 35,  0,  0,  0,
     & 380,0.010D0,  0, 50, 43,  0,  0,  0,
     & 380,0.010D0,  0, 34, 47,  0,  0,  0,
     & 380,0.010D0,  0, 42, 51,  0,  0,  0,
     & 381,0.562D0,  0, 26, 30,  0,  0,  0,
     & 381,0.155D0,  0, 31, 21,  0,  0,  0,
     & 381,0.155D0,  0, 23, 30,  0,  0,  0,
     & 381,0.088D0,  0,293, 30,  0,  0,  0,
     & 381,0.020D0,  0, 34, 51,  0,  0,  0,
     & 381,0.020D0,  0, 50, 35,  0,  0,  0,
     & 382,0.360D0,  0, 31, 38, 38,  0,  0,
     & 382,0.180D0,  0, 23, 38, 21,  0,  0,
     & 382,0.040D0,  0, 39, 21, 21,  0,  0,
     & 382,0.020D0,  0, 39, 38, 30,  0,  0,
     & 382,0.300D0,  0, 38, 21,  0,  0,  0,
     & 382,0.040D0,  0, 46, 43,  0,  0,  0,
     & 382,0.040D0,  0, 42, 47,  0,  0,  0,
     & 382,0.020D0,  0, 22, 39,  0,  0,  0/
      DATA (IDK(I),BRFRAC(I),NME(I),(IDKPRD(J,I),J=1,5),I=2110,2128)/
     & 383,0.180D0,  0, 39, 30, 21,  0,  0,
     & 383,0.180D0,  0, 31, 38, 21,  0,  0,
     & 383,0.160D0,  0, 23, 21, 21,  0,  0,
     & 383,0.080D0,  0, 23, 38, 30,  0,  0,
     & 383,0.300D0,  0, 38, 30,  0,  0,  0,
     & 383,0.020D0,  0, 46, 35,  0,  0,  0,
     & 383,0.020D0,  0, 50, 43,  0,  0,  0,
     & 383,0.020D0,  0, 34, 47,  0,  0,  0,
     & 383,0.020D0,  0, 42, 51,  0,  0,  0,
     & 383,0.020D0,  0, 22, 23,  0,  0,  0,
     & 384,0.360D0,  0, 39, 30, 30,  0,  0,
     & 384,0.180D0,  0, 23, 30, 21,  0,  0,
     & 384,0.040D0,  0, 31, 21, 21,  0,  0,
     & 384,0.020D0,  0, 31, 30, 38,  0,  0,
     & 384,0.300D0,  0, 30, 21,  0,  0,  0,
     & 384,0.040D0,  0, 34, 51,  0,  0,  0,
     & 384,0.040D0,  0, 50, 35,  0,  0,  0,
     & 384,0.020D0,  0, 22, 31,  0,  0,  0,
     & 385,0.184D0,  0, 41, 21,  0,  0,  0/
      DATA (IDK(I),BRFRAC(I),NME(I),(IDKPRD(J,I),J=1,5),I=2129,2147)/
     & 385,0.184D0,  0, 29, 38,  0,  0,  0,
     & 385,0.184D0,  0, 39, 23,  0,  0,  0,
     & 385,0.236D0,  0, 38, 21,  0,  0,  0,
     & 385,0.160D0,  0, 24, 38,  0,  0,  0,
     & 385,0.018D0,  0, 46, 43,  0,  0,  0,
     & 385,0.018D0,  0, 42, 47,  0,  0,  0,
     & 385,0.016D0,  0, 46, 42,  0,  0,  0,
     & 386,0.184D0,  0, 41, 30,  0,  0,  0,
     & 386,0.184D0,  0, 33, 38,  0,  0,  0,
     & 386,0.184D0,  0, 39, 31,  0,  0,  0,
     & 386,0.236D0,  0, 38, 30,  0,  0,  0,
     & 386,0.160D0,  0, 24, 21,  0,  0,  0,
     & 386,0.009D0,  0, 46, 35,  0,  0,  0,
     & 386,0.009D0,  0, 50, 43,  0,  0,  0,
     & 386,0.009D0,  0, 34, 47,  0,  0,  0,
     & 386,0.009D0,  0, 42, 51,  0,  0,  0,
     & 386,0.008D0,  0, 46, 34,  0,  0,  0,
     & 386,0.008D0,  0, 42, 50,  0,  0,  0,
     & 387,0.184D0,  0, 33, 21,  0,  0,  0/
      DATA (IDK(I),BRFRAC(I),NME(I),(IDKPRD(J,I),J=1,5),I=2148,2166)/
     & 387,0.184D0,  0, 29, 30,  0,  0,  0,
     & 387,0.184D0,  0, 31, 23,  0,  0,  0,
     & 387,0.236D0,  0, 30, 21,  0,  0,  0,
     & 387,0.160D0,  0, 24, 30,  0,  0,  0,
     & 387,0.018D0,  0, 34, 51,  0,  0,  0,
     & 387,0.018D0,  0, 50, 35,  0,  0,  0,
     & 387,0.016D0,  0, 34, 50,  0,  0,  0,
     & 388,0.183D0,  0,231, 38, 30,  0,  0,
     & 388,0.091D0,  0,231, 21, 21,  0,  0,
     & 388,0.067D0,  0, 59,307,  0,  0,  0,
     & 388,0.066D0,  0, 59,308,  0,  0,  0,
     & 388,0.043D0,  0, 59,309,  0,  0,  0,
     & 388,0.446D0,130, 13, 13, 13,  0,  0,
     & 388,0.023D0,130, 13, 13, 59,  0,  0,
     & 388,0.013D0,  0,121,127,  0,  0,  0,
     & 388,0.013D0,  0,123,129,  0,  0,  0,
     & 388,0.013D0,  0,125,131,  0,  0,  0,
     & 388,0.004D0,  0,  1,  7,  0,  0,  0,
     & 388,0.017D0,  0,  2,  8,  0,  0,  0/
      DATA (IDK(I),BRFRAC(I),NME(I),(IDKPRD(J,I),J=1,5),I=2167,2185)/
     & 388,0.004D0,  0,  3,  9,  0,  0,  0,
     & 388,0.017D0,  0,  4, 10,  0,  0,  0,
     & 389,0.046D0,  0, 59,388,  0,  0,  0,
     & 389,0.009D0,  0, 59,231,  0,  0,  0,
     & 389,0.755D0,  0, 13, 13,  0,  0,  0,
     & 389,0.030D0,  0,121,127,  0,  0,  0,
     & 389,0.030D0,  0,123,129,  0,  0,  0,
     & 389,0.030D0,  0,125,131,  0,  0,  0,
     & 389,0.010D0,  0,  1,  7,  0,  0,  0,
     & 389,0.040D0,  0,  2,  8,  0,  0,  0,
     & 389,0.010D0,  0,  3,  9,  0,  0,  0,
     & 389,0.040D0,  0,  4, 10,  0,  0,  0,
     & 390,0.210D0,  0, 59,388,  0,  0,  0,
     & 390,0.085D0,  0, 59,231,  0,  0,  0,
     & 390,0.565D0,  0, 13, 13,  0,  0,  0,
     & 390,0.022D0,  0,121,127,  0,  0,  0,
     & 390,0.022D0,  0,123,129,  0,  0,  0,
     & 390,0.022D0,  0,125,131,  0,  0,  0,
     & 390,0.007D0,  0,  1,  7,  0,  0,  0/
      DATA (IDK(I),BRFRAC(I),NME(I),(IDKPRD(J,I),J=1,5),I=2186,2204)/
     & 390,0.030D0,  0,  2,  8,  0,  0,  0,
     & 390,0.007D0,  0,  3,  9,  0,  0,  0,
     & 390,0.030D0,  0,  4, 10,  0,  0,  0,
     & 391,0.162D0,  0, 59,388,  0,  0,  0,
     & 391,0.071D0,  0, 59,231,  0,  0,  0,
     & 391,0.615D0,  0, 13, 13,  0,  0,  0,
     & 391,0.024D0,  0,121,127,  0,  0,  0,
     & 391,0.024D0,  0,123,129,  0,  0,  0,
     & 391,0.024D0,  0,125,131,  0,  0,  0,
     & 391,0.008D0,  0,  1,  7,  0,  0,  0,
     & 391,0.032D0,  0,  2,  8,  0,  0,  0,
     & 391,0.008D0,  0,  3,  9,  0,  0,  0,
     & 391,0.032D0,  0,  4, 10,  0,  0,  0,
     & 392,0.034D0,  0,267, 38, 30,  0,  0,
     & 392,0.017D0,  0,267, 21, 21,  0,  0,
     & 392,0.044D0,  0,231, 38, 30,  0,  0,
     & 392,0.022D0,  0,231, 21, 21,  0,  0,
     & 392,0.050D0,  0,267, 59, 59,  0,  0,
     & 392,0.114D0,  0, 59,389,  0,  0,  0/
      DATA (IDK(I),BRFRAC(I),NME(I),(IDKPRD(J,I),J=1,5),I=2205,2223)/
     & 392,0.113D0,  0, 59,390,  0,  0,  0,
     & 392,0.054D0,  0, 59,391,  0,  0,  0,
     & 392,0.403D0,130, 13, 13, 13,  0,  0,
     & 392,0.021D0,130, 13, 13, 59,  0,  0,
     & 392,0.020D0,  0,121,127,  0,  0,  0,
     & 392,0.020D0,  0,123,129,  0,  0,  0,
     & 392,0.020D0,  0,125,131,  0,  0,  0,
     & 392,0.007D0,  0,  1,  7,  0,  0,  0,
     & 392,0.027D0,  0,  2,  8,  0,  0,  0,
     & 392,0.007D0,  0,  3,  9,  0,  0,  0,
     & 392,0.027D0,  0,  4, 10,  0,  0,  0,
     & 393,0.250D0,  0,246,222,  0,  0,  0,
     & 393,0.250D0,  0,245,221,  0,  0,  0,
     & 393,0.385D0,130, 13, 13, 13,  0,  0,
     & 393,0.020D0,130, 13, 13, 59,  0,  0,
     & 393,0.015D0,  0,121,127,  0,  0,  0,
     & 393,0.015D0,  0,123,129,  0,  0,  0,
     & 393,0.015D0,  0,125,131,  0,  0,  0,
     & 393,0.005D0,  0,  1,  7,  0,  0,  0/
      DATA (IDK(I),BRFRAC(I),NME(I),(IDKPRD(J,I),J=1,5),I=2224,2242)/
     & 393,0.020D0,  0,  2,  8,  0,  0,  0,
     & 393,0.005D0,  0,  3,  9,  0,  0,  0,
     & 393,0.020D0,  0,  4, 10,  0,  0,  0,
     & 395,0.195D0,  0, 39, 30,  0,  0,  0,
     & 395,0.195D0,  0, 23, 21,  0,  0,  0,
     & 395,0.195D0,  0, 31, 38,  0,  0,  0,
     & 395,0.105D0,  0,286, 30,  0,  0,  0,
     & 395,0.105D0,  0,285, 21,  0,  0,  0,
     & 395,0.105D0,  0,287, 38,  0,  0,  0,
     & 395,0.065D0,  0, 24, 38, 30,  0,  0,
     & 395,0.035D0,  0, 24, 21, 21,  0,  0,
     & 396,0.320D0,  0, 46, 34,  0,  0,  0,
     & 396,0.320D0,  0, 60, 61,  0,  0,  0,
     & 396,0.090D0,  0, 46, 35,  0,  0,  0,
     & 396,0.090D0,  0, 42, 51,  0,  0,  0,
     & 396,0.090D0,  0, 50, 43,  0,  0,  0,
     & 396,0.090D0,  0, 34, 47,  0,  0,  0,
     & 397,0.312D0,  0, 41, 30,  0,  0,  0,
     & 397,0.312D0,  0, 29, 21,  0,  0,  0/
      DATA (IDK(I),BRFRAC(I),NME(I),(IDKPRD(J,I),J=1,5),I=2243,2261)/
     & 397,0.312D0,  0, 33, 38,  0,  0,  0,
     & 397,0.016D0,  0, 46, 35,  0,  0,  0,
     & 397,0.016D0,  0, 42, 51,  0,  0,  0,
     & 397,0.016D0,  0, 50, 43,  0,  0,  0,
     & 397,0.016D0,  0, 34, 47,  0,  0,  0,
     & 398,0.805D0,  0, 26, 22,  0,  0,  0,
     & 398,0.065D0,  0, 41, 30,  0,  0,  0,
     & 398,0.065D0,  0, 29, 21,  0,  0,  0,
     & 398,0.065D0,  0, 33, 38,  0,  0,  0,
     & 399,0.667D0,  0, 24, 38, 30,  0,  0,
     & 399,0.333D0,  0, 24, 21, 21,  0,  0,
     &  62,0.440D0,  0, 21, 22,  0,  0,  0,
     &  62,0.160D0,  0, 21, 25,  0,  0,  0,
     &  62,0.200D0,  0, 50, 42,  0,  0,  0,
     &  62,0.200D0,  0, 46, 34,  0,  0,  0,
     &  63,0.440D0,  0, 38, 22,  0,  0,  0,
     &  63,0.160D0,  0, 38, 25,  0,  0,  0,
     &  63,0.400D0,  0, 46, 42,  0,  0,  0,
     &  64,0.440D0,  0, 30, 22,  0,  0,  0/
      DATA (IDK(I),BRFRAC(I),NME(I),(IDKPRD(J,I),J=1,5),I=2262,2263)/
     &  64,0.160D0,  0, 30, 25,  0,  0,  0,
     &  64,0.400D0,  0, 50, 34,  0,  0,  0/
C--data for MRST98 LO PDF's
      DATA (FMRS(1,1,I, 1),I=1,49)/
     &     0.01518D0,  0.01868D0,  0.02298D0,  0.02594D0,  0.02828D0,
     &     0.03023D0,  0.03724D0,  0.04592D0,  0.05197D0,  0.05679D0,
     &     0.06085D0,  0.07576D0,  0.09547D0,  0.11035D0,  0.12307D0,
     &     0.13453D0,  0.15525D0,  0.18319D0,  0.22542D0,  0.26441D0,
     &     0.33553D0,  0.39881D0,  0.45451D0,  0.51363D0,  0.56120D0,
     &     0.59755D0,  0.62324D0,  0.63889D0,  0.64529D0,  0.64295D0,
     &     0.63335D0,  0.61691D0,  0.59464D0,  0.56748D0,  0.53621D0,
     &     0.50180D0,  0.46495D0,  0.42660D0,  0.38735D0,  0.34791D0,
     &     0.30888D0,  0.27105D0,  0.23455D0,  0.16807D0,  0.11197D0,
     &     0.06774D0,  0.03566D0,  0.00443D0,  0.00000D0/
      DATA (FMRS(1,1,I, 2),I=1,49)/
     &     0.01534D0,  0.01889D0,  0.02325D0,  0.02625D0,  0.02862D0,
     &     0.03061D0,  0.03771D0,  0.04653D0,  0.05268D0,  0.05757D0,
     &     0.06171D0,  0.07691D0,  0.09707D0,  0.11230D0,  0.12533D0,
     &     0.13708D0,  0.15827D0,  0.18678D0,  0.22968D0,  0.26907D0,
     &     0.34038D0,  0.40321D0,  0.45801D0,  0.51556D0,  0.56122D0,
     &     0.59551D0,  0.61905D0,  0.63261D0,  0.63699D0,  0.63286D0,
     &     0.62162D0,  0.60381D0,  0.58043D0,  0.55244D0,  0.52060D0,
     &     0.48591D0,  0.44902D0,  0.41090D0,  0.37213D0,  0.33332D0,
     &     0.29514D0,  0.25827D0,  0.22283D0,  0.15873D0,  0.10506D0,
     &     0.06310D0,  0.03294D0,  0.00399D0,  0.00000D0/
      DATA (FMRS(1,1,I, 3),I=1,49)/
     &     0.01559D0,  0.01920D0,  0.02365D0,  0.02672D0,  0.02914D0,
     &     0.03116D0,  0.03842D0,  0.04744D0,  0.05374D0,  0.05876D0,
     &     0.06301D0,  0.07866D0,  0.09949D0,  0.11525D0,  0.12874D0,
     &     0.14090D0,  0.16278D0,  0.19212D0,  0.23598D0,  0.27589D0,
     &     0.34735D0,  0.40941D0,  0.46279D0,  0.51792D0,  0.56073D0,
     &     0.59195D0,  0.61237D0,  0.62289D0,  0.62439D0,  0.61773D0,
     &     0.60419D0,  0.58448D0,  0.55962D0,  0.53052D0,  0.49799D0,
     &     0.46298D0,  0.42617D0,  0.38844D0,  0.35048D0,  0.31268D0,
     &     0.27573D0,  0.24031D0,  0.20643D0,  0.14575D0,  0.09554D0,
     &     0.05679D0,  0.02927D0,  0.00342D0,  0.00000D0/
      DATA (FMRS(1,1,I, 4),I=1,49)/
     &     0.01577D0,  0.01944D0,  0.02395D0,  0.02707D0,  0.02952D0,
     &     0.03158D0,  0.03895D0,  0.04812D0,  0.05453D0,  0.05964D0,
     &     0.06398D0,  0.07996D0,  0.10128D0,  0.11743D0,  0.13126D0,
     &     0.14371D0,  0.16610D0,  0.19602D0,  0.24052D0,  0.28078D0,
     &     0.35225D0,  0.41367D0,  0.46596D0,  0.51926D0,  0.56000D0,
     &     0.58897D0,  0.60716D0,  0.61554D0,  0.61505D0,  0.60661D0,
     &     0.59150D0,  0.57049D0,  0.54465D0,  0.51484D0,  0.48194D0,
     &     0.44680D0,  0.41012D0,  0.37271D0,  0.33536D0,  0.29833D0,
     &     0.26227D0,  0.22791D0,  0.19519D0,  0.13692D0,  0.08913D0,
     &     0.05257D0,  0.02685D0,  0.00306D0,  0.00000D0/
      DATA (FMRS(1,1,I, 5),I=1,49)/
     &     0.01597D0,  0.01969D0,  0.02427D0,  0.02744D0,  0.02993D0,
     &     0.03202D0,  0.03952D0,  0.04885D0,  0.05537D0,  0.06058D0,
     &     0.06501D0,  0.08134D0,  0.10319D0,  0.11975D0,  0.13393D0,
     &     0.14669D0,  0.16958D0,  0.20009D0,  0.24521D0,  0.28578D0,
     &     0.35715D0,  0.41781D0,  0.46887D0,  0.52022D0,  0.55877D0,
     &     0.58539D0,  0.60126D0,  0.60744D0,  0.60489D0,  0.59469D0,
     &     0.57807D0,  0.55581D0,  0.52903D0,  0.49861D0,  0.46535D0,
     &     0.43012D0,  0.39368D0,  0.35672D0,  0.32002D0,  0.28380D0,
     &     0.24878D0,  0.21549D0,  0.18398D0,  0.12819D0,  0.08284D0,
     &     0.04845D0,  0.02451D0,  0.00272D0,  0.00000D0/
      DATA (FMRS(1,1,I, 6),I=1,49)/
     &     0.01613D0,  0.01990D0,  0.02455D0,  0.02776D0,  0.03029D0,
     &     0.03241D0,  0.04001D0,  0.04949D0,  0.05611D0,  0.06141D0,
     &     0.06592D0,  0.08256D0,  0.10485D0,  0.12178D0,  0.13626D0,
     &     0.14927D0,  0.17260D0,  0.20361D0,  0.24924D0,  0.29005D0,
     &     0.36128D0,  0.42124D0,  0.47121D0,  0.52086D0,  0.55750D0,
     &     0.58213D0,  0.59603D0,  0.60035D0,  0.59612D0,  0.58445D0,
     &     0.56659D0,  0.54334D0,  0.51581D0,  0.48493D0,  0.45142D0,
     &     0.41618D0,  0.37998D0,  0.34345D0,  0.30732D0,  0.27182D0,
     &     0.23768D0,  0.20532D0,  0.17482D0,  0.12110D0,  0.07777D0,
     &     0.04515D0,  0.02267D0,  0.00245D0,  0.00000D0/
      DATA (FMRS(1,1,I, 7),I=1,49)/
     &     0.01630D0,  0.02011D0,  0.02482D0,  0.02807D0,  0.03063D0,
     &     0.03278D0,  0.04049D0,  0.05010D0,  0.05683D0,  0.06221D0,
     &     0.06680D0,  0.08373D0,  0.10647D0,  0.12373D0,  0.13849D0,
     &     0.15175D0,  0.17549D0,  0.20695D0,  0.25304D0,  0.29403D0,
     &     0.36506D0,  0.42430D0,  0.47319D0,  0.52118D0,  0.55597D0,
     &     0.57870D0,  0.59079D0,  0.59337D0,  0.58760D0,  0.57458D0,
     &     0.55556D0,  0.53145D0,  0.50329D0,  0.47196D0,  0.43832D0,
     &     0.40316D0,  0.36719D0,  0.33110D0,  0.29555D0,  0.26076D0,
     &     0.22742D0,  0.19600D0,  0.16642D0,  0.11467D0,  0.07318D0,
     &     0.04221D0,  0.02103D0,  0.00223D0,  0.00000D0/
      DATA (FMRS(1,1,I, 8),I=1,49)/
     &     0.01647D0,  0.02033D0,  0.02511D0,  0.02840D0,  0.03100D0,
     &     0.03318D0,  0.04101D0,  0.05076D0,  0.05760D0,  0.06307D0,
     &     0.06774D0,  0.08499D0,  0.10819D0,  0.12581D0,  0.14088D0,
     &     0.15440D0,  0.17856D0,  0.21047D0,  0.25702D0,  0.29817D0,
     &     0.36893D0,  0.42735D0,  0.47507D0,  0.52128D0,  0.55411D0,
     &     0.57487D0,  0.58505D0,  0.58586D0,  0.57850D0,  0.56412D0,
     &     0.54397D0,  0.51898D0,  0.49021D0,  0.45851D0,  0.42474D0,
     &     0.38970D0,  0.35404D0,  0.31842D0,  0.28351D0,  0.24949D0,
     &     0.21700D0,  0.18654D0,  0.15795D0,  0.10821D0,  0.06861D0,
     &     0.03930D0,  0.01942D0,  0.00201D0,  0.00000D0/
      DATA (FMRS(1,1,I, 9),I=1,49)/
     &     0.01662D0,  0.02053D0,  0.02536D0,  0.02869D0,  0.03133D0,
     &     0.03353D0,  0.04146D0,  0.05135D0,  0.05828D0,  0.06382D0,
     &     0.06856D0,  0.08610D0,  0.10971D0,  0.12764D0,  0.14296D0,
     &     0.15670D0,  0.18121D0,  0.21352D0,  0.26045D0,  0.30172D0,
     &     0.37220D0,  0.42986D0,  0.47655D0,  0.52120D0,  0.55234D0,
     &     0.57141D0,  0.57995D0,  0.57927D0,  0.57058D0,  0.55506D0,
     &     0.53402D0,  0.50830D0,  0.47904D0,  0.44709D0,  0.41323D0,
     &     0.37832D0,  0.34296D0,  0.30776D0,  0.27344D0,  0.24008D0,
     &     0.20833D0,  0.17868D0,  0.15093D0,  0.10287D0,  0.06487D0,
     &     0.03693D0,  0.01812D0,  0.00183D0,  0.00000D0/
      DATA (FMRS(1,1,I,10),I=1,49)/
     &     0.01676D0,  0.02072D0,  0.02560D0,  0.02898D0,  0.03164D0,
     &     0.03388D0,  0.04190D0,  0.05191D0,  0.05894D0,  0.06456D0,
     &     0.06937D0,  0.08718D0,  0.11117D0,  0.12940D0,  0.14497D0,
     &     0.15892D0,  0.18377D0,  0.21643D0,  0.26368D0,  0.30503D0,
     &     0.37520D0,  0.43209D0,  0.47774D0,  0.52089D0,  0.55041D0,
     &     0.56787D0,  0.57486D0,  0.57280D0,  0.56285D0,  0.54631D0,
     &     0.52442D0,  0.49810D0,  0.46842D0,  0.43624D0,  0.40236D0,
     &     0.36762D0,  0.33255D0,  0.29778D0,  0.26402D0,  0.23132D0,
     &     0.20029D0,  0.17139D0,  0.14445D0,  0.09798D0,  0.06147D0,
     &     0.03479D0,  0.01695D0,  0.00168D0,  0.00000D0/
      DATA (FMRS(1,1,I,11),I=1,49)/
     &     0.01688D0,  0.02087D0,  0.02580D0,  0.02920D0,  0.03189D0,
     &     0.03415D0,  0.04225D0,  0.05236D0,  0.05946D0,  0.06515D0,
     &     0.07001D0,  0.08804D0,  0.11234D0,  0.13081D0,  0.14657D0,
     &     0.16068D0,  0.18579D0,  0.21873D0,  0.26622D0,  0.30762D0,
     &     0.37751D0,  0.43378D0,  0.47859D0,  0.52054D0,  0.54880D0,
     &     0.56500D0,  0.57079D0,  0.56765D0,  0.55675D0,  0.53942D0,
     &     0.51689D0,  0.49012D0,  0.46015D0,  0.42782D0,  0.39393D0,
     &     0.35936D0,  0.32453D0,  0.29009D0,  0.25678D0,  0.22461D0,
     &     0.19416D0,  0.16583D0,  0.13951D0,  0.09427D0,  0.05892D0,
     &     0.03318D0,  0.01609D0,  0.00157D0,  0.00000D0/
      DATA (FMRS(1,1,I,12),I=1,49)/
     &     0.01713D0,  0.02119D0,  0.02622D0,  0.02969D0,  0.03243D0,
     &     0.03474D0,  0.04300D0,  0.05334D0,  0.06060D0,  0.06641D0,
     &     0.07140D0,  0.08989D0,  0.11485D0,  0.13381D0,  0.14997D0,
     &     0.16442D0,  0.19008D0,  0.22357D0,  0.27152D0,  0.31299D0,
     &     0.38219D0,  0.43708D0,  0.48008D0,  0.51946D0,  0.54505D0,
     &     0.55859D0,  0.56192D0,  0.55654D0,  0.54370D0,  0.52483D0,
     &     0.50100D0,  0.47335D0,  0.44283D0,  0.41025D0,  0.37649D0,
     &     0.34225D0,  0.30799D0,  0.27433D0,  0.24202D0,  0.21092D0,
     &     0.18167D0,  0.15459D0,  0.12954D0,  0.08683D0,  0.05380D0,
     &     0.03001D0,  0.01438D0,  0.00136D0,  0.00000D0/
      DATA (FMRS(1,1,I,13),I=1,49)/
     &     0.01734D0,  0.02147D0,  0.02658D0,  0.03011D0,  0.03290D0,
     &     0.03525D0,  0.04366D0,  0.05419D0,  0.06158D0,  0.06752D0,
     &     0.07261D0,  0.09150D0,  0.11703D0,  0.13641D0,  0.15292D0,
     &     0.16765D0,  0.19375D0,  0.22769D0,  0.27599D0,  0.31747D0,
     &     0.38599D0,  0.43964D0,  0.48105D0,  0.51822D0,  0.54152D0,
     &     0.55284D0,  0.55412D0,  0.54689D0,  0.53251D0,  0.51240D0,
     &     0.48756D0,  0.45925D0,  0.42833D0,  0.39563D0,  0.36202D0,
     &     0.32809D0,  0.29438D0,  0.26143D0,  0.22998D0,  0.19977D0,
     &     0.17155D0,  0.14553D0,  0.12155D0,  0.08091D0,  0.04976D0,
     &     0.02753D0,  0.01306D0,  0.00120D0,  0.00000D0/
      DATA (FMRS(1,1,I,14),I=1,49)/
     &     0.01759D0,  0.02179D0,  0.02699D0,  0.03059D0,  0.03343D0,
     &     0.03582D0,  0.04441D0,  0.05515D0,  0.06270D0,  0.06876D0,
     &     0.07397D0,  0.09331D0,  0.11948D0,  0.13933D0,  0.15621D0,
     &     0.17125D0,  0.19782D0,  0.23224D0,  0.28086D0,  0.32228D0,
     &     0.38998D0,  0.44216D0,  0.48181D0,  0.51649D0,  0.53727D0,
     &     0.54619D0,  0.54525D0,  0.53606D0,  0.52007D0,  0.49864D0,
     &     0.47286D0,  0.44390D0,  0.41261D0,  0.37987D0,  0.34645D0,
     &     0.31295D0,  0.27985D0,  0.24773D0,  0.21718D0,  0.18802D0,
     &     0.16091D0,  0.13605D0,  0.11323D0,  0.07479D0,  0.04562D0,
     &     0.02500D0,  0.01174D0,  0.00105D0,  0.00000D0/
      DATA (FMRS(1,1,I,15),I=1,49)/
     &     0.01784D0,  0.02212D0,  0.02742D0,  0.03109D0,  0.03399D0,
     &     0.03643D0,  0.04519D0,  0.05616D0,  0.06388D0,  0.07007D0,
     &     0.07541D0,  0.09522D0,  0.12203D0,  0.14235D0,  0.15961D0,
     &     0.17496D0,  0.20199D0,  0.23684D0,  0.28574D0,  0.32703D0,
     &     0.39374D0,  0.44435D0,  0.48208D0,  0.51422D0,  0.53243D0,
     &     0.53888D0,  0.53581D0,  0.52470D0,  0.50714D0,  0.48444D0,
     &     0.45778D0,  0.42824D0,  0.39670D0,  0.36400D0,  0.33079D0,
     &     0.29784D0,  0.26546D0,  0.23422D0,  0.20462D0,  0.17657D0,
     &     0.15056D0,  0.12684D0,  0.10517D0,  0.06893D0,  0.04169D0,
     &     0.02264D0,  0.01051D0,  0.00091D0,  0.00000D0/
      DATA (FMRS(1,1,I,16),I=1,49)/
     &     0.01807D0,  0.02243D0,  0.02782D0,  0.03155D0,  0.03450D0,
     &     0.03698D0,  0.04591D0,  0.05708D0,  0.06495D0,  0.07127D0,
     &     0.07672D0,  0.09696D0,  0.12435D0,  0.14510D0,  0.16268D0,
     &     0.17830D0,  0.20573D0,  0.24094D0,  0.29002D0,  0.33115D0,
     &     0.39689D0,  0.44603D0,  0.48202D0,  0.51185D0,  0.52778D0,
     &     0.53213D0,  0.52713D0,  0.51440D0,  0.49550D0,  0.47182D0,
     &     0.44444D0,  0.41444D0,  0.38277D0,  0.35014D0,  0.31726D0,
     &     0.28479D0,  0.25306D0,  0.22258D0,  0.19389D0,  0.16682D0,
     &     0.14175D0,  0.11905D0,  0.09839D0,  0.06403D0,  0.03844D0,
     &     0.02069D0,  0.00951D0,  0.00080D0,  0.00000D0/
      DATA (FMRS(1,1,I,17),I=1,49)/
     &     0.01831D0,  0.02273D0,  0.02822D0,  0.03202D0,  0.03502D0,
     &     0.03755D0,  0.04663D0,  0.05802D0,  0.06604D0,  0.07249D0,
     &     0.07805D0,  0.09872D0,  0.12670D0,  0.14787D0,  0.16578D0,
     &     0.18165D0,  0.20947D0,  0.24500D0,  0.29423D0,  0.33515D0,
     &     0.39986D0,  0.44747D0,  0.48171D0,  0.50924D0,  0.52291D0,
     &     0.52522D0,  0.51836D0,  0.50409D0,  0.48395D0,  0.45934D0,
     &     0.43132D0,  0.40095D0,  0.36919D0,  0.33668D0,  0.30419D0,
     &     0.27223D0,  0.24118D0,  0.21147D0,  0.18368D0,  0.15756D0,
     &     0.13343D0,  0.11172D0,  0.09203D0,  0.05947D0,  0.03543D0,
     &     0.01891D0,  0.00861D0,  0.00070D0,  0.00000D0/
      DATA (FMRS(1,1,I,18),I=1,49)/
     &     0.01851D0,  0.02299D0,  0.02855D0,  0.03241D0,  0.03546D0,
     &     0.03802D0,  0.04724D0,  0.05881D0,  0.06696D0,  0.07351D0,
     &     0.07917D0,  0.10019D0,  0.12865D0,  0.15015D0,  0.16833D0,
     &     0.18440D0,  0.21252D0,  0.24831D0,  0.29761D0,  0.33832D0,
     &     0.40212D0,  0.44845D0,  0.48121D0,  0.50687D0,  0.51871D0,
     &     0.51934D0,  0.51104D0,  0.49556D0,  0.47446D0,  0.44911D0,
     &     0.42066D0,  0.39005D0,  0.35822D0,  0.32587D0,  0.29370D0,
     &     0.26224D0,  0.23174D0,  0.20270D0,  0.17561D0,  0.15023D0,
     &     0.12693D0,  0.10599D0,  0.08707D0,  0.05595D0,  0.03312D0,
     &     0.01756D0,  0.00793D0,  0.00063D0,  0.00000D0/
      DATA (FMRS(1,1,I,19),I=1,49)/
     &     0.01875D0,  0.02330D0,  0.02896D0,  0.03288D0,  0.03599D0,
     &     0.03859D0,  0.04798D0,  0.05977D0,  0.06807D0,  0.07475D0,
     &     0.08052D0,  0.10198D0,  0.13101D0,  0.15292D0,  0.17139D0,
     &     0.18771D0,  0.21617D0,  0.25222D0,  0.30155D0,  0.34198D0,
     &     0.40461D0,  0.44935D0,  0.48033D0,  0.50374D0,  0.51343D0,
     &     0.51210D0,  0.50212D0,  0.48526D0,  0.46307D0,  0.43693D0,
     &     0.40797D0,  0.37715D0,  0.34533D0,  0.31321D0,  0.28148D0,
     &     0.25058D0,  0.22080D0,  0.19255D0,  0.16635D0,  0.14187D0,
     &     0.11948D0,  0.09946D0,  0.08142D0,  0.05198D0,  0.03054D0,
     &     0.01606D0,  0.00718D0,  0.00056D0,  0.00000D0/
      DATA (FMRS(1,1,I,20),I=1,49)/
     &     0.01896D0,  0.02358D0,  0.02932D0,  0.03331D0,  0.03646D0,
     &     0.03911D0,  0.04864D0,  0.06062D0,  0.06906D0,  0.07585D0,
     &     0.08173D0,  0.10357D0,  0.13310D0,  0.15536D0,  0.17410D0,
     &     0.19062D0,  0.21937D0,  0.25563D0,  0.30495D0,  0.34510D0,
     &     0.40666D0,  0.44998D0,  0.47941D0,  0.50085D0,  0.50868D0,
     &     0.50571D0,  0.49430D0,  0.47628D0,  0.45320D0,  0.42642D0,
     &     0.39707D0,  0.36611D0,  0.33435D0,  0.30245D0,  0.27113D0,
     &     0.24074D0,  0.21159D0,  0.18404D0,  0.15862D0,  0.13491D0,
     &     0.11330D0,  0.09405D0,  0.07676D0,  0.04872D0,  0.02844D0,
     &     0.01484D0,  0.00658D0,  0.00050D0,  0.00000D0/
      DATA (FMRS(1,1,I,21),I=1,49)/
     &     0.01916D0,  0.02384D0,  0.02966D0,  0.03370D0,  0.03689D0,
     &     0.03958D0,  0.04926D0,  0.06141D0,  0.06998D0,  0.07687D0,
     &     0.08284D0,  0.10503D0,  0.13502D0,  0.15758D0,  0.17655D0,
     &     0.19325D0,  0.22223D0,  0.25866D0,  0.30794D0,  0.34779D0,
     &     0.40831D0,  0.45032D0,  0.47832D0,  0.49795D0,  0.50413D0,
     &     0.49968D0,  0.48705D0,  0.46802D0,  0.44417D0,  0.41690D0,
     &     0.38723D0,  0.35619D0,  0.32452D0,  0.29287D0,  0.26194D0,
     &     0.23205D0,  0.20344D0,  0.17655D0,  0.15180D0,  0.12880D0,
     &     0.10792D0,  0.08934D0,  0.07273D0,  0.04591D0,  0.02665D0,
     &     0.01381D0,  0.00607D0,  0.00045D0,  0.00000D0/
      DATA (FMRS(1,1,I,22),I=1,49)/
     &     0.01941D0,  0.02417D0,  0.03009D0,  0.03420D0,  0.03745D0,
     &     0.04018D0,  0.05003D0,  0.06241D0,  0.07114D0,  0.07817D0,
     &     0.08426D0,  0.10688D0,  0.13744D0,  0.16039D0,  0.17965D0,
     &     0.19656D0,  0.22582D0,  0.26244D0,  0.31163D0,  0.35107D0,
     &     0.41025D0,  0.45056D0,  0.47676D0,  0.49416D0,  0.49829D0,
     &     0.49204D0,  0.47792D0,  0.45768D0,  0.43295D0,  0.40511D0,
     &     0.37512D0,  0.34401D0,  0.31250D0,  0.28120D0,  0.25076D0,
     &     0.22150D0,  0.19361D0,  0.16754D0,  0.14361D0,  0.12149D0,
     &     0.10149D0,  0.08376D0,  0.06796D0,  0.04260D0,  0.02455D0,
     &     0.01262D0,  0.00549D0,  0.00039D0,  0.00000D0/
      DATA (FMRS(1,1,I,23),I=1,49)/
     &     0.01965D0,  0.02448D0,  0.03049D0,  0.03467D0,  0.03797D0,
     &     0.04075D0,  0.05077D0,  0.06336D0,  0.07225D0,  0.07940D0,
     &     0.08560D0,  0.10863D0,  0.13972D0,  0.16302D0,  0.18254D0,
     &     0.19964D0,  0.22916D0,  0.26592D0,  0.31498D0,  0.35400D0,
     &     0.41189D0,  0.45060D0,  0.47511D0,  0.49045D0,  0.49274D0,
     &     0.48487D0,  0.46938D0,  0.44808D0,  0.42260D0,  0.39428D0,
     &     0.36409D0,  0.33294D0,  0.30164D0,  0.27069D0,  0.24070D0,
     &     0.21203D0,  0.18488D0,  0.15951D0,  0.13633D0,  0.11502D0,
     &     0.09581D0,  0.07887D0,  0.06380D0,  0.03974D0,  0.02273D0,
     &     0.01159D0,  0.00500D0,  0.00035D0,  0.00000D0/
      DATA (FMRS(1,1,I,24),I=1,49)/
     &     0.01987D0,  0.02478D0,  0.03088D0,  0.03511D0,  0.03847D0,
     &     0.04129D0,  0.05147D0,  0.06426D0,  0.07329D0,  0.08055D0,
     &     0.08686D0,  0.11027D0,  0.14184D0,  0.16546D0,  0.18521D0,
     &     0.20248D0,  0.23220D0,  0.26906D0,  0.31795D0,  0.35654D0,
     &     0.41317D0,  0.45035D0,  0.47330D0,  0.48677D0,  0.48734D0,
     &     0.47799D0,  0.46135D0,  0.43917D0,  0.41301D0,  0.38430D0,
     &     0.35392D0,  0.32282D0,  0.29171D0,  0.26113D0,  0.23164D0,
     &     0.20355D0,  0.17701D0,  0.15231D0,  0.12990D0,  0.10928D0,
     &     0.09079D0,  0.07455D0,  0.06012D0,  0.03723D0,  0.02116D0,
     &     0.01072D0,  0.00459D0,  0.00031D0,  0.00000D0/
      DATA (FMRS(1,1,I,25),I=1,49)/
     &     0.02010D0,  0.02507D0,  0.03126D0,  0.03556D0,  0.03897D0,
     &     0.04183D0,  0.05216D0,  0.06515D0,  0.07433D0,  0.08171D0,
     &     0.08812D0,  0.11191D0,  0.14397D0,  0.16790D0,  0.18786D0,
     &     0.20530D0,  0.23522D0,  0.27216D0,  0.32085D0,  0.35900D0,
     &     0.41434D0,  0.45001D0,  0.47142D0,  0.48304D0,  0.48197D0,
     &     0.47120D0,  0.45346D0,  0.43043D0,  0.40367D0,  0.37460D0,
     &     0.34407D0,  0.31306D0,  0.28215D0,  0.25197D0,  0.22296D0,
     &     0.19546D0,  0.16953D0,  0.14549D0,  0.12381D0,  0.10387D0,
     &     0.08608D0,  0.07049D0,  0.05669D0,  0.03490D0,  0.01971D0,
     &     0.00991D0,  0.00421D0,  0.00028D0,  0.00000D0/
      DATA (FMRS(1,1,I,26),I=1,49)/
     &     0.02032D0,  0.02536D0,  0.03164D0,  0.03600D0,  0.03946D0,
     &     0.04236D0,  0.05285D0,  0.06604D0,  0.07535D0,  0.08285D0,
     &     0.08936D0,  0.11352D0,  0.14603D0,  0.17026D0,  0.19043D0,
     &     0.20801D0,  0.23810D0,  0.27509D0,  0.32355D0,  0.36123D0,
     &     0.41527D0,  0.44945D0,  0.46936D0,  0.47919D0,  0.47657D0,
     &     0.46453D0,  0.44572D0,  0.42188D0,  0.39463D0,  0.36526D0,
     &     0.33462D0,  0.30373D0,  0.27307D0,  0.24328D0,  0.21472D0,
     &     0.18782D0,  0.16253D0,  0.13914D0,  0.11811D0,  0.09886D0,
     &     0.08171D0,  0.06673D0,  0.05353D0,  0.03277D0,  0.01840D0,
     &     0.00919D0,  0.00387D0,  0.00025D0,  0.00000D0/
      DATA (FMRS(1,1,I,27),I=1,49)/
     &     0.02054D0,  0.02564D0,  0.03200D0,  0.03642D0,  0.03992D0,
     &     0.04287D0,  0.05350D0,  0.06688D0,  0.07633D0,  0.08394D0,
     &     0.09053D0,  0.11504D0,  0.14798D0,  0.17249D0,  0.19284D0,
     &     0.21055D0,  0.24079D0,  0.27781D0,  0.32602D0,  0.36325D0,
     &     0.41604D0,  0.44883D0,  0.46732D0,  0.47551D0,  0.47145D0,
     &     0.45823D0,  0.43846D0,  0.41392D0,  0.38625D0,  0.35664D0,
     &     0.32595D0,  0.29518D0,  0.26477D0,  0.23536D0,  0.20725D0,
     &     0.18088D0,  0.15618D0,  0.13340D0,  0.11297D0,  0.09435D0,
     &     0.07779D0,  0.06337D0,  0.05071D0,  0.03088D0,  0.01724D0,
     &     0.00855D0,  0.00357D0,  0.00023D0,  0.00000D0/
      DATA (FMRS(1,1,I,28),I=1,49)/
     &     0.02074D0,  0.02591D0,  0.03234D0,  0.03682D0,  0.04037D0,
     &     0.04335D0,  0.05412D0,  0.06768D0,  0.07725D0,  0.08496D0,
     &     0.09165D0,  0.11648D0,  0.14982D0,  0.17457D0,  0.19509D0,
     &     0.21292D0,  0.24327D0,  0.28031D0,  0.32827D0,  0.36504D0,
     &     0.41665D0,  0.44811D0,  0.46527D0,  0.47196D0,  0.46656D0,
     &     0.45228D0,  0.43165D0,  0.40650D0,  0.37846D0,  0.34867D0,
     &     0.31800D0,  0.28733D0,  0.25718D0,  0.22812D0,  0.20048D0,
     &     0.17458D0,  0.15043D0,  0.12823D0,  0.10834D0,  0.09029D0,
     &     0.07427D0,  0.06037D0,  0.04820D0,  0.02920D0,  0.01621D0,
     &     0.00800D0,  0.00332D0,  0.00021D0,  0.00000D0/
      DATA (FMRS(1,1,I,29),I=1,49)/
     &     0.02094D0,  0.02617D0,  0.03269D0,  0.03722D0,  0.04081D0,
     &     0.04383D0,  0.05475D0,  0.06848D0,  0.07818D0,  0.08599D0,
     &     0.09277D0,  0.11792D0,  0.15165D0,  0.17664D0,  0.19733D0,
     &     0.21527D0,  0.24574D0,  0.28277D0,  0.33045D0,  0.36674D0,
     &     0.41715D0,  0.44728D0,  0.46313D0,  0.46834D0,  0.46164D0,
     &     0.44631D0,  0.42488D0,  0.39917D0,  0.37077D0,  0.34082D0,
     &     0.31017D0,  0.27964D0,  0.24978D0,  0.22107D0,  0.19390D0,
     &     0.16849D0,  0.14488D0,  0.12325D0,  0.10390D0,  0.08640D0,
     &     0.07092D0,  0.05751D0,  0.04581D0,  0.02761D0,  0.01524D0,
     &     0.00748D0,  0.00308D0,  0.00019D0,  0.00000D0/
      DATA (FMRS(1,1,I,30),I=1,49)/
     &     0.02115D0,  0.02644D0,  0.03303D0,  0.03762D0,  0.04125D0,
     &     0.04431D0,  0.05536D0,  0.06927D0,  0.07910D0,  0.08701D0,
     &     0.09387D0,  0.11934D0,  0.15345D0,  0.17867D0,  0.19951D0,
     &     0.21755D0,  0.24811D0,  0.28512D0,  0.33251D0,  0.36831D0,
     &     0.41752D0,  0.44634D0,  0.46092D0,  0.46470D0,  0.45678D0,
     &     0.44042D0,  0.41827D0,  0.39206D0,  0.36329D0,  0.33323D0,
     &     0.30260D0,  0.27226D0,  0.24270D0,  0.21435D0,  0.18761D0,
     &     0.16271D0,  0.13963D0,  0.11853D0,  0.09974D0,  0.08276D0,
     &     0.06777D0,  0.05484D0,  0.04358D0,  0.02615D0,  0.01436D0,
     &     0.00700D0,  0.00286D0,  0.00017D0,  0.00000D0/
      DATA (FMRS(1,1,I,31),I=1,49)/
     &     0.02134D0,  0.02669D0,  0.03336D0,  0.03800D0,  0.04168D0,
     &     0.04477D0,  0.05595D0,  0.07003D0,  0.07997D0,  0.08798D0,
     &     0.09492D0,  0.12069D0,  0.15515D0,  0.18059D0,  0.20157D0,
     &     0.21970D0,  0.25034D0,  0.28732D0,  0.33440D0,  0.36974D0,
     &     0.41780D0,  0.44538D0,  0.45878D0,  0.46121D0,  0.45216D0,
     &     0.43488D0,  0.41206D0,  0.38539D0,  0.35634D0,  0.32619D0,
     &     0.29560D0,  0.26544D0,  0.23618D0,  0.20818D0,  0.18185D0,
     &     0.15743D0,  0.13483D0,  0.11423D0,  0.09594D0,  0.07945D0,
     &     0.06492D0,  0.05243D0,  0.04157D0,  0.02483D0,  0.01357D0,
     &     0.00658D0,  0.00267D0,  0.00016D0,  0.00000D0/
      DATA (FMRS(1,1,I,32),I=1,49)/
     &     0.02153D0,  0.02693D0,  0.03367D0,  0.03836D0,  0.04208D0,
     &     0.04521D0,  0.05651D0,  0.07075D0,  0.08080D0,  0.08890D0,
     &     0.09592D0,  0.12197D0,  0.15676D0,  0.18239D0,  0.20349D0,
     &     0.22170D0,  0.25240D0,  0.28933D0,  0.33609D0,  0.37098D0,
     &     0.41793D0,  0.44434D0,  0.45663D0,  0.45780D0,  0.44772D0,
     &     0.42965D0,  0.40618D0,  0.37910D0,  0.34986D0,  0.31963D0,
     &     0.28912D0,  0.25913D0,  0.23015D0,  0.20249D0,  0.17658D0,
     &     0.15257D0,  0.13044D0,  0.11030D0,  0.09247D0,  0.07643D0,
     &     0.06234D0,  0.05026D0,  0.03976D0,  0.02365D0,  0.01287D0,
     &     0.00620D0,  0.00250D0,  0.00014D0,  0.00000D0/
      DATA (FMRS(1,1,I,33),I=1,49)/
     &     0.02171D0,  0.02717D0,  0.03398D0,  0.03872D0,  0.04248D0,
     &     0.04565D0,  0.05708D0,  0.07147D0,  0.08164D0,  0.08983D0,
     &     0.09693D0,  0.12326D0,  0.15838D0,  0.18421D0,  0.20543D0,
     &     0.22371D0,  0.25448D0,  0.29136D0,  0.33779D0,  0.37222D0,
     &     0.41806D0,  0.44331D0,  0.45449D0,  0.45441D0,  0.44330D0,
     &     0.42446D0,  0.40038D0,  0.37291D0,  0.34349D0,  0.31319D0,
     &     0.28277D0,  0.25295D0,  0.22427D0,  0.19695D0,  0.17145D0,
     &     0.14785D0,  0.12618D0,  0.10650D0,  0.08912D0,  0.07353D0,
     &     0.05986D0,  0.04817D0,  0.03803D0,  0.02252D0,  0.01220D0,
     &     0.00585D0,  0.00235D0,  0.00013D0,  0.00000D0/
      DATA (FMRS(1,1,I,34),I=1,49)/
     &     0.02190D0,  0.02741D0,  0.03429D0,  0.03909D0,  0.04289D0,
     &     0.04609D0,  0.05764D0,  0.07219D0,  0.08247D0,  0.09075D0,
     &     0.09793D0,  0.12453D0,  0.15996D0,  0.18597D0,  0.20731D0,
     &     0.22565D0,  0.25646D0,  0.29325D0,  0.33935D0,  0.37330D0,
     &     0.41800D0,  0.44209D0,  0.45219D0,  0.45092D0,  0.43883D0,
     &     0.41923D0,  0.39461D0,  0.36679D0,  0.33718D0,  0.30687D0,
     &     0.27654D0,  0.24693D0,  0.21853D0,  0.19159D0,  0.16650D0,
     &     0.14332D0,  0.12207D0,  0.10288D0,  0.08593D0,  0.07076D0,
     &     0.05749D0,  0.04618D0,  0.03639D0,  0.02146D0,  0.01157D0,
     &     0.00552D0,  0.00220D0,  0.00012D0,  0.00000D0/
      DATA (FMRS(1,1,I,35),I=1,49)/
     &     0.02208D0,  0.02764D0,  0.03459D0,  0.03943D0,  0.04327D0,
     &     0.04650D0,  0.05818D0,  0.07288D0,  0.08327D0,  0.09162D0,
     &     0.09888D0,  0.12574D0,  0.16147D0,  0.18765D0,  0.20909D0,
     &     0.22750D0,  0.25834D0,  0.29505D0,  0.34083D0,  0.37432D0,
     &     0.41794D0,  0.44094D0,  0.45002D0,  0.44763D0,  0.43463D0,
     &     0.41432D0,  0.38921D0,  0.36108D0,  0.33130D0,  0.30099D0,
     &     0.27077D0,  0.24136D0,  0.21322D0,  0.18665D0,  0.16193D0,
     &     0.13915D0,  0.11830D0,  0.09955D0,  0.08301D0,  0.06823D0,
     &     0.05533D0,  0.04437D0,  0.03490D0,  0.02050D0,  0.01100D0,
     &     0.00523D0,  0.00207D0,  0.00011D0,  0.00000D0/
      DATA (FMRS(1,1,I,36),I=1,49)/
     &     0.02225D0,  0.02787D0,  0.03488D0,  0.03977D0,  0.04364D0,
     &     0.04690D0,  0.05869D0,  0.07354D0,  0.08402D0,  0.09246D0,
     &     0.09978D0,  0.12689D0,  0.16290D0,  0.18924D0,  0.21077D0,
     &     0.22923D0,  0.26010D0,  0.29672D0,  0.34217D0,  0.37521D0,
     &     0.41781D0,  0.43978D0,  0.44789D0,  0.44447D0,  0.43062D0,
     &     0.40968D0,  0.38412D0,  0.35571D0,  0.32579D0,  0.29550D0,
     &     0.26538D0,  0.23618D0,  0.20831D0,  0.18206D0,  0.15771D0,
     &     0.13531D0,  0.11485D0,  0.09649D0,  0.08034D0,  0.06592D0,
     &     0.05337D0,  0.04272D0,  0.03354D0,  0.01963D0,  0.01049D0,
     &     0.00496D0,  0.00196D0,  0.00011D0,  0.00000D0/
      DATA (FMRS(1,1,I,37),I=1,49)/
     &     0.02242D0,  0.02809D0,  0.03517D0,  0.04010D0,  0.04401D0,
     &     0.04731D0,  0.05921D0,  0.07420D0,  0.08479D0,  0.09331D0,
     &     0.10070D0,  0.12805D0,  0.16433D0,  0.19082D0,  0.21245D0,
     &     0.23095D0,  0.26184D0,  0.29836D0,  0.34345D0,  0.37604D0,
     &     0.41760D0,  0.43853D0,  0.44568D0,  0.44123D0,  0.42654D0,
     &     0.40499D0,  0.37899D0,  0.35034D0,  0.32029D0,  0.29001D0,
     &     0.26003D0,  0.23104D0,  0.20345D0,  0.17752D0,  0.15354D0,
     &     0.13153D0,  0.11147D0,  0.09348D0,  0.07771D0,  0.06366D0,
     &     0.05147D0,  0.04112D0,  0.03222D0,  0.01879D0,  0.01000D0,
     &     0.00471D0,  0.00185D0,  0.00010D0,  0.00000D0/
      DATA (FMRS(1,1,I,38),I=1,49)/
     &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
     &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
     &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
     &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
     &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
     &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
     &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
     &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
     &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
     &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0/
      DATA (FMRS(1,2,I, 1),I=1,49)/
     &     0.00513D0,  0.00648D0,  0.00818D0,  0.00938D0,  0.01034D0,
     &     0.01116D0,  0.01418D0,  0.01818D0,  0.02118D0,  0.02372D0,
     &     0.02613D0,  0.03576D0,  0.05040D0,  0.06228D0,  0.07266D0,
     &     0.08202D0,  0.09864D0,  0.12002D0,  0.14955D0,  0.17387D0,
     &     0.21184D0,  0.23954D0,  0.25956D0,  0.27606D0,  0.28502D0,
     &     0.28790D0,  0.28586D0,  0.27985D0,  0.27060D0,  0.25918D0,
     &     0.24535D0,  0.23028D0,  0.21416D0,  0.19735D0,  0.18044D0,
     &     0.16347D0,  0.14671D0,  0.13049D0,  0.11512D0,  0.10018D0,
     &     0.08630D0,  0.07360D0,  0.06172D0,  0.04171D0,  0.02610D0,
     &     0.01478D0,  0.00721D0,  0.00074D0,  0.00000D0/
      DATA (FMRS(1,2,I, 2),I=1,49)/
     &     0.00518D0,  0.00654D0,  0.00828D0,  0.00950D0,  0.01049D0,
     &     0.01133D0,  0.01443D0,  0.01854D0,  0.02162D0,  0.02423D0,
     &     0.02670D0,  0.03657D0,  0.05155D0,  0.06366D0,  0.07421D0,
     &     0.08371D0,  0.10052D0,  0.12206D0,  0.15163D0,  0.17583D0,
     &     0.21329D0,  0.24028D0,  0.25950D0,  0.27498D0,  0.28295D0,
     &     0.28491D0,  0.28206D0,  0.27535D0,  0.26555D0,  0.25365D0,
     &     0.23952D0,  0.22423D0,  0.20802D0,  0.19123D0,  0.17441D0,
     &     0.15763D0,  0.14114D0,  0.12520D0,  0.11019D0,  0.09565D0,
     &     0.08218D0,  0.06990D0,  0.05847D0,  0.03927D0,  0.02442D0,
     &     0.01373D0,  0.00665D0,  0.00066D0,  0.00000D0/
      DATA (FMRS(1,2,I, 3),I=1,49)/
     &     0.00524D0,  0.00664D0,  0.00843D0,  0.00970D0,  0.01072D0,
     &     0.01159D0,  0.01481D0,  0.01908D0,  0.02229D0,  0.02501D0,
     &     0.02757D0,  0.03781D0,  0.05328D0,  0.06572D0,  0.07653D0,
     &     0.08622D0,  0.10330D0,  0.12505D0,  0.15465D0,  0.17864D0,
     &     0.21528D0,  0.24119D0,  0.25922D0,  0.27320D0,  0.27971D0,
     &     0.28035D0,  0.27635D0,  0.26864D0,  0.25807D0,  0.24551D0,
     &     0.23101D0,  0.21544D0,  0.19911D0,  0.18240D0,  0.16578D0,
     &     0.14929D0,  0.13320D0,  0.11772D0,  0.10322D0,  0.08926D0,
     &     0.07639D0,  0.06473D0,  0.05394D0,  0.03591D0,  0.02212D0,
     &     0.01231D0,  0.00589D0,  0.00057D0,  0.00000D0/
      DATA (FMRS(1,2,I, 4),I=1,49)/
     &     0.00529D0,  0.00672D0,  0.00855D0,  0.00985D0,  0.01090D0,
     &     0.01179D0,  0.01510D0,  0.01949D0,  0.02279D0,  0.02558D0,
     &     0.02822D0,  0.03873D0,  0.05456D0,  0.06724D0,  0.07823D0,
     &     0.08806D0,  0.10532D0,  0.12720D0,  0.15680D0,  0.18061D0,
     &     0.21663D0,  0.24172D0,  0.25888D0,  0.27177D0,  0.27723D0,
     &     0.27696D0,  0.27213D0,  0.26373D0,  0.25262D0,  0.23966D0,
     &     0.22489D0,  0.20919D0,  0.19281D0,  0.17616D0,  0.15968D0,
     &     0.14345D0,  0.12763D0,  0.11250D0,  0.09838D0,  0.08485D0,
     &     0.07242D0,  0.06118D0,  0.05083D0,  0.03363D0,  0.02058D0,
     &     0.01136D0,  0.00539D0,  0.00050D0,  0.00000D0/
      DATA (FMRS(1,2,I, 5),I=1,49)/
     &     0.00534D0,  0.00680D0,  0.00868D0,  0.01001D0,  0.01108D0,
     &     0.01200D0,  0.01540D0,  0.01993D0,  0.02332D0,  0.02620D0,
     &     0.02891D0,  0.03971D0,  0.05590D0,  0.06884D0,  0.08000D0,
     &     0.08997D0,  0.10741D0,  0.12941D0,  0.15897D0,  0.18257D0,
     &     0.21790D0,  0.24212D0,  0.25836D0,  0.27010D0,  0.27446D0,
     &     0.27326D0,  0.26762D0,  0.25853D0,  0.24692D0,  0.23356D0,
     &     0.21851D0,  0.20270D0,  0.18633D0,  0.16975D0,  0.15345D0,
     &     0.13751D0,  0.12199D0,  0.10721D0,  0.09351D0,  0.08043D0,
     &     0.06843D0,  0.05765D0,  0.04775D0,  0.03138D0,  0.01907D0,
     &     0.01045D0,  0.00491D0,  0.00045D0,  0.00000D0/
      DATA (FMRS(1,2,I, 6),I=1,49)/
     &     0.00539D0,  0.00688D0,  0.00879D0,  0.01015D0,  0.01125D0,
     &     0.01219D0,  0.01567D0,  0.02031D0,  0.02379D0,  0.02674D0,
     &     0.02951D0,  0.04056D0,  0.05708D0,  0.07022D0,  0.08154D0,
     &     0.09162D0,  0.10921D0,  0.13130D0,  0.16082D0,  0.18422D0,
     &     0.21894D0,  0.24239D0,  0.25783D0,  0.26859D0,  0.27204D0,
     &     0.27005D0,  0.26373D0,  0.25409D0,  0.24206D0,  0.22838D0,
     &     0.21313D0,  0.19724D0,  0.18088D0,  0.16440D0,  0.14826D0,
     &     0.13257D0,  0.11731D0,  0.10284D0,  0.08950D0,  0.07679D0,
     &     0.06517D0,  0.05477D0,  0.04524D0,  0.02956D0,  0.01786D0,
     &     0.00972D0,  0.00453D0,  0.00040D0,  0.00000D0/
      DATA (FMRS(1,2,I, 7),I=1,49)/
     &     0.00544D0,  0.00695D0,  0.00890D0,  0.01029D0,  0.01141D0,
     &     0.01237D0,  0.01593D0,  0.02068D0,  0.02425D0,  0.02727D0,
     &     0.03010D0,  0.04138D0,  0.05820D0,  0.07155D0,  0.08301D0,
     &     0.09319D0,  0.11091D0,  0.13308D0,  0.16253D0,  0.18572D0,
     &     0.21983D0,  0.24255D0,  0.25721D0,  0.26706D0,  0.26966D0,
     &     0.26692D0,  0.25996D0,  0.24983D0,  0.23740D0,  0.22344D0,
     &     0.20806D0,  0.19209D0,  0.17575D0,  0.15940D0,  0.14342D0,
     &     0.12794D0,  0.11298D0,  0.09881D0,  0.08579D0,  0.07344D0,
     &     0.06219D0,  0.05213D0,  0.04295D0,  0.02791D0,  0.01677D0,
     &     0.00906D0,  0.00419D0,  0.00037D0,  0.00000D0/
      DATA (FMRS(1,2,I, 8),I=1,49)/
     &     0.00549D0,  0.00703D0,  0.00902D0,  0.01044D0,  0.01159D0,
     &     0.01257D0,  0.01622D0,  0.02109D0,  0.02474D0,  0.02783D0,
     &     0.03073D0,  0.04227D0,  0.05940D0,  0.07296D0,  0.08456D0,
     &     0.09485D0,  0.11270D0,  0.13493D0,  0.16429D0,  0.18726D0,
     &     0.22070D0,  0.24263D0,  0.25647D0,  0.26535D0,  0.26707D0,
     &     0.26357D0,  0.25596D0,  0.24532D0,  0.23250D0,  0.21829D0,
     &     0.20276D0,  0.18675D0,  0.17045D0,  0.15424D0,  0.13845D0,
     &     0.12321D0,  0.10855D0,  0.09470D0,  0.08203D0,  0.07005D0,
     &     0.05917D0,  0.04947D0,  0.04065D0,  0.02627D0,  0.01569D0,
     &     0.00842D0,  0.00386D0,  0.00033D0,  0.00000D0/
      DATA (FMRS(1,2,I, 9),I=1,49)/
     &     0.00553D0,  0.00711D0,  0.00913D0,  0.01057D0,  0.01174D0,
     &     0.01274D0,  0.01647D0,  0.02144D0,  0.02517D0,  0.02833D0,
     &     0.03129D0,  0.04304D0,  0.06045D0,  0.07418D0,  0.08591D0,
     &     0.09629D0,  0.11425D0,  0.13653D0,  0.16579D0,  0.18855D0,
     &     0.22139D0,  0.24264D0,  0.25577D0,  0.26380D0,  0.26479D0,
     &     0.26063D0,  0.25250D0,  0.24142D0,  0.22830D0,  0.21390D0,
     &     0.19824D0,  0.18222D0,  0.16597D0,  0.14988D0,  0.13426D0,
     &     0.11924D0,  0.10484D0,  0.09128D0,  0.07889D0,  0.06724D0,
     &     0.05666D0,  0.04727D0,  0.03875D0,  0.02492D0,  0.01480D0,
     &     0.00790D0,  0.00360D0,  0.00030D0,  0.00000D0/
      DATA (FMRS(1,2,I,10),I=1,49)/
     &     0.00558D0,  0.00718D0,  0.00923D0,  0.01071D0,  0.01190D0,
     &     0.01291D0,  0.01671D0,  0.02178D0,  0.02559D0,  0.02881D0,
     &     0.03183D0,  0.04379D0,  0.06146D0,  0.07536D0,  0.08720D0,
     &     0.09766D0,  0.11571D0,  0.13802D0,  0.16719D0,  0.18973D0,
     &     0.22198D0,  0.24256D0,  0.25502D0,  0.26225D0,  0.26252D0,
     &     0.25776D0,  0.24914D0,  0.23766D0,  0.22428D0,  0.20968D0,
     &     0.19393D0,  0.17791D0,  0.16173D0,  0.14575D0,  0.13032D0,
     &     0.11552D0,  0.10136D0,  0.08807D0,  0.07596D0,  0.06462D0,
     &     0.05433D0,  0.04524D0,  0.03701D0,  0.02369D0,  0.01400D0,
     &     0.00743D0,  0.00336D0,  0.00028D0,  0.00000D0/
      DATA (FMRS(1,2,I,11),I=1,49)/
     &     0.00562D0,  0.00723D0,  0.00932D0,  0.01081D0,  0.01202D0,
     &     0.01305D0,  0.01691D0,  0.02206D0,  0.02593D0,  0.02920D0,
     &     0.03226D0,  0.04438D0,  0.06226D0,  0.07629D0,  0.08822D0,
     &     0.09874D0,  0.11687D0,  0.13920D0,  0.16827D0,  0.19064D0,
     &     0.22242D0,  0.24246D0,  0.25439D0,  0.26100D0,  0.26071D0,
     &     0.25548D0,  0.24648D0,  0.23472D0,  0.22112D0,  0.20638D0,
     &     0.19059D0,  0.17454D0,  0.15845D0,  0.14257D0,  0.12728D0,
     &     0.11265D0,  0.09869D0,  0.08561D0,  0.07373D0,  0.06261D0,
     &     0.05256D0,  0.04369D0,  0.03568D0,  0.02275D0,  0.01339D0,
     &     0.00707D0,  0.00318D0,  0.00026D0,  0.00000D0/
      DATA (FMRS(1,2,I,12),I=1,49)/
     &     0.00570D0,  0.00736D0,  0.00950D0,  0.01104D0,  0.01228D0,
     &     0.01335D0,  0.01733D0,  0.02266D0,  0.02665D0,  0.03003D0,
     &     0.03319D0,  0.04566D0,  0.06397D0,  0.07827D0,  0.09038D0,
     &     0.10102D0,  0.11928D0,  0.14164D0,  0.17050D0,  0.19247D0,
     &     0.22321D0,  0.24211D0,  0.25293D0,  0.25822D0,  0.25677D0,
     &     0.25059D0,  0.24082D0,  0.22847D0,  0.21448D0,  0.19945D0,
     &     0.18361D0,  0.16759D0,  0.15163D0,  0.13598D0,  0.12100D0,
     &     0.10676D0,  0.09321D0,  0.08058D0,  0.06917D0,  0.05856D0,
     &     0.04898D0,  0.04057D0,  0.03301D0,  0.02089D0,  0.01219D0,
     &     0.00638D0,  0.00284D0,  0.00022D0,  0.00000D0/
      DATA (FMRS(1,2,I,13),I=1,49)/
     &     0.00578D0,  0.00747D0,  0.00966D0,  0.01124D0,  0.01252D0,
     &     0.01361D0,  0.01770D0,  0.02318D0,  0.02729D0,  0.03076D0,
     &     0.03400D0,  0.04677D0,  0.06545D0,  0.07997D0,  0.09223D0,
     &     0.10297D0,  0.12133D0,  0.14370D0,  0.17234D0,  0.19395D0,
     &     0.22379D0,  0.24170D0,  0.25156D0,  0.25575D0,  0.25334D0,
     &     0.24638D0,  0.23598D0,  0.22317D0,  0.20887D0,  0.19364D0,
     &     0.17776D0,  0.16180D0,  0.14597D0,  0.13054D0,  0.11583D0,
     &     0.10193D0,  0.08873D0,  0.07648D0,  0.06548D0,  0.05529D0,
     &     0.04609D0,  0.03806D0,  0.03088D0,  0.01941D0,  0.01124D0,
     &     0.00583D0,  0.00257D0,  0.00020D0,  0.00000D0/
      DATA (FMRS(1,2,I,14),I=1,49)/
     &     0.00586D0,  0.00760D0,  0.00985D0,  0.01147D0,  0.01278D0,
     &     0.01391D0,  0.01812D0,  0.02377D0,  0.02801D0,  0.03158D0,
     &     0.03491D0,  0.04802D0,  0.06710D0,  0.08186D0,  0.09428D0,
     &     0.10512D0,  0.12358D0,  0.14593D0,  0.17430D0,  0.19551D0,
     &     0.22431D0,  0.24113D0,  0.24990D0,  0.25292D0,  0.24948D0,
     &     0.24168D0,  0.23063D0,  0.21737D0,  0.20273D0,  0.18735D0,
     &     0.17142D0,  0.15550D0,  0.13986D0,  0.12470D0,  0.11033D0,
     &     0.09680D0,  0.08400D0,  0.07217D0,  0.06162D0,  0.05183D0,
     &     0.04308D0,  0.03546D0,  0.02866D0,  0.01788D0,  0.01027D0,
     &     0.00528D0,  0.00231D0,  0.00017D0,  0.00000D0/
      DATA (FMRS(1,2,I,15),I=1,49)/
     &     0.00596D0,  0.00773D0,  0.01005D0,  0.01171D0,  0.01307D0,
     &     0.01423D0,  0.01857D0,  0.02439D0,  0.02876D0,  0.03244D0,
     &     0.03586D0,  0.04932D0,  0.06880D0,  0.08380D0,  0.09637D0,
     &     0.10730D0,  0.12584D0,  0.14815D0,  0.17622D0,  0.19694D0,
     &     0.22466D0,  0.24034D0,  0.24804D0,  0.24983D0,  0.24536D0,
     &     0.23677D0,  0.22506D0,  0.21136D0,  0.19645D0,  0.18096D0,
     &     0.16500D0,  0.14922D0,  0.13378D0,  0.11890D0,  0.10488D0,
     &     0.09171D0,  0.07933D0,  0.06793D0,  0.05781D0,  0.04848D0,
     &     0.04016D0,  0.03293D0,  0.02652D0,  0.01642D0,  0.00936D0,
     &     0.00477D0,  0.00206D0,  0.00015D0,  0.00000D0/
      DATA (FMRS(1,2,I,16),I=1,49)/
     &     0.00604D0,  0.00786D0,  0.01023D0,  0.01194D0,  0.01333D0,
     &     0.01452D0,  0.01898D0,  0.02497D0,  0.02945D0,  0.03323D0,
     &     0.03674D0,  0.05050D0,  0.07034D0,  0.08554D0,  0.09824D0,
     &     0.10925D0,  0.12785D0,  0.15009D0,  0.17786D0,  0.19815D0,
     &     0.22486D0,  0.23952D0,  0.24625D0,  0.24698D0,  0.24163D0,
     &     0.23233D0,  0.22009D0,  0.20603D0,  0.19091D0,  0.17529D0,
     &     0.15938D0,  0.14374D0,  0.12849D0,  0.11388D0,  0.10016D0,
     &     0.08733D0,  0.07533D0,  0.06433D0,  0.05458D0,  0.04564D0,
     &     0.03769D0,  0.03082D0,  0.02473D0,  0.01521D0,  0.00860D0,
     &     0.00435D0,  0.00186D0,  0.00013D0,  0.00000D0/
      DATA (FMRS(1,2,I,17),I=1,49)/
     &     0.00614D0,  0.00799D0,  0.01042D0,  0.01217D0,  0.01359D0,
     &     0.01482D0,  0.01940D0,  0.02555D0,  0.03016D0,  0.03404D0,
     &     0.03763D0,  0.05170D0,  0.07188D0,  0.08729D0,  0.10010D0,
     &     0.11119D0,  0.12983D0,  0.15200D0,  0.17943D0,  0.19928D0,
     &     0.22497D0,  0.23860D0,  0.24438D0,  0.24406D0,  0.23786D0,
     &     0.22788D0,  0.21517D0,  0.20077D0,  0.18546D0,  0.16976D0,
     &     0.15392D0,  0.13841D0,  0.12338D0,  0.10905D0,  0.09563D0,
     &     0.08314D0,  0.07152D0,  0.06090D0,  0.05152D0,  0.04295D0,
     &     0.03537D0,  0.02883D0,  0.02306D0,  0.01409D0,  0.00791D0,
     &     0.00396D0,  0.00168D0,  0.00011D0,  0.00000D0/
      DATA (FMRS(1,2,I,18),I=1,49)/
     &     0.00621D0,  0.00810D0,  0.01058D0,  0.01236D0,  0.01382D0,
     &     0.01507D0,  0.01975D0,  0.02604D0,  0.03075D0,  0.03471D0,
     &     0.03837D0,  0.05269D0,  0.07316D0,  0.08872D0,  0.10163D0,
     &     0.11277D0,  0.13143D0,  0.15352D0,  0.18066D0,  0.20012D0,
     &     0.22496D0,  0.23774D0,  0.24276D0,  0.24159D0,  0.23471D0,
     &     0.22421D0,  0.21113D0,  0.19645D0,  0.18102D0,  0.16532D0,
     &     0.14952D0,  0.13412D0,  0.11930D0,  0.10519D0,  0.09201D0,
     &     0.07983D0,  0.06850D0,  0.05818D0,  0.04914D0,  0.04085D0,
     &     0.03356D0,  0.02728D0,  0.02176D0,  0.01322D0,  0.00738D0,
     &     0.00367D0,  0.00154D0,  0.00010D0,  0.00000D0/
      DATA (FMRS(1,2,I,19),I=1,49)/
     &     0.00631D0,  0.00824D0,  0.01077D0,  0.01261D0,  0.01410D0,
     &     0.01538D0,  0.02018D0,  0.02663D0,  0.03146D0,  0.03553D0,
     &     0.03927D0,  0.05390D0,  0.07469D0,  0.09044D0,  0.10345D0,
     &     0.11464D0,  0.13332D0,  0.15529D0,  0.18206D0,  0.20106D0,
     &     0.22486D0,  0.23661D0,  0.24071D0,  0.23855D0,  0.23089D0,
     &     0.21978D0,  0.20626D0,  0.19133D0,  0.17575D0,  0.16006D0,
     &     0.14433D0,  0.12911D0,  0.11452D0,  0.10069D0,  0.08783D0,
     &     0.07600D0,  0.06503D0,  0.05507D0,  0.04638D0,  0.03845D0,
     &     0.03149D0,  0.02552D0,  0.02030D0,  0.01225D0,  0.00679D0,
     &     0.00335D0,  0.00139D0,  0.00009D0,  0.00000D0/
      DATA (FMRS(1,2,I,20),I=1,49)/
     &     0.00640D0,  0.00837D0,  0.01095D0,  0.01282D0,  0.01434D0,
     &     0.01565D0,  0.02057D0,  0.02717D0,  0.03210D0,  0.03625D0,
     &     0.04007D0,  0.05496D0,  0.07605D0,  0.09195D0,  0.10504D0,
     &     0.11628D0,  0.13496D0,  0.15682D0,  0.18325D0,  0.20182D0,
     &     0.22471D0,  0.23557D0,  0.23887D0,  0.23587D0,  0.22753D0,
     &     0.21592D0,  0.20204D0,  0.18691D0,  0.17123D0,  0.15556D0,
     &     0.13990D0,  0.12485D0,  0.11047D0,  0.09690D0,  0.08432D0,
     &     0.07279D0,  0.06213D0,  0.05248D0,  0.04407D0,  0.03646D0,
     &     0.02978D0,  0.02408D0,  0.01910D0,  0.01145D0,  0.00631D0,
     &     0.00309D0,  0.00127D0,  0.00008D0,  0.00000D0/
      DATA (FMRS(1,2,I,21),I=1,49)/
     &     0.00648D0,  0.00848D0,  0.01111D0,  0.01302D0,  0.01457D0,
     &     0.01591D0,  0.02092D0,  0.02766D0,  0.03269D0,  0.03692D0,
     &     0.04081D0,  0.05593D0,  0.07728D0,  0.09331D0,  0.10647D0,
     &     0.11774D0,  0.13641D0,  0.15816D0,  0.18425D0,  0.20243D0,
     &     0.22446D0,  0.23452D0,  0.23710D0,  0.23336D0,  0.22443D0,
     &     0.21239D0,  0.19820D0,  0.18290D0,  0.16716D0,  0.15148D0,
     &     0.13595D0,  0.12104D0,  0.10685D0,  0.09353D0,  0.08121D0,
     &     0.06995D0,  0.05958D0,  0.05021D0,  0.04207D0,  0.03472D0,
     &     0.02829D0,  0.02282D0,  0.01806D0,  0.01077D0,  0.00590D0,
     &     0.00287D0,  0.00118D0,  0.00007D0,  0.00000D0/
      DATA (FMRS(1,2,I,22),I=1,49)/
     &     0.00659D0,  0.00863D0,  0.01133D0,  0.01328D0,  0.01487D0,
     &     0.01624D0,  0.02138D0,  0.02828D0,  0.03345D0,  0.03777D0,
     &     0.04174D0,  0.05717D0,  0.07882D0,  0.09501D0,  0.10826D0,
     &     0.11956D0,  0.13822D0,  0.15980D0,  0.18547D0,  0.20313D0,
     &     0.22408D0,  0.23313D0,  0.23482D0,  0.23017D0,  0.22053D0,
     &     0.20797D0,  0.19344D0,  0.17794D0,  0.16215D0,  0.14650D0,
     &     0.13110D0,  0.11639D0,  0.10245D0,  0.08944D0,  0.07745D0,
     &     0.06653D0,  0.05651D0,  0.04748D0,  0.03968D0,  0.03265D0,
     &     0.02652D0,  0.02133D0,  0.01682D0,  0.00997D0,  0.00542D0,
     &     0.00262D0,  0.00106D0,  0.00006D0,  0.00000D0/
      DATA (FMRS(1,2,I,23),I=1,49)/
     &     0.00669D0,  0.00878D0,  0.01153D0,  0.01352D0,  0.01515D0,
     &     0.01655D0,  0.02181D0,  0.02888D0,  0.03416D0,  0.03858D0,
     &     0.04263D0,  0.05833D0,  0.08027D0,  0.09661D0,  0.10992D0,
     &     0.12125D0,  0.13987D0,  0.16129D0,  0.18654D0,  0.20370D0,
     &     0.22365D0,  0.23178D0,  0.23266D0,  0.22717D0,  0.21689D0,
     &     0.20387D0,  0.18906D0,  0.17340D0,  0.15758D0,  0.14198D0,
     &     0.12670D0,  0.11220D0,  0.09851D0,  0.08577D0,  0.07408D0,
     &     0.06350D0,  0.05377D0,  0.04507D0,  0.03757D0,  0.03084D0,
     &     0.02497D0,  0.02003D0,  0.01574D0,  0.00927D0,  0.00500D0,
     &     0.00240D0,  0.00096D0,  0.00006D0,  0.00000D0/
      DATA (FMRS(1,2,I,24),I=1,49)/
     &     0.00679D0,  0.00892D0,  0.01172D0,  0.01376D0,  0.01542D0,
     &     0.01685D0,  0.02222D0,  0.02944D0,  0.03483D0,  0.03934D0,
     &     0.04345D0,  0.05941D0,  0.08161D0,  0.09806D0,  0.11144D0,
     &     0.12278D0,  0.14136D0,  0.16260D0,  0.18745D0,  0.20414D0,
     &     0.22314D0,  0.23041D0,  0.23054D0,  0.22429D0,  0.21345D0,
     &     0.20006D0,  0.18498D0,  0.16918D0,  0.15336D0,  0.13783D0,
     &     0.12271D0,  0.10840D0,  0.09494D0,  0.08246D0,  0.07106D0,
     &     0.06075D0,  0.05132D0,  0.04292D0,  0.03570D0,  0.02922D0,
     &     0.02361D0,  0.01888D0,  0.01480D0,  0.00867D0,  0.00465D0,
     &     0.00221D0,  0.00088D0,  0.00005D0,  0.00000D0/
      DATA (FMRS(1,2,I,25),I=1,49)/
     &     0.00689D0,  0.00906D0,  0.01192D0,  0.01399D0,  0.01569D0,
     &     0.01715D0,  0.02264D0,  0.03000D0,  0.03550D0,  0.04009D0,
     &     0.04429D0,  0.06049D0,  0.08294D0,  0.09952D0,  0.11294D0,
     &     0.12429D0,  0.14282D0,  0.16389D0,  0.18832D0,  0.20454D0,
     &     0.22261D0,  0.22902D0,  0.22843D0,  0.22145D0,  0.21007D0,
     &     0.19632D0,  0.18101D0,  0.16509D0,  0.14928D0,  0.13382D0,
     &     0.11886D0,  0.10475D0,  0.09153D0,  0.07931D0,  0.06819D0,
     &     0.05815D0,  0.04900D0,  0.04089D0,  0.03393D0,  0.02770D0,
     &     0.02232D0,  0.01781D0,  0.01392D0,  0.00811D0,  0.00432D0,
     &     0.00204D0,  0.00081D0,  0.00004D0,  0.00000D0/
      DATA (FMRS(1,2,I,26),I=1,49)/
     &     0.00699D0,  0.00920D0,  0.01211D0,  0.01423D0,  0.01596D0,
     &     0.01744D0,  0.02304D0,  0.03056D0,  0.03616D0,  0.04084D0,
     &     0.04510D0,  0.06154D0,  0.08423D0,  0.10091D0,  0.11437D0,
     &     0.12573D0,  0.14419D0,  0.16508D0,  0.18909D0,  0.20485D0,
     &     0.22201D0,  0.22760D0,  0.22631D0,  0.21867D0,  0.20676D0,
     &     0.19266D0,  0.17717D0,  0.16120D0,  0.14536D0,  0.12999D0,
     &     0.11520D0,  0.10128D0,  0.08831D0,  0.07633D0,  0.06548D0,
     &     0.05572D0,  0.04685D0,  0.03900D0,  0.03228D0,  0.02629D0,
     &     0.02113D0,  0.01682D0,  0.01311D0,  0.00760D0,  0.00403D0,
     &     0.00189D0,  0.00074D0,  0.00004D0,  0.00000D0/
      DATA (FMRS(1,2,I,27),I=1,49)/
     &     0.00708D0,  0.00933D0,  0.01230D0,  0.01445D0,  0.01621D0,
     &     0.01773D0,  0.02343D0,  0.03108D0,  0.03678D0,  0.04155D0,
     &     0.04587D0,  0.06253D0,  0.08544D0,  0.10221D0,  0.11571D0,
     &     0.12707D0,  0.14546D0,  0.16617D0,  0.18977D0,  0.20509D0,
     &     0.22139D0,  0.22623D0,  0.22430D0,  0.21604D0,  0.20367D0,
     &     0.18926D0,  0.17361D0,  0.15759D0,  0.14176D0,  0.12648D0,
     &     0.11185D0,  0.09812D0,  0.08537D0,  0.07364D0,  0.06303D0,
     &     0.05352D0,  0.04490D0,  0.03729D0,  0.03081D0,  0.02503D0,
     &     0.02007D0,  0.01594D0,  0.01240D0,  0.00714D0,  0.00376D0,
     &     0.00176D0,  0.00068D0,  0.00004D0,  0.00000D0/
      DATA (FMRS(1,2,I,28),I=1,49)/
     &     0.00718D0,  0.00946D0,  0.01247D0,  0.01467D0,  0.01646D0,
     &     0.01800D0,  0.02380D0,  0.03158D0,  0.03738D0,  0.04221D0,
     &     0.04660D0,  0.06346D0,  0.08657D0,  0.10342D0,  0.11695D0,
     &     0.12830D0,  0.14663D0,  0.16715D0,  0.19037D0,  0.20527D0,
     &     0.22075D0,  0.22489D0,  0.22237D0,  0.21353D0,  0.20079D0,
     &     0.18610D0,  0.17031D0,  0.15425D0,  0.13844D0,  0.12326D0,
     &     0.10877D0,  0.09523D0,  0.08268D0,  0.07119D0,  0.06080D0,
     &     0.05153D0,  0.04314D0,  0.03575D0,  0.02948D0,  0.02390D0,
     &     0.01913D0,  0.01516D0,  0.01177D0,  0.00675D0,  0.00353D0,
     &     0.00164D0,  0.00063D0,  0.00003D0,  0.00000D0/
      DATA (FMRS(1,2,I,29),I=1,49)/
     &     0.00727D0,  0.00959D0,  0.01265D0,  0.01488D0,  0.01670D0,
     &     0.01827D0,  0.02417D0,  0.03208D0,  0.03797D0,  0.04288D0,
     &     0.04733D0,  0.06440D0,  0.08769D0,  0.10463D0,  0.11818D0,
     &     0.12952D0,  0.14777D0,  0.16810D0,  0.19092D0,  0.20540D0,
     &     0.22008D0,  0.22352D0,  0.22043D0,  0.21103D0,  0.19791D0,
     &     0.18297D0,  0.16705D0,  0.15095D0,  0.13519D0,  0.12011D0,
     &     0.10577D0,  0.09241D0,  0.08008D0,  0.06881D0,  0.05866D0,
     &     0.04961D0,  0.04145D0,  0.03427D0,  0.02822D0,  0.02282D0,
     &     0.01822D0,  0.01441D0,  0.01116D0,  0.00637D0,  0.00332D0,
     &     0.00153D0,  0.00059D0,  0.00003D0,  0.00000D0/
      DATA (FMRS(1,2,I,30),I=1,49)/
     &     0.00737D0,  0.00972D0,  0.01283D0,  0.01510D0,  0.01695D0,
     &     0.01854D0,  0.02454D0,  0.03258D0,  0.03856D0,  0.04354D0,
     &     0.04805D0,  0.06532D0,  0.08879D0,  0.10580D0,  0.11936D0,
     &     0.13069D0,  0.14886D0,  0.16900D0,  0.19141D0,  0.20548D0,
     &     0.21937D0,  0.22213D0,  0.21850D0,  0.20855D0,  0.19507D0,
     &     0.17994D0,  0.16388D0,  0.14775D0,  0.13208D0,  0.11709D0,
     &     0.10291D0,  0.08973D0,  0.07760D0,  0.06655D0,  0.05664D0,
     &     0.04779D0,  0.03985D0,  0.03289D0,  0.02702D0,  0.02182D0,
     &     0.01738D0,  0.01372D0,  0.01060D0,  0.00602D0,  0.00312D0,
     &     0.00143D0,  0.00055D0,  0.00003D0,  0.00000D0/
      DATA (FMRS(1,2,I,31),I=1,49)/
     &     0.00746D0,  0.00985D0,  0.01300D0,  0.01530D0,  0.01718D0,
     &     0.01880D0,  0.02489D0,  0.03306D0,  0.03912D0,  0.04417D0,
     &     0.04873D0,  0.06619D0,  0.08983D0,  0.10690D0,  0.12048D0,
     &     0.13179D0,  0.14987D0,  0.16982D0,  0.19186D0,  0.20553D0,
     &     0.21868D0,  0.22081D0,  0.21666D0,  0.20623D0,  0.19242D0,
     &     0.17710D0,  0.16093D0,  0.14478D0,  0.12919D0,  0.11430D0,
     &     0.10026D0,  0.08726D0,  0.07533D0,  0.06447D0,  0.05479D0,
     &     0.04614D0,  0.03840D0,  0.03163D0,  0.02594D0,  0.02091D0,
     &     0.01662D0,  0.01309D0,  0.01009D0,  0.00571D0,  0.00295D0,
     &     0.00134D0,  0.00051D0,  0.00003D0,  0.00000D0/
      DATA (FMRS(1,2,I,32),I=1,49)/
     &     0.00755D0,  0.00997D0,  0.01317D0,  0.01550D0,  0.01741D0,
     &     0.01905D0,  0.02522D0,  0.03351D0,  0.03966D0,  0.04477D0,
     &     0.04938D0,  0.06700D0,  0.09079D0,  0.10792D0,  0.12151D0,
     &     0.13280D0,  0.15080D0,  0.17056D0,  0.19223D0,  0.20552D0,
     &     0.21797D0,  0.21951D0,  0.21489D0,  0.20403D0,  0.18991D0,
     &     0.17441D0,  0.15817D0,  0.14202D0,  0.12646D0,  0.11170D0,
     &     0.09780D0,  0.08498D0,  0.07322D0,  0.06257D0,  0.05306D0,
     &     0.04463D0,  0.03708D0,  0.03049D0,  0.02496D0,  0.02008D0,
     &     0.01594D0,  0.01252D0,  0.00963D0,  0.00542D0,  0.00279D0,
     &     0.00126D0,  0.00048D0,  0.00002D0,  0.00000D0/
      DATA (FMRS(1,2,I,33),I=1,49)/
     &     0.00764D0,  0.01009D0,  0.01333D0,  0.01570D0,  0.01763D0,
     &     0.01930D0,  0.02556D0,  0.03396D0,  0.04019D0,  0.04537D0,
     &     0.05004D0,  0.06783D0,  0.09177D0,  0.10895D0,  0.12254D0,
     &     0.13381D0,  0.15173D0,  0.17130D0,  0.19261D0,  0.20552D0,
     &     0.21726D0,  0.21822D0,  0.21313D0,  0.20185D0,  0.18743D0,
     &     0.17175D0,  0.15545D0,  0.13931D0,  0.12379D0,  0.10917D0,
     &     0.09540D0,  0.08276D0,  0.07118D0,  0.06072D0,  0.05139D0,
     &     0.04317D0,  0.03581D0,  0.02938D0,  0.02402D0,  0.01929D0,
     &     0.01528D0,  0.01198D0,  0.00920D0,  0.00516D0,  0.00264D0,
     &     0.00119D0,  0.00045D0,  0.00002D0,  0.00000D0/
      DATA (FMRS(1,2,I,34),I=1,49)/
     &     0.00773D0,  0.01021D0,  0.01350D0,  0.01590D0,  0.01786D0,
     &     0.01955D0,  0.02590D0,  0.03441D0,  0.04072D0,  0.04597D0,
     &     0.05068D0,  0.06863D0,  0.09272D0,  0.10994D0,  0.12353D0,
     &     0.13477D0,  0.15260D0,  0.17197D0,  0.19290D0,  0.20543D0,
     &     0.21649D0,  0.21688D0,  0.21134D0,  0.19965D0,  0.18497D0,
     &     0.16913D0,  0.15278D0,  0.13665D0,  0.12121D0,  0.10669D0,
     &     0.09308D0,  0.08060D0,  0.06921D0,  0.05894D0,  0.04980D0,
     &     0.04176D0,  0.03458D0,  0.02833D0,  0.02311D0,  0.01853D0,
     &     0.01465D0,  0.01147D0,  0.00879D0,  0.00491D0,  0.00250D0,
     &     0.00112D0,  0.00042D0,  0.00002D0,  0.00000D0/
      DATA (FMRS(1,2,I,35),I=1,49)/
     &     0.00781D0,  0.01033D0,  0.01366D0,  0.01609D0,  0.01808D0,
     &     0.01979D0,  0.02622D0,  0.03484D0,  0.04123D0,  0.04653D0,
     &     0.05129D0,  0.06941D0,  0.09362D0,  0.11088D0,  0.12448D0,
     &     0.13569D0,  0.15342D0,  0.17260D0,  0.19318D0,  0.20535D0,
     &     0.21576D0,  0.21562D0,  0.20966D0,  0.19759D0,  0.18266D0,
     &     0.16668D0,  0.15028D0,  0.13418D0,  0.11882D0,  0.10439D0,
     &     0.09094D0,  0.07861D0,  0.06739D0,  0.05729D0,  0.04834D0,
     &     0.04048D0,  0.03346D0,  0.02736D0,  0.02228D0,  0.01784D0,
     &     0.01408D0,  0.01100D0,  0.00842D0,  0.00468D0,  0.00237D0,
     &     0.00106D0,  0.00039D0,  0.00002D0,  0.00000D0/
      DATA (FMRS(1,2,I,36),I=1,49)/
     &     0.00790D0,  0.01044D0,  0.01382D0,  0.01628D0,  0.01829D0,
     &     0.02002D0,  0.02653D0,  0.03525D0,  0.04172D0,  0.04707D0,
     &     0.05188D0,  0.07013D0,  0.09447D0,  0.11177D0,  0.12535D0,
     &     0.13654D0,  0.15418D0,  0.17318D0,  0.19341D0,  0.20524D0,
     &     0.21505D0,  0.21440D0,  0.20805D0,  0.19563D0,  0.18048D0,
     &     0.16438D0,  0.14795D0,  0.13186D0,  0.11657D0,  0.10226D0,
     &     0.08894D0,  0.07676D0,  0.06571D0,  0.05578D0,  0.04700D0,
     &     0.03929D0,  0.03242D0,  0.02648D0,  0.02153D0,  0.01720D0,
     &     0.01356D0,  0.01058D0,  0.00808D0,  0.00448D0,  0.00226D0,
     &     0.00101D0,  0.00037D0,  0.00002D0,  0.00000D0/
      DATA (FMRS(1,2,I,37),I=1,49)/
     &     0.00798D0,  0.01056D0,  0.01397D0,  0.01646D0,  0.01850D0,
     &     0.02025D0,  0.02684D0,  0.03567D0,  0.04221D0,  0.04762D0,
     &     0.05247D0,  0.07087D0,  0.09532D0,  0.11265D0,  0.12622D0,
     &     0.13738D0,  0.15492D0,  0.17373D0,  0.19361D0,  0.20510D0,
     &     0.21429D0,  0.21315D0,  0.20641D0,  0.19365D0,  0.17829D0,
     &     0.16207D0,  0.14561D0,  0.12954D0,  0.11434D0,  0.10013D0,
     &     0.08696D0,  0.07493D0,  0.06406D0,  0.05429D0,  0.04567D0,
     &     0.03812D0,  0.03141D0,  0.02561D0,  0.02079D0,  0.01659D0,
     &     0.01305D0,  0.01017D0,  0.00775D0,  0.00428D0,  0.00215D0,
     &     0.00095D0,  0.00035D0,  0.00002D0,  0.00000D0/
      DATA (FMRS(1,2,I,38),I=1,49)/
     &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
     &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
     &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
     &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
     &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
     &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
     &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
     &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
     &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
     &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0/
      DATA (FMRS(1,3,I, 1),I=1,49)/
     &     3.68244D0,  3.61785D0,  3.55346D0,  3.51555D0,  3.48837D0,
     &     3.46702D0,  3.39811D0,  3.32177D0,  3.27072D0,  3.23000D0,
     &     3.19378D0,  3.05765D0,  2.86346D0,  2.71339D0,  2.58651D0,
     &     2.47572D0,  2.28777D0,  2.06245D0,  1.78178D0,  1.57726D0,
     &     1.30519D0,  1.14076D0,  1.03654D0,  0.95264D0,  0.89447D0,
     &     0.84663D0,  0.80090D0,  0.75325D0,  0.70217D0,  0.64784D0,
     &     0.59048D0,  0.53173D0,  0.47263D0,  0.41459D0,  0.35887D0,
     &     0.30634D0,  0.25757D0,  0.21335D0,  0.17415D0,  0.13936D0,
     &     0.10957D0,  0.08459D0,  0.06372D0,  0.03369D0,  0.01574D0,
     &     0.00625D0,  0.00195D0,  0.00005D0,  0.00000D0/
      DATA (FMRS(1,3,I, 2),I=1,49)/
     &     6.24307D0,  5.86376D0,  5.50631D0,  5.30646D0,  5.16844D0,
     &     5.06337D0,  4.74657D0,  4.44005D0,  4.26242D0,  4.13555D0,
     &     4.03502D0,  3.71094D0,  3.34882D0,  3.11051D0,  2.92600D0,
     &     2.77355D0,  2.52821D0,  2.24967D0,  1.91859D0,  1.68481D0,
     &     1.37946D0,  1.19535D0,  1.07673D0,  0.97819D0,  0.90750D0,
     &     0.84881D0,  0.79381D0,  0.73852D0,  0.68149D0,  0.62276D0,
     &     0.56254D0,  0.50226D0,  0.44285D0,  0.38548D0,  0.33123D0,
     &     0.28073D0,  0.23437D0,  0.19279D0,  0.15633D0,  0.12427D0,
     &     0.09707D0,  0.07445D0,  0.05572D0,  0.02906D0,  0.01339D0,
     &     0.00524D0,  0.00161D0,  0.00004D0,  0.00000D0/
      DATA (FMRS(1,3,I, 3),I=1,49)/
     &    11.05139D0,  9.94786D0,  8.95244D0,  8.41536D0,  8.05287D0,
     &     7.78166D0,  6.98996D0,  6.26416D0,  5.86369D0,  5.58758D0,
     &     5.37431D0,  4.72923D0,  4.08790D0,  3.70661D0,  3.43015D0,
     &     3.21204D0,  2.87740D0,  2.51734D0,  2.11023D0,  1.83283D0,
     &     1.47833D0,  1.26530D0,  1.12571D0,  1.00618D0,  0.91793D0,
     &     0.84442D0,  0.77712D0,  0.71204D0,  0.64770D0,  0.58389D0,
     &     0.52071D0,  0.45928D0,  0.40030D0,  0.34459D0,  0.29298D0,
     &     0.24576D0,  0.20309D0,  0.16540D0,  0.13284D0,  0.10462D0,
     &     0.08093D0,  0.06152D0,  0.04560D0,  0.02333D0,  0.01054D0,
     &     0.00404D0,  0.00122D0,  0.00003D0,  0.00000D0/
      DATA (FMRS(1,3,I, 4),I=1,49)/
     &    15.37825D0, 13.53065D0, 11.90193D0, 11.03924D0, 10.46378D0,
     &    10.03696D0,  8.81034D0,  7.71341D0,  7.12073D0,  6.71781D0,
     &     6.40918D0,  5.49848D0,  4.63276D0,  4.13943D0,  3.79203D0,
     &     3.52386D0,  3.12196D0,  2.70149D0,  2.23890D0,  1.93011D0,
     &     1.54059D0,  1.30714D0,  1.15286D0,  1.01886D0,  0.91881D0,
     &     0.83562D0,  0.76055D0,  0.68952D0,  0.62095D0,  0.55452D0,
     &     0.49011D0,  0.42861D0,  0.37052D0,  0.31647D0,  0.26702D0,
     &     0.22241D0,  0.18246D0,  0.14751D0,  0.11769D0,  0.09209D0,
     &     0.07074D0,  0.05343D0,  0.03933D0,  0.01985D0,  0.00885D0,
     &     0.00335D0,  0.00100D0,  0.00002D0,  0.00000D0/
      DATA (FMRS(1,3,I, 5),I=1,49)/
     &    20.54786D0, 17.73643D0, 15.30522D0, 14.03720D0, 13.19955D0,
     &    12.58273D0, 10.83264D0,  9.29877D0,  8.48369D0,  7.93560D0,
     &     7.51848D0,  6.31010D0,  5.19808D0,  4.58383D0,  4.16067D0,
     &     3.83948D0,  3.36690D0,  2.88348D0,  2.36367D0,  2.02276D0,
     &     1.59751D0,  1.34336D0,  1.17440D0,  1.02619D0,  0.91484D0,
     &     0.82260D0,  0.74049D0,  0.66431D0,  0.59227D0,  0.52387D0,
     &     0.45886D0,  0.39784D0,  0.34106D0,  0.28898D0,  0.24193D0,
     &     0.20003D0,  0.16291D0,  0.13075D0,  0.10361D0,  0.08049D0,
     &     0.06141D0,  0.04606D0,  0.03367D0,  0.01676D0,  0.00737D0,
     &     0.00275D0,  0.00081D0,  0.00002D0,  0.00000D0/
      DATA (FMRS(1,3,I, 6),I=1,49)/
     &    25.87997D0, 22.00579D0, 18.70564D0, 17.00514D0, 15.89031D0,
     &    15.07400D0, 12.78092D0, 10.80231D0,  9.76436D0,  9.07223D0,
     &     8.54820D0,  7.05063D0,  5.70461D0,  4.97765D0,  4.48471D0,
     &     4.11512D0,  3.57867D0,  3.03899D0,  2.46867D0,  2.09967D0,
     &     1.64344D0,  1.37152D0,  1.19009D0,  1.03003D0,  0.90944D0,
     &     0.81000D0,  0.72245D0,  0.64242D0,  0.56795D0,  0.49835D0,
     &     0.43318D0,  0.37285D0,  0.31739D0,  0.26712D0,  0.22217D0,
     &     0.18254D0,  0.14775D0,  0.11786D0,  0.09285D0,  0.07171D0,
     &     0.05439D0,  0.04056D0,  0.02948D0,  0.01450D0,  0.00631D0,
     &     0.00232D0,  0.00067D0,  0.00002D0,  0.00000D0/
      DATA (FMRS(1,3,I, 7),I=1,49)/
     &    31.48650D0, 26.43816D0, 22.19174D0, 20.02570D0, 18.61470D0,
     &    17.58636D0, 14.72161D0, 12.28168D0, 11.01532D0, 10.17669D0,
     &     9.54456D0,  7.75761D0,  6.18119D0,  5.34474D0,  4.78459D0,
     &     4.36861D0,  3.77149D0,  3.17878D0,  2.56125D0,  2.16614D0,
     &     1.68135D0,  1.39321D0,  1.20050D0,  1.02990D0,  0.90129D0,
     &     0.79577D0,  0.70378D0,  0.62075D0,  0.54457D0,  0.47435D0,
     &     0.40939D0,  0.34999D0,  0.29601D0,  0.24758D0,  0.20467D0,
     &     0.16718D0,  0.13453D0,  0.10670D0,  0.08361D0,  0.06425D0,
     &     0.04845D0,  0.03594D0,  0.02598D0,  0.01264D0,  0.00544D0,
     &     0.00198D0,  0.00057D0,  0.00001D0,  0.00000D0/
      DATA (FMRS(1,3,I, 8),I=1,49)/
     &    38.19562D0, 31.67731D0, 26.26192D0, 23.52700D0, 21.75654D0,
     &    20.47217D0, 16.92324D0, 13.93891D0, 12.40615D0, 11.39793D0,
     &    10.64140D0,  8.52490D0,  6.69053D0,  5.73328D0,  5.09966D0,
     &     4.63338D0,  3.97084D0,  3.32155D0,  2.65414D0,  2.23167D0,
     &     1.71719D0,  1.41235D0,  1.20819D0,  1.02708D0,  0.89064D0,
     &     0.77934D0,  0.68328D0,  0.59764D0,  0.52014D0,  0.44964D0,
     &     0.38523D0,  0.32704D0,  0.27476D0,  0.22832D0,  0.18758D0,
     &     0.15228D0,  0.12182D0,  0.09604D0,  0.07484D0,  0.05719D0,
     &     0.04288D0,  0.03164D0,  0.02275D0,  0.01095D0,  0.00466D0,
     &     0.00168D0,  0.00048D0,  0.00001D0,  0.00000D0/
      DATA (FMRS(1,3,I, 9),I=1,49)/
     &    44.69263D0, 36.69535D0, 30.11768D0, 26.82255D0, 24.70025D0,
     &    23.16639D0, 18.95601D0, 15.45187D0, 13.66736D0, 12.49995D0,
     &    11.62724D0,  9.20581D0,  7.13631D0,  6.07035D0,  5.37118D0,
     &     4.86033D0,  4.14011D0,  3.44140D0,  2.73081D0,  2.28485D0,
     &     1.74506D0,  1.42613D0,  1.21246D0,  1.02274D0,  0.88003D0,
     &     0.76424D0,  0.66513D0,  0.57765D0,  0.49935D0,  0.42889D0,
     &     0.36519D0,  0.30820D0,  0.25746D0,  0.21275D0,  0.17388D0,
     &     0.14043D0,  0.11178D0,  0.08767D0,  0.06799D0,  0.05171D0,
     &     0.03859D0,  0.02834D0,  0.02028D0,  0.00968D0,  0.00408D0,
     &     0.00146D0,  0.00041D0,  0.00001D0,  0.00000D0/
      DATA (FMRS(1,3,I,10),I=1,49)/
     &    51.42669D0, 41.84610D0, 34.03689D0, 30.15309D0, 27.66303D0,
     &    25.86942D0, 20.97504D0, 16.93923D0, 14.89954D0, 13.57172D0,
     &    12.58248D0,  9.85775D0,  7.55746D0,  6.38605D0,  5.62372D0,
     &     5.07013D0,  4.29501D0,  3.54959D0,  2.79853D0,  2.33075D0,
     &     1.76763D0,  1.43584D0,  1.21358D0,  1.01625D0,  0.86814D0,
     &     0.74860D0,  0.64707D0,  0.55827D0,  0.47958D0,  0.40941D0,
     &     0.34660D0,  0.29089D0,  0.24172D0,  0.19871D0,  0.16160D0,
     &     0.12988D0,  0.10289D0,  0.08032D0,  0.06202D0,  0.04695D0,
     &     0.03489D0,  0.02551D0,  0.01818D0,  0.00860D0,  0.00360D0,
     &     0.00128D0,  0.00036D0,  0.00001D0,  0.00000D0/
      DATA (FMRS(1,3,I,11),I=1,49)/
     &    57.20334D0, 46.22931D0, 37.34534D0, 32.95134D0, 30.14391D0,
     &    28.12686D0, 22.64741D0, 18.16087D0, 15.90648D0, 14.44434D0,
     &    13.35786D0, 10.38182D0,  7.89242D0,  6.63544D0,  5.82215D0,
     &     5.23423D0,  4.41529D0,  3.63279D0,  2.84983D0,  2.36499D0,
     &     1.78374D0,  1.44206D0,  1.21326D0,  1.01023D0,  0.85815D0,
     &     0.73593D0,  0.63273D0,  0.54312D0,  0.46430D0,  0.39449D0,
     &     0.33248D0,  0.27783D0,  0.22993D0,  0.18826D0,  0.15250D0,
     &     0.12212D0,  0.09637D0,  0.07495D0,  0.05770D0,  0.04352D0,
     &     0.03223D0,  0.02349D0,  0.01668D0,  0.00784D0,  0.00326D0,
     &     0.00115D0,  0.00032D0,  0.00001D0,  0.00000D0/
      DATA (FMRS(1,3,I,12),I=1,49)/
     &    70.62117D0, 56.29525D0, 44.85603D0, 39.26056D0, 35.71024D0,
     &    33.17249D0, 26.34026D0, 20.82458D0, 18.08508D0, 16.32156D0,
     &    15.01807D0, 11.48651D0,  8.58576D0,  7.14521D0,  6.22372D0,
     &     5.56345D0,  4.65284D0,  3.79371D0,  2.94559D0,  2.42633D0,
     &     1.80899D0,  1.44797D0,  1.20662D0,  0.99291D0,  0.83369D0,
     &     0.70687D0,  0.60112D0,  0.51056D0,  0.43209D0,  0.36357D0,
     &     0.30359D0,  0.25146D0,  0.20630D0,  0.16753D0,  0.13462D0,
     &     0.10696D0,  0.08376D0,  0.06466D0,  0.04944D0,  0.03702D0,
     &     0.02722D0,  0.01971D0,  0.01390D0,  0.00645D0,  0.00265D0,
     &     0.00093D0,  0.00026D0,  0.00001D0,  0.00000D0/
      DATA (FMRS(1,3,I,13),I=1,49)/
     &    83.50434D0, 65.82890D0, 51.87140D0, 45.10521D0, 40.83618D0,
     &    37.79736D0, 29.67546D0, 23.19327D0, 20.00393D0, 17.96325D0,
     &    16.46149D0, 12.42825D0,  9.16326D0,  7.56303D0,  6.54853D0,
     &     5.82663D0,  4.83880D0,  3.91602D0,  3.01472D0,  2.46779D0,
     &     1.82202D0,  1.44614D0,  1.19543D0,  0.97402D0,  0.80992D0,
     &     0.68027D0,  0.57325D0,  0.48262D0,  0.40504D0,  0.33808D0,
     &     0.28014D0,  0.23033D0,  0.18761D0,  0.15130D0,  0.12077D0,
     &     0.09534D0,  0.07419D0,  0.05692D0,  0.04326D0,  0.03220D0,
     &     0.02354D0,  0.01696D0,  0.01189D0,  0.00546D0,  0.00222D0,
     &     0.00077D0,  0.00021D0,  0.00001D0,  0.00000D0/
      DATA (FMRS(1,3,I,14),I=1,49)/
     &    99.26808D0, 77.34151D0, 60.22972D0, 52.01289D0, 46.85941D0,
     &    43.20707D0, 33.52017D0, 25.88194D0, 22.16110D0, 19.79557D0,
     &    18.06292D0, 13.45200D0,  9.77556D0,  7.99825D0,  6.88178D0,
     &     6.09288D0,  5.02224D0,  4.03207D0,  3.07569D0,  2.50055D0,
     &     1.82658D0,  1.43637D0,  1.17694D0,  0.94870D0,  0.78062D0,
     &     0.64903D0,  0.54156D0,  0.45166D0,  0.37564D0,  0.31084D0,
     &     0.25547D0,  0.20834D0,  0.16843D0,  0.13481D0,  0.10686D0,
     &     0.08378D0,  0.06476D0,  0.04934D0,  0.03727D0,  0.02756D0,
     &     0.02003D0,  0.01435D0,  0.01000D0,  0.00454D0,  0.00183D0,
     &     0.00063D0,  0.00017D0,  0.00000D0,  0.00000D0/
      DATA (FMRS(1,3,I,15),I=1,49)/
     &   117.13634D0, 90.22787D0, 69.46667D0, 59.58908D0, 53.42973D0,
     &    49.08310D0, 37.64029D0, 28.72286D0, 24.42074D0, 21.70264D0,
     &    19.72087D0, 14.49332D0, 10.38573D0,  8.42544D0,  7.20484D0,
     &     6.34818D0,  5.19436D0,  4.13748D0,  3.12707D0,  2.52493D0,
     &     1.82437D0,  1.42118D0,  1.15415D0,  0.92032D0,  0.74934D0,
     &     0.61673D0,  0.50955D0,  0.42103D0,  0.34703D0,  0.28471D0,
     &     0.23205D0,  0.18777D0,  0.15064D0,  0.11967D0,  0.09419D0,
     &     0.07336D0,  0.05631D0,  0.04263D0,  0.03201D0,  0.02354D0,
     &     0.01700D0,  0.01211D0,  0.00839D0,  0.00377D0,  0.00151D0,
     &     0.00052D0,  0.00014D0,  0.00000D0,  0.00000D0/
      DATA (FMRS(1,3,I,16),I=1,49)/
     &   134.87820D0,102.87527D0, 78.42588D0, 66.88609D0, 59.72612D0,
     &    54.69190D0, 41.52393D0, 31.36570D0, 26.50579D0, 23.45176D0,
     &    21.23395D0, 15.42784D0, 10.92244D0,  8.79593D0,  7.48170D0,
     &     6.56462D0,  5.33723D0,  4.22208D0,  3.16533D0,  2.54035D0,
     &     1.81781D0,  1.40424D0,  1.13142D0,  0.89365D0,  0.72095D0,
     &     0.58811D0,  0.48181D0,  0.39483D0,  0.32289D0,  0.26295D0,
     &     0.21278D0,  0.17100D0,  0.13629D0,  0.10758D0,  0.08415D0,
     &     0.06517D0,  0.04972D0,  0.03744D0,  0.02797D0,  0.02046D0,
     &     0.01470D0,  0.01042D0,  0.00719D0,  0.00321D0,  0.00127D0,
     &     0.00043D0,  0.00012D0,  0.00000D0,  0.00000D0/
      DATA (FMRS(1,3,I,17),I=1,49)/
     &   154.38010D0,116.63111D0, 88.06633D0, 74.68806D0, 66.42747D0,
     &    60.64011D0, 45.59593D0, 34.10384D0, 28.65021D0, 25.24085D0,
     &    22.77463D0, 16.36506D0, 11.45095D0,  9.15610D0,  7.74790D0,
     &     6.77064D0,  5.47057D0,  4.29852D0,  3.19720D0,  2.55058D0,
     &     1.80771D0,  1.38488D0,  1.10716D0,  0.86634D0,  0.69264D0,
     &     0.56014D0,  0.45511D0,  0.36997D0,  0.30026D0,  0.24276D0,
     &     0.19507D0,  0.15573D0,  0.12333D0,  0.09676D0,  0.07524D0,
     &     0.05794D0,  0.04395D0,  0.03292D0,  0.02447D0,  0.01781D0,
     &     0.01274D0,  0.00899D0,  0.00618D0,  0.00274D0,  0.00108D0,
     &     0.00037D0,  0.00010D0,  0.00000D0,  0.00000D0/
      DATA (FMRS(1,3,I,18),I=1,49)/
     &   171.60985D0,128.66806D0, 96.41977D0, 81.40891D0, 72.17590D0,
     &    65.72558D0, 49.04064D0, 36.39427D0, 30.43144D0, 26.71914D0,
     &    24.04215D0, 17.12464D0, 11.87120D0,  9.43856D0,  7.95410D0,
     &     6.92832D0,  5.57016D0,  4.35322D0,  3.21721D0,  2.55406D0,
     &     1.79608D0,  1.36671D0,  1.08575D0,  0.84319D0,  0.66925D0,
     &     0.53749D0,  0.43376D0,  0.35041D0,  0.28267D0,  0.22722D0,
     &     0.18154D0,  0.14418D0,  0.11359D0,  0.08871D0,  0.06865D0,
     &     0.05262D0,  0.03976D0,  0.02965D0,  0.02195D0,  0.01592D0,
     &     0.01135D0,  0.00798D0,  0.00547D0,  0.00241D0,  0.00095D0,
     &     0.00032D0,  0.00009D0,  0.00000D0,  0.00000D0/
      DATA (FMRS(1,3,I,19),I=1,49)/
     &   193.78899D0,144.01862D0,106.97157D0, 89.85031D0, 79.36631D0,
     &    72.06629D0, 53.29134D0, 39.18974D0, 32.59051D0, 28.50177D0,
     &    25.56394D0, 18.02311D0, 12.35926D0,  9.76179D0,  8.18702D0,
     &     7.10431D0,  5.67841D0,  4.40968D0,  3.23437D0,  2.55292D0,
     &     1.77867D0,  1.34261D0,  1.05865D0,  0.81484D0,  0.64125D0,
     &     0.51082D0,  0.40904D0,  0.32798D0,  0.26269D0,  0.20975D0,
     &     0.16651D0,  0.13145D0,  0.10293D0,  0.07994D0,  0.06153D0,
     &     0.04691D0,  0.03527D0,  0.02618D0,  0.01929D0,  0.01394D0,
     &     0.00989D0,  0.00693D0,  0.00473D0,  0.00207D0,  0.00081D0,
     &     0.00027D0,  0.00007D0,  0.00000D0,  0.00000D0/
      DATA (FMRS(1,3,I,20),I=1,49)/
     &   214.89481D0,158.49641D0,116.83355D0, 97.69725D0, 86.02460D0,
     &    77.91979D0, 57.17770D0, 41.71972D0, 34.53225D0, 30.09744D0,
     &    26.92084D0, 18.81368D0, 12.78187D0, 10.03830D0,  8.38419D0,
     &     7.25181D0,  5.76723D0,  4.45410D0,  3.24560D0,  2.54901D0,
     &     1.76164D0,  1.32048D0,  1.03446D0,  0.79010D0,  0.61721D0,
     &     0.48824D0,  0.38835D0,  0.30938D0,  0.24629D0,  0.19551D0,
     &     0.15438D0,  0.12122D0,  0.09444D0,  0.07299D0,  0.05594D0,
     &     0.04245D0,  0.03178D0,  0.02349D0,  0.01725D0,  0.01242D0,
     &     0.00879D0,  0.00614D0,  0.00418D0,  0.00182D0,  0.00071D0,
     &     0.00024D0,  0.00007D0,  0.00000D0,  0.00000D0/
      DATA (FMRS(1,3,I,21),I=1,49)/
     &   234.93695D0,172.12665D0,126.03609D0,104.98046D0, 92.18044D0,
     &    83.31506D0, 60.72429D0, 44.00365D0, 36.27307D0, 31.52044D0,
     &    28.12565D0, 19.50453D0, 13.14306D0, 10.27071D0,  8.54710D0,
     &     7.37140D0,  5.83642D0,  4.48556D0,  3.24949D0,  2.54059D0,
     &     1.74309D0,  1.29840D0,  1.01128D0,  0.76711D0,  0.59538D0,
     &     0.46805D0,  0.37012D0,  0.29319D0,  0.23219D0,  0.18337D0,
     &     0.14410D0,  0.11261D0,  0.08738D0,  0.06725D0,  0.05133D0,
     &     0.03881D0,  0.02895D0,  0.02133D0,  0.01562D0,  0.01121D0,
     &     0.00791D0,  0.00551D0,  0.00374D0,  0.00162D0,  0.00063D0,
     &     0.00021D0,  0.00006D0,  0.00000D0,  0.00000D0/
      DATA (FMRS(1,3,I,22),I=1,49)/
     &   261.98752D0,190.37146D0,138.25069D0,114.59908D0,100.28083D0,
     &    90.39440D0, 65.33586D0, 46.94503D0, 38.50155D0, 33.33386D0,
     &    29.65516D0, 20.37022D0, 13.58831D0, 10.55348D0,  8.74295D0,
     &     7.51340D0,  5.91633D0,  4.51953D0,  3.25037D0,  2.52703D0,
     &     1.71812D0,  1.26985D0,  0.98192D0,  0.73853D0,  0.56860D0,
     &     0.44359D0,  0.34825D0,  0.27396D0,  0.21556D0,  0.16918D0,
     &     0.13216D0,  0.10269D0,  0.07927D0,  0.06069D0,  0.04611D0,
     &     0.03471D0,  0.02577D0,  0.01891D0,  0.01380D0,  0.00987D0,
     &     0.00694D0,  0.00482D0,  0.00326D0,  0.00141D0,  0.00055D0,
     &     0.00018D0,  0.00005D0,  0.00000D0,  0.00000D0/
      DATA (FMRS(1,3,I,23),I=1,49)/
     &   289.01031D0,208.43709D0,150.23653D0,123.98669D0,108.15595D0,
     &    97.25583D0, 69.76177D0, 49.73855D0, 40.60409D0, 35.03629D0,
     &    31.08496D0, 21.16773D0, 13.99081D0, 10.80513D0,  8.91469D0,
     &     7.63597D0,  5.98282D0,  4.54504D0,  3.24687D0,  2.51128D0,
     &     1.69316D0,  1.24243D0,  0.95435D0,  0.71223D0,  0.54431D0,
     &     0.42170D0,  0.32889D0,  0.25710D0,  0.20110D0,  0.15697D0,
     &     0.12195D0,  0.09429D0,  0.07242D0,  0.05518D0,  0.04175D0,
     &     0.03132D0,  0.02316D0,  0.01693D0,  0.01232D0,  0.00878D0,
     &     0.00615D0,  0.00426D0,  0.00288D0,  0.00124D0,  0.00048D0,
     &     0.00016D0,  0.00004D0,  0.00000D0,  0.00000D0/
      DATA (FMRS(1,3,I,24),I=1,49)/
     &   315.12421D0,225.74153D0,161.61246D0,132.84715D0,115.55888D0,
     &   103.68510D0, 73.86555D0, 52.29894D0, 42.51674D0, 36.57598D0,
     &    32.37159D0, 21.87235D0, 14.33730D0, 11.01653D0,  9.05547D0,
     &     7.73389D0,  6.03187D0,  4.55934D0,  3.23736D0,  2.49207D0,
     &     1.66734D0,  1.21544D0,  0.92800D0,  0.68769D0,  0.52210D0,
     &     0.40197D0,  0.31164D0,  0.24228D0,  0.18850D0,  0.14640D0,
     &     0.11322D0,  0.08715D0,  0.06666D0,  0.05059D0,  0.03813D0,
     &     0.02850D0,  0.02101D0,  0.01531D0,  0.01111D0,  0.00790D0,
     &     0.00552D0,  0.00382D0,  0.00258D0,  0.00111D0,  0.00043D0,
     &     0.00014D0,  0.00004D0,  0.00000D0,  0.00000D0/
      DATA (FMRS(1,3,I,25),I=1,49)/
     &   342.80673D0,243.95296D0,173.49684D0,142.06322D0,123.23465D0,
     &   110.33495D0, 78.07693D0, 54.90473D0, 44.45325D0, 38.12883D0,
     &    33.66507D0, 22.57285D0, 14.67683D0, 11.22134D0,  9.19035D0,
     &     7.82660D0,  6.07682D0,  4.57070D0,  3.22605D0,  2.47181D0,
     &     1.64130D0,  1.18872D0,  0.90224D0,  0.66398D0,  0.50084D0,
     &     0.38326D0,  0.29541D0,  0.22842D0,  0.17680D0,  0.13666D0,
     &     0.10521D0,  0.08063D0,  0.06143D0,  0.04643D0,  0.03487D0,
     &     0.02598D0,  0.01909D0,  0.01388D0,  0.01004D0,  0.00712D0,
     &     0.00496D0,  0.00343D0,  0.00231D0,  0.00099D0,  0.00038D0,
     &     0.00013D0,  0.00004D0,  0.00000D0,  0.00000D0/
      DATA (FMRS(1,3,I,26),I=1,49)/
     &   370.71918D0,262.16998D0,185.28712D0,151.16048D0,130.78375D0,
     &   116.85600D0, 82.16776D0, 57.40948D0, 46.30192D0, 39.60334D0,
     &    34.88776D0, 23.22383D0, 14.98428D0, 11.40259D0,  9.30664D0,
     &     7.90402D0,  6.11093D0,  4.57472D0,  3.21035D0,  2.44880D0,
     &     1.61427D0,  1.16192D0,  0.87693D0,  0.64114D0,  0.48063D0,
     &     0.36570D0,  0.28035D0,  0.21566D0,  0.16615D0,  0.12784D0,
     &     0.09801D0,  0.07482D0,  0.05679D0,  0.04277D0,  0.03202D0,
     &     0.02378D0,  0.01743D0,  0.01263D0,  0.00912D0,  0.00645D0,
     &     0.00449D0,  0.00310D0,  0.00208D0,  0.00089D0,  0.00034D0,
     &     0.00012D0,  0.00003D0,  0.00000D0,  0.00000D0/
      DATA (FMRS(1,3,I,27),I=1,49)/
     &   398.31635D0,280.05777D0,196.78310D0,159.99336D0,138.09111D0,
     &   123.15311D0, 86.08746D0, 59.78946D0, 48.04917D0, 40.99130D0,
     &    36.03455D0, 23.82682D0, 15.26416D0, 11.56505D0,  9.40909D0,
     &     7.97073D0,  6.13825D0,  4.57511D0,  3.19349D0,  2.42581D0,
     &     1.58834D0,  1.13668D0,  0.85340D0,  0.62017D0,  0.46227D0,
     &     0.34987D0,  0.26689D0,  0.20435D0,  0.15674D0,  0.12011D0,
     &     0.09172D0,  0.06977D0,  0.05278D0,  0.03962D0,  0.02958D0,
     &     0.02190D0,  0.01601D0,  0.01157D0,  0.00834D0,  0.00589D0,
     &     0.00409D0,  0.00282D0,  0.00189D0,  0.00081D0,  0.00031D0,
     &     0.00010D0,  0.00003D0,  0.00000D0,  0.00000D0/
      DATA (FMRS(1,3,I,28),I=1,49)/
     &   425.10541D0,297.30496D0,207.79007D0,168.41481D0,145.03664D0,
     &   129.12375D0, 89.77434D0, 62.00834D0, 49.66874D0, 42.27205D0,
     &    37.08847D0, 24.37295D0, 15.51221D0, 11.70602D0,  9.49577D0,
     &     8.02523D0,  6.15776D0,  4.57120D0,  3.17506D0,  2.40249D0,
     &     1.56325D0,  1.11278D0,  0.83141D0,  0.60084D0,  0.44554D0,
     &     0.33559D0,  0.25483D0,  0.19432D0,  0.14844D0,  0.11333D0,
     &     0.08624D0,  0.06537D0,  0.04932D0,  0.03692D0,  0.02748D0,
     &     0.02030D0,  0.01481D0,  0.01068D0,  0.00768D0,  0.00541D0,
     &     0.00376D0,  0.00258D0,  0.00173D0,  0.00074D0,  0.00028D0,
     &     0.00010D0,  0.00003D0,  0.00000D0,  0.00000D0/
      DATA (FMRS(1,3,I,29),I=1,49)/
     &   452.96622D0,315.13217D0,219.09509D0,177.03108D0,152.12305D0,
     &   135.20210D0, 93.50108D0, 64.23380D0, 51.28493D0, 43.54515D0,
     &    38.13279D0, 24.90754D0, 15.75054D0, 11.83897D0,  9.57579D0,
     &     8.07414D0,  6.17308D0,  4.56436D0,  3.15482D0,  2.37807D0,
     &     1.53780D0,  1.08891D0,  0.80971D0,  0.58195D0,  0.42935D0,
     &     0.32187D0,  0.24333D0,  0.18479D0,  0.14060D0,  0.10697D0,
     &     0.08112D0,  0.06130D0,  0.04611D0,  0.03442D0,  0.02556D0,
     &     0.01884D0,  0.01371D0,  0.00987D0,  0.00709D0,  0.00499D0,
     &     0.00346D0,  0.00237D0,  0.00159D0,  0.00068D0,  0.00026D0,
     &     0.00009D0,  0.00002D0,  0.00000D0,  0.00000D0/
      DATA (FMRS(1,3,I,30),I=1,49)/
     &   481.05176D0,332.98895D0,230.34398D0,185.57016D0,159.12541D0,
     &   141.19426D0, 97.14677D0, 66.39220D0, 52.84356D0, 44.76743D0,
     &    39.13180D0, 25.41137D0, 15.96984D0, 11.95815D0,  9.64523D0,
     &     8.11468D0,  6.18265D0,  4.55389D0,  3.13269D0,  2.35270D0,
     &     1.51231D0,  1.06542D0,  0.78862D0,  0.56381D0,  0.41396D0,
     &     0.30893D0,  0.23257D0,  0.17592D0,  0.13335D0,  0.10111D0,
     &     0.07645D0,  0.05760D0,  0.04319D0,  0.03217D0,  0.02383D0,
     &     0.01753D0,  0.01273D0,  0.00915D0,  0.00656D0,  0.00461D0,
     &     0.00319D0,  0.00219D0,  0.00146D0,  0.00062D0,  0.00024D0,
     &     0.00008D0,  0.00002D0,  0.00000D0,  0.00000D0/
      DATA (FMRS(1,3,I,31),I=1,49)/
     &   508.69336D0,350.46606D0,241.29128D0,193.85184D0,165.89978D0,
     &   146.97998D0,100.64462D0, 68.44891D0, 54.32217D0, 45.92301D0,
     &    40.07352D0, 25.88124D0, 16.17098D0, 12.06571D0,  9.70659D0,
     &     8.14933D0,  6.18899D0,  4.54214D0,  3.11075D0,  2.32815D0,
     &     1.48813D0,  1.04340D0,  0.76902D0,  0.54710D0,  0.39988D0,
     &     0.29718D0,  0.22284D0,  0.16794D0,  0.12688D0,  0.09590D0,
     &     0.07230D0,  0.05433D0,  0.04063D0,  0.03020D0,  0.02232D0,
     &     0.01639D0,  0.01188D0,  0.00852D0,  0.00610D0,  0.00428D0,
     &     0.00296D0,  0.00203D0,  0.00136D0,  0.00057D0,  0.00022D0,
     &     0.00007D0,  0.00002D0,  0.00000D0,  0.00000D0/
      DATA (FMRS(1,3,I,32),I=1,49)/
     &   535.18030D0,367.11212D0,251.65173D0,201.65910D0,172.26764D0,
     &   152.40591D0,103.89980D0, 70.34598D0, 55.67789D0, 46.97741D0,
     &    40.92907D0, 26.30087D0, 16.34517D0, 12.15570D0,  9.75539D0,
     &     8.17448D0,  6.18955D0,  4.52735D0,  3.08788D0,  2.30359D0,
     &     1.46475D0,  1.02248D0,  0.75063D0,  0.53161D0,  0.38695D0,
     &     0.28648D0,  0.21405D0,  0.16077D0,  0.12112D0,  0.09128D0,
     &     0.06863D0,  0.05145D0,  0.03839D0,  0.02847D0,  0.02101D0,
     &     0.01540D0,  0.01114D0,  0.00798D0,  0.00571D0,  0.00400D0,
     &     0.00276D0,  0.00189D0,  0.00126D0,  0.00054D0,  0.00020D0,
     &     0.00007D0,  0.00002D0,  0.00000D0,  0.00000D0/
      DATA (FMRS(1,3,I,33),I=1,49)/
     &   563.08673D0,384.57391D0,262.47256D0,209.79239D0,178.88937D0,
     &   158.04028D0,107.26506D0, 72.29848D0, 57.06943D0, 48.05758D0,
     &    41.80413D0, 26.72791D0, 16.52149D0, 12.24650D0,  9.80451D0,
     &     8.19975D0,  6.19012D0,  4.51259D0,  3.06514D0,  2.27926D0,
     &     1.44171D0,  1.00196D0,  0.73265D0,  0.51654D0,  0.37443D0,
     &     0.27615D0,  0.20559D0,  0.15389D0,  0.11561D0,  0.08687D0,
     &     0.06514D0,  0.04872D0,  0.03627D0,  0.02685D0,  0.01977D0,
     &     0.01446D0,  0.01045D0,  0.00747D0,  0.00534D0,  0.00374D0,
     &     0.00258D0,  0.00176D0,  0.00118D0,  0.00050D0,  0.00019D0,
     &     0.00006D0,  0.00002D0,  0.00000D0,  0.00000D0/
      DATA (FMRS(1,3,I,34),I=1,49)/
     &   590.49207D0,401.61096D0,272.95639D0,217.63766D0,185.25558D0,
     &   163.44283D0,110.46277D0, 74.13376D0, 58.36747D0, 49.05885D0,
     &    42.61046D0, 27.11206D0, 16.67322D0, 12.31989D0,  9.84041D0,
     &     8.21457D0,  6.18338D0,  4.49312D0,  3.03982D0,  2.25340D0,
     &     1.41818D0,  0.98144D0,  0.71494D0,  0.50189D0,  0.36238D0,
     &     0.26631D0,  0.19763D0,  0.14748D0,  0.11046D0,  0.08279D0,
     &     0.06193D0,  0.04622D0,  0.03434D0,  0.02537D0,  0.01865D0,
     &     0.01362D0,  0.00983D0,  0.00702D0,  0.00501D0,  0.00351D0,
     &     0.00242D0,  0.00165D0,  0.00110D0,  0.00046D0,  0.00018D0,
     &     0.00006D0,  0.00002D0,  0.00000D0,  0.00000D0/
      DATA (FMRS(1,3,I,35),I=1,49)/
     &   617.67798D0,418.44214D0,283.27148D0,225.33791D0,191.49365D0,
     &   168.72942D0,113.57884D0, 75.91459D0, 59.62379D0, 50.02613D0,
     &    43.38823D0, 27.48080D0, 16.81807D0, 12.38969D0,  9.87443D0,
     &     8.22855D0,  6.17694D0,  4.47470D0,  3.01600D0,  2.22915D0,
     &     1.39622D0,  0.96237D0,  0.69854D0,  0.48839D0,  0.35132D0,
     &     0.25731D0,  0.19037D0,  0.14164D0,  0.10579D0,  0.07911D0,
     &     0.05904D0,  0.04396D0,  0.03261D0,  0.02405D0,  0.01765D0,
     &     0.01287D0,  0.00928D0,  0.00662D0,  0.00472D0,  0.00330D0,
     &     0.00227D0,  0.00155D0,  0.00103D0,  0.00044D0,  0.00017D0,
     &     0.00006D0,  0.00002D0,  0.00000D0,  0.00000D0/
      DATA (FMRS(1,3,I,36),I=1,49)/
     &   643.85529D0,434.56937D0,293.10349D0,232.65437D0,197.40677D0,
     &   173.73129D0,116.50865D0, 77.57690D0, 60.79072D0, 50.92106D0,
     &    44.10533D0, 27.81589D0, 16.94600D0, 12.44906D0,  9.90141D0,
     &     8.23759D0,  6.16791D0,  4.45540D0,  2.99242D0,  2.20560D0,
     &     1.37532D0,  0.94442D0,  0.68324D0,  0.47589D0,  0.34114D0,
     &     0.24908D0,  0.18375D0,  0.13636D0,  0.10159D0,  0.07580D0,
     &     0.05645D0,  0.04195D0,  0.03106D0,  0.02287D0,  0.01676D0,
     &     0.01221D0,  0.00879D0,  0.00626D0,  0.00446D0,  0.00311D0,
     &     0.00214D0,  0.00146D0,  0.00097D0,  0.00041D0,  0.00016D0,
     &     0.00005D0,  0.00001D0,  0.00000D0,  0.00000D0/
      DATA (FMRS(1,3,I,37),I=1,49)/
     &   670.62598D0,450.98129D0,303.05762D0,240.03790D0,203.35986D0,
     &   178.75746D0,119.43383D0, 79.22430D0, 61.94125D0, 51.79964D0,
     &    44.80675D0, 28.13850D0, 17.06516D0, 12.50182D0,  9.92310D0,
     &     8.24227D0,  6.15572D0,  4.43398D0,  2.96756D0,  2.18122D0,
     &     1.35409D0,  0.92638D0,  0.66799D0,  0.46354D0,  0.33115D0,
     &     0.24105D0,  0.17731D0,  0.13125D0,  0.09756D0,  0.07262D0,
     &     0.05397D0,  0.04005D0,  0.02960D0,  0.02176D0,  0.01592D0,
     &     0.01159D0,  0.00833D0,  0.00593D0,  0.00422D0,  0.00294D0,
     &     0.00202D0,  0.00138D0,  0.00092D0,  0.00039D0,  0.00015D0,
     &     0.00005D0,  0.00001D0,  0.00000D0,  0.00000D0/
      DATA (FMRS(1,3,I,38),I=1,49)/
     &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
     &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
     &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
     &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
     &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
     &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
     &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
     &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
     &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
     &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0/
      DATA (FMRS(1,4,I, 1),I=1,49)/
     &     0.86800D0,  0.76598D0,  0.67520D0,  0.62675D0,  0.59428D0,
     &     0.57013D0,  0.50046D0,  0.43816D0,  0.40484D0,  0.38253D0,
     &     0.36613D0,  0.31874D0,  0.27654D0,  0.25397D0,  0.23882D0,
     &     0.22750D0,  0.21099D0,  0.19387D0,  0.17401D0,  0.15872D0,
     &     0.13363D0,  0.11222D0,  0.09356D0,  0.07392D0,  0.05824D0,
     &     0.04613D0,  0.03700D0,  0.03017D0,  0.02498D0,  0.02125D0,
     &     0.01786D0,  0.01513D0,  0.01268D0,  0.01040D0,  0.00852D0,
     &     0.00674D0,  0.00520D0,  0.00388D0,  0.00299D0,  0.00201D0,
     &     0.00134D0,  0.00094D0,  0.00051D0,  0.00021D0,  0.00007D0,
     &     0.00003D0, -0.00001D0,  0.00000D0,  0.00000D0/
      DATA (FMRS(1,4,I, 2),I=1,49)/
     &     0.88205D0,  0.77983D0,  0.68869D0,  0.63997D0,  0.60729D0,
     &     0.58296D0,  0.51264D0,  0.44961D0,  0.41580D0,  0.39312D0,
     &     0.37640D0,  0.32792D0,  0.28442D0,  0.26097D0,  0.24515D0,
     &     0.23328D0,  0.21590D0,  0.19782D0,  0.17683D0,  0.16077D0,
     &     0.13467D0,  0.11273D0,  0.09381D0,  0.07406D0,  0.05839D0,
     &     0.04632D0,  0.03722D0,  0.03037D0,  0.02516D0,  0.02135D0,
     &     0.01792D0,  0.01513D0,  0.01262D0,  0.01032D0,  0.00842D0,
     &     0.00664D0,  0.00510D0,  0.00380D0,  0.00291D0,  0.00197D0,
     &     0.00130D0,  0.00091D0,  0.00051D0,  0.00020D0,  0.00007D0,
     &     0.00002D0,  0.00000D0,  0.00000D0,  0.00000D0/
      DATA (FMRS(1,4,I, 3),I=1,49)/
     &     0.91886D0,  0.81356D0,  0.71953D0,  0.66920D0,  0.63541D0,
     &     0.61023D0,  0.53738D0,  0.47189D0,  0.43666D0,  0.41295D0,
     &     0.39539D0,  0.34428D0,  0.29794D0,  0.27277D0,  0.25567D0,
     &     0.24279D0,  0.22388D0,  0.20416D0,  0.18131D0,  0.16398D0,
     &     0.13630D0,  0.11352D0,  0.09418D0,  0.07425D0,  0.05857D0,
     &     0.04653D0,  0.03744D0,  0.03056D0,  0.02532D0,  0.02139D0,
     &     0.01791D0,  0.01504D0,  0.01246D0,  0.01016D0,  0.00822D0,
     &     0.00648D0,  0.00493D0,  0.00368D0,  0.00278D0,  0.00188D0,
     &     0.00124D0,  0.00086D0,  0.00051D0,  0.00020D0,  0.00006D0,
     &     0.00002D0,  0.00000D0,  0.00000D0,  0.00000D0/
      DATA (FMRS(1,4,I, 4),I=1,49)/
     &     0.95997D0,  0.84981D0,  0.75147D0,  0.69884D0,  0.66351D0,
     &     0.63718D0,  0.56100D0,  0.49247D0,  0.45556D0,  0.43069D0,
     &     0.41221D0,  0.35830D0,  0.30918D0,  0.28239D0,  0.26415D0,
     &     0.25039D0,  0.23017D0,  0.20908D0,  0.18474D0,  0.16642D0,
     &     0.13752D0,  0.11409D0,  0.09444D0,  0.07437D0,  0.05864D0,
     &     0.04662D0,  0.03752D0,  0.03063D0,  0.02535D0,  0.02135D0,
     &     0.01783D0,  0.01492D0,  0.01232D0,  0.01000D0,  0.00803D0,
     &     0.00631D0,  0.00479D0,  0.00358D0,  0.00268D0,  0.00180D0,
     &     0.00120D0,  0.00084D0,  0.00049D0,  0.00020D0,  0.00006D0,
     &     0.00001D0,  0.00000D0,  0.00000D0,  0.00000D0/
      DATA (FMRS(1,4,I, 5),I=1,49)/
     &     1.02269D0,  0.90363D0,  0.79759D0,  0.74093D0,  0.70294D0,
     &     0.67465D0,  0.59289D0,  0.51944D0,  0.47990D0,  0.45324D0,
     &     0.43337D0,  0.37541D0,  0.32249D0,  0.29359D0,  0.27391D0,
     &     0.25907D0,  0.23726D0,  0.21456D0,  0.18851D0,  0.16906D0,
     &     0.13883D0,  0.11469D0,  0.09468D0,  0.07442D0,  0.05863D0,
     &     0.04662D0,  0.03753D0,  0.03061D0,  0.02531D0,  0.02124D0,
     &     0.01767D0,  0.01472D0,  0.01211D0,  0.00977D0,  0.00782D0,
     &     0.00614D0,  0.00464D0,  0.00341D0,  0.00257D0,  0.00173D0,
     &     0.00113D0,  0.00080D0,  0.00046D0,  0.00018D0,  0.00005D0,
     &     0.00002D0,  0.00000D0,  0.00000D0,  0.00000D0/
      DATA (FMRS(1,4,I, 6),I=1,49)/
     &     1.08763D0,  0.95875D0,  0.84428D0,  0.78326D0,  0.74239D0,
     &     0.71199D0,  0.62427D0,  0.54563D0,  0.50333D0,  0.47482D0,
     &     0.45353D0,  0.39146D0,  0.33478D0,  0.30385D0,  0.28279D0,
     &     0.26692D0,  0.24362D0,  0.21944D0,  0.19183D0,  0.17138D0,
     &     0.13995D0,  0.11519D0,  0.09486D0,  0.07444D0,  0.05860D0,
     &     0.04659D0,  0.03750D0,  0.03056D0,  0.02523D0,  0.02111D0,
     &     0.01751D0,  0.01454D0,  0.01191D0,  0.00957D0,  0.00764D0,
     &     0.00598D0,  0.00450D0,  0.00328D0,  0.00247D0,  0.00167D0,
     &     0.00107D0,  0.00076D0,  0.00044D0,  0.00016D0,  0.00005D0,
     &     0.00002D0,  0.00000D0,  0.00000D0,  0.00000D0/
      DATA (FMRS(1,4,I, 7),I=1,49)/
     &     1.16556D0,  1.02401D0,  0.89875D0,  0.83219D0,  0.78769D0,
     &     0.75465D0,  0.65951D0,  0.57450D0,  0.52889D0,  0.49818D0,
     &     0.47520D0,  0.40838D0,  0.34748D0,  0.31432D0,  0.29177D0,
     &     0.27481D0,  0.24995D0,  0.22424D0,  0.19505D0,  0.17361D0,
     &     0.14101D0,  0.11563D0,  0.09500D0,  0.07441D0,  0.05852D0,
     &     0.04652D0,  0.03740D0,  0.03045D0,  0.02509D0,  0.02093D0,
     &     0.01733D0,  0.01434D0,  0.01170D0,  0.00939D0,  0.00744D0,
     &     0.00582D0,  0.00436D0,  0.00318D0,  0.00238D0,  0.00161D0,
     &     0.00104D0,  0.00073D0,  0.00042D0,  0.00014D0,  0.00005D0,
     &     0.00002D0,  0.00000D0,  0.00000D0,  0.00000D0/
      DATA (FMRS(1,4,I, 8),I=1,49)/
     &     1.26306D0,  1.10484D0,  0.96554D0,  0.89180D0,  0.84263D0,
     &     0.80618D0,  0.70157D0,  0.60853D0,  0.55877D0,  0.52532D0,
     &     0.50028D0,  0.42768D0,  0.36175D0,  0.32597D0,  0.30171D0,
     &     0.28349D0,  0.25687D0,  0.22944D0,  0.19851D0,  0.17597D0,
     &     0.14210D0,  0.11607D0,  0.09509D0,  0.07433D0,  0.05839D0,
     &     0.04638D0,  0.03725D0,  0.03028D0,  0.02490D0,  0.02071D0,
     &     0.01710D0,  0.01411D0,  0.01147D0,  0.00917D0,  0.00724D0,
     &     0.00565D0,  0.00421D0,  0.00306D0,  0.00228D0,  0.00155D0,
     &     0.00101D0,  0.00070D0,  0.00040D0,  0.00013D0,  0.00005D0,
     &     0.00002D0,  0.00000D0,  0.00000D0,  0.00000D0/
      DATA (FMRS(1,4,I, 9),I=1,49)/
     &     1.36120D0,  1.18550D0,  1.03156D0,  0.95040D0,  0.89642D0,
     &     0.85647D0,  0.74219D0,  0.64102D0,  0.58710D0,  0.55092D0,
     &     0.52385D0,  0.44558D0,  0.37481D0,  0.33656D0,  0.31068D0,
     &     0.29130D0,  0.26304D0,  0.23405D0,  0.20153D0,  0.17803D0,
     &     0.14303D0,  0.11643D0,  0.09515D0,  0.07423D0,  0.05825D0,
     &     0.04622D0,  0.03709D0,  0.03010D0,  0.02471D0,  0.02052D0,
     &     0.01688D0,  0.01389D0,  0.01125D0,  0.00895D0,  0.00706D0,
     &     0.00550D0,  0.00409D0,  0.00295D0,  0.00220D0,  0.00150D0,
     &     0.00098D0,  0.00067D0,  0.00039D0,  0.00013D0,  0.00005D0,
     &     0.00002D0,  0.00000D0,  0.00000D0,  0.00000D0/
      DATA (FMRS(1,4,I,10),I=1,49)/
     &     1.47041D0,  1.27446D0,  1.10370D0,  1.01406D0,  0.95460D0,
     &     0.91068D0,  0.78549D0,  0.67526D0,  0.61674D0,  0.57757D0,
     &     0.54827D0,  0.46388D0,  0.38797D0,  0.34713D0,  0.31960D0,
     &     0.29901D0,  0.26910D0,  0.23853D0,  0.20444D0,  0.17998D0,
     &     0.14388D0,  0.11673D0,  0.09517D0,  0.07410D0,  0.05807D0,
     &     0.04602D0,  0.03690D0,  0.02989D0,  0.02450D0,  0.02029D0,
     &     0.01665D0,  0.01365D0,  0.01102D0,  0.00875D0,  0.00689D0,
     &     0.00534D0,  0.00396D0,  0.00285D0,  0.00213D0,  0.00144D0,
     &     0.00094D0,  0.00064D0,  0.00038D0,  0.00013D0,  0.00004D0,
     &     0.00002D0,  0.00000D0,  0.00000D0,  0.00000D0/
      DATA (FMRS(1,4,I,11),I=1,49)/
     &     1.56638D0,  1.35212D0,  1.16625D0,  1.06903D0,  1.00469D0,
     &     0.95725D0,  0.82240D0,  0.70420D0,  0.64167D0,  0.59990D0,
     &     0.56868D0,  0.47904D0,  0.39878D0,  0.35576D0,  0.32683D0,
     &     0.30525D0,  0.27397D0,  0.24210D0,  0.20674D0,  0.18151D0,
     &     0.14453D0,  0.11694D0,  0.09517D0,  0.07398D0,  0.05791D0,
     &     0.04585D0,  0.03673D0,  0.02971D0,  0.02433D0,  0.02010D0,
     &     0.01646D0,  0.01346D0,  0.01083D0,  0.00860D0,  0.00675D0,
     &     0.00520D0,  0.00385D0,  0.00277D0,  0.00207D0,  0.00139D0,
     &     0.00090D0,  0.00062D0,  0.00037D0,  0.00013D0,  0.00004D0,
     &     0.00002D0,  0.00000D0,  0.00000D0,  0.00000D0/
      DATA (FMRS(1,4,I,12),I=1,49)/
     &     1.80214D0,  1.54109D0,  1.31694D0,  1.20067D0,  1.12412D0,
     &     1.06789D0,  0.90916D0,  0.77146D0,  0.69919D0,  0.65116D0,
     &     0.61534D0,  0.51323D0,  0.42280D0,  0.37478D0,  0.34269D0,
     &     0.31886D0,  0.28449D0,  0.24976D0,  0.21162D0,  0.18471D0,
     &     0.14585D0,  0.11732D0,  0.09509D0,  0.07364D0,  0.05748D0,
     &     0.04542D0,  0.03629D0,  0.02928D0,  0.02389D0,  0.01964D0,
     &     0.01603D0,  0.01303D0,  0.01043D0,  0.00824D0,  0.00644D0,
     &     0.00493D0,  0.00365D0,  0.00261D0,  0.00193D0,  0.00129D0,
     &     0.00082D0,  0.00058D0,  0.00033D0,  0.00012D0,  0.00003D0,
     &     0.00001D0,  0.00000D0,  0.00000D0,  0.00000D0/
      DATA (FMRS(1,4,I,13),I=1,49)/
     &     2.04055D0,  1.73004D0,  1.46588D0,  1.32988D0,  1.24076D0,
     &     1.17553D0,  0.99250D0,  0.83521D0,  0.75328D0,  0.69907D0,
     &     0.65875D0,  0.54456D0,  0.44445D0,  0.39176D0,  0.35673D0,
     &     0.33084D0,  0.29368D0,  0.25636D0,  0.21574D0,  0.18736D0,
     &     0.14688D0,  0.11755D0,  0.09493D0,  0.07328D0,  0.05705D0,
     &     0.04498D0,  0.03587D0,  0.02887D0,  0.02347D0,  0.01921D0,
     &     0.01564D0,  0.01265D0,  0.01010D0,  0.00793D0,  0.00617D0,
     &     0.00472D0,  0.00348D0,  0.00248D0,  0.00181D0,  0.00123D0,
     &     0.00077D0,  0.00054D0,  0.00031D0,  0.00011D0,  0.00003D0,
     &     0.00001D0,  0.00000D0,  0.00000D0,  0.00000D0/
      DATA (FMRS(1,4,I,14),I=1,49)/
     &     2.34878D0,  1.97162D0,  1.65417D0,  1.49212D0,  1.38650D0,
     &     1.30951D0,  1.09500D0,  0.91263D0,  0.81846D0,  0.75649D0,
     &     0.71054D0,  0.58140D0,  0.46952D0,  0.41122D0,  0.37271D0,
     &     0.34438D0,  0.30396D0,  0.26367D0,  0.22023D0,  0.19019D0,
     &     0.14790D0,  0.11770D0,  0.09464D0,  0.07279D0,  0.05650D0,
     &     0.04444D0,  0.03534D0,  0.02838D0,  0.02299D0,  0.01873D0,
     &     0.01518D0,  0.01221D0,  0.00971D0,  0.00758D0,  0.00587D0,
     &     0.00448D0,  0.00329D0,  0.00233D0,  0.00171D0,  0.00117D0,
     &     0.00073D0,  0.00051D0,  0.00028D0,  0.00010D0,  0.00003D0,
     &     0.00001D0,  0.00000D0,  0.00000D0,  0.00000D0/
      DATA (FMRS(1,4,I,15),I=1,49)/
     &     2.72076D0,  2.25974D0,  1.87603D0,  1.68193D0,  1.55614D0,
     &     1.46482D0,  1.21228D0,  1.00004D0,  0.89145D0,  0.82040D0,
     &     0.76790D0,  0.62156D0,  0.49638D0,  0.43184D0,  0.38951D0,
     &     0.35852D0,  0.31456D0,  0.27109D0,  0.22467D0,  0.19292D0,
     &     0.14878D0,  0.11770D0,  0.09423D0,  0.07216D0,  0.05583D0,
     &     0.04380D0,  0.03471D0,  0.02777D0,  0.02242D0,  0.01821D0,
     &     0.01468D0,  0.01176D0,  0.00931D0,  0.00721D0,  0.00560D0,
     &     0.00425D0,  0.00310D0,  0.00215D0,  0.00160D0,  0.00107D0,
     &     0.00067D0,  0.00046D0,  0.00026D0,  0.00009D0,  0.00003D0,
     &     0.00001D0,  0.00000D0,  0.00000D0,  0.00000D0/
      DATA (FMRS(1,4,I,16),I=1,49)/
     &     3.10372D0,  2.55317D0,  2.09952D0,  1.87189D0,  1.72513D0,
     &     1.61899D0,  1.32738D0,  1.08482D0,  0.96174D0,  0.88163D0,
     &     0.82262D0,  0.65935D0,  0.52128D0,  0.45078D0,  0.40481D0,
     &     0.37132D0,  0.32407D0,  0.27766D0,  0.22852D0,  0.19522D0,
     &     0.14943D0,  0.11759D0,  0.09376D0,  0.07153D0,  0.05518D0,
     &     0.04316D0,  0.03411D0,  0.02721D0,  0.02189D0,  0.01771D0,
     &     0.01421D0,  0.01135D0,  0.00894D0,  0.00691D0,  0.00532D0,
     &     0.00403D0,  0.00292D0,  0.00202D0,  0.00150D0,  0.00098D0,
     &     0.00063D0,  0.00043D0,  0.00024D0,  0.00009D0,  0.00003D0,
     &     0.00001D0,  0.00000D0,  0.00000D0,  0.00000D0/
      DATA (FMRS(1,4,I,17),I=1,49)/
     &     3.53791D0,  2.88253D0,  2.34786D0,  2.08172D0,  1.91099D0,
     &     1.78798D0,  1.45224D0,  1.17581D0,  1.03669D0,  0.94660D0,
     &     0.88048D0,  0.69881D0,  0.54694D0,  0.47011D0,  0.42034D0,
     &     0.38424D0,  0.33357D0,  0.28414D0,  0.23224D0,  0.19739D0,
     &     0.14997D0,  0.11738D0,  0.09322D0,  0.07083D0,  0.05448D0,
     &     0.04248D0,  0.03349D0,  0.02663D0,  0.02135D0,  0.01720D0,
     &     0.01373D0,  0.01094D0,  0.00857D0,  0.00662D0,  0.00504D0,
     &     0.00382D0,  0.00275D0,  0.00191D0,  0.00140D0,  0.00091D0,
     &     0.00060D0,  0.00040D0,  0.00021D0,  0.00008D0,  0.00002D0,
     &     0.00001D0,  0.00000D0,  0.00000D0,  0.00000D0/
      DATA (FMRS(1,4,I,18),I=1,49)/
     &     3.93600D0,  3.18179D0,  2.57144D0,  2.26962D0,  2.07679D0,
     &     1.93828D0,  1.56224D0,  1.25519D0,  1.10169D0,  1.00271D0,
     &     0.93026D0,  0.73238D0,  0.56848D0,  0.48622D0,  0.43319D0,
     &     0.39487D0,  0.34131D0,  0.28936D0,  0.23517D0,  0.19905D0,
     &     0.15030D0,  0.11713D0,  0.09270D0,  0.07021D0,  0.05385D0,
     &     0.04190D0,  0.03295D0,  0.02612D0,  0.02087D0,  0.01677D0,
     &     0.01334D0,  0.01060D0,  0.00827D0,  0.00637D0,  0.00486D0,
     &     0.00366D0,  0.00263D0,  0.00181D0,  0.00134D0,  0.00088D0,
     &     0.00056D0,  0.00038D0,  0.00020D0,  0.00007D0,  0.00002D0,
     &     0.00001D0,  0.00000D0,  0.00000D0,  0.00000D0/
      DATA (FMRS(1,4,I,19),I=1,49)/
     &     4.46512D0,  3.57604D0,  2.86339D0,  2.51369D0,  2.29136D0,
     &     2.13222D0,  1.70289D0,  1.35573D0,  1.18356D0,  1.07308D0,
     &     0.99248D0,  0.77387D0,  0.59477D0,  0.50571D0,  0.44864D0,
     &     0.40759D0,  0.35048D0,  0.29545D0,  0.23852D0,  0.20087D0,
     &     0.15057D0,  0.11671D0,  0.09200D0,  0.06939D0,  0.05304D0,
     &     0.04116D0,  0.03225D0,  0.02548D0,  0.02030D0,  0.01627D0,
     &     0.01289D0,  0.01018D0,  0.00793D0,  0.00608D0,  0.00462D0,
     &     0.00346D0,  0.00247D0,  0.00170D0,  0.00124D0,  0.00082D0,
     &     0.00052D0,  0.00036D0,  0.00020D0,  0.00007D0,  0.00002D0,
     &     0.00001D0,  0.00000D0,  0.00000D0,  0.00000D0/
      DATA (FMRS(1,4,I,20),I=1,49)/
     &     4.98110D0,  3.95717D0,  3.14315D0,  2.74636D0,  2.49515D0,
     &     2.31589D0,  1.83490D0,  1.44924D0,  1.25928D0,  1.13790D0,
     &     1.04961D0,  0.81156D0,  0.61839D0,  0.52309D0,  0.46234D0,
     &     0.41880D0,  0.35851D0,  0.30072D0,  0.24136D0,  0.20237D0,
     &     0.15073D0,  0.11629D0,  0.09134D0,  0.06865D0,  0.05232D0,
     &     0.04048D0,  0.03163D0,  0.02492D0,  0.01980D0,  0.01582D0,
     &     0.01251D0,  0.00983D0,  0.00765D0,  0.00583D0,  0.00441D0,
     &     0.00330D0,  0.00234D0,  0.00161D0,  0.00116D0,  0.00076D0,
     &     0.00049D0,  0.00034D0,  0.00019D0,  0.00006D0,  0.00002D0,
     &     0.00001D0,  0.00000D0,  0.00000D0,  0.00000D0/
      DATA (FMRS(1,4,I,21),I=1,49)/
     &     5.48855D0,  4.32906D0,  3.41400D0,  2.97058D0,  2.69088D0,
     &     2.49185D0,  1.96033D0,  1.53734D0,  1.33025D0,  1.19843D0,
     &     1.10279D0,  0.84628D0,  0.63987D0,  0.53877D0,  0.47461D0,
     &     0.42879D0,  0.36557D0,  0.30530D0,  0.24373D0,  0.20356D0,
     &     0.15074D0,  0.11580D0,  0.09065D0,  0.06792D0,  0.05161D0,
     &     0.03984D0,  0.03104D0,  0.02440D0,  0.01932D0,  0.01538D0,
     &     0.01214D0,  0.00950D0,  0.00738D0,  0.00561D0,  0.00423D0,
     &     0.00315D0,  0.00224D0,  0.00152D0,  0.00110D0,  0.00072D0,
     &     0.00045D0,  0.00032D0,  0.00018D0,  0.00006D0,  0.00002D0,
     &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0/
      DATA (FMRS(1,4,I,22),I=1,49)/
     &     6.18910D0,  4.83835D0,  3.78189D0,  3.27368D0,  2.95458D0,
     &     2.72828D0,  2.12748D0,  1.65375D0,  1.42355D0,  1.27771D0,
     &     1.17223D0,  0.89116D0,  0.66734D0,  0.55867D0,  0.49010D0,
     &     0.44134D0,  0.37438D0,  0.31092D0,  0.24658D0,  0.20493D0,
     &     0.15066D0,  0.11512D0,  0.08974D0,  0.06696D0,  0.05069D0,
     &     0.03901D0,  0.03030D0,  0.02374D0,  0.01874D0,  0.01485D0,
     &     0.01168D0,  0.00911D0,  0.00704D0,  0.00533D0,  0.00400D0,
     &     0.00297D0,  0.00211D0,  0.00142D0,  0.00104D0,  0.00068D0,
     &     0.00042D0,  0.00029D0,  0.00017D0,  0.00005D0,  0.00002D0,
     &     0.00001D0,  0.00000D0,  0.00000D0,  0.00000D0/
      DATA (FMRS(1,4,I,23),I=1,49)/
     &     6.90776D0,  5.35634D0,  4.15288D0,  3.57780D0,  3.21822D0,
     &     2.96398D0,  2.29266D0,  1.76775D0,  1.51442D0,  1.35462D0,
     &     1.23937D0,  0.93411D0,  0.69332D0,  0.57734D0,  0.50454D0,
     &     0.45297D0,  0.38246D0,  0.31600D0,  0.24910D0,  0.20608D0,
     &     0.15048D0,  0.11442D0,  0.08886D0,  0.06603D0,  0.04982D0,
     &     0.03823D0,  0.02961D0,  0.02314D0,  0.01820D0,  0.01437D0,
     &     0.01125D0,  0.00875D0,  0.00671D0,  0.00507D0,  0.00380D0,
     &     0.00282D0,  0.00198D0,  0.00134D0,  0.00099D0,  0.00065D0,
     &     0.00039D0,  0.00026D0,  0.00015D0,  0.00005D0,  0.00002D0,
     &     0.00001D0,  0.00000D0,  0.00000D0,  0.00000D0/
      DATA (FMRS(1,4,I,24),I=1,49)/
     &     7.62426D0,  5.86871D0,  4.51692D0,  3.87481D0,  3.47482D0,
     &     3.19280D0,  2.45168D0,  1.87657D0,  1.60070D0,  1.42736D0,
     &     1.30266D0,  0.97414D0,  0.71722D0,  0.59437D0,  0.51760D0,
     &     0.46341D0,  0.38962D0,  0.32042D0,  0.25117D0,  0.20694D0,
     &     0.15017D0,  0.11367D0,  0.08795D0,  0.06511D0,  0.04897D0,
     &     0.03748D0,  0.02894D0,  0.02253D0,  0.01769D0,  0.01392D0,
     &     0.01087D0,  0.00842D0,  0.00645D0,  0.00484D0,  0.00362D0,
     &     0.00267D0,  0.00187D0,  0.00128D0,  0.00093D0,  0.00060D0,
     &     0.00037D0,  0.00024D0,  0.00014D0,  0.00004D0,  0.00002D0,
     &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0/
      DATA (FMRS(1,4,I,25),I=1,49)/
     &     8.39819D0,  6.41814D0,  4.90446D0,  4.18965D0,  3.74601D0,
     &     3.43405D0,  2.61811D0,  1.98959D0,  1.68991D0,  1.50231D0,
     &     1.36770D0,  1.01493D0,  0.74134D0,  0.61144D0,  0.53063D0,
     &     0.47380D0,  0.39668D0,  0.32474D0,  0.25316D0,  0.20772D0,
     &     0.14981D0,  0.11289D0,  0.08703D0,  0.06420D0,  0.04813D0,
     &     0.03673D0,  0.02828D0,  0.02194D0,  0.01719D0,  0.01349D0,
     &     0.01049D0,  0.00810D0,  0.00620D0,  0.00463D0,  0.00344D0,
     &     0.00252D0,  0.00177D0,  0.00122D0,  0.00086D0,  0.00056D0,
     &     0.00034D0,  0.00023D0,  0.00012D0,  0.00004D0,  0.00001D0,
     &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0/
      DATA (FMRS(1,4,I,26),I=1,49)/
     &     9.19912D0,  6.98269D0,  5.29980D0,  4.50945D0,  4.02062D0,
     &     3.67776D0,  2.78497D0,  2.10203D0,  1.77824D0,  1.57626D0,
     &     1.43169D0,  1.05466D0,  0.76454D0,  0.62772D0,  0.54298D0,
     &     0.48357D0,  0.40325D0,  0.32867D0,  0.25488D0,  0.20830D0,
     &     0.14936D0,  0.11205D0,  0.08608D0,  0.06328D0,  0.04729D0,
     &     0.03598D0,  0.02762D0,  0.02140D0,  0.01669D0,  0.01307D0,
     &     0.01014D0,  0.00780D0,  0.00595D0,  0.00443D0,  0.00330D0,
     &     0.00240D0,  0.00168D0,  0.00114D0,  0.00081D0,  0.00053D0,
     &     0.00032D0,  0.00022D0,  0.00012D0,  0.00004D0,  0.00001D0,
     &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0/
      DATA (FMRS(1,4,I,27),I=1,49)/
     &    10.00621D0,  7.54783D0,  5.69293D0,  4.82623D0,  4.29189D0,
     &     3.91798D0,  2.94832D0,  2.21133D0,  1.86373D0,  1.64761D0,
     &     1.49327D0,  1.09257D0,  0.78647D0,  0.64301D0,  0.55451D0,
     &     0.49265D0,  0.40930D0,  0.33223D0,  0.25638D0,  0.20876D0,
     &     0.14886D0,  0.11122D0,  0.08517D0,  0.06240D0,  0.04650D0,
     &     0.03528D0,  0.02702D0,  0.02089D0,  0.01623D0,  0.01267D0,
     &     0.00980D0,  0.00752D0,  0.00573D0,  0.00425D0,  0.00316D0,
     &     0.00230D0,  0.00159D0,  0.00107D0,  0.00077D0,  0.00050D0,
     &     0.00030D0,  0.00020D0,  0.00011D0,  0.00003D0,  0.00001D0,
     &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0/
      DATA (FMRS(1,4,I,28),I=1,49)/
     &    10.80590D0,  8.10435D0,  6.07766D0,  5.13510D0,  4.55568D0,
     &     4.15111D0,  3.10583D0,  2.31601D0,  1.94527D0,  1.71546D0,
     &     1.55167D0,  1.12822D0,  0.80689D0,  0.65715D0,  0.56511D0,
     &     0.50095D0,  0.41476D0,  0.33539D0,  0.25764D0,  0.20907D0,
     &     0.14833D0,  0.11039D0,  0.08428D0,  0.06155D0,  0.04576D0,
     &     0.03462D0,  0.02647D0,  0.02040D0,  0.01582D0,  0.01230D0,
     &     0.00949D0,  0.00726D0,  0.00551D0,  0.00409D0,  0.00302D0,
     &     0.00221D0,  0.00152D0,  0.00102D0,  0.00073D0,  0.00048D0,
     &     0.00029D0,  0.00019D0,  0.00010D0,  0.00004D0,  0.00001D0,
     &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0/
      DATA (FMRS(1,4,I,29),I=1,49)/
     &    11.65207D0,  8.68978D0,  6.48001D0,  5.45700D0,  4.82993D0,
     &     4.39300D0,  3.26826D0,  2.42329D0,  2.02852D0,  1.78454D0,
     &     1.61099D0,  1.16415D0,  0.82729D0,  0.67117D0,  0.57557D0,
     &     0.50910D0,  0.42008D0,  0.33842D0,  0.25880D0,  0.20930D0,
     &     0.14773D0,  0.10953D0,  0.08337D0,  0.06069D0,  0.04500D0,
     &     0.03397D0,  0.02591D0,  0.01991D0,  0.01541D0,  0.01194D0,
     &     0.00919D0,  0.00702D0,  0.00530D0,  0.00393D0,  0.00290D0,
     &     0.00211D0,  0.00145D0,  0.00096D0,  0.00070D0,  0.00045D0,
     &     0.00028D0,  0.00018D0,  0.00010D0,  0.00003D0,  0.00001D0,
     &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0/
      DATA (FMRS(1,4,I,30),I=1,49)/
     &    12.52131D0,  9.28774D0,  6.88859D0,  5.78276D0,  5.10678D0,
     &     4.63673D0,  3.43094D0,  2.53005D0,  2.11104D0,  1.85281D0,
     &     1.66948D0,  1.19929D0,  0.84705D0,  0.68466D0,  0.58556D0,
     &     0.51685D0,  0.42507D0,  0.34121D0,  0.25979D0,  0.20942D0,
     &     0.14709D0,  0.10866D0,  0.08245D0,  0.05983D0,  0.04425D0,
     &     0.03334D0,  0.02536D0,  0.01943D0,  0.01501D0,  0.01160D0,
     &     0.00891D0,  0.00678D0,  0.00511D0,  0.00378D0,  0.00279D0,
     &     0.00202D0,  0.00138D0,  0.00091D0,  0.00067D0,  0.00043D0,
     &     0.00026D0,  0.00018D0,  0.00010D0,  0.00003D0,  0.00001D0,
     &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0/
      DATA (FMRS(1,4,I,31),I=1,49)/
     &    13.38978D0,  9.88200D0,  7.29246D0,  6.10376D0,  5.37897D0,
     &     4.87592D0,  3.58970D0,  2.63365D0,  2.19084D0,  1.91866D0,
     &     1.72578D0,  1.23288D0,  0.86578D0,  0.69738D0,  0.59494D0,
     &     0.52409D0,  0.42970D0,  0.34375D0,  0.26065D0,  0.20947D0,
     &     0.14644D0,  0.10781D0,  0.08158D0,  0.05902D0,  0.04354D0,
     &     0.03274D0,  0.02484D0,  0.01899D0,  0.01463D0,  0.01128D0,
     &     0.00865D0,  0.00657D0,  0.00493D0,  0.00364D0,  0.00268D0,
     &     0.00194D0,  0.00132D0,  0.00087D0,  0.00064D0,  0.00041D0,
     &     0.00025D0,  0.00017D0,  0.00009D0,  0.00003D0,  0.00001D0,
     &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0/
      DATA (FMRS(1,4,I,32),I=1,49)/
     &    14.23688D0, 10.45864D0,  7.68231D0,  6.41264D0,  5.64030D0,
     &     5.10517D0,  3.74102D0,  2.73180D0,  2.26617D0,  1.98065D0,
     &     1.77865D0,  1.26417D0,  0.88305D0,  0.70902D0,  0.60346D0,
     &     0.53062D0,  0.43382D0,  0.34595D0,  0.26134D0,  0.20941D0,
     &     0.14577D0,  0.10696D0,  0.08072D0,  0.05825D0,  0.04287D0,
     &     0.03215D0,  0.02436D0,  0.01857D0,  0.01428D0,  0.01098D0,
     &     0.00840D0,  0.00638D0,  0.00476D0,  0.00351D0,  0.00258D0,
     &     0.00187D0,  0.00127D0,  0.00083D0,  0.00061D0,  0.00039D0,
     &     0.00024D0,  0.00016D0,  0.00009D0,  0.00002D0,  0.00001D0,
     &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0/
      DATA (FMRS(1,4,I,33),I=1,49)/
     &    15.13941D0, 11.07021D0,  8.09390D0,  6.73786D0,  5.91493D0,
     &     5.34574D0,  3.89907D0,  2.83385D0,  2.34427D0,  2.04479D0,
     &     1.83327D0,  1.29634D0,  0.90070D0,  0.72088D0,  0.61213D0,
     &     0.53725D0,  0.43798D0,  0.34817D0,  0.26202D0,  0.20935D0,
     &     0.14510D0,  0.10612D0,  0.07988D0,  0.05749D0,  0.04221D0,
     &     0.03158D0,  0.02388D0,  0.01816D0,  0.01393D0,  0.01069D0,
     &     0.00816D0,  0.00620D0,  0.00459D0,  0.00338D0,  0.00248D0,
     &     0.00179D0,  0.00121D0,  0.00080D0,  0.00058D0,  0.00037D0,
     &     0.00022D0,  0.00014D0,  0.00008D0,  0.00002D0,  0.00001D0,
     &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0/
      DATA (FMRS(1,4,I,34),I=1,49)/
     &    16.04276D0, 11.67919D0,  8.50158D0,  7.05899D0,  6.18548D0,
     &     5.58230D0,  4.05359D0,  2.93300D0,  2.41985D0,  2.10667D0,
     &     1.88583D0,  1.32700D0,  0.91732D0,  0.73194D0,  0.62013D0,
     &     0.54331D0,  0.44171D0,  0.35007D0,  0.26248D0,  0.20913D0,
     &     0.14434D0,  0.10523D0,  0.07901D0,  0.05671D0,  0.04155D0,
     &     0.03102D0,  0.02340D0,  0.01777D0,  0.01360D0,  0.01042D0,
     &     0.00793D0,  0.00600D0,  0.00446D0,  0.00326D0,  0.00238D0,
     &     0.00173D0,  0.00118D0,  0.00076D0,  0.00055D0,  0.00036D0,
     &     0.00022D0,  0.00014D0,  0.00007D0,  0.00002D0,  0.00001D0,
     &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0/
      DATA (FMRS(1,4,I,35),I=1,49)/
     &    16.94849D0, 12.28721D0,  8.90688D0,  7.37746D0,  6.45332D0,
     &     5.81617D0,  4.20570D0,  3.03017D0,  2.49373D0,  2.16705D0,
     &     1.93704D0,  1.35674D0,  0.93336D0,  0.74257D0,  0.62781D0,
     &     0.54911D0,  0.44527D0,  0.35187D0,  0.26291D0,  0.20892D0,
     &     0.14363D0,  0.10440D0,  0.07819D0,  0.05599D0,  0.04092D0,
     &     0.03050D0,  0.02296D0,  0.01740D0,  0.01329D0,  0.01017D0,
     &     0.00772D0,  0.00583D0,  0.00433D0,  0.00315D0,  0.00229D0,
     &     0.00167D0,  0.00114D0,  0.00073D0,  0.00053D0,  0.00035D0,
     &     0.00021D0,  0.00013D0,  0.00007D0,  0.00002D0,  0.00001D0,
     &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0/
      DATA (FMRS(1,4,I,36),I=1,49)/
     &    17.83243D0, 12.87802D0,  9.29900D0,  7.68475D0,  6.71127D0,
     &     6.04107D0,  4.35129D0,  3.12272D0,  2.56388D0,  2.22424D0,
     &     1.98545D0,  1.38466D0,  0.94830D0,  0.75241D0,  0.63488D0,
     &     0.55441D0,  0.44848D0,  0.35346D0,  0.26323D0,  0.20867D0,
     &     0.14292D0,  0.10358D0,  0.07741D0,  0.05529D0,  0.04033D0,
     &     0.03000D0,  0.02255D0,  0.01705D0,  0.01300D0,  0.00993D0,
     &     0.00753D0,  0.00566D0,  0.00421D0,  0.00306D0,  0.00221D0,
     &     0.00161D0,  0.00110D0,  0.00071D0,  0.00051D0,  0.00034D0,
     &     0.00020D0,  0.00013D0,  0.00007D0,  0.00002D0,  0.00001D0,
     &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0/
      DATA (FMRS(1,4,I,37),I=1,49)/
     &    18.74867D0, 13.48785D0,  9.70200D0,  7.99976D0,  6.97522D0,
     &     6.27087D0,  4.49936D0,  3.21639D0,  2.63465D0,  2.28182D0,
     &     2.03408D0,  1.41252D0,  0.96307D0,  0.76207D0,  0.64176D0,
     &     0.55956D0,  0.45155D0,  0.35492D0,  0.26347D0,  0.20834D0,
     &     0.14216D0,  0.10274D0,  0.07660D0,  0.05459D0,  0.03974D0,
     &     0.02950D0,  0.02213D0,  0.01670D0,  0.01272D0,  0.00970D0,
     &     0.00733D0,  0.00550D0,  0.00408D0,  0.00297D0,  0.00214D0,
     &     0.00155D0,  0.00105D0,  0.00068D0,  0.00049D0,  0.00032D0,
     &     0.00018D0,  0.00012D0,  0.00007D0,  0.00002D0,  0.00001D0,
     &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0/
      DATA (FMRS(1,4,I,38),I=1,49)/
     &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
     &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
     &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
     &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
     &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
     &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
     &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
     &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
     &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
     &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0/
      DATA (FMRS(1,5,I, 1),I=1,49)/
     &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
     &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
     &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
     &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
     &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
     &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
     &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
     &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
     &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
     &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0/
      DATA (FMRS(1,5,I, 2),I=1,49)/
     &     0.00003D0,  0.00003D0,  0.00002D0,  0.00002D0,  0.00002D0,
     &     0.00002D0,  0.00002D0,  0.00002D0,  0.00002D0,  0.00002D0,
     &     0.00002D0,  0.00002D0,  0.00002D0,  0.00002D0,  0.00002D0,
     &     0.00002D0,  0.00002D0,  0.00001D0,  0.00001D0,  0.00001D0,
     &     0.00001D0,  0.00001D0,  0.00001D0,  0.00001D0,  0.00001D0,
     &     0.00001D0,  0.00001D0,  0.00001D0,  0.00001D0,  0.00001D0,
     &     0.00001D0,  0.00001D0,  0.00001D0,  0.00000D0,  0.00000D0,
     &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
     &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
     &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0/
      DATA (FMRS(1,5,I, 3),I=1,49)/
     &     0.03227D0,  0.02900D0,  0.02605D0,  0.02445D0,  0.02338D0,
     &     0.02257D0,  0.02019D0,  0.01798D0,  0.01674D0,  0.01586D0,
     &     0.01516D0,  0.01302D0,  0.01084D0,  0.00956D0,  0.00865D0,
     &     0.00795D0,  0.00692D0,  0.00587D0,  0.00477D0,  0.00405D0,
     &     0.00317D0,  0.00263D0,  0.00225D0,  0.00190D0,  0.00163D0,
     &     0.00139D0,  0.00119D0,  0.00101D0,  0.00085D0,  0.00072D0,
     &     0.00059D0,  0.00048D0,  0.00039D0,  0.00031D0,  0.00025D0,
     &     0.00019D0,  0.00015D0,  0.00011D0,  0.00008D0,  0.00006D0,
     &     0.00004D0,  0.00003D0,  0.00002D0,  0.00001D0,  0.00000D0,
     &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0/
      DATA (FMRS(1,5,I, 4),I=1,49)/
     &     0.08412D0,  0.07493D0,  0.06672D0,  0.06231D0,  0.05935D0,
     &     0.05713D0,  0.05068D0,  0.04474D0,  0.04144D0,  0.03913D0,
     &     0.03731D0,  0.03177D0,  0.02623D0,  0.02303D0,  0.02077D0,
     &     0.01905D0,  0.01652D0,  0.01397D0,  0.01129D0,  0.00957D0,
     &     0.00745D0,  0.00615D0,  0.00525D0,  0.00441D0,  0.00375D0,
     &     0.00320D0,  0.00272D0,  0.00230D0,  0.00193D0,  0.00161D0,
     &     0.00132D0,  0.00108D0,  0.00087D0,  0.00069D0,  0.00054D0,
     &     0.00042D0,  0.00032D0,  0.00024D0,  0.00018D0,  0.00013D0,
     &     0.00009D0,  0.00006D0,  0.00004D0,  0.00001D0,  0.00000D0,
     &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0/
      DATA (FMRS(1,5,I, 5),I=1,49)/
     &     0.14877D0,  0.13082D0,  0.11499D0,  0.10659D0,  0.10097D0,
     &     0.09680D0,  0.08477D0,  0.07388D0,  0.06791D0,  0.06379D0,
     &     0.06056D0,  0.05091D0,  0.04152D0,  0.03619D0,  0.03249D0,
     &     0.02969D0,  0.02561D0,  0.02153D0,  0.01729D0,  0.01459D0,
     &     0.01127D0,  0.00925D0,  0.00785D0,  0.00655D0,  0.00553D0,
     &     0.00469D0,  0.00396D0,  0.00333D0,  0.00278D0,  0.00231D0,
     &     0.00189D0,  0.00153D0,  0.00123D0,  0.00097D0,  0.00076D0,
     &     0.00059D0,  0.00045D0,  0.00034D0,  0.00025D0,  0.00018D0,
     &     0.00012D0,  0.00009D0,  0.00006D0,  0.00001D0,  0.00000D0,
     &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0/
      DATA (FMRS(1,5,I, 6),I=1,49)/
     &     0.22202D0,  0.19306D0,  0.16779D0,  0.15452D0,  0.14570D0,
     &     0.13918D0,  0.12051D0,  0.10386D0,  0.09484D0,  0.08868D0,
     &     0.08388D0,  0.06972D0,  0.05624D0,  0.04872D0,  0.04355D0,
     &     0.03966D0,  0.03405D0,  0.02848D0,  0.02274D0,  0.01911D0,
     &     0.01466D0,  0.01197D0,  0.01011D0,  0.00838D0,  0.00703D0,
     &     0.00592D0,  0.00498D0,  0.00416D0,  0.00346D0,  0.00286D0,
     &     0.00233D0,  0.00188D0,  0.00150D0,  0.00118D0,  0.00092D0,
     &     0.00071D0,  0.00054D0,  0.00041D0,  0.00030D0,  0.00021D0,
     &     0.00015D0,  0.00010D0,  0.00007D0,  0.00001D0,  0.00000D0,
     &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0/
      DATA (FMRS(1,5,I, 7),I=1,49)/
     &     0.30272D0,  0.26063D0,  0.22430D0,  0.20535D0,  0.19284D0,
     &     0.18362D0,  0.15743D0,  0.13433D0,  0.12195D0,  0.11355D0,
     &     0.10705D0,  0.08808D0,  0.07034D0,  0.06058D0,  0.05394D0,
     &     0.04898D0,  0.04185D0,  0.03485D0,  0.02767D0,  0.02316D0,
     &     0.01766D0,  0.01434D0,  0.01204D0,  0.00992D0,  0.00828D0,
     &     0.00693D0,  0.00580D0,  0.00482D0,  0.00399D0,  0.00328D0,
     &     0.00266D0,  0.00214D0,  0.00170D0,  0.00133D0,  0.00104D0,
     &     0.00080D0,  0.00060D0,  0.00045D0,  0.00033D0,  0.00024D0,
     &     0.00016D0,  0.00011D0,  0.00007D0,  0.00001D0,  0.00000D0,
     &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0/
      DATA (FMRS(1,5,I, 8),I=1,49)/
     &     0.40640D0,  0.34641D0,  0.29514D0,  0.26863D0,  0.25121D0,
     &     0.23843D0,  0.20237D0,  0.17095D0,  0.15427D0,  0.14303D0,
     &     0.13440D0,  0.10944D0,  0.08650D0,  0.07407D0,  0.06568D0,
     &     0.05945D0,  0.05056D0,  0.04189D0,  0.03309D0,  0.02757D0,
     &     0.02089D0,  0.01686D0,  0.01408D0,  0.01153D0,  0.00956D0,
     &     0.00796D0,  0.00662D0,  0.00548D0,  0.00451D0,  0.00369D0,
     &     0.00298D0,  0.00239D0,  0.00189D0,  0.00148D0,  0.00114D0,
     &     0.00087D0,  0.00066D0,  0.00049D0,  0.00037D0,  0.00026D0,
     &     0.00018D0,  0.00012D0,  0.00007D0,  0.00001D0,  0.00000D0,
     &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0/
      DATA (FMRS(1,5,I, 9),I=1,49)/
     &     0.51210D0,  0.43288D0,  0.36574D0,  0.33126D0,  0.30871D0,
     &     0.29222D0,  0.24594D0,  0.20601D0,  0.18499D0,  0.17091D0,
     &     0.16014D0,  0.12927D0,  0.10130D0,  0.08631D0,  0.07626D0,
     &     0.06885D0,  0.05833D0,  0.04813D0,  0.03783D0,  0.03141D0,
     &     0.02366D0,  0.01900D0,  0.01580D0,  0.01287D0,  0.01061D0,
     &     0.00880D0,  0.00728D0,  0.00600D0,  0.00491D0,  0.00401D0,
     &     0.00322D0,  0.00257D0,  0.00203D0,  0.00158D0,  0.00122D0,
     &     0.00093D0,  0.00070D0,  0.00052D0,  0.00039D0,  0.00028D0,
     &     0.00018D0,  0.00012D0,  0.00007D0,  0.00001D0,  0.00000D0,
     &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0/
      DATA (FMRS(1,5,I,10),I=1,49)/
     &     0.62615D0,  0.52524D0,  0.44038D0,  0.39709D0,  0.36888D0,
     &     0.34831D0,  0.29091D0,  0.24179D0,  0.21613D0,  0.19903D0,
     &     0.18601D0,  0.14895D0,  0.11579D0,  0.09820D0,  0.08649D0,
     &     0.07789D0,  0.06575D0,  0.05404D0,  0.04228D0,  0.03498D0,
     &     0.02621D0,  0.02095D0,  0.01734D0,  0.01405D0,  0.01153D0,
     &     0.00952D0,  0.00784D0,  0.00644D0,  0.00525D0,  0.00426D0,
     &     0.00342D0,  0.00272D0,  0.00213D0,  0.00166D0,  0.00127D0,
     &     0.00097D0,  0.00073D0,  0.00054D0,  0.00040D0,  0.00029D0,
     &     0.00019D0,  0.00013D0,  0.00007D0,  0.00001D0,  0.00000D0,
     &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0/
      DATA (FMRS(1,5,I,11),I=1,49)/
     &     0.72756D0,  0.60673D0,  0.50572D0,  0.45443D0,  0.42111D0,
     &     0.39687D0,  0.32951D0,  0.27226D0,  0.24251D0,  0.22276D0,
     &     0.20777D0,  0.16535D0,  0.12775D0,  0.10795D0,  0.09484D0,
     &     0.08524D0,  0.07175D0,  0.05879D0,  0.04583D0,  0.03782D0,
     &     0.02821D0,  0.02247D0,  0.01853D0,  0.01496D0,  0.01223D0,
     &     0.01005D0,  0.00826D0,  0.00676D0,  0.00549D0,  0.00445D0,
     &     0.00355D0,  0.00282D0,  0.00221D0,  0.00171D0,  0.00131D0,
     &     0.00099D0,  0.00074D0,  0.00055D0,  0.00041D0,  0.00029D0,
     &     0.00019D0,  0.00013D0,  0.00007D0,  0.00001D0,  0.00000D0,
     &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0/
      DATA (FMRS(1,5,I,12),I=1,49)/
     &     0.97596D0,  0.80419D0,  0.66232D0,  0.59100D0,  0.54494D0,
     &     0.51159D0,  0.41968D0,  0.34257D0,  0.30297D0,  0.27688D0,
     &     0.25720D0,  0.20210D0,  0.15417D0,  0.12932D0,  0.11303D0,
     &     0.10119D0,  0.08465D0,  0.06892D0,  0.05333D0,  0.04376D0,
     &     0.03235D0,  0.02557D0,  0.02094D0,  0.01675D0,  0.01359D0,
     &     0.01109D0,  0.00904D0,  0.00734D0,  0.00594D0,  0.00477D0,
     &     0.00379D0,  0.00299D0,  0.00233D0,  0.00179D0,  0.00137D0,
     &     0.00103D0,  0.00077D0,  0.00057D0,  0.00042D0,  0.00030D0,
     &     0.00019D0,  0.00013D0,  0.00007D0,  0.00001D0,  0.00000D0,
     &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0/
      DATA (FMRS(1,5,I,13),I=1,49)/
     &     1.22977D0,  1.00344D0,  0.81836D0,  0.72605D0,  0.66675D0,
     &     0.62396D0,  0.50684D0,  0.40963D0,  0.36016D0,  0.32776D0,
     &     0.30345D0,  0.23597D0,  0.17813D0,  0.14851D0,  0.12924D0,
     &     0.11531D0,  0.09599D0,  0.07773D0,  0.05977D0,  0.04882D0,
     &     0.03581D0,  0.02811D0,  0.02289D0,  0.01818D0,  0.01465D0,
     &     0.01187D0,  0.00963D0,  0.00777D0,  0.00625D0,  0.00500D0,
     &     0.00395D0,  0.00310D0,  0.00241D0,  0.00185D0,  0.00140D0,
     &     0.00105D0,  0.00078D0,  0.00058D0,  0.00043D0,  0.00031D0,
     &     0.00019D0,  0.00013D0,  0.00007D0,  0.00001D0,  0.00000D0,
     &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0/
      DATA (FMRS(1,5,I,14),I=1,49)/
     &     1.55816D0,  1.25825D0,  1.01555D0,  0.89552D0,  0.81883D0,
     &     0.76371D0,  0.61389D0,  0.49095D0,  0.42897D0,  0.38864D0,
     &     0.35854D0,  0.27572D0,  0.20581D0,  0.17047D0,  0.14766D0,
     &     0.13128D0,  0.10869D0,  0.08751D0,  0.06683D0,  0.05430D0,
     &     0.03950D0,  0.03078D0,  0.02489D0,  0.01962D0,  0.01569D0,
     &     0.01264D0,  0.01018D0,  0.00817D0,  0.00653D0,  0.00519D0,
     &     0.00408D0,  0.00319D0,  0.00246D0,  0.00188D0,  0.00142D0,
     &     0.00106D0,  0.00078D0,  0.00058D0,  0.00043D0,  0.00031D0,
     &     0.00019D0,  0.00012D0,  0.00007D0,  0.00001D0,  0.00000D0,
     &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0/
      DATA (FMRS(1,5,I,15),I=1,49)/
     &     1.94525D0,  1.55494D0,  1.24230D0,  1.08896D0,  0.99149D0,
     &     0.92172D0,  0.73335D0,  0.58046D0,  0.50409D0,  0.45471D0,
     &     0.41801D0,  0.31797D0,  0.23473D0,  0.19316D0,  0.16655D0,
     &     0.14754D0,  0.12149D0,  0.09725D0,  0.07376D0,  0.05961D0,
     &     0.04299D0,  0.03326D0,  0.02672D0,  0.02089D0,  0.01659D0,
     &     0.01327D0,  0.01061D0,  0.00847D0,  0.00673D0,  0.00532D0,
     &     0.00416D0,  0.00323D0,  0.00248D0,  0.00188D0,  0.00142D0,
     &     0.00105D0,  0.00077D0,  0.00057D0,  0.00042D0,  0.00031D0,
     &     0.00019D0,  0.00012D0,  0.00007D0,  0.00001D0,  0.00000D0,
     &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0/
      DATA (FMRS(1,5,I,16),I=1,49)/
     &     2.34531D0,  1.85826D0,  1.47159D0,  1.28330D0,  1.16416D0,
     &     1.07915D0,  0.85101D0,  0.66758D0,  0.57668D0,  0.51821D0,
     &     0.47495D0,  0.35786D0,  0.26164D0,  0.21408D0,  0.18385D0,
     &     0.16236D0,  0.13305D0,  0.10596D0,  0.07987D0,  0.06425D0,
     &     0.04599D0,  0.03535D0,  0.02822D0,  0.02192D0,  0.01729D0,
     &     0.01375D0,  0.01093D0,  0.00867D0,  0.00685D0,  0.00540D0,
     &     0.00420D0,  0.00325D0,  0.00248D0,  0.00188D0,  0.00141D0,
     &     0.00104D0,  0.00076D0,  0.00056D0,  0.00041D0,  0.00030D0,
     &     0.00018D0,  0.00011D0,  0.00006D0,  0.00001D0,  0.00000D0,
     &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0/
      DATA (FMRS(1,5,I,17),I=1,49)/
     &     2.80142D0,  2.20072D0,  1.72790D0,  1.49927D0,  1.35523D0,
     &     1.25280D0,  0.97945D0,  0.76167D0,  0.65458D0,  0.58603D0,
     &     0.53553D0,  0.39978D0,  0.28955D0,  0.23561D0,  0.20153D0,
     &     0.17743D0,  0.14473D0,  0.11467D0,  0.08591D0,  0.06880D0,
     &     0.04888D0,  0.03733D0,  0.02963D0,  0.02285D0,  0.01791D0,
     &     0.01415D0,  0.01119D0,  0.00883D0,  0.00694D0,  0.00544D0,
     &     0.00421D0,  0.00324D0,  0.00247D0,  0.00186D0,  0.00139D0,
     &     0.00102D0,  0.00075D0,  0.00055D0,  0.00040D0,  0.00029D0,
     &     0.00018D0,  0.00011D0,  0.00006D0,  0.00001D0,  0.00000D0,
     &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0/
      DATA (FMRS(1,5,I,18),I=1,49)/
     &     3.21652D0,  2.50960D0,  1.95700D0,  1.69126D0,  1.52443D0,
     &     1.40610D0,  1.09176D0,  0.84313D0,  0.72161D0,  0.64414D0,
     &     0.58724D0,  0.43516D0,  0.31280D0,  0.25339D0,  0.21606D0,
     &     0.18974D0,  0.15419D0,  0.12166D0,  0.09071D0,  0.07236D0,
     &     0.05109D0,  0.03882D0,  0.03067D0,  0.02352D0,  0.01834D0,
     &     0.01442D0,  0.01135D0,  0.00892D0,  0.00699D0,  0.00545D0,
     &     0.00421D0,  0.00322D0,  0.00245D0,  0.00184D0,  0.00137D0,
     &     0.00100D0,  0.00073D0,  0.00053D0,  0.00039D0,  0.00029D0,
     &     0.00017D0,  0.00010D0,  0.00006D0,  0.00001D0,  0.00000D0,
     &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0/
      DATA (FMRS(1,5,I,19),I=1,49)/
     &     3.76652D0,  2.91536D0,  2.25532D0,  1.93997D0,  1.74280D0,
     &     1.60338D0,  1.23496D0,  0.94601D0,  0.80577D0,  0.71678D0,
     &     0.65167D0,  0.47873D0,  0.34109D0,  0.27487D0,  0.23349D0,
     &     0.20445D0,  0.16541D0,  0.12988D0,  0.09628D0,  0.07646D0,
     &     0.05359D0,  0.04046D0,  0.03178D0,  0.02422D0,  0.01877D0,
     &     0.01467D0,  0.01149D0,  0.00898D0,  0.00700D0,  0.00543D0,
     &     0.00418D0,  0.00319D0,  0.00241D0,  0.00180D0,  0.00134D0,
     &     0.00098D0,  0.00071D0,  0.00052D0,  0.00038D0,  0.00028D0,
     &     0.00017D0,  0.00010D0,  0.00006D0,  0.00001D0,  0.00000D0,
     &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0/
      DATA (FMRS(1,5,I,20),I=1,49)/
     &     4.30575D0,  3.30993D0,  2.54302D0,  2.17866D0,  1.95165D0,
     &     1.79153D0,  1.37036D0,  1.04242D0,  0.88422D0,  0.78423D0,
     &     0.71130D0,  0.51866D0,  0.36673D0,  0.29419D0,  0.24910D0,
     &     0.21757D0,  0.17534D0,  0.13711D0,  0.10112D0,  0.07999D0,
     &     0.05571D0,  0.04184D0,  0.03270D0,  0.02477D0,  0.01909D0,
     &     0.01486D0,  0.01158D0,  0.00901D0,  0.00699D0,  0.00541D0,
     &     0.00414D0,  0.00315D0,  0.00237D0,  0.00177D0,  0.00131D0,
     &     0.00095D0,  0.00069D0,  0.00050D0,  0.00037D0,  0.00027D0,
     &     0.00016D0,  0.00009D0,  0.00005D0,  0.00001D0,  0.00000D0,
     &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0/
      DATA (FMRS(1,5,I,21),I=1,49)/
     &     4.82956D0,  3.69021D0,  2.81808D0,  2.40576D0,  2.14966D0,
     &     1.96944D0,  1.49728D0,  1.13198D0,  0.95669D0,  0.84628D0,
     &     0.76597D0,  0.55486D0,  0.38968D0,  0.31136D0,  0.26288D0,
     &     0.22909D0,  0.18399D0,  0.14333D0,  0.10523D0,  0.08295D0,
     &     0.05744D0,  0.04293D0,  0.03340D0,  0.02518D0,  0.01931D0,
     &     0.01496D0,  0.01161D0,  0.00900D0,  0.00696D0,  0.00536D0,
     &     0.00409D0,  0.00310D0,  0.00233D0,  0.00173D0,  0.00128D0,
     &     0.00093D0,  0.00067D0,  0.00049D0,  0.00036D0,  0.00027D0,
     &     0.00015D0,  0.00009D0,  0.00005D0,  0.00001D0,  0.00000D0,
     &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0/
      DATA (FMRS(1,5,I,22),I=1,49)/
     &     5.55546D0,  4.21326D0,  3.19353D0,  2.71436D0,  2.41786D0,
     &     2.20981D0,  1.66741D0,  1.25104D0,  1.05255D0,  0.92807D0,
     &     0.83783D0,  0.60198D0,  0.41926D0,  0.33333D0,  0.28043D0,
     &     0.24370D0,  0.19489D0,  0.15111D0,  0.11032D0,  0.08657D0,
     &     0.05953D0,  0.04421D0,  0.03422D0,  0.02563D0,  0.01955D0,
     &     0.01506D0,  0.01163D0,  0.00897D0,  0.00690D0,  0.00529D0,
     &     0.00403D0,  0.00304D0,  0.00227D0,  0.00168D0,  0.00124D0,
     &     0.00090D0,  0.00064D0,  0.00047D0,  0.00035D0,  0.00026D0,
     &     0.00015D0,  0.00008D0,  0.00005D0,  0.00001D0,  0.00000D0,
     &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0/
      DATA (FMRS(1,5,I,23),I=1,49)/
     &     6.30033D0,  4.74567D0,  3.57260D0,  3.02443D0,  2.68642D0,
     &     2.44984D0,  1.83585D0,  1.36787D0,  1.14612D0,  1.00758D0,
     &     0.90746D0,  0.64718D0,  0.44730D0,  0.35401D0,  0.29686D0,
     &     0.25731D0,  0.20497D0,  0.15824D0,  0.11492D0,  0.08982D0,
     &     0.06136D0,  0.04532D0,  0.03489D0,  0.02598D0,  0.01971D0,
     &     0.01511D0,  0.01161D0,  0.00892D0,  0.00683D0,  0.00522D0,
     &     0.00395D0,  0.00297D0,  0.00222D0,  0.00163D0,  0.00120D0,
     &     0.00087D0,  0.00062D0,  0.00045D0,  0.00034D0,  0.00025D0,
     &     0.00014D0,  0.00008D0,  0.00005D0,  0.00001D0,  0.00000D0,
     &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0/
      DATA (FMRS(1,5,I,24),I=1,49)/
     &     7.03684D0,  5.26796D0,  3.94145D0,  3.32468D0,  2.94556D0,
     &     2.68082D0,  1.99651D0,  1.47829D0,  1.23404D0,  1.08198D0,
     &     0.97239D0,  0.68884D0,  0.47281D0,  0.37266D0,  0.31157D0,
     &     0.26944D0,  0.21386D0,  0.16445D0,  0.11886D0,  0.09256D0,
     &     0.06285D0,  0.04618D0,  0.03539D0,  0.02621D0,  0.01979D0,
     &     0.01510D0,  0.01155D0,  0.00884D0,  0.00675D0,  0.00513D0,
     &     0.00387D0,  0.00290D0,  0.00216D0,  0.00159D0,  0.00116D0,
     &     0.00084D0,  0.00060D0,  0.00044D0,  0.00033D0,  0.00024D0,
     &     0.00014D0,  0.00007D0,  0.00004D0,  0.00001D0,  0.00000D0,
     &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0/
      DATA (FMRS(1,5,I,25),I=1,49)/
     &     7.83575D0,  5.83079D0,  4.33631D0,  3.64485D0,  3.22112D0,
     &     2.92590D0,  2.16582D0,  1.59383D0,  1.32566D0,  1.15927D0,
     &     1.03966D0,  0.73165D0,  0.49881D0,  0.39156D0,  0.32642D0,
     &     0.28163D0,  0.22275D0,  0.17063D0,  0.12274D0,  0.09523D0,
     &     0.06428D0,  0.04699D0,  0.03585D0,  0.02642D0,  0.01984D0,
     &     0.01507D0,  0.01148D0,  0.00875D0,  0.00665D0,  0.00505D0,
     &     0.00380D0,  0.00284D0,  0.00210D0,  0.00154D0,  0.00112D0,
     &     0.00081D0,  0.00058D0,  0.00042D0,  0.00031D0,  0.00024D0,
     &     0.00014D0,  0.00007D0,  0.00004D0,  0.00001D0,  0.00000D0,
     &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0/
      DATA (FMRS(1,5,I,26),I=1,49)/
     &     8.65815D0,  6.40607D0,  4.73699D0,  3.96832D0,  3.49865D0,
     &     3.17213D0,  2.33459D0,  1.70806D0,  1.41577D0,  1.23500D0,
     &     1.10538D0,  0.77305D0,  0.52365D0,  0.40947D0,  0.34040D0,
     &     0.29306D0,  0.23101D0,  0.17630D0,  0.12625D0,  0.09761D0,
     &     0.06550D0,  0.04766D0,  0.03620D0,  0.02654D0,  0.01984D0,
     &     0.01501D0,  0.01139D0,  0.00864D0,  0.00655D0,  0.00495D0,
     &     0.00371D0,  0.00276D0,  0.00204D0,  0.00149D0,  0.00108D0,
     &     0.00078D0,  0.00056D0,  0.00041D0,  0.00030D0,  0.00023D0,
     &     0.00014D0,  0.00007D0,  0.00004D0,  0.00001D0,  0.00000D0,
     &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0/
      DATA (FMRS(1,5,I,27),I=1,49)/
     &     9.48773D0,  6.98283D0,  5.13620D0,  4.28942D0,  3.77342D0,
     &     3.41540D0,  2.50025D0,  1.81942D0,  1.50325D0,  1.30829D0,
     &     1.16884D0,  0.81270D0,  0.54722D0,  0.42638D0,  0.35354D0,
     &     0.30375D0,  0.23869D0,  0.18153D0,  0.12945D0,  0.09975D0,
     &     0.06658D0,  0.04823D0,  0.03648D0,  0.02662D0,  0.01982D0,
     &     0.01493D0,  0.01129D0,  0.00853D0,  0.00645D0,  0.00486D0,
     &     0.00363D0,  0.00270D0,  0.00199D0,  0.00145D0,  0.00105D0,
     &     0.00075D0,  0.00054D0,  0.00039D0,  0.00030D0,  0.00022D0,
     &     0.00014D0,  0.00007D0,  0.00004D0,  0.00001D0,  0.00000D0,
     &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0/
      DATA (FMRS(1,5,I,28),I=1,49)/
     &    10.30763D0,  7.54945D0,  5.52601D0,  4.60181D0,  4.04004D0,
     &     3.65097D0,  2.65960D0,  1.92581D0,  1.58647D0,  1.37780D0,
     &     1.22885D0,  0.84989D0,  0.56911D0,  0.44198D0,  0.36560D0,
     &     0.31352D0,  0.24565D0,  0.18623D0,  0.13228D0,  0.10162D0,
     &     0.06750D0,  0.04868D0,  0.03669D0,  0.02666D0,  0.01976D0,
     &     0.01484D0,  0.01118D0,  0.00842D0,  0.00635D0,  0.00477D0,
     &     0.00355D0,  0.00263D0,  0.00193D0,  0.00141D0,  0.00102D0,
     &     0.00073D0,  0.00052D0,  0.00038D0,  0.00029D0,  0.00022D0,
     &     0.00014D0,  0.00007D0,  0.00004D0,  0.00001D0,  0.00000D0,
     &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0/
      DATA (FMRS(1,5,I,29),I=1,49)/
     &    11.17527D0,  8.14579D0,  5.93397D0,  4.92768D0,  4.31749D0,
     &     3.89565D0,  2.82415D0,  2.03499D0,  1.67156D0,  1.44867D0,
     &     1.28991D0,  0.88743D0,  0.59103D0,  0.45751D0,  0.37756D0,
     &     0.32318D0,  0.25249D0,  0.19081D0,  0.13501D0,  0.10341D0,
     &     0.06835D0,  0.04909D0,  0.03686D0,  0.02667D0,  0.01969D0,
     &     0.01473D0,  0.01106D0,  0.00831D0,  0.00624D0,  0.00467D0,
     &     0.00347D0,  0.00257D0,  0.00188D0,  0.00136D0,  0.00099D0,
     &     0.00070D0,  0.00050D0,  0.00037D0,  0.00028D0,  0.00021D0,
     &     0.00014D0,  0.00007D0,  0.00004D0,  0.00001D0,  0.00000D0,
     &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0/
      DATA (FMRS(1,5,I,30),I=1,49)/
     &    12.06456D0,  8.75358D0,  6.34740D0,  5.25678D0,  4.59701D0,
     &     4.14168D0,  2.98858D0,  2.14338D0,  1.75569D0,  1.51853D0,
     &     1.34994D0,  0.92405D0,  0.61221D0,  0.47241D0,  0.38898D0,
     &     0.33235D0,  0.25894D0,  0.19508D0,  0.13752D0,  0.10502D0,
     &     0.06908D0,  0.04942D0,  0.03697D0,  0.02664D0,  0.01960D0,
     &     0.01461D0,  0.01093D0,  0.00819D0,  0.00613D0,  0.00458D0,
     &     0.00339D0,  0.00250D0,  0.00183D0,  0.00132D0,  0.00095D0,
     &     0.00068D0,  0.00049D0,  0.00036D0,  0.00027D0,  0.00021D0,
     &     0.00014D0,  0.00007D0,  0.00004D0,  0.00001D0,  0.00000D0,
     &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0/
      DATA (FMRS(1,5,I,31),I=1,49)/
     &    12.95374D0,  9.35831D0,  6.75669D0,  5.58162D0,  4.87232D0,
     &     4.38360D0,  3.14942D0,  2.24882D0,  1.83726D0,  1.58610D0,
     &     1.40790D0,  0.95916D0,  0.63237D0,  0.48653D0,  0.39975D0,
     &     0.34099D0,  0.26498D0,  0.19905D0,  0.13983D0,  0.10648D0,
     &     0.06974D0,  0.04970D0,  0.03705D0,  0.02660D0,  0.01950D0,
     &     0.01449D0,  0.01081D0,  0.00807D0,  0.00603D0,  0.00449D0,
     &     0.00332D0,  0.00244D0,  0.00178D0,  0.00129D0,  0.00093D0,
     &     0.00066D0,  0.00047D0,  0.00035D0,  0.00026D0,  0.00020D0,
     &     0.00013D0,  0.00007D0,  0.00004D0,  0.00001D0,  0.00000D0,
     &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0/
      DATA (FMRS(1,5,I,32),I=1,49)/
     &    13.81822D0,  9.94319D0,  7.15042D0,  5.89310D0,  5.13569D0,
     &     4.61461D0,  3.30209D0,  2.34827D0,  1.91389D0,  1.64940D0,
     &     1.46205D0,  0.99170D0,  0.65086D0,  0.49940D0,  0.40952D0,
     &     0.34877D0,  0.27037D0,  0.20256D0,  0.14182D0,  0.10773D0,
     &     0.07026D0,  0.04989D0,  0.03708D0,  0.02652D0,  0.01938D0,
     &     0.01436D0,  0.01068D0,  0.00795D0,  0.00592D0,  0.00440D0,
     &     0.00325D0,  0.00238D0,  0.00174D0,  0.00125D0,  0.00090D0,
     &     0.00064D0,  0.00046D0,  0.00034D0,  0.00026D0,  0.00020D0,
     &     0.00013D0,  0.00007D0,  0.00004D0,  0.00001D0,  0.00000D0,
     &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0/
      DATA (FMRS(1,5,I,33),I=1,49)/
     &    14.74174D0, 10.56553D0,  7.56770D0,  6.22245D0,  5.41371D0,
     &     4.85814D0,  3.46239D0,  2.45228D0,  1.99384D0,  1.71531D0,
     &     1.51837D0,  1.02539D0,  0.66993D0,  0.51263D0,  0.41953D0,
     &     0.35674D0,  0.27589D0,  0.20614D0,  0.14386D0,  0.10899D0,
     &     0.07078D0,  0.05009D0,  0.03711D0,  0.02645D0,  0.01927D0,
     &     0.01422D0,  0.01055D0,  0.00784D0,  0.00582D0,  0.00432D0,
     &     0.00318D0,  0.00233D0,  0.00169D0,  0.00122D0,  0.00087D0,
     &     0.00062D0,  0.00044D0,  0.00033D0,  0.00025D0,  0.00020D0,
     &     0.00013D0,  0.00007D0,  0.00004D0,  0.00001D0,  0.00000D0,
     &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0/
      DATA (FMRS(1,5,I,34),I=1,49)/
     &    15.66159D0, 11.18202D0,  7.97872D0,  6.54573D0,  5.68591D0,
     &     5.09611D0,  3.61802D0,  2.55254D0,  2.07056D0,  1.77835D0,
     &     1.57208D0,  1.05721D0,  0.68771D0,  0.52486D0,  0.42872D0,
     &     0.36401D0,  0.28085D0,  0.20931D0,  0.14560D0,  0.11004D0,
     &     0.07117D0,  0.05019D0,  0.03707D0,  0.02633D0,  0.01912D0,
     &     0.01408D0,  0.01041D0,  0.00771D0,  0.00572D0,  0.00423D0,
     &     0.00311D0,  0.00227D0,  0.00165D0,  0.00118D0,  0.00085D0,
     &     0.00060D0,  0.00043D0,  0.00032D0,  0.00025D0,  0.00020D0,
     &     0.00013D0,  0.00007D0,  0.00004D0,  0.00001D0,  0.00000D0,
     &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0/
      DATA (FMRS(1,5,I,35),I=1,49)/
     &    16.58568D0, 11.79905D0,  8.38856D0,  6.86738D0,  5.95633D0,
     &     5.33223D0,  3.77185D0,  2.65127D0,  2.14594D0,  1.84019D0,
     &     1.62469D0,  1.08825D0,  0.70498D0,  0.53670D0,  0.43761D0,
     &     0.37103D0,  0.28563D0,  0.21235D0,  0.14727D0,  0.11103D0,
     &     0.07154D0,  0.05029D0,  0.03704D0,  0.02622D0,  0.01898D0,
     &     0.01394D0,  0.01028D0,  0.00760D0,  0.00562D0,  0.00415D0,
     &     0.00304D0,  0.00222D0,  0.00161D0,  0.00115D0,  0.00082D0,
     &     0.00058D0,  0.00042D0,  0.00031D0,  0.00024D0,  0.00019D0,
     &     0.00013D0,  0.00007D0,  0.00004D0,  0.00001D0,  0.00000D0,
     &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0/
      DATA (FMRS(1,5,I,36),I=1,49)/
     &    17.48656D0, 12.39804D0,  8.78469D0,  7.17746D0,  6.21652D0,
     &     5.55909D0,  3.91895D0,  2.74520D0,  2.21743D0,  1.89869D0,
     &     1.67437D0,  1.11736D0,  0.72106D0,  0.54767D0,  0.44580D0,
     &     0.37747D0,  0.28999D0,  0.21509D0,  0.14875D0,  0.11190D0,
     &     0.07184D0,  0.05035D0,  0.03698D0,  0.02610D0,  0.01884D0,
     &     0.01380D0,  0.01016D0,  0.00749D0,  0.00553D0,  0.00407D0,
     &     0.00298D0,  0.00217D0,  0.00157D0,  0.00112D0,  0.00080D0,
     &     0.00057D0,  0.00041D0,  0.00031D0,  0.00024D0,  0.00019D0,
     &     0.00013D0,  0.00007D0,  0.00004D0,  0.00001D0,  0.00000D0,
     &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0/
      DATA (FMRS(1,5,I,37),I=1,49)/
     &    18.41889D0, 13.01534D0,  9.19117D0,  7.49481D0,  6.48233D0,
     &     5.79049D0,  4.06828D0,  2.84006D0,  2.28940D0,  1.95745D0,
     &     1.72416D0,  1.14634D0,  0.73693D0,  0.55843D0,  0.45379D0,
     &     0.38373D0,  0.29419D0,  0.21770D0,  0.15013D0,  0.11269D0,
     &     0.07209D0,  0.05037D0,  0.03690D0,  0.02596D0,  0.01869D0,
     &     0.01365D0,  0.01003D0,  0.00738D0,  0.00543D0,  0.00399D0,
     &     0.00291D0,  0.00212D0,  0.00153D0,  0.00109D0,  0.00078D0,
     &     0.00055D0,  0.00040D0,  0.00030D0,  0.00023D0,  0.00019D0,
     &     0.00013D0,  0.00007D0,  0.00004D0,  0.00001D0,  0.00000D0,
     &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0/
      DATA (FMRS(1,5,I,38),I=1,49)/
     &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
     &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
     &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
     &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
     &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
     &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
     &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
     &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
     &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
     &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0/
      DATA (FMRS(1,6,I, 1),I=1,49)/
     &     0.44989D0,  0.39539D0,  0.34747D0,  0.32216D0,  0.30531D0,
     &     0.29285D0,  0.25722D0,  0.22578D0,  0.20909D0,  0.19792D0,
     &     0.18955D0,  0.16547D0,  0.14378D0,  0.13212D0,  0.12429D0,
     &     0.11845D0,  0.11003D0,  0.10150D0,  0.09208D0,  0.08532D0,
     &     0.07497D0,  0.06641D0,  0.05872D0,  0.04993D0,  0.04200D0,
     &     0.03492D0,  0.02867D0,  0.02327D0,  0.01867D0,  0.01463D0,
     &     0.01149D0,  0.00885D0,  0.00675D0,  0.00511D0,  0.00375D0,
     &     0.00275D0,  0.00200D0,  0.00140D0,  0.00092D0,  0.00067D0,
     &     0.00045D0,  0.00028D0,  0.00020D0,  0.00007D0,  0.00002D0,
     &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0/
      DATA (FMRS(1,6,I, 2),I=1,49)/
     &     0.46639D0,  0.41136D0,  0.36279D0,  0.33706D0,  0.31990D0,
     &     0.30719D0,  0.27073D0,  0.23840D0,  0.22115D0,  0.20956D0,
     &     0.20084D0,  0.17557D0,  0.15249D0,  0.13993D0,  0.13142D0,
     &     0.12504D0,  0.11578D0,  0.10635D0,  0.09591D0,  0.08845D0,
     &     0.07719D0,  0.06805D0,  0.05996D0,  0.05084D0,  0.04269D0,
     &     0.03544D0,  0.02909D0,  0.02361D0,  0.01895D0,  0.01488D0,
     &     0.01169D0,  0.00902D0,  0.00689D0,  0.00524D0,  0.00385D0,
     &     0.00283D0,  0.00206D0,  0.00146D0,  0.00096D0,  0.00071D0,
     &     0.00048D0,  0.00029D0,  0.00022D0,  0.00008D0,  0.00002D0,
     &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0/
      DATA (FMRS(1,6,I, 3),I=1,49)/
     &     0.50684D0,  0.44821D0,  0.39632D0,  0.36876D0,  0.35036D0,
     &     0.33670D0,  0.29743D0,  0.26242D0,  0.24363D0,  0.23094D0,
     &     0.22132D0,  0.19327D0,  0.16725D0,  0.15293D0,  0.14314D0,
     &     0.13576D0,  0.12501D0,  0.11402D0,  0.10188D0,  0.09328D0,
     &     0.08055D0,  0.07049D0,  0.06177D0,  0.05212D0,  0.04362D0,
     &     0.03613D0,  0.02960D0,  0.02400D0,  0.01926D0,  0.01513D0,
     &     0.01189D0,  0.00918D0,  0.00704D0,  0.00535D0,  0.00395D0,
     &     0.00290D0,  0.00211D0,  0.00152D0,  0.00101D0,  0.00074D0,
     &     0.00051D0,  0.00031D0,  0.00023D0,  0.00008D0,  0.00002D0,
     &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0/
      DATA (FMRS(1,6,I, 4),I=1,49)/
     &     0.55058D0,  0.48672D0,  0.43021D0,  0.40019D0,  0.38014D0,
     &     0.36526D0,  0.32246D0,  0.28426D0,  0.26371D0,  0.24981D0,
     &     0.23922D0,  0.20826D0,  0.17939D0,  0.16343D0,  0.15249D0,
     &     0.14425D0,  0.13221D0,  0.11993D0,  0.10640D0,  0.09689D0,
     &     0.08300D0,  0.07224D0,  0.06305D0,  0.05299D0,  0.04421D0,
     &     0.03653D0,  0.02989D0,  0.02420D0,  0.01939D0,  0.01523D0,
     &     0.01197D0,  0.00924D0,  0.00709D0,  0.00537D0,  0.00399D0,
     &     0.00293D0,  0.00213D0,  0.00154D0,  0.00102D0,  0.00074D0,
     &     0.00053D0,  0.00032D0,  0.00024D0,  0.00009D0,  0.00002D0,
     &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0/
      DATA (FMRS(1,6,I, 5),I=1,49)/
     &     0.61607D0,  0.54291D0,  0.47835D0,  0.44415D0,  0.42133D0,
     &     0.40441D0,  0.35583D0,  0.31254D0,  0.28927D0,  0.27353D0,
     &     0.26150D0,  0.22639D0,  0.19363D0,  0.17555D0,  0.16316D0,
     &     0.15384D0,  0.14026D0,  0.12643D0,  0.11130D0,  0.10077D0,
     &     0.08558D0,  0.07403D0,  0.06431D0,  0.05381D0,  0.04474D0,
     &     0.03686D0,  0.03008D0,  0.02432D0,  0.01945D0,  0.01528D0,
     &     0.01199D0,  0.00925D0,  0.00709D0,  0.00537D0,  0.00398D0,
     &     0.00293D0,  0.00214D0,  0.00154D0,  0.00103D0,  0.00074D0,
     &     0.00052D0,  0.00032D0,  0.00024D0,  0.00008D0,  0.00002D0,
     &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0/
      DATA (FMRS(1,6,I, 6),I=1,49)/
     &     0.68336D0,  0.60005D0,  0.52679D0,  0.48807D0,  0.46228D0,
     &     0.44318D0,  0.38846D0,  0.33984D0,  0.31375D0,  0.29611D0,
     &     0.28263D0,  0.24332D0,  0.20674D0,  0.18660D0,  0.17283D0,
     &     0.16249D0,  0.14745D0,  0.13219D0,  0.11560D0,  0.10414D0,
     &     0.08779D0,  0.07555D0,  0.06535D0,  0.05447D0,  0.04515D0,
     &     0.03709D0,  0.03021D0,  0.02439D0,  0.01946D0,  0.01528D0,
     &     0.01197D0,  0.00923D0,  0.00707D0,  0.00536D0,  0.00396D0,
     &     0.00291D0,  0.00213D0,  0.00154D0,  0.00103D0,  0.00073D0,
     &     0.00051D0,  0.00032D0,  0.00023D0,  0.00008D0,  0.00002D0,
     &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0/
      DATA (FMRS(1,6,I, 7),I=1,49)/
     &     0.76355D0,  0.66723D0,  0.58292D0,  0.53852D0,  0.50902D0,
     &     0.48721D0,  0.42490D0,  0.36978D0,  0.34030D0,  0.32042D0,
     &     0.30522D0,  0.26107D0,  0.22021D0,  0.19782D0,  0.18257D0,
     &     0.17114D0,  0.15457D0,  0.13784D0,  0.11976D0,  0.10736D0,
     &     0.08987D0,  0.07693D0,  0.06629D0,  0.05503D0,  0.04547D0,
     &     0.03726D0,  0.03027D0,  0.02439D0,  0.01942D0,  0.01523D0,
     &     0.01190D0,  0.00918D0,  0.00701D0,  0.00533D0,  0.00392D0,
     &     0.00287D0,  0.00209D0,  0.00153D0,  0.00101D0,  0.00073D0,
     &     0.00050D0,  0.00032D0,  0.00022D0,  0.00007D0,  0.00002D0,
     &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0/
      DATA (FMRS(1,6,I, 8),I=1,49)/
     &     0.86343D0,  0.75010D0,  0.65144D0,  0.59973D0,  0.56547D0,
     &     0.54018D0,  0.46822D0,  0.40492D0,  0.37123D0,  0.34856D0,
     &     0.33127D0,  0.28125D0,  0.23529D0,  0.21028D0,  0.19331D0,
     &     0.18063D0,  0.16233D0,  0.14394D0,  0.12420D0,  0.11077D0,
     &     0.09202D0,  0.07835D0,  0.06722D0,  0.05555D0,  0.04575D0,
     &     0.03737D0,  0.03028D0,  0.02434D0,  0.01934D0,  0.01514D0,
     &     0.01181D0,  0.00909D0,  0.00694D0,  0.00526D0,  0.00387D0,
     &     0.00282D0,  0.00206D0,  0.00150D0,  0.00100D0,  0.00072D0,
     &     0.00049D0,  0.00031D0,  0.00021D0,  0.00008D0,  0.00002D0,
     &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0/
      DATA (FMRS(1,6,I, 9),I=1,49)/
     &     0.96361D0,  0.83251D0,  0.71897D0,  0.65971D0,  0.62055D0,
     &     0.59171D0,  0.50993D0,  0.43838D0,  0.40047D0,  0.37504D0,
     &     0.35567D0,  0.29991D0,  0.24906D0,  0.22156D0,  0.20298D0,
     &     0.18914D0,  0.16924D0,  0.14933D0,  0.12809D0,  0.11373D0,
     &     0.09387D0,  0.07954D0,  0.06798D0,  0.05596D0,  0.04595D0,
     &     0.03743D0,  0.03026D0,  0.02427D0,  0.01926D0,  0.01505D0,
     &     0.01172D0,  0.00900D0,  0.00687D0,  0.00519D0,  0.00383D0,
     &     0.00278D0,  0.00203D0,  0.00148D0,  0.00098D0,  0.00071D0,
     &     0.00048D0,  0.00031D0,  0.00021D0,  0.00008D0,  0.00002D0,
     &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0/
      DATA (FMRS(1,6,I,10),I=1,49)/
     &     1.07479D0,  0.92315D0,  0.79255D0,  0.72469D0,  0.67997D0,
     &     0.64711D0,  0.55427D0,  0.47353D0,  0.43097D0,  0.40251D0,
     &     0.38089D0,  0.31894D0,  0.26290D0,  0.23280D0,  0.21256D0,
     &     0.19753D0,  0.17599D0,  0.15455D0,  0.13181D0,  0.11654D0,
     &     0.09559D0,  0.08062D0,  0.06865D0,  0.05629D0,  0.04608D0,
     &     0.03743D0,  0.03019D0,  0.02416D0,  0.01913D0,  0.01493D0,
     &     0.01161D0,  0.00890D0,  0.00677D0,  0.00511D0,  0.00377D0,
     &     0.00274D0,  0.00200D0,  0.00145D0,  0.00096D0,  0.00068D0,
     &     0.00046D0,  0.00030D0,  0.00020D0,  0.00008D0,  0.00002D0,
     &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0/
      DATA (FMRS(1,6,I,11),I=1,49)/
     &     1.17232D0,  1.00213D0,  0.85623D0,  0.78069D0,  0.73104D0,
     &     0.69461D0,  0.59200D0,  0.50321D0,  0.45658D0,  0.42550D0,
     &     0.40194D0,  0.33467D0,  0.27424D0,  0.24195D0,  0.22032D0,
     &     0.20431D0,  0.18142D0,  0.15872D0,  0.13477D0,  0.11875D0,
     &     0.09692D0,  0.08144D0,  0.06915D0,  0.05653D0,  0.04615D0,
     &     0.03741D0,  0.03011D0,  0.02406D0,  0.01902D0,  0.01482D0,
     &     0.01152D0,  0.00881D0,  0.00669D0,  0.00505D0,  0.00371D0,
     &     0.00270D0,  0.00197D0,  0.00143D0,  0.00094D0,  0.00066D0,
     &     0.00045D0,  0.00029D0,  0.00020D0,  0.00008D0,  0.00002D0,
     &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0/
      DATA (FMRS(1,6,I,12),I=1,49)/
     &     1.41135D0,  1.19389D0,  1.00931D0,  0.91452D0,  0.85253D0,
     &     0.80723D0,  0.68048D0,  0.57199D0,  0.51554D0,  0.47813D0,
     &     0.44992D0,  0.37007D0,  0.29939D0,  0.26209D0,  0.23729D0,
     &     0.21905D0,  0.19312D0,  0.16764D0,  0.14100D0,  0.12337D0,
     &     0.09965D0,  0.08309D0,  0.07010D0,  0.05694D0,  0.04624D0,
     &     0.03729D0,  0.02989D0,  0.02378D0,  0.01873D0,  0.01456D0,
     &     0.01128D0,  0.00861D0,  0.00651D0,  0.00490D0,  0.00360D0,
     &     0.00260D0,  0.00189D0,  0.00137D0,  0.00090D0,  0.00062D0,
     &     0.00043D0,  0.00028D0,  0.00019D0,  0.00007D0,  0.00002D0,
     &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0/
      DATA (FMRS(1,6,I,13),I=1,49)/
     &     1.65256D0,  1.38522D0,  1.16028D0,  1.04559D0,  0.97092D0,
     &     0.91653D0,  0.76529D0,  0.63704D0,  0.57085D0,  0.52722D0,
     &     0.49446D0,  0.40243D0,  0.32201D0,  0.28002D0,  0.25230D0,
     &     0.23200D0,  0.20332D0,  0.17533D0,  0.14629D0,  0.12724D0,
     &     0.10187D0,  0.08438D0,  0.07080D0,  0.05719D0,  0.04622D0,
     &     0.03712D0,  0.02965D0,  0.02350D0,  0.01845D0,  0.01430D0,
     &     0.01104D0,  0.00841D0,  0.00634D0,  0.00476D0,  0.00349D0,
     &     0.00251D0,  0.00182D0,  0.00132D0,  0.00086D0,  0.00060D0,
     &     0.00042D0,  0.00026D0,  0.00018D0,  0.00006D0,  0.00002D0,
     &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0/
      DATA (FMRS(1,6,I,14),I=1,49)/
     &     1.96387D0,  1.62942D0,  1.35081D0,  1.20988D0,  1.11860D0,
     &     1.05236D0,  0.86939D0,  0.71589D0,  0.63738D0,  0.58593D0,
     &     0.54750D0,  0.44041D0,  0.34815D0,  0.30054D0,  0.26935D0,
     &     0.24663D0,  0.21473D0,  0.18383D0,  0.15206D0,  0.13140D0,
     &     0.10419D0,  0.08567D0,  0.07145D0,  0.05736D0,  0.04609D0,
     &     0.03684D0,  0.02930D0,  0.02313D0,  0.01809D0,  0.01398D0,
     &     0.01074D0,  0.00816D0,  0.00615D0,  0.00459D0,  0.00334D0,
     &     0.00240D0,  0.00174D0,  0.00125D0,  0.00082D0,  0.00057D0,
     &     0.00038D0,  0.00024D0,  0.00016D0,  0.00006D0,  0.00002D0,
     &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0/
      DATA (FMRS(1,6,I,15),I=1,49)/
     &     2.33902D0,  1.92024D0,  1.57497D0,  1.40179D0,  1.29021D0,
     &     1.20956D0,  0.98833D0,  0.80477D0,  0.71175D0,  0.65116D0,
     &     0.60614D0,  0.48174D0,  0.37612D0,  0.32226D0,  0.28724D0,
     &     0.26188D0,  0.22649D0,  0.19248D0,  0.15783D0,  0.13549D0,
     &     0.10637D0,  0.08680D0,  0.07195D0,  0.05738D0,  0.04585D0,
     &     0.03646D0,  0.02886D0,  0.02269D0,  0.01768D0,  0.01360D0,
     &     0.01043D0,  0.00789D0,  0.00592D0,  0.00441D0,  0.00321D0,
     &     0.00230D0,  0.00166D0,  0.00118D0,  0.00078D0,  0.00054D0,
     &     0.00037D0,  0.00022D0,  0.00015D0,  0.00006D0,  0.00002D0,
     &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0/
      DATA (FMRS(1,6,I,16),I=1,49)/
     &     2.72482D0,  2.21608D0,  1.80052D0,  1.59364D0,  1.46096D0,
     &     1.36541D0,  1.10490D0,  0.89086D0,  0.78327D0,  0.71357D0,
     &     0.66200D0,  0.52058D0,  0.40200D0,  0.34217D0,  0.30354D0,
     &     0.27569D0,  0.23704D0,  0.20015D0,  0.16285D0,  0.13900D0,
     &     0.10817D0,  0.08767D0,  0.07227D0,  0.05729D0,  0.04554D0,
     &     0.03606D0,  0.02842D0,  0.02227D0,  0.01728D0,  0.01326D0,
     &     0.01012D0,  0.00763D0,  0.00571D0,  0.00425D0,  0.00307D0,
     &     0.00219D0,  0.00158D0,  0.00112D0,  0.00073D0,  0.00051D0,
     &     0.00035D0,  0.00021D0,  0.00014D0,  0.00005D0,  0.00002D0,
     &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0/
      DATA (FMRS(1,6,I,17),I=1,49)/
     &     3.16184D0,  2.54784D0,  2.05090D0,  1.80533D0,  1.64858D0,
     &     1.53608D0,  1.23122D0,  0.98314D0,  0.85944D0,  0.77972D0,
     &     0.72099D0,  0.56109D0,  0.42865D0,  0.36249D0,  0.32006D0,
     &     0.28962D0,  0.24759D0,  0.20774D0,  0.16775D0,  0.14236D0,
     &     0.10984D0,  0.08843D0,  0.07249D0,  0.05712D0,  0.04518D0,
     &     0.03560D0,  0.02794D0,  0.02182D0,  0.01686D0,  0.01291D0,
     &     0.00980D0,  0.00737D0,  0.00550D0,  0.00408D0,  0.00294D0,
     &     0.00209D0,  0.00150D0,  0.00107D0,  0.00069D0,  0.00049D0,
     &     0.00034D0,  0.00019D0,  0.00014D0,  0.00005D0,  0.00001D0,
     &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0/
      DATA (FMRS(1,6,I,18),I=1,49)/
     &     3.56226D0,  2.84906D0,  2.27616D0,  1.99475D0,  1.81581D0,
     &     1.68774D0,  1.34241D0,  1.06358D0,  0.92544D0,  0.83679D0,
     &     0.77171D0,  0.59551D0,  0.45100D0,  0.37940D0,  0.33372D0,
     &     0.30107D0,  0.25620D0,  0.21386D0,  0.17164D0,  0.14499D0,
     &     0.11108D0,  0.08895D0,  0.07258D0,  0.05692D0,  0.04483D0,
     &     0.03518D0,  0.02753D0,  0.02142D0,  0.01651D0,  0.01260D0,
     &     0.00954D0,  0.00717D0,  0.00532D0,  0.00393D0,  0.00284D0,
     &     0.00201D0,  0.00144D0,  0.00103D0,  0.00066D0,  0.00045D0,
     &     0.00032D0,  0.00018D0,  0.00013D0,  0.00004D0,  0.00001D0,
     &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0/
      DATA (FMRS(1,6,I,19),I=1,49)/
     &     4.09416D0,  3.24567D0,  2.57011D0,  2.24065D0,  2.03209D0,
     &     1.88332D0,  1.48448D0,  1.16540D0,  1.00850D0,  0.90831D0,
     &     0.83504D0,  0.63803D0,  0.47827D0,  0.39987D0,  0.35015D0,
     &     0.31478D0,  0.26640D0,  0.22104D0,  0.17612D0,  0.14797D0,
     &     0.11241D0,  0.08943D0,  0.07259D0,  0.05659D0,  0.04434D0,
     &     0.03464D0,  0.02699D0,  0.02092D0,  0.01606D0,  0.01221D0,
     &     0.00922D0,  0.00691D0,  0.00511D0,  0.00375D0,  0.00271D0,
     &     0.00191D0,  0.00136D0,  0.00097D0,  0.00063D0,  0.00043D0,
     &     0.00030D0,  0.00017D0,  0.00012D0,  0.00004D0,  0.00001D0,
     &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0/
      DATA (FMRS(1,6,I,20),I=1,49)/
     &     4.61257D0,  3.62885D0,  2.85161D0,  2.47491D0,  2.23738D0,
     &     2.06842D0,  1.61774D0,  1.26001D0,  1.08527D0,  0.97415D0,
     &     0.89315D0,  0.67662D0,  0.50274D0,  0.41811D0,  0.36471D0,
     &     0.32688D0,  0.27534D0,  0.22728D0,  0.17996D0,  0.15048D0,
     &     0.11349D0,  0.08979D0,  0.07253D0,  0.05626D0,  0.04389D0,
     &     0.03414D0,  0.02651D0,  0.02047D0,  0.01566D0,  0.01187D0,
     &     0.00894D0,  0.00668D0,  0.00493D0,  0.00361D0,  0.00261D0,
     &     0.00182D0,  0.00129D0,  0.00093D0,  0.00059D0,  0.00040D0,
     &     0.00028D0,  0.00016D0,  0.00011D0,  0.00004D0,  0.00001D0,
     &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0/
      DATA (FMRS(1,6,I,21),I=1,49)/
     &     5.12222D0,  4.00261D0,  3.12404D0,  2.70057D0,  2.43446D0,
     &     2.24566D0,  1.74429D0,  1.34911D0,  1.15718D0,  1.03559D0,
     &     0.94721D0,  0.71215D0,  0.52500D0,  0.43455D0,  0.37776D0,
     &     0.33766D0,  0.28323D0,  0.23271D0,  0.18324D0,  0.15257D0,
     &     0.11432D0,  0.08998D0,  0.07237D0,  0.05588D0,  0.04342D0,
     &     0.03365D0,  0.02604D0,  0.02004D0,  0.01529D0,  0.01156D0,
     &     0.00869D0,  0.00646D0,  0.00477D0,  0.00348D0,  0.00251D0,
     &     0.00175D0,  0.00124D0,  0.00088D0,  0.00057D0,  0.00038D0,
     &     0.00026D0,  0.00015D0,  0.00010D0,  0.00004D0,  0.00001D0,
     &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0/
      DATA (FMRS(1,6,I,22),I=1,49)/
     &     5.82554D0,  4.51423D0,  3.49391D0,  3.00548D0,  2.69986D0,
     &     2.48370D0,  1.91285D0,  1.46678D0,  1.25167D0,  1.11601D0,
     &     1.01775D0,  0.75806D0,  0.55345D0,  0.45543D0,  0.39424D0,
     &     0.35121D0,  0.29307D0,  0.23942D0,  0.18722D0,  0.15507D0,
     &     0.11526D0,  0.09014D0,  0.07211D0,  0.05536D0,  0.04279D0,
     &     0.03301D0,  0.02543D0,  0.01950D0,  0.01483D0,  0.01117D0,
     &     0.00837D0,  0.00620D0,  0.00456D0,  0.00332D0,  0.00238D0,
     &     0.00166D0,  0.00117D0,  0.00083D0,  0.00053D0,  0.00035D0,
     &     0.00024D0,  0.00015D0,  0.00010D0,  0.00003D0,  0.00001D0,
     &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0/
      DATA (FMRS(1,6,I,23),I=1,49)/
     &     6.54676D0,  5.03439D0,  3.86673D0,  3.31126D0,  2.96506D0,
     &     2.72090D0,  2.07933D0,  1.58195D0,  1.34364D0,  1.19398D0,
     &     1.08591D0,  0.80195D0,  0.58033D0,  0.47501D0,  0.40960D0,
     &     0.36377D0,  0.30212D0,  0.24551D0,  0.19078D0,  0.15726D0,
     &     0.11602D0,  0.09021D0,  0.07181D0,  0.05483D0,  0.04218D0,
     &     0.03240D0,  0.02486D0,  0.01900D0,  0.01440D0,  0.01081D0,
     &     0.00808D0,  0.00597D0,  0.00437D0,  0.00317D0,  0.00227D0,
     &     0.00157D0,  0.00111D0,  0.00080D0,  0.00050D0,  0.00034D0,
     &     0.00022D0,  0.00014D0,  0.00009D0,  0.00003D0,  0.00001D0,
     &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0/
      DATA (FMRS(1,6,I,24),I=1,49)/
     &     7.26565D0,  5.54876D0,  4.23247D0,  3.60982D0,  3.22311D0,
     &     2.95109D0,  2.23956D0,  1.69183D0,  1.43093D0,  1.26769D0,
     &     1.15015D0,  0.84286D0,  0.60508D0,  0.49288D0,  0.42351D0,
     &     0.37509D0,  0.31017D0,  0.25086D0,  0.19381D0,  0.15905D0,
     &     0.11655D0,  0.09013D0,  0.07142D0,  0.05426D0,  0.04157D0,
     &     0.03180D0,  0.02431D0,  0.01852D0,  0.01399D0,  0.01048D0,
     &     0.00780D0,  0.00574D0,  0.00419D0,  0.00304D0,  0.00217D0,
     &     0.00149D0,  0.00106D0,  0.00075D0,  0.00048D0,  0.00032D0,
     &     0.00021D0,  0.00013D0,  0.00009D0,  0.00003D0,  0.00001D0,
     &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0/
      DATA (FMRS(1,6,I,25),I=1,49)/
     &     8.04192D0,  6.10017D0,  4.62168D0,  3.92618D0,  3.49572D0,
     &     3.19370D0,  2.40717D0,  1.80591D0,  1.52114D0,  1.34361D0,
     &     1.21613D0,  0.88453D0,  0.63003D0,  0.51078D0,  0.43739D0,
     &     0.38633D0,  0.31813D0,  0.25609D0,  0.19674D0,  0.16076D0,
     &     0.11701D0,  0.09001D0,  0.07101D0,  0.05368D0,  0.04095D0,
     &     0.03121D0,  0.02377D0,  0.01805D0,  0.01359D0,  0.01015D0,
     &     0.00753D0,  0.00553D0,  0.00402D0,  0.00291D0,  0.00207D0,
     &     0.00142D0,  0.00101D0,  0.00071D0,  0.00045D0,  0.00030D0,
     &     0.00020D0,  0.00012D0,  0.00008D0,  0.00003D0,  0.00001D0,
     &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0/
      DATA (FMRS(1,6,I,26),I=1,49)/
     &     8.84513D0,  6.66663D0,  5.01863D0,  4.24745D0,  3.77171D0,
     &     3.43873D0,  2.57518D0,  1.91937D0,  1.61043D0,  1.41849D0,
     &     1.28102D0,  0.92509D0,  0.65405D0,  0.52788D0,  0.45056D0,
     &     0.39694D0,  0.32555D0,  0.26091D0,  0.19936D0,  0.16223D0,
     &     0.11732D0,  0.08979D0,  0.07053D0,  0.05307D0,  0.04031D0,
     &     0.03061D0,  0.02325D0,  0.01759D0,  0.01321D0,  0.00982D0,
     &     0.00728D0,  0.00532D0,  0.00387D0,  0.00279D0,  0.00197D0,
     &     0.00136D0,  0.00096D0,  0.00067D0,  0.00043D0,  0.00029D0,
     &     0.00019D0,  0.00011D0,  0.00007D0,  0.00003D0,  0.00001D0,
     &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0/
      DATA (FMRS(1,6,I,27),I=1,49)/
     &     9.65435D0,  7.23356D0,  5.41328D0,  4.56560D0,  4.04426D0,
     &     3.68017D0,  2.73960D0,  2.02962D0,  1.69683D0,  1.49072D0,
     &     1.34344D0,  0.96379D0,  0.67674D0,  0.54393D0,  0.46286D0,
     &     0.40680D0,  0.33241D0,  0.26531D0,  0.20171D0,  0.16351D0,
     &     0.11755D0,  0.08953D0,  0.07005D0,  0.05247D0,  0.03970D0,
     &     0.03004D0,  0.02275D0,  0.01715D0,  0.01284D0,  0.00953D0,
     &     0.00704D0,  0.00513D0,  0.00373D0,  0.00268D0,  0.00189D0,
     &     0.00130D0,  0.00092D0,  0.00064D0,  0.00040D0,  0.00027D0,
     &     0.00018D0,  0.00010D0,  0.00007D0,  0.00002D0,  0.00001D0,
     &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0/
      DATA (FMRS(1,6,I,28),I=1,49)/
     &    10.45602D0,  7.79175D0,  5.79941D0,  4.87575D0,  4.30926D0,
     &     3.91444D0,  2.89810D0,  2.13519D0,  1.77921D0,  1.55938D0,
     &     1.40263D0,  1.00018D0,  0.69787D0,  0.55877D0,  0.47417D0,
     &     0.41582D0,  0.33862D0,  0.26925D0,  0.20376D0,  0.16459D0,
     &     0.11767D0,  0.08923D0,  0.06955D0,  0.05189D0,  0.03911D0,
     &     0.02950D0,  0.02227D0,  0.01675D0,  0.01249D0,  0.00926D0,
     &     0.00681D0,  0.00496D0,  0.00359D0,  0.00258D0,  0.00181D0,
     &     0.00125D0,  0.00088D0,  0.00062D0,  0.00038D0,  0.00026D0,
     &     0.00017D0,  0.00010D0,  0.00007D0,  0.00002D0,  0.00001D0,
     &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0/
      DATA (FMRS(1,6,I,29),I=1,49)/
     &    11.30416D0,  8.37884D0,  6.20316D0,  5.19892D0,  4.58469D0,
     &     4.15747D0,  3.06152D0,  2.24335D0,  1.86330D0,  1.62927D0,
     &     1.46273D0,  1.03685D0,  0.71898D0,  0.57351D0,  0.48535D0,
     &     0.42471D0,  0.34469D0,  0.27305D0,  0.20570D0,  0.16558D0,
     &     0.11773D0,  0.08889D0,  0.06902D0,  0.05129D0,  0.03852D0,
     &     0.02896D0,  0.02179D0,  0.01634D0,  0.01216D0,  0.00899D0,
     &     0.00659D0,  0.00479D0,  0.00347D0,  0.00248D0,  0.00174D0,
     &     0.00119D0,  0.00084D0,  0.00059D0,  0.00036D0,  0.00024D0,
     &     0.00016D0,  0.00009D0,  0.00006D0,  0.00002D0,  0.00001D0,
     &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0/
      DATA (FMRS(1,6,I,30),I=1,49)/
     &    12.17534D0,  8.97841D0,  6.61310D0,  5.52592D0,  4.86271D0,
     &     4.40230D0,  3.22516D0,  2.35097D0,  1.94663D0,  1.69833D0,
     &     1.52199D0,  1.07270D0,  0.73942D0,  0.58770D0,  0.49605D0,
     &     0.43317D0,  0.35042D0,  0.27659D0,  0.20745D0,  0.16642D0,
     &     0.11771D0,  0.08850D0,  0.06847D0,  0.05068D0,  0.03793D0,
     &     0.02842D0,  0.02132D0,  0.01595D0,  0.01184D0,  0.00872D0,
     &     0.00639D0,  0.00464D0,  0.00334D0,  0.00238D0,  0.00167D0,
     &     0.00115D0,  0.00081D0,  0.00056D0,  0.00034D0,  0.00023D0,
     &     0.00015D0,  0.00009D0,  0.00006D0,  0.00002D0,  0.00000D0,
     &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0/
      DATA (FMRS(1,6,I,31),I=1,49)/
     &    13.04562D0,  9.57419D0,  7.01826D0,  5.84808D0,  5.13599D0,
     &     4.64254D0,  3.38483D0,  2.45538D0,  2.02720D0,  1.76492D0,
     &     1.57901D0,  1.10697D0,  0.75881D0,  0.60107D0,  0.50610D0,
     &     0.44109D0,  0.35574D0,  0.27985D0,  0.20903D0,  0.16716D0,
     &     0.11764D0,  0.08810D0,  0.06793D0,  0.05010D0,  0.03737D0,
     &     0.02791D0,  0.02089D0,  0.01558D0,  0.01154D0,  0.00848D0,
     &     0.00620D0,  0.00450D0,  0.00323D0,  0.00230D0,  0.00160D0,
     &     0.00110D0,  0.00077D0,  0.00053D0,  0.00032D0,  0.00022D0,
     &     0.00015D0,  0.00008D0,  0.00006D0,  0.00002D0,  0.00000D0,
     &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0/
      DATA (FMRS(1,6,I,32),I=1,49)/
     &    13.89443D0, 10.15226D0,  7.40931D0,  6.15805D0,  5.39834D0,
     &     4.87276D0,  3.53699D0,  2.55429D0,  2.10325D0,  1.82761D0,
     &     1.63256D0,  1.13890D0,  0.77669D0,  0.61332D0,  0.51524D0,
     &     0.44825D0,  0.36050D0,  0.28271D0,  0.21036D0,  0.16773D0,
     &     0.11750D0,  0.08767D0,  0.06738D0,  0.04952D0,  0.03683D0,
     &     0.02743D0,  0.02048D0,  0.01524D0,  0.01125D0,  0.00826D0,
     &     0.00603D0,  0.00436D0,  0.00312D0,  0.00222D0,  0.00155D0,
     &     0.00106D0,  0.00074D0,  0.00051D0,  0.00031D0,  0.00021D0,
     &     0.00014D0,  0.00008D0,  0.00005D0,  0.00002D0,  0.00001D0,
     &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0/
      DATA (FMRS(1,6,I,33),I=1,49)/
     &    14.79866D0, 10.76526D0,  7.82209D0,  6.48437D0,  5.67399D0,
     &     5.11430D0,  3.69589D0,  2.65710D0,  2.18207D0,  1.89245D0,
     &     1.68785D0,  1.17170D0,  0.79496D0,  0.62581D0,  0.52453D0,
     &     0.45551D0,  0.36532D0,  0.28560D0,  0.21171D0,  0.16831D0,
     &     0.11736D0,  0.08724D0,  0.06684D0,  0.04896D0,  0.03630D0,
     &     0.02696D0,  0.02007D0,  0.01490D0,  0.01098D0,  0.00805D0,
     &     0.00586D0,  0.00423D0,  0.00302D0,  0.00214D0,  0.00150D0,
     &     0.00102D0,  0.00071D0,  0.00049D0,  0.00030D0,  0.00020D0,
     &     0.00013D0,  0.00008D0,  0.00005D0,  0.00002D0,  0.00001D0,
     &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0/
      DATA (FMRS(1,6,I,34),I=1,49)/
     &    15.70368D0, 11.37564D0,  8.23095D0,  6.80656D0,  5.94554D0,
     &     5.35181D0,  3.85123D0,  2.75698D0,  2.25835D0,  1.95501D0,
     &     1.74107D0,  1.20298D0,  0.81219D0,  0.63747D0,  0.53315D0,
     &     0.46219D0,  0.36968D0,  0.28814D0,  0.21281D0,  0.16870D0,
     &     0.11711D0,  0.08674D0,  0.06626D0,  0.04836D0,  0.03575D0,
     &     0.02649D0,  0.01967D0,  0.01456D0,  0.01071D0,  0.00784D0,
     &     0.00568D0,  0.00409D0,  0.00292D0,  0.00207D0,  0.00144D0,
     &     0.00098D0,  0.00068D0,  0.00047D0,  0.00029D0,  0.00019D0,
     &     0.00012D0,  0.00007D0,  0.00005D0,  0.00002D0,  0.00000D0,
     &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0/
      DATA (FMRS(1,6,I,35),I=1,49)/
     &    16.61098D0, 11.98498D0,  8.63737D0,  7.12604D0,  6.21432D0,
     &     5.58657D0,  4.00413D0,  2.85486D0,  2.33290D0,  2.01603D0,
     &     1.79291D0,  1.23331D0,  0.82880D0,  0.64868D0,  0.54141D0,
     &     0.46858D0,  0.37384D0,  0.29056D0,  0.21385D0,  0.16907D0,
     &     0.11687D0,  0.08628D0,  0.06571D0,  0.04780D0,  0.03525D0,
     &     0.02604D0,  0.01929D0,  0.01425D0,  0.01046D0,  0.00764D0,
     &     0.00552D0,  0.00397D0,  0.00283D0,  0.00200D0,  0.00139D0,
     &     0.00095D0,  0.00066D0,  0.00045D0,  0.00028D0,  0.00019D0,
     &     0.00012D0,  0.00007D0,  0.00005D0,  0.00002D0,  0.00000D0,
     &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0/
      DATA (FMRS(1,6,I,36),I=1,49)/
     &    17.49641D0, 12.57703D0,  9.03053D0,  7.43428D0,  6.47316D0,
     &     5.81232D0,  4.15045D0,  2.94807D0,  2.40367D0,  2.07383D0,
     &     1.84191D0,  1.26179D0,  0.84428D0,  0.65906D0,  0.54902D0,
     &     0.47444D0,  0.37762D0,  0.29271D0,  0.21474D0,  0.16935D0,
     &     0.11660D0,  0.08580D0,  0.06517D0,  0.04726D0,  0.03476D0,
     &     0.02562D0,  0.01894D0,  0.01396D0,  0.01022D0,  0.00745D0,
     &     0.00538D0,  0.00386D0,  0.00274D0,  0.00194D0,  0.00135D0,
     &     0.00092D0,  0.00063D0,  0.00044D0,  0.00027D0,  0.00018D0,
     &     0.00011D0,  0.00007D0,  0.00005D0,  0.00002D0,  0.00000D0,
     &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0/
      DATA (FMRS(1,6,I,37),I=1,49)/
     &    18.41415D0, 13.18812D0,  9.43458D0,  7.75025D0,  6.73800D0,
     &     6.04297D0,  4.29926D0,  3.04240D0,  2.47507D0,  2.13202D0,
     &     1.89114D0,  1.29020D0,  0.85959D0,  0.66927D0,  0.55646D0,
     &     0.48015D0,  0.38126D0,  0.29476D0,  0.21554D0,  0.16955D0,
     &     0.11628D0,  0.08530D0,  0.06461D0,  0.04672D0,  0.03427D0,
     &     0.02520D0,  0.01858D0,  0.01367D0,  0.00999D0,  0.00727D0,
     &     0.00525D0,  0.00375D0,  0.00266D0,  0.00188D0,  0.00131D0,
     &     0.00088D0,  0.00061D0,  0.00042D0,  0.00026D0,  0.00017D0,
     &     0.00011D0,  0.00006D0,  0.00004D0,  0.00001D0,  0.00000D0,
     &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0/
      DATA (FMRS(1,6,I,38),I=1,49)/
     &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
     &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
     &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
     &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
     &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
     &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
     &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
     &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
     &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
     &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0/
      DATA (FMRS(1,7,I, 1),I=1,49)/
     &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
     &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
     &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
     &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
     &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
     &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
     &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
     &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
     &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
     &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0/
      DATA (FMRS(1,7,I, 2),I=1,49)/
     &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
     &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
     &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
     &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
     &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
     &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
     &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
     &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
     &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
     &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0/
      DATA (FMRS(1,7,I, 3),I=1,49)/
     &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
     &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
     &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
     &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
     &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
     &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
     &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
     &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
     &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
     &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0/
      DATA (FMRS(1,7,I, 4),I=1,49)/
     &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
     &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
     &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
     &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
     &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
     &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
     &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
     &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
     &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
     &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0/
      DATA (FMRS(1,7,I, 5),I=1,49)/
     &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
     &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
     &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
     &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
     &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
     &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
     &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
     &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
     &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
     &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0/
      DATA (FMRS(1,7,I, 6),I=1,49)/
     &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
     &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
     &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
     &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
     &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
     &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
     &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
     &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
     &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
     &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0/
      DATA (FMRS(1,7,I, 7),I=1,49)/
     &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
     &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
     &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
     &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
     &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
     &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
     &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
     &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
     &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
     &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0/
      DATA (FMRS(1,7,I, 8),I=1,49)/
     &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
     &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
     &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
     &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
     &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
     &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
     &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
     &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
     &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
     &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0/
      DATA (FMRS(1,7,I, 9),I=1,49)/
     &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
     &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
     &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
     &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
     &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
     &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
     &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
     &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
     &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
     &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0/
      DATA (FMRS(1,7,I,10),I=1,49)/
     &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
     &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
     &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
     &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
     &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
     &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
     &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
     &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
     &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
     &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0/
      DATA (FMRS(1,7,I,11),I=1,49)/
     &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
     &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
     &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
     &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
     &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
     &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
     &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
     &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
     &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
     &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0/
      DATA (FMRS(1,7,I,12),I=1,49)/
     &     0.00042D0,  0.00036D0,  0.00032D0,  0.00030D0,  0.00028D0,
     &     0.00027D0,  0.00023D0,  0.00020D0,  0.00019D0,  0.00018D0,
     &     0.00017D0,  0.00014D0,  0.00012D0,  0.00011D0,  0.00010D0,
     &     0.00009D0,  0.00008D0,  0.00007D0,  0.00006D0,  0.00005D0,
     &     0.00005D0,  0.00004D0,  0.00003D0,  0.00003D0,  0.00003D0,
     &     0.00002D0,  0.00002D0,  0.00002D0,  0.00002D0,  0.00001D0,
     &     0.00001D0,  0.00001D0,  0.00001D0,  0.00001D0,  0.00001D0,
     &     0.00001D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
     &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
     &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0/
      DATA (FMRS(1,7,I,13),I=1,49)/
     &     0.21520D0,  0.16773D0,  0.13065D0,  0.11283D0,  0.10165D0,
     &     0.09372D0,  0.07266D0,  0.05600D0,  0.04786D0,  0.04266D0,
     &     0.03883D0,  0.02862D0,  0.02044D0,  0.01649D0,  0.01402D0,
     &     0.01228D0,  0.00994D0,  0.00781D0,  0.00579D0,  0.00460D0,
     &     0.00322D0,  0.00243D0,  0.00191D0,  0.00146D0,  0.00114D0,
     &     0.00089D0,  0.00070D0,  0.00055D0,  0.00043D0,  0.00034D0,
     &     0.00026D0,  0.00020D0,  0.00015D0,  0.00011D0,  0.00009D0,
     &     0.00006D0,  0.00005D0,  0.00003D0,  0.00002D0,  0.00001D0,
     &     0.00001D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
     &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0/
      DATA (FMRS(1,7,I,14),I=1,49)/
     &     0.62424D0,  0.48455D0,  0.37589D0,  0.32385D0,  0.29126D0,
     &     0.26818D0,  0.20706D0,  0.15892D0,  0.13546D0,  0.12053D0,
     &     0.10954D0,  0.08034D0,  0.05707D0,  0.04589D0,  0.03892D0,
     &     0.03403D0,  0.02747D0,  0.02151D0,  0.01589D0,  0.01258D0,
     &     0.00876D0,  0.00658D0,  0.00515D0,  0.00391D0,  0.00303D0,
     &     0.00236D0,  0.00185D0,  0.00144D0,  0.00112D0,  0.00088D0,
     &     0.00067D0,  0.00051D0,  0.00039D0,  0.00029D0,  0.00022D0,
     &     0.00016D0,  0.00011D0,  0.00008D0,  0.00006D0,  0.00004D0,
     &     0.00002D0,  0.00001D0,  0.00000D0,  0.00000D0,  0.00000D0,
     &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0/
      DATA (FMRS(1,7,I,15),I=1,49)/
     &     1.00765D0,  0.77678D0,  0.59844D0,  0.51350D0,  0.46049D0,
     &     0.42306D0,  0.32436D0,  0.24719D0,  0.20981D0,  0.18611D0,
     &     0.16874D0,  0.12279D0,  0.08652D0,  0.06923D0,  0.05850D0,
     &     0.05102D0,  0.04100D0,  0.03196D0,  0.02347D0,  0.01849D0,
     &     0.01279D0,  0.00955D0,  0.00743D0,  0.00560D0,  0.00430D0,
     &     0.00334D0,  0.00260D0,  0.00202D0,  0.00157D0,  0.00121D0,
     &     0.00093D0,  0.00071D0,  0.00053D0,  0.00040D0,  0.00029D0,
     &     0.00021D0,  0.00015D0,  0.00011D0,  0.00007D0,  0.00005D0,
     &     0.00003D0,  0.00001D0,  0.00000D0,  0.00000D0,  0.00000D0,
     &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0/
      DATA (FMRS(1,7,I,16),I=1,49)/
     &     1.42250D0,  1.08981D0,  0.83442D0,  0.71339D0,  0.63810D0,
     &     0.58505D0,  0.44575D0,  0.33755D0,  0.28542D0,  0.25249D0,
     &     0.22841D0,  0.16506D0,  0.11545D0,  0.09197D0,  0.07747D0,
     &     0.06738D0,  0.05394D0,  0.04186D0,  0.03057D0,  0.02399D0,
     &     0.01648D0,  0.01223D0,  0.00946D0,  0.00708D0,  0.00541D0,
     &     0.00417D0,  0.00323D0,  0.00250D0,  0.00193D0,  0.00149D0,
     &     0.00113D0,  0.00086D0,  0.00064D0,  0.00048D0,  0.00035D0,
     &     0.00026D0,  0.00018D0,  0.00013D0,  0.00009D0,  0.00005D0,
     &     0.00003D0,  0.00001D0,  0.00000D0,  0.00000D0,  0.00000D0,
     &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0/
      DATA (FMRS(1,7,I,17),I=1,49)/
     &     1.90329D0,  1.44918D0,  1.10274D0,  0.93938D0,  0.83807D0,
     &     0.76686D0,  0.58064D0,  0.43692D0,  0.36805D0,  0.32470D0,
     &     0.29309D0,  0.21032D0,  0.14604D0,  0.11582D0,  0.09725D0,
     &     0.08437D0,  0.06728D0,  0.05198D0,  0.03776D0,  0.02950D0,
     &     0.02012D0,  0.01485D0,  0.01142D0,  0.00850D0,  0.00645D0,
     &     0.00494D0,  0.00381D0,  0.00293D0,  0.00225D0,  0.00172D0,
     &     0.00131D0,  0.00098D0,  0.00073D0,  0.00054D0,  0.00040D0,
     &     0.00029D0,  0.00021D0,  0.00014D0,  0.00010D0,  0.00006D0,
     &     0.00003D0,  0.00001D0,  0.00000D0,  0.00000D0,  0.00000D0,
     &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0/
      DATA (FMRS(1,7,I,18),I=1,49)/
     &     2.33137D0,  1.76616D0,  1.33713D0,  1.13567D0,  1.01106D0,
     &     0.92363D0,  0.69576D0,  0.52083D0,  0.43738D0,  0.38501D0,
     &     0.34690D0,  0.24753D0,  0.17085D0,  0.13502D0,  0.11307D0,
     &     0.09789D0,  0.07781D0,  0.05991D0,  0.04333D0,  0.03374D0,
     &     0.02288D0,  0.01680D0,  0.01286D0,  0.00952D0,  0.00719D0,
     &     0.00549D0,  0.00420D0,  0.00322D0,  0.00246D0,  0.00188D0,
     &     0.00142D0,  0.00107D0,  0.00079D0,  0.00059D0,  0.00043D0,
     &     0.00031D0,  0.00022D0,  0.00015D0,  0.00010D0,  0.00006D0,
     &     0.00003D0,  0.00001D0,  0.00000D0,  0.00000D0,  0.00000D0,
     &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0/
      DATA (FMRS(1,7,I,19),I=1,49)/
     &     2.89798D0,  2.18213D0,  1.64207D0,  1.38971D0,  1.23410D0,
     &     1.12518D0,  0.84241D0,  0.62670D0,  0.52435D0,  0.46034D0,
     &     0.41389D0,  0.29333D0,  0.20103D0,  0.15819D0,  0.13206D0,
     &     0.11405D0,  0.09031D0,  0.06924D0,  0.04982D0,  0.03863D0,
     &     0.02602D0,  0.01899D0,  0.01446D0,  0.01064D0,  0.00798D0,
     &     0.00606D0,  0.00462D0,  0.00352D0,  0.00268D0,  0.00204D0,
     &     0.00153D0,  0.00115D0,  0.00085D0,  0.00062D0,  0.00046D0,
     &     0.00034D0,  0.00024D0,  0.00016D0,  0.00010D0,  0.00006D0,
     &     0.00003D0,  0.00001D0,  0.00000D0,  0.00000D0,  0.00000D0,
     &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0/
      DATA (FMRS(1,7,I,20),I=1,49)/
     &     3.45978D0,  2.59142D0,  1.93977D0,  1.63658D0,  1.45012D0,
     &     1.31987D0,  0.98290D0,  0.72728D0,  0.60655D0,  0.53126D0,
     &     0.47676D0,  0.33590D0,  0.22879D0,  0.17936D0,  0.14933D0,
     &     0.12869D0,  0.10156D0,  0.07757D0,  0.05556D0,  0.04293D0,
     &     0.02875D0,  0.02087D0,  0.01582D0,  0.01157D0,  0.00864D0,
     &     0.00653D0,  0.00495D0,  0.00376D0,  0.00285D0,  0.00216D0,
     &     0.00162D0,  0.00120D0,  0.00089D0,  0.00065D0,  0.00048D0,
     &     0.00035D0,  0.00025D0,  0.00017D0,  0.00010D0,  0.00006D0,
     &     0.00003D0,  0.00001D0,  0.00000D0,  0.00000D0,  0.00000D0,
     &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0/
      DATA (FMRS(1,7,I,21),I=1,49)/
     &     3.99390D0,  2.97724D0,  2.21795D0,  1.86604D0,  1.65015D0,
     &     1.49961D0,  1.11138D0,  0.81834D0,  0.68051D0,  0.59480D0,
     &     0.53289D0,  0.37345D0,  0.25296D0,  0.19764D0,  0.16415D0,
     &     0.14119D0,  0.11109D0,  0.08457D0,  0.06032D0,  0.04645D0,
     &     0.03094D0,  0.02236D0,  0.01688D0,  0.01228D0,  0.00913D0,
     &     0.00687D0,  0.00519D0,  0.00392D0,  0.00296D0,  0.00223D0,
     &     0.00167D0,  0.00124D0,  0.00091D0,  0.00067D0,  0.00049D0,
     &     0.00036D0,  0.00025D0,  0.00017D0,  0.00010D0,  0.00006D0,
     &     0.00003D0,  0.00001D0,  0.00000D0,  0.00000D0,  0.00000D0,
     &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0/
      DATA (FMRS(1,7,I,22),I=1,49)/
     &     4.74104D0,  3.51318D0,  2.60162D0,  2.18119D0,  1.92405D0,
     &     1.74515D0,  1.28558D0,  0.94085D0,  0.77956D0,  0.67959D0,
     &     0.60758D0,  0.42298D0,  0.28453D0,  0.22138D0,  0.18331D0,
     &     0.15728D0,  0.12329D0,  0.09346D0,  0.06632D0,  0.05087D0,
     &     0.03366D0,  0.02418D0,  0.01815D0,  0.01313D0,  0.00971D0,
     &     0.00726D0,  0.00546D0,  0.00411D0,  0.00309D0,  0.00232D0,
     &     0.00172D0,  0.00128D0,  0.00094D0,  0.00068D0,  0.00049D0,
     &     0.00036D0,  0.00026D0,  0.00017D0,  0.00010D0,  0.00006D0,
     &     0.00003D0,  0.00001D0,  0.00000D0,  0.00000D0,  0.00000D0,
     &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0/
      DATA (FMRS(1,7,I,23),I=1,49)/
     &     5.50879D0,  4.05964D0,  2.98973D0,  2.49849D0,  2.19888D0,
     &     1.99086D0,  1.45844D0,  1.06135D0,  0.87646D0,  0.76222D0,
     &     0.68014D0,  0.47060D0,  0.31455D0,  0.24380D0,  0.20130D0,
     &     0.17233D0,  0.13462D0,  0.10166D0,  0.07179D0,  0.05486D0,
     &     0.03607D0,  0.02577D0,  0.01926D0,  0.01386D0,  0.01019D0,
     &     0.00758D0,  0.00568D0,  0.00425D0,  0.00318D0,  0.00238D0,
     &     0.00176D0,  0.00130D0,  0.00095D0,  0.00069D0,  0.00050D0,
     &     0.00037D0,  0.00026D0,  0.00017D0,  0.00010D0,  0.00006D0,
     &     0.00003D0,  0.00001D0,  0.00000D0,  0.00000D0,  0.00000D0,
     &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0/
      DATA (FMRS(1,7,I,24),I=1,49)/
     &     6.25919D0,  4.58931D0,  3.36270D0,  2.80183D0,  2.46064D0,
     &     2.22421D0,  1.62105D0,  1.17360D0,  0.96617D0,  0.83838D0,
     &     0.74677D0,  0.51381D0,  0.34143D0,  0.26369D0,  0.21716D0,
     &     0.18553D0,  0.14447D0,  0.10870D0,  0.07643D0,  0.05820D0,
     &     0.03805D0,  0.02705D0,  0.02012D0,  0.01441D0,  0.01054D0,
     &     0.00781D0,  0.00582D0,  0.00434D0,  0.00324D0,  0.00241D0,
     &     0.00178D0,  0.00131D0,  0.00095D0,  0.00069D0,  0.00050D0,
     &     0.00037D0,  0.00026D0,  0.00017D0,  0.00010D0,  0.00006D0,
     &     0.00003D0,  0.00001D0,  0.00000D0,  0.00000D0,  0.00000D0,
     &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0/
      DATA (FMRS(1,7,I,25),I=1,49)/
     &     7.07966D0,  5.16501D0,  3.76564D0,  3.12838D0,  2.74171D0,
     &     2.47426D0,  1.79422D0,  1.29235D0,  1.06071D0,  0.91840D0,
     &     0.81663D0,  0.55877D0,  0.36917D0,  0.28412D0,  0.23339D0,
     &     0.19900D0,  0.15447D0,  0.11582D0,  0.08108D0,  0.06153D0,
     &     0.03999D0,  0.02830D0,  0.02096D0,  0.01493D0,  0.01087D0,
     &     0.00803D0,  0.00595D0,  0.00442D0,  0.00329D0,  0.00244D0,
     &     0.00180D0,  0.00131D0,  0.00096D0,  0.00069D0,  0.00050D0,
     &     0.00036D0,  0.00026D0,  0.00017D0,  0.00010D0,  0.00006D0,
     &     0.00003D0,  0.00001D0,  0.00000D0,  0.00000D0,  0.00000D0,
     &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0/
      DATA (FMRS(1,7,I,26),I=1,49)/
     &     7.91829D0,  5.74916D0,  4.17141D0,  3.45573D0,  3.02255D0,
     &     2.72346D0,  1.96537D0,  1.40870D0,  1.15285D0,  0.99608D0,
     &     0.88421D0,  0.60182D0,  0.39541D0,  0.30330D0,  0.24854D0,
     &     0.21150D0,  0.16368D0,  0.12231D0,  0.08527D0,  0.06448D0,
     &     0.04169D0,  0.02937D0,  0.02165D0,  0.01535D0,  0.01113D0,
     &     0.00818D0,  0.00604D0,  0.00447D0,  0.00331D0,  0.00245D0,
     &     0.00180D0,  0.00131D0,  0.00095D0,  0.00068D0,  0.00049D0,
     &     0.00036D0,  0.00026D0,  0.00017D0,  0.00010D0,  0.00006D0,
     &     0.00003D0,  0.00001D0,  0.00000D0,  0.00000D0,  0.00000D0,
     &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0/
      DATA (FMRS(1,7,I,27),I=1,49)/
     &     8.76657D0,  6.33661D0,  4.57707D0,  3.78184D0,  3.30161D0,
     &     2.97059D0,  2.13403D0,  1.52261D0,  1.24269D0,  1.07161D0,
     &     0.94977D0,  0.64324D0,  0.42046D0,  0.32150D0,  0.26285D0,
     &     0.22328D0,  0.17230D0,  0.12835D0,  0.08912D0,  0.06719D0,
     &     0.04322D0,  0.03031D0,  0.02226D0,  0.01571D0,  0.01134D0,
     &     0.00830D0,  0.00611D0,  0.00451D0,  0.00333D0,  0.00245D0,
     &     0.00180D0,  0.00131D0,  0.00095D0,  0.00068D0,  0.00048D0,
     &     0.00036D0,  0.00026D0,  0.00017D0,  0.00010D0,  0.00006D0,
     &     0.00003D0,  0.00001D0,  0.00000D0,  0.00000D0,  0.00000D0,
     &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0/
      DATA (FMRS(1,7,I,28),I=1,49)/
     &     9.60252D0,  6.91204D0,  4.97199D0,  4.09813D0,  3.57154D0,
     &     3.20914D0,  2.29574D0,  1.63105D0,  1.32784D0,  1.14296D0,
     &     1.01154D0,  0.68194D0,  0.44362D0,  0.33823D0,  0.27595D0,
     &     0.23401D0,  0.18011D0,  0.13377D0,  0.09255D0,  0.06957D0,
     &     0.04454D0,  0.03111D0,  0.02277D0,  0.01600D0,  0.01150D0,
     &     0.00839D0,  0.00616D0,  0.00453D0,  0.00333D0,  0.00245D0,
     &     0.00179D0,  0.00130D0,  0.00094D0,  0.00067D0,  0.00048D0,
     &     0.00035D0,  0.00025D0,  0.00017D0,  0.00010D0,  0.00006D0,
     &     0.00003D0,  0.00001D0,  0.00000D0,  0.00000D0,  0.00000D0,
     &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0/
      DATA (FMRS(1,7,I,29),I=1,49)/
     &    10.48807D0,  7.51842D0,  5.38590D0,  4.42859D0,  3.85291D0,
     &     3.45734D0,  2.46302D0,  1.74255D0,  1.41507D0,  1.21586D0,
     &     1.07451D0,  0.72111D0,  0.46688D0,  0.35494D0,  0.28897D0,
     &     0.24464D0,  0.18781D0,  0.13908D0,  0.09587D0,  0.07187D0,
     &     0.04579D0,  0.03185D0,  0.02323D0,  0.01626D0,  0.01165D0,
     &     0.00847D0,  0.00619D0,  0.00454D0,  0.00333D0,  0.00244D0,
     &     0.00178D0,  0.00129D0,  0.00093D0,  0.00066D0,  0.00047D0,
     &     0.00035D0,  0.00025D0,  0.00017D0,  0.00010D0,  0.00006D0,
     &     0.00003D0,  0.00001D0,  0.00000D0,  0.00000D0,  0.00000D0,
     &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0/
      DATA (FMRS(1,7,I,30),I=1,49)/
     &    11.39334D0,  8.13482D0,  5.80422D0,  4.76138D0,  4.13555D0,
     &     3.70617D0,  2.62967D0,  1.85288D0,  1.50103D0,  1.28747D0,
     &     1.13621D0,  0.75917D0,  0.48927D0,  0.37093D0,  0.30137D0,
     &     0.25473D0,  0.19506D0,  0.14404D0,  0.09894D0,  0.07396D0,
     &     0.04691D0,  0.03251D0,  0.02363D0,  0.01647D0,  0.01175D0,
     &     0.00851D0,  0.00621D0,  0.00454D0,  0.00332D0,  0.00243D0,
     &     0.00176D0,  0.00127D0,  0.00091D0,  0.00065D0,  0.00046D0,
     &     0.00034D0,  0.00025D0,  0.00017D0,  0.00010D0,  0.00006D0,
     &     0.00003D0,  0.00001D0,  0.00000D0,  0.00000D0,  0.00000D0,
     &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0/
      DATA (FMRS(1,7,I,31),I=1,49)/
     &    12.30020D0,  8.74942D0,  6.21933D0,  5.09070D0,  4.41468D0,
     &     3.95152D0,  2.79315D0,  1.96055D0,  1.58465D0,  1.35697D0,
     &     1.19598D0,  0.79580D0,  0.51068D0,  0.38615D0,  0.31314D0,
     &     0.26427D0,  0.20189D0,  0.14868D0,  0.10179D0,  0.07589D0,
     &     0.04793D0,  0.03309D0,  0.02397D0,  0.01665D0,  0.01184D0,
     &     0.00855D0,  0.00621D0,  0.00453D0,  0.00330D0,  0.00241D0,
     &     0.00174D0,  0.00126D0,  0.00090D0,  0.00064D0,  0.00046D0,
     &     0.00034D0,  0.00025D0,  0.00017D0,  0.00010D0,  0.00006D0,
     &     0.00003D0,  0.00001D0,  0.00000D0,  0.00000D0,  0.00000D0,
     &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0/
      DATA (FMRS(1,7,I,32),I=1,49)/
     &    13.17835D0,  9.34137D0,  6.61692D0,  5.40505D0,  4.68045D0,
     &     4.18467D0,  2.94753D0,  2.06155D0,  1.66276D0,  1.42169D0,
     &     1.25150D0,  0.82954D0,  0.53019D0,  0.39993D0,  0.32374D0,
     &     0.27283D0,  0.20796D0,  0.15278D0,  0.10427D0,  0.07755D0,
     &     0.04878D0,  0.03356D0,  0.02424D0,  0.01677D0,  0.01189D0,
     &     0.00856D0,  0.00621D0,  0.00451D0,  0.00328D0,  0.00239D0,
     &     0.00173D0,  0.00124D0,  0.00089D0,  0.00063D0,  0.00045D0,
     &     0.00033D0,  0.00025D0,  0.00017D0,  0.00010D0,  0.00006D0,
     &     0.00003D0,  0.00001D0,  0.00000D0,  0.00000D0,  0.00000D0,
     &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0/
      DATA (FMRS(1,7,I,33),I=1,49)/
     &    14.12059D0,  9.97430D0,  7.04054D0,  5.73929D0,  4.96264D0,
     &     4.43195D0,  3.11069D0,  2.16791D0,  1.74484D0,  1.48959D0,
     &     1.30967D0,  0.86476D0,  0.55049D0,  0.41422D0,  0.33471D0,
     &     0.28168D0,  0.21423D0,  0.15699D0,  0.10682D0,  0.07925D0,
     &     0.04965D0,  0.03404D0,  0.02451D0,  0.01690D0,  0.01194D0,
     &     0.00857D0,  0.00620D0,  0.00449D0,  0.00326D0,  0.00237D0,
     &     0.00171D0,  0.00123D0,  0.00088D0,  0.00062D0,  0.00044D0,
     &     0.00032D0,  0.00025D0,  0.00017D0,  0.00010D0,  0.00006D0,
     &     0.00003D0,  0.00001D0,  0.00000D0,  0.00000D0,  0.00000D0,
     &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0/
      DATA (FMRS(1,7,I,34),I=1,49)/
     &    15.05309D0, 10.59701D0,  7.45476D0,  6.06488D0,  5.23678D0,
     &     4.67164D0,  3.26773D0,  2.26948D0,  1.82284D0,  1.55389D0,
     &     1.36460D0,  0.89767D0,  0.56921D0,  0.42730D0,  0.34468D0,
     &     0.28967D0,  0.21983D0,  0.16070D0,  0.10902D0,  0.08069D0,
     &     0.05036D0,  0.03441D0,  0.02470D0,  0.01698D0,  0.01196D0,
     &     0.00856D0,  0.00617D0,  0.00446D0,  0.00323D0,  0.00234D0,
     &     0.00168D0,  0.00121D0,  0.00086D0,  0.00061D0,  0.00043D0,
     &     0.00032D0,  0.00024D0,  0.00017D0,  0.00010D0,  0.00006D0,
     &     0.00003D0,  0.00001D0,  0.00000D0,  0.00000D0,  0.00000D0,
     &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0/
      DATA (FMRS(1,7,I,35),I=1,49)/
     &    15.99294D0, 11.22254D0,  7.86947D0,  6.39022D0,  5.51032D0,
     &     4.91055D0,  3.42373D0,  2.37005D0,  1.89992D0,  1.61733D0,
     &     1.41872D0,  0.92998D0,  0.58753D0,  0.44006D0,  0.35440D0,
     &     0.29744D0,  0.22527D0,  0.16430D0,  0.11114D0,  0.08207D0,
     &     0.05103D0,  0.03476D0,  0.02489D0,  0.01705D0,  0.01198D0,
     &     0.00855D0,  0.00615D0,  0.00444D0,  0.00321D0,  0.00232D0,
     &     0.00166D0,  0.00119D0,  0.00085D0,  0.00060D0,  0.00042D0,
     &     0.00031D0,  0.00024D0,  0.00017D0,  0.00010D0,  0.00006D0,
     &     0.00003D0,  0.00001D0,  0.00000D0,  0.00000D0,  0.00000D0,
     &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0/
      DATA (FMRS(1,7,I,36),I=1,49)/
     &    16.90825D0, 11.82917D0,  8.26989D0,  6.70353D0,  5.77324D0,
     &     5.13985D0,  3.57272D0,  2.46560D0,  1.97292D0,  1.67727D0,
     &     1.46976D0,  0.96025D0,  0.60456D0,  0.45187D0,  0.36334D0,
     &     0.30458D0,  0.23023D0,  0.16756D0,  0.11304D0,  0.08330D0,
     &     0.05162D0,  0.03506D0,  0.02503D0,  0.01710D0,  0.01198D0,
     &     0.00853D0,  0.00612D0,  0.00440D0,  0.00318D0,  0.00229D0,
     &     0.00164D0,  0.00117D0,  0.00083D0,  0.00059D0,  0.00042D0,
     &     0.00031D0,  0.00024D0,  0.00017D0,  0.00010D0,  0.00006D0,
     &     0.00003D0,  0.00001D0,  0.00000D0,  0.00000D0,  0.00000D0,
     &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0/
      DATA (FMRS(1,7,I,37),I=1,49)/
     &    17.85379D0, 12.45318D0,  8.67996D0,  7.02354D0,  6.04126D0,
     &     5.37323D0,  3.72362D0,  2.56187D0,  2.04622D0,  1.73730D0,
     &     1.52078D0,  0.99029D0,  0.62133D0,  0.46343D0,  0.37206D0,
     &     0.31151D0,  0.23502D0,  0.17068D0,  0.11483D0,  0.08444D0,
     &     0.05214D0,  0.03531D0,  0.02515D0,  0.01713D0,  0.01196D0,
     &     0.00850D0,  0.00608D0,  0.00437D0,  0.00315D0,  0.00226D0,
     &     0.00162D0,  0.00115D0,  0.00082D0,  0.00058D0,  0.00041D0,
     &     0.00030D0,  0.00024D0,  0.00017D0,  0.00010D0,  0.00006D0,
     &     0.00003D0,  0.00001D0,  0.00000D0,  0.00000D0,  0.00000D0,
     &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0/
      DATA (FMRS(1,7,I,38),I=1,49)/
     &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
     &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
     &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
     &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
     &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
     &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
     &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
     &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
     &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
     &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0/
      DATA (FMRS(1,8,I, 1),I=1,49)/
     &     0.88043D0,  0.77333D0,  0.67888D0,  0.62888D0,  0.59555D0,
     &     0.57086D0,  0.50019D0,  0.43775D0,  0.40464D0,  0.38254D0,
     &     0.36610D0,  0.31885D0,  0.27689D0,  0.25464D0,  0.23989D0,
     &     0.22903D0,  0.21364D0,  0.19859D0,  0.18303D0,  0.17273D0,
     &     0.15826D0,  0.14656D0,  0.13527D0,  0.12062D0,  0.10522D0,
     &     0.08955D0,  0.07420D0,  0.05981D0,  0.04692D0,  0.03554D0,
     &     0.02630D0,  0.01878D0,  0.01298D0,  0.00870D0,  0.00554D0,
     &     0.00339D0,  0.00198D0,  0.00110D0,  0.00049D0,  0.00026D0,
     &     0.00012D0,  0.00002D0,  0.00002D0,  0.00000D0, -0.00001D0,
     &    -0.00001D0,  0.00000D0,  0.00000D0,  0.00000D0/
      DATA (FMRS(1,8,I, 2),I=1,49)/
     &     0.89442D0,  0.78714D0,  0.69235D0,  0.64208D0,  0.60853D0,
     &     0.58367D0,  0.51236D0,  0.44919D0,  0.41561D0,  0.39314D0,
     &     0.37639D0,  0.32808D0,  0.28485D0,  0.26176D0,  0.24637D0,
     &     0.23501D0,  0.21882D0,  0.20291D0,  0.18634D0,  0.17532D0,
     &     0.15979D0,  0.14730D0,  0.13538D0,  0.12014D0,  0.10435D0,
     &     0.08847D0,  0.07306D0,  0.05873D0,  0.04595D0,  0.03477D0,
     &     0.02571D0,  0.01837D0,  0.01273D0,  0.00855D0,  0.00550D0,
     &     0.00340D0,  0.00204D0,  0.00117D0,  0.00055D0,  0.00031D0,
     &     0.00017D0,  0.00006D0,  0.00005D0,  0.00001D0,  0.00000D0,
     &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0/
      DATA (FMRS(1,8,I, 3),I=1,49)/
     &     0.93116D0,  0.82082D0,  0.72315D0,  0.67127D0,  0.63662D0,
     &     0.61092D0,  0.53708D0,  0.47148D0,  0.43647D0,  0.41299D0,
     &     0.39541D0,  0.34450D0,  0.29850D0,  0.27374D0,  0.25714D0,
     &     0.24483D0,  0.22722D0,  0.20981D0,  0.19154D0,  0.17933D0,
     &     0.16210D0,  0.14837D0,  0.13550D0,  0.11937D0,  0.10300D0,
     &     0.08681D0,  0.07133D0,  0.05711D0,  0.04449D0,  0.03362D0,
     &     0.02480D0,  0.01774D0,  0.01234D0,  0.00831D0,  0.00539D0,
     &     0.00338D0,  0.00208D0,  0.00122D0,  0.00062D0,  0.00038D0,
     &     0.00022D0,  0.00010D0,  0.00007D0,  0.00002D0,  0.00001D0,
     &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0/
      DATA (FMRS(1,8,I, 4),I=1,49)/
     &     0.97222D0,  0.85703D0,  0.75505D0,  0.70088D0,  0.66470D0,
     &     0.63785D0,  0.56070D0,  0.49207D0,  0.45539D0,  0.43075D0,
     &     0.41225D0,  0.35857D0,  0.30984D0,  0.28350D0,  0.26581D0,
     &     0.25266D0,  0.23382D0,  0.21514D0,  0.19549D0,  0.18234D0,
     &     0.16379D0,  0.14912D0,  0.13552D0,  0.11873D0,  0.10198D0,
     &     0.08556D0,  0.07005D0,  0.05591D0,  0.04344D0,  0.03278D0,
     &     0.02413D0,  0.01727D0,  0.01201D0,  0.00813D0,  0.00530D0,
     &     0.00334D0,  0.00207D0,  0.00123D0,  0.00065D0,  0.00042D0,
     &     0.00025D0,  0.00012D0,  0.00009D0,  0.00002D0,  0.00002D0,
     &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0/
      DATA (FMRS(1,8,I, 5),I=1,49)/
     &     1.03488D0,  0.91080D0,  0.80113D0,  0.74294D0,  0.70410D0,
     &     0.67529D0,  0.59258D0,  0.51904D0,  0.47974D0,  0.45332D0,
     &     0.43343D0,  0.37573D0,  0.32325D0,  0.29486D0,  0.27577D0,
     &     0.26158D0,  0.24123D0,  0.22104D0,  0.19979D0,  0.18555D0,
     &     0.16552D0,  0.14984D0,  0.13548D0,  0.11801D0,  0.10084D0,
     &     0.08422D0,  0.06865D0,  0.05459D0,  0.04229D0,  0.03183D0,
     &     0.02342D0,  0.01674D0,  0.01163D0,  0.00790D0,  0.00517D0,
     &     0.00326D0,  0.00204D0,  0.00126D0,  0.00069D0,  0.00044D0,
     &     0.00027D0,  0.00014D0,  0.00010D0,  0.00004D0,  0.00001D0,
     &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0/
      DATA (FMRS(1,8,I, 6),I=1,49)/
     &     1.09976D0,  0.96588D0,  0.84779D0,  0.78524D0,  0.74353D0,
     &     0.71261D0,  0.62395D0,  0.54523D0,  0.50318D0,  0.47492D0,
     &     0.45362D0,  0.39183D0,  0.33563D0,  0.30525D0,  0.28482D0,
     &     0.26964D0,  0.24787D0,  0.22628D0,  0.20357D0,  0.18835D0,
     &     0.16700D0,  0.15043D0,  0.13540D0,  0.11734D0,  0.09983D0,
     &     0.08303D0,  0.06744D0,  0.05346D0,  0.04131D0,  0.03103D0,
     &     0.02280D0,  0.01628D0,  0.01131D0,  0.00768D0,  0.00506D0,
     &     0.00319D0,  0.00201D0,  0.00126D0,  0.00071D0,  0.00044D0,
     &     0.00028D0,  0.00015D0,  0.00010D0,  0.00005D0,  0.00001D0,
     &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0/
      DATA (FMRS(1,8,I, 7),I=1,49)/
     &     1.17764D0,  1.03108D0,  0.90223D0,  0.83415D0,  0.78882D0,
     &     0.75526D0,  0.65918D0,  0.57411D0,  0.52875D0,  0.49829D0,
     &     0.47532D0,  0.40880D0,  0.34842D0,  0.31585D0,  0.29397D0,
     &     0.27773D0,  0.25447D0,  0.23144D0,  0.20722D0,  0.19102D0,
     &     0.16837D0,  0.15091D0,  0.13525D0,  0.11665D0,  0.09880D0,
     &     0.08184D0,  0.06625D0,  0.05236D0,  0.04036D0,  0.03026D0,
     &     0.02219D0,  0.01583D0,  0.01099D0,  0.00745D0,  0.00494D0,
     &     0.00313D0,  0.00199D0,  0.00124D0,  0.00071D0,  0.00044D0,
     &     0.00028D0,  0.00014D0,  0.00011D0,  0.00005D0,  0.00001D0,
     &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0/
      DATA (FMRS(1,8,I, 8),I=1,49)/
     &     1.27508D0,  1.11188D0,  0.96899D0,  0.89374D0,  0.84374D0,
     &     0.80677D0,  0.70124D0,  0.60814D0,  0.55864D0,  0.52545D0,
     &     0.50042D0,  0.42815D0,  0.36279D0,  0.32765D0,  0.30409D0,
     &     0.28664D0,  0.26167D0,  0.23701D0,  0.21111D0,  0.19383D0,
     &     0.16977D0,  0.15136D0,  0.13503D0,  0.11586D0,  0.09768D0,
     &     0.08056D0,  0.06499D0,  0.05119D0,  0.03935D0,  0.02943D0,
     &     0.02154D0,  0.01534D0,  0.01065D0,  0.00723D0,  0.00480D0,
     &     0.00305D0,  0.00194D0,  0.00121D0,  0.00071D0,  0.00043D0,
     &     0.00029D0,  0.00014D0,  0.00011D0,  0.00005D0,  0.00001D0,
     &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0/
      DATA (FMRS(1,8,I, 9),I=1,49)/
     &     1.37316D0,  1.19249D0,  1.03498D0,  0.95232D0,  0.89751D0,
     &     0.85705D0,  0.74185D0,  0.64064D0,  0.58699D0,  0.55108D0,
     &     0.52402D0,  0.44610D0,  0.37594D0,  0.33836D0,  0.31323D0,
     &     0.29464D0,  0.26809D0,  0.24193D0,  0.21452D0,  0.19627D0,
     &     0.17094D0,  0.15171D0,  0.13480D0,  0.11515D0,  0.09667D0,
     &     0.07946D0,  0.06388D0,  0.05018D0,  0.03847D0,  0.02871D0,
     &     0.02099D0,  0.01493D0,  0.01036D0,  0.00705D0,  0.00466D0,
     &     0.00297D0,  0.00189D0,  0.00119D0,  0.00071D0,  0.00043D0,
     &     0.00029D0,  0.00015D0,  0.00010D0,  0.00005D0,  0.00002D0,
     &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0/
      DATA (FMRS(1,8,I,10),I=1,49)/
     &     1.48232D0,  1.28141D0,  1.10710D0,  1.01596D0,  0.95567D0,
     &     0.91125D0,  0.78516D0,  0.67489D0,  0.61664D0,  0.57774D0,
     &     0.54846D0,  0.46445D0,  0.38919D0,  0.34906D0,  0.32230D0,
     &     0.30254D0,  0.27439D0,  0.24670D0,  0.21778D0,  0.19857D0,
     &     0.17201D0,  0.15198D0,  0.13451D0,  0.11441D0,  0.09567D0,
     &     0.07837D0,  0.06280D0,  0.04920D0,  0.03762D0,  0.02802D0,
     &     0.02045D0,  0.01454D0,  0.01009D0,  0.00685D0,  0.00453D0,
     &     0.00289D0,  0.00185D0,  0.00117D0,  0.00069D0,  0.00044D0,
     &     0.00029D0,  0.00015D0,  0.00011D0,  0.00004D0,  0.00002D0,
     &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0/
      DATA (FMRS(1,8,I,11),I=1,49)/
     &     1.57825D0,  1.35904D0,  1.16962D0,  1.07091D0,  1.00575D0,
     &     0.95780D0,  0.82207D0,  0.70384D0,  0.64159D0,  0.60009D0,
     &     0.56890D0,  0.47964D0,  0.40007D0,  0.35779D0,  0.32966D0,
     &     0.30893D0,  0.27945D0,  0.25052D0,  0.22036D0,  0.20038D0,
     &     0.17283D0,  0.15216D0,  0.13426D0,  0.11380D0,  0.09487D0,
     &     0.07750D0,  0.06195D0,  0.04843D0,  0.03696D0,  0.02748D0,
     &     0.02002D0,  0.01423D0,  0.00988D0,  0.00669D0,  0.00443D0,
     &     0.00283D0,  0.00181D0,  0.00116D0,  0.00068D0,  0.00044D0,
     &     0.00028D0,  0.00016D0,  0.00011D0,  0.00004D0,  0.00001D0,
     &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0/
      DATA (FMRS(1,8,I,12),I=1,49)/
     &     1.81391D0,  1.54794D0,  1.32027D0,  1.20251D0,  1.12515D0,
     &     1.06843D0,  0.90882D0,  0.77111D0,  0.69913D0,  0.65138D0,
     &     0.61560D0,  0.51392D0,  0.42424D0,  0.37702D0,  0.34578D0,
     &     0.32285D0,  0.29039D0,  0.25868D0,  0.22580D0,  0.20412D0,
     &     0.17445D0,  0.15244D0,  0.13361D0,  0.11242D0,  0.09312D0,
     &     0.07561D0,  0.06012D0,  0.04679D0,  0.03556D0,  0.02636D0,
     &     0.01913D0,  0.01356D0,  0.00940D0,  0.00637D0,  0.00422D0,
     &     0.00270D0,  0.00172D0,  0.00112D0,  0.00066D0,  0.00042D0,
     &     0.00027D0,  0.00016D0,  0.00011D0,  0.00004D0,  0.00001D0,
     &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0/
      DATA (FMRS(1,8,I,13),I=1,49)/
     &     2.05224D0,  1.73683D0,  1.46916D0,  1.33169D0,  1.24177D0,
     &     1.17604D0,  0.99216D0,  0.83488D0,  0.75325D0,  0.69933D0,
     &     0.65905D0,  0.54532D0,  0.44603D0,  0.39419D0,  0.36006D0,
     &     0.33511D0,  0.29992D0,  0.26571D0,  0.23041D0,  0.20724D0,
     &     0.17571D0,  0.15255D0,  0.13296D0,  0.11116D0,  0.09157D0,
     &     0.07397D0,  0.05855D0,  0.04538D0,  0.03436D0,  0.02540D0,
     &     0.01839D0,  0.01299D0,  0.00900D0,  0.00610D0,  0.00403D0,
     &     0.00259D0,  0.00165D0,  0.00107D0,  0.00064D0,  0.00040D0,
     &     0.00027D0,  0.00015D0,  0.00011D0,  0.00004D0,  0.00001D0,
     &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0/
      DATA (FMRS(1,8,I,14),I=1,49)/
     &     2.36037D0,  1.97834D0,  1.65740D0,  1.49390D0,  1.38749D0,
     &     1.31001D0,  1.09465D0,  0.91231D0,  0.81846D0,  0.75678D0,
     &     0.71089D0,  0.58224D0,  0.47125D0,  0.41385D0,  0.37630D0,
     &     0.34896D0,  0.31058D0,  0.27348D0,  0.23541D0,  0.21054D0,
     &     0.17694D0,  0.15252D0,  0.13212D0,  0.10968D0,  0.08980D0,
     &     0.07213D0,  0.05680D0,  0.04381D0,  0.03304D0,  0.02434D0,
     &     0.01758D0,  0.01241D0,  0.00857D0,  0.00582D0,  0.00382D0,
     &     0.00247D0,  0.00159D0,  0.00103D0,  0.00060D0,  0.00038D0,
     &     0.00026D0,  0.00014D0,  0.00011D0,  0.00004D0,  0.00001D0,
     &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0/
      DATA (FMRS(1,8,I,15),I=1,49)/
     &     2.73224D0,  2.26638D0,  1.87922D0,  1.68367D0,  1.55710D0,
     &     1.46530D0,  1.21194D0,  0.99975D0,  0.89148D0,  0.82073D0,
     &     0.76831D0,  0.62250D0,  0.49828D0,  0.43470D0,  0.39338D0,
     &     0.36342D0,  0.32158D0,  0.28138D0,  0.24036D0,  0.21374D0,
     &     0.17800D0,  0.15230D0,  0.13108D0,  0.10804D0,  0.08789D0,
     &     0.07017D0,  0.05499D0,  0.04222D0,  0.03170D0,  0.02325D0,
     &     0.01673D0,  0.01178D0,  0.00810D0,  0.00551D0,  0.00361D0,
     &     0.00232D0,  0.00150D0,  0.00098D0,  0.00058D0,  0.00036D0,
     &     0.00025D0,  0.00014D0,  0.00010D0,  0.00004D0,  0.00001D0,
     &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0/
      DATA (FMRS(1,8,I,16),I=1,49)/
     &     3.11511D0,  2.55975D0,  2.10267D0,  1.87361D0,  1.72607D0,
     &     1.61945D0,  1.32704D0,  1.08455D0,  0.96180D0,  0.88200D0,
     &     0.82308D0,  0.66038D0,  0.52333D0,  0.45384D0,  0.40893D0,
     &     0.37652D0,  0.33144D0,  0.28836D0,  0.24465D0,  0.21643D0,
     &     0.17877D0,  0.15196D0,  0.13002D0,  0.10649D0,  0.08613D0,
     &     0.06841D0,  0.05335D0,  0.04078D0,  0.03051D0,  0.02230D0,
     &     0.01601D0,  0.01123D0,  0.00772D0,  0.00522D0,  0.00344D0,
     &     0.00221D0,  0.00143D0,  0.00094D0,  0.00056D0,  0.00035D0,
     &     0.00023D0,  0.00014D0,  0.00009D0,  0.00004D0,  0.00001D0,
     &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0/
      DATA (FMRS(1,8,I,17),I=1,49)/
     &     3.54920D0,  2.88904D0,  2.35096D0,  2.08340D0,  1.91191D0,
     &     1.78843D0,  1.45191D0,  1.17555D0,  1.03678D0,  0.94701D0,
     &     0.88099D0,  0.69993D0,  0.54914D0,  0.47339D0,  0.42472D0,
     &     0.38973D0,  0.34130D0,  0.29525D0,  0.24881D0,  0.21897D0,
     &     0.17941D0,  0.15149D0,  0.12887D0,  0.10488D0,  0.08433D0,
     &     0.06664D0,  0.05172D0,  0.03936D0,  0.02933D0,  0.02138D0,
     &     0.01531D0,  0.01070D0,  0.00735D0,  0.00494D0,  0.00327D0,
     &     0.00210D0,  0.00135D0,  0.00089D0,  0.00053D0,  0.00034D0,
     &     0.00022D0,  0.00013D0,  0.00009D0,  0.00004D0,  0.00001D0,
     &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0/
      DATA (FMRS(1,8,I,18),I=1,49)/
     &     3.94722D0,  3.18825D0,  2.57451D0,  2.27128D0,  2.07769D0,
     &     1.93872D0,  1.56191D0,  1.25495D0,  1.10181D0,  1.00316D0,
     &     0.93081D0,  0.73357D0,  0.57081D0,  0.48966D0,  0.43777D0,
     &     0.40060D0,  0.34934D0,  0.30080D0,  0.25209D0,  0.22090D0,
     &     0.17980D0,  0.15100D0,  0.12785D0,  0.10349D0,  0.08283D0,
     &     0.06518D0,  0.05037D0,  0.03822D0,  0.02839D0,  0.02063D0,
     &     0.01472D0,  0.01026D0,  0.00705D0,  0.00475D0,  0.00313D0,
     &     0.00200D0,  0.00129D0,  0.00084D0,  0.00049D0,  0.00033D0,
     &     0.00020D0,  0.00013D0,  0.00009D0,  0.00003D0,  0.00001D0,
     &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0/
      DATA (FMRS(1,8,I,19),I=1,49)/
     &     4.47623D0,  3.58243D0,  2.86642D0,  2.51532D0,  2.29224D0,
     &     2.13264D0,  1.70256D0,  1.35552D0,  1.18371D0,  1.07357D0,
     &     0.99309D0,  0.77516D0,  0.59726D0,  0.50937D0,  0.45348D0,
     &     0.41360D0,  0.35886D0,  0.30730D0,  0.25582D0,  0.22304D0,
     &     0.18010D0,  0.15028D0,  0.12653D0,  0.10177D0,  0.08099D0,
     &     0.06341D0,  0.04879D0,  0.03686D0,  0.02728D0,  0.01973D0,
     &     0.01404D0,  0.00977D0,  0.00668D0,  0.00449D0,  0.00295D0,
     &     0.00189D0,  0.00122D0,  0.00079D0,  0.00046D0,  0.00031D0,
     &     0.00019D0,  0.00011D0,  0.00008D0,  0.00003D0,  0.00001D0,
     &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0/
      DATA (FMRS(1,8,I,20),I=1,49)/
     &     4.99213D0,  3.96349D0,  3.14614D0,  2.74797D0,  2.49601D0,
     &     2.31631D0,  1.83458D0,  1.44905D0,  1.25946D0,  1.13844D0,
     &     1.05027D0,  0.81294D0,  0.62102D0,  0.52694D0,  0.46740D0,
     &     0.42508D0,  0.36719D0,  0.31292D0,  0.25900D0,  0.22482D0,
     &     0.18028D0,  0.14958D0,  0.12531D0,  0.10024D0,  0.07938D0,
     &     0.06186D0,  0.04742D0,  0.03568D0,  0.02633D0,  0.01896D0,
     &     0.01347D0,  0.00937D0,  0.00636D0,  0.00427D0,  0.00280D0,
     &     0.00180D0,  0.00116D0,  0.00076D0,  0.00045D0,  0.00029D0,
     &     0.00019D0,  0.00009D0,  0.00007D0,  0.00003D0,  0.00001D0,
     &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0/
      DATA (FMRS(1,8,I,21),I=1,49)/
     &     5.49949D0,  4.33534D0,  3.41695D0,  2.97216D0,  2.69173D0,
     &     2.49225D0,  1.96002D0,  1.53717D0,  1.33047D0,  1.19901D0,
     &     1.10350D0,  0.84773D0,  0.64263D0,  0.54279D0,  0.47988D0,
     &     0.43530D0,  0.37453D0,  0.31778D0,  0.26166D0,  0.22622D0,
     &     0.18027D0,  0.14882D0,  0.12412D0,  0.09878D0,  0.07788D0,
     &     0.06045D0,  0.04618D0,  0.03463D0,  0.02546D0,  0.01831D0,
     &     0.01296D0,  0.00899D0,  0.00611D0,  0.00409D0,  0.00268D0,
     &     0.00172D0,  0.00111D0,  0.00073D0,  0.00045D0,  0.00028D0,
     &     0.00018D0,  0.00010D0,  0.00007D0,  0.00003D0,  0.00001D0,
     &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0/
      DATA (FMRS(1,8,I,22),I=1,49)/
     &     6.19994D0,  4.84455D0,  3.78480D0,  3.27524D0,  2.95541D0,
     &     2.72867D0,  2.12718D0,  1.65361D0,  1.42381D0,  1.27834D0,
     &     1.17300D0,  0.89272D0,  0.67027D0,  0.56291D0,  0.49563D0,
     &     0.44814D0,  0.38367D0,  0.32378D0,  0.26487D0,  0.22786D0,
     &     0.18016D0,  0.14778D0,  0.12256D0,  0.09693D0,  0.07601D0,
     &     0.05870D0,  0.04463D0,  0.03333D0,  0.02440D0,  0.01750D0,
     &     0.01234D0,  0.00854D0,  0.00580D0,  0.00388D0,  0.00253D0,
     &     0.00162D0,  0.00104D0,  0.00069D0,  0.00042D0,  0.00026D0,
     &     0.00018D0,  0.00010D0,  0.00006D0,  0.00003D0,  0.00001D0,
     &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0/
      DATA (FMRS(1,8,I,23),I=1,49)/
     &     6.91850D0,  5.36248D0,  4.15576D0,  3.57933D0,  3.21903D0,
     &     2.96436D0,  2.29236D0,  1.76765D0,  1.51472D0,  1.35530D0,
     &     1.24020D0,  0.93576D0,  0.69640D0,  0.58179D0,  0.51031D0,
     &     0.46004D0,  0.39207D0,  0.32922D0,  0.26771D0,  0.22925D0,
     &     0.17994D0,  0.14672D0,  0.12105D0,  0.09521D0,  0.07427D0,
     &     0.05708D0,  0.04320D0,  0.03213D0,  0.02345D0,  0.01676D0,
     &     0.01179D0,  0.00813D0,  0.00551D0,  0.00368D0,  0.00240D0,
     &     0.00152D0,  0.00099D0,  0.00064D0,  0.00039D0,  0.00024D0,
     &     0.00017D0,  0.00009D0,  0.00006D0,  0.00003D0,  0.00001D0,
     &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0/
      DATA (FMRS(1,8,I,24),I=1,49)/
     &     7.63491D0,  5.87479D0,  4.51976D0,  3.87632D0,  3.47562D0,
     &     3.19317D0,  2.45140D0,  1.87649D0,  1.60104D0,  1.42808D0,
     &     1.30355D0,  0.97589D0,  0.72045D0,  0.59900D0,  0.52360D0,
     &     0.47074D0,  0.39952D0,  0.33394D0,  0.27005D0,  0.23029D0,
     &     0.17956D0,  0.14561D0,  0.11956D0,  0.09355D0,  0.07262D0,
     &     0.05557D0,  0.04190D0,  0.03105D0,  0.02258D0,  0.01609D0,
     &     0.01128D0,  0.00777D0,  0.00525D0,  0.00350D0,  0.00227D0,
     &     0.00145D0,  0.00095D0,  0.00060D0,  0.00036D0,  0.00023D0,
     &     0.00015D0,  0.00008D0,  0.00006D0,  0.00003D0,  0.00001D0,
     &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0/
      DATA (FMRS(1,8,I,25),I=1,49)/
     &     8.40875D0,  6.42416D0,  4.90727D0,  4.19114D0,  3.74679D0,
     &     3.43441D0,  2.61784D0,  1.98954D0,  1.69029D0,  1.50308D0,
     &     1.36865D0,  1.01677D0,  0.74472D0,  0.61626D0,  0.53686D0,
     &     0.48138D0,  0.40687D0,  0.33856D0,  0.27230D0,  0.23124D0,
     &     0.17912D0,  0.14448D0,  0.11807D0,  0.09190D0,  0.07100D0,
     &     0.05410D0,  0.04063D0,  0.03001D0,  0.02174D0,  0.01545D0,
     &     0.01080D0,  0.00742D0,  0.00500D0,  0.00332D0,  0.00215D0,
     &     0.00138D0,  0.00091D0,  0.00056D0,  0.00034D0,  0.00022D0,
     &     0.00014D0,  0.00008D0,  0.00005D0,  0.00002D0,  0.00001D0,
     &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0/
      DATA (FMRS(1,8,I,26),I=1,49)/
     &     9.20959D0,  6.98865D0,  5.30257D0,  4.51092D0,  4.02140D0,
     &     3.67813D0,  2.78472D0,  2.10201D0,  1.77866D0,  1.57708D0,
     &     1.43269D0,  1.05659D0,  0.76808D0,  0.63273D0,  0.54942D0,
     &     0.49139D0,  0.41371D0,  0.34277D0,  0.27426D0,  0.23197D0,
     &     0.17855D0,  0.14327D0,  0.11656D0,  0.09025D0,  0.06944D0,
     &     0.05268D0,  0.03941D0,  0.02899D0,  0.02094D0,  0.01485D0,
     &     0.01035D0,  0.00708D0,  0.00476D0,  0.00316D0,  0.00205D0,
     &     0.00131D0,  0.00085D0,  0.00054D0,  0.00031D0,  0.00021D0,
     &     0.00013D0,  0.00008D0,  0.00005D0,  0.00002D0,  0.00001D0,
     &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0/
      DATA (FMRS(1,8,I,27),I=1,49)/
     &    10.01660D0,  7.55374D0,  5.69567D0,  4.82767D0,  4.29265D0,
     &     3.91834D0,  2.94808D0,  2.21134D0,  1.86419D0,  1.64848D0,
     &     1.49433D0,  1.09459D0,  0.79015D0,  0.64820D0,  0.56116D0,
     &     0.50070D0,  0.42001D0,  0.34660D0,  0.27598D0,  0.23256D0,
     &     0.17794D0,  0.14210D0,  0.11511D0,  0.08871D0,  0.06797D0,
     &     0.05137D0,  0.03829D0,  0.02806D0,  0.02022D0,  0.01430D0,
     &     0.00994D0,  0.00679D0,  0.00455D0,  0.00301D0,  0.00196D0,
     &     0.00124D0,  0.00081D0,  0.00052D0,  0.00030D0,  0.00020D0,
     &     0.00013D0,  0.00008D0,  0.00005D0,  0.00002D0,  0.00001D0,
     &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0/
      DATA (FMRS(1,8,I,28),I=1,49)/
     &    10.81622D0,  8.11020D0,  6.08037D0,  5.13653D0,  4.55643D0,
     &     4.15146D0,  3.10560D0,  2.31605D0,  1.94577D0,  1.71637D0,
     &     1.55278D0,  1.13032D0,  0.81070D0,  0.66250D0,  0.57195D0,
     &     0.50921D0,  0.42571D0,  0.35000D0,  0.27744D0,  0.23299D0,
     &     0.17730D0,  0.14094D0,  0.11373D0,  0.08726D0,  0.06658D0,
     &     0.05015D0,  0.03725D0,  0.02723D0,  0.01957D0,  0.01380D0,
     &     0.00957D0,  0.00653D0,  0.00437D0,  0.00288D0,  0.00188D0,
     &     0.00119D0,  0.00077D0,  0.00050D0,  0.00029D0,  0.00019D0,
     &     0.00012D0,  0.00007D0,  0.00005D0,  0.00002D0,  0.00001D0,
     &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0/
      DATA (FMRS(1,8,I,29),I=1,49)/
     &    11.66230D0,  8.69558D0,  6.48269D0,  5.45841D0,  4.83067D0,
     &     4.39335D0,  3.26805D0,  2.42336D0,  2.02906D0,  1.78549D0,
     &     1.61215D0,  1.16634D0,  0.83123D0,  0.67669D0,  0.58260D0,
     &     0.51757D0,  0.43126D0,  0.35327D0,  0.27879D0,  0.23332D0,
     &     0.17659D0,  0.13975D0,  0.11233D0,  0.08581D0,  0.06521D0,
     &     0.04895D0,  0.03623D0,  0.02642D0,  0.01893D0,  0.01332D0,
     &     0.00922D0,  0.00628D0,  0.00420D0,  0.00276D0,  0.00179D0,
     &     0.00113D0,  0.00073D0,  0.00048D0,  0.00028D0,  0.00018D0,
     &     0.00012D0,  0.00007D0,  0.00004D0,  0.00001D0,  0.00001D0,
     &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0/
      DATA (FMRS(1,8,I,30),I=1,49)/
     &    12.53147D0,  9.29349D0,  6.89124D0,  5.78416D0,  5.10752D0,
     &     4.63707D0,  3.43073D0,  2.53015D0,  2.11162D0,  1.85381D0,
     &     1.67070D0,  1.20157D0,  0.85112D0,  0.69035D0,  0.59278D0,
     &     0.52552D0,  0.43648D0,  0.35628D0,  0.27996D0,  0.23352D0,
     &     0.17581D0,  0.13853D0,  0.11093D0,  0.08439D0,  0.06389D0,
     &     0.04778D0,  0.03525D0,  0.02563D0,  0.01832D0,  0.01286D0,
     &     0.00888D0,  0.00603D0,  0.00403D0,  0.00265D0,  0.00171D0,
     &     0.00109D0,  0.00070D0,  0.00046D0,  0.00026D0,  0.00017D0,
     &     0.00011D0,  0.00006D0,  0.00004D0,  0.00001D0,  0.00000D0,
     &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0/
      DATA (FMRS(1,8,I,31),I=1,49)/
     &    13.39986D0,  9.88770D0,  7.29509D0,  6.10513D0,  5.37969D0,
     &     4.87627D0,  3.58951D0,  2.63377D0,  2.19145D0,  1.91971D0,
     &     1.72706D0,  1.23525D0,  0.86997D0,  0.70322D0,  0.60234D0,
     &     0.53296D0,  0.44131D0,  0.35903D0,  0.28099D0,  0.23364D0,
     &     0.17503D0,  0.13736D0,  0.10960D0,  0.08305D0,  0.06264D0,
     &     0.04669D0,  0.03435D0,  0.02491D0,  0.01775D0,  0.01244D0,
     &     0.00857D0,  0.00581D0,  0.00387D0,  0.00255D0,  0.00164D0,
     &     0.00105D0,  0.00067D0,  0.00044D0,  0.00025D0,  0.00016D0,
     &     0.00011D0,  0.00006D0,  0.00004D0,  0.00002D0,  0.00000D0,
     &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0/
      DATA (FMRS(1,8,I,32),I=1,49)/
     &    14.24690D0, 10.46430D0,  7.68491D0,  6.41400D0,  5.64102D0,
     &     5.10551D0,  3.74084D0,  2.73196D0,  2.26682D0,  1.98174D0,
     &     1.77998D0,  1.26662D0,  0.88736D0,  0.71501D0,  0.61103D0,
     &     0.53966D0,  0.44562D0,  0.36142D0,  0.28180D0,  0.23363D0,
     &     0.17423D0,  0.13620D0,  0.10832D0,  0.08177D0,  0.06147D0,
     &     0.04567D0,  0.03352D0,  0.02425D0,  0.01724D0,  0.01204D0,
     &     0.00828D0,  0.00559D0,  0.00373D0,  0.00245D0,  0.00158D0,
     &     0.00099D0,  0.00065D0,  0.00042D0,  0.00024D0,  0.00015D0,
     &     0.00010D0,  0.00006D0,  0.00004D0,  0.00002D0,  0.00000D0,
     &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0/
      DATA (FMRS(1,8,I,33),I=1,49)/
     &    15.14936D0, 11.07583D0,  8.09647D0,  6.73922D0,  5.91564D0,
     &     5.34608D0,  3.89891D0,  2.83403D0,  2.34496D0,  2.04593D0,
     &     1.83464D0,  1.29886D0,  0.90513D0,  0.72701D0,  0.61986D0,
     &     0.54647D0,  0.44998D0,  0.36383D0,  0.28262D0,  0.23362D0,
     &     0.17343D0,  0.13505D0,  0.10704D0,  0.08050D0,  0.06032D0,
     &     0.04468D0,  0.03270D0,  0.02360D0,  0.01675D0,  0.01165D0,
     &     0.00800D0,  0.00538D0,  0.00360D0,  0.00236D0,  0.00153D0,
     &     0.00094D0,  0.00062D0,  0.00040D0,  0.00024D0,  0.00014D0,
     &     0.00010D0,  0.00005D0,  0.00004D0,  0.00002D0,  0.00000D0,
     &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0/
      DATA (FMRS(1,8,I,34),I=1,49)/
     &    16.05264D0, 11.68476D0,  8.50413D0,  7.06033D0,  6.18619D0,
     &     5.58264D0,  4.05344D0,  2.93321D0,  2.42057D0,  2.10785D0,
     &     1.88726D0,  1.32960D0,  0.92187D0,  0.73821D0,  0.62802D0,
     &     0.55270D0,  0.45389D0,  0.36590D0,  0.28320D0,  0.23345D0,
     &     0.17251D0,  0.13385D0,  0.10575D0,  0.07924D0,  0.05918D0,
     &     0.04371D0,  0.03189D0,  0.02297D0,  0.01625D0,  0.01129D0,
     &     0.00773D0,  0.00520D0,  0.00346D0,  0.00227D0,  0.00146D0,
     &     0.00090D0,  0.00059D0,  0.00038D0,  0.00022D0,  0.00014D0,
     &     0.00009D0,  0.00005D0,  0.00004D0,  0.00001D0,  0.00000D0,
     &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0/
      DATA (FMRS(1,8,I,35),I=1,49)/
     &    16.95831D0, 12.29275D0,  8.90942D0,  7.37879D0,  6.45402D0,
     &     5.81651D0,  4.20556D0,  3.03041D0,  2.49449D0,  2.16827D0,
     &     1.93852D0,  1.35941D0,  0.93802D0,  0.74899D0,  0.63586D0,
     &     0.55868D0,  0.45763D0,  0.36787D0,  0.28375D0,  0.23328D0,
     &     0.17165D0,  0.13272D0,  0.10453D0,  0.07807D0,  0.05811D0,
     &     0.04281D0,  0.03114D0,  0.02238D0,  0.01579D0,  0.01096D0,
     &     0.00748D0,  0.00503D0,  0.00334D0,  0.00218D0,  0.00141D0,
     &     0.00087D0,  0.00056D0,  0.00036D0,  0.00021D0,  0.00013D0,
     &     0.00009D0,  0.00005D0,  0.00004D0,  0.00001D0,  0.00000D0,
     &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0/
      DATA (FMRS(1,8,I,36),I=1,49)/
     &    17.84218D0, 12.88352D0,  9.30151D0,  7.68607D0,  6.71197D0,
     &     6.04141D0,  4.35117D0,  3.12299D0,  2.56467D0,  2.22550D0,
     &     1.98697D0,  1.38741D0,  0.95307D0,  0.75895D0,  0.64306D0,
     &     0.56414D0,  0.46100D0,  0.36960D0,  0.28418D0,  0.23305D0,
     &     0.17079D0,  0.13162D0,  0.10337D0,  0.07695D0,  0.05711D0,
     &     0.04196D0,  0.03045D0,  0.02184D0,  0.01537D0,  0.01065D0,
     &     0.00725D0,  0.00488D0,  0.00323D0,  0.00211D0,  0.00135D0,
     &     0.00084D0,  0.00054D0,  0.00035D0,  0.00020D0,  0.00012D0,
     &     0.00009D0,  0.00005D0,  0.00003D0,  0.00001D0,  0.00000D0,
     &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0/
      DATA (FMRS(1,8,I,37),I=1,49)/
     &    18.75837D0, 13.49331D0,  9.70449D0,  8.00107D0,  6.97591D0,
     &     6.27121D0,  4.49926D0,  3.21668D0,  2.63548D0,  2.28312D0,
     &     2.03566D0,  1.41534D0,  0.96795D0,  0.76874D0,  0.65009D0,
     &     0.56943D0,  0.46423D0,  0.37122D0,  0.28450D0,  0.23274D0,
     &     0.16989D0,  0.13050D0,  0.10219D0,  0.07583D0,  0.05612D0,
     &     0.04112D0,  0.02978D0,  0.02129D0,  0.01496D0,  0.01035D0,
     &     0.00703D0,  0.00473D0,  0.00312D0,  0.00203D0,  0.00130D0,
     &     0.00081D0,  0.00052D0,  0.00034D0,  0.00019D0,  0.00012D0,
     &     0.00008D0,  0.00005D0,  0.00003D0,  0.00001D0,  0.00000D0,
     &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0/
      DATA (FMRS(1,8,I,38),I=1,49)/
     &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
     &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
     &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
     &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
     &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
     &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
     &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
     &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
     &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
     &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0/
      DATA (FMRS(2,1,I, 1),I=1,49)/
     &     0.01616D0,  0.01968D0,  0.02397D0,  0.02690D0,  0.02921D0,
     &     0.03113D0,  0.03797D0,  0.04639D0,  0.05222D0,  0.05685D0,
     &     0.06076D0,  0.07508D0,  0.09409D0,  0.10852D0,  0.12095D0,
     &     0.13220D0,  0.15265D0,  0.18041D0,  0.22265D0,  0.26180D0,
     &     0.33338D0,  0.39710D0,  0.45318D0,  0.51262D0,  0.56037D0,
     &     0.59685D0,  0.62256D0,  0.63820D0,  0.64458D0,  0.64218D0,
     &     0.63256D0,  0.61605D0,  0.59381D0,  0.56668D0,  0.53544D0,
     &     0.50113D0,  0.46441D0,  0.42608D0,  0.38703D0,  0.34764D0,
     &     0.30873D0,  0.27101D0,  0.23457D0,  0.16829D0,  0.11224D0,
     &     0.06802D0,  0.03588D0,  0.00449D0,  0.00000D0/
      DATA (FMRS(2,1,I, 2),I=1,49)/
     &     0.01632D0,  0.01989D0,  0.02423D0,  0.02721D0,  0.02954D0,
     &     0.03149D0,  0.03843D0,  0.04698D0,  0.05290D0,  0.05761D0,
     &     0.06159D0,  0.07621D0,  0.09566D0,  0.11046D0,  0.12320D0,
     &     0.13473D0,  0.15566D0,  0.18401D0,  0.22694D0,  0.26649D0,
     &     0.33826D0,  0.40154D0,  0.45671D0,  0.51456D0,  0.56041D0,
     &     0.59481D0,  0.61838D0,  0.63191D0,  0.63628D0,  0.63211D0,
     &     0.62085D0,  0.60298D0,  0.57964D0,  0.55165D0,  0.51988D0,
     &     0.48526D0,  0.44851D0,  0.41042D0,  0.37182D0,  0.33308D0,
     &     0.29500D0,  0.25823D0,  0.22287D0,  0.15893D0,  0.10532D0,
     &     0.06336D0,  0.03315D0,  0.00405D0,  0.00000D0/
      DATA (FMRS(2,1,I, 3),I=1,49)/
     &     0.01657D0,  0.02020D0,  0.02463D0,  0.02767D0,  0.03005D0,
     &     0.03204D0,  0.03912D0,  0.04786D0,  0.05393D0,  0.05876D0,
     &     0.06285D0,  0.07791D0,  0.09803D0,  0.11338D0,  0.12658D0,
     &     0.13853D0,  0.16018D0,  0.18937D0,  0.23326D0,  0.27335D0,
     &     0.34527D0,  0.40778D0,  0.46152D0,  0.51696D0,  0.55995D0,
     &     0.59126D0,  0.61170D0,  0.62221D0,  0.62369D0,  0.61697D0,
     &     0.60343D0,  0.58371D0,  0.55889D0,  0.52978D0,  0.49735D0,
     &     0.46237D0,  0.42568D0,  0.38804D0,  0.35014D0,  0.31246D0,
     &     0.27562D0,  0.24027D0,  0.20650D0,  0.14595D0,  0.09580D0,
     &     0.05701D0,  0.02946D0,  0.00347D0,  0.00000D0/
      DATA (FMRS(2,1,I, 4),I=1,49)/
     &     0.01676D0,  0.02044D0,  0.02493D0,  0.02801D0,  0.03042D0,
     &     0.03244D0,  0.03964D0,  0.04852D0,  0.05470D0,  0.05962D0,
     &     0.06379D0,  0.07918D0,  0.09980D0,  0.11554D0,  0.12909D0,
     &     0.14134D0,  0.16349D0,  0.19329D0,  0.23784D0,  0.27828D0,
     &     0.35023D0,  0.41207D0,  0.46471D0,  0.51833D0,  0.55923D0,
     &     0.58830D0,  0.60648D0,  0.61486D0,  0.61433D0,  0.60584D0,
     &     0.59072D0,  0.56980D0,  0.54398D0,  0.51418D0,  0.48131D0,
     &     0.44619D0,  0.40966D0,  0.37236D0,  0.33505D0,  0.29814D0,
     &     0.26220D0,  0.22791D0,  0.19528D0,  0.13713D0,  0.08936D0,
     &     0.05277D0,  0.02703D0,  0.00310D0,  0.00000D0/
      DATA (FMRS(2,1,I, 5),I=1,49)/
     &     0.01695D0,  0.02068D0,  0.02524D0,  0.02837D0,  0.03082D0,
     &     0.03287D0,  0.04018D0,  0.04922D0,  0.05552D0,  0.06053D0,
     &     0.06480D0,  0.08053D0,  0.10168D0,  0.11784D0,  0.13174D0,
     &     0.14430D0,  0.16698D0,  0.19737D0,  0.24257D0,  0.28331D0,
     &     0.35517D0,  0.41625D0,  0.46767D0,  0.51932D0,  0.55801D0,
     &     0.58472D0,  0.60061D0,  0.60677D0,  0.60420D0,  0.59394D0,
     &     0.57732D0,  0.55511D0,  0.52831D0,  0.49795D0,  0.46473D0,
     &     0.42958D0,  0.39324D0,  0.35636D0,  0.31976D0,  0.28363D0,
     &     0.24869D0,  0.21549D0,  0.18405D0,  0.12838D0,  0.08307D0,
     &     0.04866D0,  0.02468D0,  0.00276D0,  0.00000D0/
      DATA (FMRS(2,1,I, 6),I=1,49)/
     &     0.01712D0,  0.02090D0,  0.02552D0,  0.02868D0,  0.03117D0,
     &     0.03325D0,  0.04066D0,  0.04984D0,  0.05623D0,  0.06133D0,
     &     0.06568D0,  0.08172D0,  0.10333D0,  0.11984D0,  0.13405D0,
     &     0.14688D0,  0.17001D0,  0.20090D0,  0.24663D0,  0.28761D0,
     &     0.35934D0,  0.41972D0,  0.47004D0,  0.51998D0,  0.55675D0,
     &     0.58145D0,  0.59540D0,  0.59970D0,  0.59545D0,  0.58373D0,
     &     0.56587D0,  0.54263D0,  0.51509D0,  0.48426D0,  0.45082D0,
     &     0.41570D0,  0.37956D0,  0.34309D0,  0.30710D0,  0.27167D0,
     &     0.23758D0,  0.20532D0,  0.17488D0,  0.12129D0,  0.07799D0,
     &     0.04537D0,  0.02283D0,  0.00249D0,  0.00000D0/
      DATA (FMRS(2,1,I, 7),I=1,49)/
     &     0.01728D0,  0.02111D0,  0.02578D0,  0.02899D0,  0.03151D0,
     &     0.03361D0,  0.04113D0,  0.05044D0,  0.05693D0,  0.06211D0,
     &     0.06653D0,  0.08287D0,  0.10492D0,  0.12178D0,  0.13628D0,
     &     0.14936D0,  0.17290D0,  0.20425D0,  0.25045D0,  0.29164D0,
     &     0.36316D0,  0.42280D0,  0.47203D0,  0.52030D0,  0.55522D0,
     &     0.57804D0,  0.59016D0,  0.59271D0,  0.58692D0,  0.57390D0,
     &     0.55488D0,  0.53075D0,  0.50265D0,  0.47135D0,  0.43776D0,
     &     0.40267D0,  0.36679D0,  0.33078D0,  0.29535D0,  0.26064D0,
     &     0.22735D0,  0.19600D0,  0.16649D0,  0.11484D0,  0.07339D0,
     &     0.04241D0,  0.02117D0,  0.00226D0,  0.00000D0/
      DATA (FMRS(2,1,I, 8),I=1,49)/
     &     0.01745D0,  0.02133D0,  0.02606D0,  0.02931D0,  0.03187D0,
     &     0.03400D0,  0.04163D0,  0.05108D0,  0.05768D0,  0.06295D0,
     &     0.06745D0,  0.08411D0,  0.10662D0,  0.12385D0,  0.13865D0,
     &     0.15200D0,  0.17596D0,  0.20780D0,  0.25445D0,  0.29582D0,
     &     0.36707D0,  0.42589D0,  0.47392D0,  0.52041D0,  0.55338D0,
     &     0.57422D0,  0.58442D0,  0.58519D0,  0.57783D0,  0.56344D0,
     &     0.54329D0,  0.51831D0,  0.48960D0,  0.45793D0,  0.42423D0,
     &     0.38922D0,  0.35366D0,  0.31814D0,  0.28333D0,  0.24940D0,
     &     0.21696D0,  0.18656D0,  0.15803D0,  0.10837D0,  0.06882D0,
     &     0.03949D0,  0.01956D0,  0.00204D0,  0.00000D0/
      DATA (FMRS(2,1,I, 9),I=1,49)/
     &     0.01760D0,  0.02152D0,  0.02631D0,  0.02960D0,  0.03218D0,
     &     0.03434D0,  0.04207D0,  0.05164D0,  0.05833D0,  0.06368D0,
     &     0.06825D0,  0.08519D0,  0.10811D0,  0.12566D0,  0.14073D0,
     &     0.15430D0,  0.17863D0,  0.21087D0,  0.25789D0,  0.29938D0,
     &     0.37036D0,  0.42844D0,  0.47541D0,  0.52034D0,  0.55162D0,
     &     0.57077D0,  0.57932D0,  0.57861D0,  0.56993D0,  0.55438D0,
     &     0.53332D0,  0.50767D0,  0.47844D0,  0.44653D0,  0.41277D0,
     &     0.37787D0,  0.34261D0,  0.30753D0,  0.27327D0,  0.24001D0,
     &     0.20832D0,  0.17873D0,  0.15102D0,  0.10304D0,  0.06508D0,
     &     0.03712D0,  0.01826D0,  0.00186D0,  0.00000D0/
      DATA (FMRS(2,1,I,10),I=1,49)/
     &     0.01775D0,  0.02171D0,  0.02655D0,  0.02988D0,  0.03249D0,
     &     0.03468D0,  0.04249D0,  0.05219D0,  0.05897D0,  0.06440D0,
     &     0.06904D0,  0.08625D0,  0.10956D0,  0.12741D0,  0.14273D0,
     &     0.15651D0,  0.18119D0,  0.21379D0,  0.26115D0,  0.30273D0,
     &     0.37339D0,  0.43070D0,  0.47663D0,  0.52004D0,  0.54971D0,
     &     0.56723D0,  0.57424D0,  0.57214D0,  0.56221D0,  0.54564D0,
     &     0.52375D0,  0.49748D0,  0.46783D0,  0.43572D0,  0.40192D0,
     &     0.36718D0,  0.33221D0,  0.29755D0,  0.26385D0,  0.23124D0,
     &     0.20028D0,  0.17145D0,  0.14454D0,  0.09813D0,  0.06166D0,
     &     0.03497D0,  0.01708D0,  0.00171D0,  0.00000D0/
      DATA (FMRS(2,1,I,11),I=1,49)/
     &     0.01786D0,  0.02185D0,  0.02674D0,  0.03010D0,  0.03274D0,
     &     0.03494D0,  0.04284D0,  0.05263D0,  0.05949D0,  0.06497D0,
     &     0.06967D0,  0.08709D0,  0.11072D0,  0.12880D0,  0.14432D0,
     &     0.15827D0,  0.18322D0,  0.21609D0,  0.26371D0,  0.30535D0,
     &     0.37572D0,  0.43240D0,  0.47751D0,  0.51970D0,  0.54811D0,
     &     0.56435D0,  0.57017D0,  0.56701D0,  0.55612D0,  0.53878D0,
     &     0.51626D0,  0.48950D0,  0.45957D0,  0.42732D0,  0.39351D0,
     &     0.35893D0,  0.32420D0,  0.28986D0,  0.25663D0,  0.22452D0,
     &     0.19414D0,  0.16588D0,  0.13961D0,  0.09442D0,  0.05909D0,
     &     0.03336D0,  0.01621D0,  0.00160D0,  0.00000D0/
      DATA (FMRS(2,1,I,12),I=1,49)/
     &     0.01811D0,  0.02217D0,  0.02715D0,  0.03057D0,  0.03326D0,
     &     0.03551D0,  0.04357D0,  0.05358D0,  0.06059D0,  0.06620D0,
     &     0.07102D0,  0.08890D0,  0.11320D0,  0.13179D0,  0.14772D0,
     &     0.16201D0,  0.18751D0,  0.22095D0,  0.26905D0,  0.31076D0,
     &     0.38043D0,  0.43573D0,  0.47902D0,  0.51865D0,  0.54434D0,
     &     0.55794D0,  0.56131D0,  0.55592D0,  0.54308D0,  0.52418D0,
     &     0.50041D0,  0.47277D0,  0.44227D0,  0.40979D0,  0.37605D0,
     &     0.34185D0,  0.30765D0,  0.27411D0,  0.24188D0,  0.21085D0,
     &     0.18166D0,  0.15463D0,  0.12966D0,  0.08698D0,  0.05397D0,
     &     0.03017D0,  0.01449D0,  0.00138D0,  0.00000D0/
      DATA (FMRS(2,1,I,13),I=1,49)/
     &     0.01832D0,  0.02245D0,  0.02751D0,  0.03099D0,  0.03372D0,
     &     0.03601D0,  0.04421D0,  0.05440D0,  0.06155D0,  0.06727D0,
     &     0.07220D0,  0.09048D0,  0.11535D0,  0.13437D0,  0.15065D0,
     &     0.16524D0,  0.19119D0,  0.22510D0,  0.27356D0,  0.31528D0,
     &     0.38427D0,  0.43832D0,  0.48002D0,  0.51742D0,  0.54081D0,
     &     0.55220D0,  0.55352D0,  0.54629D0,  0.53189D0,  0.51174D0,
     &     0.48699D0,  0.45870D0,  0.42778D0,  0.39517D0,  0.36159D0,
     &     0.32774D0,  0.29406D0,  0.26124D0,  0.22984D0,  0.19975D0,
     &     0.17155D0,  0.14556D0,  0.12166D0,  0.08107D0,  0.04993D0,
     &     0.02767D0,  0.01316D0,  0.00122D0,  0.00000D0/
      DATA (FMRS(2,1,I,14),I=1,49)/
     &     0.01856D0,  0.02276D0,  0.02791D0,  0.03145D0,  0.03424D0,
     &     0.03657D0,  0.04493D0,  0.05533D0,  0.06263D0,  0.06849D0,
     &     0.07353D0,  0.09227D0,  0.11778D0,  0.13727D0,  0.15393D0,
     &     0.16884D0,  0.19528D0,  0.22966D0,  0.27847D0,  0.32014D0,
     &     0.38833D0,  0.44089D0,  0.48079D0,  0.51572D0,  0.53660D0,
     &     0.54555D0,  0.54466D0,  0.53550D0,  0.51948D0,  0.49806D0,
     &     0.47232D0,  0.44337D0,  0.41209D0,  0.37941D0,  0.34606D0,
     &     0.31264D0,  0.27962D0,  0.24761D0,  0.21707D0,  0.18804D0,
     &     0.16093D0,  0.13609D0,  0.11331D0,  0.07496D0,  0.04577D0,
     &     0.02513D0,  0.01183D0,  0.00106D0,  0.00000D0/
      DATA (FMRS(2,1,I,15),I=1,49)/
     &     0.01882D0,  0.02309D0,  0.02833D0,  0.03194D0,  0.03478D0,
     &     0.03716D0,  0.04569D0,  0.05632D0,  0.06378D0,  0.06977D0,
     &     0.07493D0,  0.09414D0,  0.12031D0,  0.14028D0,  0.15732D0,
     &     0.17254D0,  0.19946D0,  0.23430D0,  0.28337D0,  0.32492D0,
     &     0.39212D0,  0.44309D0,  0.48109D0,  0.51344D0,  0.53176D0,
     &     0.53830D0,  0.53520D0,  0.52410D0,  0.50654D0,  0.48389D0,
     &     0.45725D0,  0.42772D0,  0.39621D0,  0.36351D0,  0.33050D0,
     &     0.29757D0,  0.26525D0,  0.23404D0,  0.20451D0,  0.17653D0,
     &     0.15059D0,  0.12691D0,  0.10526D0,  0.06909D0,  0.04183D0,
     &     0.02276D0,  0.01059D0,  0.00092D0,  0.00000D0/
      DATA (FMRS(2,1,I,16),I=1,49)/
     &     0.01904D0,  0.02338D0,  0.02872D0,  0.03239D0,  0.03528D0,
     &     0.03770D0,  0.04639D0,  0.05722D0,  0.06483D0,  0.07094D0,
     &     0.07621D0,  0.09585D0,  0.12261D0,  0.14301D0,  0.16039D0,
     &     0.17588D0,  0.20321D0,  0.23842D0,  0.28769D0,  0.32908D0,
     &     0.39530D0,  0.44481D0,  0.48105D0,  0.51110D0,  0.52712D0,
     &     0.53155D0,  0.52655D0,  0.51382D0,  0.49491D0,  0.47126D0,
     &     0.44390D0,  0.41395D0,  0.38228D0,  0.34968D0,  0.31695D0,
     &     0.28453D0,  0.25288D0,  0.22245D0,  0.19380D0,  0.16677D0,
     &     0.14180D0,  0.11912D0,  0.09847D0,  0.06418D0,  0.03856D0,
     &     0.02081D0,  0.00959D0,  0.00081D0,  0.00000D0/
      DATA (FMRS(2,1,I,17),I=1,49)/
     &     0.01928D0,  0.02369D0,  0.02911D0,  0.03284D0,  0.03578D0,
     &     0.03825D0,  0.04709D0,  0.05813D0,  0.06589D0,  0.07213D0,
     &     0.07751D0,  0.09758D0,  0.12493D0,  0.14576D0,  0.16348D0,
     &     0.17924D0,  0.20696D0,  0.24251D0,  0.29193D0,  0.33312D0,
     &     0.39831D0,  0.44629D0,  0.48077D0,  0.50852D0,  0.52228D0,
     &     0.52463D0,  0.51781D0,  0.50355D0,  0.48335D0,  0.45879D0,
     &     0.43078D0,  0.40049D0,  0.36872D0,  0.33629D0,  0.30386D0,
     &     0.27197D0,  0.24101D0,  0.21137D0,  0.18360D0,  0.15751D0,
     &     0.13349D0,  0.11178D0,  0.09210D0,  0.05961D0,  0.03555D0,
     &     0.01901D0,  0.00868D0,  0.00071D0,  0.00000D0/
      DATA (FMRS(2,1,I,18),I=1,49)/
     &     0.01947D0,  0.02394D0,  0.02943D0,  0.03322D0,  0.03621D0,
     &     0.03871D0,  0.04769D0,  0.05889D0,  0.06678D0,  0.07312D0,
     &     0.07860D0,  0.09903D0,  0.12687D0,  0.14804D0,  0.16603D0,
     &     0.18199D0,  0.21002D0,  0.24583D0,  0.29534D0,  0.33632D0,
     &     0.40060D0,  0.44729D0,  0.48029D0,  0.50614D0,  0.51810D0,
     &     0.51876D0,  0.51049D0,  0.49502D0,  0.47387D0,  0.44861D0,
     &     0.42013D0,  0.38960D0,  0.35780D0,  0.32553D0,  0.29342D0,
     &     0.26197D0,  0.23158D0,  0.20258D0,  0.17557D0,  0.15022D0,
     &     0.12699D0,  0.10608D0,  0.08715D0,  0.05607D0,  0.03324D0,
     &     0.01765D0,  0.00799D0,  0.00064D0,  0.00000D0/
      DATA (FMRS(2,1,I,19),I=1,49)/
     &     0.01970D0,  0.02424D0,  0.02983D0,  0.03369D0,  0.03672D0,
     &     0.03927D0,  0.04841D0,  0.05983D0,  0.06787D0,  0.07433D0,
     &     0.07993D0,  0.10079D0,  0.12921D0,  0.15080D0,  0.16909D0,
     &     0.18531D0,  0.21368D0,  0.24977D0,  0.29932D0,  0.34002D0,
     &     0.40312D0,  0.44820D0,  0.47944D0,  0.50301D0,  0.51281D0,
     &     0.51154D0,  0.50156D0,  0.48470D0,  0.46252D0,  0.43645D0,
     &     0.40748D0,  0.37672D0,  0.34495D0,  0.31293D0,  0.28123D0,
     &     0.25036D0,  0.22064D0,  0.19244D0,  0.16630D0,  0.14187D0,
     &     0.11955D0,  0.09954D0,  0.08152D0,  0.05209D0,  0.03065D0,
     &     0.01614D0,  0.00723D0,  0.00056D0,  0.00000D0/
      DATA (FMRS(2,1,I,20),I=1,49)/
     &     0.01991D0,  0.02452D0,  0.03019D0,  0.03410D0,  0.03718D0,
     &     0.03977D0,  0.04905D0,  0.06066D0,  0.06884D0,  0.07541D0,
     &     0.08111D0,  0.10235D0,  0.13129D0,  0.15323D0,  0.17180D0,
     &     0.18822D0,  0.21689D0,  0.25320D0,  0.30276D0,  0.34318D0,
     &     0.40521D0,  0.44885D0,  0.47855D0,  0.50013D0,  0.50806D0,
     &     0.50515D0,  0.49374D0,  0.47571D0,  0.45269D0,  0.42596D0,
     &     0.39662D0,  0.36569D0,  0.33399D0,  0.30222D0,  0.27090D0,
     &     0.24056D0,  0.21144D0,  0.18393D0,  0.15855D0,  0.13491D0,
     &     0.11336D0,  0.09413D0,  0.07687D0,  0.04883D0,  0.02854D0,
     &     0.01493D0,  0.00663D0,  0.00051D0,  0.00000D0/
      DATA (FMRS(2,1,I,21),I=1,49)/
     &     0.02011D0,  0.02477D0,  0.03051D0,  0.03448D0,  0.03760D0,
     &     0.04023D0,  0.04965D0,  0.06143D0,  0.06973D0,  0.07641D0,
     &     0.08220D0,  0.10379D0,  0.13319D0,  0.15544D0,  0.17424D0,
     &     0.19085D0,  0.21976D0,  0.25625D0,  0.30577D0,  0.34590D0,
     &     0.40689D0,  0.44921D0,  0.47746D0,  0.49725D0,  0.50352D0,
     &     0.49914D0,  0.48649D0,  0.46748D0,  0.44367D0,  0.41645D0,
     &     0.38678D0,  0.35582D0,  0.32417D0,  0.29264D0,  0.26169D0,
     &     0.23187D0,  0.20335D0,  0.17646D0,  0.15176D0,  0.12881D0,
     &     0.10798D0,  0.08943D0,  0.07284D0,  0.04602D0,  0.02675D0,
     &     0.01389D0,  0.00613D0,  0.00046D0,  0.00000D0/
      DATA (FMRS(2,1,I,22),I=1,49)/
     &     0.02035D0,  0.02509D0,  0.03093D0,  0.03496D0,  0.03814D0,
     &     0.04081D0,  0.05040D0,  0.06241D0,  0.07087D0,  0.07768D0,
     &     0.08359D0,  0.10562D0,  0.13559D0,  0.15824D0,  0.17734D0,
     &     0.19417D0,  0.22338D0,  0.26006D0,  0.30949D0,  0.34920D0,
     &     0.40885D0,  0.44948D0,  0.47592D0,  0.49348D0,  0.49770D0,
     &     0.49152D0,  0.47736D0,  0.45716D0,  0.43246D0,  0.40467D0,
     &     0.37468D0,  0.34367D0,  0.31217D0,  0.28097D0,  0.25052D0,
     &     0.22133D0,  0.19355D0,  0.16747D0,  0.14359D0,  0.12150D0,
     &     0.10155D0,  0.08384D0,  0.06806D0,  0.04272D0,  0.02464D0,
     &     0.01269D0,  0.00554D0,  0.00040D0,  0.00000D0/
      DATA (FMRS(2,1,I,23),I=1,49)/
     &     0.02058D0,  0.02539D0,  0.03132D0,  0.03542D0,  0.03865D0,
     &     0.04137D0,  0.05112D0,  0.06333D0,  0.07195D0,  0.07888D0,
     &     0.08490D0,  0.10735D0,  0.13786D0,  0.16087D0,  0.18023D0,
     &     0.19726D0,  0.22673D0,  0.26356D0,  0.31287D0,  0.35216D0,
     &     0.41052D0,  0.44953D0,  0.47430D0,  0.48980D0,  0.49215D0,
     &     0.48435D0,  0.46885D0,  0.44758D0,  0.42215D0,  0.39387D0,
     &     0.36366D0,  0.33261D0,  0.30132D0,  0.27045D0,  0.24050D0,
     &     0.21190D0,  0.18476D0,  0.15947D0,  0.13635D0,  0.11504D0,
     &     0.09587D0,  0.07894D0,  0.06387D0,  0.03984D0,  0.02282D0,
     &     0.01167D0,  0.00505D0,  0.00036D0,  0.00000D0/
      DATA (FMRS(2,1,I,24),I=1,49)/
     &     0.02080D0,  0.02568D0,  0.03170D0,  0.03585D0,  0.03914D0,
     &     0.04189D0,  0.05180D0,  0.06421D0,  0.07296D0,  0.08001D0,
     &     0.08614D0,  0.10897D0,  0.13997D0,  0.16330D0,  0.18290D0,
     &     0.20010D0,  0.22978D0,  0.26672D0,  0.31586D0,  0.35473D0,
     &     0.41182D0,  0.44931D0,  0.47248D0,  0.48612D0,  0.48676D0,
     &     0.47750D0,  0.46081D0,  0.43866D0,  0.41258D0,  0.38389D0,
     &     0.35352D0,  0.32245D0,  0.29140D0,  0.26089D0,  0.23143D0,
     &     0.20340D0,  0.17690D0,  0.15229D0,  0.12990D0,  0.10931D0,
     &     0.09084D0,  0.07461D0,  0.06021D0,  0.03734D0,  0.02125D0,
     &     0.01078D0,  0.00462D0,  0.00032D0,  0.00000D0/
      DATA (FMRS(2,1,I,25),I=1,49)/
     &     0.02102D0,  0.02596D0,  0.03207D0,  0.03629D0,  0.03962D0,
     &     0.04242D0,  0.05248D0,  0.06508D0,  0.07398D0,  0.08115D0,
     &     0.08738D0,  0.11059D0,  0.14207D0,  0.16573D0,  0.18556D0,
     &     0.20292D0,  0.23281D0,  0.26985D0,  0.31879D0,  0.35722D0,
     &     0.41303D0,  0.44900D0,  0.47060D0,  0.48240D0,  0.48138D0,
     &     0.47074D0,  0.45292D0,  0.42993D0,  0.40324D0,  0.37421D0,
     &     0.34370D0,  0.31266D0,  0.28186D0,  0.25172D0,  0.22275D0,
     &     0.19528D0,  0.16943D0,  0.14547D0,  0.12379D0,  0.10391D0,
     &     0.08611D0,  0.07055D0,  0.05678D0,  0.03501D0,  0.01980D0,
     &     0.00997D0,  0.00424D0,  0.00029D0,  0.00000D0/
      DATA (FMRS(2,1,I,26),I=1,49)/
     &     0.02124D0,  0.02625D0,  0.03244D0,  0.03672D0,  0.04010D0,
     &     0.04294D0,  0.05315D0,  0.06595D0,  0.07499D0,  0.08227D0,
     &     0.08860D0,  0.11218D0,  0.14413D0,  0.16809D0,  0.18813D0,
     &     0.20564D0,  0.23571D0,  0.27281D0,  0.32152D0,  0.35948D0,
     &     0.41398D0,  0.44847D0,  0.46857D0,  0.47858D0,  0.47599D0,
     &     0.46404D0,  0.44519D0,  0.42139D0,  0.39420D0,  0.36490D0,
     &     0.33431D0,  0.30337D0,  0.27282D0,  0.24304D0,  0.21455D0,
     &     0.18765D0,  0.16244D0,  0.13911D0,  0.11808D0,  0.09890D0,
     &     0.08174D0,  0.06681D0,  0.05361D0,  0.03286D0,  0.01847D0,
     &     0.00924D0,  0.00390D0,  0.00026D0,  0.00000D0/
      DATA (FMRS(2,1,I,27),I=1,49)/
     &     0.02145D0,  0.02652D0,  0.03279D0,  0.03713D0,  0.04055D0,
     &     0.04343D0,  0.05378D0,  0.06677D0,  0.07594D0,  0.08333D0,
     &     0.08975D0,  0.11368D0,  0.14607D0,  0.17031D0,  0.19054D0,
     &     0.20819D0,  0.23841D0,  0.27555D0,  0.32402D0,  0.36153D0,
     &     0.41478D0,  0.44786D0,  0.46655D0,  0.47490D0,  0.47088D0,
     &     0.45773D0,  0.43795D0,  0.41346D0,  0.38583D0,  0.35628D0,
     &     0.32564D0,  0.29483D0,  0.26454D0,  0.23512D0,  0.20709D0,
     &     0.18074D0,  0.15610D0,  0.13337D0,  0.11295D0,  0.09439D0,
     &     0.07783D0,  0.06346D0,  0.05079D0,  0.03096D0,  0.01730D0,
     &     0.00860D0,  0.00360D0,  0.00023D0,  0.00000D0/
      DATA (FMRS(2,1,I,28),I=1,49)/
     &     0.02164D0,  0.02677D0,  0.03312D0,  0.03751D0,  0.04098D0,
     &     0.04390D0,  0.05439D0,  0.06755D0,  0.07684D0,  0.08433D0,
     &     0.09084D0,  0.11510D0,  0.14789D0,  0.17239D0,  0.19279D0,
     &     0.21056D0,  0.24091D0,  0.27806D0,  0.32630D0,  0.36334D0,
     &     0.41540D0,  0.44716D0,  0.46451D0,  0.47135D0,  0.46602D0,
     &     0.45177D0,  0.43117D0,  0.40606D0,  0.37805D0,  0.34829D0,
     &     0.31763D0,  0.28699D0,  0.25693D0,  0.22788D0,  0.20031D0,
     &     0.17447D0,  0.15036D0,  0.12818D0,  0.10834D0,  0.09032D0,
     &     0.07432D0,  0.06046D0,  0.04827D0,  0.02929D0,  0.01628D0,
     &     0.00804D0,  0.00334D0,  0.00021D0,  0.00000D0/
      DATA (FMRS(2,1,I,29),I=1,49)/
     &     0.02184D0,  0.02703D0,  0.03346D0,  0.03790D0,  0.04142D0,
     &     0.04437D0,  0.05500D0,  0.06833D0,  0.07775D0,  0.08534D0,
     &     0.09195D0,  0.11653D0,  0.14972D0,  0.17447D0,  0.19503D0,
     &     0.21292D0,  0.24339D0,  0.28054D0,  0.32851D0,  0.36507D0,
     &     0.41592D0,  0.44635D0,  0.46240D0,  0.46773D0,  0.46111D0,
     &     0.44581D0,  0.42442D0,  0.39875D0,  0.37037D0,  0.34044D0,
     &     0.30980D0,  0.27932D0,  0.24952D0,  0.22085D0,  0.19375D0,
     &     0.16840D0,  0.14482D0,  0.12320D0,  0.10392D0,  0.08643D0,
     &     0.07097D0,  0.05759D0,  0.04588D0,  0.02770D0,  0.01531D0,
     &     0.00752D0,  0.00311D0,  0.00019D0,  0.00000D0/
      DATA (FMRS(2,1,I,30),I=1,49)/
     &     0.02204D0,  0.02729D0,  0.03379D0,  0.03829D0,  0.04185D0,
     &     0.04484D0,  0.05560D0,  0.06911D0,  0.07865D0,  0.08634D0,
     &     0.09303D0,  0.11793D0,  0.15151D0,  0.17649D0,  0.19722D0,
     &     0.21521D0,  0.24577D0,  0.28291D0,  0.33057D0,  0.36667D0,
     &     0.41631D0,  0.44543D0,  0.46021D0,  0.46408D0,  0.45622D0,
     &     0.43995D0,  0.41780D0,  0.39163D0,  0.36293D0,  0.33287D0,
     &     0.30229D0,  0.27195D0,  0.24246D0,  0.21416D0,  0.18750D0,
     &     0.16265D0,  0.13957D0,  0.11850D0,  0.09976D0,  0.08278D0,
     &     0.06783D0,  0.05492D0,  0.04366D0,  0.02623D0,  0.01442D0,
     &     0.00705D0,  0.00289D0,  0.00017D0,  0.00000D0/
      DATA (FMRS(2,1,I,31),I=1,49)/
     &     0.02222D0,  0.02753D0,  0.03410D0,  0.03866D0,  0.04226D0,
     &     0.04528D0,  0.05617D0,  0.06985D0,  0.07951D0,  0.08729D0,
     &     0.09407D0,  0.11927D0,  0.15320D0,  0.17841D0,  0.19928D0,
     &     0.21737D0,  0.24802D0,  0.28513D0,  0.33249D0,  0.36812D0,
     &     0.41660D0,  0.44449D0,  0.45808D0,  0.46059D0,  0.45160D0,
     &     0.43442D0,  0.41159D0,  0.38497D0,  0.35599D0,  0.32584D0,
     &     0.29532D0,  0.26514D0,  0.23594D0,  0.20800D0,  0.18176D0,
     &     0.15738D0,  0.13478D0,  0.11421D0,  0.09597D0,  0.07947D0,
     &     0.06498D0,  0.05251D0,  0.04166D0,  0.02491D0,  0.01363D0,
     &     0.00662D0,  0.00270D0,  0.00016D0,  0.00000D0/
      DATA (FMRS(2,1,I,32),I=1,49)/
     &     0.02240D0,  0.02776D0,  0.03441D0,  0.03901D0,  0.04265D0,
     &     0.04571D0,  0.05672D0,  0.07055D0,  0.08032D0,  0.08819D0,
     &     0.09505D0,  0.12053D0,  0.15480D0,  0.18021D0,  0.20120D0,
     &     0.21937D0,  0.25009D0,  0.28716D0,  0.33421D0,  0.36938D0,
     &     0.41675D0,  0.44346D0,  0.45593D0,  0.45721D0,  0.44717D0,
     &     0.42917D0,  0.40572D0,  0.37869D0,  0.34947D0,  0.31928D0,
     &     0.28882D0,  0.25885D0,  0.22992D0,  0.20233D0,  0.17646D0,
     &     0.15252D0,  0.13038D0,  0.11028D0,  0.09251D0,  0.07647D0,
     &     0.06240D0,  0.05033D0,  0.03984D0,  0.02372D0,  0.01293D0,
     &     0.00625D0,  0.00253D0,  0.00015D0,  0.00000D0/
      DATA (FMRS(2,1,I,33),I=1,49)/
     &     0.02258D0,  0.02800D0,  0.03471D0,  0.03936D0,  0.04304D0,
     &     0.04613D0,  0.05727D0,  0.07126D0,  0.08114D0,  0.08911D0,
     &     0.09604D0,  0.12181D0,  0.15642D0,  0.18202D0,  0.20315D0,
     &     0.22140D0,  0.25219D0,  0.28920D0,  0.33594D0,  0.37065D0,
     &     0.41690D0,  0.44243D0,  0.45378D0,  0.45384D0,  0.44278D0,
     &     0.42397D0,  0.39993D0,  0.37250D0,  0.34307D0,  0.31283D0,
     &     0.28245D0,  0.25269D0,  0.22404D0,  0.19681D0,  0.17131D0,
     &     0.14780D0,  0.12613D0,  0.10648D0,  0.08918D0,  0.07357D0,
     &     0.05991D0,  0.04824D0,  0.03811D0,  0.02259D0,  0.01226D0,
     &     0.00589D0,  0.00237D0,  0.00014D0,  0.00000D0/
      DATA (FMRS(2,1,I,34),I=1,49)/
     &     0.02276D0,  0.02823D0,  0.03502D0,  0.03972D0,  0.04344D0,
     &     0.04656D0,  0.05782D0,  0.07197D0,  0.08196D0,  0.09001D0,
     &     0.09702D0,  0.12306D0,  0.15799D0,  0.18378D0,  0.20502D0,
     &     0.22334D0,  0.25418D0,  0.29111D0,  0.33751D0,  0.37174D0,
     &     0.41686D0,  0.44123D0,  0.45149D0,  0.45035D0,  0.43832D0,
     &     0.41874D0,  0.39416D0,  0.36638D0,  0.33679D0,  0.30651D0,
     &     0.27625D0,  0.24670D0,  0.21831D0,  0.19144D0,  0.16636D0,
     &     0.14329D0,  0.12204D0,  0.10286D0,  0.08597D0,  0.07080D0,
     &     0.05755D0,  0.04624D0,  0.03646D0,  0.02153D0,  0.01162D0,
     &     0.00556D0,  0.00222D0,  0.00012D0,  0.00000D0/
      DATA (FMRS(2,1,I,35),I=1,49)/
     &     0.02294D0,  0.02846D0,  0.03531D0,  0.04006D0,  0.04381D0,
     &     0.04697D0,  0.05834D0,  0.07264D0,  0.08274D0,  0.09087D0,
     &     0.09796D0,  0.12426D0,  0.15949D0,  0.18547D0,  0.20682D0,
     &     0.22520D0,  0.25608D0,  0.29293D0,  0.33900D0,  0.37277D0,
     &     0.41683D0,  0.44010D0,  0.44933D0,  0.44706D0,  0.43413D0,
     &     0.41383D0,  0.38877D0,  0.36068D0,  0.33093D0,  0.30063D0,
     &     0.27049D0,  0.24114D0,  0.21302D0,  0.18649D0,  0.16180D0,
     &     0.13914D0,  0.11828D0,  0.09955D0,  0.08303D0,  0.06826D0,
     &     0.05540D0,  0.04443D0,  0.03497D0,  0.02057D0,  0.01106D0,
     &     0.00526D0,  0.00209D0,  0.00012D0,  0.00000D0/
      DATA (FMRS(2,1,I,36),I=1,49)/
     &     0.02310D0,  0.02867D0,  0.03558D0,  0.04038D0,  0.04417D0,
     &     0.04736D0,  0.05885D0,  0.07328D0,  0.08348D0,  0.09170D0,
     &     0.09885D0,  0.12540D0,  0.16092D0,  0.18705D0,  0.20850D0,
     &     0.22693D0,  0.25784D0,  0.29461D0,  0.34036D0,  0.37368D0,
     &     0.41672D0,  0.43895D0,  0.44722D0,  0.44390D0,  0.43013D0,
     &     0.40920D0,  0.38369D0,  0.35531D0,  0.32545D0,  0.29515D0,
     &     0.26511D0,  0.23598D0,  0.20812D0,  0.18191D0,  0.15758D0,
     &     0.13530D0,  0.11483D0,  0.09649D0,  0.08034D0,  0.06595D0,
     &     0.05344D0,  0.04278D0,  0.03361D0,  0.01970D0,  0.01054D0,
     &     0.00499D0,  0.00197D0,  0.00011D0,  0.00000D0/
      DATA (FMRS(2,1,I,37),I=1,49)/
     &     0.02327D0,  0.02889D0,  0.03587D0,  0.04071D0,  0.04453D0,
     &     0.04775D0,  0.05935D0,  0.07393D0,  0.08423D0,  0.09253D0,
     &     0.09975D0,  0.12655D0,  0.16235D0,  0.18864D0,  0.21018D0,
     &     0.22866D0,  0.25959D0,  0.29626D0,  0.34166D0,  0.37452D0,
     &     0.41652D0,  0.43771D0,  0.44502D0,  0.44067D0,  0.42606D0,
     &     0.40453D0,  0.37859D0,  0.34994D0,  0.31996D0,  0.28968D0,
     &     0.25976D0,  0.23084D0,  0.20328D0,  0.17738D0,  0.15341D0,
     &     0.13150D0,  0.11145D0,  0.09348D0,  0.07773D0,  0.06369D0,
     &     0.05153D0,  0.04117D0,  0.03229D0,  0.01885D0,  0.01005D0,
     &     0.00474D0,  0.00186D0,  0.00010D0,  0.00000D0/
      DATA (FMRS(2,1,I,38),I=1,49)/
     &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
     &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
     &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
     &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
     &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
     &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
     &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
     &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
     &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
     &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0/
      DATA (FMRS(2,2,I, 1),I=1,49)/
     &     0.00683D0,  0.00832D0,  0.01013D0,  0.01138D0,  0.01237D0,
     &     0.01320D0,  0.01619D0,  0.02004D0,  0.02286D0,  0.02522D0,
     &     0.02744D0,  0.03623D0,  0.04952D0,  0.06032D0,  0.06982D0,
     &     0.07843D0,  0.09385D0,  0.11395D0,  0.14220D0,  0.16592D0,
     &     0.20382D0,  0.23228D0,  0.25344D0,  0.27158D0,  0.28216D0,
     &     0.28647D0,  0.28570D0,  0.28068D0,  0.27216D0,  0.26127D0,
     &     0.24773D0,  0.23281D0,  0.21663D0,  0.19968D0,  0.18252D0,
     &     0.16522D0,  0.14809D0,  0.13153D0,  0.11576D0,  0.10050D0,
     &     0.08631D0,  0.07335D0,  0.06127D0,  0.04098D0,  0.02531D0,
     &     0.01409D0,  0.00672D0,  0.00064D0,  0.00000D0/
      DATA (FMRS(2,2,I, 2),I=1,49)/
     &     0.00687D0,  0.00838D0,  0.01023D0,  0.01151D0,  0.01252D0,
     &     0.01336D0,  0.01643D0,  0.02037D0,  0.02327D0,  0.02569D0,
     &     0.02797D0,  0.03698D0,  0.05059D0,  0.06162D0,  0.07129D0,
     &     0.08004D0,  0.09567D0,  0.11595D0,  0.14429D0,  0.16793D0,
     &     0.20539D0,  0.23318D0,  0.25356D0,  0.27069D0,  0.28025D0,
     &     0.28363D0,  0.28200D0,  0.27624D0,  0.26713D0,  0.25572D0,
     &     0.24185D0,  0.22669D0,  0.21040D0,  0.19345D0,  0.17637D0,
     &     0.15928D0,  0.14242D0,  0.12615D0,  0.11076D0,  0.09591D0,
     &     0.08215D0,  0.06963D0,  0.05800D0,  0.03856D0,  0.02367D0,
     &     0.01309D0,  0.00619D0,  0.00057D0,  0.00000D0/
      DATA (FMRS(2,2,I, 3),I=1,49)/
     &     0.00693D0,  0.00848D0,  0.01038D0,  0.01170D0,  0.01274D0,
     &     0.01362D0,  0.01679D0,  0.02088D0,  0.02389D0,  0.02641D0,
     &     0.02877D0,  0.03812D0,  0.05220D0,  0.06356D0,  0.07349D0,
     &     0.08244D0,  0.09836D0,  0.11888D0,  0.14732D0,  0.17082D0,
     &     0.20757D0,  0.23434D0,  0.25356D0,  0.26918D0,  0.27725D0,
     &     0.27927D0,  0.27642D0,  0.26960D0,  0.25969D0,  0.24758D0,
     &     0.23327D0,  0.21778D0,  0.20136D0,  0.18446D0,  0.16756D0,
     &     0.15079D0,  0.13434D0,  0.11852D0,  0.10371D0,  0.08946D0,
     &     0.07631D0,  0.06442D0,  0.05345D0,  0.03522D0,  0.02142D0,
     &     0.01172D0,  0.00548D0,  0.00049D0,  0.00000D0/
      DATA (FMRS(2,2,I, 4),I=1,49)/
     &     0.00697D0,  0.00855D0,  0.01050D0,  0.01184D0,  0.01291D0,
     &     0.01380D0,  0.01706D0,  0.02126D0,  0.02435D0,  0.02694D0,
     &     0.02937D0,  0.03897D0,  0.05339D0,  0.06499D0,  0.07510D0,
     &     0.08419D0,  0.10031D0,  0.12100D0,  0.14949D0,  0.17285D0,
     &     0.20905D0,  0.23506D0,  0.25342D0,  0.26794D0,  0.27493D0,
     &     0.27599D0,  0.27230D0,  0.26475D0,  0.25426D0,  0.24171D0,
     &     0.22712D0,  0.21140D0,  0.19495D0,  0.17811D0,  0.16138D0,
     &     0.14485D0,  0.12869D0,  0.11323D0,  0.09881D0,  0.08500D0,
     &     0.07230D0,  0.06086D0,  0.05034D0,  0.03297D0,  0.01992D0,
     &     0.01081D0,  0.00501D0,  0.00044D0,  0.00000D0/
      DATA (FMRS(2,2,I, 5),I=1,49)/
     &     0.00702D0,  0.00863D0,  0.01062D0,  0.01200D0,  0.01309D0,
     &     0.01401D0,  0.01735D0,  0.02167D0,  0.02485D0,  0.02751D0,
     &     0.03001D0,  0.03988D0,  0.05465D0,  0.06649D0,  0.07678D0,
     &     0.08602D0,  0.10233D0,  0.12317D0,  0.15168D0,  0.17488D0,
     &     0.21046D0,  0.23564D0,  0.25309D0,  0.26645D0,  0.27234D0,
     &     0.27243D0,  0.26786D0,  0.25959D0,  0.24854D0,  0.23557D0,
     &     0.22068D0,  0.20486D0,  0.18841D0,  0.17163D0,  0.15506D0,
     &     0.13880D0,  0.12296D0,  0.10788D0,  0.09387D0,  0.08052D0,
     &     0.06829D0,  0.05730D0,  0.04726D0,  0.03074D0,  0.01844D0,
     &     0.00993D0,  0.00456D0,  0.00039D0,  0.00000D0/
      DATA (FMRS(2,2,I, 6),I=1,49)/
     &     0.00706D0,  0.00870D0,  0.01073D0,  0.01213D0,  0.01325D0,
     &     0.01419D0,  0.01761D0,  0.02203D0,  0.02528D0,  0.02801D0,
     &     0.03057D0,  0.04067D0,  0.05575D0,  0.06780D0,  0.07825D0,
     &     0.08760D0,  0.10408D0,  0.12504D0,  0.15354D0,  0.17659D0,
     &     0.21162D0,  0.23607D0,  0.25274D0,  0.26511D0,  0.27006D0,
     &     0.26933D0,  0.26403D0,  0.25518D0,  0.24367D0,  0.23035D0,
     &     0.21525D0,  0.19935D0,  0.18289D0,  0.16620D0,  0.14980D0,
     &     0.13377D0,  0.11822D0,  0.10346D0,  0.08981D0,  0.07685D0,
     &     0.06502D0,  0.05441D0,  0.04475D0,  0.02894D0,  0.01725D0,
     &     0.00923D0,  0.00420D0,  0.00035D0,  0.00000D0/
      DATA (FMRS(2,2,I, 7),I=1,49)/
     &     0.00711D0,  0.00877D0,  0.01083D0,  0.01227D0,  0.01340D0,
     &     0.01436D0,  0.01785D0,  0.02237D0,  0.02570D0,  0.02850D0,
     &     0.03112D0,  0.04143D0,  0.05680D0,  0.06905D0,  0.07964D0,
     &     0.08911D0,  0.10573D0,  0.12679D0,  0.15527D0,  0.17816D0,
     &     0.21263D0,  0.23638D0,  0.25229D0,  0.26373D0,  0.26781D0,
     &     0.26630D0,  0.26033D0,  0.25095D0,  0.23903D0,  0.22536D0,
     &     0.21011D0,  0.19416D0,  0.17766D0,  0.16111D0,  0.14488D0,
     &     0.12910D0,  0.11382D0,  0.09936D0,  0.08606D0,  0.07347D0,
     &     0.06201D0,  0.05178D0,  0.04247D0,  0.02732D0,  0.01619D0,
     &     0.00860D0,  0.00389D0,  0.00031D0,  0.00000D0/
      DATA (FMRS(2,2,I, 8),I=1,49)/
     &     0.00716D0,  0.00885D0,  0.01095D0,  0.01241D0,  0.01357D0,
     &     0.01455D0,  0.01812D0,  0.02275D0,  0.02616D0,  0.02902D0,
     &     0.03170D0,  0.04225D0,  0.05792D0,  0.07038D0,  0.08112D0,
     &     0.09070D0,  0.10747D0,  0.12863D0,  0.15707D0,  0.17976D0,
     &     0.21362D0,  0.23661D0,  0.25172D0,  0.26218D0,  0.26535D0,
     &     0.26303D0,  0.25640D0,  0.24647D0,  0.23413D0,  0.22018D0,
     &     0.20477D0,  0.18875D0,  0.17228D0,  0.15585D0,  0.13983D0,
     &     0.12430D0,  0.10932D0,  0.09519D0,  0.08225D0,  0.07005D0,
     &     0.05898D0,  0.04912D0,  0.04018D0,  0.02570D0,  0.01514D0,
     &     0.00799D0,  0.00358D0,  0.00028D0,  0.00000D0/
      DATA (FMRS(2,2,I, 9),I=1,49)/
     &     0.00720D0,  0.00891D0,  0.01105D0,  0.01254D0,  0.01372D0,
     &     0.01472D0,  0.01836D0,  0.02308D0,  0.02656D0,  0.02948D0,
     &     0.03221D0,  0.04297D0,  0.05891D0,  0.07154D0,  0.08241D0,
     &     0.09208D0,  0.10897D0,  0.13020D0,  0.15860D0,  0.18111D0,
     &     0.21443D0,  0.23674D0,  0.25116D0,  0.26078D0,  0.26316D0,
     &     0.26017D0,  0.25299D0,  0.24260D0,  0.22991D0,  0.21577D0,
     &     0.20023D0,  0.18414D0,  0.16776D0,  0.15141D0,  0.13557D0,
     &     0.12027D0,  0.10555D0,  0.09171D0,  0.07908D0,  0.06721D0,
     &     0.05646D0,  0.04691D0,  0.03829D0,  0.02437D0,  0.01428D0,
     &     0.00749D0,  0.00333D0,  0.00026D0,  0.00000D0/
      DATA (FMRS(2,2,I,10),I=1,49)/
     &     0.00724D0,  0.00898D0,  0.01115D0,  0.01266D0,  0.01386D0,
     &     0.01488D0,  0.01859D0,  0.02340D0,  0.02695D0,  0.02993D0,
     &     0.03271D0,  0.04366D0,  0.05985D0,  0.07265D0,  0.08364D0,
     &     0.09340D0,  0.11040D0,  0.13168D0,  0.16002D0,  0.18235D0,
     &     0.21512D0,  0.23679D0,  0.25054D0,  0.25935D0,  0.26099D0,
     &     0.25738D0,  0.24967D0,  0.23885D0,  0.22588D0,  0.21153D0,
     &     0.19588D0,  0.17977D0,  0.16345D0,  0.14723D0,  0.13156D0,
     &     0.11648D0,  0.10202D0,  0.08846D0,  0.07613D0,  0.06457D0,
     &     0.05413D0,  0.04488D0,  0.03655D0,  0.02315D0,  0.01349D0,
     &     0.00703D0,  0.00311D0,  0.00024D0,  0.00000D0/
      DATA (FMRS(2,2,I,11),I=1,49)/
     &     0.00727D0,  0.00904D0,  0.01123D0,  0.01276D0,  0.01398D0,
     &     0.01501D0,  0.01877D0,  0.02366D0,  0.02727D0,  0.03029D0,
     &     0.03311D0,  0.04422D0,  0.06061D0,  0.07353D0,  0.08461D0,
     &     0.09444D0,  0.11152D0,  0.13285D0,  0.16112D0,  0.18330D0,
     &     0.21564D0,  0.23680D0,  0.25001D0,  0.25818D0,  0.25925D0,
     &     0.25517D0,  0.24705D0,  0.23591D0,  0.22272D0,  0.20821D0,
     &     0.19248D0,  0.17638D0,  0.16011D0,  0.14399D0,  0.12847D0,
     &     0.11356D0,  0.09932D0,  0.08597D0,  0.07388D0,  0.06256D0,
     &     0.05235D0,  0.04334D0,  0.03522D0,  0.02223D0,  0.01290D0,
     &     0.00670D0,  0.00295D0,  0.00022D0,  0.00000D0/
      DATA (FMRS(2,2,I,12),I=1,49)/
     &     0.00735D0,  0.00915D0,  0.01141D0,  0.01298D0,  0.01423D0,
     &     0.01529D0,  0.01917D0,  0.02422D0,  0.02794D0,  0.03106D0,
     &     0.03397D0,  0.04541D0,  0.06221D0,  0.07541D0,  0.08668D0,
     &     0.09664D0,  0.11388D0,  0.13528D0,  0.16340D0,  0.18523D0,
     &     0.21662D0,  0.23667D0,  0.24876D0,  0.25560D0,  0.25550D0,
     &     0.25041D0,  0.24145D0,  0.22968D0,  0.21606D0,  0.20125D0,
     &     0.18540D0,  0.16932D0,  0.15319D0,  0.13731D0,  0.12210D0,
     &     0.10759D0,  0.09378D0,  0.08090D0,  0.06929D0,  0.05847D0,
     &     0.04874D0,  0.04022D0,  0.03256D0,  0.02039D0,  0.01173D0,
     &     0.00603D0,  0.00263D0,  0.00019D0,  0.00000D0/
      DATA (FMRS(2,2,I,13),I=1,49)/
     &     0.00742D0,  0.00926D0,  0.01156D0,  0.01317D0,  0.01446D0,
     &     0.01554D0,  0.01952D0,  0.02471D0,  0.02853D0,  0.03173D0,
     &     0.03472D0,  0.04644D0,  0.06360D0,  0.07703D0,  0.08845D0,
     &     0.09852D0,  0.11589D0,  0.13732D0,  0.16529D0,  0.18680D0,
     &     0.21735D0,  0.23643D0,  0.24757D0,  0.25329D0,  0.25220D0,
     &     0.24629D0,  0.23665D0,  0.22439D0,  0.21043D0,  0.19540D0,
     &     0.17949D0,  0.16343D0,  0.14746D0,  0.13180D0,  0.11686D0,
     &     0.10269D0,  0.08926D0,  0.07677D0,  0.06556D0,  0.05517D0,
     &     0.04584D0,  0.03772D0,  0.03044D0,  0.01893D0,  0.01082D0,
     &     0.00551D0,  0.00238D0,  0.00017D0,  0.00000D0/
      DATA (FMRS(2,2,I,14),I=1,49)/
     &     0.00750D0,  0.00938D0,  0.01173D0,  0.01339D0,  0.01471D0,
     &     0.01583D0,  0.01992D0,  0.02526D0,  0.02920D0,  0.03250D0,
     &     0.03557D0,  0.04761D0,  0.06516D0,  0.07882D0,  0.09041D0,
     &     0.10060D0,  0.11809D0,  0.13955D0,  0.16731D0,  0.18846D0,
     &     0.21802D0,  0.23605D0,  0.24613D0,  0.25062D0,  0.24846D0,
     &     0.24169D0,  0.23135D0,  0.21858D0,  0.20428D0,  0.18902D0,
     &     0.17309D0,  0.15708D0,  0.14130D0,  0.12590D0,  0.11127D0,
     &     0.09745D0,  0.08445D0,  0.07239D0,  0.06165D0,  0.05170D0,
     &     0.04281D0,  0.03511D0,  0.02824D0,  0.01743D0,  0.00988D0,
     &     0.00499D0,  0.00213D0,  0.00015D0,  0.00000D0/
      DATA (FMRS(2,2,I,15),I=1,49)/
     &     0.00758D0,  0.00950D0,  0.01192D0,  0.01362D0,  0.01498D0,
     &     0.01613D0,  0.02034D0,  0.02584D0,  0.02990D0,  0.03330D0,
     &     0.03646D0,  0.04882D0,  0.06676D0,  0.08067D0,  0.09242D0,
     &     0.10271D0,  0.12031D0,  0.14177D0,  0.16927D0,  0.19002D0,
     &     0.21855D0,  0.23546D0,  0.24445D0,  0.24771D0,  0.24448D0,
     &     0.23683D0,  0.22584D0,  0.21262D0,  0.19799D0,  0.18255D0,
     &     0.16661D0,  0.15073D0,  0.13511D0,  0.12003D0,  0.10571D0,
     &     0.09233D0,  0.07973D0,  0.06812D0,  0.05781D0,  0.04834D0,
     &     0.03990D0,  0.03259D0,  0.02612D0,  0.01599D0,  0.00899D0,
     &     0.00450D0,  0.00190D0,  0.00013D0,  0.00000D0/
      DATA (FMRS(2,2,I,16),I=1,49)/
     &     0.00766D0,  0.00962D0,  0.01210D0,  0.01384D0,  0.01522D0,
     &     0.01640D0,  0.02073D0,  0.02638D0,  0.03055D0,  0.03403D0,
     &     0.03728D0,  0.04992D0,  0.06822D0,  0.08234D0,  0.09422D0,
     &     0.10460D0,  0.12228D0,  0.14371D0,  0.17097D0,  0.19133D0,
     &     0.21891D0,  0.23481D0,  0.24283D0,  0.24499D0,  0.24085D0,
     &     0.23246D0,  0.22090D0,  0.20727D0,  0.19242D0,  0.17687D0,
     &     0.16094D0,  0.14517D0,  0.12974D0,  0.11493D0,  0.10094D0,
     &     0.08792D0,  0.07568D0,  0.06448D0,  0.05456D0,  0.04548D0,
     &     0.03743D0,  0.03047D0,  0.02435D0,  0.01480D0,  0.00826D0,
     &     0.00410D0,  0.00171D0,  0.00011D0,  0.00000D0/
      DATA (FMRS(2,2,I,17),I=1,49)/
     &     0.00775D0,  0.00975D0,  0.01228D0,  0.01406D0,  0.01548D0,
     &     0.01669D0,  0.02112D0,  0.02692D0,  0.03120D0,  0.03478D0,
     &     0.03810D0,  0.05104D0,  0.06968D0,  0.08400D0,  0.09602D0,
     &     0.10648D0,  0.12423D0,  0.14563D0,  0.17261D0,  0.19256D0,
     &     0.21918D0,  0.23405D0,  0.24112D0,  0.24221D0,  0.23719D0,
     &     0.22809D0,  0.21600D0,  0.20198D0,  0.18694D0,  0.17130D0,
     &     0.15541D0,  0.13976D0,  0.12455D0,  0.11000D0,  0.09636D0,
     &     0.08368D0,  0.07182D0,  0.06101D0,  0.05149D0,  0.04278D0,
     &     0.03510D0,  0.02849D0,  0.02269D0,  0.01370D0,  0.00759D0,
     &     0.00374D0,  0.00155D0,  0.00010D0,  0.00000D0/
      DATA (FMRS(2,2,I,18),I=1,49)/
     &     0.00782D0,  0.00985D0,  0.01243D0,  0.01424D0,  0.01569D0,
     &     0.01692D0,  0.02146D0,  0.02738D0,  0.03175D0,  0.03540D0,
     &     0.03879D0,  0.05197D0,  0.07089D0,  0.08537D0,  0.09749D0,
     &     0.10801D0,  0.12581D0,  0.14716D0,  0.17390D0,  0.19349D0,
     &     0.21930D0,  0.23333D0,  0.23963D0,  0.23986D0,  0.23413D0,
     &     0.22447D0,  0.21197D0,  0.19769D0,  0.18248D0,  0.16678D0,
     &     0.15094D0,  0.13543D0,  0.12040D0,  0.10608D0,  0.09270D0,
     &     0.08031D0,  0.06878D0,  0.05828D0,  0.04908D0,  0.04068D0,
     &     0.03329D0,  0.02694D0,  0.02140D0,  0.01285D0,  0.00708D0,
     &     0.00346D0,  0.00142D0,  0.00009D0,  0.00000D0/
      DATA (FMRS(2,2,I,19),I=1,49)/
     &     0.00791D0,  0.00998D0,  0.01261D0,  0.01447D0,  0.01595D0,
     &     0.01722D0,  0.02186D0,  0.02794D0,  0.03242D0,  0.03616D0,
     &     0.03963D0,  0.05310D0,  0.07234D0,  0.08702D0,  0.09924D0,
     &     0.10983D0,  0.12767D0,  0.14895D0,  0.17537D0,  0.19453D0,
     &     0.21933D0,  0.23238D0,  0.23773D0,  0.23696D0,  0.23039D0,
     &     0.22010D0,  0.20715D0,  0.19257D0,  0.17716D0,  0.16147D0,
     &     0.14570D0,  0.13034D0,  0.11556D0,  0.10152D0,  0.08847D0,
     &     0.07643D0,  0.06526D0,  0.05515D0,  0.04631D0,  0.03827D0,
     &     0.03122D0,  0.02519D0,  0.01995D0,  0.01190D0,  0.00650D0,
     &     0.00315D0,  0.00128D0,  0.00008D0,  0.00000D0/
      DATA (FMRS(2,2,I,20),I=1,49)/
     &     0.00799D0,  0.01010D0,  0.01278D0,  0.01467D0,  0.01619D0,
     &     0.01748D0,  0.02223D0,  0.02844D0,  0.03302D0,  0.03684D0,
     &     0.04038D0,  0.05409D0,  0.07362D0,  0.08846D0,  0.10078D0,
     &     0.11143D0,  0.12930D0,  0.15050D0,  0.17662D0,  0.19539D0,
     &     0.21931D0,  0.23148D0,  0.23602D0,  0.23438D0,  0.22712D0,
     &     0.21628D0,  0.20296D0,  0.18814D0,  0.17260D0,  0.15692D0,
     &     0.14124D0,  0.12600D0,  0.11146D0,  0.09768D0,  0.08490D0,
     &     0.07317D0,  0.06233D0,  0.05253D0,  0.04400D0,  0.03627D0,
     &     0.02950D0,  0.02375D0,  0.01875D0,  0.01112D0,  0.00604D0,
     &     0.00291D0,  0.00117D0,  0.00007D0,  0.00000D0/
      DATA (FMRS(2,2,I,21),I=1,49)/
     &     0.00806D0,  0.01021D0,  0.01293D0,  0.01486D0,  0.01641D0,
     &     0.01772D0,  0.02256D0,  0.02890D0,  0.03357D0,  0.03747D0,
     &     0.04106D0,  0.05501D0,  0.07479D0,  0.08976D0,  0.10217D0,
     &     0.11285D0,  0.13073D0,  0.15184D0,  0.17768D0,  0.19608D0,
     &     0.21918D0,  0.23055D0,  0.23436D0,  0.23195D0,  0.22407D0,
     &     0.21277D0,  0.19913D0,  0.18411D0,  0.16851D0,  0.15282D0,
     &     0.13724D0,  0.12215D0,  0.10780D0,  0.09426D0,  0.08175D0,
     &     0.07030D0,  0.05975D0,  0.05024D0,  0.04199D0,  0.03453D0,
     &     0.02802D0,  0.02251D0,  0.01772D0,  0.01045D0,  0.00564D0,
     &     0.00270D0,  0.00108D0,  0.00006D0,  0.00000D0/
      DATA (FMRS(2,2,I,22),I=1,49)/
     &     0.00816D0,  0.01035D0,  0.01313D0,  0.01511D0,  0.01669D0,
     &     0.01803D0,  0.02299D0,  0.02949D0,  0.03427D0,  0.03826D0,
     &     0.04194D0,  0.05616D0,  0.07626D0,  0.09141D0,  0.10390D0,
     &     0.11463D0,  0.13252D0,  0.15350D0,  0.17897D0,  0.19689D0,
     &     0.21895D0,  0.22932D0,  0.23223D0,  0.22887D0,  0.22024D0,
     &     0.20839D0,  0.19437D0,  0.17913D0,  0.16346D0,  0.14778D0,
     &     0.13233D0,  0.11744D0,  0.10335D0,  0.09011D0,  0.07794D0,
     &     0.06684D0,  0.05665D0,  0.04749D0,  0.03958D0,  0.03245D0,
     &     0.02625D0,  0.02103D0,  0.01650D0,  0.00967D0,  0.00518D0,
     &     0.00246D0,  0.00097D0,  0.00005D0,  0.00000D0/
      DATA (FMRS(2,2,I,23),I=1,49)/
     &     0.00826D0,  0.01049D0,  0.01333D0,  0.01534D0,  0.01695D0,
     &     0.01833D0,  0.02340D0,  0.03004D0,  0.03494D0,  0.03901D0,
     &     0.04276D0,  0.05725D0,  0.07764D0,  0.09293D0,  0.10551D0,
     &     0.11628D0,  0.13416D0,  0.15502D0,  0.18011D0,  0.19758D0,
     &     0.21867D0,  0.22812D0,  0.23018D0,  0.22598D0,  0.21667D0,
     &     0.20434D0,  0.19000D0,  0.17460D0,  0.15883D0,  0.14320D0,
     &     0.12787D0,  0.11321D0,  0.09934D0,  0.08640D0,  0.07454D0,
     &     0.06376D0,  0.05389D0,  0.04504D0,  0.03744D0,  0.03063D0,
     &     0.02471D0,  0.01973D0,  0.01544D0,  0.00899D0,  0.00479D0,
     &     0.00225D0,  0.00088D0,  0.00005D0,  0.00000D0/
      DATA (FMRS(2,2,I,24),I=1,49)/
     &     0.00835D0,  0.01062D0,  0.01351D0,  0.01556D0,  0.01721D0,
     &     0.01861D0,  0.02378D0,  0.03057D0,  0.03556D0,  0.03972D0,
     &     0.04354D0,  0.05827D0,  0.07891D0,  0.09434D0,  0.10698D0,
     &     0.11778D0,  0.13564D0,  0.15636D0,  0.18108D0,  0.19811D0,
     &     0.21829D0,  0.22687D0,  0.22819D0,  0.22319D0,  0.21330D0,
     &     0.20053D0,  0.18593D0,  0.17036D0,  0.15459D0,  0.13902D0,
     &     0.12383D0,  0.10936D0,  0.09573D0,  0.08306D0,  0.07149D0,
     &     0.06100D0,  0.05144D0,  0.04289D0,  0.03556D0,  0.02901D0,
     &     0.02335D0,  0.01859D0,  0.01451D0,  0.00840D0,  0.00444D0,
     &     0.00208D0,  0.00081D0,  0.00004D0,  0.00000D0/
      DATA (FMRS(2,2,I,25),I=1,49)/
     &     0.00844D0,  0.01075D0,  0.01369D0,  0.01578D0,  0.01746D0,
     &     0.01889D0,  0.02417D0,  0.03109D0,  0.03619D0,  0.04043D0,
     &     0.04431D0,  0.05929D0,  0.08018D0,  0.09573D0,  0.10844D0,
     &     0.11926D0,  0.13709D0,  0.15767D0,  0.18202D0,  0.19861D0,
     &     0.21788D0,  0.22561D0,  0.22620D0,  0.22044D0,  0.20998D0,
     &     0.19681D0,  0.18196D0,  0.16625D0,  0.15048D0,  0.13499D0,
     &     0.11994D0,  0.10567D0,  0.09228D0,  0.07987D0,  0.06858D0,
     &     0.05838D0,  0.04911D0,  0.04085D0,  0.03379D0,  0.02749D0,
     &     0.02207D0,  0.01753D0,  0.01364D0,  0.00785D0,  0.00413D0,
     &     0.00192D0,  0.00074D0,  0.00004D0,  0.00000D0/
      DATA (FMRS(2,2,I,26),I=1,49)/
     &     0.00853D0,  0.01088D0,  0.01388D0,  0.01600D0,  0.01772D0,
     &     0.01917D0,  0.02456D0,  0.03161D0,  0.03680D0,  0.04112D0,
     &     0.04508D0,  0.06028D0,  0.08140D0,  0.09707D0,  0.10983D0,
     &     0.12067D0,  0.13846D0,  0.15889D0,  0.18286D0,  0.19901D0,
     &     0.21739D0,  0.22430D0,  0.22419D0,  0.21773D0,  0.20672D0,
     &     0.19320D0,  0.17811D0,  0.16233D0,  0.14654D0,  0.13113D0,
     &     0.11622D0,  0.10216D0,  0.08901D0,  0.07686D0,  0.06584D0,
     &     0.05592D0,  0.04692D0,  0.03894D0,  0.03214D0,  0.02608D0,
     &     0.02089D0,  0.01655D0,  0.01285D0,  0.00735D0,  0.00384D0,
     &     0.00177D0,  0.00068D0,  0.00003D0,  0.00000D0/
      DATA (FMRS(2,2,I,27),I=1,49)/
     &     0.00862D0,  0.01100D0,  0.01405D0,  0.01622D0,  0.01796D0,
     &     0.01944D0,  0.02492D0,  0.03211D0,  0.03739D0,  0.04178D0,
     &     0.04580D0,  0.06121D0,  0.08256D0,  0.09833D0,  0.11114D0,
     &     0.12198D0,  0.13974D0,  0.16000D0,  0.18361D0,  0.19934D0,
     &     0.21688D0,  0.22303D0,  0.22227D0,  0.21516D0,  0.20368D0,
     &     0.18983D0,  0.17455D0,  0.15870D0,  0.14292D0,  0.12759D0,
     &     0.11282D0,  0.09895D0,  0.08604D0,  0.07413D0,  0.06336D0,
     &     0.05370D0,  0.04495D0,  0.03722D0,  0.03066D0,  0.02482D0,
     &     0.01983D0,  0.01568D0,  0.01214D0,  0.00691D0,  0.00359D0,
     &     0.00164D0,  0.00063D0,  0.00003D0,  0.00000D0/
      DATA (FMRS(2,2,I,28),I=1,49)/
     &     0.00871D0,  0.01113D0,  0.01422D0,  0.01642D0,  0.01819D0,
     &     0.01970D0,  0.02527D0,  0.03257D0,  0.03795D0,  0.04240D0,
     &     0.04648D0,  0.06209D0,  0.08364D0,  0.09950D0,  0.11235D0,
     &     0.12320D0,  0.14090D0,  0.16101D0,  0.18426D0,  0.19960D0,
     &     0.21635D0,  0.22178D0,  0.22043D0,  0.21273D0,  0.20082D0,
     &     0.18670D0,  0.17123D0,  0.15532D0,  0.13957D0,  0.12434D0,
     &     0.10972D0,  0.09602D0,  0.08332D0,  0.07164D0,  0.06111D0,
     &     0.05170D0,  0.04318D0,  0.03568D0,  0.02933D0,  0.02371D0,
     &     0.01889D0,  0.01491D0,  0.01151D0,  0.00652D0,  0.00337D0,
     &     0.00153D0,  0.00058D0,  0.00003D0,  0.00000D0/
      DATA (FMRS(2,2,I,29),I=1,49)/
     &     0.00880D0,  0.01125D0,  0.01439D0,  0.01662D0,  0.01842D0,
     &     0.01995D0,  0.02562D0,  0.03305D0,  0.03850D0,  0.04303D0,
     &     0.04716D0,  0.06297D0,  0.08471D0,  0.10067D0,  0.11354D0,
     &     0.12440D0,  0.14205D0,  0.16199D0,  0.18487D0,  0.19981D0,
     &     0.21577D0,  0.22050D0,  0.21856D0,  0.21030D0,  0.19797D0,
     &     0.18358D0,  0.16796D0,  0.15200D0,  0.13629D0,  0.12116D0,
     &     0.10670D0,  0.09318D0,  0.08069D0,  0.06924D0,  0.05894D0,
     &     0.04976D0,  0.04148D0,  0.03421D0,  0.02806D0,  0.02263D0,
     &     0.01799D0,  0.01417D0,  0.01091D0,  0.00615D0,  0.00316D0,
     &     0.00143D0,  0.00054D0,  0.00003D0,  0.00000D0/
      DATA (FMRS(2,2,I,30),I=1,49)/
     &     0.00889D0,  0.01137D0,  0.01456D0,  0.01683D0,  0.01865D0,
     &     0.02021D0,  0.02596D0,  0.03351D0,  0.03906D0,  0.04365D0,
     &     0.04784D0,  0.06384D0,  0.08576D0,  0.10180D0,  0.11470D0,
     &     0.12555D0,  0.14314D0,  0.16292D0,  0.18544D0,  0.19997D0,
     &     0.21516D0,  0.21921D0,  0.21670D0,  0.20790D0,  0.19518D0,
     &     0.18054D0,  0.16480D0,  0.14880D0,  0.13314D0,  0.11810D0,
     &     0.10380D0,  0.09048D0,  0.07819D0,  0.06696D0,  0.05688D0,
     &     0.04793D0,  0.03987D0,  0.03282D0,  0.02686D0,  0.02162D0,
     &     0.01715D0,  0.01347D0,  0.01036D0,  0.00581D0,  0.00297D0,
     &     0.00134D0,  0.00050D0,  0.00002D0,  0.00000D0/
      DATA (FMRS(2,2,I,31),I=1,49)/
     &     0.00897D0,  0.01149D0,  0.01472D0,  0.01702D0,  0.01887D0,
     &     0.02045D0,  0.02630D0,  0.03396D0,  0.03958D0,  0.04424D0,
     &     0.04848D0,  0.06466D0,  0.08676D0,  0.10286D0,  0.11579D0,
     &     0.12663D0,  0.14416D0,  0.16377D0,  0.18594D0,  0.20009D0,
     &     0.21455D0,  0.21797D0,  0.21493D0,  0.20563D0,  0.19256D0,
     &     0.17769D0,  0.16185D0,  0.14582D0,  0.13021D0,  0.11528D0,
     &     0.10112D0,  0.08798D0,  0.07588D0,  0.06486D0,  0.05500D0,
     &     0.04626D0,  0.03841D0,  0.03155D0,  0.02578D0,  0.02071D0,
     &     0.01640D0,  0.01285D0,  0.00986D0,  0.00551D0,  0.00280D0,
     &     0.00125D0,  0.00046D0,  0.00002D0,  0.00000D0/
      DATA (FMRS(2,2,I,32),I=1,49)/
     &     0.00905D0,  0.01160D0,  0.01487D0,  0.01721D0,  0.01909D0,
     &     0.02069D0,  0.02661D0,  0.03438D0,  0.04008D0,  0.04480D0,
     &     0.04909D0,  0.06543D0,  0.08768D0,  0.10385D0,  0.11679D0,
     &     0.12763D0,  0.14509D0,  0.16454D0,  0.18637D0,  0.20016D0,
     &     0.21393D0,  0.21676D0,  0.21323D0,  0.20346D0,  0.19008D0,
     &     0.17502D0,  0.15909D0,  0.14304D0,  0.12749D0,  0.11266D0,
     &     0.09863D0,  0.08567D0,  0.07376D0,  0.06293D0,  0.05328D0,
     &     0.04474D0,  0.03708D0,  0.03039D0,  0.02479D0,  0.01988D0,
     &     0.01572D0,  0.01229D0,  0.00941D0,  0.00524D0,  0.00265D0,
     &     0.00118D0,  0.00043D0,  0.00002D0,  0.00000D0/
      DATA (FMRS(2,2,I,33),I=1,49)/
     &     0.00914D0,  0.01172D0,  0.01503D0,  0.01740D0,  0.01930D0,
     &     0.02092D0,  0.02693D0,  0.03481D0,  0.04058D0,  0.04536D0,
     &     0.04970D0,  0.06621D0,  0.08862D0,  0.10485D0,  0.11781D0,
     &     0.12863D0,  0.14602D0,  0.16531D0,  0.18679D0,  0.20022D0,
     &     0.21330D0,  0.21555D0,  0.21154D0,  0.20131D0,  0.18763D0,
     &     0.17238D0,  0.15637D0,  0.14031D0,  0.12482D0,  0.11010D0,
     &     0.09620D0,  0.08342D0,  0.07168D0,  0.06106D0,  0.05161D0,
     &     0.04326D0,  0.03580D0,  0.02928D0,  0.02384D0,  0.01908D0,
     &     0.01506D0,  0.01176D0,  0.00899D0,  0.00498D0,  0.00251D0,
     &     0.00111D0,  0.00041D0,  0.00002D0,  0.00000D0/
      DATA (FMRS(2,2,I,34),I=1,49)/
     &     0.00922D0,  0.01183D0,  0.01519D0,  0.01758D0,  0.01951D0,
     &     0.02116D0,  0.02725D0,  0.03523D0,  0.04108D0,  0.04592D0,
     &     0.05030D0,  0.06698D0,  0.08953D0,  0.10581D0,  0.11878D0,
     &     0.12959D0,  0.14690D0,  0.16601D0,  0.18715D0,  0.20021D0,
     &     0.21262D0,  0.21429D0,  0.20982D0,  0.19916D0,  0.18519D0,
     &     0.16977D0,  0.15369D0,  0.13763D0,  0.12221D0,  0.10760D0,
     &     0.09385D0,  0.08123D0,  0.06969D0,  0.05926D0,  0.05001D0,
     &     0.04183D0,  0.03456D0,  0.02822D0,  0.02295D0,  0.01833D0,
     &     0.01444D0,  0.01126D0,  0.00858D0,  0.00473D0,  0.00238D0,
     &     0.00105D0,  0.00038D0,  0.00002D0,  0.00000D0/
      DATA (FMRS(2,2,I,35),I=1,49)/
     &     0.00930D0,  0.01194D0,  0.01534D0,  0.01777D0,  0.01972D0,
     &     0.02138D0,  0.02755D0,  0.03564D0,  0.04156D0,  0.04645D0,
     &     0.05088D0,  0.06771D0,  0.09039D0,  0.10673D0,  0.11970D0,
     &     0.13050D0,  0.14773D0,  0.16667D0,  0.18748D0,  0.20020D0,
     &     0.21197D0,  0.21309D0,  0.20820D0,  0.19714D0,  0.18290D0,
     &     0.16734D0,  0.15119D0,  0.13514D0,  0.11978D0,  0.10528D0,
     &     0.09167D0,  0.07922D0,  0.06786D0,  0.05760D0,  0.04853D0,
     &     0.04052D0,  0.03343D0,  0.02726D0,  0.02213D0,  0.01765D0,
     &     0.01387D0,  0.01080D0,  0.00822D0,  0.00451D0,  0.00226D0,
     &     0.00099D0,  0.00036D0,  0.00002D0,  0.00000D0/
      DATA (FMRS(2,2,I,36),I=1,49)/
     &     0.00938D0,  0.01205D0,  0.01549D0,  0.01794D0,  0.01992D0,
     &     0.02160D0,  0.02784D0,  0.03602D0,  0.04201D0,  0.04696D0,
     &     0.05143D0,  0.06840D0,  0.09121D0,  0.10758D0,  0.12056D0,
     &     0.13134D0,  0.14849D0,  0.16728D0,  0.18776D0,  0.20016D0,
     &     0.21132D0,  0.21194D0,  0.20664D0,  0.19522D0,  0.18074D0,
     &     0.16504D0,  0.14884D0,  0.13281D0,  0.11752D0,  0.10313D0,
     &     0.08965D0,  0.07735D0,  0.06616D0,  0.05608D0,  0.04717D0,
     &     0.03933D0,  0.03239D0,  0.02637D0,  0.02137D0,  0.01702D0,
     &     0.01336D0,  0.01038D0,  0.00788D0,  0.00431D0,  0.00215D0,
     &     0.00094D0,  0.00034D0,  0.00001D0,  0.00000D0/
      DATA (FMRS(2,2,I,37),I=1,49)/
     &     0.00946D0,  0.01216D0,  0.01563D0,  0.01812D0,  0.02011D0,
     &     0.02182D0,  0.02814D0,  0.03641D0,  0.04247D0,  0.04747D0,
     &     0.05199D0,  0.06909D0,  0.09202D0,  0.10844D0,  0.12142D0,
     &     0.13217D0,  0.14925D0,  0.16786D0,  0.18802D0,  0.20008D0,
     &     0.21063D0,  0.21075D0,  0.20506D0,  0.19327D0,  0.17856D0,
     &     0.16274D0,  0.14648D0,  0.13048D0,  0.11526D0,  0.10099D0,
     &     0.08766D0,  0.07551D0,  0.06448D0,  0.05458D0,  0.04583D0,
     &     0.03816D0,  0.03137D0,  0.02550D0,  0.02064D0,  0.01641D0,
     &     0.01285D0,  0.00997D0,  0.00756D0,  0.00412D0,  0.00204D0,
     &     0.00089D0,  0.00032D0,  0.00001D0,  0.00000D0/
      DATA (FMRS(2,2,I,38),I=1,49)/
     &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
     &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
     &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
     &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
     &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
     &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
     &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
     &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
     &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
     &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0/
      DATA (FMRS(2,3,I, 1),I=1,49)/
     &     2.49594D0,  2.59678D0,  2.70121D0,  2.76381D0,  2.80882D0,
     &     2.84400D0,  2.95410D0,  3.06293D0,  3.12376D0,  3.16433D0,
     &     3.19612D0,  3.26381D0,  3.24185D0,  3.15396D0,  3.04339D0,
     &     2.92461D0,  2.68378D0,  2.34265D0,  1.85814D0,  1.47710D0,
     &     0.96403D0,  0.68739D0,  0.56164D0,  0.53053D0,  0.57114D0,
     &     0.63752D0,  0.70266D0,  0.75190D0,  0.77864D0,  0.78165D0,
     &     0.76223D0,  0.72410D0,  0.67143D0,  0.60861D0,  0.54010D0,
     &     0.46946D0,  0.39966D0,  0.33340D0,  0.27271D0,  0.21796D0,
     &     0.17035D0,  0.13022D0,  0.09678D0,  0.04919D0,  0.02174D0,
     &     0.00799D0,  0.00226D0,  0.00004D0,  0.00000D0/
      DATA (FMRS(2,3,I, 2),I=1,49)/
     &     4.92533D0,  4.79050D0,  4.65910D0,  4.58370D0,  4.53079D0,
     &     4.49006D0,  4.36491D0,  4.24084D0,  4.16793D0,  4.11560D0,
     &     4.07957D0,  3.94076D0,  3.72768D0,  3.53640D0,  3.35786D0,
     &     3.19001D0,  2.88282D0,  2.48367D0,  1.95213D0,  1.55132D0,
     &     1.02835D0,  0.75268D0,  0.62744D0,  0.59181D0,  0.62218D0,
     &     0.67462D0,  0.72413D0,  0.75779D0,  0.77032D0,  0.76124D0,
     &     0.73236D0,  0.68747D0,  0.63069D0,  0.56612D0,  0.49789D0,
     &     0.42912D0,  0.36239D0,  0.29993D0,  0.24354D0,  0.19324D0,
     &     0.14994D0,  0.11382D0,  0.08400D0,  0.04209D0,  0.01833D0,
     &     0.00664D0,  0.00185D0,  0.00003D0,  0.00000D0/
      DATA (FMRS(2,3,I, 3),I=1,49)/
     &     9.56993D0,  8.80858D0,  8.10702D0,  7.72221D0,  7.45989D0,
     &     7.26226D0,  6.67868D0,  6.13604D0,  5.83460D0,  5.62657D0,
     &     5.47187D0,  4.98498D0,  4.45878D0,  4.10350D0,  3.81920D0,
     &     3.57625D0,  3.16921D0,  2.68460D0,  2.08542D0,  1.65674D0,
     &     1.11953D0,  0.84374D0,  0.71690D0,  0.67195D0,  0.68567D0,
     &     0.71718D0,  0.74433D0,  0.75653D0,  0.75014D0,  0.72558D0,
     &     0.68509D0,  0.63243D0,  0.57149D0,  0.50592D0,  0.43925D0,
     &     0.37400D0,  0.31223D0,  0.25550D0,  0.20529D0,  0.16120D0,
     &     0.12380D0,  0.09303D0,  0.06796D0,  0.03337D0,  0.01425D0,
     &     0.00506D0,  0.00138D0,  0.00002D0,  0.00000D0/
      DATA (FMRS(2,3,I, 4),I=1,49)/
     &    13.80940D0, 12.36505D0, 11.07010D0, 10.37511D0,  9.90777D0,
     &     9.55916D0,  8.54772D0,  7.63175D0,  7.13319D0,  6.79336D0,
     &     6.53831D0,  5.76591D0,  4.99154D0,  4.51033D0,  4.14636D0,
     &     3.84778D0,  3.36791D0,  2.82235D0,  2.17611D0,  1.72845D0,
     &     1.18134D0,  0.90432D0,  0.77478D0,  0.72147D0,  0.72239D0,
     &     0.73883D0,  0.75059D0,  0.74861D0,  0.73014D0,  0.69610D0,
     &     0.64889D0,  0.59216D0,  0.52949D0,  0.46423D0,  0.39938D0,
     &     0.33717D0,  0.27919D0,  0.22665D0,  0.18078D0,  0.14088D0,
     &     0.10742D0,  0.08015D0,  0.05814D0,  0.02814D0,  0.01185D0,
     &     0.00415D0,  0.00112D0,  0.00002D0,  0.00000D0/
      DATA (FMRS(2,3,I, 5),I=1,49)/
     &    18.88911D0, 16.54105D0, 14.48190D0, 13.39606D0, 12.67388D0,
     &    12.13950D0, 10.61083D0,  9.25560D0,  8.52999D0,  8.04031D0,
     &     7.67199D0,  6.58349D0,  5.54112D0,  4.92668D0,  4.47939D0,
     &     4.12305D0,  3.56848D0,  2.96102D0,  2.26733D0,  1.80038D0,
     &     1.24179D0,  0.96142D0,  0.82726D0,  0.76409D0,  0.75165D0,
     &     0.75317D0,  0.75022D0,  0.73504D0,  0.70570D0,  0.66340D0,
     &     0.61066D0,  0.55093D0,  0.48745D0,  0.42321D0,  0.36077D0,
     &     0.30193D0,  0.24792D0,  0.19962D0,  0.15797D0,  0.12220D0,
     &     0.09245D0,  0.06850D0,  0.04934D0,  0.02353D0,  0.00976D0,
     &     0.00337D0,  0.00090D0,  0.00002D0,  0.00000D0/
      DATA (FMRS(2,3,I, 6),I=1,49)/
     &    24.17862D0, 20.81157D0, 17.90894D0, 16.39907D0, 15.40344D0,
     &    14.67132D0, 12.59987D0, 10.79385D0,  9.83948D0,  9.20057D0,
     &     8.72036D0,  7.32519D0,  6.02998D0,  5.29291D0,  4.77007D0,
     &     4.36196D0,  3.74120D0,  3.07968D0,  2.34504D0,  1.86151D0,
     &     1.29269D0,  1.00884D0,  0.87005D0,  0.79769D0,  0.77342D0,
     &     0.76224D0,  0.74721D0,  0.72151D0,  0.68376D0,  0.63535D0,
     &     0.57871D0,  0.51714D0,  0.45352D0,  0.39051D0,  0.33033D0,
     &     0.27444D0,  0.22374D0,  0.17892D0,  0.14065D0,  0.10811D0,
     &     0.08127D0,  0.05985D0,  0.04284D0,  0.02018D0,  0.00827D0,
     &     0.00283D0,  0.00075D0,  0.00001D0,  0.00000D0/
      DATA (FMRS(2,3,I, 7),I=1,49)/
     &    29.73861D0, 25.23818D0, 21.41267D0, 19.44500D0, 18.15658D0,
     &    17.21404D0, 14.57125D0, 12.29875D0, 11.11092D0, 10.32111D0,
     &     9.72854D0,  8.02926D0,  6.48794D0,  5.63342D0,  5.03891D0,
     &     4.58210D0,  3.89945D0,  3.18799D0,  2.41570D0,  1.91680D0,
     &     1.33767D0,  1.04936D0,  0.90523D0,  0.82366D0,  0.78841D0,
     &     0.76591D0,  0.74039D0,  0.70578D0,  0.66114D0,  0.60793D0,
     &     0.54844D0,  0.48585D0,  0.42265D0,  0.36114D0,  0.30329D0,
     &     0.25030D0,  0.20271D0,  0.16106D0,  0.12587D0,  0.09616D0,
     &     0.07187D0,  0.05262D0,  0.03744D0,  0.01745D0,  0.00707D0,
     &     0.00239D0,  0.00063D0,  0.00001D0,  0.00000D0/
      DATA (FMRS(2,3,I, 8),I=1,49)/
     &    36.41777D0, 30.48425D0, 25.50925D0, 22.97827D0, 21.33235D0,
     &    20.13434D0, 16.80486D0, 13.98059D0, 12.52029D0, 11.55588D0,
     &    10.83420D0,  8.78991D0,  6.97511D0,  5.99232D0,  5.32046D0,
     &     4.81154D0,  4.06330D0,  3.29938D0,  2.48793D0,  1.97297D0,
     &     1.38262D0,  1.08896D0,  0.93866D0,  0.84707D0,  0.80034D0,
     &     0.76640D0,  0.73057D0,  0.68748D0,  0.63647D0,  0.57905D0,
     &     0.51730D0,  0.45416D0,  0.39180D0,  0.33216D0,  0.27689D0,
     &     0.22693D0,  0.18251D0,  0.14405D0,  0.11189D0,  0.08494D0,
     &     0.06310D0,  0.04592D0,  0.03248D0,  0.01496D0,  0.00600D0,
     &     0.00201D0,  0.00052D0,  0.00001D0,  0.00000D0/
      DATA (FMRS(2,3,I, 9),I=1,49)/
     &    42.89913D0, 35.51439D0, 29.39055D0, 26.30256D0, 24.30551D0,
     &    22.85784D0, 18.86316D0, 15.51177D0, 13.79420D0, 12.66617D0,
     &    11.82423D0,  9.46212D0,  7.39982D0,  6.30264D0,  5.56252D0,
     &     5.00794D0,  4.20275D0,  3.39360D0,  2.54868D0,  2.01994D0,
     &     1.41958D0,  1.12075D0,  0.96469D0,  0.86425D0,  0.80777D0,
     &     0.76439D0,  0.72030D0,  0.67061D0,  0.61480D0,  0.55436D0,
     &     0.49120D0,  0.42796D0,  0.36659D0,  0.30874D0,  0.25576D0,
     &     0.20835D0,  0.16660D0,  0.13075D0,  0.10101D0,  0.07629D0,
     &     0.05637D0,  0.04082D0,  0.02872D0,  0.01310D0,  0.00521D0,
     &     0.00173D0,  0.00045D0,  0.00001D0,  0.00000D0/
      DATA (FMRS(2,3,I,10),I=1,49)/
     &    49.61974D0, 40.67585D0, 33.33157D0, 29.65726D0, 27.29273D0,
     &    25.58490D0, 20.90223D0, 17.01226D0, 15.03449D0, 13.74211D0,
     &    12.78005D0, 10.10345D0,  7.80003D0,  6.59295D0,  5.78776D0,
     &     5.18997D0,  4.33113D0,  3.47979D0,  2.60379D0,  2.06215D0,
     &     1.45191D0,  1.14765D0,  0.98577D0,  0.87686D0,  0.81144D0,
     &     0.75966D0,  0.70838D0,  0.65310D0,  0.59339D0,  0.53065D0,
     &     0.46666D0,  0.40372D0,  0.34354D0,  0.28753D0,  0.23679D0,
     &     0.19183D0,  0.15254D0,  0.11910D0,  0.09155D0,  0.06880D0,
     &     0.05059D0,  0.03647D0,  0.02554D0,  0.01155D0,  0.00456D0,
     &     0.00150D0,  0.00039D0,  0.00001D0,  0.00000D0/
      DATA (FMRS(2,3,I,11),I=1,49)/
     &    55.39180D0, 45.07076D0, 36.65840D0, 32.47479D0, 29.79258D0,
     &    27.86062D0, 22.58892D0, 18.24235D0, 16.04583D0, 14.61602D0,
     &    13.55394D0, 10.61757D0,  8.11747D0,  6.82180D0,  5.96451D0,
     &     5.33234D0,  4.43100D0,  3.54652D0,  2.64619D0,  2.09446D0,
     &     1.47626D0,  1.16746D0,  1.00084D0,  0.88523D0,  0.81292D0,
     &     0.75482D0,  0.69824D0,  0.63893D0,  0.57653D0,  0.51229D0,
     &     0.44790D0,  0.38538D0,  0.32625D0,  0.27173D0,  0.22275D0,
     &     0.17969D0,  0.14226D0,  0.11063D0,  0.08472D0,  0.06341D0,
     &     0.04647D0,  0.03337D0,  0.02328D0,  0.01046D0,  0.00410D0,
     &     0.00135D0,  0.00035D0,  0.00001D0,  0.00000D0/
      DATA (FMRS(2,3,I,12),I=1,49)/
     &    68.81419D0, 55.16745D0, 44.20809D0, 38.82247D0, 35.39534D0,
     &    32.94036D0, 26.30577D0, 20.91710D0, 18.22705D0, 16.48958D0,
     &    15.20488D0, 11.69679D0,  8.77186D0,  7.28789D0,  6.32113D0,
     &     5.61724D0,  4.62839D0,  3.67636D0,  2.72714D0,  2.15522D0,
     &     1.52072D0,  1.20219D0,  1.02548D0,  0.89610D0,  0.81011D0,
     &     0.73981D0,  0.67337D0,  0.60686D0,  0.53995D0,  0.47362D0,
     &     0.40911D0,  0.34808D0,  0.29158D0,  0.24046D0,  0.19523D0,
     &     0.15609D0,  0.12251D0,  0.09445D0,  0.07178D0,  0.05329D0,
     &     0.03875D0,  0.02763D0,  0.01914D0,  0.00848D0,  0.00328D0,
     &     0.00107D0,  0.00027D0,  0.00001D0,  0.00000D0/
      DATA (FMRS(2,3,I,13),I=1,49)/
     &    81.72071D0, 64.73620D0, 51.25830D0, 44.69851D0, 40.54929D0,
     &    37.59021D0, 29.65526D0, 23.28836D0, 20.14139D0, 18.12166D0,
     &    16.63424D0, 12.61228D0,  9.31401D0,  7.66787D0,  6.60816D0,
     &     5.84402D0,  4.78269D0,  3.77556D0,  2.78721D0,  2.19932D0,
     &     1.55169D0,  1.22492D0,  1.03973D0,  0.89912D0,  0.80240D0,
     &     0.72291D0,  0.64937D0,  0.57800D0,  0.50838D0,  0.44121D0,
     &     0.37732D0,  0.31807D0,  0.26412D0,  0.21603D0,  0.17402D0,
     &     0.13809D0,  0.10760D0,  0.08235D0,  0.06220D0,  0.04588D0,
     &     0.03314D0,  0.02349D0,  0.01618D0,  0.00709D0,  0.00272D0,
     &     0.00088D0,  0.00022D0,  0.00001D0,  0.00000D0/
      DATA (FMRS(2,3,I,14),I=1,49)/
     &    97.52657D0, 76.29261D0, 59.65305D0, 51.63612D0, 46.59734D0,
     &    43.02061D0, 33.50751D0, 25.97167D0, 22.28590D0, 19.93624D0,
     &    18.21366D0, 13.60275D0,  9.88582D0,  8.06142D0,  6.90102D0,
     &     6.07241D0,  4.93443D0,  3.87015D0,  2.84210D0,  2.23830D0,
     &     1.57740D0,  1.24193D0,  1.04776D0,  0.89562D0,  0.78827D0,
     &     0.70003D0,  0.62012D0,  0.54473D0,  0.47326D0,  0.40608D0,
     &     0.34362D0,  0.28678D0,  0.23589D0,  0.19121D0,  0.15279D0,
     &     0.12024D0,  0.09296D0,  0.07060D0,  0.05295D0,  0.03880D0,
     &     0.02782D0,  0.01961D0,  0.01341D0,  0.00581D0,  0.00221D0,
     &     0.00071D0,  0.00018D0,  0.00000D0,  0.00000D0/
      DATA (FMRS(2,3,I,15),I=1,49)/
     &   115.42858D0, 89.21046D0, 68.91241D0, 59.22810D0, 53.17852D0,
     &    48.90368D0, 37.62299D0, 28.79719D0, 24.52433D0, 21.81818D0,
     &    19.84305D0, 14.60749D0, 10.45530D0,  8.44881D0,  7.18665D0,
     &     6.29326D0,  5.07912D0,  3.95881D0,  2.89174D0,  2.27205D0,
     &     1.59726D0,  1.25251D0,  1.04935D0,  0.88634D0,  0.76946D0,
     &     0.67380D0,  0.58880D0,  0.51059D0,  0.43833D0,  0.37190D0,
     &     0.31141D0,  0.25732D0,  0.20974D0,  0.16850D0,  0.13349D0,
     &     0.10422D0,  0.07994D0,  0.06028D0,  0.04489D0,  0.03267D0,
     &     0.02328D0,  0.01630D0,  0.01109D0,  0.00475D0,  0.00179D0,
     &     0.00057D0,  0.00015D0,  0.00000D0,  0.00000D0/
      DATA (FMRS(2,3,I,16),I=1,49)/
     &   133.20726D0,101.88441D0, 77.88580D0, 66.53202D0, 59.47687D0,
     &    54.51081D0, 41.49468D0, 31.41946D0, 26.58451D0, 23.53963D0,
     &    21.32609D0, 15.50695D0, 10.95547D0,  8.78473D0,  7.43186D0,
     &     6.48132D0,  5.20052D0,  4.03146D0,  2.93090D0,  2.29753D0,
     &     1.61041D0,  1.25744D0,  1.04659D0,  0.87462D0,  0.75027D0,
     &     0.64906D0,  0.56054D0,  0.48074D0,  0.40844D0,  0.34317D0,
     &     0.28476D0,  0.23329D0,  0.18860D0,  0.15037D0,  0.11827D0,
     &     0.09171D0,  0.06985D0,  0.05235D0,  0.03876D0,  0.02805D0,
     &     0.01988D0,  0.01385D0,  0.00937D0,  0.00398D0,  0.00150D0,
     &     0.00048D0,  0.00012D0,  0.00000D0,  0.00000D0/
      DATA (FMRS(2,3,I,17),I=1,49)/
     &   152.75288D0,115.66533D0, 87.53463D0, 74.33386D0, 66.17272D0,
     &    60.44971D0, 45.54741D0, 34.13087D0, 28.69873D0, 25.29647D0,
     &    22.83273D0, 16.40709D0, 11.44748D0,  9.11138D0,  7.66812D0,
     &     6.66113D0,  5.31487D0,  4.09842D0,  2.96558D0,  2.31899D0,
     &     1.61977D0,  1.25878D0,  1.04063D0,  0.86046D0,  0.72956D0,
     &     0.62377D0,  0.53260D0,  0.45191D0,  0.38010D0,  0.31636D0,
     &     0.26019D0,  0.21141D0,  0.16955D0,  0.13419D0,  0.10481D0,
     &     0.08073D0,  0.06109D0,  0.04550D0,  0.03350D0,  0.02411D0,
     &     0.01700D0,  0.01178D0,  0.00794D0,  0.00335D0,  0.00125D0,
     &     0.00040D0,  0.00010D0,  0.00000D0,  0.00000D0/
      DATA (FMRS(2,3,I,18),I=1,49)/
     &   170.01192D0,127.71370D0, 95.88535D0, 81.04548D0, 71.90795D0,
     &    65.51928D0, 48.96956D0, 36.39437D0, 30.45131D0, 26.74517D0,
     &    24.06967D0, 17.13549D0, 11.83889D0,  9.36824D0,  7.85201D0,
     &     6.79985D0,  5.40144D0,  4.14772D0,  2.98965D0,  2.33267D0,
     &     1.62383D0,  1.25653D0,  1.03280D0,  0.84662D0,  0.71111D0,
     &     0.60235D0,  0.50969D0,  0.42880D0,  0.35778D0,  0.29558D0,
     &     0.24138D0,  0.19483D0,  0.15529D0,  0.12217D0,  0.09488D0,
     &     0.07271D0,  0.05474D0,  0.04057D0,  0.02974D0,  0.02131D0,
     &     0.01497D0,  0.01034D0,  0.00694D0,  0.00291D0,  0.00108D0,
     &     0.00035D0,  0.00009D0,  0.00000D0,  0.00000D0/
      DATA (FMRS(2,3,I,19),I=1,49)/
     &   192.21783D0,143.06714D0,106.42301D0, 89.46533D0, 79.07272D0,
     &    71.83153D0, 53.18588D0, 39.15232D0, 32.57201D0, 28.48916D0,
     &    25.55252D0, 17.99626D0, 12.29353D0,  9.66291D0,  8.06074D0,
     &     6.95556D0,  5.49677D0,  4.20023D0,  3.01333D0,  2.34451D0,
     &     1.62470D0,  1.25025D0,  1.02039D0,  0.82787D0,  0.68779D0,
     &     0.57628D0,  0.48256D0,  0.40194D0,  0.33226D0,  0.27214D0,
     &     0.22041D0,  0.17653D0,  0.13970D0,  0.10915D0,  0.08422D0,
     &     0.06416D0,  0.04803D0,  0.03538D0,  0.02582D0,  0.01841D0,
     &     0.01287D0,  0.00885D0,  0.00592D0,  0.00247D0,  0.00092D0,
     &     0.00029D0,  0.00008D0,  0.00000D0,  0.00000D0/
      DATA (FMRS(2,3,I,20),I=1,49)/
     &   213.34880D0,157.54303D0,116.26574D0, 97.28644D0, 85.70139D0,
     &    77.65329D0, 57.03621D0, 41.64487D0, 34.47643D0, 30.04790D0,
     &    26.87277D0, 18.75275D0, 12.68704D0,  9.91527D0,  8.23788D0,
     &     7.08656D0,  5.57571D0,  4.24254D0,  3.03117D0,  2.35234D0,
     &     1.62325D0,  1.24282D0,  1.00799D0,  0.81051D0,  0.66705D0,
     &     0.55370D0,  0.45951D0,  0.37948D0,  0.31121D0,  0.25302D0,
     &     0.20347D0,  0.16190D0,  0.12732D0,  0.09891D0,  0.07590D0,
     &     0.05752D0,  0.04285D0,  0.03141D0,  0.02283D0,  0.01621D0,
     &     0.01129D0,  0.00774D0,  0.00517D0,  0.00215D0,  0.00079D0,
     &     0.00025D0,  0.00007D0,  0.00000D0,  0.00000D0/
      DATA (FMRS(2,3,I,21),I=1,49)/
     &   233.39284D0,171.15466D0,125.43786D0,104.53514D0, 91.82097D0,
     &    83.01126D0, 60.54451D0, 43.89167D0, 36.18145D0, 31.43626D0,
     &    28.04374D0, 19.41375D0, 13.02433D0, 10.12820D0,  8.38525D0,
     &     7.19405D0,  5.63853D0,  4.27419D0,  3.04230D0,  2.35510D0,
     &     1.61821D0,  1.23292D0,  0.99418D0,  0.79299D0,  0.64721D0,
     &     0.53284D0,  0.43872D0,  0.35966D0,  0.29291D0,  0.23658D0,
     &     0.18910D0,  0.14961D0,  0.11702D0,  0.09045D0,  0.06907D0,
     &     0.05212D0,  0.03865D0,  0.02823D0,  0.02044D0,  0.01446D0,
     &     0.01004D0,  0.00687D0,  0.00457D0,  0.00189D0,  0.00070D0,
     &     0.00022D0,  0.00006D0,  0.00000D0,  0.00000D0/
      DATA (FMRS(2,3,I,22),I=1,49)/
     &   260.44016D0,189.36696D0,137.60457D0,114.10131D0, 99.86725D0,
     &    90.03576D0, 65.10178D0, 46.78208D0, 38.36169D0, 33.20363D0,
     &    29.52871D0, 20.24143D0, 13.44020D0, 10.38777D0,  8.56307D0,
     &     7.32250D0,  5.71195D0,  4.30962D0,  3.05294D0,  2.35572D0,
     &     1.60960D0,  1.21865D0,  0.97551D0,  0.77034D0,  0.62226D0,
     &     0.50716D0,  0.41356D0,  0.33596D0,  0.27128D0,  0.21734D0,
     &     0.17244D0,  0.13547D0,  0.10527D0,  0.08085D0,  0.06139D0,
     &     0.04607D0,  0.03398D0,  0.02471D0,  0.01781D0,  0.01255D0,
     &     0.00868D0,  0.00593D0,  0.00393D0,  0.00162D0,  0.00060D0,
     &     0.00019D0,  0.00005D0,  0.00000D0,  0.00000D0/
      DATA (FMRS(2,3,I,23),I=1,49)/
     &   287.44696D0,207.38838D0,149.53354D0,123.42919D0,107.68206D0,
     &    96.83708D0, 69.47065D0, 49.52397D0, 40.41636D0, 34.86102D0,
     &    30.91543D0, 21.00356D0, 13.81644D0, 10.61949D0,  8.71986D0,
     &     7.43441D0,  5.77408D0,  4.33783D0,  3.05923D0,  2.35324D0,
     &     1.59919D0,  1.20346D0,  0.95679D0,  0.74861D0,  0.59903D0,
     &     0.48379D0,  0.39106D0,  0.31505D0,  0.25241D0,  0.20076D0,
     &     0.15822D0,  0.12352D0,  0.09541D0,  0.07286D0,  0.05504D0,
     &     0.04110D0,  0.03018D0,  0.02185D0,  0.01570D0,  0.01103D0,
     &     0.00760D0,  0.00518D0,  0.00342D0,  0.00141D0,  0.00052D0,
     &     0.00017D0,  0.00004D0,  0.00000D0,  0.00000D0/
      DATA (FMRS(2,3,I,24),I=1,49)/
     &   313.51825D0,224.63136D0,160.84229D0,132.22295D0,115.01953D0,
     &   103.20245D0, 73.51698D0, 52.03463D0, 42.28400D0, 36.35911D0,
     &    32.16307D0, 21.67765D0, 14.14149D0, 10.81558D0,  8.84983D0,
     &     7.52509D0,  5.82169D0,  4.35654D0,  3.05952D0,  2.34629D0,
     &     1.58590D0,  1.18656D0,  0.93734D0,  0.72724D0,  0.57702D0,
     &     0.46218D0,  0.37070D0,  0.29646D0,  0.23590D0,  0.18642D0,
     &     0.14603D0,  0.11337D0,  0.08712D0,  0.06621D0,  0.04979D0,
     &     0.03702D0,  0.02708D0,  0.01953D0,  0.01399D0,  0.00980D0,
     &     0.00674D0,  0.00458D0,  0.00302D0,  0.00124D0,  0.00046D0,
     &     0.00015D0,  0.00004D0,  0.00000D0,  0.00000D0/
      DATA (FMRS(2,3,I,25),I=1,49)/
     &   341.15173D0,242.77290D0,172.65150D0,141.36496D0,122.62321D0,
     &   109.78229D0, 77.66644D0, 54.58787D0, 44.17350D0, 37.86890D0,
     &    33.41642D0, 22.34751D0, 14.46016D0, 11.00588D0,  8.97477D0,
     &     7.61137D0,  5.86592D0,  4.37273D0,  3.05810D0,  2.33803D0,
     &     1.57177D0,  1.16920D0,  0.91780D0,  0.70620D0,  0.55570D0,
     &     0.44154D0,  0.35145D0,  0.27905D0,  0.22057D0,  0.17322D0,
     &     0.13490D0,  0.10417D0,  0.07964D0,  0.06025D0,  0.04510D0,
     &     0.03340D0,  0.02434D0,  0.01749D0,  0.01249D0,  0.00873D0,
     &     0.00599D0,  0.00406D0,  0.00268D0,  0.00110D0,  0.00041D0,
     &     0.00013D0,  0.00004D0,  0.00000D0,  0.00000D0/
      DATA (FMRS(2,3,I,26),I=1,49)/
     &   368.98822D0,260.90195D0,184.35516D0,150.38000D0,130.09390D0,
     &   116.22827D0, 81.69344D0, 57.04021D0, 45.97627D0, 39.30195D0,
     &    34.60083D0, 22.97047D0, 14.74975D0, 11.17543D0,  9.08370D0,
     &     7.68467D0,  5.90104D0,  4.38251D0,  3.05244D0,  2.32659D0,
     &     1.55551D0,  1.15047D0,  0.89759D0,  0.68521D0,  0.53495D0,
     &     0.42187D0,  0.33342D0,  0.26295D0,  0.20656D0,  0.16128D0,
     &     0.12493D0,  0.09597D0,  0.07303D0,  0.05500D0,  0.04100D0,
     &     0.03027D0,  0.02198D0,  0.01575D0,  0.01122D0,  0.00782D0,
     &     0.00536D0,  0.00363D0,  0.00239D0,  0.00098D0,  0.00036D0,
     &     0.00012D0,  0.00003D0,  0.00000D0,  0.00000D0/
      DATA (FMRS(2,3,I,27),I=1,49)/
     &   396.49847D0,278.69458D0,195.76036D0,159.12776D0,137.32101D0,
     &   122.44904D0, 85.54959D0, 59.36906D0, 47.67925D0, 40.65031D0,
     &    35.71157D0, 23.54779D0, 15.01388D0, 11.32784D0,  9.18018D0,
     &     7.74858D0,  5.93008D0,  4.38884D0,  3.04508D0,  2.31422D0,
     &     1.53913D0,  1.13220D0,  0.87829D0,  0.66558D0,  0.51586D0,
     &     0.40401D0,  0.31721D0,  0.24862D0,  0.19419D0,  0.15083D0,
     &     0.11625D0,  0.08889D0,  0.06736D0,  0.05053D0,  0.03753D0,
     &     0.02761D0,  0.01999D0,  0.01428D0,  0.01015D0,  0.00707D0,
     &     0.00483D0,  0.00327D0,  0.00215D0,  0.00088D0,  0.00033D0,
     &     0.00011D0,  0.00003D0,  0.00000D0,  0.00000D0/
      DATA (FMRS(2,3,I,28),I=1,49)/
     &   423.18488D0,295.83777D0,206.67247D0,167.46211D0,144.18538D0,
     &   128.34305D0, 89.17443D0, 61.53922D0, 49.25727D0, 41.89430D0,
     &    36.73269D0, 24.07136D0, 15.24876D0, 11.46075D0,  9.26257D0,
     &     7.80186D0,  5.95221D0,  4.39115D0,  3.03561D0,  2.30059D0,
     &     1.52239D0,  1.11417D0,  0.85969D0,  0.64709D0,  0.49822D0,
     &     0.38776D0,  0.30261D0,  0.23584D0,  0.18326D0,  0.14166D0,
     &     0.10869D0,  0.08277D0,  0.06247D0,  0.04670D0,  0.03458D0,
     &     0.02536D0,  0.01831D0,  0.01305D0,  0.00927D0,  0.00644D0,
     &     0.00439D0,  0.00297D0,  0.00195D0,  0.00080D0,  0.00030D0,
     &     0.00010D0,  0.00003D0,  0.00000D0,  0.00000D0/
      DATA (FMRS(2,3,I,29),I=1,49)/
     &   450.92862D0,313.54996D0,217.87523D0,175.98549D0,151.18591D0,
     &   134.34097D0, 92.83694D0, 63.71518D0, 50.83173D0, 43.13081D0,
     &    37.74429D0, 24.58404D0, 15.47489D0, 11.58672D0,  9.33925D0,
     &     7.85026D0,  5.97071D0,  4.39081D0,  3.02434D0,  2.28559D0,
     &     1.50481D0,  1.09565D0,  0.84093D0,  0.62877D0,  0.48096D0,
     &     0.37201D0,  0.28863D0,  0.22371D0,  0.17297D0,  0.13307D0,
     &     0.10166D0,  0.07711D0,  0.05798D0,  0.04320D0,  0.03189D0,
     &     0.02332D0,  0.01680D0,  0.01195D0,  0.00847D0,  0.00587D0,
     &     0.00400D0,  0.00270D0,  0.00178D0,  0.00073D0,  0.00027D0,
     &     0.00009D0,  0.00002D0,  0.00000D0,  0.00000D0/
      DATA (FMRS(2,3,I,30),I=1,49)/
     &   478.88074D0,331.28183D0,229.01660D0,184.42841D0,158.10007D0,
     &   140.25114D0, 96.41853D0, 65.82523D0, 52.35015D0, 44.31818D0,
     &    38.71195D0, 25.06767D0, 15.68364D0, 11.70050D0,  9.40671D0,
     &     7.89123D0,  5.98412D0,  4.38708D0,  3.01099D0,  2.26914D0,
     &     1.48646D0,  1.07684D0,  0.82225D0,  0.61085D0,  0.46437D0,
     &     0.35704D0,  0.27550D0,  0.21242D0,  0.16347D0,  0.12519D0,
     &     0.09525D0,  0.07197D0,  0.05394D0,  0.04005D0,  0.02949D0,
     &     0.02151D0,  0.01546D0,  0.01097D0,  0.00776D0,  0.00538D0,
     &     0.00366D0,  0.00247D0,  0.00162D0,  0.00067D0,  0.00025D0,
     &     0.00008D0,  0.00002D0,  0.00000D0,  0.00000D0/
      DATA (FMRS(2,3,I,31),I=1,49)/
     &   506.38092D0,348.62979D0,239.85460D0,192.61319D0,164.78622D0,
     &   145.95520D0, 99.85363D0, 67.83522D0, 53.79026D0, 45.44058D0,
     &    39.62410D0, 25.51892D0, 15.87554D0, 11.80362D0,  9.46678D0,
     &     7.92687D0,  5.99445D0,  4.38186D0,  2.99723D0,  2.25276D0,
     &     1.46868D0,  1.05889D0,  0.80464D0,  0.59419D0,  0.44909D0,
     &     0.34338D0,  0.26361D0,  0.20228D0,  0.15498D0,  0.11820D0,
     &     0.08960D0,  0.06746D0,  0.05040D0,  0.03731D0,  0.02741D0,
     &     0.01994D0,  0.01431D0,  0.01014D0,  0.00716D0,  0.00495D0,
     &     0.00337D0,  0.00227D0,  0.00149D0,  0.00061D0,  0.00023D0,
     &     0.00007D0,  0.00002D0,  0.00000D0,  0.00000D0/
      DATA (FMRS(2,3,I,32),I=1,49)/
     &   532.71063D0,365.14023D0,250.10423D0,200.32385D0,171.06720D0,
     &   151.30153D0,103.04897D0, 69.68893D0, 55.11074D0, 46.46502D0,
     &    40.45333D0, 25.92270D0, 16.04272D0, 11.89083D0,  9.51556D0,
     &     7.95409D0,  5.99947D0,  4.37358D0,  2.98195D0,  2.23557D0,
     &     1.45083D0,  1.04132D0,  0.78773D0,  0.57848D0,  0.43489D0,
     &     0.33086D0,  0.25280D0,  0.19316D0,  0.14738D0,  0.11200D0,
     &     0.08461D0,  0.06352D0,  0.04732D0,  0.03494D0,  0.02560D0,
     &     0.01860D0,  0.01332D0,  0.00942D0,  0.00665D0,  0.00459D0,
     &     0.00312D0,  0.00210D0,  0.00138D0,  0.00057D0,  0.00021D0,
     &     0.00007D0,  0.00002D0,  0.00000D0,  0.00000D0/
      DATA (FMRS(2,3,I,33),I=1,49)/
     &   560.44952D0,382.45715D0,260.80753D0,208.35481D0,177.59706D0,
     &   156.85155D0,106.35128D0, 71.59602D0, 56.46558D0, 47.51407D0,
     &    41.30114D0, 26.33344D0, 16.21190D0, 11.97881D0,  9.56466D0,
     &     7.98144D0,  6.00450D0,  4.36531D0,  2.96673D0,  2.21850D0,
     &     1.43317D0,  1.02401D0,  0.77116D0,  0.56317D0,  0.42112D0,
     &     0.31878D0,  0.24243D0,  0.18443D0,  0.14015D0,  0.10612D0,
     &     0.07989D0,  0.05980D0,  0.04442D0,  0.03272D0,  0.02392D0,
     &     0.01734D0,  0.01239D0,  0.00875D0,  0.00617D0,  0.00426D0,
     &     0.00289D0,  0.00195D0,  0.00128D0,  0.00052D0,  0.00020D0,
     &     0.00006D0,  0.00002D0,  0.00000D0,  0.00000D0/
      DATA (FMRS(2,3,I,34),I=1,49)/
     &   587.66711D0,399.34082D0,271.17145D0,216.09799D0,183.87283D0,
     &   162.17198D0,109.48943D0, 73.38959D0, 57.73061D0, 48.48780D0,
     &    42.08379D0, 26.70440D0, 16.35846D0, 12.05124D0,  9.60203D0,
     &     7.99942D0,  6.00308D0,  4.35260D0,  2.94870D0,  2.19937D0,
     &     1.41431D0,  1.00609D0,  0.75435D0,  0.54797D0,  0.40769D0,
     &     0.30718D0,  0.23257D0,  0.17622D0,  0.13341D0,  0.10068D0,
     &     0.07556D0,  0.05639D0,  0.04179D0,  0.03071D0,  0.02240D0,
     &     0.01621D0,  0.01157D0,  0.00816D0,  0.00575D0,  0.00396D0,
     &     0.00269D0,  0.00181D0,  0.00119D0,  0.00049D0,  0.00018D0,
     &     0.00006D0,  0.00002D0,  0.00000D0,  0.00000D0/
      DATA (FMRS(2,3,I,35),I=1,49)/
     &   614.66376D0,416.01791D0,281.36646D0,223.69629D0,190.02084D0,
     &   167.37685D0,112.54659D0, 75.12943D0, 58.95456D0, 49.42817D0,
     &    42.83852D0, 27.06040D0, 16.49837D0, 12.12015D0,  9.63748D0,
     &     8.01641D0,  6.00168D0,  4.34055D0,  2.93168D0,  2.18137D0,
     &     1.39666D0,  0.98938D0,  0.73876D0,  0.53395D0,  0.39535D0,
     &     0.29658D0,  0.22360D0,  0.16878D0,  0.12732D0,  0.09577D0,
     &     0.07167D0,  0.05334D0,  0.03944D0,  0.02892D0,  0.02106D0,
     &     0.01521D0,  0.01085D0,  0.00764D0,  0.00537D0,  0.00370D0,
     &     0.00251D0,  0.00169D0,  0.00111D0,  0.00046D0,  0.00017D0,
     &     0.00006D0,  0.00002D0,  0.00000D0,  0.00000D0/
      DATA (FMRS(2,3,I,36),I=1,49)/
     &   640.64490D0,431.98953D0,291.07977D0,230.91319D0,195.84616D0,
     &   172.29993D0,115.42027D0, 76.75350D0, 60.09168D0, 50.29848D0,
     &    43.53482D0, 27.38445D0, 16.62263D0, 12.17943D0,  9.66642D0,
     &     8.02868D0,  5.99763D0,  4.32731D0,  2.91439D0,  2.16350D0,
     &     1.37952D0,  0.97339D0,  0.72400D0,  0.52085D0,  0.38394D0,
     &     0.28684D0,  0.21543D0,  0.16204D0,  0.12184D0,  0.09139D0,
     &     0.06820D0,  0.05064D0,  0.03736D0,  0.02734D0,  0.01987D0,
     &     0.01434D0,  0.01021D0,  0.00718D0,  0.00505D0,  0.00348D0,
     &     0.00236D0,  0.00159D0,  0.00104D0,  0.00043D0,  0.00016D0,
     &     0.00005D0,  0.00001D0,  0.00000D0,  0.00000D0/
      DATA (FMRS(2,3,I,37),I=1,49)/
     &   667.19971D0,448.23413D0,300.90906D0,238.19307D0,201.70891D0,
     &   177.24495D0,118.28902D0, 78.36304D0, 61.21302D0, 51.15329D0,
     &    44.21644D0, 27.69705D0, 16.73916D0, 12.23290D0,  9.69072D0,
     &     8.03703D0,  5.99069D0,  4.31202D0,  2.89571D0,  2.14460D0,
     &     1.36178D0,  0.95706D0,  0.70912D0,  0.50779D0,  0.37268D0,
     &     0.27731D0,  0.20750D0,  0.15552D0,  0.11658D0,  0.08719D0,
     &     0.06491D0,  0.04808D0,  0.03540D0,  0.02586D0,  0.01877D0,
     &     0.01352D0,  0.00961D0,  0.00676D0,  0.00475D0,  0.00327D0,
     &     0.00222D0,  0.00149D0,  0.00098D0,  0.00040D0,  0.00015D0,
     &     0.00005D0,  0.00001D0,  0.00000D0,  0.00000D0/
      DATA (FMRS(2,3,I,38),I=1,49)/
     &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
     &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
     &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
     &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
     &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
     &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
     &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
     &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
     &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
     &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0/
      DATA (FMRS(2,4,I, 1),I=1,49)/
     &     0.96883D0,  0.83010D0,  0.71060D0,  0.64853D0,  0.60767D0,
     &     0.57770D0,  0.49346D0,  0.42161D0,  0.38501D0,  0.36146D0,
     &     0.34535D0,  0.30095D0,  0.26559D0,  0.24803D0,  0.23669D0,
     &     0.22831D0,  0.21597D0,  0.20255D0,  0.18524D0,  0.17029D0,
     &     0.14323D0,  0.11890D0,  0.09745D0,  0.07499D0,  0.05725D0,
     &     0.04365D0,  0.03351D0,  0.02602D0,  0.02043D0,  0.01653D0,
     &     0.01318D0,  0.01067D0,  0.00853D0,  0.00671D0,  0.00530D0,
     &     0.00405D0,  0.00296D0,  0.00217D0,  0.00162D0,  0.00103D0,
     &     0.00065D0,  0.00047D0,  0.00023D0,  0.00008D0,  0.00004D0,
     &     0.00001D0,  0.00000D0,  0.00000D0,  0.00000D0/
      DATA (FMRS(2,4,I, 2),I=1,49)/
     &     0.97285D0,  0.83723D0,  0.71985D0,  0.65865D0,  0.61827D0,
     &     0.58859D0,  0.50491D0,  0.43319D0,  0.39649D0,  0.37279D0,
     &     0.35657D0,  0.31149D0,  0.27487D0,  0.25626D0,  0.24402D0,
     &     0.23487D0,  0.22125D0,  0.20637D0,  0.18739D0,  0.17135D0,
     &     0.14312D0,  0.11837D0,  0.09689D0,  0.07465D0,  0.05719D0,
     &     0.04386D0,  0.03391D0,  0.02652D0,  0.02098D0,  0.01703D0,
     &     0.01365D0,  0.01107D0,  0.00885D0,  0.00698D0,  0.00550D0,
     &     0.00421D0,  0.00309D0,  0.00226D0,  0.00169D0,  0.00108D0,
     &     0.00069D0,  0.00049D0,  0.00025D0,  0.00010D0,  0.00003D0,
     &     0.00002D0,  0.00000D0,  0.00000D0,  0.00000D0/
      DATA (FMRS(2,4,I, 3),I=1,49)/
     &     0.99630D0,  0.86193D0,  0.74498D0,  0.68373D0,  0.64319D0,
     &     0.61334D0,  0.52882D0,  0.45586D0,  0.41827D0,  0.39388D0,
     &     0.37707D0,  0.32984D0,  0.29034D0,  0.26968D0,  0.25582D0,
     &     0.24531D0,  0.22956D0,  0.21234D0,  0.19077D0,  0.17310D0,
     &     0.14315D0,  0.11778D0,  0.09624D0,  0.07426D0,  0.05716D0,
     &     0.04417D0,  0.03445D0,  0.02716D0,  0.02168D0,  0.01765D0,
     &     0.01422D0,  0.01151D0,  0.00919D0,  0.00726D0,  0.00569D0,
     &     0.00437D0,  0.00323D0,  0.00233D0,  0.00177D0,  0.00113D0,
     &     0.00072D0,  0.00052D0,  0.00028D0,  0.00011D0,  0.00003D0,
     &     0.00002D0,  0.00000D0,  0.00000D0,  0.00000D0/
      DATA (FMRS(2,4,I, 4),I=1,49)/
     &     1.02892D0,  0.89240D0,  0.77327D0,  0.71073D0,  0.66929D0,
     &     0.63873D0,  0.55202D0,  0.47687D0,  0.43798D0,  0.41263D0,
     &     0.39503D0,  0.34528D0,  0.30287D0,  0.28033D0,  0.26505D0,
     &     0.25342D0,  0.23594D0,  0.21688D0,  0.19336D0,  0.17449D0,
     &     0.14328D0,  0.11746D0,  0.09586D0,  0.07403D0,  0.05716D0,
     &     0.04437D0,  0.03479D0,  0.02755D0,  0.02207D0,  0.01800D0,
     &     0.01451D0,  0.01172D0,  0.00935D0,  0.00736D0,  0.00577D0,
     &     0.00444D0,  0.00328D0,  0.00236D0,  0.00178D0,  0.00114D0,
     &     0.00075D0,  0.00052D0,  0.00029D0,  0.00011D0,  0.00004D0,
     &     0.00003D0,  0.00000D0,  0.00000D0,  0.00000D0/
      DATA (FMRS(2,4,I, 5),I=1,49)/
     &     1.08451D0,  0.94133D0,  0.81630D0,  0.75061D0,  0.70706D0,
     &     0.67493D0,  0.58367D0,  0.50437D0,  0.46318D0,  0.43623D0,
     &     0.41737D0,  0.36373D0,  0.31732D0,  0.29240D0,  0.27539D0,
     &     0.26243D0,  0.24295D0,  0.22186D0,  0.19623D0,  0.17608D0,
     &     0.14355D0,  0.11725D0,  0.09556D0,  0.07384D0,  0.05715D0,
     &     0.04453D0,  0.03504D0,  0.02784D0,  0.02236D0,  0.01824D0,
     &     0.01470D0,  0.01187D0,  0.00949D0,  0.00742D0,  0.00580D0,
     &     0.00445D0,  0.00328D0,  0.00235D0,  0.00175D0,  0.00116D0,
     &     0.00074D0,  0.00053D0,  0.00029D0,  0.00011D0,  0.00004D0,
     &     0.00002D0,  0.00000D0,  0.00000D0,  0.00000D0/
      DATA (FMRS(2,4,I, 6),I=1,49)/
     &     1.14357D0,  0.99242D0,  0.86045D0,  0.79114D0,  0.74518D0,
     &     0.71127D0,  0.61492D0,  0.53108D0,  0.48742D0,  0.45878D0,
     &     0.43857D0,  0.38094D0,  0.33056D0,  0.30333D0,  0.28470D0,
     &     0.27048D0,  0.24918D0,  0.22626D0,  0.19875D0,  0.17749D0,
     &     0.14383D0,  0.11711D0,  0.09533D0,  0.07370D0,  0.05713D0,
     &     0.04464D0,  0.03521D0,  0.02805D0,  0.02256D0,  0.01839D0,
     &     0.01482D0,  0.01197D0,  0.00955D0,  0.00745D0,  0.00580D0,
     &     0.00443D0,  0.00326D0,  0.00233D0,  0.00174D0,  0.00116D0,
     &     0.00074D0,  0.00053D0,  0.00029D0,  0.00011D0,  0.00004D0,
     &     0.00002D0,  0.00000D0,  0.00000D0,  0.00000D0/
      DATA (FMRS(2,4,I, 7),I=1,49)/
     &     1.21691D0,  1.05450D0,  0.91294D0,  0.83868D0,  0.78948D0,
     &     0.75319D0,  0.65015D0,  0.56049D0,  0.51374D0,  0.48302D0,
     &     0.46120D0,  0.39885D0,  0.34401D0,  0.31429D0,  0.29395D0,
     &     0.27845D0,  0.25529D0,  0.23055D0,  0.20123D0,  0.17890D0,
     &     0.14416D0,  0.11703D0,  0.09514D0,  0.07357D0,  0.05711D0,
     &     0.04471D0,  0.03532D0,  0.02818D0,  0.02268D0,  0.01846D0,
     &     0.01487D0,  0.01199D0,  0.00952D0,  0.00742D0,  0.00577D0,
     &     0.00441D0,  0.00322D0,  0.00229D0,  0.00172D0,  0.00114D0,
     &     0.00072D0,  0.00051D0,  0.00029D0,  0.00010D0,  0.00004D0,
     &     0.00001D0,  0.00000D0,  0.00000D0,  0.00000D0/
      DATA (FMRS(2,4,I, 8),I=1,49)/
     &     1.31000D0,  1.13230D0,  0.97784D0,  0.89699D0,  0.84348D0,
     &     0.80406D0,  0.69226D0,  0.59511D0,  0.54444D0,  0.51110D0,
     &     0.48726D0,  0.41913D0,  0.35898D0,  0.32638D0,  0.30408D0,
     &     0.28713D0,  0.26192D0,  0.23518D0,  0.20389D0,  0.18042D0,
     &     0.14454D0,  0.11697D0,  0.09497D0,  0.07342D0,  0.05705D0,
     &     0.04474D0,  0.03539D0,  0.02827D0,  0.02275D0,  0.01851D0,
     &     0.01488D0,  0.01197D0,  0.00947D0,  0.00737D0,  0.00571D0,
     &     0.00437D0,  0.00318D0,  0.00224D0,  0.00169D0,  0.00111D0,
     &     0.00070D0,  0.00049D0,  0.00029D0,  0.00010D0,  0.00004D0,
     &     0.00001D0,  0.00000D0,  0.00000D0,  0.00000D0/
      DATA (FMRS(2,4,I, 9),I=1,49)/
     &     1.40457D0,  1.21051D0,  1.04237D0,  0.95458D0,  0.89657D0,
     &     0.85387D0,  0.73299D0,  0.62815D0,  0.57350D0,  0.53752D0,
     &     0.51167D0,  0.43783D0,  0.37258D0,  0.33726D0,  0.31316D0,
     &     0.29488D0,  0.26778D0,  0.23925D0,  0.20624D0,  0.18177D0,
     &     0.14489D0,  0.11694D0,  0.09483D0,  0.07330D0,  0.05698D0,
     &     0.04474D0,  0.03543D0,  0.02831D0,  0.02277D0,  0.01852D0,
     &     0.01487D0,  0.01192D0,  0.00942D0,  0.00732D0,  0.00564D0,
     &     0.00433D0,  0.00313D0,  0.00219D0,  0.00166D0,  0.00109D0,
     &     0.00068D0,  0.00049D0,  0.00028D0,  0.00010D0,  0.00003D0,
     &     0.00001D0,  0.00000D0,  0.00000D0,  0.00000D0/
      DATA (FMRS(2,4,I,10),I=1,49)/
     &     1.51092D0,  1.29750D0,  1.11331D0,  1.01744D0,  0.95421D0,
     &     0.90772D0,  0.77643D0,  0.66288D0,  0.60378D0,  0.56488D0,
     &     0.53682D0,  0.45681D0,  0.38616D0,  0.34803D0,  0.32208D0,
     &     0.30246D0,  0.27350D0,  0.24321D0,  0.20851D0,  0.18308D0,
     &     0.14525D0,  0.11692D0,  0.09469D0,  0.07316D0,  0.05689D0,
     &     0.04470D0,  0.03541D0,  0.02828D0,  0.02274D0,  0.01846D0,
     &     0.01479D0,  0.01184D0,  0.00933D0,  0.00722D0,  0.00556D0,
     &     0.00426D0,  0.00307D0,  0.00215D0,  0.00161D0,  0.00106D0,
     &     0.00067D0,  0.00048D0,  0.00027D0,  0.00010D0,  0.00003D0,
     &     0.00001D0,  0.00000D0,  0.00000D0,  0.00000D0/
      DATA (FMRS(2,4,I,11),I=1,49)/
     &     1.60472D0,  1.37368D0,  1.17498D0,  1.07183D0,  1.00391D0,
     &     0.95405D0,  0.81348D0,  0.69224D0,  0.62923D0,  0.58777D0,
     &     0.55781D0,  0.47247D0,  0.39725D0,  0.35677D0,  0.32928D0,
     &     0.30856D0,  0.27807D0,  0.24637D0,  0.21032D0,  0.18413D0,
     &     0.14554D0,  0.11692D0,  0.09459D0,  0.07304D0,  0.05681D0,
     &     0.04465D0,  0.03537D0,  0.02823D0,  0.02270D0,  0.01839D0,
     &     0.01471D0,  0.01176D0,  0.00923D0,  0.00712D0,  0.00549D0,
     &     0.00419D0,  0.00301D0,  0.00213D0,  0.00157D0,  0.00105D0,
     &     0.00065D0,  0.00047D0,  0.00027D0,  0.00010D0,  0.00004D0,
     &     0.00001D0,  0.00000D0,  0.00000D0,  0.00000D0/
      DATA (FMRS(2,4,I,12),I=1,49)/
     &     1.83637D0,  1.55987D0,  1.32404D0,  1.20242D0,  1.12267D0,
     &     1.06429D0,  0.90056D0,  0.76032D0,  0.68777D0,  0.64012D0,
     &     0.60555D0,  0.50757D0,  0.42172D0,  0.37588D0,  0.34496D0,
     &     0.32177D0,  0.28792D0,  0.25312D0,  0.21417D0,  0.18636D0,
     &     0.14617D0,  0.11691D0,  0.09435D0,  0.07276D0,  0.05658D0,
     &     0.04447D0,  0.03521D0,  0.02807D0,  0.02254D0,  0.01819D0,
     &     0.01452D0,  0.01154D0,  0.00905D0,  0.00695D0,  0.00533D0,
     &     0.00404D0,  0.00292D0,  0.00205D0,  0.00149D0,  0.00100D0,
     &     0.00062D0,  0.00045D0,  0.00024D0,  0.00010D0,  0.00003D0,
     &     0.00001D0,  0.00000D0,  0.00000D0,  0.00000D0/
      DATA (FMRS(2,4,I,13),I=1,49)/
     &     2.07152D0,  1.74663D0,  1.47172D0,  1.33085D0,  1.23884D0,
     &     1.17167D0,  0.98420D0,  0.82476D0,  0.74268D0,  0.68890D0,
     &     0.64981D0,  0.53955D0,  0.44363D0,  0.39281D0,  0.35874D0,
     &     0.33333D0,  0.29647D0,  0.25893D0,  0.21746D0,  0.18826D0,
     &     0.14670D0,  0.11688D0,  0.09412D0,  0.07248D0,  0.05632D0,
     &     0.04424D0,  0.03500D0,  0.02787D0,  0.02234D0,  0.01798D0,
     &     0.01431D0,  0.01132D0,  0.00886D0,  0.00679D0,  0.00517D0,
     &     0.00390D0,  0.00284D0,  0.00195D0,  0.00143D0,  0.00095D0,
     &     0.00059D0,  0.00043D0,  0.00023D0,  0.00009D0,  0.00002D0,
     &     0.00001D0,  0.00000D0,  0.00000D0,  0.00000D0/
      DATA (FMRS(2,4,I,14),I=1,49)/
     &     2.37643D0,  1.98603D0,  1.65879D0,  1.49235D0,  1.38415D0,
     &     1.30543D0,  1.08702D0,  0.90288D0,  0.80867D0,  0.74716D0,
     &     0.70240D0,  0.57696D0,  0.46881D0,  0.41209D0,  0.37432D0,
     &     0.34632D0,  0.30599D0,  0.26535D0,  0.22106D0,  0.19032D0,
     &     0.14723D0,  0.11682D0,  0.09381D0,  0.07211D0,  0.05596D0,
     &     0.04392D0,  0.03471D0,  0.02757D0,  0.02204D0,  0.01767D0,
     &     0.01400D0,  0.01105D0,  0.00862D0,  0.00657D0,  0.00496D0,
     &     0.00374D0,  0.00270D0,  0.00182D0,  0.00137D0,  0.00090D0,
     &     0.00057D0,  0.00039D0,  0.00023D0,  0.00007D0,  0.00002D0,
     &     0.00001D0,  0.00000D0,  0.00000D0,  0.00000D0/
      DATA (FMRS(2,4,I,15),I=1,49)/
     &     2.74566D0,  2.27231D0,  1.87960D0,  1.68150D0,  1.55338D0,
     &     1.46052D0,  1.20454D0,  0.99082D0,  0.88227D0,  0.81170D0,
     &     0.76034D0,  0.61745D0,  0.49560D0,  0.43237D0,  0.39059D0,
     &     0.35980D0,  0.31580D0,  0.27191D0,  0.22470D0,  0.19238D0,
     &     0.14774D0,  0.11669D0,  0.09344D0,  0.07165D0,  0.05549D0,
     &     0.04347D0,  0.03429D0,  0.02720D0,  0.02166D0,  0.01729D0,
     &     0.01366D0,  0.01073D0,  0.00832D0,  0.00636D0,  0.00476D0,
     &     0.00357D0,  0.00255D0,  0.00175D0,  0.00131D0,  0.00086D0,
     &     0.00052D0,  0.00037D0,  0.00021D0,  0.00007D0,  0.00002D0,
     &     0.00001D0,  0.00000D0,  0.00000D0,  0.00000D0/
      DATA (FMRS(2,4,I,16),I=1,49)/
     &     3.12622D0,  2.56414D0,  2.10216D0,  1.87087D0,  1.72199D0,
     &     1.61445D0,  1.31978D0,  1.07596D0,  0.95298D0,  0.87335D0,
     &     0.81544D0,  0.65540D0,  0.52031D0,  0.45090D0,  0.40535D0,
     &     0.37197D0,  0.32458D0,  0.27772D0,  0.22787D0,  0.19414D0,
     &     0.14813D0,  0.11651D0,  0.09303D0,  0.07117D0,  0.05501D0,
     &     0.04302D0,  0.03385D0,  0.02678D0,  0.02128D0,  0.01692D0,
     &     0.01332D0,  0.01043D0,  0.00806D0,  0.00611D0,  0.00459D0,
     &     0.00341D0,  0.00242D0,  0.00166D0,  0.00123D0,  0.00082D0,
     &     0.00050D0,  0.00034D0,  0.00020D0,  0.00006D0,  0.00003D0,
     &     0.00001D0,  0.00000D0,  0.00000D0,  0.00000D0/
      DATA (FMRS(2,4,I,17),I=1,49)/
     &     3.55799D0,  2.89188D0,  2.34954D0,  2.08007D0,  1.90742D0,
     &     1.78316D0,  1.44470D0,  1.16721D0,  1.02825D0,  0.93863D0,
     &     0.87356D0,  0.69490D0,  0.54567D0,  0.46976D0,  0.42028D0,
     &     0.38422D0,  0.33334D0,  0.28346D0,  0.23097D0,  0.19583D0,
     &     0.14845D0,  0.11627D0,  0.09257D0,  0.07063D0,  0.05448D0,
     &     0.04252D0,  0.03337D0,  0.02631D0,  0.02087D0,  0.01652D0,
     &     0.01297D0,  0.01012D0,  0.00778D0,  0.00585D0,  0.00440D0,
     &     0.00326D0,  0.00231D0,  0.00157D0,  0.00115D0,  0.00076D0,
     &     0.00047D0,  0.00031D0,  0.00019D0,  0.00006D0,  0.00003D0,
     &     0.00001D0,  0.00000D0,  0.00000D0,  0.00000D0/
      DATA (FMRS(2,4,I,18),I=1,49)/
     &     3.95423D0,  3.18985D0,  2.57232D0,  2.26740D0,  2.07281D0,
     &     1.93314D0,  1.55464D0,  1.24668D0,  1.09337D0,  0.99486D0,
     &     0.92342D0,  0.72838D0,  0.56689D0,  0.48541D0,  0.43260D0,
     &     0.39429D0,  0.34049D0,  0.28810D0,  0.23344D0,  0.19715D0,
     &     0.14866D0,  0.11602D0,  0.09214D0,  0.07013D0,  0.05399D0,
     &     0.04205D0,  0.03295D0,  0.02591D0,  0.02050D0,  0.01618D0,
     &     0.01266D0,  0.00984D0,  0.00753D0,  0.00565D0,  0.00424D0,
     &     0.00314D0,  0.00221D0,  0.00150D0,  0.00109D0,  0.00072D0,
     &     0.00043D0,  0.00030D0,  0.00018D0,  0.00006D0,  0.00002D0,
     &     0.00001D0,  0.00000D0,  0.00000D0,  0.00000D0/
      DATA (FMRS(2,4,I,19),I=1,49)/
     &     4.48113D0,  3.58253D0,  2.86323D0,  2.51070D0,  2.28676D0,
     &     2.12659D0,  1.69508D0,  1.34718D0,  1.17523D0,  1.06522D0,
     &     0.98559D0,  0.76963D0,  0.59272D0,  0.50431D0,  0.44739D0,
     &     0.40630D0,  0.34895D0,  0.29355D0,  0.23628D0,  0.19863D0,
     &     0.14882D0,  0.11566D0,  0.09156D0,  0.06947D0,  0.05334D0,
     &     0.04144D0,  0.03238D0,  0.02540D0,  0.02000D0,  0.01574D0,
     &     0.01227D0,  0.00950D0,  0.00724D0,  0.00541D0,  0.00404D0,
     &     0.00298D0,  0.00211D0,  0.00142D0,  0.00103D0,  0.00067D0,
     &     0.00041D0,  0.00028D0,  0.00016D0,  0.00006D0,  0.00002D0,
     &     0.00001D0,  0.00000D0,  0.00000D0,  0.00000D0/
      DATA (FMRS(2,4,I,20),I=1,49)/
     &     4.99499D0,  3.96212D0,  3.14196D0,  2.74258D0,  2.48991D0,
     &     2.30973D0,  1.82681D0,  1.44056D0,  1.25085D0,  1.12995D0,
     &     1.04258D0,  0.80704D0,  0.61586D0,  0.52113D0,  0.46048D0,
     &     0.41689D0,  0.35636D0,  0.29827D0,  0.23871D0,  0.19986D0,
     &     0.14892D0,  0.11531D0,  0.09101D0,  0.06887D0,  0.05276D0,
     &     0.04087D0,  0.03186D0,  0.02494D0,  0.01954D0,  0.01534D0,
     &     0.01192D0,  0.00921D0,  0.00699D0,  0.00520D0,  0.00387D0,
     &     0.00284D0,  0.00201D0,  0.00135D0,  0.00099D0,  0.00063D0,
     &     0.00039D0,  0.00027D0,  0.00014D0,  0.00005D0,  0.00002D0,
     &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0/
      DATA (FMRS(2,4,I,21),I=1,49)/
     &     5.50061D0,  4.33261D0,  3.41176D0,  2.96594D0,  2.68491D0,
     &     2.48503D0,  1.95181D0,  1.52837D0,  1.32157D0,  1.19023D0,
     &     1.09549D0,  0.84140D0,  0.63686D0,  0.53627D0,  0.47219D0,
     &     0.42632D0,  0.36291D0,  0.30239D0,  0.24078D0,  0.20086D0,
     &     0.14892D0,  0.11489D0,  0.09045D0,  0.06826D0,  0.05215D0,
     &     0.04031D0,  0.03135D0,  0.02446D0,  0.01914D0,  0.01497D0,
     &     0.01162D0,  0.00892D0,  0.00678D0,  0.00502D0,  0.00373D0,
     &     0.00273D0,  0.00191D0,  0.00128D0,  0.00093D0,  0.00060D0,
     &     0.00037D0,  0.00026D0,  0.00014D0,  0.00005D0,  0.00001D0,
     &     0.00001D0,  0.00000D0,  0.00000D0,  0.00000D0/
      DATA (FMRS(2,4,I,22),I=1,49)/
     &     6.19859D0,  4.83989D0,  3.77815D0,  3.26780D0,  2.94753D0,
     &     2.72049D0,  2.11828D0,  1.64429D0,  1.41443D0,  1.26909D0,
     &     1.16448D0,  0.88574D0,  0.66367D0,  0.55547D0,  0.48697D0,
     &     0.43816D0,  0.37106D0,  0.30748D0,  0.24329D0,  0.20204D0,
     &     0.14885D0,  0.11433D0,  0.08969D0,  0.06745D0,  0.05136D0,
     &     0.03959D0,  0.03069D0,  0.02386D0,  0.01861D0,  0.01451D0,
     &     0.01121D0,  0.00856D0,  0.00649D0,  0.00480D0,  0.00355D0,
     &     0.00258D0,  0.00180D0,  0.00120D0,  0.00087D0,  0.00057D0,
     &     0.00034D0,  0.00024D0,  0.00013D0,  0.00004D0,  0.00001D0,
     &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0/
      DATA (FMRS(2,4,I,23),I=1,49)/
     &     6.91462D0,  5.35579D0,  4.14753D0,  3.57056D0,  3.20996D0,
     &     2.95511D0,  2.28266D0,  1.75769D0,  1.50477D0,  1.34548D0,
     &     1.23109D0,  0.92809D0,  0.68898D0,  0.57345D0,  0.50073D0,
     &     0.44914D0,  0.37855D0,  0.31211D0,  0.24552D0,  0.20305D0,
     &     0.14871D0,  0.11376D0,  0.08894D0,  0.06666D0,  0.05060D0,
     &     0.03890D0,  0.03007D0,  0.02332D0,  0.01811D0,  0.01408D0,
     &     0.01081D0,  0.00824D0,  0.00620D0,  0.00458D0,  0.00337D0,
     &     0.00246D0,  0.00171D0,  0.00112D0,  0.00082D0,  0.00053D0,
     &     0.00032D0,  0.00022D0,  0.00013D0,  0.00004D0,  0.00001D0,
     &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0/
      DATA (FMRS(2,4,I,24),I=1,49)/
     &     7.62855D0,  5.86601D0,  4.50985D0,  3.86607D0,  3.46522D0,
     &     3.18268D0,  2.44073D0,  1.86575D0,  1.59038D0,  1.41758D0,
     &     1.29375D0,  0.96750D0,  0.71223D0,  0.58984D0,  0.51319D0,
     &     0.45902D0,  0.38523D0,  0.31616D0,  0.24739D0,  0.20383D0,
     &     0.14846D0,  0.11312D0,  0.08817D0,  0.06586D0,  0.04986D0,
     &     0.03821D0,  0.02946D0,  0.02275D0,  0.01763D0,  0.01365D0,
     &     0.01046D0,  0.00797D0,  0.00597D0,  0.00439D0,  0.00323D0,
     &     0.00235D0,  0.00162D0,  0.00107D0,  0.00078D0,  0.00051D0,
     &     0.00031D0,  0.00021D0,  0.00012D0,  0.00003D0,  0.00001D0,
     &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0/
      DATA (FMRS(2,4,I,25),I=1,49)/
     &     8.39955D0,  6.41302D0,  4.89545D0,  4.17923D0,  3.73489D0,
     &     3.42253D0,  2.60607D0,  1.97793D0,  1.67884D0,  1.49183D0,
     &     1.35810D0,  1.00761D0,  0.73567D0,  0.60627D0,  0.52562D0,
     &     0.46884D0,  0.39183D0,  0.32012D0,  0.24919D0,  0.20455D0,
     &     0.14818D0,  0.11246D0,  0.08739D0,  0.06506D0,  0.04911D0,
     &     0.03752D0,  0.02885D0,  0.02220D0,  0.01716D0,  0.01324D0,
     &     0.01012D0,  0.00771D0,  0.00575D0,  0.00422D0,  0.00309D0,
     &     0.00225D0,  0.00154D0,  0.00103D0,  0.00074D0,  0.00048D0,
     &     0.00030D0,  0.00020D0,  0.00010D0,  0.00002D0,  0.00001D0,
     &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0/
      DATA (FMRS(2,4,I,26),I=1,49)/
     &     9.19737D0,  6.97494D0,  5.28863D0,  4.49714D0,  4.00779D0,
     &     3.66466D0,  2.77170D0,  2.08938D0,  1.76629D0,  1.56497D0,
     &     1.42130D0,  1.04661D0,  0.75821D0,  0.62194D0,  0.53740D0,
     &     0.47810D0,  0.39797D0,  0.32376D0,  0.25078D0,  0.20510D0,
     &     0.14782D0,  0.11174D0,  0.08657D0,  0.06424D0,  0.04835D0,
     &     0.03684D0,  0.02824D0,  0.02168D0,  0.01670D0,  0.01284D0,
     &     0.00977D0,  0.00742D0,  0.00552D0,  0.00404D0,  0.00296D0,
     &     0.00214D0,  0.00146D0,  0.00097D0,  0.00071D0,  0.00044D0,
     &     0.00028D0,  0.00017D0,  0.00010D0,  0.00003D0,  0.00001D0,
     &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0/
      DATA (FMRS(2,4,I,27),I=1,49)/
     &    10.00116D0,  7.53729D0,  5.67949D0,  4.81192D0,  4.27724D0,
     &     3.90320D0,  2.93374D0,  2.19765D0,  1.85088D0,  1.63549D0,
     &     1.48207D0,  1.08380D0,  0.77950D0,  0.63664D0,  0.54841D0,
     &     0.48671D0,  0.40364D0,  0.32707D0,  0.25218D0,  0.20556D0,
     &     0.14742D0,  0.11104D0,  0.08576D0,  0.06344D0,  0.04762D0,
     &     0.03619D0,  0.02766D0,  0.02119D0,  0.01627D0,  0.01248D0,
     &     0.00947D0,  0.00716D0,  0.00532D0,  0.00389D0,  0.00284D0,
     &     0.00205D0,  0.00139D0,  0.00092D0,  0.00068D0,  0.00042D0,
     &     0.00026D0,  0.00016D0,  0.00009D0,  0.00003D0,  0.00001D0,
     &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0/
      DATA (FMRS(2,4,I,28),I=1,49)/
     &    10.79744D0,  8.09092D0,  6.06186D0,  5.11871D0,  4.53915D0,
     &     4.13458D0,  3.08987D0,  2.30126D0,  1.93148D0,  1.70248D0,
     &     1.53966D0,  1.11875D0,  0.79931D0,  0.65024D0,  0.55853D0,
     &     0.49459D0,  0.40879D0,  0.33003D0,  0.25337D0,  0.20589D0,
     &     0.14698D0,  0.11033D0,  0.08498D0,  0.06267D0,  0.04691D0,
     &     0.03557D0,  0.02711D0,  0.02071D0,  0.01586D0,  0.01214D0,
     &     0.00920D0,  0.00692D0,  0.00514D0,  0.00376D0,  0.00272D0,
     &     0.00196D0,  0.00133D0,  0.00087D0,  0.00064D0,  0.00040D0,
     &     0.00025D0,  0.00016D0,  0.00009D0,  0.00003D0,  0.00001D0,
     &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0/
      DATA (FMRS(2,4,I,29),I=1,49)/
     &    11.63983D0,  8.67317D0,  6.46161D0,  5.43834D0,  4.81133D0,
     &     4.37457D0,  3.25082D0,  2.40738D0,  2.01373D0,  1.77063D0,
     &     1.59811D0,  1.15395D0,  0.81909D0,  0.66374D0,  0.56853D0,
     &     0.50235D0,  0.41381D0,  0.33288D0,  0.25448D0,  0.20616D0,
     &     0.14650D0,  0.10959D0,  0.08417D0,  0.06189D0,  0.04620D0,
     &     0.03495D0,  0.02656D0,  0.02024D0,  0.01545D0,  0.01181D0,
     &     0.00893D0,  0.00670D0,  0.00496D0,  0.00362D0,  0.00261D0,
     &     0.00187D0,  0.00127D0,  0.00083D0,  0.00060D0,  0.00038D0,
     &     0.00023D0,  0.00015D0,  0.00008D0,  0.00003D0,  0.00001D0,
     &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0/
      DATA (FMRS(2,4,I,30),I=1,49)/
     &    12.50504D0,  9.26774D0,  6.86743D0,  5.76168D0,  5.08599D0,
     &     4.61626D0,  3.41191D0,  2.51292D0,  2.09519D0,  1.83795D0,
     &     1.65570D0,  1.18836D0,  0.83825D0,  0.67674D0,  0.57810D0,
     &     0.50972D0,  0.41855D0,  0.33552D0,  0.25546D0,  0.20633D0,
     &     0.14597D0,  0.10882D0,  0.08334D0,  0.06111D0,  0.04550D0,
     &     0.03432D0,  0.02602D0,  0.01977D0,  0.01507D0,  0.01148D0,
     &     0.00865D0,  0.00649D0,  0.00478D0,  0.00347D0,  0.00250D0,
     &     0.00177D0,  0.00121D0,  0.00078D0,  0.00056D0,  0.00036D0,
     &     0.00022D0,  0.00014D0,  0.00008D0,  0.00002D0,  0.00001D0,
     &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0/
      DATA (FMRS(2,4,I,31),I=1,49)/
     &    13.36928D0,  9.85846D0,  7.26844D0,  6.08018D0,  5.35592D0,
     &     4.85338D0,  3.56907D0,  2.61529D0,  2.17393D0,  1.90285D0,
     &     1.71111D0,  1.22123D0,  0.85642D0,  0.68899D0,  0.58709D0,
     &     0.51663D0,  0.42295D0,  0.33794D0,  0.25632D0,  0.20644D0,
     &     0.14544D0,  0.10808D0,  0.08256D0,  0.06036D0,  0.04483D0,
     &     0.03373D0,  0.02551D0,  0.01933D0,  0.01470D0,  0.01117D0,
     &     0.00840D0,  0.00629D0,  0.00462D0,  0.00334D0,  0.00240D0,
     &     0.00170D0,  0.00116D0,  0.00075D0,  0.00053D0,  0.00034D0,
     &     0.00021D0,  0.00014D0,  0.00007D0,  0.00002D0,  0.00001D0,
     &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0/
      DATA (FMRS(2,4,I,32),I=1,49)/
     &    14.21204D0, 10.43149D0,  7.65538D0,  6.38652D0,  5.61495D0,
     &     5.08051D0,  3.71876D0,  2.71221D0,  2.24821D0,  1.96390D0,
     &     1.76311D0,  1.25185D0,  0.87317D0,  0.70020D0,  0.59526D0,
     &     0.52288D0,  0.42687D0,  0.34005D0,  0.25702D0,  0.20645D0,
     &     0.14487D0,  0.10733D0,  0.08179D0,  0.05963D0,  0.04417D0,
     &     0.03317D0,  0.02503D0,  0.01893D0,  0.01436D0,  0.01089D0,
     &     0.00816D0,  0.00610D0,  0.00447D0,  0.00322D0,  0.00232D0,
     &     0.00164D0,  0.00111D0,  0.00072D0,  0.00051D0,  0.00033D0,
     &     0.00020D0,  0.00013D0,  0.00007D0,  0.00002D0,  0.00001D0,
     &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0/
      DATA (FMRS(2,4,I,33),I=1,49)/
     &    15.10980D0, 11.03912D0,  8.06381D0,  6.70901D0,  5.88712D0,
     &     5.31881D0,  3.87508D0,  2.81294D0,  2.32519D0,  2.02704D0,
     &     1.81681D0,  1.28330D0,  0.89029D0,  0.71163D0,  0.60357D0,
     &     0.52922D0,  0.43085D0,  0.34218D0,  0.25771D0,  0.20646D0,
     &     0.14430D0,  0.10659D0,  0.08103D0,  0.05890D0,  0.04353D0,
     &     0.03261D0,  0.02455D0,  0.01854D0,  0.01403D0,  0.01061D0,
     &     0.00794D0,  0.00591D0,  0.00432D0,  0.00310D0,  0.00224D0,
     &     0.00159D0,  0.00107D0,  0.00069D0,  0.00049D0,  0.00032D0,
     &     0.00019D0,  0.00012D0,  0.00006D0,  0.00002D0,  0.00001D0,
     &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0/
      DATA (FMRS(2,4,I,34),I=1,49)/
     &    16.00814D0, 11.64399D0,  8.46821D0,  7.02730D0,  6.15513D0,
     &     5.55303D0,  4.02783D0,  2.91076D0,  2.39965D0,  2.08793D0,
     &     1.86846D0,  1.31328D0,  0.90643D0,  0.72231D0,  0.61128D0,
     &     0.53505D0,  0.43443D0,  0.34403D0,  0.25822D0,  0.20634D0,
     &     0.14366D0,  0.10580D0,  0.08022D0,  0.05817D0,  0.04288D0,
     &     0.03206D0,  0.02408D0,  0.01814D0,  0.01369D0,  0.01034D0,
     &     0.00771D0,  0.00572D0,  0.00418D0,  0.00300D0,  0.00216D0,
     &     0.00152D0,  0.00103D0,  0.00065D0,  0.00048D0,  0.00031D0,
     &     0.00018D0,  0.00012D0,  0.00006D0,  0.00002D0,  0.00001D0,
     &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0/
      DATA (FMRS(2,4,I,35),I=1,49)/
     &    16.90871D0, 12.24779D0,  8.87019D0,  7.34290D0,  6.42039D0,
     &     5.78454D0,  4.17816D0,  3.00661D0,  2.47242D0,  2.14733D0,
     &     1.91876D0,  1.34235D0,  0.92199D0,  0.73258D0,  0.61867D0,
     &     0.54063D0,  0.43786D0,  0.34580D0,  0.25870D0,  0.20622D0,
     &     0.14305D0,  0.10506D0,  0.07947D0,  0.05749D0,  0.04228D0,
     &     0.03154D0,  0.02364D0,  0.01777D0,  0.01338D0,  0.01009D0,
     &     0.00750D0,  0.00555D0,  0.00406D0,  0.00290D0,  0.00208D0,
     &     0.00145D0,  0.00100D0,  0.00062D0,  0.00047D0,  0.00030D0,
     &     0.00017D0,  0.00012D0,  0.00005D0,  0.00002D0,  0.00000D0,
     &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0/
      DATA (FMRS(2,4,I,36),I=1,49)/
     &    17.78739D0, 12.83436D0,  9.25897D0,  7.64732D0,  6.67578D0,
     &     6.00710D0,  4.32199D0,  3.09786D0,  2.54148D0,  2.20357D0,
     &     1.96631D0,  1.36964D0,  0.93649D0,  0.74208D0,  0.62547D0,
     &     0.54573D0,  0.44096D0,  0.34736D0,  0.25907D0,  0.20605D0,
     &     0.14244D0,  0.10433D0,  0.07874D0,  0.05683D0,  0.04170D0,
     &     0.03105D0,  0.02321D0,  0.01741D0,  0.01309D0,  0.00985D0,
     &     0.00731D0,  0.00540D0,  0.00394D0,  0.00282D0,  0.00201D0,
     &     0.00140D0,  0.00096D0,  0.00060D0,  0.00045D0,  0.00029D0,
     &     0.00016D0,  0.00012D0,  0.00005D0,  0.00001D0,  0.00000D0,
     &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0/
      DATA (FMRS(2,4,I,37),I=1,49)/
     &    18.69798D0, 13.43965D0,  9.65843D0,  7.95932D0,  6.93703D0,
     &     6.23444D0,  4.46823D0,  3.19019D0,  2.61115D0,  2.26017D0,
     &     2.01407D0,  1.39688D0,  0.95084D0,  0.75143D0,  0.63213D0,
     &     0.55070D0,  0.44393D0,  0.34881D0,  0.25937D0,  0.20581D0,
     &     0.14178D0,  0.10356D0,  0.07799D0,  0.05614D0,  0.04110D0,
     &     0.03053D0,  0.02278D0,  0.01705D0,  0.01280D0,  0.00961D0,
     &     0.00713D0,  0.00525D0,  0.00382D0,  0.00273D0,  0.00195D0,
     &     0.00136D0,  0.00092D0,  0.00058D0,  0.00043D0,  0.00028D0,
     &     0.00015D0,  0.00011D0,  0.00005D0,  0.00001D0,  0.00000D0,
     &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0/
      DATA (FMRS(2,4,I,38),I=1,49)/
     &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
     &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
     &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
     &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
     &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
     &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
     &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
     &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
     &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
     &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0/
      DATA (FMRS(2,5,I, 1),I=1,49)/
     &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
     &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
     &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
     &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
     &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
     &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
     &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
     &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
     &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
     &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0/
      DATA (FMRS(2,5,I, 2),I=1,49)/
     &     0.00003D0,  0.00002D0,  0.00002D0,  0.00002D0,  0.00002D0,
     &     0.00002D0,  0.00002D0,  0.00002D0,  0.00002D0,  0.00002D0,
     &     0.00002D0,  0.00002D0,  0.00002D0,  0.00002D0,  0.00002D0,
     &     0.00002D0,  0.00002D0,  0.00001D0,  0.00001D0,  0.00001D0,
     &     0.00001D0,  0.00001D0,  0.00001D0,  0.00001D0,  0.00001D0,
     &     0.00001D0,  0.00001D0,  0.00001D0,  0.00001D0,  0.00001D0,
     &     0.00001D0,  0.00001D0,  0.00001D0,  0.00001D0,  0.00001D0,
     &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
     &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
     &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0/
      DATA (FMRS(2,5,I, 3),I=1,49)/
     &     0.02821D0,  0.02609D0,  0.02411D0,  0.02301D0,  0.02226D0,
     &     0.02169D0,  0.01996D0,  0.01827D0,  0.01727D0,  0.01654D0,
     &     0.01595D0,  0.01400D0,  0.01174D0,  0.01027D0,  0.00917D0,
     &     0.00829D0,  0.00696D0,  0.00558D0,  0.00415D0,  0.00329D0,
     &     0.00239D0,  0.00200D0,  0.00182D0,  0.00170D0,  0.00161D0,
     &     0.00151D0,  0.00140D0,  0.00127D0,  0.00113D0,  0.00099D0,
     &     0.00084D0,  0.00071D0,  0.00058D0,  0.00047D0,  0.00038D0,
     &     0.00029D0,  0.00023D0,  0.00017D0,  0.00013D0,  0.00009D0,
     &     0.00006D0,  0.00004D0,  0.00003D0,  0.00001D0,  0.00000D0,
     &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0/
      DATA (FMRS(2,5,I, 4),I=1,49)/
     &     0.07423D0,  0.06794D0,  0.06215D0,  0.05896D0,  0.05679D0,
     &     0.05514D0,  0.05023D0,  0.04550D0,  0.04276D0,  0.04079D0,
     &     0.03919D0,  0.03404D0,  0.02827D0,  0.02460D0,  0.02188D0,
     &     0.01974D0,  0.01650D0,  0.01320D0,  0.00980D0,  0.00778D0,
     &     0.00567D0,  0.00475D0,  0.00430D0,  0.00399D0,  0.00376D0,
     &     0.00351D0,  0.00322D0,  0.00290D0,  0.00256D0,  0.00223D0,
     &     0.00189D0,  0.00158D0,  0.00129D0,  0.00104D0,  0.00083D0,
     &     0.00064D0,  0.00049D0,  0.00037D0,  0.00027D0,  0.00020D0,
     &     0.00014D0,  0.00009D0,  0.00006D0,  0.00002D0,  0.00000D0,
     &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0/
      DATA (FMRS(2,5,I, 5),I=1,49)/
     &     0.13335D0,  0.12014D0,  0.10818D0,  0.10170D0,  0.09731D0,
     &     0.09401D0,  0.08430D0,  0.07519D0,  0.07001D0,  0.06635D0,
     &     0.06344D0,  0.05426D0,  0.04442D0,  0.03837D0,  0.03396D0,
     &     0.03053D0,  0.02541D0,  0.02025D0,  0.01501D0,  0.01192D0,
     &     0.00870D0,  0.00726D0,  0.00654D0,  0.00602D0,  0.00561D0,
     &     0.00519D0,  0.00472D0,  0.00422D0,  0.00370D0,  0.00319D0,
     &     0.00269D0,  0.00224D0,  0.00183D0,  0.00146D0,  0.00116D0,
     &     0.00089D0,  0.00068D0,  0.00051D0,  0.00038D0,  0.00027D0,
     &     0.00019D0,  0.00013D0,  0.00008D0,  0.00003D0,  0.00000D0,
     &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0/
      DATA (FMRS(2,5,I, 6),I=1,49)/
     &     0.20163D0,  0.17920D0,  0.15918D0,  0.14846D0,  0.14125D0,
     &     0.13587D0,  0.12018D0,  0.10574D0,  0.09768D0,  0.09205D0,
     &     0.08763D0,  0.07395D0,  0.05979D0,  0.05130D0,  0.04521D0,
     &     0.04052D0,  0.03360D0,  0.02669D0,  0.01976D0,  0.01569D0,
     &     0.01145D0,  0.00954D0,  0.00855D0,  0.00780D0,  0.00720D0,
     &     0.00661D0,  0.00597D0,  0.00530D0,  0.00461D0,  0.00396D0,
     &     0.00333D0,  0.00275D0,  0.00223D0,  0.00178D0,  0.00140D0,
     &     0.00108D0,  0.00082D0,  0.00061D0,  0.00045D0,  0.00032D0,
     &     0.00022D0,  0.00015D0,  0.00010D0,  0.00003D0,  0.00000D0,
     &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0/
      DATA (FMRS(2,5,I, 7),I=1,49)/
     &     0.27774D0,  0.24395D0,  0.21415D0,  0.19835D0,  0.18780D0,
     &     0.17996D0,  0.15730D0,  0.13677D0,  0.12547D0,  0.11766D0,
     &     0.11157D0,  0.09303D0,  0.07437D0,  0.06341D0,  0.05566D0,
     &     0.04974D0,  0.04109D0,  0.03255D0,  0.02405D0,  0.01909D0,
     &     0.01394D0,  0.01158D0,  0.01033D0,  0.00936D0,  0.00857D0,
     &     0.00780D0,  0.00699D0,  0.00616D0,  0.00533D0,  0.00455D0,
     &     0.00380D0,  0.00313D0,  0.00253D0,  0.00201D0,  0.00157D0,
     &     0.00121D0,  0.00091D0,  0.00068D0,  0.00050D0,  0.00036D0,
     &     0.00024D0,  0.00016D0,  0.00011D0,  0.00003D0,  0.00000D0,
     &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0/
      DATA (FMRS(2,5,I, 8),I=1,49)/
     &     0.37644D0,  0.32674D0,  0.28346D0,  0.26073D0,  0.24565D0,
     &     0.23449D0,  0.20256D0,  0.17404D0,  0.15854D0,  0.14793D0,
     &     0.13972D0,  0.11511D0,  0.09095D0,  0.07707D0,  0.06738D0,
     &     0.06004D0,  0.04941D0,  0.03901D0,  0.02877D0,  0.02283D0,
     &     0.01667D0,  0.01381D0,  0.01226D0,  0.01101D0,  0.01000D0,
     &     0.00902D0,  0.00803D0,  0.00703D0,  0.00604D0,  0.00513D0,
     &     0.00426D0,  0.00349D0,  0.00280D0,  0.00222D0,  0.00173D0,
     &     0.00132D0,  0.00099D0,  0.00074D0,  0.00054D0,  0.00039D0,
     &     0.00026D0,  0.00017D0,  0.00011D0,  0.00003D0,  0.00000D0,
     &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0/
      DATA (FMRS(2,5,I, 9),I=1,49)/
     &     0.47784D0,  0.41072D0,  0.35284D0,  0.32270D0,  0.30279D0,
     &     0.28813D0,  0.24646D0,  0.20968D0,  0.18991D0,  0.17647D0,
     &     0.16612D0,  0.13548D0,  0.10603D0,  0.08938D0,  0.07787D0,
     &     0.06921D0,  0.05678D0,  0.04472D0,  0.03292D0,  0.02612D0,
     &     0.01906D0,  0.01575D0,  0.01392D0,  0.01241D0,  0.01119D0,
     &     0.01003D0,  0.00887D0,  0.00772D0,  0.00660D0,  0.00557D0,
     &     0.00461D0,  0.00376D0,  0.00301D0,  0.00237D0,  0.00184D0,
     &     0.00140D0,  0.00105D0,  0.00077D0,  0.00057D0,  0.00041D0,
     &     0.00027D0,  0.00018D0,  0.00011D0,  0.00003D0,  0.00000D0,
     &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0/
      DATA (FMRS(2,5,I,10),I=1,49)/
     &     0.58781D0,  0.50078D0,  0.42641D0,  0.38796D0,  0.36269D0,
     &     0.34414D0,  0.29176D0,  0.24601D0,  0.22164D0,  0.20518D0,
     &     0.19257D0,  0.15561D0,  0.12070D0,  0.10126D0,  0.08794D0,
     &     0.07799D0,  0.06379D0,  0.05011D0,  0.03684D0,  0.02922D0,
     &     0.02130D0,  0.01755D0,  0.01544D0,  0.01368D0,  0.01225D0,
     &     0.01090D0,  0.00959D0,  0.00830D0,  0.00706D0,  0.00594D0,
     &     0.00489D0,  0.00397D0,  0.00316D0,  0.00248D0,  0.00192D0,
     &     0.00146D0,  0.00109D0,  0.00080D0,  0.00059D0,  0.00042D0,
     &     0.00027D0,  0.00018D0,  0.00012D0,  0.00003D0,  0.00000D0,
     &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0/
      DATA (FMRS(2,5,I,11),I=1,49)/
     &     0.68602D0,  0.58051D0,  0.49095D0,  0.44491D0,  0.41476D0,
     &     0.39269D0,  0.33066D0,  0.27690D0,  0.24847D0,  0.22936D0,
     &     0.21477D0,  0.17232D0,  0.13275D0,  0.11095D0,  0.09613D0,
     &     0.08510D0,  0.06944D0,  0.05445D0,  0.03997D0,  0.03169D0,
     &     0.02308D0,  0.01898D0,  0.01663D0,  0.01466D0,  0.01306D0,
     &     0.01157D0,  0.01013D0,  0.00872D0,  0.00740D0,  0.00620D0,
     &     0.00508D0,  0.00411D0,  0.00327D0,  0.00256D0,  0.00197D0,
     &     0.00149D0,  0.00111D0,  0.00081D0,  0.00060D0,  0.00042D0,
     &     0.00028D0,  0.00018D0,  0.00012D0,  0.00003D0,  0.00000D0,
     &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0/
      DATA (FMRS(2,5,I,12),I=1,49)/
     &     0.92772D0,  0.77438D0,  0.64603D0,  0.58078D0,  0.53835D0,
     &     0.50746D0,  0.42147D0,  0.34811D0,  0.30983D0,  0.28433D0,
     &     0.26501D0,  0.20960D0,  0.15924D0,  0.13208D0,  0.11385D0,
     &     0.10043D0,  0.08155D0,  0.06370D0,  0.04663D0,  0.03692D0,
     &     0.02683D0,  0.02195D0,  0.01909D0,  0.01665D0,  0.01467D0,
     &     0.01287D0,  0.01115D0,  0.00952D0,  0.00801D0,  0.00666D0,
     &     0.00542D0,  0.00436D0,  0.00344D0,  0.00268D0,  0.00205D0,
     &     0.00155D0,  0.00115D0,  0.00083D0,  0.00061D0,  0.00043D0,
     &     0.00028D0,  0.00018D0,  0.00011D0,  0.00003D0,  0.00000D0,
     &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0/
      DATA (FMRS(2,5,I,13),I=1,49)/
     &     1.17595D0,  0.97076D0,  0.80093D0,  0.71538D0,  0.66007D0,
     &     0.61997D0,  0.50921D0,  0.41588D0,  0.36771D0,  0.33586D0,
     &     0.31184D0,  0.24377D0,  0.18310D0,  0.15092D0,  0.12956D0,
     &     0.11394D0,  0.09216D0,  0.07174D0,  0.05238D0,  0.04143D0,
     &     0.03003D0,  0.02446D0,  0.02114D0,  0.01827D0,  0.01595D0,
     &     0.01387D0,  0.01193D0,  0.01011D0,  0.00845D0,  0.00698D0,
     &     0.00565D0,  0.00451D0,  0.00355D0,  0.00275D0,  0.00209D0,
     &     0.00157D0,  0.00116D0,  0.00084D0,  0.00061D0,  0.00043D0,
     &     0.00028D0,  0.00018D0,  0.00011D0,  0.00003D0,  0.00000D0,
     &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0/
      DATA (FMRS(2,5,I,14),I=1,49)/
     &     1.49839D0,  1.22261D0,  0.99703D0,  0.88447D0,  0.81213D0,
     &     0.75993D0,  0.61688D0,  0.49791D0,  0.43718D0,  0.39731D0,
     &     0.36742D0,  0.28369D0,  0.21052D0,  0.17237D0,  0.14732D0,
     &     0.12915D0,  0.10402D0,  0.08067D0,  0.05873D0,  0.04638D0,
     &     0.03352D0,  0.02715D0,  0.02331D0,  0.01995D0,  0.01725D0,
     &     0.01486D0,  0.01267D0,  0.01065D0,  0.00884D0,  0.00725D0,
     &     0.00583D0,  0.00463D0,  0.00362D0,  0.00279D0,  0.00211D0,
     &     0.00158D0,  0.00116D0,  0.00083D0,  0.00061D0,  0.00043D0,
     &     0.00027D0,  0.00018D0,  0.00011D0,  0.00003D0,  0.00000D0,
     &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0/
      DATA (FMRS(2,5,I,15),I=1,49)/
     &     1.87945D0,  1.51634D0,  1.22268D0,  1.07750D0,  0.98475D0,
     &     0.91809D0,  0.73686D0,  0.58798D0,  0.51279D0,  0.46377D0,
     &     0.42722D0,  0.32591D0,  0.23902D0,  0.19443D0,  0.16545D0,
     &     0.14459D0,  0.11596D0,  0.08960D0,  0.06503D0,  0.05127D0,
     &     0.03691D0,  0.02973D0,  0.02534D0,  0.02147D0,  0.01838D0,
     &     0.01569D0,  0.01327D0,  0.01107D0,  0.00912D0,  0.00743D0,
     &     0.00594D0,  0.00469D0,  0.00364D0,  0.00279D0,  0.00210D0,
     &     0.00156D0,  0.00114D0,  0.00082D0,  0.00059D0,  0.00041D0,
     &     0.00026D0,  0.00017D0,  0.00010D0,  0.00003D0,  0.00000D0,
     &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0/
      DATA (FMRS(2,5,I,16),I=1,49)/
     &     2.27429D0,  1.81716D0,  1.45106D0,  1.27151D0,  1.15736D0,
     &     1.07564D0,  0.85491D0,  0.67549D0,  0.58568D0,  0.52749D0,
     &     0.48429D0,  0.36563D0,  0.26542D0,  0.21469D0,  0.18200D0,
     &     0.15862D0,  0.12673D0,  0.09760D0,  0.07063D0,  0.05559D0,
     &     0.03988D0,  0.03195D0,  0.02705D0,  0.02273D0,  0.01930D0,
     &     0.01634D0,  0.01371D0,  0.01136D0,  0.00930D0,  0.00753D0,
     &     0.00599D0,  0.00470D0,  0.00364D0,  0.00277D0,  0.00208D0,
     &     0.00154D0,  0.00112D0,  0.00080D0,  0.00058D0,  0.00040D0,
     &     0.00025D0,  0.00016D0,  0.00010D0,  0.00003D0,  0.00000D0,
     &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0/
      DATA (FMRS(2,5,I,17),I=1,49)/
     &     2.72539D0,  2.15724D0,  1.70653D0,  1.48715D0,  1.34837D0,
     &     1.24937D0,  0.98364D0,  0.76983D0,  0.66373D0,  0.59537D0,
     &     0.54484D0,  0.40724D0,  0.29272D0,  0.23547D0,  0.19888D0,
     &     0.17287D0,  0.13761D0,  0.10564D0,  0.07622D0,  0.05987D0,
     &     0.04278D0,  0.03409D0,  0.02869D0,  0.02390D0,  0.02012D0,
     &     0.01691D0,  0.01408D0,  0.01159D0,  0.00943D0,  0.00759D0,
     &     0.00600D0,  0.00469D0,  0.00361D0,  0.00273D0,  0.00204D0,
     &     0.00151D0,  0.00109D0,  0.00078D0,  0.00056D0,  0.00039D0,
     &     0.00024D0,  0.00015D0,  0.00009D0,  0.00003D0,  0.00000D0,
     &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0/
      DATA (FMRS(2,5,I,18),I=1,49)/
     &     3.13641D0,  2.46418D0,  1.93488D0,  1.67881D0,  1.51744D0,
     &     1.40264D0,  1.09608D0,  0.85138D0,  0.73076D0,  0.65340D0,
     &     0.59642D0,  0.44225D0,  0.31539D0,  0.25259D0,  0.21272D0,
     &     0.18450D0,  0.14644D0,  0.11211D0,  0.08069D0,  0.06328D0,
     &     0.04506D0,  0.03575D0,  0.02993D0,  0.02476D0,  0.02070D0,
     &     0.01729D0,  0.01432D0,  0.01172D0,  0.00949D0,  0.00760D0,
     &     0.00598D0,  0.00466D0,  0.00357D0,  0.00269D0,  0.00201D0,
     &     0.00147D0,  0.00106D0,  0.00075D0,  0.00054D0,  0.00038D0,
     &     0.00023D0,  0.00015D0,  0.00009D0,  0.00003D0,  0.00000D0,
     &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0/
      DATA (FMRS(2,5,I,19),I=1,49)/
     &     3.68153D0,  2.86757D0,  2.23222D0,  1.92702D0,  1.73553D0,
     &     1.59976D0,  1.23927D0,  0.95419D0,  0.81477D0,  0.72581D0,
     &     0.66053D0,  0.48527D0,  0.34292D0,  0.27324D0,  0.22931D0,
     &     0.19839D0,  0.15691D0,  0.11975D0,  0.08593D0,  0.06725D0,
     &     0.04768D0,  0.03762D0,  0.03130D0,  0.02569D0,  0.02130D0,
     &     0.01766D0,  0.01453D0,  0.01182D0,  0.00951D0,  0.00757D0,
     &     0.00594D0,  0.00459D0,  0.00350D0,  0.00264D0,  0.00195D0,
     &     0.00143D0,  0.00103D0,  0.00072D0,  0.00052D0,  0.00036D0,
     &     0.00022D0,  0.00014D0,  0.00008D0,  0.00003D0,  0.00000D0,
     &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0/
      DATA (FMRS(2,5,I,20),I=1,49)/
     &     4.21665D0,  3.26014D0,  2.51906D0,  2.16522D0,  1.94405D0,
     &     1.78768D0,  1.37455D0,  1.05042D0,  0.89295D0,  0.79293D0,
     &     0.71977D0,  0.52460D0,  0.36780D0,  0.29178D0,  0.24415D0,
     &     0.21076D0,  0.16620D0,  0.12648D0,  0.09052D0,  0.07070D0,
     &     0.04993D0,  0.03920D0,  0.03244D0,  0.02644D0,  0.02178D0,
     &     0.01794D0,  0.01467D0,  0.01187D0,  0.00951D0,  0.00753D0,
     &     0.00588D0,  0.00453D0,  0.00344D0,  0.00258D0,  0.00191D0,
     &     0.00139D0,  0.00099D0,  0.00070D0,  0.00050D0,  0.00035D0,
     &     0.00021D0,  0.00013D0,  0.00008D0,  0.00003D0,  0.00000D0,
     &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0/
      DATA (FMRS(2,5,I,21),I=1,49)/
     &     4.73651D0,  3.63839D0,  2.79314D0,  2.39169D0,  2.14159D0,
     &     1.96521D0,  1.50121D0,  1.13968D0,  0.96506D0,  0.85456D0,
     &     0.77398D0,  0.56020D0,  0.39006D0,  0.30823D0,  0.25724D0,
     &     0.22164D0,  0.17431D0,  0.13232D0,  0.09445D0,  0.07364D0,
     &     0.05181D0,  0.04050D0,  0.03335D0,  0.02701D0,  0.02212D0,
     &     0.01812D0,  0.01474D0,  0.01187D0,  0.00946D0,  0.00747D0,
     &     0.00580D0,  0.00446D0,  0.00337D0,  0.00252D0,  0.00185D0,
     &     0.00135D0,  0.00096D0,  0.00068D0,  0.00049D0,  0.00034D0,
     &     0.00020D0,  0.00013D0,  0.00007D0,  0.00003D0,  0.00000D0,
     &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0/
      DATA (FMRS(2,5,I,22),I=1,49)/
     &     5.45753D0,  4.15887D0,  3.16726D0,  2.69936D0,  2.40907D0,
     &     2.20495D0,  1.67083D0,  1.25820D0,  1.06032D0,  0.93568D0,
     &     0.84511D0,  0.60646D0,  0.41869D0,  0.32928D0,  0.27391D0,
     &     0.23544D0,  0.18455D0,  0.13964D0,  0.09936D0,  0.07728D0,
     &     0.05411D0,  0.04206D0,  0.03442D0,  0.02766D0,  0.02248D0,
     &     0.01829D0,  0.01478D0,  0.01184D0,  0.00938D0,  0.00736D0,
     &     0.00570D0,  0.00435D0,  0.00328D0,  0.00244D0,  0.00179D0,
     &     0.00129D0,  0.00092D0,  0.00065D0,  0.00046D0,  0.00032D0,
     &     0.00019D0,  0.00012D0,  0.00007D0,  0.00003D0,  0.00000D0,
     &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0/
      DATA (FMRS(2,5,I,23),I=1,49)/
     &     6.19783D0,  4.68879D0,  3.54494D0,  3.00840D0,  2.67675D0,
     &     2.44420D0,  1.83862D0,  1.37436D0,  1.15316D0,  1.01443D0,
     &     0.91394D0,  0.65074D0,  0.44579D0,  0.34906D0,  0.28951D0,
     &     0.24830D0,  0.19403D0,  0.14639D0,  0.10384D0,  0.08058D0,
     &     0.05616D0,  0.04343D0,  0.03534D0,  0.02820D0,  0.02276D0,
     &     0.01841D0,  0.01478D0,  0.01177D0,  0.00929D0,  0.00725D0,
     &     0.00558D0,  0.00425D0,  0.00319D0,  0.00236D0,  0.00173D0,
     &     0.00124D0,  0.00088D0,  0.00062D0,  0.00044D0,  0.00031D0,
     &     0.00018D0,  0.00011D0,  0.00007D0,  0.00003D0,  0.00000D0,
     &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0/
      DATA (FMRS(2,5,I,24),I=1,49)/
     &     6.92966D0,  5.20839D0,  3.91218D0,  3.30740D0,  2.93482D0,
     &     2.67420D0,  1.99847D0,  1.48399D0,  1.24028D0,  1.08801D0,
     &     0.97803D0,  0.69152D0,  0.47043D0,  0.36691D0,  0.30350D0,
     &     0.25978D0,  0.20243D0,  0.15231D0,  0.10773D0,  0.08341D0,
     &     0.05788D0,  0.04454D0,  0.03605D0,  0.02858D0,  0.02293D0,
     &     0.01844D0,  0.01473D0,  0.01167D0,  0.00917D0,  0.00713D0,
     &     0.00547D0,  0.00415D0,  0.00310D0,  0.00229D0,  0.00167D0,
     &     0.00120D0,  0.00085D0,  0.00059D0,  0.00043D0,  0.00030D0,
     &     0.00017D0,  0.00011D0,  0.00006D0,  0.00003D0,  0.00000D0,
     &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0/
      DATA (FMRS(2,5,I,25),I=1,49)/
     &     7.72396D0,  5.76848D0,  4.30532D0,  3.62618D0,  3.20915D0,
     &     2.91815D0,  2.16681D0,  1.59861D0,  1.33097D0,  1.16435D0,
     &     1.04435D0,  0.73337D0,  0.49551D0,  0.38498D0,  0.31761D0,
     &     0.27133D0,  0.21084D0,  0.15821D0,  0.11158D0,  0.08620D0,
     &     0.05955D0,  0.04560D0,  0.03673D0,  0.02893D0,  0.02307D0,
     &     0.01845D0,  0.01466D0,  0.01156D0,  0.00904D0,  0.00700D0,
     &     0.00535D0,  0.00404D0,  0.00301D0,  0.00221D0,  0.00161D0,
     &     0.00115D0,  0.00081D0,  0.00057D0,  0.00041D0,  0.00028D0,
     &     0.00017D0,  0.00010D0,  0.00006D0,  0.00003D0,  0.00000D0,
     &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0/
      DATA (FMRS(2,5,I,26),I=1,49)/
     &     8.54145D0,  6.34073D0,  4.70401D0,  3.94803D0,  3.48525D0,
     &     3.16305D0,  2.33446D0,  1.71181D0,  1.42007D0,  1.23908D0,
     &     1.10907D0,  0.77380D0,  0.51947D0,  0.40212D0,  0.33092D0,
     &     0.28218D0,  0.21869D0,  0.16367D0,  0.11510D0,  0.08871D0,
     &     0.06103D0,  0.04651D0,  0.03727D0,  0.02918D0,  0.02314D0,
     &     0.01840D0,  0.01456D0,  0.01142D0,  0.00889D0,  0.00686D0,
     &     0.00522D0,  0.00393D0,  0.00292D0,  0.00214D0,  0.00155D0,
     &     0.00111D0,  0.00078D0,  0.00054D0,  0.00039D0,  0.00027D0,
     &     0.00016D0,  0.00009D0,  0.00005D0,  0.00003D0,  0.00000D0,
     &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0/
      DATA (FMRS(2,5,I,27),I=1,49)/
     &     9.36625D0,  6.91445D0,  5.10115D0,  4.26741D0,  3.75848D0,
     &     3.40490D0,  2.49891D0,  1.82207D0,  1.50649D0,  1.31134D0,
     &     1.17150D0,  0.81249D0,  0.54219D0,  0.41829D0,  0.34343D0,
     &     0.29234D0,  0.22601D0,  0.16873D0,  0.11834D0,  0.09101D0,
     &     0.06235D0,  0.04731D0,  0.03774D0,  0.02938D0,  0.02318D0,
     &     0.01834D0,  0.01444D0,  0.01128D0,  0.00875D0,  0.00672D0,
     &     0.00510D0,  0.00383D0,  0.00283D0,  0.00207D0,  0.00150D0,
     &     0.00107D0,  0.00075D0,  0.00052D0,  0.00038D0,  0.00026D0,
     &     0.00015D0,  0.00009D0,  0.00005D0,  0.00003D0,  0.00000D0,
     &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0/
      DATA (FMRS(2,5,I,28),I=1,49)/
     &    10.18132D0,  7.47793D0,  5.48877D0,  4.57798D0,  4.02345D0,
     &     3.63894D0,  2.65699D0,  1.92733D0,  1.58864D0,  1.37981D0,
     &     1.23051D0,  0.84875D0,  0.56329D0,  0.43322D0,  0.35493D0,
     &     0.30165D0,  0.23267D0,  0.17330D0,  0.12123D0,  0.09305D0,
     &     0.06349D0,  0.04798D0,  0.03811D0,  0.02952D0,  0.02317D0,
     &     0.01825D0,  0.01431D0,  0.01114D0,  0.00861D0,  0.00659D0,
     &     0.00498D0,  0.00373D0,  0.00275D0,  0.00201D0,  0.00145D0,
     &     0.00103D0,  0.00072D0,  0.00050D0,  0.00036D0,  0.00026D0,
     &     0.00014D0,  0.00008D0,  0.00005D0,  0.00003D0,  0.00000D0,
     &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0/
      DATA (FMRS(2,5,I,29),I=1,49)/
     &    11.04388D0,  8.07089D0,  5.89435D0,  4.90182D0,  4.29909D0,
     &     3.88193D0,  2.82014D0,  2.03528D0,  1.67258D0,  1.44958D0,
     &     1.29048D0,  0.88533D0,  0.58442D0,  0.44808D0,  0.36634D0,
     &     0.31085D0,  0.23922D0,  0.17778D0,  0.12404D0,  0.09501D0,
     &     0.06457D0,  0.04859D0,  0.03843D0,  0.02962D0,  0.02314D0,
     &     0.01814D0,  0.01416D0,  0.01098D0,  0.00846D0,  0.00645D0,
     &     0.00486D0,  0.00363D0,  0.00267D0,  0.00194D0,  0.00140D0,
     &     0.00099D0,  0.00069D0,  0.00048D0,  0.00035D0,  0.00025D0,
     &     0.00014D0,  0.00008D0,  0.00005D0,  0.00003D0,  0.00000D0,
     &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0/
      DATA (FMRS(2,5,I,30),I=1,49)/
     &    11.92777D0,  8.67505D0,  6.30518D0,  5.22873D0,  4.57663D0,
     &     4.12613D0,  2.98306D0,  2.14237D0,  1.75551D0,  1.51831D0,
     &     1.34943D0,  0.92100D0,  0.60483D0,  0.46237D0,  0.37725D0,
     &     0.31962D0,  0.24543D0,  0.18198D0,  0.12665D0,  0.09681D0,
     &     0.06554D0,  0.04912D0,  0.03869D0,  0.02967D0,  0.02307D0,
     &     0.01801D0,  0.01401D0,  0.01082D0,  0.00830D0,  0.00632D0,
     &     0.00475D0,  0.00353D0,  0.00259D0,  0.00188D0,  0.00135D0,
     &     0.00095D0,  0.00066D0,  0.00047D0,  0.00034D0,  0.00024D0,
     &     0.00014D0,  0.00008D0,  0.00004D0,  0.00002D0,  0.00000D0,
     &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0/
      DATA (FMRS(2,5,I,31),I=1,49)/
     &    12.81161D0,  9.27611D0,  6.71181D0,  5.55130D0,  4.84990D0,
     &     4.36615D0,  3.14234D0,  2.24650D0,  1.83587D0,  1.58474D0,
     &     1.40629D0,  0.95519D0,  0.62425D0,  0.47590D0,  0.38756D0,
     &     0.32788D0,  0.25125D0,  0.18591D0,  0.12907D0,  0.09846D0,
     &     0.06642D0,  0.04959D0,  0.03891D0,  0.02970D0,  0.02299D0,
     &     0.01788D0,  0.01385D0,  0.01067D0,  0.00816D0,  0.00619D0,
     &     0.00464D0,  0.00344D0,  0.00252D0,  0.00182D0,  0.00130D0,
     &     0.00092D0,  0.00064D0,  0.00045D0,  0.00033D0,  0.00023D0,
     &     0.00013D0,  0.00007D0,  0.00004D0,  0.00002D0,  0.00000D0,
     &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0/
      DATA (FMRS(2,5,I,32),I=1,49)/
     &    13.67059D0,  9.85720D0,  7.10279D0,  5.86046D0,  5.11119D0,
     &     4.59523D0,  3.29346D0,  2.34466D0,  1.91134D0,  1.64694D0,
     &     1.45941D0,  0.98687D0,  0.64209D0,  0.48825D0,  0.39691D0,
     &     0.33535D0,  0.25648D0,  0.18940D0,  0.13119D0,  0.09990D0,
     &     0.06714D0,  0.04995D0,  0.03906D0,  0.02968D0,  0.02289D0,
     &     0.01773D0,  0.01369D0,  0.01051D0,  0.00801D0,  0.00606D0,
     &     0.00453D0,  0.00335D0,  0.00245D0,  0.00177D0,  0.00126D0,
     &     0.00089D0,  0.00062D0,  0.00043D0,  0.00032D0,  0.00023D0,
     &     0.00013D0,  0.00007D0,  0.00004D0,  0.00002D0,  0.00000D0,
     &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0/
      DATA (FMRS(2,5,I,33),I=1,49)/
     &    14.58850D0, 10.47558D0,  7.51716D0,  6.18731D0,  5.38695D0,
     &     4.83668D0,  3.45207D0,  2.44727D0,  1.99002D0,  1.71168D0,
     &     1.51462D0,  1.01965D0,  0.66046D0,  0.50094D0,  0.40651D0,
     &     0.34300D0,  0.26182D0,  0.19296D0,  0.13335D0,  0.10136D0,
     &     0.06788D0,  0.05032D0,  0.03921D0,  0.02967D0,  0.02278D0,
     &     0.01759D0,  0.01353D0,  0.01035D0,  0.00787D0,  0.00594D0,
     &     0.00443D0,  0.00327D0,  0.00238D0,  0.00172D0,  0.00122D0,
     &     0.00086D0,  0.00060D0,  0.00042D0,  0.00031D0,  0.00022D0,
     &     0.00013D0,  0.00007D0,  0.00004D0,  0.00002D0,  0.00000D0,
     &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0/
      DATA (FMRS(2,5,I,34),I=1,49)/
     &    15.50215D0, 11.08776D0,  7.92505D0,  6.50796D0,  5.65681D0,
     &     5.07248D0,  3.60600D0,  2.54615D0,  2.06552D0,  1.77359D0,
     &     1.56726D0,  1.05062D0,  0.67763D0,  0.51270D0,  0.41535D0,
     &     0.35001D0,  0.26666D0,  0.19615D0,  0.13524D0,  0.10260D0,
     &     0.06847D0,  0.05058D0,  0.03928D0,  0.02960D0,  0.02264D0,
     &     0.01742D0,  0.01336D0,  0.01019D0,  0.00772D0,  0.00581D0,
     &     0.00432D0,  0.00318D0,  0.00232D0,  0.00166D0,  0.00118D0,
     &     0.00083D0,  0.00058D0,  0.00041D0,  0.00030D0,  0.00022D0,
     &     0.00013D0,  0.00007D0,  0.00004D0,  0.00002D0,  0.00000D0,
     &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0/
      DATA (FMRS(2,5,I,35),I=1,49)/
     &    16.42021D0, 11.70052D0,  8.33176D0,  6.82695D0,  5.92484D0,
     &     5.30641D0,  3.75809D0,  2.64348D0,  2.13966D0,  1.83429D0,
     &     1.61881D0,  1.08081D0,  0.69429D0,  0.52409D0,  0.42389D0,
     &     0.35678D0,  0.27133D0,  0.19921D0,  0.13706D0,  0.10380D0,
     &     0.06904D0,  0.05083D0,  0.03934D0,  0.02953D0,  0.02251D0,
     &     0.01726D0,  0.01320D0,  0.01004D0,  0.00759D0,  0.00569D0,
     &     0.00422D0,  0.00310D0,  0.00225D0,  0.00162D0,  0.00115D0,
     &     0.00080D0,  0.00056D0,  0.00039D0,  0.00029D0,  0.00021D0,
     &     0.00013D0,  0.00007D0,  0.00004D0,  0.00002D0,  0.00000D0,
     &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0/
      DATA (FMRS(2,5,I,36),I=1,49)/
     &    17.31499D0, 12.29519D0,  8.72473D0,  7.13436D0,  6.18265D0,
     &     5.53107D0,  3.90347D0,  2.73604D0,  2.20994D0,  1.89170D0,
     &     1.66747D0,  1.10914D0,  0.70980D0,  0.53464D0,  0.43178D0,
     &     0.36300D0,  0.27560D0,  0.20200D0,  0.13869D0,  0.10485D0,
     &     0.06952D0,  0.05103D0,  0.03937D0,  0.02945D0,  0.02237D0,
     &     0.01710D0,  0.01303D0,  0.00989D0,  0.00746D0,  0.00558D0,
     &     0.00413D0,  0.00303D0,  0.00220D0,  0.00157D0,  0.00111D0,
     &     0.00078D0,  0.00054D0,  0.00038D0,  0.00028D0,  0.00021D0,
     &     0.00013D0,  0.00007D0,  0.00004D0,  0.00002D0,  0.00000D0,
     &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0/
      DATA (FMRS(2,5,I,37),I=1,49)/
     &    18.24071D0, 12.90782D0,  9.12782D0,  7.44886D0,  6.44591D0,
     &     5.76014D0,  4.05101D0,  2.82949D0,  2.28068D0,  1.94934D0,
     &     1.71624D0,  1.13734D0,  0.72513D0,  0.54501D0,  0.43949D0,
     &     0.36907D0,  0.27974D0,  0.20467D0,  0.14023D0,  0.10583D0,
     &     0.06996D0,  0.05118D0,  0.03937D0,  0.02934D0,  0.02221D0,
     &     0.01693D0,  0.01286D0,  0.00973D0,  0.00732D0,  0.00547D0,
     &     0.00404D0,  0.00296D0,  0.00214D0,  0.00153D0,  0.00108D0,
     &     0.00076D0,  0.00052D0,  0.00037D0,  0.00027D0,  0.00020D0,
     &     0.00013D0,  0.00007D0,  0.00004D0,  0.00002D0,  0.00000D0,
     &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0/
      DATA (FMRS(2,5,I,38),I=1,49)/
     &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
     &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
     &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
     &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
     &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
     &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
     &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
     &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
     &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
     &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0/
      DATA (FMRS(2,6,I, 1),I=1,49)/
     &     0.49855D0,  0.42587D0,  0.36389D0,  0.33197D0,  0.31109D0,
     &     0.29584D0,  0.25332D0,  0.21750D0,  0.19938D0,  0.18774D0,
     &     0.17961D0,  0.15726D0,  0.13904D0,  0.12982D0,  0.12379D0,
     &     0.11933D0,  0.11282D0,  0.10593D0,  0.09760D0,  0.09090D0,
     &     0.07946D0,  0.06933D0,  0.06013D0,  0.04980D0,  0.04078D0,
     &     0.03302D0,  0.02641D0,  0.02091D0,  0.01639D0,  0.01253D0,
     &     0.00964D0,  0.00728D0,  0.00545D0,  0.00406D0,  0.00291D0,
     &     0.00211D0,  0.00151D0,  0.00106D0,  0.00067D0,  0.00051D0,
     &     0.00036D0,  0.00020D0,  0.00015D0,  0.00005D0,  0.00001D0,
     &    -0.00001D0,  0.00000D0,  0.00000D0,  0.00000D0/
      DATA (FMRS(2,6,I, 2),I=1,49)/
     &     0.50643D0,  0.43610D0,  0.37562D0,  0.34428D0,  0.32368D0,
     &     0.30859D0,  0.26628D0,  0.23029D0,  0.21194D0,  0.20007D0,
     &     0.19176D0,  0.16857D0,  0.14897D0,  0.13868D0,  0.13176D0,
     &     0.12655D0,  0.11883D0,  0.11060D0,  0.10078D0,  0.09314D0,
     &     0.08065D0,  0.07007D0,  0.06069D0,  0.05033D0,  0.04135D0,
     &     0.03363D0,  0.02706D0,  0.02157D0,  0.01702D0,  0.01315D0,
     &     0.01020D0,  0.00777D0,  0.00589D0,  0.00442D0,  0.00323D0,
     &     0.00236D0,  0.00171D0,  0.00122D0,  0.00079D0,  0.00059D0,
     &     0.00042D0,  0.00024D0,  0.00018D0,  0.00006D0,  0.00002D0,
     &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0/
      DATA (FMRS(2,6,I, 3),I=1,49)/
     &     0.53555D0,  0.46535D0,  0.40441D0,  0.37256D0,  0.35153D0,
     &     0.33606D0,  0.29238D0,  0.25475D0,  0.23531D0,  0.22262D0,
     &     0.21361D0,  0.18804D0,  0.16542D0,  0.15305D0,  0.14451D0,
     &     0.13799D0,  0.12824D0,  0.11785D0,  0.10571D0,  0.09664D0,
     &     0.08259D0,  0.07132D0,  0.06165D0,  0.05118D0,  0.04219D0,
     &     0.03449D0,  0.02794D0,  0.02243D0,  0.01784D0,  0.01392D0,
     &     0.01089D0,  0.00837D0,  0.00641D0,  0.00486D0,  0.00360D0,
     &     0.00265D0,  0.00193D0,  0.00138D0,  0.00092D0,  0.00067D0,
     &     0.00048D0,  0.00029D0,  0.00022D0,  0.00008D0,  0.00002D0,
     &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0/
      DATA (FMRS(2,6,I, 4),I=1,49)/
     &     0.57226D0,  0.49911D0,  0.43533D0,  0.40188D0,  0.37974D0,
     &     0.36342D0,  0.31717D0,  0.27704D0,  0.25615D0,  0.24242D0,
     &     0.23256D0,  0.20428D0,  0.17865D0,  0.16439D0,  0.15446D0,
     &     0.14683D0,  0.13543D0,  0.12334D0,  0.10944D0,  0.09929D0,
     &     0.08411D0,  0.07232D0,  0.06240D0,  0.05181D0,  0.04280D0,
     &     0.03507D0,  0.02851D0,  0.02298D0,  0.01835D0,  0.01437D0,
     &     0.01128D0,  0.00872D0,  0.00670D0,  0.00509D0,  0.00378D0,
     &     0.00278D0,  0.00204D0,  0.00149D0,  0.00099D0,  0.00072D0,
     &     0.00050D0,  0.00032D0,  0.00023D0,  0.00009D0,  0.00003D0,
     &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0/
      DATA (FMRS(2,6,I, 5),I=1,49)/
     &     0.63213D0,  0.55147D0,  0.48109D0,  0.44417D0,  0.41970D0,
     &     0.40166D0,  0.35046D0,  0.30587D0,  0.28254D0,  0.26712D0,
     &     0.25592D0,  0.22358D0,  0.19384D0,  0.17718D0,  0.16554D0,
     &     0.15661D0,  0.14330D0,  0.12931D0,  0.11348D0,  0.10220D0,
     &     0.08579D0,  0.07344D0,  0.06325D0,  0.05250D0,  0.04341D0,
     &     0.03561D0,  0.02901D0,  0.02344D0,  0.01875D0,  0.01473D0,
     &     0.01158D0,  0.00897D0,  0.00690D0,  0.00525D0,  0.00392D0,
     &     0.00287D0,  0.00212D0,  0.00153D0,  0.00104D0,  0.00075D0,
     &     0.00052D0,  0.00033D0,  0.00023D0,  0.00009D0,  0.00002D0,
     &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0/
      DATA (FMRS(2,6,I, 6),I=1,49)/
     &     0.69484D0,  0.60548D0,  0.52759D0,  0.48675D0,  0.45969D0,
     &     0.43974D0,  0.38311D0,  0.33372D0,  0.30779D0,  0.29059D0,
     &     0.27800D0,  0.24152D0,  0.20772D0,  0.18874D0,  0.17549D0,
     &     0.16535D0,  0.15028D0,  0.13457D0,  0.11704D0,  0.10475D0,
     &     0.08728D0,  0.07444D0,  0.06400D0,  0.05308D0,  0.04390D0,
     &     0.03605D0,  0.02939D0,  0.02378D0,  0.01903D0,  0.01499D0,
     &     0.01179D0,  0.00914D0,  0.00703D0,  0.00535D0,  0.00400D0,
     &     0.00293D0,  0.00217D0,  0.00156D0,  0.00107D0,  0.00077D0,
     &     0.00053D0,  0.00034D0,  0.00024D0,  0.00009D0,  0.00002D0,
     &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0/
      DATA (FMRS(2,6,I, 7),I=1,49)/
     &     0.77164D0,  0.67034D0,  0.58230D0,  0.53624D0,  0.50577D0,
     &     0.48332D0,  0.41966D0,  0.36421D0,  0.33508D0,  0.31572D0,
     &     0.30145D0,  0.26012D0,  0.22178D0,  0.20031D0,  0.18536D0,
     &     0.17396D0,  0.15711D0,  0.13969D0,  0.12049D0,  0.10724D0,
     &     0.08874D0,  0.07542D0,  0.06472D0,  0.05362D0,  0.04433D0,
     &     0.03642D0,  0.02969D0,  0.02403D0,  0.01923D0,  0.01516D0,
     &     0.01193D0,  0.00926D0,  0.00710D0,  0.00541D0,  0.00405D0,
     &     0.00297D0,  0.00219D0,  0.00158D0,  0.00108D0,  0.00077D0,
     &     0.00052D0,  0.00033D0,  0.00024D0,  0.00008D0,  0.00002D0,
     &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0/
      DATA (FMRS(2,6,I, 8),I=1,49)/
     &     0.86838D0,  0.75105D0,  0.64953D0,  0.59658D0,  0.56163D0,
     &     0.53592D0,  0.46317D0,  0.39995D0,  0.36678D0,  0.34473D0,
     &     0.32838D0,  0.28112D0,  0.23740D0,  0.21303D0,  0.19616D0,
     &     0.18334D0,  0.16450D0,  0.14520D0,  0.12419D0,  0.10991D0,
     &     0.09031D0,  0.07647D0,  0.06547D0,  0.05416D0,  0.04475D0,
     &     0.03674D0,  0.02994D0,  0.02423D0,  0.01939D0,  0.01529D0,
     &     0.01202D0,  0.00932D0,  0.00715D0,  0.00545D0,  0.00407D0,
     &     0.00298D0,  0.00220D0,  0.00159D0,  0.00108D0,  0.00077D0,
     &     0.00052D0,  0.00033D0,  0.00024D0,  0.00008D0,  0.00002D0,
     &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0/
      DATA (FMRS(2,6,I, 9),I=1,49)/
     &     0.96608D0,  0.83177D0,  0.71606D0,  0.65593D0,  0.61632D0,
     &     0.58722D0,  0.50510D0,  0.43397D0,  0.39671D0,  0.37195D0,
     &     0.35355D0,  0.30046D0,  0.25156D0,  0.22448D0,  0.20581D0,
     &     0.19169D0,  0.17103D0,  0.15004D0,  0.12743D0,  0.11224D0,
     &     0.09169D0,  0.07737D0,  0.06612D0,  0.05461D0,  0.04508D0,
     &     0.03697D0,  0.03013D0,  0.02435D0,  0.01949D0,  0.01536D0,
     &     0.01207D0,  0.00933D0,  0.00718D0,  0.00545D0,  0.00407D0,
     &     0.00298D0,  0.00219D0,  0.00159D0,  0.00106D0,  0.00076D0,
     &     0.00052D0,  0.00033D0,  0.00024D0,  0.00009D0,  0.00002D0,
     &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0/
      DATA (FMRS(2,6,I,10),I=1,49)/
     &     1.07543D0,  0.92116D0,  0.78892D0,  0.72047D0,  0.67548D0,
     &     0.64249D0,  0.54968D0,  0.46963D0,  0.42782D0,  0.40008D0,
     &     0.37941D0,  0.32003D0,  0.26568D0,  0.23578D0,  0.21528D0,
     &     0.19985D0,  0.17739D0,  0.15473D0,  0.13057D0,  0.11449D0,
     &     0.09302D0,  0.07823D0,  0.06672D0,  0.05501D0,  0.04535D0,
     &     0.03715D0,  0.03025D0,  0.02442D0,  0.01953D0,  0.01538D0,
     &     0.01207D0,  0.00932D0,  0.00717D0,  0.00543D0,  0.00405D0,
     &     0.00296D0,  0.00217D0,  0.00158D0,  0.00105D0,  0.00075D0,
     &     0.00051D0,  0.00033D0,  0.00023D0,  0.00008D0,  0.00002D0,
     &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0/
      DATA (FMRS(2,6,I,11),I=1,49)/
     &     1.17158D0,  0.99923D0,  0.85209D0,  0.77617D0,  0.72639D0,
     &     0.68993D0,  0.58762D0,  0.49971D0,  0.45391D0,  0.42357D0,
     &     0.40096D0,  0.33616D0,  0.27719D0,  0.24495D0,  0.22293D0,
     &     0.20642D0,  0.18248D0,  0.15848D0,  0.13306D0,  0.11628D0,
     &     0.09406D0,  0.07891D0,  0.06718D0,  0.05531D0,  0.04555D0,
     &     0.03727D0,  0.03032D0,  0.02446D0,  0.01953D0,  0.01537D0,
     &     0.01205D0,  0.00930D0,  0.00714D0,  0.00540D0,  0.00402D0,
     &     0.00294D0,  0.00214D0,  0.00155D0,  0.00104D0,  0.00074D0,
     &     0.00050D0,  0.00032D0,  0.00022D0,  0.00008D0,  0.00002D0,
     &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0/
      DATA (FMRS(2,6,I,12),I=1,49)/
     &     1.40820D0,  1.18938D0,  1.00430D0,  0.90953D0,  0.84767D0,
     &     0.80252D0,  0.67658D0,  0.56932D0,  0.51382D0,  0.47719D0,
     &     0.44989D0,  0.37226D0,  0.30256D0,  0.26497D0,  0.23955D0,
     &     0.22062D0,  0.19343D0,  0.16648D0,  0.13836D0,  0.12007D0,
     &     0.09626D0,  0.08032D0,  0.06811D0,  0.05588D0,  0.04588D0,
     &     0.03745D0,  0.03039D0,  0.02446D0,  0.01948D0,  0.01531D0,
     &     0.01197D0,  0.00921D0,  0.00706D0,  0.00532D0,  0.00395D0,
     &     0.00288D0,  0.00209D0,  0.00151D0,  0.00101D0,  0.00072D0,
     &     0.00049D0,  0.00031D0,  0.00021D0,  0.00008D0,  0.00002D0,
     &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0/
      DATA (FMRS(2,6,I,13),I=1,49)/
     &     1.64756D0,  1.37951D0,  1.15467D0,  1.04031D0,  0.96596D0,
     &     0.91188D0,  0.76181D0,  0.63505D0,  0.56988D0,  0.52704D0,
     &     0.49515D0,  0.40510D0,  0.32525D0,  0.28268D0,  0.25415D0,
     &     0.23303D0,  0.20292D0,  0.17336D0,  0.14288D0,  0.12329D0,
     &     0.09812D0,  0.08148D0,  0.06886D0,  0.05629D0,  0.04609D0,
     &     0.03753D0,  0.03037D0,  0.02438D0,  0.01937D0,  0.01519D0,
     &     0.01185D0,  0.00910D0,  0.00695D0,  0.00523D0,  0.00387D0,
     &     0.00281D0,  0.00204D0,  0.00147D0,  0.00097D0,  0.00069D0,
     &     0.00048D0,  0.00029D0,  0.00020D0,  0.00007D0,  0.00002D0,
     &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0/
      DATA (FMRS(2,6,I,14),I=1,49)/
     &     1.95709D0,  1.62260D0,  1.34467D0,  1.20438D0,  1.11362D0,
     &     1.04783D0,  0.86639D0,  0.71460D0,  0.63715D0,  0.58648D0,
     &     0.54885D0,  0.44345D0,  0.35130D0,  0.30283D0,  0.27064D0,
     &     0.24698D0,  0.21351D0,  0.18099D0,  0.14786D0,  0.12681D0,
     &     0.10011D0,  0.08269D0,  0.06959D0,  0.05666D0,  0.04624D0,
     &     0.03752D0,  0.03025D0,  0.02422D0,  0.01919D0,  0.01499D0,
     &     0.01165D0,  0.00893D0,  0.00678D0,  0.00510D0,  0.00375D0,
     &     0.00271D0,  0.00197D0,  0.00141D0,  0.00093D0,  0.00065D0,
     &     0.00045D0,  0.00028D0,  0.00019D0,  0.00007D0,  0.00002D0,
     &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0/
      DATA (FMRS(2,6,I,15),I=1,49)/
     &     2.33106D0,  1.91266D0,  1.56849D0,  1.39616D0,  1.28524D0,
     &     1.20514D0,  0.98569D0,  0.80398D0,  0.71204D0,  0.65222D0,
     &     0.60792D0,  0.48491D0,  0.37897D0,  0.32402D0,  0.28785D0,
     &     0.26145D0,  0.22441D0,  0.18878D0,  0.15289D0,  0.13035D0,
     &     0.10206D0,  0.08383D0,  0.07023D0,  0.05691D0,  0.04625D0,
     &     0.03736D0,  0.03004D0,  0.02396D0,  0.01891D0,  0.01473D0,
     &     0.01139D0,  0.00872D0,  0.00659D0,  0.00494D0,  0.00362D0,
     &     0.00261D0,  0.00189D0,  0.00136D0,  0.00089D0,  0.00062D0,
     &     0.00043D0,  0.00026D0,  0.00018D0,  0.00006D0,  0.00002D0,
     &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0/
      DATA (FMRS(2,6,I,16),I=1,49)/
     &     2.71585D0,  2.20785D0,  1.79373D0,  1.58787D0,  1.45597D0,
     &     1.36104D0,  1.10250D0,  0.89041D0,  0.78391D0,  0.71494D0,
     &     0.66403D0,  0.52372D0,  0.40449D0,  0.34337D0,  0.30346D0,
     &     0.27452D0,  0.23417D0,  0.19570D0,  0.15732D0,  0.13343D0,
     &     0.10373D0,  0.08475D0,  0.07072D0,  0.05705D0,  0.04617D0,
     &     0.03716D0,  0.02977D0,  0.02366D0,  0.01861D0,  0.01445D0,
     &     0.01114D0,  0.00850D0,  0.00640D0,  0.00478D0,  0.00350D0,
     &     0.00251D0,  0.00181D0,  0.00130D0,  0.00086D0,  0.00058D0,
     &     0.00040D0,  0.00024D0,  0.00016D0,  0.00006D0,  0.00002D0,
     &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0/
      DATA (FMRS(2,6,I,17),I=1,49)/
     &     3.15180D0,  2.53892D0,  2.04375D0,  1.79938D0,  1.64351D0,
     &     1.53170D0,  1.22899D0,  0.98294D0,  0.86032D0,  0.78129D0,
     &     0.72315D0,  0.56409D0,  0.43066D0,  0.36305D0,  0.31926D0,
     &     0.28768D0,  0.24394D0,  0.20257D0,  0.16168D0,  0.13644D0,
     &     0.10531D0,  0.08560D0,  0.07112D0,  0.05711D0,  0.04602D0,
     &     0.03691D0,  0.02945D0,  0.02332D0,  0.01829D0,  0.01415D0,
     &     0.01087D0,  0.00826D0,  0.00621D0,  0.00462D0,  0.00337D0,
     &     0.00241D0,  0.00173D0,  0.00124D0,  0.00082D0,  0.00055D0,
     &     0.00038D0,  0.00023D0,  0.00015D0,  0.00005D0,  0.00002D0,
     &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0/
      DATA (FMRS(2,6,I,18),I=1,49)/
     &     3.55145D0,  2.83962D0,  2.26870D0,  1.98860D0,  1.81061D0,
     &     1.68328D0,  1.34021D0,  1.06346D0,  0.92638D0,  0.83839D0,
     &     0.77383D0,  0.59827D0,  0.45255D0,  0.37938D0,  0.33229D0,
     &     0.29849D0,  0.25191D0,  0.20813D0,  0.16517D0,  0.13882D0,
     &     0.10653D0,  0.08622D0,  0.07137D0,  0.05708D0,  0.04584D0,
     &     0.03664D0,  0.02914D0,  0.02300D0,  0.01798D0,  0.01388D0,
     &     0.01064D0,  0.00807D0,  0.00604D0,  0.00448D0,  0.00326D0,
     &     0.00232D0,  0.00166D0,  0.00119D0,  0.00077D0,  0.00053D0,
     &     0.00036D0,  0.00022D0,  0.00015D0,  0.00005D0,  0.00001D0,
     &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0/
      DATA (FMRS(2,6,I,19),I=1,49)/
     &     4.08243D0,  3.23554D0,  2.56218D0,  2.23414D0,  2.02661D0,
     &     1.87862D0,  1.48217D0,  1.16519D0,  1.00935D0,  0.90979D0,
     &     0.83697D0,  0.64037D0,  0.47917D0,  0.39910D0,  0.34794D0,
     &     0.31141D0,  0.26137D0,  0.21468D0,  0.16924D0,  0.14156D0,
     &     0.10788D0,  0.08686D0,  0.07159D0,  0.05697D0,  0.04554D0,
     &     0.03624D0,  0.02871D0,  0.02258D0,  0.01759D0,  0.01353D0,
     &     0.01034D0,  0.00780D0,  0.00582D0,  0.00431D0,  0.00313D0,
     &     0.00222D0,  0.00159D0,  0.00113D0,  0.00073D0,  0.00050D0,
     &     0.00034D0,  0.00021D0,  0.00014D0,  0.00005D0,  0.00001D0,
     &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0/
      DATA (FMRS(2,6,I,20),I=1,49)/
     &     4.59984D0,  3.61795D0,  2.84314D0,  2.46798D0,  2.23154D0,
     &     2.06341D0,  1.61522D0,  1.25965D0,  1.08594D0,  0.97542D0,
     &     0.89482D0,  0.67853D0,  0.50302D0,  0.41664D0,  0.36179D0,
     &     0.32280D0,  0.26966D0,  0.22039D0,  0.17274D0,  0.14391D0,
     &     0.10901D0,  0.08736D0,  0.07173D0,  0.05682D0,  0.04524D0,
     &     0.03586D0,  0.02831D0,  0.02220D0,  0.01723D0,  0.01322D0,
     &     0.01007D0,  0.00756D0,  0.00563D0,  0.00415D0,  0.00301D0,
     &     0.00213D0,  0.00152D0,  0.00108D0,  0.00071D0,  0.00046D0,
     &     0.00032D0,  0.00019D0,  0.00013D0,  0.00004D0,  0.00001D0,
     &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0/
      DATA (FMRS(2,6,I,21),I=1,49)/
     &     5.10866D0,  3.99099D0,  3.11497D0,  2.69310D0,  2.42814D0,
     &     2.24021D0,  1.74141D0,  1.34843D0,  1.15753D0,  1.03651D0,
     &     0.94850D0,  0.71355D0,  0.52465D0,  0.43244D0,  0.37419D0,
     &     0.33296D0,  0.27700D0,  0.22539D0,  0.17578D0,  0.14590D0,
     &     0.10992D0,  0.08772D0,  0.07175D0,  0.05660D0,  0.04490D0,
     &     0.03547D0,  0.02791D0,  0.02182D0,  0.01688D0,  0.01291D0,
     &     0.00980D0,  0.00735D0,  0.00546D0,  0.00401D0,  0.00289D0,
     &     0.00204D0,  0.00145D0,  0.00103D0,  0.00067D0,  0.00045D0,
     &     0.00030D0,  0.00018D0,  0.00012D0,  0.00004D0,  0.00001D0,
     &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0/
      DATA (FMRS(2,6,I,22),I=1,49)/
     &     5.81063D0,  4.50144D0,  3.48388D0,  2.99716D0,  2.69275D0,
     &     2.47752D0,  1.90937D0,  1.46556D0,  1.25149D0,  1.11639D0,
     &     1.01845D0,  0.75875D0,  0.55228D0,  0.45248D0,  0.38985D0,
     &     0.34573D0,  0.28616D0,  0.23159D0,  0.17950D0,  0.14831D0,
     &     0.11099D0,  0.08809D0,  0.07172D0,  0.05628D0,  0.04443D0,
     &     0.03495D0,  0.02738D0,  0.02132D0,  0.01642D0,  0.01252D0,
     &     0.00947D0,  0.00708D0,  0.00524D0,  0.00384D0,  0.00275D0,
     &     0.00194D0,  0.00137D0,  0.00097D0,  0.00062D0,  0.00042D0,
     &     0.00028D0,  0.00017D0,  0.00011D0,  0.00004D0,  0.00001D0,
     &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0/
      DATA (FMRS(2,6,I,23),I=1,49)/
     &     6.53035D0,  5.02028D0,  3.85558D0,  3.30194D0,  2.95702D0,
     &     2.71384D0,  2.07512D0,  1.58008D0,  1.34283D0,  1.19373D0,
     &     1.08596D0,  0.80189D0,  0.57834D0,  0.47125D0,  0.40444D0,
     &     0.35757D0,  0.29461D0,  0.23726D0,  0.18285D0,  0.15046D0,
     &     0.11188D0,  0.08836D0,  0.07162D0,  0.05593D0,  0.04396D0,
     &     0.03443D0,  0.02686D0,  0.02084D0,  0.01599D0,  0.01216D0,
     &     0.00917D0,  0.00683D0,  0.00504D0,  0.00368D0,  0.00262D0,
     &     0.00186D0,  0.00129D0,  0.00092D0,  0.00058D0,  0.00038D0,
     &     0.00026D0,  0.00015D0,  0.00010D0,  0.00004D0,  0.00001D0,
     &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0/
      DATA (FMRS(2,6,I,24),I=1,49)/
     &     7.24769D0,  5.53321D0,  4.22004D0,  3.59932D0,  3.21397D0,
     &     2.94299D0,  2.23445D0,  1.68918D0,  1.42937D0,  1.26671D0,
     &     1.14944D0,  0.84202D0,  0.60229D0,  0.48837D0,  0.41766D0,
     &     0.36826D0,  0.30216D0,  0.24227D0,  0.18575D0,  0.15227D0,
     &     0.11258D0,  0.08849D0,  0.07143D0,  0.05553D0,  0.04345D0,
     &     0.03390D0,  0.02636D0,  0.02037D0,  0.01559D0,  0.01181D0,
     &     0.00887D0,  0.00659D0,  0.00484D0,  0.00353D0,  0.00252D0,
     &     0.00176D0,  0.00124D0,  0.00088D0,  0.00055D0,  0.00037D0,
     &     0.00025D0,  0.00014D0,  0.00009D0,  0.00003D0,  0.00001D0,
     &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0/
      DATA (FMRS(2,6,I,25),I=1,49)/
     &     8.02203D0,  6.08288D0,  4.60775D0,  3.91431D0,  3.48531D0,
     &     3.18439D0,  2.40103D0,  1.80237D0,  1.51875D0,  1.34182D0,
     &     1.21461D0,  0.88286D0,  0.62643D0,  0.50552D0,  0.43085D0,
     &     0.37888D0,  0.30963D0,  0.24719D0,  0.18858D0,  0.15401D0,
     &     0.11322D0,  0.08857D0,  0.07120D0,  0.05510D0,  0.04294D0,
     &     0.03336D0,  0.02585D0,  0.01990D0,  0.01519D0,  0.01146D0,
     &     0.00858D0,  0.00636D0,  0.00466D0,  0.00338D0,  0.00242D0,
     &     0.00168D0,  0.00119D0,  0.00083D0,  0.00052D0,  0.00035D0,
     &     0.00023D0,  0.00013D0,  0.00009D0,  0.00003D0,  0.00001D0,
     &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0/
      DATA (FMRS(2,6,I,26),I=1,49)/
     &     8.82307D0,  6.64735D0,  5.00295D0,  4.23399D0,  3.75981D0,
     &     3.42801D0,  2.56785D0,  1.91480D0,  1.60708D0,  1.41578D0,
     &     1.27859D0,  0.92256D0,  0.64966D0,  0.52190D0,  0.44338D0,
     &     0.38892D0,  0.31662D0,  0.25175D0,  0.19114D0,  0.15555D0,
     &     0.11371D0,  0.08855D0,  0.07090D0,  0.05462D0,  0.04239D0,
     &     0.03281D0,  0.02532D0,  0.01944D0,  0.01478D0,  0.01112D0,
     &     0.00830D0,  0.00614D0,  0.00448D0,  0.00324D0,  0.00231D0,
     &     0.00160D0,  0.00113D0,  0.00079D0,  0.00049D0,  0.00033D0,
     &     0.00022D0,  0.00013D0,  0.00008D0,  0.00003D0,  0.00001D0,
     &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0/
      DATA (FMRS(2,6,I,27),I=1,49)/
     &     9.62987D0,  7.21210D0,  5.39571D0,  4.55043D0,  4.03076D0,
     &     3.66794D0,  2.73100D0,  2.02398D0,  1.69250D0,  1.48708D0,
     &     1.34010D0,  0.96040D0,  0.67159D0,  0.53727D0,  0.45509D0,
     &     0.39827D0,  0.32310D0,  0.25593D0,  0.19347D0,  0.15692D0,
     &     0.11411D0,  0.08848D0,  0.07058D0,  0.05414D0,  0.04185D0,
     &     0.03228D0,  0.02482D0,  0.01900D0,  0.01440D0,  0.01080D0,
     &     0.00804D0,  0.00593D0,  0.00431D0,  0.00312D0,  0.00222D0,
     &     0.00152D0,  0.00108D0,  0.00075D0,  0.00046D0,  0.00031D0,
     &     0.00020D0,  0.00012D0,  0.00008D0,  0.00003D0,  0.00001D0,
     &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0/
      DATA (FMRS(2,6,I,28),I=1,49)/
     &    10.42894D0,  7.76794D0,  5.77982D0,  4.85875D0,  4.29406D0,
     &     3.90061D0,  2.88817D0,  2.12844D0,  1.77387D0,  1.55479D0,
     &     1.39837D0,  0.99596D0,  0.69200D0,  0.55150D0,  0.46587D0,
     &     0.40684D0,  0.32899D0,  0.25970D0,  0.19552D0,  0.15809D0,
     &     0.11441D0,  0.08837D0,  0.07023D0,  0.05366D0,  0.04133D0,
     &     0.03176D0,  0.02435D0,  0.01859D0,  0.01405D0,  0.01051D0,
     &     0.00780D0,  0.00573D0,  0.00416D0,  0.00301D0,  0.00213D0,
     &     0.00146D0,  0.00103D0,  0.00071D0,  0.00045D0,  0.00029D0,
     &     0.00020D0,  0.00011D0,  0.00008D0,  0.00003D0,  0.00001D0,
     &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0/
      DATA (FMRS(2,6,I,29),I=1,49)/
     &    11.27410D0,  8.35239D0,  6.18132D0,  5.17989D0,  4.56762D0,
     &     4.14187D0,  3.05014D0,  2.23540D0,  1.85687D0,  1.62366D0,
     &     1.45750D0,  1.03178D0,  0.71238D0,  0.56563D0,  0.47653D0,
     &     0.41529D0,  0.33476D0,  0.26336D0,  0.19748D0,  0.15919D0,
     &     0.11465D0,  0.08820D0,  0.06985D0,  0.05316D0,  0.04080D0,
     &     0.03125D0,  0.02388D0,  0.01817D0,  0.01370D0,  0.01022D0,
     &     0.00757D0,  0.00554D0,  0.00401D0,  0.00290D0,  0.00205D0,
     &     0.00140D0,  0.00098D0,  0.00068D0,  0.00043D0,  0.00028D0,
     &     0.00019D0,  0.00011D0,  0.00007D0,  0.00002D0,  0.00001D0,
     &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0/
      DATA (FMRS(2,6,I,30),I=1,49)/
     &    12.14199D0,  8.94909D0,  6.58882D0,  5.50470D0,  4.84361D0,
     &     4.38480D0,  3.21222D0,  2.34175D0,  1.93908D0,  1.69167D0,
     &     1.51576D0,  1.06678D0,  0.73213D0,  0.57923D0,  0.48674D0,
     &     0.42334D0,  0.34023D0,  0.26678D0,  0.19927D0,  0.16016D0,
     &     0.11481D0,  0.08798D0,  0.06944D0,  0.05264D0,  0.04025D0,
     &     0.03073D0,  0.02343D0,  0.01777D0,  0.01335D0,  0.00994D0,
     &     0.00734D0,  0.00536D0,  0.00388D0,  0.00278D0,  0.00196D0,
     &     0.00135D0,  0.00094D0,  0.00065D0,  0.00041D0,  0.00027D0,
     &     0.00017D0,  0.00010D0,  0.00007D0,  0.00002D0,  0.00001D0,
     &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0/
      DATA (FMRS(2,6,I,31),I=1,49)/
     &    13.00875D0,  9.54182D0,  6.99142D0,  5.82458D0,  5.11479D0,
     &     4.62308D0,  3.37031D0,  2.44489D0,  2.01852D0,  1.75723D0,
     &     1.57179D0,  1.10022D0,  0.75086D0,  0.59207D0,  0.49634D0,
     &     0.43089D0,  0.34532D0,  0.26994D0,  0.20090D0,  0.16103D0,
     &     0.11492D0,  0.08774D0,  0.06903D0,  0.05213D0,  0.03973D0,
     &     0.03024D0,  0.02300D0,  0.01739D0,  0.01303D0,  0.00968D0,
     &     0.00712D0,  0.00520D0,  0.00375D0,  0.00268D0,  0.00188D0,
     &     0.00130D0,  0.00090D0,  0.00063D0,  0.00039D0,  0.00025D0,
     &     0.00016D0,  0.00009D0,  0.00006D0,  0.00002D0,  0.00001D0,
     &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0/
      DATA (FMRS(2,6,I,32),I=1,49)/
     &    13.85388D0, 10.11672D0,  7.37984D0,  6.13221D0,  5.37500D0,
     &     4.85130D0,  3.52087D0,  2.54252D0,  2.09344D0,  1.81889D0,
     &     1.62437D0,  1.13136D0,  0.76814D0,  0.60383D0,  0.50509D0,
     &     0.43774D0,  0.34990D0,  0.27275D0,  0.20231D0,  0.16173D0,
     &     0.11495D0,  0.08745D0,  0.06859D0,  0.05162D0,  0.03921D0,
     &     0.02977D0,  0.02256D0,  0.01702D0,  0.01273D0,  0.00943D0,
     &     0.00693D0,  0.00505D0,  0.00364D0,  0.00260D0,  0.00181D0,
     &     0.00125D0,  0.00086D0,  0.00060D0,  0.00037D0,  0.00024D0,
     &     0.00016D0,  0.00009D0,  0.00006D0,  0.00002D0,  0.00001D0,
     &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0/
      DATA (FMRS(2,6,I,33),I=1,49)/
     &    14.75398D0, 10.72621D0,  7.78974D0,  6.45599D0,  5.64833D0,
     &     5.09068D0,  3.67806D0,  2.64398D0,  2.17108D0,  1.88265D0,
     &     1.67867D0,  1.16335D0,  0.78579D0,  0.61581D0,  0.51399D0,
     &     0.44470D0,  0.35453D0,  0.27558D0,  0.20373D0,  0.16245D0,
     &     0.11497D0,  0.08717D0,  0.06816D0,  0.05112D0,  0.03871D0,
     &     0.02930D0,  0.02213D0,  0.01666D0,  0.01243D0,  0.00919D0,
     &     0.00674D0,  0.00490D0,  0.00353D0,  0.00251D0,  0.00175D0,
     &     0.00120D0,  0.00083D0,  0.00058D0,  0.00036D0,  0.00023D0,
     &     0.00015D0,  0.00009D0,  0.00006D0,  0.00002D0,  0.00001D0,
     &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0/
      DATA (FMRS(2,6,I,34),I=1,49)/
     &    15.65461D0, 11.33290D0,  8.19558D0,  6.77553D0,  5.91747D0,
     &     5.32596D0,  3.83165D0,  2.74249D0,  2.24617D0,  1.94414D0,
     &     1.73088D0,  1.19385D0,  0.80244D0,  0.62703D0,  0.52226D0,
     &     0.45111D0,  0.35875D0,  0.27811D0,  0.20493D0,  0.16299D0,
     &     0.11490D0,  0.08681D0,  0.06768D0,  0.05059D0,  0.03819D0,
     &     0.02883D0,  0.02172D0,  0.01631D0,  0.01213D0,  0.00895D0,
     &     0.00656D0,  0.00475D0,  0.00341D0,  0.00243D0,  0.00169D0,
     &     0.00116D0,  0.00080D0,  0.00055D0,  0.00034D0,  0.00022D0,
     &     0.00015D0,  0.00008D0,  0.00005D0,  0.00002D0,  0.00000D0,
     &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0/
      DATA (FMRS(2,6,I,35),I=1,49)/
     &    16.55734D0, 11.93842D0,  8.59892D0,  7.09231D0,  6.18381D0,
     &     5.55847D0,  3.98278D0,  2.83900D0,  2.31954D0,  2.00411D0,
     &     1.78173D0,  1.22341D0,  0.81850D0,  0.63782D0,  0.53020D0,
     &     0.45726D0,  0.36278D0,  0.28052D0,  0.20606D0,  0.16351D0,
     &     0.11482D0,  0.08647D0,  0.06722D0,  0.05009D0,  0.03770D0,
     &     0.02838D0,  0.02133D0,  0.01598D0,  0.01187D0,  0.00873D0,
     &     0.00639D0,  0.00462D0,  0.00330D0,  0.00235D0,  0.00163D0,
     &     0.00111D0,  0.00077D0,  0.00053D0,  0.00033D0,  0.00021D0,
     &     0.00014D0,  0.00008D0,  0.00005D0,  0.00002D0,  0.00000D0,
     &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0/
      DATA (FMRS(2,6,I,36),I=1,49)/
     &    17.43806D0, 12.52661D0,  8.98898D0,  7.39784D0,  6.44021D0,
     &     5.78196D0,  4.12737D0,  2.93087D0,  2.38917D0,  2.06088D0,
     &     1.82979D0,  1.25117D0,  0.83346D0,  0.64781D0,  0.53752D0,
     &     0.46291D0,  0.36645D0,  0.28268D0,  0.20706D0,  0.16393D0,
     &     0.11470D0,  0.08612D0,  0.06676D0,  0.04960D0,  0.03723D0,
     &     0.02796D0,  0.02096D0,  0.01566D0,  0.01161D0,  0.00852D0,
     &     0.00623D0,  0.00449D0,  0.00321D0,  0.00227D0,  0.00158D0,
     &     0.00107D0,  0.00074D0,  0.00051D0,  0.00031D0,  0.00020D0,
     &     0.00013D0,  0.00008D0,  0.00005D0,  0.00002D0,  0.00000D0,
     &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0/
      DATA (FMRS(2,6,I,37),I=1,49)/
     &    18.35067D0, 13.13351D0,  9.38971D0,  7.71095D0,  6.70247D0,
     &     6.01024D0,  4.27436D0,  3.02381D0,  2.45940D0,  2.11802D0,
     &     1.87806D0,  1.27887D0,  0.84828D0,  0.65765D0,  0.54469D0,
     &     0.46841D0,  0.37001D0,  0.28475D0,  0.20797D0,  0.16429D0,
     &     0.11453D0,  0.08573D0,  0.06628D0,  0.04909D0,  0.03675D0,
     &     0.02752D0,  0.02059D0,  0.01535D0,  0.01135D0,  0.00831D0,
     &     0.00606D0,  0.00437D0,  0.00311D0,  0.00220D0,  0.00153D0,
     &     0.00103D0,  0.00072D0,  0.00049D0,  0.00030D0,  0.00019D0,
     &     0.00013D0,  0.00007D0,  0.00005D0,  0.00001D0,  0.00000D0,
     &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0/
      DATA (FMRS(2,6,I,38),I=1,49)/
     &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
     &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
     &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
     &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
     &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
     &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
     &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
     &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
     &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
     &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0/
      DATA (FMRS(2,7,I, 1),I=1,49)/
     &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
     &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
     &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
     &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
     &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
     &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
     &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
     &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
     &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
     &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0/
      DATA (FMRS(2,7,I, 2),I=1,49)/
     &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
     &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
     &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
     &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
     &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
     &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
     &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
     &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
     &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
     &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0/
      DATA (FMRS(2,7,I, 3),I=1,49)/
     &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
     &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
     &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
     &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
     &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
     &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
     &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
     &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
     &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
     &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0/
      DATA (FMRS(2,7,I, 4),I=1,49)/
     &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
     &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
     &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
     &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
     &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
     &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
     &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
     &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
     &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
     &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0/
      DATA (FMRS(2,7,I, 5),I=1,49)/
     &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
     &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
     &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
     &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
     &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
     &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
     &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
     &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
     &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
     &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0/
      DATA (FMRS(2,7,I, 6),I=1,49)/
     &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
     &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
     &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
     &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
     &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
     &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
     &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
     &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
     &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
     &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0/
      DATA (FMRS(2,7,I, 7),I=1,49)/
     &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
     &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
     &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
     &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
     &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
     &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
     &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
     &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
     &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
     &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0/
      DATA (FMRS(2,7,I, 8),I=1,49)/
     &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
     &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
     &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
     &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
     &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
     &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
     &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
     &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
     &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
     &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0/
      DATA (FMRS(2,7,I, 9),I=1,49)/
     &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
     &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
     &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
     &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
     &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
     &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
     &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
     &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
     &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
     &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0/
      DATA (FMRS(2,7,I,10),I=1,49)/
     &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
     &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
     &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
     &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
     &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
     &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
     &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
     &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
     &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
     &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0/
      DATA (FMRS(2,7,I,11),I=1,49)/
     &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
     &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
     &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
     &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
     &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
     &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
     &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
     &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
     &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
     &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0/
      DATA (FMRS(2,7,I,12),I=1,49)/
     &     0.00041D0,  0.00036D0,  0.00032D0,  0.00030D0,  0.00028D0,
     &     0.00027D0,  0.00023D0,  0.00021D0,  0.00019D0,  0.00018D0,
     &     0.00017D0,  0.00014D0,  0.00012D0,  0.00011D0,  0.00010D0,
     &     0.00009D0,  0.00008D0,  0.00007D0,  0.00006D0,  0.00005D0,
     &     0.00004D0,  0.00004D0,  0.00003D0,  0.00003D0,  0.00003D0,
     &     0.00003D0,  0.00002D0,  0.00002D0,  0.00002D0,  0.00002D0,
     &     0.00001D0,  0.00001D0,  0.00001D0,  0.00001D0,  0.00001D0,
     &     0.00001D0,  0.00001D0,  0.00000D0,  0.00000D0,  0.00000D0,
     &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
     &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0/
      DATA (FMRS(2,7,I,13),I=1,49)/
     &     0.21131D0,  0.16558D0,  0.12967D0,  0.11232D0,  0.10141D0,
     &     0.09365D0,  0.07296D0,  0.05647D0,  0.04835D0,  0.04314D0,
     &     0.03929D0,  0.02893D0,  0.02049D0,  0.01636D0,  0.01376D0,
     &     0.01193D0,  0.00947D0,  0.00725D0,  0.00522D0,  0.00409D0,
     &     0.00289D0,  0.00226D0,  0.00187D0,  0.00153D0,  0.00127D0,
     &     0.00106D0,  0.00087D0,  0.00071D0,  0.00058D0,  0.00046D0,
     &     0.00037D0,  0.00028D0,  0.00022D0,  0.00016D0,  0.00012D0,
     &     0.00009D0,  0.00007D0,  0.00005D0,  0.00003D0,  0.00002D0,
     &     0.00001D0,  0.00001D0,  0.00000D0,  0.00000D0,  0.00000D0,
     &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0/
      DATA (FMRS(2,7,I,14),I=1,49)/
     &     0.61374D0,  0.47881D0,  0.37330D0,  0.32254D0,  0.29066D0,
     &     0.26804D0,  0.20788D0,  0.16016D0,  0.13675D0,  0.12177D0,
     &     0.11072D0,  0.08109D0,  0.05711D0,  0.04545D0,  0.03813D0,
     &     0.03299D0,  0.02611D0,  0.01996D0,  0.01434D0,  0.01121D0,
     &     0.00789D0,  0.00617D0,  0.00509D0,  0.00414D0,  0.00341D0,
     &     0.00282D0,  0.00231D0,  0.00188D0,  0.00151D0,  0.00120D0,
     &     0.00094D0,  0.00073D0,  0.00056D0,  0.00042D0,  0.00031D0,
     &     0.00023D0,  0.00016D0,  0.00012D0,  0.00008D0,  0.00005D0,
     &     0.00003D0,  0.00002D0,  0.00000D0,  0.00000D0,  0.00000D0,
     &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0/
      DATA (FMRS(2,7,I,15),I=1,49)/
     &     0.99259D0,  0.76862D0,  0.59480D0,  0.51168D0,  0.45967D0,
     &     0.42287D0,  0.32549D0,  0.24886D0,  0.21152D0,  0.18775D0,
     &     0.17025D0,  0.12366D0,  0.08636D0,  0.06840D0,  0.05719D0,
     &     0.04937D0,  0.03895D0,  0.02967D0,  0.02125D0,  0.01657D0,
     &     0.01162D0,  0.00903D0,  0.00740D0,  0.00597D0,  0.00488D0,
     &     0.00399D0,  0.00325D0,  0.00263D0,  0.00210D0,  0.00166D0,
     &     0.00130D0,  0.00100D0,  0.00076D0,  0.00057D0,  0.00042D0,
     &     0.00031D0,  0.00022D0,  0.00015D0,  0.00011D0,  0.00007D0,
     &     0.00004D0,  0.00002D0,  0.00000D0,  0.00000D0,  0.00000D0,
     &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0/
      DATA (FMRS(2,7,I,16),I=1,49)/
     &     1.40334D0,  1.07950D0,  0.82983D0,  0.71109D0,  0.63704D0,
     &     0.58478D0,  0.44710D0,  0.33953D0,  0.28741D0,  0.25436D0,
     &     0.23011D0,  0.16589D0,  0.11498D0,  0.09067D0,  0.07559D0,
     &     0.06510D0,  0.05120D0,  0.03889D0,  0.02777D0,  0.02161D0,
     &     0.01509D0,  0.01166D0,  0.00950D0,  0.00760D0,  0.00617D0,
     &     0.00501D0,  0.00405D0,  0.00325D0,  0.00258D0,  0.00203D0,
     &     0.00158D0,  0.00121D0,  0.00091D0,  0.00068D0,  0.00050D0,
     &     0.00037D0,  0.00026D0,  0.00018D0,  0.00012D0,  0.00008D0,
     &     0.00005D0,  0.00002D0,  0.00000D0,  0.00000D0,  0.00000D0,
     &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0/
      DATA (FMRS(2,7,I,17),I=1,49)/
     &     1.88020D0,  1.43681D0,  1.09723D0,  0.93659D0,  0.83676D0,
     &     0.76647D0,  0.58212D0,  0.43908D0,  0.37019D0,  0.32667D0,
     &     0.29484D0,  0.21099D0,  0.14515D0,  0.11396D0,  0.09473D0,
     &     0.08141D0,  0.06382D0,  0.04833D0,  0.03440D0,  0.02672D0,
     &     0.01856D0,  0.01428D0,  0.01156D0,  0.00918D0,  0.00739D0,
     &     0.00596D0,  0.00478D0,  0.00381D0,  0.00301D0,  0.00236D0,
     &     0.00181D0,  0.00138D0,  0.00104D0,  0.00077D0,  0.00057D0,
     &     0.00041D0,  0.00030D0,  0.00020D0,  0.00014D0,  0.00009D0,
     &     0.00005D0,  0.00002D0,  0.00000D0,  0.00000D0,  0.00000D0,
     &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0/
      DATA (FMRS(2,7,I,18),I=1,49)/
     &     2.30534D0,  1.75221D0,  1.33088D0,  1.13244D0,  1.00946D0,
     &     0.92305D0,  0.69723D0,  0.52301D0,  0.43952D0,  0.38693D0,
     &     0.34856D0,  0.24795D0,  0.16954D0,  0.13265D0,  0.11000D0,
     &     0.09436D0,  0.07379D0,  0.05574D0,  0.03958D0,  0.03067D0,
     &     0.02123D0,  0.01626D0,  0.01309D0,  0.01033D0,  0.00826D0,
     &     0.00663D0,  0.00529D0,  0.00419D0,  0.00329D0,  0.00257D0,
     &     0.00197D0,  0.00150D0,  0.00112D0,  0.00083D0,  0.00061D0,
     &     0.00044D0,  0.00032D0,  0.00022D0,  0.00015D0,  0.00009D0,
     &     0.00005D0,  0.00002D0,  0.00000D0,  0.00000D0,  0.00000D0,
     &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0/
      DATA (FMRS(2,7,I,19),I=1,49)/
     &     2.86856D0,  2.16633D0,  1.63487D0,  1.38587D0,  1.23207D0,
     &     1.12426D0,  0.84372D0,  0.62876D0,  0.52633D0,  0.46206D0,
     &     0.41530D0,  0.29334D0,  0.19914D0,  0.15517D0,  0.12832D0,
     &     0.10984D0,  0.08563D0,  0.06450D0,  0.04565D0,  0.03529D0,
     &     0.02431D0,  0.01851D0,  0.01482D0,  0.01161D0,  0.00922D0,
     &     0.00734D0,  0.00582D0,  0.00458D0,  0.00358D0,  0.00278D0,
     &     0.00212D0,  0.00160D0,  0.00119D0,  0.00088D0,  0.00064D0,
     &     0.00047D0,  0.00033D0,  0.00023D0,  0.00015D0,  0.00009D0,
     &     0.00005D0,  0.00002D0,  0.00000D0,  0.00000D0,  0.00000D0,
     &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0/
      DATA (FMRS(2,7,I,20),I=1,49)/
     &     3.42748D0,  2.57399D0,  1.93167D0,  1.63211D0,  1.44759D0,
     &     1.31854D0,  0.98395D0,  0.72909D0,  0.60825D0,  0.53267D0,
     &     0.47783D0,  0.33544D0,  0.22632D0,  0.17572D0,  0.14495D0,
     &     0.12384D0,  0.09630D0,  0.07234D0,  0.05105D0,  0.03938D0,
     &     0.02701D0,  0.02047D0,  0.01631D0,  0.01268D0,  0.01001D0,
     &     0.00793D0,  0.00625D0,  0.00489D0,  0.00380D0,  0.00294D0,
     &     0.00223D0,  0.00168D0,  0.00125D0,  0.00091D0,  0.00066D0,
     &     0.00048D0,  0.00035D0,  0.00024D0,  0.00016D0,  0.00009D0,
     &     0.00005D0,  0.00002D0,  0.00000D0,  0.00000D0,  0.00000D0,
     &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0/
      DATA (FMRS(2,7,I,21),I=1,49)/
     &     3.95907D0,  2.95830D0,  2.20894D0,  1.86088D0,  1.64705D0,
     &     1.49778D0,  1.11204D0,  0.81980D0,  0.68185D0,  0.59583D0,
     &     0.53354D0,  0.37251D0,  0.24993D0,  0.19343D0,  0.15921D0,
     &     0.13581D0,  0.10535D0,  0.07895D0,  0.05557D0,  0.04278D0,
     &     0.02922D0,  0.02205D0,  0.01748D0,  0.01352D0,  0.01061D0,
     &     0.00835D0,  0.00655D0,  0.00511D0,  0.00395D0,  0.00304D0,
     &     0.00230D0,  0.00172D0,  0.00128D0,  0.00093D0,  0.00067D0,
     &     0.00049D0,  0.00035D0,  0.00024D0,  0.00016D0,  0.00009D0,
     &     0.00005D0,  0.00002D0,  0.00000D0,  0.00000D0,  0.00000D0,
     &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0/
      DATA (FMRS(2,7,I,22),I=1,49)/
     &     4.70301D0,  3.49223D0,  2.59131D0,  2.17500D0,  1.92006D0,
     &     1.74251D0,  1.28559D0,  0.94171D0,  0.78029D0,  0.68000D0,
     &     0.60759D0,  0.42132D0,  0.28074D0,  0.21641D0,  0.17764D0,
     &     0.15121D0,  0.11695D0,  0.08738D0,  0.06130D0,  0.04706D0,
     &     0.03198D0,  0.02400D0,  0.01891D0,  0.01452D0,  0.01131D0,
     &     0.00885D0,  0.00690D0,  0.00535D0,  0.00412D0,  0.00314D0,
     &     0.00237D0,  0.00177D0,  0.00130D0,  0.00095D0,  0.00068D0,
     &     0.00049D0,  0.00036D0,  0.00024D0,  0.00016D0,  0.00009D0,
     &     0.00005D0,  0.00002D0,  0.00000D0,  0.00000D0,  0.00000D0,
     &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0/
      DATA (FMRS(2,7,I,23),I=1,49)/
     &     5.46775D0,  4.03669D0,  2.97803D0,  2.49113D0,  2.19384D0,
     &     1.98726D0,  1.45764D0,  1.06148D0,  0.87647D0,  0.76190D0,
     &     0.67941D0,  0.46817D0,  0.30998D0,  0.23809D0,  0.19493D0,
     &     0.16562D0,  0.12774D0,  0.09517D0,  0.06655D0,  0.05097D0,
     &     0.03446D0,  0.02573D0,  0.02017D0,  0.01538D0,  0.01190D0,
     &     0.00925D0,  0.00718D0,  0.00553D0,  0.00424D0,  0.00322D0,
     &     0.00242D0,  0.00179D0,  0.00132D0,  0.00095D0,  0.00069D0,
     &     0.00049D0,  0.00036D0,  0.00024D0,  0.00016D0,  0.00009D0,
     &     0.00005D0,  0.00002D0,  0.00000D0,  0.00000D0,  0.00000D0,
     &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0/
      DATA (FMRS(2,7,I,24),I=1,49)/
     &     6.21519D0,  4.56429D0,  3.34948D0,  2.79317D0,  2.45443D0,
     &     2.21950D0,  1.61934D0,  1.17290D0,  0.96539D0,  0.83728D0,
     &     0.74526D0,  0.51062D0,  0.33614D0,  0.25732D0,  0.21020D0,
     &     0.17828D0,  0.13715D0,  0.10192D0,  0.07106D0,  0.05428D0,
     &     0.03653D0,  0.02714D0,  0.02117D0,  0.01604D0,  0.01234D0,
     &     0.00954D0,  0.00736D0,  0.00565D0,  0.00431D0,  0.00326D0,
     &     0.00243D0,  0.00180D0,  0.00132D0,  0.00095D0,  0.00068D0,
     &     0.00049D0,  0.00035D0,  0.00024D0,  0.00016D0,  0.00009D0,
     &     0.00005D0,  0.00002D0,  0.00000D0,  0.00000D0,  0.00000D0,
     &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0/
      DATA (FMRS(2,7,I,25),I=1,49)/
     &     7.03262D0,  5.13776D0,  3.75072D0,  3.11823D0,  2.73413D0,
     &     2.46827D0,  1.79141D0,  1.29068D0,  1.05901D0,  0.91641D0,
     &     0.81423D0,  0.55475D0,  0.36312D0,  0.27706D0,  0.22581D0,
     &     0.19119D0,  0.14672D0,  0.10875D0,  0.07559D0,  0.05760D0,
     &     0.03859D0,  0.02852D0,  0.02214D0,  0.01668D0,  0.01276D0,
     &     0.00981D0,  0.00753D0,  0.00575D0,  0.00436D0,  0.00329D0,
     &     0.00245D0,  0.00180D0,  0.00132D0,  0.00095D0,  0.00068D0,
     &     0.00048D0,  0.00035D0,  0.00024D0,  0.00016D0,  0.00009D0,
     &     0.00005D0,  0.00002D0,  0.00000D0,  0.00000D0,  0.00000D0,
     &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0/
      DATA (FMRS(2,7,I,26),I=1,49)/
     &     7.86804D0,  5.71947D0,  4.15459D0,  3.44391D0,  3.01342D0,
     &     2.71602D0,  1.96133D0,  1.40596D0,  1.15014D0,  0.99314D0,
     &     0.88088D0,  0.59694D0,  0.38863D0,  0.29560D0,  0.24039D0,
     &     0.20320D0,  0.15555D0,  0.11500D0,  0.07970D0,  0.06059D0,
     &     0.04040D0,  0.02973D0,  0.02296D0,  0.01720D0,  0.01308D0,
     &     0.01001D0,  0.00765D0,  0.00581D0,  0.00439D0,  0.00330D0,
     &     0.00245D0,  0.00180D0,  0.00131D0,  0.00094D0,  0.00067D0,
     &     0.00048D0,  0.00034D0,  0.00024D0,  0.00016D0,  0.00009D0,
     &     0.00005D0,  0.00002D0,  0.00000D0,  0.00000D0,  0.00000D0,
     &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0/
      DATA (FMRS(2,7,I,27),I=1,49)/
     &     8.71308D0,  6.30440D0,  4.55822D0,  3.76823D0,  3.29083D0,
     &     2.96160D0,  2.12868D0,  1.51874D0,  1.23894D0,  1.06767D0,
     &     0.94548D0,  0.63752D0,  0.41296D0,  0.31319D0,  0.25418D0,
     &     0.21452D0,  0.16385D0,  0.12085D0,  0.08351D0,  0.06334D0,
     &     0.04205D0,  0.03081D0,  0.02369D0,  0.01765D0,  0.01336D0,
     &     0.01017D0,  0.00773D0,  0.00586D0,  0.00441D0,  0.00330D0,
     &     0.00244D0,  0.00178D0,  0.00129D0,  0.00092D0,  0.00066D0,
     &     0.00047D0,  0.00034D0,  0.00024D0,  0.00016D0,  0.00009D0,
     &     0.00005D0,  0.00002D0,  0.00000D0,  0.00000D0,  0.00000D0,
     &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0/
      DATA (FMRS(2,7,I,28),I=1,49)/
     &     9.54571D0,  6.87720D0,  4.95101D0,  4.08263D0,  3.55902D0,
     &     3.19851D0,  2.28903D0,  1.62602D0,  1.32303D0,  1.13803D0,
     &     1.00630D0,  0.67540D0,  0.43546D0,  0.32936D0,  0.26680D0,
     &     0.22485D0,  0.17138D0,  0.12612D0,  0.08693D0,  0.06579D0,
     &     0.04350D0,  0.03173D0,  0.02430D0,  0.01801D0,  0.01357D0,
     &     0.01029D0,  0.00779D0,  0.00587D0,  0.00441D0,  0.00329D0,
     &     0.00242D0,  0.00177D0,  0.00128D0,  0.00091D0,  0.00065D0,
     &     0.00046D0,  0.00033D0,  0.00024D0,  0.00016D0,  0.00009D0,
     &     0.00005D0,  0.00002D0,  0.00000D0,  0.00000D0,  0.00000D0,
     &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0/
      DATA (FMRS(2,7,I,29),I=1,49)/
     &    10.42768D0,  7.48069D0,  5.36257D0,  4.41099D0,  3.83846D0,
     &     3.44489D0,  2.45481D0,  1.73627D0,  1.40913D0,  1.20986D0,
     &     1.06825D0,  0.71372D0,  0.45804D0,  0.34552D0,  0.27937D0,
     &     0.23511D0,  0.17881D0,  0.13130D0,  0.09026D0,  0.06816D0,
     &     0.04488D0,  0.03260D0,  0.02487D0,  0.01834D0,  0.01375D0,
     &     0.01038D0,  0.00783D0,  0.00588D0,  0.00440D0,  0.00327D0,
     &     0.00240D0,  0.00175D0,  0.00126D0,  0.00090D0,  0.00063D0,
     &     0.00045D0,  0.00033D0,  0.00024D0,  0.00016D0,  0.00009D0,
     &     0.00005D0,  0.00002D0,  0.00000D0,  0.00000D0,  0.00000D0,
     &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0/
      DATA (FMRS(2,7,I,30),I=1,49)/
     &    11.32906D0,  8.09395D0,  5.77834D0,  4.74153D0,  4.11903D0,
     &     3.69178D0,  2.61985D0,  1.84528D0,  1.49390D0,  1.28038D0,
     &     1.12893D0,  0.75094D0,  0.47979D0,  0.36099D0,  0.29135D0,
     &     0.24485D0,  0.18584D0,  0.13617D0,  0.09335D0,  0.07035D0,
     &     0.04613D0,  0.03338D0,  0.02536D0,  0.01861D0,  0.01389D0,
     &     0.01045D0,  0.00785D0,  0.00587D0,  0.00438D0,  0.00324D0,
     &     0.00237D0,  0.00172D0,  0.00124D0,  0.00088D0,  0.00062D0,
     &     0.00044D0,  0.00032D0,  0.00024D0,  0.00016D0,  0.00009D0,
     &     0.00005D0,  0.00002D0,  0.00000D0,  0.00000D0,  0.00000D0,
     &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0/
      DATA (FMRS(2,7,I,31),I=1,49)/
     &    12.23197D0,  8.70533D0,  6.19083D0,  5.06852D0,  4.39601D0,
     &     3.93512D0,  2.78170D0,  1.95161D0,  1.57633D0,  1.34878D0,
     &     1.18767D0,  0.78675D0,  0.50057D0,  0.37571D0,  0.30272D0,
     &     0.25408D0,  0.19247D0,  0.14074D0,  0.09625D0,  0.07237D0,
     &     0.04728D0,  0.03408D0,  0.02579D0,  0.01885D0,  0.01401D0,
     &     0.01049D0,  0.00785D0,  0.00586D0,  0.00435D0,  0.00321D0,
     &     0.00235D0,  0.00170D0,  0.00122D0,  0.00086D0,  0.00061D0,
     &     0.00043D0,  0.00031D0,  0.00023D0,  0.00016D0,  0.00009D0,
     &     0.00005D0,  0.00002D0,  0.00000D0,  0.00000D0,  0.00000D0,
     &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0/
      DATA (FMRS(2,7,I,32),I=1,49)/
     &    13.10605D0,  9.29397D0,  6.58574D0,  5.38050D0,  4.65963D0,
     &     4.16627D0,  2.93446D0,  2.05131D0,  1.65329D0,  1.41245D0,
     &     1.24220D0,  0.81972D0,  0.51953D0,  0.38906D0,  0.31298D0,
     &     0.26237D0,  0.19840D0,  0.14478D0,  0.09878D0,  0.07413D0,
     &     0.04825D0,  0.03465D0,  0.02614D0,  0.01902D0,  0.01408D0,
     &     0.01051D0,  0.00784D0,  0.00583D0,  0.00432D0,  0.00318D0,
     &     0.00232D0,  0.00167D0,  0.00120D0,  0.00085D0,  0.00060D0,
     &     0.00042D0,  0.00031D0,  0.00023D0,  0.00016D0,  0.00009D0,
     &     0.00005D0,  0.00002D0,  0.00000D0,  0.00000D0,  0.00000D0,
     &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0/
      DATA (FMRS(2,7,I,33),I=1,49)/
     &    14.04396D0,  9.92333D0,  7.00645D0,  5.71217D0,  4.93947D0,
     &     4.41134D0,  3.09586D0,  2.15625D0,  1.73413D0,  1.47923D0,
     &     1.29933D0,  0.85413D0,  0.53923D0,  0.40291D0,  0.32360D0,
     &     0.27095D0,  0.20451D0,  0.14895D0,  0.10139D0,  0.07594D0,
     &     0.04925D0,  0.03524D0,  0.02649D0,  0.01920D0,  0.01416D0,
     &     0.01053D0,  0.00783D0,  0.00580D0,  0.00428D0,  0.00315D0,
     &     0.00229D0,  0.00165D0,  0.00118D0,  0.00083D0,  0.00058D0,
     &     0.00041D0,  0.00030D0,  0.00022D0,  0.00016D0,  0.00009D0,
     &     0.00005D0,  0.00002D0,  0.00000D0,  0.00000D0,  0.00000D0,
     &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0/
      DATA (FMRS(2,7,I,34),I=1,49)/
     &    14.97171D0, 10.54223D0,  7.41762D0,  6.03510D0,  5.21118D0,
     &     4.64879D0,  3.25111D0,  2.25643D0,  1.81093D0,  1.54244D0,
     &     1.35325D0,  0.88628D0,  0.55744D0,  0.41560D0,  0.33329D0,
     &     0.27873D0,  0.21001D0,  0.15267D0,  0.10367D0,  0.07749D0,
     &     0.05007D0,  0.03571D0,  0.02675D0,  0.01931D0,  0.01419D0,
     &     0.01051D0,  0.00779D0,  0.00576D0,  0.00424D0,  0.00311D0,
     &     0.00225D0,  0.00162D0,  0.00115D0,  0.00081D0,  0.00057D0,
     &     0.00041D0,  0.00030D0,  0.00022D0,  0.00016D0,  0.00009D0,
     &     0.00005D0,  0.00002D0,  0.00000D0,  0.00000D0,  0.00000D0,
     &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0/
      DATA (FMRS(2,7,I,35),I=1,49)/
     &    15.90678D0, 11.16388D0,  7.82922D0,  6.35772D0,  5.48225D0,
     &     4.88541D0,  3.40531D0,  2.35558D0,  1.88678D0,  1.60477D0,
     &     1.40636D0,  0.91783D0,  0.57524D0,  0.42799D0,  0.34272D0,
     &     0.28629D0,  0.21535D0,  0.15626D0,  0.10587D0,  0.07899D0,
     &     0.05087D0,  0.03616D0,  0.02700D0,  0.01941D0,  0.01421D0,
     &     0.01050D0,  0.00776D0,  0.00572D0,  0.00420D0,  0.00307D0,
     &     0.00222D0,  0.00159D0,  0.00113D0,  0.00080D0,  0.00056D0,
     &     0.00040D0,  0.00029D0,  0.00022D0,  0.00016D0,  0.00009D0,
     &     0.00005D0,  0.00002D0,  0.00000D0,  0.00000D0,  0.00000D0,
     &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0/
      DATA (FMRS(2,7,I,36),I=1,49)/
     &    16.81722D0, 11.76659D0,  8.22652D0,  6.66831D0,  5.74271D0,
     &     5.11243D0,  3.55252D0,  2.44976D0,  1.95860D0,  1.66366D0,
     &     1.45643D0,  0.94739D0,  0.59179D0,  0.43945D0,  0.35142D0,
     &     0.29325D0,  0.22023D0,  0.15953D0,  0.10786D0,  0.08033D0,
     &     0.05156D0,  0.03654D0,  0.02720D0,  0.01949D0,  0.01422D0,
     &     0.01047D0,  0.00772D0,  0.00567D0,  0.00416D0,  0.00303D0,
     &     0.00219D0,  0.00157D0,  0.00111D0,  0.00078D0,  0.00055D0,
     &     0.00039D0,  0.00029D0,  0.00022D0,  0.00016D0,  0.00009D0,
     &     0.00005D0,  0.00002D0,  0.00000D0,  0.00000D0,  0.00000D0,
     &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0/
      DATA (FMRS(2,7,I,37),I=1,49)/
     &    17.75747D0, 12.38637D0,  8.63327D0,  6.98544D0,  6.00814D0,
     &     5.34342D0,  3.70158D0,  2.54461D0,  2.03070D0,  1.72263D0,
     &     1.50647D0,  0.97674D0,  0.60811D0,  0.45069D0,  0.35992D0,
     &     0.30003D0,  0.22496D0,  0.16268D0,  0.10975D0,  0.08160D0,
     &     0.05220D0,  0.03687D0,  0.02737D0,  0.01954D0,  0.01421D0,
     &     0.01044D0,  0.00767D0,  0.00562D0,  0.00411D0,  0.00299D0,
     &     0.00215D0,  0.00154D0,  0.00109D0,  0.00077D0,  0.00053D0,
     &     0.00038D0,  0.00028D0,  0.00021D0,  0.00016D0,  0.00009D0,
     &     0.00005D0,  0.00002D0,  0.00000D0,  0.00000D0,  0.00000D0,
     &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0/
      DATA (FMRS(2,7,I,38),I=1,49)/
     &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
     &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
     &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
     &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
     &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
     &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
     &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
     &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
     &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
     &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0/
      DATA (FMRS(2,8,I, 1),I=1,49)/
     &     0.98494D0,  0.83942D0,  0.71517D0,  0.65113D0,  0.60921D0,
     &     0.57857D0,  0.49313D0,  0.42114D0,  0.38478D0,  0.36147D0,
     &     0.34532D0,  0.30109D0,  0.26601D0,  0.24883D0,  0.23797D0,
     &     0.23013D0,  0.21908D0,  0.20797D0,  0.19531D0,  0.18554D0,
     &     0.16898D0,  0.15367D0,  0.13862D0,  0.11992D0,  0.10161D0,
     &     0.08421D0,  0.06813D0,  0.05380D0,  0.04148D0,  0.03102D0,
     &     0.02276D0,  0.01618D0,  0.01125D0,  0.00763D0,  0.00500D0,
     &     0.00317D0,  0.00203D0,  0.00121D0,  0.00069D0,  0.00043D0,
     &     0.00027D0,  0.00012D0,  0.00011D0,  0.00003D0,  0.00000D0,
     &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0/
      DATA (FMRS(2,8,I, 2),I=1,49)/
     &     0.98889D0,  0.84649D0,  0.72438D0,  0.66122D0,  0.61978D0,
     &     0.58944D0,  0.50458D0,  0.43271D0,  0.39626D0,  0.37282D0,
     &     0.35655D0,  0.31168D0,  0.27538D0,  0.25719D0,  0.24547D0,
     &     0.23690D0,  0.22464D0,  0.21217D0,  0.19794D0,  0.18712D0,
     &     0.16930D0,  0.15330D0,  0.13787D0,  0.11894D0,  0.10059D0,
     &     0.08325D0,  0.06732D0,  0.05317D0,  0.04104D0,  0.03076D0,
     &     0.02264D0,  0.01619D0,  0.01134D0,  0.00776D0,  0.00516D0,
     &     0.00334D0,  0.00218D0,  0.00135D0,  0.00080D0,  0.00052D0,
     &     0.00034D0,  0.00018D0,  0.00014D0,  0.00004D0,  0.00001D0,
     &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0/
      DATA (FMRS(2,8,I, 3),I=1,49)/
     &     1.01222D0,  0.87111D0,  0.74946D0,  0.68626D0,  0.64467D0,
     &     0.61416D0,  0.52846D0,  0.45538D0,  0.41806D0,  0.39393D0,
     &     0.37708D0,  0.33010D0,  0.29099D0,  0.27082D0,  0.25752D0,
     &     0.24766D0,  0.23338D0,  0.21871D0,  0.20204D0,  0.18963D0,
     &     0.16990D0,  0.15288D0,  0.13686D0,  0.11759D0,  0.09914D0,
     &     0.08186D0,  0.06611D0,  0.05221D0,  0.04030D0,  0.03030D0,
     &     0.02237D0,  0.01612D0,  0.01138D0,  0.00788D0,  0.00532D0,
     &     0.00353D0,  0.00233D0,  0.00151D0,  0.00092D0,  0.00061D0,
     &     0.00042D0,  0.00024D0,  0.00016D0,  0.00005D0,  0.00002D0,
     &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0/
      DATA (FMRS(2,8,I, 4),I=1,49)/
     &     1.04476D0,  0.90153D0,  0.77771D0,  0.71324D0,  0.67074D0,
     &     0.63953D0,  0.55166D0,  0.47640D0,  0.43777D0,  0.41269D0,
     &     0.39507D0,  0.34558D0,  0.30362D0,  0.28161D0,  0.26695D0,
     &     0.25601D0,  0.24007D0,  0.22367D0,  0.20514D0,  0.19155D0,
     &     0.17043D0,  0.15264D0,  0.13620D0,  0.11664D0,  0.09810D0,
     &     0.08084D0,  0.06518D0,  0.05144D0,  0.03971D0,  0.02989D0,
     &     0.02211D0,  0.01600D0,  0.01135D0,  0.00790D0,  0.00539D0,
     &     0.00362D0,  0.00238D0,  0.00157D0,  0.00098D0,  0.00066D0,
     &     0.00045D0,  0.00026D0,  0.00018D0,  0.00006D0,  0.00003D0,
     &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0/
      DATA (FMRS(2,8,I, 5),I=1,49)/
     &     1.10026D0,  0.95040D0,  0.82069D0,  0.75308D0,  0.70848D0,
     &     0.67571D0,  0.58330D0,  0.50390D0,  0.46299D0,  0.43632D0,
     &     0.41743D0,  0.36409D0,  0.31818D0,  0.29384D0,  0.27750D0,
     &     0.26527D0,  0.24742D0,  0.22908D0,  0.20853D0,  0.19368D0,
     &     0.17108D0,  0.15248D0,  0.13556D0,  0.11567D0,  0.09702D0,
     &     0.07977D0,  0.06421D0,  0.05061D0,  0.03905D0,  0.02941D0,
     &     0.02179D0,  0.01578D0,  0.01121D0,  0.00787D0,  0.00539D0,
     &     0.00363D0,  0.00243D0,  0.00163D0,  0.00101D0,  0.00068D0,
     &     0.00046D0,  0.00028D0,  0.00020D0,  0.00007D0,  0.00002D0,
     &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0/
      DATA (FMRS(2,8,I, 6),I=1,49)/
     &     1.15923D0,  1.00143D0,  0.86481D0,  0.79358D0,  0.74658D0,
     &     0.71202D0,  0.61454D0,  0.53061D0,  0.48723D0,  0.45888D0,
     &     0.43867D0,  0.38135D0,  0.33152D0,  0.30491D0,  0.28699D0,
     &     0.27355D0,  0.25394D0,  0.23384D0,  0.21150D0,  0.19554D0,
     &     0.17166D0,  0.15236D0,  0.13502D0,  0.11484D0,  0.09608D0,
     &     0.07883D0,  0.06335D0,  0.04988D0,  0.03847D0,  0.02897D0,
     &     0.02148D0,  0.01557D0,  0.01108D0,  0.00781D0,  0.00536D0,
     &     0.00363D0,  0.00245D0,  0.00167D0,  0.00103D0,  0.00070D0,
     &     0.00046D0,  0.00029D0,  0.00021D0,  0.00007D0,  0.00002D0,
     &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0/
      DATA (FMRS(2,8,I, 7),I=1,49)/
     &     1.23248D0,  1.06345D0,  0.91726D0,  0.84109D0,  0.79085D0,
     &     0.75393D0,  0.64976D0,  0.56002D0,  0.51357D0,  0.48314D0,
     &     0.46132D0,  0.39931D0,  0.34507D0,  0.31602D0,  0.29642D0,
     &     0.28173D0,  0.26034D0,  0.23848D0,  0.21438D0,  0.19736D0,
     &     0.17224D0,  0.15227D0,  0.13452D0,  0.11404D0,  0.09516D0,
     &     0.07789D0,  0.06251D0,  0.04914D0,  0.03786D0,  0.02851D0,
     &     0.02113D0,  0.01532D0,  0.01096D0,  0.00772D0,  0.00530D0,
     &     0.00360D0,  0.00243D0,  0.00166D0,  0.00104D0,  0.00071D0,
     &     0.00048D0,  0.00030D0,  0.00020D0,  0.00008D0,  0.00002D0,
     &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0/
      DATA (FMRS(2,8,I, 8),I=1,49)/
     &     1.32548D0,  1.14118D0,  0.98212D0,  0.89937D0,  0.84484D0,
     &     0.80478D0,  0.69187D0,  0.59465D0,  0.54428D0,  0.51124D0,
     &     0.48741D0,  0.41964D0,  0.36014D0,  0.32825D0,  0.30675D0,
     &     0.29065D0,  0.26725D0,  0.24348D0,  0.21747D0,  0.19931D0,
     &     0.17288D0,  0.15217D0,  0.13398D0,  0.11319D0,  0.09418D0,
     &     0.07689D0,  0.06158D0,  0.04833D0,  0.03719D0,  0.02798D0,
     &     0.02073D0,  0.01504D0,  0.01077D0,  0.00760D0,  0.00523D0,
     &     0.00355D0,  0.00240D0,  0.00165D0,  0.00105D0,  0.00070D0,
     &     0.00048D0,  0.00029D0,  0.00020D0,  0.00007D0,  0.00002D0,
     &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0/
      DATA (FMRS(2,8,I, 9),I=1,49)/
     &     1.41996D0,  1.21934D0,  1.04662D0,  0.95694D0,  0.89790D0,
     &     0.85457D0,  0.73259D0,  0.62769D0,  0.57336D0,  0.53768D0,
     &     0.51185D0,  0.43840D0,  0.37384D0,  0.33927D0,  0.31599D0,
     &     0.29859D0,  0.27338D0,  0.24788D0,  0.22018D0,  0.20102D0,
     &     0.17344D0,  0.15210D0,  0.13351D0,  0.11246D0,  0.09333D0,
     &     0.07602D0,  0.06075D0,  0.04762D0,  0.03659D0,  0.02749D0,
     &     0.02036D0,  0.01479D0,  0.01057D0,  0.00748D0,  0.00516D0,
     &     0.00349D0,  0.00238D0,  0.00163D0,  0.00104D0,  0.00069D0,
     &     0.00047D0,  0.00028D0,  0.00019D0,  0.00006D0,  0.00002D0,
     &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0/
      DATA (FMRS(2,8,I,10),I=1,49)/
     &     1.52623D0,  1.30628D0,  1.11753D0,  1.01977D0,  0.95552D0,
     &     0.90841D0,  0.77603D0,  0.66243D0,  0.60365D0,  0.56506D0,
     &     0.53703D0,  0.45743D0,  0.38751D0,  0.35017D0,  0.32507D0,
     &     0.30636D0,  0.27933D0,  0.25214D0,  0.22280D0,  0.20266D0,
     &     0.17397D0,  0.15202D0,  0.13306D0,  0.11174D0,  0.09248D0,
     &     0.07516D0,  0.05994D0,  0.04691D0,  0.03600D0,  0.02702D0,
     &     0.02000D0,  0.01454D0,  0.01039D0,  0.00736D0,  0.00507D0,
     &     0.00344D0,  0.00235D0,  0.00162D0,  0.00103D0,  0.00069D0,
     &     0.00047D0,  0.00027D0,  0.00019D0,  0.00006D0,  0.00002D0,
     &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0/
      DATA (FMRS(2,8,I,11),I=1,49)/
     &     1.61996D0,  1.38242D0,  1.17917D0,  1.07414D0,  1.00521D0,
     &     0.95472D0,  0.81307D0,  0.69180D0,  0.62911D0,  0.58797D0,
     &     0.55803D0,  0.47313D0,  0.39867D0,  0.35901D0,  0.33241D0,
     &     0.31262D0,  0.28411D0,  0.25553D0,  0.22487D0,  0.20396D0,
     &     0.17439D0,  0.15196D0,  0.13270D0,  0.11116D0,  0.09180D0,
     &     0.07446D0,  0.05929D0,  0.04635D0,  0.03552D0,  0.02665D0,
     &     0.01972D0,  0.01433D0,  0.01024D0,  0.00726D0,  0.00500D0,
     &     0.00340D0,  0.00233D0,  0.00161D0,  0.00102D0,  0.00069D0,
     &     0.00047D0,  0.00027D0,  0.00019D0,  0.00006D0,  0.00002D0,
     &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0/
      DATA (FMRS(2,8,I,12),I=1,49)/
     &     1.85147D0,  1.56851D0,  1.32816D0,  1.20469D0,  1.12394D0,
     &     1.06494D0,  0.90014D0,  0.75989D0,  0.68768D0,  0.64036D0,
     &     0.60582D0,  0.50832D0,  0.42330D0,  0.37835D0,  0.34837D0,
     &     0.32616D0,  0.29437D0,  0.26278D0,  0.22928D0,  0.20671D0,
     &     0.17525D0,  0.15178D0,  0.13188D0,  0.10989D0,  0.09032D0,
     &     0.07294D0,  0.05789D0,  0.04511D0,  0.03448D0,  0.02582D0,
     &     0.01907D0,  0.01385D0,  0.00987D0,  0.00700D0,  0.00482D0,
     &     0.00328D0,  0.00224D0,  0.00154D0,  0.00100D0,  0.00066D0,
     &     0.00045D0,  0.00027D0,  0.00019D0,  0.00006D0,  0.00002D0,
     &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0/
      DATA (FMRS(2,8,I,13),I=1,49)/
     &     2.08649D0,  1.75519D0,  1.47580D0,  1.33308D0,  1.24007D0,
     &     1.17230D0,  0.98378D0,  0.82434D0,  0.74261D0,  0.68917D0,
     &     0.65012D0,  0.54038D0,  0.44535D0,  0.39548D0,  0.36240D0,
     &     0.33801D0,  0.30327D0,  0.26901D0,  0.23303D0,  0.20903D0,
     &     0.17595D0,  0.15158D0,  0.13113D0,  0.10875D0,  0.08901D0,
     &     0.07161D0,  0.05666D0,  0.04403D0,  0.03356D0,  0.02508D0,
     &     0.01848D0,  0.01341D0,  0.00954D0,  0.00676D0,  0.00467D0,
     &     0.00317D0,  0.00216D0,  0.00148D0,  0.00096D0,  0.00064D0,
     &     0.00043D0,  0.00027D0,  0.00018D0,  0.00006D0,  0.00002D0,
     &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0/
      DATA (FMRS(2,8,I,14),I=1,49)/
     &     2.39126D0,  1.99450D0,  1.66281D0,  1.49454D0,  1.38536D0,
     &     1.30604D0,  1.08660D0,  0.90248D0,  0.80863D0,  0.74747D0,
     &     0.70276D0,  0.57787D0,  0.47070D0,  0.41497D0,  0.37825D0,
     &     0.35132D0,  0.31319D0,  0.27591D0,  0.23714D0,  0.21153D0,
     &     0.17666D0,  0.15129D0,  0.13023D0,  0.10742D0,  0.08751D0,
     &     0.07010D0,  0.05525D0,  0.04280D0,  0.03250D0,  0.02426D0,
     &     0.01784D0,  0.01291D0,  0.00918D0,  0.00650D0,  0.00451D0,
     &     0.00308D0,  0.00210D0,  0.00146D0,  0.00091D0,  0.00061D0,
     &     0.00040D0,  0.00024D0,  0.00017D0,  0.00007D0,  0.00002D0,
     &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0/
      DATA (FMRS(2,8,I,15),I=1,49)/
     &     2.76033D0,  2.28068D0,  1.88356D0,  1.68366D0,  1.55456D0,
     &     1.46111D0,  1.20412D0,  0.99043D0,  0.88227D0,  0.81205D0,
     &     0.76076D0,  0.61847D0,  0.49766D0,  0.43549D0,  0.39480D0,
     &     0.36513D0,  0.32340D0,  0.28293D0,  0.24126D0,  0.21400D0,
     &     0.17728D0,  0.15089D0,  0.12922D0,  0.10598D0,  0.08590D0,
     &     0.06852D0,  0.05375D0,  0.04146D0,  0.03141D0,  0.02338D0,
     &     0.01716D0,  0.01238D0,  0.00882D0,  0.00618D0,  0.00431D0,
     &     0.00292D0,  0.00200D0,  0.00136D0,  0.00088D0,  0.00058D0,
     &     0.00038D0,  0.00023D0,  0.00015D0,  0.00006D0,  0.00002D0,
     &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0/
      DATA (FMRS(2,8,I,16),I=1,49)/
     &     3.14075D0,  2.57242D0,  2.10607D0,  1.87299D0,  1.72314D0,
     &     1.61501D0,  1.31935D0,  1.07560D0,  0.95301D0,  0.87374D0,
     &     0.81592D0,  0.65651D0,  0.52253D0,  0.45423D0,  0.40982D0,
     &     0.37760D0,  0.33254D0,  0.28915D0,  0.24485D0,  0.21612D0,
     &     0.17773D0,  0.15044D0,  0.12821D0,  0.10460D0,  0.08439D0,
     &     0.06702D0,  0.05238D0,  0.04027D0,  0.03041D0,  0.02258D0,
     &     0.01653D0,  0.01190D0,  0.00847D0,  0.00593D0,  0.00412D0,
     &     0.00279D0,  0.00191D0,  0.00129D0,  0.00084D0,  0.00056D0,
     &     0.00036D0,  0.00023D0,  0.00014D0,  0.00006D0,  0.00002D0,
     &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0/
      DATA (FMRS(2,8,I,17),I=1,49)/
     &     3.57238D0,  2.90007D0,  2.35339D0,  2.08215D0,  1.90855D0,
     &     1.78371D0,  1.44428D0,  1.16687D0,  1.02831D0,  0.93907D0,
     &     0.87409D0,  0.69611D0,  0.54805D0,  0.47331D0,  0.42502D0,
     &     0.39015D0,  0.34166D0,  0.29530D0,  0.24836D0,  0.21814D0,
     &     0.17810D0,  0.14991D0,  0.12715D0,  0.10317D0,  0.08284D0,
     &     0.06549D0,  0.05101D0,  0.03909D0,  0.02941D0,  0.02178D0,
     &     0.01590D0,  0.01142D0,  0.00811D0,  0.00570D0,  0.00393D0,
     &     0.00267D0,  0.00181D0,  0.00123D0,  0.00079D0,  0.00053D0,
     &     0.00034D0,  0.00022D0,  0.00013D0,  0.00006D0,  0.00001D0,
     &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0/
      DATA (FMRS(2,8,I,18),I=1,49)/
     &     3.96850D0,  3.19797D0,  2.57613D0,  2.26945D0,  2.07391D0,
     &     1.93368D0,  1.55423D0,  1.24636D0,  1.09346D0,  0.99533D0,
     &     0.92399D0,  0.72966D0,  0.56941D0,  0.48914D0,  0.43755D0,
     &     0.40046D0,  0.34910D0,  0.30027D0,  0.25115D0,  0.21971D0,
     &     0.17833D0,  0.14941D0,  0.12622D0,  0.10197D0,  0.08154D0,
     &     0.06423D0,  0.04986D0,  0.03809D0,  0.02858D0,  0.02112D0,
     &     0.01538D0,  0.01101D0,  0.00783D0,  0.00549D0,  0.00377D0,
     &     0.00256D0,  0.00173D0,  0.00118D0,  0.00076D0,  0.00050D0,
     &     0.00033D0,  0.00020D0,  0.00012D0,  0.00005D0,  0.00002D0,
     &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0/
      DATA (FMRS(2,8,I,19),I=1,49)/
     &     4.49525D0,  3.59055D0,  2.86699D0,  2.51271D0,  2.28784D0,
     &     2.12710D0,  1.69466D0,  1.34689D0,  1.17536D0,  1.06574D0,
     &     0.98622D0,  0.77102D0,  0.59540D0,  0.50826D0,  0.45260D0,
     &     0.41278D0,  0.35791D0,  0.30610D0,  0.25436D0,  0.22147D0,
     &     0.17849D0,  0.14870D0,  0.12502D0,  0.10045D0,  0.07994D0,
     &     0.06271D0,  0.04847D0,  0.03689D0,  0.02761D0,  0.02033D0,
     &     0.01477D0,  0.01056D0,  0.00749D0,  0.00523D0,  0.00359D0,
     &     0.00243D0,  0.00165D0,  0.00112D0,  0.00070D0,  0.00047D0,
     &     0.00031D0,  0.00018D0,  0.00012D0,  0.00004D0,  0.00002D0,
     &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0/
      DATA (FMRS(2,8,I,20),I=1,49)/
     &     5.00899D0,  3.97007D0,  3.14567D0,  2.74457D0,  2.49097D0,
     &     2.31023D0,  1.82640D0,  1.44029D0,  1.25101D0,  1.13051D0,
     &     1.04327D0,  0.80852D0,  0.61869D0,  0.52527D0,  0.46592D0,
     &     0.42363D0,  0.36563D0,  0.31116D0,  0.25711D0,  0.22294D0,
     &     0.17857D0,  0.14803D0,  0.12392D0,  0.09909D0,  0.07852D0,
     &     0.06137D0,  0.04727D0,  0.03584D0,  0.02676D0,  0.01965D0,
     &     0.01424D0,  0.01018D0,  0.00720D0,  0.00501D0,  0.00343D0,
     &     0.00232D0,  0.00157D0,  0.00107D0,  0.00066D0,  0.00045D0,
     &     0.00029D0,  0.00018D0,  0.00012D0,  0.00004D0,  0.00001D0,
     &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0/
      DATA (FMRS(2,8,I,21),I=1,49)/
     &     5.51448D0,  4.34048D0,  3.41543D0,  2.96790D0,  2.68596D0,
     &     2.48552D0,  1.95141D0,  1.52811D0,  1.32176D0,  1.19083D0,
     &     1.09623D0,  0.84295D0,  0.63982D0,  0.54059D0,  0.47785D0,
     &     0.43329D0,  0.37244D0,  0.31558D0,  0.25945D0,  0.22413D0,
     &     0.17852D0,  0.14733D0,  0.12285D0,  0.09781D0,  0.07721D0,
     &     0.06012D0,  0.04616D0,  0.03490D0,  0.02597D0,  0.01904D0,
     &     0.01376D0,  0.00981D0,  0.00692D0,  0.00481D0,  0.00330D0,
     &     0.00222D0,  0.00150D0,  0.00102D0,  0.00064D0,  0.00042D0,
     &     0.00028D0,  0.00017D0,  0.00011D0,  0.00004D0,  0.00001D0,
     &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0/
      DATA (FMRS(2,8,I,22),I=1,49)/
     &     6.21231D0,  4.84766D0,  3.78177D0,  3.26973D0,  2.94855D0,
     &     2.72097D0,  2.11789D0,  1.64406D0,  1.41467D0,  1.26974D0,
     &     1.16528D0,  0.88741D0,  0.66681D0,  0.56001D0,  0.49289D0,
     &     0.44543D0,  0.38094D0,  0.32104D0,  0.26228D0,  0.22553D0,
     &     0.17838D0,  0.14638D0,  0.12146D0,  0.09617D0,  0.07554D0,
     &     0.05855D0,  0.04477D0,  0.03372D0,  0.02502D0,  0.01828D0,
     &     0.01316D0,  0.00936D0,  0.00658D0,  0.00457D0,  0.00313D0,
     &     0.00210D0,  0.00142D0,  0.00097D0,  0.00060D0,  0.00039D0,
     &     0.00026D0,  0.00016D0,  0.00010D0,  0.00004D0,  0.00001D0,
     &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0/
      DATA (FMRS(2,8,I,23),I=1,49)/
     &     6.92819D0,  5.36347D0,  4.15110D0,  3.57245D0,  3.21096D0,
     &     2.95557D0,  2.28227D0,  1.75749D0,  1.50504D0,  1.34618D0,
     &     1.23195D0,  0.92986D0,  0.69228D0,  0.57821D0,  0.50690D0,
     &     0.45669D0,  0.38876D0,  0.32601D0,  0.26481D0,  0.22674D0,
     &     0.17816D0,  0.14541D0,  0.12011D0,  0.09461D0,  0.07396D0,
     &     0.05707D0,  0.04348D0,  0.03263D0,  0.02417D0,  0.01758D0,
     &     0.01264D0,  0.00894D0,  0.00628D0,  0.00436D0,  0.00298D0,
     &     0.00199D0,  0.00135D0,  0.00091D0,  0.00057D0,  0.00037D0,
     &     0.00024D0,  0.00015D0,  0.00010D0,  0.00004D0,  0.00001D0,
     &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0/
      DATA (FMRS(2,8,I,24),I=1,49)/
     &     7.64199D0,  5.87362D0,  4.51337D0,  3.86793D0,  3.46620D0,
     &     3.18314D0,  2.44035D0,  1.86558D0,  1.59069D0,  1.41834D0,
     &     1.29468D0,  0.96937D0,  0.71569D0,  0.59480D0,  0.51959D0,
     &     0.46683D0,  0.39572D0,  0.33035D0,  0.26693D0,  0.22767D0,
     &     0.17780D0,  0.14441D0,  0.11876D0,  0.09309D0,  0.07246D0,
     &     0.05571D0,  0.04226D0,  0.03164D0,  0.02333D0,  0.01693D0,
     &     0.01213D0,  0.00857D0,  0.00600D0,  0.00415D0,  0.00282D0,
     &     0.00189D0,  0.00128D0,  0.00086D0,  0.00054D0,  0.00035D0,
     &     0.00022D0,  0.00014D0,  0.00009D0,  0.00003D0,  0.00001D0,
     &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0/
      DATA (FMRS(2,8,I,25),I=1,49)/
     &     8.41285D0,  6.42055D0,  4.89893D0,  4.18106D0,  3.73585D0,
     &     3.42298D0,  2.60571D0,  1.97779D0,  1.67919D0,  1.49264D0,
     &     1.35909D0,  1.00958D0,  0.73928D0,  0.61142D0,  0.53225D0,
     &     0.47690D0,  0.40260D0,  0.33461D0,  0.26898D0,  0.22853D0,
     &     0.17741D0,  0.14339D0,  0.11741D0,  0.09159D0,  0.07099D0,
     &     0.05437D0,  0.04108D0,  0.03067D0,  0.02252D0,  0.01631D0,
     &     0.01165D0,  0.00822D0,  0.00574D0,  0.00396D0,  0.00268D0,
     &     0.00180D0,  0.00120D0,  0.00081D0,  0.00050D0,  0.00033D0,
     &     0.00021D0,  0.00013D0,  0.00008D0,  0.00003D0,  0.00001D0,
     &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0/
      DATA (FMRS(2,8,I,26),I=1,49)/
     &     9.21054D0,  6.98238D0,  5.29207D0,  4.49895D0,  4.00873D0,
     &     3.66510D0,  2.77134D0,  2.08927D0,  1.76669D0,  1.56583D0,
     &     1.42235D0,  1.04868D0,  0.76198D0,  0.62728D0,  0.54426D0,
     &     0.48640D0,  0.40901D0,  0.33853D0,  0.27078D0,  0.22922D0,
     &     0.17691D0,  0.14232D0,  0.11604D0,  0.09010D0,  0.06954D0,
     &     0.05305D0,  0.03996D0,  0.02972D0,  0.02176D0,  0.01572D0,
     &     0.01122D0,  0.00790D0,  0.00548D0,  0.00378D0,  0.00255D0,
     &     0.00171D0,  0.00115D0,  0.00078D0,  0.00048D0,  0.00031D0,
     &     0.00020D0,  0.00012D0,  0.00008D0,  0.00002D0,  0.00001D0,
     &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0/
      DATA (FMRS(2,8,I,27),I=1,49)/
     &    10.01421D0,  7.54466D0,  5.68289D0,  4.81371D0,  4.27818D0,
     &     3.90363D0,  2.93340D0,  2.19757D0,  1.85131D0,  1.63639D0,
     &     1.48318D0,  1.08596D0,  0.78341D0,  0.64217D0,  0.55547D0,
     &     0.49525D0,  0.41494D0,  0.34210D0,  0.27239D0,  0.22977D0,
     &     0.17638D0,  0.14126D0,  0.11473D0,  0.08869D0,  0.06818D0,
     &     0.05182D0,  0.03892D0,  0.02884D0,  0.02107D0,  0.01518D0,
     &     0.01082D0,  0.00760D0,  0.00526D0,  0.00363D0,  0.00244D0,
     &     0.00163D0,  0.00110D0,  0.00075D0,  0.00046D0,  0.00030D0,
     &     0.00019D0,  0.00012D0,  0.00007D0,  0.00002D0,  0.00001D0,
     &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0/
      DATA (FMRS(2,8,I,28),I=1,49)/
     &    10.81038D0,  8.09822D0,  6.06522D0,  5.12048D0,  4.54007D0,
     &     4.13500D0,  3.08954D0,  2.30121D0,  1.93196D0,  1.70343D0,
     &     1.54082D0,  1.12100D0,  0.80336D0,  0.65594D0,  0.56579D0,
     &     0.50334D0,  0.42032D0,  0.34528D0,  0.27377D0,  0.23019D0,
     &     0.17582D0,  0.14022D0,  0.11347D0,  0.08735D0,  0.06690D0,
     &     0.05067D0,  0.03795D0,  0.02804D0,  0.02043D0,  0.01468D0,
     &     0.01043D0,  0.00733D0,  0.00506D0,  0.00348D0,  0.00235D0,
     &     0.00155D0,  0.00105D0,  0.00071D0,  0.00043D0,  0.00029D0,
     &     0.00018D0,  0.00011D0,  0.00007D0,  0.00002D0,  0.00001D0,
     &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0/
      DATA (FMRS(2,8,I,29),I=1,49)/
     &    11.65265D0,  8.68040D0,  6.46494D0,  5.44008D0,  4.81224D0,
     &     4.37498D0,  3.25050D0,  2.40736D0,  2.01424D0,  1.77163D0,
     &     1.59933D0,  1.15629D0,  0.82328D0,  0.66961D0,  0.57598D0,
     &     0.51130D0,  0.42557D0,  0.34836D0,  0.27505D0,  0.23054D0,
     &     0.17519D0,  0.13914D0,  0.11219D0,  0.08600D0,  0.06563D0,
     &     0.04954D0,  0.03699D0,  0.02726D0,  0.01981D0,  0.01419D0,
     &     0.01006D0,  0.00705D0,  0.00487D0,  0.00334D0,  0.00225D0,
     &     0.00148D0,  0.00100D0,  0.00068D0,  0.00041D0,  0.00027D0,
     &     0.00017D0,  0.00010D0,  0.00006D0,  0.00002D0,  0.00001D0,
     &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0/
      DATA (FMRS(2,8,I,30),I=1,49)/
     &    12.51775D0,  9.27489D0,  6.87071D0,  5.76340D0,  5.08688D0,
     &     4.61667D0,  3.41161D0,  2.51293D0,  2.09575D0,  1.83900D0,
     &     1.65698D0,  1.19078D0,  0.84258D0,  0.68277D0,  0.58574D0,
     &     0.51889D0,  0.43052D0,  0.35121D0,  0.27618D0,  0.23078D0,
     &     0.17451D0,  0.13804D0,  0.11091D0,  0.08467D0,  0.06438D0,
     &     0.04844D0,  0.03605D0,  0.02651D0,  0.01920D0,  0.01373D0,
     &     0.00970D0,  0.00677D0,  0.00468D0,  0.00321D0,  0.00215D0,
     &     0.00142D0,  0.00096D0,  0.00064D0,  0.00040D0,  0.00026D0,
     &     0.00017D0,  0.00010D0,  0.00006D0,  0.00002D0,  0.00001D0,
     &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0/
      DATA (FMRS(2,8,I,31),I=1,49)/
     &    13.38188D0,  9.86555D0,  7.27170D0,  6.08188D0,  5.35680D0,
     &     4.85378D0,  3.56878D0,  2.61532D0,  2.17453D0,  1.90394D0,
     &     1.71244D0,  1.22374D0,  0.86087D0,  0.69518D0,  0.59491D0,
     &     0.52599D0,  0.43513D0,  0.35383D0,  0.27719D0,  0.23095D0,
     &     0.17383D0,  0.13697D0,  0.10968D0,  0.08342D0,  0.06322D0,
     &     0.04742D0,  0.03518D0,  0.02580D0,  0.01865D0,  0.01331D0,
     &     0.00937D0,  0.00652D0,  0.00451D0,  0.00308D0,  0.00206D0,
     &     0.00136D0,  0.00092D0,  0.00061D0,  0.00038D0,  0.00024D0,
     &     0.00016D0,  0.00010D0,  0.00006D0,  0.00002D0,  0.00001D0,
     &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0/
      DATA (FMRS(2,8,I,32),I=1,49)/
     &    14.22455D0, 10.43853D0,  7.65861D0,  6.38821D0,  5.61583D0,
     &     5.08091D0,  3.71848D0,  2.71227D0,  2.24884D0,  1.96503D0,
     &     1.76449D0,  1.25443D0,  0.87775D0,  0.70654D0,  0.60325D0,
     &     0.53242D0,  0.43925D0,  0.35613D0,  0.27800D0,  0.23100D0,
     &     0.17312D0,  0.13592D0,  0.10849D0,  0.08223D0,  0.06212D0,
     &     0.04645D0,  0.03438D0,  0.02514D0,  0.01814D0,  0.01292D0,
     &     0.00909D0,  0.00631D0,  0.00435D0,  0.00297D0,  0.00198D0,
     &     0.00130D0,  0.00088D0,  0.00059D0,  0.00036D0,  0.00023D0,
     &     0.00015D0,  0.00009D0,  0.00006D0,  0.00002D0,  0.00000D0,
     &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0/
      DATA (FMRS(2,8,I,33),I=1,49)/
     &    15.12220D0, 11.04609D0,  8.06700D0,  6.71068D0,  5.88799D0,
     &     5.31921D0,  3.87481D0,  2.81304D0,  2.32586D0,  2.02823D0,
     &     1.81825D0,  1.28597D0,  0.89499D0,  0.71812D0,  0.61173D0,
     &     0.53894D0,  0.44342D0,  0.35844D0,  0.27882D0,  0.23104D0,
     &     0.17241D0,  0.13488D0,  0.10730D0,  0.08105D0,  0.06103D0,
     &     0.04549D0,  0.03359D0,  0.02450D0,  0.01765D0,  0.01253D0,
     &     0.00880D0,  0.00610D0,  0.00420D0,  0.00286D0,  0.00191D0,
     &     0.00125D0,  0.00083D0,  0.00057D0,  0.00034D0,  0.00022D0,
     &     0.00014D0,  0.00008D0,  0.00005D0,  0.00002D0,  0.00000D0,
     &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0/
      DATA (FMRS(2,8,I,34),I=1,49)/
     &    16.02044D0, 11.65091D0,  8.47137D0,  7.02895D0,  6.15599D0,
     &     5.55343D0,  4.02757D0,  2.91088D0,  2.40036D0,  2.08916D0,
     &     1.86995D0,  1.31603D0,  0.91125D0,  0.72894D0,  0.61960D0,
     &     0.54494D0,  0.44718D0,  0.36046D0,  0.27943D0,  0.23094D0,
     &     0.17160D0,  0.13377D0,  0.10610D0,  0.07985D0,  0.05994D0,
     &     0.04455D0,  0.03282D0,  0.02388D0,  0.01715D0,  0.01216D0,
     &     0.00853D0,  0.00590D0,  0.00405D0,  0.00275D0,  0.00184D0,
     &     0.00120D0,  0.00080D0,  0.00054D0,  0.00033D0,  0.00021D0,
     &     0.00013D0,  0.00008D0,  0.00005D0,  0.00002D0,  0.00000D0,
     &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0/
      DATA (FMRS(2,8,I,35),I=1,49)/
     &    16.92092D0, 12.25466D0,  8.87333D0,  7.34454D0,  6.42124D0,
     &     5.78493D0,  4.17791D0,  3.00675D0,  2.47316D0,  2.14860D0,
     &     1.92031D0,  1.34518D0,  0.92693D0,  0.73935D0,  0.62715D0,
     &     0.55068D0,  0.45078D0,  0.36238D0,  0.28002D0,  0.23083D0,
     &     0.17082D0,  0.13273D0,  0.10496D0,  0.07873D0,  0.05891D0,
     &     0.04367D0,  0.03209D0,  0.02331D0,  0.01669D0,  0.01182D0,
     &     0.00827D0,  0.00571D0,  0.00391D0,  0.00265D0,  0.00178D0,
     &     0.00117D0,  0.00077D0,  0.00052D0,  0.00031D0,  0.00020D0,
     &     0.00012D0,  0.00008D0,  0.00005D0,  0.00002D0,  0.00000D0,
     &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0/
      DATA (FMRS(2,8,I,36),I=1,49)/
     &    17.79951D0, 12.84117D0,  9.26208D0,  7.64895D0,  6.67663D0,
     &     6.00749D0,  4.32176D0,  3.09803D0,  2.54226D0,  2.20489D0,
     &     1.96790D0,  1.37254D0,  0.94153D0,  0.74899D0,  0.63410D0,
     &     0.55594D0,  0.45404D0,  0.36409D0,  0.28048D0,  0.23067D0,
     &     0.17006D0,  0.13172D0,  0.10387D0,  0.07767D0,  0.05796D0,
     &     0.04286D0,  0.03142D0,  0.02277D0,  0.01627D0,  0.01150D0,
     &     0.00803D0,  0.00554D0,  0.00379D0,  0.00256D0,  0.00172D0,
     &     0.00113D0,  0.00074D0,  0.00050D0,  0.00030D0,  0.00019D0,
     &     0.00012D0,  0.00007D0,  0.00005D0,  0.00002D0,  0.00000D0,
     &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0/
      DATA (FMRS(2,8,I,37),I=1,49)/
     &    18.71000D0, 13.44641D0,  9.66151D0,  7.96092D0,  6.93787D0,
     &     6.23483D0,  4.46802D0,  3.19039D0,  2.61196D0,  2.26153D0,
     &     2.01571D0,  1.39986D0,  0.95599D0,  0.75847D0,  0.64090D0,
     &     0.56106D0,  0.45717D0,  0.36568D0,  0.28085D0,  0.23044D0,
     &     0.16924D0,  0.13067D0,  0.10276D0,  0.07660D0,  0.05700D0,
     &     0.04204D0,  0.03075D0,  0.02224D0,  0.01586D0,  0.01118D0,
     &     0.00780D0,  0.00537D0,  0.00367D0,  0.00247D0,  0.00167D0,
     &     0.00108D0,  0.00071D0,  0.00047D0,  0.00029D0,  0.00018D0,
     &     0.00011D0,  0.00006D0,  0.00004D0,  0.00002D0,  0.00000D0,
     &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0/
      DATA (FMRS(2,8,I,38),I=1,49)/
     &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
     &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
     &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
     &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
     &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
     &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
     &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
     &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
     &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0,
     &     0.00000D0,  0.00000D0,  0.00000D0,  0.00000D0/
      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 'HERWIG65.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
C-----------------------------------------------------------------------
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 'HERWIG65.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),IFGO
      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,IFGO)
      IF(IFGO) GOTO 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,IFGO)
        IF(IFGO) GOTO 120
        NMODES(IDKY)=NMODES(IDKY)+1
        IF (NMODES(IDKY).GT.NMXMOD) THEN
          CALL HWWARN('HWUDKS',100)
          GOTO 999
        ENDIF
        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 'HERWIG65.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
      SAVE BGCOLS,TBCOLS,ASPIN
      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.5: 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.5: 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.5 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.5:</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.5: ',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,E10.3,',',I3,' Modes')
   90   FORMAT(/1X,I3,1X,A8,1X,I8,1X,F8.3,1X,I2,1X,A3,1X,1P,E10.3,1X,I3)
  100   FORMAT(A1,'hline',I4,' & ',A37,' & $',I8,'$ & ',F8.3,' & $',I2,
     &   A2,'$ & ',A3,' & $',1P,E10.3,'$ & ',I3,' ',A2)
  110   FORMAT(A1,'cline{1-8}'/
     &   I4,' & ',A37,' & $',I8,'$ & ',F8.3,' & $',I2,A2,'$ & ',A3,
     &   ' & $',1P,E10.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,E10.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,E10.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,A8),']=',F5.3,', ME code',I5)
  150   FORMAT(/1X,I3,1X,A8,1X,I8,1X,F8.3,1X,I2,1X,A3,1X,1P,E10.3,1X,I3,
     &   2X,F5.3,1X,I3,5(1X,A8))
  160   FORMAT(A1,'hline',
     &   I4,' & ',A37,' & $',I8,'$ & ',F8.3,' & $',I2,A2,'$ & ',
     &   A3,' & $',1P,E10.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,E10.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>')
      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---------------------------------------------------------------------
      IMPLICIT NONE
      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 'HERWIG65.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 'HERWIG65.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)
      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 'HERWIG65.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)
      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 'HERWIG65.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
      SAVE BGCOLS,TBCOLS,THEAD,TITLE
      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,NRN,ISTAT,IERROR,EVWGT
      ENDIF
      IF (PRNTEX) THEN
        WRITE(IUNITT,40) Z,Z,Z,ISTAT,ZZ,Z,
     &   IPROC,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,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.5} & 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.5</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)
        FIRST(6)=.FALSE.
        FIRST(7)=.FALSE.
        FIRST(8)=.FALSE.
      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 Print 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
      END
CDECK  ID>, HWUGUP.
*CMZ :-        -13/02/02  07.20.46  by  Peter Richardson
*-- Author :    Peter Richardson
C-----------------------------------------------------------------------
      SUBROUTINE HWUGUP
C-----------------------------------------------------------------------
C     Subroutine to handle termination of HERWIG if reaches end of event
C     file
C-----------------------------------------------------------------------
      INCLUDE 'HERWIG65.INC'
C--reset the number of events to the correct value
      NEVHEP = NEVHEP-1
C--output information on the events
      CALL HWEFIN
C--run users end code
      CALL HWAEND
      STOP
      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 'HERWIG65.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) THEN
           CALL HWWARN('HWUFNE',100)
           GOTO 99
         ENDIF
      ENDDO
 99   CONTINUE
C---CHANGE LIGHTEST SUSY HIGGS CODE TO THE PDG VALUE
       DO IHEP=1,NHEP
          IF (IDHEP(IHEP).EQ.26) IDHEP(IHEP)=25
       ENDDO
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)
        NEVHEP=NEVHEP-1
        IF (NEGWTS.AND.EVWGT.LT.ZERO) NNEGEV=NNEGEV-1
C---PRINT FIRST MAXPR EVENTS
      ELSEIF (NEVHEP.LE.MAXPR) THEN
        CALL HWUEPR
      END IF
      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-----------------------------------------------------------------------
      IMPLICIT NONE
      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)
      SAVE W,X
      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)
    5 HWUGAU=HWUGAU+S16
      IF (BB.NE.B) GOTO 1
      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 'HERWIG65.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)
        GOTO 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)
          GOTO 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)
        GOTO 999
      ELSE
        CALL HWWARN('HWUIDT',404)
      ENDIF
 999  RETURN
      END
CDECK  ID>, HWUINC.
*CMZ :-        -12/10/01  09.56.07  by  Peter Richardson
*-- Author :    Bryan Webber
C-----------------------------------------------------------------------
      SUBROUTINE HWUINC
C-----------------------------------------------------------------------
C     COMPUTES CONSTANTS AND LOOKUP TABLES
C---BRW change 27/8/04: include Frixione's fix to reduce PDFSET calls
C-----------------------------------------------------------------------
      INCLUDE 'HERWIG65.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
      INTEGER LPROC,KPROC
      INTEGER IS,IP(3),IQ
      COMMON/SQSQH/JHIGGS,ILBL,JH,IF1MIN,IF1MAX,IF2MIN,IF2MAX
      INTEGER      JHIGGS,ILBL,JH,IF1MIN,IF1MAX,IF2MIN,IF2MAX
      INTEGER ISQ1,ISQ2
      INTEGER IHLP,JHLP,KHLP,ISIGN,ITMP(8)
      LOGICAL FIRST,FSTPDF
      CHARACTER*20 PARM(20)
      EXTERNAL HWBVMC,HWUALF,HWUPCM
      COMMON/HWRPIN/XMIN,XMAX,XPOW,FIRST
      COMMON/W50516/FSTPDF
      CHARACTER*20 PARMSAVE
      DOUBLE PRECISION VALSAVE
      COMMON/HWSFSA/PARMSAVE
      COMMON/HWSFSB/VALSAVE
      SAVE ITMP
      DATA ITMP/0,12,-12,0,0,12,-12,0/
C--read in the information frmo the Les Houches common block if needed
      IF(IPROC.LE.0) CALL HWIGUP
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...define parity of Neutral MSSM Higgses.
      IP(1)=+1
      IP(2)=+1
      IP(3)=-1
C---IPRO=9,11 (lepton-lepton); 31...38 (hadron-hadron) MSSM Higgs production.
      LPROC=MOD(IPROC,10000)
      IF((LPROC.LT.3100).OR.(LPROC.GE.3900))THEN
C...add here MSSM Higgs processes in lepton-lepton collisions.
        IF((LPROC/100.NE.9).AND.(LPROC/100.NE.11))GOTO 666
      END IF
C-----------------------------------------------------------------------
C     HARD 2 LEPTON/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-----------------------------------------------------------------------
C...leptonic processes.
      IF(LPROC/100.EQ.9)THEN
        IF(LPROC.EQ.955)THEN
          IMSSM=-1
          IHIGGS=206-201
        ELSE IF(LPROC.EQ.965)THEN
          IHIGGS=203-201
          IMSSM=-1
        ELSE IF(LPROC.EQ.975)THEN
          IHIGGS=204-201
          IMSSM=-1
        ELSE IF((LPROC.EQ.910).OR.(LPROC.EQ.920).OR.
     &          (LPROC.EQ.960).OR.(LPROC.EQ.970))THEN
          KPROC=MIN(951,LPROC)
          IV=MAX(KPROC-950,0)
          IF((IV.LT.0).OR.(IV.GT.1)) CALL HWWARN('HWUINC',627)
          IH=LPROC/10-90-5*IV
          IF((IH.LE.0).OR.(IH.GT.2)) CALL HWWARN('HWUINC',626)
          IF(LPROC.LE.920)IMSSM=LPROC-400
          IF(LPROC.GE.960)IMSSM=LPROC-300
C...assign enhancement for MSSM Higgs-VV couplings, V->W,Z-gauge bosons.
          DO 545 I=10,10
            ENHANC(I  )=GHWWSS(IH)
            ENHANC(I+1)=GHZZSS(IH)
 545      CONTINUE
          IF(IH.EQ.1)IHIGGS=203-201
          IF(IH.EQ.2)IHIGGS=204-201
          IF(IH.EQ.3)IHIGGS=205-201
        ELSE
          CALL HWWARN('HWUINC',625)
        END IF
      ELSE IF(LPROC/100.EQ.11)THEN
        IMSSM=-1
        IF(LPROC.GE.1140)THEN
          IHIGGS=207-201
          PARITY=1
          GOTO 548
        END IF
        IF(LPROC.LT.1140)IH=3
        IF(LPROC.LT.1130)IH=2
        IF(LPROC.LT.1120)IH=1
        IF((IH.LE.0).OR.(IH.GT.3)) CALL HWWARN('HWUINC',624)
        IQ=LPROC-1100-10*IH
        IF((IQ.LE.0).OR.(IQ.GT.9)) CALL HWWARN('HWUINC',623)
C...assign Neutral MSSM Higgs parity.
        PARITY=IP(IH)
C...assign enhancement for MSSM Higgs-QQ couplings, Q->U,D-type quarks.
        DO 546 I=1,5,2
          ENHANC(I  )=GHDDSS(IH)
          ENHANC(I+1)=GHUUSS(IH)
 546    CONTINUE
C...assign enhancement for MSSM Higgs-LL couplings, L->D-type leptons.
        ENHANC(7)=GHDDSS(IH)
        ENHANC(8)=GHDDSS(IH)
        ENHANC(9)=GHDDSS(IH)
C...assign enhancement for MSSM Higgs-VV couplings, V->W,Z-gauge bosons.
        DO 547 I=10,10
          ENHANC(I  )=GHWWSS(IH)
          ENHANC(I+1)=GHZZSS(IH)
 547    CONTINUE
        IF(IH.EQ.1)IHIGGS=203-201
        IF(IH.EQ.2)IHIGGS=204-201
        IF(IH.EQ.3)IHIGGS=205-201
 548    CONTINUE
C...hadronic processes.
      ELSE IF((LPROC/100.EQ.31).OR.(LPROC/100.EQ.32))THEN
        IF(LPROC/100.EQ.31)THEN
          IF((LPROC.LE.3109).OR.
     &      ((LPROC.GE.3119).AND.(LPROC.LE.3139)).OR.
     &      ((LPROC.GE.3149).AND.(LPROC.LE.3169)).OR.
     &       (LPROC.GE.3179)) CALL HWWARN('HWUINC',622)
          IMSSM=-1
          IF(LPROC/100-LPROC/10*10.LE.4)IHIGGS=5
          IF(LPROC/100-LPROC/10*10.GE.5)IHIGGS=6
        ELSE IF(LPROC/100.EQ.32)THEN
          IF(LPROC.LE.3209) CALL HWWARN('HWUINC',621)
          IF(LPROC.EQ.3219) CALL HWWARN('HWUINC',620)
          IF(LPROC.EQ.3229) CALL HWWARN('HWUINC',619)
          IF(LPROC.EQ.3239) CALL HWWARN('HWUINC',618)
          IF(LPROC.EQ.3249) CALL HWWARN('HWUINC',617)
          IF(LPROC.EQ.3259) CALL HWWARN('HWUINC',616)
          IF(LPROC.EQ.3269) CALL HWWARN('HWUINC',615)
          IF(LPROC.EQ.3279) CALL HWWARN('HWUINC',614)
          IF(LPROC.EQ.3289) CALL HWWARN('HWUINC',613)
          IF(LPROC.GE.3299) CALL HWWARN('HWUINC',612)
          IMSSM=-1
          IF(LPROC.LT.3300)IHIGGS=4
          IF(LPROC.LT.3290)IHIGGS=3
          IF(LPROC.LT.3280)IHIGGS=2
          IF(LPROC.LT.3270)IHIGGS=4
          IF(LPROC.LT.3260)IHIGGS=3
          IF(LPROC.LT.3250)IHIGGS=2
          IF(LPROC.LT.3240)IHIGGS=4
          IF(LPROC.LT.3230)IHIGGS=3
          IF(LPROC.LT.3220)IHIGGS=2
        END IF
C...assign squarks/Higgs-flavours.
        IF(LPROC/100.EQ.31)JHIGGS=1
        IF(LPROC/100.EQ.32)JHIGGS=IHIGGS-1
        IF(LPROC/100.EQ.31)ILBL=3100
        IF(LPROC/100.EQ.32)ILBL=3200
        IHLP=LPROC-ILBL-60-JHIGGS*10
        IF(LPROC.LT.ILBL+70)IHLP=LPROC-ILBL-30-JHIGGS*10
        IF(LPROC.LT.ILBL+40)IHLP=LPROC-ILBL   -JHIGGS*10
        IF(IHLP.LE.8)ISIGN=-1
        IF(IHLP.LE.4)ISIGN=+1
        JHLP=IHLP/5
        KHLP=IHLP/(3+4*JHLP)
        ISQ1=405+JHLP+12*KHLP
        IF(ILBL.EQ.3100)THEN
          ISQ2=ISQ1+ITMP(IHLP)+6+ISIGN
          IF(ISIGN.EQ.+1)JH=206
          IF(ISIGN.EQ.-1)JH=207
          IF(ISIGN.EQ.+1)JHIGGS=4
          IF(ISIGN.EQ.-1)JHIGGS=5
        ELSE IF(ILBL.EQ.3200)THEN
          ISQ2=ISQ1+ITMP(IHLP)+6
          IF(JHIGGS.EQ.1)JH=203
          IF(JHIGGS.EQ.2)JH=204
          IF(JHIGGS.EQ.3)JH=205
        END IF
        IF1MIN=ISQ1
        IF1MAX=ISQ1
        IF2MIN=ISQ2
        IF2MAX=ISQ2
        IF((LPROC.EQ.3110).OR.(LPROC.EQ.3210).OR.
     &     (LPROC.EQ.3220).OR.(LPROC.EQ.3230).OR.
     &     (LPROC.EQ.3140).OR.(LPROC.EQ.3240).OR.
     &     (LPROC.EQ.3250).OR.(LPROC.EQ.3260).OR.
     &     (LPROC.EQ.3170).OR.(LPROC.EQ.3270).OR.
     &     (LPROC.EQ.3280).OR.(LPROC.EQ.3290))THEN
          IF1MIN=405
          IF1MAX=418
          IF2MIN=411
          IF2MAX=424
        END IF
      ELSE IF(LPROC/100.EQ.33)THEN
        IF((LPROC.EQ.3350).OR.(LPROC.EQ.3355))THEN
          IMSSM=-1
          IHIGGS=206-201
        ELSE IF((LPROC.EQ.3310).OR.(LPROC.EQ.3320).OR.
     &          (LPROC.EQ.3360).OR.(LPROC.EQ.3370))THEN
          KPROC=MIN(3351,LPROC)
          IV=MAX(KPROC-3350,0)
          IF((IV.LT.0).OR.(IV.GT.1)) CALL HWWARN('HWUINC',611)
          IH=LPROC/10-330-5*IV
          IF((IH.LE.0).OR.(IH.GT.2)) CALL HWWARN('HWUINC',610)
          IF(LPROC.LE.3320)IMSSM=LPROC-2600
          IF(LPROC.GE.3360)IMSSM=LPROC-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((LPROC.EQ.3315).OR.(LPROC.EQ.3365))THEN
          IHIGGS=203-201
          IMSSM=-1
        ELSE IF((LPROC.EQ.3325).OR.(LPROC.EQ.3375))THEN
          IHIGGS=204-201
          IMSSM=-1
        ELSE IF(LPROC.EQ.3335)THEN
          IHIGGS=205-201
          IMSSM=-1
        ELSE
          CALL HWWARN('HWUINC',609)
        END IF
      ELSE IF(LPROC/100.EQ.34)THEN
        IMSSM=-1
        IF(LPROC.EQ.3410)IHIGGS=203-201
        IF(LPROC.EQ.3420)IHIGGS=204-201
        IF(LPROC.EQ.3430)IHIGGS=205-201
        IF(LPROC.EQ.3450)IHIGGS=206-201
        IF(IHIGGS.EQ.0) CALL HWWARN('HWUINC',608)
      ELSE IF(LPROC/100.EQ.35)THEN
        IMSSM=-1
        IHIGGS=206-201
      ELSE IF(LPROC/100.EQ.36)THEN
        IF((LPROC.NE.3610).AND.(LPROC.NE.3620).AND.
     &     (LPROC.NE.3630)) CALL HWWARN('HWUINC',607)
        IH=LPROC/10-360
        IF((IH.LE.0).OR.(IH.GT.3)) CALL HWWARN('HWUINC',606)
        ID=LPROC-3600-10*IH
        IF((ID.LT.0).OR.(ID.GT.9)) CALL HWWARN('HWUINC',605)
        IMSSM=LPROC-(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
      ELSE IF(LPROC/100.EQ.37)THEN
        IH=LPROC/10-370
        IF((IH.LE.0).OR.(IH.GT.2)) CALL HWWARN('HWUINC',604)
        IMSSM=LPROC-1900
C...assign enhancement for MSSM Higgs-VV couplings, V->W,Z-gauge bosons.
        DO 333 I=10,10
          ENHANC(I  )=GHWWSS(IH)
          ENHANC(I+1)=GHZZSS(IH)
 333    CONTINUE
        IF(IH.EQ.1)IHIGGS=203-201
        IF(IH.EQ.2)IHIGGS=204-201
        IF(IH.EQ.3)IHIGGS=205-201
      ELSE IF(LPROC/100.EQ.38)THEN
        IMSSM=-1
        IF((LPROC.EQ.3839).OR.(LPROC.EQ.3869).OR.(LPROC.EQ.3899))THEN
          IHIGGS=207-201
          PARITY=1
          GOTO 445
        END IF
        IF(LPROC.LT.4000)IS=6
        IF(LPROC.LT.3870)IS=3
        IF(LPROC.LT.3840)IS=0
        IH=LPROC/10-380-IS
        IF((IH.LE.0).OR.(IH.GT.3)) CALL HWWARN('HWUINC',603)
        IQ=LPROC-3800-10*(IH+IS)
        IF((IQ.LE.0).OR.(IQ.GT.6)) CALL HWWARN('HWUINC',602)
C...assign Neutral MSSM Higgs parity.
        PARITY=IP(IH)
C...assign enhancement for MSSM Higgs-QQ couplings, Q->U,D-type quarks.
        DO 444 I=1,5,2
          ENHANC(I  )=GHDDSS(IH)
          ENHANC(I+1)=GHUUSS(IH)
 444    CONTINUE
        IF(IH.EQ.1)IHIGGS=203-201
        IF(IH.EQ.2)IHIGGS=204-201
        IF(IH.EQ.3)IHIGGS=205-201
 445    CONTINUE
      END IF
      IF((IMSSM.NE.-1).AND.(IPROC.GE.10000))IMSSM=IMSSM+10000
 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
C--switch on three body matrix elements if doing spin correlations
      IF(SYSPIN) THREEB=.TRUE.
C--output spin correlation options
      WRITE(6,35) SYSPIN,THREEB,FOURB
      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)
  35  FORMAT(10X,'DECAY SPIN CORRELATIONS=',L5/
     &       10X,'SUSY THREE BODY ME     =',L5/
     &       10X,'SUSY FOUR  BODY ME     =',L5)
  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.EQ.8.OR.IPRO.EQ.9.OR.IPRO.EQ.11.OR.
     &   (IPRO.GE.30.AND.IPRO.LE.41)).AND..NOT.SUSYIN)
     &    CALL HWWARN('HWUINC',601)
C---IMPORTANCE SAMPLING
      FIRST=.TRUE.
      XMIN=0
      XMAX=0
      XPOW=-1
      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--Gauge Boson pairs in hadron-hadron
      ELSEIF(IPRO.EQ.28) THEN
        IF(EMMIN.EQ.ZERO) EMMIN=20.0D0
C--Drell-Yan + 2 jets processes
      ELSEIF(IPRO.EQ.29) THEN
        IF(EMMIN.EQ.ZERO) EMMIN=20.0D0
        IF(PTMAX.GT.ETLIM) PTMAX = ETLIM
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 = MOD(IPROC,100)
          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.10.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.10.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.12.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.12.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 =',E11.4/
     &         10X,'MAX ABS(Q**2) FOR DILS =',E11.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=',E11.4/
     &         10X,'MAX ABS(Q**2) FOR J/PSI=',E11.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)          =',E11.4/
     &         10X,'MAX ABS(Q**2)          =',E11.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   =',1PE11.4/
     &         10X,'1-MAX MTM FRAC FOR ISR =',1PE11.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).OR.
     &  ((IPRO.EQ.9).AND.(MOD(IPROC,10000).EQ.960)).OR.
     &  ((IPRO.EQ.9).AND.(MOD(IPROC,10000).EQ.970)))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,'(1X)')
        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)=FLOAT(MODPDF(I))
            PARMSAVE=PARM(1)
            VALSAVE=VAL(1)
            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)
              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,'(1X)')
      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---TAU DECAY PACKAGE
      IF(TAUDEC.EQ.'TAUOLA') THEN
        IF(IPRINT.NE.0) WRITE(6,475) 'TAUOLA'
        CALL HWDTAU(-1,0,0.0D0)
      ENDIF
  475 FORMAT(10X,A,' TAU 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---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
C--optimize the weights for the channels if needed
      CALL HWIPHS(2)
C--perform the initialisation of the SUSY ME's
      IF(SYSPIN.OR.THREEB.OR.FOURB) THEN
        CALL HWISPN
        IF (IPRINT.NE.0) WRITE (6,510)
 510    FORMAT(/10X,'CHECKING SUSY DECAY MATRIX ELEMENTS')
      ENDIF
C Print particle decay tables here
      IF (IPRINT.GE.2) CALL HWUDPR
C--   initialise photos if needed
      IF ((TAUDEC.EQ.'TAUOLA'.AND.IFPHOT.EQ.1).OR.ITOPRD.EQ.1)
     &     CALL PHOINI
      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 'HERWIG65.INC'
      DOUBLE PRECISION HWRGEN,HWRGET,DUMMY
      REAL TL
      LOGICAL CALLED,HWRLOG
      EXTERNAL HWRGEN,HWRGET,HWRLOG
      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)
      ENDIF
      CALLED=.FALSE.
C---CHECK TIME LEFT
      CALL HWUTIM(TL)
      IF (TL.LT.TLOUT) CALL HWWARN('HWUINE',200)
C---UPDATE RANDOM NUMBER SEED
      DUMMY = HWRGET(NRN)
      NEVHEP=NEVHEP+1
      IF (NEGWTS.AND.EVWGT.LT.ZERO) NNEGEV=NNEGEV+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.GE.1300.AND.IPROC.LT.10000.AND.
     &      (IPROC.EQ.8000.OR.HWRLOG(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
      IF(SYSPIN) THEN
        NSPN = 0
        CALL HWVZRI(  NMXHEP,ISNHEP)
        CALL HWVZRI(  NMXSPN,JMOSPN)
        CALL HWVZRI(2*NMXSPN,JDASPN)
        CALL HWVZRI(  NMXSPN, IDSPN)
      ENDIF
      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-----------------------------------------------------------------------
      IMPLICIT NONE
      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----------------------------------------------------------------------
      IMPLICIT NONE
      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-----------------------------------------------------------------------
      IMPLICIT NONE
      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)
      SAVE A1,A2,A3,A4,A5,A6,A7,A8,A9,A10,ZETA2
      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-----------------------------------------------------------------------
      IMPLICIT NONE
      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-----------------------------------------------------------------------
      IMPLICIT NONE
      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-----------------------------------------------------------------------
      IMPLICIT NONE
      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)
      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-----------------------------------------------------------------------
      IMPLICIT NONE
      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--BRW fix 27/8/04: changed from mass to mass-squared BW formula
C-----------------------------------------------------------------------
      INCLUDE 'HERWIG65.INC'
      DOUBLE PRECISION HWUMBW,HWRGEN,WMX,TAU,GAM,T,TM
      INTEGER ID
C--WMX IS MAX NUMBER OF WIDTHS FROM NOMINAL MASS
      WMX=GAMMAX
      HWUMBW=RMASS(ID)
      IF(ID.EQ.198.OR.ID.EQ.199) THEN
        TAU = HBAR/GAMW
      ELSEIF(ID.EQ.200) THEN
        TAU = HBAR/GAMZ
      ELSEIF(ID.EQ.201) THEN
        TAU = HBAR/GAMH
      ELSE
        TAU=RLTIM(ID)
      ENDIF
      IF (TAU.EQ.ZERO.OR.TAU.GT.1D-18) RETURN
      GAM=HBAR/TAU
 1    T=TAN(PIFAC*(HWRGEN(0)-HALF))
      TM=RMASS(ID)*(RMASS(ID)+GAM*T)
      IF(TM.LT.ZERO) GOTO 1
      TM=SQRT(TM)
      IF (ABS(TM-RMASS(ID)).GT.WMX*GAM) GOTO 1
      HWUMBW=TM
      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-----------------------------------------------------------------------
      IMPLICIT NONE
      INTEGER N,I,M,NN(7)
      CHARACTER*1 NCHAR(0:9)
      CHARACTER*7 HWUNST
      SAVE NCHAR
      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)
      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-----------------------------------------------------------------------
      IMPLICIT NONE
      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-----------------------------------------------------------------------
      IMPLICIT NONE
      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-----------------------------------------------------------------------
      IMPLICIT NONE
      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)
      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-----------------------------------------------------------------------
      IMPLICIT NONE
      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)
      SAVE GTOF,TV
      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/
      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
      END
CDECK  ID>, HWUPUP.
*CMZ :-        -13/02/02  16.42.23  by  Peter Richardson
*-- Author :    Bryan Webber
C----------------------------------------------------------------------
      SUBROUTINE HWUPUP
C----------------------------------------------------------------------
C     Prints contents of the GUPI (Generic User Process Interface)
C     common block HEPEUP
C----------------------------------------------------------------------
      INCLUDE 'HERWIG65.INC'
      INTEGER MAXNUP
      PARAMETER (MAXNUP=500)
      INTEGER NUP,IDPRUP,IDUP,ISTUP,MOTHUP,ICOLUP
      DOUBLE PRECISION XWGTUP,SCALUP,AQEDUP,AQCDUP,PUP,VTIMUP,SPINUP
      COMMON/HEPEUP/NUP,IDPRUP,XWGTUP,SCALUP,AQEDUP,AQCDUP,
     &              IDUP(MAXNUP),ISTUP(MAXNUP),MOTHUP(2,MAXNUP),
     &              ICOLUP(2,MAXNUP),PUP(5,MAXNUP),VTIMUP(MAXNUP),
     &              SPINUP(MAXNUP)
      INTEGER IUP,IWIG,I
      CHARACTER*8 NAME
      PRINT *
      PRINT *, ' I ISTUP IDUP NAME  MOTHUP ICOLUP     PUP'
      DO IUP=1,NUP
        CALL HWUIDT(1,IDUP(IUP),IWIG,NAME)
        PRINT 11,IUP,ISTUP(IUP),IDUP(IUP),NAME,MOTHUP(1,IUP),
     &  MOTHUP(2,IUP),ICOLUP(1,IUP),ICOLUP(2,IUP),(PUP(I,IUP),I=1,5)
      Enddo
 11   Format(2I3,I4,2X,A8,2I3,2I4,5F8.1)
      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 'HERWIG65.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)
      SAVE MAPF,MAPC
      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   =',E10.3,' antiparticle=',E10.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) THEN
        CALL HWWARN('HWURES',101)
        GOTO 999
      ENDIF
      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)
        GOTO 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) THEN
          CALL HWWARN('HWURES',102)
          GOTO 999
        ENDIF
        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) THEN
          CALL HWWARN('HWURES',103)
          GOTO 999
        ENDIF
        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)
        GOTO 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)
        GOTO 180
      ENDIF
      IF (NCDKS+NTMP.GT.NMXCDK) THEN
        CALL HWWARN('HWURES',104)
        GOTO 999
      ENDIF
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
        LOCN(I,J)=0
        RESN(I,J)=0
        RMIN(I,J)=MIN(RMASS(NCLDK(LOCN(I,1)))+RMASS(NCLDK(LOCN(1,J))),
     $       RMASS(NCLDK(LOCN(I,2)))+RMASS(NCLDK(LOCN(2,J))))+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  RETURN
      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-----------------------------------------------------------------------
      IMPLICIT NONE
      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-----------------------------------------------------------------------
      IMPLICIT NONE
      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-----------------------------------------------------------------------
      IMPLICIT NONE
      DOUBLE PRECISION WN,CP,SP,PTCUT,PP,PT,CT,ST,CF,SF,P(3),R(3,3)
      SAVE WN,PTCUT
      DATA WN,PTCUT/1.D0,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>, HWURQM.
*CMZ :-        -17/07/03  11.11.56  by  Bryan Webber
*-- Author :    Bryan Webber
C----------------------------------------------------------------------
      SUBROUTINE HWURQM(SCALE,RQM)
C-----------------------------------------------------------------------
C     RUNNING QUARK MASSES (MSBAR, 2-LOOP, 5 FLAVOUR, NO THRESHOLDS)
C     ASSUMING RMASS(IQ) IS POLE MASS
C-----------------------------------------------------------------------
      INCLUDE 'HERWIG65.INC'
      DOUBLE PRECISION HWUALF,SCALE,ALFAS,P0,C1,CC,MHAT(6),RQM(6)
      INTEGER IQ
      LOGICAL FIRST
      SAVE P0,C1,MHAT,FIRST
      DATA FIRST/.TRUE./
      IF (FIRST) THEN
C---INITIALIZE CONSTANTS
        P0=12./23.
        C1=3731./(3174.*PIFAC)
        CC=C1+4./(3.*PIFAC)
        DO IQ=1,6
           ALFAS=HWUALF(1,RMASS(IQ))
           IF (ALFAS.GT.ZERO) THEN
              MHAT(IQ)=RMASS(IQ)/(1.+CC*ALFAS)/ALFAS**P0
           ELSE
              CALL HWWARN('HWURQM',IQ)
              MHAT(IQ)=ZERO
           ENDIF
        ENDDO
        FIRST=.FALSE.
      ENDIF
      ALFAS=HWUALF(1,SCALE)
      CC=(1.+C1*ALFAS)*ALFAS**P0
      DO IQ=1,6
         RQM(IQ)=MHAT(IQ)*CC
      ENDDO
      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-----------------------------------------------------------------------
      IMPLICIT NONE
      INTEGER N,I,J,IOPT,K(N),IL(500),IR(500)
      DOUBLE PRECISION A(N),B(500)
      IF (N.GT.500) THEN
        CALL HWWARN('HWUSOR',100)
        GOTO 999
      ENDIF
      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
      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
C---REMOVED OBSOLESCENT ARITHMETIC IF STATEMENT
C$$$      IF(IR(J)) 12,30,13
      IF (IR(J).LT.0) THEN
        GOTO 12
      ELSEIF (IR(J).EQ.0) THEN
        GOTO 30
      ELSE
        GOTO 13
      ENDIF
C---END OF REPLACEMENT ARITHMETIC IF STATEMENT
  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  RETURN
      END
CDECK  ID>, HWUSPR.
*CMZ :-        -17/10/01  13:59:28  by  Peter Richardson
*-- Author :    Peter Richardson
C-----------------------------------------------------------------------
      SUBROUTINE HWUSPR
C-----------------------------------------------------------------------
C  Subroutine to output the contents of the spin common block
C-----------------------------------------------------------------------
      INCLUDE 'HERWIG65.INC'
      INTEGER I
C--write out the header
      WRITE(6,1000)
      DO I=1,NSPN
        WRITE(6,1010) I,IDSPN(I),DECSPN(I),JMOSPN(I),JDASPN(1,I),
     &        JDASPN(2,I)
      ENDDO
 1000 FORMAT(/1X,'ISPN',1X,'IDSPN',1X,'DECS',1X,'JMOSPN',1X,' JDASPN '/)
 1010 FORMAT( 1X,  I4  ,1X, I5    ,1X,  L4  ,1X,  I6    ,1X, I3,2X,I3)
      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-----------------------------------------------------------------------
      IMPLICIT NONE
      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 'HERWIG65.INC'
      INTEGER IPDG,IWIG
      CHARACTER*8 NAME
      CALL HWUIDT(3,IPDG,IWIG,NAME)
      IF (IWIG.EQ.20) CALL HWWARN('HWUSTA',500)
      RSTAB(IWIG)=.TRUE.
      WRITE (6,10) IWIG,NAME
   10 FORMAT(/10X,'PARTICLE TYPE',I4,'=',A8,' SET STABLE')
      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
      SAVE MMAX
      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-----------------------------------------------------------------------
      IMPLICIT NONE
      REAL TRES
      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-----------------------------------------------------------------------
      IMPLICIT NONE
      INTEGER N,I
      DOUBLE PRECISION P(N),Q(N),R(N)
      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-----------------------------------------------------------------------
      IMPLICIT NONE
      INTEGER N,I
      DOUBLE PRECISION HWVDOT,PQ,P(N),Q(N)
      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-----------------------------------------------------------------------
      IMPLICIT NONE
      INTEGER N,I
      DOUBLE PRECISION P(N),Q(N)
      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-----------------------------------------------------------------------
      IMPLICIT NONE
      INTEGER N,I
      DOUBLE PRECISION C,P(N),Q(N)
      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-----------------------------------------------------------------------
      IMPLICIT NONE
      INTEGER N,I
      DOUBLE PRECISION P(N),Q(N),R(N)
      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-----------------------------------------------------------------------
      IMPLICIT NONE
      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-----------------------------------------------------------------------
      IMPLICIT NONE
      INTEGER N,I
      DOUBLE PRECISION P(N)
      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 'HERWIG65.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
      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
      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
      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-----------------------------------------------------------------------
      IMPLICIT NONE
      INTEGER IEUPDG,I
      WRITE (6,10)
   10 FORMAT(/10X,'IEUPDG CALLED BUT NOT LINKED')
      IEUPDG=I
      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-----------------------------------------------------------------------
      IMPLICIT NONE
      INTEGER IPDGEU,I
      WRITE (6,10)
   10 FORMAT(/10X,'IPDGEU CALLED BUT NOT LINKED')
      IPDGEU=I
      STOP
      END
CDECK  ID>, INIETC.
*CMZ :-        -17/10/01  10.03.37  by  Peter Richardson
*-- Author :    Peter Richardson
C-----------------------------------------------------------------------
      SUBROUTINE INIETC(JAK1,JAK2,ITDKRC,IFPHOT)
C-----------------------------------------------------------------------
C     DUMMY SUBROUTINE: DELETE AND SET TAUDEC='TAUOLA'
C     IN MAIN PROGRAM IF YOU USE TAUOLA DECAY PACKAGE
C-----------------------------------------------------------------------
      IMPLICIT NONE
      INTEGER JAK1,JAK2,ITDKRC,IFPHOT
      WRITE (6,10)
   10 FORMAT(/10X,'INIETC CALLED BUT NOT LINKED')
      IF (JAK1.GT.1000) WRITE (6,*) JAK2,ITDKRC,IFPHOT
      STOP
      END
CDECK  ID>, INIMAS.
*CMZ :-        -17/10/01  10.03.37  by  Peter Richardson
*-- Author :    Peter Richardson
C-----------------------------------------------------------------------
      SUBROUTINE INIMAS
C-----------------------------------------------------------------------
C     DUMMY SUBROUTINE: DELETE AND SET TAUDEC='TAUOLA'
C     IN MAIN PROGRAM IF YOU USE TAUOLA DECAY PACKAGE
C-----------------------------------------------------------------------
      IMPLICIT NONE
      WRITE (6,10)
   10 FORMAT(/10X,'INIMAS CALLED BUT NOT LINKED')
      STOP
      END
CDECK  ID>, INIPHX.
*CMZ :-        -17/10/01  10.03.37  by  Peter Richardson
*-- Author :    Peter Richardson
C-----------------------------------------------------------------------
      SUBROUTINE INIPHX(CUT)
C-----------------------------------------------------------------------
C     DUMMY SUBROUTINE: DELETE AND SET TAUDEC='TAUOLA'
C     IN MAIN PROGRAM IF YOU USE TAUOLA DECAY PACKAGE
C-----------------------------------------------------------------------
      IMPLICIT NONE
      DOUBLE PRECISION CUT
      WRITE (6,10)
   10 FORMAT(/10X,'INIPHX CALLED BUT NOT LINKED')
      IF (CUT.GT.1D10) CUT=0
      STOP
      END
CDECK  ID>, INITDK.
*CMZ :-        -17/10/01  10.03.37  by  Peter Richardson
*-- Author :    Peter Richardson
C-----------------------------------------------------------------------
      SUBROUTINE INITDK
C-----------------------------------------------------------------------
C     DUMMY SUBROUTINE: DELETE AND SET TAUDEC='TAUOLA'
C     IN MAIN PROGRAM IF YOU USE TAUOLA DECAY PACKAGE
C-----------------------------------------------------------------------
      IMPLICIT NONE
      WRITE (6,10)
   10 FORMAT(/10X,'INITDK CALLED BUT NOT LINKED')
      STOP
      END
CDECK  ID>, PDFSET.
*CMZ :-        -26/04/91  11.11.54  by  Bryan Webber
*-- Author :    Bryan Webber
C----------------------------------------------------------------------
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----------------------------------------------------------------------
c      IMPLICIT NONE
c      DOUBLE PRECISION VAL(20)
c      CHARACTER*20 PARM(20)
c      WRITE (6,10)
c   10 FORMAT(/10X,'PDFSET CALLED BUT NOT LINKED')
c      IF (PARM(1).EQ.'DUMMY') VAL(1)=0
c      STOP
c      END
CDECK  ID>, PHOINI.
*CMZ :-        -17/10/01  10.03.37  by  Peter Richardson
*-- Author :    Peter Richardson
C-----------------------------------------------------------------------
      SUBROUTINE PHOINI
C-----------------------------------------------------------------------
C     DUMMY SUBROUTINE: DELETE AND SET TAUDEC='TAUOLA'
C     IN MAIN PROGRAM IF YOU USE TAUOLA DECAY PACKAGE
C-----------------------------------------------------------------------
      IMPLICIT NONE
      WRITE (6,10)
   10 FORMAT(/10X,'PHOINI CALLED BUT NOT LINKED')
      STOP
      END
CDECK  ID>, PHOTOS.
*CMZ :-        -17/10/01  10.03.37  by  Peter Richardson
*-- Author :    Peter Richardson
C-----------------------------------------------------------------------
      SUBROUTINE PHOTOS(IHEP)
C-----------------------------------------------------------------------
C     DUMMY SUBROUTINE: DELETE AND SET TAUDEC='TAUOLA'
C     IN MAIN PROGRAM IF YOU USE TAUOLA DECAY PACKAGE
C-----------------------------------------------------------------------
      IMPLICIT NONE
      INTEGER IHEP
      WRITE (6,10)
   10 FORMAT(/10X,'PHOTOS CALLED BUT NOT LINKED')
      IF (IHEP.GT.1000) IHEP=0
      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-----------------------------------------------------------------------
      IMPLICIT NONE
      LOGICAL QQLERR
      WRITE (6,10)
   10 FORMAT(/10X,'QQINIT CALLED BUT NOT LINKED')
      IF (QQLERR) WRITE (6,*)
      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
      SAVE AKF
      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
        QQLMAT=0
        WRITE(6,20) IDL
  20    FORMAT(1X,'Lund code particle ',I6,' not recognized')
      ELSEIF(NDIR.EQ.2) THEN
        QQLMAT = AKF(IDL+21)
      ELSE
        QQLMAT=0
        WRITE(6,30)
  30    FORMAT(1X,'Unrecognized option in QQLMAT')
      ENDIF
      END
CDECK  ID>, STRUCTM.
*CMZ :-        -26/04/91  11.11.54  by  Bryan Webber
*-- Author :    Bryan Webber
C-----------------------------------------------------------------------
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-----------------------------------------------------------------------
c      IMPLICIT NONE
c      DOUBLE PRECISION X,QSCA,UPV,DNV,USEA,DSEA,STR,CHM,BOT,TOP,GLU
c      WRITE (6,10)
c  10  FORMAT(/10X,'STRUCTM CALLED BUT NOT LINKED')
c      IF (X.GT.1D10) WRITE (6,*)
c     $     QSCA,UPV,DNV,USEA,DSEA,STR,CHM,BOT,TOP,GLU
c      STOP
c      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)
      SAVE PMC,PMB,AEM,AEM2PI,ALAM,FRACU,FRHO,FOMEGA,FPHI,PMRHO,PMPHI,
     $     NSTEP
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
      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)
      SAVE PMC,PMB
      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
      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)
      SAVE PMC,PMB,AEM2PI
      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
      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.
      SAVE AEM2PI
      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
      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)
      SAVE AEM2PI
      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
      END
C-----------------------------------------------------------------------
CDECK  ID>,  TIMEL.
*CMZ :-        -28/06/01  16.55.32  by  Bryan Webber
*-- Author :    Bryan Webber
C-----------------------------------------------------------------------
      SUBROUTINE TIMEL(TRES)
C-----------------------------------------------------------------------
C     DUMMY TIME SUBROUTINE: DELETE AND REPLACE BY SYSTEM
C     ROUTINE GIVING TRES = CPU TIME REMAINING (SECONDS)
C-----------------------------------------------------------------------
      IMPLICIT NONE
      REAL TRES
      LOGICAL FIRST
      SAVE FIRST
      DATA FIRST/.TRUE./
      IF (FIRST) THEN
      WRITE (6,10)
   10 FORMAT(/10X,'SUBROUTINE TIMEL CALLED BUT NOT LINKED.'/
     &        10X,'DUMMY TIMEL WILL BE USED. DELETE DUMMY'/
     &        10X,'AND LINK CERNLIB FOR CPU TIME REMAINING.')
      FIRST=.FALSE.
      ENDIF
      TRES=1E10
      END
C-----------------------------------------------------------------------
CDECK  ID>,  UPINIT.
*CMZ :-        -16/07/02  10.30.48  by  Peter Richardson
*-- Author :    Peter Richardson
C-----------------------------------------------------------------------
c      SUBROUTINE UPINIT
C-----------------------------------------------------------------------
C     DUMMY UPINIT ROUTINE DELETE AND REPLACE IF USING LES HOUCHES
C     INTERFACE
C-----------------------------------------------------------------------
c      IMPLICIT NONE
c      WRITE (6,10)
c   10 FORMAT(/10X,'UPINIT CALLED BUT NOT LINKED')
c      STOP
c      END
C-----------------------------------------------------------------------
CDECK  ID>,  UPEVNT.
*CMZ :-        -16/07/02  10.30.48  by  Peter Richardson
*-- Author :    Peter Richardson
C-----------------------------------------------------------------------
c      SUBROUTINE UPEVNT
C-----------------------------------------------------------------------
C     DUMMY UPEVNT ROUTINE DELETE AND REPLACE IF USING LES HOUCHES
C     INTERFACE
C-----------------------------------------------------------------------
c      IMPLICIT NONE
c      WRITE (6,10)
c   10 FORMAT(/10X,'UPEVNT CALLED BUT NOT LINKED')
c      STOP
c      END
