CDECK  ID>, HWMEVT.
*CMZ :-        -26/04/91  14.28.59  by  Federico Carminati
*-- Author :    Bryan Webber
C-----------------------------------------------------------------------
      SUBROUTINE HWMEVT
C-----------------------------------------------------------------------
C     IPROC = 1000,... ADDS SOFT UNDERLYING EVENT
C           = 8000:  CREATES MINIMUM-BIAS EVENT
C     SUPPRESSED BY ADDING 10000 TO IPROC
C-----------------------------------------------------------------------
      INCLUDE 'HERWIG59.INC'
      DOUBLE PRECISION HWREXP,ENFAC,TECM,SECM,SUMM,EMCL,BMP(5),BMR(3,3)
      INTEGER HWRINT,NETC,IBT,IDBT,ID1,ID2,ID3,KHEP,LHEP,NTRY,ICMS,
     & NPPBAR,NCL,MCHT,JCL,JD1,JD2,JD3,ICH,MODC,NCHT,INHEP(2),
     & INID(2,2),JBT
      EXTERNAL HWREXP,HWRINT
      IF (IERROR.NE.0) RETURN
      IF (.NOT.GENSOF) GOTO 990
      IF (IPROC.EQ.8000) THEN
C---SET UP BEAM AND TARGET CLUSTERS
    5   NETC=0
        DO 10 IBT=1,2
        JBT=IBT
        IF (JDAHEP(1,IBT).NE.0) JBT=JDAHEP(1,IBT)
        IDBT=IDHW(JBT)
        IF (IDBT.EQ.73.OR.IDBT.EQ.75) THEN
          INID(1,IBT)=HWRINT(1,2)
          INID(2,IBT)=110
        ELSEIF (IDBT.EQ.91.OR.IDBT.EQ.93) THEN
          INID(1,IBT)=116
          INID(2,IBT)=HWRINT(7,8)
        ELSEIF (IDBT.EQ.30) THEN
          INID(1,IBT)=HWRINT(1,2)
          INID(2,IBT)=8
        ELSEIF (IDBT.EQ.38) THEN
          INID(1,IBT)=2
          INID(2,IBT)=HWRINT(7,8)
        ELSEIF (IDBT.EQ.34) THEN
          INID(1,IBT)=3
          INID(2,IBT)=HWRINT(7,8)
        ELSEIF (IDBT.EQ.46) THEN
          INID(1,IBT)=HWRINT(1,2)
          INID(2,IBT)=9
        ELSEIF (IDBT.EQ.59) THEN
          INID(1,IBT)=HWRINT(1,2)
          INID(2,IBT)=HWRINT(7,8)
        ELSE
          CALL HWWARN('HWMEVT',100,*999)
        ENDIF
        NETC=NETC+ICHRG(IDBT)
     &    -(ICHRG(INID(1,IBT))+ICHRG(INID(2,IBT)))/3
        ENFAC=1.
        IDHW(NHEP+IBT)=19
        IDHEP(NHEP+IBT)=91
        ISTHEP(NHEP+IBT)=163+IBT
        JMOHEP(1,NHEP+IBT)=JBT
   10   CONTINUE
        IF (NETC.EQ.0) THEN
          ID3=HWRINT(1,2)
        ELSEIF (NETC.EQ.-1) THEN
          ID3=1
        ELSEIF (NETC.EQ.1) THEN
          ID3=2
        ELSE
          GOTO 5
        ENDIF
        DO 12 IBT=1,2
        NHEP=NHEP+1
        JBT=IBT
        IF (JDAHEP(1,IBT).NE.0) JBT=JDAHEP(1,IBT)
        CALL HWVEQU(5,PHEP(1,JBT),PHEP(1,NHEP))
   12   INHEP(IBT)=NHEP
      ELSE
C---FIND BEAM AND TARGET CLUSTERS
        DO 20 IBT=1,2
        DO 15 KHEP=1,NHEP
        IF (ISTHEP(KHEP).EQ.163+IBT) THEN
          INHEP(IBT)=KHEP
          INID(1,IBT)=IDHW(JMOHEP(1,KHEP))
          INID(2,IBT)=IDHW(JMOHEP(2,KHEP))
          GOTO 20
        ENDIF
   15   CONTINUE
C---COULDN'T FIND ONE
        INHEP(IBT)=0
   20   CONTINUE
        JCL=-1
C---TEST FOR BOTH FOUND
        IF (INHEP(1).EQ.0) JCL=INHEP(2)
        IF (INHEP(2).EQ.0) JCL=INHEP(1)
        IF (JCL.EQ.0) CALL HWWARN('HWMEVT',101,*999)
        IF (JCL.GT.0) THEN
          ISTHEP(JCL)=163
          CALL HWCFOR
          CALL HWCDEC
          CALL HWDHAD
          GOTO 90
        ENDIF
        ID3=HWRINT(1,2)
        ENFAC=ENSOF
        NETC=0
      ENDIF
C---FIND SOFT CM MOMENTUM AND MULTIPLICITY
      NTRY=0
      NHEP=NHEP+1
      IF (NHEP.GT.NMXHEP) CALL HWWARN('HWMEVT',102,*999)
      ICMS=NHEP
      IDHW(NHEP)=16
      IDHEP(NHEP)=0
      ISTHEP(NHEP)=170
      CALL HWVSUM(4,PHEP(1,INHEP(1)),PHEP(1,INHEP(2)),PHEP(1,NHEP))
      CALL HWUMAS(PHEP(1,NHEP))
      TECM=PHEP(5,NHEP)
      IF (IPROC/1000.EQ.9.OR.IPROC/1000.EQ.5) THEN
        SECM=TECM*ENFAC
      ELSE
        SECM=PHEP(5,3)*ENFAC
      ENDIF
C---CHOOSE MULTIPLICITY
   25 CALL HWMULT(SECM,NPPBAR)
   30 NCL=0
      MCHT=0
      IERROR=0
      NHEP =ICMS
      SUMM=0.
      NTRY=NTRY+1
C---CREATE CLUSTERS
   35 NCL=NCL+1
      NHEP=NHEP+1
      IF (NHEP.GT.NMXHEP) CALL HWWARN('HWMEVT',103,*999)
      JCL=NHEP
      IDHW(JCL)=19
      IDHEP(JCL)=91
      IF (NCL.LT.3) THEN
        ISTHEP(JCL)=170+NCL
        ID1=INID(1,NCL)
        ID2=INID(2,NCL)
      ELSE
        ID1=ID2-6
        IF (NCL.EQ.3) ID1=ID3
        ID2=HWRINT(7,8)
        ISTHEP(JCL)=173
      ENDIF
      JMOHEP(1,JCL)=ICMS
      JMOHEP(2,JCL)=0
      CALL HWVZRO(3,PHEP(1,JCL))
      PHEP(4,JCL)=RMASS(ID1)+RMASS(ID2)+0.4+HWREXP( ONE)
      PHEP(5,JCL)=PHEP(4,JCL)
C---HADRONIZE AND DECAY CLUSTERS
      CALL HWCFLA(ID1,ID2,JD1,JD2)
      CALL HWCHAD(JCL,JD1,JD2,JD3)
      IF (IERROR.NE.0) RETURN
      IF (JD3.EQ.0) THEN
        EMCL=RMASS(IDHW(NHEP))
        IF (PHEP(4,JCL).NE.EMCL) THEN
          PHEP(4,JCL)=EMCL
          PHEP(5,JCL)=EMCL
          PHEP(4,NHEP)=EMCL
          PHEP(5,NHEP)=EMCL
        ENDIF
      ELSE
        EMCL=PHEP(5,JCL)
      ENDIF
      IDPAR(NCL)=JD3
      PPAR(5,NCL)=EMCL
      SUMM=SUMM +EMCL
      CALL HWDHAD
      IF (IERROR.NE.0) RETURN
C---CHECK CHARGED MULTIPLICITY
      MODC=0
      DO 50 KHEP=JCL,NHEP
      IF (ISTHEP(KHEP).EQ.1) THEN
         ICH=ICHRG(IDHW(KHEP))
         IF (ICH.NE.0) THEN
            MCHT=MCHT+ABS(ICH)
            MODC=MODC+ICH
         ENDIF
      ENDIF
   50 CONTINUE
      IF (NCL.EQ.1) THEN
         NCHT=NPPBAR+NETC+ABS(MODC)
         GOTO 35
      ELSEIF (NCL.EQ.2) THEN
         NCHT=NCHT+ABS(MODC)
         IF (NCHT.LT.0) NCHT=NCHT+2
      ENDIF
      IF (MCHT.LT.NCHT) THEN
        GOTO 35
      ELSEIF (MCHT.GT.NCHT) THEN
        IF (MOD(NTRY,50).EQ.0) GOTO 25
        IF (NTRY.LT.NSTRY) GOTO 30
C---NO PHASE SPACE FOR SOFT EVENT
        NHEP=ICMS-1
        IF (IPROC.EQ.8000) THEN
C---MINIMUM BIAS: RELABEL BEAM AND TARGET CLUSTERS
          DO 60 IBT=1,2
            KHEP=INHEP(IBT)
            LHEP=JMOHEP(1,KHEP)
            ISTHEP(KHEP)=1
            IDHEP(KHEP)=IDHEP(LHEP)
            IDHW(KHEP)=IDHW(LHEP)
   60     CONTINUE
        ELSE
C---UNDERLYING EVENT: DECAY THEM
          ISTHEP(INHEP(1))=163
          ISTHEP(INHEP(2))=163
          CALL HWCFOR
          CALL HWCDEC
          CALL HWDHAD
        ENDIF
        GOTO 90
      ENDIF
C---GENERATE CLUSTER MOMENTA IN CLUSTER CM
C   FRAME.   N.B. SECOND CLUSTER IS TARGET
      IF (SUMM.GT.TECM) GOTO 25
      CALL HWMLPS(NCL,TECM)
      IF (NCL.EQ.0) GOTO 25
      JCL=0
C---ROTATE & BOOST CLUSTERS & DECAY PRODUCTS
      CALL HWULOF(PHEP(1,ICMS),PHEP(1,INHEP(1)),BMP)
      CALL HWUROT(BMP, ONE,ZERO,BMR)
C---BMR PUTS BEAM ALONG Z AXIS (WE WANT INVERSE)
      DO 70 KHEP=ICMS+1,NHEP
      IF (ISTHEP(KHEP).GT.180.AND.ISTHEP(KHEP).LT.190) THEN
          ISTHEP(KHEP)=ISTHEP(KHEP)+3
          LHEP=KHEP
          JCL=JCL+1
          CALL HWUROB(BMR,PPAR(1,JCL),PPAR(1,JCL))
          CALL HWULOB(PHEP(1,ICMS),PPAR(1,JCL),PPAR(1,JCL))
C---NOW PPAR(*,JCL) IS LAB MOMENTUM OF JTH CLUSTER
      ENDIF
      CALL HWULOB(PPAR(1,JCL),PHEP(1,KHEP),PHEP(1,KHEP))
   70 CONTINUE
      ISTHEP(INHEP(1))=167
      ISTHEP(INHEP(2))=168
      JMOHEP(1,ICMS)=INHEP(1)
      JMOHEP(2,ICMS)=INHEP(2)
      JDAHEP(1,INHEP(1))=ICMS
      JDAHEP(2,INHEP(1))=0
      JDAHEP(1,INHEP(2))=ICMS
      JDAHEP(2,INHEP(2))=0
      JDAHEP(1,ICMS)=ICMS+1
      JDAHEP(2,ICMS)=LHEP
   90 CONTINUE
C---DO SOFT HEAVY FLAVOUR DECAYS (IF ANY)
      CALL HWDHVY
  990 ISTAT=100
  999 END
