CDECK  ID>, HWHSCT.
*CMZ :-        -30/05/94  18.42.43  by  Mike Seymour
*-- Author :    Mike Seymour
C-----------------------------------------------------------------------
      SUBROUTINE HWHSCT(REPORT)
C-----------------------------------------------------------------------
C     RELABEL THE EVENT RECORD FOR EXTRA HARD SCATTERING,
C     DO THE SCATTERING, PARTON SHOWER IT, AND CLEAN UP THE EVENT RECORD
C     REPORT RETURNS THE OUTCOME:
C     0 = SUCCESSFUL
C     1 = FAILED DUE TO ERROR IN HARD SCATTERING GENERATION
C     2 = FAILED DUE TO ENERGY CONSERVATION IN HARD SCATTERING
C     3 = FAILED DUE TO ERROR IN PARTON EVOLUTION
C     4 = FAILED DUE TO ENERGY CONSERVATION IN PARTON EVOLUTION
C     5 = COMPLETELY FAILED (IERROR IS ALSO NON-ZERO TO CANCEL EVENT)
C-----------------------------------------------------------------------
      INCLUDE 'HERWIG59.INC'
      DOUBLE PRECISION HWRGEN,TMPWGT,PBOOST(5),RBOOST(3,3)
      INTEGER IHEP,IBM,ITG,IBMN,ITGN,IBMT,ITGT,I,REPORT
      LOGICAL COL
      EXTERNAL HWRGEN
      COL(I)=I.EQ.13 .OR. I.GE.1.AND.I.LE.6 .OR. I.GE.115.AND.I.LE.120
      REPORT=5
      IF (IERROR.NE.0) RETURN
C---FIND BEAM AND TARGET REMNANTS
      CALL HWHREM(IBM,ITG)
      IF (IERROR.NE.0) RETURN
C---RECALCULATE THEIR MASS CORRECTLY
      CALL HWUMAS(PHEP(1,IBM))
      CALL HWUMAS(PHEP(1,ITG))
C---SET UP NEW ENTRIES IN THE EVENT RECORD
      NHEP=NHEP+1
      CALL HWVEQU(5,PHEP(1,IBM),PHEP(1,NHEP))
      ISTHEP(NHEP)=3
      IBMN=NHEP
      IBMT=JDAHEP(1,1)
      IF (IBMT.EQ.0) THEN
        JMOHEP(1,NHEP)=1
        IDHW(NHEP)=72
      ELSE
        JMOHEP(1,NHEP)=IBMT
        IDHW(NHEP)=71
      ENDIF
      JMOHEP(2,NHEP)=0
      JDAHEP(1,NHEP)=0
      JDAHEP(2,NHEP)=0
      IDHEP(NHEP)=IDPDG(IDHW(NHEP))
      NHEP=NHEP+1
      CALL HWVEQU(5,PHEP(1,ITG),PHEP(1,NHEP))
      ISTHEP(NHEP)=3
      ITGN=NHEP
      ITGT=JDAHEP(1,2)
      IF (ITGT.EQ.0) THEN
        JMOHEP(1,NHEP)=2
        IDHW(NHEP)=72
      ELSE
        JMOHEP(1,NHEP)=ITGT
        IDHW(NHEP)=71
      ENDIF
      JMOHEP(2,NHEP)=0
      JDAHEP(1,NHEP)=0
      JDAHEP(2,NHEP)=0
      IDHEP(NHEP)=IDPDG(IDHW(NHEP))
C---BOOST TO THEIR CENTRE-OF-MASS FRAME
      CALL HWVSUM(4,PHEP(1,IBMN),PHEP(1,ITGN),PBOOST)
      CALL HWUMAS(PBOOST)
      DO 100 IHEP=IBMN,NHEP
        CALL HWULOF(PBOOST,PHEP(1,IHEP),PHEP(1,IHEP))
 100  CONTINUE
      CALL HWUROT(PHEP(1,IBMN),ONE,ZERO,RBOOST)
      DO 110 IHEP=IBMN,NHEP
        CALL HWUROF(RBOOST,PHEP(1,IHEP),PHEP(1,IHEP))
 110  CONTINUE
C---GENERATE A NEW HARD SCATTERING
      TMPWGT=EVWGT
      GENEV=.FALSE.
 10   CALL HWHQCD
      IF (IERROR.NE.0.OR.GAMWT*EVWGT.LE.WGTMAX*HWRGEN(0)) THEN
        IERROR=0
        GOTO 10
      ENDIF
      GENEV=.TRUE.
      CALL HWHQCD
      EVWGT=TMPWGT
C---IF MOMENTUM CANNOT BE CONSERVED, STOP GENERATING HARD SCATTERS
      IF (  PHEP(4,IBMN+2) .GT. PHEP(4,IBMN).OR.
     $      PHEP(4,ITGN+2) .GT. PHEP(4,ITGN).OR.
     $      PHEP(3,IBMN+2) .GT. PHEP(3,IBMN).OR.
     $     -PHEP(3,ITGN+2) .GT.-PHEP(3,ITGN).OR.IERROR.NE.0) THEN
        IF (IERROR.GT.0) THEN
          WRITE (6,'(A/A)')
     $       ' THIS ERROR OCCURED DURING A SECONDARY SCATTER AND WAS',
     $       ' CAUGHT BY HWHSCT, SO EVENT IS NOT KILLED AFTER ALL'
          REPORT=1
        ELSE
          REPORT=2
        ENDIF
        NHEP=IBMN-1
        IERROR=0
        RETURN
      ENDIF
C---RELABEL OUTGOING REMNANTS AS INCOMING HADRONS
      JDAHEP(1,1)=IBMN
      JDAHEP(1,2)=ITGN
C---EVOLVE THEM
      ISLENT=-1
      CALL HWBGEN
      ISLENT=1
C---PUT THE LABELS BACK
      JDAHEP(1,1)=IBMT
      JDAHEP(1,2)=ITGT
C---IF THERE WERE ANY PROBLEMS, STOP GENERATING HARD SCATTERS
      IF (IERROR.NE.0) THEN
        IF (IERROR.GT.0) THEN
          WRITE (6,'(A/A)')
     $       ' THIS ERROR OCCURED DURING A SECONDARY SCATTER AND WAS',
     $       ' CAUGHT BY HWHSCT, SO EVENT IS NOT KILLED AFTER ALL'
          REPORT=3
        ELSE
          REPORT=4
        ENDIF
        NHEP=IBMN-1
        IERROR=0
        RETURN
      ENDIF
C---UNDO THE LORENTZ BOOST
      DO 200 IHEP=IBMN,NHEP
        CALL HWUROB(RBOOST,PHEP(1,IHEP),PHEP(1,IHEP))
        CALL HWULOB(PBOOST,PHEP(1,IHEP),PHEP(1,IHEP))
 200  CONTINUE
C---FIND THE NEW BEAM AND TARGET REMNANTS
      ISTHEP(IBM)=3
      ISTHEP(ITG)=3
      CALL HWHREM(IBMN,ITGN)
      IF (IERROR.NE.0) RETURN
C---CONNECT UP THE COLOUR/FLAVOUR LINES OF THE TWO SCATTERS
      IDHW(IBMN)=IDHW(IBM)
      IDHEP(IBMN)=IDHEP(IBM)
      IF (COL(IDHW(IBM))) THEN
        JMOHEP(2,JDAHEP(2,IBMN))=JMOHEP(2,IBM)
        JDAHEP(2,JMOHEP(2,IBM))=JDAHEP(2,IBMN)
        JDAHEP(2,IBMN)=JDAHEP(2,IBM)
        JMOHEP(2,JDAHEP(2,IBM))=IBMN
      ELSE
        JDAHEP(2,JMOHEP(2,IBMN))=JDAHEP(2,IBM)
        JMOHEP(2,JDAHEP(2,IBM))=JMOHEP(2,IBMN)
        JMOHEP(2,IBMN)=JMOHEP(2,IBM)
        JDAHEP(2,JMOHEP(2,IBM))=IBMN
      ENDIF
      JMOHEP(2,IBM)=0
      JDAHEP(1,IBM)=IBMN
      JDAHEP(2,IBM)=0
      IDHW(ITGN)=IDHW(ITG)
      IDHEP(ITGN)=IDHEP(ITG)
      IF (COL(IDHW(ITG))) THEN
        JMOHEP(2,JDAHEP(2,ITGN))=JMOHEP(2,ITG)
        JDAHEP(2,JMOHEP(2,ITG))=JDAHEP(2,ITGN)
        JDAHEP(2,ITGN)=JDAHEP(2,ITG)
        JMOHEP(2,JDAHEP(2,ITG))=ITGN
      ELSE
        JDAHEP(2,JMOHEP(2,ITGN))=JDAHEP(2,ITG)
        JMOHEP(2,JDAHEP(2,ITG))=JMOHEP(2,ITGN)
        JMOHEP(2,ITGN)=JMOHEP(2,ITG)
        JDAHEP(2,JMOHEP(2,ITG))=ITGN
      ENDIF
      JMOHEP(2,ITG)=0
      JDAHEP(1,ITG)=ITGN
      JDAHEP(2,ITG)=0
C---LOOK FOR COLOUR SINGLET GLUONS (A RARE BUT ANNOYING SPECIAL CASE)
      DO 20 IHEP=1,NHEP
        IF (IDHW(IHEP).EQ.13.AND.JMOHEP(2,IHEP).EQ.IHEP)
     $       CALL HWWARN('HWHSCT',120,*999)
 20   CONTINUE
      REPORT=0
 999  END
