--- /dev/null
+C-----------------------------------------------------------------------
+C H E R W I G
+C
+C a Monte Carlo event generator for simulating
+C +---------------------------------------------------+
+C | Hadron Emission Reactions With Interfering Gluons |
+C +---------------------------------------------------+
+C I.G. Knowles(*), G. Marchesini(+), M.H. Seymour($) and B.R. Webber(#)
+C-----------------------------------------------------------------------
+C with Minimal Supersymmetric Standard Model Matrix Elements by
+C S. Moretti($) and K. Odagiri($)
+C-----------------------------------------------------------------------
+C R parity violating Supersymmetric Decays and Matrix Elements by
+C P. Richardson(&)
+C-----------------------------------------------------------------------
+C matrix element corrections to top decay and Drell-Yan type processes
+C by G. Corcella(+)
+C-----------------------------------------------------------------------
+C Deep Inelastic Scattering and Heavy Flavour Electroproduction by
+C G. Abbiendi(@) and L. Stanco(%)
+C-----------------------------------------------------------------------
+C and Jet Photoproduction in Lepton-Hadron Collisions by J. Chyla(~)
+C-----------------------------------------------------------------------
+C(*) Department of Physics & Astronomy, University of Edinburgh
+C(+) Dipartimento di Fisica, Universita di Milano
+C($) Rutherford Appleton Laboratory
+C(#) Cavendish Laboratory, Cambridge
+C(&) Department of Physics, University of Oxford
+C(@) Dipartimento di Fisica, Universita di Bologna
+C(%) Dipartimento di Fisica, Universita di Padova
+C(~) Institute of Physics, Prague
+C-----------------------------------------------------------------------
+C Version 6.100 - 16th December 1999
+C-----------------------------------------------------------------------
+C Main reference:
+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 send e-mail about this program to one of the authors at the
+C following Internet addresses:
+C I.Knowles@ed.ac.uk Giuseppe.Marchesini@mi.infn.it
+C M.Seymour@rl.ac.uk webber@hep.phy.cam.ac.uk
+C-----------------------------------------------------------------------
+CDECK ID>, DECADD.
+*CMZ :- -28/01/92 12.34.44 by Mike Seymour
+*-- Author : Luca Stanco
+C-----------------------------------------------------------------------
+ SUBROUTINE DECADD(LOGI)
+C-----------------------------------------------------------------------
+C DUMMY SUBROUTINE: DELETE AND SET BDECAY='CLEO'
+C IN MAIN PROGRAM IF YOU USE CLEO DECAY PACKAGE
+C-----------------------------------------------------------------------
+ LOGICAL LOGI
+ WRITE (6,10)
+ 10 FORMAT(/10X,'DECADD CALLED BUT NOT LINKED')
+ STOP
+ END
+CDECK ID>, EUDINI.
+*CMZ :- -28/01/92 12.34.44 by Mike Seymour
+*-- Author : Luca Stanco
+C-----------------------------------------------------------------------
+ SUBROUTINE EUDINI
+C-----------------------------------------------------------------------
+C DUMMY SUBROUTINE: DELETE AND SET BDECAY='EURO'
+C IN MAIN PROGRAM IF YOU USE EURODEC DECAY PACKAGE
+C-----------------------------------------------------------------------
+ WRITE (6,10)
+ 10 FORMAT(/10X,'EUDINI CALLED BUT NOT LINKED')
+ STOP
+ END
+CDECK ID>, FRAGMT.
+*CMZ :- -28/01/92 12.34.44 by Mike Seymour
+*-- Author : Luca Stanco
+C-----------------------------------------------------------------------
+ SUBROUTINE FRAGMT(I,J,K)
+C-----------------------------------------------------------------------
+C DUMMY SUBROUTINE: DELETE AND SET BDECAY='EURO'
+C IN MAIN PROGRAM IF YOU USE EURODEC DECAY PACKAGE
+C-----------------------------------------------------------------------
+ INTEGER I,J,K
+ WRITE (6,10)
+ 10 FORMAT(/10X,'FRAGMT CALLED BUT NOT LINKED')
+ STOP
+ END
+CDECK ID>, HVCBVI.
+*CMZ :- -28/01/92 12.34.44 by Mike Seymour
+*-- Author : Mike Seymour
+C-----------------------------------------------------------------------
+ SUBROUTINE HVCBVI
+C-----------------------------------------------------------------------
+C DUMMY ROUTINE: DELETE IF YOU LINK TO BARYON NUMBER VIOLATN PACKAGE
+C-----------------------------------------------------------------------
+ WRITE (6,10)
+ 10 FORMAT(/10X,'HVCBVI CALLED BUT NOT LINKED')
+ STOP
+ END
+CDECK ID>, HVHBVI.
+*CMZ :- -28/01/92 12.34.44 by Mike Seymour
+*-- Author : Mike Seymour
+C-----------------------------------------------------------------------
+ SUBROUTINE HVHBVI
+C-----------------------------------------------------------------------
+C DUMMY ROUTINE: DELETE IF YOU LINK TO BARYON NUMBER VIOLATN PACKAGE
+C-----------------------------------------------------------------------
+ WRITE (6,10)
+ 10 FORMAT(/10X,'HERBVI CALLED BUT NOT LINKED')
+ STOP
+ END
+CDECK ID>, HWBAZF.
+*CMZ :- -26/04/91 11.11.54 by Bryan Webber
+*-- Author : Ian Knowles
+C-----------------------------------------------------------------------
+ SUBROUTINE HWBAZF(IPAR,JPAR,VEC1,VEC2,VEC3,VEC)
+C-----------------------------------------------------------------------
+C Azimuthal correlation functions for Collins' algorithm,
+C see I.G.Knowles, Comp. Phys. Comm. 58 (90) 271 for notation.
+C-----------------------------------------------------------------------
+ INCLUDE 'HERWIG61.INC'
+ DOUBLE PRECISION Z1,Z2,DOT12,DOT23,DOT31,TR,FN(7),VEC1(2),VEC2(2),
+ & VEC3(2),VEC(2)
+ INTEGER IPAR,JPAR
+ LOGICAL GLUI,GLUJ
+ IF (.NOT.AZSPIN) RETURN
+ Z1=PPAR(4,JPAR)/PPAR(4,IPAR)
+ Z2=1.-Z1
+ GLUI=IDPAR(IPAR).EQ.13
+ GLUJ=IDPAR(JPAR).EQ.13
+ IF (GLUI) THEN
+ IF (GLUJ) THEN
+C Branching: g--->gg
+ FN(2)=Z2/Z1
+ FN(3)=1./FN(2)
+ FN(4)=Z1*Z2
+ FN(1)=FN(2)+FN(3)+FN(4)
+ FN(5)=FN(2)+2.*Z1
+ FN(6)=FN(3)+2.*Z2
+ FN(7)=FN(4)-2.
+ ELSE
+C Branching: g--->qqbar
+ FN(1)=(Z1*Z1+Z2*Z2)/2.
+ FN(2)=0.
+ FN(3)=0.
+ FN(4)=-Z1*Z2
+ FN(5)=-(2.*Z1-1.)/2.
+ FN(6)=-FN(5)
+ FN(7)=FN(1)
+ ENDIF
+ ELSE
+ IF (GLUJ) THEN
+C Branching: q--->gq
+ FN(1)=(1.+Z2*Z2)/(2.*Z1)
+ FN(2)=Z2/Z1
+ FN(3)=0.
+ FN(4)=0.
+ FN(5)=FN(1)
+ FN(6)=(1.+Z2)/2.
+ FN(7)=-FN(6)
+ ELSE
+C Branching: q--->qg
+ FN(1)=(1.+Z1*Z1)/(2.*Z2)
+ FN(2)=0.
+ FN(3)=Z1/Z2
+ FN(4)=0.
+ FN(5)=(1.+Z1)/2.
+ FN(6)=FN(1)
+ FN(7)=-FN(5)
+ ENDIF
+ ENDIF
+ DOT12=VEC1(1)*VEC2(1)+VEC1(2)*VEC2(2)
+ DOT23=VEC2(1)*VEC3(1)+VEC2(2)*VEC3(2)
+ DOT31=VEC3(1)*VEC1(1)+VEC3(2)*VEC1(2)
+ TR=1./(FN(1)+FN(2)*DOT23+FN(3)*DOT31+FN(4)*DOT12)
+ VEC(1)=((FN(2)+FN(5)*DOT23)*VEC1(1)
+ & +(FN(3)+FN(6)*DOT31)*VEC2(1)
+ & +(FN(4)+FN(7)*DOT12)*VEC3(1))*TR
+ VEC(2)=((FN(2)+FN(5)*DOT23)*VEC1(2)
+ & +(FN(3)+FN(6)*DOT31)*VEC2(2)
+ & +(FN(4)+FN(7)*DOT12)*VEC3(2))*TR
+ END
+CDECK ID>, HWBCON.
+*CMZ :- -26/04/91 10.18.56 by Bryan Webber
+*-- Author : Bryan Webber
+C-----------------------------------------------------------------------
+ SUBROUTINE HWBCON
+C-----------------------------------------------------------------------
+C MAKES COLOUR CONNECTIONS BETWEEN JETS
+C MODIFIED 12/10/97 BY BRW FOR SUSY PROCESSES
+C-----------------------------------------------------------------------
+ INCLUDE 'HERWIG61.INC'
+ INTEGER IHEP,IST,ID,JC,KC,JD,JHEP,LHEP,ID2
+ IF (IERROR.NE.0) RETURN
+ IF(.NOT.RPARTY) THEN
+ CALL HWBRCN
+ RETURN
+ ENDIF
+ DO 20 IHEP=1,NHEP
+ IST=ISTHEP(IHEP)
+C---LOOK FOR PARTONS WITHOUT COLOUR MOTHERS
+ IF (IST.LT.145.OR.IST.GT.152) GOTO 20
+ IF (JMOHEP(2,IHEP).EQ.0) THEN
+C---FIND COLOUR-CONNECTED PARTON
+ JC=JMOHEP(1,IHEP)
+ IF (IST.NE.152) JC=JMOHEP(1,JC)
+ JC =JMOHEP(2,JC)
+ IF (JC.EQ.0) CALL HWWARN('HWBCON',51,*20)
+C---FIND SPECTATOR WHEN JC IS DECAYED HEAVY QUARK OR SUSY PARTICLE
+ IF (ISTHEP(JC).EQ.155) THEN
+ IF (IDHEP(JMOHEP(1,JC)).EQ.94) THEN
+C---DECAYED BEFORE HADRONIZING
+ JHEP=JMOHEP(2,JC)
+ IF (JHEP.EQ.0) GO TO 20
+ ID=IDHW(JHEP)
+ IF (ISTHEP(JHEP).EQ.155) THEN
+C---SPECIAL FOR GLUINO DECAYS
+ IF (ID.EQ.449) THEN
+ ID=IDHW(JC)
+C---N.B. WILL NEED MODS WHEN SUSY PARTICLES CAN SHOWER
+ IF (ID.EQ.449.OR.ID.EQ.13.OR.
+ & (ID.GE.401.AND.ID.LE.406).OR.
+ & (ID.GE.413.AND.ID.LE.418).OR.
+ & ID.LE.6.OR.(ID.GE.115.AND.ID.LE.120)) THEN
+C---LOOK FOR ANTI(S)QUARK OR GLUON
+ DO KC=JDAHEP(1,JHEP),JDAHEP(2,JHEP)
+ ID=IDHW(KC)
+ IF ((ID.GE. 7.AND.ID.LE. 13).OR.
+ & (ID.GE.407.AND.ID.LE.412).OR.
+ & (ID.GE.419.AND.ID.LE.424)) GOTO 5
+ ENDDO
+ ELSE
+C---LOOK FOR (S)QUARK OR GLUON
+ DO KC=JDAHEP(1,JHEP),JDAHEP(2,JHEP)
+ ID=IDHW(KC)
+ IF (ID.LE. 6.OR. ID.EQ. 13.OR.
+ & (ID.GE.401.AND.ID.LE.406).OR.
+ & (ID.GE.413.AND.ID.LE.418)) GOTO 5
+ ENDDO
+ ENDIF
+C---COULDNT FIND ONE
+ CALL HWWARN('HWBCON',101,*999)
+ 5 JC=KC
+ ELSE
+C--PR MOD 30/6/99 should fix HWCFOR 104 errors
+ ID2 = IDHW(IHEP)
+ IF(IDHW(JDAHEP(1,JHEP)).EQ.449.AND.
+ & (ID2.LE.6.OR.(ID2.GE.115.AND.ID2.LE.120).OR.
+ & (ID2.GE.401.AND.ID2.LE.406).OR.ID2.EQ.13.OR.
+ & (ID2.GE.413.AND.ID2.LE.418).OR.ID2.EQ.449)) THEN
+ JC = JDAHEP(1,JHEP)
+ ELSE
+ JC=JDAHEP(2,JHEP)
+ ENDIF
+ ENDIF
+ ELSEIF (ID.EQ.6.OR.ID.EQ.12.OR.
+ & (ID.GE.209.AND.ID.LE.218).OR.
+ & (ID.GE.401.AND.ID.LE.424).OR.ID.EQ.449) THEN
+C Wait for partner heavy quark to decay
+C RETURN
+C---N.B. MAY BE A PROBLEM HERE
+ GOTO 20
+ ELSE
+ JMOHEP(2,IHEP)=JHEP
+ JDAHEP(2,JHEP)=IHEP
+ GOTO 20
+ ENDIF
+ ELSE
+ JC=JMOHEP(2,JC)
+ ENDIF
+ ENDIF
+ JC=JDAHEP(1,JC)
+ JD=JDAHEP(2,JC)
+C---SEARCH IN CORRESPONDING JET
+ IF (JD.LT.JC) JD=JC
+ LHEP=0
+ DO 10 JHEP=JC,JD
+ IF (ISTHEP(JHEP).LT.145.OR.ISTHEP(JHEP).GT.152) GOTO 10
+ IF (JDAHEP(2,JHEP).EQ.IHEP) LHEP=JHEP
+ IF (JDAHEP(2,JHEP).NE.0) GOTO 10
+C---JOIN IHEP AND JHEP
+ JMOHEP(2,IHEP)=JHEP
+ JDAHEP(2,JHEP)=IHEP
+ GOTO 20
+ 10 CONTINUE
+ IF (LHEP.NE.0) THEN
+ JMOHEP(2,IHEP)=LHEP
+C ELSE
+C---DIDN'T FIND PARTNER OF IHEP YET
+C CALL HWWARN('HWBCON',52,*20)
+ ENDIF
+ ENDIF
+ 20 CONTINUE
+C---BREAK COLOUR CONNECTIONS WITH PHOTONS
+ IHEP=1
+ 30 IF (IHEP.LE.NHEP) THEN
+ IF (IDHW(IHEP).EQ.59 .AND. ISTHEP(IHEP).EQ.149) THEN
+C BRW FIX 13/03/99
+ IF (JMOHEP(2,IHEP).NE.0) THEN
+ IF (JDAHEP(2,JMOHEP(2,IHEP)).EQ.IHEP)
+ & JDAHEP(2,JMOHEP(2,IHEP))=JDAHEP(2,IHEP)
+ ENDIF
+C END FIX
+ IF (JDAHEP(2,IHEP).NE.0) THEN
+ IF (JMOHEP(2,JDAHEP(2,IHEP)).EQ.IHEP)
+ & JMOHEP(2,JDAHEP(2,IHEP))=JMOHEP(2,IHEP)
+ ENDIF
+ JMOHEP(2,IHEP)=IHEP
+ JDAHEP(2,IHEP)=IHEP
+ ENDIF
+ IHEP=IHEP+1
+ GOTO 30
+ ENDIF
+ 999 END
+CDECK ID>, HWBDED.
+*CMZ :- -22/04/96 13.54.08 by Mike Seymour
+*-- Author : Mike Seymour
+C-----------------------------------------------------------------------
+ SUBROUTINE HWBDED(IOPT)
+C FILL MISSING AREA OF DALITZ PLOT WITH 3-JET AND 2-JET+GAMMA EVENTS
+C IF (IOPT.EQ.1) SET UP EVENT RECORD
+C IF (IOPT.EQ.2) CLEAN UP EVENT RECORD AFTER SHOWERING
+C-----------------------------------------------------------------------
+ INCLUDE 'HERWIG61.INC'
+ DOUBLE PRECISION HWBVMC,HWR,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
+ EXTERNAL HWBVMC,HWR,HWUALF,HWUSQR
+ SAVE X,WMAX
+ DATA WSUM,WMAX,X1MIN,X1MAX,EMIT,ICMF,IEVT
+ & /0.994651,1.84096,0,0.773459,3*0/
+ LAMBDA(A,B,C)=(A**2+B**2+C**2-2*A*B-2*B*C-2*C*A)/(4*A)
+ IF (IOPT.EQ.1) THEN
+C---FIND AN UNTREATED CMF
+ IF (IEVT.EQ.NEVHEP+NWGTS) RETURN
+ IEVT=0
+ ICMF=0
+ 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)
+ IF (EM.LT.2*HWBVMC(1)) RETURN
+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))**HWR()
+C---CHOOSE X2
+ X2MIN=MAX(X(1),1-X(1))
+ X2MAX=(4*X(1)-3+2*REAL( CMPLX( 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))**HWR()
+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*HWR().GT.W) GOTO 100
+C---SYMMETRIZE X1,X2
+ X(3)=2-X(1)-X(2)
+ IF (HWR().GT.HALF) THEN
+ X(1)=X(2)
+ X(2)=2-X(3)-X(1)
+ ENDIF
+C---CHOOSE WHICH PARTON WILL EMIT
+ EMIT=1
+ IF (HWR().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---IN FRACTION FAC*WSUM OF EVENTS ADD A GAMMA/GLUON
+ IF (GAMFAC*WSUM .GT. HWR()) THEN
+ ID3=59
+ ELSEIF (GLUFAC*WSUM .GT. HWR()) THEN
+ ID3=13
+ ELSE
+ EMIT=0
+ RETURN
+ ENDIF
+C---CHECK INFRA-RED CUT-OFF FOR GAMMA/GLUON
+ M(1)=HWBVMC(ID)
+ M(2)=HWBVMC(ID)
+ 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
+ RETURN
+ 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.HWR()*(X(1)**2+X(2)**2)) THEN
+ EMIT=0
+ RETURN
+ 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(1)=PHEP(5,IHEP)
+ M(2)=PHEP(5,JHEP)
+ M(3)=RMASS(ID3)
+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=NHEP
+ ELSE
+ IHEP=NHEP
+ JHEP=JDAHEP(1,ICMF)
+ ENDIF
+ KHEP=JDAHEP(2,ICMF)
+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.NHEP) THEN
+ IHEP=JHEP
+ JHEP=NHEP
+ 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
+ ELSEIF (IOPT.EQ.2) THEN
+C---MAKE THREE-JET EVENTS FROM THE `DEAD-ZONE' LOOK LIKE TWO-JET EVENTS
+ IF (EMIT.EQ.0.OR.IEVT.NE.NEVHEP+NWGTS) THEN
+ RETURN
+ ELSEIF (EMIT.EQ.1) THEN
+ IHEP=JDAHEP(1,JDAHEP(1,ICMF)+1)
+ JHEP=JDAHEP(1,JDAHEP(1,ICMF))
+ ELSE
+ IHEP=JDAHEP(1,JDAHEP(2,ICMF))
+ JHEP=JDAHEP(1,JDAHEP(1,ICMF)+1)
+ JDAHEP(1,JDAHEP(2,ICMF))=JHEP
+ IDHW(JHEP)=IDHW(IHEP)
+ IF (ISTHEP(IHEP+1).EQ.100 .AND. ISTHEP(JHEP+1).EQ.100)
+ & CALL HWVEQU(5,PHEP(1,IHEP+1),PHEP(1,JHEP+1))
+ ENDIF
+ JMOHEP(2,JDAHEP(1,ICMF))=JDAHEP(2,ICMF)
+ JDAHEP(2,JDAHEP(1,ICMF))=JDAHEP(2,ICMF)
+ JMOHEP(2,JDAHEP(2,ICMF))=JDAHEP(1,ICMF)
+ JDAHEP(2,JDAHEP(2,ICMF))=JDAHEP(1,ICMF)
+ CALL HWVEQU(5,P1,PHEP(1,JDAHEP(1,ICMF)))
+ CALL HWVEQU(5,P2,PHEP(1,JDAHEP(2,ICMF)))
+ CALL HWVSUM(4,PHEP(1,IHEP),PHEP(1,JHEP),PHEP(1,JHEP))
+ CALL HWUMAS(PHEP(1,JHEP))
+ JDAHEP(2,JHEP)=JDAHEP(2,IHEP)
+ IEDT(1)=JDAHEP(1,ICMF)+1
+ IEDT(2)=IHEP
+ IEDT(3)=IHEP+1
+ NDEL=3
+ IF (ISTHEP(IHEP+1).NE.100) NDEL=2
+ CALL HWUEDT(NDEL,IEDT)
+ DO 410 I=1,2
+ IHEP=JDAHEP(1,JDAHEP(I,ICMF))
+ JMOHEP(1,IHEP)=JDAHEP(I,ICMF)
+ IF (ISTHEP(IHEP+1).EQ.100) THEN
+ JMOHEP(1,IHEP+1)=JMOHEP(1,IHEP)
+ JMOHEP(2,IHEP+1)=JMOHEP(2,JMOHEP(1,IHEP))
+ ENDIF
+ DO 400 JHEP=JDAHEP(1,IHEP),JDAHEP(2,IHEP)
+ JMOHEP(1,JHEP)=IHEP
+ 400 CONTINUE
+ CALL HWVZRO(4,VHEP(1,JDAHEP(I,ICMF)))
+ CALL HWVZRO(4,VHEP(1,IHEP))
+ IF (ISTHEP(IHEP+1).EQ.100) CALL HWVZRO(4,VHEP(1,IHEP+1))
+ 410 CONTINUE
+ EMIT=0
+ IEVT=0
+ ELSE
+ CALL HWWARN('HWBDED',500,*999)
+ ENDIF
+ 999 END
+CDECK ID>, HWBDIS.
+*CMZ :- -17/05/94 09.33.08 by Mike Seymour
+*-- Author : Mike Seymour
+C-----------------------------------------------------------------------
+ SUBROUTINE HWBDIS(IOPT)
+C-----------------------------------------------------------------------
+C FILL MISSING AREA OF DIS PHASE-SPACE WITH 2+1-JET EVENTS
+C IF (IOPT.EQ.1) SET UP EVENT RECORD
+C IF (IOPT.EQ.2) CLEAN UP EVENT RECORD AFTER SHOWERING
+C-----------------------------------------------------------------------
+ INCLUDE 'HERWIG61.INC'
+ DOUBLE PRECISION HWR,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 HWR,HWBVMC,HWUALF,HWULDO
+ SAVE BGF,IIN,IOUT,ICMF,ID,Q1,Q2,XP,XBJ
+ DATA EMIT,COMINT,BGFINT,COMWGT/0,3.9827,1.2462,0.3/
+ DATA C1,C2,CM,B1,B2,BM/0.56,0.20,10,0.667,0.167,3/
+ IF (IERROR.NE.0) RETURN
+ IF (IOPT.EQ.1) THEN
+C---FIND AN UNTREATED CMF
+ IF (EMIT.EQ.NEVHEP+NWGTS) RETURN
+ ICMF=0
+ DO 10 IHEP=1,NHEP
+ 10 IF (ICMF.EQ.0 .AND. ISTHEP(IHEP).EQ.110 .AND.
+ & JDAHEP(2,IHEP).EQ.JDAHEP(1,IHEP)+1) ICMF=IHEP
+ IF (ICMF.EQ.0) RETURN
+ IIN=JMOHEP(2,ICMF)
+ IOUT=JDAHEP(2,ICMF)
+ ILEP=JMOHEP(1,ICMF)
+ CALL HWVEQU(5,PHEP(1,IIN),P1)
+ CALL HWVEQU(5,PHEP(1,IOUT),P2)
+ CALL HWVEQU(5,PHEP(1,ILEP),L)
+ IHAD=2
+ IF (JDAHEP(1,IHAD).NE.0) IHAD=JDAHEP(1,IHAD)
+ ID=IDHW(IIN)
+C---STORE OLD MOMENTA
+ CALL HWVEQU(5,P1,Q1)
+ CALL HWVEQU(5,P2,Q2)
+C---BOOST AND ROTATE THE MOMENTA TO THE BREIT FRAME
+ CALL HWVDIF(4,P2,P1,PCMF)
+ CALL HWUMAS(PCMF)
+ CALL HWVEQU(5,PHEP(1,IHAD),PM)
+ Q=-PCMF(5)
+ XBJ=HALF*Q**2/HWULDO(PM,PCMF)
+ CALL HWVSCA(4,HALF/XBJ,PCMF,PCMF)
+ CALL HWVSUM(4,PM,PCMF,PCMF)
+ CALL HWUMAS(PCMF)
+ CALL HWULOF(PCMF,L,L)
+ CALL HWULOF(PCMF,PM,PM)
+ CALL HWUROT(PM,ONE,ZERO,R)
+ CALL HWUROF(R,L,L)
+ PHI=ATAN2(L(2),L(1))
+ CALL HWUROT(PM,COS(PHI),SIN(PHI),R)
+C---CHOOSE THE HADRONIC-PLANE CONFIGURATION, XP,ZP
+ IF (HWR().LT.COMWGT) THEN
+C-----CONSIDER GENERATING A QCD COMPTON EVENT
+ BGF=.FALSE.
+ P3(5)=RMASS(13)
+ 100 RN=HWR()
+ IF (RN.LT.C1) THEN
+ ZP=HWR()
+ XPMAX=MIN(ZP,1-ZP)
+ XP=HWR()*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 (HWR().LT.HALF) THEN
+ ZPMAX=ZP
+ ZP=XP
+ XP=ZPMAX
+ ENDIF
+ ELSEIF (RN.LT.C1+C2) THEN
+ XPMAX=0.83
+ XP=XPMAX*HWR()
+ ZPMIN=MAX(XP,1-XP)
+ ZPMAX=1-2./3.*XP*(1+REAL( CMPLX(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.) * CMPLX(0.5,0.8660254) ))
+ ZP=1-((1-ZPMIN)/(1-ZPMAX))**HWR()*(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*HWR()
+ XPMIN=MAX(ZP,1-ZP)
+ XPMAX=(1+4*ZP*(1-ZP))/(1+6*ZP*(1-ZP))
+ XP=1-((1-XPMIN)/(1-XPMAX))**HWR()*(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+REAL( CMPLX(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.) * CMPLX(0.5,0.8660254) ))
+ IF (XP.GT.XPMAX.OR.ZP.GT.ZPMAX.OR.CM*HWR().GT.FAC)
+ $ GOTO 100
+ ELSE
+C-----CONSIDER GENERATING A BGF EVENT
+ BGF=.TRUE.
+ P3(5)=P1(5)
+ P1(5)=RMASS(13)
+ 110 RN=HWR()
+ IF (RN.LT.B1) THEN
+ ZP=HWR()
+ XPMAX=MIN(ZP,1-ZP)
+ XP=HWR()*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 (HWR().LT.HALF) XP=1-XP
+ ELSEIF (RN.LT.B1+B2) THEN
+ XPMAX=0.83
+ XP=XPMAX*HWR()
+ ZPMIN=MAX(XP,1-XP)
+ ZPMAX=1-2./3.*XP*(1+REAL( CMPLX(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.) * CMPLX(0.5,0.8660254) ))
+ ZP=1-((1-ZPMIN)/(1-ZPMAX))**HWR()*(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*HWR()
+ ZPMAX=MIN(XP,1-XP)
+ ZPMIN=2./3.*XP*(1+REAL( CMPLX(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.) * CMPLX(0.5,0.8660254) ))
+ ZP=(ZPMAX-ZPMIN)*HWR()+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+REAL( CMPLX(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.) * CMPLX(0.5,0.8660254) ))
+ IF (ZP.GT.ZPMAX.OR.ZP.LT.ONE-ZPMAX.OR.BM*HWR().GT.FAC)
+ $ GOTO 110
+ ENDIF
+C---CALCULATE THE ADDITIONAL FACTORS IN THE WEIGHT
+ IF (BGF) THEN
+ IDNEW=13
+ CFAC=1./2
+ FAC=BGFINT/(1-COMWGT)
+ ELSE
+ IDNEW=ID
+ CFAC=4./3
+ FAC=COMINT/COMWGT
+ ENDIF
+ SCALE=Q*SQRT((1-XP)*(1-ZP)*ZP/XP+1)
+ ITEMP=ISTAT
+ ISTAT=7
+ CALL HWSFUN(XBJ,Q,IDHW(IHAD),NSTRU,PDFOLD,2)
+ ISTAT=ITEMP
+ IF (PDFOLD(ID).LE.ZERO) CALL HWWARN('HWBDIS',100,*999)
+ IF (XP.GT.XBJ) THEN
+ CALL HWSFUN(XBJ/XP,SCALE,IDHW(IHAD),NSTRU,PDFNEW,2)
+ FAC=CFAC/(2*PIFAC) * HWUALF(1,SCALE) * FAC *
+ $ PDFNEW(IDNEW)/PDFOLD(ID)
+ ELSE
+ FAC=0
+ ENDIF
+C---FOR PHOTON BEAMS, INCLUDE DIRECT PHOTON COUPLING
+ IF (IDHW(IHAD).EQ.59) THEN
+ ZPMIN=2./3.*XBJ*(1+REAL( CMPLX(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.) * CMPLX(0.5,0.8660254) ))
+ 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 (HWR().GT.FAC+DIR) RETURN
+C---FOR DIRECT COUPLING, CHOOSE ZP VALUE
+ IF ((FAC+DIR)*HWR().GT.FAC) THEN
+ IF ((DIR1+DIR2)*HWR().LT.DIR1) THEN
+ NTRY=0
+ 120 NTRY=NTRY+2
+ ZP=1-(ZPMAX/ZPMIN)**HWR()*ZPMIN
+ IF ((ZPMIN**2+(1-ZPMIN)**2)*HWR().GT.ZP**2+(1-ZP)**2)
+ $ GOTO 120
+ ELSE
+ ZP=SQRT((ZPMAX-ZPMIN)*HWR()+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 (HWR()*(W1+W2).GT.W2) THEN
+ IF (BGF) THEN
+C-----WEIGHTED BY (1+SIN1*COS(PHI))**2
+ 200 PHI=(2*HWR()-1)*PIFAC
+ IF (HWR()*(1+SIN1)**2.GT.(1+SIN1*COS(PHI))**2) GOTO 200
+ ELSE
+C-----UNIFORMLY
+ PHI=(2*HWR()-1)*PIFAC
+ ENDIF
+ ELSE
+C-----WEIGHTED BY (1-SIN2*COS(PHI))**2
+ 210 PHI=(2*HWR()-1)*PIFAC
+ IF (HWR()*(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.HWR()) 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.HWR()*(1+(1-XP-ZP)**2+6*XP*(1-XP)*ZP*(1-ZP)))THEN
+C Incoming quark radiated the gluon
+ CALL HWVZRO(4,VHEP(1,NHEP-1))
+ CALL HWVDIF(4,PHEP(1,NHEP-4),PHEP(1,NHEP),PVRT)
+ CALL HWUDKL(ID,PVRT,VHEP(1,NHEP))
+ CALL HWVEQU(4,VHEP(1,NHEP),VHEP(1,NHEP-4))
+ ELSE
+C Outgoing quark radiated the gluon
+ CALL HWVZRO(4,VHEP(1,NHEP-4))
+ CALL HWVSUM(4,PHEP(1,NHEP-1),PHEP(1,NHEP),PVRT)
+ CALL HWUDKL(ID,PVRT,VHEP(1,NHEP))
+ CALL HWVEQU(4,VHEP(1,NHEP),VHEP(1,NHEP-1))
+ ENDIF
+ ENDIF
+C---STATUS, ID AND POINTERS
+ ISTHEP(NHEP)=114
+ IF (BGF) THEN
+ IF (XP.EQ.XBJ) THEN
+ IDHW(IIN)=59
+ IDHEP(IIN)=IDPDG(59)
+ ELSE
+ IDHW(IIN)=13
+ IDHEP(IIN)=IDPDG(13)
+ ENDIF
+ IF (ID.LT.7) THEN
+ IDHW(NHEP)=IDHW(IOUT)
+ IDHEP(NHEP)=IDHEP(IOUT)
+ IDHW(IOUT)=MOD(ID,6)+6
+ IDHEP(IOUT)=IDPDG(IDHW(IOUT))
+ ELSE
+ IDHW(NHEP)=MOD(ID,6)
+ IDHEP(NHEP)=IDPDG(IDHW(NHEP))
+ ENDIF
+ ELSEIF (ID.LT.7) THEN
+ IDHW(NHEP)=13
+ IDHEP(NHEP)=IDPDG(13)
+ ELSE
+ IDHW(NHEP)=IDHW(IOUT)
+ IDHEP(NHEP)=IDHEP(IOUT)
+ IDHW(IOUT)=13
+ IDHEP(IOUT)=IDPDG(13)
+ ENDIF
+ JDAHEP(2,ICMF)=NHEP
+ JMOHEP(1,NHEP)=ICMF
+C---COLOUR CONNECTIONS
+ IF (XP.EQ.XBJ) THEN
+ JMOHEP(2,IIN)=IIN
+ JDAHEP(2,IIN)=IIN
+ JMOHEP(2,IOUT)=NHEP
+ JDAHEP(2,IOUT)=NHEP
+ JMOHEP(2,NHEP)=IOUT
+ JDAHEP(2,NHEP)=IOUT
+ ELSE
+ JDAHEP(2,IIN)=NHEP
+ JDAHEP(2,NHEP)=IOUT
+ JMOHEP(2,IOUT)=NHEP
+ JMOHEP(2,NHEP)=IIN
+ ENDIF
+C---FACTORISATION SCALE
+ EMSCA=SCALE
+ EMIT=NEVHEP+NWGTS
+ ELSEIF (IOPT.EQ.2) THEN
+C---MAKE TWO-JET EVENTS LOOK LIKE ONE-JET EVENTS
+ IF (EMIT.NE.NEVHEP+NWGTS .OR. XP.EQ.XBJ) RETURN
+ IF (.NOT.BGF) THEN
+ CALL HWVEQU(5,Q1,PHEP(1,IIN))
+ CALL HWVEQU(5,Q2,PHEP(1,IOUT))
+ JMOHEP(2,IIN)=IOUT
+ JDAHEP(2,IIN)=IOUT
+ JMOHEP(2,IOUT)=IIN
+ JDAHEP(2,IOUT)=IIN
+ JDAHEP(2,ICMF)=IOUT
+ IHEP=JDAHEP(1,IOUT)
+ JHEP=JDAHEP(1,IOUT+1)
+ CALL HWVSUM(4,PHEP(1,IHEP),PHEP(1,JHEP),PHEP(1,IHEP))
+ CALL HWUMAS(PHEP(1,IHEP))
+ JDAHEP(2,IHEP)=JDAHEP(2,JHEP)
+ IEDT(1)=IOUT+1
+ IEDT(2)=JHEP
+ IEDT(3)=JHEP+1
+ NDEL=3
+ IF (ISTHEP(JHEP+1).NE.100) NDEL=2
+ IHEP=JDAHEP(1,IOUT)
+ JMOHEP(1,IHEP)=IOUT
+ IF (ISTHEP(IHEP+1).EQ.100) THEN
+ JMOHEP(1,IHEP+1)=IOUT
+ JMOHEP(2,IHEP+1)=IIN
+ ENDIF
+ DO 300 JHEP=JDAHEP(1,IHEP),JDAHEP(2,IHEP)
+ JMOHEP(1,JHEP)=IHEP
+ 300 CONTINUE
+ IF (IDHW(IOUT).EQ.13) IDHW(IOUT)=IDHW(IOUT+1)
+ IDHEP(IOUT)=IDPDG(IDHW(IOUT))
+ IDHW(IHEP)=IDHW(IOUT)
+ CALL HWUEDT(NDEL,IEDT)
+ ELSEIF (ID.LT.7) THEN
+ CALL HWVEQU(5,Q1,PHEP(1,IIN))
+ CALL HWVEQU(5,Q2,PHEP(1,IOUT+1))
+ JMOHEP(2,IIN)=IOUT+1
+ JDAHEP(2,IIN)=IOUT+1
+ JMOHEP(2,IOUT+1)=IIN
+ JDAHEP(2,IOUT+1)=IIN
+ JDAHEP(2,ICMF)=IOUT+1
+ IHEP=JDAHEP(1,IIN)
+ JHEP=JDAHEP(1,IOUT)
+ CALL HWVDIF(4,PHEP(1,IHEP),PHEP(1,JHEP),PHEP(1,IHEP))
+ CALL HWUMAS(PHEP(1,IHEP))
+ CALL HWVDIF(4,PHEP(1,ICMF),PHEP(1,JHEP),PHEP(1,ICMF))
+ CALL HWUMAS(PHEP(1,ICMF))
+ CALL HWUEMV(JDAHEP(2,JHEP)-JDAHEP(1,JHEP)+1,
+ $ JDAHEP(1,JHEP),JDAHEP(2,IHEP))
+ JHEP=JDAHEP(1,IOUT)
+ JDAHEP(2,IHEP)=JDAHEP(2,JHEP)
+ IEDT(1)=IOUT
+ IEDT(2)=JHEP
+ IEDT(3)=JHEP+1
+ NDEL=3
+ IF (ISTHEP(JHEP+1).NE.100) NDEL=2
+ CALL HWUEDT(NDEL,IEDT)
+ IHEP=JDAHEP(1,IIN)
+ DO 400 JHEP=JDAHEP(1,IHEP),JDAHEP(2,IHEP)
+ JMOHEP(1,JHEP)=IHEP
+ 400 CONTINUE
+ IDHW(IIN)=ID
+ IDHEP(IIN)=IDPDG(ID)
+ IDHW(IHEP)=ID
+ ELSE
+ CALL HWVEQU(5,Q1,PHEP(1,IIN))
+ CALL HWVEQU(5,Q2,PHEP(1,IOUT))
+ JMOHEP(2,IIN)=IOUT
+ JDAHEP(2,IIN)=IOUT
+ JMOHEP(2,IOUT)=IIN
+ JDAHEP(2,IOUT)=IIN
+ JDAHEP(2,ICMF)=IOUT
+ IHEP=JDAHEP(1,IIN)
+ JHEP=JDAHEP(1,IOUT+1)
+ CALL HWVDIF(4,PHEP(1,IHEP),PHEP(1,JHEP),PHEP(1,IHEP))
+ CALL HWUMAS(PHEP(1,IHEP))
+ CALL HWVDIF(4,PHEP(1,ICMF),PHEP(1,JHEP),PHEP(1,ICMF))
+ CALL HWUMAS(PHEP(1,ICMF))
+ CALL HWUEMV(JDAHEP(2,JHEP)-JDAHEP(1,JHEP)+1,
+ $ JDAHEP(1,JHEP),JDAHEP(1,IHEP)-1)
+ JHEP=JDAHEP(1,IOUT+1)
+ JDAHEP(1,IHEP)=JDAHEP(1,JHEP)
+ IEDT(1)=IOUT+1
+ IEDT(2)=JHEP
+ IEDT(3)=JHEP+1
+ NDEL=3
+ IF (ISTHEP(JHEP+1).NE.100.OR.JHEP.EQ.NHEP) NDEL=2
+ CALL HWUEDT(NDEL,IEDT)
+ IHEP=JDAHEP(1,IIN)
+ DO 500 JHEP=JDAHEP(1,IHEP),JDAHEP(2,IHEP)
+ JMOHEP(1,JHEP)=IHEP
+ 500 CONTINUE
+ IDHW(IIN)=ID
+ IDHEP(IIN)=IDPDG(ID)
+ IDHW(IHEP)=ID
+ ENDIF
+ CALL HWVZRO(4,VHEP(1,IIN))
+ CALL HWVZRO(4,VHEP(1,JDAHEP(1,IIN)))
+ IF (ISTHEP(JDAHEP(1,IIN)+1).EQ.100)
+ $ CALL HWVZRO(4,VHEP(1,JDAHEP(1,IIN)+1))
+ CALL HWVZRO(4,VHEP(1,IOUT))
+ CALL HWVZRO(4,VHEP(1,JDAHEP(1,IOUT)))
+ IF (ISTHEP(JDAHEP(1,IOUT)+1).EQ.100)
+ $ CALL HWVZRO(4,VHEP(1,JDAHEP(1,IOUT)+1))
+ EMIT=0
+ ELSE
+ CALL HWWARN('HWBDIS',500,*999)
+ ENDIF
+ 999 END
+CDECK ID>, HWBDYP.
+*CMZ :- -26/10/99 17.46.56 by Mike Seymour
+*-- Author : Gennaro Corcella
+C-----------------------------------------------------------------------
+ SUBROUTINE HWBDYP(IOPT)
+C MATRIX ELEMENT CORRECTIONS TO DRELL-YAN PROCESSES
+C-----------------------------------------------------------------------
+ INCLUDE 'HERWIG61.INC'
+ DOUBLE PRECISION HWBVMC,HWR,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,HWR,HWUALF,HWUSQR
+ SAVE ICMF,ID4,ID5
+ DATA EMIT,NTMP/2*0/
+ IF (IOPT.EQ.1) THEN
+ EMIT=0
+ NTMP=0
+C-----CHOOSE WEIGHTS
+ COMWGT1=0.1
+ COMWGT2=0.55
+C---FIND AN UNTREATED CMF
+ ICMF=0
+ DO 10 IHEP=1,NHEP
+ 10 IF (ICMF.EQ.0 .AND. ISTHEP(IHEP).EQ.110.AND.
+ & JDAHEP(2,IHEP).EQ.JDAHEP(1,IHEP)+1) ICMF=IHEP
+ IF (ICMF.EQ.0) RETURN
+ EM=PHEP(5,ICMF)
+C-----SET THE VECTOR BOSON RAPIDITY
+ Y=HALF*LOG((PHEP(4,ICMF)+PHEP(3,ICMF))/
+ & (PHEP(4,ICMF)-PHEP(3,ICMF)))
+C------SET PARTICLE IDENTIES
+c------ID1=QUARK, ID2=ANTIQUARK, IDBOS=VECTOR BOSON, ID4-5 BOSON DECAY
+ IDBOS=IDHW(ICMF)
+ ID1=IDHW(JMOHEP(1,ICMF))
+ ID2=IDHW(JMOHEP(2,ICMF))
+ ID4=IDHW(JDAHEP(1,ICMF))
+ ID5=IDHW(JDAHEP(2,ICMF))
+ M1=RMASS(ID1)
+ M2=RMASS(ID2)
+ M3=RMASS(13)
+C---STORE OLD MOMENTA
+C------VECTOR BOSON MOMENTUM
+ CALL HWVEQU(5,PHEP(1,ICMF),PBOS)
+C----QUARK MOMENTUM
+ CALL HWVEQU(5,PHEP(1,JMOHEP(1,ICMF)),P1)
+C------ANTIQUARK MOMENTUM
+ CALL HWVEQU(5,PHEP(1,JMOHEP(2,ICMF)),P2)
+C-------VECTOR DECAY (LEPTON) PRODUCT MOMENTA
+ CALL HWVEQU(5,PHEP(1,JDAHEP(1,ICMF)),P3)
+ CALL HWVEQU(5,PHEP(1,JDAHEP(2,ICMF)),P4)
+C------LEPTON MOMENTA IN THE BOSON REST FRAME
+ CALL HWULOF(PHEP(1,ICMF),P2,P2N)
+ CALL HWULOF(PHEP(1,ICMF),P3,P3N)
+C------AZ=AZIMUTHAL ANGLE OF P3N
+ AZ=ATAN2(P3N(2),P3N(1))
+ CZ=COS(AZ)
+ SZ=SIN(AZ)
+C------PHI=ANGLE BETWEEN P2N AND P3N
+ SCAPR=P2N(1)*P3N(1)+P2N(2)*P3N(2)+P2N(3)*P3N(3)
+ PMOD2=SQRT(P2N(1)**2+P2N(2)**2+P2N(3)**2)
+ PMOD3=SQRT(P3N(1)**2+P3N(2)**2+P3N(3)**2)
+ CPHI=SCAPR/(PMOD3*PMOD2)
+ SPHI=SQRT(1-CPHI**2)
+C------HADRON MOMENTA
+ IHAD1=1
+ IHAD2=2
+ IF (JDAHEP(1,IHAD1).NE.0) IHAD1=JDAHEP(1,IHAD1)
+ IF (JDAHEP(1,IHAD2).NE.0) IHAD2=JDAHEP(1,IHAD2)
+ CALL HWVEQU(5,PHEP(1,IHAD1),PHAD1)
+ CALL HWVEQU(5,PHEP(1,IHAD2),PHAD2)
+ CALL HWVSUM(4,PHAD1,PHAD2,PTOT)
+ CALL HWUMAS(PTOT)
+C------ Q - QBAR ENERGY FRACTIONS (BORN PROCESS)
+ ETA1=P1(4)/PHAD1(4)
+ ETA2=P2(4)/PHAD2(4)
+C------ PDFs FOR THE BORN PROCESS
+ CALL HWSFUN(ETA1,EM,IDHW(IHAD1),NSTRU,PDFOLD1,1)
+ CALL HWSFUN(ETA2,EM,IDHW(IHAD2),NSTRU,PDFOLD2,2)
+C-------CONSIDER Q(QBAR) IN THE INITIAL STATE
+ RN=HWR()
+ 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+HWR()*(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)**HWR()
+ IF (HWR().GT.HALF) T=EM**2-S-T
+ U=EM**2-S-T
+ JAC=JAC*2*T*U/(S-EM**2)*LOG(TMIN/TMAX)
+ SCALE=SQRT(U*T/S)
+ SCALE1=SQRT(U*T/S+EM**2)
+ GLUFAC=0
+ IF (SCALE1.GT.HWBVMC(13)) GLUFAC=HWUALF(1,SCALE1)/(2*PIFAC)
+C----Q-QBAR ENERGY FRACTIONS FOR Q QBAR-> VG
+ XI1=(HALF/PHAD1(4))*EXP(Y)*SQRT(S*(S+T)/(S+U))
+ XI2=S/(4*XI1*PHAD1(4)*PHAD2(4))
+ IF (XI1.GE.1.OR.XI2.GE.1) RETURN
+C-----PDFs WITH AN EMITTED GLUON
+ CALL HWSFUN(XI1,SCALE,IDHW(IHAD1),NSTRU,PDFNEW1,1)
+ CALL HWSFUN(XI2,SCALE,IDHW(IHAD2),NSTRU,PDFNEW2,2)
+C------CALCULATE WEIGHT
+ W=JAC*((EM**2-T)**2+(EM**2-U)**2)/(S**2*T*U)
+ W1=(GLUFAC/COMWGT1)*W*PDFNEW1(ID1)*PDFNEW2(ID2)/(PDFOLD1(ID1)*
+ & PDFOLD2(ID2))*(CFFAC*ETA1*ETA2/(XI1*XI2))
+C-------CHOOSE WHICH PARTON WILL EMIT
+ EMIT=1
+ IF (HWR().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+HWR()*(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)**HWR()
+ JAC=JAC*T*LOG(TMAX/TMIN)
+ U=EM**2-S-T
+ SCALE=SQRT(U*T/S)
+ SCALE1=SQRT(U*T/S+EM**2)
+ GLUFAC=0
+ IF (SCALE1.GT.HWBVMC(13)) GLUFAC=HWUALF(1,SCALE1)/(2*PIFAC)
+C--------INITIAL STATE GLUON COMING FROM HADRON 1
+ IF (RN.LE.COMWGT2) THEN
+ GP=.TRUE.
+C--------ENERGY FRACTIONS and PDFs
+ XI1=(HALF/PHAD1(4))*EXP(Y)*SQRT(S*(S+U)/(S+T))
+ XI2=S/(4*XI1*PHAD1(4)*PHAD2(4))
+ IF (XI1.GE.1.OR.XI2.GE.1) RETURN
+ CALL HWSFUN(XI1,SCALE,IDHW(IHAD1),NSTRU,PDFNEW1,1)
+ CALL HWSFUN(XI2,SCALE,IDHW(IHAD2),NSTRU,PDFNEW2,2)
+ WW=PDFNEW1(13)*PDFNEW2(ID2)/((COMWGT2-COMWGT1)*
+ & PDFOLD1(ID1)*PDFOLD2(ID2))
+ ELSE
+C-------INITIAL STATE GLUON COMING FROM HADRON 2
+ GP=.FALSE.
+C-------ENERGY FRACTIONS AND PDFs
+ XI1=(HALF/PHAD1(4))*EXP(Y)*SQRT(S*(S+T)/(S+U))
+ XI2=S/(4*XI1*PHAD1(4)*PHAD2(4))
+ IF (XI1.GE.1.OR.XI2.GE.1) RETURN
+ CALL HWSFUN(XI1,SCALE,IDHW(IHAD1),NSTRU,PDFNEW1,1)
+ CALL HWSFUN(XI2,SCALE,IDHW(IHAD2),NSTRU,PDFNEW2,2)
+ WW=PDFNEW1(ID1)*PDFNEW2(13)/((1-COMWGT2)*
+ & PDFOLD1(ID1)*PDFOLD2(ID2))
+ ENDIF
+ W=-HALF*JAC*((EM**2-T)**2+(EM**2-S)**2)/(S**3*T)
+C-------CHOOSE WHICH PARTON WILL EMIT
+ EMIT=1
+ IF (HWR().LT.(EM**2-S)**2/((EM**2-S)**2+(EM**2-T)**2))
+ & EMIT=2
+ NOEMIT=3-EMIT
+C-------FINAL WEIGHT FOR ALL THE CONSIDERED OPTIONS
+ W1=GLUFAC*W*WW*ETA1*ETA2/(XI1*XI2)
+ ENDIF
+C--------ADD ONE MORE GLUON
+ IF (W1.GT.HWR()) THEN
+ NTMP=NEVHEP+NWGTS
+ ELSE
+ RETURN
+ ENDIF
+C---------INCLUDE MASSES
+ S=S+M1**2+M2**2+M3**2
+ IF (.NOT.GLUIN) THEN
+ TEST=((S+M1**2-M2**2)*(S+M3**2-EM**2)-2*S*(M1**2+M3**2-T))**2
+ $ -((S-M1**2-M2**2)**2-4*M1**2*M2**2)*
+ $ ((S-M3**2-EM**2)**2-4*M3**2*EM**2)
+ ELSEIF (GP) THEN
+ TEST=((S+M3**2-M2**2)*(S+M1**2-EM**2)-2*S*(M3**2+M1**2-T))**2
+ $ -((S-M3**2-M2**2)**2-4*M3**2*M2**2)*
+ $ ((S-M1**2-EM**2)**2-4*M1**2*EM**2)
+ ELSE
+ TEST=((S+M3**2-M1**2)*(S+M2**2-EM**2)-2*S*(M3**2+M2**2-T))**2
+ $ -((S-M3**2-M1**2)**2-4*M3**2*M1**2)*
+ $ ((S-M2**2-EM**2)**2-4*M2**2*EM**2)
+ ENDIF
+ IF (TEST.GE.0) THEN
+ EMIT=0
+ RETURN
+ ENDIF
+ M(1)=M1
+ M(2)=M2
+ M(3)=M3
+C----MOMENTA IN THE V-REST FRAME WITH NON EMITTER ALONG THE Z AXIS
+C----V=BOSON,K=GLUON,E=EMITTER,NE=NON-EMITTER
+ PV(1)=0
+ PV(2)=0
+ PV(3)=0
+ PV(4)=EM
+ PV(5)=EM
+ PNE(2)=0
+ PNE(1)=0
+ IF (.NOT.GLUIN) THEN
+ PK(4)=(S-M(3)**2-EM**2)/(2*EM)
+ PMODK=SQRT(PK(4)**2-M(3)**2)
+ IF (EMIT.EQ.1) THEN
+ MM=M(1)
+ X1=T
+ X2=U
+ X3=-1
+ ELSE
+ MM=M(2)
+ X1=U
+ X2=T
+ X3=+1
+ ENDIF
+ PNE(4)=(EM**2+MM**2-X1)/(2*EM)
+ PNE(3)=X3*SQRT(PNE(4)**2-MM**2)
+ COS3=HALF*(X2-MM**2-M(3)**2+2*PNE(4)*PK(4))/(PNE(3)*PMODK)
+ ELSE
+ PK(4)=(EM**2+M(3)**2-U)/(2*EM)
+ PMODK=SQRT(PK(4)**2-M(3)**2)
+ IF (EMIT.EQ.1) THEN
+ IF (GP) THEN
+ MM=M(1)
+ X3=+1
+ ELSE
+ MM=M(2)
+ X3=-1
+ ENDIF
+ PNE(4)=(S-MM**2-EM**2)/(2*EM)
+ PNE(3)=X3*SQRT(PNE(4)**2-MM**2)
+ COS3=HALF*(T-MM**2-M(3)**2+2*PNE(4)*PK(4))/(PNE(3)*PMODK)
+ ELSE
+ IF (GP) THEN
+ MM=M(2)
+ X3=-1
+ ELSE
+ MM=M(1)
+ X3=+1
+ ENDIF
+ PNE(4)=(EM**2+MM**2-T)/(2*EM)
+ PNE(3)=X3*SQRT(PNE(4)**2-MM**2)
+ COS3=HALF*(MM**2+M(3)**2-S+2*PNE(4)*PK(4))/(PNE(3)*PMODK)
+ ENDIF
+ ENDIF
+ CALL HWUMAS(PNE)
+ SIN3=SQRT(1-COS3**2)
+C---------DEFINE A RANDOM ROTATION AROUND THE Z-AXIS
+ CALL HWRAZM(PMODK*SIN3,PK(1),PK(2))
+ PK(3)=PMODK*COS3
+ CALL HWUMAS(PK)
+ DO K=1,4
+ IF (.NOT.GLUIN) THEN
+ PE(K)=PV(K)+PK(K)-PNE(K)
+ ELSE
+ IF (EMIT.EQ.1) THEN
+ PE(K)=PV(K)+PNE(K)-PK(K)
+ ELSE
+ PE(K)=PNE(K)+PK(K)-PV(K)
+ ENDIF
+ ENDIF
+ ENDDO
+ CALL HWUMAS(PE)
+c------LEPTON MOMENTA IN THE BOSON REST FRAME, WITH THE DIRECTION
+C------TAKEN FROM THE BORN PROCESS
+ PS(5)=P3(5)
+ PS(4)=(EM**2+P3(5)**2-P4(5)**2)/(2*EM)
+ PS(3)=-SQRT(PS(4)**2-P3(5)**2)*CPHI
+ PS(2)=SQRT(PS(4)**2-P3(5)**2)*SPHI*SZ
+ PS(1)=SQRT(PS(4)**2-P3(5)**2)*SPHI*CZ
+ PF(5)=P4(5)
+ PF(4)=(EM**2+P4(5)**2-P3(5)**2)/(2*EM)
+ PF(3)=-PS(3)
+ PF(2)=-PS(2)
+ PF(1)=-PS(1)
+C----FIND A STATIONARY VECTOR PLAB IN THE LAB FRAME
+ IF (.NOT.GLUIN) THEN
+ IF (EMIT.EQ.1) THEN
+ CALL HWVEQU(5,PE,PP1)
+ CALL HWVEQU(5,PNE,PP2)
+ ELSE
+ CALL HWVEQU(5,PNE,PP1)
+ CALL HWVEQU(5,PE,PP2)
+ ENDIF
+ ELSE
+ IF (GP) THEN
+ CALL HWVEQU(5,PK,PP1)
+ IF (EMIT.EQ.1) THEN
+ CALL HWVEQU(5,PE,PP2)
+ ELSE
+ CALL HWVEQU(5,PNE,PP2)
+ ENDIF
+ ELSE
+ CALL HWVEQU(5,PK,PP2)
+ IF (EMIT.EQ.1) THEN
+ CALL HWVEQU(5,PE,PP1)
+ ELSE
+ CALL HWVEQU(5,PNE,PP1)
+ ENDIF
+ ENDIF
+ ENDIF
+ CALL HWVSCA(4,1/XI1,PP1,PP1)
+ CALL HWVSCA(4,1/XI2,PP2,PP2)
+ CALL HWVSUM(4,PP1,PP2,PLAB)
+ CALL HWUMAS(PLAB)
+C------BOOST TO PLAB REST FRAME
+ CALL HWULOF(PLAB,PE,PE)
+ CALL HWULOF(PLAB,PNE,PNE)
+ CALL HWULOF(PLAB,PK,PK)
+ CALL HWULOF(PLAB,PS,PS)
+ CALL HWULOF(PLAB,PF,PF)
+ CALL HWULOF(PLAB,PV,PV)
+C----PUT THE INITIAL PARTON BELONGING TO HADRON 1 ON THE Z-AXIS
+ IF (.NOT.GLUIN) THEN
+ IF (EMIT.EQ.1) THEN
+ CALL HWVEQU(5,PE,PZ)
+ ELSE
+ CALL HWVEQU(5,PNE,PZ)
+ ENDIF
+ ELSE
+ IF (GP) THEN
+ CALL HWVEQU(5,PK,PZ)
+ ELSE
+ IF (EMIT.EQ.1) THEN
+ CALL HWVEQU(5,PE,PZ)
+ ELSE
+ CALL HWVEQU(5,PNE,PZ)
+ ENDIF
+ ENDIF
+ ENDIF
+ MODP=SQRT(PZ(1)**2+PZ(2)**2)
+ CTH=PZ(1)/MODP
+ STH=PZ(2)/MODP
+ CALL HWUROT(PZ,CTH,STH,R3)
+C-----ROTATE EVERYTHING BY R3
+ CALL HWUROF(R3,PE,PE)
+ CALL HWUROF(R3,PNE,PNE)
+ CALL HWUROF(R3,PV,PV)
+ CALL HWUROF(R3,PK,PK)
+ CALL HWUROF(R3,PS,PS)
+ CALL HWUROF(R3,PF,PF)
+C--REORDER ENTRIES:--IHEP=EMITTER,JHEP=NON-EMITTER,KHEP=EMITTED
+ IF (.NOT.GLUIN) THEN
+ IHEP=JMOHEP(EMIT,ICMF)
+ JHEP=JMOHEP(NOEMIT,ICMF)
+ ENDIF
+ CHEP=ICMF
+ IDHW(CHEP)=15
+ IDHEP(CHEP)=IDPDG(15)
+ ICMF=ICMF+1
+ IDHW(ICMF)=IDBOS
+ IDHEP(ICMF)=IDPDG(IDBOS)
+C-----NO GLUON IN THE INITIAL STATE: JUST ADD IT AFTER THE VECTOR BOSON
+ IF (.NOT.GLUIN) THEN
+ KHEP=ICMF+1
+ ISTHEP(KHEP)=114
+C---STATUS OF EMITTER/NON EMITTER
+ ISTHEP(IHEP)=110+EMIT
+ ISTHEP(JHEP)=110+NOEMIT
+ ELSE
+C-----GLUON COMING FROM THE 1ST HADRON
+ IF (GP) THEN
+ KHEP=CHEP-2
+ ISTHEP(KHEP)=111
+C----EMIT=1
+ IF (EMIT.EQ.1) THEN
+ IHEP=KHEP+1
+ ISTHEP(IHEP)=112
+ JHEP=ICMF+1
+ ISTHEP(JHEP)=114
+ IDHW(IHEP)=ID2
+ IF (ID1.LE.6) THEN
+ IDHW(JHEP)=ID1+6
+ ELSE
+ IDHW(JHEP)=ID1-6
+ ENDIF
+ ELSE
+C-------EMIT=2
+ JHEP=KHEP+1
+ ISTHEP(JHEP)=112
+ IDHW(JHEP)=ID2
+ IHEP=ICMF+1
+ ISTHEP(IHEP)=114
+ IF (ID1.LE.6) THEN
+ IDHW(IHEP)=ID1+6
+ ELSE
+ IDHW(IHEP)=ID1-6
+ ENDIF
+ ENDIF
+ ENDIF
+C------GLUON COMING FROM THE HADRON 2
+ IF (.NOT.GP) THEN
+ KHEP=CHEP-1
+ ISTHEP(KHEP)=112
+C-------EMIT=1
+ IF (EMIT.EQ.1) THEN
+ IHEP=KHEP-1
+ ISTHEP(IHEP)=111
+ IDHW(IHEP)=ID1
+ JHEP=ICMF+1
+ ISTHEP(JHEP)=114
+ IF (ID2.LE.6) THEN
+ IDHW(JHEP)=ID2+6
+ ELSE
+ IDHW(JHEP)=ID2-6
+ ENDIF
+ ELSE
+C-------EMIT=2
+ JHEP=KHEP-1
+ ISTHEP(JHEP)=111
+ IDHW(JHEP)=ID1
+ IHEP=ICMF+1
+ ISTHEP(IHEP)=114
+ IF (ID2.LE.6) THEN
+ IDHW(IHEP)=ID2+6
+ ELSE
+ IDHW(IHEP)=ID2-6
+ ENDIF
+ ENDIF
+ ENDIF
+ ENDIF
+ IDHEP(IHEP)=IDPDG(IDHW(IHEP))
+ IDHEP(JHEP)=IDPDG(IDHW(JHEP))
+ ISTHEP(ICMF)=113
+ ISTHEP(CHEP)=110
+ IDHW(KHEP)=13
+ IDHEP(KHEP)=IDPDG(13)
+C---------DEFINE MOMENTA IN THE LAB FRAME
+ CALL HWVEQU(5,PV,PHEP(1,ICMF))
+ CALL HWVEQU(5,PK,PHEP(1,KHEP))
+ CALL HWVEQU(5,PNE,PHEP(1,JHEP))
+ CALL HWVEQU(5,PE,PHEP(1,IHEP))
+ IF (.NOT.GLUIN) THEN
+ CALL HWVSUM(4,PHEP(1,IHEP),PHEP(1,JHEP),PHEP(1,CHEP))
+ ELSE
+ IF (EMIT.EQ.1) THEN
+ CALL HWVSUM(4,PHEP(1,IHEP),PHEP(1,KHEP),PHEP(1,CHEP))
+ ELSE
+ CALL HWVSUM(4,PHEP(1,KHEP),PHEP(1,JHEP),PHEP(1,CHEP))
+ ENDIF
+ ENDIF
+ CALL HWUMAS(PHEP(1,CHEP))
+ IF (.NOT.GLUIN) THEN
+ JMOHEP(1,JHEP)=CHEP
+ JMOHEP(1,IHEP)=CHEP
+ JDAHEP(1,JHEP)=CHEP
+ JDAHEP(1,IHEP)=CHEP
+ JMOHEP(1,KHEP)=CHEP
+ JDAHEP(1,KHEP)=0
+ JMOHEP(1,ICMF)=CHEP
+ JMOHEP(2,ICMF)=ICMF
+ JDAHEP(1,ICMF)=0
+ JDAHEP(2,ICMF)=ICMF
+ ENDIF
+ IF (GLUIN) THEN
+ JMOHEP(2,ICMF)=ICMF
+ JDAHEP(2,ICMF)=ICMF
+ JMOHEP(1,KHEP)=CHEP
+ JDAHEP(1,KHEP)=CHEP
+ JMOHEP(1,IHEP)=CHEP
+ JMOHEP(1,JHEP)=CHEP
+ IF (EMIT.EQ.1) THEN
+ JDAHEP(1,IHEP)=CHEP
+ JDAHEP(1,JHEP)=0
+ ELSE
+ JDAHEP(1,JHEP)=CHEP
+ JDAHEP(1,IHEP)=0
+ ENDIF
+ ENDIF
+C---COLOUR CONNECTIONS
+ IF (.NOT.GLUIN) THEN
+ IF (IDHW(IHEP).LT.IDHW(JHEP)) THEN
+ JMOHEP(2,KHEP)=IHEP
+ JDAHEP(2,KHEP)=JHEP
+ JMOHEP(2,IHEP)=JHEP
+ JDAHEP(2,IHEP)=KHEP
+ JDAHEP(2,JHEP)=IHEP
+ JMOHEP(2,JHEP)=KHEP
+ ELSE
+ JMOHEP(2,KHEP)=JHEP
+ JDAHEP(2,KHEP)=IHEP
+ JMOHEP(2,JHEP)=IHEP
+ JDAHEP(2,JHEP)=KHEP
+ JDAHEP(2,IHEP)=JHEP
+ JMOHEP(2,IHEP)=KHEP
+ ENDIF
+ ENDIF
+ IF (GLUIN) THEN
+ IF (EMIT.EQ.1) THEN
+ IF (IDHEP(IHEP).GT.0) THEN
+ JMOHEP(2,IHEP)=JHEP
+ JDAHEP(2,IHEP)=KHEP
+ JMOHEP(2,JHEP)=KHEP
+ JDAHEP(2,JHEP)=IHEP
+ JMOHEP(2,KHEP)=IHEP
+ JDAHEP(2,KHEP)=JHEP
+ ELSE
+ JMOHEP(2,IHEP)=KHEP
+ JDAHEP(2,IHEP)=JHEP
+ JMOHEP(2,JHEP)=IHEP
+ JDAHEP(2,JHEP)=KHEP
+ JMOHEP(2,KHEP)=JHEP
+ JDAHEP(2,KHEP)=IHEP
+ ENDIF
+ ELSE
+ IF (IDHEP(JHEP).GT.0) THEN
+ JMOHEP(2,JHEP)=IHEP
+ JDAHEP(2,JHEP)=KHEP
+ JMOHEP(2,IHEP)=KHEP
+ JDAHEP(2,IHEP)=JHEP
+ JMOHEP(2,KHEP)=JHEP
+ JDAHEP(2,KHEP)=IHEP
+ ELSE
+ JMOHEP(2,JHEP)=KHEP
+ JDAHEP(2,JHEP)=IHEP
+ JMOHEP(2,IHEP)=JHEP
+ JDAHEP(2,IHEP)=KHEP
+ JMOHEP(2,KHEP)=IHEP
+ JDAHEP(2,KHEP)=JHEP
+ ENDIF
+ ENDIF
+ ENDIF
+ EMSCA=SQRT(EM**2+PHEP(1,ICMF)**2+PHEP(2,ICMF)**2)
+C--------SET STATUS AND LEPTON MOMENTA AFTER THE PARTON SHOWER
+ ELSEIF (IOPT.EQ.2) THEN
+ IF (EMIT.EQ.0.OR.NEVHEP+NWGTS.NE.NTMP) RETURN
+ ISTHEP(JDAHEP(1,ICMF))=195
+ IDHW(NHEP+1)=ID4
+ IDHW(NHEP+2)=ID5
+ IDHEP(NHEP+1)=IDPDG(ID4)
+ IDHEP(NHEP+2)=IDPDG(ID5)
+ ISTHEP(NHEP+1)=113
+ ISTHEP(NHEP+2)=114
+ CW=PHEP(3,ICMF)/SQRT(PHEP(1,ICMF)**2+PHEP(2,ICMF)**2+
+ & PHEP(3,ICMF)**2)
+ SW=SQRT(1-CW**2)
+ CALL HWUROT(PHEP(1,ICMF),CW,SW,R4)
+ CALL HWUROF(R4,PHEP(1,ICMF),PR)
+ PR(4)=PHEP(4,ICMF)
+ CALL HWUMAS(PR)
+ CALL HWUROF(R4,PS,PS)
+ CALL HWUROF(R4,PF,PF)
+ CALL HWUMAS(PS)
+ CALL HWUMAS(PF)
+ CALL HWUROT(PHEP(1,JDAHEP(1,ICMF)),CW,SW,R5)
+ CALL HWUROF(R5,PHEP(1,JDAHEP(1,ICMF)),PD)
+ PD(4)=PHEP(4,JDAHEP(1,ICMF))
+ CALL HWUMAS(PD)
+ BETA1=(PR(4)*PR(3)-SQRT(PR(4)**2*PD(3)**2-PR(3)**2*PD(3)**2+
+ & PD(3)**4))/(PD(3)**2+PR(4)**2)
+ GAMMA1=1/SQRT(1-BETA1**2)
+ PHEP(4,NHEP+1)=GAMMA1*PS(4)-BETA1*GAMMA1*PS(3)
+ PHEP(3,NHEP+1)=-BETA1*GAMMA1*PS(4)+GAMMA1*PS(3)
+ PHEP(4,NHEP+2)=GAMMA1*PF(4)-BETA1*GAMMA1*PF(3)
+ PHEP(3,NHEP+2)=-BETA1*GAMMA1*PF(4)+GAMMA1*PF(3)
+ PHEP(1,NHEP+1)=PS(1)
+ PHEP(2,NHEP+1)=PS(2)
+ PHEP(1,NHEP+2)=PF(1)
+ PHEP(2,NHEP+2)=PF(2)
+ CALL HWUMAS(PHEP(1,NHEP+1))
+ CALL HWUMAS(PHEP(1,NHEP+2))
+ CALL HWUROB(R5,PHEP(1,NHEP+1),PHEP(1,NHEP+1))
+ CALL HWUROB(R5,PHEP(1,NHEP+2),PHEP(1,NHEP+2))
+ JDAHEP(1,JDAHEP(1,ICMF))=NHEP+1
+ JDAHEP(2,JDAHEP(1,ICMF))=NHEP+2
+ JMOHEP(1,NHEP+1)=JDAHEP(1,ICMF)
+ JMOHEP(1,NHEP+2)=JDAHEP(1,ICMF)
+ JMOHEP(2,NHEP+1)=NHEP+2
+ JDAHEP(2,NHEP+1)=NHEP+2
+ JMOHEP(2,NHEP+2)=NHEP+1
+ JDAHEP(2,NHEP+2)=NHEP+1
+ NHEP=NHEP+2
+ EMIT=0
+ ENDIF
+ END
+CDECK ID>, HWBFIN.
+*CMZ :- -26/04/91 10.18.56 by Bryan Webber
+*-- Author : Bryan Webber
+C-----------------------------------------------------------------------
+ SUBROUTINE HWBFIN(IHEP)
+C-----------------------------------------------------------------------
+C DELETES INTERNAL LINES FROM SHOWER, MAKES COLOUR CONNECTION INDEX
+C AND COPIES INTO /HEPEVT/ IN COLOUR ORDER.
+C-----------------------------------------------------------------------
+ INCLUDE 'HERWIG61.INC'
+ INTEGER IHEP,ID,IJET,KHEP,IPAR,JPAR,NXPAR,IP,JP
+ IF (IERROR.NE.0) RETURN
+C---SAVE VIRTUAL PARTON DATA
+ NHEP=NHEP+1
+ IF(NHEP.GT.NMXHEP) CALL HWWARN('HWBFIN',100,*999)
+ ID=IDPAR(2)
+ IDHW(NHEP)=ID
+ IDHEP(NHEP)=IDPDG(ID)
+ ISTHEP(NHEP)=ISTHEP(IHEP)+20
+ JMOHEP(1,NHEP)=IHEP
+ JMOHEP(2,NHEP)=JMOHEP(1,IHEP)
+ JDAHEP(1,IHEP)=NHEP
+ JDAHEP(1,NHEP)=0
+ JDAHEP(2,NHEP)=0
+ CALL HWVEQU(5,PPAR(1,2),PHEP(1,NHEP))
+ CALL HWVEQU(4,VPAR(1,2),VHEP(1,NHEP))
+C---FINISHED FOR SPECTATOR OR NON-PARTON JETS
+ IF (ISTHEP(NHEP).GT.136) RETURN
+ IF (ID.GT.13.AND.ID.LT.209 .AND. ID.NE.59) RETURN
+ IF (ID.GT.220.AND.ABS(IDPDG(ID)).LT.1000000) RETURN
+ IF (ID.GT.424.AND.ID.NE.449) RETURN
+ IF (.NOT.TMPAR(2).AND.ID.EQ.59) RETURN
+ IDHEP(NHEP)=94
+ IJET=NHEP
+ IF (NPAR.GT.2) THEN
+C---SAVE CONE DATA
+ NHEP=NHEP+1
+ IF(NHEP.GT.NMXHEP) CALL HWWARN('HWBFIN',101,*999)
+ IDHW(NHEP)=IDPAR(1)
+ IDHEP(NHEP)=0
+ ISTHEP(NHEP)=100
+ JMOHEP(1,NHEP)=IHEP
+ JMOHEP(2,NHEP)=JCOPAR(1,1)
+ JDAHEP(1,NHEP)=0
+ JDAHEP(2,NHEP)=0
+ CALL HWVEQU(5,PPAR,PHEP(1,NHEP))
+ CALL HWVEQU(4,VPAR(1,2),VHEP(1,NHEP))
+ ENDIF
+ KHEP=NHEP
+C---START WITH ANTICOLOUR DAUGHTER OF HARDEST PARTON
+ IPAR=2
+ JPAR=JCOPAR(4,IPAR)
+ NXPAR=NPAR/2
+ DO 20 IP=1,NXPAR
+ DO 10 JP=1,NXPAR
+ IF (JPAR.EQ.0) GOTO 15
+ IF (JCOPAR(2,JPAR).EQ.IPAR) THEN
+ IPAR=JPAR
+ JPAR=JCOPAR(4,IPAR)
+ ELSE
+ IPAR=JPAR
+ JPAR=JCOPAR(1,IPAR)
+ ENDIF
+ 10 CONTINUE
+C---COULDN'T FIND COLOUR PARTNER
+ CALL HWWARN('HWBFIN',1,*999)
+ 15 JPAR=JCOPAR(1,IPAR)
+ KHEP=KHEP+1
+ IF(KHEP.GT.NMXHEP) CALL HWWARN('HWBFIN',102,*999)
+ ID=IDPAR(IPAR)
+ IF (TMPAR(IPAR)) THEN
+ IF (ID.LT.14) THEN
+ ISTHEP(KHEP)=139
+ ELSEIF (ID.EQ.59) THEN
+ ISTHEP(KHEP)=139
+ ELSEIF (ID.LT.109) THEN
+ ISTHEP(KHEP)=130
+ ELSEIF (ID.LT.120) THEN
+ ISTHEP(KHEP)=139
+ ELSEIF (ABS(IDPDG(ID)).LT.1000000) THEN
+ ISTHEP(KHEP)=130
+ ELSEIF (ID.LT.425) THEN
+ ISTHEP(KHEP)=139
+ ELSEIF (ID.EQ.449) THEN
+ ISTHEP(KHEP)=139
+ ELSE
+ ISTHEP(KHEP)=130
+ ENDIF
+ ELSE
+ ISTHEP(KHEP)=ISTHEP(IHEP)+24
+ ENDIF
+ IDHW(KHEP)=ID
+ IDHEP(KHEP)=IDPDG(ID)
+ CALL HWVEQU(5,PPAR(1,IPAR),PHEP(1,KHEP))
+ CALL HWVEQU(4,VPAR(1,IPAR),VHEP(1,KHEP))
+ JMOHEP(1,KHEP)=IJET
+ JMOHEP(2,KHEP)=KHEP+1
+ JDAHEP(1,KHEP)=0
+ JDAHEP(2,KHEP)=KHEP-1
+ 20 CONTINUE
+ JMOHEP(2,KHEP)=0
+ JDAHEP(2,NHEP+1)=0
+ JDAHEP(1,IJET)=NHEP+1
+ JDAHEP(2,IJET)=KHEP
+ NHEP=KHEP
+ 999 END
+CDECK ID>, HWBGEN.
+*CMZ :- -14/10/99 18.04.56 by Mike Seymour
+*-- Author : Bryan Webber
+C-----------------------------------------------------------------------
+ SUBROUTINE HWBGEN
+C-----------------------------------------------------------------------
+C BRANCHING GENERATOR WITH INTERFERING GLUONS
+C HWBGEN EVOLVES QCD JETS ACCORDING TO THE METHOD OF
+C G.MARCHESINI & B.R.WEBBER, NUCL. PHYS. B238(1984)1
+C-----------------------------------------------------------------------
+ INCLUDE 'HERWIG61.INC'
+ DOUBLE PRECISION HWULDO,HWRGAU,EINHEP,ERTXI,RTXI,XF
+ INTEGER NTRY,LASHEP,IHEP,NRHEP,ID,IST,JHEP,KPAR,I,J,IRHEP(NMXJET),
+ & IRST(NMXJET)
+ LOGICAL HWRLOG
+ EXTERNAL HWULDO,HWRGAU
+ IF (IERROR.NE.0) RETURN
+ IF (IPRO.EQ.80) RETURN
+C---CHECK THAT EMSCA IS SET
+ IF (EMSCA.LE.ZERO) CALL HWWARN('HWBGEN',200,*999)
+ IF (HARDME) THEN
+C---FORCE A BRANCH INTO THE `DEAD ZONE' IN E+E-
+ IF (IPROC/10.EQ.10) CALL HWBDED(1)
+C---FORCE A BRANCH INTO THE `DEAD ZONE' IN DIS
+ IF (IPRO.EQ.90) CALL HWBDIS(1)
+C---FORCE A BRANCH INTO THE `DEAD ZONE' IN DRELL-YAN PROCESSES
+ IF (IPRO.EQ.13.OR.IPRO.EQ.14) CALL HWBDYP(1)
+C---FORCE A BRANCH INTO THE `DEAD ZONE' IN TOP DECAYS
+ CALL HWBTOP
+ ENDIF
+C---GENERATE INTRINSIC PT ONCE AND FOR ALL
+ DO 5 JNHAD=1,2
+ IF (PTRMS.NE.0.) THEN
+ PTINT(1,JNHAD)=HWRGAU(1,ZERO,PXRMS)
+ PTINT(2,JNHAD)=HWRGAU(2,ZERO,PXRMS)
+ PTINT(3,JNHAD)=PTINT(1,JNHAD)**2+PTINT(2,JNHAD)**2
+ ELSE
+ CALL HWVZRO(3,PTINT(1,JNHAD))
+ ENDIF
+ 5 CONTINUE
+ NTRY=0
+ LASHEP=NHEP
+ 10 NTRY=NTRY+1
+ IF (NTRY.GT.NETRY) CALL HWWARN('HWBGEN',ISLENT*100,*999)
+ NRHEP=0
+ NHEP=LASHEP
+ FROST=.FALSE.
+ DO 100 IHEP=1,LASHEP
+ IST=ISTHEP(IHEP)
+ IF (IST.GE.111.AND.IST.LE.115) THEN
+ NRHEP=NRHEP+1
+ IRHEP(NRHEP)=IHEP
+ IRST(NRHEP)=IST
+ ID=IDHW(IHEP)
+ IF (IST.NE.115) THEN
+C---FOUND A PARTON TO EVOLVE
+ NEVPAR=IHEP
+ NPAR=2
+ IDPAR(1)=17
+ IDPAR(2)=ID
+ TMPAR(1)=.TRUE.
+ PPAR(2,1)=0.
+ PPAR(4,1)=1.
+ DO 15 J=1,2
+ DO 15 I=1,2
+ JMOPAR(I,J)=0
+ 15 JCOPAR(I,J)=0
+C---SET UP EVOLUTION SCALE AND FRAME
+ JHEP=JMOHEP(2,IHEP)
+ IF (ID.EQ.13) THEN
+ IF (HWRLOG(HALF)) JHEP=JDAHEP(2,IHEP)
+ ELSEIF (IST.GT.112) THEN
+ IF ((ID.GT.6.AND.ID.LT.13).OR.
+ & (ID.GT.214.AND.ID.LT.221)) JHEP=JDAHEP(2,IHEP)
+ ELSE
+ IF (ID.LT.7.OR.(ID.GT.208.AND.ID.LT.215)) JHEP=JDAHEP(2,IHEP)
+ ENDIF
+ IF (JHEP.LE.0.OR.JHEP.GT.NHEP) THEN
+ CALL HWWARN('HWBGEN',1,*999)
+ JHEP=IHEP
+ ENDIF
+ JCOPAR(1,1)=JHEP
+ EINHEP=PHEP(4,IHEP)
+ ERTXI=HWULDO(PHEP(1,IHEP),PHEP(1,JHEP))
+ IF (ERTXI.LT.ZERO) ERTXI=0.
+ IF (IST.LE.112.AND.IHEP.EQ.JHEP) ERTXI=0.
+ IF (ISTHEP(JHEP).EQ.155) THEN
+ ERTXI=ERTXI/PHEP(5,JHEP)
+ RTXI=1.
+ ELSE
+ ERTXI=SQRT(ERTXI)
+ RTXI=ERTXI/EINHEP
+ ENDIF
+ IF (RTXI.EQ.ZERO) THEN
+ XF=1.
+ PPAR(1,1)=0.
+ PPAR(3,1)=1.
+ PPAR(1,2)=EINHEP
+ PPAR(2,2)=0.
+ PPAR(4,2)=EINHEP
+ ELSE
+ XF=1./RTXI
+ PPAR(1,1)=1.
+ PPAR(3,1)=0.
+ PPAR(1,2)=ERTXI
+ PPAR(2,2)=1.
+ PPAR(4,2)=ERTXI
+ ENDIF
+ IF (PPAR(4,2).LT.PHEP(5,IHEP)) PPAR(4,2)=PHEP(5,IHEP)
+C---STORE MASS
+ PPAR(5,2)=PHEP(5,IHEP)
+ CALL HWVZRO(4,VPAR(1,1))
+ CALL HWVZRO(4,VPAR(1,2))
+ IF (IST.GT.112) THEN
+ TMPAR(2)=.TRUE.
+ INHAD=0
+ JNHAD=0
+ XFACT=0.
+ ELSE
+ TMPAR(2)=.FALSE.
+ JNHAD=IST-110
+ INHAD=JNHAD
+ IF (JDAHEP(1,JNHAD).NE.0) INHAD=JDAHEP(1,JNHAD)
+ XFACT=XF/PHEP(4,INHAD)
+ ANOMSC(1,JNHAD)=ZERO
+ ANOMSC(2,JNHAD)=ZERO
+ ENDIF
+C---FOR QUARKS IN A COLOUR SINGLET, ALLOW SOFT MATRIX-ELEMENT CORRECTION
+ HARDST=PPAR(4,2)
+ IF (SOFTME.AND.IDHW(IHEP).LT.13.AND.
+ $ ((JMOHEP(2,JHEP).EQ.IHEP.AND.JDAHEP(2,JHEP).EQ.IHEP).OR.
+ $ ISTHEP(JHEP).EQ.155)) HARDST=0
+C---CREATE BRANCHES AND COMPUTE ENERGIES
+ DO 20 KPAR=2,NMXPAR
+ IF (TMPAR(KPAR)) THEN
+ CALL HWBRAN(KPAR)
+ ELSE
+ CALL HWSBRN(KPAR)
+ ENDIF
+ IF (IERROR.NE.0) RETURN
+ IF (FROST) GOTO 100
+ IF (KPAR.EQ.NPAR) GOTO 30
+ 20 CONTINUE
+C---COMPUTE MASSES AND 3-MOMENTA
+ 30 CONTINUE
+ CALL HWBMAS
+ IF (AZSPIN) CALL HWBSPN
+ IF (TMPAR(2)) THEN
+ CALL HWBTIM(2,1)
+ ELSE
+ CALL HWBSPA
+ ENDIF
+C---ENTER PARTON JET IN /HEPEVT/
+ CALL HWBFIN(IHEP)
+ ELSE
+C---COPY SPECTATOR
+ NHEP=NHEP+1
+ IF (ID.GT.120.AND.ID.LT.133 .OR. ID.GE.198.AND.ID.LE.201) THEN
+ ISTHEP(NHEP)=190
+ ELSE
+ ISTHEP(NHEP)=152
+ ENDIF
+ IDHW(NHEP)=ID
+ IDHEP(NHEP)=IDPDG(ID)
+ JMOHEP(1,NHEP)=IHEP
+ JMOHEP(2,NHEP)=0
+ JDAHEP(2,NHEP)=0
+ JDAHEP(1,IHEP)=NHEP
+ CALL HWVEQU(5,PHEP(1,IHEP),PHEP(1,NHEP))
+ ENDIF
+ ISTHEP(IHEP)=ISTHEP(IHEP)+10
+ ENDIF
+ 100 CONTINUE
+ IF (.NOT.FROST) THEN
+C---COMBINE JETS
+ ISTAT=20
+ CALL HWBJCO
+ ENDIF
+ IF (.NOT.FROST) THEN
+C---ATTACH SPECTATORS
+ ISTAT=30
+ CALL HWSSPC
+ ENDIF
+ IF (FROST) THEN
+C---BAD JET: RESTORE PARTONS AND RE-EVOLVE
+ DO 120 I=1,NRHEP
+ 120 ISTHEP(IRHEP(I))=IRST(I)
+ GOTO 10
+ ENDIF
+C---CONNECT COLOURS
+ CALL HWBCON
+ ISTAT=40
+ LASHEP=NHEP
+ IF (HARDME) THEN
+C---CLEAN UP IF THERE WAS A BRANCH IN THE `DEAD ZONE' IN E+E-
+ IF (IPROC/10.EQ.10) CALL HWBDED(2)
+C---CLEAN UP IF THERE WAS A BRANCH IN THE `DEAD ZONE' IN DIS
+ IF (IPRO.EQ.90) CALL HWBDIS(2)
+C---CLEAN UP IF THERE WAS A BRANCH IN THE `DEAD ZONE' IN DRELL-YAN PROC
+ IF (IPRO.EQ.13.OR.IPRO.EQ.14) CALL HWBDYP(2)
+ ENDIF
+C---IF THE CLEAN-UP OPERATION ADDED ANY PARTONS TO THE EVENT RECORD
+C IT MIGHT NEED RESHOWERING
+ IF (NHEP.GT.LASHEP) THEN
+ LASHEP=NHEP
+ GOTO 10
+ ENDIF
+ 999 END
+CDECK ID>, HWBJCO.
+*CMZ :- -26/04/91 14.25.31 by Federico Carminati
+*-- Author : Bryan Webber
+C-----------------------------------------------------------------------
+ SUBROUTINE HWBJCO
+C-----------------------------------------------------------------------
+C COMBINES JETS WITH REQUIRED KINEMATICS
+C-----------------------------------------------------------------------
+ INCLUDE 'HERWIG61.INC'
+ DOUBLE PRECISION HWULDO,EPS,PTX,PTY,PF,PTINF,PTCON,CN,CP,SP,PP0,
+ & PM0,ET0,DET,ECM,EMJ,EMP,EMS,DMS,ES,DPF,ALF,AL(2),ET(2),PP(2),
+ & PT(3),PB(5),PC(5),PQ(5),PR(5),PS(5),RR(3,3),RS(3,3),ETC,
+ & PJ(NMXJET),PM(NMXJET),PBR(5),RBR(3,3),DISP(4)
+ INTEGER LJET,IJ1,IST,IP,ICM,IP1,IP2,NP,IHEP,MHEP,JP,KP,LP,KHEP,
+ & JHEP,NE,IJT,IEND(2),IJET(NMXJET),IPAR(NMXJET)
+ LOGICAL AZCOR,JETRAD,DISPRO,DISLOW
+ EXTERNAL HWULDO
+ PARAMETER (EPS=1.D-4)
+ IF (IERROR.NE.0) RETURN
+ AZCOR=AZSOFT.OR.AZSPIN
+C---FIRST LOOK FOR SPACELIKE JETS
+ LJET=131
+ 10 IJET(1)=1
+ 20 IJ1=IJET(1)
+ DO 40 IHEP=IJ1,NHEP
+ IST=ISTHEP(IHEP)
+ IF (IST.EQ.137.OR.IST.EQ.138) IST=133
+ IF (IST.EQ.LJET) THEN
+C---FOUND AN UNBOOSTED JET - FIND PARTNERS
+ IP=JMOHEP(1,IHEP)
+ ICM=JMOHEP(1,IP)
+ DISPRO=IPRO/10.EQ.9.AND.IDHW(ICM).EQ.15
+ DISLOW=DISPRO.AND.JDAHEP(1,ICM).EQ.JDAHEP(2,ICM)-1
+ IF (IST.EQ.131) THEN
+ IP1=JMOHEP(1,ICM)
+ IP2=JMOHEP(2,ICM)
+ ELSE
+ IP1=JDAHEP(1,ICM)
+ IP2=JDAHEP(2,ICM)
+ ENDIF
+ IF (IP1.NE.IP) CALL HWWARN('HWBJCO',100,*999)
+ NP=0
+ DO 30 JHEP=IP1,IP2
+ NP=NP+1
+ IPAR(NP)=JHEP
+ 30 IJET(NP)=JDAHEP(1,JHEP)
+ GOTO 50
+ ENDIF
+ 40 CONTINUE
+C---NO MORE JETS?
+ IF (LJET.EQ.131) THEN
+ LJET=133
+ GOTO 10
+ ENDIF
+ RETURN
+ 50 IF (LJET.EQ.131) THEN
+C---SPACELIKE JETS: FIND SPACELIKE PARTONS
+ IF (NP.NE.2) CALL HWWARN('HWBJCO',103,*999)
+C---special for DIS: FIND BOOST AND ROTATION FROM LAB TO BREIT FRAME
+ IF (DISPRO.AND.BREIT) THEN
+ IP=2
+ IF (JDAHEP(1,IP).NE.0) IP=JDAHEP(1,IP)
+ CALL HWVDIF(4,PHEP(1,JMOHEP(1,ICM)),PHEP(1,JDAHEP(1,ICM)),PB)
+ CALL HWUMAS(PB)
+C---IF Q**2<10**-2, SOMETHING MUST HAVE ALREADY GONE WRONG
+ IF (PB(5)**2.LT.1.D-2) CALL HWWARN('HWBJCO',102,*999)
+ CALL HWVSCA(4,PB(5)**2/HWULDO(PHEP(1,IP),PB),PHEP(1,IP),PBR)
+ CALL HWVSUM(4,PB,PBR,PBR)
+ CALL HWUMAS(PBR)
+ CALL HWULOF(PBR,PB,PB)
+ CALL HWUROT(PB,ONE,ZERO,RBR)
+ ENDIF
+ PTX=0.
+ PTY=0.
+ PF=1.D0
+ DO 90 IP=1,2
+ MHEP=IJET(IP)
+ IF (JDAHEP(1,MHEP).EQ.0) THEN
+C---SPECIAL FOR NON-PARTON JETS
+ IHEP=MHEP
+ GOTO 70
+ ELSE
+ IST=134+IP
+ DO 60 IHEP=MHEP,NHEP
+ 60 IF (ISTHEP(IHEP).EQ.IST) GOTO 70
+C---COULDN'T FIND SPACELIKE PARTON
+ CALL HWWARN('HWBJCO',101,*999)
+ ENDIF
+ 70 CALL HWVSCA(3,PF,PHEP(1,IHEP),PS)
+ IF (PTINT(3,IP).GT.ZERO) THEN
+C---ADD INTRINSIC PT
+ PT(1)=PTINT(1,IP)
+ PT(2)=PTINT(2,IP)
+ PT(3)=0.
+ CALL HWUROT(PS, ONE,ZERO,RS)
+ CALL HWUROB(RS,PT,PT)
+ CALL HWVSUM(3,PS,PT,PS)
+ ENDIF
+ JP=IJET(IP)+1
+ IF (AZCOR.AND.JP.LE.NHEP.AND.IDHW(JP).EQ.17) THEN
+C---ALIGN CONE WITH INTERFERING PARTON
+ CALL HWUROT(PS, ONE,ZERO,RS)
+ CALL HWUROF(RS,PHEP(1,JP),PR)
+ PTCON=PR(1)**2+PR(2)**2
+ KP=JMOHEP(2,JP)
+ IF (KP.EQ.0) THEN
+ CALL HWWARN('HWBJCO',1,*999)
+ PTINF=0.
+ ELSE
+ CALL HWVEQU(4,PHEP(1,KP),PB)
+ IF (DISPRO.AND.BREIT) THEN
+ CALL HWULOF(PBR,PB,PB)
+ CALL HWUROF(RBR,PB,PB)
+ ENDIF
+ PTINF=PB(1)**2+PB(2)**2
+ IF (PTINF.LT.EPS) THEN
+C---COLLINEAR JETS: ALIGN CONES
+ KP=JDAHEP(1,KP)+1
+ IF (ISTHEP(KP).EQ.100.AND.ISTHEP(KP-1)/10.EQ.14) THEN
+ CALL HWVEQU(4,PHEP(1,KP),PB)
+ IF (DISPRO.AND.BREIT) THEN
+ CALL HWULOF(PBR,PB,PB)
+ CALL HWUROF(RBR,PB,PB)
+ ENDIF
+ PTINF=PB(1)**2+PB(2)**2
+ ELSE
+ PTINF=0.
+ ENDIF
+ ENDIF
+ ENDIF
+ IF (PTCON.NE.ZERO.AND.PTINF.NE.ZERO) THEN
+ CN=1./SQRT(PTINF*PTCON)
+ CP=CN*(PR(1)*PB(1)+PR(2)*PB(2))
+ SP=CN*(PR(1)*PB(2)-PR(2)*PB(1))
+ ELSE
+ CALL HWRAZM( ONE,CP,SP)
+ ENDIF
+ ELSE
+ CALL HWRAZM( ONE,CP,SP)
+ ENDIF
+C---ROTATE SO SPACELIKE IS ALONG AXIS (APART FROM INTRINSIC PT)
+ CALL HWUROT(PS,CP,SP,RS)
+ IHEP=IJET(IP)
+ KHEP=JDAHEP(2,IHEP)
+ IF (KHEP.LT.IHEP) KHEP=IHEP
+ IEND(IP)=KHEP
+ DO 80 JHEP=IHEP,KHEP
+ CALL HWUROF(RS,PHEP(1,JHEP),PHEP(1,JHEP))
+ 80 CALL HWUROF(RS,VHEP(1,JHEP),VHEP(1,JHEP))
+ PP(IP)=PHEP(4,IHEP)+PF*PHEP(3,IHEP)
+ ET(IP)=PHEP(1,IHEP)**2+PHEP(2,IHEP)**2-PHEP(5,IHEP)**2
+C---REDEFINE HARD CM
+ PTX=PTX+PHEP(1,IHEP)
+ PTY=PTY+PHEP(2,IHEP)
+ 90 PF=-PF
+ PHEP(1,ICM)=PTX
+ PHEP(2,ICM)=PTY
+C---special for DIS: keep lepton momenta fixed
+ IF (DISPRO) THEN
+ IP1=JMOHEP(1,ICM)
+ IP2=JDAHEP(1,ICM)
+ IJT=IJET(1)
+C---IJT will be used to store lepton momentum transfer
+ CALL HWVDIF(4,PHEP(1,IP1),PHEP(1,IP2),PHEP(1,IJT))
+ CALL HWUMAS(PHEP(1,IJT))
+ IF (IDHEP(IP1).EQ.IDHEP(IP2)) THEN
+ IDHW(IJT)=200
+ ELSEIF (IDHEP(IP1).LT.IDHEP(IP2)) THEN
+ IDHW(IJT)=199
+ ELSE
+ IDHW(IJT)=198
+ ENDIF
+ IDHEP(IJT)=IDPDG(IDHW(IJT))
+ ISTHEP(IJT)=3
+C---calculate boost for struck parton
+C PC is momentum of outgoing parton(s)
+ IP2=JDAHEP(2,ICM)
+ IF (.NOT.DISLOW) THEN
+C---FOR heavy QQbar PQ and PC are old and new QQbar momenta
+ CALL HWVSUM(4,PHEP(1,IP2-1),PHEP(1,IP2),PQ)
+ CALL HWUMAS(PQ)
+ PC(5)=PQ(5)
+ ELSE
+ PC(5)=PHEP(5,JDAHEP(1,IP2))
+ ENDIF
+ CALL HWVSUM(2,PHEP(1,IJT),PHEP(1,IJET(2)),PC)
+ ET(1)=ET(2)
+C---USE BREIT FRAME BOSON MOMENTUM IF NECESSARY
+ IF (BREIT) THEN
+ ET(2)=ET(1)+PC(5)**2+PHEP(5,IJET(2))**2
+ PM0=PHEP(5,IJT)
+ PP0=-PM0
+ ELSE
+ ET(2)=PC(1)**2+PC(2)**2+PC(5)**2
+ PP0=PHEP(4,IJT)+PHEP(3,IJT)
+ PM0=PHEP(4,IJT)-PHEP(3,IJT)
+ ENDIF
+ ET0=(PP0*PM0)+ET(1)-ET(2)
+ DET=ET0**2-4.*(PP0*PM0)*ET(1)
+ IF (DET.LT.ZERO) THEN
+ FROST=.TRUE.
+ RETURN
+ ENDIF
+ ALF=(SQRT(DET)-ET0)/(2.*PP0*PP(2))
+ PB(1)=0.
+ PB(2)=0.
+ PB(5)=2.D0
+ PB(3)=ALF-(1./ALF)
+ PB(4)=ALF+(1./ALF)
+ DO 100 IHEP=IJET(2),IEND(2)
+ CALL HWULOF(PB,PHEP(1,IHEP),PHEP(1,IHEP))
+ CALL HWULF4(PB,VHEP(1,IHEP),VHEP(1,IHEP))
+C---BOOST FROM BREIT FRAME IF NECESSARY
+ IF (BREIT) THEN
+ CALL HWUROB(RBR,PHEP(1,IHEP),PHEP(1,IHEP))
+ CALL HWULOB(PBR,PHEP(1,IHEP),PHEP(1,IHEP))
+ CALL HWUROB(RBR,VHEP(1,IHEP),VHEP(1,IHEP))
+ CALL HWULB4(PBR,VHEP(1,IHEP),VHEP(1,IHEP))
+ ENDIF
+ 100 ISTHEP(IHEP)=ISTHEP(IHEP)+10
+ CALL HWVDIF(4,VHEP(1,IPAR(2)),VHEP(1,IJET(2)),DISP)
+ DO 110 IHEP=IJET(2),IEND(2)
+ 110 CALL HWVSUM(4,DISP,VHEP(1,IHEP),VHEP(1,IHEP))
+ IF (IEND(2).GT.IJET(2)+1) ISTHEP(IJET(2)+1)=100
+ CALL HWVSUM(4,PHEP(1,IJT),PHEP(1,IJET(2)),PC)
+ CALL HWVSUM(4,PHEP(1,IP1),PHEP(1,IJET(2)),PHEP(1,ICM))
+ CALL HWUMAS(PHEP(1,ICM))
+ ELSEIF (IPRO/10.EQ.5) THEN
+C Special to preserve photon momentum
+ ETC=PTX**2+PTY**2+PHEP(5,ICM)**2
+ ET0=ETC+ET(1)-ET(2)
+ DET=ET0**2-4.*ETC*ET(1)
+ IF (DET.LT.ZERO) THEN
+ FROST=.TRUE.
+ RETURN
+ ENDIF
+ ALF=(SQRT(DET)+ET0-2.*ET(1))/(2.*PP(1)*PP(2))
+ PB(1)=0.
+ PB(2)=0.
+ PB(3)=ALF-1./ALF
+ PB(4)=ALF+1./ALF
+ PB(5)=2.
+ IJT=IJET(2)
+ DO 120 IHEP=IJT,IEND(2)
+ CALL HWULOF(PB,PHEP(1,IHEP),PHEP(1,IHEP))
+ CALL HWULF4(PB,VHEP(1,IHEP),VHEP(1,IHEP))
+ 120 ISTHEP(IHEP)=ISTHEP(IHEP)+10
+ CALL HWVDIF(4,VHEP(1,IPAR(2)),VHEP(1,IJT),DISP)
+ DO 130 IHEP=IJT,IEND(2)
+ 130 CALL HWVSUM(4,DISP,VHEP(1,IHEP),VHEP(1,IHEP))
+ IF (IEND(2).GT.IJT+1) ISTHEP(IJT+1)=100
+ ISTHEP(IJET(1))=ISTHEP(IJET(1))+10
+ CALL HWVSUM(2,PHEP(3,IPAR(1)),PHEP(3,IJT),PHEP(3,ICM))
+ ELSE
+ PHEP(4,ICM)=SQRT(PTX**2+PTY**2+PHEP(3,ICM)**2+PHEP(5,ICM)**2)
+C---NOW BOOST TO REQUIRED Q**2 AND X-F
+ PP0=PHEP(4,ICM)+PHEP(3,ICM)
+ PM0=PHEP(4,ICM)-PHEP(3,ICM)
+ ET0=(PP0*PM0)+ET(1)-ET(2)
+ DET=ET0**2-4.*(PP0*PM0)*ET(1)
+ IF (DET.LT.ZERO) THEN
+ FROST=.TRUE.
+ RETURN
+ ENDIF
+ DET=SQRT(DET)+ET0
+ AL(1)= 2.*PM0*PP(1)/DET
+ AL(2)=(PM0/PP(2))*(1.-2.*ET(1)/DET)
+ PB(1)=0.
+ PB(2)=0.
+ PB(5)=2.
+ DO 160 IP=1,2
+ PB(3)=AL(IP)-(1./AL(IP))
+ PB(4)=AL(IP)+(1./AL(IP))
+ IJT=IJET(IP)
+ DO 140 IHEP=IJT,IEND(IP)
+ CALL HWULOF(PB,PHEP(1,IHEP),PHEP(1,IHEP))
+ CALL HWULF4(PB,VHEP(1,IHEP),VHEP(1,IHEP))
+ 140 ISTHEP(IHEP)=ISTHEP(IHEP)+10
+ CALL HWVDIF(4,VHEP(1,IPAR(IP)),VHEP(1,IJT),DISP)
+ DO 150 IHEP=IJT,IEND(IP)
+ 150 CALL HWVSUM(4,DISP,VHEP(1,IHEP),VHEP(1,IHEP))
+ IF (IEND(IP).GT.IJT+1) THEN
+ ISTHEP(IJT+1)=100
+ ELSEIF (IEND(IP).EQ.IJT) THEN
+C---NON-PARTON JET
+ ISTHEP(IJT)=3
+ ENDIF
+ 160 CONTINUE
+ ENDIF
+ ISTHEP(ICM)=120
+ ELSE
+C---TIMELIKE JETS
+C special for DIS: preserve outgoing lepton momentum
+ IF (DISPRO) THEN
+ CALL HWVEQU(5,PHEP(1,IPAR(1)),PHEP(1,IJET(1)))
+ ISTHEP(IJET(1))=1
+ LP=2
+ ELSE
+ CALL HWVEQU(5,PHEP(1,ICM),PC)
+C--- PQ AND PC ARE OLD AND NEW PARTON CM
+ CALL HWVSUM(4,PHEP(1,IPAR(1)),PHEP(1,IPAR(2)),PQ)
+ PQ(5)=PHEP(5,ICM)
+ IF (NP.GT.2) THEN
+ DO 170 KP=3,NP
+ 170 CALL HWVSUM(4,PHEP(1,IPAR(KP)),PQ,PQ)
+ ENDIF
+ LP=1
+ ENDIF
+ IF (.NOT.DISLOW) THEN
+C---FIND JET CM MOMENTA
+ ECM=PQ(5)
+ EMS=0.
+ JETRAD=.FALSE.
+ DO 180 KP=LP,NP
+ EMJ=PHEP(5,IJET(KP))
+ EMP=PHEP(5,IPAR(KP))
+ JETRAD=JETRAD.OR.EMJ.NE.EMP
+ EMS=EMS+EMJ
+ PM(KP)= EMJ**2
+C---N.B. ROUNDING ERRORS HERE AT HIGH ENERGIES
+ PJ(KP)=(HWULDO(PHEP(1,IPAR(KP)),PQ)/ECM)**2-EMP**2
+ IF (PJ(KP).LE.ZERO) CALL HWWARN('HWBJCO',104,*999)
+ 180 CONTINUE
+ PF=1.
+ IF (JETRAD) THEN
+C---JETS DID RADIATE
+ IF (EMS.GE.ECM) THEN
+ FROST=.TRUE.
+ RETURN
+ ENDIF
+ DO 200 NE=1,NETRY
+ EMS=-ECM
+ DMS=0.
+ DO 190 KP=LP,NP
+ ES=SQRT(PF*PJ(KP)+PM(KP))
+ EMS=EMS+ES
+ 190 DMS=DMS+PJ(KP)/ES
+ DPF=2.*EMS/DMS
+ IF (DPF.GT.PF) DPF=0.9*PF
+ PF=PF-DPF
+ 200 IF (ABS(DPF).LT.EPS) GOTO 210
+ CALL HWWARN('HWBJCO',105,*999)
+ ENDIF
+ 210 CONTINUE
+ ENDIF
+C---BOOST PC AND PQ TO BREIT FRAME IF NECESSARY
+ IF (DISPRO.AND.BREIT) THEN
+ CALL HWULOF(PBR,PC,PC)
+ CALL HWUROF(RBR,PC,PC)
+ IF (.NOT.DISLOW) THEN
+ CALL HWULOF(PBR,PQ,PQ)
+ CALL HWUROF(RBR,PQ,PQ)
+ ENDIF
+ ENDIF
+ DO 230 IP=LP,NP
+C---FIND CM ROTATION FOR JET IP
+ IF (.NOT.DISLOW) THEN
+ CALL HWVEQU(4,PHEP(1,IPAR(IP)),PR)
+ IF (DISPRO.AND.BREIT) THEN
+ CALL HWULOF(PBR,PR,PR)
+ CALL HWUROF(RBR,PR,PR)
+ ENDIF
+ CALL HWULOF(PQ,PR,PR)
+ CALL HWUROT(PR, ONE,ZERO,RR)
+ PR(1)=0.
+ PR(2)=0.
+ PR(3)=SQRT(PF*PJ(IP))
+ PR(4)=SQRT(PF*PJ(IP)+PM(IP))
+ PR(5)=PHEP(5,IJET(IP))
+ CALL HWUROB(RR,PR,PR)
+ CALL HWULOB(PC,PR,PR)
+ ELSE
+ CALL HWVEQU(5,PC,PR)
+ ENDIF
+C---NOW PR IS LAB/BREIT MOMENTUM OF JET IP
+ KP=IJET(IP)+1
+ IF (AZCOR.AND.KP.LE.NHEP.AND.IDHW(KP).EQ.17) THEN
+C---ALIGN CONE WITH INTERFERING PARTON
+ CALL HWUROT(PR, ONE,ZERO,RS)
+ JP=JMOHEP(2,KP)
+ IF (JP.EQ.0) THEN
+ CALL HWWARN('HWBJCO',2,*999)
+ PTINF=0.
+ ELSE
+ CALL HWVEQU(4,PHEP(1,JP),PS)
+ IF (DISPRO.AND.BREIT) THEN
+ CALL HWULOF(PBR,PS,PS)
+ CALL HWUROF(RBR,PS,PS)
+ ENDIF
+ CALL HWUROF(RS,PS,PS)
+ PTINF=PS(1)**2+PS(2)**2
+ IF (PTINF.LT.EPS) THEN
+C---COLLINEAR JETS: ALIGN CONES
+ JP=JDAHEP(1,JP)+1
+ IF (ISTHEP(JP).EQ.100.AND.ISTHEP(JP-1)/10.EQ.14) THEN
+ CALL HWVEQU(4,PHEP(1,JP),PS)
+ IF (DISPRO.AND.BREIT) THEN
+ CALL HWULOF(PBR,PS,PS)
+ CALL HWUROF(RBR,PS,PS)
+ ENDIF
+ CALL HWUROF(RS,PS,PS)
+ PTINF=PS(1)**2+PS(2)**2
+ ELSE
+ PTINF=0.
+ ENDIF
+ ENDIF
+ ENDIF
+ CALL HWVEQU(4,PHEP(1,KP),PB)
+ IF (DISPRO.AND.BREIT) THEN
+ CALL HWULOF(PBR,PB,PB)
+ CALL HWUROF(RBR,PB,PB)
+ ENDIF
+ PTCON=PB(1)**2+PB(2)**2
+ IF (PTCON.NE.ZERO.AND.PTINF.NE.ZERO) THEN
+ CN=1./SQRT(PTINF*PTCON)
+ CP=CN*(PS(1)*PB(1)+PS(2)*PB(2))
+ SP=CN*(PS(1)*PB(2)-PS(2)*PB(1))
+ ELSE
+ CALL HWRAZM( ONE,CP,SP)
+ ENDIF
+ ELSE
+ CALL HWRAZM( ONE,CP,SP)
+ ENDIF
+ CALL HWUROT(PR,CP,SP,RS)
+C---FIND BOOST FOR JET IP
+ ALF=(PHEP(3,IJET(IP))+PHEP(4,IJET(IP)))/
+ & (PR(4)+SQRT((PR(4)+PR(5))*(PR(4)-PR(5))))
+ PB(1)=0.
+ PB(2)=0.
+ PB(3)=ALF-(1./ALF)
+ PB(4)=ALF+(1./ALF)
+ PB(5)=2.
+ IHEP=IJET(IP)
+ KHEP=JDAHEP(2,IHEP)
+ IF (KHEP.LT.IHEP) KHEP=IHEP
+ DO 220 JHEP=IHEP,KHEP
+ CALL HWULOF(PB,PHEP(1,JHEP),PHEP(1,JHEP))
+ CALL HWUROB(RS,PHEP(1,JHEP),PHEP(1,JHEP))
+ CALL HWULF4(PB,VHEP(1,JHEP),VHEP(1,JHEP))
+ CALL HWUROB(RS,VHEP(1,JHEP),VHEP(1,JHEP))
+C---BOOST FROM BREIT FRAME IF NECESSARY
+ IF (DISPRO.AND.BREIT) THEN
+ CALL HWUROB(RBR,PHEP(1,JHEP),PHEP(1,JHEP))
+ CALL HWULOB(PBR,PHEP(1,JHEP),PHEP(1,JHEP))
+ CALL HWUROB(RBR,VHEP(1,JHEP),VHEP(1,JHEP))
+ CALL HWULB4(PBR,VHEP(1,JHEP),VHEP(1,JHEP))
+ ENDIF
+ CALL HWVSUM(4,VHEP(1,JHEP),VHEP(1,IPAR(IP)),VHEP(1,JHEP))
+ 220 ISTHEP(JHEP)=ISTHEP(JHEP)+10
+ IF (KHEP.GT.IHEP+1) THEN
+ ISTHEP(IHEP+1)=100
+ ELSEIF (KHEP.EQ.IHEP) THEN
+C---NON-PARTON JET
+ ISTHEP(IHEP)=190
+ ENDIF
+ 230 CONTINUE
+ IF (ISTHEP(ICM).EQ.110) ISTHEP(ICM)=120
+ ENDIF
+ GOTO 20
+ 999 END
+CDECK ID>, HWBMAS.
+*CMZ :- -26/04/91 11.11.54 by Bryan Webber
+*-- Author : Bryan Webber
+C-----------------------------------------------------------------------
+ SUBROUTINE HWBMAS
+C-----------------------------------------------------------------------
+C Passes backwards through a jet cascade calculating the masses
+C and magnitudes of the longitudinal and transverse three momenta.
+C Components given relative to direction of parent for a time-like
+C vertex and with respect to z-axis for space-like vertices.
+C
+C On input PPAR(1-5,*) contains:
+C (E*sqrt(Xi),Xi,3-mom (if external),E,M-sq (if external))
+C
+C On output PPAR(1-5,*) (if TMPAR(*)), containts:
+C (P-trans,Xi or Xilast,P-long,E,M)
+C-----------------------------------------------------------------------
+ INCLUDE 'HERWIG61.INC'
+ DOUBLE PRECISION HWUSQR,EXI,PISQ,PJPK,EJEK,PTSQ,Z,ZMIN,ZMAX,
+ $ EMI,EMJ,EMK,C,NQ,HWBVMC,RHO,POLD,PNEW,EOLD,ENEW,A,B
+ INTEGER IPAR,JPAR,KPAR,MPAR,I,J,K
+ EXTERNAL HWUSQR
+ IF (IERROR.NE.0) RETURN
+ IF (NPAR.GT.2) THEN
+ DO 30 MPAR=NPAR-1,3,-2
+ JPAR=MPAR
+C Find parent and partner of this branch
+ IPAR=JMOPAR(1,JPAR)
+ KPAR=JPAR+1
+C Determine type of branching
+ IF (TMPAR(IPAR)) THEN
+C Time-like branching
+C Compute mass of parent
+ EXI=PPAR(1,JPAR)*PPAR(1,KPAR)
+ PPAR(5,IPAR)=PPAR(5,JPAR)+PPAR(5,KPAR)+2.*EXI
+C Compute three momentum of parent
+ PISQ=PPAR(4,IPAR)*PPAR(4,IPAR)-PPAR(5,IPAR)
+ PPAR(3,IPAR)=HWUSQR(PISQ)
+C---SPECIAL FOR G-->QQBAR: READJUST ANGULAR DISTRIBUTION
+ IF (IDPAR(IPAR).EQ.13 .AND. IDPAR(JPAR).LT.13) THEN
+ Z=PPAR(4,JPAR)/PPAR(4,IPAR)
+ ZMIN=HWBVMC(IDPAR(JPAR))/PPAR(1,JPAR)*Z
+ RHO=(Z*(3-Z*(3-2*Z))-ZMIN*(3-ZMIN*(3-2*ZMIN)))
+ $ /(2*(1-2*ZMIN)*(1-ZMIN*(1-ZMIN)))
+ NQ=PPAR(3,IPAR)*(PPAR(3,IPAR)+PPAR(4,IPAR))
+ EMI=PPAR(5,IPAR)
+ EMJ=PPAR(5,JPAR)
+ EMK=PPAR(5,KPAR)
+ ZMIN=MAX((EMI+EMJ-EMK)/(2*(EMI+NQ)),
+ $ (EMI+EMJ-EMK-SQRT((EMI-EMJ-EMK)**2-4*EMJ*EMK))/(2*EMI))
+ ZMAX=1-MAX((EMI-EMJ+EMK)/(2*(EMI+NQ)),
+ $ (EMI-EMJ+EMK-SQRT((EMI-EMJ-EMK)**2-4*EMJ*EMK))/(2*EMI))
+ C=2*RMASS(IDPAR(JPAR))**2/EMI
+ Z=(4*ZMIN*(1.5*(1+C-ZMIN)+ZMIN**2)*(1-RHO)
+ $ +4*ZMAX*(1.5*(1+C-ZMAX)+ZMAX**2)*RHO-2-3*C)/(1+2*C)**1.5
+ Z=SQRT(1+2*C)*SINH(LOG(Z+SQRT(Z**2+1))/3)+0.5
+ Z=(Z*NQ+(EMI+EMJ-EMK)/2)/(NQ+EMI)
+ PPAR(4,JPAR)=Z*PPAR(4,IPAR)
+ PPAR(4,KPAR)=PPAR(4,IPAR)-PPAR(4,JPAR)
+ PPAR(3,JPAR)=HWUSQR(PPAR(4,JPAR)**2-EMJ)
+ PPAR(3,KPAR)=HWUSQR(PPAR(4,KPAR)**2-EMK)
+ PPAR(2,JPAR)=EXI/(PPAR(4,JPAR)*PPAR(4,KPAR))
+ IF(JDAPAR(2,JPAR).NE.0)PPAR(2,JDAPAR(2,JPAR))=PPAR(2,JPAR)
+ IF(JDAPAR(2,KPAR).NE.0)PPAR(2,JDAPAR(2,KPAR))=PPAR(2,JPAR)
+C---FIND DESCENDENTS OF THIS SPLITTING AND READJUST THEIR MOMENTA TOO
+ DO 20 J=JPAR+2,NPAR-1,2
+ I=J
+ 10 I=JMOPAR(1,I)
+ IF (I.GT.IPAR) GOTO 10
+ IF (I.EQ.IPAR) THEN
+ I=JMOPAR(1,J)
+ K=J+1
+ POLD=PPAR(3,J)+PPAR(3,K)
+ EOLD=PPAR(4,J)+PPAR(4,K)
+ PNEW=HWUSQR(PPAR(4,I)**2-PPAR(5,I))
+ ENEW=PPAR(4,I)
+ A=(ENEW*EOLD-PNEW*POLD)/PPAR(5,I)
+ B=(PNEW*EOLD-ENEW*POLD)/PPAR(5,I)
+ PPAR(3,J)=A*PPAR(3,J)+B*PPAR(4,J)
+ PPAR(4,J)=(PPAR(4,J)+B*PPAR(3,J))/A
+ PPAR(3,K)=PNEW-PPAR(3,J)
+ PPAR(4,K)=ENEW-PPAR(4,J)
+ PPAR(2,J)=1-(PPAR(3,J)*PPAR(3,K)+PPAR(1,J)*PPAR(1,K))
+ $ /(PPAR(4,J)*PPAR(4,K))
+ IF (JDAPAR(2,J).NE.0) PPAR(2,JDAPAR(2,J))=PPAR(2,J)
+ IF (JDAPAR(2,K).NE.0) PPAR(2,JDAPAR(2,K))=PPAR(2,J)
+ ENDIF
+ 20 CONTINUE
+ ENDIF
+C Compute daughter' transverse and longitudinal momenta
+ PJPK=PPAR(3,JPAR)*PPAR(3,KPAR)
+ EJEK=PPAR(4,JPAR)*PPAR(4,KPAR)-EXI
+ PTSQ=(PJPK+EJEK)*(PJPK-EJEK)/PISQ
+ PPAR(1,JPAR)=HWUSQR(PTSQ)
+ PPAR(3,JPAR)=HWUSQR(PPAR(3,JPAR)*PPAR(3,JPAR)-PTSQ)
+ PPAR(1,KPAR)=-PPAR(1,JPAR)
+ PPAR(3,KPAR)= PPAR(3,IPAR)-PPAR(3,JPAR)
+ ELSE
+C Space-like branching
+C Re-arrange such that JPAR is time-like
+ IF (TMPAR(KPAR)) THEN
+ KPAR=JPAR
+ JPAR=JPAR+1
+ ENDIF
+C Compute time-like branch
+ PTSQ=(2.-PPAR(2,JPAR))*PPAR(1,JPAR)*PPAR(1,JPAR)
+ & -PPAR(5,JPAR)
+ PPAR(1,JPAR)=HWUSQR(PTSQ)
+ PPAR(3,JPAR)=(1.-PPAR(2,JPAR))*PPAR(4,JPAR)
+ PPAR(3,IPAR)=PPAR(3,KPAR)-PPAR(3,JPAR)
+ PPAR(5,IPAR)=0.
+ PPAR(1,KPAR)=0.
+ ENDIF
+C Reset Xi to Xilast
+ PPAR(2,KPAR)=PPAR(2,IPAR)
+ 30 CONTINUE
+ ENDIF
+ DO 40 IPAR=2,NPAR
+ 40 PPAR(5,IPAR)=HWUSQR(PPAR(5,IPAR))
+ PPAR(1,2)=0.
+ PPAR(2,2)=0.
+ END
+CDECK ID>, HWBRAN.
+*CMZ :- -14/10/99 18.04.56 by Mike Seymour
+*-- Author : Bryan Webber & Mike Seymour
+C-----------------------------------------------------------------------
+ SUBROUTINE HWBRAN(KPAR)
+C-----------------------------------------------------------------------
+C BRANCHES TIMELIKE PARTON KPAR INTO TWO, PUTS PRODUCTS
+C INTO NPAR+1 AND NPAR+2, AND INCREASES NPAR BY TWO
+C-----------------------------------------------------------------------
+ INCLUDE 'HERWIG61.INC'
+ DOUBLE PRECISION HWBVMC,HWR,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,HWR,HWUALF,HWUTAB,HWRUNI,HWULDO,HWRINT,HWUSQR
+ SAVE BETA0,BETAP,SQRK
+ DATA ISUD,BETA0/2,2,3,4,5,6,2,2,3,4,5,6,1,4*ZERO/
+ IF (IERROR.NE.0) RETURN
+C---SET SQRK(M,N) TO THE PROBABILITY THAT A GLUON WILL NOT PRODUCE A
+C QUARK-ANTIQUARK PAIR BETWEEN SCALES RMASS(M) AND 2*HWBVMC(N)
+ IF (SUDORD.NE.1.AND.BETA0(3).EQ.ZERO) THEN
+ DO 100 M=3,6
+ BETA0(M)=(11.*CAFAC-2.*M)*0.5
+ 100 BETAP(M)=(17.*CAFAC**2-(5.*CAFAC+3.*CFFAC)*M)
+ & /BETA0(M)*0.25/PIFAC
+ DO 120 N=1,5
+ DO 110 M=4,6
+ IF (M.LE.N) THEN
+ SQRK(M,N)=ONE
+ ELSEIF (M.EQ.4.OR.M.EQ.N+1) THEN
+ NF=M
+ IF (2*HWBVMC(N).GT.RMASS(M)) NF=M+1
+ SQRK(M,N)=((BETAP(NF-1)+1/HWUALF(1,2*HWBVMC(N)))/
+ $ (BETAP(NF-1)+1/HWUALF(1,RMASS(M))))**(1/BETA0(NF-1))
+ ELSE
+ SQRK(M,N)=SQRK(M-1,N)*
+ $ ((BETAP(M-1)+1/HWUALF(1,RMASS(M-1)))/
+ $ (BETAP(M-1)+1/HWUALF(1,RMASS(M))))**(1/BETA0(M-1))
+ ENDIF
+ 110 CONTINUE
+ 120 CONTINUE
+ ENDIF
+ ID=IDPAR(KPAR)
+C--TEST FOR PARTON TYPE
+ IF (ID.LE.13) THEN
+ JD=ID
+ IS=ISUD(ID)
+ ELSEIF (ID.GE.209.AND.ID.LE.220) THEN
+ JD=ID-208
+ IS=7
+ ELSE
+ IS=0
+ END IF
+ QNOW=-1.
+ IF (IS.NE.0) THEN
+C--TIMELIKE PARTON BRANCHING
+ ENOW=PPAR(4,KPAR)
+ XIPREV=PPAR(2,KPAR)
+ IF (JMOPAR(1,KPAR).EQ.0) THEN
+ EPREV=PPAR(4,KPAR)
+ ELSE
+ EPREV=PPAR(4,JMOPAR(1,KPAR))
+ ENDIF
+C--IF THIS IS CHARGED & PHOTONS ARE ALLOWED, ANGLES MIGHT NOT BE ORDERED
+ QMAX=0
+ QLST=PPAR(1,KPAR)
+ IF (ICHRG(ID).NE.0 .AND. VPCUT.LT.PPAR(1,2)) THEN
+C--LOOK FOR A PREVIOUS G->QQBAR, IF ANY
+ MPAR=KPAR
+ 1 IF (JMOPAR(1,MPAR).NE.0) THEN
+ IF (IDPAR(JMOPAR(1,MPAR)).EQ.ID) THEN
+ MPAR=JMOPAR(1,MPAR)
+ GOTO 1
+ ENDIF
+ ENDIF
+C--IF CLIMBED TO THE TOP OF THE LIST, FIND QED INTERFERENCE PARTNER
+ IF (MPAR.EQ.2) THEN
+ JHEP=0
+ IF (ID.LT.7) THEN
+ IHEP=JDAHEP(2,JCOPAR(1,1))
+ IF (IHEP.GT.0) JHEP=JDAHEP(2,IHEP)
+ ELSE
+ IHEP=JMOHEP(2,JCOPAR(1,1))
+ IF (IHEP.GT.0) JHEP=JMOHEP(2,IHEP)
+ ENDIF
+ IF (IHEP.GT.0.AND.JHEP.GT.0) THEN
+ QMAX=HWULDO(PHEP(1,IHEP),PHEP(1,JHEP))
+ & *(ENOW/PPAR(4,2))**2
+ ELSE
+C--FIX AT HARD PROCESS SCALE IF POINTER NOT YET SET
+C (CAN HAPPEN IN SUSY EVENTS)
+ QMAX=EMSCA**2
+ ENDIF
+ ELSE
+ QMAX=ENOW**2*PPAR(2,MPAR)
+ ENDIF
+C--IF PREVIOUS BRANCHING WAS Q->QGAMMA, LOOK FOR A QCD BRANCHING
+ MPAR=KPAR
+ 2 IF (JMOPAR(1,MPAR).NE.0) THEN
+ IF (IDPAR(JDAPAR(1,JMOPAR(1,MPAR))).EQ.59 .OR.
+ & IDPAR(JDAPAR(2,JMOPAR(1,MPAR))).EQ.59) THEN
+ MPAR=JMOPAR(1,MPAR)
+ GOTO 2
+ ENDIF
+ ENDIF
+ QLST=ENOW**2*PPAR(2,MPAR)
+ QMAX=SQRT(MAX(ZERO,MIN(
+ & QMAX , EPREV**2*XIPREV , ENOW**2*XIPREV*(2-XIPREV))))
+ QLST=SQRT(MIN(
+ & QLST , EPREV**2*XIPREV , ENOW**2*XIPREV*(2-XIPREV)))
+ ENDIF
+ NTRY=0
+ 5 NTRY=NTRY+1
+ IF (NTRY.GT.NBTRY) CALL HWWARN('HWBRAN',100,*999)
+ IF (ID.EQ.13) THEN
+C--GLUON -> QUARK+ANTIQUARK OPTION
+ IF (QLST.GT.QCDL3) THEN
+ DO 8 N=1,NFLAV
+ QKTHR=2.*HWBVMC(N)
+ IF (QLST.GT.QKTHR) THEN
+ RN=HWR()
+ IF (SUDORD.NE.1) THEN
+C---FIND IN WHICH FLAVOUR INTERVAL THE UPPER LIMIT LIES
+ NF=3
+ DO 200 M=MAX(3,N),NFLAV
+ 200 IF (QLST.GT.RMASS(M)) NF=M
+C---CALCULATE THE FORM FACTOR
+ IF (NF.EQ.MAX(3,N)) THEN
+ SFNL=((BETAP(NF)+1/HWUALF(1,QKTHR))/
+ $ (BETAP(NF)+1/HWUALF(1,QLST)))**(1/BETA0(NF))
+ SLST=SFNL
+ ELSE
+ SFNL=((BETAP(NF)+1/HWUALF(1,RMASS(NF)))/
+ $ (BETAP(NF)+1/HWUALF(1,QLST)))**(1/BETA0(NF))
+ SLST=SFNL*SQRK(NF,N)
+ ENDIF
+ ENDIF
+ IF (RN.GT.1.E-3) THEN
+ QQBAR=QCDL3*(QLST/QCDL3)**(RN**BETAF)
+ ELSE
+ QQBAR=QCDL3
+ ENDIF
+ IF (SUDORD.NE.1) THEN
+C---FIND IN WHICH FLAVOUR INTERVAL THE SOLUTION LIES
+ IF (RN.GE.SFNL) THEN
+ NN=NF
+ ELSEIF (RN.GE.SLST) THEN
+ NN=MAX(3,N)
+ DO 210 M=MAX(3,N)+1,NF-1
+ 210 IF (RN.GE.SLST/SQRK(M,N)) NN=M
+ ELSE
+ NN=0
+ QQBAR=QCDL3
+ ENDIF
+ IF (NN.GT.0) THEN
+ IF (NN.EQ.NF) THEN
+ TARG=HWUALF(1,QLST)
+ ELSE
+ TARG=HWUALF(1,RMASS(NN+1))
+ RN=RN/SLST*SQRK(NN+1,N)
+ ENDIF
+ TARG=1/((BETAP(NN)+1/TARG)*RN**BETA0(NN)-BETAP(NN))
+C---NOW SOLVE HWUALF(1,QQBAR)=TARG FOR QQBAR ITERATIVELY
+ 7 QQBAR=MAX(QQBAR,HALF*QKTHR)
+ ALF=HWUALF(1,QQBAR)
+ IF (ABS(ALF-TARG).GT.ACCUR) THEN
+ NTRY=NTRY+1
+ IF (NTRY.GT.NBTRY) CALL HWWARN('HWBRAN',101,*999)
+ QQBAR=QQBAR*(1+3*PIFAC*(ALF-TARG)
+ $ /(BETA0(NN)*ALF**2*(1+BETAP(NN)*ALF)))
+ GOTO 7
+ ENDIF
+ ENDIF
+ ENDIF
+ IF (QQBAR.GT.QNOW.AND.QQBAR.GT.QKTHR) THEN
+ QNOW=QQBAR
+ ID2=N
+ ENDIF
+ ELSE
+ GOTO 9
+ ENDIF
+ 8 CONTINUE
+ ENDIF
+C--GLUON->DIQUARKS OPTION
+ 9 IF (QLST.LT.QDIQK) THEN
+ IF (PDIQK.NE.ZERO) THEN
+ RN=HWR()
+ 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=HWR()
+ SLST=HWUTAB(SUD(1,IS),QEV(1,IS),NQEV,QLST,INTER)
+ IF (RN.EQ.ZERO) THEN
+ SNOW=2.
+ ELSE
+ SNOW=SLST/RN
+ ENDIF
+ IF (SNOW.LT.ONE) THEN
+ QSUD=HWUTAB(QEV(1,IS),SUD(1,IS),NQEV,SNOW,INTER)
+C---IF FORM FACTOR DID NOT GET INVERTED CORRECTLY TRY LINEAR INSTEAD
+ IF (QSUD.GT.QLST) THEN
+ SNOW=HWUTAB(SUD(1,IS),QEV(1,IS),NQEV,QLST,1)/RN
+ QSUD=HWUTAB(QEV(1,IS),SUD(1,IS),NQEV,SNOW,1)
+ IF (QSUD.GT.QLST) THEN
+ CALL HWWARN('HWBRAN',1,*999)
+ QSUD=-1
+ ENDIF
+ ENDIF
+ IF (QSUD.GT.QGTHR.AND.QSUD.GT.QNOW) THEN
+ ID2=13
+ QNOW=QSUD
+ ENDIF
+ ENDIF
+ 300 CONTINUE
+ ENDIF
+C--BRANCHING ID->ID+PHOTON
+ IF (ICHRG(ID).NE.0) THEN
+ QGTHR=MAX(HWBVMC(ID)+HWBVMC(59),HWBVMC(59)*EXP(0.75))
+ IF (QMAX.GT.QGTHR) THEN
+ DO 400 IREJ=1,NREJ
+ RN=HWR()
+ 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**HWR())
+ Z2=1.-Z1
+ ZTEST=(1.-(Z1*Z2))**2*HWUALF(5-SUDORD*2,QNOW*(Z1*Z2))
+ IF (ZTEST.LT.ETEST*HWR()) 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*HWR()) 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**HWR()
+ Z2=1.-Z1
+ ZTEST=(1.+Z2*Z2)*HWUALF(5-SUDORD*2,QNOW*Z1*Z2)
+ IF (ZTEST.LT.ETEST*HWR()) 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**HWR()
+ Z2=1-Z1
+ ZTEST=1+Z2*Z2
+ IF (ZTEST.LT.ETEST*HWR()) 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.HWR() .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*HWR().GT.ONE) THEN
+ QMAX=QNOW
+ QLST=QNOW
+ QNOW=-1.
+ GOTO 5
+ ENDIF
+ IF (QLAM.GT.HARDST) HARDST=QLAM
+ ENDIF
+ MPAR=NPAR+1
+ IDPAR(MPAR)=ID1
+ TMPAR(MPAR)=.TRUE.
+ PPAR(1,MPAR)=QNOW*Z1
+ PPAR(2,MPAR)=XI
+ PPAR(4,MPAR)=ENOW*Z1
+ NPAR=NPAR+2
+ IDPAR(NPAR)=ID2
+ TMPAR(NPAR)=.TRUE.
+ PPAR(1,NPAR)=QNOW*Z2
+ PPAR(2,NPAR)=XI
+ PPAR(4,NPAR)=ENOW*Z2
+C---NEW MOTHER-DAUGHTER RELATIONS
+ JDAPAR(1,KPAR)=MPAR
+ JDAPAR(2,KPAR)=NPAR
+ JMOPAR(1,MPAR)=KPAR
+ JMOPAR(1,NPAR)=KPAR
+C---NEW COLOUR CONNECTIONS
+ JCOPAR(3,KPAR)=NPAR
+ JCOPAR(4,KPAR)=MPAR
+ JCOPAR(1,MPAR)=NPAR
+ JCOPAR(2,MPAR)=KPAR
+ JCOPAR(1,NPAR)=KPAR
+ JCOPAR(2,NPAR)=MPAR
+C
+ ENDIF
+ ENDIF
+ IF (QNOW.LT.ZERO) THEN
+C--BRANCHING STOPS
+ IF (ID.EQ.IDPAR(2).AND.PPAR(5,2).GT.1D-6) THEN
+ PPAR(5,KPAR)=PPAR(5,2)**2
+ ELSE
+ PPAR(5,KPAR)=RMASS(ID)**2
+ ENDIF
+ PMOM=PPAR(4,KPAR)**2-PPAR(5,KPAR)
+ IF (PMOM.LT.-1E-6) CALL HWWARN('HWBRAN',104,*999)
+ IF (PMOM.LT.ZERO) PMOM=ZERO
+ PPAR(3,KPAR)=SQRT(PMOM)
+ JDAPAR(1,KPAR)=0
+ JDAPAR(2,KPAR)=0
+ JCOPAR(3,KPAR)=0
+ JCOPAR(4,KPAR)=0
+ ENDIF
+ 999 END
+CDECK ID>, HWBRCN.
+*CMZ :- -20/07/99 10:56:12 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 'HERWIG61.INC'
+ INTEGER IHEP,IST,ID,JC,JD,JHEP,IDP,IDM,IDP2,IDM2,
+ & RHEP,IST2,ORG,ANTC,XHEP,IP,COLP
+ LOGICAL BVVUSE,BVVHRD,BVDEC1,BVDEC2,COLRD,ACOLRD,BVHRD,BVHRD2,
+ & BVDEC3
+C--logical functions to decide if baryon number violating
+C--BVDEC1 DELTAB=+1
+ BVDEC1(IP) = ((IDHW(IP).GE.419.AND.IDHW(IP).LE.424).OR.
+ & IDHW(IP).EQ.411.OR.IDHW(IP).EQ.412.OR.
+ & IDHW(IP).EQ.449).AND.IDHW(JDAHEP(1,IP)).LE.6.
+ & AND.IDHW(JDAHEP(1,IP)+1).LE.6.AND.
+ & IDHW(JDAHEP(2,IP)).LE.6
+C--BVDEC2 DELTAB=-1
+ BVDEC2(IP) = ((IDHW(IP).GE.413.AND.IDHW(IP).LE.418).OR.
+ & IDHW(IP).EQ.405.OR.IDHW(IP).EQ.406.OR.
+ & IDHW(IP).EQ.449).AND.
+ & IDHW(JDAHEP(1,IP)).GE.7.AND.IDHW(JDAHEP(1,IP)).LE.12.AND.
+ & IDHW(JDAHEP(1,IP)+1).GE.7.AND.IDHW(JDAHEP(1,IP)+1).LE.12.AND.
+ & IDHW(JDAHEP(2,IP)).GE.7.AND.IDHW(JDAHEP(2,IP)).LE.12
+C--Neutralino and Chargino Decays
+ BVDEC3(IP) = ((IDHW(IP).GE.450.AND.IDHW(IP).LE.457).AND.
+ & (IDHW(JDAHEP(1,IP)).LE.12.AND.IDHW(JDAHEP(1,IP)+1).LE.12.
+ & .AND.IDHW(JDAHEP(2,IP)).LE.12))
+C--Now the hard vertices
+ BVHRD(IP) = IDHW(IP).EQ.15.AND.IDHW(JMOHEP(1,IP)).LE.12.
+ & AND.IDHW(JMOHEP(2,IP)).LE.12.AND.IDHW(JDAHEP(1,IP)).LE.12.
+ & AND.IDHW(JDAHEP(2,IP)).GE.449.AND.IDHW(JDAHEP(2,IP)).LE.457
+ BVHRD2(IP) = IDHW(IP).EQ.15.AND.IDHW(JMOHEP(1,IP)).LE.12.
+ & AND.IDHW(JMOHEP(2,IP)).LE.12.AND.IDHW(JDAHEP(1,IP)).GE.198.
+ & AND.IDHW(JDAHEP(1,IP)).LE.207.
+ & AND.ABS(IDHEP(JDAHEP(2,IP))).GT.1000000
+C--Those particles which are coloured
+ COLRD(IP) = IP.LE.6.OR.IP.EQ.13.OR.IP.EQ.449.OR.
+ & (IP.GE.401.AND.IP.LE.406).OR.(IP.GE.413.AND.IP.LE.418).OR.
+ & (IP.GE.115.AND.IP.LE.120).OR.IP.EQ.59
+C--Those particles which are anticoloured
+ ACOLRD(IP) = (IP.GE.7.AND.IP.LE.12).OR.IP.EQ.13.OR.IP.EQ.449.OR.
+ & (IP.GE.407.AND.IP.LE.412).OR.(IP.GE.419.AND.IP.LE.424).OR.
+ & (IP.GE.109.AND.IP.LE.114).OR.IP.EQ.59
+ IF (IERROR.NE.0) RETURN
+ COLP = 0
+ IF(COLUPD.AND.HRDCOL(1,3).NE.0) THEN
+ JD = 0
+ DO IHEP = HRDCOL(1,3),HRDCOL(1,3)+4
+ JD = JD+1
+ IF(JD.NE.3) THEN
+ JMOHEP(2,IHEP) = HRDCOL(1,JD)
+ JDAHEP(2,IHEP) = HRDCOL(2,JD)
+ ENDIF
+ ENDDO
+ COLUPD=.FALSE.
+ DO IHEP=1,5
+ DO JHEP=1,2
+ HRDCOL(JHEP,IHEP)=0
+ ENDDO
+ ENDDO
+ ELSEIF(COLUPD) THEN
+ RETURN
+ ENDIF
+ DO 110 IHEP=1,NHEP
+ IST=ISTHEP(IHEP)
+ JD =0
+ BVVUSE = .FALSE.
+ BVVHRD = .FALSE.
+C---LOOK FOR PARTONS WITHOUT COLOUR MOTHERS
+ IF ((IST.LT.145.OR.IST.GT.152).AND.IST.NE.155) GOTO 110
+ IF (JMOHEP(2,IHEP).EQ.0) THEN
+C---FIND COLOUR-CONNECTED PARTON
+ IF(IST.EQ.155.AND.ABS(IDHEP(IHEP)).EQ.6) THEN
+ JC = JMOHEP(1,IHEP)
+ ELSEIF(IST.EQ.155) THEN
+ GOTO 110
+ ELSE
+ JC=JMOHEP(1,IHEP)
+ ENDIF
+ IF (IST.NE.152) JC=JMOHEP(1,JC)
+C--Correction for BV
+ IF(HRDCOL(1,1).NE.0) THEN
+ IDP = IDHW(HRDCOL(1,1))
+ IDP2 = 0
+ ELSE
+ IDP = 0
+ IDP2 = 0
+ ENDIF
+ IDM = JMOHEP(1,JC)
+ IF(BVDEC1(IDM).OR.BVDEC2(IDM)) THEN
+ IF(IDHW(IDM).EQ.449.AND.JDAHEP(1,IDM).EQ.JC) THEN
+ JC=JMOHEP(2,JC)
+ ELSE
+ JD = JMOHEP(2,JC)
+ JC = IDM
+ IF(JC.EQ.JD) JD= JDAHEP(2,JC-1)
+ BVVUSE = .TRUE.
+ ENDIF
+C--NEW FOR BV HARD PROCESS
+ ELSEIF(BVHRD(IDM)) THEN
+ IF(IDHW(JDAHEP(2,JMOHEP(1,JC))).EQ.449) THEN
+ JD = JMOHEP(2,JC)
+ IDM2 = JDAHEP(2,HRDCOL(1,2))
+ IF(JD.EQ.IDM2) JD = HRDCOL(1,1)
+ IF(JC.EQ.JDAHEP(2,IDM2).AND.COLRD(IDHW(IHEP))) THEN
+ JC = JMOHEP(2,JC)
+ ELSEIF(JC.EQ.IDM2) THEN
+ IF(JDAHEP(2,JMOHEP(2,JC)).EQ.JC) THEN
+ JC = JMOHEP(2,JC)
+ ELSE
+ JMOHEP(2,IHEP)=JMOHEP(2,JC)
+ GOTO 110
+ ENDIF
+ ELSE
+ JC = HRDCOL(1,1)
+ BVVUSE = .TRUE.
+ BVVHRD = .TRUE.
+ IF(ACOLRD(IDHW(IHEP))) JC = JD
+ IF(JC.EQ.IDM2) GOTO 110
+ ENDIF
+ ELSE
+ JC =JMOHEP(2,JC)
+ BVVUSE = .TRUE.
+ BVVHRD = .TRUE.
+ ENDIF
+ ELSEIF(BVHRD2(IDM)) THEN
+ JD = JMOHEP(2,JC)
+ IF(JC.EQ.JDAHEP(2,HRDCOL(1,2))) THEN
+ JMOHEP(2,IHEP)=JMOHEP(2,JC)
+ GOTO 110
+ ENDIF
+ IF(JD.EQ.JDAHEP(2,HRDCOL(1,2))) JD = HRDCOL(1,1)
+ BVVUSE=.TRUE.
+ BVVHRD = .TRUE.
+ IF(JC.EQ.JDAHEP(2,HRDCOL(1,2))) THEN
+ JC = JMOHEP(2,JC)
+ ELSE
+ JC = HRDCOL(1,1)
+ ENDIF
+ ELSE
+ JC =JMOHEP(2,JC)
+ ENDIF
+ IF (JC.EQ.0) CALL HWWARN('HWBCON',51,*110)
+C---FIND SPECTATOR WHEN JC IS DECAYED HEAVY QUARK OR SUSY PARTICLE
+ IF (ISTHEP(JC).EQ.155) THEN
+ IF (IDHEP(JMOHEP(1,JC)).EQ.94) THEN
+C---DECAYED BEFORE HADRONIZING
+ IF(BVVHRD) THEN
+ JHEP = JC
+ ELSEIF(BVVUSE) THEN
+ JHEP=JDAHEP(2,JC-1)
+ ELSE
+ JHEP=JMOHEP(2,JC)
+ ENDIF
+ IF(JHEP.EQ.0.AND.ABS(IDHEP(JC)).EQ.6) THEN
+ JHEP = JMOHEP(1,JMOHEP(1,JC))
+ IF(BVDEC1(JMOHEP(1,JHEP)).OR.BVDEC2(JMOHEP(1,JHEP))) THEN
+ JC = JHEP
+ JHEP = JDAHEP(2,JC-1)
+ ELSE
+ JHEP = 0
+ ENDIF
+ ENDIF
+ IF(BVVUSE.AND.ABS(IDHEP(JHEP)).GT.1000000.AND.
+ & ISTHEP(JHEP).NE.155.OR.JHEP.EQ.0) GOTO 110
+ ID=IDHW(JHEP)
+ IF (ISTHEP(JHEP).EQ.155) THEN
+C---SPECIAL FOR GLUINO DECAYS
+ IF (ID.EQ.449) THEN
+ ID=IDHW(JC)
+ IF(BVVUSE) THEN
+ ID=IDHW(IHEP)
+ IF(ID.LE.6.OR.ID.EQ.13.OR.
+ & (ID.GE.115.AND.ID.LE.120)) THEN
+ ID = 7
+ ELSE
+ ID = 1
+ ENDIF
+ ENDIF
+ CALL HWBRC1(JC,ID,JHEP,.TRUE.,*999)
+ IF(BVVUSE.AND.JMOHEP(1,JC).EQ.JMOHEP(1,JD)) JC =JD
+ ELSE
+ JC=JDAHEP(2,JHEP)
+ IF(COLRD(IDHW(IHEP)).AND.IDHW(JDAHEP(1,JHEP)).EQ.449)
+ & JC=JDAHEP(1,JHEP)
+ IF(BVVUSE.AND.JMOHEP(1,JC).EQ.JMOHEP(1,JD)) JC =JD
+ ENDIF
+ ELSE
+ IF(BVVUSE) THEN
+ IF(BVDEC2(JMOHEP(1,JHEP)).OR.JD.NE.JHEP.OR.
+ & BVHRD(JMOHEP(1,JHEP)).OR.BVHRD2(JMOHEP(1,JHEP))) THEN
+ JC = JD
+ GOTO 100
+ ELSE
+ JMOHEP(2,IHEP)=JHEP
+ ID = IDHW(JHEP)
+ IF((ID.GE.7.AND.ID.LE.12).OR.
+ & (ID.GE.109.AND.ID.LE.114)) JMOHEP(2,JHEP)=IHEP
+ ENDIF
+ ELSE
+C--new for particles connected to BV
+ IDM = JMOHEP(1,JHEP)
+ IF(BVDEC1(IDM).OR.BVHRD(IDM).OR.BVHRD2(IDM)) THEN
+ JC = JHEP
+ IF(ABS(IDHEP(IHEP)).LT.1000000) GOTO 100
+ JMOHEP(2,IHEP)=JHEP
+ GOTO 110
+ ENDIF
+C--new for top's from BV
+ ID = IDHW(JC)
+ IDP = JMOHEP(1,JMOHEP(1,JMOHEP(1,JC)))
+ IF((ID.EQ.6.AND.(BVDEC1(IDP))).
+ & OR.(ID.EQ.12.AND.BVDEC2(IDP)).
+ & OR.((ID.EQ.12.OR.ID.EQ.449).AND.BVHRD(IDP))) THEN
+ JMOHEP(2,IHEP)=JHEP
+ IF(JDAHEP(2,JHEP).EQ.JC) JDAHEP(2,JHEP)=IHEP
+ ELSE
+ IF((IDHW(IHEP).GE.7.AND.IDHW(IHEP).LE.12.
+ & AND.IDHW(JHEP).GE.7.AND.IDHW(JHEP).LE.12).OR.
+ & (IDHW(IHEP).LE.6.AND.IDHW(JHEP).LE.6)) THEN
+ JMOHEP(2,IHEP)=JHEP
+ ELSE
+ JMOHEP(2,IHEP)=JHEP
+ IF((COLRD(IDHW(IHEP)).AND.ACOLRD(IDHW(JHEP))).OR.
+ & (.NOT.COLRD(IDHW(IHEP)).AND.
+ & .NOT.ACOLRD(IDHW(JHEP)))) THEN
+ IF(JDAHEP(2,JHEP).EQ.0) THEN
+ JDAHEP(2,JHEP)=IHEP
+ ELSEIF(JMOHEP(2,JDAHEP(2,JHEP)).NE.JHEP) THEN
+ JDAHEP(2,JHEP)=IHEP
+ ENDIF
+ ELSE
+ IF(JMOHEP(2,JHEP).EQ.JC) JMOHEP(2,JHEP)=IHEP
+ ENDIF
+ ENDIF
+ ENDIF
+ ENDIF
+ GOTO 110
+ ENDIF
+ ELSE
+ JC=JMOHEP(2,JC)
+ ENDIF
+ ENDIF
+ 100 CONTINUE
+ IF(BVVUSE.AND.ABS(IDHEP(JC)).LT.1000000.AND.JC.NE.JD
+ & .AND.JD.NE.0.AND.JD.NE.JMOHEP(1,JC)) JC = JD
+ IF(BVVUSE.AND.ABS(IDHEP(JC)).GT.1000000) THEN
+ IF(COLRD(IDHW(IHEP)).AND..NOT.BVVHRD) GOTO 110
+ ENDIF
+ IF(BVVUSE.AND.ISTHEP(JC).EQ.149) JC=JMOHEP(1,JMOHEP(1,JC))
+C--SEARCH IN THE JET
+ IF((ISTHEP(JC).GT.145.AND.ISTHEP(JC).LT.152).AND.
+ & ISTHEP(IHEP).EQ.155) THEN
+ JMOHEP(2,IHEP) = JC
+ GOTO 110
+ ENDIF
+ CALL HWBRC2(COLP,IHEP,JC,.TRUE.,BVVUSE,BVVHRD)
+ IF(COLP.NE.0) THEN
+ JMOHEP(2,IHEP) = COLP
+ IF(COLRD(IDHW(IHEP)).AND.ACOLRD(IDHW(COLP)).
+ & AND.JDAHEP(2,COLP).EQ.0)
+ & JDAHEP(2,COLP) = IHEP
+ IF((IDHW(IHEP).GE.7.AND.IDHW(IHEP).LE.12).AND.
+ & (IDHW(COLP).GE.7.AND.IDHW(COLP).LE.12)) THEN
+ IF(JMOHEP(2,COLP).EQ.0) JMOHEP(2,COLP) = IHEP
+ ENDIF
+ ENDIF
+ ENDIF
+ 110 CONTINUE
+C---BREAK COLOUR CONNECTIONS WITH PHOTONS modified for Rslash
+ IHEP=1
+ 130 IF (IHEP.LE.NHEP) THEN
+ IF (IDHW(IHEP).EQ.59 .AND. ISTHEP(IHEP).EQ.149.AND.
+ & (JMOHEP(2,IHEP).NE.IHEP.OR.JDAHEP(2,IHEP).NE.IHEP)) THEN
+ IF(JMOHEP(2,IHEP).NE.0) THEN
+ IF (JDAHEP(2,JMOHEP(2,IHEP)).EQ.IHEP)
+ & JDAHEP(2,JMOHEP(2,IHEP))=JDAHEP(2,IHEP)
+ ENDIF
+ IF (JDAHEP(2,IHEP).NE.0) THEN
+ IF (JMOHEP(2,JDAHEP(2,IHEP)).EQ.IHEP)
+ & JMOHEP(2,JDAHEP(2,IHEP))=JMOHEP(2,IHEP)
+ ENDIF
+ DO RHEP=1,NHEP
+ IST=ISTHEP(RHEP)
+ IF((IST.GE.147.AND.IST.LE.149).AND.JDAHEP(2,RHEP).EQ.IHEP)
+ & JDAHEP(2,RHEP)=JMOHEP(2,IHEP)
+ ENDDO
+ DO RHEP=1,NHEP
+ IST=ISTHEP(RHEP)
+ IF((IST.GE.147.AND.IST.LE.149).AND.JMOHEP(2,RHEP).EQ.IHEP)
+ & JMOHEP(2,RHEP) = JDAHEP(2,IHEP)
+ ENDDO
+ JMOHEP(2,IHEP)=IHEP
+ JDAHEP(2,IHEP)=IHEP
+ ENDIF
+ IHEP=IHEP+1
+ GOTO 130
+ ENDIF
+C--Update the BV anticolour corrections
+ DO 210 IHEP=1,NHEP+1
+ IF(IHEP.EQ.1) GOTO 210
+ IST2 = 0
+ IF(IHEP.EQ.NHEP+1) THEN
+ ANTC = HRDCOL(1,1)
+ IF(ANTC.EQ.0.OR.(IDHW(JMOHEP(1,HRDCOL(1,2))).LE.6)) GOTO 210
+ IST=155
+ XHEP=HRDCOL(1,2)
+ IF(ANTC.EQ.JDAHEP(2,XHEP)) ANTC=JDAHEP(1,JDAHEP(1,ANTC))
+ IF(ANTC.NE.0.AND.JDAHEP(1,ANTC).NE.0) IST2=ISTHEP(ANTC)
+ ELSE
+ ANTC = JDAHEP(2,IHEP-1)
+ IF(ANTC.NE.0) IST2=ISTHEP(ANTC)
+ IST=ISTHEP(IHEP)
+ IDM = IDHW(IHEP)
+ XHEP=IHEP
+ ENDIF
+ JC = 0
+ JHEP = 0
+ JD = 0
+ ORG = 0
+ IF(IST.EQ.155.AND.IST2.EQ.155) THEN
+ IDM = IDHW(XHEP)
+ ORG = ANTC
+ IF(BVDEC1(XHEP).OR.BVDEC2(XHEP).OR.BVHRD(XHEP).OR.
+ & BVHRD2(XHEP)) THEN
+ JC=ANTC
+ ID = IDHW(JC)
+ JHEP = JC
+ IF(BVDEC1(JC).OR.BVDEC2(JC)) THEN
+ IF(IHEP.EQ.(NHEP+1)) ANTC=JDAHEP(1,JC)
+ GOTO 200
+ ENDIF
+ IF (ID.EQ.449) THEN
+C--SPECIAL FOR GLUINO DECAYS
+ ID=IDHW(XHEP)
+ IF(IHEP.EQ.NHEP+1) ID = 407
+ CALL HWBRC1(JC,ID,JHEP,.FALSE.,*999)
+ ELSE
+ IF(IDHW(JDAHEP(1,JHEP)).EQ.449) THEN
+ JC=JDAHEP(1,JHEP)
+ ELSE
+ JC=JDAHEP(2,JHEP)
+ ENDIF
+ ENDIF
+C--SEARCH IN JET
+ CALL HWBRC2(COLP,XHEP,JC,.FALSE.,BVVUSE,.FALSE.)
+ ANTC = COLP
+ IF(IHEP.LE.NHEP.AND.ACOLRD(IDHW(IHEP)).AND.
+ & COLRD(IDHW(COLP)).AND.JMOHEP(2,COLP).EQ.0) THEN
+ JMOHEP(2,COLP) = IHEP
+ ELSEIF(IHEP.LE.NHEP.AND.IDHW(IHEP).LE.6.AND.
+ & IDHW(COLP).LE.6.AND.JDAHEP(2,COLP).EQ.0) THEN
+ JDAHEP(2,COLP) = IHEP
+ ELSEIF(IHEP.GT.NHEP.AND.
+ & ((BVHRD(XHEP).AND.COLRD(JDAHEP(1,XHEP))).
+ & OR.(BVHRD2(XHEP).AND.ACOLRD(JDAHEP(2,XHEP)))).AND.
+ & ACOLRD(IDHW(COLP)).AND.JDAHEP(2,COLP).EQ.0) THEN
+ JDAHEP(2,COLP) = IHEP
+ ENDIF
+ ENDIF
+ ENDIF
+ 200 CONTINUE
+ IF(IHEP.EQ.NHEP+1) THEN
+ IF(HRDCOL(1,1).NE.ANTC.AND.ANTC.NE.0) THEN
+ HRDCOL(1,1)=ANTC
+ IF(JDAHEP(2,ANTC).EQ.IHEP) THEN
+ IF(JDAHEP(2,JMOHEP(1,HRDCOL(1,2))).EQ.JDAHEP(2,HRDCOL(1,2)).
+ & AND.JMOHEP(2,JDAHEP(2,HRDCOL(1,2))).EQ.JMOHEP(1,HRDCOL(1,2)))
+ & THEN
+ JDAHEP(2,ANTC) = JMOHEP(2,HRDCOL(1,2))
+ ELSE
+ JDAHEP(2,ANTC) = JMOHEP(1,HRDCOL(1,2))
+ ENDIF
+ ELSEIF(JMOHEP(2,ANTC).EQ.IHEP) THEN
+ JMOHEP(2,ANTC) = JMOHEP(1,HRDCOL(1,2))
+ ENDIF
+ ENDIF
+ ELSEIF(IHEP.NE.1) THEN
+ IF(JDAHEP(2,IHEP-1).NE.ANTC.AND.ANTC.NE.0) JDAHEP(2,IHEP-1)=ANTC
+ ENDIF
+ 210 CONTINUE
+C--Update BV decaying particles connections
+ DO 310 IHEP=1,NHEP+1
+ IF(IHEP.EQ.1) GOTO 310
+ IF(IHEP.EQ.NHEP+1) THEN
+ ANTC=HRDCOL(1,1)
+ IF(ANTC.EQ.0.OR.IDHW(JDAHEP(1,HRDCOL(1,2))).LE.6) GOTO 310
+ IST=155
+ XHEP=HRDCOL(1,2)
+ IF(ANTC.EQ.JDAHEP(2,XHEP)) ANTC=JDAHEP(1,JDAHEP(1,ANTC))
+ ELSE
+ ANTC=JMOHEP(2,IHEP)
+ IST=ISTHEP(IHEP)
+ IDM = IDHW(IHEP)
+ XHEP=IHEP
+ ENDIF
+ IST2 = 0
+ JC = 0
+ JD = 0
+ IF(ANTC.NE.0.AND.IHEP.NE.NHEP+1) THEN
+ IF(JDAHEP(1,ANTC).NE.0) IST2 = ISTHEP(ANTC)
+ ELSEIF(ANTC.NE.0.AND.IHEP.EQ.NHEP+1) THEN
+ IST2=ISTHEP(ANTC)
+ ENDIF
+ IF(IST.EQ.155.AND.IST2.EQ.155) THEN
+ IF(BVDEC2(XHEP).OR.BVHRD(XHEP).OR.BVHRD2(XHEP)) THEN
+C--FIND COLOUR CONNECTED PARTON
+ JC = ANTC
+ ID=IDHW(JC)
+ JHEP = JC
+ IF(BVDEC2(JHEP)) THEN
+ ANTC=JC
+ GOTO 300
+ ENDIF
+ IF (ID.EQ.449) THEN
+ ID=IDHW(XHEP)
+ IF(IHEP.EQ.NHEP+1) ID = 401
+C--SPECIAL FOR GLUINO DECAYS
+ CALL HWBRC1(JC,ID,JHEP,.TRUE.,*999)
+ ELSE
+ IF(IDHW(JDAHEP(1,JHEP)).EQ.449) THEN
+ JC=JDAHEP(1,JHEP)
+ ELSE
+ JC=JDAHEP(2,JHEP)
+ ENDIF
+ ENDIF
+C--SEARCH IN JET
+ CALL HWBRC2(COLP,XHEP,JC,.TRUE.,BVVUSE,.FALSE.)
+ ANTC = COLP
+ IF(COLP.EQ.0) GOTO 300
+ IF(IHEP.LE.NHEP) THEN
+ IF(JDAHEP(2,COLP).EQ.0) THEN
+ JDAHEP(2,COLP) = JDAHEP(2,IHEP)
+ ELSEIF(JMOHEP(2,JDAHEP(2,COLP)).NE.COLP) THEN
+ JDAHEP(2,COLP) = JDAHEP(2,IHEP)
+ ENDIF
+ ELSEIF(IHEP.GT.NHEP.AND.
+ & ((BVHRD(XHEP).AND.ACOLRD(JDAHEP(1,XHEP)).AND.
+ & IDHW(JDAHEP(2,XHEP)).EQ.449).
+ & OR.(BVHRD2(XHEP).AND.ACOLRD(JDAHEP(2,XHEP)))).AND.
+ & ACOLRD(IDHW(COLP)).AND.JDAHEP(2,COLP).EQ.0) THEN
+ JDAHEP(2,COLP) = IHEP
+ ENDIF
+ ENDIF
+ ENDIF
+ 300 CONTINUE
+ IF(IHEP.NE.NHEP+1.AND.IHEP.NE.1) THEN
+ IF(JMOHEP(2,IHEP).NE.ANTC.AND.ANTC.NE.0) JMOHEP(2,IHEP)=ANTC
+ ELSEIF(IHEP.GT.NHEP) THEN
+ IF(HRDCOL(1,1).NE.ANTC.AND.ANTC.NE.0) HRDCOL(1,1)=ANTC
+ IF(ANTC.EQ.0) GOTO 310
+ IF(JDAHEP(2,ANTC).EQ.IHEP) THEN
+ IF(JDAHEP(2,JMOHEP(1,HRDCOL(1,2))).EQ.JDAHEP(2,HRDCOL(1,2)).
+ & AND.JMOHEP(2,JDAHEP(2,HRDCOL(1,2))).EQ.JMOHEP(1,HRDCOL(1,2)))
+ & THEN
+ JDAHEP(2,ANTC) = JMOHEP(2,HRDCOL(1,2))
+ ELSE
+ JDAHEP(2,ANTC) = JMOHEP(1,HRDCOL(1,2))
+ ENDIF
+ ELSEIF(JMOHEP(2,ANTC).EQ.IHEP) THEN
+ JMOHEP(2,ANTC) = JMOHEP(1,HRDCOL(1,2))
+ ENDIF
+ ENDIF
+ 310 CONTINUE
+C--Update partons connected to decaying SUSY particle
+ DO 400 IHEP=1,NHEP
+ IST=ISTHEP(IHEP)
+C--LOOK FOR PARTONS CONNECTED TO A DECAYING SUSY PARTICLE
+ IF (IST.LT.145.OR.IST.GT.152) GOTO 400
+ IF(JMOHEP(2,IHEP).EQ.0) GOTO 400
+ IF(ISTHEP(JMOHEP(2,IHEP)).EQ.155) THEN
+C--FIND THE COLOUR CONNECTED PARTON
+ JC=JMOHEP(2,IHEP)
+ ID=IDHW(JC)
+ JHEP = JC
+ IF(BVDEC2(JC).AND.IDHW(JC).NE.449) GOTO 400
+ IF (ID.EQ.449) THEN
+C--SPECIAL FOR GLUINO DECAYS
+ ID=IDHW(IHEP)
+ CALL HWBRC1(JC,ID,JHEP,.TRUE.,*999)
+ ELSE
+ ID=IDHW(IHEP)
+ IF(COLRD(ID).AND.IDHW(JDAHEP(1,JC)).EQ.449) THEN
+ JC=JDAHEP(1,JHEP)
+ ELSE
+ JC=JDAHEP(2,JHEP)
+ ENDIF
+ ENDIF
+C--SEARCH IN JET
+ CALL HWBRC2(COLP,IHEP,JC,.TRUE.,BVVUSE,.FALSE.)
+ JMOHEP(2,IHEP) = COLP
+ ENDIF
+ 400 CONTINUE
+C--Update partons connected to decaying SUSY particle
+ DO 500 IHEP=1,NHEP
+ IST=ISTHEP(IHEP)
+C--LOOK FOR PARTONS CONNECTED TO A DECAYING SUSY PARTICLE
+ IF (IST.LT.145.OR.IST.GT.152) GOTO 500
+ IF(JDAHEP(2,IHEP).EQ.0) GOTO 500
+ IF(ISTHEP(JDAHEP(2,IHEP)).EQ.155) THEN
+C--FIND THE COLOUR CONNECTED PARTON
+ JC=JDAHEP(2,IHEP)
+ ID=IDHW(JC)
+ ID=IDHW(JC)
+ IF (ID.EQ.449) THEN
+ ID=IDHW(IHEP)
+C--SPECIAL FOR GLUINO DECAYS
+ JHEP = JC
+ CALL HWBRC1(JC,ID,JHEP,.FALSE.,*999)
+ ELSE
+ IF(ACOLRD(IDHW(IHEP)).AND.IDHW(JDAHEP(1,JC)).EQ.449) THEN
+ JC = JDAHEP(1,JC)
+ ELSE
+ JC=JDAHEP(2,JC)
+ ENDIF
+ ENDIF
+C--SEARCH IN THE JET
+ CALL HWBRC2(COLP,IHEP,JC,.FALSE.,BVVUSE,.FALSE.)
+ IF(COLP.NE.0) JDAHEP(2,IHEP) = COLP
+ ENDIF
+ 500 CONTINUE
+C--Flavour and anticolour connections in Rslash
+ DO 610 IHEP=1,NHEP
+ IST=ISTHEP(IHEP)
+ IF(IST.LT.145.OR.IST.GT.152.OR.JDAHEP(2,IHEP).NE.0) GOTO 610
+ JD = 0
+ BVVUSE = .FALSE.
+ JC = JMOHEP(1,IHEP)
+ IF(IST.NE.152) JC = JMOHEP(1,JC)
+ IF(JC.EQ.0) CALL HWWARN('HWBRCN',51,*610)
+C--For particles which came from a top decay
+ IF(ABS(IDHEP(JMOHEP(1,JC))).EQ.6) THEN
+ JD = JMOHEP(1,JMOHEP(1,JMOHEP(1,JC)))
+C--flavour connect to self if needed
+ IF(JDAHEP(2,JMOHEP(1,JC)-1).EQ.JMOHEP(1,JC)) THEN
+ JDAHEP(2,IHEP) = IHEP
+ GOTO 610
+ ELSEIF(JDAHEP(2,JMOHEP(1,JC)-1).NE.0) THEN
+ JDAHEP(2,IHEP) = JDAHEP(2,JMOHEP(1,JC)-1)
+ GOTO 610
+ ELSE
+ JC = JD
+ ENDIF
+ ENDIF
+C--Decide if this came from a BV decay
+ IDM = JMOHEP(1,JC)
+ IF(BVDEC1(IDM).OR.BVDEC2(IDM).OR.BVDEC3(IDM).
+ & OR.BVHRD(IDM).OR.BVHRD2(IDM)) THEN
+C--Do BV piece
+ IF(JDAHEP(2,JC).EQ.JMOHEP(1,JC)) THEN
+ IF(IDHW(JMOHEP(1,JC)).EQ.449.AND.
+ & JDAHEP(1,JMOHEP(1,JC)).EQ.JC) THEN
+ JC = JDAHEP(2,JMOHEP(1,JC)-1)
+ ELSE
+ JC = JMOHEP(2,JMOHEP(1,JC))
+ ENDIF
+ IF(ABS(IDHEP(JC)).LT.1000000) THEN
+ IF(JDAHEP(1,JC).EQ.0) THEN
+ JDAHEP(2,IHEP) = JC
+ GOTO 610
+ ELSE
+ GOTO 600
+ ENDIF
+ ELSEIF(ABS(IDHEP(JC)).GT.1000000
+ & .AND.ISTHEP(JC).NE.155) THEN
+ GOTO 610
+ ENDIF
+ IF(ISTHEP(JC).EQ.155.AND.ACOLRD(IDHW(IHEP))) THEN
+ JC = JDAHEP(1,JC)
+ ELSE
+ IF(ISTHEP(JC).EQ.155.AND.IDHW(JDAHEP(1,JC)).NE.449) THEN
+ JC = JDAHEP(1,JC)
+ ELSE
+ JC = JDAHEP(2,JC)
+ ENDIF
+ ENDIF
+ ELSE
+C--For the hard process
+ IF(IDHW(IDM).EQ.15.AND.JC.EQ.JDAHEP(2,JMOHEP(1,JC))) THEN
+ JDAHEP(2,IHEP) = JDAHEP(2,JC)
+ GOTO 610
+ ELSEIF(IDHW(IDM).EQ.15.AND.IDHW(IHEP).NE.449) THEN
+ JD=HRDCOL(1,1)
+ IF(BVHRD(IDM).AND.IDHW(JDAHEP(2,IDM)).NE.449) THEN
+ JC = JDAHEP(2,JC)
+ GOTO 600
+ ELSEIF(JMOHEP(1,JDAHEP(2,JC)).EQ.JD) THEN
+ JC=JDAHEP(2,JC)
+ GOTO 600
+ ENDIF
+ IF(JDAHEP(2,JC).EQ.8) JC = JD
+ ELSE
+ JD=JMOHEP(2,JMOHEP(1,JC))
+ ENDIF
+ IF(COLRD(IDHW(IHEP)).AND..NOT.ACOLRD(IDHW(IHEP)).AND.
+ & ABS(IDHEP(JD)).GT.1000000.AND.ISTHEP(JD).NE.155) THEN
+ JDAHEP(2,IHEP) = JD
+ IF(JDAHEP(2,JD).EQ.0) JDAHEP(2,JD) = IHEP
+ ENDIF
+ IF(ABS(IDHEP(JD)).GT.1000000
+ & .AND.ISTHEP(JD).NE.155) GOTO 610
+ IF(ISTHEP(JC).EQ.149) THEN
+ JDAHEP(2,IHEP)=JC
+ GOTO 610
+ ENDIF
+ IF(ACOLRD(IDHW(IHEP)).AND.IDHW(JC).EQ.449.AND.BVDEC2(JC)) THEN
+ JC = JDAHEP(1,JC)
+ ELSE
+ JC = JDAHEP(2,JC)
+ ENDIF
+ ENDIF
+C--SEARCH IN THE JET
+ 600 CALL HWBRC2(COLP,IHEP,JC,.FALSE.,BVVUSE,.FALSE.)
+ IF(COLP.NE.0) THEN
+ IF(ABS(IDHEP(COLP)).EQ.6.AND.JDAHEP(1,COLP).NE.0) THEN
+ IF(ISTHEP(COLP).EQ.155) THEN
+ JC = JDAHEP(2,COLP)
+ ELSE
+ JC = JDAHEP(2,JDAHEP(2,COLP))
+ ENDIF
+ GOTO 600
+ ENDIF
+ JDAHEP(2,IHEP) = COLP
+ ENDIF
+ ELSE
+C--check if it came from a top
+ IF(ABS(IDHEP(JC)).EQ.6) THEN
+C--start the analysis again
+ JC = JMOHEP(1,IHEP)
+ IF(IST.NE.152) JC = JMOHEP(1,JC)
+ JC = JDAHEP(2,JC)
+ IF(JC.EQ.0) CALL HWWARN('HWBRCN',52,*610)
+ IF(ISTHEP(JC).EQ.155) THEN
+ IF (IDHEP(JMOHEP(1,JC)).EQ.94) THEN
+C---DECAYED BEFORE HADRONIZING
+ JHEP=JDAHEP(2,JC-1)
+ IF (JHEP.EQ.0) GO TO 610
+ ID=IDHW(JHEP)
+ IF (ISTHEP(JHEP).EQ.155) THEN
+C---SPECIAL FOR GLUINO DECAYS
+ IF (ID.EQ.449) THEN
+ CALL HWBRC1(JC,ID,JHEP,.TRUE.,*999)
+ ELSE
+ JC=JDAHEP(2,JHEP)
+ ENDIF
+ ELSE
+ IF(JMOHEP(2,JHEP).EQ.JC) JMOHEP(2,JHEP)=IHEP
+ JDAHEP(2,IHEP) = JHEP
+ GOTO 610
+ ENDIF
+ ELSE
+ JC=JDAHEP(2,JC-1)
+ ENDIF
+ ENDIF
+C--SEARCH IN JET
+ CALL HWBRC2(COLP,IHEP,JC,.FALSE.,BVVUSE,.FALSE.)
+ IF(COLP.NE.0) JDAHEP(2,IHEP) = COLP
+ ELSE
+ CALL HWWARN('HWBRCN',100,*610)
+ ENDIF
+ ENDIF
+ 610 CONTINUE
+ 999 END
+CDECK ID>, HWBRC1.
+*CMZ :- -20/07/99 10:56:12 by Peter Richardson
+*-- Author : PeterRichardson
+C-----------------------------------------------------------------------
+ SUBROUTINE HWBRC1(JC,ID,JHEP,COL,*)
+C-----------------------------------------------------------------------
+C--Function to find the right daugther of a decaying gluino
+C-----------------------------------------------------------------------
+ INCLUDE 'HERWIG61.INC'
+ INTEGER ID,JHEP,KC,JC
+ LOGICAL COL
+C---N.B. WILL NEED MODS WHEN SUSY PARTICLES CAN SHOWER
+C--Rparity take the first daughther
+ IF(IDHW(JDAHEP(1,JHEP)).LE.12.AND.IDHW(JDAHEP(1,JHEP)+1).LE.12
+ & .AND.IDHW(JDAHEP(2,JHEP)).LE.12) THEN
+ KC = JDAHEP(1,JHEP)
+ GOTO 20
+ ELSEIF ((COL.AND.(ID.EQ.449.OR.ID.EQ.13)).OR.
+ & (ID.GE.401.AND.ID.LE.406).OR.
+ & (ID.GE.413.AND.ID.LE.418).OR.ID.LE.6.OR.
+ & (ID.GE.115.AND.ID.LE.120)) THEN
+C---LOOK FOR ANTI(S)QUARK OR GLUON
+ DO KC=JDAHEP(1,JHEP),JDAHEP(2,JHEP)
+ ID=IDHW(KC)
+ IF ((ID.GE.7.AND.ID.LE.13).OR.(ID.GE.407.AND.ID.LE.412).OR.
+ & (ID.GE.419.AND.ID.LE.424)) GOTO 20
+ ENDDO
+ ELSE
+C---LOOK FOR (S)QUARK OR GLUON
+ DO KC=JDAHEP(1,JHEP),JDAHEP(2,JHEP)
+ ID=IDHW(KC)
+ IF (ID.LE. 6.OR. ID.EQ. 13.OR.(ID.GE.401.AND.ID.LE.406).OR.
+ & (ID.GE.413.AND.ID.LE.418)) GOTO 20
+ ENDDO
+ ENDIF
+C---COULDNT FIND ONE
+ CALL HWWARN('HWBRC1',100,*10)
+ 10 RETURN 1
+ 20 JC=KC
+ END
+CDECK ID>, HWBRC2.
+*CMZ :- -20/07/99 10:56:12 by Peter Richardson
+*-- Author : Peter Richardson
+C-----------------------------------------------------------------------
+ SUBROUTINE HWBRC2(COLP,IHEP,JC,CON,BVVUSE,BVVHRD)
+C-----------------------------------------------------------------------
+C--Function to search in the jet for the particle
+C-----------------------------------------------------------------------
+ INCLUDE 'HERWIG61.INC'
+ INTEGER JC,JD,QHEP,LHEP,IHEP,JHEP,IDM,NCOUNT,ID,IP,IDM2,COLP
+ LOGICAL CON,BVVUSE,FLA,AFLA,BVVHRD
+ FLA(IP) = (IP.LE.6.OR.(IP.GE.115.AND.IP.LE.120).
+ & OR.(IP.GE.401.AND.IP.LE.406).
+ & OR.(IP.GE.413.AND.IP.LE.418))
+ AFLA(IP) = ((IP.LE.12.AND.IP.GE.7).OR.(IP.GE.109.AND.IP.LE.114).
+ & OR.(IP.GE.407.AND.IP.LE.412).
+ & OR.(IP.GE.419.AND.IP.LE.424))
+ ID = IDHW(IHEP)
+ COLP = 0
+C--begining and end of jet
+ IF(JDAHEP(1,JC).NE.0) THEN
+ JC=JDAHEP(1,JC)
+ JD=JDAHEP(2,JC)
+ ELSE
+ COLP = JC
+ RETURN
+ ENDIF
+ IF (JD.LT.JC) JD=JC
+ LHEP=0
+ IF(CON) THEN
+C--SEARCH FOR A COLOUR PARTNER
+ DO 110 JHEP=JC,JD
+ IDM = IDHW(JHEP)
+ IF (ISTHEP(JHEP).LT.145.OR.ISTHEP(JHEP).GT.152) GOTO 110
+ IF(AFLA(ID).AND.IDM.EQ.13) GOTO 110
+ IF (JDAHEP(2,JHEP).EQ.IHEP) LHEP=JHEP
+ IF ((BVVUSE.AND.JMOHEP(2,JHEP).NE.0).OR.
+ & (.NOT.BVVUSE.AND.JDAHEP(2,JHEP).NE.0)) GOTO 110
+ IF(BVVUSE.AND.ABS(IDHEP(JHEP)).GT.1000000) THEN
+ IF(BVVHRD.AND.AFLA(ID)) THEN
+ CONTINUE
+ ELSE
+ RETURN
+ ENDIF
+ ENDIF
+ IF(BVVUSE.AND.(
+ & ((FLA(ID).OR.ID.EQ.13.OR.ID.EQ.449).AND.AFLA(IDM)).
+ & OR.(AFLA(ID).AND.(FLA(IDM).OR.IDM.EQ.13.OR.IDM.EQ.449))))
+ & GOTO 110
+ IF(AFLA(ID).AND.(IDM.EQ.59.OR.IDM.EQ.449.OR.IDM.EQ.13)) GOTO 110
+C---JOIN IHEP AND JHEP
+ COLP=JHEP
+ IF(BVVUSE.OR.(ID.GE.7.AND.ID.LE.12.
+ & AND.((IDM.GE.7.AND.IDM.LE.12)))) RETURN
+ IF(IHEP.NE.HRDCOL(1,2).AND.
+ & (((FLA(ID).OR.ID.EQ.13.OR.ID.EQ.449.OR.ID.EQ.59)
+ & .AND.(AFLA(IDM).OR.IDM.EQ.13.OR.IDM.EQ.449.OR.IDM.EQ.59))
+ & .OR.(AFLA(ID).AND.(FLA(IDM).OR.IDM.EQ.59))))
+ & JDAHEP(2,JHEP)=IHEP
+ RETURN
+ 110 CONTINUE
+ IF (LHEP.NE.0) COLP=LHEP
+C--Additional Baryon number violating piece
+ IF(COLP.EQ.0) THEN
+ IDM2= IDHW(JC)
+ IF(JMOHEP(1,JC).LT.6) THEN
+ IF(IDM2.LE.6) THEN
+ IDM2= IDM2+6
+ ELSEIF(IDM2.GT.6) THEN
+ IDM2=IDM2-6
+ ENDIF
+ ENDIF
+ IF(IHEP.EQ.HRDCOL(1,2).OR.
+ & ((FLA(ID).OR.ID.EQ.13.OR.ID.EQ.449.OR.ID.EQ.15.OR.ID.EQ.59)
+ & .AND.(AFLA(IDM2).OR.IDM2.EQ.13.OR.IDM2.EQ.13))) THEN
+ QHEP = JD+1
+ 12 QHEP = QHEP-1
+ IF(IDHEP(QHEP).EQ.0) GOTO 12
+ IF(IDHW(QHEP).EQ.59) THEN
+ IF(JC.EQ.JD.AND.IDHW(JMOHEP(1,QHEP)).EQ.59) THEN
+ COLP = IHEP
+ RETURN
+ ELSE
+ GOTO 12
+ ENDIF
+ ENDIF
+ NCOUNT = 0
+ 11 IF(JDAHEP(2,QHEP).NE.0) THEN
+ IF(JMOHEP(2,JDAHEP(2,QHEP)).EQ.QHEP.AND.
+ & JDAHEP(2,QHEP).NE.QHEP) THEN
+ IF(JDAHEP(2,QHEP).GE.JC.AND.JDAHEP(2,QHEP).LE.JD) THEN
+ QHEP = JDAHEP(2,QHEP)
+ NCOUNT = NCOUNT+1
+ IF(NCOUNT.LT.NHEP) GOTO 11
+ ENDIF
+ ENDIF
+ ENDIF
+ ELSE
+ QHEP = JC
+ 13 QHEP = QHEP+1
+ IF(IDHEP(QHEP).EQ.0) GOTO 13
+ IF(IDHW(QHEP).EQ.59) THEN
+ IF(JC.EQ.JD.AND.IDHW(JMOHEP(1,QHEP)).EQ.59) THEN
+ COLP = IHEP
+ RETURN
+ ELSE
+ GOTO 13
+ ENDIF
+ ENDIF
+ NCOUNT = 0
+ 9 IF(JMOHEP(2,QHEP).NE.0) THEN
+ IF(JDAHEP(2,JMOHEP(2,QHEP)).EQ.QHEP.AND.
+ & JMOHEP(2,QHEP).NE.QHEP) THEN
+ IF(JMOHEP(2,QHEP).GE.JC.AND.JMOHEP(2,QHEP).LE.JD) THEN
+ QHEP = JMOHEP(2,QHEP)
+ NCOUNT = NCOUNT+1
+ IF(NCOUNT.LT.NHEP) GOTO 9
+ ENDIF
+ ENDIF
+ ENDIF
+ ENDIF
+ IF(ABS(IDHEP(QHEP)).LT.1000000) COLP=QHEP
+ ENDIF
+ ELSE
+C--Search for an anticolour partner
+ DO 210 JHEP=JC,JD
+ IF (ISTHEP(JHEP).LT.145.OR.ISTHEP(JHEP).GT.152) GOTO 210
+ IF (JMOHEP(2,JHEP).EQ.IHEP) LHEP=JHEP
+ IF (JMOHEP(2,JHEP).NE.0) GOTO 210
+C---JOIN IHEP AND JHEP
+ COLP=JHEP
+ RETURN
+ 210 CONTINUE
+ IF (LHEP.NE.0) COLP=LHEP
+C--New piece
+ IF(COLP.EQ.0) THEN
+ IDM2=IDHW(JC)
+ IF(JMOHEP(1,JC).LT.6) THEN
+ IF(IDM2.LE.6) THEN
+ IDM2= IDM2+6
+ ELSEIF(IDM2.GT.6) THEN
+ IDM2=IDM2-6
+ ENDIF
+ ENDIF
+C--Additional Baryon number violating piece
+ IF((FLA(ID).AND.AFLA(IDM2)).OR.
+ & ((AFLA(ID).OR.ID.EQ.13.OR.ID.EQ.449.OR.ID.EQ.15.OR.ID.EQ.59)
+ & .AND.(FLA(IDM2).OR.IDM2.EQ.13.OR.IDM2.EQ.449))) THEN
+ QHEP = JC
+ 211 QHEP = QHEP+1
+ IF(IDHEP(QHEP).EQ.0) GOTO 211
+ IF(IDHW(QHEP).EQ.59) THEN
+ IF(JC.EQ.JD.AND.IDHW(JMOHEP(1,QHEP)).EQ.59) THEN
+ COLP = IHEP
+ RETURN
+ ELSE
+ GOTO 211
+ ENDIF
+ ENDIF
+ NCOUNT = 0
+ 209 IF(JMOHEP(2,QHEP).NE.0) THEN
+ IF(JDAHEP(2,JMOHEP(2,QHEP)).EQ.QHEP.AND.
+ & JMOHEP(2,QHEP).NE.QHEP) THEN
+ IF(JMOHEP(2,QHEP).GE.JC.AND.JMOHEP(2,QHEP).LE.JD) THEN
+ QHEP = JMOHEP(2,QHEP)
+ NCOUNT = NCOUNT+1
+ IF(NCOUNT.LT.NHEP) GOTO 209
+ ENDIF
+ ENDIF
+ ENDIF
+ IF(QHEP.NE.0) COLP=QHEP
+ IF(JDAHEP(2,QHEP).EQ.0.AND.IHEP.NE.6) THEN
+ IDM2= IDHW(QHEP)
+ IF(FLA(IHEP).AND.FLA(QHEP).OR.
+ & ((AFLA(IHEP).OR.ID.EQ.13.OR.ID.EQ.449).AND.
+ & (AFLA(QHEP).OR.IDM2.EQ.13.OR.IDM2.EQ.449)))
+ & JDAHEP(2,QHEP)=IHEP
+ ENDIF
+ ELSE
+ QHEP = JD+1
+ 220 QHEP = QHEP-1
+ IF(IDHEP(QHEP).EQ.0) GOTO 220
+ IF(IDHW(QHEP).EQ.59) THEN
+ IF(JC.EQ.JD.AND.IDHW(JMOHEP(1,QHEP)).EQ.59) THEN
+ COLP = IHEP
+ RETURN
+ ELSE
+ GOTO 220
+ ENDIF
+ ENDIF
+ NCOUNT = 0
+ 219 IF(JDAHEP(2,QHEP).NE.0) THEN
+ IF(JMOHEP(2,JDAHEP(2,QHEP)).EQ.QHEP) THEN
+ IF(JDAHEP(2,QHEP).GE.JC.AND.JDAHEP(2,QHEP).LE.JD) THEN
+ QHEP = JDAHEP(2,QHEP)
+ NCOUNT = NCOUNT+1
+ IF(NCOUNT.LT.200) GOTO 219
+ ENDIF
+ ENDIF
+ ENDIF
+ IF(QHEP.NE.0) COLP=QHEP
+ IDM2 = IDHW(QHEP)
+ IF(JDAHEP(2,QHEP).EQ.0.AND.
+ & (((AFLA(ID).OR.ID.EQ.13).AND.(AFLA(IDM2).OR.IDM2.EQ.13)).OR.
+ & (FLA(ID).AND.FLA(IDM2)))) JDAHEP(2,QHEP)=IHEP
+ ENDIF
+ ENDIF
+ ENDIF
+ END
+CDECK ID>, HWBSPA.
+*CMZ :- -26/04/91 14.26.44 by Federico Carminati
+*-- Author : Ian Knowles
+C-----------------------------------------------------------------------
+ SUBROUTINE HWBSPA
+C-----------------------------------------------------------------------
+C Constructs time-like 4-momenta & production vertices in space-like
+C jet started by parton no.2 interference partner 1 and spin density
+C DECPAR(2). RHOPAR(2) gives the jet spin density matrix.
+C See I.G. Knowles, Comp. Phys. Comm. 58 (90) 271.
+C-----------------------------------------------------------------------
+ INCLUDE 'HERWIG61.INC'
+ DOUBLE PRECISION HWR,DMIN,PT,EIKON,EISCR,EINUM,EIDEN1,EIDEN2,
+ & WT,SPIN,Z1,Z2,TR,PRMAX,CX,SX,CAZ,ROHEP(3),RMAT(3,3),ZERO2(2)
+ INTEGER JPAR,KPAR,LPAR,MPAR
+ LOGICAL EICOR
+ EXTERNAL HWR
+ DATA ZERO2,DMIN/ZERO,ZERO,1.D-15/
+ IF (IERROR.NE.0) RETURN
+ JPAR=2
+ KPAR=1
+ IF (NPAR.EQ.2) THEN
+ CALL HWVZRO(2,RHOPAR(1,2))
+ RETURN
+ ENDIF
+C Generate azimuthal angle of JPAR's branching using an M-function
+C Find the daughters of JPAR, with LPAR time-like
+ 10 LPAR=JDAPAR(1,JPAR)
+ IF (TMPAR(LPAR)) THEN
+ MPAR=LPAR+1
+ ELSE
+ MPAR=LPAR
+ LPAR=MPAR+1
+ ENDIF
+C Soft correlations
+ CALL HWUROT(PPAR(1,JPAR), ONE,ZERO,RMAT)
+ CALL HWUROF(RMAT,PPAR(1,KPAR),ROHEP)
+ PT=MAX(SQRT(ROHEP(1)*ROHEP(1)+ROHEP(2)*ROHEP(2)),DMIN)
+ EIKON=1.
+ EICOR=AZSOFT.AND.IDPAR(LPAR).EQ.13
+ IF (EICOR) THEN
+ EISCR=1.-PPAR(5,MPAR)*PPAR(5,MPAR)/(MIN(PPAR(2,LPAR),
+ & PPAR(2,MPAR))*PPAR(4,MPAR)*PPAR(4,MPAR))
+ EINUM=PPAR(4,KPAR)*PPAR(4,LPAR)*ABS(PPAR(2,LPAR)-PPAR(2,MPAR))
+ EIDEN1=PPAR(4,KPAR)*PPAR(4,LPAR)-ROHEP(3)*PPAR(3,LPAR)
+ EIDEN2=PT*ABS(PPAR(1,LPAR))
+ EIKON=MAX(EISCR+EINUM/MAX(EIDEN1-EIDEN2,DMIN),ZERO)
+ ENDIF
+C Spin correlations
+ WT=0.
+ SPIN=1.
+ IF (AZSPIN.AND.IDPAR(JPAR).EQ.13) THEN
+ Z1=PPAR(4,JPAR)/PPAR(4,MPAR)
+ Z2=1.-Z1
+ IF (IDPAR(MPAR).EQ.13) THEN
+ TR=Z1/Z2+Z2/Z1+Z1*Z2
+ ELSEIF (IDPAR(MPAR).LT.13) THEN
+ TR=(Z1*Z1+Z2*Z2)/2.
+ ENDIF
+ WT=Z2/(Z1*TR)
+ ENDIF
+C Assign the azimuthal angle
+ PRMAX=(1.+ABS(WT))*EIKON
+ 50 CALL HWRAZM( ONE,CX,SX)
+ CALL HWUROT(PPAR(1,JPAR),CX,SX,RMAT)
+C Determine the angle between the branching planes
+ CALL HWUROF(RMAT,PPAR(1,KPAR),ROHEP)
+ CAZ=ROHEP(1)/PT
+ PHIPAR(1,JPAR)=2.*CAZ*CAZ-1.
+ PHIPAR(2,JPAR)=2.*CAZ*ROHEP(2)/PT
+ IF (EICOR) EIKON=MAX(EISCR+EINUM/MAX(EIDEN1-EIDEN2*CAZ,DMIN),ZERO)
+ IF (AZSPIN) SPIN=1.+WT*(DECPAR(1,JPAR)*PHIPAR(1,JPAR)
+ & +DECPAR(2,JPAR)*PHIPAR(2,JPAR))
+ IF (SPIN*EIKON.LT.HWR()*PRMAX) GOTO 50
+C Construct full 4-momentum of LPAR, sum P-trans of MPAR
+ PPAR(2,LPAR)=0.
+ PPAR(2,MPAR)=0.
+ CALL HWUROB(RMAT,PPAR(1,LPAR),PPAR(1,LPAR))
+ CALL HWVDIF(2,PPAR(1,2),PPAR(1,LPAR),PPAR(1,2))
+C Test for end of space-like branches
+ IF (JDAPAR(1,MPAR).EQ.0) GOTO 60
+C Generate new Decay matrix
+ CALL HWBAZF(MPAR,JPAR,ZERO2,DECPAR(1,JPAR),
+ & PHIPAR(1,JPAR),DECPAR(1,MPAR))
+C Advance along the space-like branch
+ JPAR=MPAR
+ KPAR=LPAR
+ GOTO 10
+C Retreat along space-like line
+C Assign initial spin density matrix
+ 60 CALL HWVEQU(2,ZERO2,RHOPAR(1,MPAR))
+ CALL HWUMAS(PPAR(1,2))
+ CALL HWVZRO(4,VPAR(1,MPAR))
+ 70 CALL HWVEQU(4,VPAR(1,MPAR),VPAR(1,LPAR))
+ IF (MPAR.EQ.2) RETURN
+C Construct spin density matrix for time-like branch
+ CALL HWBAZF(MPAR,JPAR,RHOPAR(1,MPAR),PHIPAR(1,JPAR),
+ & DECPAR(1,JPAR),RHOPAR(1,LPAR))
+C Evolve time-like side branch
+ CALL HWBTIM(LPAR,MPAR)
+C Construct spin density matrix for space-like branch
+ CALL HWBAZF(MPAR,JPAR,PHIPAR(1,JPAR),RHOPAR(1,MPAR),
+ & DECPAR(1,LPAR),RHOPAR(1,JPAR))
+C Assign production vertex to J
+ CALL HWVDIF(4,PPAR(1,MPAR),PPAR(1,LPAR),PPAR(1,JPAR))
+ CALL HWUDKL(IDPAR(JPAR),PPAR(1,JPAR),VPAR(1,JPAR))
+ CALL HWVSUM(4,VPAR(1,MPAR),VPAR(1,JPAR),VPAR(1,JPAR))
+C Find parent and partner of MPAR
+ MPAR=JPAR
+ JPAR=JMOPAR(1,MPAR)
+ LPAR=MPAR+1
+ IF (JMOPAR(1,LPAR).NE.JPAR) LPAR=MPAR-1
+ GOTO 70
+ END
+CDECK ID>, HWBSPN.
+*CMZ :- -26/04/91 11.11.54 by Bryan Webber
+*-- Author : Ian Knowles
+C-----------------------------------------------------------------------
+ SUBROUTINE HWBSPN
+C-----------------------------------------------------------------------
+C Constructs appropriate spin density/decay matrix for parton
+C in hard subprocess, othwise zero. Assignments based upon
+C Comp. Phys. Comm. 58 (1990) 271.
+C-----------------------------------------------------------------------
+ INCLUDE 'HERWIG61.INC'
+ DOUBLE PRECISION C,V12,V23,V13,TR,C1,C2,C3,R1(2),R2(2)
+ INTEGER IST
+ SAVE R1,R2,V12
+ IF (IERROR.NE.0) RETURN
+ IST=MOD(ISTHEP(NEVPAR),10)
+C Assumed partons processed in the order IST=1,2,3,4
+ IF (IPROC.GE.100.AND.IPROC.LE.116) THEN
+C An e+e- ---> qqbar g event
+ IF (IDPAR(2).EQ.13) THEN
+ RHOPAR(1,2)=GPOLN
+ RHOPAR(2,2)=0.
+ RETURN
+ ENDIF
+ ELSEIF (IPRO.EQ.15.OR.IPRO.EQ.17) THEN
+ IF (IHPRO.EQ. 7.OR.IHPRO.EQ. 8.OR.
+ & IHPRO.EQ.10.OR.IHPRO.EQ.11.OR.
+ & IHPRO.EQ.15.OR.IHPRO.EQ.16.OR.
+ & (IHPRO.GE.21.AND.IHPRO.LE.31)) THEN
+C A hard 2 --- > 2 QCD subprocess involving gluons
+ IF (IST.EQ.2) THEN
+ CALL HWVEQU(2,RHOPAR(1,2),R1(1))
+ C=GCOEF(2)/GCOEF(1)
+ DECPAR(1,2)=C*R1(1)
+ DECPAR(2,2)=C*R1(2)
+ RETURN
+ ELSEIF (IST.EQ.3) THEN
+ CALL HWVEQU(2,RHOPAR(1,2),R2(1))
+ V12=R1(1)*R2(1)+R1(2)*R2(2)
+ TR=1./(GCOEF(1)+GCOEF(2)*V12)
+ RHOPAR(1,2)= (GCOEF(3)*R1(1)+GCOEF(4)*R2(1))*TR
+ RHOPAR(2,2)=-(GCOEF(3)*R1(2)+GCOEF(4)*R2(2))*TR
+ RETURN
+ ELSEIF (IST.EQ.4) THEN
+ V13=R1(1)*DECPAR(1,2)+R1(2)*DECPAR(2,2)
+ V23=R2(1)*DECPAR(1,2)+R2(2)*DECPAR(2,2)
+ TR=1./(GCOEF(1)+GCOEF(2)*V12+GCOEF(3)*V13+GCOEF(4)*V23)
+ C1=(GCOEF(2)+GCOEF(5))*TR
+ C2=(GCOEF(3)+GCOEF(6))*TR
+ C3=(GCOEF(4)+GCOEF(6))*TR
+ RHOPAR(1,2)=C1*DECPAR(1,2)+C2*R2(1)+C3*R1(1)
+ RHOPAR(2,2)=C1*DECPAR(2,2)-C2*R1(2)-C3*R2(2)
+ RETURN
+ ENDIF
+ ENDIF
+ ELSEIF (IPRO.EQ.16) THEN
+C A gluon fusion ---> Higgs event
+ IF (IST.EQ.2) THEN
+ DECPAR(1,2)=RHOPAR(1,2)
+ DECPAR(2,2)=-RHOPAR(2,2)
+ RETURN
+ ENDIF
+ ENDIF
+ CALL HWVZRO(2,RHOPAR(1,2))
+ CALL HWVZRO(2,DECPAR(1,2))
+ END
+CDECK ID>, HWBSU1.
+*CMZ :- -13/07/92 20.15.54 by Mike Seymour
+*-- Author : Bryan Webber, modified by Mike Seymour
+C-----------------------------------------------------------------------
+ FUNCTION HWBSU1(ZLOG)
+C-----------------------------------------------------------------------
+C Z TIMES THE INTEGRAND IN EXPONENT OF QUARK SUDAKOV FORM FACTOR.
+C HWBSU1 IS FOR UPPER PART OF Z INTEGRATION REGION
+C-----------------------------------------------------------------------
+ DOUBLE PRECISION HWBSU1,HWBSUL,Z,ZLOG,U
+ EXTERNAL HWBSUL
+ Z=EXP(ZLOG)
+ U=1.-Z
+ HWBSU1=HWBSUL(Z)*(1.+U*U)
+ END
+CDECK ID>, HWBSU2.
+*CMZ :- -13/07/92 20.15.54 by Mike Seymour
+*-- Author : Bryan Webber, modified by Mike Seymour
+C-----------------------------------------------------------------------
+ FUNCTION HWBSU2(Z)
+C-----------------------------------------------------------------------
+C INTEGRAND IN EXPONENT OF QUARK SUDAKOV FORM FACTOR.
+C HWBSU2 IS FOR LOWER PART OF Z INTEGRATION REGION
+C-----------------------------------------------------------------------
+ DOUBLE PRECISION HWBSU2,HWBSUL,Z,U
+ EXTERNAL HWBSUL
+ U=1.-Z
+ HWBSU2=HWBSUL(Z)*(1.+Z*Z)/U
+ END
+CDECK ID>, HWBSUD.
+*CMZ :- -14/07/92 13.28.23 by Mike Seymour
+*-- Author : Bryan Webber
+C-----------------------------------------------------------------------
+ SUBROUTINE HWBSUD
+C-----------------------------------------------------------------------
+C COMPUTES (OR READS) TABLES OF SUDAKOV FORM FACTORS
+C-----------------------------------------------------------------------
+ INCLUDE 'HERWIG61.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
+ COMMON/HWSINT/QRAT,QLAM
+ IF (LRSUD.EQ.0) THEN
+ POWER=1./FLOAT(NQEV-1)
+ AFAC=6.*CAFAC/BETAF
+ QMIN=QG+QG
+ QFAC=(1.1*QLIM/QMIN)**POWER
+ SUD(1,1)=1.
+ QEV(1,1)=QMIN
+C--IS=1 FOR GLUON->GLUON+GLUON FORM FACTOR
+ DO 10 IQ=2,NQEV
+ QNOW=QFAC*QEV(IQ-1,1)
+ QLAM=QNOW/QCDL3
+ ZMIN=QG/QNOW
+ QRAT=1./ZMIN
+ G1=0
+ DO 5 I=3,6
+ ZLO=ZMIN
+ ZHI=HALF
+ IF (I.NE.6) ZLO=MAX(ZLO,QG/RMASS(I+1))
+ IF (I.NE.3) ZHI=MIN(ZHI,QG/RMASS(I))
+ IF (ZHI.GT.ZLO) G1=G1+HWUGAU(HWBSUG,LOG(ZLO),LOG(ZHI),ACCUR)
+ 5 CONTINUE
+ SUD(IQ,1)=EXP(AFAC*G1)
+ 10 QEV(IQ,1)=QNOW
+ AFAC=3.*CFFAC/BETAF
+C--QUARK FORM FACTORS.
+C--IS=2,3,4,5,6,7 FOR U/D,S,C,B,T,V
+ DO 15 IS=2,NSUD
+ Q1=HWBVMC(IS)
+ IF (IS.EQ.7) Q1=HWBVMC(209)
+ QMIN=Q1+QG
+ IF (QMIN.GT.QLIM) GOTO 15
+ QFAC=(1.1*QLIM/QMIN)**POWER
+ SUD(1,IS)=1.
+ QEV(1,IS)=QMIN
+ DO 14 IQ=2,NQEV
+ QNOW=QFAC*QEV(IQ-1,IS)
+ QLAM=QNOW/QCDL3
+ ZMIN=QG/QNOW
+ QRAT=1./ZMIN
+ ZMAX=QG/QMIN
+ G1=0
+ DO 12 I=3,6
+ ZLO=ZMIN
+ ZHI=ZMAX
+ IF (I.NE.6) ZLO=MAX(ZLO,QG/RMASS(I+1))
+ IF (I.NE.3) ZHI=MIN(ZHI,QG/RMASS(I))
+ IF (ZHI.GT.ZLO) G1=G1+HWUGAU(HWBSU1,LOG(ZLO),LOG(ZHI),ACCUR)
+ 12 CONTINUE
+ ZMIN=Q1/QNOW
+ QRAT=1./ZMIN
+ ZMAX=Q1/QMIN
+ G2=0
+ DO 13 I=3,6
+ ZLO=ZMIN
+ ZHI=ZMAX
+ IF (I.NE.6) ZLO=MAX(ZLO,Q1/RMASS(I+1))
+ IF (I.NE.3) ZHI=MIN(ZHI,Q1/RMASS(I))
+ IF (ZHI.GT.ZLO) G2=G2+HWUGAU(HWBSU2,ZLO,ZHI,ACCUR)
+ 13 CONTINUE
+ SUD(IQ,IS)=EXP(AFAC*(G1+G2))
+ 14 QEV(IQ,IS)=QNOW
+ 15 CONTINUE
+ QCOLD=QCDLAM
+ VGOLD=VGCUT
+ VQOLD=VQCUT
+ ACOLD=ACCUR
+ INOLD=INTER
+ NQOLD=NQEV
+ NSOLD=NSUD
+ NCOLD=NCOLO
+ NFOLD=NFLAV
+ SDOLD=SUDORD
+ DO 16 IS=1,NSUD
+ 16 RMOLD(IS)=RMASS(IS)
+ ELSE
+ IF (LRSUD.GT.0) THEN
+ IF (IPRINT.NE.0) WRITE (6,17) LRSUD
+ 17 FORMAT(10X,'READING SUDAKOV TABLE ON UNIT',I4)
+ OPEN(UNIT=LRSUD,FORM='UNFORMATTED',STATUS='UNKNOWN')
+ READ(UNIT=LRSUD) QCOLD,VGOLD,VQOLD,RMOLD,
+ & ACOLD,QEV,SUD,INOLD,NQOLD,NSOLD,NCOLD,NFOLD,SDOLD
+ CLOSE(UNIT=LRSUD)
+ ENDIF
+C---CHECK THAT RELEVANT PARAMETERS ARE UNCHANGED
+ IF (QCDLAM.NE.QCOLD) CALL HWWARN('HWBSUD',501,*999)
+ IF (VGCUT .NE.VGOLD) CALL HWWARN('HWBSUD',502,*999)
+ IF (VQCUT .NE.VQOLD) CALL HWWARN('HWBSUD',503,*999)
+ IF (ACCUR .NE.ACOLD) CALL HWWARN('HWBSUD',504,*999)
+ IF (INTER .NE.INOLD) CALL HWWARN('HWBSUD',505,*999)
+ IF (NQEV .NE.NQOLD) CALL HWWARN('HWBSUD',506,*999)
+ IF (NSUD .NE.NSOLD) CALL HWWARN('HWBSUD',507,*999)
+ IF (NCOLO .NE.NCOLD) CALL HWWARN('HWBSUD',508,*999)
+ IF (NFLAV .NE.NFOLD) CALL HWWARN('HWBSUD',509,*999)
+ IF (SUDORD.NE.SDOLD) CALL HWWARN('HWBSUD',510,*999)
+C---CHECK MASSES AND THAT TABLES ARE BIG ENOUGH FOR THIS RUN
+ DO 18 IS=1,NSUD
+ IF (RMASS(IS).NE.RMOLD(IS))
+ & CALL HWWARN('HWBSUD',510+IS,*999)
+ IF (QEV(NQEV,IS).LT.QLIM.AND.HWBVMC(IS)+QG.LT.QLIM)
+ & CALL HWWARN('HWBSUD',500,*999)
+ 18 CONTINUE
+ ENDIF
+ IF (LWSUD.GT.0) THEN
+ IF (IPRINT.NE.0) WRITE (6,19) LWSUD
+ 19 FORMAT(10X,'WRITING SUDAKOV TABLE ON UNIT',I4)
+ OPEN (UNIT=LWSUD,FORM='UNFORMATTED',STATUS='UNKNOWN')
+ WRITE(UNIT=LWSUD) QCDLAM,VGCUT,VQCUT,(RMASS(I),I=1,6),
+ & ACCUR,QEV,SUD,INTER,NQEV,NSUD,NCOLO,NFLAV,SUDORD
+ CLOSE(UNIT=LWSUD)
+ ENDIF
+ IF (IPRINT.GT.2) THEN
+C--PRINT EXTRACTS FROM TABLES OF FORM FACTORS
+ DO 40 IS=1,NSUD
+ WRITE(6,20) IS,NQEV
+ 20 FORMAT(1H1//10X,'EXTRACT FROM TABLE OF SUDAKOV FORM FACTOR NO.',
+ & I2,' (',I5,' ACTUAL ENTRIES)'//10X,'SUD IS PROBABILITY THAT',
+ & ' PARTON WITH GIVEN UPPER LIMIT ON Q WILL REACH THRESHOLD',
+ & ' WITHOUT BRANCHING'///2X,8(' Q SUD ')/)
+ L2=NQEV/8
+ L1=L2/32
+ IF (L1.LT.1) L1=1
+ DO 40 L=L1,L2,L1
+ LL=L+7*L2
+ WRITE(6,30) (QEV(I,IS),SUD(I,IS),I=L,LL,L2)
+ 30 FORMAT(2X,8(F9.2,F7.4))
+ 40 CONTINUE
+ WRITE(6,50)
+ 50 FORMAT(1H1)
+ ENDIF
+ 999 END
+CDECK ID>, HWBSUG.
+*CMZ :- -13/07/92 20.15.54 by Mike Seymour
+*-- Author : Bryan Webber, modified by Mike Seymour
+C-----------------------------------------------------------------------
+ FUNCTION HWBSUG(ZLOG)
+C-----------------------------------------------------------------------
+C Z TIMES INTEGRAND IN EXPONENT OF GLUON SUDAKOV FORM FACTOR
+C-----------------------------------------------------------------------
+ DOUBLE PRECISION HWBSUG,HWBSUL,Z,ZLOG,W
+ EXTERNAL HWBSUL
+ Z=EXP(ZLOG)
+ W=Z*(1.-Z)
+ HWBSUG=HWBSUL(Z)*(W-2.+1./W)*Z
+ END
+CDECK ID>, HWBSUL.
+*CMZ :- -13/07/92 20.15.54 by Mike Seymour
+*-- Author : Mike Seymour
+C-----------------------------------------------------------------------
+ FUNCTION HWBSUL(Z)
+C-----------------------------------------------------------------------
+C LOGARITHMIC PART OF INTEGRAND IN EXPONENT OF SUDAKOV FORM FACTOR.
+C THE SECOND ORDER ALPHAS CASE COMES FROM CONVERTING INTEGRAL OVER
+C Q^2 INTO ONE OVER ALPHAS, WITH FLAVOUR THRESHOLDS.
+C-----------------------------------------------------------------------
+ INCLUDE 'HERWIG61.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 'HERWIG61.INC'
+ DOUBLE PRECISION HWR,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 HWR
+ DATA ZERO2,DMIN/ZERO,ZERO,1.D-15/
+ IF (IERROR.NE.0) RETURN
+ JPAR=INITBR
+ KPAR=INTERF
+ IF ((JDAPAR(1,JPAR).NE.0).OR.(IDPAR(JPAR).EQ.13)) GOTO 30
+C No branching, assign decay matrix
+ CALL HWVZRO(2,DECPAR(1,JPAR))
+ RETURN
+C Advance up the leader
+C Find the parent and partner of J
+ 10 IPAR=JMOPAR(1,JPAR)
+ KPAR=JPAR+1
+C Generate new Rho
+ IF (JMOPAR(1,KPAR).EQ.IPAR) THEN
+C Generate Rho'
+ CALL HWBAZF(IPAR,JPAR,PHIPAR(1,IPAR),RHOPAR(1,IPAR),
+ & ZERO2,RHOPAR(1,JPAR))
+ ELSE
+ KPAR=JPAR-1
+ IF (JMOPAR(1,KPAR).NE.IPAR)
+ & CALL HWWARN('HWBTIM',100,*999)
+C Generate Rho''
+ CALL HWBAZF(IPAR,KPAR,RHOPAR(1,IPAR),PHIPAR(1,IPAR),
+ & DECPAR(1,KPAR),RHOPAR(1,JPAR))
+ ENDIF
+C Generate azimuthal angle of J's branching
+ 30 IF (JDAPAR(1,JPAR).EQ.0) THEN
+C Final state gluon
+ CALL HWVZRO(2,DECPAR(1,JPAR))
+ IF (JPAR.EQ.INITBR) RETURN
+ GOTO 70
+ ELSE
+C Assign an angle to a branching using an M-function
+C Find the daughters of J
+ LPAR=JDAPAR(1,JPAR)
+ MPAR=JDAPAR(2,JPAR)
+C Soft correlations
+ CALL HWUROT(PPAR(1,JPAR), ONE,ZERO,RMAT)
+ CALL HWUROF(RMAT,PPAR(1,KPAR),ROHEP)
+ PT=MAX(SQRT(ROHEP(1)*ROHEP(1)+ROHEP(2)*ROHEP(2)),DMIN)
+ EIKON=1.
+ SWAP=.FALSE.
+ EICOR=AZSOFT.AND.((IDPAR(LPAR).EQ.13).OR.(IDPAR(MPAR).EQ.13))
+ IF (EICOR) THEN
+C Rearrange s.t. LPAR is the (softest) gluon
+ IF (IDPAR(MPAR).EQ.13) THEN
+ IF (IDPAR(LPAR).NE.13.OR.
+ & PPAR(4,MPAR).LT.PPAR(4,LPAR)) THEN
+ SWAP=.TRUE.
+ LPAR=MPAR
+ MPAR=LPAR-1
+ ENDIF
+ ENDIF
+ EINUM=(PPAR(4,KPAR)*PPAR(4,LPAR))
+ & *ABS(PPAR(2,LPAR)-PPAR(2,MPAR))
+ EIDEN1=(PPAR(4,KPAR)*PPAR(4,LPAR))-ROHEP(3)*PPAR(3,LPAR)
+ EIDEN2=PT*ABS(PPAR(1,LPAR))
+ EISCR=1.-(PPAR(5,MPAR)/PPAR(4,MPAR))**2
+ & /MIN(PPAR(2,LPAR),PPAR(2,MPAR))
+ EIKON=EISCR+EINUM/MAX(EIDEN1-EIDEN2,DMIN)
+ ENDIF
+C Spin correlations
+ WT=0.
+ SPIN=1.
+ IF (AZSPIN) THEN
+ Z1=PPAR(4,LPAR)/PPAR(4,JPAR)
+ Z2=1.-Z1
+ IF (IDPAR(JPAR).EQ.13.AND.IDPAR(LPAR).EQ.13) THEN
+ WT=Z1*Z2/(Z1/Z2+Z2/Z1+Z1*Z2)
+ ELSEIF (IDPAR(JPAR).EQ.13.AND.IDPAR(LPAR).LT.13) THEN
+ WT=-2.*Z1*Z2/(Z1*Z1+Z2*Z2)
+ ENDIF
+ ENDIF
+C Assign the azimuthal angle
+ PRMAX=(1.+ABS(WT))*EIKON
+ NTRY=0
+ 50 NTRY=NTRY+1
+ IF (NTRY.GT.NBTRY) CALL HWWARN('HWBTIM',101,*999)
+ CALL HWRAZM( ONE,CX,SX)
+ CALL HWUROT(PPAR(1,JPAR),CX,SX,RMAT)
+C Determine the angle between the branching planes
+ CALL HWUROF(RMAT,PPAR(1,KPAR),ROHEP)
+ CAZ=ROHEP(1)/PT
+ PHIPAR(1,JPAR)=2.*CAZ*CAZ-1.
+ PHIPAR(2,JPAR)=2.*CAZ*ROHEP(2)/PT
+ IF (EICOR) EIKON=EISCR+EINUM/MAX(EIDEN1-EIDEN2*CAZ,DMIN)
+ IF (AZSPIN) SPIN=1.+WT*(RHOPAR(1,JPAR)*PHIPAR(1,JPAR)
+ & +RHOPAR(2,JPAR)*PHIPAR(2,JPAR))
+ IF (SPIN*EIKON.LT.HWR()*PRMAX) GOTO 50
+C Construct full 4-momentum of L and M
+ JOLD=JPAR
+ IF (SWAP) THEN
+ PPAR(1,LPAR)=-PPAR(1,LPAR)
+ PPAR(1,MPAR)=-PPAR(1,MPAR)
+ JPAR=MPAR
+ ELSE
+ JPAR=LPAR
+ ENDIF
+ PPAR(2,LPAR)=0.
+ CALL HWUROB(RMAT,PPAR(1,LPAR),PPAR(1,LPAR))
+ PPAR(2,MPAR)=0.
+ CALL HWUROB(RMAT,PPAR(1,MPAR),PPAR(1,MPAR))
+C Assign production vertex to L and M
+ CALL HWUDKL(IDPAR(JOLD),PPAR(1,JOLD),VPAR(1,LPAR))
+ CALL HWVSUM(4,VPAR(1,JOLD),VPAR(1,LPAR),VPAR(1,LPAR))
+ CALL HWVEQU(4,VPAR(1,LPAR),VPAR(1,MPAR))
+ ENDIF
+ 60 IF (JDAPAR(1,JPAR).NE.0) GOTO 10
+C Assign decay matrix
+ CALL HWVZRO(2,DECPAR(1,JPAR))
+C Backtrack down the leader
+ 70 IPAR=JMOPAR(1,JPAR)
+ KPAR=JDAPAR(1,IPAR)
+ IF (KPAR.EQ.JPAR) THEN
+C Develop the side branch
+ JPAR=JDAPAR(2,IPAR)
+ GOTO 60
+ ELSE
+C Construct decay matrix
+ CALL HWBAZF(IPAR,KPAR,DECPAR(1,JPAR),DECPAR(1,KPAR),
+ & PHIPAR(1,IPAR),DECPAR(1,IPAR))
+ ENDIF
+ IF (IPAR.EQ.INITBR) RETURN
+ JPAR=IPAR
+ GOTO 70
+ 999 END
+CDECK ID>, HWBTOP.
+*CMZ :- -14/10/99 18.04.56 by Mike Seymour
+*-- Author : Gennaro Corcella
+C-----------------------------------------------------------------------
+ SUBROUTINE HWBTOP
+C-----------------------------------------------------------------------
+ INCLUDE 'HERWIG61.INC'
+ DOUBLE PRECISION HWBVMC,HWR,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,HWR
+ 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)*HWR())
+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))**HWR()
+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.HWR()) THEN
+ ID3=13
+ ELSE
+ RETURN
+ ENDIF
+C---CHECK INFRA-RED CUT-OFF FOR GLUON
+ M(1)=PHEP(5,JDAHEP(1,ICMF))
+ M(2)=HWBVMC(ID)
+ M(3)=HWBVMC(ID3)
+ E(1)=HALF*EM*(X(1)+AW+(-M(2)**2-M(3)**2)/EM**2)
+ E(3)=HALF*EM*X(3)
+ E(2)=EM-E(1)-E(3)
+ PTSQ=-LAMBDA(E(1)**2-M(1)**2,E(3)**2-M(3)**2,
+ & E(2)**2-M(2)**2)
+ IF (PTSQ.LE.0.OR.E(1).LE.M(1).OR.E(2).LE.M(2).OR.E(3).LE.M(3))
+ $ RETURN
+C---CALCULATE MASS-DEPENDENT SUPPRESSION
+ EPS=(RMASS(ID)/EM)**2
+ EPG=(RMASS(ID3)/EM)**2
+ GAMDEP=(1-AW)*(1+1/AW-2*AW)/(SQRT(1+AW**2+EPS**2
+ & -2*AW-2*EPS-2*AW*EPS)*(1+EPS+(1-EPS)**2/AW-2*AW))
+ MASDEP=GAMDEP/(1-X(1))*((1+EPS+(1-EPS)**2/AW-2*AW)
+ & *((1-AW+EPS)*X(3)*(1-X(1))-(1-X(1))**2*(1-X(3))
+ & -X(3)**2*(1-X(1)+EPS))+(1+(1+EPS)/(2*AW))*X(3)
+ & *(1-X(1))*(X(1)+X(3)-1)**2+2*X(3)**2*(1-X(1))**2)
+ IF (MASDEP.LT.HWR()*((1+1/AW-2*AW)*((1-AW)*X(3)
+ & -(1-X(1))*(1-X(3))-X(3)**2)+(1+1/(2*AW))*X(3)
+ & *(X(1)+X(3)-1)**2+2*X(3)**2*(1-X(1)))) RETURN
+C---STORE OLD MOMENTA
+c---PT = TOP MOMENTUM, PW= W MOMENTUM
+ CALL HWVEQU(5,PHEP(1,ICMF),PT)
+ CALL HWVEQU(5,PHEP(1,JDAHEP(1,ICMF)),PW)
+C--------GET THE NON-EMITTING PARTON CMF DIRECTION
+ CALL HWULOF(PHEP(1,ICMF),PW,PW)
+ CALL HWRAZM(ONE,CS,SN)
+ CALL HWUROT(PW,CS,SN,R)
+ CALL HWUROF(R,PW,PW)
+ CALL HWUMAS(PW)
+C---REORDER ENTRIES: IHEP=EMITTER, KHEP=EMITTED
+ NHEP=NHEP+1
+ IHEP=JDAHEP(2,ICMF)
+ WHEP=JDAHEP(1,ICMF)
+ KHEP=NHEP
+C---SET UP MOMENTA IN TOP REST FRAME
+ PHEP(1,ICMF)=0
+ PHEP(2,ICMF)=0
+ PHEP(3,ICMF)=0
+ PHEP(4,ICMF)=EM
+ PHEP(5,ICMF)=EM
+ PHEP(4,IHEP)=HALF*EM*(2-X(1)-X(3)+EPS-AW+EPG)
+ PHEP(4,KHEP)=HALF*EM*X(3)
+ PHEP(5,IHEP)=RMASS(ID)
+ PHEP(5,KHEP)=RMASS(ID3)
+ PHEP(3,KHEP)=HALF*EM*((X(1)+AW-EPS-EPG)*X(3)-2*(1+EPS-AW
+ $ -EPG-(2+EPS+EPG-AW-X(1)-X(3))))/HWUSQR((X(1)+AW
+ $ -EPS-EPG)**2-4*AW)
+ PHEP(3,IHEP)=-PHEP(3,KHEP)-HALF*EM
+ $ *HWUSQR((X(1)+AW-EPS-EPG)**2-4*AW)
+ PHEP(2,IHEP)=0
+ PHEP(1,KHEP)=HWUSQR(PHEP(4,KHEP)**2-PHEP(5,KHEP)**2
+ $ -PHEP(3,KHEP)**2)
+ PHEP(1,IHEP)=-PHEP(1,KHEP)
+ PHEP(2,KHEP)=0
+ CALL HWVSUM(4,PHEP(1,IHEP),PHEP(1,KHEP),PW1)
+ CALL HWVDIF(4,PHEP(1,ICMF),PW1,PW1)
+ CALL HWUMAS(PW1)
+ DO K=1,5
+ PHEP(K,WHEP)=PW1(K)
+ ENDDO
+C---ORIENT IN CMF, THEN BOOST TO LAB
+ CALL HWUROB(R,PHEP(1,ICMF),PHEP(1,ICMF))
+ CALL HWUROB(R,PHEP(1,IHEP),PHEP(1,IHEP))
+ CALL HWUROB(R,PHEP(1,WHEP),PHEP(1,WHEP))
+ CALL HWUROB(R,PHEP(1,KHEP),PHEP(1,KHEP))
+ CALL HWULOB(PT,PHEP(1,IHEP),PHEP(1,IHEP))
+ CALL HWULOB(PT,PHEP(1,KHEP),PHEP(1,KHEP))
+ CALL HWULOB(PT,PHEP(1,ICMF),PHEP(1,ICMF))
+ CALL HWULOB(PT,PHEP(1,WHEP),PHEP(1,WHEP))
+C---STATUS AND COLOUR CONNECTION
+ ISTHEP(KHEP)=114
+ IDHW(KHEP)=ID3
+ IDHEP(KHEP)=IDPDG(ID3)
+ JDAHEP(2,ICMF)=KHEP
+ JMOHEP(1,KHEP)=ICMF
+ JMOHEP(1,IHEP)=ICMF
+ JDAHEP(1,KHEP)=0
+ JMOHEP(2,IHEP)=ICMF
+ JDAHEP(2,IHEP)=KHEP
+ JMOHEP(2,KHEP)=IHEP
+ JDAHEP(2,KHEP)=ICMF
+ 999 END
+CDECK ID>, HWBVMC.
+*CMZ :- -26/04/91 11.11.54 by Bryan Webber
+*-- Author : Bryan Webber
+C-----------------------------------------------------------------------
+ FUNCTION HWBVMC(ID)
+C-----------------------------------------------------------------------
+C VIRTUAL MASS CUTOFF FOR PARTON TYPE ID
+C-----------------------------------------------------------------------
+ INCLUDE 'HERWIG61.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 'HERWIG61.INC'
+ DOUBLE PRECISION HWUPCM,HWR,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,HWR,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*HWR()**PSPLT(IB)
+ EMY= QM3+PXY*HWR()**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.HWR()) GOTO 40
+ QM4=RMASS(ID4)
+C--Now combine particles 3 & 4 into a diquark
+C--If three also heavy this diquark doesn't exist in HERWIG
+C--just assume mass is sum of quark masses,as for other diquarks
+ DQM=QM3+QM4
+C--Now obtain the masses for the cluster splitting
+ PCX=HWUPCM(EMX,QM1,DQM)
+ IF(PCX.LT.ZERO) GOTO 20
+ PCY=HWUPCM(EMY,QM2,QM4)
+ IF(PCY.LT.ZERO) GOTO 20
+ SPLIT=.TRUE.
+C--Now we've decided which light quark to pull out of the vacuum
+C--Find the direction of the second heavy quark
+ CALL HWULOF(PCL,PHEP(1,THEP),AX)
+ RCM=1./SQRT(HWVDOT(3,AX,AX))
+ CALL HWVSCA(3,RCM,AX,AX)
+C--Construct the new CoM momenta(collinear)
+ PXY=HWUPCM(EMC,EMX,EMY)
+ CALL HWVSCA(3,PXY,AX,PC)
+C--pc is momenta of Y cluster along 2nd quark dirn in cluster frame
+ PC(4)=SQRT(PXY**2+EMY**2)
+ PC(5)=EMY
+C--pa is momenta of 2nd quark in Y frame
+ CALL HWVSCA(3,PCY,AX,PA)
+ PA(4)=SQRT(PCY**2+QM3**2)
+ PA(5)=QM3
+C--pb is momenta of 2nd quark in cluster frame,pa now momenta of antiquark
+ CALL HWULOB(PC,PA,PB)
+ CALL HWVDIF(4,PC,PB,PA)
+ PA(5)=QM4
+ LHEP=NHEP+1
+ MHEP=NHEP+2
+C--boost these momenta back to lab frame
+ CALL HWULOB(PCL,PB,PHEP(1,THEP))
+ CALL HWULOB(PCL,PA,PHEP(1,MHEP))
+C--pc now becomes momenta of X cluster in cluster frame
+ CALL HWVSCA(3,-ONE,PC,PC)
+ PC(4)=EMC-PC(4)
+ PC(5)=EMX
+C--find the dirn of the 1st heavy quark in the X frame
+C--transform to cluster frame
+ CALL HWULOF(PCL,PHEP(1,JHEP),AY)
+C--transform to X-frame
+ CALL HWULOF(PC,AY,AY)
+ RCM=1./SQRT(HWVDOT(3,AY,AY))
+ CALL HWVSCA(3,RCM,AY,AY)
+C--pa now momenta of 1st havy quark along this dirn
+ CALL HWVSCA(3,PCX,AY,PA)
+ PA(4)=SQRT(PCX**2+QM1**2)
+ PA(5)=QM1
+C--pb now momenta of 1st heavy quark in cluster frame then to lab
+ CALL HWULOB(PC,PA,PB)
+ CALL HWULOB(PCL,PB,PHEP(1,JHEP))
+C--now find the diquark momenta by momentum conservation
+ DO 50 J=1,4
+ 50 PDIQUK(J)=PCL(J)-PHEP(J,THEP)-PHEP(J,MHEP)-PHEP(J,JHEP)
+ PDIQUK(5)=DQM
+C--Now obtain the quark momenta from the diquark
+ DO 60 J=1,3
+ 60 PA(J) = 0
+ PA(4) = QM2
+ PA(5) = QM2
+ CALL HWULOB(PDIQUK,PA,PHEP(1,KHEP))
+ CALL HWVDIF(4,PDIQUK,PHEP(1,KHEP),PHEP(1,LHEP))
+C--Construct new vertex positions
+ RKAPPA=GEV2MM/SKAPPA
+ CALL HWVSCA(3,RKAPPA,AX,AX)
+ DELTM=(EMX-EMY)*(EMX+EMY)/(TWO*EMC)
+ CALL HWVSCA(3,DELTM,AX,VTMP)
+ VTMP(4)=(HALF*EMC-PXY)*RKAPPA
+ CALL HWULB4(PCL,VTMP,VTMP)
+ CALL HWVSUM(4,VTMP,VCLUS,VHEP(1,LHEP))
+ CALL HWVEQU(4,VHEP(1,LHEP),VHEP(1,MHEP))
+C--Relabel the colours of the quarks
+ IDHEP(LHEP) = IDPDG(ID4)
+ IDHEP(MHEP) = IDPDG(ID4)
+ IF(IDHEP(JHEP).GT.0) THEN
+ IDHW(LHEP) = ID4+6
+ IDHEP(LHEP) = -IDHEP(LHEP)
+ IDHW(MHEP) = ID4
+ JDAHEP(2,LHEP) = JHEP
+ JMOHEP(2,LHEP) = MHEP
+ JMOHEP(2,MHEP) = JMOHEP(2,JHEP)
+ JDAHEP(2,MHEP) = LHEP
+ JMOHEP(2,JHEP) = LHEP
+ ELSE
+ IDHW(LHEP) = ID4
+ IDHW(MHEP) = ID4+6
+ IDHEP(MHEP) = -IDHEP(MHEP)
+ JMOHEP(2,LHEP) = JHEP
+ JDAHEP(2,MHEP) = JDAHEP(2,JHEP)
+ JDAHEP(2,LHEP) = MHEP
+ JMOHEP(2,MHEP) = LHEP
+ JDAHEP(2,JHEP) = LHEP
+ ENDIF
+ ISTHEP(LHEP) = 151
+ ISTHEP(MHEP) = 151
+ JMOHEP(1,LHEP) = JMOHEP(1,KHEP)
+ JDAHEP(1,LHEP) = 0
+ JMOHEP(1,MHEP) = JMOHEP(1,JHEP)
+ JDAHEP(1,MHEP) = 0
+ NHEP = NHEP+2
+ 999 END
+CDECK ID>, HWCBVI.
+*CMZ :-
+*-- Author : Mark Gibbs modified by Peter Richardson
+C-----------------------------------------------------------------------
+ SUBROUTINE HWCBVI
+C-----------------------------------------------------------------------
+C FINDS UNPAIRED PARTONS AFTER BARYON-NUMBER VIOLATION
+C MODIFIED FOR RPARITY VIOLATING SUSY
+C-----------------------------------------------------------------------
+ INCLUDE 'HERWIG61.INC'
+ COMMON/HWBVIC/NBV,IBV(18)
+ DOUBLE PRECISION HWR,PDQ(5)
+ INTEGER NBV,IBV,JBV,KBV,LBV,IHEP,IP1,IP2,IP3,JP1,JP2,JP3,
+ & HWCBVT,NBR,MBV,IQ1,IQ2,IQ3,ID1,ID2,IDQ,IDIQK(3,3)
+ LOGICAL SPLIT,DUNBV(18)
+ DATA IDIQK/111,110,113,110,109,112,113,112,114/
+C---Check for errors
+ IF (IERROR.NE.0) RETURN
+C---Correct colour connections are gluon splitting
+ CALL HWCCCC
+C---Reset bvi clustering flag
+ HVFCEN = .FALSE.
+C---LIST PARTONS WITH WRONG COLOUR PARTNERS-QUARKS ONLY
+ 5 NBV=0
+ DO 10 IHEP=1,NHEP
+ IF (ISTHEP(IHEP).GT.149.AND.ISTHEP(IHEP).LT.155) THEN
+ IF (QORQQB(IDHW(IHEP))) THEN
+ IF (.NOT.QORQQB(IDHW(JMOHEP(2,IHEP))).
+ & AND.JMOHEP(2,IHEP).GT.6) GOTO 10
+ ELSE
+C---Extra check for Gamma's
+ IF (IDHW(IHEP).EQ.59) GO TO 10
+C---End of bug fix.
+ IF (QORQQB(IDHW(JDAHEP(2,IHEP)))) GO TO 10
+ GO TO 10
+ ENDIF
+ IF(JMOHEP(2,IHEP).LT.6.AND.
+ & .NOT.QBORQQ(IDHW(JMOHEP(2,IHEP)))) GOTO 10
+C--new for hard process
+ NBV=NBV+1
+ IF (NBV.GT.18) CALL HWWARN('HWCBVI',100,*999)
+ IBV(NBV)=IHEP
+ DUNBV(NBV)=.FALSE.
+ ENDIF
+ 10 CONTINUE
+C--NOW FIND THE ANTIQUARKS WITH WRONG COLOUR CONNECTIONS
+ DO 11 IHEP=1,NHEP
+ IF(ISTHEP(IHEP).GT.149.AND.ISTHEP(IHEP).LT.155) THEN
+ IF(QBORQQ(IDHW(IHEP))) THEN
+ IF(.NOT.QBORQQ(IDHW(JDAHEP(2,IHEP))).AND.
+ & JDAHEP(2,IHEP).GT.6) GO TO 11
+ ELSE
+C--Extra check for gamma's
+ IF(IDHW(IHEP).EQ.59) GO TO 11
+ IF(QBORQQ(IDHW(JMOHEP(2,IHEP)))) GO TO 11
+ GO TO 11
+ ENDIF
+ IF(JDAHEP(2,IHEP).LT.6.AND.
+ & .NOT.QORQQB(IDHW(JDAHEP(2,IHEP)))) GOTO 11
+ NBV=NBV+1
+ IF(NBV.GT.18) CALL HWWARN('HWCBVI',100,*999)
+ IBV(NBV)=IHEP
+ DUNBV(NBV)=.FALSE.
+ ENDIF
+ 11 CONTINUE
+ IF (NBV.EQ.0) RETURN
+ IF(MOD(NBV,3).NE.0) CALL HWWARN('HWCBVI',101,*999)
+C---PROCESS FOUND PARTONS, STARTING AT RANDOM POINT IN LIST
+ NBR=NBV*HWR()
+ DO 100 MBV=1,NBV
+ JBV=MBV+NBR
+ IF (JBV.GT.NBV) JBV=JBV-NBV
+ IF (.NOT.DUNBV(JBV)) THEN
+ DUNBV(JBV)=.TRUE.
+ IP1=IBV(JBV)
+ JP1=HWCBVT(IP1)
+C---FIND ASSOCIATED PARTONS
+ DO 20 KBV=1,NBV
+ IF (.NOT.DUNBV(KBV)) THEN
+ IP2=IBV(KBV)
+ JP2=HWCBVT(IP2)
+ IF (JP2.EQ.JP1) THEN
+ DUNBV(KBV)=.TRUE.
+ DO 15 LBV=1,NBV
+ IF (.NOT.DUNBV(LBV)) THEN
+ IP3=IBV(LBV)
+ JP3=HWCBVT(IP3)
+ IF (JP3.EQ.JP2) THEN
+ DUNBV(LBV)=.TRUE.
+ GO TO 25
+ ENDIF
+ ENDIF
+ 15 CONTINUE
+ ENDIF
+ ENDIF
+ 20 CONTINUE
+ CALL HWWARN('HWCBVI',102,*999)
+ 25 IQ1=0
+C---LOOK FOR DIQUARK
+ IF (ABS(IDHEP(IP1)).GT.100) THEN
+ IQ1=IP1
+ IQ2=IP2
+ IQ3=IP3
+ ELSEIF (ABS(IDHEP(IP2)).GT.100) THEN
+ IQ1=IP2
+ IQ2=IP3
+ IQ3=IP1
+ ELSEIF (ABS(IDHEP(IP3)).GT.100) THEN
+ IQ1=IP3
+ IQ2=IP1
+ IQ3=IP2
+ ENDIF
+ IF (IQ1.EQ.0) THEN
+C---NO DIQUARKS: COMBINE TWO (ANTI)QUARKS
+ IF (ABS(IDHEP(IP1)).GT.3) THEN
+ IQ1=IP2
+ IQ2=IP3
+ IQ3=IP1
+ ELSEIF (ABS(IDHEP(IP2)).GT.3) THEN
+ IQ1=IP3
+ IQ2=IP1
+ IQ3=IP2
+ ELSE
+ IQ1=IP1
+ IQ2=IP2
+ IQ3=IP3
+ ENDIF
+ ID1=IDHEP(IQ1)
+ ID2=IDHEP(IQ2)
+C---CHECK FLAVOURS
+ IF (ID1.GT.0.AND.ID1.LT.4.AND.
+ & ID2.GT.0.AND.ID2.LT.4) THEN
+ IDQ=IDIQK(ID1,ID2)
+ ELSEIF (ID1.LT.0.AND.ID1.GT.-4.AND.
+ & ID1.LT.0.AND.ID2.GT.-4) THEN
+ IDQ=IDIQK(-ID1,-ID2)+6
+ ELSE
+C---CANT MAKE DIQUARKS WITH HEAVY QUARKS: TRY CLUSTER SPLITTING
+ CALL HWVSUM(4,PHEP(1,IQ1),PHEP(1,IQ2),PDQ)
+ CALL HWUMAS(PDQ)
+C--Use the original splitting procedure
+ CALL HWCCUT(IQ1,IQ2,PDQ,.FALSE.,SPLIT)
+ IF(SPLIT) GOTO 5
+C--If it fails try the new procedure
+ CALL HWVSUM(4,PDQ,PHEP(1,IQ3),PDQ)
+ CALL HWUMAS(PDQ)
+ IF(ABS(ID1).GT.3) THEN
+ CALL HWCBCT(IQ3,IQ2,IQ1,PDQ,SPLIT)
+ ELSEIF(ABS(ID2).GT.3) THEN
+ CALL HWCBCT(IQ3,IQ1,IQ2,PDQ,SPLIT)
+ ELSE
+ CALL HWWARN('HWCBVI',100,*999)
+ ENDIF
+ IF (SPLIT) GO TO 5
+C---Unable to form cluster; dispose of event
+ CALL HWWARN('HWCBVI',-3,*999)
+ ENDIF
+C---OVERWRITE FIRST AND CANCEL SECOND
+ IDHW(IQ1)=IDQ
+ IDHEP(IQ1)=IDPDG(IDQ)
+ CALL HWVSUM(4,PHEP(1,IQ1),PHEP(1,IQ2),PHEP(1,IQ1))
+ CALL HWUMAS(PHEP(1,IQ1))
+ ISTHEP(IQ2)=0
+C---REMAKE COLOUR CONNECTIONS
+ IF (QORQQB(IDQ)) THEN
+ JMOHEP(2,IQ1)=IQ3
+ JDAHEP(2,IQ3)=IQ1
+ ELSE
+ JDAHEP(2,IQ1)=IQ3
+ JMOHEP(2,IQ3)=IQ1
+ ENDIF
+ ELSE
+C---SPLIT A DIQUARK
+ NHEP=NHEP+1
+ CALL HWVSCA(5,HALF,PHEP(1,IQ1),PHEP(1,IQ1))
+ CALL HWVEQU(5,PHEP(1,IQ1),PHEP(1,NHEP))
+ ISTHEP(NHEP)=150
+ JMOHEP(1,NHEP)=JMOHEP(1,IQ1)
+ JDAHEP(1,NHEP)=0
+C---FIND FLAVOURS
+ IDQ=IDHW(IQ1)
+ DO 30 ID2=1,3
+ DO 30 ID1=1,3
+ IF (IDIQK(ID1,ID2).EQ.IDQ) THEN
+ IDHW(IQ1)=ID1
+ IDHW(NHEP)=ID2
+C---REMAKE COLOUR CONNECTIONS (DIQUARK)
+ JMOHEP(2,IQ1)=IQ2
+ JMOHEP(2,IQ2)=NHEP
+ JMOHEP(2,IQ3)=IQ1
+ JMOHEP(2,NHEP)=IQ3
+ JDAHEP(2,IQ1)=IQ3
+ JDAHEP(2,IQ2)=IQ1
+ JDAHEP(2,IQ3)=NHEP
+ JDAHEP(2,NHEP)=IQ2
+ GO TO 35
+ ELSEIF (IDIQK(ID1,ID2).EQ.IDQ-6) THEN
+ IDHW(IQ1)=ID1+6
+ IDHW(NHEP)=ID2+6
+C---REMAKE COLOUR CONNECTIONS (ANTIDIQUARK)
+ JMOHEP(2,IQ1)=IQ3
+ JMOHEP(2,IQ2)=IQ1
+ JMOHEP(2,IQ3)=NHEP
+ JMOHEP(2,NHEP)=IQ2
+ JDAHEP(2,IQ1)=IQ2
+ JDAHEP(2,IQ2)=NHEP
+ JDAHEP(2,IQ3)=IQ1
+ JDAHEP(2,NHEP)=IQ3
+ GO TO 35
+ ENDIF
+ 30 CONTINUE
+ CALL HWWARN('HWCBVI',104,*999)
+ 35 IDHEP(IQ1)=IDPDG(IDHW(IQ1))
+ IDHEP(NHEP)=IDPDG(IDHW(NHEP))
+ ENDIF
+ ENDIF
+ 100 CONTINUE
+ RETURN
+ 999 END
+CDECK ID>, HWCBVT.
+*CMZ :-
+*-- Author : Peter Richardson
+C-----------------------------------------------------------------------
+ FUNCTION HWCBVT(IP)
+C-----------------------------------------------------------------------
+C Function to find the baryon number violating vertex a parton came from
+C-----------------------------------------------------------------------
+ INCLUDE 'HERWIG61.INC'
+ INTEGER HWCBVT,IP,JP(2),KP,I,J,ID,TYPE,IDM,IDM2,IDM3,IDM4
+ JP(1) = IP
+ ID = IDHW(IP)
+ IF(ID.LE.6.OR.(ID.GE.115.AND.ID.LE.120)) THEN
+ JP(2) = JMOHEP(2,IP)
+ ELSE
+ JP(2) = JDAHEP(2,IP)
+ ENDIF
+ DO I=1,2
+ IDM = JMOHEP(1,JMOHEP(1,JMOHEP(1,JMOHEP(1,JP(I)))))
+ IF(IDHW(IDM).EQ.6.OR.IDHW(IDM).EQ.12) THEN
+ JP(I)=IDM
+ ENDIF
+ ENDDO
+ DO J=1,7
+ DO I=1,2
+ KP = JMOHEP(1,JP(I))
+ IDM = IDHW(KP)
+ IDM2 = IDHW(JDAHEP(1,KP))
+ IDM3 = IDHW(JDAHEP(2,KP))
+ IDM4 = IDHW(JDAHEP(1,KP)+1)
+ IF((ISTHEP(KP).EQ.155.AND.
+ & ((IDM.GE.449.AND.IDM.LE.457.AND.IDM2.LE.12.AND.
+ & IDM3.LE.12.AND.IDM4.LE.12).OR.
+ & (((IDM.GE.411.AND.IDM.LE.424).OR.IDM.EQ.405.OR.IDM.EQ.406)
+ & .AND.IDM2.LE.12.AND.IDM3.LE.12)))
+ & .OR.(IDM.EQ.15.AND.IDM2.LE.12.AND.
+ & IDHW(JMOHEP(1,KP)).LE.12.AND.
+ & IDHW(JMOHEP(2,KP)).LE.12.AND.IDM3.GE.449.AND.
+ & IDM3.LE.457).OR.
+ & (IDM.EQ.15.AND.IDM2.GE.198.AND.IDM2.LE.200.
+ & AND.ABS(IDPDG(IDM3)).GT.1000000)) THEN
+ IF(IDHW(KP).EQ.449.AND.JDAHEP(1,KP).EQ.JP(I)) THEN
+ KP = JMOHEP(1,KP)
+ ELSEIF(IDHW(KP).EQ.15) THEN
+ TYPE=IDHW(JDAHEP(1,KP))
+ IF(TYPE.GE.7.AND.TYPE.LE.12.AND.
+ & JMOHEP(2,JDAHEP(2,KP)).EQ.JP(I)) THEN
+ KP=IP
+ ELSEIF(TYPE.LE.6.AND.
+ & JDAHEP(2,JDAHEP(2,KP)).EQ.JP(I)) THEN
+ KP=IP
+ ELSE
+ HWCBVT = KP
+ RETURN
+ ENDIF
+ ELSE
+ HWCBVT = KP
+ RETURN
+ ENDIF
+ ENDIF
+ JP(I) =KP
+ ENDDO
+ ENDDO
+ HWCBVT = 0
+ 999 END
+CDECK ID>, HWCCCC.
+*CMZ :-
+*-- Author : Peter Richardson
+C-----------------------------------------------------------------------
+ SUBROUTINE HWCCCC
+C-----------------------------------------------------------------------
+C Subroutine to correct colour connections after the gluon splitting
+C-----------------------------------------------------------------------
+ INCLUDE 'HERWIG61.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 'HERWIG61.INC'
+ DOUBLE PRECISION HWREXQ,HWUPCM,HWR,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,HWR,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*HWR()**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*HWR()**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*HWR()**PSPLT(IB)
+ EMY=QM2+PXY*HWR()**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.HWR()) GOTO 40
+ QM3=RMASS(ID3)
+ PCX=HWUPCM(EMX,QM1,QM3)
+ IF (PCX.LT.ZERO) GOTO 20
+ PCY=HWUPCM(EMY,QM2,QM3)
+ IF (PCY.LT.ZERO) GOTO 20
+ SPLIT=.TRUE.
+ ENDIF
+C Boost antiquark to CoM frame to find axis
+ CALL HWULOF(PCL,PHEP(1,KHEP),AX)
+ RCM=1./SQRT(HWVDOT(3,AX,AX))
+ CALL HWVSCA(3,RCM,AX,AX)
+C Construct new CoM momenta (collinear)
+ PXY=HWUPCM(EMC,EMX,EMY)
+ CALL HWVSCA(3,PXY,AX,PC)
+ PC(4)=SQRT(PXY**2+EMY**2)
+ PC(5)=EMY
+ CALL HWVSCA(3,PCY,AX,PA)
+ PA(4)=SQRT(PCY**2+QM2**2)
+ PA(5)=QM2
+ CALL HWULOB(PC,PA,PB)
+ CALL HWVDIF(4,PC,PB,PA)
+ PA(5)=QM3
+ LHEP=NHEP+1
+ MHEP=NHEP+2
+ CALL HWULOB(PCL,PB,PHEP(1,KHEP))
+ CALL HWULOB(PCL,PA,PHEP(1,MHEP))
+ CALL HWVSCA(3,-ONE,PC,PC)
+ PC(4)=EMC-PC(4)
+ PC(5)=EMX
+ CALL HWVSCA(3,PCX,AX,PA)
+ PA(4)=SQRT(PCX**2+QM3**2)
+ CALL HWULOB(PC,PA,PB)
+ CALL HWULOB(PCL,PB,PHEP(1,LHEP))
+ DO 50 J=1,4
+ 50 PHEP(J,JHEP)=PCL(J)-PHEP(J,KHEP)-PHEP(J,LHEP)-PHEP(J,MHEP)
+ PHEP(5,JHEP)=QM1
+ CALL HWVEQU(4,VHEP(1,LHEP),VHEP(1,MHEP))
+C Construct new vertex positions
+ RKAPPA=GEV2MM/SKAPPA
+ CALL HWVSCA(3,RKAPPA,AX,AX)
+ DELTM=(EMX-EMY)*(EMX+EMY)/(TWO*EMC)
+ CALL HWVSCA(3,DELTM,AX,VTMP)
+ VTMP(4)=(HALF*EMC-PXY)*RKAPPA
+ CALL HWULB4(PCL,VTMP,VTMP)
+ CALL HWVSUM(4,VTMP,VCLUS(1,JHEP),VHEP(1,LHEP))
+ CALL HWVEQU(4,VHEP(1,LHEP),VHEP(1,MHEP))
+ VSCA=0.25*EMC+HALF*(PXY+DELTM)
+ CALL HWVSCA(3,VSCA,AX,VTMP)
+ VTMP(4)=(EMC-VSCA)*RKAPPA
+ CALL HWULB4(PCL,VTMP,VTMP)
+ CALL HWVSUM(4,VTMP,VCLUS(1,JHEP),VCLUS(1,MHEP))
+ VSCA=-0.25*EMC+HALF*(DELTM-PXY)
+ CALL HWVSCA(3,VSCA,AX,VTMP)
+ VTMP(4)=(EMC+VSCA)*RKAPPA
+ CALL HWULB4(PCL,VTMP,VTMP)
+ CALL HWVSUM(4,VTMP,VCLUS(1,JHEP),VCLUS(1,JHEP))
+C (Re-)label quarks
+ IDHW(LHEP)=ID3+6
+ IDHW(MHEP)=ID3
+ IDHEP(MHEP)= IDPDG(ID3)
+ IDHEP(LHEP)=-IDPDG(ID3)
+ ISTHEP(LHEP)=151
+ ISTHEP(MHEP)=151
+ JMOHEP(2,JHEP)=LHEP
+ JDAHEP(2,KHEP)=MHEP
+ JMOHEP(1,LHEP)=JMOHEP(1,KHEP)
+ JMOHEP(2,LHEP)=MHEP
+ JDAHEP(1,LHEP)=0
+ JDAHEP(2,LHEP)=JHEP
+ JMOHEP(1,MHEP)=JMOHEP(1,JHEP)
+ JMOHEP(2,MHEP)=KHEP
+ JDAHEP(1,MHEP)=0
+ JDAHEP(2,MHEP)=LHEP
+ NHEP=NHEP+2
+ 999 END
+CDECK ID>, HWCDEC.
+*CMZ :- -26/04/91 10.18.56 by Bryan Webber
+*-- Author : Bryan Webber
+C-----------------------------------------------------------------------
+ SUBROUTINE HWCDEC
+C-----------------------------------------------------------------------
+C DECAYS CLUSTERS INTO PRIMARY HADRONS
+C-----------------------------------------------------------------------
+ INCLUDE 'HERWIG61.INC'
+ INTEGER JCL,KCL,IP,JP,KP,IST,ID1,ID2,ID3
+ IF (IERROR.NE.0) RETURN
+ IF (IPROC/1000.EQ.9.OR.IPROC/1000.EQ.5) THEN
+C---RELABEL CLUSTER CONNECTED TO REMNANT IN DIS
+ DO 10 JCL=2,NHEP
+ IF (ISTHEP(JCL).EQ.164) GOTO 20
+ IF (ISTHEP(JCL).EQ.165) THEN
+ IP=JMOHEP(1,JCL)
+ JP=JMOHEP(2,JCL)
+ KP=IP
+ IF (ISTHEP(IP).EQ.162) THEN
+ KP=JP
+ JP=IP
+ ENDIF
+ IF (JMOHEP(2,KP).NE.JP) THEN
+ IP=JMOHEP(2,KP)
+ ELSE
+ IP=JDAHEP(2,KP)
+ ENDIF
+ KCL=JDAHEP(1,IP)
+ IF (ISTHEP(KCL)/10.NE.16) CALL HWWARN('HWCDEC',100,*999)
+ ISTHEP(KCL)=164
+ GOTO 20
+ ENDIF
+ 10 CONTINUE
+ ENDIF
+ 20 CONTINUE
+ DO 30 JCL=1,NHEP
+ IST=ISTHEP(JCL)
+ IF (IST.GT.162.AND.IST.LT.166) THEN
+C---DON'T HADRONIZE BEAM/TARGET CLUSTERS
+ IF (IST.EQ.163.OR..NOT.GENSOF) THEN
+C---SET UP FLAVOURS FOR CLUSTER DECAY
+ CALL HWCFLA(IDHW(JMOHEP(1,JCL)),IDHW(JMOHEP(2,JCL)),ID1,ID3)
+ CALL HWCHAD(JCL,ID1,ID3,ID2)
+ ENDIF
+ ENDIF
+ 30 CONTINUE
+ ISTAT=50
+ 999 END
+CDECK ID>, HWCFLA.
+*CMZ :- -26/04/91 10.18.56 by Bryan Webber
+*-- Author : Bryan Webber
+C-----------------------------------------------------------------------
+ SUBROUTINE HWCFLA(JD1,JD2,ID1,ID2)
+C-----------------------------------------------------------------------
+C SETS UP FLAVOURS FOR CLUSTER DECAY
+C-----------------------------------------------------------------------
+ INTEGER JD1,JD2,ID1,ID2,JD,JDEC(12)
+ DATA JDEC/1,2,3,10,11,12,4,5,6,7,8,9/
+ JD=JD1
+ IF (JD.GT.12) JD=JD-108
+ ID1=JDEC(JD)
+ JD=JD2
+ IF (JD.GT.12) JD=JD-96
+ ID2=JDEC(JD-6)
+ END
+CDECK ID>, HWCFOR.
+*CMZ :- -26/04/91 14.15.56 by Federico Carminati
+*-- Author : Bryan Webber
+C-----------------------------------------------------------------------
+ SUBROUTINE HWCFOR
+C-----------------------------------------------------------------------
+C Converts colour-connected quark-antiquark pairs into clusters
+C Modified by IGK to include BRW's colour rearrangement and
+C MHS's cluster vertices
+C MODIFIED 16/10/97 BY BRW FOR SUSY PROCESSES
+C-----------------------------------------------------------------------
+ INCLUDE 'HERWIG61.INC'
+ DOUBLE PRECISION HWULDO,HWVDOT,HWR,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,HWR,HWUPCM,HWRINT
+ COMMON/HWCFRM/VCLUS(4,NMXHEP)
+ DATA MAP/1,2,3,4,5,6,1,2,3,4,5,6,96*0,7,8,9,10,11,12,7,8,9,10,11,
+ & 12/
+ IF (IERROR.NE.0) RETURN
+C Split gluons
+ CALL HWCGSP
+C Find colour partners after baryon number violating event
+ IF (HVFCEN) THEN
+ IF(RPARTY) THEN
+ CALL HVCBVI
+ ELSE
+ CALL HWCBVI
+ ENDIF
+ ENDIF
+ IF (IERROR.NE.0) RETURN
+C Look for partons to cluster
+ DO 10 IBHEP=1,NHEP
+ 10 IF (ISTHEP(IBHEP).GE.150.AND.ISTHEP(IBHEP).LE.154) GOTO 20
+ IBCL=1
+ GOTO 130
+ 20 CONTINUE
+C--Final check for colour disconnections
+ DO 25 JHEP=IBHEP,NHEP
+ IF (ISTHEP(JHEP).GE.150.AND.ISTHEP(JHEP).LE.154.AND.
+ & QORQQB(IDHW(JHEP))) THEN
+ KHEP=JMOHEP(2,JHEP)
+C BRW FIX 13/03/99
+ IF (KHEP.EQ.0.OR..NOT.(
+ & ISTHEP(KHEP).GE.150.AND.ISTHEP(KHEP).LE.154.AND.
+ & QBORQQ(IDHW(KHEP)))) THEN
+ DO KHEP=IBHEP,NHEP
+ IF (ISTHEP(KHEP).GE.150.AND.ISTHEP(KHEP).LE.154
+ & .AND.QBORQQ(IDHW(KHEP))) THEN
+ LHEP=JDAHEP(2,KHEP)
+ IF (LHEP.EQ.0.OR..NOT.(
+ & ISTHEP(LHEP).GE.150.AND.ISTHEP(LHEP).LE.154.AND.
+ & QORQQB(IDHW(LHEP)))) THEN
+ JMOHEP(2,JHEP)=KHEP
+ JDAHEP(2,KHEP)=JHEP
+ GOTO 25
+ ENDIF
+ ENDIF
+ ENDDO
+C END FIX
+ CALL HWWARN('HWCFOR',100,*999)
+ ENDIF
+ ENDIF
+ 25 CONTINUE
+ IF (CLRECO) THEN
+C Allow for colour rearrangement of primary clusters
+ NRECO=0
+C Randomize starting point
+ JBHEP=HWRINT(IBHEP,NHEP)
+ JHEP=JBHEP
+ 30 JHEP=JHEP+1
+ IF (JHEP.GT.NHEP) JHEP=IBHEP
+ IF (ISTHEP(JHEP).GE.150.AND.ISTHEP(JHEP).LE.154.AND.
+ & QORQQB(IDHW(JHEP))) THEN
+C Find colour connected antiquark or diquark
+ KHEP=JMOHEP(2,JHEP)
+C Find partner antiquark or diquark
+ LHEP=JDAHEP(2,JHEP)
+C Find closest antiquark or diquark
+ DCL0=1.D15
+ LCL=0
+ DO 40 IHEP=IBHEP,NHEP
+ IF (ISTHEP(IHEP).GE.150.AND.ISTHEP(IHEP).LE.154.AND.
+ & QBORQQ(IDHW(IHEP))) THEN
+C Check whether already reconnected
+ IF (JDAHEP(2,IHEP).GT.0.AND.IHEP.NE.LHEP) THEN
+ CALL HWVDIF(4,VHEP(1,IHEP),VHEP(1,JHEP),DCL)
+ DCL1=ABS(HWULDO(DCL,DCL))
+ IF (DCL1.LT.DCL0) THEN
+ DCL0=DCL1
+ LCL=IHEP
+ ENDIF
+ ENDIF
+ ENDIF
+ 40 CONTINUE
+ IF (LCL.NE.0.AND.LCL.NE.KHEP) THEN
+ MCL=JDAHEP(2,LCL)
+ IF (JDAHEP(2,MCL).NE.KHEP) THEN
+C Pairwise reconnection is possible
+ CALL HWVDIF(4,VHEP(1,KHEP),VHEP(1,MCL ),DCL)
+ DCL0=DCL0+ABS(HWULDO(DCL,DCL))
+ CALL HWVDIF(4,VHEP(1,JHEP),VHEP(1,KHEP),DCL)
+ DCL1=ABS(HWULDO(DCL,DCL))
+ CALL HWVDIF(4,VHEP(1,LCL ),VHEP(1,MCL ),DCL)
+ DCL1=DCL1+ABS(HWULDO(DCL,DCL))
+ IF (DCL0.LT.DCL1.AND.HWRLOG(PRECO)) THEN
+C Reconnection occurs
+ JMOHEP(2,JHEP)= LCL
+ JDAHEP(2,LCL )=-JHEP
+ JMOHEP(2,MCL) = KHEP
+ JDAHEP(2,KHEP)=-MCL
+ NRECO=NRECO+1
+ ENDIF
+ ENDIF
+ ENDIF
+ ENDIF
+ IF (JHEP.NE.JBHEP) GOTO 30
+ IF (NRECO.NE.0) THEN
+ DO 50 IHEP=IBHEP,NHEP
+ 50 JDAHEP(2,IHEP)=ABS(JDAHEP(2,IHEP))
+ ENDIF
+ ENDIF
+C Find (adjusted) cluster positions using MHS prescription
+ DFAC=10
+ DMAX=1D-10
+ DO 70 JHEP=IBHEP,NHEP
+ IF (ISTHEP(JHEP).GE.150.AND.ISTHEP(JHEP).LE.154.AND.
+ & QORQQB(IDHW(JHEP))) THEN
+ KHEP=JMOHEP(2,JHEP)
+ CALL HWUDKL(IDHW(JHEP),PHEP(1,JHEP),DISP1)
+ CALL HWVSCA(4,DFAC,DISP1,DISP1)
+ CALL HWUDKL(IDHW(KHEP),PHEP(1,KHEP),DISP2)
+ CALL HWVSCA(4,DFAC,DISP2,DISP2)
+C Rescale the lengths of DISP1,DISP2 if too long
+ DOT1=HWVDOT(3,DISP1,DISP1)
+ DOT2=HWVDOT(3,DISP2,DISP2)
+ IF (MAX(DOT1,DOT2).GT.DMAX**2) THEN
+ CALL HWVSCA(4,DMAX/SQRT(DOT1),DISP1,DISP1)
+ CALL HWVSCA(4,DMAX/SQRT(DOT2),DISP2,DISP2)
+ ENDIF
+ CALL HWVSUM(4,PHEP(1,JHEP),PHEP(1,KHEP),PCL)
+ DOT1=HWVDOT(3,DISP1,PCL)
+ DOT2=HWVDOT(3,DISP2,PCL)
+C If PCL > 90^o from either quark, use a vector which isn't
+ IF (DOT1.LE.ZERO.OR. DOT2.LE.ZERO) THEN
+ CALL HWVSUM(4,DISP1,DISP2,PCL)
+ DOT1=HWVDOT(3,DISP1,PCL)
+ DOT2=HWVDOT(3,DISP2,PCL)
+ ENDIF
+C If vectors are exactly opposite each other this method cannot work
+ IF (DOT1.EQ.ZERO.OR.DOT2.EQ.ZERO) THEN
+C So use midpoint of quark constituents
+ CALL HWVSUM(4,VHEP(1,JHEP),VHEP(1,KHEP),VCLUS(1,JHEP))
+ CALL HWVSCA(4,HALF,VCLUS(1,JHEP),VCLUS(1,JHEP))
+ GOTO 70
+ ENDIF
+C Rescale DISP1 or DISP2 to give equal components in the PCL direction
+ FAC=DOT1/DOT2
+ IF (FAC.GT.ONE) THEN
+ CALL HWVSCA(4, FAC,DISP2,DISP2)
+ DOT2=DOT1
+ ELSE
+ CALL HWVSCA(4,ONE/FAC,DISP1,DISP1)
+ DOT1=DOT2
+ ENDIF
+C Shift VHEP(1,JHEP) or VHEP(1,KHEP) s.t. their line is perp to PCL
+ FAC=(HWVDOT(3,PCL,VHEP(1,KHEP))
+ & -HWVDOT(3,PCL,VHEP(1,JHEP)))/DOT1
+ SCA1=MAX(ONE,ONE+FAC)
+ SCA2=MAX(ONE,ONE-FAC)
+ DO 60 I=1,4
+ 60 VCLUS(I,JHEP)=.5*(VHEP(I,JHEP)+VHEP(I,KHEP)
+ & +SCA1*DISP1(I)+SCA2*DISP2(I))
+ ENDIF
+ 70 CONTINUE
+C First chop up beam/target clusters
+ DO 80 JHEP=IBHEP,NHEP
+ KHEP=JMOHEP(2,JHEP)
+ ISTJ=ISTHEP(JHEP)
+ ISTK=ISTHEP(KHEP)
+C--PR MOD here 8/7/99
+ IF (QORQQB(IDHW(JHEP)).AND.
+ & (((ISTJ.EQ.153.OR.ISTJ.EQ.154).AND.ISTK.NE.151.AND.ISTK.NE.0)
+ & .OR.((ISTK.EQ.153.OR.ISTK.EQ.154).
+ & AND.ISTJ.NE.151.AND.ISTJ.NE.0))) THEN
+C--end
+ CALL HWVSUM(4,PHEP(1,JHEP),PHEP(1,KHEP),PCL)
+ CALL HWUMAS(PCL)
+ CALL HWCCUT(JHEP,KHEP,PCL,.TRUE.,SPLIT)
+ ENDIF
+ 80 CONTINUE
+C Second chop up massive pairs
+ DO 100 JHEP=IBHEP,NMXHEP
+ IF (JHEP.GT.NHEP) GOTO 110
+ IF (ISTHEP(JHEP).GE.150.AND.ISTHEP(JHEP).LE.154.AND.
+ & QORQQB(IDHW(JHEP))) THEN
+ 90 KHEP=JMOHEP(2,JHEP)
+ CALL HWVSUM(4,PHEP(1,JHEP),PHEP(1,KHEP),PCL)
+ CALL HWUMAS(PCL)
+ IF (PCL(5).GT.CTHRPW(MAP(IDHW(JHEP)),MAP(IDHW(KHEP)))) THEN
+ CALL HWCCUT(JHEP,KHEP,PCL,.FALSE.,SPLIT)
+ IF (SPLIT) GOTO 90
+ ENDIF
+ ENDIF
+ 100 CONTINUE
+C Third create clusters and store production vertex
+ 110 IBCL=NHEP+1
+ JCL=NHEP
+ DO 120 JHEP=IBHEP,NHEP
+ IF (ISTHEP(JHEP).GE.150.AND.ISTHEP(JHEP).LE.154.AND.
+ & QORQQB(IDHW(JHEP))) THEN
+ JCL=JCL+1
+ IF(JCL.GT.NMXHEP) CALL HWWARN('HWCFOR',105,*999)
+ IDHW(JCL)=19
+ IDHEP(JCL)=91
+ KHEP=JMOHEP(2,JHEP)
+ IF (KHEP.EQ.0.OR..NOT.(
+ & ISTHEP(KHEP).GE.150.AND.ISTHEP(KHEP).LE.154.AND.
+ & QBORQQ(IDHW(KHEP)))) CALL HWWARN('HWCFOR',104,*999)
+ CALL HWVSUM(4,PHEP(1,JHEP),PHEP(1,KHEP),PHEP(1,JCL))
+ CALL HWUMAS(PHEP(1,JCL))
+ IF (ISTHEP(JHEP).EQ.153.OR.ISTHEP(KHEP).EQ.153) THEN
+ ISTHEP(JCL)=164
+ ELSEIF (ISTHEP(JHEP).EQ.154.OR.ISTHEP(KHEP).EQ.154) THEN
+ ISTHEP(JCL)=165
+ ELSE
+ ISTHEP(JCL)=163
+ ENDIF
+ JMOHEP(1,JCL)=JHEP
+ JMOHEP(2,JCL)=KHEP
+ JDAHEP(1,JCL)=0
+ JDAHEP(2,JCL)=0
+ JDAHEP(1,JHEP)=JCL
+ JDAHEP(1,KHEP)=JCL
+ ISTHEP(JHEP)=ISTHEP(JHEP)+8
+ ISTHEP(KHEP)=ISTHEP(KHEP)+8
+ CALL HWVEQU(4,VCLUS(1,JHEP),VHEP(1,JCL))
+ ENDIF
+ 120 CONTINUE
+ NHEP=JCL
+C Fix up momenta for single-hadron clusters
+ 130 DO 150 JCL=IBCL,NHEP
+C Don't hadronize beam/target clusters
+ IF (ISTHEP(JCL).LT.163.OR.ISTHEP(JCL).GT.165) GOTO 150
+ IF (ISTHEP(JCL).NE.163.AND.GENSOF) GOTO 150
+C Set up flavours for cluster decay
+ CALL HWCFLA(IDHW(JMOHEP(1,JCL)),IDHW(JMOHEP(2,JCL)),ID1,ID3)
+ EM0=PHEP(5,JCL)
+ IF ((B1LIM.EQ.ZERO).OR.(ID1.NE.11.AND.ID3.NE.11)) THEN
+ IF (EM0.GT.RMIN(ID1,2)+RMIN(2,ID3)) GOTO 150
+ ELSE
+C Special for b clusters: allow 1-hadron decay above threshold
+ IF (B1LIM*HWR().LT.EM0/(RMIN(ID1,2)+RMIN(2,ID3))-1.)
+ & GOTO 150
+ ENDIF
+ EM1=RMIN(ID1,ID3)
+ IF (ABS(EM0-EM1).LT.1.D-5) GOTO 150
+C Decide to go backward or forward to transfer 4-momentum
+ L=1-TWO*INT(HALF+HWR())
+ MCL=NHEP-IBCL+1
+ LCL=JCL
+ DO 140 I=1,MCL
+ LCL=LCL+L
+ IF (LCL.LT.IBCL) LCL=LCL+MCL
+ IF (LCL.GT.NHEP) LCL=LCL-MCL
+ IF (LCL.EQ.JCL) THEN
+ IF (EM0.GE.EM1+RMIN(1,1)) GOTO 150
+ CALL HWWARN('HWCFOR',101,*999)
+ ENDIF
+ IF (ISTHEP(LCL).LT.163.OR.ISTHEP(LCL).GT.165) GOTO 140
+C Rescale momenta in 2-cluster CoM
+ CALL HWVSUM(4,PHEP(1,JCL),PHEP(1,LCL),PCL)
+ CALL HWUMAS(PCL)
+ EM2=PHEP(5,LCL)
+ PC0=HWUPCM(PCL(5),EM0,EM2)
+ PC1=HWUPCM(PCL(5),EM1,EM2)
+ IF (PC1.LT.ZERO) THEN
+C Need to rescale other mass as well
+ CALL HWCFLA(IDHW(JMOHEP(1,LCL)),IDHW(JMOHEP(2,LCL)),ID1,ID3)
+ EM2=RMIN(ID1,ID3)
+ PC1=HWUPCM(PCL(5),EM1,EM2)
+ IF (PC1.LT.ZERO) GOTO 140
+ PHEP(5,LCL)=EM2
+ ENDIF
+ IF (PC0.GT.ZERO) THEN
+ PC0=PC1/PC0
+ CALL HWULOF(PCL,PHEP(1,JCL),PHEP(1,JCL))
+ CALL HWVSCA(3,PC0,PHEP(1,JCL),PHEP(1,JCL))
+ PHEP(4,JCL)=SQRT(PC1**2+EM1**2)
+ PHEP(5,JCL)=EM1
+ CALL HWULOB(PCL,PHEP(1,JCL),PHEP(1,JCL))
+ CALL HWVDIF(4,PCL,PHEP(1,JCL),PHEP(1,LCL))
+ GOTO 150
+ ELSEIF (PC0.EQ.ZERO) THEN
+ PHEP(5,JCL)=EM1
+ CALL HWDTWO(PCL,PHEP(1,JCL),PHEP(1,LCL),PC1,TWO,.TRUE.)
+ GOTO 150
+ ELSE
+ CALL HWWARN('HWCFOR',102,*999)
+ ENDIF
+ 140 CONTINUE
+ CALL HWWARN('HWCFOR',103,*999)
+ 150 CONTINUE
+ ISTAT=60
+C Non-partons labelled as partons (ie photons) should get copied
+ DO 160 IHEP=1,NHEP
+ IF (ISTHEP(IHEP).EQ.150) THEN
+ NHEP=NHEP+1
+ JDAHEP(1,IHEP)=NHEP
+ ISTHEP(IHEP)=157
+ ISTHEP(NHEP)=190
+ IDHW(NHEP)=IDHW(IHEP)
+ IDHEP(NHEP)=IDPDG(IDHW(IHEP))
+ CALL HWVEQU(5,PHEP(1,IHEP),PHEP(1,NHEP))
+ CALL HWVEQU(4,VHEP(1,IHEP),VHEP(1,NHEP))
+ JMOHEP(1,NHEP)=IHEP
+ JMOHEP(2,NHEP)=JMOHEP(1,IHEP)
+ JDAHEP(1,NHEP)=0
+ JDAHEP(2,NHEP)=0
+ ENDIF
+ 160 CONTINUE
+ 999 END
+CDECK ID>, HWCGSP.
+*CMZ :- -13/07/92 20.15.54 by Mike Seymour
+*-- Author : Bryan Webber
+C-----------------------------------------------------------------------
+ SUBROUTINE HWCGSP
+C-----------------------------------------------------------------------
+C SPLITS ANY TIMELIKE GLUONS REMAINING AFTER PERTURBATIVE
+C BRANCHING INTO LIGHT (I.E. U OR D) Q-QBAR PAIRS
+C-----------------------------------------------------------------------
+ INCLUDE 'HERWIG61.INC'
+ DOUBLE PRECISION HWR,PF
+ INTEGER HWRINT,IHEP,JHEP,KHEP,LHEP,MHEP,ID,J,IST
+ EXTERNAL HWR,HWRINT
+ IF (NGSPL.EQ.0) CALL HWWARN('HWCGSP',400,*999)
+ LHEP=NHEP-1
+ MHEP=NHEP
+ DO 100 IHEP=1,NHEP
+ IF (ISTHEP(IHEP).GE.147.AND.ISTHEP(IHEP).LE.149) THEN
+ JHEP=JMOHEP(2,IHEP)
+C BRW FIX 12/03/99
+ IF (JHEP.LE.0) THEN
+ KHEP=0
+ DO JHEP=1,NHEP
+ IF (ISTHEP(JHEP).GE.147.AND.ISTHEP(JHEP).LE.149
+ & .AND.JDAHEP(2,JHEP).LE.0) THEN
+ KHEP=KHEP+1
+ JMOHEP(2,IHEP)=JHEP
+ JDAHEP(2,JHEP)=IHEP
+ ENDIF
+ ENDDO
+ IF (KHEP.EQ.0) CALL HWWARN('HWCGSP',102,*999)
+ IF (KHEP.NE.1) CALL HWWARN('HWCGSP',103,*999)
+ ENDIF
+C END FIX
+C---CHECK FOR DECAYED HEAVY ANTIQUARKS
+ IF (ISTHEP(JHEP).EQ.155) THEN
+ JHEP=JDAHEP(1,JDAHEP(2,JHEP))
+ DO 10 J=JDAHEP(1,JHEP),JDAHEP(2,JHEP)
+ 10 IF (ISTHEP(J).EQ.149.AND.JDAHEP(2,J).EQ.0) GOTO 20
+ CALL HWWARN('HWCGSP',100,*999)
+ 20 JHEP=J
+ ENDIF
+ KHEP=JDAHEP(2,IHEP)
+C BRW FIX 12/03/99
+ IF (KHEP.LE.0) THEN
+ KHEP=0
+ DO JHEP=1,NHEP
+ IF (ISTHEP(JHEP).GE.147.AND.ISTHEP(JHEP).LE.149
+ & .AND.JMOHEP(2,JHEP).LE.0) THEN
+ KHEP=KHEP+1
+ JDAHEP(2,IHEP)=JHEP
+ JMOHEP(2,JHEP)=IHEP
+ ENDIF
+ ENDDO
+ IF (KHEP.EQ.0) CALL HWWARN('HWCGSP',104,*999)
+ IF (KHEP.NE.1) CALL HWWARN('HWCGSP',105,*999)
+ KHEP=JDAHEP(2,IHEP)
+ ENDIF
+C END FIX
+C---CHECK FOR DECAYED HEAVY QUARKS
+ IF (ISTHEP(KHEP).EQ.155) CALL HWWARN('HWCGSP',101,*999)
+ IF (IDHW(IHEP).EQ.13) THEN
+C---SPLIT A GLUON
+ LHEP=LHEP+2
+ MHEP=MHEP+2
+ IF(MHEP.GT.NMXHEP) CALL HWWARN('HWCGSP',106,*999)
+ 30 ID=HWRINT(1,NGSPL)
+ IF (PGSPL(ID).LT.PGSMX*HWR()) 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=HWR()
+ CALL HWVSCA(4,PF,PHEP(1,IHEP),PHEP(1,LHEP))
+ CALL HWVDIF(4,PHEP(1,IHEP),PHEP(1,LHEP),PHEP(1,MHEP))
+ PHEP(5,LHEP)=PF*PHEP(5,IHEP)
+ PHEP(5,MHEP)=PHEP(5,IHEP)-PHEP(5,LHEP)
+ ENDIF
+ CALL HWUDKL(13,PHEP(1,IHEP),VHEP(1,LHEP))
+ CALL HWVSUM(4,VHEP(1,IHEP),VHEP(1,LHEP),VHEP(1,LHEP))
+ CALL HWVEQU(4,VHEP(1,LHEP),VHEP(1,MHEP))
+ IDHW(LHEP)=ID+6
+ IDHW(MHEP)=ID
+ IDHEP(MHEP)= IDPDG(ID)
+ IDHEP(LHEP)=-IDPDG(ID)
+ ISTHEP(IHEP)=2
+ ISTHEP(LHEP)=150
+ ISTHEP(MHEP)=150
+C---NEW COLOUR CONNECTIONS
+ IF(RPARTY.OR.JMOHEP(2,KHEP).EQ.IHEP) JMOHEP(2,KHEP)=LHEP
+ IF(RPARTY.OR.JDAHEP(2,JHEP).EQ.IHEP) JDAHEP(2,JHEP)=MHEP
+ JMOHEP(1,LHEP)=JMOHEP(1,IHEP)
+ JMOHEP(2,LHEP)=MHEP
+ JMOHEP(1,MHEP)=JMOHEP(1,IHEP)
+ JMOHEP(2,MHEP)=JHEP
+ JDAHEP(1,LHEP)=0
+ JDAHEP(2,LHEP)=KHEP
+ JDAHEP(1,MHEP)=0
+ JDAHEP(2,MHEP)=LHEP
+ JDAHEP(1,IHEP)=LHEP
+ JDAHEP(2,IHEP)=MHEP
+ ELSE
+C---COPY A NON-GLUON
+ LHEP=LHEP+1
+ MHEP=MHEP+1
+ IF(MHEP.GT.NMXHEP) CALL HWWARN('HWCGSP',107,*999)
+ CALL HWVEQU(5,PHEP(1,IHEP),PHEP(1,MHEP))
+ CALL HWVEQU(4,VHEP(1,IHEP),VHEP(1,MHEP))
+ IDHW(MHEP)=IDHW(IHEP)
+ IDHEP(MHEP)=IDHEP(IHEP)
+ IST=ISTHEP(IHEP)
+ ISTHEP(IHEP)=2
+ IF (IST.EQ.149) THEN
+ ISTHEP(MHEP)=150
+ ELSE
+ ISTHEP(MHEP)=IST+6
+ ENDIF
+C---NEW COLOUR CONNECTIONS
+ IF(RPARTY.OR.JMOHEP(2,KHEP).EQ.IHEP)
+ & JMOHEP(2,KHEP)=MHEP
+ IF(RPARTY.OR.(JHEP.NE.IHEP.AND.JDAHEP(2,JHEP).EQ.IHEP))
+ & JDAHEP(2,JHEP)=MHEP
+ JMOHEP(1,MHEP)=JMOHEP(1,IHEP)
+ JMOHEP(2,MHEP)=JMOHEP(2,IHEP)
+ JDAHEP(1,MHEP)=0
+ JDAHEP(2,MHEP)=JDAHEP(2,IHEP)
+ JDAHEP(1,IHEP)=MHEP
+ ENDIF
+ ENDIF
+ 100 CONTINUE
+ NHEP=MHEP
+ 999 END
+CDECK ID>, HWCHAD.
+*CMZ :- -26/04/91 14.00.57 by Federico Carminati
+*-- Author : Bryan Webber
+C-----------------------------------------------------------------------
+ SUBROUTINE HWCHAD(JCL,ID1,ID3,ID2)
+C-----------------------------------------------------------------------
+C HADRONIZES CLUSTER JCL, CONSISTING OF PARTONS ID1,ID3
+C ID2 RETURNS PARTON-ANTIPARTON PAIR CREATED
+C (IN SPECIAL CLUSTER CODE - SEE HWCFLA)
+C
+C MODIFIED 15/11/99 TO SMEAR POSITIONS OF HADRONS BY 1/(CLUSTER MASS)
+C-----------------------------------------------------------------------
+ INCLUDE 'HERWIG61.INC'
+ DOUBLE PRECISION HWR,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 HWR,HWRINT
+ DIQK(ID)=ID.GT.3.AND.ID.LT.10
+ IF (IERROR.NE.0) RETURN
+ ID2=0
+ EM0=PHEP(5,JCL)
+ IR1=NCLDK(LOCN(ID1,ID3))
+ EM1=RMIN(ID1,ID3)
+ IF (ABS(EM0-EM1).LT.0.001) THEN
+C---SINGLE-HADRON CLUSTER
+ NHEP=NHEP+1
+ IF (NHEP.GT.NMXHEP) CALL HWWARN('HWCHAD',100,*999)
+ IDHW(NHEP)=IR1
+ IDHEP(NHEP)=IDPDG(IR1)
+ ISTHEP(NHEP)=191
+ JDAHEP(1,JCL)=NHEP
+ JDAHEP(2,JCL)=NHEP
+ CALL HWVEQU(5,PHEP(1,JCL),PHEP(1,NHEP))
+ CALL HWVSUM(4,VHEP(1,JCL),VTXPIP,VHEP(1,NHEP))
+ ELSE
+ NTRY=0
+ IDMIN=1
+ EMLOW=RMIN(ID1,1)+RMIN(1,ID3)
+ EMADU=RMIN(ID1,2)+RMIN(2,ID3)
+ IF (EMADU.LT.EMLOW) THEN
+ IDMIN=2
+ EMLOW=EMADU
+ ENDIF
+ EMSQ=EM0**2
+ PCMAX=EMSQ-EMLOW**2
+ IF (PCMAX.GE.ZERO) THEN
+C---SET UP TWO QUARK-ANTIQUARK PAIRS OR A
+C QUARK-DIQUARK AND AN ANTIDIQUARK-ANTIQUARK
+ PCMAX=PCMAX*(EMSQ-(RMIN(ID1,IDMIN)-RMIN(IDMIN,ID3))**2)
+ IMAX=12
+ IF (DIQK(ID1).OR.DIQK(ID3)) IMAX=3
+ DO 10 I=3,IMAX
+ IF (EM0.LT.RMIN(ID1,I)+RMIN(I,ID3)) GOTO 20
+ 10 CONTINUE
+ I=IMAX+1
+ 20 ID2=HWRINT(1,I-1)
+ IF (PWT(ID2).NE.ONE) THEN
+ IF (PWT(ID2).LT.HWR()) GOTO 20
+ ENDIF
+C---PICK TWO PARTICLES WITH THESE QUANTUM NUMBERS
+ NTRY=NTRY+1
+ 30 IR1=LOCN(ID1,ID2)+INT(RESN(ID1,ID2)*HWR())
+ IF (CLDKWT(IR1).LT.HWR()) GOTO 30
+ IR1=NCLDK(IR1)
+ 40 IR2=LOCN(ID2,ID3)+INT(RESN(ID2,ID3)*HWR())
+ IF (CLDKWT(IR2).LT.HWR()) GOTO 40
+ IR2=NCLDK(IR2)
+ EM1=RMASS(IR1)
+ EM2=RMASS(IR2)
+ PCM=EMSQ-(EM1+EM2)**2
+ IF (PCM.GT.ZERO) GOTO 70
+ 50 IF (NTRY.LE.NDTRY) GOTO 20
+C---CAN'T FIND A DECAY MODE - CHOOSE LIGHTEST
+ 60 ID2=HWRINT(1,2)
+ IR1=NCLDK(LOCN(ID1,ID2))
+ IR2=NCLDK(LOCN(ID2,ID3))
+ EM1=RMASS(IR1)
+ EM2=RMASS(IR2)
+ PCM=EMSQ-(EM1+EM2)**2
+ IF (PCM.GT.ZERO) GOTO 70
+ NTRY=NTRY+1
+ IF (NTRY.LE.NDTRY+50) GOTO 60
+ CALL HWWARN('HWCHAD',101,*999)
+C---DECAY IS ALLOWED
+ 70 PCM=PCM*(EMSQ-(EM1-EM2)**2)
+ IF (NTRY.GT.NCTRY) GOTO 80
+ PTEST=PCM*SWTEF(IR1)*SWTEF(IR2)
+ IF (PTEST.LT.PCMAX*HWR()**2) GOTO 20
+ ELSE
+C---ALLOW DECAY BY PI0 EMISSION IF ONLY POSSIBILITY
+ ID2=1
+ IR2=NCLDK(LOCN(1,1))
+ EM2=RMASS(IR2)
+ PCM=(EMSQ-(EM1+EM2)**2)*(EMSQ-(EM1-EM2)**2)
+ ENDIF
+C---DECAY IS CHOSEN. GENERATE DECAY MOMENTA
+C AND PUT PARTICLES IN /HEPEVT/
+ 80 IF (PCM.LT.ZERO) CALL HWWARN('HWCHAD',102,*999)
+ PCM=0.5*SQRT(PCM)/EM0
+ MHEP=NHEP+1
+ NHEP=NHEP+2
+ IF (NHEP.GT.NMXHEP) CALL HWWARN('HWCHAD',103,*999)
+ PHEP(5,MHEP)=EM1
+ PHEP(5,NHEP)=EM2
+C Decide if cluster contains a b-(anti)quark or not
+ IF (ID1.EQ.11.OR.ID2.EQ.11.OR.ID3.EQ.11) THEN
+ IB=2
+ ELSE
+ IB=1
+ ENDIF
+ IF (CLDIR(IB).NE.0) THEN
+ DO 110 IM=1,2
+ JM=JMOHEP(IM,JCL)
+ IF (JM.EQ.0) GOTO 110
+ IF (ISTHEP(JM).NE.158) GOTO 110
+C LOOK FOR PARENT PARTON
+ DO 100 KM=JMOHEP(1,JM)+1,JM
+ IF (ISTHEP(KM).EQ.2) THEN
+ IF (JDAHEP(1,KM).EQ.JM) THEN
+C FOUND PARENT PARTON
+ IF (IDHW(KM).NE.13) THEN
+C FIND ITS DIRECTION IN CLUSTER CMF
+ CALL HWULOF(PHEP(1,JCL),PHEP(1,KM),PP)
+ PCQK=PP(1)**2+PP(2)**2+PP(3)**2
+ IF (PCQK.GT.ZERO) THEN
+ PCQK=SQRT(PCQK)
+ IF (CLSMR(IB).GT.ZERO) THEN
+C DO GAUSSIAN SMEARING OF DIRECTION
+ 90 CT=ONE+CLSMR(IB)*LOG(HWR())
+ IF (CT.LT.-ONE) GOTO 90
+ ST=ONE-CT*CT
+ IF (ST.GT.ZERO) ST=SQRT(ST)
+ CALL HWRAZM( ONE,CX,SX)
+ CALL HWUROT(PP,CX,SX,RMAT)
+ PP(1)=ZERO
+ PP(2)=PCQK*ST
+ PP(3)=PCQK*CT
+ CALL HWUROB(RMAT,PP,PP)
+ ENDIF
+ PCQK=PCM/PCQK
+ IF (IM.EQ.2) PCQK=-PCQK
+ CALL HWVSCA(3,PCQK,PP,PHEP(1,MHEP))
+ PHEP(4,MHEP)=SQRT(PHEP(5,MHEP)**2+PCM**2)
+ CALL HWULOB(PHEP(1,JCL),PHEP(1,MHEP),PHEP(1,MHEP))
+ CALL HWVDIF(4,PHEP(1,JCL),PHEP(1,MHEP),PHEP(1,NHEP))
+ GOTO 130
+ ENDIF
+ ENDIF
+ GOTO 120
+ ENDIF
+ ELSEIF (ISTHEP(KM).GT.140) THEN
+C FINISHED THIS JET
+ GOTO 110
+ ENDIF
+ 100 CONTINUE
+ 110 CONTINUE
+ ENDIF
+ 120 CALL HWDTWO(PHEP(1,JCL),PHEP(1,MHEP),PHEP(1,NHEP),
+ & PCM,TWO,.TRUE.)
+ 130 IDHW(MHEP)=IR1
+ IDHW(NHEP)=IR2
+ IDHEP(MHEP)=IDPDG(IR1)
+ IDHEP(NHEP)=IDPDG(IR2)
+ ISTHEP(MHEP)=192
+ ISTHEP(NHEP)=192
+ JMOHEP(1,MHEP)=JCL
+C---SECOND MOTHER OF HADRON IS JET
+ JMOHEP(2,MHEP)=JMOHEP(1,JMOHEP(1,JCL))
+ JDAHEP(1,JCL)=MHEP
+ JDAHEP(2,JCL)=NHEP
+C---SMEAR HADRON POSITIONS
+ HPSMR=GEV2MM/PHEP(5,JCL)
+ DO I=1,4
+ VHEP(I,MHEP)=HWRGAU(I,ZERO,HPSMR)
+ ENDDO
+ VHEP(4,MHEP)=ABS(VHEP(4,MHEP))
+ & +SQRT(HWVDOT(3,VHEP(1,MHEP),VHEP(1,MHEP)))
+ CALL HWULB4(PHEP(1,JCL),VHEP(1,MHEP),VHEP(1,MHEP))
+ CALL HWVSUM(4,VHEP(1,JCL),VHEP(1,MHEP),VHEP(1,MHEP))
+ CALL HWVSUM(4,VTXPIP,VHEP(1,MHEP),VHEP(1,MHEP))
+ DO I=1,4
+ VHEP(I,NHEP)=HWRGAU(I,ZERO,HPSMR)
+ ENDDO
+ VHEP(4,NHEP)=ABS(VHEP(4,NHEP))
+ & +SQRT(HWVDOT(3,VHEP(1,NHEP),VHEP(1,NHEP)))
+ CALL HWULB4(PHEP(1,JCL),VHEP(1,NHEP),VHEP(1,NHEP))
+ CALL HWVSUM(4,VHEP(1,JCL),VHEP(1,NHEP),VHEP(1,NHEP))
+ CALL HWVSUM(4,VTXPIP,VHEP(1,NHEP),VHEP(1,NHEP))
+ ENDIF
+ ISTHEP(JCL)=180+MOD(ISTHEP(JCL),10)
+ JMOHEP(1,NHEP)=JCL
+ JMOHEP(2,NHEP)=JMOHEP(1,JMOHEP(1,JCL))
+ 999 END
+CDECK ID>, HWDBOS.
+*CMZ :- -23/05/96 18.34.17 by Mike Seymour
+*-- Author : Mike Seymour
+C-----------------------------------------------------------------------
+ SUBROUTINE HWDBOS(IBOSON)
+C-----------------------------------------------------------------------
+C DECAY GAUGE BOSONS (ALREADY FOUND BY HWDHAD)
+C USES SPIN DENSITY MATRIX IN RHOHEP (1ST CMPT=>-VE,2=>LONG,3=>+VE)
+C IF BOSON CAME FROM HIGGS DECAY, GIVE BOTH THE SAME HELICITY (EPR)
+C IF BOSON CAME FROM W+1JET, GIVE IT THE CORRECT DECAY CORRELATIONS
+C-----------------------------------------------------------------------
+ INCLUDE 'HERWIG61.INC'
+ DOUBLE PRECISION HWR,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 HWR,HWRUNI,HWUPCM,HWULDO,HWRINT
+ IBOS=IBOSON
+ IF (IDHW(IBOS).LT.198.OR.IDHW(IBOS).GT.200)
+ & CALL HWWARN('HWDBOS',101,*999)
+ QUARKS=.FALSE.
+C---SEE IF IT IS PART OF A PAIR
+ IMOTH=JMOHEP(1,IBOS)
+ IPAIR=JMOHEP(2,IBOS)
+ ICMF=JMOHEP(1,IBOS)
+ IF (IDHW(ICMF).EQ.IDHW(IBOS).AND.ISTHEP(ICMF)/10.EQ.12)
+ & ICMF=JMOHEP(1,ICMF)
+ IOPT=0
+ IF (IPAIR.NE.0) THEN
+ IF (JMOHEP(2,IPAIR).NE.IBOS.OR.
+ & IDHW(IPAIR).LT.198.OR.IDHW(IPAIR).GT.200) IPAIR=0
+ ENDIF
+ IF (IPAIR.GT.0) IOPT=1
+C---SELECT DECAY PRODUCTS
+ 10 CALL HWDBOZ(IDHW(IBOS),IDN(1),IDN(2),CV,CA,BR,IOPT)
+C---V + 1JET DECAYS ARE NOW HANDLED HERE !
+ IF (IPRO.EQ.21) THEN
+ IQRK=IDHW(JMOHEP(1,ICMF))
+ IANT=IDHW(JMOHEP(2,ICMF))
+ IF (IQRK.EQ.13 .AND. IANT.LE.6) THEN
+ IQRK=JMOHEP(2,ICMF)
+ IANT=JDAHEP(2,ICMF)
+ ELSEIF (IQRK.EQ.13) THEN
+ IQRK=JDAHEP(2,ICMF)
+ IANT=JMOHEP(2,ICMF)
+ ELSEIF (IANT.EQ.13 .AND. IQRK.LE.6) THEN
+ IQRK=JMOHEP(1,ICMF)
+ IANT=JDAHEP(2,ICMF)
+ ELSEIF (IANT.EQ.13) THEN
+ IQRK=JDAHEP(2,ICMF)
+ IANT=JMOHEP(1,ICMF)
+ ELSEIF (IQRK.GT.IANT) THEN
+ IQRK=JMOHEP(2,ICMF)
+ IANT=JMOHEP(1,ICMF)
+ ELSE
+ IQRK=JMOHEP(1,ICMF)
+ IANT=JMOHEP(2,ICMF)
+ ENDIF
+ PHEP(5,NHEP+1)=RMASS(IDN(1))
+ PHEP(5,NHEP+2)=RMASS(IDN(2))
+ PCM=HWUPCM(PHEP(5,IBOS),PHEP(5,NHEP+1),PHEP(5,NHEP+2))
+ IF (PCM.LT.ZERO) CALL HWWARN('HWDBOS',103,*999)
+ IF (IDHW(IBOS).EQ.200) THEN
+ ID=IDN(1)
+ IF (ID.GT.120) ID=ID-110
+ IQ=IDHW(IQRK)
+ IF (IQ.GT.6) IQ=IQ-6
+ RRLL=(VFCH(IQ,1)**2+AFCH(IQ,1)**2)*
+ $ (VFCH(ID,1)**2+AFCH(ID,1)**2)
+ $ +4*VFCH(IQ,1)*AFCH(IQ,1)*
+ $ VFCH(ID,1)*AFCH(ID,1)
+ RLLR=(VFCH(IQ,1)**2+AFCH(IQ,1)**2)*
+ $ (VFCH(ID,1)**2+AFCH(ID,1)**2)
+ $ -4*VFCH(IQ,1)*AFCH(IQ,1)*
+ $ VFCH(ID,1)*AFCH(ID,1)
+ ELSE
+ RRLL=1
+ RLLR=0
+ ENDIF
+ PMAX=(RRLL+RLLR)
+ & *(HWULDO(PHEP(1,IANT),PHEP(1,IBOS))**2+
+ & HWULDO(PHEP(1,IQRK),PHEP(1,IBOS))**2)
+ 1 CALL HWDTWO(PHEP(1,IBOS),PHEP(1,NHEP+1),PHEP(1,NHEP+2),
+ & PCM,TWO,.TRUE.)
+ PROB=RRLL*(HWULDO(PHEP(1,IANT),PHEP(1,NHEP+1))**2+
+ & HWULDO(PHEP(1,IQRK),PHEP(1,NHEP+2))**2)+
+ & RLLR*(HWULDO(PHEP(1,IANT),PHEP(1,NHEP+2))**2+
+ & HWULDO(PHEP(1,IQRK),PHEP(1,NHEP+1))**2)
+ IF (PROB.GT.PMAX.OR.PROB.LT.ZERO)
+ & CALL HWWARN('HWDBOS',104,*999)
+ IF (PMAX*HWR().GT.PROB) GOTO 1
+ ELSE
+C---SELECT HELICITY, UNLESS IT IS THE SECOND OF A HIGGS DECAY (EPR)
+ IF (IPAIR.NE.IBOS .OR. IDHW(ICMF).NE.201) THEN
+ IF (RHOHEP(1,IBOS)+RHOHEP(2,IBOS)+RHOHEP(3,IBOS).LE.ZERO) THEN
+C---COPY PARENT HELICITY IF IT WAS A GAUGE BOSON
+ IF (IDHW(IMOTH).GE.198.AND.IDHW(IMOTH).LE.200) THEN
+ CALL HWVEQU(3,RHOHEP(1,IMOTH),RHOHEP(1,IBOS))
+ IF (RHOHEP(1,IBOS)+RHOHEP(2,IBOS)+RHOHEP(3,IBOS).GT.ZERO)
+ & GOTO 20
+C---MAY BE FROM A SUSY DECAY
+ ELSEIF (ABS(IDHEP(IMOTH)).LT.1000000) THEN
+ CALL HWWARN('HWDBOS',1,*999)
+ ENDIF
+ RHOHEP(1,IBOS)=1.
+ RHOHEP(2,IBOS)=1.
+ RHOHEP(3,IBOS)=1.
+ ENDIF
+ 20 IHEL=HWRINT(1,3)
+ IF (HWR().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.HWR()*FOUR) GOTO 30
+ IF (IHEL.EQ.2 .AND. (ONE-COSTH**2).LT.HWR() ) GOTO 30
+ IF (IHEL.EQ.3 .AND. (ONE-COSTH)**2.LT.HWR()*FOUR) GOTO 30
+C---GENERATE DECAY RELATIVE TO Z-AXIS
+ PHEP(5,NHEP+1)=RMASS(IDN(1))
+ PHEP(5,NHEP+2)=RMASS(IDN(2))
+ PCM=HWUPCM(PHEP(5,IBOS),PHEP(5,NHEP+1),PHEP(5,NHEP+2))
+ IF (PCM.LT.ZERO) CALL HWWARN('HWDBOS',102,*999)
+ CALL HWRAZM(PCM*SQRT(1-COSTH**2),PHEP(1,NHEP+1),PHEP(2,NHEP+1))
+ PHEP(3,NHEP+1)=PCM*COSTH
+ PHEP(4,NHEP+1)=SQRT(PHEP(5,NHEP+1)**2+PCM**2)
+C---ROTATE SO THAT Z-AXIS BECOMES BOSON'S DIRECTION IN ORIGINAL CM FRAME
+ CALL HWULOF(PHEP(1,ICMF),PHEP(1,IBOS),PBOS)
+ CALL HWUROT(PBOS, ONE,ZERO,R)
+ CALL HWUROB(R,PHEP(1,NHEP+1),PHEP(1,NHEP+1))
+C---BOOST BACK TO LAB
+ CALL HWULOB(PHEP(1,IBOS),PHEP(1,NHEP+1),PHEP(1,NHEP+1))
+ CALL HWVDIF(4,PHEP(1,IBOS),PHEP(1,NHEP+1),PHEP(1,NHEP+2))
+ ENDIF
+C---STATUS, IDs AND POINTERS
+ ISTHEP(IBOS)=195
+ DO 50 I=1,2
+ ISTHEP(NHEP+I)=193
+ IDHW(NHEP+I)=IDN(I)
+ IDHEP(NHEP+I)=IDPDG(IDN(I))
+ JDAHEP(I,IBOS)=NHEP+I
+ JMOHEP(1,NHEP+I)=IBOS
+ JMOHEP(2,NHEP+I)=JMOHEP(1,IBOS)
+ 50 CONTINUE
+ NHEP=NHEP+2
+ IF (IDN(1).LE.12) THEN
+ ISTHEP(NHEP-1)=113
+ ISTHEP(NHEP)=114
+ JMOHEP(2,NHEP)=NHEP-1
+ JDAHEP(2,NHEP)=NHEP-1
+ JMOHEP(2,NHEP-1)=NHEP
+ JDAHEP(2,NHEP-1)=NHEP
+ QUARKS=.TRUE.
+ ENDIF
+C---IF FIRST OF A PAIR, DO SECOND DECAY
+ IF (IPAIR.NE.0 .AND. IPAIR.NE.IBOS) THEN
+ IBOS=IPAIR
+ GOTO 10
+ ENDIF
+C---IF QUARK DECAY, HADRONIZE
+ IF (QUARKS) THEN
+ EMSCA=PHEP(5,IBOS)
+ CALL HWBGEN
+ CALL HWDHOB
+ CALL HWCFOR
+ CALL HWCDEC
+ ENDIF
+ 999 END
+CDECK ID>, HWDBOZ.
+*CMZ :- -29/04/91 18.00.03 by Federico Carminati
+*-- Author : Mike Seymour
+C-----------------------------------------------------------------------
+ SUBROUTINE HWDBOZ(IDBOS,IFER,IANT,CV,CA,BR,IOPT)
+C-----------------------------------------------------------------------
+C CHOOSE DECAY MODE OF BOSON
+C IOPT=2 TO RESET COUNTERS, 1 FOR BOSON PAIR, 0 FOR ANY OTHERS
+C-----------------------------------------------------------------------
+ INCLUDE 'HERWIG61.INC'
+ DOUBLE PRECISION HWR,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 HWR,HWRINT
+ SAVE FACW,FACZ,NWGLST,GENLST,NUMDEC,NPAIR,I1LST,I2LST,BRLST
+ DATA NWGLST,GENLST,NPAIR/-1,.FALSE.,0/
+C---STORE THE DECAY MODES (FERMION FIRST)
+ DATA IDMODE/ 2, 7, 4, 9, 6, 11, 2, 9, 4, 7,
+ & 122,127,124,129,126,131,8*0,
+ & 1, 8, 3, 10, 5, 12, 3, 8, 1, 10,
+ & 121,128,123,130,125,132,8*0,
+ & 1, 7, 2, 8, 3, 9, 4, 10, 5, 11, 6, 12,
+ & 121,127,123,129,125,131,122,128,124,130,126,132/
+C---STORE THE BRANCHING RATIOS TO THESE MODES
+ DATA BRMODE/0.321,0.321,0.000,0.017,0.017,0.108,0.108,0.108,4*0.0,
+ & 0.321,0.321,0.000,0.017,0.017,0.108,0.108,0.108,4*0.0,
+ & 0.154,0.120,0.154,0.120,0.152,0.000,
+ & 0.033,0.033,0.033,0.067,0.067,0.067/
+C---FACTORS FOR CV AND CA FOR W AND Z
+ DATA FACW,FACZ/2*0.0/
+ IF (FACZ.EQ.ZERO) FACZ=SQRT(SWEIN)
+ IF (FACW.EQ.ZERO) FACW=0.5/SQRT(2D0)
+ IF (IDBOS.LT.198.OR.IDBOS.GT.200) CALL HWWARN('HWDBOZ',101,*999)
+C---IF THIS IS A NEW EVENT SINCE LAST TIME, ZERO COUNTERS
+ IF (NWGTS.NE.NWGLST .OR.(GENEV.NEQV.GENLST).OR. IOPT.EQ.2) THEN
+ NPAIR=0
+ NUMDEC=0
+ NWGLST=NWGTS
+ GENLST=GENEV
+ IF (IOPT.EQ.2) RETURN
+ ENDIF
+ NUMDEC=NUMDEC+1
+ IF (NUMDEC.GT.MODMAX) CALL HWWARN('HWDBOZ',102,*999)
+C---IF PAIR OPTION SPECIFIED FOR THE FIRST TIME, MAKE CHOICE
+ IF (IOPT.EQ.1) THEN
+ IF (NUMDEC.GT.MODMAX-1) CALL HWWARN('HWDBOZ',103,*999)
+ IF (NPAIR.EQ.0) THEN
+ IF (HWR().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 (HWR().GT.BRMODE(IDEC,IDBOS-197).AND.I1.NE.I2) GOTO 10
+ IFER=IDMODE(1,IDEC,IDBOS-197)
+ IANT=IDMODE(2,IDEC,IDBOS-197)
+C---CALCULATE BRANCHING RATIO
+C (RESULT IS NOT WELL-DEFINED AFTER THE FIRST CALL OF A PAIR)
+ BR=0
+ DO 20 IDEC=I1,I2
+ 20 BR=BR+BRMODE(IDEC,IDBOS-197)
+ IF (IOPT.EQ.1) THEN
+ IF (NPAIR.NE.0) THEN
+ I1LST=I1
+ I2LST=I2
+ BRLST=BR
+ ELSE
+ BRCOM=0
+ DO 30 IDEC=MAX(I1,I1LST),MIN(I2,I2LST)
+ 30 BRCOM=BRCOM+BRMODE(IDEC,IDBOS-197)
+ BR=2*BR*BRLST - BRCOM**2
+ ENDIF
+ ENDIF
+C---SET UP VECTOR AND AXIAL VECTOR COUPLINGS (NORMALIZED TO THE
+C CONVENTION WHERE THE WEAK CURRENT IS G*(CV-CA*GAM5) )
+ IF (IDBOS.EQ.200) THEN
+ IF (IFER.LE.6) THEN
+C Quark couplings
+ CV=VFCH(IFER,1)
+ CA=AFCH(IFER,1)
+ ELSE
+C lepton couplings
+ JFER=IFER-110
+ CV=VFCH(JFER,1)
+ CA=AFCH(JFER,1)
+ ENDIF
+ CV=CV * FACZ
+ CA=CA * FACZ
+ ELSE
+ CV=FACW
+ CA=FACW
+ ENDIF
+ 999 END
+CDECK ID>, HWDCHK.
+*CMZ :- -27/07/99 13.33.03 by Mike Seymour
+*-- Author : Ian Knowles
+C-----------------------------------------------------------------------
+ SUBROUTINE HWDCHK(IDKY,L,*)
+C-----------------------------------------------------------------------
+C Checks line L of decay table is compatible with decay of particle
+C IDKY, tidies up the line and sets NPRODS.
+C-----------------------------------------------------------------------
+ INCLUDE 'HERWIG61.INC'
+ DOUBLE PRECISION EPS,QS,Q,DM
+ INTEGER IDKY,L,IFAULT,I,ID,J
+ PARAMETER (EPS=1.D-6)
+ IF (VTOCDK(IDKY).AND.VTORDK(IDKY)) RETURN 1
+ IFAULT=0
+ QS=FLOAT(ICHRG(IDKY))
+ IF (IDKY.LE.12.OR.(IDKY.GE.109.AND.IDKY.LE.120)
+ & .OR.(IDKY.GE.209.AND.IDKY.LE.220)
+ & .OR.(IDKY.GE.401.AND.IDKY.LE.424)) QS=QS/3.
+ DM=RMASS(IDKY)
+ NPRODS(L)=0
+ DO 10 I=1,5
+ ID=IDKPRD(I,L)
+ IF (ID.LT.0.OR.ID.EQ.20.OR.ID.GT.NRES) THEN
+ WRITE(6,20) L,RNAME(IDKY),(RNAME(IDKPRD(J,L)),J=1,5)
+ IFAULT=IFAULT+1
+ ELSEIF (ID.NE.0) THEN
+ IF (VTORDK(ID)) THEN
+ WRITE(6,30) L,RNAME(IDKY),(RNAME(IDKPRD(J,L)),J=1,5),RNAME(ID)
+ IFAULT=IFAULT+1
+ ENDIF
+ NPRODS(L)=NPRODS(L)+1
+ IDKPRD(NPRODS(L),L)=ID
+ Q=FLOAT(ICHRG(ID))
+ IF (ID.LE.12.OR.(ID.GE.109.AND.ID.LE.120)
+ & .OR.(ID.GE.209.AND.ID.LE.220)
+ & .OR.(ID.GE.401.AND.ID.LE.424)) Q=Q/3.
+ QS=QS-Q
+ DM=DM-RMASS(ID)
+ ENDIF
+ 10 CONTINUE
+C print any warnings
+ IF (NPRODS(L).EQ.0) THEN
+ WRITE(6,20) L,RNAME(IDKY),(RNAME(IDKPRD(I,L)),I=1,5)
+ IFAULT=IFAULT+1
+ ELSE
+ IF (ABS(QS).GT.EPS) THEN
+ WRITE(6,40) L,RNAME(IDKY),(RNAME(IDKPRD(I,L)),I=1,5),QS
+ IFAULT=IFAULT+1
+ ENDIF
+ IF (DM.LT.ZERO) THEN
+ WRITE(6,50) L,RNAME(IDKY),(RNAME(IDKPRD(I,L)),I=1,5),DM
+ IFAULT=IFAULT+1
+ ENDIF
+ ENDIF
+ 20 FORMAT(1X,'Line ',I4,' decay: ',A8,' --> ',4(A8,1X),A8/
+ & 1X,'contains no or unrecognised decay product(s)')
+ 30 FORMAT(1X,'Line ',I4,' decay: ',A8,' --> ',4(A8,1X),A8/
+ & 1X,'contains decay product ',A8,' which is vetoed')
+ 40 FORMAT(1X,'Line ',I4,' decay: ',A8,' --> ',4(A8,1X),A8/
+ & 1X,'violates charge conservation, Qin-Qout= ',F6.3)
+ 50 FORMAT(1X,'Line ',I4,' decay: ',A8,' --> ',4(A8,1X),A8/
+ & 1X,'is kinematically not allowed, Min-Mout= ',F10.3)
+ IF (IFAULT.NE.0) THEN
+ RETURN 1
+ ELSE
+ RETURN
+ ENDIF
+ END
+CDECK ID>, HWDCLE.
+*CMZ :- -28/01/92 12.34.44 by Mike Seymour
+*-- Author : Luca Stanco
+C-----------------------------------------------------------------------
+ SUBROUTINE HWDCLE(IHEP)
+C-----------------------------------------------------------------------
+C INTERFACE TO QQ-CLEO MONTE CARLO (LS 11/12/91)
+C-----------------------------------------------------------------------
+ INCLUDE 'HERWIG61.INC'
+ INTEGER IHEP,IIHEP,NHEPHF,QQLMAT
+ LOGICAL QQLERR
+ CHARACTER*8 NAME
+ EXTERNAL QQLMAT
+C---QQ-CLEO COMMON'S
+C*** MCPARS.INC
+ INTEGER MCTRK, NTRKS, MCVRTX, NVTXS, MCHANS, MCDTRS, MPOLQQ
+ INTEGER MCNUM, MCSTBL, MCSTAB, MCTLQQ, MDECQQ
+ INTEGER MHLPRB, MHLLST, MHLANG, MCPLST, MFDECA
+ PARAMETER (MCTRK = 512)
+ PARAMETER (NTRKS = MCTRK)
+ PARAMETER (MCVRTX = 256)
+ PARAMETER (NVTXS = MCVRTX)
+ PARAMETER (MCHANS = 4000)
+ PARAMETER (MCDTRS = 8000)
+ PARAMETER (MPOLQQ = 300)
+ PARAMETER (MCNUM = 500)
+ PARAMETER (MCSTBL = 40)
+ PARAMETER (MCSTAB = 512)
+ PARAMETER (MCTLQQ = 100)
+ PARAMETER (MDECQQ = 300)
+ PARAMETER (MHLPRB = 500)
+ PARAMETER (MHLLST = 1000)
+ PARAMETER (MHLANG = 500)
+ PARAMETER (MCPLST = 200)
+ PARAMETER (MFDECA = 5)
+C*** MCPROP.INC
+ REAL AMASS, CHARGE, CTAU, SPIN, RWIDTH, RMASMN, RMASMX
+ REAL RMIXPP, RCPMIX
+ INTEGER NPMNQQ, NPMXQQ, IDMC, INVMC, LPARTY, CPARTY
+ INTEGER IMIXPP, ICPMIX
+ COMMON/MCMAS1/
+ * NPMNQQ, NPMXQQ,
+ * AMASS(-20:MCNUM), CHARGE(-20:MCNUM), CTAU(-20:MCNUM),
+ * IDMC(-20:MCNUM), SPIN(-20:MCNUM),
+ * RWIDTH(-20:MCNUM), RMASMN(-20:MCNUM), RMASMX(-20:MCNUM),
+ * LPARTY(-20:MCNUM), CPARTY(-20:MCNUM),
+ * IMIXPP(-20:MCNUM), RMIXPP(-20:MCNUM),
+ * ICPMIX(-20:MCNUM), RCPMIX(-20:MCNUM),
+ * INVMC(0:MCSTBL)
+C
+ INTEGER NPOLQQ, IPOLQQ
+ COMMON/MCPOL1/
+ * NPOLQQ, IPOLQQ(5,MPOLQQ)
+C
+ CHARACTER QNAME*10, PNAME*10
+ COMMON/MCNAMS/
+ * QNAME(37), PNAME(-20:MCNUM)
+C
+C*** MCCOMS.INC
+ INTEGER NCTLQQ, NDECQQ, IVRSQQ, IORGQQ, IRS1QQ
+ INTEGER IEVTQQ, IRUNQQ, IBMRAD
+ INTEGER NTRKMC, QQNTRK, NSTBMC, NSTBQQ, NCHGMC, NCHGQQ
+ INTEGER IRANQQ, IRANMC, IRANCC, IRS2QQ
+ INTEGER IPFTQQ, IPCDQQ, IPRNTV, ITYPEV, IDECSV, IDAUTV
+ INTEGER ISTBMC, NDAUTV
+ INTEGER IVPROD, IVDECA
+ REAL BFLDQQ
+ REAL ENERQQ, BEAMQQ, BMPSQQ, BMNGQQ, EWIDQQ, BWPSQQ, BWNGQQ
+ REAL BPOSQQ, BSIZQQ
+ REAL ECM, P4CMQQ, P4PHQQ, ENERNW, BEAMNW, BEAMP, BEAMN
+ REAL PSAV, P4QQ, HELCQQ
+ CHARACTER DATEQQ*20, TIMEQQ*20, FOUTQQ*80, FCTLQQ*80, FDECQQ*80
+ CHARACTER FGEOQQ*80
+ CHARACTER CCTLQQ*80, CDECQQ*80
+C
+ COMMON/MCCM1A/
+ * NCTLQQ, NDECQQ, IVRSQQ, IORGQQ, IRS1QQ(3), BFLDQQ,
+ * ENERQQ, BEAMQQ, BMPSQQ, BMNGQQ, EWIDQQ, BWPSQQ, BWNGQQ,
+ * BPOSQQ(3), BSIZQQ(3),
+ * IEVTQQ, IRUNQQ,
+ * IBMRAD, ECM, P4CMQQ(4), P4PHQQ(4),
+ * ENERNW, BEAMNW, BEAMP, BEAMN,
+ * NTRKMC, QQNTRK, NSTBMC, NSTBQQ, NCHGMC, NCHGQQ,
+ * IRANQQ(2), IRANMC(2), IRANCC(2), IRS2QQ(5),
+ * IPFTQQ(MCTRK), IPCDQQ(MCTRK), IPRNTV(MCTRK), ITYPEV(MCTRK,2),
+ * IDECSV(MCTRK), IDAUTV(MCTRK), ISTBMC(MCTRK), NDAUTV(MCTRK),
+ * IVPROD(MCTRK), IVDECA(MCTRK),
+ * PSAV(MCTRK,4), HELCQQ(MCTRK), P4QQ(4,MCTRK)
+C
+ COMMON/MCCM1B/
+ * DATEQQ, TIMEQQ, FOUTQQ, FCTLQQ, FDECQQ, FGEOQQ,
+ * CCTLQQ(MCTLQQ), CDECQQ(MDECQQ)
+ INTEGER IDSTBL
+ COMMON/MCCM1C/
+ * IDSTBL(MCSTAB)
+C
+ INTEGER IFINAL(MCTRK), IFINSV(MCSTAB), NFINAL
+ EQUIVALENCE (IFINAL,ISTBMC), (IFINSV,IDSTBL), (NFINAL,NSTBMC)
+C
+ INTEGER NVRTX, ITRKIN, NTRKOU, ITRKOU, IVKODE
+ REAL XVTX, TVTX, RVTX
+ COMMON/MCCM2/
+ * NVRTX, XVTX(MCVRTX,3), TVTX(MCVRTX), RVTX(MCVRTX),
+ * ITRKIN(MCVRTX), NTRKOU(MCVRTX), ITRKOU(MCVRTX),
+ * IVKODE(MCVRTX)
+C*** MCGEN.INC
+ INTEGER QQIST,QQIFR,QQN,QQK,QQMESO,QQNC,QQKC,QQLASTN
+ REAL QQPUD,QQPS1,QQSIGM,QQMAS,QQPAR,QQCMIX,QQCND,QQBSPI,QQBSYM,QQP
+ REAL QQPC,QQCZF
+C
+ COMMON/DATA1/QQIST,QQIFR,QQPUD,QQPS1,QQSIGM,QQMAS(15),QQPAR(25)
+ COMMON/DATA2/QQCZF(15),QQMESO(36),QQCMIX(6,2)
+ COMMON/DATA3/QQCND(3)
+ COMMON/DATA5/QQBSPI(5),QQBSYM(3)
+ COMMON/JET/QQN,QQK(250,2),QQP(250,5),QQNC,QQKC(10),QQPC(10,4),
+ * QQLASTN
+C---
+ IF(FSTEVT) THEN
+C---INITIALIZE QQ-CLEO
+ CALL QQINIT(QQLERR)
+ IF(QQLERR) CALL HWWARN('HWDEUR',500,*999)
+ ENDIF
+C---CONSTRUCT THE HADRON FOR QQ-CLEO
+C NOTE: THE IDPDG CODE IS PROVIDED THROUGH THE QQLMAT ROUTINE
+C FROM THE CLEO PACKAGE (QQ-CLEO <--> IDPDG CODE TRANSFORMATION)
+ QQN=1
+ IDHEP(IHEP)=IDPDG(IDHW(IHEP))
+ QQK(1,1)=0
+ QQK(1,2)=QQLMAT(IDHEP(IHEP),1)
+ QQP(1,1)=PHEP(1,IHEP)
+ QQP(1,2)=PHEP(2,IHEP)
+ QQP(1,3)=PHEP(3,IHEP)
+ QQP(1,5)=AMASS(QQK(1,2))
+ QQP(1,4)=SQRT(QQP(1,5)**2+QQP(1,1)**2+QQP(1,2)**2+QQP(1,3)**2)
+C---LET QQ-CLEO DO THE JOB
+ QQNTRK=0
+ NVRTX=0
+ CALL DECADD(.FALSE.)
+C---UPDATE THE HERWIG TABLE : LOOP OVER QQN-CLEO FINAL PARTICLES
+ DO 40 IIHEP=1,QQN
+ NHEP=NHEP+1
+ ISTHEP(NHEP)=198
+ IF(ITYPEV(IIHEP,2).GE.0) ISTHEP(NHEP)=1
+ IDHEP(NHEP)=QQLMAT(ITYPEV(IIHEP,1),2)
+ CALL HWUIDT(1,IDHEP(NHEP),IDHW(NHEP),NAME)
+ IF(IIHEP.EQ.1) THEN
+ ISTHEP(IHEP)=199
+ JDAHEP(1,IHEP)=NHEP
+ JDAHEP(2,IHEP)=NHEP
+ ISTHEP(NHEP)=199
+ NHEPHF=NHEP
+ JMOHEP(1,NHEP)=IHEP
+ JMOHEP(2,NHEP)=IHEP
+ ELSE
+ JMOHEP(1,NHEP)=IPRNTV(IIHEP)+NHEPHF-1
+ JMOHEP(2,NHEP)=NHEPHF
+ ENDIF
+ JDAHEP(1,NHEP)=0
+ JDAHEP(2,NHEP)=0
+ IF(NDAUTV(IIHEP).GT.0) THEN
+ JDAHEP(1,NHEP)=IDAUTV(IIHEP)+NHEPHF-1
+ JDAHEP(2,NHEP)=JDAHEP(1,NHEP)+NDAUTV(IIHEP)-1
+ ENDIF
+ PHEP(1,NHEP)=QQP(IIHEP,1)
+ PHEP(2,NHEP)=QQP(IIHEP,2)
+ PHEP(3,NHEP)=QQP(IIHEP,3)
+ PHEP(4,NHEP)=QQP(IIHEP,4)
+ PHEP(5,NHEP)=QQP(IIHEP,5)
+ VHEP(1,NHEP)=XVTX(IVPROD(IIHEP),1)
+ VHEP(2,NHEP)=XVTX(IVPROD(IIHEP),2)
+ VHEP(3,NHEP)=XVTX(IVPROD(IIHEP),3)
+ VHEP(4,NHEP)=0.
+ 40 CONTINUE
+ 999 END
+CDECK ID>, HWDEUR.
+*CMZ :- -28/01/92 12.34.44 by Mike Seymour
+*-- Author : Luca Stanco
+C-----------------------------------------------------------------------
+ SUBROUTINE HWDEUR(IHEP)
+C-----------------------------------------------------------------------
+C INTERFACE TO EURODEC PACKAGE (LS 10/29/91)
+C-----------------------------------------------------------------------
+ INCLUDE 'HERWIG61.INC'
+ INTEGER IHEP,IIHEP,NHEPHF,IEUPDG,IPDGEU
+ CHARACTER*8 NAME
+C---EURODEC COMMON'S : INITIAL INPUT
+ INTEGER EULUN0,EULUN1,EULUN2,EURUN,EUEVNT
+ CHARACTER*4 EUDATD,EUTIT
+ REAL AMINIE(12),EUWEI
+ COMMON/INPOUT/EULUN0,EULUN1,EULUN2
+ COMMON/FILNAM/EUDATD,EUTIT
+ COMMON/HVYINI/AMINIE
+ COMMON/RUNINF/EURUN,EUEVNT,EUWEI
+C---EURODEC WORKING COMMON'S
+ INTEGER NPMAX,NTMAX
+ PARAMETER (NPMAX=18,NTMAX=2000)
+ INTEGER EUNP,EUIP(NPMAX),EUPHEL(NPMAX),EUTEIL,EUINDX(NTMAX),
+ & EUORIG(NTMAX),EUDCAY(NTMAX),EUTHEL(NTMAX)
+ REAL EUAPM(NPMAX),EUPCM(5,NPMAX),EUPVTX(3,NPMAX),EUPTEI(5,NTMAX),
+ & EUSECV(3,NTMAX)
+ COMMON/MOMGEN/EUNP,EUIP,EUAPM,EUPCM,EUPHEL,EUPVTX
+ COMMON/RESULT/EUTEIL,EUPTEI,EUINDX,EUORIG,EUDCAY,EUTHEL,EUSECV
+C---EURODEC COMMON'S FOR DECAY PROPERTIES
+ INTEGER NGMAX,NCMAX
+ PARAMETER (NGMAX=400,NCMAX=9000)
+ INTEGER EUNPA,EUIPC(NGMAX),EUIPDG(NGMAX),EUIDP(NGMAX),
+ & EUCONV(NCMAX)
+ REAL EUPM(NGMAX),EUPLT(NGMAX)
+ COMMON/PCTABL/EUNPA,EUIPC,EUIPDG,EUPM,EUPLT,EUIDP
+ COMMON/CONVRT/EUCONV
+C---
+ IF(FSTEVT) THEN
+C---CHANGE HERE THE DEFAULT VALUES OF EURODEC COMMON'S
+C
+C---INITIALIZE EURODEC COMMON'S
+CC CALL EUDCIN
+C---INITIALIZE EURODEC
+ CALL EUDINI
+ ENDIF
+C---CONSTRUCT THE HADRON FOR EURODEC FROM ID1,ID2
+ EUNP=1
+ IDHEP(IHEP)=IDPDG(IDHW(IHEP))
+ EUIP(1)=IPDGEU(IDHEP(IHEP))
+ EUAPM(1)=EUPM(EUCONV(IABS(EUIP(1))))
+ EUPCM(1,1)=PHEP(1,IHEP)
+ EUPCM(2,1)=PHEP(2,IHEP)
+ EUPCM(3,1)=PHEP(3,IHEP)
+ EUPCM(5,1)=SQRT(PHEP(1,IHEP)**2+PHEP(2,IHEP)**2+PHEP(3,IHEP)**2)
+ EUPCM(4,1)=SQRT(EUPCM(5,1)**2+EUAPM(1)**2)
+C NOT POLARIZED HADRONS
+ EUPHEL(1)=0
+C HADRONS START FROM PRIMARY VERTEX
+ EUPVTX(1,1)=0.
+ EUPVTX(2,1)=0.
+ EUPVTX(3,1)=0.
+C---LET EURODEC DO THE JOB
+ EUTEIL=0
+ CALL FRAGMT(1,1,0)
+C---UPDATE THE HERWIG TABLE : LOOP OVER N-EURODEC FINAL PARTICLES
+ DO 40 IIHEP=1,EUTEIL
+ NHEP=NHEP+1
+ ISTHEP(NHEP)=198
+ IF(EUDCAY(IIHEP).EQ.0) ISTHEP(NHEP)=1
+ IDHEP(NHEP)=IEUPDG(EUINDX(IIHEP))
+ CALL HWUIDT(1,IDHEP(NHEP),IDHW(NHEP),NAME)
+ IF(IIHEP.EQ.1) THEN
+ ISTHEP(IHEP)=199
+ JDAHEP(1,IHEP)=NHEP
+ JDAHEP(2,IHEP)=NHEP
+ ISTHEP(NHEP)=199
+ NHEPHF=NHEP
+ JMOHEP(1,NHEP)=IHEP
+ JMOHEP(2,NHEP)=IHEP
+ JDAHEP(1,NHEP)=EUDCAY(IIHEP)/10000+NHEPHF-1
+ JDAHEP(2,NHEP)=MOD(EUDCAY(IIHEP),10000)+NHEPHF-1
+ ELSE
+ JMOHEP(1,NHEP)=MOD(EUORIG(IIHEP),10000)+NHEPHF-1
+ JMOHEP(2,NHEP)=NHEPHF
+ JDAHEP(1,NHEP)=EUDCAY(IIHEP)/10000+NHEPHF-1
+ JDAHEP(2,NHEP)=MOD(EUDCAY(IIHEP),10000)+NHEPHF-1
+ ENDIF
+ PHEP(1,NHEP)=EUPTEI(1,IIHEP)
+ PHEP(2,NHEP)=EUPTEI(2,IIHEP)
+ PHEP(3,NHEP)=EUPTEI(3,IIHEP)
+ PHEP(4,NHEP)=EUPTEI(4,IIHEP)
+ PHEP(5,NHEP)=EUPTEI(5,IIHEP)
+ VHEP(1,NHEP)=EUSECV(1,IIHEP)
+ VHEP(2,NHEP)=EUSECV(2,IIHEP)
+ VHEP(3,NHEP)=EUSECV(3,IIHEP)
+ VHEP(4,NHEP)=0.
+ IF (IIHEP.GT.NTMAX) CALL HWWARN('HWDEUR',99,*999)
+ 40 CONTINUE
+ 999 END
+CDECK ID>, HWDFOR.
+*CMZ :- -01/04/99 19.52.44 by Mike Seymour
+*-- Author : Ian Knowles
+C-----------------------------------------------------------------------
+ SUBROUTINE HWDFOR(P0,P1,P2,P3,P4)
+C-----------------------------------------------------------------------
+C Generates 4-body decay 0->1+2+3+4 using pure phase space
+C-----------------------------------------------------------------------
+ IMPLICIT NONE
+ DOUBLE PRECISION HWR,P0(5),P1(5),P2(5),P3(5),P4(5),B,C,AA,BB,
+ & CC,DD,EE,TT,S1,RS1,FF,S2,PP,QQ,RR,P1CM,P234(5),P2CM,P34(5),P3CM
+ DOUBLE PRECISION TWO
+ PARAMETER (TWO=2.D0)
+ EXTERNAL HWR
+ B=P0(5)-P1(5)
+ C=P2(5)+P3(5)+P4(5)
+ IF (B.LT.C) CALL HWWARN('HWDFOR',100,*999)
+ AA=(P0(5)+P1(5))**2
+ BB=B**2
+ CC=C**2
+ DD=(P3(5)+P4(5))**2
+ EE=(P3(5)-P4(5))**2
+ TT=(B-C)*P0(5)**7/16
+C Select squared masses S1 and S2 of 234 and 34 subsystems
+ 10 S1=BB+HWR()*(CC-BB)
+ RS1=SQRT(S1)
+ FF=(RS1-P2(5))**2
+ S2=DD+HWR()*(FF-DD)
+ PP=(AA-S1)*(BB-S1)
+ QQ=((RS1+P2(5))**2-S2)*(FF-S2)/S1
+ RR=(S2-DD)*(S2-EE)/S2
+ IF (PP*QQ*RR*(FF-DD)**2.LT.TT*S1*S2*HWR()**2) GOTO 10
+C Do two body decays: 0-->1+234, 234-->2+34 and 34-->3+4
+ P1CM=SQRT(PP/4)/P0(5)
+ P234(5)=RS1
+ P2CM=SQRT(QQ/4)
+ P34(5)=SQRT(S2)
+ P3CM=SQRT(RR/4)
+ CALL HWDTWO(P0 ,P1,P234,P1CM,TWO,.TRUE.)
+ CALL HWDTWO(P234,P2,P34 ,P2CM,TWO,.TRUE.)
+ CALL HWDTWO(P34 ,P3,P4 ,P3CM,TWO,.TRUE.)
+ 999 END
+CDECK ID>, HWDFIV.
+*CMZ :- -01/04/99 19.52.44 by Mike Seymour
+*-- Author : Ian Knowles
+C-----------------------------------------------------------------------
+ SUBROUTINE HWDFIV(P0,P1,P2,P3,P4,P5)
+C-----------------------------------------------------------------------
+C Generates 5-body decay 0->1+2+3+4+5 using pure phase space
+C-----------------------------------------------------------------------
+ IMPLICIT NONE
+ DOUBLE PRECISION HWR,P0(5),P1(5),P2(5),P3(5),P4(5),P5(5),B,C,
+ & AA,BB,CC,DD,EE,FF,TT,S1,RS1,GG,S2,RS2,HH,S3,PP,QQ,RR,SS,P1CM,
+ & P2345(5),P2CM,P345(5),P3CM,P45(5),P4CM
+ DOUBLE PRECISION TWO
+ PARAMETER (TWO=2.D0)
+ EXTERNAL HWR
+ B=P0(5)-P1(5)
+ C=P2(5)+P3(5)+P4(5)+P5(5)
+ IF (B.LT.C) CALL HWWARN('HWDFIV',100,*999)
+ AA=(P0(5)+P1(5))**2
+ BB=B**2
+ CC=C**2
+ DD=(P3(5)+P4(5)+P5(5))**2
+ EE=(P4(5)+P5(5))**2
+ FF=(P4(5)-P5(5))**2
+ TT=(B-C)*P0(5)**11/729
+C Select squared masses S1, S2 and S3 of 2345, 345 and 45 subsystems
+ 10 S1=BB+HWR()*(CC-BB)
+ RS1=SQRT(S1)
+ GG=(RS1-P2(5))**2
+ S2=DD+HWR()*(GG-DD)
+ RS2=SQRT(S2)
+ HH=(RS2-P3(5))**2
+ S3=EE+HWR()*(HH-EE)
+ PP=(AA-S1)*(BB-S1)
+ QQ=((RS1+P2(5))**2-S2)*(GG-S2)/S1
+ RR=((RS2+P3(5))**2-S3)*(HH-S3)/S2
+ SS=(S3-EE)*(S3-FF)/S3
+ IF (PP*QQ*RR*SS*((GG-DD)*(HH-EE))**2.LT.TT*S1*S2*S3*HWR()**2)
+ & GOTO 10
+C Do two body decays: 0-->1+2345, 2345-->2+345, 345-->3+45 and 45-->4+5
+ P1CM=SQRT(PP/4)/P0(5)
+ P2345(5)=RS1
+ P2CM=SQRT(QQ/4)
+ P345(5)=RS2
+ P3CM=SQRT(RR/4)
+ P45(5)=SQRT(S3)
+ P4CM=SQRT(SS/4)
+ CALL HWDTWO(P0 ,P1,P2345,P1CM,TWO,.TRUE.)
+ CALL HWDTWO(P2345,P2,P345 ,P2CM,TWO,.TRUE.)
+ CALL HWDTWO(P345 ,P3,P45 ,P3CM,TWO,.TRUE.)
+ CALL HWDTWO(P45 ,P4,P5 ,P4CM,TWO,.TRUE.)
+ 999 END
+CDECK ID>, HWDHAD.
+*CMZ :- -26/04/91 14.01.26 by Federico Carminati
+*-- Author : Ian Knowles, Bryan Webber & Mike Seymour
+C-----------------------------------------------------------------------
+ SUBROUTINE HWDHAD
+C-----------------------------------------------------------------------
+C GENERATES DECAYS OF UNSTABLE HADRONS AND LEPTONS
+C-----------------------------------------------------------------------
+ INCLUDE 'HERWIG61.INC'
+ DOUBLE PRECISION HWR,HWULDO,RN,BF,COSANG,RSUM,DIST(4),VERTX(4),
+ & PMIX,WTMX,WTMX2,XS,DOT1,DOT2,HWDPWT,HWDWWT,XXX,YYY
+ INTEGER IHEP,ID,MHEP,IDM,I,IDS,IM,MO,IPDG
+ LOGICAL STABLE
+ EXTERNAL HWR,HWDPWT,HWDWWT,HWULDO
+ IF (IERROR.NE.0) RETURN
+ DO 100 IHEP=1,NMXHEP
+ IF (IHEP.GT.NHEP) THEN
+ ISTAT=90
+ RETURN
+ ELSEIF (ISTHEP(IHEP).EQ.120 .AND.
+ & JDAHEP(1,IHEP).EQ.IHEP.AND.JDAHEP(2,IHEP).EQ.IHEP) THEN
+C---COPY COLOUR SINGLET CMF
+ NHEP=NHEP+1
+ IF (NHEP.GT.NMXHEP) CALL HWWARN('HWDHAD',100,*999)
+ CALL HWVEQU(5,PHEP(1,IHEP),PHEP(1,NHEP))
+ CALL HWVEQU(4,VHEP(1,IHEP),VHEP(1,NHEP))
+ IDHW(NHEP)=IDHW(IHEP)
+ IDHEP(NHEP)=IDHEP(IHEP)
+ ISTHEP(NHEP)=190
+ JMOHEP(1,NHEP)=IHEP
+ JMOHEP(2,NHEP)=NHEP
+ JDAHEP(2,NHEP)=NHEP
+ JDAHEP(1,IHEP)=NHEP
+ JDAHEP(2,IHEP)=NHEP
+ ELSEIF (ISTHEP(IHEP).GE.190.AND.ISTHEP(IHEP).LE.193) THEN
+C---FIRST CHECK FOR STABILITY
+ ID=IDHW(IHEP)
+ IF (RSTAB(ID)) THEN
+ ISTHEP(IHEP)=1
+ JDAHEP(1,IHEP)=0
+ JDAHEP(2,IHEP)=0
+C---SPECIAL FOR GAUGE BOSON DECAY
+ IF (ID.GE.198.AND.ID.LE.200) CALL HWDBOS(IHEP)
+C---SPECIAL FOR HIGGS BOSON DECAY
+ IF (ID.EQ.201) CALL HWDHIG(ZERO)
+ ELSE
+C---UNSTABLE.
+C Calculate position of decay vertex
+ IF (DKLTM(ID).EQ.ZERO) THEN
+ CALL HWVEQU(4,VHEP(1,IHEP),VERTX)
+ MHEP=IHEP
+ IDM=ID
+ ELSE
+ CALL HWUDKL(ID,PHEP(1,IHEP),DIST)
+ CALL HWVSUM(4,VHEP(1,IHEP),DIST,VERTX)
+ IF (MAXDKL) THEN
+ CALL HWDXLM(VERTX,STABLE)
+ IF (STABLE) THEN
+ ISTHEP(IHEP)=1
+ JDAHEP(1,IHEP)=0
+ JDAHEP(2,IHEP)=0
+ GOTO 100
+ ENDIF
+ ENDIF
+ IF (MIXING.AND.(ID.EQ.221.OR.ID.EQ.223.OR.
+ & ID.EQ.245.OR.ID.EQ.247)) THEN
+C Select flavour of decaying b-meson allowing for flavour oscillation
+ IDS=MOD(ID,3)
+ XXX=XMRCT(IDS)*DIST(4)/PHEP(4,IHEP)
+ YYY=YMRCT(IDS)*DIST(4)/PHEP(4,IHEP)
+ IF (ABS(YYY).LT.10) THEN
+ PMIX=HALF*(ONE-COS(XXX)/COSH(YYY))
+ ELSE
+ PMIX=HALF
+ ENDIF
+ IF (HWR().LE.PMIX) THEN
+ IF (ID.LE.223) THEN
+ IDM=ID+24
+ ELSE
+ IDM=ID-24
+ ENDIF
+ ELSE
+ IDM=ID
+ ENDIF
+C Introduce a decaying neutral b-meson
+ IF (NHEP+1.GT.NMXHEP) CALL HWWARN('HWDHAD',101,*999)
+ MHEP=NHEP+1
+ ISTHEP(MHEP)=ISTHEP(IHEP)
+ ISTHEP(IHEP)=200
+ JDAHEP(1,IHEP)=MHEP
+ JDAHEP(2,IHEP)=MHEP
+ IDHW(MHEP)=IDM
+ IDHEP(MHEP)=IDPDG(IDM)
+ JMOHEP(1,MHEP)=IHEP
+ JMOHEP(2,MHEP)=JMOHEP(2,IHEP)
+ CALL HWVEQU(5,PHEP(1,IHEP),PHEP(1,MHEP))
+ CALL HWVEQU(4,VERTX,VHEP(1,MHEP))
+ NHEP=NHEP+1
+ ELSE
+ MHEP=IHEP
+ IDM=ID
+ ENDIF
+ ENDIF
+C Use CLEO/EURODEC packages for b-hadrons if requested
+ IF ((IDM.GE.221.AND.IDM.LE.231).OR.
+ & (IDM.GE.245.AND.IDM.LE.254)) THEN
+ IF (BDECAY.EQ.'CLEO') THEN
+ CALL HWDCLE(MHEP)
+ GOTO 100
+ ELSEIF (BDECAY.EQ.'EURO') THEN
+ CALL HWDEUR(MHEP)
+ GOTO 100
+ ENDIF
+ ENDIF
+C Choose decay mode
+ ISTHEP(MHEP)=ISTHEP(MHEP)+5
+ RN=HWR()
+ BF=0.
+ IM=LSTRT(IDM)
+ DO 10 I=1,NMODES(IDM)
+ BF=BF+BRFRAC(IM)
+ IF (BF.GE.RN) GOTO 20
+ 10 IM=LNEXT(IM)
+ CALL HWWARN('HWDHAD',50,*20)
+ 20 IF ((IDKPRD(1,IM).GE.1.AND.IDKPRD(1,IM).LE.13).OR.
+ & (IDKPRD(3,IM).GE.1.AND.IDKPRD(3,IM).LE.13)) THEN
+C Partonic decay of a heavy-(b,c)-hadron, store details
+ NQDK=NQDK+1
+ IF (NQDK.GT.NMXQDK) CALL HWWARN('HWDHAD',102,*999)
+ LOCQ(NQDK)=MHEP
+ IMQDK(NQDK)=IM
+ CALL HWVEQU(4,VERTX,VTXQDK(1,NQDK))
+ GOTO 100
+ ELSE
+C Exclusive decay, add decay products to event record
+ IF (NHEP+NPRODS(IM).GT.NMXHEP)
+ & CALL HWWARN('HWDHAD',103,*999)
+ JDAHEP(1,MHEP)=NHEP+1
+ DO 30 I=1,NPRODS(IM)
+ NHEP=NHEP+1
+ IDHW(NHEP)=IDKPRD(I,IM)
+ IDHEP(NHEP)=IDPDG(IDKPRD(I,IM))
+ ISTHEP(NHEP)=193
+ JMOHEP(1,NHEP)=MHEP
+ JMOHEP(2,NHEP)=JMOHEP(2,MHEP)
+ PHEP(5,NHEP)=RMASS(IDKPRD(I,IM))
+ 30 CALL HWVEQU(4,VERTX,VHEP(1,NHEP))
+ JDAHEP(2,MHEP)=NHEP
+ ENDIF
+C Next choose momenta:
+ IF (NPRODS(IM).EQ.1) THEN
+C 1-body decay: K0(BR) --> K0S,K0L
+ CALL HWVEQU(4,PHEP(1,MHEP),PHEP(1,NHEP))
+ ELSEIF (NPRODS(IM).EQ.2) THEN
+C 2-body decay
+C---SPECIAL TREATMENT OF POLARIZED MESONS
+ COSANG=TWO
+ IF (ID.EQ.IDHW(JMOHEP(1,MHEP))) THEN
+ MO=JMOHEP(1,MHEP)
+ RSUM=0
+ DO 40 I=1,3
+ 40 RSUM=RSUM+RHOHEP(I,MO)
+ IF (RSUM.GT.ZERO) THEN
+ RSUM=RSUM*HWR()
+ IF (RSUM.LT.RHOHEP(1,MO)) THEN
+C---(1+COSANG)**2
+ COSANG=MAX(HWR(),HWR(),HWR())*TWO-ONE
+ ELSEIF (RSUM.LT.RHOHEP(1,MO)+RHOHEP(2,MO)) THEN
+C---1-COSANG**2
+ COSANG=2*COS((ACOS(HWR()*TWO-ONE)+PIFAC)/THREE)
+ ELSE
+C---(1-COSANG)**2
+ COSANG=MIN(HWR(),HWR(),HWR())*TWO-ONE
+ ENDIF
+ ENDIF
+ ENDIF
+ CALL HWDTWO(PHEP(1,MHEP),PHEP(1,NHEP-1),
+ & PHEP(1,NHEP),CMMOM(IM),COSANG,.FALSE.)
+ ELSEIF (NPRODS(IM).EQ.3) THEN
+C 3-body decay
+ IF (NME(IM).EQ.100) THEN
+C Use free massless (V-A)*(V-A) Matrix Element
+ CALL HWDTHR(PHEP(1,MHEP),PHEP(1,NHEP-1),PHEP(1,NHEP-2),
+ & PHEP(1,NHEP),HWDWWT)
+ ELSEIF (NME(IM).EQ.101) THEN
+C Use bound massless (V-A)*(V-A) Matrix Element
+ WTMX=((PHEP(5,MHEP)-PHEP(5,NHEP))
+ & *(PHEP(5,MHEP)+PHEP(5,NHEP))
+ & +(PHEP(5,NHEP-1)-PHEP(5,NHEP-2))
+ & *(PHEP(5,NHEP-1)+PHEP(5,NHEP-2)))/TWO
+ WTMX2=WTMX**2
+ IPDG=ABS(IDHEP(MHEP))
+ XS=ONE-MAX(RMASS(MOD(IPDG/1000,10)),
+ & RMASS(MOD(IPDG/100,10)),RMASS(MOD(IPDG/10,10)))
+ & /(RMASS(MOD(IPDG/1000,10))+RMASS(MOD(IPDG/100,10))
+ & +RMASS(MOD(IPDG/10,10)))
+ 50 CALL HWDTHR(PHEP(1,MHEP),PHEP(1,NHEP-1),PHEP(1,NHEP-2),
+ & PHEP(1,NHEP),HWDWWT)
+ DOT1=HWULDO(PHEP(1,MHEP),PHEP(1,NHEP-1))
+ DOT2=HWULDO(PHEP(1,MHEP),PHEP(1,NHEP-2))
+ IF (DOT1*(WTMX-DOT1-XS*DOT2).LT.HWR()*WTMX2) GOTO 50
+ ELSE
+ CALL HWDTHR(PHEP(1,MHEP),PHEP(1,NHEP-2),PHEP(1,NHEP-1),
+ & PHEP(1,NHEP),HWDPWT)
+ ENDIF
+ ELSEIF (NPRODS(IM).EQ.4) THEN
+C 4-body decay
+ CALL HWDFOR(PHEP(1,MHEP ),PHEP(1,NHEP-3),PHEP(1,NHEP-2),
+ & PHEP(1,NHEP-1),PHEP(1,NHEP))
+ ELSEIF (NPRODS(IM).EQ.5) THEN
+C 5-body decay
+ CALL HWDFIV(PHEP(1,MHEP ),PHEP(1,NHEP-4),PHEP(1,NHEP-3),
+ & PHEP(1,NHEP-2),PHEP(1,NHEP-1),PHEP(1,NHEP))
+ ELSE
+ CALL HWWARN('HWDHAD',104,*999)
+ ENDIF
+ ENDIF
+ ENDIF
+ 100 CONTINUE
+C---MAY HAVE OVERFLOWED /HEPEVT/
+ CALL HWWARN('HWDHAD',105,*999)
+ 999 END
+CDECK ID>, HWDHGC.
+*CMZ :- -26/04/91 11.11.55 by Bryan Webber
+*-- Author : Mike Seymour
+C-----------------------------------------------------------------------
+ SUBROUTINE HWDHGC(TAU,FNREAL,FNIMAG)
+C-----------------------------------------------------------------------
+C CALCULATE THE COMPLEX FUNCTION F OF HHG eq 2.18
+C FOR USE IN H-->GAMMGAMM DECAYS
+C-----------------------------------------------------------------------
+ INCLUDE 'HERWIG61.INC'
+ DOUBLE PRECISION TAU,FNREAL,FNIMAG,FNLOG,FNSQR
+ IF (TAU.GT.ONE) THEN
+ FNREAL=(ASIN(1/SQRT(TAU)))**2
+ FNIMAG=0
+ ELSEIF (TAU.LT.ONE) THEN
+ FNSQR=SQRT(1-TAU)
+ FNLOG=LOG((1+FNSQR)/(1-FNSQR))
+ FNREAL=-0.25 * (FNLOG**2 - PIFAC**2)
+ FNIMAG= 0.5 * PIFAC*FNLOG
+ ELSE
+ FNREAL=0.25*PIFAC**2
+ FNIMAG=0
+ ENDIF
+ END
+CDECK ID>, HWDHGF.
+*CMZ :- -02/05/91 11.11.45 by Federico Carminati
+*-- Author : Mike Seymour
+C-----------------------------------------------------------------------
+ FUNCTION HWDHGF(X,Y)
+C-----------------------------------------------------------------------
+C CALCULATE THE DOUBLE BREIT-WIGNER INTEGRAL
+C X=(EMV/EMH)**2 , Y=EMV*GAMV/EMH**2
+C-----------------------------------------------------------------------
+ INCLUDE 'HERWIG61.INC'
+ DOUBLE PRECISION HWDHGF,X,Y,CHANGE,X1,X2,FAC1,FAC2,TH1,TH2,TH1HI,
+ & TH1LO,TH2HI,TH2LO,X2MAX,SQFAC
+ INTEGER NBIN,IBIN1,IBIN2
+C CHANGE IS THE POINT WHERE DIRECT INTEGRATION BEGINS TO CONVERGE
+C FASTER THAN STANDARD BREIT-WIGNER SUBSTITUTION
+ DATA CHANGE,NBIN/0.425,25/
+ HWDHGF=0
+ IF (Y.LT.ZERO) RETURN
+ IF (X.GT.CHANGE) THEN
+C---DIRECT INTEGRATION
+ FAC1=0.25 / NBIN
+ DO 200 IBIN1=1,NBIN
+ X1=(IBIN1-0.5) * FAC1
+ FAC2=( (1-SQRT(X1))**2-X1 ) / NBIN
+ DO 100 IBIN2=1,NBIN
+ X2=(IBIN2-0.5) * FAC2 + X1
+ SQFAC=1+X1**2+X2**2-2*(X1+X2+X1*X2)
+ IF (SQFAC.LT.ZERO) GOTO 100
+ HWDHGF=HWDHGF + 2.
+ & * ((1-X1-X2)**2+8*X1*X2)
+ & * SQRT(SQFAC)
+ & / ((X1-X)**2+Y**2) *Y
+ & / ((X2-X)**2+Y**2) *Y
+ & * FAC1*FAC2
+ 100 CONTINUE
+ 200 CONTINUE
+ ELSE
+C---INTEGRATION USING TAN THETA SUBSTITUTIONS
+ TH1LO=ATAN((0-X)/Y)
+ TH1HI=ATAN((1-X)/Y)
+ FAC1=(TH1HI-TH1LO) / NBIN
+ DO 400 IBIN1=1,NBIN
+ TH1=(IBIN1-0.5) * FAC1 + TH1LO
+ X1=Y*TAN(TH1) + X
+ X2MAX=MIN(X1,(1-SQRT(X1))**2)
+ TH2LO=ATAN((0-X)/Y)
+ TH2HI=ATAN((X2MAX-X)/Y)
+ FAC2=(TH2HI-TH2LO) / NBIN
+ DO 300 IBIN2=1,NBIN
+ TH2=(IBIN2-0.5) * FAC2 + TH2LO
+ X2=Y*TAN(TH2) + X
+ SQFAC=1+X1**2+X2**2-2*(X1+X2+X1*X2)
+ IF (SQFAC.LT.ZERO) GOTO 300
+ HWDHGF=HWDHGF + 2.
+ & * ((1-X1-X2)**2+8*X1*X2)
+ & * SQRT(SQFAC)
+ & * FAC1 * FAC2
+ 300 CONTINUE
+ 400 CONTINUE
+ ENDIF
+ HWDHGF=HWDHGF/(PIFAC*PIFAC)
+ END
+CDECK ID>, HWDHIG.
+*CMZ :- -24/04/92 14.23.44 by Mike Seymour
+*-- Author : Mike Seymour
+C-----------------------------------------------------------------------
+ SUBROUTINE HWDHIG(GAMINP)
+C-----------------------------------------------------------------------
+C HIGGS DECAY ROUTINE
+C A) FOR GAMinp=0 FIND AND DECAY HIGGS
+C B) FOR GAMinp>0 CALCULATE TOTAL HIGGS WIDTH
+C FOR EMH=GAMINP. STORE RESULT IN GAMINP.
+C-----------------------------------------------------------------------
+ INCLUDE 'HERWIG61.INC'
+ DOUBLE PRECISION HWDHGF,HWR,HWRUNI,HWUSQR,HWUPCM,GAMINP,EMH,
+ & EMF,COLFAC,ENF,K1,K0,BET0,BET1,GAM0,GAM1,SCLOG,CFAC,XF,EM,GAMLIM,
+ & GAM,XW,EMW,XZ,EMZ,YW,YZ,EMI,TAUT,TAUW,WIDHIG,VECDEC,EMB,GAMB,
+ & TMIN,TMAX1,EM1,TMAX2,EM2,X1,X2,PROB,PCM,SUMR,SUMI,TAUTR,TAUTI,
+ & TAUWR,TAUWI,GFACTR
+ INTEGER HWRINT,IHIG,I,IFERM,NLOOK,I1,I2,IPART,IMODE,IDEC,MMAX
+ LOGICAL HWRLOG
+ EXTERNAL HWDHGF,HWR,HWRUNI,HWUSQR,HWUPCM,HWRINT,HWRLOG
+ SAVE GAM,EM,VECDEC
+ PARAMETER (NLOOK=100)
+ DIMENSION VECDEC(2,0:NLOOK)
+ EQUIVALENCE (EMW,RMASS(198)),(EMZ,RMASS(200))
+ DATA GAMLIM,GAM,EM/10D0,2*0D0/
+C---IF DECAY, FIND HIGGS (HWDHAD WILL HAVE GIVEN IT STATUS=1)
+ IF (GAMINP.EQ.ZERO) THEN
+ IHIG=0
+ DO 10 I=1,NHEP
+ 10 IF (IHIG.EQ.0.AND.IDHW(I).EQ.201.AND.ISTHEP(I).EQ.1) IHIG=I
+ IF (IHIG.EQ.0) CALL HWWARN('HWDHIG',101,*999)
+ EMH=PHEP(5,IHIG)
+ IF (EMH.LE.ZERO) CALL HWWARN('HWDHIG',102,*999)
+ EMSCA=EMH
+ ELSE
+ EMH=GAMINP
+ IF (EMH.LE.ZERO) THEN
+ GAMINP=0
+ RETURN
+ ENDIF
+ ENDIF
+C---CALCULATE BRANCHING FRACTIONS
+C---FERMIONS
+C---NLL CORRECTION TO QUARK DECAY RATE (HHG eq 2.6-9)
+ ENF=0
+ DO 1 I=1,6
+ 1 IF (2*RMASS(I).LT.EMH) ENF=ENF+1
+ K1=5/PIFAC**2
+ K0=3/(4*PIFAC**2)
+ BET0=(11*CAFAC-2*ENF)/3
+ BET1=(34*CAFAC**2-(10*CAFAC+6*CFFAC)*ENF)/3
+ GAM0=-8
+ GAM1=-404./3+40*ENF/9
+ SCLOG=LOG(EMH**2/QCDLAM**2)
+ CFAC=1 + ( K1/K0 - 2*GAM0 + GAM0*BET1/BET0**2*LOG(SCLOG)
+ & + (GAM0*BET1-GAM1*BET0)/BET0**2) / (BET0*SCLOG)
+ DO 100 IFERM=1,9
+ IF (IFERM.LE.6) THEN
+ EMF=RMASS(IFERM)
+ XF=(EMF/EMH)**2
+ COLFAC=FLOAT(NCOLO)
+ IF (EMF.GT.QCDLAM)
+ & EMF=EMF*(LOG(EMH/QCDLAM)/LOG(EMF/QCDLAM))**(GAM0/(2*BET0))
+ ELSE
+ EMF=RMASS(107+IFERM*2)
+ XF=(EMF/EMH)**2
+ COLFAC=1
+ CFAC=1
+ ENDIF
+ IF (FOUR*XF.LT.ONE) THEN
+ GFACTR=ALPHEM/(8.*SWEIN*EMW**2)
+ BRHIG(IFERM)=COLFAC*GFACTR*EMH*EMF**2 * (1-4*XF)**1.5 * CFAC
+ ELSE
+ BRHIG(IFERM)=0
+ ENDIF
+ 100 CONTINUE
+C---W*W*/Z*Z*
+ IF (ABS(EM-EMH).GE.GAMLIM*GAM) THEN
+C---OFF EDGE OF LOOK-UP TABLE
+ XW=(EMW/EMH)**2
+ XZ=(EMZ/EMH)**2
+ YW=EMW*GAMW/EMH**2
+ YZ=EMZ*GAMZ/EMH**2
+ BRHIG(10)=.50*GFACTR * EMH**3 * HWDHGF(XW,YW)
+ BRHIG(11)=.25*GFACTR * EMH**3 * HWDHGF(XZ,YZ)
+ ELSE
+C---LOOK IT UP
+ EMI=((EMH-EM)/(GAM*GAMLIM)+1)*NLOOK/2.0
+ I1=INT(EMI)
+ I2=INT(EMI+1)
+ BRHIG(10)=.50*GFACTR * EMH**3 * ( VECDEC(1,I1)*(I2-EMI) +
+ & VECDEC(1,I2)*(EMI-I1) )
+ BRHIG(11)=.25*GFACTR * EMH**3 * ( VECDEC(2,I1)*(I2-EMI) +
+ & VECDEC(2,I2)*(EMI-I1) )
+ ENDIF
+C---GAMMAGAMMA
+ TAUT=(2*RMASS(6)/EMH)**2
+ TAUW=(2*EMW/EMH)**2
+ CALL HWDHGC(TAUT,TAUTR,TAUTI)
+ CALL HWDHGC(TAUW,TAUWR,TAUWI)
+ SUMR=4./3*( - 2*TAUT*( 1 + (1-TAUT)*TAUTR ) ) * ENHANC(6)
+ & +(2 + 3*TAUW*( 1 + (2-TAUW)*TAUWR ) ) * ENHANC(10)
+ SUMI=4./3*( - 2*TAUT*( (1-TAUT)*TAUTI ) ) * ENHANC(6)
+ & +( 3*TAUW*( (2-TAUW)*TAUWI ) ) * ENHANC(10)
+ BRHIG(12)=GFACTR*.03125*(ALPHEM/PIFAC)**2
+ & *EMH**3 * (SUMR**2 + SUMI**2)
+ WIDHIG=0
+ DO 200 IPART=1, 12
+ IF (IPART.LT.12) BRHIG(IPART)=BRHIG(IPART)*ENHANC(IPART)**2
+ 200 WIDHIG=WIDHIG+BRHIG(IPART)
+ IF (WIDHIG.EQ.ZERO) CALL HWWARN('HWDHIG',103,*999)
+ DO 300 IPART=1, 12
+ 300 BRHIG(IPART)=BRHIG(IPART)/WIDHIG
+ IF (EM.NE.RMASS(201)) THEN
+C---SET UP W*W*/Z*Z* LOOKUP TABLES
+ EM=EMH
+ GAM=WIDHIG
+ GAMLIM=MAX(GAMLIM,GAMMAX)
+ DO 400 I=0,NLOOK
+ EMH=(I*2.0/NLOOK-1)*GAM*GAMLIM+EM
+ XW=(EMW/EMH)**2
+ XZ=(EMZ/EMH)**2
+ YW=EMW*GAMW/EMH**2
+ YZ=EMZ*GAMZ/EMH**2
+ VECDEC(1,I)=HWDHGF(XW,YW)
+ VECDEC(2,I)=HWDHGF(XZ,YZ)
+ 400 CONTINUE
+ EMH=EM
+ ENDIF
+ IF (GAMINP.GT.ZERO) THEN
+ GAMINP=WIDHIG
+ RETURN
+ ENDIF
+C---SEE IF USER SPECIFIED A DECAY MODE
+ IMODE=MOD(IPROC,100)
+C---IF NOT, CHOOSE ONE
+ IF (IMODE.LT.1.OR.IMODE.GT.12) THEN
+ MMAX=12
+ IF (IMODE.LT.1) MMAX=6
+ 500 IMODE=HWRINT(1,MMAX)
+ IF (BRHIG(IMODE).LT.HWR()) GOTO 500
+ ENDIF
+C---SEE IF SPECIFIED DECAY IS POSSIBLE
+ IF (BRHIG(IMODE).EQ.ZERO) CALL HWWARN('HWDHIG',104,*999)
+ IF (IMODE.LE.6) THEN
+ IDEC=IMODE
+ ELSEIF (IMODE.LE.9) THEN
+ IDEC=107+IMODE*2
+ ELSEIF (IMODE.EQ.10) THEN
+ IDEC=198
+ ELSEIF (IMODE.EQ.11) THEN
+ IDEC=200
+ ELSEIF (IMODE.EQ.12) THEN
+ IDEC=59
+ ENDIF
+C---STATUS, IDs AND POINTERS
+ ISTHEP(IHIG)=195
+ DO 600 I=1,2
+ ISTHEP(NHEP+I)=193
+ IDHW(NHEP+I)=IDEC
+ IDHEP(NHEP+I)=IDPDG(IDEC)
+ JDAHEP(I,IHIG)=NHEP+I
+ JMOHEP(1,NHEP+I)=IHIG
+ JMOHEP(2,NHEP+I)=NHEP+(3-I)
+ JDAHEP(2,NHEP+I)=NHEP+(3-I)
+ PHEP(5,NHEP+I)=RMASS(IDEC)
+ IDEC=IDEC+6
+ IF (IDEC.EQ.204) IDEC=199
+ IF (IDEC.EQ.206) IDEC=200
+ IF (IDEC.EQ. 65) IDEC= 59
+ 600 CONTINUE
+C---ALLOW W/Z TO BE OFF-SHELL
+ IF (IMODE.EQ.10.OR.IMODE.EQ.11) THEN
+ IF (IMODE.EQ.10) THEN
+ EMB=EMW
+ GAMB=GAMW
+ ELSE
+ EMB=EMZ
+ GAMB=GAMZ
+ ENDIF
+C---STANDARD MASS DISTRIBUTION
+ 700 TMIN=ATAN(-EMB/GAMB)
+ TMAX1=ATAN((EMH**2/EMB-EMB)/GAMB)
+ EM1=HWUSQR(EMB*(GAMB*TAN(HWRUNI(0,TMIN,TMAX1))+EMB))
+ TMAX2=ATAN(((EMH-EM1)**2/EMB-EMB)/GAMB)
+ EM2=HWUSQR(EMB*(GAMB*TAN(HWRUNI(0,TMIN,TMAX2))+EMB))
+ X1=(EM1/EMH)**2
+ X2=(EM2/EMH)**2
+C---CORRECT MASS DISTRIBUTION
+ PROB=HWUSQR(1+X1**2+X2**2-2*X1-2*X2-2*X1*X2)
+ & * ((X1+X2-1)**2 + 8*X1*X2)
+ IF (.NOT.HWRLOG(PROB)) GOTO 700
+C---CALCULATE SPIN DENSITY MATRIX
+ RHOHEP(1,NHEP+1)=4*X1*X2 / (8*X1*X2 + (X1+X2-1)**2)
+ RHOHEP(2,NHEP+1)=(X1+X2-1)**2 / (8*X1*X2 + (X1+X2-1)**2)
+ RHOHEP(3,NHEP+1)=RHOHEP(1,NHEP+1)
+C---SYMMETRIZE DISTRIBUTIONS IN PARTICLES 1,2
+ IF (HWRLOG(HALF)) THEN
+ PHEP(5,NHEP+1)=EM1
+ PHEP(5,NHEP+2)=EM2
+ ELSE
+ PHEP(5,NHEP+1)=EM2
+ PHEP(5,NHEP+2)=EM1
+ ENDIF
+ ENDIF
+C---DO DECAY
+ PCM=HWUPCM(EMH,PHEP(5,NHEP+1),PHEP(5,NHEP+2))
+ IF (PCM.LT.ZERO) CALL HWWARN('HWDHIG',105,*999)
+ CALL HWDTWO(PHEP(1,IHIG),PHEP(1,NHEP+1),PHEP(1,NHEP+2),
+ & PCM,TWO,.TRUE.)
+ NHEP=NHEP+2
+C---IF QUARK DECAY, HADRONIZE
+ IF (IMODE.LE.6) THEN
+ ISTHEP(NHEP-1)=113
+ ISTHEP(NHEP)=114
+ CALL HWBGEN
+ CALL HWDHOB
+ CALL HWCFOR
+ CALL HWCDEC
+ ENDIF
+ 999 END
+CDECK ID>, HWDHOB.
+*CMZ :- -20/10/99 09:46:43 by Peter Richardson
+*-- Author : Ian Knowles & Bryan Webber
+C-----------------------------------------------------------------------
+ SUBROUTINE HWDHOB
+C-----------------------------------------------------------------------
+C Performs decays of heavy objects (heavy quarks & SUSY particles)
+C MODIFIED TO INCLUDE R-PARITY VIOLATING SUSY PR 9/4/99
+C-----------------------------------------------------------------------
+ INCLUDE 'HERWIG61.INC'
+ DOUBLE PRECISION HWUMBW,HWUPCM,HWR,SDKM,RN,BF,PCM,
+ & EMMX,EMWSQ,GMWSQ,EMLIM,PW(5),EMTST,HWDPWT,HWDWWT,HWULDO,PDW(5,3)
+ INTEGER IST(3),IHEP,IS,ID,IM,I,JHEP,KHEP,LHEP,MHEP,NPR,ISM,JCM,
+ & MTRY,NTRY,IDM,IDM2,THEP,CLSAVE(2),WHEP,RHEP
+ LOGICAL FOUND
+ EXTERNAL HWR,HWDPWT,HWDWWT
+ DATA IST/113,114,114/
+ IF (IERROR.NE.0) RETURN
+ 10 FOUND=.FALSE.
+ CLSAVE(1) = 0
+ CLSAVE(2) = 0
+ DO 60 IHEP=1,NMXHEP
+ IS=ISTHEP(IHEP)
+ ID=IDHW(IHEP)
+ IF (.NOT.RSTAB(ID).AND.(ID.EQ.6.OR.ID.EQ.12.OR.
+ & (ID.GE.203.AND.ID.LE.218).OR.ABS(IDPDG(ID)).GT.1000000).AND.
+ & (IS.EQ.190.OR.(IS.GE.147.AND.IS.LE.151))) THEN
+ FOUND=.TRUE.
+ IF(.NOT.RPARTY) THEN
+ NHEP = NHEP+1
+ ISTHEP(NHEP) = 3
+ IDHW(NHEP) = 20
+ IDHEP(NHEP) = 0
+ CALL HWVEQU(5,PHEP(1,IHEP),PHEP(1,NHEP))
+ CALL HWVEQU(4,VHEP(1,IHEP),VHEP(1,NHEP))
+ JMOHEP(1,NHEP)=JMOHEP(1,IHEP)
+ JMOHEP(2,NHEP)=JMOHEP(2,IHEP)
+ JDAHEP(1,NHEP)=JDAHEP(1,IHEP)
+ JDAHEP(2,NHEP)=JDAHEP(2,IHEP)
+ ENDIF
+C Make a copy of decaying object
+ NHEP=NHEP+1
+ ISTHEP(NHEP)=155
+ IDHW(NHEP)=IDHW(IHEP)
+ IDHEP(NHEP)=IDHEP(IHEP)
+ CALL HWVEQU(5,PHEP(1,IHEP),PHEP(1,NHEP))
+ CALL HWVEQU(4,VHEP(1,IHEP),VHEP(1,NHEP))
+ JMOHEP(1,NHEP)=JMOHEP(1,IHEP)
+ JMOHEP(2,NHEP)=JMOHEP(2,IHEP)
+ MTRY=0
+ 15 MTRY=MTRY+1
+C Select decay mode
+ RN=HWR()
+ BF=0.
+ IM=LSTRT(ID)
+ DO 20 I=1,NMODES(ID)
+ BF=BF+BRFRAC(IM)
+ IF (BF.GE.RN) GOTO 30
+ 20 IM=LNEXT(IM)
+ CALL HWWARN('HWDHOB',50,*30)
+ 30 IF (NHEP+5.GT.NMXHEP) CALL HWWARN('HWDHOB',100,*999)
+ NPR=NPRODS(IM)
+ JDAHEP(1,NHEP)=NHEP+1
+ JDAHEP(2,NHEP)=NHEP+NPR
+C Reset colour pointers (if set)
+ JHEP=JMOHEP(2,IHEP)
+ IF (JHEP.GT.0) THEN
+ IF (JDAHEP(2,JHEP).EQ.IHEP) JDAHEP(2,JHEP)=NHEP
+ IF(.NOT.RPARTY.AND.ISTHEP(JHEP).EQ.155
+ & .AND.ABS(IDHEP(JHEP)).GT.1000000
+ & .AND.JDAHEP(2,JHEP-1).EQ.IHEP) JDAHEP(2,JHEP-1) = NHEP
+ ENDIF
+ JHEP=JDAHEP(2,IHEP)
+ IF (JHEP.GT.0) THEN
+ IF (JMOHEP(2,JHEP).EQ.IHEP) JMOHEP(2,JHEP)=NHEP
+ IF(.NOT.RPARTY.AND.ISTHEP(JHEP).EQ.155
+ & .AND.ABS(IDHEP(JHEP)).GT.1000000
+ & .AND.JMOHEP(2,JHEP-1).EQ.IHEP) JMOHEP(2,JHEP-1) = NHEP
+ ENDIF
+C--Reset colour pointers if baryon number violated
+ IF(.NOT.RPARTY) THEN
+ DO JHEP=1,NHEP
+ IF(ISTHEP(JHEP).EQ.155
+ & .AND.ABS(IDHEP(JHEP)).GT.1000000.AND.
+ & JDAHEP(2,JHEP-1).EQ.IHEP) JDAHEP(2,JHEP-1)= NHEP
+ IF(JDAHEP(2,JHEP).EQ.IHEP) JDAHEP(2,JHEP)=NHEP
+ IF(JMOHEP(2,JHEP).EQ.IHEP) JMOHEP(2,JHEP)=NHEP
+ ENDDO
+ IF(HRDCOL(1,1).EQ.IHEP) HRDCOL(1,1)=NHEP
+ ENDIF
+C Relabel original track
+ ISTHEP(IHEP)=3
+ JMOHEP(2,IHEP)=JMOHEP(1,IHEP)
+ JDAHEP(1,IHEP)=NHEP
+ JDAHEP(2,IHEP)=NHEP
+C Label decay products and choose masses
+ LHEP=NHEP
+ MHEP=LHEP+1
+ NTRY=0
+ 35 NTRY=NTRY+1
+ SDKM=PHEP(5,NHEP)
+ DO 40 I=1,NPR
+ NHEP=NHEP+1
+ IDHW(NHEP)=IDKPRD(I,IM)
+ IDHEP(NHEP)=IDPDG(IDKPRD(I,IM))
+ ISTHEP(NHEP)=IST(I)
+ JMOHEP(1,NHEP)=LHEP
+ JDAHEP(1,NHEP)=0
+ PHEP(5,NHEP)=HWUMBW(IDKPRD(I,IM))
+ 40 SDKM=SDKM-PHEP(5,NHEP)
+ IF (SDKM.LT.ZERO) THEN
+ NHEP=NHEP-NPR
+ IF (NTRY.LE.NETRY) GO TO 35
+ CALL HWWARN('HWDHOB',1,*45)
+ 45 IF (MTRY.LE.NETRY) GO TO 15
+ CALL HWWARN('HWDHOB',101,*999)
+ ENDIF
+C Assign production vertices to decay products
+ CALL HWUDKL(ID,PHEP(1,IHEP),VHEP(1,MHEP))
+ CALL HWVSUM(4,VHEP(1,IHEP),VHEP(1,MHEP),VHEP(1,MHEP))
+ CALL HWVEQU(4,VHEP(1,MHEP),VHEP(1,NHEP))
+ IF (NPR.EQ.2) THEN
+C Two body decay: LHEP -> MHEP + NHEP
+ PCM=HWUPCM(PHEP(5,IHEP),PHEP(5,MHEP),PHEP(5,NHEP))
+ CALL HWDTWO(PHEP(1,IHEP),PHEP(1,MHEP),
+ & PHEP(1,NHEP),PCM,TWO,.FALSE.)
+ ELSEIF (NPR.EQ.3) THEN
+C Three body decay: LHEP -> KHEP + MHEP + NHEP
+ KHEP=MHEP
+ MHEP=MHEP+1
+C Provisional colour self-connection of KHEP
+ JMOHEP(2,KHEP)=KHEP
+ JDAHEP(2,KHEP)=KHEP
+ IF (NME(IM).EQ.100) THEN
+C Generate decay momenta using full (V-A)*(V-A) matrix element
+ EMMX=PHEP(5,IHEP)-PHEP(5,NHEP)
+ EMWSQ=RMASS(198)**2
+ GMWSQ=(RMASS(198)*GAMW)**2
+ EMLIM=GMWSQ
+ IF (EMMX.LT.RMASS(198)) EMLIM=EMLIM+(EMWSQ-EMMX**2)**2
+ 50 CALL HWDTHR(PHEP(1,IHEP),PHEP(1,MHEP),
+ & PHEP(1,KHEP),PHEP(1,NHEP),HWDWWT)
+ CALL HWVSUM(4,PHEP(1,KHEP),PHEP(1,MHEP),PW)
+ PW(5)=HWULDO(PW,PW)
+ EMTST=(EMWSQ-PW(5))**2
+ IF ((EMTST+GMWSQ)*HWR().GT.EMLIM) GOTO 50
+ PW(5)=SQRT(PW(5))
+C Assign production vertices to 1 and 2
+ CALL HWUDKL(198,PW,VHEP(1,KHEP))
+ CALL HWVSUM(4,VHEP(1,NHEP),VHEP(1,KHEP),VHEP(1,KHEP))
+ ELSEIF(NME(IM).EQ.300) THEN
+C Generate momenta using 3-body RPV matrix element
+ CALL HWDRME(LHEP,KHEP)
+ ELSE
+C Three body phase space decay
+ CALL HWDTHR(PHEP(1,IHEP),PHEP(1,MHEP),
+ & PHEP(1,KHEP),PHEP(1,NHEP),HWDPWT)
+ ENDIF
+ CALL HWVEQU(4,VHEP(1,KHEP),VHEP(1,MHEP))
+ ELSEIF(NPR.EQ.4) THEN
+C Four body decay: LHEP -> KHEP + RHEP + MHEP + NHEP
+ KHEP = MHEP
+ RHEP = MHEP+1
+ MHEP = MHEP+2
+C Provisional colour connections of KHEP and RHEP
+ JMOHEP(2,KHEP)=RHEP
+ JDAHEP(2,KHEP)=RHEP
+ JMOHEP(2,RHEP)=KHEP
+ JDAHEP(2,RHEP)=KHEP
+C Four body phase space decay
+ CALL HWDFOR(PHEP(1,IHEP),PHEP(1,KHEP),PHEP(1,RHEP),
+ & PHEP(1,MHEP),PHEP(1,NHEP))
+ CALL HWVEQU(4,VHEP(1,KHEP),VHEP(1,RHEP))
+ CALL HWVEQU(4,VHEP(1,KHEP),VHEP(1,MHEP))
+ ELSE
+ CALL HWWARN('HWDHOB',102,*999)
+ ENDIF
+C Colour connections
+ IF (ID.EQ.6.OR.ID.EQ.12.OR.(ID.GE.209.AND.ID.LE.212)
+ & .OR.(ID.GE.215.AND.ID.LE.218)) THEN
+ IF (NPR.EQ.3.AND.NME(IM).EQ.100) THEN
+C usual heavy quark decay
+ JMOHEP(2,KHEP)=MHEP
+ JDAHEP(2,KHEP)=MHEP
+ JMOHEP(2,MHEP)=KHEP
+ JDAHEP(2,MHEP)=KHEP
+ JMOHEP(2,NHEP)=LHEP
+ JDAHEP(2,NHEP)=LHEP
+ ELSEIF (ABS(IDHEP(MHEP)).EQ.37) THEN
+C heavy quark to charged Higgs
+ JMOHEP(2,MHEP)=MHEP
+ JDAHEP(2,MHEP)=MHEP
+ JMOHEP(2,NHEP)=LHEP
+ JDAHEP(2,NHEP)=LHEP
+ ELSEIF (ABS(IDHEP(NHEP)).EQ.37) THEN
+ JMOHEP(2,MHEP)=LHEP
+ JDAHEP(2,MHEP)=LHEP
+ JMOHEP(2,NHEP)=NHEP
+ JDAHEP(2,NHEP)=NHEP
+ ELSE
+ CALL HWWARN('HWDHOB',103,*999)
+ ENDIF
+ ELSE
+ IF(.NOT.RPARTY.AND.
+ & ((NPR.EQ.2.AND.ID.GE.401.AND.ID.LT.448.AND.
+ & IDHW(MHEP).LE.132.AND.IDHW(NHEP).LE.132)
+ & .OR.(NPR.EQ.3.AND.ID.GE.449.AND.ID.LE.457.AND.
+ & IDHW(MHEP).LE.132.AND.IDHW(NHEP).LE.132.AND.
+ & IDHW(MHEP-1).LE.132))) THEN
+C R-parity violating SUSY decays
+ IF(NPR.EQ.2) THEN
+C--Rparity slepton colour connections
+ IF(ID.GE.425.AND.ID.LE.448) THEN
+ IF(IDHW(MHEP).GT.12) THEN
+ JMOHEP(2,MHEP) = MHEP
+ JDAHEP(2,MHEP) = MHEP
+ JMOHEP(2,NHEP) = NHEP
+ JDAHEP(2,NHEP) = NHEP
+ ELSE
+ JMOHEP(2,MHEP) = NHEP
+ JDAHEP(2,MHEP) = NHEP
+ JMOHEP(2,NHEP) = MHEP
+ JDAHEP(2,NHEP) = MHEP
+ ENDIF
+C--Rparity squark colour connections
+ ELSE
+ IF(IDHEP(LHEP).GT.0) THEN
+C--LQD decay colour connections
+ IF(IDHW(MHEP).GT.12) THEN
+ JMOHEP(2,MHEP) = MHEP
+ JDAHEP(2,MHEP) = MHEP
+ JMOHEP(2,NHEP) = LHEP
+ JDAHEP(2,NHEP) = LHEP
+ ELSE
+C--UDD decay colour connections
+ HVFCEN = .TRUE.
+ CALL HWDRCL(LHEP,MHEP,CLSAVE)
+ ENDIF
+ ELSE
+C--Antisquark connections
+ IF(IDHW(MHEP).GT.12) THEN
+ JMOHEP(2,MHEP) = MHEP
+ JDAHEP(2,MHEP) = MHEP
+ JMOHEP(2,NHEP) = LHEP
+ JDAHEP(2,NHEP) = LHEP
+ ELSE
+ HVFCEN = .TRUE.
+ CALL HWDRCL(LHEP,MHEP,CLSAVE)
+ ENDIF
+ ENDIF
+ ENDIF
+ ELSE
+ IF(ID.GE.450.AND.ID.LE.457) THEN
+C--Rparity Neutralino/Chargino colour connection
+ IF(IDHW(MHEP-1).LE.12.AND.IDHW(MHEP).LE.12.
+ & AND.IDHW(NHEP).LE.12) THEN
+ HVFCEN = .TRUE.
+ CALL HWDRCL(LHEP,MHEP,CLSAVE)
+ ELSE
+ JMOHEP(2,MHEP) = NHEP
+ JDAHEP(2,MHEP) = NHEP
+ JMOHEP(2,NHEP) = MHEP
+ JDAHEP(2,NHEP) = MHEP
+ ENDIF
+C--Rparity gluino colour connections
+ ELSEIF(ID.EQ.449) THEN
+ IF(IDHW(MHEP-1).LE.12.AND.IDHW(MHEP).LE.12.
+ & AND.IDHW(NHEP).LE.12) THEN
+ HVFCEN = .TRUE.
+ CALL HWDRCL(LHEP,MHEP,CLSAVE)
+C--Now the lepton number violating decay
+ ELSE
+ IF(IDHW(MHEP).LE.6) THEN
+ JMOHEP(2,MHEP) = LHEP
+ JDAHEP(2,MHEP) = NHEP
+ JMOHEP(2,NHEP) = MHEP
+ JDAHEP(2,NHEP) = LHEP
+ ELSE
+ JMOHEP(2,MHEP) = NHEP
+ JDAHEP(2,MHEP) = LHEP
+ JMOHEP(2,NHEP) = LHEP
+ JDAHEP(2,NHEP) = MHEP
+ ENDIF
+ ENDIF
+ ELSE
+ CALL HWWARN('HWDHOB',104,*999)
+ ENDIF
+ ENDIF
+ ELSE
+C Normal SUSY decays
+ IF (ID.LE.448.AND.ID.GT.207) THEN
+C Squark (or slepton)
+ IF (IDHW(MHEP).EQ.449) THEN
+ IF (IDHEP(LHEP).GT.0) THEN
+ JMOHEP(2,MHEP)=LHEP
+ JDAHEP(2,MHEP)=NHEP
+ JMOHEP(2,NHEP)=MHEP
+ JDAHEP(2,NHEP)=LHEP
+ ELSE
+ JMOHEP(2,MHEP)=NHEP
+ JDAHEP(2,MHEP)=LHEP
+ JMOHEP(2,NHEP)=LHEP
+ JDAHEP(2,NHEP)=MHEP
+ ENDIF
+ ELSE
+ IF(NPR.EQ.3.AND.IDHW(MHEP).LE.12) THEN
+ JMOHEP(2,MHEP)=NHEP
+ JDAHEP(2,MHEP)=NHEP
+ JMOHEP(2,NHEP)=MHEP
+ JDAHEP(2,NHEP)=MHEP
+ ELSE
+ JMOHEP(2,MHEP)=MHEP
+ JDAHEP(2,MHEP)=MHEP
+ JMOHEP(2,NHEP)=LHEP
+ JDAHEP(2,NHEP)=LHEP
+ ENDIF
+ ENDIF
+ ELSEIF (ID.EQ.449) THEN
+C Gluino
+ IF (IDHW(NHEP).EQ.13) THEN
+ JMOHEP(2,MHEP)=MHEP
+ JDAHEP(2,MHEP)=MHEP
+ JMOHEP(2,NHEP)=LHEP
+ JDAHEP(2,NHEP)=LHEP
+ ELSEIF (IDHEP(MHEP).GT.0) THEN
+ JMOHEP(2,MHEP)=LHEP
+ JDAHEP(2,MHEP)=NHEP
+ JMOHEP(2,NHEP)=MHEP
+ JDAHEP(2,NHEP)=LHEP
+ ELSE
+ JMOHEP(2,MHEP)=NHEP
+ JDAHEP(2,MHEP)=LHEP
+ JMOHEP(2,NHEP)=LHEP
+ JDAHEP(2,NHEP)=MHEP
+ ENDIF
+ ELSE
+C Gaugino or Higgs
+ JMOHEP(2,MHEP)=NHEP
+ JDAHEP(2,MHEP)=NHEP
+ JMOHEP(2,NHEP)=MHEP
+ JDAHEP(2,NHEP)=MHEP
+ ENDIF
+ ENDIF
+ ENDIF
+C---SPECIAL CASE FOR THREE-BODY TOP DECAYS:
+C RELABEL THEM AS TWO TWO-BODY DECAYS FOR PARTON SHOWERING
+ IF ((ID.EQ.6.OR.ID.EQ.12).AND.NPR.EQ.3.AND.NME(IM).EQ.100) THEN
+C---STORE W DECAY PRODUCTS
+ CALL HWVEQU(10,PHEP(1,KHEP),PDW)
+C---BOOST THEM INTO W REST FRAME
+ CALL HWULOF(PW,PDW(1,1),PDW(1,3))
+C---REPLACE THEM BY W
+ CALL HWVEQU(5,PW,PHEP(1,KHEP))
+ WHEP=KHEP
+ IDHW(KHEP)=198
+ IF (ID.EQ.12) IDHW(KHEP)=199
+ IDHEP(KHEP)=IDPDG(IDHW(KHEP))
+ JMOHEP(2,KHEP)=KHEP
+ JDAHEP(2,KHEP)=KHEP
+ CALL HWVEQU(4,VHEP(1,NHEP),VHEP(1,KHEP))
+C---AND MOVE B UP
+ CALL HWVEQU(5,PHEP(1,NHEP),PHEP(1,MHEP))
+ IDHW(MHEP)=IDHW(NHEP)
+ IDHEP(MHEP)=IDHEP(NHEP)
+ JDAHEP(2,LHEP)=MHEP
+ JMOHEP(2,MHEP)=JMOHEP(2,NHEP)
+ JDAHEP(2,MHEP)=JDAHEP(2,NHEP)
+ CALL HWVEQU(4,VHEP(1,NHEP),VHEP(1,MHEP))
+ NHEP=MHEP
+C---DO PARTON SHOWER
+ EMSCA=PHEP(5,IHEP)
+ CALL HWBGEN
+ IF (IERROR.NE.0) RETURN
+C---FIND BOOSTED W MOMENTUM
+ NTRY=0
+ 41 NTRY=NTRY+1
+ IF (NTRY.GT.NHEP.OR.WHEP.LE.0.OR.WHEP.GT.NHEP)
+ $ CALL HWWARN('HWDHOB',101,*999)
+ WHEP=JDAHEP(1,WHEP)
+ IF (ISTHEP(WHEP).NE.190) GOTO 41
+C---AND HENCE ITS CHILDRENS MOMENTA
+ CALL HWULOB(PHEP(1,WHEP),PDW(1,3),PHEP(1,NHEP+1))
+ CALL HWVDIF(4,PHEP(1,WHEP),PHEP(1,NHEP+1),PHEP(1,NHEP+2))
+ PHEP(5,NHEP+2)=PDW(5,2)
+C---LABEL THEM
+ ISTHEP(WHEP)=195
+ DO 51 I=1,2
+ IDHW(NHEP+I)=IDKPRD(I,IM)
+ IDHEP(NHEP+I)=IDPDG(IDHW(NHEP+I))
+ ISTHEP(NHEP+I)=112+I
+ JDAHEP(I,WHEP)=NHEP+I
+ JMOHEP(1,NHEP+I)=WHEP
+ JMOHEP(2,NHEP+I)=NHEP+3-I
+ JDAHEP(2,NHEP+I)=NHEP+3-I
+ 51 CONTINUE
+ NHEP=NHEP+2
+C---ASSIGN PRODUCTION VERTICES TO 1 AND 2
+ CALL HWUDKL(198,PW,VHEP(1,NHEP))
+ CALL HWVSUM(4,VHEP(1,WHEP),VHEP(1,NHEP),VHEP(1,NHEP))
+ CALL HWVEQU(4,VHEP(1,NHEP),VHEP(1,NHEP-1))
+C---DO PARTON SHOWERS
+ EMSCA=PW(5)
+ CALL HWBGEN
+ IF (IERROR.NE.0) RETURN
+ ELSE
+C Do parton showers
+ EMSCA=PHEP(5,IHEP)
+ CALL HWBGEN
+ IF (IERROR.NE.0) RETURN
+ ENDIF
+ ENDIF
+C--New to correct colour connections in Rslash
+ IF(CLSAVE(1).NE.0) THEN
+ THEP = MHEP+1
+ ID = IDHW(CLSAVE(1))
+ IDM = IDHW(JMOHEP(1,CLSAVE(1)))
+ IDM2 = IDHW(LHEP)
+ IF(IDM.EQ.15) ID=IDHW(JMOHEP(1,JMOHEP(1,CLSAVE(1))))
+ IF((ID.LE.6.AND.((IDM.GE.419.AND.IDM.LE.424).OR.IDM.EQ.411.OR.
+ & IDM.EQ.412).
+ & AND.((IDM2.GE.413.AND.IDM2.LE.418)
+ & .OR.IDM2.EQ.449).OR.IDM2.EQ.405.OR.IDM2.EQ.406)
+ & .OR.(ID.LE.6.AND.IDM.EQ.449.AND.
+ & (((IDM2.GE.413.AND.IDM2.LE.418).OR.IDM2.EQ.405.OR.IDM2.EQ.406)
+ & .OR.IDM2.EQ.449)).OR.
+ & (IDM.EQ.15.AND.ID.LE.12.AND.ID.GE.7.AND.((IDM2.GE.413.AND.
+ & IDM2.LE.418).OR.IDM2.EQ.449.OR.IDM2.
+ & EQ.405.OR.IDM2.EQ.406))) THEN
+ IF(JMOHEP(2,CLSAVE(1)).EQ.MHEP) THEN
+ IF(IDHW(CLSAVE(1)).NE.13.AND.IDHW(CLSAVE(1)).NE.449)
+ & JMOHEP(2,CLSAVE(2)) = THEP
+ JDAHEP(2,MHEP) = CLSAVE(1)
+ JDAHEP(2,THEP) = CLSAVE(2)
+ ELSE
+ IF(IDHW(CLSAVE(1)).NE.13.AND.IDHW(CLSAVE(1)).NE.449)
+ & JMOHEP(2,CLSAVE(2)) = MHEP
+ JDAHEP(2,MHEP) = CLSAVE(2)
+ JDAHEP(2,THEP) = CLSAVE(1)
+ ENDIF
+ ELSEIF((ID.GT.6.AND.ID.LE.12.
+ & AND.((IDM.GE.413.AND.IDM.LE.418).OR.IDM.EQ.405.OR.
+ & IDM.EQ.406).AND.
+ & ((IDM2.GE.419.AND.IDM2.LE.424).OR.IDM2.EQ.449.OR.
+ & IDM2.EQ.411.OR.IDM2.EQ.412)).OR.
+ & (ID.GT.6.AND.ID.LE.12.AND.IDM.EQ.449.
+ & AND.((IDM2.GE.419.AND.IDM2.LE.424).OR.IDM2.EQ.449.OR.
+ & IDM2.EQ.411.OR.IDM2.EQ.412)).OR.
+ & (IDM.EQ.15.AND.ID.LE.6.AND.((IDM2.GE.419.AND.
+ & IDM2.LE.424).OR.IDM2.EQ.449.OR.IDM2.EQ.411.OR.
+ & IDM2.EQ.412))) THEN
+ IF(JDAHEP(2,CLSAVE(1)).EQ.MHEP) THEN
+ JDAHEP(2,CLSAVE(2))=THEP
+ JMOHEP(2,MHEP)=CLSAVE(1)
+ JMOHEP(2,THEP)=CLSAVE(2)
+ ELSE
+ JDAHEP(2,CLSAVE(2))=MHEP
+ JMOHEP(2,MHEP)=CLSAVE(2)
+ JMOHEP(2,THEP)=CLSAVE(1)
+ ENDIF
+ ENDIF
+ COLUPD = .FALSE.
+ CALL HWBCON
+ ENDIF
+ IF (IHEP.EQ.NHEP) GOTO 70
+ 60 CONTINUE
+ 70 IF (FOUND) THEN
+C Fix any SUSY colour disconnections
+ DO 80 IHEP=1,NHEP
+ IF (ISTHEP(IHEP).GE.147.AND.ISTHEP(IHEP).LE.151
+ & .AND.JDAHEP(2,IHEP).EQ.0) THEN
+ IM=JMOHEP(1,IHEP)
+C Chase connection back through SUSY decays
+ 75 IM=JMOHEP(1,IM)
+ ISM=ISTHEP(IM)
+ IF (ISM.EQ.120) GOTO 80
+ IF (ISM.NE.123.AND.ISM.NE.124.AND.ISM.NE.155) GOTO 75
+C Look for unclustered parton to connect
+ DO JHEP=1,NHEP
+ IF (ISTHEP(JHEP).GE.147.AND.ISTHEP(JHEP).LE.151) THEN
+ JCM=JMOHEP(2,JHEP)
+ IF (JCM.EQ.IM) THEN
+C Found it: connect
+ JMOHEP(2,JHEP)=IHEP
+ JDAHEP(2,IHEP)=JHEP
+ GOTO 80
+ ENDIF
+ ENDIF
+ ENDDO
+C Not found: need to go further back
+ GOTO 75
+ ENDIF
+ 80 CONTINUE
+C Go back to check for further heavy decay products
+ GOTO 10
+ ENDIF
+ 999 END
+CDECK ID>, HWDHVY.
+*CMZ :- -26/04/91 12.19.24 by Federico Carminati
+*-- Author : Ian Knowles & Bryan Webber
+C-----------------------------------------------------------------------
+ SUBROUTINE HWDHVY
+C-----------------------------------------------------------------------
+C Performs partonic decays of hadrons containing heavy quark(s):
+C either, meson/baryon spectator model weak decays;
+C or, quarkonia -> 2-gluons, q-qbar, 3-gluons, or 2-gluons + photon.
+C-----------------------------------------------------------------------
+ INCLUDE 'HERWIG61.INC'
+ DOUBLE PRECISION HWULDO,HWR,XS,XB,EMWSQ,GMWSQ,EMLIM,PW(4),
+ & EMTST,X1,X2,X3,TEST,HWDWWT,HWDPWT
+ INTEGER IST(3),I,IHEP,IM,ID,IDQ,IQ,IS,J
+ EXTERNAL HWR,HWDWWT,HWDPWT,HWULDO
+ DATA IST/113,114,114/
+ IF (IERROR.NE.0) RETURN
+ DO 100 I=1,NMXQDK
+ IF (I.GT.NQDK) THEN
+ NQDK=0
+ RETURN
+ ENDIF
+ IHEP=LOCQ(I)
+ IF (ISTHEP(IHEP).EQ.199) GOTO 100
+ IM=IMQDK(I)
+ IF (NHEP+NPRODS(IM).GT.NMXHEP) CALL HWWARN('HWDHVY',100,*999)
+ IF (IDKPRD(4,IM).NE.0) THEN
+C Weak decay of meson or baryon
+C Idenitify decaying heavy quark and spectator
+ ID=IDHW(IHEP)
+ IF (ID.EQ.136.OR.ID.EQ.140.OR.ID.EQ.144.OR.
+ & ID.EQ.150.OR.ID.EQ.155.OR.ID.EQ.158.OR.ID.EQ.161.OR.
+ & (ID.EQ.254.AND.IDKPRD(4,IM).EQ.11)) THEN
+C c hadron or c decay of B_c+
+ IDQ=4
+ IQ=NHEP+1
+ IS=NHEP+2
+ ELSEIF (ID.EQ.171.OR.ID.EQ.175.OR.ID.EQ.179.OR.
+ & ID.EQ.185.OR.ID.EQ.190.OR.ID.EQ.194.OR.ID.EQ.196.OR.
+ & (ID.EQ.230.AND.IDKPRD(4,IM).EQ.5)) THEN
+C cbar hadron or cbar decay of B_c-
+ IDQ=10
+ IS=NHEP+1
+ IQ=NHEP+2
+ ELSEIF ((ID.GE.221.AND.ID.LE.229).OR.
+ & (ID.EQ.230.AND.IDKPRD(4,IM).EQ.10)) THEN
+C b hadron or b decay of B_c-
+ IDQ=5
+ IQ=NHEP+1
+ IS=NHEP+2
+ ELSEIF ((ID.GE.245.AND.ID.LE.253).OR.
+ & (ID.EQ.254.AND.IDKPRD(4,IM).EQ.4)) THEN
+C bbar hadron or bbar decay of B_c+
+ IDQ=11
+ IS=NHEP+1
+ IQ=NHEP+2
+ ELSE
+C Decay not recognized
+ CALL HWWARN('HWDHVY',101,*999)
+ ENDIF
+C Label constituents
+ IF (NHEP+5.GT.NMXHEP) CALL HWWARN('HWDHVY',102,*999)
+ ISTHEP(IHEP)=199
+ JDAHEP(1,IHEP)=NHEP+1
+ JDAHEP(2,IHEP)=NHEP+2
+ IDHW(IQ)=IDQ
+ IDHW(IS)=IDKPRD(4,IM)
+ IDHEP(IQ)=IDPDG(IDQ)
+ IDHEP(IS)=IDPDG(IDKPRD(4,IM))
+ ISTHEP(IQ)=155
+ ISTHEP(IS)=115
+ JMOHEP(1,IQ)=IHEP
+ JMOHEP(2,IQ)=IS
+ JDAHEP(1,IQ)=NHEP+3
+ JDAHEP(2,IQ)=NHEP+5
+ JMOHEP(1,IS)=IHEP
+ JMOHEP(2,IS)=NHEP+5
+ JDAHEP(1,IS)=0
+ JDAHEP(2,IS)=NHEP+5
+ NHEP=NHEP+2
+C and weak decay product jets
+ DO 10 J=1,3
+ NHEP=NHEP+1
+ IDHW(NHEP)=IDKPRD(J,IM)
+ IDHEP(NHEP)=IDPDG(IDKPRD(J,IM))
+ ISTHEP(NHEP)=IST(J)
+ JMOHEP(1,NHEP)=IQ
+ JDAHEP(1,NHEP)=0
+ 10 PHEP(5,NHEP)=RMASS(IDKPRD(J,IM))
+ JMOHEP(2,NHEP-2)=NHEP-1
+ JDAHEP(2,NHEP-2)=NHEP-1
+ JMOHEP(2,NHEP-1)=NHEP-2
+ JDAHEP(2,NHEP-1)=NHEP-2
+ JMOHEP(2,NHEP )=IQ
+ JDAHEP(2,NHEP )=IQ
+C Share momenta in ratio of masses, preserving specator mass
+ XS=RMASS(IDHW(IS))/PHEP(5,IHEP)
+ XB=ONE-XS
+ CALL HWVSCA(5,XB,PHEP(1,IHEP),PHEP(1,IQ))
+ CALL HWVSCA(5,XS,PHEP(1,IHEP),PHEP(1,IS))
+ IF (NME(IM).EQ.100) THEN
+C Generate decay momenta using full (V-A)*(V-A) matrix element
+ EMWSQ=RMASS(198)**2
+ GMWSQ=(RMASS(198)*GAMW)**2
+ EMLIM=GMWSQ+(EMWSQ-(PHEP(5,IQ)-PHEP(5,NHEP))**2)**2
+ 20 CALL HWDTHR(PHEP(1,IQ ),PHEP(1,NHEP-1),
+ & PHEP(1,NHEP-2),PHEP(1,NHEP),HWDWWT)
+ CALL HWVSUM(4,PHEP(1,NHEP-2),PHEP(1,NHEP-1),PW)
+ EMTST=(HWULDO(PW,PW)-EMWSQ)**2
+ IF ((EMTST+GMWSQ)*HWR().GT.EMLIM) GOTO 20
+ ELSE
+C Use phase space
+ CALL HWDTHR(PHEP(1,IQ ),PHEP(1,NHEP-2),
+ & PHEP(1,NHEP-1),PHEP(1,NHEP),HWDPWT)
+ CALL HWVSUM(4,PHEP(1,NHEP-2),PHEP(1,NHEP-1),PW)
+ ENDIF
+C Set up production vertices
+ CALL HWVZRO(4,VHEP(1,IQ))
+ CALL HWVEQU(4,VHEP(1,IQ),VHEP(1,IS))
+ CALL HWVEQU(4,VHEP(1,IQ),VHEP(1,NHEP))
+ CALL HWUDKL(198,PW,VHEP(1,NHEP-2))
+ CALL HWVSUM(4,VHEP(1,IQ),VHEP(1,NHEP-2),VHEP(1,NHEP-2))
+ CALL HWVEQU(4,VHEP(1,NHEP-2),VHEP(1,NHEP-1))
+ EMSCA=PHEP(5,IQ)
+ ELSE
+C Quarkonium decay
+C Label products
+ ISTHEP(IHEP)=199
+ JDAHEP(1,IHEP)=NHEP+1
+ DO 30 J=1,NPRODS(IM)
+ NHEP=NHEP+1
+ IDHW(NHEP)=IDKPRD(J,IM)
+ IDHEP(NHEP)=IDPDG(IDKPRD(J,IM))
+ ISTHEP(NHEP)=IST(J)
+ JMOHEP(1,NHEP)=IHEP
+ JDAHEP(1,NHEP)=0
+ PHEP(5,NHEP)=RMASS(IDKPRD(J,IM))
+ 30 CALL HWVZRO(4,VHEP(1,NHEP))
+ JDAHEP(2,IHEP)=NHEP
+C Establish colour connections and select momentum configuration
+ IF (NPRODS(IM).EQ.3) THEN
+ IF (IDKPRD(3,IM).EQ.13) THEN
+C 3-gluon decay
+ JMOHEP(2,NHEP-2)=NHEP
+ JMOHEP(2,NHEP-1)=NHEP-2
+ JMOHEP(2,NHEP )=NHEP-1
+ JDAHEP(2,NHEP-2)=NHEP-1
+ JDAHEP(2,NHEP-1)=NHEP
+ JDAHEP(2,NHEP )=NHEP-2
+ ELSE
+C or 2-gluon + photon decay
+ JMOHEP(2,NHEP-2)=NHEP-1
+ JMOHEP(2,NHEP-1)=NHEP-2
+ JMOHEP(2,NHEP )=NHEP
+ JDAHEP(2,NHEP-2)=NHEP-1
+ JDAHEP(2,NHEP-1)=NHEP-2
+ JDAHEP(2,NHEP )=NHEP
+ ENDIF
+ IF (NME(IM).EQ.130) THEN
+C Use Ore & Powell orthopositronium matrix element
+ 40 CALL HWDTHR(PHEP(1,IHEP),PHEP(1,NHEP-2),
+ & PHEP(1,NHEP-1),PHEP(1,NHEP),HWDPWT)
+ X1=TWO*HWULDO(PHEP(1,IHEP),PHEP(1,NHEP-2))/PHEP(5,IHEP)**2
+ X2=TWO*HWULDO(PHEP(1,IHEP),PHEP(1,NHEP-1))/PHEP(5,IHEP)**2
+ X3=TWO-X1-X2
+ TEST=((X1*(ONE-X1))**2+(X2*(ONE-X2))**2+(X3*(ONE-X3))**2)
+ & /(X1*X2*X3)**2
+ IF (TEST.LT.TWO*HWR()) GOTO 40
+ ELSE
+C Use phase space
+ CALL HWDTHR(PHEP(1,IHEP),PHEP(1,NHEP-2),
+ & PHEP(1,NHEP-1),PHEP(1,NHEP),HWDPWT)
+ ENDIF
+ ELSE
+C Parapositronium 2-gluon or q-qbar decay
+ JMOHEP(2,NHEP-1)=NHEP
+ JMOHEP(2,NHEP )=NHEP-1
+ JDAHEP(2,NHEP-1)=NHEP
+ JDAHEP(2,NHEP )=NHEP-1
+ CALL HWDTWO(PHEP(1,IHEP),PHEP(1,NHEP-1),
+ & PHEP(1,NHEP),CMMOM(IM),TWO,.FALSE.)
+ ENDIF
+ EMSCA=PHEP(5,IHEP)
+ ENDIF
+C Process this new hard scatter
+ CALL HWVEQU(4,VTXQDK(1,I),VTXPIP)
+ CALL HWBGEN
+ CALL HWCFOR
+ CALL HWCDEC
+ CALL HWDHAD
+ 100 CONTINUE
+ NQDK=0
+ 999 END
+CDECK ID>, HWDRCL.
+*CMZ :- -20/07/99 10:56:12 by Peter Richardson
+*-- Author : Peter Richardson
+C-----------------------------------------------------------------------
+ SUBROUTINE HWDRCL(IHEP,MHEP,CLSAVE)
+C-----------------------------------------------------------------------
+C Sets the colour connections in Baryon number violating decays
+C-----------------------------------------------------------------------
+ INCLUDE 'HERWIG61.INC'
+ INTEGER IHEP,MHEP,ID,ID2,IDM2,IDM3,COLCON(2,2,3),FLACON(2,3),JHEP,
+ & DECAY,COLANT,KHEP,IDM,IDMB,IDMB2,IDMB3,IDMB4,QHEP,IDM4,
+ & CLSAVE(2),XHEP,I,HWRINT,THEP
+ LOGICAL CONBV
+C--Colour connections for the decays
+ DATA COLCON/-1,1,-1,-2,-2,1,-3,-1,-1,1,-2,-1/
+ DATA FLACON/1,-1,1,-1,-1,0/
+C--identify the decay
+ IF(IERROR.NE.0) RETURN
+ ID = IDHW(IHEP)
+ ID2 = IDHW(MHEP)
+ IF(ID.GE.450.AND.ID.LE.457) THEN
+ DECAY = 1
+ ELSEIF(ID.EQ.449) THEN
+ DECAY = 2
+ ELSEIF((ID.GE.411.AND.ID.LE.424).OR.ID.EQ.405.OR.ID.EQ.406) THEN
+ DECAY = 3
+ ELSE
+C--UNKNOWN DECAY
+ CALL HWWARN('HWDRCL',100,*999)
+ ENDIF
+ COLANT = 1
+C--identify the colour partner
+ IF(DECAY.GT.1.AND.ID2.LE.6) THEN
+C--colour partner
+ COLANT = 2
+ KHEP = JDAHEP(2,IHEP-1)
+ ELSEIF(DECAY.GT.1.AND.ID2.GE.7) THEN
+C--anticolour partner
+ COLANT = 3
+ KHEP = JMOHEP(2,IHEP)
+ ELSE
+ KHEP=IHEP
+ ENDIF
+ IDM = IDHW(JMOHEP(1,KHEP))
+ IF(ABS(IDPDG(IDM)).GT.1000000.OR.IDM.EQ.15) THEN
+ IDM2 = IDHW(JDAHEP(1,JMOHEP(1,KHEP)))
+ IDM3 = IDHW(JDAHEP(2,JMOHEP(1,KHEP)))
+ IDM4 = IDHW(JDAHEP(2,JMOHEP(1,KHEP))-1)
+ QHEP = JMOHEP(1,KHEP)
+ IDMB = IDHW(JMOHEP(1,QHEP))
+ IDMB2 = IDHW(JMOHEP(2,QHEP))
+ IDMB3 = IDHW(JDAHEP(1,QHEP))
+ IDMB4 = IDHW(JDAHEP(2,QHEP))
+ ENDIF
+C--Now decide if the colour partner decayed via BV
+ IF(COLANT.EQ.2.AND.((((IDM.GE.413.AND.IDM.LE.418).OR.
+ & IDM.EQ.449.OR.IDM.EQ.405.OR.IDM.EQ.406).AND.
+ & (IDM2.GE.7.AND.IDM2.LE.12.AND.
+ & IDM3.GE.7.AND.IDM3.LE.12.AND.
+ & IDM4.GE.7.AND.IDM4.LE.12)).OR.
+ & (IDM.EQ.15.AND.IDMB.LE.6.AND.IDMB2.LE.6.AND.
+ & ((IDMB3.GE.7.AND.IDMB4.GE.12.AND.IDMB4.EQ.449).OR.
+ & (IDMB3.GE.198.AND.IDMB3.LE.207.AND.
+ & ABS(IDPDG(IDMB4)).GT.1000000))))) THEN
+ CONBV = .TRUE.
+ COLUPD = .TRUE.
+ HVFCEN = .FALSE.
+ XHEP = JMOHEP(2,JDAHEP(2,JMOHEP(1,KHEP)))
+ ELSEIF(COLANT.EQ.3.AND.((((IDM.GE.419.AND.IDM.LE.424).OR.
+ & IDM.EQ.449.OR.IDM.EQ.411.OR.IDM.EQ.412).AND.
+ & (IDM2.LE.6.AND.IDM3.LE.6.AND.IDM4.LE.6)).OR.
+ & (IDM.EQ.15.AND.IDMB.GE.7.AND.IDMB.LE.12.AND.
+ & IDMB2.GE.7.AND.IDMB2.LE.12.AND.((IDMB3.LE.6.AND.
+ & IDMB4.EQ.449).OR.(ABS(IDPDG(IDMB4)).GT.1000000
+ & .AND.IDMB3.GE.198.AND.IDMB3.LE.207))))) THEN
+ CONBV = .TRUE.
+ COLUPD = .TRUE.
+ HVFCEN = .FALSE.
+ XHEP = JDAHEP(2,JDAHEP(2,JMOHEP(1,KHEP)))
+ ELSE
+ CONBV = .FALSE.
+ COLUPD = .FALSE.
+ XHEP = 0
+ ENDIF
+ IF(CONBV) THEN
+ IF(IDM.NE.15) THEN
+ CLSAVE(1) = JDAHEP(2,JMOHEP(1,KHEP))-1
+ CLSAVE(2) = CLSAVE(1)+1
+ ELSE
+ IF(IDMB4.EQ.449) THEN
+ DO I=1,2
+ CLSAVE(I) = JMOHEP(I,JMOHEP(1,KHEP))
+ IF(CLSAVE(I).EQ.XHEP) CLSAVE(I)=JDAHEP(1,JMOHEP(1,KHEP))
+ ENDDO
+ ELSE
+ CLSAVE(1) = JMOHEP(1,JMOHEP(1,KHEP))
+ CLSAVE(2) = JMOHEP(2,JMOHEP(1,KHEP))
+ ENDIF
+ ENDIF
+ ELSE
+ CLSAVE(1)=0
+ CLSAVE(2)=0
+ ENDIF
+C--Now set the colours for angular ordering
+ THEP = MHEP-1
+ IF(DECAY.EQ.1) THEN
+ IF(ID2.LE.6) THEN
+ JMOHEP(2,THEP) = THEP+HWRINT(1,2)
+ JDAHEP(2,THEP) = THEP
+ ELSE
+ JMOHEP(2,THEP) = THEP
+ JDAHEP(2,THEP) = THEP+HWRINT(1,2)
+ ENDIF
+ ELSEIF(DECAY.EQ.2) THEN
+ IF(ID2.LE.6) THEN
+ JMOHEP(2,THEP) = IHEP
+ JDAHEP(2,THEP) = THEP
+ ELSE
+ JMOHEP(2,THEP) = THEP
+ JDAHEP(2,THEP) = IHEP
+ ENDIF
+ ENDIF
+C--Colour of the second two
+ DO JHEP=1,2
+ IF(ID2.LE.6) THEN
+ JMOHEP(2,MHEP+JHEP-1) = MHEP+JHEP-1+
+ & COLCON(HWRINT(1,2),JHEP,DECAY)
+ JDAHEP(2,MHEP+JHEP-1) = MHEP+JHEP-1+FLACON(JHEP,DECAY)
+ ELSE
+ JDAHEP(2,MHEP+JHEP-1) = MHEP+JHEP-1+
+ & COLCON(HWRINT(1,2),JHEP,DECAY)
+ JMOHEP(2,MHEP+JHEP-1) = MHEP+JHEP-1+FLACON(JHEP,DECAY)
+ ENDIF
+ ENDDO
+C--Now set the colours of the colour partner
+ IF(DECAY.GT.1.AND..NOT.CONBV) THEN
+ IF(ID2.LE.6) JMOHEP(2,KHEP) = MHEP+HWRINT(0,1)
+ IF(ID2.GE.7) JDAHEP(2,KHEP) = MHEP+HWRINT(0,1)
+ ELSEIF(CONBV) THEN
+ IF(ID2.GT.6) THEN
+ JMOHEP(2,CLSAVE(1)) = MHEP+HWRINT(0,1)
+ IF(JMOHEP(2,CLSAVE(1)).EQ.MHEP) THEN
+ JMOHEP(2,CLSAVE(2)) = MHEP+1
+ ELSE
+ JMOHEP(2,CLSAVE(2)) = MHEP
+ ENDIF
+ ELSE
+ JDAHEP(2,CLSAVE(1)) = MHEP+HWRINT(0,1)
+ IF(JDAHEP(2,CLSAVE(1)).EQ.MHEP) THEN
+ JDAHEP(2,CLSAVE(2)) = MHEP+1
+ ELSE
+ JDAHEP(2,CLSAVE(2)) = MHEP
+ ENDIF
+ ENDIF
+ ENDIF
+ 999 END
+CDECK ID>, HWDRME.
+*CMZ :- -20/07/99 10:56:12 by Peter Richardson
+*-- Author : Peter Richardson
+C-----------------------------------------------------------------------
+ SUBROUTINE HWDRME(LHEP,MHEP)
+C-----------------------------------------------------------------------
+C SUBROUTINE TO IMPLEMENT ALL RPARITY DECAY MATRIX ELEMENTS
+C-----------------------------------------------------------------------
+ INCLUDE 'HERWIG61.INC'
+ DOUBLE PRECISION SM(6),SW(6),HWULDO,INFCOL,AM, M12SQ,M23SQ,MSGN,
+ & M13SQ,A(6),B(6),SWEAK,MW,DECMOM(5),TEST(4),EPS,
+ & M12SQT(6),M23SQT(6),M13SQT(6),LIMIT,M(4),RAND,
+ & MC(2),MX2(6),MX(6),HWDPWT,HWR,HWDRM1,LAMD(3)
+ EXTERNAL HWDRM1,HWULDO,HWDPWT,HWR
+ INTEGER K,SN(3),LHEP,CSP,I,SB(3),J,ND,LTRY,MHEP,NSP,ID(3),IG,
+ & IDHWTP,IDHPTP,MTRY
+ PARAMETER(EPS=1D-20)
+ IF(IERROR.NE.0) RETURN
+C--Electroweak parameters, etc
+ SWEAK = SQRT(SWEIN)
+ MW = RMASS(198)
+ M(4) = PHEP(5,LHEP)
+ IG = IDHW(LHEP)
+C--Find the masses of the final state and zero parameters
+ DO K=1,3
+ ID(K) = IDHW(MHEP+K-1)
+ IF(ID(K).LE.12) THEN
+ SN(K)=ID(K)
+ ELSE
+ SN(K)=ID(K)-120
+ ENDIF
+ IF(SN(K).GT.6) SN(K)=SN(K)-6
+ M(K) = PHEP(5,LHEP+K)
+ SB(K)=SN(K)
+ LAMD(K) = ZERO
+ ENDDO
+ DO J=1,6
+ MX2(J) = ZERO
+ MX(J) = ZERO
+ M13SQT(J) = ZERO
+ M23SQT(J) = ZERO
+ M12SQT(J) = ZERO
+ ENDDO
+C--Evaluate the coefficents for the mode we want
+ IF(IG.GE.450.AND.IG.LE.453) THEN
+C--NEUTRALINO
+ NSP = IG-449
+ AM = RMASS(IG)
+ MSGN = ZSGNSS(NSP)
+ MC(1) = ZMIXSS(NSP,3)/(2*MW*COSB*SWEAK)
+ MC(2) = ZMIXSS(NSP,4)/(2*MW*SINB*SWEAK)
+C--Calculate the combinations of couplings needed
+ IF(ID(1).LE.12.AND.ID(2).LE.12.AND.ID(3).LE.12) THEN
+C--first for the UDD modes
+ DO J=1,2
+ A(J) = M(1)*MC(2)*QMIXSS(SN(1),2,J)
+ & +SLFCH(SN(1),NSP)*QMIXSS(SN(1),1,J)
+ B(J) = MSGN*(M(1)*MC(2)*QMIXSS(SN(1),1,J)
+ & +SRFCH(SN(1),NSP)*QMIXSS(SN(1),2,J))
+ MX2(J) = QMIXSS(SN(1),2,J)
+ A(J+2) = M(2)*MC(1)*QMIXSS(SN(2),2,J)
+ & +SLFCH(SN(2),NSP)*QMIXSS(SN(2),1,J)
+ B(J+2) = MSGN*(M(2)*MC(1)*QMIXSS(SN(2),1,J)
+ & +SRFCH(SN(2),NSP)*QMIXSS(SN(2),2,J))
+ MX2(J+2) = QMIXSS(SN(2),2,J)
+ A(J+4) = M(3)*MC(1)*QMIXSS(SN(3),2,J)
+ & +SLFCH(SN(3),NSP)*QMIXSS(SN(3),1,J)
+ B(J+4) = MSGN*(M(3)*MC(1)*QMIXSS(SN(3),1,J)
+ & +SRFCH(SN(3),NSP)*QMIXSS(SN(3),2,J))
+ MX2(J+2) = QMIXSS(SN(3),2,J)
+ ENDDO
+ DO K=1,3
+ SN(K) = SN(K)+400
+ SB(K) = SB(K)+412
+ ENDDO
+ ELSEIF(ID(1).GE.121.AND.ID(2).GE.121.AND.ID(3).GE.121) THEN
+C--Now for the LLE modes
+ DO J=1,2
+ A(J) = MSGN*(M(1)*MC(1)*LMIXSS(SN(1),1,J)
+ & +SRFCH(10+SN(1),NSP)*LMIXSS(SN(1),2,J))
+ B(J) = M(1)*MC(1)*LMIXSS(SN(1),2,J)
+ & +SLFCH(10+SN(1),NSP)*LMIXSS(SN(2),1,J)
+ MX2(J)= LMIXSS(SN(1),1,J)
+ A(J+2) = ZERO
+ B(J+2) = SLFCH(10+SN(2),NSP)*LMIXSS(SN(2),1,J)
+ MX2(J+2) = LMIXSS(SN(2),1,J)
+ A(J+4) = M(3)*MC(1)*LMIXSS(SN(3),2,J)
+ & +SLFCH(10+SN(3),NSP)*LMIXSS(SN(3),1,J)
+ B(J+4) = MSGN*(M(3)*MC(1)*LMIXSS(SN(3),1,J)
+ & +SRFCH(10+SN(3),NSP)*LMIXSS(SN(3),2,J))
+ MX2(4+J) = LMIXSS(SN(3),2,J)
+ ENDDO
+ DO J=1,3
+ SN(J) = SN(J) + 424
+ SB(J) = SB(J) + 436
+ ENDDO
+ ELSE
+C--Now for both types of LQD modes
+ IF(MOD(SN(1),2).EQ.0) THEN
+C--First the neutrino,down,antidown mode
+ DO J=1,2
+ A(J) = ZERO
+ B(J) = SLFCH(10+SN(1),NSP)*
+ & LMIXSS(SN(1),1,J)
+ MX2(J) = LMIXSS(SN(1),1,J)
+ A(J+2) = MSGN*(M(2)*MC(1)*QMIXSS(SN(2),1,J)
+ & +SRFCH(SN(2),NSP)*QMIXSS(SN(2),2,J))
+ B(J+2) = M(2)*MC(1)*QMIXSS(SN(2),2,J)
+ & +SLFCH(SN(2),NSP)*QMIXSS(SN(2),1,J)
+ MX2(2+J) = QMIXSS(SN(2),1,J)
+ A(J+4) = M(3)*MC(1)*QMIXSS(SN(3),2,J)
+ & +SLFCH(SN(3),NSP)*QMIXSS(SN(3),1,J)
+ B(J+4) = MSGN*(M(3)*MC(1)*QMIXSS(SN(3),1,J)
+ & +SRFCH(SN(3),NSP)*QMIXSS(SN(3),2,J))
+ MX2(J+4) = QMIXSS(SN(3),2,J)
+ ENDDO
+ ELSE
+C--Now the charged lepton, antiup,down modes
+ DO J=1,2
+ A(J) = MSGN*(M(1)*MC(1)*LMIXSS(SN(1),1,J)
+ & +SRFCH(10+SN(1),NSP)*LMIXSS(SN(1),2,J))
+ B(J) = M(1)*MC(1)*LMIXSS(SN(1),2,J)
+ & +SLFCH(10+SN(1),NSP)*LMIXSS(SN(1),1,J)
+ MX2(J) = LMIXSS(SN(1),1,J)
+ A(J+2) =MSGN*(M(2)*MC(2)*QMIXSS(SN(2),1,J)
+ & +SRFCH(SN(2),NSP)*QMIXSS(SN(2),2,J))
+ B(J+2) = M(2)*MC(2)*QMIXSS(SN(2),2,J)
+ & +SLFCH(SN(2),NSP)*QMIXSS(SN(2),1,J)
+ MX2(2+J) = QMIXSS(SN(2),1,J)
+ A(J+4) = M(3)*MC(1)*QMIXSS(SN(3),2,J)
+ & +SLFCH(SN(3),NSP)*QMIXSS(SN(3),1,J)
+ B(J+4) = MSGN*(M(3)*MC(1)*QMIXSS(SN(3),1,J)
+ & +SRFCH(SN(3),NSP)*QMIXSS(SN(3),2,J))
+ MX2(J+4) = QMIXSS(SN(3),2,J)
+ ENDDO
+ ENDIF
+ SN(1) = SN(1) + 424
+ SB(1) = SB(1) + 436
+ DO J=2,3
+ SN(J) = SN(J) + 400
+ SB(J) = SB(J) + 412
+ ENDDO
+ ENDIF
+ DO K=1,3
+ SM(2*K-1) = RMASS(SN(K))
+ SM(2*K) = RMASS(SB(K))
+ SW(2*K-1) = HBAR/RLTIM(SN(K))
+ SW(2*K) = HBAR/RLTIM(SB(K))
+ ENDDO
+ ND = 3
+ DO K=1,3
+ LAMD(K) = ONE
+ ENDDO
+ INFCOL = ONE
+ ELSEIF(IG.EQ.449) THEN
+C--GLUINO
+C--First obtian the masses and widths needed
+ AM = RMASS(IG)
+ ND = 3
+C--Calculate the combinations of couplings needed
+ IF(ID(1).LE.12.AND.ID(2).LE.12.AND.ID(3).LE.12) THEN
+C--first for the UDD modes
+ INFCOL = -0.5D0
+C--Couplings
+ DO I=1,3
+ DO J=1,2
+ A(2*I-2+J) = -QMIXSS(SN(I),1,J)
+ B(2*I-2+J) = QMIXSS(SN(I),2,J)
+ MX2(2*I-2+J) = QMIXSS(SN(I),2,J)
+ ENDDO
+ SN(I) = SN(I)+400
+ SB(I) = SB(I)+412
+ ENDDO
+ ELSE
+ INFCOL = ONE
+C--Now for both types of LQD modes
+ IF(MOD(SN(1),2).EQ.0) THEN
+C--First the neutrino,down,antidown mode
+ DO J=1,2
+ A(J) = ZERO
+ B(J) = ZERO
+ MX2(J) = ZERO
+ A(J+2) = QMIXSS(SN(2),2,J)
+ B(J+2) = -QMIXSS(SN(2),1,J)
+ MX2(J+2) = QMIXSS(SN(2),1,J)
+ A(J+4) = -QMIXSS(SN(3),1,J)
+ B(J+4) = QMIXSS(SN(3),2,J)
+ MX2(4+J) = QMIXSS(SN(3),2,J)
+ ENDDO
+ ELSEIF(MOD(SN(1),2).EQ.1) THEN
+C--Now the charged lepton, antiup,down modes
+ DO J=1,2
+ A(J) = ZERO
+ B(J) = ZERO
+ MX2(J) = ZERO
+ A(J+2) = QMIXSS(SN(2),2,J)
+ B(J+2) = -QMIXSS(SN(2),1,J)
+ MX2(J+2) = QMIXSS(SN(2),1,J)
+ A(J+4) = -QMIXSS(SN(3),1,J)
+ B(J+4) = QMIXSS(SN(3),2,J)
+ MX2(J+4) = QMIXSS(SN(3),2,J)
+ ENDDO
+ ENDIF
+ SN(1) = SN(1) + 424
+ SB(1) = SB(1) + 436
+ DO K=2,3
+ SN(K) = SN(K) + 400
+ SB(K) = SB(K) + 412
+ ENDDO
+ ENDIF
+ DO K=1,3
+ SM(2*K-1) = RMASS(SN(K))
+ SM(2*K) = RMASS(SB(K))
+ SW(2*K-1) = HBAR/RLTIM(SN(K))
+ SW(2*K) = HBAR/RLTIM(SB(K))
+ ENDDO
+ DO K=1,3
+ LAMD(K) = ONE
+ ENDDO
+ ELSEIF(IG.GE.454.AND.IG.LE.457) THEN
+C--CHARGINO
+ CSP = IG-453
+ IF(CSP.GT.2) CSP = CSP-2
+ AM = RMASS(IG)
+ INFCOL = -ONE
+ MSGN = WSGNSS(CSP)
+ MC(1) = ONE/(SQRT(2.0D0)*MW*COSB)
+ MC(2) = ONE/(SQRT(2.0D0)*MW*SINB)
+C--Calculate the combinations of the couplings needed
+ IF(ID(1).GT.120.AND.ID(2).GT.120.AND.ID(3).GT.120) THEN
+C--first for the LLE modes, three modes
+ IF(MOD(SN(1),2).EQ.0.AND.MOD(SN(3),2).EQ.0) THEN
+C--the one diagram mode nubar,positron, nu
+ DO J=1,2
+ A(J+4) = LMIXSS(SN(3)-1,1,J)*WMXUSS(CSP,1)
+ & -RMASS(SN(3)+119)*MC(1)*LMIXSS(SN(3)-1,2,J)*WMXUSS(CSP,2)
+ B(J+4) = ZERO
+ MX2(J+4) = LMIXSS(SN(3)-1,2,J)
+ ENDDO
+ ND = 1
+ SN(3) = SN(3)+423
+ SB(3) = SB(3)+435
+ ELSEIF(MOD(SN(1),2).EQ.0.AND.MOD(SN(2),2).EQ.0) THEN
+C--the first two diagram mode nu, nu, positron
+ DO J=1,2
+ A(J) = ZERO
+ B(J) = LMIXSS(SN(1)-1,1,J)*WMXUSS(CSP,1)
+ & -RMASS(SN(1)+119)*MC(1)*LMIXSS(SN(1)-1,2,J)*WMXUSS(CSP,2)
+ A(J+2) = ZERO
+ B(J+2) = LMIXSS(SN(2)-1,1,J)*WMXUSS(CSP,1)
+ & -RMASS(SN(2)+119)*MC(1)*LMIXSS(SN(2)-1,2,J)*WMXUSS(CSP,2)
+ MX2(J) = LMIXSS(SN(1)-1,1,J)
+ MX2(J+2) = LMIXSS(SN(2)-1,1,J)
+ ENDDO
+ ND = 2
+ DO J=1,2
+ SN(J) = SN(J)+423
+ SB(J) = SB(J)+435
+ ENDDO
+ ELSE
+C--the second two diagram mode positron, positron, electron
+ DO J=1,2
+ A(J) = -M(1)*WMXUSS(CSP,2)*MC(1)*LMIXSS(SN(1)+1,1,J)
+ B(J) = MSGN*WMXVSS(CSP,1)*LMIXSS(SN(1)+1,1,J)
+ A(J+2) = -M(2)*WMXUSS(CSP,2)*MC(1)*LMIXSS(SN(2)+1,1,J)
+ B(J+2) = MSGN*WMXVSS(CSP,1)*LMIXSS(SN(2)+1,1,J)
+ MX2(J) = LMIXSS(SN(1)+1,1,J)
+ MX2(J+2) = LMIXSS(SN(2)+1,1,J)
+ ENDDO
+ DO J=1,2
+ SN(J) = SN(J)+425
+ SB(J) = SB(J)+437
+ ENDDO
+ ND = 2
+ ENDIF
+ DO K=1,3
+ LAMD(K) = ONE
+ ENDDO
+ ELSEIF(ID(1).LE.12.AND.ID(2).LE.12.AND.ID(3).LE.12) THEN
+C--now for the UDD
+ IF(MOD(SN(1),2).EQ.0) THEN
+C--two diagram mode
+ LAMD(1) = LAMDA3(SN(2)/2,SN(1)/2,(SN(3)+1)/2)
+ LAMD(2) = LAMDA3(SN(1)/2,SN(2)/2,(SN(3)+1)/2)
+ DO J=1,2
+ A(J) = WMXUSS(CSP,1)*QMIXSS(SN(1)-1,1,J)
+ & -RMASS(SN(1)-1)*MC(1)*WMXUSS(CSP,2)*QMIXSS(SN(1)-1,2,J)
+ B(J) = -MSGN*M(2)*WMXVSS(CSP,2)*QMIXSS(SN(1)-1,1,J)
+ A(J+2) = WMXUSS(CSP,1)*QMIXSS(SN(2)-1,1,J)
+ & -RMASS(SN(2)-1)*MC(1)*WMXUSS(CSP,2)*QMIXSS(SN(2)-1,2,J)
+ B(J+2) = -MSGN*M(2)*WMXVSS(CSP,2)*QMIXSS(SN(2)-1,1,J)
+ MX2(J) = QMIXSS(SN(1)-1,2,J)
+ MX2(J+2) = QMIXSS(SN(2)-1,2,J)
+ ENDDO
+ DO J=1,2
+ SN(J) = SN(J) + 399
+ SB(J) = SB(J) + 411
+ ENDDO
+ ND = 2
+ ELSE
+C--three diagram mode
+ LAMD(1) = LAMDA3((SN(1)+1)/2,(SN(2)+1)/2,(SN(3)+1)/2)
+ LAMD(2) = LAMDA3((SN(2)+1)/2,(SN(1)+1)/2,(SN(3)+1)/2)
+ LAMD(3) = LAMDA3((SN(3)+1)/2,(SN(2)+1)/2,(SN(1)+1)/2)
+ DO I=1,3
+ DO J=1,2
+ A(J+2*I-2) = MSGN*(WMXVSS(CSP,1)*QMIXSS(SN(I)+1,1,J)
+ & -RMASS(SN(I)+1)*MC(2)*WMXVSS(CSP,2)*QMIXSS(SN(I)+1,2,J))
+ B(J+2*I-2) = -M(I)*MC(1)*WMXUSS(CSP,2)
+ & *QMIXSS(SN(I)+1,1,J)
+ MX2(J+2*I-2) = QMIXSS(SN(I)+1,2,J)
+ ENDDO
+ SN(I) = SN(I) + 401
+ SB(I) = SB(I) + 413
+ ENDDO
+ ND = 3
+ ENDIF
+ ELSE
+C--now for the LQD modes
+ IF(MOD(SN(2),2).EQ.1.AND.MOD(SN(3),2).EQ.0) THEN
+C--first one diagram mode nubar, dbar, up
+ DO J=1,2
+ A(J+4) = -MSGN*M(3)*WMXVSS(CSP,2)*MC(2)*
+ & QMIXSS(SN(3)-1,1,J)
+ B(J+4) = WMXUSS(CSP,1)*QMIXSS(SN(3)-1,1,J)
+ & -RMASS(SN(3)-1)*MC(1)*WMXUSS(CSP,2)*QMIXSS(SN(3)-1,2,1)
+ MX2(J+4) = QMIXSS(SN(3)-1,2,J)
+ ENDDO
+ SN(3) = SN(3) + 399
+ SB(3) = SB(3) + 411
+ ND = 1
+ ELSEIF(MOD(SN(2),2).EQ.0.AND.MOD(SN(3),2).EQ.0) THEN
+C--second one diagram mode positron, ubar, up
+ DO J=1,2
+ A(J+4) = -MSGN*M(3)*WMXVSS(CSP,2)*MC(2)*
+ & QMIXSS(SN(3)-1,1,J)
+ B(J+4) = WMXUSS(CSP,1)*QMIXSS(SN(3)-1,1,J)
+ & -RMASS(SN(3)-1)*MC(1)*WMXUSS(CSP,2)*QMIXSS(SN(3)-1,2,1)
+ MX2(J+4) = QMIXSS(SN(3)-1,2,J)
+ ENDDO
+ SN(3) = SN(3) + 399
+ SB(3) = SB(3) + 411
+ ND = 1
+ ELSEIF(MOD(SN(2),2).EQ.1.AND.MOD(SN(3),2).EQ.1) THEN
+C--first two diagram mode positron, dbar, down
+ DO J=1,2
+ A(J) = -M(1)*MC(1)*WMXUSS(CSP,2)*LMIXSS(SN(1)+1,1,J)
+ B(J) = MSGN*WMXVSS(CSP,1)*LMIXSS(SN(2)+1,1,J)
+ A(J+2) = -M(2)*WMXUSS(CSP,2)*MC(1)*QMIXSS(SN(2)+1,1,J)
+ B(J+2) = MSGN*(WMXVSS(CSP,1)*QMIXSS(SN(2)+1,1,J)
+ & -RMASS(SN(2)+1)*MC(2)*WMXVSS(CSP,2)*QMIXSS(SN(2)+1,2,J))
+ MX2(J) = LMIXSS(SN(1)+1,1,J)
+ MX2(J+2) = QMIXSS(SN(2)+1,1,J)
+ ENDDO
+ SN(1) = SN(1) + 425
+ SB(1) = SB(1) + 437
+ SN(2) = SN(2) + 401
+ SB(2) = SB(2) + 413
+ ND = 2
+ ELSE
+C--second two diagram mode nu, up, dbar
+ DO J=1,2
+ A(J) = ZERO
+ B(J) = WMXUSS(CSP,1)*LMIXSS(SN(1)-1,1,J)
+ & -RMASS(119+SN(1))*MC(1)*WMXUSS(CSP,2)*LMIXSS(SN(1)-1,2,J)
+ A(J+2) = -MSGN*M(2)*MC(2)*WMXVSS(CSP,2)*
+ & QMIXSS(SN(2)-1,1,J)
+ B(J+2) = WMXUSS(CSP,1)*QMIXSS(SN(2)-1,1,J)
+ & -RMASS(SN(2)-1)*MC(1)*WMXUSS(CSP,2)*QMIXSS(SN(2)-1,2,J)
+ MX2(J) = LMIXSS(SN(1)-1,1,J)
+ MX2(J+2) = QMIXSS(SN(2)-1,1,J)
+ ENDDO
+ SN(1) = SN(1) + 423
+ SB(1) = SB(1) + 435
+ SN(2) = SN(2) + 399
+ SB(2) = SB(2) + 411
+ ND = 2
+ ENDIF
+ DO K=1,3
+ LAMD(K) = ONE
+ ENDDO
+ ENDIF
+ IF(ND.EQ.1) THEN
+ DO K=1,2
+ SM(2*K-1) = 0.0D0
+ SM(2*K) = 0.0D0
+ SW(2*K-1) = 0.0D0
+ SW(2*K) = 0.0D0
+ ENDDO
+ SM(5) = RMASS(SN(3))
+ SM(6) = RMASS(SB(3))
+ SW(5) = HBAR/RLTIM(SN(3))
+ SW(6) = HBAR/RLTIM(SB(3))
+ ELSE
+ DO K=1,2
+ SM(2*K-1) = RMASS(SN(K))
+ SM(2*K) = RMASS(SB(K))
+ SW(2*K-1) = HBAR/RLTIM(SN(K))
+ SW(2*K) = HBAR/RLTIM(SB(K))
+ SM(4+K) = ZERO
+ SW(4+K) = ZERO
+ ENDDO
+ ENDIF
+ ELSE
+C--UNKNOWN
+ CALL HWWARN('HWDRME',500,*999)
+ ENDIF
+C--Set mixing to zero if diagram not available
+ IF((AM.LT.(ABS(SM(1))+M(1)).OR.ABS(SM(1)).LT.(M(2)+M(3)))
+ & .AND.ABS(MX2(1)).GT.ZERO.AND.ND.NE.1) MX(1) = MX2(1)*LAMD(1)
+ IF((AM.LT.(ABS(SM(2))+M(1)).OR.ABS(SM(2)).LT.(M(2)+M(3)))
+ & .AND.ABS(MX2(2)).GT.ZERO.AND.ND.NE.1) MX(2) = MX2(2)*LAMD(1)
+ IF((AM.LT.(ABS(SM(3))+M(2)).OR.ABS(SM(3)).LT.(M(1)+M(3)))
+ & .AND.ABS(MX2(3)).GT.ZERO.AND.ND.NE.1) MX(3) = MX2(3)*LAMD(2)
+ IF((AM.LT.(ABS(SM(4))+M(2)).OR.ABS(SM(4)).LT.(M(1)+M(3)))
+ & .AND.ABS(MX2(4)).GT.ZERO.AND.ND.NE.1) MX(4) = MX2(4)*LAMD(2)
+ IF((AM.LT.(ABS(SM(5))+M(3)).OR.ABS(SM(5)).LT.(M(1)+M(2)))
+ & .AND.ABS(MX2(5)).GT.ZERO.AND.ND.NE.2) MX(5) = MX2(5)*LAMD(3)
+ IF((AM.LT.(ABS(SM(6))+M(3)).OR.ABS(SM(6)).LT.(M(1)+M(2)))
+ & .AND.ABS(MX2(6)).GT.ZERO.AND.ND.NE.2) MX(6) = MX2(6)*LAMD(3)
+C--Calculate the limiting points
+ DO J=1,2
+ IF(ND.NE.1) THEN
+ IF(ABS(MX(J)).GT.EPS) CALL HWDRM5(M23SQT(J),M13SQT(J),
+ & M12SQT(J),A(J),B(J),M(2),M(3),M(1),M(4),SM(J),SW(J))
+ IF(ABS(MX(J+2)).GT.EPS) CALL HWDRM5(M13SQT(2+J),M23SQT(2+J),
+ & M12SQT(2+J),A(2+J),B(2+J),M(1),M(3),M(2),M(4),SM(2+J),SW(2+J))
+ ENDIF
+ IF(ND.NE.2) THEN
+ IF(ABS(MX(J+4)).GT.EPS) CALL HWDRM5(M12SQT(4+J),M23SQT(4+J),
+ & M13SQT(4+J),A(4+J),B(4+J),M(1),M(2),M(3),M(4),SM(4+J),SW(4+J))
+ ENDIF
+ ENDDO
+C--Now evaluate the limit using these points
+ LIMIT = ZERO
+ DO 100 I=1,6
+ IF(ABS(MX(I)).LT.EPS) GOTO 100
+ LIMIT = LIMIT+HWDRM1(TEST,M12SQT(I),M13SQT(I),M23SQT(I),A,B,MX,
+ & M,SM,SW,INFCOL,AM,0,ND)
+ 100 CONTINUE
+ LIMIT = TWO*LIMIT
+C--Now evaluate at a random point
+ MTRY = 0
+ 25 MTRY = MTRY+1
+ LTRY = 0
+ 35 LTRY = LTRY+1
+ CALL HWDTHR(PHEP(1,LHEP),PHEP(1,MHEP),
+ & PHEP(1,MHEP+1),PHEP(1,MHEP+2),HWDPWT)
+C--Now calculate the m12sq etc for the actual point
+ M12SQ = M(1)**2+M(2)**2+2*HWULDO(PHEP(1,MHEP),PHEP(1,MHEP+1))
+ M13SQ = M(1)**2+M(3)**2+2*HWULDO(PHEP(1,MHEP),PHEP(1,MHEP+2))
+ M23SQ = M(2)**2+M(3)**2+2*HWULDO(PHEP(1,MHEP+1),PHEP(1,MHEP+2))
+C--Now calulate the matrix element
+ TEST(4) = HWDRM1(TEST,M12SQ,M13SQ,M23SQ,A,B,MX,
+ & M,SM,SW,INFCOL,AM,1,ND)
+C--Now test the value againest the limit
+ RAND = HWR()*LIMIT
+ IF(TEST(4).GT.LIMIT) THEN
+ LIMIT = 1.1D0*TEST(4)
+ CALL HWWARN('HWDRME',51,*150)
+ ENDIF
+ 150 IF(TEST(4).LT.RAND.AND.LTRY.LT.NETRY) THEN
+ GOTO 35
+ ELSEIF(LTRY.GE.NETRY) THEN
+ IF(MTRY.LE.NETRY) THEN
+ LIMIT = LIMIT*0.9D0
+ CALL HWWARN('HWDRME',52,*25)
+ ELSE
+ CALL HWWARN('HWDRME',100,*999)
+ ENDIF
+ ENDIF
+C--Reorder the particles in gluino decay to get angular ordering right
+ IF(IG.EQ.449.AND.ID(1).LE.12.AND.ID(2).LE.12.AND.ID(3).LE.12) THEN
+ DO LTRY=1,3
+ IF(TEST(LTRY).GT.RAND) THEN
+ IF(LTRY.EQ.2) THEN
+ IDHWTP = IDHW(MHEP)
+ IDHW(MHEP) = IDHW(MHEP+1)
+ IDHW(MHEP+1) = IDHWTP
+ IDHPTP = IDHEP(MHEP)
+ IDHEP(MHEP) = IDHEP(MHEP+1)
+ IDHEP(MHEP+1) = IDHPTP
+ CALL HWVEQU(5,PHEP(1,MHEP),DECMOM)
+ CALL HWVEQU(5,PHEP(1,MHEP+1),PHEP(1,MHEP))
+ CALL HWVEQU(5,DECMOM,PHEP(1,MHEP+1))
+ ELSEIF(LTRY.EQ.3) THEN
+ IDHWTP = IDHW(MHEP)
+ IDHW(MHEP) = IDHW(MHEP+2)
+ IDHW(MHEP+2) = IDHWTP
+ IDHPTP = IDHEP(MHEP)
+ IDHEP(MHEP) = IDHEP(MHEP+2)
+ IDHEP(MHEP+2) = IDHPTP
+ DO I=1,5
+ CALL HWVEQU(5,PHEP(1,MHEP),DECMOM)
+ CALL HWVEQU(5,PHEP(1,MHEP+2),PHEP(1,MHEP))
+ CALL HWVEQU(5,DECMOM,PHEP(1,MHEP+2))
+ ENDDO
+ ENDIF
+ GOTO 52
+ ENDIF
+ RAND=RAND-TEST(LTRY)
+ ENDDO
+ ENDIF
+ 52 CONTINUE
+ 999 END
+CDECK ID>, HWDRM1.
+*CMZ :- -20/07/99 10:56:12 by Peter Richardson
+*-- Author : Peter Richardson
+C-----------------------------------------------------------------------
+ FUNCTION HWDRM1(TEST,M12SQ,M13SQ,M23SQ,A,B,MX,M,SM,SW
+ & ,INFCOL,AM,LM,ND)
+C-----------------------------------------------------------------------
+C FUNCTION TO GIVE THE R-PARITY VIOLATING MATRIX ELEMENT AT A GIVEN
+C PHASE-SPACE POINT
+C-----------------------------------------------------------------------
+ IMPLICIT NONE
+ DOUBLE PRECISION M12SQ,M13SQ,M23SQ,MX(6),A(6),B(6),SM(6),SW(6),
+ & INFCOL,AM,TERM(21),TEST(4),PLN,NPLN,ZERO,
+ & M(4),HWDRM1,HWDRM2,HWDRM3,HWDRM4
+ PARAMETER (ZERO=0)
+ EXTERNAL HWDRM2,HWDRM3,HWDRM4
+ INTEGER LM,K,ND
+C--Zero the array
+ DO K=1,21
+ TERM(K) = 0.0D0
+ ENDDO
+ HWDRM1 = 0.0D0
+C--The amplitude
+ IF(ABS(MX(1)).GT.ZERO.AND.ND.NE.1) THEN
+ TERM(1) = MX(1)**2*HWDRM2(M23SQ,M(2),M(3),M(1),M(4),SM(1),
+ & SW(1),A(1),B(1))
+ IF(ABS(MX(2)).GT.ZERO) TERM(7)= MX(1)*MX(2)*HWDRM3(M23SQ,M(2),
+ & M(3),M(1),M(4),SM(1),SM(2),SW(1),SW(2),A(1),A(2),B(1),B(2))
+ IF(ABS(MX(3)).GT.ZERO) TERM(10)=-MX(1)*MX(3)*HWDRM4(M13SQ,M23SQ,
+ & M(1),M(3),M(2),M(4),SM(3),SM(1),SW(3),SW(1),A(1),A(3),B(1),B(3))
+ IF(ABS(MX(4)).GT.ZERO) TERM(11)=-MX(1)*MX(4)*HWDRM4(M13SQ,M23SQ,
+ & M(1),M(3),M(2),M(4),SM(4),SM(1),SW(4),SW(1),A(1),A(4),B(1),B(4))
+ IF(ABS(MX(5)).GT.ZERO) TERM(12)=-MX(1)*MX(5)*HWDRM4(M23SQ,M12SQ,
+ & M(3),M(2),M(1),M(4),SM(1),SM(5),SW(1),SW(5),A(5),A(1),B(5),B(1))
+ IF(ABS(MX(6)).GT.ZERO) TERM(13)=-MX(1)*MX(6)*HWDRM4(M23SQ,M12SQ,
+ & M(3),M(2),M(1),M(4),SM(1),SM(6),SW(1),SW(6),A(6),A(1),B(6),B(1))
+ ENDIF
+ IF(ABS(MX(2)).GT.ZERO.AND.ND.NE.1) THEN
+ TERM(2) = MX(2)**2*HWDRM2(M23SQ,M(2),M(3),M(1),M(4),SM(2),
+ & SW(2),A(2),B(2))
+ IF(ABS(MX(3)).GT.ZERO) TERM(14)=-MX(2)*MX(3)*HWDRM4(M13SQ,M23SQ,
+ & M(1),M(3),M(2),M(4),SM(3),SM(2),SW(3),SW(2),A(2),A(3),B(2),B(3))
+ IF(ABS(MX(4)).GT.ZERO) TERM(15)=-MX(2)*MX(4)*HWDRM4(M13SQ,M23SQ,
+ & M(1),M(3),M(2),M(4),SM(4),SM(2),SW(4),SW(2),A(2),A(4),B(2),B(4))
+ IF(ABS(MX(5)).GT.ZERO) TERM(16)=-MX(2)*MX(5)*HWDRM4(M23SQ,M12SQ,
+ & M(3),M(2),M(1),M(4),SM(2),SM(5),SW(2),SW(5),A(5),A(2),B(5),B(2))
+ IF(ABS(MX(6)).GT.ZERO) TERM(17)=-MX(2)*MX(6)*HWDRM4(M23SQ,M12SQ,
+ & M(3),M(2),M(1),M(4),SM(2),SM(6),SW(2),SW(6),A(6),A(2),B(6),B(2))
+ ENDIF
+ IF(ABS(MX(3)).GT.ZERO.AND.ND.NE.1) THEN
+ TERM(3) = MX(3)**2*HWDRM2(M13SQ,M(1),M(3),M(2),M(4),SM(3),
+ & SW(3),A(3),B(3))
+ IF(ABS(MX(4)).GT.ZERO) TERM(8)= MX(3)*MX(4)*HWDRM3(M13SQ,M(1),
+ & M(3),M(2),M(4),SM(3),SM(4),SW(3),SW(4),A(3),A(4),B(3),B(4))
+ IF(ABS(MX(5)).GT.ZERO) TERM(18)=-MX(3)*MX(5)*HWDRM4(M12SQ,M13SQ,
+ & M(2),M(1),M(3),M(4),SM(5),SM(3),SW(5),SW(3),A(3),A(5),B(3),B(5))
+ IF(ABS(MX(6)).GT.ZERO) TERM(19)=-MX(3)*MX(6)*HWDRM4(M12SQ,M13SQ,
+ & M(2),M(1),M(3),M(4),SM(6),SM(3),SW(6),SW(3),A(3),A(6),B(3),B(6))
+ ENDIF
+ IF(ABS(MX(4)).GT.ZERO.AND.ND.NE.1) THEN
+ TERM(4) = MX(4)**2*HWDRM2(M13SQ,M(1),M(3),M(2),M(4),SM(4),
+ & SW(4),A(4),B(4))
+ IF(ABS(MX(5)).GT.ZERO) TERM(20)=-MX(4)*MX(5)*HWDRM4(M12SQ,M13SQ,
+ & M(2),M(1),M(3),M(4),SM(5),SM(4),SW(5),SW(4),A(4),A(5),B(4),B(5))
+ IF(ABS(MX(6)).GT.ZERO) TERM(21)=-MX(4)*MX(6)*HWDRM4(M12SQ,M13SQ,
+ & M(2),M(1),M(3),M(4),SM(6),SM(4),SW(6),SW(4),A(4),A(6),B(4),B(6))
+ ENDIF
+ IF(ABS(MX(5)).GT.ZERO.AND.ND.NE.2) THEN
+ TERM(5) = MX(5)**2*HWDRM2(M12SQ,M(1),M(2),M(3),M(4),SM(5),
+ & SW(5),A(5),B(5))
+ IF(ABS(MX(6)).GT.ZERO) TERM(9)= MX(5)*MX(6)*HWDRM3(M12SQ,M(1),
+ & M(2),M(3),M(4),SM(5),SM(6),SW(5),SW(6),A(5),A(6),B(5),B(6))
+ ENDIF
+ IF(ABS(MX(6)).GT.ZERO.AND.ND.NE.2) TERM(6) = MX(6)**2*
+ & HWDRM2(M12SQ,M(1),M(2),M(3),M(4),SM(6),SW(6),A(6),B(6))
+ DO K=10,21
+ TERM(K)=TERM(K)*INFCOL
+ ENDDO
+C--Add them up
+ DO K=1,21
+ HWDRM1 = HWDRM1+TERM(K)
+ ENDDO
+C--Different colour flows for the gluino
+ IF(LM.NE.0) THEN
+ NPLN = 0.0D0
+ PLN = 0.0D0
+ DO K=1,9
+ PLN = PLN+TERM(K)
+ ENDDO
+ DO K=10,21
+ NPLN= NPLN+TERM(K)
+ ENDDO
+ DO K=1,3
+ TEST(K) = (TERM(2*K-1)+TERM(2*K)+TERM(6+K))*(1+NPLN/PLN)
+ ENDDO
+ ELSE
+ DO K=1,3
+ TEST(K) = 0.0D0
+ ENDDO
+ ENDIF
+ IF(TEST(4).LT.ZERO) CALL HWWARN('HWDRM1',50,*999)
+ 999 END
+CDECK ID>, HWDRM2.
+*CMZ :- -20/07/99 10:56:12 by Peter Richardson
+*-- Author : Peter Richardson
+C-----------------------------------------------------------------------
+ FUNCTION HWDRM2(X,MA,MB,MC,MD,MR1,GAM1,A,B)
+C-----------------------------------------------------------------------
+C Function to compute the matrix element squared part of a 3-body
+C R-parity decay
+C-----------------------------------------------------------------------
+ IMPLICIT NONE
+ DOUBLE PRECISION X,MA,MB,MC,MD,A,B,HWDRM2,MR1,GAM1
+ HWDRM2 = (X - MA**2 - MB**2)*(4*A*B*MC*MD +
+ & (A**2 + B**2)*(-X + MC**2 + MD**2))/
+ & ((X-MR1**2)**2+GAM1**2*MR1**2)
+ END
+CDECK ID>, HWDRM3.
+*CMZ :- -20/07/99 10:56:12 by Peter Richardson
+*-- Author : Peter Richardson
+C-----------------------------------------------------------------------
+ FUNCTION HWDRM3(X,MA,MB,MC,MD,MR1,MR2,GAM1,GAM2,A1,A2,B1,B2)
+C-----------------------------------------------------------------------
+C Function to compute the light/heavy interference part of a 3-body
+C R-parity decay
+C-----------------------------------------------------------------------
+ IMPLICIT NONE
+ DOUBLE PRECISION X,MA,MB,MC,MD,A1,A2,B1,B2,HWDRM3,MR1,MR2,GAM1
+ & ,GAM2
+C
+ HWDRM3 = 2*(X - MA**2 - MB**2)*(2*(A2*B1 + A1*B2)*MC*MD +
+ & (A1*A2 + B1*B2)*(-X + MC**2 + MD**2))*
+ & (GAM1*GAM2*MR1*MR2 + (X - MR1**2)*(X - MR2**2))/
+ & (((X-MR1**2)**2+GAM1**2*MR1**2)*((X-MR2**2)**2+GAM2**2*MR2**2))
+ END
+CDECK ID>, HWDRM4.
+*CMZ :- -20/07/99 10:56:12 by Peter Richardson
+*-- Author : Peter Richardson
+C-----------------------------------------------------------------------
+ FUNCTION HWDRM4(X,Y,MA,MB,MC,MD,MR1,MR2,GAM1,GAM2,A1,A2,B1,B2)
+C-----------------------------------------------------------------------
+C Function to compute the interference part of a 3-body
+C R-parity decay
+C-----------------------------------------------------------------------
+ IMPLICIT NONE
+ DOUBLE PRECISION X,Y,MA,MB,MC,MD,A1,A2,B1,B2,HWDRM4,MR1,MR2,GAM1
+ & ,GAM2
+C
+ HWDRM4 = 2*((GAM1*GAM2*MR1*MR2 + (X - MR1**2)*(Y - MR2**2))*
+ & (A2*B1*MC*MD*(X - MA**2 - MB**2) +
+ & A1*A2*MA*MC*(X + Y - MA**2 - MC**2) +
+ & A1*B2*MA*MD*(Y - MB**2 - MC**2) +
+ & B1*B2*(X*Y - MA**2*MC**2 - MB**2*MD**2)))/
+ & (((X-MR1**2)**2+GAM1**2*MR1**2)*((Y-MR2**2)**2+GAM2**2*MR2**2))
+ END
+CDECK ID>, HWDRM5.
+*CMZ :- -20/07/99 10:56:12 by Peter Richardson
+*-- Author : Peter Richardson
+C-----------------------------------------------------------------------
+ SUBROUTINE HWDRM5(X,Y,Z,A,B,MA,MB,MC,MD,MR,GAM)
+C-----------------------------------------------------------------------
+C Subroutine to find the maximum of the ME
+C-----------------------------------------------------------------------
+ IMPLICIT NONE
+ DOUBLE PRECISION X,Y,Z,MA,MB,MC,MD,MR,GAM,RES(3),A,B,C,D,
+ & E2S,E3S,E2M,E3M,LOW,UPP,HWRUNI,EPS,ZERO
+ EXTERNAL HWRUNI
+ PARAMETER(EPS=1D-9,ZERO=0)
+ C = A**2+B**2
+ D = 4*A*B
+ RES(1) = -D*(MA**2 + MB**2)*MC*MD +
+ & C*(GAM**2*MR**2 + MR**4 - MA**2*MC**2 - MB**2*MC**2 -
+ & MA**2*MD**2 - MB**2*MD**2)
+ RES(2) = (GAM**2*MR**2 + (-MR**2 + MA**2 + MB**2)**2)*
+ & (D**2*MC**2*MD**2 +
+ & 2*C*D*MC*MD*(-MR**2 + MC**2 + MD**2) +
+ & C**2*(GAM**2*MR**2 + (-MR**2 + MC**2 + MD**2)**2))
+ RES(3) = -D*MC*MD+C*(2*MR**2-(MA**2+MB**2+MC**2+MD**2))
+ IF(RES(2).GT.ZERO) THEN
+ RES(2) = SQRT(RES(2))
+ ELSE
+ RES(2) = 0.0D0
+ ENDIF
+ IF((RES(1)+RES(2))/RES(3).GT.(MD-MC)**2.OR.
+ & (RES(1)+RES(2))/RES(3).LT.(MA+MB)**2) THEN
+ X = (RES(1)-RES(2))/RES(3)
+ ELSE
+ X = (RES(1)+RES(2))/RES(3)
+ ENDIF
+ IF(X.GT.(MD-MC)**2) X = (MD-MC)**2
+ IF(X.LT.(MA+MB)**2) X = (MA+MB)**2
+ E2S = (X-MA**2+MB**2)/(2*SQRT(X))
+ E3S = (MD**2-X-MC**2)/(2*SQRT(X))
+ E2M = E2S**2-MB**2
+ E3M = E3S**2-MC**2
+ IF(E2M.LT.ZERO) THEN
+ IF(ABS(E2M/E2S).GT.EPS) CALL HWWARN('HWDRM5',2,*10)
+ 10 E2M= 0.0D0
+ ENDIF
+ IF(E3M.LT.ZERO) THEN
+ IF(ABS(E3M/E3S).GT.EPS) CALL HWWARN('HWDRM5',3,*20)
+ 20 E3M= 0.0D0
+ ENDIF
+ E2M = SQRT(E2M)
+ E3M = SQRT(E3M)
+ LOW = (E2S+E3S)**2-(E2M+E3M)**2
+ UPP = (E2S+E3S)**2-(E2M-E3M)**2
+ Y = HWRUNI(1,LOW,UPP)
+ Z = MA**2+MB**2+MC**2+MD**2-X-Y
+ END
+CDECK ID>, HWDPWT.
+*CMZ :- -26/04/91 11.11.55 by Bryan Webber
+*-- Author : Bryan Webber
+C-----------------------------------------------------------------------
+ FUNCTION HWDPWT(EMSQ,A,B,C)
+C-----------------------------------------------------------------------
+C MATRIX ELEMENT SQUARED FOR PHASE SPACE DECAY
+C-----------------------------------------------------------------------
+ DOUBLE PRECISION HWDPWT,EMSQ,A,B,C
+ HWDPWT=1.
+ END
+CDECK ID>, HWDTHR.
+*CMZ :- -26/04/91 14.55.44 by Federico Carminati
+*-- Author : Bryan Webber
+C-----------------------------------------------------------------------
+ SUBROUTINE HWDTHR(P0,P1,P2,P3,WEIGHT)
+C-----------------------------------------------------------------------
+C GENERATES THREE-BODY DECAY 0->1+2+3 DISTRIBUTED
+C ACCORDING TO PHASE SPACE * WEIGHT
+C-----------------------------------------------------------------------
+ DOUBLE PRECISION HWR,HWRUNI,A,B,C,D,AA,BB,CC,DD,EE,FF,PP,QQ,WW,
+ & RR,PCM1,PC23,WEIGHT,P0(5),P1(5),P2(5),P3(5),P23(5),TWO
+ EXTERNAL HWR,HWRUNI,WEIGHT
+ PARAMETER (TWO=2.D0)
+ A=P0(5)+P1(5)
+ B=P0(5)-P1(5)
+ C=P2(5)+P3(5)
+ IF (B.LT.C) CALL HWWARN('HWDTHR',100,*999)
+ D=ABS(P2(5)-P3(5))
+ AA=A*A
+ BB=B*B
+ CC=C*C
+ DD=D*D
+ EE=(B-C)*(A-D)
+ A=0.5*(AA+BB)
+ B=0.5*(CC+DD)
+ C=4./(A-B)**2
+C
+C CHOOSE MASS OF SUBSYSTEM 23 WITH PRESCRIBED DISTRIBUTION
+C
+ 10 FF=HWRUNI(0,BB,CC)
+ PP=(AA-FF)*(BB-FF)
+ QQ=(CC-FF)*(DD-FF)
+ WW=WEIGHT(FF,A,B,C)**2
+ RR=EE*FF*HWR()
+ IF (PP*QQ*WW.LT.RR*RR) GOTO 10
+C
+C FF IS MASS SQUARED OF SUBSYSTEM 23.
+C
+C DO 2-BODY DECAYS 0->1+23, 23->2+3
+C
+ P23(5)=SQRT(FF)
+ PCM1=SQRT(PP)*0.5/P0(5)
+ PC23=SQRT(QQ)*0.5/P23(5)
+ CALL HWDTWO(P0,P1,P23,PCM1,TWO,.TRUE.)
+ CALL HWDTWO(P23,P2,P3,PC23,TWO,.TRUE.)
+ 999 END
+CDECK ID>, HWDTOP.
+*CMZ :- -09/12/92 11.03.46 by Bryan Webber
+*-- Author : Bryan Webber
+C-----------------------------------------------------------------------
+ SUBROUTINE HWDTOP(DECAY)
+C-----------------------------------------------------------------------
+C DECIDES WHETHER TO DO TOP QUARK DECAY BEFORE HADRONIZATION
+C-----------------------------------------------------------------------
+ INCLUDE 'HERWIG61.INC'
+ LOGICAL DECAY
+ DECAY=RMASS(6).GT.130D0
+ END
+CDECK ID>, HWDTWO.
+*CMZ :- -27/01/94 17.38.49 by Mike Seymour
+*-- Author : Bryan Webber & Mike Seymour
+C-----------------------------------------------------------------------
+ SUBROUTINE HWDTWO(P0,P1,P2,PCM,COSTH,ZAXIS)
+C-----------------------------------------------------------------------
+C GENERATES DECAY 0 -> 1+2
+C
+C PCM IS CM MOMENTUM
+C
+C COSTH = COS THETA IN P0 REST FRAME (>1 FOR ISOTROPIC)
+C IF ZAXIS=.TRUE., COS THETA IS MEASURED FROM THE ZAXIS
+C IF .FALSE., IT IS MEASURED FROM P0'S DIRECTION
+C-----------------------------------------------------------------------
+ DOUBLE PRECISION HWRUNI,ONE,ZERO,PCM,COSTH,C,S,P0(5),P1(5),P2(5),
+ & PP(5),R(9)
+ LOGICAL ZAXIS
+ EXTERNAL HWRUNI
+ PARAMETER (ZERO=0.D0, ONE=1.D0)
+C--CHOOSE C.M. ANGLES
+ C=COSTH
+ IF (C.GT.ONE) C=HWRUNI(0,-ONE,ONE)
+ S=SQRT(ONE-C*C)
+ CALL HWRAZM(PCM*S,PP(1),PP(2))
+C--PP IS MOMENTUM OF 2 IN C.M.
+ PP(3)=-PCM*C
+ PP(4)=SQRT(P2(5)**2+PCM**2)
+ PP(5)=P2(5)
+C--ROTATE IF NECESSARY
+ IF (COSTH.LE.ONE.AND..NOT.ZAXIS) THEN
+ CALL HWUROT(P0,ONE,ZERO,R)
+ CALL HWUROB(R,PP,PP)
+ ENDIF
+C--BOOST FROM C.M. TO LAB FRAME
+ CALL HWULOB(P0,PP,P2)
+ CALL HWVDIF(4,P0,P2,P1)
+ END
+CDECK ID>, HWDWWT.
+*CMZ :- -26/04/91 11.11.55 by Bryan Webber
+*-- Author : Bryan Webber
+C-----------------------------------------------------------------------
+ FUNCTION HWDWWT(EMSQ,A,B,C)
+C-----------------------------------------------------------------------
+C MATRIX ELEMENT SQUARED FOR V-A WEAK DECAY
+C-----------------------------------------------------------------------
+ DOUBLE PRECISION HWDWWT,EMSQ,A,B,C
+ HWDWWT=(A-EMSQ)*(EMSQ-B)*C
+ END
+CDECK ID>, HWDXLM.
+*CMZ :- -27/07/99 13.33.03 by Mike Seymour
+*-- Author : Ian Knowles
+C-----------------------------------------------------------------------
+ SUBROUTINE HWDXLM(DKVRTX,STAB)
+C-----------------------------------------------------------------------
+C Sets STAB=.TRUE. if DKVRTX lies outside the specified region.
+C-----------------------------------------------------------------------
+ INCLUDE 'HERWIG61.INC'
+ DOUBLE PRECISION DKVRTX(4),RCYL,RSPH,ZMAX,R,S
+ LOGICAL STAB
+ PARAMETER (RCYL=20,RSPH=100,ZMAX=500)
+ STAB=.FALSE.
+ IF (IOPDKL.EQ.1) THEN
+C Cylinderical geometry
+ S=SQRT(DKVRTX(1)**2+DKVRTX(2)**2)
+ IF (S.GE.RCYL.OR.ABS(DKVRTX(3)).GE.ZMAX) STAB=.TRUE.
+ ELSEIF (IOPDKL.EQ.2) THEN
+C Spherical geometry
+ R=SQRT(DKVRTX(1)**2+DKVRTX(2)**2+DKVRTX(3)**2)
+ IF (R.GE.RSPH) STAB=.TRUE.
+ ELSE
+C User supplied geometry
+ ENDIF
+ RETURN
+ 999 END
+CDECK ID>, HWEFIN.
+*CMZ :- -26/04/91 11.11.55 by Bryan Webber
+*-- Author : Bryan Webber
+C-----------------------------------------------------------------------
+ SUBROUTINE HWEFIN
+C-----------------------------------------------------------------------
+C TERMINAL CALCULATIONS ON ELEMENTARY PROCESS
+C-----------------------------------------------------------------------
+ INCLUDE 'HERWIG61.INC'
+ DOUBLE PRECISION RNWGT,SPWGT,ERWGT
+ WRITE (6,1)
+ 1 FORMAT(/10X,'OUTPUT ON ELEMENTARY PROCESS'/)
+ IF (NWGTS.EQ.0) THEN
+ WRITE (6,10)
+ 10 FORMAT(10X,'NO WEIGHTS GENERATED')
+ ELSE
+ RNWGT=1./FLOAT(NWGTS)
+ AVWGT=WGTSUM*RNWGT
+ SPWGT=SQRT(MAX(WSQSUM*RNWGT-AVWGT**2,ZERO))
+ ERWGT=SPWGT*SQRT(RNWGT)
+ IF (.NOT.NOWGT) WGTMAX=AVWGT
+ IF (WGTMAX.EQ.ZERO) WGTMAX=ONE
+ WRITE (6,11) NEVHEP,NWGTS,AVWGT,SPWGT,WBIGST,WGTMAX,IPROC,
+ & 1000.*AVWGT,1000.*ERWGT,100.*AVWGT/WGTMAX
+ 11 FORMAT(1P,
+ & 10X,'NUMBER OF EVENTS = ',I11/
+ & 10X,'NUMBER OF WEIGHTS = ',I11/
+ & 10X,'MEAN VALUE OF WGT =',E12.4/
+ & 10X,'RMS SPREAD IN WGT =',E12.4/
+ & 10X,'ACTUAL MAX WEIGHT =',E12.4/
+ & 10X,'ASSUMED MAX WEIGHT =',E12.4//
+ & 10X,'PROCESS CODE IPROC = ',I11/
+ & 10X,'CROSS SECTION (PB) =',G12.4/
+ & 10X,'ERROR IN C-S (PB) =',G12.4/
+ & 10X,'EFFICIENCY PERCENT =',G12.4)
+ ENDIF
+ END
+CDECK ID>, HWEGAM.
+*CMZ :- -26/04/91 11.11.55 by Bryan Webber
+*-- Author : Bryan Webber & Luca Stanco
+C-----------------------------------------------------------------------
+ SUBROUTINE HWEGAM(IHEP,ZMI,ZMA,WWA)
+C-----------------------------------------------------------------------
+C GENERATES A PHOTON IN WEIZSACKER-WILLIAMS (WWA=.TRUE.) OR
+C ELSE EQUIVALENT PHOTON APPROX FROM INCOMING E+, E-, MU+ OR MU-
+C-----------------------------------------------------------------------
+ INCLUDE 'HERWIG61.INC'
+ DOUBLE PRECISION HWR,HWRUNI,EGMIN,ZMIN,ZMAX,ZGAM,SS,ZMI,ZMA,
+ & PPL,PMI,QT2,Q2,QQMIN,QQMAX,S0,A,RPM(2)
+ INTEGER IHEP,IHADIS,HQ,I
+ LOGICAL WWA
+ EXTERNAL HWR,HWRUNI
+ DATA EGMIN/5.D0/
+ IF (IERROR.NE.0) RETURN
+ IF (IHEP.LT.1.OR.IHEP.GT.2) CALL HWWARN('HWEGAM',500,*999)
+ SS=PHEP(5,3)
+ IF (IHEP.EQ.1) THEN
+ IHADIS=2
+ ELSE
+ IHADIS=1
+ IF (JDAHEP(1,IHADIS).NE.0) IHADIS=JDAHEP(1,IHADIS)
+ ENDIF
+C---DEFINE LIMITS FOR GAMMA MOMENTUM FRACTION
+ IF (ZMI.LE.ZERO .OR. ZMA.GT.ONE) THEN
+ IF (IPRO.EQ.13.OR.IPRO.EQ.14) THEN
+ S0 = EMMIN**2
+ ELSEIF(IPRO.EQ.15.OR.IPRO.EQ.18.OR.IPRO.EQ.22.OR.IPRO.EQ.24.OR.
+ & IPRO.EQ.50.OR.IPRO.EQ.53.OR.IPRO.EQ.55)THEN
+ S0 = 4.D0*PTMIN**2
+ ELSEIF (IPRO.EQ.17.OR.IPRO.EQ.51) THEN
+ HQ = MOD(IPROC,100)
+ S0 = 4.D0*(PTMIN**2+RMASS(HQ)**2)
+ ELSEIF (IPRO.EQ.16.OR.IPRO.EQ.19.OR.IPRO.EQ.95) THEN
+ S0 = MAX(2*RMASS(1),RMASS(201)-GAMMAX*GAMH)**2
+ ELSEIF (IPRO.EQ.23) THEN
+ S0 = MAX(2*RMASS(1),RMASS(201)-GAMMAX*GAMH)**2
+ S0 = (PTMIN+SQRT(PTMIN**2+S0))**2
+ ELSEIF (IPRO.EQ.20) THEN
+ S0 = RMASS(201)**2
+ ELSEIF (IPRO.EQ.21) THEN
+ S0 = (PTMIN+SQRT(PTMIN**2+RMASS(198)**2))**2
+C--PR MOD 7/7/99
+ ELSEIF(IPRO.EQ.30) THEN
+ S0 = 4.0D0*(PTMIN**2+RMMNSS**2)
+ ELSEIF(IPRO.EQ.40.OR.IPRO.EQ.41) THEN
+ HQ = IPROC-100*IPRO
+ RPM(1) = RMMNSS
+ RPM(2) = ZERO
+ IF(HQ.GE.10.AND.HQ.LT.20) THEN
+ RPM(1) = ABS(RMASS(450))
+ IF(HQ.GT.10) RPM(1) = ABS(RMASS(449+MOD(HQ,10)))
+ ELSEIF(HQ.GE.20.AND.HQ.LT.30) THEN
+ RPM(1) = ABS(RMASS(454))
+ IF(HQ.GT.20) RPM(1) = ABS(RMASS(453+MOD(HQ,20)))
+ ELSEIF(HQ.EQ.30) THEN
+ RPM(1) = RMASS(449)
+ ELSEIF(HQ.EQ.40) THEN
+ IF(IPRO.EQ.40) THEN
+ RPM(1) = RMASS(425)
+ DO I=1,5
+ RPM(1) = MIN(RPM(1),RMASS(425+I))
+ ENDDO
+ ELSE
+ RPM(1) = MIN(RMASS(405),RMASS(406))
+ ENDIF
+ RPM(2) = RMASS(198)
+ ELSEIF(HQ.EQ.50) THEN
+ IF(IPRO.EQ.40) THEN
+ RPM(1) = RMASS(425)
+ DO I=1,5
+ RPM(1) = MIN(RPM(1),RMASS(425+I))
+ ENDDO
+ DO I=1,3
+ RPM(2) = MIN(RPM(1),RMASS(433+2*I))
+ ENDDO
+ RPM(1) = MIN(RPM(1),RPM(2))
+ RPM(2) = RMASS(203)
+ DO I=1,2
+ RPM(2) = MIN(RPM(2),RMASS(204+I))
+ ENDDO
+ ELSE
+ RPM(1) = RMASS(401)
+ RPM(2) = RMASS(413)
+ DO I=1,5
+ RPM(1) = MIN(RPM(1),RMASS(401+I))
+ RPM(2) = MIN(RPM(2),RMASS(413+I))
+ ENDDO
+ RPM(1) = MIN(RPM(1),RPM(2))
+ RPM(2) = RMASS(203)
+ DO I=1,2
+ RPM(2) = MIN(RPM(2),RMASS(204+I))
+ ENDDO
+ ENDIF
+ RPM(2) = RMASS(203)
+ DO I=1,2
+ RPM(2) = MIN(RPM(2),RMASS(204+I))
+ ENDDO
+ ELSEIF(HQ.GE.60) THEN
+ RPM(1) = ZERO
+ ENDIF
+ RPM(1) = RPM(1)**2
+ RPM(2) = RPM(2)**2
+ S0 = RPM(1)+RPM(2)+TWO*(PTMIN**2+
+ & SQRT(RPM(1)*RPM(2)+PTMIN**2*(RPM(1)+RPM(2)+PTMIN**2)))
+C--end of mod
+ ELSEIF (IPRO.EQ.52) THEN
+ HQ = MOD(IPROC,100)
+ S0 = (PTMIN+SQRT(PTMIN**2+RMASS(HQ)**2))**2
+ ELSEIF (IPRO.EQ.60) THEN
+ HQ = MOD(IPROC,100)
+ IF (HQ.EQ.0) THEN
+ S0 = 4.D0*PTMIN**2
+ ELSE
+ IF (HQ.GT.6) HQ=2*HQ+107
+ IF (HQ.EQ.127) HQ=198
+ S0 = 4.D0*(PTMIN**2+RMASS(HQ)**2)
+ ENDIF
+ ELSEIF (IPRO.EQ.80) THEN
+ S0 = WHMIN**2
+ ELSEIF (IPRO.EQ.90) THEN
+ S0 = Q2MIN
+ ELSEIF (IPRO.EQ.91.OR.IPRO.EQ.92) THEN
+ S0 = Q2MIN+4.D0*PTMIN**2
+ HQ = MOD(IPROC,100)
+ IF (HQ.GT.0) S0 = S0+4.D0*RMASS(HQ)**2
+ IF (IPRO.EQ.91) S0 = MAX(S0,EMMIN**2)
+ ELSE
+ S0 = 0
+ ENDIF
+ IF (S0.GT.ZERO) THEN
+ S0 = (SQRT(S0)+ABS(PHEP(5,IHADIS)))**2-PHEP(5,IHADIS)**2
+ S0 = MAX(S0,WHMIN**2)
+ ZMIN = S0 / (SS**2 - PHEP(5,IHEP)**2 - PHEP(5,IHADIS)**2)
+ ZMAX = ONE
+ ELSE
+C---UNKNOWN PROCESS: USE ENERGY CUTOFF, AND WARN USER
+ IF (FSTWGT) CALL HWWARN('HWEGAM',1,*999)
+ ZMIN = EGMIN / PHEP(4,IHEP)
+ ZMAX = ONE
+ ENDIF
+ ELSE
+ ZMIN=ZMI
+ ZMAX=ZMA
+ ENDIF
+C---APPLY USER DEFINED CUTS YWWMIN,YWWMAX AND INDIRECT LIMITS ON Z
+ IF (.NOT.WWA) THEN
+ ZMIN=MAX(ZMIN,YWWMIN,SQRT(Q2WWMN)/ABS(PHEP(3,IHEP)))
+ ZMAX=MIN(ZMAX,YWWMAX)
+ IF (ZMIN.GT.ZMAX) THEN
+ GAMWT=ZERO
+ RETURN
+ ENDIF
+ ENDIF
+C---GENERATE GAMMA MOMENTUM FRACTION
+ A=HALF
+ 10 IF (HWR().LT.A) THEN
+ ZGAM=(ZMIN/ZMAX)**HWR()*ZMAX
+ ELSE
+ ZGAM=(ZMAX-ZMIN)*HWR()+ZMIN
+ ENDIF
+ GAMWT = GAMWT * .5*ALPHEM/PIFAC *
+ + (1+(1-ZGAM)**2)/(A/LOG(ZMAX/ZMIN)+(1-A)/(ZMAX-ZMIN)*ZGAM)
+ IF (WWA) THEN
+ GAMWT = GAMWT * LOG((ONE-ZGAM)/ZGAM*(SS/PHEP(5,IHEP))**2)
+ ELSE
+C---Q2WWMN AND Q2WWMX ARE USER-DEFINED LIMITS IN THE Q**2 INTEGRATION
+ QQMAX=MIN(Q2WWMX,(ZGAM*PHEP(3,IHEP))**2)
+ QQMIN=MAX(Q2WWMN,(PHEP(5,IHEP)*ZGAM)**2/(1.-ZGAM))
+ IF (QQMIN.GT.QQMAX) CALL HWWARN('HWEGAM',50,*10)
+ Q2=EXP(HWRUNI(0,LOG(QQMIN),LOG(QQMAX)))
+ GAMWT = GAMWT * LOG(QQMAX/QQMIN)
+ ENDIF
+ IF (GAMWT.LT.ZERO) GAMWT=ZERO
+C---FILL PHOTON
+ NHEP=NHEP+1
+ IDHW(NHEP)=59
+ ISTHEP(NHEP)=3
+ IDHEP(NHEP)=22
+ JMOHEP(1,NHEP)=IHEP
+ JMOHEP(2,NHEP)=0
+ JDAHEP(1,NHEP)=0
+ JDAHEP(2,NHEP)=0
+ JDAHEP(1,IHEP)=NHEP
+ IF (WWA) THEN
+C---FOR COLLINEAR KINEMATICS, ZGAM IS THE ENERGY FRACTION
+ PHEP(4,NHEP)=PHEP(4,IHEP)*ZGAM
+ PHEP(3,NHEP)=PHEP(3,IHEP)-SIGN(SQRT(
+ & (PHEP(4,IHEP)-PHEP(4,NHEP))**2-PHEP(5,IHEP)**2),PHEP(3,IHEP))
+ PHEP(2,NHEP)=0
+ PHEP(1,NHEP)=0
+ CALL HWUMAS(PHEP(1,NHEP))
+ ELSE
+C---FOR EXACT KINEMATICS, ZGAM IS TAKEN TO BE FRACTION OF (E+PZ)
+ PPL=ZGAM*(ABS(PHEP(3,IHEP))+PHEP(4,IHEP))
+ QT2=(ONE-ZGAM)*Q2-(ZGAM*PHEP(5,IHEP))**2
+ PMI=(QT2-Q2)/PPL
+ PHEP(5,NHEP)=-SQRT(Q2)
+ PHEP(4,NHEP)=(PPL+PMI)/TWO
+ PHEP(3,NHEP)=SIGN((PPL-PMI)/TWO,PHEP(3,IHEP))
+ CALL HWRAZM(SQRT(QT2),PHEP(1,NHEP),PHEP(2,NHEP))
+ ENDIF
+C---UPDATE OVERALL CM FRAME
+ JMOHEP(IHEP,3)=NHEP
+ CALL HWVDIF(4,PHEP(1,3),PHEP(1,IHEP),PHEP(1,3))
+ CALL HWVSUM(4,PHEP(1,NHEP),PHEP(1,3),PHEP(1,3))
+ CALL HWUMAS(PHEP(1,3))
+C---FILL OUTGOING LEPTON
+ NHEP=NHEP+1
+ IDHW(NHEP)=IDHW(IHEP)
+ ISTHEP(NHEP)=1
+ IDHEP(NHEP)=IDHEP(IHEP)
+ JMOHEP(1,NHEP)=IHEP
+ JMOHEP(2,NHEP)=0
+ JDAHEP(1,NHEP)=0
+ JDAHEP(2,NHEP)=0
+ JDAHEP(2,IHEP)=NHEP
+ CALL HWVDIF(4,PHEP(1,IHEP),PHEP(1,NHEP-1),PHEP(1,NHEP))
+ PHEP(5,NHEP)=PHEP(5,IHEP)
+ 999 END
+CDECK ID>, HWEINI.
+*CMZ :- -26/04/91 12.42.30 by Federico Carminati
+*-- Author : Bryan Webber
+C-----------------------------------------------------------------------
+ SUBROUTINE HWEINI
+C-----------------------------------------------------------------------
+C INITIALISES ELEMENTARY PROCESS
+C-----------------------------------------------------------------------
+ INCLUDE 'HERWIG61.INC'
+ DOUBLE PRECISION HWRSET,DUMMY,SAFETY
+ EXTERNAL HWRSET
+ PARAMETER (SAFETY=1.001)
+ INTEGER NBSH,I
+C---NO OF WEIGHT GENERATED
+ NWGTS=0
+C---ACCUMULATED WEIGHTS
+ WGTSUM=0.
+C---ACCUMULATED WEIGHT-SQUARED
+ WSQSUM=0.
+C---CURRENT MAX WEIGHT
+ WBIGST=0.
+C---LAST VALUE OF SCALE
+ EMLST=0.
+C---NUMBER OF ERRORS REPORTED
+ NUMER=0
+C---NUMBER OF ERRORS UNREPORTED
+ NUMERU=0
+C---FIND MAXIMUM EVENT WEIGHT IN CASES WHERE THIS IS REQUIRED
+ IF (NOWGT) THEN
+ IF (WGTMAX.EQ.ZERO) THEN
+ NBSH=IBSH
+ DUMMY = HWRSET(IBRN)
+ WRITE(6,10) IPROC,IBRN,NBSH
+ 10 FORMAT(/10X,'INITIAL SEARCH FOR MAX WEIGHT'//
+ & 10X,'PROCESS CODE IPROC = ',I11/
+ & 10X,'RANDOM NO. SEED 1 = ',I11/
+ & 10X,' SEED 2 = ',I11/
+ & 10X,'NUMBER OF SHOTS = ',I11)
+ NEVHEP=0
+ DO 11 I=1,NBSH
+ CALL HWEPRO
+ 11 CONTINUE
+ WRITE(6,20)
+ 20 FORMAT(/10X,'INITIAL SEARCH FINISHED')
+ IF (WBIGST*NWGTS.LT.SAFETY*WGTSUM)
+ & WGTMAX=SAFETY*WBIGST
+ CALL HWEFIN
+ NWGTS=0
+ WGTSUM=0.
+ WSQSUM=0.
+ WBIGST=0.
+ ELSE
+ WRITE(6,21) AVWGT,WGTMAX
+ 21 FORMAT(/1P,10X,'INPUT EVT WEIGHT =',E12.4/
+ & 10X,'INPUT MAX WEIGHT =',E12.4)
+ ENDIF
+ ENDIF
+C---RESET RANDOM NUMBER
+ DUMMY = HWRSET(NRN)
+ ISTAT=5
+ 999 END
+CDECK ID>, HWEISR.
+*CMZ :- -01/04/99 19.55.17 by Mike Seymour
+*-- Author : Mike Seymour
+C-----------------------------------------------------------------------
+ SUBROUTINE HWEISR(IHEP)
+C-----------------------------------------------------------------------
+C GENERATES AN ISR PHOTON FROM INCOMING E+, E-, MU+ OR MU-
+C-----------------------------------------------------------------------
+ INCLUDE 'HERWIG61.INC'
+ DOUBLE PRECISION HWR,QSQMAX,QSQMIN,A,B,B1,B2,B3,B4,B5,B6,B7,B8,
+ $ R,AA,T0,T1,C1,C2,T,Z(2),QSQ(2),PHI(2),C
+ INTEGER IHEP,I,J
+ EXTERNAL HWR
+ SAVE Z,QSQ,PHI
+C---IF ZMXISR IS ZERO, THERE CAN BE NO ISR
+ IF (ZMXISR.EQ.ZERO .OR. (IPRO.GT.3.AND.IPRO.NE.6)) RETURN
+C---CHECK CONSISTENCY OF TMNISR AND ZMXISR
+ IF (ZMXISR**2.LT.TMNISR) CALL HWWARN('HWEISR',200,*999)
+C---CALCULATE VIRTUALITY LIMITS
+ QSQMAX=4*PHEP(4,IHEP)**2
+ QSQMIN=PHEP(5,IHEP)**2
+C---AND THEREFORE THE Z DEPENDENCE
+ A=ALPHEM/PIFAC
+ B=A*(LOG(QSQMAX/QSQMIN)-1)
+C---DECIDE HOW MUCH WEIGHT TO GIVE THE Z RESONANCE
+ IF (IHEP.EQ.1) THEN
+ IF (IPRO.EQ.1.OR.IPRO.EQ.6) THEN
+ AA=10
+ ELSEIF (IPRO.EQ.2) THEN
+ AA=0
+ ELSEIF (IPRO.EQ.3) THEN
+ AA=1
+ ELSE
+ RETURN
+ ENDIF
+ T0=RMASS(200)**2/QSQMAX
+ T1=GAMZ*RMASS(200)/QSQMAX
+ IF (T0.GT.ONE) THEN
+ T0=0
+ AA=0
+ ENDIF
+ AA=AA*(1-T0)
+C---GENERATE A T VALUE BETWEEN TMNISR AND 1 ACCORDING TO:
+C ( b**2*log(zmxisr**2/t)/t + 2*b*(1-(1-zmxisr)**b)*((1-t)**(2*b-1)+1/t
+C +(1-t0)**(2b-1)*aa*t1/((t-t0)**2+t1**2)) ) *theta(zmxisr**2-t)
+C +( 2*b*(1-zmxisr)**b*((1-t)**(b-1)+1/t
+C +(1-t0)**(b-1)*aa*t1/((t-t0)**2+t1**2)) ) *theta(zmxisr-t)
+C +( (1-zmxisr)**(2*b) ) *delta(1-t)
+ B1=(1-ZMXISR)**(2*B)
+ B2=B1+2*(1-ZMXISR)**B*((1-TMNISR)**B-(1-ZMXISR)**B)
+ B3=B2+2*B*(1-ZMXISR)**B*LOG(ZMXISR/TMNISR)
+ B4=B3+2*B*(1-ZMXISR)**B*AA*(1-T0)**(B-1)
+ $ *(ATAN((ZMXISR-T0)/T1)-ATAN((TMNISR-T0)/T1))
+ B5=B4+(1-(1-ZMXISR)**B)*((1-TMNISR)**(2*B)-(1-ZMXISR**2)**(2*B))
+ B6=B5+2*B*(1-(1-ZMXISR)**B)*LOG(ZMXISR**2/TMNISR)
+ B7=B6+B**2*LOG(ZMXISR**2/TMNISR)**2/2
+ B8=B7+2*B*(1-(1-ZMXISR)**B)*AA*(1-T0)**(2*B-1)
+ $ *(ATAN((ZMXISR**2-T0)/T1)-ATAN((TMNISR-T0)/T1))
+ R=B8*HWR()
+ IF (R.LE.B1) THEN
+C---NEITHER EMITS
+ T=1
+ GAMWT=GAMWT*B8/B1
+ Z(1)=1
+ ELSEIF (R.LE.B4) THEN
+C---ONE EMITS
+ IF (R.LE.B2) THEN
+ R=(R-B1)/(B2-B1)
+ T=1-(1-TMNISR)*(1-R*(1-((1-ZMXISR)/(1-TMNISR))**B))**(1/B)
+ ELSEIF (R.LE.B3) THEN
+ R=(R-B2)/(B3-B2)
+ T=(TMNISR/ZMXISR)**R*ZMXISR
+ ELSE
+ R=(R-B3)/(B4-B3)
+ T=T0+T1*TAN(
+ $ ATAN((ZMXISR-T0)/T1)*R+ATAN((TMNISR-T0)/T1)*(1-R))
+ ENDIF
+ GAMWT=GAMWT*B8/(2*B*(1-ZMXISR)**B*((1-T)**(B-1)+1/T+
+ $ (1-T0)**(B-1)*AA*T1/((T-T0)**2+T1**2)))
+ Z(1)=1
+ IF (HWR().GT.HALF) Z(1)=T
+ GAMWT=GAMWT*2
+ ELSE
+C---BOTH EMIT
+ IF (R.LE.B5) THEN
+ R=(R-B4)/(B5-B4)
+ T=1-(1-TMNISR)*
+ $ (1-R*(1-((1-ZMXISR**2)/(1-TMNISR))**(2*B)))**(.5/B)
+ ELSEIF (R.LE.B6) THEN
+ R=(R-B5)/(B6-B5)
+ T=(TMNISR/ZMXISR**2)**R*ZMXISR**2
+ ELSEIF (R.LE.B7) THEN
+ R=(R-B6)/(B7-B6)
+ T=(TMNISR/ZMXISR**2)**SQRT(R)*ZMXISR**2
+ ELSE
+ R=(R-B7)/(B8-B7)
+ T=T0+T1*TAN(
+ $ ATAN((ZMXISR**2-T0)/T1)*R+ATAN((TMNISR-T0)/T1)*(1-R))
+ ENDIF
+ GAMWT=GAMWT*B8/(B**2*LOG(ZMXISR**2/T)/T
+ $ + 2*B*(1-(1-ZMXISR)**B)*((1-T)**(2*B-1)+1/T+
+ $ (1-T0)**(B-1)*AA*T1/((T-T0)**2+T1**2)))
+C---GENERATE A Z VALUE BETWEEN T/ZMXISR AND ZMXISR ACCORDING TO:
+C 1/z+(1-z)**(b-1)+t/z**2*(1-t/z)**(b-1)
+ C1=LOG(ZMXISR**2/T)
+ C2=C1+2/B*((1-T/ZMXISR)**B-(1-ZMXISR)**B)
+ IF (C2.GT.ZERO) THEN
+ R=C2*HWR()
+ IF (R.LE.C1) THEN
+ Z(1)=(T/ZMXISR**2)**HWR()*ZMXISR
+ ELSE
+ Z(1)=1-(1-T/ZMXISR)*
+ $ (1-HWR()*(1-((1-ZMXISR)/(1-T/ZMXISR))**B))**(1/B)
+ IF (2*R.LE.C2+C1) Z(1)=T/Z(1)
+ ENDIF
+ ELSE
+ Z(1)=SQRT(T)
+ ENDIF
+ GAMWT=GAMWT*C2/Z(1)
+ $ /(1/Z(1)+(1-Z(1))**(B-1)+T/Z(1)**2*(1-T/Z(1))**(B-1))
+ ENDIF
+C---INCLUDE DISTRIBUTION FUNCTIONS
+ Z(2)=T/Z(1)
+ DO 10 I=1,2
+ IF (Z(I).GT.ZMXISR) THEN
+ Z(I)=1
+ GAMWT=GAMWT*(1-ZMXISR)**B*EXP(3*B/4)*(1-B**2*PIFAC**2/12)
+ ELSE
+ GAMWT=GAMWT*(B*(1-Z(I))**(B-1)*(1+Z(I)**2)/2
+ $ *EXP(B*Z(I)/2*(1+Z(I)/2))*(1-B**2*PIFAC**2/12)
+ $ +B**2/8*((1+Z(I))*((1+Z(I))**2+3*LOG(Z(I)))
+ $ -4*LOG(Z(I))/(1-Z(I))))
+ ENDIF
+ 10 CONTINUE
+C---CHOOSE BOTH QSQ VALUES
+ DO 30 I=1,2
+ IF (Z(I).GT.ZMXISR .OR. COLISR) THEN
+ QSQ(I)=0
+ ELSE
+ J=3-I
+C---ACCORDING TO 1/(QSQ+QSQMIN) FROM 0 TO (1-Z)*(T/(Z+T))*QSQMAX
+ 20 QSQ(I)=(((1-Z(I))*(T/(Z(I)+T))
+ $ *QSQMAX/QSQMIN+1)**HWR()-1)*QSQMIN
+C---AND REJECT TO QSQ/(QSQ+QSQMIN)**2
+ IF (HWR()*(QSQ(I)+QSQMIN).GT.QSQ(I)) GOTO 20
+ ENDIF
+ 30 CONTINUE
+C---CHOOSE BOTH AZIMUTHS
+ PHI(1)=HWR()*2*PIFAC
+ PHI(2)=HWR()*2*PIFAC
+C---USE S-HAT PRESCRIPTION TO MODIFY Z VALUES
+ I=0
+ IF ((1-Z(1))*QSQ(1).GT.(1-Z(2))*QSQ(2)) I=1
+ IF ((1-Z(2))*QSQ(2).GT.(1-Z(1))*QSQ(1)) I=2
+ IF (I.GT.0) THEN
+ J=3-I
+ Z(I)=Z(I)+QSQ(I)/QSQMAX
+ IF (QSQ(J).GT.ZERO) THEN
+ Z(J)=((QSQ(I)*QSQMAX+QSQ(J)*QSQMAX
+ $ -QSQ(I)*QSQ(J))/QSQMAX**2+T)/Z(I)
+ C=COS(PHI(1)-PHI(2))*SQRT(QSQ(1)*QSQ(2))/QSQMAX
+ Z(J)=Z(J)+(-2*C**2*(1-Z(I))+2*C*SQRT((1-Z(I))
+ $ *(C**2*(1-Z(I))+Z(I)**2*(1-Z(J)))))/Z(I)**2
+ ENDIF
+ ENDIF
+ ELSEIF (IHEP.EQ.2) THEN
+C---EVERYTHING WAS GENERATED LAST TIME
+ ELSE
+C---ROUTINE CALLED UNEXPECTEDLY
+ CALL HWWARN('HWEISR',201,*999)
+ ENDIF
+C---IF Z IS TOO LARGE THERE IS NO EMISSION
+ IF (Z(IHEP).GT.ZMXISR) RETURN
+C---PUT NEW LEPTON IN EVENT RECORD
+ NHEP=NHEP+1
+ IDHW(NHEP)=IDHW(IHEP)
+ IDHEP(NHEP)=IDHEP(IHEP)
+ ISTHEP(NHEP)=3
+ JMOHEP(1,NHEP)=IHEP
+ JMOHEP(2,NHEP)=0
+ JDAHEP(1,NHEP)=0
+ JDAHEP(2,NHEP)=0
+ JDAHEP(1,IHEP)=NHEP
+C---AND OUTGOING PHOTON
+ NHEP=NHEP+1
+ IDHW(NHEP)=59
+ IDHEP(NHEP)=22
+ ISTHEP(NHEP)=1
+ JMOHEP(1,NHEP)=IHEP
+ JMOHEP(2,NHEP)=0
+ JDAHEP(1,NHEP)=0
+ JDAHEP(2,NHEP)=0
+ JDAHEP(2,IHEP)=NHEP
+C---RECONSTRUCT PHOTON KINEMATICS (Z IS LIGHT-CONE MOMENTUM FRACTION)
+ PHEP(1,NHEP)=SQRT(QSQ(IHEP)*(1-Z(IHEP)))*COS(PHI(IHEP))
+ PHEP(2,NHEP)=SQRT(QSQ(IHEP)*(1-Z(IHEP)))*SIN(PHI(IHEP))
+ PHEP(3,NHEP)=(1-Z(IHEP))*PHEP(4,IHEP)-QSQ(IHEP)/(4*PHEP(4,IHEP))
+ IF (IHEP.EQ.2) PHEP(3,NHEP)=-PHEP(3,NHEP)
+ PHEP(4,NHEP)=(1-Z(IHEP))*PHEP(4,IHEP)+QSQ(IHEP)/(4*PHEP(4,IHEP))
+ PHEP(5,NHEP)=0
+C---AND LEPTON
+ CALL HWVDIF(4,PHEP(1,IHEP),PHEP(1,NHEP),PHEP(1,NHEP-1))
+ CALL HWUMAS(PHEP(1,NHEP-1))
+C---UPDATE OVERALL CM FRAME
+ JMOHEP(IHEP,3)=NHEP-1
+ CALL HWVDIF(4,PHEP(1,3),PHEP(1,IHEP),PHEP(1,3))
+ CALL HWVSUM(4,PHEP(1,NHEP-1),PHEP(1,3),PHEP(1,3))
+ CALL HWUMAS(PHEP(1,3))
+ 999 END
+CDECK ID>, HWEONE.
+*CMZ :- -26/04/91 11.11.55 by Bryan Webber
+*-- Author : Bryan Webber
+C-----------------------------------------------------------------------
+ SUBROUTINE HWEONE
+C-----------------------------------------------------------------------
+C SETS UP 2->1 (COLOUR SINGLET) HARD SUBPROCESS
+C-----------------------------------------------------------------------
+ INCLUDE 'HERWIG61.INC'
+ DOUBLE PRECISION PA
+ INTEGER ICMF,I,IBM,IHEP
+C---INCOMING LINES
+ ICMF=NHEP+3
+ DO 15 I=1,2
+ IBM=I
+C---FIND BEAM AND TARGET
+ IF (JDAHEP(1,I).NE.0) IBM=JDAHEP(1,I)
+ IHEP=NHEP+I
+ IDHW(IHEP)=IDN(I)
+ IDHEP(IHEP)=IDPDG(IDN(I))
+ ISTHEP(IHEP)=110+I
+ JMOHEP(1,IHEP)=ICMF
+ JMOHEP(I,ICMF)=IHEP
+ JDAHEP(1,IHEP)=ICMF
+C---SPECIAL - IF INCOMING PARTON IS INCOMING BEAM THEN COPY IT
+ IF (XX(I).EQ.ONE.AND.IDHW(IBM).EQ.IDN(I)) THEN
+ CALL HWVEQU(5,PHEP(1,IBM),PHEP(1,IHEP))
+ IF (I.EQ.2) PHEP(3,IHEP)=-PHEP(3,IHEP)
+ ELSE
+ PHEP(1,IHEP)=0.
+ PHEP(2,IHEP)=0.
+ PHEP(5,IHEP)=RMASS(IDN(I))
+ PA=XX(I)*(PHEP(4,IBM)+ABS(PHEP(3,IBM)))
+ PHEP(4,IHEP)=0.5*(PA+PHEP(5,IHEP)**2/PA)
+ PHEP(3,IHEP)=PA-PHEP(4,IHEP)
+ ENDIF
+ 15 CONTINUE
+ PHEP(3,NHEP+2)=-PHEP(3,NHEP+2)
+C---HARD CENTRE OF MASS
+ IDHW(ICMF)=IDCMF
+ IDHEP(ICMF)=IDPDG(IDCMF)
+ ISTHEP(ICMF)=110
+ CALL HWVSUM(4,PHEP(1,NHEP+1),PHEP(1,NHEP+2),PHEP(1,ICMF))
+ CALL HWUMAS(PHEP(1,ICMF))
+C---SET UP COLOUR STRUCTURE LABELS
+ JMOHEP(2,NHEP+1)=NHEP+2
+ JDAHEP(2,NHEP+1)=NHEP+2
+ JMOHEP(2,NHEP+2)=NHEP+1
+ JDAHEP(2,NHEP+2)=NHEP+1
+ JDAHEP(1,NHEP+3)=NHEP+3
+ JDAHEP(2,NHEP+3)=NHEP+3
+ NHEP=NHEP+3
+ 999 END
+CDECK ID>, HWEPRO.
+*CMZ :- -01/04/99 19.41.18 by Mike Seymour
+*-- Author : Bryan Webber
+C-----------------------------------------------------------------------
+ SUBROUTINE HWEPRO
+C-----------------------------------------------------------------------
+C WHEN NEVHEP=0, CHOOSES X VALUES AND FINDS WEIGHT FOR PROCESS IPROC
+C OTHERWISE, CHOOSES AND LOADS ALL VARIABLES FOR HARD PROCESS
+C-----------------------------------------------------------------------
+ INCLUDE 'HERWIG61.INC'
+ DOUBLE PRECISION HWR
+ EXTERNAL HWR
+ IF (IERROR.NE.0) RETURN
+C---ROUTINE LOOPS BACK TO HERE IF GENERATED WEIGHT WAS NOT ACCEPTED
+ 10 GENEV=.FALSE.
+C---FSTWGT IS .TRUE. DURING FIRST CALL TO HARD PROCESS ROUTINE
+ FSTWGT=NWGTS.EQ.0
+C---FSTEVT IS .TRUE. THROUGHOUT THE FIRST EVENT
+ FSTEVT=NEVHEP.EQ.1
+C---SET COLOUR CORRECTION TO FALSE
+ COLUPD = .FALSE.
+ HRDCOL(1,1)=0
+ HRDCOL(1,3)=0
+C---SET UP INITIAL STATE
+ NHEP=1
+ ISTHEP(NHEP)=101
+ PHEP(1,NHEP)=0.
+ PHEP(2,NHEP)=0.
+ PHEP(3,NHEP)=PBEAM1
+ PHEP(4,NHEP)=EBEAM1
+ PHEP(5,NHEP)=RMASS(IPART1)
+ JMOHEP(1,NHEP)=0
+ JMOHEP(2,NHEP)=0
+ JDAHEP(1,NHEP)=0
+ JDAHEP(2,NHEP)=0
+ IDHW(NHEP)=IPART1
+ IDHEP(NHEP)=IDPDG(IPART1)
+ NHEP=NHEP+1
+ ISTHEP(NHEP)=102
+ PHEP(1,NHEP)=0.
+ PHEP(2,NHEP)=0.
+ PHEP(3,NHEP)=-PBEAM2
+ PHEP(4,NHEP)=EBEAM2
+ PHEP(5,NHEP)=RMASS(IPART2)
+ JMOHEP(1,NHEP)=0
+ JMOHEP(2,NHEP)=0
+ JDAHEP(1,NHEP)=0
+ JDAHEP(2,NHEP)=0
+ IDHW(NHEP)=IPART2
+ IDHEP(NHEP)=IDPDG(IPART2)
+C---NEXT ENTRY IS OVERALL CM FRAME
+ NHEP=NHEP+1
+ IDHW(NHEP)=14
+ IDHEP(NHEP)=0
+ ISTHEP(NHEP)=103
+ JMOHEP(1,NHEP)=NHEP-2
+ JMOHEP(2,NHEP)=NHEP-1
+ JDAHEP(1,NHEP)=0
+ JDAHEP(2,NHEP)=0
+ CALL HWVSUM(4,PHEP(1,NHEP-1),PHEP(1,NHEP-2),PHEP(1,NHEP))
+ CALL HWUMAS(PHEP(1,NHEP))
+C Select a primary interaction point
+ IF (PIPSMR) THEN
+ CALL HWRPIP
+ ELSE
+ CALL HWVZRO(4,VTXPIP)
+ ENDIF
+ CALL HWVEQU(3,VTXPIP,VHEP(1,NHEP))
+ VHEP(4,NHEP)=0.0
+C---GENERATE PHOTONS (WEIZSACKER-WILLIAMS APPROX)
+C FOR HADRONIC PROCESSES WITH LEPTON BEAMS
+ GAMWT=ONE
+ IF (IPRO.GT.10.AND.IPRO.LT.90) THEN
+ IF (ABS(IDHEP(1)).EQ.11.OR.ABS(IDHEP(1)).EQ.13)
+ & CALL HWEGAM(1,ZERO, ONE,.FALSE.)
+ IF (ABS(IDHEP(2)).EQ.11.OR.ABS(IDHEP(2)).EQ.13)
+ & CALL HWEGAM(2,ZERO, ONE,.FALSE.)
+ ELSEIF (IPRO.GE.90) THEN
+ IF (ABS(IDHEP(2)).EQ.11.OR.ABS(IDHEP(2)).EQ.13)
+ & CALL HWEGAM(2,ZERO, ONE,.FALSE.)
+ ENDIF
+C---GENERATE ISR PHOTONS FOR LEPTONIC PROCESSES
+ IF (IPRO.LT.10) THEN
+ CALL HWEISR(1)
+ CALL HWEISR(2)
+ ENDIF
+C---IF USER LIMITS WERE TOO TIGHT, MIGHT NOT BE ANY PHASE-SPACE
+ IF (GAMWT.LE.ZERO) GOTO 30
+C---IF CMF HAS ACQUIRED A TRANSVERSE BOOST, OR USER REQUESTS IT ANYWAY,
+C BOOST EVENT RECORD BACK TO CMF
+ IF (PHEP(1,3)**2+PHEP(2,3)**2.GT.ZERO .OR. USECMF) CALL HWUBST(1)
+C---ROUTINE LOOPS BACK TO HERE IF GENERATED WEIGHT WAS ACCEPTED
+ 20 CONTINUE
+C---IPRO=MOD(IPROC/100,100)
+ IF (IPRO.EQ.1) THEN
+ IF (IPROC.LT.110.OR.IPROC.GE.120) THEN
+C--- E+E- -> Q-QBAR OR L-LBAR
+ CALL HWHEPA
+ ELSE
+C--- E+E- -> Q-QBAR-GLUON
+ CALL HWHEPG
+ ENDIF
+ ELSEIF (IPRO.EQ.2) THEN
+C--- E+E- -> W+ W-
+ CALL HWHEWW
+ ELSEIF (IPRO.EQ.3) THEN
+C---E+E- -> Z H
+ CALL HWHIGZ
+ ELSEIF (IPRO.EQ.4) THEN
+C---E+E- -> NUEB NUE H
+ CALL HWHIGW
+ ELSEIF (IPRO.EQ.5 .AND. IPROC.LT.550) THEN
+C---EE -> EE GAMGAM -> EE FFBAR/WW
+ CALL HWHEGG
+ ELSEIF (IPRO.EQ.5) THEN
+C---EE -> ENU GAMW -> ENU FF'BAR/WZ
+ CALL HWHEGW
+ ELSEIF (IPRO.EQ.6) THEN
+C---EE -> FOUR JETS
+ CALL HWH4JT
+ ELSEIF (IPRO.EQ.13) THEN
+C---GAMMA/Z0/Z' DRELL-YAN PROCESS
+ CALL HWHDYP
+ ELSEIF (IPRO.EQ.14) THEN
+C---W+/- PRODUCTION VIA DRELL-YAN PROCESS
+ CALL HWHWPR
+ ELSEIF (IPRO.EQ.15) THEN
+C---QCD HARD 2->2 PROCESSES
+ CALL HWHQCD
+ ELSEIF (IPRO.EQ.16) THEN
+C---HIGGS PRODUCTION VIA GLUON FUSION
+ CALL HWHIGS
+ ELSEIF (IPRO.EQ.17) THEN
+C---QCD HEAVY FLAVOUR PRODUCTION
+ CALL HWHHVY
+ ELSEIF (IPRO.EQ.18) THEN
+C---QCD DIRECT PHOTON + JET PRODUCTION
+ CALL HWHPHO
+ ELSEIF (IPRO.EQ.19) THEN
+C---HIGGS PRODUCTION VIA W FUSION
+ CALL HWHIGW
+ ELSEIF (IPRO.EQ.20) THEN
+C---TOP PRODUCTION FROM W EXCHANGE
+ CALL HWHWEX
+ ELSEIF (IPRO.EQ.21) THEN
+C---VECTOR BOSON + JET PRODUCTION
+ CALL HWHV1J
+ ELSEIF (IPRO.EQ.22) THEN
+C QCD direct photon pair production
+ CALL HWHPH2
+ ELSEIF (IPRO.EQ.23) THEN
+C QCD Higgs plus jet production
+ CALL HWHIGJ
+ ELSEIF (IPRO.EQ.24) THEN
+C---COLOUR-SINGLET EXCHANGE
+ CALL HWHSNG
+ ELSEIF (IPRO.EQ.30) THEN
+C---HADRON-HADRON SUSY PROCESSES
+ CALL HWHSSP
+ ELSEIF(IPRO.EQ.40.OR.IPRO.EQ.41) THEN
+C---HADRON-HADRON R-PARITY VIOLATING SUSY PROCESSES
+ CALL HWHRSP
+ ELSEIF (IPRO.EQ.50) THEN
+C Point-like photon two-jet production
+ CALL HWHPPT
+ ELSEIF (IPRO.EQ.51) THEN
+C Point-like photon/QCD heavy flavour pair production
+ CALL HWHPPH
+ ELSEIF (IPRO.EQ.52) THEN
+C Point-like photon/QCD heavy flavour single excitation
+ CALL HWHPPE
+ ELSEIF (IPRO.EQ.53) THEN
+C Compton scattering of point-like photon and (anti)quark
+ CALL HWHPQS
+ ELSEIF (IPRO.EQ.55) THEN
+C Point-like photon/higher twist meson production
+ CALL HWHPPM
+ ELSEIF (IPRO.EQ.60) THEN
+C---QPM GAMMA-GAMMA-->QQBAR
+ CALL HWHQPM
+ ELSEIF (IPRO.GE.70.AND.IPRO.LE.79) THEN
+C---BARYON-NUMBER VIOLATION, AND OTHER MULTI-W PRODUCTION PROCESSES
+ CALL HVHBVI
+ ELSEIF (IPRO.EQ.80) THEN
+C---MINIMUM-BIAS: NO HARD SUBPROCESS
+C FIND WEIGHT
+ CALL HWMWGT
+ ELSEIF (IPRO.EQ.90) THEN
+C---DEEP INELASTIC
+ CALL HWHDIS
+ ELSEIF(IPRO.EQ.91) THEN
+C---BOSON - GLUON(QUARK) FUSION --> ANTIQUARK(GLUON) + QUARK
+ CALL HWHBGF
+ ELSEIF(IPRO.EQ.92) THEN
+C---DEEP INELASTIC WITH EXTRA JET: OBSOLETE PROCESS
+ WRITE (6,40)
+ 40 FORMAT (1X,' IPROC=92** is no longer supported.'
+ & /1X,' Please use IPROC=91** instead.')
+ CALL HWWARN('HWEPRO',500,*999)
+ ELSEIF(IPRO.EQ.95) THEN
+C---HIGGS PRODUCTION VIA W FUSION IN E P
+ CALL HWHIGW
+ ELSE
+C---UNKNOWN PROCESS
+ CALL HWWARN('HWEPRO',102,*999)
+ ENDIF
+ 30 IF (GENEV) THEN
+ IF (NOWGT) EVWGT=AVWGT
+ ISTAT=10
+ RETURN
+ ELSE
+C---IF AN EVENT IS CANCELLED BEFORE IT IS GENERATED, GIVE IT ZERO WEIGHT
+ IF (IERROR.NE.0) THEN
+ EVWGT=ZERO
+ IERROR=0
+ ENDIF
+ EVWGT=EVWGT*GAMWT
+ NWGTS=NWGTS+1
+ WGTSUM=WGTSUM+EVWGT
+ WSQSUM=WSQSUM+EVWGT**2
+ IF (EVWGT.GT.WBIGST) THEN
+ WBIGST=EVWGT
+ IF (NOWGT.AND.WBIGST.GT.WGTMAX) THEN
+ IF (NEVHEP.NE.0) CALL HWWARN('HWEPRO',1,*999)
+ WGTMAX=WBIGST*1.1
+ WRITE (6,99) WGTMAX
+ ENDIF
+ ELSEIF (EVWGT.LT.ZERO) THEN
+ IF (EVWGT.LT.-1.D-9) CALL HWWARN('HWEPRO',3,*999)
+ EVWGT=0.
+ ENDIF
+ IF (NEVHEP.NE.0) THEN
+C---LOW EFFICIENCY WARNINGS:
+C WARN AT 10*EFFMIN, STOP AT EFFMIN
+ IF (10*EFFMIN*NWGTS.GT.NEVHEP) THEN
+ IF (EFFMIN*NWGTS.GT.NEVHEP) CALL HWWARN('HWEPRO',200,*999)
+ IF (EFFMIN.GT.ZERO) THEN
+ IF (MOD(NWGTS,INT(10/EFFMIN)).EQ.0) THEN
+ CALL HWWARN('HWEPRO',2,*999)
+ WRITE (6,98) WGTMAX
+ ENDIF
+ ENDIF
+ ENDIF
+ IF (NOWGT) THEN
+ GENEV=EVWGT.GT.WGTMAX*HWR()
+ ELSE
+ GENEV=EVWGT.NE.ZERO
+ ENDIF
+ IF (GENEV) GOTO 20
+ GOTO 10
+ ENDIF
+ ENDIF
+ 98 FORMAT(10X,' MAXIMUM WEIGHT =',1PG24.16)
+ 99 FORMAT(10X,'NEW MAXIMUM WEIGHT =',1PG24.16)
+ 999 END
+CDECK ID>, HWETWO.
+*CMZ :- -26/04/91 11.11.55 by Bryan Webber
+*-- Author : Bryan Webber
+C-----------------------------------------------------------------------
+ SUBROUTINE HWETWO
+C-----------------------------------------------------------------------
+C SETS UP 2->2 HARD SUBPROCESS
+C-----------------------------------------------------------------------
+ INCLUDE 'HERWIG61.INC'
+ DOUBLE PRECISION HWUMBW,HWUPCM,PA,PCM
+ INTEGER ICMF,IBM,I,J,K,IHEP,NTRY
+ EXTERNAL HWUPCM
+C---INCOMING LINES
+ ICMF=NHEP+3
+ DO 15 I=1,2
+ IBM=I
+C---FIND BEAM AND TARGET
+ IF (JDAHEP(1,I).NE.0) IBM=JDAHEP(1,I)
+ IHEP=NHEP+I
+ IDHW(IHEP)=IDN(I)
+ IDHEP(IHEP)=IDPDG(IDN(I))
+ ISTHEP(IHEP)=110+I
+ JMOHEP(1,IHEP)=ICMF
+ JMOHEP(I,ICMF)=IHEP
+ JDAHEP(1,IHEP)=ICMF
+C---SPECIAL - IF INCOMING PARTON IS INCOMING BEAM THEN COPY IT
+ IF (XX(I).EQ.ONE.AND.IDHW(IBM).EQ.IDN(I)) THEN
+ CALL HWVEQU(5,PHEP(1,IBM),PHEP(1,IHEP))
+ IF (I.EQ.2) PHEP(3,IHEP)=-PHEP(3,IHEP)
+ ELSE
+ PHEP(1,IHEP)=0.
+ PHEP(2,IHEP)=0.
+ PHEP(5,IHEP)=RMASS(IDN(I))
+ PA=XX(I)*(PHEP(4,IBM)+ABS(PHEP(3,IBM)))
+ PHEP(4,IHEP)=0.5*(PA+PHEP(5,IHEP)**2/PA)
+ PHEP(3,IHEP)=PA-PHEP(4,IHEP)
+ ENDIF
+ 15 CONTINUE
+ PHEP(3,NHEP+2)=-PHEP(3,NHEP+2)
+C---HARD CENTRE OF MASS
+ IDHW(ICMF)=IDCMF
+ IDHEP(ICMF)=IDPDG(IDCMF)
+ ISTHEP(ICMF)=110
+ CALL HWVSUM(4,PHEP(1,NHEP+1),PHEP(1,NHEP+2),PHEP(1,ICMF))
+ CALL HWUMAS(PHEP(1,ICMF))
+C---OUTGOING LINES
+ NTRY=0
+ 19 CONTINUE
+ DO 20 I=3,4
+ IHEP=NHEP+I+1
+ IDHW(IHEP)=IDN(I)
+ IDHEP(IHEP)=IDPDG(IDN(I))
+ ISTHEP(IHEP)=110+I
+ JMOHEP(1,IHEP)=ICMF
+ JDAHEP(I-2,ICMF)=IHEP
+ 20 PHEP(5,IHEP)=HWUMBW(IDN(I))
+ PCM=HWUPCM(PHEP(5,NHEP+3),PHEP(5,NHEP+4),PHEP(5,NHEP+5))
+ IF (PCM.LT.ZERO) THEN
+ NTRY=NTRY+1
+ IF (NTRY.LE.NETRY) GO TO 19
+ CALL HWWARN('HWETWO',103,*999)
+ ENDIF
+ IHEP=NHEP+4
+ PHEP(4,IHEP)=SQRT(PCM**2+PHEP(5,IHEP)**2)
+ PHEP(3,IHEP)=PCM*COSTH
+ PHEP(1,IHEP)=SQRT((PCM+PHEP(3,IHEP))*(PCM-PHEP(3,IHEP)))
+ CALL HWRAZM(PHEP(1,IHEP),PHEP(1,IHEP),PHEP(2,IHEP))
+ CALL HWULOB(PHEP(1,NHEP+3),PHEP(1,IHEP),PHEP(1,IHEP))
+ CALL HWVDIF(4,PHEP(1,NHEP+3),PHEP(1,IHEP),PHEP(1,NHEP+5))
+C---SET UP COLOUR STRUCTURE LABELS
+ DO 30 I=1,4
+ J=I
+ IF (J.GT.2) J=J+1
+ K=ICO(I)
+ IF (K.GT.2) K=K+1
+ JMOHEP(2,NHEP+J)=NHEP+K
+ 30 JDAHEP(2,NHEP+K)=NHEP+J
+ NHEP=NHEP+5
+ 999 END
+CDECK ID>, HWH4JT.
+*CMZ :- -01/04/99 19.47.55 by Mike Seymour
+*-- Author : Ian Knowles
+C-----------------------------------------------------------------------
+ SUBROUTINE HWH4JT
+C-----------------------------------------------------------------------
+C Four jet production in e^+e^- annihilation: qqbar+gg & qqbar+qqbar
+C IOP4JT controls the treatment of the colour flow interference term
+C qqbar-gg case:
+C IOP4JT(1)=0 neglect, =1 extreme 2341; =2 extreme 3421
+C qqbar-qqbar (identical quark flavour) case:
+C IOP4JT(2)=0 neglect, =1 extreme 4123; =2 extreme 2143
+C
+C Matrix elements based on Ellis Ross & Terrano and Catani & Seymour
+C
+C WARNING: Phase space factor inaccurate for JADE y_cut > 0.14.
+C-----------------------------------------------------------------------
+ INCLUDE 'HERWIG61.INC'
+ INTEGER LM,LP,IQK,I,J,IDMN,IDMX,ID1,ID2,IST(4)
+ DOUBLE PRECISION HWR,HWUALF,HWUAEM,HWULDO,HWH4J1,HWH4J2,
+ & HWH4J4,HWH4J5,HWH4J6,HWH4J7,QNOW,Q2NOW,QLST,SCUT,PSFAC,FACT,X,
+ & COLA,COLB,COLC,CLF(7,6),P12,P13,P14,P23,P24,P34,FACTR,EP1,EP2,
+ & EP3,EP4,GG1,GG2,GG12,GG3,GG13,GG23,GGINT,WTGG,QQ,QP,QQINT,QQ1,
+ & QQ2,WTQQ,WTQP,HCS,WTAB,WTBA,WTOT,RCS
+ $ ,EF,QF,E(4)
+ LOGICAL INCLQG(6),INCLQQ(6,6),ORIENT
+ EXTERNAL HWR,HWUALF,HWUAEM,HWULDO,HWH4J1,HWH4J2,HWH4J4,
+ & HWH4J5,HWH4J6,HWH4J7
+ SAVE HCS,QLST,WTQP,WTQQ,WTGG,FACTR,COLA,COLB,COLC,IDMN,IDMX,
+ & CLF,GG1,GG2,GGINT,INCLQG,INCLQQ,LM,LP,QQ1,QQ2,QQINT,FACT,ORIENT,
+ & Q2NOW,SCUT
+ DATA QLST,IST/-1.,113,114,114,114/
+C
+ IF (GENEV) THEN
+ RCS=HCS*HWR()
+ ELSE
+ IF (NHEP+5.GT.NMXHEP) CALL HWWARN('HWH4JT',100,*999)
+ QNOW=PHEP(5,3)
+ IF (QNOW.NE.QLST) THEN
+ QLST=QNOW
+ Q2NOW=QNOW**2
+ SCUT=Y4JT*Q2NOW
+C Calculate allowed fraction of Phase Space using parameterization
+ IF (DURHAM) THEN
+ PSFAC=(1.-6.*Y4JT)**5.50*(1.-173.3*Y4JT*(1.-247.3*Y4JT
+ & *(1.+148.3*Y4JT*(1.+3.913*Y4JT))))
+ & /(1.-8.352*Y4JT*(1.-1102.*Y4JT
+ & *(1.+1603.*Y4JT*(1.+22.99*Y4JT))))
+ ELSE
+ PSFAC=(1.-6.*Y4JT)**4.62*(1.-44.72*Y4JT*(1.-176.0*Y4JT
+ & *(1.+102.9*Y4JT*(1.-6.579*Y4JT))))
+ & /(1.-3.392*Y4JT*(1.-946.5*Y4JT
+ & *(1.+423.4*Y4JT*(1.-3.971*Y4JT))))
+ ENDIF
+ FACT=GEV2NB*HWUAEM(Q2NOW)**2*CFFAC*FLOAT(NCOLO)*PSFAC
+ & /(THREE*16*PIFAC)
+ COLA=CFFAC
+ COLB=CFFAC-HALF*CAFAC
+ COLC=HALF
+ LM=1
+ IF (JDAHEP(1,LM).NE.0) LM=JDAHEP(1,LM)
+ LP=2
+ IF (JDAHEP(1,LP).NE.0) LP=JDAHEP(1,LP)
+ IQK=MOD(IPROC,10)
+ IF (IQK.NE.0) THEN
+ IDMN=IQK
+ IDMX=IQK
+ ELSE
+ IDMN=1
+ IDMX=6
+ ENDIF
+ DO 10 I=1,6
+ CALL HWUCFF(11,I,Q2NOW,CLF(1,I))
+ IF (QNOW.GT.TWO*(RMASS(I)+RMASS(13))) THEN
+ INCLQG(I)=.TRUE.
+ ELSE
+ INCLQG(I)=.FALSE.
+ ENDIF
+ DO 10 J=I,6
+ IF (QNOW.GT.TWO*(RMASS(I)+RMASS(J ))) THEN
+ INCLQQ(I,J)=.TRUE.
+ INCLQQ(J,I)=.TRUE.
+ ELSE
+ INCLQQ(I,J)=.FALSE.
+ INCLQQ(J,I)=.FALSE.
+ ENDIF
+ 10 CONTINUE
+ IF (MOD(IPROC/10,10).EQ.5) THEN
+ ORIENT=.FALSE.
+ ELSE
+ ORIENT=.TRUE.
+ ENDIF
+ ENDIF
+C Generate phase space point and check it passes cuts
+ CALL HWVEQU(5,PHEP(1,3),PHEP(1,NHEP+1))
+ DO 20 I=2,5
+ 20 PHEP(5,NHEP+I)=0.
+ 30 CALL HWDFOR(PHEP(1,NHEP+1),PHEP(1,NHEP+2),PHEP(1,NHEP+3),
+ & PHEP(1,NHEP+4),PHEP(1,NHEP+5))
+ IF (DURHAM) THEN
+ P12=2*HWULDO(PHEP(1,NHEP+2),PHEP(1,NHEP+3))
+ X=MIN(PHEP(4,NHEP+2)/PHEP(4,NHEP+3),
+ & PHEP(4,NHEP+3)/PHEP(4,NHEP+2))*P12
+ IF (X.GT.SCUT) THEN
+ P13=2*HWULDO(PHEP(1,NHEP+2),PHEP(1,NHEP+4))
+ X=MIN(PHEP(4,NHEP+2)/PHEP(4,NHEP+4),
+ & PHEP(4,NHEP+4)/PHEP(4,NHEP+2))*P13
+ IF (X.GT.SCUT) THEN
+ P14=2*HWULDO(PHEP(1,NHEP+2),PHEP(1,NHEP+5))
+ X=MIN(PHEP(4,NHEP+2)/PHEP(4,NHEP+5),
+ & PHEP(4,NHEP+5)/PHEP(4,NHEP+2))*P14
+ IF (X.GT.SCUT) THEN
+ P23=2*HWULDO(PHEP(1,NHEP+3),PHEP(1,NHEP+4))
+ X=MIN(PHEP(4,NHEP+3)/PHEP(4,NHEP+4),
+ & PHEP(4,NHEP+4)/PHEP(4,NHEP+3))*P23
+ IF (X.GT.SCUT) THEN
+ P24=2*HWULDO(PHEP(1,NHEP+3),PHEP(1,NHEP+5))
+ X=MIN(PHEP(4,NHEP+3)/PHEP(4,NHEP+5),
+ & PHEP(4,NHEP+5)/PHEP(4,NHEP+3))*P24
+ IF (X.GT.SCUT) THEN
+ P34=2*HWULDO(PHEP(1,NHEP+4),PHEP(1,NHEP+5))
+ X=MIN(PHEP(4,NHEP+4)/PHEP(4,NHEP+5),
+ & PHEP(4,NHEP+5)/PHEP(4,NHEP+4))*P34
+ IF (X.GT.SCUT) GOTO 40
+ ENDIF
+ ENDIF
+ ENDIF
+ ENDIF
+ ENDIF
+ ELSE
+ P12=2*HWULDO(PHEP(1,NHEP+2),PHEP(1,NHEP+3))
+ IF (P12.GT.SCUT) THEN
+ P13=2*HWULDO(PHEP(1,NHEP+2),PHEP(1,NHEP+4))
+ IF (P13.GT.SCUT) THEN
+ P14=2*HWULDO(PHEP(1,NHEP+2),PHEP(1,NHEP+5))
+ IF (P14.GT.SCUT) THEN
+ P23=2*HWULDO(PHEP(1,NHEP+3),PHEP(1,NHEP+4))
+ IF (P23.GT.SCUT) THEN
+ P24=2*HWULDO(PHEP(1,NHEP+3),PHEP(1,NHEP+5))
+ IF (P24.GT.SCUT) THEN
+ P34=2*HWULDO(PHEP(1,NHEP+4),PHEP(1,NHEP+5))
+ IF (P34.GT.SCUT) GOTO 40
+ ENDIF
+ ENDIF
+ ENDIF
+ ENDIF
+ ENDIF
+ ENDIF
+C Failed cuts retry
+ GOTO 30
+C Passed cuts: calculate contributions to Matrix Elements
+ 40 EMSCA=SQRT(MIN(P12,P13,P14,P23,P24,P34))
+ FACTR=FACT*HWUALF(1,EMSCA)**2
+ IF (ORIENT) THEN
+ QF=HWULDO(PHEP(1,LP),PHEP(1,3))
+ EF=Q2NOW/(2*SQRT(QF**2-HWULDO(PHEP(1,LP),PHEP(1,LP))*Q2NOW))
+ QF=HALF-EF*QF/Q2NOW
+ DO I=1,4
+ E(I)=EF*PHEP(I,LP)+QF*PHEP(I,3)
+ ENDDO
+ EP1=HWULDO(E,PHEP(1,NHEP+2))
+ EP2=HWULDO(E,PHEP(1,NHEP+3))
+ EP3=HWULDO(E,PHEP(1,NHEP+4))
+ EP4=HWULDO(E,PHEP(1,NHEP+5))
+ ENDIF
+C q-qbar-g-g
+ GG1=HWH4J1(P12,P13,P14,P23,P24,P34,EP1,EP2,EP3,EP4,ORIENT)
+ & +HWH4J1(P12,P24,P23,P14,P13,P34,EP2,EP1,EP4,EP3,ORIENT)
+ GG2=HWH4J1(P12,P23,P24,P13,P14,P34,EP2,EP1,EP3,EP4,ORIENT)
+ & +HWH4J1(P12,P14,P13,P24,P23,P34,EP1,EP2,EP4,EP3,ORIENT)
+ GG12=HWH4J2(P12,P13,P14,P23,P24,P34,EP1,EP2,EP3,EP4,ORIENT)
+ & +HWH4J2(P12,P14,P13,P24,P23,P34,EP1,EP2,EP4,EP3,ORIENT)
+ & +HWH4J2(P12,P23,P24,P13,P14,P34,EP2,EP1,EP3,EP4,ORIENT)
+ & +HWH4J2(P12,P24,P23,P14,P13,P34,EP2,EP1,EP4,EP3,ORIENT)
+ GG3=HWH4J4(P12,P13,P14,P23,P24,P34,EP1,EP2,EP3,EP4,ORIENT)
+ & +HWH4J4(P12,P24,P23,P14,P13,P34,EP2,EP1,EP4,EP3,ORIENT)
+ GG13=GG3+HWH4J5(P12,P13,P14,P23,P24,P34,EP1,EP2,EP3,EP4,ORIENT)
+ & +HWH4J5(P12,P24,P23,P14,P13,P34,EP2,EP1,EP4,EP3,ORIENT)
+ GG23=GG3+HWH4J5(P12,P14,P13,P24,P23,P34,EP1,EP2,EP4,EP3,ORIENT)
+ & +HWH4J5(P12,P23,P24,P13,P14,P34,EP2,EP1,EP3,EP4,ORIENT)
+C Add up weights
+ GG1 =COLA*(GG1 +GG13)
+ GG2 =COLA*(GG2 +GG23)
+ GGINT=COLB*(GG12-GG13-GG23)
+ WTGG=FACTR*(GG1+GG2+GGINT)
+C q-qbar-q-qbar
+ QP=HWH4J6(P13,P12,P14,P23,P34,P24,EP1,EP3,EP2,EP4,ORIENT)
+ & +HWH4J6(P24,P12,P23,P14,P34,P13,EP2,EP4,EP1,EP3,ORIENT)
+ & +HWH4J6(P13,P34,P23,P14,P12,P24,EP3,EP1,EP4,EP2,ORIENT)
+ & +HWH4J6(P24,P34,P14,P23,P12,P13,EP4,EP2,EP3,EP1,ORIENT)
+ QQ=HWH4J6(P13,P23,P34,P12,P14,P24,EP3,EP1,EP2,EP4,ORIENT)
+ & +HWH4J6(P24,P23,P12,P34,P14,P13,EP2,EP4,EP3,EP1,ORIENT)
+ & +HWH4J6(P13,P14,P12,P34,P23,P24,EP1,EP3,EP4,EP2,ORIENT)
+ & +HWH4J6(P24,P14,P34,P12,P23,P13,EP4,EP2,EP1,EP3,ORIENT)
+ QQINT=HWH4J7(P13,P12,P14,P23,P34,P24,EP1,EP3,EP2,EP4,ORIENT)
+ & +HWH4J7(P24,P12,P23,P14,P34,P13,EP2,EP4,EP1,EP3,ORIENT)
+ & +HWH4J7(P13,P23,P34,P12,P14,P24,EP3,EP1,EP2,EP4,ORIENT)
+ & +HWH4J7(P24,P23,P12,P34,P14,P13,EP2,EP4,EP3,EP1,ORIENT)
+ & +HWH4J7(P13,P14,P12,P34,P23,P24,EP1,EP3,EP4,EP2,ORIENT)
+ & +HWH4J7(P24,P14,P34,P12,P23,P13,EP4,EP2,EP1,EP3,ORIENT)
+ & +HWH4J7(P13,P34,P23,P14,P12,P24,EP3,EP1,EP4,EP2,ORIENT)
+ & +HWH4J7(P24,P34,P14,P23,P12,P13,EP4,EP2,EP3,EP1,ORIENT)
+C Add up weights
+ WTQP=FACTR*COLC*QP/TWO
+ QQ1 =COLC*QP
+ QQ2 =COLC*QQ
+ QQINT=COLB*QQINT
+ WTQQ=FACTR*(QQ1+QQ2+QQINT)/2
+ ENDIF
+C
+ HCS=0.
+ DO 60 ID1=IDMN,IDMX
+ IF (INCLQG(ID1)) THEN
+C Gluon channel
+ HCS=HCS+CLF(1,ID1)*WTGG
+ IF (GENEV.AND.HCS.GT.RCS) THEN
+C Select colour flow
+ WTAB=GG1
+ WTBA=GG2
+ IF (IOP4JT(1).EQ.1) THEN
+ IF (GGINT.GE.ZERO) THEN
+ WTAB=WTAB+GGINT
+ ELSE
+ WTBA=MAX(WTBA,WTBA+GGINT)
+ ENDIF
+ ELSEIF (IOP4JT(1).EQ.2) THEN
+ IF (GGINT.GE.ZERO) THEN
+ WTBA=WTBA+GGINT
+ ELSE
+ WTAB=MAX(WTAB,WTAB+GGINT)
+ ENDIF
+ ELSEIF (IOP4JT(1).NE.0) THEN
+ CALL HWWARN('HWH4JT',101,*999)
+ ENDIF
+ WTOT=WTAB+WTBA
+ IF (WTAB.GT.HWR()*WTOT) THEN
+ CALL HWHQCP( 13, 13,3142,91,*99)
+ ELSE
+ CALL HWHQCP( 13, 13,4123,92,*99)
+ ENDIF
+ ENDIF
+ ENDIF
+C Quark channels
+ DO 50 ID2=1,6
+C Identical quark pairs
+ IF (ID1.EQ.ID2.AND.INCLQQ(ID1,ID1)) THEN
+ HCS=HCS+CLF(1,ID1)*WTQQ
+ IF (GENEV.AND.HCS.GT.RCS) THEN
+C Select colour flow
+ WTAB=QQ1
+ WTBA=QQ2
+ IF (IOP4JT(2).EQ.1) THEN
+ IF (QQINT.GE.ZERO) THEN
+ WTAB=WTAB+QQINT
+ ELSE
+ WTBA=MAX(WTBA,WTBA+QQINT)
+ ENDIF
+ ELSEIF (IOP4JT(2).EQ.2) THEN
+ IF (QQINT.GE.ZERO) THEN
+ WTBA=WTBA+QQINT
+ ELSE
+ WTAB=MAX(WTAB,WTAB+QQINT)
+ ENDIF
+ ELSEIF (IOP4JT(2).NE.0) THEN
+ CALL HWWARN('HWH4JT',102,*999)
+ ENDIF
+ WTOT=WTAB+WTBA
+ IF (WTAB.GT.HWR()*WTOT) THEN
+ CALL HWHQCP(ID1,ID1+6,4123,93,*99)
+ ELSE
+ CALL HWHQCP(ID1,ID1+6,2143,94,*99)
+ ENDIF
+ ENDIF
+C Unlike quark pairs
+ ELSEIF (INCLQQ(ID1,ID2)) THEN
+ HCS=HCS+(CLF(1,ID1)+CLF(1,ID2))*WTQP
+ IF (GENEV.AND.HCS.GT.RCS) CALL HWHQCP(ID2,ID2+6,4123,95,*99)
+ ENDIF
+ 50 CONTINUE
+ 60 CONTINUE
+ EVWGT=HCS
+ RETURN
+C Set up labels for selected final state
+ 99 IDN(1)=ID1
+ IDN(2)=ID1+6
+ J=NHEP+1
+ IDHW(J)=200
+ IDHEP(J)=23
+ ISTHEP(J)=110
+ JMOHEP(1,J)=LM
+ JMOHEP(2,J)=LP
+ JDAHEP(1,J)=NHEP+2
+ JDAHEP(2,J)=NHEP+5
+ DO 100 I=1,4
+ J=NHEP+1+I
+ IDHW(J)=IDN(I)
+ IDHEP(J)=IDPDG(IDN(I))
+ ISTHEP(J)=IST(I)
+ JMOHEP(1,J)=NHEP+1
+ 100 JDAHEP(1,J)=0
+C And colour structure pointers
+ DO 110 I=1,4
+ J=ICO(I)
+ JMOHEP(2,NHEP+1+I)=NHEP+1+J
+ 110 JDAHEP(2,NHEP+1+J)=NHEP+1+I
+ NHEP=NHEP+5
+ 999 END
+CDECK ID>, HWH4J1.
+*CMZ :- -01/04/99 19.47.55 by Mike Seymour
+*-- Author : Ian Knowles
+C-----------------------------------------------------------------------
+ FUNCTION HWH4J1(S12,S13,S14,S23,S24,S34,EP1,EP2,EP3,EP4,ORIENT)
+C-----------------------------------------------------------------------
+C Evaluate `ERT' functions A, B, C, D, E; S12=(p1+p2)^2 etc.
+C-----------------------------------------------------------------------
+ IMPLICIT NONE
+ DOUBLE PRECISION HWH4J1,HWH4J2,HWH4J4,HWH4J5,HWH4J6,HWH4J7,
+ & S12,S13,S14,S23,S24,S34,S123,S124,S134,S234,S,EP1,EP2,EP3,EP4,
+ & SUM
+ LOGICAL ORIENT
+ S123=S12+S13+S23
+ S124=S12+S14+S24
+ S134=S13+S14+S34
+ S234=S23+S24+S34
+ S=S12+S13+S14+S23+S24+S34
+ HWH4J1=(S12*((S12+S14+S23+S34)**2+S13*(S12+S14-S24)+S24*(S12+S23))
+ & +(S14*S23-S12*S34-S13*S24)*(S14+S23+S34)/2)
+ & /(S13*S24*S134*S234)
+ & +((S12+S24)*(S13+S34)-S14*S23)/(S13*S134**2)
+ & +2*S23*(S-S13)/(S13*S134*S24) + S34/(2*S13*S24)
+ IF (ORIENT) THEN
+ HWH4J1=HWH4J1
+ & +4*((EP1*EP1*((S-S13)*(S23+S24)-S24*S34)
+ & -EP1*EP2*(S12*(S123+S124)+(S+S12)*(S14+S23)+2*S14*S23
+ & +S24*S134+S234*(S13+2*S234))
+ & +EP1*EP3*(S*(S24-S12)+S12*S13+(S14+2*S234-S34)*S24)
+ & -EP1*EP4*(S12*S124+S23*(S+S12+S14))
+ & +EP2*EP2*((S-S24)*(S13+S14)+2*(S13+S34)*S234-S13*S34)
+ & -EP2*EP3*((S+S23)*(S12+S14)+(S12+2*(S23+S234))*S234)
+ & +EP2*EP4*(S12*(S24-S)+S13*(S+S23-S34)+2*(S13+S34-S234)*S234)
+ & +EP3*EP3*(S14+2*S234)*S24
+ & +EP3*EP4*(-S234*(2*(S12+S23)+S134)+S12*S34-S13*S24-S14*S23)
+ & +EP4*EP4*S13*S23)*S134
+ & +EP2*(EP1+EP3+EP4)*2*S14*S24*S234)/(S*S13*S24*S134**2*S234)
+ ELSE
+ HWH4J1=2*HWH4J1/3
+ ENDIF
+ RETURN
+C-----------------------------------------------------------------------
+ ENTRY HWH4J2(S12,S13,S14,S23,S24,S34,EP1,EP2,EP3,EP4,ORIENT)
+C-----------------------------------------------------------------------
+ S123=S12+S13+S23
+ S124=S12+S14+S24
+ S134=S13+S14+S34
+ S234=S23+S24+S34
+ S=S12+S13+S14+S23+S24+S34
+ HWH4J2=(S12*S14*(S24+S34)+S24*(S12*(S14+S34)+S13*(S14-S24)))
+ & /(S14*S23*S13*S134)
+ & +S12*(S+S34)*S124/(S24*S234*S14*S134)
+ & -(S13*(2*(S12+S24)+S23)+S14**2)/(S134*S13*S14)
+ & +S12*S123*S124/(2*S13*S24*S14*S23)
+ IF (ORIENT) THEN
+ HWH4J2=HWH4J2
+ & +4*((EP1*EP1*(S12*S134*S234-4*S23*S24*S34)
+ & +EP1*EP2*(2*(2*S13*S234+S14*S123)*S24-S12*S134*(S+S12+S34))
+ & +EP1*EP3*(S12*(4*S24*S34-S134*(S12+S14-S24))
+ & -4*(S13*S24-S14*S23)*S24)
+ & +EP1*EP4*(4*(S13+S14)*S23*S24-S12*S134*(S12+S13-S23))
+ & +EP2*EP2*(S12*S134-4*S13*S24)*S134
+ & +EP2*EP3*(4*S13*(S12+S23+S24)*S24-S12*S134*(S12-S14+S24))
+ & -EP2*EP4*(4*(S12*(S14+S134)+S13*(S134-S234))*S24
+ & +S12*(S12-S13+S23)*S134)
+ & -EP3*EP3*4*S12*S14*S24
+ & -EP3*EP4*2*S12*(2*S14*S24+S12*S134))*S234
+ & +(EP1*(EP1*(S23+S24)+EP2*(S134-2*S))
+ & -(EP1+EP2)*(EP3+EP4)*S12+EP2*EP2*(S13+S14))*2*S14*S24*S123)
+ & /(2*S*S13*S14*S234*S23*S24*S134)
+ ELSE
+ HWH4J2=2*HWH4J2/3
+ ENDIF
+ RETURN
+C-----------------------------------------------------------------------
+ ENTRY HWH4J4(S12,S13,S14,S23,S24,S34,EP1,EP2,EP3,EP4,ORIENT)
+C-----------------------------------------------------------------------
+ S134=S13+S14+S34
+ S234=S23+S24+S34
+ S=S12+S13+S14+S23+S24+S34
+ HWH4J4=-(S12*(S34*(3*(S+S34)+S12)-S134*S234-2*(S13*S24+S14*S23))
+ & +(S14*S23-S13*S24)*(S13-S14+S24-S23))/(2*S134*S234*S34**2)
+ & -(S12*(S134**2/2+2*S13*S14+S34*(S13+S14-S34))
+ & +S34*((S13+S14)*(S23+S24)+S14*S24+S13*S23)
+ & +(S13*S24-S14*S23)*(S14-S13))/(S34*S134)**2
+ IF (ORIENT) THEN
+ HWH4J4=HWH4J4
+ & +4*((-EP1*EP1*2*(S23+S24)*S34
+ & -EP1*EP2*(S13*(S23+3*S24)+S14*(3*S23+S24)-(4*S12-S34)*S34)
+ & +EP1*EP3*((2*S12-S24)*S34-(S13-S14)*S24)
+ & +EP1*EP4*((2*S12-S23)*S34+(S13-S14)*S23)
+ & -EP2*EP2*2*(S13+S14)*S34
+ & +EP2*EP3*(2*S12*S34-S14*(S23-S24+S34))
+ & +EP2*EP4*(2*S12*S34+S13*(S23-S24-S34))
+ & +EP3*EP3*2*S14*S24
+ & +EP3*EP4*2*(S12*S34-S13*S24-S14*S23)
+ & +EP4*EP4*2*S13*S23)/(S*S134*S234*S34**2)
+ & +(EP1*EP2*(S134*(S134+2*S34)+4*(S13*S14-S34**2))
+ & +EP2*EP3*2*(2*S13*S34+S14*(S13-S14+S34))
+ & +EP2*EP4*2*(2*S14*S34-S13*(S13-S14-S34)))
+ & /(S*(S134*S34)**2))
+ ELSE
+ HWH4J4=2*HWH4J4/3
+ ENDIF
+ RETURN
+C-----------------------------------------------------------------------
+ ENTRY HWH4J5(S12,S13,S14,S23,S24,S34,EP1,EP2,EP3,EP4,ORIENT)
+C-----------------------------------------------------------------------
+ S123=S12+S13+S23
+ S124=S12+S14+S24
+ S134=S13+S14+S34
+ S234=S23+S24+S34
+ S=S12+S13+S14+S23+S24+S34
+ HWH4J5=(3*S12*S34**2-3*S13*S24*S34+3*S12*S24*S34+3*S14*S23*S34-
+ $ S13*S24**2-S12*S23*S34+6*S12*S14*S34+2*S12*S13*S34-
+ $ 2*S12**2*S34+S14*S23*S24-3*S13*S23*S24-2*S13*S14*S24+
+ $ 4*S12*S14*S24+2*S12*S13*S24+3*S14*S23**2+2*S14**2*S23+
+ $ 2*S14**2*S12+2*S12**2*S14+6*S12*S14*S23-2*S12*S13**2-
+ $ 2*S12**2*S13)/(2*S13*S134*S234*S34)+
+ $ (2*S12*S34**2-2*S13*S24*S34+S12*S24*S34+4*S13*S23*S34+
+ $ 4*S12*S14*S34+2*S12*S13*S34+2*S12**2*S34-S13*S24**2+
+ $ 3*S14*S23*S24+4*S13*S23*S24-2*S13*S14*S24+4*S12*S14*S24+
+ $ 2*S12*S13*S24+2*S14*S23**2+4*S13*S23**2+2*S13*S14*S23+
+ $ 2*S12*S14*S23+4*S12*S13*S23+2*S12*S14**2+4*S12**2*S13+
+ $ 4*S12*S13*S14+2*S12**2*S14)/(2*S13*S134*S24*S34)-
+ $ (S12*S34**2-2*S14*S24*S34-2*S13*S24*S34-S14*S23*S34+
+ $ S13*S23*S34+S12*S14*S34+2*S12*S13*S34-2*S14**2*S24-
+ $ 4*S13*S14*S24-4*S13**2*S24-S14**2*S23-S13**2*S23+
+ $ S12*S13*S14-S12*S13**2)/(S13*S34*S134**2)
+ IF (ORIENT) THEN
+ SUM=
+ & +EP1*EP1*((S13-S14+S23-3*S24)*S34+(S134+S14+2*S34)*S234)
+ & *S24*S134
+ & +EP1*EP2*((2*(S12-S24)+S34)*S134-S14*(4*S12+S14+3*S23)
+ & +S13*(S13+S23)+S24*S34 )*S24*S134
+ & -EP1*EP2*(((2*S12*S134+S13*(2*(S12+S14+S23)-S24+S34)
+ & +S14*(S14-S23)+(2*S14-S34)*S234)*S234)*S134
+ & + 4*S13**2*S24*S234)
+ & +EP1*EP3*(S12*(2*S13-S134)+S13*(S24+2*S234)+S14*(3*S24-S234)
+ & +S34*(S234-3*S24))*S24*S134
+ & +EP1*EP4*((S12*(S13-S14+3*S34)-S23*(S13+3*S14-S34))*S24
+ & -(S12*(S13+S134+2*S34)+2*S13*S24
+ & +(S13-2*S14)*S23)*S234)*S134
+ & +EP2*EP2*(S13*((2*S13+S34)*S234+S24*(S134-2*S34))
+ & +2*S14*S134*(S24+S234))*S134
+ SUM=SUM
+ & -EP2*EP3*(((S12*(S13+2*S14-S34)+S14*(S+2*S23-S34))*S24
+ & +(S12*(S13+S134)+(S13+S24+2*S234)*S14
+ & +2*S13*(2*S23+S34))*S234)*S134
+ & +4*S13**2*S24*S234)
+ & +EP2*EP4*(((S12*(S13-2*S134)+S13*(S+2*S23-3*S34))*S24
+ & -((S-3*S13+S23+2*S24)*S13+2*S12*S14
+ & +2*S14*(S23+2*S24))*S234)*S134-4*S13**2*S24*S234)
+ & +EP3*EP3*2*(S13*S234+S14*S24)*S24*S134
+ & +EP3*EP4*(2*(S12*S34-S13*S24-S14*S23)*S24
+ & -(S12*S134+2*S13*S23)*S234)*S134
+ & +EP4*EP4*2*(S12*S234+S23*S24)*S13*S134
+ HWH4J5=HWH4J5+4*SUM/(S*S234*S134**2*S13*S34*S24)
+ ELSE
+ HWH4J5=2*HWH4J5/3
+ ENDIF
+ RETURN
+C-----------------------------------------------------------------------
+ ENTRY HWH4J6(S12,S13,S14,S23,S24,S34,EP1,EP2,EP3,EP4,ORIENT)
+C-----------------------------------------------------------------------
+ S123=S12+S13+S23
+ S124=S12+S14+S24
+ S134=S13+S14+S34
+ S234=S23+S24+S34
+ S=S12+S13+S14+S23+S24+S34
+ HWH4J6=(S23*(S123*S234-S*S23)+S12*(S123*S124-S*S12))/(S13*S123)**2
+ & -(S12*S34*(S234-2*S23)+S14*S23*(S234-2*S34)
+ & -S13*S24*(S234+S13))/(S13**2*S123*S134)
+ IF (ORIENT) THEN
+ HWH4J6=HWH4J6
+ & +4*(-EP1*EP1*2*S23*S34
+ & +EP1*EP2*((S12-S23)*S34-S13*(S24-S34))
+ & +(EP1*EP3+EP2*EP4)*2*(S12*S34-S13*S24+S14*S23)
+ & -EP1*EP4*(S13*S24-(3*(S13+S14)+S34)*S23)
+ & -(EP1+EP2+EP3)*EP4*2
+ & *(S12*(S13+S23)+(S12+S13)*S23)*S134/S123
+ & +EP2*EP2*S13*(S14+S34)
+ & +EP2*EP3*(S13*(S14-S24)-(S12-S23)*S14)
+ & -EP3*EP3*2*S12*S14
+ & -EP3*EP4*(S13*S24-(3*(S13+S34)+S14)*S12)
+ & +EP4*EP4*(S12+S23)*S13)/(S*S134*S123*S13**2)
+ ELSE
+ HWH4J6=2*HWH4J6/3
+ ENDIF
+ RETURN
+C-----------------------------------------------------------------------
+ ENTRY HWH4J7(S12,S13,S14,S23,S24,S34,EP1,EP2,EP3,EP4,ORIENT)
+C-----------------------------------------------------------------------
+ S123=S12+S13+S23
+ S124=S12+S14+S24
+ S134=S13+S14+S34
+ S234=S23+S24+S34
+ S=S12+S13+S14+S23+S24+S34
+ HWH4J7=((S12*S34+S13*S24-S14*S23)*(S13+S14+S23+S24)-2*S12*S24*S34)
+ & /(S13*S134*S23*S123)
+ & -S12*(S12*S-S123*S124)/(S123**2*S13*S23)
+ & -(S13+S14)*(S23+S24)*S34/(S13*S134*S23*S234)
+ IF (ORIENT) THEN
+ HWH4J7=HWH4J7
+ & +4*(+2*(EP1+EP2)*(S23*EP1-S13*EP2)*S34*S134
+ & -EP1*EP2*2*S34**2*S123
+ & +EP1*EP3*(S123*(S23+S24)*S34+2*S134*(S13*S24-S14*S23))
+ & +EP1*EP4*(S123*(S23+S24)*S34+2*S12**2*S134*S234/S123
+ & +2*S134*(S24*(S13-S12)-S23*(S12+S14)))
+ & +EP2*EP3*(2*(S12*S34+S13*S24-S14*S23)*S134
+ & +S123*(S13+S14)*S34)
+ & +EP2*EP4*(S123*(S13+S14)*S34+2*S12**2*S234*S134/S123
+ & -2*S134*(S12*S234-S13*S24+S14*S23))
+ & -EP3*EP3*S12*(2*S24*S134+S123*S34)
+ & +EP3*EP4*2*S12*(S134*(S23-S24)-S34*S123+S12*S134*S234/S123)
+ & +EP4*EP4*S12*(2*S23*S134-S123*S34))
+ & /(S*S13*S23*S123*S134*S234)
+ ELSE
+ HWH4J7=2*HWH4J7/3
+ ENDIF
+ RETURN
+ END
+CDECK ID>, HWHBGF.
+*CMZ :- -26/04/91 11.11.55 by Bryan Webber
+*-- Author : Giovanni Abbiendi & Luca Stanco
+C-----------------------------------------------------------------------
+ SUBROUTINE HWHBGF
+C-----------------------------------------------------------------------
+C Order Alpha_s processes in charged lepton-hadron collisions
+C
+C Process code IPROC has to be set in the Main Program
+C the following codes IPROC may be selected
+C
+C 9100 : NC BOSON-GLUON FUSION
+C 9100+IQK (IQK=1,...,6) : produced flavour is IQK
+C 9107 : produced J/psi + gluon
+C
+C 9110 : NC QCD COMPTON
+C 9110+IQK (IQK=1,...,12) : struck parton is IQK
+C
+C 9130 : NC order alpha_s processes (9100+9110)
+C
+C Select maximum and minimum generated flavour when IQK=0
+C setting IFLMIN and IFLMAX in the Main Program
+C (allowed values from 1 to 6), default are 1 and 5
+C allowing d,u,s,c,b,dbar,ubar,sbar,cbar,bbar
+C
+C CHARGED CURRENT Boson-Gluon Fusion processes
+C 9141 : CC s cbar (c sbar)
+C 9142 : CC b cbar (c bbar)
+C 9143 : CC s tbar (t cbar)
+C 9144 : CC b tbar (t bbar)
+C
+C other inputs : Q2MIN,Q2MAX,YBMIN,YBMAX,PTMIN,EMMIN,EMMAX
+C when IPROC=(1)9107 : as above but Q2WWMN, Q2WWMX substitute
+C Q2MIN and Q2MAX (EPA is used); ZJMAX cut
+C
+C Add 10000 to suppress soft remnant fragmentation
+C
+C Mean EVWGT = cross section in nanoBarn
+C
+C-----------------------------------------------------------------------
+ INCLUDE 'HERWIG61.INC'
+ DOUBLE PRECISION HWR,LEP,Y,Q2,SHAT,Z,PHI,AJACOB,DSIGMA,ME,MP,
+ & ML,MREMIF(18),MFIN1(18),MFIN2(18),RS,SMA,W2,RSHAT,FSIGMA(18),
+ & SIGSUM,PROB,PRAN,PVRT(4),X
+ INTEGER IQK,IFLAVU,IFLAVD,IMIN,IMAX,IFL,IPROO,LEPFIN,ID1,ID2,I,IDD
+ LOGICAL CHARGD,INCLUD(18),INSIDE(18)
+ EXTERNAL HWR
+ SAVE LEPFIN,ID1,ID2,FSIGMA,SIGSUM
+ COMMON /HWAREA/ LEP,Y,Q2,SHAT,Z,PHI,AJACOB,DSIGMA,ME,MP,ML,MREMIF,
+ & MFIN1,MFIN2,RS,SMA,W2,RSHAT,IQK,IFLAVU,IFLAVD,IMIN,IMAX,IFL,
+ & IPROO,CHARGD,INCLUD,INSIDE
+C---Initialization
+ IF (FSTWGT) THEN
+C---LEP = 1 FOR LEPTONS, -1 FOR ANTILEPTONS
+ LEP=ZERO
+ IF (IDHW(1).GE.121.AND.IDHW(1).LE.126) THEN
+ LEP=ONE
+ ELSEIF (IDHW(1).GE.127.AND.IDHW(1).LE.132) THEN
+ LEP=-ONE
+ ENDIF
+ IF (LEP.EQ.ZERO) CALL HWWARN('HWHBGF',500,*999)
+ IPROO=MOD(IPROC,100)/10
+ IF (IPROO.EQ.0.OR.IPROO.EQ.4) THEN
+ IQK=MOD(IPROC,10)
+ IFL=IQK
+ IF (IQK.EQ.7) IFL=164
+ CHARGD=IPROO.EQ.4
+ ELSEIF (IPROO.EQ.1.OR.IPROO.EQ.2) THEN
+ IQK=MOD(IPROC,100)-10
+ IFL=IQK+6
+ CHARGD=.FALSE.
+ ELSEIF (IPROO.EQ.3) THEN
+ IQK=0
+ IFL=0
+ CHARGD=.FALSE.
+ ELSE
+ CALL HWWARN('HWHBGF',501,*999)
+ ENDIF
+C
+ LEPFIN = IDHW(1)
+ IF(CHARGD) THEN
+ LEPFIN = IDHW(1)+1
+ IF (IQK.EQ.1) THEN
+ IFLAVU=4
+ IFLAVD=3
+ ID1 = 3
+ ID2 = 10
+ ELSEIF (IQK.EQ.2) THEN
+ IFLAVU=4
+ IFLAVD=5
+ ID1 = 5
+ ID2 = 10
+ ELSEIF (IQK.EQ.3) THEN
+ IFLAVU=6
+ IFLAVD=3
+ ID1 = 3
+ ID2 =12
+ ELSE
+ IFLAVU=6
+ IFLAVD=5
+ ID1 = 5
+ ID2 =12
+ ENDIF
+ IF (LEP.EQ.-1.) THEN
+ IDD=ID1
+ ID1=ID2-6
+ ID2=IDD+6
+ ENDIF
+ ENDIF
+C
+ IF (IQK.EQ.0) THEN
+ DO I=1,18
+ INCLUD(I)=.TRUE.
+ ENDDO
+ IMIN=1
+ IMAX=18
+ DO I=1,6
+ IF (I.LT.IFLMIN.OR.I.GT.IFLMAX) INCLUD(I)=.FALSE.
+ ENDDO
+ DO I=7,18
+ IF (I.LE.12) THEN
+ IF (I-6.LT.IFLMIN.OR.I-6.GT.IFLMAX) INCLUD(I)=.FALSE.
+ ELSE
+ IF (I-12.LT.IFLMIN.OR.I-12.GT.IFLMAX) INCLUD(I)=.FALSE.
+ ENDIF
+ ENDDO
+ IF (IPROO.EQ.0) THEN
+ DO I=7,18
+ INCLUD(I)=.FALSE.
+ ENDDO
+ IMIN=IFLMIN
+ IMAX=IFLMAX
+ ELSEIF (IPROO.EQ.1.OR.IPROO.EQ.2) THEN
+ DO I=1,6
+ INCLUD(I)=.FALSE.
+ ENDDO
+ IMIN=IFLMIN+6
+ IMAX=IFLMAX+12
+ ELSEIF (IPROO.EQ.3) THEN
+ IMIN=IFLMIN
+ IMAX=IFLMAX+12
+ ENDIF
+ ELSEIF (IQK.NE.0 .AND. (.NOT.CHARGD)) THEN
+ DO I=1,18
+ INCLUD(I)=.FALSE.
+ ENDDO
+ IF (IFL.LE.18) THEN
+ INCLUD(IFL)=.TRUE.
+ IMIN=IFL
+ IMAX=IFL
+ ELSEIF (IFL.EQ.164) THEN
+ INCLUD(7)=.TRUE.
+ IMIN=7
+ IMAX=7
+ ENDIF
+ ENDIF
+ ENDIF
+C---End of initialization
+ IF(GENEV) THEN
+ IF (.NOT.CHARGD) THEN
+ IF (IQK.EQ.0) THEN
+ PRAN= SIGSUM * HWR()
+ PROB=ZERO
+ DO 10 IFL=IMIN,IMAX
+ IF (.NOT.INSIDE(IFL)) GOTO 10
+ PROB=PROB+FSIGMA(IFL)
+ IF (PROB.GE.PRAN) GOTO 20
+ 10 CONTINUE
+ ENDIF
+C---at this point the subprocess has been selected (IFL)
+ 20 CONTINUE
+ IF (IFL.LE.6) THEN
+C---Boson-Gluon Fusion event
+ IDHW(NHEP+1)=IDHW(1)
+ IDHW(NHEP+2)=13
+ IDHW(NHEP+3)=15
+ IDHW(NHEP+4)=LEPFIN
+ IDHW(NHEP+5)=IFL
+ IDHW(NHEP+6)=IFL+6
+ ELSEIF (IFL.GE.7.AND.IFL.LE.18) THEN
+C---QCD_Compton event
+ IDHW(NHEP+1)=IDHW(1)
+ IDHW(NHEP+2)=IFL-6
+ IDHW(NHEP+3)=15
+ IDHW(NHEP+4)=LEPFIN
+ IDHW(NHEP+5)=IFL-6
+ IDHW(NHEP+6)=13
+ ELSEIF (IFL.EQ.164) THEN
+C---gamma+gluon-->J/Psi+gluon
+ IDHW(NHEP+1)=IDHW(1)
+ IDHW(NHEP+2)=13
+ IDHW(NHEP+3)=15
+ IDHW(NHEP+4)=LEPFIN
+ IDHW(NHEP+5)=164
+ IDHW(NHEP+6)=13
+ ELSE
+ CALL HWWARN('HWHBGF',503,*999)
+ ENDIF
+ ELSE
+C---Charged current event of specified flavours
+ IDHW(NHEP+1)=IDHW(1)
+ IDHW(NHEP+2)=13
+ IDHW(NHEP+3)=15
+ IDHW(NHEP+4)=LEPFIN
+ IDHW(NHEP+5)=ID1
+ IDHW(NHEP+6)=ID2
+ ENDIF
+C
+ DO 1 I=NHEP+1,NHEP+6
+ 1 IDHEP(I)=IDPDG(IDHW(I))
+C
+C---Codes common for all processes
+ ISTHEP(NHEP+1)=111
+ ISTHEP(NHEP+2)=112
+ ISTHEP(NHEP+3)=110
+ ISTHEP(NHEP+4)=113
+ ISTHEP(NHEP+5)=114
+ ISTHEP(NHEP+6)=114
+C
+ DO I=NHEP+1,NHEP+6
+ JMOHEP(1,I)=NHEP+3
+ JDAHEP(1,I)=0
+ ENDDO
+C---Incoming lepton
+ JMOHEP(2,NHEP+1)=NHEP+4
+ JDAHEP(2,NHEP+1)=NHEP+4
+C---Hard Process C.M.
+ JMOHEP(1,NHEP+3)=NHEP+1
+ JMOHEP(2,NHEP+3)=NHEP+2
+ JDAHEP(1,NHEP+3)=NHEP+4
+ JDAHEP(2,NHEP+3)=NHEP+6
+C---Outgoing lepton
+ JMOHEP(2,NHEP+4)=NHEP+1
+ JDAHEP(2,NHEP+4)=NHEP+1
+C
+ IF (IFL.LE.6 .OR. CHARGD) THEN
+C---Codes for boson-gluon fusion processes
+C--- Incoming gluon
+ JMOHEP(2,NHEP+2)=NHEP+6
+ JDAHEP(2,NHEP+2)=NHEP+5
+C--- Outgoing quark
+ JMOHEP(2,NHEP+5)=NHEP+2
+ JDAHEP(2,NHEP+5)=NHEP+6
+C--- Outgoing antiquark
+ JMOHEP(2,NHEP+6)=NHEP+5
+ JDAHEP(2,NHEP+6)=NHEP+2
+ ELSEIF (IFL.GE.7 .AND. IFL.LE.12) THEN
+C---Codes for V+q --> q+g
+C--- Incoming quark
+ JMOHEP(2,NHEP+2)=NHEP+5
+ JDAHEP(2,NHEP+2)=NHEP+6
+C--- Outgoing quark
+ JMOHEP(2,NHEP+5)=NHEP+6
+ JDAHEP(2,NHEP+5)=NHEP+2
+C--- Outgoing gluon
+ JMOHEP(2,NHEP+6)=NHEP+2
+ JDAHEP(2,NHEP+6)=NHEP+5
+ ELSEIF (IFL.GE.13 .AND. IFL.LE.18) THEN
+C---Codes for V+qbar --> qbar+g
+C--- Incoming antiquark
+ JMOHEP(2,NHEP+2)=NHEP+6
+ JDAHEP(2,NHEP+2)=NHEP+5
+C--- Outgoing antiquark
+ JMOHEP(2,NHEP+5)=NHEP+2
+ JDAHEP(2,NHEP+5)=NHEP+6
+C--- Outgoing gluon
+ JMOHEP(2,NHEP+6)=NHEP+5
+ JDAHEP(2,NHEP+6)=NHEP+2
+ ELSEIF (IFL.EQ.164) THEN
+C---Codes for Gamma+gluon --> J/Psi+gluon
+C--- Incoming gluon
+ JMOHEP(2,NHEP+2)=NHEP+6
+ JDAHEP(2,NHEP+2)=NHEP+6
+C--- Outgoing J/Psi
+ JMOHEP(2,NHEP+5)=NHEP+1
+ JDAHEP(2,NHEP+5)=NHEP+1
+C--- Outgoing gluon
+ JMOHEP(2,NHEP+6)=NHEP+2
+ JDAHEP(2,NHEP+6)=NHEP+2
+ ENDIF
+C---Computation of momenta in Laboratory frame of reference
+ CALL HWHBKI
+ NHEP=NHEP+6
+C Decide which quark radiated and assign production vertices
+ IF (IFL.LE.6) THEN
+C Boson-Gluon fusion case
+ IF (1-Z.LT.HWR()) THEN
+C Gluon splitting to quark
+ CALL HWVZRO(4,VHEP(1,NHEP-1))
+ CALL HWVDIF(4,PHEP(1,NHEP-4),PHEP(1,NHEP),PVRT)
+ CALL HWUDKL(IFL,PVRT,VHEP(1,NHEP))
+ CALL HWVEQU(4,VHEP(1,NHEP),VHEP(1,NHEP-4))
+ ELSE
+C Gluon splitting to antiquark
+ CALL HWVZRO(4,VHEP(1,NHEP))
+ CALL HWVDIF(4,PHEP(1,NHEP-4),PHEP(1,NHEP-1),PVRT)
+ CALL HWUDKL(IFL,PVRT,VHEP(1,NHEP-1))
+ CALL HWVEQU(4,VHEP(1,NHEP-1),VHEP(1,NHEP-4))
+ ENDIF
+ ELSEIF (IFL.GE.7.AND.IFL.LE.18) THEN
+C QCD Compton case
+ X=1/(1+SHAT/Q2)
+ IF (1.LT.HWR()*(1+(1-X-Z)**2+6*X*(1-X)*Z*(1-Z))) THEN
+C Incoming quark radiated the gluon
+ CALL HWVZRO(4,VHEP(1,NHEP-1))
+ CALL HWVDIF(4,PHEP(1,NHEP-4),PHEP(1,NHEP),PVRT)
+ CALL HWUDKL(IFL-6,PVRT,VHEP(1,NHEP))
+ CALL HWVEQU(4,VHEP(1,NHEP),VHEP(1,NHEP-4))
+ ELSE
+C Outgoing quark radiated the gluon
+ CALL HWVZRO(4,VHEP(1,NHEP-4))
+ CALL HWVSUM(4,PHEP(1,NHEP-1),PHEP(1,NHEP),PVRT)
+ CALL HWUDKL(IFL-6,PVRT,VHEP(1,NHEP))
+ CALL HWVEQU(4,VHEP(1,NHEP),VHEP(1,NHEP-1))
+ ENDIF
+ ENDIF
+C---HERWIG gets confused if lepton momentum is different from beam
+C momentum, which it can be if incoming hadron has negative virtuality
+C As a temporary fix, simply copy the momentum.
+C Momentum conservation somehow gets taken care of HWBGEN!
+ call hwvequ(5,phep(1,1),phep(1,nhep-5))
+ ELSE
+ EVWGT=ZERO
+C---generation of the 5 variables Y,Q2,SHAT,Z,PHI and Jacobian computation
+C---in the largest phase space avalaible for selected processes and
+C---filling of logical vector INSIDE to tag contributing ones
+ CALL HWHBRN (*999)
+C---calculate differential cross section corresponding to the chosen
+C---variables and the weight for MC generation
+ IF (IQK.EQ.0) THEN
+C---many subprocesses included
+ DO I=1,18
+ FSIGMA(I)=ZERO
+ ENDDO
+ SIGSUM=ZERO
+ DO I=IMIN,IMAX
+ IF (INSIDE(I)) THEN
+ IFL=I
+ DSIGMA=ZERO
+ CALL HWHBSG
+ FSIGMA(I)=DSIGMA
+ SIGSUM=SIGSUM+DSIGMA
+ ENDIF
+ ENDDO
+ EVWGT=SIGSUM * AJACOB
+ ELSE
+C---only one subprocess included
+ CALL HWHBSG
+ EVWGT= DSIGMA * AJACOB
+ ENDIF
+ IF (EVWGT.LT.ZERO) EVWGT=ZERO
+ ENDIF
+ 999 END
+CDECK ID>, HWHBKI.
+*CMZ :- -26/04/91 13.19.32 by Federico Carminati
+*-- Author : Giovanni Abbiendi & Luca Stanco
+C----------------------------------------------------------------------
+ SUBROUTINE HWHBKI
+C----------------------------------------------------------------------
+C gives the fourmomenta in the laboratory system for the particles
+C of the hard 2-->3 subprocess, to match with HERWIG routines of
+C jet evolution.
+C----------------------------------------------------------------------
+ INCLUDE 'HERWIG61.INC'
+ DOUBLE PRECISION HWUECM,HWUPCM,HWUSQR,LEP,Y,Q2,SHAT,Z,PHI,AJACOB,
+ & DSIGMA,ME,MP,ML,MREMIF(18),MFIN1(18),MFIN2(18),RS,SMA,W2,RSHAT,
+ & PGAMMA(5),SG,MF1,MF2,EP,PP,EL,PL,E1,E2,Q1,COSBET,SINBET,COSTHE,
+ & SINTHE,SINAZI,COSAZI,ROTAZI(3,3),EGAM,A,PPROT,MREMIN,PGAM,PEP(5),
+ & COSPHI,SINPHI,ROT(3,3),EPROT,PROTON(5),MPART
+ INTEGER IQK,IFLAVU,IFLAVD,IMIN,IMAX,IFL,IPROO,I,IHAD,J,IS,ICMF
+ LOGICAL CHARGD,INCLUD(18),INSIDE(18)
+ EXTERNAL HWUECM,HWUPCM,HWUSQR
+ COMMON /HWAREA/ LEP,Y,Q2,SHAT,Z,PHI,AJACOB,DSIGMA,ME,MP,ML,MREMIF,
+ & MFIN1,MFIN2,RS,SMA,W2,RSHAT,IQK,IFLAVU,IFLAVD,IMIN,IMAX,IFL,
+ & IPROO,CHARGD,INCLUD,INSIDE
+C
+ IHAD=2
+ IF (JDAHEP(1,IHAD).NE.0) IHAD=JDAHEP(1,IHAD)
+C---Set masses
+ IF (CHARGD) THEN
+ MPART=ZERO
+ MF1=RMASS(IDHW(NHEP+5))
+ MF2=RMASS(IDHW(NHEP+6))
+ MREMIN=MP
+ ELSE
+ IS = IFL
+ IF (IFL.EQ.164) IS=IQK
+ MPART=ZERO
+ IF (IFL.GE.7.AND.IFL.LE.18) MPART=RMASS(IFL-6)
+ MF1=MFIN1(IS)
+ MF2=MFIN2(IS)
+ MREMIN = MREMIF(IS)
+ ENDIF
+C---Calculation of kinematical variables for the generated event
+C in the center of mass frame of the incoming boson and parton
+C with parton along +z
+ EGAM = HWUECM (SHAT, -Q2, MPART**2)
+ PGAM = SQRT( EGAM**2 + Q2 )
+ EP = RSHAT-EGAM
+ PP = PGAM
+ A = (W2+Q2-MP**2)/TWO
+ PPROT = (A*PGAM-EGAM*SQRT(A**2+MP**2*Q2))/Q2
+ IF (PPROT.LT.ZERO) CALL HWWARN('HWHBKI',101,*999)
+ EPROT = SQRT(PPROT**2+MP**2)
+ IF ((EPROT+PPROT).LT.(EP+PP)) CALL HWWARN('HWHBKI',102,*999)
+ EL = ( PGAM / PPROT * SMA - Q2 ) / TWO
+ + / (EGAM + PGAM / PPROT * EPROT)
+ IF (EL.GT.ME) THEN
+ PL = SQRT ( EL**2 - ME**2 )
+ ELSE
+ CALL HWWARN ('HWHBKI',103,*999)
+ ENDIF
+ COSBET = (TWO * EPROT * EL - SMA) / (TWO * PPROT * PL)
+ IF ( ABS(COSBET) .GE. ONE ) THEN
+ COSBET = SIGN (ONE,COSBET)
+ SINBET = ZERO
+ ELSE
+ SINBET = SQRT (ONE - COSBET**2)
+ ENDIF
+ SG = ME**2 + MPART**2 + Q2 + TWO * RSHAT * EL
+ IF (SG.LE.(RSHAT+ML)**2 .OR. SG.GE.(RS-MREMIN)**2)
+ + CALL HWWARN ('HWHBKI',104,*999)
+ Q1 = HWUPCM( RSHAT, MF1, MF2)
+ E1 = SQRT(Q1**2+MF1**2)
+ E2 = SQRT(Q1**2+MF2**2)
+ IF (Q1 .GT. ZERO) THEN
+ COSTHE=(TWO*EP*E1 - Z*(SHAT+Q2))/(TWO*PP*Q1)
+ IF (ABS(COSTHE) .GT. ONE) THEN
+ COSTHE=SIGN(ONE,COSTHE)
+ SINTHE=ZERO
+ ELSE
+ SINTHE=SQRT(ONE-COSTHE**2)
+ ENDIF
+ ELSE
+ COSTHE=ZERO
+ SINTHE=ONE
+ ENDIF
+C---Initial lepton
+ PHEP(1,NHEP+1)=PL*SINBET
+ PHEP(2,NHEP+1)=ZERO
+ PHEP(3,NHEP+1)=PL*COSBET
+ PHEP(4,NHEP+1)=EL
+ PHEP(5,NHEP+1)=RMASS(IDHW(1))
+C---Initial Hadron
+ PROTON(1)=ZERO
+ PROTON(2)=ZERO
+ PROTON(3)=PPROT
+ PROTON(4)=EPROT
+ CALL HWUMAS (PROTON)
+C---Initial parton
+ PHEP(1,NHEP+2)=ZERO
+ PHEP(2,NHEP+2)=ZERO
+ PHEP(3,NHEP+2)=PP
+ PHEP(4,NHEP+2)=EP
+ PHEP(5,NHEP+2)=MPART
+C---HARD SUBPROCESS 2-->3 CENTRE OF MASS
+ PHEP(1,NHEP+3)=PHEP(1,NHEP+1)+PHEP(1,NHEP+2)
+ PHEP(2,NHEP+3)=PHEP(2,NHEP+1)+PHEP(2,NHEP+2)
+ PHEP(3,NHEP+3)=PHEP(3,NHEP+1)+PHEP(3,NHEP+2)
+ PHEP(4,NHEP+3)=PHEP(4,NHEP+1)+PHEP(4,NHEP+2)
+ CALL HWUMAS ( PHEP(1,NHEP+3) )
+C---Virtual boson
+ PGAMMA(1)=ZERO
+ PGAMMA(2)=ZERO
+ PGAMMA(3)=-PGAM
+ PGAMMA(4)=EGAM
+ PGAMMA(5)=HWUSQR(Q2)
+C---Scattered lepton
+ PHEP(1,NHEP+4)=PHEP(1,NHEP+1)-PGAMMA(1)
+ PHEP(2,NHEP+4)=PHEP(2,NHEP+1)-PGAMMA(2)
+ PHEP(3,NHEP+4)=PHEP(3,NHEP+1)-PGAMMA(3)
+ PHEP(4,NHEP+4)=PHEP(4,NHEP+1)-PGAMMA(4)
+ PHEP(5,NHEP+4)=RMASS(IDHW(1))
+ IF (CHARGD) PHEP(5,NHEP+4)=ZERO
+C---First Final parton: quark (or J/psi) in Boson-Gluon Fusion
+C--- quark or antiquark in QCD Compton
+ PHEP(1,NHEP+5)=Q1*SINTHE*COS(PHI)
+ PHEP(2,NHEP+5)=Q1*SINTHE*SIN(PHI)
+ PHEP(3,NHEP+5)=Q1*COSTHE
+ PHEP(4,NHEP+5)=E1
+ PHEP(5,NHEP+5)=MF1
+C---Second Final parton: antiquark in Boson-Gluon Fusion
+C--- gluon in QCD Compton
+ PHEP(1,NHEP+6)=-PHEP(1,NHEP+5)
+ PHEP(2,NHEP+6)=-PHEP(2,NHEP+5)
+ PHEP(3,NHEP+6)=-PHEP(3,NHEP+5)
+ PHEP(4,NHEP+6)=E2
+ PHEP(5,NHEP+6)=MF2
+C---Boost to lepton-hadron CM frame
+ PEP(1) = PHEP(1,NHEP+1)
+ PEP(2) = PHEP(2,NHEP+1)
+ PEP(3) = PHEP(3,NHEP+1) + PPROT
+ PEP(4) = PHEP(4,NHEP+1) + EPROT
+ CALL HWUMAS (PEP)
+ DO I=1,6
+ CALL HWULOF (PEP,PHEP(1,NHEP+I),PHEP(1,NHEP+I))
+ ENDDO
+ CALL HWULOF (PEP,PROTON,PROTON)
+ CALL HWULOF (PEP,PGAMMA,PGAMMA)
+C---Rotation around y-axis to align lepton beam with z-axis
+ COSPHI = PHEP(3,NHEP+1) /
+ & SQRT( PHEP(1,NHEP+1)**2 + PHEP(3,NHEP+1)**2 )
+ SINPHI = PHEP(1,NHEP+1) /
+ & SQRT( PHEP(1,NHEP+1)**2 + PHEP(3,NHEP+1)**2 )
+ DO I=1,3
+ DO J=1,3
+ ROT(I,J)=ZERO
+ ENDDO
+ ENDDO
+ ROT(1,1) = COSPHI
+ ROT(1,3) = -SINPHI
+ ROT(2,2) = ONE
+ ROT(3,1) = SINPHI
+ ROT(3,3) = COSPHI
+ DO I=1,6
+ CALL HWUROF (ROT,PHEP(1,NHEP+I),PHEP(1,NHEP+I))
+ ENDDO
+ CALL HWUROF (ROT,PROTON,PROTON)
+ CALL HWUROF (ROT,PGAMMA,PGAMMA)
+C---Boost to the LAB frame
+ ICMF=3
+ DO I=1,6
+ CALL HWULOB (PHEP(1,ICMF),PHEP(1,NHEP+I),PHEP(1,NHEP+I))
+ ENDDO
+ CALL HWULOB (PHEP(1,ICMF),PROTON,PROTON)
+ CALL HWULOB (PHEP(1,ICMF),PGAMMA,PGAMMA)
+C---Random azimuthal rotation
+ CALL HWRAZM (ONE,COSAZI,SINAZI)
+ DO I=1,3
+ DO J=1,3
+ ROTAZI(I,J)=ZERO
+ ENDDO
+ ENDDO
+ ROTAZI(1,1) = COSAZI
+ ROTAZI(1,2) = SINAZI
+ ROTAZI(2,1) = -SINAZI
+ ROTAZI(2,2) = COSAZI
+ ROTAZI(3,3) = ONE
+ DO I=1,6
+ CALL HWUROF (ROTAZI,PHEP(1,NHEP+I),PHEP(1,NHEP+I))
+ ENDDO
+ CALL HWUROF (ROTAZI,PROTON,PROTON)
+ CALL HWUROF (ROTAZI,PGAMMA,PGAMMA)
+ 999 END
+CDECK ID>, HWHBRN.
+*CMZ :- -03/07/95 19.02.12 by Giovanni Abbiendi
+*-- Author : Giovanni Abbiendi & Luca Stanco
+C-----------------------------------------------------------------------
+ SUBROUTINE HWHBRN (*)
+C----------------------------------------------------------------------
+C Returns a point in the phase space (Y,Q2,SHAT,Z,PHI) and the
+C corresponding Jacobian factor AJACOB
+C Fill the logical vector INSIDE to tag contributing subprocesses
+C to the cross-section
+C-----------------------------------------------------------------------
+ INCLUDE 'HERWIG61.INC'
+ DOUBLE PRECISION HWRUNI,HWR,HWUPCM,LEP,Y,Q2,SHAT,Z,PHI,AJACOB,
+ & DSIGMA,ME,MP,ML,MREMIF(18),MFIN1(18),MFIN2(18),RS,SMA,W2,RSHAT,
+ & MF1,MF2,YMIN,YMAX,YJAC,Q2INF,Q2SUP,Q2JAC,EMW2,ZMIN,ZMAX,ZJAC,
+ & GAMMA2,LAMBDA,PHIJAC,ZINT,ZLMIN,ZL,EMW,TMIN,TMAX,EMLMIN,EMLMAX,
+ & SHMIN,EMMIF(18),EMMAF(18),WMIF(18),WMIN,MREMIN,YMIF(18),Q1CM(18),
+ & Q2MAF(18),EMMAWF(18),ZMIF(18),ZMAF(18),PLMAX,PINC,SHINF,SHSUP,
+ & SHJAC,CTHLIM,Q1,DETDSH,SRY,SRY0,SRY1
+ INTEGER IQK,IFLAVU,IFLAVD,I,IMIN,IMAX,IFL,IPROO,IHAD,NTRY,DEBUG
+ LOGICAL CHARGD,INCLUD(18),INSIDE(18)
+ EXTERNAL HWRUNI,HWR,HWUPCM
+ SAVE EMLMIN,EMLMAX,EMMIF,EMMAF,MREMIN,MF1,MF2,YMIF,
+ & YMIN,YMAX,WMIN,WMIF
+ COMMON /HWAREA/ LEP,Y,Q2,SHAT,Z,PHI,AJACOB,DSIGMA,ME,MP,ML,MREMIF,
+ & MFIN1,MFIN2,RS,SMA,W2,RSHAT,IQK,IFLAVU,IFLAVD,IMIN,IMAX,IFL,
+ & IPROO,CHARGD,INCLUD,INSIDE
+ EQUIVALENCE (EMW,RMASS(198))
+C
+ IHAD=2
+ IF (JDAHEP(1,IHAD).NE.0) IHAD=JDAHEP(1,IHAD)
+C---Initialization
+ IF (FSTWGT.OR.IHAD.NE.2) THEN
+ ME = RMASS(IDHW(1))
+ MP = RMASS(IDHW(IHAD))
+ RS = PHEP(5,3)
+ SMA = RS**2-ME**2-MP**2
+ PINC = HWUPCM(RS,ME,MP)
+C---Charged current
+ IF (CHARGD) THEN
+ ML=RMASS(IDHW(1)+1)
+ YMAX = ONE - TWO*ML*MP / SMA
+ YMAX = MIN(YMAX,YBMAX)
+ MREMIN=MP
+ IF (LEP.EQ.ONE) THEN
+ MF1=RMASS(IFLAVD)
+ MF2=RMASS(IFLAVU)
+ ELSE
+ MF1=RMASS(IFLAVU)
+ MF2=RMASS(IFLAVD)
+ ENDIF
+ SHMIN = MF1**2+MF2**2 + TWO * PTMIN**2 +
+ + TWO * SQRT(PTMIN**2+MF1**2) * SQRT(PTMIN**2+MF2**2)
+ EMLMIN=MAX(EMMIN,SQRT(SHMIN))
+ EMLMAX=MIN(EMMAX,RS-ML-MREMIN)
+ DEBUG=1
+ IF (EMLMIN.GT.EMLMAX) GOTO 888
+ WMIN=EMLMIN+MREMIN
+ PLMAX=HWUPCM(RS,ML,WMIN)
+ YMIN = ONE-TWO*(SQRT(PINC**2+MP**2)*SQRT(PLMAX**2+ML**2)+
+ + PINC*PLMAX)/SMA
+ YMIN = MAX(YMIN,YBMIN)
+ DEBUG=2
+ IF (YMIN.GT.YMAX) GOTO 888
+ ELSE
+C---Neutral current
+ ML = ME
+ YMAX = ONE - TWO*ML*MP / SMA
+ YMAX = MIN(YMAX,YBMAX)
+ DO I=1,18
+ YMIF(I)=ZERO
+ EMMIF(I)=ZERO
+ EMMAF(I)=ZERO
+ WMIF(I)=ZERO
+ IF (I.LE.8) THEN
+C---Boson-Gluon Fusion (also J/Psi) and QCD Compton with struck u or d
+ MREMIF(I)=MP
+ IF (I.LE.6) THEN
+ MFIN1(I)=RMASS(I)
+ MFIN2(I)=RMASS(I+6)
+ ELSE
+ MFIN1(I)=RMASS(I-6)
+ MFIN2(I)=ZERO
+ ENDIF
+ ELSE
+C---QCD Compton with struck non-valence parton
+ MREMIF(I)=MP+RMASS(I-6)
+ MFIN1(I)=RMASS(I-6)
+ MFIN2(I)=ZERO
+ ENDIF
+ ENDDO
+ IF (IFL.EQ.164) THEN
+C---J/Psi
+ MFIN1(7)=RMASS(164)
+ MFIN2(7)=ZERO
+ ENDIF
+C---y boundaries for different flavours and processes
+ DO 100 I=IMIN,IMAX
+ IF (INCLUD(I)) THEN
+ MF1=MFIN1(I)
+ MF2=MFIN2(I)
+ MREMIN=MREMIF(I)
+ SHMIN = MF1**2+MF2**2 + TWO * PTMIN**2 +
+ + TWO * SQRT(PTMIN**2+MF1**2) * SQRT(PTMIN**2+MF2**2)
+ EMMIF(I) = MAX(EMMIN,SQRT(SHMIN))
+ EMMAF(I) = MIN(EMMAX,RS-ML-MREMIN)
+ IF (EMMIF(I).GT.EMMAF(I)) THEN
+ INCLUD(I)=.FALSE.
+ CALL HWWARN('HWHBRN',3,*999)
+ GOTO 100
+ ENDIF
+ WMIF(I) = EMMIF(I)+MREMIF(I)
+ WMIN = WMIF(I)
+ PLMAX = HWUPCM(RS,ML,WMIN)
+ YMIF(I)=ONE-TWO*(SQRT(PINC**2+MP**2)*SQRT(PLMAX**2+ML**2)+
+ + PINC*PLMAX)/SMA
+ IF (YMIF(I).GT.YMAX) THEN
+ INCLUD(I)=.FALSE.
+ CALL HWWARN('HWHBRN',4,*999)
+ GOTO 100
+ ENDIF
+ ENDIF
+ 100 CONTINUE
+C---considering the largest boundaries
+ EMLMIN=EMMIF(IMIN)
+ EMLMAX=EMMAF(IMIN)
+ IF (IPROO.EQ.3) THEN
+ EMLMIN=MIN(EMMIF(IMIN),EMMIF(IMIN+6))
+ EMLMAX=MAX(EMMAF(IMIN),EMMAF(IMIN+6))
+ ENDIF
+ DEBUG=3
+ IF (EMLMIN.GT.EMLMAX) GOTO 888
+ YMIN=YMIF(IMIN)
+ IF (IPROO.EQ.3) YMIN=MIN(YMIF(IMIN),YMIF(IMIN+6))
+ YMIN = MAX(YMIN,YBMIN)
+ DEBUG=4
+ IF (YMIN.GT.YMAX) GOTO 888
+ WMIN = WMIF(IMIN)
+ MREMIN = MREMIF(IMIN)
+ MF1=MFIN1(IMIN)
+ MF2=MFIN2(IMIN)
+ IF (IPROO.EQ.3) THEN
+ WMIN = MIN(WMIF(IMIN),WMIF(IMIN+6))
+ MREMIN = MIN(MREMIF(IMIN),MREMIF(IMIN+6))
+ ENDIF
+ ENDIF
+ ENDIF
+C---Random generation in largest phase space
+ Y=ZERO
+ Q2=ZERO
+ SHAT=ZERO
+ Z=ZERO
+ PHI=ZERO
+ AJACOB=ZERO
+C---y generation
+ IF (.NOT.CHARGD) THEN
+ IF (IFL.LE.5.OR.(IFL.GE.7.AND.IFL.LE.18)) THEN
+ SRY0 = SQRT(YMIN)
+ SRY1 = SQRT(YMAX)
+ SRY = HWRUNI(0,SRY0,SRY1)
+ Y = SRY**2
+ YJAC = TWO*SRY*(SRY1-SRY0)
+ ELSEIF (IFL.EQ.6) THEN
+ Y = SQRT(HWRUNI(0,YMIN**2,YMAX**2))
+ YJAC = HALF * (YMAX**2-YMIN**2) / Y
+ ELSEIF (IFL.EQ.164) THEN
+C---in J/psi photoproduction Y and Q2 are given by the Equivalent Photon
+C Approximation
+ 10 NTRY=0
+ 20 NTRY=NTRY+1
+ IF (NTRY.GT.NETRY) CALL HWWARN('HWHBRN',50,*10)
+ Y = (YMIN/YMAX)**HWR()*YMAX
+ IF (ONE+(ONE-Y)**2.LT.TWO*HWR()) GOTO 20
+ YJAC=(TWO*LOG(YMAX/YMIN)-TWO*(YMAX-YMIN)
+ & +HALF*(YMAX**2-YMIN**2))
+ ENDIF
+ ELSE
+ IF (IPRO.EQ.5) THEN
+ Y = EXP(HWRUNI(0,LOG(YMIN),LOG(YMAX)))
+ YJAC = Y * LOG(YMAX/YMIN)
+ ELSE
+ Y = HWRUNI(0,YMIN,YMAX)
+ YJAC = YMAX - YMIN
+ ENDIF
+ ENDIF
+C---Q**2 generation
+ Q2INF = ME**2*Y**2 / (ONE-Y)
+ Q2SUP = MP**2 + SMA*Y - WMIN**2
+ IF (IFL.EQ.164) THEN
+ Q2INF = MAX(Q2INF,Q2WWMN)
+ Q2SUP = MIN(Q2SUP,Q2WWMX)
+ ELSE
+ Q2INF = MAX(Q2INF,Q2MIN)
+ Q2SUP = MIN(Q2SUP,Q2MAX)
+ ENDIF
+ DEBUG=5
+ IF (Q2INF .GT. Q2SUP) GOTO 888
+C
+ IF (.NOT.CHARGD) THEN
+ IF (IFL.EQ.164) THEN
+ Q2 = EXP(HWRUNI(0,LOG(Q2INF),LOG(Q2SUP)))
+ Q2JAC = LOG(Q2SUP/Q2INF)
+ ELSEIF (Q2INF.LT.RMASS(4)**2) THEN
+ Q2 = EXP(HWRUNI(0,LOG(Q2INF),LOG(Q2SUP)))
+ Q2JAC = Q2 * LOG(Q2SUP/Q2INF)
+ ELSE
+ Q2 = Q2INF*Q2SUP/HWRUNI(0,Q2INF,Q2SUP)
+ Q2JAC = Q2**2 * (Q2SUP-Q2INF)/(Q2SUP*Q2INF)
+ ENDIF
+ ELSE
+ EMW2=EMW**2
+ Q2=(Q2INF+EMW2)*(Q2SUP+EMW2)/(HWRUNI(0,Q2INF,Q2SUP)+EMW2)-EMW2
+ Q2JAC=(Q2+EMW2)**2*(Q2SUP-Q2INF)/((Q2SUP+EMW2)*(Q2INF+EMW2))
+ ENDIF
+ W2 = MP**2 + SMA*Y - Q2
+C---s_hat generation
+ SHINF = EMLMIN **2
+ SHSUP = (MIN(SQRT(W2)-MREMIN,EMLMAX))**2
+ DEBUG=6
+ IF (SHINF .GT. SHSUP) GOTO 888
+C
+ IF (IPRO.EQ.91) THEN
+ IF (.NOT.CHARGD) THEN
+ SHAT = SHINF*SHSUP/HWRUNI(0,SHINF,SHSUP)
+ SHJAC = SHAT**2 * (SHSUP-SHINF)/(SHSUP*SHINF)
+ ELSE
+ SHAT = EXP(HWRUNI(0,LOG(SHINF),LOG(SHSUP)))
+ SHJAC = SHAT*(LOG(SHSUP/SHINF))
+ ENDIF
+ ELSE
+ EMW2=EMW**2
+ IF (SHINF.GT.EMW2+10*GAMW*EMW) THEN
+ SHAT = SHINF*SHSUP/HWRUNI(0,SHINF,SHSUP)
+ SHJAC = SHAT**2 * (SHSUP-SHINF)/(SHSUP*SHINF)
+ ELSEIF (SHSUP.LT.EMW2-10*EMW*GAMW) THEN
+ SHAT = HWRUNI(0,SHINF,SHSUP)
+ SHJAC = SHSUP-SHINF
+ ELSE
+ TMIN=ATAN((SHINF-EMW2)/(GAMW*EMW))
+ TMAX=ATAN((SHSUP-EMW2)/(GAMW*EMW))
+ SHAT = GAMW*EMW*TAN(HWRUNI(0,TMIN,TMAX))+EMW2
+ SHJAC=((SHAT-EMW2)**2+(GAMW*EMW)**2)/(GAMW*EMW)*(TMAX-TMIN)
+ ENDIF
+ ENDIF
+ DETDSH = ONE/SMA/Y
+ SHJAC=SHJAC*DETDSH
+ RSHAT = SQRT (SHAT)
+C--- z generation
+ ZMIN = 10E10
+ ZMAX = -ONE
+ IF (.NOT.CHARGD) THEN
+ DO I=1,18
+ Q1CM(I) = ZERO
+ ZMIF(I) = ZERO
+ ZMAF(I) = ZERO
+ ENDDO
+ DO 150 I=IMIN,IMAX
+ IF (INCLUD(I)) THEN
+ Q1CM(I) = HWUPCM( RSHAT, MFIN1(I), MFIN2(I) )
+ IF (Q1CM(I) .LT. PTMIN) THEN
+ ZMAF(I)=-ONE
+ GOTO 150
+ ENDIF
+ CTHLIM = SQRT(ONE - (PTMIN / Q1CM(I))**2)
+ GAMMA2 = SHAT + MFIN1(I)**2 - MFIN2(I)**2
+ LAMBDA = (SHAT-MFIN1(I)**2-MFIN2(I)**2)**2 -
+ + 4.D0*MFIN1(I)**2*MFIN2(I)**2
+ ZMIF(I) = (GAMMA2 - SQRT(LAMBDA)*CTHLIM)/TWO/SHAT
+ ZMIF(I) = MAX(ZMIF(I),ZERO)
+ ZMAF(I) = (GAMMA2 + SQRT(LAMBDA)*CTHLIM)/TWO/SHAT
+ ZMAF(I) = MIN(ZMAF(I),ONE)
+ ZMIN = MIN( ZMIN, ZMIF(I) )
+ ZMAX = MAX( ZMAX, ZMAF(I) )
+ ENDIF
+ 150 CONTINUE
+ IF (IFL.EQ.164) ZMAX=MIN(ZMAX,ZJMAX)
+ ELSE
+ Q1 = HWUPCM(RSHAT,MF1,MF2)
+ DEBUG=7
+ IF (Q1.LT.PTMIN) GOTO 888
+ CTHLIM = SQRT(ONE-(PTMIN/Q1)**2)
+ GAMMA2 = SHAT+MF1**2-MF2**2
+ LAMBDA = (SHAT-MF1**2-MF2**2)**2-4.D0*MF1**2*MF2**2
+ ZMIN = (GAMMA2-SQRT(LAMBDA)*CTHLIM)/TWO/SHAT
+ ZMIN = MAX(ZMIN,1D-6)
+ ZMAX = (GAMMA2+SQRT(LAMBDA)*CTHLIM)/TWO/SHAT
+ ZMAX = MIN(ZMAX,ONE-1D-6)
+ ENDIF
+ DEBUG=8
+ IF (ZMIN .GT. ZMAX) GOTO 888
+ ZLMIN = LOG(ZMIN/(ONE-ZMIN))
+ ZINT = LOG(ZMAX/(ONE-ZMAX)) - LOG(ZMIN/(ONE-ZMIN))
+ ZL = ZLMIN+HWR()*ZINT
+ Z = EXP(ZL)/(ONE+EXP(ZL))
+ ZJAC = Z*(ONE-Z)*ZINT
+C
+ DEBUG=9
+ IF ((Y.LT.YMIN.OR.Y.GT.YMAX).OR.(Q2.LT.Q2INF.OR.Q2.GT.Q2SUP).OR.
+ + (SHAT.LT.SHINF.OR.SHAT.GT.SHSUP).OR.(Z.LT.ZMIN.OR.Z.GT.ZMAX))
+ + GOTO 888
+C---Phi generation
+ PHI = HWRUNI(0,ZERO,2*PIFAC)
+ PHIJAC = 2 * PIFAC
+ IF (IFL.EQ.164) PHIJAC=ONE
+C
+ AJACOB = YJAC * Q2JAC * SHJAC * ZJAC * PHIJAC
+C
+ IF (IQK.NE.0.OR.IPRO.EQ.5) GOTO 999
+C---contributing subprocesses: filling of logical vector INSIDE
+ DO I=1,18
+ INSIDE(I)=.FALSE.
+ Q2MAF(I)=ZERO
+ EMMAWF(I)=ZERO
+ ENDDO
+ DO 200 I=IMIN,IMAX
+ IF (INCLUD(I)) THEN
+ IF ( Y.LT.YMIF(I) ) GOTO 200
+C
+ Q2MAF(I) = MP**2 + SMA*Y - WMIF(I)**2
+ Q2MAF(I) = MIN( Q2MAF(I), Q2MAX)
+ IF (Q2INF .GT. Q2MAF(I)) GOTO 200
+ IF (Q2.LT.Q2INF .OR. Q2.GT.Q2MAF(I)) GOTO 200
+C
+ EMMAWF(I) = SQRT(W2) - MREMIF(I)
+ EMMAWF(I) = MIN( EMMAWF(I), EMLMAX )
+C
+ IF (EMMIF(I) .GT. EMMAWF(I)) GOTO 200
+ IF (SHAT.LT.EMMIF(I)**2.OR.SHAT.GT.EMMAWF(I)**2) GOTO 200
+C
+ IF (ZMIF(I) .GT. ZMAF(I)) GOTO 200
+ IF (Z.LT.ZMIF(I) .OR. Z.GT.ZMAF(I)) GOTO 200
+ INSIDE(I)=.TRUE.
+ ENDIF
+ 200 CONTINUE
+ 999 RETURN
+ 888 EVWGT=ZERO
+C---UNCOMMENT THIS LINE TO GET A DEBUGGING WARNING FOR NO PHASE-SPACE
+C CALL HWWARN('HWHBRN',DEBUG,*777)
+ 777 RETURN 1
+ END
+CDECK ID>, HWHBSG.
+*CMZ :- -03/07/95 19.02.12 by Giovanni Abbiendi
+*-- Author : Giovanni Abbiendi & Luca Stanco
+C----------------------------------------------------------------------
+ SUBROUTINE HWHBSG
+C----------------------------------------------------------------------
+C Returns differential cross section DSIGMA in (Y,Q2,ETA,Z,PHI)
+C Scale for structure functions and alpha_s selected by BGSHAT
+C----------------------------------------------------------------------
+ INCLUDE 'HERWIG61.INC'
+ DOUBLE PRECISION HWUALF,HWUAEM,LEP,Y,Q2,SHAT,Z,PHI,AJACOB,DSIGMA,
+ & ME,MP,ML,MREMIF(18),MFIN1(18),MFIN2(18),RS,SMA,W2,RSHAT,
+ & SFUN(13),ALPHA,LDSIG,DLQ(7),SG,XG,MF1,MF2,MSUM,MDIF,MPRO,FFUN,
+ & GFUN,H43,H41,H11,H12,H14,H16,H21,H22,G11,G12,G1A,G1B,G21,G22,G3,
+ & GC,A11,A12,A44,ALPHAS,PDENS,AFACT,BFACT,CFACT,DFACT,GAMMA,S,T,U,
+ & MREMIN,POL,CCOL,ETA
+ INTEGER IQK,IFLAVU,IFLAVD,IMIN,IMAX,IFL,IPROO,IHAD,ILEPT,IQ,IS
+ LOGICAL CHARGD,INCLUD(18),INSIDE(18)
+ EXTERNAL HWUALF,HWUAEM
+ COMMON /HWAREA/ LEP,Y,Q2,SHAT,Z,PHI,AJACOB,DSIGMA,ME,MP,ML,MREMIF,
+ & MFIN1,MFIN2,RS,SMA,W2,RSHAT,IQK,IFLAVU,IFLAVD,IMIN,IMAX,IFL,
+ & IPROO,CHARGD,INCLUD,INSIDE
+C
+ IHAD=2
+ IF (JDAHEP(1,IHAD).NE.0) IHAD=JDAHEP(1,IHAD)
+C---set masses
+ IF (CHARGD) THEN
+ MREMIN=MP
+ IF (LEP.EQ.ONE) THEN
+ MF1=RMASS(IFLAVD)
+ MF2=RMASS(IFLAVU)
+ ELSE
+ MF1=RMASS(IFLAVU)
+ MF2=RMASS(IFLAVD)
+ ENDIF
+ ELSE
+ IS=IFL
+ IF (IFL.EQ.164) IS=IQK
+ MREMIN = MREMIF(IS)
+ MF1 = MFIN1(IS)
+ MF2 = MFIN2(IS)
+ ENDIF
+C---choose subprocess scale
+ IF (BGSHAT) THEN
+ EMSCA = RSHAT
+ ELSE
+ S=SHAT+Q2
+ IF (IFL.GE.7.AND.IFL.LE.18) S=SHAT+Q2-MF1**2
+ T=-S*Z
+ U=-S-T
+ IF (IFL.GE.7.AND.IFL.LE.18) U=-S-T-2*MF1**2
+ EMSCA = SQRT(TWO*S*T*U/(S**2+T**2+U**2))
+ IF (IFL.EQ.164) EMSCA=SQRT(-U)
+ ENDIF
+ ALPHAS = HWUALF(1,EMSCA)
+ IF (ALPHAS.GE.ONE.OR.ALPHAS.LE.ZERO) CALL HWWARN('HWHBSG',51,*888)
+C---structure functions
+ ETA = (SHAT+Q2)/SMA/Y
+ IF (ETA.GT.ONE) ETA=ONE
+ CALL HWSFUN (ETA,EMSCA,IDHW(IHAD),NSTRU,SFUN,2)
+ XG = Q2/(SHAT + Q2)
+ SG = ETA*SMA
+ IF (SG.LE.(RSHAT+ML)**2.OR.SG.GE.(RS-MREMIN)**2) GOTO 888
+C
+ IF (IFL.EQ.164) GOTO 200
+C
+C---Electroweak couplings
+ ALPHA=HWUAEM(-Q2)
+ IF (CHARGD) THEN
+ POL = PPOLN(3) - EPOLN(3)
+ DLQ(1)=.0625*VCKM(IFLAVU/2,(IFLAVD+1)/2)/SWEIN**2 *
+ + Q2**2/((Q2+RMASS(198)**2)**2+(RMASS(198)*GAMW)**2) *
+ + (ONE + POL)
+ DLQ(2)=ZERO
+ DLQ(3)=DLQ(1)
+ ELSE
+ IQ=MOD(IFL-1,6)+1
+ ILEPT=MOD(IDHW(1)-121,6)+11
+ CALL HWUCFF(ILEPT,IQ,-Q2,DLQ(1))
+ ENDIF
+C
+ IF (IFL.LE.6) THEN
+C---For Boson-Gluon Fusion
+ PDENS = SFUN(13)/ETA
+ CCOL = HALF
+ MSUM = (MF1**2 + MF2**2) / (Y*SG)
+ MDIF = (MF1**2 - MF2**2) / (Y*SG)
+ MPRO = MF1*MF2 / (Y*SG)
+C
+ FFUN = (1.D0-XG)*Z*(1.D0-Z) + (MDIF*(2.D0*Z-1.D0)-MSUM)/2.D0
+ GFUN = (1.D0-XG)*(1.D0-Z) + XG*Z + MDIF
+ IF ( FFUN .LT. ZERO ) FFUN = ZERO
+ H43 = (8.D0*(2.D0*Z**2*XG-Z**2-2.D0*Z*XG+2.D0*Z*MDIF+Z-MDIF
+ & -MSUM)) / (Z*(1.D0-Z))**2
+C
+ H41 = (8.D0*(Z**2-Z*XG+Z*MDIF-MDIF-MSUM)) / (Z**2*(1.D0-Z))
+C
+ H11 = (4.D0*(2.D0*Z**4-4.D0*Z**3+2.D0*Z**2*MSUM*XG
+ & -2.D0*Z**2*MSUM+2.D0*Z**2*XG**2-2.D0*Z**2*XG+3.D0*Z**2
+ & +2.D0*Z*MDIF*MSUM+2.D0*Z*MDIF*XG-2.D0*Z*MSUM*XG
+ & +2.D0*Z*MSUM-2.D0*Z*XG**2+2.D0*Z*XG-Z-MDIF*MSUM-MDIF*XG
+ & -MSUM**2-MSUM*XG)) / (Z*(1.D0-Z))**2
+C
+ H12 = (16.D0*(-Z*MDIF+Z*XG+MDIF+MSUM))/(Z**2*(1.D0-Z))
+C
+ H14 = (16.D0*(-2.D0*Z**2*XG-2.D0*Z*MDIF+2.D0*Z*XG+MDIF+MSUM))
+ & / (Z*(1.D0-Z))**2
+C
+ H16 = (32.D0*(Z*MDIF-Z*XG-MDIF-MSUM)) / (Z**2*(1.D0-Z))
+C
+ H21 = (8.D0*MPRO*(-2.D0*Z**2*XG+2.D0*Z**2-2.D0*Z*MDIF+2.D0*Z*XG
+ + -2.D0*Z+MDIF+MSUM)) / (Z*(1.D0-Z))**2
+C
+ H22 = (-32.D0*MPRO) / (Z*(1.D0-Z))
+C
+ G11 = -2.D0*H11 + FFUN*H14
+ G12 = 2.D0*XG*FFUN*H14 + H12 + GFUN * ( H16+GFUN*H14 )
+ G1A = SQRT( XG*FFUN ) * ( H16 + 2.D0*GFUN*H14 )
+ G1B = FFUN*H14
+ G21 = -2.D0*H21
+ G22 = H22
+ G3 = H41 - GFUN*H43
+ GC = SQRT( XG*FFUN ) * (-2.D0*XG*H43 )
+ ELSE
+C---for QCD Compton, massless matrix element
+ PDENS = SFUN(IFL-6)/ETA
+ CCOL = CFFAC
+ FFUN = XG*(ONE-XG)*Z*(ONE-Z)
+ GFUN = (ONE-XG)*(ONE-Z)+XG*Z
+ G11 = 8.D0*((Z**2+XG**2)/(ONE-XG)/(ONE-Z)+TWO*(XG*Z+ONE))
+ G12 = 64.D0*XG**2*Z+TWO*XG*G11
+ G1A = 32.D0*XG*GFUN*SQRT(FFUN)/((ONE-XG)*(ONE-Z))
+ G1B = 16.D0*XG*Z
+ G3 = -16.D0*(ONE-XG)*(ONE-Z)+G11
+ GC = -16.D0*XG*SQRT(FFUN)*(ONE-Z-XG)/((ONE-XG)*(ONE-Z))
+ G21 = ZERO
+ G22 = ZERO
+ ENDIF
+C
+ A11 = XG * Y**2 * G11 + (1.D0-Y) * G12
+ & - (2.D0-Y) * SQRT( 1.D0-Y ) * G1A * COS( PHI )
+ & + 2.D0 * XG * (1.D0-Y) * G1B * COS( 2.D0*PHI )
+C
+ A12 = XG * Y**2 * G21 + (1.D0-Y) * G22
+C
+ A44 = XG * Y * (2.D0-Y) * G3
+ & - 2.D0 * Y * SQRT( 1.D0-Y ) * GC * COS( PHI )
+C
+ IF ( Y*Q2**2 .LT. 1D-38 ) THEN
+C---prevent numerical uncertainties in DSIGMA computation
+ DSIGMA = PDENS*ALPHA**2*ALPHAS*GEV2NB*CCOL/(16.D0*PIFAC)
+ & *(DLQ(1)*A11 + DLQ(2)*A12 + LEP*DLQ(3)*A44)
+ IF ( DSIGMA .LE. ZERO ) GOTO 888
+ LDSIG = LOG (DSIGMA) - LOG (Y) - 2.D0 * LOG (Q2)
+ DSIGMA = EXP (LDSIG)
+ ELSE
+ DSIGMA = PDENS*ALPHA**2*ALPHAS*GEV2NB*CCOL
+ & * (DLQ(1)*A11 + DLQ(2)*A12 + LEP*DLQ(3)*A44)
+ & / (16.D0*PIFAC*Y*Q2**2)
+ ENDIF
+ IF (DSIGMA.LT.ZERO) GOTO 888
+ RETURN
+C
+ 200 CONTINUE
+C--- J/psi production
+ ALPHA = HWUAEM(-Q2)
+ GAMMA = 4.8D-6
+ PDENS = SFUN(13)/ETA
+ AFACT = (8.D0*PIFAC*ALPHAS**2*RMASS(164)**3*GAMMA)/(3.D0*ALPHA)
+ BFACT = ONE/(Y*SG*Z**2*((Z-ONE)*Y*SG-RMASS(164)**2)**2)
+ CFACT = (RMASS(164)**2-Z*Y*SG)**2/(Y*SG*(ONE-XG)**2*
+ & ((ONE-XG)*Y*SG-RMASS(164)**2)**2*
+ & ((Z-ONE)*Y*SG-RMASS(164)**2)**2)
+ DFACT = ((Z-ONE)*Y*SG)**2/(Y*SG*(ONE-XG)**2*
+ & ((ONE-XG)*Y*SG-RMASS(164)**2)**2*(Z*Y*SG)**2)
+ DSIGMA = GEV2NB*ALPHA/(TWO*PIFAC)*AFACT*(BFACT+CFACT+DFACT)*PDENS
+ IF (DSIGMA.LT.ZERO ) GOTO 888
+ RETURN
+ 888 DSIGMA=ZERO
+ END
+CDECK ID>, HWHDIS.
+*CMZ :- -26/04/91 14.55.44 by Federico Carminati
+*-- Author : Giovanni Abbiendi & Luca Stanco
+C----------------------------------------------------------------------
+ SUBROUTINE HWHDIS
+C----------------------------------------------------------------------
+C DEEP INELASTIC LEPTON-HADRON SCATTERING: MEAN EVWGT = SIGMA IN NB
+C----------------------------------------------------------------------
+ INCLUDE 'HERWIG61.INC'
+ DOUBLE PRECISION HWR,HWRUNI,HWUPCM,PRAN,PROB,SAMP,SIG,Q2,
+ & XBJ,Y,W,S,MLEP,MHAD,MLSCAT,LEP,YMIN,YMAX,XXMAX,Q2JAC,XXJAC,
+ & JACOBI,A1,A2,A3,B1,B2,PCM,PCMEP,PCMLW,PCMEQ,PCMLQ,COSPHI,PA,
+ & EQ,PZQ,SHAT,PROP,DLEFT,DRGHT,DUP,DWN,FACT,EFACT,OMY2,YPLUS,
+ & YMNUS,SIGMA,AF(7,12),SMA,Q2SUP,HWUAEM,DCHRG,DNEUT
+ INTEGER I,IQK,IQKIN,IQKOUT,IDSCAT,IHAD,ILEPT
+ LOGICAL CHARGD
+ EXTERNAL HWR,HWRUNI,HWUPCM
+ SAVE MLEP,MHAD,S,SMA,PCM,MLSCAT,A1,A2,A3,B1,B2,DLEFT,DRGHT,Q2,
+ & AF,XBJ,Y,YPLUS,YMNUS,OMY2,FACT,EFACT,SIGMA,IDSCAT,CHARGD,
+ & ILEPT,DCHRG,DNEUT,LEP
+ IQK=MOD(IPROC,10)
+ IHAD=2
+ IF (JDAHEP(1,IHAD).NE.0) IHAD=JDAHEP(1,IHAD)
+ IF (FSTWGT.OR.IHAD.NE.2) THEN
+C---INITIALISE PROCESS (MUST BE DONE EVERY TIME IF S VARIES)
+C---LEPTON AND HADRON MASSES, INVARIANT MASS, MOMENTUM IN C.M. FRAME
+ MLEP=PHEP(5,1)
+ MHAD=PHEP(5,IHAD)
+ S=PHEP(5,3)**2
+ SMA=S-MLEP**2-MHAD**2
+ PCM=HWUPCM(SQRT(S),MLEP,MHAD)
+C---LEP = 1 FOR LEPTONS, -1 FOR ANTILEPTONS
+ IF (IDHW(1).GE.121.AND.IDHW(1).LE.126) THEN
+ LEP=+ONE
+ ELSEIF (IDHW(1).GE.127.AND.IDHW(1).LE.132) THEN
+ LEP=-ONE
+ ELSE
+ CALL HWWARN('HWHDIS',500,*999)
+ ENDIF
+ DCHRG=FLOAT(MOD(IDHW(1) ,2))
+ DNEUT=FLOAT(MOD(IDHW(1)+1,2))
+ ILEPT=MOD(IDHW(1)-121,6)+11
+C---DLEFT,DRIGHT = 1,0 for leptons; = 0,1 for anti-leptons
+ DLEFT=MAX(+LEP,ZERO)
+ DRGHT=MAX(-LEP,ZERO)
+ CHARGD=MOD(IPROC,100)/10.EQ.1
+C---Evaluate constant factor in cross section and
+C find and store scattered lepton identity
+ IF (CHARGD) THEN
+ IF ((EPOLN(3)-PPOLN(3)).EQ.ONE) THEN
+ WRITE(6,5)
+ CALL HWWARN('HWHDIS',501,*999)
+ 5 FORMAT(1X,'WARNING: Cross-section is zero for the',
+ & ' specified lepton helicity')
+ ENDIF
+ FACT=GEV2NB*(ONE-(EPOLN(3)-PPOLN(3)))*.25D0*PIFAC
+ & /(SWEIN*RMASS(198)**2)**2
+ IDSCAT=IDHW(1)+NINT(DCHRG-DNEUT)
+ ELSE
+ FACT=GEV2NB*TWO*PIFAC
+ IDSCAT=IDHW(1)
+ ENDIF
+ MLSCAT=RMASS(IDSCAT)
+C---PARAMETERS USED FOR THE WEIGHT GENERATION IN NEUTRAL CURRENT
+C PROCESSES. ASSUME D(SIGMA)/D(Q**2) GOES LIKE A1+A2/Q**2+A3/Q**4
+C AND D(SIGMA)/D(X) LIKE B1+B2/X
+ A1=0.5
+ A2=0.5
+ A3=1.
+ B1=0.1
+ B2=1.
+ ENDIF
+ IF (GENEV) THEN
+C---GENERATE EVENT (KINEMATICAL VARIABLES AND STRUCTURE FUNCTION
+C ALREADY FOUND)
+ PRAN=SIGMA*HWR()
+ IF (CHARGD) THEN
+C---CHARGED CURRENT PROCESS
+ IF (IQK.EQ.0) THEN
+C---FIND FLAVOUR OF THE STRUCK QUARK (IF NOT SELECTED BY THE USER)
+ PROB=ZERO
+ DO 10 I=1,6
+ DUP=MOD(I+1,2)
+ DWN=MOD(I ,2)
+ PROB=PROB+EFACT*
+ & ((DCHRG*(DLEFT*DUP+DRGHT*DWN*OMY2)
+ & +DNEUT*(DLEFT*DWN+DRGHT*DUP*OMY2))*DISF(I ,1)
+ & +(DCHRG*(DLEFT*DWN*OMY2+DRGHT*DUP)
+ & +DNEUT*(DLEFT*DUP*OMY2+DRGHT*DWN))*DISF(I+6,1))
+ IF (PROB.GE.PRAN) GOTO 20
+ 10 CONTINUE
+ I=6
+ 20 IQK=I
+ ENDIF
+ DUP=MOD(IQK+1,2)
+ DWN=MOD(IQK ,2)
+ IQKIN=IQK
+ IF ((LEP.EQ. 1.AND.MOD(IQK+IDHW(1),2).EQ.0)
+ & .OR.(LEP.EQ.-1.AND.MOD(IQK+IDHW(1),2).EQ.1)) IQKIN=IQK+6
+C---FIND FLAVOUR OF THE OUTGOING QUARK
+ PRAN=HWR()
+ PROB=ZERO
+ IF (DUP.EQ.ONE) THEN
+ DO 30 I=1,3
+ PROB=PROB+VCKM(IQK/2,I)
+ IF (PROB.GE.PRAN) GOTO 40
+ 30 CONTINUE
+ I=3
+ 40 IQKOUT=2*I-1
+ IF (IQKIN.GT.6) IQKOUT=IQKOUT+6
+ ELSE
+ DO 50 I=1,3
+ PROB=PROB+VCKM(I,(IQK+1)/2)
+ IF (PROB.GE.PRAN) GOTO 60
+ 50 CONTINUE
+ I=3
+ 60 IQKOUT=2*I
+ IF (IQKIN.GT.6) IQKOUT=IQKOUT+6
+ ENDIF
+ ELSE
+C---NEUTRAL CURRENT PROCESS
+ IF (IQK.NE.0) THEN
+ IQKIN=IQK
+ PROB=EFACT*(AF(1,IQK)*YPLUS*DISF(IQK,1)+
+ & LEP*AF(3,IQK)*YMNUS*DISF(IQK,1))
+ IF (PROB.LT.PRAN) IQKIN=IQK+6
+ ELSE
+C---FIND FLAVOUR OF THE STRUCK QUARK (IF NOT SELECTED BY THE USER)
+ PROB=ZERO
+ SIG=ONE
+ DO 70 I=1,12
+ IF (I.GT.6) SIG=-ONE
+ PROB=PROB+EFACT*(AF(1,I)*YPLUS*DISF(I,1)+
+ & LEP*SIG*AF(3,I)*YMNUS*DISF(I,1))
+ IF (PROB.GE.PRAN) GOTO 80
+ 70 CONTINUE
+ I=12
+ 80 IQKIN=I
+ ENDIF
+ IQKOUT=IQKIN
+ ENDIF
+ IDN(1)=IDHW(1)
+ IDN(2)=IQKIN
+ IDN(3)=IDSCAT
+ IDN(4)=IQKOUT
+ ICO(1)=1
+ ICO(2)=4
+ ICO(3)=3
+ ICO(4)=2
+ XX(1)=1.
+ XX(2)=XBJ
+C---CHECK PHASE SPACE WITH THE SELECTED FLAVOUR. IF OUTSIDE THE
+C EVENT IS KILLED.
+ PA=XBJ*(PHEP(4,IHAD)+ABS(PHEP(3,IHAD)))
+ EQ=HALF*(PA+RMASS(IDN(2))**2/PA)
+ PZQ=-(PA-EQ)
+ SHAT=(PHEP(4,1)+EQ)**2-(PHEP(3,1)+PZQ)**2
+ PCMEQ=HWUPCM(SQRT(SHAT),MLEP,RMASS(IDN(2)))
+ PCMLQ=HWUPCM(SQRT(SHAT),MLSCAT,RMASS(IDN(4)))
+ IF (PCMLQ.LT.ZERO) THEN
+ CALL HWWARN('HWHDIS',101,*999)
+ ELSEIF (PCMLQ.EQ.ZERO) THEN
+ COSTH=ZERO
+ ELSE
+ COSTH=(TWO*SQRT(PCMEQ**2+MLEP**2)*SQRT(PCMLQ**2+MLSCAT**2)
+ & -(Q2+MLEP**2+MLSCAT**2))/(TWO*PCMEQ*PCMLQ)
+ ENDIF
+ IF (ABS(COSTH).GT.ONE) CALL HWWARN('HWHDIS',102,*999)
+ IDCMF=15
+ CALL HWETWO
+ ELSE
+ EVWGT=ZERO
+ IF (CHARGD) THEN
+C---CHOOSE X,Y (CC PROCESS)
+ YMIN=MAX(YBMIN,Q2MIN/SMA)
+ YMAX=MIN(YBMAX,ONE)
+ IF (YMIN.GT.YMAX) GOTO 999
+ Y=HWRUNI(0,YMIN,YMAX)
+ XXMIN=Q2MIN/S/Y
+ XXMAX=MIN(Q2MAX/SMA/Y,ONE)
+ IF (XXMIN.GT.XXMAX) GOTO 999
+ XBJ=HWRUNI(0,XXMIN,XXMAX)
+ Q2=XBJ*Y*(S-MLEP**2-MHAD**2)
+ JACOBI=(YMAX-YMIN)*(XXMAX-XXMIN)*(S-MLEP**2-MHAD**2)*XBJ
+ ELSE
+C---CHOOSE X,Q**2 (NC PROCESS)
+ Q2SUP=MIN(Q2MAX,SMA*YBMAX)
+ IF (Q2MIN.GT.Q2SUP) GOTO 999
+ SAMP=(A1+A2+A3)*HWR()
+ IF (SAMP.LE.A1) THEN
+ Q2=HWRUNI(0,Q2MIN,Q2SUP)
+ ELSEIF (SAMP.LE.(A1+A2)) THEN
+ Q2=EXP(HWRUNI(0,LOG(Q2MIN),LOG(Q2SUP)))
+ ELSE
+ Q2=-ONE/HWRUNI(0,-ONE/Q2MIN,-ONE/Q2SUP)
+ ENDIF
+ Q2JAC=(A1+A2+A3)/
+ & (A1/(Q2SUP-Q2MIN)
+ & +A2/LOG(Q2SUP/Q2MIN)/Q2
+ & +A3*Q2MIN*Q2SUP/(Q2SUP-Q2MIN)/Q2**2)
+ XXMIN=Q2/SMA/YBMAX
+ XXMAX=ONE
+ IF (YBMIN.GT.ZERO) XXMAX=MIN(Q2/SMA/YBMIN,ONE)
+ IF (XXMIN.GT.XXMAX) GOTO 999
+ SAMP=(B1+B2)*HWR()
+ IF (SAMP.LE.B1) THEN
+ XBJ=HWRUNI(0,XXMIN,XXMAX)
+ ELSE
+ XBJ=EXP(HWRUNI(0,LOG(XXMIN),LOG(XXMAX)))
+ ENDIF
+ XXJAC=(B1+B2)/(B1/(XXMAX-XXMIN)+B2/LOG(XXMAX/XXMIN)/XBJ)
+ Y=Q2/(S-MLEP**2-MHAD**2)/XBJ
+ JACOBI=Q2JAC*XXJAC
+ ENDIF
+C---CHECK IF THE GENERATED POINT IS INSIDE PHASE SPACE. IF NOT
+C RETURN WITH WEIGHT EQUAL TO ZERO.
+ W=SQRT(MHAD**2+Q2*(ONE-XBJ)/XBJ)
+ IF (W.LT.WHMIN) RETURN
+ PCMEP=PCM
+ PCMLW=HWUPCM(SQRT(S),MLSCAT,W)
+ IF (PCMLW.LT.ZERO) THEN
+ EVWGT=ZERO
+ RETURN
+ ELSEIF (PCMLW.EQ.ZERO) THEN
+ COSPHI=ZERO
+ ELSE
+ COSPHI=
+ & (TWO*SQRT(PCMEP**2+MLEP**2)*SQRT(PCMLW**2+MLSCAT**2)
+ & -(Q2+MLEP**2+MLSCAT**2))/(TWO*PCMEP*PCMLW)
+ ENDIF
+ IF (ABS(COSPHI).GT.ONE) THEN
+ EVWGT=ZERO
+ RETURN
+ ENDIF
+C---SET SCALE EQUAL Q. EVALUATE STRUCTURE FUNCTIONS.
+ EMSCA=SQRT(Q2)
+ CALL HWSFUN(XBJ,EMSCA,IDHW(IHAD),NSTRU,DISF,2)
+C---SWITCH OFF ANY FLAVOURS THAT ARE BELOW THRESHOLD
+ DO 90 I=1,12
+ 90 IF (W.LT.2*RMASS(I)) DISF(I,1)=0
+C---EVALUATE DIFFERENTIAL CROSS SECTION
+ IF (CHARGD) THEN
+ PROP=RMASS(198)**2/(Q2+RMASS(198)**2)
+ EFACT=FACT*(HWUAEM(-Q2)*PROP)**2/XBJ
+ OMY2=(ONE-Y)**2
+ SIGMA=ZERO
+ DO 100 I=1,6
+ DUP=MOD(I+1,2)
+ DWN=MOD(I ,2)
+ IF (IQK.NE.0.AND.IQK.NE.I) GOTO 100
+ SIGMA=SIGMA+EFACT*
+ & ((DCHRG*(DLEFT*DUP+DRGHT*DWN*OMY2)
+ & +DNEUT*(DLEFT*DWN+DRGHT*DUP*OMY2))*DISF(I ,1)
+ & +(DCHRG*(DLEFT*DWN*OMY2+DRGHT*DUP)
+ & +DNEUT*(DLEFT*DUP*OMY2+DRGHT*DWN))*DISF(I+6,1))
+ 100 CONTINUE
+ ELSE
+ EFACT=FACT/XBJ*(HWUAEM(-Q2)/Q2)**2
+ YPLUS=ONE+(ONE-Y)**2
+ YMNUS=ONE-(ONE-Y)**2
+ DO 110 I=1,6
+ CALL HWUCFF(ILEPT,I,-Q2,AF(1,I))
+ AF(1,I+6)=AF(1,I)
+ AF(3,I+6)=AF(3,I)
+ 110 CONTINUE
+ SIGMA=ZERO
+ DO 200 I=1,6
+ IF (IQK.NE.0.AND.IQK.NE.I) GOTO 200
+ SIGMA=SIGMA+EFACT*(AF(1,I)*YPLUS*(DISF(I,1)+DISF(I+6,1))+
+ & LEP*AF(3,I)*YMNUS*(DISF(I,1)-DISF(I+6,1)))
+ 200 CONTINUE
+ ENDIF
+C---FIND WEIGHT: DIFFERENTIAL CROSS SECTION TIME THE JACOBIAN FACTOR
+ EVWGT=SIGMA*JACOBI
+ IF (EVWGT.LT.ZERO) EVWGT=ZERO
+ ENDIF
+ 999 END
+CDECK ID>, HWHDYP.
+*CMZ :- -18/05/99 12.41.07 by Mike Seymour
+*-- Author : Bryan Webber, Ian Knowles and Mike Seymour
+C-----------------------------------------------------------------------
+ SUBROUTINE HWHDYP
+C-----------------------------------------------------------------------
+C Drell-Yan Production of fermion pairs via photon, Z0 & (if ZPRIME)
+C Z' exchange. Lepton universality is assumed for photon and Z, and
+C for Z' if no lepton flavour is specified.
+C MEAN EVWGT = SIGMA IN NB
+C-----------------------------------------------------------------------
+ INCLUDE 'HERWIG61.INC'
+ DOUBLE PRECISION HWR,HWRUNI,HWUAEM,EPS,C1,C2,C3,EMSQZ,EMGMZ,
+ & EMSQZP,EMGMZP,CQF(7,6,16),QPOW,RPOW,A01,A1,A02,A2,A03,A3,CRAN,
+ & EMJ1,EMJ2,EMJ3,EMJAC,FACT,QSQ,HCS,FACTR,RCS,EXTRA,PMAX,PTHETA
+ INTEGER IMODE,JQMN,JQMX,JQ,JLMN,JLMX,JL,IQ,I,IADD(2,2),ID1,ID2,
+ & ID3,ID4,JF
+ EXTERNAL HWR,HWRUNI,HWUAEM
+ SAVE HCS,JQMN,JQMX,JLMN,JLMX,C1,C2,C3,QPOW,RPOW,EMSQZ,EMGMZ,
+ & A1,A01,A2,A02,A3,A03,EMSQZP,EMGMZP,FACT,CQF
+ PARAMETER (EPS=1.D-9)
+ DATA IADD/0,6,6,0/
+ IF (GENEV) THEN
+ RCS=HCS*HWR()
+ ELSE
+ IF (FSTWGT) THEN
+C Set limits for which particles to include
+ JLMN=1
+ JLMX=0
+ JQMN=1
+ JQMX=0
+ IMODE=MOD(IPROC,100)
+ IF (IMODE.EQ.0) THEN
+ JQMN=1
+ JQMX=6
+ ELSEIF (IMODE.LE.10) THEN
+ JQMN=IMODE
+ JQMX=IMODE
+ ELSEIF (IMODE.EQ.50) THEN
+ JLMN=11
+ JLMX=16
+ ELSEIF (IMODE.GE.50.AND.IMODE.LE.60) THEN
+ JLMN=IMODE-40
+ JLMX=IMODE-40
+ ELSEIF (IMODE.EQ.99) THEN
+ JQMN=1
+ JQMX=6
+ JLMN=11
+ JLMX=16
+ ELSE
+ CALL HWWARN('HWHDYP',500,*999)
+ ENDIF
+C Set up parameters for importance sampling:
+C sum of power law and two Breit-Wigners (relative weights C1,C2,C3)
+ C1=ONE
+ C2=ONE
+ C3=ZERO
+ IF (ZPRIME) C3=ONE
+ IF (EMPOW.EQ.ONE) CALL HWWARN('HWHDYP',501,*999)
+ IF (C2.EQ.ZERO) CALL HWWARN('HWHDYP',502,*999)
+ IF (C3.EQ.ZERO.AND.ZPRIME) CALL HWWARN('HWHDYP',503,*999)
+ QPOW=-EMPOW+1
+ RPOW=1/QPOW
+ EMSQZ=RMASS(200)**2
+ EMGMZ=RMASS(200)*GAMZ
+ A01=EMMIN**QPOW
+ A1=(EMMAX**QPOW-A01)/C1
+ A02=ATAN((EMMIN**2-EMSQZ)/EMGMZ)
+ A2=(ATAN((EMMAX**2-EMSQZ)/EMGMZ)-A02)/C2
+ IF (C3.GT.ZERO) THEN
+ EMSQZP=RMASS(202)**2
+ EMGMZP=RMASS(202)*GAMZP
+ A03=ATAN((EMMIN**2-EMSQZP)/EMGMZP)
+ A3=(ATAN((EMMAX**2-EMSQZP)/EMGMZP)-A03)/C3
+ ENDIF
+ ENDIF
+ EVWGT=0.
+C Select a mass for the produced pair
+ CRAN=(C1+C2+C3)*HWR()
+ IF (CRAN.LT.C1) THEN
+C Use power law
+ EMSCA=(A01+A1*CRAN)**RPOW
+ QSQ=EMSCA**2
+ ELSEIF (CRAN.LT.C1+C2) THEN
+C Use Z Breit-Wigner
+ CRAN=CRAN-C1
+ QSQ=EMSQZ+EMGMZ*TAN(A02+A2*CRAN)
+ EMSCA=SQRT(QSQ)
+ ELSE
+C Use Z' Breit-Wigner
+ CRAN=CRAN-C1-C2
+ QSQ=EMSQZP+EMGMZP*TAN(A03+A3*CRAN)
+ EMSCA=SQRT(QSQ)
+ ENDIF
+ EMJ1=EMSCA**EMPOW/(1-EMPOW)*A1
+ EMJ2=((QSQ-EMSQZ)**2+EMGMZ**2)/(2*EMSCA*EMGMZ)*A2
+ IF (C3.GT.ZERO) THEN
+ EMJ3=((QSQ-EMSQZP)**2+EMGMZP**2)/(2*EMSCA*EMGMZP)*A3
+ EMJAC=(C1+C2+C3)/(1/EMJ1+1/EMJ2+1/EMJ3)
+ ELSE
+ EMJAC=(C1+C2)/(1/EMJ1+1/EMJ2)
+ ENDIF
+C Select initial momentum fractions
+ XXMIN=QSQ/PHEP(5,3)**2
+ XLMIN=LOG(XXMIN)
+ CALL HWSGEN(.TRUE.)
+ FACT=-GEV2NB*HWUAEM(QSQ)**2*PIFAC*8*EMJAC*XLMIN
+ $ /(3*NCOLO*EMSCA**3)
+C Store cross-section coefficients
+ DO 50 IQ=1,6
+ DO 30 JQ=JQMN,JQMX
+ IF (EMSCA.GT.2.*RMASS(JQ)) THEN
+ CALL HWUCFF(IQ,JQ,QSQ,CQF(1,IQ,JQ))
+ ELSE
+ CALL HWVZRO(7,CQF(1,IQ,JQ))
+ ENDIF
+ 30 CONTINUE
+ DO 40 JL=JLMN,JLMX
+ IF (EMSCA.GT.2.*RMASS(JL)) THEN
+ CALL HWUCFF(IQ,JL,QSQ,CQF(1,IQ,JL))
+ ELSE
+ CALL HWVZRO(7,CQF(1,IQ,JL))
+ ENDIF
+ 40 CONTINUE
+ 50 CONTINUE
+ ENDIF
+C
+ HCS=0.
+ DO 90 I=1,2
+C I=1 quark first, I=2 anti-quark first
+ DO 80 IQ=1,6
+ ID1=IQ+IADD(1,I)
+ ID2=IQ+IADD(2,I)
+ IF (DISF(ID1,1).LT.EPS.OR.DISF(ID2,2).LT.EPS) GOTO 80
+ FACTR=FACT*DISF(ID1,1)*DISF(ID2,2)
+C Quark final states
+ DO 60 JQ=JQMN,JQMX
+ ID3=JQ
+ ID4=JQ+6
+ IF (IQ.EQ.JQ) THEN
+ HCS=HCS+FACTR*(CQF(1,IQ,JQ)*FLOAT(NCOLO)+3*HALF*QFCH(IQ)**4)
+ IF (GENEV.AND.HCS.GT.RCS) CALL HWHQCP(ID3,ID4,2143,50,*99)
+ ELSE
+ HCS=HCS+FACTR*CQF(1,IQ,JQ)*FLOAT(NCOLO)
+ IF (GENEV.AND.HCS.GT.RCS) CALL HWHQCP(ID3,ID4,2143,50,*99)
+ ENDIF
+ 60 CONTINUE
+C Lepton final states
+ DO 70 JL=JLMN,JLMX
+ ID3=110+JL
+ ID4=ID3+6
+ HCS=HCS+FACTR*CQF(1,IQ,JL)
+ IF (GENEV.AND.HCS.GT.RCS) CALL HWHQCP(ID3,ID4,2134,50,*99)
+ 70 CONTINUE
+ 80 CONTINUE
+ 90 CONTINUE
+ EVWGT=HCS
+ RETURN
+C Generate event
+ 99 IDN(1)=ID1
+ IDN(2)=ID2
+ IDCMF=200
+ IF (ID3.LE.6) THEN
+ JF=JQ
+ ELSE
+ JF=JL
+ ENDIF
+C Select polar angle from distribution:
+C CQF(1,IQ,JF)*(ONE+COSTH**2)+CQF(3,IQ,JF)*COSTH+EXTRA*(ONE+COSTH)
+ IF (ID1.EQ.ID3.OR.ID2.EQ.ID3) THEN
+ EXTRA=TWO*QFCH(ID3)**4/NCOLO
+ ELSE
+ EXTRA=0
+ ENDIF
+ PMAX=2.*(CQF(1,IQ,JF)+EXTRA)+ABS(CQF(3,IQ,JF))
+ 100 COSTH=HWRUNI(0,-ONE,ONE)
+ PTHETA=CQF(1,IQ,JF)*(ONE+COSTH**2)+CQF(3,IQ,JF)*COSTH
+ & +EXTRA*(ONE+COSTH)
+ IF (PTHETA.LT.PMAX*HWR()) GOTO 100
+ IF (ID1.GT.ID2) COSTH=-COSTH
+ IDCMF=200
+ CALL HWETWO
+ 999 END
+CDECK ID>, HWHEGG.
+*CMZ :- -19/03/92 10.13.56 by Mike Seymour
+*-- Author : Mike Seymour
+C-----------------------------------------------------------------------
+ SUBROUTINE HWHEGG
+C----------------------------------------------------------------------
+C HARD PROCESS: EE --> EEGAMGAM --> EEFFBAR/WW
+C MEAN EVENT WEIGHT = CROSS-SECTION IN NB
+C AFTER CUTS ON PT AND MASS OF CENTRE-OF-MASS SYSTEM
+C AND COS(THETA) IN CENTRE-OF-MASS SYSTEM
+C AND TIMES BRANCHING FRACTION IF WW
+C-----------------------------------------------------------------------
+ INCLUDE 'HERWIG61.INC'
+ DOUBLE PRECISION HWR,HWULDO,EMSQ,BETA,S,T,U,TMIN,TMAX,TRAT,
+ & DSDT,PROB,X,Z(2),ZMIN,ZMAX,PCMIN,PCMAX,PCFAC,PLOGMI,PLOGMA,PTCMF,
+ & Q,PC,BLOG,EMCMIN,EMCMAX,EMLMIN,EMLMAX,WGT(6),RWGT,CV,CA,BR,QT(2),
+ & QX(2),QY(2),PX,PY,ROOTS,DOT,A,B,C,SHAT,PCF(2),PCM(2),PCMAC,ZZ(2),
+ & COLFAC
+ INTEGER I,IGAM,ID,IDL,ID1,ID2,IHEP,JHEP,NADD,NTRY,NQ,JGAM
+ LOGICAL HWRLOG
+ EXTERNAL HWR,HWULDO,HWRLOG
+ SAVE S,BETA,X,ID,NQ,WGT,EMLMIN,EMLMAX,PCFAC,PLOGMA,PLOGMI,SHAT,
+ & PCF,PCM,Z,PCMAC,NADD
+ IF (IERROR.NE.0) RETURN
+C---INITIALIZE LOCAL COPIES OF EMMIN,EMMAX
+ IF (FSTWGT) THEN
+ EMLMIN=EMMIN
+ EMLMAX=EMMAX
+ ENDIF
+ IF (.NOT.GENEV) THEN
+C---CHOOSE Z1,Z2 AND CALCULATE SUB-PROCESS CROSS-SECTION
+ EVWGT=0
+C-----FIND FINAL STATE PARTICLES
+ IHPRO=MOD(IPROC,100)
+ IF (IHPRO.EQ.0) THEN
+ ID=1
+ NQ=6
+ COLFAC=FLOAT(NCOLO)
+ NADD=6
+ ELSEIF (IHPRO.LE.6) THEN
+ ID=IHPRO
+ NQ=1
+ COLFAC=FLOAT(NCOLO)
+ NADD=6
+ Q=QFCH(ID)
+ ELSEIF (IHPRO.LE.9) THEN
+ ID=119+2*(IHPRO-6)
+ NQ=1
+ COLFAC=1.
+ NADD=6
+ Q=QFCH(ID-110)
+ ELSEIF (IHPRO.LE.10) THEN
+ ID=198
+ NQ=1
+ NADD=1
+ ELSE
+ CALL HWWARN('HWHEGG',200,*999)
+ ENDIF
+C-----SPLIT ELECTRONS TO PHOTONS
+ NHEP=3
+ GAMWT=1
+ S=2*HWULDO(PHEP(1,1),PHEP(1,2))
+ ROOTS=SQRT(S)
+ EMCMIN=MAX(EMLMIN,MAX(2*RMASS(ID),PTMIN))
+ EMCMAX=MIN(EMLMAX,ROOTS)
+ IF (EMCMIN.GT.EMCMAX) RETURN
+ ZMIN=EMCMIN**2/S
+ ZMAX=1-PHEP(5,1)/PHEP(4,1)
+ IF (ZMIN.GT.ZMAX) RETURN
+ CALL HWEGAM(1,ZMIN,ZMAX,.TRUE.)
+ Z(1)=PHEP(4,NHEP-1)/PHEP(4,1)
+ ZMIN=EMCMIN**2/(Z(1)*S)
+ ZMAX=MIN(EMCMAX**2/(Z(1)*S), ONE-PHEP(5,2)/PHEP(4,2))
+ IF (ZMIN.GT.ZMAX) RETURN
+ CALL HWEGAM(2,ZMIN,ZMAX,.TRUE.)
+ Z(2)=PHEP(4,NHEP-1)/PHEP(4,2)
+ EMSCA=PHEP(5,3)
+ SHAT=EMSCA**2
+C-----REMOVE LOG TERMS FROM WEIGHT, CALCULATE NEW ONES FROM PT LIMITS
+ GAMWT=GAMWT/(0.5*LOG((1-Z(1))*S/(Z(1)*PHEP(5,1)**2))
+ & *0.5*LOG((1-Z(2))*Z(1)*S/(Z(2)*PHEP(5,2)**2)))
+ PCF(1)=Z(1)*PHEP(5,1)
+ PCF(2)=Z(2)*PHEP(5,2)
+ PCFAC=SQRT(PCF(1)*PCF(2))
+ PCM(1)=(1-Z(1))*PHEP(4,1)
+ PCM(2)=(1-Z(2))*PHEP(4,2)
+ PCMAC=SQRT(PCM(1)*PCM(2))
+ PCMIN=MAX(PTMIN,MAX(PCF(1),PCF(2)))
+ PCMAX=MIN( MIN(PTMAX,PHEP(5,3)) , MIN(PCM(1),PCM(2)) )
+ IF (PCMIN.GT.PCMAX) RETURN
+ PLOGMI=(LOG(PCMIN/PCFAC))**2
+ PLOGMA=(LOG(PCMAX/PCFAC))**2
+ GAMWT=GAMWT*(PLOGMA-PLOGMI)
+C-----CALCULATE CROSS-SECTION
+ DO 10 IDL=1,NQ
+ WGT(IDL)=EVWGT
+ IF (IHPRO.EQ.0) THEN
+ ID=IDL
+ Q=QFCH(ID)
+ ENDIF
+ EMSQ=RMASS(ID)**2
+ X=4*EMSQ/SHAT
+ IF (X.GT.ONE) GOTO 10
+ BETA=SQRT(1-X)
+ BLOG=LOG((1+BETA*CTMAX)/(1-BETA*CTMAX))/BETA
+ IF (IHPRO.LE.9) THEN
+ EVWGT=EVWGT+GEV2NB*4*PIFAC*COLFAC*Q**4*ALPHEM**2*BETA
+ & /SHAT * GAMWT * ( (1+X-0.5*X**2)*BLOG
+ & - CTMAX*(1+X**2/(CTMAX**2*(X-1)+1)) )
+ WGT(IDL)=EVWGT
+ ELSE
+ CALL HWDBOZ(198,ID1,ID2,CV,CA,BR,1)
+ CALL HWDBOZ(199,ID1,ID2,CV,CA,BR,1)
+ EVWGT=EVWGT + GEV2NB*6*PIFAC*ALPHEM**2*BETA/SHAT*BR
+ & * GAMWT * (-( X-0.5*X**2)*BLOG
+ & + CTMAX*(1+(X**2+16/3.)/(CTMAX**2*(X-1)+1)) )
+ ENDIF
+ 10 CONTINUE
+C-----GAMWT MUST BE RESET TO ONE, SINCE IT IS REAPPLIED LATER!
+ GAMWT=ONE
+ ELSE
+C---GENERATE EVENT
+C-----CHOOSE PT OF THE CMF
+ PTCMF=PCFAC*EXP(SQRT(HWR()*(PLOGMA-PLOGMI)+PLOGMI))
+C-----CHOOSE WHICH PHOTON USUALLY HAS SMALLER PT
+ NTRY=0
+ 20 IGAM=1
+ IF (LOG(PCM(1)/PCF(1)).LT.HWR()*2*LOG(PCMAC/PCFAC)) IGAM=2
+ JGAM=3-IGAM
+C-----CHOOSE ITS PT
+ 30 NTRY=NTRY+1
+ IF (NTRY.GT.NBTRY) CALL HWWARN('HWHEGG',100,*999)
+ QT(IGAM)=(PCM(IGAM)/PCF(IGAM))**HWR()
+ PROB=(QT(IGAM)**2/(QT(IGAM)**2+1))**2
+ QT(IGAM)=QT(IGAM)*PCF(IGAM)
+ IF (HWRLOG(1-PROB)) GOTO 30
+C-----CHOOSE ITS DIRECTION
+ CALL HWRAZM(QT(IGAM),QX(IGAM),QY(IGAM))
+C-----CALCULATE THE OTHER PHOTON'S PT
+ QX(JGAM)=PTCMF-QX(IGAM)
+ QY(JGAM)= -QY(IGAM)
+ QT(JGAM)=SQRT(QX(JGAM)**2+QY(JGAM)**2)
+ IF (QT(JGAM).LT.PCF(JGAM).OR.QT(JGAM).GT.PCM(JGAM)) GOTO 20
+C-----APPLY A RANDOM ROTATION AROUND THE BEAM AXIS
+ CALL HWRAZM(ONE,PX,PY)
+ IF (PX.EQ.ZERO) PX=1D-20
+ QX(1)=(QX(1)*PX -QY(1)*PY)
+ QY(1)=(QY(1) +QX(1)*PY)/PX
+ QX(2)=(QX(2)*PX -QY(2)*PY)
+ QY(2)=(QY(2) +QX(2)*PY)/PX
+C-----RECONSTRUCT MOMENTA
+ IF (QT(IGAM).GT.QT(JGAM)) THEN
+ IGAM=3-IGAM
+ JGAM=3-JGAM
+ ENDIF
+ DOT=-Z(JGAM)*S+SHAT+2*(QX(1)*QX(2)+QY(1)*QY(2))
+C-------SOLVE QUADRATIC IN Z(IGAM) TO FIND ELECTRON ENERGIES
+ A=S*(S*Z(JGAM)+QT(JGAM)**2)
+ B=S*DOT*(1+Z(JGAM))
+ C=DOT**2+S*QT(IGAM)**2*(1-Z(JGAM))**2-4*QT(IGAM)**2*QT(JGAM)**2
+ IF (B**2.LT.4*A*C) GOTO 20
+ ZZ(IGAM)=(-B+SQRT(B**2-4*A*C))/(2*A)
+ IF (ZZ(IGAM).LT.ZERO .OR. ZZ(IGAM).GT.ONE-Z(IGAM)) GOTO 20
+ ZZ(JGAM)=1-Z(JGAM)
+C-------REJECT AGAINST PHOTON DISTRIBUTION FUNCTION
+ PROB=((1+ZZ(IGAM)**2)/(1-ZZ(IGAM)))/((1+(1-Z(IGAM))**2)/Z(IGAM))
+ & *((1+ZZ(JGAM)**2)/(1-ZZ(JGAM)))/((1+(1-Z(JGAM))**2)/Z(JGAM))
+ IF (HWRLOG(1-PROB)) GOTO 20
+C-------RECONSTRUCT ALL OTHER VARIABLES
+ DO 40 I=1,2
+ IGAM=2*I+3
+ PHEP(1,IGAM)=QX(I)
+ PHEP(2,IGAM)=QY(I)
+ PHEP(4,IGAM)=ZZ(I)*PHEP(4,I)
+ PHEP(5,IGAM)=RMASS(IDHW(IGAM))
+C---------IF MOMENTUM CANNOT BE CONSERVED TRY AGAIN
+ IF (PHEP(4,IGAM)**2-PHEP(5,IGAM)**2-QT(I)**2 .LT. 0) GOTO 20
+ PHEP(3,IGAM)=SIGN(SQRT(PHEP(4,IGAM)**2-PHEP(5,IGAM)**2-
+ & QT(I)**2),PHEP(3,IGAM))
+ CALL HWVDIF(4,PHEP(1,I),PHEP(1,IGAM),PHEP(1,IGAM-1))
+ CALL HWUMAS(PHEP(1,IGAM-1))
+ 40 CONTINUE
+C-----TIDY UP EVENT RECORD
+ NHEP=NHEP+1
+ IDHW(NHEP)=IDHW(3)
+ IDHEP(NHEP)=IDHEP(3)
+ ISTHEP(NHEP)=110
+ CALL HWVSUM(4,PHEP(1,4),PHEP(1,6),PHEP(1,NHEP))
+ CALL HWVSUM(4,PHEP(1,1),PHEP(1,2),PHEP(1,3))
+ CALL HWUMAS(PHEP(1,NHEP))
+ CALL HWUMAS(PHEP(1,3))
+ JMOHEP(1,NHEP)=4
+ JMOHEP(2,NHEP)=6
+ JMOHEP(1,3)=0
+ JMOHEP(2,3)=0
+C-----CHOOSE FINAL STATE QUARK
+ IF (IHPRO.EQ.0) THEN
+ RWGT=HWR()*EVWGT
+ ID=1
+ DO 50 IDL=1,NQ
+ IF (RWGT.GT.WGT(IDL)) ID=IDL+1
+ 50 CONTINUE
+ EMSQ=RMASS(ID)**2
+ X=4*EMSQ/SHAT
+ BETA=SQRT(1-X)
+ ENDIF
+C-----CHOOSE T (WHERE T = MANDELSTAM_T - EMSQ)
+ TMIN=-SHAT/2
+ TMAX=-SHAT/2*(1-BETA*CTMAX)
+ TRAT=TMAX/TMIN
+ NTRY=0
+ IF (IHPRO.LE.9) THEN
+C-------FOR FFBAR, CHOOSE T ACCORDING TO -SHAT/T
+ 60 NTRY=NTRY+1
+ IF (NTRY.GT.NBTRY) CALL HWWARN('HWHEGG',101,*999)
+ T=TRAT**HWR()*TMIN
+ U=-T-SHAT
+C-------REWEIGHT TO CORRECT DISTRIBUTION
+ DSDT=(T*U-2*EMSQ*(T+2*EMSQ))/T**2
+ & +( 2*EMSQ*(SHAT-4*EMSQ))/(T*U)
+ & +(T*U-2*EMSQ*(U+2*EMSQ))/U**2
+ PROB=-DSDT*T/SHAT / (1 + 2*X - 2*X**2)
+ IF (HWRLOG(1-PROB)) GOTO 60
+ ELSE
+C-------FOR WW, CHOOSE T ACCORDING TO (SHAT/T)**2
+ 70 NTRY=NTRY+1
+ IF (NTRY.GT.NBTRY) CALL HWWARN('HWHEGG',102,*999)
+ T=TMAX/(1-(1-TRAT)*HWR())
+ U=-T-SHAT
+C-------REWEIGHT TO CORRECT DISTRIBUTION
+ DSDT=( 3*(T*U)**2 - SHAT*T*U*(4*SHAT+6*EMSQ)
+ & + SHAT**2*(2*SHAT**2+6*EMSQ**2) ) / (T*U)**2
+ PROB=DSDT*(T/SHAT)**2 / (4.75 - 1.5*X + 1.5*X**2)
+ IF (HWRLOG(1-PROB)) GOTO 70
+ ENDIF
+C-----SYMMETRIZE IN T,U
+ IF (HWRLOG(HALF)) T=U
+C-----FILL EVENT RECORD
+ COSTH=(1+2*T/SHAT)/BETA
+ PC=0.5*BETA*PHEP(5,NHEP)
+ PHEP(5,NHEP+1)=RMASS(ID)
+ PHEP(5,NHEP+2)=RMASS(ID)
+ CALL HWDTWO(PHEP(1,NHEP),PHEP(1,NHEP+1),PHEP(1,NHEP+2),
+ & PC,COSTH,.TRUE.)
+ DO 80 I=1,2
+ IHEP=NHEP+I
+ JHEP=NHEP+3-I
+ ISTHEP(IHEP)=190
+ IF (IHPRO.LE.6) ISTHEP(IHEP)=112+I
+ IDHW(IHEP)=ID+NADD*(I-1)
+ IDHEP(IHEP)=IDPDG(IDHW(IHEP))
+ JDAHEP(I,NHEP)=IHEP
+ JMOHEP(1,IHEP)=NHEP
+ JMOHEP(2,IHEP)=JHEP
+ JDAHEP(2,IHEP)=JHEP
+ IF (IHPRO.EQ.10) THEN
+ RHOHEP(1,IHEP)=0.3333
+ RHOHEP(2,IHEP)=0.3333
+ RHOHEP(3,IHEP)=0.3333
+ ENDIF
+ 80 CONTINUE
+ NHEP=NHEP+2
+ ENDIF
+ 999 END
+CDECK ID>, HWHEGW.
+*CMZ :- -26/04/91 10.18.56 by Bryan Webber
+*-- Author : Mike Seymour
+C-----------------------------------------------------------------------
+ SUBROUTINE HWHEGW
+C----------------------------------------------------------------------
+C W + GAMMA --> FF'BAR : MEAN EVWGT = CROSS SECTION IN NANOBARN
+C BASED ON BOSON GLUON FUSION OF ABBIENDI AND STANCO
+C-----------------------------------------------------------------------
+ INCLUDE 'HERWIG61.INC'
+ DOUBLE PRECISION HWR,GMASS,EV(3),RV,LEP,Y,Q2,SHAT,Z,PHI,AJACOB,
+ & DSIGMA,ME,MP,ML,MREMIF(18),MFIN1(18),MFIN2(18),RS,SMA,W2,RSHAT
+ INTEGER LEPFIN,ID1,ID2,I,IQK,IFLAVU,IFLAVD,IMIN,IMAX,IFL,IPROO
+ LOGICAL CHARGD,INCLUD(18),INSIDE(18)
+ EXTERNAL HWR
+ SAVE LEPFIN,ID1,ID2
+ COMMON /HWAREA/ LEP,Y,Q2,SHAT,Z,PHI,AJACOB,DSIGMA,ME,MP,ML,MREMIF,
+ & MFIN1,MFIN2,RS,SMA,W2,RSHAT,IQK,IFLAVU,IFLAVD,IMIN,IMAX,IFL,
+ & IPROO,CHARGD,INCLUD,INSIDE
+ IQK=MOD(IPROC,10)
+ CHARGD=.TRUE.
+ IF(GENEV) THEN
+C
+ IDHW(4)=IDHW(1)
+ IDHW(5)=59
+ IDHW(6)=15
+ IDHW(7)=LEPFIN
+ IDHW(8)=ID1
+ IDHW(9)=ID2
+ DO 1 I=4,9
+ 1 IDHEP(I)=IDPDG(IDHW(I))
+C
+ IFLAVD=ID1
+ IFLAVU=ID2-6
+C
+ ISTHEP(4)=111
+ ISTHEP(5)=112
+ ISTHEP(6)=110
+ ISTHEP(7)=113
+ ISTHEP(8)=114
+ ISTHEP(9)=114
+C
+ JMOHEP(1,4)=6
+ JMOHEP(2,4)=7
+ JMOHEP(1,5)=6
+ JMOHEP(2,5)=5
+ JMOHEP(1,6)=4
+ JMOHEP(2,6)=5
+ JMOHEP(1,7)=6
+ JMOHEP(2,7)=4
+ JMOHEP(1,8)=6
+ JMOHEP(2,8)=9
+ JMOHEP(1,9)=6
+ JMOHEP(2,9)=8
+ JDAHEP(1,4)=0
+ JDAHEP(2,4)=7
+ JDAHEP(1,5)=0
+ JDAHEP(2,5)=5
+ JDAHEP(1,6)=7
+ JDAHEP(2,6)=9
+ JDAHEP(1,7)=0
+ JDAHEP(2,7)=4
+ JDAHEP(1,8)=0
+ JDAHEP(2,8)=9
+ JDAHEP(1,9)=0
+ JDAHEP(2,9)=8
+C---COMPUTATION OF MOMENTA IN LABORATORY FRAME OF REFERENCE
+C---Persuade HWHBKI that the gluon is actually a photon...
+ GMASS=RMASS(13)
+ RMASS(13)=0
+ CALL HWHBKI
+ RMASS(13)=GMASS
+C---put the other outgoing lepton in as well
+ IDHW(10)=IDHW(2)
+ IDHEP(10)=IDPDG(IDHW(10))
+ ISTHEP(10)=1
+ JMOHEP(1,10)=2
+ JMOHEP(2,10)=0
+ JDAHEP(1,10)=0
+ JDAHEP(2,10)=0
+ JDAHEP(1,2)=5
+ JDAHEP(2,2)=10
+ CALL HWVDIF(4,PHEP(1,2),PHEP(1,5),PHEP(1,10))
+ CALL HWUMAS(PHEP(1,10))
+ NHEP=10
+C
+C---if antilepton was first, do charge conjugation
+ IF (LEP.EQ.ONE) THEN
+ DO 27 I=7,9
+ IF (IDHEP(I).NE.0 .AND. ABS(IDHEP(I)).LT.20) THEN
+ IDHW(I)=IDHW(I) + 6*SIGN(1,IDHEP(I))
+ IDHEP(I)=-IDHEP(I)
+ ENDIF
+ 27 CONTINUE
+ ENDIF
+C
+C---half the time, do charge conjugation and parity flip
+ IF (HWR().GT.HALF) THEN
+ DO 2 I=4,10
+ IF (IDHEP(I).NE.0 .AND. ABS(IDHEP(I)).LT.20) THEN
+ IDHW(I)=IDHW(I) + 6*SIGN(1,IDHEP(I))
+ IDHEP(I)=-IDHEP(I)
+ ENDIF
+ PHEP(1,I)=-PHEP(1,I)
+ PHEP(2,I)=-PHEP(2,I)
+ PHEP(3,I)=-PHEP(3,I)
+ 2 CONTINUE
+ JMOHEP(1,10)=3-JMOHEP(1,10)
+ ENDIF
+C
+ ELSE
+C
+ EVWGT=ZERO
+C---LEP = 1 IF TRACK 1 IS A LEPTON, -1 FOR ANTILEPTON
+ LEP=0.
+ IF (IDHW(1).GE.121.AND.IDHW(1).LE.126) THEN
+ LEP=1.
+ ELSEIF (IDHW(1).GE.127.AND.IDHW(1).LE.132) THEN
+ LEP=-1.
+ ENDIF
+ IF (LEP.EQ.ZERO) CALL HWWARN('HWHEGW',500,*999)
+C---program only works if beam and target are charge conjugates
+ IF (INT(LEP)*(IDHW(2)-IDHW(1)).NE.6)
+ & CALL HWWARN('HWHEGW',501,*999)
+C---program only works for equal energy beams colliding
+ IF (PHEP(3,3).NE.ZERO) CALL HWWARN('HWHEGW',503,*999)
+C
+C---FINAL STATE IS ALWAYS SET UP AS IF PARTICLE IS BEFORE ANTI-PARTICLE
+C AND THEN INVERTED IF NECESSARY
+ LEPFIN = MIN(IDHW(1),IDHW(2))+1
+ IF (IQK.LE.2) THEN
+ IFLAVU=2
+ IFLAVD=1
+ ID1 = 1
+ ID2 = 8
+ ELSEIF (IQK.LE.4) THEN
+ IFLAVU=4
+ IFLAVD=3
+ ID1 = 3
+ ID2 =10
+ ELSEIF (IQK.LE.6) THEN
+ IFLAVU=6
+ IFLAVD=5
+ ID1 = 5
+ ID2 =12
+ ELSEIF (IQK.EQ.7) THEN
+ IFLAVU=122
+ IFLAVD=121
+ ID1 = 121
+ ID2 = 128
+C---INTERFERENCE TERMS IN EE -> EE NUE NUEB NEGLECTED: SIGMA UNRELIABLE
+ IF (FSTWGT) CALL HWWARN('HWHEGW',1,*999)
+ ELSEIF (IQK.EQ.8) THEN
+ IFLAVU=124
+ IFLAVD=123
+ ID1 = 123
+ ID2 = 130
+ ELSEIF (IQK.EQ.9) THEN
+ IFLAVU=126
+ IFLAVD=125
+ ID1 = 125
+ ID2 = 132
+ ELSE
+ CALL HWWARN('HWHEGW',504,*999)
+ ENDIF
+ IF (IQK.GT.0) THEN
+ IF (IQK.LE.6) IQK=0
+ CALL HWHBRN(*999)
+ CALL HWHEGX
+ EVWGT = 2 * DSIGMA * AJACOB
+ IF (EVWGT.LT.ZERO) EVWGT=ZERO
+ ELSE
+C---SUM OVER QUARK FLAVOURS
+ CALL HWHBRN(*999)
+ DO 3 I=1,3
+ IF (SHAT.GT.(RMASS(IFLAVD)+RMASS(IFLAVU))**2) THEN
+ CALL HWHEGX
+ EV(I) = 2 * DSIGMA * AJACOB
+ IF (EV(I).LT.ZERO) EV(I)=ZERO
+ ELSE
+ EV(I)=ZERO
+ ENDIF
+ EVWGT=EVWGT+EV(I)
+ EV(I)=EVWGT
+ IFLAVU=IFLAVU+2
+ IFLAVD=IFLAVD+2
+ 3 CONTINUE
+C---CHOOSE QUARK FLAVOUR
+ RV=EV(3)*HWR()
+ IF (RV.LT.EV(1)) THEN
+ ID1 = 1
+ ID2 = 8
+ ELSEIF (RV.LT.EV(2)) THEN
+ ID1 = 3
+ ID2 =10
+ ELSE
+ ID1 = 5
+ ID2 =12
+ ENDIF
+ ENDIF
+ ENDIF
+ 999 END
+CDECK ID>, HWHEGX.
+*CMZ :- -17/07/92 16.42.56 by Mike Seymour
+*-- Author : Mike Seymour
+C-----------------------------------------------------------------------
+ SUBROUTINE HWHEGX
+C-----------------------------------------------------------------------
+C COMPUTES DIFFERENTIAL CROSS SECTION DSIGMA IN (Y,Q2,ETA,Z,PHI)
+C-----------------------------------------------------------------------
+ INCLUDE 'HERWIG61.INC'
+ DOUBLE PRECISION TMAX,TMIN,A1,A2,B1,B2,I0,I1,I2,I3,I4,I5,MUSQ,
+ & MDSQ,ETA,Q1,COSTHE,S,G,T,U,C1,C2,D1,D2,F1,F2,COSBET,WPROP,D(4,4),
+ & C(4,4),QU,QD,QE,QW,PHOTON,EMWSQ,EMSSQ,CFAC,LEP,Y,Q2,SHAT,Z,PHI,
+ & AJACOB,DSIGMA,ME,MP,ML,MREMIF(18),MFIN1(18),MFIN2(18),RS,SMA,W2,
+ & RSHAT
+ INTEGER IQK,IFLAVU,IFLAVD,IMIN,IMAX,IFL,IPROO,I,J
+ LOGICAL CHARGD,INCLUD(18),INSIDE(18)
+ COMMON /HWAREA/ LEP,Y,Q2,SHAT,Z,PHI,AJACOB,DSIGMA,ME,MP,ML,MREMIF,
+ & MFIN1,MFIN2,RS,SMA,W2,RSHAT,IQK,IFLAVU,IFLAVD,IMIN,IMAX,IFL,
+ & IPROO,CHARGD,INCLUD,INSIDE
+C---INPUT VARIABLES
+ IF (IERROR.NE.0) RETURN
+ DSIGMA=0
+ IF (IFLAVU.LE.12) THEN
+ QU=QFCH(MOD(IFLAVU-1,6)+1)
+ QD=QFCH(MOD(IFLAVD-1,6)+1)
+ CFAC=CAFAC
+ ELSE
+ QU=QFCH(MOD(IFLAVU-1,6)+11)
+ QD=QFCH(MOD(IFLAVD-1,6)+11)
+ CFAC=1
+ ENDIF
+ QE=QFCH(11)
+ QW=+1
+ EMWSQ=RMASS(198)**2
+ EMSCA=PHEP(5,3)
+ EMSSQ=EMSCA**2
+ MUSQ=RMASS(IFLAVU)**2
+ MDSQ=RMASS(IFLAVD)**2
+ ETA=(SHAT+Q2)/EMSSQ/Y
+ IF (ETA.GT.ONE) RETURN
+C---CALCULATE KINEMATIC TERMS
+ G=0.5*(ETA*EMSSQ*Y-Q2) -0.5*(MUSQ+MDSQ)
+ S=0.5*ETA*EMSSQ
+ T=0.5*ETA*EMSSQ*(1-Y)
+ U=0.5*Q2
+ C1=0.5*ETA*EMSSQ*Y*Z
+ C2=0.5*ETA*EMSSQ*Y*(1-Z)
+ COSBET=(-ETA*EMSSQ*Y+Q2*(2-Y))/(Y*(ETA*EMSSQ-Q2))
+ IF (SHAT.LE.(RMASS(IFLAVU)+RMASS(IFLAVD))**2) RETURN
+ Q1=SQRT((SHAT**2+MUSQ**2+MDSQ**2
+ & -2*SHAT*MUSQ-2*SHAT*MDSQ-2*MUSQ*MDSQ)/SHAT**2)
+ COSTHE=(1+(MDSQ-MUSQ)/SHAT-2*Z)/Q1
+ IF (ABS(COSTHE).GE.ONE .OR. ABS(COSBET).GE.ONE) RETURN
+ D1=0.25*(ETA*EMSSQ-Q2)*(1+(MDSQ-MUSQ)/SHAT-Q1*
+ & (COSTHE*COSBET+SQRT((1-COSTHE**2)*(1-COSBET**2))*COS(PHI)))
+ D2=S-U-D1
+ F1=D1+C1-G -MDSQ
+ F2=U+T-F1
+C---CALCULATE TRACE TERMS
+ CALL HWVZRO(16,D)
+ CALL HWVZRO(16,C)
+ D(1,1)=2*F1*C2*S
+ D(2,2)=2*C1*D2*T
+ D(3,3)=-D1*(2*F2*G-D2*(F1+2*U))
+ & -D2*F1*(F2+U-D2+F1)
+ & +2*F1*F2*U
+ & -G*(-2*D1*(F1+F2+U)-F1*(D2+2*U)+2*D2*(U-F2)+2*U*(F2-U+G))
+ D(4,4)=2*F1*C2*S
+ D(1,2)=(D1+U-F2)*(D1*F2-F1*D2)-G*(D1*(F2+U)+U*(U-F2-G)+F1*D2)
+ D(1,3)=D1*F2*(-2*F1+U-F2+D1)
+ & +F1*(F2*(D2-2*U)+F1*D2)
+ & +G*(-D1*(2*F1+F2+U)-F1*(D2+2*U)+U*(F2-U+G))
+ D(1,4)=-2*F1*(D1+U)*(F2+G)
+ D(2,3)=D1*(D2*(F1+2*(U-F2))+F2*(F2-U-D1))
+ & +F1*D2**2
+ & +G*(D1*(F2+U)+D2*(F1-2*(U-F2))+U*(U-F2-G))
+ D(2,4)=-D1*F2*(U-F2+D1)
+ & -F1*D2*(U-D1-G-F2)
+ & -G*(U*(F2-U+G)-D1*(F2+U))
+ D(3,4)=D1*(F1*(D2+2*F2)+F2*(F2-U-D1))
+ & +F1*(2*F2*U-D2*(U+F1))
+ & +G*(D1*(2*F1+F2+U)+U*(2*F1-F2+U-G))
+C---REGULATE PROPAGATORS
+ TMAX=EMSSQ-2*G
+ TMIN=PHEP(5,2)**2
+ A1=2*C1+MDSQ*(G+U)/G
+ A2=2*C2+MUSQ*(G+U)/G
+ B1=(2*U+MUSQ)/(2*G+2*U)
+ B2=(2*U+MDSQ)/(2*G+2*U)
+ I0=LOG(TMAX/TMIN)
+ I1=1/A1*(I0-LOG((A1+B1*TMAX)/(A1+B1*TMIN)))
+ I2=1/A2*(I0-LOG((A2+B2*TMAX)/(A2+B2*TMIN)))
+ I3=(B1*I1-B2*I2)/(B1*A2-B2*A1)
+ I4=1/A1*(I1+1/(A1+B1*TMAX)-1/(A1+B1*TMIN))
+ I5=1/A2*(I2+1/(A2+B2*TMAX)-1/(A2+B2*TMIN))
+ WPROP=1/((2*G-EMWSQ)**2+GAMW**2*EMWSQ)
+C---CALCULATE COEFFICIENTS
+ C(1,1)= QU**2/(2*U+EMWSQ)**2 *I5
+ C(2,2)= QD**2/(2*U+EMWSQ)**2 *I4
+ C(3,3)= QW**2/(2*U+EMWSQ)**2 *WPROP *I0
+ C(4,4)= QE**2/(2*S)**2 *WPROP *I0
+ C(1,2)= 2*QU*QD/(2*U+EMWSQ)**2 *I3
+ C(1,3)= 2*QW*QU/(2*U+EMWSQ)**2 *WPROP*(2*G-EMWSQ) *I2
+ C(1,4)= 2*QU*QE/(2*S*(2*U+EMWSQ)) *WPROP*(2*G-EMWSQ) *I2
+ C(2,3)= 2*QW*QD/(2*U+EMWSQ)**2 *WPROP*(2*G-EMWSQ) *I1
+ C(2,4)= 2*QD*QE/(2*S*(2*U+EMWSQ)) *WPROP*(2*G-EMWSQ) *I1
+ C(3,4)= 2*QW*QE/(2*S*(2*U+EMWSQ)) *WPROP *I0
+C---CALCULATE PHOTON STRUCTURE FUNCTION
+ PHOTON=ALPHEM * (1+(1-ETA)**2) / (2*PIFAC*ETA)
+C---SUM ALL TENSOR CONTRIBUTIONS
+ DO 10 I=1,4
+ DO 10 J=1,4
+ 10 DSIGMA=DSIGMA + C(I,J)*D(I,J)
+C---CALCULATE TOTAL SUMMED AND AVERAGED MATRIX ELEMENT SQUARED
+ DSIGMA = DSIGMA * 2*CFAC*(4*PIFAC*ALPHEM)**3/SWEIN**2
+C---CALCULATE DIFFERENTIAL CROSS-SECTION
+ DSIGMA = DSIGMA * GEV2NB*PHOTON/(512*PIFAC**4*ETA*EMSSQ)
+ 999 END
+CDECK ID>, HWHEPA.
+*CMZ :- -26/04/91 14.55.44 by Federico Carminati
+*-- Author : Bryan Webber and Ian Knowles
+C-----------------------------------------------------------------------
+ SUBROUTINE HWHEPA
+C-----------------------------------------------------------------------
+C (Initially polarised) e+e- --> ffbar (f=quark, mu or tau)
+C If IPROC=107: --> gg, distributed as sum of light quarks.
+C If fermion flavour specified mass effects fully included.
+C EVWGT=sig(e+e- --> ffbar) in nb
+C-----------------------------------------------------------------------
+ INCLUDE 'HERWIG61.INC'
+ DOUBLE PRECISION HWR,HWRUNI,HWUPCM,HWUAEM,Q2NOW,Q2LST,FACTR,
+ & VF2,VF,CLF(7),PRAN,PQWT,PMAX,PTHETA,SINTH2,CPHI,SPHI,C2PHI,S2PHI,
+ & PPHI,SINTH,PCM,PP(5),EWGT
+ INTEGER ID1,ID2,IDF,IQ,IQ1,I
+ EXTERNAL HWR,HWRUNI,HWUPCM,HWUAEM
+ SAVE Q2LST,FACTR,ID1,ID2,VF2,VF,CLF,EWGT
+ DATA Q2LST/0./
+ IF (GENEV) THEN
+ IF (ID2.EQ.0) THEN
+C Choose quark flavour
+ PRAN=TQWT*HWR()
+ PQWT=0.
+ DO 10 IQ=1,MAXFL
+ PQWT=PQWT+CLQ(1,IQ)
+ IF (PQWT.GT.PRAN) GOTO 11
+ 10 CONTINUE
+ IQ=MAXFL
+ 11 IQ1=MAPQ(IQ)
+ DO 20 I=1,7
+ 20 CLF(I)=CLQ(I,IQ)
+ ELSE
+ IQ1=ID1
+ ENDIF
+C Label particles, assign outgoing particle masses
+ IDHW(NHEP+1)=200
+ IDHEP(NHEP+1)=23
+ ISTHEP(NHEP+1)=110
+ IF (ID1.EQ.7) THEN
+ IDHW(NHEP+2)=13
+ IDHW(NHEP+3)=13
+ IDHEP(NHEP+2)=21
+ IDHEP(NHEP+3)=21
+ PHEP(5,NHEP+2)=RMASS(13)
+ PHEP(5,NHEP+3)=RMASS(13)
+ ELSE
+ IDHW(NHEP+2)=IQ1
+ IDHW(NHEP+3)=IQ1+6
+ IDHEP(NHEP+2)=IDPDG(IQ1)
+ IDHEP(NHEP+3)=-IDHEP(NHEP+2)
+ PHEP(5,NHEP+2)=RMASS(IQ1)
+ PHEP(5,NHEP+3)=RMASS(IQ1)
+ ENDIF
+ ISTHEP(NHEP+2)=113
+ ISTHEP(NHEP+3)=114
+ JMOHEP(1,NHEP+1)=1
+ IF (JDAHEP(1,1).NE.0) JMOHEP(1,NHEP+1)=JDAHEP(1,1)
+ JMOHEP(2,NHEP+1)=2
+ IF (JDAHEP(1,2).NE.0) JMOHEP(1,NHEP+1)=JDAHEP(1,2)
+ JMOHEP(1,NHEP+2)=NHEP+1
+ JMOHEP(2,NHEP+2)=NHEP+3
+ JMOHEP(1,NHEP+3)=NHEP+1
+ JMOHEP(2,NHEP+3)=NHEP+2
+ JDAHEP(1,NHEP+1)=NHEP+2
+ JDAHEP(2,NHEP+1)=NHEP+3
+ JDAHEP(1,NHEP+2)=0
+ JDAHEP(2,NHEP+2)=NHEP+3
+ JDAHEP(1,NHEP+3)=0
+ JDAHEP(2,NHEP+3)=NHEP+2
+C Generate polar and azimuthal angular distributions:
+C CLF(1)*(1+(VF*COSTH)**2)+CLF(2)*(1-VF**2)+CLF(3)*2.*VF*COSTH
+C +(VF*SINTH)**2*(CLF(4)*COS(2*PHI-PHI1-PHI2)
+C +CLF(6)*SIN(2*PHI-PHI1-PHI2))
+ PMAX=CLF(1)*(1.+VF2)+CLF(2)*(1.-VF2)+ABS(CLF(3))*2.*VF
+ 30 COSTH=HWRUNI(0,-ONE, ONE)
+ PTHETA=CLF(1)*(1.+VF2*COSTH**2)+CLF(2)*(1.-VF2)
+ & +CLF(3)*2.*VF*COSTH
+ IF (PTHETA.LT.PMAX*HWR()) GOTO 30
+ IF (IDHW(1).GT.IDHW(2)) COSTH=-COSTH
+ SINTH2=1.-COSTH**2
+ IF (TPOL) THEN
+ PMAX=PTHETA+VF2*SINTH2*SQRT(CLF(4)**2+CLF(6)**2)
+ 40 CALL HWRAZM(ONE,CPHI,SPHI)
+ C2PHI=2.*CPHI**2-1.
+ S2PHI=2.*CPHI*SPHI
+ PPHI=PTHETA+(CLF(4)*(C2PHI*COSS+S2PHI*SINS)
+ & +CLF(6)*(S2PHI*COSS-C2PHI*SINS))*VF2*SINTH2
+ IF (PPHI.LT.PMAX*HWR()) GOTO 40
+ ELSE
+ CALL HWRAZM(ONE,CPHI,SPHI)
+ ENDIF
+C Construct final state 4-mommenta
+ CALL HWVEQU(5,PHEP(1,3),PHEP(1,NHEP+1))
+ PCM=HWUPCM(PHEP(5,NHEP+1),PHEP(5,NHEP+2),PHEP(5,NHEP+3))
+C PP is momentum of track NHEP+2 in CoM (track NHEP+1) frame
+ SINTH=SQRT(SINTH2)
+ PP(5)=PHEP(5,NHEP+2)
+ PP(1)=PCM*SINTH*CPHI
+ PP(2)=PCM*SINTH*SPHI
+ PP(3)=PCM*COSTH
+ PP(4)=SQRT(PCM**2+PP(5)**2)
+ CALL HWULOB(PHEP(1,NHEP+1),PP(1),PHEP(1,NHEP+2))
+ CALL HWVDIF(4,PHEP(1,NHEP+1),PHEP(1,NHEP+2),PHEP(1,NHEP+3))
+C Set production vertices
+ CALL HWVZRO(4,VHEP(1,NHEP+2))
+ CALL HWVEQU(4,VHEP(1,NHEP+2),VHEP(1,NHEP+3))
+ NHEP=NHEP+3
+ ELSE
+ EMSCA=PHEP(5,3)
+ Q2NOW=EMSCA**2
+ IF (Q2NOW.NE.Q2LST) THEN
+C Calculate coefficients for cross-section
+ EMSCA=PHEP(5,3)
+ Q2LST=Q2NOW
+ FACTR=PIFAC*GEV2NB*HWUAEM(Q2NOW)**2/Q2NOW
+ ID1=MOD(IPROC,10)
+ ID2=MOD(ID1,7)
+ IF (ID2.EQ.0) THEN
+ CALL HWUEEC(1)
+ VF2=1.
+ VF=1.
+ EWGT=FACTR*FLOAT(NCOLO)*TQWT*4./3.
+ ELSE
+ IF (IPROC.LT.150) THEN
+ IDF=ID1
+ FACTR=FACTR*FLOAT(NCOLO)
+ ELSE
+ ID1=2*ID1+119
+ IDF=ID1-110
+ ENDIF
+ IF (EMSCA.LE.2.*RMASS(ID1)) then
+ EWGT=0.
+ ELSE
+ CALL HWUCFF(11,IDF,Q2NOW,CLF(1))
+ VF2=1.-4.*RMASS(ID1)**2/Q2NOW
+ VF=SQRT(VF2)
+ EWGT=FACTR*VF*(CLF(1)*(1.+VF2/3.)+CLF(2)*(1.-VF2))
+ ENDIF
+ ENDIF
+ ENDIF
+ EVWGT=EWGT
+ ENDIF
+ 999 END
+CDECK ID>, HWHEPG.
+*CMZ :- -02/05/91 10.57.27 by Federico Carminati
+*-- Author : Bryan Webber and Ian Knowles
+C-----------------------------------------------------------------------
+ SUBROUTINE HWHEPG
+C-----------------------------------------------------------------------
+C (Initially polarised) e-e+ --> qqbar g with parton thrust < THMAX,
+C equivalent to: maximum parton energy < THMAX*EMSCA/2; or a JADE E0
+c scheme, y_cut=1.-THMAX.
+C If flavour specified mass effects fully included.
+C EVWGT=sig(e^-e^+ --> qqbar g) in nb
+C-----------------------------------------------------------------------
+ INCLUDE 'HERWIG61.INC'
+ DOUBLE PRECISION HWR,HWUALF,HWUAEM,HWULDO,HWDPWT,Q2NOW,Q2LST,
+ & PHASP,QGMAX,QGMIN,FACTR,QM2,CLF(7),ORDER,PRAN,PQWT,QQG,QBG,SUM,
+ & RUT,QQLM,QQLP,QBLM,QBLP,DYN1,DYN2,DYN3,DYN4,DYN5,DYN6,XQ2,X2SUM,
+ & PVRT(4)
+ INTEGER ID1,IQ,I,LM,LP,IQ1
+ LOGICAL MASS
+ EXTERNAL HWR,HWUALF,HWUAEM,HWULDO,HWDPWT
+ SAVE Q2NOW,Q2LST,QGMAX,QGMIN,FACTR,ORDER,ID1,MASS,QM2,CLF,LM,LP,
+ & IQ1,QQG,QBG,SUM
+ DATA Q2LST/0./
+ IF (GENEV) THEN
+C Label produced partons and calculate gluon spin
+ IDHW(NHEP+1)=200
+ IDHW(NHEP+2)=IQ1
+ IDHW(NHEP+3)=13
+ IDHW(NHEP+4)=IQ1+6
+ IDHEP(NHEP+1)=23
+ IDHEP(NHEP+2)=IQ1
+ IDHEP(NHEP+3)=21
+ IDHEP(NHEP+4)=-IQ1
+ ISTHEP(NHEP+1)=110
+ ISTHEP(NHEP+2)=113
+ ISTHEP(NHEP+3)=114
+ ISTHEP(NHEP+4)=114
+ JMOHEP(1,NHEP+1)=LM
+ JMOHEP(2,NHEP+1)=LP
+ JMOHEP(1,NHEP+2)=NHEP+1
+ JMOHEP(2,NHEP+2)=NHEP+3
+ JMOHEP(1,NHEP+3)=NHEP+1
+ JMOHEP(2,NHEP+3)=NHEP+4
+ JMOHEP(1,NHEP+4)=NHEP+1
+ JMOHEP(2,NHEP+4)=NHEP+2
+ JDAHEP(1,NHEP+1)=NHEP+2
+ JDAHEP(2,NHEP+1)=NHEP+4
+ JDAHEP(1,NHEP+2)=0
+ JDAHEP(2,NHEP+2)=NHEP+4
+ JDAHEP(1,NHEP+3)=0
+ JDAHEP(2,NHEP+3)=NHEP+2
+ JDAHEP(1,NHEP+4)=0
+ JDAHEP(2,NHEP+4)=NHEP+3
+C Decide which quark radiated and assign production vertices
+ XQ2=(Q2NOW-2.*QBG)**2
+ X2SUM=XQ2+(Q2NOW-2.*QQG)**2
+ IF (XQ2.LT.HWR()*X2SUM) THEN
+C Quark radiated the gluon
+ CALL HWVZRO(4,VHEP(1,NHEP+4))
+ CALL HWVSUM(4,PHEP(1,NHEP+2),PHEP(1,NHEP+3),PVRT)
+ CALL HWUDKL(IQ1,PVRT,VHEP(1,NHEP+3))
+ CALL HWVEQU(4,VHEP(1,NHEP+3),VHEP(1,NHEP+2))
+ ELSE
+C Anti-quark radiated the gluon
+ CALL HWVZRO(4,VHEP(1,NHEP+2))
+ CALL HWVSUM(4,PHEP(1,NHEP+4),PHEP(1,NHEP+3),PVRT)
+ CALL HWUDKL(IQ1,PVRT,VHEP(1,NHEP+3))
+ CALL HWVEQU(4,VHEP(1,NHEP+3),VHEP(1,NHEP+4))
+ ENDIF
+ IF (AZSPIN) THEN
+C Calculate the transverse polarisation of the gluon
+C Correlation with leptons presently neglected
+ GPOLN=(QQG**2+QBG**2)/((Q2NOW-2.*SUM)*Q2NOW)
+ GPOLN=2./(2.+GPOLN)
+ ENDIF
+ NHEP=NHEP+4
+ ELSE
+ EMSCA=PHEP(5,3)
+ Q2NOW=EMSCA**2
+ IF (Q2NOW.NE.Q2LST) THEN
+ Q2LST=Q2NOW
+ PHASP=3.*THMAX-2.
+ IF (PHASP.LE.ZERO) CALL HWWARN('HWHEPG',400,*999)
+ QGMAX=.5*Q2NOW*THMAX
+ QGMIN=.5*Q2NOW*(1.-THMAX)
+ FACTR=GEV2NB*FLOAT(NCOLO)*CFFAC*HWUALF(1,EMSCA)
+ & *.5*(HWUAEM(Q2NOW)*PHASP)**2/Q2NOW
+ LM=1
+ IF (JDAHEP(1,LM).NE.0) LM=JDAHEP(1,LM)
+ LP=2
+ IF (JDAHEP(1,LP).NE.0) LP=JDAHEP(1,LP)
+ ORDER=1.
+ IF (IDHW(1).GT.IDHW(2)) ORDER=-ORDER
+ ID1=MOD(IPROC,10)
+ IF (ID1.NE.0) THEN
+ MASS=.TRUE.
+ QM2=RMASS(ID1)**2
+ CALL HWUCFF(11,ID1,Q2NOW,CLF(1))
+ FACTR=FACTR*CLF(1)
+ ELSE
+ MASS=.FALSE.
+ CALL HWUEEC(1)
+ FACTR=FACTR*TQWT
+ ENDIF
+ ENDIF
+ IF (ID1.EQ.0) THEN
+C Select quark flavour
+ PRAN=TQWT*HWR()
+ PQWT=0.
+ DO 10 IQ=1,MAXFL
+ PQWT=PQWT+CLQ(1,IQ)
+ IF (PQWT.GT.PRAN) GOTO 11
+ 10 CONTINUE
+ IQ=MAXFL
+ 11 IQ1=MAPQ(IQ)
+ DO 20 I=1,7
+ 20 CLF(I)=CLQ(I,IQ)
+ ELSEIF (Q2NOW.GT.4*QM2/(2*THMAX-1)) THEN
+ IQ1=ID1
+ ELSE
+ EVWGT=0.
+ RETURN
+ ENDIF
+C Select final state momentum configuration
+ CALL HWVEQU(5,PHEP(1,3),PHEP(1,NHEP+1))
+ PHEP(5,NHEP+2)=RMASS(IQ1)
+ PHEP(5,NHEP+3)=RMASS(13)
+ PHEP(5,NHEP+4)=RMASS(IQ1)
+ 30 CALL HWDTHR(PHEP(1,NHEP+1),PHEP(1,NHEP+2),
+ & PHEP(1,NHEP+3),PHEP(1,NHEP+4),HWDPWT)
+ QQG=HWULDO(PHEP(1,NHEP+2),PHEP(1,NHEP+3))
+ IF (QQG.LT.QGMIN) GOTO 30
+ QBG=HWULDO(PHEP(1,NHEP+4),PHEP(1,NHEP+3))
+ SUM=QQG+QBG
+ IF (QBG.LT.QGMIN.OR.SUM.GT.QGMAX) GOTO 30
+ QQLM=HWULDO(PHEP(1,NHEP+2),PHEP(1,LM))
+ QQLP=HWULDO(PHEP(1,NHEP+2),PHEP(1,LP))
+ QBLM=HWULDO(PHEP(1,NHEP+4),PHEP(1,LM))
+ QBLP=HWULDO(PHEP(1,NHEP+4),PHEP(1,LP))
+ DYN1=QQLM**2+QQLP**2+QBLM**2+QBLP**2
+ DYN2=0.
+ DYN3=DYN1-2.*(QQLM**2+QBLP**2)
+ IF (MASS) THEN
+ RUT=1./QQG+1./QBG
+ DYN1=DYN1+8.*QM2*(1.-.25*Q2NOW*RUT
+ & +QQLM*QQLP/(Q2NOW*QBG)+QBLM*QBLP/(Q2NOW*QQG))
+ DYN2=QM2*(Q2NOW-SUM*(2.+QM2*RUT)
+ & -4.*HWULDO(PHEP(1,NHEP+3),PHEP(1,LM))
+ & *HWULDO(PHEP(1,NHEP+3),PHEP(1,LP))/Q2NOW)
+ DYN3=DYN3+QM2*2.*RUT*(QBG*(QBLP-QBLM)-QQG*(QQLP-QQLM))
+ ENDIF
+ EVWGT=CLF(1)*DYN1+CLF(2)*DYN2+ORDER*CLF(3)*DYN3
+ IF (TPOL) THEN
+C Include event plane azimuthal angle
+ DYN4=.5*Q2NOW
+ DYN5=DYN4
+ DYN6=0.
+ IF (MASS) THEN
+ DYN4=DYN4-QM2*SUM/QBG
+ DYN5=DYN5-QM2*SUM/QQG
+ DYN6=QM2
+ ENDIF
+ EVWGT=EVWGT
+ & +(CLF(4)*COSS-CLF(6)*SINS)
+ & *(DYN4*(PHEP(1,NHEP+2)**2-PHEP(2,NHEP+2)**2)
+ & +DYN5*(PHEP(1,NHEP+4)**2-PHEP(2,NHEP+4)**2))
+ & +(CLF(4)*SINS+CLF(6)*COSS)*2.
+ & *(DYN4*PHEP(1,NHEP+2)*PHEP(2,NHEP+2)
+ & +DYN5*PHEP(1,NHEP+4)*PHEP(2,NHEP+4))
+ & +(CLF(5)*COSS-CLF(7)*SINS)*DYN6
+ & *(PHEP(1,NHEP+3)**2-PHEP(2,NHEP+3)**2)
+ & +(CLF(5)*SINS+CLF(7)*COSS)*DYN6*2.
+ & *PHEP(1,NHEP+3)*PHEP(2,NHEP+3)
+ ENDIF
+C Assign event weight
+ EVWGT=EVWGT*FACTR/(QQG*QBG*CLF(1))
+ ENDIF
+ 999 END
+CDECK ID>, HWHEW0.
+*CMZ :- -26/04/91 11.11.55 by Bryan Webber
+*-- Author : Zoltan Kunszt, modified by Bryan Webber & Mike Seymour
+C-----------------------------------------------------------------------
+ SUBROUTINE HWHEW0(IP,ETOT,XM,PR,WEIGHT,CR)
+C-----------------------------------------------------------------------
+ INCLUDE 'HERWIG61.INC'
+ DOUBLE PRECISION HWR,ETOT,XM(2),PR(5,2),WEIGHT,CR,XM1,XM2,S,
+ & D1,PABS,D,CX,C,E,F,SC,G
+ INTEGER IP,I
+ EXTERNAL HWR
+ WEIGHT=ZERO
+ XM1=XM(1)**2
+ XM2=XM(2)**2
+ S=ETOT*ETOT
+ D1=S-XM1-XM2
+ PABS=D1*D1-4.*XM1*XM2
+ IF (PABS.LE.ZERO) RETURN
+ PABS=SQRT(PABS)
+ D=D1/PABS
+ IF(IP.EQ.2)GOTO3
+ CX=CR
+ C=D-(D+CX)*((D-CR)/(D+CX))**HWR()
+ GOTO 4
+3 E=((D+ONE)/(D-ONE))*(TWO*HWR()-ONE)
+ C=D*((E-ONE)/(E+ONE))
+4 F=2D0*PIFAC*HWR()
+ SC=SQRT(ONE-C*C)
+ PR(4,1)=(S+XM1-XM2)/(TWO*ETOT)
+ PR(5,1)=PR(4,1)*PR(4,1)-XM1
+ IF (PR(5,1).LE.ZERO) RETURN
+ PR(5,1)=SQRT(PR(5,1))
+ PR(4,2)=ETOT-PR(4,1)
+ PR(3,1)=PR(5,1)*C
+ PR(5,2)=PR(5,1)
+ PR(2,1)=PR(5,1)*SC*COS(F)
+ PR(1,1)=PR(5,1)*SC*SIN(F)
+ DO 7 I=1,3
+7 PR(I,2)=-PR(I,1)
+ G=0.
+ IF(IP.EQ.1)G=(D-C)*LOG((D+CX)/(D-CR))
+ IF(IP.EQ.2)G=(D*D-C*C)/D*LOG((D+ONE)/(D-ONE))
+ WEIGHT=PIFAC*G*PR(5,1)/ETOT*HALF
+ RETURN
+ END
+CDECK ID>, HWHEW1.
+*CMZ :- -26/04/91 11.11.55 by Bryan Webber
+*-- Author : Zoltan Kunszt, modified by Bryan Webber
+C-----------------------------------------------------------------------
+ SUBROUTINE HWHEW1(NPART)
+C-----------------------------------------------------------------------
+ IMPLICIT NONE
+ DOUBLE PRECISION P(4,7),XMASS,PLAB,PRW,PCM
+ INTEGER NPART,I,J,K
+ COMMON/HWHEWP/ XMASS(10),PLAB(5,10),PRW(5,2),PCM(5,10)
+ DO 10 I=1,NPART
+ P(1,I)=PLAB(3,I)
+ P(2,I)=PLAB(1,I)
+ P(3,I)=PLAB(2,I)
+ P(4,I)=PLAB(4,I)
+ 10 CONTINUE
+ DO 20 J=1,4
+ DO 30 K=1,(NPART-2)
+ 30 PCM(J,K)=P(J,K+2)
+ PCM(J,NPART-1)=-P(J,1)
+ PCM(J,NPART)=-P(J,2)
+ 20 CONTINUE
+ END
+CDECK ID>, HWHEW2.
+*CMZ :- -26/04/91 13.22.25 by Federico Carminati
+*-- Author : Zoltan Kunszt, modified by Bryan Webber
+C-----------------------------------------------------------------------
+ SUBROUTINE HWHEW2(NPART,PPCM,H,CH,D)
+C-----------------------------------------------------------------------
+C PCM SHOULD BE DEFINED SUCH THAT ALL 4-MOMENTA ARE OUTGOING.
+C CONVENTION FOR PCM AND P IS THAT DIRECTION 1 =BEAM, COMPONENT
+C 4 = ENERGY AND COMPONENT 2 AND 3 ARE TRANSVERSE COMPONENTS.
+C THUS INCOMING MOMENTA SHOULD CORRESPOND TO OUTGOING MOMENTA
+C OF NEGATIVE ENERGY.
+C PCM IS FILLED BY PHASE SPACE MONTE CARLO.
+C I1-I7 HERE REFER TO HOW PCM INDEXING IS MAPPED TO OUR STANDARD
+C 1-6=GLUON,GLUON,Q,QBAR,QP,QPBAR ORDERING `
+C-----------------------------------------------------------------------
+ IMPLICIT NONE
+ COMPLEX PT5,ZT,Z1,ZI,ZP,ZQ,ZD,ZPS,ZQS,ZDPM,ZDMP,H(7,7),CH(7,7),
+ & D(7,7)
+ DOUBLE PRECISION ZERO,ONE,PPCM(5,7),P(5,7),WRN(7),EPS,Q1,Q2,QP,QM,
+ & P1,P2,PP,PM,DMP,DPM,PT,QT,PTI,QTI
+ INTEGER J,L,IJ,II,JJ,I,NPART,IP1,IPP1
+ PARAMETER (ZERO=0.D0,ONE=1.D0)
+ EPS=0.0000001
+ ZI=CMPLX(0.,1.)
+ Z1=CMPLX(1.,0.)
+C FOLLOWING DO LOOP IS TO CONVERT TO OUR STANDARD INDEXING
+ DO 1 L=1,NPART
+ DO 1 IJ=1,4
+1 P(IJ,L)=PPCM(IJ,L)
+ DO 2 II=1,7
+ WRN(II)=ONE
+ IF(P(4,II).LT.ZERO) WRN(II)=-ONE
+ DO 2 JJ=1,4
+ P(JJ,II)=WRN(II)*P(JJ,II)
+ 2 CONTINUE
+C THE ABOVE CHECKS FOR MOMENTA WITH NEGATIVE ENERGY,INNER PRODUCTS
+C ARE EXPRESSED DIFFERENTLY FOR DIFFERENT CASES
+ DO 11 I=1,NPART-1
+ IP1=I+1
+ DO 11 J=IP1,NPART
+ Q1=P(4,I)+P(1,I)
+ QP=0.0
+ IF(Q1.GT.EPS)QP=SQRT(Q1)
+ Q2=P(4,I)-P(1,I)
+ QM=0.0
+ IF(Q2.GT.EPS)QM=SQRT(Q2)
+ P1=P(4,J)+P(1,J)
+ PP=0.
+ IF(P1.GT.EPS)PP=SQRT(P1)
+ P2=P(4,J)-P(1,J)
+ PM=0.
+ IF(P2.GT.EPS)PM=SQRT(P2)
+ DMP=PM*QP
+ ZDMP=CMPLX(DMP,ZERO)
+ DPM=PP*QM
+ ZDPM=CMPLX(DPM,ZERO)
+C NOTE THAT IN OUR INNER PRODUCT NOTATION WE ARE COMPUTING <P,Q>
+ PT=SQRT(P(2,J)**2+P(3,J)**2)
+ QT=SQRT(P(2,I)**2+P(3,I)**2)
+ IF(PT.GT.EPS) GOTO 99
+ ZP=Z1
+ GOTO 98
+ 99 PTI=ONE/PT
+ ZP=CMPLX(PTI*P(2,J),PTI*P(3,J))
+ 98 ZPS=CONJG(ZP)
+ IF(QT.GT.EPS) GOTO 89
+ ZQ=Z1
+ GOTO 88
+ 89 QTI=ONE/QT
+ ZQ=CMPLX(QTI*P(2,I),QTI*P(3,I))
+ 88 ZQS=CONJG(ZQ)
+ ZT=Z1
+ IF(WRN(I).LT.ZERO) ZT=ZT*ZI
+ IF(WRN(J).LT.ZERO) ZT=ZT*ZI
+ H(J,I)=(ZDMP*ZP-ZDPM*ZQ)*ZT
+ CH(J,I)=(ZDMP*ZPS-ZDPM*ZQS)*ZT
+ ZD=H(J,I)*CH(J,I)
+ PT5=CMPLX(.5,0.)
+ D(J,I)=PT5*ZD
+ 11 CONTINUE
+ DO 60 I=1,NPART-1
+ IPP1=I+1
+ DO 60 J=IPP1,NPART
+ H(I,J)=-H(J,I)
+ CH(I,J)=-CH(J,I)
+ 60 D(I,J)=D(J,I)
+ RETURN
+ END
+CDECK ID>, HWHEW3.
+*CMZ :- -27/03/92 19.48.55 by Mike Seymour
+*-- Author : Zoltan Kunszt, modified by Bryan Webber
+C-----------------------------------------------------------------------
+ SUBROUTINE HWHEW3(N1,N2,N3,N4,N5,N6,AMPWW)
+C-----------------------------------------------------------------------
+C RECALL THAT N1,N3,N5 MUST BE OUTGOING FERMIONS, AND N2,N4,N6 MUST BE
+C OUTGOING ANTI-FERMIONS; 3,4 FOR W-, 5,6 FOR W+
+C
+C EQ1 AND T31 ARE FOR OUTOING INITIAL QUARK
+C CHOOSE APPROPRIATE CASE ACCORDING TO NUPDN
+C NUPDN=1 FOR UUBAR COLLISIONS, NUPDN=2 FOR DDBAR COLLISIONS
+C NFINAL CHOOSES THE FINAL DECAYS, 1 FOR DOUBLE LEPTON, 2 FOR 1 FLAVOR
+C LEPTON+2FAMILIES OF QUARKS, 3 THE SAME, 4 FOR DOUBLE 2FAM3COLOR QUARKS
+C
+C NOTE: EXTERNAL FACTOR OF COLOR AVERAGE AND SPIN AVERAGE AND
+C COUPLING (E**8/4/9) MUST BE INCLUDED AS WELL AS COMPENSATION
+C FOR ON POLE APPROXIMATION AS DESIRED.
+C-----------------------------------------------------------------------
+ INCLUDE 'HERWIG61.INC'
+ COMPLEX HWHEW4,ZH,ZCH,ZD,ZAMP1,ZAMP2,ZAMP3,DWW,CWW,BWW,AWW,AWWM,
+ & AWWP,AMPTEM,ZTWO,ZHALF
+ DOUBLE PRECISION XW,ZMASS,T3,EQ1,RR,RL,ZM2,AMP2,RKW,COLFAC(4),
+ & AMPWW(4)
+ INTEGER I,N1,N2,N3,N4,N5,N6
+ EXTERNAL HWHEW4
+ COMMON/HWHEWQ/ZH(7,7),ZCH(7,7),ZD(7,7)
+ EQUIVALENCE (XW,SWEIN),(ZMASS,RMASS(200))
+ DATA COLFAC/1.D0,3.D0,3.D0,9.D0/
+ DATA ZTWO,ZHALF/(2.0,0.0),(0.5,0.0)/
+ T3=-1.D0
+ EQ1=-1.D0
+ RR=-2.D0*EQ1*XW
+ RL=T3+RR
+ ZM2=ZMASS*ZMASS
+ ZAMP1=CMPLX(ZM2)/(ZTWO*ZD(N1,N2))
+ & /(ZTWO*ZD(N1,N2)+CMPLX(-ZM2,GAMZ*ZMASS))
+ ZAMP2=ZHALF/(ZD(N1,N3)+ZD(N1,N4)+ZD(N3,N4))
+ ZAMP3=ZHALF/(ZD(N1,N5)+ZD(N1,N6)+ZD(N5,N6))
+ DWW=CMPLX(RL)*ZAMP1+T3/(ZTWO*ZD(N1,N2))
+ CWW=CMPLX(RR)*ZAMP1
+ AWW=DWW
+ BWW=DWW-ZAMP3
+ AWWM=AWW*HWHEW4(N1,N2,N3,N4,N5,N6)-BWW*HWHEW4(N1,N2,N5,N6,N3,N4)
+ AWWP=CWW*(HWHEW4(N2,N1,N5,N6,N3,N4)-HWHEW4(N2,N1,N3,N4,N5,N6))
+ AMPTEM=AWWM*CONJG(AWWM)+AWWP*CONJG(AWWP)
+ AMP2=REAL(AMPTEM)
+C AMP2 DOES NOT INCLUDE COLOR OR FLAVOR SUMS OR AVERAGES YET
+C NOR DOES IT INCLUDE TO THIS POINT KWW**2
+C 1 LEPTON FLAVOR IF APPROPRIATE FOR NFINAL CHOICE
+ RKW=0.25D0/XW**2
+ DO 6 I=1,4
+6 AMPWW(I)=AMP2*COLFAC(I)*RKW*RKW
+ RETURN
+ END
+CDECK ID>, HWHEW4.
+*CMZ :- -26/04/91 10.18.57 by Bryan Webber
+*-- Author : Zoltan Kunszt, modified by Bryan Webber
+C-----------------------------------------------------------------------
+ FUNCTION HWHEW4(N1,N2,N3,N4,N5,N6)
+C-----------------------------------------------------------------------
+ IMPLICIT NONE
+ COMPLEX HWHEW4,ZH,ZCH,ZD
+ INTEGER N1,N2,N3,N4,N5,N6
+ COMMON/HWHEWQ/ZH(7,7),ZCH(7,7),ZD(7,7)
+ HWHEW4=CMPLX(4.0)*ZH(N1,N3)*ZCH(N2,N6)*(ZH(N1,N5)*ZCH(N1,N4)
+ X +ZH(N3,N5)*ZCH(N3,N4))
+ RETURN
+ END
+CDECK ID>, HWHEW5.
+*CMZ : 20/08/91 22.09.33 by Federico Carminati
+*-- Author : Zoltan Kunszt, modified by Mike Seymour
+C-----------------------------------------------------------------------
+ SUBROUTINE HWHEW5(N1,N2,N3,N4,N5,N6,HELSUM,HELCTY,ID1,ID2)
+C-----------------------------------------------------------------------
+C RECALL THAT N1,N3,N5 MUST BE OUTGOING FERMIONS, AND N2,N4,N6 MUST BE
+C OUTGOING ANTI-FERMIONS; 3,4 FOR Z0, 5,6 FOR Z0
+C
+C EQ1 AND T31 ARE FOR OUTOING INITIAL QUARK
+C CHOOSE APPROPRIATE CASE ACCORDING TO NUPDN
+C NUPDN=1 FOR UUBAR COLLISIONS, NUPDN=2 FOR DDBAR COLLISIONS
+C NFINAL CHOOSES THE FINAL DECAYS, 1 FOR DOUBLE LEPTON, 2 FOR 1 FLAVOR
+C LEPTON+2FAMILIES OF QUARKS, 3 THE SAME, 4 FOR DOUBLE 2FAM3COLOR QUARKS
+C
+C NOTE: EXTERNAL FACTOR OF COLOR AVERAGE AND SPIN AVERAGE AND
+C COUPLING (E**8/4/9) MUST BE INCLUDED AS WELL AS COMPENSATION
+C FOR ON POLE APPROXIMATION AS DESIRED.
+C
+C---SLIGHTLY MODIFIED BY MHS, SO THAT HELCTY REFERS TO THE FINAL STATE
+C INDICATED BY ID1,ID2
+C-----------------------------------------------------------------------
+ IMPLICIT NONE
+ COMPLEX HWHEW4,ZH,ZCH,ZD,ZAMM(8),ZS134,ZS156,ZS234,ZS256,ZTWO
+ DOUBLE PRECISION CPFAC,CPALL,HELSUM,HELCTY,AMM
+ INTEGER N1,N2,N3,N4,N5,N6,ID1,ID2,I
+ EXTERNAL HWHEW4
+ COMMON/HWHEWQ/ZH(7,7),ZCH(7,7),ZD(7,7)
+ COMMON/HWHEWR/CPFAC(12,12,8),CPALL(8)
+ DATA ZTWO/(2.0,0.0)/
+C THE MATRIX ELEMENT DEPENDS ON
+ ZS134=(ZD(N1,N3)+ZD(N1,N4)+ZD(N3,N4))*ZTWO
+ ZS156=(ZD(N1,N5)+ZD(N1,N6)+ZD(N5,N6))*ZTWO
+ ZS234=(ZD(N2,N3)+ZD(N2,N4)+ZD(N3,N4))*ZTWO
+ ZS256=(ZD(N2,N5)+ZD(N2,N6)+ZD(N5,N6))*ZTWO
+ ZAMM(1)=HWHEW4(N1,N2,N3,N4,N5,N6)/ZS134+
+ > HWHEW4(N1,N2,N5,N6,N3,N4)/ZS156
+ ZAMM(2)=HWHEW4(N1,N2,N4,N3,N5,N6)/ZS134+
+ > HWHEW4(N1,N2,N5,N6,N4,N3)/ZS156
+ ZAMM(3)=HWHEW4(N1,N2,N3,N4,N6,N5)/ZS134+
+ > HWHEW4(N1,N2,N6,N5,N3,N4)/ZS156
+ ZAMM(4)=HWHEW4(N1,N2,N4,N3,N6,N5)/ZS134+
+ > HWHEW4(N1,N2,N6,N5,N4,N3)/ZS156
+ ZAMM(5)=HWHEW4(N2,N1,N3,N4,N5,N6)/ZS234+
+ > HWHEW4(N2,N1,N5,N6,N3,N4)/ZS256
+ ZAMM(6)=HWHEW4(N2,N1,N4,N3,N5,N6)/ZS234+
+ > HWHEW4(N2,N1,N5,N6,N4,N3)/ZS256
+ ZAMM(7)=HWHEW4(N2,N1,N3,N4,N6,N5)/ZS234+
+ > HWHEW4(N2,N1,N6,N5,N3,N4)/ZS256
+ ZAMM(8)=HWHEW4(N2,N1,N4,N3,N6,N5)/ZS234+
+ > HWHEW4(N2,N1,N6,N5,N4,N3)/ZS256
+ HELSUM=0.0
+ HELCTY=0.0
+ DO 1 I=1,8
+ AMM=REAL(ZAMM(I)*CONJG(ZAMM(I)))
+ HELSUM=HELSUM+CPALL(I)*AMM
+ HELCTY=HELCTY+CPFAC(ID1,ID2,I)*AMM
+ 1 CONTINUE
+ RETURN
+ END
+CDECK ID>, HWHEWW.
+*CMZ :- -02/05/91 10.58.29 by Federico Carminati
+*-- Author : Zoltan Kunszt, modified by Bryan Webber
+C-----------------------------------------------------------------------
+ SUBROUTINE HWHEWW
+C-----------------------------------------------------------------------
+C E+E- -> W+W-/Z0Z0 (BASED ON ZOLTAN KUNSZT'S PROGRAM)
+C-----------------------------------------------------------------------
+ INCLUDE 'HERWIG61.INC'
+ COMPLEX ZH,ZCH,ZD
+ DOUBLE PRECISION HWUAEM,HWR,HWUPCM,ETOT,STOT,FLUXW,GAMM,GIMM,
+ & WM2,WXMIN,WX1MAX,WX2MAX,FJAC1,FJAC2,WX1,WX2,WMM1,WMM2,XXM,W2BO,
+ & PST,WEIGHT,TOTSIG,WMASS,WWIDTH,ELST,CV,CA,BR,XMASS,PLAB,PRW,PCM,
+ & AMPWW(4),CCC,HELSUM,HELCTY,BRZED(12),BRTOT,CPFAC,CPALL,RLL(12),
+ & RRL(12),DIST(4)
+ INTEGER IB,IBOS,I,ID1,ID2,NTRY,IDP(10),IDBOS(2),J1,J2,IPRC,ILST,
+ & IDZOLT(16),MAP(12),NEWHEP
+ LOGICAL EISBM1,HWRLOG
+ EXTERNAL HWUAEM,HWR,HWUPCM
+ SAVE IDP,STOT,FLUXW,GAMM,GIMM,WM2,WXMIN,WX1MAX,FJAC1,ELST,ILST,
+ & IDBOS,WMASS,WWIDTH
+ COMMON/HWHEWP/XMASS(10),PLAB(5,10),PRW(5,2),PCM(5,10)
+ COMMON/HWHEWQ/ZH(7,7),ZCH(7,7),ZD(7,7)
+ COMMON/HWHEWR/CPFAC(12,12,8),CPALL(8)
+ DATA ELST,ILST/0.,0/
+ DATA IDZOLT/4,3,8,7,12,11,4*0,2,1,6,5,10,9/
+ DATA MAP/12,11,2,1,14,13,4,3,16,15,6,5/
+ IF (IERROR.NE.0) RETURN
+ EISBM1=IDHW(1).LT.IDHW(2)
+ IF (GENEV) THEN
+ NEWHEP=NHEP
+ NHEP=NHEP+2
+ DO 20 IB=1,2
+ IBOS=IB+NEWHEP
+ CALL HWVEQU(5,PRW(1,IB),PHEP(1,IBOS))
+ IF (EISBM1) PHEP(3,IBOS)=-PHEP(3,IBOS)
+ CALL HWVZRO(4,VHEP(1,IBOS))
+ CALL HWUDKL(IDBOS(IB),PHEP(1,IBOS),DIST)
+ CALL HWVSUM(4,VHEP(1,IBOS),DIST,DIST)
+ IDHW(IBOS)=IDBOS(IB)
+ IDHEP(IBOS)=IDPDG(IDBOS(IB))
+ JMOHEP(1,IBOS)=1
+ JMOHEP(2,IBOS)=2
+ ISTHEP(IBOS)=110
+ DO 10 I=1,2
+ CALL HWVEQU(5,PLAB(1,2*IB+I),PHEP(1,NHEP+I))
+ IF (EISBM1) PHEP(3,NHEP+I)=-PHEP(3,NHEP+I)
+ CALL HWVEQU(4,DIST,VHEP(1,NHEP+I))
+C---STATUS, IDs AND POINTERS
+ ISTHEP(NHEP+I)=112+I
+ IDHW(NHEP+I)=IDP(2*IB+I)
+ IDHEP(NHEP+I)=IDPDG(IDP(2*IB+I))
+ JDAHEP(I,IBOS)=NHEP+I
+ JMOHEP(1,NHEP+I)=IBOS
+ JMOHEP(2,NHEP+I)=JMOHEP(1,IBOS)
+ 10 CONTINUE
+ NHEP=NHEP+2
+ JMOHEP(2,NHEP)=NHEP-1
+ JDAHEP(2,NHEP)=NHEP-1
+ JMOHEP(2,NHEP-1)=NHEP
+ JDAHEP(2,NHEP-1)=NHEP
+ 20 CONTINUE
+ ELSE
+ EMSCA=PHEP(5,3)
+ ETOT=EMSCA
+ IPRC=MOD(IPROC,100)
+ IF (ETOT.NE.ELST .OR. IPRC.NE.ILST) THEN
+ STOT=ETOT*ETOT
+ FLUXW=GEV2NB*.125*(HWUAEM(STOT)/PIFAC)**4/STOT
+ IF (IPRC.EQ.0) THEN
+ WMASS=RMASS(198)
+ WWIDTH=GAMW
+ IDBOS(1)=198
+ IDBOS(2)=199
+ ELSEIF (IPRC.EQ.50) THEN
+ WMASS=RMASS(200)
+ WWIDTH=GAMZ
+ IDBOS(1)=200
+ IDBOS(2)=200
+C---LOAD FERMION COUPLINGS TO Z
+ DO 30 I=1,12
+ RLL(I)=VFCH(MAP(I),1)+AFCH(MAP(I),1)
+ RRL(I)=VFCH(MAP(I),1)-AFCH(MAP(I),1)
+ 30 CONTINUE
+ RLL(11)=0
+ RRL(11)=0
+ BRTOT=0
+ DO 60 J1=1,12
+ BRZED(J1)=0
+ DO 50 J2=1,12
+ CCC=1
+ IF (MOD(J1-1,4).GE.2) CCC=CCC*CAFAC
+ IF (MOD(J2-1,4).GE.2) CCC=CCC*CAFAC
+ CPFAC(J1,J2,1)=CCC*(RLL(2)**2*RLL(J1)*RLL(J2))**2
+ CPFAC(J1,J2,2)=CCC*(RLL(2)**2*RRL(J1)*RLL(J2))**2
+ CPFAC(J1,J2,3)=CCC*(RLL(2)**2*RLL(J1)*RRL(J2))**2
+ CPFAC(J1,J2,4)=CCC*(RLL(2)**2*RRL(J1)*RRL(J2))**2
+ CPFAC(J1,J2,5)=CCC*(RRL(2)**2*RLL(J1)*RLL(J2))**2
+ CPFAC(J1,J2,6)=CCC*(RRL(2)**2*RRL(J1)*RLL(J2))**2
+ CPFAC(J1,J2,7)=CCC*(RRL(2)**2*RLL(J1)*RRL(J2))**2
+ CPFAC(J1,J2,8)=CCC*(RRL(2)**2*RRL(J1)*RRL(J2))**2
+ DO 40 I=1,8
+ IF (J1.EQ.1.AND.J2.EQ.1) CPALL(I)=0
+ CPALL(I)=CPALL(I)+CPFAC(J1,J2,I)
+ BRZED(J1)=BRZED(J1)+CPFAC(J1,J2,I)
+ BRTOT=BRTOT+CPFAC(J1,J2,I)
+ 40 CONTINUE
+ 50 CONTINUE
+ 60 CONTINUE
+ DO 70 I=1,12
+ 70 BRZED(I)=BRZED(I)/BRTOT
+ ELSE
+ CALL HWWARN('HWHEWW',500,*999)
+ ENDIF
+ GAMM=WMASS*WWIDTH
+ GIMM=1.D0/GAMM
+ WM2=WMASS*WMASS
+ WXMIN=ATAN(-WMASS/WWIDTH)
+ WX1MAX=ATAN((STOT-WM2)*GIMM)
+ FJAC1=WX1MAX-WXMIN
+ ILST=IPRC
+ ELST=ETOT
+ ENDIF
+ EVWGT=0
+C---CHOOSE W MASSES
+ WX1=WXMIN+FJAC1*HWR()
+ WMM1=GAMM*TAN(WX1)+WM2
+ XMASS(1)=SQRT(WMM1)
+ WX2MAX=ATAN(((ETOT-XMASS(1))**2-WM2)*GIMM)
+ FJAC2=WX2MAX-WXMIN
+ WX2=WXMIN+FJAC2*HWR()
+ WMM2=GAMM*TAN(WX2)+WM2
+ XMASS(2)=SQRT(WMM2)
+ IF (HWRLOG(HALF))THEN
+ XXM=XMASS(1)
+ XMASS(1)=XMASS(2)
+ XMASS(2)=XXM
+ ENDIF
+C---CTMAX=ANGULAR CUT ON COS W-ANGLE
+ CALL HWHEW0(1,ETOT,XMASS(1),PRW(1,1),W2BO,CTMAX)
+ IF (W2BO.EQ.ZERO) RETURN
+C---FOR ZZ EVENTS, FORCE BOSE STATISTICS, BY KILLING EVENTS WITH COS1<0
+ IF (IPRC.NE.0) THEN
+ IF (PRW(3,1).LT.ZERO) RETURN
+C---AND THEN SYMMETRIZE (THIS PROCEDURE VASTLY IMPROVES EFFICIENCY)
+ IF (HWRLOG(HALF)) THEN
+ PRW(3,1)=-PRW(3,1)
+ PRW(3,2)=-PRW(3,2)
+ ENDIF
+ ENDIF
+ PLAB(3,1)=0.5*ETOT
+ PLAB(4,1)=PLAB(3,1)
+ PLAB(3,2)=-PLAB(3,1)
+ PLAB(4,2)=PLAB(3,1)
+C
+C---LET THE W BOSONS DECAY
+ NTRY=0
+ 80 NTRY=NTRY+1
+ DO 90 IB=1,2
+ CALL HWDBOZ(IDBOS(IB),ID1,ID2,CV,CA,BR,1)
+ PST=HWUPCM(XMASS(IB),RMASS(ID1),RMASS(ID2))
+ IF (PST.LT.ZERO) THEN
+ CALL HWDBOZ(IDBOS(IB),ID1,ID2,CV,CA,BR,2)
+ IF (NTRY.LE.NBTRY) GOTO 80
+C CALL HWWARN('HWHEWW',1,*999)
+ RETURN
+ ENDIF
+ PRW(5,IB)=XMASS(IB)
+ IDP(2*IB+1)=ID1
+ IDP(2*IB+2)=ID2
+ PLAB(5,2*IB+1)=RMASS(ID1)
+ PLAB(5,2*IB+2)=RMASS(ID2)
+ CALL HWDTWO(PRW(1,IB),PLAB(1,2*IB+1),PLAB(1,2*IB+2),
+ & PST,TWO,.TRUE.)
+ 90 CONTINUE
+ WEIGHT=FLUXW*W2BO*FJAC1*FJAC2*(0.5D0*PIFAC*GIMM)**2
+ CALL HWHEW1(6)
+ CALL HWHEW2(6,PCM(1,1),ZH,ZCH,ZD)
+ IF (IPRC.EQ.0) THEN
+ CALL HWHEW3(5,6,3,4,1,2,AMPWW)
+ TOTSIG=9.*AMPWW(1)+6.*(AMPWW(2)+AMPWW(3))+4.*AMPWW(4)
+ EVWGT=TOTSIG*WEIGHT*BR
+ ELSE
+ ID1=IDZOLT(IDPDG(IDP(3)))
+ ID2=IDZOLT(IDPDG(IDP(5)))
+ CALL HWHEW5(5,6,3,4,1,2,HELSUM,HELCTY,ID1,ID2)
+ EVWGT=HELCTY*WEIGHT*BR/(BRZED(ID1)*BRZED(ID2))
+ ENDIF
+ ENDIF
+ 999 END
+CDECK ID>, HWHHVY.
+*CMZ :- -18/05/99 14.55.44 by Kosuke Odagiri
+*-- Author : Bryan Webber
+C-----------------------------------------------------------------------
+ SUBROUTINE HWHHVY
+C-----------------------------------------------------------------------
+C QCD HEAVY FLAVOUR PRODUCTION: MEAN EVWGT = SIGMA IN NB
+C-----------------------------------------------------------------------
+ INCLUDE 'HERWIG61.INC'
+ DOUBLE PRECISION HWR,HWRUNI,HWUALF,EPS,RCS,Z1,Z2,ET,EJ,
+ & QM2,QPE,FACTR,S,T,U,ST,TU,US,TUS,UST,EN,RN,AF,ASTU,
+ & AUST,CF,CN,CS,CSTU,CSUT,CTSU,CTUS,HCS,UT,SU,GT,DIST,KK,KK2,
+ & YJ1INF,YJ1SUP,YJ2INF,YJ2SUP
+ INTEGER IQ1,IQ2,ID1,ID2
+ LOGICAL HQ1,HQ2
+ EXTERNAL HWR,HWRUNI,HWUALF
+ SAVE HCS,ASTU,AUST,CSTU,CSUT,CTSU,CTUS,S,T,TU,U,US
+ PARAMETER (EPS=1.D-9)
+ IF (GENEV) THEN
+ RCS=HCS*HWR()
+ ELSE
+ EVWGT=0.
+ CALL HWRPOW(ET,EJ)
+ KK = ET/PHEP(5,3)
+ KK2=KK**2
+ IF (KK.GE.ONE) RETURN
+ YJ1INF = MAX( YJMIN, LOG((ONE-SQRT(ONE-KK2))/KK) )
+ YJ1SUP = MIN( YJMAX, LOG((ONE+SQRT(ONE-KK2))/KK) )
+ IF (YJ1INF.GE.YJ1SUP) RETURN
+ Z1=EXP(HWRUNI(1,YJ1INF,YJ1SUP))
+ YJ2INF = MAX( YJMIN, -LOG(TWO/KK-ONE/Z1) )
+ YJ2SUP = MIN( YJMAX, LOG(TWO/KK-Z1) )
+ IF (YJ2INF.GE.YJ2SUP) RETURN
+ Z2=EXP(HWRUNI(2,YJ2INF,YJ2SUP))
+ XX(1)=HALF*(Z1+Z2)*KK
+ IF (XX(1).GE.ONE) RETURN
+ XX(2)=XX(1)/(Z1*Z2)
+ IF (XX(2).GE.ONE) RETURN
+ S=XX(1)*XX(2)*PHEP(5,3)**2
+ IQ1=MOD(IPROC,100)
+ QM2=RMASS(IQ1)**2
+ QPE=S-4.*QM2
+ IF (QPE.LE.ZERO) RETURN
+ COSTH=HALF*ET*(Z1-Z2)/SQRT(Z1*Z2*QPE)
+ IF (ABS(COSTH).GT.ONE) RETURN
+C---REDEFINE S, T, U AS P1.P2, -P1.P3, -P1.P4
+ S=HALF*S
+ T=-HALF*(1.+Z2/Z1)*(HALF*ET)**2
+ U=-S-T
+C---SET EMSCA TO HEAVY HARD PROCESS SCALE
+ EMSCA=SQRT(4.*S*T*U/(S*S+T*T+U*U))
+ FACTR = GEV2NB*.125*PIFAC*EJ*ET*(HWUALF(1,EMSCA)/S)**2
+ & *(YJ1SUP-YJ1INF)*(YJ2SUP-YJ2INF)
+ CALL HWSGEN(.FALSE.)
+C
+ ST=S/T
+ TU=T/U
+ UT=U/T
+ US=U/S
+ SU=S/U
+ TUS=US/ST
+ UST=ST/TU
+C
+ EN=CAFAC
+ RN=CFFAC/EN
+ AF=FACTR*RN
+ ASTU=AF*(1.-2.*UST+QM2/T)
+ AUST=AF*(1.-2.*TUS+QM2/S)
+ CF=FACTR/(2.*CFFAC)
+ CN=1./(EN*EN)
+C-----------------------------------------------------------------------
+C---Heavy flavour colour decomposition modifications below (KO)
+C-----------------------------------------------------------------------
+ CS=(TU+UT-CN/TUS)*(HALF-TUS+QM2/S-QM2**2/U/T/TWO)
+ CSTU=CF*CS/(ONE+TU**2)
+ CSUT=CF*CS/(ONE+UT**2)
+ CS=(SU+US-CN/UST)*(HALF-UST+QM2/T-QM2**2/U/S/TWO)
+ CTSU=-FACTR*CS/(ONE+SU**2)
+ CTUS=-FACTR*CS/(ONE+US**2)
+C-----------------------------------------------------------------------
+C CS=HALF/TU-QM2/T-HALF*(QM2/T)**2
+C CSTU=CF*(CS- US**2-QM2/S - CN*(CS+QM2*QM2/(S*T)))
+C CS=HALF*TU-QM2/U-HALF*(QM2/U)**2
+C CSUT=CF*(CS-1./ST**2-QM2/S - CN*(CS+QM2*QM2/(S*U)))
+C CS=HALF*US-QM2/S-HALF*(QM2/S)**2
+C CTSU=-FACTR*(CS-1./TU**2-QM2/T - CN*(CS+QM2*QM2/(S*T)))
+C CS=HALF/US-QM2/U-HALF*(QM2/U)**2
+C CTUS=-FACTR*(CS- ST**2-QM2/T - CN*(CS+QM2*QM2/(T*U)))
+C-----------------------------------------------------------------------
+ ENDIF
+C
+ HCS=0.
+ IQ2=IQ1+6
+ DO 6 ID1=1,13
+ IF (DISF(ID1,1).LT.EPS) GOTO 6
+ HQ1=ID1.EQ.IQ1.OR.ID1.EQ.IQ2
+ DO 5 ID2=1,13
+ IF (DISF(ID2,2).LT.EPS) GOTO 5
+ HQ2=ID2.EQ.IQ1.OR.ID2.EQ.IQ2
+ DIST=DISF(ID1,1)*DISF(ID2,2)
+ IF (HQ1.OR.HQ2) THEN
+C---PROCESSES INVOLVING HEAVY CONSTITUENT
+C N.B. NEGLECT CASE THAT BOTH ARE HEAVY
+ IF (HQ1.AND.HQ2) GOTO 5
+ IF (ID1.LT.7) THEN
+C---QUARK FIRST
+ IF (ID2.LT.7) THEN
+ HCS=HCS+ASTU*DIST
+ IF (GENEV.AND.HCS.GT.RCS) CALL HWHQCP(ID1,ID2,3421, 3,*9)
+ ELSEIF (ID2.NE.13) THEN
+ HCS=HCS+ASTU*DIST
+ IF (GENEV.AND.HCS.GT.RCS) CALL HWHQCP(ID1,ID2,3142, 9,*9)
+ ELSE
+ HCS=HCS+CTSU*DIST
+ IF (GENEV.AND.HCS.GT.RCS) CALL HWHQCP(ID1,ID2,3142,10,*9)
+ HCS=HCS+CTUS*DIST
+ IF (GENEV.AND.HCS.GT.RCS) CALL HWHQCP(ID1,ID2,3421,11,*9)
+ ENDIF
+ ELSEIF (ID1.NE.13) THEN
+C---QBAR FIRST
+ IF (ID2.LT.7) THEN
+ HCS=HCS+ASTU*DIST
+ IF (GENEV.AND.HCS.GT.RCS) CALL HWHQCP(ID1,ID2,2413,17,*9)
+ ELSEIF (ID2.NE.13) THEN
+ HCS=HCS+ASTU*DIST
+ IF (GENEV.AND.HCS.GT.RCS) CALL HWHQCP(ID1,ID2,4312,20,*9)
+ ELSE
+ HCS=HCS+CTSU*DIST
+ IF (GENEV.AND.HCS.GT.RCS) CALL HWHQCP(ID1,ID2,2413,21,*9)
+ HCS=HCS+CTUS*DIST
+ IF (GENEV.AND.HCS.GT.RCS) CALL HWHQCP(ID1,ID2,4312,22,*9)
+ ENDIF
+ ELSE
+C---GLUON FIRST
+ IF (ID2.LT.7) THEN
+ HCS=HCS+CTSU*DIST
+ IF (GENEV.AND.HCS.GT.RCS) CALL HWHQCP(ID1,ID2,2413,23,*9)
+ HCS=HCS+CTUS*DIST
+ IF (GENEV.AND.HCS.GT.RCS) CALL HWHQCP(ID1,ID2,3421,24,*9)
+ ELSEIF (ID2.LT.13) THEN
+ HCS=HCS+CTSU*DIST
+ IF (GENEV.AND.HCS.GT.RCS) CALL HWHQCP(ID1,ID2,3142,25,*9)
+ HCS=HCS+CTUS*DIST
+ IF (GENEV.AND.HCS.GT.RCS) CALL HWHQCP(ID1,ID2,4312,26,*9)
+ ENDIF
+ ENDIF
+ ELSEIF (ID2.NE.13.AND.ID2.EQ.ID1+6) THEN
+C---LIGHT Q-QBAR ANNIHILATION
+ HCS=HCS+AUST*DIST
+ IF (GENEV.AND.HCS.GT.RCS) CALL HWHQCP(IQ1,IQ2,2413, 4,*9)
+ ELSEIF (ID1.NE.13.AND.ID1.EQ.ID2+6) THEN
+C---LIGHT QBAR-Q ANNIHILATION
+ HCS=HCS+AUST*DIST
+ IF (GENEV.AND.HCS.GT.RCS) CALL HWHQCP(IQ2,IQ1,3142,12,*9)
+ ELSEIF (ID1.EQ.13.AND.ID2.EQ.13) THEN
+C---GLUON FUSION
+ HCS=HCS+CSTU*DIST
+ IF (GENEV.AND.HCS.GT.RCS) CALL HWHQCP(IQ1,IQ2,2413,27,*9)
+ HCS=HCS+CSUT*DIST
+ IF (GENEV.AND.HCS.GT.RCS) CALL HWHQCP(IQ1,IQ2,4123,28,*9)
+ ENDIF
+ 5 CONTINUE
+ 6 CONTINUE
+ EVWGT=HCS
+ RETURN
+C---GENERATE EVENT
+ 9 IDN(1)=ID1
+ IDN(2)=ID2
+ IDCMF=15
+ CALL HWETWO
+ IF (AZSPIN) THEN
+C Calculate coefficients for constructing spin density matrices
+ IF (IHPRO.EQ.7 .OR.IHPRO.EQ.8 .OR.
+ & IHPRO.EQ.15.OR.IHPRO.EQ.16) THEN
+C qqbar-->gg or qbarq-->gg
+ UT=1./TU
+ GCOEF(1)=UT+TU
+ GCOEF(2)=-2.
+ GCOEF(3)=0.
+ GCOEF(4)=0.
+ GCOEF(5)=GCOEF(1)
+ GCOEF(6)=UT-TU
+ GCOEF(7)=-GCOEF(6)
+ ELSEIF (IHPRO.EQ.10.OR.IHPRO.EQ.11.OR.
+ & IHPRO.EQ.21.OR.IHPRO.EQ.22.OR.
+ & IHPRO.EQ.23.OR.IHPRO.EQ.24.OR.
+ & IHPRO.EQ.25.OR.IHPRO.EQ.26) THEN
+C qg-->qg or qbarg-->qbarg or gq-->gq or gqbar-->gqbar
+ SU=1./US
+ GCOEF(1)=-(SU+US)
+ GCOEF(2)=0.
+ GCOEF(3)=2.
+ GCOEF(4)=0.
+ GCOEF(5)=SU-US
+ GCOEF(6)=GCOEF(1)
+ GCOEF(7)=-GCOEF(5)
+ ELSEIF (IHPRO.EQ.27.OR.IHPRO.EQ.28) THEN
+C gg-->qqbar
+ UT=1./TU
+ GCOEF(1)=TU+UT
+ GCOEF(2)=-2.
+ GCOEF(3)=0.
+ GCOEF(4)=0.
+ GCOEF(5)=GCOEF(1)
+ GCOEF(6)=TU-UT
+ GCOEF(7)=-GCOEF(6)
+ ELSEIF (IHPRO.EQ.29.OR.IHPRO.EQ.30.OR.
+ & IHPRO.EQ.31) THEN
+C gg-->gg
+ GT=S*S+T*T+U*U
+ GCOEF(2)=2.*U*U*T*T
+ GCOEF(3)=2.*S*S*U*U
+ GCOEF(4)=2.*S*S*T*T
+ GCOEF(1)=GT*GT-GCOEF(2)-GCOEF(3)-GCOEF(4)
+ GCOEF(5)=GT*(GT-2.*S*S)-GCOEF(2)
+ GCOEF(6)=GT*(GT-2.*T*T)-GCOEF(3)
+ GCOEF(7)=GT*(GT-2.*U*U)-GCOEF(4)
+ ELSE
+ CALL HWVZRO(7,GCOEF)
+ ENDIF
+ ENDIF
+ 999 END
+CDECK ID>, HWHIG1.
+*CMZ :- -23/08/94 13.22.29 by Mike Seymour
+*-- Author : Ulrich Baur & Nigel Glover, adapted by Ian Knowles
+C-----------------------------------------------------------------------
+ FUNCTION HWHIG1(S,T,U,EH2,EQ2,I,J,K,I1,J1,K1)
+C-----------------------------------------------------------------------
+C Basic matrix elements for Higgs + jet production; used in HWHIGA
+C-----------------------------------------------------------------------
+ IMPLICIT NONE
+ DOUBLE COMPLEX HWHIG1,HWHIG2,HWHIG5,BI(4),CI(7),DI(3)
+ DOUBLE PRECISION S,T,U,EH2,EQ2,S1,T1,U1,ONE,TWO,FOUR,HALF
+ INTEGER I,J,K,I1,J1,K1
+ COMMON/CINTS/BI,CI,DI
+ PARAMETER (ONE =1.D0, TWO =2.D0, FOUR =4.D0, HALF =0.5D0)
+C-----------------------------------------------------------------------
+C +++ helicity amplitude for: g+g --> g+H
+C-----------------------------------------------------------------------
+ S1=S-EH2
+ T1=T-EH2
+ U1=U-EH2
+ HWHIG1=EQ2*FOUR*DSQRT(TWO*S*T*U)*(
+ & -FOUR*(ONE/(U*T)+ONE/(U*U1)+ONE/(T*T1))
+ & -FOUR*((TWO*S+T)*BI(K)/U1**2+(TWO*S+U)*BI(J)/T1**2)/S
+ & -(S-FOUR*EQ2)*(S1*CI(I1)+(U-S)*CI(J1)+(T-S)*CI(K1))/(S*T*U)
+ & -8.D0*EQ2*(CI(J1)/(T*T1)+CI(K1)/(U*U1))
+ & +HALF*(S-FOUR*EQ2)*(S*T*DI(K)+U*S*DI(J)-U*T*DI(I))/(S*T*U)
+ & +FOUR*EQ2*DI(I)/S
+ & -TWO*(U*CI(K)+T*CI(J)+U1*CI(K1)+T1*CI(J1)-U*T*DI(I))/S**2 )
+ RETURN
+C-----------------------------------------------------------------------
+ ENTRY HWHIG2(S,T,U,EH2,EQ2,I,J,K,I1,J1,K1)
+C-----------------------------------------------------------------------
+C ++- helicity amplitude for: g+g --> g+H
+C-----------------------------------------------------------------------
+ S1=S-EH2
+ T1=T-EH2
+ U1=U-EH2
+ HWHIG2=EQ2*FOUR*DSQRT(TWO*S*T*U)*(FOUR*EH2
+ & +(EH2-FOUR*EQ2)*(S1*CI(4)+T1*CI(5)+U1*CI(6))
+ & -HALF*(EH2-FOUR*EQ2)*(S*T*DI(3)+U*S*DI(2)+U*T*DI(1)) )/(S*T*U)
+ RETURN
+C-----------------------------------------------------------------------
+ ENTRY HWHIG5(S,T,U,EH2,EQ2,I,J,K,I1,J1,K1)
+C-----------------------------------------------------------------------
+C Amplitude for: q+qbar --> g+H
+C-----------------------------------------------------------------------
+ HWHIG5=DCMPLX(TWO+TWO*S/(S-EH2))*BI(I)+DCMPLX(FOUR*EQ2-U-T)*CI(K)
+ RETURN
+ END
+CDECK ID>, HWHIGA.
+*CMZ :- -23/08/94 13.22.29 by Mike Seymour
+*-- Author : Ulrich Baur & Nigel Glover, adapted by Ian Knowles
+C-----------------------------------------------------------------------
+ SUBROUTINE HWHIGA(S,T,U,EMH2,WTQQ,WTQG,WTGQ,WTGG)
+C-----------------------------------------------------------------------
+C Gives amplitudes squared for q-qbar, q(bar)-g and gg -> Higgs +jet
+C IAPHIG (set in HWIGIN)=0: zero mass approximation =1: exact result
+C =2: infinite mass limit.
+C Only top loop included. A factor (alpha_s**3*alpha_W) is extracted
+C-----------------------------------------------------------------------
+ INCLUDE 'HERWIG61.INC'
+ DOUBLE COMPLEX HWHIGB,HWHIGC,HWHIGD,HWHIG5,HWHIG1,HWHIG2,BI(4),
+ & CI(7),DI(3),EPSI,TAMP(7)
+ DOUBLE PRECISION S,T,U,EMH2,WTQQ,WTQG,WTGQ,WTGG,EMW2,RNGLU,RNQRK,
+ & FLUXGG,FLUXGQ,FLUXQQ,EMQ2,TAMPI(7),TAMPR(7)
+ INTEGER I
+ LOGICAL NOMASS
+ EXTERNAL HWHIGB,HWHIGC,HWHIGD,HWHIG5,HWHIG1,HWHIG2
+ COMMON/SMALL/EPSI
+ COMMON/CINTS/BI,CI,DI
+ EPSI=CMPLX(ZERO,-1.D-10)
+ EMW2=RMASS(198)**2
+C Spin and colour flux factors plus enhancement factor
+ RNGLU=1./FLOAT(NCOLO**2-1)
+ RNQRK=1./FLOAT(NCOLO)
+ FLUXGG=.25*RNGLU**2*ENHANC(6)**2
+ FLUXGQ=.25*RNGLU*RNQRK*ENHANC(6)**2
+ FLUXQQ=.25*RNQRK**2*ENHANC(6)**2
+ IF (IAPHIG.EQ.2) THEN
+C Infinite mass limit in loops
+ WTGG=2./3.*FLOAT(NCOLO*(NCOLO**2-1))
+ & *(EMH2**4+S**4+T**4+U**4)/(S*T*U*EMW2)*FLUXGG
+ WTQQ= 16./9.*(U**2+T**2)/(S*EMW2)*FLUXQQ
+ WTQG=-16./9.*(U**2+S**2)/(T*EMW2)*FLUXGQ
+ WTGQ=-16./9.*(S**2+T**2)/(U*EMW2)*FLUXGQ
+ RETURN
+ ELSEIF (IAPHIG.EQ.1) THEN
+C Exact result for loops
+ NOMASS=.FALSE.
+ ELSEIF (IAPHIG.EQ.0) THEN
+C Small mass approximation in loops
+ NOMASS=.TRUE.
+ ELSE
+ CALL HWWARN('HWHIGA',500,*999)
+ ENDIF
+C Include only top quark contribution
+ EMQ2=RMASS(6)**2
+ BI(1)=HWHIGB(NOMASS,S,ZERO,ZERO,EMQ2)
+ BI(2)=HWHIGB(NOMASS,T,ZERO,ZERO,EMQ2)
+ BI(3)=HWHIGB(NOMASS,U,ZERO,ZERO,EMQ2)
+ BI(4)=HWHIGB(NOMASS,EMH2,ZERO,ZERO,EMQ2)
+ BI(1)=BI(1)-BI(4)
+ BI(2)=BI(2)-BI(4)
+ BI(3)=BI(3)-BI(4)
+ CI(1)=HWHIGC(NOMASS,S,ZERO,ZERO,EMQ2)
+ CI(2)=HWHIGC(NOMASS,T,ZERO,ZERO,EMQ2)
+ CI(3)=HWHIGC(NOMASS,U,ZERO,ZERO,EMQ2)
+ CI(7)=HWHIGC(NOMASS,EMH2,ZERO,ZERO,EMQ2)
+ CI(4)=(S*CI(1)-EMH2*CI(7))/(S-EMH2)
+ CI(5)=(T*CI(2)-EMH2*CI(7))/(T-EMH2)
+ CI(6)=(U*CI(3)-EMH2*CI(7))/(U-EMH2)
+ DI(1)=HWHIGD(NOMASS,U,T,EMH2,EMQ2)
+ DI(2)=HWHIGD(NOMASS,S,U,EMH2,EMQ2)
+ DI(3)=HWHIGD(NOMASS,S,T,EMH2,EMQ2)
+C Compute complex amplitudes
+ TAMP(1)=HWHIG1(S,T,U,EMH2,EMQ2,1,2,3,4,5,6)
+ TAMP(2)=HWHIG2(S,T,U,EMH2,EMQ2,1,2,3,0,0,0)
+ TAMP(3)=HWHIG1(T,S,U,EMH2,EMQ2,2,1,3,5,4,6)
+ TAMP(4)=HWHIG1(U,T,S,EMH2,EMQ2,3,2,1,6,5,4)
+ TAMP(5)=HWHIG5(S,T,U,EMH2,EMQ2,1,0,4,0,0,0)
+ TAMP(6)=HWHIG5(T,S,U,EMH2,EMQ2,2,0,5,0,0,0)
+ TAMP(7)=HWHIG5(U,T,S,EMH2,EMQ2,3,0,6,0,0,0)
+ DO 20 I=1,7
+ TAMPI(I)= DBLE(TAMP(I))
+ 20 TAMPR(I)=-IMAG(TAMP(I))
+C Square and add prefactors
+ WTGG=0.03125*FLOAT(NCOLO*(NCOLO**2-1))
+ & *(TAMPR(1)**2+TAMPI(1)**2+TAMPR(2)**2+TAMPI(2)**2
+ & +TAMPR(3)**2+TAMPI(3)**2+TAMPR(4)**2+TAMPI(4)**2)*FLUXGG
+ WTQQ= 16.*(U**2+T**2)/(U+T)**2*EMQ2**2/(S*EMW2)
+ & *(TAMPR(5)**2+TAMPI(5)**2)*FLUXQQ
+ WTQG=-16.*(U**2+S**2)/(U+S)**2*EMQ2**2/(T*EMW2)
+ & *(TAMPR(6)**2+TAMPI(6)**2)*FLUXGQ
+ WTGQ=-16.*(S**2+T**2)/(S+T)**2*EMQ2**2/(U*EMW2)
+ & *(TAMPR(7)**2+TAMPI(7)**2)*FLUXGQ
+ 999 RETURN
+ END
+CDECK ID>, HWHIGB.
+*CMZ :- -23/08/94 13.22.29 by Mike Seymour
+*-- Author : Ulrich Baur & Nigel Glover, adapted by Ian Knowles
+C-----------------------------------------------------------------------
+ FUNCTION HWHIGB(NOMASS,S,T,EH2,EQ2)
+C-----------------------------------------------------------------------
+C One loop scalar integrals, used in HWHIGJ.
+C If NOMASS=.TRUE. use a small mass approx. for particle in loop.
+C-----------------------------------------------------------------------
+ INCLUDE 'HERWIG61.INC'
+ DOUBLE COMPLEX HWHIGB,HWHIGC,HWHIGD,HWUCI2,HWULI2,EPSI,PII,Z1,Z2
+ DOUBLE PRECISION S,T,EQ2,EH2,RAT,COSH,DLS,DLT,DLM,RZ12,DL1,DL2,
+ & ST,ROOT,XP,XM
+ LOGICAL NOMASS
+ EXTERNAL HWULI2,HWUCI2
+ COMMON/SMALL/EPSI
+C-----------------------------------------------------------------------
+C B_0(2p1.p2=S;mq,mq)
+C-----------------------------------------------------------------------
+ PII=CMPLX(ZERO,PIFAC)
+ IF (NOMASS) THEN
+ RAT=DABS(S/EQ2)
+ HWHIGB=-DLOG(RAT)+TWO
+ IF (S.GT.ZERO) HWHIGB=HWHIGB+PII
+ ELSE
+ RAT=S/(FOUR*EQ2)
+ IF (S.LT.ZERO) THEN
+ HWHIGB=TWO-TWO*DSQRT(ONE-ONE/RAT)
+ & *DLOG(DSQRT(-RAT)+DSQRT(ONE-RAT))
+ ELSEIF (S.GT.ZERO.AND.RAT.LT.ONE) THEN
+ HWHIGB=TWO-TWO*DSQRT(ONE/RAT-ONE)*DASIN(DSQRT(RAT))
+ ELSEIF (RAT.GT.ONE) THEN
+ HWHIGB=TWO-DSQRT(ONE-ONE/RAT)
+ & *(TWO*DLOG(DSQRT(RAT)+DSQRT(RAT-ONE))-PII)
+ ENDIF
+ ENDIF
+ RETURN
+C-----------------------------------------------------------------------
+ ENTRY HWHIGC(NOMASS,S,T,EH2,EQ2)
+C-----------------------------------------------------------------------
+C C_0(p{1,2}^2=0,2p1.p2=S;mq,mq,mq)
+C-----------------------------------------------------------------------
+ PII=CMPLX(ZERO,PIFAC)
+ IF (NOMASS) THEN
+ RAT=DABS(S/EQ2)
+ HWHIGC=HALF*DLOG(RAT)**2
+ IF (S.GT.ZERO) HWHIGC=HWHIGC-HALF*PIFAC**2-PII*DLOG(RAT)
+ HWHIGC=HWHIGC/S
+ ELSE
+ RAT=S/(FOUR*EQ2)
+ IF (S.LT.ZERO) THEN
+ HWHIGC=TWO*DLOG(DSQRT(-RAT)+DSQRT(ONE-RAT))**2/S
+ ELSEIF (S.GT.ZERO.AND.RAT.LT.ONE) THEN
+ HWHIGC=-TWO*(DASIN(DSQRT(RAT)))**2/S
+ ELSEIF (RAT.GT.ONE) THEN
+ COSH=DLOG(DSQRT(RAT)+DSQRT(RAT-ONE))
+ HWHIGC=TWO*(COSH**2-PIFAC**2/FOUR-PII*COSH)/S
+ ENDIF
+ ENDIF
+ RETURN
+C-----------------------------------------------------------------------
+ ENTRY HWHIGD(NOMASS,S,T,EH2,EQ2)
+C-----------------------------------------------------------------------
+C D_0(p{1,2,3}^2=0,p4^2=EH2,2p1.p2=S,2p2.p3=T;mq,mq,mq,mq)
+C-----------------------------------------------------------------------
+ PII=CMPLX(ZERO,PIFAC)
+ IF (NOMASS) THEN
+ DLS=DLOG(DABS(S/EQ2))
+ DLT=DLOG(DABS(T/EQ2))
+ DLM=DLOG(DABS(EH2/EQ2))
+ IF (S.GE.ZERO.AND.T.LE.ZERO) THEN
+ DL1=DLOG((EH2-T)/S)
+ Z1=T/(T-EH2)
+ Z2=(S-EH2)/S
+ HWHIGD=DLS**2+DLT**2-DLM**2+DL1**2
+ & +TWO*(DLOG(S/(EH2-T))*DLOG(-T/S)+HWULI2(Z1)-HWULI2(Z2)
+ & +PII*DLOG(EH2/(EH2-T)))
+ ELSEIF (S.LT.ZERO.AND.T.LT.ZERO) THEN
+ Z1=(S-EH2)/S
+ Z2=(T-EH2)/T
+ RZ12=ONE/(Z1*Z2)
+ DL1=DLOG((T-EH2)/(S-EH2))
+ DL2=DLOG(RZ12)
+ HWHIGD=DLS**2+DLT**2-DLM**2+TWO*PIFAC**2/THREE
+ & +TWO*DLOG(S/(T-EH2))*DLOG(ONE/DBLE(Z2))
+ & +TWO*DLOG(T/(S-EH2))*DLOG(ONE/DBLE(Z1))
+ & -DL1**2-DL2**2-TWO*(HWULI2(Z1)+HWULI2(Z2))
+ & +TWO*PII*DLOG(RZ12**2*EH2/EQ2)
+ ENDIF
+ HWHIGD=HWHIGD/(S*T)
+ ELSE
+ ST=S*T
+ ROOT=DSQRT(ST**2-FOUR*ST*EQ2*(S+T-EH2))
+ XP=HALF*(ST+ROOT)/ST
+ XM=1-XP
+ HWHIGD=TWO/ROOT*(-HWUCI2(EQ2,S,XP)-HWUCI2(EQ2,T,XP)
+ & +HWUCI2(EQ2,EH2,XP)+DLOG(-XM/XP)
+ & *(LOG(EQ2+EPSI)-LOG(EQ2+EPSI-S*XP*XM)
+ & +LOG(EQ2+EPSI-EH2*XP*XM)-LOG(EQ2+EPSI-T*XP*XM)))
+ ENDIF
+ RETURN
+ END
+CDECK ID>, HWHIGJ.
+*CMZ :- -23/08/94 13.22.29 by Mike Seymour
+*-- Author : Ian Knowles
+C-----------------------------------------------------------------------
+ SUBROUTINE HWHIGJ
+C-----------------------------------------------------------------------
+C QCD Higgs plus jet production; mean EVWGT = Sigma in nb*Higgs B.R.
+C Adapted from the program of U. Baur and E.W.N. Glover
+C See: Nucl. Phys. B339 (1990) 38
+C-----------------------------------------------------------------------
+ INCLUDE 'HERWIG61.INC'
+ DOUBLE PRECISION HWR,HWRUNI,HWUALF,HWUAEM,EPS,RCS,EMH,EMHWT,
+ & EMHTMP,BR,CV,CA,EMH2,ET,EJ,PT,EMT,EMAX,YMAX,YHINF,YHSUP,EXYH,
+ & YMIN,YJINF,YJSUP,EXYJ,S,T,U,FACT,AMPQQ,AMPQG,AMPGQ,AMPGG,HCS,
+ & FACTR
+ INTEGER I,IDEC,ID1,ID2
+ EXTERNAL HWR,HWRUNI,HWUALF,HWUAEM
+ SAVE HCS,AMPGG,AMPGQ,AMPQG,AMPQQ,EMH,FACT
+ PARAMETER (EPS=1.D-9)
+ IF (GENEV) THEN
+ RCS=HCS*HWR()
+ ELSE
+ EVWGT=0.
+C Select a Higgs mass
+ CALL HWHIGM(EMH,EMHWT)
+ IF (EMH.LE.ZERO .OR. EMH.GE.PHEP(5,3)) RETURN
+C Store branching ratio for specified Higgs deacy channel
+ IDEC=MOD(IPROC,100)
+ BR=1.
+ IF (IDEC.EQ.0) THEN
+ BR=0.
+ DO 10 I=1,6
+ 10 BR=BR+BRHIG(I)
+ ELSEIF (IDEC.EQ.10) THEN
+ CALL HWDBOZ(198,ID1,ID2,CV,CA,BR,1)
+ CALL HWDBOZ(199,ID1,ID2,CV,CA,BR,1)
+ BR=BR*BRHIG(IDEC)
+ ELSEIF (IDEC.EQ.11) THEN
+ CALL HWDBOZ(200,ID1,ID2,CV,CA,BR,1)
+ CALL HWDBOZ(200,ID1,ID2,CV,CA,BR,1)
+ BR=BR*BRHIG(IDEC)
+ ELSEIF (IDEC.LE.12) THEN
+ BR=BRHIG(IDEC)
+ ENDIF
+C Select subprocess kinematics
+ EMH2=EMH**2
+ CALL HWRPOW(ET,EJ)
+ PT=.5*ET
+ EMT=SQRT(PT**2+EMH2)
+ EMAX=0.5*(PHEP(5,3)+EMH2/PHEP(5,3))
+ IF (EMAX.LE.EMT) RETURN
+ YMAX=LOG((EMAX+SQRT(EMAX**2-EMT**2))/EMT)
+ YHINF=MAX(YJMIN,-YMAX)
+ YHSUP=MIN(YJMAX, YMAX)
+ IF (YHSUP.LE.YHINF) RETURN
+ EXYH=EXP(HWRUNI(1,YHINF,YHSUP))
+ YMIN=LOG(PT/(PHEP(5,3)-EMT/EXYH))
+ YMAX=LOG((PHEP(5,3)-EMT*EXYH)/PT)
+ YJINF=MAX(YJMIN,YMIN)
+ YJSUP=MIN(YJMAX,YMAX)
+ IF (YJSUP.LE.YJINF) RETURN
+ EXYJ=EXP(HWRUNI(2,YJINF,YJSUP))
+ XX(1)=(EMT*EXYH+PT*EXYJ)/PHEP(5,3)
+ XX(2)=(EMT/EXYH+PT/EXYJ)/PHEP(5,3)
+ S=XX(1)*XX(2)*PHEP(5,3)**2
+ T=EMH2-XX(1)*EMT*PHEP(5,3)/EXYH
+ U=EMH2-S-T
+ COSTH=(S+2.*T-EMH2)/(S-EMH2)
+C Set subprocess scale
+ EMSCA=EMT
+ CALL HWSGEN(.FALSE.)
+ FACT=GEV2NB*PT*EJ*(YHSUP-YHINF)*(YJSUP-YJINF)*BR*EMHWT
+ & *HWUALF(1,EMSCA)**3*HWUAEM(EMH2)/(SWEIN*16*PIFAC*S**2)
+ CALL HWHIGA(S,T,U,EMH2,AMPQQ,AMPQG,AMPGQ,AMPGG)
+ ENDIF
+ HCS=0.
+ DO 30 ID1=1,13
+ IF (DISF(ID1,1).LT.EPS) GOTO 30
+ FACTR=FACT*DISF(ID1,1)
+ IF (ID1.LT.7) THEN
+C Quark first:
+ ID2=ID1+6
+ HCS=HCS+FACTR*DISF(ID2,2)*AMPQQ
+ IF (GENEV.AND.HCS.GT.RCS) CALL HWHQCP(13 ,201,2314,81,*99)
+ ID2=13
+ HCS=HCS+FACTR*DISF(ID2,2)*AMPQG
+ IF (GENEV.AND.HCS.GT.RCS) CALL HWHQCP(ID1,201,3124,82,*99)
+ ELSEIF (ID1.LT.13) THEN
+C Antiquark first:
+ ID2=ID1-6
+ HCS=HCS+FACTR*DISF(ID2,2)*AMPQQ
+ IF (GENEV.AND.HCS.GT.RCS) CALL HWHQCP(13 ,201,3124,83,*99)
+ ID2=13
+ HCS=HCS+FACTR*DISF(ID2,2)*AMPQG
+ IF (GENEV.AND.HCS.GT.RCS) CALL HWHQCP(ID1,201,2314,84,*99)
+ ELSE
+C Gluon first:
+ DO 20 ID2=1,12
+ IF (DISF(ID2,2).LT.EPS) GOTO 20
+ IF (ID2.LT.7) THEN
+ HCS=HCS+FACTR*DISF(ID2,2)*AMPGQ
+ IF (GENEV.AND.HCS.GT.RCS) CALL HWHQCP(ID2,201,2314,85,*99)
+ ELSE
+ HCS=HCS+FACTR*DISF(ID2,2)*AMPGQ
+ IF (GENEV.AND.HCS.GT.RCS) CALL HWHQCP(ID2,201,3124,86,*99)
+ ENDIF
+ 20 CONTINUE
+ HCS=HCS+FACTR*DISF(13,2)*AMPGG
+ IF (GENEV.AND.HCS.GT.RCS) CALL HWHQCP(13 ,201,2314,87,*99)
+ ENDIF
+ 30 CONTINUE
+ EVWGT=HCS
+ RETURN
+C Generate event
+ 99 IDN(1)=ID1
+ IDN(2)=ID2
+ IDCMF=15
+C Trick HWETWO into using off-shell Higgs mass
+ EMHTMP=RMASS(IDN(4))
+ RMASS(IDN(4))=EMH
+ CALL HWETWO
+ RMASS(IDN(4))=EMHTMP
+ 999 END
+CDECK ID>, HWHIGM.
+*CMZ :- -02/05/91 11.17.14 by Federico Carminati
+*-- Author : Mike Seymour
+C-----------------------------------------------------------------------
+ SUBROUTINE HWHIGM(EM,WEIGHT)
+C-----------------------------------------------------------------------
+C CHOOSE HIGGS MASS:
+C IF (IOPHIG.EQ.0.OR.IOPHIG.EQ.2) THEN
+C CHOOSE HIGGS MASS ACCORDING TO
+C EM**4 / (EM**2-EMH**2)**2 + (GAMH*EMH)**2
+C ELSE
+C CHOOSE HIGGS MASS ACCORDING TO
+C EMH * GAMH / (EM**2-EMH**2)**2 + (GAMH*EMH)**2
+C ENDIF
+C IF (IOPHIG.EQ.0.OR.IOPHIG.EQ.1) THEN
+C SUPPLY WEIGHT FACTOR TO YIELD
+C EM * GAM(EM)/ (EM**2-EMH**2)**2 + (GAM(EM)*EM)**2
+C ELSE
+C SUPPLY WEIGHT FACTOR TO YIELD
+C EM*(EMH/EM)**4 * GAM(EM)
+C / (EM**2-EMH**2)**2 + (GAM(EM)*EMH**2/EM)**2
+C AS SUGGESTED IN M.H.SEYMOUR, PHYS.LETT.B354(1995)409.
+C ENDIF
+C-----------------------------------------------------------------------
+ INCLUDE 'HERWIG61.INC'
+ DOUBLE PRECISION HWRUNI,EM,WEIGHT,EMH,DIF,FUN,THETA,T,EMHLST,W0,
+ & W1,EMM,GAMEM,T0,TMIN,TMAX,THEMIN,THEMAX,ZMIN,ZMAX,Z,F,GAMOFS
+ INTEGER I
+ EXTERNAL HWRUNI
+ SAVE EMHLST,GAMEM,T0,TMIN,TMAX,THEMIN,THEMAX,ZMIN,ZMAX,W0,W1
+ EQUIVALENCE (EMH,RMASS(201))
+ DATA EMHLST/0D0/
+C---SET UP INTEGRAND AND INDEFINITE INTEGRAL OF DISTRIBUTION
+C THETA=ATAN((EM**2-EMH**2)/(GAMH*EMH)); T=TAN(THETA); T0=EMH/GAMH
+ DIF(T,T0)=(T+T0)**2
+ FUN(THETA,T,T0)=T + (T0*T0-1)*THETA + T0*LOG(1+T*T)
+C---SET UP CONSTANTS
+ IF (EMH.NE.EMHLST .OR. FSTWGT) THEN
+ EMHLST=EMH
+ GAMEM=GAMH*EMH
+ T0=EMH/GAMH
+ TMIN=(MAX(ONE*1E-10,EMH-GAMMAX*GAMH))**2/GAMEM-T0
+ TMAX=( EMH+GAMMAX*GAMH )**2/GAMEM-T0
+ THEMIN=ATAN(TMIN)
+ THEMAX=ATAN(TMAX)
+ ZMIN=FUN(THEMIN,TMIN,T0)
+ ZMAX=FUN(THEMAX,TMAX,T0)
+ W0=(ZMAX-ZMIN) / PIFAC * GAMEM
+ W1=(THEMAX-THEMIN) / PIFAC
+ ENDIF
+C---CHOOSE HIGGS MASS
+ IF (IOPHIG.EQ.0.OR.IOPHIG.EQ.2) THEN
+ 1 EM=0
+ WEIGHT=0
+ Z=HWRUNI(1,ZMIN,ZMAX)
+C---SOLVE FUN(THETA,TAN(THETA))=Z BY NEWTON'S METHOD
+ THETA=MAX(THEMIN, MIN(THEMAX, Z/T0**2 ))
+ I=1
+ F=0
+ 10 IF (I.LE.20 .AND. ABS(1-F/Z).GT.1E-4) THEN
+ I=I+1
+ IF (2*ABS(THETA).GT.PIFAC) CALL HWWARN('HWHIGM',51,*999)
+ T=TAN(THETA)
+ F=FUN(THETA,T,T0)
+ THETA=THETA-(F-Z)/DIF(T,T0)
+ GOTO 10
+ ENDIF
+ IF (I.GT.20) CALL HWWARN('HWHIGM',1,*999)
+ ELSE
+ THETA=HWRUNI(0,THEMIN,THEMAX)
+ ENDIF
+ EM=SQRT(GAMEM*(T0+TAN(THETA)))
+C---NOW CALCULATE WEIGHT FACTOR FOR NON-CONSTANT HIGGS WIDTH
+ GAMOFS=EM
+ CALL HWDHIG(GAMOFS)
+ IF (IOPHIG.EQ.0) THEN
+ WEIGHT=W0*GAMOFS*EM /EM**4 *((EM**2-EMH**2)**2 + GAMEM**2)
+ & /((EM**2-EMH**2)**2 +(GAMOFS*EM)**2)
+ ELSEIF (IOPHIG.EQ.1) THEN
+ WEIGHT=W1*GAMOFS*EM /GAMEM *((EM**2-EMH**2)**2 + GAMEM**2)
+ & /((EM**2-EMH**2)**2 +(GAMOFS*EM)**2)
+ ELSEIF (IOPHIG.EQ.2) THEN
+ EMM=EM*(EMH/EM)**4
+ WEIGHT=W0*GAMOFS*EMM/EM**4 *((EM**2-EMH**2)**2 + GAMEM**2)
+ & /((EM**2-EMH**2)**2 +(GAMOFS*EMM)**2)
+ ELSEIF (IOPHIG.EQ.3) THEN
+ EMM=EM*(EMH/EM)**4
+ WEIGHT=W1*GAMOFS*EMM/GAMEM *((EM**2-EMH**2)**2 + GAMEM**2)
+ & /((EM**2-EMH**2)**2 +(GAMOFS*EMM)**2)
+ ELSE
+ CALL HWWARN('HWHIGM',500,*999)
+ ENDIF
+ 999 END
+CDECK ID>, HWHIGS.
+*CMZ :- -26/04/91 11.11.55 by Bryan Webber
+*-- Author : Mike Seymour
+C-----------------------------------------------------------------------
+ SUBROUTINE HWHIGS
+C-----------------------------------------------------------------------
+C HIGGS PRODUCTION VIA GLUON OR QUARK FUSION
+C MEAN EVWGT = HIGGS PRODN C-S * BRANCHING FRACTION IN NB
+C-----------------------------------------------------------------------
+ INCLUDE 'HERWIG61.INC'
+ DOUBLE PRECISION HWUALF,HWHIGT,HWR,HWUSQR,HWUAEM,BRHIGQ,EMH,
+ & CSFAC(13),EVSUM(13),EMFAC,CV,CA,BR,RWGT,E1,E2,EMQ,GFACTR
+ INTEGER IDEC,I,J,ID1,ID2
+ EXTERNAL HWUALF,HWHIGT,HWR,HWUSQR,HWUAEM
+ SAVE CSFAC,BR,EVSUM
+ IF (GENEV) THEN
+ RWGT=HWR()*EVSUM(13)
+ IDN(1)=1
+ DO 10 I=1,12
+ 10 IF (RWGT.GT.EVSUM(I)) IDN(1)=I+1
+ IDN(2)=13
+ IF (IDN(1).LE.12) IDN(2)=IDN(1)-6
+ IF (IDN(1).LE. 6) IDN(2)=IDN(1)+6
+ IDCMF=201
+ CALL HWEONE
+ ELSE
+ EVWGT=0.
+ CALL HWHIGM(EMH,EMFAC)
+ IF (EMH.LE.ZERO .OR. EMH.GE.PHEP(5,3)) RETURN
+ EMSCA=EMH
+ IF (EMSCA.NE.EMLST) THEN
+ EMLST=EMH
+ XXMIN=(EMH/PHEP(5,3))**2
+ XLMIN=LOG(XXMIN)
+ GFACTR=GEV2NB*HWUAEM(EMH**2)/(288.*SWEIN*RMASS(198)**2)
+ DO 20 I=1,13
+ EMQ=RMASS(I)
+ IF (I.EQ.13) THEN
+ CSFAC(I)=-GFACTR*HWHIGT(RMASS(NFLAV)/EMH)*XLMIN
+ & *HWUALF(1,EMH)**2 *EMFAC*ENHANC(NFLAV)**2
+ ELSEIF (I.GT.6) THEN
+ CSFAC(I)=CSFAC(I-6)
+ ELSEIF (EMH.GT.2*EMQ) THEN
+ CSFAC(I)=-GFACTR*96.*PIFAC**2 *(1-(2*EMQ/EMH)**2)
+ & *(EMQ/EMH)**2 *XLMIN *EMFAC*ENHANC(I)**2
+ ELSE
+ CSFAC(I)=0
+ ENDIF
+ 20 CONTINUE
+C INCLUDE BRANCHING RATIO OF HIGGS
+ IDEC=MOD(IPROC,100)
+ BR=1
+ IF (IDEC.EQ.0) THEN
+ BRHIGQ=0
+ DO 30 I=1,6
+ 30 BRHIGQ=BRHIGQ+BRHIG(I)
+ BR=BRHIGQ
+ ELSEIF (IDEC.EQ.10) THEN
+ CALL HWDBOZ(198,ID1,ID2,CV,CA,BR,1)
+ CALL HWDBOZ(199,ID1,ID2,CV,CA,BR,1)
+ BR=BR*BRHIG(IDEC)
+ ELSEIF (IDEC.EQ.11) THEN
+ CALL HWDBOZ(200,ID1,ID2,CV,CA,BR,1)
+ CALL HWDBOZ(200,ID1,ID2,CV,CA,BR,1)
+ BR=BR*BRHIG(IDEC)
+ ELSEIF (IDEC.LE.12) THEN
+ BR=BRHIG(IDEC)
+ ENDIF
+ ENDIF
+ CALL HWSGEN(.TRUE.)
+ EVWGT=0
+ E1=PHEP(4,MAX(1,JDAHEP(1,1)))
+ E2=PHEP(4,MAX(2,JDAHEP(1,2)))
+ DO 40 I=1,13
+ EMQ=RMASS(I)
+ IF (EMH.GT.2*EMQ) THEN
+ J=13
+ IF (I.LE.12) J=I-6
+ IF (I.LE. 6) J=I+6
+ IF (XX(1).LT.HALF*(ONE-EMQ/E1+HWUSQR(ONE-TWO*EMQ/E1)) .AND.
+ & XX(2).LT.HALF*(ONE-EMQ/E2+HWUSQR(ONE-TWO*EMQ/E2)))
+ & EVWGT=EVWGT+DISF(I,1)*DISF(J,2)*CSFAC(I)*BR
+ ENDIF
+ EVSUM(I)=EVWGT
+ 40 CONTINUE
+ ENDIF
+ 999 END
+CDECK ID>, HWHIGT.
+*CMZ :- -26/04/91 11.11.55 by Bryan Webber
+*-- Author : Mike Seymour
+C-----------------------------------------------------------------------
+ FUNCTION HWHIGT(RATIO)
+C-----------------------------------------------------------------------
+C CALCULATE MOD SQUARED I FOR RATIO = Mtop / Mhiggs
+C I DEFINED AS IN BARGER & PHILLIPS p433
+C WARNING: THIS IS A FACTOR OF 3 GREATER THAN EHLQ'S ETA FUNCTION
+C-----------------------------------------------------------------------
+ INCLUDE 'HERWIG61.INC'
+ DOUBLE PRECISION HWHIGT,RATIO,RAT2,FREAL,FIMAG,ETALOG,AIREAL,
+ & AIIMAG
+ RAT2=RATIO**2
+ IF (FOUR*RAT2.GT.ONE) THEN
+ FREAL=-TWO*ASIN(HALF/RATIO)**2
+ FIMAG=ZERO
+ ELSEIF (FOUR*RAT2.LT.ONE) THEN
+ ETALOG=LOG((HALF+SQRT(0.25-RAT2)) / (HALF-SQRT(0.25-RAT2)) )
+ FREAL=HALF * (ETALOG**2 - PIFAC**2)
+ FIMAG=PIFAC * ETALOG
+ ELSE
+ FREAL=HALF * ( - PIFAC**2)
+ FIMAG=ZERO
+ ENDIF
+ AIREAL=THREE*( TWO*RAT2 + RAT2*(FOUR*RAT2-ONE)*FREAL )
+ AIIMAG=THREE*( RAT2*(FOUR*RAT2-ONE)*FIMAG )
+ HWHIGT=AIREAL**2 + AIIMAG**2
+ END
+CDECK ID>, HWHIGW.
+*CMZ :- -26/04/91 14.55.44 by Federico Carminati
+*-- Author : Mike Seymour
+C-----------------------------------------------------------------------
+ SUBROUTINE HWHIGW
+C-----------------------------------------------------------------------
+C HIGGS PRODUCTION VIA W BOSON FUSION
+C MEAN EVWGT = HIGGS PRODN C-S * BRANCHING FRACTION IN NB
+C-----------------------------------------------------------------------
+ INCLUDE 'HERWIG61.INC'
+ DOUBLE PRECISION HWULDO,HWRUNI,HWR,HWUAEM,K1MAX2,K1MIN2,K12,
+ & K2MAX2,K2MIN2,K22,EMW2,EMW,ROOTS,EMH2,EMH,ROOTS2,P1,PHI1,PHI2,
+ & COSPHI,COSTH1,SINTH1,COSTH2,SINTH2,P2,WEIGHT,TAU,TAULN,CSFAC,
+ & PSUM,PROB,Q1(5),Q2(5),H(5),A,B,C,TERM2,BRHIGQ,G1WW,G2WW,G1ZZ(6),
+ & G2ZZ(6),AWW,AZZ(6),PWW,PZZ(6),EMZ,EMZ2,RSUM,GLUSQ,GRUSQ,GLDSQ,
+ & GRDSQ,GLESQ,GRESQ,CW,CZ,EMFAC,CV,CA,BR,X2,ETA,P1JAC,FACTR,EH2
+ INTEGER HWRINT,IDEC,I,ID1,ID2,IHAD
+ LOGICAL EE,EP
+ EXTERNAL HWULDO,HWRUNI,HWR,HWUAEM,HWRINT
+ SAVE EMW2,EMZ2,EE,GLUSQ,GRUSQ,GLDSQ,GRDSQ,GLESQ,GRESQ,G1ZZ,G2ZZ,
+ & G1WW,G2WW,CW,CZ,PSUM,AWW,PWW,AZZ,PZZ,ROOTS,Q1,Q2,H,FACTR
+ EQUIVALENCE (EMW,RMASS(198)),(EMZ,RMASS(200))
+ IHAD=2
+ IF (JDAHEP(1,IHAD).NE.0) IHAD=JDAHEP(1,IHAD)
+ IF (FSTWGT) THEN
+ EMW2=EMW**2
+ EMZ2=EMZ**2
+ GLUSQ=(VFCH(2,1)+AFCH(2,1))**2
+ GRUSQ=(VFCH(2,1)-AFCH(2,1))**2
+ GLDSQ=(VFCH(1,1)+AFCH(1,1))**2
+ GRDSQ=(VFCH(1,1)-AFCH(1,1))**2
+ GLESQ=(VFCH(11,1)+AFCH(11,1))**2
+ GRESQ=(VFCH(11,1)-AFCH(11,1))**2
+ G1ZZ(1)=GLUSQ*GLUSQ+GRUSQ*GRUSQ
+ G2ZZ(1)=GLUSQ*GRUSQ+GRUSQ*GLUSQ
+ G1ZZ(2)=GLUSQ*GLDSQ+GRUSQ*GRDSQ
+ G2ZZ(2)=GLUSQ*GRDSQ+GRUSQ*GLDSQ
+ G1ZZ(3)=GLDSQ*GLDSQ+GRDSQ*GRDSQ
+ G2ZZ(3)=GLDSQ*GRDSQ+GRDSQ*GLDSQ
+ G1ZZ(4)=GLESQ*GLESQ+GRESQ*GRESQ
+ G2ZZ(4)=GLESQ*GRESQ+GRESQ*GLESQ
+ G1ZZ(5)=GLESQ*GLUSQ+GRESQ*GRUSQ
+ G2ZZ(5)=GLESQ*GRUSQ+GRESQ*GLUSQ
+ G1ZZ(6)=GLESQ*GLDSQ+GRESQ*GRDSQ
+ G2ZZ(6)=GLESQ*GRDSQ+GRESQ*GLDSQ
+ G1WW=0.25
+ G2WW=0
+ FACTR=GEV2NB/(128.*PIFAC**3)
+ EH2=RMASS(201)**2
+ CW=256*(PIFAC*HWUAEM(EH2)/SWEIN)**3*EMW2
+ CZ=256.*(PIFAC*HWUAEM(EH2))**3*EMZ2/(SWEIN*(1.-SWEIN))
+ ENDIF
+ EE=IPRO.LT.10
+ EP=IPRO.GE.90
+ IF (.NOT.GENEV) THEN
+C---CHOOSE PARAMETERS
+ EVWGT=0.
+ CALL HWHIGM(EMH,EMFAC)
+ IF (EMH.LE.ZERO .OR. EMH.GE.PHEP(5,3)) RETURN
+ EMSCA=EMH
+ IF (EE) THEN
+ ROOTS=PHEP(5,3)
+ ELSE
+ TAU=(EMH/PHEP(5,3))**2
+ TAULN=LOG(TAU)
+ ROOTS=PHEP(5,3)*SQRT(EXP(HWRUNI(0,-1D-10,TAULN)))
+ ENDIF
+ EMH2=EMH**2
+ ROOTS2=ROOTS**2
+C---CHOOSE P1 ACCORDING TO (1-ETA)*(ETA-X2)/ETA**2
+C WHERE ETA=1-2P1/ROOTS AND X2=EMH**2/S
+ X2=EMH2/ROOTS2
+ 1 ETA=X2**HWR()
+ IF (HWR()*(1-EMH/ROOTS)**2*ETA.GT.(1-ETA)*(ETA-X2))GOTO 1
+ P1JAC=0.5*ROOTS*ETA**2/((1-ETA)*(ETA-X2))
+ & *(-LOG(X2)*(1+X2)-2*(1-X2))
+ P1=0.5*ROOTS*(1-ETA)
+C---CHOOSE PHI1,2 UNIFORMLY
+ PHI1=2*PIFAC*HWR()
+ PHI2=2*PIFAC*HWR()
+ COSPHI=COS(PHI2-PHI1)
+C---CHOOSE K1^2, ON PROPAGATOR FACTOR
+ K1MAX2=2*P1*ROOTS
+ K1MIN2=0
+ K12=EMW2-(EMW2+K1MAX2)*(EMW2+K1MIN2)/
+ & ((K1MAX2-K1MIN2)*HWR()+(EMW2+K1MIN2))
+C---CALCULATE COSTH1 FROM K1^2
+ COSTH1=1+K12/(P1*ROOTS)
+ SINTH1=SQRT(1-COSTH1**2)
+C---CHOOSE K2^2
+ K2MAX2=ROOTS*(ROOTS2-EMH2-2*ROOTS*P1)*(ROOTS-P1-P1*COSTH1)
+ & /((ROOTS-P1)**2-(P1*COSTH1)**2-(P1*SINTH1*COSPHI)**2)
+ K2MIN2=0
+ K22=EMW2-(EMW2+K2MAX2)*(EMW2+K2MIN2)/
+ & ((K2MAX2-K2MIN2)*HWR()+(EMW2+K2MIN2))
+C---CALCULATE A,B,C FACTORS, AND...
+ A=-2*K22*P1*COSTH1 - ROOTS*(ROOTS2-EMH2-2*ROOTS*P1)
+ B=-2*K22*P1*SINTH1*COSPHI
+ C=+2*K22*P1 - 2*ROOTS*K22 - ROOTS*(ROOTS2-EMH2-2*ROOTS*P1)
+C---SOLVE A*COSTH2 + B*SINTH2 + C = 0 FOR COSTH2
+ TERM2=B**2 + A**2 - C**2
+ IF (TERM2.LT.ZERO) RETURN
+ TERM2=B*SQRT(TERM2)
+ IF (A.GE.ZERO) RETURN
+ COSTH2=(-A*C + TERM2)/(A**2+B**2)
+ SINTH2=SQRT(1-COSTH2**2)
+C---FINALLY, GET P2
+ IF (COSTH2.EQ.-ONE) RETURN
+ P2=-K22/(ROOTS*(1+COSTH2))
+C---LOAD UP CMF MOMENTA
+ Q1(1)=P1*SINTH1*COS(PHI1)
+ Q1(2)=P1*SINTH1*SIN(PHI1)
+ Q1(3)=P1*COSTH1
+ Q1(4)=P1
+ Q1(5)=0
+ Q2(1)=P2*SINTH2*COS(PHI2)
+ Q2(2)=P2*SINTH2*SIN(PHI2)
+ Q2(3)=P2*COSTH2
+ Q2(4)=P2
+ Q2(5)=0
+ H(1)=-Q1(1)-Q2(1)
+ H(2)=-Q1(2)-Q2(2)
+ H(3)=-Q1(3)-Q2(3)
+ H(4)=-Q1(4)-Q2(4)+ROOTS
+ CALL HWUMAS(H)
+C---CALCULATE MATRIX ELEMENTS SQUARED
+ AWW=ENHANC(10)**2 * CW*(ROOTS2/2*HWULDO(Q1,Q2)*G1WW
+ & +ROOTS2/4*P1*P2*(1+COSTH1)*(1-COSTH2)*G2WW)
+ DO 10 I=1,6
+ AZZ(I)=ENHANC(11)**2 * CZ*(ROOTS2/2*HWULDO(Q1,Q2)*G1ZZ(I)
+ & +ROOTS2/4*P1*P2*(1+COSTH1)*(1-COSTH2)*G2ZZ(I))
+ & *((K12-EMW2)/(K12-EMZ2)*(K22-EMW2)/(K22-EMZ2))**2
+ 10 CONTINUE
+C---CALCULATE WEIGHT IN INTEGRAL
+ WEIGHT=FACTR*P2*P1JAC/(ROOTS2**2*HWULDO(H,Q2))
+ & *(K1MAX2-K1MIN2)/((K1MAX2+EMW2)*(K1MIN2+EMW2))
+ & *(K2MAX2-K2MIN2)/((K2MAX2+EMW2)*(K2MIN2+EMW2))
+ & * EMFAC
+ EMSCA=EMW
+ XXMIN=(ROOTS/PHEP(5,3))**2
+ XLMIN=LOG(XXMIN)
+C---INCLUDE BRANCHING RATIO OF HIGGS
+ IDEC=MOD(IPROC,100)
+ IF (IDEC.GT.0.AND.IDEC.LE.12) WEIGHT=WEIGHT*BRHIG(IDEC)
+ IF (IDEC.EQ.0) THEN
+ BRHIGQ=0
+ DO 20 I=1,6
+ 20 BRHIGQ=BRHIGQ+BRHIG(I)
+ WEIGHT=WEIGHT*BRHIGQ
+ ENDIF
+ IF (IDEC.EQ.10) THEN
+ CALL HWDBOZ(198,ID1,ID2,CV,CA,BR,1)
+ CALL HWDBOZ(199,ID1,ID2,CV,CA,BR,1)
+ WEIGHT=WEIGHT*BR
+ ELSEIF (IDEC.EQ.11) THEN
+ CALL HWDBOZ(200,ID1,ID2,CV,CA,BR,1)
+ CALL HWDBOZ(200,ID1,ID2,CV,CA,BR,1)
+ WEIGHT=WEIGHT*BR
+ ENDIF
+ IF (EE) THEN
+ CSFAC=WEIGHT
+ PSUM=AWW+AZZ(4)
+ EVWGT=CSFAC*PSUM
+ ELSEIF (EP) THEN
+ CSFAC=-WEIGHT*TAULN
+ XX(1)=ONE
+ XX(2)=XXMIN
+ CALL HWSFUN(XX(2),EMSCA,IDHW(IHAD),NSTRU,DISF(1,2),2)
+ IF (IDHW(1).LE.126) THEN
+ PWW=(DISF(2,2)+DISF(4,2)+DISF(7,2)+DISF( 9,2))*AWW
+ ELSE
+ PWW=(DISF(1,2)+DISF(3,2)+DISF(8,2)+DISF(10,2))*AWW
+ ENDIF
+ PZZ(5)=(DISF(2,2)+DISF(4,2)+DISF(8,2)+DISF(10,2))*AZZ(5)
+ PZZ(6)=(DISF(1,2)+DISF(3,2)+DISF(7,2)+DISF( 9,2))*AZZ(6)
+ PSUM=PWW+PZZ(5)+PZZ(6)
+ EVWGT=CSFAC*PSUM
+ ELSE
+ CSFAC=WEIGHT*TAULN*XLMIN
+ CALL HWSGEN(.TRUE.)
+ PWW=((DISF(2,1)+DISF(4, 1)+DISF(7,1)+DISF(9,1))
+ & *(DISF(8,2)+DISF(10,2)+DISF(1,2)+DISF(3,2))
+ & +(DISF(8,1)+DISF(10,1)+DISF(1,1)+DISF(3,1))
+ & *(DISF(2,2)+DISF(4, 2)+DISF(7,2)+DISF(9,2)))
+ & *AWW
+ PZZ(1)=((DISF(2,1)+DISF(4,1)+DISF(8,1)+DISF(10,1))
+ & *(DISF(2,2)+DISF(4,2)+DISF(8,2)+DISF(10,2)))
+ & *AZZ(1)
+ PZZ(2)=((DISF(2,1)+DISF(4,1)+DISF(8,1)+DISF(10,1))
+ & *(DISF(1,2)+DISF(3,2)+DISF(7,2)+DISF(9, 2))
+ & +(DISF(1,1)+DISF(3,1)+DISF(7,1)+DISF(9, 1))
+ & *(DISF(2,2)+DISF(4,2)+DISF(8,2)+DISF(10,2)))
+ & *AZZ(2)
+ PZZ(3)=((DISF(1,1)+DISF(3,1)+DISF(7,1)+DISF(9,1))
+ & *(DISF(1,2)+DISF(3,2)+DISF(7,2)+DISF(9,2)))
+ & *AZZ(3)
+ PSUM=PWW+PZZ(1)+PZZ(2)+PZZ(3)
+C---EVENT WEIGHT IS SUM OVER ALL COMBINATIONS
+ EVWGT=CSFAC*PSUM
+ ENDIF
+ ELSE
+C---GENERATE EVENT
+C---CHOOSE EVENT TYPE
+ RSUM=PSUM*HWR()
+C---ELECTRON BEAMS?
+ IF (EE) THEN
+ IDN(1)=IDHW(1)
+ IDN(2)=IDHW(2)
+C---WW FUSION?
+ IF (RSUM.LT.AWW) THEN
+ IDN(3)=IDN(1)+1
+ IDN(4)=IDN(2)+1
+C---ZZ FUSION?
+ ELSE
+ IDN(3)=IDN(1)
+ IDN(4)=IDN(2)
+ ENDIF
+C---LEPTON-HADRON COLISION?
+ ELSEIF (EP) THEN
+C---WW FUSION?
+ IDN(1)=IDHW(1)
+ IF (RSUM.LT.PWW) THEN
+ 24 IDN(2)=HWRINT(1,8)
+ IF (IDN(2).GE.5) IDN(2)=IDN(2)+2
+ IF (ICHRG(IDN(1))*ICHRG(IDN(2)).GT.0) GOTO 24
+ PROB=DISF(IDN(2),2)*AWW/PWW
+ IF (HWR().GT.PROB) GOTO 24
+ IDN(3)=IDN(1)+1
+ IF (HWR().GT.SCABI) THEN
+ IDN(4)= 4*INT((IDN(2)-1)/2)-IDN(2)+3
+ ELSE
+ IDN(4)=12*INT((IDN(2)-1)/6)-IDN(2)+5
+ ENDIF
+C---ZZ FUSION FROM U-TYPE QUARK?
+ ELSEIF (RSUM.LT.PWW+PZZ(5)) THEN
+ 26 IDN(2)=2*HWRINT(1,4)
+ IF (IDN(2).GE.5) IDN(2)=IDN(2)+2
+ PROB=DISF(IDN(2),2)*AZZ(5)/PZZ(5)
+ IF (HWR().GT.PROB) GOTO 26
+ IDN(3)=IDN(1)
+ IDN(4)=IDN(2)
+C---ZZ FUSION FROM D-TYPE QUARK?
+ ELSE
+ 28 IDN(2)=2*HWRINT(1,4)-1
+ IF (IDN(2).GE.5) IDN(2)=IDN(2)+2
+ PROB=DISF(IDN(2),2)*AZZ(6)/PZZ(6)
+ IF (HWR().GT.PROB) GOTO 28
+ IDN(3)=IDN(1)
+ IDN(4)=IDN(2)
+ ENDIF
+C---HADRON BEAMS?
+ ELSE
+C---WW FUSION?
+ IF (RSUM.LT.PWW) THEN
+ 31 DO 32 I=1,2
+ IDN(I)=HWRINT(1,8)
+ IF (IDN(I).GE.5) IDN(I)=IDN(I)+2
+ 32 CONTINUE
+ IF (ICHRG(IDN(1))*ICHRG(IDN(2)).GT.0) GOTO 31
+ PROB=DISF(IDN(1),1)*DISF(IDN(2),2)*AWW/PWW
+ IF (HWR().GT.PROB) GOTO 31
+C---CHOOSE OUTGOING QUARKS
+ DO 33 I=1,2
+ IF (HWR().GT.SCABI) THEN
+ IDN(I+2)=4*INT((IDN(I)-1)/2)-IDN(I)+3
+ ELSE
+ IDN(I+2)=12*INT((IDN(I)-1)/6)-IDN(I)+5
+ ENDIF
+ 33 CONTINUE
+C---ZZ FUSION FROM U-TYPE QUARKS?
+ ELSEIF (RSUM.LT.PWW+PZZ(1)) THEN
+ 41 DO 42 I=1,2
+ IDN(I)=2*HWRINT(1,4)
+ IF (IDN(I).GE.5) IDN(I)=IDN(I)+2
+ 42 CONTINUE
+ PROB=DISF(IDN(1),1)*DISF(IDN(2),2)*AZZ(1)/PZZ(1)
+ IF (HWR().GT.PROB) GOTO 41
+ IDN(3)=IDN(1)
+ IDN(4)=IDN(2)
+C---ZZ FUSION FROM D-TYPE QUARKS?
+ ELSEIF (RSUM.LT.PWW+PZZ(1)+PZZ(3)) THEN
+ 51 DO 52 I=1,2
+ IDN(I)=2*HWRINT(1,4)-1
+ IF (IDN(I).GE.5) IDN(I)=IDN(I)+2
+ 52 CONTINUE
+ PROB=DISF(IDN(1),1)*DISF(IDN(2),2)*AZZ(3)/PZZ(3)
+ IF (HWR().GT.PROB) GOTO 51
+ IDN(3)=IDN(1)
+ IDN(4)=IDN(2)
+C---ZZ FUSION FROM UD-TYPE PAIRS?
+ ELSE
+ 61 IF (HWR().GT.HALF) THEN
+ IDN(1)=2*HWRINT(1,4)-1
+ IDN(2)=2*HWRINT(1,4)
+ ELSE
+ IDN(1)=2*HWRINT(1,4)
+ IDN(2)=2*HWRINT(1,4)-1
+ ENDIF
+ DO 62 I=1,2
+ 62 IF (IDN(I).GE.5) IDN(I)=IDN(I)+2
+ PROB=DISF(IDN(1),1)*DISF(IDN(2),2)*AZZ(2)/PZZ(2)
+ IF (HWR().GT.PROB) GOTO 61
+ IDN(3)=IDN(1)
+ IDN(4)=IDN(2)
+ ENDIF
+ ENDIF
+C---NOW BOOST TO LAB, AND SET UP STATUS CODES etc
+ IDCMF=15
+C---INCOMING
+ IF (.NOT.EE) CALL HWEONE
+C---CMF POINTERS
+ JDAHEP(1,NHEP)=NHEP+1
+ JDAHEP(2,NHEP)=NHEP+3
+ JMOHEP(1,NHEP+1)=NHEP
+ JMOHEP(1,NHEP+2)=NHEP
+ JMOHEP(1,NHEP+3)=NHEP
+C---OUTGOING MOMENTA (GIVE QUARKS MASS NON-COVARIANTLY!)
+ Q1(5)=RMASS(IDN(1))
+ Q1(4)=SQRT(Q1(4)**2+Q1(5)**2)
+ Q2(5)=RMASS(IDN(2))
+ Q2(4)=SQRT(Q2(4)**2+Q2(5)**2)
+ H(4)=-Q1(4)-Q2(4)+PHEP(5,NHEP)
+ CALL HWUMAS(H)
+ CALL HWULOB(PHEP(1,NHEP),Q1,PHEP(1,NHEP+1))
+ CALL HWULOB(PHEP(1,NHEP),Q2,PHEP(1,NHEP+2))
+ CALL HWULOB(PHEP(1,NHEP),H,PHEP(1,NHEP+3))
+C---STATUS AND IDs
+ ISTHEP(NHEP+1)=113
+ ISTHEP(NHEP+2)=114
+ ISTHEP(NHEP+3)=114
+ IDHW(NHEP+1)=IDN(3)
+ IDHEP(NHEP+1)=IDPDG(IDN(3))
+ IDHW(NHEP+2)=IDN(4)
+ IDHEP(NHEP+2)=IDPDG(IDN(4))
+ IDHW(NHEP+3)=201
+ IDHEP(NHEP+3)=IDPDG(201)
+C---COLOUR LABELS
+ JMOHEP(2,NHEP+1)=NHEP-2
+ JMOHEP(2,NHEP+2)=NHEP-1
+ JMOHEP(2,NHEP-1)=NHEP+2
+ JMOHEP(2,NHEP-2)=NHEP+1
+ JMOHEP(2,NHEP+3)=NHEP+3
+ JDAHEP(2,NHEP+1)=NHEP-2
+ JDAHEP(2,NHEP+2)=NHEP-1
+ JDAHEP(2,NHEP-1)=NHEP+2
+ JDAHEP(2,NHEP-2)=NHEP+1
+ JDAHEP(2,NHEP+3)=NHEP+3
+ NHEP=NHEP+3
+ ENDIF
+ 999 END
+CDECK ID>, HWHIGY.
+*CMZ :- -26/04/91 13.37.37 by Federico Carminati
+*-- Author : Mike Seymour
+C-----------------------------------------------------------------------
+ FUNCTION HWHIGY(A,B,XP)
+C-----------------------------------------------------------------------
+C CALCULATE THE INTEGRAL OF BERENDS AND KLEISS APPENDIX B
+C-----------------------------------------------------------------------
+ IMPLICIT NONE
+ COMPLEX XQ,Z1,Z2,Z3,Z4,C0,C1,C2,C3,C4,C5,C6,C7,C8,FUN,Z
+ DOUBLE PRECISION HWHIGY,TWO,A,B,XP,Y
+ PARAMETER (TWO=2.D0)
+C---DECLARE ALL THE STATEMENT-FUNCTION DEFINITIONS
+ C0(Z,A)=(Z**2-A)**2*((Z**2+A)**2-24*Z*(Z**2+A)+8*Z**2*(A+6))/Z**4
+ C1(Z,A)=A**4/(3*Z)
+ C2(Z,A)=-A**3*(24*Z-A)/(2*Z**2)
+ C3(Z,A)=A**2*(8*Z**2*(A+6)-24*A*Z+A**2)/Z**3
+ C4(Z,A)=-A**2*(24*Z**3+8*Z**2*(A+6)-24*A*Z+A**2)/Z**4
+ C5(Z,A)=Z**3-24*Z**2+8*Z*(A+6)+24*A
+ C6(Z,A)=0.5*Z**2-12*Z+4*(A+6)
+ C7(Z,A)=Z/3-8
+ C8(Z,A)=0.25
+ FUN(Z,Y,A)=C0(Z,A)*LOG(Y-Z)
+ & +C1(Z,A)/Y**3
+ & +C2(Z,A)/Y**2
+ & +C3(Z,A)/Y
+ & +C4(Z,A)*LOG(Y)
+ & +C5(Z,A)*Y
+ & +C6(Z,A)*Y**2
+ & +C7(Z,A)*Y**3
+ & +C8(Z,A)*Y**4
+C---NOW EVALUATE THE INTEGRAL
+ HWHIGY=0
+ IF (A.GT.4) RETURN
+ XQ=CMPLX(XP,B)
+ Z1=XQ+SQRT(XQ**2-A)
+ Z2=XQ-SQRT(XQ**2-A)
+ Z3=FUN(Z1,TWO,A)-FUN(Z1,SQRT(A),A)
+ Z4=FUN(Z2,TWO,A)-FUN(Z2,SQRT(A),A)
+ HWHIGY=AIMAG((Z3-Z4)/(Z1-Z2))/(8*B)
+ END
+CDECK ID>, HWHIGZ.
+*CMZ :- -02/05/91 11.18.44 by Federico Carminati
+*-- Author : Mike Seymour
+C-----------------------------------------------------------------------
+ SUBROUTINE HWHIGZ
+C-----------------------------------------------------------------------
+C HIGGS PRODUCTION VIA THE BJORKEN PROCESS: E+E- --> Z(*) --> Z(*)H
+C WHERE ONE OR BOTH OF THE Zs IS OFF-SHELL
+C USES ALGORITHM OF BERENDS AND KLEISS: NUCL.PHYS. B260(1985)32
+C
+C MEAN EVWGT = CROSS-SECTION (IN NB) * HIGGS BRANCHING FRACTION
+C-----------------------------------------------------------------------
+ INCLUDE 'HERWIG61.INC'
+ DOUBLE PRECISION HWUAEM,HWHIGY,HWRUNI,HWR,HWULDO,EMZ,CVE,CAE,
+ & POL1,POL2,CE1,CE2,CE3,PMAX,EMZ2,S,B,FACTR,EMH,EMFAC,EMH2,A,XP,
+ & CV,CA,BRHIGQ,BR,X1,X2,FAC1,FAC2,XPP,XPPSQ,COEF,X,XSQ,PROB,C1,C2,
+ & CHIGG,PTHETA,SHIGG,C3,PHIMAX,CPHI,SPHI,C2PHI,S2PHI,PCM,ELST
+ INTEGER IDEC,I,NLOOP,ICMF,IHIG,IZED,IFER,IANT,ID1,ID2,IN1,IN2
+ EXTERNAL HWUAEM,HWHIGY,HWRUNI,HWR,HWULDO
+ SAVE CVE,CAE,CE1,CE2,CE3,PMAX,EMZ2,S,EMH,B,FACTR,A,EMH2
+ EQUIVALENCE (EMZ,RMASS(200))
+ DATA ELST/0/
+C---SET UP CONSTANTS
+ IN1=1
+ IF (JDAHEP(1,IN1).NE.0) IN1=JDAHEP(1,IN1)
+ IN2=2
+ IF (JDAHEP(1,IN2).NE.0) IN2=JDAHEP(1,IN2)
+ IF (FSTWGT.OR.ELST.NE.PHEP(5,3)) THEN
+ ELST=PHEP(5,3)
+ CVE=VFCH(11,1)
+ CAE=AFCH(11,1)
+ POL1=1.-EPOLN(3)*PPOLN(3)
+ POL2=EPOLN(3)-PPOLN(3)
+ CE1=(POL1*(CVE**2+CAE**2)+POL2*2.*CVE*CAE)
+ CE2=(POL1*2.*CVE*CAE+POL2*(CVE**2+CAE**2))
+ IF ((IDHW(IN1).GT.IDHW(IN2).AND.PHEP(3,IN1).LT.ZERO).OR.
+ & (IDHW(IN2).GT.IDHW(IN1).AND.PHEP(3,IN2).LT.ZERO)) CE2=-CE2
+ IF (TPOL) CE3=(CVE**2-CAE**2)
+ PMAX=4
+ EMZ2=EMZ**2
+ S=PHEP(5,3)**2
+ B=EMZ*GAMZ/S
+ FACTR=GEV2NB*CE1*(HWUAEM(RMASS(201)**2)*ENHANC(11))**2
+ & /(12.*S*SWEIN*(1.-SWEIN))*B/((1-EMZ2/S)**2+B**2)
+ ENDIF
+ IF (.NOT.GENEV) THEN
+C---CHOOSE HIGGS MASS, AND CALCULATE EVENT WEIGHT
+ EVWGT=0D0
+ CALL HWHIGM(EMH,EMFAC)
+ IF (EMH.LE.ZERO .OR. EMH.GT.PHEP(5,3)) RETURN
+ EMSCA=EMH
+ EMH2=EMH**2
+ A=4*EMH2/S
+ XP=1+(EMH2-EMZ2)/S
+ EVWGT=FACTR*HWHIGY(A,B,XP)*EMFAC
+C---INCLUDE BRANCHING RATIO OF HIGGS
+ IDEC=MOD(IPROC,100)
+ IF (IDEC.GT.0.AND.IDEC.LE.12) EVWGT=EVWGT*BRHIG(IDEC)
+ IF (IDEC.EQ.0) THEN
+ BRHIGQ=0
+ DO 10 I=1,6
+ 10 BRHIGQ=BRHIGQ+BRHIG(I)
+ EVWGT=EVWGT*BRHIGQ
+ ENDIF
+C Add Z branching fractions
+ CALL HWDBOZ(200,ID1,ID2,CV,CA,BR,0)
+ EVWGT=EVWGT*BR
+ IF (IDEC.EQ.10) THEN
+ CALL HWDBOZ(198,ID1,ID2,CV,CA,BR,1)
+ CALL HWDBOZ(199,ID1,ID2,CV,CA,BR,1)
+ EVWGT=EVWGT*BR
+ ELSEIF (IDEC.EQ.11) THEN
+ CALL HWDBOZ(200,ID1,ID2,CV,CA,BR,1)
+ CALL HWDBOZ(200,ID1,ID2,CV,CA,BR,1)
+ EVWGT=EVWGT*BR
+ ENDIF
+ ELSE
+C---GENERATE EVENT
+ ICMF=NHEP+1
+ IHIG=NHEP+2
+ IZED=NHEP+3
+ IFER=NHEP+4
+ IANT=NHEP+5
+ CALL HWVEQU(5,PHEP(1,3),PHEP(1,ICMF))
+ NHEP=NHEP+5
+C---CHOOSE ENERGY FRACTION OF HIGGS
+ X1=SQRT(A)
+ X2=1+0.25*A
+ XP=1+(EMH2-EMZ2)/S
+ FAC1=ATAN((X1-XP)/B)
+ FAC2=ATAN((X2-XP)/B)
+ XPP=MIN(X2,MAX(X1+B,XP))
+ XPPSQ=XPP**2
+ NLOOP=0
+ COEF=1./((12+2*A-12*XPP+XPPSQ)*SQRT(XPPSQ-A))
+ 20 NLOOP=NLOOP+1
+ IF (NLOOP.GT.NBTRY) CALL HWWARN('HWHIGZ',101,*999)
+ X=XP+B*TAN(HWRUNI(1,FAC1,FAC2))
+ XSQ=X**2
+ PROB=COEF*((12+2*A-12*X+XSQ)*SQRT(XSQ-A))
+ IF (PROB.GT.PMAX) THEN
+ PMAX=1.1*PROB
+ CALL HWWARN('HWHIGZ',1,*999)
+ WRITE (6,21) PMAX
+ 21 FORMAT(7X,'NEW HWHIGZ MAX WEIGHT =',F8.4)
+ ENDIF
+ IF (PROB.LT.PMAX*HWR()) GOTO 20
+C Choose Z decay mode
+ CALL HWDBOZ(200,IDHW(IFER),IDHW(IANT),CV,CA,BR,0)
+ C1=CE1*(CV**2+CA**2)
+ C2=CE2*2.*CV*CA
+C---CHOOSE HIGGS DIRECTION
+C First polar angle
+ NLOOP=0
+ COEF=(XSQ-A)/(8.*(1.-X)+XSQ+A)
+ 30 NLOOP=NLOOP+1
+ IF (NLOOP.GT.NBTRY) CALL HWWARN('HWHIGZ',102,*999)
+ CHIGG=HWRUNI(2,-ONE, ONE)
+ PTHETA=1-COEF*CHIGG**2
+ IF (PTHETA.LT.HWR()) GOTO 30
+ SHIGG=SQRT(1-CHIGG**2)
+C Now azimuthal angle
+ IF (TPOL) THEN
+ C3=CE3*(CV*2+CA**2)
+ COEF=COEF*SHIGG**2*C3/C1
+ PHIMAX=PTHETA+ABS(COEF)
+ 40 CALL HWRAZM(ONE,CPHI,SPHI)
+ C2PHI=2.*CPHI**2-1.
+ S2PHI=2.*CPHI*SPHI
+ PROB=PTHETA-COEF*(C2PHI*COSS+S2PHI*SINS)
+ IF (PROB.LT.HWR()*PHIMAX) GOTO 40
+ ELSE
+ CALL HWRAZM(ONE,CPHI,SPHI)
+ ENDIF
+C Construct Higgs and Z momenta
+ PHEP(5,IHIG)=EMH
+ PHEP(4,IHIG)=X*PHEP(5,ICMF)/2
+ PCM=SQRT(PHEP(4,IHIG)**2-EMH2)
+ PHEP(3,IHIG)=CHIGG*PCM
+ PHEP(1,IHIG)=SHIGG*PCM*CPHI
+ PHEP(2,IHIG)=SHIGG*PCM*SPHI
+ CALL HWVDIF(4,PHEP(1,ICMF),PHEP(1,IHIG),PHEP(1,IZED))
+ CALL HWUMAS(PHEP(1,IZED))
+C Choose orientation of Z decay
+ NLOOP=0
+ COEF=2.*(C1+ABS(C2))*HWULDO(PHEP(1,IN1),PHEP(1,IZED))
+ & *HWULDO(PHEP(1,IN2),PHEP(1,IZED))/S
+ IF (TPOL) COEF=COEF*(C1+ABS(C2)+ABS(C3))/(C1+ABS(C2))
+ PCM=PHEP(5,IZED)/2
+ PHEP(5,IFER)=0
+ PHEP(5,IANT)=0
+ 50 NLOOP=NLOOP+1
+ IF (NLOOP.GT.NBTRY) CALL HWWARN('HWHIGZ',103,*999)
+ CALL HWDTWO(PHEP(1,IZED),PHEP(1,IFER),PHEP(1,IANT),
+ & PCM,TWO,.TRUE.)
+ PROB=C1*(PHEP(4,IFER)*PHEP(4,IANT)-PHEP(3,IFER)*PHEP(3,IANT))
+ & +C2*(PHEP(4,IFER)*PHEP(3,IANT)-PHEP(3,IFER)*PHEP(4,IANT))
+ IF (TPOL) PROB=PROB+C3*
+ & (COSS*(PHEP(1,IFER)*PHEP(1,IANT)-PHEP(2,IFER)*PHEP(2,IANT))
+ & +SINS*(PHEP(1,IFER)*PHEP(2,IANT)+PHEP(2,IFER)*PHEP(1,IANT)))
+ IF (PROB.LT.HWR()*COEF) GOTO 50
+C---SET UP STATUS CODES,
+ ISTHEP(ICMF)=120
+ ISTHEP(IHIG)=190
+ ISTHEP(IZED)=195
+ ISTHEP(IFER)=113
+ ISTHEP(IANT)=114
+C---COLOR CONNECTIONS,
+ JMOHEP(1,ICMF)=1
+ JMOHEP(2,ICMF)=2
+ JDAHEP(1,ICMF)=IHIG
+ JDAHEP(2,ICMF)=IZED
+ JMOHEP(1,IHIG)=ICMF
+ JMOHEP(1,IZED)=ICMF
+ JMOHEP(1,IFER)=IZED
+ JMOHEP(1,IANT)=IZED
+ JMOHEP(2,IFER)=IANT
+ JMOHEP(2,IANT)=IFER
+ JDAHEP(1,IZED)=IFER
+ JDAHEP(2,IZED)=IANT
+ JDAHEP(2,IFER)=IANT
+ JDAHEP(2,IANT)=IFER
+C---IDENTITY CODES
+ IDHW(ICMF)=200
+ IDHW(IHIG)=201
+ IDHW(IZED)=200
+ IDHEP(ICMF)=IDPDG(IDHW(ICMF))
+ IDHEP(IHIG)=IDPDG(IDHW(IHIG))
+ IDHEP(IZED)=IDPDG(IDHW(IZED))
+ IDHEP(IFER)=IDPDG(IDHW(IFER))
+ IDHEP(IANT)=IDPDG(IDHW(IANT))
+ ENDIF
+ 999 END
+CDECK ID>, HWHPH2.
+*CMZ :- -12/01/93 10.12.43 by Bryan Webber
+*-- Author : Ian Knowles
+C-----------------------------------------------------------------------
+ SUBROUTINE HWHPH2
+C-----------------------------------------------------------------------
+C QQD direct photon pair production: mean EVWGT = sigma in nb
+C-----------------------------------------------------------------------
+ INCLUDE 'HERWIG61.INC'
+ DOUBLE PRECISION HWR,HWRUNI,HWUALF,HWHPPB,EPS,RCS,ET,EJ,KK,KK2,
+ & YJ1INF,YJ1SUP,Z1,YJ2INF,YJ2SUP,Z2,FACT,FACTR,RS,S,T,U,CSTU,TQSQ,
+ & DSTU,HCS
+ INTEGER ID,ID1,ID2
+ EXTERNAL HWR,HWRUNI,HWUALF,HWHPPB
+ SAVE HCS,CSTU,DSTU,FACT
+ PARAMETER (EPS=1.D-9)
+ IF (GENEV) THEN
+ RCS=HCS*HWR()
+ ELSE
+ EVWGT=0.
+ CALL HWRPOW(ET,EJ)
+ KK=ET/PHEP(5,3)
+ KK2=KK**2
+ IF (KK.GE.ONE) RETURN
+ YJ1INF=MAX( YJMIN , LOG((1.-SQRT(1.-KK2))/KK) )
+ YJ1SUP=MIN( YJMAX , LOG((1.+SQRT(1.-KK2))/KK) )
+ IF (YJ1INF.GE.YJ1SUP) RETURN
+ Z1=EXP(HWRUNI(1,YJ1INF,YJ1SUP))
+ YJ2INF=MAX( YJMIN , -LOG(2./KK-1./Z1) )
+ YJ2SUP=MIN( YJMAX , LOG(2./KK-Z1) )
+ IF (YJ2INF.GE.YJ2SUP) RETURN
+ Z2=EXP(HWRUNI(2,YJ2INF,YJ2SUP))
+ XX(1)=0.5*(Z1+Z2)*KK
+ IF (XX(1).GE.ONE) RETURN
+ XX(2)=XX(1)/(Z1*Z2)
+ IF (XX(2).GE.ONE) RETURN
+ COSTH=(Z1-Z2)/(Z1+Z2)
+ S=XX(1)*XX(2)*PHEP(5,3)**2
+ RS=0.5*SQRT(S)
+ T=-0.5*S*(1.-COSTH)
+ U=-S-T
+ EMSCA=SQRT(2.*S*T*U/(S*S+T*T+U*U))
+ FACT=GEV2NB*PIFAC*0.5*ET*EJ*(YJ1SUP-YJ1INF)*(YJ2SUP-YJ2INF)
+ & *(ALPHEM/S)**2
+ CALL HWSGEN(.FALSE.)
+ CSTU=2.*(U/T+T/U)/CAFAC
+ IF (DISF(13,1).GT.EPS.AND.DISF(13,2).GT.EPS) THEN
+ TQSQ=0.
+ DO 10 ID=1,6
+ 10 IF (RMASS(ID).LT.RS) TQSQ=TQSQ+QFCH(ID)**2
+ DSTU=DISF(13,1)*DISF(13,2)*FACT*HWHPPB(S,T,U)
+ & /64.*(HWUALF(1,EMSCA)*TQSQ/PIFAC)**2
+ ENDIF
+ ENDIF
+ HCS=0.
+ DO 30 ID=1,6
+ FACTR=FACT*CSTU*QFCH(ID)**4
+C q+qbar ---> gamma+gamma
+ ID1=ID
+ ID2=ID+6
+ IF (DISF(ID1,1).LT.EPS.OR.DISF(ID2,2).LT.EPS) GOTO 20
+ HCS=HCS+FACTR*DISF(ID1,1)*DISF(ID2,2)
+ IF (GENEV.AND.HCS.GT.RCS) CALL HWHQCP(59,59,2134,61,*99)
+C qbar+q ---> gamma+gamma
+ 20 ID1=ID+6
+ ID2=ID
+ IF (DISF(ID1,1).LT.EPS.OR.DISF(ID2,2).LT.EPS) GOTO 30
+ HCS=HCS+FACTR*DISF(ID1,1)*DISF(ID2,2)
+ IF (GENEV.AND.HCS.GT.RCS) CALL HWHQCP(59,59,2134,62,*99)
+ 30 CONTINUE
+C g+g ---> gamma+gamma
+ ID1=13
+ ID2=13
+ HCS=HCS+DSTU
+ IF (GENEV.AND.HCS.GT.RCS) CALL HWHQCP(59,59,2134,63,*99)
+ EVWGT=HCS
+ RETURN
+C Generate event
+ 99 IDN(1)=ID1
+ IDN(2)=ID2
+ IDCMF=15
+ CALL HWETWO
+ 999 END
+CDECK ID>, HWHPHO.
+*CMZ :- -26/04/91 14.55.45 by Federico Carminati
+*-- Author : Bryan Webber
+C-----------------------------------------------------------------------
+ SUBROUTINE HWHPHO
+C-----------------------------------------------------------------------
+C QCD DIRECT PHOTON + JET PRODUCTION: MEAN EVWGT = SIGMA IN NB
+C-----------------------------------------------------------------------
+ INCLUDE 'HERWIG61.INC'
+ DOUBLE PRECISION HWR,HWRUNI,HWUALF,HWHPPB,EPS,RCS,ET,EJ,KK,KK2,
+ & YJ1INF,YJ1SUP,Z1,YJ2INF,YJ2SUP,Z2,FACT,FACTR,FACTF,RS,S,T,U,CF,
+ & AF,CSTU,CTSU,CUST,DSTU,HCS,TQCH
+ INTEGER ID,ID1,ID2
+ EXTERNAL HWR,HWRUNI,HWUALF,HWHPPB
+ SAVE HCS
+ PARAMETER (EPS=1.D-9)
+ IF (GENEV) THEN
+ RCS=HCS*HWR()
+ ELSE
+ EVWGT=0.
+ CALL HWRPOW(ET,EJ)
+ KK=ET/PHEP(5,3)
+ KK2=KK**2
+ IF (KK.GE.ONE) RETURN
+ YJ1INF=MAX( YJMIN , LOG((1.-SQRT(1.-KK2))/KK) )
+ YJ1SUP=MIN( YJMAX , LOG((1.+SQRT(1.-KK2))/KK) )
+ IF (YJ1INF.GE.YJ1SUP) RETURN
+ Z1=EXP(HWRUNI(1,YJ1INF,YJ1SUP))
+ YJ2INF=MAX( YJMIN , -LOG(2./KK-1./Z1) )
+ YJ2SUP=MIN( YJMAX , LOG(2./KK-Z1) )
+ IF (YJ2INF.GE.YJ2SUP) RETURN
+ Z2=EXP(HWRUNI(2,YJ2INF,YJ2SUP))
+ XX(1)=0.5*(Z1+Z2)*KK
+ IF (XX(1).GE.ONE) RETURN
+ XX(2)=XX(1)/(Z1*Z2)
+ IF (XX(2).GE.ONE) RETURN
+ COSTH=(Z1-Z2)/(Z1+Z2)
+ S=XX(1)*XX(2)*PHEP(5,3)**2
+ RS=0.5*SQRT(S)
+ T=-0.5*S*(1.-COSTH)
+ U=-S-T
+C---SET EMSCA TO HARD PROCESS SCALE (APPROX ET-JET)
+ EMSCA=SQRT(2.*S*T*U/(S*S+T*T+U*U))
+ FACT=GEV2NB*PIFAC*0.5*ET*EJ*ALPHEM
+ & *HWUALF(1,EMSCA)*(YJ1SUP-YJ1INF)*(YJ2SUP-YJ2INF)/S**2
+ CALL HWSGEN(.FALSE.)
+C
+ CF=2.*CFFAC/CAFAC
+ AF=-1./CAFAC
+ CSTU=CF*(U/T+T/U)
+ CTSU=AF*(U/S+S/U)
+ CUST=AF*(T/S+S/T)
+ IF (DISF(13,1).GT.EPS.AND.DISF(13,2).GT.EPS) THEN
+ TQCH=0.
+ DO 10 ID=1,6
+ 10 IF (RMASS(ID).LT.RS) TQCH=TQCH+QFCH(ID)
+ DSTU=DISF(13,1)*DISF(13,2)*FACT*HWHPPB(S,T,U)
+ & *5./768.*(HWUALF(1,EMSCA)*TQCH/PIFAC)**2
+ ENDIF
+ ENDIF
+C
+ HCS=0.
+ DO 30 ID=1,6
+ FACTR=FACT*QFCH(ID)**2
+C---QUARK FIRST
+ ID1=ID
+ IF (DISF(ID1,1).LT.EPS) GOTO 20
+ ID2=ID1+6
+ HCS=HCS+CSTU*FACTR*DISF(ID1,1)*DISF(ID2,2)
+ IF (GENEV.AND.HCS.GT.RCS) CALL HWHQCP( 13, 59,2314,41,*9)
+ ID2=13
+ HCS=HCS+CTSU*FACTR*DISF(ID1,1)*DISF(ID2,2)
+ IF (GENEV.AND.HCS.GT.RCS) CALL HWHQCP(ID1, 59,3124,42,*9)
+C---QBAR FIRST
+ 20 ID1=ID+6
+ IF (DISF(ID1,1).LT.EPS) GOTO 30
+ ID2=ID
+ HCS=HCS+CSTU*FACTR*DISF(ID1,1)*DISF(ID2,2)
+ IF (GENEV.AND.HCS.GT.RCS) CALL HWHQCP( 13, 59,3124,43,*9)
+ ID2=13
+ HCS=HCS+CTSU*FACTR*DISF(ID1,1)*DISF(ID2,2)
+ IF (GENEV.AND.HCS.GT.RCS) CALL HWHQCP(ID1, 59,2314,44,*9)
+ 30 CONTINUE
+C---GLUON FIRST
+ ID1=13
+ FACTF=FACT*CUST*DISF(ID1,1)
+ DO 50 ID=1,6
+ FACTR=FACTF*QFCH(ID)**2
+ ID2=ID
+ IF (DISF(ID2,2).LT.EPS) GOTO 40
+ HCS=HCS+FACTR*DISF(ID2,2)
+ IF (GENEV.AND.HCS.GT.RCS) CALL HWHQCP(ID2, 59,2314,45,*9)
+ 40 ID2=ID+6
+ IF (DISF(ID2,2).LT.EPS) GOTO 50
+ HCS=HCS+FACTR*DISF(ID2,2)
+ IF (GENEV.AND.HCS.GT.RCS) CALL HWHQCP(ID2, 59,3124,46,*9)
+ 50 CONTINUE
+C g+g ---> g+gamma
+ ID2=13
+ HCS=HCS+DSTU
+ IF (GENEV.AND.HCS.GT.RCS) CALL HWHQCP( 13, 59,2314,47,*9)
+ EVWGT=HCS
+ RETURN
+C---GENERATE EVENT
+ 9 IDN(1)=ID1
+ IDN(2)=ID2
+ IDCMF=15
+ CALL HWETWO
+ 999 END
+CDECK ID>, HWHPPB.
+*CMZ :- -12/01/93 10.12.43 by Bryan Webber
+*-- Author : Ian Knowles
+C-----------------------------------------------------------------------
+ FUNCTION HWHPPB(S,T,U)
+C-----------------------------------------------------------------------
+C Quark box diagram contribution to photon/gluon scattering
+C Internal quark mass neglected: m_q << U,T,S
+C-----------------------------------------------------------------------
+ IMPLICIT NONE
+ DOUBLE PRECISION HWHPPB,S,T,U,S2,T2,U2,PI2,ALNTU,ALNST,ALNSU
+ PI2=ACOS(-1.D0)**2
+ S2=S**2
+ T2=T**2
+ U2=U**2
+ ALNTU=LOG(T/U)
+ ALNST=LOG(-S/T)
+ ALNSU=ALNST+ALNTU
+ HWHPPB=5.*4.
+ & +((2.*S2+2.*(U2-T2)*ALNTU+(T2+U2)*(ALNTU**2+PI2))/S2)**2
+ & +((2.*U2+2.*(T2-S2)*ALNST+(T2+S2)* ALNST**2 )/U2)**2
+ & +((2.*T2+2.*(U2-S2)*ALNSU+(U2+S2)* ALNSU**2 )/T2)**2
+ & +4.*PI2*(((T2-S2+(T2+S2)*ALNST)/U2)**2
+ & +((U2-S2+(U2+S2)*ALNSU)/T2)**2)
+ END
+CDECK ID>, HWHPPE.
+*CMZ :- -12/01/93 10.12.43 by Bryan Webber
+*-- Author : Ian Knowles
+C-----------------------------------------------------------------------
+ SUBROUTINE HWHPPE
+C-----------------------------------------------------------------------
+C point-like photon/QCD heavy flavour single excitation, using exact
+C massive lightcone kinematics, mean EVWGT = sigma in nb.
+C-----------------------------------------------------------------------
+ INCLUDE 'HERWIG61.INC'
+ DOUBLE PRECISION HWR,HWRUNI,HWUALF,EPS,PP1,PP2,QM2,FACTR,
+ & PT,PJ,PT2,PTM,EXY,T,CC,EXY2,S,U,C,SIGE,HCS,RCS
+ INTEGER IQ1,IQ2,ID1,ID2,IHAD1,IHAD2
+ EXTERNAL HWR,HWRUNI,HWUALF
+ SAVE PP1,PP2,IQ1,IQ2,QM2,FACTR,SIGE,HCS
+ PARAMETER (EPS=1.E-9)
+ IHAD1=1
+ IF (JDAHEP(1,IHAD1).NE.0) IHAD1=JDAHEP(1,IHAD1)
+ IHAD2=2
+ IF (JDAHEP(1,IHAD2).NE.0) IHAD2=JDAHEP(1,IHAD2)
+ IF (FSTWGT.OR.IHAD1.NE.1.OR.IHAD2.NE.2) THEN
+ PP1=PHEP(4,IHAD1)+ABS(PHEP(3,IHAD1))
+ PP2=PHEP(4,IHAD2)+ABS(PHEP(3,IHAD2))
+ XX(1)=1.
+ IQ1=MOD(IPROC,100)
+ IQ2=IQ1+6
+ QM2=RMASS(IQ1)**2
+ FACTR=GEV2NB*(YJMAX-YJMIN)*4.*PIFAC*CFFAC*PP1
+ & *ALPHEM*QFCH(IQ1)**2
+ ENDIF
+ IF (GENEV) THEN
+ RCS=HCS*HWR()
+ ELSE
+ EVWGT=0.
+ CALL HWRPOW(PT,PJ)
+ PT2=PT**2
+ PTM=SQRT(PT2+QM2)
+ EXY=EXP(HWRUNI(1,YJMIN,YJMAX))
+ T=-PP1*PT/EXY
+ CC=T**2-4.*QM2*(PT2+T)
+ IF (CC.LT.ZERO) RETURN
+ EXY2=(2.*PT2+T-SQRT(CC))*PP1/(2.*T*PTM)
+ IF (EXY2.LT.EXP(YJMIN).OR.EXY2.GT.EXP(YJMAX)) RETURN
+ XX(2)=(PT/EXY+PTM/EXY2)/PP2
+ IF (XX(2).GT.ONE) RETURN
+C define: S=Shat-M**2, T=That ,U=Uhat-M**2 (2p.Q, -2p.g, -2p.Q')
+ S=XX(2)*PP1*PP2
+ U=-S-T
+ COSTH=(1.+QM2/S)*(T-U)/S-QM2/S
+C Set hard process scale (Approx ET-jet)
+ EMSCA=SQRT(2.*S*T*U/(S*S+T*T+U*U))
+ C=QM2*T/(U*S)
+ SIGE=-FACTR*PT*PJ*HWUALF(1,EMSCA)*(S/U+U/S+4.*C*(1.-C))
+ & /(S**2*EXY2*PTM*(1-QM2/(XX(2)*PP2*EXY2)**2))
+ CALL HWSFUN(XX(2),EMSCA,IDHW(IHAD2),NSTRU,DISF(1,2),2)
+ ENDIF
+ HCS=0.
+ ID1=59
+C photon+Q ---> g+Q
+ ID2=IQ1
+ IF (DISF(ID2,2).LT.EPS) GOTO 10
+ HCS=HCS+SIGE*DISF(ID2,2)
+ IF (GENEV.AND.HCS.GT.RCS) CALL HWHQCP(13,ID2,1423,51,*99)
+C photon+Qbar ---> g+Qbar
+ 10 ID2=IQ2
+ IF (DISF(ID2,2).LT.EPS) GOTO 20
+ HCS=HCS+SIGE*DISF(ID2,2)
+ IF (GENEV.AND.HCS.GT.RCS) CALL HWHQCP(13,ID2,1342,52,*99)
+ 20 EVWGT=HCS
+ RETURN
+C Generate event
+ 99 IDN(1)=ID1
+ IDN(2)=ID2
+ IDCMF=15
+ CALL HWETWO
+ 999 END
+CDECK ID>, HWHPPH.
+*CMZ :- -12/01/93 10.12.43 by Bryan Webber
+*-- Author : Ian Knowles
+C-----------------------------------------------------------------------
+ SUBROUTINE HWHPPH
+C-----------------------------------------------------------------------
+C Point-like photon/gluon heavy flavour pair production, with
+C exact lightcone massive kinematics, mean EVWGT = sigma in nb.
+C-----------------------------------------------------------------------
+ INCLUDE 'HERWIG61.INC'
+ DOUBLE PRECISION HWRUNI,HWUALF,EPS,PP1,PP2,QM2,FACTR,ET,EJ,ET2,
+ & EXY,EXY2,S,T,U,C
+ INTEGER IQ1,IHAD1,IHAD2
+ EXTERNAL HWRUNI,HWUALF
+ SAVE PP1,PP2,IQ1,QM2,FACTR
+ PARAMETER (EPS=1.E-9)
+ IHAD1=1
+ IF (JDAHEP(1,IHAD1).NE.0) IHAD1=JDAHEP(1,IHAD1)
+ IHAD2=2
+ IF (JDAHEP(1,IHAD2).NE.0) IHAD2=JDAHEP(1,IHAD2)
+ IF (FSTWGT.OR.IHAD1.NE.1.OR.IHAD2.NE.2) THEN
+ PP1=PHEP(4,IHAD1)+ABS(PHEP(3,IHAD1))
+ PP2=PHEP(4,IHAD2)+ABS(PHEP(3,IHAD2))
+ XX(1)=1.
+ IQ1=MOD(IPROC,100)
+ QM2=RMASS(IQ1)**2
+ IHPRO=53
+ FACTR=-GEV2NB*(YJMAX-YJMIN)*.5*PIFAC*ALPHEM*QFCH(IQ1)**2
+ ENDIF
+ IF (GENEV) THEN
+C Generate event
+ IDN(1)=59
+ IDN(2)=13
+ IDN(3)=IQ1
+ IDN(4)=IQ1+6
+ ICO(1)=1
+ ICO(2)=4
+ ICO(3)=2
+ ICO(4)=3
+ IDCMF=15
+ CALL HWETWO
+ ELSE
+C Select kinematics
+ EVWGT=0.
+ CALL HWRPOW(ET,EJ)
+ ET2=ET**2
+ EXY=EXP(HWRUNI(1,YJMIN,YJMAX))
+ EXY2=2.*PP1/ET-EXY
+ IF (EXY2.LT.EXP(YJMIN).OR.EXY2.GT.EXP(YJMAX)) RETURN
+ XX(2)=.5*ET*(1./EXY+1./EXY2)/PP2
+ IF (XX(2).LT.ZERO.OR.XX(2).GT.ONE) RETURN
+ S=XX(2)*PP1*PP2
+ IF (S.LT.ET2) RETURN
+C define: S=Shat, T=That-M**2, U=Uhat-M**2 (2p.g, -2p.Q, -2p.QBar)
+ T=-.5*PP1*ET/EXY
+ U=-S-T
+ COSTH=(T-U)/(S*SQRT(1.-4.*QM2/S))
+ EMSCA=SQRT(2.*S*T*U/(S*S+T*T+U*U))
+ CALL HWSFUN(XX(2),EMSCA,IDHW(IHAD2),NSTRU,DISF(1,2),2)
+C photon+g ---> Q+Qbar
+ IF (DISF(13,2).LT.EPS) THEN
+ EVWGT=0.
+ ELSE
+ C=QM2*S/(U*T)
+ EVWGT=FACTR*EJ*ET*HWUALF(1,EMSCA)
+ & *DISF(13,2)*(T/U+U/T+4.*C*(1.-C))/(S*T)
+ ENDIF
+ ENDIF
+ 999 END
+CDECK ID>, HWHPPM.
+*CMZ :- -09/12/93 15.50.26 by Mike Seymour
+*-- Author : Ian Knowles & Mike Seymour
+C-----------------------------------------------------------------------
+ SUBROUTINE HWHPPM
+C-----------------------------------------------------------------------
+C Point-like photon/QCD direct meson production
+C See M. Benayoun, et al., Nucl. Phys. B282 (1987) 653 for details.
+C mean EVWGT = sigma in nb
+C-----------------------------------------------------------------------
+ INCLUDE 'HERWIG61.INC'
+ DOUBLE PRECISION HWR,HWRUNI,HWUALF,EPS,PP1,PP2,ET,EJ,EXY,EXY2,
+ & FACT,FACTR,S,T,U,REDS,DELT(3,3),C1STU,C3STU,HCS,RCS,CMIX,SMIX,
+ & C1WVFN,FPI,FETA8,FETA1,FRHO,FPHI8,FPHI1,FPI2,FETA2(3),FETAP2(3),
+ 7 FRHO2,FPHI2(3),FOMEG2(3)
+ INTEGER MNAME(3,3,2),N4(3),I,J,ID2,ID4,I2,I4,M1,M2,IHAD1,IHAD2
+ LOGICAL SPIN0,SPIN1
+ EXTERNAL HWR,HWRUNI,HWUALF
+ SAVE FPI2,FETA2,FETAP2,FRHO2,FPHI2,FOMEG2,HCS,REDS,FACT,DELT,
+ & C1STU,C3STU
+ PARAMETER (EPS=1.D-20)
+ DATA MNAME/21,38,42,30,21,34,50,46,0,23,39,43,31,23,35,51,47,0/
+ DATA N4,SPIN0,SPIN1/3,3,2,.TRUE.,.TRUE./
+ DATA C1WVFN,FPI,FETA8,FETA1,FRHO,FPHI8,FPHI1/1.,3*0.093,3*0.107/
+ IF (FSTWGT) THEN
+ FPI2=FPI**2
+ CMIX=COS(ETAMIX*PIFAC/180.D0)
+ SMIX=SIN(ETAMIX*PIFAC/180.D0)
+ FETA2(1) =(+CMIX*FETA8/SQRT(TWO)-SMIX*FETA1)**2/THREE
+ FETA2(2) =FETA2(1)
+ FETA2(3) =(-CMIX*FETA8*SQRT(TWO)-SMIX*FETA1)**2/THREE
+ FETAP2(1)=(+SMIX*FETA8/SQRT(TWO)+CMIX*FETA1)**2/THREE
+ FETAP2(2)=FETAP2(1)
+ FETAP2(3)=(-SMIX*FETA8*SQRT(TWO)+CMIX*FETA1)**2/THREE
+ FRHO2=FRHO**2
+ CMIX=COS(PHIMIX*PIFAC/180.D0)
+ SMIX=SIN(PHIMIX*PIFAC/180.D0)
+ FPHI2(1) =(+CMIX*FPHI8/SQRT(TWO)-SMIX*FPHI1)**2/THREE
+ FPHI2(2) =FPHI2(1)
+ FPHI2(3) =(-CMIX*FPHI8*SQRT(TWO)-SMIX*FPHI1)**2/THREE
+ FOMEG2(1)=(+SMIX*FPHI8/SQRT(TWO)+CMIX*FPHI1)**2/THREE
+ FOMEG2(2)=FOMEG2(1)
+ FOMEG2(3)=(-SMIX*FPHI8*SQRT(TWO)+CMIX*FPHI1)**2/THREE
+ ENDIF
+ SPIN0=.NOT.(MOD(IPROC/10,10).EQ.2)
+ SPIN1=.NOT.(MOD(IPROC/10,10).EQ.1)
+ IF (GENEV) THEN
+ RCS=HCS*HWR()
+ ELSE
+ EVWGT=ZERO
+ IHAD1=1
+ IF (JDAHEP(1,IHAD1).NE.0) IHAD1=JDAHEP(1,IHAD1)
+ IHAD2=2
+ IF (JDAHEP(1,IHAD2).NE.0) IHAD2=JDAHEP(1,IHAD2)
+ PP1=PHEP(4,IHAD1)+ABS(PHEP(3,IHAD1))
+ PP2=PHEP(4,IHAD2)+ABS(PHEP(3,IHAD2))
+ XX(1)=ONE
+ CALL HWRPOW(ET,EJ)
+ EXY=EXP(HWRUNI(1,YJMIN,YJMAX))
+ EXY2=TWO*PP1/ET-EXY
+ IF (EXY2.LE.EXP(YJMIN).OR.EXY2.GE.EXP(YJMAX)) RETURN
+ XX(2)=PP1/(PP2*EXY*EXY2)
+ IF (XX(2).LE.ZERO.OR.XX(2).GE.ONE) RETURN
+ S=XX(2)*PP1*PP2
+ REDS=SQRT(S-ET*SQRT(S))
+ T=-HALF*PP1*ET/EXY
+ U=-S-T
+ COSTH=(T-U)/S
+C Set EMSCA to hard process scale (Approx ET-jet)
+ EMSCA=SQRT(TWO*S*T*U/(S*S+T*T+U*U))
+ FACT=-GEV2NB*ET*EJ*(YJMAX-YJMIN)*ALPHEM*CFFAC
+ & *(HWUALF(1,EMSCA)*PIFAC*C1WVFN)**2*32.D0/(THREE*S*T)
+ CALL HWSFUN(XX(2),EMSCA,IDHW(IHAD2),NSTRU,DISF(1,2),2)
+ DO 10 I=1,3
+ DO 10 J=1,3
+ 10 DELT(I,J)=(QFCH(I)*U+QFCH(J)*S)**2
+ C1STU=-(S**2+U**2)/(T*S**2*U**2)
+ C3STU=-8.D0*T/(S**2*U**2)
+ ENDIF
+ HCS=ZERO
+ DO 50 I2=1,3
+C Quark initiated processes
+ ID2=I2
+ IF (DISF(ID2,2).LT.EPS) GOTO 30
+ DO 20 ID4=1,N4(I2)
+ M1=MNAME(ID2,ID4,1)
+ FACTR=FACT*DELT(ID2,ID4)*DISF(ID2,2)
+ IF (ID2.EQ.ID4) FACTR=HALF*FACTR
+ IF (SPIN0.AND.REDS.GT.RMASS(M1)) THEN
+C photon+q --> meson_0+q'
+ HCS=HCS+HALF*FACTR*C1STU*FPI2
+ IF (GENEV.AND.HCS.GT.RCS) CALL HWHQCP(M1,ID4,1432,71,*99)
+ ENDIF
+ M2=MNAME(ID2,ID4,2)
+ IF (SPIN1.AND.REDS.GT.RMASS(M2)) THEN
+C photon+q --> meson_L+q'
+ HCS=HCS+FACTR*C1STU*FRHO2
+ IF (GENEV.AND.HCS.GT.RCS) CALL HWHQCP(M2,ID4,1432,72,*99)
+C photon+q --> meson_T+q'
+ HCS=HCS+FACTR*C3STU*FRHO2
+ IF (GENEV.AND.HCS.GT.RCS) CALL HWHQCP(M2,ID4,1432,73,*99)
+ ENDIF
+ 20 CONTINUE
+ FACTR=FACT*DELT(I2,I2)*DISF(ID2,2)
+ IF (SPIN0.AND.REDS.GT.RMASS(22)) THEN
+C photon+q -->eta+q
+ HCS=HCS+HALF*FACTR*C1STU*FETA2(I2)
+ IF (GENEV.AND.HCS.GT.RCS) CALL HWHQCP(22,ID2,1432,71,*99)
+ ENDIF
+ IF (SPIN0.AND.REDS.GT.RMASS(25)) THEN
+C photon+q -->eta'+q
+ HCS=HCS+HALF*FACTR*C1STU*FETAP2(I2)
+ IF (GENEV.AND.HCS.GT.RCS) CALL HWHQCP(25,ID2,1432,71,*99)
+ ENDIF
+ IF (SPIN1.AND.REDS.GT.RMASS(56)) THEN
+C photon+q -->phi_L+q
+ HCS=HCS+FACTR*C1STU*FPHI2(I2)
+ IF (GENEV.AND.HCS.GT.RCS) CALL HWHQCP(56,ID2,1432,72,*99)
+C photon+q -->phi_T+q
+ HCS=HCS+FACTR*C3STU*FPHI2(I2)
+ IF (GENEV.AND.HCS.GT.RCS) CALL HWHQCP(56,ID2,1432,73,*99)
+ ENDIF
+ IF (SPIN1.AND.REDS.GT.RMASS(24)) THEN
+C photon+q -->omega_L+q
+ HCS=HCS+FACTR*C1STU*FOMEG2(I2)
+ IF (GENEV.AND.HCS.GT.RCS) CALL HWHQCP(24,ID2,1432,72,*99)
+C photon+q -->omega_T+q
+ HCS=HCS+FACTR*C3STU*FOMEG2(I2)
+ IF (GENEV.AND.HCS.GT.RCS) CALL HWHQCP(24,ID2,1432,73,*99)
+ ENDIF
+C Anti-quark initiated processes
+ 30 ID2=I2+6
+ IF (DISF(ID2,2).LT.EPS) GOTO 50
+ DO 40 I4=1,N4(I2)
+ ID4=I4+6
+ FACTR=FACT*DELT(I2,I4)*DISF(ID2,2)
+ IF (ID2.EQ.ID4) FACTR=HALF*FACTR
+ M1=MNAME(I4,I2,1)
+ IF (SPIN0.AND.REDS.GT.RMASS(M1)) THEN
+C photon+qbar --> meson_0+qbar'
+ HCS=HCS+HALF*FACTR*C1STU*FPI2
+ IF (GENEV.AND.HCS.GT.RCS) CALL HWHQCP(M1,ID4,1432,74,*99)
+ ENDIF
+ M2=MNAME(I4,I2,2)
+ IF (SPIN1.AND.REDS.GT.RMASS(M2)) THEN
+C photon+qbar --> meson_L+qbar'
+ HCS=HCS+FACTR*C1STU*FRHO2
+ IF (GENEV.AND.HCS.GT.RCS) CALL HWHQCP(M2,ID4,1432,75,*99)
+C photon+qbar --> meson_T+qbar'
+ HCS=HCS+FACTR*C3STU*FRHO2
+ IF (GENEV.AND.HCS.GT.RCS) CALL HWHQCP(M2,ID4,1432,76,*99)
+ ENDIF
+ 40 CONTINUE
+ FACTR=FACT*DELT(I2,I2)*DISF(ID2,2)
+ IF (SPIN0.AND.REDS.GT.RMASS(22)) THEN
+C photon+qbar -->eta+qbar
+ HCS=HCS+HALF*FACTR*C1STU*FETA2(I2)
+ IF (GENEV.AND.HCS.GT.RCS) CALL HWHQCP(22,ID2,1432,74,*99)
+ ENDIF
+ IF (SPIN0.AND.REDS.GT.RMASS(25)) THEN
+C photon+qbar -->eta'+qbar
+ HCS=HCS+HALF*FACTR*C1STU*FETAP2(I2)
+ IF (GENEV.AND.HCS.GT.RCS) CALL HWHQCP(25,ID2,1432,74,*99)
+ ENDIF
+ IF (SPIN1.AND.REDS.GT.RMASS(56)) THEN
+C photon+qbar -->phi_L+qbar
+ HCS=HCS+FACTR*C1STU*FPHI2(I2)
+ IF (GENEV.AND.HCS.GT.RCS) CALL HWHQCP(56,ID2,1432,75,*99)
+C photon+qbar -->phi_T+qbar
+ HCS=HCS+FACTR*C3STU*FPHI2(I2)
+ IF (GENEV.AND.HCS.GT.RCS) CALL HWHQCP(56,ID2,1432,76,*99)
+ ENDIF
+ IF (SPIN1.AND.REDS.GT.RMASS(24)) THEN
+C photon+qbar -->omega_L+qbar
+ HCS=HCS+FACTR*C1STU*FOMEG2(I2)
+ IF (GENEV.AND.HCS.GT.RCS) CALL HWHQCP(24,ID2,1432,75,*99)
+C photon+qbar -->omega_T+qbar
+ HCS=HCS+FACTR*C3STU*FOMEG2(I2)
+ IF (GENEV.AND.HCS.GT.RCS) CALL HWHQCP(24,ID2,1432,76,*99)
+ ENDIF
+ 50 CONTINUE
+ EVWGT=HCS
+ RETURN
+C Generate event
+ 99 IDN(1)=59
+ IDN(2)=ID2
+ IDCMF=15
+ CALL HWETWO
+C Set polarization vector
+ IF (IHPRO.EQ.72.OR.IHPRO.EQ.75) THEN
+ RHOHEP(2,NHEP-1)=ONE
+ ELSEIF (IHPRO.EQ.73.OR.IHPRO.EQ.76) THEN
+ RHOHEP(1,NHEP-1)=HALF
+ RHOHEP(3,NHEP-1)=HALF
+ ENDIF
+ 999 END
+CDECK ID>, HWHPPT.
+*CMZ :- -12/01/93 10.12.43 by Bryan Webber
+*-- Author : Ian Knowles
+C-----------------------------------------------------------------------
+ SUBROUTINE HWHPPT
+C-----------------------------------------------------------------------
+C point-like photon/QCD di-jet production: mean EVWGT = sigma in nb
+C-----------------------------------------------------------------------
+ INCLUDE 'HERWIG61.INC'
+ DOUBLE PRECISION HWR,HWRUNI,HWUALF,EPS,RCS,PP1,PP2,ET,EJ,
+ & EXY,EXY2,FACTR,RS,S,T,U,CSTU,CTSU,HCS
+ INTEGER ID1,ID2,ID3,ID4,IHAD1,IHAD2
+ EXTERNAL HWR,HWRUNI,HWUALF
+ SAVE CSTU,CTSU,HCS,FACTR,RS
+ PARAMETER (EPS=1.E-9)
+ IHAD1=1
+ IF (JDAHEP(1,IHAD1).NE.0) IHAD1=JDAHEP(1,IHAD1)
+ IHAD2=2
+ IF (JDAHEP(1,IHAD2).NE.0) IHAD2=JDAHEP(1,IHAD2)
+ IF (GENEV) THEN
+ RCS=HCS*HWR()
+ ELSE
+ EVWGT=0.
+ PP1=PHEP(4,IHAD1)+ABS(PHEP(3,IHAD1))
+ PP2=PHEP(4,IHAD2)+ABS(PHEP(3,IHAD2))
+ XX(1)=1.
+ CALL HWRPOW(ET,EJ)
+ EXY=EXP(HWRUNI(1,YJMIN,YJMAX))
+ EXY2=2.*PP1/ET-EXY
+ IF (EXY2.LE.EXP(YJMIN).OR.EXY2.GE.EXP(YJMAX)) RETURN
+ XX(2)=PP1/(PP2*EXY*EXY2)
+ IF (XX(2).LE.ZERO.OR.XX(2).GE.ONE) RETURN
+ S=XX(2)*PP1*PP2
+ RS=.5*SQRT(S)
+ T=-PP1*0.5*ET/EXY
+ U=-S-T
+ COSTH=(T-U)/S
+C Set EMSCA to hard process scale (Approx ET-jet)
+ EMSCA=SQRT(2.*S*T*U/(S*S+T*T+U*U))
+ FACTR=-GEV2NB*0.5*EJ*(YJMAX-YJMIN)*ET*PIFAC*ALPHEM
+ & *HWUALF(1,EMSCA)/(S*T)
+ CALL HWSFUN(XX(2),EMSCA,IDHW(IHAD2),NSTRU,DISF(1,2),2)
+ CSTU=U/T+T/U
+ CTSU=-2.*CFFAC*(U/S+S/U)
+ ENDIF
+ HCS=0.
+ ID1=59
+ DO 20 ID2=1,13
+ IF (DISF(ID2,2).LT.EPS) GOTO 20
+ IF (ID2.LT.7) THEN
+C photon+q ---> g+q
+ HCS=HCS+CTSU*DISF(ID2,2)*QFCH(ID2)**2
+ IF (GENEV.AND.HCS.GT.RCS) CALL HWHQCP( 13,ID2,1423,51,*99)
+ ELSEIF (ID2.LT.13) THEN
+C photon+qbar ---> g+qbar
+ HCS=HCS+CTSU*DISF(ID2,2)*QFCH(ID2-6)**2
+ IF (GENEV.AND.HCS.GT.RCS) CALL HWHQCP( 13,ID2,1342,52,*99)
+ ELSE
+C photon+g ---> q+qbar
+ DO 10 ID3=1,6
+ IF (RS.GT.RMASS(ID3)) THEN
+ ID4=ID3+6
+ HCS=HCS+CSTU*DISF(ID2,2)*QFCH(ID3)**2
+ IF (GENEV.AND.HCS.GT.RCS) CALL HWHQCP(ID3,ID4,1423,53,*99)
+ ENDIF
+ 10 CONTINUE
+ ENDIF
+ 20 CONTINUE
+ EVWGT=FACTR*HCS
+ RETURN
+C Generate event
+ 99 IDN(1)=ID1
+ IDN(2)=ID2
+ IDCMF=15
+ CALL HWETWO
+ 999 END
+CDECK ID>, HWHPQS.
+*CMZ :- -27/03/95 13.27.22 by Mike Seymour
+*-- Author : Ian Knowles
+C-----------------------------------------------------------------------
+ SUBROUTINE HWHPQS
+C-----------------------------------------------------------------------
+C Compton scattering of point-like photon and (anti)quark
+C mean EVWGT = sigma in nb
+C-----------------------------------------------------------------------
+ INCLUDE 'HERWIG61.INC'
+ DOUBLE PRECISION HWR,HWRUNI,EPS,RCS,PP1,PP2,ET,EJ,EXY,EXY2,
+ & FACTR,S,T,U,CTSU,HCS
+ INTEGER ID1,ID2,IHAD1,IHAD2
+ EXTERNAL HWR,HWRUNI
+ SAVE CTSU,HCS,FACTR
+ PARAMETER (EPS=1.E-9)
+ IHAD1=1
+ IF (JDAHEP(1,IHAD1).NE.0) IHAD1=JDAHEP(1,IHAD1)
+ IHAD2=2
+ IF (JDAHEP(1,IHAD2).NE.0) IHAD2=JDAHEP(1,IHAD2)
+ IF (GENEV) THEN
+ RCS=HCS*HWR()
+ ELSE
+ EVWGT=0.
+ PP1=PHEP(4,IHAD1)+ABS(PHEP(3,IHAD1))
+ PP2=PHEP(4,IHAD2)+ABS(PHEP(3,IHAD2))
+ XX(1)=1.
+ CALL HWRPOW(ET,EJ)
+ EXY=EXP(HWRUNI(1,YJMIN,YJMAX))
+ EXY2=2.*PP1/ET-EXY
+ IF (EXY2.LE.EXP(YJMIN).OR.EXY2.GE.EXP(YJMAX)) RETURN
+ XX(2)=PP1/(PP2*EXY*EXY2)
+ IF (XX(2).LE.ZERO.OR.XX(2).GE.ONE) RETURN
+ S=XX(2)*PP1*PP2
+ T=-PP1*0.5*ET/EXY
+ U=-S-T
+ COSTH=(T-U)/S
+C Set EMSCA to hard process scale (Approx ET-jet)
+ EMSCA=SQRT(2.*S*T*U/(S*S+T*T+U*U))
+ FACTR=-GEV2NB*0.5*EJ*(YJMAX-YJMIN)*ET*PIFAC*ALPHEM**2/(S*T)
+ CALL HWSFUN(XX(2),EMSCA,IDHW(IHAD2),NSTRU,DISF(1,2),2)
+ CTSU=-2.*(U/S+S/U)
+ ENDIF
+ HCS=0.
+ ID1=59
+ DO 20 ID2=1,12
+ IF (DISF(ID2,2).LT.EPS) GOTO 20
+ IF (ID2.LT.7) THEN
+C photon+q ---> photon+q
+ HCS=HCS+CTSU*DISF(ID2,2)*QFCH(ID2)**4
+ IF (GENEV.AND.HCS.GT.RCS) CALL HWHQCP( 59,ID2,1432,66,*99)
+ ELSE
+C photon+qbar ---> photon+qbar
+ HCS=HCS+CTSU*DISF(ID2,2)*QFCH(ID2-6)**4
+ IF (GENEV.AND.HCS.GT.RCS) CALL HWHQCP( 59,ID2,1432,67,*99)
+ ENDIF
+ 20 CONTINUE
+ EVWGT=FACTR*HCS
+ RETURN
+C Generate event
+ 99 IDN(1)=ID1
+ IDN(2)=ID2
+ IDCMF=15
+ CALL HWETWO
+ 999 END
+CDECK ID>, HWHQCD.
+*CMZ :- -20/05/99 12.39.45 by Kosuke Odagiri
+*-- Author : Bryan Webber
+C-----------------------------------------------------------------------
+ SUBROUTINE HWHQCD
+C-----------------------------------------------------------------------
+C QCD HARD 2->2 PROCESSES: MEAN EVWGT = SIGMA IN NB
+C-----------------------------------------------------------------------
+ INCLUDE 'HERWIG61.INC'
+ DOUBLE PRECISION HWR,HWRUNI,HWUALF,RS,EPS,HF,RCS,Z1,Z2,ET,EJ,
+ & FACTR,S,T,U,ST,TU,US,STU,TUS,UST,EN,RN,GFLA,AF,ASTU,ASUT,AUST,
+ & BF,BSTU,BSUT,BUST,BUTS,CF,CSTU,CSUT,CTSU,CTUS,DF,DSTU,DTSU,DUTS,
+ & DIST,HCS,UT,SU,GT,KK,KK2,YJ1INF,YJ1SUP,YJ2INF,YJ2SUP
+ INTEGER ID1,ID2,I
+ EXTERNAL HWR,HWRUNI,HWUALF
+ SAVE HCS,ASTU,AUST,BSTU,BSUT,BUST,BUTS,CSTU,CSUT,CTSU,CTUS,
+ & DSTU,DTSU,DUTS,GFLA,RCS,S,T,TU,U,US
+ PARAMETER (EPS=1.E-9,HF=0.5)
+ IF (GENEV) THEN
+ RCS=HCS*HWR()
+ ELSE
+ EVWGT=0.
+ CALL HWRPOW(ET,EJ)
+ KK = ET/PHEP(5,3)
+ KK2=KK**2
+ IF (KK.GE.ONE) RETURN
+ YJ1INF = MAX( YJMIN, LOG((ONE-SQRT(ONE-KK2))/KK) )
+ YJ1SUP = MIN( YJMAX, LOG((ONE+SQRT(ONE-KK2))/KK) )
+ IF (YJ1INF.GE.YJ1SUP) RETURN
+ Z1=EXP(HWRUNI(1,YJ1INF,YJ1SUP))
+ YJ2INF = MAX( YJMIN, -LOG(TWO/KK-ONE/Z1) )
+ YJ2SUP = MIN( YJMAX, LOG(TWO/KK-Z1) )
+ IF (YJ2INF.GE.YJ2SUP) RETURN
+ Z2=EXP(HWRUNI(2,YJ2INF,YJ2SUP))
+ XX(1)=.5*(Z1+Z2)*KK
+ IF (XX(1).GE.ONE) RETURN
+ XX(2)=XX(1)/(Z1*Z2)
+ IF (XX(2).GE.ONE) RETURN
+ COSTH=(Z1-Z2)/(Z1+Z2)
+ S=XX(1)*XX(2)*PHEP(5,3)**2
+ RS=HF*SQRT(S)
+ DO 3 I=1,NFLAV
+ IF (RS.LT.RMASS(I)) GOTO 4
+ 3 CONTINUE
+ I=NFLAV+1
+ 4 MAXFL=I-1
+ IF (MAXFL.EQ.0) CALL HWWARN('HWHQCD',100,*999)
+C
+ T=-HF*S*(1.-COSTH)
+ U=-S-T
+C---SET EMSCA TO HARD PROCESS SCALE (APPROX ET-JET)
+ EMSCA=SQRT(2.*S*T*U/(S*S+T*T+U*U))
+ FACTR = GEV2NB*.5*PIFAC*EJ*ET*(HWUALF(1,EMSCA)/S)**2
+ & * (YJ1SUP-YJ1INF)*(YJ2SUP-YJ2INF)
+ CALL HWSGEN(.FALSE.)
+C
+ ST=S/T
+ TU=T/U
+ US=U/S
+ STU=TU/US
+ TUS=US/ST
+ UST=ST/TU
+C
+ EN=CAFAC
+ RN=CFFAC/EN
+ GFLA=HF*FLOAT(MAXFL)/(EN*RN)**2
+ AF=FACTR*RN
+ ASTU=AF*(1.-2.*UST)
+ ASUT=AF*(1.-2.*STU)
+ AUST=AF*(1.-2.*TUS)
+C-----------------------------------------------------------------------
+C---Colour decomposition modifications below (KO)
+C-----------------------------------------------------------------------
+ BF=HF-AF/EN/TUS/(ASTU+ASUT)
+ BSTU=BF*ASTU
+ BSUT=BF*ASUT
+ BF=ONE-TWO*AF/EN/STU/(AUST+ASTU)
+ BUST=BF*AUST
+ BUTS=BF*ASTU
+C-----------------------------------------------------------------------
+C BF=2.*AF/EN
+C BSTU=HF*(ASTU+BF*ST)
+C BSUT=HF*(ASUT+BF/US)
+C BUST=AUST+BF*US
+C BUTS=ASTU+BF/TU
+C-----------------------------------------------------------------------
+ CF=AF*EN
+ CSTU=(CF*(RN-TUS))/TU
+ CSUT=(CF*(RN-TUS))*TU
+ CTSU=(FACTR*(UST-RN))*US
+ CTUS=(FACTR*(UST-RN))/US
+ DF=HF*FACTR/RN
+ DSTU=DF*(1.+1./TUS-STU-UST)
+ DTSU=DF*(1.+1./UST-STU-TUS)
+ DUTS=DF*(1.+1./STU-UST-TUS)
+ ENDIF
+C
+ HCS=0.
+ DO 6 ID1=1,13
+ IF (DISF(ID1,1).LT.EPS) GOTO 6
+ DO 5 ID2=1,13
+ IF (DISF(ID2,2).LT.EPS) GOTO 5
+ DIST=DISF(ID1,1)*DISF(ID2,2)
+ IF (ID1.LT.7) THEN
+C---QUARK FIRST
+ IF (ID2.LT.7) THEN
+ IF (ID1.NE.ID2) THEN
+ HCS=HCS+ASTU*DIST
+ IF (GENEV.AND.HCS.GT.RCS) CALL HWHQCP(ID1,ID2,3421, 3,*9)
+ ELSE
+ HCS=HCS+BSTU*DIST
+ IF (GENEV.AND.HCS.GT.RCS) CALL HWHQCP(ID1,ID2,3421, 1,*9)
+ HCS=HCS+BSUT*DIST
+ IF (GENEV.AND.HCS.GT.RCS) CALL HWHQCP(ID1,ID2,4312, 2,*9)
+ ENDIF
+ ELSEIF (ID2.NE.13) THEN
+ IF (ID2.NE.ID1+6) THEN
+ HCS=HCS+ASTU*DIST
+ IF (GENEV.AND.HCS.GT.RCS) CALL HWHQCP(ID1,ID2,3142, 9,*9)
+ ELSE
+ HCS=HCS+FLOAT(MAXFL-1)*AUST*DIST
+ IF (GENEV.AND.HCS.GT.RCS) CALL HWHQCP(-ID1, 0,2413, 4,*9)
+ HCS=HCS+BUTS*DIST
+ IF (GENEV.AND.HCS.GT.RCS) CALL HWHQCP(ID1,ID2,3142, 5,*9)
+ HCS=HCS+BUST*DIST
+ IF (GENEV.AND.HCS.GT.RCS) CALL HWHQCP(ID1,ID2,2413, 6,*9)
+ HCS=HCS+CSTU*DIST
+ IF (GENEV.AND.HCS.GT.RCS) CALL HWHQCP( 13, 13,2413, 7,*9)
+ HCS=HCS+CSUT*DIST
+ IF (GENEV.AND.HCS.GT.RCS) CALL HWHQCP( 13, 13,2341, 8,*9)
+ ENDIF
+ ELSE
+ HCS=HCS+CTSU*DIST
+ IF (GENEV.AND.HCS.GT.RCS) CALL HWHQCP(ID1,ID2,3142,10,*9)
+ HCS=HCS+CTUS*DIST
+ IF (GENEV.AND.HCS.GT.RCS) CALL HWHQCP(ID1,ID2,3421,11,*9)
+ ENDIF
+ ELSEIF (ID1.NE.13) THEN
+C---QBAR FIRST
+ IF (ID2.LT.7) THEN
+ IF (ID1.NE.ID2+6) THEN
+ HCS=HCS+ASTU*DIST
+ IF (GENEV.AND.HCS.GT.RCS) CALL HWHQCP(ID1,ID2,2413,17,*9)
+ ELSE
+ HCS=HCS+FLOAT(MAXFL-1)*AUST*DIST
+ IF (GENEV.AND.HCS.GT.RCS) CALL HWHQCP(-ID1, 0,3142,12,*9)
+ HCS=HCS+BUTS*DIST
+ IF (GENEV.AND.HCS.GT.RCS) CALL HWHQCP(ID1,ID2,2413,13,*9)
+ HCS=HCS+BUST*DIST
+ IF (GENEV.AND.HCS.GT.RCS) CALL HWHQCP(ID1,ID2,3142,14,*9)
+ HCS=HCS+CSTU*DIST
+ IF (GENEV.AND.HCS.GT.RCS) CALL HWHQCP( 13, 13,3142,15,*9)
+ HCS=HCS+CSUT*DIST
+ IF (GENEV.AND.HCS.GT.RCS) CALL HWHQCP( 13, 13,4123,16,*9)
+ ENDIF
+ ELSEIF (ID2.NE.13) THEN
+ IF (ID1.NE.ID2) THEN
+ HCS=HCS+ASTU*DIST
+ IF (GENEV.AND.HCS.GT.RCS) CALL HWHQCP(ID1,ID2,4312,20,*9)
+ ELSE
+ HCS=HCS+BSTU*DIST
+ IF (GENEV.AND.HCS.GT.RCS) CALL HWHQCP(ID1,ID2,4312,18,*9)
+ HCS=HCS+BSUT*DIST
+ IF (GENEV.AND.HCS.GT.RCS) CALL HWHQCP(ID1,ID2,3421,19,*9)
+ ENDIF
+ ELSE
+ HCS=HCS+CTSU*DIST
+ IF (GENEV.AND.HCS.GT.RCS) CALL HWHQCP(ID1,ID2,2413,21,*9)
+ HCS=HCS+CTUS*DIST
+ IF (GENEV.AND.HCS.GT.RCS) CALL HWHQCP(ID1,ID2,4312,22,*9)
+ ENDIF
+ ELSE
+C---GLUON FIRST
+ IF (ID2.LT.7) THEN
+ HCS=HCS+CTSU*DIST
+ IF (GENEV.AND.HCS.GT.RCS) CALL HWHQCP(ID1,ID2,2413,23,*9)
+ HCS=HCS+CTUS*DIST
+ IF (GENEV.AND.HCS.GT.RCS) CALL HWHQCP(ID1,ID2,3421,24,*9)
+ ELSEIF (ID2.LT.13) THEN
+ HCS=HCS+CTSU*DIST
+ IF (GENEV.AND.HCS.GT.RCS) CALL HWHQCP(ID1,ID2,3142,25,*9)
+ HCS=HCS+CTUS*DIST
+ IF (GENEV.AND.HCS.GT.RCS) CALL HWHQCP(ID1,ID2,4312,26,*9)
+ ELSE
+ HCS=HCS+GFLA*CSTU*DIST
+ IF (GENEV.AND.HCS.GT.RCS) CALL HWHQCP( 0, 0,2413,27,*9)
+ HCS=HCS+GFLA*CSUT*DIST
+ IF (GENEV.AND.HCS.GT.RCS) CALL HWHQCP( 0, 0,4123,28,*9)
+ HCS=HCS+DTSU*DIST
+ IF (GENEV.AND.HCS.GT.RCS) CALL HWHQCP(ID1,ID2,2341,29,*9)
+ HCS=HCS+DSTU*DIST
+ IF (GENEV.AND.HCS.GT.RCS) CALL HWHQCP(ID1,ID2,3421,30,*9)
+ HCS=HCS+DUTS*DIST
+ IF (GENEV.AND.HCS.GT.RCS) CALL HWHQCP(ID1,ID2,2413,31,*9)
+ ENDIF
+ ENDIF
+ 5 CONTINUE
+ 6 CONTINUE
+ EVWGT=HCS
+ RETURN
+C---GENERATE EVENT
+ 9 IDN(1)=ID1
+ IDN(2)=ID2
+ IDCMF=15
+ CALL HWETWO
+ IF (AZSPIN) THEN
+C Calculate coefficients for constructing spin density matrices
+ IF (IHPRO.EQ.7 .OR.IHPRO.EQ.8 .OR.
+ & IHPRO.EQ.15.OR.IHPRO.EQ.16) THEN
+C qqbar-->gg or qbarq-->gg
+ UT=1./TU
+ GCOEF(1)=UT+TU
+ GCOEF(2)=-2.
+ GCOEF(3)=0.
+ GCOEF(4)=0.
+ GCOEF(5)=GCOEF(1)
+ GCOEF(6)=UT-TU
+ GCOEF(7)=-GCOEF(6)
+ ELSEIF (IHPRO.EQ.10.OR.IHPRO.EQ.11.OR.
+ & IHPRO.EQ.21.OR.IHPRO.EQ.22.OR.
+ & IHPRO.EQ.23.OR.IHPRO.EQ.24.OR.
+ & IHPRO.EQ.25.OR.IHPRO.EQ.26) THEN
+C qg-->qg or qbarg-->qbarg or gq-->gq or gqbar-->gqbar
+ SU=1./US
+ GCOEF(1)=-(SU+US)
+ GCOEF(2)=0.
+ GCOEF(3)=2.
+ GCOEF(4)=0.
+ GCOEF(5)=SU-US
+ GCOEF(6)=GCOEF(1)
+ GCOEF(7)=-GCOEF(5)
+ ELSEIF (IHPRO.EQ.27.OR.IHPRO.EQ.28) THEN
+C gg-->qqbar
+ UT=1./TU
+ GCOEF(1)=TU+UT
+ GCOEF(2)=-2.
+ GCOEF(3)=0.
+ GCOEF(4)=0.
+ GCOEF(5)=GCOEF(1)
+ GCOEF(6)=TU-UT
+ GCOEF(7)=-GCOEF(6)
+ ELSEIF (IHPRO.EQ.29.OR.IHPRO.EQ.30.OR.
+ & IHPRO.EQ.31) THEN
+C gg-->gg
+ GT=S*S+T*T+U*U
+ GCOEF(2)=2.*U*U*T*T
+ GCOEF(3)=2.*S*S*U*U
+ GCOEF(4)=2.*S*S*T*T
+ GCOEF(1)=GT*GT-GCOEF(2)-GCOEF(3)-GCOEF(4)
+ GCOEF(5)=GT*(GT-2.*S*S)-GCOEF(2)
+ GCOEF(6)=GT*(GT-2.*T*T)-GCOEF(3)
+ GCOEF(7)=GT*(GT-2.*U*U)-GCOEF(4)
+ ELSE
+ CALL HWVZRO(7,GCOEF)
+ ENDIF
+ ENDIF
+ 999 END
+CDECK ID>, HWHQCP.
+*CMZ :- -26/04/91 10.18.57 by Bryan Webber
+*-- Author : Bryan Webber
+C-----------------------------------------------------------------------
+ SUBROUTINE HWHQCP(ID3,ID4,IPERM,IHPR,*)
+C-----------------------------------------------------------------------
+C IDENTIFIES HARD SUBPROCESS
+C-----------------------------------------------------------------------
+ INCLUDE 'HERWIG61.INC'
+ INTEGER HWRINT,ID3,ID4,IPERM,IHPR,ND3
+ EXTERNAL HWRINT
+ IHPRO=IHPR
+ IF (ID3.GT.0) THEN
+ IDN(3)=ID3
+ IDN(4)=ID4
+ ELSE
+ ND3=-ID3
+ IF (ID3.GT.-7) THEN
+ 1 IDN(3)=HWRINT(1,MAXFL)
+ IF (IDN(3).EQ.ND3) GOTO 1
+ IDN(4)=IDN(3)+6
+ ELSE
+ 2 IDN(3)=HWRINT(1,MAXFL)+6
+ IF (IDN(3).EQ.ND3) GOTO 2
+ IDN(4)=IDN(3)-6
+ ENDIF
+ ENDIF
+ ICO(1)=IPERM/1000
+ ICO(2)=IPERM/100-10*ICO(1)
+ ICO(3)=IPERM/10 -10*(IPERM/100)
+ ICO(4)=IPERM -10*(IPERM/10)
+ RETURN 1
+ END
+CDECK ID>, HWHQPM.
+*CMZ :- -27/07/95 14.13.56 by Mike Seymour
+*-- Author : Mike Seymour
+C-----------------------------------------------------------------------
+ SUBROUTINE HWHQPM
+C HARD PROCESS: GAMGAM --> QQBAR/LLBAR/W+W-
+C MEAN EVENT WEIGHT = CROSS-SECTION IN NB AFTER CUTS ON PT
+C-----------------------------------------------------------------------
+ INCLUDE 'HERWIG61.INC'
+ DOUBLE PRECISION RCS,HCS,RS,S,EMSQ,BE,TMIN,TMAX,T,U,FACTR,Q,CFAC,
+ $ HWR
+ INTEGER IHAD1,IHAD2,HQ,ID3,ID4,I1,I2
+ SAVE HCS,FACTR,HQ,RS
+ IHAD1=1
+ IF (JDAHEP(1,IHAD1).NE.0) IHAD1=JDAHEP(1,IHAD1)
+ IHAD2=2
+ IF (JDAHEP(1,IHAD2).NE.0) IHAD2=JDAHEP(1,IHAD2)
+ IF (GENEV) THEN
+ RCS=HCS*HWR()
+ ELSE
+ EVWGT=0.
+ RS=PHEP(5,3)
+ S=RS**2
+ HQ=MOD(IPROC,100)
+ IF (HQ.EQ.0) THEN
+ EMSQ=0
+ BE=1
+ CFAC=3
+ ELSE
+ IF (HQ.GT.6) HQ=2*HQ+107
+ IF (HQ.EQ.127) HQ=198
+ EMSQ=RMASS(HQ)**2
+ BE=1-4*EMSQ/S
+ IF (BE.LT.ZERO) RETURN
+ BE=SQRT(BE)
+ CFAC=1
+ IF (HQ.LE.6) CFAC=3
+ ENDIF
+ TMIN=S/2*(1-SQRT(MAX(1-4*(EMSQ+PTMIN**2)/S,ZERO)))
+ TMAX=S/2*(1-SQRT(MAX(1-4*(EMSQ+PTMAX**2)/S,ZERO)))
+ IF (TMIN.GE.TMAX) RETURN
+ T=-(TMAX/TMIN)**HWR()*TMIN
+ IF (HWR().GT.HALF) T=-S-T
+ U=-S-T
+ COSTH=(T-U)/(BE*S)
+ EMSCA=SQRT(2.*S*T*U/(S*S+T*T+U*U))
+ IF (HQ.NE.198) THEN
+ FACTR=-GEV2NB*2*LOG(TMAX/TMIN)*MAX(T,U)
+ $ *2*PIFAC*CFAC*ALPHEM**2/S**2
+ $ *((U-4*EMSQ)/T+(T-4*EMSQ)/U-4*(EMSQ/T+EMSQ/U)**2)
+ ELSE
+ FACTR=-GEV2NB*2*LOG(TMAX/TMIN)*MAX(T,U)
+ $ *6*PIFAC*CFAC*ALPHEM**2/S**2
+ $ *(1-S/(T*U)*(4D0/3*S+2*EMSQ)
+ $ +(S/(T*U))**2*(2D0/3*S**2+2*EMSQ**2))
+ ENDIF
+ ENDIF
+ HCS=0.
+ XX(1)=1.
+ XX(2)=1.
+ IF (HQ.EQ.0) THEN
+ I1=1
+ I2=6
+ ELSE
+ I1=HQ
+ I2=HQ
+ ENDIF
+ DO 10 ID3=I1,I2
+ IF (RS.GT.2*RMASS(ID3)) THEN
+ Q=ICHRG(ID3)
+ IF (HQ.LE.6) Q=Q/THREE
+ ID4=ID3+6
+ IF (HQ.EQ.198) ID4=199
+ HCS=HCS+Q**4
+ IF (GENEV.AND.HCS.GT.RCS) CALL HWHQCP(ID3,ID4,1243,61,*99)
+ ENDIF
+ 10 CONTINUE
+ EVWGT=FACTR*HCS
+ RETURN
+ 99 IDN(1)=59
+ IDN(2)=59
+ IDCMF=15
+ CALL HWETWO
+ END
+CDECK ID>, HWHRBB.
+*CMZ :- -20/10/99 09:46:43 by Peter Richardson
+*-- Author : Peter Richardson
+C-----------------------------------------------------------------------
+ SUBROUTINE HWHRBB
+C-----------------------------------------------------------------------
+C Subroutine for 2 parton -> 2 parton via UDD resonant squarks
+C-----------------------------------------------------------------------
+ INCLUDE 'HERWIG61.INC'
+ DOUBLE PRECISION HCS,S,RCS,HWR,MQ1,MQ2,TAU,LOWTLM,UPPTLM,RTAB,
+ & SQSH,MATELM,SCF(12),CHANPB(2),HWRUNI,PCM,MIX(12),
+ & ME(2,3,3,3,3),WD,MS(12),SWD(12),RAND,TAUA,
+ & CHAN(12),EPS,SH,FAC,TAUB,LAM(6,3,3,3,3),
+ & XMIN,XMAX,XPOW,XUPP,MS2(12),MSWD(12)
+ INTEGER I,J,K,L,I1,J1,K1,L1,N,THEP,CONECT(4,5),HWRINT,
+ & GENR,GN,MIG,MXG,GEN
+ LOGICAL FIRST
+ EXTERNAL HWR,HWRUNI
+ PARAMETER(EPS=1D-20)
+ COMMON/HWRPIN/XMIN,XMAX,XPOW,FIRST
+ SAVE HCS,ME,MS,SWD,CHAN,LAM,MIX,FAC,SH,SQSH,SCF,MS2,MSWD
+ DATA CONECT/1,1,3,4,-1,-1,2,3,0,0,0,0,1,1,-2,-3,-1,-1,-3,-4/
+ IF(GENEV) THEN
+ RCS = HCS*HWR()
+ ELSE
+ IF(FSTWGT) THEN
+C--Extract masses and width's needed
+ DO I=1,3
+ MS(2*I-1) = RMASS(399+2*I)
+ MS(2*I) = RMASS(411+2*I)
+ MS(2*I+5) = RMASS(400+2*I)
+ MS(2*I+6) = RMASS(412+2*I)
+ SWD(2*I-1) = HBAR/RLTIM(399+2*I)
+ SWD(2*I) = HBAR/RLTIM(411+2*I)
+ SWD(2*I+5) = HBAR/RLTIM(400+2*I)
+ SWD(2*I+6) = HBAR/RLTIM(412+2*I)
+ ENDDO
+ DO I=1,12
+ MS2(I) = MS(I)**2
+ MSWD(I) = MS(I)*SWD(I)
+ ENDDO
+C--Now set up the parmaters for multichannel integration
+ RAND = ZERO
+ DO K=1,3
+ CHANPB(1) = ZERO
+ CHANPB(2) = ZERO
+ DO I=1,3
+ DO J=1,3
+ CHANPB(1)=CHANPB(1)+LAMDA3(I,J,K)**2
+ CHANPB(2)=CHANPB(2)+LAMDA3(K,I,J)**2
+ ENDDO
+ ENDDO
+ RAND=RAND+CHANPB(1)+CHANPB(2)
+ DO J=1,2
+ CHAN(2*K-2+J) = CHANPB(1)*QMIXSS(2*K-1,2,J)**2
+ CHAN(2*K+4+J) = CHANPB(2)*QMIXSS(2*K ,2,J)**2
+ MIX(2*K-2+J) = QMIXSS(2*K-1,2,J)**2
+ MIX(2*K+4+J) = QMIXSS(2*K,2,J)**2
+ ENDDO
+ ENDDO
+ IF(RAND.GT.ZERO) THEN
+ DO I=1,12
+ CHAN(I)=CHAN(I)/RAND
+ ENDDO
+ ELSE
+ HCS =ZERO
+ CALL HWWARN('HWHRBB',500,*999)
+ ENDIF
+C--find the couplings
+ DO GN=1,3
+ DO I=1,3
+ DO J=1,3
+ DO K=1,3
+ DO L=1,3
+ LAM(GN,I,J,K,L) =LAMDA3(I,J,GN)*LAMDA3(K,L,GN)
+ LAM(GN+3,I,J,K,L)=LAMDA3(GN,I,J)*LAMDA3(GN,K,L)
+ ENDDO
+ ENDDO
+ ENDDO
+ ENDDO
+ ENDDO
+ ENDIF
+ EVWGT = ZERO
+ S = PHEP(5,3)**2
+ COSTH = HWRUNI(0,-ONE,ONE)
+C--Generate the smoothing
+ RAND=HWRUNI(0,ZERO,ONE)
+ DO I=1,12
+ IF(CHAN(I).GT.RAND) GOTO 20
+ RAND=RAND-CHAN(I)
+ ENDDO
+ 20 GENR=I
+C--Calculate hard scale and obtain parton distributions
+ TAUA = MS2(GENR)/S
+ TAUB = SWD(GENR)**2/S
+ RTAB = SQRT(TAUA*TAUB)
+ XUPP = XMAX
+ IF(XMAX**2.GT.S) XUPP = SQRT(S)
+ LOWTLM = DATAN((XMIN**2/S-TAUA)/RTAB)/RTAB
+ UPPTLM = DATAN((XUPP**2/S-TAUA)/RTAB)/RTAB
+ TAU = HWRUNI(0,LOWTLM,UPPTLM)
+ TAU = RTAB*TAN(RTAB*TAU)+TAUA
+ SH = S*TAU
+ SQSH = SQRT(SH)
+ EMSCA = SQSH
+ XX(1) = EXP(HWRUNI(0,ZERO,LOG(TAU)))
+ XX(2) = TAU/XX(1)
+ CALL HWSGEN(.FALSE.)
+C--Calculate the prefactor due multichannel approach
+ FAC = ZERO
+ DO GN=1,12
+ SCF(GN)=1/((SH-MS2(GN))**2+MSWD(GN)**2)
+ FAC=FAC+CHAN(GN)*SCF(GN)
+ ENDDO
+ FAC=-(UPPTLM-LOWTLM)*LOG(TAU)*GEV2NB
+ & /(24*PIFAC*SQSH*SH*TAU*FAC*S**2)
+ ENDIF
+C--loop over the quarks
+ HCS = ZERO
+C--temp mod
+ DO GN=1,2
+ IF(GN.EQ.1) THEN
+ MIG = 1
+ MXG = 6
+ ELSE
+ MIG = 7
+ MXG = 12
+ ENDIF
+ DO K1=1,3
+ DO 70 L1=1,3
+ IF(GN.EQ.1) THEN
+ K = 2*K1
+ L = 2*L1-1
+ ELSE
+ K=2*K1-1
+ L=2*L1-1
+ IF(GN.EQ.2.AND.L1.GE.K1) GOTO 70
+ ENDIF
+ MQ1=RMASS(K)
+ MQ2=RMASS(L)
+ IF(SQSH.GT.(MQ1+MQ2)) THEN
+ PCM=SQRT((SH-(MQ1+MQ2)**2)*(SH-(MQ1-MQ2)**2)/(4*SH))
+ WD = SH*(SH-MQ1**2-MQ2**2)*PCM
+ ELSE
+ GOTO 70
+ ENDIF
+ DO I1=1,3
+ DO 60 J1=1,3
+ IF(GN.EQ.1) THEN
+ I = 2*I1
+ J = 2*J1-1
+ ELSE
+ I=2*I1-1
+ J=2*J1-1
+ IF(J1.GT.I1) GOTO 60
+ ENDIF
+ IF(GENEV) GOTO 50
+ MATELM = ZERO
+ DO 40 GEN=MIG,MXG
+ IF(ABS(MIX(GEN)).LT.EPS.OR.
+ & ABS(LAM(INT((GEN+1)/2),I1,J1,K1,L1)).LT.EPS) GOTO 40
+ DO 30 GENR=MIG,MXG
+ IF(ABS(LAM(INT((GENR+1)/2),I1,J1,K1,L1)).LT.EPS.
+ & OR.ABS(MIX(GENR)).LT.EPS) GOTO 30
+ MATELM =MATELM+SCF(GEN)*SCF(GENR)*WD*
+ & ((SH-MS2(GEN))*(SH-MS2(GENR))+
+ & MSWD(GEN)*MSWD(GENR))
+ & *LAM(INT((GEN+1)/2),I1,J1,K1,L1)*MIX(GEN)
+ & *LAM(INT((GENR+1)/2),I1,J1,K1,L1)*MIX(GENR)
+ 30 CONTINUE
+ 40 CONTINUE
+ ME(GN,I1,J1,K1,L1) = MATELM*FAC
+C--Add up the term to get the cross-section
+ 50 HCS = HCS+ME(GN,I1,J1,K1,L1)*DISF(I,1)*DISF(J,2)
+ IF(HCS.GT.RCS.AND.GENEV)
+ & CALL HWHRSS(1,I,J,K,L,0,0,*100)
+ HCS = HCS+ME(GN,I1,J1,K1,L1)*DISF(J,1)*DISF(I,2)
+ IF(HCS.GT.RCS.AND.GENEV)
+ & CALL HWHRSS(2,J,I,K,L,0,0,*100)
+ HCS = HCS+ME(GN,I1,J1,K1,L1)*DISF(I+6,1)*DISF(J+6,2)
+ IF(HCS.GT.RCS.AND.GENEV)
+ & CALL HWHRSS(1,I,J,K,L,1,0,*100)
+ HCS = HCS+ME(GN,I1,J1,K1,L1)*DISF(J+6,1)*DISF(I+6,2)
+ IF(HCS.GT.RCS.AND.GENEV)
+ & CALL HWHRSS(2,J,I,K,L,1,0,*100)
+ 60 CONTINUE
+ ENDDO
+ 70 CONTINUE
+ ENDDO
+ ENDDO
+ 100 IF(GENEV) THEN
+ CALL HWETWO
+C--first stage of the colour connection corrections
+ DO THEP=1,5
+ IF(THEP.NE.3) THEN
+ JMOHEP(2,THEP+NHEP-5)=NHEP-5+THEP+CONECT(HWRINT(1,4),THEP)
+ JDAHEP(2,THEP+NHEP-5) = JMOHEP(2,THEP+NHEP-5)
+ ENDIF
+ ENDDO
+ THEP = NHEP-4
+ IF(HWRINT(1,2).EQ.1) THEN
+ HRDCOL(2,1) = THEP+3
+ HRDCOL(2,2) = THEP+4
+ HRDCOL(1,4) = THEP
+ HRDCOL(1,5) = THEP+1
+ ELSE
+ HRDCOL(2,1) = THEP+4
+ HRDCOL(2,2) = THEP+3
+ HRDCOL(1,4) = THEP+1
+ HRDCOL(1,5) = THEP
+ ENDIF
+ DO N=1,5
+ IF(N.LE.2) THEN
+ HRDCOL(1,N)=HRDCOL(2,N)
+ ELSEIF(N.GE.4) THEN
+ HRDCOL(2,N)=HRDCOL(1,N)
+ ENDIF
+ ENDDO
+ HRDCOL(1,3) = 4
+ COLUPD = .TRUE.
+ ELSE
+ EVWGT = HCS
+ ENDIF
+ 999 END
+CDECK ID>, HWHRBS.
+*CMZ :- -20/10/99 09:46:43 by Peter Richardson
+*-- Author : Peter Richardson
+C-----------------------------------------------------------------------
+ SUBROUTINE HWHRBS
+C-----------------------------------------------------------------------
+C Subroutine for 2 parton -> parton SUSY particle via UDD resonant
+C squarks.
+C-----------------------------------------------------------------------
+ INCLUDE 'HERWIG61.INC'
+ DOUBLE PRECISION HCS,S,RCS,HWR,ME(4),CW,MER(6),MZ,TAU,TAUA,
+ & TAUB,LOWTLM,UPPTLM,HWRUNI,SH,SQSH,SCF(12),MW2,
+ & LAMC(3),CHANPB(2),PCM,ECM,RAND,MEN(7,6,3,3),
+ & MEC(2,6,3,3),RTAB,MS(12),SWD(12),AS,HWUALF,
+ & MQ,MN,MQS,SIN2B,TH,UH,FAC,MX(14),CHAN(12),MC(2),
+ & MNS,HWUAEM,SW,G,EC,MW,A(7,14),B(7,14),EPS,XUPP,
+ & MEH(3,42),XMIN,XMAX,XPOW,FAC2,MH(4),ZSQU(2,2),
+ & ZQRK(2),MZ2,GUU(4),GDD(4),ME2,MS2(12),MSWD(12)
+ INTEGER I,J,K,I1,J1,GEN,THEP,HWRINT,L,GT,GU,GR,I2,
+ & CONECT(2,6,5),GN,GENR,SP,SPMN,SPMX,CON,CHARMN,CHARMX,
+ & CM,CN
+ LOGICAL RAD,NEUT,CHAR,HIGGS,FIRST
+ EXTERNAL HWR,HWRUNI,HWUAEM,HWUALF,HWRINT
+ COMMON/HWRPIN/XMIN,XMAX,XPOW,FIRST
+ SAVE HCS,MS,SWD,MX,CHAN,A,B,SPMN,SPMX,RAD,MEN,MEC,HIGGS,
+ & CHARMN,CHARMX,NEUT,CHAR,SQSH,MEH,SW,CW,MW,MZ,MER,SH,MH,
+ & AS,EC,FAC,G,SCF,ZSQU,ZQRK,MW2,MZ2,MS2,MSWD
+ PARAMETER(EPS=1D-20)
+ DATA CONECT/ 4, 4, 2, 3, 0, 0, 1,-2,-1,-3,-4,-4,
+ & 3, 4, 3, 3, 0, 0, 1,-3,-1,-4,-3,-3,
+ & 1, 4,-1, 3, 0, 0, 1, 1,-3,-4,-1,-1,
+ & 1, 3,-1, 2, 0, 0,-3,-2, 0, 0, 0, 0,
+ & 1, 4,-1, 3, 0, 0,-3,-2,-1,-1,-1,-1/
+ IF(GENEV) THEN
+ RCS = HCS*HWR()
+ ELSE
+ IF(FSTWGT) THEN
+C--Extract masses and width's needed
+ DO I=1,3
+ MS(2*I-1) = RMASS(399+2*I)
+ MS(2*I) = RMASS(411+2*I)
+ MS(2*I+5) = RMASS(400+2*I)
+ MS(2*I+6) = RMASS(412+2*I)
+ SWD(2*I-1) = HBAR/RLTIM(399+2*I)
+ SWD(2*I) = HBAR/RLTIM(411+2*I)
+ SWD(2*I+5) = HBAR/RLTIM(400+2*I)
+ SWD(2*I+6) = HBAR/RLTIM(412+2*I)
+ ENDDO
+ DO I=1,12
+ MS2(I) = MS(I)**2
+ MSWD(I) = MS(I)*SWD(I)
+ ENDDO
+C--Electroweak parameters
+ SW = SQRT(SWEIN)
+ CW = SQRT(1-SWEIN)
+ MW = RMASS(198)
+ MZ = RMASS(200)
+ MW2 = MW**2
+ MZ2 = MZ**2
+ SIN2B = TWO*SINB*COSB
+C--Now set up the parmaters for multichannel integration
+ RAND = ZERO
+ DO K=1,3
+ CHANPB(1) = ZERO
+ CHANPB(2) = ZERO
+ DO I=1,3
+ DO J=1,3
+ CHANPB(1)=CHANPB(1)+LAMDA3(I,J,K)**2
+ CHANPB(2)=CHANPB(2)+LAMDA3(K,I,J)**2
+ ENDDO
+ ENDDO
+ RAND=RAND+CHANPB(1)+CHANPB(2)
+ DO J=1,2
+ CHAN(2*K-2+J) = CHANPB(1)*QMIXSS(2*K-1,2,J)**2
+ CHAN(2*K+4+J) = CHANPB(2)*QMIXSS(2*K ,2,J)**2
+ MX(2*K-2+J) = QMIXSS(2*K-1,2,J)
+ MX(2*K+4+J) = QMIXSS(2*K,2,J)
+ ENDDO
+ MX(13) = ZERO
+ MX(14) = ZERO
+ ENDDO
+ IF(RAND.GT.ZERO) THEN
+ DO I=1,12
+ CHAN(I)=CHAN(I)/RAND
+ ENDDO
+ ELSE
+ CALL HWWARN('HWHRBS',500,*999)
+ ENDIF
+C--Couplings we need for the various processes
+C--Gluino
+ DO I=1,3
+ DO J=1,2
+ A(1,2*I-2+J) = QMIXSS(2*I-1,2,J)
+ B(1,2*I-2+J) = -QMIXSS(2*I-1,1,J)
+ A(1,2*I+4+J) = QMIXSS(2*I,2,J)
+ B(1,2*I+4+J) = -QMIXSS(2*I,1,J)
+ ENDDO
+ ENDDO
+C--Now the neutralinos
+ DO L=1,4
+ MC(1) = ZMIXSS(L,3)/(2*MW*COSB*SW)
+ MC(2) = ZMIXSS(L,4)/(2*MW*SINB*SW)
+ DO I=1,3
+ DO J=1,2
+ A(L+1,2*I-2+J) = ZSGNSS(L)*(MC(1)*QMIXSS(2*I-1,1,J)*
+ & RMASS(2*I-1)+SRFCH(2*I-1,L)*QMIXSS(2*I-1,2,J))
+ B(L+1,2*I-2+J) = MC(1)*QMIXSS(2*I-1,2,J)*
+ & RMASS(2*I-1)+SLFCH(2*I-1,L)*QMIXSS(2*I-1,1,J)
+ A(L+1,2*I+4+J) = ZSGNSS(L)*(MC(2)*QMIXSS(2*I,1,J)*
+ & RMASS(2*I)+SRFCH(2*I ,L)*QMIXSS(2*I,2,J))
+ B(L+1,2*I+4+J) = MC(2)*QMIXSS(2*I,2,J)*
+ & RMASS(2*I)+SLFCH(2*I, L)*QMIXSS(2*I,1,J)
+ ENDDO
+ ENDDO
+ ENDDO
+C--Now for the charginos
+ DO L=1,2
+ MC(1) = 1/(SQRT(2.0D0)*MW*COSB)
+ MC(2) = 1/(SQRT(2.0D0)*MW*SINB)
+ DO I=1,3
+ DO J=1,2
+ A(5+L,2*I-2+J) = -WSGNSS(L)*WMXVSS(L,2)*MC(2)*
+ & RMASS(2*I)*QMIXSS(2*I-1,1,J)
+ B(5+L,2*I-2+J) = WMXUSS(L,1)*QMIXSS(2*I-1,1,J)
+ & -WMXUSS(L,2)*MC(1)*RMASS(2*I-1)*QMIXSS(2*I-1,2,J)
+ A(5+L,2*I+4+J) = -WMXUSS(L,2)*MC(1)*RMASS(2*I-1)
+ & *QMIXSS(2*I,1,J)
+ B(5+L,2*I+4+J) = WSGNSS(L)*(WMXVSS(L,1)*QMIXSS(2*I,1,J)
+ & -WMXVSS(L,2)*MC(2)*RMASS(2*I)*QMIXSS(2*I,2,J))
+ ENDDO
+ ENDDO
+ ENDDO
+C--Zero couplings
+ DO I=1,7
+ A(I,13) = ZERO
+ B(I,13) = ZERO
+ A(I,14) = ZERO
+ B(I,14) = ZERO
+ ENDDO
+C--Couplings to the Z boson of squarks and right-handed quarks
+ ZQRK(1) = -SW**2/6.0D0/CW
+ ZQRK(2) = SW**2/3.0D0/CW
+ ZSQU(1,1) = HALF*(QMIXSS(5,1,1)**2-2.0D0*SW**2/3.0D0)/CW
+ ZSQU(1,2) = HALF*QMIXSS(5,1,1)*QMIXSS(5,1,2)/CW
+ ZSQU(2,1) = -HALF*(QMIXSS(6,1,1)**2-4.0D0*SW**2/3.0D0)/CW
+ ZSQU(2,2) = -HALF*QMIXSS(6,1,1)*QMIXSS(6,1,2)/CW
+C--Higgs Masses
+ DO I=1,4
+ MH(I) = RMASS(202+I)
+ ENDDO
+C--Higgs couplings to quarks
+ DO I=1,3
+ GUU(I) = GHUUSS(I)**2*HALF**2/MW2
+ GDD(I) = GHDDSS(I)**2*HALF**2/MW2
+ ENDDO
+ GUU(4) = ONE/TANB**2/MW2/8.0D0
+ GDD(4) = ONE*TANB**2/MW2/8.0D0
+C--decide which processes to generate from IPROC
+ RAD = .FALSE.
+ NEUT = .FALSE.
+ CHAR = .FALSE.
+ HIGGS = .FALSE.
+ SPMN = 1
+ SPMX = 5
+ CHARMN = 1
+ CHARMX = 2
+ IF(IPROC.EQ.4100) THEN
+ RAD = .TRUE.
+ NEUT = .TRUE.
+ CHAR = .TRUE.
+ HIGGS = .TRUE.
+ ELSEIF(IPROC.LT.4120) THEN
+ SPMN = 2
+ IF(IPROC.NE.4110) THEN
+ SPMN = MOD(IPROC,10)+1
+ SPMX = SPMN
+ ENDIF
+ NEUT=.TRUE.
+ ELSEIF(IPROC.LT.4130) THEN
+ IF(IPROC.NE.4120) THEN
+ CHARMN = MOD(IPROC,10)
+ CHARMX=CHARMN
+ ENDIF
+ CHAR = .TRUE.
+ ELSEIF(IPROC.EQ.4130) THEN
+ SPMX = 1
+ NEUT=.TRUE.
+ ELSEIF(IPROC.EQ.4140) THEN
+ RAD = .TRUE.
+ ELSEIF(IPROC.EQ.4150) THEN
+ HIGGS = .TRUE.
+ ELSE
+ CALL HWWARN('HWHRBS',501,*999)
+ ENDIF
+ ENDIF
+ EVWGT = ZERO
+ S = PHEP(5,3)**2
+ COSTH = HWRUNI(0,-ONE,ONE)
+C--zero the array
+ DO I=1,6
+ DO J=1,3
+ DO K=1,3
+ DO L=1,7
+ MEN(L,I,J,K)=ZERO
+ ENDDO
+ DO L=1,2
+ MEC(L,I,J,K)=ZERO
+ ENDDO
+ ENDDO
+ ENDDO
+ ENDDO
+C--Multichannel peak
+ RAND=HWRUNI(0,ZERO,ONE)
+ DO I=1,12
+ IF(CHAN(I).GT.RAND) GOTO 25
+ RAND=RAND-CHAN(I)
+ ENDDO
+ 25 GENR=I
+C--Calculate the hard scale and obtain parton distributions
+ TAUA = MS2(GENR)/S
+ TAUB = SWD(GENR)**2/S
+ RTAB = SQRT(TAUA*TAUB)
+ XUPP = XMAX
+ IF(XMAX**2.GT.S) XUPP = SQRT(S)
+ LOWTLM = DATAN((XMIN**2/S-TAUA)/RTAB)/RTAB
+ UPPTLM = DATAN((XUPP**2/S-TAUA)/RTAB)/RTAB
+ TAU = HWRUNI(0,LOWTLM,UPPTLM)
+ TAU = RTAB*TAN(RTAB*TAU)+TAUA
+ SH = S*TAU
+ SQSH = SQRT(SH)
+ EMSCA = SQSH
+ XX(1) = EXP(HWRUNI(0,ZERO,LOG(TAU)))
+ XX(2) = TAU/XX(1)
+ CALL HWSGEN(.FALSE.)
+C--Strong, EM coupling and weak couplings
+ AS = HWUALF(1,EMSCA)
+ EC = SQRT(4*PIFAC*HWUAEM(SH))
+ G = EC/SW
+C--Calculate the prefactor due multichannel approach
+ FAC = ZERO
+ DO GN=1,12
+ SCF(GN)=1/((SH-MS2(GN))**2+MSWD(GN)**2)
+ FAC=FAC+CHAN(GN)*SCF(GN)
+ ENDDO
+ FAC=-(UPPTLM-LOWTLM)*LOG(TAU)*GEV2NB
+ & /(48*PIFAC*SQSH*SH*TAU*FAC*S**2)
+ ENDIF
+ HCS = ZERO
+ IF(.NOT.NEUT) GOTO 200
+ DO 140 GN=1,6
+ GR=2*GN
+ IF(CHAN(GR).LT.EPS) GOTO 140
+ DO 130 L=SPMN,SPMX
+ K = 2*GN+5
+ IF(GN.GT.3) K = 2*GN
+ MQ = RMASS(K)
+ MN = ABS(RMASS(448+L))
+ MQS = MQ**2
+ MNS = MN**2
+ IF(SQSH.LT.(MQ+MN)) GOTO 130
+ PCM=SQRT((SH-(MQ+MN)**2)*(SH-(MQ-MN)**2)/(4*SH))
+ ECM=SQRT(PCM**2+MQS)
+ TH = MQS-SQSH*(ECM-PCM*COSTH)
+ UH = MQS-SQSH*(ECM+PCM*COSTH)
+ DO I=1,3
+ DO 120 J=1,3
+ IF(GN.LE.3) THEN
+ GU = 6+2*I
+ I1 = 2*I
+ LAMC(1) = LAMDA3(I,J,GN)**2
+ ELSE
+ GU = 2*I
+ I1 = 2*I-1
+ LAMC(1) = LAMDA3(GN-3,I,J)**2
+ IF(J.GT.I) LAMC(1) = ZERO
+ ENDIF
+ GT = 2*J
+ J1 = 2*J-1
+C--Now the matrix elements
+ IF(LAMC(1).LT.EPS) GOTO 120
+ IF(GENEV) GOTO 110
+C--S channel
+ ME(3) = MX(GR)**2*SCF(GR)*SH*((SH-MQS-MNS)*(A(L,GR)**2+
+ & B(L,GR)**2)-4*MQ*MN*A(L,GR)*B(L,GR))
+ ME(4) =-TWO*MX(GU)*MX(GT)*(MQS*MNS-UH*TH)*A(L,GT)*A(L,GU)
+ & /(TH-MS2(GT))/(UH-MS2(GU))
+ & +TWO*MX(GR)*MX(GU)*(SH-MS2(GR))*SCF(GR)*SH*
+ & A(L,GU)*(A(L,GR)*UH+B(L,GR)*MQ*MN)/(UH-MS2(GU))
+ & +TWO*MX(GR)*MX(GT)*(SH-MS2(GR))*SCF(GR)*SH*
+ & A(L,GT)*(A(L,GR)*TH+B(L,GR)*MQ*MN)/(TH-MS2(GT))
+C--L/R s channel and interference
+ IF(ABS(MX(GR-1)).GT.EPS) THEN
+ ME(3) = ME(3)+
+ & MX(GR-1)**2*SCF(GR-1)*SH*((SH-MQS-MNS)*(A(L,GR-1)**2
+ & +B(L,GR-1)**2)-4*MQ*MN*A(L,GR-1)*B(L,GR-1))
+ & +TWO*MX(GR)*MX(GR-1)*SCF(GR)*SCF(GR-1)*SH*
+ & ((SH-MS2(GR))*(SH-MS2(GR-1))+MSWD(GR)*MSWD(GR-1))*
+ & ((SH-MQS-MNS)*(A(L,GR)*A(L,GR-1)
+ & +B(L,GR)*B(L,GR-1))
+ & -TWO*MQ*MN*(A(L,GR)*B(L,GR-1)+A(L,GR-1)*B(L,GR)))
+ ME(4) = ME(4)+TWO*MX(GR-1)*MX(GU)*(SH-MS2(GR-1))
+ & *SCF(GR-1)*A(L,GU)*SH*(A(L,GR-1)*UH+B(L,GR-1)*MQ*MN)
+ & /(UH-MS2(GU))
+ & +TWO*MX(GR-1)*MX(GT)*(SH-MS2(GR-1))*SCF(GR-1)*SH*
+ & A(L,GT)*(A(L,GR-1)*TH+B(L,GR-1)*MQ*MN)/(TH-MS2(GT))
+ IF(ABS(MX(GU-1)).GT.EPS) ME(4)=ME(4)+TWO*MX(GR-1)*
+ & MX(GU-1)*(SH-MS2(GR-1))*SCF(GR-1)*A(L,GU-1)*SH*(
+ & A(L,GR-1)*UH+B(L,GR-1)*MQ*MN)/(UH-MS2(GU-1))
+ IF(ABS(MX(GT-1)).GT.EPS) ME(4)=ME(4)+TWO*MX(GR-1)*
+ & MX(GT-1)*(SH-MS2(GR-1))*SCF(GR-1)*A(L,GT-1)*SH*
+ & (A(L,GR-1)*TH+B(L,GR-1)*MQ*MN)/(TH-MS2(GT-1))
+ ENDIF
+C--u channel and L/R mixing
+ ME(1)= MX(GU)**2*(MQS-UH)*(MNS-UH)*
+ & (A(L,GU)**2+B(L,GU)**2)/(UH-MS2(GU))**2
+ IF(ABS(MX(GU-1)).GT.EPS) THEN
+ ME(1) = ME(1)+MX(GU-1)**2*(MQS-UH)*(MNS-UH)*
+ & (A(L,GU-1)**2+B(L,GU-1)**2)/(UH-MS2(GU-1))**2
+ & +TWO*MX(GU)*MX(GU-1)*(MQS-UH)*(MNS-UH)*
+ & (A(L,GU)*A(L,GU-1)+B(L,GU)*B(L,GU-1))
+ & /(UH-MS2(GU))/(UH-MS2(GU-1))
+ ME(4) =ME(4)+TWO*MX(GR)*MX(GU-1)*(SH-MS2(GR))*
+ & SCF(GR)*A(L,GU-1)*SH*(A(L,GR)*UH+B(L,GR)*MQ*MN)
+ & /(UH-MS2(GU-1))
+ & -2*MX(GU-1)*MX(GT)*(MQS*MNS-UH*TH)*A(L,GT)*
+ & A(L,GU-1)/(TH-MS2(GT))/(UH-MS2(GU-1))
+ IF(ABS(MX(GT-1)).GT.EPS) ME(4)=ME(4)-2*MX(GU-1)*MX(GT-1)
+ & *(MQS*MNS-UH*TH)*A(L,GT-1)*A(L,GU-1)
+ & /(TH-MS2(GT-1))/(UH-MS2(GU-1))
+ ENDIF
+C--t channel and t channel L/R mixing
+ ME(2) = MX(GT)**2*(MQS-TH)*(MNS-TH)*
+ & (A(L,GT)**2+B(L,GT)**2)/(TH-MS2(GT))**2
+ IF(ABS(MX(GT-1)).GT.EPS) THEN
+ ME(2) = ME(2)+MX(GT-1)**2*(MQS-TH)*(MNS-TH)*
+ & (A(L,GT-1)**2+B(L,GT-1)**2)/(TH-MS2(GT-1))**2
+ & +TWO*MX(GT)*MX(GT-1)*(MQS-TH)*(MNS-TH)*(A(L,GT)*
+ & A(L,GT-1)+ B(L,GT)*B(L,GT-1))
+ & /(TH-MS2(GT))/(TH-MS2(GT-1))
+ ME(4)=ME(4)-TWO*MX(GU)*MX(GT-1)*(MQS*MNS-UH*TH)*
+ & A(L,GT-1)*A(L,GU)/(TH-MS2(GT-1))/(UH-MS2(GU))
+ & +TWO*MX(GR)*MX(GT-1)*(SH-MS2(GR))*SCF(GR)*
+ & A(L,GT-1)*SH*(A(L,GR)*TH+B(L,GR)*MQ*MN)
+ & /(TH-MS2(GT-1))
+ ENDIF
+C--Angular ordering and the phase space factors
+ IF(L.EQ.1) THEN
+ ME(4)=-HALF*ME(4)/(ME(1)+ME(2)+ME(3))
+ LAMC(1) = 32.0D0*LAMC(1)*AS*PIFAC/THREE
+ DO GEN=1,3
+ MEN(GEN,GN,I,J) = FAC*PCM*LAMC(1)*ME(GEN)*(ONE+ME(4))
+ ENDDO
+ ELSE
+ LAMC(1) = TWO*LAMC(1)*EC**2
+ MEN(L+2,GN,I,J)=FAC*PCM*LAMC(1)*(ME(1)+ME(2)+ME(3)+ME(4))
+ ENDIF
+C--Multiply by the pdf's
+ 110 IF(L.EQ.1) THEN
+ CM = 1
+ CN = 3
+ ELSE
+ CM = L+2
+ CN = L+2
+ ENDIF
+ DO GEN=CM,CN
+ CON = 4
+ IF(GEN.LE.3) CON = GEN
+ HCS=HCS+MEN(GEN,GN,I,J)*DISF(I1,1)*DISF(J1,2)
+ IF(GENEV.AND.HCS.GT.RCS) CALL HWHRSS(3,I1,J1,K,GEN,0,0,*900)
+ HCS=HCS+MEN(GEN,GN,I,J)*DISF(J1,1)*DISF(I1,2)
+ IF(GENEV.AND.HCS.GT.RCS) CALL HWHRSS(4,J1,I1,K,GEN,0,0,*900)
+ HCS=HCS+MEN(GEN,GN,I,J)*DISF(I1+6,1)*DISF(J1+6,2)
+ IF(GENEV.AND.HCS.GT.RCS) CALL HWHRSS(3,I1,J1,K,GEN,1,0,*900)
+ HCS=HCS+MEN(GEN,GN,I,J)*DISF(J1+6,1)*DISF(I1+6,2)
+ IF(GENEV.AND.HCS.GT.RCS) CALL HWHRSS(4,J1,I1,K,GEN,1,0,*900)
+ ENDDO
+ 120 CONTINUE
+ ENDDO
+ 130 CONTINUE
+ 140 CONTINUE
+C--Now the chargino processes if wanted
+ 200 IF(.NOT.CHAR) GOTO 300
+ DO 240 GN=1,6
+ GR=2*GN
+ IF(CHAN(GR).LT.EPS) GOTO 240
+ DO 230 L=CHARMN,CHARMX
+ SP =5+L
+ K = 2*GN+6
+ IF(GN.GT.3) K = 2*GN-1
+ MQ = RMASS(K)
+ MN = ABS(RMASS(453+L))
+ MQS = MQ**2
+ MNS = MN**2
+ IF(SQSH.LT.(MQ+MN)) GOTO 230
+ PCM=SQRT((SH-(MQ+MN)**2)*(SH-(MQ-MN)**2)/(4*SH))
+ ECM=SQRT(PCM**2+MQS)
+ TH = MQS-SQSH*(ECM-PCM*COSTH)
+ UH = MQS-SQSH*(ECM+PCM*COSTH)
+ DO I=1,3
+ DO 220 J=1,3
+ IF(GN.LE.3) THEN
+ GU = 2*I
+ GT = 14
+ I1 = 2*I
+ LAMC(1) = LAMDA3(I,J,GN)
+ LAMC(2) = LAMDA3(GN,I,J)
+ LAMC(3) = ZERO
+ ELSE
+ GU = 6+2*I
+ GT = 6+2*J
+ I1 = 2*I-1
+ LAMC(1) = LAMDA3(GN-3,I,J)
+ LAMC(2) = LAMDA3(I,J,GN-3)
+ LAMC(3) = LAMDA3(J,GN-3,I)
+ IF(J.GT.I) LAMC(1) = ZERO
+ ENDIF
+ J1 = 2*J-1
+ IF(ABS(LAMC(1)).LT.EPS) GOTO 220
+ IF(GENEV) GOTO 210
+C--Matrix element
+C--S channel
+ ME(1) = LAMC(1)**2*MX(GR)**2*SCF(GR)*SH*((SH-MQS-MNS)*
+ & (A(SP,GR)**2+B(SP,GR)**2)-4*MQ*MN*A(SP,GR)*B(SP,GR))
+ IF(ABS(MX(GU)).GT.EPS) THEN
+ ME(1) = ME(1)+LAMC(2)**2*MX(GU)**2*(MQS-UH)*(MNS-UH)*
+ & (A(SP,GU)**2+B(SP,GU)**2)/(UH-MS2(GU))**2
+ & +LAMC(1)*LAMC(2)*TWO*MX(GR)*MX(GU)*
+ & (SH-MS2(GR))*SCF(GR)*A(SP,GU)*SH*
+ & (A(SP,GR)*UH+B(SP,GR)*MQ*MN)/(UH-MS2(GU))
+ IF(ABS(MX(GT)).GT.EPS) ME(1) = ME(1)-LAMC(2)*LAMC(3)*
+ & TWO*MX(GU)*MX(GT)*(MQS*MNS-UH*TH)*A(SP,GT)*
+ & A(SP,GU)/(TH-MS2(GT))/(UH-MS2(GU))
+ ENDIF
+ IF(ABS(MX(GT)).GT.EPS) THEN
+ ME(1) = ME(1)+LAMC(3)**2*MX(GT)**2*(MQS-TH)*(MNS-TH)*
+ & (A(SP,GT)**2+B(SP,GT)**2)/(TH-MS2(GT))**2
+ & +LAMC(1)*LAMC(3)*TWO*MX(GR)*MX(GT)*
+ & (SH-MS2(GR))*SCF(GR)*A(SP,GT)*SH*
+ & (A(SP,GR)*TH+B(SP,GR)*MQ*MN)/(TH-MS2(GT))
+ ENDIF
+c--L/R s channel and interference
+ IF(ABS(MX(GR-1)).GT.EPS) THEN
+ ME(1) = ME(1)+LAMC(1)**2*MX(GR-1)**2*SCF(GR-1)*SH*
+ & ((SH-MQS-MNS)*(A(SP,GR-1)**2+B(SP,GR-1)**2)
+ & -4*MQ*MN*A(SP,GR-1)*B(SP,GR-1))
+ & +LAMC(1)**2*TWO*MX(GR)*MX(GR-1)*SCF(GR)*
+ & SCF(GR-1)*SH*
+ & ((SH-MS2(GR))*(SH-MS2(GR-1))+
+ & MSWD(GR)*MSWD(GR-1))*
+ & ((SH-MQS-MNS)*(A(SP,GR)*A(SP,GR-1)+
+ & B(SP,GR)*B(SP,GR-1))-TWO*MQ*MN*
+ & (A(SP,GR)*B(SP,GR-1)+A(SP,GR-1)*B(SP,GR)))
+ IF(ABS(MX(GU)).GT.EPS) ME(1) = ME(1)+LAMC(1)*LAMC(2)*
+ & TWO*MX(GR-1)*MX(GU)*(SH-MS2(GR-1))*SCF(GR-1)*
+ & A(SP,GU)*SH*(A(SP,GR-1)*UH+B(SP,GR-1)*MQ*MN)
+ & /(UH-MS2(GU))
+ IF(ABS(MX(GT)).GT.EPS) ME(1) = ME(1)+LAMC(1)*LAMC(3)*
+ & TWO*MX(GR-1)*MX(GT)*(SH-MS2(GR-1))*SCF(GR-1)*
+ & A(SP,GT)*SH*(A(SP,GR-1)*TH+B(SP,GR-1)*MQ*MN)
+ & /(TH-MS2(GT))
+ IF(ABS(MX(GU-1)).GT.EPS) ME(1)=ME(1)+LAMC(1)*LAMC(2)*
+ & TWO*MX(GR-1)*MX(GU-1)*(SH-MS2(GR-1))*
+ & SCF(GR-1)*A(SP,GU-1)*SH*(A(SP,GR-1)*UH+
+ & B(SP,GR-1)*MQ*MN)/(UH-MS2(GU-1))
+ IF(ABS(MX(GT-1)).GT.EPS) ME(1)=ME(1)+LAMC(1)*LAMC(3)*
+ & TWO*MX(GR-1)*MX(GT-1)*(SH-MS2(GR-1))*
+ & SCF(GR-1)*A(SP,GT-1)*SH*(A(SP,GR-1)*TH+
+ & B(SP,GR-1)*MQ*MN)/(TH-MS2(GT-1))
+ ENDIF
+C--u channel and L/R mixing
+ IF(ABS(MX(GU-1)).GT.EPS) THEN
+ ME(1) = ME(1)+LAMC(2)**2*MX(GU-1)**2*(MQS-UH)*(MNS-UH)*
+ & (A(SP,GU-1)**2+B(SP,GU-1)**2)/(UH-MS2(GU-1))**2
+ & +LAMC(2)**2*TWO*MX(GU)*MX(GU-1)*(MQS-UH)*(MNS-UH)*
+ & (A(SP,GU)*A(SP,GU-1)+B(SP,GU)*B(SP,GU-1))
+ & /(UH-MS2(GU))/(UH-MS2(GU-1))
+ & +TWO*LAMC(1)*LAMC(2)*MX(GR)*MX(GU-1)*
+ & (SH-MS2(GR))*SCF(GR)*A(SP,GU-1)*SH*
+ & (A(SP,GR)*UH+B(SP,GR)*MQ*MN)/(UH-MS2(GU-1))
+ IF(ABS(MX(GT)).GT.EPS) ME(1)=ME(1)-LAMC(2)*LAMC(3)*TWO*
+ & MX(GU-1)*MX(GT)*(MQS*MNS-UH*TH)*A(SP,GT)*A(SP,GU-1)
+ & /(TH-MS2(GT))/(UH-MS2(GU-1))
+ IF(ABS(MX(GT-1)).GT.EPS) ME(1)=ME(1)-LAMC(2)*LAMC(3)*
+ & TWO*MX(GU-1)*MX(GT-1)*(MQS*MNS-UH*TH)*A(SP,GT-1)*
+ & A(SP,GU-1)/(TH-MS2(GT-1))/(UH-MS2(GU-1))
+ ENDIF
+C--t channel and t channel L/R mixing
+ IF(ABS(MX(GT-1)).GT.EPS) THEN
+ ME(1) = ME(1)+LAMC(3)**2*MX(GT-1)**2*(MQS-TH)*(MNS-TH)*
+ & (A(SP,GT-1)**2+B(SP,GT-1)**2)/(TH-MS2(GT-1))**2
+ & +LAMC(3)**2*TWO*MX(GT)*MX(GT-1)*(MQS-TH)*(MNS-TH)*
+ & (A(SP,GT)*A(SP,GT-1)+B(SP,GT)*B(SP,GT-1))
+ & /(TH-MS2(GT))/(TH-MS2(GT-1))
+ & +LAMC(1)*LAMC(3)*TWO*MX(GR)*MX(GT-1)*
+ & (SH-MS2(GR))*SCF(GR)*A(SP,GT-1)*SH*
+ & (A(SP,GR)*TH+B(SP,GR)*MQ*MN)/(TH-MS2(GT-1))
+ IF(ABS(MX(GU)).GT.EPS) ME(1)=ME(1)-LAMC(2)*LAMC(3)*TWO*
+ & MX(GU)*MX(GT-1)*(MQS*MNS-UH*TH)*A(SP,GT-1)*A(SP,GU)
+ & /(TH-MS2(GT-1))/(UH-MS2(GU))
+ ENDIF
+c--phase space factors
+ MEC(L,GN,I,J) = G**2*FAC*ME(1)*PCM
+ 210 CON = 4
+ I2 = SP+2
+ IF(MOD(K,2).EQ.1) I2 =I2+2
+ HCS=HCS+MEC(L,GN,I,J)*DISF(I1,1)*DISF(J1,2)
+ IF(GENEV.AND.HCS.GT.RCS) CALL HWHRSS(3,I1,J1,K,I2,0,0,*900)
+ HCS=HCS+MEC(L,GN,I,J)*DISF(J1,1)*DISF(I1,2)
+ IF(GENEV.AND.HCS.GT.RCS) CALL HWHRSS(4,J1,I1,K,I2,0,0,*900)
+ HCS=HCS+MEC(L,GN,I,J)*DISF(I1+6,1)*DISF(J1+6,2)
+ IF(GENEV.AND.HCS.GT.RCS) CALL HWHRSS(3,I1,J1,K,I2+2,1,0,*900)
+ HCS=HCS+MEC(L,GN,I,J)*DISF(J1+6,1)*DISF(I1+6,2)
+ IF(GENEV.AND.HCS.GT.RCS) CALL HWHRSS(4,J1,I1,K,I2+2,1,0,*900)
+ 220 CONTINUE
+ ENDDO
+ 230 CONTINUE
+ 240 CONTINUE
+C--Now the radiative decays, if possible
+ 300 IF(.NOT.RAD.OR.(CHAN(5).LT.EPS.AND.CHAN(11).LT.EPS)) GOTO 400
+ IF(GENEV) GOTO 320
+ DO 310 I=1,6
+ 310 MER(I)=ZERO
+C--stop to light stop and Z
+ IF(SH.GT.(MZ+MS(11))**2) THEN
+ PCM = SQRT((SH-(MZ+MS(11))**2)*(SH-(MZ-MS(11))**2))*HALF/SQSH
+ ECM=SQRT(PCM**2+MZ2)
+ TH = MZ2-SQSH*(ECM-PCM*COSTH)
+ UH = MZ2-SQSH*(ECM+PCM*COSTH)
+ MER(3) = SH**2*PCM**2*(SCF(11)*ZSQU(2,1)**2*QMIXSS(6,2,1)**2
+ & +SCF(12)*ZSQU(2,2)**2*QMIXSS(6,2,2)**2
+ & +TWO*SCF(11)*SCF(12)*QMIXSS(6,2,1)*QMIXSS(6,2,2)*
+ & ZSQU(2,1)*ZSQU(2,2)*((SH-MS2(11))*
+ & (SH-MS2(12))+MSWD(11)*MSWD(12)))
+ & +QMIXSS(6,2,1)**2/UH**2*ZQRK(1)**2*(
+ & TWO*MZ2*(UH*TH-MS2(11)*MZ2)+UH**2*SH)
+ & +QMIXSS(6,2,1)**2/TH**2*ZQRK(1)**2*(
+ & TWO*MZ2*(UH*TH-MS2(11)*MZ2)+TH**2*SH)
+ & +ZQRK(1)*SH*QMIXSS(6,2,1)*
+ & (QMIXSS(6,2,1)*ZSQU(2,1)*(SH-MS2(11))*SCF(11)
+ & +QMIXSS(6,2,2)*ZSQU(2,2)*(SH-MS2(12))*SCF(12))
+ & *((MZ2*(TWO*MS2(11)-TH)+TH*(SH-MS2(11)))/TH
+ & +(MZ2*(TWO*MS2(11)-UH)+UH*(SH-MS2(11)))/UH)
+ & -TWO*QMIXSS(6,2,1)**2/UH/TH*ZQRK(1)**2*
+ & (TWO*MZ2*(MS2(11)-UH)*(MS2(11)-TH)-SH*TH*UH)
+ MER(3) = MER(3)*FOUR*PCM/MZ2
+ ENDIF
+C--sbottom to light sbottom and Z
+ IF(SH.GT.(MZ+MS(5))**2) THEN
+ PCM = SQRT((SH-(MZ+MS(5))**2)*(SH-(MZ-MS(5))**2))*HALF/SQSH
+ ECM=SQRT(PCM**2+MZ2)
+ TH = MZ2-SQSH*(ECM-PCM*COSTH)
+ UH = MZ2-SQSH*(ECM+PCM*COSTH)
+ MER(6) = SH**2*PCM**2*(SCF(5)*QMIXSS(5,2,1)**2*ZSQU(1,1)**2
+ & +SCF(6)*QMIXSS(5,2,2)**2*ZSQU(1,2)**2
+ & +TWO*SCF(5)*SCF(6)*QMIXSS(5,2,1)*QMIXSS(5,2,2)*
+ & ZSQU(1,1)*ZSQU(1,2)*((SH-MS2(5))*
+ & (SH-MS2(6))+MSWD(5)*MSWD(6)))
+ & +QMIXSS(5,2,1)**2/UH**2*ZQRK(1)**2*
+ & (TWO*MZ2*(UH*TH-MS2(5)*MZ2)+UH**2*SH)
+ & +QMIXSS(5,2,1)**2/TH**2*ZQRK(2)**2*
+ & (TWO*MZ2*(UH*TH-MS2(5)*MZ2)+TH**2*SH)
+ & +QMIXSS(5,2,1)*SH*
+ & (QMIXSS(5,2,1)*ZSQU(1,1)*(SH-MS2(5))*SCF(5)
+ & +QMIXSS(5,2,2)*ZSQU(1,2)*(SH-MS2(6))*SCF(6))*
+ & (ZQRK(1)/UH*(MZ2*(TWO*MS2(5)-UH)+(SH-MS2(5))*UH)
+ & +ZQRK(2)/TH*(MZ2*(TWO*MS2(5)-TH)+(SH-MS2(5))*TH))
+ & -TWO*QMIXSS(5,2,1)**2*ZQRK(1)*ZQRK(2)/UH/TH*
+ & (TWO*MZ2*(MS2(5)-UH)*(MS2(5)-TH)-SH*TH*UH)
+ MER(6) = MER(6)*FOUR*PCM/MZ2
+ ENDIF
+C--stop to sbottom and W
+ DO J=1,2
+ IF(SH.GT.(MW+MS(4+J))**2) THEN
+ PCM =SQRT((SH-(MW+MS(4+J))**2)*(SH-(MW-MS(4+J))**2))*HALF/SQSH
+C--diagram square pieces
+ DO I=1,2
+ MER(J)=MER(J)+SCF(10+I)*
+ & (QMIXSS(6,2,I)*QMIXSS(6,1,I)*QMIXSS(5,1,J))**2
+ ENDDO
+C--light/heavy interference
+ MER(J)=TWO*SH**2*PCM**3/MW2*(MER(J)+TWO*SCF(11)*SCF(12)*
+ & ((SH-MS2(11))*(SH-MS2(12))
+ & +MSWD(11)*MSWD(12))*QMIXSS(5,1,J)**2*
+ & QMIXSS(6,2,1)*QMIXSS(6,2,2)*QMIXSS(6,1,1)*QMIXSS(6,1,2))
+ ENDIF
+C--sbottom to stop and W
+ IF(SH.GT.(MW+MS(10+J))**2) THEN
+ PCM=SQRT((SH-(MW+MS(10+J))**2)*(SH-(MW-MS(10+J))**2))*HALF/SQSH
+C--diagram square pieces
+ DO I=1,2
+ MER(J+3)=MER(J+3)+SCF(4+I)*
+ & (QMIXSS(5,2,I)*QMIXSS(5,1,I)*QMIXSS(6,1,J))**2
+ ENDDO
+C--light/heavy interference
+ MER(J+3)=TWO*SH**2*PCM**3/MW2*(MER(J+3)+TWO*SCF(5)*SCF(6)*
+ & ((SH-MS2(5))*(SH-MS2(6))+
+ & MSWD(5)*MSWD(6))*QMIXSS(6,1,J)**2*
+ & QMIXSS(5,2,1)*QMIXSS(5,2,2)*QMIXSS(5,1,1)*QMIXSS(5,1,2))
+ ENDIF
+ ENDDO
+C--Now multiply by the parton distributions and phase space factors
+ 320 DO J=1,3
+ DO K=1,3
+ CON = 5
+C--resonant stop's
+ IF(ABS(LAMDA3(3,J,K)).GT.EPS.AND.J.LT.K) THEN
+ FAC2 = LAMDA3(3,J,K)**2*FAC*G**2
+ DO I=1,3
+ I1=2*J-1
+ J1=2*K-1
+ ME2 = MER(I)*FAC2
+ HCS=HCS+ME2*DISF(I1,1)*DISF(J1,2)
+ IF(GENEV.AND.HCS.GT.RCS) CALL HWHRSS(5,I1,J1,I,I,0,0,*900)
+ HCS=HCS+ME2*DISF(J1,1)*DISF(I1,2)
+ IF(GENEV.AND.HCS.GT.RCS) CALL HWHRSS(6,J1,I1,I,I,0,0,*900)
+ HCS=HCS+ME2*DISF(I1+6,1)*DISF(J1+6,2)
+ IF(GENEV.AND.HCS.GT.RCS) CALL HWHRSS(5,I1,J1,I,I,1,0,*900)
+ HCS=HCS+ME2*DISF(J1+6,1)*DISF(I1+6,2)
+ IF(GENEV.AND.HCS.GT.RCS) CALL HWHRSS(6,J1,I1,I,I,1,0,*900)
+ ENDDO
+ ENDIF
+C--resonant sbottom's
+ IF(ABS(LAMDA3(J,K,3)).GT.EPS) THEN
+ FAC2 = LAMDA3(J,K,3)**2*FAC*G**2
+ DO I=4,6
+ I1=2*J
+ J1=2*K-1
+ ME2 = MER(I)*FAC2
+ HCS=HCS+ME2*DISF(I1,1)*DISF(J1,2)
+ IF(GENEV.AND.HCS.GT.RCS) CALL HWHRSS(5,I1,J1,I,I,0,0,*900)
+ HCS=HCS+ME2*DISF(J1,1)*DISF(I1,2)
+ IF(GENEV.AND.HCS.GT.RCS) CALL HWHRSS(6,J1,I1,I,I,0,0,*900)
+ HCS=HCS+ME2*DISF(I1+6,1)*DISF(J1+6,2)
+ IF(GENEV.AND.HCS.GT.RCS) CALL HWHRSS(5,I1,J1,I,I,1,0,*900)
+ HCS=HCS+ME2*DISF(J1+6,1)*DISF(I1+6,2)
+ IF(GENEV.AND.HCS.GT.RCS) CALL HWHRSS(6,J1,I1,I,I,1,0,*900)
+ ENDDO
+ ENDIF
+ ENDDO
+ ENDDO
+C--Now the Higgs decays if possible
+ 400 IF(.NOT.HIGGS) GOTO 900
+ IF(GENEV) GOTO 490
+ DO I=1,3
+ DO 405 J=1,42
+ 405 MEH(I,J) = ZERO
+ ENDDO
+ DO I=1,3
+ DO 420 J=1,3
+C--Neutral Higgs down type squark
+ IF(SQSH.LT.MH(J)+MS(2*I-1)) GOTO 410
+ PCM = SQRT((SH-(MH(J)+MS(2*I-1))**2)*
+ & (SH-(MH(J)-MS(2*I-1))**2))*HALF/SQSH
+ ECM=SQRT(PCM**2+MH(J)**2)
+ TH = MH(J)**2-SQSH*(ECM-PCM*COSTH)
+ UH = MH(J)**2-SQSH*(ECM+PCM*COSTH)
+ MEH(1,3*I-3+J) = PCM*SH*(
+ & QMIXSS(2*I-1,2,1)**2*SCF(2*I-1)*GHSQSS(J,2*I-1,1,1)**2
+ & +QMIXSS(2*I-1,2,2)**2*SCF(2*I)*GHSQSS(J,2*I-1,2,1)**2
+ & +TWO*QMIXSS(2*I-1,2,1)*QMIXSS(2*I-1,2,2)*SCF(2*I-1)
+ & *SCF(2*I)*GHSQSS(J,2*I-1,1,1)*GHSQSS(J,2*I-1,2,1)*
+ & ((SH-MS2(2*I-1))*(SH-MS2(2*I))+MSWD(2*I-1)*MSWD(2*I)))
+ MEH(2,3*I-3+J) = PCM*GUU(J)*QMIXSS(2*I,2,1)**2/TH**2*
+ & (TH*UH-MH(J)**2*MS2(2*I-1))
+ MEH(3,3*I-3+J) = PCM*GDD(J)*QMIXSS(2*I,2,1)**2/UH**2*
+ & (TH*UH-MH(J)**2*MS2(2*I-1))
+C--Neutral Higgs up type squarks
+ 410 IF(SQSH.LT.MH(J)+MS(2*I+5)) GOTO 420
+ PCM = SQRT((SH-(MH(J)+MS(2*I+5))**2)*
+ & (SH-(MH(J)-MS(2*I+5))**2))*HALF/SQSH
+ ECM=SQRT(PCM**2+MH(J)**2)
+ TH = MH(J)**2-SQSH*(ECM-PCM*COSTH)
+ UH = MH(J)**2-SQSH*(ECM+PCM*COSTH)
+ MEH(1,3*I+6+J) = PCM*SH*(
+ & QMIXSS(2*I,2,1)**2*SCF(2*I+5)*GHSQSS(J,2*I,1,1)**2
+ & +QMIXSS(2*I,2,2)**2*SCF(2*I+6)*GHSQSS(J,2*I,2,1)**2
+ & +TWO*QMIXSS(2*I,2,1)*QMIXSS(2*I,2,2)*SCF(2*I+5)
+ & *SCF(2*I+6)*GHSQSS(J,2*I,1,1)*GHSQSS(J,2*I,2,1)*
+ & ((SH-MS2(2*I+5))*(SH-MS2(2*I+6))+
+ & MSWD(2*I+5)*MSWD(2*I+6)))
+ MEH(2,3*I+6+J) = PCM*GDD(J)*QMIXSS(2*I-1,2,1)**2/TH**2*
+ & (TH*UH-MH(J)**2*MS2(2*I+5))
+ MEH(3,3*I+6+J) = PCM*GDD(J)*QMIXSS(2*I-1,2,1)**2/UH**2*
+ & (TH*UH-MH(J)**2*MS2(2*I+5))
+ 420 CONTINUE
+C--Charged Higgs up type squark
+ DO 440 J=1,2
+ IF(SQSH.LT.MH(4)+MS(2*I+4+J)) GOTO 430
+ PCM = SQRT((SH-(MH(4)+MS(2*I+4+J))**2)*
+ & (SH-(MH(4)-MS(2*I+4+J))**2))*HALF/SQSH
+ ECM=SQRT(PCM**2+MH(4)**2)
+ TH = MH(4)**2-SQSH*(ECM-PCM*COSTH)
+ UH = MH(4)**2-SQSH*(ECM+PCM*COSTH)
+ MEH(1,4*I+14+J) = PCM*SH*(
+ & QMIXSS(2*I-1,2,1)**2*GHSQSS(4,2*I,J,1)**2*SCF(2*I-1)
+ & +QMIXSS(2*I-1,2,2)**2*GHSQSS(4,2*I,J,2)**2*SCF(2*I)
+ & +TWO*QMIXSS(2*I-1,2,1)*QMIXSS(2*I-1,2,2)*SCF(2*I-1)
+ & *SCF(2*I)*GHSQSS(4,2*I,J,1)*GHSQSS(4,2*I,J,2)*
+ & ((SH-MS2(2*I-1))*(SH-MS2(2*I))+
+ & MSWD(2*I-1)*MSWD(2*I)))
+ MEH(2,4*I+14+J) = PCM*QMIXSS(2*I,2,J)**2*GDD(4)/TH**2*
+ & (UH*TH-MS2(2*I+4+J)*MH(4)**2)
+C--Charged Higgs down type squark
+ 430 IF(SQSH.LT.MH(4)+MS(2*I-2+J)) GOTO 440
+ PCM = SQRT((SH-(MH(4)+MS(2*I-2+J))**2)*
+ & (SH-(MH(4)-MS(2*I-2+J))**2))*HALF/SQSH
+ ECM=SQRT(PCM**2+MH(4)**2)
+ TH = MH(4)**2-SQSH*(ECM-PCM*COSTH)
+ UH = MH(4)**2-SQSH*(ECM+PCM*COSTH)
+ MEH(1,4*I+16+J) = PCM*SH*(
+ & QMIXSS(2*I,2,1)**2*GHSQSS(4,2*I-1,J,1)**2*SCF(2*I+5)
+ & +QMIXSS(2*I,2,2)**2*GHSQSS(4,2*I-1,J,2)**2*SCF(2*I+6)
+ & +TWO*QMIXSS(2*I,2,1)*QMIXSS(2*I,2,2)*SCF(2*I+5)
+ & *SCF(2*I+6)*GHSQSS(4,2*I-1,J,1)*GHSQSS(4,2*I-1,J,2)*
+ & ((SH-MS2(2*I+5))*(SH-MS2(2*I+6))+
+ & MSWD(2*I+5)*MSWD(2*I+6)))
+ MEH(2,4*I+16+J) = PCM*QMIXSS(2*I-1,2,J)**2*GUU(4)/TH**2*
+ & (UH*TH-MS2(2*I-2+J)*MH(4)**2)
+ MEH(3,4*I+16+J) = PCM*QMIXSS(2*I-1,2,J)**2*GUU(4)/UH**2*
+ & (UH*TH-MS2(2*I-2+J)*MH(4)**2)
+ 440 CONTINUE
+ ENDDO
+ 490 DO I=1,3
+ DO J=1,3
+ DO K=1,3
+ CON = 5
+ DO L=1,3
+ IF(ABS(LAMDA3(J,K,I)).GT.EPS) THEN
+C--neutral higgs and sdown
+ FAC2 = FAC*G**2*LAMDA3(J,K,I)**2
+ I1=2*J
+ J1=2*K-1
+ ME2 = FAC2*(MEH(1,3*I-3+L)+RMASS(I1)**2*MEH(2,3*I-3+L)
+ & +RMASS(J1)**2*MEH(3,3*I-3+L))
+ HCS=HCS+ME2*DISF(I1,1)*DISF(J1,2)
+ IF(GENEV.AND.HCS.GT.RCS) CALL HWHRSS(7,I1,J1,L,2*I-1,0,0,*900)
+ HCS=HCS+ME2*DISF(J1,1)*DISF(I1,2)
+ IF(GENEV.AND.HCS.GT.RCS) CALL HWHRSS(8,J1,I1,L,2*I-1,0,0,*900)
+ IF(I2.NE.200) I2=198
+ HCS=HCS+ME2*DISF(I1+6,1)*DISF(J1+6,2)
+ IF(GENEV.AND.HCS.GT.RCS) CALL HWHRSS(7,I1,J1,L,2*I-1,1,0,*900)
+ HCS=HCS+ME2*DISF(J1+6,1)*DISF(I1+6,2)
+ IF(GENEV.AND.HCS.GT.RCS) CALL HWHRSS(8,J1,I1,L,2*I-1,1,0,*900)
+ ENDIF
+ IF(ABS(LAMDA3(I,J,K)).GT.EPS.AND.J.LT.K) THEN
+ FAC2 = FAC*G**2*LAMDA3(I,J,K)**2
+C--neutral higgs and sup
+ I1=2*J-1
+ J1=2*K-1
+ ME2 = FAC2*(MEH(1,3*I+6+L)+RMASS(I1)**2*MEH(2,3*I+6+L)
+ & +RMASS(J1)**2*MEH(3,3*I+6+L))
+ HCS=HCS+ME2*DISF(I1,1)*DISF(J1,2)
+ IF(GENEV.AND.HCS.GT.RCS) CALL HWHRSS(7,I1,J1,L,2*I+5,0,0,*900)
+ HCS=HCS+ME2*DISF(J1,1)*DISF(I1,2)
+ IF(GENEV.AND.HCS.GT.RCS) CALL HWHRSS(8,J1,I1,L,2*I+5,0,0,*900)
+ HCS=HCS+ME2*DISF(I1+6,1)*DISF(J1+6,2)
+ IF(GENEV.AND.HCS.GT.RCS) CALL HWHRSS(7,I1,J1,L,2*I+5,1,0,*900)
+ HCS=HCS+ME2*DISF(J1+6,1)*DISF(I1+6,2)
+ IF(GENEV.AND.HCS.GT.RCS) CALL HWHRSS(8,J1,I1,L,2*I+5,1,0,*900)
+ ENDIF
+ ENDDO
+ DO L=1,2
+ IF(ABS(LAMDA3(J,K,I)).GT.EPS) THEN
+C--charged higgs and sup
+ I1=2*J
+ J1=2*K-1
+ FAC2 = FAC*G**2
+ ME2 = FAC2*(LAMDA3(J,K,I)**2*MEH(1,4*I+L+14)
+ & +LAMDA3(I,J,K)**2*RMASS(I1-1)**2*MEH(2,4*I+L+14))
+ HCS= HCS+ME2*DISF(I1,1)*DISF(J1,2)
+ IF(GENEV.AND.HCS.GT.RCS) CALL HWHRSS(7,I1,J1,4,2*I+4+L,0,0,*900)
+ HCS= HCS+ME2*DISF(J1,1)*DISF(I1,2)
+ IF(GENEV.AND.HCS.GT.RCS) CALL HWHRSS(8,J1,I1,4,2*I+4+L,0,0,*900)
+ HCS= HCS+ME2*DISF(I1+6,1)*DISF(J1+6,2)
+ IF(GENEV.AND.HCS.GT.RCS) CALL HWHRSS(7,I1,J1,5,2*I+4+L,1,0,*900)
+ HCS= HCS+ME2*DISF(J1+6,1)*DISF(I1+6,2)
+ IF(GENEV.AND.HCS.GT.RCS) CALL HWHRSS(8,J1,I1,5,2*I+4+L,1,0,*900)
+ ENDIF
+C--charged higgs and sdown
+ IF(ABS(LAMDA3(I,J,K)).GT.EPS.AND.J.LT.K) THEN
+ I1=2*J-1
+ J1=2*K-1
+ FAC2 = FAC*G**2
+ ME2 = FAC2*(MEH(1,4*I+L+16)*LAMDA3(I,J,K)**2
+ & +RMASS(I1+1)**2*LAMDA3(J,I,K)**2*MEH(2,4*I+L+16)
+ & +RMASS(J1+1)**2*LAMDA3(K,I,J)**2*MEH(3,4*I+L+16))
+ HCS=HCS+ME2*DISF(I1,1)*DISF(J1,2)
+ IF(GENEV.AND.HCS.GT.RCS) CALL HWHRSS(7,I1,J1,5,2*I-2+L,0,0,*900)
+ HCS=HCS+ME2*DISF(J1,1)*DISF(I1,2)
+ IF(GENEV.AND.HCS.GT.RCS) CALL HWHRSS(8,J1,I1,5,2*I-2+L,0,0,*900)
+ HCS=HCS+ME2*DISF(I1+6,1)*DISF(J1+6,2)
+ IF(GENEV.AND.HCS.GT.RCS) CALL HWHRSS(7,I1,J1,4,2*I-2+L,1,0,*900)
+ HCS=HCS+ME2*DISF(J1+6,1)*DISF(I1+6,2)
+ IF(GENEV.AND.HCS.GT.RCS) CALL HWHRSS(8,J1,I1,4,2*I-2+L,1,0,*900)
+ ENDIF
+ ENDDO
+ ENDDO
+ ENDDO
+ ENDDO
+C--calculate of the matrix elements
+ 900 IF(GENEV) THEN
+ CALL HWETWO
+ IF(IERROR.NE.0) RETURN
+ HVFCEN = .TRUE.
+C--first stage of the colour connection corrections
+ DO THEP=1,5
+ IF(THEP.NE.3) THEN
+ JMOHEP(2,THEP+NHEP-5)=NHEP-5+THEP
+ & +CONECT(HWRINT(1,2),THEP,CON)
+ JDAHEP(2,THEP+NHEP-5) = JMOHEP(2,THEP+NHEP-5)
+ ENDIF
+ ENDDO
+ IF(IDHEP(NHEP-4).LT.0) THEN
+ JDAHEP(2,NHEP-4)=NHEP-1
+ JDAHEP(2,NHEP-3)=NHEP-3
+ JDAHEP(2,NHEP-1)=NHEP-4
+ IF(CON.EQ.5) JDAHEP(2,NHEP-4)=NHEP
+ JDAHEP(2,NHEP)=CONECT(1,6,CON)+NHEP
+ ELSE
+ JMOHEP(2,NHEP-4)=NHEP-1
+ JMOHEP(2,NHEP-3)=NHEP-3
+ JMOHEP(2,NHEP-1)=NHEP-4
+ IF(CON.EQ.5) JMOHEP(2,NHEP-4)=NHEP
+ JMOHEP(2,NHEP)=CONECT(1,6,CON)+NHEP
+ ENDIF
+ IF(CON.EQ.5) THEN
+ SP=JDAHEP(2,NHEP)
+ JDAHEP(2,NHEP) = JDAHEP(2,NHEP-1)
+ JDAHEP(2,NHEP-1) = SP
+ SP=JMOHEP(2,NHEP)
+ JMOHEP(2,NHEP) = JMOHEP(2,NHEP-1)
+ JMOHEP(2,NHEP-1) = SP
+ ENDIF
+ HRDCOL(1,1) = NHEP
+ HRDCOL(1,2) = NHEP-2
+ ELSE
+ EVWGT = HCS
+ ENDIF
+ 999 END
+CDECK ID>, HWHREM.
+*CMZ :- -01/06/94 17.03.31 by Mike Seymour
+*-- Author : Mike Seymour
+C-----------------------------------------------------------------------
+ SUBROUTINE HWHREM(IBEAM,ITARG)
+C-----------------------------------------------------------------------
+C IDENTIFY THE REMNANTS OF THE HARD SCATTERING
+C AND BREAK THEIR COLOUR CONNECTION IF NECESSARY
+C-----------------------------------------------------------------------
+ INCLUDE 'HERWIG61.INC'
+ DOUBLE PRECISION PCL(5)
+ INTEGER IBEAM,ITARG,IHEP,NTEMP,I,ICOL,IANT
+ LOGICAL LTEMP,T,COL,ANT
+ PARAMETER (T=.TRUE.)
+ COL(I)=I.EQ.13 .OR. I.GE.1.AND.I.LE.6 .OR. I.GE.115.AND.I.LE.120
+ ANT(I)=I.EQ.13 .OR. I.GE.7.AND.I.LE.12.OR. I.GE.109.AND.I.LE.114
+C---LOOK FOR UNTREATED BEAM AND TARGET REMNANTS
+ IBEAM=0
+ ITARG=0
+ DO 10 IHEP=1,NHEP
+ IF (ISTHEP(IHEP).EQ.148) THEN
+ IF (ITARG.NE.0) CALL HWWARN('HWHREM',100,*999)
+ ITARG=IHEP
+ ELSEIF (ISTHEP(IHEP).EQ.147) THEN
+ IF (IBEAM.NE.0) CALL HWWARN('HWHREM',101,*999)
+ IBEAM=IHEP
+ ENDIF
+ 10 CONTINUE
+ IF (ITARG.EQ.0) CALL HWWARN('HWHREM',102,*999)
+ IF (IBEAM.EQ.0) CALL HWWARN('HWHREM',103,*999)
+C---IF THEY ARE COLOUR CONNECTED, DISCONNECT THEM BY EMITTING A SOFT
+C GLUON AND SPLITTING THAT GLUON TO LIGHT QUARKS
+C (WHICH NORMALLY GETS DONE AS THE FIRST STAGE OF CLUSTER FORMATION)
+C---LOOP OVER COLOUR/ANTICOLOUR LINE
+ DO 20 I=1,2
+ IF (I.EQ.1) THEN
+ ICOL=IBEAM
+ IANT=ITARG
+ ELSE
+ ICOL=ITARG
+ IANT=IBEAM
+ ENDIF
+ IF (COL(IDHW(ICOL)).AND.ANT(IDHW(IANT)).AND.
+ $ JMOHEP(2,ICOL).EQ.IANT.AND.JDAHEP(2,IANT).EQ.ICOL) THEN
+ CALL HWVSUM(4,PHEP(1,ICOL),PHEP(1,IANT),PCL)
+ CALL HWUMAS(PCL)
+ NTEMP=NHEP
+ CALL HWCCUT(ICOL,IANT,PCL,T,LTEMP)
+C---IF NOTHING WAS CREATED THEY MUST BE BELOW THRESHOLD, SO GIVE UP
+ IF (NHEP.NE.NTEMP+2) RETURN
+C---RELABEL THEM AS PERTUBATIVE JUST TO NEATEN UP THE EVENT RECORD
+ ISTHEP(NHEP-1)=149
+ ISTHEP(NHEP)=149
+ ENDIF
+ 20 CONTINUE
+ 999 END
+CDECK ID>, HWHRLL.
+*CMZ :- -13/12/99 15:12:21 by Peter Richardson
+*-- Author : Peter Richardson
+C-----------------------------------------------------------------------
+ SUBROUTINE HWHRLL
+C-----------------------------------------------------------------------
+C Subroutine for resonant sleptons to standard model particles
+C-----------------------------------------------------------------------
+ INCLUDE 'HERWIG61.INC'
+ DOUBLE PRECISION HCS,S,RCS,HWR,FAC,ECM,TH,PCM,CFAC,CHANPB,SH,
+ & TAU,TAUA,TAUB,LOWTLM,UPPTLM,HWRUNI,MSL(12),
+ & SQSH,MET(2),SCF(12),MIX(12),ME(4,3,3,3,3,2),
+ & RAND,CHAN(12),LAM(2,7,3,3,3,3),SLWD(12),RTAB,
+ & WD,MQ1,MQ2,EPS,XMIN,XMAX,XPOW,XUPP,MSL2(12),
+ & MSWD(12)
+ INTEGER I,J,K,L,I1,J1,K1,L1,GEN,GN,GR,GNMX,GNMN,MIG,MXG,CUP,CF
+ LOGICAL FIRST
+ EXTERNAL HWR,HWRUNI
+ PARAMETER(EPS=1D-20)
+ COMMON/HWRPIN/XMIN,XMAX,XPOW,FIRST
+ SAVE HCS,ME,MSL,SLWD,LAM,MIX,CHAN,GNMN,GNMX,SH,SQSH,FAC,SCF
+ IF(GENEV) THEN
+ RCS = HCS*HWR()
+ ELSE
+ IF(FSTWGT) THEN
+ DO I=1,3
+ MSL(2*I-1) = RMASS(423+2*I)
+ MSL(2*I) = RMASS(435+2*I)
+ MSL(2*I+5) = RMASS(424+2*I)
+ MSL(2*I+6) = RMASS(436+2*I)
+ SLWD(2*I-1) = HBAR/RLTIM(423+2*I)
+ SLWD(2*I) = HBAR/RLTIM(435+2*I)
+ SLWD(2*I+5) = HBAR/RLTIM(424+2*I)
+ SLWD(2*I+6) = HBAR/RLTIM(436+2*I)
+ ENDDO
+ DO I=1,12
+ MSL2(I) = MSL(I)**2
+ MSWD(I) = MSL(I)*SLWD(I)
+ ENDDO
+ RAND = ZERO
+ DO I=1,3
+ CHANPB=ZERO
+ DO J=1,3
+ DO K=1,3
+ CHANPB=CHANPB+LAMDA2(I,J,K)**4
+ ENDDO
+ ENDDO
+ RAND=RAND+2*CHANPB
+ DO J=1,2
+ CHAN(2*I-2+J) = LMIXSS(2*I-1,1,J)**2*CHANPB
+ CHAN(2*I+4+J) = LMIXSS(2*I ,1,J)**2*CHANPB
+ MIX(2*I-2+J) = LMIXSS(2*I-1,1,J)**2
+ MIX(2*I+4+J) = LMIXSS(2*I ,1,J)**2
+ ENDDO
+ ENDDO
+ IF(RAND.GT.ZERO) THEN
+ DO I=1,12
+ CHAN(I)=CHAN(I)/RAND
+ ENDDO
+ ELSE
+ CALL HWWARN('HWHRLL',500,*999)
+ ENDIF
+C--find the couplings
+ DO GN=1,3
+ DO I=1,3
+ DO J=1,3
+ DO K=1,3
+ DO L=1,3
+ LAM(1,GN,I,J,K,L) =LAMDA2(GN,I,J)*LAMDA1(GN,K,L)
+ LAM(2,GN,I,J,K,L) =LAMDA2(GN,I,J)*LAMDA2(GN,K,L)
+ LAM(1,GN+3,I,J,K,L)=LAM(1,GN,I,J,K,L)
+ LAM(2,GN+3,I,J,K,L)=LAM(2,GN,I,J,K,L)
+ ENDDO
+ ENDDO
+ ENDDO
+ ENDDO
+ ENDDO
+C--select the process from the IPROC code
+ GNMN = 1
+ GNMX = 4
+ IF(IPROC.EQ.4070) THEN
+ GNMX = 2
+ ELSEIF(IPROC.EQ.4080) THEN
+ GNMN = 3
+ ENDIF
+ ENDIF
+ EVWGT = ZERO
+ S = PHEP(5,3)**2
+ COSTH = HWRUNI(0,-ONE,ONE)
+C--Generate the smoothing
+ RAND=HWRUNI(0,ZERO,ONE)
+ DO I=1,12
+ IF(CHAN(I).GT.RAND) GOTO 20
+ RAND=RAND-CHAN(I)
+ ENDDO
+ 20 GR = I
+C--Calculate hard scale and obtain parton distributions
+ TAUA = MSL2(GR)/S
+ TAUB = SLWD(GR)**2/S
+ RTAB = SQRT(TAUA*TAUB)
+ XUPP = XMAX
+ IF(XMAX**2.GT.S) XUPP = SQRT(S)
+ LOWTLM = DATAN((XMIN**2/S-TAUA)/RTAB)/RTAB
+ UPPTLM = DATAN((XUPP**2/S-TAUA)/RTAB)/RTAB
+ TAU = HWRUNI(0,LOWTLM,UPPTLM)
+ TAU = RTAB*TAN(RTAB*TAU)+TAUA
+ SH = S*TAU
+ SQSH = SQRT(SH)
+ EMSCA = SQSH
+ XX(1) = EXP(HWRUNI(0,ZERO,LOG(TAU)))
+ XX(2) = TAU/XX(1)
+ CALL HWSGEN(.FALSE.)
+C--Calculate the prefactor due multichannel approach
+ FAC = ZERO
+ DO GN=1,12
+ SCF(GN)=1/((SH-MSL2(GN))**2+MSWD(GN)**2)
+ FAC=FAC+CHAN(GN)*SCF(GN)
+ ENDDO
+ FAC=-(UPPTLM-LOWTLM)*LOG(TAU)*GEV2NB
+ & /(96*PIFAC*SQSH*SH*TAU*FAC*S**2)
+ ENDIF
+C--Now the loop to actually calculate the cross-sections
+ HCS = ZERO
+ DO GN=GNMN,GNMX
+ IF(MOD(GN,2).EQ.1) THEN
+ MIG = 1
+ MXG = 6
+ ELSE
+ MIG = 7
+ MXG = 12
+ ENDIF
+ IF(GN.LE.2) THEN
+ CFAC = THREE*FAC
+ CUP=2
+ ELSE
+ CFAC = FAC
+ CUP=1
+ ENDIF
+ DO K1=1,3
+ DO 80 L1=1,3
+ IF(GN.EQ.1) THEN
+ K = 2*K1
+ L = 2*L1+5
+ ELSEIF(GN.EQ.2) THEN
+ K = 2*K1-1
+ L = 2*L1+5
+ ELSEIF(GN.EQ.3) THEN
+ K = 120+2*K1
+ L = 125+2*L1
+ ELSEIF(GN.EQ.4) THEN
+ K = 119+2*K1
+ L = 125+2*L1
+ ENDIF
+ MQ1 = RMASS(K)
+ MQ2 = RMASS(L)
+ IF(SQSH.GT.(MQ1+MQ2)) THEN
+ PCM = SQRT((SH-(MQ1+MQ2)**2)*(SH-(MQ1-MQ2)**2))/(2*SQSH)
+ WD = (SH-MQ1**2-MQ2**2)*SH*PCM
+ ELSE
+ GOTO 80
+ ENDIF
+ DO I1=1,3
+ DO 70 J1=1,3
+ IF(MOD(GN,2).EQ.1) THEN
+ I=2*I1
+ J=2*J1+5
+ ELSE
+ I=2*I1-1
+ J=2*J1+5
+ ENDIF
+ DO GR =1,2
+ MET(GR) = ZERO
+ ENDDO
+ IF(GENEV) GOTO 60
+ DO 50 GEN=MIG,MXG
+ IF(ABS(LAM(CUP,INT((GEN+1)/2),I1,J1,K1,L1)).LT.EPS.
+ & OR.ABS(MIX(GEN)).LT.EPS) GOTO 50
+ DO GR=MIG,MXG
+ IF(ABS(LAM(CUP,INT((GR+1)/2),I1,J1,K1,L1)).GT.EPS.
+ & AND.ABS(MIX(GR)).GT.EPS) THEN
+ MET(1) =MET(1)+SCF(GEN)*SCF(GR)*WD*
+ & ((SH-MSL2(GEN))*(SH-MSL2(GR))+MSWD(GEN)*MSWD(GR))
+ & *LAM(CUP,INT((GEN+1)/2),I1,J1,K1,L1)*MIX(GEN)
+ & *LAM(CUP,INT((GR+1)/2),I1,J1,K1,L1)*MIX(GR)
+ ENDIF
+ ENDDO
+C--Now the t-channel diagrams if the s-channel particles is a sneutrino
+ IF(GN.EQ.2) THEN
+ ECM=SQRT(PCM**2+MQ1**2)
+ TH=MQ1**2-SQSH*(ECM-PCM*COSTH)
+ DO GR=MIG,MXG
+ MET(2)=MET(2)+(MQ1**2-TH)*(MQ2**2-TH)*PCM*
+ & LAM(2,INT((GEN+1)/2),I1,K1,J1,L1)*MIX(GEN)*
+ & LAM(2,INT((GR+1)/2),I1,K1,J1,L1)*MIX(GR)
+ & /((TH-MSL2(GEN))*(TH-MSL2(GR)))
+ ENDDO
+ ENDIF
+ 50 CONTINUE
+C--final phase space factors
+ IF(MET(1).LT.EPS.AND.MET(2).LT.EPS) GOTO 70
+ DO GR = 1,2
+ ME(GN,I1,J1,K1,L1,GR) = MET(GR)*CFAC
+ ENDDO
+ 60 DO GR = 1,2
+ CF = GR
+ IF(CUP.EQ.1) CF=0
+ HCS = HCS+ME(GN,I1,J1,K1,L1,GR)*DISF(I,1)*DISF(J,2)
+ IF(HCS.GT.RCS.AND.GENEV)
+ & CALL HWHRSS(9,I,J,K,L,0,CF,*100)
+ HCS = HCS+ME(GN,I1,J1,K1,L1,GR)*DISF(J,1)*DISF(I,2)
+ IF(HCS.GT.RCS.AND.GENEV)
+ & CALL HWHRSS(10,J,I,K,L,0,CF,*100)
+ HCS = HCS+ME(GN,I1,J1,K1,L1,GR)
+ & *DISF(I+6,1)*DISF(J-6,2)
+ IF(HCS.GT.RCS.AND.GENEV)
+ & CALL HWHRSS(9,I,J,K,L,1,CF,*100)
+ HCS = HCS+ME(GN,I1,J1,K1,L1,GR)
+ & *DISF(J-6,1)*DISF(I+6,2)
+ IF(HCS.GT.RCS.AND.GENEV)
+ & CALL HWHRSS(10,J,I,K,L,1,CF,*100)
+ ENDDO
+ 70 CONTINUE
+ ENDDO
+ 80 CONTINUE
+ ENDDO
+ ENDDO
+ 100 IF(GENEV) THEN
+ CALL HWETWO
+ ELSE
+ EVWGT = HCS
+ ENDIF
+ 999 END
+CDECK ID>, HWHRLS.
+*CMZ :- -20/10/99 09:46:43 by Peter Richardson
+*-- Author : Peter Richardson
+C-----------------------------------------------------------------------
+ SUBROUTINE HWHRLS
+C-----------------------------------------------------------------------
+C Subroutine for 2 parton -> sparticle + X via LQD
+C-----------------------------------------------------------------------
+ INCLUDE 'HERWIG61.INC'
+ DOUBLE PRECISION HCS,A(6,12),B(6,12),S,RCS,HWR,CW,FAC2,EC,ME2,
+ & MW,G,TAU,TAUA,TAUB,LOWTLM,UPPTLM,HWRUNI,SW,SQSH,LC,
+ & SH,MSL(12),MSU(12),MST(6),C(2,6,12),D(2,6,12),UH,
+ & TH,MEN(4,6,3,3),SCF(12),SLWD(12),MLT(6),MNT(4),PCM,
+ & MXS(12),MER(8),MCR(2),RTAB,H(18),MEH(3,18),MXT(12),
+ & CHAN(12),MXU(12),RAND,FAC,ECM,MC(2),MEC(2,6,3,3),
+ & MZ,CHPROB,EPS,HWUAEM,XMIN,XMAX,XPOW,SIN2B,GUU(4),
+ & ML,MN,MLS,MNS,XUPP,MW2,MZ2,ZSLP(2),ZQRK(2),GDD(4),
+ & MSL2(12),MH(4),MSWD(12)
+ INTEGER I,J,K,L,J1,K1,GN,GR,SP,GU,GT,I2,I1,NEUTMN
+ & ,NEUTMX,CHARMN,CHARMX,P
+ LOGICAL RAD,NEUT,CHAR,HIGGS,FIRST
+ EXTERNAL HWR,HWRUNI,HWUAEM
+ COMMON/HWRPIN/XMIN,XMAX,XPOW,FIRST
+ SAVE HCS,A,B,C,D,FAC,MER,MEC,MEN,MLT,MSL,MSU,MST,SLWD,MNT,MXT,MXU,
+ & SW,CW,MXS,H,MEH,CHAN,NEUTMN,NEUTMX,CHARMN,CHARMX,RAD,NEUT,
+ & CHAR,HIGGS,MW,MZ,MW2,MZ2,MCR,SH,SQSH,EC,G,SCF,ZSLP,ZQRK,GUU,
+ & GDD,MSL2,MH,MSWD
+ PARAMETER(EPS=1D-20)
+ IF(GENEV) THEN
+ RCS = HCS*HWR()
+ ELSE
+ IF(FSTWGT) THEN
+C--Calculate Electroweak parameters needed
+ SW = SQRT(SWEIN)
+ CW = SQRT(1-SWEIN)
+ MW = RMASS(198)
+ MZ = RMASS(200)
+ MW2 = MW**2
+ MZ2 = MZ**2
+ SIN2B = TWO*SINB*COSB
+C--Masses and widths
+ DO I=1,3
+ MSL(2*I-1) = RMASS(423+2*I)
+ MSL(2*I) = RMASS(435+2*I)
+ MSL(2*I+5) = RMASS(424+2*I)
+ MSL(2*I+6) = RMASS(436+2*I)
+ SLWD(2*I-1) = HBAR/RLTIM(423+2*I)
+ SLWD(2*I) = HBAR/RLTIM(435+2*I)
+ SLWD(2*I+5) = HBAR/RLTIM(424+2*I)
+ SLWD(2*I+6) = HBAR/RLTIM(436+2*I)
+ MSU(2*I-1) = RMASS(400+2*I)**2
+ MSU(2*I) = RMASS(412+2*I)**2
+ MSU(2*I+5) = RMASS(399+2*I)**2
+ MSU(2*I+6) = RMASS(411+2*I)**2
+ MST(2*I-1) = RMASS(399+2*I)**2
+ MST(2*I) = RMASS(411+2*I)**2
+ MLT(2*I) = ZERO
+ MLT(2*I-1) = RMASS(119+2*I)
+ ENDDO
+ DO I=1,12
+ MSL2(I) = MSL(I)**2
+ MSWD(I) = MSL(I)*SLWD(I)
+ ENDDO
+ DO I=1,4
+ MNT(I) = ABS(RMASS(449+I))
+ ENDDO
+ MCR(1) = ABS(RMASS(454))
+ MCR(2) = ABS(RMASS(455))
+C--Couplings for the neutralinos
+ DO L=1,4
+ MC(1) = ZMIXSS(L,3)/(2*MW*COSB*SW)
+ MC(2) = ZMIXSS(L,4)/(2*MW*SINB*SW)
+ DO I=1,3
+ DO J=1,2
+C--resonant charged sleptons
+ A(L,2*I-2+J) = MC(1)*MLT(2*I-1)*LMIXSS(2*I-1,2,J)
+ & +SLFCH(9+2*I,L)*LMIXSS(2*I-1,1,J)
+ B(L,2*I-2+J) = ZSGNSS(L)*(MC(1)*MLT(2*I-1)*
+ & LMIXSS(2*I-1,1,J)+SRFCH(9+2*I,L)*LMIXSS(2*I-1,2,J))
+C--resonant sneutrinos
+ A(L,2*I+4+J) = SLFCH(10+2*I,L)*LMIXSS(2*I,1,J)
+ B(L,2*I+4+J) = ZERO
+C--u channel up type squarks
+ C(1,L,2*I-2+J) = MC(2)*QMIXSS(2*I,2,J)*
+ & RMASS(2*I)+SLFCH(2*I,L)*QMIXSS(2*I,1,J)
+ D(1,L,2*I-2+J) = ZSGNSS(L)*(MC(2)*QMIXSS(2*I,1,J)*
+ & RMASS(2*I)+SRFCH(2*I ,L)*QMIXSS(2*I,2,J))
+C--u channel down type squarks
+ C(1,L,2*I+4+J) = MC(1)*QMIXSS(2*I-1,2,J)*
+ & RMASS(2*I-1)+SLFCH(2*I-1,L)*QMIXSS(2*I-1,1,J)
+ D(1,L,2*I+4+J) = ZSGNSS(L)*(MC(1)*QMIXSS(2*I-1,1,J)*
+ & RMASS(2*I-1)+SRFCH(2*I-1,L)*QMIXSS(2*I-1,2,J))
+C--t channel down type squarks
+ C(2,L,2*I-2+J) = ZSGNSS(L)*(MC(1)*QMIXSS(2*I-1,1,J)*
+ & RMASS(2*I-1)+SRFCH(2*I-1,L)*QMIXSS(2*I-1,2,J))
+ D(2,L,2*I-2+J) = MC(1)*QMIXSS(2*I-1,2,J)*
+ & RMASS(2*I-1)+SLFCH(2*I-1,L)*QMIXSS(2*I-1,1,J)
+ ENDDO
+ ENDDO
+ DO I=1,6
+ C(2,L,6+I) = C(2,L,I)
+ D(2,L,6+I) = D(2,L,I)
+ ENDDO
+ ENDDO
+C--Couplings for charginos
+ DO L=1,2
+ MC(1) = 1/(SQRT(2.0D0)*MW*COSB)
+ MC(2) = 1/(SQRT(2.0D0)*MW*SINB)
+ SP=L+4
+ DO I=1,3
+ DO J=1,2
+C--resonant charged slepton
+ A(SP,2*I-2+J) = WMXUSS(L,1)*LMIXSS(2*I-1,1,J)
+ & -LMIXSS(2*I-1,2,J)*WMXUSS(L,2)*
+ & MLT(2*I-1)*MC(1)
+ B(SP,2*I-2+J) = ZERO
+C--resonant sneutrinos
+ A(SP,2*I+4+J) = WSGNSS(L)*WMXVSS(L,1)*LMIXSS(2*I,1,J)
+ B(SP,2*I+4+J) = -MLT(2*I-1)*WMXUSS(L,2)*LMIXSS(2*I,1,J)
+ & *MC(1)
+C--u channel sup
+ C(1,SP,2*I-2+J) = WSGNSS(L)*(WMXVSS(L,1)*QMIXSS(2*I,1,J)
+ & -WMXVSS(L,2)*MC(2)*RMASS(2*I)*QMIXSS(2*I,2,J))
+ D(1,SP,2*I-2+J) = -WMXUSS(L,2)*MC(1)*RMASS(2*I-1)
+ & *QMIXSS(2*I,1,J)
+C--u channel sdown
+ C(1,SP,2*I+4+J) = WMXUSS(L,1)*QMIXSS(2*I-1,1,J)
+ & -WMXUSS(L,2)*MC(1)*RMASS(2*I-1)*QMIXSS(2*I-1,2,J)
+ D(1,SP,2*I+4+J) = -WSGNSS(L)*WMXVSS(L,2)*MC(2)*
+ & RMASS(2*I)*QMIXSS(2*I-1,1,J)
+ ENDDO
+ ENDDO
+ ENDDO
+C--Couplings and massesfor Higgs
+ DO I=1,4
+ MH(I) = RMASS(202+I)
+ ENDDO
+C--first the neutral Higgs
+ DO I=1,3
+ H(I) = -MLT(2*I-1)*HALF/MW/COSB*MUSS*COSA
+ H(I+4) = -MLT(2*I-1)*HALF/MW/COSB*MUSS*SINA
+ H(I+8) = MLT(2*I-1)*HALF/MW*MUSS
+ ENDDO
+ H(3) = (H(3)-MLT(5)*HALF/MW/COSB*ALSS*SINA)*TWO*
+ & LMIXSS(5,2,1)*LMIXSS(5,1,1)
+ & -MZ*SINBPA/CW*(LMIXSS(5,1,1)**2*(HALF-SWEIN)
+ & +SWEIN*LMIXSS(5,2,1)**2)+MLT(5)**2*SINA/MW/COSB
+ H(4) = -MZ*SINBPA/CW*(LMIXSS(5,1,1)*LMIXSS(5,1,2)*(HALF-SWEIN)
+ & +SWEIN*LMIXSS(5,2,1)*LMIXSS(5,2,2))
+ & -MLT(5)*HALF/COSB/MW*(MUSS*COSA+ALSS*SINA)*
+ & (LMIXSS(5,2,2)*LMIXSS(5,1,1)+LMIXSS(5,1,2)*LMIXSS(5,2,1))
+ H(7) = (H(7)+MLT(5)*HALF/MW/COSB*ALSS*COSA)*TWO*
+ & LMIXSS(5,2,1)*LMIXSS(5,1,1)
+ & +MZ*COSBPA/CW*(LMIXSS(5,1,1)**2*(HALF-SWEIN)
+ & +LMIXSS(5,2,1)**2*SWEIN)-MLT(5)**2*COSA/MW/COSB
+ H(8) = MZ*COSBPA/CW*(LMIXSS(5,1,2)*LMIXSS(5,1,1)*(HALF-SWEIN)
+ & +LMIXSS(5,2,2)*LMIXSS(5,2,1)*SWEIN)
+ & -MLT(5)*HALF/MW/COSB*(MUSS*SINA-ALSS*COSA)*
+ & (LMIXSS(5,2,2)*LMIXSS(5,1,1)+LMIXSS(5,1,2)*LMIXSS(5,2,1))
+ H(12) = H(11)+MLT(5)*HALF/MW*ALSS*TANB
+ H(11) = ZERO
+C--Now the charged Higgs
+ DO J=1,2
+ DO I=1,3
+ H(10+2*I+J) = LMIXSS(2*I-1,1,J)*
+ & (MLT(2*I-1)**2*TANB-MW2*SIN2B)
+ & -LMIXSS(2*I-1,2,J)*MLT(2*I-1)*MUSS
+ ENDDO
+ H(16+J) = H(16+J)-LMIXSS(5,2,J)*MLT(5)*ALSS*TANB
+ ENDDO
+C--couplings of the Higgs to Squarks
+ DO I=1,3
+ GUU(I) = GHUUSS(I)**2/MW2*HALF**2
+ GDD(I) = GHDDSS(I)**2/MW2*HALF**2
+ ENDDO
+ GUU(4) = ONE/TANB**2/MW2/8.0D0
+ GDD(4) = ONE*TANB**2/MW2/8.0D0
+C--Couplings of the Z to quarks, left up right down, and charged sleptons
+ ZQRK(1) = -SW**2/6.0D0/CW
+ ZQRK(2) = (SW**2/3.0D0-HALF**2)/CW
+ ZSLP(1) = HALF*(LMIXSS(5,1,1)**2-2.0D0*SW**2)/CW
+ ZSLP(2) = HALF*LMIXSS(5,1,1)*LMIXSS(5,1,2)/CW
+C--parameters for multichannel integration
+ RAND = ZERO
+ DO I=1,3
+ CHPROB = ZERO
+ DO J=1,3
+ DO K=1,3
+ CHPROB=CHPROB+LAMDA2(I,J,K)**2
+ ENDDO
+ ENDDO
+ RAND = RAND+2*CHPROB
+ DO J=1,2
+ MXS(2*I-2+J) = LMIXSS(2*I-1,1,J)
+ MXS(2*I+4+J) = LMIXSS(2*I,1,J)
+ MXU(2*I-2+J) = QMIXSS(2*I,1,J)
+ MXU(2*I+4+J) = QMIXSS(2*I-1,1,J)
+ MXT(2*I-2+J) = QMIXSS(2*I-1,2,J)
+ MXT(2*I+4+J) = QMIXSS(2*I-1,2,J)
+ CHAN(2*I-2+J) = LMIXSS(2*I-1,1,J)**2*CHPROB
+ CHAN(2*I+4+J) = LMIXSS(2*I,1,J)**2*CHPROB
+ ENDDO
+ ENDDO
+ IF(RAND.GT.ZERO) THEN
+ DO I=1,12
+ CHAN(I)=CHAN(I)/RAND
+ ENDDO
+ ELSE
+ CALL HWWARN('HWHRLS',500,*999)
+ ENDIF
+C--decide what processes to generate
+ RAD = .FALSE.
+ NEUT = .FALSE.
+ CHAR = .FALSE.
+ HIGGS = .FALSE.
+ NEUTMN= 1
+ NEUTMX = 4
+ CHARMN = 1
+ CHARMX = 2
+C--Decide which process to generate
+ IF(IPROC.EQ.4000) THEN
+ RAD = .TRUE.
+ NEUT = .TRUE.
+ CHAR = .TRUE.
+ HIGGS = .TRUE.
+ ELSEIF(IPROC.LT.4020) THEN
+ IF(IPROC.NE.4010) THEN
+ NEUTMN = MOD(IPROC,10)
+ NEUTMX = NEUTMN
+ ENDIF
+ NEUT=.TRUE.
+ ELSEIF(IPROC.LT.4030) THEN
+ IF(IPROC.NE.4020) THEN
+ CHARMN = MOD(IPROC,10)
+ CHARMX=CHARMN
+ ENDIF
+ CHAR = .TRUE.
+ ELSEIF(IPROC.EQ.4040) THEN
+ RAD = .TRUE.
+ ELSEIF(IPROC.EQ.4050) THEN
+ HIGGS = .TRUE.
+ ENDIF
+ ENDIF
+C--basic parameters
+ EVWGT = ZERO
+ S = PHEP(5,3)**2
+ COSTH = HWRUNI(0,-ONE,ONE)
+ RAND = HWRUNI(0,ZERO,ONE)
+C--zero arrays
+ DO I=1,6
+ DO J=1,3
+ DO K=1,3
+ DO L=1,2
+ MEN(L,I,J,K) = ZERO
+ MEN(L+2,I,J,K) = ZERO
+ MEC(L,I,J,K) = ZERO
+ ENDDO
+ ENDDO
+ ENDDO
+ ENDDO
+ DO I=1,8
+ MER(I)=ZERO
+ ENDDO
+C--Perform multichannel integration
+ DO I=1,12
+ IF(CHAN(I).GT.RAND) THEN
+ GR=I
+ GOTO 25
+ ENDIF
+ RAND=RAND-CHAN(I)
+ ENDDO
+C--Calculate the hard scale and obtain parton distributions
+ 25 TAUA = MSL2(GR)/S
+ TAUB = SLWD(GR)**2/S
+ RTAB = SQRT(TAUA*TAUB)
+ XUPP = XMAX
+ IF(XMAX**2.GT.S) XUPP = SQRT(S)
+ LOWTLM = DATAN((XMIN**2/S-TAUA)/RTAB)/RTAB
+ UPPTLM = DATAN((XUPP**2/S-TAUA)/RTAB)/RTAB
+ TAU = HWRUNI(0,LOWTLM,UPPTLM)
+ TAU = RTAB*TAN(RTAB*TAU)+TAUA
+ SH = S*TAU
+ SQSH = SQRT(SH)
+ EMSCA = SQSH
+ XX(1) = EXP(HWRUNI(0,LOG(TAU),ZERO))
+ XX(2) = TAU/XX(1)
+ CALL HWSGEN(.FALSE.)
+C--EM and Weak couplings
+ EC = SQRT(4*PIFAC*HWUAEM(SH))
+ G = EC/SW
+C--Calculate the prefactor due multichannel approach
+ FAC = ZERO
+ DO GN=1,12
+ SCF(GN)=1/((SH-MSL2(GN))**2+MSWD(GN)**2)
+ FAC=FAC+CHAN(GN)*SCF(GN)
+ ENDDO
+ FAC=-(UPPTLM-LOWTLM)*GEV2NB*LOG(TAU)/
+ & (48*TAU*FAC*PIFAC*S**2*SH*SQSH)
+ ENDIF
+ HCS = ZERO
+C--First we do the neutralino production
+ IF(.NOT.NEUT) GOTO 200
+ DO 140 GN=1,6
+ I=GN
+ GR = 2*GN-1
+ I1 = 2*GN-1
+ IF(GN.GT.3) THEN
+ I=I-3
+ I1=I1-5
+ ENDIF
+ IF(CHAN(GR).LT.EPS) GOTO 140
+ DO 130 L=NEUTMN,NEUTMX
+ MN = MNT(L)
+ MNS = MN**2
+ ML = MLT(I1)
+ MLS = ML**2
+ IF((ML+MN).GT.SQSH) GOTO 130
+C--that and uhat
+ PCM = SQRT((SH-(ML+MN)**2)*(SH-(ML-MN)**2))*HALF/SQSH
+ ECM = SQRT(PCM**2+MLS)
+ TH = MLS-SQSH*(ECM-PCM*COSTH)
+ UH = MLS-SQSH*(ECM+PCM*COSTH)
+ DO J=1,3
+ DO 120 K=1,3
+ IF(ABS(LAMDA2(I,J,K)).LT.EPS) GOTO 120
+ J1 = 2*J
+ K1 = 2*K+5
+ IF(GN.GT.3) J1=J1-1
+ IF(GENEV) GOTO 110
+C--squarks in u and t channels
+ GU = 6*INT((GN-1)/3)+2*J-1
+ GT = 2*K
+C--calulate the matrix element
+ ME2=MXS(GR)**2*SCF(GR)*SH*((SH-MLS-MNS)*
+ & (A(L,GR)**2+B(L,GR)**2)-4*ML*MN*A(L,GR)*B(L,GR))
+ & +MXU(GU)**2*(MLS-UH)*(MNS-UH)*
+ & (C(1,L,GU)**2+D(1,L,GU)**2)/(UH-MSU(GU))**2
+ & +MXT(GT)**2*(MLS-TH)*(MNS-TH)*
+ & (C(2,L,GT)**2+D(2,L,GT)**2)/(TH-MST(GT))**2
+ & -TWO*MXT(GT)*MXU(GU)*C(1,L,GU)*C(2,L,GT)*(MLS*MNS-UH*TH)
+ & /(UH-MSU(GU))/(TH-MST(GT))
+ & +TWO*MXS(GR)*MXU(GU)*(SH-MSL2(GR))*SCF(GR)*C(1,L,GU)*
+ & SH*(UH*A(L,GR)+ML*MN*B(L,GR))/(UH-MSU(GU))
+ & +TWO*MXS(GR)*MXT(GT)*(SH-MSL2(GR))*SCF(GR)*C(2,L,GT)*
+ & SH*(TH*A(L,GR)+ML*MN*B(L,GR))/(TH-MST(GT))
+C--s channel mixing L/R mixing
+ IF(ABS(MXS(GR+1)).GT.EPS) THEN
+ ME2=ME2+MXS(GR+1)**2*SCF(GR+1)*SH*((SH-MLS-MNS)*
+ & (A(L,GR+1)**2+B(L,GR+1)**2)
+ & -4*ML*MN*A(L,GR+1)*B(L,GR+1))
+ & +TWO*MXS(GR)*MXS(GR+1)*SCF(GR)*SCF(GR+1)*
+ & ((SH-MSL2(GR))*(SH-MSL2(GR+1))+
+ & MSWD(GR)*MSWD(GR+1))*SH*
+ & ((SH-MLS-MNS)*(A(L,GR)*A(L,GR+1)+B(L,GR)*B(L,GR+1))
+ & -2*ML*MN*(A(L,GR)*B(L,GR+1)+A(L,GR+1)*B(L,GR)))
+ & +TWO*MXS(GR+1)*MXU(GU)*(SH-MSL2(GR+1))*SCF(GR+1)*
+ & SH*C(1,L,GU)*(UH*A(L,GR+1)+ML*MN*B(L,GR+1))
+ & /(UH-MSU(GU))
+ & +TWO*MXS(GR+1)*MXT(GT)*(SH-MSL2(GR+1))*SCF(GR+1)*
+ & SH*C(2,L,GT)*(TH*A(L,GR+1)+ML*MN*B(L,GR+1))
+ & /(TH-MST(GT))
+ IF(ABS(MXU(GU+1)).GT.EPS) ME2=ME2+TWO*MXS(GR+1)*MXU(GU+1)*
+ & (SH-MSL2(GR+1))*SCF(GR+1)*SH*C(1,L,GU+1)*
+ & (UH*A(L,GR+1)+ML*MN*B(L,GR+1))/(UH-MSU(GU+1))
+ IF(ABS(MXT(GT-1)).GT.EPS) ME2=ME2+TWO*MXS(GR+1)*MXT(GT-1)*
+ & (SH-MSL2(GR+1))*SCF(GR+1)*SH*C(2,L,GT-1)*
+ & (TH*A(L,GR+1)+ML*MN*B(L,GR+1))/(TH-MST(GT-1))
+ ENDIF
+C--u channel L/R mixing
+ IF(ABS(MXU(GU+1)).GT.EPS) THEN
+ ME2=ME2+MXU(GU+1)**2*(MLS-UH)*(MNS-UH)*(C(1,L,GU+1)**2+
+ & D(1,L,GU+1)**2)/(UH-MSU(GU+1))**2
+ & +TWO*MXU(GU)*MXU(GU+1)*(MLS-UH)*(MNS-UH)*
+ & (C(1,L,GU)*C(1,L,GU+1)+D(1,L,GU)*D(1,L,GU+1))
+ & /(UH-MSU(GU))/(UH-MSU(GU+1))
+ & -TWO*MXT(GT)*MXU(GU+1)*C(1,L,GU+1)*C(2,L,GT)*
+ & (MLS*MNS-UH*TH)/(UH-MSU(GU+1))/(TH-MST(GT))
+ & +TWO*MXS(GR)*MXU(GU+1)*(SH-MSL2(GR))*SCF(GR)*
+ & SH*C(1,L,GU+1)*(UH*A(L,GR)+ML*MN*B(L,GR))
+ & /(UH-MSU(GU+1))
+ IF(ABS(MXT(GT-1)).GT.EPS) ME2=ME2-TWO*MXT(GT-1)*MXU(GU+1)*
+ & C(1,L,GU+1)*C(2,L,GT-1)*(MLS*MNS-UH*TH)
+ & /(UH-MSU(GU+1))/(TH-MST(GT-1))
+ ENDIF
+C--t channel L/R mixing
+ IF(ABS(MXT(GT-1)).GT.EPS) THEN
+ ME2=ME2+MXT(GT-1)**2*(MLS-TH)*(MNS-TH)*(C(2,L,GT-1)**2
+ & +D(2,L,GT-1)**2)/(TH-MST(GT-1))**2
+ & +TWO*MXT(GT)*MXT(GT-1)*(MLS-TH)*(MNS-TH)*
+ & (C(2,L,GT)*C(2,L,GT-1)+D(2,L,GT)*D(2,L,GT-1))
+ & /(TH-MST(GT))/(TH-MST(GT-1))
+ & -TWO*MXT(GT-1)*MXU(GU)*C(1,L,GU)*C(2,L,GT-1)*
+ & (MLS*MNS-UH*TH)/(UH-MSU(GU))/(TH-MST(GT-1))
+ & +TWO*MXS(GR)*MXT(GT-1)*(SH-MSL2(GR))*SCF(GR)*
+ & SH*C(2,L,GT-1)*(TH*A(L,GR)+ML*MN*B(L,GR))
+ & /(TH-MST(GT-1))
+ ENDIF
+C--multiply by lamda and factors
+ MEN(L,GN,J,K) = FAC*ME2*EC**2*LAMDA2(I,J,K)**2*PCM
+ 110 I2=I1+6
+ HCS = HCS+MEN(L,GN,J,K)*DISF(J1,1)*DISF(K1,2)
+ IF(GENEV.AND.HCS.GT.RCS) CALL HWHRSS(11,J1,K1,I2,L,0,0,*500)
+ HCS = HCS+MEN(L,GN,J,K)*DISF(K1,1)*DISF(J1,2)
+ IF(GENEV.AND.HCS.GT.RCS) CALL HWHRSS(12,K1,J1,I2,L,0,0,*500)
+ HCS = HCS+MEN(L,GN,J,K)*DISF(J1+6,1)*DISF(K1-6,2)
+ IF(GENEV.AND.HCS.GT.RCS) CALL HWHRSS(11,J1,K1,I2,L,1,0,*500)
+ HCS = HCS+MEN(L,GN,J,K)*DISF(K1-6,1)*DISF(J1+6,2)
+ IF(GENEV.AND.HCS.GT.RCS) CALL HWHRSS(12,K1,J1,I2,L,1,0,*500)
+ 120 CONTINUE
+ ENDDO
+ 130 CONTINUE
+ 140 CONTINUE
+ 200 IF(.NOT.CHAR) GOTO 300
+C--Chargino production
+ DO 240 GN=1,6
+ GR=2*GN-1
+ I=GN
+ I1 = 2*GN
+ IF(GN.GT.3) THEN
+ I1=I1-7
+ I=GN-3
+ ENDIF
+ IF(CHAN(GR).LT.EPS) GOTO 240
+ DO 230 L=CHARMN,CHARMX
+ MN = MCR(L)
+ MNS = MN**2
+ ML = MLT(I1)
+ MLS = ML**2
+ SP = L+4
+ IF((ML+MN).GT.EMSCA) GOTO 230
+ PCM = SQRT((SH-(ML+MN)**2)*(SH-(ML-MN)**2))*HALF/SQSH
+ ECM = SQRT(PCM**2+MLS)
+ TH = MLS-SQSH*(ECM-PCM*COSTH)
+ UH = MLS-SQSH*(ECM+PCM*COSTH)
+ DO J=1,3
+ DO 220 K=1,3
+ IF(ABS(LAMDA2(I,J,K)).LT.EPS) GOTO 220
+ J1=2*J
+ K1=2*K+5
+ IF(GN.GT.3) J1=J1-1
+ IF(GENEV) GOTO 210
+ GU = 2*J-1
+ IF(GN.LE.3) GU=GU+6
+C--Calculate the matrix element, s and u terms
+ ME2 =MXS(GR)**2*SCF(GR)*SH*(
+ & (SH-MLS-MNS)*(A(SP,GR)**2+B(SP,GR)**2)
+ & -4*ML*MN*A(SP,GR)*B(SP,GR))
+ & +MXU(GU)**2*(MLS-UH)*(MNS-UH)*
+ & (C(1,SP,GU)**2+D(1,SP,GU)**2)/(UH-MSU(GU))**2
+ & -2*MXS(GR)*MXU(GU)*(SH-MSL2(GR))*SCF(GR)*C(1,SP,GU)*
+ & SH*(UH*A(SP,GR)+B(SP,GR)*ML*MN)/(UH-MSU(GU))
+C--s channel L/R mixing
+ IF(ABS(MXS(GR+1)).GT.EPS) THEN
+ ME2=ME2+MXS(GR+1)**2*SCF(GR+1)*SH*((SH-MLS-MNS)*
+ & (A(SP,GR+1)**2+B(SP,GR+1)**2)
+ & -4*ML*MN*A(SP,GR+1)*B(SP,GR+1))
+ & +2*MXS(GR)*MXS(GR+1)*SCF(GR)*SCF(GR+1)*
+ & ((SH-MSL2(GR))*(SH-MSL2(GR+1))+
+ & MSWD(GR)*MSWD(GR+1))*SH*
+ & ((SH-MLS-MNS)*(A(SP,GR)*A(SP,GR+1)
+ & +B(SP,GR)*B(SP,GR+1))-4*ML*MN*
+ & (A(SP,GR)*B(SP,GR+1)+B(SP,GR)*A(SP,GR+1)))
+ & -2*MXS(GR+1)*MXU(GU)*(SH-MSL2(GR+1))*SCF(GR+1)*SH*
+ & C(1,SP,GU)*(UH*A(SP,GR+1)+B(SP,GR+1)*ML*MN)
+ & /(UH-MSU(GU))
+ IF(ABS(MXU(GU+1)).GT.EPS) ME2=ME2-2*MXS(GR+1)*MXU(GU+1)*
+ & (SH-MSL2(GR+1))*SCF(GR+1)*C(1,SP,GU+1)*SH*
+ & (UH*A(SP,GR+1)+B(SP,GR+1)*ML*MN)/(UH-MSU(GU+1))
+ ENDIF
+C--u channel L/R mixing
+ IF(ABS(MXU(GU+1)).GT.EPS) ME2 = ME2+MXU(GU+1)**2*(MLS-UH)*
+ & (MNS-UH)*(C(1,SP,GU+1)**2+D(1,SP,GU+1)**2)
+ & /(UH-MSU(GU+1))**2
+ & +2*MXU(GU)*MXU(GU+1)*(MLS-UH)*(MNS-UH)*
+ & (C(1,SP,GU)*C(1,SP,GU+1)+D(1,SP,GU)*D(1,SP,GU+1))
+ & /(UH-MSU(GU))/(UH-MSU(GU+1))
+ & -2*MXS(GR)*MXU(GU+1)*(SH-MSL2(GR))*SCF(GR)*SH*
+ & C(1,SP,GU+1)*(UH*A(SP,GR)+B(SP,GR)*ML*MN)
+ & /(UH-MSU(GU+1))
+ MEC(L,GN,J,K) = FAC*ME2*G**2*LAMDA2(I,J,K)**2*PCM*HALF
+ 210 I2 = I1+6
+ P = L+4
+ HCS = HCS+MEC(L,GN,J,K)*DISF(J1,1)*DISF(K1,2)
+ IF(GN.GT.3) P = P+2
+ IF(GENEV.AND.HCS.GT.RCS) CALL HWHRSS(11,J1,K1,I2,P,0,0,*500)
+ HCS = HCS+MEC(L,GN,J,K)*DISF(K1,1)*DISF(J1,2)
+ IF(GENEV.AND.HCS.GT.RCS) CALL HWHRSS(12,K1,J1,I2,P,0,0,*500)
+ HCS = HCS+MEC(L,GN,J,K)*DISF(J1+6,1)*DISF(K1-6,2)
+ IF(GENEV.AND.HCS.GT.RCS) CALL HWHRSS(11,J1,K1,I2,P,1,0,*500)
+ HCS = HCS+MEC(L,GN,J,K)*DISF(K1-6,1)*DISF(J1+6,2)
+ IF(GENEV.AND.HCS.GT.RCS) CALL HWHRSS(12,K1,J1,I2,P,1,0,*500)
+ 220 CONTINUE
+ ENDDO
+ 230 CONTINUE
+ 240 CONTINUE
+ 300 IF(.NOT.RAD) GOTO 400
+C--Radiative decays
+ IF(GENEV) GOTO 320
+ DO 310 GN=1,3
+ I1= 2*GN+5
+ I = 2*GN-1
+C--charged slepton to sneutrino W
+ IF(SQSH.GT.(MW+MSL(I1))) THEN
+ PCM = SQRT((SH-(MW+MSL(I1))**2)*(SH-(MW-MSL(I1))**2))*HALF/SQSH
+ ECM = SQRT(PCM**2+MW2)
+ TH = MW2-SQSH*(ECM-PCM*COSTH)
+ UH = MW2-SQSH*(ECM+PCM*COSTH)
+ ME2 = MXS(I)**4*SCF(I)*SH**2*PCM**2
+ & +HALF**2/TH**2*(TWO*MW2*(UH*TH-MSL2(I1)*MW2)+TH**2*SH)
+ & +HALF*MXS(I)*SH*(SH-MSL2(I))*SCF(I)/TH*
+ & (MW2*(TWO*MSL2(I1)-TH)+(SH-MSL2(I1))*TH)
+ IF(GN.EQ.3) ME2 = ME2+MXS(I+1)**4*SCF(I+1)*SH**2*PCM**2
+ & +2*MXS(I)**2*MXS(I+1)**2*SCF(I)*SCF(I+1)*SH**2*PCM**2
+ & *((SH-MSL2(I))*(SH-MSL2(I+1))+MSWD(I)*MSWD(I+1))
+ & +HALF*MXS(I+1)*SH*(SH-MSL2(I+1))*SCF(I+1)/TH*
+ & (MW2*(TWO*MSL2(I1)-TH)+(SH-MSL2(I))*TH)
+ MER(GN) = ME2*PCM/MW2
+ ENDIF
+C--sneutrino to charged slepton W
+ IF(SQSH.GT.(MW+MSL(I))) THEN
+ PCM = SQRT((SH-(MW+MSL(I))**2)*(SH-(MW-MSL(I))**2))*HALF/SQSH
+ ECM = SQRT(PCM**2+MW2)
+ TH = MW2-SQSH*(ECM-PCM*COSTH)
+ UH = MW2-SQSH*(ECM+PCM*COSTH)
+ ME2 = MXS(I)**2*SCF(I1)*SH**2*PCM**2
+ & +HALF**2*MXS(I)**2/TH**2*
+ & (TWO*MW2*(UH*TH-MW2*MSL2(I))+TH**2*SH)
+ & +HALF*MXS(I)**2*SH*(SH-MSL2(I1))*SCF(I1)/TH*
+ & (MW2*(TWO*MSL2(I)-TH)+(SH-MSL2(I))*TH)
+ MER(GN+4) = ME2*PCM/MW2
+ ENDIF
+ 310 CONTINUE
+C--now the decay stau_2 to stau_1 Z
+ IF(SQSH.GT.(MZ+MSL(5))) THEN
+ PCM = SQRT((SH-(MZ+MSL(5))**2)*(SH-(MZ-MSL(5))**2))*HALF/SQSH
+ ECM = SQRT(PCM**2+MZ2)
+ TH = MZ2-SQSH*(ECM-PCM*COSTH)
+ UH = MZ2-SQSH*(ECM+PCM*COSTH)
+ ME2 = SH**2*PCM**2*(SCF(5)*MXS(5)**2*ZSLP(1)**2
+ & +SCF(6)*MXS(6)**2*ZSLP(2)**2+TWO*SCF(5)*SCF(6)*
+ & MXS(5)*MXS(6)*ZSLP(1)*ZSLP(2)*((SH-MSL2(5))*
+ & (SH-MSL2(6))+MSWD(5)*MSWD(6)))
+ & +MXS(5)**2*ZQRK(2)**2/TH**2*
+ & (TWO*MZ2*(UH*TH-MZ2*MSL2(5))+TH**2*SH)
+ & +MXS(5)**2*ZQRK(1)**2/UH**2*
+ & (TWO*MZ2*(UH*TH-MZ2*MSL2(5))+UH**2*SH)
+ & +MXS(5)*SH*(MXS(5)*SCF(5)*ZSLP(1)*(SH-MSL2(5))
+ & +MXS(6)*SCF(6)*ZSLP(2)*(SH-MSL2(6)))*
+ & ( ZQRK(2)/TH*(MZ2*(TWO*MSL2(5)-TH)+TH*(SH-MSL2(5)))
+ & +ZQRK(1)/UH*(MZ2*(TWO*MSL2(5)-UH)+UH*(SH-MSL2(5))))
+ & -TWO*MXS(5)**2*ZQRK(1)*ZQRK(2)/UH/TH*
+ & (TWO*MZ2*(MSL2(5)-UH)*(MSL2(5)-TH)-SH*UH*TH)
+ MER(4) = TWO*ME2*PCM/MZ2
+ ENDIF
+C--now the decay tau sneutrino to tau_2 W
+ IF(SQSH.GT.(MW+MSL(6))) THEN
+ PCM = SQRT((SH-(MW+MSL(6))**2)*(SH-(MW-MSL(6))**2))*HALF/SQSH
+ ECM = SQRT(PCM**2+MW2)
+ TH = MW2-SQSH*(ECM-PCM*COSTH)
+ UH = MW2-SQSH*(ECM+PCM*COSTH)
+ ME2 = MXS(6)**2*SCF(11)*SH**2*PCM**2
+ & +HALF**2*MXS(6)**2/TH**2*
+ & (TWO*MW2*(UH*TH-MW2*MSL2(6))+TH**2*SH)
+ & +HALF*MXS(6)**2*SH*(SH-MSL2(11))*SCF(11)/TH*
+ & (MW2*(2*MSL2(6)-TH)+(SH-MSL2(6))*TH)
+ MER(8) = ME2*PCM/MW2
+ ENDIF
+C--Multiply by the parton distributions
+ 320 DO I=1,4
+ DO J=1,3
+ DO 330 K=1,3
+ IF(I.LE.3) THEN
+ LC = LAMDA2(I,J,K)**2
+ ELSE
+ LC = LAMDA2(3,J,K)**2
+ ENDIF
+ IF(LC.LT.EPS) GOTO 330
+ FAC2 = G**2*LC*FAC
+C--radiative cross-sections
+ J1=2*J
+ K1=2*K+5
+ ME2 = FAC2*MER(I)
+ HCS = HCS+ME2*DISF(J1,1)*DISF(K1,2)
+ IF(GENEV.AND.HCS.GT.RCS) CALL HWHRSS(13,J1,K1,I,I,0,0,*500)
+ HCS = HCS+ME2*DISF(K1,1)*DISF(J1,2)
+ IF(GENEV.AND.HCS.GT.RCS) CALL HWHRSS(14,K1,J1,I,I,0,0,*500)
+ HCS = HCS+ME2*DISF(J1+6,1)*DISF(K1-6,2)
+ IF(GENEV.AND.HCS.GT.RCS) CALL HWHRSS(13,J1,K1,I,I,1,0,*500)
+ HCS = HCS+ME2*DISF(K1-6,1)*DISF(J1+6,2)
+ IF(GENEV.AND.HCS.GT.RCS) CALL HWHRSS(14,K1,J1,I,I,1,0,*500)
+ J1=2*J-1
+ K1=2*K+5
+ ME2 = FAC2*MER(I+4)
+ HCS = HCS+ME2*DISF(J1,1)*DISF(K1,2)
+ IF(GENEV.AND.HCS.GT.RCS) CALL HWHRSS(13,J1,K1,I+4,I+4,0,0,*500)
+ HCS = HCS+ME2*DISF(K1,1)*DISF(J1,2)
+ IF(GENEV.AND.HCS.GT.RCS) CALL HWHRSS(14,K1,J1,I+4,I+4,0,0,*500)
+ HCS = HCS+ME2*DISF(J1+6,1)*DISF(K1-6,2)
+ IF(GENEV.AND.HCS.GT.RCS) CALL HWHRSS(13,J1,K1,I+4,I+4,1,0,*500)
+ HCS = HCS+ME2*DISF(K1-6,1)*DISF(J1+6,2)
+ IF(GENEV.AND.HCS.GT.RCS) CALL HWHRSS(14,K1,J1,I+4,I+4,1,0,*500)
+ 330 CONTINUE
+ ENDDO
+ ENDDO
+ 400 IF(.NOT.HIGGS) GOTO 500
+ IF(GENEV) GOTO 480
+ DO I=1,3
+ DO 405 J=1,18
+ 405 MEH(I,J) = ZERO
+ ENDDO
+C--Neutral higgs charged slepton
+ DO 420 L=1,3
+ DO 410 I=1,2
+C--first two generations
+ IF(SQSH.LT.MH(L)+MSL(2*I)) GOTO 410
+ PCM = SQRT((SH-(MSL(2*I)+MH(L))**2)*
+ & (SH-(MSL(2*I)-MH(L))**2))*HALF/SQSH
+ MEH(1,3*L-3+I) = PCM*SH*SCF(2*I-1)*H(4*L+I-4)**2
+ 410 CONTINUE
+C--third generation
+ IF(SQSH.LT.MH(L)+MSL(5)) GOTO 420
+ PCM = SQRT((SH-(MSL(5)+MH(L))**2)*
+ & (SH-(MSL(5)-MH(L))**2))*HALF/SQSH
+ ECM = SQRT(PCM**2+MH(L)**2)
+ TH = MH(L)**2-SQSH*(ECM-PCM*COSTH)
+ UH = MH(L)**2-SQSH*(ECM+PCM*COSTH)
+ MEH(1,3*L) = PCM*SH*(MXS(5)**2*SCF(5)*H(4*L-1)**2
+ & +MXS(6)**2*SCF(6)*H(4*L)**2
+ & +TWO*MXS(5)*MXS(6)*SCF(5)*SCF(6)*H(4*L-1)*
+ & H(4*L)*((SH-MSL2(5))*(SH-MSL2(6))+
+ & MSWD(5)*MSWD(6)) )
+ ME2 = MXS(5)**2*PCM*(UH*TH-MSL2(5)*MH(L)**2)
+ MEH(2,3*L) =ME2*GUU(L)/TH**2
+ MEH(3,3*L) =ME2*GDD(L)/UH**2
+ 420 CONTINUE
+C--Charged higgs
+ DO 440 I=1,3
+C--charged slepton charged Higgs
+ DO 430 J=1,2
+ IF(SQSH.LT.(MH(4)+MSL(2*I-2+J))) GOTO 430
+ PCM = SQRT((SH-(MH(4)+MSL(2*I-2+J))**2)*
+ & (SH-(MH(4)-MSL(2*I-2+J))**2))*HALF/SQSH
+ ECM = SQRT(PCM**2+MH(4)**2)
+ TH = MH(4)**2-SQSH*(ECM-PCM*COSTH)
+ UH = MH(4)**2-SQSH*(ECM+PCM*COSTH)
+ MEH(1,2*I+J+7) = PCM*SH*HALF/MW2*H(2*I+J+10)**2*SCF(5+2*I)
+ MEH(2,2*I+J+7) = PCM*GDD(4)*MXS(2*I-2+J)**2*
+ & (UH*TH-MH(4)**2*MSL2(2*I-2+J))/TH**2
+ 430 CONTINUE
+C--Sneutrino Charged Higgs
+ IF(SQSH.LT.(MH(4)+MSL(2*I+5))) GOTO 440
+ PCM = SQRT((SH-(MH(4)+MSL(2*I+5))**2)*
+ & (SH-(MH(4)-MSL(2*I+5))**2))*HALF/SQSH
+ ECM = SQRT(PCM**2+MH(4)**2)
+ TH = MH(4)**2-SQSH*(ECM-PCM*COSTH)
+ UH = MH(4)**2-SQSH*(ECM+PCM*COSTH)
+ MEH(1,15+I) = PCM*SH*HALF/MW2*(
+ & MXS(2*I-1)**2*SCF(2*I-1)*H(11+2*I)**2
+ & +MXS(2*I)**2*SCF(2*I)*H(12+2*I)**2
+ & +TWO*MXS(2*I-1)*MXS(2*I)*SCF(2*I-1)*
+ & SCF(2*I)*H(11+2*I)*H(12+2*I)*
+ & ((SH-MSL2(2*I-1))*(SH-MSL2(2*I))+
+ & MSWD(2*I-1)*MSWD(2*I)))
+ MEH(2,15+I) = PCM*GUU(4)*
+ & (UH*TH-MH(4)**2*MSL2(2*I+5))/TH**2
+ 440 CONTINUE
+C--Multiply by the parton distributions
+ 480 DO I=1,3
+ DO J=1,3
+ DO 490 K=1,3
+ IF(LAMDA2(I,J,K).LT.EPS) GOTO 490
+C--Higgs cross-sections
+ J1=2*J
+ K1=2*K+5
+ FAC2 = G**2*LAMDA2(I,J,K)**2*FAC*HALF
+ DO L=1,3
+ ME2 = FAC2*(MEH(1,3*L-3+I)+RMASS(J1)**2*MEH(2,3*L-3+I)
+ & +RMASS(K1)**2*MEH(3,3*L-3+I))
+ HCS = HCS+ME2*DISF(J1,1)*DISF(K1,2)
+ IF(GENEV.AND.HCS.GT.RCS) CALL HWHRSS(15,J1,K1,I,L,0,0,*500)
+ HCS = HCS+ME2*DISF(K1,1)*DISF(J1,2)
+ IF(GENEV.AND.HCS.GT.RCS) CALL HWHRSS(16,K1,J1,I,L,0,0,*500)
+ HCS = HCS+ME2*DISF(J1+6,1)*DISF(K1-6,2)
+ IF(GENEV.AND.HCS.GT.RCS) CALL HWHRSS(15,J1,K1,I,L,1,0,*500)
+ HCS = HCS+ME2*DISF(K1-6,1)*DISF(J1+6,2)
+ IF(GENEV.AND.HCS.GT.RCS) CALL HWHRSS(16,K1,J1,I,L,1,0,*500)
+ ENDDO
+ ME2 = FAC2*(MEH(1,15+I)+RMASS(J1)**2*MEH(2,15+I))
+ HCS = HCS+ME2*DISF(J1,1)*DISF(K1,2)
+ IF(GENEV.AND.HCS.GT.RCS) CALL HWHRSS(15,J1,K1,9+I,4,0,0,*500)
+ HCS = HCS+ME2*DISF(K1,1)*DISF(J1,2)
+ IF(GENEV.AND.HCS.GT.RCS) CALL HWHRSS(16,K1,J1,9+I,4,0,0,*500)
+ HCS = HCS+ME2*DISF(J1+6,1)*DISF(K1-6,2)
+ IF(GENEV.AND.HCS.GT.RCS) CALL HWHRSS(15,J1,K1,9+I,5,1,0,*500)
+ HCS = HCS+ME2*DISF(K1-6,1)*DISF(J1+6,2)
+ IF(GENEV.AND.HCS.GT.RCS) CALL HWHRSS(16,K1,J1,9+I,5,1,0,*500)
+ J1=2*J-1
+ K1=2*K+5
+ DO L=2,3
+ ME2 = FAC2*(MEH(1,2*I+L+6)+RMASS(J1)**2*MEH(2,2*I+L+6))
+ HCS = HCS+ME2*DISF(J1,1)*DISF(K1,2)
+ IF(GENEV.AND.HCS.GT.RCS) CALL HWHRSS(15,J1,K1,2*I+L,5,0,0,*500)
+ HCS = HCS+ME2*DISF(K1,1)*DISF(J1,2)
+ IF(GENEV.AND.HCS.GT.RCS) CALL HWHRSS(16,K1,J1,2*I+L,5,0,0,*500)
+ HCS = HCS+ME2*DISF(J1+6,1)*DISF(K1-6,2)
+ IF(GENEV.AND.HCS.GT.RCS) CALL HWHRSS(15,J1,K1,2*I+L,4,1,0,*500)
+ HCS = HCS+ME2*DISF(K1-6,1)*DISF(J1+6,2)
+ IF(GENEV.AND.HCS.GT.RCS) CALL HWHRSS(16,K1,J1,2*I+L,4,1,0,*500)
+ ENDDO
+ 490 CONTINUE
+ ENDDO
+ ENDDO
+C--Setup to generate the event
+ 500 IF(GENEV) THEN
+ CALL HWETWO
+ ELSE
+ EVWGT = HCS
+ ENDIF
+ 999 END
+CDECK ID>, HWHRSP.
+*CMZ :- -20/07/99 10:56:12 by Peter Richardson
+*-- Author : Peter Richardson
+C-----------------------------------------------------------------------
+ SUBROUTINE HWHRSP
+C-----------------------------------------------------------------------
+C Subroutine for all hadron-hadron Rparity violating processes
+C-----------------------------------------------------------------------
+ INCLUDE 'HERWIG61.INC'
+ IF(IPROC.GE.4000.AND.IPROC.LT.4060) THEN
+C--SINGLE SPARTICLE VIA LQD
+ CALL HWHRLS
+ ELSEIF(IPROC.GE.4060.AND.IPROC.LT.4100) THEN
+C--RESONANT SLEPTONS TO STANDARD MODEL VIA LQD
+ CALL HWHRLL
+ ELSEIF(IPROC.GE.4100.AND.IPROC.LT.4160) THEN
+C--SINGLE SPARTICLE VIA UDD
+ CALL HWHRBS
+C--RESONANT SQUARKS TO STANDARD MODEL VIA UDD
+ ELSEIF(IPROC.EQ.4160) THEN
+ CALL HWHRBB
+ ELSE
+C--UNKNOWN PROCESS
+ CALL HWWARN('HWHRSP',500,*999)
+ ENDIF
+ 999 END
+CDECK ID>, HWHRSS.
+*CMZ :- -20/07/99 10:56:12 by Peter Richardson
+*-- Author : Peter Richardson
+C-----------------------------------------------------------------------
+ SUBROUTINE HWHRSS(TYPE,ID1,ID2,ID3,ID4,R4,IPERM,*)
+C-----------------------------------------------------------------------
+C IDENTIDY HARD R-PARITY VIOLATING PROCESS
+C-----------------------------------------------------------------------
+ INCLUDE 'HERWIG61.INC'
+ INTEGER ID3, ID4, R4, IPERM,TYPE,ID1,ID2,NEUTD1(8),SLEPID(8),
+ & NEUTD2(13),SQUID(6),SGN,HWUANT,SQUID2(12),SLPID2(12),
+ & GAGID1(6),GAGID2(8)
+ EXTERNAL HWUANT
+ DATA NEUTD1 /450,451,452,453,454,455,456,457/
+ DATA NEUTD2 /449,449,449,450,451,452,453,454,455,456,457,454,455/
+ DATA SLEPID /432,434,436,435,431,433,435,447/
+ DATA SQUID /411,423,412,412,424,411/
+ DATA SQUID2 /407,419,409,421,411,423,408,420,410,422,412,424/
+ DATA SLPID2 /443,445,435,431,443,433,445,435,447,432,434,436/
+ DATA GAGID1 /199,199,200,198,198,200/
+ DATA GAGID2 /198,198,198,200,199,199,199,199/
+ IDCMF = 15
+ IF(IPERM.EQ.0) THEN
+ ICO(1) = 2
+ ICO(2) = 1
+ ICO(3) = 3
+ ICO(4) = 4
+ ELSEIF(IPERM.EQ.1) THEN
+ ICO(1) = 2
+ ICO(2) = 1
+ ICO(3) = 4
+ ICO(4) = 3
+ ELSEIF(IPERM.EQ.2) THEN
+ ICO(1) = 3
+ ICO(2) = 4
+ ICO(3) = 1
+ ICO(4) = 2
+ ELSE
+ CALL HWWARN('HWHRSS',100,*999)
+ ENDIF
+ IF(TYPE.LE.8) THEN
+ IDN(1) = ID1+R4*6
+ IDN(2) = ID2+R4*6
+ ELSE
+ SGN = 1
+ IF(MOD(TYPE,2).EQ.0) SGN = -1
+ IDN(1) = ID1+R4*6*SGN
+ IDN(2) = ID2-R4*6*SGN
+ ENDIF
+ IF(TYPE.LE.2) THEN
+ IDN(3) = ID3+6*R4
+ IDN(4) = ID4+6*R4
+ ELSEIF(TYPE.GE.3.AND.TYPE.LE.4) THEN
+ IDN(3) = ID3-R4*6
+ IDN(4) = NEUTD2(ID4)
+ ELSEIF(TYPE.GE.5.AND.TYPE.LE.6) THEN
+ IDN(3) = GAGID1(ID3)
+ IDN(4) = SQUID(ID4)-R4*6
+ IF(R4.EQ.1) IDN(3) = HWUANT(IDN(3))
+ ELSEIF(TYPE.GE.7.AND.TYPE.LE.8) THEN
+ IDN(3) =202+ID3
+ IDN(4) = SQUID2(ID4)-R4*6
+ ELSEIF(TYPE.GE.9.AND.TYPE.LE.10) THEN
+ IDN(3) = ID3+6*R4
+ IDN(4) = ID4-6*R4
+ IF(IPERM.EQ.2.AND.TYPE.EQ.10) THEN
+ SGN=IDN(3)
+ IDN(3) = IDN(4)
+ IDN(4) = SGN
+ ENDIF
+ ELSEIF(TYPE.GE.11.AND.TYPE.LE.12) THEN
+ IDN(3) = 120+ID3-R4*6
+ IDN(4) = NEUTD1(ID4)
+ IF(R4.EQ.1) IDN(4) = HWUANT(IDN(4))
+ ELSEIF(TYPE.GE.13.AND.TYPE.LE.14) THEN
+ IDN(3) = SLEPID(ID3)-R4*6
+ IDN(4) = GAGID2(ID4)
+ IF(R4.NE.0) IDN(4) = HWUANT(IDN(4))
+ ELSEIF(TYPE.GE.15.AND.TYPE.LE.16) THEN
+ IDN(3) = SLPID2(ID3)-R4*6
+ IDN(4) = 202+ID4
+ ENDIF
+ IF(MOD(TYPE,2).EQ.0.AND.TYPE.NE.8) COSTH=-COSTH
+ RETURN 1
+ 999 END
+CDECK ID>, HWHSCT.
+*CMZ :- -30/05/94 18.42.43 by Mike Seymour
+*-- Author : Mike Seymour
+C-----------------------------------------------------------------------
+ SUBROUTINE HWHSCT(REPORT)
+C-----------------------------------------------------------------------
+C RELABEL THE EVENT RECORD FOR EXTRA HARD SCATTERING,
+C DO THE SCATTERING, PARTON SHOWER IT, AND CLEAN UP THE EVENT RECORD
+C REPORT RETURNS THE OUTCOME:
+C 0 = SUCCESSFUL
+C 1 = FAILED DUE TO ERROR IN HARD SCATTERING GENERATION
+C 2 = FAILED DUE TO ENERGY CONSERVATION IN HARD SCATTERING
+C 3 = FAILED DUE TO ERROR IN PARTON EVOLUTION
+C 4 = FAILED DUE TO ENERGY CONSERVATION IN PARTON EVOLUTION
+C 5 = COMPLETELY FAILED (IERROR IS ALSO NON-ZERO TO CANCEL EVENT)
+C-----------------------------------------------------------------------
+ INCLUDE 'HERWIG61.INC'
+ DOUBLE PRECISION HWR,TMPWGT,PBOOST(5),RBOOST(3,3)
+ INTEGER IHEP,IBM,ITG,IBMN,ITGN,IBMT,ITGT,I,REPORT
+ LOGICAL COL
+ EXTERNAL HWR
+ 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*HWR()) THEN
+ IERROR=0
+ GOTO 10
+ ENDIF
+ GENEV=.TRUE.
+ CALL HWHQCD
+ EVWGT=TMPWGT
+C---IF MOMENTUM CANNOT BE CONSERVED, STOP GENERATING HARD SCATTERS
+ IF ( PHEP(4,IBMN+2) .GT. PHEP(4,IBMN).OR.
+ $ PHEP(4,ITGN+2) .GT. PHEP(4,ITGN).OR.
+ $ PHEP(3,IBMN+2) .GT. PHEP(3,IBMN).OR.
+ $ -PHEP(3,ITGN+2) .GT.-PHEP(3,ITGN).OR.IERROR.NE.0) THEN
+ IF (IERROR.GT.0) THEN
+ WRITE (6,'(A/A)')
+ $ ' THIS ERROR OCCURED DURING A SECONDARY SCATTER AND WAS',
+ $ ' CAUGHT BY HWHSCT, SO EVENT IS NOT KILLED AFTER ALL'
+ REPORT=1
+ ELSE
+ REPORT=2
+ ENDIF
+ NHEP=IBMN-1
+ IERROR=0
+ RETURN
+ ENDIF
+C---RELABEL OUTGOING REMNANTS AS INCOMING HADRONS
+ JDAHEP(1,1)=IBMN
+ JDAHEP(1,2)=ITGN
+C---EVOLVE THEM
+ ISLENT=-1
+ CALL HWBGEN
+ ISLENT=1
+C---PUT THE LABELS BACK
+ JDAHEP(1,1)=IBMT
+ JDAHEP(1,2)=ITGT
+C---IF THERE WERE ANY PROBLEMS, STOP GENERATING HARD SCATTERS
+ IF (IERROR.NE.0) THEN
+ IF (IERROR.GT.0) THEN
+ WRITE (6,'(A/A)')
+ $ ' THIS ERROR OCCURED DURING A SECONDARY SCATTER AND WAS',
+ $ ' CAUGHT BY HWHSCT, SO EVENT IS NOT KILLED AFTER ALL'
+ REPORT=3
+ ELSE
+ REPORT=4
+ ENDIF
+ NHEP=IBMN-1
+ IERROR=0
+ RETURN
+ ENDIF
+C---UNDO THE LORENTZ BOOST
+ DO 200 IHEP=IBMN,NHEP
+ CALL HWUROB(RBOOST,PHEP(1,IHEP),PHEP(1,IHEP))
+ CALL HWULOB(PBOOST,PHEP(1,IHEP),PHEP(1,IHEP))
+ 200 CONTINUE
+C---FIND THE NEW BEAM AND TARGET REMNANTS
+ ISTHEP(IBM)=3
+ ISTHEP(ITG)=3
+ CALL HWHREM(IBMN,ITGN)
+ IF (IERROR.NE.0) RETURN
+C---CONNECT UP THE COLOUR/FLAVOUR LINES OF THE TWO SCATTERS
+ IDHW(IBMN)=IDHW(IBM)
+ IDHEP(IBMN)=IDHEP(IBM)
+ IF (COL(IDHW(IBM))) THEN
+ JMOHEP(2,JDAHEP(2,IBMN))=JMOHEP(2,IBM)
+ JDAHEP(2,JMOHEP(2,IBM))=JDAHEP(2,IBMN)
+ JDAHEP(2,IBMN)=JDAHEP(2,IBM)
+ JMOHEP(2,JDAHEP(2,IBM))=IBMN
+ ELSE
+ JDAHEP(2,JMOHEP(2,IBMN))=JDAHEP(2,IBM)
+ JMOHEP(2,JDAHEP(2,IBM))=JMOHEP(2,IBMN)
+ JMOHEP(2,IBMN)=JMOHEP(2,IBM)
+ JDAHEP(2,JMOHEP(2,IBM))=IBMN
+ ENDIF
+ JMOHEP(2,IBM)=0
+ JDAHEP(1,IBM)=IBMN
+ JDAHEP(2,IBM)=0
+ IDHW(ITGN)=IDHW(ITG)
+ IDHEP(ITGN)=IDHEP(ITG)
+ IF (COL(IDHW(ITG))) THEN
+ JMOHEP(2,JDAHEP(2,ITGN))=JMOHEP(2,ITG)
+ JDAHEP(2,JMOHEP(2,ITG))=JDAHEP(2,ITGN)
+ JDAHEP(2,ITGN)=JDAHEP(2,ITG)
+ JMOHEP(2,JDAHEP(2,ITG))=ITGN
+ ELSE
+ JDAHEP(2,JMOHEP(2,ITGN))=JDAHEP(2,ITG)
+ JMOHEP(2,JDAHEP(2,ITG))=JMOHEP(2,ITGN)
+ JMOHEP(2,ITGN)=JMOHEP(2,ITG)
+ JDAHEP(2,JMOHEP(2,ITG))=ITGN
+ ENDIF
+ JMOHEP(2,ITG)=0
+ JDAHEP(1,ITG)=ITGN
+ JDAHEP(2,ITG)=0
+C---LOOK FOR COLOUR SINGLET GLUONS (A RARE BUT ANNOYING SPECIAL CASE)
+ DO 20 IHEP=1,NHEP
+ IF (IDHW(IHEP).EQ.13.AND.JMOHEP(2,IHEP).EQ.IHEP)
+ $ CALL HWWARN('HWHSCT',120,*999)
+ 20 CONTINUE
+ REPORT=0
+ 999 END
+CDECK ID>, HWHSNG.
+*CMZ :- -20/09/95 14.59.15 by Mike Seymour
+*-- Author : Mike Seymour
+C-----------------------------------------------------------------------
+ SUBROUTINE HWHSNG
+C PARTON-PARTON SCATTERING VIA COLOUR SINGLET
+C MEAN EVWGT = SIGMA IN NB
+C TREATS ALL PARTONS ON EQUAL FOOTING WITH HWHSNM(ID1,ID2,S,T)
+C PROVIDING THE MATRIX ELEMENT SQUARED FOR PARTON TYPES ID1 AND ID2
+C-----------------------------------------------------------------------
+ INCLUDE 'HERWIG61.INC'
+ INTEGER ID1,ID2
+ DOUBLE PRECISION HWR,HWRUNI,HWHSNM,EPS,RCS,ET,EJ,KK,KK2,
+ & YJ1INF,YJ1SUP,Z1,YJ2INF,YJ2SUP,Z2,FACT,S,T,U,HCS
+ SAVE HCS,FACT,S,T
+ PARAMETER (EPS=1.D-9)
+ IF (GENEV) THEN
+ RCS=HCS*HWR()
+ ELSE
+ EVWGT=0.
+ CALL HWRPOW(ET,EJ)
+ KK=ET/PHEP(5,3)
+ KK2=KK**2
+ IF (KK.GE.ONE) RETURN
+ YJ1INF=MAX( YJMIN , LOG((1.-SQRT(1.-KK2))/KK) )
+ YJ1SUP=MIN( YJMAX , LOG((1.+SQRT(1.-KK2))/KK) )
+ IF (YJ1INF.GE.YJ1SUP) RETURN
+ Z1=EXP(HWRUNI(1,YJ1INF,YJ1SUP))
+ YJ2INF=MAX( YJMIN , -LOG(2./KK-1./Z1) )
+ YJ2SUP=MIN( YJMAX , LOG(2./KK-Z1) )
+ IF (YJ2INF.GE.YJ2SUP) RETURN
+ Z2=EXP(HWRUNI(2,YJ2INF,YJ2SUP))
+ XX(1)=0.5*(Z1+Z2)*KK
+ IF (XX(1).GE.ONE) RETURN
+ XX(2)=XX(1)/(Z1*Z2)
+ IF (XX(2).GE.ONE) RETURN
+ COSTH=(Z1-Z2)/(Z1+Z2)
+ S=XX(1)*XX(2)*PHEP(5,3)**2
+ T=-0.5*S*(1.-COSTH)
+ U=-S-T
+C---SET EMSCA TO HARD PROCESS SCALE (APPROX ET-JET)
+ EMSCA=SQRT(2.*S*T*U/(S*S+T*T+U*U))
+ FACT=GEV2NB*0.5*ET*EJ*(YJ1SUP-YJ1INF)*(YJ2SUP-YJ2INF)
+ $ /(16*PIFAC*S**2)
+ CALL HWSGEN(.FALSE.)
+ ENDIF
+C
+ HCS=0.
+ DO 20 ID1=1,13
+ IF (DISF(ID1,1).LT.EPS) GOTO 20
+ DO 10 ID2=1,13
+ IF (DISF(ID2,1).LT.EPS) GOTO 10
+ HCS=HCS+FACT*DISF(ID1,1)*DISF(ID2,2)*HWHSNM(ID1,ID2,S,T)
+ IF (GENEV.AND.HCS.GT.RCS) CALL HWHQCP(ID1,ID2,3412,90,*30)
+ 10 CONTINUE
+ 20 CONTINUE
+ EVWGT=HCS
+ RETURN
+C---GENERATE EVENT
+ 30 IDN(1)=ID1
+ IDN(2)=ID2
+ IDCMF=15
+ CALL HWETWO
+ 999 END
+CDECK ID>, HWHSNM.
+*CMZ :- -20/09/95 15.28.53 by Mike Seymour
+*-- Author : Mike Seymour
+C-----------------------------------------------------------------------
+ FUNCTION HWHSNM(ID1,ID2,S,T)
+C MATRIX ELEMENT SQUARED FOR COLOUR-SINGLET PARTON-PARTON SCATTERING
+C INCLUDES SPIN AND COLOUR AVERAGES AND SUMS.
+C FOR PHOTON EXCHANGE, INTERFERENCE WITH U-CHANNEL CONTRIBUTION IS
+C INCLUDED FOR IDENTICAL QUARKS AND LIKEWISE S-CHANNEL CONTRIBUTION
+C FOR IDENTICAL QUARK-ANTIQUARK PAIRS.
+C-----------------------------------------------------------------------
+ INCLUDE 'HERWIG61.INC'
+ DOUBLE PRECISION HWHSNM,HWUAEM,HWUALF,S,T,ASQ,AINU,AINS,Y,SOLD,
+ $ TOLD,QQ(13,13),ZETA3
+ INTEGER ID1,ID2
+ LOGICAL PHOTON
+C---ZETA3=RIEMANN ZETA FUNCTION(3)
+ PARAMETER (ZETA3=1.202056903159594D0)
+C---PHOTON=.TRUE. FOR PHOTON EXCHANGE, .FALSE. FOR MUELLER-TANG
+ PHOTON=MOD(IPROC,100).GE.50
+ DATA ASQ,AINU,AINS,SOLD,TOLD,QQ/5*0,169*-1/
+C---QQ CACHES THE KINEMATIC-INDEPENDENT FACTORS, TO MAKE IT RUN FASTER
+C (BEARING IN MIND THAT THIS ROUTINE IS CALLED 169 TIMES PER EVENT)
+ IF (QQ(ID1,ID2).LT.ZERO) THEN
+ IF (PHOTON) THEN
+ IF (ID1.EQ.13.OR.ID2.EQ.13) THEN
+ QQ(ID1,ID2)=0
+ ELSE
+ QQ(ID1,ID2)=(QFCH(MOD(ID1-1,6)+1)*QFCH(MOD(ID2-1,6)+1))**2
+ $ *(4*PIFAC)**2
+ ENDIF
+ ELSE
+ IF (ID1.EQ.13.AND.ID2.EQ.13) THEN
+ QQ(ID1,ID2)=CAFAC**4
+ ELSEIF (ID1.EQ.13.OR.ID2.EQ.13) THEN
+ QQ(ID1,ID2)=(CAFAC*CFFAC)**2
+ ELSE
+ QQ(ID1,ID2)=CFFAC**4
+ ENDIF
+ QQ(ID1,ID2)=QQ(ID1,ID2)*
+ $ PIFAC**3/(4*(3.5*ASFIXD*CAFAC*ZETA3)**3)
+ $ *(16*PIFAC)
+ ENDIF
+ ENDIF
+C---THE KINEMATIC-DEPENDENT PART IS ALSO CACHED
+ IF (S.NE.SOLD.OR.T.NE.TOLD) THEN
+ IF (PHOTON) THEN
+ AINS=HWUAEM(T)**2
+ ASQ=2*(S**2+(S+T)**2)/T**2*AINS
+ AINU=-4*S/T*AINS/NCOLO
+ AINS=4*AINS/NCOLO-AINU
+ ELSE
+ Y=LOG(S/(-T))+ONE
+ ASQ=HWUALF(1,EMSCA)**4*(S/T)**2*EXP(2*OMEGA0*Y)/Y**3
+ AINU=0
+ AINS=0
+ ENDIF
+ ENDIF
+C---THE FINAL ANSWER IS JUST THEIR PRODUCT
+ IF (ID1.EQ.ID2) THEN
+ HWHSNM=QQ(ID1,ID2)*(ASQ+AINU)
+ ELSEIF (ABS(ID1-ID2).EQ.6) THEN
+ HWHSNM=QQ(ID1,ID2)*(ASQ+AINS)
+ ELSE
+ HWHSNM=QQ(ID1,ID2)*ASQ
+ ENDIF
+ END
+CDECK ID>, HWHSS1.
+*CMZ :- -18/05/99 20.33.45 by Kosuke Odagiri
+*-- Author : Kosuke Odagiri
+C-----------------------------------------------------------------------
+ FUNCTION HWHSS1(S, T, U, M3, M4, SGN, CLL, CLR, CRL, CRR)
+C-----------------------------------------------------------------------
+C QQ(BAR) -> GAUGINOS
+C-----------------------------------------------------------------------
+ IMPLICIT NONE
+ DOUBLE PRECISION HWHSS1, S, T, U, M3, M4, SGN
+ DOUBLE COMPLEX CLL, CLR, CRL, CRR
+ HWHSS1 = DBLE(
+ & (CONJG(CLL)*CLL+CONJG(CRR)*CRR)*(U-M3*M3)*(U-M4*M4)+
+ & (CONJG(CLR)*CLR+CONJG(CRL)*CRL)*(T-M3*M3)*(T-M4*M4)+
+ & (CONJG(CLL)*CLR+CONJG(CRL)*CRR)*2.*SGN*M3*M4*S )
+ RETURN
+ END
+CDECK ID>, HWHSSG.
+*CMZ :- -18/05/99 20.33.45 by Kosuke Odagiri
+*-- Author : Kosuke Odagiri
+C-----------------------------------------------------------------------
+ SUBROUTINE HWHSSG
+C-----------------------------------------------------------------------
+C SUSY 2 PARTON -> 2 GAUGINOS PROCESSES (1 - 3)
+C -> GAUGINO + SPARTON PROCESSES (4 - 7)
+C-----------------------------------------------------------------------
+ INCLUDE 'HERWIG61.INC'
+ DOUBLE PRECISION HWR, HWUALF, HWUAEM, EPS, HCS, RCS, DIST,
+ & ML(6), ML2(6), MR(6), MR2(6), MCH(2), MCH2(2), MNU(4), MNU2(4),
+ & MSQK, MG, MG2, SM, DM, DAB, QPE, SGN, PF, SQPE, EMSC2,
+ & FAC0, FACA, FACB, FACC, S, T, T3, U, U4, SN2TH
+ DOUBLE PRECISION M1(2,2,6), M2(4,4,6), M3(2,4,6,6),
+ & M4(4,6), M5(2,6,6), M6L(4,6), M6R(4,6), M7(2,2,6,6),
+ & XA(4), XB(4), XC(4), XD(4), MZ, MW, XW, SQXW, S2W, S22W
+ INTEGER I, IQ, IQ1, IQ2, IQ3, IQ4, IG1, IG2, IG3, IG4,
+ & ID1, ID2, IGL, SSL, SSR, GLU, SSNU, SSCH, INU, ICH, IWD(6), IPB
+ DOUBLE PRECISION DQD(6), DQU(6), HWHSS1
+ EXTERNAL HWR, HWUALF, HWUAEM, HWHSS1
+ SAVE HCS, M1, M2, M3, M4, M5, M6L, M6R, M7
+ PARAMETER (EPS = 1.D-9, IGL = 49, SSL = 400, SSR = 412, GLU = 449)
+ PARAMETER (SSNU = 449, SSCH = 453, INU = 49, ICH = 53)
+ DOUBLE COMPLEX Z, Z0, C1, C2, C3, GZ, GW, CLL, CLR, CRL, CRR
+ PARAMETER (Z = (0.D0,1.D0), Z0 = (0.D0,0.D0))
+ EQUIVALENCE (MZ, RMASS(200)), (MW, RMASS(198)), (MG, RMASS(GLU))
+ EQUIVALENCE (XA(1), ZMIXSS(1,1)), (XA(2), ZMIXSS(2,1))
+ EQUIVALENCE (XA(3), ZMIXSS(3,1)), (XA(4), ZMIXSS(4,1))
+ EQUIVALENCE (XB(1), ZMIXSS(1,2)), (XB(2), ZMIXSS(2,2))
+ EQUIVALENCE (XB(3), ZMIXSS(3,2)), (XB(4), ZMIXSS(4,2))
+ EQUIVALENCE (XC(1), ZMIXSS(1,3)), (XC(2), ZMIXSS(2,3))
+ EQUIVALENCE (XC(3), ZMIXSS(3,3)), (XC(4), ZMIXSS(4,3))
+ EQUIVALENCE (XD(1), ZMIXSS(1,4)), (XD(2), ZMIXSS(2,4))
+ EQUIVALENCE (XD(3), ZMIXSS(3,4)), (XD(4), ZMIXSS(4,4))
+ DATA IWD/2,1,4,3,6,5/
+ DATA DQD/ONE,ZERO,ONE,ZERO,ONE,ZERO/
+ DATA DQU/ZERO,ONE,ZERO,ONE,ZERO,ONE/
+C
+ CALL HWSGEN(.FALSE.)
+ IF (GENEV) THEN
+ RCS = HCS*HWR()
+ ELSE
+ SN2TH = 0.25D0 - 0.25D0*COSTH**2
+ S=XX(1)*XX(2)*PHEP(5,3)**2
+ EMSC2 = EMSCA**2
+ FAC0 = FACTSS*HWUAEM(EMSC2)
+c prefactor for pair production, includes 1/Nc colour factor
+ FACA = FAC0*HWUAEM(EMSC2) / CAFAC
+c prefactor for qq -> gaugino + gluino, includes CF/Nc colour factor
+ FACB = FAC0*HWUALF(1,EMSCA) * CFFAC / CAFAC
+c prefactor for qg -> gaugino + squark, includes 1/2Nc colour factor
+ FACC = FACB / CFFAC / TWO
+ MG2 = MG**2
+ GZ = S-MZ**2+Z*S/MZ*GAMZ
+ GW = S-MW**2+Z*S/MW*GAMW
+ DO IQ = 1,6
+ IQ1 = SSL + IQ
+ IQ2 = SSR + IQ
+ ML(IQ) = RMASS(IQ1)
+ ML2(IQ) = ML(IQ)**2
+ MR(IQ) = RMASS(IQ2)
+ MR2(IQ) = MR(IQ)**2
+ END DO
+ XW = TWO * SWEIN
+ SQXW = SQRT(XW)
+ S22W = XW * (TWO - XW)
+ S2W = SQRT(S22W)
+ DO IG1 = 1,4
+ MNU(IG1) = RMASS(IG1+SSNU)
+ MNU2(IG1) = MNU(IG1)**2
+ END DO
+ DO IG1 = 1,2
+ MCH(IG1) = RMASS(IG1+SSCH)
+ MCH2(IG1) = MCH(IG1)**2
+ END DO
+c _ ~+ ~-
+c (1) q q -> X X
+c a b
+ DO IG1 = 1,2
+ DO IG2 = 1,2
+ SM = MCH(IG1) + MCH(IG2)
+ QPE = S - SM**2
+ IF (QPE.GE.ZERO) THEN
+ DM = MCH(IG1) - MCH(IG2)
+ SQPE = SQRT(QPE*(S-DM**2))
+ PF = SQPE/S
+ T = (SQPE*COSTH - S + MCH2(IG1) + MCH2(IG2)) / TWO
+ U = - T - S + MCH2(IG1) + MCH2(IG2)
+ DAB = ABS(FLOAT(IG1+IG2-3))
+ C1 = (-WMXVSS(IG1,2)*WMXVSS(IG2,2)+DAB*S22W/XW)/S2W/GZ
+ C2 = (-WMXUSS(IG1,2)*WMXUSS(IG2,2)+DAB*S22W/XW)/S2W/GZ
+ SGN = WSGNSS(IG1)*WSGNSS(IG2)
+ DO IQ = 1,6
+ C3 = -DAB*QFCH(IQ)/S
+ CLL = C3 - LFCH(IQ)*C1 +
+ & DQD(IQ)*WMXUSS(IG1,1)*WMXUSS(IG2,1)/(U-ML2(IWD(IQ)))
+ CLR = C3 - LFCH(IQ)*C2 -
+ & DQU(IQ)*WMXVSS(IG1,1)*WMXVSS(IG2,1)/(T-ML2(IWD(IQ)))
+ CRL = C3 - RFCH(IQ)*C1
+ CRR = C3 - RFCH(IQ)*C2
+ M1(IG1,IG2,IQ)=FACA*PF*
+ & HWHSS1(S,T,U,MCH(IG1),MCH(IG2),SGN,CLL,CLR,CRL,CRR)
+ END DO
+ ELSE
+ DO IQ = 1,6
+ M1(IG1,IG2,IQ) = ZERO
+ END DO
+ END IF
+ END DO
+ END DO
+c _ ~o ~o
+c (2) q q -> X X
+c i j
+ DO IG1 = 1,4
+ DO IG2 = 1,4
+ SM = MNU(IG1) + MNU(IG2)
+ QPE = S - SM**2
+ IF (QPE.GE.ZERO) THEN
+ DM = MNU(IG1) - MNU(IG2)
+ SQPE = SQRT(QPE*(S-DM**2))
+ PF = SQPE/S
+ T = (SQPE*COSTH - S + MNU2(IG1) + MNU2(IG2)) / TWO
+ U = - T - S + MNU2(IG1) + MNU2(IG2)
+ C1 = (XD(IG1)*XD(IG2)-XC(IG1)*XC(IG2))/S2W/GZ
+ C2 = - C1
+ SGN = ZSGNSS(IG1)*ZSGNSS(IG2)
+ DO IQ = 1,6
+ CLL =LFCH(IQ)*C1+SLFCH(IQ,IG1)*SLFCH(IQ,IG2)/(U-ML2(IQ))
+ CLR =LFCH(IQ)*C2-SLFCH(IQ,IG1)*SLFCH(IQ,IG2)/(T-ML2(IQ))
+ CRL =RFCH(IQ)*C1-SRFCH(IQ,IG1)*SRFCH(IQ,IG2)/(T-MR2(IQ))
+ CRR =RFCH(IQ)*C2+SRFCH(IQ,IG1)*SRFCH(IQ,IG2)/(U-MR2(IQ))
+ M2(IG1,IG2,IQ) = FACA*PF*HALF*
+ & HWHSS1(S,T,U,MNU(IG1),MNU(IG2),SGN,CLL,CLR,CRL,CRR)
+ END DO
+ ELSE
+ DO IQ = 1,6
+ M2(IG1,IG2,IQ) = ZERO
+ END DO
+ END IF
+ END DO
+ END DO
+c _ ~+ ~o
+c (3) U D -> X X
+c a i
+ DO IG1 = 1,2
+ DO IG2 = 1,4
+ SM = MCH(IG1) + MNU(IG2)
+ QPE = S - SM**2
+ IF (QPE.GE.ZERO) THEN
+ DM = MCH(IG1) - MNU(IG2)
+ SQPE = SQRT(QPE*(S-DM**2))
+ PF = SQPE/S
+ T = (SQPE*COSTH - S + MCH2(IG1) + MNU2(IG2)) / TWO
+ U = - T - S + MCH2(IG1) + MNU2(IG2)
+ C1 = XA(IG2)+S2W/XW*XB(IG2)
+c note the new s-channel signs below.
+ C2 = ( XC(IG2)*WMXUSS(IG1,2)/SQXW+C1*WMXUSS(IG1,1))/GW
+ C3 = (-XD(IG2)*WMXVSS(IG1,2)/SQXW+C1*WMXVSS(IG1,1))/GW
+ SGN = WSGNSS(IG1)*ZSGNSS(IG2)
+ DO IQ1 = 1,3
+ IQ3 = IQ1*2
+ DO IQ2 = 1,3
+ IQ4 = IQ2*2-1
+ CLL = C2+WMXVSS(IG1,1)*SLFCH(IQ3,IG2)/(U-ML2(IQ3))
+ CLR = C3-WMXUSS(IG1,1)*SLFCH(IQ4,IG2)/(T-ML2(IQ4))
+ M3(IG1,IG2,IQ1,IQ2) = FACA*PF*VCKM(IQ1,IQ2)/XW*
+ & HWHSS1(S,T,U,MCH(IG1),MNU(IG2),SGN,CLL,CLR,Z0,Z0)
+ END DO
+ END DO
+ ELSE
+ DO IQ1 = 1,3
+ DO IQ2 = 1,3
+ M3(IG1,IG2,IQ1,IQ2) = ZERO
+ END DO
+ END DO
+ END IF
+ END DO
+ END DO
+c _ ~o ~
+c (4) q q -> X g
+c i
+ DO IG1 = 1,4
+ SM = MNU(IG1) + MG
+ QPE = S - SM**2
+ IF (QPE.GE.ZERO) THEN
+ DM = MNU(IG1) - MG
+ SQPE = SQRT(QPE*(S-DM**2))
+ PF = SQPE/S
+ T = (SQPE*COSTH - S + MG2 + MNU2(IG1)) / TWO
+ U = - T - S + MG2 + MNU2(IG1)
+ DO IQ = 1,6
+ CLL = SLFCH(IQ,IG1)/(U-ML2(IQ))
+ CLR = - SLFCH(IQ,IG1)/(T-ML2(IQ))
+ CRL = - SRFCH(IQ,IG1)/(T-MR2(IQ))
+ CRR = SRFCH(IQ,IG1)/(U-MR2(IQ))
+ M4(IG1,IQ) = FACB*PF*
+ & HWHSS1(S,T,U,MNU(IG1),MG,ZSGNSS(IG1),CLL,CLR,CRL,CRR)
+ END DO
+ ELSE
+ DO IQ = 1,6
+ M4(IG1,IQ) = ZERO
+ END DO
+ END IF
+ END DO
+c _ ~+ ~
+c (5) U D -> X g
+c a
+ DO IG1 = 1,2
+ SM = MCH(IG1) + MG
+ QPE = S - SM**2
+ IF (QPE.GE.ZERO) THEN
+ DM = MCH(IG1) - MG
+ SQPE = SQRT(QPE*(S-DM**2))
+ PF = SQPE/S
+ T = (SQPE*COSTH - S + MCH2(IG1) + MG2) / TWO
+ U = - T - S + MCH2(IG1) + MG2
+ DO IQ1 = 1,3
+ IQ3 = IQ1*2
+ DO IQ2 = 1,3
+ IQ4 = IQ2*2-1
+ CLL = WMXVSS(IG1,1)/(U-ML2(IQ3))
+ CLR = - WMXUSS(IG1,1)/(T-ML2(IQ4))
+ M5(IG1,IQ1,IQ2) = FACB*PF*VCKM(IQ1,IQ2)/XW*
+ & HWHSS1(S,T,U,MCH(IG1),MG,WSGNSS(IG1),CLL,CLR,Z0,Z0)
+ END DO
+ END DO
+ ELSE
+ DO IQ1 = 1,3
+ DO IQ2 = 1,3
+ M5(IG1,IQ1,IQ2) = ZERO
+ END DO
+ END DO
+ END IF
+ END DO
+c ~o ~
+c (6) g q -> X q
+c i LR
+ DO IG1 = 1,4
+ DO IQ = 1,6
+c left squarks
+ SM = MNU(IG1)+ML(IQ)
+ QPE = S - SM**2
+ IF (QPE.GE.ZERO) THEN
+ DM = MNU(IG1)-ML(IQ)
+ SQPE = SQRT(QPE*(S-DM**2))
+ PF = SQPE/S
+ T3 = (SQPE*COSTH - S - SM*DM) / TWO
+ U4 = - T3 - S
+ M6L(IG1,IQ) = FACC*PF * (
+ & QMIXSS(IQ,1,1)*SLFCH(IQ,IG1)+QMIXSS(IQ,2,1)*SRFCH(IQ,IG1)
+ & )**2 * T3/S/U4*(-U4+TWO*SM*DM/T3/U4*SQPE*SQPE*SN2TH)
+ ELSE
+ M6L(IG1,IQ) = ZERO
+ END IF
+c right squarks
+ SM = MNU(IG1)+MR(IQ)
+ QPE = S - SM**2
+ IF (QPE.GE.ZERO) THEN
+ DM = MNU(IG1)-MR(IQ)
+ SQPE = SQRT(QPE*(S-DM**2))
+ PF = SQPE/S
+ T3 = (SQPE*COSTH - S - SM*DM) / TWO
+ U4 = - T3 - S
+ M6R(IG1,IQ) = FACC*PF * (
+ & QMIXSS(IQ,1,2)*SLFCH(IQ,IG1)+QMIXSS(IQ,2,2)*SRFCH(IQ,IG1)
+ & )**2 * T3/S/U4*(-U4+TWO*SM*DM/T3/U4*SQPE*SQPE*SN2TH)
+ ELSE
+ M6R(IG1,IQ) = ZERO
+ END IF
+ END DO
+ END DO
+c ~+-~
+c (7) g q -> X q'
+c a L
+ DO IG1 = 1,2
+ DO IQ1 = 1,3
+ IQ3 = IQ1*2
+ DO IQ2 = 1,3
+ IQ4 = IQ2*2-1
+ DO I = 1,2
+c U initiated processes
+ IF (I.EQ.1) THEN
+ MSQK = ML(IQ4)
+ ELSE
+ MSQK = MR(IQ4)
+ END IF
+ SM = MCH(IG1) + MSQK
+ QPE = S - SM**2
+ IF (((I.EQ.1).OR.(IQ2.EQ.3)).AND.(QPE.GE.ZERO)) THEN
+ DM = MCH(IG1) - MSQK
+ SQPE = SQRT(QPE*(S-DM**2))
+ PF = SQPE/S
+ T3 = (SQPE*COSTH - S - SM*DM) / TWO
+ U4 = - T3 - S
+ M7(I,IG1,IQ3,IQ4)=FACC*PF*WMXUSS(IG1,1)**2*VCKM(IQ1,IQ2)
+ & /XW*T3/S/U4*(-U4+TWO*SM*DM/T3/U4*SQPE*SQPE*SN2TH)*
+ & QMIXSS(IQ4,1,I)**2
+ ELSE
+ M7(I,IG1,IQ3,IQ4) = ZERO
+ END IF
+c D initiated processes
+ IF (I.EQ.1) THEN
+ MSQK = ML(IQ3)
+ ELSE
+ MSQK = MR(IQ3)
+ END IF
+ SM = MCH(IG1) + MSQK
+ QPE = S - SM**2
+ IF (((I.EQ.1).OR.(IQ1.EQ.3)).AND.(QPE.GE.ZERO)) THEN
+ DM = MCH(IG1) - MSQK
+ SQPE = SQRT(QPE*(S-DM**2))
+ PF = SQPE/S
+ T3 = (SQPE*COSTH - S - SM*DM) / TWO
+ U4 = - T3 - S
+ M7(I,IG1,IQ4,IQ3)=FACC*PF*WMXVSS(IG1,1)**2*VCKM(IQ1,IQ2)
+ & /XW*T3/S/U4*(-U4+TWO*SM*DM/T3/U4*SQPE*SQPE*SN2TH)*
+ & QMIXSS(IQ3,1,I)**2
+ ELSE
+ M7(I,IG1,IQ4,IQ3) = ZERO
+ END IF
+ END DO
+ END DO
+ END DO
+ END DO
+ END IF
+ HCS = 0.
+c _ _ ~+ ~- ~o ~o ~o ~
+c q q , q q -> X X , X X , X g
+c a b i j i
+ DO 1 ID1 = 1,12
+ IF (DISF(ID1,1).LT.EPS) GOTO 1
+ IF (ID1.GT.6) THEN
+ ID2 = ID1 - 6
+ IQ = ID2
+ IPB = 4132
+ ELSE
+ ID2 = ID1 + 6
+ IQ = ID1
+ IPB = 2431
+ END IF
+ IF (DISF(ID2,2).LT.EPS) GOTO 1
+ DIST = DISF(ID1,1)*DISF(ID2,2)
+ DO IG1 = 1,2
+ IG3 = ICH+IG1
+ DO IG2 = 1,2
+ IG4 = ICH+IG2+2
+ HCS = HCS + DIST*M1(IG1,IG2,IQ)
+ IF (GENEV.AND.HCS.GT.RCS) CALL HWHSSS(IG3,0,IG4,0,2134,21,*9)
+ END DO
+ END DO
+ DO IG1 = 1,4
+ IG3 = INU+IG1
+ DO IG2 = 1,4
+ IG4 = INU+IG2
+ IF (IG2.GE.IG1) HCS = HCS + DIST*M2(IG1,IG2,IQ)
+ IF (GENEV.AND.HCS.GT.RCS) CALL HWHSSS(IG3,0,IG4,0,2134,22,*9)
+ END DO
+ HCS = HCS + DIST*M4(IG1,IQ)
+ IF (GENEV.AND.HCS.GT.RCS) CALL HWHSSS(IG3,0,IGL,0, IPB,24,*9)
+ END DO
+ 1 CONTINUE
+c _ _ ~+-~o ~+-~
+c q q', q q' -> X X , X g
+c a i a
+c
+c _ _ _ _
+c ud(+), ud(-), du(-), du(+)
+ DO 2 IQ1 = 1, 3
+ DO IQ2 = 1, 3
+ IF(VCKM(IQ1,IQ2).GT.EPS) THEN
+c _
+c ud (+)
+ ID1 = IQ1 * 2
+ ID2 = IQ2 * 2 + 5
+ IF ((DISF(ID1,1).GT.EPS).AND.(DISF(ID2,2).GT.EPS)) THEN
+ DIST = DISF(ID1,1)*DISF(ID2,2)
+ DO IG1 = 1,2
+ IG3 = ICH+IG1
+ DO IG2 = 1,4
+ IG4 = INU+IG2
+ HCS = HCS + DIST*M3(IG1,IG2,IQ1,IQ2)
+ IF (GENEV.AND.HCS.GT.RCS) CALL HWHSSS(IG3,0,IG4,0,2134,23,*9)
+ END DO
+ HCS = HCS + DIST*M5(IG1,IQ1,IQ2)
+ IF (GENEV.AND.HCS.GT.RCS) CALL HWHSSS(IG3,0,IGL,0,2431,25,*9)
+ END DO
+ END IF
+c _
+c du (+)
+ ID1 = IQ2 * 2 + 5
+ ID2 = IQ1 * 2
+ IF ((DISF(ID1,1).GT.EPS).AND.(DISF(ID2,2).GT.EPS)) THEN
+ DIST = DISF(ID1,1)*DISF(ID2,2)
+ DO IG1 = 1,2
+ IG3 = ICH+IG1
+ DO IG2 = 1,4
+ IG4 = INU+IG2
+ HCS = HCS + DIST*M3(IG1,IG2,IQ1,IQ2)
+ IF (GENEV.AND.HCS.GT.RCS) CALL HWHSSS(IG4,0,IG3,0,2134,23,*9)
+ END DO
+ HCS = HCS + DIST*M5(IG1,IQ1,IQ2)
+ IF (GENEV.AND.HCS.GT.RCS) CALL HWHSSS(IGL,0,IG3,0,3124,25,*9)
+ END DO
+ END IF
+c _
+c du (-)
+ ID1 = IQ2 * 2 - 1
+ ID2 = IQ1 * 2 + 6
+ IF ((DISF(ID1,1).GT.EPS).AND.(DISF(ID2,2).GT.EPS)) THEN
+ DIST = DISF(ID1,1)*DISF(ID2,2)
+ DO IG1 = 1,2
+ IG3 = ICH+IG1+2
+ DO IG2 = 1,4
+ IG4 = INU+IG2
+ HCS = HCS + DIST*M3(IG1,IG2,IQ1,IQ2)
+ IF (GENEV.AND.HCS.GT.RCS) CALL HWHSSS(IG4,0,IG3,0,2134,23,*9)
+ END DO
+ HCS = HCS + DIST*M5(IG1,IQ1,IQ2)
+ IF (GENEV.AND.HCS.GT.RCS) CALL HWHSSS(IGL,0,IG3,0,2314,25,*9)
+ END DO
+ END IF
+c _
+c ud (-)
+ ID1 = IQ1 * 2 + 6
+ ID2 = IQ2 * 2 - 1
+ IF ((DISF(ID1,1).GT.EPS).AND.(DISF(ID2,2).GT.EPS)) THEN
+ DIST = DISF(ID1,1)*DISF(ID2,2)
+ DO IG1 = 1,2
+ IG3 = ICH+IG1+2
+ DO IG2 = 1,4
+ IG4 = INU+IG2
+ HCS = HCS + DIST*M3(IG1,IG2,IQ1,IQ2)
+ IF (GENEV.AND.HCS.GT.RCS) CALL HWHSSS(IG3,0,IG4,0,2134,23,*9)
+ END DO
+ HCS = HCS + DIST*M5(IG1,IQ1,IQ2)
+ IF (GENEV.AND.HCS.GT.RCS) CALL HWHSSS(IG3,0,IGL,0,4132,25,*9)
+ END DO
+ END IF
+ END IF
+ END DO
+ 2 CONTINUE
+c _ _ ~o ~ ~+-~
+c g q , g q , q g , q g -> X q , X q'
+c i LR a L
+c neutralino
+ DO IQ1 = 1,6
+c
+c gq
+ ID1 = 13
+ ID2 = IQ1
+ IF ((DISF(ID1,1).GT.EPS).AND.(DISF(ID2,2).GT.EPS)) THEN
+ DIST = DISF(ID1,1)*DISF(ID2,2)
+ DO IG1 = 1,4
+ IG3 = INU+IG1
+ HCS = HCS + DIST*M6L(IG1,IQ1)
+ IF (GENEV.AND.HCS.GT.RCS) CALL HWHSSS(IG3,0,ID2,0,2431,26,*9)
+ HCS = HCS + DIST*M6R(IG1,IQ1)
+ IF (GENEV.AND.HCS.GT.RCS) CALL HWHSSS(IG3,0,ID2,2,2431,26,*9)
+ END DO
+ END IF
+c _
+c gq
+ ID1 = 13
+ ID2 = IQ1 + 6
+ IF ((DISF(ID1,1).GT.EPS).AND.(DISF(ID2,2).GT.EPS)) THEN
+ DIST = DISF(ID1,1)*DISF(ID2,2)
+ DO IG1 = 1,4
+ IG3 = INU+IG1
+ HCS = HCS + DIST*M6L(IG1,IQ1)
+ IF (GENEV.AND.HCS.GT.RCS) CALL HWHSSS(IG3,0,ID2,0,4132,26,*9)
+ HCS = HCS + DIST*M6R(IG1,IQ1)
+ IF (GENEV.AND.HCS.GT.RCS) CALL HWHSSS(IG3,0,ID2,2,4132,26,*9)
+ END DO
+ END IF
+c
+c qg
+ ID1 = IQ1
+ ID2 = 13
+ IF ((DISF(ID1,1).GT.EPS).AND.(DISF(ID2,2).GT.EPS)) THEN
+ DIST = DISF(ID1,1)*DISF(ID2,2)
+ DO IG1 = 1,4
+ IG3 = INU+IG1
+ HCS = HCS + DIST*M6L(IG1,IQ1)
+ IF (GENEV.AND.HCS.GT.RCS) CALL HWHSSS(ID1,0,IG3,0,3124,26,*9)
+ HCS = HCS + DIST*M6R(IG1,IQ1)
+ IF (GENEV.AND.HCS.GT.RCS) CALL HWHSSS(ID1,2,IG3,0,3124,26,*9)
+ END DO
+ END IF
+c _
+c qg
+ ID1 = IQ1 + 6
+ ID2 = 13
+ IF ((DISF(ID1,1).GT.EPS).AND.(DISF(ID2,2).GT.EPS)) THEN
+ DIST = DISF(ID1,1)*DISF(ID2,2)
+ DO IG1 = 1,4
+ IG3 = INU+IG1
+ HCS = HCS + DIST*M6L(IG1,IQ1)
+ IF (GENEV.AND.HCS.GT.RCS) CALL HWHSSS(ID1,0,IG3,0,2314,26,*9)
+ HCS = HCS + DIST*M6R(IG1,IQ1)
+ IF (GENEV.AND.HCS.GT.RCS) CALL HWHSSS(ID1,2,IG3,0,2314,26,*9)
+ END DO
+ END IF
+ END DO
+c chargino
+ DO IQ1 = 1,3
+ IQ3 = IQ1*2
+ DO 3 IQ2 = 1,3
+ IF (VCKM(IQ1,IQ2).LT.EPS) GOTO 3
+ IQ4 = IQ2*2-1
+ DO IG1 = 1,2
+ IG3 = ICH+IG1
+ IG4 = ICH+IG1+2
+c
+c gq & qg
+ ID1 = 13
+ ID2 = IQ3
+ HCS = HCS + DISF(ID1,1)*DISF(ID2,2)*M7(1,IG1,IQ3,IQ4)
+ IF (GENEV.AND.HCS.GT.RCS) CALL HWHSSS(IG3,0,IQ4,0,2431,27,*9)
+ HCS = HCS + DISF(ID1,1)*DISF(ID2,2)*M7(2,IG1,IQ3,IQ4)
+ IF (GENEV.AND.HCS.GT.RCS) CALL HWHSSS(IG3,0,IQ4,2,2431,27,*9)
+ ID2 = IQ4
+ HCS = HCS + DISF(ID1,1)*DISF(ID2,2)*M7(1,IG1,IQ4,IQ3)
+ IF (GENEV.AND.HCS.GT.RCS) CALL HWHSSS(IG4,0,IQ3,0,2431,27,*9)
+ HCS = HCS + DISF(ID1,1)*DISF(ID2,2)*M7(2,IG1,IQ4,IQ3)
+ IF (GENEV.AND.HCS.GT.RCS) CALL HWHSSS(IG4,0,IQ3,2,2431,27,*9)
+ ID1 = IQ3
+ ID2 = 13
+ HCS = HCS + DISF(ID1,1)*DISF(ID2,2)*M7(1,IG1,IQ3,IQ4)
+ IF (GENEV.AND.HCS.GT.RCS) CALL HWHSSS(IQ4,0,IG3,0,3124,27,*9)
+ HCS = HCS + DISF(ID1,1)*DISF(ID2,2)*M7(2,IG1,IQ3,IQ4)
+ IF (GENEV.AND.HCS.GT.RCS) CALL HWHSSS(IQ4,2,IG3,0,3124,27,*9)
+ ID1 = IQ4
+ HCS = HCS + DISF(ID1,1)*DISF(ID2,2)*M7(1,IG1,IQ4,IQ3)
+ IF (GENEV.AND.HCS.GT.RCS) CALL HWHSSS(IQ3,0,IG4,0,3124,27,*9)
+ HCS = HCS + DISF(ID1,1)*DISF(ID2,2)*M7(2,IG1,IQ4,IQ3)
+ IF (GENEV.AND.HCS.GT.RCS) CALL HWHSSS(IQ3,2,IG4,0,3124,27,*9)
+c _ _
+c gq & qg
+ ID1 = 13
+ ID2 = IQ3 + 6
+ HCS = HCS + DISF(ID1,1)*DISF(ID2,2)*M7(1,IG1,IQ3,IQ4)
+ IF (GENEV.AND.HCS.GT.RCS) CALL HWHSSS(IG4,0,IQ4,1,4132,27,*9)
+ HCS = HCS + DISF(ID1,1)*DISF(ID2,2)*M7(2,IG1,IQ3,IQ4)
+ IF (GENEV.AND.HCS.GT.RCS) CALL HWHSSS(IG4,0,IQ4,3,4132,27,*9)
+ ID2 = IQ4 + 6
+ HCS = HCS + DISF(ID1,1)*DISF(ID2,2)*M7(1,IG1,IQ4,IQ3)
+ IF (GENEV.AND.HCS.GT.RCS) CALL HWHSSS(IG3,0,IQ3,1,4132,27,*9)
+ HCS = HCS + DISF(ID1,1)*DISF(ID2,2)*M7(2,IG1,IQ4,IQ3)
+ IF (GENEV.AND.HCS.GT.RCS) CALL HWHSSS(IG3,0,IQ3,3,4132,27,*9)
+ ID1 = IQ3 + 6
+ ID2 = 13
+ HCS = HCS + DISF(ID1,1)*DISF(ID2,2)*M7(1,IG1,IQ3,IQ4)
+ IF (GENEV.AND.HCS.GT.RCS) CALL HWHSSS(IQ4,1,IG4,0,2314,27,*9)
+ HCS = HCS + DISF(ID1,1)*DISF(ID2,2)*M7(2,IG1,IQ3,IQ4)
+ IF (GENEV.AND.HCS.GT.RCS) CALL HWHSSS(IQ4,3,IG4,0,2314,27,*9)
+ ID1 = IQ4 + 6
+ HCS = HCS + DISF(ID1,1)*DISF(ID2,2)*M7(1,IG1,IQ4,IQ3)
+ IF (GENEV.AND.HCS.GT.RCS) CALL HWHSSS(IQ3,1,IG3,0,2314,27,*9)
+ HCS = HCS + DISF(ID1,1)*DISF(ID2,2)*M7(2,IG1,IQ4,IQ3)
+ IF (GENEV.AND.HCS.GT.RCS) CALL HWHSSS(IQ3,3,IG3,0,2314,27,*9)
+ END DO
+ 3 CONTINUE
+ END DO
+ EVWGT = HCS
+ RETURN
+C---GENERATE EVENT
+ 9 IDN(1)=ID1
+ IDN(2)=ID2
+ IDCMF=15
+ CALL HWETWO
+ IF (AZSPIN) THEN
+C Calculate coefficients for constructing spin density matrices
+C Set to zero for now
+ CALL HWVZRO(7,GCOEF)
+ END IF
+ 888 END
+CDECK ID>, HWHSSL.
+*CMZ :- -18/05/99 20.33.45 by Kosuke Odagiri
+*-- Author : Kosuke Odagiri
+C-----------------------------------------------------------------------
+ SUBROUTINE HWHSSL
+C-----------------------------------------------------------------------
+C SUSY 2 PARTON -> 2 SLEPTON PROCESSES
+C-----------------------------------------------------------------------
+ INCLUDE 'HERWIG61.INC'
+ DOUBLE PRECISION HWR, HWUAEM, EPS, HCS, RCS, DIST, S, PF, QPE,
+ & FACTR, SN2TH, MZ, MW, ME2(2,2,6,2), ME2W(2,3), EMSC2, GW2
+ INTEGER IQ, IQ1, IQ2, ID1, ID2, IL, IL1, IL2, I, J
+ EXTERNAL HWR, HWUAEM
+ SAVE HCS, ME2, ME2W
+ PARAMETER (EPS = 1.D-9)
+ DOUBLE COMPLEX Z, GZ, A, BL, BR, CL, CR, D, E
+ PARAMETER (Z = (0.D0,1.D0))
+ EQUIVALENCE (MZ, RMASS(200)), (MW, RMASS(198))
+C
+ S = XX(1)*XX(2)*PHEP(5,3)**2
+ EMSC2 = S
+ EMSCA = SQRT(EMSC2)
+ CALL HWSGEN(.FALSE.)
+ IF (GENEV) THEN
+ RCS = HCS*HWR()
+ ELSE
+ SN2TH = 0.25D0 - 0.25D0*COSTH**2
+ FACTR = FACTSS*HWUAEM(EMSC2)**2/CAFAC*SN2TH
+ GZ = (S-MZ**2+Z*S*GAMZ/MZ)/S
+ GW2 = ((ONE-MW**2/S)**2+(GAMW/MW)**2)*(TWO*SWEIN)**2
+c _ ~ ~*
+c q q -> l l
+c
+ DO IL = 1,6
+ DO I = 1,2
+ DO J = 1,2
+ IF (((I.NE.J).AND.(IL.NE.5)).OR.
+ & ((I.EQ.2).AND.(((IL/2)*2).EQ.IL))) THEN
+ QPE = -1.
+ ELSE
+ ID1 = 412 + I*12 + IL
+ ID2 = 412 + J*12 + IL
+ IL1 = IL + 10
+ QPE = S-(RMASS(ID1)+RMASS(ID2))**2
+ END IF
+ IF (QPE.GT.ZERO) THEN
+ PF = SQRT(QPE*(S-(RMASS(ID1)-RMASS(ID2))**2))/S
+ DO IQ = 1,2
+ A = QFCH(IL1)*QFCH(IQ)
+ BL = LFCH(IL1)/GZ
+ BR = RFCH(IL1)/GZ
+ CL = LMIXSS(IL,1,I)*LMIXSS(IL,1,J)
+ CR = LMIXSS(IL,2,I)*LMIXSS(IL,2,J)
+ D = (A+BL*LFCH(IQ))*CL+(A+BR*LFCH(IQ))*CR
+ E = (A+BL*RFCH(IQ))*CL+(A+BR*RFCH(IQ))*CR
+ ME2(I,J,IL,IQ)=FACTR*PF**3*DBLE(CONJG(D)*D+CONJG(E)*E)
+ END DO
+ ELSE
+ ME2(I,J,IL,1)=ZERO
+ ME2(I,J,IL,2)=ZERO
+ END IF
+ END DO
+ END DO
+ END DO
+c _ ~ ~*
+c q q' -> l v
+c
+ DO IL = 1,3
+ DO I = 1,2
+ IF ((IL.NE.3).AND.(I.EQ.2)) THEN
+ QPE = -1.
+ ELSE
+ ID1 = 411 + IL*2 + I*12
+ ID2 = 424 + IL*2
+ QPE = S-(RMASS(ID1)+RMASS(ID2))**2
+ END IF
+ IF (QPE.GT.ZERO) THEN
+ PF = SQRT(QPE*(S-(RMASS(ID1)-RMASS(ID2))**2))/S
+ ME2W(I,IL)=FACTR*PF**3/GW2
+ IF (IL.EQ.3) ME2W(I,3)=ME2W(I,3)*LMIXSS(5,1,I)**2
+ ELSE
+ ME2W(I,IL)=ZERO
+ END IF
+ END DO
+ END DO
+
+ END IF
+ HCS = 0.
+C
+ DO 1 ID1 = 1, 12
+ IF (DISF(ID1,1).LT.EPS) GOTO 1
+ IF (ID1.GT.6) THEN
+ ID2 = ID1 - 6
+ ELSE
+ ID2 = ID1 + 6
+ END IF
+ IQ = ID1 - ((ID1-1)/2)*2
+ IF (DISF(ID2,2).LT.EPS) GOTO 1
+ DIST = DISF(ID1,1)*DISF(ID2,2)
+ DO IL = 1,6
+ DO I = 1,2
+ DO J = 1,2
+ IL1 = IL+I*12
+ IL2 = IL+J*12
+ HCS = HCS + DIST*ME2(I,J,IL,IQ)
+ IF (GENEV.AND.HCS.GT.RCS) CALL HWHSSS(IL1,2,IL2,3,2134,30,*9)
+ END DO
+ END DO
+ END DO
+ 1 CONTINUE
+c _ _ _ _
+c ud(+), ud(-), du(-), du(+)
+ DO 2 IQ1 = 1, 3
+ DO IQ2 = 1, 3
+ IF(VCKM(IQ1,IQ2).GT.EPS) THEN
+c _
+c ud (+)
+ ID1 = IQ1 * 2
+ ID2 = IQ2 * 2 + 5
+ IF ((DISF(ID1,1).GT.EPS).AND.(DISF(ID2,2).GT.EPS)) THEN
+ DIST = VCKM(IQ1,IQ2)*DISF(ID1,1)*DISF(ID2,2)
+ DO IL = 1,3
+ IL1 = IL*2-1
+ IL2 = IL1+1
+ HCS = HCS + DIST*ME2W(1,IL)
+ IF (GENEV.AND.HCS.GT.RCS) CALL HWHSSS(IL1,5,IL2,4,2134,30,*9)
+ END DO
+ HCS = HCS + DIST*ME2W(2,3)
+ IF (GENEV.AND.HCS.GT.RCS) CALL HWHSSS(5,7,6,4,2134,30,*9)
+ END IF
+c _
+c du (+)
+ ID1 = IQ2 * 2 + 5
+ ID2 = IQ1 * 2
+ IF ((DISF(ID1,1).GT.EPS).AND.(DISF(ID2,2).GT.EPS)) THEN
+ DIST = VCKM(IQ1,IQ2)*DISF(ID1,1)*DISF(ID2,2)
+ DO IL = 1,3
+ IL1 = IL*2-1
+ IL2 = IL1+1
+ HCS = HCS + DIST*ME2W(1,IL)
+ IF (GENEV.AND.HCS.GT.RCS) CALL HWHSSS(IL1,5,IL2,4,2134,30,*9)
+ END DO
+ HCS = HCS + DIST*ME2W(2,3)
+ IF (GENEV.AND.HCS.GT.RCS) CALL HWHSSS(5,7,6,4,2134,30,*9)
+ END IF
+c _
+c du (-)
+ ID1 = IQ2 * 2 - 1
+ ID2 = IQ1 * 2 + 6
+ IF ((DISF(ID1,1).GT.EPS).AND.(DISF(ID2,2).GT.EPS)) THEN
+ DIST = VCKM(IQ1,IQ2)*DISF(ID1,1)*DISF(ID2,2)
+ DO IL = 1,3
+ IL1 = IL*2-1
+ IL2 = IL1+1
+ HCS = HCS + DIST*ME2W(1,IL)
+ IF (GENEV.AND.HCS.GT.RCS) CALL HWHSSS(IL1,4,IL2,5,2134,30,*9)
+ END DO
+ HCS = HCS + DIST*ME2W(2,3)
+ IF (GENEV.AND.HCS.GT.RCS) CALL HWHSSS(5,6,6,5,2134,30,*9)
+ END IF
+c _
+c ud (-)
+ ID1 = IQ1 * 2 + 6
+ ID2 = IQ2 * 2 - 1
+ IF ((DISF(ID1,1).GT.EPS).AND.(DISF(ID2,2).GT.EPS)) THEN
+ DIST = VCKM(IQ1,IQ2)*DISF(ID1,1)*DISF(ID2,2)
+ DO IL = 1,3
+ IL1 = IL*2-1
+ IL2 = IL1+1
+ HCS = HCS + DIST*ME2W(1,IL)
+ IF (GENEV.AND.HCS.GT.RCS) CALL HWHSSS(IL1,4,IL2,5,2134,30,*9)
+ END DO
+ HCS = HCS + DIST*ME2W(2,3)
+ IF (GENEV.AND.HCS.GT.RCS) CALL HWHSSS(5,6,6,5,2134,30,*9)
+ END IF
+ END IF
+ END DO
+ 2 CONTINUE
+
+ EVWGT = HCS
+ RETURN
+C---GENERATE EVENT
+ 9 IDN(1)=ID1
+ IDN(2)=ID2
+ IDCMF=15
+ CALL HWETWO
+ IF (AZSPIN) THEN
+C Calculate coefficients for constructing spin density matrices
+C Set to zero for now
+ CALL HWVZRO(7,GCOEF)
+ END IF
+ END
+CDECK ID>, HWHSSQ.
+*CMZ :- -18/05/99 20.33.45 by Kosuke Odagiri
+*-- Author : Kosuke Odagiri
+C-----------------------------------------------------------------------
+ SUBROUTINE HWHSSQ
+C-----------------------------------------------------------------------
+C SUSY HARD 2 PARTON -> 2 SPARTON PROCESSES
+C-----------------------------------------------------------------------
+ INCLUDE 'HERWIG61.INC'
+ DOUBLE PRECISION HWR, HWUALF, EPS, HCS, RCS, DIST, NC, NC2,
+ & NC2C, ML2(6), ML4(6), MR2(6), MR4(6), MG2, SM, DM, QPE,
+ & SQPE, FACTR, AFAC, AF, BONE, CFAC, CFC2, CFC3, CONE,
+ & CONN, CONT, CONU, CONL, CONR, DFAC, DONE, PF, S,
+ & S2, TT, TT2, TMG, TMG2, UU, UU2, UMG, UMG2,
+ & L, L2, TTML, UUML, R, R2, TTMR, UUMR, SN2TH
+ DOUBLE PRECISION
+ & AUSTLL(6), AUSTRR(6),
+ & ASTULL(6,6), ASTURR(6,6), ASTULR(6,6), ASTURL(6,6),
+ & AUTSLL(6,6), AUTSRR(6,6), AUTSLR(6,6), AUTSRL(6,6),
+ & BSTULL(6), BSTURR(6), BSTULR(6), BSTURL(6),
+ & BSUTLL(6), BSUTRR(6), BSUTLR(6), BSUTRL(6),
+ & BUTSLL(6), BUTSRR(6), BUTSLR(6), BUTSRL(6),
+ & BUSTLL(6), BUSTRR(6), BUSTLR(6), BUSTRL(6),
+ & CSTU(6), CSUT(6), CSTUL(6), CSTUR(6), CSUTL(6), CSUTR(6),
+ & CTSUL(6), CTSUR(6), CTUSL(6), CTUSR(6), DUTS, DTSU, DSTU
+ INTEGER IQ, IQ1, IQ2, ID1, ID2, ID2MIN, IGL, SSL, SSR, GLU
+ EXTERNAL HWR, HWUALF
+ SAVE HCS, AUSTLL, AUSTRR, ASTULL, ASTURR, ASTULR, ASTURL,
+ & AUTSLL, AUTSRR, AUTSLR, AUTSRL, BSTULL, BSTURR, BSTULR,
+ & BSTURL, BSUTLL, BSUTRR, BSUTLR, BSUTRL, BUTSLL, BUTSRR, BUTSLR,
+ & BUTSRL, BUSTLL, BUSTRR, BUSTLR, BUSTRL, CSTU, CSUT, CSTUL, CSTUR,
+ & CSUTL, CSUTR, CTSUL, CTSUR, CTUSL, CTUSR, DUTS, DTSU, DSTU
+ PARAMETER (EPS = 1.D-9, IGL = 49, SSL = 400, SSR = 412, GLU = 449)
+ CALL HWSGEN(.FALSE.)
+ IF (GENEV) THEN
+ RCS = HCS*HWR()
+ ELSE
+ SN2TH = 0.25D0 - 0.25D0*COSTH**2
+ S = XX(1)*XX(2)*PHEP(5,3)**2
+ FACTR = FACTSS*HWUALF(1,EMSCA)**2
+ NC = CAFAC
+ NC2 = NC**2
+ NC2C = ONE - ONE/NC2
+ AFAC = FACTR*NC2C/FOUR
+ CFAC = FACTR*CFFAC/FOUR
+ CFC2 = FACTR/CFFAC/FOUR
+ CFC3 = FACTR/FOUR
+ DFAC = FACTR/NC2C
+ S2 = S**2
+ MG2 = RMASS(GLU)**2
+ DO 10 IQ = 1, 6
+ IQ1 = SSL + IQ
+ IQ2 = SSR + IQ
+ ML2(IQ) = RMASS(IQ1)**2
+ ML4(IQ) = ML2(IQ)**2
+ MR2(IQ) = RMASS(IQ2)**2
+ MR4(IQ) = MR2(IQ)**2
+ 10 CONTINUE
+c gluino pair production
+ QPE = S - FOUR*MG2
+ IF (QPE.GE.ZERO) THEN
+ SQPE = SQRT(S*QPE)
+ PF = SQPE/S
+ TT = (SQPE*COSTH - S) / TWO
+ TT2 = TT**2
+ UU = - S - TT
+ UU2 = UU**2
+c ~ ~
+c g g -> g g
+c
+ DONE =
+ & DFAC*PF/TWO*(UU2+TT2+FOUR*MG2*S*SQPE**2*SN2TH/TT/UU)/S2/TT/UU
+ DUTS = DONE*UU2
+ DTSU = DONE*TT2
+ DSTU = DONE*S2
+c _ ~ ~
+c q q -> g g
+c
+ DO 21 IQ = 1, 6
+ L = ML2(IQ)-MG2
+ L2 = L**2
+ TTML = TT-L
+ UUML = UU-L
+ R = MR2(IQ)-MG2
+ R2 = R**2
+ TTMR = TT-R
+ UUMR = UU-R
+ CONE = TWO*PF**2*SN2TH
+ CONL = CONE/UUML/TTML
+ CONR = CONE/UUMR/TTMR
+ CONT = (UU2-L2)*CONL+(UU2-R2)*CONR+L2/TTML**2+R2/TTMR**2
+ CONU = (TT2-L2)*CONL+(TT2-R2)*CONR+L2/UUML**2+R2/UUMR**2
+ CONN = CFAC*(PF-PF/NC2/(CONT+CONU)*( S2*(CONL+CONR)+
+ & L2*((TT-UU)*CONL/CONE)**2+R2*((TT-UU)*CONR/CONE)**2 ))
+ CSTU(IQ) = CONT*CONN
+ CSUT(IQ) = CONU*CONN
+ 21 CONTINUE
+ ELSE
+ DUTS = ZERO
+ DTSU = ZERO
+ DSTU = ZERO
+ DO 23 IQ = 1, 6
+ CSTU(IQ) = ZERO
+ CSUT(IQ) = ZERO
+ 23 CONTINUE
+ END IF
+c left handed squark (identical flavour) pair production
+ DO 22 IQ = 1, 6
+ QPE = S - FOUR*ML2(IQ)
+ IF (QPE.GE.ZERO) THEN
+ SQPE = SQRT(S*QPE)
+ PF = SQPE/S
+ TT = (SQPE*COSTH - S) / TWO
+ TT2 = TT**2
+ UU = - S - TT
+ UU2 = UU**2
+c ~ ~*
+c g g -> q q
+c L L
+ CONE = CFC2*PF*((SQPE*PF*SN2TH)**2+ML4(IQ))/TT2/UU2
+ CONN = CONE-CONE*S2/(TT2+UU2)/NC2
+ CSTUL(IQ) = CONN*UU2
+ CSUTL(IQ) = CONN*TT2
+c ~ ~
+c q q -> q q
+c L L
+ TMG = TT+ML2(IQ)-MG2
+ TMG2 = TMG**2
+ UMG = UU+ML2(IQ)-MG2
+ UMG2 = UMG**2
+ BONE = AFAC*PF*MG2*S*(HALF-TMG*UMG/(TMG2+UMG2)/NC)
+ BSTULL(IQ) = BONE/TMG2
+ BSUTLL(IQ) = BONE/UMG2
+c _ ~ ~*
+c q q -> q q
+c L L
+ AF = AFAC*PF*PF**2*SN2TH
+ BONE = AF/TMG2-AF*S/(HALF*S2+TMG2)/TMG/NC
+ BUTSLL(IQ) = BONE*S2
+ BUSTLL(IQ) = BONE*TWO*TMG2
+c _ ~ ~*
+c q q -> q'q' q =/= q'
+c L L
+ AUSTLL(IQ) = TWO*AF
+ ELSE
+ CSTUL(IQ) = ZERO
+ CSUTL(IQ) = ZERO
+ BSTULL(IQ) = ZERO
+ BSUTLL(IQ) = ZERO
+ BUTSLL(IQ) = ZERO
+ BUSTLL(IQ) = ZERO
+ AUSTLL(IQ) = ZERO
+ END IF
+c right handed squark (identical flavour) pair production
+ QPE = S - FOUR*MR2(IQ)
+ IF (QPE.GE.ZERO) THEN
+ SQPE = SQRT(S*QPE)
+ PF = SQPE/S
+ TT = (SQPE*COSTH - S) / TWO
+ TT2 = TT**2
+ UU = - S - TT
+ UU2 = UU**2
+c ~ ~*
+c g g -> q q
+c R R
+ CONE = CFC2*PF*((SQPE*PF*SN2TH)**2+MR4(IQ))/TT2/UU2
+ CONN = CONE-CONE*S2/(TT2+UU2)/NC2
+ CSTUR(IQ) = CONN*UU2
+ CSUTR(IQ) = CONN*TT2
+c ~ ~
+c q q -> q q
+c R R
+ TMG = TT+MR2(IQ)-MG2
+ TMG2 = TMG**2
+ UMG = UU+MR2(IQ)-MG2
+ UMG2 = UMG**2
+ BONE = AFAC*PF*MG2*S*(HALF-TMG*UMG/(TMG2+UMG2)/NC)
+ BSTURR(IQ) = BONE/TMG2
+ BSUTRR(IQ) = BONE/UMG2
+c _ ~ ~*
+c q q -> q q
+c R R
+ AF = AFAC*PF*PF**2*SN2TH
+ BONE = AF/TMG2-AF*S/(HALF*S2+TMG2)/TMG/NC
+ BUTSRR(IQ) = BONE*S2
+ BUSTRR(IQ) = BONE*TWO*TMG2
+c _ ~ ~*
+c q q -> q'q' q =/= q'
+c R R
+ AUSTRR(IQ) = TWO*AF
+ ELSE
+ CSTUR(IQ) = ZERO
+ CSUTR(IQ) = ZERO
+ BSTURR(IQ) = ZERO
+ BSUTRR(IQ) = ZERO
+ BUTSRR(IQ) = ZERO
+ BUSTRR(IQ) = ZERO
+ AUSTRR(IQ) = ZERO
+ END IF
+c left and right handed squark (identical flavour) pair production
+ IQ1 = SSL + IQ
+ IQ2 = SSR + IQ
+ SM = RMASS(IQ1)+RMASS(IQ2)
+ QPE = S - SM**2
+ IF (QPE.GE.ZERO) THEN
+ DM = RMASS(IQ1)-RMASS(IQ2)
+ SQPE = SQRT( QPE*(S-DM**2) )
+ PF = SQPE/S
+ AF = AFAC*PF
+ TT = (SQPE*COSTH - S - SM*DM) / TWO
+ UU = - S - TT
+ TMG = TT + ML2(IQ) - MG2
+ TMG2 = TMG**2
+ UMG = UU + MR2(IQ) - MG2
+ UMG2 = UMG**2
+c ~ ~
+c q q -> q q
+c L R
+ BONE = AFAC*PF*SQPE**2*SN2TH
+ BSTULR(IQ) = BONE/TMG2
+ BSUTLR(IQ) = BONE/UMG2
+c _ ~ ~*
+c q q -> q q
+c L R
+ BUTSLR(IQ) = AFAC*PF*MG2*S/TMG2
+ BUSTLR(IQ) = ZERO
+ TT = (SQPE*COSTH - S + SM*DM) / TWO
+ UU = - S - TT
+ TMG = TT + MR2(IQ) - MG2
+ TMG2 = TMG**2
+ UMG = UU + ML2(IQ) - MG2
+ UMG2 = UMG**2
+c ~ ~
+c q q -> q q
+c R L
+c BONE = AFAC*PF*SQPE**2*SN2TH
+c BSTURL(IQ) = BONE/TMG2
+c BSUTRL(IQ) = BONE/UMG2
+ BSTURL(IQ) = ZERO
+ BSUTRL(IQ) = ZERO
+c _ ~ ~*
+c q q -> q q
+c R L
+ BUTSRL(IQ) = AFAC*PF*MG2*S/TMG2
+ BUSTRL(IQ) = ZERO
+ ELSE
+ BSTULR(IQ) = ZERO
+ BSUTLR(IQ) = ZERO
+ BUTSLR(IQ) = ZERO
+ BUSTLR(IQ) = ZERO
+ BSTURL(IQ) = ZERO
+ BSUTRL(IQ) = ZERO
+ BUTSRL(IQ) = ZERO
+ BUSTRL(IQ) = ZERO
+ END IF
+ 22 CONTINUE
+c distinct flavours - gq, qq'
+ DO 11 ID1 = 1, 6
+ IQ1 = SSL + ID1
+ SM = RMASS(GLU)+RMASS(IQ1)
+ QPE = S - SM**2
+ IF (QPE.GE.ZERO) THEN
+ DM = RMASS(GLU)-RMASS(IQ1)
+ SQPE = SQRT( QPE*(S-DM**2) )
+ PF = SQPE/S
+ TT = (SQPE*COSTH - S - SM*DM) / TWO
+ TT2 = TT**2
+ UU = - S - TT
+ UU2 = UU**2
+c ~ ~
+c g q -> g q
+c L
+ CONE = (-UU+TWO*SM*DM*(ONE+MG2/TT+ML2(ID1)/UU))/S/TT/UU
+ CONN = CFC3*PF*CONE*(ONE-TT2/(UU2+S2)/NC2)
+ CTSUL(ID1) = CONN*UU2
+ CTUSL(ID1) = CONN*S2
+ ELSE
+ CTSUL(ID1) = ZERO
+ CTUSL(ID1) = ZERO
+ END IF
+ IQ2 = SSR + ID1
+ SM = RMASS(GLU)+RMASS(IQ2)
+ QPE = S - SM**2
+ IF (QPE.GE.ZERO) THEN
+ DM = RMASS(GLU)-RMASS(IQ2)
+ SQPE = SQRT( QPE*(S-DM**2) )
+ PF = SQPE/S
+ TT = (SQPE*COSTH - S - SM*DM) / TWO
+ TT2 = TT**2
+ UU = - S - TT
+ UU2 = UU**2
+c ~ ~
+c g q -> g q
+c R
+ CONE = (-UU+TWO*SM*DM*(ONE+MG2/TT+MR2(ID1)/UU))/S/TT/UU
+ CONN = CFC3*PF*CONE*(ONE-TT2/(UU2+S2)/NC2)
+ CTSUR(ID1) = CONN*UU2
+ CTUSR(ID1) = CONN*S2
+ ELSE
+ CTSUR(ID1) = ZERO
+ CTUSR(ID1) = ZERO
+ END IF
+ IF(ID1.EQ.6) GOTO 11
+ ID2MIN = ID1+1
+ DO 12 ID2 = ID2MIN, 6
+ IQ1 = SSL + ID1
+ IQ2 = SSL + ID2
+ SM = RMASS(IQ1)+RMASS(IQ2)
+ QPE = S - SM**2
+ IF (QPE.GE.ZERO) THEN
+ DM = RMASS(IQ1)-RMASS(IQ2)
+ SQPE = SQRT( QPE*(S-DM**2) )
+ PF = SQPE/S
+ TT = (SQPE*COSTH - S - SM*DM) / TWO
+ UU = - S - TT
+ TMG = TT+ML2(ID1)-MG2
+ AF = AFAC*PF/TMG/TMG
+c ~ ~
+c q q' -> q q'
+c L L
+ ASTULL(ID1,ID2) = AF*MG2*S
+ ASTULL(ID2,ID1) = ASTULL(ID1,ID2)
+c _ ~ ~*
+c q q' -> q q'
+c L L
+ AUTSLL(ID1,ID2) = AF*SQPE**2*SN2TH
+ AUTSLL(ID2,ID1) = AUTSLL(ID1,ID2)
+ ELSE
+ ASTULL(ID1,ID2) = ZERO
+ ASTULL(ID2,ID1) = ZERO
+ AUTSLL(ID1,ID2) = ZERO
+ AUTSLL(ID2,ID1) = ZERO
+ END IF
+ IQ1 = SSR + ID1
+ IQ2 = SSR + ID2
+ SM = RMASS(IQ1)+RMASS(IQ2)
+ QPE = S - SM**2
+ IF (QPE.GE.ZERO) THEN
+ DM = RMASS(IQ1)-RMASS(IQ2)
+ SQPE = SQRT( QPE*(S-DM**2) )
+ PF = SQPE/S
+ TT = (SQPE*COSTH - S - SM*DM) / TWO
+ UU = - S - TT
+ TMG = TT+MR2(ID1)-MG2
+ AF = AFAC*PF/TMG/TMG
+c ~ ~
+c q q' -> q q'
+c R R
+ ASTURR(ID1,ID2) = AF*MG2*S
+ ASTURR(ID2,ID1) = ASTURR(ID1,ID2)
+c _ ~ ~*
+c q q' -> q q'
+c R R
+ AUTSRR(ID1,ID2) = AF*SQPE**2*SN2TH
+ AUTSRR(ID2,ID1) = AUTSRR(ID1,ID2)
+ ELSE
+ ASTURR(ID1,ID2) = ZERO
+ ASTURR(ID2,ID1) = ZERO
+ AUTSRR(ID1,ID2) = ZERO
+ AUTSRR(ID2,ID1) = ZERO
+ END IF
+ IQ1 = SSL + ID1
+ IQ2 = SSR + ID2
+ SM = RMASS(IQ1)+RMASS(IQ2)
+ QPE = S - SM**2
+ IF (QPE.GE.ZERO) THEN
+ DM = RMASS(IQ1)-RMASS(IQ2)
+ SQPE = SQRT( QPE*(S-DM**2) )
+ PF = SQPE/S
+ TT = (SQPE*COSTH - S - SM*DM) / TWO
+ UU = - S - TT
+ TMG = TT+ML2(ID1)-MG2
+ AF = AFAC*PF/TMG/TMG
+c ~ ~
+c q q' -> q q'
+c L R
+ ASTULR(ID1,ID2) = AF*SQPE**2*SN2TH
+ ASTULR(ID2,ID1) = ASTULR(ID1,ID2)
+c _ ~ ~*
+c q q' -> q q'
+c L R
+ AUTSLR(ID1,ID2) = AF*MG2*S
+ AUTSLR(ID2,ID1) = AUTSLR(ID1,ID2)
+ TT = (SQPE*COSTH - S + SM*DM) / TWO
+ UU = - S - TT
+ TMG = TT+MR2(ID1)-MG2
+ AF = AFAC*PF/TMG/TMG
+c ~ ~
+c q q' -> q q'
+c R L
+ ASTURL(ID1,ID2) = AF*SQPE**2*SN2TH
+ ASTURL(ID2,ID1) = ASTULR(ID1,ID2)
+c _ ~ ~*
+c q q' -> q q'
+c R L
+ AUTSRL(ID1,ID2) = AF*MG2*S
+ AUTSRL(ID2,ID1) = AUTSLR(ID1,ID2)
+ ELSE
+ ASTULR(ID1,ID2) = ZERO
+ ASTULR(ID2,ID1) = ZERO
+ AUTSLR(ID1,ID2) = ZERO
+ AUTSLR(ID2,ID1) = ZERO
+ ASTURL(ID1,ID2) = ZERO
+ ASTURL(ID2,ID1) = ZERO
+ AUTSRL(ID1,ID2) = ZERO
+ AUTSRL(ID2,ID1) = ZERO
+ END IF
+ 12 CONTINUE
+ 11 CONTINUE
+ END IF
+ HCS = ZERO
+ DO 6 ID1 = 1, 13
+ IF (DISF(ID1,1).LT.EPS) GOTO 6
+ DO 5 ID2 = 1, 13
+ IF (DISF(ID2,2).LT.EPS) GOTO 5
+ DIST = DISF(ID1,1)*DISF(ID2,2)
+
+ IF (ID1.LT.7) THEN
+ IQ1 = ID1
+ IF (ID2.LT.7) THEN
+ IQ2 = ID2
+ IF (IQ1.NE.IQ2) THEN
+c ~ ~
+c qq' -> q q'
+ HCS = HCS + ASTULL(IQ1,IQ2)*DIST
+ IF (GENEV.AND.HCS.GT.RCS) CALL HWHSSS(IQ1,0,IQ2,0,3421,10,*9)
+ HCS = HCS + ASTURR(IQ1,IQ2)*DIST
+ IF (GENEV.AND.HCS.GT.RCS) CALL HWHSSS(IQ1,2,IQ2,2,3421,10,*9)
+ HCS = HCS + ASTULR(IQ1,IQ2)*DIST
+ IF (GENEV.AND.HCS.GT.RCS) CALL HWHSSS(IQ1,0,IQ2,2,3421,10,*9)
+ HCS = HCS + ASTURL(IQ1,IQ2)*DIST
+ IF (GENEV.AND.HCS.GT.RCS) CALL HWHSSS(IQ1,2,IQ2,0,3421,10,*9)
+ ELSE
+c ~ ~
+c qq -> q q
+ HCS = HCS + BSTULL(IQ1)*DIST
+ IF (GENEV.AND.HCS.GT.RCS) CALL HWHSSS(IQ1,0,IQ2,0,3421,10,*9)
+ HCS = HCS + BSTURR(IQ1)*DIST
+ IF (GENEV.AND.HCS.GT.RCS) CALL HWHSSS(IQ1,2,IQ2,2,3421,10,*9)
+ HCS = HCS + BSTULR(IQ1)*DIST
+ IF (GENEV.AND.HCS.GT.RCS) CALL HWHSSS(IQ1,0,IQ2,2,3421,10,*9)
+ HCS = HCS + BSTURL(IQ1)*DIST
+ IF (GENEV.AND.HCS.GT.RCS) CALL HWHSSS(IQ1,2,IQ2,0,3421,10,*9)
+ HCS = HCS + BSUTLL(IQ1)*DIST
+ IF (GENEV.AND.HCS.GT.RCS) CALL HWHSSS(IQ1,0,IQ2,0,4312,10,*9)
+ HCS = HCS + BSUTRR(IQ1)*DIST
+ IF (GENEV.AND.HCS.GT.RCS) CALL HWHSSS(IQ1,2,IQ2,2,4312,10,*9)
+ HCS = HCS + BSUTLR(IQ1)*DIST
+ IF (GENEV.AND.HCS.GT.RCS) CALL HWHSSS(IQ1,0,IQ2,2,4312,10,*9)
+ HCS = HCS + BSUTRL(IQ1)*DIST
+ IF (GENEV.AND.HCS.GT.RCS) CALL HWHSSS(IQ1,2,IQ2,0,4312,10,*9)
+ END IF
+ ELSEIF (ID2.NE.13) THEN
+ IQ2 = ID2-6
+ IF (IQ1.NE.IQ2) THEN
+c _ ~ ~*
+c qq' -> q q'
+ HCS = HCS + AUTSLL(IQ1,IQ2)*DIST
+ IF (GENEV.AND.HCS.GT.RCS) CALL HWHSSS(IQ1,0,IQ2,1,3142,10,*9)
+ HCS = HCS + AUTSRR(IQ1,IQ2)*DIST
+ IF (GENEV.AND.HCS.GT.RCS) CALL HWHSSS(IQ1,2,IQ2,3,3142,10,*9)
+ HCS = HCS + AUTSLR(IQ1,IQ2)*DIST
+ IF (GENEV.AND.HCS.GT.RCS) CALL HWHSSS(IQ1,0,IQ2,3,3142,10,*9)
+ HCS = HCS + AUTSRL(IQ1,IQ2)*DIST
+ IF (GENEV.AND.HCS.GT.RCS) CALL HWHSSS(IQ1,2,IQ2,1,3142,10,*9)
+ ELSE
+c _ ~ ~*
+c qq -> q'q' (q =/= q')
+ DO 30 IQ = 1, 6
+ IF (IQ .EQ.IQ1) GOTO 30
+ HCS = HCS + AUSTLL(IQ )*DIST
+ IF (GENEV.AND.HCS.GT.RCS) CALL HWHSSS(IQ ,0,IQ ,1,2413,10,*9)
+ HCS = HCS + AUSTRR(IQ )*DIST
+ IF (GENEV.AND.HCS.GT.RCS) CALL HWHSSS(IQ ,2,IQ ,3,2413,10,*9)
+ 30 CONTINUE
+c _ ~ ~*
+c qq -> q q
+ HCS = HCS + BUTSLL(IQ1)*DIST
+ IF (GENEV.AND.HCS.GT.RCS) CALL HWHSSS(IQ1,0,IQ2,1,3142,10,*9)
+ HCS = HCS + BUTSRR(IQ1)*DIST
+ IF (GENEV.AND.HCS.GT.RCS) CALL HWHSSS(IQ1,2,IQ2,3,3142,10,*9)
+ HCS = HCS + BUTSLR(IQ1)*DIST
+ IF (GENEV.AND.HCS.GT.RCS) CALL HWHSSS(IQ1,0,IQ2,3,3142,10,*9)
+ HCS = HCS + BUTSRL(IQ1)*DIST
+ IF (GENEV.AND.HCS.GT.RCS) CALL HWHSSS(IQ1,2,IQ2,1,3142,10,*9)
+ HCS = HCS + BUSTLL(IQ1)*DIST
+ IF (GENEV.AND.HCS.GT.RCS) CALL HWHSSS(IQ1,0,IQ2,1,2413,10,*9)
+ HCS = HCS + BUSTRR(IQ1)*DIST
+ IF (GENEV.AND.HCS.GT.RCS) CALL HWHSSS(IQ1,2,IQ2,3,2413,10,*9)
+ HCS = HCS + BUSTLR(IQ1)*DIST
+ IF (GENEV.AND.HCS.GT.RCS) CALL HWHSSS(IQ1,0,IQ2,3,2413,10,*9)
+ HCS = HCS + BUSTRL(IQ1)*DIST
+ IF (GENEV.AND.HCS.GT.RCS) CALL HWHSSS(IQ1,2,IQ2,1,2413,10,*9)
+ IQ = IGL
+c _ ~ ~
+c qq -> g g
+ HCS = HCS + CSTU(IQ1)*DIST
+ IF (GENEV.AND.HCS.GT.RCS) CALL HWHSSS(IQ ,0,IQ ,0,2413,10,*9)
+ HCS = HCS + CSUT(IQ1)*DIST
+ IF (GENEV.AND.HCS.GT.RCS) CALL HWHSSS(IQ ,0,IQ ,0,2341,10,*9)
+ END IF
+ ELSE
+ IQ2 = IGL
+c ~ ~
+c qg -> q g
+ HCS = HCS + CTSUL(IQ1)*DIST
+ IF (GENEV.AND.HCS.GT.RCS) CALL HWHSSS(IQ1,0,IQ2,0,3142,10,*9)
+ HCS = HCS + CTSUR(IQ1)*DIST
+ IF (GENEV.AND.HCS.GT.RCS) CALL HWHSSS(IQ1,2,IQ2,0,3142,10,*9)
+ HCS = HCS + CTUSL(IQ1)*DIST
+ IF (GENEV.AND.HCS.GT.RCS) CALL HWHSSS(IQ1,0,IQ2,0,3421,10,*9)
+ HCS = HCS + CTUSR(IQ1)*DIST
+ IF (GENEV.AND.HCS.GT.RCS) CALL HWHSSS(IQ1,2,IQ2,0,3421,10,*9)
+ END IF
+ ELSEIF (ID1.NE.13) THEN
+ IQ1 = ID1 - 6
+ IF (ID2.LT.7) THEN
+ IQ2 = ID2
+ IF (IQ1.NE.IQ2) THEN
+c _ ~*~
+c qq' -> q q'
+ HCS = HCS + AUTSLL(IQ1,IQ2)*DIST
+ IF (GENEV.AND.HCS.GT.RCS) CALL HWHSSS(IQ1,1,IQ2,0,2413,10,*9)
+ HCS = HCS + AUTSRR(IQ1,IQ2)*DIST
+ IF (GENEV.AND.HCS.GT.RCS) CALL HWHSSS(IQ1,3,IQ2,2,2413,10,*9)
+ HCS = HCS + AUTSLR(IQ1,IQ2)*DIST
+ IF (GENEV.AND.HCS.GT.RCS) CALL HWHSSS(IQ1,1,IQ2,2,2413,10,*9)
+ HCS = HCS + AUTSRL(IQ1,IQ2)*DIST
+ IF (GENEV.AND.HCS.GT.RCS) CALL HWHSSS(IQ1,3,IQ2,0,2413,10,*9)
+ ELSE
+c _ ~*~
+c qq -> q'q' (q =/= q')
+ DO 31 IQ = 1, 6
+ IF (IQ .EQ.IQ1) GOTO 31
+ HCS = HCS + AUSTLL(IQ)*DIST
+ IF (GENEV.AND.HCS.GT.RCS) CALL HWHSSS(IQ ,1,IQ ,0,3142,10,*9)
+ HCS = HCS + AUSTRR(IQ)*DIST
+ IF (GENEV.AND.HCS.GT.RCS) CALL HWHSSS(IQ ,3,IQ ,2,3142,10,*9)
+ 31 CONTINUE
+c _ ~*~
+c qq -> q q
+ HCS = HCS + BUTSLL(IQ1)*DIST
+ IF (GENEV.AND.HCS.GT.RCS) CALL HWHSSS(IQ1,1,IQ2,0,2413,10,*9)
+ HCS = HCS + BUTSRR(IQ1)*DIST
+ IF (GENEV.AND.HCS.GT.RCS) CALL HWHSSS(IQ1,3,IQ2,2,2413,10,*9)
+ HCS = HCS + BUTSLR(IQ1)*DIST
+ IF (GENEV.AND.HCS.GT.RCS) CALL HWHSSS(IQ1,1,IQ2,2,2413,10,*9)
+ HCS = HCS + BUTSRL(IQ1)*DIST
+ IF (GENEV.AND.HCS.GT.RCS) CALL HWHSSS(IQ1,3,IQ2,0,2413,10,*9)
+ HCS = HCS + BUSTLL(IQ1)*DIST
+ IF (GENEV.AND.HCS.GT.RCS) CALL HWHSSS(IQ1,1,IQ2,0,3142,10,*9)
+ HCS = HCS + BUSTRR(IQ1)*DIST
+ IF (GENEV.AND.HCS.GT.RCS) CALL HWHSSS(IQ1,3,IQ2,2,3142,10,*9)
+ HCS = HCS + BUSTLR(IQ1)*DIST
+ IF (GENEV.AND.HCS.GT.RCS) CALL HWHSSS(IQ1,1,IQ2,2,3142,10,*9)
+ HCS = HCS + BUSTRL(IQ1)*DIST
+ IF (GENEV.AND.HCS.GT.RCS) CALL HWHSSS(IQ1,3,IQ2,0,3142,10,*9)
+c _ ~ ~
+c qq -> g g
+ HCS = HCS + CSTU(IQ1)*DIST
+ IF (GENEV.AND.HCS.GT.RCS) CALL HWHSSS(IGL,0,IGL,0,3142,10,*9)
+ HCS = HCS + CSUT(IQ1)*DIST
+ IF (GENEV.AND.HCS.GT.RCS) CALL HWHSSS(IGL,0,IGL,0,4123,10,*9)
+ END IF
+ ELSEIF (ID2.NE.13) THEN
+ IQ2 = ID2 - 6
+ IF (IQ1.NE.IQ2) THEN
+c __ ~*~*
+c qq' -> q q'
+ HCS = HCS + ASTULL(IQ1,IQ2)*DIST
+ IF (GENEV.AND.HCS.GT.RCS) CALL HWHSSS(IQ1,1,IQ2,1,4312,10,*9)
+ HCS = HCS + ASTURR(IQ1,IQ2)*DIST
+ IF (GENEV.AND.HCS.GT.RCS) CALL HWHSSS(IQ1,3,IQ2,3,4312,10,*9)
+ HCS = HCS + ASTULR(IQ1,IQ2)*DIST
+ IF (GENEV.AND.HCS.GT.RCS) CALL HWHSSS(IQ1,1,IQ2,3,4312,10,*9)
+ HCS = HCS + ASTURL(IQ1,IQ2)*DIST
+ IF (GENEV.AND.HCS.GT.RCS) CALL HWHSSS(IQ1,3,IQ2,1,4312,10,*9)
+ ELSE
+c __ ~*~*
+c qq -> q q
+ HCS = HCS + BSTULL(IQ1)*DIST
+ IF (GENEV.AND.HCS.GT.RCS) CALL HWHSSS(IQ1,1,IQ2,1,4312,10,*9)
+ HCS = HCS + BSTURR(IQ1)*DIST
+ IF (GENEV.AND.HCS.GT.RCS) CALL HWHSSS(IQ1,3,IQ2,3,4312,10,*9)
+ HCS = HCS + BSTULR(IQ1)*DIST
+ IF (GENEV.AND.HCS.GT.RCS) CALL HWHSSS(IQ1,1,IQ2,3,4312,10,*9)
+ HCS = HCS + BSTURL(IQ1)*DIST
+ IF (GENEV.AND.HCS.GT.RCS) CALL HWHSSS(IQ1,3,IQ2,1,4312,10,*9)
+ HCS = HCS + BSUTLL(IQ1)*DIST
+ IF (GENEV.AND.HCS.GT.RCS) CALL HWHSSS(IQ1,1,IQ2,1,3421,10,*9)
+ HCS = HCS + BSUTRR(IQ1)*DIST
+ IF (GENEV.AND.HCS.GT.RCS) CALL HWHSSS(IQ1,3,IQ2,3,3421,10,*9)
+ HCS = HCS + BSUTLR(IQ1)*DIST
+ IF (GENEV.AND.HCS.GT.RCS) CALL HWHSSS(IQ1,1,IQ2,3,3421,10,*9)
+ HCS = HCS + BSUTRL(IQ1)*DIST
+ IF (GENEV.AND.HCS.GT.RCS) CALL HWHSSS(IQ1,3,IQ2,1,3421,10,*9)
+ END IF
+ ELSE
+ IQ2 = IGL
+c _ ~*~
+c qg -> q g
+ HCS = HCS + CTSUL(IQ1)*DIST
+ IF (GENEV.AND.HCS.GT.RCS) CALL HWHSSS(IQ1,1,IQ2,0,2413,10,*9)
+ HCS = HCS + CTSUR(IQ1)*DIST
+ IF (GENEV.AND.HCS.GT.RCS) CALL HWHSSS(IQ1,3,IQ2,0,2413,10,*9)
+ HCS = HCS + CTUSL(IQ1)*DIST
+ IF (GENEV.AND.HCS.GT.RCS) CALL HWHSSS(IQ1,1,IQ2,0,4312,10,*9)
+ HCS = HCS + CTUSR(IQ1)*DIST
+ IF (GENEV.AND.HCS.GT.RCS) CALL HWHSSS(IQ1,3,IQ2,0,4312,10,*9)
+ END IF
+ ELSE
+ IQ1 = IGL
+ IF (ID2.LT.7) THEN
+ IQ2 = ID2
+c ~ ~
+c gq -> g q
+ HCS = HCS + CTSUL(IQ2)*DIST
+ IF (GENEV.AND.HCS.GT.RCS) CALL HWHSSS(IQ1,0,IQ2,0,2413,10,*9)
+ HCS = HCS + CTSUR(IQ2)*DIST
+ IF (GENEV.AND.HCS.GT.RCS) CALL HWHSSS(IQ1,0,IQ2,2,2413,10,*9)
+ HCS = HCS + CTUSL(IQ2)*DIST
+ IF (GENEV.AND.HCS.GT.RCS) CALL HWHSSS(IQ1,0,IQ2,0,3421,10,*9)
+ HCS = HCS + CTUSR(IQ2)*DIST
+ IF (GENEV.AND.HCS.GT.RCS) CALL HWHSSS(IQ1,0,IQ2,2,3421,10,*9)
+ ELSEIF (ID2.LT.13) THEN
+ IQ2 = ID2 - 6
+c _ ~ ~*
+c gq -> g q
+ HCS = HCS + CTSUL(IQ2)*DIST
+ IF (GENEV.AND.HCS.GT.RCS) CALL HWHSSS(IQ1,0,IQ2,1,3142,10,*9)
+ HCS = HCS + CTSUR(IQ2)*DIST
+ IF (GENEV.AND.HCS.GT.RCS) CALL HWHSSS(IQ1,0,IQ2,3,3142,10,*9)
+ HCS = HCS + CTUSL(IQ2)*DIST
+ IF (GENEV.AND.HCS.GT.RCS) CALL HWHSSS(IQ1,0,IQ2,1,4312,10,*9)
+ HCS = HCS + CTUSR(IQ2)*DIST
+ IF (GENEV.AND.HCS.GT.RCS) CALL HWHSSS(IQ1,0,IQ2,3,4312,10,*9)
+ ELSE
+ IQ2 = IGL
+c ~ ~*
+c gg -> q q
+ DO 32 IQ = 1, 6
+ HCS = HCS + CSTUL(IQ)*DIST
+ IF (GENEV.AND.HCS.GT.RCS) CALL HWHSSS(IQ ,0,IQ ,1,2413,10,*9)
+ HCS = HCS + CSTUR(IQ)*DIST
+ IF (GENEV.AND.HCS.GT.RCS) CALL HWHSSS(IQ ,2,IQ ,3,2413,10,*9)
+ HCS = HCS + CSUTL(IQ)*DIST
+ IF (GENEV.AND.HCS.GT.RCS) CALL HWHSSS(IQ ,0,IQ ,1,4123,10,*9)
+ HCS = HCS + CSUTR(IQ)*DIST
+ IF (GENEV.AND.HCS.GT.RCS) CALL HWHSSS(IQ ,2,IQ ,3,4123,10,*9)
+ 32 CONTINUE
+c ~ ~
+c gg -> g g
+ HCS = HCS + DTSU*DIST
+ IF (GENEV.AND.HCS.GT.RCS) CALL HWHSSS(IQ1,0,IQ2,0,2341,10,*9)
+ HCS = HCS + DSTU*DIST
+ IF (GENEV.AND.HCS.GT.RCS) CALL HWHSSS(IQ1,0,IQ2,0,3421,10,*9)
+ HCS = HCS + DUTS*DIST
+ IF (GENEV.AND.HCS.GT.RCS) CALL HWHSSS(IQ1,0,IQ2,0,2413,10,*9)
+ END IF
+ END IF
+ 5 CONTINUE
+ 6 CONTINUE
+ EVWGT = HCS
+ RETURN
+C---GENERATE EVENT
+ 9 IDN(1)=ID1
+ IDN(2)=ID2
+ IDCMF=15
+ CALL HWETWO
+ IF (AZSPIN) THEN
+C Calculate coefficients for constructing spin density matrices
+C Set to zero for now
+ CALL HWVZRO(7,GCOEF)
+ END IF
+ 999 END
+CDECK ID>, HWHSSP.
+*CMZ :- -25/06/99 20.33.45 by Kosuke Odagiri
+*-- Author : Kosuke Odagiri & Bryan Webber
+C-----------------------------------------------------------------------
+ SUBROUTINE HWHSSP
+C-----------------------------------------------------------------------
+C SUSY HARD 2 PARTON -> 2 SPARTON/GAUGINO/SLEPTON PROCESSES
+C-----------------------------------------------------------------------
+ INCLUDE 'HERWIG61.INC'
+ DOUBLE PRECISION SAVWT(3),RANWT,HWR,HWRUNI,Z1,Z2,ET,EJ,
+ & QPE,S,T,U,KK,KK2,YJ1INF,YJ1SUP,YJ2INF,YJ2SUP,SVEMSC
+ INTEGER ISP
+ EXTERNAL HWR,HWRUNI
+ SAVE SAVWT,SVEMSC
+ IF (.NOT.GENEV) THEN
+ EVWGT=ZERO
+ CALL HWRPOW(ET,EJ)
+ KK = ET/PHEP(5,3)
+ KK2=KK**2
+ IF (KK.GE.ONE) RETURN
+ YJ1INF = MAX( YJMIN, LOG((ONE-SQRT(ONE-KK2))/KK) )
+ YJ1SUP = MIN( YJMAX, LOG((ONE+SQRT(ONE-KK2))/KK) )
+ IF (YJ1INF.GE.YJ1SUP) RETURN
+ Z1=EXP(HWRUNI(1,YJ1INF,YJ1SUP))
+ YJ2INF = MAX( YJMIN, -LOG(TWO/KK-ONE/Z1) )
+ YJ2SUP = MIN( YJMAX, LOG(TWO/KK-Z1) )
+ IF (YJ2INF.GE.YJ2SUP) RETURN
+ Z2=EXP(HWRUNI(2,YJ2INF,YJ2SUP))
+ XX(1)=HALF*(Z1+Z2)*KK
+ IF (XX(1).GE.ONE) RETURN
+ XX(2)=XX(1)/(Z1*Z2)
+ IF (XX(2).GE.ONE) RETURN
+ S=XX(1)*XX(2)*PHEP(5,3)**2
+ QPE=S-(TWO*RMMNSS)**2
+ IF (QPE.LE.ZERO) RETURN
+ COSTH=HALF*ET*(Z1-Z2)/SQRT(Z1*Z2*QPE)
+ IF (ABS(COSTH).GT.ONE) RETURN
+ T=-(ONE+Z2/Z1)*(HALF*ET)**2
+ U=-S-T
+C---SET EMSCA TO HEAVY HARD PROCESS SCALE
+ SVEMSC = SQRT(TWO*S*T*U/(S*S+T*T+U*U))
+ FACTSS = GEV2NB*HALF*PIFAC*EJ*ET/S**2
+ & * (YJ1SUP-YJ1INF)*(YJ2SUP-YJ2INF)
+ & * SQRT(S/QPE)
+ ENDIF
+ EMSCA=SVEMSC
+ ISP=MOD(IPROC,100)
+ IF (ISP.EQ.0) THEN
+ IF (GENEV) THEN
+ RANWT=SAVWT(3)*HWR()
+ IF (RANWT.LT.SAVWT(1)) THEN
+ CALL HWHSSQ
+ ELSEIF (RANWT.LT.SAVWT(2)) THEN
+ CALL HWHSSG
+ ELSE
+ CALL HWHSSL
+ ENDIF
+ ELSE
+ CALL HWHSSQ
+ SAVWT(1)=EVWGT
+ CALL HWHSSG
+ SAVWT(2)=SAVWT(1)+EVWGT
+ CALL HWHSSL
+ SAVWT(3)=SAVWT(2)+EVWGT
+ EVWGT=SAVWT(3)
+ ENDIF
+ ELSEIF (ISP.EQ.10) THEN
+ CALL HWHSSQ
+ ELSEIF (ISP.EQ.20) THEN
+ CALL HWHSSG
+ ELSEIF (ISP.EQ.30) THEN
+ CALL HWHSSL
+ ELSE
+C---UNRECOGNIZED PROCESS
+ CALL HWWARN('HWHSSP',500,*999)
+ ENDIF
+ 999 END
+CDECK ID>, HWHSSS.
+*CMZ :- -18/05/99 20.33.45 by Kosuke Odagiri
+*-- Author : Kosuke Odagiri
+C-----------------------------------------------------------------------
+ SUBROUTINE HWHSSS(ID3,R3,ID4,R4,IPERM,IHPR,*)
+C-----------------------------------------------------------------------
+C IDENTIFIES HARD SUSY SUBPROCESS
+C-----------------------------------------------------------------------
+ INCLUDE 'HERWIG61.INC'
+ INTEGER ID3, R3, ID4, R4, IPERM, IHPR, SSL
+ PARAMETER (SSL = 400)
+ IHPRO = 3000 + IHPR
+ IDN(3) = SSL + ID3 + R3*6
+ IDN(4) = SSL + ID4 + R4*6
+ ICO(1) = IPERM/1000
+ ICO(2) = IPERM/100 - 10*ICO(1)
+ ICO(3) = IPERM/10 - 10*(IPERM/100)
+ ICO(4) = IPERM - 10*(IPERM/10)
+ RETURN 1
+ END
+CDECK ID>, HWHV1J.
+*CMZ :- -18/05/99 14.37.45 by Mike Seymour
+*-- Author : Mike Seymour
+C-----------------------------------------------------------------------
+ SUBROUTINE HWHV1J
+C-----------------------------------------------------------------------
+C V + 1 JET PRODUCTION, WHERE V=W (IHPRO.LT.5) OR Z (IHPRO.GE.5).
+C USES CROSS-SECTIONS OF EHLQ FOR ANNIHILATION AND COMPTON SCATTERING
+C IHPRO=0 FOR BOTH, 1 FOR ANNIHILATION, AND 2 FOR COMPTON.
+C-----------------------------------------------------------------------
+ INCLUDE 'HERWIG61.INC'
+ DOUBLE PRECISION HWR,HWRUNI,DISFAC(2,12,2),EMV2,DISMAX,S,T,U,
+ & SHAT,THAT,UHAT,Z,HWUALF,PT,EMT,GFACTR,SIGANN,SIGCOM(2),CSFAC,ET,
+ & EJ,YMIN,YMAX,VYMIN,VYMAX,EMAX,CV,CA,BR,EMV,GAMV
+ INTEGER HWRINT,IDINIT(2,12,2),ICOFLO(4,2),I,J,K,L,M,ID1,ID2,
+ $ IDV,IDI,IDM
+ EXTERNAL HWRINT
+ SAVE DISFAC,SHAT,THAT,EMV,EMV2,IDV,IDI
+C---IDINIT HOLDS THE INITIAL STATES FOR ANNIHILATION PROCESSES
+ DATA IDINIT/1,8,2,7,3,10,4,9,5,12,6,11,1,10,2,9,3,8,4,7,5,12,6,11,
+ $ 1,7,2,8,3,9,4,10,5,11,6,12,1,7,2,8,3,9,4,10,5,11,6,12/
+C---ICOFLO HOLDS THE COLOR FLOW FOR EACH PROCESS
+C---DISFAC HOLDS THE DISTRIBUTION FUNCTION*CROSS-SECTION FOR EACH
+C POSSIBLE SUB-PROCESS.
+C INDEX1=INITIAL STATE PERMUTATION (1=AS IDINIT/QG;2=OPPOSITE/GQ),
+C 2=QUARK (FOR ANNIHILATION, >6 IMPLIES CABIBBO ROTATED PAIR),
+C 3=PROCESS (1=ANNIHILATION, 2=COMPTON)
+ DATA ICOFLO,DISFAC/2,4,3,1,4,1,3,2,48*0./
+ IF (GENEV) THEN
+ DISMAX=0
+ DO 110 I=1,2
+ DO 110 J=1,12
+ DO 110 K=1,2
+ 110 DISMAX=MAX(DISFAC(K,J,I),DISMAX)
+ 120 I=HWRINT(1,2)
+ J=HWRINT(1,12)
+ K=HWRINT(1,2)
+ IF (HWR()*DISMAX.GT.DISFAC(K,J,I)) GOTO 120
+ IF (I.EQ.1) THEN
+C---ANNIHILATION
+ IDN(1)=IDINIT(K,J,IDI)
+ IDN(2)=IDINIT(3-K,J,IDI)
+ IDN(4)=13
+ ELSE
+C---COMPTON SCATTERING
+ IDN(1)=J
+ IDN(2)=13
+ IF (IDV.EQ.200) THEN
+ IDN(4)=J
+ ELSE
+ IF (J.EQ.5.OR.J.EQ.6.OR.J.GE.11.OR.HWR().GT.SCABI) THEN
+C---CHANGE QUARKS (1->2,2->1,3->4,4->3,...)
+ IDN(4)=4*INT((J-1)/2)-J+3
+ ELSE
+C---CHANGE AND CABIBBO ROTATE QUARKS (1->4,2->3,3->2,...)
+ IDN(4)=12*INT((J-1)/6)-J+5
+ ENDIF
+ ENDIF
+ IF ((SQRT(EMV2)+RMASS(IDN(4)))**2.GT.SHAT) GOTO 120
+ IF (K.EQ.2) THEN
+C---SWAP INITIAL STATES
+ IDN(3)=IDN(1)
+ IDN(1)=IDN(2)
+ IDN(2)=IDN(3)
+ ENDIF
+ ENDIF
+ IF (IDV.EQ.200) THEN
+ IDN(3)=200
+ ELSE
+C---W+ OR W-? USE CHARGE CONSERVATION TO WORK OUT
+ IDN(3)=NINT(198.5-.1667*FLOAT(ICHRG(IDN(1))+ICHRG(IDN(2))))
+ ENDIF
+ M=K
+ IF (I.EQ.2.AND.J.LE.6) M=3-K
+ DO 130 L=1,4
+ 130 ICO(L)=ICOFLO(L,M)
+ IDCMF=15
+ COSTH=(SHAT+2*THAT-EMV2)/(SHAT-EMV2)
+C---TRICK HWETWO INTO USING THE OFF-SHELL V MASS
+ RMASS(IDN(3))=SQRT(EMV2)
+ CALL HWETWO
+ RMASS(IDN(3))=EMV
+ RHOHEP(1,NHEP-1)=0.5
+ RHOHEP(2,NHEP-1)=0.0
+ RHOHEP(3,NHEP-1)=0.5
+ ELSE
+ EVWGT=0.
+ IHPRO=MOD(IPROC,100)/10
+ IF (IHPRO.LT.5) THEN
+ IDV=198
+ IDI=1
+ IDM=10
+ GAMV=GAMW
+ ELSE
+ IDV=200
+ IDI=2
+ IDM=6
+ GAMV=GAMZ
+ IHPRO=IHPRO-5
+ ENDIF
+ EMV=RMASS(IDV)
+ EMV2=EMV*(EMV+GAMV*TAN(HWRUNI(0,-ONE-HALF,ONE+HALF)))
+ IF (EMV2.LE.ZERO) RETURN
+ CALL HWRPOW(ET,EJ)
+ PT=0.5*ET
+ EMT=SQRT(PT**2+EMV2)
+ EMAX=0.5*(PHEP(5,3)+EMV2/PHEP(5,3))
+ IF (EMAX.LE.EMT) RETURN
+ VYMAX=0.5*LOG((EMAX+SQRT(EMAX**2-EMT**2))
+ & /(EMAX-SQRT(EMAX**2-EMT**2)))
+ VYMIN=-VYMAX
+ IF (VYMAX.LE.VYMIN) RETURN
+ Z=EXP(HWRUNI(0,VYMIN,VYMAX))
+ S= PHEP(5,3)**2
+ T=-PHEP(5,3)*EMT/Z+EMV2
+ U=-PHEP(5,3)*EMT*Z+EMV2
+ XXMIN=-U/(S+T-EMV2)
+ IF (XXMIN.LT.ZERO.OR.XXMIN.GT.ONE) RETURN
+ YMIN=MAX(LOG((XXMIN*PHEP(5,3)-EMT*Z)/PT),YJMIN)
+ YMAX=MIN(LOG((PHEP(5,3)-EMT*Z)/PT),YJMAX)
+ IF (YMAX.LE.YMIN) RETURN
+ XX(1)=(Z*EMT+EXP(HWRUNI(2,YMIN,YMAX))*PT)/PHEP(5,3)
+ IF (XX(1).LE.ZERO.OR.XX(1).GT.ONE) RETURN
+ THAT =XX(1)*T+(1.-XX(1))*EMV2
+ XX(2)=-THAT / (XX(1)*S+U-EMV2)
+ IF (XX(2).LT.ZERO.OR.XX(2).GT.ONE) RETURN
+ UHAT =XX(2)*U+(1.-XX(2))*EMV2
+ SHAT =XX(1)*XX(2)*S
+ EMSCA=EMT
+ CALL HWSGEN(.FALSE.)
+ GFACTR=GEV2NB*2.*PIFAC*ALPHEM*HWUALF(1,EMSCA)/(9.*SWEIN)
+ SIGANN=GFACTR*((THAT-EMV2)**2+(UHAT-EMV2)**2)
+ & /(SHAT**2*THAT*UHAT)
+ SIGCOM(2)=.375*GFACTR*(SHAT**2+UHAT**2+2*EMV2*THAT)
+ & /(-UHAT*SHAT**3)
+ SIGCOM(1)=.375*GFACTR*(SHAT**2+THAT**2+2*EMV2*UHAT)
+ & /(-THAT*SHAT**3)
+C---IF USER SPECIFIED A SUB-PROCESS, ZERO THE OTHER
+ IF (IHPRO.EQ.1) THEN
+ SIGCOM(1)=0.
+ SIGCOM(2)=0.
+ ENDIF
+ IF (IHPRO.EQ.2) SIGANN=0.
+ DO 210 I=1,IDM
+ IF (IDV.EQ.200) THEN
+ J=I
+ IF(I.GT.6) J=I-6
+ DISFAC(1,I,1)=4*SWEIN*(VFCH(J,1)**2+AFCH(J,1)**2)
+ ELSE
+ IF (I.LE.4) THEN
+ DISFAC(1,I,1)=1-SCABI
+ ELSEIF (I.GE.7) THEN
+ DISFAC(1,I,1)=SCABI
+ ELSE
+ DISFAC(1,I,1)=1.
+ ENDIF
+ ENDIF
+ DISFAC(2,I,1)=DISFAC(1,I,1) *
+ & SIGANN*DISF(IDINIT(1,I,IDI),2)*DISF(IDINIT(2,I,IDI),1)
+ DISFAC(1,I,1)=DISFAC(1,I,1) *
+ & SIGANN*DISF(IDINIT(1,I,IDI),1)*DISF(IDINIT(2,I,IDI),2)
+ 210 CONTINUE
+ DO 211 I=IDM+1,12
+ DISFAC(1,I,1)=0
+ DISFAC(2,I,1)=0
+ 211 CONTINUE
+ DO 220 I=1,12
+ IF (IDV.EQ.200) THEN
+ J=I
+ IF(I.GT.6) J=I-6
+ DISFAC(1,I,2)=4*SWEIN*(VFCH(J,1)**2+AFCH(J,1)**2)
+ ELSE
+ DISFAC(1,I,2)=1.
+ ENDIF
+ DISFAC(2,I,2)=DISFAC(1,I,2)*SIGCOM(2)*DISF(I,2)*DISF(13,1)
+ DISFAC(1,I,2)=DISFAC(1,I,2)*SIGCOM(1)*DISF(I,1)*DISF(13,2)
+ 220 CONTINUE
+ DO 230 I=1,2
+ DO 230 J=1,12
+ DO 230 K=1,2
+ 230 EVWGT=EVWGT+DISFAC(K,J,I)
+ CSFAC=PT*EJ*(YMAX-YMIN)*(VYMAX-VYMIN)*THREE/PIFAC
+C---INCLUDE BRANCHING RATIO OF V
+ CALL HWDBOZ(IDV,ID1,ID2,CV,CA,BR,0)
+ EVWGT=EVWGT*CSFAC*BR
+ ENDIF
+ 999 END
+CDECK ID>, HWHWEX.
+*CMZ :- -26/04/91 14.55.45 by Federico Carminati
+*-- Author : Mike Seymour
+C-----------------------------------------------------------------------
+ SUBROUTINE HWHWEX
+C-----------------------------------------------------------------------
+C TOP QUARK PRODUCTION VIA W EXCHANGE: MEAN EVWGT=TOP PROD C-S IN NB
+C C-S IS SUM OF:
+C UbarBbar, DBbar, DbarB, UB, CbarBbar, SBbar, SbarB, AND CB
+C UNLESS USER SPECIFIES OTHERWISE BY MOD(IPROC,100)=1-8 RESPECTIVELY
+C---DSDCOS HOLDS THE CROSS-SECTIONS FOR THE PROCESSES LISTED ABOVE
+C (1-8) ARE WITH B FROM BEAM 1, (9-16) ARE WITH B FROM BEAM 2.
+C-----------------------------------------------------------------------
+ INCLUDE 'HERWIG61.INC'
+ DOUBLE PRECISION HWR,HWRUNI,DSDCOS(16),EMT2,EMT,EMW2,EMW,
+ & CMFMIN,TAUMIN,TAUMLN,S,T,U,ROOTS,DSMAX
+ INTEGER HWRINT,IDHWEX(2,16),I
+ EXTERNAL HWR,HWRUNI,HWRINT
+ SAVE DSDCOS,DSMAX
+ EQUIVALENCE (EMW,RMASS(198)),(EMT,RMASS(6))
+C---IDHWEX HOLDS THE IDs OF THE INCOMING PARTICLES FOR EACH SUB-PROCESS
+ DATA IDHWEX/11,8,11,1,5,7,5,2,11,10,11,3,5,9,5,4,
+ & 8,11,1,11,7,5,2,5,10,11,3,11,9,5,4,5/
+ EMT2=EMT**2
+ EMW2=EMW**2
+ IF (GENEV) THEN
+ 300 IHPRO=HWRINT(1,16)
+ IF (HWR().GT.DSDCOS(IHPRO)/DSMAX) GOTO 300
+ DO 10 I=1,2
+ IDN(I)=IDHWEX(I,IHPRO)
+ IF (IDN(I).EQ.5 .OR. IDN(I).EQ.11) THEN
+C---CHANGE B QUARK INTO T QUARK
+ IDN(I+2)=IDN(I)+1
+ ELSEIF (HWR().GT.SCABI) THEN
+C---CHANGE QUARKS (1->2,2->1,3->4,4->3,7->8,8->7,...)
+ IDN(I+2)=4*INT((IDN(I)-1)/2)-IDN(I)+3
+ ELSE
+C---CHANGE AND CABIBBO ROTATE QUARKS (1->4,2->3,3->2,4->1,7->10,...)
+ IDN(I+2)=12*INT((IDN(I)-1)/6)-IDN(I)+5
+ ENDIF
+ ICO(I)=I+2
+ ICO(I+2)=I
+ 10 CONTINUE
+ IDCMF=15
+ CALL HWETWO
+ ELSE
+ EVWGT=0.
+ CMFMIN=EMT
+ TAUMIN=(CMFMIN/PHEP(5,3))**2
+ TAUMLN=LOG(TAUMIN)
+ ROOTS=PHEP(5,3)*SQRT(EXP(HWRUNI(0,ZERO,TAUMLN)))
+ XXMIN=(ROOTS/PHEP(5,3))**2
+ XLMIN=LOG(XXMIN)
+ COSTH=HWRUNI(0,-ONE, ONE)
+ S=ROOTS**2
+ T=-0.5*S*(1-COSTH)
+ U=-0.5*S*(1+COSTH)
+ EMSCA=SQRT(2*S*T*U/(S*S+T*T+U*U))
+ DSDCOS(1)=GEV2NB*PIFAC*.125*(ALPHEM/SWEIN)**2
+ & *(S-EMT2)**2 / S / (EMW2 + 0.5*(S-EMT2)*(1-COSTH))**2
+ DSDCOS(2)=DSDCOS(1) / 4
+ & * (1 + EMT2/S + 2*COSTH + (1-EMT2/S)*COSTH**2)
+ DSDCOS(3)=DSDCOS(2)
+ DSDCOS(4)=DSDCOS(1)
+C---IF USER SPECIFIED SUB-PROCESS THEN ZERO ALL THE OTHERS
+ IHPRO=MOD(IPROC,100)
+ IF (IHPRO.GT.8) THEN
+ CALL HWWARN('HWHWEX',1,*999)
+ IHPRO=0
+ ENDIF
+ DO 100 I=1,8
+ IF (I.LE.4) DSDCOS(I+4)=DSDCOS(I)
+ IF (IHPRO.NE.0 .AND. IHPRO.NE.I) DSDCOS(I)=0
+ DSDCOS(I+8)=DSDCOS(I)
+ 100 CONTINUE
+ CALL HWSGEN(.TRUE.)
+ DSMAX=0
+ DO 200 I=1,16
+ DSDCOS(I)=DSDCOS(I)*DISF(IDHWEX(1,I),1)*DISF(IDHWEX(2,I),2)
+ EVWGT=EVWGT + 2*TAUMLN*XLMIN*DSDCOS(I)
+ IF (DSDCOS(I).GT.DSMAX) DSMAX=DSDCOS(I)
+ 200 CONTINUE
+ ENDIF
+ 999 END
+CDECK ID>, HWHWPR.
+*CMZ :- -18/05/99 14.22.13 by Mike Seymour
+*-- Author : Bryan Webber
+C-----------------------------------------------------------------------
+ SUBROUTINE HWHWPR
+C-----------------------------------------------------------------------
+C W+/- PRODUCTION AND DECAY VIA DRELL-YAN PROCESS
+C MEAN EVWGT IS SIG(W+/-)*(BRANCHING FRACTION) IN NB
+C-----------------------------------------------------------------------
+ INCLUDE 'HERWIG61.INC'
+ DOUBLE PRECISION HWR,HWRUNI,HWUPCM,PRAN,PROB,COEF,CSFAC,EMW,
+ & FTQK,PTOP,ETOP,EBOT,PMAX,FHAD,FTOT,BRAF,FLEP,TMIN,HWUAEM
+ INTEGER HWRINT,ICH,IC,IL,ID,IDEC,JDEC,IWP(2,16)
+ LOGICAL HWRLOG
+ EXTERNAL HWR,HWRUNI,HWUPCM,HWRINT,HWRLOG
+ SAVE CSFAC,IDEC,FLEP,FTQK,ETOP,PTOP,EBOT,PMAX,PROB
+ DATA IWP/2,7,1,8,7,2,8,1,4,9,3,10,9,4,10,3,
+ & 2,9,3,8,9,2,8,3,4,7,1,10,7,4,10,1/
+ IF (GENEV) THEN
+C---GENERATE EVENT (X'S AND STRUCTURE FUNCTIONS ALREADY FOUND)
+ PRAN=PROB*HWR()
+C---LOOP OVER PARTON FLAVOURS
+ PROB=0.
+ COEF=1.-SCABI
+ DO 10 IC=1,16
+ IF (IC.EQ.9) COEF=SCABI
+ PROB=PROB+DISF(IWP(1,IC),1)*DISF(IWP(2,IC),2)*COEF
+ IF (PROB.GE.PRAN) GOTO 20
+ 10 CONTINUE
+C---STORE INCOMING PARTONS
+ 20 IDN(1)=IWP(1,IC)
+ IDN(2)=IWP(2,IC)
+ ICO(1)=2
+ ICO(2)=1
+C---ICH=1/2 FOR W+/-
+ ICH=2-MOD(IC,2)
+ IF ((IDEC.GT.49.AND.IDEC.LT.54).OR.
+ & (IDEC.EQ.99.AND.HWRLOG(FLEP))) THEN
+C---LEPTONIC DECAY
+ IL=IDEC-50
+ IF (IL.EQ.0.OR.IL.GT.3) IL=HWRINT(1,3)
+ IDN(3)=2*IL+121-ICH
+ IDN(4)=2*IL+124+ICH
+C---W DECAY ANGLE (1+COSTH)**2
+ COSTH=2.*HWR()**0.3333-1.
+ ELSEIF (IDEC.EQ.5.OR.IDEC.EQ.6.OR.
+ & ((IDEC.EQ.0.OR.IDEC.EQ.99).AND.HWRLOG(FTQK))) THEN
+C---W -> TOP + BOTTOM DECAY
+ IDN(3)=7-ICH
+ IDN(4)=10+ICH
+ 21 COSTH=HWRUNI(1,-ONE, ONE)
+ IF ((ETOP+(PTOP*COSTH))*(EBOT+(PTOP*COSTH)).LT.
+ & PMAX*HWR()) GOTO 21
+ ELSE
+C---OTHER HADRONIC DECAY
+ 25 PROB=0.
+ PRAN=2.*HWR()
+ COEF=1.-SCABI
+ DO 30 ID=ICH,16,4
+ IF (ID.GT.8) COEF=SCABI
+ PROB=PROB+COEF
+ IF (PROB.GE.PRAN) THEN
+ IDN(3)=IWP(1,ID)
+ IDN(4)=IWP(2,ID)
+ GOTO 40
+ ENDIF
+ 30 CONTINUE
+ 40 CONTINUE
+ IF (IDEC.GT.0.AND.IDEC.LT.5) THEN
+ JDEC=IDEC+6
+ IF (IDN(3).NE.IDEC.AND.IDN(4).NE.IDEC
+ & .AND.IDN(3).NE.JDEC.AND.IDN(4).NE.JDEC) GOTO 25
+ ENDIF
+ COSTH=2.*HWR()**0.3333-1.
+ ENDIF
+ IDCMF=197+ICH
+ IF (IDN(1).GT.6) COSTH=-COSTH
+ ICO(3)=4
+ ICO(4)=3
+ CALL HWETWO
+ ELSE
+ IDEC=MOD(IPROC,100)
+ IF (IDEC.EQ.5.OR.IDEC.EQ.6) THEN
+ TMIN=ATAN((RMASS(6)**2-RMASS(199)**2)/(GAMW*RMASS(199)))
+ ELSE
+ TMIN=-ATAN(RMASS(199)/GAMW)
+ ENDIF
+ EVWGT=0.
+ EMW=GAMW*TAN(HWRUNI(0,TMIN,PIFAC/2.))+RMASS(199)
+ IF (EMW.LE.ZERO) RETURN
+ EMW=SQRT(EMW*RMASS(199))
+ IF (EMW.LE.QSPAC.OR.EMW.GE.PHEP(5,3)) RETURN
+ EMSCA=EMW
+ IF (EMLST.NE.EMW) THEN
+ EMLST=EMW
+ XXMIN=(EMW/PHEP(5,3))**2
+ XLMIN=LOG(XXMIN)
+ CSFAC=-GEV2NB*PIFAC**2*HWUAEM(EMSCA**2)
+ & /(3.*SWEIN*RMASS(199)**2)*XLMIN
+C---COMPUTE TOP AND LEPTONIC FRACTIONS
+ FTQK=0.
+ IF (NFLAV.GT.5) THEN
+ PTOP=HWUPCM(EMW,RMASS(5),RMASS(6))
+ IF (PTOP.GT.ZERO) THEN
+ ETOP=SQRT(PTOP**2+RMASS(6)**2)
+ EBOT=EMW-ETOP
+ FTQK=2.*PTOP*(3.*ETOP*EBOT+PTOP**2)/EMW**3
+ PMAX=(ETOP+PTOP)*(EBOT+PTOP)
+ ENDIF
+ ENDIF
+ FHAD=FTQK+2.
+ FTOT=FTQK+3.
+C---MULTIPLY WEIGHT BY BRANCHING FRACTION
+ IF (IDEC.EQ.0) THEN
+ BRAF=FHAD
+ ELSEIF (IDEC.LT.5.OR.IDEC.EQ.50) THEN
+ BRAF=1.
+ ELSEIF (IDEC.LT.7) THEN
+ BRAF=FTQK
+ ELSEIF (IDEC.EQ.99) THEN
+ BRAF=FTOT
+ ELSE
+ BRAF=1/THREE
+ ENDIF
+ CSFAC=CSFAC*BRAF/FTOT*(0.5-TMIN/PIFAC)
+ FTQK=FTQK/FHAD
+ FLEP=1./FTOT
+ ENDIF
+ CALL HWSGEN(.TRUE.)
+C---LOOP OVER PARTON FLAVOURS
+ PROB=0.
+ COEF=1.-SCABI
+ DO 100 IC=1,16
+ IF (IC.EQ.9) COEF=SCABI
+ PROB=PROB+DISF(IWP(1,IC),1)*DISF(IWP(2,IC),2)*COEF
+ 100 CONTINUE
+ EVWGT=PROB*CSFAC
+ ENDIF
+ 999 END
+CDECK ID>, HWIGIN.
+*CMZ :- -01/04/99 19.44.55 by Mike Seymour
+*-- Author : Bryan Webber
+C----------------------------------------------------------------------
+ SUBROUTINE HWIGIN
+C-----------------------------------------------------------------------
+C SETS INPUT PARAMETERS
+C----------------------------------------------------------------------
+ INCLUDE 'HERWIG61.INC'
+ DOUBLE PRECISION FAC,ANGLE
+ INTEGER I,J,N,L
+ CHARACTER*28 TITLE
+ DATA TITLE/'HERWIG 6.100 December 1999'/
+ WRITE (6,10) TITLE
+ 10 FORMAT(//10X,A28//,
+ & 10X,'Please reference: G. Marchesini, B.R. Webber,',/,
+ & 10X,'G.Abbiendi, I.G.Knowles, M.H.Seymour & L.Stanco',/,
+ & 10X,'Computer Physics Communications 67 (1992) 465')
+C---PRINT OPTIONS:
+C IPRINT=0 NO PRINTOUT
+C 1 PRINT SELECTED INPUT PARAMETERS
+C 2 1 + TABLE OF PARTICLE CODES AND PROPERTIES
+C 3 2 + TABLES OF SUDAKOV FORM FACTORS
+ IPRINT=1
+C Format for track numbers in event listing
+C PRNDEC=.TRUE. use decimal
+C .FALSE. use hexadecimal
+ PRNDEC=(NMXHEP.LE.9999)
+C Number of significant figures to print out in event listing
+C NPRFMT (< 2) compact 80 character stout and A4-long tex output,
+C (= 2) 2 decimal places in stout, (> 2) - 5 decimal places in stout
+ NPRFMT=1
+C Print out vertex information
+ PRVTX=.TRUE.
+C Print out particle properties/event record to stout, tex or web
+ PRNDEF=.TRUE.
+ PRNTEX=.FALSE.
+ PRNWEB=.FALSE.
+C---MAX NO OF EVENTS TO PRINT
+ MAXPR=0
+C---UNIT FOR READING SUDAKOV FORM FACTORS (IF ZERO THEN COMPUTE THEM)
+ LRSUD=0
+C---UNIT FOR WRITING SUDAKOV FORM FACTORS (IF ZERO THEN NOT WRITTEN)
+ LWSUD=77
+C---UNIT FOR WRITING EVENT DATA IN HWANAL (IF ZERO THEN NOT WRITTEN)
+ LWEVT=0
+C---SEEDS FOR RANDOM NUMBER GENERATOR (CALLED HWR)
+ NRN(1)= 17673
+ NRN(2)= 63565
+C---AZIMUTHAL CORRELATIONS?
+C THESE INCLUDE SOFT GLUON (INSIDE CONE)
+ AZSOFT=.TRUE.
+C AND NEAREST-NEIGHBOUR SPIN CORRELATIONS
+ AZSPIN=.TRUE.
+C---MATRIX-ELEMENT MATCHING FOR E+E-, DIS, DRELL-YAN AND TOP DECAY
+C---HARD EMISSION
+ HARDME=.TRUE.
+C---SOFT EMISSION
+ SOFTME=.TRUE.
+C---GLUON ENERGY CUT FOR TOP DECAY CASE
+ GCUTME=2
+C Electromagnetic fine structure constant: Thomson limit
+ ALPHEM=.0072993
+C---QCD LAMBDA: CORRESPONDS TO 5-FLAVOUR LAMBDA-MS-BAR AT LARGE X ONLY
+ QCDLAM=0.18
+C---NUMBER OF COLOURS
+ NCOLO=3
+C---NUMBER OF FLAVOURS
+ NFLAV=6
+C---QUARK, GLUON AND PHOTON VIRTUAL MASS CUTOFFS IN
+C PARTON SHOWER (ADDED TO MASSES GIVEN BELOW)
+ VQCUT=0.48
+ VGCUT=0.10
+ VPCUT=0.40
+ ALPFAC=1
+C---D,U,S,C,B,T QUARK AND GLUON MASSES (IN THAT ORDER)
+ RMASS(1)=0.32
+ RMASS(2)=0.32
+ RMASS(3)=0.5
+ RMASS(4)=1.55
+ RMASS(5)=4.95
+ RMASS(6)=175.
+ RMASS(13)=0.75
+C---W+/- AND Z0 MASSES
+ RMASS(198)=80.4
+ RMASS(199)=80.4
+ RMASS(200)=91.2
+C---HIGGS BOSON MASS
+ RMASS(201)=150.
+C---WIDTHS OF W, Z, HIGGS
+ GAMW=2.0
+ GAMZ=2.5
+ GAMH=0.02
+C Include additional neutral, massive vector boson (Z')
+ ZPRIME=.FALSE.
+C Z' mass and width
+ RMASS(202)=500.
+ GAMZP=5.
+C Lepton (EPOLN) and anti-lepton (PPOLN) beam polarisations used in:
+C e+e- --> ffbar/qqbar g; and l/lbar N DIS.
+C Cpts. 1,2 Transverse polarisation; cpt. 3 longitudinal polarisation.
+C Note require POLN(1)**2+POLN(2)**2+POLN(3)**2 < 1.
+ DO 20 I=1,3
+ EPOLN(I)=0.
+ 20 PPOLN(I)=0.
+C-----------------------------------------------------------------------
+C Specify couplings of weak vector bosons to fermions:
+C
+C electric current: QFCH(I)*e*G_mu (electric charge, e>0)
+C weak neutral current: [VFCH(I,J).1+AFCH(I,J).G_5]*e*G_mu
+C weak charged current: SQRT(VCKM(K,L)/2.)*g*(1+G_5)*G_mu
+C
+C I= 1- 6: d,u,s,c,b,t (quarks)
+C =11-16: e,nu_e,mu,nu_mu,tau,nu_tau (leptons) (`I=IDHW-110')
+C J=1 for minimal SM:
+C =2 for Z' couplings (ZPRIME=.TRUE.)
+C K=1,2,3 for u,c,t; L=1,2,3 for d,s,b
+C-----------------------------------------------------------------------
+C Minimal standard model neutral vector boson couplings
+C VFCH(I,1)=(T3/2-Q*S^2_W)/(C_W*S_W); AFCH(I,1)=T3/(2*C_W*S_W)
+C sin**2 Weinberg angle (PDG '94)
+ SWEIN=.2319
+ FAC=1./SQRT(SWEIN*(1.-SWEIN))
+ DO 30 I=1,3
+C Down-type quarks
+ J=2*I-1
+ QFCH(J)=-1./3.
+ VFCH(J,1)=(-0.25+SWEIN/3.)*FAC
+ AFCH(J,1)= -0.25*FAC
+C Up-type quarks
+ J=2*I
+ QFCH(J)=+2./3.
+ VFCH(J,1)=(+0.25-2.*SWEIN/3.)*FAC
+ AFCH(J,1)= +0.25*FAC
+C Charged leptons
+ J=2*I+9
+ QFCH(J)=-1.
+ VFCH(J,1)=(-0.25+SWEIN)*FAC
+ AFCH(J,1)= -0.25*FAC
+C Neutrinos
+ J=2*I+10
+ QFCH(J)=0.
+ VFCH(J,1)=+0.25*FAC
+ AFCH(J,1)=+0.25*FAC
+ 30 CONTINUE
+C Additional Z' couplings (To be set by the user)
+ IF (.NOT.ZPRIME) THEN
+ DO 40 I=1,6
+ AFCH(I,2)=0.
+ AFCH(10+I,2)=0.
+ VFCH(I,2)=0.
+ VFCH(10+I,2)=0.
+ 40 CONTINUE
+ ENDIF
+C Cabibbo-Kobayashi-Maskawa matrix elements squared (PDG '92):
+C sin**2 of Cabibbo angle
+ SCABI=.0488
+C u ---> d,s,b
+ VCKM(1,1)=1.-SCABI
+ VCKM(1,2)=SCABI
+ VCKM(1,3)=0.0
+C c ---> d,s,b
+ VCKM(2,1)=SCABI
+ VCKM(2,2)=1.-SCABI-.002
+ VCKM(2,3)=0.002
+C t ---> d,b,s
+ VCKM(3,1)=0.0
+ VCKM(3,2)=0.002
+ VCKM(3,3)=0.998
+C---GAUGE BOSON DECAYS
+ DO 50 I=1,12
+ BRHIG(I)=1.D0/12
+ ENHANC(I)=1.D0
+ 50 IF (I.LE.MODMAX) MODBOS(I)=0
+C
+C THE iTH GAUGE BOSON DECAY PER EVENT IS CONTROLLED BY MODBOS AS FOLLOWS
+C MODBOS(i) W DECAY Z DECAY
+C 0 all all
+C 1 qqbar qqbar
+C 2 enu e+e-
+C 3 munu mu+mu-
+C 4 taunu tau+tau-
+C 5 enu & munu ee & mumu
+C 6 all nunu
+C 7 all bbbar
+C >7 all all
+C BOSON PAIRS (eg FROM HIGGS DECAY) ARE CHOSEN FROM MODBOS(i),MODBOS(i+1
+C
+C---CONTROL OF LARGE EMH BEHAVIOUR (SEE HWHIGM FOR DETAILS)
+ IOPHIG=3
+ GAMMAX=10.
+C Specicify approximation used in HWHIGA
+ IAPHIG=1
+C---MASSES OF HYPOTHETICAL NEW QUARKS GO
+C INTO 209-214 (ANTIQUARKS IN 215-220)
+C ID = 209,210 ARE B',T' WITH DECAYS T'->B'->C
+C 211,212 ARE B',T' WITH DECAYS T'->B'->T
+C 215-218 ARE THEIR ANTIQUARKS
+ RMASS(209)=200.
+ RMASS(215)=200.
+C---MAXIMUM CLUSTER MASS PARAMETERS
+C N.B. LIMIT FOR Q1-Q2BAR CLUSTER MASS
+C IS (CLMAX**CLPOW + (QM1+QM2)**CLPOW)**(1/CLPOW)
+ CLMAX=3.35
+ CLPOW=2.0
+C For PSPLT(I), CLDIR(I) & CLSMR(I): I=1 light u,d,s,c cluster
+C =2 heavy b cluster
+C---MASS SPECTRUM OF PRODUCTS IN CLUSTER
+C SPLITTING ABOVE CLMAX - FLAT IN M**PSPLT(*)
+ PSPLT(1)=1.0
+ PSPLT(2)=PSPLT(1)
+C---KINEMATIC TREATMENT OF CLUSTER DECAY
+C 0=ISOTROPIC, 1=REMEMBER DIRECTION OF PERTURBATIVELY PRODUCED QUARKS
+ CLDIR(1)=1
+ CLDIR(2)=CLDIR(1)
+C IF CLDIR(*)=1, DO GAUSSIAN SMEARING OF DIRECTION:
+C ACTUALLY EXPONENTIAL IN 1-COS(THETA) WITH MEAN CLSMR(*)
+ CLSMR(1)=0.0
+ CLSMR(2)=CLSMR(1)
+C---OPTION FOR TREATMENT OF REMNANT CLUSTERS:
+C 0=BOTH CHILDREN ARE SOFT, (EQUIVALENT TO PREVIOUS VERSIONS)
+C 1=REMNANT CHILD IS SOFT, BUT PERTURBATIVE CHILD IS NORMAL
+ IOPREM=1
+C---TREATMENT OF LOWER LIMIT FOR SPACELIKE EVOLUTION
+C 0=EVOLUTION STOPS AT QSPAC, BUT STRUCT FUNS CAN GET CALLED AT
+C SMALLER SCALES IN FORCED EMISSION (EQUIVALENT TO V5.7 AND EARLIER)
+C 1=EVOLUTION STOPS AT QSPAC, STRUCTURE FUNCTIONS FREEZE AT QSPAC
+C 2=EVOLUTION CONTINUES TO INFRARED CUT, BUT S.F.S FREEZE AT QSPAC
+ ISPAC=0
+C---LOWER LIMIT FOR SPACELIKE EVOLUTION
+ QSPAC=2.5
+C---SWITCH OFF SPACE-LIKE SHOWERS
+ NOSPAC=.FALSE.
+C---INTRINSIC PT OF SPACELIKE PARTONS (RMS)
+ PTRMS=0.0
+C---MASS PARAMETER IN REMNANT FRAGMENTATION
+ BTCLM=1.0
+C---STRUCTURE FUNCTION SET:
+C SET MODPDF(I)=MODE AND AUTPDF='AUTHOR GROUP' TO USE CERN LIBRARY
+C PDFLIB PACKAGE FOR STRUCTURE FUNCTIONS IN BEAM I
+ MODPDF(1)=-1
+ MODPDF(2)=-1
+ AUTPDF(1)='MRS'
+ AUTPDF(2)='MRS'
+C OR SET MODPDF(I)=-1 TO USE BUILT-IN STRUCTURE FUNCTION SET:
+C 1,2 FOR DUKE+OWENS SETS 1,2 (SOFT/HARD GLUE)
+C 3,4 FOR EICHTEN+AL SETS 1,2 (NUCLEONS ONLY)
+C 5 FOR OWENS SET 1.1 (SOFT GLUE ONLY)
+ NSTRU=5
+C PARAMETER FOR B CLUSTER DECAY TO 1 HADRON. IF MCL IS CLUSTER MASS
+C AND MTH IS THRESHOLD FOR 2-HADRON DECAY, THEN PROBABILITY IS
+C 1 IF MCL<MTH, 0 IF MCL>(1+B1LIM)*MTH, WITH LINEAR INTERPOLATION,
+ B1LIM=0.0
+C---B DECAY PACKAGE ('HERW'=>HERWIG, 'EURO'=>EURODEC, 'CLEO'=>CLEO)
+ BDECAY='HERW'
+C---HARD SUBPROCESS SCALE TO BE USED IN BOSON-GLUON FUSION
+C IF (BGSHAT) THEN SCALE=SHAT
+C ELSE SCALE=2.*SHAT*THAT*UHAT/(SHAT**2+THAT**2+UHAT**2)
+ BGSHAT=.FALSE.
+C---RECONSTRUCT DIS EVENTS IN BREIT FRAME
+ BREIT=.TRUE.
+C---TREAT ALL EVENTS IN THEIR CMF (ELSE USE LAB FRAME)
+ USECMF=.TRUE.
+C---PROBABILITY OF UNDERLYING SOFT EVENT:
+ PRSOF=1.
+C---SOFT UNDERLYING OR MIN BIAS EVENT PARAMETERS
+C DEFAULT VALUES ARE FROM UA5 COLLAB, NPB291(1987)445
+C NCH_PPBAR(SQRT(S)) = PMBN1*S**PMBN2+PMBN3
+ PMBN1= 9.11
+ PMBN2= 0.115
+ PMBN3=-9.50
+C 1/K (IN NEG BINOMIAL) = PMBK1*LN(S)+PMBK2
+ PMBK1= 0.029
+ PMBK2=-0.104
+C SOFT CLUSTER MASS SPECTRUM (M-M1-M2-PMBM1)*EXP(-PMBM2*M)
+ PMBM1= 0.4
+ PMBM2= 2.0
+C SOFT CLUSTER PT SPECTRUM PT*EXP(-B*SQRT(PT**2+M**2))
+C B=PMBP1 FOR D,U, PMBP2 FOR S,C, PMBP3 FOR DIQUARKS
+ PMBP1= 5.2
+ PMBP2= 3.0
+ PMBP3= 5.2
+C---MULTIPLICITY ENHANCEMENT FOR UNDERLYING SOFT EVENT:
+C NCH = NCH_PPBAR(ENSOF*SQRT(S))
+ ENSOF=1.
+C PARAMETERS FOR MUELLER TANG FORMUA: IPROC=2400
+C---THE VALUE TO USE FOR FIXED ALPHA_S IN DENOMINATOR
+ ASFIXD=0.25
+C---OMEGA0=12*LOG(2)*ALPHA_S/PI, BUT NOT NECESSARILY THE SAME ALPHA_S
+ OMEGA0=0.3
+C---MIN AND MAX JET RAPIDITIES IN QCD 2->2,
+C HEAVY FLAVOUR, SUSY AND DIRECT PHOTON PROCESSES
+ YJMAX=8.
+ YJMIN=-YJMAX
+C---MIN AND MAX PARTON TRANSVERSE MOMENTUM
+C IN ELEMENTARY 2 -> 2 SUBPROCESSES
+ PTMIN=1D1
+ PTMAX=1D8
+C---UPPER LIMIT ON HARD PROCESS SCALE
+ QLIM=1D8
+C---MAX PARTON THRUST IN 2->3 HARD PROCESSES
+ THMAX=0.9
+C Set parameters for 2->4 hard process
+C Choose inter-jet metric (else JADE) and minimum y-cut
+ DURHAM=.TRUE.
+ Y4JT=0.01
+C---TREATMENT OF COLOUR INTERFERENCE IN E+E- -> 4 JETS:
+C qqbar-gg case:
+C IOP4JT(1)=0 neglect, =1 extreme 2341; =2 extreme 3421
+C qqbar-qqbar (identical quark flavour) case:
+C IOP4JT(2)=0 neglect, =1 extreme 4123; =2 extreme 2143
+ IOP4JT(1)=0
+ IOP4JT(2)=0
+C---MIN AND MAX DILEPTON INVARIANT MASS IN DRELL-YAN PROCESS
+ EMMIN=0D0
+ EMMAX=1D8
+C---MIN AND MAX ABS(Q**2) IN DEEP INELASTIC LEPTON SCATTERING
+ Q2MIN=0D0
+ Q2MAX=1D10
+C---MIN AND MAX ABS(Q**2) IN WEISZACKER-WILLIAMS APPROXIMATION
+ Q2WWMN=0.
+ Q2WWMX=4.
+C---MIN AND MAX ENERGY FRACTION IN WEISZACKER-WILLIAMS APPROXIMATION
+ YWWMIN=0.
+ YWWMAX=1.
+C---MINIMUM HADRONIC MASS FOR PHOTON-INDUCED PROCESSES (INCLUDING DIS)
+ WHMIN=0.
+C---IF PHOMAS IS NON-ZERO, PARTON DISTRIBUTION FUNCTIONS FOR OFF-SHELL
+C PHOTONS IS DAMPED, WITH MASS PARAMETER = PHOMAS
+ PHOMAS=0.
+C---MIN AND MAX FLAVOURS GENERATED BY IPROC=9100,9110,9130
+ IFLMIN=1
+ IFLMAX=5
+C---MAX Z IN J/PSI PHOTO- AND ELECTRO- PRODUCTION
+ ZJMAX=0.9
+C---MIN AND MAX BJORKEN-Y
+ YBMIN=0.
+ YBMAX=1.
+C---MAX COS(THETA) FOR W'S IN E+E- -> W+W-
+ CTMAX=0.9999
+C Minimum virtuality^2 of partons to use in calculating distances
+ VMIN2=0.1
+C Exageration factor for lifetimes of weakly decaying heavy particles
+ EXAG=1.
+C Include colour rearrangement in cluster formation
+ CLRECO=.FALSE.
+C Probability for colour rearrangement to occur
+ PRECO=1./9.
+C Minimum lifetime for particle to be considered stable
+ PLTCUT=1.D-8
+C Incude neutral B-meson mixing
+ MIXING=.TRUE.
+C Set B_s and B_d mixing parameters: X=Delta m/Gamma
+ XMIX(1)=10.0
+ XMIX(2)=0.70
+C Y=Delta Gamma/2*Gamma
+ YMIX(1)=0.2
+ YMIX(2)=0.0
+C Include a cut on particle decay lengths
+ MAXDKL=.FALSE.
+C Set option for decay length cut (see HWDXLM)
+ IOPDKL=1
+C Smear the primary interaction vertex: see HWRPIP for details
+ PIPSMR=.TRUE.
+ DO 60 I=0,NMXRES
+C Veto cluster decays into particle type I
+ VTOCDK(I)=.FALSE.
+C Veto unstable particle decays into modes involving particle type I
+ 60 VTORDK(I)=.FALSE.
+C Veto f_0(980) and a_0(980) production in cluster decays
+ VTOCDK(290)=.TRUE.
+ VTOCDK(291)=.TRUE.
+ VTOCDK(292)=.TRUE.
+ VTOCDK(293)=.TRUE.
+C---MINIMUM AND MAXIMUM S-HAT/S RANGE FOR PHOTON ISR
+ TMNISR=1D-4
+ ZMXISR=1-1D-6
+C---COLISR IS .TRUE. TO MAKE ISR PHOTONS COLLINEAR WITH BEAMS
+ COLISR=.FALSE.
+C A Priori weights for mesons w.r.t. pionic n=1, 0-(+) states:
+C old VECWT=REPWT(0,1,0) & TENWT=REPWT(0,2,0)
+ DO 70 N=0,4
+ DO 70 J=0,4
+ DO 70 L=0,3
+ 70 REPWT(L,J,N)=1.
+C and singlet (Lambda-like) and decuplet barons
+ SNGWT=1.
+ DECWT=1.
+C---A PRIORI WEIGHTS FOR D,U,S,C,B,T QUARKS AND DIQUARKS (IN THAT ORDER)
+ PWT(1)=1.
+ PWT(2)=1.
+ PWT(3)=1.
+ PWT(4)=1.
+ PWT(5)=1.
+ PWT(6)=1.
+ PWT(7)=1.
+C Octet-Singlet isoscalar mixing angles in degrees
+C (use ANGLE for ideal mixing, recommended for F0MIX & OMHMIX)
+ ANGLE=ATAN(ONE/SQRT(TWO))*180./ACOS(-ONE)
+C eta - eta'
+ ETAMIX=-23.
+C phi - omega
+ PHIMIX=+36.
+C h_1(1380) - h_1(1170)
+ H1MIX=ANGLE
+C MISSING - f_0(1370)
+ F0MIX=ANGLE
+C f_1(1420) - f_1(1285)
+ F1MIX=ANGLE
+C f'_2 - f_2
+ F2MIX=+26.
+C MISSING - omega(1600)
+ OMHMIX=ANGLE
+C eta_2(1645) - eta_2(1870)
+ ET2MIX=ANGLE
+C phi_3 - omega_3
+ PH3MIX=+28.
+C---PARAMETERS FOR NON-PERTURBATIVE SPLITTING OF GLUONS INTO
+C DIQUARK-ANTIDIQUARK PAIRS:
+C SCALE AT WHICH GLUONS CAN BE SPLIT INTO DIQUARKS
+C (0.0 FOR NO SPLITTING)
+ QDIQK=0.0
+C PROBABILITY (PER UNIT LOG SCALE) OF DIQUARK SPLITTING
+ PDIQK=5.0
+C---PARAMETERS FOR IMPORTANCE SAMPLING
+C ASSUME QCD 2->2 DSIG/DET FALLS LIKE ET**(-PTPOW)
+C WHERE ET=SQRT(MQ**2+PT**2) FOR HEAVY FLAVOURS
+ PTPOW=4.
+C DEFAULT PTPOW=2 FOR SUSY PROCESSES
+ IF (MOD(IPROC/100,100).EQ.30) PTPOW=2.
+C ASSUME DRELL-YAN DSIG/DEM FALLS LIKE EM**(-EMPOW)
+ EMPOW=4.
+C ASSUME DEEP INELASTIC DSIG/DQ**2 FALLS LIKE (Q**2)**(-Q2POW)
+ Q2POW=2.5
+C---GENERATE UNWEIGHTED EVENTS (EVWGT=AVWGT)?
+ NOWGT=.TRUE.
+C---DEFAULT MEAN EVENT WEIGHT
+ AVWGT=1.
+C---ASSUMED MAXIMUM WEIGHT (ZERO TO RECOMPUTE)
+ WGTMAX=0.
+C---MINIMUM ACCEPTABLE EVENT GENERATION EFFICIENCY
+ EFFMIN=1E-3
+C---MAX NO OF (CODE.GE.100) ERRORS
+ MAXER=10
+C---TIME (SEC) NEEDED TO TERMINATE GRACEFULLY
+ TLOUT=5.
+C---CURRENT NO OF EVENTS
+ NEVHEP=0
+C---CURRENT NO OF ENTRIES IN /HEPEVT/
+ NHEP=0
+C---ISTAT IS STATUS OF EVENT (I.E. STAGE IN PROCESSING)
+ ISTAT=0
+C---IERROR IS ERROR CODE
+ IERROR=0
+C---MORE TECHNICAL PARAMETERS - SHOULDN'T NEED ADJUSTMENT
+C---PI
+ PIFAC=ACOS(-1.D0)
+C Speed of light (mm/s)
+ CSPEED=2.99792D11
+C Cross-section conversion factor (hbar.c/e)**2
+ GEV2NB=389380
+C---NUMBER OF SHOTS FOR INITIAL MAX WEIGHT SEARCH
+ IBSH=10000
+C---RANDOM NO. SEEDS FOR INITIAL MAX WEIGHT SEARCH
+ IBRN(1)=1246579
+ IBRN(2)=8447766
+C---NUMBER OF ENTRIES IN LOOKUP TABLES OF SUDAKOV FORM FACTORS
+ NQEV=1024
+C---MAXIMUM BIN SIZE IN Z FOR SPACELIKE BRANCHING
+ ZBINM=0.05
+C---MAXIMUM NUMBER OF Z BINS FOR SPACELIKE BRANCHING
+ NZBIN=100
+C---MAXIMUM NUMBER OF BRANCH REJECTIONS (TO AVOID INFINITE LOOPS)
+ NBTRY=200
+C---MAXIMUM NUMBER OF TRIES TO GENERATE CLUSTER DECAY
+ NCTRY=200
+C---MAXIMUM NUMBER OF TRIES TO GENERATE MASS REQUESTED
+ NETRY=200
+C---MAXIMUM NUMBER OF TRIES TO GENERATE SOFT SUBPROCESS
+ NSTRY=200
+C---PRECISION FOR GAUSSIAN INTEGRATION
+ ACCUR=1.D-6
+C---ORDER OF INTERPOLATION IN SUDAKOV TABLES
+ INTER=3
+C---ORDER TO USE FOR ALPHAS IN SUDAKOV TABLES
+ SUDORD=1
+C--CONSERVATION OF RPARITY
+ RPARTY = .TRUE.
+C--CHECK WHETHER SUSY DATA INPUTTED
+ SUSYIN=.FALSE.
+ 999 END
+CDECK ID>, HWIODK.
+*CMZ :- -27/07/99 13.33.03 by Mike Seymour
+*-- Author : Ian Knowles
+C-----------------------------------------------------------------------
+ SUBROUTINE HWIODK(IUNIT,IOPT,IME)
+C-----------------------------------------------------------------------
+C If IUNIT > 0 writes out present HERWIG decay tables to unit IUNIT
+C < 0 reads in decay tables from unit IUNIT
+C The format used during the read/write is specified by IOPT
+C =1 PDG; =2 HERWIG numeric; =3 HERWIG character name.
+C When reading in if IME =1 matrix element codes >= 100 are accepted
+C 0 are set zero.
+C-----------------------------------------------------------------------
+ INCLUDE 'HERWIG61.INC'
+ INTEGER IUNIT,IOPT,IME,JUNIT,I,J,K,L,IDKY,ITMP(5),IDUM
+ CHARACTER*8 CDK(NMXDKS),CDKPRD(5,NMXDKS),CDUM
+ JUNIT=ABS(IUNIT)
+ OPEN(UNIT=JUNIT,FORM='FORMATTED',STATUS='UNKNOWN')
+ IF (IUNIT.GT.0) THEN
+C Write out the decay table
+ WRITE(JUNIT,100) NDKYS
+ IF (IOPT.EQ.1) THEN
+ DO 20 I=1,NRES
+ IF (NMODES(I).EQ.0) GOTO 20
+ K=LSTRT(I)
+ DO 10 J=1,NMODES(I)
+ WRITE(JUNIT,110) IDPDG(I),BRFRAC(K),NME(K),
+ & (IDPDG(IDKPRD(L,K)),L=1,5)
+ 10 K=LNEXT(K)
+ 20 CONTINUE
+ ELSEIF (IOPT.EQ.2) THEN
+ DO 40 I=1,NRES
+ IF (NMODES(I).EQ.0) GOTO 40
+ K=LSTRT(I)
+ DO 30 J=1,NMODES(I)
+ WRITE(JUNIT,120) I,BRFRAC(K),NME(K),(IDKPRD(L,K),L=1,5)
+ 30 K=LNEXT(K)
+ 40 CONTINUE
+ ELSEIF (IOPT.EQ.3) THEN
+ DO 60 I=1,NRES
+ IF (NMODES(I).EQ.0) GOTO 60
+ K=LSTRT(I)
+ DO 50 J=1,NMODES(I)
+ WRITE(JUNIT,130) RNAME(I),BRFRAC(K),NME(K),
+ & (RNAME(IDKPRD(L,K)),L=1,5)
+ 50 K=LNEXT(K)
+ 60 CONTINUE
+ ENDIF
+ ELSEIF (IUNIT.LT.0) THEN
+C Read in the decay table and convert to HERWIG numeric format
+ READ(JUNIT,100) NDKYS
+ IF (NDKYS.GT.NMXDKS) CALL HWWARN('HWIODK',100,*999)
+ IF (IOPT.EQ.1) THEN
+ DO 70 I=1,NDKYS
+ READ(JUNIT,110) IDKY,BRFRAC(I),NME(I),ITMP
+ IF (IME.EQ.0.AND.NME(I).GE.100) NME(I)=0
+ CALL HWUIDT(1,IDKY,IDK(I),CDUM)
+ DO 70 J=1,5
+ 70 CALL HWUIDT(1,ITMP(J),IDKPRD(J,I),CDUM)
+ ELSEIF (IOPT.EQ.2) THEN
+ DO 80 I=1,NDKYS
+ READ(JUNIT,120) IDK(I),BRFRAC(I),NME(I),(IDKPRD(J,I),J=1,5)
+ IF (IDK(I).LT.0.OR.IDK(I).GT.NRES) IDK(I)=20
+ 80 IF (IME.EQ.0.AND.NME(I).GE.100) NME(I)=0
+ ELSEIF (IOPT.EQ.3) THEN
+ DO 90 I=1,NDKYS
+ READ(JUNIT,130) CDK(I),BRFRAC(I),NME(I),(CDKPRD(J,I),J=1,5)
+ IF (IME.EQ.0.AND.NME(I).GE.100) NME(I)=0
+ CALL HWUIDT(3,IDUM,IDK(I),CDK(I))
+ DO 90 J=1,5
+ 90 CALL HWUIDT(3,IDUM,IDKPRD(J,I),CDKPRD(J,I))
+ ELSE
+ CALL HWWARN('HWIODK',101,*999)
+ ENDIF
+ ENDIF
+ CLOSE(UNIT=JUNIT)
+ 100 FORMAT(1X,I4)
+ 110 FORMAT(1X,I7,1X,F7.5,1X,I3,5(1X,I7))
+ 120 FORMAT(1X,I3,1X,F7.5,6(1X,I3))
+ 130 FORMAT(1X,A8,1X,F7.5,1X,I3,5(1X,A8))
+ 999 RETURN
+ END
+CDECK ID>, HWISSP.
+*CMZ :- -20/10/99 09:46:43 by Peter Richardson
+*-- Author : Bryan Webber, modified by Kosuke Odagiri
+C-----------------------------------------------------------------------
+ SUBROUTINE HWISSP(LRSUSY)
+C-----------------------------------------------------------------------
+C Reads in SUSY particle properties and decays,
+C in format generated by ISAWIG
+C-----------------------------------------------------------------------
+ INCLUDE 'HERWIG61.INC'
+ INTEGER I,J,K,IH,IHW,NSSP,NDEC,MDKYS,LRSUSY
+ DOUBLE PRECISION BETAH, WEINCOS,WEINSIN, MW,MZ, RMMAX
+ DOUBLE PRECISION FTM,FTMUU(4),FTMDD(4),FTMTT(4),FTMBB(4),FTMU,FTMD
+ DOUBLE PRECISION YTM,YTM1,DTERM(4), SQHF,SNBCSB,MZSW2
+ LOGICAL FIRST
+ EQUIVALENCE (MW,RMASS(198)), (MZ,RMASS(200))
+ DATA FIRST/.TRUE./
+ SAVE MDKYS
+ IF (FIRST) THEN
+ MDKYS=NDKYS
+ FIRST=.FALSE.
+ ELSE
+ NDKYS=MDKYS
+ ENDIF
+C--reset susy input flag
+ IF (LRSUSY.LT.0) CALL HWWARN('HWISSP',500,*999)
+ SUSYIN = .TRUE.
+C
+C Input SUSY particle + top quark table
+C
+ WRITE (6,10) LRSUSY
+ 10 FORMAT (10X,'Reading in SUSY data from unit',I3)
+ READ (LRSUSY,'(I4)') NSSP
+ IF (NSSP.LE.0) RETURN
+ RMMAX=SQRT(HALF*(EBEAM1*EBEAM2+PBEAM1*PBEAM2))
+ RMMNSS=RMMAX
+ DO I=1,NSSP
+ READ (LRSUSY,1) IHW,RMASS(IHW),RLTIM(IHW)
+C Negative gaugino mass means physical field is gamma_5*psi
+C Store the signs
+ IF ((IHW.GE.450).AND.(IHW.LE.457)) THEN
+ IF (IHW.LE.453) THEN
+ J=IHW-449
+ ZSGNSS(J)=RMASS(IHW)/ABS(RMASS(IHW))
+ ELSEIF (IHW.LE.455) THEN
+ J=IHW-453
+ WSGNSS(J)=RMASS(IHW)/ABS(RMASS(IHW))
+ ENDIF
+ RMASS(IHW)=ABS(RMASS(IHW))
+ ENDIF
+ IF (ABS(IDPDG(IHW)).GT.1000000.AND.(RMASS(IHW).NE.ZERO))
+ & RMMNSS=MIN(RMMNSS,RMASS(IHW))
+ IF (IHW.GT.NRES) THEN
+ IF (IHW.GT.NMXRES) CALL HWWARN('HWISSP',501,*999)
+ NRES=IHW
+ ENDIF
+ ENDDO
+ XLMNSS=TWO*LOG(RMMNSS/RMMAX)
+ 1 FORMAT(I5,F12.4,E15.5)
+C
+C Input decay modes
+C
+ DO I=1,NSSP
+ READ (LRSUSY,'(I4)') NDEC
+ IF (NDEC.GT.0) THEN
+ DO J=1,NDEC
+ NDKYS=NDKYS+1
+ IF (NDKYS.GT.NMXDKS) CALL HWWARN('HWISSP',100,*999)
+ READ (LRSUSY,11) IDK(NDKYS),BRFRAC(NDKYS),NME(NDKYS),
+ & (IDKPRD(K,NDKYS),K=1,5)
+ 11 FORMAT(I6,F16.8,6I6)
+ ENDDO
+ ENDIF
+ ENDDO
+C
+C Mixings and other SUSY parameters
+C
+ READ (LRSUSY,'(2F16.8)') TANB,ALPHAH
+ DO I=1,4
+ READ (LRSUSY,13) ZMXNSS(I,1),ZMXNSS(I,2),ZMXNSS(I,3),ZMXNSS(I,4)
+ END DO
+ WEINSIN = SQRT(SWEIN)
+ WEINCOS = SQRT(1.-SWEIN)
+ DO I=1,4
+ ZMIXSS(I,1) = WEINCOS*ZMXNSS(I,1)+WEINSIN*ZMXNSS(I,2)
+ ZMIXSS(I,2) = -WEINSIN*ZMXNSS(I,1)+WEINCOS*ZMXNSS(I,2)
+ ZMIXSS(I,3) = ZMXNSS(I,3)
+ ZMIXSS(I,4) = ZMXNSS(I,4)
+ END DO
+ DO J=1,16
+ IF ((J.LE.6).OR.(J.GE.11)) THEN
+ LFCH(J)=VFCH(J,1)+AFCH(J,1)
+ RFCH(J)=VFCH(J,1)-AFCH(J,1)
+ DO I=1,4
+ SLFCH(J,I)= ZMIXSS(I,1)*QFCH(J)+ZMIXSS(I,2)*LFCH(J)
+ SRFCH(J,I)=-ZMIXSS(I,1)*QFCH(J)-ZMIXSS(I,2)*RFCH(J)
+ END DO
+ ENDIF
+ END DO
+ READ (LRSUSY,13) WMXVSS(1,1),WMXVSS(1,2), WMXVSS(2,1),WMXVSS(2,2)
+ READ (LRSUSY,13) WMXUSS(1,1),WMXUSS(1,2), WMXUSS(2,1),WMXUSS(2,2)
+ READ (LRSUSY,'(3F16.8)') THETAT,THETAB,THETAL
+ READ (LRSUSY,'(3F16.8)') ATSS,ABSS,ALSS
+ READ (LRSUSY,'( F16.8)') MUSS
+ DO I=1,6
+ QMIXSS(I,1,1)=1.
+ QMIXSS(I,1,2)=0.
+ QMIXSS(I,2,1)=0.
+ QMIXSS(I,2,2)=1.
+ LMIXSS(I,1,1)=1.
+ LMIXSS(I,1,2)=0.
+ LMIXSS(I,2,1)=0.
+ LMIXSS(I,2,2)=1.
+ END DO
+ QMIXSS(6,1,1)= COS(THETAT)
+ QMIXSS(6,1,2)= SIN(THETAT)
+ QMIXSS(6,2,1)=-QMIXSS(6,1,2)
+ QMIXSS(6,2,2)= QMIXSS(6,1,1)
+ QMIXSS(5,1,1)= COS(THETAB)
+ QMIXSS(5,1,2)= SIN(THETAB)
+ QMIXSS(5,2,1)=-QMIXSS(5,1,2)
+ QMIXSS(5,2,2)= QMIXSS(5,1,1)
+ LMIXSS(5,1,1)= COS(THETAL)
+ LMIXSS(5,1,2)= SIN(THETAL)
+ LMIXSS(5,2,1)=-LMIXSS(5,1,2)
+ LMIXSS(5,2,2)= LMIXSS(5,1,1)
+C--Evaluating Higgs parameters and couplings
+ BETAH=ATAN(TANB)
+ COTB=ONE/TANB
+ COSBPA=COS(BETAH+ALPHAH)
+ SINBPA=SIN(BETAH+ALPHAH)
+ COSBMA=COS(BETAH-ALPHAH)
+ SINBMA=SIN(BETAH-ALPHAH)
+ COSA=COS(ALPHAH)
+ SINA=SIN(ALPHAH)
+ COSB=COS(BETAH)
+ SINB=SIN(BETAH)
+ GHWWSS(1)=SINBMA
+ GHWWSS(2)=COSBMA
+ GHWWSS(3)=ZERO
+ DO 30 I=1,3
+ GHZZSS(I)=GHWWSS(I)
+ 30 CONTINUE
+ GHDDSS(1)=-SINA/COSB
+ GHDDSS(2)= COSA/COSB
+ GHDDSS(3)= TANB
+ GHUUSS(1)= COSA/SINB
+ GHUUSS(2)= SINA/SINB
+ GHUUSS(3)= COTB
+ GHWHSS(1)= COSBMA
+ GHWHSS(2)= SINBMA
+ GHWHSS(3)= ONE
+ MZSW2 = MZ**2 * SQRT(SWEIN*(ONE-SWEIN))
+ DTERM(1) =-SINBPA*MZSW2
+ DTERM(2) = COSBPA*MZSW2
+ DTERM(3) = ZERO
+ FTMUU(1) =-MUSS*SINA/SINB
+ FTMUU(2) = MUSS*COSA/SINB
+ FTMUU(3) = MUSS
+ FTMUU(4) = MUSS
+ FTMTT(1) =-ATSS*COSA/SINB
+ FTMTT(2) =-ATSS*SINA/SINB
+ FTMTT(3) = ATSS*COTB
+ FTMTT(4) = ATSS*COTB
+ FTMDD(1) = MUSS*COSA/COSB
+ FTMDD(2) = MUSS*SINA/COSB
+ FTMDD(3) = MUSS
+ FTMDD(4) = MUSS
+ FTMBB(1) = ABSS*SINA/COSB
+ FTMBB(2) =-ABSS*COSA/COSB
+ FTMBB(3) = ABSS*TANB
+ FTMBB(4) = ABSS*TANB
+ DO 40 IH=1,4
+ FTMU=FTMUU(IH)
+ FTMD=FTMDD(IH)
+ DO 50 I=1,6
+ IF (I.EQ.5) FTMU=FTMU+FTMTT(IH)
+ IF (I.EQ.5) FTMD=FTMD+FTMBB(IH)
+ IF (MOD(I,2).EQ.0) THEN
+ YTM = GHUUSS(IH)
+ FTM = FTMU
+ ELSE
+ YTM = GHDDSS(IH)
+ FTM = FTMD
+ END IF
+ IF (IH.EQ.3) THEN
+ GHSQSS(IH,I,1,1) = ZERO
+ GHSQSS(IH,I,2,2) = ZERO
+ GHSQSS(IH,I,1,2) = FTM*HALF*RMASS(I)/MW
+ GHSQSS(IH,I,2,1) = - GHSQSS(IH,I,1,2)
+ GOTO 50
+ ELSEIF (IH.EQ.4) THEN
+ SQHF=SQRT(HALF)
+ SNBCSB=SINB*COSB
+ DO 60 J=1,2
+ DO 70 K=1,2
+ IF (MOD(I,2).EQ.1) THEN
+ GHSQSS(IH,I,J,K)=SQHF*(
+ & RMASS(I )*FTMD*QMIXSS(I,2,J)*QMIXSS(I+1,1,K)
+ & +RMASS(I+1)*FTMU*QMIXSS(I,1,J)*QMIXSS(I+1,2,K)
+ & +( MW**2*TWO*SNBCSB-RMASS(I+1)**2*COTB
+ & -RMASS(I )**2*TANB )*QMIXSS(I,1,J)*QMIXSS(I+1,1,K)
+ & -RMASS(I)*RMASS(I+1)/SNBCSB
+ & *QMIXSS(I,2,J)*QMIXSS(I+1,2,K) ) / MW
+ ELSE
+ GHSQSS(IH,I,J,K)=GHSQSS(IH,I-1,K,J)
+ END IF
+ 70 END DO
+ 60 END DO
+ ELSE
+ DO 80 J=1,2
+ DO 90 K=1,2
+ YTM1=ZERO
+ IF (J.EQ.K) YTM1=YTM*RMASS(I)**2
+ GHSQSS(IH,I,J,K)=( YTM1
+ & +( LFCH(I)*QMIXSS(I,1,J)*QMIXSS(I,1,K)
+ & -RFCH(I)*QMIXSS(I,2,J)*QMIXSS(I,2,K) )*DTERM(IH)
+ & +FTM*HALF*RMASS(I)*(QMIXSS(I,1,J)*QMIXSS(I,2,K)
+ & +QMIXSS(I,2,J)*QMIXSS(I,1,K)) ) / MW
+ 90 CONTINUE
+ 80 CONTINUE
+ END IF
+ 50 CONTINUE
+ 40 CONTINUE
+C--Rparity violation
+ READ (LRSUSY,'(L5)') RPARTY
+ IF(.NOT.RPARTY) THEN
+ READ(LRSUSY,20) (((LAMDA1(I,J,K),K=1,3),J=1,3),I=1,3)
+ READ(LRSUSY,20) (((LAMDA2(I,J,K),K=1,3),J=1,3),I=1,3)
+ READ(LRSUSY,20) (((LAMDA3(I,J,K),K=1,3),J=1,3),I=1,3)
+ ENDIF
+ 13 FORMAT(4F16.8)
+ 20 FORMAT(27E16.8)
+ CLOSE(LRSUSY)
+ 999 END
+CDECK ID>, HWMEVT.
+*CMZ :- -04/05/99 14.28.59 by Bryan Webber
+*-- Author : Bryan Webber
+C-----------------------------------------------------------------------
+ SUBROUTINE HWMEVT
+C-----------------------------------------------------------------------
+C IPROC = 1000,... ADDS SOFT UNDERLYING EVENT
+C = 8000: CREATES MINIMUM-BIAS EVENT
+C SUPPRESSED BY ADDING 10000 TO IPROC
+C-----------------------------------------------------------------------
+ INCLUDE 'HERWIG61.INC'
+ DOUBLE PRECISION HWREXP,ENFAC,TECM,SECM,SUMM,EMCL,BMP(5),BMR(3,3)
+ INTEGER HWRINT,NETC,IBT,IDBT,ID1,ID2,ID3,KHEP,LHEP,NTRY,ICMS,
+ & NPPBAR,MCHT,JCL,JD1,JD2,JD3,ICH,MODC,NCHT,INHEP(2),
+ & INID(2,2),JBT
+ EXTERNAL HWREXP,HWRINT
+ IF (IERROR.NE.0) RETURN
+ IF (.NOT.GENSOF) GOTO 990
+ IF (IPROC.EQ.8000) THEN
+C---SET UP BEAM AND TARGET CLUSTERS
+ 5 NETC=0
+ DO 10 IBT=1,2
+ JBT=IBT
+ IF (JDAHEP(1,IBT).NE.0) JBT=JDAHEP(1,IBT)
+ IDBT=IDHW(JBT)
+ IF (IDBT.EQ.73.OR.IDBT.EQ.75) THEN
+ INID(1,IBT)=HWRINT(1,2)
+ INID(2,IBT)=110
+ ELSEIF (IDBT.EQ.91.OR.IDBT.EQ.93) THEN
+ INID(1,IBT)=116
+ INID(2,IBT)=HWRINT(7,8)
+ ELSEIF (IDBT.EQ.30) THEN
+ INID(1,IBT)=HWRINT(1,2)
+ INID(2,IBT)=8
+ ELSEIF (IDBT.EQ.38) THEN
+ INID(1,IBT)=2
+ INID(2,IBT)=HWRINT(7,8)
+ ELSEIF (IDBT.EQ.34) THEN
+ INID(1,IBT)=3
+ INID(2,IBT)=HWRINT(7,8)
+ ELSEIF (IDBT.EQ.46) THEN
+ INID(1,IBT)=HWRINT(1,2)
+ INID(2,IBT)=9
+ ELSEIF (IDBT.EQ.59) THEN
+ INID(1,IBT)=HWRINT(1,2)
+ INID(2,IBT)=HWRINT(7,8)
+ ELSE
+ CALL HWWARN('HWMEVT',100,*999)
+ ENDIF
+ NETC=NETC+ICHRG(IDBT)
+ & -(ICHRG(INID(1,IBT))+ICHRG(INID(2,IBT)))/3
+ ENFAC=1.
+ IDHW(NHEP+IBT)=19
+ IDHEP(NHEP+IBT)=91
+ ISTHEP(NHEP+IBT)=163+IBT
+ JMOHEP(1,NHEP+IBT)=JBT
+ 10 CONTINUE
+ IF (NETC.EQ.0) THEN
+ ID3=HWRINT(1,2)
+ ELSEIF (NETC.EQ.-1) THEN
+ ID3=1
+ ELSEIF (NETC.EQ.1) THEN
+ ID3=2
+ ELSE
+ GOTO 5
+ ENDIF
+ DO 12 IBT=1,2
+ NHEP=NHEP+1
+ JBT=IBT
+ IF (JDAHEP(1,IBT).NE.0) JBT=JDAHEP(1,IBT)
+ CALL HWVEQU(5,PHEP(1,JBT),PHEP(1,NHEP))
+ 12 INHEP(IBT)=NHEP
+ ELSE
+C---FIND BEAM AND TARGET CLUSTERS
+ DO 20 IBT=1,2
+ DO 15 KHEP=1,NHEP
+ IF (ISTHEP(KHEP).EQ.163+IBT) THEN
+ INHEP(IBT)=KHEP
+ INID(1,IBT)=IDHW(JMOHEP(1,KHEP))
+ INID(2,IBT)=IDHW(JMOHEP(2,KHEP))
+ GOTO 20
+ ENDIF
+ 15 CONTINUE
+C---COULDN'T FIND ONE
+ INHEP(IBT)=0
+ 20 CONTINUE
+ JCL=-1
+C---TEST FOR BOTH FOUND
+ IF (INHEP(1).EQ.0) JCL=INHEP(2)
+ IF (INHEP(2).EQ.0) JCL=INHEP(1)
+ IF (JCL.EQ.0) CALL HWWARN('HWMEVT',101,*999)
+ IF (JCL.GT.0) THEN
+ ISTHEP(JCL)=163
+ CALL HWCFOR
+ CALL HWCDEC
+ CALL HWDHAD
+ CALL HWDHVY
+ GOTO 90
+ ENDIF
+ ID3=HWRINT(1,2)
+ ENFAC=ENSOF
+ NETC=0
+ ENDIF
+C---FIND SOFT CM MOMENTUM AND MULTIPLICITY
+ NTRY=0
+ NHEP=NHEP+1
+ IF (NHEP.GT.NMXHEP) CALL HWWARN('HWMEVT',102,*999)
+ ICMS=NHEP
+ IDHW(NHEP)=16
+ IDHEP(NHEP)=0
+ ISTHEP(NHEP)=170
+ CALL HWVSUM(4,PHEP(1,INHEP(1)),PHEP(1,INHEP(2)),PHEP(1,NHEP))
+ CALL HWUMAS(PHEP(1,NHEP))
+ TECM=PHEP(5,NHEP)
+ IF (IPROC/1000.EQ.9.OR.IPROC/1000.EQ.5) THEN
+ SECM=TECM*ENFAC
+ ELSE
+ SECM=PHEP(5,3)*ENFAC
+ ENDIF
+C---CHOOSE MULTIPLICITY
+ 25 CALL HWMULT(SECM,NPPBAR)
+ 30 NCL=0
+ MCHT=0
+ IERROR=0
+ NHEP =ICMS
+ SUMM=0.
+ NTRY=NTRY+1
+C---CREATE CLUSTERS
+ 35 NCL=NCL+1
+ NHEP=NHEP+1
+ IF (NHEP.GT.NMXHEP) CALL HWWARN('HWMEVT',103,*999)
+ JCL=NHEP
+ IDHW(JCL)=19
+ IDHEP(JCL)=91
+ IF (NCL.LT.3) THEN
+ ISTHEP(JCL)=170+NCL
+ ID1=INID(1,NCL)
+ ID2=INID(2,NCL)
+ ELSE
+ ID1=ID2-6
+ IF (NCL.EQ.3) ID1=ID3
+ ID2=HWRINT(7,8)
+ ISTHEP(JCL)=173
+ ENDIF
+ JMOHEP(1,JCL)=ICMS
+ JMOHEP(2,JCL)=0
+ CALL HWVZRO(3,PHEP(1,JCL))
+ PHEP(4,JCL)=RMASS(ID1)+RMASS(ID2)+PMBM1+HWREXP(TWO/PMBM2)
+ PHEP(5,JCL)=PHEP(4,JCL)
+C---HADRONIZE AND DECAY CLUSTERS
+ CALL HWCFLA(ID1,ID2,JD1,JD2)
+ CALL HWCHAD(JCL,JD1,JD2,JD3)
+ IF (IERROR.NE.0) RETURN
+ IF (JD3.EQ.0) THEN
+ EMCL=RMASS(IDHW(NHEP))
+ IF (PHEP(4,JCL).NE.EMCL) THEN
+ PHEP(4,JCL)=EMCL
+ PHEP(5,JCL)=EMCL
+ PHEP(4,NHEP)=EMCL
+ PHEP(5,NHEP)=EMCL
+ ENDIF
+ ELSE
+ EMCL=PHEP(5,JCL)
+ ENDIF
+ IDCL(NCL)=JD3
+ PPCL(5,NCL)=EMCL
+ SUMM=SUMM +EMCL
+ CALL HWDHAD
+ CALL HWDHVY
+ IF (IERROR.NE.0) RETURN
+C---CHECK CHARGED MULTIPLICITY
+ MODC=0
+ DO 50 KHEP=JCL,NHEP
+ IF (ISTHEP(KHEP).EQ.1) THEN
+ ICH=ICHRG(IDHW(KHEP))
+ IF (ICH.NE.0) THEN
+ MCHT=MCHT+ABS(ICH)
+ MODC=MODC+ICH
+ ENDIF
+ ENDIF
+ 50 CONTINUE
+ IF (NCL.EQ.1) THEN
+ NCHT=NPPBAR+NETC+ABS(MODC)
+ GOTO 35
+ ELSEIF (NCL.EQ.2) THEN
+ NCHT=NCHT+ABS(MODC)
+ IF (NCHT.LT.0) NCHT=NCHT+2
+ ENDIF
+ IF (MCHT.LT.NCHT) THEN
+ GOTO 35
+ ELSEIF (MCHT.GT.NCHT) THEN
+ IF (MOD(NTRY,50).EQ.0) GOTO 25
+ IF (NTRY.LT.NSTRY) GOTO 30
+C---NO PHASE SPACE FOR SOFT EVENT
+ NHEP=ICMS-1
+ IF (IPROC.EQ.8000) THEN
+C---MINIMUM BIAS: RELABEL BEAM AND TARGET CLUSTERS
+ DO 60 IBT=1,2
+ KHEP=INHEP(IBT)
+ LHEP=JMOHEP(1,KHEP)
+ ISTHEP(KHEP)=1
+ IDHEP(KHEP)=IDHEP(LHEP)
+ IDHW(KHEP)=IDHW(LHEP)
+ 60 CONTINUE
+ ELSE
+C---UNDERLYING EVENT: DECAY THEM
+ ISTHEP(INHEP(1))=163
+ ISTHEP(INHEP(2))=163
+ CALL HWCFOR
+ CALL HWCDEC
+ CALL HWDHAD
+ CALL HWDHVY
+ ENDIF
+ GOTO 90
+ ENDIF
+C---GENERATE CLUSTER MOMENTA IN CLUSTER CM
+C FRAME. N.B. SECOND CLUSTER IS TARGET
+ IF (SUMM.GT.TECM) GOTO 25
+ CALL HWMLPS(TECM)
+ IF (NCL.EQ.0) GOTO 25
+ JCL=0
+C---ROTATE & BOOST CLUSTERS & DECAY PRODUCTS
+ CALL HWULOF(PHEP(1,ICMS),PHEP(1,INHEP(1)),BMP)
+ CALL HWUROT(BMP, ONE,ZERO,BMR)
+C---BMR PUTS BEAM ALONG Z AXIS (WE WANT INVERSE)
+ DO 70 KHEP=ICMS+1,NHEP
+ IF (ISTHEP(KHEP).GT.180.AND.ISTHEP(KHEP).LT.190
+ $ .AND.JMOHEP(1,KHEP).EQ.ICMS) THEN
+ ISTHEP(KHEP)=ISTHEP(KHEP)+3
+ LHEP=KHEP
+ JCL=JCL+1
+ CALL HWUROB(BMR,PPCL(1,JCL),PPCL(1,JCL))
+ CALL HWULOB(PHEP(1,ICMS),PPCL(1,JCL),PPCL(1,JCL))
+C---NOW PPCL(*,JCL) IS LAB MOMENTUM OF JTH CLUSTER
+ ENDIF
+ CALL HWULOB(PPCL(1,JCL),PHEP(1,KHEP),PHEP(1,KHEP))
+ 70 CONTINUE
+ ISTHEP(INHEP(1))=167
+ ISTHEP(INHEP(2))=168
+ 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
+ 990 ISTAT=100
+ 999 END
+CDECK ID>, HWMLPS.
+*CMZ :- -04/05/99 14.17.04 by Bryan Webber
+*-- Author : David Ward, modified by Bryan Webber
+C-----------------------------------------------------------------------
+ SUBROUTINE HWMLPS(TECM)
+C-----------------------------------------------------------------------
+C GENERATES CYLINDRICAL PHASE SPACE USING THE METHOD OF JADACH
+C RETURNS WITH NCL=0 IF UNSUCCESSFUL
+C-----------------------------------------------------------------------
+ INCLUDE 'HERWIG61.INC'
+ DOUBLE PRECISION HWREXT,HWRUNG,HWUSQR,TECM,ESS,ALOGS,EPS,SUMX,
+ & SUMY,PT,PX,PY,PT2,SUMPT2,SUMTM,XIMIN,XIMAX,YY,SUM1,SUM2,SUM3,
+ & SUM4,EX,FY,DD,DYY,ZZ,E1,TM,SLOP,XI(NMXCL)
+ INTEGER NTRY,I,NIT,IY(NMXCL),IDP
+ EXTERNAL HWREXT,HWRUNG,HWUSQR
+ IF (NCL.GT.NMXCL) THEN
+ CALL HWWARN('HWMLPS',1,*999)
+ NCL=NMXCL
+ ENDIF
+ ESS=TECM**2
+ ALOGS=LOG(ESS)
+ EPS=1D-10/NCL
+ NTRY=0
+ 11 NTRY=NTRY+1
+ IF (NTRY.GT.NSTRY) THEN
+ NCL=0
+ RETURN
+ ENDIF
+ SUMX=0.
+ SUMY=0.
+ DO 12 I=1,NCL
+C---Pt distribution of form exp(-b*Mt)
+C---Factors for pt slopes to fit data. IDCL contains the type of
+C q-qbar pair produced in this cluster (0 if 1-particle cluster).
+ IDP=IDCL(I)
+ IF (IDP.LE.2) THEN
+ SLOP=PMBP1
+ ELSEIF(IDP.EQ.3.OR.IDP.EQ.10) THEN
+ SLOP=PMBP2
+ ELSEIF(IDP.GT.3.AND.IDP.LE.9) THEN
+ SLOP=PMBP3
+ ELSE
+ CALL HWWARN('HWMLPS',200,*999)
+ ENDIF
+ PT=HWREXT(PPCL(5,I),SLOP)
+ PT=HWUSQR(PT**2-PPCL(5,I)**2)
+ CALL HWRAZM(PT,PX,PY)
+ PPCL(1,I)=PX
+ PPCL(2,I)=PY
+ SUMX=SUMX+PPCL(1,I)
+ 12 SUMY=SUMY+PPCL(2,I)
+ SUMX=SUMX/NCL
+ SUMY=SUMY/NCL
+ SUMPT2=0.
+ SUMTM=0.
+ DO 13 I=1,NCL
+ PPCL(1,I)=PPCL(1,I)-SUMX
+ PPCL(2,I)=PPCL(2,I)-SUMY
+ PT2=PPCL(1,I)**2+PPCL(2,I)**2
+ SUMPT2=SUMPT2+PT2
+C---STORE TRANSVERSE MASS IN PPCL(3,I) TEMPORARILY
+ PPCL(3,I)=SQRT(PT2+PPCL(5,I)**2)
+ 13 SUMTM=SUMTM+PPCL(3,I)
+ IF (SUMTM.GT.TECM) GOTO 11
+ DO 14 I=1,NCL
+C---Form of "reduced rapidity" distribution
+ XI(I)=HWRUNG(0.6*ONE,ONE)
+ 14 CONTINUE
+ CALL HWUSOR(XI,NCL,IY,1)
+ XIMIN=XI(1)
+ XIMAX=XI(NCL)-XI(1)
+C---N.B. TARGET CLUSTER IS SECOND
+ XI(1)=0.
+ DO 16 I=NCL-1,2,-1
+ XI(I+1)=(XI(I)-XIMIN)/XIMAX
+ 16 CONTINUE
+ XI(2)=1.
+ YY=LOG(ESS/(PPCL(3,1)*PPCL(3,2)))
+ DO 18 NIT=1,10
+ SUM1=0.
+ SUM2=0.
+ SUM3=0.
+ SUM4=0.
+ DO 19 I=1,NCL
+ TM=PPCL(3,I)
+ EX=EXP(YY*XI(I))
+ SUM1=SUM1+(TM*EX)
+ SUM2=SUM2+(TM/EX)
+ SUM3=SUM3+(TM*EX)*XI(I)
+ 19 SUM4=SUM4+(TM/EX)*XI(I)
+ FY=ALOGS-LOG(SUM1*SUM2)
+ DD=(SUM3*SUM2-SUM1*SUM4)/(SUM1*SUM2)
+ DYY=FY/DD
+ IF(ABS(DYY/YY).LT.EPS) GOTO 20
+ 18 YY=YY+DYY
+C---Y ITERATIONS EXCEEDED - TRY AGAIN
+ IF (NTRY.LT.100) GOTO 11
+ EPS=10.*EPS
+ IF (EPS.GT.ONE) CALL HWWARN('HWMLPS',100,*999)
+ CALL HWWARN('HWMLPS',50,*11)
+ 20 YY=YY+DYY
+ ZZ=LOG(TECM/SUM1)
+ DO 22 I=1,NCL
+ TM=PPCL(3,I)
+ E1=EXP(ZZ+YY*XI(I))
+ PPCL(3,I)=(0.5*TM)*((1./E1)-E1)
+ PPCL(4,I)=(0.5*TM)*((1./E1)+E1)
+ 22 CONTINUE
+ 999 END
+CDECK ID>, HWMNBI.
+*CMZ :- -26/04/91 11.11.55 by Bryan Webber
+*-- Author : David Ward, modified by Bryan Webber
+C-----------------------------------------------------------------------
+ FUNCTION HWMNBI(N,AVNCH,EK)
+C-----------------------------------------------------------------------
+C---Computes negative binomial probability
+C-----------------------------------------------------------------------
+ DOUBLE PRECISION HWMNBI,AVNCH,EK,R
+ INTEGER N,I
+ IF(N.LE.0) THEN
+ HWMNBI=0
+ ELSE
+ R=AVNCH/EK
+ HWMNBI=(1.+R)**(-EK)
+ R=R/(1.+R)
+ DO 1 I=1,N
+ HWMNBI=HWMNBI*R*(EK+I-1)/I
+ 1 CONTINUE
+ ENDIF
+ END
+CDECK ID>, HWMODK.
+*CMZ :- -27/07/99 13.33.03 by Mike Seymour
+*-- Author : Ian Knowles
+C-----------------------------------------------------------------------
+ SUBROUTINE HWMODK(IDKTMP,BRTMP,IMETMP,
+ & IATMP,IBTMP,ICTMP,IDTMP,IETMP)
+C-----------------------------------------------------------------------
+C Takes the decay, IDKTMP -> I-(A+B+C+D+E)-TMP, and simply stores it
+C if internal pointers not set up (.NOT.DKPSET) else if pre-existing
+C mode updates branching ratio BRTMP and matrix element code IMETMP,
+C if -ve leaves as is. If a new mode adds to table and if consistent
+C adjusts pointers, sets CMMOM (for two-body mode) and resets RSTAB
+C if necessary. The branching ratios of any other IDKTMP decays are
+C scaled by (1.-BRTMP)/(1.-BR_OLD)
+C-----------------------------------------------------------------------
+ INCLUDE 'HERWIG61.INC'
+ DOUBLE PRECISION HWUPCM,BRTMP,SCALE,EPS
+ INTEGER IDKTMP,IMETMP,IATMP,IBTMP,ICTMP,IDTMP,IETMP,IDKY,ITMP(5),
+ & L,I,J,K,JPREV
+ LOGICAL MATCH(5)
+ CHARACTER*8 CDUM
+ EXTERNAL HWUPCM
+ PARAMETER (EPS=1.D-6)
+C Convert to internal format
+ CALL HWUIDT(1,IDKTMP,IDKY,CDUM)
+ IF (IDKY.EQ.20) THEN
+ WRITE(6,10) IDKTMP
+ 10 FORMAT(1X,'Particle decaying,',I7,', is not recognised')
+ RETURN
+ ENDIF
+ CALL HWUIDT(1,IATMP,ITMP(1),CDUM)
+ CALL HWUIDT(1,IBTMP,ITMP(2),CDUM)
+ CALL HWUIDT(1,ICTMP,ITMP(3),CDUM)
+ CALL HWUIDT(1,IDTMP,ITMP(4),CDUM)
+ CALL HWUIDT(1,IETMP,ITMP(5),CDUM)
+C If internal pointers not yet set up simply store decay
+ IF (.NOT.DKPSET) THEN
+ NDKYS=NDKYS+1
+ IF (NDKYS.GT.NMXDKS) CALL HWWARN('HWMODK',100,*999)
+ IDK(NDKYS)=IDKY
+ BRFRAC(NDKYS)=BRTMP
+ NME(NDKYS)=IMETMP
+ DO 20 I=1,5
+ 20 IDKPRD(I,NDKYS)=ITMP(I)
+ ELSE
+ IF (NMODES(IDKY).GT.0) THEN
+C First search to see if mode pre-exists
+ IF ((ITMP(2).GE.1.AND.ITMP(2).LE.13).OR.
+ & (ITMP(3).GE.1.AND.ITMP(3).LE.13)) THEN
+C Partonic respect order
+ L=LSTRT(IDKY)
+ DO 30 K=1,NMODES(IDKY)
+ IF (ITMP(1).EQ.IDKPRD(1,L).AND.
+ & ITMP(2).EQ.IDKPRD(2,L).AND.
+ & ITMP(3).EQ.IDKPRD(3,L).AND.
+ & ITMP(4).EQ.IDKPRD(4,L).AND.
+ & ITMP(5).EQ.IDKPRD(5,L)) GOTO 90
+ 30 L=LNEXT(L)
+ ELSE
+C Allow for different order in matching
+ L=LSTRT(IDKY)
+ DO 70 I=1,NMODES(IDKY)
+ DO 40 J=1,5
+ 40 MATCH(J)=.FALSE.
+ DO 60 J=1,5
+ DO 50 K=1,5
+ IF (.NOT.MATCH(K).AND.ITMP(K).EQ.IDKPRD(J,L)) THEN
+ MATCH(K)=.TRUE.
+ GOTO 60
+ ENDIF
+ 50 CONTINUE
+ 60 CONTINUE
+ IF (MATCH(1).AND.MATCH(2).AND.MATCH(3).AND.
+ & MATCH(4).AND.MATCH(5)) GOTO 90
+ 70 L=LNEXT(L)
+ ENDIF
+ ENDIF
+C A new mode put decay products in table
+ NDKYS=NDKYS+1
+ IF (NDKYS.GT.NMXDKS) CALL HWWARN('HWMODK',101,*999)
+ DO 80 I=1,5
+ 80 IDKPRD(I,NDKYS)=ITMP(I)
+C If decay consistent set up new pointers
+ CALL HWDCHK(IDKY,NDKYS,*980)
+ IF (NMODES(IDKY).EQ.0) THEN
+ LSTRT(IDKY)=NDKYS
+ IF (RLTIM(IDKY).LT.PLTCUT.AND.RMASS(IDKY).NE.ZERO) THEN
+ RSTAB(IDKY)=.FALSE.
+ DKLTM(IDKY)=RLTIM(IDKY)*RMASS(IDKY)/HBAR
+ ELSE
+ RSTAB(IDKY)=.TRUE.
+ ENDIF
+ ELSE
+ LNEXT(L)=NDKYS
+ ENDIF
+ NMODES(IDKY)=NMODES(IDKY)+1
+ LNEXT(NDKYS)=NDKYS
+ L=NDKYS
+C Set CMMOM if two body decay
+ IF (NPRODS(L).EQ.2) CMMOM(L)=
+ & HWUPCM(RMASS(IDKY),RMASS(IDKPRD(1,L)),RMASS(IDKPRD(2,L)))
+C A Pre-existing mode, line L, add/update ME code and BR, scaling all
+C other branching fractions
+ 90 IF (IMETMP.GT.0) NME(L)=IMETMP
+ IF (ABS(BRTMP-1.).LT.EPS) THEN
+C This modes dominant: eliminate others
+ NMODES(IDKY)=1
+ LSTRT(IDKY)=L
+ BRFRAC(L)=ONE
+ LNEXT(L)=L
+ ELSEIF (ABS(BRTMP).LT.EPS) THEN
+C This mode insignificant: eliminate it
+ IF (NMODES(IDKY).EQ.1) THEN
+ RSTAB(IDKY)=.TRUE.
+ ELSE
+ J=LSTRT(IDKY)
+ IF (J.EQ.L) THEN
+ LSTRT(IDKY)=LNEXT(J)
+ ELSE
+ JPREV=J
+ DO 100 I=2,NMODES(IDKY)
+ J=LNEXT(J)
+ IF (J.EQ.L) LNEXT(JPREV)=LNEXT(J)
+ 100 JPREV=J
+ ENDIF
+C Rescale other modes
+ SCALE=ONE/(ONE-BRFRAC(L))
+ J=LSTRT(IDKY)
+ DO 110 I=1,NMODES(IDKY)-1
+ BRFRAC(J)=SCALE*BRFRAC(J)
+ 110 J=LNEXT(J)
+ ENDIF
+ NMODES(IDKY)=NMODES(IDKY)-1
+ ELSE
+C Rescale all other modes
+ IF (NMODES(IDKY).EQ.1) THEN
+ BRFRAC(L)=ONE
+ ELSE
+ IF (L.EQ.NDKYS) THEN
+ SCALE=ONE-BRTMP
+ ELSE
+ SCALE=(ONE-BRTMP)/(ONE-BRFRAC(L))
+ ENDIF
+ J=LSTRT(IDKY)
+ DO 120 I=1,NMODES(IDKY)
+ IF (J.NE.L) BRFRAC(J)=SCALE*BRFRAC(J)
+ 120 J=LNEXT(J)
+ BRFRAC(L)=BRTMP
+ ENDIF
+ ENDIF
+ ENDIF
+ GOTO 999
+ 980 WRITE(6,990)
+ 990 FORMAT(1X,'Decay mode inconsistent, no modifications made')
+ 999 RETURN
+ END
+CDECK ID>, HWMULT.
+*CMZ :- -04/05/99 11.11.55 by Bryan Webber
+*-- Author : David Ward, modified by Bryan Webber
+C-----------------------------------------------------------------------
+ SUBROUTINE HWMULT(EPPBAR,NCHT)
+C-----------------------------------------------------------------------
+C Chooses charged multiplicity NCHT at the p-pbar c.m. energy EPPBAR
+C-----------------------------------------------------------------------
+ INCLUDE 'HERWIG61.INC'
+ DOUBLE PRECISION HWMNBI,HWR,EPPBAR,E0,ALOGS,RK,EK,AVN,SUM,R,
+ & CUM(500)
+ INTEGER NCHT,IMAX,I,N
+ SAVE IMAX,CUM
+ EXTERNAL HWMNBI,HWR
+ DATA E0/0/
+ IF (EPPBAR.NE.E0) THEN
+ E0=EPPBAR
+C---Initialize
+ ALOGS=2.*LOG(EPPBAR)
+ RK=PMBK1*ALOGS+PMBK2
+ IF (ABS(RK).GT.1000.) RK=1000.
+ EK=1./RK
+ AVN=PMBN1*EXP(PMBN2*ALOGS)+PMBN3
+ IF (AVN.LT.ONE) AVN=1.
+ SUM=0.
+ IMAX=1
+ DO 10 I=1,500
+ N=2*I
+ CUM(I)=HWMNBI(N,AVN,EK)
+ IF (CUM(I).LT.1D-7*SUM) GOTO 11
+ IMAX=I
+ SUM=SUM+CUM(I)
+ CUM(I)=SUM
+ 10 CONTINUE
+ 11 CONTINUE
+ IF (IMAX.LE.1) THEN
+ IMAX=1
+ CUM(1)=1
+ ELSEIF (IMAX.EQ.500) THEN
+ CALL HWWARN('HWMULT',200,*999)
+ ELSE
+ DO 12 I=1,IMAX
+ 12 CUM(I)=CUM(I)/SUM
+ ENDIF
+ ENDIF
+C --- Select NCHT
+ R=HWR()
+ DO 20 I=1,IMAX
+ IF(R.GT.CUM(I)) GOTO 20
+ NCHT=2*I
+ RETURN
+ 20 CONTINUE
+ CALL HWWARN('HWMULT',100,*999)
+ 999 END
+CDECK ID>, HWMWGT.
+*CMZ :- -02/11/93 11.11.55 by Bryan Webber
+*-- Author : Bryan Webber
+C-----------------------------------------------------------------------
+ SUBROUTINE HWMWGT
+C-----------------------------------------------------------------------
+C COMPUTES WEIGHT FOR MINIMUM-BIAS EVENT
+C-----------------------------------------------------------------------
+ INCLUDE 'HERWIG61.INC'
+ DOUBLE PRECISION S,X,Y
+ INTEGER IDB,IDT,IDBT
+ IF (IERROR.NE.0) RETURN
+ IDB=IDHW(1)
+ IF (JDAHEP(1,1).NE.0) IDB=IDHW(JDAHEP(1,1))
+ IDT=IDHW(2)
+ IF (JDAHEP(1,2).NE.0) IDT=IDHW(JDAHEP(1,2))
+ IDBT=100*IDB+IDT
+ IF (IDT.GT.IDB) IDBT=100*IDT+IDB
+C---USE TOTAL CROSS SECTION FITS OF DONNACHIE & LANDSHOFF
+C CERN-TH.6635/92
+ IF (IDBT.EQ.9173) THEN
+ X=21.70
+ Y=98.39
+ ELSEIF (IDBT.EQ.7373) THEN
+ X=21.70
+ Y=56.08
+ ELSEIF (IDBT.EQ.7330) THEN
+ X=13.63
+ Y=36.02
+ ELSEIF (IDBT.EQ.7338) THEN
+ X=13.63
+ Y=27.56
+ ELSEIF (IDBT.EQ.7334) THEN
+ X=11.82
+ Y=26.36
+ ELSEIF (IDBT.EQ.7346) THEN
+ X=11.82
+ Y= 8.15
+ ELSEIF (IDBT.EQ.7359) THEN
+ X=.0677
+ Y=.1290
+ ELSEIF (IDBT.EQ.9175) THEN
+ X=21.70
+ Y=92.71
+ ELSEIF (IDBT.EQ.7573) THEN
+ X=21.70
+ Y=54.77
+ ELSEIF (IDBT.EQ.5959) THEN
+C---FOR GAMMA-GAMMA ASSUME X AND Y FACTORIZE
+ X=2.1E-4
+ Y=3.0E-4
+ ELSE
+ PRINT *,' IDBT=',IDBT
+ CALL HWWARN('HWMWGT',100,*999)
+ ENDIF
+ S=PHEP(5,3)**2
+C---EVWGT IS NON-DIFFRACTIVE CROSS SECTION IN NANOBARNS
+C ASSUMING NON-DIFFRACTIVE = TOTAL*0.7
+ EVWGT=.7E6*(X*S**.0808 + Y*S**(-.4525))
+ 999 END
+CDECK ID>, HWRAZM.
+*CMZ :- -26/04/91 11.11.55 by Bryan Webber
+*-- Author : Bryan Webber
+C-----------------------------------------------------------------------
+ SUBROUTINE HWRAZM(PT,PX,PY)
+C-----------------------------------------------------------------------
+C RANDOMLY ROTATED 2-VECTOR (PX,PY) OF LENGTH PT
+C-----------------------------------------------------------------------
+ DOUBLE PRECISION HWR,PT,PX,PY,C,S,CS,QT,ONE,ZERO
+ PARAMETER(ONE=1.0D0, ZERO=0.0D0)
+ EXTERNAL HWR
+ 10 C=2.*HWR()-1.
+ S=2.*HWR()-1.
+ CS=C*C+S*S
+ IF (CS.GT.ONE .OR. CS.EQ.ZERO) GOTO 10
+ QT=PT/CS
+ PX=(C*C-S*S)*QT
+ PY=2.*C*S*QT
+ END
+CDECK ID>, HWREXP.
+*CMZ :- -26/04/91 11.11.55 by Bryan Webber
+*-- Author : David Ward, modified by Bryan Webber
+C-----------------------------------------------------------------------
+ FUNCTION HWREXP(AV)
+C-----------------------------------------------------------------------
+C Random number from dN/d(x**2)=exp(-b*x) with mean AV
+C-----------------------------------------------------------------------
+ DOUBLE PRECISION HWREXP,HWR,AV,B,R1,R2
+ EXTERNAL HWR
+ B=2./AV
+ R1=HWR()
+ R2=HWR()
+ HWREXP=-LOG(R1*R2)/B
+ END
+CDECK ID>, HWREXQ.
+*CMZ :- -02/06/94 11.02.47 by Mike Seymour
+*-- Author : David Ward, modified by Bryan Webber and Mike Seymour
+C-----------------------------------------------------------------------
+ FUNCTION HWREXQ(AV,XMAX)
+C-----------------------------------------------------------------------
+C Random number from dN/d(x**2)=EXQ(-b*x) with mean AV,
+C But truncated at XMAX
+C-----------------------------------------------------------------------
+ DOUBLE PRECISION HWREXQ,HWR,AV,B,BXMAX,R1,R2,XMAX,R,RMIN
+ EXTERNAL HWR
+ B=2./AV
+ BXMAX=B*XMAX
+ IF (BXMAX.LT.50) THEN
+ RMIN=EXP(-BXMAX)
+ ELSE
+ RMIN=0
+ ENDIF
+ 10 R1=HWR()*(1-RMIN)+RMIN
+ R2=HWR()*(1-RMIN)+RMIN
+ R=R1*R2
+ IF (R.LT.RMIN) GOTO 10
+ HWREXQ=-LOG(R)/B
+ END
+CDECK ID>, HWREXT.
+*CMZ :- -26/04/91 11.11.55 by Bryan Webber
+*-- Author : David Ward, modified by Bryan Webber
+C-----------------------------------------------------------------------
+ FUNCTION HWREXT(AM0,B)
+C-----------------------------------------------------------------------
+C Random number from dN/d(x**2)=exp(-B*TM) distribution, where
+C TM = SQRT(X**2+AM0**2). Uses Newton's method to solve F-R=0
+C-----------------------------------------------------------------------
+ DOUBLE PRECISION HWREXT,HWR,AM0,B,R,A,F,DF,DAM,AM
+ INTEGER NIT
+ EXTERNAL HWR
+ R=HWR()
+C --- Starting value
+ AM=AM0-LOG(R)/B
+ DO 1 NIT=1,20
+ A=EXP(-B*(AM-AM0))/(1.+B*AM0)
+ F=(1.+B*AM)*A-R
+ DF=-B**2*AM*A
+ DAM=-F/DF
+ AM=AM+DAM
+ IF(AM.LT.AM0) AM=AM0+.001
+ IF(ABS(DAM).LT..001) GOTO 2
+ 1 CONTINUE
+ CALL HWWARN('HWREXT',1,*2)
+ 2 HWREXT=AM
+ END
+CDECK ID>, HWRGAU.
+*CMZ :- -19/05/99 11.11.56 by Mike Seymour
+*-- Author : Mike Seymour
+C-----------------------------------------------------------------------
+ FUNCTION HWRGAU(J,A,B)
+C-----------------------------------------------------------------------
+C Gaussian random number, mean A, standard deviation B.
+C Generates uncorrelated pairs and throws one of them away.
+C-----------------------------------------------------------------------
+ INCLUDE 'HERWIG61.INC'
+ DOUBLE PRECISION HWRGAU,HWR,A,B,X,TRASH
+ INTEGER J
+ EXTERNAL HWR
+ 10 X=HWR()
+ IF (X.LE.ZERO.OR.X.GT.ONE) GOTO 10
+ X=SQRT(-TWO*LOG(X))
+ CALL HWRAZM(X,X,TRASH)
+ HWRGAU=A+B*X
+ END
+CDECK ID>, HWR.
+*CMZ :- -26/04/91 12.42.30 by Federico Carminati
+*-- Author : F. James, modified by Mike Seymour
+C-----------------------------------------------------------------------
+ FUNCTION HWRGEN(I)
+C-----------------------------------------------------------------------
+C MAIN RANDOM NUMBER GENERATOR
+C USES METHOD OF l'Ecuyer, (VIA F.JAMES, COMP PHYS COMM 60(1990)329)
+C-----------------------------------------------------------------------
+ IMPLICIT NONE
+ DOUBLE PRECISION HWRGEN,HWRSET,HWRGET
+ INTEGER I,ISEED(2),K,IZ,JSEED(2)
+ SAVE ISEED
+ DATA ISEED/12345,67890/
+ K=ISEED(1)/53668
+ ISEED(1)=40014*(ISEED(1)-K*53668)-K*12211
+ IF (ISEED(1).LT.0) ISEED(1)=ISEED(1)+2147483563
+ K=ISEED(2)/52774
+ ISEED(2)=40692*(ISEED(2)-K*52774)-K*3791
+ IF (ISEED(2).LT.0) ISEED(2)=ISEED(2)+2147483399
+ IZ=ISEED(1)-ISEED(2)
+ IF (IZ.LT.1) IZ=IZ+2147483562
+ HWRGEN=DBLE(IZ)*4.656613001013252D-10
+C---> (4.656613001013252D-10 = 1.D0/2147483589)
+ RETURN
+C-----------------------------------------------------------------------
+ ENTRY HWRSET(JSEED)
+C-----------------------------------------------------------------------
+ IF (JSEED(1).EQ.0.OR.JSEED(2).EQ.0) CALL HWWARN('HWRSET',99,*999)
+ ISEED(1)=JSEED(1)
+ ISEED(2)=JSEED(2)
+ HWRSET=0.0D0
+ 999 RETURN
+C-----------------------------------------------------------------------
+ ENTRY HWRGET(JSEED)
+C-----------------------------------------------------------------------
+ JSEED(1)=ISEED(1)
+ JSEED(2)=ISEED(2)
+ HWRGET=0.0D0
+ RETURN
+ END
+CDECK ID>, HWRINT.
+*CMZ :- -26/04/91 11.11.56 by Bryan Webber
+*-- Author : Bryan Webber
+C-----------------------------------------------------------------------
+ FUNCTION HWRINT(IMIN,IMAX)
+C-----------------------------------------------------------------------
+C RANDOM INTEGER IN [IMIN,IMAX]. N.B. ASSUMES IMAX.GE.IMIN
+C-----------------------------------------------------------------------
+ DOUBLE PRECISION HWR,RN,ONE
+ INTEGER HWRINT,IMIN,IMAX
+ EXTERNAL HWR
+ PARAMETER (ONE=1.0D0)
+ 1 RN=HWR()
+ IF (RN.EQ.ONE) GOTO 1
+ RN=RN*(IMAX-IMIN+1)
+ HWRINT=IMIN+INT(RN)
+ END
+CDECK ID>, HWRLOG.
+*CMZ :- -26/04/91 14.15.56 by Federico Carminati
+*-- Author : Bryan Webber
+C-----------------------------------------------------------------------
+ FUNCTION HWRLOG(A)
+C-----------------------------------------------------------------------
+C Returns .TRUE. with probability A
+C-----------------------------------------------------------------------
+ DOUBLE PRECISION HWR,A,R
+ LOGICAL HWRLOG
+ EXTERNAL HWR
+ HWRLOG=.TRUE.
+ R=HWR()
+ IF(R.GT.A) HWRLOG=.FALSE.
+ END
+CDECK ID>, HWRPIP.
+*CMZ :- -27/07/99 13.33.03 by Mike Seymour
+*-- Author : Ian Knowles
+C-----------------------------------------------------------------------
+ SUBROUTINE HWRPIP
+C-----------------------------------------------------------------------
+C Generates a random primary IP using a triple Gaussian distribution
+C-----------------------------------------------------------------------
+ INCLUDE 'HERWIG61.INC'
+ DOUBLE PRECISION HWRGAU,VIP(3),VIPWID(3)
+ INTEGER I
+ EXTERNAL HWRGAU
+ DATA VIP,VIPWID/3*0.0,.25,.015,1.8/
+ DO 10 I=1,3
+ 10 VTXPIP(I)=HWRGAU(I,VIP(I),VIPWID(I))
+ VTXPIP(4)=0.
+ END
+CDECK ID>, HWRPOW.
+*CMZ :- -26/04/91 11.11.56 by Bryan Webber
+*-- Author : Bryan Webber
+C-----------------------------------------------------------------------
+ SUBROUTINE HWRPOW(XVAL,XJAC)
+C-----------------------------------------------------------------------
+C RETURNS XVAL DISTRIBUTED ON (XMIN,XMAX) LIKE XVAL**XPOW
+C AND CORRESPONDING JACOBIAN FACTOR XJAC
+C SET FIRST=.TRUE. IF NEW XMIN,XMAX OR XPOW
+C-----------------------------------------------------------------------
+ DOUBLE PRECISION HWR,XVAL,XJAC,XMIN,XMAX,XPOW,P,Q,A,B,C,Z,ZERO
+ LOGICAL FIRST
+ PARAMETER(ZERO=0.0D0)
+ EXTERNAL HWR
+ SAVE Q,A,B,C
+ COMMON/HWRPIN/XMIN,XMAX,XPOW,FIRST
+ IF (FIRST) THEN
+ P=XPOW+1.
+ IF (P.EQ.ZERO) CALL HWWARN('HWRPOW',500,*999)
+ Q=1./P
+ A=XMIN**P
+ B=XMAX**P-A
+ C=B*Q
+ FIRST=.FALSE.
+ ENDIF
+ Z=A+B*HWR()
+ XVAL=Z**Q
+ XJAC=XVAL*C/Z
+ 999 END
+CDECK ID>, HWRUNG.
+*CMZ :- -26/04/91 14.55.45 by Federico Carminati
+*-- Author : David Ward, modified by Bryan Webber
+C-----------------------------------------------------------------------
+ FUNCTION HWRUNG(A,B)
+C-----------------------------------------------------------------------
+C Random number from distribution having flat top [-A,A] & gaussian
+C tail of s.d. B
+C-----------------------------------------------------------------------
+ DOUBLE PRECISION HWRUNG,HWRGAU,HWRUNI,A,B,PRUN,ZERO
+ LOGICAL HWRLOG
+ EXTERNAL HWRGAU,HWRUNI,HWRLOG
+ PARAMETER (ZERO=0.D0)
+ IF (A.EQ.ZERO) THEN
+ PRUN=0
+ ELSE
+ PRUN=1./(1.+B*1.2533/A)
+ ENDIF
+ IF(HWRLOG(PRUN)) THEN
+ HWRUNG=HWRUNI(0,-A,A)
+ ELSE
+ HWRUNG=HWRGAU(0,ZERO,B)
+ HWRUNG=HWRUNG+SIGN(A,HWRUNG)
+ ENDIF
+ END
+CDECK ID>, HWRUNI.
+*CMZ :- -26/04/91 14.55.45 by Federico Carminati
+*-- Author : Bryan Webber
+C-----------------------------------------------------------------------
+ FUNCTION HWRUNI(I,A,B)
+C-----------------------------------------------------------------------
+C Uniform random random number in range [A,B]
+C-----------------------------------------------------------------------
+ DOUBLE PRECISION HWRUNI,HWR,A,B,RN
+ INTEGER I
+ EXTERNAL HWR
+ RN=HWR()
+ HWRUNI=A+RN*(B-A)
+ END
+CDECK ID>, HWSBRN.
+*CMZ :- -18/10/99 19.08.45 by Mike Seymour
+*-- Author : Bryan Webber
+C-----------------------------------------------------------------------
+ SUBROUTINE HWSBRN(KPAR)
+C-----------------------------------------------------------------------
+C DOES BRANCHING OF SPACELIKE PARTON KPAR
+C-----------------------------------------------------------------------
+ INCLUDE 'HERWIG61.INC'
+ DOUBLE PRECISION HWBVMC,HWR,HWRUNI,HWSTAB,HWUALF,HWUTAB,HWSGQQ,
+ & HWSSUD,XLAST,QNOW,QLST,QP,QMIN,QLAM,QSAV,SMAX,SLST,SNOW,RN,SUDA,
+ & SUDB,ZZ,ENOW,XI,PMOM,DIST(13),DMIN,X1,X2,REJFAC,OTHXI,OTHZ,QTMP,
+ & PTMP(2),JAC,OTHJAC,S,T,U
+ INTEGER N0,IS,ID,ID1,ID2,IDHAD,N1,I,MQ,NTRY,NDEL,NA,NB,IW1,IW2,
+ & KPAR,LPAR,MPAR,ISUD(13),IREJ,NREJ
+ LOGICAL HWSVAL,FORCE,VALPAR,FTMP
+ EXTERNAL HWBVMC,HWR,HWRUNI,HWSTAB,HWUALF,HWUTAB,HWSGQQ,HWSSUD,
+ & HWSVAL
+ COMMON/HWTABC/XLAST,N0,IS,ID
+ DATA ISUD,DMIN/2,2,3,4,5,6,2,2,3,4,5,6,1,1.D-15/
+ IF (IERROR.NE.0) RETURN
+ ID=IDPAR(KPAR)
+C--TEST FOR PARTON TYPE
+ IF (ID.LE.13) THEN
+ IS=ISUD(ID)
+ ELSEIF (ID.GE.208) THEN
+ IS=7
+ ELSE
+ IS=0
+ END IF
+ QNOW=-1.
+ IF (IS.NE.0) THEN
+C--SPACELIKE PARTON BRANCHING
+ QLST=PPAR(1,KPAR)
+ IDHAD=IDHW(INHAD)
+ VALPAR=HWSVAL(ID)
+ QP=HWBVMC(ID)
+ XLAST=XFACT*PPAR(4,KPAR)
+ IF (XLAST.GE.ONE) CALL HWWARN('HWSBRN',107,*999)
+C--SET UP Q BOUNDARY
+ IF (VALPAR) THEN
+ QMIN=QG/(1.-XLAST)
+ ELSEIF (ID.EQ.13) THEN
+ QMIN=QV/(1.-XLAST)
+ ELSE
+ QMIN=.5*(QP+QV+SQRT((QP-QV)**2+4.*QP*QV*XLAST))/(1.-XLAST)
+ ENDIF
+ QSAV=QMIN
+ IF (QMIN.LE.QSPAC.AND.ISPAC.LT.2) THEN
+ QMIN=QSPAC
+ N1=NSPAC(IS)
+ ELSEIF (QMIN.LE.QEV(1,IS)) THEN
+ QMIN=QEV(1,IS)
+ N1=1
+ ELSE
+ DO 110 I=2,NQEV
+ IF (QEV(I,IS).GT.QMIN) GOTO 120
+ 110 CONTINUE
+ 120 N1=I-1
+ ENDIF
+ N0=N1-1
+ MQ=NQEV-N0
+ NTRY=0
+ 125 NTRY=NTRY+1
+ NREJ=1
+ IF (QLST.GT.QMIN.AND..NOT.NOSPAC.OR..NOT.VALPAR) THEN
+ IF (QLST.LE.QMIN) THEN
+C--CHECK PHASE SPACE FOR FORCED SPLITTING OF NON-VALENCE PARTON
+ IF (QLST.LT.QSAV) CALL HWWARN('HWSBRN',ISLENT*105,*999)
+ FORCE=.TRUE.
+ QNOW=(QLST/QSAV)**HWR()*QSAV
+ ELSE
+C--ENHANCE EMISSION BY A FACTOR OF TWO IF THIS BRANCH
+C IS CAPABLE OF BEING THE HARDEST SO FAR
+ IF (QLST.GT.HARDST) NREJ=2
+ QTMP=-1
+ DO 300 IREJ=1,NREJ
+C--FIND NEW VALUE OF SUD/DIST
+ CALL HWSFUN(XLAST,QMIN,IDHAD,NSTRU,DIST,JNHAD)
+ IF (ID.EQ.13) DIST(ID)=DIST(ID)*HWSGQQ(QMIN)
+ IF (DIST(ID).LT.DMIN) DIST(ID)=DMIN
+ SMAX=HWUTAB(SUD(N1,IS),QEV(N1,IS),MQ,QMIN,INTER)/DIST(ID)
+ CALL HWSFUN(XLAST,QLST,IDHAD,NSTRU,DIST,JNHAD)
+ IF (ID.EQ.13) DIST(ID)=DIST(ID)*HWSGQQ(QLST)
+ IF (DIST(ID).LT.DMIN) DIST(ID)=DMIN
+ SLST=HWUTAB(SUD(N1,IS),QEV(N1,IS),MQ,QLST,INTER)/DIST(ID)
+ RN=HWR()
+ IF (RN.EQ.ZERO) THEN
+ SNOW=SLST*2.
+ ELSE
+ SNOW=SLST/RN
+ ENDIF
+ IF (VALPAR.AND.SNOW.GE.SMAX) GOTO 200
+ IF (SNOW.LT.SMAX.AND..NOT.NOSPAC) THEN
+ FORCE=.FALSE.
+ ELSE
+C--FORCE SPLITTING OF NON-VALENCE PARTON
+ FORCE=.TRUE.
+ QNOW=(MIN(QLST,1.1*QMIN)/QSAV)**HWR()*QSAV
+ ENDIF
+ IF (QNOW.LT.ZERO) THEN
+C--BRANCHING OCCURS. FIRST CHECK FOR MONOTONIC FORM FACTOR
+ SUDA=SMAX
+ NDEL=32
+ NA=N1
+ 130 NB=NA+NDEL
+ IF (NB.GT.NQEV) CALL HWWARN('HWSBRN',103,*999)
+ CALL HWSFUN(XLAST,QEV(NB,IS),IDHAD,NSTRU,DIST,JNHAD)
+ IF (ID.EQ.13) DIST(ID)=DIST(ID)*HWSGQQ(QEV(NB,IS))
+ IF (DIST(ID).LT.DMIN) DIST(ID)=DMIN
+ SUDB=SUD(NB,IS)/DIST(ID)
+ IF (SUDB.GT.SUDA) THEN
+ SUDA=SUDB
+ NA=NB
+ GOTO 130
+ ELSEIF (NA.NE.N1) THEN
+ IF (SUDB.LT.SNOW) THEN
+ NDEL=NDEL/2
+ IF (NDEL.EQ.0) CALL HWWARN('HWSBRN',100,*999)
+ GOTO 130
+ ENDIF
+ N1=NB
+ N0=N1-1
+ MQ=NQEV-N0
+ ENDIF
+C--NOW FIND NEW Q
+ QNOW=HWSTAB(QEV(N1,IS),HWSSUD,MQ,SNOW,INTER)
+ IF (QNOW.LE.QMIN.OR.QNOW.GT.QLST) THEN
+C--INTERPOLATION PROBLEM: USE LINEAR INSTEAD
+C CALL HWWARN('HWSBRN',1,*999)
+ QNOW=HWRUNI(0,QMIN,QLST)
+ ENDIF
+ ENDIF
+ 200 CONTINUE
+ IF (QNOW.GT.QTMP) THEN
+ QTMP=QNOW
+ FTMP=FORCE
+ ENDIF
+ QNOW=-1
+ 300 CONTINUE
+ QNOW=QTMP
+ FORCE=FTMP
+ ENDIF
+ IF (QNOW.LT.ZERO) GOTO 210
+C--NOW FIND NEW X
+ CALL HWSFBR(XLAST,QNOW,FORCE,ID,1,ID1,ID2,IW1,IW2,ZZ)
+ IF (ID1.LT.0) THEN
+C--NO PHASE SPACE FOR BRANCHING
+ FROST=.TRUE.
+ RETURN
+ ELSEIF (ID1.EQ.0) THEN
+C--BRANCHING REJECTED: REDUCE Q AND REPEAT
+ IF (NTRY.GT.NBTRY.OR.IERROR.NE.0)
+ $ CALL HWWARN('HWSBRN',102,*999)
+ QLST=QNOW
+ QNOW=-1.
+ GOTO 125
+ ELSEIF (ID1.EQ.59) THEN
+C--ANOMALOUS PHOTON SPLITTING: ADD PT TO INTRINSIC PT AND STOP BRANCHING
+ IF (IDHAD.NE.59) CALL HWWARN('HWSBRN',109,*999)
+ ENOW=PPAR(4,KPAR)/XLAST
+ XI=(QNOW/ENOW)**2
+ QLAM=QNOW*(1.-XLAST)
+ IF ((2.-XI)*QLAM**2.GT.EMSCA**2) THEN
+C--BRANCHING REJECTED: REDUCE Q AND REPEAT
+ IF (NTRY.GT.NBTRY) CALL HWWARN('HWSBRN',110,*999)
+ QLST=QNOW
+ QNOW=-1.
+ GOTO 125
+ ENDIF
+ CALL HWRAZM(QNOW*(1.-XLAST),PTMP(1),PTMP(2))
+ CALL HWVSUM(2,PTMP,PTINT(1,JNHAD),PTINT(1,JNHAD))
+ PTINT(3,JNHAD)=PTINT(1,JNHAD)**2+PTINT(2,JNHAD)**2
+ ANOMSC(1,JNHAD)=QNOW
+ ANOMSC(2,JNHAD)=QNOW*(1.-XLAST)
+ QNOW=-1.
+ QLST=QNOW
+ GOTO 125
+ ELSEIF (FORCE.AND..NOT.HWSVAL(ID1).AND.ID1.NE.13) THEN
+C--FORCED BRANCHING PRODUCED A NON-VALENCE PARTON: TRY AGAIN
+ IF (NTRY.GT.NBTRY) CALL HWWARN('HWSBRN',108,*999)
+ QLST=QNOW
+ QNOW=-1.
+ GOTO 125
+ ENDIF
+ ENDIF
+ 210 CONTINUE
+ IF (QNOW.GT.ZERO) THEN
+C--BRANCHING HAS OCCURRED
+ ENOW=PPAR(4,KPAR)/ZZ
+ XI=(QNOW/ENOW)**2
+ QLAM=QNOW*(1.-ZZ)
+ IF (SUDORD.EQ.1.AND.HWUALF(2,QLAM).LT.HWR() .OR.
+ & (2.-XI)*QLAM**2.GT.EMSCA**2.AND..NOT.FORCE) THEN
+C--BRANCHING REJECTED: REDUCE Q AND REPEAT
+ IF (NTRY.GT.NBTRY) CALL HWWARN('HWSBRN',104,*999)
+ QLST=QNOW
+ QNOW=-1.
+ GOTO 125
+ ENDIF
+C--IF THIS IS HARDEST EMISSION SO FAR, APPLY MATRIX-ELEMENT CORRECTION
+ IF (.NOT.FORCE) THEN
+ REJFAC=1
+ IF (QLAM.GT.HARDST .AND. ID.NE.13) THEN
+ IF (MOD(ISTHEP(JCOPAR(1,1)),10).GE.3) THEN
+C---COLOUR PARTNER IS OUTGOING (X1=XP, X2=ZP)
+ X2=SQRT((ZZ**2-(1-ZZ)*XI)**2+2*(ZZ*(1-ZZ))**2*XI*(2-XI))
+ X1=(ZZ**2+(1-ZZ)*XI-X2)/(2*(1-ZZ)*XI)
+ X2=(ZZ**2-(1-ZZ)*XI+X2)/(2*ZZ**2)
+ IF (ID2.EQ.13) THEN
+C---GLUON EMISSION
+ REJFAC=ZZ**3*(1-X1-X2+2*X1*X2)
+ $ /(X1**2*(1-ZZ)*(ZZ+XI*(1-ZZ)))
+ $ *(1+ZZ**2)/((1-ZZ)*XI)
+ $ *(1-X1)*(1-X2)/
+ $ (1+(1-X1-X2+2*X1*X2)**2+2*(1-X1)*(1-X2)*X1*X2)
+C---CHECK WHETHER IT IS IN THE OVERLAP REGION
+ OTHXI=2*(1-X1)/(1-X1+2*(3*X1-2)*X2*(1-X2))
+ IF (OTHXI.LT.ONE) THEN
+ OTHZ=(1-(2*X2-1)*SQRT((3*X1-2)/X1))/2
+ REJFAC=REJFAC+SQRT(3-2/X1)/(X1**2*OTHZ*(1-OTHZ))
+ $ *(1+(1-OTHZ)**2)/(OTHZ*OTHXI)
+ $ *(1-X1)*(1-X2)/
+ $ (1+(1-X1-X2+2*X1*X2)**2+2*(1-X1)*(1-X2)*X1*X2)
+ ENDIF
+ ELSEIF (ID1.EQ.13) THEN
+C---GLUON SPLITTING
+ REJFAC=ZZ**3*(1-X1-X2+2*X1*X2)
+ $ /(X1**2*(1-ZZ)*(ZZ+XI*(1-ZZ)))
+ $ *(ZZ**2+(1-ZZ)**2)/XI
+ $ *(1-X2)/
+ $ (( X1+X2-2*X1*X2)**2+2*(1-X1)*(1-X2)*X1*X2
+ $ +(1-X1-X2+2*X1*X2)**2+2*(1-X1)*(1-X2)*X1*X2)
+ ENDIF
+ ELSE
+C---COLOUR PARTNER IS ALSO INCOMING
+ T=-(1-ZZ)*XI/ZZ**2
+ S=2*(ZZ**2+(1-ZZ)*XI)/(ZZ**2*(2*ZZ+XI*(1-ZZ)))
+ U=1-S-T
+ JAC=-T*(1-T)/S**2*ZZ**5/(XI*(1-ZZ)**2*(ZZ+XI*(1-ZZ)))
+ IF (ID2.EQ.13) THEN
+C---GLUON EMISSION
+ REJFAC=(1+ZZ**2)/((1-ZZ)*ZZ*XI)
+ & *JAC*S**2*T*U/((1-U)**2+(1-T)**2)
+C---CHECK WHETHER IT IS IN THE OVERLAPPING REGION
+ OTHZ=(1+SQRT(1-2*U*(1-U)/S))/U
+ OTHXI=2*(1-OTHZ+T/S)/(1-OTHZ)
+ IF (OTHXI.LT.OTHZ**2) THEN
+ OTHJAC=-U*(1-U)/S**2*OTHZ**5/(OTHXI*
+ & (1-OTHZ)**2*(OTHZ+OTHXI*(1-OTHZ)))
+ REJFAC=REJFAC+(1+OTHZ**2)/((1-OTHZ)*OTHZ*OTHXI)
+ & *OTHJAC*S**2*T*U/((1-U)**2+(1-T)**2)
+ ENDIF
+ ELSEIF (ID1.EQ.13) THEN
+C---GLUON SPLITTING
+ REJFAC=-((1-ZZ)**2+ZZ**2)/(ZZ*XI)
+ & *JAC*S**3*T/((1-S)**2+(1-T)**2)
+ ENDIF
+ ENDIF
+ ENDIF
+ IF (NREJ*REJFAC*HWR().GT.ONE) THEN
+ QLST=QNOW
+ QNOW=-1.
+ GOTO 125
+ ENDIF
+ IF (QLAM.GT.HARDST) HARDST=QLAM
+ ENDIF
+ IF (IW2.GT.IW1) THEN
+ LPAR=NPAR+1
+ MPAR=NPAR+2
+C---NEW MOTHER-DAUGHTER RELATIONS
+C N.B. DEFINED MOVING AWAY FROM HARD PROCESS
+ JDAPAR(1,KPAR)=LPAR
+ JDAPAR(2,KPAR)=MPAR
+C---NEW COLOUR CONNECTIONS
+ JCOPAR(3,KPAR)=MPAR
+ JCOPAR(4,KPAR)=LPAR
+ JCOPAR(1,MPAR)=KPAR
+ JCOPAR(2,MPAR)=LPAR
+ JCOPAR(1,LPAR)=MPAR
+ JCOPAR(2,LPAR)=KPAR
+ ELSE
+ MPAR=NPAR+1
+ LPAR=NPAR+2
+ JDAPAR(1,KPAR)=MPAR
+ JDAPAR(2,KPAR)=LPAR
+ JCOPAR(3,KPAR)=LPAR
+ JCOPAR(4,KPAR)=MPAR
+ JCOPAR(1,MPAR)=LPAR
+ JCOPAR(2,MPAR)=KPAR
+ JCOPAR(1,LPAR)=KPAR
+ JCOPAR(2,LPAR)=MPAR
+ ENDIF
+ JMOPAR(1,LPAR)=KPAR
+ JMOPAR(1,MPAR)=KPAR
+ IDPAR(LPAR)=ID1
+ IDPAR(MPAR)=ID2
+ TMPAR(LPAR)=.FALSE.
+ TMPAR(MPAR)=.TRUE.
+ PPAR(1,LPAR)=QNOW
+ PPAR(2,LPAR)=XI
+ PPAR(4,LPAR)=ENOW
+ PPAR(1,MPAR)=QNOW*(1.-ZZ)
+ PPAR(2,MPAR)=XI
+ PPAR(4,MPAR)=ENOW*(1.-ZZ)
+ NPAR=NPAR+2
+ ENDIF
+ ENDIF
+ IF (QNOW.LT.ZERO) THEN
+C--BRANCHING STOPS
+ JDAPAR(1,KPAR)=0
+ JDAPAR(2,KPAR)=0
+ JCOPAR(3,KPAR)=0
+ JCOPAR(4,KPAR)=0
+ IF (ID.LE.13) THEN
+C---PUT SPECTATOR (APPROXIMATELY) ON-SHELL
+ XLAST=XFACT*PPAR(4,KPAR)
+ IF ((1-XLAST)**2.LT.(RMASS(ID)**2+PTINT(3,JNHAD))*XFACT**2)
+ & THEN
+ FROST=.TRUE.
+ RETURN
+ ENDIF
+ PPAR(5,KPAR)=-(RMASS(ID)**2*XLAST+PTINT(3,JNHAD))/(1.-XLAST)
+ & +XLAST*SIGN(PHEP(5,INHAD)**2,PHEP(5,INHAD))
+ ELSEIF (ID.EQ.IDHW(INHAD)) THEN
+C---IF INCOMING PARTON IS INCOMING BEAM, ALLOW IT TO BE OFF-SHELL
+ PPAR(5,KPAR)=SIGN(PHEP(5,INHAD)**2,PHEP(5,INHAD))
+ ELSE
+ PPAR(5,KPAR)=RMASS(ID)**2
+ ENDIF
+ PMOM=PPAR(4,KPAR)**2-PPAR(5,KPAR)
+ IF (PMOM.LT.ZERO) THEN
+ FROST=.TRUE.
+ RETURN
+ ENDIF
+ PPAR(3,KPAR)=SQRT(PMOM)
+ ENDIF
+ 999 END
+CDECK ID>, HWSDGG.
+*CMZ := =26/04/91 12.47.48 by Federico Carminati
+*-- Author : Drees, Grassie, Charchula, modified by Bryan Webber
+C ===============================================================
+C DREES & GRASSIE PARAMETRIZATION OF PHOTON STRUCTURE FUNCTION
+C
+C HWSDGQ(X,Q2,NFL,NCH) - X*QUARK_IN_PHOTON/ALPHA (!)
+C HWSDGG(X,Q2,NFL) - X*GLUON_IN_PHOTON/ALPHA (!)
+C WHERE:
+C (INTEGER) NCH - QUARK CHARGE: 1 FOR 1/3
+C 2 FOR 2/3
+C (INTEGER) NFL - NUMBER OF QUARK FLAVOURS /3 OR 4/
+C Q2 - SQUARE OF MOMENTUM Q /IN GEV2/
+C X - LONGITUDINAL FRACTION
+C LAMBDA=0.4 GEV
+C
+C NFL=3: 1 < Q2 < 50 GEV^2
+C NFL=4: 20 < Q2 < 500 GEV^2
+C NFL=5: 200 < Q2 < 10^4 GEV^2
+C
+C
+C KRZYSZTOF CHARCHULA /14.02.1989/
+C================================================================
+C
+C PS. Note that for the case of three flavors, one has to add
+C the QPM charm contribution for getting F2.
+C
+C================================================================
+C MODIFIED FOR HERWIG BY BRW 19/4/91
+C--- -----------------------------------------------
+C GLUON PART OF THE PHOTON SF
+C--- -----------------------------------------------
+ FUNCTION HWSDGG(X,Q2,NFL)
+ IMPLICIT REAL (A-H,P-Z)
+ INTEGER NFL
+ DIMENSION A(3,4,3),AT(3)
+ ALAM2=0.160
+ T=LOG(Q2/ALAM2)
+C- --- CHECK WHETHER NFL HAVE RIGHT VALUES -----
+ IF (.NOT.((NFL.EQ.3).OR.(NFL.EQ.4).OR.(NFL.EQ.5)))THEN
+ 130 WRITE(6,131)
+ 131 FORMAT(' NUMBER OF FLAVOURS(NFL) HAS NOT BEEN SET TO: 3,4 OR 5;'/
+ *' NFL=3 IS ASSUMED')
+ NFL=3
+ ELSEIF (T.LE.0) THEN
+ WRITE(6,132)
+ 132 FORMAT(' HWSDGG CALLED WITH SCALE < LAMBDA. RETURNING ZERO.')
+ HWSDGG=0
+ RETURN
+ ENDIF
+C ------ INITIALIZATION OF PARAMETERS ARRAY -----
+ DATA(((A(I,J,K),I=1,3),J=1,4),K=1,3)/
+ + -0.20700,-0.19870, 5.11900,
+ + 0.61580, 0.62570,-0.27520,
+ + 1.07400, 8.35200,-6.99300,
+ + 0.00000, 5.02400, 2.29800,
+ + 0.8926E-2, 0.05090,-0.23130,
+ + 0.659400, 0.27740, 0.13820,
+ + 0.476600,-0.39060, 6.54200,
+ + 0.019750,-0.32120, 0.51620,
+ + 0.031970, -0.618E-2, -0.1216,
+ + 1.0180, 0.94760, 0.90470,
+ + 0.24610, -0.60940, 2.6530,
+ + 0.027070, -0.010670, 0.2003E-2/
+C ------ Q2 DEPENDENCE -----------
+ LF=NFL-2
+ DO 20 I=1,3
+ AT(I)=A(I,1,LF)*T**A(I,2,LF)+A(I,3,LF)*T**(-A(I,4,LF))
+ 20 CONTINUE
+C ------ GLUON DISTRIBUTION -------------
+ HWSDGG=AT(1)*X**AT(2)*(1.0-X)**AT(3)/137.
+ RETURN
+ END
+CDECK ID>, HWSDGQ.
+*CMZ :- -26/04/91 13.04.45 by Federico Carminati
+*-- Author : Drees, Grassie, Charchula, modified by Bryan Webber
+C --------------------------------------
+C QUARK PART OF THE PHOTON SF
+C --------------------------------------
+ FUNCTION HWSDGQ(X,Q2,NFL,NCH)
+ IMPLICIT REAL (A-H,P-Z)
+ INTEGER NFL,NCH
+ DIMENSION A(5,4,2,3),AT(5,2),XQPOM(2),E(2)
+ COMMON/DG/F2
+C SQUARE OF LAMBDA=0.4 GEV
+ ALAM2=0.160
+ T=LOG(Q2/ALAM2)
+C
+C CHECK WHETHER NFL AND NCH HAVE RIGHT VALUES
+C
+ IF(.NOT.((NFL.EQ.3).OR.(NFL.EQ.4).OR.(NFL.EQ.5))) THEN
+ 110 WRITE(6,111)
+ 111 FORMAT('NUMBER OF FLAVOURS (NFL) HAS NOT BEEN SET TO: 3,4 OR 5'/
+ *' NFL=3 IS ASSUMED')
+ NFL=3
+ ELSEIF (T.LE.0) THEN
+ WRITE(6,132)
+ 132 FORMAT(' HWSDGQ CALLED WITH SCALE < LAMBDA. RETURNING ZERO.')
+ HWSDGQ=0
+ RETURN
+ ENDIF
+ IF (.NOT.((NCH.EQ.1).OR.(NCH.EQ.2))) THEN
+ 120 WRITE(6,121)
+ 121 FORMAT(' QUARK CHARGE NUMBER (NCH) HAS NOT BEEN SET',
+ *' TO 1 OR 2;'/
+ *' NCH=1 IS ASSUMED')
+ NCH=1
+ ENDIF
+C ------ INITIALIZATION ------
+ DATA(((A(I,J,K,1),I=1,5),J=1,4),K=1,2)/
+ + 2.28500, 6.07300, -0.42020,-0.08080, 0.05530,
+ +-0.01530, -0.81320, 0.01780, 0.63460, 1.13600,
+ + 1.3300E3,-41.3100, 0.92160, 1.20800, 0.95120,
+ + 4.21900, 3.16500, 0.18000, 0.20300, 0.01160,
+ +16.6900, 0.17600, -0.02080,-0.01680,-0.19860,
+ +-0.79160, 0.04790, 0.3386E-2,1.35300, 1.10000,
+ + 1.0990E3, 1.04700, 4.85300, 1.42600, 1.13600,
+ + 4.42800, 0.02500, 0.84040, 1.23900,-0.27790/
+ DATA(((A(I,J,K,2),I=1,5),J=1,4),K=1,2)/
+ +-0.37110,-0.17170, 0.087660,-0.89150,-0.18160,
+ + 1.06100, 0.78150, 0.021970, 0.28570, 0.58660,
+ + 4.75800, 1.53500, 0.109600, 2.97300, 2.42100,
+ +-0.01500, 0.7067E-2,0.204000, 0.11850, 0.40590,
+ +-0.12070,25.00000,-0.012300,-0.09190, 0.020150,
+ + 1.07100,-1.64800, 1.162000, 0.79120, 0.98690,
+ + 1.97700,-0.015630,0.482400, 0.63970,-0.070360,
+ +-0.8625E-2,6.43800,-0.011000, 2.32700, 0.016940/
+ DATA(((A(I,J,K,3),I=1,5),J=1,4),K=1,2)/
+ +15.80, 2.7420, 0.029170,-0.03420, -0.023020,
+ +-0.94640, -0.73320, 0.046570, 0.71960, 0.92290,
+ +-0.50, 0.71480, 0.17850, 0.73380, 0.58730,
+ +-0.21180, 3.2870, 0.048110, 0.081390,-0.79E-4,
+ + 6.7340, 59.880, -0.3226E-2,-0.03321, 0.10590,
+ +-1.0080, -2.9830, 0.84320, 0.94750, 0.69540,
+ +-0.085940, 4.480, 0.36160, -0.31980, -0.66630,
+ + 0.076250, 0.96860, 0.1383E-2, 0.021320, 0.36830/
+ CF=10.0
+C ------- EVALUATION OF PARAMETERS IN Q2 ---------
+ E(1)=1.0
+ IF (NFL.EQ.3) THEN
+ E(2)=9.0
+ LF=1
+ ELSEIF (NFL.EQ.4) THEN
+ E(2)=10.0
+ LF=2
+ ELSEIF (NFL.EQ.5) THEN
+ E(2)=55.0/6.0
+ LF=3
+ ENDIF
+ DO 10 J=1,2
+ DO 20 I=1,5
+ ATP=A(I,1,J,LF)*T**A(I,2,J,LF)
+ AT(I,J)=ATP+A(I,3,J,LF)*T**(-A(I,4,J,LF))
+ 20 CONTINUE
+ 10 CONTINUE
+ DO 30 J=1,2
+ POM1=X*(X*X+(1.0-X)**2)/(AT(1,J)-AT(2,J)*ALOG(1.0-X))
+ POM2=AT(3,J)*X**AT(4,J)*(1.0-X)**AT(5,J)
+ XQPOM(J)=E(J)*POM1+POM2
+ 30 CONTINUE
+C ------- QUARK DISTRIBUTIONS ----------
+ IF (NFL.EQ.3) THEN
+ IF (NCH.EQ.2) THEN
+ HWSDGQ=1.0/6.0*(XQPOM(2)+9.0*XQPOM(1))
+ ELSEIF(NCH.EQ.1) THEN
+ HWSDGQ=1.0/6.0*(XQPOM(2)-9.0/2.0*XQPOM(1))
+ ENDIF
+ F2=2.0/9.0*XQPOM(2)+XQPOM(1)
+ ELSEIF (NFL.EQ.4) THEN
+ IF (NCH.EQ.2) THEN
+ HWSDGQ=1.0/8.0*(XQPOM(2)+6.0*XQPOM(1))
+ ELSEIF(NCH.EQ.1) THEN
+ HWSDGQ=1.0/8.0*(XQPOM(2)-6.0*XQPOM(1))
+ ENDIF
+ F2=5.0/18.0*XQPOM(2)+XQPOM(1)
+ ELSEIF (NFL.EQ.5) THEN
+ IF (NCH.EQ.2) THEN
+ HWSDGQ=1.0/10.0*(XQPOM(2)+15.0/2.0*XQPOM(1))
+ ELSEIF(NCH.EQ.1) THEN
+ HWSDGQ=1.0/10.0*(XQPOM(2)-5.0*XQPOM(1))
+ ENDIF
+ F2=11.0/45.0*XQPOM(2)+XQPOM(1)
+ ENDIF
+ HWSDGQ=HWSDGQ/137.
+ RETURN
+ END
+CDECK ID>, HWSFBR.
+*CMZ :- -15/07/92 14.08.45 by Mike Seymour
+*-- Author : Bryan Webber
+C-----------------------------------------------------------------------
+ SUBROUTINE HWSFBR(X,QQ,FORCED,ID,IW,ID1,ID2,IW1,IW2,Z)
+C-----------------------------------------------------------------------
+C FINDS BRANCHING (ID1->ID+ID2) AND Z=X/X1 IN BACKWARD
+C EVOLUTION AT ENERGY FRACTION X AND SCALE QQ
+C
+C FORCED=.TRUE. FORCES SPLITTING OF NON-VALENCE PARTON
+C
+C IW,IW1,IW2 ARE COLOUR CONNECTION WORDS
+C
+C ID1.LT.0 ON RETURN MEANS NO PHASE SPACE
+C ID1.EQ.0 ON RETURN FLAGS REJECTED BRANCHINGS
+C-----------------------------------------------------------------------
+ INCLUDE 'HERWIG61.INC'
+ DOUBLE PRECISION HWBVMC,HWR,HWUALF,HWUAEM,QP,X,QQ,Z,WQG,WQV,
+ & WQP,XQV,ZMIN,ZMAX,YMIN,YMAX,DELY,YY,PSUM,EZ,WQN,WR,ZR,WZ,ZZ,AZ,
+ & PVAL,EY,DIST(13),PROB(13,100),PPHO
+ INTEGER ID,IW,ID1,ID2,IW1,IW2,NZ,IDHAD,IP,IZ
+ LOGICAL HWRLOG,HWSVAL,FORCED,NONF,NONV,PHOTPR
+ EXTERNAL HWBVMC,HWR,HWUALF,HWUAEM,HWRLOG,HWSVAL
+ ID1=-1
+ QP=HWBVMC(ID)
+ WQG=1.-QG/QQ
+ WQV=1.-QV/QQ
+ WQP=1.-QP/QQ
+ XQV=X/WQV
+ NONV=.NOT.HWSVAL(ID)
+ NONF=.NOT.FORCED
+ 5 IF (ID.EQ.13) THEN
+ ZMIN=X
+ IF (NONF) THEN
+ ZMAX=WQG
+ ELSE
+ ZMAX=WQV
+ ENDIF
+ ELSE
+ IF (NONV) THEN
+ ZMIN=XQV
+ IF (NONF) THEN
+ ZMAX=WQG
+ ELSE
+ ZMAX=WQP
+ ENDIF
+ ELSE
+ ZMIN=X
+ ZMAX=MAX(WQG,WQP)
+ ENDIF
+ ENDIF
+ IF (ZMIN.GE.ZMAX) RETURN
+ ID1=0
+C---INTERPOLATION VARIABLE IS Y=LN(Z/(1-Z))
+ YMIN=LOG(ZMIN/(1.-ZMIN))
+ YMAX=LOG(ZMAX/(1.-ZMAX))
+ DELY=YMAX-YMIN
+ NZ=MIN(INT(ZBINM*DELY)+1,NZBIN)
+ DELY=(YMAX-YMIN)/FLOAT(NZ)
+ YY=YMIN+0.5*DELY
+ PSUM=0.
+ IDHAD=IDHW(INHAD)
+C---SET UP TABLES FOR CHOOSING BRANCHING
+ DO 40 IZ=1,NZ
+ EZ=EXP(YY)
+ WR=1.+EZ
+ ZR=WR/EZ
+ WZ=1./WR
+ ZZ=WZ*EZ
+ AZ=WZ*ZZ*HWUALF(5-2*SUDORD,MAX(WZ*QQ,QG))
+ CALL HWSFUN(X*ZR,QQ,IDHAD,NSTRU,DIST,JNHAD)
+ IF (ID.NE.13) THEN
+C---SPLITTING INTO QUARK
+ DO 10 IP=1,ID-1
+ 10 PROB(IP,IZ)=PSUM
+ IF (NONF) PSUM=PSUM+DIST(ID)*AZ*CFFAC*(1.+ZZ*ZZ)*WR
+ DO 20 IP=ID,12
+ 20 PROB(IP,IZ)=PSUM
+ PSUM=PSUM+DIST(13)*AZ*0.5*(ZZ*ZZ+WZ*WZ)
+ PROB(13,IZ)=PSUM
+ ELSE
+C---SPLITTING INTO GLUON
+ DO 30 IP=1,12
+ PSUM=PSUM+DIST(IP)*AZ*CFFAC*(1.+WZ*WZ)*ZR
+ 30 PROB(IP,IZ)=PSUM
+ IF (NONF) PSUM=PSUM+DIST(13)*AZ*2.*CAFAC*(WZ*ZR+ZZ*WR+WZ*ZZ)
+ PROB(13,IZ)=PSUM
+ ENDIF
+ 40 YY=YY+DELY
+ 50 PHOTPR=IDHAD.EQ.59.AND.ID.NE.13
+ IF (PHOTPR) THEN
+C---ALLOW ANOMALOUS PHOTON SPLITTING
+ PPHO=HWUAEM(-QQ*QQ)*CAFAC*(ZMIN**2+(1.-ZMIN)**2)
+ & *ICHRG(ID)**2/(18.*PIFAC)
+ IF (PPHO.GT.(PPHO+PSUM*DELY)*HWR()) THEN
+C---ANOMALOUS PHOTON SPLITTING OCCURRED
+ ID1=59
+ RETURN
+ ENDIF
+ ENDIF
+ IF (PSUM.LE.ZERO) RETURN
+C---CHOOSE Z
+ PVAL=PSUM*HWR()
+ DO 60 IZ=1,NZ
+ IF (PROB(13,IZ).GT.PVAL) GOTO 70
+ 60 CONTINUE
+ IZ=NZ
+ 70 EY=EXP(YMIN+DELY*(FLOAT(IZ)-HWR()))
+ ZZ=EY/(1.+EY)
+C---CHOOSE BRANCHING
+ DO 80 IP=1,13
+ IF (PROB(IP,IZ).GT.PVAL) GOTO 90
+ 80 CONTINUE
+ IP=13
+C---CHECK THAT Z IS INSIDE PHASE SPACE (RETURN IF NOT)
+ 90 CONTINUE
+ IF (ID.NE.13) THEN
+ IF (IP.EQ.ID) THEN
+ IF ((NONV.AND.ZZ*WQP.LT.XQV).OR.ZZ.GT.WQG) THEN
+ IF (PHOTPR) GOTO 50
+ RETURN
+ ENDIF
+ ELSE
+ IF (ZZ.LT.XQV.OR.ZZ.GT.WQP) THEN
+ IF (PHOTPR) GOTO 50
+ RETURN
+ ENDIF
+ ENDIF
+ ELSE
+ IF (IP.EQ.ID) THEN
+ IF (ZZ.LT.XQV.OR.ZZ.GT.WQG) RETURN
+ ELSEIF (.NOT.HWSVAL(IP)) THEN
+ WQN=1.-HWBVMC(IP)/QQ
+ IF (ZZ*WQN.LT.XQV.OR.ZZ.GT.WQN) RETURN
+ ENDIF
+ ENDIF
+C---EVERYTHING OK: LABEL NEW BRANCHES
+ Z=ZZ
+ ID1=IP
+ IW1=IW*2
+ IW2=IW1+1
+ IF (ID.LE.6) THEN
+ IF (ID1.EQ.13) THEN
+ ID2=ID+6
+ ELSE
+ ID2=13
+ IW2=IW1
+ ENDIF
+ ELSE IF (ID.NE.13) THEN
+ IF (ID1.EQ.13) THEN
+ ID2=ID-6
+ IW2=IW1
+ ELSE
+ ID2=13
+ ENDIF
+ ELSE
+ ID2=ID1
+ IF (ID1.EQ.13) THEN
+ IF (HWRLOG(HALF)) IW2=IW1
+ ELSE IF (ID1.GT.6) THEN
+ IW2=IW1
+ END IF
+ END IF
+ IF (IW2.EQ.IW1) IW1=IW1+1
+ 999 END
+CDECK ID>, HWSFUN.
+*CMZ :- -02/05/91 11.30.51 by Federico Carminati
+*-- Author : Miscellaneous, combined by Bryan Webber
+C-----------------------------------------------------------------------
+ SUBROUTINE HWSFUN(X,SCALE,IDHAD,NSET,DIST,IBEAM)
+C-----------------------------------------------------------------------
+C NUCLEON AND PION STRUCTURE FUNCTIONS DIST=X*QRK(X,Q=SCALE)
+C
+C IDHAD = TYPE OF HADRON:
+C 73=P 91=PBAR 75=N 93=NBAR 38=PI+ 30=PI- 59=PHOTON
+C
+C NEW SPECIAL CODES:
+C 71=`REMNANT PHOTON' 72=`REMNANT NUCLEON'
+C
+C NSET = STRUCTURE FUNCTION SET
+C = 1,2 FOR DUKE+OWENS SETS 1,2 (SOFT/HARD GLUE)
+C = 3,4 FOR EICHTEN ET AL SETS 1,2 (NUCLEON ONLY)
+C = 5 FOR OWENS SET 1.1 (PREPRINT FSU-HEP-910606)
+C
+C FOR PHOTON DREES+GRASSIE IS USED
+C
+C N.B. IF IBEAM.GT.0.AND.MODPDF(IBEAM).GE.0 THEN NSET IS
+C IGNORED AND CERN PDFLIB WITH AUTHOR GROUP=AUTPDF(IBEAM) AND
+C SET=MODPDF(IBEAM) IS USED. FOR COMPATABILITY WITH VERSIONS 3
+C AND EARLIER, AUTPDF SHOULD BE SET TO 'MODE'
+C NOTE THAT NO CONSISTENCY CHECK IS MADE, FOR EXAMPLE THAT THE
+C REQUESTED SET FOR A PHOTON IS ACTUALLY A PHOTON SET
+C
+C IF (ISPAC.GT.0) SCALE IS REPLACED BY MAX(SCALE,QSPAC)
+C
+C FOR PHOTON, IF (PHOMAS.GT.0) THEN QUARK DISTRIBUTIONS ARE
+C SUPPRESSED BY LOG((Q**2+PHOMAS**2)/(P**2+PHOMAS**2))
+C L = -------------------------------------- ,
+C LOG((Q**2+PHOMAS**2)/( PHOMAS**2))
+C WHILE GLUON DISTRIBUTIONS ARE SUPPRESSED BY L**2,
+C WHERE Q=SCALE AND P=VIRTUALITY OF THE PHOTON
+C
+C DUKE+OWENS = D.W.DUKE AND J.F.OWENS, PHYS. REV. D30 (1984) 49 (P/N)
+C + J.F.OWENS, PHYS. REV. D30 (1984) 943 (PI+/-)
+C WITH EXTRA SIGNIFICANT FIGURES VIA ED BERGER
+C WARNING....MOMENTUM SUM RULE BADLY VIOLATED ABOVE 1 TEV
+C DUKE+OWENS SETS 1,2 OBSOLETE. SET 1 UPDATED TO OWENS 1.1 (1991)
+C PION NOT RELIABLE ABOVE SCALE = 50 GEV
+C
+C EICHTEN ET AL = E.EICHTEN,I.HINCHLIFFE,K.LANE AND C.QUIGG,
+C REV. MOD. PHYS. 56 (1984) 579
+C REVISED AS IN REV. MOD. PHYS. 58 (1986) 1065
+C RELIABLE RANGE : SQRT(5)GEV < SCALE < 10TEV, 1E-4 < X < 1
+C
+C DREES+GRASSIE = M.DREES & K.GRASSIE, ZEIT. PHYS. C28 (1985) 451
+C MODIFIED IN M.DREES & C.S.KIM, DESY 91-039
+C AND C.S.KIM, DTP/91/16 FOR HEAVY QUARKS
+C
+C FOR CERN PDFLIB DETAILS SEE PDFLIB DOC Q ON CERNVM OR
+C CERN_ROOT:[DOC]PDFLIB.TXT ON VXCERN
+C-----------------------------------------------------------------------
+ INCLUDE 'HERWIG61.INC'
+ DOUBLE PRECISION HWSGAM,X,SCALE,XOLD,QOLD,XMWN,QSCA,SS,SMIN,S,T,
+ & TMIN,TMAX,VX,AA,VT,WT,UPV,DNV,SEA,STR,CHM,BTM,TOP,GLU,WX,XQSUM,
+ & DMIN,TPMIN,TPMAX,DIST(13),G(2),Q0(5),QL(5),F(5),A(6,5),
+ & B(3,6,5,4),XQ(6),TX(6),TT(6),TB(6),NEHLQ(8,2),CEHLQ(6,6,2,8,2),
+ & BB(4,6,5),VAL(20),USEA,DSEA,TOTAL,SCALEF,FAC,TBMIN(2),TTMIN(2)
+ REAL HWSDGG,HWSDGQ,XSP,Q2,P2,W2,EMB2,EMC2,ALAM2,XPGA(-6:6),F2GM,
+ & XPVMD,XPANL,XPANH,XPBEH,XPDIR
+ COMMON/SASCOM/XPVMD(-6:6),XPANL(-6:6),XPANH(-6:6),XPBEH(-6:6),
+ & XPDIR(-6:6)
+ LOGICAL PDFWRX(2,2),PDFWRQ(2,2)
+ DOUBLE PRECISION PDFXMN,PDFXMX,PDFQMN,PDFQMX
+ COMMON /W50513/PDFXMN,PDFXMX,PDFQMN,PDFQMX
+ INTEGER IDHAD,NSET,IBEAM,IOLD,NOLD,IP,I,J,K,NX,IT,IX,IFL,NFL,
+ & MPDF,IHAD,ISET,IOP1,IOP2,IP2
+ CHARACTER*20 PARM(20)
+ EXTERNAL HWSGAM,HWSDGG,HWSDGQ
+ SAVE QOLD,IOLD,NOLD,XOLD,SS,S,T,TMIN,TMAX,G,A,TX,TT,TB,IP,NX
+ DATA PDFWRX,PDFWRQ/8*.TRUE./
+ DATA (((B(I,J,K,1),I=1,3),J=1,6),K=1,5)/
+ &3.,0.,0.,.419,.004383,-.007412,
+ &3.46,.72432,-.065998,4.4,-4.8644,1.3274,
+ &6*0.,1.,
+ &0.,0.,.763,-.23696,.025836,4.,.62664,-.019163,
+ &0.,-.42068,.032809,6*0.,1.265,-1.1323,.29268,
+ &0.,-.37162,-.028977,8.05,1.5877,-.15291,
+ &0.,6.3059,-.27342,0.,-10.543,-3.1674,
+ &0.,14.698,9.798,0.,.13479,-.074693,
+ &-.0355,-.22237,-.057685,6.3494,3.2649,-.90945,
+ &0.,-3.0331,1.5042,0.,17.431,-11.255,
+ &0.,-17.861,15.571,1.564,-1.7112,.63751,
+ &0.,-.94892,.32505,6.,1.4345,-1.0485,
+ &9.,-7.1858,.25494,0.,-16.457,10.947,
+ &0.,15.261,-10.085/
+ DATA (((B(I,J,K,2),I=1,3),J=1,6),K=1,5)/
+ &3.,0.,0.,.3743,.013946,-.00031695,
+ &3.329,.75343,-.076125,6.032,-6.2153,1.5561,
+ &6*0.,1.,0.,
+ &0.,.7608,-.2317,.023232,3.83,.62746,-.019155,
+ &0.,-.41843,.035972,6*0.,1.6714,-1.9168,.58175,
+ &0.,-.27307,-.16392,9.145,.53045,-.76271,
+ &0.,15.665,-2.8341,0.,-100.63,44.658,
+ &0.,223.24,-116.76,0.,.067368,-.030574,
+ &-.11989,-.23293,-.023273,3.5087,3.6554,-.45313,
+ &0.,-.47369,.35793,0.,9.5041,-5.4303,
+ &0.,-16.563,15.524,.8789,-.97093,.43388,
+ &0.,-1.1612,.4759,4.,1.2271,-.25369,
+ &9.,-5.6354,-.81747,0.,-7.5438,5.5034,
+ &0.,-.59649,.12611/
+ DATA (((B(I,J,K,3),I=1,3),J=1,6),K=1,5)/
+ &1.,0.,0.,0.4,-0.06212,-0.007109,0.7,0.6478,0.01335,27*0.,
+ &0.9,-0.2428,0.1386,0.,-0.2120,0.003671,5.0,0.8673,0.04747,
+ &0.,1.266,-2.215,0.,2.382,0.3482,3*0.,
+ &0.,0.07928,-0.06134,-0.02212,-0.3785,-0.1088,2.894,9.433,
+ &-10.852,0.,5.248,-7.187,0.,8.388,-11.61,3*0.,
+ &0.888,-1.802,1.812,0.,-1.576,1.20,3.11,-0.1317,0.5068,
+ &6.0,2.801,-12.16,0.,-17.28,20.49,3*0./
+ DATA (((B(I,J,K,4),I=1,3),J=1,6),K=1,5)/
+ &1.,0.,0.,0.4,-0.05909,-0.006524,0.628,0.6436,0.01451,27*0.,
+ &0.90,-0.1417,-0.1740,0.,-0.1697,-0.09623,5.0,-2.474,1.575,
+ &0.,-2.534,1.378,0.,0.5621,-0.2701,3*0.,
+ &0.,0.06229,-0.04099,-0.0882,-0.2892,-0.1082,1.924,0.2424,
+ &2.036,0.,-4.463,5.209,0.,-0.8367,-0.04840,3*0.,
+ &0.794,-0.9144,0.5966,0.,-1.237,0.6582,2.89,0.5966,-0.2550,
+ &6.0,-3.671,-2.304,0.,-8.191,7.758,3*0./
+C---COEFFTS FOR NEW OWENS 1.1 SET
+ DATA BB/3.,3*0.,.665,-.1097,-.002442,0.,
+ &3.614,.8395,-.02186,0.,.8673,-1.6637,.342,0.,
+ &0.,1.1049,-.2369,5*0.,1.,3*0.,
+ &.8388,-.2092,.02657,0.,4.667,.7951,.1081,0.,
+ &0.,-1.0232,.05799,0.,0.,.8616,.153,5*0.,
+ &.909,-.4023,.006305,0.,
+ &0.,-.3823,.02766,0.,7.278,-.7904,.8108,0.,
+ &0.,-1.6629,.5719,0.,0.,-.01333,.5299,0.,
+ &0.,.1211,-.1739,0.,0.,.09469,-.07066,.01236,
+ &-.1447,-.402,.1533,-.06479,6.7599,1.6596,.6798,-.8525,
+ &0.,-4.4559,3.3756,-.9468,
+ &0.,7.862,-3.6591,.03672,0.,-.2472,-.751,.0487,
+ &3.017,-4.7347,3.3594,-.9443,0.,-.9342,.5454,-.1668,
+ &5.304,1.4654,-1.4292,.7569,0.,-3.9141,2.8445,-.8411,
+ &0.,9.0176,-10.426,4.0983,0.,-5.9602,7.515,-2.7329/
+C...THE FOLLOWING DATA LINES ARE COEFFICIENTS NEEDED IN THE
+C...EICHTEN, HINCHLIFFE, LANE, QUIGG PROTON STRUCTURE FUNCTION
+C...POWERS OF 1-X IN DIFFERENT CASES
+ DATA NEHLQ/3,4,7,5,7,7,7,7,3,4,7,6,7,7,7,7/
+C...EXPANSION COEFFICIENTS FOR UP VALENCE QUARK DISTRIBUTION
+ DATA (((CEHLQ(IX,IT,NX,1,1),IX=1,6),IT=1,6),NX=1,2)/
+ 1 7.677E-01,-2.087E-01,-3.303E-01,-2.517E-02,-1.570E-02,-1.000E-04,
+ 2-5.326E-01,-2.661E-01, 3.201E-01, 1.192E-01, 2.434E-02, 7.620E-03,
+ 3 2.162E-01, 1.881E-01,-8.375E-02,-6.515E-02,-1.743E-02,-5.040E-03,
+ 4-9.211E-02,-9.952E-02, 1.373E-02, 2.506E-02, 8.770E-03, 2.550E-03,
+ 5 3.670E-02, 4.409E-02, 9.600E-04,-7.960E-03,-3.420E-03,-1.050E-03,
+ 6-1.549E-02,-2.026E-02,-3.060E-03, 2.220E-03, 1.240E-03, 4.100E-04,
+ 1 2.395E-01, 2.905E-01, 9.778E-02, 2.149E-02, 3.440E-03, 5.000E-04,
+ 2 1.751E-02,-6.090E-03,-2.687E-02,-1.916E-02,-7.970E-03,-2.750E-03,
+ 3-5.760E-03,-5.040E-03, 1.080E-03, 2.490E-03, 1.530E-03, 7.500E-04,
+ 4 1.740E-03, 1.960E-03, 3.000E-04,-3.400E-04,-2.900E-04,-1.800E-04,
+ 5-5.300E-04,-6.400E-04,-1.700E-04, 4.000E-05, 6.000E-05, 4.000E-05,
+ 6 1.700E-04, 2.200E-04, 8.000E-05, 1.000E-05,-1.000E-05,-1.000E-05/
+ DATA (((CEHLQ(IX,IT,NX,1,2),IX=1,6),IT=1,6),NX=1,2)/
+ 1 7.237E-01,-2.189E-01,-2.995E-01,-1.909E-02,-1.477E-02, 2.500E-04,
+ 2-5.314E-01,-2.425E-01, 3.283E-01, 1.119E-01, 2.223E-02, 7.070E-03,
+ 3 2.289E-01, 1.890E-01,-9.859E-02,-6.900E-02,-1.747E-02,-5.080E-03,
+ 4-1.041E-01,-1.084E-01, 2.108E-02, 2.975E-02, 9.830E-03, 2.830E-03,
+ 5 4.394E-02, 5.116E-02,-1.410E-03,-1.055E-02,-4.230E-03,-1.270E-03,
+ 6-1.991E-02,-2.539E-02,-2.780E-03, 3.430E-03, 1.720E-03, 5.500E-04,
+ 1 2.410E-01, 2.884E-01, 9.369E-02, 1.900E-02, 2.530E-03, 2.400E-04,
+ 2 1.765E-02,-9.220E-03,-3.037E-02,-2.085E-02,-8.440E-03,-2.810E-03,
+ 3-6.450E-03,-5.260E-03, 1.720E-03, 3.110E-03, 1.830E-03, 8.700E-04,
+ 4 2.120E-03, 2.320E-03, 2.600E-04,-4.900E-04,-3.900E-04,-2.300E-04,
+ 5-6.900E-04,-8.200E-04,-2.000E-04, 7.000E-05, 9.000E-05, 6.000E-05,
+ 6 2.400E-04, 3.100E-04, 1.100E-04, 0.000E+00,-2.000E-05,-2.000E-05/
+C...EXPANSION COEFFICIENTS FOR DOWN VALENCE QUARK DISTRIBUTION
+ DATA (((CEHLQ(IX,IT,NX,2,1),IX=1,6),IT=1,6),NX=1,2)/
+ 1 3.813E-01,-8.090E-02,-1.634E-01,-2.185E-02,-8.430E-03,-6.200E-04,
+ 2-2.948E-01,-1.435E-01, 1.665E-01, 6.638E-02, 1.473E-02, 4.080E-03,
+ 3 1.252E-01, 1.042E-01,-4.722E-02,-3.683E-02,-1.038E-02,-2.860E-03,
+ 4-5.478E-02,-5.678E-02, 8.900E-03, 1.484E-02, 5.340E-03, 1.520E-03,
+ 5 2.220E-02, 2.567E-02,-3.000E-05,-4.970E-03,-2.160E-03,-6.500E-04,
+ 6-9.530E-03,-1.204E-02,-1.510E-03, 1.510E-03, 8.300E-04, 2.700E-04,
+ 1 1.261E-01, 1.354E-01, 3.958E-02, 8.240E-03, 1.660E-03, 4.500E-04,
+ 2 3.890E-03,-1.159E-02,-1.625E-02,-9.610E-03,-3.710E-03,-1.260E-03,
+ 3-1.910E-03,-5.600E-04, 1.590E-03, 1.590E-03, 8.400E-04, 3.900E-04,
+ 4 6.400E-04, 4.900E-04,-1.500E-04,-2.900E-04,-1.800E-04,-1.000E-04,
+ 5-2.000E-04,-1.900E-04, 0.000E+00, 6.000E-05, 4.000E-05, 3.000E-05,
+ 6 7.000E-05, 8.000E-05, 2.000E-05,-1.000E-05,-1.000E-05,-1.000E-05/
+ DATA (((CEHLQ(IX,IT,NX,2,2),IX=1,6),IT=1,6),NX=1,2)/
+ 1 3.578E-01,-8.622E-02,-1.480E-01,-1.840E-02,-7.820E-03,-4.500E-04,
+ 2-2.925E-01,-1.304E-01, 1.696E-01, 6.243E-02, 1.353E-02, 3.750E-03,
+ 3 1.318E-01, 1.041E-01,-5.486E-02,-3.872E-02,-1.038E-02,-2.850E-03,
+ 4-6.162E-02,-6.143E-02, 1.303E-02, 1.740E-02, 5.940E-03, 1.670E-03,
+ 5 2.643E-02, 2.957E-02,-1.490E-03,-6.450E-03,-2.630E-03,-7.700E-04,
+ 6-1.218E-02,-1.497E-02,-1.260E-03, 2.240E-03, 1.120E-03, 3.500E-04,
+ 1 1.263E-01, 1.334E-01, 3.732E-02, 7.070E-03, 1.260E-03, 3.400E-04,
+ 2 3.660E-03,-1.357E-02,-1.795E-02,-1.031E-02,-3.880E-03,-1.280E-03,
+ 3-2.100E-03,-3.600E-04, 2.050E-03, 1.920E-03, 9.800E-04, 4.400E-04,
+ 4 7.700E-04, 5.400E-04,-2.400E-04,-3.900E-04,-2.400E-04,-1.300E-04,
+ 5-2.600E-04,-2.300E-04, 2.000E-05, 9.000E-05, 6.000E-05, 4.000E-05,
+ 6 9.000E-05, 1.000E-04, 2.000E-05,-2.000E-05,-2.000E-05,-1.000E-05/
+C...EXPANSION COEFFICIENTS FOR UP AND DOWN SEA QUARK DISTRIBUTIONS
+ DATA (((CEHLQ(IX,IT,NX,3,1),IX=1,6),IT=1,6),NX=1,2)/
+ 1 6.870E-02,-6.861E-02, 2.973E-02,-5.400E-03, 3.780E-03,-9.700E-04,
+ 2-1.802E-02, 1.400E-04, 6.490E-03,-8.540E-03, 1.220E-03,-1.750E-03,
+ 3-4.650E-03, 1.480E-03,-5.930E-03, 6.000E-04,-1.030E-03,-8.000E-05,
+ 4 6.440E-03, 2.570E-03, 2.830E-03, 1.150E-03, 7.100E-04, 3.300E-04,
+ 5-3.930E-03,-2.540E-03,-1.160E-03,-7.700E-04,-3.600E-04,-1.900E-04,
+ 6 2.340E-03, 1.930E-03, 5.300E-04, 3.700E-04, 1.600E-04, 9.000E-05,
+ 1 1.014E+00,-1.106E+00, 3.374E-01,-7.444E-02, 8.850E-03,-8.700E-04,
+ 2 9.233E-01,-1.285E+00, 4.475E-01,-9.786E-02, 1.419E-02,-1.120E-03,
+ 3 4.888E-02,-1.271E-01, 8.606E-02,-2.608E-02, 4.780E-03,-6.000E-04,
+ 4-2.691E-02, 4.887E-02,-1.771E-02, 1.620E-03, 2.500E-04,-6.000E-05,
+ 5 7.040E-03,-1.113E-02, 1.590E-03, 7.000E-04,-2.000E-04, 0.000E+00,
+ 6-1.710E-03, 2.290E-03, 3.800E-04,-3.500E-04, 4.000E-05, 1.000E-05/
+ DATA (((CEHLQ(IX,IT,NX,3,2),IX=1,6),IT=1,6),NX=1,2)/
+ 1 1.008E-01,-7.100E-02, 1.973E-02,-5.710E-03, 2.930E-03,-9.900E-04,
+ 2-5.271E-02,-1.823E-02, 1.792E-02,-6.580E-03, 1.750E-03,-1.550E-03,
+ 3 1.220E-02, 1.763E-02,-8.690E-03,-8.800E-04,-1.160E-03,-2.100E-04,
+ 4-1.190E-03,-7.180E-03, 2.360E-03, 1.890E-03, 7.700E-04, 4.100E-04,
+ 5-9.100E-04, 2.040E-03,-3.100E-04,-1.050E-03,-4.000E-04,-2.400E-04,
+ 6 1.190E-03,-1.700E-04,-2.000E-04, 4.200E-04, 1.700E-04, 1.000E-04,
+ 1 1.081E+00,-1.189E+00, 3.868E-01,-8.617E-02, 1.115E-02,-1.180E-03,
+ 2 9.917E-01,-1.396E+00, 4.998E-01,-1.159E-01, 1.674E-02,-1.720E-03,
+ 3 5.099E-02,-1.338E-01, 9.173E-02,-2.885E-02, 5.890E-03,-6.500E-04,
+ 4-3.178E-02, 5.703E-02,-2.070E-02, 2.440E-03, 1.100E-04,-9.000E-05,
+ 5 8.970E-03,-1.392E-02, 2.050E-03, 6.500E-04,-2.300E-04, 2.000E-05,
+ 6-2.340E-03, 3.010E-03, 5.000E-04,-3.900E-04, 6.000E-05, 1.000E-05/
+C...EXPANSION COEFFICIENTS FOR GLUON DISTRIBUTION
+ DATA (((CEHLQ(IX,IT,NX,4,1),IX=1,6),IT=1,6),NX=1,2)/
+ 1 9.482E-01,-9.578E-01, 1.009E-01,-1.051E-01, 3.456E-02,-3.054E-02,
+ 2-9.627E-01, 5.379E-01, 3.368E-01,-9.525E-02, 1.488E-02,-2.051E-02,
+ 3 4.300E-01,-8.306E-02,-3.372E-01, 4.902E-02,-9.160E-03, 1.041E-02,
+ 4-1.925E-01,-1.790E-02, 2.183E-01, 7.490E-03, 4.140E-03,-1.860E-03,
+ 5 8.183E-02, 1.926E-02,-1.072E-01,-1.944E-02,-2.770E-03,-5.200E-04,
+ 6-3.884E-02,-1.234E-02, 5.410E-02, 1.879E-02, 3.350E-03, 1.040E-03,
+ 1 2.948E+01,-3.902E+01, 1.464E+01,-3.335E+00, 5.054E-01,-5.915E-02,
+ 2 2.559E+01,-3.955E+01, 1.661E+01,-4.299E+00, 6.904E-01,-8.243E-02,
+ 3-1.663E+00, 1.176E+00, 1.118E+00,-7.099E-01, 1.948E-01,-2.404E-02,
+ 4-2.168E-01, 8.170E-01,-7.169E-01, 1.851E-01,-1.924E-02,-3.250E-03,
+ 5 2.088E-01,-4.355E-01, 2.239E-01,-2.446E-02,-3.620E-03, 1.910E-03,
+ 6-9.097E-02, 1.601E-01,-5.681E-02,-2.500E-03, 2.580E-03,-4.700E-04/
+ DATA (((CEHLQ(IX,IT,NX,4,2),IX=1,6),IT=1,6),NX=1,2)/
+ 1 2.367E+00, 4.453E-01, 3.660E-01, 9.467E-02, 1.341E-01, 1.661E-02,
+ 2-3.170E+00,-1.795E+00, 3.313E-02,-2.874E-01,-9.827E-02,-7.119E-02,
+ 3 1.823E+00, 1.457E+00,-2.465E-01, 3.739E-02, 6.090E-03, 1.814E-02,
+ 4-1.033E+00,-9.827E-01, 2.136E-01, 1.169E-01, 5.001E-02, 1.684E-02,
+ 5 5.133E-01, 5.259E-01,-1.173E-01,-1.139E-01,-4.988E-02,-2.021E-02,
+ 6-2.881E-01,-3.145E-01, 5.667E-02, 9.161E-02, 4.568E-02, 1.951E-02,
+ 1 3.036E+01,-4.062E+01, 1.578E+01,-3.699E+00, 6.020E-01,-7.031E-02,
+ 2 2.700E+01,-4.167E+01, 1.770E+01,-4.804E+00, 7.862E-01,-1.060E-01,
+ 3-1.909E+00, 1.357E+00, 1.127E+00,-7.181E-01, 2.232E-01,-2.481E-02,
+ 4-2.488E-01, 9.781E-01,-8.127E-01, 2.094E-01,-2.997E-02,-4.710E-03,
+ 5 2.506E-01,-5.427E-01, 2.672E-01,-3.103E-02,-1.800E-03, 2.870E-03,
+ 6-1.128E-01, 2.087E-01,-6.972E-02,-2.480E-03, 2.630E-03,-8.400E-04/
+C...EXPANSION COEFFICIENTS FOR STRANGE SEA QUARK DISTRIBUTION
+ DATA (((CEHLQ(IX,IT,NX,5,1),IX=1,6),IT=1,6),NX=1,2)/
+ 1 4.968E-02,-4.173E-02, 2.102E-02,-3.270E-03, 3.240E-03,-6.700E-04,
+ 2-6.150E-03,-1.294E-02, 6.740E-03,-6.890E-03, 9.000E-04,-1.510E-03,
+ 3-8.580E-03, 5.050E-03,-4.900E-03,-1.600E-04,-9.400E-04,-1.500E-04,
+ 4 7.840E-03, 1.510E-03, 2.220E-03, 1.400E-03, 7.000E-04, 3.500E-04,
+ 5-4.410E-03,-2.220E-03,-8.900E-04,-8.500E-04,-3.600E-04,-2.000E-04,
+ 6 2.520E-03, 1.840E-03, 4.100E-04, 3.900E-04, 1.600E-04, 9.000E-05,
+ 1 9.235E-01,-1.085E+00, 3.464E-01,-7.210E-02, 9.140E-03,-9.100E-04,
+ 2 9.315E-01,-1.274E+00, 4.512E-01,-9.775E-02, 1.380E-02,-1.310E-03,
+ 3 4.739E-02,-1.296E-01, 8.482E-02,-2.642E-02, 4.760E-03,-5.700E-04,
+ 4-2.653E-02, 4.953E-02,-1.735E-02, 1.750E-03, 2.800E-04,-6.000E-05,
+ 5 6.940E-03,-1.132E-02, 1.480E-03, 6.500E-04,-2.100E-04, 0.000E+00,
+ 6-1.680E-03, 2.340E-03, 4.200E-04,-3.400E-04, 5.000E-05, 1.000E-05/
+ DATA (((CEHLQ(IX,IT,NX,5,2),IX=1,6),IT=1,6),NX=1,2)/
+ 1 6.478E-02,-4.537E-02, 1.643E-02,-3.490E-03, 2.710E-03,-6.700E-04,
+ 2-2.223E-02,-2.126E-02, 1.247E-02,-6.290E-03, 1.120E-03,-1.440E-03,
+ 3-1.340E-03, 1.362E-02,-6.130E-03,-7.900E-04,-9.000E-04,-2.000E-04,
+ 4 5.080E-03,-3.610E-03, 1.700E-03, 1.830E-03, 6.800E-04, 4.000E-04,
+ 5-3.580E-03, 6.000E-05,-2.600E-04,-1.050E-03,-3.800E-04,-2.300E-04,
+ 6 2.420E-03, 9.300E-04,-1.000E-04, 4.500E-04, 1.700E-04, 1.100E-04,
+ 1 9.868E-01,-1.171E+00, 3.940E-01,-8.459E-02, 1.124E-02,-1.250E-03,
+ 2 1.001E+00,-1.383E+00, 5.044E-01,-1.152E-01, 1.658E-02,-1.830E-03,
+ 3 4.928E-02,-1.368E-01, 9.021E-02,-2.935E-02, 5.800E-03,-6.600E-04,
+ 4-3.133E-02, 5.785E-02,-2.023E-02, 2.630E-03, 1.600E-04,-8.000E-05,
+ 5 8.840E-03,-1.416E-02, 1.900E-03, 5.800E-04,-2.500E-04, 1.000E-05,
+ 6-2.300E-03, 3.080E-03, 5.500E-04,-3.700E-04, 7.000E-05, 1.000E-05/
+C...EXPANSION COEFFICIENTS FOR CHARM SEA QUARK DISTRIBUTION
+ DATA (((CEHLQ(IX,IT,NX,6,1),IX=1,6),IT=1,6),NX=1,2)/
+ 1 9.270E-03,-1.817E-02, 9.590E-03,-6.390E-03, 1.690E-03,-1.540E-03,
+ 2 5.710E-03,-1.188E-02, 6.090E-03,-4.650E-03, 1.240E-03,-1.310E-03,
+ 3-3.960E-03, 7.100E-03,-3.590E-03, 1.840E-03,-3.900E-04, 3.400E-04,
+ 4 1.120E-03,-1.960E-03, 1.120E-03,-4.800E-04, 1.000E-04,-4.000E-05,
+ 5 4.000E-05,-3.000E-05,-1.800E-04, 9.000E-05,-5.000E-05,-2.000E-05,
+ 6-4.200E-04, 7.300E-04,-1.600E-04, 5.000E-05, 5.000E-05, 5.000E-05,
+ 1 8.098E-01,-1.042E+00, 3.398E-01,-6.824E-02, 8.760E-03,-9.000E-04,
+ 2 8.961E-01,-1.217E+00, 4.339E-01,-9.287E-02, 1.304E-02,-1.290E-03,
+ 3 3.058E-02,-1.040E-01, 7.604E-02,-2.415E-02, 4.600E-03,-5.000E-04,
+ 4-2.451E-02, 4.432E-02,-1.651E-02, 1.430E-03, 1.200E-04,-1.000E-04,
+ 5 1.122E-02,-1.457E-02, 2.680E-03, 5.800E-04,-1.200E-04, 3.000E-05,
+ 6-7.730E-03, 7.330E-03,-7.600E-04,-2.400E-04, 1.000E-05, 0.000E+00/
+ DATA (((CEHLQ(IX,IT,NX,6,2),IX=1,6),IT=1,6),NX=1,2)/
+ 1 9.980E-03,-1.945E-02, 1.055E-02,-6.870E-03, 1.860E-03,-1.560E-03,
+ 2 5.700E-03,-1.203E-02, 6.250E-03,-4.860E-03, 1.310E-03,-1.370E-03,
+ 3-4.490E-03, 7.990E-03,-4.170E-03, 2.050E-03,-4.400E-04, 3.300E-04,
+ 4 1.470E-03,-2.480E-03, 1.460E-03,-5.700E-04, 1.200E-04,-1.000E-05,
+ 5-9.000E-05, 1.500E-04,-3.200E-04, 1.200E-04,-6.000E-05,-4.000E-05,
+ 6-4.200E-04, 7.600E-04,-1.400E-04, 4.000E-05, 7.000E-05, 5.000E-05,
+ 1 8.698E-01,-1.131E+00, 3.836E-01,-8.111E-02, 1.048E-02,-1.300E-03,
+ 2 9.626E-01,-1.321E+00, 4.854E-01,-1.091E-01, 1.583E-02,-1.700E-03,
+ 3 3.057E-02,-1.088E-01, 8.022E-02,-2.676E-02, 5.590E-03,-5.600E-04,
+ 4-2.845E-02, 5.164E-02,-1.918E-02, 2.210E-03,-4.000E-05,-1.500E-04,
+ 5 1.311E-02,-1.751E-02, 3.310E-03, 5.100E-04,-1.200E-04, 5.000E-05,
+ 6-8.590E-03, 8.380E-03,-9.200E-04,-2.600E-04, 1.000E-05,-1.000E-05/
+C...EXPANSION COEFFICIENTS FOR BOTTOM SEA QUARK DISTRIBUTION
+ DATA (((CEHLQ(IX,IT,NX,7,1),IX=1,6),IT=1,6),NX=1,2)/
+ 1 9.010E-03,-1.401E-02, 7.150E-03,-4.130E-03, 1.260E-03,-1.040E-03,
+ 2 6.280E-03,-9.320E-03, 4.780E-03,-2.890E-03, 9.100E-04,-8.200E-04,
+ 3-2.930E-03, 4.090E-03,-1.890E-03, 7.600E-04,-2.300E-04, 1.400E-04,
+ 4 3.900E-04,-1.200E-03, 4.400E-04,-2.500E-04, 2.000E-05,-2.000E-05,
+ 5 2.600E-04, 1.400E-04,-8.000E-05, 1.000E-04, 1.000E-05, 1.000E-05,
+ 6-2.600E-04, 3.200E-04, 1.000E-05,-1.000E-05, 1.000E-05,-1.000E-05,
+ 1 8.029E-01,-1.075E+00, 3.792E-01,-7.843E-02, 1.007E-02,-1.090E-03,
+ 2 7.903E-01,-1.099E+00, 4.153E-01,-9.301E-02, 1.317E-02,-1.410E-03,
+ 3-1.704E-02,-1.130E-02, 2.882E-02,-1.341E-02, 3.040E-03,-3.600E-04,
+ 4-7.200E-04, 7.230E-03,-5.160E-03, 1.080E-03,-5.000E-05,-4.000E-05,
+ 5 3.050E-03,-4.610E-03, 1.660E-03,-1.300E-04,-1.000E-05, 1.000E-05,
+ 6-4.360E-03, 5.230E-03,-1.610E-03, 2.000E-04,-2.000E-05, 0.000E+00/
+ DATA (((CEHLQ(IX,IT,NX,7,2),IX=1,6),IT=1,6),NX=1,2)/
+ 1 8.980E-03,-1.459E-02, 7.510E-03,-4.410E-03, 1.310E-03,-1.070E-03,
+ 2 5.970E-03,-9.440E-03, 4.800E-03,-3.020E-03, 9.100E-04,-8.500E-04,
+ 3-3.050E-03, 4.440E-03,-2.100E-03, 8.500E-04,-2.400E-04, 1.400E-04,
+ 4 5.300E-04,-1.300E-03, 5.600E-04,-2.700E-04, 3.000E-05,-2.000E-05,
+ 5 2.000E-04, 1.400E-04,-1.100E-04, 1.000E-04, 0.000E+00, 0.000E+00,
+ 6-2.600E-04, 3.200E-04, 0.000E+00,-3.000E-05, 1.000E-05,-1.000E-05,
+ 1 8.672E-01,-1.174E+00, 4.265E-01,-9.252E-02, 1.244E-02,-1.460E-03,
+ 2 8.500E-01,-1.194E+00, 4.630E-01,-1.083E-01, 1.614E-02,-1.830E-03,
+ 3-2.241E-02,-5.630E-03, 2.815E-02,-1.425E-02, 3.520E-03,-4.300E-04,
+ 4-7.300E-04, 8.030E-03,-5.780E-03, 1.380E-03,-1.300E-04,-4.000E-05,
+ 5 3.460E-03,-5.380E-03, 1.960E-03,-2.100E-04, 1.000E-05, 1.000E-05,
+ 6-4.850E-03, 5.950E-03,-1.890E-03, 2.600E-04,-3.000E-05, 0.000E+00/
+C...EXPANSION COEFFICIENTS FOR TOP SEA QUARK DISTRIBUTION
+ DATA (((CEHLQ(IX,IT,NX,8,1),IX=1,6),IT=1,6),NX=1,2)/
+ 1 4.410E-03,-7.480E-03, 3.770E-03,-2.580E-03, 7.300E-04,-7.100E-04,
+ 2 3.840E-03,-6.050E-03, 3.030E-03,-2.030E-03, 5.800E-04,-5.900E-04,
+ 3-8.800E-04, 1.660E-03,-7.500E-04, 4.700E-04,-1.000E-04, 1.000E-04,
+ 4-8.000E-05,-1.500E-04, 1.200E-04,-9.000E-05, 3.000E-05, 0.000E+00,
+ 5 1.300E-04,-2.200E-04,-2.000E-05,-2.000E-05,-2.000E-05,-2.000E-05,
+ 6-7.000E-05, 1.900E-04,-4.000E-05, 2.000E-05, 0.000E+00, 0.000E+00,
+ 1 6.623E-01,-9.248E-01, 3.519E-01,-7.930E-02, 1.110E-02,-1.180E-03,
+ 2 6.380E-01,-9.062E-01, 3.582E-01,-8.479E-02, 1.265E-02,-1.390E-03,
+ 3-2.581E-02, 2.125E-02, 4.190E-03,-4.980E-03, 1.490E-03,-2.100E-04,
+ 4 7.100E-04, 5.300E-04,-1.270E-03, 3.900E-04,-5.000E-05,-1.000E-05,
+ 5 3.850E-03,-5.060E-03, 1.860E-03,-3.500E-04, 4.000E-05, 0.000E+00,
+ 6-3.530E-03, 4.460E-03,-1.500E-03, 2.700E-04,-3.000E-05, 0.000E+00/
+ DATA (((CEHLQ(IX,IT,NX,8,2),IX=1,6),IT=1,6),NX=1,2)/
+ 1 4.260E-03,-7.530E-03, 3.830E-03,-2.680E-03, 7.600E-04,-7.300E-04,
+ 2 3.640E-03,-6.050E-03, 3.030E-03,-2.090E-03, 5.900E-04,-6.000E-04,
+ 3-9.200E-04, 1.710E-03,-8.200E-04, 5.000E-04,-1.200E-04, 1.000E-04,
+ 4-5.000E-05,-1.600E-04, 1.300E-04,-9.000E-05, 3.000E-05, 0.000E+00,
+ 5 1.300E-04,-2.100E-04,-1.000E-05,-2.000E-05,-2.000E-05,-1.000E-05,
+ 6-8.000E-05, 1.800E-04,-5.000E-05, 2.000E-05, 0.000E+00, 0.000E+00,
+ 1 7.146E-01,-1.007E+00, 3.932E-01,-9.246E-02, 1.366E-02,-1.540E-03,
+ 2 6.856E-01,-9.828E-01, 3.977E-01,-9.795E-02, 1.540E-02,-1.790E-03,
+ 3-3.053E-02, 2.758E-02, 2.150E-03,-4.880E-03, 1.640E-03,-2.500E-04,
+ 4 9.200E-04, 4.200E-04,-1.340E-03, 4.600E-04,-8.000E-05,-1.000E-05,
+ 5 4.230E-03,-5.660E-03, 2.140E-03,-4.300E-04, 6.000E-05, 0.000E+00,
+ 6-3.890E-03, 5.000E-03,-1.740E-03, 3.300E-04,-4.000E-05, 0.000E+00/
+ DATA TBMIN,TTMIN/8.1905,7.4474,11.5528,10.8097/
+ DATA XOLD,QOLD,IOLD,NOLD/-1.,0.,0,0/
+ DATA DMIN,Q0,QL/0.,2*2.,2*2.236,2.,.2,.4,.2,.29,.177/
+ IF (X.LE.ZERO) CALL HWWARN('HWSFUN',100,*999)
+ XMWN=ONE-X
+ IF (XMWN.LE.ZERO) THEN
+ DO 1 I=1,13
+ DIST(I)=0
+ 1 CONTINUE
+ RETURN
+ ENDIF
+C---FREEZE THE SCALE IF REQUIRED
+ SCALEF=SCALE
+ IF (ISPAC.GT.0) SCALEF=MAX(SCALEF,QSPAC)
+C---CHECK IF PDFLIB REQUESTED
+ IF (IBEAM.EQ.1.OR.IBEAM.EQ.2) THEN
+ MPDF=MODPDF(IBEAM)
+ ELSE
+ MPDF=-1
+ ENDIF
+ QSCA=ABS(SCALEF)
+ IF (IDHAD.EQ.59.OR.IDHAD.EQ.71) THEN
+ IF (MPDF.GE.0) THEN
+C---USE PDFLIB PHOTON STRUCTURE FUNCTIONS
+ PARM(1)=AUTPDF(IBEAM)
+ VAL(1)=FLOAT(MPDF)
+C---FIX TO CALL SCHULER-SJOSTRAND CODE
+ IF (AUTPDF(IBEAM).EQ.'SaSph') THEN
+ XSP=X
+ IF ( XSP.LE.ZERO) CALL HWWARN('HWSFUN',102,*999)
+ IF (ONE-XSP.LE.ZERO) CALL HWWARN('HWSFUN',103,*999)
+ Q2=QSCA**2
+ ISET=MOD(MODPDF(IBEAM),10)
+ IOP1=MOD(MODPDF(IBEAM)/10,2)
+ IOP2=MOD(MODPDF(IBEAM)/20,2)
+ IP2=MODPDF(IBEAM)/100
+ IF (IOP2.EQ.0) THEN
+ P2=0.
+ ELSE
+ IHAD=IBEAM
+ IF (JDAHEP(1,IHAD).NE.0) IHAD=JDAHEP(1,IHAD)
+ P2=PHEP(5,IHAD)**2
+ ENDIF
+ CALL SASGAM(ISET,XSP,Q2,P2,IP2,F2GM,XPGA)
+ IF (IOP1.EQ.1 .AND. ISTAT.LT.10) THEN
+ DO 5 I=-6,6
+ 5 XPGA(I)=XPVMD(I)+XPANL(I)+XPBEH(I)+XPDIR(I)
+ ENDIF
+ UPV=XPGA(2)
+ DNV=XPGA(1)
+ USEA=XPGA(2)
+ DSEA=XPGA(1)
+ STR=XPGA(3)
+ CHM=XPGA(4)
+ BTM=XPGA(5)
+ TOP=XPGA(6)
+ GLU=XPGA(0)
+ ELSE
+ CALL PDFSET(PARM,VAL)
+ IF (X.LT.PDFXMN.AND.PDFWRX(IBEAM,1) .OR.
+ & X.GT.PDFXMX.AND.PDFWRX(IBEAM,2)) THEN
+ CALL HWWARN('HWSFUN',2,*999)
+ WRITE (6,'(2A)') ' WARNING: PDFLIB CALLED WITH X',
+ & ' OUTSIDE ALLOWED RANGE!'
+ WRITE (6,'(1P,3(A,E9.3))') ' X VALUE=',X,
+ & ', MINIMUM=',PDFXMN,', MAXIMUM=',PDFXMX
+ WRITE (6,'(A)') ' NO FURTHER WARNINGS WILL BE ISSUED'
+ IF (X.LT.PDFXMN) PDFWRX(IBEAM,1)=.FALSE.
+ IF (X.GT.PDFXMX) PDFWRX(IBEAM,2)=.FALSE.
+ ENDIF
+ IF (QSCA**2.LT.PDFQMN.AND.PDFWRQ(IBEAM,1) .OR.
+ & QSCA**2.GT.PDFQMX.AND.PDFWRQ(IBEAM,2)) THEN
+ CALL HWWARN('HWSFUN',3,*999)
+ WRITE (6,'(2A)') ' WARNING: PDFLIB CALLED WITH Q',
+ & ' OUTSIDE ALLOWED RANGE!'
+ WRITE (6,'(1P,3(A,E9.3))') ' Q VALUE=',QSCA,
+ & ', MINIMUM=',SQRT(PDFQMN),', MAXIMUM=',SQRT(PDFQMX)
+ WRITE (6,'(A)') ' NO FURTHER WARNINGS WILL BE ISSUED'
+ IF (QSCA**2.LT.PDFQMN) PDFWRQ(IBEAM,1)=.FALSE.
+ IF (QSCA**2.GT.PDFQMN) PDFWRQ(IBEAM,2)=.FALSE.
+ ENDIF
+ CALL STRUCTM(X,QSCA,UPV,DNV,USEA,DSEA,STR,CHM,BTM,TOP,GLU)
+ ENDIF
+ DIST(1)=DSEA
+ DIST(2)=USEA
+ DIST(7)=DSEA
+ DIST(8)=USEA
+ ELSE
+ XSP=X
+ IF ( XSP.LE.ZERO) CALL HWWARN('HWSFUN',102,*999)
+ IF (ONE-XSP.LE.ZERO) CALL HWWARN('HWSFUN',103,*999)
+ Q2=SCALEF**2
+ W2=Q2*(1-X)/X
+ EMC2=4*RMASS(4)**2
+ EMB2=4*RMASS(5)**2
+ ALAM2=0.160
+ NFL=3
+ IF (Q2.GT.50.) NFL=4
+ IF (Q2.GT.500.) NFL=5
+ STR=HWSDGQ(XSP,Q2,NFL,1)
+ CHM=HWSDGQ(XSP,Q2,NFL,2)
+ GLU=HWSDGG(XSP,Q2,NFL)
+ DIST(1)=STR
+ DIST(2)=CHM
+ DIST(7)=STR
+ DIST(8)=CHM
+ IF (W2.GT.EMB2) THEN
+ BTM=STR
+ IF (W2*ALAM2.LT.Q2*EMB2)
+ & BTM=BTM*LOG(W2/EMB2)/LOG(Q2/ALAM2)
+ ELSE
+ BTM=0.
+ ENDIF
+ IF (W2.GT.EMC2) THEN
+ IF (W2*ALAM2.LT.Q2*EMC2)
+ & CHM=CHM*LOG(W2/EMC2)/LOG(Q2/ALAM2)
+ ELSE
+ CHM=0.
+ ENDIF
+ TOP=0.
+ ENDIF
+C---INCLUDE SUPPRESSION FROM PHOTON VIRTUALITY IF NECESSARY
+ IF (PHOMAS.GT.ZERO.AND.(IBEAM.EQ.1.OR.IBEAM.EQ.2)) THEN
+ IHAD=IBEAM
+ IF (JDAHEP(1,IHAD).NE.0) IHAD=JDAHEP(1,IHAD)
+ IF (IDHW(IHAD).EQ.59) THEN
+ FAC=LOG((QSCA**2+PHOMAS**2)/(PHEP(5,IHAD)**2+PHOMAS**2))/
+ $ LOG((QSCA**2+PHOMAS**2)/( PHOMAS**2))
+ IF (FAC.LT.ZERO) FAC=ZERO
+ DIST(1)=DIST(1)*FAC
+ DIST(2)=DIST(2)*FAC
+ DIST(7)=DIST(7)*FAC
+ DIST(8)=DIST(8)*FAC
+ STR=STR*FAC
+ CHM=CHM*FAC
+ BTM=BTM*FAC
+ TOP=TOP*FAC
+ GLU=GLU*FAC**2
+ ELSE
+ CALL HWWARN('HWSFUN',1,*999)
+ ENDIF
+ ENDIF
+ GOTO 900
+ ENDIF
+ IF (MPDF.GE.0) THEN
+C---USE PDFLIB NUCLEON STRUCTURE FUNCTIONS
+ PARM(1)=AUTPDF(IBEAM)
+ VAL(1)=FLOAT(MPDF)
+ CALL PDFSET(PARM,VAL)
+ IF (X.LT.PDFXMN.AND.PDFWRX(IBEAM,1) .OR.
+ & X.GT.PDFXMX.AND.PDFWRX(IBEAM,2)) THEN
+ CALL HWWARN('HWSFUN',4,*999)
+ WRITE (6,'(2A)') ' WARNING: PDFLIB CALLED WITH X',
+ & ' OUTSIDE ALLOWED RANGE!'
+ WRITE (6,'(1P,3(A,E9.3))') ' X VALUE=',X,
+ & ', MINIMUM=',PDFXMN,', MAXIMUM=',PDFXMX
+ WRITE (6,'(A)') ' NO FURTHER WARNINGS WILL BE ISSUED'
+ IF (X.LT.PDFXMN) PDFWRX(IBEAM,1)=.FALSE.
+ IF (X.GT.PDFXMX) PDFWRX(IBEAM,2)=.FALSE.
+ ENDIF
+ IF (QSCA**2.LT.PDFQMN.AND.PDFWRQ(IBEAM,1) .OR.
+ & QSCA**2.GT.PDFQMX.AND.PDFWRQ(IBEAM,2)) THEN
+ CALL HWWARN('HWSFUN',5,*999)
+ WRITE (6,'(2A)') ' WARNING: PDFLIB CALLED WITH Q',
+ & ' OUTSIDE ALLOWED RANGE!'
+ WRITE (6,'(1P,3(A,E9.3))') ' Q VALUE=',QSCA,
+ & ', MINIMUM=',SQRT(PDFQMN),', MAXIMUM=',SQRT(PDFQMX)
+ WRITE (6,'(A)') ' NO FURTHER WARNINGS WILL BE ISSUED'
+ IF (QSCA**2.LT.PDFQMN) PDFWRQ(IBEAM,1)=.FALSE.
+ IF (QSCA**2.GT.PDFQMN) PDFWRQ(IBEAM,2)=.FALSE.
+ ENDIF
+ CALL STRUCTM(X,QSCA,UPV,DNV,USEA,DSEA,STR,CHM,BTM,TOP,GLU)
+ ELSE
+ IF (QSCA.LT.Q0(NSET)) QSCA=Q0(NSET)
+ IF (QSCA.NE.QOLD.OR.IDHAD.NE.IOLD.OR.NSET.NE.NOLD) THEN
+C---INITIALIZE
+ IF (NSET.LT.1.OR.NSET.GT.5) CALL HWWARN('HWSFUN',400,*999)
+ QOLD=QSCA
+ IOLD=IDHAD
+ NOLD=NSET
+ SS=LOG(QSCA/QL(NSET))
+ SMIN=LOG(Q0(NSET)/QL(NSET))
+ IF (NSET.LT.3.OR.NSET.EQ.5) THEN
+ S=LOG(SS/SMIN)
+ ELSE
+ T=2.*SS
+ TMIN=2.*SMIN
+ TMAX=2.*LOG(1.E4/QL(NSET))
+ ENDIF
+ IF (IDHAD.GE.72) THEN
+ IF (NSET.LT.3) THEN
+ IP=NSET
+ DO 10 I=1,5
+ DO 10 J=1,6
+ 10 A(J,I)=B(1,J,I,IP)+S*(B(2,J,I,IP)+S*B(3,J,I,IP))
+ DO 20 K=1,2
+ AA=ONE+A(2,K)+A(3,K)
+ 20 G(K)=HWSGAM(AA)/((ONE+A(2,K)*A(4,K)/AA)*HWSGAM(A(2,K))
+ & *HWSGAM(ONE+A(3,K)))
+ ELSEIF (NSET.EQ.5) THEN
+ DO 21 I=1,5
+ DO 21 J=1,6
+ 21 A(J,I)=BB(1,J,I)+S*(BB(2,J,I)+S*(BB(3,J,I)+S*BB(4,J,I)))
+ DO 22 K=1,2
+ AA=ONE+A(2,K)+A(3,K)
+ 22 G(K)=HWSGAM(AA)/((ONE+A(2,K)/AA*(A(4,K)+
+ & (ONE+A(2,K))/(ONE+AA)*A(5,K)))*HWSGAM(A(2,K))
+ & *HWSGAM(ONE+A(3,K)))
+ ELSE
+ IP=NSET-2
+ VT=MAX(-ONE,MIN(ONE,(2.*T-TMAX-TMIN)/(TMAX-TMIN)))
+ WT=VT*VT
+C...CHEBYSHEV POLYNOMIALS FOR T EXPANSION
+ TT(1)=1.
+ TT(2)=VT
+ TT(3)= 2.*WT- 1.
+ TT(4)= (4.*WT- 3.)*VT
+ TT(5)= (8.*WT- 8.)*WT+1.
+ TT(6)=((16.*WT-20.)*WT+5.)*VT
+ ENDIF
+ ELSEIF (NSET.LT.3) THEN
+ IP=NSET+2
+ DO 30 I=1,5
+ DO 30 J=1,6
+ 30 A(J,I)=B(1,J,I,IP)+S*(B(2,J,I,IP)+S*B(3,J,I,IP))
+ AA=ONE+A(2,1)+A(3,1)
+ G(1)=HWSGAM(AA)/(HWSGAM(A(2,1))*HWSGAM(ONE+A(3,1)))
+ G(2)=0.
+ ENDIF
+ ENDIF
+C
+ IF (NSET.LT.3.OR.NSET.EQ.5) THEN
+ DO 50 I=1,5
+ 50 F(I)=A(1,I)*X**A(2,I)*XMWN**A(3,I)*(ONE+X*
+ & (A(4,I)+X*(A(5,I) + X*A(6,I))))
+ F(1)=F(1)*G(1)
+ F(2)=F(2)*G(2)
+ UPV=F(1)-F(2)
+ DNV=F(2)
+ SEA=F(3)/6.
+ STR=SEA
+ CHM=F(4)
+ BTM=0.
+ TOP=0.
+ GLU=F(5)
+ ELSE
+ IF (X.NE.XOLD) THEN
+ XOLD=X
+ IF (X.GT.0.1) THEN
+ NX=1
+ VX=(2.*X-1.1)/0.9
+ ELSE
+ NX=2
+ VX=MAX(-ONE,(2.*LOG(X)+11.51293)/6.90776)
+ ENDIF
+ WX=VX*VX
+ TX(1)=1.
+ TX(2)=VX
+ TX(3)= 2.*WX- 1.
+ TX(4)= (4.*WX- 3.)*VX
+ TX(5)= (8.*WX- 8.)*WX+1.
+ TX(6)=((16.*WX-20.)*WX+5.)*VX
+ ENDIF
+C...CALCULATE STRUCTURE FUNCTIONS
+ DO 120 IFL=1,6
+ XQSUM=0.
+ DO 110 IT=1,6
+ DO 110 IX=1,6
+ 110 XQSUM=XQSUM+CEHLQ(IX,IT,NX,IFL,IP)*TX(IX)*TT(IT)
+ 120 XQ(IFL)=XQSUM*XMWN**NEHLQ(IFL,IP)
+ UPV=XQ(1)
+ DNV=XQ(2)
+ STR=XQ(5)
+ CHM=XQ(6)
+ SEA=XQ(3)
+ GLU=XQ(4)
+C...SPECIAL EXPANSION FOR BOTTOM (THRESHOLD EFFECTS)
+ IF (NFLAV.LT.5.OR.T.LE.TBMIN(IP)) THEN
+ BTM=0.
+ ELSE
+ VT=MAX(-ONE,MIN(ONE,(2.*T-TMAX-TBMIN(IP))/(TMAX-TBMIN(IP))))
+ WT=VT*VT
+ TB(1)=1.
+ TB(2)=VT
+ TB(3)= 2.*WT- 1.
+ TB(4)= (4.*WT- 3.)*VT
+ TB(5)= (8.*WT- 8.)*WT+1.
+ TB(6)=((16.*WT-20.)*WT+5.)*VT
+ XQSUM=0.
+ DO 130 IT=1,6
+ DO 130 IX=1,6
+ 130 XQSUM=XQSUM+CEHLQ(IX,IT,NX,7,IP)*TX(IX)*TB(IT)
+ BTM=XQSUM*XMWN**NEHLQ(7,IP)
+ ENDIF
+C...SPECIAL EXPANSION FOR TOP (THRESHOLD EFFECTS)
+ TPMIN=TTMIN(IP)+TMTOP
+C---TMTOP=2.*LOG(TOPMAS/30.)
+ TPMAX=TMAX+TMTOP
+ IF (NFLAV.LT.6.OR.T.LE.TPMIN) THEN
+ TOP=0.
+ ELSE
+ VT=MAX(-ONE,MIN(ONE,(2.*T-TPMAX-TPMIN)/(TPMAX-TPMIN)))
+ WT=VT*VT
+ TB(1)=1.
+ TB(2)=VT
+ TB(3)= 2.*WT- 1.
+ TB(4)= (4.*WT- 3.)*VT
+ TB(5)= (8.*WT- 8.)*WT+1.
+ TB(6)=((16.*WT-20.)*WT+5.)*VT
+ XQSUM=0.
+ DO 150 IT=1,6
+ DO 150 IX=1,6
+ 150 XQSUM=XQSUM+CEHLQ(IX,IT,NX,8,IP)*TX(IX)*TB(IT)
+ TOP=XQSUM*XMWN**NEHLQ(8,IP)
+ ENDIF
+ ENDIF
+ ENDIF
+ IF (MPDF.LT.0) THEN
+ USEA=SEA
+ DSEA=USEA
+ ENDIF
+ IF (IDHAD.EQ.73.OR.IDHAD.EQ.72) THEN
+ DIST(1)=DSEA+DNV
+ DIST(2)=USEA+UPV
+ DIST(7)=DSEA
+ DIST(8)=USEA
+ ELSEIF (IDHAD.EQ.91) THEN
+ DIST(1)=DSEA
+ DIST(2)=USEA
+ DIST(7)=DSEA+DNV
+ DIST(8)=USEA+UPV
+ ELSEIF (IDHAD.EQ.75) THEN
+ DIST(1)=USEA+UPV
+ DIST(2)=DSEA+DNV
+ DIST(7)=USEA
+ DIST(8)=DSEA
+ ELSEIF (IDHAD.EQ.93) THEN
+ DIST(1)=USEA
+ DIST(2)=DSEA
+ DIST(7)=USEA+UPV
+ DIST(8)=DSEA+DNV
+ ELSEIF (IDHAD.EQ.38) THEN
+ DIST(1)=USEA
+ DIST(2)=USEA+UPV
+ DIST(7)=USEA+UPV
+ DIST(8)=USEA
+ ELSEIF (IDHAD.EQ.30) THEN
+ DIST(1)=USEA+UPV
+ DIST(2)=USEA
+ DIST(7)=USEA
+ DIST(8)=USEA+UPV
+ ELSE
+ PRINT *,' CALLED HWSFUN FOR IDHAD =',IDHAD
+ CALL HWWARN('HWSFUN',400,*999)
+ ENDIF
+ 900 DIST(3)=STR
+ DIST(4)=CHM
+ DIST(5)=BTM
+ DIST(6)=TOP
+ DIST(9)=STR
+ DIST(10)=CHM
+ DIST(11)=BTM
+ DIST(12)=TOP
+ DIST(13)=GLU
+ DO 901 I=1,13
+ IF (DIST(I).LT.DMIN) DIST(I)=DMIN
+ 901 CONTINUE
+C---FOR REMNANT NUCLEONS SWITCH OFF VALENCE QUARKS,
+C WHILE MAINTAINING MOMENTUM SUM RULE
+ IF (IDHAD.EQ.72) THEN
+ TOTAL=0
+ DO 910 I=1,13
+ TOTAL=TOTAL+DIST(I)
+ 910 CONTINUE
+ DIST(1)=DIST(1)-DNV
+ DIST(2)=DIST(2)-UPV
+ IF (TOTAL.GT.DNV+UPV) THEN
+ DO 920 I=1,13
+ DIST(I)=DIST(I)*TOTAL/(TOTAL-DNV-UPV)
+ 920 CONTINUE
+ ENDIF
+ ENDIF
+ 999 END
+CDECK ID>, HWSGAM.
+*CMZ :- -26/04/91 11.11.56 by Bryan Webber
+*-- Author : Adapted by Bryan Webber
+C-----------------------------------------------------------------------
+ FUNCTION HWSGAM(ZINPUT)
+C-----------------------------------------------------------------------
+C Gamma function computed by eq. 6.1.40, Abramowitz.
+C B(M) = B2m/(2m *(2m-1)) where B2m is the 2m'th Bernoulli number.
+C HLNTPI = .5*LOG(2.*PI)
+C-----------------------------------------------------------------------
+ DOUBLE PRECISION HWSGAM,ZINPUT,B(10),HLNTPI,Z,SHIFT,G,T,RECZSQ
+ INTEGER I
+ DATA B/
+ 1 0.83333333333333333333D-01, -0.27777777777777777778D-02,
+ 1 0.79365079365079365079D-03, -0.59523809523809523810D-03,
+ 1 0.84175084175084175084D-03, -0.19175269175269175269D-02,
+ 1 0.64102564102564102564D-02, -0.29550653594771241830D-01,
+ 1 0.17964437236883057316D0 , -1.3924322169059011164D0 /
+ DATA HLNTPI/0.91893853320467274178D0/
+C
+C Shift argument to large value ( > 20 )
+C
+ Z=ZINPUT
+ SHIFT=1.
+ 10 IF (Z.LT.20.D0) THEN
+ SHIFT = SHIFT*Z
+ Z = Z + 1.D0
+ GOTO 10
+ ENDIF
+C
+C Compute asymptotic formula
+C
+ G = (Z-.5D0)*LOG(Z) - Z + HLNTPI
+ T = 1.D0/Z
+ RECZSQ = T**2
+ DO 20 I = 1,10
+ G = G + B(I)*T
+ T = T*RECZSQ
+ 20 CONTINUE
+ HWSGAM = EXP(G)/SHIFT
+ END
+CDECK ID>, HWSGEN.
+*CMZ :- -26/04/91 14.55.45 by Federico Carminati
+*-- Author : Bryan Webber
+C-----------------------------------------------------------------------
+ SUBROUTINE HWSGEN(GENEX)
+C-----------------------------------------------------------------------
+C GENERATES X VALUES (IF GENEX)
+C EVALUATES STRUCTURE FUNCTIONS AND ENFORCES CUTOFFS ON X
+C-----------------------------------------------------------------------
+ INCLUDE 'HERWIG61.INC'
+ DOUBLE PRECISION HWBVMC,HWRUNI,X,QL
+ INTEGER I,J
+ LOGICAL GENEX
+ EXTERNAL HWBVMC,HWRUNI
+ IF (GENEX) THEN
+ XX(1)=EXP(HWRUNI(0,ZERO,XLMIN))
+ XX(2)=XXMIN/XX(1)
+ ENDIF
+ DO 10 I=1,2
+ J=I
+ IF (JDAHEP(1,I).NE.0) J=JDAHEP(1,I)
+ X=XX(I)
+ QL=(1.-X)*EMSCA
+ CALL HWSFUN(X,EMSCA,IDHW(J),NSTRU,DISF(1,I),I)
+ DO 10 J=1,13
+ IF (QL.LT.HWBVMC(J)) DISF(J,I)=0.
+ 10 CONTINUE
+ END
+CDECK ID>, HWSGQQ.
+*CMZ :- -26/04/91 11.11.56 by Bryan Webber
+*-- Author : Bryan Webber
+C-----------------------------------------------------------------------
+ FUNCTION HWSGQQ(QSCA)
+C-----------------------------------------------------------------------
+C CORRECTION TO GLUON STRUCTURE FUNCTION FOR BACKWARD EVOLUTION:
+C G->Q-QBAR PART OF FORM FACTOR
+C-----------------------------------------------------------------------
+ INCLUDE 'HERWIG61.INC'
+ DOUBLE PRECISION HWSGQQ,HWUALF,QSCA,GG
+ EXTERNAL HWUALF
+ GG=HWUALF(1,QSCA)**(-ONE/BETAF)
+ IF (GG.LT.ONE) GG=ONE
+ IF (QSCA.GT.RMASS(6)) THEN
+ HWSGQQ=GG**6
+ ELSEIF (QSCA.GT.RMASS(5)) THEN
+ HWSGQQ=GG**5
+ ELSEIF (QSCA.GT.RMASS(4)) THEN
+ HWSGQQ=GG**4
+ ELSE
+ HWSGQQ=GG**3
+ ENDIF
+ END
+CDECK ID>, HWSSPC.
+*CMZ :- -26/04/91 11.11.56 by Bryan Webber
+*-- Author : Bryan Webber
+C-----------------------------------------------------------------------
+ SUBROUTINE HWSSPC
+C-----------------------------------------------------------------------
+C REPLACES SPACELIKE PARTONS BY SPECTATORS
+C-----------------------------------------------------------------------
+ INCLUDE 'HERWIG61.INC'
+ DOUBLE PRECISION HWUSQR,EMSQ,EMTR,EPAR,XPAR,QSQ,PCL(5)
+ INTEGER KHEP,IP,JP,IDH,IDP,ISP,IDSPC,JHEP
+ EXTERNAL HWUSQR
+ IF (IERROR.NE.0) RETURN
+ DO 50 KHEP=1,NHEP
+ IF (ISTHEP(KHEP).EQ.145.OR.ISTHEP(KHEP).EQ.146) THEN
+ IP=ISTHEP(KHEP)-144
+ JP=IP
+ IF (JDAHEP(1,IP).NE.0) JP=JDAHEP(1,IP)
+ IDH=IDHW(JP)
+ IDP=IDHW(KHEP)
+ IF (IDH.NE.IDP) THEN
+ IF (IDH.EQ.59) THEN
+C---PHOTON CASE
+ IF (IDP.LT.7) THEN
+ IDSPC=IDP+6
+ ELSEIF (IDP.LT.13) THEN
+ IDSPC=IDP-6
+ ELSE
+ CALL HWWARN('HWSSPC',100,*999)
+ ENDIF
+C---IDENTIFY SPECTATOR
+C (1) QUARK CASE
+ ELSEIF (IDP.LE.3) THEN
+ DO 10 ISP=1,12
+ 10 IF (IDH.EQ.NCLDK(LOCN(IDP,ISP))) GOTO 20
+ CALL HWWARN('HWSSPC',101,*999)
+ 20 IF (ISP.LE.3) THEN
+ IDSPC=ISP+6
+ ELSEIF (ISP.LE.9) THEN
+ IDSPC=ISP+105
+ ELSE
+ IDSPC=ISP
+ ENDIF
+C---(2) ANTIQUARK CASE
+ ELSEIF (IDP.GT.6.AND.IDP.LE.9) THEN
+ IDP=IDP-6
+ DO 30 ISP=1,12
+ 30 IF (IDH.EQ.NCLDK(LOCN(ISP,IDP))) GOTO 40
+ CALL HWWARN('HWSSPC',103,*999)
+ RETURN
+ 40 IF (ISP.LE.3) THEN
+ IDSPC=ISP
+ ELSEIF (ISP.LE.9) THEN
+ IDSPC=ISP+111
+ ELSE
+ IDSPC=ISP-6
+ ENDIF
+C---SPECIAL CASE FOR REMNANT HADRON
+ ELSEIF (IDH.EQ.71.OR.IDH.EQ.72) THEN
+ IF (IDP.EQ.13) THEN
+ IDSPC=IDP
+ ELSE
+ CALL HWWARN('HWSSPC',106,*999)
+ ENDIF
+ ELSE
+ CALL HWWARN('HWSSPC',105,*999)
+ ENDIF
+C---REPLACE PARTON BY SPECTATOR
+ IDHW(KHEP)=IDSPC
+ IDHEP(KHEP)=IDPDG(IDSPC)
+ ISTHEP(KHEP)=146+IP
+ EMSQ=SIGN(PHEP(5,KHEP)**2,PHEP(5,KHEP))
+ EMTR=EMSQ+PHEP(1,KHEP)**2+PHEP(2,KHEP)**2
+ EPAR=PHEP(4,KHEP)
+ CALL HWVDIF(4,PHEP(1,JP),PHEP(1,KHEP),PHEP(1,KHEP))
+ IF (EPAR**2.LT.10000.*ABS(EMTR)) THEN
+ CALL HWUMAS(PHEP(1,KHEP))
+ ELSE
+C---COMPUTE SPECTATOR MASS ELIMINATING ROUNDING ERRORS
+ XPAR=EPAR/PHEP(4,JP)
+ QSQ=SIGN(PHEP(5,JP)**2,PHEP(5,JP))
+ PHEP(5,KHEP)=HWUSQR((1.-XPAR)*QSQ+EMSQ-EMTR/XPAR
+ & -((QSQ*XPAR**2-EMTR)/(2*EPAR*XPAR**2))**2*XPAR)
+ ENDIF
+C---CHECK FOR UNPHYSICAL SPECTATOR
+ IF (PHEP(4,KHEP).LT.ZERO) FROST=.TRUE.
+C---FIND MASS OF CORRESPONDING CLUSTER, IF PARTNER IS IN THE SAME JET
+ IF (QORQQB(IDHW(KHEP))) THEN
+ JHEP=JMOHEP(2,KHEP)
+ ELSEIF (QBORQQ(IDHW(KHEP))) THEN
+ JHEP=JDAHEP(2,KHEP)
+ ELSE
+ JHEP=0
+ ENDIF
+ IF (JHEP.GT.0) THEN
+ CALL HWVSUM(4,PHEP(1,KHEP),PHEP(1,JHEP),PCL)
+ CALL HWUMAS(PCL)
+C---IF IT IS NEGATIVE, REJECT
+ IF (PCL(5).LT.ZERO) FROST=.TRUE.
+ ENDIF
+ ENDIF
+ ENDIF
+ 50 CONTINUE
+ 999 END
+CDECK ID>, HWSSUD.
+*CMZ :- -26/04/91 11.11.56 by Bryan Webber
+*-- Author : Bryan Webber
+C-----------------------------------------------------------------------
+ FUNCTION HWSSUD(I)
+C-----------------------------------------------------------------------
+ INCLUDE 'HERWIG61.INC'
+ DOUBLE PRECISION HWSSUD,HWSGQQ,DMIN,QSCA,XLAST,DIST(13)
+ INTEGER I,N0,IS,ID
+ EXTERNAL HWSGQQ
+ COMMON/HWTABC/XLAST,N0,IS,ID
+ DATA DMIN/1.D-15/
+ QSCA=QEV(N0+I,IS)
+ CALL HWSFUN(XLAST,QSCA,IDHW(INHAD),NSTRU,DIST,JNHAD)
+ IF (ID.EQ.13) DIST(ID)=DIST(ID)*HWSGQQ(QSCA)
+ IF (DIST(ID).LT.DMIN) DIST(ID)=DMIN
+ HWSSUD=SUD(N0+I,IS)/DIST(ID)
+ END
+CDECK ID>, HWSTAB.
+*CMZ :- -26/04/91 11.11.56 by Bryan Webber
+*-- Author : Adapted by Bryan Webber
+C-----------------------------------------------------------------------
+ FUNCTION HWSTAB(F,AFUN,NN,X,MM)
+C-----------------------------------------------------------------------
+C MODIFIED CERN INTERPOLATION ROUTINE DIVDIF
+C LIKE HWUTAB BUT USES FUNCTION AFUN IN PLACE OF ARRAY A
+C-----------------------------------------------------------------------
+ IMPLICIT NONE
+ INTEGER NN,MM,MMAX,N,M,MPLUS,IX,IY,MID,NPTS,IP,I,J,L,ISUB
+ DOUBLE PRECISION HWSTAB,AFUN,SUM,X,F(NN),T(20),D(20)
+ LOGICAL EXTRA
+ EXTERNAL AFUN
+ DATA MMAX/10/
+ N=NN
+ M=MIN(MM,MMAX,N-1)
+ MPLUS=M+1
+ IX=0
+ IY=N+1
+ IF (AFUN(1).GT.AFUN(N)) GOTO 94
+ 91 MID=(IX+IY)/2
+ IF (X.GE.AFUN(MID)) GOTO 92
+ IY=MID
+ GOTO 93
+ 92 IX=MID
+ 93 IF (IY-IX.GT.1) GOTO 91
+ GOTO 97
+ 94 MID=(IX+IY)/2
+ IF (X.LE.AFUN(MID)) GOTO 95
+ IY=MID
+ GOTO 96
+ 95 IX=MID
+ 96 IF (IY-IX.GT.1) GOTO 94
+ 97 NPTS=M+2-MOD(M,2)
+ IP=0
+ L=0
+ GOTO 99
+ 98 L=-L
+ IF (L.GE.0) L=L+1
+ 99 ISUB=IX+L
+ IF ((1.LE.ISUB).AND.(ISUB.LE.N)) GOTO 100
+ NPTS=MPLUS
+ GOTO 101
+ 100 IP=IP+1
+ T(IP)=AFUN(ISUB)
+ D(IP)=F(ISUB)
+ 101 IF (IP.LT.NPTS) GOTO 98
+ EXTRA=NPTS.NE.MPLUS
+ DO 14 L=1,M
+ IF (.NOT.EXTRA) GOTO 12
+ ISUB=MPLUS-L
+ D(M+2)=(D(M+2)-D(M))/(T(M+2)-T(ISUB))
+ 12 I=MPLUS
+ DO 13 J=L,M
+ ISUB=I-L
+ D(I)=(D(I)-D(I-1))/(T(I)-T(ISUB))
+ I=I-1
+ 13 CONTINUE
+ 14 CONTINUE
+ SUM=D(MPLUS)
+ IF (EXTRA) SUM=0.5*(SUM+D(M+2))
+ J=M
+ DO 15 L=1,M
+ SUM=D(J)+(X-T(J))*SUM
+ J=J-1
+ 15 CONTINUE
+ HWSTAB=SUM
+ END
+CDECK ID>, HWSVAL.
+*CMZ :- -26/04/91 10.18.58 by Bryan Webber
+*-- Author : Bryan Webber
+C-----------------------------------------------------------------------
+ FUNCTION HWSVAL(ID)
+C-----------------------------------------------------------------------
+C TRUE FOR VALENCE PARTON ID IN INCOMING HADRON INHAD
+C-----------------------------------------------------------------------
+ INCLUDE 'HERWIG61.INC'
+ INTEGER ID,IDHAD
+ LOGICAL HWSVAL
+ HWSVAL=.FALSE.
+ IDHAD=IDHW(INHAD)
+ IF (IDHAD.EQ.73.OR.IDHAD.EQ.75) THEN
+ IF (ID.EQ.1.OR.ID.EQ.2) HWSVAL=.TRUE.
+ ELSEIF (IDHAD.EQ.91.OR.IDHAD.EQ.93) THEN
+ IF (ID.EQ.7.OR.ID.EQ.8) HWSVAL=.TRUE.
+ ELSEIF (IDHAD.EQ.30) THEN
+ IF (ID.EQ.1.OR.ID.EQ.8) HWSVAL=.TRUE.
+ ELSEIF (IDHAD.EQ.38) THEN
+ IF (ID.EQ.2.OR.ID.EQ.7) HWSVAL=.TRUE.
+ ELSEIF (IDHAD.EQ.59) THEN
+ IF (ID.LT.6.OR.(ID.GT.6.AND.ID.LT.12)) HWSVAL=.TRUE.
+ ELSEIF (IDHAD.EQ.71.OR.IDHAD.EQ.72) THEN
+ IF (ID.EQ.13) HWSVAL=.TRUE.
+ ELSE
+ CALL HWWARN('HWSVAL',100,*999)
+ ENDIF
+ 999 END
+CDECK ID>, HWUAEM.
+*CMZ :- -23/08/94 13.22.29 by Mike Seymour
+*-- Author : Ian Knowles
+C-----------------------------------------------------------------------
+ FUNCTION HWUAEM(Q2)
+C-----------------------------------------------------------------------
+C Running electromagnetic coupling constant.
+C See R. Kleiss et al.: CERN yellow report 89-08, vol.3 p.129
+C Hadronic component from: H. Burkhardt et al.: Z. Phys C43 (89) 497
+C-----------------------------------------------------------------------
+ INCLUDE 'HERWIG61.INC'
+ DOUBLE PRECISION HWUAEM,HWUAER,Q2,EPS,A1,B1,C1,A2,B2,C2,A3,B3,C3,
+ & A4,B4,C4,AEMPI,EEL2,EMU2,ETAU2,ETOP2,REPIGG,X
+ LOGICAL FIRST
+ EXTERNAL HWUAER
+ SAVE FIRST,AEMPI,EEL2,EMU2,ETAU2,ETOP2
+ PARAMETER (EPS=1.D-6)
+ DATA A1,B1,C1/0.0 ,0.00835,1.000/
+ DATA A2,B2,C2/0.0 ,0.00238,3.927/
+ DATA A3,B3,C3/0.00165,0.00299,1.000/
+ DATA A4,B4,C4/0.00221,0.00293,1.000/
+ DATA FIRST/.TRUE./
+ IF (FIRST) THEN
+ AEMPI=ALPHEM/(THREE*PIFAC)
+ EEL2 =RMASS(121)**2
+ EMU2 =RMASS(123)**2
+ ETAU2=RMASS(125)**2
+ ETOP2=RMASS(6)**2
+ FIRST=.FALSE.
+ ENDIF
+ IF (ABS(Q2).LT.EPS) THEN
+ HWUAEM=ALPHEM
+ RETURN
+ ENDIF
+C Leptonic component
+ REPIGG=AEMPI*(HWUAER(EEL2/Q2)+HWUAER(EMU2/Q2)+HWUAER(ETAU2/Q2))
+C Hadronic component from light quarks
+ X=ABS(Q2)
+ IF (X.LT.9.D-2) THEN
+ REPIGG=REPIGG+A1+B1*LOG(ONE+C1*X)
+ ELSEIF (X.LT.9.D0) THEN
+ REPIGG=REPIGG+A2+B2*LOG(ONE+C2*X)
+ ELSEIF (X.LT.1.D4) THEN
+ REPIGG=REPIGG+A3+B3*LOG(ONE+C3*X)
+ ELSE
+ REPIGG=REPIGG+A4+B4*LOG(ONE+C4*X)
+ ENDIF
+C Top Contribution
+ REPIGG=REPIGG+AEMPI*HWUAER(ETOP2/Q2)
+ HWUAEM=ALPHEM/(ONE-REPIGG)
+ RETURN
+ END
+CDECK ID>, HWUAER.
+*CMZ :- -23/08/94 13.22.29 by Mike Seymour
+*-- Author : Ian Knowles
+C-----------------------------------------------------------------------
+ FUNCTION HWUAER(R)
+C-----------------------------------------------------------------------
+C Real part of photon self-energy: Pi_{gg}(R=M^2/Q^2)
+C-----------------------------------------------------------------------
+ DOUBLE PRECISION HWUAER,R,ZERO,ONE,TWO,FOUR,FVTHR,THIRD,RMAX,BETA
+ PARAMETER (ZERO=0.D0, ONE=1.D0, TWO=2.D0, FOUR=4.D0,
+ & FVTHR=1.666666666666667D0, THIRD=.3333333333333333D0)
+ PARAMETER (RMAX=1.D6)
+ IF (ABS(R).LT.1.D-3) THEN
+C Use assymptotic formula
+ HWUAER=-FVTHR-LOG(ABS(R))
+ ELSEIF (ABS(R).GT.RMAX) THEN
+ HWUAER=ZERO
+ ELSEIF (FOUR*R.GT.ONE) THEN
+ BETA=SQRT(FOUR*R-ONE)
+ HWUAER=THIRD
+ & -(ONE+TWO*R)*(TWO-BETA*ACOS(ONE-ONE/(TWO*R)))
+ ELSE
+ BETA=SQRT(ONE-FOUR*R)
+ HWUAER=THIRD
+ & -(ONE+TWO*R)*(TWO+BETA*LOG(ABS((BETA-ONE)/(BETA+ONE))))
+ ENDIF
+ RETURN
+ END
+CDECK ID>, HWUALF.
+*CMZ :- -15/07/92 14.08.45 by Mike Seymour
+*-- Author : Bryan Webber
+C-----------------------------------------------------------------------
+ FUNCTION HWUALF(IOPT,SCALE)
+C-----------------------------------------------------------------------
+C STRONG COUPLING CONSTANT
+C IOPT.EQ.0 INITIALIZES
+C .EQ.1 TWO-LOOP, FLAVOUR THRESHOLDS
+C .EQ.2 RATIO OF ABOVE TO ONE-LOOP
+C WITH 5-FLAVOUR BETA, LAMBDA=QCDL3
+C .EQ.3 ONE-LOOP WITH 5-FLAVOUR BETA, LAMBDA=QCDL3
+C-----------------------------------------------------------------------
+ INCLUDE 'HERWIG61.INC'
+ DOUBLE PRECISION HWUALF,SCALE,KAFAC,B3,B4,B5,B6,C3,C4,C5,C6,C35,
+ & C45,C65,D35,RHO,RAT,RLF,DRH,EPS
+ INTEGER IOPT,ITN
+ SAVE B3,B4,B5,B6,C3,C4,C5,C6,C35,C45,C65,D35
+ DATA EPS/1.D-6/
+ IF (IOPT.EQ.0) THEN
+C---INITIALIZE CONSTANTS
+ CAFAC=FLOAT(NCOLO)
+ CFFAC=FLOAT(NCOLO**2-1)/(2.*CAFAC)
+ B3=((11.*CAFAC)- 6.)/(12.*PIFAC)
+ B4=((11.*CAFAC)- 8.)/(12.*PIFAC)
+ B5=((11.*CAFAC)-10.)/(12.*PIFAC)
+ B6=((11.*CAFAC)-12.)/(12.*PIFAC)
+ BETAF=6.*PIFAC*B5
+ C3=((17.*CAFAC**2)-(5.*CAFAC+3.*CFFAC)*3.)/(24.*PIFAC**2)/B3**2
+ C4=((17.*CAFAC**2)-(5.*CAFAC+3.*CFFAC)*4.)/(24.*PIFAC**2)/B4**2
+ C5=((17.*CAFAC**2)-(5.*CAFAC+3.*CFFAC)*5.)/(24.*PIFAC**2)/B5**2
+ C6=((17.*CAFAC**2)-(5.*CAFAC+3.*CFFAC)*6.)/(24.*PIFAC**2)/B6**2
+ KAFAC=CAFAC*(67./18.-PIFAC**2/6.)-25./9.
+C---QCDLAM IS 5-FLAVOUR LAMBDA-MS-BAR AT LARGE X OR Z
+C---QCDL5 IS 5-FLAVOUR LAMBDA-MC
+ QCDL5=QCDLAM*EXP(KAFAC/(4.*PIFAC*B5))/SQRT(2.D0)
+C---COMPUTE THRESHOLD MATCHING
+ RHO=2.*LOG(RMASS(6)/QCDL5)
+ RAT=LOG(RHO)/RHO
+ C65=(B5/(1.-C5*RAT)-B6/(1.-C6*RAT))*RHO
+ RHO=2.*LOG(RMASS(5)/QCDL5)
+ RAT=LOG(RHO)/RHO
+ C45=(B5/(1.-C5*RAT)-B4/(1.-C4*RAT))*RHO
+ RHO=2.*LOG(RMASS(4)/QCDL5)
+ RAT=LOG(RHO)/RHO
+ C35=(B4/(1.-C4*RAT)-B3/(1.-C3*RAT))*RHO+C45
+C---FIND QCDL3
+ D35=-1./(B3*C35)
+ DO 10 ITN=1,100
+ RAT=LOG(D35)/D35
+ RLF=B3*D35/(1.-C3*RAT)
+ DRH=B3*(RLF+C35)*D35**2/((1.-2.*C3*RAT+C3/D35)*RLF**2)
+ D35=D35-DRH
+ IF (ABS(DRH).LT.EPS*D35) GOTO 20
+ 10 CONTINUE
+ 20 QCDL3=QCDL5*EXP(0.5*D35)
+ ENDIF
+ IF (SCALE.LE.QCDL5) CALL HWWARN('HWUALF',51,*999)
+ RHO=2.*LOG(SCALE/QCDL5)
+ IF (IOPT.EQ.3) THEN
+ IF (RHO.LE.D35) CALL HWWARN('HWUALF',52,*999)
+ HWUALF=1./(B5*(RHO-D35))
+ RETURN
+ ENDIF
+ RAT=LOG(RHO)/RHO
+ IF (SCALE.GT.RMASS(6)) THEN
+ RLF=B6*RHO/(1.-C6*RAT)+C65
+ ELSEIF (SCALE.GT.RMASS(5)) THEN
+ RLF=B5*RHO/(1.-C5*RAT)
+ ELSEIF (SCALE.GT.RMASS(4)) THEN
+ RLF=B4*RHO/(1.-C4*RAT)+C45
+ ELSE
+ RLF=B3*RHO/(1.-C3*RAT)+C35
+ ENDIF
+ IF (RLF.LE.ZERO) CALL HWWARN('HWUALF',53,*999)
+ IF (IOPT.EQ.1) THEN
+ HWUALF=1./RLF
+ ELSE
+ HWUALF=B5*(RHO-D35)/RLF
+ IF (HWUALF.GT.ONE) CALL HWWARN('HWUALF',54,*999)
+ ENDIF
+ RETURN
+ 999 HWUALF=ZERO
+ END
+CDECK ID>, HWUANT.
+*CMZ :- -27/07/99 13.33.03 by Mike Seymour
+*-- Author : Ian Knowles
+C-----------------------------------------------------------------------
+ FUNCTION HWUANT(IPART)
+C-----------------------------------------------------------------------
+C Returns the antiparticle of IPART; uses HERWIG numbering
+C-----------------------------------------------------------------------
+ INCLUDE 'HERWIG61.INC'
+ INTEGER HWUANT,IPART,IPDG,IANTI,OLDERR
+ CHARACTER*8 CDUM
+ OLDERR=IERROR
+ IPDG=IDPDG(IPART)
+ IF (IPDG.EQ. 9.OR.IPDG.EQ.21.OR.IPDG.EQ.22.OR.IPDG.EQ.23.OR.
+ & IPDG.EQ.25.OR.IPDG.EQ.26.OR.IPDG.EQ.32.OR.IPDG.EQ.35.OR.
+ & IPDG.EQ.36.OR.IPDG.EQ.91.OR.IPDG.EQ.98.OR.IPDG.EQ.99.OR.
+ & IPDG.EQ.130.OR.IPDG.EQ.310.OR.
+ & IPDG.EQ.1000021.OR.IPDG.EQ.1000022.OR.IPDG.EQ.1000023.OR.
+ & IPDG.EQ.1000025.OR.IPDG.EQ.1000035.OR.IPDG.EQ.1000039.OR.
+ & (FLOAT(INT(RSPIN(IPART))).EQ.RSPIN(IPART).AND.
+ & MOD(IPDG/100,10).EQ.MOD(IPDG/10,10).AND.
+ & MOD(IPDG/10,10).NE.0)) THEN
+C Self-conjugate boson
+ IANTI=IPART
+ ELSEIF(IPART.EQ.211.OR.IPART.EQ.212) THEN
+C Fourth generation (anti-)quarks
+ IANTI=IPART+6
+ ELSEIF(IPART.EQ.217.OR.IPART.EQ.218) THEN
+ IANTI=IPART-6
+ ELSE
+C Non-zero charge particle
+ CALL HWUIDT(1,-IPDG,IANTI,CDUM)
+ ENDIF
+ IF (IANTI.EQ.20) WRITE(6,10) RNAME(IPART)
+ 10 FORMAT(1X,A8,' has no antiparticle'/)
+ HWUANT=IANTI
+ IERROR=OLDERR
+ END
+CDECK ID>, HWUATS.
+*CMZ :- -07/07/99 17.42.00 by Kosuke Odagiri
+*-- Author : Kosuke Odagiri
+C-----------------------------------------------------------------------
+ SUBROUTINE HWUATS
+C-----------------------------------------------------------------------
+C Replaces all &'s in TXNAME by \'s
+C-----------------------------------------------------------------------
+ INCLUDE 'HERWIG61.INC'
+ INTEGER I,J,L
+ CHARACTER*1 Z
+ Z=CHAR(92)
+ L=LEN(TXNAME(1,1))
+ DO 1 I=0,NMXRES
+ DO 2 J=1,L
+ IF (TXNAME(1,I)(J:J).EQ.'&') TXNAME(1,I)(J:J)=Z
+ 2 CONTINUE
+ 1 CONTINUE
+ END
+CDECK ID>, HWUBPR.
+*CMZ :- -26/04/91 10.18.58 by Bryan Webber
+*-- Author : Bryan Webber
+C-----------------------------------------------------------------------
+ SUBROUTINE HWUBPR
+C-----------------------------------------------------------------------
+C PRINTS OUT DATA ON PARTON SHOWER
+C-----------------------------------------------------------------------
+ INCLUDE 'HERWIG61.INC'
+ INTEGER I,J
+ IF (PRVTX) THEN
+ WRITE(6,10) INHAD,XFACT
+ 10 FORMAT(///10X,'DATA ON LAST PARTON SHOWER: INHAD =',I3,
+ & ' XFACT =',E11.3//' IPAR ID TM DA1 CMO AMO CDA',
+ & ' ADA P-X P-Y P-Z ENERGY MASS',
+ & ' V-X V-Y V-Z V-C*T')
+ DO 20 J=1,NPAR
+ 20 WRITE(6,30) J,RNAME(ABS(IDPAR(J))),TMPAR(J),JDAPAR(1,J),
+ & (JCOPAR(I,J),I=1,4),(PPAR(I,J),I=1,5),(VPAR(I,J),I=1,4)
+ 30 FORMAT(I5,1X,A8,L2,5I4,F7.2,4F8.2,4E11.4)
+ ELSE
+ WRITE(6,40) INHAD,XFACT
+ 40 FORMAT(///10X,'DATA ON LAST PARTON SHOWER: INHAD =',I3,
+ & ' XFACT =',E11.3//' IPAR ID TM DA1 CMO AMO CDA',
+ & ' ADA P-X P-Y P-Z ENERGY MASS')
+ DO 50 J=1,NPAR
+ 50 WRITE(6,60) J,RNAME(ABS(IDPAR(J))),TMPAR(J),JDAPAR(1,J),
+ & (JCOPAR(I,J),I=1,4),(PPAR(I,J),I=1,5)
+ 60 FORMAT(I5,1X,A8,L2,5I4,F7.2,4F8.2)
+ ENDIF
+ END
+CDECK ID>, HWUBST.
+*CMZ :- -18/10/93 10.21.56 by Mike Seymour
+*-- Author : Mike Seymour
+C-----------------------------------------------------------------------
+ SUBROUTINE HWUBST(IOPT)
+C-----------------------------------------------------------------------
+C BOOST THE ENTIRE EVENT RECORD TO (IOPT=1) OR FROM (IOPT=0) ITS
+C CENTRE-OF-MASS FRAME, WITH INCOMING HADRONS ON Z-AXIS
+C-----------------------------------------------------------------------
+ INCLUDE 'HERWIG61.INC'
+ DOUBLE PRECISION PBOOST(5),RBOOST(3,3)
+ INTEGER IOPT,IHEP,BOOSTD,IHAD
+ SAVE BOOSTD,PBOOST,RBOOST
+ DATA BOOSTD/-1/
+ IF (IERROR.NE.0) RETURN
+ IF (IOPT.EQ.1) THEN
+C---FIND FIRST INCOMING HADRON
+ IHAD=1
+ IF (JDAHEP(1,IHAD).NE.0) IHAD=JDAHEP(1,IHAD)
+C---IF WE'RE ALREADY IN THE RIGHT FRAME, DON'T DO ANYTHING
+ IF (PHEP(1,3)**2+PHEP(2,3)**2+PHEP(3,3)**2.EQ.ZERO .AND.
+ & PHEP(1,IHAD)**2+PHEP(2,IHAD)**2.EQ.ZERO) RETURN
+C---FIND AND APPLY BOOST
+ CALL HWVEQU(5,PHEP(1,3),PBOOST)
+ DO 100 IHEP=1,NHEP
+ CALL HWULOF(PBOOST,PHEP(1,IHEP),PHEP(1,IHEP))
+ CALL HWULOF(PBOOST,VHEP(1,IHEP),VHEP(1,IHEP))
+ 100 CONTINUE
+ CALL HWULOF(PBOOST,VTXPIP,VTXPIP)
+C---FIND AND APPLY ROTATION TO PUT IT ON Z-AXIS
+ CALL HWUROT(PHEP(1,IHAD),ONE,ZERO,RBOOST)
+ DO 110 IHEP=1,NHEP
+ CALL HWUROF(RBOOST,PHEP(1,IHEP),PHEP(1,IHEP))
+ CALL HWUROF(RBOOST,VHEP(1,IHEP),VHEP(1,IHEP))
+ 110 CONTINUE
+ CALL HWUROF(RBOOST,VTXPIP,VTXPIP)
+C---ENSURE THAT WE ONLY EVER UNBOOST THE SAME EVENT THAT WE BOOSTED
+C (BEARING IN MIND THAT NWGTS IS UPDATED AFTER GENERATING THE WEIGHT)
+ BOOSTD=NWGTS+1
+ ELSEIF (IOPT.EQ.0) THEN
+ IF (BOOSTD.NE.NWGTS) RETURN
+C---UNDO ROTATION AND BOOST
+ DO 200 IHEP=1,NHEP
+ CALL HWUROB(RBOOST,PHEP(1,IHEP),PHEP(1,IHEP))
+ CALL HWULOB(PBOOST,PHEP(1,IHEP),PHEP(1,IHEP))
+ CALL HWUROB(RBOOST,VHEP(1,IHEP),VHEP(1,IHEP))
+ CALL HWULB4(PBOOST,VHEP(1,IHEP),VHEP(1,IHEP))
+ 200 CONTINUE
+ ENDIF
+ END
+CDECK ID>, HWUCFF.
+*CMZ :- -23/08/94 13.22.29 by Mike Seymour
+*-- Author : Bryan Webber and Ian Knowles
+C-----------------------------------------------------------------------
+ SUBROUTINE HWUCFF(I,J,QSQ,CLF)
+C-----------------------------------------------------------------------
+C Calculates basic coefficients in cross-section formula for
+C ffbar --> f'fbar', at virtuality QSQ, I labels initial, J
+C labels final fermion; type given as:
+C I,J= 1- 6: d,u,s,c,b,t
+C =11-16: e,nu_e,mu,nu_mu,tau,nu_tau
+C-----------------------------------------------------------------------
+ INCLUDE 'HERWIG61.INC'
+ DOUBLE PRECISION QSQ,CLF(7),POL1,POL2,QIF,VI,AI,VF,AF,PG,DQM,PMW,
+ & DEN,XRE,XIM,XSQ,VI2,AI2,VF2,AF2,PG2,PG12,DQM2,PMW2,DEN2,XRE2,
+ & XIM2,XSQ2,XRE12,XIM12
+ INTEGER I,J
+C Longitudinal Polarisation factors
+ POL1=1.-EPOLN(3)*PPOLN(3)
+ POL2=PPOLN(3)-EPOLN(3)
+C Standard model couplings
+ QIF=QFCH(I)*QFCH(J)
+ VI=VFCH(I,1)
+ AI=AFCH(I,1)
+ VF=VFCH(J,1)
+ AF=AFCH(J,1)
+ PG=POL1*(VI**2+AI**2)+POL2*2.*VI*AI
+C Z propagator factors
+ DQM=QSQ-RMASS(200)**2
+ PMW=GAMZ*RMASS(200)
+ DEN=QSQ/(DQM**2+PMW**2)
+ XRE=DEN*DQM
+ XIM=DEN*PMW
+ XSQ=DEN*QSQ
+C Calculate cross-section coefficients
+ CLF(1)=POL1*QIF**2+XRE*2.*QIF*(POL1*VI+POL2*AI)*VF
+ & +XSQ*PG*(VF**2+AF**2)
+ CLF(2)=CLF(1)-2.*XSQ*PG*AF**2
+ CLF(3)=2.*(XRE*QIF*(POL1*AI+POL2*VI)*AF
+ & +XSQ*(POL1*2.*VI*AI+POL2*(VI**2+AI**2))*VF*AF)
+ IF (TPOL) THEN
+ CLF(4)=QIF**2+XRE*2.*QIF*VI*VF+XSQ*(VI**2-AI**2)*(VF**2+AF**2)
+ CLF(5)=CLF(4)-2.*XSQ*(VI**2-AI**2)*AF**2
+ CLF(6)=XIM*2.*QIF*AI*VF
+ CLF(7)=CLF(6)
+ ENDIF
+ IF (ZPRIME) THEN
+C Z' couplings:
+ VI2=VFCH(I,2)
+ AI2=AFCH(I,2)
+ VF2=VFCH(J,2)
+ AF2=AFCH(J,2)
+ PG2=POL1*(VI2**2+AI2**2)+POL2*2.*VI2*AI2
+ PG12=POL1*(VI*VI2+AI*AI2)+POL2*(VI*AI2+AI+VI2)
+C Z' propagator factors
+ DQM2=QSQ-RMASS(202)**2
+ PMW2=RMASS(202)*GAMZP
+ DEN2=QSQ/(DQM2**2+PMW2**2)
+ XRE2=DEN2*DQM2
+ XIM2=DEN2*PMW2
+ XSQ2=DEN2*QSQ
+ XRE12=DEN*DEN2*(DQM*DQM2+PMW*PMW2)
+ XIM12=DEN*DEN2*(DQM*PMW2-DQM2*PMW)
+C Additional contributions to cross-section coefficients
+ CLF(1)=CLF(1)+XRE2*2.*QIF*(POL1*VI2+POL2*AI2)*VF2
+ & +XSQ2*PG2*(VF2**2+AF2**2)+XRE12*2.*PG12*(VF*VF2+AF*AF2)
+ CLF(2)=CLF(1)-2.*(XSQ2*PG2*AF2**2+XRE12*2.*PG12*AF*AF2)
+ CLF(3)=CLF(3)+2.*(XRE2*QIF*(POL1*AI2+POL2*VI2)*AF2
+ & +XSQ2*(POL1*2.*VI2*AI2+POL2*(VI2**2+AI2**2))*VF2*AF2
+ & +XRE12*(POL1*(VI*AI2+AI*VI2)+POL1*(VI*VI2+AI*AI2))
+ & *(VF*VF2+AF*AF2))
+ IF (TPOL) THEN
+ CLF(4)=CLF(4)+XRE2*2.*QIF*VI2*VF2
+ & +XSQ2*(VI2**2-AI2**2)*(VF2**2+AF2**2)
+ & +XRE12*2.*(VI*VI2-AI*AI2)*(VF*VF2+AF*AF2)
+ CLF(5)=CLF(4)-2*(XSQ2*(VI2**2-AI2**2)*AF2**2
+ & +XRE12*2.*(VI*VI2-AI*AI2)*AF*AF2)
+ CLF(6)=CLF(6)+2.*(XIM2*QIF*AI2*VF2
+ & -XIM12*(VI*AI2-AI*VI2)*(VF*VF2+AF*AF2))
+ CLF(7)=CLF(6)+4.*XIM12*(VI*AI2-AI*AI2)*AF*AF2
+ ENDIF
+ ENDIF
+ RETURN
+ END
+CDECK ID>, HWUCI2.
+*CMZ :- -23/08/94 13.22.29 by Mike Seymour
+*-- Author : Ulrich Baur & Nigel Glover, adapted by Ian Knowles
+C-----------------------------------------------------------------------
+ FUNCTION HWUCI2(A,B,Y0)
+C-----------------------------------------------------------------------
+C Integral LOG(A-EPSI-BY(1-Y))/(Y-Y0)
+C-----------------------------------------------------------------------
+ IMPLICIT NONE
+ DOUBLE COMPLEX HWUCI2,HWULI2,EPSI,Y1,Y2,Z1,Z2,Z3,Z4
+ DOUBLE PRECISION A,B,Y0,ZERO,ONE,FOUR,HALF
+ EXTERNAL HWULI2
+ COMMON/SMALL/EPSI
+ PARAMETER (ZERO=0.D0, ONE =1.D0, FOUR= 4.D0, HALF=0.5D0)
+ IF(B.EQ.ZERO)THEN
+ HWUCI2=CMPLX(ZERO,ZERO)
+ ELSE
+ Y1=HALF*(ONE+SQRT(ONE-FOUR*(A+EPSI)/B))
+ Y2=ONE-Y1
+ Z1=Y0/(Y0-Y1)
+ Z2=(Y0-ONE)/(Y0-Y1)
+ Z3=Y0/(Y0-Y2)
+ Z4=(Y0-ONE)/(Y0-Y2)
+ HWUCI2=HWULI2(Z1)-HWULI2(Z2)+HWULI2(Z3)-HWULI2(Z4)
+ ENDIF
+ RETURN
+ END
+CDECK ID>, HWUDAT.
+*CMZ :- -26/04/91 10.18.58 by Bryan Webber
+*-- Author : Ian Knowles & Bryan Webber
+C-----------------------------------------------------------------------
+ BLOCK DATA HWUDAT
+C-----------------------------------------------------------------------
+C Loads common blocks with particle properties data; for particle I:
+C RNAME(I) = Name
+C IDPDG(I) = PDG code
+C IFLAV(I) = HERWIG flavour code
+C ICHRG(I) = Electric charge (|e-|) (*3 for (di-)quarks)
+C RMASS(I) = Mass (GeV/c^2)
+C RLTIM(I) = Proper life time (s)
+C RSPIN(I) = Spin
+C QORQQB(I) = .TRUE. if it is a quark or an antidiquark
+C QBORQQ(I) = .TRUE. if it is an antiquark or a diquark
+C And stores the particle decay tables: call HWUDPR to print them
+C-----------------------------------------------------------------------
+ INCLUDE 'HERWIG61.INC'
+ INTEGER NLAST,NNEXT,NLEFT,NREST,I,J,MMWIDE,MMLONG,MMHOFF,MMVOFF
+ COMMON/PAPER/MMWIDE,MMLONG,MMHOFF,MMVOFF
+ PARAMETER (NLAST=458,NNEXT=458+1,NLEFT=NMXRES-458)
+ PARAMETER (NREST=NMXRES-120)
+ DATA NRES/458/
+C Don't forget to change the three occurances above as well
+ DATA MMWIDE,MMLONG,MMHOFF,MMVOFF/190,280,-39,-35/
+ DATA (RNAME(I),IDPDG(I),IFLAV(I),ICHRG(I),RMASS(I),RLTIM(I),
+ & RSPIN(I),I=0,16)/
+ & ' ', 0, 0, 0,0.0000,0.000D+00,0.0,
+ & 'DQRK ', 1, 0,-1,0.3200,0.000D+00,0.5,
+ & 'UQRK ', 2, 0,+2,0.3200,0.000D+00,0.5,
+ & 'SQRK ', 3, 0,-1,0.5000,0.000D+00,0.5,
+ & 'CQRK ', 4, 0,+2,1.5500,0.000D+00,0.5,
+ & 'BQRK ', 5, 0,-1,4.9500,0.000D+00,0.5,
+ & 'TQRK ', 6, 0,+2,170.00,0.000D+00,0.5,
+ & 'DBAR ', -1, 0,+1,0.3200,0.000D+00,0.5,
+ & 'UBAR ', -2, 0,-2,0.3200,0.000D+00,0.5,
+ & 'SBAR ', -3, 0,+1,0.5000,0.000D+00,0.5,
+ & 'CBAR ', -4, 0,-2,1.5500,0.000D+00,0.5,
+ & 'BBAR ', -5, 0,+1,4.9500,0.000D+00,0.5,
+ & 'TBAR ', -6, 0,-2,170.00,0.000D+00,0.5,
+ & 'GLUON ', 21, 0, 0,0.7500,0.000D+00,1.0,
+ & 'CMF ', 0, 0, 0,0.0000,0.000D+00,0.0,
+ & 'HARD ', 0, 0, 0,0.0000,0.000D+00,0.0,
+ & 'SOFT ', 0, 0, 0,0.0000,0.000D+00,0.0/
+ DATA (RNAME(I),IDPDG(I),IFLAV(I),ICHRG(I),RMASS(I),RLTIM(I),
+ & RSPIN(I),I=17,32)/
+ & 'CONE ', 0, 0, 0,0.0000,0.000D+00,0.0,
+ & 'HEAVY ', 0, 0, 0,0.0000,0.000D+00,0.0,
+ & 'CLUS ', 91, 0, 0,0.0000,0.000D+00,0.0,
+ & '**** ', 0, 0, 0,0.0000,0.000D+00,0.0,
+ & 'PI0 ', 111, 11, 0,.13498,8.400D-17,0.0,
+ & 'ETA ', 221, 33, 0,.54730,0.000D+00,0.0,
+ & 'RHO0 ', 113, 11, 0,.77000,0.000D+00,1.0,
+ & 'OMEGA ', 223, 33, 0,.78194,0.000D+00,1.0,
+ & 'ETAP ', 331, 33, 0,.95778,0.000D+00,0.0,
+ & 'F_2 ', 225, 33, 0,1.2750,0.000D+00,2.0,
+ & 'A_10 ', 20113, 11, 0,1.2300,0.000D+00,1.0,
+ & 'FL_1 ', 20223, 33, 0,1.2819,0.000D+00,1.0,
+ & 'A_20 ', 115, 11, 0,1.3181,0.000D+00,2.0,
+ & 'PI- ', -211, 12,-1,.13957,2.603D-08,0.0,
+ & 'RHO- ', -213, 12,-1,.77000,0.000D+00,1.0,
+ & 'A_1- ', -20213, 12,-1,1.2300,0.000D+00,1.0/
+ DATA (RNAME(I),IDPDG(I),IFLAV(I),ICHRG(I),RMASS(I),RLTIM(I),
+ & RSPIN(I),I=33,48)/
+ & 'A_2- ', -215, 12,-1,1.3181,0.000D+00,2.0,
+ & 'K- ', -321, 32,-1,.49368,1.237D-08,0.0,
+ & 'K*- ', -323, 32,-1,.89166,0.000D+00,1.0,
+ & 'KH_1- ', -20323, 32,-1,1.8500,0.000D+00,1.0,
+ & 'K*_2- ', -325, 32,-1,1.4256,0.000D+00,2.0,
+ & 'PI+ ', 211, 21,+1,.13957,2.603D-08,0.0,
+ & 'RHO+ ', 213, 21,+1,.77000,0.000D+00,1.0,
+ & 'A_1+ ', 20213, 21,+1,1.2300,0.000D+00,1.0,
+ & 'A_2+ ', 215, 21,+1,1.3181,0.000D+00,2.0,
+ & 'KBAR0 ', -311, 31, 0,.49767,0.000D+00,0.0,
+ & 'K*BAR0 ', -313, 31, 0,.89610,0.000D+00,1.0,
+ & 'KH_1BAR0', -20313, 31, 0,1.8500,0.000D+00,1.0,
+ & 'K*_2BAR0', -315, 31, 0,1.4324,0.000D+00,2.0,
+ & 'K+ ', 321, 23,+1,.49368,1.237D-08,0.0,
+ & 'K*+ ', 323, 23,+1,.89166,0.000D+00,1.0,
+ & 'KH_1+ ', 20323, 23,+1,1.8500,0.000D+00,1.0/
+ DATA (RNAME(I),IDPDG(I),IFLAV(I),ICHRG(I),RMASS(I),RLTIM(I),
+ & RSPIN(I),I=49,64)/
+ & 'K*_2+ ', 325, 23,+1,1.4256,0.000D+00,2.0,
+ & 'K0 ', 311, 13, 0,.49767,0.000D+00,0.0,
+ & 'K*0 ', 313, 13, 0,.89610,0.000D+00,1.0,
+ & 'KH_10 ', 20313, 13, 0,1.8500,0.000D+00,1.0,
+ & 'K*_20 ', 315, 13, 0,1.4324,0.000D+00,2.0,
+ & ' ', 0, 0, 0,0.0000,0.000D+00,0.0,
+ & ' ', 0, 0, 0,0.0000,0.000D+00,0.0,
+ & 'PHI ', 333, 33, 0,1.0194,0.000D+00,1.0,
+ & 'FH_1 ', 20333, 33, 0,1.4262,0.000D+00,1.0,
+ & 'FP_2 ', 335, 33, 0,1.5250,0.000D+00,2.0,
+ & 'GAMMA ', 22, 0, 0,0.0000,1.000D+30,1.0,
+ & 'K_S0 ', 310, 0, 0,.49767,8.926D-11,0.0,
+ & 'K_L0 ', 130, 0, 0,.49767,5.170D-08,0.0,
+ & 'A_0(H)0 ', 10111, 11, 0,1.4740,0.000D+00,0.0,
+ & 'A_0(H)+ ', 10211, 21,+1,1.4740,0.000D+00,0.0,
+ & 'A_0(H)- ', -10211, 12,-1,1.4740,0.000D+00,0.0/
+ DATA (RNAME(I),IDPDG(I),IFLAV(I),ICHRG(I),RMASS(I),RLTIM(I),
+ & RSPIN(I),I=65,80)/
+ & ' ', 0, 0, 0,0.0000,0.000D+00,0.0,
+ & ' ', 0, 0, 0,0.0000,0.000D+00,0.0,
+ & ' ', 0, 0, 0,0.0000,0.000D+00,0.0,
+ & ' ', 0, 0, 0,0.0000,0.000D+00,0.0,
+ & ' ', 0, 0, 0,0.0000,0.000D+00,0.0,
+ & ' ', 0, 0, 0,0.0000,0.000D+00,0.0,
+ & 'REMG ', 98, 0, 0,0.0000,0.000D+00,0.0,
+ & 'REMN ', 99, 0, 0,0.0000,0.000D+00,0.0,
+ & 'P ', 2212, 122,+1,.93827,1.000D+30,0.5,
+ & 'DELTA+ ', 2214, 122,+1,1.2320,0.000D+00,1.5,
+ & 'N ', 2112, 112, 0,.93957,8.870D+02,0.5,
+ & 'DELTA0 ', 2114, 112, 0,1.2320,0.000D+00,1.5,
+ & 'DELTA- ', 1114, 111,-1,1.2320,0.000D+00,1.5,
+ & 'LAMBDA ', 3122, 123, 0,1.1157,2.632D-10,0.5,
+ & 'SIGMA0 ', 3212, 123, 0,1.1926,7.400D-20,0.5,
+ & 'SIGMA*0 ', 3214, 123, 0,1.3837,0.000D+00,1.5/
+ DATA (RNAME(I),IDPDG(I),IFLAV(I),ICHRG(I),RMASS(I),RLTIM(I),
+ & RSPIN(I),I=81,96)/
+ & 'SIGMA- ', 3112, 113,-1,1.1974,1.479D-10,0.5,
+ & 'SIGMA*- ', 3114, 113,-1,1.3872,0.000D+00,1.5,
+ & 'XI- ', 3312, 133,-1,1.3213,1.639D-10,0.5,
+ & 'XI*- ', 3314, 133,-1,1.5350,0.000D+00,1.5,
+ & 'DELTA++ ', 2224, 222,+2,1.2320,0.000D+00,1.5,
+ & 'SIGMA+ ', 3222, 223,+1,1.1894,7.990D-11,0.5,
+ & 'SIGMA*+ ', 3224, 223,+1,1.3828,0.000D+00,1.5,
+ & 'XI0 ', 3322, 233, 0,1.3149,2.900D-10,0.5,
+ & 'XI*0 ', 3324, 233, 0,1.5318,0.000D+00,1.5,
+ & 'OMEGA- ', 3334, 333,-1,1.6725,8.220D-11,1.5,
+ & 'PBAR ', -2212,-122,-1,.93827,1.000D+30,0.5,
+ & 'DELTABR-', -2214,-122,-1,1.2320,0.000D+00,1.5,
+ & 'NBAR ', -2112,-112, 0,.93957,8.870D+02,0.5,
+ & 'DELTABR0', -2114,-112, 0,1.2320,0.000D+00,1.5,
+ & 'DELTABR+', -1114,-111,+1,1.2320,0.000D+00,1.5,
+ & 'LAMBDABR', -3122,-123, 0,1.1157,2.632D-10,0.5/
+ DATA (RNAME(I),IDPDG(I),IFLAV(I),ICHRG(I),RMASS(I),RLTIM(I),
+ & RSPIN(I),I=97,112)/
+ & 'SIGMABR0', -3212,-123, 0,1.1926,7.400D-20,0.5,
+ & 'SGMA*BR0', -3214,-123, 0,1.3837,0.000D+00,1.5,
+ & 'SIGMABR+', -3112,-113,+1,1.1974,1.479D-10,0.5,
+ & 'SGMA*BR+', -3114,-113,+1,1.3872,0.000D+00,1.5,
+ & 'XIBAR+ ', -3312,-133,+1,1.3213,1.639D-10,0.5,
+ & 'XI*BAR+ ', -3314,-133,+1,1.5350,0.000D+00,1.5,
+ & 'DLTABR--', -2224,-222,-2,1.2320,0.000D+00,1.5,
+ & 'SIGMABR-', -3222,-223,-1,1.1894,7.990D-11,0.5,
+ & 'SGMA*BR-', -3224,-223,-1,1.3828,0.000D+00,1.5,
+ & 'XIBAR0 ', -3322,-233, 0,1.3149,2.900D-10,0.5,
+ & 'XI*BAR ', -3324,-233, 0,1.5318,0.000D+00,1.5,
+ & 'OMEGABR+', -3334,-333,+1,1.6725,8.220D-11,1.5,
+ & 'UU ', 2203, 0,+4,0.6400,0.000D+00,0.0,
+ & 'UD ', 2101, 0,+1,0.6400,0.000D+00,0.0,
+ & 'DD ', 1103, 0,-2,0.6400,0.000D+00,0.0,
+ & 'US ', 3201, 0,+1,0.8200,0.000D+00,0.0/
+ DATA (RNAME(I),IDPDG(I),IFLAV(I),ICHRG(I),RMASS(I),RLTIM(I),
+ & RSPIN(I),I=113,128)/
+ & 'DS ', 3101, 0,-2,0.8200,0.000D+00,0.0,
+ & 'SS ', 3303, 0,-2,1.0000,0.000D+00,0.0,
+ & 'UBARUBAR', -2203, 0,-4,0.6400,0.000D+00,0.0,
+ & 'UBARDBAR', -2101, 0,-1,0.6400,0.000D+00,0.0,
+ & 'DBARDBAR', -1103, 0,+2,0.6400,0.000D+00,0.0,
+ & 'UBARSBAR', -3201, 0,-1,0.8200,0.000D+00,0.0,
+ & 'DBARSBAR', -3101, 0,+2,0.8200,0.000D+00,0.0,
+ & 'SBARSBAR', -3303, 0,+2,1.0000,0.000D+00,0.0,
+ & 'E- ', 11, 0,-1,5.11D-4,1.00D+30,0.5,
+ & 'NU_E ', 12, 0, 0,0.0000,1.000D+30,0.5,
+ & 'MU- ', 13, 0,-1,.10566,2.197D-06,0.5,
+ & 'NU_MU ', 14, 0, 0,0.0000,1.000D+30,0.5,
+ & 'TAU- ', 15, 0,-1,1.7771,2.916D-13,0.5,
+ & 'NU_TAU ', 16, 0, 0,0.0000,1.000D+30,0.5,
+ & 'E+ ', -11, 0,+1,5.11D-4,1.00D+30,0.5,
+ & 'NU_EBAR ', -12, 0, 0,0.0000,1.000D+30,0.5/
+ DATA (RNAME(I),IDPDG(I),IFLAV(I),ICHRG(I),RMASS(I),RLTIM(I),
+ & RSPIN(I),I=129,144)/
+ & 'MU+ ', -13, 0,+1,.10566,2.197D-06,0.5,
+ & 'NU_MUBAR', -14, 0, 0,0.0000,1.000D+30,0.5,
+ & 'TAU+ ', -15, 0,+1,1.7771,2.916D-13,0.5,
+ & 'NU_TAUBR', -16, 0, 0,0.0000,1.000D+30,0.5,
+ & ' ', 0, 0, 0,0.0000,0.000D+00,0.0,
+ & ' ', 0, 0, 0,0.0000,0.000D+00,0.0,
+ & ' ', 0, 0, 0,0.0000,0.000D+00,0.0,
+ & 'D+ ', 411, 41,+1,1.8693,1.057D-12,0.0,
+ & 'D*+ ', 413, 41,+1,2.0100,0.000D+00,1.0,
+ & 'DH_1+ ', 20413, 41,+1,2.4270,0.000D+00,1.0,
+ & 'D*_2+ ', 415, 41,+1,2.4590,0.000D+00,2.0,
+ & 'D0 ', 421, 42, 0,1.8646,4.150D-13,0.0,
+ & 'D*0 ', 423, 42, 0,2.0067,0.000D+00,1.0,
+ & 'DH_10 ', 20423, 42, 0,2.4222,0.000D+00,1.0,
+ & 'D*_20 ', 425, 42, 0,2.4589,0.000D+00,2.0,
+ & 'D_S+ ', 431, 43,+1,1.9685,4.670D-13,0.0/
+ DATA (RNAME(I),IDPDG(I),IFLAV(I),ICHRG(I),RMASS(I),RLTIM(I),
+ & RSPIN(I),I=145,160)/
+ & 'D*_S+ ', 433, 43,+1,2.1124,0.000D+00,1.0,
+ & 'DH_S1+ ', 20433, 43,+1,2.5354,0.000D+00,1.0,
+ & 'D*_S2+ ', 435, 43,+1,2.5735,0.000D+00,2.0,
+ & 'SGMA_C++', 4222, 224,+2,2.4528,0.000D+00,0.5,
+ & 'SGM*_C++', 4224, 224,+2,2.5194,0.000D+00,1.5,
+ & 'LMBDA_C+', 4122, 124,+1,2.2849,2.060D-13,0.5,
+ & 'SIGMA_C+', 4212, 124,+1,2.4536,0.000D+00,0.5,
+ & 'SGMA*_C+', 4214, 124,+1,2.5185,0.000D+00,1.5,
+ & 'SIGMA_C0', 4112, 114, 0,2.4522,0.000D+00,0.5,
+ & 'SGMA*_C0', 4114, 114, 0,2.5175,0.000D+00,1.5,
+ & 'XI_C+ ', 4232, 234,+1,2.4656,3.500D-13,0.5,
+ & 'XIP_C+ ', 4322, 234,+1,2.5750,0.000D+00,0.5,
+ & 'XI*_C+ ', 4324, 234,+1,2.6446,0.000D+00,1.5,
+ & 'XI_C0 ', 4132, 134, 0,2.4703,9.800D-14,0.5,
+ & 'XIP_C0 ', 4312, 134, 0,2.5800,0.000D+00,0.5,
+ & 'XI*_C0 ', 4314, 134, 0,2.6438,0.000D+00,1.5/
+ DATA (RNAME(I),IDPDG(I),IFLAV(I),ICHRG(I),RMASS(I),RLTIM(I),
+ & RSPIN(I),I=161,176)/
+ & 'OMEGA_C0', 4332, 334, 0,2.7040,6.400D-14,0.5,
+ & 'OMGA*_C0', 4334, 334, 0,2.7300,0.000D+00,1.5,
+ & 'ETA_C ', 441, 44, 0,2.9798,0.000D+00,0.0,
+ & 'JPSI ', 443, 44, 0,3.0969,0.000D+00,1.0,
+ & 'CHI_C1 ', 10441, 44, 0,3.4173,0.000D+00,0.0,
+ & 'PSI2S ', 100443, 44, 0,3.6860,0.000D+00,1.0,
+ & 'PSID ', 30443, 44, 0,3.7699,0.000D+00,1.0,
+ & ' ', 0, 0, 0,0.0000,0.000D+00,0.0,
+ & ' ', 0, 0, 0,0.0000,0.000D+00,0.0,
+ & ' ', 0, 0, 0,0.0000,0.000D+00,0.0,
+ & 'D- ', -411, 14,-1,1.8693,1.057D-12,0.0,
+ & 'D*- ', -413, 14,-1,2.0100,0.000D+00,1.0,
+ & 'DH_1- ', -20413, 14,-1,2.4270,0.000D+00,1.0,
+ & 'D*_2- ', -415, 14,-1,2.4590,0.000D+00,2.0,
+ & 'DBAR0 ', -421, 24, 0,1.8646,4.140D-13,0.0,
+ & 'D*BAR0 ', -423, 24, 0,2.0067,0.000D+00,1.0/
+ DATA (RNAME(I),IDPDG(I),IFLAV(I),ICHRG(I),RMASS(I),RLTIM(I),
+ & RSPIN(I),I=177,192)/
+ & 'DH_1BAR0', -20423, 24, 0,2.4222,0.000D+00,1.0,
+ & 'D*_2BAR0', -425, 24, 0,2.4589,0.000D+00,2.0,
+ & 'D_S- ', -431, 34,-1,1.9685,4.670D-13,0.0,
+ & 'D*_S- ', -433, 34,-1,2.1124,0.000D+00,1.0,
+ & 'DH_S1- ', -20433, 34,-1,2.5354,0.000D+00,1.0,
+ & 'D*_S2- ', -435, 34,-1,2.5735,0.000D+00,2.0,
+ & 'SGMA_C--', -4222,-224,-2,2.4528,0.000D+00,0.5,
+ & 'SGM*_C--', -4224,-224,-2,2.5194,0.000D+00,1.5,
+ & 'LMBDA_C-', -4122,-124,-1,2.2849,2.060D-13,0.5,
+ & 'SIGMA_C-', -4212,-124,-1,2.4536,0.000D+00,0.5,
+ & 'SGMA*_C-', -4214,-124,-1,2.5185,0.000D+00,1.5,
+ & 'SGM_CBR0', -4112,-114, 0,2.4522,0.000D+00,0.5,
+ & 'SG*_CBR0', -4114,-114, 0,2.5175,0.000D+00,1.5,
+ & 'XI_C- ', -4232,-234,-1,2.4656,3.500D-13,0.5,
+ & 'XIP_C- ', -4322,-234,-1,2.5750,0.000D+00,0.5,
+ & 'XI*_C- ', -4324,-234,-1,2.6446,0.000D+00,1.5/
+ DATA (RNAME(I),IDPDG(I),IFLAV(I),ICHRG(I),RMASS(I),RLTIM(I),
+ & RSPIN(I),I=193,208)/
+ & 'XI_CBAR0', -4132,-134, 0,2.4703,9.800D-14,0.5,
+ & 'XIP_CBR0', -4312,-134, 0,2.5800,0.000D+00,0.5,
+ & 'XI*_CBR0', -4314,-134, 0,2.6438,0.000D+00,1.5,
+ & 'OMG_CBR0', -4332,-334, 0,2.7040,6.400D-14,0.5,
+ & 'OM*_CBR0', -4334,-334, 0,2.7300,0.000D+00,1.5,
+ & 'W+ ', 24, 0,+1,80.360,0.000D+00,1.0,
+ & 'W- ', -24, 0,-1,80.360,0.000D+00,1.0,
+ & 'Z0/GAMA*', 23, 0, 0,91.187,0.000D+00,1.0,
+ & 'HIGGS ', 25, 0, 0,150.00,0.000D+00,0.0,
+ & 'Z0P ', 32, 0, 0,500.00,0.000D+00,1.0,
+ & 'HIGGSL0 ', 26, 0, 0,0.0000,1.000D+30,0.0,
+ & 'HIGGSH0 ', 35, 0, 0,0.0000,1.000D+30,0.0,
+ & 'HIGGSA0 ', 36, 0, 0,0.0000,1.000D+30,0.0,
+ & 'HIGGS+ ', 37, 0,+1,0.0000,1.000D+30,0.0,
+ & 'HIGGS- ', -37, 0,-1,0.0000,1.000D+30,0.0,
+ & ' ', 0, 0, 0,0.0 ,0.0D+00 ,0.0/
+ DATA (RNAME(I),IDPDG(I),IFLAV(I),ICHRG(I),RMASS(I),RLTIM(I),
+ & RSPIN(I),I=209,224)/
+ & 'VQRK ', 7, 0,-1,200.00,0.000D+00,0.5,
+ & 'AQRK ', 8, 0,+2,400.00,0.000D+00,0.5,
+ & 'HQRK ', 7, 0,-1,400.00,0.000D+00,0.5,
+ & 'HPQK ', 8, 0,+2,600.00,0.000D+00,0.5,
+ & ' ', 0, 0, 0,0.0000,0.000D+00,0.0,
+ & ' ', 0, 0, 0,0.0000,0.000D+00,0.0,
+ & 'VBAR ', -7, 0,+1,200.00,0.000D+00,0.5,
+ & 'ABAR ', -8, 0,-2,400.00,0.000D+00,0.5,
+ & 'HBAR ', -7, 0,+1,400.00,0.000D+00,0.5,
+ & 'HPBR ', -8, 0,-2,600.00,0.000D+00,0.5,
+ & ' ', 0, 0, 0,0.0000,0.000D+00,0.0,
+ & ' ', 0, 0, 0,0.0000,0.000D+00,0.0,
+ & 'B_DBAR0 ', -511, 51, 0,5.2792,1.614D-12,0.0,
+ & 'B- ', -521, 52,-1,5.2789,1.652D-12,0.0,
+ & 'B_SBAR0 ', -531, 53, 0,5.3693,1.540D-12,0.0,
+ & 'SIGMA_B+', 5222, 225,+1,5.8200,1.070D-12,0.5/
+ DATA (RNAME(I),IDPDG(I),IFLAV(I),ICHRG(I),RMASS(I),RLTIM(I),
+ & RSPIN(I),I=225,240)/
+ & 'LMBDA_B0', 5122, 125, 0,5.6240,1.070D-12,0.5,
+ & 'SIGMA_B-', 5112, 115,-1,5.8200,1.070D-12,0.5,
+ & 'XI_B0 ', 5232, 235, 0,5.8000,1.070D-12,0.5,
+ & 'XI_B- ', 5132, 135,-1,5.8000,1.070D-12,0.5,
+ & 'OMEGA_B-', 5332, 335,-1,6.0400,1.070D-12,0.5,
+ & 'B_C- ', -541, 54,-1,6.2500,1.000D-12,0.5,
+ & 'UPSLON1S', 553, 55, 0,9.4604,0.000D+00,1.0,
+ & 'T_B- ', -651, 56,-1,0.0000,0.000D+00,0.0,
+ & 'T+ ', 611, 61,+1,0.0000,0.000D+00,0.0,
+ & 'T0 ', 621, 62, 0,0.0000,0.000D+00,0.0,
+ & 'T_S+ ', 631, 63,+1,0.0000,0.000D+00,0.0,
+ & 'SGMA_T++', 6222, 226,+2,0.0000,0.000D+00,0.5,
+ & 'LMBDA_T0', 6122, 126,+1,0.0000,0.000D+00,0.5,
+ & 'SIGMA_T0', 6112, 116, 0,0.0000,0.000D+00,0.5,
+ & 'XI_T+ ', 6232, 236,+1,0.0000,0.000D+00,0.5,
+ & 'XI_T0 ', 6132, 136, 0,0.0000,0.000D+00,0.5/
+ DATA (RNAME(I),IDPDG(I),IFLAV(I),ICHRG(I),RMASS(I),RLTIM(I),
+ & RSPIN(I),I=241,256)/
+ & 'OMEGA_T0', 6332, 336, 0,0.0000,0.000D+00,0.5,
+ & 'T_C0 ', 641, 64, 0,0.0000,0.000D+00,0.0,
+ & 'T_B+ ', 651, 65,+1,0.0000,0.000D+00,0.0,
+ & 'TOPONIUM', 663, 66, 0,0.0000,0.000D+00,1.0,
+ & 'B_D0 ', 511, 15, 0,5.2792,1.614D-12,0.0,
+ & 'B+ ', 521, 25,+1,5.2789,1.652D-12,0.0,
+ & 'B_S0 ', 531, 35, 0,5.3693,1.540D-12,0.0,
+ & 'SGM_BBR-', -5222,-225,-1,5.8200,1.070D-12,0.5,
+ & 'LMD_BBR0', -5122,-125, 0,5.6240,1.070D-12,0.5,
+ & 'SGM_BBR+', -5112,-115,+1,5.8200,1.070D-12,0.5,
+ & 'XI_BBAR0', -5232,-235, 0,5.8000,1.070D-12,0.5,
+ & 'XI_B+ ', -5132,-135,+1,5.8000,1.070D-12,0.5,
+ & 'OMG_BBR+', -5332,-335,+1,6.0400,1.070D-12,0.5,
+ & 'B_C+ ', 541, 45,+1,6.2500,1.000D-12,0.5,
+ & 'T- ', -611, 16,-1,0.0000,0.000D+00,0.0,
+ & 'TBAR0 ', -621, 26, 0,0.0000,0.000D+00,0.0/
+ DATA (RNAME(I),IDPDG(I),IFLAV(I),ICHRG(I),RMASS(I),RLTIM(I),
+ & RSPIN(I),I=257,272)/
+ & 'T_S- ', -631, 36,-1,0.0000,0.000D+00,0.0,
+ & 'SGMA_T--', -6222,-226,-2,0.0000,0.000D+00,0.5,
+ & 'LAMDA_T-', -6122,-126,-1,0.0000,0.000D+00,0.5,
+ & 'SGM_TBR0', -6112,-116, 0,0.0000,0.000D+00,0.5,
+ & 'XI_T- ', -6232,-236,-1,0.0000,0.000D+00,0.5,
+ & 'XI_TBAR0', -6132,-136, 0,0.0000,0.000D+00,0.5,
+ & 'OMG_TBR0', -6332,-336, 0,0.0000,0.000D+00,0.5,
+ & 'T_CBAR0 ', -641, 46, 0,0.0000,0.000D+00,0.0,
+ & 'B*BAR0 ', -513, 51, 0,5.3249,0.000D+00,1.0,
+ & 'B*- ', -523, 52,-1,5.3249,0.000D+00,1.0,
+ & 'B*_SBAR0', -533, 53, 0,5.4163,0.000D+00,1.0,
+ & 'BH_1BAR0', -20513, 51, 0,5.7600,0.000D+00,1.0,
+ & 'BH_1- ', -20523, 52,-1,5.7600,0.000D+00,1.0,
+ & 'BH_S1BR0', -20533, 53, 0,5.8550,0.000D+00,1.0,
+ & 'B*_2BAR0', -515, 51, 0,5.7700,0.000D+00,2.0,
+ & 'B*_2- ', -525, 52,-1,5.7700,0.000D+00,2.0/
+ DATA (RNAME(I),IDPDG(I),IFLAV(I),ICHRG(I),RMASS(I),RLTIM(I),
+ & RSPIN(I),I=273,288)/
+ & 'B*_S2BR0', -535, 53, 0,5.8650,0.000D+00,2.0,
+ & 'B*0 ', 513, 15, 0,5.3249,0.000D+00,1.0,
+ & 'B*+ ', 523, 25,+1,5.3249,0.000D+00,1.0,
+ & 'B*_S0 ', 533, 35, 0,5.4163,0.000D+00,1.0,
+ & 'BH_10 ', 20513, 15, 0,5.7600,0.000D+00,1.0,
+ & 'BH_1+ ', 20523, 25,+1,5.7600,0.000D+00,1.0,
+ & 'BH_S10 ', 20533, 35, 0,5.8550,0.000D+00,1.0,
+ & 'B*_20 ', 515, 15, 0,5.7700,0.000D+00,2.0,
+ & 'B*_2+ ', 525, 25,+1,5.7700,0.000D+00,2.0,
+ & 'B*_S20 ', 535, 35, 0,5.8650,0.000D+00,2.0,
+ & ' ', 0, 0, 0,0.0000,0.000D+00, 0,
+ & ' ', 0, 0, 0,0.0000,0.000D+00, 0,
+ & 'B_10 ', 10113, 11, 0,1.2295,0.000D+00,1.0,
+ & 'B_1+ ', 10213, 21,+1,1.2295,0.000D+00,1.0,
+ & 'B_1- ', -10213, 12,-1,1.2295,0.000D+00,1.0,
+ & 'HL_10 ', 10223, 33, 0,1.1700,0.000D+00,1.0/
+ DATA (RNAME(I),IDPDG(I),IFLAV(I),ICHRG(I),RMASS(I),RLTIM(I),
+ & RSPIN(I),I=289,304)/
+ & 'HH_10 ', 10333, 33, 0,1.3950,0.000D+00,1.0,
+ & 'A_00 ', 9000111, 11, 0,.99600,0.000D+00,0.0,
+ & 'A_0+ ', 9000211, 21,+1,.99600,0.000D+00,0.0,
+ & 'A_0- ',-9000211, 12,-1,.99600,0.000D+00,0.0,
+ & 'F0P0 ', 9010221, 33, 0,.99600,0.000D+00,0.0,
+ & 'FH_00 ', 10221, 33, 0,1.3500,0.000D+00,0.0,
+ & 'B*_C+ ', 543, 45,+1,6.2950,0.000D+00,1.0,
+ & 'B*_C- ', -543, 54,-1,6.2950,0.000D+00,1.0,
+ & 'BH_C1+ ', 20543, 45,+1,6.7300,0.000D+00,1.0,
+ & 'BH_C1- ', -20543, 54,-1,6.7300,0.000D+00,1.0,
+ & 'B*_C2+ ', 545, 45,+1,6.7400,0.000D+00,2.0,
+ & 'B*_C2- ', -545, 54,-1,6.7400,0.000D+00,2.0,
+ & 'H_C ', 10443, 44, 0,3.5261,0.000D+00,1.0,
+ & 'CHI_C0 ', 20443, 44, 0,3.5105,0.000D+00,0.0,
+ & 'CHI_C2 ', 445, 44, 0,3.5562,0.000D+00,2.0,
+ & 'ETA_B ', 551, 55, 0,9.0000,0.000D+00,0.0/
+ DATA (RNAME(I),IDPDG(I),IFLAV(I),ICHRG(I),RMASS(I),RLTIM(I),
+ & RSPIN(I),I=305,320)/
+ & 'H_B ', 10553, 55, 0,9.8880,0.000D+00,1.0,
+ & 'CHI_B0 ', 10551, 55, 0,9.8598,0.000D+00,0.0,
+ & 'CHI_B1 ', 20553, 55, 0,9.8919,0.000D+00,1.0,
+ & 'CHI_B2 ', 555, 55, 0,9.9132,0.000D+00,2.0,
+ & 'KL_10 ', 10313, 13, 0,1.5700,0.000D+00,1.0,
+ & 'KL_1+ ', 10323, 23,+1,1.5700,0.000D+00,1.0,
+ & 'KL_1BAR0', -10313, 31, 0,1.5700,0.000D+00,1.0,
+ & 'KL_1- ', -10323, 32,-1,1.5700,0.000D+00,1.0,
+ & 'DL_1+ ', 10413, 41,+1,2.4270,0.000D+00,1.0,
+ & 'DL_10 ', 10423, 42, 0,2.4222,0.000D+00,1.0,
+ & 'DL_S1+ ', 10433, 43,+1,2.5354,0.000D+00,1.0,
+ & 'DL_1- ', -10413, 14,-1,2.4270,0.000D+00,1.0,
+ & 'DL_1BAR0', -10423, 24, 0,2.4222,0.000D+00,1.0,
+ & 'DL_S1- ', -10433, 34,-1,2.5354,0.000D+00,1.0,
+ & 'BL_10 ', 10513, 15, 0,5.7600,0.000D+00,1.0,
+ & 'BL_1+ ', 10523, 25,+1,5.7600,0.000D+00,1.0/
+ DATA (RNAME(I),IDPDG(I),IFLAV(I),ICHRG(I),RMASS(I),RLTIM(I),
+ & RSPIN(I),I=321,336)/
+ & 'BL_S10 ', 10533, 35, 0,5.8530,0.000D+00,1.0,
+ & 'BL_C1+ ', 10543, 45,+1,6.7300,0.000D+00,1.0,
+ & 'BL_1BAR0', -10513, 51, 0,5.7600,0.000D+00,1.0,
+ & 'BL_1- ', -10523, 52,-1,5.7600,0.000D+00,1.0,
+ & 'BL_S1BR0', -10533, 53, 0,5.8530,0.000D+00,1.0,
+ & 'BL_C1- ', -10543, 54,-1,6.7300,0.000D+00,1.0,
+ & 'K*_0+ ', 10321, 23,+1,1.4290,0.000D+00,0.0,
+ & 'K*_00 ', 10311, 13, 0,1.4290,0.000D+00,0.0,
+ & 'K*_0BAR0', -10311, 31, 0,1.4290,0.000D+00,0.0,
+ & 'K*_0- ', -10321, 32,-1,1.4290,0.000D+00,0.0,
+ & 'D*_0+ ', 10411, 41,+1,2.4230,0.000D+00,0.0,
+ & 'D*_00 ', 10421, 42, 0,2.4230,0.000D+00,0.0,
+ & 'D*_S0+ ', 10431, 43,+1,2.5250,0.000D+00,0.0,
+ & 'D*_0- ', -10411, 14,-1,2.4230,0.000D+00,0.0,
+ & 'D*_0BAR0', -10421, 24, 0,2.4230,0.000D+00,0.0,
+ & 'D*_S0- ', -10431, 34,-1,2.5250,0.000D+00,0.0/
+ DATA (RNAME(I),IDPDG(I),IFLAV(I),ICHRG(I),RMASS(I),RLTIM(I),
+ & RSPIN(I),I=337,352)/
+ & 'B*_00 ', 10511, 15, 0,5.7600,0.000D+00,0.0,
+ & 'B*_0+ ', 10521, 25,+1,5.7600,0.000D+00,0.0,
+ & 'B*_S00 ', 10531, 35, 0,5.8550,0.000D+00,0.0,
+ & 'B*_C0+ ', 10541, 45,+1,6.7300,0.000D+00,0.0,
+ & 'B*_0BAR0', -10511, 51, 0,5.7600,0.000D+00,0.0,
+ & 'B*_0- ', -10521, 52,-1,5.7600,0.000D+00,0.0,
+ & 'B*_S0BR0', -10531, 53, 0,5.8550,0.000D+00,0.0,
+ & 'B*_C0- ', -10541, 54,-1,6.7300,0.000D+00,0.0,
+ & 'SGMA*_B-', 5114, 115,-1,5.8400,0.000D+00,1.5,
+ & 'SIGMA_B0', 5212, 125, 0,5.8200,0.000D+00,0.5,
+ & 'SGMA*_B0', 5214, 125, 0,5.8400,0.000D+00,1.5,
+ & 'SGMA*_B+', 5224, 225,+1,5.8400,0.000D+00,1.5,
+ & 'XIP_B0 ', 5322, 235, 0,5.9450,0.000D+00,0.5,
+ & 'XI*_B0 ', 5324, 235, 0,5.9450,0.000D+00,1.5,
+ & 'XIP_B- ', 5312, 135,-1,5.9450,0.000D+00,0.5,
+ & 'XI*_B- ', 5314, 135,-1,5.9450,0.000D+00,1.5/
+ DATA (RNAME(I),IDPDG(I),IFLAV(I),ICHRG(I),RMASS(I),RLTIM(I),
+ & RSPIN(I),I=353,368)/
+ & '0MGA*_B-', 5334, 335,-1,6.0600,0.000D+00,1.5,
+ & 'SG*_BBR+', -5114,-115,+1,5.8400,0.000D+00,1.5,
+ & 'SGM_BBR0', -5212,-125, 0,5.8200,0.000D+00,0.5,
+ & 'SG*_BBR0', -5214,-125, 0,5.8400,0.000D+00,1.5,
+ & 'SG*_BBR-', -5224,-225,-1,5.8400,0.000D+00,1.5,
+ & 'XIP_BBR0', -5322,-235, 0,5.9450,0.000D+00,0.5,
+ & 'XI*_BBR0', -5324,-235, 0,5.9450,0.000D+00,1.5,
+ & 'XIP_B+ ', -5312,-135,+1,5.9450,0.000D+00,0.5,
+ & 'XI*_B+ ', -5314,-135,+1,5.9450,0.000D+00,1.5,
+ & '0MGA*_B+', -5334,-335,+1,6.0600,0.000D+00,1.5,
+ & 'KDL_2+ ', 10325, 23,+1,1.7730,0.000D+00,2.0,
+ & 'KDL_20 ', 10315, 13, 0,1.7730,0.000D+00,2.0,
+ & 'KDL_2BR0', -10315, 31, 0,1.7730,0.000D+00,2.0,
+ & 'KDL_2- ', -10325, 32,-1,1.7730,0.000D+00,2.0,
+ & 'KD*+ ', 30323, 23,+1,1.717,0.000D+00,1.0,
+ & 'KD*0 ', 30313, 13, 0,1.717,0.000D+00,1.0/
+ DATA (RNAME(I),IDPDG(I),IFLAV(I),ICHRG(I),RMASS(I),RLTIM(I),
+ & RSPIN(I),I=369,384)/
+ & 'KD*BAR0 ', -30313, 31, 0,1.717,0.000D+00,1.0,
+ & 'KD*- ', -30323, 32,-1,1.717,0.000D+00,1.0,
+ & 'KDH_2+ ', 20325, 23,+1,1.8160,0.000D+00,2.0,
+ & 'KDH_20 ', 20315, 13, 0,1.8160,0.000D+00,2.0,
+ & 'KDH_2BR0', -20315, 31, 0,1.8160,0.000D+00,2.0,
+ & 'KDH_2- ', -20325, 32,-1,1.8160,0.000D+00,2.0,
+ & 'KD_3+ ', 327, 23,+1,1.7730,0.000D+00,3.0,
+ & 'KD_30 ', 317, 13, 0,1.7730,0.000D+00,3.0,
+ & 'KD_3BAR0', -317, 31, 0,1.7730,0.000D+00,3.0,
+ & 'KD_3- ', -327, 32,-1,1.7730,0.000D+00,3.0,
+ & 'PI_2+ ', 10215, 21,+1,1.6700,0.000D+00,2.0,
+ & 'PI_20 ', 10115, 11, 0,1.6700,0.000D+00,2.0,
+ & 'PI_2- ', -10215, 12,-1,1.6700,0.000D+00,2.0,
+ & 'RHOD+ ', 30213, 21,+1,1.7000,0.000D+00,1.0,
+ & 'RHOD0 ', 30113, 11, 0,1.7000,0.000D+00,1.0,
+ & 'RHOD- ', -30213, 12,-1,1.7000,0.000D+00,1.0/
+ DATA (RNAME(I),IDPDG(I),IFLAV(I),ICHRG(I),RMASS(I),RLTIM(I),
+ & RSPIN(I),I=385,400)/
+ & 'RHO_3+ ', 217, 21,+1,1.6910,0.000D+00,3.0,
+ & 'RHO_30 ', 117, 11, 0,1.6910,0.000D+00,3.0,
+ & 'RHO_3- ', -217, 12,-1,1.6910,0.000D+00,3.0,
+ & 'UPSLON2S', 100553, 55, 0,10.023,0.000D+00,1.0,
+ & 'CHI2P_B0', 110551, 55, 0,10.232,0.000D+00,0.0,
+ & 'CHI2P_B1', 120553, 55, 0,10.255,0.000D+00,1.0,
+ & 'CHI2P_B2', 100555, 55, 0,10.269,0.000D+00,2.0,
+ & 'UPSLON3S', 200553, 55, 0,10.355,0.000D+00,1.0,
+ & 'UPSLON4S', 300553, 55, 0,10.580,0.000D+00,1.0,
+ & ' ', 0, 0, 0,0.0 , 0.0D+00, 0,
+ & 'OMEGA_3 ', 227, 33, 0,1.6670,0.000D+00,3.0,
+ & 'PHI_3 ', 337, 33, 0,1.8540,0.000D+00,3.0,
+ & 'ETA_2(L)', 10225, 33, 0,1.6320,0.000D+00,2.0,
+ & 'ETA_2(H)', 10335, 33, 0,1.8540,0.000D+00,2.0,
+ & 'OMEGA(H)', 30223, 33, 0,1.6490,0.000D+00,1.0,
+ & ' ', 0, 0, 0,0.0 ,0.0D+00 , 0/
+ DATA (RNAME(I),IDPDG(I),IFLAV(I),ICHRG(I),RMASS(I),RLTIM(I),
+ & RSPIN(I),I=401,416)/
+ & 'SSDL ', 1000001, 0,-1,0.00D0,1.000D+30,0.0,
+ & 'SSUL ', 1000002, 0,+2,0.00D0,1.000D+30,0.0,
+ & 'SSSL ', 1000003, 0,-1,0.00D0,1.000D+30,0.0,
+ & 'SSCL ', 1000004, 0,+2,0.00D0,1.000D+30,0.0,
+ & 'SSB1 ', 1000005, 0,-1,0.00D0,1.000D+30,0.0,
+ & 'SST1 ', 1000006, 0,+2,0.00D0,1.000D+30,0.0,
+ & 'SSDLBR ',-1000001, 0,+1,0.00D0,1.000D+30,0.0,
+ & 'SSULBR ',-1000002, 0,-2,0.00D0,1.000D+30,0.0,
+ & 'SSSLBR ',-1000003, 0,+1,0.00D0,1.000D+30,0.0,
+ & 'SSCLBR ',-1000004, 0,-2,0.00D0,1.000D+30,0.0,
+ & 'SSB1BR ',-1000005, 0,+1,0.00D0,1.000D+30,0.0,
+ & 'SST1BR ',-1000006, 0,-2,0.00D0,1.000D+30,0.0,
+ & 'SSDR ', 2000001, 0,-1,0.00D0,1.000D+30,0.0,
+ & 'SSUR ', 2000002, 0,+2,0.00D0,1.000D+30,0.0,
+ & 'SSSR ', 2000003, 0,-1,0.00D0,1.000D+30,0.0,
+ & 'SSCR ', 2000004, 0,+2,0.00D0,1.000D+30,0.0/
+ DATA (RNAME(I),IDPDG(I),IFLAV(I),ICHRG(I),RMASS(I),RLTIM(I),
+ & RSPIN(I),I=417,432)/
+ & 'SSB2 ', 2000005, 0,-1,0.00D0,1.000D+30,0.0,
+ & 'SST2 ', 2000006, 0,+2,0.00D0,1.000D+30,0.0,
+ & 'SSDRBR ',-2000001, 0,+1,0.00D0,1.000D+30,0.0,
+ & 'SSURBR ',-2000002, 0,-2,0.00D0,1.000D+30,0.0,
+ & 'SSSRBR ',-2000003, 0,+1,0.00D0,1.000D+30,0.0,
+ & 'SSCRBR ',-2000004, 0,-2,0.00D0,1.000D+30,0.0,
+ & 'SSB2BR ',-2000005, 0,+1,0.00D0,1.000D+30,0.0,
+ & 'SST2BR ',-2000006, 0,-2,0.00D0,1.000D+30,0.0,
+ & 'SSEL- ', 1000011, 0,-1,0.00D0,1.000D+30,0.0,
+ & 'SSNUEL ', 1000012, 0, 0,0.00D0,1.000D+30,0.0,
+ & 'SSMUL- ', 1000013, 0,-1,0.00D0,1.000D+30,0.0,
+ & 'SSNUMUL ', 1000014, 0, 0,0.00D0,1.000D+30,0.0,
+ & 'SSTAU1- ', 1000015, 0,-1,0.00D0,1.000D+30,0.0,
+ & 'SSNUTL ', 1000016, 0, 0,0.00D0,1.000D+30,0.0,
+ & 'SSEL+ ',-1000011, 0,+1,0.00D0,1.000D+30,0.0,
+ & 'SSNUELBR',-1000012, 0, 0,0.00D0,1.000D+30,0.0/
+ DATA (RNAME(I),IDPDG(I),IFLAV(I),ICHRG(I),RMASS(I),RLTIM(I),
+ & RSPIN(I),I=433,448)/
+ & 'SSMUL+ ',-1000013, 0,+1,0.00D0,1.000D+30,0.0,
+ & 'SSNUMLBR',-1000014, 0, 0,0.00D0,1.000D+30,0.0,
+ & 'SSTAU1+ ',-1000015, 0,+1,0.00D0,1.000D+30,0.0,
+ & 'SSNUTLBR',-1000016, 0, 0,0.00D0,1.000D+30,0.0,
+ & 'SSER- ', 2000011, 0,-1,0.00D0,1.000D+30,0.0,
+ & 'SSNUER ', 2000012, 0, 0,0.00D0,1.000D+30,0.0,
+ & 'SSMUR- ', 2000013, 0,-1,0.00D0,1.000D+30,0.0,
+ & 'SSNUMUR ', 2000014, 0, 0,0.00D0,1.000D+30,0.0,
+ & 'SSTAU2- ', 2000015, 0,-1,0.00D0,1.000D+30,0.0,
+ & 'SSNUTR ', 2000016, 0, 0,0.00D0,1.000D+30,0.0,
+ & 'SSER+ ',-2000011, 0,+1,0.00D0,1.000D+30,0.0,
+ & 'SSNUERBR',-2000012, 0, 0,0.00D0,1.000D+30,0.0,
+ & 'SSMUR+ ',-2000013, 0,+1,0.00D0,1.000D+30,0.0,
+ & 'SSNUMRBR',-2000014, 0, 0,0.00D0,1.000D+30,0.0,
+ & 'SSTAU2+ ',-2000015, 0,+1,0.00D0,1.000D+30,0.0,
+ & 'SSNUTRBR',-2000016, 0, 0,0.00D0,1.000D+30,0.0/
+ DATA (RNAME(I),IDPDG(I),IFLAV(I),ICHRG(I),RMASS(I),RLTIM(I),
+ & RSPIN(I),I=449,NLAST)/
+ & 'GLUINO ', 1000021, 0, 0,0.00D0,1.000D+30,0.5,
+ & 'NTLINO1 ', 1000022, 0, 0,0.00D0,1.000D+30,0.5,
+ & 'NTLINO2 ', 1000023, 0, 0,0.00D0,1.000D+30,0.5,
+ & 'NTLINO3 ', 1000025, 0, 0,0.00D0,1.000D+30,0.5,
+ & 'NTLINO4 ', 1000035, 0, 0,0.00D0,1.000D+30,0.5,
+ & 'CHGINO1+', 1000024, 0,+1,0.00D0,1.000D+30,0.5,
+ & 'CHGINO2+', 1000037, 0,+1,0.00D0,1.000D+30,0.5,
+ & 'CHGINO1-',-1000024, 0,-1,0.00D0,1.000D+30,0.5,
+ & 'CHGINO2-',-1000037, 0,-1,0.00D0,1.000D+30,0.5,
+ & 'GRAVTINO', 1000039, 0, 0,0.00D0,1.000D+30,1.5/
+C
+ DATA QORQQB/.FALSE.,
+ & 6*.TRUE.,6*.FALSE.,96*.FALSE.,6*.FALSE.,6*.TRUE.,NREST*.FALSE./
+ DATA QBORQQ/.FALSE.,
+ & 6*.FALSE.,6*.TRUE.,96*.FALSE.,6*.TRUE.,6*.FALSE.,NREST*.FALSE./
+C
+C In the character strings use an ampersand to represent a backslash
+C to avoid compiler problems with the C escape character i.e. & = \
+ DATA ((TXNAME(J,I),J=1,2),I=0,8)/
+ & ' ',
+ & ' ',
+ & ' d',
+ & ' d',
+ & ' u',
+ & ' u',
+ & ' s',
+ & ' s',
+ & ' c',
+ & ' c',
+ & ' b',
+ & ' b',
+ & ' t',
+ & ' t',
+ & ' $&bar{&rm d}$',
+ & ' -d',
+ & ' $&bar{&rm u}$',
+ & ' -u'/
+ DATA ((TXNAME(J,I),J=1,2),I=9,16)/
+ & ' $&bar{&rm s}$',
+ & ' -s',
+ & ' $&bar{&rm c}$',
+ & ' -c',
+ & ' $&bar{&rm b}$',
+ & ' -b',
+ & ' $&bar{&rm t}$',
+ & ' -t',
+ & ' $g$',
+ & ' g',
+ & ' CoM',
+ & ' CoM',
+ & ' Hard',
+ & ' Hard',
+ & ' Soft',
+ & ' Soft'/
+ DATA ((TXNAME(J,I),J=1,2),I=17,24)/
+ & ' Cone',
+ & ' Cone',
+ & ' Heavy',
+ & ' Heavy',
+ & ' Cluster',
+ & ' Cluster',
+ & ' $&star&star&star&star$',
+ & ' ****',
+ & ' $&pi^0$',
+ & ' pi<SUP>0</SUP>',
+ & ' $&eta$',
+ & ' eta',
+ & ' $&rho^0$',
+ & ' rho<SUP>0</SUP>',
+ & ' $&omega$',
+ & ' omega'/
+ DATA ((TXNAME(J,I),J=1,2),I=25,32)/
+ & ' $&eta^&prime$',
+ & ' eta<SUP>''</SUP>',
+ & ' $f_2$',
+ & ' f<SUB>2</SUB>',
+ & ' $a^0_1$',
+ & ' a<SUB>1</SUB><SUP>0</SUP>',
+ & ' $f_1(L)$',
+ & ' f<SUB>1</SUB>(L)',
+ & ' $a^0_2$',
+ & ' a<SUB>2</SUB><SUP>0</SUP>',
+ & ' $&pi^-$',
+ & ' pi<SUP>-</SUP>',
+ & ' $&rho^-$',
+ & ' rho<SUP>-</SUP>',
+ & ' $a^-_1$',
+ & ' a<SUB>1</SUB><SUP>-</SUP>'/
+ DATA ((TXNAME(J,I),J=1,2),I=33,40)/
+ & ' $a^-_2$',
+ & ' a<SUB>2</SUB><SUP>-</SUP>',
+ & ' K$^-$',
+ & ' K<SUP>-</SUP>',
+ & ' K$^{&star-}$',
+ & ' K<SUP>*-</SUP>',
+ & ' K$_1(H)^-$',
+ & ' K<SUB>1</SUB>(H)<SUP>-</SUP>',
+ & ' K$^{&star-}_2$',
+ & ' K<SUB>2</SUB><SUP>*-</SUP>',
+ & ' $&pi^+$',
+ & ' pi<SUP>+</SUP>',
+ & ' $&rho^+$',
+ & ' rho<SUP>+</SUP>',
+ & ' $a^+_1$',
+ & ' a<SUB>1</SUB><SUP>+</SUP>'/
+ DATA ((TXNAME(J,I),J=1,2),I=41,48)/
+ & ' $a^+_2$',
+ & ' a<SUB>2</SUB><SUP>+</SUP>',
+ & ' $&overline{&rm K}^0$',
+ & ' -K<SUP>0</SUP>',
+ & ' $&overline{&rm K}^{&star0}$',
+ & ' -K<SUP>*0</SUP>',
+ & ' $&overline{&rm K}_1(H)^0$',
+ & ' -K<SUB>1</SUB>(H)<SUP>0</SUP>',
+ & ' $&overline{&rm K}^{&star0}_2$',
+ & ' -K<SUB>2</SUB><SUP>*0</SUP>',
+ & ' K$^+$',
+ & ' K<SUP>+</SUP>',
+ & ' K$^{&star+}$',
+ & ' K<SUP>*+</SUP>',
+ & ' K$_1(H)^+$',
+ & ' K<SUB>1</SUB>(H)<SUP>+</SUP>'/
+ DATA ((TXNAME(J,I),J=1,2),I=49,56)/
+ & ' K$^{&star+}_2$',
+ & ' K<SUB>2</SUB>(H)<SUP>*+</SUP>',
+ & ' K$^0$',
+ & ' K<SUP>0</SUP>',
+ & ' K$^{&star0}$',
+ & ' K<SUP>*-</SUP>',
+ & ' K$_1(H)^0$',
+ & ' K<SUB>1</SUB>(H)<SUP>0</SUP>',
+ & ' K$^{&star0}_2$',
+ & ' K<SUB>2</SUB><SUP>*0</SUP>',
+ & ' ',
+ & ' ',
+ & ' ',
+ & ' ',
+ & ' $&phi$',
+ & ' phi'/
+ DATA ((TXNAME(J,I),J=1,2),I=57,64)/
+ & ' $f_1(1420)$',
+ & ' f<SUB>1</SUB>(1420)',
+ & ' $f^&prime_2$',
+ & ' f<SUP>''</SUP><SUB>2</SUB>',
+ & ' $&gamma$',
+ & ' gamma',
+ & ' K$^0_{&rm S}$',
+ & ' K<SUB>S</SUB><SUP>0</SUP>',
+ & ' K$^0_{&rm L}$',
+ & ' K<SUB>L</SUB><SUP>0</SUP>',
+ & ' $a_0(1450)^0$',
+ & ' a<SUB>0</SUB>(1450)<SUP>0</SUP>',
+ & ' $a_0(1450)^+$',
+ & ' a<SUB>0</SUB>(1450)<SUP>+</SUP>',
+ & ' $a_0(1450)^-$',
+ & ' a<SUB>0</SUB>(1450)<SUP>-</SUP>'/
+ DATA ((TXNAME(J,I),J=1,2),I=65,72)/
+ & ' ',
+ & ' ',
+ & ' ',
+ & ' ',
+ & ' ',
+ & ' ',
+ & ' ',
+ & ' ',
+ & ' ',
+ & ' ',
+ & ' ',
+ & ' ',
+ & ' $&gamma$-remnant',
+ & ' gamma-remnant',
+ & ' $N$-remnant',
+ & ' N-remnant'/
+ DATA ((TXNAME(J,I),J=1,2),I=73,80)/
+ & ' p',
+ & ' p',
+ & ' $&Delta^+$',
+ & ' Delta<SUP>+</SUP>',
+ & ' n',
+ & ' n',
+ & ' $&Delta^0$',
+ & ' Delta<SUP>0</SUP>',
+ & ' $&Delta^-$',
+ & ' Delta<SUP>-</SUP>',
+ & ' $&Lambda$',
+ & ' Lambda',
+ & ' $&Sigma^0$',
+ & ' Sigma<SUP>0</SUP>',
+ & ' $&Sigma^{&star0}$',
+ & ' Sigma<SUP>*0</SUP>'/
+ DATA ((TXNAME(J,I),J=1,2),I=81,88)/
+ & ' $&Sigma^-$',
+ & ' Sigma<SUP>-</SUP>',
+ & ' $&Sigma^{&star-}$',
+ & ' Sigma<SUP>*-</SUP>',
+ & ' $&Xi^-$',
+ & ' Xi<SUP>-</SUP>',
+ & ' $&Xi^{&star-}$',
+ & ' Xi<SUP>*-</SUP>',
+ & ' $&Delta^{++}$',
+ & ' Delta<SUP>++</SUP>',
+ & ' $&Sigma^+$',
+ & ' Sigma<SUP>+</SUP>',
+ & ' $&Sigma^{&star+}$',
+ & ' Sigma<SUP>*+</SUP>',
+ & ' $&Xi^0$',
+ & ' Xi<SUP>0</SUP>'/
+ DATA ((TXNAME(J,I),J=1,2),I=89,96)/
+ & ' $&Xi^{&star0}$',
+ & ' Xi<SUP>*0</SUP>',
+ & ' $&Omega^-$',
+ & ' Omega<SUP>-</SUP>',
+ & ' $&bar{&rm p}$',
+ & ' -p',
+ & ' $&overline{&Delta}^-$',
+ & ' -Delta<SUP>-</SUP>',
+ & ' $&bar{&rm n}$',
+ & ' -n',
+ & ' $&overline{&Delta}^0$',
+ & ' -Delta<SUP>0</SUP>',
+ & ' $&overline{&Delta}^+$',
+ & ' -Delta<SUP>+</SUP>',
+ & ' $&overline{&Lambda}$',
+ & ' -Lambda'/
+ DATA ((TXNAME(J,I),J=1,2),I=97,104)/
+ & ' $&overline{&Sigma}^0$',
+ & ' -Sigma<SUP>0</SUP>',
+ & ' $&overline{&Sigma}^{&star0}$',
+ & ' -Sigma<SUP>*0</SUP>',
+ & ' $&overline{&Sigma}^+$',
+ & ' -Sigma<SUP>+</SUP>',
+ & ' $&overline{&Sigma}^{&star+}$',
+ & ' -Sigma<SUP>*+</SUP>',
+ & ' $&overline{&Xi}^+$',
+ & ' -Xi<SUP>+</SUP>',
+ & ' $&overline{&Xi}^{&star+}$',
+ & ' -Xi<SUP>*+</SUP>',
+ & ' $&overline{&Delta}^{--}$',
+ & ' -Delta<SUP>--</SUP>',
+ & ' $&overline{&Sigma}^-$',
+ & ' -Sigma<SUP>-</SUP>'/
+ DATA ((TXNAME(J,I),J=1,2),I=105,112)/
+ & ' $&overline{&Sigma}^{&star-}$',
+ & ' -Sigma<SUP>*-</SUP>',
+ & ' $&overline{&Xi}^0$',
+ & ' -Xi<SUP>0</SUP>',
+ & ' $&overline&Xi^{&star0}$',
+ & ' -Xi<SUP>*0</SUP>',
+ & ' $&overline{&Omega}^+$',
+ & ' -Omega<SUP>+</SUP>',
+ & ' uu',
+ & ' uu',
+ & ' ud',
+ & ' ud',
+ & ' dd',
+ & ' dd',
+ & ' us',
+ & ' us'/
+ DATA ((TXNAME(J,I),J=1,2),I=113,120)/
+ & ' ds',
+ & ' ds',
+ & ' ss',
+ & ' ss',
+ & ' $&bar{&rm u}&bar{&rm u}$',
+ & ' -uu',
+ & ' $&bar{&rm u}&bar{&rm d}$',
+ & ' -ud',
+ & ' $&bar{&rm d}&bar{&rm d}$',
+ & ' -dd',
+ & ' $&bar{&rm u}&bar{&rm s}$',
+ & ' -us',
+ & ' $&bar{&rm d}&bar{&rm s}$',
+ & ' -ds',
+ & ' $&bar{&rm s}&bar{&rm s}$',
+ & ' -ss'/
+ DATA ((TXNAME(J,I),J=1,2),I=121,128)/
+ & ' e$^-$',
+ & ' e<SUP>-</SUP>',
+ & ' $&nu_{&rm e}$',
+ & ' nu<SUB>e</SUB>',
+ & ' $&mu^-$',
+ & ' mu<SUP>-</SUP>',
+ & ' $&nu_&mu$',
+ & ' nu<SUB>mu</SUB>',
+ & ' $&tau^-$',
+ & ' tau<SUP>-</SUP>',
+ & ' $&nu_&tau$',
+ & ' nu<SUB>tau</SUB>',
+ & ' e$^+$',
+ & ' e<SUP>+</SUP>',
+ & ' $&bar{&nu}_{&rm e}$',
+ & ' -nu<SUB>e</SUB>'/
+ DATA ((TXNAME(J,I),J=1,2),I=129,136)/
+ & ' $&mu^+$',
+ & ' mu<SUP>+</SUP>',
+ & ' $&bar{&nu}_&mu$',
+ & ' -nu<SUB>mu</SUB>',
+ & ' $&tau^+$',
+ & ' tau<SUP>+</SUP>',
+ & ' $&bar{&nu}_&tau$',
+ & ' -nu<SUB>tau</SUB>',
+ & ' ',
+ & ' ',
+ & ' ',
+ & ' ',
+ & ' ',
+ & ' ',
+ & ' D$^+$',
+ & ' D<SUP>+</SUP>'/
+ DATA ((TXNAME(J,I),J=1,2),I=137,144)/
+ & ' D$^{&star+}$',
+ & ' D<SUP>*+</SUP>',
+ & ' D$_1(H)^+$',
+ & ' D<SUB>1</SUB>(H)<SUP>+</SUP>',
+ & ' D$_2^{&star+}$',
+ & ' D<SUB>2</SUB><SUP>*+</SUP>',
+ & ' D$^0$',
+ & ' D<SUP>0</SUP>',
+ & ' D$^{&star0}$',
+ & ' D<SUP>*0</SUP>',
+ & ' D$_1(H)^0$',
+ & ' D<SUB>1</SUB>(H)<SUP>0</SUP>',
+ & ' D$_2^{&star0}$',
+ & ' D<SUB>2</SUB><SUP>*0</SUP>',
+ & ' D$_{&rm s}^+$',
+ & ' D<SUB>s</SUB><SUP>+</SUP>'/
+ DATA ((TXNAME(J,I),J=1,2),I=145,152)/
+ & ' D$_{&rm s}^{&star+}$',
+ & ' D<SUB>s</SUB><SUP>*+</SUP>',
+ & ' D$_{&rm s1}(H)^+$',
+ & ' D<SUB>s1</SUB>(H)<SUP>+</SUP>',
+ & ' D$^{&star+}_{&rm s2}$',
+ & ' D<SUB>s1</SUB>(H)<SUP>*+</SUP>',
+ & ' $&Sigma_{&rm c}^{++}$',
+ & ' Sigma<SUB>c</SUB><SUP>++</SUP>',
+ & ' $&Sigma_{&rm c}^{&star++}$',
+ & ' Sigma<SUB>c</SUB><SUP>*++</SUP>',
+ & ' $&Lambda_{&rm c}^+$',
+ & ' Lambda<SUB>c</SUB><SUP>+</SUP>',
+ & ' $&Sigma_{&rm c}^+$',
+ & ' Sigma<SUB>c</SUB><SUP>+</SUP>',
+ & ' $&Sigma_{&rm c}^{&star+}$',
+ & ' Sigma<SUB>c</SUB><SUP>*+</SUP>'/
+ DATA ((TXNAME(J,I),J=1,2),I=153,160)/
+ & ' $&Sigma_{&rm c}^0$',
+ & ' Sigma<SUB>c</SUB><SUP>0</SUP>',
+ & ' $&Sigma_{&rm c}^{&star0}$',
+ & ' Sigma<SUB>c</SUB><SUP>*0</SUP>',
+ & ' $&Xi_{&rm c}^+$',
+ & ' Xi<SUB>c</SUB><SUP>+</SUP>',
+ & ' $&Xi_{&rm c}^{&prime+}$',
+ & ' Xi<SUB>c</SUB><SUP>''+</SUP>',
+ & ' $&Xi_{&rm c}^{&star+}$',
+ & ' Xi<SUB>c</SUB><SUP>*+</SUP>',
+ & ' $&Xi_{&rm c}^0$',
+ & ' Xi<SUB>c</SUB><SUP>0</SUP>',
+ & ' $&Xi_{&rm c}^{&prime0}$',
+ & ' Xi<SUB>c</SUB><SUP>''0</SUP>',
+ & ' $&Xi_{&rm c}^{&star0}$',
+ & ' Xi<SUB>c</SUB><SUP>*0</SUP>'/
+ DATA ((TXNAME(J,I),J=1,2),I=161,168)/
+ & ' $&Omega_{&rm c}^0$',
+ & ' Omega<SUB>c</SUB><SUP>0</SUP>',
+ & ' $&Omega_{&rm c}^{&star0}$',
+ & ' Omega<SUB>c</SUB><SUP>*0</SUP>',
+ & ' $&eta_{&rm c}(1S)$',
+ & ' eta<SUB>c</SUB>(1S)',
+ & ' J/$&psi$',
+ & ' J/psi',
+ & ' $&chi_{&rm c0}(1P)$',
+ & ' chi<SUB>c0</SUB>(1P)',
+ & ' $&psi(2S)$',
+ & ' psi(2S)',
+ & ' $&psi(1D)$',
+ & ' psi(1D)',
+ & ' ',
+ & ' '/
+ DATA ((TXNAME(J,I),J=1,2),I=169,176)/
+ & ' ',
+ & ' ',
+ & ' ',
+ & ' ',
+ & ' D$^-$',
+ & ' D<SUP>-</SUP>',
+ & ' D$^{&star-}$',
+ & ' D<SUP>*-</SUP>',
+ & ' D$_1(H)^-$',
+ & ' D<SUB>1</SUB>(H)<SUP>-</SUP>',
+ & ' D$_2^{&star-}$',
+ & ' D<SUB>2</SUB><SUP>*-</SUP>',
+ & ' $&overline{&rm D}^0$',
+ & ' -D<SUP>0</SUP>',
+ & ' $&overline{&rm D}^{&star0}$',
+ & ' -D<SUP>*0</SUP>'/
+ DATA ((TXNAME(J,I),J=1,2),I=177,184)/
+ & ' $&overline{&rm D}_1(H)^0$',
+ & ' -D<SUB>1</SUB>(H)<SUP>0</SUP>',
+ & ' $&overline{&rm D}_2^{&star0}$',
+ & ' -D<SUB>2</SUB><SUP>*0</SUP>',
+ & ' D$_{&rm s}^-$',
+ & ' D<SUB>s</SUB><SUP>-</SUP>',
+ & ' D$_{&rm s}^{&star-}$',
+ & ' D<SUB>s</SUB><SUP>*-</SUP>',
+ & ' D$_{&rm s1}(H)^-$',
+ & ' D<SUB>s1</SUB>(H)<SUP>-</SUP>',
+ & ' D$_{&rm s2}^{&star-}$',
+ & ' D<SUB>s1</SUB>(H)<SUP>*-</SUP>',
+ & ' $&overline{&Sigma}_{&rm c}^{--}$',
+ & ' -Sigma<SUB>c</SUB><SUP>--</SUP>',
+ & '$&overline{&Sigma}_{&rm c}^{&star--}$',
+ & ' -Sigma<SUB>c</SUB><SUP>*--</SUP>'/
+ DATA ((TXNAME(J,I),J=1,2),I=185,192)/
+ & ' $&overline{&Lambda}_{&rm c}^-$',
+ & ' -Lambda<SUB>c</SUB><SUP>-</SUP>',
+ & ' $&overline{&Sigma}_{&rm c}^-$',
+ & ' -Sigma<SUB>c</SUB><SUP>-</SUP>',
+ & ' $&overline{&Sigma}_{&rm c}^{&star-}$',
+ & ' -Sigma<SUB>c</SUB><SUP>*-</SUP>',
+ & ' $&overline{&Sigma}_{&rm c}^0$',
+ & ' -Sigma<SUB>c</SUB><SUP>0</SUP>',
+ & ' $&overline{&Sigma}_{&rm c}^{&star0}$',
+ & ' -Sigma<SUB>c</SUB><SUP>*0</SUP>',
+ & ' $&overline{&Xi}_{&rm c}^-$',
+ & ' -Xi<SUB>c</SUB><SUP>-</SUP>',
+ & ' $&overline{&Xi}_{&rm c}^{&prime-}$',
+ & ' -Xi<SUB>c</SUB><SUP>''-</SUP>',
+ & ' $&overline{&Xi}_{&rm c}^{&star-}$',
+ & ' -Xi<SUB>c</SUB><SUP>*-</SUP>'/
+ DATA ((TXNAME(J,I),J=1,2),I=193,200)/
+ & ' $&overline{&Xi}_{&rm c}^0$',
+ & ' -Xi<SUB>c</SUB><SUP>0</SUP>',
+ & ' $&overline{&Xi}_{&rm c}^{&prime0}$',
+ & ' -Xi<SUB>c</SUB><SUP>''0</SUP>',
+ & ' $&overline{&Xi}_{&rm c}^{&star0}$',
+ & ' -Xi<SUB>c</SUB><SUP>*0</SUP>',
+ & ' $&overline{&Omega}_{&rm c}^0$',
+ & ' -Omega<SUB>c</SUB><SUP>0</SUP>',
+ & ' $&overline{&Omega}_{&rm c}^{&star0}$',
+ & ' -Omega<SUB>c</SUB><SUP>*0</SUP>',
+ & ' W$^+$',
+ & ' W<SUP>+</SUP>',
+ & ' W$^-$',
+ & ' W<SUP>-</SUP>',
+ & ' Z$^0/&gamma^&star$',
+ & ' Z<SUP>0</SUP>/gamma<SUP>*</SUP>'/
+ DATA ((TXNAME(J,I),J=1,2),I=201,208)/
+ & ' $H^0_{&rm SM}$',
+ & ' H<SUP>0</SUP><SUB>SM</SUB>',
+ & ' Z$^{&prime0}$',
+ & ' Z<SUP>''0</SUP>',
+ & ' $h^0$',
+ & ' h<SUP>0</SUP>',
+ & ' $H^0$',
+ & ' H<SUP>0</SUP>',
+ & ' $A^0$',
+ & ' A<SUP>0</SUP>',
+ & ' $H^+$',
+ & ' H<SUP>+</SUP>',
+ & ' $H^-$',
+ & ' H<SUP>-</SUP>',
+ & ' ',
+ & ' '/
+ DATA ((TXNAME(J,I),J=1,2),I=209,216)/
+ & ' V-quark',
+ & ' V-quark',
+ & ' A-quark',
+ & ' A-quark',
+ & ' H-quark',
+ & ' H-quark',
+ & ' H$^&prime$-quark',
+ & ' H<SUP>''</SUP>-quark',
+ & ' ',
+ & ' ',
+ & ' ',
+ & ' ',
+ & ' $&overline{&rm V}$-quark',
+ & ' -V-quark',
+ & ' $&overline{&rm A}$-quark',
+ & ' -A-quark'/
+ DATA ((TXNAME(J,I),J=1,2),I=217,224)/
+ & ' $&overline{&rm H}$-quark',
+ & ' -H-quark',
+ & ' $&overline{&rm H}^&prime$-quark',
+ & ' -H<SUP>''</SUP>-quark',
+ & ' ',
+ & ' ',
+ & ' ',
+ & ' ',
+ & ' $&overline{&rm B}_{&rm d}^0$',
+ & ' -B<SUB>d</SUB><SUP>0</SUP>',
+ & ' B$^-$',
+ & ' B<SUP>-</SUP>',
+ & ' $&overline{&rm B}_{&rm s}^0$',
+ & ' -B<SUB>s</SUB><SUP>0</SUP>',
+ & ' $&Sigma_{&rm b}^+$',
+ & ' Sigma<SUB>b</SUB><SUP>+</SUP>'/
+ DATA ((TXNAME(J,I),J=1,2),I=225,232)/
+ & ' $&Lambda_{&rm b}^0$',
+ & ' Lambda<SUB>b</SUB><SUP>0</SUP>',
+ & ' $&Sigma_{&rm b}^-$',
+ & ' Sigma<SUB>b</SUB><SUP>-</SUP>',
+ & ' $&Xi_{&rm b}^0$',
+ & ' Xi<SUB>b</SUB><SUP>0</SUP>',
+ & ' $&Xi_{&rm b}^-$',
+ & ' Xi<SUB>b</SUB><SUP>-</SUP>',
+ & ' $&Omega_{&rm b}^-$',
+ & ' Omega<SUB>b</SUB><SUP>-</SUP>',
+ & ' B$_{&rm c}^-$',
+ & ' B<SUB>c</SUB><SUP>-</SUP>',
+ & ' $&Upsilon(1S)$',
+ & ' Upsilon(1S)',
+ & ' T$_{&rm b}^-$',
+ & ' T<SUB>b</SUB><SUP>-</SUP>'/
+ DATA ((TXNAME(J,I),J=1,2),I=233,240)/
+ & ' T$^+$',
+ & ' T<SUP>+</SUP>',
+ & ' T$^0$',
+ & ' T<SUP>0</SUP>',
+ & ' T$_{&rm s}^+$',
+ & ' T<SUB>s</SUB><SUP>+</SUP>',
+ & ' $&Sigma_{&rm t}^{++}$',
+ & ' Sigma<SUB>t</SUB><SUP>++</SUP>',
+ & ' $&Lambda_{&rm t}^0$',
+ & ' Lambda<SUB>t</SUB><SUP>0</SUP>',
+ & ' $&Sigma_{&rm t}^0$',
+ & ' Sigma<SUB>t</SUB><SUP>0</SUP>',
+ & ' $&chi_{&rm t}^+$',
+ & ' Xi<SUB>t</SUB><SUP>+</SUP>',
+ & ' $&chi_{&rm t}^0$',
+ & ' Xi<SUB>t</SUB><SUP>0</SUP>'/
+ DATA ((TXNAME(J,I),J=1,2),I=241,248)/
+ & ' $&Omega_{&rm t}^0$',
+ & ' Omega<SUB>t</SUB><SUP>0</SUP>',
+ & ' T$_{&rm c}^0$',
+ & ' T<SUB>c</SUB><SUP>0</SUP>',
+ & ' T$_{&rm b}^+$',
+ & ' T<SUB>b</SUB><SUP>+</SUP>',
+ & ' Toponium',
+ & ' Toponium',
+ & ' B$_{&rm d}^0$',
+ & ' B<SUB>d</SUB><SUP>0</SUP>',
+ & ' B$^+$',
+ & ' B<SUP>+</SUP>',
+ & ' B$_{&rm s}^0$',
+ & ' B<SUB>s</SUB><SUP>0</SUP>',
+ & ' $&overline{&Sigma}_{&rm b}^-$',
+ & ' -Sigma<SUB>b</SUB><SUP>-</SUP>'/
+ DATA ((TXNAME(J,I),J=1,2),I=249,256)/
+ & ' $&overline{&Lambda}_{&rm b}^-$',
+ & ' -Lambda<SUB>b</SUB><SUP>-</SUP>',
+ & ' $&overline{&Sigma}_{&rm b}^+$',
+ & ' -Sigma<SUB>b</SUB><SUP>+</SUP>',
+ & ' $&overline{&Xi}_{&rm b}^0$',
+ & ' -Xi<SUB>b</SUB><SUP>0</SUP>',
+ & ' $&Xi_{&rm b}^+$',
+ & ' Xi<SUB>b</SUB><SUP>+</SUP>',
+ & ' $&overline{&Omega}_{&rm b}^+$',
+ & ' -Omega<SUB>b</SUB><SUP>+</SUP>',
+ & ' B$_{&rm c}^+$',
+ & ' B<SUB>c</SUB><SUP>+</SUP>',
+ & ' T$^-$',
+ & ' T<SUP>-</SUP>',
+ & ' $&overline{&rm T}^0$',
+ & ' T<SUP>0</SUP>'/
+ DATA ((TXNAME(J,I),J=1,2),I=257,264)/
+ & ' T$_{&rm s}^-$',
+ & ' T<SUB>s</SUB><SUP>-</SUP>',
+ & ' $&overline{&Sigma}_{&rm t}^{--}$',
+ & ' Sigma<SUB>t</SUB><SUP>--</SUP>',
+ & ' $&overline{&Lambda}_{&rm t}^-$',
+ & ' -Lambda<SUB>t</SUB><SUP>-</SUP>',
+ & ' $&overline{&Sigma}_{&rm t}^0$',
+ & ' -Sigma<SUB>t</SUB><SUP>0</SUP>',
+ & ' $&overline{&Xi}_{&rm t}^-$',
+ & ' -Xi<SUB>t</SUB><SUP>-</SUP>',
+ & ' $&overline{&Xi}_{&rm t}^0$',
+ & ' -Xi<SUB>t</SUB><SUP>0</SUP>',
+ & ' $&overline{&Omega}_{&rm t}^0$',
+ & ' -Omega<SUB>t</SUB><SUP>0</SUP>',
+ & ' $&overline{&rm T}_{&rm c}^0$',
+ & ' T<SUB>c</SUB><SUP>0</SUP>'/
+ DATA ((TXNAME(J,I),J=1,2),I=265,272)/
+ & ' $&overline{&rm B}^{&star0}$',
+ & ' -B<SUP>*0</SUP>',
+ & ' B$^{&star-}$',
+ & ' B<SUP>*-</SUP>',
+ & ' $&overline{&rm B}_{&rm s}^{&star0}$',
+ & ' -B<SUB>s</SUB><SUP>*0</SUP>',
+ & ' $&overline{&rm B}_1(H)^0$',
+ & ' -B<SUB>1</SUB>(H)<SUP>0</SUP>',
+ & ' B$_1(H)^-$',
+ & ' B<SUB>1</SUB>(H)<SUP>-</SUP>',
+ & ' $&overline{&rm B}_{&rm s1}(H)^0$',
+ & ' -B<SUB>s1</SUB>(H)<SUP>0</SUP>',
+ & ' $&overline{&rm B}_2^{&star0}$',
+ & ' -B<SUB>2</SUB><SUP>*0</SUP>',
+ & ' B$_2^{&star-}$',
+ & ' B<SUB>2</SUB><SUP>*-</SUP>'/
+ DATA ((TXNAME(J,I),J=1,2),I=273,280)/
+ & ' B$_{&rm s2}^{&star0}$',
+ & ' B<SUB>s2</SUB><SUP>*0</SUP>',
+ & ' B$^{&star0}$',
+ & ' B<SUP>*0</SUP>',
+ & ' B$^{&star+}$',
+ & ' B<SUP>*+</SUP>',
+ & ' B$_{&rm s}^{&star0}$',
+ & ' B<SUB>s</SUB><SUP>*0</SUP>',
+ & ' B$_1(H)^0$',
+ & ' B<SUB>1</SUB>(H)<SUP>0</SUP>',
+ & ' B$_1(H)^+$',
+ & ' B<SUB>1</SUB>(H)<SUP>+</SUP>',
+ & ' B$_{&rm s1}(H)^0$',
+ & ' B<SUB>s1</SUB>(H)<SUP>0</SUP>',
+ & ' B$_2^{&star0}$',
+ & ' B<SUB>2</SUB><SUP>*0</SUP>'/
+ DATA ((TXNAME(J,I),J=1,2),I=281,288)/
+ & ' B$_2^{&star+}$',
+ & ' B<SUB>2</SUB><SUP>*+</SUP>',
+ & ' B$_{&rm s2}^{&star0}$',
+ & ' B<SUB>s2</SUB><SUP>*0</SUP>',
+ & ' ',
+ & ' ',
+ & ' ',
+ & ' ',
+ & ' b$_1^0$',
+ & ' b<SUB>1</SUB><SUP>0</SUP>',
+ & ' b$_1^+$',
+ & ' b<SUB>1</SUB><SUP>+</SUP>',
+ & ' b$_1^-$',
+ & ' b<SUB>1</SUB><SUP>-</SUP>',
+ & ' h$_1(L)^0$',
+ & ' h<SUB>1</SUB>(L)<SUP>0</SUP>'/
+ DATA ((TXNAME(J,I),J=1,2),I=289,296)/
+ & ' h$_1(H)^0$',
+ & ' h<SUB>1</SUB>(H)<SUP>0</SUP>',
+ & ' a$_0(980)^0$',
+ & ' a<SUB>0</SUB>(980)<SUP>0</SUP>',
+ & ' a$_0(980)^+$',
+ & ' a<SUB>0</SUB>(980)<SUP>+</SUP>',
+ & ' a$_0(980)^-$',
+ & ' a<SUB>0</SUB>(980)<SUP>-</SUP>',
+ & ' f$_0(980)$',
+ & ' f<SUB>0</SUB>(980)',
+ & ' f$_0(1370)$',
+ & ' f<SUB>0</SUB>(1370)',
+ & ' B$_{&rm c}^{&star+}$',
+ & ' B<SUB>c</SUB><SUP>*+</SUP>',
+ & ' B$_{&rm c}^{&star-}$',
+ & ' B<SUB>c</SUB><SUP>*-</SUP>'/
+ DATA ((TXNAME(J,I),J=1,2),I=297,304)/
+ & ' B$_{&rm c1}(H)^+$',
+ & ' B<SUB>c1</SUB>(H)<SUP>+</SUP>',
+ & ' B$_{&rm c1}(H)^-$',
+ & ' B<SUB>c1</SUB>(H)<SUP>-</SUP>',
+ & ' B$_{&rm c2}^{&star+}$',
+ & ' B<SUB>c2</SUB><SUP>*+</SUP>',
+ & ' B$_{&rm c2}^{&star-}$',
+ & ' B<SUB>c2</SUB><SUP>*-</SUP>',
+ & ' h$_{&rm c}(1P)$',
+ & ' h<SUB>c</SUB>(1P)',
+ & ' $&chi_{&rm c0}(1P)$',
+ & ' chi<SUB>c0</SUB>(1P)',
+ & ' $&chi_{&rm c2}(1P)$',
+ & ' chi<SUB>c2</SUB>(1P)',
+ & ' $&eta_{&rm b}(1S)$',
+ & ' eta<SUB>b</SUB>(1S)'/
+ DATA ((TXNAME(J,I),J=1,2),I=305,312)/
+ & ' h$_{&rm b}(1P)$',
+ & ' h<SUB>b</SUB>(1P)',
+ & ' $&chi_{&rm b0}(1P)$',
+ & ' chi<SUB>b0</SUB>(1P)',
+ & ' $&chi_{&rm b1}(1P)$',
+ & ' chi<SUB>b1</SUB>(1P)',
+ & ' $&chi_{&rm b2}(1P)$',
+ & ' chi<SUB>b2</SUB>(1P)',
+ & ' K$_1(L)^0$',
+ & ' K<SUB>1</SUB>(L)<SUP>0</SUP>',
+ & ' K$_1(L)^+$',
+ & ' K<SUB>1</SUB>(L)<SUP>+</SUP>',
+ & ' $&overline{&rm K}_1(L)^0$',
+ & ' -K<SUB>1</SUB>(L)<SUP>0</SUP>',
+ & ' K$_1(L)^-$',
+ & ' K<SUB>1</SUB>(L)<SUP>-</SUP>'/
+ DATA ((TXNAME(J,I),J=1,2),I=313,320)/
+ & ' D$_1(L)^+$',
+ & ' D<SUB>1</SUB>(L)<SUP>+</SUP>',
+ & ' D$_1(L)^0$',
+ & ' D<SUB>1</SUB>(L)<SUP>0</SUP>',
+ & ' D$_{&rm s1}(L)^+$',
+ & ' D<SUB>s1</SUB>(L)<SUP>+</SUP>',
+ & ' D$_1(L)^-$',
+ & ' D<SUB>1</SUB>(L)<SUP>-</SUP>',
+ & ' $&overline{&rm D}_1(L)^0$',
+ & ' D<SUB>1</SUB>(L)<SUP>0</SUP>',
+ & ' D$_{&rm s1}(L)^-$',
+ & ' D<SUB>s1</SUB>(L)<SUP>-</SUP>',
+ & ' B$_1(L)^0$',
+ & ' B<SUB>1</SUB>(L)<SUP>0</SUP>',
+ & ' B$_1(L)^+$',
+ & ' B<SUB>1</SUB>(L)<SUP>+</SUP>'/
+ DATA ((TXNAME(J,I),J=1,2),I=321,328)/
+ & ' B$_{&rm s1}(L)^0$',
+ & ' B<SUB>s1</SUB>(L)<SUP>0</SUP>',
+ & ' B$_{&rm c1}(L)^+$',
+ & ' B<SUB>c1</SUB>(L)<SUP>+</SUP>',
+ & ' $&overline{&rm B}_1(L)^0$',
+ & ' -B<SUB>1</SUB>(L)<SUP>0</SUP>',
+ & ' B$_1(L)^-$',
+ & ' B<SUB>1</SUB>(L)<SUP>-</SUP>',
+ & ' $&overline{&rm B}_{&rm s1}(L)^0$',
+ & ' -B<SUB>s1</SUB>(L)<SUP>0</SUP>',
+ & ' B$_{&rm c1}(L)^-$',
+ & ' B<SUB>c1</SUB>(L)<SUP>-</SUP>',
+ & ' K$_0^{&star+}$',
+ & ' K<SUB>0</SUB><SUP>*+</SUP>',
+ & ' K$_0^{&star0}$',
+ & ' K<SUB>0</SUB><SUP>*0</SUP>'/
+ DATA ((TXNAME(J,I),J=1,2),I=329,336)/
+ & ' $&overline{&rm K}_0^{&star0}$',
+ & ' -K<SUB>0</SUB><SUP>*0</SUP>',
+ & ' K$_0^{&star-}$',
+ & ' K<SUB>0</SUB><SUP>*-</SUP>',
+ & ' D$_0^{&star+}$',
+ & ' D<SUB>0</SUB><SUP>*+</SUP>',
+ & ' D$_0^{&star0}$',
+ & ' D<SUB>0</SUB><SUP>*0</SUP>',
+ & ' D$_{&rm s0}^{&star+}$',
+ & ' D<SUB>s0</SUB><SUP>*+</SUP>',
+ & ' D$_0^{&star-}$',
+ & ' D<SUB>0</SUB><SUP>*-</SUP>',
+ & ' $&overline{&rm D}_0^{&star0}$',
+ & ' -D<SUB>0</SUB><SUP>*0</SUP>',
+ & ' D$_{&rm s0}^{&star-}$',
+ & ' D<SUB>s0</SUB><SUP>*-</SUP>'/
+ DATA ((TXNAME(J,I),J=1,2),I=337,344)/
+ & ' B$_0^{&star0}$',
+ & ' B<SUB>0</SUB><SUP>*0</SUP>',
+ & ' B$_0^{&star+}$',
+ & ' B<SUB>0</SUB><SUP>*+</SUP>',
+ & ' B$_{&rm s0}^{&star0}$',
+ & ' B<SUB>s0</SUB><SUP>*0</SUP>',
+ & ' B$_{&rm c0}^{&star+}$',
+ & ' B<SUB>c0</SUB><SUP>*+</SUP>',
+ & ' $&overline{&rm B}_0^{&star0}$',
+ & ' -B<SUB>0</SUB><SUP>*0</SUP>',
+ & ' B$_0^{&star-}$',
+ & ' B<SUB>0</SUB><SUP>*-</SUP>',
+ & ' $&overline{&rm B}_{&rm s0}^{&star0}$',
+ & ' -B<SUB>s0</SUB><SUP>*0</SUP>',
+ & ' B$_{&rm c0}^{&star-}$',
+ & ' B<SUB>c0</SUB><SUP>*-</SUP>'/
+ DATA ((TXNAME(J,I),J=1,2),I=345,352)/
+ & ' $&Sigma_{&rm b}^0$',
+ & ' Sigma<SUB>b</SUB><SUP>0</SUP>',
+ & ' $&Sigma_{&rm b}^{&star-}$',
+ & ' Sigma<SUB>b</SUB><SUP>*-</SUP>',
+ & ' $&Sigma_{&rm b}^{&star0}$',
+ & ' Sigma<SUB>b</SUB><SUP>*0</SUP>',
+ & ' $&Sigma_{&rm b}^{&star+}$',
+ & ' Sigma<SUB>b</SUB><SUP>*+</SUP>',
+ & ' $&Xi_{&rm b}^{&prime0}$',
+ & ' Xi<SUB>b</SUB><SUP>''0</SUP>',
+ & ' $&Xi_{&rm b}^{&star0}$',
+ & ' Xi<SUB>b</SUB><SUP>*0</SUP>',
+ & ' $&Xi_{&rm b}^{&prime-}$',
+ & ' Xi<SUB>b</SUB><SUP>''-</SUP>',
+ & ' $&Xi_{&rm b}^{&star-}$',
+ & ' Xi<SUB>b</SUB><SUP>*-</SUP>'/
+ DATA ((TXNAME(J,I),J=1,2),I=353,360)/
+ & ' $&Omega_{&rm b}^{&star-}$',
+ & ' -Omega<SUB>b</SUB><SUP>*-</SUP>',
+ & ' $&overline{&Sigma}_{&rm b}^{&star+}$',
+ & ' Sigma<SUB>b</SUB><SUP>*+</SUP>',
+ & ' $&overline{&Sigma}_{&rm b}^0$',
+ & ' -Sigma<SUB>b</SUB><SUP>0</SUP>',
+ & ' $&overline{&Sigma}_{&rm b}^{&star0}$',
+ & ' -Sigma<SUB>b</SUB><SUP>*0</SUP>',
+ & ' $&overline{&Sigma}_{&rm b}^{&star-}$',
+ & ' -Sigma<SUB>b</SUB><SUP>*-</SUP>',
+ & ' $&overline{&Xi}_{&rm b}^{&prime0}$',
+ & ' -Xi<SUB>b</SUB><SUP>''0</SUP>',
+ & ' $&overline{&Xi}_{&rm b}^{&star0}$',
+ & ' -Xi<SUB>b</SUB><SUP>*0</SUP>',
+ & ' $&overline{&Xi}_{&rm b}^{&prime+}$',
+ & ' -Xi<SUB>b</SUB><SUP>''+</SUP>'/
+ DATA ((TXNAME(J,I),J=1,2),I=361,368)/
+ & ' $&overline{&Xi}_{&rm b}^{&star+}$',
+ & ' -Xi<SUB>b</SUB><SUP>*+</SUP>',
+ & ' $&Omega_{&rm b}^{&star+}$',
+ & ' Omega<SUB>b</SUB><SUP>*+</SUP>',
+ & ' K$(DL)_2^+$',
+ & ' K(DL)<SUB>2</SUB><SUP>+</SUP>',
+ & ' K$(DL)_2^0$',
+ & ' K(DL)<SUB>2</SUB><SUP>0</SUP>',
+ & ' $&overline{&rm K}(DL)_2^0$',
+ & ' -K(DL)<SUB>2</SUB><SUP>0</SUP>',
+ & ' K$(DL)_2^-$',
+ & ' K(DL)<SUB>2</SUB><SUP>-</SUP>',
+ & ' K$(D)^{&star+}$',
+ & ' K(D)<SUP>*+</SUP>',
+ & ' K$(D)^{&star0}$',
+ & ' K(D)<SUP>*0</SUP>'/
+ DATA ((TXNAME(J,I),J=1,2),I=369,376)/
+ & ' $&overline{&rm K}(D)^{&star0}$',
+ & ' -K(D)<SUP>*0</SUP>',
+ & ' K$(D)^{&star-}$',
+ & ' K(D)<SUP>*-</SUP>',
+ & ' K$(DH)_2^+$',
+ & ' K(DH)<SUB>2</SUB><SUP>+</SUP>',
+ & ' K$(DH)_2^0$',
+ & ' K(DH)<SUB>2</SUB><SUP>0</SUP>',
+ & ' $&overline{&rm K}(DH)_2^0$',
+ & ' -K(DH)<SUB>2</SUB><SUP>0</SUP>',
+ & ' K$(DH)_2^-$',
+ & ' K(DH)<SUB>2</SUB><SUP>-</SUP>',
+ & ' K$(D)_3^+$',
+ & ' K(D)<SUB>3</SUB><SUP>+</SUP>',
+ & ' K$(D)_3^0$',
+ & ' K(D)<SUB>3</SUB><SUP>0</SUP>'/
+ DATA ((TXNAME(J,I),J=1,2),I=377,384)/
+ & ' $&overline{&rm K}(D)_3^0$',
+ & ' -K(D)<SUB>3</SUB><SUP>0</SUP>',
+ & ' K$(D)_3^-$',
+ & ' K(D)<SUB>3</SUB><SUP>-</SUP>',
+ & ' $&pi_2^+$',
+ & ' pi<SUB>2</SUB><SUP>+</SUP>',
+ & ' $&pi_2^0$',
+ & ' pi<SUB>2</SUB><SUP>0</SUP>',
+ & ' $&pi_2^-$',
+ & ' pi<SUB>2</SUB><SUP>-</SUP>',
+ & ' $&rho(D)^+$',
+ & ' rho(D)<SUP>+</SUP>',
+ & ' $&rho(D)^0$',
+ & ' rho(D)<SUP>0</SUP>',
+ & ' $&rho(D)^-$',
+ & ' rho(D)<SUP>-</SUP>'/
+ DATA ((TXNAME(J,I),J=1,2),I=385,392)/
+ & ' $&rho_3^+$',
+ & ' rho<SUB>3</SUB><SUP>+</SUP>',
+ & ' $&rho_3^0$',
+ & ' rho<SUB>3</SUB><SUP>0</SUP>',
+ & ' $&rho_3^-$',
+ & ' rho<SUB>3</SUB><SUP>-</SUP>',
+ & ' $&Upsilon(2S)$',
+ & ' Upsilon(2S)',
+ & ' $&chi_{&rm b0}(2P)$',
+ & ' Chi<SUB>b0</SUB>(2P)',
+ & ' $&chi_{&rm b1}(2P)$',
+ & ' Chi<SUB>b1</SUB>(2P)',
+ & ' $&chi_{&rm b2}(2P)$',
+ & ' Chi<SUB>b2</SUB>(2P)',
+ & ' $&Upsilon(3S)$',
+ & ' Upsilon(3S)'/
+ DATA ((TXNAME(J,I),J=1,2),I=393,400)/
+ & ' $&Upsilon(4S)$',
+ & ' Upsilon(4S)',
+ & ' ',
+ & ' ',
+ & ' $&omega_3$',
+ & ' omega<SUB>3</SUB>',
+ & ' $&phi_3$',
+ & ' phi<SUB>3</SUB>',
+ & ' $&eta_2(L)$',
+ & ' eta<SUB>2</SUB>(L)',
+ & ' $&eta_2(H)$',
+ & ' eta<SUB>2</SUB>(H)',
+ & ' $&omega(H)$',
+ & ' omega(H)',
+ & ' ',
+ & ' '/
+ DATA ((TXNAME(J,I),J=1,2),I=401,408)/
+ & ' $&tilde{&rm d}_{&rm L}$',
+ & ' ~d<SUB>L</SUB>',
+ & ' $&tilde{&rm u}_{&rm L}$',
+ & ' ~u<SUB>L</SUB>',
+ & ' $&tilde{&rm s}_{&rm L}$',
+ & ' ~s<SUB>L</SUB>',
+ & ' $&tilde{&rm c}_{&rm L}$',
+ & ' ~c<SUB>L</SUB>',
+ & ' $&tilde{&rm b}_1$',
+ & ' ~b<SUB>1</SUB>',
+ & ' $&tilde{&rm t}_1$',
+ & ' ~t<SUB>1</SUB>',
+ & ' $&overline{&tilde{&rm d}}_{&rm L}$',
+ & ' -~d<SUB>L</SUB>',
+ & ' $&overline{&tilde{&rm u}}_{&rm L}$',
+ & ' -~u<SUB>L</SUB>'/
+ DATA ((TXNAME(J,I),J=1,2),I=409,416)/
+ & ' $&overline{&tilde{&rm s}}_{&rm L}$',
+ & ' -~s<SUB>L</SUB>',
+ & ' $&overline{&tilde{&rm c}}_{&rm L}$',
+ & ' -~c<SUB>L</SUB>',
+ & ' $&overline{&tilde{&rm b}}_1$',
+ & ' -~b<SUB>1</SUB>',
+ & ' $&overline{&tilde{&rm t}}_1$',
+ & ' -~t<SUB>1</SUB>',
+ & ' $&tilde{&rm d}_{&rm R}$',
+ & ' ~d<SUB>R</SUB>',
+ & ' $&tilde{&rm u}_{&rm R}$',
+ & ' ~u<SUB>R</SUB>',
+ & ' $&tilde{&rm s}_{&rm R}$',
+ & ' ~s<SUB>R</SUB>',
+ & ' $&tilde{&rm c}_{&rm R}$',
+ & ' ~c<SUB>R</SUB>'/
+ DATA ((TXNAME(J,I),J=1,2),I=417,424)/
+ & ' $&tilde{&rm b}_2$',
+ & ' ~b<SUB>2</SUB>',
+ & ' $&tilde{&rm t}_2$',
+ & ' ~t<SUB>2</SUB>',
+ & ' $&overline{&tilde{&rm d}}_{&rm R}$',
+ & ' -~d<SUB>R</SUB>',
+ & ' $&overline{&tilde{&rm u}}_{&rm R}$',
+ & ' -~u<SUB>R</SUB>',
+ & ' $&overline{&tilde{&rm s}}_{&rm R}$',
+ & ' -~s<SUB>R</SUB>',
+ & ' $&overline{&tilde{&rm c}}_{&rm R}$',
+ & ' -~c<SUB>R</SUB>',
+ & ' $&overline{&tilde{&rm b}}_2$',
+ & ' -~b<SUB>2</SUB>',
+ & ' $&overline{&tilde{&rm t}}_2$',
+ & ' -~t<SUB>2</SUB>'/
+ DATA ((TXNAME(J,I),J=1,2),I=425,432)/
+ & ' $&tilde{&rm e}^-_{&rm L}$',
+ & ' ~e<SUP>-</SUP><SUB>L</SUB>',
+ & ' $&tilde{&nu}_{&rm e}$',
+ & ' ~nu<SUB>e L</SUB>',
+ & ' $&tilde{&mu}^-_{&rm L}$',
+ & ' ~mu<SUP>-</SUP><SUB>L</SUB>',
+ & ' $&tilde{&nu}_&mu$',
+ & ' ~nu<SUB>mu L</SUB>',
+ & ' $&tilde{&tau}^-_1$',
+ & ' ~tau<SUP>-</SUP><SUB>1</SUB>',
+ & ' $&tilde{&nu}_&tau$',
+ & ' ~nu<SUB>tau L</SUB>',
+ & ' $&tilde{&rm e}^+_{&rm L}$',
+ & ' ~e<SUP>+</SUP><SUB>L</SUB>',
+ & ' $&overline{&tilde{&nu}}_{&rm eL}$',
+ & ' -~nu<SUB>eL</SUB>'/
+ DATA ((TXNAME(J,I),J=1,2),I=433,440)/
+ & ' $&tilde{&mu}^+_{&rm L}$',
+ & ' ~mu<SUP>+</SUP><SUB>L</SUB>',
+ & ' $&overline{&tilde{&nu}}_{&rm&mu L}$',
+ & ' -~nu<SUB>mu L</SUB>',
+ & ' $&tilde{&tau}^+_1$',
+ & ' ~tau<SUP>+</SUP><SUB>1</SUB>',
+ & ' $&overline{&tilde{&nu}}_{&rm&tau L}$',
+ & ' -~nu<SUB>tau L</SUB>',
+ & ' $&tilde{&rm e}^-_{&rm R}$',
+ & ' ~e<SUP>-</SUP><SUB>R</SUB>',
+ & ' $&tilde{&nu}_{&rm eR}$',
+ & ' ~nu<SUB>e R</SUB>',
+ & ' $&tilde{&mu}^-_{&rm R}$',
+ & ' ~mu<SUP>-</SUP><SUB>R</SUB>',
+ & ' $&tilde{&nu}_{&mu{&rm R}}$',
+ & ' ~nu<SUB>mu R</SUB>'/
+ DATA ((TXNAME(J,I),J=1,2),I=441,448)/
+ & ' $&tilde{&tau}^-_2$',
+ & ' ~tau<SUP>-</SUP><SUB>2</SUB>',
+ & ' $&tilde{&nu}_{&tau{&rm R}}$',
+ & ' ~nu<SUB>tau R</SUB>',
+ & ' $&tilde{&rm e}^+_{&rm R}$',
+ & ' ~e<SUP>+</SUP><SUB>R</SUB>',
+ & ' $&overline{&tilde{&nu}}_{&rm eR}$',
+ & ' -~nu<SUB>e R</SUB>',
+ & ' $&tilde{&mu}^+_{&rm R}$',
+ & ' ~mu<SUP>+</SUP><SUB>R</SUB>',
+ & ' $&overline{&tilde{&nu}}_{&rm&mu R}$',
+ & ' -~nu<SUB>mu R</SUB>',
+ & ' $&tilde{&tau}^+_2$',
+ & ' ~tau<SUP>+</SUP><SUB>2</SUB>',
+ & ' $&overline{&tilde{&nu}}_{&rm&tau R}$',
+ & ' -~nu<SUB>tau R</SUB>'/
+ DATA ((TXNAME(J,I),J=1,2),I=449,456)/
+ & ' $&tilde{g}$',
+ & ' ~g',
+ & ' $&tilde{&chi}^0_1$',
+ & ' ~chi<SUP>0</SUP><SUB>1</SUB>',
+ & ' $&tilde{&chi}^0_2$',
+ & ' ~chi<SUP>0</SUP><SUB>2</SUB>',
+ & ' $&tilde{&chi}^0_3$',
+ & ' ~chi<SUP>0</SUP><SUB>3</SUB>',
+ & ' $&tilde{&chi}^0_4$',
+ & ' ~chi<SUP>0</SUP><SUB>4</SUB>',
+ & ' $&tilde{&chi}^+_1$',
+ & ' ~chi<SUP>+</SUP><SUB>1</SUB>',
+ & ' $&tilde{&chi}^+_2$',
+ & ' ~chi<SUP>+</SUP><SUB>2</SUB>',
+ & ' $&tilde{&chi}^-_1$',
+ & ' ~chi<SUP>-</SUP><SUB>1</SUB>'/
+ DATA ((TXNAME(J,I),J=1,2),I=457,NLAST)/
+ & ' $&tilde{&chi}^-_2$',
+ & ' ~chi<SUP>-</SUP><SUB>2</SUB>',
+ & ' $&tilde{G}$',
+ & ' ~G'/
+C
+ DATA (RNAME(I),I=NNEXT,NMXRES)/NLEFT*' '/
+ DATA (IDPDG(I),I=NNEXT,NMXRES)/NLEFT*0/
+ DATA (IFLAV(I),I=NNEXT,NMXRES)/NLEFT*0/
+ DATA (RMASS(I),I=NNEXT,NMXRES)/NLEFT*0.0000/
+ DATA (RLTIM(I),I=NNEXT,NMXRES)/NLEFT*0.000D+00/
+ DATA (RSPIN(I),I=NNEXT,NMXRES)/NLEFT*0.0/
+ DATA (TXNAME(1,I),I=NNEXT,NMXRES)/
+ & NLEFT*' '/
+ DATA (TXNAME(2,I),I=NNEXT,NMXRES)/
+ & NLEFT*' '/
+C
+ DATA (RSTAB(I),I=1,NMXRES)/NMXRES*.FALSE./
+ DATA DKPSET/.FALSE./
+C
+ DATA NDKYS/2263/
+ DATA (IDK(I),BRFRAC(I),NME(I),(IDKPRD(J,I),J=1,5),I= 1, 19)/
+ & 6,0.334,100, 2, 7, 5, 0, 0,
+ & 6,0.333,100, 4, 9, 5, 0, 0,
+ & 6,0.111,100,122,127, 5, 0, 0,
+ & 6,0.111,100,124,129, 5, 0, 0,
+ & 6,0.111,100,126,131, 5, 0, 0,
+ & 12,0.334,100, 8, 1, 11, 0, 0,
+ & 12,0.333,100, 10, 3, 11, 0, 0,
+ & 12,0.111,100,128,121, 11, 0, 0,
+ & 12,0.111,100,130,123, 11, 0, 0,
+ & 12,0.111,100,132,125, 11, 0, 0,
+ & 21,0.988, 0, 59, 59, 0, 0, 0,
+ & 21,0.012, 0,127,121, 59, 0, 0,
+ & 22,0.388, 0, 59, 59, 0, 0, 0,
+ & 22,0.319, 0, 21, 21, 21, 0, 0,
+ & 22,0.001, 0, 21, 59, 59, 0, 0,
+ & 22,0.236, 0, 38, 30, 21, 0, 0,
+ & 22,0.049, 0, 38, 30, 59, 0, 0,
+ & 22,0.005, 0,127,121, 59, 0, 0,
+ & 22,0.002, 0, 38, 30,127,121, 0/
+ DATA (IDK(I),BRFRAC(I),NME(I),(IDKPRD(J,I),J=1,5),I= 20, 38)/
+ & 23,0.989, 0, 38, 30, 0, 0, 0,
+ & 23,0.010, 0, 38, 30, 59, 0, 0,
+ & 23,0.001, 0, 21, 59, 0, 0, 0,
+ & 24,0.888, 0, 38, 30, 21, 0, 0,
+ & 24,0.085, 0, 21, 59, 0, 0, 0,
+ & 24,0.022, 0, 38, 30, 0, 0, 0,
+ & 24,0.001, 0, 22, 59, 0, 0, 0,
+ & 24,0.001, 0, 21,127,121, 0, 0,
+ & 24,0.003, 0, 38, 30, 21, 21, 0,
+ & 25,0.437, 0, 38, 30, 22, 0, 0,
+ & 25,0.302, 0, 23, 59, 0, 0, 0,
+ & 25,0.208, 0, 21, 21, 22, 0, 0,
+ & 25,0.030, 0, 24, 59, 0, 0, 0,
+ & 25,0.021, 0, 59, 59, 0, 0, 0,
+ & 25,0.002, 0, 21, 21, 21, 0, 0,
+ & 26,0.566, 0, 38, 30, 0, 0, 0,
+ & 26,0.283, 0, 21, 21, 0, 0, 0,
+ & 26,0.069, 0, 38, 30, 21, 21, 0,
+ & 26,0.023, 0, 46, 34, 0, 0, 0/
+ DATA (IDK(I),BRFRAC(I),NME(I),(IDKPRD(J,I),J=1,5),I= 39, 57)/
+ & 26,0.023, 0, 50, 42, 0, 0, 0,
+ & 26,0.028, 0, 38, 38, 30, 30, 0,
+ & 26,0.005, 0, 22, 22, 0, 0, 0,
+ & 26,0.003, 0, 21, 21, 21, 21, 0,
+ & 27,0.499, 0, 39, 30, 0, 0, 0,
+ & 27,0.499, 0, 31, 38, 0, 0, 0,
+ & 27,0.002, 0, 21, 59, 59, 0, 0,
+ & 28,0.148, 0, 21, 21, 38, 30, 0,
+ & 28,0.148, 0, 23, 38, 30, 0, 0,
+ & 28,0.147, 0,291, 30, 0, 0, 0,
+ & 28,0.147, 0,290, 21, 0, 0, 0,
+ & 28,0.147, 0,292, 38, 0, 0, 0,
+ & 28,0.067, 0, 22, 38, 30, 0, 0,
+ & 28,0.033, 0, 22, 21, 21, 0, 0,
+ & 28,0.032, 0, 46, 42, 30, 0, 0,
+ & 28,0.016, 0, 46, 34, 21, 0, 0,
+ & 28,0.016, 0, 50, 42, 21, 0, 0,
+ & 28,0.032, 0, 50, 34, 38, 0, 0,
+ & 28,0.066, 0, 59, 23, 0, 0, 0/
+ DATA (IDK(I),BRFRAC(I),NME(I),(IDKPRD(J,I),J=1,5),I= 58, 76)/
+ & 28,0.001, 0, 56, 59, 0, 0, 0,
+ & 29,0.349, 0, 39, 30, 0, 0, 0,
+ & 29,0.349, 0, 31, 38, 0, 0, 0,
+ & 29,0.144, 0, 22, 21, 0, 0, 0,
+ & 29,0.104, 0, 24, 38, 30, 0, 0,
+ & 29,0.024, 0, 46, 34, 0, 0, 0,
+ & 29,0.024, 0, 50, 42, 0, 0, 0,
+ & 29,0.006, 0, 25, 21, 0, 0, 0,
+ & 30,1.000, 0,123,130, 0, 0, 0,
+ & 31,1.000, 0, 30, 21, 0, 0, 0,
+ & 32,0.499, 0, 31, 21, 0, 0, 0,
+ & 32,0.499, 0, 23, 30, 0, 0, 0,
+ & 32,0.002, 0, 30, 59, 0, 0, 0,
+ & 33,0.349, 0, 31, 21, 0, 0, 0,
+ & 33,0.349, 0, 23, 30, 0, 0, 0,
+ & 33,0.144, 0, 22, 30, 0, 0, 0,
+ & 33,0.101, 0, 24, 30, 21, 0, 0,
+ & 33,0.048, 0, 50, 34, 0, 0, 0,
+ & 33,0.006, 0, 25, 30, 0, 0, 0/
+ DATA (IDK(I),BRFRAC(I),NME(I),(IDKPRD(J,I),J=1,5),I= 77, 95)/
+ & 33,0.003, 0, 30, 59, 0, 0, 0,
+ & 34,0.629, 0,123,130, 0, 0, 0,
+ & 34,0.212, 0, 30, 21, 0, 0, 0,
+ & 34,0.056, 0, 30, 38, 30, 0, 0,
+ & 34,0.017, 0, 30, 21, 21, 0, 0,
+ & 34,0.048,101,121,128, 21, 0, 0,
+ & 34,0.032,101,123,130, 21, 0, 0,
+ & 34,0.006, 0,123,130, 59, 0, 0,
+ & 35,0.666, 0, 42, 30, 0, 0, 0,
+ & 35,0.333, 0, 34, 21, 0, 0, 0,
+ & 35,0.001, 0, 34, 59, 0, 0, 0,
+ & 36,0.627, 0, 43, 30, 0, 0, 0,
+ & 36,0.313, 0, 35, 21, 0, 0, 0,
+ & 36,0.020, 0, 42, 31, 0, 0, 0,
+ & 36,0.010, 0, 34, 23, 0, 0, 0,
+ & 36,0.020, 0, 34,294, 0, 0, 0,
+ & 36,0.010, 0, 34, 24, 0, 0, 0,
+ & 37,0.331, 0, 42, 30, 0, 0, 0,
+ & 37,0.166, 0, 34, 21, 0, 0, 0/
+ DATA (IDK(I),BRFRAC(I),NME(I),(IDKPRD(J,I),J=1,5),I= 96, 114)/
+ & 37,0.168, 0, 43, 30, 0, 0, 0,
+ & 37,0.084, 0, 35, 21, 0, 0, 0,
+ & 37,0.087, 0, 35, 38, 30, 0, 0,
+ & 37,0.044, 0, 35, 21, 21, 0, 0,
+ & 37,0.059, 0, 42, 31, 0, 0, 0,
+ & 37,0.029, 0, 34, 23, 0, 0, 0,
+ & 37,0.029, 0, 34, 24, 0, 0, 0,
+ & 37,0.002, 0, 34, 59, 0, 0, 0,
+ & 37,0.001, 0, 34, 22, 0, 0, 0,
+ & 38,1.000, 0,129,124, 0, 0, 0,
+ & 39,1.000, 0, 38, 21, 0, 0, 0,
+ & 40,0.499, 0, 39, 21, 0, 0, 0,
+ & 40,0.499, 0, 23, 38, 0, 0, 0,
+ & 40,0.002, 0, 38, 59, 0, 0, 0,
+ & 41,0.349, 0, 39, 21, 0, 0, 0,
+ & 41,0.349, 0, 23, 38, 0, 0, 0,
+ & 41,0.144, 0, 22, 38, 0, 0, 0,
+ & 41,0.101, 0, 24, 38, 21, 0, 0,
+ & 41,0.048, 0, 46, 42, 0, 0, 0/
+ DATA (IDK(I),BRFRAC(I),NME(I),(IDKPRD(J,I),J=1,5),I= 115, 133)/
+ & 41,0.006, 0, 25, 38, 0, 0, 0,
+ & 41,0.003, 0, 38, 59, 0, 0, 0,
+ & 42,0.500, 0, 60, 0, 0, 0, 0,
+ & 42,0.500, 0, 61, 0, 0, 0, 0,
+ & 43,0.665, 0, 34, 38, 0, 0, 0,
+ & 43,0.333, 0, 42, 21, 0, 0, 0,
+ & 43,0.002, 0, 42, 59, 0, 0, 0,
+ & 44,0.627, 0, 35, 38, 0, 0, 0,
+ & 44,0.313, 0, 43, 21, 0, 0, 0,
+ & 44,0.020, 0, 34, 39, 0, 0, 0,
+ & 44,0.010, 0, 42, 23, 0, 0, 0,
+ & 44,0.020, 0, 42,294, 0, 0, 0,
+ & 44,0.010, 0, 42, 24, 0, 0, 0,
+ & 45,0.331, 0, 34, 38, 0, 0, 0,
+ & 45,0.166, 0, 42, 21, 0, 0, 0,
+ & 45,0.168, 0, 35, 38, 0, 0, 0,
+ & 45,0.084, 0, 43, 21, 0, 0, 0,
+ & 45,0.089, 0, 42, 38, 30, 0, 0,
+ & 45,0.044, 0, 42, 21, 21, 0, 0/
+ DATA (IDK(I),BRFRAC(I),NME(I),(IDKPRD(J,I),J=1,5),I= 134, 152)/
+ & 45,0.059, 0, 34, 39, 0, 0, 0,
+ & 45,0.029, 0, 42, 23, 0, 0, 0,
+ & 45,0.029, 0, 42, 24, 0, 0, 0,
+ & 45,0.001, 0, 42, 22, 0, 0, 0,
+ & 46,0.629, 0,129,124, 0, 0, 0,
+ & 46,0.212, 0, 38, 21, 0, 0, 0,
+ & 46,0.056, 0, 38, 38, 30, 0, 0,
+ & 46,0.017, 0, 38, 21, 21, 0, 0,
+ & 46,0.032,101,129,124, 21, 0, 0,
+ & 46,0.048,101,127,122, 21, 0, 0,
+ & 46,0.006, 0,129,124, 59, 0, 0,
+ & 47,0.666, 0, 50, 38, 0, 0, 0,
+ & 47,0.333, 0, 46, 21, 0, 0, 0,
+ & 47,0.001, 0, 46, 59, 0, 0, 0,
+ & 48,0.627, 0, 51, 38, 0, 0, 0,
+ & 48,0.313, 0, 47, 21, 0, 0, 0,
+ & 48,0.020, 0, 50, 39, 0, 0, 0,
+ & 48,0.010, 0, 46, 23, 0, 0, 0,
+ & 48,0.020, 0, 46,294, 0, 0, 0/
+ DATA (IDK(I),BRFRAC(I),NME(I),(IDKPRD(J,I),J=1,5),I= 153, 171)/
+ & 48,0.010, 0, 46, 24, 0, 0, 0,
+ & 49,0.331, 0, 50, 38, 0, 0, 0,
+ & 49,0.166, 0, 46, 21, 0, 0, 0,
+ & 49,0.168, 0, 51, 38, 0, 0, 0,
+ & 49,0.084, 0, 47, 21, 0, 0, 0,
+ & 49,0.087, 0, 47, 38, 30, 0, 0,
+ & 49,0.044, 0, 47, 21, 21, 0, 0,
+ & 49,0.059, 0, 50, 39, 0, 0, 0,
+ & 49,0.029, 0, 46, 23, 0, 0, 0,
+ & 49,0.029, 0, 46, 24, 0, 0, 0,
+ & 49,0.002, 0, 46, 59, 0, 0, 0,
+ & 49,0.001, 0, 46, 22, 0, 0, 0,
+ & 50,0.500, 0, 60, 0, 0, 0, 0,
+ & 50,0.500, 0, 61, 0, 0, 0, 0,
+ & 51,0.665, 0, 46, 30, 0, 0, 0,
+ & 51,0.333, 0, 50, 21, 0, 0, 0,
+ & 51,0.002, 0, 50, 59, 0, 0, 0,
+ & 52,0.627, 0, 47, 30, 0, 0, 0,
+ & 52,0.313, 0, 51, 21, 0, 0, 0/
+ DATA (IDK(I),BRFRAC(I),NME(I),(IDKPRD(J,I),J=1,5),I= 172, 190)/
+ & 52,0.020, 0, 46, 31, 0, 0, 0,
+ & 52,0.010, 0, 50, 23, 0, 0, 0,
+ & 52,0.020, 0, 50,294, 0, 0, 0,
+ & 52,0.010, 0, 50, 24, 0, 0, 0,
+ & 53,0.331, 0, 46, 30, 0, 0, 0,
+ & 53,0.166, 0, 50, 21, 0, 0, 0,
+ & 53,0.168, 0, 47, 30, 0, 0, 0,
+ & 53,0.084, 0, 51, 21, 0, 0, 0,
+ & 53,0.089, 0, 50, 38, 30, 0, 0,
+ & 53,0.044, 0, 50, 21, 21, 0, 0,
+ & 53,0.059, 0, 46, 31, 0, 0, 0,
+ & 53,0.029, 0, 50, 23, 0, 0, 0,
+ & 53,0.029, 0, 50, 24, 0, 0, 0,
+ & 53,0.001, 0, 50, 22, 0, 0, 0,
+ & 56,0.490, 0, 46, 34, 0, 0, 0,
+ & 56,0.342, 0, 61, 60, 0, 0, 0,
+ & 56,0.043, 0, 39, 30, 0, 0, 0,
+ & 56,0.043, 0, 23, 21, 0, 0, 0,
+ & 56,0.043, 0, 31, 38, 0, 0, 0/
+ DATA (IDK(I),BRFRAC(I),NME(I),(IDKPRD(J,I),J=1,5),I= 191, 209)/
+ & 56,0.025, 0, 38, 30, 21, 0, 0,
+ & 56,0.013, 0, 22, 59, 0, 0, 0,
+ & 56,0.001, 0, 21, 59, 0, 0, 0,
+ & 57,0.250, 0, 50, 43, 0, 0, 0,
+ & 57,0.250, 0, 34, 47, 0, 0, 0,
+ & 57,0.250, 0, 42, 51, 0, 0, 0,
+ & 57,0.250, 0, 46, 35, 0, 0, 0,
+ & 58,0.356, 0, 46, 34, 0, 0, 0,
+ & 58,0.356, 0, 50, 42, 0, 0, 0,
+ & 58,0.279, 0, 22, 22, 0, 0, 0,
+ & 58,0.006, 0, 38, 30, 0, 0, 0,
+ & 58,0.003, 0, 21, 21, 0, 0, 0,
+ & 60,0.684, 0, 38, 30, 0, 0, 0,
+ & 60,0.314, 0, 21, 21, 0, 0, 0,
+ & 60,0.002, 0, 38, 30, 59, 0, 0,
+ & 61,0.216, 0, 21, 21, 21, 0, 0,
+ & 61,0.124, 0, 38, 30, 21, 0, 0,
+ & 61,0.135,101,123,130, 38, 0, 0,
+ & 61,0.135,101,124,129, 30, 0, 0/
+ DATA (IDK(I),BRFRAC(I),NME(I),(IDKPRD(J,I),J=1,5),I= 210, 228)/
+ & 61,0.187,101,121,128, 38, 0, 0,
+ & 61,0.187,101,122,127, 30, 0, 0,
+ & 61,0.006, 0,121,128, 38, 59, 0,
+ & 61,0.006, 0,122,127, 30, 59, 0,
+ & 61,0.002, 0, 38, 30, 0, 0, 0,
+ & 61,0.001, 0, 21, 21, 0, 0, 0,
+ & 61,0.001, 0, 59, 59, 0, 0, 0,
+ & 74,0.663, 0, 73, 21, 0, 0, 0,
+ & 74,0.331, 0, 75, 38, 0, 0, 0,
+ & 74,0.006, 0, 73, 59, 0, 0, 0,
+ & 75,1.000,101,121,128, 73, 0, 0,
+ & 76,0.663, 0, 75, 21, 0, 0, 0,
+ & 76,0.331, 0, 73, 30, 0, 0, 0,
+ & 76,0.006, 0, 75, 59, 0, 0, 0,
+ & 77,1.000, 0, 75, 30, 0, 0, 0,
+ & 78,0.638, 0, 73, 30, 0, 0, 0,
+ & 78,0.358, 0, 75, 21, 0, 0, 0,
+ & 78,0.002, 0, 75, 59, 0, 0, 0,
+ & 78,0.001, 0, 73, 30, 59, 0, 0/
+ DATA (IDK(I),BRFRAC(I),NME(I),(IDKPRD(J,I),J=1,5),I= 229, 247)/
+ & 78,0.001,101,121,128, 73, 0, 0,
+ & 79,0.995, 0, 78, 59, 0, 0, 0,
+ & 79,0.005, 0, 78,127,121, 0, 0,
+ & 80,0.880, 0, 78, 21, 0, 0, 0,
+ & 80,0.060, 0, 86, 30, 0, 0, 0,
+ & 80,0.060, 0, 81, 38, 0, 0, 0,
+ & 81,0.998, 0, 75, 30, 0, 0, 0,
+ & 81,0.001, 0, 75, 30, 59, 0, 0,
+ & 81,0.001,101,121,128, 75, 0, 0,
+ & 82,0.880, 0, 78, 30, 0, 0, 0,
+ & 82,0.060, 0, 79, 30, 0, 0, 0,
+ & 82,0.060, 0, 81, 21, 0, 0, 0,
+ & 83,0.999, 0, 78, 30, 0, 0, 0,
+ & 83,0.001,101,121,128, 78, 0, 0,
+ & 84,0.667, 0, 88, 30, 0, 0, 0,
+ & 84,0.333, 0, 83, 21, 0, 0, 0,
+ & 85,1.000, 0, 73, 38, 0, 0, 0,
+ & 86,0.516, 0, 73, 21, 0, 0, 0,
+ & 86,0.483, 0, 75, 38, 0, 0, 0/
+ DATA (IDK(I),BRFRAC(I),NME(I),(IDKPRD(J,I),J=1,5),I= 248, 266)/
+ & 86,0.001, 0, 73, 59, 0, 0, 0,
+ & 87,0.880, 0, 78, 38, 0, 0, 0,
+ & 87,0.060, 0, 86, 21, 0, 0, 0,
+ & 87,0.060, 0, 79, 38, 0, 0, 0,
+ & 88,0.995, 0, 78, 21, 0, 0, 0,
+ & 88,0.001, 0, 78, 59, 0, 0, 0,
+ & 88,0.004, 0, 79, 59, 0, 0, 0,
+ & 89,0.667, 0, 83, 38, 0, 0, 0,
+ & 89,0.333, 0, 88, 21, 0, 0, 0,
+ & 90,0.675, 0, 78, 34, 0, 0, 0,
+ & 90,0.233, 0, 88, 30, 0, 0, 0,
+ & 90,0.086, 0, 83, 21, 0, 0, 0,
+ & 90,0.006,101,121,128, 88, 0, 0,
+ & 92,0.663, 0, 91, 21, 0, 0, 0,
+ & 92,0.331, 0, 93, 30, 0, 0, 0,
+ & 92,0.006, 0, 91, 59, 0, 0, 0,
+ & 93,1.000,101,127,122, 91, 0, 0,
+ & 94,0.663, 0, 93, 21, 0, 0, 0,
+ & 94,0.331, 0, 91, 38, 0, 0, 0/
+ DATA (IDK(I),BRFRAC(I),NME(I),(IDKPRD(J,I),J=1,5),I= 267, 285)/
+ & 94,0.006, 0, 93, 59, 0, 0, 0,
+ & 95,1.000, 0, 93, 38, 0, 0, 0,
+ & 96,0.638, 0, 91, 38, 0, 0, 0,
+ & 96,0.358, 0, 93, 21, 0, 0, 0,
+ & 96,0.002, 0, 93, 59, 0, 0, 0,
+ & 96,0.001, 0, 91, 38, 59, 0, 0,
+ & 96,0.001,101,127,122, 91, 0, 0,
+ & 97,0.995, 0, 96, 59, 0, 0, 0,
+ & 97,0.005, 0, 96,127,121, 0, 0,
+ & 98,0.880, 0, 96, 21, 0, 0, 0,
+ & 98,0.060, 0,104, 38, 0, 0, 0,
+ & 98,0.060, 0, 99, 30, 0, 0, 0,
+ & 99,0.998, 0, 93, 38, 0, 0, 0,
+ & 99,0.001, 0, 93, 38, 59, 0, 0,
+ & 99,0.001,101,127,122, 93, 0, 0,
+ & 100,0.880, 0, 96, 38, 0, 0, 0,
+ & 100,0.060, 0, 97, 38, 0, 0, 0,
+ & 100,0.060, 0, 99, 21, 0, 0, 0,
+ & 101,0.999, 0, 96, 38, 0, 0, 0/
+ DATA (IDK(I),BRFRAC(I),NME(I),(IDKPRD(J,I),J=1,5),I= 286, 304)/
+ & 101,0.001,101,127,122, 96, 0, 0,
+ & 102,0.667, 0,106, 38, 0, 0, 0,
+ & 102,0.333, 0,101, 21, 0, 0, 0,
+ & 103,1.000, 0, 91, 30, 0, 0, 0,
+ & 104,0.516, 0, 91, 21, 0, 0, 0,
+ & 104,0.483, 0, 93, 30, 0, 0, 0,
+ & 104,0.001, 0, 91, 59, 0, 0, 0,
+ & 105,0.880, 0, 96, 30, 0, 0, 0,
+ & 105,0.060, 0,104, 21, 0, 0, 0,
+ & 105,0.060, 0, 97, 30, 0, 0, 0,
+ & 106,0.995, 0, 96, 21, 0, 0, 0,
+ & 106,0.001, 0, 96, 59, 0, 0, 0,
+ & 106,0.004, 0, 97, 59, 0, 0, 0,
+ & 107,0.667, 0,101, 30, 0, 0, 0,
+ & 107,0.333, 0,106, 21, 0, 0, 0,
+ & 108,0.675, 0, 96, 46, 0, 0, 0,
+ & 108,0.233, 0,106, 38, 0, 0, 0,
+ & 108,0.086, 0,101, 21, 0, 0, 0,
+ & 108,0.006,101,127,122,106, 0, 0/
+ DATA (IDK(I),BRFRAC(I),NME(I),(IDKPRD(J,I),J=1,5),I= 305, 323)/
+ & 123,0.986,100,121,128,124, 0, 0,
+ & 123,0.014, 0,121,128,124, 59, 0,
+ & 125,0.178,100,121,128,126, 0, 0,
+ & 125,0.171,100,123,130,126, 0, 0,
+ & 125,0.002, 0,123,130, 59,126, 0,
+ & 125,0.111, 0, 30,126, 0, 0, 0,
+ & 125,0.253, 0, 31,126, 0, 0, 0,
+ & 125,0.181, 0, 32,126, 0, 0, 0,
+ & 125,0.002, 0, 30, 22, 21,126, 0,
+ & 125,0.018, 0, 30, 24,126, 0, 0,
+ & 125,0.004, 0, 30, 24, 21,126, 0,
+ & 125,0.015, 0, 31, 23,126, 0, 0,
+ & 125,0.001, 0, 31, 24, 21,126, 0,
+ & 125,0.024, 0, 32, 21,126, 0, 0,
+ & 125,0.002, 0, 32, 38, 30,126, 0,
+ & 125,0.007, 0, 34,126, 0, 0, 0,
+ & 125,0.014, 0, 35,126, 0, 0, 0,
+ & 125,0.003, 0, 35, 21,126, 0, 0,
+ & 125,0.001, 0, 34, 38, 30,126, 0/
+ DATA (IDK(I),BRFRAC(I),NME(I),(IDKPRD(J,I),J=1,5),I= 324, 342)/
+ & 125,0.004, 0, 30, 43,126, 0, 0,
+ & 125,0.003, 0, 34, 50,126, 0, 0,
+ & 125,0.003, 0, 34, 51,126, 0, 0,
+ & 125,0.003, 0, 30, 50, 42,126, 0,
+ & 129,0.986,100,127,122,130, 0, 0,
+ & 129,0.014, 0,127,122,130, 59, 0,
+ & 131,0.178,100,127,122,132, 0, 0,
+ & 131,0.171,100,129,124,132, 0, 0,
+ & 131,0.002, 0,129,124, 59,132, 0,
+ & 131,0.111, 0, 38,132, 0, 0, 0,
+ & 131,0.253, 0, 39,132, 0, 0, 0,
+ & 131,0.181, 0, 40,132, 0, 0, 0,
+ & 131,0.002, 0, 38, 22, 21,132, 0,
+ & 131,0.018, 0, 38, 24,132, 0, 0,
+ & 131,0.004, 0, 38, 24, 21,132, 0,
+ & 131,0.015, 0, 39, 23,132, 0, 0,
+ & 131,0.001, 0, 39, 24, 21,132, 0,
+ & 131,0.024, 0, 40, 21,132, 0, 0,
+ & 131,0.002, 0, 40, 38, 30,132, 0/
+ DATA (IDK(I),BRFRAC(I),NME(I),(IDKPRD(J,I),J=1,5),I= 343, 361)/
+ & 131,0.007, 0, 46,132, 0, 0, 0,
+ & 131,0.014, 0, 47,132, 0, 0, 0,
+ & 131,0.003, 0, 47, 21,132, 0, 0,
+ & 131,0.001, 0, 46, 38, 30,132, 0,
+ & 131,0.004, 0, 38, 51,132, 0, 0,
+ & 131,0.003, 0, 46, 42,132, 0, 0,
+ & 131,0.003, 0, 46, 43,132, 0, 0,
+ & 131,0.003, 0, 38, 50, 42,132, 0,
+ & 136,0.067,101,122,127, 42, 0, 0,
+ & 136,0.067,101,124,129, 42, 0, 0,
+ & 136,0.048,101,122,127, 43, 0, 0,
+ & 136,0.048,101,124,129, 43, 0, 0,
+ & 136,0.003, 0, 34, 38,122,127, 0,
+ & 136,0.003, 0, 34, 38,124,129, 0,
+ & 136,0.006,101,122,127, 21, 0, 0,
+ & 136,0.006,101,124,129, 21, 0, 0,
+ & 136,0.002,101,122,127, 23, 0, 0,
+ & 136,0.002,101,124,129, 23, 0, 0,
+ & 136,0.055, 0, 34, 38, 38, 0, 0/
+ DATA (IDK(I),BRFRAC(I),NME(I),(IDKPRD(J,I),J=1,5),I= 362, 380)/
+ & 136,0.031, 0, 34, 39, 38, 0, 0,
+ & 136,0.042, 0, 34, 38, 38, 21, 21,
+ & 136,0.002, 0, 34, 38, 38, 38, 31,
+ & 136,0.021, 0, 35, 38, 38, 0, 0,
+ & 136,0.027, 0, 42, 38, 0, 0, 0,
+ & 136,0.066, 0, 42, 39, 0, 0, 0,
+ & 136,0.081, 0, 42, 40, 0, 0, 0,
+ & 136,0.024, 0, 42, 38, 21, 0, 0,
+ & 136,0.004, 0, 42, 38, 23, 0, 0,
+ & 136,0.069, 0, 42, 38, 38, 30, 21,
+ & 136,0.001, 0, 42, 38, 38, 30, 23,
+ & 136,0.022, 0, 43, 38, 0, 0, 0,
+ & 136,0.021, 0, 43, 39, 0, 0, 0,
+ & 136,0.042, 0, 43, 38, 21, 0, 0,
+ & 136,0.008, 0, 43, 38, 23, 0, 0,
+ & 136,0.010, 0, 43, 38, 38, 30, 0,
+ & 136,0.050, 0,311, 38, 0, 0, 0,
+ & 136,0.034, 0,329, 38, 0, 0, 0,
+ & 136,0.010, 0,369, 38, 0, 0, 0/
+ DATA (IDK(I),BRFRAC(I),NME(I),(IDKPRD(J,I),J=1,5),I= 381, 399)/
+ & 136,0.031, 0, 46, 42, 42, 0, 0,
+ & 136,0.003, 0, 38, 21, 0, 0, 0,
+ & 136,0.001, 0, 38, 23, 0, 0, 0,
+ & 136,0.002, 0, 38, 38, 30, 0, 0,
+ & 136,0.008, 0, 38, 22, 0, 0, 0,
+ & 136,0.001, 0, 38, 38, 38, 30, 30,
+ & 136,0.003, 0, 38, 38, 38, 30, 31,
+ & 136,0.008, 0, 46, 42, 0, 0, 0,
+ & 136,0.005, 0, 46, 43, 0, 0, 0,
+ & 136,0.026, 0, 47, 43, 0, 0, 0,
+ & 136,0.005, 0, 46, 34, 38, 0, 0,
+ & 136,0.007, 0, 38, 56, 0, 0, 0,
+ & 136,0.023, 0, 38, 56, 21, 0, 0,
+ & 136,0.005, 0, 46, 46, 34, 0, 0,
+ & 137,0.683, 0,140, 38, 0, 0, 0,
+ & 137,0.306, 0,136, 21, 0, 0, 0,
+ & 137,0.011, 0,136, 59, 0, 0, 0,
+ & 138,0.667, 0,141, 38, 0, 0, 0,
+ & 138,0.333, 0,137, 21, 0, 0, 0/
+ DATA (IDK(I),BRFRAC(I),NME(I),(IDKPRD(J,I),J=1,5),I= 400, 418)/
+ & 139,0.220, 0,140, 38, 0, 0, 0,
+ & 139,0.110, 0,136, 21, 0, 0, 0,
+ & 139,0.380, 0,141, 38, 0, 0, 0,
+ & 139,0.190, 0,137, 21, 0, 0, 0,
+ & 139,0.004, 0,136, 22, 0, 0, 0,
+ & 139,0.064, 0,141, 38, 21, 0, 0,
+ & 139,0.032, 0,137, 38, 30, 0, 0,
+ & 140,0.037,101,122,127, 34, 0, 0,
+ & 140,0.037,101,124,129, 34, 0, 0,
+ & 140,0.016,101,122,127, 35, 0, 0,
+ & 140,0.016,101,124,129, 35, 0, 0,
+ & 140,0.013, 0, 34, 21,122,127, 0,
+ & 140,0.013, 0, 34, 21,124,129, 0,
+ & 140,0.012, 0, 42, 30,122,127, 0,
+ & 140,0.012, 0, 42, 30,124,129, 0,
+ & 140,0.003,101,122,127, 30, 0, 0,
+ & 140,0.003,101,124,129, 30, 0, 0,
+ & 140,0.039, 0, 34, 38, 0, 0, 0,
+ & 140,0.091, 0, 34, 39, 0, 0, 0/
+ DATA (IDK(I),BRFRAC(I),NME(I),(IDKPRD(J,I),J=1,5),I= 419, 437)/
+ & 140,0.067, 0, 34, 40, 0, 0, 0,
+ & 140,0.004, 0, 34, 38, 21, 0, 0,
+ & 140,0.100, 0, 34, 38, 21, 21, 0,
+ & 140,0.058, 0, 34, 38, 23, 0, 0,
+ & 140,0.020, 0, 34, 38, 24, 0, 0,
+ & 140,0.006, 0, 34, 38, 25, 0, 0,
+ & 140,0.043, 0, 35, 38, 0, 0, 0,
+ & 140,0.035, 0, 35, 39, 0, 0, 0,
+ & 140,0.007, 0,312, 38, 0, 0, 0,
+ & 140,0.007, 0,330, 38, 0, 0, 0,
+ & 140,0.020, 0, 42, 21, 0, 0, 0,
+ & 140,0.006, 0, 42, 22, 0, 0, 0,
+ & 140,0.009, 0, 42, 23, 0, 0, 0,
+ & 140,0.016, 0, 42, 24, 0, 0, 0,
+ & 140,0.014, 0, 42, 25, 0, 0, 0,
+ & 140,0.003, 0, 42,293, 0, 0, 0,
+ & 140,0.007, 0, 42, 56, 0, 0, 0,
+ & 140,0.003, 0, 42, 26, 0, 0, 0,
+ & 140,0.004, 0, 42,294, 0, 0, 0/
+ DATA (IDK(I),BRFRAC(I),NME(I),(IDKPRD(J,I),J=1,5),I= 438, 456)/
+ & 140,0.006, 0, 42, 21, 21, 0, 0,
+ & 140,0.042, 0, 42, 38, 30, 21, 0,
+ & 140,0.004, 0, 42, 38, 38, 30, 30,
+ & 140,0.076, 0, 42, 38, 30, 21, 21,
+ & 140,0.026, 0, 43, 21, 0, 0, 0,
+ & 140,0.014, 0, 43, 22, 0, 0, 0,
+ & 140,0.014, 0, 43, 23, 0, 0, 0,
+ & 140,0.011, 0, 43, 24, 0, 0, 0,
+ & 140,0.018, 0, 43, 38, 30, 0, 0,
+ & 140,0.004, 0, 42, 46, 34, 0, 0,
+ & 140,0.004, 0, 42, 46, 34, 21, 0,
+ & 140,0.005, 0, 42, 42, 50, 0, 0,
+ & 140,0.002, 0, 38, 30, 0, 0, 0,
+ & 140,0.001, 0, 21, 21, 0, 0, 0,
+ & 140,0.008, 0, 38, 30, 21, 0, 0,
+ & 140,0.007, 0, 38, 38, 30, 30, 0,
+ & 140,0.015, 0, 38, 38, 30, 30, 21,
+ & 140,0.004, 0, 46, 34, 0, 0, 0,
+ & 140,0.003, 0, 47, 34, 0, 0, 0/
+ DATA (IDK(I),BRFRAC(I),NME(I),(IDKPRD(J,I),J=1,5),I= 457, 475)/
+ & 140,0.002, 0, 46, 35, 0, 0, 0,
+ & 140,0.001, 0, 50, 42, 0, 0, 0,
+ & 140,0.002, 0, 51, 43, 0, 0, 0,
+ & 140,0.003, 0, 50, 34, 38, 0, 0,
+ & 140,0.003, 0, 42, 46, 30, 0, 0,
+ & 140,0.001, 0, 46, 34, 38, 30, 21,
+ & 140,0.002, 0, 56, 23, 0, 0, 0,
+ & 140,0.001, 0, 56, 38, 30, 0, 0,
+ & 141,0.636, 0,140, 21, 0, 0, 0,
+ & 141,0.364, 0,140, 59, 0, 0, 0,
+ & 142,0.667, 0,137, 30, 0, 0, 0,
+ & 142,0.333, 0,141, 21, 0, 0, 0,
+ & 143,0.220, 0,136, 30, 0, 0, 0,
+ & 143,0.110, 0,140, 21, 0, 0, 0,
+ & 143,0.380, 0,137, 30, 0, 0, 0,
+ & 143,0.190, 0,141, 21, 0, 0, 0,
+ & 143,0.004, 0,140, 22, 0, 0, 0,
+ & 143,0.064, 0,137, 30, 21, 0, 0,
+ & 143,0.032, 0,141, 38, 30, 0, 0/
+ DATA (IDK(I),BRFRAC(I),NME(I),(IDKPRD(J,I),J=1,5),I= 476, 494)/
+ & 144,0.009, 0,124,129, 0, 0, 0,
+ & 144,0.019,101,122,127, 56, 0, 0,
+ & 144,0.019,101,124,129, 56, 0, 0,
+ & 144,0.025,101,122,127, 22, 0, 0,
+ & 144,0.025,101,124,129, 22, 0, 0,
+ & 144,0.009,101,122,127, 25, 0, 0,
+ & 144,0.009,101,124,129, 25, 0, 0,
+ & 144,0.036, 0, 46, 42, 0, 0, 0,
+ & 144,0.034, 0, 46, 43, 0, 0, 0,
+ & 144,0.007, 0, 46,329, 0, 0, 0,
+ & 144,0.043, 0, 47, 42, 0, 0, 0,
+ & 144,0.058, 0, 47, 43, 0, 0, 0,
+ & 144,0.011, 0, 46, 34, 38, 0, 0,
+ & 144,0.055, 0, 46, 34, 38, 21, 0,
+ & 144,0.003, 0, 46, 34, 38, 38, 30,
+ & 144,0.014, 0, 46, 42, 38, 30, 0,
+ & 144,0.017, 0, 50, 34, 38, 38, 0,
+ & 144,0.036, 0, 56, 38, 0, 0, 0,
+ & 144,0.067, 0, 56, 39, 0, 0, 0/
+ DATA (IDK(I),BRFRAC(I),NME(I),(IDKPRD(J,I),J=1,5),I= 495, 513)/
+ & 144,0.023, 0, 56, 38, 21, 0, 0,
+ & 144,0.018, 0, 56, 38, 38, 30, 0,
+ & 144,0.020, 0, 22, 38, 0, 0, 0,
+ & 144,0.001, 0, 23, 38, 0, 0, 0,
+ & 144,0.009, 0, 24, 38, 0, 0, 0,
+ & 144,0.049, 0, 25, 38, 0, 0, 0,
+ & 144,0.011, 0,293, 38, 0, 0, 0,
+ & 144,0.015, 0, 22, 38, 21, 0, 0,
+ & 144,0.016, 0, 25, 38, 21, 0, 0,
+ & 144,0.103, 0, 22, 39, 0, 0, 0,
+ & 144,0.120, 0, 25, 39, 0, 0, 0,
+ & 144,0.010, 0, 38, 38, 30, 0, 0,
+ & 144,0.046, 0, 38, 38, 30, 21, 0,
+ & 144,0.003, 0, 38, 38, 38, 30, 30,
+ & 144,0.042, 0, 38, 30, 30, 38, 39,
+ & 144,0.001, 0, 46, 23, 0, 0, 0,
+ & 144,0.005, 0, 46, 38, 30, 0, 0,
+ & 144,0.001, 0, 46, 56, 0, 0, 0,
+ & 144,0.004, 0, 50, 38, 0, 0, 0/
+ DATA (IDK(I),BRFRAC(I),NME(I),(IDKPRD(J,I),J=1,5),I= 514, 532)/
+ & 144,0.007, 0, 51, 38, 0, 0, 0,
+ & 145,0.900, 0,144, 59, 0, 0, 0,
+ & 145,0.100, 0,144, 21, 0, 0, 0,
+ & 146,0.500, 0,137, 50, 0, 0, 0,
+ & 146,0.500, 0,141, 46, 0, 0, 0,
+ & 147,0.440, 0,136, 50, 0, 0, 0,
+ & 147,0.440, 0,140, 46, 0, 0, 0,
+ & 147,0.055, 0,137, 50, 0, 0, 0,
+ & 147,0.055, 0,141, 46, 0, 0, 0,
+ & 147,0.010, 0,144, 22, 0, 0, 0,
+ & 148,1.000, 0,150, 38, 0, 0, 0,
+ & 149,1.000, 0,150, 38, 0, 0, 0,
+ & 150,0.028,101,122,127, 78, 0, 0,
+ & 150,0.010,101,122,127, 80, 0, 0,
+ & 150,0.028,101,124,129, 78, 0, 0,
+ & 150,0.010,101,124,129, 80, 0, 0,
+ & 150,0.026, 0, 73, 42, 0, 0, 0,
+ & 150,0.030, 0, 73, 42, 21, 0, 0,
+ & 150,0.029, 0, 73, 42, 38, 30, 0/
+ DATA (IDK(I),BRFRAC(I),NME(I),(IDKPRD(J,I),J=1,5),I= 533, 551)/
+ & 150,0.014, 0, 73, 42, 22, 0, 0,
+ & 150,0.020, 0, 73, 43, 0, 0, 0,
+ & 150,0.029, 0, 73, 34, 38, 0, 0,
+ & 150,0.039, 0, 73, 34, 38, 21, 0,
+ & 150,0.002, 0, 73, 34, 38, 38, 30,
+ & 150,0.010, 0, 73, 34, 38, 21, 21,
+ & 150,0.014, 0, 73, 35, 38, 0, 0,
+ & 150,0.010, 0, 74, 42, 0, 0, 0,
+ & 150,0.020, 0, 74, 43, 0, 0, 0,
+ & 150,0.010, 0, 74, 43, 21, 0, 0,
+ & 150,0.007, 0, 85, 34, 0, 0, 0,
+ & 150,0.014, 0, 85, 35, 0, 0, 0,
+ & 150,0.004, 0, 73,293, 0, 0, 0,
+ & 150,0.003, 0, 73, 38, 30, 0, 0,
+ & 150,0.003, 0, 73, 38, 30, 38, 30,
+ & 150,0.001, 0, 73, 56, 0, 0, 0,
+ & 150,0.002, 0, 73, 46, 34, 0, 0,
+ & 150,0.010, 0, 78, 38, 0, 0, 0,
+ & 150,0.020, 0, 78, 39, 0, 0, 0/
+ DATA (IDK(I),BRFRAC(I),NME(I),(IDKPRD(J,I),J=1,5),I= 552, 570)/
+ & 150,0.030, 0, 78, 38, 21, 0, 0,
+ & 150,0.010, 0, 78, 38, 22, 0, 0,
+ & 150,0.020, 0, 78, 38, 24, 0, 0,
+ & 150,0.035, 0, 78, 38, 38, 30, 0,
+ & 150,0.020, 0, 78, 38, 21, 21, 0,
+ & 150,0.010, 0, 78, 38, 38, 30, 21,
+ & 150,0.010, 0, 78, 38, 21, 21, 21,
+ & 150,0.007, 0, 78, 46, 42, 0, 0,
+ & 150,0.011, 0, 79, 38, 0, 0, 0,
+ & 150,0.022, 0, 79, 38, 21, 0, 0,
+ & 150,0.013, 0, 79, 38, 38, 30, 0,
+ & 150,0.010, 0, 79, 38, 21, 21, 0,
+ & 150,0.007, 0, 79, 38, 38, 30, 21,
+ & 150,0.005, 0, 79, 38, 21, 21, 21,
+ & 150,0.005, 0, 80, 38, 0, 0, 0,
+ & 150,0.015, 0, 80, 39, 0, 0, 0,
+ & 150,0.011, 0, 86, 21, 0, 0, 0,
+ & 150,0.007, 0, 86, 22, 0, 0, 0,
+ & 150,0.010, 0, 86, 23, 0, 0, 0/
+ DATA (IDK(I),BRFRAC(I),NME(I),(IDKPRD(J,I),J=1,5),I= 571, 589)/
+ & 150,0.031, 0, 86, 24, 0, 0, 0,
+ & 150,0.010, 0, 86, 25, 0, 0, 0,
+ & 150,0.004, 0, 86, 56, 0, 0, 0,
+ & 150,0.026, 0, 86, 38, 30, 0, 0,
+ & 150,0.005, 0, 86, 38, 38, 30, 30,
+ & 150,0.005, 0, 86, 38, 30, 21, 21,
+ & 150,0.005, 0, 87, 21, 0, 0, 0,
+ & 150,0.006, 0, 87, 23, 0, 0, 0,
+ & 150,0.004, 0, 86, 46, 34, 0, 0,
+ & 150,0.002, 0, 86, 46, 30, 0, 0,
+ & 150,0.001, 0, 86, 46, 30, 21, 0,
+ & 150,0.016, 0, 81, 38, 38, 0, 0,
+ & 150,0.003, 0, 88, 46, 0, 0, 0,
+ & 150,0.002, 0, 89, 46, 0, 0, 0,
+ & 150,0.003, 0, 83, 46, 38, 0, 0,
+ & 150,0.040, 0, 75, 46, 21, 0, 0,
+ & 150,0.040, 0, 75, 46, 38, 30, 0,
+ & 150,0.020, 0, 75, 46, 21, 21, 0,
+ & 150,0.010, 0, 75, 46, 38, 30, 21/
+ DATA (IDK(I),BRFRAC(I),NME(I),(IDKPRD(J,I),J=1,5),I= 590, 608)/
+ & 150,0.010, 0, 75, 46, 21, 21, 21,
+ & 150,0.020, 0, 75, 47, 21, 0, 0,
+ & 150,0.040, 0, 75, 42, 38, 0, 0,
+ & 150,0.020, 0, 75, 42, 39, 0, 0,
+ & 150,0.010, 0, 75, 42, 38, 38, 30,
+ & 150,0.010, 0, 75, 42, 38, 21, 21,
+ & 150,0.006, 0, 75, 43, 38, 0, 0,
+ & 151,1.000, 0,150, 21, 0, 0, 0,
+ & 152,1.000, 0,150, 21, 0, 0, 0,
+ & 153,1.000, 0,150, 30, 0, 0, 0,
+ & 154,1.000, 0,150, 30, 0, 0, 0,
+ & 155,0.045,101,122,127, 88, 0, 0,
+ & 155,0.005,101,122,127, 89, 0, 0,
+ & 155,0.045,101,124,129, 88, 0, 0,
+ & 155,0.005,101,124,129, 89, 0, 0,
+ & 155,0.021, 0, 86, 42, 0, 0, 0,
+ & 155,0.032, 0, 87, 42, 0, 0, 0,
+ & 155,0.032, 0, 79, 38, 42, 0, 0,
+ & 155,0.045, 0, 86, 43, 0, 0, 0/
+ DATA (IDK(I),BRFRAC(I),NME(I),(IDKPRD(J,I),J=1,5),I= 609, 627)/
+ & 155,0.065, 0, 87, 43, 0, 0, 0,
+ & 155,0.065, 0, 79, 38, 43, 0, 0,
+ & 155,0.055, 0, 88, 38, 0, 0, 0,
+ & 155,0.160, 0, 88, 39, 0, 0, 0,
+ & 155,0.105, 0, 89, 38, 0, 0, 0,
+ & 155,0.320, 0, 89, 39, 0, 0, 0,
+ & 156,1.000, 0,155, 59, 0, 0, 0,
+ & 157,0.667, 0,158, 38, 0, 0, 0,
+ & 157,0.333, 0,155, 21, 0, 0, 0,
+ & 158,0.045,101,122,127, 83, 0, 0,
+ & 158,0.045,101,124,129, 83, 0, 0,
+ & 158,0.005,101,122,127, 84, 0, 0,
+ & 158,0.005,101,124,129, 84, 0, 0,
+ & 158,0.020, 0, 79, 42, 0, 0, 0,
+ & 158,0.020, 0, 79, 21, 42, 0, 0,
+ & 158,0.020, 0, 80, 42, 0, 0, 0,
+ & 158,0.060, 0, 79, 43, 0, 0, 0,
+ & 158,0.060, 0, 79, 21, 43, 0, 0,
+ & 158,0.060, 0, 80, 43, 0, 0, 0/
+ DATA (IDK(I),BRFRAC(I),NME(I),(IDKPRD(J,I),J=1,5),I= 628, 646)/
+ & 158,0.020, 0, 86, 34, 0, 0, 0,
+ & 158,0.060, 0, 86, 35, 0, 0, 0,
+ & 158,0.040, 0, 87, 34, 0, 0, 0,
+ & 158,0.120, 0, 87, 35, 0, 0, 0,
+ & 158,0.020, 0, 83, 38, 0, 0, 0,
+ & 158,0.060, 0, 83, 39, 0, 0, 0,
+ & 158,0.040, 0, 84, 38, 0, 0, 0,
+ & 158,0.120, 0, 84, 39, 0, 0, 0,
+ & 158,0.010, 0, 88, 21, 0, 0, 0,
+ & 158,0.030, 0, 88, 23, 0, 0, 0,
+ & 158,0.020, 0, 89, 21, 0, 0, 0,
+ & 158,0.060, 0, 89, 23, 0, 0, 0,
+ & 158,0.030, 0, 88, 56, 0, 0, 0,
+ & 158,0.030, 0, 90, 46, 0, 0, 0,
+ & 159,1.000, 0,158, 59, 0, 0, 0,
+ & 160,0.670, 0,155, 30, 0, 0, 0,
+ & 160,0.330, 0,158, 21, 0, 0, 0,
+ & 161,0.050,101,122,127, 90, 0, 0,
+ & 161,0.050,101,124,129, 90, 0, 0/
+ DATA (IDK(I),BRFRAC(I),NME(I),(IDKPRD(J,I),J=1,5),I= 647, 665)/
+ & 161,0.075, 0, 88, 42, 0, 0, 0,
+ & 161,0.225, 0, 88, 43, 0, 0, 0,
+ & 161,0.150, 0, 89, 42, 0, 0, 0,
+ & 161,0.450, 0, 89, 43, 0, 0, 0,
+ & 162,1.000, 0,161, 59, 0, 0, 0,
+ & 163,0.028, 0, 25, 38, 30, 0, 0,
+ & 163,0.014, 0, 25, 21, 21, 0, 0,
+ & 163,0.018, 0, 39, 31, 0, 0, 0,
+ & 163,0.009, 0, 23, 23, 0, 0, 0,
+ & 163,0.010, 0, 51, 34, 38, 0, 0,
+ & 163,0.010, 0, 43, 47, 30, 0, 0,
+ & 163,0.004, 0, 51, 43, 0, 0, 0,
+ & 163,0.004, 0, 47, 35, 0, 0, 0,
+ & 163,0.007, 0, 56, 56, 0, 0, 0,
+ & 163,0.022, 0, 46, 42, 30, 0, 0,
+ & 163,0.011, 0, 46, 34, 21, 0, 0,
+ & 163,0.011, 0, 50, 42, 21, 0, 0,
+ & 163,0.022, 0, 50, 34, 38, 0, 0,
+ & 163,0.032, 0, 22, 38, 30, 0, 0/
+ DATA (IDK(I),BRFRAC(I),NME(I),(IDKPRD(J,I),J=1,5),I= 666, 684)/
+ & 163,0.016, 0, 22, 21, 21, 0, 0,
+ & 163,0.020, 0, 38, 30, 46, 34, 0,
+ & 163,0.012, 0, 38, 30, 38, 30, 0,
+ & 163,0.001, 0, 73, 91, 0, 0, 0,
+ & 163,0.001, 0, 59, 59, 0, 0, 0,
+ & 163,0.748, 0, 13, 13, 0, 0, 0,
+ & 164,0.060, 0,121,127, 0, 0, 0,
+ & 164,0.060, 0,123,129, 0, 0, 0,
+ & 164,0.004, 0, 39, 30, 0, 0, 0,
+ & 164,0.004, 0, 23, 21, 0, 0, 0,
+ & 164,0.004, 0, 31, 38, 0, 0, 0,
+ & 164,0.003, 0, 41, 31, 0, 0, 0,
+ & 164,0.003, 0, 29, 23, 0, 0, 0,
+ & 164,0.003, 0, 33, 39, 0, 0, 0,
+ & 164,0.009, 0, 24, 38, 38, 30, 30,
+ & 164,0.007, 0, 24, 38, 30, 0, 0,
+ & 164,0.003, 0, 51, 45, 0, 0, 0,
+ & 164,0.003, 0, 43, 53, 0, 0, 0,
+ & 164,0.003, 0, 24, 51, 42, 0, 0/
+ DATA (IDK(I),BRFRAC(I),NME(I),(IDKPRD(J,I),J=1,5),I= 685, 703)/
+ & 164,0.003, 0, 24, 43, 50, 0, 0,
+ & 164,0.004, 0, 24, 26, 0, 0, 0,
+ & 164,0.003, 0, 46, 35, 0, 0, 0,
+ & 164,0.003, 0, 34, 47, 0, 0, 0,
+ & 164,0.002, 0, 50, 43, 0, 0, 0,
+ & 164,0.002, 0, 42, 51, 0, 0, 0,
+ & 164,0.003, 0, 24, 21, 21, 0, 0,
+ & 164,0.002, 0,286, 30, 0, 0, 0,
+ & 164,0.002, 0,287, 38, 0, 0, 0,
+ & 164,0.003, 0, 24, 46, 42, 30, 0,
+ & 164,0.003, 0, 24, 34, 50, 38, 0,
+ & 164,0.002, 0,285, 21, 0, 0, 0,
+ & 164,0.001, 0, 56, 51, 42, 0, 0,
+ & 164,0.001, 0, 56, 43, 50, 0, 0,
+ & 164,0.001, 0, 24, 50, 42, 0, 0,
+ & 164,0.001, 0, 24, 46, 34, 0, 0,
+ & 164,0.002, 0, 56, 38, 30, 38, 30,
+ & 164,0.002, 0, 85, 91, 30, 0, 0,
+ & 164,0.002, 0,103, 73, 38, 0, 0/
+ DATA (IDK(I),BRFRAC(I),NME(I),(IDKPRD(J,I),J=1,5),I= 704, 722)/
+ & 164,0.002, 0, 24, 22, 0, 0, 0,
+ & 164,0.001, 0, 56, 50, 42, 0, 0,
+ & 164,0.001, 0, 56, 46, 34, 0, 0,
+ & 164,0.001, 0, 73, 91, 24, 0, 0,
+ & 164,0.001, 0, 85,103, 0, 0, 0,
+ & 164,0.001, 0, 82,100, 0, 0, 0,
+ & 164,0.001, 0, 87,105, 0, 0, 0,
+ & 164,0.001, 0, 73, 91, 25, 0, 0,
+ & 164,0.001, 0, 56, 58, 0, 0, 0,
+ & 164,0.001, 0, 56, 38, 30, 0, 0,
+ & 164,0.001, 0, 56, 46, 42, 30, 0,
+ & 164,0.001, 0, 56, 34, 50, 38, 0,
+ & 164,0.001, 0, 56, 22, 0, 0, 0,
+ & 164,0.001, 0, 84,102, 0, 0, 0,
+ & 164,0.001, 0, 73, 34, 98, 0, 0,
+ & 164,0.001, 0, 91, 46, 80, 0, 0,
+ & 164,0.034, 0, 38, 38, 30, 30, 21,
+ & 164,0.029, 0, 23, 23, 23, 21, 0,
+ & 164,0.015, 0, 38, 30, 21, 0, 0/
+ DATA (IDK(I),BRFRAC(I),NME(I),(IDKPRD(J,I),J=1,5),I= 723, 741)/
+ & 164,0.012, 0, 38, 30, 21, 34, 46,
+ & 164,0.009, 0, 23, 23, 23, 24, 0,
+ & 164,0.007, 0, 38, 30, 34, 46, 0,
+ & 164,0.002, 0, 46, 42, 30, 0, 0,
+ & 164,0.001, 0, 46, 34, 21, 0, 0,
+ & 164,0.001, 0, 50, 42, 21, 0, 0,
+ & 164,0.002, 0, 50, 34, 38, 0, 0,
+ & 164,0.006, 0, 73, 91, 38, 30, 0,
+ & 164,0.004, 0, 38, 30, 38, 30, 0,
+ & 164,0.004, 0, 38, 30, 38, 30, 23,
+ & 164,0.004, 0, 75, 93, 38, 30, 0,
+ & 164,0.001, 0, 86,104, 0, 0, 0,
+ & 164,0.001, 0, 79, 97, 0, 0, 0,
+ & 164,0.001, 0, 81, 99, 0, 0, 0,
+ & 164,0.003, 0, 23, 23, 34, 46, 0,
+ & 164,0.002, 0, 73, 91, 38, 30, 21,
+ & 164,0.002, 0, 73, 91, 0, 0, 0,
+ & 164,0.002, 0, 73, 91, 22, 0, 0,
+ & 164,0.002, 0, 73, 93, 30, 0, 0/
+ DATA (IDK(I),BRFRAC(I),NME(I),(IDKPRD(J,I),J=1,5),I= 742, 760)/
+ & 164,0.002, 0, 75, 93, 0, 0, 0,
+ & 164,0.001, 0, 83,102, 0, 0, 0,
+ & 164,0.001, 0, 88,106, 0, 0, 0,
+ & 164,0.001, 0, 78, 96, 0, 0, 0,
+ & 164,0.001, 0, 73, 91, 21, 0, 0,
+ & 164,0.001, 0, 78,104, 38, 0, 0,
+ & 164,0.001, 0, 96, 86, 30, 0, 0,
+ & 164,0.001, 0, 73, 34, 96, 0, 0,
+ & 164,0.001, 0, 91, 46, 78, 0, 0,
+ & 164,0.001, 0, 46, 34, 46, 34, 0,
+ & 164,0.013, 0, 59,163, 0, 0, 0,
+ & 164,0.008, 0, 59, 38, 30, 21, 21,
+ & 164,0.004, 0, 59, 22, 38, 30, 0,
+ & 164,0.002, 0, 59, 22, 21, 21, 0,
+ & 164,0.003, 0, 59, 39, 31, 0, 0,
+ & 164,0.002, 0, 59, 23, 23, 0, 0,
+ & 164,0.004, 0, 59, 25, 0, 0, 0,
+ & 164,0.003, 0, 59, 38, 30, 38, 30,
+ & 164,0.002, 0, 59, 24, 24, 0, 0/
+ DATA (IDK(I),BRFRAC(I),NME(I),(IDKPRD(J,I),J=1,5),I= 761, 779)/
+ & 164,0.001, 0, 59, 26, 0, 0, 0,
+ & 164,0.001, 0, 59, 22, 0, 0, 0,
+ & 164,0.001, 0, 59, 28, 0, 0, 0,
+ & 164,0.001, 0, 59, 58, 0, 0, 0,
+ & 164,0.020, 0, 1, 7, 0, 0, 0,
+ & 164,0.080, 0, 2, 8, 0, 0, 0,
+ & 164,0.020, 0, 3, 9, 0, 0, 0,
+ & 164,0.364,130, 13, 13, 13, 0, 0,
+ & 164,0.091,130, 13, 13, 59, 0, 0,
+ & 165,0.037, 0, 38, 30, 38, 30, 0,
+ & 165,0.030, 0, 38, 30, 46, 34, 0,
+ & 165,0.016, 0, 23, 38, 30, 0, 0,
+ & 165,0.015, 0, 23, 38, 30, 38, 30,
+ & 165,0.004, 0, 46, 43, 30, 0, 0,
+ & 165,0.002, 0, 46, 35, 21, 0, 0,
+ & 165,0.002, 0, 51, 43, 21, 0, 0,
+ & 165,0.004, 0, 51, 35, 38, 0, 0,
+ & 165,0.008, 0, 38, 30, 0, 0, 0,
+ & 165,0.007, 0, 46, 34, 0, 0, 0/
+ DATA (IDK(I),BRFRAC(I),NME(I),(IDKPRD(J,I),J=1,5),I= 780, 798)/
+ & 165,0.005, 0, 38, 30, 73, 91, 0,
+ & 165,0.003, 0, 21, 21, 0, 0, 0,
+ & 165,0.003, 0, 22, 22, 0, 0, 0,
+ & 165,0.007, 0, 59,164, 0, 0, 0,
+ & 165,0.857, 0, 13, 13, 0, 0, 0,
+ & 166,0.008, 0,121,127, 0, 0, 0,
+ & 166,0.008, 0,123,129, 0, 0, 0,
+ & 166,0.001, 0,125,131, 0, 0, 0,
+ & 166,0.338, 0,164, 38, 30, 0, 0,
+ & 166,0.169, 0,164, 21, 21, 0, 0,
+ & 166,0.027, 0,164, 22, 0, 0, 0,
+ & 166,0.001, 0,164, 21, 0, 0, 0,
+ & 166,0.004, 0, 23, 23, 23, 21, 0,
+ & 166,0.003, 0, 23, 23, 21, 0, 0,
+ & 166,0.002, 0, 38, 30, 46, 34, 0,
+ & 166,0.001, 0, 38, 30, 73, 91, 0,
+ & 166,0.093, 0, 59,165, 0, 0, 0,
+ & 166,0.087, 0, 59,302, 0, 0, 0,
+ & 166,0.078, 0, 59,303, 0, 0, 0/
+ DATA (IDK(I),BRFRAC(I),NME(I),(IDKPRD(J,I),J=1,5),I= 799, 817)/
+ & 166,0.003, 0, 59,163, 0, 0, 0,
+ & 166,0.003, 0, 1, 7, 0, 0, 0,
+ & 166,0.012, 0, 2, 8, 0, 0, 0,
+ & 166,0.003, 0, 3, 9, 0, 0, 0,
+ & 166,0.127,130, 13, 13, 13, 0, 0,
+ & 166,0.032,130, 13, 13, 59, 0, 0,
+ & 167,0.500, 0,136,171, 0, 0, 0,
+ & 167,0.500, 0,140,175, 0, 0, 0,
+ & 171,0.067,101,128,121, 50, 0, 0,
+ & 171,0.067,101,130,123, 50, 0, 0,
+ & 171,0.048,101,128,121, 51, 0, 0,
+ & 171,0.048,101,130,123, 51, 0, 0,
+ & 171,0.003, 0,128,121, 46, 30, 0,
+ & 171,0.003, 0,130,123, 46, 30, 0,
+ & 171,0.006,101,128,121, 21, 0, 0,
+ & 171,0.006,101,130,123, 21, 0, 0,
+ & 171,0.002,101,128,121, 23, 0, 0,
+ & 171,0.002,101,130,123, 23, 0, 0,
+ & 171,0.055, 0, 46, 30, 30, 0, 0/
+ DATA (IDK(I),BRFRAC(I),NME(I),(IDKPRD(J,I),J=1,5),I= 818, 836)/
+ & 171,0.031, 0, 46, 31, 30, 0, 0,
+ & 171,0.042, 0, 46, 30, 30, 21, 21,
+ & 171,0.002, 0, 46, 30, 30, 30, 39,
+ & 171,0.021, 0, 47, 30, 30, 0, 0,
+ & 171,0.027, 0, 50, 30, 0, 0, 0,
+ & 171,0.066, 0, 50, 31, 0, 0, 0,
+ & 171,0.081, 0, 50, 32, 0, 0, 0,
+ & 171,0.024, 0, 50, 30, 21, 0, 0,
+ & 171,0.004, 0, 50, 30, 23, 0, 0,
+ & 171,0.069, 0, 50, 30, 30, 38, 21,
+ & 171,0.001, 0, 50, 30, 30, 38, 23,
+ & 171,0.022, 0, 51, 30, 0, 0, 0,
+ & 171,0.021, 0, 51, 31, 0, 0, 0,
+ & 171,0.042, 0, 51, 30, 21, 0, 0,
+ & 171,0.008, 0, 51, 30, 23, 0, 0,
+ & 171,0.010, 0, 51, 30, 30, 38, 0,
+ & 171,0.050, 0,309, 30, 0, 0, 0,
+ & 171,0.034, 0,328, 30, 0, 0, 0,
+ & 171,0.010, 0,368, 30, 0, 0, 0/
+ DATA (IDK(I),BRFRAC(I),NME(I),(IDKPRD(J,I),J=1,5),I= 837, 855)/
+ & 171,0.031, 0, 34, 50, 50, 0, 0,
+ & 171,0.003, 0, 30, 21, 0, 0, 0,
+ & 171,0.001, 0, 30, 23, 0, 0, 0,
+ & 171,0.002, 0, 30, 30, 38, 0, 0,
+ & 171,0.008, 0, 30, 22, 0, 0, 0,
+ & 171,0.001, 0, 30, 30, 30, 38, 38,
+ & 171,0.003, 0, 30, 30, 30, 38, 39,
+ & 171,0.008, 0, 34, 50, 0, 0, 0,
+ & 171,0.005, 0, 34, 51, 0, 0, 0,
+ & 171,0.026, 0, 35, 51, 0, 0, 0,
+ & 171,0.005, 0, 34, 46, 30, 0, 0,
+ & 171,0.007, 0, 30, 56, 0, 0, 0,
+ & 171,0.023, 0, 30, 56, 21, 0, 0,
+ & 171,0.005, 0, 34, 34, 46, 0, 0,
+ & 172,0.683, 0,175, 30, 0, 0, 0,
+ & 172,0.306, 0,171, 21, 0, 0, 0,
+ & 172,0.011, 0,171, 59, 0, 0, 0,
+ & 173,0.667, 0,176, 30, 0, 0, 0,
+ & 173,0.333, 0,172, 21, 0, 0, 0/
+ DATA (IDK(I),BRFRAC(I),NME(I),(IDKPRD(J,I),J=1,5),I= 856, 874)/
+ & 174,0.220, 0,175, 30, 0, 0, 0,
+ & 174,0.110, 0,171, 21, 0, 0, 0,
+ & 174,0.380, 0,176, 30, 0, 0, 0,
+ & 174,0.190, 0,172, 21, 0, 0, 0,
+ & 174,0.004, 0,171, 22, 0, 0, 0,
+ & 174,0.064, 0,176, 30, 21, 0, 0,
+ & 174,0.032, 0,172, 38, 30, 0, 0,
+ & 175,0.037,101,128,121, 46, 0, 0,
+ & 175,0.037,101,130,123, 46, 0, 0,
+ & 175,0.016,101,128,121, 47, 0, 0,
+ & 175,0.016,101,130,123, 47, 0, 0,
+ & 175,0.013, 0,128,121, 46, 21, 0,
+ & 175,0.013, 0,130,123, 46, 21, 0,
+ & 175,0.012, 0,128,121, 50, 38, 0,
+ & 175,0.012, 0,130,123, 50, 38, 0,
+ & 175,0.003,101,128,121, 38, 0, 0,
+ & 175,0.003,101,130,123, 38, 0, 0,
+ & 175,0.039, 0, 46, 30, 0, 0, 0,
+ & 175,0.091, 0, 46, 31, 0, 0, 0/
+ DATA (IDK(I),BRFRAC(I),NME(I),(IDKPRD(J,I),J=1,5),I= 875, 893)/
+ & 175,0.067, 0, 46, 32, 0, 0, 0,
+ & 175,0.004, 0, 46, 30, 21, 0, 0,
+ & 175,0.100, 0, 46, 30, 21, 21, 0,
+ & 175,0.058, 0, 46, 30, 23, 0, 0,
+ & 175,0.020, 0, 46, 30, 24, 0, 0,
+ & 175,0.006, 0, 46, 30, 25, 0, 0,
+ & 175,0.043, 0, 47, 30, 0, 0, 0,
+ & 175,0.035, 0, 47, 31, 0, 0, 0,
+ & 175,0.007, 0,310, 30, 0, 0, 0,
+ & 175,0.007, 0,327, 30, 0, 0, 0,
+ & 175,0.020, 0, 50, 21, 0, 0, 0,
+ & 175,0.006, 0, 50, 22, 0, 0, 0,
+ & 175,0.009, 0, 50, 23, 0, 0, 0,
+ & 175,0.016, 0, 50, 24, 0, 0, 0,
+ & 175,0.014, 0, 50, 25, 0, 0, 0,
+ & 175,0.003, 0, 50,293, 0, 0, 0,
+ & 175,0.007, 0, 50, 56, 0, 0, 0,
+ & 175,0.003, 0, 50, 26, 0, 0, 0,
+ & 175,0.004, 0, 50,294, 0, 0, 0/
+ DATA (IDK(I),BRFRAC(I),NME(I),(IDKPRD(J,I),J=1,5),I= 894, 912)/
+ & 175,0.006, 0, 50, 21, 21, 0, 0,
+ & 175,0.042, 0, 50, 30, 38, 21, 0,
+ & 175,0.004, 0, 50, 30, 30, 38, 38,
+ & 175,0.076, 0, 50, 30, 38, 21, 21,
+ & 175,0.026, 0, 51, 21, 0, 0, 0,
+ & 175,0.014, 0, 51, 22, 0, 0, 0,
+ & 175,0.014, 0, 51, 23, 0, 0, 0,
+ & 175,0.011, 0, 51, 24, 0, 0, 0,
+ & 175,0.018, 0, 51, 30, 38, 0, 0,
+ & 175,0.004, 0, 50, 34, 46, 0, 0,
+ & 175,0.004, 0, 50, 34, 46, 21, 0,
+ & 175,0.005, 0, 50, 50, 42, 0, 0,
+ & 175,0.002, 0, 30, 38, 0, 0, 0,
+ & 175,0.001, 0, 21, 21, 0, 0, 0,
+ & 175,0.008, 0, 30, 38, 21, 0, 0,
+ & 175,0.007, 0, 30, 30, 38, 38, 0,
+ & 175,0.015, 0, 30, 30, 38, 38, 21,
+ & 175,0.004, 0, 34, 46, 0, 0, 0,
+ & 175,0.003, 0, 35, 46, 0, 0, 0/
+ DATA (IDK(I),BRFRAC(I),NME(I),(IDKPRD(J,I),J=1,5),I= 913, 931)/
+ & 175,0.002, 0, 34, 47, 0, 0, 0,
+ & 175,0.001, 0, 42, 50, 0, 0, 0,
+ & 175,0.002, 0, 43, 51, 0, 0, 0,
+ & 175,0.003, 0, 42, 46, 30, 0, 0,
+ & 175,0.003, 0, 50, 34, 38, 0, 0,
+ & 175,0.001, 0, 34, 46, 30, 38, 21,
+ & 175,0.002, 0, 56, 23, 0, 0, 0,
+ & 175,0.001, 0, 56, 30, 38, 0, 0,
+ & 176,0.636, 0,175, 21, 0, 0, 0,
+ & 176,0.364, 0,175, 59, 0, 0, 0,
+ & 177,0.667, 0,172, 38, 0, 0, 0,
+ & 177,0.333, 0,176, 21, 0, 0, 0,
+ & 178,0.220, 0,171, 38, 0, 0, 0,
+ & 178,0.110, 0,175, 21, 0, 0, 0,
+ & 178,0.380, 0,172, 38, 0, 0, 0,
+ & 178,0.190, 0,176, 21, 0, 0, 0,
+ & 178,0.004, 0,175, 22, 0, 0, 0,
+ & 178,0.064, 0,172, 38, 21, 0, 0,
+ & 178,0.032, 0,176, 38, 30, 0, 0/
+ DATA (IDK(I),BRFRAC(I),NME(I),(IDKPRD(J,I),J=1,5),I= 932, 950)/
+ & 179,0.009, 0,130,123, 0, 0, 0,
+ & 179,0.019,101,128,121, 56, 0, 0,
+ & 179,0.019,101,130,123, 56, 0, 0,
+ & 179,0.025,101,128,121, 22, 0, 0,
+ & 179,0.025,101,130,123, 22, 0, 0,
+ & 179,0.009,101,128,121, 25, 0, 0,
+ & 179,0.009,101,130,123, 25, 0, 0,
+ & 179,0.036, 0, 34, 50, 0, 0, 0,
+ & 179,0.034, 0, 34, 51, 0, 0, 0,
+ & 179,0.007, 0, 34,328, 0, 0, 0,
+ & 179,0.043, 0, 35, 50, 0, 0, 0,
+ & 179,0.058, 0, 35, 51, 0, 0, 0,
+ & 179,0.011, 0, 34, 46, 30, 0, 0,
+ & 179,0.055, 0, 34, 46, 30, 21, 0,
+ & 179,0.003, 0, 34, 46, 30, 38, 30,
+ & 179,0.014, 0, 34, 50, 38, 30, 0,
+ & 179,0.017, 0, 42, 46, 30, 30, 0,
+ & 179,0.036, 0, 56, 30, 0, 0, 0,
+ & 179,0.067, 0, 56, 31, 0, 0, 0/
+ DATA (IDK(I),BRFRAC(I),NME(I),(IDKPRD(J,I),J=1,5),I= 951, 969)/
+ & 179,0.023, 0, 56, 30, 21, 0, 0,
+ & 179,0.018, 0, 56, 30, 38, 30, 0,
+ & 179,0.020, 0, 22, 30, 0, 0, 0,
+ & 179,0.001, 0, 23, 30, 0, 0, 0,
+ & 179,0.009, 0, 24, 30, 0, 0, 0,
+ & 179,0.049, 0, 25, 30, 0, 0, 0,
+ & 179,0.011, 0,293, 30, 0, 0, 0,
+ & 179,0.015, 0, 22, 30, 21, 0, 0,
+ & 179,0.016, 0, 25, 30, 21, 0, 0,
+ & 179,0.103, 0, 22, 31, 0, 0, 0,
+ & 179,0.120, 0, 25, 31, 0, 0, 0,
+ & 179,0.010, 0, 30, 38, 30, 0, 0,
+ & 179,0.046, 0, 30, 38, 30, 21, 0,
+ & 179,0.003, 0, 30, 38, 38, 30, 30,
+ & 179,0.042, 0, 30, 38, 38, 30, 31,
+ & 179,0.001, 0, 34, 23, 0, 0, 0,
+ & 179,0.005, 0, 34, 38, 30, 0, 0,
+ & 179,0.001, 0, 34, 56, 0, 0, 0,
+ & 179,0.004, 0, 42, 30, 0, 0, 0/
+ DATA (IDK(I),BRFRAC(I),NME(I),(IDKPRD(J,I),J=1,5),I= 970, 988)/
+ & 179,0.007, 0, 43, 30, 0, 0, 0,
+ & 180,0.900, 0,179, 59, 0, 0, 0,
+ & 180,0.100, 0,179, 21, 0, 0, 0,
+ & 181,0.500, 0,172, 42, 0, 0, 0,
+ & 181,0.500, 0,176, 34, 0, 0, 0,
+ & 182,0.440, 0,171, 42, 0, 0, 0,
+ & 182,0.440, 0,175, 34, 0, 0, 0,
+ & 182,0.055, 0,172, 42, 0, 0, 0,
+ & 182,0.055, 0,176, 34, 0, 0, 0,
+ & 182,0.010, 0,179, 22, 0, 0, 0,
+ & 183,1.000, 0,185, 30, 0, 0, 0,
+ & 184,1.000, 0,185, 30, 0, 0, 0,
+ & 185,0.028,101,128,121, 96, 0, 0,
+ & 185,0.010,101,128,121, 98, 0, 0,
+ & 185,0.028,101,130,123, 96, 0, 0,
+ & 185,0.010,101,130,123, 98, 0, 0,
+ & 185,0.026, 0, 91, 50, 0, 0, 0,
+ & 185,0.030, 0, 91, 50, 21, 0, 0,
+ & 185,0.029, 0, 91, 50, 38, 30, 0/
+ DATA (IDK(I),BRFRAC(I),NME(I),(IDKPRD(J,I),J=1,5),I= 989,1007)/
+ & 185,0.014, 0, 91, 50, 22, 0, 0,
+ & 185,0.020, 0, 91, 51, 0, 0, 0,
+ & 185,0.029, 0, 91, 46, 30, 0, 0,
+ & 185,0.039, 0, 91, 46, 30, 21, 0,
+ & 185,0.002, 0, 91, 46, 30, 30, 38,
+ & 185,0.010, 0, 91, 46, 30, 21, 21,
+ & 185,0.014, 0, 91, 47, 30, 0, 0,
+ & 185,0.010, 0, 92, 50, 0, 0, 0,
+ & 185,0.020, 0, 92, 51, 0, 0, 0,
+ & 185,0.010, 0, 92, 51, 21, 0, 0,
+ & 185,0.007, 0,103, 46, 0, 0, 0,
+ & 185,0.014, 0,103, 47, 0, 0, 0,
+ & 185,0.004, 0, 91,293, 0, 0, 0,
+ & 185,0.003, 0, 91, 38, 30, 0, 0,
+ & 185,0.003, 0, 91, 38, 30, 38, 30,
+ & 185,0.001, 0, 91, 56, 0, 0, 0,
+ & 185,0.002, 0, 91, 46, 34, 0, 0,
+ & 185,0.010, 0, 96, 30, 0, 0, 0,
+ & 185,0.020, 0, 96, 31, 0, 0, 0/
+ DATA (IDK(I),BRFRAC(I),NME(I),(IDKPRD(J,I),J=1,5),I=1008,1026)/
+ & 185,0.030, 0, 96, 30, 21, 0, 0,
+ & 185,0.010, 0, 96, 30, 22, 0, 0,
+ & 185,0.020, 0, 96, 30, 24, 0, 0,
+ & 185,0.035, 0, 96, 30, 30, 38, 0,
+ & 185,0.020, 0, 96, 30, 21, 21, 0,
+ & 185,0.010, 0, 96, 30, 38, 30, 21,
+ & 185,0.010, 0, 96, 30, 21, 21, 21,
+ & 185,0.007, 0, 96, 34, 50, 0, 0,
+ & 185,0.011, 0, 97, 30, 0, 0, 0,
+ & 185,0.022, 0, 97, 30, 21, 0, 0,
+ & 185,0.013, 0, 97, 30, 38, 30, 0,
+ & 185,0.010, 0, 97, 30, 21, 21, 0,
+ & 185,0.007, 0, 97, 30, 38, 30, 21,
+ & 185,0.005, 0, 97, 30, 21, 21, 21,
+ & 185,0.005, 0, 98, 30, 0, 0, 0,
+ & 185,0.015, 0, 98, 31, 0, 0, 0,
+ & 185,0.011, 0,104, 21, 0, 0, 0,
+ & 185,0.007, 0,104, 22, 0, 0, 0,
+ & 185,0.010, 0,104, 23, 0, 0, 0/
+ DATA (IDK(I),BRFRAC(I),NME(I),(IDKPRD(J,I),J=1,5),I=1027,1045)/
+ & 185,0.031, 0,104, 24, 0, 0, 0,
+ & 185,0.010, 0,104, 25, 0, 0, 0,
+ & 185,0.004, 0,104, 56, 0, 0, 0,
+ & 185,0.026, 0,104, 38, 30, 0, 0,
+ & 185,0.005, 0,104, 38, 38, 30, 30,
+ & 185,0.005, 0,104, 38, 30, 21, 21,
+ & 185,0.005, 0,105, 21, 0, 0, 0,
+ & 185,0.006, 0,105, 23, 0, 0, 0,
+ & 185,0.004, 0,104, 46, 34, 0, 0,
+ & 185,0.002, 0,104, 34, 38, 0, 0,
+ & 185,0.001, 0,104, 34, 38, 21, 0,
+ & 185,0.016, 0, 99, 30, 30, 0, 0,
+ & 185,0.003, 0,106, 34, 0, 0, 0,
+ & 185,0.002, 0,107, 34, 0, 0, 0,
+ & 185,0.003, 0,101, 34, 30, 0, 0,
+ & 185,0.040, 0, 93, 34, 21, 0, 0,
+ & 185,0.040, 0, 93, 34, 38, 30, 0,
+ & 185,0.020, 0, 93, 34, 21, 21, 0,
+ & 185,0.010, 0, 93, 34, 38, 30, 21/
+ DATA (IDK(I),BRFRAC(I),NME(I),(IDKPRD(J,I),J=1,5),I=1046,1064)/
+ & 185,0.010, 0, 93, 34, 21, 21, 21,
+ & 185,0.020, 0, 93, 35, 21, 0, 0,
+ & 185,0.040, 0, 93, 50, 30, 0, 0,
+ & 185,0.020, 0, 93, 50, 31, 0, 0,
+ & 185,0.010, 0, 93, 50, 30, 38, 30,
+ & 185,0.010, 0, 93, 50, 30, 21, 21,
+ & 185,0.006, 0, 93, 51, 30, 0, 0,
+ & 186,1.000, 0,185, 21, 0, 0, 0,
+ & 187,1.000, 0,185, 21, 0, 0, 0,
+ & 188,1.000, 0,185, 38, 0, 0, 0,
+ & 189,1.000, 0,185, 38, 0, 0, 0,
+ & 190,0.045,101,128,121,106, 0, 0,
+ & 190,0.005,101,128,121,107, 0, 0,
+ & 190,0.045,101,130,123,106, 0, 0,
+ & 190,0.005,101,130,123,107, 0, 0,
+ & 190,0.021, 0,104, 50, 0, 0, 0,
+ & 190,0.032, 0,105, 50, 0, 0, 0,
+ & 190,0.032, 0, 97, 30, 50, 0, 0,
+ & 190,0.045, 0,104, 51, 0, 0, 0/
+ DATA (IDK(I),BRFRAC(I),NME(I),(IDKPRD(J,I),J=1,5),I=1065,1083)/
+ & 190,0.065, 0,105, 51, 0, 0, 0,
+ & 190,0.065, 0, 97, 30, 51, 0, 0,
+ & 190,0.055, 0,106, 30, 0, 0, 0,
+ & 190,0.160, 0,106, 31, 0, 0, 0,
+ & 190,0.105, 0,107, 30, 0, 0, 0,
+ & 190,0.320, 0,107, 31, 0, 0, 0,
+ & 191,1.000, 0,190, 59, 0, 0, 0,
+ & 192,0.667, 0,193, 30, 0, 0, 0,
+ & 192,0.333, 0,190, 21, 0, 0, 0,
+ & 193,0.045,101,128,121,101, 0, 0,
+ & 193,0.045,101,130,123,101, 0, 0,
+ & 193,0.005,101,128,121,102, 0, 0,
+ & 193,0.005,101,130,123,102, 0, 0,
+ & 193,0.020, 0, 97, 50, 0, 0, 0,
+ & 193,0.020, 0, 97, 21, 50, 0, 0,
+ & 193,0.020, 0, 98, 50, 0, 0, 0,
+ & 193,0.060, 0, 97, 51, 0, 0, 0,
+ & 193,0.060, 0, 97, 21, 51, 0, 0,
+ & 193,0.060, 0, 98, 51, 0, 0, 0/
+ DATA (IDK(I),BRFRAC(I),NME(I),(IDKPRD(J,I),J=1,5),I=1084,1102)/
+ & 193,0.020, 0,104, 46, 0, 0, 0,
+ & 193,0.060, 0,104, 47, 0, 0, 0,
+ & 193,0.040, 0,105, 46, 0, 0, 0,
+ & 193,0.120, 0,105, 47, 0, 0, 0,
+ & 193,0.020, 0,101, 30, 0, 0, 0,
+ & 193,0.060, 0,101, 31, 0, 0, 0,
+ & 193,0.040, 0,102, 30, 0, 0, 0,
+ & 193,0.120, 0,102, 31, 0, 0, 0,
+ & 193,0.010, 0,106, 21, 0, 0, 0,
+ & 193,0.030, 0,106, 23, 0, 0, 0,
+ & 193,0.020, 0,107, 21, 0, 0, 0,
+ & 193,0.060, 0,107, 23, 0, 0, 0,
+ & 193,0.030, 0,106, 56, 0, 0, 0,
+ & 193,0.030, 0,108, 34, 0, 0, 0,
+ & 194,1.000, 0,193, 59, 0, 0, 0,
+ & 195,0.670, 0,190, 38, 0, 0, 0,
+ & 195,0.330, 0,193, 21, 0, 0, 0,
+ & 196,0.050,101,128,121,108, 0, 0,
+ & 196,0.050,101,130,123,108, 0, 0/
+ DATA (IDK(I),BRFRAC(I),NME(I),(IDKPRD(J,I),J=1,5),I=1103,1121)/
+ & 196,0.075, 0,106, 50, 0, 0, 0,
+ & 196,0.225, 0,106, 51, 0, 0, 0,
+ & 196,0.150, 0,107, 50, 0, 0, 0,
+ & 196,0.450, 0,107, 51, 0, 0, 0,
+ & 197,1.000, 0,196, 59, 0, 0, 0,
+ & 209,0.250,100, 1, 8, 4, 0, 0,
+ & 209,0.250,100, 3, 10, 4, 0, 0,
+ & 209,0.250,100, 5, 12, 4, 0, 0,
+ & 209,0.085,100,121,128, 4, 0, 0,
+ & 209,0.085,100,123,130, 4, 0, 0,
+ & 209,0.080,100,125,132, 4, 0, 0,
+ & 210,0.250,100, 2, 7,209, 0, 0,
+ & 210,0.250,100, 4, 9,209, 0, 0,
+ & 210,0.250,100, 6, 11,209, 0, 0,
+ & 210,0.085,100,122,127,209, 0, 0,
+ & 210,0.085,100,124,129,209, 0, 0,
+ & 210,0.080,100,126,131,209, 0, 0,
+ & 211,0.250,100, 1, 8, 6, 0, 0,
+ & 211,0.250,100, 3, 10, 6, 0, 0/
+ DATA (IDK(I),BRFRAC(I),NME(I),(IDKPRD(J,I),J=1,5),I=1122,1140)/
+ & 211,0.250,100, 5, 12, 6, 0, 0,
+ & 211,0.085,100,121,128, 6, 0, 0,
+ & 211,0.085,100,123,130, 6, 0, 0,
+ & 211,0.080,100,125,132, 6, 0, 0,
+ & 212,0.250,100, 2, 7,211, 0, 0,
+ & 212,0.250,100, 4, 9,211, 0, 0,
+ & 212,0.250,100, 6, 11,211, 0, 0,
+ & 212,0.085,100,122,127,211, 0, 0,
+ & 212,0.085,100,124,129,211, 0, 0,
+ & 212,0.080,100,126,131,211, 0, 0,
+ & 215,0.250,100, 7, 2, 10, 0, 0,
+ & 215,0.250,100, 9, 4, 10, 0, 0,
+ & 215,0.250,100, 11, 6, 10, 0, 0,
+ & 215,0.085,100,127,122, 10, 0, 0,
+ & 215,0.085,100,129,124, 10, 0, 0,
+ & 215,0.080,100,131,126, 10, 0, 0,
+ & 216,0.250,100, 8, 1,215, 0, 0,
+ & 216,0.250,100, 10, 3,215, 0, 0,
+ & 216,0.250,100, 12, 5,215, 0, 0/
+ DATA (IDK(I),BRFRAC(I),NME(I),(IDKPRD(J,I),J=1,5),I=1141,1159)/
+ & 216,0.085,100,128,121,215, 0, 0,
+ & 216,0.085,100,130,123,215, 0, 0,
+ & 216,0.080,100,132,125,215, 0, 0,
+ & 217,0.250,100, 7, 2, 12, 0, 0,
+ & 217,0.250,100, 9, 4, 12, 0, 0,
+ & 217,0.250,100, 11, 6, 12, 0, 0,
+ & 217,0.085,100,127,122, 12, 0, 0,
+ & 217,0.085,100,129,124, 12, 0, 0,
+ & 217,0.080,100,131,126, 12, 0, 0,
+ & 218,0.250,100, 8, 1,217, 0, 0,
+ & 218,0.250,100, 10, 3,217, 0, 0,
+ & 218,0.250,100, 12, 5,217, 0, 0,
+ & 218,0.085,100,128,121,217, 0, 0,
+ & 218,0.085,100,130,123,217, 0, 0,
+ & 218,0.080,100,132,125,217, 0, 0,
+ & 221,0.016,101,121,128,136, 0, 0,
+ & 221,0.016,101,123,130,136, 0, 0,
+ & 221,0.008,101,125,132,136, 0, 0,
+ & 221,0.048,101,121,128,137, 0, 0/
+ DATA (IDK(I),BRFRAC(I),NME(I),(IDKPRD(J,I),J=1,5),I=1160,1178)/
+ & 221,0.048,101,123,130,137, 0, 0,
+ & 221,0.022,101,125,132,137, 0, 0,
+ & 221,0.003,101,121,128,331, 0, 0,
+ & 221,0.003,101,123,130,331, 0, 0,
+ & 221,0.001,101,125,132,331, 0, 0,
+ & 221,0.008,101,121,128,138, 0, 0,
+ & 221,0.008,101,123,130,138, 0, 0,
+ & 221,0.004,101,125,132,138, 0, 0,
+ & 221,0.008,101,121,128,313, 0, 0,
+ & 221,0.008,101,123,130,313, 0, 0,
+ & 221,0.004,101,125,132,313, 0, 0,
+ & 221,0.013,101,121,128,139, 0, 0,
+ & 221,0.013,101,123,130,139, 0, 0,
+ & 221,0.006,101,125,132,139, 0, 0,
+ & 221,0.004, 0,136, 30, 0, 0, 0,
+ & 221,0.010, 0,136, 31, 0, 0, 0,
+ & 221,0.006, 0,136, 32, 0, 0, 0,
+ & 221,0.003, 0,137, 30, 0, 0, 0,
+ & 221,0.009, 0,137, 31, 0, 0, 0/
+ DATA (IDK(I),BRFRAC(I),NME(I),(IDKPRD(J,I),J=1,5),I=1179,1197)/
+ & 221,0.017, 0,137, 32, 0, 0, 0,
+ & 221,0.011, 0,136,179, 0, 0, 0,
+ & 221,0.015, 0,136,180, 0, 0, 0,
+ & 221,0.011, 0,137,179, 0, 0, 0,
+ & 221,0.022, 0,137,180, 0, 0, 0,
+ & 221,0.001, 0,164, 42, 0, 0, 0,
+ & 221,0.002, 0,164, 43, 0, 0, 0,
+ & 221,0.001, 0,165, 42, 0, 0, 0,
+ & 221,0.001, 0,165, 43, 0, 0, 0,
+ & 221,0.001, 0,166, 42, 0, 0, 0,
+ & 221,0.001, 0,166, 43, 0, 0, 0,
+ & 221,0.207,100, 1, 8, 4, 7, 0,
+ & 221,0.207,100, 3, 10, 4, 7, 0,
+ & 221,0.024,100, 1, 8, 2, 7, 0,
+ & 221,0.024,100, 3, 10, 2, 7, 0,
+ & 221,0.012,100, 3, 8, 4, 7, 0,
+ & 221,0.012,100, 1, 10, 4, 7, 0,
+ & 221,0.069,100, 4, 8, 1, 7, 0,
+ & 221,0.069,100, 4, 10, 3, 7, 0/
+ DATA (IDK(I),BRFRAC(I),NME(I),(IDKPRD(J,I),J=1,5),I=1198,1216)/
+ & 221,0.008,100, 2, 8, 1, 7, 0,
+ & 221,0.008,100, 2, 10, 3, 7, 0,
+ & 221,0.004,100, 4, 8, 3, 7, 0,
+ & 221,0.004,100, 4, 10, 1, 7, 0,
+ & 222,0.016,101,121,128,140, 0, 0,
+ & 222,0.016,101,123,130,140, 0, 0,
+ & 222,0.008,101,125,132,140, 0, 0,
+ & 222,0.048,101,121,128,141, 0, 0,
+ & 222,0.048,101,123,130,141, 0, 0,
+ & 222,0.022,101,125,132,141, 0, 0,
+ & 222,0.003,101,121,128,332, 0, 0,
+ & 222,0.003,101,123,130,332, 0, 0,
+ & 222,0.001,101,125,132,332, 0, 0,
+ & 222,0.008,101,121,128,142, 0, 0,
+ & 222,0.008,101,123,130,142, 0, 0,
+ & 222,0.004,101,125,132,142, 0, 0,
+ & 222,0.008,101,121,128,314, 0, 0,
+ & 222,0.008,101,123,130,314, 0, 0,
+ & 222,0.004,101,125,132,314, 0, 0/
+ DATA (IDK(I),BRFRAC(I),NME(I),(IDKPRD(J,I),J=1,5),I=1217,1235)/
+ & 222,0.013,101,121,128,143, 0, 0,
+ & 222,0.013,101,123,130,143, 0, 0,
+ & 222,0.006,101,125,132,143, 0, 0,
+ & 222,0.004, 0,140, 30, 0, 0, 0,
+ & 222,0.010, 0,140, 31, 0, 0, 0,
+ & 222,0.006, 0,140, 32, 0, 0, 0,
+ & 222,0.003, 0,141, 30, 0, 0, 0,
+ & 222,0.009, 0,141, 31, 0, 0, 0,
+ & 222,0.017, 0,141, 32, 0, 0, 0,
+ & 222,0.011, 0,140,179, 0, 0, 0,
+ & 222,0.015, 0,140,180, 0, 0, 0,
+ & 222,0.011, 0,141,179, 0, 0, 0,
+ & 222,0.022, 0,141,180, 0, 0, 0,
+ & 222,0.001, 0,164, 34, 0, 0, 0,
+ & 222,0.002, 0,164, 35, 0, 0, 0,
+ & 222,0.001, 0,165, 34, 0, 0, 0,
+ & 222,0.001, 0,165, 35, 0, 0, 0,
+ & 222,0.001, 0,166, 34, 0, 0, 0,
+ & 222,0.001, 0,166, 35, 0, 0, 0/
+ DATA (IDK(I),BRFRAC(I),NME(I),(IDKPRD(J,I),J=1,5),I=1236,1254)/
+ & 222,0.207,100, 1, 8, 4, 8, 0,
+ & 222,0.207,100, 3, 10, 4, 8, 0,
+ & 222,0.024,100, 1, 8, 2, 8, 0,
+ & 222,0.024,100, 3, 10, 2, 8, 0,
+ & 222,0.012,100, 3, 8, 4, 8, 0,
+ & 222,0.012,100, 1, 10, 4, 8, 0,
+ & 222,0.069,100, 4, 8, 1, 8, 0,
+ & 222,0.069,100, 4, 10, 3, 8, 0,
+ & 222,0.008,100, 2, 8, 1, 8, 0,
+ & 222,0.008,100, 2, 10, 3, 8, 0,
+ & 222,0.004,100, 4, 8, 3, 8, 0,
+ & 222,0.004,100, 4, 10, 1, 8, 0,
+ & 223,0.016,101,121,128,144, 0, 0,
+ & 223,0.016,101,123,130,144, 0, 0,
+ & 223,0.008,101,125,132,144, 0, 0,
+ & 223,0.048,101,121,128,145, 0, 0,
+ & 223,0.048,101,123,130,145, 0, 0,
+ & 223,0.022,101,125,132,145, 0, 0,
+ & 223,0.003,101,121,128,333, 0, 0/
+ DATA (IDK(I),BRFRAC(I),NME(I),(IDKPRD(J,I),J=1,5),I=1255,1273)/
+ & 223,0.003,101,123,130,333, 0, 0,
+ & 223,0.001,101,125,132,333, 0, 0,
+ & 223,0.008,101,121,128,146, 0, 0,
+ & 223,0.008,101,123,130,146, 0, 0,
+ & 223,0.004,101,125,132,146, 0, 0,
+ & 223,0.008,101,121,128,315, 0, 0,
+ & 223,0.008,101,123,130,315, 0, 0,
+ & 223,0.004,101,125,132,315, 0, 0,
+ & 223,0.013,101,121,128,147, 0, 0,
+ & 223,0.013,101,123,130,147, 0, 0,
+ & 223,0.006,101,125,132,147, 0, 0,
+ & 223,0.004, 0,144, 30, 0, 0, 0,
+ & 223,0.010, 0,144, 31, 0, 0, 0,
+ & 223,0.006, 0,144, 32, 0, 0, 0,
+ & 223,0.003, 0,145, 30, 0, 0, 0,
+ & 223,0.009, 0,145, 31, 0, 0, 0,
+ & 223,0.017, 0,145, 32, 0, 0, 0,
+ & 223,0.011, 0,144,179, 0, 0, 0,
+ & 223,0.015, 0,144,180, 0, 0, 0/
+ DATA (IDK(I),BRFRAC(I),NME(I),(IDKPRD(J,I),J=1,5),I=1274,1292)/
+ & 223,0.011, 0,145,179, 0, 0, 0,
+ & 223,0.022, 0,145,180, 0, 0, 0,
+ & 223,0.001, 0,164, 25, 0, 0, 0,
+ & 223,0.002, 0,164, 56, 0, 0, 0,
+ & 223,0.001, 0,165, 25, 0, 0, 0,
+ & 223,0.001, 0,165, 56, 0, 0, 0,
+ & 223,0.001, 0,166, 25, 0, 0, 0,
+ & 223,0.001, 0,166, 56, 0, 0, 0,
+ & 223,0.207,100, 1, 8, 4, 9, 0,
+ & 223,0.207,100, 3, 10, 4, 9, 0,
+ & 223,0.024,100, 1, 8, 2, 9, 0,
+ & 223,0.024,100, 3, 10, 2, 9, 0,
+ & 223,0.012,100, 3, 8, 4, 9, 0,
+ & 223,0.012,100, 1, 10, 4, 9, 0,
+ & 223,0.069,100, 4, 8, 1, 9, 0,
+ & 223,0.069,100, 4, 10, 3, 9, 0,
+ & 223,0.008,100, 2, 8, 1, 9, 0,
+ & 223,0.008,100, 2, 10, 3, 9, 0,
+ & 223,0.004,100, 4, 8, 3, 9, 0/
+ DATA (IDK(I),BRFRAC(I),NME(I),(IDKPRD(J,I),J=1,5),I=1293,1311)/
+ & 223,0.004,100, 4, 10, 1, 9, 0,
+ & 224,0.090,100,121,128, 4,109, 0,
+ & 224,0.090,100,123,130, 4,109, 0,
+ & 224,0.045,100,125,132, 4,109, 0,
+ & 224,0.010,100,121,128, 2,109, 0,
+ & 224,0.010,100,123,130, 2,109, 0,
+ & 224,0.005,100,125,132, 2,109, 0,
+ & 224,0.242,100, 1, 8, 4,109, 0,
+ & 224,0.242,100, 3, 10, 4,109, 0,
+ & 224,0.027,100, 1, 8, 2,109, 0,
+ & 224,0.027,100, 3, 10, 2,109, 0,
+ & 224,0.012,100, 3, 8, 4,109, 0,
+ & 224,0.012,100, 1, 10, 4,109, 0,
+ & 224,0.081,100, 4, 8, 1,109, 0,
+ & 224,0.081,100, 4, 10, 3,109, 0,
+ & 224,0.009,100, 2, 8, 1,109, 0,
+ & 224,0.009,100, 2, 10, 3,109, 0,
+ & 224,0.004,100, 4, 8, 3,109, 0,
+ & 224,0.004,100, 4, 10, 1,109, 0/
+ DATA (IDK(I),BRFRAC(I),NME(I),(IDKPRD(J,I),J=1,5),I=1312,1330)/
+ & 225,0.090,100,121,128, 4,110, 0,
+ & 225,0.090,100,123,130, 4,110, 0,
+ & 225,0.045,100,125,132, 4,110, 0,
+ & 225,0.010,100,121,128, 2,110, 0,
+ & 225,0.010,100,123,130, 2,110, 0,
+ & 225,0.005,100,125,132, 2,110, 0,
+ & 225,0.242,100, 1, 8, 4,110, 0,
+ & 225,0.242,100, 3, 10, 4,110, 0,
+ & 225,0.027,100, 1, 8, 2,110, 0,
+ & 225,0.027,100, 3, 10, 2,110, 0,
+ & 225,0.012,100, 3, 8, 4,110, 0,
+ & 225,0.012,100, 1, 10, 4,110, 0,
+ & 225,0.081,100, 4, 8, 1,110, 0,
+ & 225,0.081,100, 4, 10, 3,110, 0,
+ & 225,0.009,100, 2, 8, 1,110, 0,
+ & 225,0.009,100, 2, 10, 3,110, 0,
+ & 225,0.004,100, 4, 8, 3,110, 0,
+ & 225,0.004,100, 4, 10, 1,110, 0,
+ & 226,0.090,100,121,128, 4,111, 0/
+ DATA (IDK(I),BRFRAC(I),NME(I),(IDKPRD(J,I),J=1,5),I=1331,1349)/
+ & 226,0.090,100,123,130, 4,111, 0,
+ & 226,0.045,100,125,132, 4,111, 0,
+ & 226,0.010,100,121,128, 2,111, 0,
+ & 226,0.010,100,123,130, 2,111, 0,
+ & 226,0.005,100,125,132, 2,111, 0,
+ & 226,0.242,100, 1, 8, 4,111, 0,
+ & 226,0.242,100, 3, 10, 4,111, 0,
+ & 226,0.027,100, 1, 8, 2,111, 0,
+ & 226,0.027,100, 3, 10, 2,111, 0,
+ & 226,0.012,100, 3, 8, 4,111, 0,
+ & 226,0.012,100, 1, 10, 4,111, 0,
+ & 226,0.081,100, 4, 8, 1,111, 0,
+ & 226,0.081,100, 4, 10, 3,111, 0,
+ & 226,0.009,100, 2, 8, 1,111, 0,
+ & 226,0.009,100, 2, 10, 3,111, 0,
+ & 226,0.004,100, 4, 8, 3,111, 0,
+ & 226,0.004,100, 4, 10, 1,111, 0,
+ & 227,0.090,100,121,128, 4,112, 0,
+ & 227,0.090,100,123,130, 4,112, 0/
+ DATA (IDK(I),BRFRAC(I),NME(I),(IDKPRD(J,I),J=1,5),I=1350,1368)/
+ & 227,0.045,100,125,132, 4,112, 0,
+ & 227,0.010,100,121,128, 2,112, 0,
+ & 227,0.010,100,123,130, 2,112, 0,
+ & 227,0.005,100,125,132, 2,112, 0,
+ & 227,0.242,100, 1, 8, 4,112, 0,
+ & 227,0.242,100, 3, 10, 4,112, 0,
+ & 227,0.027,100, 1, 8, 2,112, 0,
+ & 227,0.027,100, 3, 10, 2,112, 0,
+ & 227,0.012,100, 3, 8, 4,112, 0,
+ & 227,0.012,100, 1, 10, 4,112, 0,
+ & 227,0.081,100, 4, 8, 1,112, 0,
+ & 227,0.081,100, 4, 10, 3,112, 0,
+ & 227,0.009,100, 2, 8, 1,112, 0,
+ & 227,0.009,100, 2, 10, 3,112, 0,
+ & 227,0.004,100, 4, 8, 3,112, 0,
+ & 227,0.004,100, 4, 10, 1,112, 0,
+ & 228,0.090,100,121,128, 4,113, 0,
+ & 228,0.090,100,123,130, 4,113, 0,
+ & 228,0.045,100,125,132, 4,113, 0/
+ DATA (IDK(I),BRFRAC(I),NME(I),(IDKPRD(J,I),J=1,5),I=1369,1387)/
+ & 228,0.010,100,121,128, 2,113, 0,
+ & 228,0.010,100,123,130, 2,113, 0,
+ & 228,0.005,100,125,132, 2,113, 0,
+ & 228,0.242,100, 1, 8, 4,113, 0,
+ & 228,0.242,100, 3, 10, 4,113, 0,
+ & 228,0.027,100, 1, 8, 2,113, 0,
+ & 228,0.027,100, 3, 10, 2,113, 0,
+ & 228,0.012,100, 3, 8, 4,113, 0,
+ & 228,0.012,100, 1, 10, 4,113, 0,
+ & 228,0.081,100, 4, 8, 1,113, 0,
+ & 228,0.081,100, 4, 10, 3,113, 0,
+ & 228,0.009,100, 2, 8, 1,113, 0,
+ & 228,0.009,100, 2, 10, 3,113, 0,
+ & 228,0.004,100, 4, 8, 3,113, 0,
+ & 228,0.004,100, 4, 10, 1,113, 0,
+ & 229,0.090,100,121,128, 4,114, 0,
+ & 229,0.090,100,123,130, 4,114, 0,
+ & 229,0.045,100,125,132, 4,114, 0,
+ & 229,0.010,100,121,128, 2,114, 0/
+ DATA (IDK(I),BRFRAC(I),NME(I),(IDKPRD(J,I),J=1,5),I=1388,1406)/
+ & 229,0.010,100,123,130, 2,114, 0,
+ & 229,0.005,100,125,132, 2,114, 0,
+ & 229,0.242,100, 1, 8, 4,114, 0,
+ & 229,0.242,100, 3, 10, 4,114, 0,
+ & 229,0.027,100, 1, 8, 2,114, 0,
+ & 229,0.027,100, 3, 10, 2,114, 0,
+ & 229,0.012,100, 3, 8, 4,114, 0,
+ & 229,0.012,100, 1, 10, 4,114, 0,
+ & 229,0.081,100, 4, 8, 1,114, 0,
+ & 229,0.081,100, 4, 10, 3,114, 0,
+ & 229,0.009,100, 2, 8, 1,114, 0,
+ & 229,0.009,100, 2, 10, 3,114, 0,
+ & 229,0.004,100, 4, 8, 3,114, 0,
+ & 229,0.004,100, 4, 10, 1,114, 0,
+ & 230,0.080,100,121,128, 4, 10, 0,
+ & 230,0.080,100,123,130, 4, 10, 0,
+ & 230,0.040,100,125,132, 4, 10, 0,
+ & 230,0.080,100,121,128, 9, 5, 0,
+ & 230,0.080,100,123,130, 9, 5, 0/
+ DATA (IDK(I),BRFRAC(I),NME(I),(IDKPRD(J,I),J=1,5),I=1407,1425)/
+ & 230,0.228,100, 1, 8, 4, 10, 0,
+ & 230,0.228,100, 3, 10, 4, 10, 0,
+ & 230,0.012,100, 3, 8, 4, 10, 0,
+ & 230,0.012,100, 1, 10, 4, 10, 0,
+ & 230,0.076,100, 4, 8, 1, 10, 0,
+ & 230,0.076,100, 4, 10, 3, 10, 0,
+ & 230,0.004,100, 4, 8, 3, 10, 0,
+ & 230,0.004,100, 4, 10, 1, 10, 0,
+ & 231,0.025, 0,121,127, 0, 0, 0,
+ & 231,0.025, 0,123,129, 0, 0, 0,
+ & 231,0.025, 0,125,131, 0, 0, 0,
+ & 231,0.008, 0, 1, 7, 0, 0, 0,
+ & 231,0.033, 0, 2, 8, 0, 0, 0,
+ & 231,0.008, 0, 3, 9, 0, 0, 0,
+ & 231,0.033, 0, 4, 10, 0, 0, 0,
+ & 231,0.801,130, 13, 13, 13, 0, 0,
+ & 231,0.042,130, 13, 13, 59, 0, 0,
+ & 245,0.016,101,127,122,171, 0, 0,
+ & 245,0.016,101,129,124,171, 0, 0/
+ DATA (IDK(I),BRFRAC(I),NME(I),(IDKPRD(J,I),J=1,5),I=1426,1444)/
+ & 245,0.008,101,131,126,171, 0, 0,
+ & 245,0.048,101,127,122,172, 0, 0,
+ & 245,0.048,101,129,124,172, 0, 0,
+ & 245,0.022,101,131,126,172, 0, 0,
+ & 245,0.003,101,127,122,334, 0, 0,
+ & 245,0.003,101,129,124,334, 0, 0,
+ & 245,0.001,101,131,126,334, 0, 0,
+ & 245,0.008,101,127,122,173, 0, 0,
+ & 245,0.008,101,129,124,173, 0, 0,
+ & 245,0.004,101,131,126,173, 0, 0,
+ & 245,0.008,101,127,122,316, 0, 0,
+ & 245,0.008,101,129,124,316, 0, 0,
+ & 245,0.004,101,131,126,316, 0, 0,
+ & 245,0.013,101,127,122,174, 0, 0,
+ & 245,0.013,101,129,124,174, 0, 0,
+ & 245,0.006,101,131,126,174, 0, 0,
+ & 245,0.004, 0,171, 38, 0, 0, 0,
+ & 245,0.010, 0,171, 39, 0, 0, 0,
+ & 245,0.006, 0,171, 40, 0, 0, 0/
+ DATA (IDK(I),BRFRAC(I),NME(I),(IDKPRD(J,I),J=1,5),I=1445,1463)/
+ & 245,0.003, 0,172, 38, 0, 0, 0,
+ & 245,0.009, 0,172, 39, 0, 0, 0,
+ & 245,0.017, 0,172, 40, 0, 0, 0,
+ & 245,0.011, 0,171,144, 0, 0, 0,
+ & 245,0.015, 0,171,145, 0, 0, 0,
+ & 245,0.011, 0,172,144, 0, 0, 0,
+ & 245,0.022, 0,172,145, 0, 0, 0,
+ & 245,0.001, 0,164, 50, 0, 0, 0,
+ & 245,0.002, 0,164, 51, 0, 0, 0,
+ & 245,0.001, 0,165, 50, 0, 0, 0,
+ & 245,0.001, 0,165, 51, 0, 0, 0,
+ & 245,0.001, 0,166, 50, 0, 0, 0,
+ & 245,0.001, 0,166, 51, 0, 0, 0,
+ & 245,0.207,100, 7, 2, 10, 1, 0,
+ & 245,0.207,100, 9, 4, 10, 1, 0,
+ & 245,0.024,100, 7, 2, 8, 1, 0,
+ & 245,0.024,100, 9, 4, 8, 1, 0,
+ & 245,0.012,100, 9, 2, 10, 1, 0,
+ & 245,0.012,100, 7, 4, 10, 1, 0/
+ DATA (IDK(I),BRFRAC(I),NME(I),(IDKPRD(J,I),J=1,5),I=1464,1482)/
+ & 245,0.069,100, 10, 2, 7, 1, 0,
+ & 245,0.069,100, 10, 4, 9, 1, 0,
+ & 245,0.008,100, 8, 2, 7, 1, 0,
+ & 245,0.008,100, 8, 4, 9, 1, 0,
+ & 245,0.004,100, 10, 2, 9, 1, 0,
+ & 245,0.004,100, 10, 4, 7, 1, 0,
+ & 246,0.016,101,127,122,175, 0, 0,
+ & 246,0.016,101,129,124,175, 0, 0,
+ & 246,0.008,101,131,126,175, 0, 0,
+ & 246,0.048,101,127,122,176, 0, 0,
+ & 246,0.048,101,129,124,176, 0, 0,
+ & 246,0.022,101,131,126,176, 0, 0,
+ & 246,0.003,101,127,122,335, 0, 0,
+ & 246,0.003,101,129,124,335, 0, 0,
+ & 246,0.001,101,131,126,335, 0, 0,
+ & 246,0.008,101,127,122,177, 0, 0,
+ & 246,0.008,101,129,124,177, 0, 0,
+ & 246,0.004,101,131,126,177, 0, 0,
+ & 246,0.008,101,127,122,317, 0, 0/
+ DATA (IDK(I),BRFRAC(I),NME(I),(IDKPRD(J,I),J=1,5),I=1483,1501)/
+ & 246,0.008,101,129,124,317, 0, 0,
+ & 246,0.004,101,131,126,317, 0, 0,
+ & 246,0.013,101,127,122,178, 0, 0,
+ & 246,0.013,101,129,124,178, 0, 0,
+ & 246,0.006,101,131,126,178, 0, 0,
+ & 246,0.004, 0,175, 38, 0, 0, 0,
+ & 246,0.010, 0,175, 39, 0, 0, 0,
+ & 246,0.006, 0,175, 40, 0, 0, 0,
+ & 246,0.003, 0,176, 38, 0, 0, 0,
+ & 246,0.009, 0,176, 39, 0, 0, 0,
+ & 246,0.017, 0,176, 40, 0, 0, 0,
+ & 246,0.011, 0,175,144, 0, 0, 0,
+ & 246,0.015, 0,175,145, 0, 0, 0,
+ & 246,0.011, 0,176,144, 0, 0, 0,
+ & 246,0.022, 0,176,145, 0, 0, 0,
+ & 246,0.001, 0,164, 46, 0, 0, 0,
+ & 246,0.002, 0,164, 47, 0, 0, 0,
+ & 246,0.001, 0,165, 46, 0, 0, 0,
+ & 246,0.001, 0,165, 47, 0, 0, 0/
+ DATA (IDK(I),BRFRAC(I),NME(I),(IDKPRD(J,I),J=1,5),I=1502,1520)/
+ & 246,0.001, 0,166, 46, 0, 0, 0,
+ & 246,0.001, 0,166, 47, 0, 0, 0,
+ & 246,0.207,100, 7, 2, 10, 2, 0,
+ & 246,0.207,100, 9, 4, 10, 2, 0,
+ & 246,0.024,100, 7, 2, 8, 2, 0,
+ & 246,0.024,100, 9, 4, 8, 2, 0,
+ & 246,0.012,100, 9, 2, 10, 2, 0,
+ & 246,0.012,100, 7, 4, 10, 2, 0,
+ & 246,0.069,100, 10, 2, 7, 2, 0,
+ & 246,0.069,100, 10, 4, 9, 2, 0,
+ & 246,0.008,100, 8, 2, 7, 2, 0,
+ & 246,0.008,100, 8, 4, 9, 2, 0,
+ & 246,0.004,100, 10, 2, 9, 2, 0,
+ & 246,0.004,100, 10, 4, 7, 2, 0,
+ & 247,0.016,101,127,122,179, 0, 0,
+ & 247,0.016,101,129,124,179, 0, 0,
+ & 247,0.008,101,131,126,179, 0, 0,
+ & 247,0.048,101,127,122,180, 0, 0,
+ & 247,0.048,101,129,124,180, 0, 0/
+ DATA (IDK(I),BRFRAC(I),NME(I),(IDKPRD(J,I),J=1,5),I=1521,1539)/
+ & 247,0.022,101,131,126,180, 0, 0,
+ & 247,0.003,101,127,122,336, 0, 0,
+ & 247,0.003,101,129,124,336, 0, 0,
+ & 247,0.001,101,131,126,336, 0, 0,
+ & 247,0.008,101,127,122,181, 0, 0,
+ & 247,0.008,101,129,124,181, 0, 0,
+ & 247,0.004,101,131,126,181, 0, 0,
+ & 247,0.008,101,127,122,318, 0, 0,
+ & 247,0.008,101,129,124,318, 0, 0,
+ & 247,0.004,101,131,126,318, 0, 0,
+ & 247,0.013,101,127,122,182, 0, 0,
+ & 247,0.013,101,129,124,182, 0, 0,
+ & 247,0.006,101,131,126,182, 0, 0,
+ & 247,0.004, 0,179, 38, 0, 0, 0,
+ & 247,0.010, 0,179, 39, 0, 0, 0,
+ & 247,0.006, 0,179, 40, 0, 0, 0,
+ & 247,0.003, 0,180, 38, 0, 0, 0,
+ & 247,0.009, 0,180, 39, 0, 0, 0,
+ & 247,0.017, 0,180, 40, 0, 0, 0/
+ DATA (IDK(I),BRFRAC(I),NME(I),(IDKPRD(J,I),J=1,5),I=1540,1558)/
+ & 247,0.011, 0,179,144, 0, 0, 0,
+ & 247,0.015, 0,179,145, 0, 0, 0,
+ & 247,0.011, 0,180,144, 0, 0, 0,
+ & 247,0.022, 0,180,145, 0, 0, 0,
+ & 247,0.001, 0,164, 25, 0, 0, 0,
+ & 247,0.002, 0,164, 56, 0, 0, 0,
+ & 247,0.001, 0,165, 25, 0, 0, 0,
+ & 247,0.001, 0,165, 56, 0, 0, 0,
+ & 247,0.001, 0,166, 25, 0, 0, 0,
+ & 247,0.001, 0,166, 56, 0, 0, 0,
+ & 247,0.207,100, 7, 2, 10, 3, 0,
+ & 247,0.207,100, 9, 4, 10, 3, 0,
+ & 247,0.024,100, 7, 2, 8, 3, 0,
+ & 247,0.024,100, 9, 4, 8, 3, 0,
+ & 247,0.012,100, 9, 2, 10, 3, 0,
+ & 247,0.012,100, 7, 4, 10, 3, 0,
+ & 247,0.069,100, 10, 2, 7, 3, 0,
+ & 247,0.069,100, 10, 4, 9, 3, 0,
+ & 247,0.008,100, 8, 2, 7, 3, 0/
+ DATA (IDK(I),BRFRAC(I),NME(I),(IDKPRD(J,I),J=1,5),I=1559,1577)/
+ & 247,0.008,100, 8, 4, 9, 3, 0,
+ & 247,0.004,100, 10, 2, 9, 3, 0,
+ & 247,0.004,100, 10, 4, 7, 3, 0,
+ & 248,0.090,100,127,122, 10,115, 0,
+ & 248,0.090,100,129,124, 10,115, 0,
+ & 248,0.045,100,131,126, 10,115, 0,
+ & 248,0.010,100,127,122, 8,115, 0,
+ & 248,0.010,100,129,124, 8,115, 0,
+ & 248,0.005,100,131,126, 8,115, 0,
+ & 248,0.242,100, 7, 2, 10,115, 0,
+ & 248,0.242,100, 9, 4, 10,115, 0,
+ & 248,0.027,100, 7, 2, 8,115, 0,
+ & 248,0.027,100, 9, 4, 8,115, 0,
+ & 248,0.012,100, 9, 2, 10,115, 0,
+ & 248,0.012,100, 7, 4, 10,115, 0,
+ & 248,0.081,100, 10, 2, 7,115, 0,
+ & 248,0.081,100, 10, 4, 9,115, 0,
+ & 248,0.009,100, 8, 2, 7,115, 0,
+ & 248,0.009,100, 8, 4, 9,115, 0/
+ DATA (IDK(I),BRFRAC(I),NME(I),(IDKPRD(J,I),J=1,5),I=1578,1596)/
+ & 248,0.004,100, 10, 2, 9,115, 0,
+ & 248,0.004,100, 10, 4, 7,115, 0,
+ & 249,0.090,100,127,122, 10,116, 0,
+ & 249,0.090,100,129,124, 10,116, 0,
+ & 249,0.045,100,131,126, 10,116, 0,
+ & 249,0.010,100,127,122, 8,116, 0,
+ & 249,0.010,100,129,124, 8,116, 0,
+ & 249,0.005,100,131,126, 8,116, 0,
+ & 249,0.242,100, 7, 2, 10,116, 0,
+ & 249,0.242,100, 9, 4, 10,116, 0,
+ & 249,0.027,100, 7, 2, 8,116, 0,
+ & 249,0.027,100, 9, 4, 8,116, 0,
+ & 249,0.012,100, 9, 2, 10,116, 0,
+ & 249,0.012,100, 7, 4, 10,116, 0,
+ & 249,0.081,100, 10, 2, 7,116, 0,
+ & 249,0.081,100, 10, 4, 9,116, 0,
+ & 249,0.009,100, 8, 2, 7,116, 0,
+ & 249,0.009,100, 8, 4, 9,116, 0,
+ & 249,0.004,100, 10, 2, 9,116, 0/
+ DATA (IDK(I),BRFRAC(I),NME(I),(IDKPRD(J,I),J=1,5),I=1597,1615)/
+ & 249,0.004,100, 10, 4, 7,116, 0,
+ & 250,0.090,100,127,122, 10,117, 0,
+ & 250,0.090,100,129,124, 10,117, 0,
+ & 250,0.045,100,131,126, 10,117, 0,
+ & 250,0.010,100,127,122, 8,117, 0,
+ & 250,0.010,100,129,124, 8,117, 0,
+ & 250,0.005,100,131,126, 8,117, 0,
+ & 250,0.242,100, 7, 2, 10,117, 0,
+ & 250,0.242,100, 9, 4, 10,117, 0,
+ & 250,0.027,100, 7, 2, 8,117, 0,
+ & 250,0.027,100, 9, 4, 8,117, 0,
+ & 250,0.012,100, 9, 2, 10,117, 0,
+ & 250,0.012,100, 7, 4, 10,117, 0,
+ & 250,0.081,100, 10, 2, 7,117, 0,
+ & 250,0.081,100, 10, 4, 9,117, 0,
+ & 250,0.009,100, 8, 2, 7,117, 0,
+ & 250,0.009,100, 8, 4, 9,117, 0,
+ & 250,0.004,100, 10, 2, 9,117, 0,
+ & 250,0.004,100, 10, 4, 7,117, 0/
+ DATA (IDK(I),BRFRAC(I),NME(I),(IDKPRD(J,I),J=1,5),I=1616,1634)/
+ & 251,0.090,100,127,122, 10,118, 0,
+ & 251,0.090,100,129,124, 10,118, 0,
+ & 251,0.045,100,131,126, 10,118, 0,
+ & 251,0.010,100,127,122, 8,118, 0,
+ & 251,0.010,100,129,124, 8,118, 0,
+ & 251,0.005,100,131,126, 8,118, 0,
+ & 251,0.242,100, 7, 2, 10,118, 0,
+ & 251,0.242,100, 9, 4, 10,118, 0,
+ & 251,0.027,100, 7, 2, 8,118, 0,
+ & 251,0.027,100, 9, 4, 8,118, 0,
+ & 251,0.012,100, 9, 2, 10,118, 0,
+ & 251,0.012,100, 7, 4, 10,118, 0,
+ & 251,0.081,100, 10, 2, 7,118, 0,
+ & 251,0.081,100, 10, 4, 9,118, 0,
+ & 251,0.009,100, 8, 2, 7,118, 0,
+ & 251,0.009,100, 8, 4, 9,118, 0,
+ & 251,0.004,100, 10, 2, 9,118, 0,
+ & 251,0.004,100, 10, 4, 7,118, 0,
+ & 252,0.090,100,127,122, 10,119, 0/
+ DATA (IDK(I),BRFRAC(I),NME(I),(IDKPRD(J,I),J=1,5),I=1635,1653)/
+ & 252,0.090,100,129,124, 10,119, 0,
+ & 252,0.045,100,131,126, 10,119, 0,
+ & 252,0.010,100,127,122, 8,119, 0,
+ & 252,0.010,100,129,124, 8,119, 0,
+ & 252,0.005,100,131,126, 8,119, 0,
+ & 252,0.242,100, 7, 2, 10,119, 0,
+ & 252,0.242,100, 9, 4, 10,119, 0,
+ & 252,0.027,100, 7, 2, 8,119, 0,
+ & 252,0.027,100, 9, 4, 8,119, 0,
+ & 252,0.012,100, 9, 2, 10,119, 0,
+ & 252,0.012,100, 7, 4, 10,119, 0,
+ & 252,0.081,100, 10, 2, 7,119, 0,
+ & 252,0.081,100, 10, 4, 9,119, 0,
+ & 252,0.009,100, 8, 2, 7,119, 0,
+ & 252,0.009,100, 8, 4, 9,119, 0,
+ & 252,0.004,100, 10, 2, 9,119, 0,
+ & 252,0.004,100, 10, 4, 7,119, 0,
+ & 253,0.090,100,127,122, 10,120, 0,
+ & 253,0.090,100,129,124, 10,120, 0/
+ DATA (IDK(I),BRFRAC(I),NME(I),(IDKPRD(J,I),J=1,5),I=1654,1672)/
+ & 253,0.045,100,131,126, 10,120, 0,
+ & 253,0.010,100,127,122, 8,120, 0,
+ & 253,0.010,100,129,124, 8,120, 0,
+ & 253,0.005,100,131,126, 8,120, 0,
+ & 253,0.242,100, 7, 2, 10,120, 0,
+ & 253,0.242,100, 9, 4, 10,120, 0,
+ & 253,0.027,100, 7, 2, 8,120, 0,
+ & 253,0.027,100, 9, 4, 8,120, 0,
+ & 253,0.012,100, 9, 2, 10,120, 0,
+ & 253,0.012,100, 7, 4, 10,120, 0,
+ & 253,0.081,100, 10, 2, 7,120, 0,
+ & 253,0.081,100, 10, 4, 9,120, 0,
+ & 253,0.009,100, 8, 2, 7,120, 0,
+ & 253,0.009,100, 8, 4, 9,120, 0,
+ & 253,0.004,100, 10, 2, 9,120, 0,
+ & 253,0.004,100, 10, 4, 7,120, 0,
+ & 254,0.080,100,127,122, 10, 4, 0,
+ & 254,0.080,100,129,124, 10, 4, 0,
+ & 254,0.040,100,131,126, 10, 4, 0/
+ DATA (IDK(I),BRFRAC(I),NME(I),(IDKPRD(J,I),J=1,5),I=1673,1691)/
+ & 254,0.080,100,127,122, 3, 11, 0,
+ & 254,0.080,100,129,124, 3, 11, 0,
+ & 254,0.228,100, 7, 2, 10, 4, 0,
+ & 254,0.228,100, 9, 4, 10, 4, 0,
+ & 254,0.012,100, 9, 2, 10, 4, 0,
+ & 254,0.012,100, 7, 4, 10, 4, 0,
+ & 254,0.076,100, 10, 2, 7, 4, 0,
+ & 254,0.076,100, 10, 4, 9, 4, 0,
+ & 254,0.004,100, 10, 2, 9, 4, 0,
+ & 254,0.004,100, 10, 4, 7, 4, 0,
+ & 265,1.000, 0,221, 59, 0, 0, 0,
+ & 266,1.000, 0,222, 59, 0, 0, 0,
+ & 267,1.000, 0,223, 59, 0, 0, 0,
+ & 268,0.667, 0,266, 38, 0, 0, 0,
+ & 268,0.333, 0,265, 21, 0, 0, 0,
+ & 269,0.667, 0,265, 30, 0, 0, 0,
+ & 269,0.333, 0,266, 21, 0, 0, 0,
+ & 270,0.500, 0,265, 50, 0, 0, 0,
+ & 270,0.500, 0,266, 46, 0, 0, 0/
+ DATA (IDK(I),BRFRAC(I),NME(I),(IDKPRD(J,I),J=1,5),I=1692,1710)/
+ & 271,0.290, 0,266, 38, 0, 0, 0,
+ & 271,0.150, 0,265, 21, 0, 0, 0,
+ & 271,0.290, 0,222, 38, 0, 0, 0,
+ & 271,0.150, 0,221, 21, 0, 0, 0,
+ & 271,0.060, 0,266, 38, 21, 0, 0,
+ & 271,0.020, 0,265, 38, 30, 0, 0,
+ & 271,0.010, 0,265, 21, 21, 0, 0,
+ & 271,0.020, 0,222, 38, 21, 0, 0,
+ & 271,0.010, 0,221, 38, 30, 0, 0,
+ & 272,0.290, 0,265, 30, 0, 0, 0,
+ & 272,0.150, 0,266, 21, 0, 0, 0,
+ & 272,0.290, 0,221, 30, 0, 0, 0,
+ & 272,0.150, 0,222, 21, 0, 0, 0,
+ & 272,0.060, 0,265, 30, 21, 0, 0,
+ & 272,0.020, 0,266, 38, 30, 0, 0,
+ & 272,0.010, 0,266, 21, 21, 0, 0,
+ & 272,0.020, 0,221, 30, 21, 0, 0,
+ & 272,0.010, 0,222, 38, 30, 0, 0,
+ & 273,0.350, 0,221, 50, 0, 0, 0/
+ DATA (IDK(I),BRFRAC(I),NME(I),(IDKPRD(J,I),J=1,5),I=1711,1729)/
+ & 273,0.350, 0,222, 46, 0, 0, 0,
+ & 273,0.150, 0,265, 50, 0, 0, 0,
+ & 273,0.150, 0,266, 46, 0, 0, 0,
+ & 274,1.000, 0,245, 59, 0, 0, 0,
+ & 275,1.000, 0,246, 59, 0, 0, 0,
+ & 276,1.000, 0,247, 59, 0, 0, 0,
+ & 277,0.667, 0,275, 30, 0, 0, 0,
+ & 277,0.333, 0,274, 21, 0, 0, 0,
+ & 278,0.667, 0,274, 38, 0, 0, 0,
+ & 278,0.333, 0,275, 21, 0, 0, 0,
+ & 279,0.500, 0,274, 42, 0, 0, 0,
+ & 279,0.500, 0,275, 34, 0, 0, 0,
+ & 280,0.290, 0,275, 30, 0, 0, 0,
+ & 280,0.150, 0,274, 21, 0, 0, 0,
+ & 280,0.290, 0,246, 30, 0, 0, 0,
+ & 280,0.150, 0,245, 21, 0, 0, 0,
+ & 280,0.060, 0,275, 30, 21, 0, 0,
+ & 280,0.020, 0,274, 38, 30, 0, 0,
+ & 280,0.010, 0,274, 21, 21, 0, 0/
+ DATA (IDK(I),BRFRAC(I),NME(I),(IDKPRD(J,I),J=1,5),I=1730,1748)/
+ & 280,0.020, 0,246, 30, 21, 0, 0,
+ & 280,0.010, 0,245, 38, 30, 0, 0,
+ & 281,0.290, 0,274, 38, 0, 0, 0,
+ & 281,0.150, 0,275, 21, 0, 0, 0,
+ & 281,0.290, 0,245, 38, 0, 0, 0,
+ & 281,0.150, 0,246, 21, 0, 0, 0,
+ & 281,0.060, 0,274, 38, 21, 0, 0,
+ & 281,0.020, 0,275, 38, 30, 0, 0,
+ & 281,0.010, 0,275, 21, 21, 0, 0,
+ & 281,0.020, 0,245, 38, 21, 0, 0,
+ & 281,0.010, 0,246, 38, 30, 0, 0,
+ & 282,0.350, 0,245, 42, 0, 0, 0,
+ & 282,0.350, 0,246, 34, 0, 0, 0,
+ & 282,0.150, 0,274, 42, 0, 0, 0,
+ & 282,0.150, 0,275, 34, 0, 0, 0,
+ & 285,1.000, 0, 24, 21, 0, 0, 0,
+ & 286,0.998, 0, 24, 38, 0, 0, 0,
+ & 286,0.002, 0, 38, 59, 0, 0, 0,
+ & 287,0.998, 0, 24, 30, 0, 0, 0/
+ DATA (IDK(I),BRFRAC(I),NME(I),(IDKPRD(J,I),J=1,5),I=1749,1767)/
+ & 287,0.002, 0, 30, 59, 0, 0, 0,
+ & 288,0.330, 0, 39, 30, 0, 0, 0,
+ & 288,0.340, 0, 23, 21, 0, 0, 0,
+ & 288,0.330, 0, 31, 38, 0, 0, 0,
+ & 289,0.250, 0, 46, 35, 0, 0, 0,
+ & 289,0.250, 0, 34, 47, 0, 0, 0,
+ & 289,0.250, 0, 50, 43, 0, 0, 0,
+ & 289,0.250, 0, 42, 51, 0, 0, 0,
+ & 290,0.996, 0, 22, 21, 0, 0, 0,
+ & 290,0.002, 0, 46, 34, 0, 0, 0,
+ & 290,0.002, 0, 50, 42, 0, 0, 0,
+ & 291,0.996, 0, 22, 38, 0, 0, 0,
+ & 291,0.004, 0, 46, 42, 0, 0, 0,
+ & 292,0.996, 0, 22, 30, 0, 0, 0,
+ & 292,0.004, 0, 50, 34, 0, 0, 0,
+ & 293,0.520, 0, 38, 30, 0, 0, 0,
+ & 293,0.260, 0, 21, 21, 0, 0, 0,
+ & 293,0.110, 0, 46, 34, 0, 0, 0,
+ & 293,0.110, 0, 50, 42, 0, 0, 0/
+ DATA (IDK(I),BRFRAC(I),NME(I),(IDKPRD(J,I),J=1,5),I=1768,1786)/
+ & 294,0.620, 0, 38, 30, 0, 0, 0,
+ & 294,0.310, 0, 21, 21, 0, 0, 0,
+ & 294,0.035, 0, 46, 34, 0, 0, 0,
+ & 294,0.035, 0, 50, 42, 0, 0, 0,
+ & 295,1.000, 0,254, 59, 0, 0, 0,
+ & 296,1.000, 0,230, 59, 0, 0, 0,
+ & 297,1.000, 0,254, 59, 0, 0, 0,
+ & 298,1.000, 0,230, 59, 0, 0, 0,
+ & 299,1.000, 0,254, 59, 0, 0, 0,
+ & 300,1.000, 0,230, 59, 0, 0, 0,
+ & 301,0.050, 0,121,127, 0, 0, 0,
+ & 301,0.050, 0,123,129, 0, 0, 0,
+ & 301,0.017, 0, 1, 7, 0, 0, 0,
+ & 301,0.066, 0, 2, 8, 0, 0, 0,
+ & 301,0.017, 0, 3, 9, 0, 0, 0,
+ & 301,0.640,130, 13, 13, 13, 0, 0,
+ & 301,0.160,130, 13, 13, 59, 0, 0,
+ & 302,0.022, 0, 38, 30, 38, 30, 23,
+ & 302,0.016, 0, 38, 30, 38, 30, 0/
+ DATA (IDK(I),BRFRAC(I),NME(I),(IDKPRD(J,I),J=1,5),I=1787,1805)/
+ & 302,0.009, 0, 38, 30, 46, 34, 0,
+ & 302,0.004, 0, 23, 38, 30, 0, 0,
+ & 302,0.002, 0, 46, 43, 30, 0, 0,
+ & 302,0.002, 0, 34, 51, 38, 0, 0,
+ & 302,0.001, 0, 38, 30, 73, 91, 0,
+ & 302,0.273, 0, 59,164, 0, 0, 0,
+ & 302,0.671, 0, 13, 13, 0, 0, 0,
+ & 303,0.022, 0, 38, 30, 38, 30, 0,
+ & 303,0.019, 0, 38, 30, 46, 34, 0,
+ & 303,0.012, 0, 38, 30, 38, 30, 23,
+ & 303,0.007, 0, 23, 38, 30, 0, 0,
+ & 303,0.002, 0, 46, 43, 30, 0, 0,
+ & 303,0.002, 0, 34, 51, 38, 0, 0,
+ & 303,0.003, 0, 38, 30, 73, 91, 0,
+ & 303,0.002, 0, 38, 30, 0, 0, 0,
+ & 303,0.002, 0, 46, 34, 0, 0, 0,
+ & 303,0.001, 0, 21, 21, 0, 0, 0,
+ & 303,0.135, 0, 59,164, 0, 0, 0,
+ & 303,0.793, 0, 13, 13, 0, 0, 0/
+ DATA (IDK(I),BRFRAC(I),NME(I),(IDKPRD(J,I),J=1,5),I=1806,1824)/
+ & 304,1.000, 0, 13, 13, 0, 0, 0,
+ & 305,1.000, 0, 13, 13, 0, 0, 0,
+ & 306,0.050, 0, 59,231, 0, 0, 0,
+ & 306,0.950, 0, 13, 13, 0, 0, 0,
+ & 307,0.350, 0, 59,231, 0, 0, 0,
+ & 307,0.650, 0, 13, 13, 0, 0, 0,
+ & 308,0.220, 0, 59,231, 0, 0, 0,
+ & 308,0.780, 0, 13, 13, 0, 0, 0,
+ & 309,0.280, 0, 46, 31, 0, 0, 0,
+ & 309,0.140, 0, 50, 23, 0, 0, 0,
+ & 309,0.187, 0,327, 30, 0, 0, 0,
+ & 309,0.093, 0,328, 21, 0, 0, 0,
+ & 309,0.110, 0, 50, 24, 0, 0, 0,
+ & 309,0.107, 0, 47, 30, 0, 0, 0,
+ & 309,0.053, 0, 51, 21, 0, 0, 0,
+ & 309,0.030, 0, 50,293, 0, 0, 0,
+ & 310,0.280, 0, 50, 39, 0, 0, 0,
+ & 310,0.140, 0, 46, 23, 0, 0, 0,
+ & 310,0.187, 0,328, 38, 0, 0, 0/
+ DATA (IDK(I),BRFRAC(I),NME(I),(IDKPRD(J,I),J=1,5),I=1825,1843)/
+ & 310,0.093, 0,327, 21, 0, 0, 0,
+ & 310,0.110, 0, 46, 24, 0, 0, 0,
+ & 310,0.107, 0, 51, 38, 0, 0, 0,
+ & 310,0.053, 0, 47, 21, 0, 0, 0,
+ & 310,0.030, 0, 46,293, 0, 0, 0,
+ & 311,0.280, 0, 34, 39, 0, 0, 0,
+ & 311,0.140, 0, 42, 23, 0, 0, 0,
+ & 311,0.187, 0,330, 38, 0, 0, 0,
+ & 311,0.093, 0,329, 21, 0, 0, 0,
+ & 311,0.110, 0, 42, 24, 0, 0, 0,
+ & 311,0.107, 0, 35, 38, 0, 0, 0,
+ & 311,0.053, 0, 43, 21, 0, 0, 0,
+ & 311,0.030, 0, 42,293, 0, 0, 0,
+ & 312,0.280, 0, 42, 31, 0, 0, 0,
+ & 312,0.140, 0, 34, 23, 0, 0, 0,
+ & 312,0.187, 0,329, 30, 0, 0, 0,
+ & 312,0.093, 0,330, 21, 0, 0, 0,
+ & 312,0.110, 0, 34, 24, 0, 0, 0,
+ & 312,0.107, 0, 43, 30, 0, 0, 0/
+ DATA (IDK(I),BRFRAC(I),NME(I),(IDKPRD(J,I),J=1,5),I=1844,1862)/
+ & 312,0.053, 0, 35, 21, 0, 0, 0,
+ & 312,0.030, 0, 34,293, 0, 0, 0,
+ & 313,0.430, 0,140, 38, 0, 0, 0,
+ & 313,0.215, 0,136, 21, 0, 0, 0,
+ & 313,0.235, 0,140, 38, 21, 0, 0,
+ & 313,0.120, 0,136, 38, 30, 0, 0,
+ & 314,0.430, 0,136, 30, 0, 0, 0,
+ & 314,0.215, 0,140, 21, 0, 0, 0,
+ & 314,0.235, 0,136, 30, 21, 0, 0,
+ & 314,0.120, 0,140, 38, 30, 0, 0,
+ & 315,0.480, 0,136, 50, 0, 0, 0,
+ & 315,0.480, 0,140, 46, 0, 0, 0,
+ & 315,0.040, 0,145, 59, 0, 0, 0,
+ & 316,0.430, 0,175, 30, 0, 0, 0,
+ & 316,0.215, 0,171, 21, 0, 0, 0,
+ & 316,0.235, 0,175, 30, 21, 0, 0,
+ & 316,0.120, 0,171, 38, 30, 0, 0,
+ & 317,0.430, 0,171, 38, 0, 0, 0,
+ & 317,0.215, 0,175, 21, 0, 0, 0/
+ DATA (IDK(I),BRFRAC(I),NME(I),(IDKPRD(J,I),J=1,5),I=1863,1881)/
+ & 317,0.235, 0,171, 38, 21, 0, 0,
+ & 317,0.120, 0,175, 38, 30, 0, 0,
+ & 318,0.480, 0,171, 42, 0, 0, 0,
+ & 318,0.480, 0,175, 34, 0, 0, 0,
+ & 318,0.040, 0,180, 59, 0, 0, 0,
+ & 319,0.540, 0,275, 30, 0, 0, 0,
+ & 319,0.270, 0,274, 21, 0, 0, 0,
+ & 319,0.030, 0,275, 30, 21, 0, 0,
+ & 319,0.010, 0,274, 38, 30, 0, 0,
+ & 319,0.010, 0,274, 21, 21, 0, 0,
+ & 319,0.090, 0,246, 30, 21, 0, 0,
+ & 319,0.030, 0,245, 38, 30, 0, 0,
+ & 319,0.020, 0,245, 21, 21, 0, 0,
+ & 320,0.540, 0,274, 38, 0, 0, 0,
+ & 320,0.270, 0,275, 21, 0, 0, 0,
+ & 320,0.030, 0,274, 38, 21, 0, 0,
+ & 320,0.010, 0,275, 38, 30, 0, 0,
+ & 320,0.010, 0,275, 21, 21, 0, 0,
+ & 320,0.090, 0,245, 38, 21, 0, 0/
+ DATA (IDK(I),BRFRAC(I),NME(I),(IDKPRD(J,I),J=1,5),I=1882,1900)/
+ & 320,0.030, 0,246, 38, 30, 0, 0,
+ & 320,0.020, 0,246, 21, 21, 0, 0,
+ & 321,0.500, 0,266, 46, 0, 0, 0,
+ & 321,0.500, 0,265, 50, 0, 0, 0,
+ & 322,1.000, 0,254, 59, 0, 0, 0,
+ & 323,0.540, 0,266, 38, 0, 0, 0,
+ & 323,0.270, 0,265, 21, 0, 0, 0,
+ & 323,0.030, 0,266, 38, 21, 0, 0,
+ & 323,0.010, 0,265, 38, 30, 0, 0,
+ & 323,0.010, 0,265, 21, 21, 0, 0,
+ & 323,0.090, 0,222, 38, 21, 0, 0,
+ & 323,0.030, 0,221, 38, 30, 0, 0,
+ & 323,0.020, 0,221, 21, 21, 0, 0,
+ & 324,0.540, 0,265, 30, 0, 0, 0,
+ & 324,0.270, 0,266, 21, 0, 0, 0,
+ & 324,0.030, 0,265, 30, 21, 0, 0,
+ & 324,0.010, 0,266, 38, 30, 0, 0,
+ & 324,0.010, 0,266, 21, 21, 0, 0,
+ & 324,0.090, 0,221, 30, 21, 0, 0/
+ DATA (IDK(I),BRFRAC(I),NME(I),(IDKPRD(J,I),J=1,5),I=1901,1919)/
+ & 324,0.030, 0,222, 38, 30, 0, 0,
+ & 324,0.020, 0,222, 21, 21, 0, 0,
+ & 325,0.500, 0,275, 34, 0, 0, 0,
+ & 325,0.500, 0,274, 42, 0, 0, 0,
+ & 326,1.000, 0,230, 59, 0, 0, 0,
+ & 327,0.667, 0, 50, 38, 0, 0, 0,
+ & 327,0.333, 0, 46, 21, 0, 0, 0,
+ & 328,0.667, 0, 46, 30, 0, 0, 0,
+ & 328,0.333, 0, 50, 21, 0, 0, 0,
+ & 329,0.667, 0, 34, 38, 0, 0, 0,
+ & 329,0.333, 0, 42, 21, 0, 0, 0,
+ & 330,0.667, 0, 42, 30, 0, 0, 0,
+ & 330,0.333, 0, 34, 21, 0, 0, 0,
+ & 331,0.667, 0,140, 38, 0, 0, 0,
+ & 331,0.333, 0,136, 21, 0, 0, 0,
+ & 332,0.667, 0,136, 30, 0, 0, 0,
+ & 332,0.333, 0,140, 21, 0, 0, 0,
+ & 333,0.500, 0,136, 50, 0, 0, 0,
+ & 333,0.500, 0,140, 46, 0, 0, 0/
+ DATA (IDK(I),BRFRAC(I),NME(I),(IDKPRD(J,I),J=1,5),I=1920,1938)/
+ & 334,0.667, 0,175, 30, 0, 0, 0,
+ & 334,0.333, 0,171, 21, 0, 0, 0,
+ & 335,0.667, 0,171, 38, 0, 0, 0,
+ & 335,0.333, 0,175, 21, 0, 0, 0,
+ & 336,0.500, 0,171, 42, 0, 0, 0,
+ & 336,0.500, 0,175, 34, 0, 0, 0,
+ & 337,0.667, 0,246, 30, 0, 0, 0,
+ & 337,0.333, 0,245, 21, 0, 0, 0,
+ & 338,0.667, 0,245, 38, 0, 0, 0,
+ & 338,0.333, 0,246, 21, 0, 0, 0,
+ & 339,0.500, 0,246, 34, 0, 0, 0,
+ & 339,0.500, 0,245, 42, 0, 0, 0,
+ & 340,1.000, 0,254, 59, 0, 0, 0,
+ & 341,0.667, 0,222, 38, 0, 0, 0,
+ & 341,0.333, 0,221, 21, 0, 0, 0,
+ & 342,0.667, 0,221, 30, 0, 0, 0,
+ & 342,0.333, 0,222, 21, 0, 0, 0,
+ & 343,0.500, 0,222, 46, 0, 0, 0,
+ & 343,0.500, 0,221, 50, 0, 0, 0/
+ DATA (IDK(I),BRFRAC(I),NME(I),(IDKPRD(J,I),J=1,5),I=1939,1957)/
+ & 344,1.000, 0,230, 59, 0, 0, 0,
+ & 345,1.000, 0,225, 30, 0, 0, 0,
+ & 346,1.000, 0,225, 21, 0, 0, 0,
+ & 347,1.000, 0,225, 21, 0, 0, 0,
+ & 348,1.000, 0,225, 38, 0, 0, 0,
+ & 349,0.600, 0,228, 38, 0, 0, 0,
+ & 349,0.300, 0,227, 21, 0, 0, 0,
+ & 349,0.100, 0,227, 59, 0, 0, 0,
+ & 350,0.600, 0,228, 38, 0, 0, 0,
+ & 350,0.300, 0,227, 21, 0, 0, 0,
+ & 350,0.100, 0,227, 59, 0, 0, 0,
+ & 351,0.600, 0,227, 30, 0, 0, 0,
+ & 351,0.300, 0,228, 21, 0, 0, 0,
+ & 351,0.100, 0,228, 59, 0, 0, 0,
+ & 352,0.600, 0,227, 30, 0, 0, 0,
+ & 352,0.300, 0,228, 21, 0, 0, 0,
+ & 352,0.100, 0,228, 59, 0, 0, 0,
+ & 353,1.000, 0,229, 59, 0, 0, 0,
+ & 354,1.000, 0,249, 38, 0, 0, 0/
+ DATA (IDK(I),BRFRAC(I),NME(I),(IDKPRD(J,I),J=1,5),I=1958,1976)/
+ & 355,1.000, 0,249, 21, 0, 0, 0,
+ & 356,1.000, 0,249, 21, 0, 0, 0,
+ & 357,1.000, 0,249, 30, 0, 0, 0,
+ & 358,0.600, 0,252, 30, 0, 0, 0,
+ & 358,0.300, 0,251, 21, 0, 0, 0,
+ & 358,0.100, 0,251, 59, 0, 0, 0,
+ & 359,0.600, 0,252, 30, 0, 0, 0,
+ & 359,0.300, 0,251, 21, 0, 0, 0,
+ & 359,0.100, 0,251, 59, 0, 0, 0,
+ & 360,0.600, 0,251, 38, 0, 0, 0,
+ & 360,0.300, 0,252, 21, 0, 0, 0,
+ & 360,0.100, 0,252, 59, 0, 0, 0,
+ & 361,0.600, 0,251, 38, 0, 0, 0,
+ & 361,0.300, 0,252, 21, 0, 0, 0,
+ & 361,0.100, 0,252, 59, 0, 0, 0,
+ & 362,1.000, 0,253, 59, 0, 0, 0,
+ & 363,0.400, 0, 53, 38, 0, 0, 0,
+ & 363,0.200, 0, 49, 21, 0, 0, 0,
+ & 363,0.100, 0, 51, 38, 0, 0, 0/
+ DATA (IDK(I),BRFRAC(I),NME(I),(IDKPRD(J,I),J=1,5),I=1977,1995)/
+ & 363,0.050, 0, 47, 21, 0, 0, 0,
+ & 363,0.150, 0, 46, 26, 0, 0, 0,
+ & 363,0.050, 0, 46, 56, 0, 0, 0,
+ & 363,0.050, 0, 46, 24, 0, 0, 0,
+ & 364,0.400, 0, 49, 30, 0, 0, 0,
+ & 364,0.200, 0, 53, 21, 0, 0, 0,
+ & 364,0.100, 0, 47, 30, 0, 0, 0,
+ & 364,0.050, 0, 51, 21, 0, 0, 0,
+ & 364,0.150, 0, 50, 26, 0, 0, 0,
+ & 364,0.050, 0, 50, 56, 0, 0, 0,
+ & 364,0.050, 0, 50, 24, 0, 0, 0,
+ & 365,0.400, 0, 37, 38, 0, 0, 0,
+ & 365,0.200, 0, 45, 21, 0, 0, 0,
+ & 365,0.100, 0, 35, 38, 0, 0, 0,
+ & 365,0.050, 0, 43, 21, 0, 0, 0,
+ & 365,0.150, 0, 42, 26, 0, 0, 0,
+ & 365,0.050, 0, 42, 56, 0, 0, 0,
+ & 365,0.050, 0, 42, 24, 0, 0, 0,
+ & 366,0.400, 0, 45, 30, 0, 0, 0/
+ DATA (IDK(I),BRFRAC(I),NME(I),(IDKPRD(J,I),J=1,5),I=1996,2014)/
+ & 366,0.200, 0, 37, 21, 0, 0, 0,
+ & 366,0.100, 0, 43, 30, 0, 0, 0,
+ & 366,0.050, 0, 35, 21, 0, 0, 0,
+ & 366,0.150, 0, 34, 26, 0, 0, 0,
+ & 366,0.050, 0, 34, 56, 0, 0, 0,
+ & 366,0.050, 0, 34, 24, 0, 0, 0,
+ & 367,0.258, 0, 50, 38, 0, 0, 0,
+ & 367,0.129, 0, 46, 21, 0, 0, 0,
+ & 367,0.209, 0, 50, 39, 0, 0, 0,
+ & 367,0.105, 0, 46, 23, 0, 0, 0,
+ & 367,0.199, 0, 51, 38, 0, 0, 0,
+ & 367,0.100, 0, 47, 21, 0, 0, 0,
+ & 368,0.258, 0, 46, 30, 0, 0, 0,
+ & 368,0.129, 0, 50, 21, 0, 0, 0,
+ & 368,0.209, 0, 46, 31, 0, 0, 0,
+ & 368,0.105, 0, 50, 23, 0, 0, 0,
+ & 368,0.199, 0, 47, 30, 0, 0, 0,
+ & 368,0.100, 0, 51, 21, 0, 0, 0,
+ & 369,0.258, 0, 34, 38, 0, 0, 0/
+ DATA (IDK(I),BRFRAC(I),NME(I),(IDKPRD(J,I),J=1,5),I=2015,2033)/
+ & 369,0.129, 0, 42, 21, 0, 0, 0,
+ & 369,0.209, 0, 34, 39, 0, 0, 0,
+ & 369,0.105, 0, 42, 23, 0, 0, 0,
+ & 369,0.199, 0, 35, 38, 0, 0, 0,
+ & 369,0.100, 0, 43, 21, 0, 0, 0,
+ & 370,0.258, 0, 42, 30, 0, 0, 0,
+ & 370,0.129, 0, 34, 21, 0, 0, 0,
+ & 370,0.209, 0, 42, 31, 0, 0, 0,
+ & 370,0.105, 0, 34, 23, 0, 0, 0,
+ & 370,0.199, 0, 43, 30, 0, 0, 0,
+ & 370,0.100, 0, 35, 21, 0, 0, 0,
+ & 371,0.400, 0, 53, 38, 0, 0, 0,
+ & 371,0.200, 0, 49, 21, 0, 0, 0,
+ & 371,0.100, 0, 51, 38, 0, 0, 0,
+ & 371,0.050, 0, 47, 21, 0, 0, 0,
+ & 371,0.150, 0, 46, 26, 0, 0, 0,
+ & 371,0.050, 0, 46, 56, 0, 0, 0,
+ & 371,0.050, 0, 46, 24, 0, 0, 0,
+ & 372,0.400, 0, 49, 30, 0, 0, 0/
+ DATA (IDK(I),BRFRAC(I),NME(I),(IDKPRD(J,I),J=1,5),I=2034,2052)/
+ & 372,0.200, 0, 53, 21, 0, 0, 0,
+ & 372,0.100, 0, 47, 30, 0, 0, 0,
+ & 372,0.050, 0, 51, 21, 0, 0, 0,
+ & 372,0.150, 0, 50, 26, 0, 0, 0,
+ & 372,0.050, 0, 50, 56, 0, 0, 0,
+ & 372,0.050, 0, 50, 24, 0, 0, 0,
+ & 373,0.400, 0, 37, 38, 0, 0, 0,
+ & 373,0.200, 0, 45, 21, 0, 0, 0,
+ & 373,0.100, 0, 35, 38, 0, 0, 0,
+ & 373,0.050, 0, 43, 21, 0, 0, 0,
+ & 373,0.150, 0, 42, 26, 0, 0, 0,
+ & 373,0.050, 0, 42, 56, 0, 0, 0,
+ & 373,0.050, 0, 42, 24, 0, 0, 0,
+ & 374,0.400, 0, 45, 30, 0, 0, 0,
+ & 374,0.200, 0, 37, 21, 0, 0, 0,
+ & 374,0.100, 0, 43, 30, 0, 0, 0,
+ & 374,0.050, 0, 35, 21, 0, 0, 0,
+ & 374,0.150, 0, 34, 26, 0, 0, 0,
+ & 374,0.050, 0, 34, 56, 0, 0, 0/
+ DATA (IDK(I),BRFRAC(I),NME(I),(IDKPRD(J,I),J=1,5),I=2053,2071)/
+ & 374,0.050, 0, 34, 24, 0, 0, 0,
+ & 375,0.208, 0, 50, 39, 0, 0, 0,
+ & 375,0.104, 0, 46, 23, 0, 0, 0,
+ & 375,0.134, 0, 51, 38, 0, 0, 0,
+ & 375,0.067, 0, 47, 21, 0, 0, 0,
+ & 375,0.124, 0, 50, 38, 0, 0, 0,
+ & 375,0.062, 0, 46, 21, 0, 0, 0,
+ & 375,0.301, 0, 46, 22, 0, 0, 0,
+ & 376,0.208, 0, 46, 31, 0, 0, 0,
+ & 376,0.104, 0, 50, 23, 0, 0, 0,
+ & 376,0.134, 0, 47, 30, 0, 0, 0,
+ & 376,0.067, 0, 51, 21, 0, 0, 0,
+ & 376,0.124, 0, 46, 30, 0, 0, 0,
+ & 376,0.062, 0, 50, 21, 0, 0, 0,
+ & 376,0.301, 0, 50, 22, 0, 0, 0,
+ & 377,0.208, 0, 34, 39, 0, 0, 0,
+ & 377,0.104, 0, 42, 23, 0, 0, 0,
+ & 377,0.134, 0, 35, 38, 0, 0, 0,
+ & 377,0.067, 0, 43, 21, 0, 0, 0/
+ DATA (IDK(I),BRFRAC(I),NME(I),(IDKPRD(J,I),J=1,5),I=2072,2090)/
+ & 377,0.124, 0, 34, 38, 0, 0, 0,
+ & 377,0.062, 0, 42, 21, 0, 0, 0,
+ & 377,0.301, 0, 42, 22, 0, 0, 0,
+ & 378,0.208, 0, 42, 31, 0, 0, 0,
+ & 378,0.104, 0, 34, 23, 0, 0, 0,
+ & 378,0.134, 0, 43, 30, 0, 0, 0,
+ & 378,0.067, 0, 35, 21, 0, 0, 0,
+ & 378,0.124, 0, 42, 30, 0, 0, 0,
+ & 378,0.062, 0, 34, 21, 0, 0, 0,
+ & 378,0.301, 0, 34, 22, 0, 0, 0,
+ & 379,0.562, 0, 26, 38, 0, 0, 0,
+ & 379,0.155, 0, 39, 21, 0, 0, 0,
+ & 379,0.155, 0, 23, 38, 0, 0, 0,
+ & 379,0.088, 0,293, 38, 0, 0, 0,
+ & 379,0.020, 0, 46, 43, 0, 0, 0,
+ & 379,0.020, 0, 42, 47, 0, 0, 0,
+ & 380,0.562, 0, 26, 21, 0, 0, 0,
+ & 380,0.155, 0, 39, 30, 0, 0, 0,
+ & 380,0.155, 0, 31, 38, 0, 0, 0/
+ DATA (IDK(I),BRFRAC(I),NME(I),(IDKPRD(J,I),J=1,5),I=2091,2109)/
+ & 380,0.088, 0,293, 21, 0, 0, 0,
+ & 380,0.010, 0, 46, 35, 0, 0, 0,
+ & 380,0.010, 0, 50, 43, 0, 0, 0,
+ & 380,0.010, 0, 34, 47, 0, 0, 0,
+ & 380,0.010, 0, 42, 51, 0, 0, 0,
+ & 381,0.562, 0, 26, 30, 0, 0, 0,
+ & 381,0.155, 0, 31, 21, 0, 0, 0,
+ & 381,0.155, 0, 23, 30, 0, 0, 0,
+ & 381,0.088, 0,293, 30, 0, 0, 0,
+ & 381,0.020, 0, 34, 51, 0, 0, 0,
+ & 381,0.020, 0, 50, 35, 0, 0, 0,
+ & 382,0.360, 0, 31, 38, 38, 0, 0,
+ & 382,0.180, 0, 23, 38, 21, 0, 0,
+ & 382,0.040, 0, 39, 21, 21, 0, 0,
+ & 382,0.020, 0, 39, 38, 30, 0, 0,
+ & 382,0.300, 0, 38, 21, 0, 0, 0,
+ & 382,0.040, 0, 46, 43, 0, 0, 0,
+ & 382,0.040, 0, 42, 47, 0, 0, 0,
+ & 382,0.020, 0, 22, 39, 0, 0, 0/
+ DATA (IDK(I),BRFRAC(I),NME(I),(IDKPRD(J,I),J=1,5),I=2110,2128)/
+ & 383,0.180, 0, 39, 30, 21, 0, 0,
+ & 383,0.180, 0, 31, 38, 21, 0, 0,
+ & 383,0.160, 0, 23, 21, 21, 0, 0,
+ & 383,0.080, 0, 23, 38, 30, 0, 0,
+ & 383,0.300, 0, 38, 30, 0, 0, 0,
+ & 383,0.020, 0, 46, 35, 0, 0, 0,
+ & 383,0.020, 0, 50, 43, 0, 0, 0,
+ & 383,0.020, 0, 34, 47, 0, 0, 0,
+ & 383,0.020, 0, 42, 51, 0, 0, 0,
+ & 383,0.020, 0, 22, 23, 0, 0, 0,
+ & 384,0.360, 0, 39, 30, 30, 0, 0,
+ & 384,0.180, 0, 23, 30, 21, 0, 0,
+ & 384,0.040, 0, 31, 21, 21, 0, 0,
+ & 384,0.020, 0, 31, 30, 38, 0, 0,
+ & 384,0.300, 0, 30, 21, 0, 0, 0,
+ & 384,0.040, 0, 34, 51, 0, 0, 0,
+ & 384,0.040, 0, 50, 35, 0, 0, 0,
+ & 384,0.020, 0, 22, 31, 0, 0, 0,
+ & 385,0.184, 0, 41, 21, 0, 0, 0/
+ DATA (IDK(I),BRFRAC(I),NME(I),(IDKPRD(J,I),J=1,5),I=2129,2147)/
+ & 385,0.184, 0, 29, 38, 0, 0, 0,
+ & 385,0.184, 0, 39, 23, 0, 0, 0,
+ & 385,0.236, 0, 38, 21, 0, 0, 0,
+ & 385,0.160, 0, 24, 38, 0, 0, 0,
+ & 385,0.018, 0, 46, 43, 0, 0, 0,
+ & 385,0.018, 0, 42, 47, 0, 0, 0,
+ & 385,0.016, 0, 46, 42, 0, 0, 0,
+ & 386,0.184, 0, 41, 30, 0, 0, 0,
+ & 386,0.184, 0, 33, 38, 0, 0, 0,
+ & 386,0.184, 0, 39, 31, 0, 0, 0,
+ & 386,0.236, 0, 38, 30, 0, 0, 0,
+ & 386,0.160, 0, 24, 21, 0, 0, 0,
+ & 386,0.009, 0, 46, 35, 0, 0, 0,
+ & 386,0.009, 0, 50, 43, 0, 0, 0,
+ & 386,0.009, 0, 34, 47, 0, 0, 0,
+ & 386,0.009, 0, 42, 51, 0, 0, 0,
+ & 386,0.008, 0, 46, 34, 0, 0, 0,
+ & 386,0.008, 0, 42, 50, 0, 0, 0,
+ & 387,0.184, 0, 33, 21, 0, 0, 0/
+ DATA (IDK(I),BRFRAC(I),NME(I),(IDKPRD(J,I),J=1,5),I=2148,2166)/
+ & 387,0.184, 0, 29, 30, 0, 0, 0,
+ & 387,0.184, 0, 31, 23, 0, 0, 0,
+ & 387,0.236, 0, 30, 21, 0, 0, 0,
+ & 387,0.160, 0, 24, 30, 0, 0, 0,
+ & 387,0.018, 0, 34, 51, 0, 0, 0,
+ & 387,0.018, 0, 50, 35, 0, 0, 0,
+ & 387,0.016, 0, 34, 50, 0, 0, 0,
+ & 388,0.183, 0,231, 38, 30, 0, 0,
+ & 388,0.091, 0,231, 21, 21, 0, 0,
+ & 388,0.067, 0, 59,307, 0, 0, 0,
+ & 388,0.066, 0, 59,308, 0, 0, 0,
+ & 388,0.043, 0, 59,309, 0, 0, 0,
+ & 388,0.446,130, 13, 13, 13, 0, 0,
+ & 388,0.023,130, 13, 13, 59, 0, 0,
+ & 388,0.013, 0,121,127, 0, 0, 0,
+ & 388,0.013, 0,123,129, 0, 0, 0,
+ & 388,0.013, 0,125,131, 0, 0, 0,
+ & 388,0.004, 0, 1, 7, 0, 0, 0,
+ & 388,0.017, 0, 2, 8, 0, 0, 0/
+ DATA (IDK(I),BRFRAC(I),NME(I),(IDKPRD(J,I),J=1,5),I=2167,2185)/
+ & 388,0.004, 0, 3, 9, 0, 0, 0,
+ & 388,0.017, 0, 4, 10, 0, 0, 0,
+ & 389,0.046, 0, 59,388, 0, 0, 0,
+ & 389,0.009, 0, 59,231, 0, 0, 0,
+ & 389,0.755, 0, 13, 13, 0, 0, 0,
+ & 389,0.030, 0,121,127, 0, 0, 0,
+ & 389,0.030, 0,123,129, 0, 0, 0,
+ & 389,0.030, 0,125,131, 0, 0, 0,
+ & 389,0.010, 0, 1, 7, 0, 0, 0,
+ & 389,0.040, 0, 2, 8, 0, 0, 0,
+ & 389,0.010, 0, 3, 9, 0, 0, 0,
+ & 389,0.040, 0, 4, 10, 0, 0, 0,
+ & 390,0.210, 0, 59,388, 0, 0, 0,
+ & 390,0.085, 0, 59,231, 0, 0, 0,
+ & 390,0.565, 0, 13, 13, 0, 0, 0,
+ & 390,0.022, 0,121,127, 0, 0, 0,
+ & 390,0.022, 0,123,129, 0, 0, 0,
+ & 390,0.022, 0,125,131, 0, 0, 0,
+ & 390,0.007, 0, 1, 7, 0, 0, 0/
+ DATA (IDK(I),BRFRAC(I),NME(I),(IDKPRD(J,I),J=1,5),I=2186,2204)/
+ & 390,0.030, 0, 2, 8, 0, 0, 0,
+ & 390,0.007, 0, 3, 9, 0, 0, 0,
+ & 390,0.030, 0, 4, 10, 0, 0, 0,
+ & 391,0.162, 0, 59,388, 0, 0, 0,
+ & 391,0.071, 0, 59,231, 0, 0, 0,
+ & 391,0.615, 0, 13, 13, 0, 0, 0,
+ & 391,0.024, 0,121,127, 0, 0, 0,
+ & 391,0.024, 0,123,129, 0, 0, 0,
+ & 391,0.024, 0,125,131, 0, 0, 0,
+ & 391,0.008, 0, 1, 7, 0, 0, 0,
+ & 391,0.032, 0, 2, 8, 0, 0, 0,
+ & 391,0.008, 0, 3, 9, 0, 0, 0,
+ & 391,0.032, 0, 4, 10, 0, 0, 0,
+ & 392,0.034, 0,267, 38, 30, 0, 0,
+ & 392,0.017, 0,267, 21, 21, 0, 0,
+ & 392,0.044, 0,231, 38, 30, 0, 0,
+ & 392,0.022, 0,231, 21, 21, 0, 0,
+ & 392,0.050, 0,267, 59, 59, 0, 0,
+ & 392,0.114, 0, 59,389, 0, 0, 0/
+ DATA (IDK(I),BRFRAC(I),NME(I),(IDKPRD(J,I),J=1,5),I=2205,2223)/
+ & 392,0.113, 0, 59,390, 0, 0, 0,
+ & 392,0.054, 0, 59,391, 0, 0, 0,
+ & 392,0.403,130, 13, 13, 13, 0, 0,
+ & 392,0.021,130, 13, 13, 59, 0, 0,
+ & 392,0.020, 0,121,127, 0, 0, 0,
+ & 392,0.020, 0,123,129, 0, 0, 0,
+ & 392,0.020, 0,125,131, 0, 0, 0,
+ & 392,0.007, 0, 1, 7, 0, 0, 0,
+ & 392,0.027, 0, 2, 8, 0, 0, 0,
+ & 392,0.007, 0, 3, 9, 0, 0, 0,
+ & 392,0.027, 0, 4, 10, 0, 0, 0,
+ & 393,0.250, 0,246,222, 0, 0, 0,
+ & 393,0.250, 0,245,221, 0, 0, 0,
+ & 393,0.385,130, 13, 13, 13, 0, 0,
+ & 393,0.020,130, 13, 13, 59, 0, 0,
+ & 393,0.015, 0,121,127, 0, 0, 0,
+ & 393,0.015, 0,123,129, 0, 0, 0,
+ & 393,0.015, 0,125,131, 0, 0, 0,
+ & 393,0.005, 0, 1, 7, 0, 0, 0/
+ DATA (IDK(I),BRFRAC(I),NME(I),(IDKPRD(J,I),J=1,5),I=2224,2242)/
+ & 393,0.020, 0, 2, 8, 0, 0, 0,
+ & 393,0.005, 0, 3, 9, 0, 0, 0,
+ & 393,0.020, 0, 4, 10, 0, 0, 0,
+ & 395,0.195, 0, 39, 30, 0, 0, 0,
+ & 395,0.195, 0, 23, 21, 0, 0, 0,
+ & 395,0.195, 0, 31, 38, 0, 0, 0,
+ & 395,0.105, 0,286, 30, 0, 0, 0,
+ & 395,0.105, 0,285, 21, 0, 0, 0,
+ & 395,0.105, 0,287, 38, 0, 0, 0,
+ & 395,0.065, 0, 24, 38, 30, 0, 0,
+ & 395,0.035, 0, 24, 21, 21, 0, 0,
+ & 396,0.320, 0, 46, 34, 0, 0, 0,
+ & 396,0.320, 0, 60, 61, 0, 0, 0,
+ & 396,0.090, 0, 46, 35, 0, 0, 0,
+ & 396,0.090, 0, 42, 51, 0, 0, 0,
+ & 396,0.090, 0, 50, 43, 0, 0, 0,
+ & 396,0.090, 0, 34, 47, 0, 0, 0,
+ & 397,0.312, 0, 41, 30, 0, 0, 0,
+ & 397,0.312, 0, 29, 21, 0, 0, 0/
+ DATA (IDK(I),BRFRAC(I),NME(I),(IDKPRD(J,I),J=1,5),I=2243,2261)/
+ & 397,0.312, 0, 33, 38, 0, 0, 0,
+ & 397,0.016, 0, 46, 35, 0, 0, 0,
+ & 397,0.016, 0, 42, 51, 0, 0, 0,
+ & 397,0.016, 0, 50, 43, 0, 0, 0,
+ & 397,0.016, 0, 34, 47, 0, 0, 0,
+ & 398,0.805, 0, 26, 22, 0, 0, 0,
+ & 398,0.065, 0, 41, 30, 0, 0, 0,
+ & 398,0.065, 0, 29, 21, 0, 0, 0,
+ & 398,0.065, 0, 33, 38, 0, 0, 0,
+ & 399,0.667, 0, 24, 38, 30, 0, 0,
+ & 399,0.333, 0, 24, 21, 21, 0, 0,
+ & 62,0.440, 0, 21, 22, 0, 0, 0,
+ & 62,0.160, 0, 21, 25, 0, 0, 0,
+ & 62,0.200, 0, 50, 42, 0, 0, 0,
+ & 62,0.200, 0, 46, 34, 0, 0, 0,
+ & 63,0.440, 0, 38, 22, 0, 0, 0,
+ & 63,0.160, 0, 38, 25, 0, 0, 0,
+ & 63,0.400, 0, 46, 42, 0, 0, 0,
+ & 64,0.440, 0, 30, 22, 0, 0, 0/
+ DATA (IDK(I),BRFRAC(I),NME(I),(IDKPRD(J,I),J=1,5),I=2262,2263)/
+ & 64,0.160, 0, 30, 25, 0, 0, 0,
+ & 64,0.400, 0, 50, 34, 0, 0, 0/
+ END
+CDECK ID>, HWUDKL.
+*CMZ :- -27/07/99 13.33.03 by Mike Seymour
+*-- Author : Ian Knowles
+C-----------------------------------------------------------------------
+ SUBROUTINE HWUDKL(ID,PMOM,DISP)
+C-----------------------------------------------------------------------
+C Given a real or virtual particle, flavour ID and 4-momentum PMOM,
+C returns DISP its distance travelled in mm.
+C-----------------------------------------------------------------------
+ INCLUDE 'HERWIG61.INC'
+ DOUBLE PRECISION HWR,PMOM(4),DISP(4),PMOM2,SCALE
+ INTEGER ID
+ EXTERNAL HWR
+ PMOM2=(PMOM(4)+PMOM(3))*(PMOM(4)-PMOM(3))-PMOM(1)**2-PMOM(2)**2
+ SCALE=-GEV2MM*LOG(HWR())
+ & /SQRT((PMOM2-RMASS(ID)**2)**2+(PMOM2/DKLTM(ID))**2)
+ IF (ID.GT.197.AND.ID.LT.203) SCALE=SCALE*EXAG
+ CALL HWVSCA(4,SCALE,PMOM,DISP)
+ END
+CDECK ID>, HWUDKS.
+*CMZ :- -27/07/99 13.33.03 by Mike Seymour
+*-- Author : Ian Knowles
+C-----------------------------------------------------------------------
+ SUBROUTINE HWUDKS
+C-----------------------------------------------------------------------
+C Sets up internal pointers based on the decay table in HWUDAT or as
+C supplied via HWIODK. Computes CoM momenta of two-body decay modes.
+C Particles with long lifetimes or no allowed decay (excepting light
+C b hadrons when CLEO/EURODEC decays requested) are set stable, else
+C calculate DKLTM(I) = mass/width ( = mass * lifetime/hbar).
+C Gives warnings if: a particle has no decay modes or antiparticle's
+C modes are not the charge conjugates of the particles.
+C (N.B. CP violation permits this).
+C-----------------------------------------------------------------------
+ INCLUDE 'HERWIG61.INC'
+ DOUBLE PRECISION HWUPCM,HWUAEM,HWUALF,BRSUM,EPS,SCALE,
+ & BRTMP(NMXDKS),FN,X,W,Q,FAC
+ INTEGER HWUANT,I,IDKY,LAST,LTMP(NMXMOD),J,L,K,M,N,INDX(NMXMOD),
+ & IRES,IAPDG,IPART,LR,LP,KPRDLR
+ LOGICAL BPDK,TOPDKS,MATCH(5),PMATCH(NMXMOD)
+ CHARACTER*7 CVETO(2)
+ CHARACTER*8 CDUM
+ EXTERNAL HWUPCM,HWUAEM,HWUALF,HWUANT
+ PARAMETER(EPS=1.E-6)
+ FN(X,Q,W)=X**4/(((X*X-Q*Q)**2+W*W*(X*X+Q*Q)-2.*W**4)
+ & *SQRT(X**4+Q**4+W**4-2.*(X*X*Q*Q+X*X*W*W+Q*Q*W*W)))
+ WRITE(6,10)
+ 10 FORMAT(/10X,'Checking consistency of decay tables'/)
+ DKPSET=.TRUE.
+C First zero arrays
+ DO 20 I=1,NMXRES
+ LSTRT(I)=0
+ 20 NMODES(I)=0
+ DO 30 I=1,NMXDKS
+ NPRODS(I)=0
+ LNEXT(I)=0
+ 30 CMMOM(I)=0
+ BPDK=BDECAY.NE.'HERW'
+ DO 180 I=1,NDKYS
+C Search for next decaying particle type
+ IDKY=IDK(I)
+C Skip if particle is not recognised or already dealt with
+ IF (IDKY.EQ.0.OR.IDKY.EQ.20) THEN
+ WRITE(6,40) I
+ 40 FORMAT(1X,'Line ',I4,': decaying particle not recognised')
+ GOTO 180
+ ENDIF
+ IF (NMODES(IDKY).GT.0) GOTO 180
+C Check and include first decay mode, storing a copy
+ CALL HWDCHK(IDKY,I,*180)
+ LSTRT(IDKY)=I
+ NMODES(IDKY)=1
+ BRSUM=BRFRAC(I)
+ LTMP(1)=I
+ BRTMP(1)=-BRFRAC(I)
+ LAST=I
+C Sets CMMOM(IDKY) = CoM momentum for first 2-body decay mode I (else 0)
+ IF (NPRODS(I).EQ.2) CMMOM(I)=
+ & HWUPCM(RMASS(IDKY),RMASS(IDKPRD(1,I)),RMASS(IDKPRD(2,I)))
+C Include any other decay modes of IDKY
+ DO 120 J=I+1,NDKYS
+ IF (IDK(J).EQ.IDKY) THEN
+C First see if it is a copy of the same decay channel
+ IF ((IDKPRD(2,J).GE.1.AND.IDKPRD(2,J).LE.13).OR.
+ & (IDKPRD(3,J).GE.1.AND.IDKPRD(3,J).LE.13)) THEN
+C Partonic respect order
+ L=LSTRT(IDKY)
+ DO 50 K=1,NMODES(IDKY)
+ IF (IDKPRD(1,L).EQ.IDKPRD(1,J).AND.
+ & IDKPRD(2,L).EQ.IDKPRD(2,J).AND.
+ & IDKPRD(3,L).EQ.IDKPRD(3,J).AND.
+ & IDKPRD(4,L).EQ.IDKPRD(4,J).AND.
+ & IDKPRD(5,L).EQ.IDKPRD(5,J)) GOTO 100
+ 50 L=LNEXT(L)
+ ELSE
+C Allow for different order in matching
+ L=LSTRT(IDKY)
+ DO 90 K=1,NMODES(IDKY)
+ DO 60 M=1,5
+ 60 MATCH(M)=.FALSE.
+ DO 80 M=1,5
+ DO 70 N=1,5
+ IF (.NOT.MATCH(N).AND.IDKPRD(N,L).EQ.IDKPRD(M,J)) THEN
+ MATCH(N)=.TRUE.
+ GOTO 80
+ ENDIF
+ 70 CONTINUE
+ 80 CONTINUE
+ IF (MATCH(1).AND.MATCH(2).AND.MATCH(3).AND.
+ & MATCH(4).AND.MATCH(5)) GOTO 100
+ 90 L=LNEXT(L)
+ ENDIF
+ CALL HWDCHK(IDKY,J,*120)
+ NMODES(IDKY)=NMODES(IDKY)+1
+ IF (NMODES(IDKY).GT.NMXMOD) CALL HWWARN('HWUDKS',100,*999)
+ LNEXT(LAST)=J
+ BRSUM=BRSUM+BRFRAC(J)
+ LTMP(NMODES(IDKY))=J
+ BRTMP(NMODES(IDKY))=-BRFRAC(J)
+ LAST=J
+C Sets CMMOM(IDKY) = CoM momentum for next 2-body decay mode J (else 0)
+ IF (NPRODS(J).EQ.2) CMMOM(J)=
+ & HWUPCM(RMASS(IDKY),RMASS(IDKPRD(1,J)),RMASS(IDKPRD(2,J)))
+ ENDIF
+ GOTO 120
+ 100 WRITE(6,110) L,J,BRFRAC(J),NME(J)
+ BRSUM=BRSUM-BRFRAC(L)+BRFRAC(J)
+ BRFRAC(L)=BRFRAC(J)
+ BRTMP(L)=-BRFRAC(L)
+ NME(L)=NME(J)
+ 110 FORMAT(1X,'Line ',I4,' is the same as line ',I4/
+ & 1X,'Take BR ',F5.3,' and ME code ',I3,' from second entry')
+ 120 CONTINUE
+C Set sum of branching ratios to 1. if necessary
+ IF (ABS(BRSUM-1.).GT.EPS) THEN
+ WRITE(6,130) RNAME(IDKY),BRSUM
+ 130 FORMAT(1X,A8,': BR sum =',F8.5)
+ IF (ABS(BRSUM).LT.EPS) THEN
+ WRITE(6,140)
+ 140 FORMAT(1X,'Setting particle stable'/)
+ NMODES(IDKY)=0
+ ELSE
+ WRITE(6,150)
+ 150 FORMAT(1X,'Rescaling to 1'/)
+ SCALE=1./BRSUM
+ K=LSTRT(IDKY)
+ DO 160 J=1,NMODES(IDKY)
+ BRFRAC(K)=SCALE*BRFRAC(K)
+ 160 K=LNEXT(K)
+ ENDIF
+ ENDIF
+C Sort branching ratios into descending order and rearrange pointers
+ CALL HWUSOR(BRTMP,NMODES(IDKY),INDX,2)
+ LSTRT(IDKY)=LTMP(INDX(1))
+ LNEXT(LTMP(INDX(1)))=LTMP(INDX(1))
+ DO 170 J=2,NMODES(IDKY)
+ IF (ABS(BRFRAC(LTMP(INDX(J)))).LT.EPS) THEN
+ NMODES(IDKY)=J-1
+ GOTO 175
+ ENDIF
+ 170 LNEXT(LTMP(INDX(J-1)))=LTMP(INDX(J))
+ 175 LNEXT(LTMP(INDX(NMODES(IDKY))))=LTMP(INDX(NMODES(IDKY)))
+ 180 CONTINUE
+C If not a short lived particle with a decay mode then set stable
+ DO 190 I=1,NRES
+ IF (.NOT.RSTAB(I).AND.RLTIM(I).LT.PLTCUT.AND.
+ & (NMODES(I).GT.0.OR.
+ & (BPDK.AND.((I.GE.221.AND.I.LE.231).OR.
+ & (I.GE.245.AND.I.LE.254))))) THEN
+ DKLTM(I)=RLTIM(I)*RMASS(I)/HBAR
+ ELSE
+ RSTAB(I)=.TRUE.
+ ENDIF
+ 190 CONTINUE
+C Set up DKLTM for light quarks
+ DO 200 I=1,5
+ DKLTM(I)=RMASS(I)**2/VMIN2
+ 200 DKLTM(I+6)=DKLTM(I)
+C gluon
+ DKLTM(13)=RMASS(13)**2/VMIN2
+C and diquarks
+ DO 210 I=109,114
+ DKLTM(I)=RMASS(I)**2/VMIN2
+ 210 DKLTM(I+6)=DKLTM(I)
+C Set up DKLTM for weak bosons
+ DKLTM(198)=RMASS(198)/GAMW
+ DKLTM(199)=DKLTM(198)
+ DKLTM(200)=RMASS(200)/GAMZ
+ DKLTM(201)=RMASS(201)/GAMH
+ DKLTM(202)=RMASS(202)/GAMZP
+C Set up DKTRM for massive quarks (plus check m_Q > M_W + m_q)
+ FAC=SWEIN*(FOUR*RMASS(198))**2/HWUAEM(RMASS(198)**2)
+ IF (.NOT.SUSYIN) THEN
+ IF (RMASS(6).GT.RMASS(5)+RMASS(198)) THEN
+ DKLTM(6)=FAC*FN(RMASS(6 ),RMASS(5 ),RMASS(198))
+ & /(1-HWUALF(1,RMASS(6))*2*(2*PIFAC**2/3-5/2)/(3*PIFAC))
+ DKLTM(12)=DKLTM(6)
+ ELSE
+ WRITE(6,220) RNAME(6),RNAME(5),RNAME(198)
+ ENDIF
+ ENDIF
+ IF (RMASS(209).GT.RMASS(4)+RMASS(198)) THEN
+ DKLTM(209)=FAC*FN(RMASS(209),RMASS(4 ),RMASS(198))
+ DKLTM(215)=DKLTM(209)
+ ELSE
+ WRITE(6,220) RNAME(209),RNAME(4),RNAME(198)
+ ENDIF
+ IF (RMASS(210).GT.RMASS(209)+RMASS(198)) THEN
+ DKLTM(210)=FAC*FN(RMASS(210),RMASS(209),RMASS(198))
+ DKLTM(216)=DKLTM(210)
+ ELSE
+ WRITE(6,220) RNAME(210),RNAME(209),RNAME(198)
+ ENDIF
+ IF (RMASS(211).GT.RMASS(6)+RMASS(198)) THEN
+ DKLTM(211)=FAC*FN(RMASS(211),RMASS(6 ),RMASS(198))
+ DKLTM(217)=DKLTM(211)
+ ELSE
+ WRITE(6,220) RNAME(211),RNAME(6),RNAME(198)
+ ENDIF
+ IF (RMASS(212).GT.RMASS(211)+RMASS(198)) THEN
+ DKLTM(212)=FAC*FN(RMASS(212),RMASS(211),RMASS(198))
+ DKLTM(218)=DKLTM(212)
+ ELSE
+ WRITE(6,220) RNAME(212),RNAME(211),RNAME(198)
+ ENDIF
+ 220 FORMAT(1X,'W not real in the decay: ',A8,' --> ',A8,' + ',A8)
+C Now carry out diagnostic checks on decay table
+ CALL HWDTOP(TOPDKS)
+ DO 310 IRES=1,NRES
+ IAPDG=ABS(IDPDG(IRES))
+C Do not check (di-)quarks, gauge bosons, higgses or special particles
+ IF ((IAPDG.GE.1.AND.IAPDG.LE.9).OR.
+ & (MOD(IAPDG/10,10).EQ.0.AND.MOD(IAPDG/1000,10).NE.0).OR.
+ & (IAPDG.GE.21.AND.IAPDG.LE.26).OR.
+ & IAPDG.EQ.32.OR.
+ & (IAPDG.GE.35.AND.IAPDG.LE.37).OR.
+ & IAPDG.EQ.91.OR.
+ & IAPDG.EQ.98.OR.IAPDG.EQ.99) THEN
+ GOTO 310
+C Ignore top hadrons if top decays
+ ELSEIF(TOPDKS.AND.((IRES.GE.232.AND.IRES.LE.244).OR.
+ & (IRES.GE.255.AND.IRES.LE.264))) THEN
+ GOTO 310
+C Ignore particles not produced in cluster or particle decays
+ ELSEIF(VTOCDK(IRES).AND.VTORDK(IRES)) THEN
+ GOTO 310
+C Ignore B's if EURO or CLEO decay package used
+ ELSEIF(((IRES.GE.221.AND.IRES.LE.223).OR.
+ & (IRES.GE.245.AND.IRES.LE.247)).AND.BDECAY.NE.'HERW') THEN
+ WRITE(6,320) BDECAY,RNAME(IRES)
+C Check decay modes exist for massive, short lived particles
+ ELSEIF (NMODES(IRES).EQ.0.AND.RMASS(IRES).NE.ZERO.AND.
+ & RLTIM(IRES).LT.PLTCUT) THEN
+ IF (VTOCDK(IRES)) THEN
+ CVETO(1)='VETOED '
+ ELSE
+ CVETO(1)='ALLOWED'
+ ENDIF
+ IF (VTORDK(IRES)) THEN
+ CVETO(2)='VETOED '
+ ELSE
+ CVETO(2)='ALLOWED'
+ ENDIF
+ WRITE(6,330) RNAME(IRES),CVETO(1),CVETO(2)
+C ignore particles with no modes if massless or long lived
+ ELSEIF (NMODES(IRES).EQ.0.AND.
+ & (RMASS(IRES).EQ.ZERO.OR.RLTIM(IRES).GT.PLTCUT)) THEN
+ GOTO 310
+ ELSEIF (IDPDG(IRES).LT.0) THEN
+C Antiparticle: check decays are charge conjugates of particle decays
+ CALL HWUIDT(1,-IDPDG(IRES),IPART,CDUM)
+ IF (NMODES(IPART).EQ.0) THEN
+C Nothing to compare to
+ WRITE(6,340) RNAME(IPART),RNAME(IRES)
+ ELSE
+C First initialize particle matching array
+ DO 230 I=1,NMODES(IPART)
+ 230 PMATCH(I)=.FALSE.
+C Loop through antiparticle decay modes
+ LR=LSTRT(IRES)
+ DO 290 I=1,NMODES(IRES)
+C Search for conjugate mode allowing for different particle order
+ LP=LSTRT(IPART)
+ DO 270 J=1,NMODES(IPART)
+ IF (PMATCH(J)) GOTO 270
+ DO 240 K=1,5
+ 240 MATCH(K)=.FALSE.
+ DO 260 K=1,5
+ KPRDLR=HWUANT(IDKPRD(K,LR))
+ DO 250 L=1,5
+ IF (.NOT.MATCH(L).AND.KPRDLR.EQ.IDKPRD(L,LP) ) THEN
+ MATCH(L)=.TRUE.
+ GOTO 260
+ ENDIF
+ 250 CONTINUE
+ 260 CONTINUE
+ IF (MATCH(1).AND.MATCH(2).AND.MATCH(3).AND.
+ & MATCH(4).AND.MATCH(5)) GOTO 280
+ 270 LP=LNEXT(LP)
+C No match found
+ WRITE(6,350) LR,RNAME(IRES),(RNAME(IDKPRD(J,LR)),J=1,5)
+ GOTO 290
+C Match found, check branching ratios and matrix element codes
+ 280 PMATCH(J)=.TRUE.
+ IF (BRFRAC(LR).NE.BRFRAC(LP))
+ & WRITE(6,360) LR,RNAME(IRES),(RNAME(IDKPRD(J,LR)),J=1,5),
+ & BRFRAC(LR),BRFRAC(LP)
+ IF (NME(LR).NE.NME(LP))
+ & WRITE(6,370) LR,RNAME(IRES),(RNAME(IDKPRD(J,LR)),J=1,5),
+ & NME(LR),NME(LP)
+ 290 LR=LNEXT(LR)
+C Check for unmatched modes of particle conjugate to antiparticle
+ LP=LSTRT(IPART)
+ DO 300 I=1,NMODES(IPART)
+ IF (.NOT.PMATCH(I))
+ & WRITE(6,350) LP,RNAME(IPART),(RNAME(IDKPRD(J,LP)),J=1,5)
+ 300 LP=LNEXT(LP)
+ ENDIF
+ ENDIF
+ 310 CONTINUE
+ 320 FORMAT(1X,A8,' decay package to be used for particle ',A8)
+ 330 FORMAT(1X,'No decay modes available for particle ',A8/
+ & 1X,'Production in cluster decays ',A7,' and particle decays ',A7)
+ 340 FORMAT(1X,A8,' has no modes conjugate to those of ',A8)
+ 350 FORMAT(1X,'Line, ',I4,' decay: ',A8,' --> ',4(A8,1X),A8/
+ & 1X,'A charge conjugate decay mode does not exist')
+ 360 FORMAT(1X,'Line, ',I4,' decay: ',A8,' --> ',4(A8,1X),A8/
+ & 1X,'BR ',F5.3,' unequal to that of conjugate mode ',F5.3)
+ 370 FORMAT(1X,'Line, ',I4,' decay: ',A8,' --> ',4(A8,1X),A8/
+ & 1X,'ME code ',I3,' unequal to that of conjugate mode ',I3)
+ 999 RETURN
+ END
+CDECK ID>, HWUDPR.
+*CMZ :- -27/07/99 13.33.03 by Mike Seymour
+*-- Author : Ian Knowles, Bryan Webber & Kosuke Odagiri
+C-----------------------------------------------------------------------
+ SUBROUTINE HWUDPR
+C-----------------------------------------------------------------------
+C Prints out particle properies/decay tables in a number of formats:
+C If (PRNDEF) ASCII to stout
+C If (PRNTEX) LaTeX to the file HW_decays.tex
+C Paper size and offsets as set in HWUEPR
+C Uses the package longtable.sty
+C Designed to be printed as landscape
+C If (PRNWEB) HTML to the file HW_decays/index.html
+C /PART0000001.html etc.
+C-----------------------------------------------------------------------
+ INCLUDE 'HERWIG61.INC'
+ INTEGER MMWIDE,MMLONG,MMHOFF,MMVOFF,IUNITT,IUNTW1,IUNTW2,I,NM,J,K,
+ & L,M
+ CHARACTER*1 Z
+ CHARACTER*2 ZZ,ACHRG
+ CHARACTER*3 ASPIN(0:10)
+ CHARACTER*6 BGCOLS(5),TBCOLS(3)
+ CHARACTER*7 HWUNST,TMPNME
+ CHARACTER*17 FNAMEP
+ CHARACTER*33 FNAMEW
+ COMMON/PAPER/MMWIDE,MMLONG,MMHOFF,MMVOFF
+ EXTERNAL HWUNST
+ DATA BGCOLS/'ffffff','0000aa','aa0000','00aa00','aa00ff'/
+ DATA TBCOLS/'ccccff','9966ff','ffff00'/
+ DATA ASPIN/' 0 ','1/2',' 1 ','3/2',' 2 ','5/2',' 3 ','7/2',
+ & ' 4 ','9/2',' 5 '/
+C
+ Z=CHAR(92)
+ ZZ=Z//Z
+C
+ IUNITT=50
+ IUNTW1=51
+ IUNTW2=52
+C Open and write out file header information for index file
+ IF (PRNDEF) THEN
+ IF (NPRFMT.LE.1) THEN
+ WRITE (6,10) NRES
+ ELSE
+ WRITE (6,20) NRES
+ END IF
+ END IF
+ IF (PRNTEX) THEN
+ OPEN(IUNITT,STATUS='UNKNOWN',FILE='HW_decays.tex')
+ IF (NPRFMT.LE.1) THEN
+ WRITE(IUNITT,30) Z,Z,Z,MMWIDE,Z,MMLONG,Z,MMHOFF,Z,MMVOFF,
+ & Z,Z,Z,Z,Z,ZZ,Z,Z,Z,Z,Z,Z,NRES,ZZ,Z,Z,ZZ,Z,Z
+ ELSE
+ WRITE(IUNITT,40) Z,Z,Z,MMLONG,Z,MMWIDE,Z,MMHOFF,Z,MMVOFF,
+ & Z,Z,Z,Z,Z,Z,ZZ,Z,Z,Z,Z,Z,Z,NRES,ZZ,Z,Z,Z,ZZ,Z,Z
+ END IF
+ ENDIF
+ IF (PRNWEB) THEN
+ OPEN(IUNTW1,STATUS='UNKNOWN',FILE='HW_decays/index.html')
+ WRITE(IUNTW1,50) BGCOLS,TBCOLS,NRES,((TBCOLS(I),I=2,3),J=1,7)
+ ENDIF
+ 10 FORMAT(1H1//15X,'TABLE OF PROPERTIES OF',I4,' PARTICLES USED'/)
+ 20 FORMAT(1H1//30X,'TABLE OF PROPERTIES OF',I4,' PARTICLES USED'//
+ & 5X,'Name IDPDG Mass Chg Spn Lifetime Modes ',
+ & ' Branching fractions ME codes and decay products')
+ 30 FORMAT(A1,'documentclass{article}'/A1,'usepackage{longtable}'/
+ & A1,'textwidth ',I4,'mm ',A1,'textheight ',I4,'mm'/
+ & A1,'hoffset ',I4,'mm ',A1,'voffset ',I4,'mm'/
+ & A1,'pagestyle{empty}'/A1,'begin{document}'/
+ & A1,'begin{center}'/A1,'begin{longtable}{|r|c|r|r|r|r|r|r|}'/
+ & A1,'hline'/'Id HW & Name & Id PDG & Mass & Charge & Spin ',
+ & '& Lifetime & Modes ',A2/A1,'hline'/
+ & A1,'endhead'/A1,'hline'/A1,'endfoot'/A1,'hline'/
+ & A1,'multicolumn{8}{|c|}{HERWIG 6.0: Table of properties',
+ & ' of the ',I3,' particles used} ',A2/A1,'hline',A1,'hline'/
+ & 'Id HW & Name & Id PDG & Mass & Charge & Spin & ',
+ & 'Lifetime & Modes ',A2/A1,'hline'/A1,'endfirsthead')
+ 40 FORMAT(A1,'documentclass{article}'/A1,'usepackage{longtable}'/
+ & A1,'textwidth ',I4,'mm ',A1,'textheight ',I4,'mm'/
+ & A1,'hoffset ',I4,'mm ',A1,'voffset ',I4,'mm'/
+ & A1,'pagestyle{empty}'/A1,'begin{document}'/A1,'begin{center}'/
+ & A1,'begin{longtable}{|r|c|r|r|r|r|r|r|c|r|ccccc|}'/
+ & A1,'hline'/'Id HW & Name & Id PDG & Mass & Charge & Spin ',
+ & '& Lifetime & Modes & B.R. & M.E. & ' /
+ & A1,'multicolumn{5}{|c|}{Decay Products} ',A2/A1,'hline'/
+ & A1,'endhead'/A1,'hline'/A1,'endfoot'/A1,'hline'/
+ & A1,'multicolumn{15}{|c|}{HERWIG 6.0: Table of properties',
+ & ' of the ',I3,' particles used} ',A2/A1,'hline',A1,'hline'/
+ & 'Id HW & Name & Id PDG & Mass & Charge & Spin & ',
+ & 'Lifetime & Modes & B.R. & M.E. & '/
+ & A1,'multicolumn{5}{|c|}{Decay Products} ',A2/A1,'hline'/
+ & A1,'endfirsthead')
+ 50 FORMAT('<!-- No Less productions -->'/'<HTML>'/'<HEAD>'/
+ & '<TITLE>HERWIG 6.0 Particle Properties</TITLE>'/'</HEAD>'/
+ & '<BODY BGCOLOR=#',A6,' TEXT=#',A6,' LINK=#',A6,
+ & ' ALINK=#',A6,' VLINK=#',A6,'>'/'<CENTER>'/
+ & '<TABLE ALIGN="CENTER" BGCOLOR=#',A6,'>',
+ & '<TR>'/'<TH COLSPAN=8 BGCOLOR=#',A6,' ALIGN="CENTER">',
+ & '<A HREF=="http://hepwww.rl.ac.uk/theory/seymour/herwig/">',
+ & 'HERWIG 6.0:</A><FONT COLOR=#',A6,'> Table of properties of',
+ & ' the ',I3,' particles used</FONT></TH>'/'<TR>'/'<TH></TH>'/
+ & '<TH BGCOLOR=#',A6,'><FONT COLOR=#',A6,'>Name</FONT></TH>'/
+ & '<TH BGCOLOR=#',A6,' ALIGN="CENTER"><FONT COLOR=#',A6,'>',
+ & 'Id PDG</FONT></TH>'/
+ & '<TH BGCOLOR=#',A6,'><FONT COLOR=#',A6,'>Mass</FONT></TH>'/
+ & '<TH BGCOLOR=#',A6,'><FONT COLOR=#',A6,'>Charge</FONT></TH>'/
+ & '<TH BGCOLOR=#',A6,'><FONT COLOR=#',A6,'>Spin</FONT></TH>'/
+ & '<TH BGCOLOR=#',A6,'><FONT COLOR=#',A6,'>Lifetime</FONT></TH>'/
+ & '<TH BGCOLOR=#',A6,'><FONT COLOR=#',A6,'>Modes</FONT></TH>'/
+ & '</TR>')
+C Loop through resonances
+ DO 260 I=1,NRES
+C Skip particles that can't be produced or blank lines
+ IF ((VTOCDK(I).AND.VTORDK(I)).OR.
+ & (RNAME(I).EQ.' ')) GOTO 260
+C Open and write out header information for particle file
+ IF (PRNWEB) THEN
+ TMPNME = HWUNST(I)
+ WRITE(FNAMEP,'(A5,A7,A5)') 'PART_',TMPNME,'.html'
+ WRITE(FNAMEW,'(A,A17)') 'HW_decays/',FNAMEP
+ OPEN(IUNTW2,STATUS='UNKNOWN',FILE=FNAMEW)
+ WRITE(IUNTW2,60) RNAME(I),BGCOLS
+ WRITE(IUNTW2,70) TBCOLS,((TBCOLS(L),L=2,3),M=1,6)
+ ENDIF
+ 60 FORMAT('<!-- No Less productions -->'/'<HTML>'/'<HEAD>'/
+ & '<TITLE>HERWIG 6.0: ',A8,' properties</TITLE>'/'</HEAD>'/
+ & '<BODY BGCOLOR=#',A6,' TEXT=#',A6,' LINK=#',A6,
+ & ' ALINK=#',A6,' VLINK=#',A6,'>'/'<CENTER>')
+ 70 FORMAT('<TABLE ALIGN="CENTER" BGCOLOR=#',A6,'>'/
+ & '<TR>'/'<TH></TH>'/
+ & '<TH BGCOLOR=#',A6,'><FONT COLOR=#',A6,'>Name</FONT></TH>'/
+ & '<TH BGCOLOR=#',A6,' ALIGN="CENTER"><FONT COLOR=#',A6,
+ & '>Id PDG</FONT></TH>'/
+ & '<TH BGCOLOR=#',A6,'><FONT COLOR=#',A6,'>Mass</FONT></TH>'/
+ & '<TH BGCOLOR=#',A6,'><FONT COLOR=#',A6,'>Charge</FONT></TH>'/
+ & '<TH BGCOLOR=#',A6,'><FONT COLOR=#',A6,'>Spin</FONT></TH>'/
+ & '<TH BGCOLOR=#',A6,'><FONT COLOR=#',A6,'>Lifetime</FONT></TH>'/
+ & '<TH BGCOLOR=#',A6,'><FONT COLOR=#',A6,'>Modes</FONT></TH>'/
+ & '</TR>')
+C Trick to output charge in fractions for di/s - quarks
+ IF ((I.GE. 1.AND.I.LE. 12).OR.(I.GE.109.AND.I.LE.120).OR.
+ & (I.GE.209.AND.I.LE.218).OR.(I.GE.401.AND.I.LE.424)) THEN
+ ACHRG='/3'
+ ELSE
+ ACHRG=' '
+ ENDIF
+C Write out special particles with no decay modes
+ IF (NMODES(I).EQ.0) THEN
+ IF (PRNDEF) THEN
+ IF (NPRFMT.LE.1) THEN
+ WRITE(6,80) I,RNAME(I),IDPDG(I),RMASS(I),ICHRG(I),
+ & ASPIN(INT(TWO*RSPIN(I))),RLTIM(I),0
+ ELSE
+ WRITE(6,90) I,RNAME(I),IDPDG(I),RMASS(I),ICHRG(I),
+ & ASPIN(INT(TWO*RSPIN(I))),RLTIM(I),0
+ ENDIF
+ ENDIF
+C Add particle to LaTeX file
+ IF (PRNTEX) THEN
+ IF (NPRFMT.LE.1) THEN
+ WRITE(IUNITT,100) Z,I,TXNAME(1,I),IDPDG(I),RMASS(I),
+ & ICHRG(I),ACHRG,ASPIN(INT(TWO*RSPIN(I))),RLTIM(I),0,ZZ
+ ELSE
+ WRITE(IUNITT,110) Z,I,TXNAME(1,I),IDPDG(I),RMASS(I),
+ & ICHRG(I),ACHRG,ASPIN(INT(TWO*RSPIN(I))),RLTIM(I),0,Z,ZZ
+ ENDIF
+ ENDIF
+ IF (PRNWEB) THEN
+C Add properties to Web index
+ WRITE(IUNTW1,120) TBCOLS(2),TBCOLS(3),I,FNAMEP,TXNAME(2,I),
+ & IDPDG(I),RMASS(I),ICHRG(I),ACHRG,
+ & ASPIN(INT(TWO*RSPIN(I))),RLTIM(I),0
+C Add properties to Web particle file
+ WRITE(IUNTW2,130) TBCOLS(2),TBCOLS(3),I,TXNAME(2,I),
+ & IDPDG(I),RMASS(I),ICHRG(I),ACHRG,
+ & ASPIN(INT(TWO*RSPIN(I))),RLTIM(I),0
+ ENDIF
+ 80 FORMAT(/1X,I3,1X,A8,' IDPDG=',I8,', M=',F8.3,', Q=',I2,', J=',
+ & A3,', T=',1P,E9.3,',',I3,' Modes')
+ 90 FORMAT(/1X,I3,1X,A8,1X,I8,1X,F8.3,1X,I2,1X,A3,1X,1P,E9.3,1X,I3)
+ 100 FORMAT(A1,'hline',I4,' & ',A37,' & $',I8,'$ & ',F8.3,' & $',I2,
+ & A2,'$ & ',A3,' & $',1P,E9.3,'$ & ',I3,' ',A2)
+ 110 FORMAT(A1,'cline{1-8}'/
+ & I4,' & ',A37,' & $',I8,'$ & ',F8.3,' & $',I2,A2,'$ & ',A3,
+ & ' & $',1P,E9.3,'$ & ',I3,' & ',A1,'multicolumn{7}{|c|}{} ',A2)
+ 120 FORMAT('<TR>'/
+ & '<TD ALIGN="RIGHT" BGCOLOR=#',A6,'><FONT COLOR=#',A6,'>',I3,
+ & '</FONT></TD>'/
+ & '<TD ALIGN="CENTER"><A HREF="',A17,'">',A37,'</A></TD>'/
+ & '<TD ALIGN="RIGHT">',I8,'</TD>'/
+ & '<TD ALIGN="RIGHT">',F8.3,'</TD>'/
+ & '<TD ALIGN="RIGHT">',I2,A2,'</TD>'/
+ & '<TD ALIGN="RIGHT">',A3,'</TD>'/
+ & '<TD ALIGN="RIGHT">',1P,E9.3,'</TD>'/
+ & '<TD ALIGN="RIGHT">',I3,'</TD>'/'</TR>')
+ 130 FORMAT('<TR>'/
+ & '<TD ALIGN="RIGHT" BGCOLOR=#',A6,'><FONT COLOR=#',A6,'>',I3,
+ & '</FONT></TD>'/
+ & '<TD ALIGN="CENTER">',A37,'</TD>'/
+ & '<TD ALIGN="RIGHT">',I8,'</TD>'/
+ & '<TD ALIGN="RIGHT">',F8.3,'</TD>'/
+ & '<TD ALIGN="RIGHT">',I2,A2,'</TD>'/
+ & '<TD ALIGN="RIGHT">',A3,'</TD>'/
+ & '<TD ALIGN="RIGHT">',1P,E9.3,'</TD>'/
+ & '<TD ALIGN="RIGHT">',I3,'</TD>'/'</TR>'/'</TABLE>'/'<P>')
+ ELSE
+C Particle with decay modes
+ IF (RSTAB(I)) THEN
+ NM=0
+ ELSEIF (VTOCDK(I)) THEN
+ NM=-NMODES(I)
+ ELSE
+ NM=NMODES(I)
+ ENDIF
+ K=LSTRT(I)
+C Write out properties and first decay mode
+ IF (PRNDEF) THEN
+ IF (NPRFMT.LE.1) THEN
+ WRITE(6, 80) I,RNAME(I),IDPDG(I),RMASS(I),ICHRG(I),
+ & ASPIN(INT(TWO*RSPIN(I))),RLTIM(I),NM
+ WRITE(6,140) (RNAME(IDKPRD(L,K)),L=1,5),BRFRAC(K),NME(K)
+ ELSE
+ WRITE(6,150) I,RNAME(I),IDPDG(I),RMASS(I),ICHRG(I),
+ & ASPIN(INT(TWO*RSPIN(I))),RLTIM(I),NM,BRFRAC(K),NME(K),
+ & (RNAME(IDKPRD(L,K)),L=1,5)
+ ENDIF
+ ENDIF
+ IF (PRNTEX) THEN
+ IF (NPRFMT.LE.1) THEN
+ WRITE(IUNITT,160) Z,I,TXNAME(1,I),IDPDG(I),RMASS(I),
+ & ICHRG(I),ACHRG,ASPIN(INT(TWO*RSPIN(I))),RLTIM(I),NM,ZZ,Z
+ WRITE(IUNITT,170) Z,Z,(TXNAME(1,IDKPRD(L,K)),L=1,5),Z,
+ & BRFRAC(K),Z,NME(K),ZZ
+ ELSE
+ WRITE(IUNITT,180) Z,I,TXNAME(1,I),IDPDG(I),RMASS(I),
+ & ICHRG(I),ACHRG,ASPIN(INT(TWO*RSPIN(I))),RLTIM(I),NM,
+ & BRFRAC(K),NME(K),(TXNAME(1,IDKPRD(L,K)),L=1,5),ZZ,Z
+ ENDIF
+ END IF
+ IF (PRNWEB) THEN
+C Add properties to index
+ WRITE(IUNTW1,120) TBCOLS(2),TBCOLS(3),I,FNAMEP,TXNAME(2,I),
+ & IDPDG(I),RMASS(I),ICHRG(I),ACHRG,ASPIN(INT(TWO*RSPIN(I))),
+ & RLTIM(I),NM
+C Add properties to Web particle file
+ WRITE(IUNTW2,130) TBCOLS(2),TBCOLS(3),I,TXNAME(2,I),IDPDG(I),
+ & RMASS(I),ICHRG(I),ACHRG,ASPIN(INT(TWO*RSPIN(I))),RLTIM(I),NM
+ WRITE(IUNTW2,190) TBCOLS,TXNAME(2,I),
+ & ((TBCOLS(L),L=2,3),M=1,3)
+ WRITE(IUNTW2,200) TBCOLS(2),TBCOLS(3),1,BRFRAC(K),NME(K),
+ & (TXNAME(2,IDKPRD(L,K)),L=1,5)
+ ENDIF
+ 140 FORMAT(5X,'BR[ -->',5(1X,A6),']=',F5.3,', ME code',I4)
+ 150 FORMAT(/1X,I3,1X,A8,1X,I8,1X,F8.3,1X,I2,1X,A3,1X,1P,E9.3,1X,I3,
+ & 2X,F5.3,1X,I3,5(1X,A8))
+ 160 FORMAT(A1,'hline',
+ & I4,' & ',A37,' & $',I8,'$ & ',F8.3,' & $',I2,A2,'$ & ',
+ & A3,' & $',1P,E9.3,'$ & ',I3,' ',A2/A1,'cline{2-8}')
+ 170 FORMAT(' & & ',A1,'multicolumn{2}{l}{$',A1,'longrightarrow$'/
+ & 5(A37,' '),'}'/' & ',A1,'multicolumn{2}{l}{BR = ',F5.3,'} & ',
+ & A1,'multicolumn{2}{l|}{ME code = ',I3,'} ',A2)
+ 180 FORMAT(A1,'hline'/
+ & I4,' & ',A37,' & $',I8,'$ & ',F8.3,' & $',I2,A2,'$ & ',
+ & A3,' & $',1P,E9.3,'$ & ',I3,' & ',F5.3,' & ',I3,
+ & 5(' & ',A37), ' ',A2/A1,'cline{2-8}')
+ 190 FORMAT('<TABLE ALIGN="CENTER" BGCOLOR=#',A6,'>'/'<TR>'/
+ & '<TH COLSPAN=8 BGCOLOR=#',A6,'><FONT COLOR=#',A6,'>',A37,
+ & ' Decay Modes</FONT></TH>'/'</TR>'/'<TR>'/'<TH></TH>',
+ & '<TH BGCOLOR=#',A6,'><FONT COLOR=#',A6,'>B.R.</FONT></TH>'/
+ & '<TH BGCOLOR=#',A6,'><FONT COLOR=#',A6,'>M.E.</FONT></TH>'/
+ & '<TH BGCOLOR=#',A6,' ALIGN="CENTER" COLSPAN=5>',
+ & '<FONT COLOR=#',A6,'>Decay products</FONT></TH>'/'</TR>')
+ 200 FORMAT('<TR>'/
+ & '<TD ALIGN="RIGHT" BGCOLOR=#',A6,'><FONT COLOR=#',A6,'>',
+ & I3,'</FONT></TD>'/
+ & '<TD ALIGN="RIGHT">',F5.3,'</TD>'/
+ & '<TD ALIGN="RIGHT">',I3,'</TD>'/
+ & 5('<TD ALIGN="CENTER">',A37,'</TD>'/),'</TR>')
+C Write out additional decay modes
+ IF (NMODES(I).GE.2) THEN
+ DO 210 J=2,NMODES(I)
+ K=LNEXT(K)
+ IF (PRNDEF) THEN
+ IF (NPRFMT.LE.1) THEN
+ WRITE(6,140) (RNAME(IDKPRD(L,K)),L=1,5),BRFRAC(K),NME(K)
+ ELSE
+ WRITE(6,220) BRFRAC(K),NME(K),(RNAME(IDKPRD(L,K)),L=1,5)
+ END IF
+ END IF
+ IF (PRNTEX) THEN
+ IF (NPRFMT.LE.1) THEN
+ WRITE(IUNITT,170) Z,Z,(TXNAME(1,IDKPRD(L,K)),L=1,5),Z,
+ & BRFRAC(K),Z,NME(K),ZZ
+ ELSE
+ WRITE(IUNITT,230) Z,BRFRAC(K),NME(K),
+ & (TXNAME(1,IDKPRD(L,K)),L=1,5),ZZ
+ ENDIF
+ ENDIF
+ IF (PRNWEB) WRITE(IUNTW2,200) TBCOLS(2),TBCOLS(3),J,
+ & BRFRAC(K),NME(K),(TXNAME(2,IDKPRD(L,K)),L=1,5)
+ 210 CONTINUE
+ IF (PRNTEX.AND.NPRFMT.EQ.2.AND.NMODES(I+1).EQ.0)
+ & WRITE(IUNITT,240) Z
+ 220 FORMAT(54X,F5.3,1X,I3,5(1X,A8))
+ 230 FORMAT(' & ',A1,'multicolumn{7}{|c|}{} & ',F5.3,' & ',I3,
+ & 5(' & ',A37),' ',A2)
+ 240 FORMAT(A1,'hline')
+ ENDIF
+ ENDIF
+C Close Web particle file
+ IF (PRNWEB) THEN
+ WRITE(IUNTW2,250)
+ CLOSE(IUNTW2)
+ ENDIF
+ 250 FORMAT('</TABLE>'/'</CENTER>'/'<P>'/
+ & 'Main particle <A HREF="index.html">index</A>'/
+ & '</BODY>'/'</HTML>')
+ 260 CONTINUE
+C Close the LaTeX file
+ IF (PRNTEX) THEN
+ WRITE(IUNITT,270) Z,Z,Z
+ CLOSE(IUNITT)
+ ENDIF
+C Close the index file
+ IF (PRNWEB) THEN
+ WRITE(IUNTW1,280)
+ CLOSE(IUNTW1)
+ ENDIF
+ 270 FORMAT(A1,'end{longtable}'/A1,'end{center}'/A1,'end{document}')
+ 280 FORMAT('</TABLE>'/'</CENTER>'/'</BODY>'/'</HTML>')
+ RETURN
+ END
+CDECK ID>, HWUECM.
+*CMZ :- -29/01/93 11.11.55 by Bryan Webber
+*-- Author : Giovanni Abbiendi & Luca Stanco
+C---------------------------------------------------------------------
+ FUNCTION HWUECM (S,M1QUAD,M2QUAD)
+C-----------------------------------------------------------------------
+C C.M. ENERGY OF A PARTICLE IN 1-->2 BRANCH, MAY BE SPACELIKE
+C---------------------------------------------------------------------
+ DOUBLE PRECISION HWUECM,S,M1QUAD,M2QUAD
+ HWUECM = (S+M1QUAD-M2QUAD)/(2.D0*SQRT(S))
+ END
+CDECK ID>, HWUEDT.
+*CMZ :- -09/12/91 12.07.08 by Mike Seymour
+*-- Author : Mike Seymour
+C-----------------------------------------------------------------------
+ SUBROUTINE HWUEDT(N,IEDT)
+C-----------------------------------------------------------------------
+C EDIT THE EVENT RECORD
+C IF N>0 DELETE THE N ENTRIES IN IEDT FROM EVENT RECORD
+C IF N<0 INSERT LINES AFTER THE -N ENTRIES IN IEDT
+C-----------------------------------------------------------------------
+ INCLUDE 'HERWIG61.INC'
+ INTEGER N,IEDT(*),IMAP(0:NMXHEP),IHEP,I,J,I1,I2
+ COMMON /HWUMAP/IMAP
+C---MOVE ENTRIES AND CALCULATE MAPPING OF POINTERS
+ IF (N.EQ.0) THEN
+ RETURN
+ ELSEIF (N.GT.0) THEN
+ I=1
+ I1=1
+ I2=NHEP
+ ELSE
+ I=NHEP-N
+ I1=NHEP
+ I2=1
+ ENDIF
+ DO 110 IHEP=I1,I2,SIGN(1,I2-I1)
+ IMAP(IHEP)=I
+ DO 100 J=1,ABS(N)
+ IF (IHEP.EQ.IEDT(J)) THEN
+ IF (N.GT.0) IMAP(IHEP)=0
+ I=I-1
+ IF (N.LT.0) IMAP(IHEP)=I
+ ENDIF
+ 100 CONTINUE
+ IF (IMAP(IHEP).EQ.I .AND. IHEP.NE.I) THEN
+ ISTHEP(I)=ISTHEP(IHEP)
+ IDHW(I)=IDHW(IHEP)
+ IDHEP(I)=IDHEP(IHEP)
+ JMOHEP(1,I)=JMOHEP(1,IHEP)
+ JMOHEP(2,I)=JMOHEP(2,IHEP)
+ JDAHEP(1,I)=JDAHEP(1,IHEP)
+ JDAHEP(2,I)=JDAHEP(2,IHEP)
+ CALL HWVEQU(5,PHEP(1,IHEP),PHEP(1,I))
+ CALL HWVEQU(4,VHEP(1,IHEP),VHEP(1,I))
+ ISTHEP(IHEP)=0
+ IDHW(IHEP)=20
+ IDHEP(IHEP)=0
+ JMOHEP(1,IHEP)=0
+ JMOHEP(2,IHEP)=0
+ JDAHEP(1,IHEP)=0
+ JDAHEP(2,IHEP)=0
+ CALL HWVZRO(5,PHEP(1,IHEP))
+ CALL HWVZRO(4,VHEP(1,IHEP))
+ ENDIF
+ I=I+SIGN(1,N)
+ 110 CONTINUE
+ NHEP=NHEP-N
+C---RELABEL POINTERS, SETTING ANY WHICH WERE TO DELETED ENTRIES TO ZERO
+ IMAP(0)=0
+ DO 200 IHEP=1,NHEP
+ JMOHEP(1,IHEP)=IMAP(JMOHEP(1,IHEP))
+ JMOHEP(2,IHEP)=IMAP(JMOHEP(2,IHEP))
+ JDAHEP(1,IHEP)=IMAP(JDAHEP(1,IHEP))
+ JDAHEP(2,IHEP)=IMAP(JDAHEP(2,IHEP))
+ 200 CONTINUE
+ END
+CDECK ID>, HWUEEC.
+*CMZ :- -26/04/91 14.22.30 by Federico Carminati
+*-- Author : Bryan Webber and Ian Knowles
+C-----------------------------------------------------------------------
+ SUBROUTINE HWUEEC(IL)
+C-----------------------------------------------------------------------
+C Loads cross-section coefficients, for kinematically open channels,
+C in llbar-->qqbar; lepton label IL=1-6: e,nu_e,mu,nu_mu,tau,nu_tau.
+C-----------------------------------------------------------------------
+ INCLUDE 'HERWIG61.INC'
+ DOUBLE PRECISION Q2
+ INTEGER IL,JL,IQ
+ Q2=EMSCA**2
+ JL=IL+10
+ MAXFL=0
+ TQWT=0.
+ DO 10 IQ=1,NFLAV
+ IF (EMSCA.GT.2.*RMASS(IQ)) THEN
+ MAXFL=MAXFL+1
+ MAPQ(MAXFL)=IQ
+ CALL HWUCFF(JL,IQ,Q2,CLQ(1,MAXFL))
+ TQWT=TQWT+CLQ(1,MAXFL)
+ ENDIF
+ 10 CONTINUE
+ IF (MAXFL.EQ.0) CALL HWWARN('HWUEEC',100,*999)
+ 999 END
+CDECK ID>, HWUEMV.
+*CMZ :- -30/06/94 19.31.08 by Mike Seymour
+*-- Author : Mike Seymour
+C-----------------------------------------------------------------------
+ SUBROUTINE HWUEMV(N,IFROM,ITO)
+C-----------------------------------------------------------------------
+C MOVE A BLOCK OF ENTRIES IN THE EVENT RECORD
+C N ENTRIES IN HEPEVT STARTING AT IFROM ARE MOVED TO AFTER ITO
+C-----------------------------------------------------------------------
+ INCLUDE 'HERWIG61.INC'
+ INTEGER N,IFROM,ITO,IMAP(0:NMXHEP),LFROM,LTO,I,IEDT(NMXHEP),IHEP,
+ $ JHEP,KHEP
+ COMMON /HWUMAP/IMAP
+ LFROM=IFROM
+ LTO=ITO
+ DO 100 I=1,N
+ 100 IEDT(I)=LTO
+ CALL HWUEDT(-N,IEDT)
+ DO 300 I=1,N
+ IHEP=LTO+I
+ JHEP=IMAP(LFROM+I-1)
+ ISTHEP(IHEP)=ISTHEP(JHEP)
+ IDHW(IHEP)=IDHW(JHEP)
+ IDHEP(IHEP)=IDHEP(JHEP)
+ JMOHEP(1,IHEP)=JMOHEP(1,JHEP)
+ JMOHEP(2,IHEP)=JMOHEP(2,JHEP)
+ JDAHEP(1,IHEP)=JDAHEP(1,JHEP)
+ JDAHEP(2,IHEP)=JDAHEP(2,JHEP)
+ CALL HWVEQU(5,PHEP(1,JHEP),PHEP(1,IHEP))
+ CALL HWVEQU(4,VHEP(1,JHEP),VHEP(1,IHEP))
+ DO 200 KHEP=1,NHEP
+ IF (JMOHEP(1,KHEP).EQ.JHEP) JMOHEP(1,KHEP)=IHEP
+ IF (JMOHEP(2,KHEP).EQ.JHEP) JMOHEP(2,KHEP)=IHEP
+ IF (JDAHEP(1,KHEP).EQ.JHEP) JDAHEP(1,KHEP)=IHEP
+ IF (JDAHEP(2,KHEP).EQ.JHEP) JDAHEP(2,KHEP)=IHEP
+ 200 CONTINUE
+ IEDT(I)=JHEP
+ 300 CONTINUE
+ CALL HWUEDT(N,IEDT)
+ 999 END
+CDECK ID>, HWUEPR.
+*CMZ :- -27/07/99 13.33.03 by Mike Seymour
+*-- Author : Ian Knowles, Bryan Webber & Kosuke Odagiri
+C-----------------------------------------------------------------------
+ SUBROUTINE HWUEPR
+C-----------------------------------------------------------------------
+C Prints out event data in a number of possible formats:
+C If (PRNDEF) ASCII to stout
+C If (PRNTEX) LaTeX to the file HWEV_*******.tex
+C Please check paper size and offsets given in mm
+C Uses the package longtable.sty
+C If (PRVTX>OR.NPRFMT.EQ.2) designed to be printed
+C as landscape
+C If (PRNWEB) HTML to the file HWEV_*******.html
+C Call HWUDPR to create particle property files in
+C the subdirectory HW_decays/
+C ******* gives the event number 0000001 etc.
+C-----------------------------------------------------------------------
+ INCLUDE 'HERWIG61.INC'
+ INTEGER MMWIDE,MMLONG,MMHOFF,MMVOFF,I,IST,IS,ID,MS,J,K,IUNITW,
+ & IUNITT
+ CHARACTER*1 Z
+ CHARACTER*2 ZZ
+ CHARACTER*6 BGCOLS(5),TBCOLS(3),THEAD(17,3)
+ CHARACTER*7 HWUNST,TMPNME
+ CHARACTER*16 FNAMET
+ CHARACTER*17 FNAMEW
+ CHARACTER*27 FNAMEP
+ CHARACTER*28 TITLE(11),SECTXT
+ LOGICAL FIRST(11),NEWSEC
+ COMMON/PAPER/MMWIDE,MMLONG,MMHOFF,MMVOFF
+ EXTERNAL HWUNST
+C
+ DATA BGCOLS/'ffffff','0000aa','aa0000','00aa00','aa00ff'/
+ DATA TBCOLS/'ccccff','9966ff','ffff00'/
+ DATA THEAD/ 17*'9966ff',17*'ffff00',
+ & 'IHEP ',' ID ',' IDPDG',' IST ',' MO1 ',' MO2 ',
+ & ' DA1 ',' DA2 ',' P-X ',' P-Y ',' P-Z ','ENERGY',
+ & ' MASS ',' V-X ',' V-Y ',' V-Z ',' V-C*T'/
+ DATA TITLE/' ---INITIAL STATE--- ',
+ & ' ---HARD SUBPROCESS--- ',
+ & ' ---PARTON SHOWERS--- ',
+ & ' ---GLUON SPLITTING--- ',
+ & ' ---CLUSTER FORMATION--- ',
+ & ' ---CLUSTER DECAYS--- ',
+ & ' ---STRONG HADRON DECAYS--- ',
+ & ' ---HEAVY PARTICLE DECAYS---',
+ & ' ---H/W/Z BOSON DECAYS--- ',
+ & ' ---SOFT UNDERLYING EVENT---',
+ & ' ---MULTIPLE SCATTERING--- '/
+ Z=CHAR(92)
+ ZZ=Z//Z
+C
+ IUNITT=50
+ IUNITW=51
+C Write out any required file header information
+ TMPNME=HWUNST(NEVHEP)
+ IF (PRNTEX) THEN
+ WRITE(FNAMET,'(A5,A7,A4)') 'HWEV_',TMPNME,'.tex'
+ OPEN(IUNITT,STATUS='UNKNOWN',FILE=FNAMET)
+ IF (PRVTX.OR.NPRFMT.EQ.2) THEN
+ WRITE(IUNITT,10) Z,Z,Z,MMLONG,Z,MMWIDE,Z,MMVOFF,Z,MMHOFF,Z,Z,Z
+ ELSE
+ WRITE(IUNITT,10) Z,Z,Z,MMWIDE,Z,MMLONG,Z,MMHOFF,Z,MMVOFF,Z,Z,Z
+ ENDIF
+ ENDIF
+ IF (PRNWEB) THEN
+ WRITE(FNAMEW,'(A5,A7,A5)') 'HWEV_',TMPNME,'.html'
+ OPEN(IUNITW,STATUS='UNKNOWN',FILE=FNAMEW)
+ WRITE(IUNITW,20) BGCOLS
+ ENDIF
+ 10 FORMAT(A1,'documentclass{article}'/A1,'usepackage{longtable}'/
+ & A1,'textwidth ',I4,'mm ',A1,'textheight ',I4,'mm'/
+ & A1,'hoffset ',I4,'mm ',A1,'voffset ',I4,'mm'/
+ & A1,'pagestyle{empty}'/A1,'begin{document}'/A1,'begin{center}')
+ 20 FORMAT('<!-- No Less productions -->'/'<HTML>'/'<HEAD>'/
+ & '<TITLE>HERWIG Event Record</TITLE>'/'</HEAD>'/
+ & '<BODY BGCOLOR=#',A6,' TEXT=#',A6,' LINK=#',A6,
+ & ' ALINK=#',A6,' VLINK=#',A6,'>')
+C Write out event header details and set up tables
+ IF (PRNDEF) THEN
+ WRITE(6,30) NEVHEP,PBEAM1,PART1,PBEAM2,PART2,IPROC,NRN,
+ & ISTAT,IERROR,EVWGT
+ ENDIF
+ IF (PRNTEX) THEN
+ WRITE(IUNITT,40) Z,Z,Z,ISTAT,ZZ,Z,IPROC,PBEAM1,PBEAM2,NRN(1),
+ & IERROR,ZZ,Z,Z,NEVHEP,TXNAME(1,IDHW(1)),TXNAME(1,IDHW(2)),
+ & NRN(2),EVWGT,ZZ,Z,Z,Z
+ IF (PRVTX) THEN
+ WRITE(IUNITT,50) Z,Z,Z,Z,Z
+ ELSE
+ WRITE(IUNITT,60) Z,Z,Z,Z,Z
+ ENDIF
+ ENDIF
+ IF (PRNWEB) THEN
+ WRITE(IUNITW,70) TBCOLS(1),TBCOLS(2),(TBCOLS(2),TBCOLS(3),
+ & I=1,4),ISTAT,TBCOLS(2),TBCOLS(3),IPROC,PBEAM1,PBEAM2,NRN(1),
+ & TBCOLS(2),TBCOLS(3),IERROR
+ WRITE(IUNITW,71) TBCOLS(2),TBCOLS(3),NEVHEP,TXNAME(2,IDHW(1)),
+ & TXNAME(2,IDHW(2)),NRN(2),TBCOLS(2),TBCOLS(3),EVWGT,TBCOLS(1)
+ ENDIF
+ 30 FORMAT(///1X,'EVENT ',I7,':',F8.2,' GEV/C ',A8,' ON ',F8.2,
+ & ' GEV/C ',A8,' PROCESS:',I6/1X,'SEEDS: ',I11,' & ',I11,
+ & ' STATUS: ',I4,' ERROR:',I4,' WEIGHT: ',1P,E11.4/)
+ 40 FORMAT(A1,'begin{tabular}{|l|r|c|c|r|l|c|}'/A1,'hline'/
+ & A1,'multicolumn{2}{|c|}{HERWIG 6.0} & Beam 1: & Beam 2: & ',
+ & 'Seeds: & Status: & ',I4, ' ',A2/A1,'hline'/'Process: & ',I6,
+ & ' & ',F8.2,'~GeV/c & ',F8.2,'~GeV/c',' & ',I11,' & Error: & ',
+ & I4,' ',A2/A1,'cline{1-2} ',A1,'cline{6-7}'/'Event: & ',I7,' & ',
+ & A37,' & ',A37,' & ',I11,' & Weight: & ',1P,E11.4,' ',A2/A1,
+ & 'hline'/A1,'end{tabular}'/A1,'vskip 5mm')
+ 50 FORMAT(A1,'begin{longtable}{|r|c|r|r|r|r|r|r|r|r|r|r|r|r|r|r|r|}'/
+ & A1,'hline'/A1,'endhead'/A1,'hline'/A1,'endfoot')
+ 60 FORMAT(A1,'begin{longtable}{|r|c|r|r|r|r|r|r|r|r|r|r|r|}'/
+ & A1,'hline'/A1,'endhead'/A1,'hline'/A1,'endfoot')
+ 70 FORMAT(/'<CENTER>'/'<TABLE ALIGN="CENTER" BGCOLOR=#',A6,'>'/
+ & '<TR>'/'<TH BGCOLOR=#',A6,' COLSPAN=2>',
+ & '<A HREF="http://hepwww.rl.ac.uk/theory/seymour/herwig/">',
+ & 'HERWIG 6.0</A></TH>'/
+ & '<TH BGCOLOR=#',A6,'><FONT COLOR=#',A6,'>Beam 1:</FONT></TH>'/
+ & '<TH BGCOLOR=#',A6,'><FONT COLOR=#',A6,'>Beam 2:</FONT></TH>'/
+ & '<TH BGCOLOR=#',A6,'><FONT COLOR=#',A6,'>Seeds:</FONT></TH>'/
+ & '<TH BGCOLOR=#',A6,' ALIGN="LEFTT"><FONT COLOR=#',A6,
+ & '>Status:</FONT></TH>'/'<TD ALIGN="RIGHT">',I4,'</TD>'/'</TR>'/
+ & '<TR>'/
+ & '<TH BGCOLOR=#',A6,' ALIGN="LEFTT"><FONT COLOR=#',A6,
+ & '>Process:</Th>'/'<TD>',I6,'</TD>'/
+ & '<TD>',F8.2,' GeV/c</TD>'/'<TD>',F8.2,' GeV/c</TD>'/
+ & '<TD ALIGN="RIGHT">',I11,'</TD>'/
+ & '<TH BGCOLOR=#',A6,' ALIGN="LEFT"><FONT COLOR=#',A6,
+ & '>Error:</FONT></TH>'/'<TD ALIGN="RIGHT">',I4,'</TD>'/'</TR>')
+ 71 FORMAT('<TR>'/
+ & '<TH BGCOLOR=#',A6,' ALIGN="LEFT"><FONT COLOR=#',A6,
+ & '>Event:</Th>'/'<TD ALIGN="RIGHT">',I7,'</TD>'/
+ & '<TD ALIGN="CENTER">',A37,'</TD>'/
+ & '<TD ALIGN="CENTER">',A37,'</TD>'/
+ & '<TD ALIGN="RIGHT">',I11,'</TD>'/
+ & '<TH BGCOLOR=#',A6,' ALIGN="LEFT"><FONT COLOR=#',A6,
+ & '>Weight:</FONT></TH>'/'<TD>',1P,E11.4,'</TD>'/'</TR>'/
+ & '</TABLE>'//'<P>'/
+ & '<TABLE ALIGN="CENTER" BGCOLOR=#',A6,'>')
+C Initialize control flags
+ DO 80 I=1,11
+ 80 FIRST(I)=.TRUE.
+C Loop through event record
+ DO 410 I=1,NHEP
+ NEWSEC=.FALSE.
+C First find start of new sections
+ IST=ISTHEP(I)
+ IS=IST/10
+ ID=IDHW(I)
+ IF (IST.EQ.101) THEN
+ NEWSEC=.TRUE.
+ SECTXT=TITLE(1)
+ ELSEIF (FIRST(2).AND.IS.EQ.12) THEN
+ NEWSEC=.TRUE.
+ SECTXT=TITLE(2)
+ FIRST(2)=.FALSE.
+ ELSEIF (FIRST(3).AND.IS.EQ.14) THEN
+ NEWSEC=.TRUE.
+ SECTXT=TITLE(3)
+ FIRST(3)=.FALSE.
+ FIRST(8)=.TRUE.
+ FIRST(9)=.TRUE.
+ FIRST(11)=.TRUE.
+ ELSEIF (FIRST(4).AND.IST.GE.158.AND.IST.NE.160
+ & .AND.IST.LE.162) THEN
+ NEWSEC=.TRUE.
+ SECTXT=TITLE(4)
+ FIRST(4)=.FALSE.
+ ELSEIF (FIRST(5).AND.(IS.EQ.16.OR.IS.EQ.18)
+ & .AND.IST.GT.162) THEN
+ NEWSEC=.TRUE.
+ SECTXT=TITLE(5)
+ FIRST(5)=.FALSE.
+ ELSEIF (IS.EQ.19.OR.IST.EQ.1.OR.IST.EQ.200) THEN
+ MS=ISTHEP(JMOHEP(1,I))/10
+ IF (MS.EQ.15.OR.MS.EQ.16.OR.MS.EQ.18) THEN
+ IF (FIRST(6)) THEN
+ NEWSEC=.TRUE.
+ SECTXT=TITLE(6)
+ FIRST(6)=.FALSE.
+ ENDIF
+ ELSEIF (FIRST(7).AND.(.NOT.FIRST(6))) THEN
+ NEWSEC=.TRUE.
+ SECTXT=TITLE(7)
+ FIRST(7)=.FALSE.
+ ENDIF
+ ELSEIF (FIRST(8).AND.(IST.EQ.125.OR.IST.EQ.155.OR.
+ & (IST.EQ.123.AND.ISTHEP(JMOHEP(1,I)).EQ.199))) THEN
+ NEWSEC=.TRUE.
+ SECTXT=TITLE(8)
+ FIRST(3)=.TRUE.
+ FIRST(4)=.TRUE.
+ FIRST(5)=.TRUE.
+ FIRST(6)=.TRUE.
+ FIRST(7)=.TRUE.
+ FIRST(8)=.FALSE.
+ ELSEIF (FIRST(9).AND.(IST.EQ.123.OR.IST.EQ.124)) THEN
+ MS=ABS(IDHEP(JMOHEP(1,I)))
+ IF (MS.EQ.23.OR.MS.EQ.24.OR.MS.EQ.25) THEN
+ NEWSEC=.TRUE.
+ SECTXT=TITLE(9)
+ FIRST(3)=.TRUE.
+ FIRST(4)=.TRUE.
+ FIRST(5)=.TRUE.
+ FIRST(6)=.TRUE.
+ FIRST(7)=.TRUE.
+ FIRST(8)=.TRUE.
+ FIRST(9)=.FALSE.
+ ENDIF
+ ELSEIF (IST.EQ.170) THEN
+ NEWSEC=.TRUE.
+ SECTXT=TITLE(10)
+ ELSEIF (FIRST(11).AND.(ID.EQ.71.OR.ID.EQ.72)) THEN
+ NEWSEC=.TRUE.
+ SECTXT=TITLE(11)
+ FIRST(3)=.TRUE.
+ FIRST(11)=.FALSE.
+ ENDIF
+C Prit out section heading
+ IF (NEWSEC) THEN
+ IF (PRVTX) THEN
+ IF (PRNDEF) THEN
+ IF (NPRFMT.EQ.1) THEN
+ WRITE(6, 90) SECTXT,(THEAD(J,3),J=1,17)
+ ELSE
+ WRITE(6,100) SECTXT,(THEAD(J,3),J=1,17)
+ ENDIF
+ ENDIF
+ IF (PRNTEX) WRITE(IUNITT,110) Z,Z,SECTXT,ZZ,Z,
+ & (Z,THEAD(J,3),J=1,17),ZZ,Z
+ IF (PRNWEB) WRITE(IUNITW,120) TBCOLS(2),TBCOLS(3),
+ & SECTXT,((THEAD(K,J),J=1,3),K=1,17)
+ 90 FORMAT(/46X,A28//1X,A4,2X,A6,3X,A6,5A4,3(2X,A6),A6,3X,A5,
+ & 4(4X,A6))
+ 100 FORMAT(/58X,A28//1X,A4,2X,A6,3X,A6,5A4,3(6X,A6),5X,A6,8X,A5,
+ & 4X,A6,2(5X,A6),6X,A6)
+ 110 FORMAT(A1,'hline'/A1,'multicolumn{17}{|c|}{',A28,'} ',A2/A1,
+ & 'hline'/16(A1,'multicolumn{1}{|c|}{',A6,'} & '),
+ & A1,'multicolumn{1}{|c|}{',A6,'} ',A2/A1,'hline')
+ 120 FORMAT('<TR><TH COLSPAN=17 BGCOLOR=#',A6,'>',
+ & '<FONT COLOR=#',A6,'>',A28,'</FONT></TH></TR>'/
+ & '<TR>',17(/,1X,'<TH BGCOLOR=#',A6,'>
+ & <FONT COLOR=',A6,'>',A6,'</FONT></TH>'),'</TR>')
+ ELSE
+ IF (PRNDEF) THEN
+ IF (NPRFMT.EQ.1) THEN
+ WRITE(6,130) SECTXT,(THEAD(J,3),J=1,13)
+ ELSE
+ WRITE(6,140) SECTXT,(THEAD(J,3),J=1,13)
+ ENDIF
+ END IF
+ IF (PRNTEX) WRITE(IUNITT,150) Z,Z,SECTXT,ZZ,Z,
+ & (Z,THEAD(J,3),J=1,13),ZZ,Z
+ IF (PRNWEB) WRITE(IUNITW,160) TBCOLS(2),TBCOLS(3),
+ & SECTXT,((THEAD(K,J),J=1,3),K=1,13)
+ 130 FORMAT(/26X,A28//1X,A4,2X,A6,3X,A6,5A4,3(2X,A6),A6,3X,A5)
+ 140 FORMAT(/36X,A28//1X,A4,2X,A6,3X,A6,5A4,3(6X,A6),5X,A6,8X,A5)
+ 150 FORMAT(A1,'hline'/A1,'multicolumn{13}{|c|}{',A28,'} ',A2/A1,
+ & 'hline'/12(A1,'multicolumn{1}{|c|}{',A6,'} & '),
+ & A1,'multicolumn{1}{|c|}{',A6,'} ',A2/A1,'hline')
+ 160 FORMAT('<TR><TH COLSPAN=13 BGCOLOR=#',A6,'>',
+ & '<FONT COLOR=#',A6,'>',A28,'</FONT></TH></TR>'/
+ & '<TR>',13(/'<TH BGCOLOR=#',A6,'>',
+ & '<FONT COLOR=#',A6,'>',A6,'</FONT></TH>'),'</TR>')
+ ENDIF
+ ENDIF
+C Now print out the data line
+ IF (PRVTX) THEN
+C Include vertex information
+ IF (PRNDEF) THEN
+ IF (PRNDEC) THEN
+ IF (NPRFMT.EQ.1) THEN
+ WRITE(6,190) I,RNAME(IDHW(I)),IDHEP(I),IST,
+ & JMOHEP(1,I),JMOHEP(2,I),JDAHEP(1,I),JDAHEP(2,I),
+ & (PHEP(J,I),J=1,5),(VHEP(J,I),J=1,4)
+ ELSE
+ WRITE(6,200) I,RNAME(IDHW(I)),IDHEP(I),IST,
+ & JMOHEP(1,I),JMOHEP(2,I),JDAHEP(1,I),JDAHEP(2,I),
+ & (PHEP(J,I),J=1,5),(VHEP(J,I),J=1,4)
+ ENDIF
+ ELSE
+ IF (NPRFMT.EQ.1) THEN
+ WRITE(6,210) I,RNAME(IDHW(I)),IDHEP(I),IST,
+ & JMOHEP(1,I),JMOHEP(2,I),JDAHEP(1,I),JDAHEP(2,I),
+ & (PHEP(J,I),J=1,5),(VHEP(J,I),J=1,4)
+ ELSE
+ WRITE(6,220) I,RNAME(IDHW(I)),IDHEP(I),IST,
+ & JMOHEP(1,I),JMOHEP(2,I),JDAHEP(1,I),JDAHEP(2,I),
+ & (PHEP(J,I),J=1,5),(VHEP(J,I),J=1,4)
+ ENDIF
+ ENDIF
+ ENDIF
+ IF (PRNTEX) WRITE(IUNITT,230) I,TXNAME(1,IDHW(I)),IDHEP(I),
+ & IST,JMOHEP(1,I),JMOHEP(2,I),JDAHEP(1,I),JDAHEP(2,I),
+ & (PHEP(J,I),J=1,5),(VHEP(J,I),J=1,4),ZZ
+ IF (PRNWEB) THEN
+ WRITE(IUNITW,240) TBCOLS(2),TBCOLS(3),I,I
+ IF (IDHEP(I).EQ.0.OR.IDHEP(I).EQ.91) THEN
+ WRITE(IUNITW,250) TXNAME(2,IDHW(I)),IDHEP(I),IST
+ ELSE
+ TMPNME=HWUNST(IDHW(I))
+ WRITE(FNAMEP,'(A15,A7,A5)')
+ & 'HW_decays/PART_',TMPNME,'.html'
+ WRITE(IUNITW,260) FNAMEP,TXNAME(2,IDHW(I)),IDHEP(I),IST
+ ENDIF
+ DO 170 J=1,2
+ IF (JMOHEP(J,I).NE.0) THEN
+ WRITE(IUNITW,270) JMOHEP(J,I),JMOHEP(J,I)
+ ELSE
+ WRITE(IUNITW,280) JMOHEP(J,I)
+ ENDIF
+ 170 CONTINUE
+ DO 180 J=1,2
+ IF (JDAHEP(J,I).NE.0) THEN
+ WRITE(IUNITW,270) JDAHEP(J,I),JDAHEP(J,I)
+ ELSE
+ WRITE(IUNITW,280) JDAHEP(J,I)
+ ENDIF
+ 180 CONTINUE
+ IF (NPRFMT.EQ.1) THEN
+ WRITE(IUNITW,290) (PHEP(J,I),J=1,5),(VHEP(J,I),J=1,4)
+ ELSE
+ WRITE(IUNITW,300) (PHEP(J,I),J=1,5),(VHEP(J,I),J=1,4)
+ ENDIF
+ ENDIF
+ 190 FORMAT(1X,I4,1X,A8,I8,5I4, 2F8.2,2F7.1,F8.2,1P,4E10.3)
+ 200 FORMAT(1X,I4,1X,A8,I8,5I4, 5F12.5,1P,4E11.4)
+ 210 FORMAT(1X,Z4,1X,A8,I8,I4,4Z4,2F8.2,2F7.1,F8.2,1P,4E10.3)
+ 220 FORMAT(1X,Z4,1X,A8,I8,I4,4Z4,5F12.5,1P,4E11.4)
+ 230 FORMAT(I4,' & ',A37,' & $',I8,'$',5(' & ',I4),
+ & 5(' & $',F8.2,'$'),4(' & $',1P,E11.3,'$'),' ',A2)
+ 240 FORMAT('<TR>'/'<TD BGCOLOR=#',A6,' ALIGN="RIGHT">',
+ & '<FONT COLOR=#',A6,'><A NAME="',I4,'">',I4,'</A></FONT></TD>'/)
+ 250 FORMAT('<TD ALIGN="CENTER">',A37,'</TD>'/'<TD ALIGN="RIGHT">',
+ & I8,'</TD>'/'<TD ALIGN="RIGHT">',I4,'</TD>')
+ 260 FORMAT('<TD ALIGN="CENTER"><A HREF="',A27,'">',A37,'</A></TD>'/
+ & '<TD ALIGN="RIGHT">',I8,'</TD>'/
+ & '<TD ALIGN="RIGHT">',I4,'</TD>')
+ 270 FORMAT(/'<TD ALIGN="RIGHT"><A HREF="#',I4,'">',I4,'</A></TD>')
+ 280 FORMAT(/'<TD ALIGN="RIGHT">',I4,'</TD>')
+ 290 FORMAT(5(/'<TD ALIGN="RIGHT">',F8.2,'</TD>'),1P,
+ & 4(/'<TD ALIGN="RIGHT">',E10.3,'</TD>')/'</TR>')
+ 300 FORMAT(5(/'<TD ALIGN="RIGHT">',F12.5,'</TD>'),1P,
+ & 4(/'<TD ALIGN="RIGHT">',E11.4,'</TD>')/'</TR>')
+ ELSE
+C Do not include vertex information
+ IF (PRNDEF) THEN
+ IF (PRNDEC) THEN
+ IF (NPRFMT.EQ.1) THEN
+ WRITE(6,330) I,RNAME(IDHW(I)),IDHEP(I),IST,
+ & JMOHEP(1,I),JMOHEP(2,I),JDAHEP(1,I),JDAHEP(2,I),
+ & (PHEP(J,I),J=1,5)
+ ELSE
+ WRITE(6,340) I,RNAME(IDHW(I)),IDHEP(I),IST,
+ & JMOHEP(1,I),JMOHEP(2,I),JDAHEP(1,I),JDAHEP(2,I),
+ & (PHEP(J,I),J=1,5)
+ ENDIF
+ ELSE
+ IF (NPRFMT.EQ.1) THEN
+ WRITE(6,350) I,RNAME(IDHW(I)),IDHEP(I),IST,
+ & JMOHEP(1,I),JMOHEP(2,I),JDAHEP(1,I),JDAHEP(2,I),
+ & (PHEP(J,I),J=1,5)
+ ELSE
+ WRITE(6,360) I,RNAME(IDHW(I)),IDHEP(I),IST,
+ & JMOHEP(1,I),JMOHEP(2,I),JDAHEP(1,I),JDAHEP(2,I),
+ & (PHEP(J,I),J=1,5)
+ ENDIF
+ ENDIF
+ ENDIF
+ IF (PRNTEX) THEN
+ IF (NPRFMT.EQ.1) THEN
+ WRITE(IUNITT,370) I,TXNAME(1,IDHW(I)),IDHEP(I),
+ & IST,JMOHEP(1,I),JMOHEP(2,I),JDAHEP(1,I),JDAHEP(2,I),
+ & (PHEP(J,I),J=1,5),ZZ
+ ELSE
+ WRITE(IUNITT,380) I,TXNAME(1,IDHW(I)),IDHEP(I),
+ & IST,JMOHEP(1,I),JMOHEP(2,I),JDAHEP(1,I),JDAHEP(2,I),
+ & (PHEP(J,I),J=1,5),ZZ
+ ENDIF
+ ENDIF
+ IF (PRNWEB) THEN
+ WRITE(IUNITW,240) TBCOLS(2),TBCOLS(3),I,I
+ IF (IDHEP(I).EQ.0.OR.IDHEP(I).EQ.91) THEN
+ WRITE(IUNITW,250) TXNAME(2,IDHW(I)),IDHEP(I),IST
+ ELSE
+ TMPNME = HWUNST(IDHW(I))
+ WRITE(FNAMEP,'(A15,A7,A5)')
+ & 'HW_decays/PART_',TMPNME,'.html'
+ WRITE(IUNITW,260) FNAMEP,TXNAME(2,IDHW(I)),IDHEP(I),IST
+ ENDIF
+ DO 310 J=1,2
+ IF (JMOHEP(J,I).NE.0) THEN
+ WRITE(IUNITW,270) JMOHEP(J,I),JMOHEP(J,I)
+ ELSE
+ WRITE(IUNITW,280) JMOHEP(J,I)
+ ENDIF
+ 310 CONTINUE
+ DO 320 J=1,2
+ IF (JDAHEP(J,I).NE.0) THEN
+ WRITE(IUNITW,270) JDAHEP(J,I),JDAHEP(J,I)
+ ELSE
+ WRITE(IUNITW,280) JDAHEP(J,I)
+ ENDIF
+ 320 CONTINUE
+ IF (NPRFMT.EQ.1) THEN
+ WRITE(IUNITW,390) (PHEP(J,I),J=1,5)
+ ELSE
+ WRITE(IUNITW,400) (PHEP(J,I),J=1,5)
+ ENDIF
+ ENDIF
+ 330 FORMAT(1X,I4,1X,A8,I8,5I4 ,2F8.2,2F7.1,F8.2)
+ 340 FORMAT(1X,I4,1X,A8,I8,5I4 ,5F12.5)
+ 350 FORMAT(1X,Z4,1X,A8,I8,I4,4Z4,2F8.2,2F7.1,F8.2)
+ 360 FORMAT(1X,Z4,1X,A8,I8,I4,4Z4,5F12.5)
+ 370 FORMAT(I4,' & ',A37,' & $',I8,'$',5(' & ',I4),
+ & 5(' & $',F8.2,'$'),' ',A2)
+ 380 FORMAT(I4,' & ',A37,' & $',I8,'$',5(' & ',I4),
+ & 5(' & $',F12.5,'$'),' ',A2)
+ 390 FORMAT(5(/'<TD ALIGN="RIGHT">',F8.2,'</TD>')/'</TR>')
+ 400 FORMAT(5(/'<TD ALIGN="RIGHT">',F12.5,'</TD>')/'</TR>')
+ ENDIF
+ 410 CONTINUE
+C Close the files
+ IF (PRNTEX) THEN
+ WRITE(IUNITT,420) Z,Z,Z
+ 420 FORMAT(A1,'end{longtable}'/A1,'end{center}'/A1,'end{document}')
+ CLOSE(IUNITT)
+ ENDIF
+ IF (PRNWEB) THEN
+ WRITE(IUNITW,430)
+ 430 FORMAT('</TABLE>'/'</CENTER>'/'</BODY>'/'</HTML>')
+ CLOSE(IUNITW)
+ ENDIF
+ RETURN
+ END
+CDECK ID>, HWUFNE.
+*CMZ :- -16/10/93 12.42.15 by Mike Seymour
+*-- Author : Mike Seymour
+C-----------------------------------------------------------------------
+ SUBROUTINE HWUFNE
+C-----------------------------------------------------------------------
+C FINALISES THE EVENT BY UNDOING THE LORENTZ BOOST IF THERE WAS ONE,
+C CHECKING FOR ERRORS, AND PRINTING
+C-----------------------------------------------------------------------
+ INCLUDE 'HERWIG61.INC'
+ LOGICAL CALLED
+ COMMON/HWDBUG/CALLED
+ CALLED=.TRUE.
+C---UNBOOST EVENT RECORD IF NECESSARY
+ CALL HWUBST(0)
+C---CHECK FOR FATAL ERROR
+ IF (IERROR.NE.0) THEN
+ IF (IERROR.GT.0) THEN
+ NUMER=NUMER+1
+ ELSE
+ NUMERU=NUMERU+1
+ ENDIF
+ IF (NUMER.GT.MAXER) CALL HWWARN('HWUFNE',300,*999)
+ NEVHEP=NEVHEP-1
+C---PRINT FIRST MAXPR EVENTS
+ ELSEIF (NEVHEP.LE.MAXPR) THEN
+ CALL HWUEPR
+ END IF
+ 999 END
+CDECK ID>, HWUGAU.
+*CMZ :- -26/04/91 11.11.56 by Bryan Webber
+*-- Author : Adapted by Bryan Webber
+C-----------------------------------------------------------------------
+ FUNCTION HWUGAU(F,A,B,EPS)
+C-----------------------------------------------------------------------
+C ADAPTIVE GAUSSIAN INTEGRATION OF FUNCTION F
+C IN INTERVAL (A,B) WITH PRECISION EPS
+C (MODIFIED CERN LIBRARY ROUTINE GAUSS)
+C-----------------------------------------------------------------------
+ DOUBLE PRECISION HWUGAU,F,A,B,EPS,CONST,AA,BB,C1,C2,S8,U,S16,
+ & W(12),X(12),ZERO
+ INTEGER I
+ EXTERNAL F
+ PARAMETER (ZERO=0.0D0)
+ DATA W/.1012285363D0,.2223810345D0,.3137066459D0,
+ & .3626837834D0,.0271524594D0,.0622535239D0,
+ & .0951585117D0,.1246289713D0,.1495959888D0,
+ & .1691565194D0,.1826034150D0,.1894506105D0/
+ DATA X/.9602898565D0,.7966664774D0,.5255324099D0,
+ & .1834346425D0,.9894009350D0,.9445750231D0,
+ & .8656312024D0,.7554044084D0,.6178762444D0,
+ & .4580167777D0,.2816035508D0,.0950125098D0/
+ HWUGAU=0.
+ IF (A.EQ.B) RETURN
+ CONST=.005/ABS(B-A)
+ BB=A
+ 1 AA=BB
+ BB=B
+ 2 C1=0.5*(BB+AA)
+ C2=0.5*(BB-AA)
+ S8=0.
+ DO 3 I=1,4
+ U=C2*X(I)
+ S8=S8+W(I)*(F(C1+U)+F(C1-U))
+ 3 CONTINUE
+ S8=C2*S8
+ S16=0.
+ DO 4 I=5,12
+ U=C2*X(I)
+ S16=S16+W(I)*(F(C1+U)+F(C1-U))
+ 4 CONTINUE
+ S16=C2*S16
+ IF (ABS(S16-S8).LE.EPS*(1.+ABS(S16))) GOTO 5
+ BB=C1
+ IF (CONST*ABS(C2).NE.ZERO) GOTO 2
+C---TOO HIGH ACCURACY REQUESTED
+ CALL HWWARN('HWUGAU',500,*999)
+ 5 HWUGAU=HWUGAU+S16
+ IF (BB.NE.B) GOTO 1
+ 999 END
+CDECK ID>, HWUIDT.
+*CMZ :- -26/04/91 10.18.58 by Bryan Webber
+*-- Author : Bryan Webber
+C-----------------------------------------------------------------------
+ SUBROUTINE HWUIDT(IOPT,IPDG,IWIG,NWIG)
+C-----------------------------------------------------------------------
+C TRANSLATES PARTICLE IDENTIFIERS:
+C IPDG = PARTICLE DATA GROUP CODE
+C IWIG = HERWIG IDENTITY CODE
+C NWIG = HERWIG CHARACTER*8 NAME
+C
+C IOPT= 1 GIVEN IPDG, RETURNS IWIG AND NWIG
+C IOPT= 2 GIVEN IWIG, RETURNS IPDG AND NWIG
+C IOPT= 3 GIVEN NWIG, RETURNS IPDG AND IWIG
+C-----------------------------------------------------------------------
+ INCLUDE 'HERWIG61.INC'
+ INTEGER IOPT,IPDG,IWIG,I
+ CHARACTER*8 NWIG
+ IF (IOPT.EQ.1) THEN
+ DO 10 I=0,NRES
+ IF (IDPDG(I).EQ.IPDG) THEN
+ IWIG=I
+ NWIG=RNAME(I)
+ RETURN
+ ENDIF
+ 10 CONTINUE
+ WRITE(6,20) IPDG
+ 20 FORMAT(1X,'Particle not recognised, PDG code: ',I8)
+ IWIG=20
+ NWIG=RNAME(20)
+ CALL HWWARN('HWUIDT',101,*999)
+ ELSEIF (IOPT.EQ.2) THEN
+ IF (IWIG.LT.0.OR.IWIG.GT.NRES) THEN
+ WRITE(6,30) IWIG
+ 30 FORMAT(1X,'Particle not recognised, HERWIG code: ',I3)
+ IPDG=0
+ NWIG=RNAME(20)
+ CALL HWWARN('HWUIDT',102,*999)
+ ELSE
+ IPDG=IDPDG(IWIG)
+ NWIG=RNAME(IWIG)
+ RETURN
+ ENDIF
+ ELSEIF (IOPT.EQ.3) THEN
+ DO 40 I=0,NRES
+ IF (RNAME(I).EQ.NWIG) THEN
+ IWIG=I
+ IPDG=IDPDG(I)
+ RETURN
+ ENDIF
+ 40 CONTINUE
+ WRITE(6,50) NWIG
+ 50 FORMAT(1X,'Particle not recognised, HERWIG name: ',A8)
+ IWIG=20
+ IPDG=0
+ CALL HWWARN('HWUIDT',103,*999)
+ ELSE
+ CALL HWWARN('HWUIDT',404,*999)
+ ENDIF
+ 999 END
+CDECK ID>, HWUINC.
+*CMZ :- -26/04/91 11.11.56 by Bryan Webber
+*-- Author : Bryan Webber
+C-----------------------------------------------------------------------
+ SUBROUTINE HWUINC
+C-----------------------------------------------------------------------
+C COMPUTES CONSTANTS AND LOOKUP TABLES
+C-----------------------------------------------------------------------
+ INCLUDE 'HERWIG61.INC'
+ DOUBLE PRECISION HWBVMC,HWUALF,HWUPCM,XMIN,XMAX,XPOW,QR,DQKWT,
+ & UQKWT,SQKWT,DIQWT,QMAX,PMAX,PTLIM,ETLIM,PGS,PTELM,X,QSCA,UPV,DNV,
+ & USEA,DSEA,STR,CHM,BTM,TOP,GLU,VAL(20),CLMXPW,RCLPOW,TEST,RPM(2)
+ INTEGER ISTOP,I,J,IQK,IDB,IDT,ISET,IOP1,IOP2,IP2,ID
+ LOGICAL FIRST,FSTPDF
+ CHARACTER*20 PARM(20)
+ EXTERNAL HWBVMC,HWUALF,HWUPCM
+ COMMON/HWRPIN/XMIN,XMAX,XPOW,FIRST
+ COMMON/W50516/FSTPDF
+ IPRO=MOD(IPROC/100,100)
+ IQK=MOD(IPROC,100)
+C---SET UP BEAMS
+ CALL HWUIDT(3,IDB,IPART1,PART1)
+ CALL HWUIDT(3,IDT,IPART2,PART2)
+ EBEAM1=SQRT(PBEAM1**2+RMASS(IPART1)**2)
+ EBEAM2=SQRT(PBEAM2**2+RMASS(IPART2)**2)
+C---PHOTON CUTOFF DEFAULTS TO ROOT S
+ PTLIM=SQRT(HALF*(EBEAM1*EBEAM2+PBEAM1*PBEAM2))
+ ETLIM=TWO*PTLIM
+ IF (VPCUT.GT.ETLIM) VPCUT=ETLIM
+ IF (Q2MAX.GT.ETLIM**2) Q2MAX=ETLIM**2
+C---PRINT OUT MOST IMPORTANT INPUT PARAMETERS
+ IF (IPRINT.EQ.0) GOTO 50
+ WRITE (6,10) PART1,PBEAM1,PART2,PBEAM2,IPROC,NFLAV,NSTRU,
+ & AZSPIN,AZSOFT,QCDLAM,(RMASS(I),I=1,6),RMASS(13)
+ IF (ISPAC.LE.1) THEN
+ WRITE (6,20) VQCUT,VGCUT,VPCUT,CLMAX,QSPAC,PTRMS
+ ELSE
+ WRITE (6,30) VQCUT,VGCUT,VPCUT,CLMAX,QSPAC,PTRMS
+ ENDIF
+ IF (NOSPAC) WRITE (6,40)
+ 10 FORMAT(/10X,'INPUT CONDITIONS FOR THIS RUN'//
+ & 10X,'BEAM 1 (',A8,') MOM. =',F10.2/
+ & 10X,'BEAM 2 (',A8,') MOM. =',F10.2/
+ & 10X,'PROCESS CODE (IPROC) =',I8/
+ & 10X,'NUMBER OF FLAVOURS =',I5/
+ & 10X,'STRUCTURE FUNCTION SET =',I5/
+ & 10X,'AZIM SPIN CORRELATIONS =',L5/
+ & 10X,'AZIM SOFT CORRELATIONS =',L5/
+ & 10X,'QCD LAMBDA (GEV) =',F10.4/
+ & 10X,'DOWN QUARK MASS =',F10.4/
+ & 10X,'UP QUARK MASS =',F10.4/
+ & 10X,'STRANGE QUARK MASS =',F10.4/
+ & 10X,'CHARMED QUARK MASS =',F10.4/
+ & 10X,'BOTTOM QUARK MASS =',F10.4/
+ & 10X,'TOP QUARK MASS =',F10.4/
+ & 10X,'GLUON EFFECTIVE MASS =',F10.4)
+ 20 FORMAT(10X,'EXTRA SHOWER CUTOFF (Q)=',F10.4/
+ & 10X,'EXTRA SHOWER CUTOFF (G)=',F10.4/
+ & 10X,'PHOTON SHOWER CUTOFF =',F10.4/
+ & 10X,'CLUSTER MASS PARAMETER =',F10.4/
+ & 10X,'SPACELIKE EVOLN CUTOFF =',F10.4/
+ & 10X,'INTRINSIC P-TRAN (RMS) =',F10.4)
+ 30 FORMAT(10X,'EXTRA SHOWER CUTOFF (Q)=',F10.4/
+ & 10X,'EXTRA SHOWER CUTOFF (G)=',F10.4/
+ & 10X,'PHOTON SHOWER CUTOFF =',F10.4/
+ & 10X,'CLUSTER MASS PARAMETER =',F10.4/
+ & 10X,'PDF FREEZING CUTOFF =',F10.4/
+ & 10X,'INTRINSIC P-TRAN (RMS) =',F10.4)
+ 40 FORMAT(10X,'NO SPACE-LIKE SHOWERS')
+ 50 ISTOP=0
+C---INITIALIZE ALPHA-STRONG
+ IF (QLIM.GT.ETLIM) QLIM=ETLIM
+ QR=HWUALF(0,QLIM)
+C---DO SOME SAFETY CHECKS ON INPUT PARAMETERS
+C Check beam order for point-like photon/QCD processes
+ IF (IPRO.GE.50.AND.IPRO.LE.59.AND.
+ & IDB.NE.22.AND.ABS(IDB).NE.11.AND.ABS(IDB).NE.13) THEN
+ WRITE(6,60)
+ 60 FORMAT(1X,'WARNING: require FIRST beam to be a photon/lepton')
+ ISTOP=ISTOP+1
+ ENDIF
+ QG=HWBVMC(13)
+ QR=QG/QCDL3
+ IF (QR.GE.2.01) GOTO 80
+ WRITE (6,70) QG,QCDLAM,QCDL3
+ 70 FORMAT(//10X,'SHOWER GLUON VIRTUAL MASS CUTOFF =',F8.5/
+ & 10X,'TOO SMALL RELATIVE TO QCD LAMBDA =',F8.5/
+ & 10X,'CORRESPONDS TO 3-FLAV MC LAMBDA =',F8.5)
+ ISTOP=ISTOP+1
+ 80 QV=MIN(HWBVMC(1),HWBVMC(2))
+ IF (QV.GE.QG/(QR-1.)) GOTO 100
+ ISTOP=ISTOP+1
+ WRITE (6,90) QV,QCDLAM,QCDL3
+ 90 FORMAT(//10X,'SHOWER QUARK VIRTUAL MASS CUTOFF =',F8.5/
+ & 10X,'TOO SMALL RELATIVE TO QCD LAMBDA =',F8.5/
+ & 10X,'CORRESPONDS TO 3-FLAV MC LAMBDA =',F8.5)
+ 100 IF (ISTOP.NE.0) THEN
+ WRITE (6,110) ISTOP
+ 110 FORMAT(//10X,'EXECUTION PREVENTED BY',I2,
+ & ' ERRORS IN INPUT PARAMETERS.')
+ STOP
+ ENDIF
+ DO 120 I=1,6
+ 120 RMASS(I+6)=RMASS(I)
+ RMASS(199)=RMASS(198)
+C---A PRIORI WEIGHTS FOR QUARK AND DIQUARKS
+ DQKWT=PWT(1)
+ UQKWT=PWT(2)
+ SQKWT=PWT(3)
+ DIQWT=PWT(7)
+ PWT(10)=PWT(4)
+ PWT(11)=PWT(5)
+ PWT(12)=PWT(6)
+C
+ PWT(4)=UQKWT*UQKWT*DIQWT
+ PWT(5)=UQKWT*DQKWT*DIQWT*HALF
+ PWT(6)=DQKWT*DQKWT*DIQWT
+ PWT(7)=UQKWT*SQKWT*DIQWT*HALF
+ PWT(8)=DQKWT*SQKWT*DIQWT*HALF
+ PWT(9)=SQKWT*SQKWT*DIQWT
+ QMAX=MAX(PWT(1),PWT(2),PWT(3))
+ PMAX=MAX(PWT(4),PWT(5),PWT(6),PWT(7),PWT(8),PWT(9),
+ & PWT(10),PWT(11),PWT(12),QMAX)
+ PMAX=1./PMAX
+ QMAX=1./QMAX
+ DO 130 I=1,3
+ 130 QWT(I)=PWT(I)*QMAX
+ DO 140 I=1,12
+ 140 PWT(I)=PWT(I)*PMAX
+C MASSES OF DIQUARKS (ASSUME BINDING NEGLIGIBLE)
+ RMASS(109)=RMASS(2)+RMASS(2)
+ RMASS(110)=RMASS(1)+RMASS(2)
+ RMASS(111)=RMASS(1)+RMASS(1)
+ RMASS(112)=RMASS(2)+RMASS(3)
+ RMASS(113)=RMASS(1)+RMASS(3)
+ RMASS(114)=RMASS(3)+RMASS(3)
+ DO 150 I=109,114
+ 150 RMASS(I+6)=RMASS(I)
+C MASSES OF TOP HADRONS (ASSUME BINDING NEGLIGIBLE)
+ RMASS(232)=RMASS(6)+RMASS(5)
+ RMASS(233)=RMASS(6)+RMASS(1)
+ RMASS(234)=RMASS(6)+RMASS(2)
+ RMASS(235)=RMASS(6)+RMASS(3)
+ RMASS(236)=RMASS(6)+RMASS(2)+RMASS(2)
+ RMASS(237)=RMASS(6)+RMASS(1)+RMASS(2)
+ RMASS(238)=RMASS(6)+RMASS(1)+RMASS(1)
+ RMASS(239)=RMASS(6)+RMASS(2)+RMASS(3)
+ RMASS(240)=RMASS(6)+RMASS(1)+RMASS(3)
+ RMASS(241)=RMASS(6)+RMASS(3)+RMASS(3)
+ RMASS(242)=RMASS(6)+RMASS(4)
+ RMASS(243)=RMASS(6)+RMASS(5)
+ RMASS(244)=RMASS(6)+RMASS(6)
+ RMASS(232)=RMASS(243)
+ DO 160 I=233,242
+ 160 RMASS(I+22)=RMASS(I)
+C Set up an array of cluster mass threholds
+ CLMXPW=CLMAX**CLPOW
+ RCLPOW=ONE/CLPOW
+ CALL HWVZRO(144,CTHRPW(1,1))
+ DO 170 I=1,6
+ DO 170 J=1,6
+ CTHRPW(I ,J )=(CLMXPW+(RMASS(I )+RMASS(J+6 ))**CLPOW)**RCLPOW
+ CTHRPW(I ,J+6)=(CLMXPW+(RMASS(I )+RMASS(J+108))**CLPOW)**RCLPOW
+ 170 CTHRPW(I+6,J )=(CLMXPW+(RMASS(I+114)+RMASS(J+6 ))**CLPOW)**RCLPOW
+C Decay length conversion factor GEV2MM hbar.c/e
+ GEV2MM=1.D-15*SQRT(GEV2NB/10.)
+C Plank's constant/2pi (GeV.s)
+ HBAR=GEV2MM/CSPEED
+C---IMPORTANCE SAMPLING
+ FIRST=.TRUE.
+ IF (IPRO.EQ.5) THEN
+ IF (EMMAX.GT.ETLIM) EMMAX=ETLIM
+ IF (PTMAX.GT.PTLIM) PTMAX=PTLIM
+ ELSEIF (IPRO.EQ.13) THEN
+ IF (EMMIN.EQ.ZERO) EMMIN=10
+ IF (EMMAX.GT.ETLIM) EMMAX=ETLIM
+ IF (IQK.GT.0.AND.IQK.LE.6) EMMIN=MAX(EMMIN,2*RMASS(IQK))
+ XMIN=EMMIN
+ XMAX=EMMAX
+ XPOW=-EMPOW
+ ELSEIF (IPRO.EQ.15.OR.IPRO.EQ.17.OR.IPRO.EQ.18.OR.IPRO.EQ.21
+ & .OR.IPRO.EQ.22.OR.IPRO.EQ.23.OR.IPRO.EQ.24.OR.IPRO.EQ.50
+ & .OR.IPRO.EQ.51.OR.IPRO.EQ.53.OR.IPRO.EQ.55.OR.IPRO.EQ.60) THEN
+ IF (PTMAX.GT.PTLIM) PTMAX=PTLIM
+ IF (IQK.NE.0.AND.IQK.LT.7.AND.IPRO.NE.23) THEN
+ XMIN=2.*SQRT(PTMIN**2+RMASS(IQK)**2)
+ XMAX=2.*SQRT(PTMAX**2+RMASS(IQK)**2)
+ IF (XMAX.GT.ETLIM) XMAX=ETLIM
+ ELSE
+ XMIN=2.*PTMIN
+ XMAX=2.*PTMAX
+ ENDIF
+ XPOW=-PTPOW
+ ELSEIF (IPRO.EQ.52) THEN
+ PTELM=PTLIM-RMASS(IQK)**2/(4.*PTLIM)
+ IF (PTMAX.GT.PTELM) PTMAX=PTELM
+ XMIN=PTMIN
+ XMAX=PTMAX
+ XPOW=-PTPOW
+ ELSEIF (IPRO.EQ.30) THEN
+C---CHECK THAT SUSY DATA HAVE BEEN INPUT
+ IF (.NOT.SUSYIN) CALL HWWARN('HWUINC',600,*999)
+ IF (PTMAX.GT.PTLIM) PTMAX=PTLIM
+ XMIN=2.*SQRT(PTMIN**2+RMMNSS**2)
+ XMAX=2.*SQRT(PTMAX**2+RMMNSS**2)
+ IF (XMAX.GT.ETLIM) XMAX=ETLIM
+ XPOW=-PTPOW
+C--PR MOD 7/7/99
+ ELSEIF(IPRO.EQ.40.OR.IPRO.EQ.41) THEN
+ IF (.NOT.SUSYIN) CALL HWWARN('HWUINC',600,*999)
+ IF (PTMAX.GT.PTLIM) PTMAX=PTLIM
+ ID = IPROC-100*IPRO
+ RPM(1) = RMMNSS
+ RPM(2) = ZERO
+ IF(ID.GE.10.AND.ID.LT.20) THEN
+ RPM(1) = ABS(RMASS(450))
+ IF(ID.GT.10) RPM(1) = ABS(RMASS(449+MOD(ID,10)))
+ ELSEIF(ID.GE.20.AND.ID.LT.30) THEN
+ RPM(1) = ABS(RMASS(454))
+ IF(ID.GT.20) RPM(1) = ABS(RMASS(453+MOD(ID,20)))
+ ELSEIF(ID.EQ.30) THEN
+ RPM(1) = RMASS(449)
+ ELSEIF(ID.EQ.40) THEN
+ IF(IPRO.EQ.40) THEN
+ RPM(1) = RMASS(425)
+ DO I=1,5
+ RPM(1) = MIN(RPM(1),RMASS(425+I))
+ ENDDO
+ ELSE
+ RPM(1) = MIN(RMASS(405),RMASS(406))
+ ENDIF
+ RPM(2) = RMASS(198)
+ ELSEIF(ID.EQ.50) THEN
+ IF(IPRO.EQ.40) THEN
+ RPM(1) = RMASS(425)
+ DO I=1,5
+ RPM(1) = MIN(RPM(1),RMASS(425+I))
+ ENDDO
+ DO I=1,3
+ RPM(2) = MIN(RPM(1),RMASS(433+2*I))
+ ENDDO
+ RPM(1) = MIN(RPM(1),RPM(2))
+ RPM(2) = RMASS(203)
+ DO I=1,2
+ RPM(2) = MIN(RPM(2),RMASS(204+I))
+ ENDDO
+ ELSE
+ RPM(1) = RMASS(401)
+ RPM(2) = RMASS(413)
+ DO I=1,5
+ RPM(1) = MIN(RPM(1),RMASS(401+I))
+ RPM(2) = MIN(RPM(2),RMASS(413+I))
+ ENDDO
+ RPM(1) = MIN(RPM(1),RPM(2))
+ RPM(2) = RMASS(203)
+ DO I=1,2
+ RPM(2) = MIN(RPM(2),RMASS(204+I))
+ ENDDO
+ ENDIF
+ RPM(2) = RMASS(203)
+ DO I=1,2
+ RPM(2) = MIN(RPM(2),RMASS(204+I))
+ ENDDO
+ ELSEIF(ID.GE.60) THEN
+ RPM(1) = ZERO
+ ENDIF
+ RPM(1) = RPM(1)**2
+ RPM(2) = RPM(2)**2
+ XMIN = SQRT(RPM(1)+RPM(2)+TWO*(PTMIN**2+
+ & SQRT(RPM(1)*RPM(2)+PTMIN**2*(RPM(1)+RPM(2)+PTMIN**2))))
+ XMAX = SQRT(RPM(1)+RPM(2)+TWO*(PTMAX**2+
+ & SQRT(RPM(1)*RPM(2)+PTMAX**2*(RPM(1)+RPM(2)+PTMAX**2))))
+ IF (XMAX.GT.ETLIM) XMAX=ETLIM
+C--end of mod
+ ELSEIF (IPRO.EQ.90) THEN
+ XMIN=SQRT(Q2MIN)
+ XMAX=SQRT(Q2MAX)
+ XPOW=1.-2.*Q2POW
+ ELSEIF (IPRO.EQ.91) THEN
+ IF (EMMAX.GT.ETLIM) EMMAX=ETLIM
+ ENDIF
+C---CALCULATE HIGGS WIDTH
+ IF (IPRO.EQ. 3.OR.IPRO.EQ. 4.OR.IPRO.EQ.16.OR.IPRO.EQ.19
+ &.OR.IPRO.EQ.23.OR.IPRO.EQ.95) THEN
+ GAMH=RMASS(201)
+ CALL HWDHIG(GAMH)
+ ENDIF
+C---IF Q**2 CAN BE TOO SMALL, BREIT FRAME MAKES NO SENSE
+ IF ((IPRO/10.EQ.9.AND.Q2MIN.LE.1.D-2).OR.
+ & (IPRO.EQ.91.AND.IQK.EQ.7)) BREIT=.FALSE.
+ IF (IPRINT.NE.0) THEN
+ IF (PBEAM1.NE.PBEAM2) WRITE (6,180) USECMF
+ IF (IPRO.EQ.91.OR.IPRO.EQ.92)
+ & WRITE (6,190) PTMIN
+ IF (IPRO.EQ.90.OR.(IPRO.EQ.91.AND.IQK.NE.7).OR.IPRO.EQ.92)
+ & WRITE (6,200) Q2MIN,Q2MAX,BREIT
+ IF (IPRO.EQ.90.OR.(IPRO.EQ.91.AND.IQK.NE.7).OR.IPRO.EQ.92)
+ & WRITE (6,210) YBMIN,YBMAX
+ IF (IPRO.EQ.91.AND.IQK.EQ.7)
+ & WRITE (6,220) Q2WWMN,Q2WWMX,BREIT,ZJMAX
+ IF (IPROC/10.EQ.11) WRITE (6,230) THMAX
+ IF (IPRO.EQ.13) WRITE (6,240) EMMIN,EMMAX
+ IF (IPRO.EQ.15.OR.IPRO.EQ.17.OR.IPRO.EQ.18.OR.IPRO.EQ.21
+ & .OR.IPRO.EQ.22.OR.IPRO.EQ.23.OR.IPRO.EQ.24.OR.IPRO.EQ.50
+ & .OR.IPRO.EQ.51.OR.IPRO.EQ.52.OR.IPRO.EQ.53.OR.IPRO.EQ.55
+ & .OR.IPRO.EQ.60)
+ & WRITE (6,250) PTMIN,PTMAX
+ IF (IPRO.EQ. 3.OR.IPRO.EQ. 4.OR.IPRO.EQ.16.OR.IPRO.EQ.19
+ & .OR.IPRO.EQ.23.OR.IPRO.EQ.95)
+ & WRITE (6,260) RMASS(201),GAMH,
+ & GAMMAX,RMASS(201)+GAMMAX*GAMH,(BRHIG(I)*100,I=1,12)
+ IF (IPRO.EQ.91) WRITE (6,270) BGSHAT,EMMIN,EMMAX
+ IF (IPRO.EQ.5.AND.IQK.LT.50)
+ & WRITE (6,280) EMMIN,EMMAX,PTMIN,PTMAX,CTMAX
+ IF (IPRO.EQ.5.AND.IQK.GE.50)
+ & WRITE (6,290) EMMIN,EMMAX,Q2MIN,Q2MAX,PTMIN
+ IF (IPRO.GT.10.AND.
+ & (IPRO.LT.90.AND.(ABS(IDB).EQ.11.OR.ABS(IDB).EQ.13).OR.
+ & (ABS(IDT).EQ.11.OR.ABS(IDT).EQ.13))) THEN
+ WRITE (6,300) Q2WWMN,Q2WWMX,YWWMIN,YWWMAX
+ IF (PHOMAS.GT.ZERO) WRITE (6,310) PHOMAS
+ ENDIF
+ IF (IPROC/10.EQ.10.OR.IPRO.EQ.90)
+ & WRITE (6,320) HARDME,SOFTME
+C Check minimum mass threshold if ISR switched on
+ IF ((IPRO.LE.3.OR.IPRO.EQ.6).AND.ZMXISR.GT.ZERO) THEN
+ TEST=TWO*RMASS(IPART1)**2+ETLIM**2
+ TEST=FOUR*RMASS(2)**2/TEST
+ IF (TMNISR.LT.TEST) THEN
+ WRITE(6,175) TMNISR,TEST
+ 175 FORMAT(10X,'Minimum invariant mass',F10.6,' too low'/
+ & 10X,'increasing to TMNISR=',F10.6)
+ TMNISR=TEST
+ ENDIF
+ WRITE (6,330) TMNISR,ONE-ZMXISR
+ ENDIF
+ IF (WHMIN.GT.ZERO .AND. IPRO.GT.10.AND.(IPRO.EQ.90.OR.
+ & (ABS(IDB).EQ.11.OR.ABS(IDB).EQ.13).OR.
+ & (ABS(IDT).EQ.11.OR.ABS(IDT).EQ.13))) WRITE (6,340) WHMIN
+ 180 FORMAT(10X,'USE BEAM-TARGET C.M.F. =',L5)
+ 190 FORMAT(10X,'MIN P-T FOR O(AS) DILS =',F10.4)
+ 200 FORMAT(10X,'MIN ABS(Q**2) FOR DILS =',E10.4/
+ & 10X,'MAX ABS(Q**2) FOR DILS =',E10.4/
+ & 10X,'BREIT FRAME SHOWERING =',L5)
+ 210 FORMAT(10X,'MIN BJORKEN Y FOR DILS =',F10.4/
+ & 10X,'MAX BJORKEN Y FOR DILS =',F10.4)
+ 220 FORMAT(10X,'MIN ABS(Q**2) FOR J/PSI=',E10.4/
+ & 10X,'MAX ABS(Q**2) FOR J/PSI=',E10.4/
+ & 10X,'BREIT FRAME SHOWERING =',L5/
+ & 10X,'MAX Z FOR J/PSI =',F10.4)
+ 230 FORMAT(10X,'MAX THRUST FOR 2->3 =',F10.4)
+ 240 FORMAT(10X,'MIN MASS FOR DRELL-YAN =',F10.4/
+ & 10X,'MAX MASS FOR DRELL-YAN =',F10.4)
+ 250 FORMAT(10X,'MIN P-TRAN FOR 2->2 =',F10.4/
+ & 10X,'MAX P-TRAN FOR 2->2 =',F10.4)
+ 260 FORMAT(10X,'HIGGS BOSON MASS =',F10.4/
+ & 10X,'HIGGS BOSON WIDTH =',F10.4/
+ & 10X,'CUTOFF = EMH +',F4.1,'*GAMH=',F10.4/
+ & 10X,'HIGGS D DBAR =',F10.4/
+ & 10X,'BRANCHING U UBAR =',F10.4/
+ & 10X,'FRACTIONS S SBAR =',F10.4/
+ & 10X,'(PER CENT) C CBAR =',F10.4/
+ & 10X,' B BBAR =',F10.4/
+ & 10X,' T TBAR =',F10.4/
+ & 10X,' E+ E- =',F10.4/
+ & 10X,' MU+ MU- =',F10.4/
+ & 10X,' TAU+ TAU- =',F10.4/
+ & 10X,' W W =',F10.4/
+ & 10X,' Z Z =',F10.4/
+ & 10X,' GAMMA GAMMA =',F10.4)
+ 270 FORMAT(10X,'SCALE FOR BGF IS S-HAT =',L5/
+ & 10X,'MIN MASS FOR BGF =',F10.4/
+ & 10X,'MAX MASS FOR BGF =',F10.4)
+ 280 FORMAT(10X,'MIN MASS FOR 2 PHOTONS =',F10.4/
+ & 10X,'MAX MASS FOR 2 PHOTONS =',F10.4/
+ & 10X,'MIN PT OF 2 PHOTON CMF =',F10.4/
+ & 10X,'MAX PT OF 2 PHOTON CMF =',F10.4/
+ & 10X,'MAX COS THETA IN CMF =',F10.4)
+ 290 FORMAT(10X,'MIN MASS FOR GAMMA + W =',F10.4/
+ & 10X,'MAX MASS FOR GAMMA + W =',F10.4/
+ & 10X,'MIN ABS(Q**2) =',E10.4/
+ & 10X,'MAX ABS(Q**2) =',E10.4/
+ & 10X,'MIN PT =',F10.4)
+ 300 FORMAT(10X,'MIN Q**2 FOR WW PHOTON =',F10.4/
+ & 10X,'MAX Q**2 FOR WW PHOTON =',F10.4/
+ & 10X,'MIN MOMENTUM FRACTION =',F10.4/
+ & 10X,'MAX MOMENTUM FRACTION =',F10.4)
+ 310 FORMAT(10X,'GAMMA* S.F. MASS PARAM =',F10.4)
+ 320 FORMAT(10X,'HARD M.E. MATCHING =',L5/
+ & 10X,'SOFT M.E. MATCHING =',L5)
+ 330 FORMAT(10X,'MIN MTM FRAC FOR ISR =',1PE10.4/
+ & 10X,'1-MAX MTM FRAC FOR ISR =',1PE10.4)
+ 340 FORMAT(10X,'MINIMUM HADRONIC MASS =',F10.4)
+ IF (LWEVT.LE.0) THEN
+ WRITE (6,350)
+ ELSE
+ WRITE (6,360) LWEVT
+ ENDIF
+ 350 FORMAT(/10X,'NO EVENTS WILL BE WRITTEN TO DISK')
+ 360 FORMAT(/10X,'EVENTS WILL BE OUTPUT ON UNIT',I4)
+ ENDIF
+C Verify and print beam polarisations
+ IF (IPRO.EQ.1.OR.IPRO.EQ.3) THEN
+C Set up transverse polarisation parameters for e+e-
+ IF ((EPOLN(1)**2+EPOLN(2)**2)
+ & *(PPOLN(1)**2+PPOLN(2)**2).GT.ZERO) THEN
+ TPOL=.TRUE.
+ COSS=EPOLN(1)*PPOLN(1)-EPOLN(2)*PPOLN(2)
+ SINS=EPOLN(2)*PPOLN(1)+EPOLN(1)*PPOLN(2)
+ ELSE
+ TPOL=.FALSE.
+ ENDIF
+C print out lepton beam polarisation(s)
+ IF (IPRINT.NE.0) THEN
+ IF (IPART1.EQ.121) THEN
+ WRITE (6,370) PART1,EPOLN,PART2,PPOLN
+ ELSE
+ WRITE (6,370) PART1,PPOLN,PART2,EPOLN
+ ENDIF
+ 370 FORMAT(/10X,A8,'Beam polarisation=',3F10.4/
+ & 10X,A8,'Beam polarisation=',3F10.4)
+ ENDIF
+ ELSEIF (IPRO.GE.90.AND.IPRO.LE.99) THEN
+ IF (IDB.GE.11.AND.IDB.LE.16) THEN
+ CALL HWVZRO(3,PPOLN)
+C Check neutrino polarisations for DIS
+ IF (IDB.EQ. 12.OR.IDB.EQ. 14.OR.IDB.EQ. 16.AND.
+ & EPOLN(3).NE.-ONE) EPOLN(3)=-ONE
+ IF (IPRINT.NE.0) WRITE(6,380) PART1,EPOLN(3)
+ ELSE
+ CALL HWVZRO(3,EPOLN)
+C Check anti-neutrino polarisations for DIS
+ IF (IDB.EQ.-12.OR.IDB.EQ.-14.OR.IDB.EQ.-16.AND.
+ & PPOLN(3).NE.ONE) PPOLN(3)=ONE
+ IF (IPRINT.NE.0) WRITE(6,380) PART1,PPOLN(3)
+ ENDIF
+ 380 FORMAT(/10X,A8,1X,'Longitudinal beam polarisation=',F10.4/)
+ ENDIF
+ IF (IPRINT.NE.0) THEN
+ IF (ZPRIME) THEN
+ WRITE(6,390) RMASS(200),RMASS(202),GAMZ,GAMZP
+ WRITE(6,400) (RNAME(I),VFCH(I,1),AFCH(I,1),VFCH(I,2),
+ & AFCH(I,2),I=1,6)
+ WRITE(6,400) (RNAME(110+I),VFCH(I,1),AFCH(I,1),
+ & VFCH(I,2),AFCH(I,2),I=11,16)
+ 390 FORMAT(/10X,'MASSIVE NEUTRAL VECTOR BOSON PARAMS'/
+ & 10X,'Z MASS=',F10.4,7X,'Z-PRIME MASS=',F10.4/
+ & 10X,' WIDTH=',F10.4,7X,' WIDTH=',F10.4/
+ & 10X,'FERMION COUPLINGS: e.(V.1+A.G_5)G_mu'/
+ & 10X,'FERMION: VECTOR AXIAL',6X,
+ & 'VECTOR AXIAL'/)
+ 400 FORMAT(10X,A8,2X,F10.4,1X,F10.4,1X,F10.4,1X,F10.4)
+ ENDIF
+ IF (MIXING) THEN
+ WRITE(6,410) XMIX(2),YMIX(2),XMIX(1),YMIX(1)
+ 410 FORMAT(/10X,'B_d: Delt-M/Gam =',F6.4,
+ & ' Delt-Gam/2*Gam =',F6.4,/
+ & 10X,'B_s: Delt-M/Gam =',F6.2,
+ & ' Delt-Gam/2*Gam =',F6.4)
+ ENDIF
+ IF (CLRECO) WRITE(6,420) PRECO,EXAG
+ 420 FORMAT(/10X,'Colour rearrangement ALLOWED, probability =',F6.4,/
+ & 10x,'Weak boson life-time exaggeration factor =',F10.6)
+C---PDF STRUCTURE FUNCTIONS
+ WRITE (6,'(X)')
+ DO 450 I=1,2
+ IF (MODPDF(I).GE.0) THEN
+ WRITE (6,430) I,MODPDF(I),AUTPDF(I)
+ ELSE
+ WRITE (6,440) I
+ ENDIF
+ 430 FORMAT(10X,'PDFLIB USED FOR BEAM',I2,': SET',I3,' OF ',A20)
+ 440 FORMAT(10X,'PDFLIB NOT USED FOR BEAM',I2)
+ 450 CONTINUE
+C---GET THE UGLY INITIALISATION MESSAGES OVER AND DONE WITH NOW TOO
+ DO 460 I=1,2
+ IF (MODPDF(I).GE.0) THEN
+ PARM(1)=AUTPDF(I)
+ VAL(1)=MODPDF(I)
+ FSTPDF=.TRUE.
+ X=0.5
+ QSCA=10
+C---FIX TO CALL SCHULER-SJOSTRAND CODE
+ IF (AUTPDF(I).EQ.'SaSph') THEN
+ ISET=MOD(MODPDF(I),10)
+ IOP1=MOD(MODPDF(I)/10,2)
+ IOP2=MOD(MODPDF(I)/20,2)
+ IP2=MODPDF(I)/100
+ IF (ISET.EQ.1) THEN
+ WRITE (6,'(10X,A)')'SCHULER-SJOSTRAND PHOTON PDF SET 1D'
+ ELSEIF (ISET.EQ.2) THEN
+ WRITE (6,'(10X,A)')'SCHULER-SJOSTRAND PHOTON PDF SET 1M'
+ ELSEIF (ISET.EQ.3) THEN
+ WRITE (6,'(10X,A)')'SCHULER-SJOSTRAND PHOTON PDF SET 2D'
+ ELSEIF (ISET.EQ.4) THEN
+ WRITE (6,'(10X,A)')'SCHULER-SJOSTRAND PHOTON PDF SET 2M'
+ ELSE
+ WRITE (6,'(10X,A)')'UNKNOWN SCHULER-SJOSTRAND PDF SET'
+ CALL HWWARN('HWUINC',500,*999)
+ ENDIF
+ IF (IOP1.EQ.1) THEN
+ WRITE (6,'(10X,A)') 'WITH DIRECT COMPONENT IN DIS'
+ IF (IPRO.NE.90) WRITE (6,'(10X,A)')
+ $ 'NOT RECOMMENDED FOR NON-DIS PROCESSES'
+ ENDIF
+ IF (IOP2.EQ.1) THEN
+ WRITE (6,'(10X,A)') 'WITH P**2 DEPENDENCE INCLUDED'
+ IF (PHOMAS.GT.ZERO)
+ $ WRITE (6,'(10X,A)') 'NOT RECOMMENDED WITH PHOMAS.GT.0'
+ IF (IP2.GT.0)
+ $ WRITE (6,'(10X,A,I2)') 'WITH IP2 OPTION EQUAL TO',IP2
+ ENDIF
+ ELSEIF (AUTPDF(I).EQ.'SSph') THEN
+ WRITE (6,'(10X,A)') 'THE ACRONYM FOR SCHULER-SJOSTRAND'
+ WRITE (6,'(10X,A)') 'HAS CHANGED TO SaSph ACCORDING TO'
+ WRITE (6,'(10X,A)') 'THEIR WISHES. SSph NO LONGER WORKS'
+ STOP
+ ELSE
+ CALL PDFSET(PARM,VAL)
+ CALL STRUCTM(X,QSCA,UPV,DNV,USEA,DSEA,STR,CHM,BTM,TOP,GLU)
+ ENDIF
+ ENDIF
+ 460 CONTINUE
+ WRITE (6,'(X)')
+ ENDIF
+C Set up neutral B meson mixing parameters
+ IF (MIXING.AND..NOT.(RSTAB(223).AND.RSTAB(247))) THEN
+ XMRCT(1)=XMIX(1)*RMASS(223)/(CSPEED*RLTIM(223))
+ YMRCT(1)=YMIX(1)*RMASS(223)/(CSPEED*RLTIM(223))
+ ENDIF
+ IF (MIXING.AND..NOT.(RSTAB(221).AND.RSTAB(245))) THEN
+ XMRCT(2)=XMIX(2)*RMASS(221)/(CSPEED*RLTIM(221))
+ YMRCT(2)=YMIX(2)*RMASS(221)/(CSPEED*RLTIM(221))
+ ENDIF
+C---B DECAY PACKAGE
+ IF (BDECAY.EQ.'EURO') THEN
+ IF (IPRINT.NE.0) WRITE (6,470) 'EURODEC'
+ ELSEIF (BDECAY.EQ.'CLEO') THEN
+ IF (IPRINT.NE.0) WRITE (6,470) 'CLEO'
+ ELSE
+ BDECAY='HERW'
+ ENDIF
+ 470 FORMAT (10X,A,' B DECAY PACKAGE WILL BE USED')
+C---COMPUTE PARTICLE PROPERTIES FOR HADRONIZATION
+ CALL HWURES
+C Prepare internal decay tables and do diagnostic checks
+ CALL HWUDKS
+C Convert ampersands to backslahes in particle LaTeX names
+ CALL HWUATS
+C Print particle decay tables here
+ IF (IPRINT.GE.2) CALL HWUDPR
+C---MISCELLANEOUS DERIVED QUANTITIES
+ TMTOP=2.*LOG(RMASS(6)/30.)
+ PXRMS=PTRMS/SQRT(2.)
+ ZBINM=0.25/ZBINM
+ PSPLT(1)=1./PSPLT(1)
+ PSPLT(2)=1./PSPLT(2)
+ NDTRY=2*NCTRY
+ NGSPL=0
+ PGSMX=0.
+ DO 480 I=1,4
+ PGS=HWUPCM(RMASS(13),RMASS(I),RMASS(I))
+ IF (PGS.GE.ZERO) NGSPL=I
+ IF (PGS.GE.PGSMX) PGSMX=PGS
+ 480 PGSPL(I)=PGS
+ CALL HWVZRO(6,PTINT)
+ IF (IPRO.NE.80) THEN
+C---SET UP TABLES OF SUDAKOV FORM FACTORS, GIVING
+C PROBABILITY DISTRIBUTION IN VARIABLE Q = E*SQRT(XI)
+ NSUD=NFLAV
+ CALL HWBSUD
+C---SET PARAMETERS FOR SPACELIKE BRANCHING
+ DO 500 I=1,NSUD
+ DO 490 J=2,NQEV
+ IF (QEV(J,I).GT.QSPAC) GOTO 500
+ 490 CONTINUE
+ 500 NSPAC(I)=J-1
+ ENDIF
+ EVWGT=AVWGT
+ ISTAT=1
+ 999 END
+CDECK ID>, HWUINE.
+*CMZ :- -16/10/93 12.42.15 by Mike Seymour
+*-- Author : Bryan Webber
+C-----------------------------------------------------------------------
+ SUBROUTINE HWUINE
+C-----------------------------------------------------------------------
+C INITIALISES AN EVENT
+C-----------------------------------------------------------------------
+ INCLUDE 'HERWIG61.INC'
+ DOUBLE PRECISION HWR,HWRGET,DUMMY
+ REAL TL
+ LOGICAL CALLED
+ EXTERNAL HWR,HWRGET
+ COMMON/HWDBUG/CALLED
+C---CHECK THAT MAIN PROGRAM HAS BEEN MODIFIED CORRECTLY
+ IF (NEVHEP.GT.0.AND..NOT.CALLED) THEN
+ WRITE (6,10)
+ 10 FORMAT (1X,'A call to the subroutine HWUFNE should be added to',
+ & /,' the main program, immediately after the call to HWMEVT')
+ CALL HWWARN('HWUINE',500,*999)
+ ENDIF
+ CALLED=.FALSE.
+C---CHECK TIME LEFT
+c-jgc CALL HWUTIM(TL)
+c-jgc IF (TL.LT.TLOUT) CALL HWWARN('HWUINE',200,*999)
+C---UPDATE RANDOM NUMBER SEED
+ DUMMY = HWRGET(NRN)
+ NEVHEP=NEVHEP+1
+ NHEP=0
+ ISTAT=6
+ IERROR=0
+ EVWGT=AVWGT
+ HVFCEN=.FALSE.
+ ISLENT=1
+ NQDK=0
+C---DECIDE WHETHER TO GENERATE SOFT UNDERLYING EVENT
+ GENSOF=IPROC.GT.1000.AND.IPROC.LT.10000.AND.
+ & (IPROC.EQ.8000.OR.HWR().LT.PRSOF)
+C Zero arrays
+ CALL HWVZRI(2*NMXHEP,JMOHEP)
+ CALL HWVZRI(2*NMXHEP,JDAHEP)
+ CALL HWVZRO(4*NMXHEP,VHEP)
+ CALL HWVZRO(3*NMXHEP,RHOHEP)
+ EMSCA=ZERO
+ 999 END
+CDECK ID>, HWULB4.
+*CMZ :- -05/11/95 19.33.42 by Mike Seymour
+*-- Author : Adapted by Bryan Webber
+C-----------------------------------------------------------------------
+ SUBROUTINE HWULB4(PS,PI,PF)
+C-----------------------------------------------------------------------
+C TRANSFORMS PI (GIVEN IN REST FRAME OF PS) INTO PF (IN LAB)
+C N.B. P(1,2,3,4) = (PX,PY,PZ,E); PS(5)=M
+C-----------------------------------------------------------------------
+ DOUBLE PRECISION PF4,FN,PS(5),PI(4),PF(4)
+ IF (PS(4).EQ.PS(5)) THEN
+ PF(1)= PI(1)
+ PF(2)= PI(2)
+ PF(3)= PI(3)
+ PF(4)= PI(4)
+ ELSE
+ PF4 = (PI(1)*PS(1)+PI(2)*PS(2)
+ & +PI(3)*PS(3)+PI(4)*PS(4))/PS(5)
+ FN = (PF4+PI(4)) / (PS(4)+PS(5))
+ PF(1)= PI(1) + FN*PS(1)
+ PF(2)= PI(2) + FN*PS(2)
+ PF(3)= PI(3) + FN*PS(3)
+ PF(4)= PF4
+ END IF
+ END
+CDECK ID>, HWULDO.
+*CMZ :- -26/04/91 11.11.56 by Bryan Webber
+*-- Author : Bryan Webber
+C----------------------------------------------------------------------
+ FUNCTION HWULDO(P,Q)
+C----------------------------------------------------------------------
+C LORENTZ 4-VECTOR DOT PRODUCT
+C----------------------------------------------------------------------
+ DOUBLE PRECISION HWULDO,P(4),Q(4)
+ HWULDO=P(4)*Q(4)-(P(1)*Q(1)+P(2)*Q(2)+P(3)*Q(3))
+ END
+CDECK ID>, HWULF4.
+*CMZ :- -05/11/95 19.33.42 by Mike Seymour
+*-- Author : Adapted by Bryan Webber
+C-----------------------------------------------------------------------
+ SUBROUTINE HWULF4(PS,PI,PF)
+C-----------------------------------------------------------------------
+C TRANSFORMS PI (GIVEN IN LAB) INTO PF (IN REST FRAME OF PS)
+C N.B. P(1,2,3,4) = (PX,PY,PZ,E); PS(5)=M
+C-----------------------------------------------------------------------
+ DOUBLE PRECISION PF4,FN,PS(5),PI(4),PF(4)
+ IF (PS(4).EQ.PS(5)) THEN
+ PF(1)= PI(1)
+ PF(2)= PI(2)
+ PF(3)= PI(3)
+ PF(4)= PI(4)
+ ELSE
+ PF4 = (PI(4)*PS(4)-PI(3)*PS(3)
+ & -PI(2)*PS(2)-PI(1)*PS(1))/PS(5)
+ FN = (PF4+PI(4)) / (PS(4)+PS(5))
+ PF(1)= PI(1) - FN*PS(1)
+ PF(2)= PI(2) - FN*PS(2)
+ PF(3)= PI(3) - FN*PS(3)
+ PF(4)= PF4
+ END IF
+ END
+CDECK ID>, HWULI2.
+*CMZ :- -23/08/94 13.22.29 by Mike Seymour
+*-- Author : Ulrich Baur & Nigel Glover, adapted by Ian Knowles
+C-----------------------------------------------------------------------
+ FUNCTION HWULI2(X)
+C-----------------------------------------------------------------------
+C Complex dilogarithm function, Li_2 (Spence function)
+C-----------------------------------------------------------------------
+ IMPLICIT NONE
+ DOUBLE COMPLEX HWULI2,PROD,Y,Y2,X,Z
+ DOUBLE PRECISION XR,XI,R2,A1,A2,A3,A4,A5,A6,A7,A8,A9,A10,ZETA2,
+ & ZERO,ONE,HALF
+ PARAMETER (ZERO=0.0D0, ONE=1.0D0, HALF=0.5D0)
+ DATA A1,A2,A3,A4,A5,A6,A7,A8,A9,A10,ZETA2/ -0.250000000000000D0,
+ & -0.111111111111111D0,-0.010000000000000D0,-0.017006802721088D0,
+ & -0.019444444444444D0,-0.020661157024793D0,-0.021417300648069D0,
+ & -0.021948866377231D0,-0.022349233811171D0,-0.022663689135191D0,
+ & 1.644934066848226D0/
+ PROD(Y,Y2)=Y*(ONE+A1*Y*(ONE+A2*Y*(ONE+A3*Y2*(ONE+A4*Y2*(ONE+A5*Y2*
+ & (ONE+A6*Y2*(ONE+A7*Y2*(ONE+A8*Y2*(ONE+A9*Y2*(ONE+A10*Y2))))))))))
+ XR=DBLE(X)
+ XI=IMAG(X)
+ R2=XR*XR+XI*XI
+ IF (R2.GT.ONE.AND.(XR/R2).GT.HALF) THEN
+ Z=-LOG(ONE/X)
+ HWULI2=PROD(Z,Z*Z)+ZETA2-LOG(X)*LOG(ONE-X)+HALF*LOG(X)**2
+ ELSEIF (R2.GT.ONE.AND.(XR/R2).LE.HALF) THEN
+ Z=-LOG(ONE-ONE/X)
+ HWULI2=-PROD(Z,Z*Z)-ZETA2-HALF*LOG(-X)**2
+ ELSEIF (R2.EQ.ONE.AND.XI.EQ.ZERO) THEN
+ HWULI2=ZETA2
+ ELSEIF (R2.LE.ONE.AND.XR.GT.HALF) THEN
+ Z=-LOG(X)
+ HWULI2=-PROD(Z,Z*Z)+ZETA2-LOG(X)*LOG(ONE-X)
+ ELSE
+ Z=-LOG(ONE-X)
+ HWULI2=PROD(Z,Z*Z)
+ ENDIF
+ END
+CDECK ID>, HWULOB.
+*CMZ :- -05/11/95 19.33.42 by Mike Seymour
+*-- Author : Adapted by Bryan Webber
+C-----------------------------------------------------------------------
+ SUBROUTINE HWULOB(PS,PI,PF)
+C-----------------------------------------------------------------------
+C TRANSFORMS PI (GIVEN IN REST FRAME OF PS) INTO PF (IN LAB)
+C N.B. P(1,2,3,4,5) = (PX,PY,PZ,E,M)
+C-----------------------------------------------------------------------
+ DOUBLE PRECISION PS(5),PI(5),PF(5)
+ CALL HWULB4(PS,PI,PF)
+ PF(5)= PI(5)
+ END
+CDECK ID>, HWULOF.
+*CMZ :- -05/11/95 19.33.42 by Mike Seymour
+*-- Author : Adapted by Bryan Webber
+C-----------------------------------------------------------------------
+ SUBROUTINE HWULOF(PS,PI,PF)
+C-----------------------------------------------------------------------
+C TRANSFORMS PI (GIVEN IN LAB) INTO PF (IN REST FRAME OF PS)
+C N.B. P(1,2,3,4,5) = (PX,PY,PZ,E,M)
+C-----------------------------------------------------------------------
+ DOUBLE PRECISION PS(5),PI(5),PF(5)
+ CALL HWULF4(PS,PI,PF)
+ PF(5)= PI(5)
+ END
+CDECK ID>, HWULOR.
+*CMZ :- -26/04/91 11.11.56 by Bryan Webber
+*-- Author : Giovanni Abbiendi & Luca Stanco
+C-----------------------------------------------------------------------
+ SUBROUTINE HWULOR (TRANSF,PI,PF)
+C-----------------------------------------------------------------------
+C Makes the HWULOR transformation specified by TRANSF on the
+C quadrivector PI(5), giving PF(5).
+C-----------------------------------------------------------------------
+ DOUBLE PRECISION TRANSF(4,4),PI(5),PF(5)
+ INTEGER I,J
+ DO 1 I=1,5
+ PF(I)=0.D0
+ 1 CONTINUE
+ DO 3 I=1,4
+ DO 2 J=1,4
+ PF(I) = PF(I) + TRANSF(I,J) * PI(J)
+ 2 CONTINUE
+ 3 CONTINUE
+ PF(5) = PI(5)
+ RETURN
+ END
+CDECK ID>, HWUMAS.
+*CMZ :- -26/04/91 11.11.56 by Bryan Webber
+*-- Author : Bryan Webber
+C-----------------------------------------------------------------------
+ SUBROUTINE HWUMAS(P)
+C-----------------------------------------------------------------------
+C PUTS INVARIANT MASS IN 5TH COMPONENT OF VECTOR
+C (NEGATIVE SIGN IF SPACELIKE)
+C-----------------------------------------------------------------------
+ DOUBLE PRECISION HWUSQR,P(5)
+ EXTERNAL HWUSQR
+ P(5)=HWUSQR((P(4)+P(3))*(P(4)-P(3))-P(1)**2-P(2)**2)
+ END
+CDECK ID>, HWUMBW.
+*CMZ :- -21/02/98 11.11.56 by Bryan Webber
+*-- Author : Bryan Webber
+C-----------------------------------------------------------------------
+ FUNCTION HWUMBW(ID)
+C-----------------------------------------------------------------------
+C CHOOSES MASS ACCORDING TO BREIT-WIGNER DISTRIBUTION
+C-----------------------------------------------------------------------
+ INCLUDE 'HERWIG61.INC'
+ DOUBLE PRECISION HWUMBW,HWR,WMX,TAU,T
+ INTEGER ID
+C--WMX IS MAX NUMBER OF WIDTHS FROM NOMINAL MASS
+ DATA WMX/10D0/
+ SAVE WMX
+ HWUMBW=RMASS(ID)
+ TAU=RLTIM(ID)
+ IF (TAU.EQ.ZERO.OR.TAU.GT.1D-18) RETURN
+ 1 T=HALF*TAN(PIFAC*(HWR()-HALF))
+ IF (ABS(T).GT.WMX) GO TO 1
+ HWUMBW=HWUMBW+HBAR*T/TAU
+ IF(HWUMBW.LT.ZERO) GOTO 1
+ END
+CDECK ID>, HWUNST.
+*CMZ :- -27/07/99 13.33.03 by Mike Seymour
+*-- Author : Ian Knowles
+C-----------------------------------------------------------------------
+ FUNCTION HWUNST(N)
+C-----------------------------------------------------------------------
+C Creates a character string of length 7 equivalent to integer N
+C-----------------------------------------------------------------------
+ INTEGER N,I,M,NN(7)
+ CHARACTER*1 NCHAR(0:9)
+ CHARACTER*7 HWUNST
+ DATA NCHAR/'0','1','2','3','4','5','6','7','8','9'/
+ M=1
+ DO 10 I=7,1,-1
+ NN(I)=MOD(N/M,10)
+ 10 M=M*10
+ WRITE(HWUNST,'(7A1)') (NCHAR(NN(I)),I=1,7)
+ RETURN
+ END
+CDECK ID>, HWUPCM.
+*CMZ :- -26/04/91 11.11.56 by Bryan Webber
+*-- Author : Bryan Webber
+C-----------------------------------------------------------------------
+ FUNCTION HWUPCM(EM0,EM1,EM2)
+C-----------------------------------------------------------------------
+C C.M. MOMENTUM FOR DECAY MASSES EM0 -> EM1 + EM2
+C SET TO -1 BELOW THRESHOLD
+C-----------------------------------------------------------------------
+ DOUBLE PRECISION HWUPCM,EM0,EM1,EM2,EMS,EMD
+ EMS=ABS(EM1+EM2)
+ EMD=ABS(EM1-EM2)
+ IF (EM0.LT.EMS.OR.EM0.LT.EMD) THEN
+ HWUPCM=-1.
+ ELSEIF (EM0.EQ.EMS.OR.EM0.EQ.EMD) THEN
+ HWUPCM=0.
+ ELSE
+ HWUPCM=SQRT((EM0+EMD)*(EM0-EMD)*
+ & (EM0+EMS)*(EM0-EMS))*.5/EM0
+ ENDIF
+ END
+CDECK ID>, HWURAP.
+*CMZ :- -26/04/91 11.11.56 by Bryan Webber
+*-- Author : Bryan Webber
+C-----------------------------------------------------------------------
+ FUNCTION HWURAP(P)
+C-----------------------------------------------------------------------
+C LONGITUDINAL RAPIDITY (SET TO +/-1000 IF TOO LARGE)
+C-----------------------------------------------------------------------
+ DOUBLE PRECISION HWURAP,EMT2,P(5),ZERO
+ PARAMETER (ZERO=0.D0)
+ EMT2=P(1)**2+P(2)**2+P(5)**2
+ IF (P(3).GT.ZERO) THEN
+ IF (EMT2.EQ.ZERO) THEN
+ HWURAP=1000.
+ ELSE
+ HWURAP= 0.5*LOG((P(3)+P(4))**2/EMT2)
+ ENDIF
+ ELSEIF (P(3).LT.ZERO) THEN
+ IF (EMT2.EQ.ZERO) THEN
+ HWURAP=-1000.
+ ELSE
+ HWURAP=-0.5*LOG((P(3)-P(4))**2/EMT2)
+ ENDIF
+ ELSE
+ HWURAP=0.
+ ENDIF
+ END
+CDECK ID>, HWURES.
+*CMZ :- -26/04/91 11.11.56 by Bryan Webber
+*-- Author : Ian Knowles & Bryan Webber
+C-----------------------------------------------------------------------
+ SUBROUTINE HWURES
+C-----------------------------------------------------------------------
+C Using properties of particle I supplied in HWUDAT checks particles
+C and antiparticles have compatible properties and sets SWTEF(I) =
+C ( rep. enhancement factor)^2 - used in cluster decays
+C Finds iso-flavour hadrons and creates pointers for cluster decays.
+C Sets CLDKWT(K) =(2J+1) spin weight normalizing largest value to 1.
+C-----------------------------------------------------------------------
+ INCLUDE 'HERWIG61.INC'
+ INTEGER NMXTMP
+ PARAMETER (NMXTMP=20)
+ DOUBLE PRECISION EPS,WTMX,REMMN,RWTMX,WTMP,RESTMP(91),WTMX2,
+ & REMMN2,WT,CDWTMP(NMXTMP)
+ INTEGER HWUANT,MAPF(89),MAPC(12,12),I,IANT,IABPDG,J,L,N,K,LTMP,
+ & NCDKS,IMN,ITMP,LOCTMP(91),NTMP,NCDTMP(NMXTMP),IMN2
+ EXTERNAL HWUANT
+ PARAMETER (EPS=1.D-6)
+ DATA MAPF/21,31,41,51,61,12,32,42,52,62,13,23,43,53,63,14,24,34,
+ & 44,54,64,15,25,35,45,55,65,16,26,36,46,56,66,111,112,113,122,123,
+ & 133,222,223,233,333,-111,-112,-113,-122,-123,-133,-222,-223,-233,
+ & -333,114,124,134,224,234,334,-114,-124,-134,-224,-234,-334,115,
+ & 125,135,225,235,335,-115,-125,-135,-225,-235,-335,116,126,136,
+ & 226,236,336,-116,-126,-136,-226,-236,-336/
+ DATA MAPC/90,1,2,47,45,44,48,46,49,3,4,5,6,90,7,50,47,45,51,48,52,
+ & 8,9,10,11,12,91,51,48,46,52,49,53,13,14,15,37,40,41,6*0,57,69,81,
+ & 35,37,38,6*0,55,67,79,34,35,36,6*0,54,66,78,38,41,42,6*0,58,70,
+ & 82,36,38,39,6*0,56,68,80,39,42,43,6*0,59,71,83,16,17,18,63,61,60,
+ & 64,62,65,19,20,21,22,23,24,75,73,72,76,74,77,25,26,27,28,29,30,
+ & 87,85,84,88,86,89,31,32,33/
+C Check particle/anti-particle properties are compatible
+ WRITE(6,10)
+ 10 FORMAT(/10X,'Checking consistency of particle properties'/)
+ DO 20 I=10,NRES
+ IF (IDPDG(I).GT.0) THEN
+ IANT=HWUANT(I)
+ IF (IANT.EQ.20) GOTO 20
+ IF (MOD(IDPDG(I)/1000,10).EQ.0.AND.
+ & MOD(IDPDG(I)/100 ,10).NE.0) THEN
+ IF (MOD(IFLAV(I)/10-IFLAV(IANT),10).NE.0.OR.
+ & MOD(IFLAV(I)-IFLAV(IANT)/10,10).NE.0)
+ & WRITE(6,30) RNAME(I),IFLAV(I),IFLAV(IANT)
+ ELSE
+ IF (IFLAV(I)+IFLAV(IANT).NE.0)
+ & WRITE(6,30) RNAME(I),IFLAV(I),IFLAV(IANT)
+ ENDIF
+ IF (ICHRG(I)+ICHRG(IANT).NE.0)
+ & WRITE(6,40) RNAME(I),RNAME(IANT),ICHRG(I),ICHRG(IANT)
+ IF (ABS(RMASS(I)-RMASS(IANT)).GT.EPS)
+ & WRITE(6,50) RNAME(I),RMASS(I),RMASS(IANT)
+ IF (ABS(RLTIM(I)-RLTIM(IANT)).GT.EPS)
+ & WRITE(6,60) RNAME(I),RLTIM(I),RLTIM(IANT)
+ IF (ABS(RSPIN(I)-RSPIN(IANT)).GT.EPS)
+ & WRITE(6,70) RNAME(I),RSPIN(I),RSPIN(IANT)
+ ENDIF
+ 20 CONTINUE
+ 30 FORMAT(10X,A8,' flavour code=',I4,5X,' antiparticle=',I4)
+ 40 FORMAT(10X,2A8,' charge =',I2,7X,' antiparticle=',I2)
+ 50 FORMAT(10X,A8,' mass =',F7.3,2X,' antiparticle=',F7.3)
+ 60 FORMAT(10X,A8,' life time =',E9.3,' antiparticle=',E9.3)
+ 70 FORMAT(10X,A8,' spin =',F3.1,6X,' antiparticle=',F3.1)
+C Compute resonance properties
+ DO 80 I=21,NRES
+C Compute representation weights for hadrons, used in cluster decays
+ IABPDG=ABS(IDPDG(I))
+ J=MOD(IABPDG,10)
+ IF (J.EQ.2.AND.MOD(IABPDG/100,10).LT.MOD(IABPDG/10,10)) THEN
+C Singlet (Lambda-like) baryon
+ SWTEF(I)=SNGWT**2
+ ELSEIF (J.EQ.4) THEN
+C Decuplet baryon
+ SWTEF(I)=DECWT**2
+ ELSEIF(2*(J/2).NE.J) THEN
+C Mesons: identify by spin, angular momentum & radial excitation
+ J=(J-1)/2
+ L= MOD(IABPDG/10000 ,10)
+ N= MOD(IABPDG/100000,10)
+ IF (L.EQ.0.AND.J.EQ.0.AND.N.EQ.0.OR.
+ & L.GT.3.OR. J.GT.4.OR .N.GT.4) THEN
+ SWTEF(I)=1.
+ ELSE
+ SWTEF(I)=REPWT(L,J,N)**2
+ ENDIF
+ ELSE
+C Not recognized
+ SWTEF(I)=1.
+ ENDIF
+ 80 CONTINUE
+C Prepare tables for cluster decays, except flavourless light mesons
+ LTMP=1
+ NCDKS=0
+ DO 120 I=1,89
+C Store particles, flavour MAPF(I), noting highest spin and lowest mass
+ WTMX=0.
+ REMMN=1000.
+ DO 90 J=21,NRES
+ IF (VTOCDK(J).OR.IFLAV(J).NE.MAPF(I)) GOTO 90
+ NCDKS=NCDKS+1
+ IF (NCDKS.GT.NMXCDK) CALL HWWARN('HWURES',101,*999)
+ NCLDK(NCDKS)=J
+ CLDKWT(NCDKS)=TWO*RSPIN(J)+ONE
+ IF (CLDKWT(NCDKS).GT.WTMX) WTMX=CLDKWT(NCDKS)
+ IF (RMASS(J).LT.REMMN) THEN
+ REMMN=RMASS(J)
+ IMN=NCDKS
+ ENDIF
+ 90 CONTINUE
+ IF (NCDKS+1-LTMP.EQ.0) THEN
+ WRITE(6,100) MAPF(I)
+ 100 FORMAT(1X,'No particles exist for a cluster with flavour, ',I4,
+ & ' to decay into')
+ CALL HWWARN('HWURES',51,*120)
+ ENDIF
+C Set scaled spin weights
+ RWTMX=1./WTMX
+ DO 110 J=LTMP,NCDKS
+ 110 CLDKWT(J)=CLDKWT(J)*RWTMX
+C Swap order if lightest hadron of given flavour not first
+ IF (IMN.NE.LTMP) THEN
+ ITMP=NCLDK(LTMP)
+ WTMP=CLDKWT(LTMP)
+ NCLDK(LTMP)=NCLDK(IMN)
+ CLDKWT(LTMP)=CLDKWT(IMN)
+ NCLDK(IMN)=ITMP
+ CLDKWT(IMN)=WTMP
+ ENDIF
+C Set pointers etc
+ LOCTMP(I)=LTMP
+ RESTMP(I)=FLOAT(NCDKS+1-LTMP)
+ LTMP=NCDKS+1
+ 120 CONTINUE
+C Now do flavourless light mesons, allowing for mixing in weights
+ WTMX=0.
+ REMMN=1000.
+ WTMX2=0.
+ REMMN2=1000.
+ NTMP=0
+ DO 140 J=21,NRES
+ IF (VTOCDK(J)) THEN
+ GOTO 140
+C Calculate mixing weight for (|uubar>+|ddbar>)/sqrt(2) component
+ ELSEIF (IFLAV(J).EQ.11) THEN
+ WT=1.
+ ELSEIF (IFLAV(J).EQ.33) THEN
+C eta - eta'
+ IF (J.EQ.22 ) THEN
+ WT=COS(ETAMIX*PIFAC/180.+ATAN(SQRT(TWO)))**2
+ ELSEIF (J.EQ.25 ) THEN
+ WT=SIN(ETAMIX*PIFAC/180.+ATAN(SQRT(TWO)))**2
+C phi - omega
+ ELSEIF (J.EQ.56 ) THEN
+ WT=COS(PHIMIX*PIFAC/180.+ATAN(SQRT(TWO)))**2
+ ELSEIF (J.EQ.24 ) THEN
+ WT=SIN(PHIMIX*PIFAC/180.+ATAN(SQRT(TWO)))**2
+C f'_2 - f_2
+ ELSEIF (J.EQ.58 ) THEN
+ WT=COS(F2MIX *PIFAC/180.+ATAN(SQRT(TWO)))**2
+ ELSEIF (J.EQ.26 ) THEN
+ WT=SIN(F2MIX *PIFAC/180.+ATAN(SQRT(TWO)))**2
+C f_1(1420) - f_1(1285)
+ ELSEIF (J.EQ.57 ) THEN
+ WT=COS(F1MIX *PIFAC/180.+ATAN(SQRT(TWO)))**2
+ ELSEIF (J.EQ.28 ) THEN
+ WT=SIN(F1MIX *PIFAC/180.+ATAN(SQRT(TWO)))**2
+C h_1(1380) - h_1(1170)
+ ELSEIF (J.EQ.289) THEN
+ WT=COS(H1MIX *PIFAC/180.+ATAN(SQRT(TWO)))**2
+ ELSEIF (J.EQ.288) THEN
+ WT=SIN(H1MIX *PIFAC/180.+ATAN(SQRT(TWO)))**2
+C MISSING - f_0(1370)
+ ELSEIF (J.EQ.294) THEN
+ WT=SIN(F0MIX *PIFAC/180.+ATAN(SQRT(TWO)))**2
+C phi_3 - omega_3
+ ELSEIF (J.EQ.396) THEN
+ WT=COS(PH3MIX*PIFAC/180.+ATAN(SQRT(TWO)))**2
+ ELSEIF (J.EQ.395) THEN
+ WT=SIN(PH3MIX*PIFAC/180.+ATAN(SQRT(TWO)))**2
+C eta_2(1645) - eta_2(1870)
+ ELSEIF (J.EQ.397) THEN
+ WT=COS(ET2MIX*PIFAC/180.+ATAN(SQRT(TWO)))**2
+ ELSEIF (J.EQ.398) THEN
+ WT=SIN(ET2MIX*PIFAC/180.+ATAN(SQRT(TWO)))**2
+C MISSING - omega(1600)
+ ELSEIF (J.EQ.399) THEN
+ WT=SIN(OMHMIX*PIFAC/180.+ATAN(SQRT(TWO)))**2
+ ELSE
+ WT=1./3.
+ WRITE(6,130) J
+ 130 FORMAT(1X,'Isoscalar particle ',I3,' not recognised,',
+ & ' no I=0 mixing assumed')
+ ENDIF
+ ELSE
+ GOTO 140
+ ENDIF
+ IF (WT.GT.EPS) THEN
+ NCDKS=NCDKS+1
+ IF (NCDKS.GT.NMXCDK) CALL HWWARN('HWURES',102,*999)
+ NCLDK(NCDKS)=J
+ CLDKWT(NCDKS)=WT*(TWO*RSPIN(J)+ONE)
+ IF (CLDKWT(NCDKS).GT.WTMX) WTMX=CLDKWT(NCDKS)
+ IF (RMASS(J).LT.REMMN) THEN
+ REMMN=RMASS(J)
+ IMN=NCDKS
+ ENDIF
+ ENDIF
+ IF (ONE-WT.GT.EPS) THEN
+ NTMP=NTMP+1
+ IF (NTMP.GT.NMXTMP) CALL HWWARN('HWURES',103,*999)
+ NCDTMP(NTMP)=J
+ CDWTMP(NTMP)=(ONE-WT)*(TWO*RSPIN(J)+ONE)
+ IF (CDWTMP(NTMP).GT.WTMX2) WTMX2=CDWTMP(NTMP)
+ IF (RMASS(J).LT.REMMN2) THEN
+ REMMN2=RMASS(J)
+ IMN2=NTMP
+ ENDIF
+ ENDIF
+ 140 CONTINUE
+ IF (NCDKS+1-LTMP.EQ.0) THEN
+ WRITE(6,100) 11
+ CALL HWWARN('HWURES',52,*160)
+ ENDIF
+C Normalize scaled spin weights
+ RWTMX=1./WTMX
+ DO 150 I=LTMP,NCDKS
+ 150 CLDKWT(I)=CLDKWT(I)*RWTMX
+C Swap order if lightest hadron of flavour 11 not first
+ IF (IMN.NE.LTMP) THEN
+ ITMP=NCLDK(LTMP)
+ WTMP=CLDKWT(LTMP)
+ NCLDK(LTMP)=NCLDK(IMN)
+ CLDKWT(LTMP)=CLDKWT(IMN)
+ NCLDK(IMN)=ITMP
+ CLDKWT(IMN)=WTMP
+ ENDIF
+ 160 IF (NTMP.EQ.0) THEN
+ WRITE(6,100) 33
+ CALL HWWARN('HWURES',53,*180)
+ ENDIF
+ IF (NCDKS+NTMP.GT.NMXCDK) CALL HWWARN('HWURES',104,*999)
+C Store hadrons for |ssbar> channel and normalize their weights
+ RWTMX=1./WTMX2
+ DO 170 I=1,NTMP
+ J=NCDKS+I
+ NCLDK(J)=NCDTMP(I)
+ 170 CLDKWT(J)=CDWTMP(I)*RWTMX
+C Swap order if lightest hadron of flavour 33 not first
+ IF (IMN2.NE.1) THEN
+ ITMP=NCLDK(NCDKS+1)
+ WTMP=CLDKWT(NCDKS+1)
+ NCLDK(NCDKS+1)=NCLDK(NCDKS+IMN2)
+ CLDKWT(NCDKS+1)=CLDKWT(NCDKS+IMN2)
+ NCLDK(NCDKS+IMN2)=ITMP
+ CLDKWT(NCDKS+IMN2)=WTMP
+ ENDIF
+C Set pointers etc
+ 180 LOCTMP(90)=LTMP
+ RESTMP(90)=FLOAT(NCDKS+1-LTMP)
+ LOCTMP(91)=NCDKS+1
+ RESTMP(91)=FLOAT(NTMP)
+C Set pointers to hadrons of given flavours for cluster decays
+ DO 190 I=1,12
+ DO 190 J=1,12
+ K=MAPC(I,J)
+ IF (K.EQ.0) THEN
+ RMIN(I,J)=RMASS(NCLDK(LOCN(I,2)))+RMASS(NCLDK(LOCN(I,2)))+1.D-2
+ ELSE
+ LOCN(I,J)=LOCTMP(K)
+ RESN(I,J)=RESTMP(K)
+ RMIN(I,J)=RMASS(NCLDK(LOCN(I,J)))
+ ENDIF
+ 190 CONTINUE
+ 999 END
+CDECK ID>, HWUROB.
+*CMZ :- -26/04/91 11.11.56 by Bryan Webber
+*-- Author : Bryan Webber
+C-----------------------------------------------------------------------
+ SUBROUTINE HWUROB(R,P,Q)
+C-----------------------------------------------------------------------
+C ROTATES VECTORS BY INVERSE OF ROTATION MATRIX R
+C-----------------------------------------------------------------------
+ DOUBLE PRECISION S1,S2,S3,R(3,3),P(3),Q(3)
+ S1=P(1)*R(1,1)+P(2)*R(2,1)+P(3)*R(3,1)
+ S2=P(1)*R(1,2)+P(2)*R(2,2)+P(3)*R(3,2)
+ S3=P(1)*R(1,3)+P(2)*R(2,3)+P(3)*R(3,3)
+ Q(1)=S1
+ Q(2)=S2
+ Q(3)=S3
+ END
+CDECK ID>, HWUROF.
+*CMZ :- -26/04/91 11.11.56 by Bryan Webber
+*-- Author : Bryan Webber
+C-----------------------------------------------------------------------
+ SUBROUTINE HWUROF(R,P,Q)
+C-----------------------------------------------------------------------
+C ROTATES VECTORS BY ROTATION MATRIX R
+C-----------------------------------------------------------------------
+ DOUBLE PRECISION S1,S2,S3,R(3,3),P(3),Q(3)
+ S1=R(1,1)*P(1)+R(1,2)*P(2)+R(1,3)*P(3)
+ S2=R(2,1)*P(1)+R(2,2)*P(2)+R(2,3)*P(3)
+ S3=R(3,1)*P(1)+R(3,2)*P(2)+R(3,3)*P(3)
+ Q(1)=S1
+ Q(2)=S2
+ Q(3)=S3
+ END
+CDECK ID>, HWUROT.
+*CMZ :- -26/04/91 11.11.56 by Bryan Webber
+*-- Author : Bryan Webber
+C-----------------------------------------------------------------------
+ SUBROUTINE HWUROT(P,CP,SP,R)
+C-----------------------------------------------------------------------
+C R IS ROTATION MATRIX TO GET FROM VECTOR P TO Z AXIS, FOLLOWED BY
+C A ROTATION BY PSI ABOUT Z AXIS, WHERE CP = COS-PSI, SP = SIN-PSI
+C-----------------------------------------------------------------------
+ DOUBLE PRECISION WN,CP,SP,PTCUT,PP,PT,CT,ST,CF,SF,P(3),R(3,3)
+ DATA WN,PTCUT/1.,1.D-20/
+ PT=P(1)**2+P(2)**2
+ PP=P(3)**2+PT
+ IF (PT.LE.PP*PTCUT) THEN
+ CT=SIGN(WN,P(3))
+ ST=0.
+ CF=1.
+ SF=0.
+ ELSE
+ PP=SQRT(PP)
+ PT=SQRT(PT)
+ CT=P(3)/PP
+ ST=PT/PP
+ CF=P(1)/PT
+ SF=P(2)/PT
+ END IF
+ R(1,1)= CP*CF*CT+SP*SF
+ R(1,2)= CP*SF*CT-SP*CF
+ R(1,3)=-CP*ST
+ R(2,1)=-CP*SF+SP*CF*CT
+ R(2,2)= CP*CF+SP*SF*CT
+ R(2,3)=-SP*ST
+ R(3,1)= CF*ST
+ R(3,2)= SF*ST
+ R(3,3)= CT
+ END
+CDECK ID>, HWUSOR.
+*CMZ :- -26/04/91 11.11.56 by Bryan Webber
+*-- Author : Adapted by Bryan Webber
+C-----------------------------------------------------------------------
+ SUBROUTINE HWUSOR(A,N,K,IOPT)
+C-----------------------------------------------------------------------
+C Sort A(N) into ascending order
+C IOPT = 1 : return sorted A and index array K
+C IOPT = 2 : return index array K only
+C-----------------------------------------------------------------------
+ DOUBLE PRECISION A(N),B(500)
+ INTEGER N,I,J,IOPT,K(N),IL(500),IR(500)
+ IF (N.GT.500) CALL HWWARN('HWUSOR',100,*999)
+ IL(1)=0
+ IR(1)=0
+ DO 10 I=2,N
+ IL(I)=0
+ IR(I)=0
+ J=1
+ 2 IF(A(I).GT.A(J)) GOTO 5
+ 3 IF(IL(J).EQ.0) GOTO 4
+ J=IL(J)
+ GOTO 2
+ 4 IR(I)=-J
+ IL(J)=I
+ GOTO 10
+ 5 IF(IR(J).LE.0) GOTO 6
+ J=IR(J)
+ GOTO 2
+ 6 IR(I)=IR(J)
+ IR(J)=I
+ 10 CONTINUE
+ I=1
+ J=1
+ GOTO 8
+ 20 J=IL(J)
+ 8 IF(IL(J).GT.0) GOTO 20
+ 9 K(I)=J
+ B(I)=A(J)
+ I=I+1
+ IF(IR(J)) 12,30,13
+ 13 J=IR(J)
+ GOTO 8
+ 12 J=-IR(J)
+ GOTO 9
+ 30 IF(IOPT.EQ.2) RETURN
+ DO 31 I=1,N
+ 31 A(I)=B(I)
+ 999 END
+CDECK ID>, HWUSQR.
+*CMZ :- -26/04/91 11.11.56 by Bryan Webber
+*-- Author : Bryan Webber
+C-----------------------------------------------------------------------
+ FUNCTION HWUSQR(X)
+C-----------------------------------------------------------------------
+C SQUARE ROOT WITH SIGN RETENTION
+C-----------------------------------------------------------------------
+ DOUBLE PRECISION HWUSQR,X
+ HWUSQR=SIGN(SQRT(ABS(X)),X)
+ END
+CDECK ID>, HWUSTA.
+*CMZ :- -26/04/91 10.18.58 by Bryan Webber
+*-- Author : Bryan Webber
+C-----------------------------------------------------------------------
+ SUBROUTINE HWUSTA(NAME)
+C-----------------------------------------------------------------------
+C MAKES PARTICLE TYPE 'NAME' STABLE
+C-----------------------------------------------------------------------
+ INCLUDE 'HERWIG61.INC'
+ INTEGER IPDG,IWIG
+ CHARACTER*8 NAME
+ CALL HWUIDT(3,IPDG,IWIG,NAME)
+ IF (IWIG.EQ.20) CALL HWWARN('HWUSTA',500,*999)
+ RSTAB(IWIG)=.TRUE.
+ WRITE (6,10) IWIG,NAME
+ 10 FORMAT(/10X,'PARTICLE TYPE',I4,'=',A8,' SET STABLE')
+ 999 END
+CDECK ID>, HWUTAB.
+*CMZ :- -26/04/91 11.11.56 by Bryan Webber
+*-- Author : Adapted by Bryan Webber
+C-----------------------------------------------------------------------
+ FUNCTION HWUTAB(F,A,NN,X,MM)
+C-----------------------------------------------------------------------
+C MODIFIED CERN INTERPOLATION ROUTINE DIVDIF
+C-----------------------------------------------------------------------
+ IMPLICIT NONE
+ INTEGER NN,MM,MMAX,N,M,MPLUS,IX,IY,MID,NPTS,IP,I,J,L,ISUB
+ DOUBLE PRECISION HWUTAB,SUM,X,F(NN),A(NN),T(20),D(20)
+ LOGICAL EXTRA
+ DATA MMAX/10/
+ N=NN
+ M=MIN(MM,MMAX,N-1)
+ MPLUS=M+1
+ IX=0
+ IY=N+1
+ IF (A(1).GT.A(N)) GOTO 4
+ 1 MID=(IX+IY)/2
+ IF (X.GE.A(MID)) GOTO 2
+ IY=MID
+ GOTO 3
+ 2 IX=MID
+ 3 IF (IY-IX.GT.1) GOTO 1
+ GOTO 7
+ 4 MID=(IX+IY)/2
+ IF (X.LE.A(MID)) GOTO 5
+ IY=MID
+ GOTO 6
+ 5 IX=MID
+ 6 IF (IY-IX.GT.1) GOTO 4
+ 7 NPTS=M+2-MOD(M,2)
+ IP=0
+ L=0
+ GOTO 9
+ 8 L=-L
+ IF (L.GE.0) L=L+1
+ 9 ISUB=IX+L
+ IF ((1.LE.ISUB).AND.(ISUB.LE.N)) GOTO 10
+ NPTS=MPLUS
+ GOTO 11
+ 10 IP=IP+1
+ T(IP)=A(ISUB)
+ D(IP)=F(ISUB)
+ 11 IF (IP.LT.NPTS) GOTO 8
+ EXTRA=NPTS.NE.MPLUS
+ DO 14 L=1,M
+ IF (.NOT.EXTRA) GOTO 12
+ ISUB=MPLUS-L
+ D(M+2)=(D(M+2)-D(M))/(T(M+2)-T(ISUB))
+ 12 I=MPLUS
+ DO 13 J=L,M
+ ISUB=I-L
+ D(I)=(D(I)-D(I-1))/(T(I)-T(ISUB))
+ I=I-1
+ 13 CONTINUE
+ 14 CONTINUE
+ SUM=D(MPLUS)
+ IF (EXTRA) SUM=0.5*(SUM+D(M+2))
+ J=M
+ DO 15 L=1,M
+ SUM=D(J)+(X-T(J))*SUM
+ J=J-1
+ 15 CONTINUE
+ HWUTAB=SUM
+ END
+CDECK ID>, HWUTIM.
+*CMZ :- -26/04/91 11.38.43 by Federico Carminati
+*-- Author : Federico Carminati
+C-----------------------------------------------------------------------
+c-jgc SUBROUTINE HWUTIM(TRES)
+C-----------------------------------------------------------------------
+c-jgc CALL TIMEL(TRES)
+c-jgc END
+CDECK ID>, HWVDIF.
+*CMZ :- -26/04/91 11.11.56 by Bryan Webber
+*-- Author : Bryan Webber
+C-----------------------------------------------------------------------
+ SUBROUTINE HWVDIF(N,P,Q,R)
+C-----------------------------------------------------------------------
+C VECTOR DIFFERENCE
+C-----------------------------------------------------------------------
+ DOUBLE PRECISION P(N),Q(N),R(N)
+ INTEGER N,I
+ DO 10 I=1,N
+ 10 R(I)=P(I)-Q(I)
+ END
+CDECK ID>, HWVDOT.
+*CMZ :- -26/04/91 11.11.56 by Bryan Webber
+*-- Author : Bryan Webber
+C-----------------------------------------------------------------------
+ FUNCTION HWVDOT(N,P,Q)
+C-----------------------------------------------------------------------
+C VECTOR DOT PRODUCT
+C-----------------------------------------------------------------------
+ DOUBLE PRECISION HWVDOT,PQ,P(N),Q(N)
+ INTEGER N,I
+ PQ=0.
+ DO 10 I=1,N
+ 10 PQ=PQ+P(I)*Q(I)
+ HWVDOT=PQ
+ END
+CDECK ID>, HWVEQU.
+*CMZ :- -26/04/91 11.11.56 by Bryan Webber
+*-- Author : Bryan Webber
+C-----------------------------------------------------------------------
+ SUBROUTINE HWVEQU(N,P,Q)
+C-----------------------------------------------------------------------
+C VECTOR EQUALITY
+C-----------------------------------------------------------------------
+ DOUBLE PRECISION P(N),Q(N)
+ INTEGER N,I
+ DO 10 I=1,N
+ 10 Q(I)=P(I)
+ END
+CDECK ID>, HWVSCA.
+*CMZ :- -26/04/91 11.11.56 by Bryan Webber
+*-- Author : Bryan Webber
+C-----------------------------------------------------------------------
+ SUBROUTINE HWVSCA(N,C,P,Q)
+C-----------------------------------------------------------------------
+C VECTOR TIMES SCALAR
+C-----------------------------------------------------------------------
+ DOUBLE PRECISION C,P(N),Q(N)
+ INTEGER N,I
+ DO 10 I=1,N
+ 10 Q(I)=C*P(I)
+ END
+CDECK ID>, HWVSUM.
+*CMZ :- -26/04/91 11.11.56 by Bryan Webber
+*-- Author : Bryan Webber
+C-----------------------------------------------------------------------
+ SUBROUTINE HWVSUM(N,P,Q,R)
+C-----------------------------------------------------------------------
+C VECTOR SUM
+C-----------------------------------------------------------------------
+ DOUBLE PRECISION P(N),Q(N),R(N)
+ INTEGER N,I
+ DO 10 I=1,N
+ 10 R(I)=P(I)+Q(I)
+ END
+CDECK ID>, HWVZRI.
+*CMZ :- -05/02/98 11.11.56 by Bryan Webber
+*-- Author : Bryan Webber
+C-----------------------------------------------------------------------
+ SUBROUTINE HWVZRI(N,IP)
+C-----------------------------------------------------------------------
+C ZERO INTEGER VECTOR
+C-----------------------------------------------------------------------
+ INTEGER N,IP(N),I
+ DO 10 I=1,N
+ 10 IP(I)=0
+ END
+CDECK ID>, HWVZRO.
+*CMZ :- -26/04/91 11.11.56 by Bryan Webber
+*-- Author : Bryan Webber
+C-----------------------------------------------------------------------
+ SUBROUTINE HWVZRO(N,P)
+C-----------------------------------------------------------------------
+C ZERO VECTOR
+C-----------------------------------------------------------------------
+ DOUBLE PRECISION P(N)
+ INTEGER N,I
+ DO 10 I=1,N
+ 10 P(I)=0D0
+ END
+CDECK ID>, HWWARN.
+*CMZ :- -26/04/91 10.18.58 by Bryan Webber
+*-- Author : Bryan Webber
+C-----------------------------------------------------------------------
+ SUBROUTINE HWWARN(SUBRTN,ICODE,*)
+C-----------------------------------------------------------------------
+C DEALS WITH ERRORS DURING EXECUTION
+C SUBRTN = NAME OF CALLING SUBROUTINE
+C ICODE = ERROR CODE: - -1 NONFATAL, KILL EVENT & PRINT NOTHING
+C 0- 49 NONFATAL, PRINT WARNING & CONTINUE
+C 50- 99 NONFATAL, PRINT WARNING & JUMP
+C 100-199 NONFATAL, DUMP & KILL EVENT
+C 200-299 FATAL, TERMINATE RUN
+C 300-399 FATAL, DUMP EVENT & TERMINATE RUN
+C 400-499 FATAL, DUMP EVENT & STOP DEAD
+C 500- FATAL, STOP DEAD WITH NO DUMP
+C-----------------------------------------------------------------------
+ INCLUDE 'HERWIG61.INC'
+ INTEGER ICODE
+ CHARACTER*6 SUBRTN
+ IF (ICODE.GE.0) WRITE (6,10) SUBRTN,ICODE
+ 10 FORMAT(/' HWWARN CALLED FROM SUBPROGRAM ',A6,': CODE =',I4)
+ IF (ICODE.LT.0) THEN
+ IERROR=ICODE
+ RETURN 1
+ ELSEIF (ICODE.LT.100) THEN
+ WRITE (6,20) NEVHEP,NRN,EVWGT
+ 20 FORMAT(' EVENT',I8,': SEEDS =',I11,' &',I11,
+ &' WEIGHT =',E11.4/' EVENT SURVIVES. EXECUTION CONTINUES')
+ IF (ICODE.GT.49) RETURN 1
+ ELSEIF (ICODE.LT.200) THEN
+ WRITE (6,30) NEVHEP,NRN,EVWGT
+ 30 FORMAT(' EVENT',I8,': SEEDS =',I11,' &',I11,
+ &' WEIGHT =',E11.4/' EVENT KILLED. EXECUTION CONTINUES')
+ IERROR=ICODE
+ RETURN 1
+ ELSEIF (ICODE.LT.300) THEN
+ WRITE (6,40)
+ 40 FORMAT(' EVENT SURVIVES. RUN ENDS GRACEFULLY')
+ CALL HWEFIN
+c-jgc CALL HWAEND
+ STOP
+ ELSEIF (ICODE.LT.400) THEN
+ WRITE (6,50)
+ 50 FORMAT(' EVENT KILLED: DUMP FOLLOWS. RUN ENDS GRACEFULLY')
+ IERROR=ICODE
+ CALL HWUEPR
+ CALL HWUBPR
+ CALL HWEFIN
+c-jgc CALL HWAEND
+ STOP
+ ELSEIF (ICODE.LT.500) THEN
+ WRITE (6,60)
+ 60 FORMAT(' EVENT KILLED: DUMP FOLLOWS. RUN STOPS DEAD')
+ IERROR=ICODE
+ CALL HWUEPR
+ CALL HWUBPR
+ STOP
+ ELSE
+ WRITE (6,70)
+ 70 FORMAT(' RUN CANNOT CONTINUE')
+ STOP
+ ENDIF
+ END
+CDECK ID>, IEUPDG.
+*CMZ :- -28/01/92 12.34.44 by Mike Seymour
+*-- Author : Luca Stanco
+C-----------------------------------------------------------------------
+ FUNCTION IEUPDG(I)
+C-----------------------------------------------------------------------
+C DUMMY SUBROUTINE: DELETE AND SET BDECAY='EURO'
+C IN MAIN PROGRAM IF YOU USE EURODEC DECAY PACKAGE
+C-----------------------------------------------------------------------
+ INTEGER IEUPDG,I
+ WRITE (6,10)
+ 10 FORMAT(/10X,'IEUPDG CALLED BUT NOT LINKED')
+ IEUPDG=0
+ STOP
+ END
+CDECK ID>, IPDGEU.
+*CMZ :- -28/01/92 12.34.44 by Mike Seymour
+*-- Author : Luca Stanco
+C-----------------------------------------------------------------------
+ FUNCTION IPDGEU(I)
+C-----------------------------------------------------------------------
+C DUMMY SUBROUTINE: DELETE AND SET BDECAY='EURO'
+C IN MAIN PROGRAM IF YOU USE EURODEC DECAY PACKAGE
+C-----------------------------------------------------------------------
+ INTEGER IPDGEU,I
+ WRITE (6,10)
+ 10 FORMAT(/10X,'IPDGEU CALLED BUT NOT LINKED')
+ IPDGEU=0
+ STOP
+ END
+CDECK ID>, PDFSET.
+*CMZ :- -26/04/91 11.11.54 by Bryan Webber
+*-- Author : Bryan Webber
+C----------------------------------------------------------------------
+C SUBROUTINE PDFSET(PARM,VAL)
+C----------------------------------------------------------------------
+C DUMMY SUBROUTINE: DELETE AND SET MODPDF(I)
+C IN MAIN PROGRAM IF YOU USE PDFLIB CERN-LIBRARY
+C PACKAGE FOR NUCLEON STRUCTURE FUNCTIONS
+C----------------------------------------------------------------------
+C DOUBLE PRECISION VAL(20)
+C CHARACTER*20 PARM(20)
+C WRITE (6,10)
+C 10 FORMAT(/10X,'PDFSET CALLED BUT NOT LINKED')
+C STOP
+C END
+CDECK ID>, QQINIT.
+*CMZ :- -28/01/92 12.34.44 by Mike Seymour
+*-- Author : Luca Stanco
+C-----------------------------------------------------------------------
+ SUBROUTINE QQINIT(QQLERR)
+C-----------------------------------------------------------------------
+C DUMMY SUBROUTINE: DELETE AND SET BDECAY='CLEO'
+C IN MAIN PROGRAM IF YOU USE CLEO DECAY PACKAGE
+C-----------------------------------------------------------------------
+ LOGICAL QQLERR
+ WRITE (6,10)
+ 10 FORMAT(/10X,'QQINIT CALLED BUT NOT LINKED')
+ STOP
+ END
+CDECK ID>, QQLMAT.
+*CMZ :- -28/01/92 12.34.44 by Mike Seymour
+*-- Author : Luca Stanco
+C-----------------------------------------------------------------------
+ INTEGER FUNCTION QQLMAT(IDL,NDIR)
+C-----------------------------------------------------------------------
+C. QQLMAT - Given a particle flavor (KF), converts it to QQ particle number
+C. (KF = IDPDG code)
+C.
+C. Inputs : IDL (input particle code)
+C NDIR = 1 LUND --> QQ
+C NDIR = 2 QQ --> LUND
+C
+C. Outputs : QQLMAT (output particle code)
+C.
+C-----------------------------------------------------------------------
+ IMPLICIT NONE
+C-- Calling variable
+ INTEGER IDL,NDIR
+C-- External declaration
+C-- Local variables
+ INTEGER AKF(321),I
+ DATA (AKF(I), I=1,151) /
+ + 0, 0, 0, 0, 0, 0, 0, 21, -6, -5,
+ + -4, -3, -1, -2, 6, 5, 4, 3, 1, 2,
+ + 0,
+ + 22, 23, 24, -24, 90, 0, 11, -11, 12, -12,
+ + 13, -13, 14, -14, 15, -15, 16, -16,20313,-20313,
+ + 211, -211, 321, -321, 311, -311, 421, -421, 411, -411,
+ + 431, -431, -521, 521, -511, 511, -531, 531, -541, 541,
+ + 621, -621, 611, -611, 631, -631, 641, -641, 651, -651,
+ + 111, 221, 331, 441,20551, 661, 310, 130,10313,-10313,
+ + 213, -213, 323, -323, 313, -313, 423, -423, 413, -413,
+ + 433, -433, -523, 523, -513, 513, -533, 533, -543, 543,
+ + 623, -623, 613, -613, 633, -633, 643, -643, 653, -653,
+ + 113, 223, 333, 443, 553, 136, 20553, 30553, 40553, 551,
+ + 10553, 555, 10551,70553,10555, 0, 20213, 20113, -20213, 10441,
+ + 10443, 445, 8*0,
+ + 3122, -3122, 4122, -4122, 4232, -4232, 4132, -4132, 3212, -3212/
+ DATA (AKF(I), I=152,321) /
+ + 4212, -4212, 4322, -4322, 4312, -4312, 2212, -2212, 3222, -3222,
+ + 4222, -4222, 2112, -2112, 3112, -3112, 4112, -4112, 3322, -3322,
+ + 3312, -3312, 4332, -4332, 6*0,
+ + 3214, -3214, 4214, -4214, 4324, -4324, 4314, -4314, 2214, -2214,
+ + 3224, -3224, 4224, -4224, 2114, -2114, 3114, -3114, 4114, -4114,
+ + 3324, -3324, 3314, -3314, 4334, -4334, 4*0,
+ + 0, 0, 2224, -2224, 1114, -1114, 3334, -3334, 0, 0,
+ + 10323, -10323, 20323, -20323, 6*0,
+ + 30443, 0, 0, 0, 70443, 50553, 60553, 80553, 20443, 0,
+ + 10411, 20413, 10413, 415,
+ + -10411,-20413,-10413,-415,
+ + 10421, 20423, 10423, 425,
+ + -10421,-20423,-10423,-425,
+ + 10431, 20433, 10433, 435,
+ + -10431,-20433,-10433,-435, 0,0,0,0,0,0,
+ + 10111, 10211,-10211, 115, 215, -215,10221,10331,20223,20333,
+ + 225, 335, 10223, 10333, 10113, 10213,-10213, 33*0 /
+ IF(NDIR.EQ.1) THEN
+ DO 10 I=1,321
+ IF (IDL.EQ.AKF(I)) THEN
+ QQLMAT=I-21
+ RETURN
+ ENDIF
+ 10 CONTINUE
+ WRITE(6,20) IDL
+ 20 FORMAT(1X,'Lund code particle ',I6,' not recognized')
+ ELSEIF(NDIR.EQ.2) THEN
+ QQLMAT = AKF(IDL+21)
+ ENDIF
+ RETURN
+ END
+CDECK ID>, STRUCTM.
+*CMZ :S E26/04/91 11.11.54 by Bryan Webber
+*-- Author : Bryan Webber
+C-----------------------------------------------------------------------
+C SUBROUTINE STRUCTM(X,QSCA,UPV,DNV,USEA,DSEA,STR,CHM,BOT,TOP,GLU)
+C-----------------------------------------------------------------------
+C DUMMY SUBROUTINE: DELETE IF YOU USE PDFLIB CERN-LIBRARY
+C PACKAGE FOR NUCLEON STRUCTURE FUNCTIONS
+C-----------------------------------------------------------------------
+C DOUBLE PRECISION X,QSCA,UPV,DNV,USEA,DSEA,STR,CHM,BOT,TOP,GLU
+C WRITE (6,10)
+C 10 FORMAT(/10X,'STRUCTM CALLED BUT NOT LINKED')
+C STOP
+C END
+C-----------------------------------------------------------------------
+C...SaSgam version 2 - parton distributions of the photon
+C...by Gerhard A. Schuler and Torbjorn Sjostrand
+C...For further information see Z. Phys. C68 (1995) 607
+C...and CERN-TH/96-04 and LU TP 96-2.
+C...Program last changed on 18 January 1996.
+C
+C!!!Note that one further call parameter - IP2 - has been added
+C!!!to the SASGAM argument list compared with version 1.
+C
+C...The user should only need to call the SASGAM routine,
+C...which in turn calls the auxiliary routines SASVMD, SASANO,
+C...SASBEH and SASDIR. The package is self-contained.
+C
+C...One particular aspect of these parametrizations is that F2 for
+C...the photon is not obtained just as the charge-squared-weighted
+C...sum of quark distributions, but differ in the treatment of
+C...heavy flavours (in F2 the DIS relation W2 = Q2*(1-x)/x restricts
+C...the kinematics range of heavy-flavour production, but the same
+C...kinematics is not relevant e.g. for jet production) and, for the
+C...'MSbar' fits, in the addition of a Cgamma term related to the
+C...separation of direct processes. Schematically:
+C...PDF = VMD (rho, omega, phi) + anomalous (d, u, s, c, b).
+C...F2 = VMD (rho, omega, phi) + anomalous (d, u, s) +
+C... Bethe-Heitler (c, b) (+ Cgamma (d, u, s)).
+C...The J/psi and Upsilon states have not been included in the VMD sum,
+C...but low c and b masses in the other components should compensate
+C...for this in a duality sense.
+C
+C...The calling sequence is the following:
+C CALL SASGAM(ISET,X,Q2,P2,IP2,F2GM,XPDFGM)
+C...with the following declaration statement:
+C DIMENSION XPDFGM(-6:6)
+C...and, optionally, further information in:
+C COMMON/SASCOM/XPVMD(-6:6),XPANL(-6:6),XPANH(-6:6),XPBEH(-6:6),
+C &XPDIR(-6:6)
+C COMMON/SASVAL/VXPVMD(-6:6),VXPANL(-6:6),VXPANH(-6:6),VXPDGM(-6:6)
+C...Input: ISET = 1 : SaS set 1D ('DIS', Q0 = 0.6 GeV)
+C = 2 : SaS set 1M ('MSbar', Q0 = 0.6 GeV)
+C = 3 : SaS set 2D ('DIS', Q0 = 2 GeV)
+C = 4 : SaS set 2M ('MSbar', Q0 = 2 GeV)
+C X : x value.
+C Q2 : Q2 value.
+C P2 : P2 value; should be = 0. for an on-shell photon.
+C IP2 : scheme used to evaluate off-shell anomalous component.
+C = 0 : recommended default, see = 7.
+C = 1 : dipole dampening by integration; very time-consuming.
+C = 2 : P_0^2 = max( Q_0^2, P^2 )
+C = 3 : P'_0^2 = Q_0^2 + P^2.
+C = 4 : P_{eff} that preserves momentum sum.
+C = 5 : P_{int} that preserves momentum and average
+C evolution range.
+C = 6 : P_{eff}, matched to P_0 in P2 -> Q2 limit.
+C = 7 : P_{eff}, matched to P_0 in P2 -> Q2 limit.
+C...Output: F2GM : F2 value of the photon (including factors of alpha_em).
+C XPFDGM : x times parton distribution functions of the photon,
+C with elements 0 = g, 1 = d, 2 = u, 3 = s, 4 = c, 5 = b,
+C 6 = t (always empty!), - for antiquarks (result is same).
+C...The breakdown by component is stored in the commonblock SASCOM,
+C with elements as above.
+C XPVMD : rho, omega, phi VMD part only of output.
+C XPANL : d, u, s anomalous part only of output.
+C XPANH : c, b anomalous part only of output.
+C XPBEH : c, b Bethe-Heitler part only of output.
+C XPDIR : Cgamma (direct contribution) part only of output.
+C...The above arrays do not distinguish valence and sea contributions,
+C...although this information is available internally. The additional
+C...commonblock SASVAL provides the valence part only of the above
+C...distributions. Array names VXPVMD, VXPANL and VXPANH correspond
+C...to XPVMD, XPANL and XPANH, while XPBEH and XPDIR are valence only
+C...and therefore not given doubly. VXPDGM gives the sum of valence
+C...parts, and so matches XPDFGM. The difference, i.e. XPVMD-VXPVMD
+C...and so on, gives the sea part only.
+C
+ SUBROUTINE SASGAM(ISET,X,Q2,P2,IP2,F2GM,XPDFGM)
+C...Purpose: to construct the F2 and parton distributions of the photon
+C...by summing homogeneous (VMD) and inhomogeneous (anomalous) terms.
+C...For F2, c and b are included by the Bethe-Heitler formula;
+C...in the 'MSbar' scheme additionally a Cgamma term is added.
+ DIMENSION XPDFGM(-6:6)
+ COMMON/SASCOM/XPVMD(-6:6),XPANL(-6:6),XPANH(-6:6),XPBEH(-6:6),
+ &XPDIR(-6:6)
+ COMMON/SASVAL/VXPVMD(-6:6),VXPANL(-6:6),VXPANH(-6:6),VXPDGM(-6:6)
+ SAVE /SASCOM/,/SASVAL/
+C
+C...Temporary array.
+ DIMENSION XPGA(-6:6), VXPGA(-6:6)
+C...Charm and bottom masses (low to compensate for J/psi etc.).
+ DATA PMC/1.3/, PMB/4.6/
+C...alpha_em and alpha_em/(2*pi).
+ DATA AEM/0.007297/, AEM2PI/0.0011614/
+C...Lambda value for 4 flavours.
+ DATA ALAM/0.20/
+C...Mixture u/(u+d), = 0.5 for incoherent and = 0.8 for coherent sum.
+ DATA FRACU/0.8/
+C...VMD couplings f_V**2/(4*pi).
+ DATA FRHO/2.20/, FOMEGA/23.6/, FPHI/18.4/
+C...Masses for rho (=omega) and phi.
+ DATA PMRHO/0.770/, PMPHI/1.020/
+C...Number of points in integration for IP2=1.
+ DATA NSTEP/100/
+C
+C...Reset output.
+ F2GM=0.
+ DO 100 KFL=-6,6
+ XPDFGM(KFL)=0.
+ XPVMD(KFL)=0.
+ XPANL(KFL)=0.
+ XPANH(KFL)=0.
+ XPBEH(KFL)=0.
+ XPDIR(KFL)=0.
+ VXPVMD(KFL)=0.
+ VXPANL(KFL)=0.
+ VXPANH(KFL)=0.
+ VXPDGM(KFL)=0.
+ 100 CONTINUE
+C
+C...Check that input sensible.
+ IF(ISET.LE.0.OR.ISET.GE.5) THEN
+ WRITE(*,*) ' FATAL ERROR: SaSgam called for unknown set'
+ WRITE(*,*) ' ISET = ',ISET
+ STOP
+ ENDIF
+ IF(X.LE.0..OR.X.GT.1.) THEN
+ WRITE(*,*) ' FATAL ERROR: SaSgam called for unphysical x'
+ WRITE(*,*) ' X = ',X
+ STOP
+ ENDIF
+C
+C...Set Q0 cut-off parameter as function of set used.
+ IF(ISET.LE.2) THEN
+ Q0=0.6
+ ELSE
+ Q0=2.
+ ENDIF
+ Q02=Q0**2
+C
+C...Scale choice for off-shell photon; common factors.
+ Q2A=Q2
+ FACNOR=1.
+ IF(IP2.EQ.1) THEN
+ P2MX=P2+Q02
+ Q2A=Q2+P2*Q02/MAX(Q02,Q2)
+ FACNOR=LOG(Q2/Q02)/NSTEP
+ ELSEIF(IP2.EQ.2) THEN
+ P2MX=MAX(P2,Q02)
+ ELSEIF(IP2.EQ.3) THEN
+ P2MX=P2+Q02
+ Q2A=Q2+P2*Q02/MAX(Q02,Q2)
+ ELSEIF(IP2.EQ.4) THEN
+ P2MX=Q2*(Q02+P2)/(Q2+P2)*EXP(P2*(Q2-Q02)/
+ & ((Q2+P2)*(Q02+P2)))
+ ELSEIF(IP2.EQ.5) THEN
+ P2MXA=Q2*(Q02+P2)/(Q2+P2)*EXP(P2*(Q2-Q02)/
+ & ((Q2+P2)*(Q02+P2)))
+ P2MX=Q0*SQRT(P2MXA)
+ FACNOR=LOG(Q2/P2MXA)/LOG(Q2/P2MX)
+ ELSEIF(IP2.EQ.6) THEN
+ P2MX=Q2*(Q02+P2)/(Q2+P2)*EXP(P2*(Q2-Q02)/
+ & ((Q2+P2)*(Q02+P2)))
+ P2MX=MAX(0.,1.-P2/Q2)*P2MX+MIN(1.,P2/Q2)*MAX(P2,Q02)
+ ELSE
+ P2MXA=Q2*(Q02+P2)/(Q2+P2)*EXP(P2*(Q2-Q02)/
+ & ((Q2+P2)*(Q02+P2)))
+ P2MX=Q0*SQRT(P2MXA)
+ P2MXB=P2MX
+ P2MX=MAX(0.,1.-P2/Q2)*P2MX+MIN(1.,P2/Q2)*MAX(P2,Q02)
+ P2MXB=MAX(0.,1.-P2/Q2)*P2MXB+MIN(1.,P2/Q2)*P2MXA
+ FACNOR=LOG(Q2/P2MXA)/LOG(Q2/P2MXB)
+ ENDIF
+C
+C...Call VMD parametrization for d quark and use to give rho, omega,
+C...phi. Note dipole dampening for off-shell photon.
+ CALL SASVMD(ISET,1,X,Q2A,P2MX,ALAM,XPGA,VXPGA)
+ XFVAL=VXPGA(1)
+ XPGA(1)=XPGA(2)
+ XPGA(-1)=XPGA(-2)
+ FACUD=AEM*(1./FRHO+1./FOMEGA)*(PMRHO**2/(PMRHO**2+P2))**2
+ FACS=AEM*(1./FPHI)*(PMPHI**2/(PMPHI**2+P2))**2
+ DO 110 KFL=-5,5
+ XPVMD(KFL)=(FACUD+FACS)*XPGA(KFL)
+ 110 CONTINUE
+ XPVMD(1)=XPVMD(1)+(1.-FRACU)*FACUD*XFVAL
+ XPVMD(2)=XPVMD(2)+FRACU*FACUD*XFVAL
+ XPVMD(3)=XPVMD(3)+FACS*XFVAL
+ XPVMD(-1)=XPVMD(-1)+(1.-FRACU)*FACUD*XFVAL
+ XPVMD(-2)=XPVMD(-2)+FRACU*FACUD*XFVAL
+ XPVMD(-3)=XPVMD(-3)+FACS*XFVAL
+ VXPVMD(1)=(1.-FRACU)*FACUD*XFVAL
+ VXPVMD(2)=FRACU*FACUD*XFVAL
+ VXPVMD(3)=FACS*XFVAL
+ VXPVMD(-1)=(1.-FRACU)*FACUD*XFVAL
+ VXPVMD(-2)=FRACU*FACUD*XFVAL
+ VXPVMD(-3)=FACS*XFVAL
+C
+ IF(IP2.NE.1) THEN
+C...Anomalous parametrizations for different strategies
+C...for off-shell photons; except full integration.
+C
+C...Call anomalous parametrization for d + u + s.
+ CALL SASANO(-3,X,Q2A,P2MX,ALAM,XPGA,VXPGA)
+ DO 120 KFL=-5,5
+ XPANL(KFL)=FACNOR*XPGA(KFL)
+ VXPANL(KFL)=FACNOR*VXPGA(KFL)
+ 120 CONTINUE
+C
+C...Call anomalous parametrization for c and b.
+ CALL SASANO(4,X,Q2A,P2MX,ALAM,XPGA,VXPGA)
+ DO 130 KFL=-5,5
+ XPANH(KFL)=FACNOR*XPGA(KFL)
+ VXPANH(KFL)=FACNOR*VXPGA(KFL)
+ 130 CONTINUE
+ CALL SASANO(5,X,Q2A,P2MX,ALAM,XPGA,VXPGA)
+ DO 140 KFL=-5,5
+ XPANH(KFL)=XPANH(KFL)+FACNOR*XPGA(KFL)
+ VXPANH(KFL)=VXPANH(KFL)+FACNOR*VXPGA(KFL)
+ 140 CONTINUE
+C
+ ELSE
+C...Special option: loop over flavours and integrate over k2.
+ DO 170 KF=1,5
+ DO 160 ISTEP=1,NSTEP
+ Q2STEP=Q02*(Q2/Q02)**((ISTEP-0.5)/NSTEP)
+ IF((KF.EQ.4.AND.Q2STEP.LT.PMC**2).OR.
+ & (KF.EQ.5.AND.Q2STEP.LT.PMB**2)) GOTO 160
+ CALL SASVMD(0,KF,X,Q2,Q2STEP,ALAM,XPGA,VXPGA)
+ FACQ=AEM2PI*(Q2STEP/(Q2STEP+P2))**2*FACNOR
+ IF(MOD(KF,2).EQ.0) FACQ=FACQ*(8./9.)
+ IF(MOD(KF,2).EQ.1) FACQ=FACQ*(2./9.)
+ DO 150 KFL=-5,5
+ IF(KF.LE.3) XPANL(KFL)=XPANL(KFL)+FACQ*XPGA(KFL)
+ IF(KF.GE.4) XPANH(KFL)=XPANH(KFL)+FACQ*XPGA(KFL)
+ IF(KF.LE.3) VXPANL(KFL)=VXPANL(KFL)+FACQ*VXPGA(KFL)
+ IF(KF.GE.4) VXPANH(KFL)=VXPANH(KFL)+FACQ*VXPGA(KFL)
+ 150 CONTINUE
+ 160 CONTINUE
+ 170 CONTINUE
+ ENDIF
+C
+C...Call Bethe-Heitler term expression for charm and bottom.
+ CALL SASBEH(4,X,Q2,P2,PMC**2,XPBH)
+ XPBEH(4)=XPBH
+ XPBEH(-4)=XPBH
+ CALL SASBEH(5,X,Q2,P2,PMB**2,XPBH)
+ XPBEH(5)=XPBH
+ XPBEH(-5)=XPBH
+C
+C...For MSbar subtraction call C^gamma term expression for d, u, s.
+ IF(ISET.EQ.2.OR.ISET.EQ.4) THEN
+ CALL SASDIR(X,Q2,P2,Q02,XPGA)
+ DO 180 KFL=-5,5
+ XPDIR(KFL)=XPGA(KFL)
+ 180 CONTINUE
+ ENDIF
+C
+C...Store result in output array.
+ DO 190 KFL=-5,5
+ CHSQ=1./9.
+ IF(IABS(KFL).EQ.2.OR.IABS(KFL).EQ.4) CHSQ=4./9.
+ XPF2=XPVMD(KFL)+XPANL(KFL)+XPBEH(KFL)+XPDIR(KFL)
+ IF(KFL.NE.0) F2GM=F2GM+CHSQ*XPF2
+ XPDFGM(KFL)=XPVMD(KFL)+XPANL(KFL)+XPANH(KFL)
+ VXPDGM(KFL)=VXPVMD(KFL)+VXPANL(KFL)+VXPANH(KFL)
+ 190 CONTINUE
+C
+ RETURN
+ END
+C
+C*********************************************************************
+C
+ SUBROUTINE SASVMD(ISET,KF,X,Q2,P2,ALAM,XPGA,VXPGA)
+C...Purpose: to evaluate the VMD parton distributions of a photon,
+C...evolved homogeneously from an initial scale P2 to Q2.
+C...Does not include dipole suppression factor.
+C...ISET is parton distribution set, see above;
+C...additionally ISET=0 is used for the evolution of an anomalous photon
+C...which branched at a scale P2 and then evolved homogeneously to Q2.
+C...ALAM is the 4-flavour Lambda, which is automatically converted
+C...to 3- and 5-flavour equivalents as needed.
+ DIMENSION XPGA(-6:6), VXPGA(-6:6)
+ DATA PMC/1.3/, PMB/4.6/
+C
+C...Reset output.
+ DO 100 KFL=-6,6
+ XPGA(KFL)=0.
+ VXPGA(KFL)=0.
+ 100 CONTINUE
+ KFA=IABS(KF)
+C
+C...Calculate Lambda; protect against unphysical Q2 and P2 input.
+ ALAM3=ALAM*(PMC/ALAM)**(2./27.)
+ ALAM5=ALAM*(ALAM/PMB)**(2./23.)
+ P2EFF=MAX(P2,1.2*ALAM3**2)
+ IF(KFA.EQ.4) P2EFF=MAX(P2EFF,PMC**2)
+ IF(KFA.EQ.5) P2EFF=MAX(P2EFF,PMB**2)
+ Q2EFF=MAX(Q2,P2EFF)
+C
+C...Find number of flavours at lower and upper scale.
+ NFP=4
+ IF(P2EFF.LT.PMC**2) NFP=3
+ IF(P2EFF.GT.PMB**2) NFP=5
+ NFQ=4
+ IF(Q2EFF.LT.PMC**2) NFQ=3
+ IF(Q2EFF.GT.PMB**2) NFQ=5
+C
+C...Find s as sum of 3-, 4- and 5-flavour parts.
+ S=0.
+ IF(NFP.EQ.3) THEN
+ Q2DIV=PMC**2
+ IF(NFQ.EQ.3) Q2DIV=Q2EFF
+ S=S+(6./27.)*LOG(LOG(Q2DIV/ALAM3**2)/LOG(P2EFF/ALAM3**2))
+ ENDIF
+ IF(NFP.LE.4.AND.NFQ.GE.4) THEN
+ P2DIV=P2EFF
+ IF(NFP.EQ.3) P2DIV=PMC**2
+ Q2DIV=Q2EFF
+ IF(NFQ.EQ.5) Q2DIV=PMB**2
+ S=S+(6./25.)*LOG(LOG(Q2DIV/ALAM**2)/LOG(P2DIV/ALAM**2))
+ ENDIF
+ IF(NFQ.EQ.5) THEN
+ P2DIV=PMB**2
+ IF(NFP.EQ.5) P2DIV=P2EFF
+ S=S+(6./23.)*LOG(LOG(Q2EFF/ALAM5**2)/LOG(P2DIV/ALAM5**2))
+ ENDIF
+C
+C...Calculate frequent combinations of x and s.
+ X1=1.-X
+ XL=-LOG(X)
+ S2=S**2
+ S3=S**3
+ S4=S**4
+C
+C...Evaluate homogeneous anomalous parton distributions below or
+C...above threshold.
+ IF(ISET.EQ.0) THEN
+ IF(Q2.LE.P2.OR.(KFA.EQ.4.AND.Q2.LT.PMC**2).OR.
+ &(KFA.EQ.5.AND.Q2.LT.PMB**2)) THEN
+ XVAL = X * 1.5 * (X**2+X1**2)
+ XGLU = 0.
+ XSEA = 0.
+ ELSE
+ XVAL = (1.5/(1.-0.197*S+4.33*S2)*X**2 + (1.5+2.10*S)/
+ & (1.+3.29*S)*X1**2 + 5.23*S/(1.+1.17*S+19.9*S3)*X*X1) *
+ & X**(1./(1.+1.5*S)) * (1.-X**2)**(2.667*S)
+ XGLU = 4.*S/(1.+4.76*S+15.2*S2+29.3*S4) *
+ & X**(-2.03*S/(1.+2.44*S)) * (X1*XL)**(1.333*S) *
+ & ((4.*X**2+7.*X+4.)*X1/3. - 2.*X*(1.+X)*XL)
+ XSEA = S2/(1.+4.54*S+8.19*S2+8.05*S3) *
+ & X**(-1.54*S/(1.+1.29*S)) * X1**(2.667*S) *
+ & ((8.-73.*X+62.*X**2)*X1/9. + (3.-8.*X**2/3.)*X*XL +
+ & (2.*X-1.)*X*XL**2)
+ ENDIF
+C
+C...Evaluate set 1D parton distributions below or above threshold.
+ ELSEIF(ISET.EQ.1) THEN
+ IF(Q2.LE.P2.OR.(KFA.EQ.4.AND.Q2.LT.PMC**2).OR.
+ &(KFA.EQ.5.AND.Q2.LT.PMB**2)) THEN
+ XVAL = 1.294 * X**0.80 * X1**0.76
+ XGLU = 1.273 * X**0.40 * X1**1.76
+ XSEA = 0.100 * X1**3.76
+ ELSE
+ XVAL = 1.294/(1.+0.252*S+3.079*S2) * X**(0.80-0.13*S) *
+ & X1**(0.76+0.667*S) * XL**(2.*S)
+ XGLU = 7.90*S/(1.+5.50*S) * EXP(-5.16*S) *
+ & X**(-1.90*S/(1.+3.60*S)) * X1**1.30 * XL**(0.50+3.*S) +
+ & 1.273 * EXP(-10.*S) * X**0.40 * X1**(1.76+3.*S)
+ XSEA = (0.1-0.397*S2+1.121*S3)/(1.+5.61*S2+5.26*S3) *
+ & X**(-7.32*S2/(1.+10.3*S2)) *
+ & X1**((3.76+15.*S+12.*S2)/(1.+4.*S))
+ XSEA0 = 0.100 * X1**3.76
+ ENDIF
+C
+C...Evaluate set 1M parton distributions below or above threshold.
+ ELSEIF(ISET.EQ.2) THEN
+ IF(Q2.LE.P2.OR.(KFA.EQ.4.AND.Q2.LT.PMC**2).OR.
+ &(KFA.EQ.5.AND.Q2.LT.PMB**2)) THEN
+ XVAL = 0.8477 * X**0.51 * X1**1.37
+ XGLU = 3.42 * X**0.255 * X1**2.37
+ XSEA = 0.
+ ELSE
+ XVAL = 0.8477/(1.+1.37*S+2.18*S2+3.73*S3) * X**(0.51+0.21*S)
+ & * X1**1.37 * XL**(2.667*S)
+ XGLU = 24.*S/(1.+9.6*S+0.92*S2+14.34*S3) * EXP(-5.94*S) *
+ & X**((-0.013-1.80*S)/(1.+3.14*S)) * X1**(2.37+0.4*S) *
+ & XL**(0.32+3.6*S) + 3.42 * EXP(-12.*S) * X**0.255 *
+ & X1**(2.37+3.*S)
+ XSEA = 0.842*S/(1.+21.3*S-33.2*S2+229.*S3) *
+ & X**((0.13-2.90*S)/(1.+5.44*S)) * X1**(3.45+0.5*S) *
+ & XL**(2.8*S)
+ XSEA0 = 0.
+ ENDIF
+C
+C...Evaluate set 2D parton distributions below or above threshold.
+ ELSEIF(ISET.EQ.3) THEN
+ IF(Q2.LE.P2.OR.(KFA.EQ.4.AND.Q2.LT.PMC**2).OR.
+ &(KFA.EQ.5.AND.Q2.LT.PMB**2)) THEN
+ XVAL = X**0.46 * X1**0.64 + 0.76 * X
+ XGLU = 1.925 * X1**2
+ XSEA = 0.242 * X1**4
+ ELSE
+ XVAL = (1.+0.186*S)/(1.-0.209*S+1.495*S2) * X**(0.46+0.25*S)
+ & * X1**((0.64+0.14*S+5.*S2)/(1.+S)) * XL**(1.9*S) +
+ & (0.76+0.4*S) * X * X1**(2.667*S)
+ XGLU = (1.925+5.55*S+147.*S2)/(1.-3.59*S+3.32*S2) *
+ & EXP(-18.67*S) * X**((-5.81*S-5.34*S2)/(1.+29.*S-4.26*S2))
+ & * X1**((2.-5.9*S)/(1.+1.7*S)) * XL**(9.3*S/(1.+1.7*S))
+ XSEA = (0.242-0.252*S+1.19*S2)/(1.-0.607*S+21.95*S2) *
+ & X**(-12.1*S2/(1.+2.62*S+16.7*S2)) * X1**4 * XL**S
+ XSEA0 = 0.242 * X1**4
+ ENDIF
+C
+C...Evaluate set 2M parton distributions below or above threshold.
+ ELSEIF(ISET.EQ.4) THEN
+ IF(Q2.LE.P2.OR.(KFA.EQ.4.AND.Q2.LT.PMC**2).OR.
+ &(KFA.EQ.5.AND.Q2.LT.PMB**2)) THEN
+ XVAL = 1.168 * X**0.50 * X1**2.60 + 0.965 * X
+ XGLU = 1.808 * X1**2
+ XSEA = 0.209 * X1**4
+ ELSE
+ XVAL = (1.168+1.771*S+29.35*S2) * EXP(-5.776*S) *
+ & X**((0.5+0.208*S)/(1.-0.794*S+1.516*S2)) *
+ & X1**((2.6+7.6*S)/(1.+5.*S)) * XL**(5.15*S/(1.+2.*S)) +
+ & (0.965+22.35*S)/(1.+18.4*S) * X * X1**(2.667*S)
+ XGLU = (1.808+29.9*S)/(1.+26.4*S) * EXP(-5.28*S) *
+ & X**((-5.35*S-10.11*S2)/(1.+31.71*S)) *
+ & X1**((2.-7.3*S+4.*S2)/(1.+2.5*S)) *
+ & XL**(10.9*S/(1.+2.5*S))
+ XSEA = (0.209+0.644*S2)/(1.+0.319*S+17.6*S2) *
+ & X**((-0.373*S-7.71*S2)/(1.+0.815*S+11.0*S2)) *
+ & X1**(4.+S) * XL**(0.45*S)
+ XSEA0 = 0.209 * X1**4
+ ENDIF
+ ENDIF
+C
+C...Threshold factors for c and b sea.
+ SLL=LOG(LOG(Q2EFF/ALAM**2)/LOG(P2EFF/ALAM**2))
+ XCHM=0.
+ IF(Q2.GT.PMC**2.AND.Q2.GT.1.001*P2EFF) THEN
+ SCH=MAX(0.,LOG(LOG(PMC**2/ALAM**2)/LOG(P2EFF/ALAM**2)))
+ IF(ISET.EQ.0) THEN
+ XCHM=XSEA*(1.-(SCH/SLL)**2)
+ ELSE
+ XCHM=MAX(0.,XSEA-XSEA0*X1**(2.667*S))*(1.-SCH/SLL)
+ ENDIF
+ ENDIF
+ XBOT=0.
+ IF(Q2.GT.PMB**2.AND.Q2.GT.1.001*P2EFF) THEN
+ SBT=MAX(0.,LOG(LOG(PMB**2/ALAM**2)/LOG(P2EFF/ALAM**2)))
+ IF(ISET.EQ.0) THEN
+ XBOT=XSEA*(1.-(SBT/SLL)**2)
+ ELSE
+ XBOT=MAX(0.,XSEA-XSEA0*X1**(2.667*S))*(1.-SBT/SLL)
+ ENDIF
+ ENDIF
+C
+C...Fill parton distributions.
+ XPGA(0)=XGLU
+ XPGA(1)=XSEA
+ XPGA(2)=XSEA
+ XPGA(3)=XSEA
+ XPGA(4)=XCHM
+ XPGA(5)=XBOT
+ XPGA(KFA)=XPGA(KFA)+XVAL
+ DO 110 KFL=1,5
+ XPGA(-KFL)=XPGA(KFL)
+ 110 CONTINUE
+ VXPGA(KFA)=XVAL
+ VXPGA(-KFA)=XVAL
+C
+ RETURN
+ END
+C
+C*********************************************************************
+C
+ SUBROUTINE SASANO(KF,X,Q2,P2,ALAM,XPGA,VXPGA)
+C...Purpose: to evaluate the parton distributions of the anomalous
+C...photon, inhomogeneously evolved from a scale P2 (where it vanishes)
+C...to Q2.
+C...KF=0 gives the sum over (up to) 5 flavours,
+C...KF<0 limits to flavours up to abs(KF),
+C...KF>0 is for flavour KF only.
+C...ALAM is the 4-flavour Lambda, which is automatically converted
+C...to 3- and 5-flavour equivalents as needed.
+ DIMENSION XPGA(-6:6), VXPGA(-6:6), ALAMSQ(3:5)
+ DATA PMC/1.3/, PMB/4.6/, AEM2PI/0.0011614/
+C
+C...Reset output.
+ DO 100 KFL=-6,6
+ XPGA(KFL)=0.
+ VXPGA(KFL)=0.
+ 100 CONTINUE
+ IF(Q2.LE.P2) RETURN
+ KFA=IABS(KF)
+C
+C...Calculate Lambda; protect against unphysical Q2 and P2 input.
+ ALAMSQ(3)=(ALAM*(PMC/ALAM)**(2./27.))**2
+ ALAMSQ(4)=ALAM**2
+ ALAMSQ(5)=(ALAM*(ALAM/PMB)**(2./23.))**2
+ P2EFF=MAX(P2,1.2*ALAMSQ(3))
+ IF(KF.EQ.4) P2EFF=MAX(P2EFF,PMC**2)
+ IF(KF.EQ.5) P2EFF=MAX(P2EFF,PMB**2)
+ Q2EFF=MAX(Q2,P2EFF)
+ XL=-LOG(X)
+C
+C...Find number of flavours at lower and upper scale.
+ NFP=4
+ IF(P2EFF.LT.PMC**2) NFP=3
+ IF(P2EFF.GT.PMB**2) NFP=5
+ NFQ=4
+ IF(Q2EFF.LT.PMC**2) NFQ=3
+ IF(Q2EFF.GT.PMB**2) NFQ=5
+C
+C...Define range of flavour loop.
+ IF(KF.EQ.0) THEN
+ KFLMN=1
+ KFLMX=5
+ ELSEIF(KF.LT.0) THEN
+ KFLMN=1
+ KFLMX=KFA
+ ELSE
+ KFLMN=KFA
+ KFLMX=KFA
+ ENDIF
+C
+C...Loop over flavours the photon can branch into.
+ DO 110 KFL=KFLMN,KFLMX
+C
+C...Light flavours: calculate t range and (approximate) s range.
+ IF(KFL.LE.3.AND.(KFL.EQ.1.OR.KFL.EQ.KF)) THEN
+ TDIFF=LOG(Q2EFF/P2EFF)
+ S=(6./(33.-2.*NFQ))*LOG(LOG(Q2EFF/ALAMSQ(NFQ))/
+ & LOG(P2EFF/ALAMSQ(NFQ)))
+ IF(NFQ.GT.NFP) THEN
+ Q2DIV=PMB**2
+ IF(NFQ.EQ.4) Q2DIV=PMC**2
+ SNFQ=(6./(33.-2.*NFQ))*LOG(LOG(Q2DIV/ALAMSQ(NFQ))/
+ & LOG(P2EFF/ALAMSQ(NFQ)))
+ SNFP=(6./(33.-2.*(NFQ-1)))*LOG(LOG(Q2DIV/ALAMSQ(NFQ-1))/
+ & LOG(P2EFF/ALAMSQ(NFQ-1)))
+ S=S+(LOG(Q2DIV/P2EFF)/LOG(Q2EFF/P2EFF))*(SNFP-SNFQ)
+ ENDIF
+ IF(NFQ.EQ.5.AND.NFP.EQ.3) THEN
+ Q2DIV=PMC**2
+ SNF4=(6./(33.-2.*4))*LOG(LOG(Q2DIV/ALAMSQ(4))/
+ & LOG(P2EFF/ALAMSQ(4)))
+ SNF3=(6./(33.-2.*3))*LOG(LOG(Q2DIV/ALAMSQ(3))/
+ & LOG(P2EFF/ALAMSQ(3)))
+ S=S+(LOG(Q2DIV/P2EFF)/LOG(Q2EFF/P2EFF))*(SNF3-SNF4)
+ ENDIF
+C
+C...u and s quark do not need a separate treatment when d has been done.
+ ELSEIF(KFL.EQ.2.OR.KFL.EQ.3) THEN
+C
+C...Charm: as above, but only include range above c threshold.
+ ELSEIF(KFL.EQ.4) THEN
+ IF(Q2.LE.PMC**2) GOTO 110
+ P2EFF=MAX(P2EFF,PMC**2)
+ Q2EFF=MAX(Q2EFF,P2EFF)
+ TDIFF=LOG(Q2EFF/P2EFF)
+ S=(6./(33.-2.*NFQ))*LOG(LOG(Q2EFF/ALAMSQ(NFQ))/
+ & LOG(P2EFF/ALAMSQ(NFQ)))
+ IF(NFQ.EQ.5.AND.NFP.EQ.4) THEN
+ Q2DIV=PMB**2
+ SNFQ=(6./(33.-2.*NFQ))*LOG(LOG(Q2DIV/ALAMSQ(NFQ))/
+ & LOG(P2EFF/ALAMSQ(NFQ)))
+ SNFP=(6./(33.-2.*(NFQ-1)))*LOG(LOG(Q2DIV/ALAMSQ(NFQ-1))/
+ & LOG(P2EFF/ALAMSQ(NFQ-1)))
+ S=S+(LOG(Q2DIV/P2EFF)/LOG(Q2EFF/P2EFF))*(SNFP-SNFQ)
+ ENDIF
+C
+C...Bottom: as above, but only include range above b threshold.
+ ELSEIF(KFL.EQ.5) THEN
+ IF(Q2.LE.PMB**2) GOTO 110
+ P2EFF=MAX(P2EFF,PMB**2)
+ Q2EFF=MAX(Q2,P2EFF)
+ TDIFF=LOG(Q2EFF/P2EFF)
+ S=(6./(33.-2.*NFQ))*LOG(LOG(Q2EFF/ALAMSQ(NFQ))/
+ & LOG(P2EFF/ALAMSQ(NFQ)))
+ ENDIF
+C
+C...Evaluate flavour-dependent prefactor (charge^2 etc.).
+ CHSQ=1./9.
+ IF(KFL.EQ.2.OR.KFL.EQ.4) CHSQ=4./9.
+ FAC=AEM2PI*2.*CHSQ*TDIFF
+C
+C...Evaluate parton distributions (normalized to unit momentum sum).
+ IF(KFL.EQ.1.OR.KFL.EQ.4.OR.KFL.EQ.5.OR.KFL.EQ.KF) THEN
+ XVAL= ((1.5+2.49*S+26.9*S**2)/(1.+32.3*S**2)*X**2 +
+ & (1.5-0.49*S+7.83*S**2)/(1.+7.68*S**2)*(1.-X)**2 +
+ & 1.5*S/(1.-3.2*S+7.*S**2)*X*(1.-X)) *
+ & X**(1./(1.+0.58*S)) * (1.-X**2)**(2.5*S/(1.+10.*S))
+ XGLU= 2.*S/(1.+4.*S+7.*S**2) *
+ & X**(-1.67*S/(1.+2.*S)) * (1.-X**2)**(1.2*S) *
+ & ((4.*X**2+7.*X+4.)*(1.-X)/3. - 2.*X*(1.+X)*XL)
+ XSEA= 0.333*S**2/(1.+4.90*S+4.69*S**2+21.4*S**3) *
+ & X**(-1.18*S/(1.+1.22*S)) * (1.-X)**(1.2*S) *
+ & ((8.-73.*X+62.*X**2)*(1.-X)/9. + (3.-8.*X**2/3.)*X*XL +
+ & (2.*X-1.)*X*XL**2)
+C
+C...Threshold factors for c and b sea.
+ SLL=LOG(LOG(Q2EFF/ALAM**2)/LOG(P2EFF/ALAM**2))
+ XCHM=0.
+ IF(Q2.GT.PMC**2.AND.Q2.GT.1.001*P2EFF) THEN
+ SCH=MAX(0.,LOG(LOG(PMC**2/ALAM**2)/LOG(P2EFF/ALAM**2)))
+ XCHM=XSEA*(1.-(SCH/SLL)**3)
+ ENDIF
+ XBOT=0.
+ IF(Q2.GT.PMB**2.AND.Q2.GT.1.001*P2EFF) THEN
+ SBT=MAX(0.,LOG(LOG(PMB**2/ALAM**2)/LOG(P2EFF/ALAM**2)))
+ XBOT=XSEA*(1.-(SBT/SLL)**3)
+ ENDIF
+ ENDIF
+C
+C...Add contribution of each valence flavour.
+ XPGA(0)=XPGA(0)+FAC*XGLU
+ XPGA(1)=XPGA(1)+FAC*XSEA
+ XPGA(2)=XPGA(2)+FAC*XSEA
+ XPGA(3)=XPGA(3)+FAC*XSEA
+ XPGA(4)=XPGA(4)+FAC*XCHM
+ XPGA(5)=XPGA(5)+FAC*XBOT
+ XPGA(KFL)=XPGA(KFL)+FAC*XVAL
+ VXPGA(KFL)=VXPGA(KFL)+FAC*XVAL
+ 110 CONTINUE
+ DO 120 KFL=1,5
+ XPGA(-KFL)=XPGA(KFL)
+ VXPGA(-KFL)=VXPGA(KFL)
+ 120 CONTINUE
+C
+ RETURN
+ END
+C
+C*********************************************************************
+C
+ SUBROUTINE SASBEH(KF,X,Q2,P2,PM2,XPBH)
+C...Purpose: to evaluate the Bethe-Heitler cross section for
+C...heavy flavour production.
+ DATA AEM2PI/0.0011614/
+C
+C...Reset output.
+ XPBH=0.
+ SIGBH=0.
+C
+C...Check kinematics limits.
+ IF(X.GE.Q2/(4.*PM2+Q2+P2)) RETURN
+ W2=Q2*(1.-X)/X-P2
+ BETA2=1.-4.*PM2/W2
+ IF(BETA2.LT.1E-10) RETURN
+ BETA=SQRT(BETA2)
+ RMQ=4.*PM2/Q2
+C
+C...Simple case: P2 = 0.
+ IF(P2.LT.1E-4) THEN
+ IF(BETA.LT.0.99) THEN
+ XBL=LOG((1.+BETA)/(1.-BETA))
+ ELSE
+ XBL=LOG((1.+BETA)**2*W2/(4.*PM2))
+ ENDIF
+ SIGBH=BETA*(8.*X*(1.-X)-1.-RMQ*X*(1.-X))+
+ & XBL*(X**2+(1.-X)**2+RMQ*X*(1.-3.*X)-0.5*RMQ**2*X**2)
+C
+C...Complicated case: P2 > 0, based on approximation of
+C...C.T. Hill and G.G. Ross, Nucl. Phys. B148 (1979) 373
+ ELSE
+ RPQ=1.-4.*X**2*P2/Q2
+ IF(RPQ.GT.1E-10) THEN
+ RPBE=SQRT(RPQ*BETA2)
+ IF(RPBE.LT.0.99) THEN
+ XBL=LOG((1.+RPBE)/(1.-RPBE))
+ XBI=2.*RPBE/(1.-RPBE**2)
+ ELSE
+ RPBESN=4.*PM2/W2+(4.*X**2*P2/Q2)*BETA2
+ XBL=LOG((1.+RPBE)**2/RPBESN)
+ XBI=2.*RPBE/RPBESN
+ ENDIF
+ SIGBH=BETA*(6.*X*(1.-X)-1.)+
+ & XBL*(X**2+(1.-X)**2+RMQ*X*(1.-3.*X)-0.5*RMQ**2*X**2)+
+ & XBI*(2.*X/Q2)*(PM2*X*(2.-RMQ)-P2*X)
+ ENDIF
+ ENDIF
+C
+C...Multiply by charge-squared etc. to get parton distribution.
+ CHSQ=1./9.
+ IF(IABS(KF).EQ.2.OR.IABS(KF).EQ.4) CHSQ=4./9.
+ XPBH=3.*CHSQ*AEM2PI*X*SIGBH
+C
+ RETURN
+ END
+C
+C*********************************************************************
+C
+ SUBROUTINE SASDIR(X,Q2,P2,Q02,XPGA)
+C...Purpose: to evaluate the direct contribution, i.e. the C^gamma term,
+C...as needed in MSbar parametrizations.
+ DIMENSION XPGA(-6:6)
+ DATA AEM2PI/0.0011614/
+C
+C...Reset output.
+ DO 100 KFL=-6,6
+ XPGA(KFL)=0.
+ 100 CONTINUE
+C
+C...Evaluate common x-dependent expression.
+ XTMP = (X**2+(1.-X)**2) * (-LOG(X)) - 1.
+ CGAM = 3.*AEM2PI*X * (XTMP*(1.+P2/(P2+Q02)) + 6.*X*(1.-X))
+C
+C...d, u, s part by simple charge factor.
+ XPGA(1)=(1./9.)*CGAM
+ XPGA(2)=(4./9.)*CGAM
+ XPGA(3)=(1./9.)*CGAM
+C
+C...Also fill for antiquarks.
+ DO 110 KF=1,5
+ XPGA(-KF)=XPGA(KF)
+ 110 CONTINUE
+C
+ RETURN
+ END
+C-----------------------------------------------------------------------
git://git.uio.no / u / mrichter / AliRoot.git / commitdiff