Version 6.5-10 added.
authormorsch <morsch@f7af4fe6-9843-0410-8265-dc069ae4e863>
Mon, 2 Oct 2006 10:37:30 +0000 (10:37 +0000)
committermorsch <morsch@f7af4fe6-9843-0410-8265-dc069ae4e863>
Mon, 2 Oct 2006 10:37:30 +0000 (10:37 +0000)
HERWIG/herwig6510.f [new file with mode: 0644]
HERWIG/herwig6510.inc [new file with mode: 0644]

diff --git a/HERWIG/herwig6510.f b/HERWIG/herwig6510.f
new file mode 100644 (file)
index 0000000..fd8b474
--- /dev/null
@@ -0,0 +1,63596 @@
+C  HERWIG---AliRoot/HERWIG
+C-----------------------------------------------------------------------
+C                           H E R W I G
+C
+C            a Monte Carlo event generator for simulating
+C        +---------------------------------------------------+
+C        | Hadron Emission Reactions With Interfering Gluons |
+C        +---------------------------------------------------+
+C I.G. Knowles(*), G. Marchesini(+), M.H.Seymour($,&) and B.R. Webber(#)
+C-----------------------------------------------------------------------
+C with Minimal Supersymmetric Standard Model Matrix Elements by
+C                  S. Moretti(") and K. Odagiri(^)
+C-----------------------------------------------------------------------
+C R parity violating Supersymmetric Decays and Matrix Elements by
+C                          P. Richardson(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.510 - 31st October 2005
+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://hepwww.rl.ac.uk/theory/seymour/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
+      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')
+      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
+      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')
+      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')
+      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')
+      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 :-        -26/10/99  17.46.56  by  Mike Seymour
+*-- Author :    Gennaro Corcella
+C-----------------------------------------------------------------------
+      SUBROUTINE HWBDYP(IOPT)
+C     MATRIX ELEMENT CORRECTIONS TO DRELL-YAN PROCESSES
+C-----------------------------------------------------------------------
+      INCLUDE '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(5),PS(5),PD(5),P2N(5),
+     & PBOS(5),PLAB(5),PTOT(5),P3N(5),SVNTN
+      LOGICAL GLUIN,GP
+      INTEGER EMIT,NOEMIT,IHEP,JHEP,KHEP,ICMF,IOPT,CHEP,
+     & ID2,ID1,K,ID4,ID5,IDBOS,IHAD1,IHAD2,NTMP
+      EXTERNAL HWBVMC,HWRGEN,HWUALF,HWUSQR
+      SAVE PS,PF,ICMF,ID4,ID5
+      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 HWVSUM(4,PP1,PP2,PLAB)
+        CALL HWUMAS(PLAB)
+C------BOOST TO PLAB REST FRAME
+        CALL HWULOF(PLAB,PE,PE)
+        CALL HWULOF(PLAB,PNE,PNE)
+        CALL HWULOF(PLAB,PK,PK)
+        CALL HWULOF(PLAB,PS,PS)
+        CALL HWULOF(PLAB,PF,PF)
+        CALL HWULOF(PLAB,PV,PV)
+C----PUT THE INITIAL PARTON BELONGING TO HADRON 1 ON THE Z-AXIS
+        IF (.NOT.GLUIN) THEN
+          IF (EMIT.EQ.1) THEN
+            CALL HWVEQU(5,PE,PZ)
+          ELSE
+            CALL HWVEQU(5,PNE,PZ)
+          ENDIF
+        ELSE
+          IF (GP) THEN
+            CALL HWVEQU(5,PK,PZ)
+          ELSE
+            IF (EMIT.EQ.1) THEN
+              CALL HWVEQU(5,PE,PZ)
+            ELSE
+              CALL HWVEQU(5,PNE,PZ)
+            ENDIF
+          ENDIF
+        ENDIF
+        MODP=SQRT(PZ(1)**2+PZ(2)**2)
+        CTH=PZ(1)/MODP
+        STH=PZ(2)/MODP
+        CALL HWUROT(PZ,CTH,STH,R3)
+C-----ROTATE EVERYTHING BY R3
+        CALL HWUROF(R3,PE,PE)
+        CALL HWUROF(R3,PNE,PNE)
+        CALL HWUROF(R3,PV,PV)
+        CALL HWUROF(R3,PK,PK)
+        CALL HWUROF(R3,PS,PS)
+        CALL HWUROF(R3,PF,PF)
+C--REORDER ENTRIES:--IHEP=EMITTER,JHEP=NON-EMITTER,KHEP=EMITTED
+        IF (.NOT.GLUIN) THEN
+          IHEP=JMOHEP(EMIT,ICMF)
+          JHEP=JMOHEP(NOEMIT,ICMF)
+        ENDIF
+        CHEP=ICMF
+        IDHW(CHEP)=15
+        IDHEP(CHEP)=IDPDG(15)
+        ICMF=ICMF+1
+        IDHW(ICMF)=IDBOS
+        IDHEP(ICMF)=IDPDG(IDBOS)
+C-----NO GLUON IN THE INITIAL STATE: JUST ADD IT AFTER THE VECTOR BOSON
+        IF (.NOT.GLUIN) THEN
+          KHEP=ICMF+1
+          ISTHEP(KHEP)=114
+C---STATUS OF EMITTER/NON EMITTER
+          ISTHEP(IHEP)=110+EMIT
+          ISTHEP(JHEP)=110+NOEMIT
+        ELSE
+C-----GLUON COMING FROM THE 1ST HADRON
+          IF (GP) THEN
+            KHEP=CHEP-2
+            ISTHEP(KHEP)=111
+C----EMIT=1
+            IF (EMIT.EQ.1) THEN
+              IHEP=KHEP+1
+              ISTHEP(IHEP)=112
+              JHEP=ICMF+1
+              ISTHEP(JHEP)=114
+              IDHW(IHEP)=ID2
+              IF (ID1.LE.6) THEN
+                IDHW(JHEP)=ID1+6
+              ELSE
+                IDHW(JHEP)=ID1-6
+              ENDIF
+            ELSE
+C-------EMIT=2
+              JHEP=KHEP+1
+              ISTHEP(JHEP)=112
+              IDHW(JHEP)=ID2
+              IHEP=ICMF+1
+              ISTHEP(IHEP)=114
+              IF (ID1.LE.6) THEN
+                IDHW(IHEP)=ID1+6
+              ELSE
+                IDHW(IHEP)=ID1-6
+              ENDIF
+            ENDIF
+          ENDIF
+C------GLUON COMING FROM THE HADRON 2
+          IF (.NOT.GP) THEN
+            KHEP=CHEP-1
+            ISTHEP(KHEP)=112
+C-------EMIT=1
+            IF (EMIT.EQ.1) THEN
+              IHEP=KHEP-1
+              ISTHEP(IHEP)=111
+              IDHW(IHEP)=ID1
+              JHEP=ICMF+1
+              ISTHEP(JHEP)=114
+              IF (ID2.LE.6) THEN
+                IDHW(JHEP)=ID2+6
+              ELSE
+                IDHW(JHEP)=ID2-6
+              ENDIF
+            ELSE
+C-------EMIT=2
+              JHEP=KHEP-1
+              ISTHEP(JHEP)=111
+              IDHW(JHEP)=ID1
+              IHEP=ICMF+1
+              ISTHEP(IHEP)=114
+              IF (ID2.LE.6) THEN
+                IDHW(IHEP)=ID2+6
+              ELSE
+                IDHW(IHEP)=ID2-6
+              ENDIF
+            ENDIF
+          ENDIF
+        ENDIF
+        IDHEP(IHEP)=IDPDG(IDHW(IHEP))
+        IDHEP(JHEP)=IDPDG(IDHW(JHEP))
+        ISTHEP(ICMF)=113
+        ISTHEP(CHEP)=110
+        IDHW(KHEP)=13
+        IDHEP(KHEP)=IDPDG(13)
+C---------DEFINE MOMENTA IN THE LAB FRAME
+        CALL HWVEQU(5,PV,PHEP(1,ICMF))
+        CALL HWVEQU(5,PK,PHEP(1,KHEP))
+        CALL HWVEQU(5,PNE,PHEP(1,JHEP))
+        CALL HWVEQU(5,PE,PHEP(1,IHEP))
+        IF (.NOT.GLUIN) THEN
+          CALL HWVSUM(4,PHEP(1,IHEP),PHEP(1,JHEP),PHEP(1,CHEP))
+        ELSE
+          IF (EMIT.EQ.1) THEN
+            CALL HWVSUM(4,PHEP(1,IHEP),PHEP(1,KHEP),PHEP(1,CHEP))
+          ELSE
+            CALL HWVSUM(4,PHEP(1,KHEP),PHEP(1,JHEP),PHEP(1,CHEP))
+          ENDIF
+        ENDIF
+        CALL HWUMAS(PHEP(1,CHEP))
+        IF (.NOT.GLUIN) THEN
+          JMOHEP(1,JHEP)=CHEP
+          JMOHEP(1,IHEP)=CHEP
+          JDAHEP(1,JHEP)=CHEP
+          JDAHEP(1,IHEP)=CHEP
+          JMOHEP(1,KHEP)=CHEP
+          JDAHEP(1,KHEP)=0
+          JMOHEP(1,ICMF)=CHEP
+          JMOHEP(2,ICMF)=ICMF
+          JDAHEP(1,ICMF)=0
+          JDAHEP(2,ICMF)=ICMF
+        ENDIF
+        IF (GLUIN) THEN
+          JMOHEP(2,ICMF)=ICMF
+          JDAHEP(2,ICMF)=ICMF
+          JMOHEP(1,KHEP)=CHEP
+          JDAHEP(1,KHEP)=CHEP
+          JMOHEP(1,IHEP)=CHEP
+          JMOHEP(1,JHEP)=CHEP
+          IF (EMIT.EQ.1) THEN
+            JDAHEP(1,IHEP)=CHEP
+            JDAHEP(1,JHEP)=0
+          ELSE
+            JDAHEP(1,JHEP)=CHEP
+            JDAHEP(1,IHEP)=0
+          ENDIF
+        ENDIF
+C---COLOUR CONNECTIONS
+        IF (.NOT.GLUIN) THEN
+          IF (IDHW(IHEP).LT.IDHW(JHEP)) THEN
+            JMOHEP(2,KHEP)=IHEP
+            JDAHEP(2,KHEP)=JHEP
+            JMOHEP(2,IHEP)=JHEP
+            JDAHEP(2,IHEP)=KHEP
+            JDAHEP(2,JHEP)=IHEP
+            JMOHEP(2,JHEP)=KHEP
+          ELSE
+            JMOHEP(2,KHEP)=JHEP
+            JDAHEP(2,KHEP)=IHEP
+            JMOHEP(2,JHEP)=IHEP
+            JDAHEP(2,JHEP)=KHEP
+            JDAHEP(2,IHEP)=JHEP
+            JMOHEP(2,IHEP)=KHEP
+          ENDIF
+        ENDIF
+        IF (GLUIN) THEN
+          IF (EMIT.EQ.1) THEN
+            IF (IDHEP(IHEP).GT.0) THEN
+              JMOHEP(2,IHEP)=JHEP
+              JDAHEP(2,IHEP)=KHEP
+              JMOHEP(2,JHEP)=KHEP
+              JDAHEP(2,JHEP)=IHEP
+              JMOHEP(2,KHEP)=IHEP
+              JDAHEP(2,KHEP)=JHEP
+            ELSE
+              JMOHEP(2,IHEP)=KHEP
+              JDAHEP(2,IHEP)=JHEP
+              JMOHEP(2,JHEP)=IHEP
+              JDAHEP(2,JHEP)=KHEP
+              JMOHEP(2,KHEP)=JHEP
+              JDAHEP(2,KHEP)=IHEP
+            ENDIF
+          ELSE
+            IF (IDHEP(JHEP).GT.0) THEN
+              JMOHEP(2,JHEP)=IHEP
+              JDAHEP(2,JHEP)=KHEP
+              JMOHEP(2,IHEP)=KHEP
+              JDAHEP(2,IHEP)=JHEP
+              JMOHEP(2,KHEP)=JHEP
+              JDAHEP(2,KHEP)=IHEP
+            ELSE
+              JMOHEP(2,JHEP)=KHEP
+              JDAHEP(2,JHEP)=IHEP
+              JMOHEP(2,IHEP)=JHEP
+              JDAHEP(2,IHEP)=KHEP
+              JMOHEP(2,KHEP)=IHEP
+              JDAHEP(2,KHEP)=JHEP
+            ENDIF
+          ENDIF
+        ENDIF
+        EMSCA=SQRT(EM**2+PHEP(1,ICMF)**2+PHEP(2,ICMF)**2)
+C--------SET STATUS AND LEPTON MOMENTA AFTER THE PARTON SHOWER
+      ELSEIF (IOPT.EQ.2) THEN
+        IF (EMIT.EQ.0.OR.NEVHEP+NWGTS.NE.NTMP) RETURN
+        ISTHEP(JDAHEP(1,ICMF))=195
+        IDHW(NHEP+1)=ID4
+        IDHW(NHEP+2)=ID5
+        IDHEP(NHEP+1)=IDPDG(ID4)
+        IDHEP(NHEP+2)=IDPDG(ID5)
+        ISTHEP(NHEP+1)=113
+        ISTHEP(NHEP+2)=114
+        CW=PHEP(3,ICMF)/SQRT(PHEP(1,ICMF)**2+PHEP(2,ICMF)**2+
+     &       PHEP(3,ICMF)**2)
+        SW=SQRT(1-CW**2)
+        CALL HWUROT(PHEP(1,ICMF),CW,SW,R4)
+        CALL HWUROF(R4,PHEP(1,ICMF),PR)
+        PR(4)=PHEP(4,ICMF)
+        CALL HWUMAS(PR)
+        CALL HWUROF(R4,PS,PS)
+        CALL HWUROF(R4,PF,PF)
+        CALL HWUMAS(PS)
+        CALL HWUMAS(PF)
+        CALL HWUROT(PHEP(1,JDAHEP(1,ICMF)),CW,SW,R5)
+        CALL HWUROF(R5,PHEP(1,JDAHEP(1,ICMF)),PD)
+        PD(4)=PHEP(4,JDAHEP(1,ICMF))
+        CALL HWUMAS(PD)
+        BETA1=(PR(4)*PR(3)-SQRT(PR(4)**2*PD(3)**2-PR(3)**2*PD(3)**2+
+     &       PD(3)**4))/(PD(3)**2+PR(4)**2)
+        GAMMA1=1/SQRT(1-BETA1**2)
+        PHEP(4,NHEP+1)=GAMMA1*PS(4)-BETA1*GAMMA1*PS(3)
+        PHEP(3,NHEP+1)=-BETA1*GAMMA1*PS(4)+GAMMA1*PS(3)
+        PHEP(4,NHEP+2)=GAMMA1*PF(4)-BETA1*GAMMA1*PF(3)
+        PHEP(3,NHEP+2)=-BETA1*GAMMA1*PF(4)+GAMMA1*PF(3)
+        PHEP(1,NHEP+1)=PS(1)
+        PHEP(2,NHEP+1)=PS(2)
+        PHEP(1,NHEP+2)=PF(1)
+        PHEP(2,NHEP+2)=PF(2)
+        CALL HWUMAS(PHEP(1,NHEP+1))
+        CALL HWUMAS(PHEP(1,NHEP+2))
+        CALL HWUROB(R5,PHEP(1,NHEP+1),PHEP(1,NHEP+1))
+        CALL HWUROB(R5,PHEP(1,NHEP+2),PHEP(1,NHEP+2))
+        JDAHEP(1,JDAHEP(1,ICMF))=NHEP+1
+        JDAHEP(2,JDAHEP(1,ICMF))=NHEP+2
+        JMOHEP(1,NHEP+1)=JDAHEP(1,ICMF)
+        JMOHEP(1,NHEP+2)=JDAHEP(1,ICMF)
+        JMOHEP(2,NHEP+1)=NHEP+2
+        JDAHEP(2,NHEP+1)=NHEP+2
+        JMOHEP(2,NHEP+2)=NHEP+1
+        JDAHEP(2,NHEP+2)=NHEP+1
+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
+      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
+          IF (HWRLOG(HALF)) JHEP=JDAHEP(2,IHEP)
+        ELSEIF (IST.GT.112) THEN
+          IF ((ID.GT.6.AND.ID.LT.13).OR.
+     &        (ID.GT.214.AND.ID.LT.221)) JHEP=JDAHEP(2,IHEP)
+        ELSE
+          IF (ID.LT.7.OR.(ID.GT.208.AND.ID.LT.215)) JHEP=JDAHEP(2,IHEP)
+        ENDIF
+        IF (JHEP.LE.0.OR.JHEP.GT.NHEP) THEN
+          CALL HWWARN('HWBGEN',1)
+          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
+ 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)
+      INTEGER LJET,IJ1,IST,IP,ICM,IP1,IP2,NP,IHEP,MHEP,JP,KP,LP,KHEP,
+     & JHEP,NE,IJT,IEND(2),IJET(NMXJET),IPAR(NMXJET)
+      LOGICAL AZCOR,JETRAD,DISPRO,DISLOW
+      EXTERNAL HWULDO
+      PARAMETER (EPS=1.D-4)
+      IF (IERROR.NE.0) RETURN
+      AZCOR=AZSOFT.OR.AZSPIN
+      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
+          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
+            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=SQRT(DET)+ET0
+          AL(1)= 2.*PM0*PP(1)/DET
+          AL(2)=(PM0/PP(2))*(1.-2.*ET(1)/DET)
+          PB(1)=0.
+          PB(2)=0.
+          PB(5)=2.
+          DO 160 IP=1,2
+          PB(3)=AL(IP)-(1./AL(IP))
+          PB(4)=AL(IP)+(1./AL(IP))
+          IJT=IJET(IP)
+          DO 140 IHEP=IJT,IEND(IP)
+          CALL HWULOF(PB,PHEP(1,IHEP),PHEP(1,IHEP))
+          CALL HWULF4(PB,VHEP(1,IHEP),VHEP(1,IHEP))
+  140     ISTHEP(IHEP)=ISTHEP(IHEP)+10
+          CALL HWVDIF(4,VHEP(1,IPAR(IP)),VHEP(1,IJT),DISP)
+          DO 150 IHEP=IJT,IEND(IP)
+  150     CALL HWVSUM(4,DISP,VHEP(1,IHEP),VHEP(1,IHEP))
+          IF (IEND(IP).GT.IJT+1) THEN
+            ISTHEP(IJT+1)=100
+          ELSEIF (IEND(IP).EQ.IJT) THEN
+C---NON-PARTON JET
+            ISTHEP(IJT)=3
+          ENDIF
+  160     CONTINUE
+        ENDIF
+        ISTHEP(ICM)=120
+      ELSE
+C---TIMELIKE JETS
+C---SPECIAL CASE: IF HARD PROCESS IS W/Z DECAY, PERFORM KINEMATIC
+C   RECONSTRUCTION IN ITS REST FRAME INSTEAD OF THE LAB FRAME
+        IF (IDHW(ICM).GE.198.AND.IDHW(ICM).LE.200.AND.WZRFR) THEN
+          CALL HWVEQU(5,PHEP(1,ICM),PLAB)
+          CALL HWULOF(PLAB,PHEP(1,ICM),PHEP(1,ICM))
+          CALL HWULF4(PLAB,VHEP(1,ICM),VHEP(1,ICM))
+          DO 165 IP=1,NP
+            CALL HWULOF(PLAB,PHEP(1,IPAR(IP)),PHEP(1,IPAR(IP)))
+            CALL HWULF4(PLAB,VHEP(1,IPAR(IP)),VHEP(1,IPAR(IP)))
+ 165      CONTINUE
+        ENDIF
+C   special for DIS: preserve outgoing lepton momentum
+        IF (DISPRO) THEN
+          CALL HWVEQU(5,PHEP(1,IPAR(1)),PHEP(1,IJET(1)))
+          ISTHEP(IJET(1))=1
+          LP=2
+        ELSE
+          CALL HWVEQU(5,PHEP(1,ICM),PC)
+C--- PQ AND PC ARE OLD AND NEW PARTON CM
+          CALL HWVSUM(4,PHEP(1,IPAR(1)),PHEP(1,IPAR(2)),PQ)
+          PQ(5)=PHEP(5,ICM)
+          IF (NP.GT.2) THEN
+            DO 170 KP=3,NP
+  170       CALL HWVSUM(4,PHEP(1,IPAR(KP)),PQ,PQ)
+          ENDIF
+          LP=1
+        ENDIF
+        IF (.NOT.DISLOW) THEN
+C---FIND JET CM MOMENTA
+          ECM=PQ(5)
+          EMS=0.
+          JETRAD=.FALSE.
+          DO 180 KP=LP,NP
+          EMJ=PHEP(5,IJET(KP))
+          EMP=PHEP(5,IPAR(KP))
+          JETRAD=JETRAD.OR.EMJ.NE.EMP
+          EMS=EMS+EMJ
+          PM(KP)= EMJ**2
+C---N.B. ROUNDING ERRORS HERE AT HIGH ENERGIES
+          PJ(KP)=(HWULDO(PHEP(1,IPAR(KP)),PQ)/ECM)**2-EMP**2
+          IF (PJ(KP).LE.ZERO) THEN
+            CALL HWWARN('HWBJCO',104)
+            GOTO 999
+          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) 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
+        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
+          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.EQ.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.EQ.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.EQ.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.EQ.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.EQ.2) WRITE(6,3010) WSUM,WSSUM
+        IF(IPRINT.EQ.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.EQ.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-----------------------------------------------------------------------
+      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
+      LOGICAL QUARKS
+      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)
+      IF (IPAIR.NE.IBOS .OR. IDHW(ICMF).NE.201) THEN
+      IF (RHOHEP(1,IBOS)+RHOHEP(2,IBOS)+RHOHEP(3,IBOS).LE.ZERO) THEN
+C---COPY PARENT HELICITY IF IT WAS A GAUGE BOSON
+        IF (IDHW(IMOTH).GE.198.AND.IDHW(IMOTH).LE.200) THEN
+          CALL HWVEQU(3,RHOHEP(1,IMOTH),RHOHEP(1,IBOS))
+          IF (RHOHEP(1,IBOS)+RHOHEP(2,IBOS)+RHOHEP(3,IBOS).GT.ZERO)
+     &    GOTO 20
+C---MAY BE FROM A SUSY DECAY
+        ELSEIF (ABS(IDHEP(IMOTH)).LT.1000000) THEN
+          CALL HWWARN('HWDBOS',1)
+        ENDIF
+        RHOHEP(1,IBOS)=1.
+        RHOHEP(2,IBOS)=1.
+        RHOHEP(3,IBOS)=1.
+      ENDIF
+ 20   IHEL=HWRINT(1,3)
+      IF (HWRGEN(0).GT.RHOHEP(IHEL,IBOS)) GOTO 20
+      ENDIF
+C---SELECT DIRECTION OF FERMION
+ 30   COSTH=HWRUNI(0,-ONE,ONE)
+      IF (IHEL.EQ.1 .AND. (ONE+COSTH)**2.LT.HWRGEN(0)*FOUR) GOTO 30
+      IF (IHEL.EQ.2 .AND. (ONE-COSTH**2).LT.HWRGEN(0)     ) GOTO 30
+      IF (IHEL.EQ.3 .AND. (ONE-COSTH)**2.LT.HWRGEN(0)*FOUR) GOTO 30
+C---GENERATE DECAY RELATIVE TO Z-AXIS
+      PHEP(5,NHEP+1)=RMASS(IDN(1))
+      PHEP(5,NHEP+2)=RMASS(IDN(2))
+      PCM=HWUPCM(PHEP(5,IBOS),PHEP(5,NHEP+1),PHEP(5,NHEP+2))
+      IF (PCM.LT.ZERO) 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
+      CALL HWULOB(PHEP(1,IBOS),PHEP(1,NHEP+1),PHEP(1,NHEP+1))
+      CALL HWVDIF(4,PHEP(1,IBOS),PHEP(1,NHEP+1),PHEP(1,NHEP+2))
+      ENDIF
+C---STATUS, IDs AND POINTERS
+      ISTHEP(IBOS)=195
+      DO 50 I=1,2
+        ISTHEP(NHEP+I)=193
+        IDHW(NHEP+I)=IDN(I)
+        IDHEP(NHEP+I)=IDPDG(IDN(I))
+        JDAHEP(I,IBOS)=NHEP+I
+        JMOHEP(1,NHEP+I)=IBOS
+        JMOHEP(2,NHEP+I)=JMOHEP(1,IBOS)
+ 50   CONTINUE
+      NHEP=NHEP+2
+      IF (IDN(1).LE.12) THEN
+        ISTHEP(NHEP-1)=113
+        ISTHEP(NHEP)=114
+        JMOHEP(2,NHEP)=NHEP-1
+        JDAHEP(2,NHEP)=NHEP-1
+        JMOHEP(2,NHEP-1)=NHEP
+        JDAHEP(2,NHEP-1)=NHEP
+        QUARKS=.TRUE.
+      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
+        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
+  &nbs