+++ /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
-
git://git.uio.no / u / mrichter / AliRoot.git / commitdiff